*** empty log message ***
[emacs.git] / lisp / enriched.el
blob8f4bf4f0392d6a72efed535e11ad22d0a12a23ad
1 ;;; enriched.el --- read and save files in text/enriched format
3 ;; Copyright (c) 1994, 1995, 1996 Free Software Foundation, Inc.
5 ;; Author: Boris Goldowsky <boris@gnu.org>
6 ;; Keywords: wp, faces
8 ;; This file is part of GNU Emacs.
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.
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.
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.
25 ;;; Commentary:
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.
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.
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.
41 ;;; Code:
43 (provide 'enriched)
45 ;;;
46 ;;; Variables controlling the display
47 ;;;
49 (defgroup enriched nil
50 "Read and save files in text/enriched format"
51 :group 'wp)
53 (defcustom enriched-verbose t
54 "*If non-nil, give status messages when reading and writing files."
55 :type 'boolean
56 :group 'enriched)
58 ;;;
59 ;;; Set up faces & display table
60 ;;;
62 ;; Emacs doesn't have a "fixed" face by default, since all faces currently
63 ;; have to be fixed-width. So we just pick one that looks different from the
64 ;; default.
65 (defface fixed
66 '((t (:bold t)))
67 "Face used for text that must be shown in fixed width.
68 Currently, emacs can only display fixed-width fonts, but this may change.
69 This face is used for text specifically marked as fixed-width, for example
70 in text/enriched files."
71 :group 'enriched)
73 (defface excerpt
74 '((t (:italic t)))
75 "Face used for text that is an excerpt from another document.
76 This is used in enriched-mode for text explicitly marked as an excerpt."
77 :group 'enriched)
79 (defconst enriched-display-table (or (copy-sequence standard-display-table)
80 (make-display-table)))
81 (aset enriched-display-table ?\f (make-vector (1- (frame-width)) ?-))
83 (defconst enriched-par-props '(left-margin right-margin justification)
84 "Text-properties that usually apply to whole paragraphs.
85 These are set front-sticky everywhere except at hard newlines.")
87 ;;;
88 ;;; Variables controlling the file format
89 ;;; (bidirectional)
91 (defconst enriched-initial-annotation
92 (lambda ()
93 (format "Content-Type: text/enriched\nText-Width: %d\n\n"
94 fill-column))
95 "What to insert at the start of a text/enriched file.
96 If this is a string, it is inserted. If it is a list, it should be a lambda
97 expression, which is evaluated to get the string to insert.")
99 (defconst enriched-annotation-format "<%s%s>"
100 "General format of enriched-text annotations.")
102 (defconst enriched-annotation-regexp "<\\(/\\)?\\([-A-Za-z0-9]+\\)>"
103 "Regular expression matching enriched-text annotations.")
105 (defconst enriched-translations
106 '((face (bold-italic "bold" "italic")
107 (bold "bold")
108 (italic "italic")
109 (underline "underline")
110 (fixed "fixed")
111 (excerpt "excerpt")
112 (default )
113 (nil enriched-encode-other-face))
114 (left-margin (4 "indent"))
115 (right-margin (4 "indentright"))
116 (justification (none "nofill")
117 (right "flushright")
118 (left "flushleft")
119 (full "flushboth")
120 (center "center"))
121 (PARAMETER (t "param")) ; Argument of preceding annotation
122 ;; The following are not part of the standard:
123 (FUNCTION (enriched-decode-foreground "x-color")
124 (enriched-decode-background "x-bg-color")
125 (enriched-decode-display-prop "x-display"))
126 (read-only (t "x-read-only"))
127 (display (nil enriched-handle-display-prop))
128 (unknown (nil format-annotate-value))
129 ; (font-size (2 "bigger") ; unimplemented
130 ; (-2 "smaller"))
132 "List of definitions of text/enriched annotations.
133 See `format-annotate-region' and `format-deannotate-region' for the definition
134 of this structure.")
136 (defconst enriched-ignore
137 '(front-sticky rear-nonsticky hard)
138 "Properties that are OK to ignore when saving text/enriched files.
139 Any property that is neither on this list nor dealt with by
140 `enriched-translations' will generate a warning.")
142 ;;; Internal variables
144 (defvar enriched-mode nil
145 "True if Enriched mode is in use.")
146 (make-variable-buffer-local 'enriched-mode)
147 (put 'enriched-mode 'permanent-local t)
149 (if (not (assq 'enriched-mode minor-mode-alist))
150 (setq minor-mode-alist
151 (cons '(enriched-mode " Enriched")
152 minor-mode-alist)))
154 (defcustom enriched-mode-hook nil
155 "Functions to run when entering Enriched mode.
156 If you set variables in this hook, you should arrange for them to be restored
157 to their old values if you leave Enriched mode. One way to do this is to add
158 them and their old values to `enriched-old-bindings'."
159 :type 'hook
160 :group 'enriched)
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)
168 ;;; Define the mode
171 ;;;###autoload
172 (defun enriched-mode (&optional arg)
173 "Minor mode for editing text/enriched files.
174 These are files with embedded formatting information in the MIME standard
175 text/enriched format.
176 Turning the mode on runs `enriched-mode-hook'.
178 More information about Enriched mode is available in the file
179 etc/enriched.doc in the Emacs distribution directory.
181 Commands:
183 \\<enriched-mode-map>\\{enriched-mode-map}"
184 (interactive "P")
185 (let ((mod (buffer-modified-p)))
186 (cond ((or (<= (prefix-numeric-value arg) 0)
187 (and enriched-mode (null arg)))
188 ;; Turn mode off
189 (setq enriched-mode nil)
190 (setq buffer-file-format (delq 'text/enriched buffer-file-format))
191 ;; restore old variable values
192 (while enriched-old-bindings
193 (funcall 'set (car enriched-old-bindings)
194 (car (cdr enriched-old-bindings)))
195 (setq enriched-old-bindings (cdr (cdr enriched-old-bindings)))))
197 (enriched-mode nil) ; Mode already on; do nothing.
199 (t (setq enriched-mode t) ; Turn mode on
200 (add-to-list 'buffer-file-format 'text/enriched)
201 ;; Save old variable values before we change them.
202 ;; These will be restored if we exit Enriched mode.
203 (setq enriched-old-bindings
204 (list 'buffer-display-table buffer-display-table
205 'indent-line-function indent-line-function
206 'default-text-properties default-text-properties))
207 (make-local-variable 'indent-line-function)
208 (make-local-variable 'default-text-properties)
209 (setq indent-line-function 'indent-to-left-margin
210 buffer-display-table enriched-display-table)
211 (use-hard-newlines 1 nil)
212 (let ((sticky (plist-get default-text-properties 'front-sticky))
213 (p enriched-par-props))
214 (while p
215 (add-to-list 'sticky (car p))
216 (setq p (cdr p)))
217 (if sticky
218 (setq default-text-properties
219 (plist-put default-text-properties
220 'front-sticky sticky))))
221 (run-hooks 'enriched-mode-hook)))
222 (set-buffer-modified-p mod)
223 (force-mode-line-update)))
226 ;;; Keybindings
229 (defvar enriched-mode-map nil
230 "Keymap for Enriched mode.")
232 (if (null enriched-mode-map)
233 (fset 'enriched-mode-map (setq enriched-mode-map (make-sparse-keymap))))
235 (if (not (assq 'enriched-mode minor-mode-map-alist))
236 (setq minor-mode-map-alist
237 (cons (cons 'enriched-mode enriched-mode-map)
238 minor-mode-map-alist)))
240 (define-key enriched-mode-map "\C-a" 'beginning-of-line-text)
241 (define-key enriched-mode-map "\C-m" 'reindent-then-newline-and-indent)
242 (define-key enriched-mode-map "\C-j" 'reindent-then-newline-and-indent)
243 (define-key enriched-mode-map "\M-j" 'facemenu-justification-menu)
244 (define-key enriched-mode-map "\M-S" 'set-justification-center)
245 (define-key enriched-mode-map "\C-x\t" 'increase-left-margin)
246 (define-key enriched-mode-map "\C-c\C-l" 'set-left-margin)
247 (define-key enriched-mode-map "\C-c\C-r" 'set-right-margin)
250 ;;; Some functions dealing with text-properties, especially indentation
253 (defun enriched-map-property-regions (prop func &optional from to)
254 "Apply a function to regions of the buffer based on a text property.
255 For each contiguous region of the buffer for which the value of PROPERTY is
256 eq, the FUNCTION will be called. Optional arguments FROM and TO specify the
257 region over which to scan.
259 The specified function receives three arguments: the VALUE of the property in
260 the region, and the START and END of each region."
261 (save-excursion
262 (save-restriction
263 (if to (narrow-to-region (point-min) to))
264 (goto-char (or from (point-min)))
265 (let ((begin (point))
267 (marker (make-marker))
268 (val (get-text-property (point) prop)))
269 (while (setq end (text-property-not-all begin (point-max) prop val))
270 (move-marker marker end)
271 (funcall func val begin (marker-position marker))
272 (setq begin (marker-position marker)
273 val (get-text-property marker prop)))
274 (if (< begin (point-max))
275 (funcall func val begin (point-max)))))))
277 (put 'enriched-map-property-regions 'lisp-indent-hook 1)
279 (defun enriched-insert-indentation (&optional from to)
280 "Indent and justify each line in the region."
281 (save-excursion
282 (save-restriction
283 (if to (narrow-to-region (point-min) to))
284 (goto-char (or from (point-min)))
285 (if (not (bolp)) (forward-line 1))
286 (while (not (eobp))
287 (if (eolp)
288 nil ; skip blank lines
289 (indent-to (current-left-margin))
290 (justify-current-line t nil t))
291 (forward-line 1)))))
294 ;;; Encoding Files
297 ;;;###autoload
298 (defun enriched-encode (from to orig-buf)
299 (if enriched-verbose (message "Enriched: encoding document..."))
300 (save-restriction
301 (narrow-to-region from to)
302 (delete-to-left-margin)
303 (unjustify-region)
304 (goto-char from)
305 (format-replace-strings '(("<" . "<<")))
306 (format-insert-annotations
307 (format-annotate-region from (point-max) enriched-translations
308 'enriched-make-annotation enriched-ignore))
309 (goto-char from)
310 (insert (if (stringp enriched-initial-annotation)
311 enriched-initial-annotation
312 (save-excursion
313 ;; Eval this in the buffer we are annotating. This
314 ;; fixes a bug which was saving incorrect File-Width
315 ;; information, since we were looking at local
316 ;; variables in the wrong buffer.
317 (if orig-buf (set-buffer orig-buf))
318 (funcall enriched-initial-annotation))))
319 (enriched-map-property-regions 'hard
320 (lambda (v b e)
321 (if (and v (= ?\n (char-after b)))
322 (progn (goto-char b) (insert "\n"))))
323 (point) nil)
324 (if enriched-verbose (message nil))
325 ;; Return new end.
326 (point-max)))
328 (defun enriched-make-annotation (name positive)
329 "Format an annotation called NAME.
330 If POSITIVE is non-nil, this is the opening annotation, if nil, this is the
331 matching close."
332 (cond ((stringp name)
333 (format enriched-annotation-format (if positive "" "/") name))
334 ;; Otherwise it is an annotation with parameters, represented as a list
335 (positive
336 (let ((item (car name))
337 (params (cdr name)))
338 (concat (format enriched-annotation-format "" item)
339 (mapconcat (lambda (i) (concat "<param>" i "</param>"))
340 params ""))))
341 (t (format enriched-annotation-format "/" (car name)))))
343 (defun enriched-encode-other-face (old new)
344 "Generate annotations for random face change.
345 One annotation each for foreground color, background color, italic, etc."
346 (cons (and old (enriched-face-ans old))
347 (and new (enriched-face-ans new))))
349 (defun enriched-face-ans (face)
350 "Return annotations specifying FACE."
351 (cond ((and (consp face) (eq (car face) 'foreground-color))
352 (list (list "x-color" (cdr face))))
353 ((and (consp face) (eq (car face) 'background-color))
354 (list (list "x-bg-color" (cdr face))))
355 ((string-match "^fg:" (symbol-name face))
356 (list (list "x-color" (substring (symbol-name face) 3))))
357 ((string-match "^bg:" (symbol-name face))
358 (list (list "x-bg-color" (substring (symbol-name face) 3))))
359 ((let* ((fg (face-attribute face :foreground))
360 (bg (face-attribute face :background))
361 (props (face-font face t))
362 (ans (cdr (format-annotate-single-property-change
363 'face nil props enriched-translations))))
364 (unless (eq fg 'unspecified)
365 (setq ans (cons (list "x-color" fg) ans)))
366 (unless (eq bg 'unspecified)
367 (setq ans (cons (list "x-bg-color" bg) ans)))
368 ans))))
371 ;;; Decoding files
374 ;;;###autoload
375 (defun enriched-decode (from to)
376 (if enriched-verbose (message "Enriched: decoding document..."))
377 (use-hard-newlines 1 'never)
378 (save-excursion
379 (save-restriction
380 (narrow-to-region from to)
381 (goto-char from)
383 ;; Deal with header
384 (let ((file-width (enriched-get-file-width)))
385 (enriched-remove-header)
387 ;; Deal with newlines
388 (while (search-forward-regexp "\n\n+" nil t)
389 (if (current-justification)
390 (delete-char -1))
391 (set-hard-newline-properties (match-beginning 0) (point)))
393 ;; Translate annotations
394 (format-deannotate-region from (point-max) enriched-translations
395 'enriched-next-annotation)
397 ;; Indent or fill the buffer
398 (cond (file-width ; File was filled to this width
399 (setq fill-column file-width)
400 (if enriched-verbose (message "Indenting..."))
401 (enriched-insert-indentation))
402 (t ; File was not filled.
403 (if enriched-verbose (message "Filling paragraphs..."))
404 (fill-region (point-min) (point-max))))
405 (if enriched-verbose (message nil)))
406 (point-max))))
408 (defun enriched-next-annotation ()
409 "Find and return next text/enriched annotation.
410 Any \"<<\" strings encountered are converted to \"<\".
411 Return value is \(begin end name positive-p), or nil if none was found."
412 (while (and (search-forward "<" nil 1)
413 (progn (goto-char (match-beginning 0))
414 (not (looking-at enriched-annotation-regexp))))
415 (forward-char 1)
416 (if (= ?< (char-after (point)))
417 (delete-char 1)
418 ;; A single < that does not start an annotation is an error,
419 ;; which we note and then ignore.
420 (message "Warning: malformed annotation in file at %s"
421 (1- (point)))))
422 (if (not (eobp))
423 (let* ((beg (match-beginning 0))
424 (end (match-end 0))
425 (name (downcase (buffer-substring
426 (match-beginning 2) (match-end 2))))
427 (pos (not (match-beginning 1))))
428 (list beg end name pos))))
430 (defun enriched-get-file-width ()
431 "Look for file width information on this line."
432 (save-excursion
433 (if (search-forward "Text-Width: " (+ (point) 1000) t)
434 (read (current-buffer)))))
436 (defun enriched-remove-header ()
437 "Remove file-format header at point."
438 (while (looking-at "^[-A-Za-z]+: .*\n")
439 (delete-region (point) (match-end 0)))
440 (if (looking-at "^\n")
441 (delete-char 1)))
443 (defun enriched-decode-foreground (from to &optional color)
444 (let ((face (intern (concat "fg:" color))))
445 (cond ((null color)
446 (message "Warning: no color specified for <x-color>"))
447 ((facep face))
448 ((and (display-color-p) (facemenu-get-face face)))
449 ((make-face face)
450 (message "Warning: color `%s' can't be displayed" color)))
451 (list from to 'face face)))
453 (defun enriched-decode-background (from to &optional color)
454 (let ((face (intern (concat "bg:" color))))
455 (cond ((null color)
456 (message "Warning: no color specified for <x-bg-color>"))
457 ((facep face))
458 ((and (display-color-p) (facemenu-get-face face)))
459 ((make-face face)
460 (message "Warning: color `%s' can't be displayed" color)))
461 (list from to 'face face)))
465 ;;; Handling the `display' property.
468 (defun enriched-handle-display-prop (old new)
469 "Return a list of annotations for a change in the `display' property.
470 OLD is the old value of the property, NEW is the new value. Value
471 is a list `(CLOSE OPEN)', where CLOSE is a list of annotations to
472 close and OPEN a list of annotations to open. Each of these lists
473 has the form `(ANNOTATION PARAM ...)'."
474 (let ((annotation "x-display")
475 (param (prin1-to-string (or old new)))
476 close open)
477 (if (null old)
478 (list nil (list annotation param))
479 (list (list annotation param)))))
482 (defun enriched-decode-display-prop (start end &optional param)
483 "Decode a `display' property for text between START and END.
484 PARAM is a `<param>' found for the property.
485 Value is a list `(START END SYMBOL VALUE)' with START and END denoting
486 the range of text to assign text property SYMBOL with value VALUE "
487 (let ((prop (when (stringp param)
488 (condition-case ()
489 (car (read-from-string param))
490 (error nil)))))
491 (unless prop
492 (message "Warning: invalid <x-display> parameter %s" param))
493 (list start end 'display prop)))
496 ;;; enriched.el ends here