aboutsummaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorStefan Monnier2003-05-24 00:34:15 +0000
committerStefan Monnier2003-05-24 00:34:15 +0000
commitd49b7f88eb5f1597098fe863df8c98dcec5771e0 (patch)
treef7e36aee647640b955070ea3544b86ecc681d2b6
parent1a89be1e46016afa977aa74cb6eb67920f79e5f7 (diff)
downloademacs-d49b7f88eb5f1597098fe863df8c98dcec5771e0.tar.gz
emacs-d49b7f88eb5f1597098fe863df8c98dcec5771e0.zip
Use `push' and replace `regi-pos' by equivalents.
(sc-emacs-features): Remove. Use better tests instead. (sc-minor-mode): Use define-minor-mode. (sc-mode-string, sc-set-mode-string): Remove. Use a better modeline expression instead. (sc-completing-read, sc-read-string, sc-submatch, sc-member) (sc-string-text): Remove those compatibility functions.
-rw-r--r--lisp/mail/supercite.el431
1 files changed, 154 insertions, 277 deletions
diff --git a/lisp/mail/supercite.el b/lisp/mail/supercite.el
index d9d1e01fae7..558b9f9e388 100644
--- a/lisp/mail/supercite.el
+++ b/lisp/mail/supercite.el
@@ -1,6 +1,6 @@
1;;; supercite.el --- minor mode for citing mail and news replies 1;;; supercite.el --- minor mode for citing mail and news replies
2 2
3;; Copyright (C) 1993, 1997 Free Software Foundation, Inc. 3;; Copyright (C) 1993, 1997, 2003 Free Software Foundation, Inc.
4 4
5;; Author: 1993 Barry A. Warsaw, Century Computing, Inc. <bwarsaw@cen.com> 5;; Author: 1993 Barry A. Warsaw, Century Computing, Inc. <bwarsaw@cen.com>
6;; Maintainer: FSF 6;; Maintainer: FSF
@@ -510,39 +510,15 @@ string."
510(defvar sc-attributions nil 510(defvar sc-attributions nil
511 "Alist of attributions for use when citing.") 511 "Alist of attributions for use when citing.")
512 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.
524Known flavors are:
525
526Emacs 18 : (v18 GNU)
527Emacs 19 or later : (v19 GNU)
528Lucid 19 or later : (v19 Lucid)")
529
530
531(defvar sc-tmp-nested-regexp nil 513(defvar sc-tmp-nested-regexp nil
532 "Temporary regepx describing nested citations.") 514 "Temporary regexp describing nested citations.")
533(defvar sc-tmp-nonnested-regexp nil 515(defvar sc-tmp-nonnested-regexp nil
534 "Temporary regexp describing non-nested citations.") 516 "Temporary regexp describing non-nested citations.")
535(defvar sc-tmp-dumb-regexp nil 517(defvar sc-tmp-dumb-regexp nil
536 "Temp regexp describing non-nested citation cited with a nesting citer.") 518 "Temp regexp describing non-nested citation cited with a nesting citer.")
537 519
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) 520(make-variable-buffer-local 'sc-mail-info)
544(make-variable-buffer-local 'sc-attributions) 521(make-variable-buffer-local 'sc-attributions)
545(make-variable-buffer-local 'sc-minor-mode)
546 522
547 523
548;; ====================================================================== 524;; ======================================================================
@@ -552,140 +528,82 @@ Lucid 19 or later : (v19 Lucid)")
552 "*Key binding to install Supercite keymap. 528 "*Key binding to install Supercite keymap.
553If this is nil, Supercite keymap is not installed.") 529If this is nil, Supercite keymap is not installed.")
554 530
555(defvar sc-T-keymap () 531(defvar sc-T-keymap
532 (let ((map (make-sparse-keymap)))
533 (define-key map "a" 'sc-S-preferred-attribution-list)
534 (define-key map "b" 'sc-T-mail-nuke-blank-lines)
535 (define-key map "c" 'sc-T-confirm-always)
536 (define-key map "d" 'sc-T-downcase)
537 (define-key map "e" 'sc-T-electric-references)
538 (define-key map "f" 'sc-T-auto-fill-region)
539 (define-key map "h" 'sc-T-describe)
540 (define-key map "l" 'sc-S-cite-region-limit)
541 (define-key map "n" 'sc-S-mail-nuke-mail-headers)
542 (define-key map "N" 'sc-S-mail-header-nuke-list)
543 (define-key map "o" 'sc-T-electric-circular)
544 (define-key map "p" 'sc-S-preferred-header-style)
545 (define-key map "s" 'sc-T-nested-citation)
546 (define-key map "u" 'sc-T-use-only-preferences)
547 (define-key map "w" 'sc-T-fixup-whitespace)
548 (define-key map "?" 'sc-T-describe)
549 map)
556 "Keymap for sub-keymap of setting and toggling functions.") 550 "Keymap for sub-keymap of setting and toggling functions.")
557(if sc-T-keymap 551
558 () 552(defvar sc-mode-map
559 (setq sc-T-keymap (make-sparse-keymap)) 553 (let ((map (make-sparse-keymap)))
560 (define-key sc-T-keymap "a" 'sc-S-preferred-attribution-list) 554 (define-key map "c" 'sc-cite-region)
561 (define-key sc-T-keymap "b" 'sc-T-mail-nuke-blank-lines) 555 (define-key map "f" 'sc-mail-field-query)
562 (define-key sc-T-keymap "c" 'sc-T-confirm-always) 556 (define-key map "g" 'sc-mail-process-headers)
563 (define-key sc-T-keymap "d" 'sc-T-downcase) 557 (define-key map "h" 'sc-describe)
564 (define-key sc-T-keymap "e" 'sc-T-electric-references) 558 (define-key map "i" 'sc-insert-citation)
565 (define-key sc-T-keymap "f" 'sc-T-auto-fill-region) 559 (define-key map "o" 'sc-open-line)
566 (define-key sc-T-keymap "h" 'sc-T-describe) 560 (define-key map "r" 'sc-recite-region)
567 (define-key sc-T-keymap "l" 'sc-S-cite-region-limit) 561 (define-key map "\C-p" 'sc-raw-mode-toggle)
568 (define-key sc-T-keymap "n" 'sc-S-mail-nuke-mail-headers) 562 (define-key map "u" 'sc-uncite-region)
569 (define-key sc-T-keymap "N" 'sc-S-mail-header-nuke-list) 563 (define-key map "v" 'sc-version)
570 (define-key sc-T-keymap "o" 'sc-T-electric-circular) 564 (define-key map "w" 'sc-insert-reference)
571 (define-key sc-T-keymap "p" 'sc-S-preferred-header-style) 565 (define-key map "\C-t" sc-T-keymap)
572 (define-key sc-T-keymap "s" 'sc-T-nested-citation) 566 (define-key map "\C-b" 'sc-submit-bug-report)
573 (define-key sc-T-keymap "u" 'sc-T-use-only-preferences) 567 (define-key map "?" 'sc-describe)
574 (define-key sc-T-keymap "w" 'sc-T-fixup-whitespace) 568 map)
575 (define-key sc-T-keymap "?" 'sc-T-describe)
576 )
577
578(defvar sc-mode-map ()
579 "Keymap for Supercite quasi-mode.") 569 "Keymap for Supercite quasi-mode.")
580(if sc-mode-map 570
581 () 571(defvar sc-electric-mode-map
582 (setq sc-mode-map (make-sparse-keymap)) 572 (let ((map (make-sparse-keymap)))
583 (define-key sc-mode-map "c" 'sc-cite-region) 573 (define-key map "p" 'sc-eref-prev)
584 (define-key sc-mode-map "f" 'sc-mail-field-query) 574 (define-key map "n" 'sc-eref-next)
585 (define-key sc-mode-map "g" 'sc-mail-process-headers) 575 (define-key map "s" 'sc-eref-setn)
586 (define-key sc-mode-map "h" 'sc-describe) 576 (define-key map "j" 'sc-eref-jump)
587 (define-key sc-mode-map "i" 'sc-insert-citation) 577 (define-key map "x" 'sc-eref-abort)
588 (define-key sc-mode-map "o" 'sc-open-line) 578 (define-key map "q" 'sc-eref-abort)
589 (define-key sc-mode-map "r" 'sc-recite-region) 579 (define-key map "\r" 'sc-eref-exit)
590 (define-key sc-mode-map "\C-p" 'sc-raw-mode-toggle) 580 (define-key map "\n" 'sc-eref-exit)
591 (define-key sc-mode-map "u" 'sc-uncite-region) 581 (define-key map "g" 'sc-eref-goto)
592 (define-key sc-mode-map "v" 'sc-version) 582 (define-key map "?" 'describe-mode)
593 (define-key sc-mode-map "w" 'sc-insert-reference) 583 (define-key map "\C-h" 'describe-mode)
594 (define-key sc-mode-map "\C-t" sc-T-keymap) 584 (define-key map [f1] 'describe-mode)
595 (define-key sc-mode-map "\C-b" 'sc-submit-bug-report) 585 (define-key map [help] 'describe-mode)
596 (define-key sc-mode-map "?" 'sc-describe) 586 map)
597 )
598
599(defvar sc-electric-mode-map ()
600 "Keymap for `sc-electric-mode' electric references mode.") 587 "Keymap for `sc-electric-mode' electric references mode.")
601(if sc-electric-mode-map 588
602 nil 589
603 (setq sc-electric-mode-map (make-sparse-keymap)) 590(defvar sc-minibuffer-local-completion-map
604 (define-key sc-electric-mode-map "p" 'sc-eref-prev) 591 (let ((map (copy-keymap minibuffer-local-completion-map)))
605 (define-key sc-electric-mode-map "n" 'sc-eref-next) 592 (define-key map "\C-t" 'sc-toggle-fn)
606 (define-key sc-electric-mode-map "s" 'sc-eref-setn) 593 (define-key map " " 'self-insert-command)
607 (define-key sc-electric-mode-map "j" 'sc-eref-jump) 594 map)
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.") 595 "Keymap for minibuffer confirmation of attribution strings.")
621(if sc-minibuffer-local-completion-map 596
622 () 597(defvar sc-minibuffer-local-map
623 (setq sc-minibuffer-local-completion-map 598 (let ((map (copy-keymap minibuffer-local-map)))
624 (copy-keymap minibuffer-local-completion-map)) 599 (define-key map "\C-t" 'sc-toggle-fn)
625 (define-key sc-minibuffer-local-completion-map "\C-t" 'sc-toggle-fn) 600 map)
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.") 601 "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 602
635 603
636;; ====================================================================== 604;; ======================================================================
637;; utility functions 605;; utility functions
638 606
639(defun sc-completing-read (prompt table &optional predicate require-match
640 initial-contents history)
641 "Compatibility between Emacs 18 and 19 `completing-read'.
642In 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'.
652In 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.
661If optional STRING is provided, take sub-expression using `substring'
662of argument, otherwise use `buffer-substring' on current buffer. Note
663that `match-data' must have already been generated and no error
664checking 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'.
673Emacs19 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) 607(defun sc-ask (alist)
690 "Ask a question in the minibuffer requiring a single character answer. 608 "Ask a question in the minibuffer requiring a single character answer.
691This function is kind of an extension of `y-or-n-p' where a single 609This function is kind of an extension of `y-or-n-p' where a single
@@ -704,30 +622,23 @@ the list should be unique."
704 ") ")) 622 ") "))
705 (p prompt) 623 (p prompt)
706 (event 624 (event
707 (if (memq 'Lucid sc-emacs-features) 625 (if (fboundp 'allocate-event)
708 (allocate-event) 626 (allocate-event)
709 nil))) 627 nil)))
710 (while (stringp p) 628 (while (stringp p)
711 (if (let ((cursor-in-echo-area t) 629 (if (let ((cursor-in-echo-area t)
712 (inhibit-quit t)) 630 (inhibit-quit t))
713 (message "%s" p) 631 (message "%s" p)
714 ;; lets be good neighbors and be compatible with all emacsen 632 (setq event (read-event))
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))) 633 (prog1 quit-flag (setq quit-flag nil)))
723 (progn 634 (progn
724 (message "%s%s" p (single-key-description event)) 635 (message "%s%s" p (single-key-description event))
725 (and (memq 'Lucid sc-emacs-features) 636 (and (fboundp 'deallocate-event)
726 (deallocate-event event)) 637 (deallocate-event event))
727 (setq quit-flag nil) 638 (setq quit-flag nil)
728 (signal 'quit '()))) 639 (signal 'quit '())))
729 (let ((char 640 (let ((char
730 (if (memq 'Lucid sc-emacs-features) 641 (if (featurep 'xemacs)
731 (let* ((key (and (key-press-event-p event) (event-key event))) 642 (let* ((key (and (key-press-event-p event) (event-key event)))
732 (char (and key (event-to-character event)))) 643 (char (and key (event-to-character event))))
733 char) 644 char)
@@ -738,18 +649,18 @@ the list should be unique."
738 ((setq elt (rassq char alist)) 649 ((setq elt (rassq char alist))
739 (message "%s%s" p (car elt)) 650 (message "%s%s" p (car elt))
740 (setq p (cdr elt))) 651 (setq p (cdr elt)))
741 ((and (memq 'Lucid sc-emacs-features) 652 ((and (fboundp 'button-release-event-p)
742 (button-release-event-p event)) ; ignore them 653 (button-release-event-p event)) ; ignore them
743 nil) 654 nil)
744 (t 655 (t
745 (message "%s%s" p (single-key-description event)) 656 (message "%s%s" p (single-key-description event))
746 (if (memq 'Lucid sc-emacs-features) 657 (if (featurep 'xemacs)
747 (ding nil 'y-or-n-p) 658 (ding nil 'y-or-n-p)
748 (ding)) 659 (ding))
749 (discard-input) 660 (discard-input)
750 (if (eq p prompt) 661 (if (eq p prompt)
751 (setq p (concat "Try again. " prompt))))))) 662 (setq p (concat "Try again. " prompt)))))))
752 (and (memq 'Lucid sc-emacs-features) 663 (and (fboundp 'deallocate-event)
753 (deallocate-event event)) 664 (deallocate-event event))
754 p)) 665 p))
755 666
@@ -801,7 +712,7 @@ the list should be unique."
801 (end (setq sc-mail-headers-end (point)))) 712 (end (setq sc-mail-headers-end (point))))
802 "Regi frame for glomming mail header information.") 713 "Regi frame for glomming mail header information.")
803 714
804(eval-when-compile (defvar curline)) ; dynamic bondage 715(defvar curline) ; dynamic bondage
805 716
806;; regi functions 717;; regi functions
807(defun sc-mail-fetch-field (&optional attribs-p) 718(defun sc-mail-fetch-field (&optional attribs-p)
@@ -809,13 +720,12 @@ the list should be unique."
809If optional ATTRIBS-P is non-nil, the key/value pair is placed in 720If optional ATTRIBS-P is non-nil, the key/value pair is placed in
810`sc-attributions' too." 721`sc-attributions' too."
811 (if (string-match "^\\(\\S *\\)\\s *:\\s +\\(.*\\)$" curline) 722 (if (string-match "^\\(\\S *\\)\\s *:\\s +\\(.*\\)$" curline)
812 (let* ((key (downcase (sc-string-text (sc-submatch 1 curline)))) 723 (let* ((key (downcase (match-string-no-properties 1 curline)))
813 (val (sc-string-text (sc-submatch 2 curline))) 724 (val (match-string-no-properties 2 curline))
814 (keyval (cons key val))) 725 (keyval (cons key val)))
815 (setq sc-mail-info (cons keyval sc-mail-info)) 726 (push keyval sc-mail-info)
816 (if attribs-p 727 (if attribs-p
817 (setq sc-attributions (cons keyval sc-attributions))) 728 (push keyval sc-attributions))))
818 ))
819 nil) 729 nil)
820 730
821(defun sc-mail-append-field () 731(defun sc-mail-append-field ()
@@ -823,7 +733,7 @@ If optional ATTRIBS-P is non-nil, the key/value pair is placed in
823 (let ((keyval (car sc-mail-info))) 733 (let ((keyval (car sc-mail-info)))
824 (if (and keyval (string-match "^\\s *\\(.*\\)$" curline)) 734 (if (and keyval (string-match "^\\s *\\(.*\\)$" curline))
825 (setcdr keyval (concat (cdr keyval) " " 735 (setcdr keyval (concat (cdr keyval) " "
826 (sc-string-text (sc-submatch 1 curline)))))) 736 (match-string-no-properties 1 curline)))))
827 nil) 737 nil)
828 738
829(defun sc-mail-error-in-mail-field () 739(defun sc-mail-error-in-mail-field ()
@@ -842,7 +752,7 @@ If optional ATTRIBS-P is non-nil, the key/value pair is placed in
842 752
843(defun sc-mail-nuke-line () 753(defun sc-mail-nuke-line ()
844 "Nuke the current mail header line." 754 "Nuke the current mail header line."
845 (delete-region (regi-pos 'bol) (regi-pos 'bonl)) 755 (delete-region (line-beginning-position) (line-beginning-position 2))
846 '((step . -1))) 756 '((step . -1)))
847 757
848(defun sc-mail-nuke-header-line () 758(defun sc-mail-nuke-header-line ()
@@ -866,7 +776,8 @@ The number of lines left is specified by `sc-blank-lines-after-headers'."
866 (delete-blank-lines) 776 (delete-blank-lines)
867 (beginning-of-line) 777 (beginning-of-line)
868 (if (looking-at "[ \t]*$") 778 (if (looking-at "[ \t]*$")
869 (delete-region (regi-pos 'bol) (regi-pos 'bonl))) 779 (delete-region (line-beginning-position)
780 (line-beginning-position 2)))
870 (insert-char ?\n sc-blank-lines-after-headers))) 781 (insert-char ?\n sc-blank-lines-after-headers)))
871 nil) 782 nil)
872 783
@@ -938,7 +849,7 @@ Action can be one of: View, Modify, Add, or Delete."
938 key) 849 key)
939 (if (not action) 850 (if (not action)
940 () 851 ()
941 (setq key (sc-completing-read 852 (setq key (completing-read
942 (concat (car (rassq action alist)) 853 (concat (car (rassq action alist))
943 " information key: ") 854 " information key: ")
944 sc-mail-info nil 855 sc-mail-info nil
@@ -952,17 +863,15 @@ Action can be one of: View, Modify, Add, or Delete."
952 ((eq action ?m) 863 ((eq action ?m)
953 (let ((keyval (assoc key sc-mail-info))) 864 (let ((keyval (assoc key sc-mail-info)))
954 ;; first put initial value onto list if not already there 865 ;; first put initial value onto list if not already there
955 (if (not (sc-member (cdr keyval) 866 (if (not (member (cdr keyval)
956 sc-mail-field-modification-history)) 867 sc-mail-field-modification-history))
957 (setq sc-mail-field-modification-history 868 (setq sc-mail-field-modification-history
958 (cons (cdr keyval) sc-mail-field-modification-history))) 869 (cons (cdr keyval) sc-mail-field-modification-history)))
959 (setcdr keyval (sc-read-string 870 (setcdr keyval (read-string
960 (concat key ": ") (cdr keyval) 871 (concat key ": ") (cdr keyval)
961 'sc-mail-field-modification-history)))) 872 'sc-mail-field-modification-history))))
962 ((eq action ?a) 873 ((eq action ?a)
963 (setq sc-mail-info 874 (push (cons key (read-string (concat key ": "))) sc-mail-info))
964 (cons (cons key
965 (sc-read-string (concat key ": "))) sc-mail-info)))
966 )))) 875 ))))
967 876
968 877
@@ -980,7 +889,7 @@ Match addresses of the style ``name%[stuff].'' when called with DELIM
980of \"%\" and addresses of the style ``[stuff]name@[stuff]'' when 889of \"%\" and addresses of the style ``[stuff]name@[stuff]'' when
981called with DELIM \"@\". If DELIM is nil or not provided, matches 890called with DELIM \"@\". If DELIM is nil or not provided, matches
982addresses of the style ``name''." 891addresses of the style ``name''."
983 (and (string-match (concat "[-a-zA-Z0-9_.]+" delim) from 0) 892 (and (string-match (concat "[-[:alnum:]_.]+" delim) from 0)
984 (substring from 893 (substring from
985 (match-beginning 0) 894 (match-beginning 0)
986 (- (match-end 0) (if (null delim) 0 1))))) 895 (- (match-end 0) (if (null delim) 0 1)))))
@@ -989,7 +898,7 @@ addresses of the style ``name''."
989 "Extract the author's email terminus from email address FROM. 898 "Extract the author's email terminus from email address FROM.
990Match addresses of the style ``[stuff]![stuff]...!name[stuff].''" 899Match addresses of the style ``[stuff]![stuff]...!name[stuff].''"
991 (let ((eos (length from)) 900 (let ((eos (length from))
992 (mstart (string-match "![-a-zA-Z0-9_.]+\\([^-!a-zA-Z0-9_.]\\|$\\)" 901 (mstart (string-match "![-[:alnum:]_.]+\\([^-![:alnum:]_.]\\|$\\)"
993 from 0)) 902 from 0))
994 (mend (match-end 0))) 903 (mend (match-end 0)))
995 (and mstart 904 (and mstart
@@ -1000,7 +909,7 @@ Match addresses of the style ``[stuff]![stuff]...!name[stuff].''"
1000 "Extract the author's email terminus from email address FROM. 909 "Extract the author's email terminus from email address FROM.
1001Match addresses of the style ``<name[stuff]>.''" 910Match addresses of the style ``<name[stuff]>.''"
1002 (and (string-match "<\\(.*\\)>" from) 911 (and (string-match "<\\(.*\\)>" from)
1003 (sc-submatch 1 from))) 912 (match-string 1 from)))
1004 913
1005(defun sc-get-address (from author) 914(defun sc-get-address (from author)
1006 "Get the full email address path from FROM. 915 "Get the full email address path from FROM.
@@ -1014,7 +923,7 @@ AUTHOR is the author's name (which is removed from the address)."
1014 (substring address 1 (1- (length address))) 923 (substring address 1 (1- (length address)))
1015 address)) 924 address))
1016 (if (string-match "[-[:alnum:]!@%._]+" from 0) 925 (if (string-match "[-[:alnum:]!@%._]+" from 0)
1017 (sc-submatch 0 from) 926 (match-string 0 from)
1018 "") 927 "")
1019 ))) 928 )))
1020 929
@@ -1042,6 +951,7 @@ substring."
1042(defun sc-attribs-extract-namestring (from) 951(defun sc-attribs-extract-namestring (from)
1043 "Extract the name string from FROM. 952 "Extract the name string from FROM.
1044This should be the author's full name minus an optional title." 953This should be the author's full name minus an optional title."
954 ;; FIXME: we probably should use mail-extract-address-components.
1045 (let ((namestring 955 (let ((namestring
1046 (or 956 (or
1047 ;; If there is a <...> in the name, 957 ;; If there is a <...> in the name,
@@ -1077,10 +987,10 @@ This should be the author's full name minus an optional title."
1077 987
1078(defun sc-attribs-chop-namestring (namestring) 988(defun sc-attribs-chop-namestring (namestring)
1079 "Convert NAMESTRING to a list of names. 989 "Convert NAMESTRING to a list of names.
1080example: (sc-namestring-to-list \"John Xavier Doe\") 990example: (sc-attribs-chop-namestring \"John Xavier Doe\")
1081 => (\"John\" \"Xavier\" \"Doe\")" 991 => (\"John\" \"Xavier\" \"Doe\")"
1082 (if (string-match "\\([ \t]*\\)\\([^ \t._]+\\)\\([ \t]*\\)" namestring) 992 (if (string-match "\\([ \t]*\\)\\([^ \t._]+\\)\\([ \t]*\\)" namestring)
1083 (cons (sc-submatch 2 namestring) 993 (cons (match-string 2 namestring)
1084 (sc-attribs-chop-namestring (substring namestring (match-end 3))) 994 (sc-attribs-chop-namestring (substring namestring (match-end 3)))
1085 ))) 995 )))
1086 996
@@ -1098,13 +1008,14 @@ example: (sc-namestring-to-list \"John Xavier Doe\")
1098If attribution cannot be guessed, nil is returned. Optional STRING if 1008If attribution cannot be guessed, nil is returned. Optional STRING if
1099supplied, is used instead of the line point is on in the current buffer." 1009supplied, is used instead of the line point is on in the current buffer."
1100 (let ((start 0) 1010 (let ((start 0)
1101 (string (or string (buffer-substring (regi-pos 'bol) (regi-pos 'eol)))) 1011 (string (or string (buffer-substring (line-beginning-position)
1012 (line-end-position))))
1102 attribution) 1013 attribution)
1103 (and 1014 (and
1104 (= start (or (string-match sc-citation-leader-regexp string start) -1)) 1015 (= start (or (string-match sc-citation-leader-regexp string start) -1))
1105 (setq start (match-end 0)) 1016 (setq start (match-end 0))
1106 (= start (or (string-match sc-citation-root-regexp string start) 1)) 1017 (= start (or (string-match sc-citation-root-regexp string start) 1))
1107 (setq attribution (sc-submatch 0 string) 1018 (setq attribution (match-string 0 string)
1108 start (match-end 0)) 1019 start (match-end 0))
1109 (= start (or (string-match sc-citation-delimiter-regexp string start) -1)) 1020 (= start (or (string-match sc-citation-delimiter-regexp string start) -1))
1110 (setq start (match-end 0)) 1021 (setq start (match-end 0))
@@ -1173,12 +1084,9 @@ This populates the `sc-attributions' with the list of possible attributions."
1173 (lambda (midname) 1084 (lambda (midname)
1174 (let ((key-attribs (format "middlename-%d" n)) 1085 (let ((key-attribs (format "middlename-%d" n))
1175 (key-mail (format "sc-middlename-%d" n))) 1086 (key-mail (format "sc-middlename-%d" n)))
1176 (setq 1087 (push (cons key-attribs midname) sc-attributions)
1177 sc-attributions (cons (cons key-attribs midname) 1088 (push (cons key-mail midname) sc-mail-info)
1178 sc-attributions) 1089 (setq n (1+ n))
1179 sc-mail-info (cons (cons key-mail midname)
1180 sc-mail-info)
1181 n (1+ n))
1182 midname))) 1090 midname)))
1183 midnames " ") 1091 midnames " ")
1184 1092
@@ -1212,8 +1120,7 @@ This populates the `sc-attributions' with the list of possible attributions."
1212 sc-mail-info) 1120 sc-mail-info)
1213 )) 1121 ))
1214 ;; from string is empty 1122 ;; from string is empty
1215 (setq sc-mail-info (cons (cons "sc-author" sc-default-author-name) 1123 (push (cons "sc-author" sc-default-author-name) sc-mail-info)))
1216 sc-mail-info))))
1217 1124
1218(defvar sc-attrib-or-cite nil 1125(defvar sc-attrib-or-cite nil
1219 "Used to toggle between attribution input or citation input.") 1126 "Used to toggle between attribution input or citation input.")
@@ -1325,11 +1232,11 @@ to the auto-selected attribution string."
1325 (progn 1232 (progn
1326 (setq choice 1233 (setq choice
1327 (if sc-attrib-or-cite 1234 (if sc-attrib-or-cite
1328 (sc-read-string 1235 (read-string
1329 "Enter citation prefix: " 1236 "Enter citation prefix: "
1330 citation 1237 citation
1331 'sc-citation-confirmation-history) 1238 'sc-citation-confirmation-history)
1332 (sc-completing-read 1239 (completing-read
1333 "Complete attribution name: " 1240 "Complete attribution name: "
1334 query-alist nil nil 1241 query-alist nil nil
1335 (cons initial 0) 1242 (cons initial 0)
@@ -1360,20 +1267,17 @@ to the auto-selected attribution string."
1360 (akeyval (assoc akey sc-mail-info))) 1267 (akeyval (assoc akey sc-mail-info)))
1361 (if ckeyval 1268 (if ckeyval
1362 (setcdr ckeyval citation) 1269 (setcdr ckeyval citation)
1363 (setq sc-mail-info 1270 (push (cons ckey citation) sc-mail-info))
1364 (append (list (cons ckey citation)) sc-mail-info)))
1365 (if akeyval 1271 (if akeyval
1366 (setcdr akeyval attribution) 1272 (setcdr akeyval attribution)
1367 (setq sc-mail-info 1273 (push (cons akey attribution) sc-mail-info)))
1368 (append (list (cons akey attribution)) sc-mail-info))))
1369 1274
1370 ;; set the sc-lastchoice attribution 1275 ;; set the sc-lastchoice attribution
1371 (let* ((lkey "sc-lastchoice") 1276 (let* ((lkey "sc-lastchoice")
1372 (lastchoice (assoc lkey sc-attributions))) 1277 (lastchoice (assoc lkey sc-attributions)))
1373 (if lastchoice 1278 (if lastchoice
1374 (setcdr lastchoice attribution) 1279 (setcdr lastchoice attribution)
1375 (setq sc-attributions 1280 (push (cons lkey attribution) sc-attributions)))
1376 (cons (cons lkey attribution) sc-attributions))))
1377 )) 1281 ))
1378 1282
1379 1283
@@ -1426,14 +1330,14 @@ not supplied, initialize fill variables. This is useful for a regi
1426`begin' frame-entry." 1330`begin' frame-entry."
1427 (if (not prefix) 1331 (if (not prefix)
1428 (setq sc-fill-line-prefix "" 1332 (setq sc-fill-line-prefix ""
1429 sc-fill-begin (regi-pos 'bol)) 1333 sc-fill-begin (line-beginning-position))
1430 (if (and sc-auto-fill-region-p 1334 (if (and sc-auto-fill-region-p
1431 (not (string= prefix sc-fill-line-prefix))) 1335 (not (string= prefix sc-fill-line-prefix)))
1432 (let ((fill-prefix sc-fill-line-prefix)) 1336 (let ((fill-prefix sc-fill-line-prefix))
1433 (if (not (string= fill-prefix "")) 1337 (if (not (string= fill-prefix ""))
1434 (fill-region sc-fill-begin (regi-pos 'bol))) 1338 (fill-region sc-fill-begin (line-beginning-position)))
1435 (setq sc-fill-line-prefix prefix 1339 (setq sc-fill-line-prefix prefix
1436 sc-fill-begin (regi-pos 'bol)))) 1340 sc-fill-begin (line-beginning-position))))
1437 ) 1341 )
1438 nil) 1342 nil)
1439 1343
@@ -1467,13 +1371,14 @@ If nesting cannot be guessed, nil is returned. Optional STRING if
1467supplied, is used instead of the line point is on in the current 1371supplied, is used instead of the line point is on in the current
1468buffer." 1372buffer."
1469 (let ((start 0) 1373 (let ((start 0)
1470 (string (or string (buffer-substring (regi-pos 'bol) (regi-pos 'eol)))) 1374 (string (or string (buffer-substring (line-beginning-position)
1375 (line-end-position))))
1471 nesting) 1376 nesting)
1472 (and 1377 (and
1473 (= start (or (string-match sc-citation-leader-regexp string start) -1)) 1378 (= start (or (string-match sc-citation-leader-regexp string start) -1))
1474 (setq start (match-end 0)) 1379 (setq start (match-end 0))
1475 (= start (or (string-match sc-citation-delimiter-regexp string start) -1)) 1380 (= start (or (string-match sc-citation-delimiter-regexp string start) -1))
1476 (setq nesting (sc-submatch 0 string) 1381 (setq nesting (match-string 0 string)
1477 start (match-end 0)) 1382 start (match-end 0))
1478 (= start (or (string-match sc-citation-separator-regexp string start) -1)) 1383 (= start (or (string-match sc-citation-separator-regexp string start) -1))
1479 nesting))) 1384 nesting)))
@@ -1863,7 +1768,6 @@ entered, regardless of the value of `sc-electric-references-p'. See
1863 (interactive) 1768 (interactive)
1864 (setq sc-fixup-whitespace-p (not sc-fixup-whitespace-p) 1769 (setq sc-fixup-whitespace-p (not sc-fixup-whitespace-p)
1865 sc-auto-fill-region-p (not sc-auto-fill-region-p)) 1770 sc-auto-fill-region-p (not sc-auto-fill-region-p))
1866 (sc-set-mode-string)
1867 (force-mode-line-update)) 1771 (force-mode-line-update))
1868 1772
1869(defun sc-toggle-var (variable) 1773(defun sc-toggle-var (variable)
@@ -1872,8 +1776,7 @@ VARIABLE must be a bound symbol. nil values change to t, non-nil
1872values are changed to nil." 1776values are changed to nil."
1873 (message "%s changed from %s to %s" 1777 (message "%s changed from %s to %s"
1874 variable (symbol-value variable) 1778 variable (symbol-value variable)
1875 (set variable (not (symbol-value variable)))) 1779 (set variable (not (symbol-value variable)))))
1876 (sc-set-mode-string))
1877 1780
1878(defun sc-set-variable (var) 1781(defun sc-set-variable (var)
1879 "Set the Supercite VARIABLE. 1782 "Set the Supercite VARIABLE.
@@ -1886,41 +1789,35 @@ querying you by typing `C-h'. Note that the format is changed
1886slightly from that used by `set-variable' -- the current value is 1789slightly from that used by `set-variable' -- the current value is
1887printed just after the variable's name instead of at the bottom of the 1790printed just after the variable's name instead of at the bottom of the
1888help window." 1791help window."
1889 (let* ((minibuffer-help-form 1792 (let* ((minibuffer-help-form '(funcall myhelp))
1890 '(funcall myhelp))
1891 (myhelp 1793 (myhelp
1892 (function 1794 (lambda ()
1893 (lambda () 1795 (with-output-to-temp-buffer "*Help*"
1894 (with-output-to-temp-buffer "*Help*" 1796 (prin1 var)
1895 (prin1 var) 1797 (if (boundp var)
1896 (if (boundp var) 1798 (let ((print-length 20))
1897 (let ((print-length 20)) 1799 (princ "\t(Current value: ")
1898 (princ "\t(Current value: ") 1800 (prin1 (symbol-value var))
1899 (prin1 (symbol-value var)) 1801 (princ ")")))
1900 (princ ")"))) 1802 (princ "\n\nDocumentation:\n")
1901 (princ "\n\nDocumentation:\n") 1803 (princ (substring (documentation-property
1902 (princ (substring (documentation-property 1804 var
1903 var 1805 'variable-documentation)
1904 'variable-documentation) 1806 1))
1905 1)) 1807 (with-current-buffer standard-output
1906 (save-excursion 1808 (help-mode))
1907 (set-buffer standard-output) 1809 nil))))
1908 (help-mode)) 1810 (set var (eval-minibuffer (format "Set %s to value: " var)))))
1909 nil)))))
1910 (set var (eval-minibuffer (format "Set %s to value: " var))))
1911 (sc-set-mode-string))
1912 1811
1913(defmacro sc-toggle-symbol (rootname) 1812(defmacro sc-toggle-symbol (rootname)
1914 (list 'defun (intern (concat "sc-T-" rootname)) '() 1813 `(defun ,(intern (concat "sc-T-" rootname)) ()
1915 (list 'interactive) 1814 (interactive)
1916 (list 'sc-toggle-var 1815 (sc-toggle-var ',(intern (concat "sc-" rootname "-p")))))
1917 (list 'quote (intern (concat "sc-" rootname "-p"))))))
1918 1816
1919(defmacro sc-setvar-symbol (rootname) 1817(defmacro sc-setvar-symbol (rootname)
1920 (list 'defun (intern (concat "sc-S-" rootname)) '() 1818 `(defun ,(intern (concat "sc-S-" rootname)) ()
1921 (list 'interactive) 1819 (interactive)
1922 (list 'sc-set-variable 1820 (sc-set-variable ',(intern (concat "sc-" rootname)))))
1923 (list 'quote (intern (concat "sc-" rootname))))))
1924 1821
1925(sc-toggle-symbol "confirm-always") 1822(sc-toggle-symbol "confirm-always")
1926(sc-toggle-symbol "downcase") 1823(sc-toggle-symbol "downcase")
@@ -1953,27 +1850,24 @@ Note on function names in this list: all functions of the form
1953 (interactive) 1850 (interactive)
1954 (describe-function 'sc-T-describe)) 1851 (describe-function 'sc-T-describe))
1955 1852
1956(defun sc-set-mode-string ()
1957 "Update the minor mode string to show state of Supercite."
1958 (setq sc-mode-string
1959 (concat " SC"
1960 (if (or sc-auto-fill-region-p
1961 sc-fixup-whitespace-p)
1962 ":" "")
1963 (if sc-auto-fill-region-p "f" "")
1964 (if sc-fixup-whitespace-p "w" "")
1965 )))
1966
1967 1853
1968;; ====================================================================== 1854;; ======================================================================
1969;; published interface to mail and news readers 1855;; published interface to mail and news readers
1970 1856
1857(define-minor-mode sc-minor-mode
1858 "Supercite minor mode."
1859 nil (" SC" (sc-auto-fill-region-p
1860 (":f" (sc-fixup-whitespace-p "w"))
1861 (sc-fixup-whitespace-p ":w")))
1862 `((,sc-mode-map-prefix . ,sc-mode-map)))
1863
1971;;;###autoload 1864;;;###autoload
1972(defun sc-cite-original () 1865(defun sc-cite-original ()
1973 "Workhorse citing function which performs the initial citation. 1866 "Workhorse citing function which performs the initial citation.
1974This is callable from the various mail and news readers' reply 1867This is callable from the various mail and news readers' reply
1975function according to the agreed upon standard. See `\\[sc-describe]' 1868function according to the agreed upon standard. See the associated
1976for more details. `sc-cite-original' does not do any yanking of the 1869info node `(SC)Top' for more details.
1870`sc-cite-original' does not do any yanking of the
1977original message but it does require a few things: 1871original message but it does require a few things:
1978 1872
1979 1) The reply buffer is the current buffer. 1873 1) The reply buffer is the current buffer.
@@ -1994,29 +1888,14 @@ when this function is called. Also, the hook `sc-pre-hook' is run
1994before, and `sc-post-hook' is run after the guts of this function." 1888before, and `sc-post-hook' is run after the guts of this function."
1995 (run-hooks 'sc-pre-hook) 1889 (run-hooks 'sc-pre-hook)
1996 1890
1997 ;; before we do anything, we want to insert the supercite keymap so 1891 (sc-minor-mode 1)
1998 ;; we can proceed from here
1999 (and sc-mode-map-prefix
2000 (local-set-key sc-mode-map-prefix sc-mode-map))
2001
2002 ;; hack onto the minor mode alist, if it hasn't been done before,
2003 ;; then turn on the minor mode. also, set the minor mode string with
2004 ;; the values of fill and fixup whitespace variables
2005 (if (not (get 'minor-mode-alist 'sc-minor-mode))
2006 (progn
2007 (put 'minor-mode-alist 'sc-minor-mode 'sc-minor-mode)
2008 (setq minor-mode-alist
2009 (cons '(sc-minor-mode sc-mode-string) minor-mode-alist))
2010 ))
2011 (setq sc-minor-mode t)
2012 (sc-set-mode-string)
2013 1892
2014 (undo-boundary) 1893 (undo-boundary)
2015 1894
2016 ;; grab point and mark since the region is probably not active when 1895 ;; grab point and mark since the region is probably not active when
2017 ;; this function gets automatically called. we want point to be a 1896 ;; this function gets automatically called. we want point to be a
2018 ;; mark so any deleting before point works properly 1897 ;; mark so any deleting before point works properly
2019 (let* ((zmacs-regions nil) ; for Lemacs 1898 (let* ((zmacs-regions nil) ; for XEemacs
2020 (mark-active t) ; for Emacs 1899 (mark-active t) ; for Emacs
2021 (point (point-marker)) 1900 (point (point-marker))
2022 (mark (copy-marker (mark-marker)))) 1901 (mark (copy-marker (mark-marker))))
@@ -2061,9 +1940,7 @@ before, and `sc-post-hook' is run after the guts of this function."
2061 (set-marker point nil) 1940 (set-marker point nil)
2062 (set-marker mark nil) 1941 (set-marker mark nil)
2063 ) 1942 )
2064 (run-hooks 'sc-post-hook) 1943 (run-hooks 'sc-post-hook))
2065 ;; post hook could have changed the variables
2066 (sc-set-mode-string))
2067 1944
2068 1945
2069;; ====================================================================== 1946;; ======================================================================
@@ -2077,7 +1954,7 @@ With numeric ARG, inserts that many new lines."
2077 (let ((start (point)) 1954 (let ((start (point))
2078 (prefix (or (progn (beginning-of-line) 1955 (prefix (or (progn (beginning-of-line)
2079 (if (looking-at (sc-cite-regexp)) 1956 (if (looking-at (sc-cite-regexp))
2080 (sc-submatch 0))) 1957 (match-string 0)))
2081 ""))) 1958 "")))
2082 (goto-char start) 1959 (goto-char start)
2083 (open-line arg) 1960 (open-line arg)
@@ -2116,7 +1993,7 @@ inserts the version string in the current buffer instead."
2116 " 1993 "
2117Supercite is a package which provides a flexible mechanism for citing 1994Supercite is a package which provides a flexible mechanism for citing
2118email and news replies. Please see the associated texinfo file for 1995email and news replies. Please see the associated texinfo file for
2119more information." 1996more information. Info node `(SC)Top'."
2120 (interactive) 1997 (interactive)
2121 (describe-function 'sc-describe)) 1998 (describe-function 'sc-describe))
2122 1999