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