Mercurial > emacs
annotate lisp/format.el @ 24419:30e478cd167e
(shell-command-default-error-buffer): Renamed from
shell-command-on-region-default-error-buffer.
(shell-command-on-region): Mention in echo area when there
is some error output. Mention success or failure, too.
Accumulate multiple error outputs
going forward, with formfeed in between. Display the error buffer
when we have put something in it.
(shell-command): Add the ERROR-BUFFER argument feature.
author | Karl Heuer <kwzh@gnu.org> |
---|---|
date | Mon, 01 Mar 1999 03:19:32 +0000 |
parents | eb03024d18fc |
children | 583275537b14 |
rev | line source |
---|---|
13352 | 1 ;;; format.el --- read and save files in multiple formats |
14169 | 2 |
24156 | 3 ;; Copyright (c) 1994, 1995, 1997, 1999 Free Software Foundation |
11054 | 4 |
24156 | 5 ;; Author: Boris Goldowsky <boris@gnu.org> |
11054 | 6 |
7 ;; This file is part of GNU Emacs. | |
8 | |
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 | |
11 ;; the Free Software Foundation; either version 2, or (at your option) | |
12 ;; any later version. | |
14169 | 13 |
11054 | 14 ;; GNU Emacs is distributed in the hope that it will be useful, |
15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
17 ;; GNU General Public License for more details. | |
14169 | 18 |
11054 | 19 ;; You should have received a copy of the GNU General Public License |
14169 | 20 ;; along with GNU Emacs; see the file COPYING. If not, write to the |
21 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, | |
22 ;; Boston, MA 02111-1307, USA. | |
11054 | 23 |
24 ;;; Commentary: | |
14169 | 25 |
26 ;; This file defines a unified mechanism for saving & loading files stored | |
27 ;; in different formats. `format-alist' contains information that directs | |
11054 | 28 ;; Emacs to call an encoding or decoding function when reading or writing |
24156 | 29 ;; files that match certain conditions. |
11054 | 30 ;; |
14169 | 31 ;; When a file is visited, its format is determined by matching the |
32 ;; beginning of the file against regular expressions stored in | |
33 ;; `format-alist'. If this fails, you can manually translate the buffer | |
34 ;; using `format-decode-buffer'. In either case, the formats used are | |
35 ;; listed in the variable `buffer-file-format', and become the default | |
36 ;; format for saving the buffer. To save a buffer in a different format, | |
37 ;; change this variable, or use `format-write-file'. | |
11054 | 38 ;; |
39 ;; Auto-save files are normally created in the same format as the visited | |
14169 | 40 ;; file, but the variable `auto-save-file-format' can be set to a |
41 ;; particularly fast or otherwise preferred format to be used for | |
42 ;; auto-saving (or nil to do no encoding on auto-save files, but then you | |
43 ;; risk losing any text-properties in the buffer). | |
11054 | 44 ;; |
14169 | 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'. | |
47 ;; To translate just the region use the functions `format-encode-region' | |
24156 | 48 ;; and `format-decode-region'. |
11054 | 49 ;; |
14169 | 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 | |
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 | |
54 ;; encoding and decoding functions: | |
55 ;; * `format-annotate-region' and `format-deannotate-region' allow a | |
56 ;; single alist of information to be used for encoding and decoding. | |
57 ;; The alist defines a correspondence between strings in the file | |
58 ;; ("annotations") and text-properties in the buffer. | |
11054 | 59 ;; * `format-replace-strings' is similarly useful for doing simple |
60 ;; string->string translations in a reversible manner. | |
61 | |
14169 | 62 ;;; Code: |
63 | |
11054 | 64 (put 'buffer-file-format 'permanent-local t) |
65 | |
24156 | 66 (defvar format-alist |
18690
df8ab82c73f3
(format-alist): Don't handle compression here.
Richard M. Stallman <rms@gnu.org>
parents:
18140
diff
changeset
|
67 '((text/enriched "Extended MIME text/enriched format." |
11054 | 68 "Content-[Tt]ype:[ \t]*text/enriched" |
69 enriched-decode enriched-encode t enriched-mode) | |
18140
f16cf00a2f42
(format-insert-file): Fix arg order to format-decode.
Richard M. Stallman <rms@gnu.org>
parents:
16954
diff
changeset
|
70 (plain "ISO 8859-1 standard format, no text properties." |
11054 | 71 ;; Plain only exists so that there is an obvious neutral choice in |
72 ;; the completion list. | |
18140
f16cf00a2f42
(format-insert-file): Fix arg order to format-decode.
Richard M. Stallman <rms@gnu.org>
parents:
16954
diff
changeset
|
73 nil nil nil nil nil) |
24156 | 74 (ibm "IBM Code Page 850 (DOS)" |
75 nil ; The original "1\\(^\\)" is obscure. | |
22051
3e5822a3448d
(format-alist): Use -f when running recode.
Richard M. Stallman <rms@gnu.org>
parents:
20087
diff
changeset
|
76 "recode -f ibm-pc:latin1" "recode -f latin1:ibm-pc" t nil) |
24156 | 77 (mac "Apple Macintosh" |
78 nil | |
22051
3e5822a3448d
(format-alist): Use -f when running recode.
Richard M. Stallman <rms@gnu.org>
parents:
20087
diff
changeset
|
79 "recode -f mac:latin1" "recode -f latin1:mac" t nil) |
24156 | 80 (hp "HP Roman8" |
81 nil | |
22051
3e5822a3448d
(format-alist): Use -f when running recode.
Richard M. Stallman <rms@gnu.org>
parents:
20087
diff
changeset
|
82 "recode -f roman8:latin1" "recode -f latin1:roman8" t nil) |
24156 | 83 (TeX "TeX (encoding)" |
84 nil | |
18140
f16cf00a2f42
(format-insert-file): Fix arg order to format-decode.
Richard M. Stallman <rms@gnu.org>
parents:
16954
diff
changeset
|
85 iso-tex2iso iso-iso2tex t nil) |
24156 | 86 (gtex "German TeX (encoding)" |
87 nil | |
18140
f16cf00a2f42
(format-insert-file): Fix arg order to format-decode.
Richard M. Stallman <rms@gnu.org>
parents:
16954
diff
changeset
|
88 iso-gtex2iso iso-iso2gtex t nil) |
24156 | 89 (html "HTML (encoding)" |
90 nil | |
22051
3e5822a3448d
(format-alist): Use -f when running recode.
Richard M. Stallman <rms@gnu.org>
parents:
20087
diff
changeset
|
91 "recode -f html:latin1" "recode -f latin1:html" t nil) |
24156 | 92 (rot13 "rot13" |
93 nil | |
18140
f16cf00a2f42
(format-insert-file): Fix arg order to format-decode.
Richard M. Stallman <rms@gnu.org>
parents:
16954
diff
changeset
|
94 "tr a-mn-z n-za-m" "tr a-mn-z n-za-m" t nil) |
24156 | 95 (duden "Duden Ersatzdarstellung" |
96 nil | |
97 "diac" iso-iso2duden t nil) | |
98 (de646 "German ASCII (ISO 646)" | |
99 nil | |
22051
3e5822a3448d
(format-alist): Use -f when running recode.
Richard M. Stallman <rms@gnu.org>
parents:
20087
diff
changeset
|
100 "recode -f iso646-ge:latin1" "recode -f latin1:iso646-ge" t nil) |
24156 | 101 (denet "net German" |
102 nil | |
18140
f16cf00a2f42
(format-insert-file): Fix arg order to format-decode.
Richard M. Stallman <rms@gnu.org>
parents:
16954
diff
changeset
|
103 iso-german iso-cvt-read-only t nil) |
24156 | 104 (esnet "net Spanish" |
105 nil | |
18690
df8ab82c73f3
(format-alist): Don't handle compression here.
Richard M. Stallman <rms@gnu.org>
parents:
18140
diff
changeset
|
106 iso-spanish iso-cvt-read-only t nil)) |
11054 | 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). | |
19244
dc92be3441cd
(format-alist): Doc fix.
Richard M. Stallman <rms@gnu.org>
parents:
19235
diff
changeset
|
109 |
11054 | 110 NAME is a symbol, which is stored in `buffer-file-format'. |
19244
dc92be3441cd
(format-alist): Doc fix.
Richard M. Stallman <rms@gnu.org>
parents:
19235
diff
changeset
|
111 |
11054 | 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 | |
114 the user if they ask for more information. | |
19244
dc92be3441cd
(format-alist): Doc fix.
Richard M. Stallman <rms@gnu.org>
parents:
19235
diff
changeset
|
115 |
11054 | 116 REGEXP is a regular expression to match against the beginning of the file; |
24156 | 117 it should match only files in that format. Use nil to avoid |
118 matching at all for formats for which this isn't appropriate to | |
119 require explicit encoding/decoding. | |
19244
dc92be3441cd
(format-alist): Doc fix.
Richard M. Stallman <rms@gnu.org>
parents:
19235
diff
changeset
|
120 |
24156 | 121 FROM-FN is called to decode files in that format; it gets two args, BEGIN |
11054 | 122 and END, and can make any modifications it likes, returning the new |
123 end. It must make sure that the beginning of the file no longer | |
124 matches REGEXP, or else it will get called again. | |
19245
33adb5cee0b0
(format-alist): Doc fix.
Richard M. Stallman <rms@gnu.org>
parents:
19244
diff
changeset
|
125 Alternatively, FROM-FN can be a string, which specifies a shell command |
33adb5cee0b0
(format-alist): Doc fix.
Richard M. Stallman <rms@gnu.org>
parents:
19244
diff
changeset
|
126 (including options) to be used as a filter to perform the conversion. |
19244
dc92be3441cd
(format-alist): Doc fix.
Richard M. Stallman <rms@gnu.org>
parents:
19235
diff
changeset
|
127 |
16020
0f704de0600f
(format-alist): Doc fix.
Richard M. Stallman <rms@gnu.org>
parents:
14452
diff
changeset
|
128 TO-FN is called to encode a region into that format; it is passed three |
0f704de0600f
(format-alist): Doc fix.
Richard M. Stallman <rms@gnu.org>
parents:
14452
diff
changeset
|
129 arguments: BEGIN, END, and BUFFER. BUFFER is the original buffer that |
0f704de0600f
(format-alist): Doc fix.
Richard M. Stallman <rms@gnu.org>
parents:
14452
diff
changeset
|
130 the data being written came from, which the function could use, for |
0f704de0600f
(format-alist): Doc fix.
Richard M. Stallman <rms@gnu.org>
parents:
14452
diff
changeset
|
131 example, to find the values of local variables. TO-FN should either |
0f704de0600f
(format-alist): Doc fix.
Richard M. Stallman <rms@gnu.org>
parents:
14452
diff
changeset
|
132 return a list of annotations like `write-region-annotate-functions', |
0f704de0600f
(format-alist): Doc fix.
Richard M. Stallman <rms@gnu.org>
parents:
14452
diff
changeset
|
133 or modify the region and return the new end. |
19245
33adb5cee0b0
(format-alist): Doc fix.
Richard M. Stallman <rms@gnu.org>
parents:
19244
diff
changeset
|
134 Alternatively, TO-FN can be a string, which specifies a shell command |
33adb5cee0b0
(format-alist): Doc fix.
Richard M. Stallman <rms@gnu.org>
parents:
19244
diff
changeset
|
135 (including options) to be used as a filter to perform the conversion. |
19244
dc92be3441cd
(format-alist): Doc fix.
Richard M. Stallman <rms@gnu.org>
parents:
19235
diff
changeset
|
136 |
16020
0f704de0600f
(format-alist): Doc fix.
Richard M. Stallman <rms@gnu.org>
parents:
14452
diff
changeset
|
137 MODIFY, if non-nil, means the TO-FN wants to modify the region. If nil, |
0f704de0600f
(format-alist): Doc fix.
Richard M. Stallman <rms@gnu.org>
parents:
14452
diff
changeset
|
138 TO-FN will not make any changes but will instead return a list of |
24156 | 139 annotations. |
19244
dc92be3441cd
(format-alist): Doc fix.
Richard M. Stallman <rms@gnu.org>
parents:
19235
diff
changeset
|
140 |
11054 | 141 MODE-FN, if specified, is called when visiting a file with that format.") |
142 | |
143 ;;; Basic Functions (called from Lisp) | |
144 | |
18140
f16cf00a2f42
(format-insert-file): Fix arg order to format-decode.
Richard M. Stallman <rms@gnu.org>
parents:
16954
diff
changeset
|
145 (defun format-encode-run-method (method from to &optional buffer) |
f16cf00a2f42
(format-insert-file): Fix arg order to format-decode.
Richard M. Stallman <rms@gnu.org>
parents:
16954
diff
changeset
|
146 "Translate using function or shell script METHOD the text from FROM to TO. |
f16cf00a2f42
(format-insert-file): Fix arg order to format-decode.
Richard M. Stallman <rms@gnu.org>
parents:
16954
diff
changeset
|
147 If METHOD is a string, it is a shell command; |
f16cf00a2f42
(format-insert-file): Fix arg order to format-decode.
Richard M. Stallman <rms@gnu.org>
parents:
16954
diff
changeset
|
148 otherwise, it should be a Lisp function. |
f16cf00a2f42
(format-insert-file): Fix arg order to format-decode.
Richard M. Stallman <rms@gnu.org>
parents:
16954
diff
changeset
|
149 BUFFER should be the buffer that the output originally came from." |
f16cf00a2f42
(format-insert-file): Fix arg order to format-decode.
Richard M. Stallman <rms@gnu.org>
parents:
16954
diff
changeset
|
150 (if (stringp method) |
24156 | 151 (let ((error-buff (get-buffer-create "*Format Errors*")) |
24347
eb03024d18fc
(format-encode-run-method, format-decode-run-method): Fix previous change.
Dave Love <fx@gnu.org>
parents:
24315
diff
changeset
|
152 (coding-system-for-read 'no-conversion) |
24156 | 153 format-alist) |
154 (with-current-buffer error-buff | |
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"))) | |
18140
f16cf00a2f42
(format-insert-file): Fix arg order to format-decode.
Richard M. Stallman <rms@gnu.org>
parents:
16954
diff
changeset
|
165 (funcall method from to buffer))) |
f16cf00a2f42
(format-insert-file): Fix arg order to format-decode.
Richard M. Stallman <rms@gnu.org>
parents:
16954
diff
changeset
|
166 |
f16cf00a2f42
(format-insert-file): Fix arg order to format-decode.
Richard M. Stallman <rms@gnu.org>
parents:
16954
diff
changeset
|
167 (defun format-decode-run-method (method from to &optional buffer) |
f16cf00a2f42
(format-insert-file): Fix arg order to format-decode.
Richard M. Stallman <rms@gnu.org>
parents:
16954
diff
changeset
|
168 "Decode using function or shell script METHOD the text from FROM to TO. |
24156 | 169 If METHOD is a string, it is a shell command; otherwise, it should be |
170 a Lisp function. Decoding is done for the given BUFFER." | |
18140
f16cf00a2f42
(format-insert-file): Fix arg order to format-decode.
Richard M. Stallman <rms@gnu.org>
parents:
16954
diff
changeset
|
171 (if (stringp method) |
24156 | 172 (let ((error-buff (get-buffer-create "*Format Errors*")) |
24347
eb03024d18fc
(format-encode-run-method, format-decode-run-method): Fix previous change.
Dave Love <fx@gnu.org>
parents:
24315
diff
changeset
|
173 (coding-system-for-write 'no-conversion) |
24156 | 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")) | |
18140
f16cf00a2f42
(format-insert-file): Fix arg order to format-decode.
Richard M. Stallman <rms@gnu.org>
parents:
16954
diff
changeset
|
190 (point)) |
f16cf00a2f42
(format-insert-file): Fix arg order to format-decode.
Richard M. Stallman <rms@gnu.org>
parents:
16954
diff
changeset
|
191 (funcall method from to))) |
f16cf00a2f42
(format-insert-file): Fix arg order to format-decode.
Richard M. Stallman <rms@gnu.org>
parents:
16954
diff
changeset
|
192 |
16020
0f704de0600f
(format-alist): Doc fix.
Richard M. Stallman <rms@gnu.org>
parents:
14452
diff
changeset
|
193 (defun format-annotate-function (format from to orig-buf) |
24156 | 194 "Return annotations for writing region as FORMAT. |
11054 | 195 FORMAT is a symbol naming one of the formats defined in `format-alist', |
196 it must be a single symbol, not a list like `buffer-file-format'. | |
16020
0f704de0600f
(format-alist): Doc fix.
Richard M. Stallman <rms@gnu.org>
parents:
14452
diff
changeset
|
197 FROM and TO delimit the region to be operated on in the current buffer. |
0f704de0600f
(format-alist): Doc fix.
Richard M. Stallman <rms@gnu.org>
parents:
14452
diff
changeset
|
198 ORIG-BUF is the original buffer that the data came from. |
11054 | 199 This function works like a function on `write-region-annotate-functions': |
200 it either returns a list of annotations, or returns with a different buffer | |
201 current, which contains the modified text to write. | |
202 | |
203 For most purposes, consider using `format-encode-region' instead." | |
24156 | 204 ;; This function is called by write-region (actually build-annotations) |
11054 | 205 ;; for each element of buffer-file-format. |
206 (let* ((info (assq format format-alist)) | |
207 (to-fn (nth 4 info)) | |
208 (modify (nth 5 info))) | |
209 (if to-fn | |
210 (if modify | |
211 ;; To-function wants to modify region. Copy to safe place. | |
212 (let ((copy-buf (get-buffer-create " *Format Temp*"))) | |
213 (copy-to-buffer copy-buf from to) | |
214 (set-buffer copy-buf) | |
215 (format-insert-annotations write-region-annotations-so-far from) | |
18140
f16cf00a2f42
(format-insert-file): Fix arg order to format-decode.
Richard M. Stallman <rms@gnu.org>
parents:
16954
diff
changeset
|
216 (format-encode-run-method to-fn (point-min) (point-max) orig-buf) |
11054 | 217 nil) |
218 ;; Otherwise just call function, it will return annotations. | |
16020
0f704de0600f
(format-alist): Doc fix.
Richard M. Stallman <rms@gnu.org>
parents:
14452
diff
changeset
|
219 (funcall to-fn from to orig-buf))))) |
11054 | 220 |
221 (defun format-decode (format length &optional visit-flag) | |
222 ;; This function is called by insert-file-contents whenever a file is read. | |
223 "Decode text from any known FORMAT. | |
24156 | 224 FORMAT is a symbol appearing in `format-alist' or a list of such symbols, |
11054 | 225 or nil, in which case this function tries to guess the format of the data by |
226 matching against the regular expressions in `format-alist'. After a match is | |
227 found and the region decoded, the alist is searched again from the beginning | |
228 for another match. | |
229 | |
230 Second arg LENGTH is the number of characters following point to operate on. | |
231 If optional third arg VISIT-FLAG is true, set `buffer-file-format' | |
232 to the list of formats used, and call any mode functions defined for those | |
233 formats. | |
234 | |
235 Returns the new length of the decoded region. | |
236 | |
237 For most purposes, consider using `format-decode-region' instead." | |
238 (let ((mod (buffer-modified-p)) | |
24156 | 239 (begin (point)) |
11054 | 240 (end (+ (point) length))) |
241 (if (null format) | |
242 ;; Figure out which format it is in, remember list in `format'. | |
243 (let ((try format-alist)) | |
244 (while try | |
245 (let* ((f (car try)) | |
246 (regexp (nth 2 f)) | |
247 (p (point))) | |
248 (if (and regexp (looking-at regexp) | |
249 (< (match-end 0) (+ begin length))) | |
250 (progn | |
251 (setq format (cons (car f) format)) | |
252 ;; Decode it | |
18140
f16cf00a2f42
(format-insert-file): Fix arg order to format-decode.
Richard M. Stallman <rms@gnu.org>
parents:
16954
diff
changeset
|
253 (if (nth 3 f) |
f16cf00a2f42
(format-insert-file): Fix arg order to format-decode.
Richard M. Stallman <rms@gnu.org>
parents:
16954
diff
changeset
|
254 (setq end (format-decode-run-method (nth 3 f) begin end))) |
11054 | 255 ;; Call visit function if required |
256 (if (and visit-flag (nth 6 f)) (funcall (nth 6 f) 1)) | |
257 ;; Safeguard against either of the functions changing pt. | |
258 (goto-char p) | |
259 ;; Rewind list to look for another format | |
260 (setq try format-alist)) | |
261 (setq try (cdr try)))))) | |
262 ;; Deal with given format(s) | |
263 (or (listp format) (setq format (list format))) | |
264 (let ((do format) f) | |
265 (while do | |
266 (or (setq f (assq (car do) format-alist)) | |
267 (error "Unknown format" (car do))) | |
268 ;; Decode: | |
18140
f16cf00a2f42
(format-insert-file): Fix arg order to format-decode.
Richard M. Stallman <rms@gnu.org>
parents:
16954
diff
changeset
|
269 (if (nth 3 f) |
f16cf00a2f42
(format-insert-file): Fix arg order to format-decode.
Richard M. Stallman <rms@gnu.org>
parents:
16954
diff
changeset
|
270 (setq end (format-decode-run-method (nth 3 f) begin end))) |
11054 | 271 ;; Call visit function if required |
272 (if (and visit-flag (nth 6 f)) (funcall (nth 6 f) 1)) | |
273 (setq do (cdr do))))) | |
274 (if visit-flag | |
275 (setq buffer-file-format format)) | |
276 (set-buffer-modified-p mod) | |
277 ;; Return new length of region | |
278 (- end begin))) | |
279 | |
280 ;;; | |
281 ;;; Interactive functions & entry points | |
282 ;;; | |
283 | |
284 (defun format-decode-buffer (&optional format) | |
285 "Translate the buffer from some FORMAT. | |
286 If the format is not specified, this function attempts to guess. | |
24156 | 287 `buffer-file-format' is set to the format used, and any mode-functions |
11054 | 288 for the format are called." |
289 (interactive | |
290 (list (format-read "Translate buffer from format (default: guess): "))) | |
291 (save-excursion | |
292 (goto-char (point-min)) | |
293 (format-decode format (buffer-size) t))) | |
294 | |
295 (defun format-decode-region (from to &optional format) | |
296 "Decode the region from some format. | |
297 Arg FORMAT is optional; if omitted the format will be determined by looking | |
298 for identifying regular expressions at the beginning of the region." | |
299 (interactive | |
24156 | 300 (list (region-beginning) (region-end) |
11054 | 301 (format-read "Translate region from format (default: guess): "))) |
302 (save-excursion | |
303 (goto-char from) | |
304 (format-decode format (- to from) nil))) | |
305 | |
306 (defun format-encode-buffer (&optional format) | |
307 "Translate the buffer into FORMAT. | |
308 FORMAT defaults to `buffer-file-format'. It is a symbol naming one of the | |
309 formats defined in `format-alist', or a list of such symbols." | |
310 (interactive | |
311 (list (format-read (format "Translate buffer to format (default %s): " | |
312 buffer-file-format)))) | |
313 (format-encode-region (point-min) (point-max) format)) | |
314 | |
315 (defun format-encode-region (beg end &optional format) | |
24156 | 316 "Translate the region into some FORMAT. |
11054 | 317 FORMAT defaults to `buffer-file-format', it is a symbol naming |
318 one of the formats defined in `format-alist', or a list of such symbols." | |
24156 | 319 (interactive |
320 (list (region-beginning) (region-end) | |
321 (format-read (format "Translate region to format (default %s): " | |
322 buffer-file-format)))) | |
323 (if (null format) (setq format buffer-file-format)) | |
324 (if (symbolp format) (setq format (list format))) | |
325 (save-excursion | |
326 (goto-char end) | |
327 (let ((cur-buf (current-buffer)) | |
328 (end (point-marker))) | |
329 (while format | |
330 (let* ((info (assq (car format) format-alist)) | |
331 (to-fn (nth 4 info)) | |
332 (modify (nth 5 info)) | |
333 result) | |
334 (if to-fn | |
335 (if modify | |
336 (setq end (format-encode-run-method to-fn beg end | |
337 (current-buffer))) | |
338 (format-insert-annotations | |
339 (funcall to-fn beg end (current-buffer))))) | |
340 (setq format (cdr format))))))) | |
11054 | 341 |
342 (defun format-write-file (filename format) | |
24156 | 343 "Write current buffer into file FILENAME using some FORMAT. |
11054 | 344 Makes buffer visit that file and sets the format as the default for future |
345 saves. If the buffer is already visiting a file, you can specify a directory | |
24156 | 346 name as FILENAME, to write a file of the same old name in that directory." |
11054 | 347 (interactive |
348 ;; Same interactive spec as write-file, plus format question. | |
349 (let* ((file (if buffer-file-name | |
350 (read-file-name "Write file: " | |
351 nil nil nil nil) | |
352 (read-file-name "Write file: " | |
353 (cdr (assq 'default-directory | |
354 (buffer-local-variables))) | |
355 nil nil (buffer-name)))) | |
24156 | 356 (fmt (format-read (format "Write file `%s' in format: " |
11054 | 357 (file-name-nondirectory file))))) |
358 (list file fmt))) | |
359 (setq buffer-file-format format) | |
360 (write-file filename)) | |
361 | |
12154
38a933f88c87
(format-find-file, format-insert-file): New functions.
Karl Heuer <kwzh@gnu.org>
parents:
12082
diff
changeset
|
362 (defun format-find-file (filename format) |
24156 | 363 "Find the file FILENAME using data format FORMAT. |
12154
38a933f88c87
(format-find-file, format-insert-file): New functions.
Karl Heuer <kwzh@gnu.org>
parents:
12082
diff
changeset
|
364 If FORMAT is nil then do not do any format conversion." |
38a933f88c87
(format-find-file, format-insert-file): New functions.
Karl Heuer <kwzh@gnu.org>
parents:
12082
diff
changeset
|
365 (interactive |
38a933f88c87
(format-find-file, format-insert-file): New functions.
Karl Heuer <kwzh@gnu.org>
parents:
12082
diff
changeset
|
366 ;; Same interactive spec as write-file, plus format question. |
38a933f88c87
(format-find-file, format-insert-file): New functions.
Karl Heuer <kwzh@gnu.org>
parents:
12082
diff
changeset
|
367 (let* ((file (read-file-name "Find file: ")) |
24156 | 368 (fmt (format-read (format "Read file `%s' in format: " |
12154
38a933f88c87
(format-find-file, format-insert-file): New functions.
Karl Heuer <kwzh@gnu.org>
parents:
12082
diff
changeset
|
369 (file-name-nondirectory file))))) |
38a933f88c87
(format-find-file, format-insert-file): New functions.
Karl Heuer <kwzh@gnu.org>
parents:
12082
diff
changeset
|
370 (list file fmt))) |
38a933f88c87
(format-find-file, format-insert-file): New functions.
Karl Heuer <kwzh@gnu.org>
parents:
12082
diff
changeset
|
371 (let ((format-alist nil)) |
38a933f88c87
(format-find-file, format-insert-file): New functions.
Karl Heuer <kwzh@gnu.org>
parents:
12082
diff
changeset
|
372 (find-file filename)) |
38a933f88c87
(format-find-file, format-insert-file): New functions.
Karl Heuer <kwzh@gnu.org>
parents:
12082
diff
changeset
|
373 (if format |
38a933f88c87
(format-find-file, format-insert-file): New functions.
Karl Heuer <kwzh@gnu.org>
parents:
12082
diff
changeset
|
374 (format-decode-buffer format))) |
38a933f88c87
(format-find-file, format-insert-file): New functions.
Karl Heuer <kwzh@gnu.org>
parents:
12082
diff
changeset
|
375 |
38a933f88c87
(format-find-file, format-insert-file): New functions.
Karl Heuer <kwzh@gnu.org>
parents:
12082
diff
changeset
|
376 (defun format-insert-file (filename format &optional beg end) |
24156 | 377 "Insert the contents of file FILENAME using data format FORMAT. |
12154
38a933f88c87
(format-find-file, format-insert-file): New functions.
Karl Heuer <kwzh@gnu.org>
parents:
12082
diff
changeset
|
378 If FORMAT is nil then do not do any format conversion. |
38a933f88c87
(format-find-file, format-insert-file): New functions.
Karl Heuer <kwzh@gnu.org>
parents:
12082
diff
changeset
|
379 The optional third and fourth arguments BEG and END specify |
38a933f88c87
(format-find-file, format-insert-file): New functions.
Karl Heuer <kwzh@gnu.org>
parents:
12082
diff
changeset
|
380 the part of the file to read. |
38a933f88c87
(format-find-file, format-insert-file): New functions.
Karl Heuer <kwzh@gnu.org>
parents:
12082
diff
changeset
|
381 |
38a933f88c87
(format-find-file, format-insert-file): New functions.
Karl Heuer <kwzh@gnu.org>
parents:
12082
diff
changeset
|
382 The return value is like the value of `insert-file-contents': |
38a933f88c87
(format-find-file, format-insert-file): New functions.
Karl Heuer <kwzh@gnu.org>
parents:
12082
diff
changeset
|
383 a list (ABSOLUTE-FILE-NAME . SIZE)." |
38a933f88c87
(format-find-file, format-insert-file): New functions.
Karl Heuer <kwzh@gnu.org>
parents:
12082
diff
changeset
|
384 (interactive |
38a933f88c87
(format-find-file, format-insert-file): New functions.
Karl Heuer <kwzh@gnu.org>
parents:
12082
diff
changeset
|
385 ;; Same interactive spec as write-file, plus format question. |
38a933f88c87
(format-find-file, format-insert-file): New functions.
Karl Heuer <kwzh@gnu.org>
parents:
12082
diff
changeset
|
386 (let* ((file (read-file-name "Find file: ")) |
24156 | 387 (fmt (format-read (format "Read file `%s' in format: " |
12154
38a933f88c87
(format-find-file, format-insert-file): New functions.
Karl Heuer <kwzh@gnu.org>
parents:
12082
diff
changeset
|
388 (file-name-nondirectory file))))) |
38a933f88c87
(format-find-file, format-insert-file): New functions.
Karl Heuer <kwzh@gnu.org>
parents:
12082
diff
changeset
|
389 (list file fmt))) |
38a933f88c87
(format-find-file, format-insert-file): New functions.
Karl Heuer <kwzh@gnu.org>
parents:
12082
diff
changeset
|
390 (let (value size) |
38a933f88c87
(format-find-file, format-insert-file): New functions.
Karl Heuer <kwzh@gnu.org>
parents:
12082
diff
changeset
|
391 (let ((format-alist nil)) |
38a933f88c87
(format-find-file, format-insert-file): New functions.
Karl Heuer <kwzh@gnu.org>
parents:
12082
diff
changeset
|
392 (setq value (insert-file-contents filename nil beg end)) |
38a933f88c87
(format-find-file, format-insert-file): New functions.
Karl Heuer <kwzh@gnu.org>
parents:
12082
diff
changeset
|
393 (setq size (nth 1 value))) |
38a933f88c87
(format-find-file, format-insert-file): New functions.
Karl Heuer <kwzh@gnu.org>
parents:
12082
diff
changeset
|
394 (if format |
18140
f16cf00a2f42
(format-insert-file): Fix arg order to format-decode.
Richard M. Stallman <rms@gnu.org>
parents:
16954
diff
changeset
|
395 (setq size (format-decode format size) |
12154
38a933f88c87
(format-find-file, format-insert-file): New functions.
Karl Heuer <kwzh@gnu.org>
parents:
12082
diff
changeset
|
396 value (cons (car value) size))) |
38a933f88c87
(format-find-file, format-insert-file): New functions.
Karl Heuer <kwzh@gnu.org>
parents:
12082
diff
changeset
|
397 value)) |
38a933f88c87
(format-find-file, format-insert-file): New functions.
Karl Heuer <kwzh@gnu.org>
parents:
12082
diff
changeset
|
398 |
11054 | 399 (defun format-read (&optional prompt) |
400 "Read and return the name of a format. | |
401 Return value is a list, like `buffer-file-format'; it may be nil. | |
402 Formats are defined in `format-alist'. Optional arg is the PROMPT to use." | |
403 (let* ((table (mapcar (lambda (x) (list (symbol-name (car x)))) | |
404 format-alist)) | |
405 (ans (completing-read (or prompt "Format: ") table nil t))) | |
406 (if (not (equal "" ans)) (list (intern ans))))) | |
407 | |
408 | |
409 ;;; | |
410 ;;; Below are some functions that may be useful in writing encoding and | |
411 ;;; decoding functions for use in format-alist. | |
412 ;;; | |
413 | |
414 (defun format-replace-strings (alist &optional reverse beg end) | |
415 "Do multiple replacements on the buffer. | |
416 ALIST is a list of (from . to) pairs, which should be proper arguments to | |
417 `search-forward' and `replace-match' respectively. | |
418 Optional 2nd arg REVERSE, if non-nil, means the pairs are (to . from), so that | |
419 you can use the same list in both directions if it contains only literal | |
24156 | 420 strings. |
421 Optional args BEG and END specify a region of the buffer on which to operate." | |
11054 | 422 (save-excursion |
423 (save-restriction | |
424 (or beg (setq beg (point-min))) | |
425 (if end (narrow-to-region (point-min) end)) | |
426 (while alist | |
427 (let ((from (if reverse (cdr (car alist)) (car (car alist)))) | |
24315
382a7de604b6
(format-replace-strings): Fix value of TO in REVERSE case.
Richard M. Stallman <rms@gnu.org>
parents:
24156
diff
changeset
|
428 (to (if reverse (car (car alist)) (cdr (car alist))))) |
11054 | 429 (goto-char beg) |
430 (while (search-forward from nil t) | |
431 (goto-char (match-beginning 0)) | |
432 (insert to) | |
433 (set-text-properties (- (point) (length to)) (point) | |
434 (text-properties-at (point))) | |
435 (delete-region (point) (+ (point) (- (match-end 0) | |
436 (match-beginning 0))))) | |
437 (setq alist (cdr alist))))))) | |
438 | |
439 ;;; Some list-manipulation functions that we need. | |
440 | |
441 (defun format-delq-cons (cons list) | |
24156 | 442 "Remove the given CONS from LIST by side effect and return the new LIST. |
443 Since CONS could be the first element of LIST, write | |
444 `\(setq foo \(format-delq-cons element foo))' to be sure of changing | |
445 the value of `foo'." | |
11054 | 446 (if (eq cons list) |
447 (cdr list) | |
448 (let ((p list)) | |
449 (while (not (eq (cdr p) cons)) | |
450 (if (null p) (error "format-delq-cons: not an element.")) | |
451 (setq p (cdr p))) | |
452 ;; Now (cdr p) is the cons to delete | |
453 (setcdr p (cdr cons)) | |
454 list))) | |
455 | |
456 (defun format-make-relatively-unique (a b) | |
457 "Delete common elements of lists A and B, return as pair. | |
458 Compares using `equal'." | |
459 (let* ((acopy (copy-sequence a)) | |
460 (bcopy (copy-sequence b)) | |
461 (tail acopy)) | |
462 (while tail | |
463 (let ((dup (member (car tail) bcopy)) | |
464 (next (cdr tail))) | |
465 (if dup (setq acopy (format-delq-cons tail acopy) | |
466 bcopy (format-delq-cons dup bcopy))) | |
467 (setq tail next))) | |
468 (cons acopy bcopy))) | |
469 | |
470 (defun format-common-tail (a b) | |
471 "Given two lists that have a common tail, return it. | |
472 Compares with `equal', and returns the part of A that is equal to the | |
473 equivalent part of B. If even the last items of the two are not equal, | |
474 returns nil." | |
475 (let ((la (length a)) | |
476 (lb (length b))) | |
477 ;; Make sure they are the same length | |
24156 | 478 (if (> la lb) |
11054 | 479 (setq a (nthcdr (- la lb) a)) |
480 (setq b (nthcdr (- lb la) b)))) | |
481 (while (not (equal a b)) | |
482 (setq a (cdr a) | |
483 b (cdr b))) | |
484 a) | |
485 | |
486 (defun format-reorder (items order) | |
487 "Arrange ITEMS to following partial ORDER. | |
488 Elements of ITEMS equal to elements of ORDER will be rearranged to follow the | |
489 ORDER. Unmatched items will go last." | |
490 (if order | |
491 (let ((item (member (car order) items))) | |
492 (if item | |
24156 | 493 (cons (car item) |
11054 | 494 (format-reorder (format-delq-cons item items) |
495 (cdr order))) | |
496 (format-reorder items (cdr order)))) | |
497 items)) | |
498 | |
499 (put 'face 'format-list-valued t) ; These text-properties take values | |
500 (put 'unknown 'format-list-valued t) ; that are lists, the elements of which | |
501 ; should be considered separately. | |
502 ; See format-deannotate-region and | |
503 ; format-annotate-region. | |
504 | |
505 ;;; | |
506 ;;; Decoding | |
507 ;;; | |
508 | |
509 (defun format-deannotate-region (from to translations next-fn) | |
510 "Translate annotations in the region into text properties. | |
24156 | 511 This sets text properties between FROM to TO as directed by the |
11054 | 512 TRANSLATIONS and NEXT-FN arguments. |
513 | |
514 NEXT-FN is a function that searches forward from point for an annotation. | |
515 It should return a list of 4 elements: \(BEGIN END NAME POSITIVE). BEGIN and | |
516 END are buffer positions bounding the annotation, NAME is the name searched | |
517 for in TRANSLATIONS, and POSITIVE should be non-nil if this annotation marks | |
518 the beginning of a region with some property, or nil if it ends the region. | |
519 NEXT-FN should return nil if there are no annotations after point. | |
520 | |
521 The basic format of the TRANSLATIONS argument is described in the | |
522 documentation for the `format-annotate-region' function. There are some | |
523 additional things to keep in mind for decoding, though: | |
524 | |
525 When an annotation is found, the TRANSLATIONS list is searched for a | |
526 text-property name and value that corresponds to that annotation. If the | |
527 text-property has several annotations associated with it, it will be used only | |
528 if the other annotations are also in effect at that point. The first match | |
529 found whose annotations are all present is used. | |
530 | |
531 The text property thus determined is set to the value over the region between | |
532 the opening and closing annotations. However, if the text-property name has a | |
533 non-nil `format-list-valued' property, then the value will be consed onto the | |
534 surrounding value of the property, rather than replacing that value. | |
535 | |
536 There are some special symbols that can be used in the \"property\" slot of | |
537 the TRANSLATIONS list: PARAMETER and FUNCTION \(spelled in uppercase). | |
538 Annotations listed under the pseudo-property PARAMETER are considered to be | |
539 arguments of the immediately surrounding annotation; the text between the | |
540 opening and closing parameter annotations is deleted from the buffer but saved | |
541 as a string. The surrounding annotation should be listed under the | |
542 pseudo-property FUNCTION. Instead of inserting a text-property for this | |
543 annotation, the function listed in the VALUE slot is called to make whatever | |
544 changes are appropriate. The function's first two arguments are the START and | |
545 END locations, and the rest of the arguments are any PARAMETERs found in that | |
546 region. | |
547 | |
548 Any annotations that are found by NEXT-FN but not defined by TRANSLATIONS | |
549 are saved as values of the `unknown' text-property \(which is list-valued). | |
550 The TRANSLATIONS list should usually contain an entry of the form | |
551 \(unknown \(nil format-annotate-value)) | |
552 to write these unknown annotations back into the file." | |
553 (save-excursion | |
554 (save-restriction | |
555 (narrow-to-region (point-min) to) | |
556 (goto-char from) | |
557 (let (next open-ans todo loc unknown-ans) | |
558 (while (setq next (funcall next-fn)) | |
559 (let* ((loc (nth 0 next)) | |
560 (end (nth 1 next)) | |
561 (name (nth 2 next)) | |
562 (positive (nth 3 next)) | |
563 (found nil)) | |
564 | |
565 ;; Delete the annotation | |
566 (delete-region loc end) | |
19631
51b56762f98b
(format-subtract-regions): New function.
Richard M. Stallman <rms@gnu.org>
parents:
19363
diff
changeset
|
567 (cond |
51b56762f98b
(format-subtract-regions): New function.
Richard M. Stallman <rms@gnu.org>
parents:
19363
diff
changeset
|
568 ;; Positive annotations are stacked, remembering location |
51b56762f98b
(format-subtract-regions): New function.
Richard M. Stallman <rms@gnu.org>
parents:
19363
diff
changeset
|
569 (positive (setq open-ans (cons `(,name ((,loc . nil))) open-ans))) |
51b56762f98b
(format-subtract-regions): New function.
Richard M. Stallman <rms@gnu.org>
parents:
19363
diff
changeset
|
570 ;; It is a negative annotation: |
51b56762f98b
(format-subtract-regions): New function.
Richard M. Stallman <rms@gnu.org>
parents:
19363
diff
changeset
|
571 ;; Close the top annotation & add its text property. |
51b56762f98b
(format-subtract-regions): New function.
Richard M. Stallman <rms@gnu.org>
parents:
19363
diff
changeset
|
572 ;; If the file's nesting is messed up, the close might not match |
51b56762f98b
(format-subtract-regions): New function.
Richard M. Stallman <rms@gnu.org>
parents:
19363
diff
changeset
|
573 ;; the top thing on the open-annotations stack. |
51b56762f98b
(format-subtract-regions): New function.
Richard M. Stallman <rms@gnu.org>
parents:
19363
diff
changeset
|
574 ;; If no matching annotation is open, just ignore the close. |
51b56762f98b
(format-subtract-regions): New function.
Richard M. Stallman <rms@gnu.org>
parents:
19363
diff
changeset
|
575 ((not (assoc name open-ans)) |
51b56762f98b
(format-subtract-regions): New function.
Richard M. Stallman <rms@gnu.org>
parents:
19363
diff
changeset
|
576 (message "Extra closing annotation (%s) in file" name)) |
51b56762f98b
(format-subtract-regions): New function.
Richard M. Stallman <rms@gnu.org>
parents:
19363
diff
changeset
|
577 ;; If one is open, but not on the top of the stack, close |
51b56762f98b
(format-subtract-regions): New function.
Richard M. Stallman <rms@gnu.org>
parents:
19363
diff
changeset
|
578 ;; the things in between as well. Set `found' when the real |
51b56762f98b
(format-subtract-regions): New function.
Richard M. Stallman <rms@gnu.org>
parents:
19363
diff
changeset
|
579 ;; one is closed. |
51b56762f98b
(format-subtract-regions): New function.
Richard M. Stallman <rms@gnu.org>
parents:
19363
diff
changeset
|
580 (t |
51b56762f98b
(format-subtract-regions): New function.
Richard M. Stallman <rms@gnu.org>
parents:
19363
diff
changeset
|
581 (while (not found) |
51b56762f98b
(format-subtract-regions): New function.
Richard M. Stallman <rms@gnu.org>
parents:
19363
diff
changeset
|
582 (let* ((top (car open-ans)) ; first on stack: should match. |
51b56762f98b
(format-subtract-regions): New function.
Richard M. Stallman <rms@gnu.org>
parents:
19363
diff
changeset
|
583 (top-name (car top)) ; text property name |
51b56762f98b
(format-subtract-regions): New function.
Richard M. Stallman <rms@gnu.org>
parents:
19363
diff
changeset
|
584 (top-extents (nth 1 top)) ; property regions |
51b56762f98b
(format-subtract-regions): New function.
Richard M. Stallman <rms@gnu.org>
parents:
19363
diff
changeset
|
585 (params (cdr (cdr top))) ; parameters |
51b56762f98b
(format-subtract-regions): New function.
Richard M. Stallman <rms@gnu.org>
parents:
19363
diff
changeset
|
586 (aalist translations) |
51b56762f98b
(format-subtract-regions): New function.
Richard M. Stallman <rms@gnu.org>
parents:
19363
diff
changeset
|
587 (matched nil)) |
51b56762f98b
(format-subtract-regions): New function.
Richard M. Stallman <rms@gnu.org>
parents:
19363
diff
changeset
|
588 (if (equal name top-name) |
51b56762f98b
(format-subtract-regions): New function.
Richard M. Stallman <rms@gnu.org>
parents:
19363
diff
changeset
|
589 (setq found t) |
51b56762f98b
(format-subtract-regions): New function.
Richard M. Stallman <rms@gnu.org>
parents:
19363
diff
changeset
|
590 (message "Improper nesting in file.")) |
51b56762f98b
(format-subtract-regions): New function.
Richard M. Stallman <rms@gnu.org>
parents:
19363
diff
changeset
|
591 ;; Look through property names in TRANSLATIONS |
51b56762f98b
(format-subtract-regions): New function.
Richard M. Stallman <rms@gnu.org>
parents:
19363
diff
changeset
|
592 (while aalist |
51b56762f98b
(format-subtract-regions): New function.
Richard M. Stallman <rms@gnu.org>
parents:
19363
diff
changeset
|
593 (let ((prop (car (car aalist))) |
51b56762f98b
(format-subtract-regions): New function.
Richard M. Stallman <rms@gnu.org>
parents:
19363
diff
changeset
|
594 (alist (cdr (car aalist)))) |
51b56762f98b
(format-subtract-regions): New function.
Richard M. Stallman <rms@gnu.org>
parents:
19363
diff
changeset
|
595 ;; And look through values for each property |
51b56762f98b
(format-subtract-regions): New function.
Richard M. Stallman <rms@gnu.org>
parents:
19363
diff
changeset
|
596 (while alist |
51b56762f98b
(format-subtract-regions): New function.
Richard M. Stallman <rms@gnu.org>
parents:
19363
diff
changeset
|
597 (let ((value (car (car alist))) |
51b56762f98b
(format-subtract-regions): New function.
Richard M. Stallman <rms@gnu.org>
parents:
19363
diff
changeset
|
598 (ans (cdr (car alist)))) |
51b56762f98b
(format-subtract-regions): New function.
Richard M. Stallman <rms@gnu.org>
parents:
19363
diff
changeset
|
599 (if (member top-name ans) |
51b56762f98b
(format-subtract-regions): New function.
Richard M. Stallman <rms@gnu.org>
parents:
19363
diff
changeset
|
600 ;; This annotation is listed, but still have to |
51b56762f98b
(format-subtract-regions): New function.
Richard M. Stallman <rms@gnu.org>
parents:
19363
diff
changeset
|
601 ;; check if multiple annotations are satisfied |
51b56762f98b
(format-subtract-regions): New function.
Richard M. Stallman <rms@gnu.org>
parents:
19363
diff
changeset
|
602 (if (member nil (mapcar (lambda (r) |
51b56762f98b
(format-subtract-regions): New function.
Richard M. Stallman <rms@gnu.org>
parents:
19363
diff
changeset
|
603 (assoc r open-ans)) |
51b56762f98b
(format-subtract-regions): New function.
Richard M. Stallman <rms@gnu.org>
parents:
19363
diff
changeset
|
604 ans)) |
51b56762f98b
(format-subtract-regions): New function.
Richard M. Stallman <rms@gnu.org>
parents:
19363
diff
changeset
|
605 nil ; multiple ans not satisfied |
51b56762f98b
(format-subtract-regions): New function.
Richard M. Stallman <rms@gnu.org>
parents:
19363
diff
changeset
|
606 ;; If there are multiple annotations going |
51b56762f98b
(format-subtract-regions): New function.
Richard M. Stallman <rms@gnu.org>
parents:
19363
diff
changeset
|
607 ;; into one text property, split up the other |
51b56762f98b
(format-subtract-regions): New function.
Richard M. Stallman <rms@gnu.org>
parents:
19363
diff
changeset
|
608 ;; annotations so they apply individually to |
51b56762f98b
(format-subtract-regions): New function.
Richard M. Stallman <rms@gnu.org>
parents:
19363
diff
changeset
|
609 ;; the other regions. |
51b56762f98b
(format-subtract-regions): New function.
Richard M. Stallman <rms@gnu.org>
parents:
19363
diff
changeset
|
610 (setcdr (car top-extents) loc) |
51b56762f98b
(format-subtract-regions): New function.
Richard M. Stallman <rms@gnu.org>
parents:
19363
diff
changeset
|
611 (let ((to-split ans) this-one extents) |
51b56762f98b
(format-subtract-regions): New function.
Richard M. Stallman <rms@gnu.org>
parents:
19363
diff
changeset
|
612 (while to-split |
51b56762f98b
(format-subtract-regions): New function.
Richard M. Stallman <rms@gnu.org>
parents:
19363
diff
changeset
|
613 (setq this-one |
51b56762f98b
(format-subtract-regions): New function.
Richard M. Stallman <rms@gnu.org>
parents:
19363
diff
changeset
|
614 (assoc (car to-split) open-ans) |
51b56762f98b
(format-subtract-regions): New function.
Richard M. Stallman <rms@gnu.org>
parents:
19363
diff
changeset
|
615 extents (nth 1 this-one)) |
51b56762f98b
(format-subtract-regions): New function.
Richard M. Stallman <rms@gnu.org>
parents:
19363
diff
changeset
|
616 (if (not (eq this-one top)) |
51b56762f98b
(format-subtract-regions): New function.
Richard M. Stallman <rms@gnu.org>
parents:
19363
diff
changeset
|
617 (setcar (cdr this-one) |
51b56762f98b
(format-subtract-regions): New function.
Richard M. Stallman <rms@gnu.org>
parents:
19363
diff
changeset
|
618 (format-subtract-regions |
51b56762f98b
(format-subtract-regions): New function.
Richard M. Stallman <rms@gnu.org>
parents:
19363
diff
changeset
|
619 extents top-extents))) |
51b56762f98b
(format-subtract-regions): New function.
Richard M. Stallman <rms@gnu.org>
parents:
19363
diff
changeset
|
620 (setq to-split (cdr to-split)))) |
51b56762f98b
(format-subtract-regions): New function.
Richard M. Stallman <rms@gnu.org>
parents:
19363
diff
changeset
|
621 ;; Set loop variables to nil so loop |
51b56762f98b
(format-subtract-regions): New function.
Richard M. Stallman <rms@gnu.org>
parents:
19363
diff
changeset
|
622 ;; will exit. |
51b56762f98b
(format-subtract-regions): New function.
Richard M. Stallman <rms@gnu.org>
parents:
19363
diff
changeset
|
623 (setq alist nil aalist nil matched t |
51b56762f98b
(format-subtract-regions): New function.
Richard M. Stallman <rms@gnu.org>
parents:
19363
diff
changeset
|
624 ;; pop annotation off stack. |
51b56762f98b
(format-subtract-regions): New function.
Richard M. Stallman <rms@gnu.org>
parents:
19363
diff
changeset
|
625 open-ans (cdr open-ans)) |
51b56762f98b
(format-subtract-regions): New function.
Richard M. Stallman <rms@gnu.org>
parents:
19363
diff
changeset
|
626 (let ((extents top-extents) |
51b56762f98b
(format-subtract-regions): New function.
Richard M. Stallman <rms@gnu.org>
parents:
19363
diff
changeset
|
627 (start (car (car top-extents))) |
51b56762f98b
(format-subtract-regions): New function.
Richard M. Stallman <rms@gnu.org>
parents:
19363
diff
changeset
|
628 (loc (cdr (car top-extents)))) |
51b56762f98b
(format-subtract-regions): New function.
Richard M. Stallman <rms@gnu.org>
parents:
19363
diff
changeset
|
629 (while extents |
51b56762f98b
(format-subtract-regions): New function.
Richard M. Stallman <rms@gnu.org>
parents:
19363
diff
changeset
|
630 (cond |
51b56762f98b
(format-subtract-regions): New function.
Richard M. Stallman <rms@gnu.org>
parents:
19363
diff
changeset
|
631 ;; Check for pseudo-properties |
51b56762f98b
(format-subtract-regions): New function.
Richard M. Stallman <rms@gnu.org>
parents:
19363
diff
changeset
|
632 ((eq prop 'PARAMETER) |
51b56762f98b
(format-subtract-regions): New function.
Richard M. Stallman <rms@gnu.org>
parents:
19363
diff
changeset
|
633 ;; A parameter of the top open ann: |
51b56762f98b
(format-subtract-regions): New function.
Richard M. Stallman <rms@gnu.org>
parents:
19363
diff
changeset
|
634 ;; delete text and use as arg. |
51b56762f98b
(format-subtract-regions): New function.
Richard M. Stallman <rms@gnu.org>
parents:
19363
diff
changeset
|
635 (if open-ans |
51b56762f98b
(format-subtract-regions): New function.
Richard M. Stallman <rms@gnu.org>
parents:
19363
diff
changeset
|
636 ;; (If nothing open, discard). |
51b56762f98b
(format-subtract-regions): New function.
Richard M. Stallman <rms@gnu.org>
parents:
19363
diff
changeset
|
637 (setq open-ans |
51b56762f98b
(format-subtract-regions): New function.
Richard M. Stallman <rms@gnu.org>
parents:
19363
diff
changeset
|
638 (cons |
51b56762f98b
(format-subtract-regions): New function.
Richard M. Stallman <rms@gnu.org>
parents:
19363
diff
changeset
|
639 (append (car open-ans) |
51b56762f98b
(format-subtract-regions): New function.
Richard M. Stallman <rms@gnu.org>
parents:
19363
diff
changeset
|
640 (list |
51b56762f98b
(format-subtract-regions): New function.
Richard M. Stallman <rms@gnu.org>
parents:
19363
diff
changeset
|
641 (buffer-substring |
51b56762f98b
(format-subtract-regions): New function.
Richard M. Stallman <rms@gnu.org>
parents:
19363
diff
changeset
|
642 start loc))) |
51b56762f98b
(format-subtract-regions): New function.
Richard M. Stallman <rms@gnu.org>
parents:
19363
diff
changeset
|
643 (cdr open-ans)))) |
51b56762f98b
(format-subtract-regions): New function.
Richard M. Stallman <rms@gnu.org>
parents:
19363
diff
changeset
|
644 (delete-region start loc)) |
51b56762f98b
(format-subtract-regions): New function.
Richard M. Stallman <rms@gnu.org>
parents:
19363
diff
changeset
|
645 ((eq prop 'FUNCTION) |
51b56762f98b
(format-subtract-regions): New function.
Richard M. Stallman <rms@gnu.org>
parents:
19363
diff
changeset
|
646 ;; Not a property, but a function. |
51b56762f98b
(format-subtract-regions): New function.
Richard M. Stallman <rms@gnu.org>
parents:
19363
diff
changeset
|
647 (let ((rtn |
51b56762f98b
(format-subtract-regions): New function.
Richard M. Stallman <rms@gnu.org>
parents:
19363
diff
changeset
|
648 (apply value start loc params))) |
51b56762f98b
(format-subtract-regions): New function.
Richard M. Stallman <rms@gnu.org>
parents:
19363
diff
changeset
|
649 (if rtn (setq todo (cons rtn todo))))) |
51b56762f98b
(format-subtract-regions): New function.
Richard M. Stallman <rms@gnu.org>
parents:
19363
diff
changeset
|
650 (t |
51b56762f98b
(format-subtract-regions): New function.
Richard M. Stallman <rms@gnu.org>
parents:
19363
diff
changeset
|
651 ;; Normal property/value pair |
51b56762f98b
(format-subtract-regions): New function.
Richard M. Stallman <rms@gnu.org>
parents:
19363
diff
changeset
|
652 (setq todo |
51b56762f98b
(format-subtract-regions): New function.
Richard M. Stallman <rms@gnu.org>
parents:
19363
diff
changeset
|
653 (cons (list start loc prop value) |
51b56762f98b
(format-subtract-regions): New function.
Richard M. Stallman <rms@gnu.org>
parents:
19363
diff
changeset
|
654 todo)))) |
51b56762f98b
(format-subtract-regions): New function.
Richard M. Stallman <rms@gnu.org>
parents:
19363
diff
changeset
|
655 (setq extents (cdr extents) |
51b56762f98b
(format-subtract-regions): New function.
Richard M. Stallman <rms@gnu.org>
parents:
19363
diff
changeset
|
656 start (car (car extents)) |
51b56762f98b
(format-subtract-regions): New function.
Richard M. Stallman <rms@gnu.org>
parents:
19363
diff
changeset
|
657 loc (cdr (car extents)))))))) |
51b56762f98b
(format-subtract-regions): New function.
Richard M. Stallman <rms@gnu.org>
parents:
19363
diff
changeset
|
658 (setq alist (cdr alist)))) |
51b56762f98b
(format-subtract-regions): New function.
Richard M. Stallman <rms@gnu.org>
parents:
19363
diff
changeset
|
659 (setq aalist (cdr aalist))) |
51b56762f98b
(format-subtract-regions): New function.
Richard M. Stallman <rms@gnu.org>
parents:
19363
diff
changeset
|
660 (if (not matched) |
11054 | 661 ;; Didn't find any match for the annotation: |
662 ;; Store as value of text-property `unknown'. | |
19631
51b56762f98b
(format-subtract-regions): New function.
Richard M. Stallman <rms@gnu.org>
parents:
19363
diff
changeset
|
663 (let ((extents top-extents) |
51b56762f98b
(format-subtract-regions): New function.
Richard M. Stallman <rms@gnu.org>
parents:
19363
diff
changeset
|
664 (start (car (car top-extents))) |
20087
3a72c0f0ad69
(format-deannotate-region): In case of unmatched tags,
Karl Heuer <kwzh@gnu.org>
parents:
19631
diff
changeset
|
665 (loc (or (cdr (car top-extents)) loc))) |
19631
51b56762f98b
(format-subtract-regions): New function.
Richard M. Stallman <rms@gnu.org>
parents:
19363
diff
changeset
|
666 (while extents |
51b56762f98b
(format-subtract-regions): New function.
Richard M. Stallman <rms@gnu.org>
parents:
19363
diff
changeset
|
667 (setq open-ans (cdr open-ans) |
51b56762f98b
(format-subtract-regions): New function.
Richard M. Stallman <rms@gnu.org>
parents:
19363
diff
changeset
|
668 todo (cons (list start loc 'unknown top-name) |
51b56762f98b
(format-subtract-regions): New function.
Richard M. Stallman <rms@gnu.org>
parents:
19363
diff
changeset
|
669 todo) |
51b56762f98b
(format-subtract-regions): New function.
Richard M. Stallman <rms@gnu.org>
parents:
19363
diff
changeset
|
670 unknown-ans (cons name unknown-ans) |
51b56762f98b
(format-subtract-regions): New function.
Richard M. Stallman <rms@gnu.org>
parents:
19363
diff
changeset
|
671 extents (cdr extents) |
51b56762f98b
(format-subtract-regions): New function.
Richard M. Stallman <rms@gnu.org>
parents:
19363
diff
changeset
|
672 start (car (car extents)) |
51b56762f98b
(format-subtract-regions): New function.
Richard M. Stallman <rms@gnu.org>
parents:
19363
diff
changeset
|
673 loc (cdr (car extents)))))))))))) |
11054 | 674 |
675 ;; Once entire file has been scanned, add the properties. | |
676 (while todo | |
677 (let* ((item (car todo)) | |
678 (from (nth 0 item)) | |
679 (to (nth 1 item)) | |
680 (prop (nth 2 item)) | |
681 (val (nth 3 item))) | |
19631
51b56762f98b
(format-subtract-regions): New function.
Richard M. Stallman <rms@gnu.org>
parents:
19363
diff
changeset
|
682 |
51b56762f98b
(format-subtract-regions): New function.
Richard M. Stallman <rms@gnu.org>
parents:
19363
diff
changeset
|
683 (if (numberp val) ; add to ambient value if numeric |
51b56762f98b
(format-subtract-regions): New function.
Richard M. Stallman <rms@gnu.org>
parents:
19363
diff
changeset
|
684 (format-property-increment-region from to prop val 0) |
51b56762f98b
(format-subtract-regions): New function.
Richard M. Stallman <rms@gnu.org>
parents:
19363
diff
changeset
|
685 (put-text-property |
11054 | 686 from to prop |
19631
51b56762f98b
(format-subtract-regions): New function.
Richard M. Stallman <rms@gnu.org>
parents:
19363
diff
changeset
|
687 (cond ((get prop 'format-list-valued) ; value gets consed onto |
11054 | 688 ; list-valued properties |
689 (let ((prev (get-text-property from prop))) | |
690 (cons val (if (listp prev) prev (list prev))))) | |
19631
51b56762f98b
(format-subtract-regions): New function.
Richard M. Stallman <rms@gnu.org>
parents:
19363
diff
changeset
|
691 (t val))))) ; normally, just set to val. |
11054 | 692 (setq todo (cdr todo))) |
19631
51b56762f98b
(format-subtract-regions): New function.
Richard M. Stallman <rms@gnu.org>
parents:
19363
diff
changeset
|
693 |
11054 | 694 (if unknown-ans |
695 (message "Unknown annotations: %s" unknown-ans)))))) | |
696 | |
19631
51b56762f98b
(format-subtract-regions): New function.
Richard M. Stallman <rms@gnu.org>
parents:
19363
diff
changeset
|
697 (defun format-subtract-regions (minu subtra) |
24156 | 698 "Remove from the regions in MINUend the regions in SUBTRAhend. |
699 A region is a dotted pair (from . to). Both parameters are lists of | |
700 regions. Each list must contain nonoverlapping, noncontiguous | |
701 regions, in descending order. The result is also nonoverlapping, | |
702 noncontiguous, and in descending order. The first element of MINUEND | |
703 can have a cdr of nil, indicating that the end of that region is not | |
704 yet known." | |
19631
51b56762f98b
(format-subtract-regions): New function.
Richard M. Stallman <rms@gnu.org>
parents:
19363
diff
changeset
|
705 (let* ((minuend (copy-alist minu)) |
51b56762f98b
(format-subtract-regions): New function.
Richard M. Stallman <rms@gnu.org>
parents:
19363
diff
changeset
|
706 (subtrahend (copy-alist subtra)) |
51b56762f98b
(format-subtract-regions): New function.
Richard M. Stallman <rms@gnu.org>
parents:
19363
diff
changeset
|
707 (m (car minuend)) |
51b56762f98b
(format-subtract-regions): New function.
Richard M. Stallman <rms@gnu.org>
parents:
19363
diff
changeset
|
708 (s (car subtrahend)) |
51b56762f98b
(format-subtract-regions): New function.
Richard M. Stallman <rms@gnu.org>
parents:
19363
diff
changeset
|
709 results) |
51b56762f98b
(format-subtract-regions): New function.
Richard M. Stallman <rms@gnu.org>
parents:
19363
diff
changeset
|
710 (while (and minuend subtrahend) |
24156 | 711 (cond |
19631
51b56762f98b
(format-subtract-regions): New function.
Richard M. Stallman <rms@gnu.org>
parents:
19363
diff
changeset
|
712 ;; The minuend starts after the subtrahend ends; keep it. |
51b56762f98b
(format-subtract-regions): New function.
Richard M. Stallman <rms@gnu.org>
parents:
19363
diff
changeset
|
713 ((> (car m) (cdr s)) |
51b56762f98b
(format-subtract-regions): New function.
Richard M. Stallman <rms@gnu.org>
parents:
19363
diff
changeset
|
714 (setq results (cons m results) |
51b56762f98b
(format-subtract-regions): New function.
Richard M. Stallman <rms@gnu.org>
parents:
19363
diff
changeset
|
715 minuend (cdr minuend) |
51b56762f98b
(format-subtract-regions): New function.
Richard M. Stallman <rms@gnu.org>
parents:
19363
diff
changeset
|
716 m (car minuend))) |
51b56762f98b
(format-subtract-regions): New function.
Richard M. Stallman <rms@gnu.org>
parents:
19363
diff
changeset
|
717 ;; The minuend extends beyond the end of the subtrahend. Chop it off. |
51b56762f98b
(format-subtract-regions): New function.
Richard M. Stallman <rms@gnu.org>
parents:
19363
diff
changeset
|
718 ((or (null (cdr m)) (> (cdr m) (cdr s))) |
51b56762f98b
(format-subtract-regions): New function.
Richard M. Stallman <rms@gnu.org>
parents:
19363
diff
changeset
|
719 (setq results (cons (cons (1+ (cdr s)) (cdr m)) results)) |
51b56762f98b
(format-subtract-regions): New function.
Richard M. Stallman <rms@gnu.org>
parents:
19363
diff
changeset
|
720 (setcdr m (cdr s))) |
51b56762f98b
(format-subtract-regions): New function.
Richard M. Stallman <rms@gnu.org>
parents:
19363
diff
changeset
|
721 ;; The subtrahend starts after the minuend ends; throw it away. |
51b56762f98b
(format-subtract-regions): New function.
Richard M. Stallman <rms@gnu.org>
parents:
19363
diff
changeset
|
722 ((< (cdr m) (car s)) |
51b56762f98b
(format-subtract-regions): New function.
Richard M. Stallman <rms@gnu.org>
parents:
19363
diff
changeset
|
723 (setq subtrahend (cdr subtrahend) s (car subtrahend))) |
51b56762f98b
(format-subtract-regions): New function.
Richard M. Stallman <rms@gnu.org>
parents:
19363
diff
changeset
|
724 ;; The subtrahend extends beyond the end of the minuend. Chop it off. |
51b56762f98b
(format-subtract-regions): New function.
Richard M. Stallman <rms@gnu.org>
parents:
19363
diff
changeset
|
725 (t ;(<= (cdr m) (cdr s))) |
51b56762f98b
(format-subtract-regions): New function.
Richard M. Stallman <rms@gnu.org>
parents:
19363
diff
changeset
|
726 (if (>= (car m) (car s)) |
51b56762f98b
(format-subtract-regions): New function.
Richard M. Stallman <rms@gnu.org>
parents:
19363
diff
changeset
|
727 (setq minuend (cdr minuend) m (car minuend)) |
51b56762f98b
(format-subtract-regions): New function.
Richard M. Stallman <rms@gnu.org>
parents:
19363
diff
changeset
|
728 (setcdr m (1- (car s))) |
51b56762f98b
(format-subtract-regions): New function.
Richard M. Stallman <rms@gnu.org>
parents:
19363
diff
changeset
|
729 (setq subtrahend (cdr subtrahend) s (car subtrahend)))))) |
51b56762f98b
(format-subtract-regions): New function.
Richard M. Stallman <rms@gnu.org>
parents:
19363
diff
changeset
|
730 (nconc (nreverse results) minuend))) |
51b56762f98b
(format-subtract-regions): New function.
Richard M. Stallman <rms@gnu.org>
parents:
19363
diff
changeset
|
731 |
51b56762f98b
(format-subtract-regions): New function.
Richard M. Stallman <rms@gnu.org>
parents:
19363
diff
changeset
|
732 ;; This should probably go somewhere other than format.el. Then again, |
51b56762f98b
(format-subtract-regions): New function.
Richard M. Stallman <rms@gnu.org>
parents:
19363
diff
changeset
|
733 ;; indent.el has alter-text-property. NOTE: We can also use |
51b56762f98b
(format-subtract-regions): New function.
Richard M. Stallman <rms@gnu.org>
parents:
19363
diff
changeset
|
734 ;; next-single-property-change instead of text-property-not-all, but then |
51b56762f98b
(format-subtract-regions): New function.
Richard M. Stallman <rms@gnu.org>
parents:
19363
diff
changeset
|
735 ;; we have to see if we passed TO. |
51b56762f98b
(format-subtract-regions): New function.
Richard M. Stallman <rms@gnu.org>
parents:
19363
diff
changeset
|
736 (defun format-property-increment-region (from to prop delta default) |
24156 | 737 "Over the region between FROM and TO increment property PROP by amount DELTA. |
738 DELTA may be negative. If property PROP is nil anywhere | |
19631
51b56762f98b
(format-subtract-regions): New function.
Richard M. Stallman <rms@gnu.org>
parents:
19363
diff
changeset
|
739 in the region, it is treated as though it were DEFAULT." |
51b56762f98b
(format-subtract-regions): New function.
Richard M. Stallman <rms@gnu.org>
parents:
19363
diff
changeset
|
740 (let ((cur from) val newval next) |
51b56762f98b
(format-subtract-regions): New function.
Richard M. Stallman <rms@gnu.org>
parents:
19363
diff
changeset
|
741 (while cur |
51b56762f98b
(format-subtract-regions): New function.
Richard M. Stallman <rms@gnu.org>
parents:
19363
diff
changeset
|
742 (setq val (get-text-property cur prop) |
51b56762f98b
(format-subtract-regions): New function.
Richard M. Stallman <rms@gnu.org>
parents:
19363
diff
changeset
|
743 newval (+ (or val default) delta) |
51b56762f98b
(format-subtract-regions): New function.
Richard M. Stallman <rms@gnu.org>
parents:
19363
diff
changeset
|
744 next (text-property-not-all cur to prop val)) |
51b56762f98b
(format-subtract-regions): New function.
Richard M. Stallman <rms@gnu.org>
parents:
19363
diff
changeset
|
745 (put-text-property cur (or next to) prop newval) |
51b56762f98b
(format-subtract-regions): New function.
Richard M. Stallman <rms@gnu.org>
parents:
19363
diff
changeset
|
746 (setq cur next)))) |
51b56762f98b
(format-subtract-regions): New function.
Richard M. Stallman <rms@gnu.org>
parents:
19363
diff
changeset
|
747 |
11054 | 748 ;;; |
749 ;;; Encoding | |
750 ;;; | |
751 | |
752 (defun format-insert-annotations (list &optional offset) | |
753 "Apply list of annotations to buffer as `write-region' would. | |
754 Inserts each element of the given LIST of buffer annotations at its | |
755 appropriate place. Use second arg OFFSET if the annotations' locations are | |
756 not relative to the beginning of the buffer: annotations will be inserted | |
757 at their location-OFFSET+1 \(ie, the offset is treated as the character number | |
758 of the first character in the buffer)." | |
24156 | 759 (if (not offset) |
11054 | 760 (setq offset 0) |
761 (setq offset (1- offset))) | |
762 (let ((l (reverse list))) | |
763 (while l | |
764 (goto-char (- (car (car l)) offset)) | |
765 (insert (cdr (car l))) | |
766 (setq l (cdr l))))) | |
767 | |
768 (defun format-annotate-value (old new) | |
769 "Return OLD and NEW as a \(close . open) annotation pair. | |
770 Useful as a default function for TRANSLATIONS alist when the value of the text | |
771 property is the name of the annotation that you want to use, as it is for the | |
772 `unknown' text property." | |
773 (cons (if old (list old)) | |
774 (if new (list new)))) | |
775 | |
24156 | 776 (defun format-annotate-region (from to translations format-fn ignore) |
11054 | 777 "Generate annotations for text properties in the region. |
778 Searches for changes between FROM and TO, and describes them with a list of | |
779 annotations as defined by alist TRANSLATIONS and FORMAT-FN. IGNORE lists text | |
780 properties not to consider; any text properties that are neither ignored nor | |
781 listed in TRANSLATIONS are warned about. | |
782 If you actually want to modify the region, give the return value of this | |
783 function to `format-insert-annotations'. | |
784 | |
785 Format of the TRANSLATIONS argument: | |
786 | |
787 Each element is a list whose car is a PROPERTY, and the following | |
788 elements are VALUES of that property followed by the names of zero or more | |
789 ANNOTATIONS. Whenever the property takes on that value, the annotations | |
790 \(as formatted by FORMAT-FN) are inserted into the file. | |
791 When the property stops having that value, the matching negated annotation | |
792 will be inserted \(it may actually be closed earlier and reopened, if | |
24156 | 793 necessary, to keep proper nesting). |
11054 | 794 |
795 If the property's value is a list, then each element of the list is dealt with | |
796 separately. | |
797 | |
798 If a VALUE is numeric, then it is assumed that there is a single annotation | |
799 and each occurrence of it increments the value of the property by that number. | |
800 Thus, given the entry \(left-margin \(4 \"indent\")), if the left margin | |
801 changes from 4 to 12, two <indent> annotations will be generated. | |
802 | |
803 If the VALUE is nil, then instead of annotations, a function should be | |
804 specified. This function is used as a default: it is called for all | |
805 transitions not explicitly listed in the table. The function is called with | |
806 two arguments, the OLD and NEW values of the property. It should return | |
807 lists of annotations like `format-annotate-location' does. | |
808 | |
809 The same structure can be used in reverse for reading files." | |
810 (let ((all-ans nil) ; All annotations - becomes return value | |
811 (open-ans nil) ; Annotations not yet closed | |
812 (loc nil) ; Current location | |
813 (not-found nil)) ; Properties that couldn't be saved | |
814 (while (or (null loc) | |
815 (and (setq loc (next-property-change loc nil to)) | |
816 (< loc to))) | |
817 (or loc (setq loc from)) | |
24156 | 818 (let* ((ans (format-annotate-location loc (= loc from) ignore translations)) |
11054 | 819 (neg-ans (format-reorder (aref ans 0) open-ans)) |
820 (pos-ans (aref ans 1)) | |
821 (ignored (aref ans 2))) | |
822 (setq not-found (append ignored not-found) | |
823 ignore (append ignored ignore)) | |
824 ;; First do the negative (closing) annotations | |
825 (while neg-ans | |
826 ;; Check if it's missing. This can happen (eg, a numeric property | |
827 ;; going negative can generate closing annotations before there are | |
828 ;; any open). Warn user & ignore. | |
829 (if (not (member (car neg-ans) open-ans)) | |
830 (message "Can't close %s: not open." (car neg-ans)) | |
831 (while (not (equal (car neg-ans) (car open-ans))) | |
832 ;; To close anno. N, need to first close ans 1 to N-1, | |
833 ;; remembering to re-open them later. | |
834 (setq pos-ans (cons (car open-ans) pos-ans)) | |
24156 | 835 (setq all-ans |
11054 | 836 (cons (cons loc (funcall format-fn (car open-ans) nil)) |
837 all-ans)) | |
838 (setq open-ans (cdr open-ans))) | |
839 ;; Now remove the one we're really interested in from open list. | |
840 (setq open-ans (cdr open-ans)) | |
841 ;; And put the closing annotation here. | |
24156 | 842 (setq all-ans |
11054 | 843 (cons (cons loc (funcall format-fn (car neg-ans) nil)) |
844 all-ans))) | |
845 (setq neg-ans (cdr neg-ans))) | |
846 ;; Now deal with positive (opening) annotations | |
847 (let ((p pos-ans)) | |
848 (while pos-ans | |
849 (setq open-ans (cons (car pos-ans) open-ans)) | |
24156 | 850 (setq all-ans |
11054 | 851 (cons (cons loc (funcall format-fn (car pos-ans) t)) |
852 all-ans)) | |
853 (setq pos-ans (cdr pos-ans)))))) | |
854 | |
855 ;; Close any annotations still open | |
856 (while open-ans | |
24156 | 857 (setq all-ans |
11054 | 858 (cons (cons to (funcall format-fn (car open-ans) nil)) |
859 all-ans)) | |
860 (setq open-ans (cdr open-ans))) | |
861 (if not-found | |
862 (message "These text properties could not be saved:\n %s" | |
863 not-found)) | |
864 (nreverse all-ans))) | |
865 | |
866 ;;; Internal functions for format-annotate-region. | |
867 | |
24156 | 868 (defun format-annotate-location (loc all ignore translations) |
869 "Return annotation(s) needed at location LOC. | |
11054 | 870 This includes any properties that change between LOC-1 and LOC. |
871 If ALL is true, don't look at previous location, but generate annotations for | |
872 all non-nil properties. | |
873 Third argument IGNORE is a list of text-properties not to consider. | |
24156 | 874 Use the TRANSLATIONS alist. |
11054 | 875 |
876 Return value is a vector of 3 elements: | |
877 1. List of names of the annotations to close | |
878 2. List of the names of annotations to open. | |
879 3. List of properties that were ignored or couldn't be annotated." | |
880 (let* ((prev-loc (1- loc)) | |
881 (before-plist (if all nil (text-properties-at prev-loc))) | |
882 (after-plist (text-properties-at loc)) | |
883 p negatives positives prop props not-found) | |
884 ;; make list of all property names involved | |
885 (setq p before-plist) | |
886 (while p | |
887 (if (not (memq (car p) props)) | |
888 (setq props (cons (car p) props))) | |
889 (setq p (cdr (cdr p)))) | |
890 (setq p after-plist) | |
891 (while p | |
892 (if (not (memq (car p) props)) | |
893 (setq props (cons (car p) props))) | |
894 (setq p (cdr (cdr p)))) | |
895 | |
896 (while props | |
897 (setq prop (car props) | |
898 props (cdr props)) | |
899 (if (memq prop ignore) | |
900 nil ; If it's been ignored before, ignore it now. | |
901 (let ((before (if all nil (car (cdr (memq prop before-plist))))) | |
902 (after (car (cdr (memq prop after-plist))))) | |
903 (if (equal before after) | |
904 nil ; no change; ignore | |
905 (let ((result (format-annotate-single-property-change | |
24156 | 906 prop before after translations))) |
11054 | 907 (if (not result) |
908 (setq not-found (cons prop not-found)) | |
909 (setq negatives (nconc negatives (car result)) | |
910 positives (nconc positives (cdr result))))))))) | |
911 (vector negatives positives not-found))) | |
912 | |
913 (defun format-annotate-single-property-change (prop old new trans) | |
24156 | 914 "Return annotations for property PROP changing from OLD to NEW. |
915 These are searched for in the translations alist TRANS. | |
11054 | 916 If NEW does not appear in the list, but there is a default function, then that |
917 function is called. | |
918 Annotations to open and to close are returned as a dotted pair." | |
919 (let ((prop-alist (cdr (assoc prop trans))) | |
920 default) | |
921 (if (not prop-alist) | |
922 nil | |
923 ;; If either old or new is a list, have to treat both that way. | |
924 (if (or (consp old) (consp new)) | |
925 (let* ((old (if (listp old) old (list old))) | |
926 (new (if (listp new) new (list new))) | |
927 (tail (format-common-tail old new)) | |
928 close open) | |
929 (while old | |
24156 | 930 (setq close |
11054 | 931 (append (car (format-annotate-atomic-property-change |
932 prop-alist (car old) nil)) | |
933 close) | |
934 old (cdr old))) | |
935 (while new | |
24156 | 936 (setq open |
11054 | 937 (append (cdr (format-annotate-atomic-property-change |
938 prop-alist nil (car new))) | |
939 open) | |
940 new (cdr new))) | |
941 (format-make-relatively-unique close open)) | |
942 (format-annotate-atomic-property-change prop-alist old new))))) | |
943 | |
944 (defun format-annotate-atomic-property-change (prop-alist old new) | |
945 "Internal function annotate a single property change. | |
13983
292411768ad9
(format-annotate-atomic-property-change): Doc fix.
Karl Heuer <kwzh@gnu.org>
parents:
13352
diff
changeset
|
946 PROP-ALIST is the relevant segment of a TRANSLATIONS list. |
11054 | 947 OLD and NEW are the values." |
19155
20fda18753c2
(format-annotate-atomic-property-change):
Richard M. Stallman <rms@gnu.org>
parents:
18690
diff
changeset
|
948 (let (num-ann) |
20fda18753c2
(format-annotate-atomic-property-change):
Richard M. Stallman <rms@gnu.org>
parents:
18690
diff
changeset
|
949 ;; If old and new values are numbers, |
20fda18753c2
(format-annotate-atomic-property-change):
Richard M. Stallman <rms@gnu.org>
parents:
18690
diff
changeset
|
950 ;; look for a number in PROP-ALIST. |
19235
759e45894579
(format-annotate-single-property-change,
Richard M. Stallman <rms@gnu.org>
parents:
19155
diff
changeset
|
951 (if (and (or (null old) (numberp old)) |
759e45894579
(format-annotate-single-property-change,
Richard M. Stallman <rms@gnu.org>
parents:
19155
diff
changeset
|
952 (or (null new) (numberp new))) |
19155
20fda18753c2
(format-annotate-atomic-property-change):
Richard M. Stallman <rms@gnu.org>
parents:
18690
diff
changeset
|
953 (progn |
20fda18753c2
(format-annotate-atomic-property-change):
Richard M. Stallman <rms@gnu.org>
parents:
18690
diff
changeset
|
954 (setq num-ann prop-alist) |
20fda18753c2
(format-annotate-atomic-property-change):
Richard M. Stallman <rms@gnu.org>
parents:
18690
diff
changeset
|
955 (while (and num-ann (not (numberp (car (car num-ann))))) |
20fda18753c2
(format-annotate-atomic-property-change):
Richard M. Stallman <rms@gnu.org>
parents:
18690
diff
changeset
|
956 (setq num-ann (cdr num-ann))))) |
20fda18753c2
(format-annotate-atomic-property-change):
Richard M. Stallman <rms@gnu.org>
parents:
18690
diff
changeset
|
957 (if num-ann |
19235
759e45894579
(format-annotate-single-property-change,
Richard M. Stallman <rms@gnu.org>
parents:
19155
diff
changeset
|
958 ;; Numerical annotation - use difference |
19359
8f531dfe20bc
(format-annotate-atomic-property-change): Fix prev change.
Richard M. Stallman <rms@gnu.org>
parents:
19245
diff
changeset
|
959 (progn |
8f531dfe20bc
(format-annotate-atomic-property-change): Fix prev change.
Richard M. Stallman <rms@gnu.org>
parents:
19245
diff
changeset
|
960 ;; If property is numeric, nil means 0 |
8f531dfe20bc
(format-annotate-atomic-property-change): Fix prev change.
Richard M. Stallman <rms@gnu.org>
parents:
19245
diff
changeset
|
961 (cond ((and (numberp old) (null new)) |
8f531dfe20bc
(format-annotate-atomic-property-change): Fix prev change.
Richard M. Stallman <rms@gnu.org>
parents:
19245
diff
changeset
|
962 (setq new 0)) |
8f531dfe20bc
(format-annotate-atomic-property-change): Fix prev change.
Richard M. Stallman <rms@gnu.org>
parents:
19245
diff
changeset
|
963 ((and (numberp new) (null old)) |
8f531dfe20bc
(format-annotate-atomic-property-change): Fix prev change.
Richard M. Stallman <rms@gnu.org>
parents:
19245
diff
changeset
|
964 (setq old 0))) |
19235
759e45894579
(format-annotate-single-property-change,
Richard M. Stallman <rms@gnu.org>
parents:
19155
diff
changeset
|
965 |
19359
8f531dfe20bc
(format-annotate-atomic-property-change): Fix prev change.
Richard M. Stallman <rms@gnu.org>
parents:
19245
diff
changeset
|
966 (let* ((entry (car num-ann)) |
8f531dfe20bc
(format-annotate-atomic-property-change): Fix prev change.
Richard M. Stallman <rms@gnu.org>
parents:
19245
diff
changeset
|
967 (increment (car entry)) |
8f531dfe20bc
(format-annotate-atomic-property-change): Fix prev change.
Richard M. Stallman <rms@gnu.org>
parents:
19245
diff
changeset
|
968 (n (ceiling (/ (float (- new old)) (float increment)))) |
8f531dfe20bc
(format-annotate-atomic-property-change): Fix prev change.
Richard M. Stallman <rms@gnu.org>
parents:
19245
diff
changeset
|
969 (anno (car (cdr entry)))) |
8f531dfe20bc
(format-annotate-atomic-property-change): Fix prev change.
Richard M. Stallman <rms@gnu.org>
parents:
19245
diff
changeset
|
970 (if (> n 0) |
8f531dfe20bc
(format-annotate-atomic-property-change): Fix prev change.
Richard M. Stallman <rms@gnu.org>
parents:
19245
diff
changeset
|
971 (cons nil (make-list n anno)) |
8f531dfe20bc
(format-annotate-atomic-property-change): Fix prev change.
Richard M. Stallman <rms@gnu.org>
parents:
19245
diff
changeset
|
972 (cons (make-list (- n) anno) nil)))) |
11054 | 973 |
19155
20fda18753c2
(format-annotate-atomic-property-change):
Richard M. Stallman <rms@gnu.org>
parents:
18690
diff
changeset
|
974 ;; Standard annotation |
20fda18753c2
(format-annotate-atomic-property-change):
Richard M. Stallman <rms@gnu.org>
parents:
18690
diff
changeset
|
975 (let ((close (and old (cdr (assoc old prop-alist)))) |
11054 | 976 (open (and new (cdr (assoc new prop-alist))))) |
977 (if (or close open) | |
978 (format-make-relatively-unique close open) | |
979 ;; Call "Default" function, if any | |
980 (let ((default (assq nil prop-alist))) | |
981 (if default | |
982 (funcall (car (cdr default)) old new)))))))) | |
983 | |
18140
f16cf00a2f42
(format-insert-file): Fix arg order to format-decode.
Richard M. Stallman <rms@gnu.org>
parents:
16954
diff
changeset
|
984 (provide 'format) |
24156 | 985 |
986 ;;; format.el ends here |