code.delx.au - gnu-emacs/blob - lisp/enriched.el

   1 ;;; enriched.el -- read and save files in text/enriched format
   2 ;; Copyright (c) 1994 Free Software Foundation
   3
   4 ;; Author: Boris Goldowsky <boris@cs.rochester.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)))
  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-properties   default-properties))
 213              (make-local-variable 'indent-line-function)
 214              (make-local-variable 'use-hard-newlines)
 215              (make-local-variable 'default-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 (get-text-property-default '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                    (put-text-property-default 'front-sticky sticky)))
 227              (run-hooks 'enriched-mode-hooks)))
 228     (set-buffer-modified-p mod)
 229     (force-mode-line-update)))
 230
 231 ;;;
 232 ;;; Keybindings
 233 ;;;
 234
 235 (defvar enriched-mode-map nil
 236   "Keymap for `enriched-mode'.")
 237
 238 (if (null enriched-mode-map)
 239     (fset 'enriched-mode-map (setq enriched-mode-map (make-sparse-keymap))))
 240
 241 (if (not (assq 'enriched-mode minor-mode-map-alist))
 242     (setq minor-mode-map-alist
 243           (cons (cons 'enriched-mode enriched-mode-map)
 244                 minor-mode-map-alist)))
 245
 246 (define-key enriched-mode-map "\C-a" 'beginning-of-line-text)
 247 (define-key enriched-mode-map "\C-m" 'reindent-then-newline-and-indent)
 248 (define-key enriched-mode-map "\C-j" 'reindent-then-newline-and-indent)
 249 (define-key enriched-mode-map "\M-j" 'facemenu-justification-menu)
 250 (define-key enriched-mode-map "\M-S" 'set-justification-center)
 251 (define-key enriched-mode-map "\C-x\t" 'increase-left-margin)
 252 (define-key enriched-mode-map "\C-c\C-l" 'set-left-margin)
 253 (define-key enriched-mode-map "\C-c\C-r" 'set-right-margin)
 254
 255 ;;;
 256 ;;; Some functions dealing with text-properties, especially indentation
 257 ;;;
 258
 259 (defun enriched-map-property-regions (prop func &optional from to)
 260   "Apply a function to regions of the buffer based on a text property.
 261 For each contiguous region of the buffer for which the value of PROPERTY is
 262 eq, the FUNCTION will be called.  Optional arguments FROM and TO specify the
 263 region over which to scan.
 264
 265 The specified function receives three arguments: the VALUE of the property in
 266 the region, and the START and END of each region."
 267   (save-excursion
 268     (save-restriction
 269       (if to (narrow-to-region (point-min) to))
 270       (goto-char (or from (point-min)))
 271       (let ((begin (point))
 272             end
 273             (marker (make-marker))
 274             (val (get-text-property (point) prop)))
 275         (while (setq end (text-property-not-all begin (point-max) prop val))
 276           (move-marker marker end)
 277           (funcall func val begin (marker-position marker))
 278           (setq begin (marker-position marker)
 279                 val (get-text-property marker prop)))
 280         (if (< begin (point-max))
 281             (funcall func val begin (point-max)))))))
 282
 283 (put 'enriched-map-property-regions 'lisp-indent-hook 1)
 284
 285 (defun enriched-insert-indentation (&optional from to)
 286   "Indent and justify each line in the region."
 287   (save-excursion
 288     (save-restriction
 289       (if to (narrow-to-region (point-min) to))
 290       (goto-char (or from (point-min)))
 291       (if (not (bolp)) (forward-line 1))
 292       (while (not (eobp))
 293         (if (eolp)
 294             nil ; skip blank lines
 295           (indent-to (current-left-margin))
 296           (justify-current-line t nil t))
 297         (forward-line 1)))))
 298
 299 (defun enriched-text-width ()
 300   "The width of unindented text in this window, in characters.
 301 This is the width of the window minus `enriched-default-right-margin'."
 302   (or enriched-text-width
 303       (let ((ww (window-width)))
 304         (setq enriched-text-width
 305               (if (> ww enriched-default-right-margin)
 306                   (- ww enriched-default-right-margin)
 307                 ww)))))
 308
 309 ;;;
 310 ;;; Encoding Files
 311 ;;;
 312
 313 ;;;###autoload
 314 (defun enriched-encode (from to)
 315   (if enriched-verbose (message "Enriched: encoding document..."))
 316   (save-restriction
 317     (narrow-to-region from to)
 318     (delete-to-left-margin)
 319     (unjustify-region)
 320     (goto-char from)
 321     (format-replace-strings '(("<" . "<<")))
 322     (format-insert-annotations
 323      (format-annotate-region from (point-max) enriched-translations
 324                              'enriched-make-annotation enriched-ignore))
 325     (goto-char from)
 326     (insert (if (stringp enriched-initial-annotation)
 327                 enriched-initial-annotation
 328               (funcall enriched-initial-annotation)))
 329     (enriched-map-property-regions 'hard
 330       (lambda (v b e)
 331         (if (and v (= ?\n (char-after b)))
 332             (progn (goto-char b) (insert "\n"))))
 333       (point) nil)
 334     (if enriched-verbose (message nil))
 335     ;; Return new end.
 336     (point-max)))
 337
 338 (defun enriched-make-annotation (name positive)
 339   "Format an annotation called NAME.
 340 If POSITIVE is non-nil, this is the opening annotation, if nil, this is the
 341 matching close."
 342   (cond ((stringp name)
 343          (format enriched-annotation-format (if positive "" "/") name))
 344         ;; Otherwise it is an annotation with parameters, represented as a list
 345         (positive
 346          (let ((item (car name))
 347                (params (cdr name)))
 348            (concat (format enriched-annotation-format "" item)
 349                    (mapconcat (lambda (i) (concat "<param>" i "</param>"))
 350                               params ""))))
 351         (t (format enriched-annotation-format "/" (car name)))))
 352
 353 (defun enriched-encode-other-face (old new)
 354   "Generate annotations for random face change.
 355 One annotation each for foreground color, background color, italic, etc."
 356   (cons (and old (enriched-face-ans old))
 357         (and new (enriched-face-ans new))))
 358
 359 (defun enriched-face-ans (face)
 360   "Return annotations specifying FACE."
 361   (cond ((string-match "^fg:" (symbol-name face))
 362          (list (list "x-color" (substring (symbol-name face) 3))))
 363         ((string-match "^bg:" (symbol-name face))
 364          (list (list "x-bg-color" (substring (symbol-name face) 3))))
 365         ((let* ((fg (face-foreground face))
 366                 (bg (face-background face))
 367                 (props (face-font face t))
 368                 (ans (cdr (format-annotate-single-property-change
 369                            'face nil props enriched-translations))))
 370            (if fg (setq ans (cons (list "x-color" fg) ans)))
 371            (if bg (setq ans (cons (list "x-bg-color" bg) ans)))
 372            ans))))
 373
 374 ;;;
 375 ;;; Decoding files
 376 ;;;
 377
 378 ;;;###autoload
 379 (defun enriched-decode (from to)
 380   (if enriched-verbose (message "Enriched: decoding document..."))
 381   (save-excursion
 382     (save-restriction
 383       (narrow-to-region from to)
 384       (goto-char from)
 385       (let ((file-width (enriched-get-file-width))
 386             (use-hard-newlines t))
 387         (enriched-remove-header)
 388
 389         ;; Deal with newlines
 390         (goto-char from)
 391         (while (search-forward-regexp "\n\n+" nil t)
 392           (if (current-justification)
 393               (delete-char -1))
 394           (put-text-property (match-beginning 0) (point) 'hard t)
 395           (put-text-property (match-beginning 0) (point) 'front-sticky nil))
 396
 397         ;; Translate annotations
 398         (format-deannotate-region from (point-max) enriched-translations
 399                                   'enriched-next-annotation)
 400
 401         ;; Fill paragraphs
 402         (if (or (and file-width         ; possible reasons not to fill:
 403                      (= file-width (enriched-text-width))) ; correct wd.
 404                 (null enriched-fill-after-visiting) ; never fill
 405                 (and (eq 'ask enriched-fill-after-visiting) ; asked & declined
 406                      (not (y-or-n-p "Re-fill for current display width? "))))
 407             ;; Minimally, we have to insert indentation and justification.
 408             (enriched-insert-indentation)
 409           (if enriched-verbose (message "Filling paragraphs..."))
 410           (fill-region (point-min) (point-max))))
 411       (if enriched-verbose (message nil))
 412       (point-max))))
 413
 414 (defun enriched-next-annotation ()
 415   "Find and return next text/enriched annotation.
 416 Any \"<<\" strings encountered are coverted to \"<\".
 417 Return value is \(begin end name positive-p), or nil if none was found."
 418   (while (and (search-forward "<" nil 1)
 419               (progn (goto-char (match-beginning 0))
 420                      (not (looking-at enriched-annotation-regexp))))
 421     (forward-char 1)
 422     (if (= ?< (char-after (point)))
 423         (delete-char 1)
 424       ;; A single < that does not start an annotation is an error,
 425       ;; which we note and then ignore.
 426       (message (format "Warning: malformed annotation in file at %s"
 427                        (1- (point))))))
 428   (if (not (eobp))
 429       (let* ((beg (match-beginning 0))
 430              (end (match-end 0))
 431              (name (downcase (buffer-substring
 432                               (match-beginning 2) (match-end 2))))
 433              (pos (not (match-beginning 1))))
 434         (list beg end name pos))))
 435
 436 (defun enriched-get-file-width ()
 437   "Look for file width information on this line."
 438   (save-excursion
 439     (if (search-forward "Text-Width: " (+ (point) 1000) t)
 440         (read (current-buffer)))))
 441
 442 (defun enriched-remove-header ()
 443   "Remove file-format header at point."
 444   (while (looking-at "^[-A-Za-z]+: .*\n")
 445     (delete-region (point) (match-end 0)))
 446   (if (looking-at "^\n")
 447       (delete-char 1)))
 448
 449 (defun enriched-decode-foreground (from to color)
 450   (let ((face (intern (concat "fg:" color))))
 451     (cond ((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 (defun enriched-decode-background (from to color)
 460   (let ((face (intern (concat "bg:" color))))
 461     (cond ((internal-find-face face))
 462           ((and window-system (facemenu-get-face face)))
 463           (window-system
 464            (message "Warning: color \"%s\" is not defined." color))
 465           ((make-face face)
 466            (message "Warning: Color \"%s\" can't be displayed." color)))
 467     (list from to 'face face)))
 468
 469 ;;; enriched.el ends here