Mercurial > hg > xemacs-beta
diff lisp/vm/vm-summary.el @ 70:131b0175ea99 r20-0b30
Import from CVS: tag r20-0b30
author | cvs |
---|---|
date | Mon, 13 Aug 2007 09:02:59 +0200 |
parents | 05472e90ae02 |
children | 0d2f883870bc |
line wrap: on
line diff
--- a/lisp/vm/vm-summary.el Mon Aug 13 09:00:04 2007 +0200 +++ b/lisp/vm/vm-summary.el Mon Aug 13 09:02:59 2007 +0200 @@ -1,5 +1,5 @@ ;;; Summary gathering and formatting routines for VM -;;; Copyright (C) 1989-1995 Kyle E. Jones +;;; Copyright (C) 1989, 1990, 1993, 1994, 1995 Kyle E. Jones ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by @@ -22,7 +22,7 @@ major-mode 'vm-summary-mode mode-line-format vm-mode-line-format ;; must come after the setting of major-mode - mode-popup-menu (and vm-use-menus vm-popup-menu-on-mouse-3 + mode-popup-menu (and vm-use-menus (vm-menu-support-possible-p) (vm-menu-mode-menu)) buffer-read-only t @@ -32,16 +32,16 @@ truncate-lines t) ;; horizontal scrollbar off by default ;; user can turn it on in summary hook if desired. - (and vm-xemacs-p (featurep 'scrollbar) + (and (fboundp 'set-specifier) + scrollbar-height (set-specifier scrollbar-height (cons (current-buffer) 0))) (use-local-map vm-summary-mode-map) (and (vm-menu-support-possible-p) (vm-menu-install-menus)) - (and vm-mouse-track-summary - (vm-mouse-support-possible-p) + (and (vm-mouse-support-possible-p) (vm-mouse-xemacs-mouse-p) (add-hook 'mode-motion-hook 'mode-motion-highlight-line)) - (if (and vm-mutable-frames (or vm-frame-per-folder vm-frame-per-summary)) + (if (or vm-frame-per-folder vm-frame-per-summary) (vm-set-hooks-for-frame-deletion)) (run-hooks 'vm-summary-mode-hook) ;; Lucid Emacs apparently used this name @@ -50,12 +50,12 @@ (fset 'vm-summary-mode 'vm-mode) (put 'vm-summary-mode 'mode-class 'special) -(defun vm-summarize (&optional display raise) +(defun vm-summarize (&optional display) "Summarize the contents of the folder in a summary buffer. The format is as described by the variable vm-summary-format. Generally one line per message is most pleasing to the eye but this is not mandatory." - (interactive "p\np") + (interactive "p") (vm-select-folder-buffer) (vm-check-for-killed-summary) (if (null vm-summary-buffer) @@ -79,11 +79,20 @@ (vm-set-summary-redo-start-point t))) (if display (save-excursion - (vm-goto-new-summary-frame-maybe) + (if vm-frame-per-summary + (let ((w (vm-get-buffer-window vm-summary-buffer))) + (if (null w) + (progn + (vm-goto-new-frame 'summary) + (vm-set-hooks-for-frame-deletion)) + (save-excursion + (select-window w) + (and vm-warp-mouse-to-new-frame + (vm-warp-mouse-to-frame-maybe (vm-window-frame w))))))) (vm-display vm-summary-buffer t '(vm-summarize vm-summarize-other-frame) - (list this-command) (not raise)) + (list this-command)) ;; need to do this after any frame creation because the ;; toolbar sets frame-specific height and width specifiers. (set-buffer vm-summary-buffer) @@ -109,8 +118,7 @@ ;; Just for laughs, make the update interval vary. (modulus (+ (% (vm-abs (random)) 11) 10)) (mouse-track-func - (and vm-mouse-track-summary - (vm-mouse-support-possible-p) + (and (vm-mouse-support-possible-p) (vm-mouse-fsfemacs-mouse-p) (function vm-mouse-set-mouse-track-highlight))) summary) @@ -141,10 +149,10 @@ (vm-set-su-end-of (car mp) (point)) (setq mp (cdr mp) n (1+ n)) (if (zerop (% n modulus)) - (message "Generating summary... %d" n))) + (vm-unsaved-message "Generating summary... %d" n))) ;; now convert the ints to markers. (if (>= n modulus) - (message "Generating summary markers... ")) + (vm-unsaved-message "Generating summary markers... ")) (setq mp m-list) (while mp (and mouse-track-func (funcall mouse-track-func @@ -156,7 +164,7 @@ (set-buffer-modified-p modified)) (run-hooks 'vm-summary-redo-hook))) (if (>= n modulus) - (message "Generating summary... done")))) + (vm-unsaved-message "Generating summary... done")))) (defun vm-do-needed-summary-rebuild () (if (and vm-summary-redo-start-point vm-summary-buffer) @@ -180,8 +188,7 @@ (marker-buffer (vm-su-start-of m))) (let ((modified (buffer-modified-p)) (mouse-track-func - (and vm-mouse-track-summary - (vm-mouse-support-possible-p) + (and (vm-mouse-support-possible-p) (vm-mouse-fsfemacs-mouse-p) (function vm-mouse-set-mouse-track-highlight))) summary) @@ -196,14 +203,14 @@ (goto-char (vm-su-start-of m)) (setq selected (not (looking-at vm-summary-no-=>))) ;; We do a little dance to update the text in - ;; order to make the markers in the text do + ;; order to make the markets in the text do ;; what we want. ;; ;; 1. We need to avoid having the su-start-of - ;; and su-end-of markers clumping together at + ;; and su-end-of market clumping together at ;; the start position. ;; - ;; 2. We want the window point marker (w->pointm + ;; 2. We want the window point market (w->pointm ;; in the Emacs display code) to move to the ;; start of the summary entry if it is ;; anywhere within the su-start-of to @@ -237,8 +244,7 @@ (if vm-summary-buffer (let ((w (vm-get-visible-buffer-window vm-summary-buffer)) (mouse-track-func - (and vm-mouse-track-summary - (vm-mouse-support-possible-p) + (and (vm-mouse-support-possible-p) (vm-mouse-fsfemacs-mouse-p) (function vm-mouse-set-mouse-track-highlight))) (old-window nil)) @@ -283,23 +289,16 @@ (and old-window (select-window old-window))))))) (defun vm-summary-highlight-region (start end face) - (cond (vm-fsfemacs-19-p + (cond ((fboundp 'make-overlay) (if (and vm-summary-overlay (overlay-buffer vm-summary-overlay)) (move-overlay vm-summary-overlay start end) (setq vm-summary-overlay (make-overlay start end)) (overlay-put vm-summary-overlay 'evaporate nil) (overlay-put vm-summary-overlay 'face face))) - (vm-xemacs-p + ((fboundp 'make-extent) (if (and vm-summary-overlay (extent-end-position vm-summary-overlay)) (set-extent-endpoints vm-summary-overlay start end) (setq vm-summary-overlay (make-extent start end)) - ;; the reason this isn't needed under FSF Emacs is - ;; that insert-before-markers also inserts before - ;; overlays! so a summary update of an entry just - ;; before this overlay in the summary buffer won't - ;; leak into the overlay, but it _will_ leak into an - ;; XEmacs extent. - (set-extent-property vm-summary-overlay 'start-open t) (set-extent-property vm-summary-overlay 'detachable nil) (set-extent-property vm-summary-overlay 'face face))))) @@ -326,9 +325,7 @@ (while tokens (setq token (car tokens)) (cond ((stringp token) - (if vm-display-using-mime - (insert (vm-decode-mime-encoded-words-in-string token)) - (insert token))) + (insert token)) ((eq token 'number) (insert (vm-padded-number-of message))) ((eq token 'mark) @@ -445,10 +442,6 @@ (setq token ''mark) (setq sexp (cons (list 'vm-su-mark 'vm-su-message) sexp))))) - (cond ((and (not token) vm-display-using-mime) - (setcar sexp - (list 'vm-decode-mime-encoded-words-in-string - (car sexp))))) (cond ((and (not token) (match-beginning 1)) (setcar sexp (list 'vm-left-justify-string (car sexp) @@ -470,10 +463,6 @@ (substring format (match-beginning 4) (match-end 4))))))) - (cond ((and (not token) vm-display-using-mime) - (setcar sexp - (list 'vm-reencode-mime-encoded-words-in-string - (car sexp))))) (setq sexp-fmt (cons (if token "" "%s") (cons (substring format @@ -504,7 +493,7 @@ (put format-variable 'vm-compiled-format format) (put format-variable 'vm-format-sexp (if list (cons 'list list) sexp)))) -(defun vm-get-header-contents (message header-name-regexp &optional clump-sep) +(defun vm-get-header-contents (message header-name-regexp) (let ((contents nil) regexp) (setq regexp (concat "^\\(" header-name-regexp "\\)") @@ -515,13 +504,12 @@ (widen) (goto-char (vm-headers-of message)) (let ((case-fold-search t)) - (while (and (or (null contents) clump-sep) - (re-search-forward regexp (vm-text-of message) t) + (while (and (re-search-forward regexp (vm-text-of message) t) (save-excursion (goto-char (match-beginning 0)) (vm-match-header))) (if contents (setq contents - (concat contents clump-sep (vm-matched-header-contents))) + (concat contents ", " (vm-matched-header-contents))) (setq contents (vm-matched-header-contents)))))) contents ))) @@ -536,20 +524,7 @@ (concat (make-string (- width (length string)) ?\ ) string))) (defun vm-truncate-string (string width) - (cond -;; doesn't work because the width of wide chars such as the Kanji -;; glyphs as not even multiples of the default face's font width. -;; ((fboundp 'char-width) -;; (let ((i 0) -;; (lim (length string)) -;; (total 0)) -;; (while (and (< i lim) (<= total width)) -;; (setq total (+ total (char-width (aref string i))) -;; i (1+ i))) -;; (if (<= total width) -;; string -;; (substring string 0 (1- i))))) - ((<= (length string) width) + (cond ((<= (length string) width) string) ((< width 0) (substring string width)) @@ -637,19 +612,18 @@ nil (save-excursion (set-buffer (vm-buffer-of (vm-real-message-of message))) - (save-excursion - (save-restriction - (widen) - (goto-char (vm-start-of message)) - (let ((case-fold-search nil)) - (if (or (looking-at - ;; special case this so that the "remote from blah" - ;; isn't included. - "From [^ \t\n]*[ \t]+\\([^ \t\n].*\\) remote from .*") - (looking-at "From [^ \t\n]*[ \t]+\\([^ \t\n].*\\)")) - (vm-buffer-substring-no-properties - (match-beginning 1) - (match-end 1))))))))) + (save-restriction + (widen) + (goto-char (vm-start-of message)) + (let ((case-fold-search nil)) + (if (or (looking-at + ;; special case this so that the "remote from blah" + ;; isn't included. + "From [^ \t\n]*[ \t]+\\([^ \t\n].*\\) remote from .*") + (looking-at "From [^ \t\n]*[ \t]+\\([^ \t\n].*\\)")) + (vm-buffer-substring-no-properties + (match-beginning 1) + (match-end 1)))))))) (defun vm-parse-date (date) (let ((weekday "") @@ -734,8 +708,7 @@ (vm-set-year-of m (substring date (match-beginning 5) (match-end 5))) (if (match-beginning 6) (vm-set-zone-of m (substring date (match-beginning 6) - (match-end 6))) - (vm-set-zone-of m ""))) + (match-end 6))))) (t (setq vector (vm-parse-date date)) (vm-set-weekday-of m (elt vector 0)) @@ -806,21 +779,20 @@ nil (save-excursion (set-buffer (vm-buffer-of message)) - (save-excursion - (save-restriction - (widen) - (goto-char (vm-start-of message)) - (let ((case-fold-search nil)) - (if (looking-at "From \\([^ \t\n]+\\)") - (vm-buffer-substring-no-properties - (match-beginning 1) - (match-end 1))))))))) + (save-restriction + (widen) + (goto-char (vm-start-of message)) + (let ((case-fold-search nil)) + (if (looking-at "From \\([^ \t\n]+\\)") + (vm-buffer-substring-no-properties + (match-beginning 1) + (match-end 1)))))))) (defun vm-su-do-author (m) (let ((full-name (vm-get-header-contents m "Full-Name:")) - (from (or (vm-get-header-contents m "From:" ", ") + (from (or (vm-get-header-contents m "From:") (vm-grok-From_-author m))) - pair i) + pair) (if (and full-name (string-match "^[ \t]*$" full-name)) (setq full-name nil)) (if (null from) @@ -834,8 +806,6 @@ (if (string-match "\\`\"\\([^\"]+\\)\"\\'" full-name) (setq full-name (substring full-name (match-beginning 1) (match-end 1)))) - (while (setq i (string-match "\n" full-name i)) - (aset full-name i ?\ )) (vm-set-full-name-of m full-name) (vm-set-from-of m from))) @@ -892,28 +862,37 @@ (funcall vm-chop-full-name-function address))) (defun vm-su-do-recipients (m) - (let ((mail-use-rfc822 t) i names addresses to cc all list full-name) - (setq to (or (vm-get-header-contents m "To:" ", ") - (vm-get-header-contents m "Apparently-To:" ", ") + (let ((mail-use-rfc822 t) names addresses to cc all list) + (setq to (or (vm-get-header-contents m "To:") + (vm-get-header-contents m "Apparently-To:") ;; desperation.... (user-login-name)) - cc (vm-get-header-contents m "Cc:" ", ") + cc (vm-get-header-contents m "Cc:") all to all (if all (concat all ", " cc) cc) addresses (rfc822-addresses all)) (setq list (vm-parse-addresses all)) (while list - ;; Just like vm-su-do-author: - (setq full-name (or (nth 0 (funcall vm-chop-full-name-function - (car list))) - (car list))) - ;; If double quoted are around the full name, fish the name out. - (if (string-match "\\`\"\\([^\"]+\\)\"\\'" full-name) - (setq full-name - (substring full-name (match-beginning 1) (match-end 1)))) - (while (setq i (string-match "\n" full-name i)) - (aset full-name i ?\ )) - (setq names (cons full-name names)) + (cond ((string= (car list) "")) + ((string-match "^\\(\"?\\([^<]+[^ \t\n\"]\\)\"?[ \t\n]+\\)?<\\([^>]+\\)>" + (car list)) + (if (match-beginning 2) + (setq names + (cons + (substring (car list) (match-beginning 2) + (match-end 2)) + names)) + (setq names + (cons + (substring (car list) (match-beginning 3) + (match-end 3)) + names)))) + ((string-match "[\000-\177]*(\\([^)]+\\))[\000-\177]*" (car list)) + (setq names + (cons (substring (car list) (match-beginning 1) + (match-end 1)) + names))) + (t (setq names (cons (car list) names)))) (setq list (cdr list))) (setq names (nreverse names)) ; added by jwz for fixed vm-parse-addresses (vm-set-to-of m (mapconcat 'identity addresses ", ")) @@ -929,8 +908,7 @@ (or (vm-message-id-of m) (vm-set-message-id-of m - (or (let ((id (vm-get-header-contents m "Message-Id:"))) - (and id (car (vm-parse id "[^<]*\\(<[^>]+>\\)")))) + (or (vm-get-header-contents m "Message-Id:") ;; try running md5 on the message body to produce an ID ;; better than nothing. (save-excursion @@ -963,10 +941,11 @@ (or (vm-subject-of m) (vm-set-subject-of m - (let ((subject (or (vm-get-header-contents m "Subject:" " ") "")) + (let ((subject (or (vm-get-header-contents m "Subject:") "")) (i nil)) - (while (setq i (string-match "\n" subject i)) - (aset subject i ?\ )) + (if vm-summary-subject-no-newlines + (while (setq i (string-match "\n" subject i)) + (aset subject i ?\ ))) subject )))) (defun vm-su-summary (m) @@ -987,16 +966,16 @@ (vm-select-folder-buffer) (vm-check-for-killed-summary) (vm-error-if-folder-empty) - (message "Fixing your summary...") + (vm-unsaved-message "Fixing your summary...") (let ((mp vm-message-list)) (while mp (vm-set-summary-of (car mp) nil) (vm-mark-for-summary-update (car mp)) + (vm-stuff-attributes (car mp)) (setq mp (cdr mp))) - (vm-stuff-folder-attributes nil) (set-buffer-modified-p t) (vm-update-summary-and-mode-line)) - (message "Fixing your summary... done")) + (vm-unsaved-message "Fixing your summary... done")) (defun vm-su-thread-indent (m) (if (natnump vm-summary-thread-indent-level)