Mercurial > emacs
annotate lisp/enriched.el @ 10128:59ccd063e016
(search_regs_saved): Delete initializer.
author | Richard M. Stallman <rms@gnu.org> |
---|---|
date | Wed, 07 Dec 1994 13:03:48 +0000 |
parents | f8aa9230c3fa |
children | 66c7e651194d |
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-indent-increment 4 | |
56 "*Number of columns to indent for an <Indent> annotation. | |
57 Should agree with the definition of <Indent> in enriched-annotation-alist.") | |
58 | |
59 (defvar enriched-fill-after-visiting t | |
60 "If t, fills paragraphs when reading in enriched documents. | |
61 If nil, only fills when you explicitly request it. If the value is 'ask, then | |
62 it will query you whether to fill. | |
63 Filling is never done if the current text-width is the same as the value | |
64 stored in the file.") | |
65 | |
66 (defvar enriched-default-justification 'left | |
67 "*Method of justifying text not otherwise specified. | |
68 Can be `left' `right' `both' `center' or `none'.") | |
69 | |
70 (defvar enriched-auto-save-interval 1000 | |
71 "*`Auto-save-interval' to use for `enriched-mode'. | |
72 Auto-saving enriched files is slow, so you may wish to have them happen less | |
73 often. You can set this to nil to only do auto-saves when you are not | |
74 actively working.") | |
75 | |
76 ;;Unimplemented: | |
77 ;(defvar enriched-aggressive-auto-fill t | |
78 ; "*If t, try to keep things properly filled and justified always. | |
79 ;Set this to nil if you have a slow terminal or prefer to justify on request. | |
80 ;The difference between aggressive and non-aggressive is subtle right now, but | |
81 ;may become stronger in the future.") | |
82 | |
83 ;; Unimplemented: | |
84 ; (defvar enriched-keep-ignored-items nil | |
85 ; "*If t, keep track of codes that are not understood. | |
86 ; Otherwise they are deleted on reading the file, and not written out.") | |
87 | |
88 ;;Unimplemented: | |
89 ;(defvar enriched-electric-indentation t | |
90 ; "*If t, newlines and following indentation stick together. | |
91 ;Deleting a newline or any part of the indenation will delete the whole | |
92 ;stretch.") | |
93 | |
94 ;;; | |
95 ;;; Set up faces & display table | |
96 ;;; | |
97 | |
98 ;; A slight cheat - all emacs's faces are fixed-width. | |
99 ;; The idea is just to pick one that looks different from the default. | |
100 (if (internal-find-face 'fixed) | |
101 nil | |
102 (make-face 'fixed) | |
103 (if window-system | |
104 (set-face-font 'fixed | |
105 (car (or (x-list-fonts "*fixed-medium*" | |
106 'default (selected-frame)) | |
107 (x-list-fonts "*fixed*" | |
108 'default (selected-frame))))))) | |
109 | |
110 (if (internal-find-face 'excerpt) | |
111 nil | |
112 (make-face 'excerpt) | |
113 (if window-system | |
114 (make-face-italic 'excerpt))) | |
115 | |
116 ;;; The following two faces should not appear on menu. | |
117 (if (boundp 'facemenu-unlisted-faces) | |
118 (setq facemenu-unlisted-faces | |
119 (append '(enriched-code-face enriched-indentation-face) | |
120 facemenu-unlisted-faces))) | |
121 | |
122 (if (internal-find-face 'enriched-code-face) | |
123 nil | |
124 (make-face 'enriched-code-face) | |
125 (if window-system | |
126 (set-face-background 'enriched-code-face | |
127 (if (x-display-color-p) | |
128 "LightSteelBlue" | |
129 "gray35")))) | |
130 | |
131 (if (internal-find-face 'enriched-indentation-face) | |
132 nil | |
133 (make-face 'enriched-indentation-face) | |
134 (if window-system | |
135 (set-face-background 'enriched-indentation-face | |
136 (if (x-display-color-p) | |
137 "DarkSlateBlue" | |
138 "gray25")))) | |
139 | |
140 (defvar enriched-display-table (make-display-table)) | |
141 (aset enriched-display-table ?\f (make-vector (1- (frame-width)) ?-)) | |
142 | |
143 (defvar enriched-hard-newline | |
144 (let ((s "\n")) | |
145 (put-text-property 0 1 'hard-newline t s) | |
146 s) | |
147 "String used to indicate hard newline in a enriched buffer. | |
148 This is a newline with the `hard-newline' property set.") | |
149 | |
150 (defvar enriched-show-codes nil "See the function of the same name") | |
151 | |
152 (defvar enriched-par-props '(left-margin right-margin justification | |
153 front-sticky) | |
154 "Text-properties that usually apply to whole paragraphs. | |
155 These are set front-sticky everywhere except at hard newlines.") | |
156 | |
157 ;;; | |
158 ;;; Variables controlling the file format | |
159 ;;; (bidirectional) | |
160 | |
161 (defvar enriched-initial-annotation | |
162 (lambda () | |
163 (format "<param>-*-enriched-*-width:%d | |
164 </param>" (enriched-text-width))) | |
165 "What to insert at the start of a text/enriched file. | |
166 If this is a string, it is inserted. If it is a list, it should be a lambda | |
167 expression, which is evaluated to get the string to insert.") | |
168 | |
169 (defvar enriched-annotation-format "<%s%s>" | |
170 "General format of enriched-text annotations.") | |
171 | |
172 (defvar enriched-annotation-regexp "<\\(/\\)?\\([-A-za-z0-9]+\\)>" | |
173 "Regular expression matching enriched-text annotations.") | |
174 | |
175 (defvar enriched-downcase-annotations t | |
176 "Set to t if case of annotations is irrelevant. | |
177 In this case all annotations listed in enriched-annotation-list should be | |
178 lowercase, and annotations read from files will be downcased before being | |
179 compared to that list.") | |
180 | |
181 (defvar enriched-list-valued-properties '(face unknown) | |
182 "List of properties whose values can be lists.") | |
183 | |
184 (defvar enriched-annotation-alist | |
185 '((face (bold-italic "bold" "italic") | |
186 (bold "bold") | |
187 (italic "italic") | |
188 (underline "underline") | |
189 (fixed "fixed") | |
190 (excerpt "excerpt") | |
191 (default ) | |
192 (nil enriched-encode-other-face)) | |
193 (hard-newline (nil enriched-encode-hard-newline)) | |
194 (left-margin (4 "indent")) | |
195 (right-margin (4 "indentright")) | |
196 (justification (none "nofill") | |
197 (right "flushright") | |
198 (left "flushleft") | |
199 (both "flushboth") | |
200 (center "center")) | |
201 (PARAMETER (t "param")) ; Argument of preceding annotation | |
202 ;; The following are not part of the standard: | |
203 (FUNCTION (enriched-decode-foreground "x-color") | |
204 (enriched-decode-background "x-bg-color")) | |
205 (read-only (t "x-read-only")) | |
206 (unknown (nil enriched-encode-unknown)) ;anything else found | |
207 ; (font-size (2 "bigger") ; unimplemented | |
208 ; (-2 "smaller")) | |
209 ) | |
210 "List of definitions of text/enriched annotations. | |
211 Each element is a list whose car is a PROPERTY, and the following | |
212 elements are VALUES of that property followed by zero or more ANNOTATIONS. | |
213 Whenever the property takes on that value, each of the annotations | |
214 will be inserted into the file. Only the name of the annotation | |
215 should be specified, it will be formatted by `enriched-make-annotation'. | |
216 At the point that the property stops having that value, the matching | |
217 negated annotation will be inserted (it may actually be closed earlier and | |
218 reopened, if necessary, to keep proper nesting). | |
219 | |
220 Conversely, when annotations are read, they are searched for in this list, and | |
221 the relevant text property is added to the buffer. The first match found whose | |
222 conditions are satisfied is used. If enriched-downcase-annotations is true, | |
223 then annotations in this list should be listed in lowercase, and annotations | |
224 read from the file will be downcased. | |
225 | |
226 If the VALUE is numeric, then it is assumed that there is a single annotation | |
227 and each occurrence of it increments the value of the property by that number. | |
228 Thus, given the entry \(left-margin \(4 \"indent\")), `enriched-encode-region' | |
229 will insert two <indent> annotations if the left margin changes from 4 to 12. | |
230 | |
231 If the VALUE is nil, then instead of annotations, a function should be | |
232 specified. This function is used as a default: it is called for all | |
233 transitions not explicitly listed in the table. The function is called with | |
234 two arguments, the OLD and NEW values of the property. It should return a | |
235 list of annotations like `enriched-loc-annotations' does, or may directly | |
236 modify the buffer. Note that this only works for encoding; there must be some | |
237 other way of decoding the annotations thus produced. | |
238 | |
239 [For future expansion:] If the VALUE is a list, then the property's value will | |
240 be appended to the surrounding value of the property. | |
241 | |
242 For decoding, there are some special symbols that can be used in the | |
243 \"property\" slot. Annotations listed under the pseudo-property PARAMETER are | |
244 considered to be arguments of the immediately surrounding annotation; the text | |
245 between the opening and closing parameter annotations is deleted from the | |
246 buffer but saved as a string. The surrounding annotation should be listed | |
247 under the pseudo-property FUNCTION. Instead of inserting a text-property for | |
248 this annotation, enriched-decode-buffer will call the function listed in the | |
249 VALUE slot, with the first two arguments being the start and end locations and | |
250 the rest of the arguments being any PARAMETERs found in that region.") | |
251 | |
252 ;;; This is not needed for text/enriched format, since all annotations are in | |
253 ;;; a standard form: | |
254 ;(defvar enriched-special-annotations-alist nil | |
255 ; "List of annotations not formatted in the usual way. | |
256 ;Each element has the form (ANNOTATION BEGIN END), where | |
257 ;ANNOTATION is the annotation's name, which is a symbol (normal | |
258 ;annotations are named with strings, special ones with symbols), | |
259 ;BEGIN is the literal string to insert as the opening annotation, and | |
260 ;END is the literal string to insert as the close. | |
261 ;This is used only for encoding. Typically, each will have an entry in | |
262 ;enriched-decode-special-alist to deal with its decoding.") | |
263 | |
264 ;;; Encoding variables | |
265 | |
266 (defvar enriched-encode-interesting-regexp "<" | |
267 "Regexp matching the start of something that may require encoding. | |
268 All text-property changes are also considered \"interesting\".") | |
269 | |
270 (defvar enriched-encode-special-alist | |
271 '(("<" . (lambda () (insert-and-inherit "<")))) | |
272 "List of special operations for writing enriched files. | |
273 Each element has the form \(STRING . FUNCTION). | |
274 Whenever one of the strings \(including its properties, if any) | |
275 is found, the corresponding function is called. | |
276 Match data is available to the function. | |
277 See `enriched-decode-special-alist' for instructions on decoding special | |
278 items.") | |
279 | |
280 (defvar enriched-ignored-ok | |
281 '(front-sticky rear-nonsticky) | |
282 "Properties that are not written into enriched files. | |
283 Generally this list should only contain properties that just for enriched's | |
284 internal purposes; other properties that cannot be recorded will generate | |
285 a warning message to the user since information will be lost.") | |
286 | |
287 ;;; Decoding variables | |
288 | |
289 (defvar enriched-decode-interesting-regexp "[<\n]" | |
290 "Regexp matching the start of something that may require decoding.") | |
291 | |
292 (defvar enriched-decode-special-alist | |
293 '(("<<" . (lambda () (delete-char 1) (forward-char 1))) | |
294 ("\n\n" . enriched-decode-hard-newline)) | |
295 "List of special operations for reading enriched files. | |
296 Each element has the form \(STRING . FUNCTION). | |
297 Whenever one of the strings is found, the corresponding function is called, | |
298 with point at the beginning of the match and the match data is available to | |
299 the function. Should leave point where next search should start.") | |
300 | |
301 ;;; Internal variables | |
302 | |
303 (defvar enriched-mode nil | |
304 "True if `enriched-mode' \(which see) is enabled.") | |
305 (make-variable-buffer-local 'enriched-mode) | |
306 | |
307 (if (not (assq 'enriched-mode minor-mode-alist)) | |
308 (setq minor-mode-alist | |
309 (cons '(enriched-mode " Enriched") | |
310 minor-mode-alist))) | |
311 | |
312 (defvar enriched-mode-hooks nil | |
313 "Functions to run when entering `enriched-mode'. | |
314 If you set variables in this hook, you should arrange for them to be restored | |
315 to their old values if enriched-mode is left. One way to do this is to add | |
316 them and their old values to `enriched-old-bindings'.") | |
317 | |
318 (defvar enriched-old-bindings nil | |
319 "Store old variable values that we change when entering mode. | |
320 The value is a list of \(VAR VALUE VAR VALUE...).") | |
321 (make-variable-buffer-local 'enriched-old-bindings) | |
322 | |
323 (defvar enriched-translated nil | |
324 "True if buffer has already been decoded.") | |
325 (make-variable-buffer-local 'enriched-translated) | |
326 | |
327 (defvar enriched-text-width nil) | |
328 (make-variable-buffer-local 'enriched-text-width) | |
329 | |
330 (defvar enriched-ignored-list nil) | |
331 | |
332 (defvar enriched-open-ans nil) | |
333 | |
334 ;;; | |
335 ;;; Functions defining the format of annotations | |
336 ;;; | |
337 | |
338 (defun enriched-make-annotation (name positive) | |
339 "Format an annotation called NAME. | |
340 If POSITIVE is non-nil, this is the opening annotation, if nil, this is the | |
341 matching close." | |
342 ;; Could be used for annotations not following standard form: | |
343 ; (if (symbolp name) | |
344 ; (if positive | |
345 ; (elt (assq name enriched-special-annotations-alist) 1) | |
346 ; (elt (assq name enriched-special-annotations-alist) 2)) ) | |
347 (if (stringp name) | |
348 (format enriched-annotation-format (if positive "" "/") name) | |
349 ;; has parameters. | |
350 (if positive | |
351 (let ((item (car name)) | |
352 (params (cdr name))) | |
353 (concat (format enriched-annotation-format "" item) | |
354 (mapconcat (lambda (i) (concat "<param>" i "</param>")) | |
355 params ""))) | |
356 (format enriched-annotation-format "/" (car name))))) | |
357 | |
358 (defun enriched-annotation-name (a) | |
359 "Find the name of an ANNOTATION." | |
360 (save-match-data | |
361 (if (string-match enriched-annotation-regexp a) | |
362 (substring a (match-beginning 2) (match-end 2))))) | |
363 | |
364 (defun enriched-annotation-positive-p (a) | |
365 "Returns t if ANNOTATION is positive (open), | |
366 or nil if it is a closing (negative) annotation." | |
367 (save-match-data | |
368 (and (string-match enriched-annotation-regexp a) | |
369 (not (match-beginning 1))))) | |
370 | |
371 (defun enriched-encode-unknown (old new) | |
372 "Deals with re-inserting unknown annotations." | |
373 (cons (if old (list old)) | |
374 (if new (list new)))) | |
375 | |
376 (defun enriched-encode-hard-newline (old new) | |
377 "Deal with encoding `hard-newline' property change." | |
378 ;; This makes a sequence of N hard newlines into N+1 duplicates of the first | |
379 ;; one- so all property changes are put off until after all the newlines. | |
380 (if (and new (enriched-justification)) ; no special processing inside NoFill | |
381 (let* ((length (skip-chars-forward "\n")) | |
382 (s (make-string length ?\n))) | |
383 (backward-delete-char (1- length)) | |
384 (add-text-properties 0 length (text-properties-at (1- (point))) s) | |
385 (insert s) | |
386 (backward-char (+ length 1))))) | |
387 | |
388 (defun enriched-decode-hard-newline () | |
389 "Deal with newlines while decoding file." | |
390 ;; We label double newlines as `hard' and single ones as soft even in NoFill | |
391 ;; regions; otherwise the paragraph functions would not do anything | |
392 ;; reasonable in NoFill regions. | |
393 (let ((nofill (equal "nofill" ; find out if we're in NoFill region | |
394 (enriched-which-assoc | |
395 '("nofill" "flushleft" "flushright" "center" | |
396 "flushboth") | |
397 enriched-open-ans))) | |
398 (n (skip-chars-forward "\n"))) | |
399 (delete-char (- n)) | |
400 (enriched-insert-hard-newline (if nofill n (1- n))))) | |
401 | |
402 (defun enriched-encode-other-face (old new) | |
403 "Generate annotations for random face change. | |
404 One annotation each for foreground color, background color, italic, etc." | |
405 (cons (and old (enriched-face-ans old)) | |
406 (and new (enriched-face-ans new)))) | |
407 | |
408 (defun enriched-face-ans (face) | |
409 "Return annotations specifying FACE." | |
410 (cond ((string-match "^fg:" (symbol-name face)) | |
411 (list (list "x-color" (substring (symbol-name face) 3)))) | |
412 ((string-match "^bg:" (symbol-name face)) | |
413 (list (list "x-bg-color" (substring (symbol-name face) 3)))) | |
414 ((let* ((fg (face-foreground face)) | |
415 (bg (face-background face)) | |
416 (props (face-font face t)) | |
417 (ans (cdr (enriched-annotate-change 'face nil props)))) | |
418 (if fg (enriched-push (list "x-color" fg) ans)) | |
419 (if bg (enriched-push (list "x-bg-color" bg) ans)) | |
420 ans)))) | |
421 | |
422 (defun enriched-decode-foreground (from to color) | |
423 (let ((face (intern (concat "fg:" color)))) | |
9694
f8aa9230c3fa
(enriched-mode): Add autoload cookie.
Boris Goldowsky <boris@gnu.org>
parents:
9677
diff
changeset
|
424 (cond ((internal-find-face face)) |
f8aa9230c3fa
(enriched-mode): Add autoload cookie.
Boris Goldowsky <boris@gnu.org>
parents:
9677
diff
changeset
|
425 ((and window-system (facemenu-get-face face))) |
f8aa9230c3fa
(enriched-mode): Add autoload cookie.
Boris Goldowsky <boris@gnu.org>
parents:
9677
diff
changeset
|
426 (window-system |
f8aa9230c3fa
(enriched-mode): Add autoload cookie.
Boris Goldowsky <boris@gnu.org>
parents:
9677
diff
changeset
|
427 (enriched-warn "Color \"%s\" not defined: |
f8aa9230c3fa
(enriched-mode): Add autoload cookie.
Boris Goldowsky <boris@gnu.org>
parents:
9677
diff
changeset
|
428 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
|
429 ((make-face face) |
f8aa9230c3fa
(enriched-mode): Add autoload cookie.
Boris Goldowsky <boris@gnu.org>
parents:
9677
diff
changeset
|
430 (enriched-warn "Color \"%s\" can't be displayed." color))) |
9676 | 431 (list from to 'face face))) |
432 | |
433 (defun enriched-decode-background (from to color) | |
434 (let ((face (intern (concat "bg:" color)))) | |
9694
f8aa9230c3fa
(enriched-mode): Add autoload cookie.
Boris Goldowsky <boris@gnu.org>
parents:
9677
diff
changeset
|
435 (cond ((internal-find-face face)) |
f8aa9230c3fa
(enriched-mode): Add autoload cookie.
Boris Goldowsky <boris@gnu.org>
parents:
9677
diff
changeset
|
436 ((and window-system (facemenu-get-face face))) |
f8aa9230c3fa
(enriched-mode): Add autoload cookie.
Boris Goldowsky <boris@gnu.org>
parents:
9677
diff
changeset
|
437 (window-system |
f8aa9230c3fa
(enriched-mode): Add autoload cookie.
Boris Goldowsky <boris@gnu.org>
parents:
9677
diff
changeset
|
438 (enriched-warn "Color \"%s\" not defined: |
f8aa9230c3fa
(enriched-mode): Add autoload cookie.
Boris Goldowsky <boris@gnu.org>
parents:
9677
diff
changeset
|
439 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
|
440 ((make-face face) |
f8aa9230c3fa
(enriched-mode): Add autoload cookie.
Boris Goldowsky <boris@gnu.org>
parents:
9677
diff
changeset
|
441 (enriched-warn "Color \"%s\" can't be displayed." color))) |
9676 | 442 (list from to 'face face))) |
443 | |
444 ;;; | |
445 ;;; NOTE: Everything below this point is intended to be independent of the file | |
446 ;;; format, which is defined by the variables and functions above. | |
447 ;;; | |
448 | |
449 ;;; | |
450 ;;; Define the mode | |
451 ;;; | |
452 | |
9694
f8aa9230c3fa
(enriched-mode): Add autoload cookie.
Boris Goldowsky <boris@gnu.org>
parents:
9677
diff
changeset
|
453 ;;;###autoload |
9676 | 454 (defun enriched-mode (&optional arg notrans) |
455 "Minor mode for editing text/enriched files. | |
456 These are files with embedded formatting information in the MIME standard | |
457 text/enriched format. | |
458 | |
459 Turning the mode on or off interactively will query whether the buffer | |
460 should be translated into or out of text/enriched format immediately. | |
461 Noninteractively translation is done without query unless the optional | |
462 second argument NO-TRANS is non-nil. | |
463 Turning mode on runs `enriched-mode-hooks'. | |
464 | |
465 More information about enriched-mode is available in the file | |
466 etc/enriched.doc in the Emacs distribution directory. | |
467 | |
468 Commands: | |
469 | |
470 \\<enriched-mode-map>\\{enriched-mode-map}" | |
471 (interactive "P") | |
472 (let ((mod (buffer-modified-p))) | |
473 (cond ((or (<= (prefix-numeric-value arg) 0) | |
474 (and enriched-mode (null arg))) | |
475 ;; Turn mode off | |
476 (setq enriched-mode nil) | |
477 (if (if (interactive-p) | |
478 (y-or-n-p "Translate buffer into text/enriched format?") | |
479 (not notrans)) | |
480 (progn (enriched-encode-region) | |
481 (mapcar (lambda (x) | |
482 (remove-text-properties | |
483 (point-min) (point-max) | |
484 (list (if (consp x) (car x) x) nil))) | |
485 (append enriched-ignored-ok | |
486 enriched-annotation-alist)) | |
487 (setq enriched-translated nil))) | |
488 ;; restore old variable values | |
489 (while enriched-old-bindings | |
490 (funcall 'set (car enriched-old-bindings) | |
491 (car (cdr enriched-old-bindings))) | |
492 (setq enriched-old-bindings (cdr (cdr enriched-old-bindings)))) | |
493 (remove-hook 'write-region-annotate-functions | |
494 'enriched-annotate-function t) | |
495 (remove-hook 'after-change-functions 'enriched-nogrow-hook t)) | |
496 (enriched-mode nil) ; Mode already on; do nothing. | |
497 (t ; Turn mode on | |
498 ;; save old variable values before we change them. | |
499 (setq enriched-mode t | |
500 enriched-old-bindings | |
501 (list 'indent-line-function indent-line-function | |
502 'auto-fill-function auto-fill-function | |
503 'buffer-display-table buffer-display-table | |
504 'fill-column fill-column | |
505 'auto-save-interval auto-save-interval | |
506 'sentence-end-double-space sentence-end-double-space)) | |
507 (make-local-variable 'auto-fill-function) | |
508 (make-local-variable 'auto-save-interval) | |
509 (make-local-variable 'indent-line-function) | |
510 (make-local-variable 'sentence-end-double-space) | |
511 (setq buffer-display-table enriched-display-table | |
512 indent-line-function 'enriched-indent-line | |
513 auto-fill-function 'enriched-auto-fill-function | |
514 fill-column 0 ; always run auto-fill-function | |
515 auto-save-interval enriched-auto-save-interval | |
516 sentence-end-double-space nil) ; Weird in Center&FlushRight | |
517 ;; Add hooks | |
518 (add-hook 'write-region-annotate-functions | |
519 'enriched-annotate-function) | |
520 (add-hook 'after-change-functions 'enriched-nogrow-hook) | |
521 | |
522 (put-text-property (point-min) (point-max) | |
523 'front-sticky enriched-par-props) | |
524 | |
525 (if (and (not enriched-translated) | |
526 (if (interactive-p) | |
527 (y-or-n-p "Does buffer need to be translated now? ") | |
528 (not notrans))) | |
529 (progn (enriched-decode-region) | |
530 (setq enriched-translated t))) | |
531 (run-hooks 'enriched-mode-hooks))) | |
532 (set-buffer-modified-p mod) | |
533 (force-mode-line-update))) | |
534 | |
535 ;;; | |
536 ;;; Keybindings | |
537 ;;; | |
538 | |
539 (defvar enriched-mode-map nil | |
540 "Keymap for `enriched-mode'.") | |
541 | |
542 (if (null enriched-mode-map) | |
543 (fset 'enriched-mode-map (setq enriched-mode-map (make-sparse-keymap)))) | |
544 | |
545 (if (not (assq 'enriched-mode minor-mode-map-alist)) | |
546 (setq minor-mode-map-alist | |
547 (cons (cons 'enriched-mode enriched-mode-map) | |
548 minor-mode-map-alist))) | |
549 | |
550 (define-key enriched-mode-map "\r" 'enriched-newline) | |
551 (define-key enriched-mode-map "\n" 'enriched-newline) | |
552 (define-key enriched-mode-map "\C-a" 'enriched-beginning-of-line) | |
553 (define-key enriched-mode-map "\C-o" 'enriched-open-line) | |
554 (define-key enriched-mode-map "\M-{" 'enriched-backward-paragraph) | |
555 (define-key enriched-mode-map "\M-}" 'enriched-forward-paragraph) | |
556 (define-key enriched-mode-map "\M-q" 'enriched-fill-paragraph) | |
557 (define-key enriched-mode-map "\M-S" 'enriched-set-justification-center) | |
558 (define-key enriched-mode-map "\C-x\t" 'enriched-change-left-margin) | |
559 (define-key enriched-mode-map "\C-c\C-l" 'enriched-set-left-margin) | |
560 (define-key enriched-mode-map "\C-c\C-r" 'enriched-set-right-margin) | |
561 (define-key enriched-mode-map "\C-c\C-s" 'enriched-show-codes) | |
562 (define-key enriched-mode-map "\M-j" 'enriched-justification-menu-map) | |
563 | |
564 ;;; These extend the "Face" menu. | |
9677
8ff145bf72cf
Don't try to make menu bindings when window-system==nil.
Boris Goldowsky <boris@gnu.org>
parents:
9676
diff
changeset
|
565 (let ((menu (and window-system (car (where-is-internal facemenu-menu))))) |
9676 | 566 (if (null menu) |
567 nil | |
568 (define-key enriched-mode-map | |
569 (apply 'vector (append menu '(Sep-faces))) '("------")) | |
570 (define-key enriched-mode-map | |
571 (apply 'vector (append menu '(Justification))) | |
572 (cons "Justification" 'enriched-justification-menu-map)) | |
573 (define-key enriched-mode-map | |
574 (apply 'vector (append menu '(Indentation))) | |
575 (cons "Indentation" 'enriched-indentation-menu-map)))) | |
576 | |
577 ;;; The "Indentation" sub-menu: | |
578 | |
579 (defvar enriched-indentation-menu-map (make-sparse-keymap "Indentation") | |
580 "Submenu for indentation commands.") | |
581 (defalias 'enriched-indentation-menu-map enriched-indentation-menu-map) | |
582 | |
583 (define-key enriched-indentation-menu-map [UnIndentRight] | |
584 (cons "UnIndentRight" 'enriched-unindent-right)) | |
585 (define-key enriched-indentation-menu-map [IndentRight] | |
586 (cons "IndentRight" 'enriched-indent-right)) | |
587 (define-key enriched-indentation-menu-map [Unindent] | |
588 (cons "UnIndent" 'enriched-unindent)) | |
589 (define-key enriched-indentation-menu-map [Indent] | |
590 (cons "Indent" ' enriched-indent)) | |
591 | |
592 ;;; The "Justification" sub-menu: | |
593 (defvar enriched-justification-menu-map (make-sparse-keymap "Justification") | |
594 "Submenu for text justification commands.") | |
595 (defalias 'enriched-justification-menu-map enriched-justification-menu-map) | |
596 | |
597 (define-key enriched-justification-menu-map [?c] | |
598 (cons "Center" 'enriched-set-justification-center)) | |
599 (define-key enriched-justification-menu-map [?b] | |
600 (cons "Flush Both" 'enriched-set-justification-both)) | |
601 (define-key enriched-justification-menu-map [?r] | |
602 (cons "Flush Right" 'enriched-set-justification-right)) | |
603 (define-key enriched-justification-menu-map [?l] | |
604 (cons "Flush Left" 'enriched-set-justification-left)) | |
605 (define-key enriched-justification-menu-map [?u] | |
606 (cons "Unfilled" 'enriched-set-nofill)) | |
607 | |
608 ;;; | |
609 ;;; Interactive Functions | |
610 ;;; | |
611 | |
612 (defun enriched-newline (n) | |
613 "Insert N hard newlines. | |
614 These are newlines that will not be affected by paragraph filling or | |
615 justification; they are used for necessary line breaks or to separate | |
616 paragraphs." | |
617 (interactive "*p") | |
618 (enriched-auto-fill-function) | |
619 (while (> n 0) | |
620 (enriched-insert-hard-newline 1) | |
621 (end-of-line 0) | |
622 (enriched-justify-line) | |
623 (beginning-of-line 2) | |
624 (setq n (1- n))) | |
625 (enriched-indent-line)) | |
626 | |
627 (defun enriched-open-line (arg) | |
628 "Inserts a newline and leave point before it. | |
629 With arg N, inserts N newlines. Makes sure all lines are properly indented." | |
630 (interactive "*p") | |
631 (save-excursion | |
632 (enriched-newline arg)) | |
633 (enriched-auto-fill-function) | |
634 (end-of-line)) | |
635 | |
636 (defun enriched-beginning-of-line (&optional n) | |
637 "Move point to the beginning of the text part of the current line. | |
638 This is after all indentation due to left-margin setting or center or right | |
639 justification, but before any literal spaces or tabs used for indentation. | |
640 With argument ARG not nil or 1, move forward ARG - 1 lines first. | |
641 If scan reaches end of buffer, stop there without error." | |
642 (interactive "p") | |
643 (beginning-of-line n) | |
644 ; (if (interactive-p) (enriched-justify-line)) | |
645 (goto-char | |
646 (or (text-property-any (point) (point-max) 'enriched-indentation nil) | |
647 (point-max)))) | |
648 | |
649 (defun enriched-backward-paragraph (n) | |
650 "Move backward N paragraphs. | |
651 Hard newlines are considered to be the only paragraph separators." | |
652 (interactive "p") | |
653 (enriched-forward-paragraph (- n))) | |
654 | |
655 (defun enriched-forward-paragraph (n) | |
656 "Move forward N paragraphs. | |
657 Hard newlines are considered to be the only paragraph separators." | |
658 (interactive "p") | |
659 (if (> n 0) | |
660 (while (> n 0) | |
661 (skip-chars-forward " \t\n") | |
662 (enriched-end-of-paragraph) | |
663 (setq n (1- n))) | |
664 (while (< n 0) | |
665 (skip-chars-backward " \t\n") | |
666 (enriched-beginning-of-paragraph) | |
667 (setq n (1+ n))) | |
668 (enriched-beginning-of-line))) | |
669 | |
670 (defun enriched-fill-paragraph () | |
671 "Make the current paragraph fit between its left and right margins." | |
672 (interactive) | |
673 (save-excursion | |
674 (enriched-fill-region-as-paragraph (enriched-beginning-of-paragraph) | |
675 (enriched-end-of-paragraph)))) | |
676 | |
677 (defun enriched-indent (b e) | |
678 "Make the left margin of the region larger." | |
679 (interactive "r") | |
680 (enriched-change-left-margin b e enriched-indent-increment)) | |
681 | |
682 (defun enriched-unindent (b e) | |
683 "Make the left margin of the region smaller." | |
684 (interactive "r") | |
685 (enriched-change-left-margin b e (- enriched-indent-increment))) | |
686 | |
687 (defun enriched-indent-right (b e) | |
688 "Make the right margin of the region larger." | |
689 (interactive "r") | |
690 (enriched-change-right-margin b e enriched-indent-increment)) | |
691 | |
692 (defun enriched-unindent-right (b e) | |
693 "Make the right margin of the region smaller." | |
694 (interactive "r") | |
695 (enriched-change-right-margin b e (- enriched-indent-increment))) | |
696 | |
697 (defun enriched-set-nofill (b e) | |
698 "Disable automatic filling in the region. | |
699 Actually applies to all lines ending in the region. | |
700 If mark is not active, applies to the current line." | |
701 (interactive (enriched-region-pars)) | |
702 (enriched-set-justification b e 'none)) | |
703 | |
704 (defun enriched-set-justification-left (b e) | |
705 "Declare the region to be left-justified. | |
706 This is usually the default, but see `enriched-default-justification'." | |
707 (interactive (enriched-region-pars)) | |
708 (enriched-set-justification b e 'left)) | |
709 | |
710 (defun enriched-set-justification-right (b e) | |
711 "Declare paragraphs in the region to be right-justified: | |
712 Flush at the right margin and ragged on the left. | |
713 If mark is not active, applies to the current paragraph." | |
714 (interactive (enriched-region-pars)) | |
715 (enriched-set-justification b e 'right)) | |
716 | |
717 (defun enriched-set-justification-both (b e) | |
718 "Declare the region to be fully justified. | |
719 If mark is not active, applies to the current paragraph." | |
720 (interactive (enriched-region-pars)) | |
721 (enriched-set-justification b e 'both)) | |
722 | |
723 (defun enriched-set-justification-center (b e) | |
724 "Make each line in the region centered. | |
725 If mark is not active, applies to the current paragraph." | |
726 (interactive (enriched-region-pars)) | |
727 (enriched-set-justification b e 'center)) | |
728 | |
729 ;;; | |
730 ;;; General list/stack manipulation | |
731 ;;; | |
732 | |
733 (defmacro enriched-push (item stack) | |
734 "Push ITEM onto STACK. | |
735 STACK should be a symbol whose value is a list." | |
736 (` (setq (, stack) (cons (, item) (, stack))))) | |
737 | |
738 (defmacro enriched-pop (stack) | |
739 "Remove and return first item on STACK." | |
740 (` (let ((pop-item (car (, stack)))) | |
741 (setq (, stack) (cdr (, stack))) | |
742 pop-item))) | |
743 | |
744 (defun enriched-delq1 (cons list) | |
745 "Remove the given CONS from LIST by side effect. | |
746 Since CONS could be the first element of LIST, write | |
747 `(setq foo (enriched-delq1 element foo))' to be sure of changing the value | |
748 of `foo'." | |
749 (if (eq cons list) | |
750 (cdr list) | |
751 (let ((p list)) | |
752 (while (not (eq (cdr p) cons)) | |
753 (if (null p) (error "enriched-delq1: Attempt to delete a non-element")) | |
754 (setq p (cdr p))) | |
755 ;; Now (cdr p) is the cons to delete | |
756 (setcdr p (cdr cons)) | |
757 list))) | |
758 | |
759 (defun enriched-make-list-uniq (list) | |
760 "Destructively remove duplicates from LIST. | |
761 Compares using `eq'." | |
762 (let ((l list)) | |
763 (while l | |
764 (setq l (setcdr l (delq (car l) (cdr l))))) | |
765 list)) | |
766 | |
767 (defun enriched-make-relatively-unique (a b) | |
768 "Delete common elements of lists A and B, return as pair. | |
769 Compares using `equal'." | |
770 (let* ((acopy (copy-sequence a)) | |
771 (bcopy (copy-sequence b)) | |
772 (tail acopy)) | |
773 (while tail | |
774 (let ((dup (member (car tail) bcopy)) | |
775 (next (cdr tail))) | |
776 (if dup (setq acopy (enriched-delq1 tail acopy) | |
777 bcopy (enriched-delq1 dup bcopy))) | |
778 (setq tail next))) | |
779 (cons acopy bcopy))) | |
780 | |
781 (defun enriched-common-tail (a b) | |
782 "Given two lists that have a common tail, return it. | |
783 Compares with `equal', and returns the part of A that is equal to the | |
784 equivalent part of B. If even the last items of the two are not equal, | |
785 returns nil." | |
786 (let ((la (length a)) | |
787 (lb (length b))) | |
788 ;; Make sure they are the same length | |
789 (while (> la lb) | |
790 (setq a (cdr a) | |
791 la (1- la))) | |
792 (while (> lb la) | |
793 (setq b (cdr b) | |
794 lb (1- lb)))) | |
795 (while (not (equal a b)) | |
796 (setq a (cdr a) | |
797 b (cdr b))) | |
798 a) | |
799 | |
800 (defun enriched-which-assoc (items list) | |
801 "Return which one of ITEMS occurs first as a car of an element of LIST." | |
802 (let (res) | |
803 (while list | |
804 (if (setq res (member (car (car list)) items)) | |
805 (setq res (car res) | |
806 list nil) | |
807 (setq list (cdr list)))) | |
808 res)) | |
809 | |
810 (defun enriched-reorder (items order) | |
811 "Arrange ITEMS to following partial ORDER. | |
812 Elements of ITEMS equal to elements of ORDER will be rearranged to follow the | |
813 ORDER. Unmatched items will go last." | |
814 (if order | |
815 (let ((item (member (car order) items))) | |
816 (if item | |
817 (cons (car item) | |
818 (enriched-reorder (enriched-delq1 item items) | |
819 (cdr order))) | |
820 (enriched-reorder items (cdr order)))) | |
821 items)) | |
822 | |
823 ;;; | |
824 ;;; Utility functions | |
825 ;;; | |
826 | |
827 (defun enriched-get-face-attribute (attr face &optional frame) | |
828 "Get an attribute of a face or list of faces. | |
829 ATTRIBUTE should be one of the functions `face-font' `face-foreground', | |
830 `face-background', or `face-underline-p'. FACE can be a face or a list of | |
831 faces. If optional argument FRAME is given, report on the face in that frame. | |
832 If FRAME is t, report on the defaults for the face in new frames. If FRAME is | |
833 omitted or nil, use the selected frame." | |
834 (cond ((null face) nil) | |
835 ((or (symbolp face) (internal-facep face)) (funcall attr face frame)) | |
836 ((funcall attr (car face) frame)) | |
837 ((enriched-get-face-attribute attr (cdr face) frame)))) | |
838 | |
839 (defun enriched-region-pars () | |
840 "Return region expanded to begin and end at paragraph breaks. | |
841 If the region is not active, this is just the current paragraph. | |
842 A paragraph does not count as overlapping the region if only whitespace is | |
843 overlapping. Return value is a list of two numers, the beginning and end of | |
844 the defined region." | |
845 (save-excursion | |
846 (let* ((b (progn (if mark-active (goto-char (region-beginning))) | |
847 (enriched-beginning-of-paragraph))) | |
848 (e (progn (if mark-active (progn (goto-char (region-end)) | |
849 (skip-chars-backward " \t\n" b))) | |
850 (min (point-max) | |
851 (1+ (enriched-end-of-paragraph)))))) | |
852 (list b e)))) | |
853 | |
854 (defun enriched-end-of-paragraph () | |
855 "Move to the end of the current paragraph. | |
856 Only hard newlines delimit paragraphs. Returns point." | |
857 (interactive) | |
858 (if (not (bolp)) (backward-char 1)) | |
859 (if (enriched-search-forward-with-props enriched-hard-newline nil 1) | |
860 (backward-char 1)) | |
861 (point)) | |
862 | |
863 (defun enriched-beginning-of-paragraph () | |
864 "Move to beginning of the current paragraph. | |
865 Only hard newlines delimit paragraphs. Returns point." | |
866 (interactive) | |
867 (if (not (eolp)) (forward-char 1)) | |
868 (if (enriched-search-backward-with-props enriched-hard-newline nil 1) | |
869 (forward-char 1)) | |
870 (point)) | |
871 | |
872 (defun enriched-overlays-overlapping (begin end &optional test) | |
873 "Return a list of the overlays which overlap the specified region. | |
874 If optional arg TEST is given, it is called with each overlay as its | |
875 argument, and only those for which it is true are returned." | |
876 (overlay-recenter begin) | |
877 (let ((res nil) | |
878 (overlays (cdr (overlay-lists)))) ; includes all ending after BEGIN | |
879 (while overlays | |
880 (if (and (< (overlay-start (car overlays)) end) | |
881 (or (not test) | |
882 (funcall test (car overlays)))) | |
883 (enriched-push (car overlays) res)) | |
884 (setq overlays (cdr overlays))) | |
885 res)) | |
886 | |
887 (defun enriched-show-codes (&rest which) | |
888 "Enable or disable highlighting of special regions. | |
889 With argument null or `none', turns off highlighting. | |
890 If argument is `newline', turns on display of hard newlines. | |
891 If argument is `indent', highlights the automatic indentation at the beginning | |
892 of each line. | |
893 If argument is `margin', highlights all regions with non-standard margins." | |
894 (interactive | |
895 (list (intern (completing-read "Show which codes: " | |
896 '(("none") ("newline") ("indent") ("margin")) | |
897 nil t)))) | |
898 (if (null which) | |
899 (setq enriched-show-codes nil) | |
900 (setq enriched-show-codes which)) | |
901 ;; First delete current overlays | |
902 (let* ((ol (overlay-lists)) | |
903 (overlays (append (car ol) (cdr ol)))) | |
904 (while overlays | |
905 (if (eq (overlay-get (car overlays) 'face) 'enriched-code-face) | |
906 (delete-overlay (car overlays))) | |
907 (setq overlays (cdr overlays)))) | |
908 ;; Now add new ones for each thing displayed. | |
909 (if (null which) | |
910 (message "Code display off.")) | |
911 (while which | |
912 (cond ((eq (car which) 'margin) | |
913 (enriched-show-margin-codes)) | |
914 ((eq (car which) 'indent) | |
915 (enriched-map-property-regions 'enriched-indentation | |
916 (lambda (v b e) | |
917 (if v (enriched-show-region-as-code b e 'indent))))) | |
918 ((eq (car which) 'newline) | |
919 (save-excursion | |
920 (goto-char (point-min)) | |
921 (while (enriched-search-forward-with-props | |
922 enriched-hard-newline nil t) | |
923 (enriched-show-region-as-code (match-beginning 0) (match-end 0) | |
924 'newline))))) | |
925 (setq which (cdr which)))) | |
926 | |
927 (defun enriched-show-margin-codes (&optional from to) | |
928 "Highlight regions with nonstandard left-margins. | |
929 See `enriched-show-codes'." | |
930 (enriched-map-property-regions 'left-margin | |
931 (lambda (v b e) | |
932 (if (and v (> v 0)) | |
933 (enriched-show-region-as-code b e 'margin))) | |
934 from to) | |
935 (enriched-map-property-regions 'right-margin | |
936 (lambda (v b e) | |
937 (if (and v (> v 0)) | |
938 (enriched-show-region-as-code b e 'margin))) | |
939 from to)) | |
940 | |
941 (defun enriched-show-region-as-code (from to type) | |
942 "Display region between FROM and TO as a code if TYPE is displayed. | |
943 Displays it only if TYPE is an element of `enriched-show-codes' or is t." | |
944 (if (or (eq t type) (memq type enriched-show-codes)) | |
945 (let* ((old (enriched-overlays-overlapping | |
946 from to (lambda (o) | |
947 (eq 'enriched-code-face | |
948 (overlay-get o 'face))))) | |
949 (new (if old (move-overlay (car old) from to) | |
950 (make-overlay from to)))) | |
951 (overlay-put new 'face 'enriched-code-face) | |
952 (overlay-put new 'front-nogrow t) | |
953 (if (eq type 'margin) | |
954 (overlay-put new 'rear-grow t)) | |
955 (while (setq old (cdr old)) | |
956 (delete-overlay (car old)))))) | |
957 | |
958 (defun enriched-nogrow-hook (beg end old-length) | |
959 "Implement front-nogrow and rear-grow for overlays. | |
960 Normally overlays have opposite inheritance properties than | |
961 text-properties: they will expand to include text inserted at their | |
962 beginning, but not text inserted at their end. However, | |
963 if this function is an element of `after-change-functions', then | |
964 overlays with a non-nil value of the `front-nogrow' property will not | |
965 expand to include text that is inserted just in front of them, and | |
966 overlays with a non-nil value of the `rear-grow' property will | |
967 expand to include text that is inserted just after them." | |
968 (if (not (zerop old-length)) | |
969 nil ;; not an insertion | |
970 (let ((overlays (overlays-at end)) o) | |
971 (while overlays | |
972 (setq o (car overlays) | |
973 overlays (cdr overlays)) | |
974 (if (and (overlay-get o 'front-nogrow) | |
975 (= beg (overlay-start o))) | |
976 (move-overlay o end (overlay-end o))))) | |
977 (let ((overlays (overlays-at (1- beg))) o) | |
978 (while overlays | |
979 (setq o (car overlays) | |
980 overlays (cdr overlays)) | |
981 (if (and (overlay-get o 'rear-grow) | |
982 (= beg (overlay-end o))) | |
983 (move-overlay o (overlay-start o) end)))))) | |
984 | |
985 (defun enriched-warn (&rest args) | |
986 "Display a warning message. | |
987 Arguments are given to `format' and the result is displayed in a buffer." | |
988 (save-excursion | |
989 (let ((buf (current-buffer)) | |
990 (line (1+ (count-lines 1 (point)))) | |
991 (mark (point-marker))) | |
992 (pop-to-buffer (get-buffer-create "*Enriched Warnings*")) | |
993 (goto-char (point-max)) | |
994 (insert | |
995 ; (format "%s:%d: " (if (boundp 'enriched-file) enriched-file | |
996 ; (buffer-file-name buf)) | |
997 ; line) | |
998 (apply (function format) args) | |
999 "\n") | |
1000 (pop-to-buffer buf)))) | |
1001 | |
1002 (defun enriched-looking-at-with-props (string) | |
1003 "True if text at point is equal to STRING, including text props. | |
1004 This is a literal, not a regexp match. | |
1005 The buffer text must include all text properties that STRING has, in | |
1006 the same places, but it is allowed to have others that STRING lacks." | |
1007 (let ((buffer-string (buffer-substring (point) (+ (point) (length string))))) | |
1008 (and (string-equal string buffer-string) | |
1009 (enriched-text-properties-include string buffer-string)))) | |
1010 | |
1011 (defun enriched-search-forward-with-props | |
1012 (string &optional bound noerror count) | |
1013 "Search forward for STRING, including its text properties. | |
1014 Set point to end of occurrence found, and return point. | |
1015 The match found must include all text properties that STRING has, in | |
1016 the same places, but it is allowed to have others that STRING lacks. | |
1017 An optional second argument bounds the search; it is a buffer position. | |
1018 The match found must not extend after that position. nil is equivalent | |
1019 to (point-max). | |
1020 Optional third argument, if t, means if fail just return nil (no error). | |
1021 If not nil and not t, move to limit of search and return nil. | |
1022 Optional fourth argument is repeat count--search for successive occurrences. | |
1023 See also the functions `match-beginning', `match-end' and `replace-match'." | |
1024 (interactive "sSearch for: ") | |
1025 (or bound (setq bound (point-max))) | |
1026 (or count (setq count 1)) | |
1027 (let ((start (point)) | |
1028 (res t)) | |
1029 (while (and res (> count 0)) | |
1030 (while (and (setq res (search-forward string bound t)) | |
1031 (not (enriched-text-properties-include | |
1032 string (buffer-substring (match-beginning 0) | |
1033 (match-end 0)))))) | |
1034 (setq count (1- count))) | |
1035 (cond (res) | |
1036 ((eq noerror t) (goto-char start) nil) | |
1037 (noerror (goto-char bound) nil) | |
1038 (t (goto-char start) | |
1039 (error "Search failed: %s" string))))) | |
1040 | |
1041 (defun enriched-search-backward-with-props | |
1042 (string &optional bound noerror count) | |
1043 "Search backward for STRING, including its text properties. | |
1044 Set point to the beginning of occurrence found, and return point. | |
1045 The match found must include all text properties that STRING has, in | |
1046 the same places, but it is allowed to have others that STRING lacks. | |
1047 An optional second argument bounds the search; it is a buffer position. | |
1048 The match found must not start before that position. nil is equivalent | |
1049 to (point-min). | |
1050 Optional third argument, if t, means if fail just return nil (no error). | |
1051 If not nil and not t, move to limit of search and return nil. | |
1052 Optional fourth argument is repeat count--search for successive occurrences. | |
1053 See also the functions `match-beginning', `match-end' and `replace-match'." | |
1054 (interactive "sSearch for: ") | |
1055 (or bound (setq bound (point-min))) | |
1056 (or count (setq count 1)) | |
1057 (let ((start (point)) | |
1058 (res t)) | |
1059 (while (and res (> count 0)) | |
1060 (while (and (setq res (search-backward string bound t)) | |
1061 (not (enriched-text-properties-include | |
1062 string (buffer-substring (match-beginning 0) | |
1063 (match-end 0)))))) | |
1064 (setq count (1- count))) | |
1065 (cond (res) | |
1066 ((eq noerror t) (goto-char start) nil) | |
1067 (noerror (goto-char bound) nil) | |
1068 (t (goto-char start) | |
1069 (error "Search failed: %s" string))))) | |
1070 | |
1071 (defun enriched-text-properties-include (a b) | |
1072 "True if all of A's text-properties are also properties of B. | |
1073 They must match in property name, value, and position. B must be at least as | |
1074 long as A, but comparison is done only up to the length of A." | |
1075 (let ((loc (length a))) | |
1076 (catch 'fail | |
1077 (while (>= loc 0) | |
1078 (let ((plist (text-properties-at loc a))) | |
1079 (while plist | |
1080 (if (not (equal (car (cdr plist)) | |
1081 (get-text-property loc (car plist) b))) | |
1082 (throw 'fail nil)) | |
1083 (setq plist (cdr (cdr plist))))) | |
1084 (setq loc (1- loc))) | |
1085 t))) | |
1086 | |
1087 (defun enriched-map-property-regions (prop func &optional from to) | |
1088 "Apply a function to regions of the buffer based on a text property. | |
1089 For each contiguous region of the buffer for which the value of PROPERTY is | |
1090 eq, the FUNCTION will be called. Optional arguments FROM and TO specify the | |
1091 region over which to scan. | |
1092 | |
1093 The specified function receives three arguments: the VALUE of the property in | |
1094 the region, and the START and END of each region." | |
1095 (save-excursion | |
1096 (save-restriction | |
1097 (if to (narrow-to-region (point-min) to)) | |
1098 (goto-char (or from (point-min))) | |
1099 (let ((begin (point)) | |
1100 end | |
1101 (marker (make-marker)) | |
1102 (val (get-text-property (point) prop))) | |
1103 (while (setq end (text-property-not-all begin (point-max) prop val)) | |
1104 (move-marker marker end) | |
1105 (funcall func val begin (marker-position marker)) | |
1106 (setq begin (marker-position marker) | |
1107 val (get-text-property marker prop))) | |
1108 (if (< begin (point-max)) | |
1109 (funcall func val begin (point-max))))))) | |
1110 | |
1111 (put 'enriched-map-property-regions 'lisp-indent-hook 1) | |
1112 | |
1113 (defun enriched-insert-annotations (list &optional offset) | |
1114 "Apply list of annotations to buffer as write-region would. | |
1115 Inserts each element of LIST of buffer annotations at its appropriate place. | |
1116 Use second arg OFFSET if the annotations' locations are not | |
1117 relative to the beginning of the buffer: annotations will be inserted | |
1118 at their location-OFFSET+1 \(ie, the offset is the character number of | |
1119 the first character in the buffer)." | |
1120 (if (not offset) | |
1121 (setq offset 0) | |
1122 (setq offset (1- offset))) | |
1123 (let ((l (reverse list))) | |
1124 (while l | |
1125 (goto-char (- (car (car l)) offset)) | |
1126 (insert (cdr (car l))) | |
1127 (setq l (cdr l))))) | |
1128 | |
1129 ;;; | |
1130 ;;; Indentation, Filling, Justification | |
1131 ;;; | |
1132 | |
1133 (defun enriched-insert-hard-newline (n) | |
1134 ;; internal function; use enriched-newline for most purposes. | |
1135 (while (> n 0) | |
1136 (insert-and-inherit ?\n) | |
1137 (add-text-properties (1- (point)) (point) | |
1138 (list 'hard-newline t | |
1139 'rear-nonsticky '(hard-newline) | |
1140 'front-sticky nil)) | |
1141 (enriched-show-region-as-code (1- (point)) (point) 'newline) | |
1142 (setq n (1- n)))) | |
1143 | |
1144 (defun enriched-left-margin () | |
1145 "Return the left margin of this line. | |
1146 This is defined as the value of the text-property `left-margin' in | |
1147 effect at the first character of the line, or the value of the | |
1148 variable `left-margin' if this is nil, or 0." | |
1149 (save-excursion | |
1150 (beginning-of-line) | |
1151 (or (get-text-property (point) 'left-margin) 0))) | |
1152 | |
1153 (defun enriched-fill-column (&optional pos) | |
1154 "Return the fill-column in effect at POS or point. | |
1155 This is `enriched-text-width' minus the current `right-margin' | |
1156 text-property." | |
1157 (- (enriched-text-width) | |
1158 (or (get-text-property (or pos (point)) 'right-margin) 0))) | |
1159 | |
1160 (defun enriched-move-to-fill-column () | |
1161 "Move point to right margin of current line. | |
1162 For filling, the line should be broken before this point." | |
1163 ;; Defn: The first point where (enriched-fill-column) <= (current-column) | |
1164 (interactive) | |
1165 (goto-char | |
1166 (catch 'found | |
1167 (enriched-map-property-regions 'right-margin | |
1168 (lambda (v b e) | |
1169 (goto-char (1- e)) | |
1170 (if (<= (enriched-fill-column) (current-column)) | |
1171 (progn (move-to-column (enriched-fill-column)) | |
1172 (throw 'found (point))))) | |
1173 (progn (beginning-of-line) (point)) | |
1174 (progn (end-of-line) (point))) | |
1175 (end-of-line) | |
1176 (point)))) | |
1177 | |
1178 (defun enriched-line-length () | |
1179 "Length of text part of current line." | |
1180 (save-excursion | |
1181 (- (progn (end-of-line) (current-column)) | |
1182 (progn (enriched-beginning-of-line) (current-column))))) | |
1183 | |
1184 (defun enriched-text-width () | |
1185 "The width of unindented text in this window, in characters. | |
1186 This is the width of the window minus `enriched-default-right-margin'." | |
1187 (or enriched-text-width | |
1188 (let ((ww (window-width))) | |
1189 (setq enriched-text-width | |
1190 (if (> ww enriched-default-right-margin) | |
1191 (- ww enriched-default-right-margin) | |
1192 ww))))) | |
1193 | |
1194 (defun enriched-tag-indentation (from to) | |
1195 "Define region to be indentation." | |
1196 (add-text-properties from to '(enriched-indentation t | |
1197 rear-nonsticky (enriched-indentation)))) | |
1198 | |
1199 (defun enriched-indent-line (&optional column) | |
1200 "Line-indenting primitive for enriched-mode. | |
1201 By default, indents current line to `enriched-left-margin'. | |
1202 Optional arg COLUMN asks for indentation to that column, eg to indent a | |
1203 centered or flushright line." | |
1204 (save-excursion | |
1205 (beginning-of-line) | |
1206 (or column (setq column (enriched-left-margin))) | |
1207 (let ((bol (point))) | |
1208 (if (not (get-text-property (point) 'enriched-indentation)) | |
1209 nil ; no current indentation | |
1210 (goto-char (or (text-property-any (point) (point-max) | |
1211 'enriched-indentation nil) | |
1212 (point))) | |
1213 (if (> (current-column) column) ; too far right | |
1214 (delete-region bol (point)))) | |
1215 (indent-to column) | |
1216 (if (= bol (point)) | |
1217 nil | |
1218 ;; Indentation gets same properties as first real char. | |
1219 (set-text-properties bol (point) (text-properties-at (point))) | |
1220 (enriched-show-region-as-code bol (point) 'indent) | |
1221 (enriched-tag-indentation bol (point)))))) | |
1222 | |
1223 (defun enriched-insert-indentation (&optional from to) | |
1224 "Indent and justify each line in the region." | |
1225 (save-excursion | |
1226 (save-restriction | |
1227 (if to (narrow-to-region (point-min) to)) | |
1228 (goto-char (or from (point-min))) | |
1229 (if (not (bolp)) (forward-line 1)) | |
1230 (while (not (eobp)) | |
1231 (enriched-justify-line) | |
1232 (forward-line 1))))) | |
1233 | |
1234 (defun enriched-delete-indentation (&optional from to) | |
1235 "Remove indentation and justification from region. | |
1236 Does not alter the left-margin and right-margin text properties, so the | |
1237 indentation can be reconstructed. Tries only to remove whitespace that was | |
1238 added automatically, not spaces and tabs inserted by user." | |
1239 (save-excursion | |
1240 (save-restriction | |
1241 (if to (narrow-to-region (point-min) to)) | |
1242 (if from | |
1243 (progn (goto-char from) | |
1244 (if (not (bolp)) (forward-line 1)) | |
1245 (setq from (point)))) | |
1246 ;; Remove everything that has the enriched-indentation text | |
1247 ;; property set, unless it is not at the left margin. In that case, the | |
1248 ;; property must be there by mistake and should be removed. | |
1249 (enriched-map-property-regions 'enriched-indentation | |
1250 (lambda (v b e) | |
1251 (if (null v) | |
1252 nil | |
1253 (goto-char b) | |
1254 (if (bolp) | |
1255 (delete-region b e) | |
1256 (remove-text-properties b e '(enriched-indentation nil | |
1257 rear-nonsticky nil))))) | |
1258 from nil) | |
1259 ;; Remove spaces added for FlushBoth. | |
1260 (enriched-map-property-regions 'justification | |
1261 (lambda (v b e) | |
1262 (if (eq v 'both) | |
1263 (enriched-squeeze-spaces b e))) | |
1264 from nil)))) | |
1265 | |
1266 (defun enriched-change-left-margin (from to inc) | |
1267 "Adjust the left-margin property between FROM and TO by INCREMENT. | |
1268 If the given region includes the character at the left margin, it is extended | |
1269 to include the indentation too." | |
1270 (interactive "*r\np") | |
1271 (if (interactive-p) (setq inc (* inc enriched-indent-increment))) | |
1272 (save-excursion | |
1273 (let ((from (progn (goto-char from) | |
1274 (if (<= (current-column) (enriched-left-margin)) | |
1275 (beginning-of-line)) | |
1276 (point))) | |
1277 (to (progn (goto-char to) | |
1278 (point-marker))) | |
1279 (inhibit-read-only t)) | |
1280 (enriched-delete-indentation from to) | |
1281 (enriched-map-property-regions 'left-margin | |
1282 (lambda (v b e) | |
1283 (put-text-property b e 'left-margin | |
1284 (max 0 (+ inc (or v 0))))) | |
1285 from to) | |
1286 (enriched-fill-region from to) | |
1287 (enriched-show-margin-codes from to)))) | |
1288 | |
1289 (defun enriched-change-right-margin (from to inc) | |
1290 "Adjust the right-margin property between FROM and TO by INCREMENT. | |
1291 If the given region includes the character at the left margin, it is extended | |
1292 to include the indentation too." | |
1293 (interactive "r\np") | |
1294 (if (interactive-p) (setq inc (* inc enriched-indent-increment))) | |
1295 (save-excursion | |
1296 (let ((inhibit-read-only t)) | |
1297 (enriched-map-property-regions 'right-margin | |
1298 (lambda (v b e) | |
1299 (put-text-property b e 'right-margin | |
1300 (max 0 (+ inc (or v 0))))) | |
1301 from to) | |
1302 (fill-region (progn (goto-char from) | |
1303 (enriched-beginning-of-paragraph)) | |
1304 (progn (goto-char to) | |
1305 (enriched-end-of-paragraph))) | |
1306 (enriched-show-margin-codes from to)))) | |
1307 | |
1308 (defun enriched-set-left-margin (from to lm) | |
1309 "Set the left margin of the region to WIDTH. | |
1310 If the given region includes the character at the left margin, it is extended | |
1311 to include the indentation too." | |
1312 (interactive "r\nNSet left margin to column: ") | |
1313 (if (interactive-p) (setq lm (prefix-numeric-value lm))) | |
1314 (save-excursion | |
1315 (let ((from (progn (goto-char from) | |
1316 (if (<= (current-column) (enriched-left-margin)) | |
1317 (beginning-of-line)) | |
1318 (point))) | |
1319 (to (progn (goto-char to) | |
1320 (point-marker))) | |
1321 (inhibit-read-only t)) | |
1322 (enriched-delete-indentation from to) | |
1323 (put-text-property from to 'left-margin lm) | |
1324 (enriched-fill-region from to) | |
1325 (enriched-show-region-as-code from to 'margin)))) | |
1326 | |
1327 (defun enriched-set-right-margin (from to lm) | |
1328 "Set the right margin of the region to WIDTH. | |
1329 The right margin is the space left between fill-column and | |
1330 `enriched-text-width'. | |
1331 If the given region includes the leftmost character on a line, it is extended | |
1332 to include the indentation too." | |
1333 (interactive "r\nNSet left margin to column: ") | |
1334 (if (interactive-p) (setq lm (prefix-numeric-value lm))) | |
1335 (save-excursion | |
1336 (let ((from (progn (goto-char from) | |
1337 (if (<= (current-column) (enriched-left-margin)) | |
1338 (end-of-line 0)) | |
1339 (point))) | |
1340 (to (progn (goto-char to) | |
1341 (point-marker))) | |
1342 (inhibit-read-only t)) | |
1343 (enriched-delete-indentation from to) | |
1344 (put-text-property from to 'right-margin lm) | |
1345 (enriched-fill-region from to) | |
1346 (enriched-show-region-as-code from to 'margin)))) | |
1347 | |
1348 (defun enriched-set-justification (b e val) | |
1349 "Set justification of region to new value." | |
1350 (save-restriction | |
1351 (narrow-to-region (point-min) e) | |
1352 (enriched-delete-indentation b (point-max)) | |
1353 (put-text-property b (point-max) 'justification val) | |
1354 (enriched-fill-region b (point-max)))) | |
1355 | |
1356 (defun enriched-justification () | |
1357 "How should we justify at point? | |
1358 This returns the value of the text-property `justification' or if that is nil, | |
1359 the value of `enriched-default-justification'. However, it returns nil | |
1360 rather than `none' to mean \"don't justify\"." | |
1361 (let ((j (or (get-text-property | |
1362 (if (and (eolp) (not (bolp))) (1- (point)) (point)) | |
1363 'justification) | |
1364 enriched-default-justification))) | |
1365 (if (eq 'none j) | |
1366 nil | |
1367 j))) | |
1368 | |
1369 (defun enriched-justify-line () | |
1370 "Indent and/or justify current line. | |
1371 Action depends on `justification' text property." | |
1372 (let ((just (enriched-justification))) | |
1373 (if (or (null just) (eq 'left just)) | |
1374 (enriched-indent-line) | |
1375 (save-excursion | |
1376 (let ((left-margin (enriched-left-margin)) | |
1377 (fill-column (enriched-fill-column)) | |
1378 (length (enriched-line-length))) | |
1379 (cond ((eq 'both just) | |
1380 (enriched-indent-line left-margin) | |
1381 (end-of-line) | |
1382 (if (not (or (get-text-property (point) 'hard-newline) | |
1383 (= (current-column) fill-column))) | |
1384 (justify-current-line))) | |
1385 ((eq 'center just) | |
1386 (let* ((space (- fill-column left-margin))) | |
1387 (if (and (> length space) enriched-verbose) | |
1388 (enriched-warn "Line too long to center")) | |
1389 (enriched-indent-line | |
1390 (+ left-margin (/ (- space length) 2))))) | |
1391 ((eq 'right just) | |
1392 (end-of-line) | |
1393 (let* ((lmar (- fill-column length))) | |
1394 (if (and (< lmar 0) enriched-verbose) | |
1395 (enriched-warn "Line to long to justify")) | |
1396 (enriched-indent-line lmar))))))))) | |
1397 | |
1398 (defun enriched-squeeze-spaces (from to) | |
1399 "Remove unnecessary spaces between words. | |
1400 This should only be used in FlushBoth regions; otherwise spaces are the | |
1401 property of the user and should not be tampered with." | |
1402 (save-excursion | |
1403 (goto-char from) | |
1404 (let ((endmark (make-marker))) | |
1405 (set-marker endmark to) | |
1406 (while (re-search-forward " *" endmark t) | |
1407 (delete-region | |
1408 (+ (match-beginning 0) | |
1409 (if (save-excursion | |
1410 (skip-chars-backward " ]})\"'") | |
1411 (memq (preceding-char) '(?. ?? ?!))) | |
1412 2 1)) | |
1413 (match-end 0)))))) | |
1414 | |
1415 (defun enriched-fill-region (from to) | |
1416 "Fill each paragraph in region. | |
1417 Whether or not filling or justification is done depends on the text properties | |
1418 in effect at each location." | |
1419 (interactive "r") | |
1420 (save-excursion | |
1421 (goto-char to) | |
1422 (let ((to (point-marker))) | |
1423 (goto-char from) | |
1424 (while (< (point) to) | |
1425 (let ((begin (point))) | |
1426 (enriched-end-of-paragraph) | |
1427 (enriched-fill-region-as-paragraph begin (point))) | |
1428 (if (not (eobp)) | |
1429 (forward-char 1)))))) | |
1430 | |
1431 (defun enriched-fill-region-as-paragraph (from to) | |
1432 "Make sure region is filled properly between margins. | |
1433 Whether or not filling or justification is done depends on the text properties | |
1434 in effect at each location." | |
1435 (save-restriction | |
1436 (narrow-to-region (point-min) to) | |
1437 (goto-char from) | |
1438 (let ((just (enriched-justification))) | |
1439 (if (not just) | |
1440 (while (not (eobp)) | |
1441 (enriched-indent-line) | |
1442 (forward-line 1)) | |
1443 (enriched-delete-indentation from (point-max)) | |
1444 (enriched-indent-line) | |
1445 ;; Following 3 lines taken from fill.el: | |
1446 (while (re-search-forward "[.?!][])}\"']*$" nil t) | |
1447 (insert-and-inherit ?\ )) | |
1448 (subst-char-in-region from (point-max) ?\n ?\ ) | |
1449 ;; If we are full-justifying, we can commandeer all extra spaces. | |
1450 ;; Remove them before filling. | |
1451 (if (eq 'both just) | |
1452 (enriched-squeeze-spaces from (point-max))) | |
1453 ;; Now call on auto-fill for each different segment of the par. | |
1454 (enriched-map-property-regions 'right-margin | |
1455 (lambda (v b e) | |
1456 (goto-char (1- e)) | |
1457 (enriched-auto-fill-function)) | |
1458 from (point-max)) | |
1459 (goto-char (point-max)) | |
1460 (enriched-justify-line))))) | |
1461 | |
1462 (defun enriched-auto-fill-function () | |
1463 "If past `enriched-fill-column', break current line. | |
1464 Line so ended will be filled and justified, as appropriate." | |
1465 (if (and (not enriched-mode) enriched-old-bindings) | |
1466 ;; Mode was turned off improperly. | |
1467 (progn (enriched-mode 0) | |
1468 (funcall auto-fill-function)) | |
1469 ;; Necessary for FlushRight, etc: | |
1470 (enriched-indent-line) ; standardize left margin | |
1471 (let* ((fill-column (enriched-fill-column)) | |
1472 (lmar (save-excursion (enriched-beginning-of-line) (point))) | |
1473 (rmar (save-excursion (end-of-line) (point))) | |
1474 (justify (enriched-justification)) | |
1475 (give-up (not justify))) ; don't even start if in a NoFill region. | |
1476 ;; remove inside spaces if FlushBoth | |
1477 (if (eq justify 'both) | |
1478 (enriched-squeeze-spaces lmar rmar)) | |
1479 (while (and (not give-up) (> (current-column) fill-column)) | |
1480 ;; Determine where to split the line. | |
1481 (setq lmar (save-excursion (enriched-beginning-of-line) (point))) | |
1482 (let ((fill-point | |
1483 (let ((opoint (point)) | |
1484 bounce | |
1485 (first t)) | |
1486 (save-excursion | |
1487 (enriched-move-to-fill-column) | |
1488 ;; Move back to a word boundary. | |
1489 (while (or first | |
1490 ;; If this is after period and a single space, | |
1491 ;; move back once more--we don't want to break | |
1492 ;; the line there and make it look like a | |
1493 ;; sentence end. | |
1494 (and (not (bobp)) | |
1495 (not bounce) | |
1496 sentence-end-double-space | |
1497 (save-excursion (forward-char -1) | |
1498 (and (looking-at "\\. ") | |
1499 (not (looking-at "\\. " )))))) | |
1500 (setq first nil) | |
1501 (skip-chars-backward "^ \t\n") | |
1502 ;; If we are not allowed to break here, move back to | |
1503 ;; somewhere that may be legal. If no legal spots, this | |
1504 ;; will land us at bol. | |
1505 ;;(if (not (enriched-canbreak)) | |
1506 ;; (goto-char (previous-single-property-change | |
1507 ;; (point) 'justification nil lmar))) | |
1508 ;; If we find nowhere on the line to break it, | |
1509 ;; break after one word. Set bounce to t | |
1510 ;; so we will not keep going in this while loop. | |
1511 (if (<= (point) lmar) | |
1512 (progn | |
1513 (re-search-forward "[ \t]" opoint t) | |
1514 ;;(while (and (re-search-forward "[ \t]" opoint t) | |
1515 ;; (not (enriched-canbreak)))) | |
1516 (setq bounce t))) | |
1517 (skip-chars-backward " \t")) | |
1518 ;; Let fill-point be set to the place where we end up. | |
1519 (point))))) | |
1520 ;; If that place is not the beginning of the line, | |
1521 ;; break the line there. | |
1522 (if ; and (enriched-canbreak).... | |
1523 (save-excursion | |
1524 (goto-char fill-point) | |
1525 (not (bolp))) | |
1526 (let ((prev-column (current-column))) | |
1527 ;; If point is at the fill-point, do not `save-excursion'. | |
1528 ;; Otherwise, if a comment prefix or fill-prefix is inserted, | |
1529 ;; point will end up before it rather than after it. | |
1530 (if (save-excursion | |
1531 (skip-chars-backward " \t") | |
1532 (= (point) fill-point)) | |
1533 (progn | |
1534 (insert-and-inherit "\n") | |
1535 (delete-region (point) | |
1536 (progn (skip-chars-forward " ") (point))) | |
1537 (enriched-indent-line)) | |
1538 (save-excursion | |
1539 (goto-char fill-point) | |
1540 (insert-and-inherit "\n") | |
1541 (delete-region (point) | |
1542 (progn (skip-chars-forward " ") (point))) | |
1543 (enriched-indent-line))) | |
1544 ;; Now do proper sort of justification of the previous line | |
1545 (save-excursion | |
1546 (end-of-line 0) | |
1547 (enriched-justify-line)) | |
1548 ;; If making the new line didn't reduce the hpos of | |
1549 ;; the end of the line, then give up now; | |
1550 ;; trying again will not help. | |
1551 (if (>= (current-column) prev-column) | |
1552 (setq give-up t))) | |
1553 ;; No place to break => stop trying. | |
1554 (setq give-up t)))) | |
1555 ;; Check last line too ? | |
1556 ))) | |
1557 | |
1558 (defun enriched-aggressive-auto-fill-function () | |
1559 "Too slow." | |
1560 (save-excursion | |
1561 (enriched-fill-region (progn (beginning-of-line) (point)) | |
1562 (enriched-end-of-paragraph)))) | |
1563 | |
1564 ;;; | |
1565 ;;; Writing Files | |
1566 ;;; | |
1567 | |
1568 (defsubst enriched-open-annotation (name) | |
1569 (insert-and-inherit (enriched-make-annotation name t))) | |
1570 | |
1571 (defsubst enriched-close-annotation (name) | |
1572 (insert-and-inherit (enriched-make-annotation name nil))) | |
1573 | |
1574 (defun enriched-annotate-function (start end) | |
1575 "For use on write-region-annotations-functions. | |
1576 Makes a new buffer containing the region in text/enriched format." | |
1577 (if enriched-mode | |
1578 (let (;(enriched-file (file-name-nondirectory buffer-file-name)) | |
1579 (copy-buf (generate-new-buffer "*Enriched Temp*"))) | |
1580 (copy-to-buffer copy-buf start end) | |
1581 (set-buffer copy-buf) | |
1582 (enriched-insert-annotations write-region-annotations-so-far start) | |
1583 (setq write-region-annotations-so-far nil) | |
1584 (enriched-encode-region))) | |
1585 nil) | |
1586 | |
1587 (defun enriched-encode-region (&optional from to) | |
1588 "Transform buffer into text/enriched format." | |
1589 (if enriched-verbose (message "Enriched: encoding document...")) | |
1590 (setq enriched-ignored-list enriched-ignored-ok) | |
1591 (save-excursion | |
1592 (save-restriction | |
1593 (if to (narrow-to-region (point-min) to)) | |
1594 (enriched-delete-indentation from to) | |
1595 (let ((enriched-open-ans nil) | |
1596 (inhibit-read-only t)) | |
1597 (goto-char (or from (point-min))) | |
1598 (insert (if (stringp enriched-initial-annotation) | |
1599 enriched-initial-annotation | |
1600 (funcall enriched-initial-annotation))) | |
1601 (while | |
1602 (let* ((ans (enriched-loc-annotations (point))) | |
1603 (neg-ans (enriched-reorder (car ans) enriched-open-ans)) | |
1604 (pos-ans (cdr ans))) | |
1605 ;; First do the negative (closing) annotations | |
1606 (while neg-ans | |
1607 (if (not (member (car neg-ans) enriched-open-ans)) | |
1608 (enriched-warn "BUG DETECTED: Closing %s with open list=%s" | |
1609 (enriched-pop neg-ans) enriched-open-ans) | |
1610 (while (not (equal (car neg-ans) (car enriched-open-ans))) | |
1611 ;; To close anno. N, need to first close ans 1 to N-1, | |
1612 ;; remembering to re-open them later. | |
1613 (enriched-push (car enriched-open-ans) pos-ans) | |
1614 (enriched-close-annotation (enriched-pop enriched-open-ans))) | |
1615 ;; Now we can safely close this anno & remove from open list | |
1616 (enriched-close-annotation (enriched-pop neg-ans)) | |
1617 (enriched-pop enriched-open-ans))) | |
1618 ;; Now deal with positive (opening) annotations | |
1619 (while pos-ans | |
1620 (enriched-push (car pos-ans) enriched-open-ans) | |
1621 (enriched-open-annotation (enriched-pop pos-ans))) | |
1622 (enriched-move-to-next-property-change))) | |
1623 | |
1624 ;; Close up shop... | |
1625 (goto-char (point-max)) | |
1626 (while enriched-open-ans | |
1627 (enriched-close-annotation (enriched-pop enriched-open-ans))) | |
1628 (if (not (= ?\n (char-after (1- (point))))) | |
1629 (insert ?\n))) | |
1630 (if (and enriched-verbose (> (length enriched-ignored-list) | |
1631 (length enriched-ignored-ok))) | |
1632 (let ((not-ok nil)) | |
1633 (while (not (eq enriched-ignored-list enriched-ignored-ok)) | |
1634 (setq not-ok (cons (car enriched-ignored-list) not-ok) | |
1635 enriched-ignored-list (cdr enriched-ignored-list))) | |
1636 (enriched-warn "Not recorded: %s" not-ok) | |
1637 (sit-for 1)))))) | |
1638 | |
1639 (defun enriched-move-to-next-property-change () | |
1640 "Advance point to next prop change, dealing with special items on the way. | |
1641 Returns the location, or nil." | |
1642 (let ((prop-change (next-property-change (point)))) | |
1643 (while (and (< (point) (or prop-change (point-max))) | |
1644 (search-forward enriched-encode-interesting-regexp | |
1645 prop-change 1)) | |
1646 (goto-char (match-beginning 0)) | |
1647 (let ((specials enriched-encode-special-alist)) | |
1648 (while specials | |
1649 (if (enriched-looking-at-with-props (car (car specials))) | |
1650 (progn (goto-char (match-end 0)) | |
1651 (funcall (cdr (car specials))) | |
1652 (setq specials nil)) | |
1653 (enriched-pop specials))))) | |
1654 prop-change)) | |
1655 | |
1656 (defun enriched-loc-annotations (loc) | |
1657 "Return annotation(s) needed at LOCATION. | |
1658 This includes any properties that change between LOC-1 and LOC. | |
1659 If LOC is at the beginning of the buffer, will generate annotations for any | |
1660 non-nil properties there, plus the enriched-version annotation. | |
1661 Annotations are returned as a list. The car of the list is the list of | |
1662 names of the annotations to close, and the cdr is the list of the names of the | |
1663 annotations to open." | |
1664 (let* ((prev-loc (1- loc)) | |
1665 (begin (< prev-loc (point-min))) | |
1666 (before-plist (if begin nil (text-properties-at prev-loc))) | |
1667 (after-plist (text-properties-at loc)) | |
1668 negatives positives prop props) | |
1669 ;; make list of all property names involved | |
1670 (while before-plist | |
1671 (enriched-push (car before-plist) props) | |
1672 (setq before-plist (cdr (cdr before-plist)))) | |
1673 (while after-plist | |
1674 (enriched-push (car after-plist) props) | |
1675 (setq after-plist (cdr (cdr after-plist)))) | |
1676 (setq props (enriched-make-list-uniq props)) | |
1677 | |
1678 (while props | |
1679 (setq prop (enriched-pop props)) | |
1680 (if (memq prop enriched-ignored-list) | |
1681 nil ; If its been ignored before, ignore it now. | |
1682 (let ((before (if begin nil (get-text-property prev-loc prop))) | |
1683 (after (get-text-property loc prop))) | |
1684 (if (equal before after) | |
1685 nil ; no change; ignore | |
1686 (let ((result (enriched-annotate-change prop before after))) | |
1687 (setq negatives (nconc negatives (car result)) | |
1688 positives (nconc positives (cdr result)))))))) | |
1689 (cons negatives positives))) | |
1690 | |
1691 (defun enriched-annotate-change (prop old new) | |
1692 "Return annotations for PROPERTY changing from OLD to NEW. | |
1693 These are searched for in `enriched-annotation-list'. | |
1694 If NEW does not appear in the list, but there is a default function, then that | |
1695 function is called. | |
1696 Annotations are returned as a list, as in `enriched-loc-annotations'." | |
1697 ;; If property is numeric, nil means 0 | |
1698 (if (or (consp old) (consp new)) | |
1699 (let* ((old (if (listp old) old (list old))) | |
1700 (new (if (listp new) new (list new))) | |
1701 (tail (enriched-common-tail old new)) | |
1702 close open) | |
1703 (while old | |
1704 (setq close | |
1705 (append (car (enriched-annotate-change prop (car old) nil)) | |
1706 close) | |
1707 old (cdr old))) | |
1708 (while new | |
1709 (setq open | |
1710 (append (cdr (enriched-annotate-change prop nil (car new))) | |
1711 open) | |
1712 new (cdr new))) | |
1713 (enriched-make-relatively-unique close open)) | |
1714 (cond ((and (numberp old) (null new)) | |
1715 (setq new 0)) | |
1716 ((and (numberp new) (null old)) | |
1717 (setq old 0))) | |
1718 (let ((prop-alist (cdr (assoc prop enriched-annotation-alist))) | |
1719 default) | |
1720 (cond ((null prop-alist) ; not found | |
1721 (if (not (memq prop enriched-ignored-list)) | |
1722 (enriched-push prop enriched-ignored-list)) | |
1723 nil) | |
1724 | |
1725 ;; Numerical values: use the difference | |
1726 ((and (numberp old) (numberp new)) | |
1727 (let* ((entry (progn | |
1728 (while (and (car (car prop-alist)) | |
1729 (not (numberp (car (car prop-alist))))) | |
1730 (enriched-pop prop-alist)) | |
1731 (car prop-alist))) | |
1732 (increment (car (car prop-alist))) | |
1733 (n (ceiling (/ (float (- new old)) (float increment)))) | |
1734 (anno (car (cdr (car prop-alist))))) | |
1735 (if (> n 0) | |
1736 (cons nil (make-list n anno)) | |
1737 (cons (make-list (- n) anno) nil)))) | |
1738 | |
1739 ;; Standard annotation | |
1740 (t (let ((close (and old (cdr (assoc old prop-alist)))) | |
1741 (open (and new (cdr (assoc new prop-alist))))) | |
1742 (if (or close open) | |
1743 (enriched-make-relatively-unique close open) | |
1744 (let ((default (assoc nil prop-alist))) | |
1745 (if default | |
1746 (funcall (car (cdr default)) old new)))))))))) | |
1747 | |
1748 ;;; | |
1749 ;;; Reading files | |
1750 ;;; | |
1751 | |
1752 (defun enriched-decode-region (&optional from to) | |
1753 "Decode text/enriched buffer into text with properties. | |
1754 This is the primary entry point for decoding." | |
1755 (if enriched-verbose (message "Enriched: decoding document...")) | |
1756 (save-excursion | |
1757 (save-restriction | |
1758 (if to (narrow-to-region (point-min) to)) | |
1759 (goto-char (or from (point-min))) | |
1760 (let ((file-width (enriched-get-file-width)) | |
1761 (inhibit-read-only t) | |
1762 enriched-open-ans todo loc unknown-ans) | |
1763 | |
1764 (while (enriched-move-to-next-annotation) | |
1765 (let* ((loc (match-beginning 0)) | |
1766 (anno (buffer-substring (match-beginning 0) (match-end 0))) | |
1767 (name (enriched-annotation-name anno)) | |
1768 (positive (enriched-annotation-positive-p anno))) | |
1769 | |
1770 (if enriched-downcase-annotations | |
1771 (setq name (downcase name))) | |
1772 | |
1773 (delete-region (match-beginning 0) (match-end 0)) | |
1774 (if positive | |
1775 (enriched-push (list name loc) enriched-open-ans) | |
1776 ;; negative... | |
1777 (let* ((top (car enriched-open-ans)) | |
1778 (top-name (car top)) | |
1779 (start (car (cdr top))) | |
1780 (params (cdr (cdr top))) | |
1781 (aalist enriched-annotation-alist) | |
1782 (matched nil)) | |
1783 (if (not (equal name top-name)) | |
1784 (error (format "Improper nesting in file: %s != %s" | |
1785 name top))) | |
1786 (while aalist | |
1787 (let ((prop (car (car aalist))) | |
1788 (alist (cdr (car aalist)))) | |
1789 (while alist | |
1790 (let ((value (car (car alist))) | |
1791 (ans (cdr (car alist)))) | |
1792 (if (member name ans) | |
1793 ;; Check if multiple annotations are satisfied | |
1794 (if (member 'nil (mapcar | |
1795 (lambda (r) | |
1796 (assoc r enriched-open-ans)) | |
1797 ans)) | |
1798 nil ; multiple ans not satisfied | |
1799 ;; Yes, we got it: | |
1800 (setq alist nil aalist nil matched t | |
1801 enriched-open-ans (cdr enriched-open-ans)) | |
1802 (cond | |
1803 ((eq prop 'PARAMETER) | |
1804 ;; This is a parameter of the top open ann. | |
1805 (let ((nxt (enriched-pop enriched-open-ans))) | |
1806 (if nxt | |
1807 (enriched-push | |
1808 (append | |
1809 nxt | |
1810 (list (buffer-substring start loc))) | |
1811 enriched-open-ans)) | |
1812 (delete-region start loc))) | |
1813 ((eq prop 'FUNCTION) | |
1814 (let ((rtn (apply value start loc params))) | |
1815 (if rtn (enriched-push rtn todo)))) | |
1816 (t | |
1817 ;; Normal property/value pair | |
1818 (enriched-push (list start loc prop value) | |
1819 todo)))))) | |
1820 (enriched-pop alist))) | |
1821 (enriched-pop aalist)) | |
1822 (if matched | |
1823 nil | |
1824 ;; Didn't find it | |
1825 (enriched-pop enriched-open-ans) | |
1826 (enriched-push (list start loc 'unknown name) todo) | |
1827 (enriched-push name unknown-ans)))))) | |
1828 | |
1829 ;; Now actually add the properties | |
1830 | |
1831 (while todo | |
1832 (let* ((item (enriched-pop todo)) | |
1833 (from (elt item 0)) | |
1834 (to (elt item 1)) | |
1835 (prop (elt item 2)) | |
1836 (val (elt item 3))) | |
1837 | |
1838 ; (if (and (eq prop 'IGNORE) ; 'IGNORE' pseudo-property was special | |
1839 ; (eq val t)) | |
1840 ; (delete-region from to)) | |
1841 (put-text-property | |
1842 from to prop | |
1843 (cond ((numberp val) | |
1844 (+ val (or (get-text-property from prop) 0))) | |
1845 ((memq prop enriched-list-valued-properties) | |
1846 (let ((prev (get-text-property from prop))) | |
1847 (cons val (if (listp prev) prev (list prev))))) | |
1848 (t val))))) | |
1849 | |
1850 (if (or (and file-width ; possible reasons not to fill: | |
1851 (= file-width (enriched-text-width))) ; correct wd. | |
1852 (null enriched-fill-after-visiting) ; never fill | |
1853 (and (eq 'ask enriched-fill-after-visiting) ; asked & declined | |
1854 (not (y-or-n-p "Reformat for current display width? ")))) | |
1855 ;; Minimally, we have to insert indentation and justification. | |
1856 (enriched-insert-indentation) | |
1857 (sit-for 1) | |
1858 (if enriched-verbose (message "Filling paragraphs...")) | |
1859 (enriched-fill-region (point-min) (point-max)) | |
1860 (if enriched-verbose (message nil))) | |
1861 | |
1862 (if enriched-verbose | |
1863 (progn | |
1864 (message nil) | |
1865 (if unknown-ans | |
1866 (enriched-warn "Unknown annotations: %s" unknown-ans)))))))) | |
1867 | |
1868 (defun enriched-get-file-width () | |
1869 "Look for file width information on this line." | |
1870 (save-excursion | |
1871 (if (search-forward "width:" (save-excursion (end-of-line) (point)) t) | |
1872 (read (current-buffer))))) | |
1873 | |
1874 (defun enriched-move-to-next-annotation () | |
1875 "Advances point to next annotation, dealing with special items on the way. | |
1876 Returns t if one was found, otherwise nil." | |
1877 (while (and (re-search-forward enriched-decode-interesting-regexp nil t) | |
1878 (goto-char (match-beginning 0)) | |
1879 (not (looking-at enriched-annotation-regexp))) | |
1880 (let ((regexps enriched-decode-special-alist)) | |
1881 (while (and regexps | |
1882 (not (looking-at (car (car regexps))))) | |
1883 (enriched-pop regexps)) | |
1884 (if regexps | |
1885 (funcall (cdr (car regexps))) | |
1886 (forward-char 1)))) ; nothing found | |
1887 (not (eobp))) | |
1888 | |
1889 ;;; enriched.el ends here |