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))))
|
|
424 (or (and (fboundp 'facemenu-get-face) (facemenu-get-face face))
|
|
425 (progn (enriched-warn "Color \"%s\" not defined" color)
|
|
426 (if window-system
|
|
427 (enriched-warn
|
|
428 " Try M-x set-face-foreground RET %s RET some-other-color" face))))
|
|
429 (list from to 'face face)))
|
|
430
|
|
431 (defun enriched-decode-background (from to color)
|
|
432 (let ((face (intern (concat "bg:" color))))
|
|
433 (or (and (fboundp 'facemenu-get-face) (facemenu-get-face face))
|
|
434 (progn
|
|
435 (enriched-warn "Color \"%s\" not defined" color)
|
|
436 (if window-system
|
|
437 (enriched-warn
|
|
438 " Try M-x set-face-background RET %s RET some-other-color" face))))
|
|
439 (list from to 'face face)))
|
|
440
|
|
441 ;;;
|
|
442 ;;; NOTE: Everything below this point is intended to be independent of the file
|
|
443 ;;; format, which is defined by the variables and functions above.
|
|
444 ;;;
|
|
445
|
|
446 ;;;
|
|
447 ;;; Define the mode
|
|
448 ;;;
|
|
449
|
|
450 (defun enriched-mode (&optional arg notrans)
|
|
451 "Minor mode for editing text/enriched files.
|
|
452 These are files with embedded formatting information in the MIME standard
|
|
453 text/enriched format.
|
|
454
|
|
455 Turning the mode on or off interactively will query whether the buffer
|
|
456 should be translated into or out of text/enriched format immediately.
|
|
457 Noninteractively translation is done without query unless the optional
|
|
458 second argument NO-TRANS is non-nil.
|
|
459 Turning mode on runs `enriched-mode-hooks'.
|
|
460
|
|
461 More information about enriched-mode is available in the file
|
|
462 etc/enriched.doc in the Emacs distribution directory.
|
|
463
|
|
464 Commands:
|
|
465
|
|
466 \\<enriched-mode-map>\\{enriched-mode-map}"
|
|
467 (interactive "P")
|
|
468 (let ((mod (buffer-modified-p)))
|
|
469 (cond ((or (<= (prefix-numeric-value arg) 0)
|
|
470 (and enriched-mode (null arg)))
|
|
471 ;; Turn mode off
|
|
472 (setq enriched-mode nil)
|
|
473 (if (if (interactive-p)
|
|
474 (y-or-n-p "Translate buffer into text/enriched format?")
|
|
475 (not notrans))
|
|
476 (progn (enriched-encode-region)
|
|
477 (mapcar (lambda (x)
|
|
478 (remove-text-properties
|
|
479 (point-min) (point-max)
|
|
480 (list (if (consp x) (car x) x) nil)))
|
|
481 (append enriched-ignored-ok
|
|
482 enriched-annotation-alist))
|
|
483 (setq enriched-translated nil)))
|
|
484 ;; restore old variable values
|
|
485 (while enriched-old-bindings
|
|
486 (funcall 'set (car enriched-old-bindings)
|
|
487 (car (cdr enriched-old-bindings)))
|
|
488 (setq enriched-old-bindings (cdr (cdr enriched-old-bindings))))
|
|
489 (remove-hook 'write-region-annotate-functions
|
|
490 'enriched-annotate-function t)
|
|
491 (remove-hook 'after-change-functions 'enriched-nogrow-hook t))
|
|
492 (enriched-mode nil) ; Mode already on; do nothing.
|
|
493 (t ; Turn mode on
|
|
494 ;; save old variable values before we change them.
|
|
495 (setq enriched-mode t
|
|
496 enriched-old-bindings
|
|
497 (list 'indent-line-function indent-line-function
|
|
498 'auto-fill-function auto-fill-function
|
|
499 'buffer-display-table buffer-display-table
|
|
500 'fill-column fill-column
|
|
501 'auto-save-interval auto-save-interval
|
|
502 'sentence-end-double-space sentence-end-double-space))
|
|
503 (make-local-variable 'auto-fill-function)
|
|
504 (make-local-variable 'auto-save-interval)
|
|
505 (make-local-variable 'indent-line-function)
|
|
506 (make-local-variable 'sentence-end-double-space)
|
|
507 (setq buffer-display-table enriched-display-table
|
|
508 indent-line-function 'enriched-indent-line
|
|
509 auto-fill-function 'enriched-auto-fill-function
|
|
510 fill-column 0 ; always run auto-fill-function
|
|
511 auto-save-interval enriched-auto-save-interval
|
|
512 sentence-end-double-space nil) ; Weird in Center&FlushRight
|
|
513 ;; Add hooks
|
|
514 (add-hook 'write-region-annotate-functions
|
|
515 'enriched-annotate-function)
|
|
516 (add-hook 'after-change-functions 'enriched-nogrow-hook)
|
|
517
|
|
518 (put-text-property (point-min) (point-max)
|
|
519 'front-sticky enriched-par-props)
|
|
520
|
|
521 (if (and (not enriched-translated)
|
|
522 (if (interactive-p)
|
|
523 (y-or-n-p "Does buffer need to be translated now? ")
|
|
524 (not notrans)))
|
|
525 (progn (enriched-decode-region)
|
|
526 (setq enriched-translated t)))
|
|
527 (run-hooks 'enriched-mode-hooks)))
|
|
528 (set-buffer-modified-p mod)
|
|
529 (force-mode-line-update)))
|
|
530
|
|
531 ;;;
|
|
532 ;;; Keybindings
|
|
533 ;;;
|
|
534
|
|
535 (defvar enriched-mode-map nil
|
|
536 "Keymap for `enriched-mode'.")
|
|
537
|
|
538 (if (null enriched-mode-map)
|
|
539 (fset 'enriched-mode-map (setq enriched-mode-map (make-sparse-keymap))))
|
|
540
|
|
541 (if (not (assq 'enriched-mode minor-mode-map-alist))
|
|
542 (setq minor-mode-map-alist
|
|
543 (cons (cons 'enriched-mode enriched-mode-map)
|
|
544 minor-mode-map-alist)))
|
|
545
|
|
546 (define-key enriched-mode-map "\r" 'enriched-newline)
|
|
547 (define-key enriched-mode-map "\n" 'enriched-newline)
|
|
548 (define-key enriched-mode-map "\C-a" 'enriched-beginning-of-line)
|
|
549 (define-key enriched-mode-map "\C-o" 'enriched-open-line)
|
|
550 (define-key enriched-mode-map "\M-{" 'enriched-backward-paragraph)
|
|
551 (define-key enriched-mode-map "\M-}" 'enriched-forward-paragraph)
|
|
552 (define-key enriched-mode-map "\M-q" 'enriched-fill-paragraph)
|
|
553 (define-key enriched-mode-map "\M-S" 'enriched-set-justification-center)
|
|
554 (define-key enriched-mode-map "\C-x\t" 'enriched-change-left-margin)
|
|
555 (define-key enriched-mode-map "\C-c\C-l" 'enriched-set-left-margin)
|
|
556 (define-key enriched-mode-map "\C-c\C-r" 'enriched-set-right-margin)
|
|
557 (define-key enriched-mode-map "\C-c\C-s" 'enriched-show-codes)
|
|
558 (define-key enriched-mode-map "\M-j" 'enriched-justification-menu-map)
|
|
559
|
|
560 ;;; These extend the "Face" menu.
|
|
561 (let ((menu (car (where-is-internal facemenu-menu))))
|
|
562 (if (null menu)
|
|
563 nil
|
|
564 (define-key enriched-mode-map
|
|
565 (apply 'vector (append menu '(Sep-faces))) '("------"))
|
|
566 (define-key enriched-mode-map
|
|
567 (apply 'vector (append menu '(Justification)))
|
|
568 (cons "Justification" 'enriched-justification-menu-map))
|
|
569 (define-key enriched-mode-map
|
|
570 (apply 'vector (append menu '(Indentation)))
|
|
571 (cons "Indentation" 'enriched-indentation-menu-map))))
|
|
572
|
|
573 ;;; The "Indentation" sub-menu:
|
|
574
|
|
575 (defvar enriched-indentation-menu-map (make-sparse-keymap "Indentation")
|
|
576 "Submenu for indentation commands.")
|
|
577 (defalias 'enriched-indentation-menu-map enriched-indentation-menu-map)
|
|
578
|
|
579 (define-key enriched-indentation-menu-map [UnIndentRight]
|
|
580 (cons "UnIndentRight" 'enriched-unindent-right))
|
|
581 (define-key enriched-indentation-menu-map [IndentRight]
|
|
582 (cons "IndentRight" 'enriched-indent-right))
|
|
583 (define-key enriched-indentation-menu-map [Unindent]
|
|
584 (cons "UnIndent" 'enriched-unindent))
|
|
585 (define-key enriched-indentation-menu-map [Indent]
|
|
586 (cons "Indent" ' enriched-indent))
|
|
587
|
|
588 ;;; The "Justification" sub-menu:
|
|
589 (defvar enriched-justification-menu-map (make-sparse-keymap "Justification")
|
|
590 "Submenu for text justification commands.")
|
|
591 (defalias 'enriched-justification-menu-map enriched-justification-menu-map)
|
|
592
|
|
593 (define-key enriched-justification-menu-map [?c]
|
|
594 (cons "Center" 'enriched-set-justification-center))
|
|
595 (define-key enriched-justification-menu-map [?b]
|
|
596 (cons "Flush Both" 'enriched-set-justification-both))
|
|
597 (define-key enriched-justification-menu-map [?r]
|
|
598 (cons "Flush Right" 'enriched-set-justification-right))
|
|
599 (define-key enriched-justification-menu-map [?l]
|
|
600 (cons "Flush Left" 'enriched-set-justification-left))
|
|
601 (define-key enriched-justification-menu-map [?u]
|
|
602 (cons "Unfilled" 'enriched-set-nofill))
|
|
603
|
|
604 ;;;
|
|
605 ;;; Interactive Functions
|
|
606 ;;;
|
|
607
|
|
608 (defun enriched-newline (n)
|
|
609 "Insert N hard newlines.
|
|
610 These are newlines that will not be affected by paragraph filling or
|
|
611 justification; they are used for necessary line breaks or to separate
|
|
612 paragraphs."
|
|
613 (interactive "*p")
|
|
614 (enriched-auto-fill-function)
|
|
615 (while (> n 0)
|
|
616 (enriched-insert-hard-newline 1)
|
|
617 (end-of-line 0)
|
|
618 (enriched-justify-line)
|
|
619 (beginning-of-line 2)
|
|
620 (setq n (1- n)))
|
|
621 (enriched-indent-line))
|
|
622
|
|
623 (defun enriched-open-line (arg)
|
|
624 "Inserts a newline and leave point before it.
|
|
625 With arg N, inserts N newlines. Makes sure all lines are properly indented."
|
|
626 (interactive "*p")
|
|
627 (save-excursion
|
|
628 (enriched-newline arg))
|
|
629 (enriched-auto-fill-function)
|
|
630 (end-of-line))
|
|
631
|
|
632 (defun enriched-beginning-of-line (&optional n)
|
|
633 "Move point to the beginning of the text part of the current line.
|
|
634 This is after all indentation due to left-margin setting or center or right
|
|
635 justification, but before any literal spaces or tabs used for indentation.
|
|
636 With argument ARG not nil or 1, move forward ARG - 1 lines first.
|
|
637 If scan reaches end of buffer, stop there without error."
|
|
638 (interactive "p")
|
|
639 (beginning-of-line n)
|
|
640 ; (if (interactive-p) (enriched-justify-line))
|
|
641 (goto-char
|
|
642 (or (text-property-any (point) (point-max) 'enriched-indentation nil)
|
|
643 (point-max))))
|
|
644
|
|
645 (defun enriched-backward-paragraph (n)
|
|
646 "Move backward N paragraphs.
|
|
647 Hard newlines are considered to be the only paragraph separators."
|
|
648 (interactive "p")
|
|
649 (enriched-forward-paragraph (- n)))
|
|
650
|
|
651 (defun enriched-forward-paragraph (n)
|
|
652 "Move forward N paragraphs.
|
|
653 Hard newlines are considered to be the only paragraph separators."
|
|
654 (interactive "p")
|
|
655 (if (> n 0)
|
|
656 (while (> n 0)
|
|
657 (skip-chars-forward " \t\n")
|
|
658 (enriched-end-of-paragraph)
|
|
659 (setq n (1- n)))
|
|
660 (while (< n 0)
|
|
661 (skip-chars-backward " \t\n")
|
|
662 (enriched-beginning-of-paragraph)
|
|
663 (setq n (1+ n)))
|
|
664 (enriched-beginning-of-line)))
|
|
665
|
|
666 (defun enriched-fill-paragraph ()
|
|
667 "Make the current paragraph fit between its left and right margins."
|
|
668 (interactive)
|
|
669 (save-excursion
|
|
670 (enriched-fill-region-as-paragraph (enriched-beginning-of-paragraph)
|
|
671 (enriched-end-of-paragraph))))
|
|
672
|
|
673 (defun enriched-indent (b e)
|
|
674 "Make the left margin of the region larger."
|
|
675 (interactive "r")
|
|
676 (enriched-change-left-margin b e enriched-indent-increment))
|
|
677
|
|
678 (defun enriched-unindent (b e)
|
|
679 "Make the left margin of the region smaller."
|
|
680 (interactive "r")
|
|
681 (enriched-change-left-margin b e (- enriched-indent-increment)))
|
|
682
|
|
683 (defun enriched-indent-right (b e)
|
|
684 "Make the right margin of the region larger."
|
|
685 (interactive "r")
|
|
686 (enriched-change-right-margin b e enriched-indent-increment))
|
|
687
|
|
688 (defun enriched-unindent-right (b e)
|
|
689 "Make the right margin of the region smaller."
|
|
690 (interactive "r")
|
|
691 (enriched-change-right-margin b e (- enriched-indent-increment)))
|
|
692
|
|
693 (defun enriched-set-nofill (b e)
|
|
694 "Disable automatic filling in the region.
|
|
695 Actually applies to all lines ending in the region.
|
|
696 If mark is not active, applies to the current line."
|
|
697 (interactive (enriched-region-pars))
|
|
698 (enriched-set-justification b e 'none))
|
|
699
|
|
700 (defun enriched-set-justification-left (b e)
|
|
701 "Declare the region to be left-justified.
|
|
702 This is usually the default, but see `enriched-default-justification'."
|
|
703 (interactive (enriched-region-pars))
|
|
704 (enriched-set-justification b e 'left))
|
|
705
|
|
706 (defun enriched-set-justification-right (b e)
|
|
707 "Declare paragraphs in the region to be right-justified:
|
|
708 Flush at the right margin and ragged on the left.
|
|
709 If mark is not active, applies to the current paragraph."
|
|
710 (interactive (enriched-region-pars))
|
|
711 (enriched-set-justification b e 'right))
|
|
712
|
|
713 (defun enriched-set-justification-both (b e)
|
|
714 "Declare the region to be fully justified.
|
|
715 If mark is not active, applies to the current paragraph."
|
|
716 (interactive (enriched-region-pars))
|
|
717 (enriched-set-justification b e 'both))
|
|
718
|
|
719 (defun enriched-set-justification-center (b e)
|
|
720 "Make each line in the region centered.
|
|
721 If mark is not active, applies to the current paragraph."
|
|
722 (interactive (enriched-region-pars))
|
|
723 (enriched-set-justification b e 'center))
|
|
724
|
|
725 ;;;
|
|
726 ;;; General list/stack manipulation
|
|
727 ;;;
|
|
728
|
|
729 (defmacro enriched-push (item stack)
|
|
730 "Push ITEM onto STACK.
|
|
731 STACK should be a symbol whose value is a list."
|
|
732 (` (setq (, stack) (cons (, item) (, stack)))))
|
|
733
|
|
734 (defmacro enriched-pop (stack)
|
|
735 "Remove and return first item on STACK."
|
|
736 (` (let ((pop-item (car (, stack))))
|
|
737 (setq (, stack) (cdr (, stack)))
|
|
738 pop-item)))
|
|
739
|
|
740 (defun enriched-delq1 (cons list)
|
|
741 "Remove the given CONS from LIST by side effect.
|
|
742 Since CONS could be the first element of LIST, write
|
|
743 `(setq foo (enriched-delq1 element foo))' to be sure of changing the value
|
|
744 of `foo'."
|
|
745 (if (eq cons list)
|
|
746 (cdr list)
|
|
747 (let ((p list))
|
|
748 (while (not (eq (cdr p) cons))
|
|
749 (if (null p) (error "enriched-delq1: Attempt to delete a non-element"))
|
|
750 (setq p (cdr p)))
|
|
751 ;; Now (cdr p) is the cons to delete
|
|
752 (setcdr p (cdr cons))
|
|
753 list)))
|
|
754
|
|
755 (defun enriched-make-list-uniq (list)
|
|
756 "Destructively remove duplicates from LIST.
|
|
757 Compares using `eq'."
|
|
758 (let ((l list))
|
|
759 (while l
|
|
760 (setq l (setcdr l (delq (car l) (cdr l)))))
|
|
761 list))
|
|
762
|
|
763 (defun enriched-make-relatively-unique (a b)
|
|
764 "Delete common elements of lists A and B, return as pair.
|
|
765 Compares using `equal'."
|
|
766 (let* ((acopy (copy-sequence a))
|
|
767 (bcopy (copy-sequence b))
|
|
768 (tail acopy))
|
|
769 (while tail
|
|
770 (let ((dup (member (car tail) bcopy))
|
|
771 (next (cdr tail)))
|
|
772 (if dup (setq acopy (enriched-delq1 tail acopy)
|
|
773 bcopy (enriched-delq1 dup bcopy)))
|
|
774 (setq tail next)))
|
|
775 (cons acopy bcopy)))
|
|
776
|
|
777 (defun enriched-common-tail (a b)
|
|
778 "Given two lists that have a common tail, return it.
|
|
779 Compares with `equal', and returns the part of A that is equal to the
|
|
780 equivalent part of B. If even the last items of the two are not equal,
|
|
781 returns nil."
|
|
782 (let ((la (length a))
|
|
783 (lb (length b)))
|
|
784 ;; Make sure they are the same length
|
|
785 (while (> la lb)
|
|
786 (setq a (cdr a)
|
|
787 la (1- la)))
|
|
788 (while (> lb la)
|
|
789 (setq b (cdr b)
|
|
790 lb (1- lb))))
|
|
791 (while (not (equal a b))
|
|
792 (setq a (cdr a)
|
|
793 b (cdr b)))
|
|
794 a)
|
|
795
|
|
796 (defun enriched-which-assoc (items list)
|
|
797 "Return which one of ITEMS occurs first as a car of an element of LIST."
|
|
798 (let (res)
|
|
799 (while list
|
|
800 (if (setq res (member (car (car list)) items))
|
|
801 (setq res (car res)
|
|
802 list nil)
|
|
803 (setq list (cdr list))))
|
|
804 res))
|
|
805
|
|
806 (defun enriched-reorder (items order)
|
|
807 "Arrange ITEMS to following partial ORDER.
|
|
808 Elements of ITEMS equal to elements of ORDER will be rearranged to follow the
|
|
809 ORDER. Unmatched items will go last."
|
|
810 (if order
|
|
811 (let ((item (member (car order) items)))
|
|
812 (if item
|
|
813 (cons (car item)
|
|
814 (enriched-reorder (enriched-delq1 item items)
|
|
815 (cdr order)))
|
|
816 (enriched-reorder items (cdr order))))
|
|
817 items))
|
|
818
|
|
819 ;;;
|
|
820 ;;; Utility functions
|
|
821 ;;;
|
|
822
|
|
823 (defun enriched-get-face-attribute (attr face &optional frame)
|
|
824 "Get an attribute of a face or list of faces.
|
|
825 ATTRIBUTE should be one of the functions `face-font' `face-foreground',
|
|
826 `face-background', or `face-underline-p'. FACE can be a face or a list of
|
|
827 faces. If optional argument FRAME is given, report on the face in that frame.
|
|
828 If FRAME is t, report on the defaults for the face in new frames. If FRAME is
|
|
829 omitted or nil, use the selected frame."
|
|
830 (cond ((null face) nil)
|
|
831 ((or (symbolp face) (internal-facep face)) (funcall attr face frame))
|
|
832 ((funcall attr (car face) frame))
|
|
833 ((enriched-get-face-attribute attr (cdr face) frame))))
|
|
834
|
|
835 (defun enriched-region-pars ()
|
|
836 "Return region expanded to begin and end at paragraph breaks.
|
|
837 If the region is not active, this is just the current paragraph.
|
|
838 A paragraph does not count as overlapping the region if only whitespace is
|
|
839 overlapping. Return value is a list of two numers, the beginning and end of
|
|
840 the defined region."
|
|
841 (save-excursion
|
|
842 (let* ((b (progn (if mark-active (goto-char (region-beginning)))
|
|
843 (enriched-beginning-of-paragraph)))
|
|
844 (e (progn (if mark-active (progn (goto-char (region-end))
|
|
845 (skip-chars-backward " \t\n" b)))
|
|
846 (min (point-max)
|
|
847 (1+ (enriched-end-of-paragraph))))))
|
|
848 (list b e))))
|
|
849
|
|
850 (defun enriched-end-of-paragraph ()
|
|
851 "Move to the end of the current paragraph.
|
|
852 Only hard newlines delimit paragraphs. Returns point."
|
|
853 (interactive)
|
|
854 (if (not (bolp)) (backward-char 1))
|
|
855 (if (enriched-search-forward-with-props enriched-hard-newline nil 1)
|
|
856 (backward-char 1))
|
|
857 (point))
|
|
858
|
|
859 (defun enriched-beginning-of-paragraph ()
|
|
860 "Move to beginning of the current paragraph.
|
|
861 Only hard newlines delimit paragraphs. Returns point."
|
|
862 (interactive)
|
|
863 (if (not (eolp)) (forward-char 1))
|
|
864 (if (enriched-search-backward-with-props enriched-hard-newline nil 1)
|
|
865 (forward-char 1))
|
|
866 (point))
|
|
867
|
|
868 (defun enriched-overlays-overlapping (begin end &optional test)
|
|
869 "Return a list of the overlays which overlap the specified region.
|
|
870 If optional arg TEST is given, it is called with each overlay as its
|
|
871 argument, and only those for which it is true are returned."
|
|
872 (overlay-recenter begin)
|
|
873 (let ((res nil)
|
|
874 (overlays (cdr (overlay-lists)))) ; includes all ending after BEGIN
|
|
875 (while overlays
|
|
876 (if (and (< (overlay-start (car overlays)) end)
|
|
877 (or (not test)
|
|
878 (funcall test (car overlays))))
|
|
879 (enriched-push (car overlays) res))
|
|
880 (setq overlays (cdr overlays)))
|
|
881 res))
|
|
882
|
|
883 (defun enriched-show-codes (&rest which)
|
|
884 "Enable or disable highlighting of special regions.
|
|
885 With argument null or `none', turns off highlighting.
|
|
886 If argument is `newline', turns on display of hard newlines.
|
|
887 If argument is `indent', highlights the automatic indentation at the beginning
|
|
888 of each line.
|
|
889 If argument is `margin', highlights all regions with non-standard margins."
|
|
890 (interactive
|
|
891 (list (intern (completing-read "Show which codes: "
|
|
892 '(("none") ("newline") ("indent") ("margin"))
|
|
893 nil t))))
|
|
894 (if (null which)
|
|
895 (setq enriched-show-codes nil)
|
|
896 (setq enriched-show-codes which))
|
|
897 ;; First delete current overlays
|
|
898 (let* ((ol (overlay-lists))
|
|
899 (overlays (append (car ol) (cdr ol))))
|
|
900 (while overlays
|
|
901 (if (eq (overlay-get (car overlays) 'face) 'enriched-code-face)
|
|
902 (delete-overlay (car overlays)))
|
|
903 (setq overlays (cdr overlays))))
|
|
904 ;; Now add new ones for each thing displayed.
|
|
905 (if (null which)
|
|
906 (message "Code display off."))
|
|
907 (while which
|
|
908 (cond ((eq (car which) 'margin)
|
|
909 (enriched-show-margin-codes))
|
|
910 ((eq (car which) 'indent)
|
|
911 (enriched-map-property-regions 'enriched-indentation
|
|
912 (lambda (v b e)
|
|
913 (if v (enriched-show-region-as-code b e 'indent)))))
|
|
914 ((eq (car which) 'newline)
|
|
915 (save-excursion
|
|
916 (goto-char (point-min))
|
|
917 (while (enriched-search-forward-with-props
|
|
918 enriched-hard-newline nil t)
|
|
919 (enriched-show-region-as-code (match-beginning 0) (match-end 0)
|
|
920 'newline)))))
|
|
921 (setq which (cdr which))))
|
|
922
|
|
923 (defun enriched-show-margin-codes (&optional from to)
|
|
924 "Highlight regions with nonstandard left-margins.
|
|
925 See `enriched-show-codes'."
|
|
926 (enriched-map-property-regions 'left-margin
|
|
927 (lambda (v b e)
|
|
928 (if (and v (> v 0))
|
|
929 (enriched-show-region-as-code b e 'margin)))
|
|
930 from to)
|
|
931 (enriched-map-property-regions 'right-margin
|
|
932 (lambda (v b e)
|
|
933 (if (and v (> v 0))
|
|
934 (enriched-show-region-as-code b e 'margin)))
|
|
935 from to))
|
|
936
|
|
937 (defun enriched-show-region-as-code (from to type)
|
|
938 "Display region between FROM and TO as a code if TYPE is displayed.
|
|
939 Displays it only if TYPE is an element of `enriched-show-codes' or is t."
|
|
940 (if (or (eq t type) (memq type enriched-show-codes))
|
|
941 (let* ((old (enriched-overlays-overlapping
|
|
942 from to (lambda (o)
|
|
943 (eq 'enriched-code-face
|
|
944 (overlay-get o 'face)))))
|
|
945 (new (if old (move-overlay (car old) from to)
|
|
946 (make-overlay from to))))
|
|
947 (overlay-put new 'face 'enriched-code-face)
|
|
948 (overlay-put new 'front-nogrow t)
|
|
949 (if (eq type 'margin)
|
|
950 (overlay-put new 'rear-grow t))
|
|
951 (while (setq old (cdr old))
|
|
952 (delete-overlay (car old))))))
|
|
953
|
|
954 (defun enriched-nogrow-hook (beg end old-length)
|
|
955 "Implement front-nogrow and rear-grow for overlays.
|
|
956 Normally overlays have opposite inheritance properties than
|
|
957 text-properties: they will expand to include text inserted at their
|
|
958 beginning, but not text inserted at their end. However,
|
|
959 if this function is an element of `after-change-functions', then
|
|
960 overlays with a non-nil value of the `front-nogrow' property will not
|
|
961 expand to include text that is inserted just in front of them, and
|
|
962 overlays with a non-nil value of the `rear-grow' property will
|
|
963 expand to include text that is inserted just after them."
|
|
964 (if (not (zerop old-length))
|
|
965 nil ;; not an insertion
|
|
966 (let ((overlays (overlays-at end)) o)
|
|
967 (while overlays
|
|
968 (setq o (car overlays)
|
|
969 overlays (cdr overlays))
|
|
970 (if (and (overlay-get o 'front-nogrow)
|
|
971 (= beg (overlay-start o)))
|
|
972 (move-overlay o end (overlay-end o)))))
|
|
973 (let ((overlays (overlays-at (1- beg))) o)
|
|
974 (while overlays
|
|
975 (setq o (car overlays)
|
|
976 overlays (cdr overlays))
|
|
977 (if (and (overlay-get o 'rear-grow)
|
|
978 (= beg (overlay-end o)))
|
|
979 (move-overlay o (overlay-start o) end))))))
|
|
980
|
|
981 (defun enriched-warn (&rest args)
|
|
982 "Display a warning message.
|
|
983 Arguments are given to `format' and the result is displayed in a buffer."
|
|
984 (save-excursion
|
|
985 (let ((buf (current-buffer))
|
|
986 (line (1+ (count-lines 1 (point))))
|
|
987 (mark (point-marker)))
|
|
988 (pop-to-buffer (get-buffer-create "*Enriched Warnings*"))
|
|
989 (goto-char (point-max))
|
|
990 (insert
|
|
991 ; (format "%s:%d: " (if (boundp 'enriched-file) enriched-file
|
|
992 ; (buffer-file-name buf))
|
|
993 ; line)
|
|
994 (apply (function format) args)
|
|
995 "\n")
|
|
996 (pop-to-buffer buf))))
|
|
997
|
|
998 (defun enriched-looking-at-with-props (string)
|
|
999 "True if text at point is equal to STRING, including text props.
|
|
1000 This is a literal, not a regexp match.
|
|
1001 The buffer text must include all text properties that STRING has, in
|
|
1002 the same places, but it is allowed to have others that STRING lacks."
|
|
1003 (let ((buffer-string (buffer-substring (point) (+ (point) (length string)))))
|
|
1004 (and (string-equal string buffer-string)
|
|
1005 (enriched-text-properties-include string buffer-string))))
|
|
1006
|
|
1007 (defun enriched-search-forward-with-props
|
|
1008 (string &optional bound noerror count)
|
|
1009 "Search forward for STRING, including its text properties.
|
|
1010 Set point to end of occurrence found, and return point.
|
|
1011 The match found must include all text properties that STRING has, in
|
|
1012 the same places, but it is allowed to have others that STRING lacks.
|
|
1013 An optional second argument bounds the search; it is a buffer position.
|
|
1014 The match found must not extend after that position. nil is equivalent
|
|
1015 to (point-max).
|
|
1016 Optional third argument, if t, means if fail just return nil (no error).
|
|
1017 If not nil and not t, move to limit of search and return nil.
|
|
1018 Optional fourth argument is repeat count--search for successive occurrences.
|
|
1019 See also the functions `match-beginning', `match-end' and `replace-match'."
|
|
1020 (interactive "sSearch for: ")
|
|
1021 (or bound (setq bound (point-max)))
|
|
1022 (or count (setq count 1))
|
|
1023 (let ((start (point))
|
|
1024 (res t))
|
|
1025 (while (and res (> count 0))
|
|
1026 (while (and (setq res (search-forward string bound t))
|
|
1027 (not (enriched-text-properties-include
|
|
1028 string (buffer-substring (match-beginning 0)
|
|
1029 (match-end 0))))))
|
|
1030 (setq count (1- count)))
|
|
1031 (cond (res)
|
|
1032 ((eq noerror t) (goto-char start) nil)
|
|
1033 (noerror (goto-char bound) nil)
|
|
1034 (t (goto-char start)
|
|
1035 (error "Search failed: %s" string)))))
|
|
1036
|
|
1037 (defun enriched-search-backward-with-props
|
|
1038 (string &optional bound noerror count)
|
|
1039 "Search backward for STRING, including its text properties.
|
|
1040 Set point to the beginning of occurrence found, and return point.
|
|
1041 The match found must include all text properties that STRING has, in
|
|
1042 the same places, but it is allowed to have others that STRING lacks.
|
|
1043 An optional second argument bounds the search; it is a buffer position.
|
|
1044 The match found must not start before that position. nil is equivalent
|
|
1045 to (point-min).
|
|
1046 Optional third argument, if t, means if fail just return nil (no error).
|
|
1047 If not nil and not t, move to limit of search and return nil.
|
|
1048 Optional fourth argument is repeat count--search for successive occurrences.
|
|
1049 See also the functions `match-beginning', `match-end' and `replace-match'."
|
|
1050 (interactive "sSearch for: ")
|
|
1051 (or bound (setq bound (point-min)))
|
|
1052 (or count (setq count 1))
|
|
1053 (let ((start (point))
|
|
1054 (res t))
|
|
1055 (while (and res (> count 0))
|
|
1056 (while (and (setq res (search-backward string bound t))
|
|
1057 (not (enriched-text-properties-include
|
|
1058 string (buffer-substring (match-beginning 0)
|
|
1059 (match-end 0))))))
|
|
1060 (setq count (1- count)))
|
|
1061 (cond (res)
|
|
1062 ((eq noerror t) (goto-char start) nil)
|
|
1063 (noerror (goto-char bound) nil)
|
|
1064 (t (goto-char start)
|
|
1065 (error "Search failed: %s" string)))))
|
|
1066
|
|
1067 (defun enriched-text-properties-include (a b)
|
|
1068 "True if all of A's text-properties are also properties of B.
|
|
1069 They must match in property name, value, and position. B must be at least as
|
|
1070 long as A, but comparison is done only up to the length of A."
|
|
1071 (let ((loc (length a)))
|
|
1072 (catch 'fail
|
|
1073 (while (>= loc 0)
|
|
1074 (let ((plist (text-properties-at loc a)))
|
|
1075 (while plist
|
|
1076 (if (not (equal (car (cdr plist))
|
|
1077 (get-text-property loc (car plist) b)))
|
|
1078 (throw 'fail nil))
|
|
1079 (setq plist (cdr (cdr plist)))))
|
|
1080 (setq loc (1- loc)))
|
|
1081 t)))
|
|
1082
|
|
1083 (defun enriched-map-property-regions (prop func &optional from to)
|
|
1084 "Apply a function to regions of the buffer based on a text property.
|
|
1085 For each contiguous region of the buffer for which the value of PROPERTY is
|
|
1086 eq, the FUNCTION will be called. Optional arguments FROM and TO specify the
|
|
1087 region over which to scan.
|
|
1088
|
|
1089 The specified function receives three arguments: the VALUE of the property in
|
|
1090 the region, and the START and END of each region."
|
|
1091 (save-excursion
|
|
1092 (save-restriction
|
|
1093 (if to (narrow-to-region (point-min) to))
|
|
1094 (goto-char (or from (point-min)))
|
|
1095 (let ((begin (point))
|
|
1096 end
|
|
1097 (marker (make-marker))
|
|
1098 (val (get-text-property (point) prop)))
|
|
1099 (while (setq end (text-property-not-all begin (point-max) prop val))
|
|
1100 (move-marker marker end)
|
|
1101 (funcall func val begin (marker-position marker))
|
|
1102 (setq begin (marker-position marker)
|
|
1103 val (get-text-property marker prop)))
|
|
1104 (if (< begin (point-max))
|
|
1105 (funcall func val begin (point-max)))))))
|
|
1106
|
|
1107 (put 'enriched-map-property-regions 'lisp-indent-hook 1)
|
|
1108
|
|
1109 (defun enriched-insert-annotations (list &optional offset)
|
|
1110 "Apply list of annotations to buffer as write-region would.
|
|
1111 Inserts each element of LIST of buffer annotations at its appropriate place.
|
|
1112 Use second arg OFFSET if the annotations' locations are not
|
|
1113 relative to the beginning of the buffer: annotations will be inserted
|
|
1114 at their location-OFFSET+1 \(ie, the offset is the character number of
|
|
1115 the first character in the buffer)."
|
|
1116 (if (not offset)
|
|
1117 (setq offset 0)
|
|
1118 (setq offset (1- offset)))
|
|
1119 (let ((l (reverse list)))
|
|
1120 (while l
|
|
1121 (goto-char (- (car (car l)) offset))
|
|
1122 (insert (cdr (car l)))
|
|
1123 (setq l (cdr l)))))
|
|
1124
|
|
1125 ;;;
|
|
1126 ;;; Indentation, Filling, Justification
|
|
1127 ;;;
|
|
1128
|
|
1129 (defun enriched-insert-hard-newline (n)
|
|
1130 ;; internal function; use enriched-newline for most purposes.
|
|
1131 (while (> n 0)
|
|
1132 (insert-and-inherit ?\n)
|
|
1133 (add-text-properties (1- (point)) (point)
|
|
1134 (list 'hard-newline t
|
|
1135 'rear-nonsticky '(hard-newline)
|
|
1136 'front-sticky nil))
|
|
1137 (enriched-show-region-as-code (1- (point)) (point) 'newline)
|
|
1138 (setq n (1- n))))
|
|
1139
|
|
1140 (defun enriched-left-margin ()
|
|
1141 "Return the left margin of this line.
|
|
1142 This is defined as the value of the text-property `left-margin' in
|
|
1143 effect at the first character of the line, or the value of the
|
|
1144 variable `left-margin' if this is nil, or 0."
|
|
1145 (save-excursion
|
|
1146 (beginning-of-line)
|
|
1147 (or (get-text-property (point) 'left-margin) 0)))
|
|
1148
|
|
1149 (defun enriched-fill-column (&optional pos)
|
|
1150 "Return the fill-column in effect at POS or point.
|
|
1151 This is `enriched-text-width' minus the current `right-margin'
|
|
1152 text-property."
|
|
1153 (- (enriched-text-width)
|
|
1154 (or (get-text-property (or pos (point)) 'right-margin) 0)))
|
|
1155
|
|
1156 (defun enriched-move-to-fill-column ()
|
|
1157 "Move point to right margin of current line.
|
|
1158 For filling, the line should be broken before this point."
|
|
1159 ;; Defn: The first point where (enriched-fill-column) <= (current-column)
|
|
1160 (interactive)
|
|
1161 (goto-char
|
|
1162 (catch 'found
|
|
1163 (enriched-map-property-regions 'right-margin
|
|
1164 (lambda (v b e)
|
|
1165 (goto-char (1- e))
|
|
1166 (if (<= (enriched-fill-column) (current-column))
|
|
1167 (progn (move-to-column (enriched-fill-column))
|
|
1168 (throw 'found (point)))))
|
|
1169 (progn (beginning-of-line) (point))
|
|
1170 (progn (end-of-line) (point)))
|
|
1171 (end-of-line)
|
|
1172 (point))))
|
|
1173
|
|
1174 (defun enriched-line-length ()
|
|
1175 "Length of text part of current line."
|
|
1176 (save-excursion
|
|
1177 (- (progn (end-of-line) (current-column))
|
|
1178 (progn (enriched-beginning-of-line) (current-column)))))
|
|
1179
|
|
1180 (defun enriched-text-width ()
|
|
1181 "The width of unindented text in this window, in characters.
|
|
1182 This is the width of the window minus `enriched-default-right-margin'."
|
|
1183 (or enriched-text-width
|
|
1184 (let ((ww (window-width)))
|
|
1185 (setq enriched-text-width
|
|
1186 (if (> ww enriched-default-right-margin)
|
|
1187 (- ww enriched-default-right-margin)
|
|
1188 ww)))))
|
|
1189
|
|
1190 (defun enriched-tag-indentation (from to)
|
|
1191 "Define region to be indentation."
|
|
1192 (add-text-properties from to '(enriched-indentation t
|
|
1193 rear-nonsticky (enriched-indentation))))
|
|
1194
|
|
1195 (defun enriched-indent-line (&optional column)
|
|
1196 "Line-indenting primitive for enriched-mode.
|
|
1197 By default, indents current line to `enriched-left-margin'.
|
|
1198 Optional arg COLUMN asks for indentation to that column, eg to indent a
|
|
1199 centered or flushright line."
|
|
1200 (save-excursion
|
|
1201 (beginning-of-line)
|
|
1202 (or column (setq column (enriched-left-margin)))
|
|
1203 (let ((bol (point)))
|
|
1204 (if (not (get-text-property (point) 'enriched-indentation))
|
|
1205 nil ; no current indentation
|
|
1206 (goto-char (or (text-property-any (point) (point-max)
|
|
1207 'enriched-indentation nil)
|
|
1208 (point)))
|
|
1209 (if (> (current-column) column) ; too far right
|
|
1210 (delete-region bol (point))))
|
|
1211 (indent-to column)
|
|
1212 (if (= bol (point))
|
|
1213 nil
|
|
1214 ;; Indentation gets same properties as first real char.
|
|
1215 (set-text-properties bol (point) (text-properties-at (point)))
|
|
1216 (enriched-show-region-as-code bol (point) 'indent)
|
|
1217 (enriched-tag-indentation bol (point))))))
|
|
1218
|
|
1219 (defun enriched-insert-indentation (&optional from to)
|
|
1220 "Indent and justify each line in the region."
|
|
1221 (save-excursion
|
|
1222 (save-restriction
|
|
1223 (if to (narrow-to-region (point-min) to))
|
|
1224 (goto-char (or from (point-min)))
|
|
1225 (if (not (bolp)) (forward-line 1))
|
|
1226 (while (not (eobp))
|
|
1227 (enriched-justify-line)
|
|
1228 (forward-line 1)))))
|
|
1229
|
|
1230 (defun enriched-delete-indentation (&optional from to)
|
|
1231 "Remove indentation and justification from region.
|
|
1232 Does not alter the left-margin and right-margin text properties, so the
|
|
1233 indentation can be reconstructed. Tries only to remove whitespace that was
|
|
1234 added automatically, not spaces and tabs inserted by user."
|
|
1235 (save-excursion
|
|
1236 (save-restriction
|
|
1237 (if to (narrow-to-region (point-min) to))
|
|
1238 (if from
|
|
1239 (progn (goto-char from)
|
|
1240 (if (not (bolp)) (forward-line 1))
|
|
1241 (setq from (point))))
|
|
1242 ;; Remove everything that has the enriched-indentation text
|
|
1243 ;; property set, unless it is not at the left margin. In that case, the
|
|
1244 ;; property must be there by mistake and should be removed.
|
|
1245 (enriched-map-property-regions 'enriched-indentation
|
|
1246 (lambda (v b e)
|
|
1247 (if (null v)
|
|
1248 nil
|
|
1249 (goto-char b)
|
|
1250 (if (bolp)
|
|
1251 (delete-region b e)
|
|
1252 (remove-text-properties b e '(enriched-indentation nil
|
|
1253 rear-nonsticky nil)))))
|
|
1254 from nil)
|
|
1255 ;; Remove spaces added for FlushBoth.
|
|
1256 (enriched-map-property-regions 'justification
|
|
1257 (lambda (v b e)
|
|
1258 (if (eq v 'both)
|
|
1259 (enriched-squeeze-spaces b e)))
|
|
1260 from nil))))
|
|
1261
|
|
1262 (defun enriched-change-left-margin (from to inc)
|
|
1263 "Adjust the left-margin property between FROM and TO by INCREMENT.
|
|
1264 If the given region includes the character at the left margin, it is extended
|
|
1265 to include the indentation too."
|
|
1266 (interactive "*r\np")
|
|
1267 (if (interactive-p) (setq inc (* inc enriched-indent-increment)))
|
|
1268 (save-excursion
|
|
1269 (let ((from (progn (goto-char from)
|
|
1270 (if (<= (current-column) (enriched-left-margin))
|
|
1271 (beginning-of-line))
|
|
1272 (point)))
|
|
1273 (to (progn (goto-char to)
|
|
1274 (point-marker)))
|
|
1275 (inhibit-read-only t))
|
|
1276 (enriched-delete-indentation from to)
|
|
1277 (enriched-map-property-regions 'left-margin
|
|
1278 (lambda (v b e)
|
|
1279 (put-text-property b e 'left-margin
|
|
1280 (max 0 (+ inc (or v 0)))))
|
|
1281 from to)
|
|
1282 (enriched-fill-region from to)
|
|
1283 (enriched-show-margin-codes from to))))
|
|
1284
|
|
1285 (defun enriched-change-right-margin (from to inc)
|
|
1286 "Adjust the right-margin property between FROM and TO by INCREMENT.
|
|
1287 If the given region includes the character at the left margin, it is extended
|
|
1288 to include the indentation too."
|
|
1289 (interactive "r\np")
|
|
1290 (if (interactive-p) (setq inc (* inc enriched-indent-increment)))
|
|
1291 (save-excursion
|
|
1292 (let ((inhibit-read-only t))
|
|
1293 (enriched-map-property-regions 'right-margin
|
|
1294 (lambda (v b e)
|
|
1295 (put-text-property b e 'right-margin
|
|
1296 (max 0 (+ inc (or v 0)))))
|
|
1297 from to)
|
|
1298 (fill-region (progn (goto-char from)
|
|
1299 (enriched-beginning-of-paragraph))
|
|
1300 (progn (goto-char to)
|
|
1301 (enriched-end-of-paragraph)))
|
|
1302 (enriched-show-margin-codes from to))))
|
|
1303
|
|
1304 (defun enriched-set-left-margin (from to lm)
|
|
1305 "Set the left margin of the region to WIDTH.
|
|
1306 If the given region includes the character at the left margin, it is extended
|
|
1307 to include the indentation too."
|
|
1308 (interactive "r\nNSet left margin to column: ")
|
|
1309 (if (interactive-p) (setq lm (prefix-numeric-value lm)))
|
|
1310 (save-excursion
|
|
1311 (let ((from (progn (goto-char from)
|
|
1312 (if (<= (current-column) (enriched-left-margin))
|
|
1313 (beginning-of-line))
|
|
1314 (point)))
|
|
1315 (to (progn (goto-char to)
|
|
1316 (point-marker)))
|
|
1317 (inhibit-read-only t))
|
|
1318 (enriched-delete-indentation from to)
|
|
1319 (put-text-property from to 'left-margin lm)
|
|
1320 (enriched-fill-region from to)
|
|
1321 (enriched-show-region-as-code from to 'margin))))
|
|
1322
|
|
1323 (defun enriched-set-right-margin (from to lm)
|
|
1324 "Set the right margin of the region to WIDTH.
|
|
1325 The right margin is the space left between fill-column and
|
|
1326 `enriched-text-width'.
|
|
1327 If the given region includes the leftmost character on a line, it is extended
|
|
1328 to include the indentation too."
|
|
1329 (interactive "r\nNSet left margin to column: ")
|
|
1330 (if (interactive-p) (setq lm (prefix-numeric-value lm)))
|
|
1331 (save-excursion
|
|
1332 (let ((from (progn (goto-char from)
|
|
1333 (if (<= (current-column) (enriched-left-margin))
|
|
1334 (end-of-line 0))
|
|
1335 (point)))
|
|
1336 (to (progn (goto-char to)
|
|
1337 (point-marker)))
|
|
1338 (inhibit-read-only t))
|
|
1339 (enriched-delete-indentation from to)
|
|
1340 (put-text-property from to 'right-margin lm)
|
|
1341 (enriched-fill-region from to)
|
|
1342 (enriched-show-region-as-code from to 'margin))))
|
|
1343
|
|
1344 (defun enriched-set-justification (b e val)
|
|
1345 "Set justification of region to new value."
|
|
1346 (save-restriction
|
|
1347 (narrow-to-region (point-min) e)
|
|
1348 (enriched-delete-indentation b (point-max))
|
|
1349 (put-text-property b (point-max) 'justification val)
|
|
1350 (enriched-fill-region b (point-max))))
|
|
1351
|
|
1352 (defun enriched-justification ()
|
|
1353 "How should we justify at point?
|
|
1354 This returns the value of the text-property `justification' or if that is nil,
|
|
1355 the value of `enriched-default-justification'. However, it returns nil
|
|
1356 rather than `none' to mean \"don't justify\"."
|
|
1357 (let ((j (or (get-text-property
|
|
1358 (if (and (eolp) (not (bolp))) (1- (point)) (point))
|
|
1359 'justification)
|
|
1360 enriched-default-justification)))
|
|
1361 (if (eq 'none j)
|
|
1362 nil
|
|
1363 j)))
|
|
1364
|
|
1365 (defun enriched-justify-line ()
|
|
1366 "Indent and/or justify current line.
|
|
1367 Action depends on `justification' text property."
|
|
1368 (let ((just (enriched-justification)))
|
|
1369 (if (or (null just) (eq 'left just))
|
|
1370 (enriched-indent-line)
|
|
1371 (save-excursion
|
|
1372 (let ((left-margin (enriched-left-margin))
|
|
1373 (fill-column (enriched-fill-column))
|
|
1374 (length (enriched-line-length)))
|
|
1375 (cond ((eq 'both just)
|
|
1376 (enriched-indent-line left-margin)
|
|
1377 (end-of-line)
|
|
1378 (if (not (or (get-text-property (point) 'hard-newline)
|
|
1379 (= (current-column) fill-column)))
|
|
1380 (justify-current-line)))
|
|
1381 ((eq 'center just)
|
|
1382 (let* ((space (- fill-column left-margin)))
|
|
1383 (if (and (> length space) enriched-verbose)
|
|
1384 (enriched-warn "Line too long to center"))
|
|
1385 (enriched-indent-line
|
|
1386 (+ left-margin (/ (- space length) 2)))))
|
|
1387 ((eq 'right just)
|
|
1388 (end-of-line)
|
|
1389 (let* ((lmar (- fill-column length)))
|
|
1390 (if (and (< lmar 0) enriched-verbose)
|
|
1391 (enriched-warn "Line to long to justify"))
|
|
1392 (enriched-indent-line lmar)))))))))
|
|
1393
|
|
1394 (defun enriched-squeeze-spaces (from to)
|
|
1395 "Remove unnecessary spaces between words.
|
|
1396 This should only be used in FlushBoth regions; otherwise spaces are the
|
|
1397 property of the user and should not be tampered with."
|
|
1398 (save-excursion
|
|
1399 (goto-char from)
|
|
1400 (let ((endmark (make-marker)))
|
|
1401 (set-marker endmark to)
|
|
1402 (while (re-search-forward " *" endmark t)
|
|
1403 (delete-region
|
|
1404 (+ (match-beginning 0)
|
|
1405 (if (save-excursion
|
|
1406 (skip-chars-backward " ]})\"'")
|
|
1407 (memq (preceding-char) '(?. ?? ?!)))
|
|
1408 2 1))
|
|
1409 (match-end 0))))))
|
|
1410
|
|
1411 (defun enriched-fill-region (from to)
|
|
1412 "Fill each paragraph in region.
|
|
1413 Whether or not filling or justification is done depends on the text properties
|
|
1414 in effect at each location."
|
|
1415 (interactive "r")
|
|
1416 (save-excursion
|
|
1417 (goto-char to)
|
|
1418 (let ((to (point-marker)))
|
|
1419 (goto-char from)
|
|
1420 (while (< (point) to)
|
|
1421 (let ((begin (point)))
|
|
1422 (enriched-end-of-paragraph)
|
|
1423 (enriched-fill-region-as-paragraph begin (point)))
|
|
1424 (if (not (eobp))
|
|
1425 (forward-char 1))))))
|
|
1426
|
|
1427 (defun enriched-fill-region-as-paragraph (from to)
|
|
1428 "Make sure region is filled properly between margins.
|
|
1429 Whether or not filling or justification is done depends on the text properties
|
|
1430 in effect at each location."
|
|
1431 (save-restriction
|
|
1432 (narrow-to-region (point-min) to)
|
|
1433 (goto-char from)
|
|
1434 (let ((just (enriched-justification)))
|
|
1435 (if (not just)
|
|
1436 (while (not (eobp))
|
|
1437 (enriched-indent-line)
|
|
1438 (forward-line 1))
|
|
1439 (enriched-delete-indentation from (point-max))
|
|
1440 (enriched-indent-line)
|
|
1441 ;; Following 3 lines taken from fill.el:
|
|
1442 (while (re-search-forward "[.?!][])}\"']*$" nil t)
|
|
1443 (insert-and-inherit ?\ ))
|
|
1444 (subst-char-in-region from (point-max) ?\n ?\ )
|
|
1445 ;; If we are full-justifying, we can commandeer all extra spaces.
|
|
1446 ;; Remove them before filling.
|
|
1447 (if (eq 'both just)
|
|
1448 (enriched-squeeze-spaces from (point-max)))
|
|
1449 ;; Now call on auto-fill for each different segment of the par.
|
|
1450 (enriched-map-property-regions 'right-margin
|
|
1451 (lambda (v b e)
|
|
1452 (goto-char (1- e))
|
|
1453 (enriched-auto-fill-function))
|
|
1454 from (point-max))
|
|
1455 (goto-char (point-max))
|
|
1456 (enriched-justify-line)))))
|
|
1457
|
|
1458 (defun enriched-auto-fill-function ()
|
|
1459 "If past `enriched-fill-column', break current line.
|
|
1460 Line so ended will be filled and justified, as appropriate."
|
|
1461 (if (and (not enriched-mode) enriched-old-bindings)
|
|
1462 ;; Mode was turned off improperly.
|
|
1463 (progn (enriched-mode 0)
|
|
1464 (funcall auto-fill-function))
|
|
1465 ;; Necessary for FlushRight, etc:
|
|
1466 (enriched-indent-line) ; standardize left margin
|
|
1467 (let* ((fill-column (enriched-fill-column))
|
|
1468 (lmar (save-excursion (enriched-beginning-of-line) (point)))
|
|
1469 (rmar (save-excursion (end-of-line) (point)))
|
|
1470 (justify (enriched-justification))
|
|
1471 (give-up (not justify))) ; don't even start if in a NoFill region.
|
|
1472 ;; remove inside spaces if FlushBoth
|
|
1473 (if (eq justify 'both)
|
|
1474 (enriched-squeeze-spaces lmar rmar))
|
|
1475 (while (and (not give-up) (> (current-column) fill-column))
|
|
1476 ;; Determine where to split the line.
|
|
1477 (setq lmar (save-excursion (enriched-beginning-of-line) (point)))
|
|
1478 (let ((fill-point
|
|
1479 (let ((opoint (point))
|
|
1480 bounce
|
|
1481 (first t))
|
|
1482 (save-excursion
|
|
1483 (enriched-move-to-fill-column)
|
|
1484 ;; Move back to a word boundary.
|
|
1485 (while (or first
|
|
1486 ;; If this is after period and a single space,
|
|
1487 ;; move back once more--we don't want to break
|
|
1488 ;; the line there and make it look like a
|
|
1489 ;; sentence end.
|
|
1490 (and (not (bobp))
|
|
1491 (not bounce)
|
|
1492 sentence-end-double-space
|
|
1493 (save-excursion (forward-char -1)
|
|
1494 (and (looking-at "\\. ")
|
|
1495 (not (looking-at "\\. " ))))))
|
|
1496 (setq first nil)
|
|
1497 (skip-chars-backward "^ \t\n")
|
|
1498 ;; If we are not allowed to break here, move back to
|
|
1499 ;; somewhere that may be legal. If no legal spots, this
|
|
1500 ;; will land us at bol.
|
|
1501 ;;(if (not (enriched-canbreak))
|
|
1502 ;; (goto-char (previous-single-property-change
|
|
1503 ;; (point) 'justification nil lmar)))
|
|
1504 ;; If we find nowhere on the line to break it,
|
|
1505 ;; break after one word. Set bounce to t
|
|
1506 ;; so we will not keep going in this while loop.
|
|
1507 (if (<= (point) lmar)
|
|
1508 (progn
|
|
1509 (re-search-forward "[ \t]" opoint t)
|
|
1510 ;;(while (and (re-search-forward "[ \t]" opoint t)
|
|
1511 ;; (not (enriched-canbreak))))
|
|
1512 (setq bounce t)))
|
|
1513 (skip-chars-backward " \t"))
|
|
1514 ;; Let fill-point be set to the place where we end up.
|
|
1515 (point)))))
|
|
1516 ;; If that place is not the beginning of the line,
|
|
1517 ;; break the line there.
|
|
1518 (if ; and (enriched-canbreak)....
|
|
1519 (save-excursion
|
|
1520 (goto-char fill-point)
|
|
1521 (not (bolp)))
|
|
1522 (let ((prev-column (current-column)))
|
|
1523 ;; If point is at the fill-point, do not `save-excursion'.
|
|
1524 ;; Otherwise, if a comment prefix or fill-prefix is inserted,
|
|
1525 ;; point will end up before it rather than after it.
|
|
1526 (if (save-excursion
|
|
1527 (skip-chars-backward " \t")
|
|
1528 (= (point) fill-point))
|
|
1529 (progn
|
|
1530 (insert-and-inherit "\n")
|
|
1531 (delete-region (point)
|
|
1532 (progn (skip-chars-forward " ") (point)))
|
|
1533 (enriched-indent-line))
|
|
1534 (save-excursion
|
|
1535 (goto-char fill-point)
|
|
1536 (insert-and-inherit "\n")
|
|
1537 (delete-region (point)
|
|
1538 (progn (skip-chars-forward " ") (point)))
|
|
1539 (enriched-indent-line)))
|
|
1540 ;; Now do proper sort of justification of the previous line
|
|
1541 (save-excursion
|
|
1542 (end-of-line 0)
|
|
1543 (enriched-justify-line))
|
|
1544 ;; If making the new line didn't reduce the hpos of
|
|
1545 ;; the end of the line, then give up now;
|
|
1546 ;; trying again will not help.
|
|
1547 (if (>= (current-column) prev-column)
|
|
1548 (setq give-up t)))
|
|
1549 ;; No place to break => stop trying.
|
|
1550 (setq give-up t))))
|
|
1551 ;; Check last line too ?
|
|
1552 )))
|
|
1553
|
|
1554 (defun enriched-aggressive-auto-fill-function ()
|
|
1555 "Too slow."
|
|
1556 (save-excursion
|
|
1557 (enriched-fill-region (progn (beginning-of-line) (point))
|
|
1558 (enriched-end-of-paragraph))))
|
|
1559
|
|
1560 ;;;
|
|
1561 ;;; Writing Files
|
|
1562 ;;;
|
|
1563
|
|
1564 (defsubst enriched-open-annotation (name)
|
|
1565 (insert-and-inherit (enriched-make-annotation name t)))
|
|
1566
|
|
1567 (defsubst enriched-close-annotation (name)
|
|
1568 (insert-and-inherit (enriched-make-annotation name nil)))
|
|
1569
|
|
1570 (defun enriched-annotate-function (start end)
|
|
1571 "For use on write-region-annotations-functions.
|
|
1572 Makes a new buffer containing the region in text/enriched format."
|
|
1573 (if enriched-mode
|
|
1574 (let (;(enriched-file (file-name-nondirectory buffer-file-name))
|
|
1575 (copy-buf (generate-new-buffer "*Enriched Temp*")))
|
|
1576 (copy-to-buffer copy-buf start end)
|
|
1577 (set-buffer copy-buf)
|
|
1578 (enriched-insert-annotations write-region-annotations-so-far start)
|
|
1579 (setq write-region-annotations-so-far nil)
|
|
1580 (enriched-encode-region)))
|
|
1581 nil)
|
|
1582
|
|
1583 (defun enriched-encode-region (&optional from to)
|
|
1584 "Transform buffer into text/enriched format."
|
|
1585 (if enriched-verbose (message "Enriched: encoding document..."))
|
|
1586 (setq enriched-ignored-list enriched-ignored-ok)
|
|
1587 (save-excursion
|
|
1588 (save-restriction
|
|
1589 (if to (narrow-to-region (point-min) to))
|
|
1590 (enriched-delete-indentation from to)
|
|
1591 (let ((enriched-open-ans nil)
|
|
1592 (inhibit-read-only t))
|
|
1593 (goto-char (or from (point-min)))
|
|
1594 (insert (if (stringp enriched-initial-annotation)
|
|
1595 enriched-initial-annotation
|
|
1596 (funcall enriched-initial-annotation)))
|
|
1597 (while
|
|
1598 (let* ((ans (enriched-loc-annotations (point)))
|
|
1599 (neg-ans (enriched-reorder (car ans) enriched-open-ans))
|
|
1600 (pos-ans (cdr ans)))
|
|
1601 ;; First do the negative (closing) annotations
|
|
1602 (while neg-ans
|
|
1603 (if (not (member (car neg-ans) enriched-open-ans))
|
|
1604 (enriched-warn "BUG DETECTED: Closing %s with open list=%s"
|
|
1605 (enriched-pop neg-ans) enriched-open-ans)
|
|
1606 (while (not (equal (car neg-ans) (car enriched-open-ans)))
|
|
1607 ;; To close anno. N, need to first close ans 1 to N-1,
|
|
1608 ;; remembering to re-open them later.
|
|
1609 (enriched-push (car enriched-open-ans) pos-ans)
|
|
1610 (enriched-close-annotation (enriched-pop enriched-open-ans)))
|
|
1611 ;; Now we can safely close this anno & remove from open list
|
|
1612 (enriched-close-annotation (enriched-pop neg-ans))
|
|
1613 (enriched-pop enriched-open-ans)))
|
|
1614 ;; Now deal with positive (opening) annotations
|
|
1615 (while pos-ans
|
|
1616 (enriched-push (car pos-ans) enriched-open-ans)
|
|
1617 (enriched-open-annotation (enriched-pop pos-ans)))
|
|
1618 (enriched-move-to-next-property-change)))
|
|
1619
|
|
1620 ;; Close up shop...
|
|
1621 (goto-char (point-max))
|
|
1622 (while enriched-open-ans
|
|
1623 (enriched-close-annotation (enriched-pop enriched-open-ans)))
|
|
1624 (if (not (= ?\n (char-after (1- (point)))))
|
|
1625 (insert ?\n)))
|
|
1626 (if (and enriched-verbose (> (length enriched-ignored-list)
|
|
1627 (length enriched-ignored-ok)))
|
|
1628 (let ((not-ok nil))
|
|
1629 (while (not (eq enriched-ignored-list enriched-ignored-ok))
|
|
1630 (setq not-ok (cons (car enriched-ignored-list) not-ok)
|
|
1631 enriched-ignored-list (cdr enriched-ignored-list)))
|
|
1632 (enriched-warn "Not recorded: %s" not-ok)
|
|
1633 (sit-for 1))))))
|
|
1634
|
|
1635 (defun enriched-move-to-next-property-change ()
|
|
1636 "Advance point to next prop change, dealing with special items on the way.
|
|
1637 Returns the location, or nil."
|
|
1638 (let ((prop-change (next-property-change (point))))
|
|
1639 (while (and (< (point) (or prop-change (point-max)))
|
|
1640 (search-forward enriched-encode-interesting-regexp
|
|
1641 prop-change 1))
|
|
1642 (goto-char (match-beginning 0))
|
|
1643 (let ((specials enriched-encode-special-alist))
|
|
1644 (while specials
|
|
1645 (if (enriched-looking-at-with-props (car (car specials)))
|
|
1646 (progn (goto-char (match-end 0))
|
|
1647 (funcall (cdr (car specials)))
|
|
1648 (setq specials nil))
|
|
1649 (enriched-pop specials)))))
|
|
1650 prop-change))
|
|
1651
|
|
1652 (defun enriched-loc-annotations (loc)
|
|
1653 "Return annotation(s) needed at LOCATION.
|
|
1654 This includes any properties that change between LOC-1 and LOC.
|
|
1655 If LOC is at the beginning of the buffer, will generate annotations for any
|
|
1656 non-nil properties there, plus the enriched-version annotation.
|
|
1657 Annotations are returned as a list. The car of the list is the list of
|
|
1658 names of the annotations to close, and the cdr is the list of the names of the
|
|
1659 annotations to open."
|
|
1660 (let* ((prev-loc (1- loc))
|
|
1661 (begin (< prev-loc (point-min)))
|
|
1662 (before-plist (if begin nil (text-properties-at prev-loc)))
|
|
1663 (after-plist (text-properties-at loc))
|
|
1664 negatives positives prop props)
|
|
1665 ;; make list of all property names involved
|
|
1666 (while before-plist
|
|
1667 (enriched-push (car before-plist) props)
|
|
1668 (setq before-plist (cdr (cdr before-plist))))
|
|
1669 (while after-plist
|
|
1670 (enriched-push (car after-plist) props)
|
|
1671 (setq after-plist (cdr (cdr after-plist))))
|
|
1672 (setq props (enriched-make-list-uniq props))
|
|
1673
|
|
1674 (while props
|
|
1675 (setq prop (enriched-pop props))
|
|
1676 (if (memq prop enriched-ignored-list)
|
|
1677 nil ; If its been ignored before, ignore it now.
|
|
1678 (let ((before (if begin nil (get-text-property prev-loc prop)))
|
|
1679 (after (get-text-property loc prop)))
|
|
1680 (if (equal before after)
|
|
1681 nil ; no change; ignore
|
|
1682 (let ((result (enriched-annotate-change prop before after)))
|
|
1683 (setq negatives (nconc negatives (car result))
|
|
1684 positives (nconc positives (cdr result))))))))
|
|
1685 (cons negatives positives)))
|
|
1686
|
|
1687 (defun enriched-annotate-change (prop old new)
|
|
1688 "Return annotations for PROPERTY changing from OLD to NEW.
|
|
1689 These are searched for in `enriched-annotation-list'.
|
|
1690 If NEW does not appear in the list, but there is a default function, then that
|
|
1691 function is called.
|
|
1692 Annotations are returned as a list, as in `enriched-loc-annotations'."
|
|
1693 ;; If property is numeric, nil means 0
|
|
1694 (if (or (consp old) (consp new))
|
|
1695 (let* ((old (if (listp old) old (list old)))
|
|
1696 (new (if (listp new) new (list new)))
|
|
1697 (tail (enriched-common-tail old new))
|
|
1698 close open)
|
|
1699 (while old
|
|
1700 (setq close
|
|
1701 (append (car (enriched-annotate-change prop (car old) nil))
|
|
1702 close)
|
|
1703 old (cdr old)))
|
|
1704 (while new
|
|
1705 (setq open
|
|
1706 (append (cdr (enriched-annotate-change prop nil (car new)))
|
|
1707 open)
|
|
1708 new (cdr new)))
|
|
1709 (enriched-make-relatively-unique close open))
|
|
1710 (cond ((and (numberp old) (null new))
|
|
1711 (setq new 0))
|
|
1712 ((and (numberp new) (null old))
|
|
1713 (setq old 0)))
|
|
1714 (let ((prop-alist (cdr (assoc prop enriched-annotation-alist)))
|
|
1715 default)
|
|
1716 (cond ((null prop-alist) ; not found
|
|
1717 (if (not (memq prop enriched-ignored-list))
|
|
1718 (enriched-push prop enriched-ignored-list))
|
|
1719 nil)
|
|
1720
|
|
1721 ;; Numerical values: use the difference
|
|
1722 ((and (numberp old) (numberp new))
|
|
1723 (let* ((entry (progn
|
|
1724 (while (and (car (car prop-alist))
|
|
1725 (not (numberp (car (car prop-alist)))))
|
|
1726 (enriched-pop prop-alist))
|
|
1727 (car prop-alist)))
|
|
1728 (increment (car (car prop-alist)))
|
|
1729 (n (ceiling (/ (float (- new old)) (float increment))))
|
|
1730 (anno (car (cdr (car prop-alist)))))
|
|
1731 (if (> n 0)
|
|
1732 (cons nil (make-list n anno))
|
|
1733 (cons (make-list (- n) anno) nil))))
|
|
1734
|
|
1735 ;; Standard annotation
|
|
1736 (t (let ((close (and old (cdr (assoc old prop-alist))))
|
|
1737 (open (and new (cdr (assoc new prop-alist)))))
|
|
1738 (if (or close open)
|
|
1739 (enriched-make-relatively-unique close open)
|
|
1740 (let ((default (assoc nil prop-alist)))
|
|
1741 (if default
|
|
1742 (funcall (car (cdr default)) old new))))))))))
|
|
1743
|
|
1744 ;;;
|
|
1745 ;;; Reading files
|
|
1746 ;;;
|
|
1747
|
|
1748 (defun enriched-decode-region (&optional from to)
|
|
1749 "Decode text/enriched buffer into text with properties.
|
|
1750 This is the primary entry point for decoding."
|
|
1751 (if enriched-verbose (message "Enriched: decoding document..."))
|
|
1752 (save-excursion
|
|
1753 (save-restriction
|
|
1754 (if to (narrow-to-region (point-min) to))
|
|
1755 (goto-char (or from (point-min)))
|
|
1756 (let ((file-width (enriched-get-file-width))
|
|
1757 (inhibit-read-only t)
|
|
1758 enriched-open-ans todo loc unknown-ans)
|
|
1759
|
|
1760 (while (enriched-move-to-next-annotation)
|
|
1761 (let* ((loc (match-beginning 0))
|
|
1762 (anno (buffer-substring (match-beginning 0) (match-end 0)))
|
|
1763 (name (enriched-annotation-name anno))
|
|
1764 (positive (enriched-annotation-positive-p anno)))
|
|
1765
|
|
1766 (if enriched-downcase-annotations
|
|
1767 (setq name (downcase name)))
|
|
1768
|
|
1769 (delete-region (match-beginning 0) (match-end 0))
|
|
1770 (if positive
|
|
1771 (enriched-push (list name loc) enriched-open-ans)
|
|
1772 ;; negative...
|
|
1773 (let* ((top (car enriched-open-ans))
|
|
1774 (top-name (car top))
|
|
1775 (start (car (cdr top)))
|
|
1776 (params (cdr (cdr top)))
|
|
1777 (aalist enriched-annotation-alist)
|
|
1778 (matched nil))
|
|
1779 (if (not (equal name top-name))
|
|
1780 (error (format "Improper nesting in file: %s != %s"
|
|
1781 name top)))
|
|
1782 (while aalist
|
|
1783 (let ((prop (car (car aalist)))
|
|
1784 (alist (cdr (car aalist))))
|
|
1785 (while alist
|
|
1786 (let ((value (car (car alist)))
|
|
1787 (ans (cdr (car alist))))
|
|
1788 (if (member name ans)
|
|
1789 ;; Check if multiple annotations are satisfied
|
|
1790 (if (member 'nil (mapcar
|
|
1791 (lambda (r)
|
|
1792 (assoc r enriched-open-ans))
|
|
1793 ans))
|
|
1794 nil ; multiple ans not satisfied
|
|
1795 ;; Yes, we got it:
|
|
1796 (setq alist nil aalist nil matched t
|
|
1797 enriched-open-ans (cdr enriched-open-ans))
|
|
1798 (cond
|
|
1799 ((eq prop 'PARAMETER)
|
|
1800 ;; This is a parameter of the top open ann.
|
|
1801 (let ((nxt (enriched-pop enriched-open-ans)))
|
|
1802 (if nxt
|
|
1803 (enriched-push
|
|
1804 (append
|
|
1805 nxt
|
|
1806 (list (buffer-substring start loc)))
|
|
1807 enriched-open-ans))
|
|
1808 (delete-region start loc)))
|
|
1809 ((eq prop 'FUNCTION)
|
|
1810 (let ((rtn (apply value start loc params)))
|
|
1811 (if rtn (enriched-push rtn todo))))
|
|
1812 (t
|
|
1813 ;; Normal property/value pair
|
|
1814 (enriched-push (list start loc prop value)
|
|
1815 todo))))))
|
|
1816 (enriched-pop alist)))
|
|
1817 (enriched-pop aalist))
|
|
1818 (if matched
|
|
1819 nil
|
|
1820 ;; Didn't find it
|
|
1821 (enriched-pop enriched-open-ans)
|
|
1822 (enriched-push (list start loc 'unknown name) todo)
|
|
1823 (enriched-push name unknown-ans))))))
|
|
1824
|
|
1825 ;; Now actually add the properties
|
|
1826
|
|
1827 (while todo
|
|
1828 (let* ((item (enriched-pop todo))
|
|
1829 (from (elt item 0))
|
|
1830 (to (elt item 1))
|
|
1831 (prop (elt item 2))
|
|
1832 (val (elt item 3)))
|
|
1833
|
|
1834 ; (if (and (eq prop 'IGNORE) ; 'IGNORE' pseudo-property was special
|
|
1835 ; (eq val t))
|
|
1836 ; (delete-region from to))
|
|
1837 (put-text-property
|
|
1838 from to prop
|
|
1839 (cond ((numberp val)
|
|
1840 (+ val (or (get-text-property from prop) 0)))
|
|
1841 ((memq prop enriched-list-valued-properties)
|
|
1842 (let ((prev (get-text-property from prop)))
|
|
1843 (cons val (if (listp prev) prev (list prev)))))
|
|
1844 (t val)))))
|
|
1845
|
|
1846 (if (or (and file-width ; possible reasons not to fill:
|
|
1847 (= file-width (enriched-text-width))) ; correct wd.
|
|
1848 (null enriched-fill-after-visiting) ; never fill
|
|
1849 (and (eq 'ask enriched-fill-after-visiting) ; asked & declined
|
|
1850 (not (y-or-n-p "Reformat for current display width? "))))
|
|
1851 ;; Minimally, we have to insert indentation and justification.
|
|
1852 (enriched-insert-indentation)
|
|
1853 (sit-for 1)
|
|
1854 (if enriched-verbose (message "Filling paragraphs..."))
|
|
1855 (enriched-fill-region (point-min) (point-max))
|
|
1856 (if enriched-verbose (message nil)))
|
|
1857
|
|
1858 (if enriched-verbose
|
|
1859 (progn
|
|
1860 (message nil)
|
|
1861 (if unknown-ans
|
|
1862 (enriched-warn "Unknown annotations: %s" unknown-ans))))))))
|
|
1863
|
|
1864 (defun enriched-get-file-width ()
|
|
1865 "Look for file width information on this line."
|
|
1866 (save-excursion
|
|
1867 (if (search-forward "width:" (save-excursion (end-of-line) (point)) t)
|
|
1868 (read (current-buffer)))))
|
|
1869
|
|
1870 (defun enriched-move-to-next-annotation ()
|
|
1871 "Advances point to next annotation, dealing with special items on the way.
|
|
1872 Returns t if one was found, otherwise nil."
|
|
1873 (while (and (re-search-forward enriched-decode-interesting-regexp nil t)
|
|
1874 (goto-char (match-beginning 0))
|
|
1875 (not (looking-at enriched-annotation-regexp)))
|
|
1876 (let ((regexps enriched-decode-special-alist))
|
|
1877 (while (and regexps
|
|
1878 (not (looking-at (car (car regexps)))))
|
|
1879 (enriched-pop regexps))
|
|
1880 (if regexps
|
|
1881 (funcall (cdr (car regexps)))
|
|
1882 (forward-char 1)))) ; nothing found
|
|
1883 (not (eobp)))
|
|
1884
|
|
1885 ;;; enriched.el ends here
|