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