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