cgit.sxemacs.org Git - packages/blob - xemacs-packages/xemacs-base/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 ;; Adapted-by: Mike Sperber <sperber@informatik.uni-tuebingen.de>
   7 ;; Maintainer: XEmacs Development Team
   8 ;; Keywords: wp, faces
   9
  10 ;; This file is part of XEmacs.
  11
  12 ;; XEmacs is free software; you can redistribute it and/or modify it
  13 ;; under the terms of the GNU General Public License as published by
  14 ;; the Free Software Foundation; either version 2, or (at your option)
  15 ;; any later version.
  16
  17 ;; XEmacs is distributed in the hope that it will be useful, but
  18 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  20 ;; General Public License for more details.
  21
  22 ;; You should have received a copy of the GNU General Public License
  23 ;; along with XEmacs; see the file COPYING.  If not, write to the Free
  24 ;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
  25 ;; 02111-1307, USA.
  26
  27 ;;; Synched up with: FSF 20.2.
  28
  29 ;;; Commentary:
  30
  31 ;; This file implements reading, editing, and saving files with
  32 ;; text-properties such as faces, levels of indentation, and true line
  33 ;; breaks distinguished from newlines just used to fit text into the window.
  34
  35 ;; The file format used is the MIME text/enriched format, which is a
  36 ;; standard format defined in internet RFC 1563.  All standard annotations
  37 ;; are supported except for <smaller> and <bigger>, which are currently not
  38 ;; possible to display.
  39
  40 ;; A separate file, enriched.doc, contains further documentation and other
  41 ;; important information about this code.  It also serves as an example
  42 ;; file in text/enriched format.  It should be in the etc directory of your
  43 ;; emacs distribution.
  44
  45 ;;; TODO for the XEmacs port:
  46 ;;
  47 ;; Currently XEmacs does not support default-text-properties.  The
  48 ;; original enriched.el uses this to set the left-margin,
  49 ;; right-margin, and justification properties to 'front-sticky.
  50 ;; If you know the Right Way to fix this, contact
  51 ;; Mike Sperber <sperber@informatik.uni-tuebingen.de>.
  52
  53 ;;; Code:
  54
  55 (provide 'enriched)
  56
  57 (defun-when-void put-display-table (range value display-table)
  58   "Set the value for char RANGE to VALUE in DISPLAY-TABLE.  "
  59   (ecase (type-of display-table)
  60     (vector
  61      (aset display-table range value))
  62     (char-table
  63      (put-char-table range value display-table))))
  64
  65 ;;;
  66 ;;; Variables controlling the display
  67 ;;;
  68
  69 (defgroup enriched nil
  70   "Read and save files in text/enriched format"
  71   :group 'wp)
  72
  73 (defcustom enriched-verbose t
  74   "*If non-nil, give status messages when reading and writing files."
  75   :type 'boolean
  76   :group 'enriched)
  77
  78 ;;;
  79 ;;; Set up faces & display table
  80 ;;;
  81
  82 ;; Emacs doesn't have a "fixed" face by default, since all faces currently
  83 ;; have to be fixed-width.  So we just pick one that looks different from the
  84 ;; default.
  85 (defface fixed
  86   '((t (:bold t)))
  87   "Face used for text that must be shown in fixed width.
  88 Currently, emacs can only display fixed-width fonts, but this may change.
  89 This face is used for text specifically marked as fixed-width, for example
  90 in text/enriched files."
  91   :group 'enriched)
  92
  93 (defface excerpt
  94   '((t (:italic t)))
  95   "Face used for text that is an excerpt from another document.
  96 This is used in enriched-mode for text explicitly marked as an excerpt."
  97   :group 'enriched)
  98
  99 (defconst enriched-display-table
 100   ;; XEmacs change.
 101   ;; This is actually broken in several ways:
 102   ;;
 103   ;; -- It's not used; search for the string enriched-display-table in this
 104   ;;    file, it's commented out.
 105   ;; -- Its initialisation reflects the frame width at the time this file
 106   ;;    was loaded, not the current frame width in the frame being displayed.
 107   ;; -- (A general problem with display tables:) the visible cursor won't
 108   ;;    ever display on it.
 109   ;;
 110   ;; There are other more important and more interesting things to fix at
 111   ;; the moment, though.
 112   (let ((table (make-display-table)))
 113     (put-display-table ?\f (make-string (max (1- (frame-width)) 24) ?-)
 114                        table)
 115     table))
 116
 117 (defconst enriched-par-props '(left-margin right-margin justification)
 118   "Text-properties that usually apply to whole paragraphs.
 119 These are set front-sticky everywhere except at hard newlines.")
 120
 121 ;;;
 122 ;;; Variables controlling the file format
 123 ;;;   (bidirectional)
 124
 125 (defconst enriched-initial-annotation
 126   (lambda ()
 127     (format "Content-Type: text/enriched\nText-Width: %d\n\n"
 128             fill-column))
 129   "What to insert at the start of a text/enriched file.
 130 If this is a string, it is inserted.  If it is a list, it should be a lambda
 131 expression, which is evaluated to get the string to insert.")
 132
 133 (defconst enriched-annotation-format "<%s%s>"
 134   "General format of enriched-text annotations.")
 135
 136 (defconst enriched-annotation-regexp "<\\(/\\)?\\([-A-za-z0-9]+\\)>"
 137   "Regular expression matching enriched-text annotations.")
 138
 139 (defconst enriched-translations
 140   '((face          (bold-italic "bold" "italic")
 141                    (bold        "bold")
 142                    (italic      "italic")
 143                    (underline   "underline")
 144                    (fixed       "fixed")
 145                    (excerpt     "excerpt")
 146                    (default     )
 147                    (nil         enriched-encode-other-face))
 148     (left-margin   (4           "indent"))
 149     (right-margin  (4           "indentright"))
 150     (justification (none        "nofill")
 151                    (right       "flushright")
 152                    (left        "flushleft")
 153                    (full        "flushboth")
 154                    (center      "center"))
 155     (PARAMETER     (t           "param")) ; Argument of preceding annotation
 156     ;; The following are not part of the standard:
 157     (FUNCTION      (enriched-decode-foreground "x-color")
 158                    (enriched-decode-background "x-bg-color")
 159                    ;; XEmacs addition
 160                    (facemenu-make-larger "bigger")
 161                    (facemenu-make-smaller "smaller"))
 162     (read-only     (t           "x-read-only"))
 163     (unknown       (nil         format-annotate-value))
 164 ;   (font-size     (2           "bigger")       ; unimplemented
 165 ;                  (-2          "smaller"))
 166 )
 167   "List of definitions of text/enriched annotations.
 168 See `format-annotate-region' and `format-deannotate-region' for the definition
 169 of this structure.")
 170
 171 (defconst enriched-ignore
 172   '(front-sticky rear-nonsticky hard)
 173   "Properties that are OK to ignore when saving text/enriched files.
 174 Any property that is neither on this list nor dealt with by
 175 `enriched-translations' will generate a warning.")
 176
 177 ;;; Internal variables
 178
 179 (defvar enriched-mode nil
 180   "True if Enriched mode is in use.")
 181 (make-variable-buffer-local 'enriched-mode)
 182
 183 (if (not (assq 'enriched-mode minor-mode-alist))
 184     (setq minor-mode-alist
 185           (cons '(enriched-mode " Enriched")
 186                 minor-mode-alist)))
 187
 188 (defcustom enriched-mode-hook nil
 189   "Functions to run when entering Enriched mode.
 190 If you set variables in this hook, you should arrange for them to be restored
 191 to their old values if you leave Enriched mode.  One way to do this is to add
 192 them and their old values to `enriched-old-bindings'."
 193   :type 'hook
 194   :group 'enriched)
 195
 196 (defvar enriched-old-bindings nil
 197   "Store old variable values that we change when entering mode.
 198 The value is a list of \(VAR VALUE VAR VALUE...).")
 199 (make-variable-buffer-local 'enriched-old-bindings)
 200
 201 ;;;
 202 ;;; Define the mode
 203 ;;;
 204
 205 ;;;###autoload
 206 (defun enriched-mode (&optional arg)
 207   "Minor mode for editing text/enriched files.
 208 These are files with embedded formatting information in the MIME standard
 209 text/enriched format.
 210 Turning the mode on runs `enriched-mode-hook'.
 211
 212 More information about Enriched mode is available in the file
 213 etc/enriched.doc  in the Emacs distribution directory.
 214
 215 Commands:
 216
 217 \\<enriched-mode-map>\\{enriched-mode-map}"
 218   (interactive "P")
 219   (let ((mod (buffer-modified-p)))
 220     (cond ((or (<= (prefix-numeric-value arg) 0)
 221                (and enriched-mode (null arg)))
 222            ;; Turn mode off
 223            (setq enriched-mode nil)
 224            (setq buffer-file-format (delq 'text/enriched buffer-file-format))
 225            ;; restore old variable values
 226            (while enriched-old-bindings
 227              (funcall 'set (car enriched-old-bindings)
 228                       (car (cdr enriched-old-bindings)))
 229              (setq enriched-old-bindings (cdr (cdr enriched-old-bindings)))))
 230
 231           (enriched-mode nil)           ; Mode already on; do nothing.
 232
 233           (t (setq enriched-mode t)     ; Turn mode on
 234              (add-to-list 'buffer-file-format 'text/enriched)
 235              ;; Save old variable values before we change them.
 236              ;; These will be restored if we exit Enriched mode.
 237              (setq enriched-old-bindings
 238                    ;; XEmacs change
 239                    (list ; 'buffer-display-table buffer-display-table
 240                          'indent-line-function indent-line-function
 241                          'default-text-properties default-text-properties))
 242              (make-local-variable 'indent-line-function)
 243              (make-local-variable 'default-text-properties)
 244              (setq indent-line-function 'indent-to-left-margin
 245                    ;; XEmacs change
 246                    ;; buffer-display-table  enriched-display-table
 247                    )
 248              (use-hard-newlines 1 nil)
 249              (let ((sticky (plist-get default-text-properties 'front-sticky))
 250                    (p enriched-par-props))
 251                (while p
 252                  (add-to-list 'sticky (car p))
 253                  (setq p (cdr p)))
 254                (if sticky
 255                    (setq default-text-properties
 256                          (plist-put default-text-properties
 257                                     'front-sticky sticky))))
 258              (run-hooks 'enriched-mode-hook)))
 259     (set-buffer-modified-p mod)
 260     ;; XEmacs change
 261     (redraw-modeline)))
 262
 263 ;;;
 264 ;;; Keybindings
 265 ;;;
 266
 267 (defvar enriched-mode-map nil
 268   "Keymap for Enriched mode.")
 269
 270 (if (null enriched-mode-map)
 271     (fset 'enriched-mode-map (setq enriched-mode-map (make-sparse-keymap))))
 272
 273 (if (not (assq 'enriched-mode minor-mode-map-alist))
 274     (setq minor-mode-map-alist
 275           (cons (cons 'enriched-mode enriched-mode-map)
 276                 minor-mode-map-alist)))
 277
 278 (define-key enriched-mode-map "\C-a" 'beginning-of-line-text)
 279 (define-key enriched-mode-map "\C-m" 'reindent-then-newline-and-indent)
 280 (define-key enriched-mode-map "\C-j" 'reindent-then-newline-and-indent)
 281 (define-key enriched-mode-map "\M-j" 'facemenu-justification-menu)
 282 (define-key enriched-mode-map "\M-S" 'set-justification-center)
 283 (define-key enriched-mode-map "\C-x\t" 'increase-left-margin)
 284 (define-key enriched-mode-map "\C-c\C-l" 'set-left-margin)
 285 (define-key enriched-mode-map "\C-c\C-r" 'set-right-margin)
 286
 287 ;;;
 288 ;;; Some functions dealing with text-properties, especially indentation
 289 ;;;
 290
 291 (defun enriched-map-property-regions (prop func &optional from to)
 292   "Apply a function to regions of the buffer based on a text property.
 293 For each contiguous region of the buffer for which the value of PROPERTY is
 294 eq, the FUNCTION will be called.  Optional arguments FROM and TO specify the
 295 region over which to scan.
 296
 297 The specified function receives three arguments: the VALUE of the property in
 298 the region, and the START and END of each region."
 299   (save-excursion
 300     (save-restriction
 301       (if to (narrow-to-region (point-min) to))
 302       (goto-char (or from (point-min)))
 303       (let ((begin (point))
 304             end
 305             (marker (make-marker))
 306             (val (get-text-property (point) prop)))
 307         (while (setq end (text-property-not-all begin (point-max) prop val))
 308           (move-marker marker end)
 309           (funcall func val begin (marker-position marker))
 310           (setq begin (marker-position marker)
 311                 val (get-text-property marker prop)))
 312         (if (< begin (point-max))
 313             (funcall func val begin (point-max)))))))
 314
 315 (put 'enriched-map-property-regions 'lisp-indent-hook 1)
 316
 317 (defun enriched-insert-indentation (&optional from to)
 318   "Indent and justify each line in the region."
 319   (save-excursion
 320     (save-restriction
 321       (if to (narrow-to-region (point-min) to))
 322       (goto-char (or from (point-min)))
 323       (if (not (bolp)) (forward-line 1))
 324       (while (not (eobp))
 325         (if (eolp)
 326             nil ; skip blank lines
 327           (indent-to (current-left-margin))
 328           (justify-current-line t nil t))
 329         (forward-line 1)))))
 330
 331 ;;;
 332 ;;; Encoding Files
 333 ;;;
 334
 335 ;;;###autoload
 336 (defun enriched-encode (from to &optional orig-buf)
 337   (if enriched-verbose (message "Enriched: encoding document..."))
 338   (save-restriction
 339     (narrow-to-region from to)
 340     (delete-to-left-margin)
 341     (unjustify-region)
 342     (goto-char from)
 343     (format-replace-strings '(("<" . "<<")))
 344     (format-insert-annotations
 345      (format-annotate-region from (point-max) enriched-translations
 346                              'enriched-make-annotation enriched-ignore))
 347     (goto-char from)
 348     (insert (if (stringp enriched-initial-annotation)
 349                 enriched-initial-annotation
 350               (save-excursion
 351                 ;; Eval this in the buffer we are annotating.  This
 352                 ;; fixes a bug which was saving incorrect File-Width
 353                 ;; information, since we were looking at local
 354                 ;; variables in the wrong buffer.
 355                 (if orig-buf (set-buffer orig-buf))
 356                 (funcall enriched-initial-annotation))))
 357     (enriched-map-property-regions 'hard
 358       (lambda (v b e)
 359         (if (and v (= ?\n (char-after b)))
 360             (progn (goto-char b) (insert "\n"))))
 361       (point) nil)
 362     (if enriched-verbose (message nil))
 363     ;; Return new end.
 364     (point-max)))
 365
 366 (defun enriched-make-annotation (name positive)
 367   "Format an annotation called NAME.
 368 If POSITIVE is non-nil, this is the opening annotation, if nil, this is the
 369 matching close."
 370   (cond ((stringp name)
 371          (format enriched-annotation-format (if positive "" "/") name))
 372         ;; Otherwise it is an annotation with parameters, represented as a list
 373         (positive
 374          (let ((item (car name))
 375                (params (cdr name)))
 376            (concat (format enriched-annotation-format "" item)
 377                    (mapconcat (lambda (i) (concat "<param>" i "</param>"))
 378                               params ""))))
 379         (t (format enriched-annotation-format "/" (car name)))))
 380
 381 ;; XEmacs addition
 382 (defun enriched-face-strip-size (face)
 383   "Create a symbol from the name of FACE devoid of size information,
 384 i.e. remove all larger- and smaller- prefixes."
 385   (let* ((face-symbol (face-name face))
 386          (face-name (symbol-name face-symbol))
 387          (old-name face-name)
 388          new-name)
 389     (while
 390         (not (string-equal
 391               old-name
 392               (setq new-name (replace-in-string old-name "^larger-" ""))))
 393       (setq old-name new-name))
 394
 395     (while
 396         (not (string-equal
 397               old-name
 398               (setq new-name (replace-in-string old-name "^smaller-" ""))))
 399       (setq old-name new-name))
 400
 401     (if (string-equal new-name face-name)
 402         face-symbol
 403       (intern new-name))))
 404
 405 (defun enriched-encode-other-face (old new)
 406   "Generate annotations for random face change.
 407 One annotation each for foreground color, background color, italic, etc."
 408   (cons (and old (enriched-face-ans old))
 409         (and new (enriched-face-ans new))))
 410
 411 (defun enriched-face-ans (face)
 412   "Return annotations specifying FACE."
 413   ;; XEmacs change (entire body of this function)
 414   (let ((face-name (symbol-name face)))
 415     (cond ((string-match "^fg:" face-name)
 416            (list (list "x-color" (substring face-name 3))))
 417           ((string-match "^bg:" face-name)
 418            (list (list "x-bg-color" (substring face-name 3))))
 419           ((or (string-match "^larger-" face-name)
 420                (string-match "^smaller-" face-name))
 421            (cdr (format-annotate-single-property-change
 422                  'face nil (enriched-face-strip-size face)
 423                  enriched-translations)))
 424           (t
 425            (let* ((fg (and (not (eq (face-foreground face)
 426                                     (face-foreground 'default)))
 427                            (color-name (face-foreground face))))
 428                   (bg (and (not (eq (face-background face)
 429                                     (face-background 'default)))
 430                            (color-name (face-background face))))
 431                   (ans '()))
 432              (if fg (setq ans (cons (list "x-color" fg) ans)))
 433              (if bg (setq ans (cons (list "x-bg-color" bg) ans)))
 434              ans)))))
 435
 436 ;; XEmacs addition
 437 (defun enriched-size-annotation (n annotation)
 438   "Generate ANNOTATION N times."
 439   (let ((l '()))
 440     (while (not (zerop n))
 441       (setq l (cons annotation l))
 442       (setq n (1- n)))
 443     l))
 444
 445 ;; XEmacs addition
 446 (defun enriched-encode-size (old new)
 447   "Return annotations specifying SIZE."
 448   (let* ((old (or old 0))
 449          (new (or new 0))
 450          (closing-annotation
 451           (enriched-size-annotation (abs old)
 452                                     (if (> old 0) "bigger" "smaller")))
 453          (opening-annotation
 454           (enriched-size-annotation (abs new)
 455                                     (if (> new 0) "bigger" "smaller"))))
 456     (cons closing-annotation
 457           opening-annotation)))
 458
 459 ;;;
 460 ;;; Decoding files
 461 ;;;
 462
 463 ;;;###autoload
 464 (defun enriched-decode (from to)
 465   (if enriched-verbose (message "Enriched: decoding document..."))
 466   (use-hard-newlines 1 'never)
 467   (save-excursion
 468     (save-restriction
 469       (narrow-to-region from to)
 470       (goto-char from)
 471
 472       ;; Deal with header
 473       (let ((file-width (enriched-get-file-width)))
 474         (enriched-remove-header)
 475
 476         ;; Deal with newlines
 477         (while (search-forward-regexp "\n\n+" nil t)
 478           (if (current-justification)
 479               (delete-char -1))
 480           (set-hard-newline-properties (match-beginning 0) (point)))
 481
 482         ;; Translate annotations
 483         (format-deannotate-region from (point-max) enriched-translations
 484                                   'enriched-next-annotation)
 485
 486         ;; Indent or fill the buffer
 487         (cond (file-width               ; File was filled to this width
 488                (setq fill-column file-width)
 489                (if enriched-verbose (message "Indenting..."))
 490                (enriched-insert-indentation))
 491               (t                        ; File was not filled.
 492                (if enriched-verbose (message "Filling paragraphs..."))
 493                (fill-region (point-min) (point-max))))
 494         (if enriched-verbose (message nil)))
 495       (point-max))))
 496
 497 (defun enriched-next-annotation ()
 498   "Find and return next text/enriched annotation.
 499 Any \"<<\" strings encountered are converted to \"<\".
 500 Return value is \(begin end name positive-p), or nil if none was found."
 501   (while (and (search-forward "<" nil 1)
 502               (progn (goto-char (match-beginning 0))
 503                      (not (looking-at enriched-annotation-regexp))))
 504     (forward-char 1)
 505     (if (= ?< (char-after (point)))
 506         (delete-char 1)
 507       ;; A single < that does not start an annotation is an error,
 508       ;; which we note and then ignore.
 509       (message "Warning: malformed annotation in file at %s"
 510                (1- (point)))))
 511   (if (not (eobp))
 512       (let* ((beg (match-beginning 0))
 513              (end (match-end 0))
 514              (name (downcase (buffer-substring
 515                               (match-beginning 2) (match-end 2))))
 516              (pos (not (match-beginning 1))))
 517         (list beg end name pos))))
 518
 519 (defun enriched-get-file-width ()
 520   "Look for file width information on this line."
 521   (save-excursion
 522     (if (search-forward "Text-Width: " (+ (point) 1000) t)
 523         (read (current-buffer)))))
 524
 525 (defun enriched-remove-header ()
 526   "Remove file-format header at point."
 527   (while (looking-at "^[-A-Za-z]+: .*\n")
 528     (delete-region (point) (match-end 0)))
 529   (if (looking-at "^\n")
 530       (delete-char 1)))
 531
 532 (defun enriched-decode-foreground (from to &optional color)
 533   ;; XEmacs change
 534   (let ((face (facemenu-get-face (intern (concat "fg:" color)))))
 535     (if (not face)
 536         (progn
 537           (make-face face)
 538           (message "Warning: Color \"%s\" can't be displayed." color)))
 539     (list from to 'face face)))
 540
 541 (defun enriched-decode-background (from to &optional color)
 542   ;; XEmacs change
 543   (let ((face (facemenu-get-face (intern (concat "bg:" color)))))
 544     (if (not face)
 545         (progn
 546           (make-face face)
 547           (message "Warning: Color \"%s\" can't be displayed." color)))
 548     (list from to 'face face)))
 549
 550 ;;; enriched.el ends here