Mercurial > hg > xemacs-beta

comparison lisp/vm/vm-summary.el @ 20:859a2309aef8 r19-15b93

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-15b93
author cvs
date Mon, 13 Aug 2007 08:50:05 +0200
parents 376386a54a3c
children 4103f0995bd7
comparison
equal deleted inserted replaced
19:ac1f612d5250 20:859a2309aef8
1 ;;; Summary gathering and formatting routines for VM 1 ;;; Summary gathering and formatting routines for VM
2 ;;; Copyright (C) 1989, 1990, 1993, 1994, 1995 Kyle E. Jones 2 ;;; Copyright (C) 1989-1995 Kyle E. Jones
3 ;;; 3 ;;;
4 ;;; This program is free software; you can redistribute it and/or modify 4 ;;; This program is free software; you can redistribute it and/or modify
5 ;;; it under the terms of the GNU General Public License as published by 5 ;;; it under the terms of the GNU General Public License as published by
6 ;;; the Free Software Foundation; either version 1, or (at your option) 6 ;;; the Free Software Foundation; either version 1, or (at your option)
7 ;;; any later version. 7 ;;; any later version.
20 (defun vm-summary-mode-internal () 20 (defun vm-summary-mode-internal ()
21 (setq mode-name "VM Summary" 21 (setq mode-name "VM Summary"
22 major-mode 'vm-summary-mode 22 major-mode 'vm-summary-mode
23 mode-line-format vm-mode-line-format 23 mode-line-format vm-mode-line-format
24 ;; must come after the setting of major-mode 24 ;; must come after the setting of major-mode
25 mode-popup-menu (and vm-use-menus 25 mode-popup-menu (and vm-use-menus vm-popup-menu-on-mouse-3
26 (vm-menu-support-possible-p) 26 (vm-menu-support-possible-p)
27 (vm-menu-mode-menu)) 27 (vm-menu-mode-menu))
28 buffer-read-only t 28 buffer-read-only t
29 vm-summary-pointer nil 29 vm-summary-pointer nil
30 vm-summary-=> (if (stringp vm-summary-arrow) vm-summary-arrow "") 30 vm-summary-=> (if (stringp vm-summary-arrow) vm-summary-arrow "")
36 scrollbar-height 36 scrollbar-height
37 (set-specifier scrollbar-height (cons (current-buffer) 0))) 37 (set-specifier scrollbar-height (cons (current-buffer) 0)))
38 (use-local-map vm-summary-mode-map) 38 (use-local-map vm-summary-mode-map)
39 (and (vm-menu-support-possible-p) 39 (and (vm-menu-support-possible-p)
40 (vm-menu-install-menus)) 40 (vm-menu-install-menus))
41 (and (vm-mouse-support-possible-p) 41 (and vm-mouse-track-summary
42 (vm-mouse-support-possible-p)
42 (vm-mouse-xemacs-mouse-p) 43 (vm-mouse-xemacs-mouse-p)
43 (add-hook 'mode-motion-hook 'mode-motion-highlight-line)) 44 (add-hook 'mode-motion-hook 'mode-motion-highlight-line))
44 (if (or vm-frame-per-folder vm-frame-per-summary) 45 (if (or vm-frame-per-folder vm-frame-per-summary)
45 (vm-set-hooks-for-frame-deletion)) 46 (vm-set-hooks-for-frame-deletion))
46 (run-hooks 'vm-summary-mode-hook) 47 (run-hooks 'vm-summary-mode-hook)
48 (run-hooks 'vm-summary-mode-hooks)) 49 (run-hooks 'vm-summary-mode-hooks))
49 50
50 (fset 'vm-summary-mode 'vm-mode) 51 (fset 'vm-summary-mode 'vm-mode)
51 (put 'vm-summary-mode 'mode-class 'special) 52 (put 'vm-summary-mode 'mode-class 'special)
52 53
53 (defun vm-summarize (&optional display) 54 (defun vm-summarize (&optional display raise)
54 "Summarize the contents of the folder in a summary buffer. 55 "Summarize the contents of the folder in a summary buffer.
55 The format is as described by the variable vm-summary-format. Generally 56 The format is as described by the variable vm-summary-format. Generally
56 one line per message is most pleasing to the eye but this is not 57 one line per message is most pleasing to the eye but this is not
57 mandatory." 58 mandatory."
58 (interactive "p") 59 (interactive "p\np")
59 (vm-select-folder-buffer) 60 (vm-select-folder-buffer)
60 (vm-check-for-killed-summary) 61 (vm-check-for-killed-summary)
61 (if (null vm-summary-buffer) 62 (if (null vm-summary-buffer)
62 (let ((b (current-buffer)) 63 (let ((b (current-buffer))
63 (read-only vm-folder-read-only)) 64 (read-only vm-folder-read-only))
77 vm-folder-read-only read-only) 78 vm-folder-read-only read-only)
78 (vm-summary-mode-internal)) 79 (vm-summary-mode-internal))
79 (vm-set-summary-redo-start-point t))) 80 (vm-set-summary-redo-start-point t)))
80 (if display 81 (if display
81 (save-excursion 82 (save-excursion
82 (if vm-frame-per-summary 83 (vm-goto-new-summary-frame-maybe)
83 (let ((w (vm-get-buffer-window vm-summary-buffer)))
84 (if (null w)
85 (progn
86 (vm-goto-new-frame 'summary)
87 (vm-set-hooks-for-frame-deletion))
88 (save-excursion
89 (select-window w)
90 (and vm-warp-mouse-to-new-frame
91 (vm-warp-mouse-to-frame-maybe (vm-window-frame w)))))))
92 (vm-display vm-summary-buffer t 84 (vm-display vm-summary-buffer t
93 '(vm-summarize 85 '(vm-summarize
94 vm-summarize-other-frame) 86 vm-summarize-other-frame)
95 (list this-command)) 87 (list this-command) (not raise))
96 ;; need to do this after any frame creation because the 88 ;; need to do this after any frame creation because the
97 ;; toolbar sets frame-specific height and width specifiers. 89 ;; toolbar sets frame-specific height and width specifiers.
98 (set-buffer vm-summary-buffer) 90 (set-buffer vm-summary-buffer)
99 (and (vm-toolbar-support-possible-p) vm-use-toolbar 91 (and (vm-toolbar-support-possible-p) vm-use-toolbar
100 (vm-toolbar-install-toolbar))) 92 (vm-toolbar-install-toolbar)))
116 mp 108 mp
117 (n 0) 109 (n 0)
118 ;; Just for laughs, make the update interval vary. 110 ;; Just for laughs, make the update interval vary.
119 (modulus (+ (% (vm-abs (random)) 11) 10)) 111 (modulus (+ (% (vm-abs (random)) 11) 10))
120 (mouse-track-func 112 (mouse-track-func
121 (and (vm-mouse-support-possible-p) 113 (and vm-mouse-track-summary
114 (vm-mouse-support-possible-p)
122 (vm-mouse-fsfemacs-mouse-p) 115 (vm-mouse-fsfemacs-mouse-p)
123 (function vm-mouse-set-mouse-track-highlight))) 116 (function vm-mouse-set-mouse-track-highlight)))
124 summary) 117 summary)
125 (setq mp m-list) 118 (setq mp m-list)
126 (save-excursion 119 (save-excursion
186 (defun vm-update-message-summary (m) 179 (defun vm-update-message-summary (m)
187 (if (and (vm-su-start-of m) 180 (if (and (vm-su-start-of m)
188 (marker-buffer (vm-su-start-of m))) 181 (marker-buffer (vm-su-start-of m)))
189 (let ((modified (buffer-modified-p)) 182 (let ((modified (buffer-modified-p))
190 (mouse-track-func 183 (mouse-track-func
191 (and (vm-mouse-support-possible-p) 184 (and vm-mouse-track-summary
185 (vm-mouse-support-possible-p)
192 (vm-mouse-fsfemacs-mouse-p) 186 (vm-mouse-fsfemacs-mouse-p)
193 (function vm-mouse-set-mouse-track-highlight))) 187 (function vm-mouse-set-mouse-track-highlight)))
194 summary) 188 summary)
195 (save-excursion 189 (save-excursion
196 (setq summary (vm-su-summary m)) 190 (setq summary (vm-su-summary m))
201 (unwind-protect 195 (unwind-protect
202 (save-excursion 196 (save-excursion
203 (goto-char (vm-su-start-of m)) 197 (goto-char (vm-su-start-of m))
204 (setq selected (not (looking-at vm-summary-no-=>))) 198 (setq selected (not (looking-at vm-summary-no-=>)))
205 ;; We do a little dance to update the text in 199 ;; We do a little dance to update the text in
206 ;; order to make the markets in the text do 200 ;; order to make the markers in the text do
207 ;; what we want. 201 ;; what we want.
208 ;; 202 ;;
209 ;; 1. We need to avoid having the su-start-of 203 ;; 1. We need to avoid having the su-start-of
210 ;; and su-end-of market clumping together at 204 ;; and su-end-of market clumping together at
211 ;; the start position. 205 ;; the start position.
242 236
243 (defun vm-set-summary-pointer (m) 237 (defun vm-set-summary-pointer (m)
244 (if vm-summary-buffer 238 (if vm-summary-buffer
245 (let ((w (vm-get-visible-buffer-window vm-summary-buffer)) 239 (let ((w (vm-get-visible-buffer-window vm-summary-buffer))
246 (mouse-track-func 240 (mouse-track-func
247 (and (vm-mouse-support-possible-p) 241 (and vm-mouse-track-summary
242 (vm-mouse-support-possible-p)
248 (vm-mouse-fsfemacs-mouse-p) 243 (vm-mouse-fsfemacs-mouse-p)
249 (function vm-mouse-set-mouse-track-highlight))) 244 (function vm-mouse-set-mouse-track-highlight)))
250 (old-window nil)) 245 (old-window nil))
251 (vm-save-buffer-excursion 246 (vm-save-buffer-excursion
252 (unwind-protect 247 (unwind-protect
297 (overlay-put vm-summary-overlay 'face face))) 292 (overlay-put vm-summary-overlay 'face face)))
298 ((fboundp 'make-extent) 293 ((fboundp 'make-extent)
299 (if (and vm-summary-overlay (extent-end-position vm-summary-overlay)) 294 (if (and vm-summary-overlay (extent-end-position vm-summary-overlay))
300 (set-extent-endpoints vm-summary-overlay start end) 295 (set-extent-endpoints vm-summary-overlay start end)
301 (setq vm-summary-overlay (make-extent start end)) 296 (setq vm-summary-overlay (make-extent start end))
297 ;; the reason this isn't needed under FSF Emacs is
298 ;; that insert-before-marker also inserts before
299 ;; overlays! so a summary update of an entry just
300 ;; before this overlay in the summary buffer won't
301 ;; leak into the overlay, but it _will_ leak into an
302 ;; XEmacs extent.
303 (set-extent-property vm-summary-overlay 'start-open t)
302 (set-extent-property vm-summary-overlay 'detachable nil) 304 (set-extent-property vm-summary-overlay 'detachable nil)
303 (set-extent-property vm-summary-overlay 'face face))))) 305 (set-extent-property vm-summary-overlay 'face face)))))
304 306
305 (defun vm-auto-center-summary () 307 (defun vm-auto-center-summary ()
306 (if vm-auto-center-summary 308 (if vm-auto-center-summary
491 sexp nil 493 sexp nil
492 sexp-fmt nil))) 494 sexp-fmt nil)))
493 (put format-variable 'vm-compiled-format format) 495 (put format-variable 'vm-compiled-format format)
494 (put format-variable 'vm-format-sexp (if list (cons 'list list) sexp)))) 496 (put format-variable 'vm-format-sexp (if list (cons 'list list) sexp))))
495 497
496 (defun vm-get-header-contents (message header-name-regexp) 498 (defun vm-get-header-contents (message header-name-regexp &optional clump-sep)
497 (let ((contents nil) 499 (let ((contents nil)
498 regexp) 500 regexp)
499 (setq regexp (concat "^\\(" header-name-regexp "\\)") 501 (setq regexp (concat "^\\(" header-name-regexp "\\)")
500 message (vm-real-message-of message)) 502 message (vm-real-message-of message))
501 (save-excursion 503 (save-excursion
502 (set-buffer (vm-buffer-of (vm-real-message-of message))) 504 (set-buffer (vm-buffer-of (vm-real-message-of message)))
503 (save-restriction 505 (save-restriction
504 (widen) 506 (widen)
505 (goto-char (vm-headers-of message)) 507 (goto-char (vm-headers-of message))
506 (let ((case-fold-search t)) 508 (let ((case-fold-search t))
507 (while (and (re-search-forward regexp (vm-text-of message) t) 509 (while (and (or (null contents) clump-sep)
510 (re-search-forward regexp (vm-text-of message) t)
508 (save-excursion (goto-char (match-beginning 0)) 511 (save-excursion (goto-char (match-beginning 0))
509 (vm-match-header))) 512 (vm-match-header)))
510 (if contents 513 (if contents
511 (setq contents 514 (setq contents
512 (concat contents ", " (vm-matched-header-contents))) 515 (concat contents clump-sep (vm-matched-header-contents)))
513 (setq contents (vm-matched-header-contents)))))) 516 (setq contents (vm-matched-header-contents))))))
514 contents ))) 517 contents )))
515 518
516 (defun vm-left-justify-string (string width) 519 (defun vm-left-justify-string (string width)
517 (if (>= (length string) width) 520 (if (>= (length string) width)
610 (if (not (memq (vm-message-type-of message) 613 (if (not (memq (vm-message-type-of message)
611 '(From_ From_-with-Content-Length))) 614 '(From_ From_-with-Content-Length)))
612 nil 615 nil
613 (save-excursion 616 (save-excursion
614 (set-buffer (vm-buffer-of (vm-real-message-of message))) 617 (set-buffer (vm-buffer-of (vm-real-message-of message)))
615 (save-restriction 618 (save-excursion
616 (widen) 619 (save-restriction
617 (goto-char (vm-start-of message)) 620 (widen)
618 (let ((case-fold-search nil)) 621 (goto-char (vm-start-of message))
619 (if (or (looking-at 622 (let ((case-fold-search nil))
620 ;; special case this so that the "remote from blah" 623 (if (or (looking-at
621 ;; isn't included. 624 ;; special case this so that the "remote from blah"
622 "From [^ \t\n]*[ \t]+\\([^ \t\n].*\\) remote from .*") 625 ;; isn't included.
623 (looking-at "From [^ \t\n]*[ \t]+\\([^ \t\n].*\\)")) 626 "From [^ \t\n]*[ \t]+\\([^ \t\n].*\\) remote from .*")
624 (vm-buffer-substring-no-properties 627 (looking-at "From [^ \t\n]*[ \t]+\\([^ \t\n].*\\)"))
625 (match-beginning 1) 628 (vm-buffer-substring-no-properties
626 (match-end 1)))))))) 629 (match-beginning 1)
630 (match-end 1)))))))))
627 631
628 (defun vm-parse-date (date) 632 (defun vm-parse-date (date)
629 (let ((weekday "") 633 (let ((weekday "")
630 (monthday "") 634 (monthday "")
631 (month "") 635 (month "")
777 (if (not (memq (vm-message-type-of message) 781 (if (not (memq (vm-message-type-of message)
778 '(From_ From_-with-Content-Length))) 782 '(From_ From_-with-Content-Length)))
779 nil 783 nil
780 (save-excursion 784 (save-excursion
781 (set-buffer (vm-buffer-of message)) 785 (set-buffer (vm-buffer-of message))
782 (save-restriction 786 (save-excursion
783 (widen) 787 (save-restriction
784 (goto-char (vm-start-of message)) 788 (widen)
785 (let ((case-fold-search nil)) 789 (goto-char (vm-start-of message))
786 (if (looking-at "From \\([^ \t\n]+\\)") 790 (let ((case-fold-search nil))
787 (vm-buffer-substring-no-properties 791 (if (looking-at "From \\([^ \t\n]+\\)")
788 (match-beginning 1) 792 (vm-buffer-substring-no-properties
789 (match-end 1)))))))) 793 (match-beginning 1)
794 (match-end 1)))))))))
790 795
791 (defun vm-su-do-author (m) 796 (defun vm-su-do-author (m)
792 (let ((full-name (vm-get-header-contents m "Full-Name:")) 797 (let ((full-name (vm-get-header-contents m "Full-Name:"))
793 (from (or (vm-get-header-contents m "From:") 798 (from (or (vm-get-header-contents m "From:" ", ")
794 (vm-grok-From_-author m))) 799 (vm-grok-From_-author m)))
795 pair) 800 pair i)
796 (if (and full-name (string-match "^[ \t]*$" full-name)) 801 (if (and full-name (string-match "^[ \t]*$" full-name))
797 (setq full-name nil)) 802 (setq full-name nil))
798 (if (null from) 803 (if (null from)
799 (progn 804 (progn
800 (setq from "???") 805 (setq from "???")
804 from (or (nth 1 pair) from) 809 from (or (nth 1 pair) from)
805 full-name (or full-name (nth 0 pair) from))) 810 full-name (or full-name (nth 0 pair) from)))
806 (if (string-match "\\`\"\\([^\"]+\\)\"\\'" full-name) 811 (if (string-match "\\`\"\\([^\"]+\\)\"\\'" full-name)
807 (setq full-name 812 (setq full-name
808 (substring full-name (match-beginning 1) (match-end 1)))) 813 (substring full-name (match-beginning 1) (match-end 1))))
814 (setq full-name (vm-decode-mime-encoded-words-maybe full-name))
815 (while (setq i (string-match "\n" full-name i))
816 (aset full-name i ?\ ))
809 (vm-set-full-name-of m full-name) 817 (vm-set-full-name-of m full-name)
810 (vm-set-from-of m from))) 818 (vm-set-from-of m from)))
811 819
812 (defun vm-default-chop-full-name (address) 820 (defun vm-default-chop-full-name (address)
813 (let ((from address) 821 (let ((from address)
860 ;; it passed the tests 868 ;; it passed the tests
861 (setq vm-chop-full-name-function 'mail-extract-address-components)) 869 (setq vm-chop-full-name-function 'mail-extract-address-components))
862 (funcall vm-chop-full-name-function address))) 870 (funcall vm-chop-full-name-function address)))
863 871
864 (defun vm-su-do-recipients (m) 872 (defun vm-su-do-recipients (m)
865 (let ((mail-use-rfc822 t) names addresses to cc all list) 873 (let ((mail-use-rfc822 t) i names addresses to cc all list full-name)
866 (setq to (or (vm-get-header-contents m "To:") 874 (setq to (or (vm-get-header-contents m "To:" ", ")
867 (vm-get-header-contents m "Apparently-To:") 875 (vm-get-header-contents m "Apparently-To:" ", ")
868 ;; desperation.... 876 ;; desperation....
869 (user-login-name)) 877 (user-login-name))
870 cc (vm-get-header-contents m "Cc:") 878 cc (vm-get-header-contents m "Cc:" ", ")
871 all to 879 all to
872 all (if all (concat all ", " cc) cc) 880 all (if all (concat all ", " cc) cc)
873 addresses (rfc822-addresses all)) 881 addresses (rfc822-addresses all))
874 (setq list (vm-parse-addresses all)) 882 (setq list (vm-parse-addresses all))
875 (while list 883 (while list
876 (cond ((string= (car list) "")) 884 ;; Just like vm-su-do-author:
877 ((string-match "^\\(\"?\\([^<]+[^ \t\n\"]\\)\"?[ \t\n]+\\)?<\\([^>]+\\)>" 885 (setq full-name (or (nth 0 (funcall vm-chop-full-name-function
878 (car list)) 886 (car list)))
879 (if (match-beginning 2) 887 (car list)))
880 (setq names 888 ;; If double quoted are around the full name, fish the name out.
881 (cons 889 (if (string-match "\\`\"\\([^\"]+\\)\"\\'" full-name)
882 (substring (car list) (match-beginning 2) 890 (setq full-name
883 (match-end 2)) 891 (substring full-name (match-beginning 1) (match-end 1))))
884 names)) 892 (setq full-name (vm-decode-mime-encoded-words-maybe full-name))
885 (setq names 893 (while (setq i (string-match "\n" full-name i))
886 (cons 894 (aset full-name i ?\ ))
887 (substring (car list) (match-beginning 3) 895 (setq names (cons full-name names))
888 (match-end 3))
889 names))))
890 ((string-match "[\000-\177]*(\\([^)]+\\))[\000-\177]*" (car list))
891 (setq names
892 (cons (substring (car list) (match-beginning 1)
893 (match-end 1))
894 names)))
895 (t (setq names (cons (car list) names))))
896 (setq list (cdr list))) 896 (setq list (cdr list)))
897 (setq names (nreverse names)) ; added by jwz for fixed vm-parse-addresses 897 (setq names (nreverse names)) ; added by jwz for fixed vm-parse-addresses
898 (vm-set-to-of m (mapconcat 'identity addresses ", ")) 898 (vm-set-to-of m (mapconcat 'identity addresses ", "))
899 (vm-set-to-names-of m (mapconcat 'identity names ", ")))) 899 (vm-set-to-names-of m (mapconcat 'identity names ", "))))
900 900
939 939
940 (defun vm-su-subject (m) 940 (defun vm-su-subject (m)
941 (or (vm-subject-of m) 941 (or (vm-subject-of m)
942 (vm-set-subject-of 942 (vm-set-subject-of
943 m 943 m
944 (let ((subject (or (vm-get-header-contents m "Subject:") "")) 944 (let ((subject (or (vm-get-header-contents m "Subject:" " ") ""))
945 (i nil)) 945 (i nil))
946 (if vm-summary-subject-no-newlines 946 (setq subject (vm-decode-mime-encoded-words-maybe subject))
947 (while (setq i (string-match "\n" subject i)) 947 (while (setq i (string-match "\n" subject i))
948 (aset subject i ?\ ))) 948 (aset subject i ?\ ))
949 subject )))) 949 subject ))))
950 950
951 (defun vm-su-summary (m) 951 (defun vm-su-summary (m)
952 (if (and (vm-virtual-message-p m) (not (vm-virtual-messages-of m))) 952 (if (and (vm-virtual-message-p m) (not (vm-virtual-messages-of m)))
953 (or (vm-virtual-summary-of m) 953 (or (vm-virtual-summary-of m)
969 (vm-unsaved-message "Fixing your summary...") 969 (vm-unsaved-message "Fixing your summary...")
970 (let ((mp vm-message-list)) 970 (let ((mp vm-message-list))
971 (while mp 971 (while mp
972 (vm-set-summary-of (car mp) nil) 972 (vm-set-summary-of (car mp) nil)
973 (vm-mark-for-summary-update (car mp)) 973 (vm-mark-for-summary-update (car mp))
974 (vm-stuff-attributes (car mp))
975 (setq mp (cdr mp))) 974 (setq mp (cdr mp)))
975 (vm-stuff-folder-attributes nil)
976 (set-buffer-modified-p t) 976 (set-buffer-modified-p t)
977 (vm-update-summary-and-mode-line)) 977 (vm-update-summary-and-mode-line))
978 (vm-unsaved-message "Fixing your summary... done")) 978 (vm-unsaved-message "Fixing your summary... done"))
979 979
980 (defun vm-su-thread-indent (m) 980 (defun vm-su-thread-indent (m)