In window--min-size-1 set WINDOW arg when calling window-min-pixel-height/-width.
[emacs.git] / lisp / format.el
blob5529e6c3a48ad7df1af6c73d25fdc0f008840272
1 ;;; format.el --- read and save files in multiple formats
3 ;; Copyright (C) 1994-1995, 1997, 1999, 2001-2014 Free Software
4 ;; Foundation, Inc.
6 ;; Author: Boris Goldowsky <boris@gnu.org>
7 ;; Package: emacs
9 ;; This file is part of GNU Emacs.
11 ;; GNU Emacs is free software: you can redistribute it and/or modify
12 ;; it under the terms of the GNU General Public License as published by
13 ;; the Free Software Foundation, either version 3 of the License, or
14 ;; (at your option) any later version.
16 ;; GNU Emacs is distributed in the hope that it will be useful,
17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
19 ;; GNU General Public License for more details.
21 ;; You should have received a copy of the GNU General Public License
22 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
24 ;;; Commentary:
26 ;; This file defines a unified mechanism for saving & loading files stored
27 ;; in different formats. `format-alist' contains information that directs
28 ;; Emacs to call an encoding or decoding function when reading or writing
29 ;; files that match certain conditions.
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'.
39 ;; Auto-save files are normally created in the same format as the visited
40 ;; file, but the variable `buffer-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).
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'
48 ;; and `format-decode-region'.
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.
59 ;; * `format-replace-strings' is similarly useful for doing simple
60 ;; string->string translations in a reversible manner.
62 ;;; Code:
64 (put 'buffer-file-format 'permanent-local t)
65 (put 'buffer-auto-save-file-format 'permanent-local t)
67 (defvar format-alist
68 ;; FIXME: maybe each item can be purecopied instead of just the strings.
69 `((text/enriched ,(purecopy "Extended MIME text/enriched format.")
70 ,(purecopy "Content-[Tt]ype:[ \t]*text/enriched")
71 enriched-decode enriched-encode t enriched-mode)
72 (plain ,(purecopy "ISO 8859-1 standard format, no text properties.")
73 ;; Plain only exists so that there is an obvious neutral choice in
74 ;; the completion list.
75 nil nil nil nil nil)
76 (TeX ,(purecopy "TeX (encoding)")
77 nil
78 iso-tex2iso iso-iso2tex t nil)
79 (gtex ,(purecopy "German TeX (encoding)")
80 nil
81 iso-gtex2iso iso-iso2gtex t nil)
82 (html ,(purecopy "HTML/SGML \"ISO 8879:1986//ENTITIES Added Latin 1//EN\" (encoding)")
83 nil
84 iso-sgml2iso iso-iso2sgml t nil)
85 (rot13 ,(purecopy "rot13")
86 nil
87 ,(purecopy "tr a-mn-z n-za-m") ,(purecopy "tr a-mn-z n-za-m") t nil)
88 (duden ,(purecopy "Duden Ersatzdarstellung")
89 nil
90 ,(purecopy "diac") iso-iso2duden t nil)
91 (de646 ,(purecopy "German ASCII (ISO 646)")
92 nil
93 ,(purecopy "recode -f iso646-ge:latin1")
94 ,(purecopy "recode -f latin1:iso646-ge") t nil)
95 (denet ,(purecopy "net German")
96 nil
97 iso-german iso-cvt-read-only t nil)
98 (esnet ,(purecopy "net Spanish")
99 nil
100 iso-spanish iso-cvt-read-only t nil))
101 "List of information about understood file formats.
102 Elements are of the form
103 \(NAME DOC-STR REGEXP FROM-FN TO-FN MODIFY MODE-FN PRESERVE).
105 NAME is a symbol, which is stored in `buffer-file-format'.
107 DOC-STR should be a single line providing more information about the
108 format. It is currently unused, but in the future will be shown to
109 the user if they ask for more information.
111 REGEXP is a regular expression to match against the beginning of the file;
112 it should match only files in that format. REGEXP may be nil, in
113 which case the format will never be applied automatically to a file.
114 Use this for formats that you only ever want to apply manually.
116 FROM-FN is called to decode files in that format; it takes two args, BEGIN
117 and END, and can make any modifications it likes, returning the new
118 end. It must make sure that the beginning of the file no longer
119 matches REGEXP, or else it will get called again.
120 Alternatively, FROM-FN can be a string, which specifies a shell command
121 (including options) to be used as a filter to perform the conversion.
123 TO-FN is called to encode a region into that format; it takes three
124 arguments: BEGIN, END, and BUFFER. BUFFER is the original buffer that
125 the data being written came from, which the function could use, for
126 example, to find the values of local variables. TO-FN should either
127 return a list of annotations like `write-region-annotate-functions',
128 or modify the region and return the new end.
129 Alternatively, TO-FN can be a string, which specifies a shell command
130 (including options) to be used as a filter to perform the conversion.
132 MODIFY, if non-nil, means the TO-FN wants to modify the region. If nil,
133 TO-FN will not make any changes but will instead return a list of
134 annotations.
136 MODE-FN, if specified, is called when visiting a file with that format.
137 It is called with a single positive argument, on the assumption
138 that this would turn on some minor mode.
140 PRESERVE, if non-nil, means that `format-write-file' should not remove
141 this format from `buffer-file-format'.")
142 ;;;###autoload
143 (put 'format-alist 'risky-local-variable t)
145 ;;; Basic Functions (called from Lisp)
147 (defun format-encode-run-method (method from to &optional buffer)
148 "Translate using METHOD the text from FROM to TO.
149 If METHOD is a string, it is a shell command (including options);
150 otherwise, it should be a Lisp function.
151 BUFFER should be the buffer that the output originally came from."
152 (if (stringp method)
153 (let ((error-buff (get-buffer-create "*Format Errors*"))
154 (coding-system-for-read 'no-conversion)
155 format-alist)
156 (with-current-buffer error-buff
157 (widen)
158 (erase-buffer))
159 (if (and (zerop (save-window-excursion
160 (shell-command-on-region from to method t t
161 error-buff)))
162 ;; gzip gives zero exit status with bad args, for instance.
163 (zerop (with-current-buffer error-buff
164 (buffer-size))))
165 (bury-buffer error-buff)
166 (switch-to-buffer-other-window error-buff)
167 (error "Format encoding failed")))
168 (funcall method from to buffer)))
170 (defun format-decode-run-method (method from to &optional _buffer)
171 "Decode using METHOD the text from FROM to TO.
172 If METHOD is a string, it is a shell command (including options); otherwise,
173 it should be a Lisp function. BUFFER is currently ignored."
174 (if (stringp method)
175 (let ((error-buff (get-buffer-create "*Format Errors*"))
176 (coding-system-for-write 'no-conversion)
177 format-alist)
178 (with-current-buffer error-buff
179 (widen)
180 (erase-buffer))
181 ;; We should perhaps go via a temporary buffer and copy it
182 ;; back, in case of errors.
183 (if (and (zerop (save-window-excursion
184 (shell-command-on-region from to method t t
185 error-buff)))
186 ;; gzip gives zero exit status with bad args, for instance.
187 (zerop (with-current-buffer error-buff
188 (buffer-size))))
189 (bury-buffer error-buff)
190 (switch-to-buffer-other-window error-buff)
191 (error "Format decoding failed"))
192 (point))
193 (funcall method from to)))
195 (defun format-annotate-function (format from to orig-buf format-count)
196 "Return annotations for writing region as FORMAT.
197 FORMAT is a symbol naming one of the formats defined in `format-alist'.
198 It must be a single symbol, not a list like `buffer-file-format'.
199 FROM and TO delimit the region to be operated on in the current buffer.
200 ORIG-BUF is the original buffer that the data came from.
202 FORMAT-COUNT is an integer specifying how many times this function has
203 been called in the process of decoding ORIG-BUF.
205 This function works like a function in `write-region-annotate-functions':
206 it either returns a list of annotations, or returns with a different buffer
207 current, which contains the modified text to write. In the latter case,
208 this function's value is nil.
210 For most purposes, consider using `format-encode-region' instead."
211 ;; This function is called by write-region (actually
212 ;; build_annotations) for each element of buffer-file-format.
213 (let* ((info (assq format format-alist))
214 (to-fn (nth 4 info))
215 (modify (nth 5 info)))
216 (if to-fn
217 (if modify
218 ;; To-function wants to modify region. Copy to safe place.
219 (let ((copy-buf (get-buffer-create (format " *Format Temp %d*"
220 format-count)))
221 (sel-disp selective-display)
222 (multibyte enable-multibyte-characters)
223 (coding-system buffer-file-coding-system))
224 (with-current-buffer copy-buf
225 (setq selective-display sel-disp)
226 (set-buffer-multibyte multibyte)
227 (setq buffer-file-coding-system coding-system))
228 (let ((inhibit-read-only t)) ; bug#14887
229 (copy-to-buffer copy-buf from to)
230 (set-buffer copy-buf)
231 (format-insert-annotations write-region-annotations-so-far from)
232 (format-encode-run-method to-fn (point-min) (point-max)
233 orig-buf))
234 (when (buffer-live-p copy-buf)
235 (with-current-buffer copy-buf
236 ;; Set write-region-post-annotation-function to
237 ;; delete the buffer once the write is done, but do
238 ;; it after running to-fn so it doesn't affect
239 ;; write-region calls in to-fn.
240 (set (make-local-variable
241 'write-region-post-annotation-function)
242 'kill-buffer)))
243 nil)
244 ;; Otherwise just call function, it will return annotations.
245 (funcall to-fn from to orig-buf)))))
247 (defun format-decode (format length &optional visit-flag)
248 ;; This function is called by insert-file-contents whenever a file is read.
249 "Decode text from any known FORMAT.
250 FORMAT is a symbol appearing in `format-alist' or a list of such symbols,
251 or nil, in which case this function tries to guess the format of the data by
252 matching against the regular expressions in `format-alist'. After a match is
253 found and the region decoded, the alist is searched again from the beginning
254 for another match.
256 Second arg LENGTH is the number of characters following point to operate on.
257 If optional third arg VISIT-FLAG is true, set `buffer-file-format'
258 to the reverted list of formats used, and call any mode functions defined
259 for those formats.
261 Return the new length of the decoded region.
263 For most purposes, consider using `format-decode-region' instead."
264 (let ((mod (buffer-modified-p))
265 (begin (point))
266 (end (+ (point) length)))
267 (unwind-protect
268 (progn
269 ;; Don't record undo information for the decoding.
271 (if (null format)
272 ;; Figure out which format it is in, remember list in `format'.
273 (let ((try format-alist))
274 (while try
275 (let* ((f (car try))
276 (regexp (nth 2 f))
277 (p (point)))
278 (if (and regexp (looking-at regexp)
279 (< (match-end 0) (+ begin length)))
280 (progn
281 (push (car f) format)
282 ;; Decode it
283 (if (nth 3 f)
284 (setq end (format-decode-run-method (nth 3 f) begin end)))
285 ;; Call visit function if required
286 (if (and visit-flag (nth 6 f)) (funcall (nth 6 f) 1))
287 ;; Safeguard against either of the functions changing pt.
288 (goto-char p)
289 ;; Rewind list to look for another format
290 (setq try format-alist))
291 (setq try (cdr try))))))
292 ;; Deal with given format(s)
293 (or (listp format) (setq format (list format)))
294 (let ((do format) f)
295 (while do
296 (or (setq f (assq (car do) format-alist))
297 (error "Unknown format %s" (car do)))
298 ;; Decode:
299 (if (nth 3 f)
300 (setq end (format-decode-run-method (nth 3 f) begin end)))
301 ;; Call visit function if required
302 (if (and visit-flag (nth 6 f)) (funcall (nth 6 f) 1))
303 (setq do (cdr do))))
304 ;; Encode in the opposite order.
305 (setq format (reverse format)))
306 (if visit-flag
307 (setq buffer-file-format format)))
309 (set-buffer-modified-p mod))
311 ;; Return new length of region
312 (- end begin)))
315 ;;; Interactive functions & entry points
318 (defun format-decode-buffer (&optional format)
319 "Translate the buffer from some FORMAT.
320 If the format is not specified, attempt a regexp-based guess.
321 Set `buffer-file-format' to the format used, and call any
322 format-specific mode functions."
323 (interactive
324 (list (format-read "Translate buffer from format (default guess): ")))
325 (save-excursion
326 (goto-char (point-min))
327 (format-decode format (buffer-size) t)))
329 (defun format-decode-region (from to &optional format)
330 "Decode the region from some format.
331 Arg FORMAT is optional; if omitted the format will be determined by looking
332 for identifying regular expressions at the beginning of the region."
333 (interactive
334 (list (region-beginning) (region-end)
335 (format-read "Translate region from format (default guess): ")))
336 (save-excursion
337 (goto-char from)
338 (format-decode format (- to from) nil)))
340 (defun format-encode-buffer (&optional format)
341 "Translate the buffer into FORMAT.
342 FORMAT defaults to `buffer-file-format'. It is a symbol naming one of the
343 formats defined in `format-alist', or a list of such symbols."
344 (interactive
345 (list (format-read (format "Translate buffer to format (default %s): "
346 buffer-file-format))))
347 (format-encode-region (point-min) (point-max) format))
349 (defun format-encode-region (beg end &optional format)
350 "Translate the region into some FORMAT.
351 FORMAT defaults to `buffer-file-format'. It is a symbol naming
352 one of the formats defined in `format-alist', or a list of such symbols."
353 (interactive
354 (list (region-beginning) (region-end)
355 (format-read (format "Translate region to format (default %s): "
356 buffer-file-format))))
357 (if (null format) (setq format buffer-file-format))
358 (if (symbolp format) (setq format (list format)))
359 (save-excursion
360 (goto-char end)
361 (let ((end (point-marker)))
362 (while format
363 (let* ((info (assq (car format) format-alist))
364 (to-fn (nth 4 info))
365 (modify (nth 5 info)))
366 (if to-fn
367 (if modify
368 (setq end (format-encode-run-method to-fn beg end
369 (current-buffer)))
370 (format-insert-annotations
371 (funcall to-fn beg end (current-buffer)))))
372 (setq format (cdr format)))))))
374 (defun format-write-file (filename format &optional confirm)
375 "Write current buffer into FILENAME, using a format based on FORMAT.
376 Constructs the actual format starting from FORMAT, then appending
377 any elements from the value of `buffer-file-format' with a non-nil
378 `preserve' flag (see the documentation of `format-alist'), if they
379 are not already present in FORMAT. It then updates `buffer-file-format'
380 with this format, making it the default for future saves.
382 If the buffer is already visiting a file, you can specify a
383 directory name as FILENAME, to write a file of the same old name
384 in that directory.
386 If optional third arg CONFIRM is non-nil, asks for confirmation before
387 overwriting an existing file. Interactively, requires confirmation
388 unless you supply a prefix argument."
389 (interactive
390 ;; Same interactive spec as write-file, plus format question.
391 (let* ((file (if buffer-file-name
392 (read-file-name "Write file: "
393 nil nil nil nil)
394 (read-file-name "Write file: "
395 (cdr (assq 'default-directory
396 (buffer-local-variables)))
397 nil nil (buffer-name))))
398 (fmt (format-read (format "Write file `%s' in format: "
399 (file-name-nondirectory file)))))
400 (list file fmt (not current-prefix-arg))))
401 (let ((old-formats buffer-file-format)
402 preserve-formats)
403 (dolist (fmt old-formats)
404 (let ((aelt (assq fmt format-alist)))
405 (if (nth 7 aelt)
406 (push fmt preserve-formats))))
407 (setq buffer-file-format format)
408 (dolist (fmt preserve-formats)
409 (unless (memq fmt buffer-file-format)
410 (setq buffer-file-format (append buffer-file-format (list fmt))))))
411 (write-file filename confirm))
413 (defun format-find-file (filename format)
414 "Find the file FILENAME using data format FORMAT.
415 If FORMAT is nil then do not do any format conversion."
416 (interactive
417 ;; Same interactive spec as write-file, plus format question.
418 (let* ((file (read-file-name "Find file: "))
419 (fmt (format-read (format "Read file `%s' in format: "
420 (file-name-nondirectory file)))))
421 (list file fmt)))
422 (let ((format-alist nil))
423 (find-file filename))
424 (if format
425 (format-decode-buffer format)))
427 (defun format-insert-file (filename format &optional beg end)
428 "Insert the contents of file FILENAME using data format FORMAT.
429 If FORMAT is nil then do not do any format conversion.
430 The optional third and fourth arguments BEG and END specify
431 the part (in bytes) of the file to read.
433 The return value is like the value of `insert-file-contents':
434 a list (ABSOLUTE-FILE-NAME SIZE)."
435 (interactive
436 ;; Same interactive spec as write-file, plus format question.
437 (let* ((file (read-file-name "Find file: "))
438 (fmt (format-read (format "Read file `%s' in format: "
439 (file-name-nondirectory file)))))
440 (list file fmt)))
441 (let (value size old-undo)
442 ;; Record only one undo entry for the insertion. Inhibit point-motion and
443 ;; modification hooks as with `insert-file-contents'.
444 (let ((inhibit-point-motion-hooks t)
445 (inhibit-modification-hooks t))
446 ;; Don't bind `buffer-undo-list' to t here to assert that
447 ;; `insert-file-contents' may record whether the buffer was unmodified
448 ;; before.
449 (let ((format-alist nil))
450 (setq value (insert-file-contents filename nil beg end))
451 (setq size (nth 1 value)))
452 (when (consp buffer-undo-list)
453 (let ((head (car buffer-undo-list)))
454 (when (and (consp head)
455 (equal (car head) (point))
456 (equal (cdr head) (+ (point) size)))
457 ;; Remove first entry from `buffer-undo-list', we shall insert
458 ;; another one below.
459 (setq old-undo (cdr buffer-undo-list)))))
460 (when format
461 (let ((buffer-undo-list t))
462 (setq size (format-decode format size)
463 value (list (car value) size)))
464 (unless (eq buffer-undo-list t)
465 (setq buffer-undo-list
466 (cons (cons (point) (+ (point) size)) old-undo)))))
467 (unless inhibit-modification-hooks
468 (run-hook-with-args 'after-change-functions (point) (+ (point) size) 0))
469 value))
471 (defun format-read (&optional prompt)
472 "Read and return the name of a format.
473 Return value is a list, like `buffer-file-format'; it may be nil.
474 Formats are defined in `format-alist'. Optional arg is the PROMPT to use."
475 (let* ((table (mapcar (lambda (x) (list (symbol-name (car x))))
476 format-alist))
477 (ans (completing-read (or prompt "Format: ") table nil t)))
478 (if (not (equal "" ans)) (list (intern ans)))))
482 ;;; Below are some functions that may be useful in writing encoding and
483 ;;; decoding functions for use in format-alist.
486 (defun format-replace-strings (alist &optional reverse beg end)
487 "Do multiple replacements on the buffer.
488 ALIST is a list of (FROM . TO) pairs, which should be proper arguments to
489 `search-forward' and `replace-match', respectively.
490 Optional second arg REVERSE, if non-nil, means the pairs are (TO . FROM),
491 so that you can use the same list in both directions if it contains only
492 literal strings.
493 Optional args BEG and END specify a region of the buffer on which to operate."
494 (save-excursion
495 (save-restriction
496 (or beg (setq beg (point-min)))
497 (if end (narrow-to-region (point-min) end))
498 (while alist
499 (let ((from (if reverse (cdr (car alist)) (car (car alist))))
500 (to (if reverse (car (car alist)) (cdr (car alist)))))
501 (goto-char beg)
502 (while (search-forward from nil t)
503 (goto-char (match-beginning 0))
504 (insert to)
505 (set-text-properties (- (point) (length to)) (point)
506 (text-properties-at (point)))
507 (delete-region (point) (+ (point) (- (match-end 0)
508 (match-beginning 0)))))
509 (setq alist (cdr alist)))))))
511 ;;; Some list-manipulation functions that we need.
513 (defun format-delq-cons (cons list)
514 "Remove the given CONS from LIST by side effect and return the new LIST.
515 Since CONS could be the first element of LIST, write
516 `\(setq foo \(format-delq-cons element foo))' to be sure of changing
517 the value of `foo'."
518 (if (eq cons list)
519 (cdr list)
520 (let ((p list))
521 (while (not (eq (cdr p) cons))
522 (if (null p) (error "format-delq-cons: not an element"))
523 (setq p (cdr p)))
524 ;; Now (cdr p) is the cons to delete
525 (setcdr p (cdr cons))
526 list)))
528 (defun format-make-relatively-unique (a b)
529 "Delete common elements of lists A and B, return as pair.
530 Compare using `equal'."
531 (let* ((acopy (copy-sequence a))
532 (bcopy (copy-sequence b))
533 (tail acopy))
534 (while tail
535 (let ((dup (member (car tail) bcopy))
536 (next (cdr tail)))
537 (if dup (setq acopy (format-delq-cons tail acopy)
538 bcopy (format-delq-cons dup bcopy)))
539 (setq tail next)))
540 (cons acopy bcopy)))
542 (defun format-proper-list-p (list)
543 "Return t if LIST is a proper list.
544 A proper list is a list ending with a nil cdr, not with an atom "
545 (when (listp list)
546 (while (consp list)
547 (setq list (cdr list)))
548 (null list)))
550 (defun format-reorder (items order)
551 "Arrange ITEMS to follow partial ORDER.
552 Elements of ITEMS equal to elements of ORDER will be rearranged
553 to follow the ORDER. Unmatched items will go last."
554 (if order
555 (let ((item (member (car order) items)))
556 (if item
557 (cons (car item)
558 (format-reorder (format-delq-cons item items)
559 (cdr order)))
560 (format-reorder items (cdr order))))
561 items))
563 (put 'face 'format-list-valued t) ; These text-properties take values
564 (put 'unknown 'format-list-valued t) ; that are lists, the elements of which
565 ; should be considered separately.
566 ; See format-deannotate-region and
567 ; format-annotate-region.
569 ;; This text property has list values, but they are treated atomically.
571 (put 'display 'format-list-atomic-p t)
574 ;;; Decoding
577 (defun format-deannotate-region (from to translations next-fn)
578 "Translate annotations in the region into text properties.
579 This sets text properties between FROM to TO as directed by the
580 TRANSLATIONS and NEXT-FN arguments.
582 NEXT-FN is a function that searches forward from point for an annotation.
583 It should return a list of 4 elements: \(BEGIN END NAME POSITIVE). BEGIN and
584 END are buffer positions bounding the annotation, NAME is the name searched
585 for in TRANSLATIONS, and POSITIVE should be non-nil if this annotation marks
586 the beginning of a region with some property, or nil if it ends the region.
587 NEXT-FN should return nil if there are no annotations after point.
589 The basic format of the TRANSLATIONS argument is described in the
590 documentation for the `format-annotate-region' function. There are some
591 additional things to keep in mind for decoding, though:
593 When an annotation is found, the TRANSLATIONS list is searched for a
594 text-property name and value that corresponds to that annotation. If the
595 text-property has several annotations associated with it, it will be used only
596 if the other annotations are also in effect at that point. The first match
597 found whose annotations are all present is used.
599 The text property thus determined is set to the value over the region between
600 the opening and closing annotations. However, if the text-property name has a
601 non-nil `format-list-valued' property, then the value will be consed onto the
602 surrounding value of the property, rather than replacing that value.
604 There are some special symbols that can be used in the \"property\" slot of
605 the TRANSLATIONS list: PARAMETER and FUNCTION \(spelled in uppercase).
606 Annotations listed under the pseudo-property PARAMETER are considered to be
607 arguments of the immediately surrounding annotation; the text between the
608 opening and closing parameter annotations is deleted from the buffer but saved
609 as a string.
611 The surrounding annotation should be listed under the pseudo-property
612 FUNCTION. Instead of inserting a text-property for this annotation,
613 the function listed in the VALUE slot is called to make whatever
614 changes are appropriate. It can also return a list of the form
615 \(START LOC PROP VALUE) which specifies a property to put on. The
616 function's first two arguments are the START and END locations, and
617 the rest of the arguments are any PARAMETERs found in that region.
619 Any annotations that are found by NEXT-FN but not defined by TRANSLATIONS
620 are saved as values of the `unknown' text-property \(which is list-valued).
621 The TRANSLATIONS list should usually contain an entry of the form
622 \(unknown \(nil format-annotate-value))
623 to write these unknown annotations back into the file."
624 (save-excursion
625 (save-restriction
626 (narrow-to-region (point-min) to)
627 (goto-char from)
628 (let (next open-ans todo unknown-ans)
629 (while (setq next (funcall next-fn))
630 (let* ((loc (nth 0 next))
631 (end (nth 1 next))
632 (name (nth 2 next))
633 (positive (nth 3 next))
634 (found nil))
636 ;; Delete the annotation
637 (delete-region loc end)
638 (cond
639 ;; Positive annotations are stacked, remembering location
640 (positive (push `(,name ((,loc . nil))) open-ans))
641 ;; It is a negative annotation:
642 ;; Close the top annotation & add its text property.
643 ;; If the file's nesting is messed up, the close might not match
644 ;; the top thing on the open-annotations stack.
645 ;; If no matching annotation is open, just ignore the close.
646 ((not (assoc name open-ans))
647 (message "Extra closing annotation (%s) in file" name))
648 ;; If one is open, but not on the top of the stack, close
649 ;; the things in between as well. Set `found' when the real
650 ;; one is closed.
652 (while (not found)
653 (let* ((top (car open-ans)) ; first on stack: should match.
654 (top-name (car top)) ; text property name
655 (top-extents (nth 1 top)) ; property regions
656 (params (cdr (cdr top))) ; parameters
657 (aalist translations)
658 (matched nil))
659 (if (equal name top-name)
660 (setq found t)
661 (message "Improper nesting in file."))
662 ;; Look through property names in TRANSLATIONS
663 (while aalist
664 (let ((prop (car (car aalist)))
665 (alist (cdr (car aalist))))
666 ;; And look through values for each property
667 (while alist
668 (let ((value (car (car alist)))
669 (ans (cdr (car alist))))
670 (if (member top-name ans)
671 ;; This annotation is listed, but still have to
672 ;; check if multiple annotations are satisfied
673 (if (member nil (mapcar (lambda (r)
674 (assoc r open-ans))
675 ans))
676 nil ; multiple ans not satisfied
677 ;; If there are multiple annotations going
678 ;; into one text property, split up the other
679 ;; annotations so they apply individually to
680 ;; the other regions.
681 (setcdr (car top-extents) loc)
682 (let ((to-split ans) this-one extents)
683 (while to-split
684 (setq this-one
685 (assoc (car to-split) open-ans)
686 extents (nth 1 this-one))
687 (if (not (eq this-one top))
688 (setcar (cdr this-one)
689 (format-subtract-regions
690 extents top-extents)))
691 (setq to-split (cdr to-split))))
692 ;; Set loop variables to nil so loop
693 ;; will exit.
694 (setq alist nil aalist nil matched t
695 ;; pop annotation off stack.
696 open-ans (cdr open-ans))
697 (let ((extents top-extents)
698 (start (car (car top-extents)))
699 (loc (cdr (car top-extents))))
700 (while extents
701 (cond
702 ;; Check for pseudo-properties
703 ((eq prop 'PARAMETER)
704 ;; A parameter of the top open ann:
705 ;; delete text and use as arg.
706 (if open-ans
707 ;; (If nothing open, discard).
708 (setq open-ans
709 (cons
710 (append (car open-ans)
711 (list
712 (buffer-substring
713 start loc)))
714 (cdr open-ans))))
715 (delete-region start loc))
716 ((eq prop 'FUNCTION)
717 ;; Not a property, but a function.
718 (let ((rtn
719 (apply value start loc params)))
720 (if rtn (push rtn todo))))
722 ;; Normal property/value pair
723 (setq todo
724 (cons (list start loc prop value)
725 todo))))
726 (setq extents (cdr extents)
727 start (car (car extents))
728 loc (cdr (car extents))))))))
729 (setq alist (cdr alist))))
730 (setq aalist (cdr aalist)))
731 (if (not matched)
732 ;; Didn't find any match for the annotation:
733 ;; Store as value of text-property `unknown'.
734 (let ((extents top-extents)
735 (start (car (car top-extents)))
736 (loc (or (cdr (car top-extents)) loc)))
737 (while extents
738 (setq open-ans (cdr open-ans)
739 todo (cons (list start loc 'unknown top-name)
740 todo)
741 unknown-ans (cons name unknown-ans)
742 extents (cdr extents)
743 start (car (car extents))
744 loc (cdr (car extents))))))))))))
746 ;; Once entire file has been scanned, add the properties.
747 (while todo
748 (let* ((item (car todo))
749 (from (nth 0 item))
750 (to (nth 1 item))
751 (prop (nth 2 item))
752 (val (nth 3 item)))
754 (if (numberp val) ; add to ambient value if numeric
755 (format-property-increment-region from to prop val 0)
756 (put-text-property
757 from to prop
758 (cond ((get prop 'format-list-valued) ; value gets consed onto
759 ; list-valued properties
760 (let ((prev (get-text-property from prop)))
761 (cons val (if (listp prev) prev (list prev)))))
762 (t val))))) ; normally, just set to val.
763 (setq todo (cdr todo)))
765 (if unknown-ans
766 (message "Unknown annotations: %s" unknown-ans))))))
768 (defun format-subtract-regions (minu subtra)
769 "Remove from the regions in MINUEND the regions in SUBTRAHEND.
770 A region is a dotted pair (FROM . TO). Both parameters are lists of
771 regions. Each list must contain nonoverlapping, noncontiguous
772 regions, in descending order. The result is also nonoverlapping,
773 noncontiguous, and in descending order. The first element of MINUEND
774 can have a cdr of nil, indicating that the end of that region is not
775 yet known.
777 \(fn MINUEND SUBTRAHEND)"
778 (let* ((minuend (copy-alist minu))
779 (subtrahend (copy-alist subtra))
780 (m (car minuend))
781 (s (car subtrahend))
782 results)
783 (while (and minuend subtrahend)
784 (cond
785 ;; The minuend starts after the subtrahend ends; keep it.
786 ((> (car m) (cdr s))
787 (push m results)
788 (setq minuend (cdr minuend)
789 m (car minuend)))
790 ;; The minuend extends beyond the end of the subtrahend. Chop it off.
791 ((or (null (cdr m)) (> (cdr m) (cdr s)))
792 (push (cons (1+ (cdr s)) (cdr m)) results)
793 (setcdr m (cdr s)))
794 ;; The subtrahend starts after the minuend ends; throw it away.
795 ((< (cdr m) (car s))
796 (setq subtrahend (cdr subtrahend) s (car subtrahend)))
797 ;; The subtrahend extends beyond the end of the minuend. Chop it off.
798 (t ;(<= (cdr m) (cdr s)))
799 (if (>= (car m) (car s))
800 (setq minuend (cdr minuend) m (car minuend))
801 (setcdr m (1- (car s)))
802 (setq subtrahend (cdr subtrahend) s (car subtrahend))))))
803 (nconc (nreverse results) minuend)))
805 ;; This should probably go somewhere other than format.el. Then again,
806 ;; indent.el has alter-text-property. NOTE: We can also use
807 ;; next-single-property-change instead of text-property-not-all, but then
808 ;; we have to see if we passed TO.
809 (defun format-property-increment-region (from to prop delta default)
810 "In the region from FROM to TO increment property PROP by amount DELTA.
811 DELTA may be negative. If property PROP is nil anywhere
812 in the region, it is treated as though it were DEFAULT."
813 (let ((cur from) val newval next)
814 (while cur
815 (setq val (get-text-property cur prop)
816 newval (+ (or val default) delta)
817 next (text-property-not-all cur to prop val))
818 (put-text-property cur (or next to) prop newval)
819 (setq cur next))))
822 ;;; Encoding
825 (defun format-insert-annotations (list &optional offset)
826 "Apply list of annotations to buffer as `write-region' would.
827 Insert each element of the given LIST of buffer annotations at its
828 appropriate place. Use second arg OFFSET if the annotations' locations are
829 not relative to the beginning of the buffer: annotations will be inserted
830 at their location-OFFSET+1 \(ie, the offset is treated as the position of
831 the first character in the buffer)."
832 (if (not offset)
833 (setq offset 0)
834 (setq offset (1- offset)))
835 (let ((l (reverse list)))
836 (while l
837 (goto-char (- (car (car l)) offset))
838 (insert (cdr (car l)))
839 (setq l (cdr l)))))
841 (defun format-annotate-value (old new)
842 "Return OLD and NEW as a \(CLOSE . OPEN) annotation pair.
843 Useful as a default function for TRANSLATIONS alist when the value of the text
844 property is the name of the annotation that you want to use, as it is for the
845 `unknown' text property."
846 (cons (if old (list old))
847 (if new (list new))))
849 (defun format-annotate-region (from to translations format-fn ignore)
850 "Generate annotations for text properties in the region.
851 Search for changes between FROM and TO, and describe them with a list of
852 annotations as defined by alist TRANSLATIONS and FORMAT-FN. IGNORE lists text
853 properties not to consider; any text properties that are neither ignored nor
854 listed in TRANSLATIONS are warned about.
855 If you actually want to modify the region, give the return value of this
856 function to `format-insert-annotations'.
858 Format of the TRANSLATIONS argument:
860 Each element is a list whose car is a PROPERTY, and the following
861 elements have the form (VALUE ANNOTATIONS...).
862 Whenever the property takes on the value VALUE, the annotations
863 \(as formatted by FORMAT-FN) are inserted into the file.
864 When the property stops having that value, the matching negated annotation
865 will be inserted \(it may actually be closed earlier and reopened, if
866 necessary, to keep proper nesting).
868 If VALUE is a list, then each element of the list is dealt with
869 separately.
871 If a VALUE is numeric, then it is assumed that there is a single annotation
872 and each occurrence of it increments the value of the property by that number.
873 Thus, given the entry \(left-margin \(4 \"indent\")), if the left margin
874 changes from 4 to 12, two <indent> annotations will be generated.
876 If the VALUE is nil, then instead of annotations, a function should be
877 specified. This function is used as a default: it is called for all
878 transitions not explicitly listed in the table. The function is called with
879 two arguments, the OLD and NEW values of the property. It should return
880 a cons cell (CLOSE . OPEN) as `format-annotate-single-property-change' does.
882 The same TRANSLATIONS structure can be used in reverse for reading files."
883 (let ((all-ans nil) ; All annotations - becomes return value
884 (open-ans nil) ; Annotations not yet closed
885 (loc nil) ; Current location
886 (not-found nil)) ; Properties that couldn't be saved
887 (while (or (null loc)
888 (and (setq loc (next-property-change loc nil to))
889 (< loc to)))
890 (or loc (setq loc from))
891 (let* ((ans (format-annotate-location loc (= loc from) ignore translations))
892 (neg-ans (format-reorder (aref ans 0) open-ans))
893 (pos-ans (aref ans 1))
894 (ignored (aref ans 2)))
895 (setq not-found (append ignored not-found)
896 ignore (append ignored ignore))
897 ;; First do the negative (closing) annotations
898 (while neg-ans
899 ;; Check if it's missing. This can happen (eg, a numeric property
900 ;; going negative can generate closing annotations before there are
901 ;; any open). Warn user & ignore.
902 (if (not (member (car neg-ans) open-ans))
903 (message "Can't close %s: not open." (car neg-ans))
904 (while (not (equal (car neg-ans) (car open-ans)))
905 ;; To close anno. N, need to first close ans 1 to N-1,
906 ;; remembering to re-open them later.
907 (push (car open-ans) pos-ans)
908 (setq all-ans
909 (cons (cons loc (funcall format-fn (car open-ans) nil))
910 all-ans))
911 (setq open-ans (cdr open-ans)))
912 ;; Now remove the one we're really interested in from open list.
913 (setq open-ans (cdr open-ans))
914 ;; And put the closing annotation here.
915 (push (cons loc (funcall format-fn (car neg-ans) nil))
916 all-ans))
917 (setq neg-ans (cdr neg-ans)))
918 ;; Now deal with positive (opening) annotations
919 (while pos-ans
920 (push (car pos-ans) open-ans)
921 (push (cons loc (funcall format-fn (car pos-ans) t))
922 all-ans)
923 (setq pos-ans (cdr pos-ans)))))
925 ;; Close any annotations still open
926 (while open-ans
927 (setq all-ans
928 (cons (cons to (funcall format-fn (car open-ans) nil))
929 all-ans))
930 (setq open-ans (cdr open-ans)))
931 (if not-found
932 (message "These text properties could not be saved:\n %s"
933 not-found))
934 (nreverse all-ans)))
936 ;;; Internal functions for format-annotate-region.
938 (defun format-annotate-location (loc all ignore translations)
939 "Return annotation(s) needed at location LOC.
940 This includes any properties that change between LOC - 1 and LOC.
941 If ALL is true, don't look at previous location, but generate annotations for
942 all non-nil properties.
943 Third argument IGNORE is a list of text-properties not to consider.
944 Use the TRANSLATIONS alist (see `format-annotate-region' for doc).
946 Return value is a vector of 3 elements:
947 1. List of annotations to close
948 2. List of annotations to open.
949 3. List of properties that were ignored or couldn't be annotated.
951 The annotations in lists 1 and 2 need not be strings.
952 They can be whatever the FORMAT-FN in `format-annotate-region'
953 can handle. If that is `enriched-make-annotation', they can be
954 either strings, or lists of the form (PARAMETER VALUE)."
955 (let* ((prev-loc (1- loc))
956 (before-plist (if all nil (text-properties-at prev-loc)))
957 (after-plist (text-properties-at loc))
958 p negatives positives prop props not-found)
959 ;; make list of all property names involved
960 (setq p before-plist)
961 (while p
962 (if (not (memq (car p) props))
963 (push (car p) props))
964 (setq p (cdr (cdr p))))
965 (setq p after-plist)
966 (while p
967 (if (not (memq (car p) props))
968 (push (car p) props))
969 (setq p (cdr (cdr p))))
971 (while props
972 (setq prop (pop props))
973 (if (memq prop ignore)
974 nil ; If it's been ignored before, ignore it now.
975 (let ((before (if all nil (car (cdr (memq prop before-plist)))))
976 (after (car (cdr (memq prop after-plist)))))
977 (if (equal before after)
978 nil ; no change; ignore
979 (let ((result (format-annotate-single-property-change
980 prop before after translations)))
981 (if (not result)
982 (push prop not-found)
983 (setq negatives (nconc negatives (car result))
984 positives (nconc positives (cdr result)))))))))
985 (vector negatives positives not-found)))
987 (defun format-annotate-single-property-change (prop old new translations)
988 "Return annotations for property PROP changing from OLD to NEW.
989 These are searched for in the translations alist TRANSLATIONS
990 (see `format-annotate-region' for the format).
991 If NEW does not appear in the list, but there is a default function,
992 then call that function.
993 Return a cons of the form (CLOSE . OPEN)
994 where CLOSE is a list of annotations to close
995 and OPEN is a list of annotations to open.
997 The annotations in CLOSE and OPEN need not be strings.
998 They can be whatever the FORMAT-FN in `format-annotate-region'
999 can handle. If that is `enriched-make-annotation', they can be
1000 either strings, or lists of the form (PARAMETER VALUE)."
1002 (let ((prop-alist (cdr (assoc prop translations))))
1003 (if (not prop-alist)
1005 ;; If either old or new is a list, have to treat both that way.
1006 (if (and (or (listp old) (listp new))
1007 (not (get prop 'format-list-atomic-p)))
1008 (if (or (not (format-proper-list-p old))
1009 (not (format-proper-list-p new)))
1010 (format-annotate-atomic-property-change prop-alist old new)
1011 (let* ((old (if (listp old) old (list old)))
1012 (new (if (listp new) new (list new)))
1013 close open)
1014 (while old
1015 (setq close
1016 (append (car (format-annotate-atomic-property-change
1017 prop-alist (car old) nil))
1018 close)
1019 old (cdr old)))
1020 (while new
1021 (setq open
1022 (append (cdr (format-annotate-atomic-property-change
1023 prop-alist nil (car new)))
1024 open)
1025 new (cdr new)))
1026 (format-make-relatively-unique close open)))
1027 (format-annotate-atomic-property-change prop-alist old new)))))
1029 (defun format-annotate-atomic-property-change (prop-alist old new)
1030 "Internal function to annotate a single property change.
1031 PROP-ALIST is the relevant element of a TRANSLATIONS list.
1032 OLD and NEW are the values."
1033 (let (num-ann)
1034 ;; If old and new values are numbers,
1035 ;; look for a number in PROP-ALIST.
1036 (if (and (or (null old) (numberp old))
1037 (or (null new) (numberp new)))
1038 (progn
1039 (setq num-ann prop-alist)
1040 (while (and num-ann (not (numberp (car (car num-ann)))))
1041 (setq num-ann (cdr num-ann)))))
1042 (if num-ann
1043 ;; Numerical annotation - use difference
1044 (progn
1045 ;; If property is numeric, nil means 0
1046 (cond ((and (numberp old) (null new))
1047 (setq new 0))
1048 ((and (numberp new) (null old))
1049 (setq old 0)))
1051 (let* ((entry (car num-ann))
1052 (increment (car entry))
1053 (n (ceiling (/ (float (- new old)) (float increment))))
1054 (anno (car (cdr entry))))
1055 (if (> n 0)
1056 (cons nil (make-list n anno))
1057 (cons (make-list (- n) anno) nil))))
1059 ;; Standard annotation
1060 (let ((close (and old (cdr (assoc old prop-alist))))
1061 (open (and new (cdr (assoc new prop-alist)))))
1062 (if (or close open)
1063 (format-make-relatively-unique close open)
1064 ;; Call "Default" function, if any
1065 (let ((default (assq nil prop-alist)))
1066 (if default
1067 (funcall (car (cdr default)) old new))))))))
1069 (provide 'format)
1071 ;;; format.el ends here