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.ai.mit.edu>
   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 (defvar enriched-verbose t
  50   "*If non-nil, give status messages when reading and writing files.")
  51
  52 ;;;
  53 ;;; Set up faces & display table
  54 ;;;
  55
  56 ;; A slight cheat - all emacs's faces are fixed-width.
  57 ;; The idea is just to pick one that looks different from the default.
  58 (if (internal-find-face 'fixed)
  59     nil
  60   (make-face 'fixed)
  61   (if window-system
  62       (set-face-font 'fixed
  63                      (car (or (x-list-fonts "*fixed-medium*"
  64                                             'default (selected-frame))
  65                               (x-list-fonts "*fixed*"
  66                                             'default (selected-frame)))))))
  67
  68 (if (internal-find-face 'excerpt)
  69     nil
  70   (make-face 'excerpt)
  71   (if window-system
  72       (make-face-italic 'excerpt nil t)))
  73
  74 (defconst enriched-display-table (or (copy-sequence standard-display-table)
  75                                      (make-display-table)))
  76 (aset enriched-display-table ?\f (make-vector (1- (frame-width)) ?-))
  77
  78 (defconst enriched-par-props '(left-margin right-margin justification)
  79   "Text-properties that usually apply to whole paragraphs.
  80 These are set front-sticky everywhere except at hard newlines.")
  81
  82 ;;;
  83 ;;; Variables controlling the file format
  84 ;;;   (bidirectional)
  85
  86 (defconst enriched-initial-annotation
  87   (lambda ()
  88     (format "Content-Type: text/enriched\nText-Width: %d\n\n"
  89             fill-column))
  90   "What to insert at the start of a text/enriched file.
  91 If this is a string, it is inserted.  If it is a list, it should be a lambda
  92 expression, which is evaluated to get the string to insert.")
  93
  94 (defconst enriched-annotation-format "<%s%s>"
  95   "General format of enriched-text annotations.")
  96
  97 (defconst enriched-annotation-regexp "<\\(/\\)?\\([-A-za-z0-9]+\\)>"
  98   "Regular expression matching enriched-text annotations.")
  99
 100 (defconst enriched-translations
 101   '((face          (bold-italic "bold" "italic")
 102                    (bold        "bold")
 103                    (italic      "italic")
 104                    (underline   "underline")
 105                    (fixed       "fixed")
 106                    (excerpt     "excerpt")
 107                    (default     )
 108                    (nil         enriched-encode-other-face))
 109     (left-margin   (4           "indent"))
 110     (right-margin  (4           "indentright"))
 111     (justification (none        "nofill")
 112                    (right       "flushright")
 113                    (left        "flushleft")
 114                    (full        "flushboth")
 115                    (center      "center"))
 116     (PARAMETER     (t           "param")) ; Argument of preceding annotation
 117     ;; The following are not part of the standard:
 118     (FUNCTION      (enriched-decode-foreground "x-color")
 119                    (enriched-decode-background "x-bg-color"))
 120     (read-only     (t           "x-read-only"))
 121     (unknown       (nil         format-annotate-value))
 122 ;   (font-size     (2           "bigger")       ; unimplemented
 123 ;                  (-2          "smaller"))
 124 )
 125   "List of definitions of text/enriched annotations.
 126 See `format-annotate-region' and `format-deannotate-region' for the definition
 127 of this structure.")
 128
 129 (defconst enriched-ignore
 130   '(front-sticky rear-nonsticky hard)
 131   "Properties that are OK to ignore when saving text/enriched files.
 132 Any property that is neither on this list nor dealt with by
 133 `enriched-translations' will generate a warning.")
 134
 135 ;;; Internal variables
 136
 137 (defvar enriched-mode nil
 138   "True if Enriched mode is in use.")
 139 (make-variable-buffer-local 'enriched-mode)
 140
 141 (if (not (assq 'enriched-mode minor-mode-alist))
 142     (setq minor-mode-alist
 143           (cons '(enriched-mode " Enriched")
 144                 minor-mode-alist)))
 145
 146 (defvar enriched-mode-hook nil
 147   "Functions to run when entering Enriched mode.
 148 If you set variables in this hook, you should arrange for them to be restored
 149 to their old values if you leave Enriched mode.  One way to do this is to add
 150 them and their old values to `enriched-old-bindings'.")
 151
 152 (defvar enriched-old-bindings nil
 153   "Store old variable values that we change when entering mode.
 154 The value is a list of \(VAR VALUE VAR VALUE...).")
 155 (make-variable-buffer-local 'enriched-old-bindings)
 156
 157 ;;;
 158 ;;; Define the mode
 159 ;;;
 160
 161 ;;;###autoload
 162 (defun enriched-mode (&optional arg)
 163   "Minor mode for editing text/enriched files.
 164 These are files with embedded formatting information in the MIME standard
 165 text/enriched format.
 166 Turning the mode on runs `enriched-mode-hook'.
 167
 168 More information about Enriched mode is available in the file
 169 etc/enriched.doc  in the Emacs distribution directory.
 170
 171 Commands:
 172
 173 \\<enriched-mode-map>\\{enriched-mode-map}"
 174   (interactive "P")
 175   (let ((mod (buffer-modified-p)))
 176     (cond ((or (<= (prefix-numeric-value arg) 0)
 177                (and enriched-mode (null arg)))
 178            ;; Turn mode off
 179            (setq enriched-mode nil)
 180            (setq buffer-file-format (delq 'text/enriched buffer-file-format))
 181            ;; restore old variable values
 182            (while enriched-old-bindings
 183              (funcall 'set (car enriched-old-bindings)
 184                       (car (cdr enriched-old-bindings)))
 185              (setq enriched-old-bindings (cdr (cdr enriched-old-bindings)))))
 186
 187           (enriched-mode nil)           ; Mode already on; do nothing.
 188
 189           (t (setq enriched-mode t)     ; Turn mode on
 190              (add-to-list 'buffer-file-format 'text/enriched)
 191              ;; Save old variable values before we change them.
 192              ;; These will be restored if we exit Enriched mode.
 193              (setq enriched-old-bindings
 194                    (list 'buffer-display-table buffer-display-table
 195                          'indent-line-function indent-line-function
 196                          'default-text-properties default-text-properties))
 197              (make-local-variable 'indent-line-function)
 198              (make-local-variable 'default-text-properties)
 199              (setq indent-line-function 'indent-to-left-margin
 200                    buffer-display-table  enriched-display-table)
 201              (use-hard-newlines 1 nil)
 202              (let ((sticky (plist-get default-text-properties 'front-sticky))
 203                    (p enriched-par-props))
 204                (while p
 205                  (add-to-list 'sticky (car p))
 206                  (setq p (cdr p)))
 207                (if sticky
 208                    (setq default-text-properties
 209                          (plist-put default-text-properties
 210                                     'front-sticky sticky))))
 211              (run-hooks 'enriched-mode-hook)))
 212     (set-buffer-modified-p mod)
 213     (force-mode-line-update)))
 214
 215 ;;;
 216 ;;; Keybindings
 217 ;;;
 218
 219 (defvar enriched-mode-map nil
 220   "Keymap for Enriched mode.")
 221
 222 (if (null enriched-mode-map)
 223     (fset 'enriched-mode-map (setq enriched-mode-map (make-sparse-keymap))))
 224
 225 (if (not (assq 'enriched-mode minor-mode-map-alist))
 226     (setq minor-mode-map-alist
 227           (cons (cons 'enriched-mode enriched-mode-map)
 228                 minor-mode-map-alist)))
 229
 230 (define-key enriched-mode-map "\C-a" 'beginning-of-line-text)
 231 (define-key enriched-mode-map "\C-m" 'reindent-then-newline-and-indent)
 232 (define-key enriched-mode-map "\C-j" 'reindent-then-newline-and-indent)
 233 (define-key enriched-mode-map "\M-j" 'facemenu-justification-menu)
 234 (define-key enriched-mode-map "\M-S" 'set-justification-center)
 235 (define-key enriched-mode-map "\C-x\t" 'increase-left-margin)
 236 (define-key enriched-mode-map "\C-c\C-l" 'set-left-margin)
 237 (define-key enriched-mode-map "\C-c\C-r" 'set-right-margin)
 238
 239 ;;;
 240 ;;; Some functions dealing with text-properties, especially indentation
 241 ;;;
 242
 243 (defun enriched-map-property-regions (prop func &optional from to)
 244   "Apply a function to regions of the buffer based on a text property.
 245 For each contiguous region of the buffer for which the value of PROPERTY is
 246 eq, the FUNCTION will be called.  Optional arguments FROM and TO specify the
 247 region over which to scan.
 248
 249 The specified function receives three arguments: the VALUE of the property in
 250 the region, and the START and END of each region."
 251   (save-excursion
 252     (save-restriction
 253       (if to (narrow-to-region (point-min) to))
 254       (goto-char (or from (point-min)))
 255       (let ((begin (point))
 256             end
 257             (marker (make-marker))
 258             (val (get-text-property (point) prop)))
 259         (while (setq end (text-property-not-all begin (point-max) prop val))
 260           (move-marker marker end)
 261           (funcall func val begin (marker-position marker))
 262           (setq begin (marker-position marker)
 263                 val (get-text-property marker prop)))
 264         (if (< begin (point-max))
 265             (funcall func val begin (point-max)))))))
 266
 267 (put 'enriched-map-property-regions 'lisp-indent-hook 1)
 268
 269 (defun enriched-insert-indentation (&optional from to)
 270   "Indent and justify each line in the region."
 271   (save-excursion
 272     (save-restriction
 273       (if to (narrow-to-region (point-min) to))
 274       (goto-char (or from (point-min)))
 275       (if (not (bolp)) (forward-line 1))
 276       (while (not (eobp))
 277         (if (eolp)
 278             nil ; skip blank lines
 279           (indent-to (current-left-margin))
 280           (justify-current-line t nil t))
 281         (forward-line 1)))))
 282
 283 ;;;
 284 ;;; Encoding Files
 285 ;;;
 286
 287 ;;;###autoload
 288 (defun enriched-encode (from to orig-buf)
 289   (if enriched-verbose (message "Enriched: encoding document..."))
 290   (save-restriction
 291     (narrow-to-region from to)
 292     (delete-to-left-margin)
 293     (unjustify-region)
 294     (goto-char from)
 295     (format-replace-strings '(("<" . "<<")))
 296     (format-insert-annotations
 297      (format-annotate-region from (point-max) enriched-translations
 298                              'enriched-make-annotation enriched-ignore))
 299     (goto-char from)
 300     (insert (if (stringp enriched-initial-annotation)
 301                 enriched-initial-annotation
 302               (save-excursion
 303                 ;; Eval this in the buffer we are annotating.  This
 304                 ;; fixes a bug which was saving incorrect File-Width
 305                 ;; information, since we were looking at local
 306                 ;; variables in the wrong buffer.
 307                 (if orig-buf (set-buffer orig-buf))
 308                 (funcall enriched-initial-annotation))))
 309     (enriched-map-property-regions 'hard
 310       (lambda (v b e)
 311         (if (and v (= ?\n (char-after b)))
 312             (progn (goto-char b) (insert "\n"))))
 313       (point) nil)
 314     (if enriched-verbose (message nil))
 315     ;; Return new end.
 316     (point-max)))
 317
 318 (defun enriched-make-annotation (name positive)
 319   "Format an annotation called NAME.
 320 If POSITIVE is non-nil, this is the opening annotation, if nil, this is the
 321 matching close."
 322   (cond ((stringp name)
 323          (format enriched-annotation-format (if positive "" "/") name))
 324         ;; Otherwise it is an annotation with parameters, represented as a list
 325         (positive
 326          (let ((item (car name))
 327                (params (cdr name)))
 328            (concat (format enriched-annotation-format "" item)
 329                    (mapconcat (lambda (i) (concat "<param>" i "</param>"))
 330                               params ""))))
 331         (t (format enriched-annotation-format "/" (car name)))))
 332
 333 (defun enriched-encode-other-face (old new)
 334   "Generate annotations for random face change.
 335 One annotation each for foreground color, background color, italic, etc."
 336   (cons (and old (enriched-face-ans old))
 337         (and new (enriched-face-ans new))))
 338
 339 (defun enriched-face-ans (face)
 340   "Return annotations specifying FACE."
 341   (cond ((string-match "^fg:" (symbol-name face))
 342          (list (list "x-color" (substring (symbol-name face) 3))))
 343         ((string-match "^bg:" (symbol-name face))
 344          (list (list "x-bg-color" (substring (symbol-name face) 3))))
 345         ((let* ((fg (face-foreground face))
 346                 (bg (face-background face))
 347                 (props (face-font face t))
 348                 (ans (cdr (format-annotate-single-property-change
 349                            'face nil props enriched-translations))))
 350            (if fg (setq ans (cons (list "x-color" fg) ans)))
 351            (if bg (setq ans (cons (list "x-bg-color" bg) ans)))
 352            ans))))
 353
 354 ;;;
 355 ;;; Decoding files
 356 ;;;
 357
 358 ;;;###autoload
 359 (defun enriched-decode (from to)
 360   (if enriched-verbose (message "Enriched: decoding document..."))
 361   (use-hard-newlines 1 'never)
 362   (save-excursion
 363     (save-restriction
 364       (narrow-to-region from to)
 365       (goto-char from)
 366
 367       ;; Deal with header
 368       (let ((file-width (enriched-get-file-width)))
 369         (enriched-remove-header)
 370
 371         ;; Deal with newlines
 372         (while (search-forward-regexp "\n\n+" nil t)
 373           (if (current-justification)
 374               (delete-char -1))
 375           (set-hard-newline-properties (match-beginning 0) (point)))
 376
 377         ;; Translate annotations
 378         (format-deannotate-region from (point-max) enriched-translations
 379                                   'enriched-next-annotation)
 380
 381         ;; Indent or fill the buffer
 382         (cond (file-width               ; File was filled to this width
 383                (setq fill-column file-width)
 384                (if enriched-verbose (message "Indenting..."))
 385                (enriched-insert-indentation))
 386               (t                        ; File was not filled.
 387                (if enriched-verbose (message "Filling paragraphs..."))
 388                (fill-region (point-min) (point-max))))
 389         (if enriched-verbose (message nil)))
 390       (point-max))))
 391
 392 (defun enriched-next-annotation ()
 393   "Find and return next text/enriched annotation.
 394 Any \"<<\" strings encountered are converted to \"<\".
 395 Return value is \(begin end name positive-p), or nil if none was found."
 396   (while (and (search-forward "<" nil 1)
 397               (progn (goto-char (match-beginning 0))
 398                      (not (looking-at enriched-annotation-regexp))))
 399     (forward-char 1)
 400     (if (= ?< (char-after (point)))
 401         (delete-char 1)
 402       ;; A single < that does not start an annotation is an error,
 403       ;; which we note and then ignore.
 404       (message "Warning: malformed annotation in file at %s"
 405                (1- (point)))))
 406   (if (not (eobp))
 407       (let* ((beg (match-beginning 0))
 408              (end (match-end 0))
 409              (name (downcase (buffer-substring
 410                               (match-beginning 2) (match-end 2))))
 411              (pos (not (match-beginning 1))))
 412         (list beg end name pos))))
 413
 414 (defun enriched-get-file-width ()
 415   "Look for file width information on this line."
 416   (save-excursion
 417     (if (search-forward "Text-Width: " (+ (point) 1000) t)
 418         (read (current-buffer)))))
 419
 420 (defun enriched-remove-header ()
 421   "Remove file-format header at point."
 422   (while (looking-at "^[-A-Za-z]+: .*\n")
 423     (delete-region (point) (match-end 0)))
 424   (if (looking-at "^\n")
 425       (delete-char 1)))
 426
 427 (defun enriched-decode-foreground (from to color)
 428   (let ((face (intern (concat "fg:" color))))
 429     (cond ((internal-find-face face))
 430           ((and window-system (facemenu-get-face face)))
 431           (window-system
 432            (message "Warning: color \"%s\" is not defined." color))
 433           ((make-face face)
 434            (message "Warning: Color \"%s\" can't be displayed." color)))
 435     (list from to 'face face)))
 436
 437 (defun enriched-decode-background (from to color)
 438   (let ((face (intern (concat "bg:" color))))
 439     (cond ((internal-find-face face))
 440           ((and window-system (facemenu-get-face face)))
 441           (window-system
 442            (message "Warning: color \"%s\" is not defined." color))
 443           ((make-face face)
 444            (message "Warning: Color \"%s\" can't be displayed." color)))
 445     (list from to 'face face)))
 446
 447 ;;; enriched.el ends here