lisp/enriched.el

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