Mercurial > emacs
comparison lisp/format.el @ 24156:e93962ff30b0
Doc fixes.
(format-encode-run-method): Have things happen in the right
buffer. Deal with errors from method. Set
coding-system-for-write.
(format-decode-run-method): Have things happen in the right
buffer. Deal with errors from method. Set
coding-system-for-read.
(format-alist): Use nil instead of unmatchable regexps.
author | Dave Love <fx@gnu.org> |
---|---|
date | Sat, 23 Jan 1999 21:52:40 +0000 |
parents | 3e5822a3448d |
children | 382a7de604b6 |
comparison
equal
deleted
inserted
replaced
24155:62548105541c | 24156:e93962ff30b0 |
---|---|
1 ;;; format.el --- read and save files in multiple formats | 1 ;;; format.el --- read and save files in multiple formats |
2 | 2 |
3 ;; Copyright (c) 1994, 1995, 1997 Free Software Foundation | 3 ;; Copyright (c) 1994, 1995, 1997, 1999 Free Software Foundation |
4 | 4 |
5 ;; Author: Boris Goldowsky <boris@gnu.ai.mit.edu> | 5 ;; Author: Boris Goldowsky <boris@gnu.org> |
6 | 6 |
7 ;; This file is part of GNU Emacs. | 7 ;; This file is part of GNU Emacs. |
8 | 8 |
9 ;; GNU Emacs is free software; you can redistribute it and/or modify | 9 ;; GNU Emacs is free software; you can redistribute it and/or modify |
10 ;; it under the terms of the GNU General Public License as published by | 10 ;; it under the terms of the GNU General Public License as published by |
24 ;;; Commentary: | 24 ;;; Commentary: |
25 | 25 |
26 ;; This file defines a unified mechanism for saving & loading files stored | 26 ;; This file defines a unified mechanism for saving & loading files stored |
27 ;; in different formats. `format-alist' contains information that directs | 27 ;; in different formats. `format-alist' contains information that directs |
28 ;; Emacs to call an encoding or decoding function when reading or writing | 28 ;; Emacs to call an encoding or decoding function when reading or writing |
29 ;; files that match certain conditions. | 29 ;; files that match certain conditions. |
30 ;; | 30 ;; |
31 ;; When a file is visited, its format is determined by matching the | 31 ;; When a file is visited, its format is determined by matching the |
32 ;; beginning of the file against regular expressions stored in | 32 ;; beginning of the file against regular expressions stored in |
33 ;; `format-alist'. If this fails, you can manually translate the buffer | 33 ;; `format-alist'. If this fails, you can manually translate the buffer |
34 ;; using `format-decode-buffer'. In either case, the formats used are | 34 ;; using `format-decode-buffer'. In either case, the formats used are |
43 ;; risk losing any text-properties in the buffer). | 43 ;; risk losing any text-properties in the buffer). |
44 ;; | 44 ;; |
45 ;; You can manually translate a buffer into or out of a particular format | 45 ;; You can manually translate a buffer into or out of a particular format |
46 ;; with the functions `format-encode-buffer' and `format-decode-buffer'. | 46 ;; with the functions `format-encode-buffer' and `format-decode-buffer'. |
47 ;; To translate just the region use the functions `format-encode-region' | 47 ;; To translate just the region use the functions `format-encode-region' |
48 ;; and `format-decode-region'. | 48 ;; and `format-decode-region'. |
49 ;; | 49 ;; |
50 ;; You can define a new format by writing the encoding and decoding | 50 ;; You can define a new format by writing the encoding and decoding |
51 ;; functions, and adding an entry to `format-alist'. See enriched.el for | 51 ;; functions, and adding an entry to `format-alist'. See enriched.el for |
52 ;; an example of how to implement a file format. There are various | 52 ;; an example of how to implement a file format. There are various |
53 ;; functions defined in this file that may be useful for writing the | 53 ;; functions defined in this file that may be useful for writing the |
61 | 61 |
62 ;;; Code: | 62 ;;; Code: |
63 | 63 |
64 (put 'buffer-file-format 'permanent-local t) | 64 (put 'buffer-file-format 'permanent-local t) |
65 | 65 |
66 (defvar format-alist | 66 (defvar format-alist |
67 '((text/enriched "Extended MIME text/enriched format." | 67 '((text/enriched "Extended MIME text/enriched format." |
68 "Content-[Tt]ype:[ \t]*text/enriched" | 68 "Content-[Tt]ype:[ \t]*text/enriched" |
69 enriched-decode enriched-encode t enriched-mode) | 69 enriched-decode enriched-encode t enriched-mode) |
70 (plain "ISO 8859-1 standard format, no text properties." | 70 (plain "ISO 8859-1 standard format, no text properties." |
71 ;; Plain only exists so that there is an obvious neutral choice in | 71 ;; Plain only exists so that there is an obvious neutral choice in |
72 ;; the completion list. | 72 ;; the completion list. |
73 nil nil nil nil nil) | 73 nil nil nil nil nil) |
74 (ibm "IBM Code Page 850 (DOS)" | 74 (ibm "IBM Code Page 850 (DOS)" |
75 "1\\(^\\)" | 75 nil ; The original "1\\(^\\)" is obscure. |
76 "recode -f ibm-pc:latin1" "recode -f latin1:ibm-pc" t nil) | 76 "recode -f ibm-pc:latin1" "recode -f latin1:ibm-pc" t nil) |
77 (mac "Apple Macintosh" | 77 (mac "Apple Macintosh" |
78 "1\\(^\\)" | 78 nil |
79 "recode -f mac:latin1" "recode -f latin1:mac" t nil) | 79 "recode -f mac:latin1" "recode -f latin1:mac" t nil) |
80 (hp "HP Roman8" | 80 (hp "HP Roman8" |
81 "1\\(^\\)" | 81 nil |
82 "recode -f roman8:latin1" "recode -f latin1:roman8" t nil) | 82 "recode -f roman8:latin1" "recode -f latin1:roman8" t nil) |
83 (TeX "TeX (encoding)" | 83 (TeX "TeX (encoding)" |
84 "1\\(^\\)" | 84 nil |
85 iso-tex2iso iso-iso2tex t nil) | 85 iso-tex2iso iso-iso2tex t nil) |
86 (gtex "German TeX (encoding)" | 86 (gtex "German TeX (encoding)" |
87 "1\\(^\\)" | 87 nil |
88 iso-gtex2iso iso-iso2gtex t nil) | 88 iso-gtex2iso iso-iso2gtex t nil) |
89 (html "HTML (encoding)" | 89 (html "HTML (encoding)" |
90 "1\\(^\\)" | 90 nil |
91 "recode -f html:latin1" "recode -f latin1:html" t nil) | 91 "recode -f html:latin1" "recode -f latin1:html" t nil) |
92 (rot13 "rot13" | 92 (rot13 "rot13" |
93 "1\\(^\\)" | 93 nil |
94 "tr a-mn-z n-za-m" "tr a-mn-z n-za-m" t nil) | 94 "tr a-mn-z n-za-m" "tr a-mn-z n-za-m" t nil) |
95 (duden "Duden Ersatzdarstellung" | 95 (duden "Duden Ersatzdarstellung" |
96 "1\\(^\\)" | 96 nil |
97 "diac" iso-iso2duden t nil) | 97 "diac" iso-iso2duden t nil) |
98 (de646 "German ASCII (ISO 646)" | 98 (de646 "German ASCII (ISO 646)" |
99 "1\\(^\\)" | 99 nil |
100 "recode -f iso646-ge:latin1" "recode -f latin1:iso646-ge" t nil) | 100 "recode -f iso646-ge:latin1" "recode -f latin1:iso646-ge" t nil) |
101 (denet "net German" | 101 (denet "net German" |
102 "1\\(^\\)" | 102 nil |
103 iso-german iso-cvt-read-only t nil) | 103 iso-german iso-cvt-read-only t nil) |
104 (esnet "net Spanish" | 104 (esnet "net Spanish" |
105 "1\\(^\\)" | 105 nil |
106 iso-spanish iso-cvt-read-only t nil)) | 106 iso-spanish iso-cvt-read-only t nil)) |
107 "List of information about understood file formats. | 107 "List of information about understood file formats. |
108 Elements are of the form \(NAME DOC-STR REGEXP FROM-FN TO-FN MODIFY MODE-FN). | 108 Elements are of the form \(NAME DOC-STR REGEXP FROM-FN TO-FN MODIFY MODE-FN). |
109 | 109 |
110 NAME is a symbol, which is stored in `buffer-file-format'. | 110 NAME is a symbol, which is stored in `buffer-file-format'. |
112 DOC-STR should be a single line providing more information about the | 112 DOC-STR should be a single line providing more information about the |
113 format. It is currently unused, but in the future will be shown to | 113 format. It is currently unused, but in the future will be shown to |
114 the user if they ask for more information. | 114 the user if they ask for more information. |
115 | 115 |
116 REGEXP is a regular expression to match against the beginning of the file; | 116 REGEXP is a regular expression to match against the beginning of the file; |
117 it should match only files in that format. | 117 it should match only files in that format. Use nil to avoid |
118 | 118 matching at all for formats for which this isn't appropriate to |
119 FROM-FN is called to decode files in that format; it gets two args, BEGIN | 119 require explicit encoding/decoding. |
120 | |
121 FROM-FN is called to decode files in that format; it gets two args, BEGIN | |
120 and END, and can make any modifications it likes, returning the new | 122 and END, and can make any modifications it likes, returning the new |
121 end. It must make sure that the beginning of the file no longer | 123 end. It must make sure that the beginning of the file no longer |
122 matches REGEXP, or else it will get called again. | 124 matches REGEXP, or else it will get called again. |
123 Alternatively, FROM-FN can be a string, which specifies a shell command | 125 Alternatively, FROM-FN can be a string, which specifies a shell command |
124 (including options) to be used as a filter to perform the conversion. | 126 (including options) to be used as a filter to perform the conversion. |
132 Alternatively, TO-FN can be a string, which specifies a shell command | 134 Alternatively, TO-FN can be a string, which specifies a shell command |
133 (including options) to be used as a filter to perform the conversion. | 135 (including options) to be used as a filter to perform the conversion. |
134 | 136 |
135 MODIFY, if non-nil, means the TO-FN wants to modify the region. If nil, | 137 MODIFY, if non-nil, means the TO-FN wants to modify the region. If nil, |
136 TO-FN will not make any changes but will instead return a list of | 138 TO-FN will not make any changes but will instead return a list of |
137 annotations. | 139 annotations. |
138 | 140 |
139 MODE-FN, if specified, is called when visiting a file with that format.") | 141 MODE-FN, if specified, is called when visiting a file with that format.") |
140 | 142 |
141 ;;; Basic Functions (called from Lisp) | 143 ;;; Basic Functions (called from Lisp) |
142 | 144 |
144 "Translate using function or shell script METHOD the text from FROM to TO. | 146 "Translate using function or shell script METHOD the text from FROM to TO. |
145 If METHOD is a string, it is a shell command; | 147 If METHOD is a string, it is a shell command; |
146 otherwise, it should be a Lisp function. | 148 otherwise, it should be a Lisp function. |
147 BUFFER should be the buffer that the output originally came from." | 149 BUFFER should be the buffer that the output originally came from." |
148 (if (stringp method) | 150 (if (stringp method) |
149 (save-current-buffer | 151 (let ((error-buff (get-buffer-create "*Format Errors*")) |
150 (set-buffer buffer) | 152 (coding-system-for-write 'no-conversion) |
151 (with-output-to-temp-buffer "*Format Errors*" | 153 format-alist) |
152 (shell-command-on-region from to method t nil standard-output)) | 154 (with-current-buffer error-buff |
153 (point)) | 155 (widen) |
156 (erase-buffer)) | |
157 (if (and (zerop (shell-command-on-region from to method t t | |
158 error-buff)) | |
159 ;; gzip gives zero exit status with bad args, for instance. | |
160 (zerop (with-current-buffer error-buff | |
161 (buffer-size)))) | |
162 (bury-buffer error-buff) | |
163 (switch-to-buffer-other-window error-buff) | |
164 (error "Format decoding failed"))) | |
154 (funcall method from to buffer))) | 165 (funcall method from to buffer))) |
155 | 166 |
156 (defun format-decode-run-method (method from to &optional buffer) | 167 (defun format-decode-run-method (method from to &optional buffer) |
157 "Decode using function or shell script METHOD the text from FROM to TO. | 168 "Decode using function or shell script METHOD the text from FROM to TO. |
158 If METHOD is a string, it is a shell command; | 169 If METHOD is a string, it is a shell command; otherwise, it should be |
159 otherwise, it should be a Lisp function." | 170 a Lisp function. Decoding is done for the given BUFFER." |
160 (if (stringp method) | 171 (if (stringp method) |
161 (progn | 172 (let ((error-buff (get-buffer-create "*Format Errors*")) |
162 (with-output-to-temp-buffer "*Format Errors*" | 173 (coding-system-for-read 'no-conversion) ; like jka-compr |
163 (shell-command-on-region from to method t nil standard-output)) | 174 format-alist) |
175 (with-current-buffer error-buff | |
176 (widen) | |
177 (erase-buffer)) | |
178 ;; We should perhaps go via a temporary buffer and copy it | |
179 ;; back, in case of errors. | |
180 (if (and (zerop (save-window-excursion | |
181 (shell-command-on-region (point-min) (point-max) | |
182 method t t | |
183 error-buff))) | |
184 ;; gzip gives zero exit status with bad args, for instance. | |
185 (zerop (with-current-buffer error-buff | |
186 (buffer-size)))) | |
187 (bury-buffer error-buff) | |
188 (switch-to-buffer-other-window error-buff) | |
189 (error "Format decoding failed")) | |
164 (point)) | 190 (point)) |
165 (funcall method from to))) | 191 (funcall method from to))) |
166 | 192 |
167 (defun format-annotate-function (format from to orig-buf) | 193 (defun format-annotate-function (format from to orig-buf) |
168 "Returns annotations for writing region as FORMAT. | 194 "Return annotations for writing region as FORMAT. |
169 FORMAT is a symbol naming one of the formats defined in `format-alist', | 195 FORMAT is a symbol naming one of the formats defined in `format-alist', |
170 it must be a single symbol, not a list like `buffer-file-format'. | 196 it must be a single symbol, not a list like `buffer-file-format'. |
171 FROM and TO delimit the region to be operated on in the current buffer. | 197 FROM and TO delimit the region to be operated on in the current buffer. |
172 ORIG-BUF is the original buffer that the data came from. | 198 ORIG-BUF is the original buffer that the data came from. |
173 This function works like a function on `write-region-annotate-functions': | 199 This function works like a function on `write-region-annotate-functions': |
174 it either returns a list of annotations, or returns with a different buffer | 200 it either returns a list of annotations, or returns with a different buffer |
175 current, which contains the modified text to write. | 201 current, which contains the modified text to write. |
176 | 202 |
177 For most purposes, consider using `format-encode-region' instead." | 203 For most purposes, consider using `format-encode-region' instead." |
178 ;; This function is called by write-region (actually build-annotations) | 204 ;; This function is called by write-region (actually build-annotations) |
179 ;; for each element of buffer-file-format. | 205 ;; for each element of buffer-file-format. |
180 (let* ((info (assq format format-alist)) | 206 (let* ((info (assq format format-alist)) |
181 (to-fn (nth 4 info)) | 207 (to-fn (nth 4 info)) |
182 (modify (nth 5 info))) | 208 (modify (nth 5 info))) |
183 (if to-fn | 209 (if to-fn |
193 (funcall to-fn from to orig-buf))))) | 219 (funcall to-fn from to orig-buf))))) |
194 | 220 |
195 (defun format-decode (format length &optional visit-flag) | 221 (defun format-decode (format length &optional visit-flag) |
196 ;; This function is called by insert-file-contents whenever a file is read. | 222 ;; This function is called by insert-file-contents whenever a file is read. |
197 "Decode text from any known FORMAT. | 223 "Decode text from any known FORMAT. |
198 FORMAT is a symbol appearing in `format-alist' or a list of such symbols, | 224 FORMAT is a symbol appearing in `format-alist' or a list of such symbols, |
199 or nil, in which case this function tries to guess the format of the data by | 225 or nil, in which case this function tries to guess the format of the data by |
200 matching against the regular expressions in `format-alist'. After a match is | 226 matching against the regular expressions in `format-alist'. After a match is |
201 found and the region decoded, the alist is searched again from the beginning | 227 found and the region decoded, the alist is searched again from the beginning |
202 for another match. | 228 for another match. |
203 | 229 |
208 | 234 |
209 Returns the new length of the decoded region. | 235 Returns the new length of the decoded region. |
210 | 236 |
211 For most purposes, consider using `format-decode-region' instead." | 237 For most purposes, consider using `format-decode-region' instead." |
212 (let ((mod (buffer-modified-p)) | 238 (let ((mod (buffer-modified-p)) |
213 (begin (point)) | 239 (begin (point)) |
214 (end (+ (point) length))) | 240 (end (+ (point) length))) |
215 (if (null format) | 241 (if (null format) |
216 ;; Figure out which format it is in, remember list in `format'. | 242 ;; Figure out which format it is in, remember list in `format'. |
217 (let ((try format-alist)) | 243 (let ((try format-alist)) |
218 (while try | 244 (while try |
256 ;;; | 282 ;;; |
257 | 283 |
258 (defun format-decode-buffer (&optional format) | 284 (defun format-decode-buffer (&optional format) |
259 "Translate the buffer from some FORMAT. | 285 "Translate the buffer from some FORMAT. |
260 If the format is not specified, this function attempts to guess. | 286 If the format is not specified, this function attempts to guess. |
261 `buffer-file-format' is set to the format used, and any mode-functions | 287 `buffer-file-format' is set to the format used, and any mode-functions |
262 for the format are called." | 288 for the format are called." |
263 (interactive | 289 (interactive |
264 (list (format-read "Translate buffer from format (default: guess): "))) | 290 (list (format-read "Translate buffer from format (default: guess): "))) |
265 (save-excursion | 291 (save-excursion |
266 (goto-char (point-min)) | 292 (goto-char (point-min)) |
269 (defun format-decode-region (from to &optional format) | 295 (defun format-decode-region (from to &optional format) |
270 "Decode the region from some format. | 296 "Decode the region from some format. |
271 Arg FORMAT is optional; if omitted the format will be determined by looking | 297 Arg FORMAT is optional; if omitted the format will be determined by looking |
272 for identifying regular expressions at the beginning of the region." | 298 for identifying regular expressions at the beginning of the region." |
273 (interactive | 299 (interactive |
274 (list (region-beginning) (region-end) | 300 (list (region-beginning) (region-end) |
275 (format-read "Translate region from format (default: guess): "))) | 301 (format-read "Translate region from format (default: guess): "))) |
276 (save-excursion | 302 (save-excursion |
277 (goto-char from) | 303 (goto-char from) |
278 (format-decode format (- to from) nil))) | 304 (format-decode format (- to from) nil))) |
279 | 305 |
285 (list (format-read (format "Translate buffer to format (default %s): " | 311 (list (format-read (format "Translate buffer to format (default %s): " |
286 buffer-file-format)))) | 312 buffer-file-format)))) |
287 (format-encode-region (point-min) (point-max) format)) | 313 (format-encode-region (point-min) (point-max) format)) |
288 | 314 |
289 (defun format-encode-region (beg end &optional format) | 315 (defun format-encode-region (beg end &optional format) |
290 "Translate the region into some FORMAT. | 316 "Translate the region into some FORMAT. |
291 FORMAT defaults to `buffer-file-format', it is a symbol naming | 317 FORMAT defaults to `buffer-file-format', it is a symbol naming |
292 one of the formats defined in `format-alist', or a list of such symbols." | 318 one of the formats defined in `format-alist', or a list of such symbols." |
293 (interactive | 319 (interactive |
294 (list (region-beginning) (region-end) | 320 (list (region-beginning) (region-end) |
295 (format-read (format "Translate region to format (default %s): " | 321 (format-read (format "Translate region to format (default %s): " |
296 buffer-file-format)))) | 322 buffer-file-format)))) |
297 (if (null format) (setq format buffer-file-format)) | 323 (if (null format) (setq format buffer-file-format)) |
298 (if (symbolp format) (setq format (list format))) | 324 (if (symbolp format) (setq format (list format))) |
299 (save-excursion | 325 (save-excursion |
300 (goto-char end) | 326 (goto-char end) |
301 (let ((cur-buf (current-buffer)) | 327 (let ((cur-buf (current-buffer)) |
302 (end (point-marker))) | 328 (end (point-marker))) |
303 (while format | 329 (while format |
304 (let* ((info (assq (car format) format-alist)) | 330 (let* ((info (assq (car format) format-alist)) |
305 (to-fn (nth 4 info)) | 331 (to-fn (nth 4 info)) |
306 (modify (nth 5 info)) | 332 (modify (nth 5 info)) |
307 result) | 333 result) |
308 (if to-fn | 334 (if to-fn |
309 (if modify | 335 (if modify |
310 (setq end (format-encode-run-method to-fn beg end | 336 (setq end (format-encode-run-method to-fn beg end |
311 (current-buffer))) | 337 (current-buffer))) |
312 (format-insert-annotations | 338 (format-insert-annotations |
313 (funcall to-fn beg end (current-buffer))))) | 339 (funcall to-fn beg end (current-buffer))))) |
314 (setq format (cdr format))))))) | 340 (setq format (cdr format))))))) |
315 | 341 |
316 (defun format-write-file (filename format) | 342 (defun format-write-file (filename format) |
317 "Write current buffer into a FILE using some FORMAT. | 343 "Write current buffer into file FILENAME using some FORMAT. |
318 Makes buffer visit that file and sets the format as the default for future | 344 Makes buffer visit that file and sets the format as the default for future |
319 saves. If the buffer is already visiting a file, you can specify a directory | 345 saves. If the buffer is already visiting a file, you can specify a directory |
320 name as FILE, to write a file of the same old name in that directory." | 346 name as FILENAME, to write a file of the same old name in that directory." |
321 (interactive | 347 (interactive |
322 ;; Same interactive spec as write-file, plus format question. | 348 ;; Same interactive spec as write-file, plus format question. |
323 (let* ((file (if buffer-file-name | 349 (let* ((file (if buffer-file-name |
324 (read-file-name "Write file: " | 350 (read-file-name "Write file: " |
325 nil nil nil nil) | 351 nil nil nil nil) |
326 (read-file-name "Write file: " | 352 (read-file-name "Write file: " |
327 (cdr (assq 'default-directory | 353 (cdr (assq 'default-directory |
328 (buffer-local-variables))) | 354 (buffer-local-variables))) |
329 nil nil (buffer-name)))) | 355 nil nil (buffer-name)))) |
330 (fmt (format-read (format "Write file `%s' in format: " | 356 (fmt (format-read (format "Write file `%s' in format: " |
331 (file-name-nondirectory file))))) | 357 (file-name-nondirectory file))))) |
332 (list file fmt))) | 358 (list file fmt))) |
333 (setq buffer-file-format format) | 359 (setq buffer-file-format format) |
334 (write-file filename)) | 360 (write-file filename)) |
335 | 361 |
336 (defun format-find-file (filename format) | 362 (defun format-find-file (filename format) |
337 "Find the file FILE using data format FORMAT. | 363 "Find the file FILENAME using data format FORMAT. |
338 If FORMAT is nil then do not do any format conversion." | 364 If FORMAT is nil then do not do any format conversion." |
339 (interactive | 365 (interactive |
340 ;; Same interactive spec as write-file, plus format question. | 366 ;; Same interactive spec as write-file, plus format question. |
341 (let* ((file (read-file-name "Find file: ")) | 367 (let* ((file (read-file-name "Find file: ")) |
342 (fmt (format-read (format "Read file `%s' in format: " | 368 (fmt (format-read (format "Read file `%s' in format: " |
343 (file-name-nondirectory file))))) | 369 (file-name-nondirectory file))))) |
344 (list file fmt))) | 370 (list file fmt))) |
345 (let ((format-alist nil)) | 371 (let ((format-alist nil)) |
346 (find-file filename)) | 372 (find-file filename)) |
347 (if format | 373 (if format |
348 (format-decode-buffer format))) | 374 (format-decode-buffer format))) |
349 | 375 |
350 (defun format-insert-file (filename format &optional beg end) | 376 (defun format-insert-file (filename format &optional beg end) |
351 "Insert the contents of file FILE using data format FORMAT. | 377 "Insert the contents of file FILENAME using data format FORMAT. |
352 If FORMAT is nil then do not do any format conversion. | 378 If FORMAT is nil then do not do any format conversion. |
353 The optional third and fourth arguments BEG and END specify | 379 The optional third and fourth arguments BEG and END specify |
354 the part of the file to read. | 380 the part of the file to read. |
355 | 381 |
356 The return value is like the value of `insert-file-contents': | 382 The return value is like the value of `insert-file-contents': |
357 a list (ABSOLUTE-FILE-NAME . SIZE)." | 383 a list (ABSOLUTE-FILE-NAME . SIZE)." |
358 (interactive | 384 (interactive |
359 ;; Same interactive spec as write-file, plus format question. | 385 ;; Same interactive spec as write-file, plus format question. |
360 (let* ((file (read-file-name "Find file: ")) | 386 (let* ((file (read-file-name "Find file: ")) |
361 (fmt (format-read (format "Read file `%s' in format: " | 387 (fmt (format-read (format "Read file `%s' in format: " |
362 (file-name-nondirectory file))))) | 388 (file-name-nondirectory file))))) |
363 (list file fmt))) | 389 (list file fmt))) |
364 (let (value size) | 390 (let (value size) |
365 (let ((format-alist nil)) | 391 (let ((format-alist nil)) |
366 (setq value (insert-file-contents filename nil beg end)) | 392 (setq value (insert-file-contents filename nil beg end)) |
389 "Do multiple replacements on the buffer. | 415 "Do multiple replacements on the buffer. |
390 ALIST is a list of (from . to) pairs, which should be proper arguments to | 416 ALIST is a list of (from . to) pairs, which should be proper arguments to |
391 `search-forward' and `replace-match' respectively. | 417 `search-forward' and `replace-match' respectively. |
392 Optional 2nd arg REVERSE, if non-nil, means the pairs are (to . from), so that | 418 Optional 2nd arg REVERSE, if non-nil, means the pairs are (to . from), so that |
393 you can use the same list in both directions if it contains only literal | 419 you can use the same list in both directions if it contains only literal |
394 strings. | 420 strings. |
395 Optional args BEGIN and END specify a region of the buffer to operate on." | 421 Optional args BEG and END specify a region of the buffer on which to operate." |
396 (save-excursion | 422 (save-excursion |
397 (save-restriction | 423 (save-restriction |
398 (or beg (setq beg (point-min))) | 424 (or beg (setq beg (point-min))) |
399 (if end (narrow-to-region (point-min) end)) | 425 (if end (narrow-to-region (point-min) end)) |
400 (while alist | 426 (while alist |
411 (setq alist (cdr alist))))))) | 437 (setq alist (cdr alist))))))) |
412 | 438 |
413 ;;; Some list-manipulation functions that we need. | 439 ;;; Some list-manipulation functions that we need. |
414 | 440 |
415 (defun format-delq-cons (cons list) | 441 (defun format-delq-cons (cons list) |
416 "Remove the given CONS from LIST by side effect, | 442 "Remove the given CONS from LIST by side effect and return the new LIST. |
417 and return the new LIST. Since CONS could be the first element | 443 Since CONS could be the first element of LIST, write |
418 of LIST, write `\(setq foo \(format-delq-cons element foo))' to be sure of | 444 `\(setq foo \(format-delq-cons element foo))' to be sure of changing |
419 changing the value of `foo'." | 445 the value of `foo'." |
420 (if (eq cons list) | 446 (if (eq cons list) |
421 (cdr list) | 447 (cdr list) |
422 (let ((p list)) | 448 (let ((p list)) |
423 (while (not (eq (cdr p) cons)) | 449 (while (not (eq (cdr p) cons)) |
424 (if (null p) (error "format-delq-cons: not an element.")) | 450 (if (null p) (error "format-delq-cons: not an element.")) |
447 equivalent part of B. If even the last items of the two are not equal, | 473 equivalent part of B. If even the last items of the two are not equal, |
448 returns nil." | 474 returns nil." |
449 (let ((la (length a)) | 475 (let ((la (length a)) |
450 (lb (length b))) | 476 (lb (length b))) |
451 ;; Make sure they are the same length | 477 ;; Make sure they are the same length |
452 (if (> la lb) | 478 (if (> la lb) |
453 (setq a (nthcdr (- la lb) a)) | 479 (setq a (nthcdr (- la lb) a)) |
454 (setq b (nthcdr (- lb la) b)))) | 480 (setq b (nthcdr (- lb la) b)))) |
455 (while (not (equal a b)) | 481 (while (not (equal a b)) |
456 (setq a (cdr a) | 482 (setq a (cdr a) |
457 b (cdr b))) | 483 b (cdr b))) |
462 Elements of ITEMS equal to elements of ORDER will be rearranged to follow the | 488 Elements of ITEMS equal to elements of ORDER will be rearranged to follow the |
463 ORDER. Unmatched items will go last." | 489 ORDER. Unmatched items will go last." |
464 (if order | 490 (if order |
465 (let ((item (member (car order) items))) | 491 (let ((item (member (car order) items))) |
466 (if item | 492 (if item |
467 (cons (car item) | 493 (cons (car item) |
468 (format-reorder (format-delq-cons item items) | 494 (format-reorder (format-delq-cons item items) |
469 (cdr order))) | 495 (cdr order))) |
470 (format-reorder items (cdr order)))) | 496 (format-reorder items (cdr order)))) |
471 items)) | 497 items)) |
472 | 498 |
480 ;;; Decoding | 506 ;;; Decoding |
481 ;;; | 507 ;;; |
482 | 508 |
483 (defun format-deannotate-region (from to translations next-fn) | 509 (defun format-deannotate-region (from to translations next-fn) |
484 "Translate annotations in the region into text properties. | 510 "Translate annotations in the region into text properties. |
485 This sets text properties between FROM to TO as directed by the | 511 This sets text properties between FROM to TO as directed by the |
486 TRANSLATIONS and NEXT-FN arguments. | 512 TRANSLATIONS and NEXT-FN arguments. |
487 | 513 |
488 NEXT-FN is a function that searches forward from point for an annotation. | 514 NEXT-FN is a function that searches forward from point for an annotation. |
489 It should return a list of 4 elements: \(BEGIN END NAME POSITIVE). BEGIN and | 515 It should return a list of 4 elements: \(BEGIN END NAME POSITIVE). BEGIN and |
490 END are buffer positions bounding the annotation, NAME is the name searched | 516 END are buffer positions bounding the annotation, NAME is the name searched |
667 | 693 |
668 (if unknown-ans | 694 (if unknown-ans |
669 (message "Unknown annotations: %s" unknown-ans)))))) | 695 (message "Unknown annotations: %s" unknown-ans)))))) |
670 | 696 |
671 (defun format-subtract-regions (minu subtra) | 697 (defun format-subtract-regions (minu subtra) |
672 "Remove the regions in SUBTRAHEND from the regions in MINUEND. A region | 698 "Remove from the regions in MINUend the regions in SUBTRAhend. |
673 is a dotted pair (from . to). Both parameters are lists of regions. Each | 699 A region is a dotted pair (from . to). Both parameters are lists of |
674 list must contain nonoverlapping, noncontiguous regions, in descending | 700 regions. Each list must contain nonoverlapping, noncontiguous |
675 order. The result is also nonoverlapping, noncontiguous, and in descending | 701 regions, in descending order. The result is also nonoverlapping, |
676 order. The first element of MINUEND can have a cdr of nil, indicating that | 702 noncontiguous, and in descending order. The first element of MINUEND |
677 the end of that region is not yet known." | 703 can have a cdr of nil, indicating that the end of that region is not |
704 yet known." | |
678 (let* ((minuend (copy-alist minu)) | 705 (let* ((minuend (copy-alist minu)) |
679 (subtrahend (copy-alist subtra)) | 706 (subtrahend (copy-alist subtra)) |
680 (m (car minuend)) | 707 (m (car minuend)) |
681 (s (car subtrahend)) | 708 (s (car subtrahend)) |
682 results) | 709 results) |
683 (while (and minuend subtrahend) | 710 (while (and minuend subtrahend) |
684 (cond | 711 (cond |
685 ;; The minuend starts after the subtrahend ends; keep it. | 712 ;; The minuend starts after the subtrahend ends; keep it. |
686 ((> (car m) (cdr s)) | 713 ((> (car m) (cdr s)) |
687 (setq results (cons m results) | 714 (setq results (cons m results) |
688 minuend (cdr minuend) | 715 minuend (cdr minuend) |
689 m (car minuend))) | 716 m (car minuend))) |
705 ;; This should probably go somewhere other than format.el. Then again, | 732 ;; This should probably go somewhere other than format.el. Then again, |
706 ;; indent.el has alter-text-property. NOTE: We can also use | 733 ;; indent.el has alter-text-property. NOTE: We can also use |
707 ;; next-single-property-change instead of text-property-not-all, but then | 734 ;; next-single-property-change instead of text-property-not-all, but then |
708 ;; we have to see if we passed TO. | 735 ;; we have to see if we passed TO. |
709 (defun format-property-increment-region (from to prop delta default) | 736 (defun format-property-increment-region (from to prop delta default) |
710 "Increment property PROP over the region between FROM and TO by the | 737 "Over the region between FROM and TO increment property PROP by amount DELTA. |
711 amount DELTA (which may be negative). If property PROP is nil anywhere | 738 DELTA may be negative. If property PROP is nil anywhere |
712 in the region, it is treated as though it were DEFAULT." | 739 in the region, it is treated as though it were DEFAULT." |
713 (let ((cur from) val newval next) | 740 (let ((cur from) val newval next) |
714 (while cur | 741 (while cur |
715 (setq val (get-text-property cur prop) | 742 (setq val (get-text-property cur prop) |
716 newval (+ (or val default) delta) | 743 newval (+ (or val default) delta) |
727 Inserts each element of the given LIST of buffer annotations at its | 754 Inserts each element of the given LIST of buffer annotations at its |
728 appropriate place. Use second arg OFFSET if the annotations' locations are | 755 appropriate place. Use second arg OFFSET if the annotations' locations are |
729 not relative to the beginning of the buffer: annotations will be inserted | 756 not relative to the beginning of the buffer: annotations will be inserted |
730 at their location-OFFSET+1 \(ie, the offset is treated as the character number | 757 at their location-OFFSET+1 \(ie, the offset is treated as the character number |
731 of the first character in the buffer)." | 758 of the first character in the buffer)." |
732 (if (not offset) | 759 (if (not offset) |
733 (setq offset 0) | 760 (setq offset 0) |
734 (setq offset (1- offset))) | 761 (setq offset (1- offset))) |
735 (let ((l (reverse list))) | 762 (let ((l (reverse list))) |
736 (while l | 763 (while l |
737 (goto-char (- (car (car l)) offset)) | 764 (goto-char (- (car (car l)) offset)) |
744 property is the name of the annotation that you want to use, as it is for the | 771 property is the name of the annotation that you want to use, as it is for the |
745 `unknown' text property." | 772 `unknown' text property." |
746 (cons (if old (list old)) | 773 (cons (if old (list old)) |
747 (if new (list new)))) | 774 (if new (list new)))) |
748 | 775 |
749 (defun format-annotate-region (from to trans format-fn ignore) | 776 (defun format-annotate-region (from to translations format-fn ignore) |
750 "Generate annotations for text properties in the region. | 777 "Generate annotations for text properties in the region. |
751 Searches for changes between FROM and TO, and describes them with a list of | 778 Searches for changes between FROM and TO, and describes them with a list of |
752 annotations as defined by alist TRANSLATIONS and FORMAT-FN. IGNORE lists text | 779 annotations as defined by alist TRANSLATIONS and FORMAT-FN. IGNORE lists text |
753 properties not to consider; any text properties that are neither ignored nor | 780 properties not to consider; any text properties that are neither ignored nor |
754 listed in TRANSLATIONS are warned about. | 781 listed in TRANSLATIONS are warned about. |
761 elements are VALUES of that property followed by the names of zero or more | 788 elements are VALUES of that property followed by the names of zero or more |
762 ANNOTATIONS. Whenever the property takes on that value, the annotations | 789 ANNOTATIONS. Whenever the property takes on that value, the annotations |
763 \(as formatted by FORMAT-FN) are inserted into the file. | 790 \(as formatted by FORMAT-FN) are inserted into the file. |
764 When the property stops having that value, the matching negated annotation | 791 When the property stops having that value, the matching negated annotation |
765 will be inserted \(it may actually be closed earlier and reopened, if | 792 will be inserted \(it may actually be closed earlier and reopened, if |
766 necessary, to keep proper nesting). | 793 necessary, to keep proper nesting). |
767 | 794 |
768 If the property's value is a list, then each element of the list is dealt with | 795 If the property's value is a list, then each element of the list is dealt with |
769 separately. | 796 separately. |
770 | 797 |
771 If a VALUE is numeric, then it is assumed that there is a single annotation | 798 If a VALUE is numeric, then it is assumed that there is a single annotation |
786 (not-found nil)) ; Properties that couldn't be saved | 813 (not-found nil)) ; Properties that couldn't be saved |
787 (while (or (null loc) | 814 (while (or (null loc) |
788 (and (setq loc (next-property-change loc nil to)) | 815 (and (setq loc (next-property-change loc nil to)) |
789 (< loc to))) | 816 (< loc to))) |
790 (or loc (setq loc from)) | 817 (or loc (setq loc from)) |
791 (let* ((ans (format-annotate-location loc (= loc from) ignore trans)) | 818 (let* ((ans (format-annotate-location loc (= loc from) ignore translations)) |
792 (neg-ans (format-reorder (aref ans 0) open-ans)) | 819 (neg-ans (format-reorder (aref ans 0) open-ans)) |
793 (pos-ans (aref ans 1)) | 820 (pos-ans (aref ans 1)) |
794 (ignored (aref ans 2))) | 821 (ignored (aref ans 2))) |
795 (setq not-found (append ignored not-found) | 822 (setq not-found (append ignored not-found) |
796 ignore (append ignored ignore)) | 823 ignore (append ignored ignore)) |
803 (message "Can't close %s: not open." (car neg-ans)) | 830 (message "Can't close %s: not open." (car neg-ans)) |
804 (while (not (equal (car neg-ans) (car open-ans))) | 831 (while (not (equal (car neg-ans) (car open-ans))) |
805 ;; To close anno. N, need to first close ans 1 to N-1, | 832 ;; To close anno. N, need to first close ans 1 to N-1, |
806 ;; remembering to re-open them later. | 833 ;; remembering to re-open them later. |
807 (setq pos-ans (cons (car open-ans) pos-ans)) | 834 (setq pos-ans (cons (car open-ans) pos-ans)) |
808 (setq all-ans | 835 (setq all-ans |
809 (cons (cons loc (funcall format-fn (car open-ans) nil)) | 836 (cons (cons loc (funcall format-fn (car open-ans) nil)) |
810 all-ans)) | 837 all-ans)) |
811 (setq open-ans (cdr open-ans))) | 838 (setq open-ans (cdr open-ans))) |
812 ;; Now remove the one we're really interested in from open list. | 839 ;; Now remove the one we're really interested in from open list. |
813 (setq open-ans (cdr open-ans)) | 840 (setq open-ans (cdr open-ans)) |
814 ;; And put the closing annotation here. | 841 ;; And put the closing annotation here. |
815 (setq all-ans | 842 (setq all-ans |
816 (cons (cons loc (funcall format-fn (car neg-ans) nil)) | 843 (cons (cons loc (funcall format-fn (car neg-ans) nil)) |
817 all-ans))) | 844 all-ans))) |
818 (setq neg-ans (cdr neg-ans))) | 845 (setq neg-ans (cdr neg-ans))) |
819 ;; Now deal with positive (opening) annotations | 846 ;; Now deal with positive (opening) annotations |
820 (let ((p pos-ans)) | 847 (let ((p pos-ans)) |
821 (while pos-ans | 848 (while pos-ans |
822 (setq open-ans (cons (car pos-ans) open-ans)) | 849 (setq open-ans (cons (car pos-ans) open-ans)) |
823 (setq all-ans | 850 (setq all-ans |
824 (cons (cons loc (funcall format-fn (car pos-ans) t)) | 851 (cons (cons loc (funcall format-fn (car pos-ans) t)) |
825 all-ans)) | 852 all-ans)) |
826 (setq pos-ans (cdr pos-ans)))))) | 853 (setq pos-ans (cdr pos-ans)))))) |
827 | 854 |
828 ;; Close any annotations still open | 855 ;; Close any annotations still open |
829 (while open-ans | 856 (while open-ans |
830 (setq all-ans | 857 (setq all-ans |
831 (cons (cons to (funcall format-fn (car open-ans) nil)) | 858 (cons (cons to (funcall format-fn (car open-ans) nil)) |
832 all-ans)) | 859 all-ans)) |
833 (setq open-ans (cdr open-ans))) | 860 (setq open-ans (cdr open-ans))) |
834 (if not-found | 861 (if not-found |
835 (message "These text properties could not be saved:\n %s" | 862 (message "These text properties could not be saved:\n %s" |
836 not-found)) | 863 not-found)) |
837 (nreverse all-ans))) | 864 (nreverse all-ans))) |
838 | 865 |
839 ;;; Internal functions for format-annotate-region. | 866 ;;; Internal functions for format-annotate-region. |
840 | 867 |
841 (defun format-annotate-location (loc all ignore trans) | 868 (defun format-annotate-location (loc all ignore translations) |
842 "Return annotation(s) needed at LOCATION. | 869 "Return annotation(s) needed at location LOC. |
843 This includes any properties that change between LOC-1 and LOC. | 870 This includes any properties that change between LOC-1 and LOC. |
844 If ALL is true, don't look at previous location, but generate annotations for | 871 If ALL is true, don't look at previous location, but generate annotations for |
845 all non-nil properties. | 872 all non-nil properties. |
846 Third argument IGNORE is a list of text-properties not to consider. | 873 Third argument IGNORE is a list of text-properties not to consider. |
874 Use the TRANSLATIONS alist. | |
847 | 875 |
848 Return value is a vector of 3 elements: | 876 Return value is a vector of 3 elements: |
849 1. List of names of the annotations to close | 877 1. List of names of the annotations to close |
850 2. List of the names of annotations to open. | 878 2. List of the names of annotations to open. |
851 3. List of properties that were ignored or couldn't be annotated." | 879 3. List of properties that were ignored or couldn't be annotated." |
873 (let ((before (if all nil (car (cdr (memq prop before-plist))))) | 901 (let ((before (if all nil (car (cdr (memq prop before-plist))))) |
874 (after (car (cdr (memq prop after-plist))))) | 902 (after (car (cdr (memq prop after-plist))))) |
875 (if (equal before after) | 903 (if (equal before after) |
876 nil ; no change; ignore | 904 nil ; no change; ignore |
877 (let ((result (format-annotate-single-property-change | 905 (let ((result (format-annotate-single-property-change |
878 prop before after trans))) | 906 prop before after translations))) |
879 (if (not result) | 907 (if (not result) |
880 (setq not-found (cons prop not-found)) | 908 (setq not-found (cons prop not-found)) |
881 (setq negatives (nconc negatives (car result)) | 909 (setq negatives (nconc negatives (car result)) |
882 positives (nconc positives (cdr result))))))))) | 910 positives (nconc positives (cdr result))))))))) |
883 (vector negatives positives not-found))) | 911 (vector negatives positives not-found))) |
884 | 912 |
885 (defun format-annotate-single-property-change (prop old new trans) | 913 (defun format-annotate-single-property-change (prop old new trans) |
886 "Return annotations for PROPERTY changing from OLD to NEW. | 914 "Return annotations for property PROP changing from OLD to NEW. |
887 These are searched for in the TRANSLATIONS alist. | 915 These are searched for in the translations alist TRANS. |
888 If NEW does not appear in the list, but there is a default function, then that | 916 If NEW does not appear in the list, but there is a default function, then that |
889 function is called. | 917 function is called. |
890 Annotations to open and to close are returned as a dotted pair." | 918 Annotations to open and to close are returned as a dotted pair." |
891 (let ((prop-alist (cdr (assoc prop trans))) | 919 (let ((prop-alist (cdr (assoc prop trans))) |
892 default) | 920 default) |
897 (let* ((old (if (listp old) old (list old))) | 925 (let* ((old (if (listp old) old (list old))) |
898 (new (if (listp new) new (list new))) | 926 (new (if (listp new) new (list new))) |
899 (tail (format-common-tail old new)) | 927 (tail (format-common-tail old new)) |
900 close open) | 928 close open) |
901 (while old | 929 (while old |
902 (setq close | 930 (setq close |
903 (append (car (format-annotate-atomic-property-change | 931 (append (car (format-annotate-atomic-property-change |
904 prop-alist (car old) nil)) | 932 prop-alist (car old) nil)) |
905 close) | 933 close) |
906 old (cdr old))) | 934 old (cdr old))) |
907 (while new | 935 (while new |
908 (setq open | 936 (setq open |
909 (append (cdr (format-annotate-atomic-property-change | 937 (append (cdr (format-annotate-atomic-property-change |
910 prop-alist nil (car new))) | 938 prop-alist nil (car new))) |
911 open) | 939 open) |
912 new (cdr new))) | 940 new (cdr new))) |
913 (format-make-relatively-unique close open)) | 941 (format-make-relatively-unique close open)) |
952 (let ((default (assq nil prop-alist))) | 980 (let ((default (assq nil prop-alist))) |
953 (if default | 981 (if default |
954 (funcall (car (cdr default)) old new)))))))) | 982 (funcall (car (cdr default)) old new)))))))) |
955 | 983 |
956 (provide 'format) | 984 (provide 'format) |
957 ;; format.el ends here | 985 |
986 ;;; format.el ends here |