lisp/enriched.el

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