code.delx.au - gnu-emacs/blob - lisp/format.el

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