lisp/format.el

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