Mercurial > hg > xemacs-beta

comparison lisp/modes/enriched.el @ 2:ac2d302a0011 r19-15b2

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-15b2
author cvs
date Mon, 13 Aug 2007 08:46:35 +0200
parents 376386a54a3c
children 34a5b81f86ba
comparison
equal deleted inserted replaced
1:c0c6a60d29db 2:ac2d302a0011
3 3
4 ;; XEmacs version: Mike Sperber <sperber@informatik.uni-tuebingen.de> 4 ;; XEmacs version: Mike Sperber <sperber@informatik.uni-tuebingen.de>
5 ;; Original author: Boris Goldowsky <boris@gnu.ai.mit.edu> 5 ;; Original author: Boris Goldowsky <boris@gnu.ai.mit.edu>
6 ;; Keywords: wp, faces 6 ;; Keywords: wp, faces
7 7
8 ;; This file is part of GNU Emacs. 8 ;; This file is part of XEmacs.
9 9
10 ;; GNU Emacs is free software; you can redistribute it and/or modify 10 ;; XEmacs is free software; you can redistribute it and/or modify it
11 ;; it under the terms of the GNU General Public License as published by 11 ;; under the terms of the GNU General Public License as published by
12 ;; the Free Software Foundation; either version 2, or (at your option) 12 ;; the Free Software Foundation; either version 2, or (at your option)
13 ;; any later version. 13 ;; any later version.
14 ;; 14
15 ;; GNU Emacs is distributed in the hope that it will be useful, 15 ;; XEmacs is distributed in the hope that it will be useful, but
16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 16 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
18 ;; GNU General Public License for more details. 18 ;; General Public License for more details.
19 ;; 19
20 ;; You should have received a copy of the GNU General Public License 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 21 ;; along with XEmacs; see the file COPYING. If not, write to the Free
22 ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. 22 ;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
23 23 ;; 02111-1307, USA.
24 ;;; Synched up with: FSF 19.30. 24
25 ;;; Synched up with: FSF 19.34.
25 26
26 ;;; Commentary: 27 ;;; Commentary:
27 ;; 28 ;;
28 ;; This file implements reading, editing, and saving files with 29 ;; This file implements reading, editing, and saving files with
29 ;; text-properties such as faces, levels of indentation, and true line breaks 30 ;; text-properties such as faces, levels of indentation, and true line
30 ;; distinguished from newlines just used to fit text into the window. 31 ;; breaks distinguished from newlines just used to fit text into the
32 ;; window.
31 ;; 33 ;;
32 ;; 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
33 ;; standard format defined in internet RFC 1563. All standard 35 ;; standard format defined in internet RFC 1563. All standard
34 ;; annotations are supported. 36 ;; annotations are supported.
35 ;; 37 ;;
36 ;; A separate file, enriched.doc, contains further documentation and other 38 ;; A separate file, enriched.doc, contains further documentation and
37 ;; important information about this code. It also serves as an example file 39 ;; other important information about this code. It also serves as an
38 ;; in text/enriched format. It should be in the etc directory of your emacs 40 ;; example file in text/enriched format. It should be in the etc
39 ;; distribution. 41 ;; directory of your emacs distribution.
40 ;; 42 ;;
41 ;;; TODO for the XEmacs port: 43 ;;; TODO for the XEmacs port:
42 ;; 44 ;;
43 ;; Currently XEmacs does not support default-text-properties. The 45 ;; Currently XEmacs does not support default-text-properties. The
44 ;; original enriched.el uses this to set the left-margin, 46 ;; original enriched.el uses this to set the left-margin,
45 ;; right-margin, and justification properties to 'front-sticky. 47 ;; right-margin, and justification properties to 'front-sticky.
46 ;; If you know the Right Way to fix this, contact 48 ;; If you know the Right Way to fix this, contact
47 ;; Mike Sperber <sperber@informatik.uni-tuebingen.de>. 49 ;; Mike Sperber <sperber@informatik.uni-tuebingen.de>.
48 50
49 (provide 'enriched) 51 (provide 'enriched)
50 (require 'facemenu) 52 (if window-system (require 'facemenu))
51 53
52 ;;; 54 ;;;
53 ;;; Variables controlling the display 55 ;;; Variables controlling the display
54 ;;; 56 ;;;
55 57
71 73
72 ;;; 74 ;;;
73 ;;; Set up faces & display table 75 ;;; Set up faces & display table
74 ;;; 76 ;;;
75 77
78 ;; XEmacs change (Can't cheat, we have variable width fonts)
76 (if (not (find-face 'fixed)) 79 (if (not (find-face 'fixed))
77 (copy-face 'default 'fixed)) 80 (copy-face 'default 'fixed))
78 81
79 (if (not (find-face 'excerpt)) 82 (if (not (find-face 'excerpt))
80 (copy-face 'italic 'excerpt)) 83 (copy-face 'italic 'excerpt))
81 84
82 (defconst enriched-display-table (make-display-table)) 85 (defconst enriched-display-table (make-display-table))
83 (aset enriched-display-table ?\f (make-string (1- (frame-width)) ?-)) 86 (aset enriched-display-table ?\f (make-string (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.")
84 91
85 ;;; 92 ;;;
86 ;;; Variables controlling the file format 93 ;;; Variables controlling the file format
87 ;;; (bidirectional) 94 ;;; (bidirectional)
88 95
107 (underline "underline") 114 (underline "underline")
108 (fixed "fixed") 115 (fixed "fixed")
109 (excerpt "excerpt") 116 (excerpt "excerpt")
110 (default ) 117 (default )
111 (nil enriched-encode-other-face)) 118 (nil enriched-encode-other-face))
112 (size (nil enriched-encode-size)) 119 (left-margin (4 "indent"))
120 (right-margin (4 "indentright"))
113 (justification (none "nofill") 121 (justification (none "nofill")
114 (right "flushright") 122 (right "flushright")
115 (left "flushleft") 123 (left "flushleft")
116 (full "flushboth") 124 (full "flushboth")
117 (center "center")) 125 (center "center"))
118 (left-margin (4 "indent"))
119 (right-margin (4 "indentright"))
120 (PARAMETER (t "param")) ; Argument of preceding annotation 126 (PARAMETER (t "param")) ; Argument of preceding annotation
127 ;; The following are not part of the standard:
121 (FUNCTION (enriched-decode-foreground "x-color") 128 (FUNCTION (enriched-decode-foreground "x-color")
122 (enriched-decode-background "x-bg-color") 129 (enriched-decode-background "x-bg-color")
130 ;; XEmacs addition
123 (facemenu-make-larger "bigger") 131 (facemenu-make-larger "bigger")
124 (facemenu-make-smaller "smaller")) 132 (facemenu-make-smaller "smaller"))
125 (read-only (t "x-read-only")) 133 (read-only (t "x-read-only"))
126 (unknown (nil format-annotate-value))) 134 (unknown (nil format-annotate-value))
135 ; (font-size (2 "bigger") ; unimplemented
136 ; (-2 "smaller"))
137 )
127 "List of definitions of text/enriched annotations. 138 "List of definitions of text/enriched annotations.
128 See `format-annotate-region' and `format-deannotate-region' for the definition 139 See `format-annotate-region' and `format-deannotate-region' for the definition
129 of this structure.") 140 of this structure.")
130 141
131 (defconst enriched-ignore '(hard) 142 (defconst enriched-ignore
143 '(front-sticky rear-nonsticky hard)
132 "Properties that are OK to ignore when saving text/enriched files. 144 "Properties that are OK to ignore when saving text/enriched files.
133 Any property that is neither on this list nor dealt with by 145 Any property that is neither on this list nor dealt with by
134 `enriched-translations' will generate a warning.") 146 `enriched-translations' will generate a warning.")
135 147
136 ;;; Internal variables 148 ;;; Internal variables
137 149
138 (defvar enriched-mode nil 150 (defvar enriched-mode nil
139 "True if `enriched-mode' is in use.") 151 "True if Enriched mode is in use.")
140 (make-variable-buffer-local 'enriched-mode) 152 (make-variable-buffer-local 'enriched-mode)
141 153
142 (if (not (assq 'enriched-mode minor-mode-alist)) 154 (if (not (assq 'enriched-mode minor-mode-alist))
143 (setq minor-mode-alist 155 (setq minor-mode-alist
144 (cons '(enriched-mode " Enriched") 156 (cons '(enriched-mode " Enriched")
145 minor-mode-alist))) 157 minor-mode-alist)))
146 158
147 (defvar enriched-mode-hooks nil 159 (defvar enriched-mode-hook nil
148 "Functions to run when entering `enriched-mode'. 160 "Functions to run when entering Enriched mode.
149 If you set variables in this hook, you should arrange for them to be restored 161 If you set variables in this hook, you should arrange for them to be restored
150 to their old values if enriched-mode is left. One way to do this is to add 162 to their old values if you leave Enriched mode. One way to do this is to add
151 them and their old values to `enriched-old-bindings'.") 163 them and their old values to `enriched-old-bindings'.")
152 164
153 (defvar enriched-old-bindings nil 165 (defvar enriched-old-bindings nil
154 "Store old variable values that we change when entering mode. 166 "Store old variable values that we change when entering mode.
155 The value is a list of \(VAR VALUE VAR VALUE...).") 167 The value is a list of \(VAR VALUE VAR VALUE...).")
165 ;;;###autoload 177 ;;;###autoload
166 (defun enriched-mode (&optional arg) 178 (defun enriched-mode (&optional arg)
167 "Minor mode for editing text/enriched files. 179 "Minor mode for editing text/enriched files.
168 These are files with embedded formatting information in the MIME standard 180 These are files with embedded formatting information in the MIME standard
169 text/enriched format. 181 text/enriched format.
170 Turning the mode on runs `enriched-mode-hooks'. 182 Turning the mode on runs `enriched-mode-hook'.
171 183
172 More information about enriched-mode is available in the file 184 More information about Enriched mode is available in the file
173 etc/enriched.doc in the Emacs distribution directory. 185 etc/enriched.doc in the Emacs distribution directory.
174 186
175 Commands: 187 Commands:
176 188
177 \\<enriched-mode-map>\\{enriched-mode-map}" 189 \\<enriched-mode-map>\\{enriched-mode-map}"
193 (t (setq enriched-mode t) ; Turn mode on 205 (t (setq enriched-mode t) ; Turn mode on
194 (if (not (memq 'text/enriched buffer-file-format)) 206 (if (not (memq 'text/enriched buffer-file-format))
195 (setq buffer-file-format 207 (setq buffer-file-format
196 (cons 'text/enriched buffer-file-format))) 208 (cons 'text/enriched buffer-file-format)))
197 ;; Save old variable values before we change them. 209 ;; Save old variable values before we change them.
198 ;; These will be restored if we exit enriched-mode. 210 ;; These will be restored if we exit Enriched mode.
199 (setq enriched-old-bindings 211 (setq enriched-old-bindings
200 (list 'indent-line-function indent-line-function 212 ;; XEmacs change
201 'use-hard-newlines use-hard-newlines)) 213 (list ; 'buffer-display-table buffer-display-table
214 'indent-line-function indent-line-function
215 'use-hard-newlines use-hard-newlines
216 'default-text-properties default-text-properties))
202 (make-local-variable 'indent-line-function) 217 (make-local-variable 'indent-line-function)
203 (make-local-variable 'use-hard-newlines) 218 (make-local-variable 'use-hard-newlines)
219 (make-local-variable 'default-text-properties)
204 (setq indent-line-function 'indent-to-left-margin 220 (setq indent-line-function 'indent-to-left-margin
205 use-hard-newlines t) 221 ;; XEmacs change
206 222 ;; buffer-display-table enriched-display-table
207 ;; copy display table 223 use-hard-newlines t)
208 (frob-display-table 224 (let ((sticky (plist-get default-text-properties 'front-sticky))
209 #'(lambda (dt) 225 (p enriched-par-props))
210 (let ((l (length enriched-display-table)) 226 (while p
211 (c 0)) 227 (if (not (memq (car p) sticky))
212 (while (< c l) 228 (setq sticky (cons (car p) sticky)))
213 (let ((v (aref enriched-display-table c))) 229 (setq p (cdr p)))
214 (if v 230 (if sticky
215 (aset dt c v))) 231 (setq default-text-properties
216 (setq c (1+ c))))) 232 (plist-put default-text-properties
217 (current-buffer)) 233 'front-sticky sticky))))
218 (run-hooks 'enriched-mode-hooks))) 234 (run-hooks 'enriched-mode-hook)))
219 (set-buffer-modified-p mod) 235 (set-buffer-modified-p mod)
236 ;; XEmacs change
220 (redraw-modeline))) 237 (redraw-modeline)))
221 238
222 ;;; 239 ;;;
223 ;;; Keybindings 240 ;;; Keybindings
224 ;;; 241 ;;;
225 242
226 (defvar enriched-mode-map nil 243 (defvar enriched-mode-map nil
227 "Keymap for `enriched-mode'.") 244 "Keymap for Enriched mode.")
228 245
229 (if (null enriched-mode-map) 246 (if (null enriched-mode-map)
230 (fset 'enriched-mode-map (setq enriched-mode-map (make-sparse-keymap)))) 247 (fset 'enriched-mode-map (setq enriched-mode-map (make-sparse-keymap))))
231 248
232 (if (not (assq 'enriched-mode minor-mode-map-alist)) 249 (if (not (assq 'enriched-mode minor-mode-map-alist))
339 (concat (format enriched-annotation-format "" item) 356 (concat (format enriched-annotation-format "" item)
340 (mapconcat (lambda (i) (concat "<param>" i "</param>")) 357 (mapconcat (lambda (i) (concat "<param>" i "</param>"))
341 params "")))) 358 params ""))))
342 (t (format enriched-annotation-format "/" (car name))))) 359 (t (format enriched-annotation-format "/" (car name)))))
343 360
361 ;; XEmacs addition
344 (defun enriched-face-strip-size (face) 362 (defun enriched-face-strip-size (face)
345 "Create a symbol from the name of FACE devoid of size information, 363 "Create a symbol from the name of FACE devoid of size information,
346 i.e. remove all larger- and smaller- prefixes." 364 i.e. remove all larger- and smaller- prefixes."
347 (let* ((face-symbol (face-name face)) 365 (let* ((face-symbol (face-name face))
348 (face-name (symbol-name face-symbol)) 366 (face-name (symbol-name face-symbol))
370 (cons (and old (enriched-face-ans old)) 388 (cons (and old (enriched-face-ans old))
371 (and new (enriched-face-ans new)))) 389 (and new (enriched-face-ans new))))
372 390
373 (defun enriched-face-ans (face) 391 (defun enriched-face-ans (face)
374 "Return annotations specifying FACE." 392 "Return annotations specifying FACE."
393 ;; XEmacs change (entire body of this function)
375 (let ((face-name (symbol-name face))) 394 (let ((face-name (symbol-name face)))
376 (cond ((string-match "^fg:" face-name) 395 (cond ((string-match "^fg:" face-name)
377 (list (list "x-color" (substring face-name 3)))) 396 (list (list "x-color" (substring face-name 3))))
378 ((string-match "^bg:" face-name) 397 ((string-match "^bg:" face-name)
379 (list (list "x-bg-color" (substring face-name 3)))) 398 (list (list "x-bg-color" (substring face-name 3))))
392 (ans '())) 411 (ans '()))
393 (if fg (setq ans (cons (list "x-color" fg) ans))) 412 (if fg (setq ans (cons (list "x-color" fg) ans)))
394 (if bg (setq ans (cons (list "x-bg-color" bg) ans))) 413 (if bg (setq ans (cons (list "x-bg-color" bg) ans)))
395 ans))))) 414 ans)))))
396 415
397 416 ;; XEmacs addition
398 (defun enriched-size-annotation (n annotation) 417 (defun enriched-size-annotation (n annotation)
399 "Generate ANNOTATION N times." 418 "Generate ANNOTATION N times."
400 (let ((l '())) 419 (let ((l '()))
401 (while (not (zerop n)) 420 (while (not (zerop n))
402 (setq l (cons annotation l)) 421 (setq l (cons annotation l))
403 (setq n (1- n))) 422 (setq n (1- n)))
404 l)) 423 l))
405 424
425 ;; XEmacs addition
406 (defun enriched-encode-size (old new) 426 (defun enriched-encode-size (old new)
407 "Return annotations specifying SIZE." 427 "Return annotations specifying SIZE."
408 (let* ((old (or old 0)) 428 (let* ((old (or old 0))
409 (new (or new 0)) 429 (new (or new 0))
410 (closing-annotation 430 (closing-annotation
466 (forward-char 1) 486 (forward-char 1)
467 (if (= ?< (char-after (point))) 487 (if (= ?< (char-after (point)))
468 (delete-char 1) 488 (delete-char 1)
469 ;; A single < that does not start an annotation is an error, 489 ;; A single < that does not start an annotation is an error,
470 ;; which we note and then ignore. 490 ;; which we note and then ignore.
471 (message (format "Warning: malformed annotation in file at %s" 491 (message "Warning: malformed annotation in file at %s"
472 (1- (point)))))) 492 (1- (point)))))
473 (if (not (eobp)) 493 (if (not (eobp))
474 (let* ((beg (match-beginning 0)) 494 (let* ((beg (match-beginning 0))
475 (end (match-end 0)) 495 (end (match-end 0))
476 (name (downcase (buffer-substring 496 (name (downcase (buffer-substring
477 (match-beginning 2) (match-end 2)))) 497 (match-beginning 2) (match-end 2))))
490 (delete-region (point) (match-end 0))) 510 (delete-region (point) (match-end 0)))
491 (if (looking-at "^\n") 511 (if (looking-at "^\n")
492 (delete-char 1))) 512 (delete-char 1)))
493 513
494 (defun enriched-decode-foreground (from to color) 514 (defun enriched-decode-foreground (from to color)
515 ;; XEmacs change
495 (let ((face (facemenu-get-face (intern (concat "fg:" color))))) 516 (let ((face (facemenu-get-face (intern (concat "fg:" color)))))
496 (if (not face) 517 (if (not face)
497 (progn 518 (progn
498 (make-face face) 519 (make-face face)
499 (message "Warning: Color \"%s\" can't be displayed." color))) 520 (message "Warning: Color \"%s\" can't be displayed." color)))
500 (list from to 'face face))) 521 (list from to 'face face)))
501 522
502 (defun enriched-decode-background (from to color) 523 (defun enriched-decode-background (from to color)
524 ;; XEmacs change
503 (let ((face (facemenu-get-face (intern (concat "bg:" color))))) 525 (let ((face (facemenu-get-face (intern (concat "bg:" color)))))
504 (if (not face) 526 (if (not face)
505 (progn 527 (progn
506 (make-face face) 528 (make-face face)
507 (message "Warning: Color \"%s\" can't be displayed." color))) 529 (message "Warning: Color \"%s\" can't be displayed." color)))