Mercurial > emacs
annotate lisp/enriched.el @ 10660:0501556eef3a
(IRIX): Sed - to _.
author | Jim Wilson <wilson@gnu.org> |
---|---|
date | Sat, 04 Feb 1995 17:59:47 +0000 |
parents | 66c7e651194d |
children | c8790275a636 |
rev | line source |
---|---|
9676 | 1 ;;; enriched.el -- read and save files in text/enriched format |
2 ;; Copyright (c) 1994 Free Software Foundation | |
3 | |
4 ;; Author: Boris Goldowsky <boris@cs.rochester.edu> | |
5 ;; Keywords: wp, faces | |
6 | |
7 ;; This file is part of GNU Emacs. | |
8 | |
9 ;; GNU Emacs is free software; you can redistribute it and/or modify | |
10 ;; it under the terms of the GNU General Public License as published by | |
11 ;; the Free Software Foundation; either version 2, or (at your option) | |
12 ;; any later version. | |
13 ;; | |
14 ;; GNU Emacs is distributed in the hope that it will be useful, | |
15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
17 ;; GNU General Public License for more details. | |
18 ;; | |
19 ;; You should have received a copy of the GNU General Public License | |
20 ;; along with GNU Emacs; see the file COPYING. If not, write to | |
21 ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. | |
22 | |
23 ;;; Commentary: | |
24 ;; | |
25 ;; This file implements reading, editing, and saving files with | |
26 ;; text-properties such as faces, levels of indentation, and true line breaks | |
27 ;; distinguished from newlines just used to fit text into the window. | |
28 ;; | |
29 ;; The file format used is the MIME text/enriched format, which is a | |
30 ;; standard format defined in internet RFC 1563. All standard annotations are | |
31 ;; supported except for <smaller> and <bigger>, which are currently not | |
32 ;; possible to display. | |
33 ;; | |
34 ;; A separate file, enriched.doc, contains further documentation and other | |
35 ;; important information about this code. It also serves as an example file | |
36 ;; in text/enriched format. It should be in the etc directory of your emacs | |
37 ;; distribution. | |
38 | |
39 (provide 'enriched) | |
40 (if window-system (require 'facemenu)) | |
41 | |
42 ;;; | |
43 ;;; Variables controlling the display | |
44 ;;; | |
45 | |
46 (defvar enriched-verbose t | |
47 "*If non-nil, give status messages when reading and writing files.") | |
48 | |
49 (defvar enriched-default-right-margin 10 | |
50 "*Default amount of space to leave on the right edge of the screen. | |
51 This can be increased inside text by changing the 'right-margin text property. | |
52 Measured in character widths. If the screen is narrower than this, it is | |
53 assumed to be 0.") | |
54 | |
55 (defvar enriched-fill-after-visiting t | |
56 "If t, fills paragraphs when reading in enriched documents. | |
57 If nil, only fills when you explicitly request it. If the value is 'ask, then | |
58 it will query you whether to fill. | |
59 Filling is never done if the current text-width is the same as the value | |
60 stored in the file.") | |
61 | |
62 (defvar enriched-auto-save-interval 1000 | |
63 "*`Auto-save-interval' to use for `enriched-mode'. | |
64 Auto-saving enriched files is slow, so you may wish to have them happen less | |
65 often. You can set this to nil to only do auto-saves when you are not | |
66 actively working.") | |
67 | |
68 ;;Unimplemented: | |
69 ;(defvar enriched-aggressive-auto-fill t | |
70 ; "*If t, try to keep things properly filled and justified always. | |
71 ;Set this to nil if you have a slow terminal or prefer to justify on request. | |
72 ;The difference between aggressive and non-aggressive is subtle right now, but | |
73 ;may become stronger in the future.") | |
74 | |
75 ;; Unimplemented: | |
76 ; (defvar enriched-keep-ignored-items nil | |
77 ; "*If t, keep track of codes that are not understood. | |
78 ; Otherwise they are deleted on reading the file, and not written out.") | |
79 | |
80 ;;Unimplemented: | |
81 ;(defvar enriched-electric-indentation t | |
82 ; "*If t, newlines and following indentation stick together. | |
83 ;Deleting a newline or any part of the indenation will delete the whole | |
84 ;stretch.") | |
85 | |
86 ;;; | |
87 ;;; Set up faces & display table | |
88 ;;; | |
89 | |
90 ;; A slight cheat - all emacs's faces are fixed-width. | |
91 ;; The idea is just to pick one that looks different from the default. | |
92 (if (internal-find-face 'fixed) | |
93 nil | |
94 (make-face 'fixed) | |
95 (if window-system | |
96 (set-face-font 'fixed | |
97 (car (or (x-list-fonts "*fixed-medium*" | |
98 'default (selected-frame)) | |
99 (x-list-fonts "*fixed*" | |
100 'default (selected-frame))))))) | |
101 | |
102 (if (internal-find-face 'excerpt) | |
103 nil | |
104 (make-face 'excerpt) | |
105 (if window-system | |
106 (make-face-italic 'excerpt))) | |
107 | |
108 ;;; The following two faces should not appear on menu. | |
109 (if (boundp 'facemenu-unlisted-faces) | |
110 (setq facemenu-unlisted-faces | |
111 (append '(enriched-code-face enriched-indentation-face) | |
112 facemenu-unlisted-faces))) | |
113 | |
114 (if (internal-find-face 'enriched-code-face) | |
115 nil | |
116 (make-face 'enriched-code-face) | |
117 (if window-system | |
118 (set-face-background 'enriched-code-face | |
119 (if (x-display-color-p) | |
120 "LightSteelBlue" | |
121 "gray35")))) | |
122 | |
123 (if (internal-find-face 'enriched-indentation-face) | |
124 nil | |
125 (make-face 'enriched-indentation-face) | |
126 (if window-system | |
127 (set-face-background 'enriched-indentation-face | |
128 (if (x-display-color-p) | |
129 "DarkSlateBlue" | |
130 "gray25")))) | |
131 | |
132 (defvar enriched-display-table (make-display-table)) | |
133 (aset enriched-display-table ?\f (make-vector (1- (frame-width)) ?-)) | |
134 | |
10519
66c7e651194d
(enriched-annotation-list): property `hard-newline'
Richard M. Stallman <rms@gnu.org>
parents:
9694
diff
changeset
|
135 ; (defvar enriched-show-codes nil "See the function of the same name") |
9676 | 136 |
137 (defvar enriched-par-props '(left-margin right-margin justification | |
138 front-sticky) | |
139 "Text-properties that usually apply to whole paragraphs. | |
140 These are set front-sticky everywhere except at hard newlines.") | |
141 | |
142 ;;; | |
143 ;;; Variables controlling the file format | |
144 ;;; (bidirectional) | |
145 | |
146 (defvar enriched-initial-annotation | |
147 (lambda () | |
148 (format "<param>-*-enriched-*-width:%d | |
149 </param>" (enriched-text-width))) | |
150 "What to insert at the start of a text/enriched file. | |
151 If this is a string, it is inserted. If it is a list, it should be a lambda | |
152 expression, which is evaluated to get the string to insert.") | |
153 | |
154 (defvar enriched-annotation-format "<%s%s>" | |
155 "General format of enriched-text annotations.") | |
156 | |
157 (defvar enriched-annotation-regexp "<\\(/\\)?\\([-A-za-z0-9]+\\)>" | |
158 "Regular expression matching enriched-text annotations.") | |
159 | |
160 (defvar enriched-downcase-annotations t | |
161 "Set to t if case of annotations is irrelevant. | |
162 In this case all annotations listed in enriched-annotation-list should be | |
163 lowercase, and annotations read from files will be downcased before being | |
164 compared to that list.") | |
165 | |
166 (defvar enriched-list-valued-properties '(face unknown) | |
167 "List of properties whose values can be lists.") | |
168 | |
169 (defvar enriched-annotation-alist | |
170 '((face (bold-italic "bold" "italic") | |
171 (bold "bold") | |
172 (italic "italic") | |
173 (underline "underline") | |
174 (fixed "fixed") | |
175 (excerpt "excerpt") | |
176 (default ) | |
177 (nil enriched-encode-other-face)) | |
10519
66c7e651194d
(enriched-annotation-list): property `hard-newline'
Richard M. Stallman <rms@gnu.org>
parents:
9694
diff
changeset
|
178 (hard (nil enriched-encode-hard-newline)) |
9676 | 179 (left-margin (4 "indent")) |
180 (right-margin (4 "indentright")) | |
181 (justification (none "nofill") | |
182 (right "flushright") | |
183 (left "flushleft") | |
10519
66c7e651194d
(enriched-annotation-list): property `hard-newline'
Richard M. Stallman <rms@gnu.org>
parents:
9694
diff
changeset
|
184 (full "flushboth") |
9676 | 185 (center "center")) |
186 (PARAMETER (t "param")) ; Argument of preceding annotation | |
187 ;; The following are not part of the standard: | |
188 (FUNCTION (enriched-decode-foreground "x-color") | |
189 (enriched-decode-background "x-bg-color")) | |
190 (read-only (t "x-read-only")) | |
191 (unknown (nil enriched-encode-unknown)) ;anything else found | |
192 ; (font-size (2 "bigger") ; unimplemented | |
193 ; (-2 "smaller")) | |
194 ) | |
195 "List of definitions of text/enriched annotations. | |
196 Each element is a list whose car is a PROPERTY, and the following | |
197 elements are VALUES of that property followed by zero or more ANNOTATIONS. | |
198 Whenever the property takes on that value, each of the annotations | |
199 will be inserted into the file. Only the name of the annotation | |
200 should be specified, it will be formatted by `enriched-make-annotation'. | |
201 At the point that the property stops having that value, the matching | |
202 negated annotation will be inserted (it may actually be closed earlier and | |
203 reopened, if necessary, to keep proper nesting). | |
204 | |
205 Conversely, when annotations are read, they are searched for in this list, and | |
206 the relevant text property is added to the buffer. The first match found whose | |
207 conditions are satisfied is used. If enriched-downcase-annotations is true, | |
208 then annotations in this list should be listed in lowercase, and annotations | |
209 read from the file will be downcased. | |
210 | |
211 If the VALUE is numeric, then it is assumed that there is a single annotation | |
212 and each occurrence of it increments the value of the property by that number. | |
213 Thus, given the entry \(left-margin \(4 \"indent\")), `enriched-encode-region' | |
214 will insert two <indent> annotations if the left margin changes from 4 to 12. | |
215 | |
216 If the VALUE is nil, then instead of annotations, a function should be | |
217 specified. This function is used as a default: it is called for all | |
218 transitions not explicitly listed in the table. The function is called with | |
219 two arguments, the OLD and NEW values of the property. It should return a | |
220 list of annotations like `enriched-loc-annotations' does, or may directly | |
221 modify the buffer. Note that this only works for encoding; there must be some | |
222 other way of decoding the annotations thus produced. | |
223 | |
224 [For future expansion:] If the VALUE is a list, then the property's value will | |
225 be appended to the surrounding value of the property. | |
226 | |
227 For decoding, there are some special symbols that can be used in the | |
228 \"property\" slot. Annotations listed under the pseudo-property PARAMETER are | |
229 considered to be arguments of the immediately surrounding annotation; the text | |
230 between the opening and closing parameter annotations is deleted from the | |
231 buffer but saved as a string. The surrounding annotation should be listed | |
232 under the pseudo-property FUNCTION. Instead of inserting a text-property for | |
233 this annotation, enriched-decode-buffer will call the function listed in the | |
234 VALUE slot, with the first two arguments being the start and end locations and | |
235 the rest of the arguments being any PARAMETERs found in that region.") | |
236 | |
237 ;;; This is not needed for text/enriched format, since all annotations are in | |
238 ;;; a standard form: | |
239 ;(defvar enriched-special-annotations-alist nil | |
240 ; "List of annotations not formatted in the usual way. | |
241 ;Each element has the form (ANNOTATION BEGIN END), where | |
242 ;ANNOTATION is the annotation's name, which is a symbol (normal | |
243 ;annotations are named with strings, special ones with symbols), | |
244 ;BEGIN is the literal string to insert as the opening annotation, and | |
245 ;END is the literal string to insert as the close. | |
246 ;This is used only for encoding. Typically, each will have an entry in | |
247 ;enriched-decode-special-alist to deal with its decoding.") | |
248 | |
249 ;;; Encoding variables | |
250 | |
251 (defvar enriched-encode-interesting-regexp "<" | |
252 "Regexp matching the start of something that may require encoding. | |
253 All text-property changes are also considered \"interesting\".") | |
254 | |
255 (defvar enriched-encode-special-alist | |
256 '(("<" . (lambda () (insert-and-inherit "<")))) | |
257 "List of special operations for writing enriched files. | |
258 Each element has the form \(STRING . FUNCTION). | |
259 Whenever one of the strings \(including its properties, if any) | |
260 is found, the corresponding function is called. | |
261 Match data is available to the function. | |
262 See `enriched-decode-special-alist' for instructions on decoding special | |
263 items.") | |
264 | |
265 (defvar enriched-ignored-ok | |
266 '(front-sticky rear-nonsticky) | |
267 "Properties that are not written into enriched files. | |
268 Generally this list should only contain properties that just for enriched's | |
269 internal purposes; other properties that cannot be recorded will generate | |
270 a warning message to the user since information will be lost.") | |
271 | |
272 ;;; Decoding variables | |
273 | |
274 (defvar enriched-decode-interesting-regexp "[<\n]" | |
275 "Regexp matching the start of something that may require decoding.") | |
276 | |
277 (defvar enriched-decode-special-alist | |
278 '(("<<" . (lambda () (delete-char 1) (forward-char 1))) | |
279 ("\n\n" . enriched-decode-hard-newline)) | |
280 "List of special operations for reading enriched files. | |
281 Each element has the form \(STRING . FUNCTION). | |
282 Whenever one of the strings is found, the corresponding function is called, | |
283 with point at the beginning of the match and the match data is available to | |
284 the function. Should leave point where next search should start.") | |
285 | |
286 ;;; Internal variables | |
287 | |
288 (defvar enriched-mode nil | |
289 "True if `enriched-mode' \(which see) is enabled.") | |
290 (make-variable-buffer-local 'enriched-mode) | |
291 | |
292 (if (not (assq 'enriched-mode minor-mode-alist)) | |
293 (setq minor-mode-alist | |
294 (cons '(enriched-mode " Enriched") | |
295 minor-mode-alist))) | |
296 | |
297 (defvar enriched-mode-hooks nil | |
298 "Functions to run when entering `enriched-mode'. | |
299 If you set variables in this hook, you should arrange for them to be restored | |
300 to their old values if enriched-mode is left. One way to do this is to add | |
301 them and their old values to `enriched-old-bindings'.") | |
302 | |
303 (defvar enriched-old-bindings nil | |
304 "Store old variable values that we change when entering mode. | |
305 The value is a list of \(VAR VALUE VAR VALUE...).") | |
306 (make-variable-buffer-local 'enriched-old-bindings) | |
307 | |
308 (defvar enriched-translated nil | |
309 "True if buffer has already been decoded.") | |
310 (make-variable-buffer-local 'enriched-translated) | |
311 | |
312 (defvar enriched-text-width nil) | |
313 (make-variable-buffer-local 'enriched-text-width) | |
314 | |
315 (defvar enriched-ignored-list nil) | |
316 | |
317 (defvar enriched-open-ans nil) | |
318 | |
319 ;;; | |
320 ;;; Functions defining the format of annotations | |
321 ;;; | |
322 | |
323 (defun enriched-make-annotation (name positive) | |
324 "Format an annotation called NAME. | |
325 If POSITIVE is non-nil, this is the opening annotation, if nil, this is the | |
326 matching close." | |
327 ;; Could be used for annotations not following standard form: | |
328 ; (if (symbolp name) | |
329 ; (if positive | |
330 ; (elt (assq name enriched-special-annotations-alist) 1) | |
331 ; (elt (assq name enriched-special-annotations-alist) 2)) ) | |
332 (if (stringp name) | |
333 (format enriched-annotation-format (if positive "" "/") name) | |
334 ;; has parameters. | |
335 (if 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 (format enriched-annotation-format "/" (car name))))) | |
342 | |
343 (defun enriched-annotation-name (a) | |
344 "Find the name of an ANNOTATION." | |
345 (save-match-data | |
346 (if (string-match enriched-annotation-regexp a) | |
347 (substring a (match-beginning 2) (match-end 2))))) | |
348 | |
349 (defun enriched-annotation-positive-p (a) | |
350 "Returns t if ANNOTATION is positive (open), | |
351 or nil if it is a closing (negative) annotation." | |
352 (save-match-data | |
353 (and (string-match enriched-annotation-regexp a) | |
354 (not (match-beginning 1))))) | |
355 | |
356 (defun enriched-encode-unknown (old new) | |
357 "Deals with re-inserting unknown annotations." | |
358 (cons (if old (list old)) | |
359 (if new (list new)))) | |
360 | |
361 (defun enriched-encode-hard-newline (old new) | |
362 "Deal with encoding `hard-newline' property change." | |
363 ;; This makes a sequence of N hard newlines into N+1 duplicates of the first | |
364 ;; one- so all property changes are put off until after all the newlines. | |
10519
66c7e651194d
(enriched-annotation-list): property `hard-newline'
Richard M. Stallman <rms@gnu.org>
parents:
9694
diff
changeset
|
365 (if (and new (current-justification)) ; no special processing inside NoFill |
9676 | 366 (let* ((length (skip-chars-forward "\n")) |
367 (s (make-string length ?\n))) | |
368 (backward-delete-char (1- length)) | |
369 (add-text-properties 0 length (text-properties-at (1- (point))) s) | |
370 (insert s) | |
371 (backward-char (+ length 1))))) | |
372 | |
373 (defun enriched-decode-hard-newline () | |
374 "Deal with newlines while decoding file." | |
375 (let ((nofill (equal "nofill" ; find out if we're in NoFill region | |
376 (enriched-which-assoc | |
377 '("nofill" "flushleft" "flushright" "center" | |
378 "flushboth") | |
379 enriched-open-ans))) | |
380 (n (skip-chars-forward "\n"))) | |
381 (delete-char (- n)) | |
10519
66c7e651194d
(enriched-annotation-list): property `hard-newline'
Richard M. Stallman <rms@gnu.org>
parents:
9694
diff
changeset
|
382 (newline (if nofill n (1- n))))) |
9676 | 383 |
384 (defun enriched-encode-other-face (old new) | |
385 "Generate annotations for random face change. | |
386 One annotation each for foreground color, background color, italic, etc." | |
387 (cons (and old (enriched-face-ans old)) | |
388 (and new (enriched-face-ans new)))) | |
389 | |
390 (defun enriched-face-ans (face) | |
391 "Return annotations specifying FACE." | |
392 (cond ((string-match "^fg:" (symbol-name face)) | |
393 (list (list "x-color" (substring (symbol-name face) 3)))) | |
394 ((string-match "^bg:" (symbol-name face)) | |
395 (list (list "x-bg-color" (substring (symbol-name face) 3)))) | |
396 ((let* ((fg (face-foreground face)) | |
397 (bg (face-background face)) | |
398 (props (face-font face t)) | |
399 (ans (cdr (enriched-annotate-change 'face nil props)))) | |
400 (if fg (enriched-push (list "x-color" fg) ans)) | |
401 (if bg (enriched-push (list "x-bg-color" bg) ans)) | |
402 ans)))) | |
403 | |
404 (defun enriched-decode-foreground (from to color) | |
405 (let ((face (intern (concat "fg:" color)))) | |
9694
f8aa9230c3fa
(enriched-mode): Add autoload cookie.
Boris Goldowsky <boris@gnu.org>
parents:
9677
diff
changeset
|
406 (cond ((internal-find-face face)) |
f8aa9230c3fa
(enriched-mode): Add autoload cookie.
Boris Goldowsky <boris@gnu.org>
parents:
9677
diff
changeset
|
407 ((and window-system (facemenu-get-face face))) |
f8aa9230c3fa
(enriched-mode): Add autoload cookie.
Boris Goldowsky <boris@gnu.org>
parents:
9677
diff
changeset
|
408 (window-system |
f8aa9230c3fa
(enriched-mode): Add autoload cookie.
Boris Goldowsky <boris@gnu.org>
parents:
9677
diff
changeset
|
409 (enriched-warn "Color \"%s\" not defined: |
f8aa9230c3fa
(enriched-mode): Add autoload cookie.
Boris Goldowsky <boris@gnu.org>
parents:
9677
diff
changeset
|
410 Try M-x set-face-foreground RET %s RET some-other-color" color face)) |
f8aa9230c3fa
(enriched-mode): Add autoload cookie.
Boris Goldowsky <boris@gnu.org>
parents:
9677
diff
changeset
|
411 ((make-face face) |
f8aa9230c3fa
(enriched-mode): Add autoload cookie.
Boris Goldowsky <boris@gnu.org>
parents:
9677
diff
changeset
|
412 (enriched-warn "Color \"%s\" can't be displayed." color))) |
9676 | 413 (list from to 'face face))) |
414 | |
415 (defun enriched-decode-background (from to color) | |
416 (let ((face (intern (concat "bg:" color)))) | |
9694
f8aa9230c3fa
(enriched-mode): Add autoload cookie.
Boris Goldowsky <boris@gnu.org>
parents:
9677
diff
changeset
|
417 (cond ((internal-find-face face)) |
f8aa9230c3fa
(enriched-mode): Add autoload cookie.
Boris Goldowsky <boris@gnu.org>
parents:
9677
diff
changeset
|
418 ((and window-system (facemenu-get-face face))) |
f8aa9230c3fa
(enriched-mode): Add autoload cookie.
Boris Goldowsky <boris@gnu.org>
parents:
9677
diff
changeset
|
419 (window-system |
f8aa9230c3fa
(enriched-mode): Add autoload cookie.
Boris Goldowsky <boris@gnu.org>
parents:
9677
diff
changeset
|
420 (enriched-warn "Color \"%s\" not defined: |
f8aa9230c3fa
(enriched-mode): Add autoload cookie.
Boris Goldowsky <boris@gnu.org>
parents:
9677
diff
changeset
|
421 Try M-x set-face-background RET %s RET some-other-color" color face)) |
f8aa9230c3fa
(enriched-mode): Add autoload cookie.
Boris Goldowsky <boris@gnu.org>
parents:
9677
diff
changeset
|
422 ((make-face face) |
f8aa9230c3fa
(enriched-mode): Add autoload cookie.
Boris Goldowsky <boris@gnu.org>
parents:
9677
diff
changeset
|
423 (enriched-warn "Color \"%s\" can't be displayed." color))) |
9676 | 424 (list from to 'face face))) |
425 | |
426 ;;; | |
427 ;;; NOTE: Everything below this point is intended to be independent of the file | |
428 ;;; format, which is defined by the variables and functions above. | |
429 ;;; | |
430 | |
431 ;;; | |
432 ;;; Define the mode | |
433 ;;; | |
434 | |
9694
f8aa9230c3fa
(enriched-mode): Add autoload cookie.
Boris Goldowsky <boris@gnu.org>
parents:
9677
diff
changeset
|
435 ;;;###autoload |
9676 | 436 (defun enriched-mode (&optional arg notrans) |
437 "Minor mode for editing text/enriched files. | |
438 These are files with embedded formatting information in the MIME standard | |
439 text/enriched format. | |
440 | |
441 Turning the mode on or off interactively will query whether the buffer | |
442 should be translated into or out of text/enriched format immediately. | |
443 Noninteractively translation is done without query unless the optional | |
444 second argument NO-TRANS is non-nil. | |
445 Turning mode on runs `enriched-mode-hooks'. | |
446 | |
447 More information about enriched-mode is available in the file | |
448 etc/enriched.doc in the Emacs distribution directory. | |
449 | |
450 Commands: | |
451 | |
452 \\<enriched-mode-map>\\{enriched-mode-map}" | |
453 (interactive "P") | |
454 (let ((mod (buffer-modified-p))) | |
455 (cond ((or (<= (prefix-numeric-value arg) 0) | |
456 (and enriched-mode (null arg))) | |
457 ;; Turn mode off | |
458 (setq enriched-mode nil) | |
459 (if (if (interactive-p) | |
460 (y-or-n-p "Translate buffer into text/enriched format?") | |
461 (not notrans)) | |
462 (progn (enriched-encode-region) | |
463 (mapcar (lambda (x) | |
464 (remove-text-properties | |
465 (point-min) (point-max) | |
466 (list (if (consp x) (car x) x) nil))) | |
467 (append enriched-ignored-ok | |
468 enriched-annotation-alist)) | |
469 (setq enriched-translated nil))) | |
470 ;; restore old variable values | |
471 (while enriched-old-bindings | |
472 (funcall 'set (car enriched-old-bindings) | |
473 (car (cdr enriched-old-bindings))) | |
474 (setq enriched-old-bindings (cdr (cdr enriched-old-bindings)))) | |
475 (remove-hook 'write-region-annotate-functions | |
476 'enriched-annotate-function t) | |
477 (remove-hook 'after-change-functions 'enriched-nogrow-hook t)) | |
478 (enriched-mode nil) ; Mode already on; do nothing. | |
479 (t ; Turn mode on | |
480 ;; save old variable values before we change them. | |
481 (setq enriched-mode t | |
482 enriched-old-bindings | |
10519
66c7e651194d
(enriched-annotation-list): property `hard-newline'
Richard M. Stallman <rms@gnu.org>
parents:
9694
diff
changeset
|
483 (list 'auto-save-interval auto-save-interval |
9676 | 484 'buffer-display-table buffer-display-table |
10519
66c7e651194d
(enriched-annotation-list): property `hard-newline'
Richard M. Stallman <rms@gnu.org>
parents:
9694
diff
changeset
|
485 'indent-line-function indent-line-function |
66c7e651194d
(enriched-annotation-list): property `hard-newline'
Richard M. Stallman <rms@gnu.org>
parents:
9694
diff
changeset
|
486 'use-hard-newlines use-hard-newlines)) |
9676 | 487 (make-local-variable 'auto-save-interval) |
488 (make-local-variable 'indent-line-function) | |
10519
66c7e651194d
(enriched-annotation-list): property `hard-newline'
Richard M. Stallman <rms@gnu.org>
parents:
9694
diff
changeset
|
489 (make-local-variable 'use-hard-newlines) |
66c7e651194d
(enriched-annotation-list): property `hard-newline'
Richard M. Stallman <rms@gnu.org>
parents:
9694
diff
changeset
|
490 (setq auto-save-interval enriched-auto-save-interval |
66c7e651194d
(enriched-annotation-list): property `hard-newline'
Richard M. Stallman <rms@gnu.org>
parents:
9694
diff
changeset
|
491 indent-line-function 'indent-to-left-margin |
66c7e651194d
(enriched-annotation-list): property `hard-newline'
Richard M. Stallman <rms@gnu.org>
parents:
9694
diff
changeset
|
492 buffer-display-table enriched-display-table |
66c7e651194d
(enriched-annotation-list): property `hard-newline'
Richard M. Stallman <rms@gnu.org>
parents:
9694
diff
changeset
|
493 use-hard-newlines t) ; Weird in Center&FlushRight |
9676 | 494 ;; Add hooks |
495 (add-hook 'write-region-annotate-functions | |
496 'enriched-annotate-function) | |
10519
66c7e651194d
(enriched-annotation-list): property `hard-newline'
Richard M. Stallman <rms@gnu.org>
parents:
9694
diff
changeset
|
497 ; (add-hook 'after-change-functions 'enriched-nogrow-hook) |
9676 | 498 |
499 (put-text-property (point-min) (point-max) | |
500 'front-sticky enriched-par-props) | |
501 | |
502 (if (and (not enriched-translated) | |
503 (if (interactive-p) | |
504 (y-or-n-p "Does buffer need to be translated now? ") | |
505 (not notrans))) | |
506 (progn (enriched-decode-region) | |
507 (setq enriched-translated t))) | |
508 (run-hooks 'enriched-mode-hooks))) | |
509 (set-buffer-modified-p mod) | |
510 (force-mode-line-update))) | |
511 | |
512 ;;; | |
513 ;;; Keybindings | |
514 ;;; | |
515 | |
516 (defvar enriched-mode-map nil | |
517 "Keymap for `enriched-mode'.") | |
518 | |
519 (if (null enriched-mode-map) | |
520 (fset 'enriched-mode-map (setq enriched-mode-map (make-sparse-keymap)))) | |
521 | |
522 (if (not (assq 'enriched-mode minor-mode-map-alist)) | |
523 (setq minor-mode-map-alist | |
524 (cons (cons 'enriched-mode enriched-mode-map) | |
525 minor-mode-map-alist))) | |
526 | |
10519
66c7e651194d
(enriched-annotation-list): property `hard-newline'
Richard M. Stallman <rms@gnu.org>
parents:
9694
diff
changeset
|
527 (define-key enriched-mode-map "\C-a" 'move-to-left-margin) |
66c7e651194d
(enriched-annotation-list): property `hard-newline'
Richard M. Stallman <rms@gnu.org>
parents:
9694
diff
changeset
|
528 (define-key enriched-mode-map "\C-j" 'newline) |
9676 | 529 (define-key enriched-mode-map "\M-j" 'enriched-justification-menu-map) |
10519
66c7e651194d
(enriched-annotation-list): property `hard-newline'
Richard M. Stallman <rms@gnu.org>
parents:
9694
diff
changeset
|
530 (define-key enriched-mode-map "\M-S" 'set-justification-center) |
66c7e651194d
(enriched-annotation-list): property `hard-newline'
Richard M. Stallman <rms@gnu.org>
parents:
9694
diff
changeset
|
531 (define-key enriched-mode-map "\C-x\t" 'increment-left-margin) |
66c7e651194d
(enriched-annotation-list): property `hard-newline'
Richard M. Stallman <rms@gnu.org>
parents:
9694
diff
changeset
|
532 (define-key enriched-mode-map "\C-c\C-l" 'set-left-margin) |
66c7e651194d
(enriched-annotation-list): property `hard-newline'
Richard M. Stallman <rms@gnu.org>
parents:
9694
diff
changeset
|
533 (define-key enriched-mode-map "\C-c\C-r" 'set-right-margin) |
66c7e651194d
(enriched-annotation-list): property `hard-newline'
Richard M. Stallman <rms@gnu.org>
parents:
9694
diff
changeset
|
534 ;;(define-key enriched-mode-map "\C-c\C-s" 'enriched-show-codes) |
9676 | 535 |
536 ;;; | |
537 ;;; General list/stack manipulation | |
538 ;;; | |
539 | |
540 (defmacro enriched-push (item stack) | |
541 "Push ITEM onto STACK. | |
542 STACK should be a symbol whose value is a list." | |
543 (` (setq (, stack) (cons (, item) (, stack))))) | |
544 | |
545 (defmacro enriched-pop (stack) | |
546 "Remove and return first item on STACK." | |
547 (` (let ((pop-item (car (, stack)))) | |
548 (setq (, stack) (cdr (, stack))) | |
549 pop-item))) | |
550 | |
551 (defun enriched-delq1 (cons list) | |
552 "Remove the given CONS from LIST by side effect. | |
553 Since CONS could be the first element of LIST, write | |
554 `(setq foo (enriched-delq1 element foo))' to be sure of changing the value | |
555 of `foo'." | |
556 (if (eq cons list) | |
557 (cdr list) | |
558 (let ((p list)) | |
559 (while (not (eq (cdr p) cons)) | |
560 (if (null p) (error "enriched-delq1: Attempt to delete a non-element")) | |
561 (setq p (cdr p))) | |
562 ;; Now (cdr p) is the cons to delete | |
563 (setcdr p (cdr cons)) | |
564 list))) | |
565 | |
566 (defun enriched-make-list-uniq (list) | |
567 "Destructively remove duplicates from LIST. | |
568 Compares using `eq'." | |
569 (let ((l list)) | |
570 (while l | |
571 (setq l (setcdr l (delq (car l) (cdr l))))) | |
572 list)) | |
573 | |
574 (defun enriched-make-relatively-unique (a b) | |
575 "Delete common elements of lists A and B, return as pair. | |
576 Compares using `equal'." | |
577 (let* ((acopy (copy-sequence a)) | |
578 (bcopy (copy-sequence b)) | |
579 (tail acopy)) | |
580 (while tail | |
581 (let ((dup (member (car tail) bcopy)) | |
582 (next (cdr tail))) | |
583 (if dup (setq acopy (enriched-delq1 tail acopy) | |
584 bcopy (enriched-delq1 dup bcopy))) | |
585 (setq tail next))) | |
586 (cons acopy bcopy))) | |
587 | |
588 (defun enriched-common-tail (a b) | |
589 "Given two lists that have a common tail, return it. | |
590 Compares with `equal', and returns the part of A that is equal to the | |
591 equivalent part of B. If even the last items of the two are not equal, | |
592 returns nil." | |
593 (let ((la (length a)) | |
594 (lb (length b))) | |
595 ;; Make sure they are the same length | |
596 (while (> la lb) | |
597 (setq a (cdr a) | |
598 la (1- la))) | |
599 (while (> lb la) | |
600 (setq b (cdr b) | |
601 lb (1- lb)))) | |
602 (while (not (equal a b)) | |
603 (setq a (cdr a) | |
604 b (cdr b))) | |
605 a) | |
606 | |
607 (defun enriched-which-assoc (items list) | |
608 "Return which one of ITEMS occurs first as a car of an element of LIST." | |
609 (let (res) | |
610 (while list | |
611 (if (setq res (member (car (car list)) items)) | |
612 (setq res (car res) | |
613 list nil) | |
614 (setq list (cdr list)))) | |
615 res)) | |
616 | |
617 (defun enriched-reorder (items order) | |
618 "Arrange ITEMS to following partial ORDER. | |
619 Elements of ITEMS equal to elements of ORDER will be rearranged to follow the | |
620 ORDER. Unmatched items will go last." | |
621 (if order | |
622 (let ((item (member (car order) items))) | |
623 (if item | |
624 (cons (car item) | |
625 (enriched-reorder (enriched-delq1 item items) | |
626 (cdr order))) | |
627 (enriched-reorder items (cdr order)))) | |
628 items)) | |
629 | |
630 ;;; | |
631 ;;; Utility functions | |
632 ;;; | |
633 | |
634 (defun enriched-get-face-attribute (attr face &optional frame) | |
635 "Get an attribute of a face or list of faces. | |
636 ATTRIBUTE should be one of the functions `face-font' `face-foreground', | |
637 `face-background', or `face-underline-p'. FACE can be a face or a list of | |
638 faces. If optional argument FRAME is given, report on the face in that frame. | |
639 If FRAME is t, report on the defaults for the face in new frames. If FRAME is | |
640 omitted or nil, use the selected frame." | |
641 (cond ((null face) nil) | |
642 ((or (symbolp face) (internal-facep face)) (funcall attr face frame)) | |
643 ((funcall attr (car face) frame)) | |
644 ((enriched-get-face-attribute attr (cdr face) frame)))) | |
645 | |
646 (defun enriched-overlays-overlapping (begin end &optional test) | |
647 "Return a list of the overlays which overlap the specified region. | |
648 If optional arg TEST is given, it is called with each overlay as its | |
649 argument, and only those for which it is true are returned." | |
650 (overlay-recenter begin) | |
651 (let ((res nil) | |
652 (overlays (cdr (overlay-lists)))) ; includes all ending after BEGIN | |
653 (while overlays | |
654 (if (and (< (overlay-start (car overlays)) end) | |
655 (or (not test) | |
656 (funcall test (car overlays)))) | |
657 (enriched-push (car overlays) res)) | |
658 (setq overlays (cdr overlays))) | |
659 res)) | |
660 | |
10519
66c7e651194d
(enriched-annotation-list): property `hard-newline'
Richard M. Stallman <rms@gnu.org>
parents:
9694
diff
changeset
|
661 ;(defun enriched-show-codes (&rest which) |
66c7e651194d
(enriched-annotation-list): property `hard-newline'
Richard M. Stallman <rms@gnu.org>
parents:
9694
diff
changeset
|
662 ; "Enable or disable highlighting of special regions. |
66c7e651194d
(enriched-annotation-list): property `hard-newline'
Richard M. Stallman <rms@gnu.org>
parents:
9694
diff
changeset
|
663 ;With argument null or `none', turns off highlighting. |
66c7e651194d
(enriched-annotation-list): property `hard-newline'
Richard M. Stallman <rms@gnu.org>
parents:
9694
diff
changeset
|
664 ;If argument is `newline', turns on display of hard newlines. |
66c7e651194d
(enriched-annotation-list): property `hard-newline'
Richard M. Stallman <rms@gnu.org>
parents:
9694
diff
changeset
|
665 ;If argument is `indent', highlights the automatic indentation at the beginning |
66c7e651194d
(enriched-annotation-list): property `hard-newline'
Richard M. Stallman <rms@gnu.org>
parents:
9694
diff
changeset
|
666 ;of each line. |
66c7e651194d
(enriched-annotation-list): property `hard-newline'
Richard M. Stallman <rms@gnu.org>
parents:
9694
diff
changeset
|
667 ;If argument is `margin', highlights all regions with non-standard margins." |
66c7e651194d
(enriched-annotation-list): property `hard-newline'
Richard M. Stallman <rms@gnu.org>
parents:
9694
diff
changeset
|
668 ; (interactive |
66c7e651194d
(enriched-annotation-list): property `hard-newline'
Richard M. Stallman <rms@gnu.org>
parents:
9694
diff
changeset
|
669 ; (list (intern (completing-read "Show which codes: " |
66c7e651194d
(enriched-annotation-list): property `hard-newline'
Richard M. Stallman <rms@gnu.org>
parents:
9694
diff
changeset
|
670 ; '(("none") ("newline") ("indent") ("margin")) |
66c7e651194d
(enriched-annotation-list): property `hard-newline'
Richard M. Stallman <rms@gnu.org>
parents:
9694
diff
changeset
|
671 ; nil t)))) |
66c7e651194d
(enriched-annotation-list): property `hard-newline'
Richard M. Stallman <rms@gnu.org>
parents:
9694
diff
changeset
|
672 ; (if (null which) |
66c7e651194d
(enriched-annotation-list): property `hard-newline'
Richard M. Stallman <rms@gnu.org>
parents:
9694
diff
changeset
|
673 ; (setq enriched-show-codes nil) |
66c7e651194d
(enriched-annotation-list): property `hard-newline'
Richard M. Stallman <rms@gnu.org>
parents:
9694
diff
changeset
|
674 ; (setq enriched-show-codes which)) |
66c7e651194d
(enriched-annotation-list): property `hard-newline'
Richard M. Stallman <rms@gnu.org>
parents:
9694
diff
changeset
|
675 ; ;; First delete current overlays |
66c7e651194d
(enriched-annotation-list): property `hard-newline'
Richard M. Stallman <rms@gnu.org>
parents:
9694
diff
changeset
|
676 ; (let* ((ol (overlay-lists)) |
66c7e651194d
(enriched-annotation-list): property `hard-newline'
Richard M. Stallman <rms@gnu.org>
parents:
9694
diff
changeset
|
677 ; (overlays (append (car ol) (cdr ol)))) |
66c7e651194d
(enriched-annotation-list): property `hard-newline'
Richard M. Stallman <rms@gnu.org>
parents:
9694
diff
changeset
|
678 ; (while overlays |
66c7e651194d
(enriched-annotation-list): property `hard-newline'
Richard M. Stallman <rms@gnu.org>
parents:
9694
diff
changeset
|
679 ; (if (eq (overlay-get (car overlays) 'face) 'enriched-code-face) |
66c7e651194d
(enriched-annotation-list): property `hard-newline'
Richard M. Stallman <rms@gnu.org>
parents:
9694
diff
changeset
|
680 ; (delete-overlay (car overlays))) |
66c7e651194d
(enriched-annotation-list): property `hard-newline'
Richard M. Stallman <rms@gnu.org>
parents:
9694
diff
changeset
|
681 ; (setq overlays (cdr overlays)))) |
66c7e651194d
(enriched-annotation-list): property `hard-newline'
Richard M. Stallman <rms@gnu.org>
parents:
9694
diff
changeset
|
682 ; ;; Now add new ones for each thing displayed. |
66c7e651194d
(enriched-annotation-list): property `hard-newline'
Richard M. Stallman <rms@gnu.org>
parents:
9694
diff
changeset
|
683 ; (if (null which) |
66c7e651194d
(enriched-annotation-list): property `hard-newline'
Richard M. Stallman <rms@gnu.org>
parents:
9694
diff
changeset
|
684 ; (message "Code display off.")) |
66c7e651194d
(enriched-annotation-list): property `hard-newline'
Richard M. Stallman <rms@gnu.org>
parents:
9694
diff
changeset
|
685 ; (while which |
66c7e651194d
(enriched-annotation-list): property `hard-newline'
Richard M. Stallman <rms@gnu.org>
parents:
9694
diff
changeset
|
686 ; (cond ((eq (car which) 'margin) |
66c7e651194d
(enriched-annotation-list): property `hard-newline'
Richard M. Stallman <rms@gnu.org>
parents:
9694
diff
changeset
|
687 ; (enriched-show-margin-codes)) |
66c7e651194d
(enriched-annotation-list): property `hard-newline'
Richard M. Stallman <rms@gnu.org>
parents:
9694
diff
changeset
|
688 ; ((eq (car which) 'indent) |
66c7e651194d
(enriched-annotation-list): property `hard-newline'
Richard M. Stallman <rms@gnu.org>
parents:
9694
diff
changeset
|
689 ; (enriched-map-property-regions 'enriched-indentation |
66c7e651194d
(enriched-annotation-list): property `hard-newline'
Richard M. Stallman <rms@gnu.org>
parents:
9694
diff
changeset
|
690 ; (lambda (v b e) |
66c7e651194d
(enriched-annotation-list): property `hard-newline'
Richard M. Stallman <rms@gnu.org>
parents:
9694
diff
changeset
|
691 ; (if v (enriched-show-region-as-code b e 'indent))))) |
66c7e651194d
(enriched-annotation-list): property `hard-newline'
Richard M. Stallman <rms@gnu.org>
parents:
9694
diff
changeset
|
692 ; ((eq (car which) 'newline) |
66c7e651194d
(enriched-annotation-list): property `hard-newline'
Richard M. Stallman <rms@gnu.org>
parents:
9694
diff
changeset
|
693 ; (save-excursion |
66c7e651194d
(enriched-annotation-list): property `hard-newline'
Richard M. Stallman <rms@gnu.org>
parents:
9694
diff
changeset
|
694 ; (goto-char (point-min)) |
66c7e651194d
(enriched-annotation-list): property `hard-newline'
Richard M. Stallman <rms@gnu.org>
parents:
9694
diff
changeset
|
695 ; (while (enriched-search-forward-with-props |
66c7e651194d
(enriched-annotation-list): property `hard-newline'
Richard M. Stallman <rms@gnu.org>
parents:
9694
diff
changeset
|
696 ; enriched-hard-newline nil t) |
66c7e651194d
(enriched-annotation-list): property `hard-newline'
Richard M. Stallman <rms@gnu.org>
parents:
9694
diff
changeset
|
697 ; (enriched-show-region-as-code (match-beginning 0) (match-end 0) |
66c7e651194d
(enriched-annotation-list): property `hard-newline'
Richard M. Stallman <rms@gnu.org>
parents:
9694
diff
changeset
|
698 ; 'newline))))) |
66c7e651194d
(enriched-annotation-list): property `hard-newline'
Richard M. Stallman <rms@gnu.org>
parents:
9694
diff
changeset
|
699 ; (setq which (cdr which)))) |
9676 | 700 |
10519
66c7e651194d
(enriched-annotation-list): property `hard-newline'
Richard M. Stallman <rms@gnu.org>
parents:
9694
diff
changeset
|
701 ;(defun enriched-show-margin-codes (&optional from to) |
66c7e651194d
(enriched-annotation-list): property `hard-newline'
Richard M. Stallman <rms@gnu.org>
parents:
9694
diff
changeset
|
702 ; "Highlight regions with nonstandard left-margins. |
66c7e651194d
(enriched-annotation-list): property `hard-newline'
Richard M. Stallman <rms@gnu.org>
parents:
9694
diff
changeset
|
703 ;See `enriched-show-codes'." |
66c7e651194d
(enriched-annotation-list): property `hard-newline'
Richard M. Stallman <rms@gnu.org>
parents:
9694
diff
changeset
|
704 ; (enriched-map-property-regions 'left-margin |
66c7e651194d
(enriched-annotation-list): property `hard-newline'
Richard M. Stallman <rms@gnu.org>
parents:
9694
diff
changeset
|
705 ; (lambda (v b e) |
66c7e651194d
(enriched-annotation-list): property `hard-newline'
Richard M. Stallman <rms@gnu.org>
parents:
9694
diff
changeset
|
706 ; (if (and v (> v 0)) |
66c7e651194d
(enriched-annotation-list): property `hard-newline'
Richard M. Stallman <rms@gnu.org>
parents:
9694
diff
changeset
|
707 ; (enriched-show-region-as-code b e 'margin))) |
66c7e651194d
(enriched-annotation-list): property `hard-newline'
Richard M. Stallman <rms@gnu.org>
parents:
9694
diff
changeset
|
708 ; from to) |
66c7e651194d
(enriched-annotation-list): property `hard-newline'
Richard M. Stallman <rms@gnu.org>
parents:
9694
diff
changeset
|
709 ; (enriched-map-property-regions 'right-margin |
66c7e651194d
(enriched-annotation-list): property `hard-newline'
Richard M. Stallman <rms@gnu.org>
parents:
9694
diff
changeset
|
710 ; (lambda (v b e) |
66c7e651194d
(enriched-annotation-list): property `hard-newline'
Richard M. Stallman <rms@gnu.org>
parents:
9694
diff
changeset
|
711 ; (if (and v (> v 0)) |
66c7e651194d
(enriched-annotation-list): property `hard-newline'
Richard M. Stallman <rms@gnu.org>
parents:
9694
diff
changeset
|
712 ; (enriched-show-region-as-code b e 'margin))) |
66c7e651194d
(enriched-annotation-list): property `hard-newline'
Richard M. Stallman <rms@gnu.org>
parents:
9694
diff
changeset
|
713 ; from to)) |
9676 | 714 |
10519
66c7e651194d
(enriched-annotation-list): property `hard-newline'
Richard M. Stallman <rms@gnu.org>
parents:
9694
diff
changeset
|
715 ;(defun enriched-show-region-as-code (from to type) |
66c7e651194d
(enriched-annotation-list): property `hard-newline'
Richard M. Stallman <rms@gnu.org>
parents:
9694
diff
changeset
|
716 ; "Display region between FROM and TO as a code if TYPE is displayed. |
66c7e651194d
(enriched-annotation-list): property `hard-newline'
Richard M. Stallman <rms@gnu.org>
parents:
9694
diff
changeset
|
717 ;Displays it only if TYPE is an element of `enriched-show-codes' or is t." |
66c7e651194d
(enriched-annotation-list): property `hard-newline'
Richard M. Stallman <rms@gnu.org>
parents:
9694
diff
changeset
|
718 ; (if (or (eq t type) (memq type enriched-show-codes)) |
66c7e651194d
(enriched-annotation-list): property `hard-newline'
Richard M. Stallman <rms@gnu.org>
parents:
9694
diff
changeset
|
719 ; (let* ((old (enriched-overlays-overlapping |
66c7e651194d
(enriched-annotation-list): property `hard-newline'
Richard M. Stallman <rms@gnu.org>
parents:
9694
diff
changeset
|
720 ; from to (lambda (o) |
66c7e651194d
(enriched-annotation-list): property `hard-newline'
Richard M. Stallman <rms@gnu.org>
parents:
9694
diff
changeset
|
721 ; (eq 'enriched-code-face |
66c7e651194d
(enriched-annotation-list): property `hard-newline'
Richard M. Stallman <rms@gnu.org>
parents:
9694
diff
changeset
|
722 ; (overlay-get o 'face))))) |
66c7e651194d
(enriched-annotation-list): property `hard-newline'
Richard M. Stallman <rms@gnu.org>
parents:
9694
diff
changeset
|
723 ; (new (if old (move-overlay (car old) from to) |
66c7e651194d
(enriched-annotation-list): property `hard-newline'
Richard M. Stallman <rms@gnu.org>
parents:
9694
diff
changeset
|
724 ; (make-overlay from to)))) |
66c7e651194d
(enriched-annotation-list): property `hard-newline'
Richard M. Stallman <rms@gnu.org>
parents:
9694
diff
changeset
|
725 ; (overlay-put new 'face 'enriched-code-face) |
66c7e651194d
(enriched-annotation-list): property `hard-newline'
Richard M. Stallman <rms@gnu.org>
parents:
9694
diff
changeset
|
726 ; (overlay-put new 'front-nogrow t) |
66c7e651194d
(enriched-annotation-list): property `hard-newline'
Richard M. Stallman <rms@gnu.org>
parents:
9694
diff
changeset
|
727 ; (if (eq type 'margin) |
66c7e651194d
(enriched-annotation-list): property `hard-newline'
Richard M. Stallman <rms@gnu.org>
parents:
9694
diff
changeset
|
728 ; (overlay-put new 'rear-grow t)) |
66c7e651194d
(enriched-annotation-list): property `hard-newline'
Richard M. Stallman <rms@gnu.org>
parents:
9694
diff
changeset
|
729 ; (while (setq old (cdr old)) |
66c7e651194d
(enriched-annotation-list): property `hard-newline'
Richard M. Stallman <rms@gnu.org>
parents:
9694
diff
changeset
|
730 ; (delete-overlay (car old)))))) |
9676 | 731 |
10519
66c7e651194d
(enriched-annotation-list): property `hard-newline'
Richard M. Stallman <rms@gnu.org>
parents:
9694
diff
changeset
|
732 ;(defun enriched-nogrow-hook (beg end old-length) |
66c7e651194d
(enriched-annotation-list): property `hard-newline'
Richard M. Stallman <rms@gnu.org>
parents:
9694
diff
changeset
|
733 ; "Implement front-nogrow and rear-grow for overlays. |
66c7e651194d
(enriched-annotation-list): property `hard-newline'
Richard M. Stallman <rms@gnu.org>
parents:
9694
diff
changeset
|
734 ;Normally overlays have opposite inheritance properties than |
66c7e651194d
(enriched-annotation-list): property `hard-newline'
Richard M. Stallman <rms@gnu.org>
parents:
9694
diff
changeset
|
735 ;text-properties: they will expand to include text inserted at their |
66c7e651194d
(enriched-annotation-list): property `hard-newline'
Richard M. Stallman <rms@gnu.org>
parents:
9694
diff
changeset
|
736 ;beginning, but not text inserted at their end. However, |
66c7e651194d
(enriched-annotation-list): property `hard-newline'
Richard M. Stallman <rms@gnu.org>
parents:
9694
diff
changeset
|
737 ;if this function is an element of `after-change-functions', then |
66c7e651194d
(enriched-annotation-list): property `hard-newline'
Richard M. Stallman <rms@gnu.org>
parents:
9694
diff
changeset
|
738 ;overlays with a non-nil value of the `front-nogrow' property will not |
66c7e651194d
(enriched-annotation-list): property `hard-newline'
Richard M. Stallman <rms@gnu.org>
parents:
9694
diff
changeset
|
739 ;expand to include text that is inserted just in front of them, and |
66c7e651194d
(enriched-annotation-list): property `hard-newline'
Richard M. Stallman <rms@gnu.org>
parents:
9694
diff
changeset
|
740 ;overlays with a non-nil value of the `rear-grow' property will |
66c7e651194d
(enriched-annotation-list): property `hard-newline'
Richard M. Stallman <rms@gnu.org>
parents:
9694
diff
changeset
|
741 ;expand to include text that is inserted just after them." |
66c7e651194d
(enriched-annotation-list): property `hard-newline'
Richard M. Stallman <rms@gnu.org>
parents:
9694
diff
changeset
|
742 ; (if (not (zerop old-length)) |
66c7e651194d
(enriched-annotation-list): property `hard-newline'
Richard M. Stallman <rms@gnu.org>
parents:
9694
diff
changeset
|
743 ; nil ;; not an insertion |
66c7e651194d
(enriched-annotation-list): property `hard-newline'
Richard M. Stallman <rms@gnu.org>
parents:
9694
diff
changeset
|
744 ; (let ((overlays (overlays-at end)) o) |
66c7e651194d
(enriched-annotation-list): property `hard-newline'
Richard M. Stallman <rms@gnu.org>
parents:
9694
diff
changeset
|
745 ; (while overlays |
66c7e651194d
(enriched-annotation-list): property `hard-newline'
Richard M. Stallman <rms@gnu.org>
parents:
9694
diff
changeset
|
746 ; (setq o (car overlays) |
66c7e651194d
(enriched-annotation-list): property `hard-newline'
Richard M. Stallman <rms@gnu.org>
parents:
9694
diff
changeset
|
747 ; overlays (cdr overlays)) |
66c7e651194d
(enriched-annotation-list): property `hard-newline'
Richard M. Stallman <rms@gnu.org>
parents:
9694
diff
changeset
|
748 ; (if (and (overlay-get o 'front-nogrow) |
66c7e651194d
(enriched-annotation-list): property `hard-newline'
Richard M. Stallman <rms@gnu.org>
parents:
9694
diff
changeset
|
749 ; (= beg (overlay-start o))) |
66c7e651194d
(enriched-annotation-list): property `hard-newline'
Richard M. Stallman <rms@gnu.org>
parents:
9694
diff
changeset
|
750 ; (move-overlay o end (overlay-end o))))) |
66c7e651194d
(enriched-annotation-list): property `hard-newline'
Richard M. Stallman <rms@gnu.org>
parents:
9694
diff
changeset
|
751 ; (let ((overlays (overlays-at (1- beg))) o) |
66c7e651194d
(enriched-annotation-list): property `hard-newline'
Richard M. Stallman <rms@gnu.org>
parents:
9694
diff
changeset
|
752 ; (while overlays |
66c7e651194d
(enriched-annotation-list): property `hard-newline'
Richard M. Stallman <rms@gnu.org>
parents:
9694
diff
changeset
|
753 ; (setq o (car overlays) |
66c7e651194d
(enriched-annotation-list): property `hard-newline'
Richard M. Stallman <rms@gnu.org>
parents:
9694
diff
changeset
|
754 ; overlays (cdr overlays)) |
66c7e651194d
(enriched-annotation-list): property `hard-newline'
Richard M. Stallman <rms@gnu.org>
parents:
9694
diff
changeset
|
755 ; (if (and (overlay-get o 'rear-grow) |
66c7e651194d
(enriched-annotation-list): property `hard-newline'
Richard M. Stallman <rms@gnu.org>
parents:
9694
diff
changeset
|
756 ; (= beg (overlay-end o))) |
66c7e651194d
(enriched-annotation-list): property `hard-newline'
Richard M. Stallman <rms@gnu.org>
parents:
9694
diff
changeset
|
757 ; (move-overlay o (overlay-start o) end)))))) |
9676 | 758 |
759 (defun enriched-warn (&rest args) | |
760 "Display a warning message. | |
761 Arguments are given to `format' and the result is displayed in a buffer." | |
762 (save-excursion | |
763 (let ((buf (current-buffer)) | |
764 (line (1+ (count-lines 1 (point)))) | |
765 (mark (point-marker))) | |
766 (pop-to-buffer (get-buffer-create "*Enriched Warnings*")) | |
767 (goto-char (point-max)) | |
768 (insert | |
769 ; (format "%s:%d: " (if (boundp 'enriched-file) enriched-file | |
770 ; (buffer-file-name buf)) | |
771 ; line) | |
772 (apply (function format) args) | |
773 "\n") | |
774 (pop-to-buffer buf)))) | |
775 | |
776 (defun enriched-looking-at-with-props (string) | |
777 "True if text at point is equal to STRING, including text props. | |
778 This is a literal, not a regexp match. | |
779 The buffer text must include all text properties that STRING has, in | |
780 the same places, but it is allowed to have others that STRING lacks." | |
781 (let ((buffer-string (buffer-substring (point) (+ (point) (length string))))) | |
782 (and (string-equal string buffer-string) | |
783 (enriched-text-properties-include string buffer-string)))) | |
784 | |
785 (defun enriched-search-forward-with-props | |
786 (string &optional bound noerror count) | |
787 "Search forward for STRING, including its text properties. | |
788 Set point to end of occurrence found, and return point. | |
789 The match found must include all text properties that STRING has, in | |
790 the same places, but it is allowed to have others that STRING lacks. | |
791 An optional second argument bounds the search; it is a buffer position. | |
792 The match found must not extend after that position. nil is equivalent | |
793 to (point-max). | |
794 Optional third argument, if t, means if fail just return nil (no error). | |
795 If not nil and not t, move to limit of search and return nil. | |
796 Optional fourth argument is repeat count--search for successive occurrences. | |
797 See also the functions `match-beginning', `match-end' and `replace-match'." | |
798 (interactive "sSearch for: ") | |
799 (or bound (setq bound (point-max))) | |
800 (or count (setq count 1)) | |
801 (let ((start (point)) | |
802 (res t)) | |
803 (while (and res (> count 0)) | |
804 (while (and (setq res (search-forward string bound t)) | |
805 (not (enriched-text-properties-include | |
806 string (buffer-substring (match-beginning 0) | |
807 (match-end 0)))))) | |
808 (setq count (1- count))) | |
809 (cond (res) | |
810 ((eq noerror t) (goto-char start) nil) | |
811 (noerror (goto-char bound) nil) | |
812 (t (goto-char start) | |
813 (error "Search failed: %s" string))))) | |
814 | |
815 (defun enriched-search-backward-with-props | |
816 (string &optional bound noerror count) | |
817 "Search backward for STRING, including its text properties. | |
818 Set point to the beginning of occurrence found, and return point. | |
819 The match found must include all text properties that STRING has, in | |
820 the same places, but it is allowed to have others that STRING lacks. | |
821 An optional second argument bounds the search; it is a buffer position. | |
822 The match found must not start before that position. nil is equivalent | |
823 to (point-min). | |
824 Optional third argument, if t, means if fail just return nil (no error). | |
825 If not nil and not t, move to limit of search and return nil. | |
826 Optional fourth argument is repeat count--search for successive occurrences. | |
827 See also the functions `match-beginning', `match-end' and `replace-match'." | |
828 (interactive "sSearch for: ") | |
829 (or bound (setq bound (point-min))) | |
830 (or count (setq count 1)) | |
831 (let ((start (point)) | |
832 (res t)) | |
833 (while (and res (> count 0)) | |
834 (while (and (setq res (search-backward string bound t)) | |
835 (not (enriched-text-properties-include | |
836 string (buffer-substring (match-beginning 0) | |
837 (match-end 0)))))) | |
838 (setq count (1- count))) | |
839 (cond (res) | |
840 ((eq noerror t) (goto-char start) nil) | |
841 (noerror (goto-char bound) nil) | |
842 (t (goto-char start) | |
843 (error "Search failed: %s" string))))) | |
844 | |
845 (defun enriched-text-properties-include (a b) | |
846 "True if all of A's text-properties are also properties of B. | |
847 They must match in property name, value, and position. B must be at least as | |
848 long as A, but comparison is done only up to the length of A." | |
849 (let ((loc (length a))) | |
850 (catch 'fail | |
851 (while (>= loc 0) | |
852 (let ((plist (text-properties-at loc a))) | |
853 (while plist | |
854 (if (not (equal (car (cdr plist)) | |
855 (get-text-property loc (car plist) b))) | |
856 (throw 'fail nil)) | |
857 (setq plist (cdr (cdr plist))))) | |
858 (setq loc (1- loc))) | |
859 t))) | |
860 | |
861 (defun enriched-map-property-regions (prop func &optional from to) | |
862 "Apply a function to regions of the buffer based on a text property. | |
863 For each contiguous region of the buffer for which the value of PROPERTY is | |
864 eq, the FUNCTION will be called. Optional arguments FROM and TO specify the | |
865 region over which to scan. | |
866 | |
867 The specified function receives three arguments: the VALUE of the property in | |
868 the region, and the START and END of each region." | |
869 (save-excursion | |
870 (save-restriction | |
871 (if to (narrow-to-region (point-min) to)) | |
872 (goto-char (or from (point-min))) | |
873 (let ((begin (point)) | |
874 end | |
875 (marker (make-marker)) | |
876 (val (get-text-property (point) prop))) | |
877 (while (setq end (text-property-not-all begin (point-max) prop val)) | |
878 (move-marker marker end) | |
879 (funcall func val begin (marker-position marker)) | |
880 (setq begin (marker-position marker) | |
881 val (get-text-property marker prop))) | |
882 (if (< begin (point-max)) | |
883 (funcall func val begin (point-max))))))) | |
884 | |
885 (put 'enriched-map-property-regions 'lisp-indent-hook 1) | |
886 | |
887 (defun enriched-insert-annotations (list &optional offset) | |
888 "Apply list of annotations to buffer as write-region would. | |
889 Inserts each element of LIST of buffer annotations at its appropriate place. | |
890 Use second arg OFFSET if the annotations' locations are not | |
891 relative to the beginning of the buffer: annotations will be inserted | |
892 at their location-OFFSET+1 \(ie, the offset is the character number of | |
893 the first character in the buffer)." | |
894 (if (not offset) | |
895 (setq offset 0) | |
896 (setq offset (1- offset))) | |
897 (let ((l (reverse list))) | |
898 (while l | |
899 (goto-char (- (car (car l)) offset)) | |
900 (insert (cdr (car l))) | |
901 (setq l (cdr l))))) | |
902 | |
903 ;;; | |
904 ;;; Indentation, Filling, Justification | |
905 ;;; | |
906 | |
907 (defun enriched-text-width () | |
908 "The width of unindented text in this window, in characters. | |
909 This is the width of the window minus `enriched-default-right-margin'." | |
910 (or enriched-text-width | |
911 (let ((ww (window-width))) | |
912 (setq enriched-text-width | |
913 (if (> ww enriched-default-right-margin) | |
914 (- ww enriched-default-right-margin) | |
915 ww))))) | |
916 | |
917 (defun enriched-tag-indentation (from to) | |
918 "Define region to be indentation." | |
919 (add-text-properties from to '(enriched-indentation t | |
920 rear-nonsticky (enriched-indentation)))) | |
921 | |
922 (defun enriched-insert-indentation (&optional from to) | |
923 "Indent and justify each line in the region." | |
924 (save-excursion | |
925 (save-restriction | |
926 (if to (narrow-to-region (point-min) to)) | |
927 (goto-char (or from (point-min))) | |
928 (if (not (bolp)) (forward-line 1)) | |
929 (while (not (eobp)) | |
10519
66c7e651194d
(enriched-annotation-list): property `hard-newline'
Richard M. Stallman <rms@gnu.org>
parents:
9694
diff
changeset
|
930 (indent-to (current-left-margin)) |
66c7e651194d
(enriched-annotation-list): property `hard-newline'
Richard M. Stallman <rms@gnu.org>
parents:
9694
diff
changeset
|
931 (justify-current-line t nil t) |
9676 | 932 (forward-line 1))))) |
933 | |
934 (defun enriched-delete-indentation (&optional from to) | |
935 "Remove indentation and justification from region. | |
936 Does not alter the left-margin and right-margin text properties, so the | |
937 indentation can be reconstructed. Tries only to remove whitespace that was | |
938 added automatically, not spaces and tabs inserted by user." | |
939 (save-excursion | |
940 (save-restriction | |
941 (if to (narrow-to-region (point-min) to)) | |
942 (if from | |
943 (progn (goto-char from) | |
944 (if (not (bolp)) (forward-line 1)) | |
10519
66c7e651194d
(enriched-annotation-list): property `hard-newline'
Richard M. Stallman <rms@gnu.org>
parents:
9694
diff
changeset
|
945 (setq from (point))) |
66c7e651194d
(enriched-annotation-list): property `hard-newline'
Richard M. Stallman <rms@gnu.org>
parents:
9694
diff
changeset
|
946 (setq from (point-min))) |
66c7e651194d
(enriched-annotation-list): property `hard-newline'
Richard M. Stallman <rms@gnu.org>
parents:
9694
diff
changeset
|
947 (delete-to-left-margin from (point-max)) |
9676 | 948 (enriched-map-property-regions 'justification |
949 (lambda (v b e) | |
10519
66c7e651194d
(enriched-annotation-list): property `hard-newline'
Richard M. Stallman <rms@gnu.org>
parents:
9694
diff
changeset
|
950 (if (eq v 'full) |
66c7e651194d
(enriched-annotation-list): property `hard-newline'
Richard M. Stallman <rms@gnu.org>
parents:
9694
diff
changeset
|
951 (canonically-space-region b e))) |
9676 | 952 from nil)))) |
953 | |
954 ;;; | |
955 ;;; Writing Files | |
956 ;;; | |
957 | |
958 (defsubst enriched-open-annotation (name) | |
959 (insert-and-inherit (enriched-make-annotation name t))) | |
960 | |
961 (defsubst enriched-close-annotation (name) | |
962 (insert-and-inherit (enriched-make-annotation name nil))) | |
963 | |
964 (defun enriched-annotate-function (start end) | |
965 "For use on write-region-annotations-functions. | |
966 Makes a new buffer containing the region in text/enriched format." | |
967 (if enriched-mode | |
968 (let (;(enriched-file (file-name-nondirectory buffer-file-name)) | |
969 (copy-buf (generate-new-buffer "*Enriched Temp*"))) | |
970 (copy-to-buffer copy-buf start end) | |
971 (set-buffer copy-buf) | |
972 (enriched-insert-annotations write-region-annotations-so-far start) | |
973 (setq write-region-annotations-so-far nil) | |
974 (enriched-encode-region))) | |
975 nil) | |
976 | |
977 (defun enriched-encode-region (&optional from to) | |
978 "Transform buffer into text/enriched format." | |
979 (if enriched-verbose (message "Enriched: encoding document...")) | |
980 (setq enriched-ignored-list enriched-ignored-ok) | |
981 (save-excursion | |
982 (save-restriction | |
983 (if to (narrow-to-region (point-min) to)) | |
984 (enriched-delete-indentation from to) | |
985 (let ((enriched-open-ans nil) | |
986 (inhibit-read-only t)) | |
987 (goto-char (or from (point-min))) | |
988 (insert (if (stringp enriched-initial-annotation) | |
989 enriched-initial-annotation | |
990 (funcall enriched-initial-annotation))) | |
991 (while | |
992 (let* ((ans (enriched-loc-annotations (point))) | |
993 (neg-ans (enriched-reorder (car ans) enriched-open-ans)) | |
994 (pos-ans (cdr ans))) | |
995 ;; First do the negative (closing) annotations | |
996 (while neg-ans | |
997 (if (not (member (car neg-ans) enriched-open-ans)) | |
998 (enriched-warn "BUG DETECTED: Closing %s with open list=%s" | |
999 (enriched-pop neg-ans) enriched-open-ans) | |
1000 (while (not (equal (car neg-ans) (car enriched-open-ans))) | |
1001 ;; To close anno. N, need to first close ans 1 to N-1, | |
1002 ;; remembering to re-open them later. | |
1003 (enriched-push (car enriched-open-ans) pos-ans) | |
1004 (enriched-close-annotation (enriched-pop enriched-open-ans))) | |
1005 ;; Now we can safely close this anno & remove from open list | |
1006 (enriched-close-annotation (enriched-pop neg-ans)) | |
1007 (enriched-pop enriched-open-ans))) | |
1008 ;; Now deal with positive (opening) annotations | |
1009 (while pos-ans | |
1010 (enriched-push (car pos-ans) enriched-open-ans) | |
1011 (enriched-open-annotation (enriched-pop pos-ans))) | |
1012 (enriched-move-to-next-property-change))) | |
1013 | |
1014 ;; Close up shop... | |
1015 (goto-char (point-max)) | |
1016 (while enriched-open-ans | |
1017 (enriched-close-annotation (enriched-pop enriched-open-ans))) | |
1018 (if (not (= ?\n (char-after (1- (point))))) | |
1019 (insert ?\n))) | |
1020 (if (and enriched-verbose (> (length enriched-ignored-list) | |
1021 (length enriched-ignored-ok))) | |
1022 (let ((not-ok nil)) | |
1023 (while (not (eq enriched-ignored-list enriched-ignored-ok)) | |
1024 (setq not-ok (cons (car enriched-ignored-list) not-ok) | |
1025 enriched-ignored-list (cdr enriched-ignored-list))) | |
1026 (enriched-warn "Not recorded: %s" not-ok) | |
1027 (sit-for 1)))))) | |
1028 | |
1029 (defun enriched-move-to-next-property-change () | |
1030 "Advance point to next prop change, dealing with special items on the way. | |
1031 Returns the location, or nil." | |
1032 (let ((prop-change (next-property-change (point)))) | |
1033 (while (and (< (point) (or prop-change (point-max))) | |
1034 (search-forward enriched-encode-interesting-regexp | |
1035 prop-change 1)) | |
1036 (goto-char (match-beginning 0)) | |
1037 (let ((specials enriched-encode-special-alist)) | |
1038 (while specials | |
1039 (if (enriched-looking-at-with-props (car (car specials))) | |
1040 (progn (goto-char (match-end 0)) | |
1041 (funcall (cdr (car specials))) | |
1042 (setq specials nil)) | |
1043 (enriched-pop specials))))) | |
1044 prop-change)) | |
1045 | |
1046 (defun enriched-loc-annotations (loc) | |
1047 "Return annotation(s) needed at LOCATION. | |
1048 This includes any properties that change between LOC-1 and LOC. | |
1049 If LOC is at the beginning of the buffer, will generate annotations for any | |
1050 non-nil properties there, plus the enriched-version annotation. | |
1051 Annotations are returned as a list. The car of the list is the list of | |
1052 names of the annotations to close, and the cdr is the list of the names of the | |
1053 annotations to open." | |
1054 (let* ((prev-loc (1- loc)) | |
1055 (begin (< prev-loc (point-min))) | |
1056 (before-plist (if begin nil (text-properties-at prev-loc))) | |
1057 (after-plist (text-properties-at loc)) | |
1058 negatives positives prop props) | |
1059 ;; make list of all property names involved | |
1060 (while before-plist | |
1061 (enriched-push (car before-plist) props) | |
1062 (setq before-plist (cdr (cdr before-plist)))) | |
1063 (while after-plist | |
1064 (enriched-push (car after-plist) props) | |
1065 (setq after-plist (cdr (cdr after-plist)))) | |
1066 (setq props (enriched-make-list-uniq props)) | |
1067 | |
1068 (while props | |
1069 (setq prop (enriched-pop props)) | |
1070 (if (memq prop enriched-ignored-list) | |
1071 nil ; If its been ignored before, ignore it now. | |
1072 (let ((before (if begin nil (get-text-property prev-loc prop))) | |
1073 (after (get-text-property loc prop))) | |
1074 (if (equal before after) | |
1075 nil ; no change; ignore | |
1076 (let ((result (enriched-annotate-change prop before after))) | |
1077 (setq negatives (nconc negatives (car result)) | |
1078 positives (nconc positives (cdr result)))))))) | |
1079 (cons negatives positives))) | |
1080 | |
1081 (defun enriched-annotate-change (prop old new) | |
1082 "Return annotations for PROPERTY changing from OLD to NEW. | |
1083 These are searched for in `enriched-annotation-list'. | |
1084 If NEW does not appear in the list, but there is a default function, then that | |
1085 function is called. | |
1086 Annotations are returned as a list, as in `enriched-loc-annotations'." | |
1087 ;; If property is numeric, nil means 0 | |
1088 (if (or (consp old) (consp new)) | |
1089 (let* ((old (if (listp old) old (list old))) | |
1090 (new (if (listp new) new (list new))) | |
1091 (tail (enriched-common-tail old new)) | |
1092 close open) | |
1093 (while old | |
1094 (setq close | |
1095 (append (car (enriched-annotate-change prop (car old) nil)) | |
1096 close) | |
1097 old (cdr old))) | |
1098 (while new | |
1099 (setq open | |
1100 (append (cdr (enriched-annotate-change prop nil (car new))) | |
1101 open) | |
1102 new (cdr new))) | |
1103 (enriched-make-relatively-unique close open)) | |
1104 (cond ((and (numberp old) (null new)) | |
1105 (setq new 0)) | |
1106 ((and (numberp new) (null old)) | |
1107 (setq old 0))) | |
1108 (let ((prop-alist (cdr (assoc prop enriched-annotation-alist))) | |
1109 default) | |
1110 (cond ((null prop-alist) ; not found | |
1111 (if (not (memq prop enriched-ignored-list)) | |
1112 (enriched-push prop enriched-ignored-list)) | |
1113 nil) | |
1114 | |
1115 ;; Numerical values: use the difference | |
1116 ((and (numberp old) (numberp new)) | |
1117 (let* ((entry (progn | |
1118 (while (and (car (car prop-alist)) | |
1119 (not (numberp (car (car prop-alist))))) | |
1120 (enriched-pop prop-alist)) | |
1121 (car prop-alist))) | |
1122 (increment (car (car prop-alist))) | |
1123 (n (ceiling (/ (float (- new old)) (float increment)))) | |
1124 (anno (car (cdr (car prop-alist))))) | |
1125 (if (> n 0) | |
1126 (cons nil (make-list n anno)) | |
1127 (cons (make-list (- n) anno) nil)))) | |
1128 | |
1129 ;; Standard annotation | |
1130 (t (let ((close (and old (cdr (assoc old prop-alist)))) | |
1131 (open (and new (cdr (assoc new prop-alist))))) | |
1132 (if (or close open) | |
1133 (enriched-make-relatively-unique close open) | |
1134 (let ((default (assoc nil prop-alist))) | |
1135 (if default | |
1136 (funcall (car (cdr default)) old new)))))))))) | |
1137 | |
1138 ;;; | |
1139 ;;; Reading files | |
1140 ;;; | |
1141 | |
1142 (defun enriched-decode-region (&optional from to) | |
1143 "Decode text/enriched buffer into text with properties. | |
1144 This is the primary entry point for decoding." | |
1145 (if enriched-verbose (message "Enriched: decoding document...")) | |
1146 (save-excursion | |
1147 (save-restriction | |
1148 (if to (narrow-to-region (point-min) to)) | |
1149 (goto-char (or from (point-min))) | |
1150 (let ((file-width (enriched-get-file-width)) | |
1151 (inhibit-read-only t) | |
1152 enriched-open-ans todo loc unknown-ans) | |
1153 | |
1154 (while (enriched-move-to-next-annotation) | |
1155 (let* ((loc (match-beginning 0)) | |
1156 (anno (buffer-substring (match-beginning 0) (match-end 0))) | |
1157 (name (enriched-annotation-name anno)) | |
1158 (positive (enriched-annotation-positive-p anno))) | |
1159 | |
1160 (if enriched-downcase-annotations | |
1161 (setq name (downcase name))) | |
1162 | |
1163 (delete-region (match-beginning 0) (match-end 0)) | |
1164 (if positive | |
1165 (enriched-push (list name loc) enriched-open-ans) | |
1166 ;; negative... | |
1167 (let* ((top (car enriched-open-ans)) | |
1168 (top-name (car top)) | |
1169 (start (car (cdr top))) | |
1170 (params (cdr (cdr top))) | |
1171 (aalist enriched-annotation-alist) | |
1172 (matched nil)) | |
1173 (if (not (equal name top-name)) | |
1174 (error (format "Improper nesting in file: %s != %s" | |
1175 name top))) | |
1176 (while aalist | |
1177 (let ((prop (car (car aalist))) | |
1178 (alist (cdr (car aalist)))) | |
1179 (while alist | |
1180 (let ((value (car (car alist))) | |
1181 (ans (cdr (car alist)))) | |
1182 (if (member name ans) | |
1183 ;; Check if multiple annotations are satisfied | |
1184 (if (member 'nil (mapcar | |
1185 (lambda (r) | |
1186 (assoc r enriched-open-ans)) | |
1187 ans)) | |
1188 nil ; multiple ans not satisfied | |
1189 ;; Yes, we got it: | |
1190 (setq alist nil aalist nil matched t | |
1191 enriched-open-ans (cdr enriched-open-ans)) | |
1192 (cond | |
1193 ((eq prop 'PARAMETER) | |
1194 ;; This is a parameter of the top open ann. | |
1195 (let ((nxt (enriched-pop enriched-open-ans))) | |
1196 (if nxt | |
1197 (enriched-push | |
1198 (append | |
1199 nxt | |
1200 (list (buffer-substring start loc))) | |
1201 enriched-open-ans)) | |
1202 (delete-region start loc))) | |
1203 ((eq prop 'FUNCTION) | |
1204 (let ((rtn (apply value start loc params))) | |
1205 (if rtn (enriched-push rtn todo)))) | |
1206 (t | |
1207 ;; Normal property/value pair | |
1208 (enriched-push (list start loc prop value) | |
1209 todo)))))) | |
1210 (enriched-pop alist))) | |
1211 (enriched-pop aalist)) | |
1212 (if matched | |
1213 nil | |
1214 ;; Didn't find it | |
1215 (enriched-pop enriched-open-ans) | |
1216 (enriched-push (list start loc 'unknown name) todo) | |
1217 (enriched-push name unknown-ans)))))) | |
1218 | |
1219 ;; Now actually add the properties | |
1220 | |
1221 (while todo | |
1222 (let* ((item (enriched-pop todo)) | |
1223 (from (elt item 0)) | |
1224 (to (elt item 1)) | |
1225 (prop (elt item 2)) | |
1226 (val (elt item 3))) | |
1227 | |
1228 ; (if (and (eq prop 'IGNORE) ; 'IGNORE' pseudo-property was special | |
1229 ; (eq val t)) | |
1230 ; (delete-region from to)) | |
1231 (put-text-property | |
1232 from to prop | |
1233 (cond ((numberp val) | |
1234 (+ val (or (get-text-property from prop) 0))) | |
1235 ((memq prop enriched-list-valued-properties) | |
1236 (let ((prev (get-text-property from prop))) | |
1237 (cons val (if (listp prev) prev (list prev))))) | |
1238 (t val))))) | |
1239 | |
1240 (if (or (and file-width ; possible reasons not to fill: | |
1241 (= file-width (enriched-text-width))) ; correct wd. | |
1242 (null enriched-fill-after-visiting) ; never fill | |
1243 (and (eq 'ask enriched-fill-after-visiting) ; asked & declined | |
1244 (not (y-or-n-p "Reformat for current display width? ")))) | |
1245 ;; Minimally, we have to insert indentation and justification. | |
1246 (enriched-insert-indentation) | |
1247 (sit-for 1) | |
1248 (if enriched-verbose (message "Filling paragraphs...")) | |
10519
66c7e651194d
(enriched-annotation-list): property `hard-newline'
Richard M. Stallman <rms@gnu.org>
parents:
9694
diff
changeset
|
1249 (fill-region (point-min) (point-max)) |
9676 | 1250 (if enriched-verbose (message nil))) |
1251 | |
1252 (if enriched-verbose | |
1253 (progn | |
1254 (message nil) | |
1255 (if unknown-ans | |
1256 (enriched-warn "Unknown annotations: %s" unknown-ans)))))))) | |
1257 | |
1258 (defun enriched-get-file-width () | |
1259 "Look for file width information on this line." | |
1260 (save-excursion | |
1261 (if (search-forward "width:" (save-excursion (end-of-line) (point)) t) | |
1262 (read (current-buffer))))) | |
1263 | |
1264 (defun enriched-move-to-next-annotation () | |
1265 "Advances point to next annotation, dealing with special items on the way. | |
1266 Returns t if one was found, otherwise nil." | |
1267 (while (and (re-search-forward enriched-decode-interesting-regexp nil t) | |
1268 (goto-char (match-beginning 0)) | |
1269 (not (looking-at enriched-annotation-regexp))) | |
1270 (let ((regexps enriched-decode-special-alist)) | |
1271 (while (and regexps | |
1272 (not (looking-at (car (car regexps))))) | |
1273 (enriched-pop regexps)) | |
1274 (if regexps | |
1275 (funcall (cdr (car regexps))) | |
1276 (forward-char 1)))) ; nothing found | |
1277 (not (eobp))) | |
1278 | |
1279 ;;; enriched.el ends here |