Mercurial > emacs
annotate lisp/=sc.el @ 26465:b9ad44d699ec
New maintainer.
author | Gerd Moellmann <gerd@gnu.org> |
---|---|
date | Tue, 16 Nov 1999 13:27:36 +0000 |
parents | ca55f9c620c5 |
children |
rev | line source |
---|---|
1745 | 1 ;; -*- Mode: Emacs-Lisp -*- |
2 ;; sc.el -- Version 2.3 (used to be supercite.el) | |
3 | |
4 ;; ========== Introduction ========== | |
5 ;; Citation and attribution package for various GNU emacs news and | |
4662 | 6 ;; electronic mail reading subsystems. This version of supercite should |
7 ;; work with Rmail and GNUS as found in Emacs 19. It may also work with | |
8 ;; VM 4.40+ and MH-E 3.7. | |
1745 | 9 |
10 ;; This package does not do any yanking of messages, but instead | |
11 ;; massages raw reply buffers set up by the reply/forward functions in | |
12 ;; the news/mail subsystems. Therefore, such useful operations as | |
13 ;; yanking and citing portions of the original article (instead of the | |
3591
507f64624555
Apply typo patches from Paul Eggert.
Jim Blandy <jimb@redhat.com>
parents:
3577
diff
changeset
|
14 ;; whole article) are not within the ability or responsibility of |
1745 | 15 ;; supercite. |
16 | |
17 ;; ========== Disclaimer ========== | |
18 ;; This software is distributed in the hope that it will be useful, | |
19 ;; but WITHOUT ANY WARRANTY. No author or distributor, nor any | |
20 ;; author's past, present, or future employers accepts responsibility | |
21 ;; to anyone for the consequences of using it or for whether it serves | |
22 ;; any particular purpose or works at all, unless he says so in | |
23 ;; writing. | |
24 | |
25 ;; Some of this software was written as part of the supercite author's | |
26 ;; official duty as an employee of the United States Government and is | |
27 ;; thus not subject to copyright. You are free to use that particular | |
28 ;; software as you wish, but WITHOUT ANY WARRANTY WHATSOEVER. It | |
29 ;; would be nice, though if when you use any of this or other freely | |
30 ;; available code, you give due credit to the author. | |
31 | |
32 ;; Other parts of this code were written by other people. Wherever | |
33 ;; possible, credit to that author, and the copy* notice supplied by | |
34 ;; the author are included with that code. The supercite author is no | |
35 ;; longer an employee of the U.S. Government so the GNU Public Licence | |
36 ;; should be considered in effect for all enhancements and bug fixes | |
37 ;; performed by the author. | |
38 | |
39 ;; ========== Author (unless otherwise stated) ======================== | |
40 ;; NAME: Barry A. Warsaw USMAIL: Century Computing, Inc. | |
41 ;; TELE: (301) 593-3330 1014 West Street | |
42 ;; INET: bwarsaw@cen.com Laurel, Md 20707 | |
43 ;; UUCP: uunet!cen.com!bwarsaw | |
44 ;; | |
45 ;; Want to be on the Supercite mailing list? | |
46 ;; | |
47 ;; Send articles to: | |
48 ;; Internet: supercite@anthem.nlm.nih.gov | |
49 ;; UUCP: uunet!anthem.nlm.nih.gov!supercite | |
50 ;; | |
51 ;; Send administrivia (additions/deletions to list, etc) to: | |
52 ;; Internet: supercite-request@anthem.nlm.nih.gov | |
53 ;; UUCP: uunet!anthem.nlm.nih.gov!supercite-request | |
54 | |
55 ;; ========== Credits and Thanks ========== | |
56 ;; This package was derived from the Superyank 1.11 package as posted | |
57 ;; to the net. Superyank 1.11 was inspired by code and ideas from | |
58 ;; Martin Neitzel and Ashwin Ram. Supercite version 2.3 has evolved | |
59 ;; through the comments and suggestions of the supercite mailing list | |
60 ;; which consists of many authors and users of the various mail and | |
61 ;; news reading subsystems. | |
62 | |
63 ;; Many folks on the supercite mailing list have contributed their | |
64 ;; help in debugging, making suggestions and supplying support code or | |
65 ;; bug fixes for the previous versions of supercite. I want to thank | |
66 ;; everyone who helped, especially (in no particular order): | |
67 ;; | |
68 ;; Mark D. Baushke, Khalid Sattar, David Lawrence, Chris Davis, Kyle | |
69 ;; Jones, Kayvan Sylvan, Masanobu Umeda, Dan Jacobson, Piet van | |
70 ;; Oostrum, Hamish (H.I.) Macdonald, and Joe Wells. | |
71 ;; | |
72 ;; I don't mean to leave anyone out. All who have helped have been | |
73 ;; appreciated. | |
74 | |
75 ;; ========== Getting Started ========== | |
76 ;; Here is a quick guide to getting started with supercite. The | |
77 ;; information contained here is mostly excerpted from the more | |
78 ;; detailed explanations given in the accompanying README file. | |
79 ;; Naturally, there are many customizations you can do to give your | |
80 ;; replies that personalized flair, but the instructions in this | |
81 ;; section should be sufficient for getting started. | |
82 | |
83 ;; First, to connect supercite to any mail/news reading subsystem, put | |
84 ;; this in your .emacs file: | |
85 ;; | |
3815 | 86 ;; (setq mail-yank-hooks 'sc-cite-original) ; for old mail agents |
1745 | 87 ;; (setq mh-yank-hooks 'sc-cite-original) ; for MH-E only |
3815 | 88 ;; (add-hook 'mail-citation-hook 'sc-cite-original) ; for newer mail agents |
1745 | 89 ;; |
90 ;; If supercite is not pre-loaded into your emacs session, you should | |
91 ;; add the following autoload: | |
92 ;; | |
93 ;; (autoload 'sc-cite-original "sc" "Supercite 2.3" t) | |
94 ;; | |
95 ;; Finally, if you want to customize supercite, you should do it in a | |
96 ;; function called my-supercite-hook and: | |
97 ;; | |
98 ;; (setq sc-load-hook 'my-supercite-hook) | |
99 | |
4323
51964472e60e
Require assoc instead of sc-alist.
Richard M. Stallman <rms@gnu.org>
parents:
3815
diff
changeset
|
100 (require 'assoc) |
1745 | 101 |
102 | |
103 ;; vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv | |
104 ;; start of user defined variables | |
105 ;; vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv | |
106 | |
107 (defvar sc-nested-citation-p nil | |
108 "*Controls whether to use nested or non-nested citation style. | |
109 Non-nil uses nested citations, nil uses non-nested citations. Type | |
110 \\[sc-describe] for more information.") | |
111 | |
112 (defvar sc-citation-leader " " | |
113 "*String comprising first part of a citation.") | |
114 | |
115 (defvar sc-citation-delimiter ">" | |
116 "*String comprising third part of a citation. | |
117 This string is used in both nested and non-nested citations.") | |
118 | |
119 (defvar sc-citation-separator " " | |
120 "*String comprising fourth and last part of a citation.") | |
121 | |
122 (defvar sc-default-author-name "Anonymous" | |
123 "*String used when author's name cannot be determined.") | |
124 | |
125 (defvar sc-default-attribution "Anon" | |
126 "*String used when author's attribution cannot be determined.") | |
127 | |
128 ;; Noriya KOBAYASHI (nk@ics.osaka-u.ac.jp) writes to the supercite | |
129 ;; mailing list: | |
130 ;; I use supercite in Nemacs-3.3.2. In order to handle citation using | |
131 ;; Kanji, [...set sc-cite-regexp to...] | |
132 ;; "\\s *\\([a-zA-Z0-9]\\|\\cc\\|\\cC\\|\\ch\\|\\cH\\|\\ck\\|\\cK\\)*\\s *>+" | |
133 ;; | |
134 (defvar sc-cite-regexp "\\s *[-a-zA-Z0-9_.]*>+\\s *" | |
135 "*Regular expression describing how a already cited line begins. | |
136 The regexp is only used at the beginning of a line, so it doesn't need | |
137 to start with a '^'.") | |
138 | |
139 (defvar sc-titlecue-regexp "\\s +-+\\s +" | |
140 "*Regular expression describing the separator between names and titles. | |
141 Set to nil to treat entire field as a name.") | |
142 | |
143 (defvar sc-spacify-name-chars '(?_ ?* ?+ ?=) | |
144 "*List of characters to convert to spaces if found in an author's name.") | |
145 | |
146 (defvar sc-nicknames-alist | |
147 '(("Michael" "Mike") | |
148 ("Daniel" "Dan") | |
149 ("David" "Dave") | |
150 ("Jonathan" "John") | |
151 ("William" "Bill") | |
152 ("Elizabeth" "Beth") | |
153 ("Elizabeth" "Betsy") | |
154 ("Kathleen" "Kathy") | |
155 ("Smith" "Smitty")) | |
156 "*Association list of names and their common nicknames. | |
157 Entries are of the form (NAME NICKNAME), and NAMEs can have more than | |
158 one nickname. Nicknames will not be automatically used as an | |
159 attribution string, since I'm not sure this is really polite, but if a | |
160 name is glommed from the author name and presented in the attribution | |
161 string completion list, the matching nicknames will also be presented. | |
162 Set this variable to nil to defeat nickname expansions. Also note that | |
163 nicknames are not put in the supercite information alist.") | |
164 | |
165 (defvar sc-confirm-always-p t | |
166 "*If non-nil, always confirm attribution string before citing text body.") | |
167 | |
168 (defvar sc-preferred-attribution 'firstname | |
169 "*Specifies which part of the author's name becomes the attribution. | |
170 The value of this variable must be one of the following quoted symbols: | |
171 | |
172 emailname -- email terminus name | |
173 initials -- initials of author | |
174 firstname -- first name of author | |
175 lastname -- last name of author | |
176 middlename1 -- first middle name of author | |
177 middlename2 -- second middle name of author | |
178 ... | |
179 | |
180 Middle name indexes can be any positive integer greater than 0, though | |
181 it is unlikely that many authors will supply more than one middle | |
182 name, if that many.") | |
183 | |
184 (defvar sc-use-only-preference-p nil | |
185 "*Controls what happens when the preferred attribution cannot be found. | |
186 If non-nil, then sc-default-attribution will be used. If nil, then | |
187 some secondary scheme will be employed to find a suitable attribution | |
188 string.") | |
189 | |
190 (defvar sc-downcase-p nil | |
191 "*Non-nil means downcase the attribution and citation strings.") | |
192 | |
193 (defvar sc-rewrite-header-list | |
194 '((sc-no-header) | |
195 (sc-header-on-said) | |
196 (sc-header-inarticle-writes) | |
197 (sc-header-regarding-adds) | |
198 (sc-header-attributed-writes) | |
199 (sc-header-verbose) | |
200 (sc-no-blank-line-or-header) | |
201 ) | |
202 "*List of reference header rewrite functions. | |
203 The variable sc-preferred-header-style controls which function in this | |
204 list is chosen for automatic reference header insertions. Electric | |
205 reference mode will cycle through this list of functions. For more | |
206 information, type \\[sc-describe].") | |
207 | |
208 (defvar sc-preferred-header-style 1 | |
209 "*Index into sc-rewrite-header-list specifying preferred header style. | |
210 Index zero accesses the first function in the list.") | |
211 | |
212 (defvar sc-electric-references-p t | |
213 "*Use electric references if non-nil.") | |
214 | |
215 (defvar sc-electric-circular-p t | |
216 "*Treat electric references as circular if non-nil.") | |
217 | |
218 (defvar sc-mail-fields-list | |
219 '("date" "message-id" "subject" "newsgroups" "references" | |
220 "from" "return-path" "path" "reply-to" "organization" | |
221 "reply" ) | |
222 "*List of mail header whose values will be saved by supercite. | |
223 These values can be used in header rewrite functions by accessing them | |
224 with the sc-field function. Mail headers in this list are case | |
225 insensitive and do not require a trailing colon.") | |
226 | |
227 (defvar sc-mumble-string "" | |
228 "*Value returned by sc-field if chosen field cannot be found.") | |
229 | |
230 (defvar sc-nuke-mail-headers-p t | |
231 "*Nuke or don't nuke mail headers. | |
232 If non-nil, nuke mail headers after gleaning useful information from | |
233 them.") | |
234 | |
235 (defvar sc-reference-tag-string ">>>>> " | |
236 "*String used at the beginning of built-in reference headers.") | |
237 | |
238 (defvar sc-fill-paragraph-hook 'sc-fill-paragraph | |
239 "*Hook for filling a paragraph. | |
240 This hook gets executed when you fill a paragraph either manually or | |
241 automagically. It expects point to be within the extent of the | |
242 paragraph that is going to be filled. This hook allows you to use a | |
243 different paragraph filling package than the one supplied with | |
244 supercite.") | |
245 | |
246 (defvar sc-auto-fill-region-p nil | |
247 "*If non-nil, automatically fill each paragraph after it has been cited.") | |
248 | |
249 (defvar sc-auto-fill-query-each-paragraph-p nil | |
250 "*If non-nil, query before filling each paragraph. | |
251 No querying and no filling will be performed if sc-auto-fill-region-p | |
252 is set to nil.") | |
253 | |
254 (defvar sc-fixup-whitespace-p nil | |
255 "*If non-nil, delete all leading white space before citing.") | |
256 | |
257 (defvar sc-all-but-cite-p nil | |
258 "*If non-nil, sc-cite-original does everything but cite the text. | |
259 This is useful for manually citing large messages, or portions of | |
260 large messages. When non-nil, sc-cite-original will still set up all | |
261 necessary variables and databases, but will skip the citing routine | |
262 which modify the reply buffer's text.") | |
263 | |
264 (defvar sc-load-hook nil | |
265 "*User definable hook. | |
266 Runs after supercite is loaded. Set your customizations here.") | |
267 | |
268 (defvar sc-pre-hook nil | |
269 "*User definable hook. | |
270 Runs before sc-cite-original executes.") | |
271 | |
272 (defvar sc-post-hook nil | |
273 "*User definable hook. | |
274 Runs after sc-cite-original executes.") | |
275 | |
276 (defvar sc-header-nuke-list | |
277 '("via" "origin" "status" "received" "remailed" "cc" "sender" "replied" | |
278 "organization" "keywords" "distribution" "xref" "references" "expires" | |
279 "approved" "summary" "precedence" "subject" "newsgroup[s]?" | |
280 "\\(followup\\|apparently\\|errors\\|\\(\\(in-\\)?reply\\)?-\\)?to" | |
281 "x-[a-z0-9-]+" "[a-z-]*message-id" "\\(summary-\\)?line[s]" | |
282 "\\(\\(return\\|reply\\)-\\)?path" "\\(posted-\\)?date" | |
283 "\\(mail-\\)?from") | |
284 "*List of mail headers to remove from body of reply.") | |
285 | |
286 | |
287 | |
288 ;; ====================================================================== | |
289 ;; keymaps | |
290 | |
291 (defvar sc-default-keymap | |
292 '(lambda () | |
293 (local-set-key "\C-c\C-r" 'sc-insert-reference) | |
294 (local-set-key "\C-c\C-t" 'sc-cite) | |
295 (local-set-key "\C-c\C-a" 'sc-recite) | |
296 (local-set-key "\C-c\C-u" 'sc-uncite) | |
297 (local-set-key "\C-c\C-i" 'sc-insert-citation) | |
298 (local-set-key "\C-c\C-o" 'sc-open-line) | |
299 (local-set-key "\C-c\C-q" 'sc-fill-paragraph-manually) | |
300 (local-set-key "\C-cq" 'sc-fill-paragraph-manually) | |
301 (local-set-key "\C-c\C-m" 'sc-modify-information) | |
302 (local-set-key "\C-cf" 'sc-view-field) | |
303 (local-set-key "\C-cg" 'sc-glom-headers) | |
304 (local-set-key "\C-c\C-v" 'sc-version) | |
305 (local-set-key "\C-c?" 'sc-describe) | |
306 ) | |
307 "*Default keymap if major-mode can't be found in `sc-local-keymaps'.") | |
308 | |
309 (defvar sc-local-keymaps | |
310 '((mail-mode | |
311 (lambda () | |
312 (local-set-key "\C-c\C-r" 'sc-insert-reference) | |
313 (local-set-key "\C-c\C-t" 'sc-cite) | |
314 (local-set-key "\C-c\C-a" 'sc-recite) | |
315 (local-set-key "\C-c\C-u" 'sc-uncite) | |
316 (local-set-key "\C-c\C-i" 'sc-insert-citation) | |
317 (local-set-key "\C-c\C-o" 'sc-open-line) | |
318 (local-set-key "\C-c\C-q" 'sc-fill-paragraph-manually) | |
319 (local-set-key "\C-cq" 'sc-fill-paragraph-manually) | |
320 (local-set-key "\C-c\C-m" 'sc-modify-information) | |
321 (local-set-key "\C-cf" 'sc-view-field) | |
322 (local-set-key "\C-cg" 'sc-glom-headers) | |
323 (local-set-key "\C-c\C-v" 'sc-version) | |
324 (local-set-key "\C-c?" 'sc-describe) | |
325 )) | |
326 (mh-letter-mode | |
327 (lambda () | |
328 (local-set-key "\C-c\C-r" 'sc-insert-reference) | |
329 (local-set-key "\C-c\C-t" 'sc-cite) | |
330 (local-set-key "\C-c\C-a" 'sc-recite) | |
331 (local-set-key "\C-c\C-u" 'sc-uncite) | |
332 (local-set-key "\C-ci" 'sc-insert-citation) | |
333 (local-set-key "\C-c\C-o" 'sc-open-line) | |
334 (local-set-key "\C-cq" 'sc-fill-paragraph-manually) | |
335 (local-set-key "\C-c\C-m" 'sc-modify-information) | |
336 (local-set-key "\C-cf" 'sc-view-field) | |
337 (local-set-key "\C-cg" 'sc-glom-headers) | |
338 (local-set-key "\C-c\C-v" 'sc-version) | |
339 (local-set-key "\C-c?" 'sc-describe) | |
340 )) | |
341 (news-reply-mode mail-mode) | |
342 (vm-mail-mode mail-mode) | |
343 (e-reply-mode mail-mode) | |
344 (n-reply-mode mail-mode) | |
345 ) | |
346 "*List of keymaps to use with the associated major-mode.") | |
347 | |
348 (defvar sc-electric-mode-map nil | |
349 "*Keymap for sc-electric-mode.") | |
350 | |
351 (if sc-electric-mode-map | |
352 nil | |
353 (setq sc-electric-mode-map (make-sparse-keymap)) | |
354 (define-key sc-electric-mode-map "p" 'sc-eref-prev) | |
355 (define-key sc-electric-mode-map "n" 'sc-eref-next) | |
356 (define-key sc-electric-mode-map "s" 'sc-eref-setn) | |
357 (define-key sc-electric-mode-map "j" 'sc-eref-jump) | |
358 (define-key sc-electric-mode-map "x" 'sc-eref-abort) | |
359 (define-key sc-electric-mode-map "\r" 'sc-eref-exit) | |
360 (define-key sc-electric-mode-map "\n" 'sc-eref-exit) | |
361 (define-key sc-electric-mode-map "q" 'sc-eref-exit) | |
362 (define-key sc-electric-mode-map "g" 'sc-eref-goto) | |
363 ) | |
364 | |
365 ;; ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ | |
366 ;; end of user defined variables | |
367 ;; ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ | |
368 | |
369 | |
370 ;; ====================================================================== | |
3591
507f64624555
Apply typo patches from Paul Eggert.
Jim Blandy <jimb@redhat.com>
parents:
3577
diff
changeset
|
371 ;; global variables, not user accessible |
1745 | 372 |
373 (defconst sc-version-number "2.3" | |
374 "Supercite's version number.") | |
375 | |
376 ;; when rnewspost.el patch is installed (or function is overloaded) | |
377 ;; this should be nil since supercite now does this itself. | |
378 (setq news-reply-header-hook nil) | |
379 | |
380 ;; autoload for sc-electric-mode | |
381 (autoload 'sc-electric-mode "sc-elec" | |
382 "Quasi-major mode for viewing supercite reference headers." nil) | |
383 | |
384 ;; global alists (gals), misc variables. make new bytecompiler happy | |
385 (defvar sc-gal-information nil | |
386 "Internal global alist variable containing information.") | |
387 (defvar sc-gal-attributions nil | |
388 "Internal global alist variable containing attributions.") | |
389 (defvar sc-fill-arg nil | |
390 "Internal fill argument holder.") | |
391 (defvar sc-cite-context nil | |
392 "Internal citation context holder.") | |
393 (defvar sc-force-confirmation-p nil | |
394 "Internal variable.") | |
395 | |
396 (make-variable-buffer-local 'sc-gal-attributions) | |
397 (make-variable-buffer-local 'sc-gal-information) | |
398 (make-variable-buffer-local 'sc-leached-keymap) | |
399 (make-variable-buffer-local 'sc-fill-arg) | |
400 (make-variable-buffer-local 'sc-cite-context) | |
401 | |
402 (setq-default sc-gal-attributions nil) | |
403 (setq-default sc-gal-information nil) | |
404 (setq-default sc-leached-keymap (current-local-map)) | |
405 (setq-default sc-fill-arg nil) | |
406 (setq-default sc-cite-context nil) | |
407 | |
408 | |
409 | |
410 ;; ====================================================================== | |
411 ;; miscellaneous support functions | |
412 | |
413 (defun sc-mark () | |
414 "Mark compatibility between emacs v18 and v19." | |
415 (let ((zmacs-regions nil)) | |
3577
d4c48ca1b220
(sc-mark): Use mark-marker.
Richard M. Stallman <rms@gnu.org>
parents:
3547
diff
changeset
|
416 (marker-position (mark-marker)))) |
1745 | 417 |
418 (defun sc-update-gal (attribution) | |
419 "Update the information alist. | |
420 Add ATTRIBUTION and compose the nested and non-nested citation | |
421 strings." | |
422 (let ((attrib (if sc-downcase-p (downcase attribution) attribution))) | |
423 (aput 'sc-gal-information "sc-attribution" attrib) | |
424 (aput 'sc-gal-information "sc-nested-citation" | |
425 (concat attrib sc-citation-delimiter)) | |
426 (aput 'sc-gal-information "sc-citation" | |
427 (concat sc-citation-leader | |
428 attrib | |
429 sc-citation-delimiter | |
430 sc-citation-separator)))) | |
431 | |
432 (defun sc-valid-index-p (index) | |
433 "Returns t if INDEX is a valid index into sc-rewrite-header-list." | |
434 (let ((last (1- (length sc-rewrite-header-list)))) | |
435 (and (natnump index) ;; a number, and greater than or equal to zero | |
436 (<= index last) ;; less than or equal to the last index | |
437 ))) | |
438 | |
439 (defun sc-string-car (namestring) | |
440 "Return the string-equivalent \"car\" of NAMESTRING. | |
441 | |
442 example: (sc-string-car \"John Xavier Doe\") | |
443 => \"John\"" | |
444 (substring namestring | |
445 (progn (string-match "\\s *" namestring) (match-end 0)) | |
446 (progn (string-match "\\s *\\S +" namestring) (match-end 0)))) | |
447 | |
448 (defun sc-string-cdr (namestring) | |
449 "Return the string-equivalent \"cdr\" of NAMESTRING. | |
450 | |
451 example: (sc-string-cdr \"John Xavier Doe\") | |
452 => \"Xavier Doe\"" | |
453 (substring namestring | |
454 (progn (string-match "\\s *\\S +\\s *" namestring) | |
455 (match-end 0)))) | |
456 | |
457 (defun sc-linepos (&optional position col-p) | |
458 "Return the character position at various line positions. | |
459 Optional POSITION can be one of the following symbols: | |
460 bol == beginning of line | |
461 boi == beginning of indentation | |
462 eol == end of line [default] | |
463 | |
464 Optional COL-P non-nil returns current-column instead of character position." | |
465 (let ((tpnt (point)) | |
466 rval) | |
467 (cond | |
468 ((eq position 'bol) (beginning-of-line)) | |
469 ((eq position 'boi) (back-to-indentation)) | |
470 (t (end-of-line))) | |
471 (setq rval (if col-p (current-column) (point))) | |
472 (goto-char tpnt) | |
473 rval)) | |
474 | |
475 | |
476 ;; ====================================================================== | |
477 ;; this section snarfs mail fields and places them in the info alist | |
478 | |
479 (defun sc-build-header-zap-regexp () | |
480 "Return a regexp for sc-mail-yank-clear-headers." | |
481 (let ((headers sc-header-nuke-list) | |
482 (regexp nil)) | |
483 (while headers | |
484 (setq regexp (concat regexp | |
485 "^" (car headers) ":" | |
486 (if (cdr headers) "\\|" nil))) | |
487 (setq headers (cdr headers))) | |
488 regexp)) | |
489 | |
490 (defun sc-mail-yank-clear-headers (start end) | |
491 "Nuke mail headers between START and END." | |
492 (if (and sc-nuke-mail-headers-p sc-header-nuke-list) | |
493 (let ((regexp (sc-build-header-zap-regexp))) | |
494 (save-excursion | |
495 (goto-char start) | |
496 (if (search-forward "\n\n" end t) | |
497 (save-restriction | |
498 (narrow-to-region start (point)) | |
499 (goto-char start) | |
500 (while (let ((case-fold-search t)) | |
501 (re-search-forward regexp nil t)) | |
502 (beginning-of-line) | |
503 (delete-region (point) | |
504 (progn (re-search-forward "\n[^ \t]") | |
505 (forward-char -1) | |
506 (point))) | |
507 ))) | |
508 )))) | |
509 | |
510 (defun sc-mail-fetch-field (field) | |
511 "Return the value of the header field FIELD. | |
512 The buffer is expected to be narrowed to just the headers of the | |
513 message." | |
514 (save-excursion | |
515 (goto-char (point-min)) | |
516 (let ((case-fold-search t) | |
517 (name (concat "^" (regexp-quote field) "[ \t]*:[ \t]*"))) | |
518 (goto-char (point-min)) | |
519 (if (re-search-forward name nil t) | |
520 (let ((opoint (point))) | |
521 (while (progn (forward-line 1) | |
522 (looking-at "[ \t]"))) | |
523 (buffer-substring opoint (1- (point)))))))) | |
524 | |
525 (defun sc-fetch-fields (start end) | |
526 "Fetch the mail fields in the region from START to END. | |
527 These fields can be accessed in header rewrite functions with sc-field." | |
528 (save-excursion | |
529 (save-restriction | |
530 (narrow-to-region start end) | |
531 (goto-char start) | |
532 (let ((fields sc-mail-fields-list)) | |
533 (while fields | |
534 (let ((value (sc-mail-fetch-field (car fields))) | |
535 (next (cdr fields))) | |
536 (and value | |
537 (aput 'sc-gal-information (car fields) value)) | |
538 (setq fields next))) | |
539 (if (sc-mail-fetch-field "from") | |
540 (aput 'sc-gal-information "from" (sc-mail-fetch-field "from"))))))) | |
541 | |
542 (defun sc-field (field) | |
543 "Return the alist information associated with the FIELD. | |
544 If FIELD is not a valid key, return sc-mumble-string." | |
545 (or (aget sc-gal-information field) sc-mumble-string)) | |
546 | |
547 | |
548 ;; ====================================================================== | |
549 ;; built-in reference header rewrite functions | |
550 | |
551 (defun sc-no-header () | |
552 "Does nothing. Use this instead of nil to get a blank header." | |
553 ()) | |
554 | |
555 (defun sc-no-blank-line-or-header() | |
3591
507f64624555
Apply typo patches from Paul Eggert.
Jim Blandy <jimb@redhat.com>
parents:
3577
diff
changeset
|
556 "Similar to sc-no-header except it removes the preceding blank line." |
1745 | 557 (if (not (bobp)) |
558 (if (and (eolp) | |
559 (progn (forward-line -1) | |
560 (or (looking-at mail-header-separator) | |
561 (and (eq major-mode 'mh-letter-mode) | |
562 (mh-in-header-p))))) | |
563 (progn (forward-line) | |
564 (let ((kill-lines-magic t)) (kill-line)))))) | |
565 | |
566 (defun sc-header-on-said () | |
567 "\"On <date>, <from> said:\", unless 1. the \"from\" field cannot be | |
568 found, in which case nothing is inserted; or 2. the \"date\" field is | |
569 missing in which case only the from part is printed." | |
570 (let* ((sc-mumble-string "") | |
571 (whofrom (sc-field "from")) | |
572 (when (sc-field "date"))) | |
573 (if (not (string= whofrom "")) | |
574 (insert sc-reference-tag-string | |
575 (if (not (string= when "")) | |
576 (concat "On " when ", ") "") | |
577 whofrom " said:\n")))) | |
578 | |
579 (defun sc-header-inarticle-writes () | |
580 "\"In article <message-id>, <from> writes:\" | |
581 Treats \"message-id\" and \"from\" fields similar to sc-header-on-said." | |
582 (let* ((sc-mumble-string "") | |
583 (whofrom (sc-field "from")) | |
584 (msgid (sc-field "message-id"))) | |
585 (if (not (string= whofrom "")) | |
586 (insert sc-reference-tag-string | |
587 (if (not (string= msgid "")) | |
588 (concat "In article " msgid ", ") "") | |
589 whofrom " writes:\n")))) | |
590 | |
591 (defun sc-header-regarding-adds () | |
592 "\"Regarding <subject>; <from> adds:\" | |
593 Treats \"subject\" and \"from\" fields similar to sc-header-on-said." | |
594 (let* ((sc-mumble-string "") | |
595 (whofrom (sc-field "from")) | |
596 (subj (sc-field "subject"))) | |
597 (if (not (string= whofrom "")) | |
598 (insert sc-reference-tag-string | |
599 (if (not (string= subj "")) | |
600 (concat "Regarding " subj "; ") "") | |
601 whofrom " adds:\n")))) | |
602 | |
603 (defun sc-header-attributed-writes () | |
604 "\"<sc-attribution>\" == <sc-author> <address> writes: | |
605 Treats these fields in a similar manner to sc-header-on-said." | |
606 (let* ((sc-mumble-string "") | |
607 (whofrom (sc-field "from")) | |
608 (reply (sc-field "sc-reply-address")) | |
609 (from (sc-field "sc-from-address")) | |
610 (attr (sc-field "sc-attribution")) | |
611 (auth (sc-field "sc-author"))) | |
612 (if (not (string= whofrom "")) | |
613 (insert sc-reference-tag-string | |
614 (if (not (string= attr "")) | |
615 (concat "\"" attr "\" == " ) "") | |
616 (if (not (string= auth "")) | |
617 (concat auth " ") "") | |
618 (if (not (string= reply "")) | |
619 (concat "<" reply ">") | |
620 (if (not (string= from "")) | |
621 (concat "<" from ">") "")) | |
622 " writes:\n")))) | |
623 | |
624 (defun sc-header-verbose () | |
625 "Very verbose, some say gross." | |
626 (let* ((sc-mumble-string "") | |
627 (whofrom (sc-field "from")) | |
628 (reply (sc-field "sc-reply-address")) | |
629 (from (sc-field "sc-from-address")) | |
630 (author (sc-field "sc-author")) | |
631 (date (sc-field "date")) | |
632 (org (sc-field "organization")) | |
633 (msgid (sc-field "message-id")) | |
634 (ngrps (sc-field "newsgroups")) | |
635 (subj (sc-field "subject")) | |
636 (refs (sc-field "references")) | |
637 (cite (sc-field "sc-citation")) | |
638 (nl sc-reference-tag-string)) | |
639 (if (not (string= whofrom "")) | |
640 (insert (if (not (string= date "")) | |
641 (concat nl "On " date ",\n") "") | |
642 (concat nl (if (not (string= author "")) | |
643 author | |
644 whofrom) "\n") | |
645 (if (not (string= org "")) | |
646 (concat nl "from the organization of " org "\n") "") | |
647 (if (not (string= reply "")) | |
648 (concat nl "who can be reached at: " reply "\n") | |
649 (if (not (string= from "")) | |
650 (concat nl "who can be reached at: " from "\n") "")) | |
651 (if (not (string= cite "")) | |
652 (concat nl "(whose comments are cited below with \"" | |
653 cite "\"),\n") "") | |
654 (if (not (string= msgid "")) | |
655 (concat nl "had this to say in article " msgid "\n") "") | |
656 (if (not (string= ngrps "")) | |
657 (concat nl "in newsgroups " ngrps "\n") "") | |
658 (if (not (string= subj "")) | |
659 (concat nl "concerning the subject of " subj "\n") "") | |
660 (if (not (string= refs "")) | |
661 (concat nl "(see " refs " for more details)\n") "") | |
662 )))) | |
663 | |
664 | |
665 ;; ====================================================================== | |
666 ;; this section queries the user for necessary information | |
667 | |
668 (defun sc-query (&optional default) | |
669 "Query for an attribution string with the optional DEFAULT choice. | |
670 Returns the string entered by the user, if non-empty and non-nil, or | |
671 DEFAULT otherwise. If DEFAULT is not supplied, sc-default-attribution | |
672 is used." | |
673 (if (not default) (setq default sc-default-attribution)) | |
674 (let* ((prompt (concat "Enter attribution string: (default " default ") ")) | |
675 (query (read-string prompt))) | |
676 (if (or (null query) | |
677 (string= query "")) | |
678 default | |
679 query))) | |
680 | |
681 (defun sc-confirm () | |
682 "Confirm the preferred attribution with the user." | |
683 (if (or sc-confirm-always-p | |
684 sc-force-confirmation-p) | |
685 (aput 'sc-gal-attributions | |
686 (let* ((default (aheadsym sc-gal-attributions)) | |
687 chosen | |
688 (prompt (concat "Complete " | |
689 (cond | |
690 ((eq sc-cite-context 'citing) "cite") | |
691 ((eq sc-cite-context 'reciting) "recite") | |
692 (t "")) | |
693 " attribution string: (default " | |
694 default ") ")) | |
695 (minibuffer-local-completion-map | |
696 (copy-keymap minibuffer-local-completion-map))) | |
697 (define-key minibuffer-local-completion-map "\C-g" | |
698 '(lambda () (interactive) (beep) (throw 'select-abort nil))) | |
699 (setq chosen (completing-read prompt sc-gal-attributions)) | |
700 (if (or (not chosen) | |
701 (string= chosen "")) | |
702 default | |
703 chosen))))) | |
704 | |
705 | |
706 ;; ====================================================================== | |
707 ;; this section contains primitive functions used in the email address | |
708 ;; parsing schemes. they extract name fields from various parts of | |
709 ;; the "from:" field. | |
710 | |
711 (defun sc-style1-addresses (from-string &optional delim) | |
712 "Extract the author's email terminus from email address FROM-STRING. | |
713 Match addresses of the style \"name%[stuff].\" when called with DELIM | |
714 of \"%\" and addresses of the style \"[stuff]name@[stuff]\" when | |
715 called with DELIM \"@\". If DELIM is nil or not provided, matches | |
716 addresses of the style \"name\"." | |
717 (and (string-match (concat "[a-zA-Z0-9_-]+" delim) from-string 0) | |
718 (substring from-string | |
719 (match-beginning 0) | |
720 (- (match-end 0) (if (null delim) 0 1))))) | |
721 | |
722 (defun sc-style2-addresses (from-string) | |
723 "Extract the author's email terminus from email address FROM-STRING. | |
724 Match addresses of the style \"[stuff]![stuff]...!name[stuff].\"" | |
725 (let ((eos (length from-string)) | |
726 (mstart (string-match "![a-zA-Z0-9_-]+\\([^!a-zA-Z0-9_-]\\|$\\)" | |
727 from-string 0)) | |
728 (mend (match-end 0))) | |
729 (and mstart | |
730 (substring from-string (1+ mstart) (- mend (if (= mend eos) 0 1))) | |
731 ))) | |
732 | |
733 (defun sc-get-address (from-string author) | |
734 "Get the full email address path from FROM-STRING. | |
735 AUTHOR is the author's name (which is removed from the address)." | |
736 (let ((eos (length from-string))) | |
737 (if (string-match (concat "\\(^\\|^\"\\)" author | |
738 "\\(\\s +\\|\"\\s +\\)") from-string 0) | |
739 (let ((addr (substring from-string (match-end 0) eos))) | |
740 (if (and (= (aref addr 0) ?<) | |
741 (= (aref addr (1- (length addr))) ?>)) | |
742 (substring addr 1 (1- (length addr))) | |
743 addr)) | |
744 (if (string-match "[a-zA-Z0-9!@%._-]+" from-string 0) | |
745 (substring from-string (match-beginning 0) (match-end 0)) | |
746 "") | |
747 ))) | |
748 | |
749 (defun sc-get-emailname (from-string) | |
750 "Get the email terminus name from FROM-STRING." | |
751 (cond | |
752 ((sc-style1-addresses from-string "%")) | |
753 ((sc-style1-addresses from-string "@")) | |
754 ((sc-style2-addresses from-string)) | |
755 ((sc-style1-addresses from-string nil)) | |
756 (t (substring from-string 0 10)))) | |
757 | |
758 | |
759 ;; ====================================================================== | |
760 ;; this section contains functions that will extract a list of names | |
761 ;; from the name field string. | |
762 | |
763 (defun sc-spacify-name-chars (name) | |
764 (let ((len (length name)) | |
765 (s 0)) | |
766 (while (< s len) | |
767 (if (memq (aref name s) sc-spacify-name-chars) | |
768 (aset name s 32)) | |
769 (setq s (1+ s))) | |
770 name)) | |
771 | |
772 (defun sc-name-substring (string start end extend) | |
773 "Extract the specified substring of STRING from START to END. | |
774 EXTEND is the number of characters on each side to extend the | |
775 substring." | |
776 (and start | |
777 (let ((sos (+ start extend)) | |
778 (eos (- end extend))) | |
779 (substring string sos | |
780 (or (string-match sc-titlecue-regexp string sos) eos) | |
781 )))) | |
782 | |
783 (defun sc-extract-namestring (from-string) | |
784 "Extract the name string from FROM-STRING. | |
785 This should be the author's full name minus an optional title." | |
786 (let ((pstart (string-match "(.*)" from-string 0)) | |
787 (pend (match-end 0)) | |
788 (qstart (string-match "\".*\"" from-string 0)) | |
789 (qend (match-end 0)) | |
790 (bstart (string-match "\\([.a-zA-Z0-9_-]+\\s *\\)+" from-string 0)) | |
791 (bend (match-end 0))) | |
792 (sc-spacify-name-chars | |
793 (cond | |
794 ((sc-name-substring from-string pstart pend 1)) | |
795 ((sc-name-substring from-string qstart qend 1)) | |
796 ((sc-name-substring from-string bstart bend 0)) | |
797 )))) | |
798 | |
799 (defun sc-chop-namestring (namestring) | |
800 "Convert NAMESTRING to a list of names. | |
801 | |
802 example: (sc-namestring-to-list \"John Xavier Doe\") | |
803 => (\"John\" \"Xavier\" \"Doe\")" | |
804 (if (not (string= namestring "")) | |
805 (append (list (sc-string-car namestring)) | |
806 (sc-chop-namestring (sc-string-cdr namestring))))) | |
807 | |
808 (defun sc-strip-initials (namelist) | |
809 "Extract the author's initials from the NAMELIST." | |
810 (if (not namelist) | |
811 nil | |
812 (concat (if (string= (car namelist) "") | |
813 "" | |
814 (substring (car namelist) 0 1)) | |
815 (sc-strip-initials (cdr namelist))))) | |
816 | |
817 | |
818 ;; ====================================================================== | |
819 ;; this section handles selection of the attribution and citation strings | |
820 | |
821 (defun sc-populate-alists (from-string) | |
822 "Put important and useful information in the alists using FROM-STRING. | |
823 Return the list of name symbols." | |
824 (let* ((namelist (sc-chop-namestring (sc-extract-namestring from-string))) | |
825 (revnames (reverse (cdr namelist))) | |
826 (midnames (reverse (cdr revnames))) | |
827 (firstname (car namelist)) | |
828 (midnames (reverse (cdr revnames))) | |
829 (lastname (car revnames)) | |
830 (initials (sc-strip-initials namelist)) | |
831 (emailname (sc-get-emailname from-string)) | |
832 (n 1) | |
833 (symlist (list 'emailname 'initials 'firstname 'lastname))) | |
834 | |
835 ;; put basic information | |
836 (aput 'sc-gal-attributions 'firstname firstname) | |
837 (aput 'sc-gal-attributions 'lastname lastname) | |
838 (aput 'sc-gal-attributions 'emailname emailname) | |
839 (aput 'sc-gal-attributions 'initials initials) | |
840 | |
841 (aput 'sc-gal-information "sc-firstname" firstname) | |
842 (aput 'sc-gal-information "sc-lastname" lastname) | |
843 (aput 'sc-gal-information "sc-emailname" emailname) | |
844 (aput 'sc-gal-information "sc-initials" initials) | |
845 | |
846 ;; put middle names and build sc-author entry | |
847 (let ((author (concat firstname " "))) | |
848 (while midnames | |
849 (let ((name (car midnames)) | |
850 (next (cdr midnames)) | |
851 (symbol (intern (format "middlename%d" n))) | |
852 (string (format "sc-middlename-%d" n))) | |
853 ;; first put new middlename | |
854 (aput 'sc-gal-attributions symbol name) | |
855 (aput 'sc-gal-information string name) | |
856 (setq n (1+ n)) | |
857 (nconc symlist (list symbol)) | |
858 | |
859 ;; now build author name | |
860 (setq author (concat author name " ")) | |
861 | |
862 ;; incr loop | |
863 (setq midnames next) | |
864 )) | |
865 (setq author (concat author lastname)) | |
866 | |
867 ;; put author name and email address | |
868 (aput 'sc-gal-information "sc-author" author) | |
869 (aput 'sc-gal-information "sc-from-address" | |
870 (sc-get-address from-string author)) | |
871 (aput 'sc-gal-information "sc-reply-address" | |
872 (sc-get-address (sc-field "reply-to") author)) | |
873 ) | |
874 ;; return value | |
875 symlist)) | |
876 | |
877 (defun sc-sort-attribution-alist () | |
878 "Put preferred attribution at head of attributions alist." | |
879 (asort 'sc-gal-attributions sc-preferred-attribution) | |
880 | |
881 ;; use backup scheme if preference is not legal | |
882 (if (or (null sc-preferred-attribution) | |
883 (anot-head-p sc-gal-attributions sc-preferred-attribution) | |
884 (let ((prefval (aget sc-gal-attributions | |
885 sc-preferred-attribution))) | |
886 (or (null prefval) | |
887 (string= prefval "")))) | |
888 ;; no legal attribution | |
889 (if sc-use-only-preference-p | |
890 (aput 'sc-gal-attributions 'sc-user-query | |
891 (sc-query sc-default-attribution)) | |
892 ;; else use secondary scheme | |
893 (asort 'sc-gal-attributions 'firstname)))) | |
894 | |
895 (defun sc-build-attribution-alist (from-string) | |
896 "Extract attributions from FROM-STRING, applying preferences." | |
897 (let ((symlist (sc-populate-alists from-string)) | |
898 (headval (progn (sc-sort-attribution-alist) | |
899 (aget sc-gal-attributions | |
900 (aheadsym sc-gal-attributions) t)))) | |
901 | |
902 ;; for each element in the symlist, remove the corresponding | |
903 ;; key-value pair in the alist, then insert just the value. | |
904 (while symlist | |
905 (let ((value (aget sc-gal-attributions (car symlist) t)) | |
906 (next (cdr symlist))) | |
907 (if (not (or (null value) | |
908 (string= value ""))) | |
909 (aput 'sc-gal-attributions value)) | |
910 (adelete 'sc-gal-attributions (car symlist)) | |
911 (setq symlist next))) | |
912 | |
913 ;; add nicknames to the completion list | |
914 (let ((gal sc-gal-attributions)) | |
915 (while gal | |
916 (let ((nns sc-nicknames-alist) | |
917 (galname (car (car gal)))) | |
918 (while nns | |
919 (if (string= galname (car (car nns))) | |
920 (aput 'sc-gal-attributions (car (cdr (car nns))))) | |
921 (setq nns (cdr nns))) | |
922 (setq gal (cdr gal))))) | |
923 | |
924 ;; now reinsert the head (preferred) attribution unless it is nil, | |
925 ;; this effectively just moves the head value to the front of the | |
926 ;; list. | |
927 (if headval | |
928 (aput 'sc-gal-attributions headval)) | |
929 | |
930 ;; check to be sure alist is not nil | |
931 (if (null sc-gal-attributions) | |
932 (aput 'sc-gal-attributions sc-default-attribution)))) | |
933 | |
934 (defun sc-select () | |
935 "Select an attribution and create a citation string." | |
936 (cond | |
937 (sc-nested-citation-p | |
938 (sc-update-gal "")) | |
939 ((null (aget sc-gal-information "from" t)) | |
940 (aput 'sc-gal-information "sc-author" sc-default-author-name) | |
941 (sc-update-gal (sc-query sc-default-attribution))) | |
942 ((null sc-gal-attributions) | |
943 (sc-build-attribution-alist (aget sc-gal-information "from" t)) | |
944 (sc-confirm) | |
945 (sc-update-gal (aheadsym sc-gal-attributions))) | |
946 (t | |
947 (sc-confirm) | |
948 (sc-update-gal (aheadsym sc-gal-attributions)))) | |
949 t) | |
950 | |
951 | |
952 ;; ====================================================================== | |
953 ;; region citing and unciting | |
954 | |
955 (defun sc-cite-region (start end) | |
956 "Cite a region delineated by START and END." | |
957 (save-excursion | |
958 ;; set real end-of-region | |
959 (goto-char end) | |
960 (forward-line 1) | |
961 (set-mark (point)) | |
962 ;; goto real beginning-of-region | |
963 (goto-char start) | |
964 (beginning-of-line) | |
965 (let ((fstart (point)) | |
966 (fend (point))) | |
967 (while (< (point) (sc-mark)) | |
968 ;; remove leading whitespace if desired | |
969 (and sc-fixup-whitespace-p | |
970 (fixup-whitespace)) | |
971 ;; if end of line then perhaps autofill | |
972 (cond ((eolp) | |
973 (or (= fstart fend) | |
974 (not sc-auto-fill-region-p) | |
975 (and sc-auto-fill-query-each-paragraph-p | |
976 (not (y-or-n-p "Fill this paragraph? "))) | |
977 (save-excursion (set-mark fend) | |
978 (goto-char (/ (+ fstart fend 1) 2)) | |
979 (run-hooks 'sc-fill-paragraph-hook))) | |
980 (setq fstart (point) | |
981 fend (point))) | |
3591
507f64624555
Apply typo patches from Paul Eggert.
Jim Blandy <jimb@redhat.com>
parents:
3577
diff
changeset
|
982 ;; not end of line so perhaps cite it |
1745 | 983 ((not (looking-at sc-cite-regexp)) |
984 (insert (aget sc-gal-information "sc-citation"))) | |
985 (sc-nested-citation-p | |
986 (insert (aget sc-gal-information "sc-nested-citation")))) | |
987 (setq fend (point)) | |
988 (forward-line 1)) | |
989 (and sc-auto-fill-query-each-paragraph-p | |
990 (message " ")) | |
991 ))) | |
992 | |
993 (defun sc-uncite-region (start end cite-regexp) | |
994 "Uncite a previously cited region delineated by START and END. | |
995 CITE-REGEXP describes how a cited line of texts starts. Unciting also | |
996 auto-fills paragraph if sc-auto-fill-region-p is non-nil." | |
997 (save-excursion | |
998 (set-mark end) | |
999 (goto-char start) | |
1000 (beginning-of-line) | |
1001 (let ((fstart (point)) | |
1002 (fend (point))) | |
1003 (while (< (point) (sc-mark)) | |
1004 ;; if end of line, then perhaps autofill | |
1005 (cond ((eolp) | |
1006 (or (= fstart fend) | |
1007 (not sc-auto-fill-region-p) | |
1008 (and sc-auto-fill-query-each-paragraph-p | |
1009 (not (y-or-n-p "Fill this paragraph? "))) | |
1010 (save-excursion (set-mark fend) | |
1011 (goto-char (/ (+ fstart fend 1) 2)) | |
1012 (run-hooks 'sc-fill-paragraph-hook))) | |
1013 (setq fstart (point) | |
1014 fend (point))) | |
1015 ;; not end of line so perhaps uncite it | |
1016 ((looking-at cite-regexp) | |
1017 (save-excursion | |
1018 (save-restriction | |
1019 (narrow-to-region (sc-linepos 'bol) (sc-linepos)) | |
1020 (beginning-of-line) | |
1021 (delete-region (point-min) | |
1022 (progn (re-search-forward cite-regexp | |
1023 (point-max) | |
1024 t) | |
1025 (match-end 0))))))) | |
1026 (setq fend (point)) | |
1027 (forward-line 1))))) | |
1028 | |
1029 | |
1030 ;; ====================================================================== | |
1031 ;; this section contains paragraph filling support | |
1032 | |
1033 (defun sc-guess-fill-prefix (&optional literalp) | |
1034 "Guess the fill prefix used on the current line. | |
1035 Use various heuristics to find the fill prefix. Search begins on first | |
1036 non-blank line after point. | |
1037 | |
1038 1) If fill-prefix is already bound to the empty string, return | |
1039 nil. | |
1040 | |
1041 2) If fill-prefix is already bound, but not to the empty | |
1042 string, return the value of fill-prefix. | |
1043 | |
1044 3) If the current line starts with the last chosen citation | |
1045 string, then that string is returned. | |
1046 | |
1047 4) If the current line starts with a string matching the regular | |
1048 expression sc-cite-regexp, return the match. Note that if | |
1049 optional LITERALP is provided and non-nil, then the *string* | |
1050 that matches the regexp is return. Otherwise, if LITERALP is | |
1051 not provided or is nil, the *regexp* sc-cite-regexp is | |
1052 returned. | |
1053 | |
1054 5) If the current line starts with any number of characters, | |
1055 followed by the sc-citation-delimiter and then white space, | |
1056 that match is returned. See comment #4 above for handling of | |
1057 LITERALP. | |
1058 | |
1059 6) Nil is returned." | |
1060 (save-excursion | |
1061 ;; scan for first non-blank line in the region | |
1062 (beginning-of-line) | |
1063 (skip-chars-forward "\n\t ") | |
1064 (beginning-of-line) | |
1065 (let ((citation (aget sc-gal-information "sc-citation")) | |
1066 (generic-citation | |
1067 (concat "\\s *[^ \t\n" sc-citation-delimiter "]+>\\s +"))) | |
1068 (cond | |
1069 ((string= fill-prefix "") nil) ;; heuristic #1 | |
1070 (fill-prefix) ;; heuristic #2 | |
1071 ((looking-at (regexp-quote citation)) citation) ;; heuristic #3 | |
1072 ((looking-at sc-cite-regexp) ;; heuristic #4 | |
1073 (if literalp | |
1074 (buffer-substring | |
1075 (point) | |
1076 (progn (re-search-forward (concat sc-cite-regexp "\\s *") | |
1077 (point-max) nil) | |
1078 (point))) | |
1079 sc-cite-regexp)) | |
1080 ((looking-at generic-citation) ;; heuristic #5 | |
1081 (if literalp | |
1082 (buffer-substring | |
1083 (point) | |
1084 (progn (re-search-forward generic-citation) (point))) | |
1085 generic-citation)) | |
1086 (t nil))))) ;; heuristic #6 | |
1087 | |
3547 | 1088 (defun sc-consistent-cite-p (prefix) |
1089 "Check current paragraph for consistent citation. | |
1745 | 1090 Scans to paragraph delineated by (forward|backward)-paragraph to see |
1091 if all lines start with PREFIX. Returns t if entire paragraph is | |
3547 | 1092 consistently cited, nil otherwise." |
1745 | 1093 (save-excursion |
1094 (let ((end (progn (forward-paragraph) | |
1095 (beginning-of-line) | |
1096 (or (not (eolp)) | |
1097 (forward-char -1)) | |
1098 (point))) | |
1099 (start (progn (backward-paragraph) | |
1100 (beginning-of-line) | |
1101 (or (not (eolp)) | |
1102 (forward-char 1)) | |
1103 (point))) | |
1104 (badline t)) | |
1105 (goto-char start) | |
1106 (beginning-of-line) | |
1107 (while (and (< (point) end) | |
1108 badline) | |
1109 (setq badline (looking-at prefix)) | |
1110 (forward-line 1)) | |
1111 badline))) | |
1112 | |
1113 (defun sc-fill-start (fill-prefix) | |
1114 "Find buffer position of start of region which begins with FILL-PREFIX. | |
1115 Restrict scan to current paragraph." | |
1116 (save-excursion | |
1117 (let ((badline nil) | |
1118 (top (save-excursion | |
1119 (backward-paragraph) | |
1120 (beginning-of-line) | |
1121 (or (not (eolp)) | |
1122 (forward-char 1)) | |
1123 (point)))) | |
1124 (while (and (not badline) | |
1125 (> (point) top)) | |
1126 (forward-line -1) | |
1127 (setq badline (not (looking-at fill-prefix))))) | |
1128 (forward-line 1) | |
1129 (point))) | |
1130 | |
1131 (defun sc-fill-end (fill-prefix) | |
1132 "Find the buffer position of end of region which begins with FILL-PREFIX. | |
1133 Restrict scan to current paragraph." | |
1134 (save-excursion | |
1135 (let ((badline nil) | |
1136 (bot (save-excursion | |
1137 (forward-paragraph) | |
1138 (beginning-of-line) | |
1139 (or (not (eolp)) | |
1140 (forward-char -1)) | |
1141 (point)))) | |
1142 (while (and (not badline) | |
1143 (< (point) bot)) | |
1144 (beginning-of-line) | |
1145 (setq badline (not (looking-at fill-prefix))) | |
1146 (forward-line 1))) | |
1147 (forward-line -1) | |
1148 (point))) | |
1149 | |
1150 (defun sc-fill-paragraph () | |
1151 "Supercite's paragraph fill function. | |
1152 Fill the paragraph containing or following point. Use | |
1153 sc-guess-fill-prefix to find the fill-prefix for the paragraph. | |
1154 | |
3547 | 1155 If the paragraph is inconsistently cited (mixed fill-prefix), then the |
1745 | 1156 user is queried to restrict the the fill to only those lines around |
1157 point which begin with the fill prefix. | |
1158 | |
1159 The variable sc-fill-arg is passed to fill-paragraph and | |
1160 fill-region-as-paragraph which controls justification of the | |
1161 paragraph. sc-fill-arg is set by sc-fill-paragraph-manually." | |
1162 (save-excursion | |
1163 (let ((pnt (point)) | |
1164 (fill-prefix (sc-guess-fill-prefix t))) | |
1165 (cond | |
1166 ((not fill-prefix) | |
1167 (fill-paragraph sc-fill-arg)) | |
3547 | 1168 ((sc-consistent-cite-p fill-prefix) |
1745 | 1169 (fill-paragraph sc-fill-arg)) |
1170 ((y-or-n-p "Inconsistent citation found. Restrict? ") | |
1171 (message "") | |
1172 (fill-region-as-paragraph (progn (goto-char pnt) | |
1173 (sc-fill-start fill-prefix)) | |
1174 (progn (goto-char pnt) | |
1175 (sc-fill-end fill-prefix)) | |
1176 sc-fill-arg)) | |
1177 (t | |
1178 (message "") | |
1179 (progn | |
1180 (setq fill-prefix (aget sc-gal-information "sc-citation")) | |
1181 (fill-paragraph sc-fill-arg))))))) | |
1182 | |
1183 | |
1184 ;; ====================================================================== | |
1185 ;; the following functions are the top level, interactive commands that | |
1186 ;; can be bound to key strokes | |
1187 | |
1188 (defun sc-insert-reference (arg) | |
1189 "Insert, at point, a reference header in the body of the reply. | |
1190 Numeric ARG indicates which header style from sc-rewrite-header-list | |
1191 to use when rewriting the header. No supplied ARG indicates use of | |
1192 sc-preferred-header-style. | |
1193 | |
1194 With just \\[universal-argument], electric reference insert mode is | |
1195 entered, regardless of the value of sc-electric-references-p. See | |
1196 sc-electric-mode for more information." | |
1197 (interactive "P") | |
1198 (if (consp arg) | |
1199 (sc-electric-mode) | |
1200 (let ((pref (cond ((sc-valid-index-p arg) arg) | |
1201 ((sc-valid-index-p sc-preferred-header-style) | |
1202 sc-preferred-header-style) | |
1203 (t 0)))) | |
1204 (if sc-electric-references-p (sc-electric-mode pref) | |
1205 (condition-case err | |
1206 (eval (nth pref sc-rewrite-header-list)) | |
1207 (void-function | |
1208 (progn (message | |
1209 "Symbol's function definition is void: %s. (Header %d)." | |
1210 (symbol-name (car (cdr err))) | |
1211 pref) | |
1212 (beep))) | |
1213 (error | |
1214 (progn (message "Error evaluating rewrite header function %d." | |
1215 pref) | |
1216 (beep))) | |
1217 ))))) | |
1218 | |
1219 (defun sc-cite (arg) | |
1220 "Cite the region of text between point and mark. | |
1221 Numeric ARG, if supplied, is passed unaltered to sc-insert-reference." | |
1222 (interactive "P") | |
1223 (if (not (sc-mark)) | |
1224 (error "Please designate a region to cite (i.e. set the mark).")) | |
1225 (catch 'select-abort | |
1226 (let ((sc-cite-context 'citing) | |
1227 (sc-force-confirmation-p (interactive-p))) | |
1228 (sc-select) | |
1229 (undo-boundary) | |
1230 (let ((xchange (if (> (sc-mark) (point)) nil | |
1231 (exchange-point-and-mark) | |
1232 t))) | |
1233 (sc-insert-reference arg) | |
1234 (sc-cite-region (point) (sc-mark)) | |
1235 ;; leave point on first cited line | |
1236 (while (and (< (point) (sc-mark)) | |
1237 (not (looking-at (aget sc-gal-information | |
1238 (if sc-nested-citation-p | |
1239 "sc-nested-citation" | |
1240 "sc-citation"))))) | |
1241 (forward-line 1)) | |
1242 (and xchange | |
1243 (exchange-point-and-mark)) | |
1244 )))) | |
1245 | |
1246 (defun sc-uncite () | |
1247 "Uncite the region between point and mark." | |
1248 (interactive) | |
1249 (if (not (sc-mark)) | |
1250 (error "Please designate a region to uncite (i.e. set the mark).")) | |
1251 (undo-boundary) | |
1252 (let ((xchange (if (> (sc-mark) (point)) nil | |
1253 (exchange-point-and-mark) | |
1254 t)) | |
1255 (fp (or (sc-guess-fill-prefix) | |
1256 ""))) | |
1257 (sc-uncite-region (point) (sc-mark) fp) | |
1258 (and xchange | |
1259 (exchange-point-and-mark)))) | |
1260 | |
1261 (defun sc-recite () | |
1262 "Recite the region by first unciting then citing the text." | |
1263 (interactive) | |
1264 (if (not (sc-mark)) | |
1265 (error "Please designate a region to recite (i.e. set the mark).")) | |
1266 (catch 'select-abort | |
1267 (let ((sc-cite-context 'reciting) | |
1268 (sc-force-confirmation-p t)) | |
1269 (sc-select) | |
1270 (undo-boundary) | |
1271 (let ((xchange (if (> (sc-mark) (point)) nil | |
1272 (exchange-point-and-mark) | |
1273 t)) | |
1274 (fp (or (sc-guess-fill-prefix) | |
1275 ""))) | |
1276 (sc-uncite-region (point) (sc-mark) fp) | |
1277 (sc-cite-region (point) (sc-mark)) | |
1278 (and xchange | |
1279 (exchange-point-and-mark)) | |
1280 )))) | |
1281 | |
1282 (defun sc-insert-citation () | |
1283 "Insert citation string at beginning of current line." | |
1284 (interactive) | |
1285 (save-excursion | |
1286 (beginning-of-line) | |
1287 (insert (aget sc-gal-information "sc-citation")))) | |
1288 | |
1289 (defun sc-open-line (arg) | |
1290 "Insert a newline and leave point before it. | |
1291 Also inserts the guessed prefix at the beginning of the new line. With | |
1292 numeric ARG, inserts that many new lines." | |
1293 (interactive "p") | |
1294 (save-excursion | |
1295 (let ((start (point)) | |
1296 (string (or (sc-guess-fill-prefix t) | |
1297 ""))) | |
1298 (open-line arg) | |
1299 (goto-char start) | |
1300 (forward-line 1) | |
1301 (while (< 0 arg) | |
1302 (insert string) | |
1303 (forward-line 1) | |
1304 (setq arg (- arg 1)))))) | |
1305 | |
1306 (defun sc-fill-paragraph-manually (arg) | |
1307 "Fill current cited paragraph. | |
1308 Really just runs the hook sc-fill-paragraph-hook, however it does set | |
1309 the global variable sc-fill-arg to the value of ARG. This is | |
1310 currently the only way to pass an argument to a hookified function." | |
1311 (interactive "P") | |
1312 (setq sc-fill-arg arg) | |
1313 (run-hooks 'sc-fill-paragraph-hook)) | |
1314 | |
1315 (defun sc-modify-information (arg) | |
1316 "Interactively modify information in the information alist. | |
1317 \\[universal-argument] if supplied, deletes the entry from the alist. | |
1318 You can add an entry by supplying a key instead of completing." | |
1319 (interactive "P") | |
1320 (let* ((delete-p (consp arg)) | |
1321 (action (if delete-p "delete" "modify")) | |
1322 (defaultkey (aheadsym sc-gal-information)) | |
1323 (prompt (concat "Select information key to " | |
1324 action ": (default " | |
1325 defaultkey ") ")) | |
1326 (key (completing-read prompt sc-gal-information)) | |
1327 ) | |
1328 (if (or (string= key "") | |
1329 (null key)) | |
1330 (setq key defaultkey)) | |
1331 (if delete-p (adelete 'sc-gal-information key) | |
1332 (let* ((oldval (aget sc-gal-information key t)) | |
1333 (prompt (concat "Enter new value for key \"" | |
1334 key "\" (default \"" oldval "\") ")) | |
1335 (newval (read-input prompt))) | |
1336 (if (or (string= newval "") | |
1337 (null newval)) | |
1338 nil | |
1339 (aput 'sc-gal-information key newval) | |
1340 ))))) | |
1341 | |
1342 (defun sc-view-field (arg) | |
1343 "View field values in the information alist. | |
1344 This is essentially an interactive version of sc-field, and is similar | |
1345 to sc-modify-information, except that the field values can't be | |
1346 modified. With \\[universal-argument], if supplied, inserts the value | |
1347 into the current buffer as well." | |
1348 (interactive "P") | |
1349 (let* ((defaultkey (aheadsym sc-gal-information)) | |
1350 (prompt (concat "View information key: (default " | |
1351 defaultkey ") ")) | |
1352 (key (completing-read prompt sc-gal-information))) | |
1353 (if (or (string= key "") | |
1354 (null key)) | |
1355 (setq key defaultkey)) | |
1356 (let* ((val (aget sc-gal-information key t)) | |
1357 (pval (if val (concat "\"" val "\"") "nil"))) | |
1358 (message "value of key %s: %s" key pval) | |
1359 (if (and key (consp arg)) (insert val))))) | |
1360 | |
1361 (defun sc-glom-headers () | |
1362 "Glom information from mail headers in region between point and mark. | |
1363 Any old information is lost, unless an error occurs." | |
1364 (interactive) | |
1365 (let ((attr (copy-sequence sc-gal-attributions)) | |
1366 (info (copy-sequence sc-gal-information))) | |
1367 (setq sc-gal-attributions nil | |
1368 sc-gal-information nil) | |
4707
ca55f9c620c5
(sc-glom-headers): Bind mark-active around calling region-...
Richard M. Stallman <rms@gnu.org>
parents:
4662
diff
changeset
|
1369 (let (start end |
1745 | 1370 (sc-force-confirmation-p t) |
1371 (sc-cite-context nil)) | |
4707
ca55f9c620c5
(sc-glom-headers): Bind mark-active around calling region-...
Richard M. Stallman <rms@gnu.org>
parents:
4662
diff
changeset
|
1372 (let ((mark-active t)) |
ca55f9c620c5
(sc-glom-headers): Bind mark-active around calling region-...
Richard M. Stallman <rms@gnu.org>
parents:
4662
diff
changeset
|
1373 (setq start (region-beginning) |
ca55f9c620c5
(sc-glom-headers): Bind mark-active around calling region-...
Richard M. Stallman <rms@gnu.org>
parents:
4662
diff
changeset
|
1374 end (region-end))) |
1745 | 1375 (sc-fetch-fields start end) |
1376 (if (null sc-gal-information) | |
1377 (progn | |
1378 (message "No mail headers found! Restoring old information.") | |
1379 (setq sc-gal-attributions attr | |
1380 sc-gal-information info)) | |
1381 (sc-mail-yank-clear-headers start end) | |
1382 (if (not (catch 'select-abort | |
1383 (condition-case foo | |
1384 (sc-select) | |
1385 (quit (beep) (throw 'select-abort nil))) | |
1386 )) | |
1387 (setq sc-gal-attributions attr | |
1388 sc-gal-information info)) | |
1389 )))) | |
1390 | |
1391 (defun sc-version (arg) | |
1392 "Show supercite version. | |
1393 Universal argument (\\[universal-argument]) ARG inserts version | |
1394 information in the current buffer instead of printing the message in | |
1395 the echo area." | |
1396 (interactive "P") | |
1397 (if (consp arg) | |
1398 (insert "Using Supercite version " sc-version-number) | |
1399 (message "Using Supercite version %s" sc-version-number))) | |
1400 | |
1401 | |
1402 ;; ====================================================================== | |
1403 ;; leach onto current mode | |
1404 | |
1405 (defun sc-append-current-keymap () | |
1406 "Append some useful key bindings to the current local key map. | |
1407 This searches sc-local-keymap for the keymap to install based on the | |
1408 major-mode of the current buffer." | |
1409 (let ((hook (car (cdr (assq major-mode sc-local-keymaps))))) | |
1410 (cond | |
1411 ((not hook) | |
1412 (run-hooks 'sc-default-keymap)) | |
1413 ((not (listp hook)) | |
1414 (setq hook (car (cdr (assq hook sc-local-keymaps)))) | |
1415 (run-hooks 'hook)) | |
1416 (t | |
1417 (run-hooks 'hook)))) | |
1418 (setq sc-leached-keymap (current-local-map))) | |
1419 | |
1420 (defun sc-snag-all-keybindings () | |
1421 "Snag all keybindings in major-mode's current keymap." | |
1422 (let* ((curkeymap (current-local-map)) | |
1423 (symregexp ".*sc-.*\n") | |
1424 (docstring (substitute-command-keys "\\{curkeymap}")) | |
1425 (start 0) | |
1426 (maxend (length docstring)) | |
1427 (spooge "")) | |
1428 (while (and (< start maxend) | |
1429 (string-match symregexp docstring start)) | |
1430 (setq spooge (concat spooge (substring docstring | |
1431 (match-beginning 0) | |
1432 (match-end 0)))) | |
1433 (setq start (match-end 0))) | |
1434 spooge)) | |
1435 | |
1436 (defun sc-spoogify-docstring () | |
1437 "Modifies (makes into spooge) the docstring for the current major mode. | |
1438 This will leach the keybinding descriptions for supercite onto the end | |
1439 of the current major mode's docstring. If major mode is preloaded, | |
1440 this function will first make a copy of the list associated with the | |
1441 mode, then modify this copy." | |
1442 (let* ((symfunc (symbol-function major-mode)) | |
1443 (doc-cdr (and (listp symfunc) (nthcdr 2 symfunc))) | |
1444 (doc-str (documentation major-mode))) | |
1445 (cond | |
1446 ;; is a docstring even provided? | |
1447 ((not (stringp doc-str))) | |
1448 ;; have we already leached on? | |
1449 ((string-match "Supercite" doc-str)) | |
1450 ;; lets build the new doc string | |
1451 (t | |
1452 (let* ((described (sc-snag-all-keybindings)) | |
1453 (commonstr " | |
1454 | |
1455 The major mode for this buffer has been modified to include the | |
1456 Supercite 2.3 package for handling attributions and citations of | |
1457 original messages in email replies. For more information on this | |
1458 package, type \"\\[sc-describe]\".") | |
1459 (newdoc-str | |
1460 (concat doc-str commonstr | |
1461 (if (not (string= described "")) | |
1462 (concat "\n\nThe following keys are bound " | |
1463 "to Supercite commands:\n\n" | |
1464 described))) | |
1465 )) | |
1466 (cond | |
1467 (doc-cdr | |
1468 (condition-case nil | |
1469 (setcar doc-cdr newdoc-str) | |
1470 (error | |
1471 ;; the major mode must be preloaded, make a copy first | |
1472 (setq symfunc (copy-sequence (symbol-function major-mode)) | |
1473 doc-cdr (nthcdr 2 symfunc)) | |
1474 (setcar doc-cdr newdoc-str) | |
1475 (fset major-mode symfunc)))) | |
1476 ;; lemacs 19 byte-code. | |
1477 ;; Set function to a new byte-code vector with the | |
1478 ;; new documentation in the documentation slot (element 4). | |
1479 ;; We can't use aset because aset won't allow you to modify | |
1480 ;; a byte-code vector. | |
1481 ;; Include element 5 if the vector has one. | |
1482 (t | |
1483 (fset major-mode | |
1484 (apply 'make-byte-code | |
1485 (aref symfunc 0) (aref symfunc 1) | |
1486 (aref symfunc 2) (aref symfunc 3) | |
1487 newdoc-str | |
1488 (if (> (length symfunc) 5) | |
1489 (list (aref symfunc 5))))) | |
1490 ))))))) | |
1491 | |
1492 | |
1493 ;; ====================================================================== | |
1494 ;; this section contains default hooks and hook support for execution | |
1495 | |
3397
b21d11dec171
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
1745
diff
changeset
|
1496 ;;;###autoload |
1745 | 1497 (defun sc-cite-original () |
1498 "Hook version of sc-cite. | |
1499 This is callable from the various mail and news readers' reply | |
1500 function according to the agreed upon standard. See \\[sc-describe] | |
1501 for more details. Sc-cite-original does not do any yanking of the | |
1502 original message but it does require a few things: | |
1503 | |
1504 1) The reply buffer is the current buffer. | |
1505 | |
1506 2) The original message has been yanked and inserted into the | |
1507 reply buffer. | |
1508 | |
1509 3) Verbose mail headers from the original message have been | |
1510 inserted into the reply buffer directly before the text of the | |
1511 original message. | |
1512 | |
1513 4) Point is at the beginning of the verbose headers. | |
1514 | |
1515 5) Mark is at the end of the body of text to be cited." | |
1516 (run-hooks 'sc-pre-hook) | |
1517 (setq sc-gal-attributions nil) | |
1518 (setq sc-gal-information nil) | |
4707
ca55f9c620c5
(sc-glom-headers): Bind mark-active around calling region-...
Richard M. Stallman <rms@gnu.org>
parents:
4662
diff
changeset
|
1519 (let (start end) |
ca55f9c620c5
(sc-glom-headers): Bind mark-active around calling region-...
Richard M. Stallman <rms@gnu.org>
parents:
4662
diff
changeset
|
1520 (let ((mark-active t)) |
ca55f9c620c5
(sc-glom-headers): Bind mark-active around calling region-...
Richard M. Stallman <rms@gnu.org>
parents:
4662
diff
changeset
|
1521 (setq start (region-beginning) |
ca55f9c620c5
(sc-glom-headers): Bind mark-active around calling region-...
Richard M. Stallman <rms@gnu.org>
parents:
4662
diff
changeset
|
1522 end (region-end))) |
1745 | 1523 (sc-fetch-fields start end) |
1524 (sc-mail-yank-clear-headers start end) | |
1525 (if (not sc-all-but-cite-p) | |
1526 (sc-cite sc-preferred-header-style)) | |
1527 (sc-append-current-keymap) | |
1528 (sc-spoogify-docstring) | |
1529 (run-hooks 'sc-post-hook))) | |
1530 | |
1531 | |
1532 ;; ====================================================================== | |
1533 ;; describe this package | |
1534 ;; | |
1535 (defun sc-describe () | |
1536 "Supercite version 2.3 is now described in a texinfo manual which | |
3591
507f64624555
Apply typo patches from Paul Eggert.
Jim Blandy <jimb@redhat.com>
parents:
3577
diff
changeset
|
1537 makes the documentation available both for online perusal via emacs' |
1745 | 1538 info system, or for hard-copy printing using the TeX facility. |
1539 | |
1540 To view the online document hit \\[info], then \"mSupercite <RET>\"." | |
1541 (interactive) | |
1542 (describe-function 'sc-describe)) | |
1543 | |
1544 ;; ====================================================================== | |
1545 ;; load hook | |
1546 (run-hooks 'sc-load-hook) | |
1547 (provide 'sc) |