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