comparison lisp/modes/enriched.el @ 215:1f0dabaa0855 r20-4b6

Import from CVS: tag r20-4b6
author cvs
date Mon, 13 Aug 2007 10:07:35 +0200
parents e45d5e7c476e
children
comparison
equal deleted inserted replaced
214:c5d88c05e1e9 215:1f0dabaa0855
1 ;;; enriched.el --- read and save files in text/enriched format 1 ;;; enriched.el --- read and save files in text/enriched format
2 ;; Copyright (c) 1994, 1995 Free Software Foundation, Inc. 2
3 ;; Copyright (c) 1994, 1995, 1996 Free Software Foundation, Inc.
3 4
4 ;; XEmacs version: Mike Sperber <sperber@informatik.uni-tuebingen.de> 5 ;; XEmacs version: Mike Sperber <sperber@informatik.uni-tuebingen.de>
5 ;; Original author: Boris Goldowsky <boris@gnu.ai.mit.edu> 6 ;; Original author: Boris Goldowsky <boris@gnu.ai.mit.edu>
6 ;; Keywords: wp, faces 7 ;; Keywords: wp, faces
7 8
20 ;; You should have received a copy of the GNU General Public License 21 ;; You should have received a copy of the GNU General Public License
21 ;; along with XEmacs; see the file COPYING. If not, write to the Free 22 ;; along with XEmacs; see the file COPYING. If not, write to the Free
22 ;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 23 ;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
23 ;; 02111-1307, USA. 24 ;; 02111-1307, USA.
24 25
25 ;;; Synched up with: FSF 19.34. 26 ;;; Synched up with: FSF 20.2.
26 27
27 ;;; Commentary: 28 ;;; Commentary:
28 ;; 29
29 ;; This file implements reading, editing, and saving files with 30 ;; This file implements reading, editing, and saving files with
30 ;; text-properties such as faces, levels of indentation, and true line 31 ;; text-properties such as faces, levels of indentation, and true line
31 ;; breaks distinguished from newlines just used to fit text into the 32 ;; breaks distinguished from newlines just used to fit text into the window.
32 ;; window. 33
33 ;;
34 ;; The file format used is the MIME text/enriched format, which is a 34 ;; The file format used is the MIME text/enriched format, which is a
35 ;; standard format defined in internet RFC 1563. All standard 35 ;; standard format defined in internet RFC 1563. All standard annotations
36 ;; annotations are supported. 36 ;; are supported except for <smaller> and <bigger>, which are currently not
37 ;; 37 ;; possible to display.
38 ;; A separate file, enriched.doc, contains further documentation and 38
39 ;; other important information about this code. It also serves as an 39 ;; A separate file, enriched.doc, contains further documentation and other
40 ;; example file in text/enriched format. It should be in the etc 40 ;; important information about this code. It also serves as an example
41 ;; directory of your emacs distribution. 41 ;; file in text/enriched format. It should be in the etc directory of your
42 ;; 42 ;; emacs distribution.
43
43 ;;; TODO for the XEmacs port: 44 ;;; TODO for the XEmacs port:
44 ;; 45 ;;
45 ;; Currently XEmacs does not support default-text-properties. The 46 ;; Currently XEmacs does not support default-text-properties. The
46 ;; original enriched.el uses this to set the left-margin, 47 ;; original enriched.el uses this to set the left-margin,
47 ;; right-margin, and justification properties to 'front-sticky. 48 ;; right-margin, and justification properties to 'front-sticky.
48 ;; If you know the Right Way to fix this, contact 49 ;; If you know the Right Way to fix this, contact
49 ;; Mike Sperber <sperber@informatik.uni-tuebingen.de>. 50 ;; Mike Sperber <sperber@informatik.uni-tuebingen.de>.
50 51
52 ;;; Code:
53
51 (provide 'enriched) 54 (provide 'enriched)
52 (if window-system (require 'facemenu))
53 55
54 ;;; 56 ;;;
55 ;;; Variables controlling the display 57 ;;; Variables controlling the display
56 ;;; 58 ;;;
57 59
58 (defgroup enriched nil 60 (defgroup enriched nil
59 "Read and save files in text/enriched format" 61 "Read and save files in text/enriched format"
60 :group 'wp) 62 :group 'wp)
61
62 63
63 (defcustom enriched-verbose t 64 (defcustom enriched-verbose t
64 "*If non-nil, give status messages when reading and writing files." 65 "*If non-nil, give status messages when reading and writing files."
65 :type 'boolean 66 :type 'boolean
66 :group 'enriched) 67 :group 'enriched)
67 68
68 (defcustom enriched-default-right-margin 10 69 ;;;
69 "*Default amount of space to leave on the right edge of the screen. 70 ;;; Set up faces & display table
70 This can be increased inside text by changing the 'right-margin text property. 71 ;;;
71 Measured in character widths. If the screen is narrower than this, it is 72
72 assumed to be 0." 73 ;; Emacs doesn't have a "fixed" face by default, since all faces currently
73 :type 'integer 74 ;; have to be fixed-width. So we just pick one that looks different from the
75 ;; default.
76 (defface fixed
77 '((t (:bold t)))
78 "Face used for text that must be shown in fixed width.
79 Currently, emacs can only display fixed-width fonts, but this may change.
80 This face is used for text specifically marked as fixed-width, for example
81 in text/enriched files."
74 :group 'enriched) 82 :group 'enriched)
75 83
76 (defcustom enriched-fill-after-visiting t 84 (defface excerpt
77 "If t, fills paragraphs when reading in enriched documents. 85 '((t (:italic t)))
78 If nil, only fills when you explicitly request it. If the value is 'ask, then 86 "Face used for text that is an excerpt from another document.
79 it will query you whether to fill. 87 This is used in enriched-mode for text explicitly marked as an excerpt."
80 Filling is never done if the current text-width is the same as the value
81 stored in the file."
82 :type '(choice (const nil) (const t) (const ask))
83 :group 'enriched) 88 :group 'enriched)
84 89
85 ;;; 90 (defconst enriched-display-table
86 ;;; Set up faces & display table 91 ;; XEmacs change
87 ;;; 92 ;; (or (copy-sequence standard-display-table)
88 93 ;; (make-display-table)))
89 ;; XEmacs change (Can't cheat, we have variable width fonts) 94 (make-display-table))
90 (if (not (find-face 'fixed)) 95 (aset enriched-display-table ?\f (make-vector (1- (frame-width)) ?-))
91 (copy-face 'default 'fixed))
92
93 (if (not (find-face 'excerpt))
94 (copy-face 'italic 'excerpt))
95
96 (defconst enriched-display-table (make-display-table))
97 (aset enriched-display-table ?\f (make-string (1- (frame-width)) ?-))
98 96
99 (defconst enriched-par-props '(left-margin right-margin justification) 97 (defconst enriched-par-props '(left-margin right-margin justification)
100 "Text-properties that usually apply to whole paragraphs. 98 "Text-properties that usually apply to whole paragraphs.
101 These are set front-sticky everywhere except at hard newlines.") 99 These are set front-sticky everywhere except at hard newlines.")
102 100
105 ;;; (bidirectional) 103 ;;; (bidirectional)
106 104
107 (defconst enriched-initial-annotation 105 (defconst enriched-initial-annotation
108 (lambda () 106 (lambda ()
109 (format "Content-Type: text/enriched\nText-Width: %d\n\n" 107 (format "Content-Type: text/enriched\nText-Width: %d\n\n"
110 (enriched-text-width))) 108 fill-column))
111 "What to insert at the start of a text/enriched file. 109 "What to insert at the start of a text/enriched file.
112 If this is a string, it is inserted. If it is a list, it should be a lambda 110 If this is a string, it is inserted. If it is a list, it should be a lambda
113 expression, which is evaluated to get the string to insert.") 111 expression, which is evaluated to get the string to insert.")
114 112
115 (defconst enriched-annotation-format "<%s%s>" 113 (defconst enriched-annotation-format "<%s%s>"
178 (defvar enriched-old-bindings nil 176 (defvar enriched-old-bindings nil
179 "Store old variable values that we change when entering mode. 177 "Store old variable values that we change when entering mode.
180 The value is a list of \(VAR VALUE VAR VALUE...).") 178 The value is a list of \(VAR VALUE VAR VALUE...).")
181 (make-variable-buffer-local 'enriched-old-bindings) 179 (make-variable-buffer-local 'enriched-old-bindings)
182 180
183 (defvar enriched-text-width nil)
184 (make-variable-buffer-local 'enriched-text-width)
185
186 ;;; 181 ;;;
187 ;;; Define the mode 182 ;;; Define the mode
188 ;;; 183 ;;;
189 184
190 ;;;###autoload 185 ;;;###autoload
214 (setq enriched-old-bindings (cdr (cdr enriched-old-bindings))))) 209 (setq enriched-old-bindings (cdr (cdr enriched-old-bindings)))))
215 210
216 (enriched-mode nil) ; Mode already on; do nothing. 211 (enriched-mode nil) ; Mode already on; do nothing.
217 212
218 (t (setq enriched-mode t) ; Turn mode on 213 (t (setq enriched-mode t) ; Turn mode on
219 (if (not (memq 'text/enriched buffer-file-format)) 214 (add-to-list 'buffer-file-format 'text/enriched)
220 (setq buffer-file-format
221 (cons 'text/enriched buffer-file-format)))
222 ;; Save old variable values before we change them. 215 ;; Save old variable values before we change them.
223 ;; These will be restored if we exit Enriched mode. 216 ;; These will be restored if we exit Enriched mode.
224 (setq enriched-old-bindings 217 (setq enriched-old-bindings
225 ;; XEmacs change 218 ;; XEmacs change
226 (list ; 'buffer-display-table buffer-display-table 219 (list ; 'buffer-display-table buffer-display-table
227 'indent-line-function indent-line-function 220 'indent-line-function indent-line-function
228 'use-hard-newlines use-hard-newlines
229 'default-text-properties default-text-properties)) 221 'default-text-properties default-text-properties))
230 (make-local-variable 'indent-line-function) 222 (make-local-variable 'indent-line-function)
231 (make-local-variable 'use-hard-newlines)
232 (make-local-variable 'default-text-properties) 223 (make-local-variable 'default-text-properties)
233 (setq indent-line-function 'indent-to-left-margin 224 (setq indent-line-function 'indent-to-left-margin
234 ;; XEmacs change 225 ;; XEmacs change
235 ;; buffer-display-table enriched-display-table 226 ;; buffer-display-table enriched-display-table
236 use-hard-newlines t) 227 )
228 (use-hard-newlines 1 nil)
237 (let ((sticky (plist-get default-text-properties 'front-sticky)) 229 (let ((sticky (plist-get default-text-properties 'front-sticky))
238 (p enriched-par-props)) 230 (p enriched-par-props))
239 (while p 231 (while p
240 (if (not (memq (car p) sticky)) 232 (add-to-list 'sticky (car p))
241 (setq sticky (cons (car p) sticky)))
242 (setq p (cdr p))) 233 (setq p (cdr p)))
243 (if sticky 234 (if sticky
244 (setq default-text-properties 235 (setq default-text-properties
245 (plist-put default-text-properties 236 (plist-put default-text-properties
246 'front-sticky sticky)))) 237 'front-sticky sticky))))
315 nil ; skip blank lines 306 nil ; skip blank lines
316 (indent-to (current-left-margin)) 307 (indent-to (current-left-margin))
317 (justify-current-line t nil t)) 308 (justify-current-line t nil t))
318 (forward-line 1))))) 309 (forward-line 1)))))
319 310
320 (defun enriched-text-width ()
321 "The width of unindented text in this window, in characters.
322 This is the width of the window minus `enriched-default-right-margin'."
323 (or enriched-text-width
324 (let ((ww (window-width)))
325 (setq enriched-text-width
326 (if (> ww enriched-default-right-margin)
327 (- ww enriched-default-right-margin)
328 ww)))))
329
330 ;;; 311 ;;;
331 ;;; Encoding Files 312 ;;; Encoding Files
332 ;;; 313 ;;;
333 314
334 ;;;###autoload 315 ;;;###autoload
335 (defun enriched-encode (from to) 316 (defun enriched-encode (from to &optional orig-buf)
336 (if enriched-verbose (message "Enriched: encoding document...")) 317 (if enriched-verbose (message "Enriched: encoding document..."))
337 (save-restriction 318 (save-restriction
338 (narrow-to-region from to) 319 (narrow-to-region from to)
339 (delete-to-left-margin) 320 (delete-to-left-margin)
340 (unjustify-region) 321 (unjustify-region)
344 (format-annotate-region from (point-max) enriched-translations 325 (format-annotate-region from (point-max) enriched-translations
345 'enriched-make-annotation enriched-ignore)) 326 'enriched-make-annotation enriched-ignore))
346 (goto-char from) 327 (goto-char from)
347 (insert (if (stringp enriched-initial-annotation) 328 (insert (if (stringp enriched-initial-annotation)
348 enriched-initial-annotation 329 enriched-initial-annotation
349 (funcall enriched-initial-annotation))) 330 (save-excursion
331 ;; Eval this in the buffer we are annotating. This
332 ;; fixes a bug which was saving incorrect File-Width
333 ;; information, since we were looking at local
334 ;; variables in the wrong buffer.
335 (if orig-buf (set-buffer orig-buf))
336 (funcall enriched-initial-annotation))))
350 (enriched-map-property-regions 'hard 337 (enriched-map-property-regions 'hard
351 (lambda (v b e) 338 (lambda (v b e)
352 (if (and v (= ?\n (char-after b))) 339 (if (and v (= ?\n (char-after b)))
353 (progn (goto-char b) (insert "\n")))) 340 (progn (goto-char b) (insert "\n"))))
354 (point) nil) 341 (point) nil)
454 ;;; 441 ;;;
455 442
456 ;;;###autoload 443 ;;;###autoload
457 (defun enriched-decode (from to) 444 (defun enriched-decode (from to)
458 (if enriched-verbose (message "Enriched: decoding document...")) 445 (if enriched-verbose (message "Enriched: decoding document..."))
446 (use-hard-newlines 1 'never)
459 (save-excursion 447 (save-excursion
460 (save-restriction 448 (save-restriction
461 (narrow-to-region from to) 449 (narrow-to-region from to)
462 (goto-char from) 450 (goto-char from)
463 (let ((file-width (enriched-get-file-width)) 451
464 (use-hard-newlines t)) 452 ;; Deal with header
453 (let ((file-width (enriched-get-file-width)))
465 (enriched-remove-header) 454 (enriched-remove-header)
466 455
467 ;; Deal with newlines 456 ;; Deal with newlines
468 (goto-char from)
469 (while (search-forward-regexp "\n\n+" nil t) 457 (while (search-forward-regexp "\n\n+" nil t)
470 (if (current-justification) 458 (if (current-justification)
471 (delete-char -1)) 459 (delete-char -1))
472 (put-text-property (match-beginning 0) (point) 'hard t) 460 (set-hard-newline-properties (match-beginning 0) (point)))
473 (put-text-property (match-beginning 0) (point) 'front-sticky nil))
474 461
475 ;; Translate annotations 462 ;; Translate annotations
476 (format-deannotate-region from (point-max) enriched-translations 463 (format-deannotate-region from (point-max) enriched-translations
477 'enriched-next-annotation) 464 'enriched-next-annotation)
478 465
479 ;; Fill paragraphs 466 ;; Indent or fill the buffer
480 (if (or (and file-width ; possible reasons not to fill: 467 (cond (file-width ; File was filled to this width
481 (= file-width (enriched-text-width))) ; correct wd. 468 (setq fill-column file-width)
482 (null enriched-fill-after-visiting) ; never fill 469 (if enriched-verbose (message "Indenting..."))
483 (and (eq 'ask enriched-fill-after-visiting) ; asked & declined 470 (enriched-insert-indentation))
484 (not (y-or-n-p "Re-fill for current display width? ")))) 471 (t ; File was not filled.
485 ;; Minimally, we have to insert indentation and justification. 472 (if enriched-verbose (message "Filling paragraphs..."))
486 (enriched-insert-indentation) 473 (fill-region (point-min) (point-max))))
487 (if enriched-verbose (message "Filling paragraphs...")) 474 (if enriched-verbose (message nil)))
488 (fill-region (point-min) (point-max))))
489 (if enriched-verbose (message nil))
490 (point-max)))) 475 (point-max))))
491 476
492 (defun enriched-next-annotation () 477 (defun enriched-next-annotation ()
493 "Find and return next text/enriched annotation. 478 "Find and return next text/enriched annotation.
494 Any \"<<\" strings encountered are converted to \"<\". 479 Any \"<<\" strings encountered are converted to \"<\".
522 (while (looking-at "^[-A-Za-z]+: .*\n") 507 (while (looking-at "^[-A-Za-z]+: .*\n")
523 (delete-region (point) (match-end 0))) 508 (delete-region (point) (match-end 0)))
524 (if (looking-at "^\n") 509 (if (looking-at "^\n")
525 (delete-char 1))) 510 (delete-char 1)))
526 511
527 (defun enriched-decode-foreground (from to color) 512 (defun enriched-decode-foreground (from to &optional color)
528 ;; XEmacs change 513 ;; XEmacs change
529 (let ((face (facemenu-get-face (intern (concat "fg:" color))))) 514 (let ((face (facemenu-get-face (intern (concat "fg:" color)))))
530 (if (not face) 515 (if (not face)
531 (progn 516 (progn
532 (make-face face) 517 (make-face face)
533 (message "Warning: Color \"%s\" can't be displayed." color))) 518 (message "Warning: Color \"%s\" can't be displayed." color)))
534 (list from to 'face face))) 519 (list from to 'face face)))
535 520
536 (defun enriched-decode-background (from to color) 521 (defun enriched-decode-background (from to &optional color)
537 ;; XEmacs change 522 ;; XEmacs change
538 (let ((face (facemenu-get-face (intern (concat "bg:" color))))) 523 (let ((face (facemenu-get-face (intern (concat "bg:" color)))))
539 (if (not face) 524 (if (not face)
540 (progn 525 (progn
541 (make-face face) 526 (make-face face)