(font-lock-keyword-face, font-lock-set-defaults, font-lock-string-face):

[gnu-emacs] / lisp / informat.el

diff --git a/lisp/informat.el b/lisp/informat.el
index 2d923a1570d29bcdd5d98436d0e36adaa9d8262c..c9198d9319175404d811747bd4dc33343db555fa 100644 (file)
--- a/lisp/informat.el
+++ b/lisp/informat.el
@@ -1,6 +1,6 @@
 ;;; informat.el --- info support functions package for Emacs
 
 ;;; informat.el --- info support functions package for Emacs
 

-;; Copyright (C) 1986 Free Software Foundation, Inc.
+;; Copyright (C) 1986, 2002, 2003, 2004, 2005 Free Software Foundation, Inc.

 
 ;; Maintainer: FSF
 ;; Keywords: help
 
 ;; Maintainer: FSF
 ;; Keywords: help


@@ -18,48 +18,109 @@
 ;; GNU General Public License for more details.
 
 ;; You should have received a copy of the GNU General Public License
 ;; GNU General Public License for more details.
 
 ;; You should have received a copy of the GNU General Public License

-;; along with GNU Emacs; see the file COPYING.  If not, write to
-;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+;; along with GNU Emacs; see the file COPYING.  If not, write to the
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
+
+;;; Commentary:
+
+;; Nowadays, the Texinfo formatting commands always tagify a buffer
+;; (as does `makeinfo') since @anchor commands need tag tables.

 
 ;;; Code:
 
 (require 'info)
 
 ;;;###autoload
 
 ;;; Code:
 
 (require 'info)
 
 ;;;###autoload

-(defun Info-tagify ()
-  "Create or update Info-file tag table in current buffer."
+(defun Info-tagify (&optional input-buffer-name)
+  "Create or update Info file tag table in current buffer or in a region."

   (interactive)
   ;; Save and restore point and restrictions.
   ;; save-restrictions would not work
   ;; because it records the old max relative to the end.
   ;; We record it relative to the beginning.
   (interactive)
   ;; Save and restore point and restrictions.
   ;; save-restrictions would not work
   ;; because it records the old max relative to the end.
   ;; We record it relative to the beginning.

-  (message "Tagifying %s ..." (file-name-nondirectory (buffer-file-name)))
+  (if input-buffer-name
+      (message "Tagifying region in %s ..." input-buffer-name)
+      (message
+       "Tagifying %s ..."  (file-name-nondirectory (buffer-file-name))))

   (let ((omin (point-min))
        (omax (point-max))
        (nomax (= (point-max) (1+ (buffer-size))))
        (opoint (point)))
     (unwind-protect
   (let ((omin (point-min))
        (omax (point-max))
        (nomax (= (point-max) (1+ (buffer-size))))
        (opoint (point)))
     (unwind-protect

-       (progn
-         (widen)
-         (goto-char (point-min))
-         (if (search-forward "\^_\nIndirect:\n" nil t)
-             (message "Cannot tagify split info file")
-           (let ((regexp "Node:[ \t]*\\([^,\n\t]*\\)[,\t\n]")
-                 (case-fold-search t)
-                 list)
-             (while (search-forward "\n\^_" nil t)
-               ;; We want the 0-origin character position of the ^_.
-               ;; That is the same as the Emacs (1-origin) position
-               ;; of the newline before it.
-               (let ((beg (match-beginning 0)))
-                 (forward-line 2)
-                 (if (re-search-backward regexp beg t)
-                     (setq list
-                           (cons (list (buffer-substring
-                                         (match-beginning 1)
-                                         (match-end 1))
-                                       beg)
-                                 list)))))
+    (progn
+      (widen)
+      (goto-char (point-min))
+      (if (search-forward "\^_\nIndirect:\n" nil t)
+          (message
+           "Cannot tagify split info file.  Run this before splitting.")
+        (let (tag-list
+              refillp
+              (case-fold-search t)
+              (regexp
+               (concat
+                "\\("
+
+
+                "\\("
+                "@anchor"        ; match-string 2 matches @anchor
+                "\\)"
+                "\\(-no\\|-yes\\)"  ; match-string 3 matches -no or -yes
+                "\\("
+                "-refill"
+                "\\)"
+
+                "\\("
+                "{"
+                "\\)"
+                "\\("
+                "[^}]+"          ; match-string 6 matches arg to anchor
+                "\\)"
+                "\\("
+                "}"
+                "\\)"
+
+                "\\|"
+
+                "\\("
+                "\n\^_\\(\^L\\)?"
+                "\\)"
+
+                "\\("
+                "\n\\(File:[ \t]*\\([^,\n\t]*\\)[,\t\n]+[ \t\n]*\\)?"
+                "Node:[ \t]*"
+                "\\("
+                "[^,\n\t]*"      ; match-string 13 matches arg to node name
+                "\\)"
+                "[,\t\n]"
+                "\\)"
+
+                "\\)"
+                )))
+          (while (re-search-forward regexp nil t)
+            (if (string-equal "@anchor" (match-string 2))
+                (progn
+                  ;; kludge lest lose match-data
+                  (if (string-equal "-yes" (match-string 3))
+                      (setq refillp t))
+                  (setq tag-list
+                        (cons (list
+                               (concat "Ref: " (match-string 6))
+                               (match-beginning 0))
+                              tag-list))
+                  (if (eq refillp t)
+                      ;; set start and end so texinfo-format-refill works
+                      (let ((texinfo-command-start (match-beginning 0))
+                            (texinfo-command-end (match-end 0)))
+                        (texinfo-format-refill))
+                  (delete-region  (match-beginning 0) (match-end 0))))
+              ;; else this is a Node
+              (setq tag-list
+                    (cons (list
+                           (concat "Node: " (match-string-no-properties 13))
+                           (1+ (match-beginning 10)))
+                          tag-list))))
+

              (goto-char (point-max))
              (forward-line -8)
              (let ((buffer-read-only nil))
              (goto-char (point-max))
              (forward-line -8)
              (let ((buffer-read-only nil))


@@ -69,19 +130,26 @@
                      (beginning-of-line)
                      (delete-region (point) end)))
                (goto-char (point-max))
                      (beginning-of-line)
                      (delete-region (point) end)))
                (goto-char (point-max))

+               (or (bolp)
+                   (newline))

                (insert "\^_\f\nTag table:\n")
                (insert "\^_\f\nTag table:\n")

-               (move-marker Info-tag-table-marker (point))
-               (setq list (nreverse list))
-               (while list
-                 (insert "Node: " (car (car list)) ?\177)
-                 (princ (car (cdr (car list))) (current-buffer))
+               (if (eq major-mode 'info-mode)
+                   (move-marker Info-tag-table-marker (point)))
+               (setq tag-list (nreverse tag-list))
+               (while tag-list
+                 (insert (car (car tag-list)) ?\177)
+                 (princ (car (cdr (car tag-list))) (current-buffer))

                  (insert ?\n)
                  (insert ?\n)

-                 (setq list (cdr list)))
+                 (setq tag-list (cdr tag-list)))

                (insert "\^_\nEnd tag table\n")))))
       (goto-char opoint)
       (narrow-to-region omin (if nomax (1+ (buffer-size))
                               (min omax (point-max))))))
                (insert "\^_\nEnd tag table\n")))))
       (goto-char opoint)
       (narrow-to-region omin (if nomax (1+ (buffer-size))
                               (min omax (point-max))))))

-  (message "Tagifying %s ... done" (file-name-nondirectory (buffer-file-name))))
+  (if input-buffer-name
+      (message "Tagifying region in %s done" input-buffer-name)
+      (message
+       "Tagifying %s done"  (file-name-nondirectory (buffer-file-name)))))
+

 \f
 ;;;###autoload
 (defun Info-split ()
 \f
 ;;;###autoload
 (defun Info-split ()


@@ -151,6 +219,10 @@ contains just the tag table and a directory of subfiles."
     (search-forward "\nTag Table:\n")
     (insert "(Indirect)\n")))
 \f
     (search-forward "\nTag Table:\n")
     (insert "(Indirect)\n")))
 \f

+(defvar Info-validate-allnodes)
+(defvar Info-validate-thisnode)
+(defvar Info-validate-lossages)
+

 ;;;###autoload
 (defun Info-validate ()
   "Check current buffer for validity as an Info file.
 ;;;###autoload
 (defun Info-validate ()
   "Check current buffer for validity as an Info file.


@@ -164,76 +236,79 @@ Check that every node pointer points to an existing node."
          (error "Don't yet know how to validate indirect info files: \"%s\""
                 (buffer-name (current-buffer))))
       (goto-char (point-min))
          (error "Don't yet know how to validate indirect info files: \"%s\""
                 (buffer-name (current-buffer))))
       (goto-char (point-min))

-      (let ((allnodes '(("*")))
+      (let ((Info-validate-allnodes '(("*")))

            (regexp "Node:[ \t]*\\([^,\n\t]*\\)[,\t\n]")
            (case-fold-search t)
            (tags-losing nil)
            (regexp "Node:[ \t]*\\([^,\n\t]*\\)[,\t\n]")
            (case-fold-search t)
            (tags-losing nil)

-           (lossages ()))
+           (Info-validate-lossages ()))

        (while (search-forward "\n\^_" nil t)
          (forward-line 1)
          (let ((beg (point)))
            (forward-line 1)
            (if (re-search-backward regexp beg t)
                (let ((name (downcase
        (while (search-forward "\n\^_" nil t)
          (forward-line 1)
          (let ((beg (point)))
            (forward-line 1)
            (if (re-search-backward regexp beg t)
                (let ((name (downcase

-                             (buffer-substring
-                               (match-beginning 1)
-                               (progn
-                                 (goto-char (match-end 1))
-                                 (skip-chars-backward " \t")
-                                 (point))))))
-                 (if (assoc name allnodes)
-                     (setq lossages
+                            (buffer-substring-no-properties
+                             (match-beginning 1)
+                             (progn
+                               (goto-char (match-end 1))
+                               (skip-chars-backward " \t")
+                               (point))))))
+                 (if (assoc name Info-validate-allnodes)
+                     (setq Info-validate-lossages

                            (cons (list name "Duplicate node-name" nil)
                            (cons (list name "Duplicate node-name" nil)

-                                 lossages))
-                     (setq allnodes
-                           (cons (list name
-                                       (progn
-                                         (end-of-line)
-                                         (and (re-search-backward
-                                               "prev[ious]*:" beg t)
-                                              (progn
-                                                (goto-char (match-end 0))
-                                                (downcase
-                                                  (Info-following-node-name)))))
-                                       beg)
-                                 allnodes)))))))
+                                 Info-validate-lossages))
+                   (setq Info-validate-allnodes
+                         (cons (list name
+                                     (progn
+                                       (end-of-line)
+                                       (and (re-search-backward
+                                             "prev[ious]*:" beg t)
+                                            (progn
+                                              (goto-char (match-end 0))
+                                              (downcase
+                                               (Info-following-node-name)))))
+                                     beg)
+                               Info-validate-allnodes)))))))

        (goto-char (point-min))
        (while (search-forward "\n\^_" nil t)
          (forward-line 1)
          (let ((beg (point))
        (goto-char (point-min))
        (while (search-forward "\n\^_" nil t)
          (forward-line 1)
          (let ((beg (point))

-               thisnode next)
+               Info-validate-thisnode next)

            (forward-line 1)
            (if (re-search-backward regexp beg t)
                (save-restriction
            (forward-line 1)
            (if (re-search-backward regexp beg t)
                (save-restriction

-                 (search-forward "\n\^_" nil 'move)
-                 (narrow-to-region beg (point))
-                 (setq thisnode (downcase
-                                  (buffer-substring
-                                    (match-beginning 1)
-                                    (progn
-                                      (goto-char (match-end 1))
-                                      (skip-chars-backward " \t")
-                                      (point)))))
+                 (let ((md (match-data)))
+                   (search-forward "\n\^_" nil 'move)
+                   (narrow-to-region beg (point))
+                   (set-match-data md))
+                 (setq Info-validate-thisnode (downcase
+                                               (buffer-substring-no-properties
+                                                (match-beginning 1)
+                                                (progn
+                                                  (goto-char (match-end 1))
+                                                  (skip-chars-backward " \t")
+                                                  (point)))))

                  (end-of-line)
                  (and (search-backward "next:" nil t)
                       (setq next (Info-validate-node-name "invalid Next"))
                  (end-of-line)
                  (and (search-backward "next:" nil t)
                       (setq next (Info-validate-node-name "invalid Next"))

-                      (assoc next allnodes)
-                      (if (equal (car (cdr (assoc next allnodes)))
-                                 thisnode)
+                      (assoc next Info-validate-allnodes)
+                      (if (equal (car (cdr (assoc next Info-validate-allnodes)))
+                                 Info-validate-thisnode)

                           ;; allow multiple `next' pointers to one node
                           ;; allow multiple `next' pointers to one node

-                          (let ((tem lossages))
+                          (let ((tem Info-validate-lossages))

                             (while tem
                               (if (and (equal (car (cdr (car tem)))
                                               "should have Previous")
                                        (equal (car (car tem))
                                               next))
                             (while tem
                               (if (and (equal (car (cdr (car tem)))
                                               "should have Previous")
                                        (equal (car (car tem))
                                               next))

-                                  (setq lossages (delq (car tem) lossages)))
+                                  (setq Info-validate-lossages
+                                        (delq (car tem) Info-validate-lossages)))

                               (setq tem (cdr tem))))
                               (setq tem (cdr tem))))

-                        (setq lossages
+                        (setq Info-validate-lossages

                               (cons (list next
                                           "should have Previous"
                               (cons (list next
                                           "should have Previous"

-                                          thisnode)
-                                    lossages))))
+                                          Info-validate-thisnode)
+                                    Info-validate-lossages))))

                  (end-of-line)
                  (if (re-search-backward "prev[ious]*:" nil t)
                      (Info-validate-node-name "invalid Previous"))
                  (end-of-line)
                  (if (re-search-backward "prev[ious]*:" nil t)
                      (Info-validate-node-name "invalid Previous"))


@@ -243,12 +318,12 @@ Check that every node pointer points to an existing node."
                  (if (re-search-forward "\n* Menu:" nil t)
                      (while (re-search-forward "\n\\* " nil t)
                        (Info-validate-node-name
                  (if (re-search-forward "\n* Menu:" nil t)
                      (while (re-search-forward "\n\\* " nil t)
                        (Info-validate-node-name

-                         (concat "invalid menu item "
-                                 (buffer-substring (point)
-                                                   (save-excursion
-                                                     (skip-chars-forward "^:")
-                                                     (point))))
-                         (Info-extract-menu-node-name))))
+                        (concat "invalid menu item "
+                                (buffer-substring (point)
+                                                  (save-excursion
+                                                    (skip-chars-forward "^:")
+                                                    (point))))
+                        (Info-extract-menu-node-name))))

                  (goto-char (point-min))
                  (while (re-search-forward "\\*note[ \n]*[^:\t]*:" nil t)
                    (goto-char (+ (match-beginning 0) 5))
                  (goto-char (point-min))
                  (while (re-search-forward "\\*note[ \n]*[^:\t]*:" nil t)
                    (goto-char (+ (match-beginning 0) 5))


@@ -261,29 +336,29 @@ Check that every node pointer points to an existing node."
                                                 (point))))
                     (Info-extract-menu-node-name "Bad format cross-reference")))))))
        (setq tags-losing (not (Info-validate-tags-table)))
                                                 (point))))
                     (Info-extract-menu-node-name "Bad format cross-reference")))))))
        (setq tags-losing (not (Info-validate-tags-table)))

-       (if (or lossages tags-losing)
+       (if (or Info-validate-lossages tags-losing)

            (with-output-to-temp-buffer " *problems in info file*"
            (with-output-to-temp-buffer " *problems in info file*"

-             (while lossages
+             (while Info-validate-lossages

                (princ "In node \"")
                (princ "In node \"")

-               (princ (car (car lossages)))
+               (princ (car (car Info-validate-lossages)))

                (princ "\", ")
                (princ "\", ")

-               (let ((tem (nth 1 (car lossages))))
+               (let ((tem (nth 1 (car Info-validate-lossages))))

                  (cond ((string-match "\n" tem)
                         (princ (substring tem 0 (match-beginning 0)))
                         (princ "..."))
                        (t
                         (princ tem))))
                  (cond ((string-match "\n" tem)
                         (princ (substring tem 0 (match-beginning 0)))
                         (princ "..."))
                        (t
                         (princ tem))))

-               (if (nth 2 (car lossages))
+               (if (nth 2 (car Info-validate-lossages))

                    (progn
                      (princ ": ")
                    (progn
                      (princ ": ")

-                     (let ((tem (nth 2 (car lossages))))
+                     (let ((tem (nth 2 (car Info-validate-lossages))))

                        (cond ((string-match "\n" tem)
                               (princ (substring tem 0 (match-beginning 0)))
                               (princ "..."))
                              (t
                               (princ tem))))))
                (terpri)
                        (cond ((string-match "\n" tem)
                               (princ (substring tem 0 (match-beginning 0)))
                               (princ "..."))
                              (t
                               (princ tem))))))
                (terpri)

-               (setq lossages (cdr lossages)))
+               (setq Info-validate-lossages (cdr Info-validate-lossages)))

              (if tags-losing (princ "\nTags table must be recomputed\n")))
          ;; Here if info file is valid.
          ;; If we already made a list of problems, clear it out.
              (if tags-losing (princ "\nTags table must be recomputed\n")))
          ;; Here if info file is valid.
          ;; If we already made a list of problems, clear it out.


@@ -302,19 +377,20 @@ Check that every node pointer points to an existing node."
     (if (= (following-char) ?\()
        nil
       (setq name
     (if (= (following-char) ?\()
        nil
       (setq name

-           (buffer-substring
+           (buffer-substring-no-properties

             (point)
             (progn
             (point)
             (progn

-             (skip-chars-forward "^,\t\n")
-             (skip-chars-backward " ")
-             (point))))))
+              (skip-chars-forward "^,\t\n")
+              (skip-chars-backward " ")
+              (point))))))

   (if (null name)
       nil
     (setq name (downcase name))
     (or (and (> (length name) 0) (= (aref name 0) ?\())
   (if (null name)
       nil
     (setq name (downcase name))
     (or (and (> (length name) 0) (= (aref name 0) ?\())

-       (assoc name allnodes)
-       (setq lossages
-             (cons (list thisnode kind name) lossages))))
+       (assoc name Info-validate-allnodes)
+       (setq Info-validate-lossages
+             (cons (list Info-validate-thisnode kind name)
+                   Info-validate-lossages))))

   name)
 
 (defun Info-validate-tags-table ()
   name)
 
 (defun Info-validate-tags-table ()


@@ -326,7 +402,7 @@ Check that every node pointer points to an existing node."
                  (start (progn (search-backward "\nTag table:\n")
                                (1- (match-end 0))))
                  tem)
                  (start (progn (search-backward "\nTag table:\n")
                                (1- (match-end 0))))
                  tem)

-            (setq tem allnodes)
+            (setq tem Info-validate-allnodes)

             (while tem
               (goto-char start)
               (or (equal (car (car tem)) "*")
             (while tem
               (goto-char start)
               (or (equal (car (car tem)) "*")


@@ -338,18 +414,20 @@ Check that every node pointer points to an existing node."
               (setq tem (cdr tem)))
             (goto-char (1+ start))
             (while (looking-at ".*Node: \\(.*\\)\177\\([0-9]+\\)$")
               (setq tem (cdr tem)))
             (goto-char (1+ start))
             (while (looking-at ".*Node: \\(.*\\)\177\\([0-9]+\\)$")

-              (setq tem (downcase (buffer-substring
+              (setq tem (downcase (buffer-substring-no-properties

                                     (match-beginning 1)
                                     (match-end 1))))
                                     (match-beginning 1)
                                     (match-end 1))))

-              (setq tem (assoc tem allnodes))
+              (setq tem (assoc tem Info-validate-allnodes))

               (if (or (not tem)
                       (< 1000 (progn
                                 (goto-char (match-beginning 2))
                                 (setq tem (- (car (cdr (cdr tem)))
                                              (read (current-buffer))))
                                 (if (> tem 0) tem (- tem)))))
               (if (or (not tem)
                       (< 1000 (progn
                                 (goto-char (match-beginning 2))
                                 (setq tem (- (car (cdr (cdr tem)))
                                              (read (current-buffer))))
                                 (if (> tem 0) tem (- tem)))))

-                  (throw 'losing 'y)))
-            (forward-line 1))
+                  (throw 'losing 'y))
+              (forward-line 1)))
+          (if (looking-at "\^_\n")
+              (forward-line 1))

           (or (looking-at "End tag table\n")
               (throw 'losing 'z))
           nil))))
           (or (looking-at "End tag table\n")
               (throw 'losing 'z))
           nil))))


@@ -361,7 +439,7 @@ Must be used only with -batch, and kills Emacs on completion.
 Each file will be processed even if an error occurred previously.
 For example, invoke \"emacs -batch -f batch-info-validate $info/ ~/*.info\""
   (if (not noninteractive)
 Each file will be processed even if an error occurred previously.
 For example, invoke \"emacs -batch -f batch-info-validate $info/ ~/*.info\""
   (if (not noninteractive)

-      (error "batch-info-validate may only be used -batch."))
+      (error "batch-info-validate may only be used -batch"))

   (let ((version-control t)
        (auto-save-default nil)
        (find-file-run-dired nil)
   (let ((version-control t)
        (auto-save-default nil)
        (find-file-run-dired nil)


@@ -375,7 +453,7 @@ For example, invoke \"emacs -batch -f batch-info-validate $info/ ~/*.info\""
        (cond ((not (file-exists-p file))
               (message ">> %s does not exist!" file)
               (setq error 1
        (cond ((not (file-exists-p file))
               (message ">> %s does not exist!" file)
               (setq error 1

-                    command-line-args-left (cdr command-line-args-left))) 
+                    command-line-args-left (cdr command-line-args-left)))

              ((file-directory-p file)
               (setq command-line-args-left (nconc (directory-files file)
                                              (cdr command-line-args-left))))
              ((file-directory-p file)
               (setq command-line-args-left (nconc (directory-files file)
                                              (cdr command-line-args-left))))


@@ -412,7 +490,8 @@ For example, invoke \"emacs -batch -f batch-info-validate $info/ ~/*.info\""
                    (message ">> PROBLEMS IN INFO FILE %s" file)
                    (save-excursion
                      (set-buffer loss-name)
                    (message ">> PROBLEMS IN INFO FILE %s" file)
                    (save-excursion
                      (set-buffer loss-name)

-                     (princ (buffer-substring (point-min) (point-max))))
+                     (princ (buffer-substring-no-properties
+                             (point-min) (point-max))))

                    (message "----------------------------------------------------------------------")
                    (setq error 1 lose t)))
                (if (and (buffer-modified-p)
                    (message "----------------------------------------------------------------------")
                    (setq error 1 lose t)))
                (if (and (buffer-modified-p)


@@ -422,4 +501,7 @@ For example, invoke \"emacs -batch -f batch-info-validate $info/ ~/*.info\""
            (error (message ">> Error: %s" (prin1-to-string err))))))
       (kill-emacs error))))
 
            (error (message ">> Error: %s" (prin1-to-string err))))))
       (kill-emacs error))))
 

+(provide 'informat)
+
+;;; arch-tag: 581c440e-5be1-4f31-b005-2d5824bbf569

 ;;; informat.el ends here
 ;;; informat.el ends here