lisp/enriched.el

   1 ;;; enriched.el --- read and save files in text/enriched format
   2
   3 ;; Copyright (c) 1994, 1995, 1996 Free Software Foundation, Inc.
   4
   5 ;; Author: Boris Goldowsky <boris@gnu.org>
   6 ;; Keywords: wp, faces
   7
   8 ;; This file is part of GNU Emacs.
   9
  10 ;; GNU Emacs is free software; you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation; either version 2, or (at your option)
  13 ;; any later version.
  14
  15 ;; GNU Emacs is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  22 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  23 ;; Boston, MA 02111-1307, USA.
  24
  25 ;;; Commentary:
  26
  27 ;; This file implements reading, editing, and saving files with
  28 ;; text-properties such as faces, levels of indentation, and true line
  29 ;; breaks distinguished from newlines just used to fit text into the window.
  30
  31 ;; The file format used is the MIME text/enriched format, which is a
  32 ;; standard format defined in internet RFC 1563.  All standard annotations
  33 ;; are supported except for <smaller> and <bigger>, which are currently not
  34 ;; possible to display.
  35
  36 ;; A separate file, enriched.doc, contains further documentation and other
  37 ;; important information about this code.  It also serves as an example
  38 ;; file in text/enriched format.  It should be in the etc directory of your
  39 ;; emacs distribution.
  40
  41 ;;; Code:
  42
  43 (provide 'enriched)
  44
  45 ;;;
  46 ;;; Variables controlling the display
  47 ;;;
  48
  49 (defgroup enriched nil
  50   "Read and save files in text/enriched format"
  51   :group 'wp)
  52
  53 (defcustom enriched-verbose t
  54   "*If non-nil, give status messages when reading and writing files."
  55   :type 'boolean
  56   :group 'enriched)
  57
  58 ;;;
  59 ;;; Set up faces & display table
  60 ;;;
  61
  62 ;; Emacs doesn't have a "fixed" face by default, since all faces currently
  63 ;; have to be fixed-width.  So we just pick one that looks different from the
  64 ;; default.
  65 (defface fixed
  66   '((t (:bold t)))
  67   "Face used for text that must be shown in fixed width.
  68 Currently, emacs can only display fixed-width fonts, but this may change.
  69 This face is used for text specifically marked as fixed-width, for example
  70 in text/enriched files."
  71   :group 'enriched)
  72
  73 (defface excerpt
  74   '((t (:italic t)))
  75   "Face used for text that is an excerpt from another document.
  76 This is used in enriched-mode for text explicitly marked as an excerpt."
  77   :group 'enriched)
  78
  79 (defconst enriched-display-table (or (copy-sequence standard-display-table)
  80                                      (make-display-table)))
  81 (aset enriched-display-table ?\f (make-vector (1- (frame-width)) ?-))
  82
  83 (defconst enriched-par-props '(left-margin right-margin justification)
  84   "Text-properties that usually apply to whole paragraphs.
  85 These are set front-sticky everywhere except at hard newlines.")
  86
  87 ;;;
  88 ;;; Variables controlling the file format
  89 ;;;   (bidirectional)
  90
  91 (defconst enriched-initial-annotation
  92   (lambda ()
  93     (format "Content-Type: text/enriched\nText-Width: %d\n\n"
  94             fill-column))
  95   "What to insert at the start of a text/enriched file.
  96 If this is a string, it is inserted.  If it is a list, it should be a lambda
  97 expression, which is evaluated to get the string to insert.")
  98
  99 (defconst enriched-annotation-format "<%s%s>"
 100   "General format of enriched-text annotations.")
 101
 102 (defconst enriched-annotation-regexp "<\\(/\\)?\\([-A-za-z0-9]+\\)>"
 103   "Regular expression matching enriched-text annotations.")
 104
 105 (defconst enriched-translations
 106   '((face          (bold-italic "bold" "italic")
 107                    (bold        "bold")
 108                    (italic      "italic")
 109                    (underline   "underline")
 110                    (fixed       "fixed")
 111                    (excerpt     "excerpt")
 112                    (default     )
 113                    (nil         enriched-encode-other-face))
 114     (left-margin   (4           "indent"))
 115     (right-margin  (4           "indentright"))
 116     (justification (none        "nofill")
 117                    (right       "flushright")
 118                    (left        "flushleft")
 119                    (full        "flushboth")
 120                    (center      "center"))
 121     (PARAMETER     (t           "param")) ; Argument of preceding annotation
 122     ;; The following are not part of the standard:
 123     (FUNCTION      (enriched-decode-foreground "x-color")
 124                    (enriched-decode-background "x-bg-color")
 125                    (enriched-decode-display-prop "x-display"))
 126     (read-only     (t           "x-read-only"))
 127     (display       (nil         enriched-handle-display-prop))
 128     (unknown       (nil         format-annotate-value))
 129 ;   (font-size     (2           "bigger")       ; unimplemented
 130 ;                  (-2          "smaller"))
 131 )
 132   "List of definitions of text/enriched annotations.
 133 See `format-annotate-region' and `format-deannotate-region' for the definition
 134 of this structure.")
 135
 136 (defconst enriched-ignore
 137   '(front-sticky rear-nonsticky hard)
 138   "Properties that are OK to ignore when saving text/enriched files.
 139 Any property that is neither on this list nor dealt with by
 140 `enriched-translations' will generate a warning.")
 141
 142 ;;; Internal variables
 143
 144 (defvar enriched-mode nil
 145   "True if Enriched mode is in use.")
 146 (make-variable-buffer-local 'enriched-mode)
 147 (put 'enriched-mode 'permanent-local t)
 148
 149 (if (not (assq 'enriched-mode minor-mode-alist))
 150     (setq minor-mode-alist
 151           (cons '(enriched-mode " Enriched")
 152                 minor-mode-alist)))
 153
 154 (defcustom enriched-mode-hook nil
 155   "Functions to run when entering Enriched mode.
 156 If you set variables in this hook, you should arrange for them to be restored
 157 to their old values if you leave Enriched mode.  One way to do this is to add
 158 them and their old values to `enriched-old-bindings'."
 159   :type 'hook
 160   :group 'enriched)
 161
 162 (defvar enriched-old-bindings nil
 163   "Store old variable values that we change when entering mode.
 164 The value is a list of \(VAR VALUE VAR VALUE...).")
 165 (make-variable-buffer-local 'enriched-old-bindings)
 166
 167 ;;;
 168 ;;; Define the mode
 169 ;;;
 170
 171 ;;;###autoload
 172 (defun enriched-mode (&optional arg)
 173   "Minor mode for editing text/enriched files.
 174 These are files with embedded formatting information in the MIME standard
 175 text/enriched format.
 176 Turning the mode on runs `enriched-mode-hook'.
 177
 178 More information about Enriched mode is available in the file
 179 etc/enriched.doc  in the Emacs distribution directory.
 180
 181 Commands:
 182
 183 \\<enriched-mode-map>\\{enriched-mode-map}"
 184   (interactive "P")
 185   (let ((mod (buffer-modified-p)))
 186     (cond ((or (<= (prefix-numeric-value arg) 0)
 187                (and enriched-mode (null arg)))
 188            ;; Turn mode off
 189            (setq enriched-mode nil)
 190            (setq buffer-file-format (delq 'text/enriched buffer-file-format))
 191            ;; restore old variable values
 192            (while enriched-old-bindings
 193              (funcall 'set (car enriched-old-bindings)
 194                       (car (cdr enriched-old-bindings)))
 195              (setq enriched-old-bindings (cdr (cdr enriched-old-bindings)))))
 196
 197           (enriched-mode nil)           ; Mode already on; do nothing.
 198
 199           (t (setq enriched-mode t)     ; Turn mode on
 200              (add-to-list 'buffer-file-format 'text/enriched)
 201              ;; Save old variable values before we change them.
 202              ;; These will be restored if we exit Enriched mode.
 203              (setq enriched-old-bindings
 204                    (list 'buffer-display-table buffer-display-table
 205                          'indent-line-function indent-line-function
 206                          'default-text-properties default-text-properties))
 207              (make-local-variable 'indent-line-function)
 208              (make-local-variable 'default-text-properties)
 209              (setq indent-line-function 'indent-to-left-margin
 210                    buffer-display-table  enriched-display-table)
 211              (use-hard-newlines 1 nil)
 212              (let ((sticky (plist-get default-text-properties 'front-sticky))
 213                    (p enriched-par-props))
 214                (while p
 215                  (add-to-list 'sticky (car p))
 216                  (setq p (cdr p)))
 217                (if sticky
 218                    (setq default-text-properties
 219                          (plist-put default-text-properties
 220                                     'front-sticky sticky))))
 221              (run-hooks 'enriched-mode-hook)))
 222     (set-buffer-modified-p mod)
 223     (force-mode-line-update)))
 224
 225 ;;;
 226 ;;; Keybindings
 227 ;;;
 228
 229 (defvar enriched-mode-map nil
 230   "Keymap for Enriched mode.")
 231
 232 (if (null enriched-mode-map)
 233     (fset 'enriched-mode-map (setq enriched-mode-map (make-sparse-keymap))))
 234
 235 (if (not (assq 'enriched-mode minor-mode-map-alist))
 236     (setq minor-mode-map-alist
 237           (cons (cons 'enriched-mode enriched-mode-map)
 238                 minor-mode-map-alist)))
 239
 240 (define-key enriched-mode-map "\C-a" 'beginning-of-line-text)
 241 (define-key enriched-mode-map "\C-m" 'reindent-then-newline-and-indent)
 242 (define-key enriched-mode-map "\C-j" 'reindent-then-newline-and-indent)
 243 (define-key enriched-mode-map "\M-j" 'facemenu-justification-menu)
 244 (define-key enriched-mode-map "\M-S" 'set-justification-center)
 245 (define-key enriched-mode-map "\C-x\t" 'increase-left-margin)
 246 (define-key enriched-mode-map "\C-c\C-l" 'set-left-margin)
 247 (define-key enriched-mode-map "\C-c\C-r" 'set-right-margin)
 248
 249 ;;;
 250 ;;; Some functions dealing with text-properties, especially indentation
 251 ;;;
 252
 253 (defun enriched-map-property-regions (prop func &optional from to)
 254   "Apply a function to regions of the buffer based on a text property.
 255 For each contiguous region of the buffer for which the value of PROPERTY is
 256 eq, the FUNCTION will be called.  Optional arguments FROM and TO specify the
 257 region over which to scan.
 258
 259 The specified function receives three arguments: the VALUE of the property in
 260 the region, and the START and END of each region."
 261   (save-excursion
 262     (save-restriction
 263       (if to (narrow-to-region (point-min) to))
 264       (goto-char (or from (point-min)))
 265       (let ((begin (point))
 266             end
 267             (marker (make-marker))
 268             (val (get-text-property (point) prop)))
 269         (while (setq end (text-property-not-all begin (point-max) prop val))
 270           (move-marker marker end)
 271           (funcall func val begin (marker-position marker))
 272           (setq begin (marker-position marker)
 273                 val (get-text-property marker prop)))
 274         (if (< begin (point-max))
 275             (funcall func val begin (point-max)))))))
 276
 277 (put 'enriched-map-property-regions 'lisp-indent-hook 1)
 278
 279 (defun enriched-insert-indentation (&optional from to)
 280   "Indent and justify each line in the region."
 281   (save-excursion
 282     (save-restriction
 283       (if to (narrow-to-region (point-min) to))
 284       (goto-char (or from (point-min)))
 285       (if (not (bolp)) (forward-line 1))
 286       (while (not (eobp))
 287         (if (eolp)
 288             nil ; skip blank lines
 289           (indent-to (current-left-margin))
 290           (justify-current-line t nil t))
 291         (forward-line 1)))))
 292
 293 ;;;
 294 ;;; Encoding Files
 295 ;;;
 296
 297 ;;;###autoload
 298 (defun enriched-encode (from to orig-buf)
 299   (if enriched-verbose (message "Enriched: encoding document..."))
 300   (save-restriction
 301     (narrow-to-region from to)
 302     (delete-to-left-margin)
 303     (unjustify-region)
 304     (goto-char from)
 305     (format-replace-strings '(("<" . "<<")))
 306     (format-insert-annotations
 307      (format-annotate-region from (point-max) enriched-translations
 308                              'enriched-make-annotation enriched-ignore))
 309     (goto-char from)
 310     (insert (if (stringp enriched-initial-annotation)
 311                 enriched-initial-annotation
 312               (save-excursion
 313                 ;; Eval this in the buffer we are annotating.  This
 314                 ;; fixes a bug which was saving incorrect File-Width
 315                 ;; information, since we were looking at local
 316                 ;; variables in the wrong buffer.
 317                 (if orig-buf (set-buffer orig-buf))
 318                 (funcall enriched-initial-annotation))))
 319     (enriched-map-property-regions 'hard
 320       (lambda (v b e)
 321         (if (and v (= ?\n (char-after b)))
 322             (progn (goto-char b) (insert "\n"))))
 323       (point) nil)
 324     (if enriched-verbose (message nil))
 325     ;; Return new end.
 326     (point-max)))
 327
 328 (defun enriched-make-annotation (name positive)
 329   "Format an annotation called NAME.
 330 If POSITIVE is non-nil, this is the opening annotation, if nil, this is the
 331 matching close."
 332   (cond ((stringp name)
 333          (format enriched-annotation-format (if positive "" "/") name))
 334         ;; Otherwise it is an annotation with parameters, represented as a list
 335         (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         (t (format enriched-annotation-format "/" (car name)))))
 342
 343 (defun enriched-encode-other-face (old new)
 344   "Generate annotations for random face change.
 345 One annotation each for foreground color, background color, italic, etc."
 346   (cons (and old (enriched-face-ans old))
 347         (and new (enriched-face-ans new))))
 348
 349 (defun enriched-face-ans (face)
 350   "Return annotations specifying FACE."
 351   (cond ((and (consp face) (eq (car face) 'foreground-color))
 352          (list "x-color" (cdr face)))
 353         ((and (consp face) (eq (car face) 'background-color))
 354          (list "x-bg-color" (cdr face)))
 355         ((string-match "^fg:" (symbol-name face))
 356          (list (list "x-color" (substring (symbol-name face) 3))))
 357         ((string-match "^bg:" (symbol-name face))
 358          (list (list "x-bg-color" (substring (symbol-name face) 3))))
 359         ((let* ((fg (face-foreground face))
 360                 (bg (face-background face))
 361                 (props (face-font face t))
 362                 (ans (cdr (format-annotate-single-property-change
 363                            'face nil props enriched-translations))))
 364            (if fg (setq ans (cons (list "x-color" fg) ans)))
 365            (if bg (setq ans (cons (list "x-bg-color" bg) ans)))
 366            ans))))
 367
 368 ;;;
 369 ;;; Decoding files
 370 ;;;
 371
 372 ;;;###autoload
 373 (defun enriched-decode (from to)
 374   (if enriched-verbose (message "Enriched: decoding document..."))
 375   (use-hard-newlines 1 'never)
 376   (save-excursion
 377     (save-restriction
 378       (narrow-to-region from to)
 379       (goto-char from)
 380
 381       ;; Deal with header
 382       (let ((file-width (enriched-get-file-width)))
 383         (enriched-remove-header)
 384
 385         ;; Deal with newlines
 386         (while (search-forward-regexp "\n\n+" nil t)
 387           (if (current-justification)
 388               (delete-char -1))
 389           (set-hard-newline-properties (match-beginning 0) (point)))
 390
 391         ;; Translate annotations
 392         (format-deannotate-region from (point-max) enriched-translations
 393                                   'enriched-next-annotation)
 394
 395         ;; Indent or fill the buffer
 396         (cond (file-width               ; File was filled to this width
 397                (setq fill-column file-width)
 398                (if enriched-verbose (message "Indenting..."))
 399                (enriched-insert-indentation))
 400               (t                        ; File was not filled.
 401                (if enriched-verbose (message "Filling paragraphs..."))
 402                (fill-region (point-min) (point-max))))
 403         (if enriched-verbose (message nil)))
 404       (point-max))))
 405
 406 (defun enriched-next-annotation ()
 407   "Find and return next text/enriched annotation.
 408 Any \"<<\" strings encountered are converted to \"<\".
 409 Return value is \(begin end name positive-p), or nil if none was found."
 410   (while (and (search-forward "<" nil 1)
 411               (progn (goto-char (match-beginning 0))
 412                      (not (looking-at enriched-annotation-regexp))))
 413     (forward-char 1)
 414     (if (= ?< (char-after (point)))
 415         (delete-char 1)
 416       ;; A single < that does not start an annotation is an error,
 417       ;; which we note and then ignore.
 418       (message "Warning: malformed annotation in file at %s"
 419                (1- (point)))))
 420   (if (not (eobp))
 421       (let* ((beg (match-beginning 0))
 422              (end (match-end 0))
 423              (name (downcase (buffer-substring
 424                               (match-beginning 2) (match-end 2))))
 425              (pos (not (match-beginning 1))))
 426         (list beg end name pos))))
 427
 428 (defun enriched-get-file-width ()
 429   "Look for file width information on this line."
 430   (save-excursion
 431     (if (search-forward "Text-Width: " (+ (point) 1000) t)
 432         (read (current-buffer)))))
 433
 434 (defun enriched-remove-header ()
 435   "Remove file-format header at point."
 436   (while (looking-at "^[-A-Za-z]+: .*\n")
 437     (delete-region (point) (match-end 0)))
 438   (if (looking-at "^\n")
 439       (delete-char 1)))
 440
 441 (defun enriched-decode-foreground (from to &optional color)
 442   (let ((face (intern (concat "fg:" color))))
 443     (cond ((null color)
 444            (message "Warning: no color specified for <x-color>"))
 445           ((internal-find-face face))
 446           ((and (display-color-p) (facemenu-get-face face)))
 447           ((make-face face)
 448            (message "Warning: color `%s' can't be displayed" color)))
 449     (list from to 'face face)))
 450
 451 (defun enriched-decode-background (from to &optional color)
 452   (let ((face (intern (concat "bg:" color))))
 453     (cond ((null color)
 454            (message "Warning: no color specified for <x-bg-color>"))
 455           ((internal-find-face face))
 456           ((and (display-color-p) (facemenu-get-face face)))
 457           ((make-face face)
 458            (message "Warning: color `%s' can't be displayed" color)))
 459     (list from to 'face face)))
 460
 461
 462 \f
 463 ;;; Handling the `display' property.
 464
 465
 466 (defun enriched-handle-display-prop (old new)
 467   "Return a list of annotations for a change in the `display' property.
 468 OLD is the old value of the property, NEW is the new value.  Value
 469 is a list `(CLOSE OPEN)', where CLOSE is a list of annotations to
 470 close and OPEN a list of annotations to open.  Each of these lists
 471 has the form `(ANNOTATION PARAM ...)'."
 472   (let ((annotation "x-display")
 473         (param (prin1-to-string (or old new)))
 474         close open)
 475     (if (null old)
 476         (list nil (list annotation param))
 477       (list (list annotation param)))))
 478
 479
 480 (defun enriched-decode-display-prop (start end &optional param)
 481   "Decode a `display' property for text between START and END.
 482 PARAM is a `<param>' found for the property.
 483 Value is a list `(START END SYMBOL VALUE)' with START and END denoting
 484 the range of text to assign text property SYMBOL with value VALUE "
 485   (let ((prop (when (stringp param)
 486                 (condition-case ()
 487                     (car (read-from-string param))
 488                   (error nil)))))
 489     (unless prop
 490       (message "Warning: invalid <x-display> parameter %s" param))
 491     (list start end 'display prop)))
 492
 493
 494 ;;; enriched.el ends here