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