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