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

   1 ;;; enriched.el -- read and save files in text/enriched format
   2 ;; Copyright (c) 1994 Free Software Foundation
   3
   4 ;; Author: Boris Goldowsky <boris@cs.rochester.edu>
   5 ;; Keywords: wp, faces
   6
   7 ;; This file is part of GNU Emacs.
   8
   9 ;; GNU Emacs is free software; you can redistribute it and/or modify
  10 ;; it under the terms of the GNU General Public License as published by
  11 ;; the Free Software Foundation; either version 2, or (at your option)
  12 ;; any later version.
  13 ;;
  14 ;; GNU Emacs is distributed in the hope that it will be useful,
  15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17 ;; GNU General Public License for more details.
  18 ;;
  19 ;; You should have received a copy of the GNU General Public License
  20 ;; along with GNU Emacs; see the file COPYING.  If not, write to
  21 ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  22
  23 ;;; Commentary:
  24 ;;
  25 ;; This file implements reading, editing, and saving files with
  26 ;; text-properties such as faces, levels of indentation, and true line breaks
  27 ;; distinguished from newlines just used to fit text into the window.
  28 ;;
  29 ;; The file format used is the MIME text/enriched format, which is a
  30 ;; standard format defined in internet RFC 1563.  All standard annotations are
  31 ;; supported except for <smaller> and <bigger>, which are currently not
  32 ;; possible to display.
  33 ;;
  34 ;; A separate file, enriched.doc, contains further documentation and other
  35 ;; important information about this code.  It also serves as an example file
  36 ;; in text/enriched format.  It should be in the etc directory of your emacs
  37 ;; distribution.
  38
  39 (provide 'enriched)
  40 (if window-system (require 'facemenu))
  41
  42 ;;;
  43 ;;; Variables controlling the display
  44 ;;;
  45
  46 (defvar enriched-verbose t
  47   "*If non-nil, give status messages when reading and writing files.")
  48
  49 (defvar enriched-default-right-margin 10
  50   "*Default amount of space to leave on the right edge of the screen.
  51 This can be increased inside text by changing the 'right-margin text property.
  52 Measured in character widths.  If the screen is narrower than this, it is
  53 assumed to be 0.")
  54
  55 (defvar enriched-fill-after-visiting t
  56   "If t, fills paragraphs when reading in enriched documents.
  57 If nil, only fills when you explicitly request it.  If the value is 'ask, then
  58 it will query you whether to fill.
  59 Filling is never done if the current text-width is the same as the value
  60 stored in the file.")
  61
  62 (defvar enriched-auto-save-interval 1000
  63   "*`Auto-save-interval' to use for `enriched-mode'.
  64 Auto-saving enriched files is slow, so you may wish to have them happen less
  65 often.  You can set this to nil to only do auto-saves when you are not
  66 actively working.")
  67
  68 ;;Unimplemented:
  69 ;(defvar enriched-aggressive-auto-fill t
  70 ;  "*If t, try to keep things properly filled and justified always.
  71 ;Set this to nil if you have a slow terminal or prefer to justify on request.
  72 ;The difference between aggressive and non-aggressive is subtle right now, but
  73 ;may become stronger in the future.")
  74
  75 ;; Unimplemented:
  76 ; (defvar enriched-keep-ignored-items nil
  77 ;   "*If t, keep track of codes that are not understood.
  78 ; Otherwise they are deleted on reading the file, and not written out.")
  79
  80 ;;Unimplemented:
  81 ;(defvar enriched-electric-indentation t
  82 ;  "*If t, newlines and following indentation stick together.
  83 ;Deleting a newline or any part of the indenation will delete the whole
  84 ;stretch.")
  85
  86 ;;;
  87 ;;; Set up faces & display table
  88 ;;;
  89
  90 ;; A slight cheat - all emacs's faces are fixed-width.
  91 ;; The idea is just to pick one that looks different from the default.
  92 (if (internal-find-face 'fixed)
  93     nil
  94   (make-face 'fixed)
  95   (if window-system
  96       (set-face-font 'fixed
  97                      (car (or (x-list-fonts "*fixed-medium*"
  98                                             'default (selected-frame))
  99                               (x-list-fonts "*fixed*"
 100                                             'default (selected-frame)))))))
 101
 102 (if (internal-find-face 'excerpt)
 103     nil
 104   (make-face 'excerpt)
 105   (if window-system
 106       (make-face-italic 'excerpt)))
 107
 108 ;;; The following two faces should not appear on menu.
 109 (if (boundp 'facemenu-unlisted-faces)
 110     (setq facemenu-unlisted-faces
 111           (append '(enriched-code-face enriched-indentation-face)
 112                   facemenu-unlisted-faces)))
 113
 114 (if (internal-find-face 'enriched-code-face)
 115     nil
 116   (make-face 'enriched-code-face)
 117   (if window-system
 118       (set-face-background 'enriched-code-face
 119                            (if (x-display-color-p)
 120                                "LightSteelBlue"
 121                              "gray35"))))
 122
 123 (if (internal-find-face 'enriched-indentation-face)
 124     nil
 125   (make-face 'enriched-indentation-face)
 126   (if window-system
 127       (set-face-background 'enriched-indentation-face
 128                            (if (x-display-color-p)
 129                                "DarkSlateBlue"
 130                              "gray25"))))
 131
 132 (defvar enriched-display-table (make-display-table))
 133 (aset enriched-display-table ?\f (make-vector (1- (frame-width)) ?-))
 134
 135 ; (defvar enriched-show-codes nil "See the function of the same name")
 136
 137 (defvar enriched-par-props '(left-margin right-margin justification
 138                                          front-sticky)
 139   "Text-properties that usually apply to whole paragraphs.
 140 These are set front-sticky everywhere except at hard newlines.")
 141
 142 ;;;
 143 ;;; Variables controlling the file format
 144 ;;;   (bidirectional)
 145
 146 (defvar enriched-initial-annotation
 147   (lambda ()
 148     (format "<param>-*-enriched-*-width:%d
 149 </param>" (enriched-text-width)))
 150   "What to insert at the start of a text/enriched file.
 151 If this is a string, it is inserted.  If it is a list, it should be a lambda
 152 expression, which is evaluated to get the string to insert.")
 153
 154 (defvar enriched-annotation-format "<%s%s>"
 155   "General format of enriched-text annotations.")
 156
 157 (defvar enriched-annotation-regexp "<\\(/\\)?\\([-A-za-z0-9]+\\)>"
 158   "Regular expression matching enriched-text annotations.")
 159
 160 (defvar enriched-downcase-annotations t
 161   "Set to t if case of annotations is irrelevant.
 162 In this case all annotations listed in enriched-annotation-list should be
 163 lowercase, and annotations read from files will be downcased before being
 164 compared to that list.")
 165
 166 (defvar enriched-list-valued-properties '(face unknown)
 167   "List of properties whose values can be lists.")
 168
 169 (defvar enriched-annotation-alist
 170   '((face          (bold-italic "bold" "italic")
 171                    (bold        "bold")
 172                    (italic      "italic")
 173                    (underline   "underline")
 174                    (fixed       "fixed")
 175                    (excerpt     "excerpt")
 176                    (default     )
 177                    (nil         enriched-encode-other-face))
 178     (hard          (nil         enriched-encode-hard-newline))
 179     (left-margin   (4           "indent"))
 180     (right-margin  (4           "indentright"))
 181     (justification (none        "nofill")
 182                    (right       "flushright")
 183                    (left        "flushleft")
 184                    (full        "flushboth")
 185                    (center      "center"))
 186     (PARAMETER     (t           "param")) ; Argument of preceding annotation
 187     ;; The following are not part of the standard:
 188     (FUNCTION      (enriched-decode-foreground "x-color")
 189                    (enriched-decode-background "x-bg-color"))
 190     (read-only     (t           "x-read-only"))
 191     (unknown       (nil         enriched-encode-unknown)) ;anything else found
 192 ;   (font-size     (2           "bigger")       ; unimplemented
 193 ;                  (-2          "smaller"))
 194 )
 195   "List of definitions of text/enriched annotations.
 196 Each element is a list whose car is a PROPERTY, and the following
 197 elements are VALUES of that property followed by zero or more ANNOTATIONS.
 198 Whenever the property takes on that value, each of the annotations
 199 will be inserted into the file.  Only the name of the annotation
 200 should be specified, it will be formatted by `enriched-make-annotation'.
 201 At the point that the property stops having that value, the matching
 202 negated annotation will be inserted (it may actually be closed earlier and
 203 reopened, if necessary, to keep proper nesting).
 204
 205 Conversely, when annotations are read, they are searched for in this list, and
 206 the relevant text property is added to the buffer.  The first match found whose
 207 conditions are satisfied is used.  If enriched-downcase-annotations is true,
 208 then annotations in this list should be listed in lowercase, and annotations
 209 read from the file will be downcased.
 210
 211 If the VALUE is numeric, then it is assumed that there is a single annotation
 212 and each occurrence of it increments the value of the property by that number.
 213 Thus, given the entry \(left-margin \(4 \"indent\")), `enriched-encode-region'
 214 will insert two <indent> annotations if the left margin changes from 4 to 12.
 215
 216 If the VALUE is nil, then instead of annotations, a function should be
 217 specified.  This function is used as a default: it is called for all
 218 transitions not explicitly listed in the table.  The function is called with
 219 two arguments, the OLD and NEW values of the property.  It should return a
 220 list of annotations like `enriched-loc-annotations' does, or may directly
 221 modify the buffer.  Note that this only works for encoding; there must be some
 222 other way of decoding the annotations thus produced.
 223
 224 [For future expansion:] If the VALUE is a list, then the property's value will
 225 be appended to the surrounding value of the property.
 226
 227 For decoding, there are some special symbols that can be used in the
 228 \"property\" slot.  Annotations listed under the pseudo-property PARAMETER are
 229 considered to be arguments of the immediately surrounding annotation; the text
 230 between the opening and closing parameter annotations is deleted from the
 231 buffer but saved as a string.  The surrounding annotation should be listed
 232 under the pseudo-property FUNCTION.  Instead of inserting a text-property for
 233 this annotation, enriched-decode-buffer will call the function listed in the
 234 VALUE slot, with the first two arguments being the start and end locations and
 235 the rest of the arguments being any PARAMETERs found in that region.")
 236
 237 ;;; This is not needed for text/enriched format, since all annotations are in
 238 ;;; a standard form:
 239 ;(defvar enriched-special-annotations-alist nil
 240 ;  "List of annotations not formatted in the usual way.
 241 ;Each element has the form (ANNOTATION BEGIN END), where
 242 ;ANNOTATION is the annotation's name, which is a symbol (normal
 243 ;annotations are named with strings, special ones with symbols),
 244 ;BEGIN is the literal string to insert as the opening annotation, and
 245 ;END is the literal string to insert as the close.
 246 ;This is used only for encoding.  Typically, each will have an entry in
 247 ;enriched-decode-special-alist to deal with its decoding.")
 248
 249 ;;; Encoding variables
 250
 251 (defvar enriched-encode-interesting-regexp "<"
 252   "Regexp matching the start of something that may require encoding.
 253 All text-property changes are also considered \"interesting\".")
 254
 255 (defvar enriched-encode-special-alist
 256   '(("<" . (lambda () (insert-and-inherit "<"))))
 257   "List of special operations for writing enriched files.
 258 Each element has the form \(STRING . FUNCTION).
 259 Whenever one of the strings \(including its properties, if any)
 260 is found, the corresponding function is called.
 261 Match data is available to the function.
 262 See `enriched-decode-special-alist' for instructions on decoding special
 263 items.")
 264
 265 (defvar enriched-ignored-ok
 266   '(front-sticky rear-nonsticky)
 267   "Properties that are not written into enriched files.
 268 Generally this list should only contain properties that just for enriched's
 269 internal purposes; other properties that cannot be recorded will generate
 270 a warning message to the user since information will be lost.")
 271
 272 ;;; Decoding variables
 273
 274 (defvar enriched-decode-interesting-regexp "[<\n]"
 275   "Regexp matching the start of something that may require decoding.")
 276
 277 (defvar enriched-decode-special-alist
 278   '(("<<" . (lambda () (delete-char 1) (forward-char 1)))
 279     ("\n\n" . enriched-decode-hard-newline))
 280   "List of special operations for reading enriched files.
 281 Each element has the form \(STRING . FUNCTION).
 282 Whenever one of the strings is found, the corresponding function is called,
 283 with point at the beginning of the match and the match data is available to
 284 the function.  Should leave point where next search should start.")
 285
 286 ;;; Internal variables
 287
 288 (defvar enriched-mode nil
 289   "True if `enriched-mode' \(which see) is enabled.")
 290 (make-variable-buffer-local 'enriched-mode)
 291
 292 (if (not (assq 'enriched-mode minor-mode-alist))
 293     (setq minor-mode-alist
 294           (cons '(enriched-mode " Enriched")
 295                 minor-mode-alist)))
 296
 297 (defvar enriched-mode-hooks nil
 298   "Functions to run when entering `enriched-mode'.
 299 If you set variables in this hook, you should arrange for them to be restored
 300 to their old values if enriched-mode is left.  One way to do this is to add
 301 them and their old values to `enriched-old-bindings'.")
 302
 303 (defvar enriched-old-bindings nil
 304   "Store old variable values that we change when entering mode.
 305 The value is a list of \(VAR VALUE VAR VALUE...).")
 306 (make-variable-buffer-local 'enriched-old-bindings)
 307
 308 (defvar enriched-translated nil
 309   "True if buffer has already been decoded.")
 310 (make-variable-buffer-local 'enriched-translated)
 311
 312 (defvar enriched-text-width nil)
 313 (make-variable-buffer-local 'enriched-text-width)
 314
 315 (defvar enriched-ignored-list nil)
 316
 317 (defvar enriched-open-ans nil)
 318
 319 ;;;
 320 ;;; Functions defining the format of annotations
 321 ;;;
 322
 323 (defun enriched-make-annotation (name positive)
 324   "Format an annotation called NAME.
 325 If POSITIVE is non-nil, this is the opening annotation, if nil, this is the
 326 matching close."
 327 ;; Could be used for annotations not following standard form:
 328 ;  (if (symbolp name)
 329 ;      (if positive
 330 ;         (elt (assq name enriched-special-annotations-alist) 1)
 331 ;       (elt (assq name enriched-special-annotations-alist) 2))  )
 332   (if (stringp name)
 333       (format enriched-annotation-format (if positive "" "/") name)
 334     ;; has parameters.
 335     (if positive
 336         (let ((item (car name))
 337               (params (cdr name)))
 338           (concat (format enriched-annotation-format "" item)
 339                   (mapconcat (lambda (i) (concat "<param>" i "</param>"))
 340                              params "")))
 341       (format enriched-annotation-format "/" (car name)))))
 342
 343 (defun enriched-annotation-name (a)
 344   "Find the name of an ANNOTATION."
 345   (save-match-data
 346     (if (string-match enriched-annotation-regexp a)
 347         (substring a (match-beginning 2) (match-end 2)))))
 348
 349 (defun enriched-annotation-positive-p (a)
 350   "Returns t if ANNOTATION is positive (open),
 351 or nil if it is a closing (negative) annotation."
 352   (save-match-data
 353     (and (string-match enriched-annotation-regexp a)
 354          (not (match-beginning 1)))))
 355
 356 (defun enriched-encode-unknown (old new)
 357   "Deals with re-inserting unknown annotations."
 358   (cons (if old (list old))
 359         (if new (list new))))
 360
 361 (defun enriched-encode-hard-newline (old new)
 362   "Deal with encoding `hard-newline' property change."
 363   ;; This makes a sequence of N hard newlines into N+1 duplicates of the first
 364   ;; one- so all property changes are put off until after all the newlines.
 365   (if (and new (current-justification))  ; no special processing inside NoFill
 366       (let* ((length (skip-chars-forward "\n"))
 367              (s (make-string length ?\n)))
 368         (backward-delete-char (1- length))
 369         (add-text-properties 0 length (text-properties-at (1- (point))) s)
 370         (insert s)
 371         (backward-char (+ length 1)))))
 372
 373 (defun enriched-decode-hard-newline ()
 374   "Deal with newlines while decoding file."
 375   (let ((nofill (equal "nofill" ; find out if we're in NoFill region
 376                        (enriched-which-assoc
 377                         '("nofill" "flushleft" "flushright" "center"
 378                           "flushboth")
 379                         enriched-open-ans)))
 380         (n (skip-chars-forward "\n")))
 381     (delete-char (- n))
 382     (newline (if nofill n (1- n)))))
 383
 384 (defun enriched-encode-other-face (old new)
 385   "Generate annotations for random face change.
 386 One annotation each for foreground color, background color, italic, etc."
 387   (cons (and old (enriched-face-ans old))
 388         (and new (enriched-face-ans new))))
 389
 390 (defun enriched-face-ans (face)
 391   "Return annotations specifying FACE."
 392   (cond ((string-match "^fg:" (symbol-name face))
 393          (list (list "x-color" (substring (symbol-name face) 3))))
 394         ((string-match "^bg:" (symbol-name face))
 395          (list (list "x-bg-color" (substring (symbol-name face) 3))))
 396         ((let* ((fg (face-foreground face))
 397                 (bg (face-background face))
 398                 (props (face-font face t))
 399                 (ans (cdr (enriched-annotate-change 'face nil props))))
 400            (if fg (enriched-push (list "x-color" fg) ans))
 401            (if bg (enriched-push (list "x-bg-color" bg) ans))
 402            ans))))
 403
 404 (defun enriched-decode-foreground (from to color)
 405   (let ((face (intern (concat "fg:" color))))
 406     (cond ((internal-find-face face))
 407           ((and window-system (facemenu-get-face face)))
 408           (window-system
 409            (enriched-warn "Color \"%s\" not defined:
 410     Try M-x set-face-foreground RET %s RET some-other-color" color face))
 411           ((make-face face)
 412            (enriched-warn "Color \"%s\" can't be displayed." color)))
 413     (list from to 'face face)))
 414
 415 (defun enriched-decode-background (from to color)
 416   (let ((face (intern (concat "bg:" color))))
 417     (cond ((internal-find-face face))
 418           ((and window-system (facemenu-get-face face)))
 419           (window-system
 420            (enriched-warn "Color \"%s\" not defined:
 421     Try M-x set-face-background RET %s RET some-other-color" color face))
 422           ((make-face face)
 423            (enriched-warn "Color \"%s\" can't be displayed." color)))
 424     (list from to 'face face)))
 425
 426 ;;;
 427 ;;; NOTE: Everything below this point is intended to be independent of the file
 428 ;;; format, which is defined by the variables and functions above.
 429 ;;;
 430
 431 ;;;
 432 ;;; Define the mode
 433 ;;;
 434
 435 ;;;###autoload
 436 (defun enriched-mode (&optional arg notrans)
 437   "Minor mode for editing text/enriched files.
 438 These are files with embedded formatting information in the MIME standard
 439 text/enriched format.
 440
 441 Turning the mode on or off interactively will query whether the buffer
 442 should be translated into or out of text/enriched format immediately.
 443 Noninteractively translation is done without query unless the optional
 444 second argument NO-TRANS is non-nil.
 445 Turning mode on runs `enriched-mode-hooks'.
 446
 447 More information about enriched-mode is available in the file
 448 etc/enriched.doc  in the Emacs distribution directory.
 449
 450 Commands:
 451
 452 \\<enriched-mode-map>\\{enriched-mode-map}"
 453   (interactive "P")
 454   (let ((mod (buffer-modified-p)))
 455     (cond ((or (<= (prefix-numeric-value arg) 0)
 456                (and enriched-mode (null arg)))
 457            ;; Turn mode off
 458            (setq enriched-mode nil)
 459            (if (if (interactive-p)
 460                    (y-or-n-p "Translate buffer into text/enriched format?")
 461                  (not notrans))
 462                (progn (enriched-encode-region)
 463                       (mapcar (lambda (x)
 464                                 (remove-text-properties
 465                                  (point-min) (point-max)
 466                                  (list (if (consp x) (car x) x) nil)))
 467                               (append enriched-ignored-ok
 468                                       enriched-annotation-alist))
 469                       (setq enriched-translated nil)))
 470            ;; restore old variable values
 471            (while enriched-old-bindings
 472              (funcall 'set (car enriched-old-bindings)
 473                       (car (cdr enriched-old-bindings)))
 474              (setq enriched-old-bindings (cdr (cdr enriched-old-bindings))))
 475            (remove-hook 'write-region-annotate-functions
 476                         'enriched-annotate-function t)
 477            (remove-hook 'after-change-functions 'enriched-nogrow-hook t))
 478           (enriched-mode nil)           ; Mode already on; do nothing.
 479           (t                            ; Turn mode on
 480            ;; save old variable values before we change them.
 481            (setq enriched-mode t
 482                  enriched-old-bindings
 483                  (list 'auto-save-interval   auto-save-interval
 484                        'buffer-display-table buffer-display-table
 485                        'indent-line-function indent-line-function
 486                        'use-hard-newlines    use-hard-newlines))
 487            (make-local-variable 'auto-save-interval)
 488            (make-local-variable 'indent-line-function)
 489            (make-local-variable 'use-hard-newlines)
 490            (setq auto-save-interval enriched-auto-save-interval
 491                  indent-line-function 'indent-to-left-margin
 492                  buffer-display-table enriched-display-table
 493                  use-hard-newlines t) ; Weird in Center&FlushRight
 494            ;; Add hooks
 495            (add-hook 'write-region-annotate-functions
 496                      'enriched-annotate-function)
 497 ;          (add-hook 'after-change-functions 'enriched-nogrow-hook)
 498
 499            (put-text-property (point-min) (point-max)
 500                               'front-sticky enriched-par-props)
 501
 502            (if (and (not enriched-translated)
 503                     (if (interactive-p)
 504                         (y-or-n-p "Does buffer need to be translated now? ")
 505                       (not notrans)))
 506                (progn (enriched-decode-region)
 507                       (setq enriched-translated t)))
 508            (run-hooks 'enriched-mode-hooks)))
 509     (set-buffer-modified-p mod)
 510     (force-mode-line-update)))
 511
 512 ;;;
 513 ;;; Keybindings
 514 ;;;
 515
 516 (defvar enriched-mode-map nil
 517   "Keymap for `enriched-mode'.")
 518
 519 (if (null enriched-mode-map)
 520     (fset 'enriched-mode-map (setq enriched-mode-map (make-sparse-keymap))))
 521
 522 (if (not (assq 'enriched-mode minor-mode-map-alist))
 523     (setq minor-mode-map-alist
 524           (cons (cons 'enriched-mode enriched-mode-map)
 525                 minor-mode-map-alist)))
 526
 527 (define-key enriched-mode-map "\C-a" 'move-to-left-margin)
 528 (define-key enriched-mode-map "\C-j" 'newline)
 529 (define-key enriched-mode-map "\M-j" 'enriched-justification-menu-map)
 530 (define-key enriched-mode-map "\M-S" 'set-justification-center)
 531 (define-key enriched-mode-map "\C-x\t" 'increment-left-margin)
 532 (define-key enriched-mode-map "\C-c\C-l" 'set-left-margin)
 533 (define-key enriched-mode-map "\C-c\C-r" 'set-right-margin)
 534 ;;(define-key enriched-mode-map "\C-c\C-s" 'enriched-show-codes)
 535
 536 ;;;
 537 ;;; General list/stack manipulation
 538 ;;;
 539
 540 (defmacro enriched-push (item stack)
 541   "Push ITEM onto STACK.
 542 STACK should be a symbol whose value is a list."
 543   (` (setq (, stack) (cons (, item) (, stack)))))
 544
 545 (defmacro enriched-pop (stack)
 546   "Remove and return first item on STACK."
 547   (` (let ((pop-item (car (, stack))))
 548        (setq (, stack) (cdr (, stack)))
 549        pop-item)))
 550
 551 (defun enriched-delq1 (cons list)
 552   "Remove the given CONS from LIST by side effect.
 553 Since CONS could be the first element of LIST, write
 554 `(setq foo (enriched-delq1 element foo))' to be sure of changing the value
 555 of `foo'."
 556   (if (eq cons list)
 557       (cdr list)
 558     (let ((p list))
 559       (while (not (eq (cdr p) cons))
 560         (if (null p) (error "enriched-delq1: Attempt to delete a non-element"))
 561         (setq p (cdr p)))
 562       ;; Now (cdr p) is the cons to delete
 563       (setcdr p (cdr cons))
 564       list)))
 565
 566 (defun enriched-make-list-uniq (list)
 567   "Destructively remove duplicates from LIST.
 568 Compares using `eq'."
 569   (let ((l list))
 570     (while l
 571       (setq l (setcdr l (delq (car l) (cdr l)))))
 572     list))
 573
 574 (defun enriched-make-relatively-unique (a b)
 575   "Delete common elements of lists A and B, return as pair.
 576 Compares using `equal'."
 577   (let* ((acopy (copy-sequence a))
 578          (bcopy (copy-sequence b))
 579          (tail acopy))
 580     (while tail
 581       (let ((dup (member (car tail) bcopy))
 582             (next (cdr tail)))
 583         (if dup (setq acopy (enriched-delq1 tail acopy)
 584                       bcopy (enriched-delq1 dup  bcopy)))
 585         (setq tail next)))
 586     (cons acopy bcopy)))
 587
 588 (defun enriched-common-tail (a b)
 589   "Given two lists that have a common tail, return it.
 590 Compares with `equal', and returns the part of A that is equal to the
 591 equivalent part of B.  If even the last items of the two are not equal,
 592 returns nil."
 593   (let ((la (length a))
 594         (lb (length b)))
 595     ;; Make sure they are the same length
 596     (while (> la lb)
 597       (setq a (cdr a)
 598             la (1- la)))
 599     (while (> lb la)
 600       (setq b (cdr b)
 601             lb (1- lb))))
 602   (while (not (equal a b))
 603     (setq a (cdr a)
 604           b (cdr b)))
 605   a)
 606
 607 (defun enriched-which-assoc (items list)
 608   "Return which one of ITEMS occurs first as a car of an element of LIST."
 609   (let (res)
 610     (while list
 611       (if (setq res (member (car (car list)) items))
 612           (setq res (car res)
 613                 list nil)
 614         (setq list (cdr list))))
 615     res))
 616
 617 (defun enriched-reorder (items order)
 618   "Arrange ITEMS to following partial ORDER.
 619 Elements of ITEMS equal to elements of ORDER will be rearranged to follow the
 620 ORDER.  Unmatched items will go last."
 621   (if order
 622       (let ((item (member (car order) items)))
 623         (if item
 624             (cons (car item)
 625                   (enriched-reorder (enriched-delq1 item items)
 626                               (cdr order)))
 627           (enriched-reorder items (cdr order))))
 628     items))
 629
 630 ;;;
 631 ;;; Utility functions
 632 ;;;
 633
 634 (defun enriched-get-face-attribute (attr face &optional frame)
 635   "Get an attribute of a face or list of faces.
 636 ATTRIBUTE should be one of the functions `face-font' `face-foreground',
 637 `face-background', or `face-underline-p'.  FACE can be a face or a list of
 638 faces.  If optional argument FRAME is given, report on the face in that frame.
 639 If FRAME is t, report on the defaults for the face in new frames.  If FRAME is
 640 omitted or nil, use the selected frame."
 641   (cond ((null face) nil)
 642         ((or (symbolp face) (internal-facep face)) (funcall attr face frame))
 643         ((funcall attr (car face) frame))
 644         ((enriched-get-face-attribute attr (cdr face) frame))))
 645
 646 (defun enriched-overlays-overlapping (begin end &optional test)
 647   "Return a list of the overlays which overlap the specified region.
 648 If optional arg TEST is given, it is called with each overlay as its
 649 argument, and only those for which it is true are returned."
 650   (overlay-recenter begin)
 651   (let ((res nil)
 652         (overlays (cdr (overlay-lists)))) ; includes all ending after BEGIN
 653     (while overlays
 654       (if (and (< (overlay-start (car overlays)) end)
 655                (or (not test)
 656                    (funcall test (car overlays))))
 657           (enriched-push (car overlays) res))
 658       (setq overlays (cdr overlays)))
 659     res))
 660
 661 ;(defun enriched-show-codes (&rest which)
 662 ;  "Enable or disable highlighting of special regions.
 663 ;With argument null or `none', turns off highlighting.
 664 ;If argument is `newline', turns on display of hard newlines.
 665 ;If argument is `indent', highlights the automatic indentation at the beginning
 666 ;of each line.
 667 ;If argument is `margin', highlights all regions with non-standard margins."
 668 ;  (interactive
 669 ;   (list (intern (completing-read "Show which codes: "
 670 ;                                 '(("none") ("newline") ("indent") ("margin"))
 671 ;                                 nil t))))
 672 ;  (if (null which)
 673 ;      (setq enriched-show-codes nil)
 674 ;    (setq enriched-show-codes which))
 675 ;  ;; First delete current overlays
 676 ;  (let* ((ol (overlay-lists))
 677 ;        (overlays (append (car ol) (cdr ol))))
 678 ;    (while overlays
 679 ;      (if (eq (overlay-get (car overlays) 'face) 'enriched-code-face)
 680 ;         (delete-overlay (car overlays)))
 681 ;      (setq overlays (cdr overlays))))
 682 ;  ;; Now add new ones for each thing displayed.
 683 ;  (if (null which)
 684 ;      (message "Code display off."))
 685 ;  (while which
 686 ;    (cond ((eq (car which) 'margin)
 687 ;          (enriched-show-margin-codes))
 688 ;         ((eq (car which) 'indent)
 689 ;          (enriched-map-property-regions 'enriched-indentation
 690 ;            (lambda (v b e)
 691 ;              (if v (enriched-show-region-as-code b e 'indent)))))
 692 ;         ((eq (car which) 'newline)
 693 ;          (save-excursion
 694 ;            (goto-char (point-min))
 695 ;            (while (enriched-search-forward-with-props
 696 ;                    enriched-hard-newline nil t)
 697 ;              (enriched-show-region-as-code (match-beginning 0) (match-end 0)
 698 ;                                      'newline)))))
 699 ;    (setq which (cdr which))))
 700
 701 ;(defun enriched-show-margin-codes (&optional from to)
 702 ;  "Highlight regions with nonstandard left-margins.
 703 ;See `enriched-show-codes'."
 704 ;  (enriched-map-property-regions 'left-margin
 705 ;    (lambda (v b e)
 706 ;      (if (and v (> v 0))
 707 ;         (enriched-show-region-as-code b e 'margin)))
 708 ;    from to)
 709 ;  (enriched-map-property-regions 'right-margin
 710 ;    (lambda (v b e)
 711 ;      (if (and v (> v 0))
 712 ;         (enriched-show-region-as-code b e 'margin)))
 713 ;    from to))
 714
 715 ;(defun enriched-show-region-as-code (from to type)
 716 ;  "Display region between FROM and TO as a code if TYPE is displayed.
 717 ;Displays it only if TYPE is an element of `enriched-show-codes' or is t."
 718 ;  (if (or (eq t type) (memq type enriched-show-codes))
 719 ;      (let* ((old (enriched-overlays-overlapping
 720 ;                  from to (lambda (o)
 721 ;                            (eq 'enriched-code-face
 722 ;                                (overlay-get o 'face)))))
 723 ;            (new (if old (move-overlay (car old) from to)
 724 ;                   (make-overlay from to))))
 725 ;       (overlay-put new 'face 'enriched-code-face)
 726 ;       (overlay-put new 'front-nogrow t)
 727 ;       (if (eq type 'margin)
 728 ;           (overlay-put new 'rear-grow t))
 729 ;       (while (setq old (cdr old))
 730 ;         (delete-overlay (car old))))))
 731
 732 ;(defun enriched-nogrow-hook (beg end old-length)
 733 ;  "Implement front-nogrow and rear-grow for overlays.
 734 ;Normally overlays have opposite inheritance properties than
 735 ;text-properties: they will expand to include text inserted at their
 736 ;beginning, but not text inserted at their end.  However,
 737 ;if this function is an element of `after-change-functions', then
 738 ;overlays with a non-nil value of the `front-nogrow' property will not
 739 ;expand to include text that is inserted just in front of them, and
 740 ;overlays with a non-nil value of the `rear-grow' property will
 741 ;expand to include text that is inserted just after them."
 742 ;  (if (not (zerop old-length))
 743 ;      nil ;; not an insertion
 744 ;    (let ((overlays (overlays-at end)) o)
 745 ;      (while overlays
 746 ;       (setq o (car overlays)
 747 ;             overlays (cdr overlays))
 748 ;       (if (and (overlay-get o 'front-nogrow)
 749 ;                (= beg (overlay-start o)))
 750 ;           (move-overlay o end (overlay-end o)))))
 751 ;    (let ((overlays (overlays-at (1- beg))) o)
 752 ;      (while overlays
 753 ;       (setq o (car overlays)
 754 ;             overlays (cdr overlays))
 755 ;       (if (and (overlay-get o 'rear-grow)
 756 ;                (= beg (overlay-end o)))
 757 ;           (move-overlay o (overlay-start o) end))))))
 758
 759 (defun enriched-warn (&rest args)
 760   "Display a warning message.
 761 Arguments are given to `format' and the result is displayed in a buffer."
 762   (save-excursion
 763     (let ((buf (current-buffer))
 764           (line (1+ (count-lines 1 (point))))
 765           (mark (point-marker)))
 766       (pop-to-buffer (get-buffer-create "*Enriched Warnings*"))
 767       (goto-char (point-max))
 768       (insert
 769 ;       (format "%s:%d: " (if (boundp 'enriched-file) enriched-file
 770 ;                          (buffer-file-name buf))
 771 ;              line)
 772        (apply (function format) args)
 773        "\n")
 774       (pop-to-buffer buf))))
 775
 776 (defun enriched-looking-at-with-props (string)
 777   "True if text at point is equal to STRING, including text props.
 778 This is a literal, not a regexp match.
 779 The buffer text must include all text properties that STRING has, in
 780 the same places, but it is allowed to have others that STRING lacks."
 781   (let ((buffer-string (buffer-substring (point) (+ (point) (length string)))))
 782     (and (string-equal string buffer-string)
 783          (enriched-text-properties-include string buffer-string))))
 784
 785 (defun enriched-search-forward-with-props
 786   (string &optional bound noerror count)
 787   "Search forward for STRING, including its text properties.
 788 Set point to end of occurrence found, and return point.
 789 The match found must include all text properties that STRING has, in
 790 the same places, but it is allowed to have others that STRING lacks.
 791 An optional second argument bounds the search; it is a buffer position.
 792 The match found must not extend after that position.  nil is equivalent
 793   to (point-max).
 794 Optional third argument, if t, means if fail just return nil (no error).
 795   If not nil and not t, move to limit of search and return nil.
 796 Optional fourth argument is repeat count--search for successive occurrences.
 797 See also the functions `match-beginning', `match-end' and `replace-match'."
 798   (interactive "sSearch for: ")
 799   (or bound (setq bound (point-max)))
 800   (or count (setq count 1))
 801   (let ((start (point))
 802         (res t))
 803     (while (and res (> count 0))
 804       (while (and (setq res (search-forward string bound t))
 805                   (not (enriched-text-properties-include
 806                         string (buffer-substring (match-beginning 0)
 807                                                  (match-end 0))))))
 808       (setq count (1- count)))
 809     (cond (res)
 810           ((eq noerror t) (goto-char start) nil)
 811           (noerror (goto-char bound) nil)
 812           (t (goto-char start)
 813              (error "Search failed: %s" string)))))
 814
 815 (defun enriched-search-backward-with-props
 816   (string &optional bound noerror count)
 817   "Search backward for STRING, including its text properties.
 818 Set point to the beginning of occurrence found, and return point.
 819 The match found must include all text properties that STRING has, in
 820 the same places, but it is allowed to have others that STRING lacks.
 821 An optional second argument bounds the search; it is a buffer position.
 822 The match found must not start before that position.  nil is equivalent
 823   to (point-min).
 824 Optional third argument, if t, means if fail just return nil (no error).
 825   If not nil and not t, move to limit of search and return nil.
 826 Optional fourth argument is repeat count--search for successive occurrences.
 827 See also the functions `match-beginning', `match-end' and `replace-match'."
 828   (interactive "sSearch for: ")
 829   (or bound (setq bound (point-min)))
 830   (or count (setq count 1))
 831   (let ((start (point))
 832         (res t))
 833     (while (and res (> count 0))
 834       (while (and (setq res (search-backward string bound t))
 835                   (not (enriched-text-properties-include
 836                         string (buffer-substring (match-beginning 0)
 837                                                  (match-end 0))))))
 838       (setq count (1- count)))
 839     (cond (res)
 840           ((eq noerror t) (goto-char start) nil)
 841           (noerror (goto-char bound) nil)
 842           (t (goto-char start)
 843              (error "Search failed: %s" string)))))
 844
 845 (defun enriched-text-properties-include (a b)
 846   "True if all of A's text-properties are also properties of B.
 847 They must match in property name, value, and position.  B must be at least as
 848 long as A, but comparison is done only up to the length of A."
 849   (let ((loc (length a)))
 850     (catch 'fail
 851       (while (>= loc 0)
 852         (let ((plist (text-properties-at loc a)))
 853           (while plist
 854             (if (not (equal (car (cdr plist))
 855                             (get-text-property loc (car plist) b)))
 856                 (throw 'fail nil))
 857             (setq plist (cdr (cdr plist)))))
 858         (setq loc (1- loc)))
 859       t)))
 860
 861 (defun enriched-map-property-regions (prop func &optional from to)
 862   "Apply a function to regions of the buffer based on a text property.
 863 For each contiguous region of the buffer for which the value of PROPERTY is
 864 eq, the FUNCTION will be called.  Optional arguments FROM and TO specify the
 865 region over which to scan.
 866
 867 The specified function receives three arguments: the VALUE of the property in
 868 the region, and the START and END of each region."
 869   (save-excursion
 870     (save-restriction
 871       (if to (narrow-to-region (point-min) to))
 872       (goto-char (or from (point-min)))
 873       (let ((begin (point))
 874             end
 875             (marker (make-marker))
 876             (val (get-text-property (point) prop)))
 877         (while (setq end (text-property-not-all begin (point-max) prop val))
 878           (move-marker marker end)
 879           (funcall func val begin (marker-position marker))
 880           (setq begin (marker-position marker)
 881                 val (get-text-property marker prop)))
 882         (if (< begin (point-max))
 883             (funcall func val begin (point-max)))))))
 884
 885 (put 'enriched-map-property-regions 'lisp-indent-hook 1)
 886
 887 (defun enriched-insert-annotations (list &optional offset)
 888   "Apply list of annotations to buffer as write-region would.
 889 Inserts each element of LIST of buffer annotations at its appropriate place.
 890 Use second arg OFFSET if the annotations' locations are not
 891 relative to the beginning of the buffer: annotations will be inserted
 892 at their location-OFFSET+1 \(ie, the offset is the character number of
 893 the first character in the buffer)."
 894   (if (not offset)
 895       (setq offset 0)
 896     (setq offset (1- offset)))
 897   (let ((l (reverse list)))
 898     (while l
 899       (goto-char (- (car (car l)) offset))
 900       (insert (cdr (car l)))
 901       (setq l (cdr l)))))
 902
 903 ;;;
 904 ;;; Indentation, Filling, Justification
 905 ;;;
 906
 907 (defun enriched-text-width ()
 908   "The width of unindented text in this window, in characters.
 909 This is the width of the window minus `enriched-default-right-margin'."
 910   (or enriched-text-width
 911       (let ((ww (window-width)))
 912         (setq enriched-text-width
 913               (if (> ww enriched-default-right-margin)
 914                   (- ww enriched-default-right-margin)
 915                 ww)))))
 916
 917 (defun enriched-tag-indentation (from to)
 918   "Define region to be indentation."
 919   (add-text-properties from to '(enriched-indentation t
 920                                  rear-nonsticky (enriched-indentation))))
 921
 922 (defun enriched-insert-indentation (&optional from to)
 923   "Indent and justify each line in the region."
 924   (save-excursion
 925     (save-restriction
 926       (if to (narrow-to-region (point-min) to))
 927       (goto-char (or from (point-min)))
 928       (if (not (bolp)) (forward-line 1))
 929       (while (not (eobp))
 930         (indent-to (current-left-margin))
 931         (justify-current-line t nil t)
 932         (forward-line 1)))))
 933
 934 (defun enriched-delete-indentation (&optional from to)
 935   "Remove indentation and justification from region.
 936 Does not alter the left-margin and right-margin text properties, so the
 937 indentation can be reconstructed.  Tries only to remove whitespace that was
 938 added automatically, not spaces and tabs inserted by user."
 939   (save-excursion
 940     (save-restriction
 941       (if to (narrow-to-region (point-min) to))
 942       (if from
 943           (progn (goto-char from)
 944                  (if (not (bolp)) (forward-line 1))
 945                  (setq from (point)))
 946         (setq from (point-min)))
 947       (delete-to-left-margin from (point-max))
 948       (enriched-map-property-regions 'justification
 949         (lambda (v b e)
 950           (if (eq v 'full)
 951               (canonically-space-region b e)))
 952         from nil))))
 953
 954 ;;;
 955 ;;; Writing Files
 956 ;;;
 957
 958 (defsubst enriched-open-annotation (name)
 959   (insert-and-inherit (enriched-make-annotation name t)))
 960
 961 (defsubst enriched-close-annotation (name)
 962   (insert-and-inherit (enriched-make-annotation name nil)))
 963
 964 (defun enriched-annotate-function (start end)
 965   "For use on write-region-annotations-functions.
 966 Makes a new buffer containing the region in text/enriched format."
 967   (if enriched-mode
 968       (let (;(enriched-file (file-name-nondirectory buffer-file-name))
 969             (copy-buf (generate-new-buffer "*Enriched Temp*")))
 970         (copy-to-buffer copy-buf start end)
 971         (set-buffer copy-buf)
 972         (enriched-insert-annotations write-region-annotations-so-far start)
 973         (setq write-region-annotations-so-far nil)
 974         (enriched-encode-region)))
 975   nil)
 976
 977 (defun enriched-encode-region (&optional from to)
 978   "Transform buffer into text/enriched format."
 979   (if enriched-verbose (message "Enriched: encoding document..."))
 980   (setq enriched-ignored-list enriched-ignored-ok)
 981   (save-excursion
 982     (save-restriction
 983       (if to (narrow-to-region (point-min) to))
 984       (enriched-delete-indentation from to)
 985       (let ((enriched-open-ans nil)
 986             (inhibit-read-only t))
 987         (goto-char (or from (point-min)))
 988         (insert (if (stringp enriched-initial-annotation)
 989                     enriched-initial-annotation
 990                   (funcall enriched-initial-annotation)))
 991         (while
 992             (let* ((ans (enriched-loc-annotations (point)))
 993                    (neg-ans (enriched-reorder (car ans) enriched-open-ans))
 994                    (pos-ans (cdr ans)))
 995               ;; First do the negative (closing) annotations
 996               (while neg-ans
 997                 (if (not (member (car neg-ans) enriched-open-ans))
 998                     (enriched-warn "BUG DETECTED: Closing %s with open list=%s"
 999                                    (enriched-pop neg-ans) enriched-open-ans)
1000                   (while (not (equal (car neg-ans) (car enriched-open-ans)))
1001                     ;; To close anno. N, need to first close ans 1 to N-1,
1002                     ;; remembering to re-open them later.
1003                     (enriched-push (car enriched-open-ans) pos-ans)
1004                     (enriched-close-annotation (enriched-pop enriched-open-ans)))
1005                   ;; Now we can safely close this anno & remove from open list
1006                   (enriched-close-annotation (enriched-pop neg-ans))
1007                   (enriched-pop enriched-open-ans)))
1008               ;; Now deal with positive (opening) annotations
1009               (while pos-ans
1010                 (enriched-push (car pos-ans) enriched-open-ans)
1011                 (enriched-open-annotation (enriched-pop pos-ans)))
1012               (enriched-move-to-next-property-change)))
1013
1014         ;; Close up shop...
1015         (goto-char (point-max))
1016         (while enriched-open-ans
1017           (enriched-close-annotation (enriched-pop enriched-open-ans)))
1018         (if (not (= ?\n (char-after (1- (point)))))
1019             (insert ?\n)))
1020     (if (and enriched-verbose (> (length enriched-ignored-list)
1021                                  (length enriched-ignored-ok)))
1022         (let ((not-ok nil))
1023           (while (not (eq enriched-ignored-list enriched-ignored-ok))
1024             (setq not-ok (cons (car enriched-ignored-list) not-ok)
1025                   enriched-ignored-list (cdr enriched-ignored-list)))
1026           (enriched-warn "Not recorded: %s" not-ok)
1027           (sit-for 1))))))
1028
1029 (defun enriched-move-to-next-property-change ()
1030   "Advance point to next prop change, dealing with special items on the way.
1031 Returns the location, or nil."
1032   (let ((prop-change (next-property-change (point))))
1033     (while (and (< (point) (or prop-change (point-max)))
1034                 (search-forward enriched-encode-interesting-regexp
1035                                 prop-change 1))
1036       (goto-char (match-beginning 0))
1037       (let ((specials enriched-encode-special-alist))
1038         (while specials
1039           (if (enriched-looking-at-with-props (car (car specials)))
1040               (progn (goto-char (match-end 0))
1041                      (funcall (cdr (car specials)))
1042                      (setq specials nil))
1043             (enriched-pop specials)))))
1044     prop-change))
1045
1046 (defun enriched-loc-annotations (loc)
1047   "Return annotation(s) needed at LOCATION.
1048 This includes any properties that change between LOC-1 and LOC.
1049 If LOC is at the beginning of the buffer, will generate annotations for any
1050 non-nil properties there, plus the enriched-version annotation.
1051    Annotations are returned as a list.  The car of the list is the list of
1052 names of the annotations to close, and the cdr is the list of the names of the
1053 annotations to open."
1054   (let* ((prev-loc (1- loc))
1055          (begin (< prev-loc (point-min)))
1056          (before-plist (if begin nil (text-properties-at prev-loc)))
1057          (after-plist (text-properties-at loc))
1058          negatives positives prop props)
1059     ;; make list of all property names involved
1060     (while before-plist
1061       (enriched-push (car before-plist) props)
1062       (setq before-plist (cdr (cdr before-plist))))
1063     (while after-plist
1064       (enriched-push (car after-plist) props)
1065       (setq after-plist (cdr (cdr after-plist))))
1066     (setq props (enriched-make-list-uniq props))
1067
1068     (while props
1069       (setq prop (enriched-pop props))
1070       (if (memq prop enriched-ignored-list)
1071           nil  ; If its been ignored before, ignore it now.
1072         (let ((before (if begin nil (get-text-property prev-loc prop)))
1073               (after (get-text-property loc prop)))
1074           (if (equal before after)
1075               nil ; no change; ignore
1076             (let ((result (enriched-annotate-change prop before after)))
1077               (setq negatives (nconc negatives (car result))
1078                     positives (nconc positives (cdr result))))))))
1079     (cons negatives positives)))
1080
1081 (defun enriched-annotate-change (prop old new)
1082   "Return annotations for PROPERTY changing from OLD to NEW.
1083 These are searched for in `enriched-annotation-list'.
1084 If NEW does not appear in the list, but there is a default function, then that
1085 function is called.
1086 Annotations are returned as a list, as in `enriched-loc-annotations'."
1087   ;; If property is numeric, nil means 0
1088   (if (or (consp old) (consp new))
1089       (let* ((old (if (listp old) old (list old)))
1090              (new (if (listp new) new (list new)))
1091              (tail (enriched-common-tail old new))
1092              close open)
1093         (while old
1094           (setq close
1095                 (append (car (enriched-annotate-change prop (car old) nil))
1096                         close)
1097                 old (cdr old)))
1098         (while new
1099           (setq open
1100                 (append (cdr (enriched-annotate-change prop nil (car new)))
1101                         open)
1102                 new (cdr new)))
1103         (enriched-make-relatively-unique close open))
1104     (cond ((and (numberp old) (null new))
1105            (setq new 0))
1106           ((and (numberp new) (null old))
1107            (setq old 0)))
1108     (let ((prop-alist (cdr (assoc prop enriched-annotation-alist)))
1109           default)
1110       (cond ((null prop-alist)          ; not found
1111              (if (not (memq prop enriched-ignored-list))
1112                  (enriched-push prop enriched-ignored-list))
1113              nil)
1114
1115             ;; Numerical values: use the difference
1116             ((and (numberp old) (numberp new))
1117              (let* ((entry (progn
1118                              (while (and (car (car prop-alist))
1119                                          (not (numberp (car (car prop-alist)))))
1120                                (enriched-pop prop-alist))
1121                              (car prop-alist)))
1122                     (increment (car (car prop-alist)))
1123                     (n (ceiling (/ (float (- new old)) (float increment))))
1124                     (anno (car (cdr (car prop-alist)))))
1125                (if (> n 0)
1126                    (cons nil (make-list n anno))
1127                  (cons (make-list (- n) anno) nil))))
1128
1129             ;; Standard annotation
1130             (t (let ((close (and old (cdr (assoc old prop-alist))))
1131                      (open  (and new (cdr (assoc new prop-alist)))))
1132                  (if (or close open)
1133                      (enriched-make-relatively-unique close open)
1134                    (let ((default (assoc nil prop-alist)))
1135                      (if default
1136                          (funcall (car (cdr default)) old new))))))))))
1137
1138 ;;;
1139 ;;; Reading files
1140 ;;;
1141
1142 (defun enriched-decode-region (&optional from to)
1143   "Decode text/enriched buffer into text with properties.
1144 This is the primary entry point for decoding."
1145   (if enriched-verbose (message "Enriched: decoding document..."))
1146   (save-excursion
1147     (save-restriction
1148       (if to (narrow-to-region (point-min) to))
1149       (goto-char (or from (point-min)))
1150       (let ((file-width (enriched-get-file-width))
1151             (inhibit-read-only t)
1152             enriched-open-ans todo loc unknown-ans)
1153
1154         (while (enriched-move-to-next-annotation)
1155           (let* ((loc (match-beginning 0))
1156                  (anno (buffer-substring (match-beginning 0) (match-end 0)))
1157                  (name (enriched-annotation-name anno))
1158                  (positive (enriched-annotation-positive-p anno)))
1159
1160             (if enriched-downcase-annotations
1161                 (setq name (downcase name)))
1162
1163             (delete-region (match-beginning 0) (match-end 0))
1164             (if positive
1165                 (enriched-push (list name loc) enriched-open-ans)
1166               ;; negative...
1167               (let* ((top (car enriched-open-ans))
1168                      (top-name (car top))
1169                      (start (car (cdr top)))
1170                      (params (cdr (cdr top)))
1171                      (aalist enriched-annotation-alist)
1172                      (matched nil))
1173                 (if (not (equal name top-name))
1174                     (error (format "Improper nesting in file: %s != %s"
1175                                    name top)))
1176                 (while aalist
1177                   (let ((prop (car (car aalist)))
1178                         (alist (cdr (car aalist))))
1179                     (while alist
1180                       (let ((value (car (car alist)))
1181                             (ans (cdr (car alist))))
1182                         (if (member name ans)
1183                             ;; Check if multiple annotations are satisfied
1184                             (if (member 'nil (mapcar
1185                                               (lambda (r)
1186                                                 (assoc r enriched-open-ans))
1187                                               ans))
1188                                 nil     ; multiple ans not satisfied
1189                               ;; Yes, we got it:
1190                               (setq alist nil aalist nil matched t
1191                                     enriched-open-ans (cdr enriched-open-ans))
1192                               (cond
1193                                ((eq prop 'PARAMETER)
1194                                 ;; This is a parameter of the top open ann.
1195                                 (let ((nxt (enriched-pop enriched-open-ans)))
1196                                   (if nxt
1197                                       (enriched-push
1198                                        (append
1199                                         nxt
1200                                         (list (buffer-substring start loc)))
1201                                        enriched-open-ans))
1202                                   (delete-region start loc)))
1203                                ((eq prop 'FUNCTION)
1204                                 (let ((rtn (apply value start loc params)))
1205                                   (if rtn (enriched-push rtn todo))))
1206                                (t
1207                                 ;; Normal property/value pair
1208                                 (enriched-push (list start loc prop value)
1209                                                todo))))))
1210                         (enriched-pop alist)))
1211                   (enriched-pop aalist))
1212                 (if matched
1213                     nil
1214                   ;; Didn't find it
1215                   (enriched-pop enriched-open-ans)
1216                   (enriched-push (list start loc 'unknown name) todo)
1217                   (enriched-push name unknown-ans))))))
1218
1219         ;; Now actually add the properties
1220
1221         (while todo
1222           (let* ((item (enriched-pop todo))
1223                  (from (elt item 0))
1224                  (to   (elt item 1))
1225                  (prop (elt item 2))
1226                  (val  (elt item 3)))
1227
1228 ;           (if (and (eq prop 'IGNORE)  ; 'IGNORE' pseudo-property was special
1229 ;                    (eq val t))
1230 ;               (delete-region from to))
1231             (put-text-property
1232                from to prop
1233                (cond ((numberp val)
1234                       (+ val (or (get-text-property from prop) 0)))
1235                      ((memq prop enriched-list-valued-properties)
1236                       (let ((prev (get-text-property from prop)))
1237                         (cons val (if (listp prev) prev (list prev)))))
1238                      (t val)))))
1239
1240         (if (or (and file-width         ; possible reasons not to fill:
1241                      (= file-width (enriched-text-width)))  ; correct wd.
1242                 (null enriched-fill-after-visiting)         ; never fill
1243                 (and (eq 'ask enriched-fill-after-visiting) ; asked & declined
1244                      (not (y-or-n-p "Reformat for current display width? "))))
1245             ;; Minimally, we have to insert indentation and justification.
1246             (enriched-insert-indentation)
1247           (sit-for 1)
1248           (if enriched-verbose (message "Filling paragraphs..."))
1249           (fill-region (point-min) (point-max))
1250           (if enriched-verbose (message nil)))
1251
1252         (if enriched-verbose
1253             (progn
1254               (message nil)
1255               (if unknown-ans
1256                   (enriched-warn "Unknown annotations: %s" unknown-ans))))))))
1257
1258 (defun enriched-get-file-width ()
1259   "Look for file width information on this line."
1260   (save-excursion
1261     (if (search-forward "width:" (save-excursion (end-of-line) (point)) t)
1262         (read (current-buffer)))))
1263
1264 (defun enriched-move-to-next-annotation ()
1265   "Advances point to next annotation, dealing with special items on the way.
1266 Returns t if one was found, otherwise nil."
1267   (while (and (re-search-forward enriched-decode-interesting-regexp nil t)
1268               (goto-char (match-beginning 0))
1269               (not (looking-at enriched-annotation-regexp)))
1270       (let ((regexps enriched-decode-special-alist))
1271         (while (and regexps
1272                     (not (looking-at (car (car regexps)))))
1273           (enriched-pop regexps))
1274         (if regexps
1275             (funcall (cdr (car regexps)))
1276           (forward-char 1)))) ; nothing found
1277   (not (eobp)))
1278
1279 ;;; enriched.el ends here