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

   1 ;;; enriched.el --- read and save files in text/enriched format
   2
   3 ;; Copyright (C) 1994, 1995, 1996, 2001, 2002, 2003, 2004,
   4 ;;   2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
   5
   6 ;; Author: Boris Goldowsky <boris@gnu.org>
   7 ;; Keywords: wp, faces
   8
   9 ;; This file is part of GNU Emacs.
  10
  11 ;; GNU Emacs is free software: you can redistribute it and/or modify
  12 ;; it under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation, either version 3 of the License, or
  14 ;; (at your option) any later version.
  15
  16 ;; GNU Emacs is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;; GNU General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  23
  24 ;;; Commentary:
  25
  26 ;; This file implements reading, editing, and saving files with
  27 ;; text-properties such as faces, levels of indentation, and true line
  28 ;; breaks distinguished from newlines just used to fit text into the window.
  29
  30 ;; The file format used is the MIME text/enriched format, which is a
  31 ;; standard format defined in internet RFC 1563.  All standard annotations
  32 ;; are supported except for <smaller> and <bigger>, which are currently not
  33 ;; possible to display.
  34
  35 ;; A separate file, enriched.doc, contains further documentation and other
  36 ;; important information about this code.  It also serves as an example
  37 ;; file in text/enriched format.  It should be in the etc directory of your
  38 ;; emacs distribution.
  39
  40 ;;; Code:
  41
  42 (provide 'enriched)
  43
  44 ;;;
  45 ;;; Variables controlling the display
  46 ;;;
  47
  48 (defgroup enriched nil
  49   "Read and save files in text/enriched format."
  50   :group 'wp)
  51
  52 (defcustom enriched-verbose t
  53   "*If non-nil, give status messages when reading and writing files."
  54   :type 'boolean
  55   :group 'enriched)
  56
  57 ;;;
  58 ;;; Set up faces & display table
  59 ;;;
  60
  61 ;; Emacs doesn't have a "fixed" face by default, since all faces currently
  62 ;; have to be fixed-width.  So we just pick one that looks different from the
  63 ;; default.
  64 (defface fixed
  65   '((t (:weight bold)))
  66   "Face used for text that must be shown in fixed width.
  67 Currently, Emacs can only display fixed-width fonts, but this may change.
  68 This face is used for text specifically marked as fixed-width, for example
  69 in text/enriched files."
  70   :group 'enriched)
  71
  72 (defface excerpt
  73   '((t (:slant italic)))
  74   "Face used for text that is an excerpt from another document.
  75 This is used in Enriched mode for text explicitly marked as an excerpt."
  76   :group 'enriched)
  77
  78 (defconst enriched-display-table (or (copy-sequence standard-display-table)
  79                                      (make-display-table)))
  80 (aset enriched-display-table ?\f (make-vector (1- (frame-width)) ?-))
  81
  82 (defconst enriched-par-props '(left-margin right-margin justification)
  83   "Text-properties that usually apply to whole paragraphs.
  84 These are set front-sticky everywhere except at hard newlines.")
  85
  86 ;;;
  87 ;;; Variables controlling the file format
  88 ;;;   (bidirectional)
  89
  90 (defconst enriched-initial-annotation
  91   (lambda ()
  92     (format "Content-Type: text/enriched\nText-Width: %d\n\n"
  93             fill-column))
  94   "What to insert at the start of a text/enriched file.
  95 If this is a string, it is inserted.  If it is a list, it should be a lambda
  96 expression, which is evaluated to get the string to insert.")
  97
  98 (defconst enriched-annotation-format "<%s%s>"
  99   "General format of enriched-text annotations.")
 100
 101 (defconst enriched-annotation-regexp "<\\(/\\)?\\([-A-Za-z0-9]+\\)>"
 102   "Regular expression matching enriched-text annotations.")
 103
 104 (defvar enriched-translations
 105   '((face          (bold-italic "bold" "italic")
 106                    (bold        "bold")
 107                    (italic      "italic")
 108                    (underline   "underline")
 109                    (fixed       "fixed")
 110                    (excerpt     "excerpt")
 111                    (default     )
 112                    (nil         enriched-encode-other-face))
 113     (left-margin   (4           "indent"))
 114     (right-margin  (4           "indentright"))
 115     (justification (none        "nofill")
 116                    (right       "flushright")
 117                    (left        "flushleft")
 118                    (full        "flushboth")
 119                    (center      "center"))
 120     (PARAMETER     (t           "param")) ; Argument of preceding annotation
 121     ;; The following are not part of the standard:
 122     (FUNCTION      (enriched-decode-foreground "x-color")
 123                    (enriched-decode-background "x-bg-color")
 124                    (enriched-decode-display-prop "x-display"))
 125     (read-only     (t           "x-read-only"))
 126     (display       (nil         enriched-handle-display-prop))
 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 (defcustom enriched-mode-hook nil
 144   "Hook run after entering/leaving Enriched mode.
 145 If you set variables in this hook, you should arrange for them to be restored
 146 to their old values if you leave Enriched mode.  One way to do this is to add
 147 them and their old values to `enriched-old-bindings'."
 148   :type 'hook
 149   :group 'enriched)
 150
 151 (defvar enriched-old-bindings nil
 152   "Store old variable values that we change when entering mode.
 153 The value is a list of \(VAR VALUE VAR VALUE...).")
 154 (make-variable-buffer-local 'enriched-old-bindings)
 155
 156 ;; The next variable is buffer local if and only if Enriched mode is
 157 ;; enabled.  The buffer local value records whether
 158 ;; `default-text-properties' should remain buffer local when disabling
 159 ;; Enriched mode.  For technical reasons, the default value should be t.
 160 (defvar enriched-default-text-properties-local-flag t)
 161
 162 ;; Technical internal variable.  Bound to t if `enriched-mode' is
 163 ;; being rerun by a major mode to allow it to restore buffer-local
 164 ;; variables and to correctly update `enriched-old-bindings'.
 165 (defvar enriched-rerun-flag nil)
 166
 167 ;;;
 168 ;;; Define the mode
 169 ;;;
 170
 171 (put 'enriched-mode 'permanent-local t)
 172 ;;;###autoload
 173 (define-minor-mode enriched-mode
 174   "Minor mode for editing text/enriched files.
 175 These are files with embedded formatting information in the MIME standard
 176 text/enriched format.
 177 Turning the mode on or off runs `enriched-mode-hook'.
 178
 179 More information about Enriched mode is available in the file
 180 etc/enriched.doc in the Emacs distribution directory.
 181
 182 Commands:
 183
 184 \\{enriched-mode-map}"
 185   :group 'enriched :lighter " Enriched"
 186   (cond ((null enriched-mode)
 187          ;; Turn mode off
 188          (setq buffer-file-format (delq 'text/enriched buffer-file-format))
 189          ;; restore old variable values
 190          (while enriched-old-bindings
 191            (set (pop enriched-old-bindings) (pop enriched-old-bindings)))
 192          (unless enriched-default-text-properties-local-flag
 193            (kill-local-variable 'default-text-properties))
 194          (kill-local-variable 'enriched-default-text-properties-local-flag)
 195          (unless use-hard-newlines (use-hard-newlines 0)))
 196
 197         ((and (memq 'text/enriched buffer-file-format)
 198               (not enriched-rerun-flag))
 199          ;; Mode already on; do nothing.
 200          nil)
 201
 202         (t                              ; Turn mode on
 203          (add-to-list 'buffer-file-format 'text/enriched)
 204          ;; Save old variable values before we change them.
 205          ;; These will be restored if we exit Enriched mode.
 206          (setq enriched-old-bindings
 207                (list 'buffer-display-table buffer-display-table
 208                      'default-text-properties default-text-properties
 209                      'use-hard-newlines use-hard-newlines))
 210          (make-local-variable 'enriched-default-text-properties-local-flag)
 211          (setq enriched-default-text-properties-local-flag
 212                (local-variable-p 'default-text-properties))
 213          (make-local-variable 'default-text-properties)
 214          (setq buffer-display-table  enriched-display-table)
 215          (use-hard-newlines 1 (if enriched-rerun-flag 'never nil))
 216          (let ((sticky (plist-get default-text-properties 'front-sticky))
 217                (p enriched-par-props))
 218            (dolist (x p)
 219              (add-to-list 'sticky x))
 220            (if sticky
 221                (setq default-text-properties
 222                      (plist-put default-text-properties
 223                                 'front-sticky sticky)))))))
 224
 225 (defun enriched-before-change-major-mode ()
 226   (when enriched-mode
 227     (while enriched-old-bindings
 228       (set (pop enriched-old-bindings) (pop enriched-old-bindings)))))
 229
 230 (add-hook 'change-major-mode-hook 'enriched-before-change-major-mode)
 231
 232 (defun enriched-after-change-major-mode ()
 233   (when enriched-mode
 234     (let ((enriched-rerun-flag t))
 235       (enriched-mode 1))))
 236
 237 (add-hook 'after-change-major-mode-hook 'enriched-after-change-major-mode)
 238
 239 ;;;
 240 ;;; Keybindings
 241 ;;;
 242
 243 (defvar enriched-mode-map nil
 244   "Keymap for Enriched mode.")
 245
 246 (if (null enriched-mode-map)
 247     (fset 'enriched-mode-map (setq enriched-mode-map (make-sparse-keymap))))
 248
 249 (if (not (assq 'enriched-mode minor-mode-map-alist))
 250     (setq minor-mode-map-alist
 251           (cons (cons 'enriched-mode enriched-mode-map)
 252                 minor-mode-map-alist)))
 253
 254 (define-key enriched-mode-map [remap move-beginning-of-line] 'beginning-of-line-text)
 255 (define-key enriched-mode-map "\C-m" 'reindent-then-newline-and-indent)
 256 (define-key enriched-mode-map
 257   [remap newline-and-indent] 'reindent-then-newline-and-indent)
 258 (define-key enriched-mode-map "\M-j" 'facemenu-justification-menu)
 259 (define-key enriched-mode-map "\M-S" 'set-justification-center)
 260 (define-key enriched-mode-map "\C-x\t" 'increase-left-margin)
 261 (define-key enriched-mode-map "\C-c[" 'set-left-margin)
 262 (define-key enriched-mode-map "\C-c]" 'set-right-margin)
 263
 264 ;;;
 265 ;;; Some functions dealing with text-properties, especially indentation
 266 ;;;
 267
 268 (defun enriched-map-property-regions (prop func &optional from to)
 269   "Apply a function to regions of the buffer based on a text property.
 270 For each contiguous region of the buffer for which the value of PROPERTY is
 271 eq, the FUNCTION will be called.  Optional arguments FROM and TO specify the
 272 region over which to scan.
 273
 274 The specified function receives three arguments: the VALUE of the property in
 275 the region, and the START and END of each region."
 276   (save-excursion
 277     (save-restriction
 278       (if to (narrow-to-region (point-min) to))
 279       (goto-char (or from (point-min)))
 280       (let ((begin (point))
 281             end
 282             (marker (make-marker))
 283             (val (get-text-property (point) prop)))
 284         (while (setq end (text-property-not-all begin (point-max) prop val))
 285           (move-marker marker end)
 286           (funcall func val begin (marker-position marker))
 287           (setq begin (marker-position marker)
 288                 val (get-text-property marker prop)))
 289         (if (< begin (point-max))
 290             (funcall func val begin (point-max)))))))
 291
 292 (put 'enriched-map-property-regions 'lisp-indent-hook 1)
 293
 294 (defun enriched-insert-indentation (&optional from to)
 295   "Indent and justify each line in the region."
 296   (save-excursion
 297     (save-restriction
 298       (if to (narrow-to-region (point-min) to))
 299       (goto-char (or from (point-min)))
 300       (if (not (bolp)) (forward-line 1))
 301       (while (not (eobp))
 302         (if (eolp)
 303             nil ; skip blank lines
 304           (indent-to (current-left-margin))
 305           (justify-current-line t nil t))
 306         (forward-line 1)))))
 307
 308 ;;;
 309 ;;; Encoding Files
 310 ;;;
 311
 312 ;;;###autoload
 313 (defun enriched-encode (from to orig-buf)
 314   (if enriched-verbose (message "Enriched: encoding document..."))
 315   (let ((inhibit-read-only t))
 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                 (save-excursion
 329                   ;; Eval this in the buffer we are annotating.  This
 330                   ;; fixes a bug which was saving incorrect File-Width
 331                   ;; information, since we were looking at local
 332                   ;; variables in the wrong buffer.
 333                   (if orig-buf (set-buffer orig-buf))
 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 (internal-ann positive)
 345   "Format an annotation INTERNAL-ANN.
 346 INTERNAL-ANN may be a string, for a flag, or a list of the form (PARAM VALUE).
 347 If POSITIVE is non-nil, this is the opening annotation;
 348 if nil, the matching close."
 349   (cond ((stringp internal-ann)
 350          (format enriched-annotation-format (if positive "" "/") internal-ann))
 351         ;; Otherwise it is an annotation with parameters, represented as a list
 352         (positive
 353          (let ((item (car internal-ann))
 354                (params (cdr internal-ann)))
 355            (concat (format enriched-annotation-format "" item)
 356                    (mapconcat (lambda (i) (concat "<param>" i "</param>"))
 357                               params ""))))
 358         (t (format enriched-annotation-format "/" (car internal-ann)))))
 359
 360 (defun enriched-encode-other-face (old new)
 361   "Generate annotations for random face change.
 362 One annotation each for foreground color, background color, italic, etc."
 363   (cons (and old (enriched-face-ans old))
 364         (and new (enriched-face-ans new))))
 365
 366 (defun enriched-face-ans (face)
 367   "Return annotations specifying FACE.
 368 FACE may be a list of faces instead of a single face;
 369 it can also be anything allowed as an element of a list
 370 which can be the value of the `face' text property."
 371   (cond ((and (consp face) (eq (car face) 'foreground-color))
 372          (list (list "x-color" (cdr face))))
 373         ((and (consp face) (eq (car face) 'background-color))
 374          (list (list "x-bg-color" (cdr face))))
 375         ((and (listp face) (eq (car face) :foreground))
 376          (list (list "x-color" (cadr face))))
 377         ((and (listp face) (eq (car face) :background))
 378          (list (list "x-bg-color" (cadr face))))
 379         ((listp face)
 380          (apply 'append (mapcar 'enriched-face-ans face)))
 381         ((let* ((fg (face-attribute face :foreground))
 382                 (bg (face-attribute face :background))
 383                 (props (face-font face t))
 384                 (ans (cdr (format-annotate-single-property-change
 385                            'face nil props enriched-translations))))
 386            (unless (eq fg 'unspecified)
 387              (setq ans (cons (list "x-color" fg) ans)))
 388            (unless (eq bg 'unspecified)
 389              (setq ans (cons (list "x-bg-color" bg) ans)))
 390            ans))))
 391
 392 ;;;
 393 ;;; Decoding files
 394 ;;;
 395
 396 ;;;###autoload
 397 (defun enriched-decode (from to)
 398   (if enriched-verbose (message "Enriched: decoding document..."))
 399   (use-hard-newlines 1 'never)
 400   (save-excursion
 401     (save-restriction
 402       (narrow-to-region from to)
 403       (goto-char from)
 404
 405       ;; Deal with header
 406       (let ((file-width (enriched-get-file-width)))
 407         (enriched-remove-header)
 408
 409         ;; Deal with newlines
 410         (while (search-forward-regexp "\n\n+" nil t)
 411           (if (current-justification)
 412               (delete-char -1))
 413           (set-hard-newline-properties (match-beginning 0) (point)))
 414
 415         ;; Translate annotations
 416         (format-deannotate-region from (point-max) enriched-translations
 417                                   'enriched-next-annotation)
 418
 419         ;; Indent or fill the buffer
 420         (cond (file-width               ; File was filled to this width
 421                (setq fill-column file-width)
 422                (if enriched-verbose (message "Indenting..."))
 423                (enriched-insert-indentation))
 424               (t                        ; File was not filled.
 425                (if enriched-verbose (message "Filling paragraphs..."))
 426                (fill-region (point-min) (point-max))))
 427         (if enriched-verbose (message nil)))
 428       (point-max))))
 429
 430 (defun enriched-next-annotation ()
 431   "Find and return next text/enriched annotation.
 432 Any \"<<\" strings encountered are converted to \"<\".
 433 Return value is \(begin end name positive-p), or nil if none was found."
 434   (while (and (search-forward "<" nil 1)
 435               (progn (goto-char (match-beginning 0))
 436                      (not (looking-at enriched-annotation-regexp))))
 437     (forward-char 1)
 438     (if (= ?< (char-after (point)))
 439         (delete-char 1)
 440       ;; A single < that does not start an annotation is an error,
 441       ;; which we note and then ignore.
 442       (message "Warning: malformed annotation in file at %s"
 443                (1- (point)))))
 444   (if (not (eobp))
 445       (let* ((beg (match-beginning 0))
 446              (end (match-end 0))
 447              (name (downcase (buffer-substring
 448                               (match-beginning 2) (match-end 2))))
 449              (pos (not (match-beginning 1))))
 450         (list beg end name pos))))
 451
 452 (defun enriched-get-file-width ()
 453   "Look for file width information on this line."
 454   (save-excursion
 455     (if (search-forward "Text-Width: " (+ (point) 1000) t)
 456         (read (current-buffer)))))
 457
 458 (defun enriched-remove-header ()
 459   "Remove file-format header at point."
 460   (while (looking-at "^[-A-Za-z]+: .*\n")
 461     (delete-region (point) (match-end 0)))
 462   (if (looking-at "^\n")
 463       (delete-char 1)))
 464
 465 (defun enriched-decode-foreground (from to &optional color)
 466   (if color
 467       (list from to 'face (list ':foreground color))
 468     (message "Warning: no color specified for <x-color>")
 469     nil))
 470
 471 (defun enriched-decode-background (from to &optional color)
 472   (if color
 473       (list from to 'face (list ':background color))
 474     (message "Warning: no color specified for <x-bg-color>")
 475     nil))
 476 \f
 477 ;;; Handling the `display' property.
 478
 479
 480 (defun enriched-handle-display-prop (old new)
 481   "Return a list of annotations for a change in the `display' property.
 482 OLD is the old value of the property, NEW is the new value.  Value
 483 is a list `(CLOSE OPEN)', where CLOSE is a list of annotations to
 484 close and OPEN a list of annotations to open.  Each of these lists
 485 has the form `(ANNOTATION PARAM ...)'."
 486   (let ((annotation "x-display")
 487         (param (prin1-to-string (or old new))))
 488     (if (null old)
 489         (cons nil (list (list annotation param)))
 490       (cons (list (list annotation param)) nil))))
 491
 492 (defun enriched-decode-display-prop (start end &optional param)
 493   "Decode a `display' property for text between START and END.
 494 PARAM is a `<param>' found for the property.
 495 Value is a list `(START END SYMBOL VALUE)' with START and END denoting
 496 the range of text to assign text property SYMBOL with value VALUE."
 497   (let ((prop (when (stringp param)
 498                 (condition-case ()
 499                     (car (read-from-string param))
 500                   (error nil)))))
 501     (unless prop
 502       (message "Warning: invalid <x-display> parameter %s" param))
 503     (list start end 'display prop)))
 504
 505 ;; arch-tag: 05cae488-3fea-45cd-ac29-5b02cb64e42b
 506 ;;; enriched.el ends here