| 1 | ;;; supercite.el --- minor mode for citing mail and news replies |
| 2 | |
| 3 | ;; Copyright (C) 1993, 1997 Free Software Foundation, Inc. |
| 4 | |
| 5 | ;; Author: 1993 Barry A. Warsaw, Century Computing, Inc. <bwarsaw@cen.com> |
| 6 | ;; Maintainer: Mark Senn <mds@ecn.purdue.edu> |
| 7 | ;; Created: February 1993 |
| 8 | ;; Last Modified: 1993/09/22 18:58:46 |
| 9 | ;; Keywords: mail, news |
| 10 | |
| 11 | ;; supercite.el revision: 3.54 |
| 12 | |
| 13 | ;; This file is part of GNU Emacs. |
| 14 | |
| 15 | ;; GNU Emacs is free software; you can redistribute it and/or modify |
| 16 | ;; it under the terms of the GNU General Public License as published by |
| 17 | ;; the Free Software Foundation; either version 2, or (at your option) |
| 18 | ;; any later version. |
| 19 | |
| 20 | ;; GNU Emacs is distributed in the hope that it will be useful, |
| 21 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
| 22 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
| 23 | ;; GNU General Public License for more details. |
| 24 | |
| 25 | ;; You should have received a copy of the GNU General Public License |
| 26 | ;; along with GNU Emacs; see the file COPYING. If not, write to the |
| 27 | ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, |
| 28 | ;; Boston, MA 02111-1307, USA. |
| 29 | |
| 30 | ;; LCD Archive Entry |
| 31 | ;; supercite|Barry A. Warsaw|supercite-help@python.org |
| 32 | ;; |Mail and news reply citation package |
| 33 | ;; |1993/09/22 18:58:46|3.1| |
| 34 | |
| 35 | ;;; Commentary: |
| 36 | |
| 37 | ;;; Code: |
| 38 | |
| 39 | \f |
| 40 | (require 'regi) |
| 41 | (require 'sendmail) ;; For mail-header-end. |
| 42 | |
| 43 | ;; start user configuration variables |
| 44 | ;; vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv |
| 45 | |
| 46 | (defgroup supercite nil |
| 47 | "Supercite package" |
| 48 | :prefix "sc-" |
| 49 | :group 'mail |
| 50 | :group 'news) |
| 51 | |
| 52 | (defgroup supercite-frames nil |
| 53 | "Supercite (regi) frames" |
| 54 | :prefix "sc-" |
| 55 | :group 'supercite) |
| 56 | |
| 57 | (defgroup supercite-attr nil |
| 58 | "Supercite attributions" |
| 59 | :prefix "sc-" |
| 60 | :group 'supercite) |
| 61 | |
| 62 | (defgroup supercite-cite nil |
| 63 | "Supercite citings" |
| 64 | :prefix "sc-" |
| 65 | :group 'supercite) |
| 66 | |
| 67 | (defgroup supercite-hooks nil |
| 68 | "Hooking into supercite" |
| 69 | :prefix "sc-" |
| 70 | :group 'supercite) |
| 71 | |
| 72 | (defcustom sc-auto-fill-region-p t |
| 73 | "*If non-nil, automatically fill each paragraph after it has been cited." |
| 74 | :type 'boolean |
| 75 | :group 'supercite) |
| 76 | |
| 77 | (defcustom sc-blank-lines-after-headers 1 |
| 78 | "*Number of blank lines to leave after mail headers have been nuked. |
| 79 | Set to nil, to use whatever blank lines happen to occur naturally." |
| 80 | :type '(choice (const :tag "leave" nil) |
| 81 | integer) |
| 82 | :group 'supercite) |
| 83 | |
| 84 | (defcustom sc-citation-leader " " |
| 85 | "*String comprising first part of a citation." |
| 86 | :type 'string |
| 87 | :group 'supercite-cite) |
| 88 | |
| 89 | (defcustom sc-citation-delimiter ">" |
| 90 | "*String comprising third part of a citation. |
| 91 | This string is used in both nested and non-nested citations." |
| 92 | :type 'string |
| 93 | :group 'supercite-cite) |
| 94 | |
| 95 | (defcustom sc-citation-separator " " |
| 96 | "*String comprising fourth and last part of a citation." |
| 97 | :type 'string |
| 98 | :group 'supercite-cite) |
| 99 | |
| 100 | (defcustom sc-citation-leader-regexp "[ \t]*" |
| 101 | "*Regexp describing citation leader for a cited line. |
| 102 | This should NOT have a leading `^' character." |
| 103 | :type 'regexp |
| 104 | :group 'supercite-cite) |
| 105 | |
| 106 | ;; Nemacs and Mule users note: please see the texinfo manual for |
| 107 | ;; suggestions on setting these variables. |
| 108 | (defcustom sc-citation-root-regexp "[-._[:alnum:]]*" |
| 109 | "*Regexp describing variable root part of a citation for a cited line. |
| 110 | This should NOT have a leading `^' character. See also |
| 111 | `sc-citation-nonnested-root-regexp'." |
| 112 | :type 'regexp |
| 113 | :group 'supercite-cite) |
| 114 | |
| 115 | (defcustom sc-citation-nonnested-root-regexp "[-._[:alnum:]]+" |
| 116 | "*Regexp describing the variable root part of a nested citation. |
| 117 | This should NOT have a leading `^' character. This variable is |
| 118 | related to `sc-citation-root-regexp' but whereas that variable |
| 119 | describes both nested and non-nested citation roots, this variable |
| 120 | describes only nested citation roots." |
| 121 | :type 'regexp |
| 122 | :group 'supercite-cite) |
| 123 | |
| 124 | (defcustom sc-citation-delimiter-regexp "[>]+" |
| 125 | "*Regexp describing citation delimiter for a cited line. |
| 126 | This should NOT have a leading `^' character." |
| 127 | :type 'regexp |
| 128 | :group 'supercite-cite) |
| 129 | |
| 130 | (defcustom sc-citation-separator-regexp "[ \t]*" |
| 131 | "*Regexp describing citation separator for a cited line. |
| 132 | This should NOT have a leading `^' character." |
| 133 | :type 'regexp |
| 134 | :group 'supercite-cite) |
| 135 | |
| 136 | (defcustom sc-cite-blank-lines-p nil |
| 137 | "*If non-nil, put a citation on blank lines." |
| 138 | :type 'boolean |
| 139 | :group 'supercite-cite) |
| 140 | |
| 141 | (defcustom sc-cite-frame-alist '() |
| 142 | "*Alist for frame selection during citing. |
| 143 | Each element of this list has the following form: |
| 144 | (INFOKEY ((REGEXP . FRAME) |
| 145 | (REGEXP . FRAME) |
| 146 | (...))) |
| 147 | |
| 148 | Where INFOKEY is a key for `sc-mail-field', REGEXP is a regular |
| 149 | expression to match against the INFOKEY's value. FRAME is a citation |
| 150 | frame, or a variable containing a citation frame." |
| 151 | :type '(repeat (list symbol (repeat (cons regexp |
| 152 | (choice (repeat (repeat sexp)) |
| 153 | symbol))))) |
| 154 | :group 'supercite-frames) |
| 155 | |
| 156 | (defcustom sc-uncite-frame-alist '() |
| 157 | "*Alist for frame selection during unciting. |
| 158 | See the variable `sc-cite-frame-alist' for details." |
| 159 | :type '(repeat (list symbol (repeat (cons regexp |
| 160 | (choice (repeat (repeat sexp)) |
| 161 | symbol))))) |
| 162 | :group 'supercite-frames) |
| 163 | |
| 164 | (defcustom sc-recite-frame-alist '() |
| 165 | "*Alist for frame selection during reciting. |
| 166 | See the variable `sc-cite-frame-alist' for details." |
| 167 | :type '(repeat (list symbol (repeat (cons regexp |
| 168 | (choice (repeat (repeat sexp)) |
| 169 | symbol))))) |
| 170 | :group 'supercite-frames) |
| 171 | |
| 172 | (defcustom sc-default-cite-frame |
| 173 | '(;; initialize fill state and temporary variables when entering |
| 174 | ;; frame. this makes things run much faster |
| 175 | (begin (progn |
| 176 | (sc-fill-if-different) |
| 177 | (setq sc-tmp-nested-regexp (sc-cite-regexp "") |
| 178 | sc-tmp-nonnested-regexp (sc-cite-regexp) |
| 179 | sc-tmp-dumb-regexp |
| 180 | (concat "\\(" |
| 181 | (sc-cite-regexp "") |
| 182 | "\\)" |
| 183 | (sc-cite-regexp sc-citation-nonnested-root-regexp)) |
| 184 | ))) |
| 185 | ;; blank lines mean paragraph separators, so fill the last cited |
| 186 | ;; paragraph, unless sc-cite-blank-lines-p is non-nil, in which |
| 187 | ;; case we treat blank lines just like any other line. |
| 188 | ("^[ \t]*$" (if sc-cite-blank-lines-p |
| 189 | (sc-cite-line) |
| 190 | (sc-fill-if-different ""))) |
| 191 | ;; do nothing if looking at a reference tag. make sure that the |
| 192 | ;; tag string isn't the empty string since this will match every |
| 193 | ;; line. it cannot be nil. |
| 194 | (sc-reference-tag-string (if (string= sc-reference-tag-string "") |
| 195 | (list 'continue) |
| 196 | nil)) |
| 197 | ;; this regexp catches nested citations in which the author cited |
| 198 | ;; a non-nested citation with a dumb citer. |
| 199 | (sc-tmp-dumb-regexp (sc-cite-coerce-dumb-citer)) |
| 200 | ;; if we are looking at a nested citation then add a citation level |
| 201 | (sc-tmp-nested-regexp (sc-add-citation-level)) |
| 202 | ;; if we're looking at a non-nested citation, coerce it to our style |
| 203 | (sc-tmp-nonnested-regexp (sc-cite-coerce-cited-line)) |
| 204 | ;; we must be looking at an uncited line. if we are in nested |
| 205 | ;; citations, just add a citation level |
| 206 | (sc-nested-citation-p (sc-add-citation-level)) |
| 207 | ;; we're looking at an uncited line and we are in non-nested |
| 208 | ;; citations, so cite it with a non-nested citation |
| 209 | (t (sc-cite-line)) |
| 210 | ;; be sure when we're done that we fill the last cited paragraph. |
| 211 | (end (sc-fill-if-different "")) |
| 212 | ) |
| 213 | "*Default REGI frame for citing a region." |
| 214 | :type '(repeat (repeat sexp)) |
| 215 | :group 'supercite-frames) |
| 216 | |
| 217 | (defcustom sc-default-uncite-frame |
| 218 | '(;; do nothing on a blank line |
| 219 | ("^[ \t]*$" nil) |
| 220 | ;; if the line is cited, uncite it |
| 221 | ((sc-cite-regexp) (sc-uncite-line)) |
| 222 | ) |
| 223 | "*Default REGI frame for unciting a region." |
| 224 | :type '(repeat (repeat sexp)) |
| 225 | :group 'supercite-frames) |
| 226 | |
| 227 | (defcustom sc-default-recite-frame |
| 228 | '(;; initialize fill state when entering frame |
| 229 | (begin (sc-fill-if-different)) |
| 230 | ;; do nothing on a blank line |
| 231 | ("^[ \t]*$" nil) |
| 232 | ;; if we're looking at a cited line, recite it |
| 233 | ((sc-cite-regexp) (sc-recite-line (sc-cite-regexp))) |
| 234 | ;; otherwise, the line is uncited, so just cite it |
| 235 | (t (sc-cite-line)) |
| 236 | ;; be sure when we're done that we fill the last cited paragraph. |
| 237 | (end (sc-fill-if-different "")) |
| 238 | ) |
| 239 | "*Default REGI frame for reciting a region." |
| 240 | :type '(repeat (repeat sexp)) |
| 241 | :group 'supercite-frames) |
| 242 | |
| 243 | (defcustom sc-cite-region-limit t |
| 244 | "*This variable controls automatic citation of yanked text. |
| 245 | Legal values are: |
| 246 | |
| 247 | non-nil -- cite the entire region, regardless of its size |
| 248 | nil -- do not cite the region at all |
| 249 | <integer> -- a number indicating the threshold for citation. When |
| 250 | the number of lines in the region is greater than this |
| 251 | value, a warning message will be printed and the region |
| 252 | will not be cited. Lines in region are counted with |
| 253 | `count-lines'. |
| 254 | |
| 255 | The gathering of attribution information is not affected by the value |
| 256 | of this variable. The number of lines in the region is calculated |
| 257 | *after* all mail headers are removed. This variable is only consulted |
| 258 | during the initial citing via `sc-cite-original'." |
| 259 | :type '(choice (const :tag "do not cite" nil) |
| 260 | (integer :tag "citation threshold") |
| 261 | (other :tag "always cite" t)) |
| 262 | :group 'supercite-cite) |
| 263 | |
| 264 | (defcustom sc-confirm-always-p t |
| 265 | "*If non-nil, always confirm attribution string before citing text body." |
| 266 | :type 'boolean |
| 267 | :group 'supercite-attr) |
| 268 | |
| 269 | (defcustom sc-default-attribution "Anon" |
| 270 | "*String used when author's attribution cannot be determined." |
| 271 | :type 'string |
| 272 | :group 'supercite-attr) |
| 273 | (defcustom sc-default-author-name "Anonymous" |
| 274 | "*String used when author's name cannot be determined." |
| 275 | :type 'string |
| 276 | :group 'supercite-attr) |
| 277 | (defcustom sc-downcase-p nil |
| 278 | "*Non-nil means downcase the attribution and citation strings." |
| 279 | :type 'boolean |
| 280 | :group 'supercite-attr |
| 281 | :group 'supercite-cite) |
| 282 | (defcustom sc-electric-circular-p t |
| 283 | "*If non-nil, treat electric references as circular." |
| 284 | :type 'boolean |
| 285 | :group 'supercite-attr) |
| 286 | |
| 287 | (defcustom sc-electric-mode-hook nil |
| 288 | "*Hook for `sc-electric-mode' electric references mode." |
| 289 | :type 'hook |
| 290 | :group 'supercite-hooks) |
| 291 | (defcustom sc-electric-references-p nil |
| 292 | "*Use electric references if non-nil." |
| 293 | :type 'boolean |
| 294 | :group 'supercite) |
| 295 | |
| 296 | (defcustom sc-fixup-whitespace-p nil |
| 297 | "*If non-nil, delete all leading white space before citing." |
| 298 | :type 'boolean |
| 299 | :group 'supercite) |
| 300 | |
| 301 | (defcustom sc-load-hook nil |
| 302 | "*Hook which gets run once after Supercite loads." |
| 303 | :type 'hook |
| 304 | :group 'supercite-hooks) |
| 305 | (defcustom sc-pre-hook nil |
| 306 | "*Hook which gets run before each invocation of `sc-cite-original'." |
| 307 | :type 'hook |
| 308 | :group 'supercite-hooks) |
| 309 | (defcustom sc-post-hook nil |
| 310 | "*Hook which gets run after each invocation of `sc-cite-original'." |
| 311 | :type 'hook |
| 312 | :group 'supercite-hooks) |
| 313 | |
| 314 | (defcustom sc-mail-warn-if-non-rfc822-p t |
| 315 | "*Warn if mail headers don't conform to RFC822." |
| 316 | :type 'boolean |
| 317 | :group 'supercite-attr) |
| 318 | (defcustom sc-mumble "" |
| 319 | "*Value returned by `sc-mail-field' if field isn't in mail headers." |
| 320 | :type 'string |
| 321 | :group 'supercite-attr) |
| 322 | |
| 323 | (defcustom sc-name-filter-alist |
| 324 | '(("^\\(Mr\\|Mrs\\|Ms\\|Dr\\)[.]?$" . 0) |
| 325 | ("^\\(Jr\\|Sr\\)[.]?$" . last) |
| 326 | ("^ASTS$" . 0) |
| 327 | ("^[I]+$" . last)) |
| 328 | "*Name list components which are filtered out as noise. |
| 329 | This variable contains an association list where each element is of |
| 330 | the form: (REGEXP . POSITION). |
| 331 | |
| 332 | REGEXP is a regular expression which matches the name list component. |
| 333 | Match is performed using `string-match'. POSITION is the position in |
| 334 | the name list which can match the regular expression, starting at zero |
| 335 | for the first element. Use `last' to match the last element in the |
| 336 | list and `any' to match all elements." |
| 337 | :type '(repeat (cons regexp (choice (const last) (const any) |
| 338 | (integer :tag "position")))) |
| 339 | :group 'supercite-attr) |
| 340 | |
| 341 | (defcustom sc-nested-citation-p nil |
| 342 | "*Controls whether to use nested or non-nested citation style. |
| 343 | Non-nil uses nested citations, nil uses non-nested citations." |
| 344 | :type 'boolean |
| 345 | :group 'supercite) |
| 346 | |
| 347 | (defcustom sc-nuke-mail-headers 'all |
| 348 | "*Controls mail header nuking. |
| 349 | Used in conjunction with `sc-nuke-mail-header-list'. Legal values are: |
| 350 | |
| 351 | `all' -- nuke all mail headers |
| 352 | `none' -- don't nuke any mail headers |
| 353 | `specified' -- nuke headers specified in `sc-nuke-mail-header-list' |
| 354 | `keep' -- keep headers specified in `sc-nuke-mail-header-list'" |
| 355 | :type '(choice (const all) (const none) |
| 356 | (const specified) (const keep)) |
| 357 | :group 'supercite) |
| 358 | |
| 359 | (defcustom sc-nuke-mail-header-list nil |
| 360 | "*List of mail header regexps to remove or keep in body of reply. |
| 361 | This list contains regular expressions describing the mail headers to |
| 362 | keep or nuke, depending on the value of `sc-nuke-mail-headers'." |
| 363 | :type '(repeat regexp) |
| 364 | :group 'supercite) |
| 365 | |
| 366 | (defcustom sc-preferred-attribution-list |
| 367 | '("sc-lastchoice" "x-attribution" "firstname" "initials" "lastname") |
| 368 | "*Specifies what to use as the attribution string. |
| 369 | Supercite creates a list of possible attributions when it scans the |
| 370 | mail headers from the original message. Each attribution choice is |
| 371 | associated with a key in an attribution alist. Supercite tries to |
| 372 | pick a \"preferred\" attribution by matching the attribution alist |
| 373 | keys against the elements in `sc-preferred-attribution-list' in order. |
| 374 | The first non-empty string value found is used as the preferred |
| 375 | attribution. |
| 376 | |
| 377 | Note that Supercite now honors the X-Attribution: mail field. If |
| 378 | present in the original message, the value of this field should always |
| 379 | be used to select the most preferred attribution since it reflects how |
| 380 | the original author would like to be distinguished. It should be |
| 381 | considered bad taste to put any attribution preference key before |
| 382 | \"x-attribution\" in this list, except perhaps for \"sc-lastchoice\" |
| 383 | \(see below). |
| 384 | |
| 385 | Supercite remembers the last attribution used when reciting an already |
| 386 | cited paragraph. This attribution will always be saved with the |
| 387 | \"sc-lastchoice\" key, which can be used in this list. Note that the |
| 388 | last choice is always reset after every call of `sc-cite-original'. |
| 389 | |
| 390 | Barring error conditions, the following preferences are always present |
| 391 | in the attribution alist: |
| 392 | |
| 393 | \"emailname\" -- email terminus name |
| 394 | \"initials\" -- initials of author |
| 395 | \"firstname\" -- first name of author |
| 396 | \"lastname\" -- last name of author |
| 397 | \"middlename-1\" -- first middle name of author |
| 398 | \"middlename-2\" -- second middle name of author |
| 399 | ... |
| 400 | |
| 401 | Middle name indexes can be any positive integer greater than 0, |
| 402 | although it is unlikely that many authors will supply more than one |
| 403 | middle name, if that many. The string of all middle names is |
| 404 | associated with the key \"middlenames\"." |
| 405 | :type '(repeat string) |
| 406 | :group 'supercite-attr) |
| 407 | |
| 408 | (defcustom sc-attrib-selection-list nil |
| 409 | "*An alist for selecting preferred attribution based on mail headers. |
| 410 | Each element of this list has the following form: |
| 411 | |
| 412 | (INFOKEY ((REGEXP . ATTRIBUTION) |
| 413 | (REGEXP . ATTRIBUTION) |
| 414 | (...))) |
| 415 | |
| 416 | Where INFOKEY is a key for `sc-mail-field', REGEXP is a regular |
| 417 | expression to match against the INFOKEY's value. ATTRIBUTION can be a |
| 418 | string or a list. If its a string, then it is the attribution that is |
| 419 | selected by `sc-select-attribution'. If it is a list, it is `eval'd |
| 420 | and the return value must be a string, which is used as the selected |
| 421 | attribution. Note that the variable `sc-preferred-attribution-list' |
| 422 | must contain an element of the string \"sc-consult\" for this variable |
| 423 | to be consulted during attribution selection." |
| 424 | :type '(repeat (list string |
| 425 | (repeat (cons regexp |
| 426 | (choice (sexp :tag "List to eval") |
| 427 | string))))) |
| 428 | :group 'supercite-attr) |
| 429 | |
| 430 | (defcustom sc-attribs-preselect-hook nil |
| 431 | "*Hook to run before selecting an attribution." |
| 432 | :type 'hook |
| 433 | :group 'supercite-attr |
| 434 | :group 'supercite-hooks) |
| 435 | (defcustom sc-attribs-postselect-hook nil |
| 436 | "*Hook to run after selecting an attribution, but before confirmation." |
| 437 | :type 'hook |
| 438 | :group 'supercite-attr |
| 439 | :group 'supercite-hooks) |
| 440 | |
| 441 | (defcustom sc-pre-cite-hook nil |
| 442 | "*Hook to run before citing a region of text." |
| 443 | :type 'hook |
| 444 | :group 'supercite-cite |
| 445 | :group 'supercite-hooks) |
| 446 | (defcustom sc-pre-uncite-hook nil |
| 447 | "*Hook to run before unciting a region of text." |
| 448 | :type 'hook |
| 449 | :group 'supercite-cite |
| 450 | :group 'supercite-hooks) |
| 451 | (defcustom sc-pre-recite-hook nil |
| 452 | "*Hook to run before reciting a region of text." |
| 453 | :type 'hook |
| 454 | :group 'supercite-cite |
| 455 | :group 'supercite-hooks) |
| 456 | |
| 457 | (defcustom sc-preferred-header-style 4 |
| 458 | "*Index into `sc-rewrite-header-list' specifying preferred header style. |
| 459 | Index zero accesses the first function in the list." |
| 460 | :type 'integer |
| 461 | :group 'supercite) |
| 462 | |
| 463 | (defcustom sc-reference-tag-string ">>>>> " |
| 464 | "*String used at the beginning of built-in reference headers." |
| 465 | :type 'string |
| 466 | :group 'supercite) |
| 467 | |
| 468 | (defcustom sc-rewrite-header-list |
| 469 | '((sc-no-header) |
| 470 | (sc-header-on-said) |
| 471 | (sc-header-inarticle-writes) |
| 472 | (sc-header-regarding-adds) |
| 473 | (sc-header-attributed-writes) |
| 474 | (sc-header-author-writes) |
| 475 | (sc-header-verbose) |
| 476 | (sc-no-blank-line-or-header) |
| 477 | ) |
| 478 | "*List of reference header rewrite functions. |
| 479 | The variable `sc-preferred-header-style' controls which function in |
| 480 | this list is chosen for automatic reference header insertions. |
| 481 | Electric reference mode will cycle through this list of functions." |
| 482 | :type '(repeat sexp) |
| 483 | :group 'supercite) |
| 484 | |
| 485 | (defcustom sc-titlecue-regexp "\\s +-+\\s +" |
| 486 | "*Regular expression describing the separator between names and titles. |
| 487 | Set to nil to treat entire field as a name." |
| 488 | :type '(choice (const :tag "entire field as name" nil) |
| 489 | regexp) |
| 490 | :group 'supercite-attr) |
| 491 | |
| 492 | (defcustom sc-use-only-preference-p nil |
| 493 | "*Controls what happens when the preferred attribution cannot be found. |
| 494 | If non-nil, then `sc-default-attribution' will be used. If nil, then |
| 495 | some secondary scheme will be employed to find a suitable attribution |
| 496 | string." |
| 497 | :type 'boolean |
| 498 | :group 'supercite-attr) |
| 499 | |
| 500 | ;; ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ |
| 501 | ;; end user configuration variables |
| 502 | \f |
| 503 | (defconst sc-version "3.1" |
| 504 | "Supercite version number.") |
| 505 | (defconst sc-help-address "bug-supercite@gnu.org" |
| 506 | "Address accepting submissions of bug reports.") |
| 507 | |
| 508 | (defvar sc-mail-info nil |
| 509 | "Alist of mail header information gleaned from reply buffer.") |
| 510 | (defvar sc-attributions nil |
| 511 | "Alist of attributions for use when citing.") |
| 512 | |
| 513 | (defconst sc-emacs-features |
| 514 | (let ((version 'v18) |
| 515 | (flavor 'GNU)) |
| 516 | (if (not |
| 517 | (string= (substring emacs-version 0 2) "18")) |
| 518 | (setq version 'v19)) |
| 519 | (if (string-match "Lucid" emacs-version) |
| 520 | (setq flavor 'Lucid)) |
| 521 | ;; cobble up list |
| 522 | (list version flavor)) |
| 523 | "A list describing what version of Emacs we're running on. |
| 524 | Known flavors are: |
| 525 | |
| 526 | Emacs 18 : (v18 GNU) |
| 527 | Emacs 19 or later : (v19 GNU) |
| 528 | Lucid 19 or later : (v19 Lucid)") |
| 529 | |
| 530 | |
| 531 | (defvar sc-tmp-nested-regexp nil |
| 532 | "Temporary regepx describing nested citations.") |
| 533 | (defvar sc-tmp-nonnested-regexp nil |
| 534 | "Temporary regexp describing non-nested citations.") |
| 535 | (defvar sc-tmp-dumb-regexp nil |
| 536 | "Temp regexp describing non-nested citation cited with a nesting citer.") |
| 537 | |
| 538 | (defvar sc-minor-mode nil |
| 539 | "Supercite minor mode on flag.") |
| 540 | (defvar sc-mode-string " SC" |
| 541 | "Supercite minor mode string.") |
| 542 | |
| 543 | (make-variable-buffer-local 'sc-mail-info) |
| 544 | (make-variable-buffer-local 'sc-attributions) |
| 545 | (make-variable-buffer-local 'sc-minor-mode) |
| 546 | |
| 547 | \f |
| 548 | ;; ====================================================================== |
| 549 | ;; supercite keymaps |
| 550 | |
| 551 | (defvar sc-mode-map-prefix "\C-c\C-p" |
| 552 | "*Key binding to install Supercite keymap. |
| 553 | If this is nil, Supercite keymap is not installed.") |
| 554 | |
| 555 | (defvar sc-T-keymap () |
| 556 | "Keymap for sub-keymap of setting and toggling functions.") |
| 557 | (if sc-T-keymap |
| 558 | () |
| 559 | (setq sc-T-keymap (make-sparse-keymap)) |
| 560 | (define-key sc-T-keymap "a" 'sc-S-preferred-attribution-list) |
| 561 | (define-key sc-T-keymap "b" 'sc-T-mail-nuke-blank-lines) |
| 562 | (define-key sc-T-keymap "c" 'sc-T-confirm-always) |
| 563 | (define-key sc-T-keymap "d" 'sc-T-downcase) |
| 564 | (define-key sc-T-keymap "e" 'sc-T-electric-references) |
| 565 | (define-key sc-T-keymap "f" 'sc-T-auto-fill-region) |
| 566 | (define-key sc-T-keymap "h" 'sc-T-describe) |
| 567 | (define-key sc-T-keymap "l" 'sc-S-cite-region-limit) |
| 568 | (define-key sc-T-keymap "n" 'sc-S-mail-nuke-mail-headers) |
| 569 | (define-key sc-T-keymap "N" 'sc-S-mail-header-nuke-list) |
| 570 | (define-key sc-T-keymap "o" 'sc-T-electric-circular) |
| 571 | (define-key sc-T-keymap "p" 'sc-S-preferred-header-style) |
| 572 | (define-key sc-T-keymap "s" 'sc-T-nested-citation) |
| 573 | (define-key sc-T-keymap "u" 'sc-T-use-only-preferences) |
| 574 | (define-key sc-T-keymap "w" 'sc-T-fixup-whitespace) |
| 575 | (define-key sc-T-keymap "?" 'sc-T-describe) |
| 576 | ) |
| 577 | |
| 578 | (defvar sc-mode-map () |
| 579 | "Keymap for Supercite quasi-mode.") |
| 580 | (if sc-mode-map |
| 581 | () |
| 582 | (setq sc-mode-map (make-sparse-keymap)) |
| 583 | (define-key sc-mode-map "c" 'sc-cite-region) |
| 584 | (define-key sc-mode-map "f" 'sc-mail-field-query) |
| 585 | (define-key sc-mode-map "g" 'sc-mail-process-headers) |
| 586 | (define-key sc-mode-map "h" 'sc-describe) |
| 587 | (define-key sc-mode-map "i" 'sc-insert-citation) |
| 588 | (define-key sc-mode-map "o" 'sc-open-line) |
| 589 | (define-key sc-mode-map "r" 'sc-recite-region) |
| 590 | (define-key sc-mode-map "\C-p" 'sc-raw-mode-toggle) |
| 591 | (define-key sc-mode-map "u" 'sc-uncite-region) |
| 592 | (define-key sc-mode-map "v" 'sc-version) |
| 593 | (define-key sc-mode-map "w" 'sc-insert-reference) |
| 594 | (define-key sc-mode-map "\C-t" sc-T-keymap) |
| 595 | (define-key sc-mode-map "\C-b" 'sc-submit-bug-report) |
| 596 | (define-key sc-mode-map "?" 'sc-describe) |
| 597 | ) |
| 598 | |
| 599 | (defvar sc-electric-mode-map () |
| 600 | "Keymap for `sc-electric-mode' electric references mode.") |
| 601 | (if sc-electric-mode-map |
| 602 | nil |
| 603 | (setq sc-electric-mode-map (make-sparse-keymap)) |
| 604 | (define-key sc-electric-mode-map "p" 'sc-eref-prev) |
| 605 | (define-key sc-electric-mode-map "n" 'sc-eref-next) |
| 606 | (define-key sc-electric-mode-map "s" 'sc-eref-setn) |
| 607 | (define-key sc-electric-mode-map "j" 'sc-eref-jump) |
| 608 | (define-key sc-electric-mode-map "x" 'sc-eref-abort) |
| 609 | (define-key sc-electric-mode-map "q" 'sc-eref-abort) |
| 610 | (define-key sc-electric-mode-map "\r" 'sc-eref-exit) |
| 611 | (define-key sc-electric-mode-map "\n" 'sc-eref-exit) |
| 612 | (define-key sc-electric-mode-map "g" 'sc-eref-goto) |
| 613 | (define-key sc-electric-mode-map "?" 'describe-mode) |
| 614 | (define-key sc-electric-mode-map "\C-h" 'describe-mode) |
| 615 | (define-key sc-electric-mode-map [f1] 'describe-mode) |
| 616 | (define-key sc-electric-mode-map [help] 'describe-mode) |
| 617 | ) |
| 618 | |
| 619 | (defvar sc-minibuffer-local-completion-map nil |
| 620 | "Keymap for minibuffer confirmation of attribution strings.") |
| 621 | (if sc-minibuffer-local-completion-map |
| 622 | () |
| 623 | (setq sc-minibuffer-local-completion-map |
| 624 | (copy-keymap minibuffer-local-completion-map)) |
| 625 | (define-key sc-minibuffer-local-completion-map "\C-t" 'sc-toggle-fn) |
| 626 | (define-key sc-minibuffer-local-completion-map " " 'self-insert-command)) |
| 627 | |
| 628 | (defvar sc-minibuffer-local-map nil |
| 629 | "Keymap for minibuffer confirmation of attribution strings.") |
| 630 | (if sc-minibuffer-local-map |
| 631 | () |
| 632 | (setq sc-minibuffer-local-map (copy-keymap minibuffer-local-map)) |
| 633 | (define-key sc-minibuffer-local-map "\C-t" 'sc-toggle-fn)) |
| 634 | |
| 635 | \f |
| 636 | ;; ====================================================================== |
| 637 | ;; utility functions |
| 638 | |
| 639 | (defun sc-completing-read (prompt table &optional predicate require-match |
| 640 | initial-contents history) |
| 641 | "Compatibility between Emacs 18 and 19 `completing-read'. |
| 642 | In version 18, the HISTORY argument is ignored." |
| 643 | (if (memq 'v19 sc-emacs-features) |
| 644 | (funcall 'completing-read prompt table predicate require-match |
| 645 | initial-contents history) |
| 646 | (funcall 'completing-read prompt table predicate require-match |
| 647 | (or (car-safe initial-contents) |
| 648 | initial-contents)))) |
| 649 | |
| 650 | (defun sc-read-string (prompt &optional initial-contents history) |
| 651 | "Compatibility between Emacs 18 and 19 `read-string'. |
| 652 | In version 18, the HISTORY argument is ignored." |
| 653 | (if (memq 'v19 sc-emacs-features) |
| 654 | (read-string prompt initial-contents history) |
| 655 | (read-string prompt initial-contents))) |
| 656 | |
| 657 | (if (fboundp 'match-string) |
| 658 | (defalias 'sc-submatch 'match-string) |
| 659 | (defun sc-submatch (matchnum &optional string) |
| 660 | "Returns `match-beginning' and `match-end' sub-expression for MATCHNUM. |
| 661 | If optional STRING is provided, take sub-expression using `substring' |
| 662 | of argument, otherwise use `buffer-substring' on current buffer. Note |
| 663 | that `match-data' must have already been generated and no error |
| 664 | checking is performed by this function." |
| 665 | (if string |
| 666 | (substring string (match-beginning matchnum) (match-end matchnum)) |
| 667 | (buffer-substring (match-beginning matchnum) (match-end matchnum))))) |
| 668 | |
| 669 | (if (fboundp 'member) |
| 670 | (defalias 'sc-member 'member) |
| 671 | (defun sc-member (elt list) |
| 672 | "Like `memq', but uses `equal' instead of `eq'. |
| 673 | Emacs19 has a builtin function `member' which does exactly this." |
| 674 | (catch 'elt-is-member |
| 675 | (while list |
| 676 | (if (equal elt (car list)) |
| 677 | (throw 'elt-is-member list)) |
| 678 | (setq list (cdr list)))))) |
| 679 | |
| 680 | ;; One day maybe Emacs will have this... |
| 681 | (if (fboundp 'string-text) |
| 682 | (defalias 'sc-string-text 'string-text) |
| 683 | (defun sc-string-text (string) |
| 684 | "Return STRING with all text properties removed." |
| 685 | (let ((string (copy-sequence string))) |
| 686 | (set-text-properties 0 (length string) nil string) |
| 687 | string))) |
| 688 | |
| 689 | (defun sc-ask (alist) |
| 690 | "Ask a question in the minibuffer requiring a single character answer. |
| 691 | This function is kind of an extension of `y-or-n-p' where a single |
| 692 | letter is used to answer a question. Question is formed from ALIST |
| 693 | which has members of the form: (WORD . LETTER). WORD is the long |
| 694 | word form, while LETTER is the letter for selecting that answer. The |
| 695 | selected letter is returned, or nil if the question was not answered. |
| 696 | Note that WORD is a string and LETTER is a character. All LETTERs in |
| 697 | the list should be unique." |
| 698 | (let* ((prompt (concat |
| 699 | (mapconcat (function (lambda (elt) (car elt))) alist ", ") |
| 700 | "? (" |
| 701 | (mapconcat |
| 702 | (function |
| 703 | (lambda (elt) (char-to-string (cdr elt)))) alist "/") |
| 704 | ") ")) |
| 705 | (p prompt) |
| 706 | (event |
| 707 | (if (memq 'Lucid sc-emacs-features) |
| 708 | (allocate-event) |
| 709 | nil))) |
| 710 | (while (stringp p) |
| 711 | (if (let ((cursor-in-echo-area t) |
| 712 | (inhibit-quit t)) |
| 713 | (message "%s" p) |
| 714 | ;; lets be good neighbors and be compatible with all emacsen |
| 715 | (cond |
| 716 | ((memq 'v18 sc-emacs-features) |
| 717 | (setq event (read-char))) |
| 718 | ((memq 'Lucid sc-emacs-features) |
| 719 | (next-command-event event)) |
| 720 | (t ; must be Emacs 19 |
| 721 | (setq event (read-event)))) |
| 722 | (prog1 quit-flag (setq quit-flag nil))) |
| 723 | (progn |
| 724 | (message "%s%s" p (single-key-description event)) |
| 725 | (and (memq 'Lucid sc-emacs-features) |
| 726 | (deallocate-event event)) |
| 727 | (setq quit-flag nil) |
| 728 | (signal 'quit '()))) |
| 729 | (let ((char |
| 730 | (if (memq 'Lucid sc-emacs-features) |
| 731 | (let* ((key (and (key-press-event-p event) (event-key event))) |
| 732 | (char (and key (event-to-character event)))) |
| 733 | char) |
| 734 | event)) |
| 735 | elt) |
| 736 | (if char (setq char (downcase char))) |
| 737 | (cond |
| 738 | ((setq elt (rassq char alist)) |
| 739 | (message "%s%s" p (car elt)) |
| 740 | (setq p (cdr elt))) |
| 741 | ((and (memq 'Lucid sc-emacs-features) |
| 742 | (button-release-event-p event)) ; ignore them |
| 743 | nil) |
| 744 | (t |
| 745 | (message "%s%s" p (single-key-description event)) |
| 746 | (if (memq 'Lucid sc-emacs-features) |
| 747 | (ding nil 'y-or-n-p) |
| 748 | (ding)) |
| 749 | (discard-input) |
| 750 | (if (eq p prompt) |
| 751 | (setq p (concat "Try again. " prompt))))))) |
| 752 | (and (memq 'Lucid sc-emacs-features) |
| 753 | (deallocate-event event)) |
| 754 | p)) |
| 755 | |
| 756 | (defun sc-scan-info-alist (alist) |
| 757 | "Find a match in the info alist that matches a regexp in ALIST." |
| 758 | (let ((sc-mumble "") |
| 759 | rtnvalue) |
| 760 | (while alist |
| 761 | (let* ((elem (car alist)) |
| 762 | (infokey (car elem)) |
| 763 | (infoval (sc-mail-field infokey)) |
| 764 | (mlist (car (cdr elem)))) |
| 765 | (while mlist |
| 766 | (let* ((ml-elem (car mlist)) |
| 767 | (regexp (car ml-elem)) |
| 768 | (thing (cdr ml-elem))) |
| 769 | (if (string-match regexp infoval) |
| 770 | ;; we found a match, time to return |
| 771 | (setq rtnvalue thing |
| 772 | mlist nil |
| 773 | alist nil) |
| 774 | ;; else we didn't find a match |
| 775 | (setq mlist (cdr mlist)) |
| 776 | ))) ;end of mlist loop |
| 777 | (setq alist (cdr alist)) |
| 778 | )) ;end of alist loop |
| 779 | rtnvalue)) |
| 780 | |
| 781 | \f |
| 782 | ;; ====================================================================== |
| 783 | ;; extract mail field information from headers in reply buffer |
| 784 | |
| 785 | ;; holder variables for bc happiness |
| 786 | (defvar sc-mail-headers-start nil |
| 787 | "Start of header fields.") |
| 788 | (defvar sc-mail-headers-end nil |
| 789 | "End of header fields.") |
| 790 | (defvar sc-mail-field-history nil |
| 791 | "For minibuffer completion on mail field queries.") |
| 792 | (defvar sc-mail-field-modification-history nil |
| 793 | "For minibuffer completion on mail field modifications.") |
| 794 | (defvar sc-mail-glom-frame |
| 795 | '((begin (setq sc-mail-headers-start (point))) |
| 796 | ("^x-attribution:[ \t]+.*$" (sc-mail-fetch-field t) nil t) |
| 797 | ("^\\S +:.*$" (sc-mail-fetch-field) nil t) |
| 798 | ("^$" (list 'abort '(step . 0))) |
| 799 | ("^[ \t]+" (sc-mail-append-field)) |
| 800 | (sc-mail-warn-if-non-rfc822-p (sc-mail-error-in-mail-field)) |
| 801 | (end (setq sc-mail-headers-end (point)))) |
| 802 | "Regi frame for glomming mail header information.") |
| 803 | |
| 804 | (eval-when-compile (defvar curline)) ; dynamic bondage |
| 805 | |
| 806 | ;; regi functions |
| 807 | (defun sc-mail-fetch-field (&optional attribs-p) |
| 808 | "Insert a key and value into `sc-mail-info' alist. |
| 809 | If optional ATTRIBS-P is non-nil, the key/value pair is placed in |
| 810 | `sc-attributions' too." |
| 811 | (if (string-match "^\\(\\S *\\)\\s *:\\s +\\(.*\\)$" curline) |
| 812 | (let* ((key (downcase (sc-string-text (sc-submatch 1 curline)))) |
| 813 | (val (sc-string-text (sc-submatch 2 curline))) |
| 814 | (keyval (cons key val))) |
| 815 | (setq sc-mail-info (cons keyval sc-mail-info)) |
| 816 | (if attribs-p |
| 817 | (setq sc-attributions (cons keyval sc-attributions))) |
| 818 | )) |
| 819 | nil) |
| 820 | |
| 821 | (defun sc-mail-append-field () |
| 822 | "Append a continuation line onto the last fetched mail field's info." |
| 823 | (let ((keyval (car sc-mail-info))) |
| 824 | (if (and keyval (string-match "^\\s *\\(.*\\)$" curline)) |
| 825 | (setcdr keyval (concat (cdr keyval) " " |
| 826 | (sc-string-text (sc-submatch 1 curline)))))) |
| 827 | nil) |
| 828 | |
| 829 | (defun sc-mail-error-in-mail-field () |
| 830 | "Issue warning that mail headers don't conform to RFC 822." |
| 831 | (let* ((len (min (length curline) 10)) |
| 832 | (ellipsis (if (< len (length curline)) "..." "")) |
| 833 | (msg "Mail header \"%s%s\" doesn't conform to RFC 822. skipping...")) |
| 834 | (message msg (substring curline 0 len) ellipsis)) |
| 835 | (beep) |
| 836 | (sit-for 2) |
| 837 | nil) |
| 838 | |
| 839 | ;; mail header nuking |
| 840 | (defvar sc-mail-last-header-nuked-p nil |
| 841 | "True if the last header was nuked.") |
| 842 | |
| 843 | (defun sc-mail-nuke-line () |
| 844 | "Nuke the current mail header line." |
| 845 | (delete-region (regi-pos 'bol) (regi-pos 'bonl)) |
| 846 | '((step . -1))) |
| 847 | |
| 848 | (defun sc-mail-nuke-header-line () |
| 849 | "Delete current-line and set up for possible continuation." |
| 850 | (setq sc-mail-last-header-nuked-p t) |
| 851 | (sc-mail-nuke-line)) |
| 852 | |
| 853 | (defun sc-mail-nuke-continuation-line () |
| 854 | "Delete a continuation line if the last header line was deleted." |
| 855 | (if sc-mail-last-header-nuked-p |
| 856 | (sc-mail-nuke-line))) |
| 857 | |
| 858 | (defun sc-mail-cleanup-blank-lines () |
| 859 | "Leave some blank lines after original mail headers are nuked. |
| 860 | The number of lines left is specified by `sc-blank-lines-after-headers'." |
| 861 | (if sc-blank-lines-after-headers |
| 862 | (save-restriction |
| 863 | (widen) |
| 864 | (skip-chars-backward " \t\n") |
| 865 | (forward-line 1) |
| 866 | (delete-blank-lines) |
| 867 | (beginning-of-line) |
| 868 | (if (looking-at "[ \t]*$") |
| 869 | (delete-region (regi-pos 'bol) (regi-pos 'bonl))) |
| 870 | (insert-char ?\n sc-blank-lines-after-headers))) |
| 871 | nil) |
| 872 | |
| 873 | (defun sc-mail-build-nuke-frame () |
| 874 | "Build the regiframe for nuking mail headers." |
| 875 | (let (every-func entry-func nonentry-func) |
| 876 | (cond |
| 877 | ((eq sc-nuke-mail-headers 'all) |
| 878 | (setq every-func '(progn (forward-line -1) (sc-mail-nuke-line)))) |
| 879 | ((eq sc-nuke-mail-headers 'specified) |
| 880 | (setq entry-func '(sc-mail-nuke-header-line) |
| 881 | nonentry-func '(setq sc-mail-last-header-nuked-p nil))) |
| 882 | ((eq sc-nuke-mail-headers 'keep) |
| 883 | (setq entry-func '(setq sc-mail-last-header-nuked-p nil) |
| 884 | nonentry-func '(sc-mail-nuke-header-line))) |
| 885 | ;; we never get far enough to interpret a frame if s-n-m-h == 'none |
| 886 | ((eq sc-nuke-mail-headers 'none)) |
| 887 | (t (error "Illegal value for sc-nuke-mail-headers: %s" |
| 888 | sc-nuke-mail-headers)) |
| 889 | ) ; end-cond |
| 890 | (append |
| 891 | (and entry-func |
| 892 | (regi-mapcar sc-nuke-mail-header-list entry-func nil t)) |
| 893 | (and nonentry-func (list (list "^\\S +:.*$" nonentry-func))) |
| 894 | (and (not every-func) |
| 895 | '(("^[ \t]+" (sc-mail-nuke-continuation-line)))) |
| 896 | '((begin (setq sc-mail-last-header-zapped-p nil))) |
| 897 | '((end (sc-mail-cleanup-blank-lines))) |
| 898 | (and every-func (list (list 'every every-func))) |
| 899 | ))) |
| 900 | |
| 901 | ;; mail processing and zapping. this is the top level entry defun to |
| 902 | ;; all header processing. |
| 903 | (defun sc-mail-process-headers (start end) |
| 904 | "Process original mail message's mail headers. |
| 905 | After processing, mail headers may be nuked. Header information is |
| 906 | stored in `sc-mail-info', and any old information is lost unless an |
| 907 | error occurs." |
| 908 | (interactive "r") |
| 909 | (let ((info (copy-alist sc-mail-info)) |
| 910 | (attribs (copy-alist sc-attributions))) |
| 911 | (setq sc-mail-info nil |
| 912 | sc-attributions nil) |
| 913 | (regi-interpret sc-mail-glom-frame start end) |
| 914 | (if (null sc-mail-info) |
| 915 | (progn |
| 916 | (message "No mail headers found! Restoring old information.") |
| 917 | (setq sc-mail-info info |
| 918 | sc-attributions attribs)) |
| 919 | (regi-interpret (sc-mail-build-nuke-frame) |
| 920 | sc-mail-headers-start sc-mail-headers-end) |
| 921 | ))) |
| 922 | |
| 923 | \f |
| 924 | ;; let the user change mail field information |
| 925 | (defun sc-mail-field (field) |
| 926 | "Return the mail header field value associated with FIELD. |
| 927 | If there was no mail header with FIELD as its key, return the value of |
| 928 | `sc-mumble'. FIELD is case insensitive." |
| 929 | (or (cdr (assoc (downcase field) sc-mail-info)) sc-mumble)) |
| 930 | |
| 931 | (defun sc-mail-field-query (arg) |
| 932 | "View the value of a mail field. |
| 933 | With `\\[universal-argument]', prompts for action on mail field. |
| 934 | Action can be one of: View, Modify, Add, or Delete." |
| 935 | (interactive "P") |
| 936 | (let* ((alist '(("view" . ?v) ("modify" . ?m) ("add" . ?a) ("delete" . ?d))) |
| 937 | (action (if (not arg) ?v (sc-ask alist))) |
| 938 | key) |
| 939 | (if (not action) |
| 940 | () |
| 941 | (setq key (sc-completing-read |
| 942 | (concat (car (rassq action alist)) |
| 943 | " information key: ") |
| 944 | sc-mail-info nil |
| 945 | (if (eq action ?a) nil 'noexit) |
| 946 | nil 'sc-mail-field-history)) |
| 947 | (cond |
| 948 | ((eq action ?v) |
| 949 | (message "%s: %s" key (cdr (assoc key sc-mail-info)))) |
| 950 | ((eq action ?d) |
| 951 | (setq sc-mail-info (delq (assoc key sc-mail-info) sc-mail-info))) |
| 952 | ((eq action ?m) |
| 953 | (let ((keyval (assoc key sc-mail-info))) |
| 954 | ;; first put initial value onto list if not already there |
| 955 | (if (not (sc-member (cdr keyval) |
| 956 | sc-mail-field-modification-history)) |
| 957 | (setq sc-mail-field-modification-history |
| 958 | (cons (cdr keyval) sc-mail-field-modification-history))) |
| 959 | (setcdr keyval (sc-read-string |
| 960 | (concat key ": ") (cdr keyval) |
| 961 | 'sc-mail-field-modification-history)))) |
| 962 | ((eq action ?a) |
| 963 | (setq sc-mail-info |
| 964 | (cons (cons key |
| 965 | (sc-read-string (concat key ": "))) sc-mail-info))) |
| 966 | )))) |
| 967 | |
| 968 | \f |
| 969 | ;; ====================================================================== |
| 970 | ;; attributions |
| 971 | |
| 972 | (defvar sc-attribution-confirmation-history nil |
| 973 | "History for confirmation of attribution strings.") |
| 974 | (defvar sc-citation-confirmation-history nil |
| 975 | "History for confirmation of attribution prefixes.") |
| 976 | |
| 977 | (defun sc-attribs-%@-addresses (from &optional delim) |
| 978 | "Extract the author's email terminus from email address FROM. |
| 979 | Match addresses of the style ``name%[stuff].'' when called with DELIM |
| 980 | of \"%\" and addresses of the style ``[stuff]name@[stuff]'' when |
| 981 | called with DELIM \"@\". If DELIM is nil or not provided, matches |
| 982 | addresses of the style ``name''." |
| 983 | (and (string-match (concat "[-a-zA-Z0-9_.]+" delim) from 0) |
| 984 | (substring from |
| 985 | (match-beginning 0) |
| 986 | (- (match-end 0) (if (null delim) 0 1))))) |
| 987 | |
| 988 | (defun sc-attribs-!-addresses (from) |
| 989 | "Extract the author's email terminus from email address FROM. |
| 990 | Match addresses of the style ``[stuff]![stuff]...!name[stuff].''" |
| 991 | (let ((eos (length from)) |
| 992 | (mstart (string-match "![-a-zA-Z0-9_.]+\\([^-!a-zA-Z0-9_.]\\|$\\)" |
| 993 | from 0)) |
| 994 | (mend (match-end 0))) |
| 995 | (and mstart |
| 996 | (substring from (1+ mstart) (- mend (if (= mend eos) 0 1))) |
| 997 | ))) |
| 998 | |
| 999 | (defun sc-attribs-<>-addresses (from) |
| 1000 | "Extract the author's email terminus from email address FROM. |
| 1001 | Match addresses of the style ``<name[stuff]>.''" |
| 1002 | (and (string-match "<\\(.*\\)>" from) |
| 1003 | (sc-submatch 1 from))) |
| 1004 | |
| 1005 | (defun sc-get-address (from author) |
| 1006 | "Get the full email address path from FROM. |
| 1007 | AUTHOR is the author's name (which is removed from the address)." |
| 1008 | (let ((eos (length from))) |
| 1009 | (if (string-match (concat "\\(^\\|^\"\\)" author |
| 1010 | "\\(\\s +\\|\"\\s +\\)") from 0) |
| 1011 | (let ((address (substring from (match-end 0) eos))) |
| 1012 | (if (and (= (aref address 0) ?<) |
| 1013 | (= (aref address (1- (length address))) ?>)) |
| 1014 | (substring address 1 (1- (length address))) |
| 1015 | address)) |
| 1016 | (if (string-match "[-[:alnum:]!@%._]+" from 0) |
| 1017 | (sc-submatch 0 from) |
| 1018 | "") |
| 1019 | ))) |
| 1020 | |
| 1021 | (defun sc-attribs-emailname (from) |
| 1022 | "Get the email terminus name from FROM." |
| 1023 | (or |
| 1024 | (sc-attribs-%@-addresses from "%") |
| 1025 | (sc-attribs-%@-addresses from "@") |
| 1026 | (sc-attribs-!-addresses from) |
| 1027 | (sc-attribs-<>-addresses from) |
| 1028 | (sc-attribs-%@-addresses from) |
| 1029 | (substring from 0 10))) |
| 1030 | |
| 1031 | (defun sc-name-substring (string start end extend) |
| 1032 | "Extract the specified substring of STRING from START to END. |
| 1033 | EXTEND is the number of characters on each side to extend the |
| 1034 | substring." |
| 1035 | (and start |
| 1036 | (let ((sos (+ start extend)) |
| 1037 | (eos (- end extend))) |
| 1038 | (substring string sos |
| 1039 | (or (string-match sc-titlecue-regexp string sos) eos) |
| 1040 | )))) |
| 1041 | |
| 1042 | (defun sc-attribs-extract-namestring (from) |
| 1043 | "Extract the name string from FROM. |
| 1044 | This should be the author's full name minus an optional title." |
| 1045 | (let ((namestring |
| 1046 | (or |
| 1047 | ;; If there is a <...> in the name, |
| 1048 | ;; treat everything before that as the full name. |
| 1049 | ;; Even if it contains parens, use the whole thing. |
| 1050 | ;; On the other hand, we do look for quotes in the usual way. |
| 1051 | (and (string-match " *<.*>" from 0) |
| 1052 | (let ((before-angles |
| 1053 | (sc-name-substring from 0 (match-beginning 0) 0))) |
| 1054 | (if (string-match "\".*\"" before-angles 0) |
| 1055 | (sc-name-substring |
| 1056 | before-angles (match-beginning 0) (match-end 0) 1) |
| 1057 | before-angles))) |
| 1058 | (sc-name-substring |
| 1059 | from (string-match "(.*)" from 0) (match-end 0) 1) |
| 1060 | (sc-name-substring |
| 1061 | from (string-match "\".*\"" from 0) (match-end 0) 1) |
| 1062 | (sc-name-substring |
| 1063 | from (string-match "\\([-.[:alnum:]_]+\\s +\\)+<" from 0) |
| 1064 | (match-end 1) 0) |
| 1065 | (sc-attribs-emailname from)))) |
| 1066 | ;; strip off any leading or trailing whitespace |
| 1067 | (if namestring |
| 1068 | (let ((bos 0) |
| 1069 | (eos (1- (length namestring)))) |
| 1070 | (while (and (<= bos eos) |
| 1071 | (memq (aref namestring bos) '(32 ?\t))) |
| 1072 | (setq bos (1+ bos))) |
| 1073 | (while (and (> eos bos) |
| 1074 | (memq (aref namestring eos) '(32 ?\t))) |
| 1075 | (setq eos (1- eos))) |
| 1076 | (substring namestring bos (1+ eos)))))) |
| 1077 | |
| 1078 | (defun sc-attribs-chop-namestring (namestring) |
| 1079 | "Convert NAMESTRING to a list of names. |
| 1080 | example: (sc-namestring-to-list \"John Xavier Doe\") |
| 1081 | => (\"John\" \"Xavier\" \"Doe\")" |
| 1082 | (if (string-match "\\([ \t]*\\)\\([^ \t._]+\\)\\([ \t]*\\)" namestring) |
| 1083 | (cons (sc-submatch 2 namestring) |
| 1084 | (sc-attribs-chop-namestring (substring namestring (match-end 3))) |
| 1085 | ))) |
| 1086 | |
| 1087 | (defun sc-attribs-strip-initials (namelist) |
| 1088 | "Extract the author's initials from the NAMELIST." |
| 1089 | (mapconcat |
| 1090 | (function |
| 1091 | (lambda (name) |
| 1092 | (if (< 0 (length name)) |
| 1093 | (substring name 0 1)))) |
| 1094 | namelist "")) |
| 1095 | |
| 1096 | (defun sc-guess-attribution (&optional string) |
| 1097 | "Guess attribution string on current line. |
| 1098 | If attribution cannot be guessed, nil is returned. Optional STRING if |
| 1099 | supplied, is used instead of the line point is on in the current buffer." |
| 1100 | (let ((start 0) |
| 1101 | (string (or string (buffer-substring (regi-pos 'bol) (regi-pos 'eol)))) |
| 1102 | attribution) |
| 1103 | (and |
| 1104 | (= start (or (string-match sc-citation-leader-regexp string start) -1)) |
| 1105 | (setq start (match-end 0)) |
| 1106 | (= start (or (string-match sc-citation-root-regexp string start) 1)) |
| 1107 | (setq attribution (sc-submatch 0 string) |
| 1108 | start (match-end 0)) |
| 1109 | (= start (or (string-match sc-citation-delimiter-regexp string start) -1)) |
| 1110 | (setq start (match-end 0)) |
| 1111 | (= start (or (string-match sc-citation-separator-regexp string start) -1)) |
| 1112 | attribution))) |
| 1113 | |
| 1114 | (defun sc-attribs-filter-namelist (namelist) |
| 1115 | "Filter out noise in NAMELIST according to `sc-name-filter-alist'." |
| 1116 | (let ((elements (length namelist)) |
| 1117 | (position -1) |
| 1118 | keepers filtered-list) |
| 1119 | (mapcar |
| 1120 | (function |
| 1121 | (lambda (name) |
| 1122 | (setq position (1+ position)) |
| 1123 | (let ((keep-p t)) |
| 1124 | (mapcar |
| 1125 | (function |
| 1126 | (lambda (filter) |
| 1127 | (let ((regexp (car filter)) |
| 1128 | (pos (cdr filter))) |
| 1129 | (if (and (string-match regexp name) |
| 1130 | (or (and (numberp pos) |
| 1131 | (= pos position)) |
| 1132 | (and (eq pos 'last) |
| 1133 | (= position (1- elements))) |
| 1134 | (eq pos 'any))) |
| 1135 | (setq keep-p nil)) |
| 1136 | ))) |
| 1137 | sc-name-filter-alist) |
| 1138 | (if keep-p |
| 1139 | (setq keepers (cons position keepers))) |
| 1140 | ))) |
| 1141 | namelist) |
| 1142 | (mapcar |
| 1143 | (function |
| 1144 | (lambda (position) |
| 1145 | (setq filtered-list (cons (nth position namelist) filtered-list)) |
| 1146 | )) |
| 1147 | keepers) |
| 1148 | filtered-list)) |
| 1149 | |
| 1150 | (defun sc-attribs-chop-address (from) |
| 1151 | "Extract attribution information from FROM. |
| 1152 | This populates the `sc-attributions' with the list of possible attributions." |
| 1153 | (if (and (stringp from) |
| 1154 | (< 0 (length from))) |
| 1155 | (let* ((sc-mumble "") |
| 1156 | (namestring (sc-attribs-extract-namestring from)) |
| 1157 | (namelist (sc-attribs-filter-namelist |
| 1158 | (sc-attribs-chop-namestring namestring))) |
| 1159 | (revnames (reverse (cdr namelist))) |
| 1160 | (firstname (car namelist)) |
| 1161 | (midnames (reverse (cdr revnames))) |
| 1162 | (lastname (car revnames)) |
| 1163 | (initials (sc-attribs-strip-initials namelist)) |
| 1164 | (emailname (sc-attribs-emailname from)) |
| 1165 | (n 1) |
| 1166 | author middlenames) |
| 1167 | |
| 1168 | ;; put basic information |
| 1169 | (setq |
| 1170 | ;; put middle names and build sc-author entry |
| 1171 | middlenames (mapconcat |
| 1172 | (function |
| 1173 | (lambda (midname) |
| 1174 | (let ((key-attribs (format "middlename-%d" n)) |
| 1175 | (key-mail (format "sc-middlename-%d" n))) |
| 1176 | (setq |
| 1177 | sc-attributions (cons (cons key-attribs midname) |
| 1178 | sc-attributions) |
| 1179 | sc-mail-info (cons (cons key-mail midname) |
| 1180 | sc-mail-info) |
| 1181 | n (1+ n)) |
| 1182 | midname))) |
| 1183 | midnames " ") |
| 1184 | |
| 1185 | author (concat firstname " " middlenames (and midnames " ") lastname) |
| 1186 | |
| 1187 | sc-attributions (append |
| 1188 | (list |
| 1189 | (cons "firstname" firstname) |
| 1190 | (cons "lastname" lastname) |
| 1191 | (cons "emailname" emailname) |
| 1192 | (cons "initials" initials)) |
| 1193 | sc-attributions) |
| 1194 | sc-mail-info (append |
| 1195 | (list |
| 1196 | (cons "sc-firstname" firstname) |
| 1197 | (cons "sc-middlenames" middlenames) |
| 1198 | (cons "sc-lastname" lastname) |
| 1199 | (cons "sc-emailname" emailname) |
| 1200 | (cons "sc-initials" initials) |
| 1201 | (cons "sc-author" author) |
| 1202 | (cons "sc-from-address" (sc-get-address |
| 1203 | (sc-mail-field "from") |
| 1204 | namestring)) |
| 1205 | (cons "sc-reply-address" (sc-get-address |
| 1206 | (sc-mail-field "reply-to") |
| 1207 | namestring)) |
| 1208 | (cons "sc-sender-address" (sc-get-address |
| 1209 | (sc-mail-field "sender") |
| 1210 | namestring)) |
| 1211 | ) |
| 1212 | sc-mail-info) |
| 1213 | )) |
| 1214 | ;; from string is empty |
| 1215 | (setq sc-mail-info (cons (cons "sc-author" sc-default-author-name) |
| 1216 | sc-mail-info)))) |
| 1217 | |
| 1218 | (defvar sc-attrib-or-cite nil |
| 1219 | "Used to toggle between attribution input or citation input.") |
| 1220 | |
| 1221 | (defun sc-toggle-fn () |
| 1222 | "Toggle between attribution selection and citation selection. |
| 1223 | Only used during confirmation." |
| 1224 | (interactive) |
| 1225 | (setq sc-attrib-or-cite (not sc-attrib-or-cite)) |
| 1226 | (throw 'sc-reconfirm t)) |
| 1227 | |
| 1228 | (defun sc-select-attribution () |
| 1229 | "Select an attribution from `sc-attributions'. |
| 1230 | |
| 1231 | Variables involved in selection process include: |
| 1232 | `sc-preferred-attribution-list' |
| 1233 | `sc-use-only-preference-p' |
| 1234 | `sc-confirm-always-p' |
| 1235 | `sc-default-attribution' |
| 1236 | `sc-attrib-selection-list'. |
| 1237 | |
| 1238 | Runs the hook `sc-attribs-preselect-hook' before selecting an |
| 1239 | attribution and the hook `sc-attribs-postselect-hook' after making the |
| 1240 | selection but before querying is performed. During |
| 1241 | `sc-attribs-postselect-hook' the variable `citation' is bound to the |
| 1242 | auto-selected citation string and the variable `attribution' is bound |
| 1243 | to the auto-selected attribution string." |
| 1244 | (run-hooks 'sc-attribs-preselect-hook) |
| 1245 | (let ((query-p sc-confirm-always-p) |
| 1246 | attribution citation |
| 1247 | (attriblist sc-preferred-attribution-list)) |
| 1248 | |
| 1249 | ;; first cruise through sc-preferred-attribution-list looking for |
| 1250 | ;; a match in either sc-attributions or sc-mail-info. if the |
| 1251 | ;; element is "sc-consult", then we have to do the alist |
| 1252 | ;; consultation phase |
| 1253 | (while attriblist |
| 1254 | (let* ((preferred (car attriblist))) |
| 1255 | (cond |
| 1256 | ((string= preferred "sc-consult") |
| 1257 | ;; we've been told to consult the attribution vs. mail |
| 1258 | ;; header key alist. we do this until we find a match in |
| 1259 | ;; the sc-attrib-selection-list. if we do not find a match, |
| 1260 | ;; we continue scanning attriblist |
| 1261 | (let ((attrib (sc-scan-info-alist sc-attrib-selection-list))) |
| 1262 | (cond |
| 1263 | ((not attrib) |
| 1264 | (setq attriblist (cdr attriblist))) |
| 1265 | ((stringp attrib) |
| 1266 | (setq attribution attrib |
| 1267 | attriblist nil)) |
| 1268 | ((listp attrib) |
| 1269 | (setq attribution (eval attrib) |
| 1270 | attriblist nil)) |
| 1271 | (t (error "%s did not evaluate to a string or list!" |
| 1272 | "sc-attrib-selection-list")) |
| 1273 | ))) |
| 1274 | ((setq attribution (cdr (assoc preferred sc-attributions))) |
| 1275 | (setq attriblist nil)) |
| 1276 | (t |
| 1277 | (setq attriblist (cdr attriblist))) |
| 1278 | ))) |
| 1279 | |
| 1280 | ;; if preference was not found, we may use a secondary method to |
| 1281 | ;; find a valid attribution |
| 1282 | (if (and (not attribution) |
| 1283 | (not sc-use-only-preference-p)) |
| 1284 | ;; secondary method tries to find a preference in this order |
| 1285 | ;; 1. sc-lastchoice |
| 1286 | ;; 2. x-attribution |
| 1287 | ;; 3. firstname |
| 1288 | ;; 4. lastname |
| 1289 | ;; 5. initials |
| 1290 | ;; 6. first non-empty attribution in alist |
| 1291 | (setq attribution |
| 1292 | (or (cdr (assoc "sc-lastchoice" sc-attributions)) |
| 1293 | (cdr (assoc "x-attribution" sc-attributions)) |
| 1294 | (cdr (assoc "firstname" sc-attributions)) |
| 1295 | (cdr (assoc "lastname" sc-attributions)) |
| 1296 | (cdr (assoc "initials" sc-attributions)) |
| 1297 | (cdr (car sc-attributions))))) |
| 1298 | |
| 1299 | ;; still couldn't find an attribution. we're now limited to using |
| 1300 | ;; the default attribution, but we'll force a query when this happens |
| 1301 | (if (not attribution) |
| 1302 | (setq attribution sc-default-attribution |
| 1303 | query-p t)) |
| 1304 | |
| 1305 | ;; create the attribution prefix |
| 1306 | (setq citation (sc-make-citation attribution)) |
| 1307 | |
| 1308 | ;; run the post selection hook before querying the user |
| 1309 | (run-hooks 'sc-attribs-postselect-hook) |
| 1310 | |
| 1311 | ;; query for confirmation |
| 1312 | (if query-p |
| 1313 | (let* ((query-alist (mapcar (function (lambda (entry) |
| 1314 | (list (cdr entry)))) |
| 1315 | sc-attributions)) |
| 1316 | (minibuffer-local-completion-map |
| 1317 | sc-minibuffer-local-completion-map) |
| 1318 | (minibuffer-local-map sc-minibuffer-local-map) |
| 1319 | (initial attribution) |
| 1320 | (completer-disable t) ; in case completer.el is used |
| 1321 | choice) |
| 1322 | (setq sc-attrib-or-cite nil) ; nil==attribution, t==citation |
| 1323 | (while |
| 1324 | (catch 'sc-reconfirm |
| 1325 | (string= "" (setq choice |
| 1326 | (if sc-attrib-or-cite |
| 1327 | (sc-read-string |
| 1328 | "Enter citation prefix: " |
| 1329 | citation |
| 1330 | 'sc-citation-confirmation-history) |
| 1331 | (sc-completing-read |
| 1332 | "Complete attribution name: " |
| 1333 | query-alist nil nil |
| 1334 | (cons initial 0) |
| 1335 | 'sc-attribution-confirmation-history) |
| 1336 | ))))) |
| 1337 | (if sc-attrib-or-cite |
| 1338 | ;; since the citation was chosen, we have to guess at |
| 1339 | ;; the attribution |
| 1340 | (setq citation choice |
| 1341 | attribution (or (sc-guess-attribution citation) |
| 1342 | citation)) |
| 1343 | |
| 1344 | (setq citation (sc-make-citation choice) |
| 1345 | attribution choice)) |
| 1346 | )) |
| 1347 | |
| 1348 | ;; its possible that the user wants to downcase the citation and |
| 1349 | ;; attribution |
| 1350 | (if sc-downcase-p |
| 1351 | (setq citation (downcase citation) |
| 1352 | attribution (downcase attribution))) |
| 1353 | |
| 1354 | ;; set up mail info alist |
| 1355 | (let* ((ckey "sc-citation") |
| 1356 | (akey "sc-attribution") |
| 1357 | (ckeyval (assoc ckey sc-mail-info)) |
| 1358 | (akeyval (assoc akey sc-mail-info))) |
| 1359 | (if ckeyval |
| 1360 | (setcdr ckeyval citation) |
| 1361 | (setq sc-mail-info |
| 1362 | (append (list (cons ckey citation)) sc-mail-info))) |
| 1363 | (if akeyval |
| 1364 | (setcdr akeyval attribution) |
| 1365 | (setq sc-mail-info |
| 1366 | (append (list (cons akey attribution)) sc-mail-info)))) |
| 1367 | |
| 1368 | ;; set the sc-lastchoice attribution |
| 1369 | (let* ((lkey "sc-lastchoice") |
| 1370 | (lastchoice (assoc lkey sc-attributions))) |
| 1371 | (if lastchoice |
| 1372 | (setcdr lastchoice attribution) |
| 1373 | (setq sc-attributions |
| 1374 | (cons (cons lkey attribution) sc-attributions)))) |
| 1375 | )) |
| 1376 | |
| 1377 | \f |
| 1378 | ;; ====================================================================== |
| 1379 | ;; filladapt hooks for supercite 3.1. you shouldn't need anything |
| 1380 | ;; extra to make gin-mode understand supercited lines. Even this |
| 1381 | ;; stuff might not be entirely necessary... |
| 1382 | |
| 1383 | (defun sc-cite-regexp (&optional root-regexp) |
| 1384 | "Return a regexp describing a Supercited line. |
| 1385 | The regexp is the concatenation of `sc-citation-leader-regexp', |
| 1386 | `sc-citation-root-regexp', `sc-citation-delimiter-regexp', and |
| 1387 | `sc-citation-separator-regexp'. If optional ROOT-REGEXP is supplied, |
| 1388 | use it instead of `sc-citation-root-regexp'." |
| 1389 | (concat sc-citation-leader-regexp |
| 1390 | (or root-regexp sc-citation-root-regexp) |
| 1391 | sc-citation-delimiter-regexp |
| 1392 | sc-citation-separator-regexp)) |
| 1393 | |
| 1394 | (defun sc-make-citation (attribution) |
| 1395 | "Make a non-nested citation from ATTRIBUTION." |
| 1396 | (concat sc-citation-leader |
| 1397 | attribution |
| 1398 | sc-citation-delimiter |
| 1399 | sc-citation-separator)) |
| 1400 | |
| 1401 | (defun sc-setup-filladapt () |
| 1402 | "Setup `filladapt-prefix-table' to handle Supercited paragraphs." |
| 1403 | (let* ((fa-sc-elt 'filladapt-supercite-included-text) |
| 1404 | (elt (rassq fa-sc-elt filladapt-prefix-table))) |
| 1405 | (if elt (setcar elt (sc-cite-regexp)) |
| 1406 | (message "Filladapt doesn't seem to know about Supercite.") |
| 1407 | (beep)))) |
| 1408 | |
| 1409 | \f |
| 1410 | ;; ====================================================================== |
| 1411 | ;; citing and unciting regions of text |
| 1412 | |
| 1413 | (defvar sc-fill-begin 1 |
| 1414 | "Buffer position to begin filling.") |
| 1415 | (defvar sc-fill-line-prefix "" |
| 1416 | "Fill prefix of previous line") |
| 1417 | |
| 1418 | ;; filling |
| 1419 | (defun sc-fill-if-different (&optional prefix) |
| 1420 | "Fill the region bounded by `sc-fill-begin' and point. |
| 1421 | Only fill if optional PREFIX is different than `sc-fill-line-prefix'. |
| 1422 | If `sc-auto-fill-region-p' is nil, do not fill region. If PREFIX is |
| 1423 | not supplied, initialize fill variables. This is useful for a regi |
| 1424 | `begin' frame-entry." |
| 1425 | (if (not prefix) |
| 1426 | (setq sc-fill-line-prefix "" |
| 1427 | sc-fill-begin (regi-pos 'bol)) |
| 1428 | (if (and sc-auto-fill-region-p |
| 1429 | (not (string= prefix sc-fill-line-prefix))) |
| 1430 | (let ((fill-prefix sc-fill-line-prefix)) |
| 1431 | (if (not (string= fill-prefix "")) |
| 1432 | (fill-region sc-fill-begin (regi-pos 'bol))) |
| 1433 | (setq sc-fill-line-prefix prefix |
| 1434 | sc-fill-begin (regi-pos 'bol)))) |
| 1435 | ) |
| 1436 | nil) |
| 1437 | |
| 1438 | (defun sc-cite-coerce-cited-line () |
| 1439 | "Coerce a Supercited line to look like our style." |
| 1440 | (let* ((attribution (sc-guess-attribution)) |
| 1441 | (regexp (sc-cite-regexp attribution)) |
| 1442 | (prefix (sc-make-citation attribution))) |
| 1443 | (if (and attribution |
| 1444 | (looking-at regexp)) |
| 1445 | (progn |
| 1446 | (delete-region |
| 1447 | (match-beginning 0) |
| 1448 | (save-excursion |
| 1449 | (goto-char (match-end 0)) |
| 1450 | (if (bolp) (forward-char -1)) |
| 1451 | (point))) |
| 1452 | (insert prefix) |
| 1453 | (sc-fill-if-different prefix))) |
| 1454 | nil)) |
| 1455 | |
| 1456 | (defun sc-cite-coerce-dumb-citer () |
| 1457 | "Coerce a non-nested citation that's been cited with a dumb nesting citer." |
| 1458 | (delete-region (match-beginning 1) (match-end 1)) |
| 1459 | (beginning-of-line) |
| 1460 | (sc-cite-coerce-cited-line)) |
| 1461 | |
| 1462 | (defun sc-guess-nesting (&optional string) |
| 1463 | "Guess the citation nesting on the current line. |
| 1464 | If nesting cannot be guessed, nil is returned. Optional STRING if |
| 1465 | supplied, is used instead of the line point is on in the current |
| 1466 | buffer." |
| 1467 | (let ((start 0) |
| 1468 | (string (or string (buffer-substring (regi-pos 'bol) (regi-pos 'eol)))) |
| 1469 | nesting) |
| 1470 | (and |
| 1471 | (= start (or (string-match sc-citation-leader-regexp string start) -1)) |
| 1472 | (setq start (match-end 0)) |
| 1473 | (= start (or (string-match sc-citation-delimiter-regexp string start) -1)) |
| 1474 | (setq nesting (sc-submatch 0 string) |
| 1475 | start (match-end 0)) |
| 1476 | (= start (or (string-match sc-citation-separator-regexp string start) -1)) |
| 1477 | nesting))) |
| 1478 | |
| 1479 | (defun sc-add-citation-level () |
| 1480 | "Add a citation level for nested citation style w/ coercion." |
| 1481 | (let* ((nesting (sc-guess-nesting)) |
| 1482 | (citation (make-string (1+ (length nesting)) |
| 1483 | (string-to-char sc-citation-delimiter))) |
| 1484 | (prefix (concat sc-citation-leader citation sc-citation-separator))) |
| 1485 | (if (looking-at (sc-cite-regexp "")) |
| 1486 | (delete-region (match-beginning 0) (match-end 0))) |
| 1487 | (insert prefix) |
| 1488 | (sc-fill-if-different prefix))) |
| 1489 | |
| 1490 | (defun sc-cite-line (&optional citation) |
| 1491 | "Cite a single line of uncited text. |
| 1492 | Optional CITATION overrides any citation automatically selected." |
| 1493 | (if sc-fixup-whitespace-p |
| 1494 | (fixup-whitespace)) |
| 1495 | (let ((prefix (or citation |
| 1496 | (cdr (assoc "sc-citation" sc-mail-info)) |
| 1497 | sc-default-attribution))) |
| 1498 | (insert prefix) |
| 1499 | (sc-fill-if-different prefix)) |
| 1500 | nil) |
| 1501 | |
| 1502 | (defun sc-uncite-line () |
| 1503 | "Remove citation from current line." |
| 1504 | (let ((cited (looking-at (sc-cite-regexp)))) |
| 1505 | (if cited |
| 1506 | (delete-region (match-beginning 0) (match-end 0)))) |
| 1507 | nil) |
| 1508 | |
| 1509 | (defun sc-recite-line (regexp) |
| 1510 | "Remove citation matching REGEXP from current line and recite line." |
| 1511 | (let ((cited (looking-at (concat "^" regexp))) |
| 1512 | (prefix (cdr (assoc "sc-citation" sc-mail-info)))) |
| 1513 | (if cited |
| 1514 | (delete-region (match-beginning 0) (match-end 0))) |
| 1515 | (insert (or prefix sc-default-attribution)) |
| 1516 | (sc-fill-if-different prefix)) |
| 1517 | nil) |
| 1518 | |
| 1519 | ;; interactive functions |
| 1520 | (defun sc-cite-region (start end &optional confirm-p) |
| 1521 | "Cite a region delineated by START and END. |
| 1522 | If optional CONFIRM-P is non-nil, the attribution is confirmed before |
| 1523 | its use in the citation string. This function first runs |
| 1524 | `sc-pre-cite-hook'." |
| 1525 | (interactive "r\nP") |
| 1526 | (undo-boundary) |
| 1527 | (let ((frame (or (sc-scan-info-alist sc-cite-frame-alist) |
| 1528 | sc-default-cite-frame)) |
| 1529 | (sc-confirm-always-p (if confirm-p t sc-confirm-always-p))) |
| 1530 | (run-hooks 'sc-pre-cite-hook) |
| 1531 | (if (interactive-p) |
| 1532 | (sc-select-attribution)) |
| 1533 | (regi-interpret frame start end))) |
| 1534 | |
| 1535 | (defun sc-uncite-region (start end) |
| 1536 | "Uncite a region delineated by START and END. |
| 1537 | First runs `sc-pre-uncite-hook'." |
| 1538 | (interactive "r") |
| 1539 | (undo-boundary) |
| 1540 | (let ((frame (or (sc-scan-info-alist sc-uncite-frame-alist) |
| 1541 | sc-default-uncite-frame))) |
| 1542 | (run-hooks 'sc-pre-uncite-hook) |
| 1543 | (regi-interpret frame start end))) |
| 1544 | |
| 1545 | (defun sc-recite-region (start end) |
| 1546 | "Recite a region delineated by START and END. |
| 1547 | First runs `sc-pre-recite-hook'." |
| 1548 | (interactive "r") |
| 1549 | (let ((sc-confirm-always-p t)) |
| 1550 | (sc-select-attribution)) |
| 1551 | (undo-boundary) |
| 1552 | (let ((frame (or (sc-scan-info-alist sc-recite-frame-alist) |
| 1553 | sc-default-recite-frame))) |
| 1554 | (run-hooks 'sc-pre-recite-hook) |
| 1555 | (regi-interpret frame start end))) |
| 1556 | |
| 1557 | \f |
| 1558 | ;; ====================================================================== |
| 1559 | ;; building headers |
| 1560 | |
| 1561 | (defun sc-hdr (prefix field &optional sep return-nil-p) |
| 1562 | "Returns a concatenation of PREFIX and FIELD. |
| 1563 | If FIELD is not a string or is the empty string, the empty string will |
| 1564 | be returned. Optional third argument SEP is concatenated on the end if |
| 1565 | it is a string. Returns empty string, unless optional RETURN-NIL-P is |
| 1566 | non-nil." |
| 1567 | (if (and (stringp field) |
| 1568 | (not (string= field ""))) |
| 1569 | (concat prefix field (or sep "")) |
| 1570 | (and (not return-nil-p) ""))) |
| 1571 | |
| 1572 | (defun sc-whofrom () |
| 1573 | "Return the value of (sc-mail-field \"from\") or nil." |
| 1574 | (let ((sc-mumble nil)) |
| 1575 | (sc-mail-field "from"))) |
| 1576 | |
| 1577 | (defun sc-no-header () |
| 1578 | "Does nothing. Use this instead of nil to get a blank header." |
| 1579 | ()) |
| 1580 | |
| 1581 | (defun sc-no-blank-line-or-header() |
| 1582 | "Similar to `sc-no-header' except it removes the preceding blank line." |
| 1583 | (if (not (bobp)) |
| 1584 | (if (and (eolp) |
| 1585 | (progn (forward-line -1) |
| 1586 | (or (= (point) (mail-header-end)) |
| 1587 | (and (eq major-mode 'mh-letter-mode) |
| 1588 | (mh-in-header-p))))) |
| 1589 | (progn (forward-line) |
| 1590 | (let ((kill-lines-magic t)) |
| 1591 | (kill-line)))))) |
| 1592 | |
| 1593 | (defun sc-header-on-said () |
| 1594 | "\"On <date>, <from> said:\" unless: |
| 1595 | 1. the \"from\" field cannot be found, in which case nothing is inserted; |
| 1596 | 2. the \"date\" field is missing in which case only the from part is printed." |
| 1597 | (let ((sc-mumble "") |
| 1598 | (whofrom (sc-whofrom))) |
| 1599 | (if whofrom |
| 1600 | (insert sc-reference-tag-string |
| 1601 | (sc-hdr "On " (sc-mail-field "date") ", ") |
| 1602 | whofrom " said:\n")))) |
| 1603 | |
| 1604 | (defun sc-header-inarticle-writes () |
| 1605 | "\"In article <message-id>, <from> writes:\" |
| 1606 | Treats \"message-id\" and \"from\" fields similar to `sc-header-on-said'." |
| 1607 | (let ((sc-mumble "") |
| 1608 | (whofrom (sc-mail-field "from"))) |
| 1609 | (if whofrom |
| 1610 | (insert sc-reference-tag-string |
| 1611 | (sc-hdr "In article " (sc-mail-field "message-id") ", ") |
| 1612 | whofrom " writes:\n")))) |
| 1613 | |
| 1614 | (defun sc-header-regarding-adds () |
| 1615 | "\"Regarding <subject>; <from> adds:\" |
| 1616 | Treats \"subject\" and \"from\" fields similar to `sc-header-on-said'." |
| 1617 | (let ((sc-mumble "") |
| 1618 | (whofrom (sc-whofrom))) |
| 1619 | (if whofrom |
| 1620 | (insert sc-reference-tag-string |
| 1621 | (sc-hdr "Regarding " (sc-mail-field "subject") "; ") |
| 1622 | whofrom " adds:\n")))) |
| 1623 | |
| 1624 | (defun sc-header-attributed-writes () |
| 1625 | "\"<sc-attribution>\" == <sc-author> <address> writes: |
| 1626 | Treats these fields in a similar manner to `sc-header-on-said'." |
| 1627 | (let ((sc-mumble "") |
| 1628 | (whofrom (sc-whofrom))) |
| 1629 | (if whofrom |
| 1630 | (insert sc-reference-tag-string |
| 1631 | (sc-hdr "\"" (sc-mail-field "sc-attribution") "\" == ") |
| 1632 | (sc-hdr "" (sc-mail-field "sc-author") " ") |
| 1633 | (or (sc-hdr "<" (sc-mail-field "sc-from-address") ">" t) |
| 1634 | (sc-hdr "<" (sc-mail-field "sc-reply-address") ">" t) |
| 1635 | "") |
| 1636 | " writes:\n")))) |
| 1637 | |
| 1638 | (defun sc-header-author-writes () |
| 1639 | "<sc-author> writes:" |
| 1640 | (let ((sc-mumble "") |
| 1641 | (whofrom (sc-whofrom))) |
| 1642 | (if whofrom |
| 1643 | (insert sc-reference-tag-string |
| 1644 | (sc-hdr "" (sc-mail-field "sc-author")) |
| 1645 | " writes:\n")))) |
| 1646 | |
| 1647 | (defun sc-header-verbose () |
| 1648 | "Very verbose, some say gross." |
| 1649 | (let ((sc-mumble "") |
| 1650 | (whofrom (sc-whofrom)) |
| 1651 | (tag sc-reference-tag-string)) |
| 1652 | (if whofrom |
| 1653 | (insert (sc-hdr (concat tag "On ") (sc-mail-field "date") ",\n") |
| 1654 | (or (sc-hdr tag (sc-mail-field "sc-author") "\n" t) |
| 1655 | (concat tag whofrom "\n")) |
| 1656 | (sc-hdr (concat tag "from the organization of ") |
| 1657 | (sc-mail-field "organization") "\n") |
| 1658 | (let ((rtag (concat tag "who can be reached at: "))) |
| 1659 | (or (sc-hdr rtag (sc-mail-field "sc-from-address") "\n" t) |
| 1660 | (sc-hdr rtag (sc-mail-field "sc-reply-address") "\n" t) |
| 1661 | "")) |
| 1662 | (sc-hdr |
| 1663 | (concat tag "(whose comments are cited below with \"") |
| 1664 | (sc-mail-field "sc-citation") "\"),\n") |
| 1665 | (sc-hdr (concat tag "had this to say in article ") |
| 1666 | (sc-mail-field "message-id") "\n") |
| 1667 | (sc-hdr (concat tag "in newsgroups ") |
| 1668 | (sc-mail-field "newsgroups") "\n") |
| 1669 | (sc-hdr (concat tag "concerning the subject of ") |
| 1670 | (sc-mail-field "subject") "\n") |
| 1671 | (sc-hdr (concat tag "(see ") |
| 1672 | (sc-mail-field "references") |
| 1673 | " for more details)\n") |
| 1674 | )))) |
| 1675 | |
| 1676 | \f |
| 1677 | ;; ====================================================================== |
| 1678 | ;; header rewrites |
| 1679 | |
| 1680 | (defconst sc-electric-bufname " *sc-erefs* " |
| 1681 | "Supercite electric reference mode's buffer name.") |
| 1682 | (defvar sc-eref-style 0 |
| 1683 | "Current electric reference style.") |
| 1684 | |
| 1685 | (defun sc-valid-index-p (index) |
| 1686 | "Returns INDEX if it is a valid index into `sc-rewrite-header-list'. |
| 1687 | Otherwise returns nil." |
| 1688 | ;; a number, and greater than or equal to zero |
| 1689 | ;; less than or equal to the last index |
| 1690 | (and (natnump index) |
| 1691 | (< index (length sc-rewrite-header-list)) |
| 1692 | index)) |
| 1693 | |
| 1694 | (defun sc-eref-insert-selected (&optional nomsg) |
| 1695 | "Insert the selected reference header in the current buffer. |
| 1696 | Optional NOMSG, if non-nil, inhibits printing messages, unless an |
| 1697 | error occurs." |
| 1698 | (let ((ref (nth sc-eref-style sc-rewrite-header-list))) |
| 1699 | (condition-case err |
| 1700 | (progn |
| 1701 | (eval ref) |
| 1702 | (let ((lines (count-lines (point-min) (point-max)))) |
| 1703 | (or nomsg (message "Ref header %d [%d line%s]: %s" |
| 1704 | sc-eref-style lines |
| 1705 | (if (= lines 1) "" "s") |
| 1706 | ref)))) |
| 1707 | (void-function |
| 1708 | (progn (message |
| 1709 | "Symbol's function definition is void: %s (Header %d)" |
| 1710 | (car (cdr err)) sc-eref-style) |
| 1711 | (beep) |
| 1712 | )) |
| 1713 | ))) |
| 1714 | |
| 1715 | (defun sc-electric-mode (&optional arg) |
| 1716 | " |
| 1717 | Mode for viewing Supercite reference headers. Commands are: |
| 1718 | \n\\{sc-electric-mode-map} |
| 1719 | |
| 1720 | `sc-electric-mode' is not intended to be run interactively, but rather |
| 1721 | accessed through Supercite's electric reference feature. See |
| 1722 | `sc-insert-reference' for more details. Optional ARG is the initial |
| 1723 | header style to use, unless not supplied or invalid, in which case |
| 1724 | `sc-preferred-header-style' is used." |
| 1725 | |
| 1726 | (let ((info sc-mail-info)) |
| 1727 | |
| 1728 | (setq sc-eref-style |
| 1729 | (or (sc-valid-index-p arg) |
| 1730 | (sc-valid-index-p sc-preferred-header-style) |
| 1731 | 0)) |
| 1732 | |
| 1733 | (get-buffer-create sc-electric-bufname) |
| 1734 | ;; set up buffer and enter command loop |
| 1735 | (save-excursion |
| 1736 | (save-window-excursion |
| 1737 | (pop-to-buffer sc-electric-bufname) |
| 1738 | (kill-all-local-variables) |
| 1739 | (let ((sc-mail-info info) |
| 1740 | (buffer-read-only t) |
| 1741 | (mode-name "SC Electric Refs") |
| 1742 | (major-mode 'sc-electric-mode)) |
| 1743 | (use-local-map sc-electric-mode-map) |
| 1744 | (sc-eref-show sc-eref-style) |
| 1745 | (run-hooks 'sc-electric-mode-hook) |
| 1746 | (recursive-edit) |
| 1747 | ))) |
| 1748 | |
| 1749 | (and sc-eref-style |
| 1750 | (sc-eref-insert-selected)) |
| 1751 | (kill-buffer sc-electric-bufname) |
| 1752 | )) |
| 1753 | |
| 1754 | ;; functions for electric reference mode |
| 1755 | (defun sc-eref-show (index) |
| 1756 | "Show reference INDEX in `sc-rewrite-header-list'." |
| 1757 | (let ((msg "No %ing reference headers in list.") |
| 1758 | (last (length sc-rewrite-header-list))) |
| 1759 | (setq sc-eref-style |
| 1760 | (cond |
| 1761 | ((sc-valid-index-p index) index) |
| 1762 | ((< index 0) |
| 1763 | (if sc-electric-circular-p |
| 1764 | (1- last) |
| 1765 | (progn (error msg "preced") 0))) |
| 1766 | ((>= index last) |
| 1767 | (if sc-electric-circular-p |
| 1768 | 0 |
| 1769 | (progn (error msg "follow") (1- last)))) |
| 1770 | )) |
| 1771 | (save-excursion |
| 1772 | (set-buffer sc-electric-bufname) |
| 1773 | (let ((buffer-read-only nil)) |
| 1774 | (erase-buffer) |
| 1775 | (goto-char (point-min)) |
| 1776 | (sc-eref-insert-selected) |
| 1777 | ;; now shrink the window to just contain the electric reference |
| 1778 | ;; header. |
| 1779 | (let ((hdrlines (count-lines (point-min) (point-max))) |
| 1780 | (winlines (1- (window-height)))) |
| 1781 | (if (/= hdrlines winlines) |
| 1782 | (if (> hdrlines winlines) |
| 1783 | ;; we have to enlarge the window |
| 1784 | (enlarge-window (- hdrlines winlines)) |
| 1785 | ;; we have to shrink the window |
| 1786 | (shrink-window (- winlines (max hdrlines window-min-height))) |
| 1787 | ))) |
| 1788 | )))) |
| 1789 | |
| 1790 | (defun sc-eref-next () |
| 1791 | "Display next reference in other buffer." |
| 1792 | (interactive) |
| 1793 | (sc-eref-show (1+ sc-eref-style))) |
| 1794 | |
| 1795 | (defun sc-eref-prev () |
| 1796 | "Display previous reference in other buffer." |
| 1797 | (interactive) |
| 1798 | (sc-eref-show (1- sc-eref-style))) |
| 1799 | |
| 1800 | (defun sc-eref-setn () |
| 1801 | "Set reference header selected as preferred." |
| 1802 | (interactive) |
| 1803 | (setq sc-preferred-header-style sc-eref-style) |
| 1804 | (message "Preferred reference style set to header %d." sc-eref-style)) |
| 1805 | |
| 1806 | (defun sc-eref-goto (refnum) |
| 1807 | "Show reference style indexed by REFNUM. |
| 1808 | If REFNUM is an invalid index, don't go to that reference and return |
| 1809 | nil." |
| 1810 | (interactive "NGoto Reference: ") |
| 1811 | (if (sc-valid-index-p refnum) |
| 1812 | (sc-eref-show refnum) |
| 1813 | (error "Invalid reference: %d. (Range: [%d .. %d])" |
| 1814 | refnum 0 (1- (length sc-rewrite-header-list))) |
| 1815 | )) |
| 1816 | |
| 1817 | (defun sc-eref-jump () |
| 1818 | "Set reference header to preferred header." |
| 1819 | (interactive) |
| 1820 | (sc-eref-show sc-preferred-header-style)) |
| 1821 | |
| 1822 | (defun sc-eref-abort () |
| 1823 | "Exit from electric reference mode without inserting reference." |
| 1824 | (interactive) |
| 1825 | (setq sc-eref-style nil) |
| 1826 | (exit-recursive-edit)) |
| 1827 | |
| 1828 | (defun sc-eref-exit () |
| 1829 | "Exit from electric reference mode and insert selected reference." |
| 1830 | (interactive) |
| 1831 | (exit-recursive-edit)) |
| 1832 | |
| 1833 | (defun sc-insert-reference (arg) |
| 1834 | "Insert, at point, a reference header in the body of the reply. |
| 1835 | Numeric ARG indicates which header style from `sc-rewrite-header-list' |
| 1836 | to use when rewriting the header. No supplied ARG indicates use of |
| 1837 | `sc-preferred-header-style'. |
| 1838 | |
| 1839 | With just `\\[universal-argument]', electric reference insert mode is |
| 1840 | entered, regardless of the value of `sc-electric-references-p'. See |
| 1841 | `sc-electric-mode' for more information." |
| 1842 | (interactive "P") |
| 1843 | (if (consp arg) |
| 1844 | (sc-electric-mode) |
| 1845 | (let ((preference (or (sc-valid-index-p arg) |
| 1846 | (sc-valid-index-p sc-preferred-header-style) |
| 1847 | sc-preferred-header-style |
| 1848 | 0))) |
| 1849 | (if sc-electric-references-p |
| 1850 | (sc-electric-mode preference) |
| 1851 | (sc-eref-insert-selected t) |
| 1852 | )))) |
| 1853 | |
| 1854 | \f |
| 1855 | ;; ====================================================================== |
| 1856 | ;; variable toggling |
| 1857 | |
| 1858 | (defun sc-raw-mode-toggle () |
| 1859 | "Toggle, in one fell swoop, two important SC variables: |
| 1860 | `sc-fixup-whitespace-p' and `sc-auto-fill-region-p'" |
| 1861 | (interactive) |
| 1862 | (setq sc-fixup-whitespace-p (not sc-fixup-whitespace-p) |
| 1863 | sc-auto-fill-region-p (not sc-auto-fill-region-p)) |
| 1864 | (sc-set-mode-string) |
| 1865 | (force-mode-line-update)) |
| 1866 | |
| 1867 | (defun sc-toggle-var (variable) |
| 1868 | "Boolean toggle VARIABLE's value. |
| 1869 | VARIABLE must be a bound symbol. Nil values change to t, non-nil |
| 1870 | values are changed to nil." |
| 1871 | (message "%s changed from %s to %s" |
| 1872 | variable (symbol-value variable) |
| 1873 | (set variable (not (symbol-value variable)))) |
| 1874 | (sc-set-mode-string)) |
| 1875 | |
| 1876 | (defun sc-set-variable (var) |
| 1877 | "Set the Supercite VARIABLE. |
| 1878 | This function mimics `set-variable', except that the variable to set |
| 1879 | is determined non-interactively. The value is queried for in the |
| 1880 | minibuffer exactly the same way that `set-variable' does it. |
| 1881 | |
| 1882 | You can see the current value of the variable when the minibuffer is |
| 1883 | querying you by typing `C-h'. Note that the format is changed |
| 1884 | slightly from that used by `set-variable' -- the current value is |
| 1885 | printed just after the variable's name instead of at the bottom of the |
| 1886 | help window." |
| 1887 | (let* ((minibuffer-help-form |
| 1888 | '(funcall myhelp)) |
| 1889 | (myhelp |
| 1890 | (function |
| 1891 | (lambda () |
| 1892 | (with-output-to-temp-buffer "*Help*" |
| 1893 | (prin1 var) |
| 1894 | (if (boundp var) |
| 1895 | (let ((print-length 20)) |
| 1896 | (princ "\t(Current value: ") |
| 1897 | (prin1 (symbol-value var)) |
| 1898 | (princ ")"))) |
| 1899 | (princ "\n\nDocumentation:\n") |
| 1900 | (princ (substring (documentation-property |
| 1901 | var |
| 1902 | 'variable-documentation) |
| 1903 | 1)) |
| 1904 | (save-excursion |
| 1905 | (set-buffer standard-output) |
| 1906 | (help-mode)) |
| 1907 | nil))))) |
| 1908 | (set var (eval-minibuffer (format "Set %s to value: " var)))) |
| 1909 | (sc-set-mode-string)) |
| 1910 | |
| 1911 | (defmacro sc-toggle-symbol (rootname) |
| 1912 | (list 'defun (intern (concat "sc-T-" rootname)) '() |
| 1913 | (list 'interactive) |
| 1914 | (list 'sc-toggle-var |
| 1915 | (list 'quote (intern (concat "sc-" rootname "-p")))))) |
| 1916 | |
| 1917 | (defmacro sc-setvar-symbol (rootname) |
| 1918 | (list 'defun (intern (concat "sc-S-" rootname)) '() |
| 1919 | (list 'interactive) |
| 1920 | (list 'sc-set-variable |
| 1921 | (list 'quote (intern (concat "sc-" rootname)))))) |
| 1922 | |
| 1923 | (sc-toggle-symbol "confirm-always") |
| 1924 | (sc-toggle-symbol "downcase") |
| 1925 | (sc-toggle-symbol "electric-references") |
| 1926 | (sc-toggle-symbol "auto-fill-region") |
| 1927 | (sc-toggle-symbol "mail-nuke-blank-lines") |
| 1928 | (sc-toggle-symbol "nested-citation") |
| 1929 | (sc-toggle-symbol "electric-circular") |
| 1930 | (sc-toggle-symbol "use-only-preferences") |
| 1931 | (sc-toggle-symbol "fixup-whitespace") |
| 1932 | |
| 1933 | (sc-setvar-symbol "preferred-attribution-list") |
| 1934 | (sc-setvar-symbol "preferred-header-style") |
| 1935 | (sc-setvar-symbol "mail-nuke-mail-headers") |
| 1936 | (sc-setvar-symbol "mail-header-nuke-list") |
| 1937 | (sc-setvar-symbol "cite-region-limit") |
| 1938 | |
| 1939 | (defun sc-T-describe () |
| 1940 | " |
| 1941 | |
| 1942 | Supercite provides a number of key bindings which simplify the process |
| 1943 | of setting or toggling certain variables controlling its operation. |
| 1944 | |
| 1945 | Note on function names in this list: all functions of the form |
| 1946 | `sc-S-<name>' actually call `sc-set-variable' on the corresponding |
| 1947 | `sc-<name>' variable. All functions of the form `sc-T-<name>' call |
| 1948 | `sc-toggle-var' on the corresponding `sc-<name>-p' variable. |
| 1949 | |
| 1950 | \\{sc-T-keymap}" |
| 1951 | (interactive) |
| 1952 | (describe-function 'sc-T-describe)) |
| 1953 | |
| 1954 | (defun sc-set-mode-string () |
| 1955 | "Update the minor mode string to show state of Supercite." |
| 1956 | (setq sc-mode-string |
| 1957 | (concat " SC" |
| 1958 | (if (or sc-auto-fill-region-p |
| 1959 | sc-fixup-whitespace-p) |
| 1960 | ":" "") |
| 1961 | (if sc-auto-fill-region-p "f" "") |
| 1962 | (if sc-fixup-whitespace-p "w" "") |
| 1963 | ))) |
| 1964 | |
| 1965 | \f |
| 1966 | ;; ====================================================================== |
| 1967 | ;; published interface to mail and news readers |
| 1968 | |
| 1969 | ;;;###autoload |
| 1970 | (defun sc-cite-original () |
| 1971 | "Workhorse citing function which performs the initial citation. |
| 1972 | This is callable from the various mail and news readers' reply |
| 1973 | function according to the agreed upon standard. See `\\[sc-describe]' |
| 1974 | for more details. `sc-cite-original' does not do any yanking of the |
| 1975 | original message but it does require a few things: |
| 1976 | |
| 1977 | 1) The reply buffer is the current buffer. |
| 1978 | |
| 1979 | 2) The original message has been yanked and inserted into the |
| 1980 | reply buffer. |
| 1981 | |
| 1982 | 3) Verbose mail headers from the original message have been |
| 1983 | inserted into the reply buffer directly before the text of the |
| 1984 | original message. |
| 1985 | |
| 1986 | 4) Point is at the beginning of the verbose headers. |
| 1987 | |
| 1988 | 5) Mark is at the end of the body of text to be cited. |
| 1989 | |
| 1990 | For Emacs 19's, the region need not be active (and typically isn't |
| 1991 | when this function is called. Also, the hook `sc-pre-hook' is run |
| 1992 | before, and `sc-post-hook' is run after the guts of this function." |
| 1993 | (run-hooks 'sc-pre-hook) |
| 1994 | |
| 1995 | ;; before we do anything, we want to insert the supercite keymap so |
| 1996 | ;; we can proceed from here |
| 1997 | (and sc-mode-map-prefix |
| 1998 | (local-set-key sc-mode-map-prefix sc-mode-map)) |
| 1999 | |
| 2000 | ;; hack onto the minor mode alist, if it hasn't been done before, |
| 2001 | ;; then turn on the minor mode. also, set the minor mode string with |
| 2002 | ;; the values of fill and fixup whitespace variables |
| 2003 | (if (not (get 'minor-mode-alist 'sc-minor-mode)) |
| 2004 | (progn |
| 2005 | (put 'minor-mode-alist 'sc-minor-mode 'sc-minor-mode) |
| 2006 | (setq minor-mode-alist |
| 2007 | (cons '(sc-minor-mode sc-mode-string) minor-mode-alist)) |
| 2008 | )) |
| 2009 | (setq sc-minor-mode t) |
| 2010 | (sc-set-mode-string) |
| 2011 | |
| 2012 | (undo-boundary) |
| 2013 | |
| 2014 | ;; grab point and mark since the region is probably not active when |
| 2015 | ;; this function gets automatically called. we want point to be a |
| 2016 | ;; mark so any deleting before point works properly |
| 2017 | (let* ((zmacs-regions nil) ; for Lemacs |
| 2018 | (mark-active t) ; for Emacs |
| 2019 | (point (point-marker)) |
| 2020 | (mark (copy-marker (mark-marker)))) |
| 2021 | |
| 2022 | ;; make sure point comes before mark, not all functions are |
| 2023 | ;; interactive "r" |
| 2024 | (if (< mark point) |
| 2025 | (let ((tmp point)) |
| 2026 | (setq point mark |
| 2027 | mark tmp))) |
| 2028 | |
| 2029 | ;; first process mail headers, and populate sc-mail-info |
| 2030 | (sc-mail-process-headers point mark) |
| 2031 | |
| 2032 | ;; now get possible attributions |
| 2033 | (sc-attribs-chop-address (or (sc-mail-field "from") |
| 2034 | (sc-mail-field "reply") |
| 2035 | (sc-mail-field "reply-to") |
| 2036 | (sc-mail-field "sender"))) |
| 2037 | ;; select the attribution |
| 2038 | (sc-select-attribution) |
| 2039 | |
| 2040 | ;; cite the region, but first check the value of sc-cite-region-limit |
| 2041 | (let ((linecnt (count-lines point mark))) |
| 2042 | (and sc-cite-region-limit |
| 2043 | (if (or (not (numberp sc-cite-region-limit)) |
| 2044 | (<= linecnt sc-cite-region-limit)) |
| 2045 | (progn |
| 2046 | ;; cite the region and insert the header rewrite |
| 2047 | (sc-cite-region point mark) |
| 2048 | (goto-char point) |
| 2049 | (let ((sc-eref-style (or sc-preferred-header-style 0))) |
| 2050 | (if sc-electric-references-p |
| 2051 | (sc-electric-mode sc-eref-style) |
| 2052 | (sc-eref-insert-selected t)))) |
| 2053 | (beep) |
| 2054 | (message |
| 2055 | "Region not cited. %d lines exceeds sc-cite-region-limit: %d" |
| 2056 | linecnt sc-cite-region-limit)))) |
| 2057 | |
| 2058 | ;; finally, free the point-marker |
| 2059 | (set-marker point nil) |
| 2060 | (set-marker mark nil) |
| 2061 | ) |
| 2062 | (run-hooks 'sc-post-hook) |
| 2063 | ;; post hook could have changed the variables |
| 2064 | (sc-set-mode-string)) |
| 2065 | |
| 2066 | \f |
| 2067 | ;; ====================================================================== |
| 2068 | ;; bug reporting and miscellaneous commands |
| 2069 | |
| 2070 | (defun sc-open-line (arg) |
| 2071 | "Like `open-line', but insert the citation prefix at the front of the line. |
| 2072 | With numeric ARG, inserts that many new lines." |
| 2073 | (interactive "p") |
| 2074 | (save-excursion |
| 2075 | (let ((start (point)) |
| 2076 | (prefix (or (progn (beginning-of-line) |
| 2077 | (if (looking-at (sc-cite-regexp)) |
| 2078 | (sc-submatch 0))) |
| 2079 | ""))) |
| 2080 | (goto-char start) |
| 2081 | (open-line arg) |
| 2082 | (forward-line 1) |
| 2083 | (while (< 0 arg) |
| 2084 | (insert prefix) |
| 2085 | (forward-line 1) |
| 2086 | (setq arg (1- arg)) |
| 2087 | )))) |
| 2088 | |
| 2089 | (defun sc-insert-citation (arg) |
| 2090 | "Insert citation string at beginning of current line if not already cited. |
| 2091 | With `\\[universal-argument]' insert citation even if line is already |
| 2092 | cited." |
| 2093 | (interactive "P") |
| 2094 | (save-excursion |
| 2095 | (beginning-of-line) |
| 2096 | (if (or (not (looking-at (sc-cite-regexp))) |
| 2097 | (looking-at "^[ \t]*$") |
| 2098 | (consp arg)) |
| 2099 | (insert (sc-mail-field "sc-citation")) |
| 2100 | (error "Line is already cited")))) |
| 2101 | |
| 2102 | (defun sc-version (arg) |
| 2103 | "Echo the current version of Supercite in the minibuffer. |
| 2104 | With \\[universal-argument] (universal-argument), or if run non-interactively, |
| 2105 | inserts the version string in the current buffer instead." |
| 2106 | (interactive "P") |
| 2107 | (let ((verstr (format "Using Supercite.el %s" sc-version))) |
| 2108 | (if (or (consp arg) |
| 2109 | (not (interactive-p))) |
| 2110 | (insert "`sc-version' says: " verstr) |
| 2111 | (message verstr)))) |
| 2112 | |
| 2113 | (defun sc-describe () |
| 2114 | " |
| 2115 | Supercite is a package which provides a flexible mechanism for citing |
| 2116 | email and news replies. Please see the associated texinfo file for |
| 2117 | more information." |
| 2118 | (interactive) |
| 2119 | (describe-function 'sc-describe)) |
| 2120 | |
| 2121 | (defun sc-submit-bug-report () |
| 2122 | "Submit a bug report on Supercite via mail." |
| 2123 | (interactive) |
| 2124 | (require 'reporter) |
| 2125 | (and |
| 2126 | (y-or-n-p "Do you want to submit a report on Supercite? ") |
| 2127 | (reporter-submit-bug-report |
| 2128 | sc-help-address |
| 2129 | (concat "Supercite version " sc-version) |
| 2130 | (list |
| 2131 | 'sc-attrib-selection-list |
| 2132 | 'sc-auto-fill-region-p |
| 2133 | 'sc-blank-lines-after-headers |
| 2134 | 'sc-citation-leader |
| 2135 | 'sc-citation-delimiter |
| 2136 | 'sc-citation-separator |
| 2137 | 'sc-citation-leader-regexp |
| 2138 | 'sc-citation-root-regexp |
| 2139 | 'sc-citation-nonnested-root-regexp |
| 2140 | 'sc-citation-delimiter-regexp |
| 2141 | 'sc-citation-separator-regexp |
| 2142 | 'sc-cite-region-limit |
| 2143 | 'sc-confirm-always-p |
| 2144 | 'sc-default-attribution |
| 2145 | 'sc-default-author-name |
| 2146 | 'sc-downcase-p |
| 2147 | 'sc-electric-circular-p |
| 2148 | 'sc-electric-references-p |
| 2149 | 'sc-fixup-whitespace-p |
| 2150 | 'sc-mail-warn-if-non-rfc822-p |
| 2151 | 'sc-mumble |
| 2152 | 'sc-name-filter-alist |
| 2153 | 'sc-nested-citation-p |
| 2154 | 'sc-nuke-mail-headers |
| 2155 | 'sc-nuke-mail-header-list |
| 2156 | 'sc-preferred-attribution-list |
| 2157 | 'sc-preferred-header-style |
| 2158 | 'sc-reference-tag-string |
| 2159 | 'sc-rewrite-header-list |
| 2160 | 'sc-titlecue-regexp |
| 2161 | 'sc-use-only-preference-p |
| 2162 | )))) |
| 2163 | |
| 2164 | \f |
| 2165 | ;; useful stuff |
| 2166 | (provide 'supercite) |
| 2167 | (run-hooks 'sc-load-hook) |
| 2168 | |
| 2169 | ;;; supercite.el ends here |