lisp/informat.el

   1 ;;; informat.el --- info support functions package for Emacs
   2
   3 ;; Copyright (C) 1986 Free Software Foundation, Inc.
   4
   5 ;; This file is part of GNU Emacs.
   6
   7 ;; GNU Emacs is free software; you can redistribute it and/or modify
   8 ;; it under the terms of the GNU General Public License as published by
   9 ;; the Free Software Foundation; either version 1, or (at your option)
  10 ;; any later version.
  11
  12 ;; GNU Emacs is distributed in the hope that it will be useful,
  13 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  14 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 ;; GNU General Public License for more details.
  16
  17 ;; You should have received a copy of the GNU General Public License
  18 ;; along with GNU Emacs; see the file COPYING.  If not, write to
  19 ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  20
  21 (require 'info)
  22
  23 ;;;###autoload
  24 (defun Info-tagify ()
  25   "Create or update Info-file tag table in current buffer."
  26   (interactive)
  27   ;; Save and restore point and restrictions.
  28   ;; save-restrictions would not work
  29   ;; because it records the old max relative to the end.
  30   ;; We record it relative to the beginning.
  31   (message "Tagifying %s ..." (file-name-nondirectory (buffer-file-name)))
  32   (let ((omin (point-min))
  33         (omax (point-max))
  34         (nomax (= (point-max) (1+ (buffer-size))))
  35         (opoint (point)))
  36     (unwind-protect
  37         (progn
  38           (widen)
  39           (goto-char (point-min))
  40           (if (search-forward "\^_\nIndirect:\n" nil t)
  41               (message "Cannot tagify split info file")
  42             (let ((regexp "Node:[ \t]*\\([^,\n\t]\\)*[,\t\n]")
  43                   (case-fold-search t)
  44                   list)
  45               (while (search-forward "\n\^_" nil t)
  46                 (forward-line 1)
  47                 (let ((beg (point)))
  48                   (forward-line 1)
  49                   (if (re-search-backward regexp beg t)
  50                       (setq list
  51                             (cons (list (buffer-substring
  52                                           (match-beginning 1)
  53                                           (match-end 1))
  54                                         beg)
  55                                   list)))))
  56               (goto-char (point-max))
  57               (forward-line -8)
  58               (let ((buffer-read-only nil))
  59                 (if (search-forward "\^_\nEnd tag table\n" nil t)
  60                     (let ((end (point)))
  61                       (search-backward "\nTag table:\n")
  62                       (beginning-of-line)
  63                       (delete-region (point) end)))
  64                 (goto-char (point-max))
  65                 (insert "\^_\f\nTag table:\n")
  66                 (move-marker Info-tag-table-marker (point))
  67                 (setq list (nreverse list))
  68                 (while list
  69                   (insert "Node: " (car (car list)) ?\177)
  70                   (princ (car (cdr (car list))) (current-buffer))
  71                   (insert ?\n)
  72                   (setq list (cdr list)))
  73                 (insert "\^_\nEnd tag table\n")))))
  74       (goto-char opoint)
  75       (narrow-to-region omin (if nomax (1+ (buffer-size))
  76                                (min omax (point-max))))))
  77   (message "Tagifying %s ... done" (file-name-nondirectory (buffer-file-name))))
  78 \f
  79 ;;;###autoload
  80 (defun Info-split ()
  81   "Split an info file into an indirect file plus bounded-size subfiles.
  82 Each subfile will be up to 50,000 characters plus one node.
  83
  84 To use this command, first visit a large Info file that has a tag
  85 table.  The buffer is modified into a (small) indirect info file which
  86 should be saved in place of the original visited file.
  87
  88 The subfiles are written in the same directory the original file is
  89 in, with names generated by appending `-' and a number to the original
  90 file name.  The indirect file still functions as an Info file, but it
  91 contains just the tag table and a directory of subfiles."
  92
  93   (interactive)
  94   (if (< (buffer-size) 70000)
  95       (error "This is too small to be worth splitting"))
  96   (goto-char (point-min))
  97   (search-forward "\^_")
  98   (forward-char -1)
  99   (let ((start (point))
 100         (chars-deleted 0)
 101         subfiles
 102         (subfile-number 1)
 103         (case-fold-search t)
 104         (filename (file-name-sans-versions buffer-file-name)))
 105     (goto-char (point-max))
 106     (forward-line -8)
 107     (setq buffer-read-only nil)
 108     (or (search-forward "\^_\nEnd tag table\n" nil t)
 109         (error "Tag table required; use M-x Info-tagify"))
 110     (search-backward "\nTag table:\n")
 111     (if (looking-at "\nTag table:\n\^_")
 112         (error "Tag table is just a skeleton; use M-x Info-tagify"))
 113     (beginning-of-line)
 114     (forward-char 1)
 115     (save-restriction
 116       (narrow-to-region (point-min) (point))
 117       (goto-char (point-min))
 118       (while (< (1+ (point)) (point-max))
 119         (goto-char (min (+ (point) 50000) (point-max)))
 120         (search-forward "\^_" nil 'move)
 121         (setq subfiles
 122               (cons (list (+ start chars-deleted)
 123                           (concat (file-name-nondirectory filename)
 124                                   (format "-%d" subfile-number)))
 125                     subfiles))
 126         ;; Put a newline at end of split file, to make Unix happier.
 127         (insert "\n")
 128         (write-region (point-min) (point)
 129                       (concat filename (format "-%d" subfile-number)))
 130         (delete-region (1- (point)) (point))
 131         ;; Back up over the final ^_.
 132         (forward-char -1)
 133         (setq chars-deleted (+ chars-deleted (- (point) start)))
 134         (delete-region start (point))
 135         (setq subfile-number (1+ subfile-number))))
 136     (while subfiles
 137       (goto-char start)
 138       (insert (nth 1 (car subfiles))
 139               (format ": %d" (car (car subfiles)))
 140               "\n")
 141       (setq subfiles (cdr subfiles)))
 142     (goto-char start)
 143     (insert "\^_\nIndirect:\n")
 144     (search-forward "\nTag Table:\n")
 145     (insert "(Indirect)\n")))
 146 \f
 147 ;;;###autoload
 148 (defun Info-validate ()
 149   "Check current buffer for validity as an Info file.
 150 Check that every node pointer points to an existing node."
 151   (interactive)
 152   (save-excursion
 153     (save-restriction
 154       (widen)
 155       (goto-char (point-min))
 156       (if (search-forward "\nTag table:\n(Indirect)\n" nil t)
 157           (error "Don't yet know how to validate indirect info files: \"%s\""
 158                  (buffer-name (current-buffer))))
 159       (goto-char (point-min))
 160       (let ((allnodes '(("*")))
 161             (regexp "Node:[ \t]*\\([^,\n\t]*\\)[,\t\n]")
 162             (case-fold-search t)
 163             (tags-losing nil)
 164             (lossages ()))
 165         (while (search-forward "\n\^_" nil t)
 166           (forward-line 1)
 167           (let ((beg (point)))
 168             (forward-line 1)
 169             (if (re-search-backward regexp beg t)
 170                 (let ((name (downcase
 171                               (buffer-substring
 172                                 (match-beginning 1)
 173                                 (progn
 174                                   (goto-char (match-end 1))
 175                                   (skip-chars-backward " \t")
 176                                   (point))))))
 177                   (if (assoc name allnodes)
 178                       (setq lossages
 179                             (cons (list name "Duplicate node-name" nil)
 180                                   lossages))
 181                       (setq allnodes
 182                             (cons (list name
 183                                         (progn
 184                                           (end-of-line)
 185                                           (and (re-search-backward
 186                                                 "prev[ious]*:" beg t)
 187                                                (progn
 188                                                  (goto-char (match-end 0))
 189                                                  (downcase
 190                                                    (Info-following-node-name)))))
 191                                         beg)
 192                                   allnodes)))))))
 193         (goto-char (point-min))
 194         (while (search-forward "\n\^_" nil t)
 195           (forward-line 1)
 196           (let ((beg (point))
 197                 thisnode next)
 198             (forward-line 1)
 199             (if (re-search-backward regexp beg t)
 200                 (save-restriction
 201                   (search-forward "\n\^_" nil 'move)
 202                   (narrow-to-region beg (point))
 203                   (setq thisnode (downcase
 204                                    (buffer-substring
 205                                      (match-beginning 1)
 206                                      (progn
 207                                        (goto-char (match-end 1))
 208                                        (skip-chars-backward " \t")
 209                                        (point)))))
 210                   (end-of-line)
 211                   (and (search-backward "next:" nil t)
 212                        (setq next (Info-validate-node-name "invalid Next"))
 213                        (assoc next allnodes)
 214                        (if (equal (car (cdr (assoc next allnodes)))
 215                                   thisnode)
 216                            ;; allow multiple `next' pointers to one node
 217                            (let ((tem lossages))
 218                              (while tem
 219                                (if (and (equal (car (cdr (car tem)))
 220                                                "should have Previous")
 221                                         (equal (car (car tem))
 222                                                next))
 223                                    (setq lossages (delq (car tem) lossages)))
 224                                (setq tem (cdr tem))))
 225                          (setq lossages
 226                                (cons (list next
 227                                            "should have Previous"
 228                                            thisnode)
 229                                      lossages))))
 230                   (end-of-line)
 231                   (if (re-search-backward "prev[ious]*:" nil t)
 232                       (Info-validate-node-name "invalid Previous"))
 233                   (end-of-line)
 234                   (if (search-backward "up:" nil t)
 235                       (Info-validate-node-name "invalid Up"))
 236                   (if (re-search-forward "\n* Menu:" nil t)
 237                       (while (re-search-forward "\n\\* " nil t)
 238                         (Info-validate-node-name
 239                           (concat "invalid menu item "
 240                                   (buffer-substring (point)
 241                                                     (save-excursion
 242                                                       (skip-chars-forward "^:")
 243                                                       (point))))
 244                           (Info-extract-menu-node-name))))
 245                   (goto-char (point-min))
 246                   (while (re-search-forward "\\*note[ \n]*[^:\t]*:" nil t)
 247                     (goto-char (+ (match-beginning 0) 5))
 248                     (skip-chars-forward " \n")
 249                     (Info-validate-node-name
 250                      (concat "invalid reference "
 251                              (buffer-substring (point)
 252                                                (save-excursion
 253                                                  (skip-chars-forward "^:")
 254                                                  (point))))
 255                      (Info-extract-menu-node-name "Bad format cross-reference")))))))
 256         (setq tags-losing (not (Info-validate-tags-table)))
 257         (if (or lossages tags-losing)
 258             (with-output-to-temp-buffer " *problems in info file*"
 259               (while lossages
 260                 (princ "In node \"")
 261                 (princ (car (car lossages)))
 262                 (princ "\", ")
 263                 (let ((tem (nth 1 (car lossages))))
 264                   (cond ((string-match "\n" tem)
 265                          (princ (substring tem 0 (match-beginning 0)))
 266                          (princ "..."))
 267                         (t
 268                          (princ tem))))
 269                 (if (nth 2 (car lossages))
 270                     (progn
 271                       (princ ": ")
 272                       (let ((tem (nth 2 (car lossages))))
 273                         (cond ((string-match "\n" tem)
 274                                (princ (substring tem 0 (match-beginning 0)))
 275                                (princ "..."))
 276                               (t
 277                                (princ tem))))))
 278                 (terpri)
 279                 (setq lossages (cdr lossages)))
 280               (if tags-losing (princ "\nTags table must be recomputed\n")))
 281           ;; Here if info file is valid.
 282           ;; If we already made a list of problems, clear it out.
 283           (save-excursion
 284             (if (get-buffer " *problems in info file*")
 285                 (progn
 286                   (set-buffer " *problems in info file*")
 287                   (kill-buffer (current-buffer)))))
 288           (message "File appears valid"))))))
 289
 290 (defun Info-validate-node-name (kind &optional name)
 291   (if name
 292       nil
 293     (goto-char (match-end 0))
 294     (skip-chars-forward " \t")
 295     (if (= (following-char) ?\()
 296         nil
 297       (setq name
 298             (buffer-substring
 299              (point)
 300              (progn
 301               (skip-chars-forward "^,\t\n")
 302               (skip-chars-backward " ")
 303               (point))))))
 304   (if (null name)
 305       nil
 306     (setq name (downcase name))
 307     (or (and (> (length name) 0) (= (aref name 0) ?\())
 308         (assoc name allnodes)
 309         (setq lossages
 310               (cons (list thisnode kind name) lossages))))
 311   name)
 312
 313 (defun Info-validate-tags-table ()
 314   (goto-char (point-min))
 315   (if (not (search-forward "\^_\nEnd tag table\n" nil t))
 316       t
 317     (not (catch 'losing
 318            (let* ((end (match-beginning 0))
 319                   (start (progn (search-backward "\nTag table:\n")
 320                                 (1- (match-end 0))))
 321                   tem)
 322              (setq tem allnodes)
 323              (while tem
 324                (goto-char start)
 325                (or (equal (car (car tem)) "*")
 326                    (search-forward (concat "Node: "
 327                                            (car (car tem))
 328                                            "\177")
 329                                    end t)
 330                    (throw 'losing 'x))
 331                (setq tem (cdr tem)))
 332              (goto-char (1+ start))
 333              (while (looking-at ".*Node: \\(.*\\)\177\\([0-9]+\\)$")
 334                (setq tem (downcase (buffer-substring
 335                                      (match-beginning 1)
 336                                      (match-end 1))))
 337                (setq tem (assoc tem allnodes))
 338                (if (or (not tem)
 339                        (< 1000 (progn
 340                                  (goto-char (match-beginning 2))
 341                                  (setq tem (- (car (cdr (cdr tem)))
 342                                               (read (current-buffer))))
 343                                  (if (> tem 0) tem (- tem)))))
 344                    (throw 'losing 'y)))
 345              (forward-line 1))
 346            (or (looking-at "End tag table\n")
 347                (throw 'losing 'z))
 348            nil))))
 349 \f
 350 ;;;###autoload
 351 (defun batch-info-validate ()
 352   "Runs `Info-validate' on the files remaining on the command line.
 353 Must be used only with -batch, and kills Emacs on completion.
 354 Each file will be processed even if an error occurred previously.
 355 For example, invoke \"emacs -batch -f batch-info-validate $info/ ~/*.info\""
 356   (if (not noninteractive)
 357       (error "batch-info-validate may only be used -batch."))
 358   (let ((version-control t)
 359         (auto-save-default nil)
 360         (find-file-run-dired nil)
 361         (kept-old-versions 259259)
 362         (kept-new-versions 259259))
 363     (let ((error 0)
 364           file
 365           (files ()))
 366       (while command-line-args-left
 367         (setq file (expand-file-name (car command-line-args-left)))
 368         (cond ((not (file-exists-p file))
 369                (message ">> %s does not exist!" file)
 370                (setq error 1
 371                      command-line-args-left (cdr command-line-args-left)))
 372               ((file-directory-p file)
 373                (setq command-line-args-left (nconc (directory-files file)
 374                                               (cdr command-line-args-left))))
 375               (t
 376                (setq files (cons file files)
 377                      command-line-args-left (cdr command-line-args-left)))))
 378       (while files
 379         (setq file (car files)
 380               files (cdr files))
 381         (let ((lose nil))
 382           (condition-case err
 383               (progn
 384                 (if buffer-file-name (kill-buffer (current-buffer)))
 385                 (find-file file)
 386                 (buffer-disable-undo (current-buffer))
 387                 (set-buffer-modified-p nil)
 388                 (fundamental-mode)
 389                 (let ((case-fold-search nil))
 390                   (goto-char (point-max))
 391                   (cond ((search-backward "\n\^_\^L\nTag table:\n" nil t)
 392                          (message "%s already tagified" file))
 393                         ((< (point-max) 30000)
 394                          (message "%s too small to bother tagifying" file))
 395                         (t
 396                          (Info-tagify file))))
 397                 (let ((loss-name " *problems in info file*"))
 398                   (message "Checking validity of info file %s..." file)
 399                   (if (get-buffer loss-name)
 400                       (kill-buffer loss-name))
 401                   (Info-validate)
 402                   (if (not (get-buffer loss-name))
 403                       nil ;(message "Checking validity of info file %s... OK" file)
 404                     (message "----------------------------------------------------------------------")
 405                     (message ">> PROBLEMS IN INFO FILE %s" file)
 406                     (save-excursion
 407                       (set-buffer loss-name)
 408                       (princ (buffer-substring (point-min) (point-max))))
 409                     (message "----------------------------------------------------------------------")
 410                     (setq error 1 lose t)))
 411                 (if (and (buffer-modified-p)
 412                          (not lose))
 413                     (progn (message "Saving modified %s" file)
 414                            (save-buffer))))
 415             (error (message ">> Error: %s" (prin1-to-string err))))))
 416       (kill-emacs error))))
 417
 418 ;;; informat.el ends here