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