Fix (again!) extraction of strongs numbers

bible.el

@@ -30,7 +30,7 @@
 ;; Url: https://github.com/Zacalot/bible-mode
 
 ;; This package uses the `diatheke' program to browse and search
-;; Biblical texts provided by the Sword project.
+;; Biblical texts provided by the Sword project (https://crosswire.org).
 ;; Word study is also supported.
 
 ;;;; Usage
@@ -112,8 +112,8 @@
 
 (defcustom bible-module
   "KJV"
-  "Default book module for Diatheke to query. (For full list of installed
-modules, run `diatheke -b system -l bibliography')"
+  "Customize default book module for Diatheke to query.
+\(For full list of installed modules, run `diatheke -b system -l bibliography'\)"
   :type '(choice (const :tag "None" nil)
                  (string :tag "Module abbreviation (e.g. \"KJV\")"))
 ;;  :local t
@@ -130,8 +130,8 @@ modules, run `diatheke -b system -l bibliography')"
 
 (defcustom bible-sword-query
   "diatheke"
-  "Program used to query sword modules---some version of the sword
-library's diatheke program."
+  "Specify program used to query sword modules.
+Must be some version of the sword library's diatheke program."
   :type '(string :tag "Sword library query executable (e.g. \"/usr/local/bin/diatheke\").")
   :local nil
   :group 'bible)
@@ -141,7 +141,7 @@ library's diatheke program."
   ;; AbbottSmithStrongs now has both links to lemmas and definitions
   ;; keyed by lemma. So we only need the AbbottSmithStrongs lexicon
   ;; and not the AbbottSmith lexicon.
-  "AbbottSmithStrongs" 
+  "AbbottSmithStrongs"
   "Lexicon used for displaying definitions of Greek words using Strong's codes."
   :type '(string :tag "Lexicon module (e.g. \"StrongsRealGreek\").")
   :local nil
@@ -181,9 +181,9 @@ which are of the form
 ;; correctly, so stick with the following.
 (defcustom bible-hebrew-lexicon
   "BDBGlosses_Strongs" ; This seems to work
-  "Lexicon used for displaying definitions of Hebrew words using Strong's
-codes. Note that changing this may require changing some code. See
-bible--display-lemma-hebrew."
+  "Specify Lexicon used to display definitions of Hebrew words.
+Note that changing this may require changing some code.
+See `bible--display-lemma-hebrew'."
   :type '(string :tag "Lexicon module (e.g. \"BDBGlosses_Strongs\")")
   :local nil
   :group 'bible)
@@ -198,8 +198,8 @@ bible--display-lemma-hebrew."
 
 (defcustom bible-word-study-enabled
   nil
-  "Display original language Lemma words if present in module 
-(e.g. in KJV New Testament)."
+  "Display original language Lemma words if present in module.
+\(KJV New Testament has this.\)"
   :type 'boolean
   :local t
   :group 'bible)
@@ -242,7 +242,7 @@ bible--display-lemma-hebrew."
     ("Haggai"		. 2)	("Zechariah"		. 14)	("Malachi"		. 4)
     ;; New Testament
     ("Matthew"		. 28)	("Mark"			. 16)	("Luke"			. 24)	("John"			. 21)
-    ("Acts"		. 28)	("Romans"		. 16)	
+    ("Acts"		. 28)	("Romans"		. 16)
     ("I Corinthians"	. 16)	("II Corinthians" 	. 13)
     ("1 Corinthians"	. 16)	("2 Corinthians" 	. 13)
     ("Galatians"	. 6)	("Ephesians"		. 6)	("Philippians"		. 4)	("Colossians"		. 4)
@@ -550,9 +550,9 @@ This command is run by clicking on text, not directly by the user."
 (define-key bible-morph-keymap (kbd "RET")
 	    (lambda ()
 	      (interactive)
-;;;	      (let ((thing (thing-at-point 'word)))
-;;;		(message "thing at point: %s" thing)
-;;;		(message "morph property %s" (get-text-property 0 'field thing))
+;;	      (let ((thing (thing-at-point 'word)))
+;;		(message "thing at point: %s" thing)
+;;		(message "morph property %s" (get-text-property 0 'field thing))
 		))
 
 ;;;; Modes
@@ -709,7 +709,7 @@ Genesis 1:1 is used."
   (bible-open bible--current-book-name bible--current-chapter))
 
 (defun bible-search (query)
-  "Search for a QUERY: a word or phrase.  
+  "Search for a QUERY: a word or phrase.
 Asks the user for type of search: either `lucene', `phrase', `regex'
 or `multiword'.  `lucene' is the default search.
 
@@ -730,7 +730,7 @@ Create a new `bible' buffer positioned at the selected verse."
          verse)
     (string-match bible--verse-regexp text)
     (setq text (match-string 0 text))
-    (message "Following verse result: %s" text)
+;;    (message "Following verse result: %s" text)
     (string-match "I?I?I? ?[A-Z]?[a-z]* " text)
     (setq book (match-string 0 text))
     (string-match "[0-9]?[0-9]?[0-9]?:" text)
@@ -800,8 +800,8 @@ Handle abbreviations from lexicon module (AbbottSmith)."
 ;; Can we avoid returning (buffer-string) and just use whatever buffer is current?
 ;;
 (defun bible--exec-diatheke (query &optional filter format module)
-  "Execute `diatheke' with specified QUERY options, returning output
-buffer. FILTER is the Diatheke filter argument. FORMAT is either plain
+  "Execute `diatheke' with specified QUERY options, returning buffer.
+FILTER is the Diatheke filter argument. FORMAT is either plain
 or the default of internal. MODULE is the text module to use."
   (let ((module (or module bible-module)))
     (with-temp-buffer
@@ -818,10 +818,9 @@ or the default of internal. MODULE is the text module to use."
 
 
 (defun bible--diatheke-search (query searchtype &optional format module)
-  "Execute `diatheke' for searches. Requires the search query and the
-search type. Optional argument FORMAT is either plain or the default of
-internal. MODULE is the text module to use and defaults to the current
-module."
+  "Execute `diatheke' on QUERY with SEARCHTYPE.
+Optional argument FORMAT is either plain or the default of internal.
+MODULE is the text module to use and defaults to the current module."
   (with-temp-buffer
     (let ((args (list bible-sword-query nil (current-buffer) t "-b" (or module bible-module))))
       (setq args (append args (list "-s" (pcase searchtype
@@ -845,8 +844,8 @@ module."
 ;;
 ;; Fixing this issue would require keeping track of the current
 ;; chapter title and emitting the title whenever it changed. Since
-;; there is (AFAIK) only one chapter in the Bible that has this
-;;; issue, it doesn't seem like a high priority now.
+;; there is (AFAIK) only one chapter in the Bible that has this issue,
+;; it doesn't seem like a high priority now.
 (defvar-local bible-chapter-title nil
   "Text preceding start of chapter.
 Mostly in Psalms, like `Of David' or the like.")
@@ -881,7 +880,7 @@ Render HTML, return string.  Do some tweaking specific to morphology."
 
 ;; Use "plain" format with diatheke.
 (defun bible--lex-query (query module)
-  "Execute `diatheke' for QUERY, using MODULE. 
+  "Execute `diatheke' for QUERY, using MODULE.
 Plain format, returns string."
   (bible--exec-diatheke query nil "plain" module))
 
@@ -890,7 +889,7 @@ Plain format, returns string."
   "Return the Greek lemma from lemma index with a strong's number as KEY."
   (string-trim
    (string-replace
-    (concat "(" bible-lexicon-index) 
+    (concat "(" bible-lexicon-index)
     ""
     (bible--lex-query key bible-lexicon-index))))
 
@@ -941,7 +940,7 @@ them to the <bookname> <chapter>:<verse> format."
   "Execute `diatheke' to do query on KEY.
 Massage output so verse cross references are usable.  Returns string."
   (with-temp-buffer
-    (let ((args (list bible-sword-query nil (current-buffer) t "-b" bible-greek-lexicon "-o" "m" "-f" "plain" "-k" key)))      
+    (let ((args (list bible-sword-query nil (current-buffer) t "-b" bible-greek-lexicon "-o" "m" "-f" "plain" "-k" key)))
       (when bible-show-diatheke-exec
 	(message "%s" args))
       (apply 'call-process args)
@@ -997,13 +996,13 @@ Massage output so various cross references are usable. Returns string."
 ;; lex and morph strings, hoping to speed up tooltip rendering.
 ;;
 (defun bible--lookup-lemma-greek-short (lemma)
-  "Look up Greek lexical entry for LEX from short Greek lexicon."
+  "Look up Greek lexical entry for LEMMA from short Greek lexicon."
   (when (string-match "[0-9]+" lemma)
     (bible--lex-query (match-string 0 lemma) bible-greek-lexicon-short)))
 
 (defun bible--lookup-lemma-hebrew-short (lemma)
-  "Look up Hebrew lexical entry for LEX from short Hebrew 
-lexicon (StrongsRealHebrew)."
+  "Look up Hebrew lexical entry for LEMMA.
+Uses short Hebrew lexicon (e.g. StrongsRealHebrew)."
   (when (string-match "[0-9]+" lemma)
     ;; Remove redundant stuff at the beginnning.
     (substring (bible--lex-query (concat (match-string 0 lemma)) bible-hebrew-lexicon-short) 7)))
@@ -1023,8 +1022,8 @@ database and stash in cache."
 	  lex-text
       	(setq lex-text
 	      (cond ((string-prefix-p "G" key)
-		     (string-replace 
-		      (concat "(" bible-greek-lexicon-short ) 
+		     (string-replace
+		      (concat "(" bible-greek-lexicon-short )
 		      ""
 		      (bible--lookup-lemma-greek-short key)))
 		    ((string-prefix-p "H" key)
@@ -1036,7 +1035,7 @@ database and stash in cache."
 	(puthash key (string-fill (bible--cleanup-lex-text lex-text) 75) lex-hash)))))
 
 (defun bible--lookup-morph-entry (morph)
-  "Look up entry for morphological item MORPH. 
+  "Look up entry for morphological item MORPH.
 Return hash table entry if present in morph-hash cache, else look up in
 database and stash in cache."
   (when morph
@@ -1109,8 +1108,8 @@ both tags, otherwise just get lex definition."
       ;; binding for some command---see Info doc on Substituting Key
       ;; Bindings) in the tooltip. XXX I couldn't figure out a better
       ;; way to bypass command substitution in the tooltips.
-      (subst-char-in-string 
-       ?\\ 
+      (subst-char-in-string
+       ?\\
        ?
        (if morph-text
 	   (concat (string-trim lex-text) "\n" (string-trim morph-text))
@@ -1142,67 +1141,72 @@ in buffer)."
 	(savlm (dom-attr item 'savlm))
 	(lemma (dom-attr item 'lemma))
 	(divinename (dom-by-tag item 'divinename)))
-
     (let ((refstart (point))
 	  (refend (+ (point) (length word))))
-
       (insert word)
-
       ;; Red letter (Yuck, some modules need this below)
       (when (plist-get iproperties 'jesus)
 	(add-face-text-property refstart refend '(:foreground "red")))
-
       ;; Special case this. XXX Some modules do this differently.
       (when divinename
 	(insert " ")
 	(bible-handle-divine-name item))
-
       ;; lexical definitions
-      (when (or lemma savlm)
-	(let* ((matched nil)
-	       (lexemes (split-string (or lemma savlm)))
-	       ;; XXX Kludge alert. KJV module conflates articles with lemmas. Deal with this.
-	       (lexeme (if (> (length lexemes) 2) (nth 1 lexemes) (nth 0 lexemes))))
-	  (cond ((string-match "strong:G.*" lexeme) ; Greek
-		 (setq matched (match-string 0 lexeme))
-		 (put-text-property refstart refend 'keymap bible-greek-keymap))
-		((string-match "strong:H.*" lexeme) ; Hebrew
-		 (setq matched (match-string 0 lexeme))
-		 (put-text-property refstart refend 'keymap bible-hebrew-keymap)))
-	  ;; Add help-echo, strongs reference for tooltips if match.
-	  (when matched
-	    (setq bible-has-lexemes t)
-	    (put-text-property refstart refend 'help-echo 'bible--show-lex-morph)
-	    (put-text-property refstart refend 'strong matched))))
-
-      ;; morphology
-      (when morph
+      ;; N.B. There are some severe issues with Strongs numbers in some modules.
+      (when (or savlm lemma)
 	(let* ((matched nil)
-	       (morphemes (split-string morph))
-       (morpheme (car (last morphemes)))) ; KJV kludge as above
-	  (if (or
-	       (string-match "robinson:.*" morpheme)	; Robinson Greek morphology
-	       (string-match "packard:.*" morpheme)	; Packard Greek morphology --- LXX seems to use this
-	       (string-match "oshm:.*" morpheme))	; OSHM Hebrew morphology
-	      (setq matched (match-string 0 morpheme))
-	    ;;(message "Unknown morphology %s" morph)
-	    )
-	  (when matched
-	    (setq bible-has-morphemes t)
-	    (put-text-property refstart refend 'morph matched)
-	    (put-text-property refstart refend 'help-echo 'bible--show-lex-morph))))
-
-      ;; Insert lemma into buffer. Lemma tag will be part of lemma/savelm item.
-      ;; XXX Should I enable lexicon lookups on these lemmas? I don't use
-      ;; this anyway....
-      (when (and bible-word-study-enabled lemma (string-match "lemma.*:.*" lemma))
-	(dolist (word (split-string (match-string 0 lemma) " "))
-	  (setq word (replace-regexp-in-string "[.:a-zA-Z0-9]+" "" word))
-	  (insert " " word)
-	  (let ((refstart (- (point) 1 (length word)))
-		(refend (point)))
-	    (add-face-text-property refstart refend '(:foreground "blue"))
-	    (put-text-property refstart refend 'keymap bible-lemma-keymap)))))))
+	       (lexemes (split-string (or savlm lemma)))
+	       (lexeme
+		;; XXX Kludge alert. KJV module conflates Greek articles with lemmas. Deal with this.
+		(let ((result
+		       (if (string= bible-module "KJV")
+			   (let (thing)
+			     (dolist (item lexemes thing)
+			       (when (string-prefix-p "strong:" item)
+				 (setq thing item)))
+			     thing)
+			 (catch 'loop
+			   (dolist (item lexemes)
+			     (when (string-prefix-p "strong:" item)
+			       (throw 'loop item)))))))
+		  result)))
+	  (when lexeme
+	    (cond ((string-match "strong:G.*" lexeme) ; Greek
+		   (setq matched (match-string 0 lexeme))
+		   (put-text-property refstart refend 'keymap bible-greek-keymap))
+		  ((string-match "strong:H.*" lexeme) ; Hebrew
+		   (setq matched (match-string 0 lexeme))
+		   (put-text-property refstart refend 'keymap bible-hebrew-keymap)))
+	    ;; Add help-echo, strongs reference for tooltips if match.
+	    (when matched
+	      (setq bible-has-lexemes t)
+	      (put-text-property refstart refend 'help-echo 'bible--show-lex-morph)
+	      (put-text-property refstart refend 'strong matched))))
+	;; morphology
+	(when morph
+	  (let* ((matched nil)
+		 (morphemes (split-string morph))
+		 (morpheme (car (last morphemes)))) ; KJV kludge as above
+	    (if (or
+		 (string-match "robinson:.*" morpheme) ; Robinson Greek morphology
+		 (string-match "packard:.*" morpheme) ; Packard Greek morphology --- LXX seems to use this
+		 (string-match "oshm:.*" morpheme)) ; OSHM Hebrew morphology
+		(setq matched (match-string 0 morpheme)))
+	    (when matched
+	      (setq bible-has-morphemes t)
+	      (put-text-property refstart refend 'morph matched)
+	      (put-text-property refstart refend 'help-echo 'bible--show-lex-morph))))
+	;; Insert lemma into buffer. Lemma tag will be part of lemma/savelm item.
+	;; XXX Should I enable lexicon lookups on these lemmas? I don't use
+	;; this anyway....
+	(when (and bible-word-study-enabled lemma (string-match "lemma.*:.*" lemma))
+	  (dolist (word (split-string (match-string 0 lemma) " "))
+	    (setq word (replace-regexp-in-string "[.:a-zA-Z0-9]+" "" word))
+	    (insert " " word)
+	    (let ((refstart (- (point) 1 (length word)))
+		  (refend (point)))
+	      (add-face-text-property refstart refend '(:foreground "blue"))
+	      (put-text-property refstart refend 'keymap bible-lemma-keymap))))))))
 
 
 (defun bible-new-line ()
@@ -1249,7 +1253,7 @@ XXX In processing subnodes, each case will prepend a space if it needs it."
 	       ;; 'q is used for red letter.
 	       ;; NASB Module uses 'seg to indicate OT quotations (and others?).
 	       ((or 'body 'seg 'p 'q) (bible--insert-domnode-recursive subnode iproperties notitle))
-	       ('title (when (not notitle) (setq bible-chapter-title subnode) (bible-new-line)))
+	       ('title (unless notitle (setq bible-chapter-title subnode) (bible-new-line)))
 	       ;; These tags appear in ESV modules (and maybe others?) XXX still not right
 	       ('l
 		(let ((attributes (dom-attributes subnode)))
@@ -1268,7 +1272,7 @@ XXX In processing subnodes, each case will prepend a space if it needs it."
 	       ('br (bible-new-line))
 	       ('div (when (equal (dom-attr subnode 'type) "paragraph") (bible-new-line)))
 	       ;; For commentaries and the like. XXX Clicking on verse doesn't work yet. This will take work.
-	       ((or 'scripref 'reference) 
+	       ((or 'scripref 'reference)
 		(let ((word (bible-dom-text subnode)))
 		  (let ((start (point)))
 		    (insert " " word)
@@ -1289,8 +1293,8 @@ XXX In processing subnodes, each case will prepend a space if it needs it."
 
 
 (defun bible--display (&optional verse)
-  "Render a page of text for `bible'. If optional argument VERSE is
-supplied, set cursor at verse."
+  "Render a page of text for `bible'.
+If optional argument VERSE is supplied, set cursor at verse."
 
   (setq-local bible-module (default-value 'bible-module))
 
@@ -1302,7 +1306,7 @@ supplied, set cursor at verse."
     (insert (bible--exec-diatheke (concat bible--current-book-name ":" (number-to-string bible--current-chapter))))
 
     ;; Parse the xml in the buffer into a DOM tree.
-    (let ((html-dom-tree (libxml-parse-html-region (point-min) (point-max))))
+ (let ((html-dom-tree (libxml-parse-html-region (point-min) (point-max))))
       ;; Render the DOM tree into the buffer.
       (unless bible-debugme ; If this is true, display the XML.
 	(erase-buffer)
@@ -1311,9 +1315,9 @@ supplied, set cursor at verse."
 	(goto-char (point-min))))
 
     (save-excursion
-      (let ((search-string (concat (car bible--current-book) " " (number-to-string bible--current-chapter) ":")))
+      (let ((search-string (concat " *" (car bible--current-book) " " (number-to-string bible--current-chapter) ":")))
 	;; Delete <Book Ch:> at beginning of verse, just leave verse number.
-	(while (search-forward search-string nil t)
+	(while (re-search-forward search-string nil t)
 	  (replace-match "")
 	  ;; Highlight verse number
 	  (when (re-search-forward "^ *[0-9]+" nil t 1)
@@ -1325,7 +1329,7 @@ supplied, set cursor at verse."
 	(replace-match "" nil t)))
 
     (save-excursion
-       ;; Deal with chapter titles (i.e. in Psalms)
+      ;; Deal with chapter titles (i.e. in Psalms)
       ;; XXX N.B. This won't change a title inside a chapter, and so it
       ;; doesn't work with Psalm 119 where the acrostic letters get
       ;; printed as "titles".
@@ -1435,7 +1439,7 @@ supplied, set cursor at verse."
 			       "Entries .+?--" ""
 			       (bible--diatheke-search query searchmode "plain" bible-module)))))
     (if (equal results (concat "none (" bible-module ")"))
-	(message (concat 
+	(message (concat
 		  "No results found."
 		  (when (equal searchmode "lucene")
 		    " Verify index has been build with mkfastmod.")))
@@ -1461,7 +1465,7 @@ supplied, set cursor at verse."
 	(push
 	 ;; Massage match to make it more sortable, get rid of some characters.
 	 (replace-regexp-in-string
-	  ".+; " "" 
+	  ".+; " ""
 	  (string-replace
 	   "I " "1"
 	   (string-replace
@@ -1584,7 +1588,7 @@ This code is customized for the BDBGlosses_Strongs lexicon."
 If PREFIX is supplied, prepend PREFIX to the entries.
 Used in tandem with `completing-read' for chapter selection."
   (let ((range-list nil))
-    (dotimes (num (1+ max)) 
+    (dotimes (num (1+ max))
      (when (>= num min)
 	(push (cons (concat prefix (number-to-string num)) num) range-list)))
     (nreverse range-list)))