X-Git-Url: http://git.hcoop.net/bpt/emacs.git/blobdiff_plain/a1a4d0bc34d29b6a8aa46a81ba3189fbe994dc42..15cc05e98486f43b21aaf6e7428fa9f08ddd9e94:/lisp/informat.el

diff --git a/lisp/informat.el b/lisp/informat.el
index 2d923a1570..f64cede4ae 100644
--- a/lisp/informat.el
+++ b/lisp/informat.el
@@ -1,16 +1,16 @@
 ;;; informat.el --- info support functions package for Emacs
 
-;; Copyright (C) 1986 Free Software Foundation, Inc.
+;; Copyright (C) 1986, 2001-2012 Free Software Foundation, Inc.
 
 ;; Maintainer: FSF
 ;; Keywords: help
 
 ;; This file is part of GNU Emacs.
 
-;; GNU Emacs is free software; you can redistribute it and/or modify
+;; GNU Emacs is free software: you can redistribute it and/or modify
 ;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 2, or (at your option)
-;; any later version.
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
 
 ;; GNU Emacs is distributed in the hope that it will be useful,
 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
@@ -18,48 +18,113 @@
 ;; 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.  If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; Nowadays, the Texinfo formatting commands always tagify a buffer
+;; (as does `makeinfo') since @anchor commands need tag tables.
 
 ;;; Code:
 
 (require 'info)
 
+(declare-function texinfo-format-refill "texinfmt" ())
+
+;; From texinfmt.el
+(defvar texinfo-command-start)
+(defvar texinfo-command-end)
+
 ;;;###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.
-  (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
-	(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))
@@ -69,24 +134,39 @@
 		      (beginning-of-line)
 		      (delete-region (point) end)))
 		(goto-char (point-max))
+		(or (bolp)
+		    (newline))
 		(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)
-		  (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))))))
-  (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)))))
+
 
+;;;###autoload
+(defcustom Info-split-threshold 262144
+  "The number of characters by which `Info-split' splits an info file."
+  :type 'integer
+  :version "23.1"
+  :group 'texinfo)
+
 ;;;###autoload
 (defun Info-split ()
   "Split an info file into an indirect file plus bounded-size subfiles.
-Each subfile will be up to 50,000 characters plus one node.
+Each subfile will be up to the number of characters that
+`Info-split-threshold' specifies, plus one node.
 
 To use this command, first visit a large Info file that has a tag
 table.  The buffer is modified into a (small) indirect info file which
@@ -98,7 +178,7 @@ file name.  The indirect file still functions as an Info file, but it
 contains just the tag table and a directory of subfiles."
 
   (interactive)
-  (if (< (buffer-size) 70000)
+  (if (< (buffer-size) (+ 20000 Info-split-threshold))
       (error "This is too small to be worth splitting"))
   (goto-char (point-min))
   (search-forward "\^_")
@@ -123,7 +203,7 @@ contains just the tag table and a directory of subfiles."
       (narrow-to-region (point-min) (point))
       (goto-char (point-min))
       (while (< (1+ (point)) (point-max))
-	(goto-char (min (+ (point) 50000) (point-max)))
+	(goto-char (min (+ (point) Info-split-threshold) (point-max)))
 	(search-forward "\^_" nil 'move)
 	(setq subfiles
 	      (cons (list (+ start chars-deleted)
@@ -151,6 +231,10 @@ contains just the tag table and a directory of subfiles."
     (search-forward "\nTag Table:\n")
     (insert "(Indirect)\n")))
 
+(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.
@@ -164,76 +248,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))
-      (let ((allnodes '(("*")))
+      (let ((Info-validate-allnodes '(("*")))
 	    (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
-			      (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)
-				  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))
-		thisnode next)
+		Info-validate-thisnode next)
 	    (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"))
-		       (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
-			   (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))
-				   (setq lossages (delq (car tem) lossages)))
+				   (setq Info-validate-lossages
+					 (delq (car tem) Info-validate-lossages)))
 			       (setq tem (cdr tem))))
-			 (setq lossages
+			 (setq Info-validate-lossages
 			       (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"))
@@ -243,12 +330,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
-			  (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))
@@ -261,29 +348,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)))
-	(if (or lossages tags-losing)
+	(if (or Info-validate-lossages tags-losing)
 	    (with-output-to-temp-buffer " *problems in info file*"
-	      (while lossages
+	      (while Info-validate-lossages
 		(princ "In node \"")
-		(princ (car (car lossages)))
+		(princ (car (car Info-validate-lossages)))
 		(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))))
-		(if (nth 2 (car lossages))
+		(if (nth 2 (car Info-validate-lossages))
 		    (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)
-		(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.
@@ -302,19 +389,20 @@ Check that every node pointer points to an existing node."
     (if (= (following-char) ?\()
 	nil
       (setq name
-	    (buffer-substring
+	    (buffer-substring-no-properties
 	     (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) ?\())
-	(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 ()
@@ -326,7 +414,7 @@ Check that every node pointer points to an existing node."
 		  (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)) "*")
@@ -338,18 +426,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 (downcase (buffer-substring
+	       (setq tem (downcase (buffer-substring-no-properties
 				     (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)))))
-		   (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))))
@@ -361,7 +451,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)
-      (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)
@@ -375,7 +465,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
-		     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))))
@@ -410,9 +500,9 @@ For example, invoke \"emacs -batch -f batch-info-validate $info/ ~/*.info\""
 		      nil ;(message "Checking validity of info file %s... OK" file)
 		    (message "----------------------------------------------------------------------")
 		    (message ">> PROBLEMS IN INFO FILE %s" file)
-		    (save-excursion
-		      (set-buffer loss-name)
-		      (princ (buffer-substring (point-min) (point-max))))
+		    (with-current-buffer loss-name
+		      (princ (buffer-substring-no-properties
+			      (point-min) (point-max))))
 		    (message "----------------------------------------------------------------------")
 		    (setq error 1 lose t)))
 		(if (and (buffer-modified-p)
@@ -422,4 +512,6 @@ For example, invoke \"emacs -batch -f batch-info-validate $info/ ~/*.info\""
 	    (error (message ">> Error: %s" (prin1-to-string err))))))
       (kill-emacs error))))
 
+(provide 'informat)
+
 ;;; informat.el ends here