Move provide to end. Doc fixes.
[bpt/emacs.git] / lisp / format.el
CommitLineData
a8581027 1;;; format.el --- read and save files in multiple formats
b578f267 2
823139fb 3;; Copyright (c) 1994, 1995, 1997, 1999 Free Software Foundation
029894b9 4
823139fb 5;; Author: Boris Goldowsky <boris@gnu.org>
029894b9
BG
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.
b578f267 13
029894b9
BG
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.
b578f267 18
029894b9 19;; You should have received a copy of the GNU General Public License
b578f267
EN
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.
029894b9
BG
23
24;;; Commentary:
b578f267
EN
25
26;; This file defines a unified mechanism for saving & loading files stored
27;; in different formats. `format-alist' contains information that directs
029894b9 28;; Emacs to call an encoding or decoding function when reading or writing
823139fb 29;; files that match certain conditions.
029894b9 30;;
b578f267
EN
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'.
029894b9
BG
38;;
39;; Auto-save files are normally created in the same format as the visited
b578f267
EN
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).
029894b9 44;;
b578f267
EN
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'
823139fb 48;; and `format-decode-region'.
029894b9 49;;
b578f267
EN
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.
029894b9
BG
59;; * `format-replace-strings' is similarly useful for doing simple
60;; string->string translations in a reversible manner.
61
b578f267
EN
62;;; Code:
63
029894b9
BG
64(put 'buffer-file-format 'permanent-local t)
65
823139fb 66(defvar format-alist
8d0dd9d2 67 '((text/enriched "Extended MIME text/enriched format."
029894b9
BG
68 "Content-[Tt]ype:[ \t]*text/enriched"
69 enriched-decode enriched-encode t enriched-mode)
c84cf2bf 70 (plain "ISO 8859-1 standard format, no text properties."
029894b9
BG
71 ;; Plain only exists so that there is an obvious neutral choice in
72 ;; the completion list.
c84cf2bf 73 nil nil nil nil nil)
823139fb
DL
74 (ibm "IBM Code Page 850 (DOS)"
75 nil ; The original "1\\(^\\)" is obscure.
271af233 76 "recode -f ibm-pc:latin1" "recode -f latin1:ibm-pc" t nil)
823139fb
DL
77 (mac "Apple Macintosh"
78 nil
271af233 79 "recode -f mac:latin1" "recode -f latin1:mac" t nil)
823139fb
DL
80 (hp "HP Roman8"
81 nil
271af233 82 "recode -f roman8:latin1" "recode -f latin1:roman8" t nil)
823139fb
DL
83 (TeX "TeX (encoding)"
84 nil
c84cf2bf 85 iso-tex2iso iso-iso2tex t nil)
823139fb
DL
86 (gtex "German TeX (encoding)"
87 nil
c84cf2bf 88 iso-gtex2iso iso-iso2gtex t nil)
823139fb
DL
89 (html "HTML (encoding)"
90 nil
271af233 91 "recode -f html:latin1" "recode -f latin1:html" t nil)
823139fb
DL
92 (rot13 "rot13"
93 nil
c84cf2bf 94 "tr a-mn-z n-za-m" "tr a-mn-z n-za-m" t nil)
823139fb
DL
95 (duden "Duden Ersatzdarstellung"
96 nil
97 "diac" iso-iso2duden t nil)
98 (de646 "German ASCII (ISO 646)"
99 nil
271af233 100 "recode -f iso646-ge:latin1" "recode -f latin1:iso646-ge" t nil)
823139fb
DL
101 (denet "net German"
102 nil
c84cf2bf 103 iso-german iso-cvt-read-only t nil)
823139fb
DL
104 (esnet "net Spanish"
105 nil
8d0dd9d2 106 iso-spanish iso-cvt-read-only t nil))
029894b9
BG
107 "List of information about understood file formats.
108Elements are of the form \(NAME DOC-STR REGEXP FROM-FN TO-FN MODIFY MODE-FN).
d1ae737b 109
029894b9 110NAME is a symbol, which is stored in `buffer-file-format'.
d1ae737b 111
029894b9
BG
112DOC-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.
d1ae737b 115
029894b9 116REGEXP is a regular expression to match against the beginning of the file;
823139fb
DL
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.
d1ae737b 120
823139fb 121FROM-FN is called to decode files in that format; it gets two args, BEGIN
029894b9
BG
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.
d1ae737b
RS
125 Alternatively, FROM-FN can be a string, which specifies a shell command
126 (including options) to be used as a filter to perform the conversion.
127
d1abb42f
RS
128TO-FN is called to encode a region into that format; it is passed three
129 arguments: BEGIN, END, and BUFFER. BUFFER is the original buffer that
130 the data being written came from, which the function could use, for
131 example, to find the values of local variables. TO-FN should either
132 return a list of annotations like `write-region-annotate-functions',
133 or modify the region and return the new end.
d1ae737b
RS
134 Alternatively, TO-FN can be a string, which specifies a shell command
135 (including options) to be used as a filter to perform the conversion.
136
d1abb42f
RS
137MODIFY, if non-nil, means the TO-FN wants to modify the region. If nil,
138 TO-FN will not make any changes but will instead return a list of
823139fb 139 annotations.
d1ae737b 140
029894b9
BG
141MODE-FN, if specified, is called when visiting a file with that format.")
142
143;;; Basic Functions (called from Lisp)
144
c84cf2bf
RS
145(defun format-encode-run-method (method from to &optional buffer)
146 "Translate using function or shell script METHOD the text from FROM to TO.
147If METHOD is a string, it is a shell command;
148otherwise, it should be a Lisp function.
149BUFFER should be the buffer that the output originally came from."
150 (if (stringp method)
823139fb 151 (let ((error-buff (get-buffer-create "*Format Errors*"))
7cc45a35 152 (coding-system-for-read 'no-conversion)
823139fb
DL
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")))
c84cf2bf
RS
165 (funcall method from to buffer)))
166
167(defun format-decode-run-method (method from to &optional buffer)
168 "Decode using function or shell script METHOD the text from FROM to TO.
823139fb
DL
169If METHOD is a string, it is a shell command; otherwise, it should be
170a Lisp function. Decoding is done for the given BUFFER."
c84cf2bf 171 (if (stringp method)
823139fb 172 (let ((error-buff (get-buffer-create "*Format Errors*"))
7cc45a35 173 (coding-system-for-write 'no-conversion)
823139fb
DL
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"))
c84cf2bf
RS
190 (point))
191 (funcall method from to)))
192
d1abb42f 193(defun format-annotate-function (format from to orig-buf)
823139fb 194 "Return annotations for writing region as FORMAT.
029894b9
BG
195FORMAT is a symbol naming one of the formats defined in `format-alist',
196it must be a single symbol, not a list like `buffer-file-format'.
d1abb42f
RS
197FROM and TO delimit the region to be operated on in the current buffer.
198ORIG-BUF is the original buffer that the data came from.
029894b9
BG
199This function works like a function on `write-region-annotate-functions':
200it either returns a list of annotations, or returns with a different buffer
201current, which contains the modified text to write.
202
203For most purposes, consider using `format-encode-region' instead."
823139fb 204 ;; This function is called by write-region (actually build-annotations)
029894b9
BG
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)
c84cf2bf 216 (format-encode-run-method to-fn (point-min) (point-max) orig-buf)
029894b9
BG
217 nil)
218 ;; Otherwise just call function, it will return annotations.
d1abb42f 219 (funcall to-fn from to orig-buf)))))
029894b9
BG
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.
823139fb 224FORMAT is a symbol appearing in `format-alist' or a list of such symbols,
029894b9
BG
225or nil, in which case this function tries to guess the format of the data by
226matching against the regular expressions in `format-alist'. After a match is
227found and the region decoded, the alist is searched again from the beginning
228for another match.
229
230Second arg LENGTH is the number of characters following point to operate on.
231If optional third arg VISIT-FLAG is true, set `buffer-file-format'
232to the list of formats used, and call any mode functions defined for those
233formats.
234
235Returns the new length of the decoded region.
236
237For most purposes, consider using `format-decode-region' instead."
238 (let ((mod (buffer-modified-p))
823139fb 239 (begin (point))
029894b9
BG
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
c84cf2bf
RS
253 (if (nth 3 f)
254 (setq end (format-decode-run-method (nth 3 f) begin end)))
029894b9
BG
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:
c84cf2bf
RS
269 (if (nth 3 f)
270 (setq end (format-decode-run-method (nth 3 f) begin end)))
029894b9
BG
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.
286If the format is not specified, this function attempts to guess.
823139fb 287`buffer-file-format' is set to the format used, and any mode-functions
029894b9
BG
288for 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.
297Arg FORMAT is optional; if omitted the format will be determined by looking
298for identifying regular expressions at the beginning of the region."
299 (interactive
823139fb 300 (list (region-beginning) (region-end)
029894b9
BG
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.
308FORMAT defaults to `buffer-file-format'. It is a symbol naming one of the
309formats 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)
823139fb 316 "Translate the region into some FORMAT.
029894b9
BG
317FORMAT defaults to `buffer-file-format', it is a symbol naming
318one of the formats defined in `format-alist', or a list of such symbols."
823139fb
DL
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)))))))
029894b9
BG
341
342(defun format-write-file (filename format)
823139fb 343 "Write current buffer into file FILENAME using some FORMAT.
029894b9
BG
344Makes buffer visit that file and sets the format as the default for future
345saves. If the buffer is already visiting a file, you can specify a directory
823139fb 346name as FILENAME, to write a file of the same old name in that directory."
029894b9
BG
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))))
823139fb 356 (fmt (format-read (format "Write file `%s' in format: "
029894b9
BG
357 (file-name-nondirectory file)))))
358 (list file fmt)))
359 (setq buffer-file-format format)
360 (write-file filename))
361
ce6af52b 362(defun format-find-file (filename format)
823139fb 363 "Find the file FILENAME using data format FORMAT.
ce6af52b
KH
364If FORMAT is nil then do not do any format conversion."
365 (interactive
366 ;; Same interactive spec as write-file, plus format question.
367 (let* ((file (read-file-name "Find file: "))
823139fb 368 (fmt (format-read (format "Read file `%s' in format: "
ce6af52b
KH
369 (file-name-nondirectory file)))))
370 (list file fmt)))
371 (let ((format-alist nil))
372 (find-file filename))
373 (if format
374 (format-decode-buffer format)))
375
376(defun format-insert-file (filename format &optional beg end)
823139fb 377 "Insert the contents of file FILENAME using data format FORMAT.
ce6af52b
KH
378If FORMAT is nil then do not do any format conversion.
379The optional third and fourth arguments BEG and END specify
380the part of the file to read.
381
382The return value is like the value of `insert-file-contents':
383a list (ABSOLUTE-FILE-NAME . SIZE)."
384 (interactive
385 ;; Same interactive spec as write-file, plus format question.
386 (let* ((file (read-file-name "Find file: "))
823139fb 387 (fmt (format-read (format "Read file `%s' in format: "
ce6af52b
KH
388 (file-name-nondirectory file)))))
389 (list file fmt)))
390 (let (value size)
391 (let ((format-alist nil))
392 (setq value (insert-file-contents filename nil beg end))
393 (setq size (nth 1 value)))
394 (if format
c84cf2bf 395 (setq size (format-decode format size)
ce6af52b
KH
396 value (cons (car value) size)))
397 value))
398
029894b9
BG
399(defun format-read (&optional prompt)
400 "Read and return the name of a format.
401Return value is a list, like `buffer-file-format'; it may be nil.
402Formats 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.
416ALIST is a list of (from . to) pairs, which should be proper arguments to
417`search-forward' and `replace-match' respectively.
418Optional 2nd arg REVERSE, if non-nil, means the pairs are (to . from), so that
419you can use the same list in both directions if it contains only literal
823139fb
DL
420strings.
421Optional args BEG and END specify a region of the buffer on which to operate."
029894b9
BG
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))))
2c3ac81d 428 (to (if reverse (car (car alist)) (cdr (car alist)))))
029894b9
BG
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)
823139fb
DL
442 "Remove the given CONS from LIST by side effect and return the new LIST.
443Since CONS could be the first element of LIST, write
444`\(setq foo \(format-delq-cons element foo))' to be sure of changing
445the value of `foo'."
029894b9
BG
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.
458Compares 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.
472Compares with `equal', and returns the part of A that is equal to the
473equivalent part of B. If even the last items of the two are not equal,
474returns nil."
475 (let ((la (length a))
476 (lb (length b)))
477 ;; Make sure they are the same length
823139fb 478 (if (> la lb)
029894b9
BG
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
f0a6c717
GM
486(defun format-proper-list-p (list)
487 "Return t if LIST is a proper list.
488A proper list is a list ending with a nil cdr, not with an atom "
489 (when (listp list)
490 (while (consp list)
491 (setq list (cdr list)))
492 (null list)))
493
029894b9
BG
494(defun format-reorder (items order)
495 "Arrange ITEMS to following partial ORDER.
496Elements of ITEMS equal to elements of ORDER will be rearranged to follow the
497ORDER. Unmatched items will go last."
498 (if order
499 (let ((item (member (car order) items)))
500 (if item
823139fb 501 (cons (car item)
029894b9
BG
502 (format-reorder (format-delq-cons item items)
503 (cdr order)))
504 (format-reorder items (cdr order))))
505 items))
506
507(put 'face 'format-list-valued t) ; These text-properties take values
508(put 'unknown 'format-list-valued t) ; that are lists, the elements of which
509 ; should be considered separately.
510 ; See format-deannotate-region and
511 ; format-annotate-region.
512
f3bbef87
GM
513;; This text property has list values, but they are treated atomically.
514
515(put 'display 'format-list-atomic-p t)
516
029894b9
BG
517;;;
518;;; Decoding
519;;;
520
521(defun format-deannotate-region (from to translations next-fn)
522 "Translate annotations in the region into text properties.
823139fb 523This sets text properties between FROM to TO as directed by the
029894b9
BG
524TRANSLATIONS and NEXT-FN arguments.
525
526NEXT-FN is a function that searches forward from point for an annotation.
527It should return a list of 4 elements: \(BEGIN END NAME POSITIVE). BEGIN and
528END are buffer positions bounding the annotation, NAME is the name searched
529for in TRANSLATIONS, and POSITIVE should be non-nil if this annotation marks
530the beginning of a region with some property, or nil if it ends the region.
531NEXT-FN should return nil if there are no annotations after point.
532
533The basic format of the TRANSLATIONS argument is described in the
534documentation for the `format-annotate-region' function. There are some
535additional things to keep in mind for decoding, though:
536
537When an annotation is found, the TRANSLATIONS list is searched for a
538text-property name and value that corresponds to that annotation. If the
539text-property has several annotations associated with it, it will be used only
540if the other annotations are also in effect at that point. The first match
541found whose annotations are all present is used.
542
543The text property thus determined is set to the value over the region between
544the opening and closing annotations. However, if the text-property name has a
545non-nil `format-list-valued' property, then the value will be consed onto the
546surrounding value of the property, rather than replacing that value.
547
548There are some special symbols that can be used in the \"property\" slot of
549the TRANSLATIONS list: PARAMETER and FUNCTION \(spelled in uppercase).
550Annotations listed under the pseudo-property PARAMETER are considered to be
551arguments of the immediately surrounding annotation; the text between the
552opening and closing parameter annotations is deleted from the buffer but saved
553as a string. The surrounding annotation should be listed under the
554pseudo-property FUNCTION. Instead of inserting a text-property for this
555annotation, the function listed in the VALUE slot is called to make whatever
556changes are appropriate. The function's first two arguments are the START and
557END locations, and the rest of the arguments are any PARAMETERs found in that
558region.
559
560Any annotations that are found by NEXT-FN but not defined by TRANSLATIONS
561are saved as values of the `unknown' text-property \(which is list-valued).
562The TRANSLATIONS list should usually contain an entry of the form
563 \(unknown \(nil format-annotate-value))
564to write these unknown annotations back into the file."
565 (save-excursion
566 (save-restriction
567 (narrow-to-region (point-min) to)
568 (goto-char from)
569 (let (next open-ans todo loc unknown-ans)
570 (while (setq next (funcall next-fn))
571 (let* ((loc (nth 0 next))
572 (end (nth 1 next))
573 (name (nth 2 next))
574 (positive (nth 3 next))
575 (found nil))
576
577 ;; Delete the annotation
578 (delete-region loc end)
22828206
RS
579 (cond
580 ;; Positive annotations are stacked, remembering location
581 (positive (setq open-ans (cons `(,name ((,loc . nil))) open-ans)))
582 ;; It is a negative annotation:
583 ;; Close the top annotation & add its text property.
584 ;; If the file's nesting is messed up, the close might not match
585 ;; the top thing on the open-annotations stack.
586 ;; If no matching annotation is open, just ignore the close.
587 ((not (assoc name open-ans))
588 (message "Extra closing annotation (%s) in file" name))
589 ;; If one is open, but not on the top of the stack, close
590 ;; the things in between as well. Set `found' when the real
591 ;; one is closed.
592 (t
593 (while (not found)
594 (let* ((top (car open-ans)) ; first on stack: should match.
595 (top-name (car top)) ; text property name
596 (top-extents (nth 1 top)) ; property regions
597 (params (cdr (cdr top))) ; parameters
598 (aalist translations)
599 (matched nil))
600 (if (equal name top-name)
601 (setq found t)
602 (message "Improper nesting in file."))
603 ;; Look through property names in TRANSLATIONS
604 (while aalist
605 (let ((prop (car (car aalist)))
606 (alist (cdr (car aalist))))
607 ;; And look through values for each property
608 (while alist
609 (let ((value (car (car alist)))
610 (ans (cdr (car alist))))
611 (if (member top-name ans)
612 ;; This annotation is listed, but still have to
613 ;; check if multiple annotations are satisfied
614 (if (member nil (mapcar (lambda (r)
615 (assoc r open-ans))
616 ans))
617 nil ; multiple ans not satisfied
618 ;; If there are multiple annotations going
619 ;; into one text property, split up the other
620 ;; annotations so they apply individually to
621 ;; the other regions.
622 (setcdr (car top-extents) loc)
623 (let ((to-split ans) this-one extents)
624 (while to-split
625 (setq this-one
626 (assoc (car to-split) open-ans)
627 extents (nth 1 this-one))
628 (if (not (eq this-one top))
629 (setcar (cdr this-one)
630 (format-subtract-regions
631 extents top-extents)))
632 (setq to-split (cdr to-split))))
633 ;; Set loop variables to nil so loop
634 ;; will exit.
635 (setq alist nil aalist nil matched t
636 ;; pop annotation off stack.
637 open-ans (cdr open-ans))
638 (let ((extents top-extents)
639 (start (car (car top-extents)))
640 (loc (cdr (car top-extents))))
641 (while extents
642 (cond
643 ;; Check for pseudo-properties
644 ((eq prop 'PARAMETER)
645 ;; A parameter of the top open ann:
646 ;; delete text and use as arg.
647 (if open-ans
648 ;; (If nothing open, discard).
649 (setq open-ans
650 (cons
651 (append (car open-ans)
652 (list
653 (buffer-substring
654 start loc)))
655 (cdr open-ans))))
656 (delete-region start loc))
657 ((eq prop 'FUNCTION)
658 ;; Not a property, but a function.
659 (let ((rtn
660 (apply value start loc params)))
661 (if rtn (setq todo (cons rtn todo)))))
662 (t
663 ;; Normal property/value pair
664 (setq todo
665 (cons (list start loc prop value)
666 todo))))
667 (setq extents (cdr extents)
668 start (car (car extents))
669 loc (cdr (car extents))))))))
670 (setq alist (cdr alist))))
671 (setq aalist (cdr aalist)))
672 (if (not matched)
029894b9
BG
673 ;; Didn't find any match for the annotation:
674 ;; Store as value of text-property `unknown'.
22828206
RS
675 (let ((extents top-extents)
676 (start (car (car top-extents)))
0b140219 677 (loc (or (cdr (car top-extents)) loc)))
22828206
RS
678 (while extents
679 (setq open-ans (cdr open-ans)
680 todo (cons (list start loc 'unknown top-name)
681 todo)
682 unknown-ans (cons name unknown-ans)
683 extents (cdr extents)
684 start (car (car extents))
685 loc (cdr (car extents))))))))))))
029894b9
BG
686
687 ;; Once entire file has been scanned, add the properties.
688 (while todo
689 (let* ((item (car todo))
690 (from (nth 0 item))
691 (to (nth 1 item))
692 (prop (nth 2 item))
693 (val (nth 3 item)))
22828206
RS
694
695 (if (numberp val) ; add to ambient value if numeric
696 (format-property-increment-region from to prop val 0)
697 (put-text-property
029894b9 698 from to prop
22828206 699 (cond ((get prop 'format-list-valued) ; value gets consed onto
029894b9
BG
700 ; list-valued properties
701 (let ((prev (get-text-property from prop)))
702 (cons val (if (listp prev) prev (list prev)))))
22828206 703 (t val))))) ; normally, just set to val.
029894b9 704 (setq todo (cdr todo)))
22828206 705
029894b9
BG
706 (if unknown-ans
707 (message "Unknown annotations: %s" unknown-ans))))))
708
22828206 709(defun format-subtract-regions (minu subtra)
823139fb
DL
710 "Remove from the regions in MINUend the regions in SUBTRAhend.
711A region is a dotted pair (from . to). Both parameters are lists of
712regions. Each list must contain nonoverlapping, noncontiguous
713regions, in descending order. The result is also nonoverlapping,
714noncontiguous, and in descending order. The first element of MINUEND
715can have a cdr of nil, indicating that the end of that region is not
716yet known."
22828206
RS
717 (let* ((minuend (copy-alist minu))
718 (subtrahend (copy-alist subtra))
719 (m (car minuend))
720 (s (car subtrahend))
721 results)
722 (while (and minuend subtrahend)
823139fb 723 (cond
22828206
RS
724 ;; The minuend starts after the subtrahend ends; keep it.
725 ((> (car m) (cdr s))
726 (setq results (cons m results)
727 minuend (cdr minuend)
728 m (car minuend)))
729 ;; The minuend extends beyond the end of the subtrahend. Chop it off.
730 ((or (null (cdr m)) (> (cdr m) (cdr s)))
731 (setq results (cons (cons (1+ (cdr s)) (cdr m)) results))
732 (setcdr m (cdr s)))
733 ;; The subtrahend starts after the minuend ends; throw it away.
734 ((< (cdr m) (car s))
735 (setq subtrahend (cdr subtrahend) s (car subtrahend)))
736 ;; The subtrahend extends beyond the end of the minuend. Chop it off.
737 (t ;(<= (cdr m) (cdr s)))
738 (if (>= (car m) (car s))
739 (setq minuend (cdr minuend) m (car minuend))
740 (setcdr m (1- (car s)))
741 (setq subtrahend (cdr subtrahend) s (car subtrahend))))))
742 (nconc (nreverse results) minuend)))
743
744;; This should probably go somewhere other than format.el. Then again,
745;; indent.el has alter-text-property. NOTE: We can also use
746;; next-single-property-change instead of text-property-not-all, but then
747;; we have to see if we passed TO.
748(defun format-property-increment-region (from to prop delta default)
823139fb
DL
749 "Over the region between FROM and TO increment property PROP by amount DELTA.
750DELTA may be negative. If property PROP is nil anywhere
22828206
RS
751in the region, it is treated as though it were DEFAULT."
752 (let ((cur from) val newval next)
753 (while cur
754 (setq val (get-text-property cur prop)
755 newval (+ (or val default) delta)
756 next (text-property-not-all cur to prop val))
757 (put-text-property cur (or next to) prop newval)
758 (setq cur next))))
759
029894b9
BG
760;;;
761;;; Encoding
762;;;
763
764(defun format-insert-annotations (list &optional offset)
765 "Apply list of annotations to buffer as `write-region' would.
766Inserts each element of the given LIST of buffer annotations at its
767appropriate place. Use second arg OFFSET if the annotations' locations are
768not relative to the beginning of the buffer: annotations will be inserted
769at their location-OFFSET+1 \(ie, the offset is treated as the character number
770of the first character in the buffer)."
823139fb 771 (if (not offset)
029894b9
BG
772 (setq offset 0)
773 (setq offset (1- offset)))
774 (let ((l (reverse list)))
775 (while l
776 (goto-char (- (car (car l)) offset))
777 (insert (cdr (car l)))
778 (setq l (cdr l)))))
779
780(defun format-annotate-value (old new)
781 "Return OLD and NEW as a \(close . open) annotation pair.
782Useful as a default function for TRANSLATIONS alist when the value of the text
783property is the name of the annotation that you want to use, as it is for the
784`unknown' text property."
785 (cons (if old (list old))
786 (if new (list new))))
787
823139fb 788(defun format-annotate-region (from to translations format-fn ignore)
029894b9
BG
789 "Generate annotations for text properties in the region.
790Searches for changes between FROM and TO, and describes them with a list of
791annotations as defined by alist TRANSLATIONS and FORMAT-FN. IGNORE lists text
792properties not to consider; any text properties that are neither ignored nor
793listed in TRANSLATIONS are warned about.
794If you actually want to modify the region, give the return value of this
795function to `format-insert-annotations'.
796
797Format of the TRANSLATIONS argument:
798
799Each element is a list whose car is a PROPERTY, and the following
800elements are VALUES of that property followed by the names of zero or more
801ANNOTATIONS. Whenever the property takes on that value, the annotations
802\(as formatted by FORMAT-FN) are inserted into the file.
803When the property stops having that value, the matching negated annotation
804will be inserted \(it may actually be closed earlier and reopened, if
823139fb 805necessary, to keep proper nesting).
029894b9
BG
806
807If the property's value is a list, then each element of the list is dealt with
808separately.
809
810If a VALUE is numeric, then it is assumed that there is a single annotation
811and each occurrence of it increments the value of the property by that number.
812Thus, given the entry \(left-margin \(4 \"indent\")), if the left margin
813changes from 4 to 12, two <indent> annotations will be generated.
814
815If the VALUE is nil, then instead of annotations, a function should be
816specified. This function is used as a default: it is called for all
817transitions not explicitly listed in the table. The function is called with
818two arguments, the OLD and NEW values of the property. It should return
819lists of annotations like `format-annotate-location' does.
820
821 The same structure can be used in reverse for reading files."
822 (let ((all-ans nil) ; All annotations - becomes return value
823 (open-ans nil) ; Annotations not yet closed
824 (loc nil) ; Current location
825 (not-found nil)) ; Properties that couldn't be saved
826 (while (or (null loc)
827 (and (setq loc (next-property-change loc nil to))
828 (< loc to)))
829 (or loc (setq loc from))
823139fb 830 (let* ((ans (format-annotate-location loc (= loc from) ignore translations))
029894b9
BG
831 (neg-ans (format-reorder (aref ans 0) open-ans))
832 (pos-ans (aref ans 1))
833 (ignored (aref ans 2)))
834 (setq not-found (append ignored not-found)
835 ignore (append ignored ignore))
836 ;; First do the negative (closing) annotations
837 (while neg-ans
838 ;; Check if it's missing. This can happen (eg, a numeric property
839 ;; going negative can generate closing annotations before there are
840 ;; any open). Warn user & ignore.
841 (if (not (member (car neg-ans) open-ans))
842 (message "Can't close %s: not open." (car neg-ans))
843 (while (not (equal (car neg-ans) (car open-ans)))
844 ;; To close anno. N, need to first close ans 1 to N-1,
845 ;; remembering to re-open them later.
846 (setq pos-ans (cons (car open-ans) pos-ans))
823139fb 847 (setq all-ans
029894b9
BG
848 (cons (cons loc (funcall format-fn (car open-ans) nil))
849 all-ans))
850 (setq open-ans (cdr open-ans)))
851 ;; Now remove the one we're really interested in from open list.
852 (setq open-ans (cdr open-ans))
853 ;; And put the closing annotation here.
823139fb 854 (setq all-ans
029894b9
BG
855 (cons (cons loc (funcall format-fn (car neg-ans) nil))
856 all-ans)))
857 (setq neg-ans (cdr neg-ans)))
858 ;; Now deal with positive (opening) annotations
859 (let ((p pos-ans))
860 (while pos-ans
861 (setq open-ans (cons (car pos-ans) open-ans))
823139fb 862 (setq all-ans
029894b9
BG
863 (cons (cons loc (funcall format-fn (car pos-ans) t))
864 all-ans))
865 (setq pos-ans (cdr pos-ans))))))
866
867 ;; Close any annotations still open
868 (while open-ans
823139fb 869 (setq all-ans
029894b9
BG
870 (cons (cons to (funcall format-fn (car open-ans) nil))
871 all-ans))
872 (setq open-ans (cdr open-ans)))
873 (if not-found
874 (message "These text properties could not be saved:\n %s"
875 not-found))
876 (nreverse all-ans)))
877
878;;; Internal functions for format-annotate-region.
879
823139fb
DL
880(defun format-annotate-location (loc all ignore translations)
881 "Return annotation(s) needed at location LOC.
029894b9
BG
882This includes any properties that change between LOC-1 and LOC.
883If ALL is true, don't look at previous location, but generate annotations for
884all non-nil properties.
885Third argument IGNORE is a list of text-properties not to consider.
823139fb 886Use the TRANSLATIONS alist.
029894b9
BG
887
888Return value is a vector of 3 elements:
8891. List of names of the annotations to close
8902. List of the names of annotations to open.
8913. List of properties that were ignored or couldn't be annotated."
892 (let* ((prev-loc (1- loc))
893 (before-plist (if all nil (text-properties-at prev-loc)))
894 (after-plist (text-properties-at loc))
895 p negatives positives prop props not-found)
896 ;; make list of all property names involved
897 (setq p before-plist)
898 (while p
899 (if (not (memq (car p) props))
900 (setq props (cons (car p) props)))
901 (setq p (cdr (cdr p))))
902 (setq p after-plist)
903 (while p
904 (if (not (memq (car p) props))
905 (setq props (cons (car p) props)))
906 (setq p (cdr (cdr p))))
907
908 (while props
909 (setq prop (car props)
910 props (cdr props))
911 (if (memq prop ignore)
912 nil ; If it's been ignored before, ignore it now.
913 (let ((before (if all nil (car (cdr (memq prop before-plist)))))
914 (after (car (cdr (memq prop after-plist)))))
915 (if (equal before after)
916 nil ; no change; ignore
917 (let ((result (format-annotate-single-property-change
823139fb 918 prop before after translations)))
029894b9
BG
919 (if (not result)
920 (setq not-found (cons prop not-found))
921 (setq negatives (nconc negatives (car result))
922 positives (nconc positives (cdr result)))))))))
923 (vector negatives positives not-found)))
924
925(defun format-annotate-single-property-change (prop old new trans)
823139fb
DL
926 "Return annotations for property PROP changing from OLD to NEW.
927These are searched for in the translations alist TRANS.
029894b9
BG
928If NEW does not appear in the list, but there is a default function, then that
929function is called.
930Annotations to open and to close are returned as a dotted pair."
931 (let ((prop-alist (cdr (assoc prop trans)))
932 default)
933 (if (not prop-alist)
934 nil
029894b9 935 ;; If either old or new is a list, have to treat both that way.
f0a6c717 936 (if (and (or (listp old) (listp new))
f3bbef87 937 (not (get prop 'format-list-atomic-p)))
f0a6c717
GM
938 (if (or (not (format-proper-list-p old))
939 (not (format-proper-list-p new)))
940 (format-annotate-atomic-property-change prop-alist old new)
941 (let* ((old (if (listp old) old (list old)))
942 (new (if (listp new) new (list new)))
943 (tail (format-common-tail old new))
944 close open)
945 (while old
946 (setq close
947 (append (car (format-annotate-atomic-property-change
948 prop-alist (car old) nil))
949 close)
950 old (cdr old)))
951 (while new
952 (setq open
953 (append (cdr (format-annotate-atomic-property-change
954 prop-alist nil (car new)))
955 open)
956 new (cdr new)))
957 (format-make-relatively-unique close open)))
029894b9
BG
958 (format-annotate-atomic-property-change prop-alist old new)))))
959
960(defun format-annotate-atomic-property-change (prop-alist old new)
961 "Internal function annotate a single property change.
fa1f61e5 962PROP-ALIST is the relevant segment of a TRANSLATIONS list.
029894b9 963OLD and NEW are the values."
e5a60108
RS
964 (let (num-ann)
965 ;; If old and new values are numbers,
966 ;; look for a number in PROP-ALIST.
5f525595
RS
967 (if (and (or (null old) (numberp old))
968 (or (null new) (numberp new)))
e5a60108
RS
969 (progn
970 (setq num-ann prop-alist)
971 (while (and num-ann (not (numberp (car (car num-ann)))))
972 (setq num-ann (cdr num-ann)))))
973 (if num-ann
5f525595 974 ;; Numerical annotation - use difference
34fbecde
RS
975 (progn
976 ;; If property is numeric, nil means 0
977 (cond ((and (numberp old) (null new))
978 (setq new 0))
979 ((and (numberp new) (null old))
980 (setq old 0)))
981
982 (let* ((entry (car num-ann))
983 (increment (car entry))
984 (n (ceiling (/ (float (- new old)) (float increment))))
985 (anno (car (cdr entry))))
986 (if (> n 0)
987 (cons nil (make-list n anno))
988 (cons (make-list (- n) anno) nil))))
e5a60108
RS
989
990 ;; Standard annotation
991 (let ((close (and old (cdr (assoc old prop-alist))))
029894b9
BG
992 (open (and new (cdr (assoc new prop-alist)))))
993 (if (or close open)
994 (format-make-relatively-unique close open)
995 ;; Call "Default" function, if any
996 (let ((default (assq nil prop-alist)))
997 (if default
998 (funcall (car (cdr default)) old new))))))))
999
c84cf2bf 1000(provide 'format)
823139fb
DL
1001
1002;;; format.el ends here