xemacs-beta: lisp/vm/vm-summary.el comparison

comparison 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

comparison

equal deleted inserted replaced

-:804d1389bcd6
+:131b0175ea99
 ;;; 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
 ;;; the Free Software Foundation; either version 1, or (at your option)
 ;;; any later version.
 (defun vm-summary-mode-internal ()
 (setq mode-name "VM Summary"
 	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
 	vm-summary-pointer nil
 	vm-summary-=> (if (stringp vm-summary-arrow) vm-summary-arrow "")
 	vm-summary-no-=> (make-string (length vm-summary-=>) ? )
 	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
+(and (vm-mouse-support-possible-p)
-(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
 (run-hooks 'vm-summary-mode-hooks))
 (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)
 (let ((b (current-buffer))
 	    (read-only vm-folder-read-only))
 		vm-folder-read-only read-only)
 	  (vm-summary-mode-internal))
 	(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)
 	(and (vm-toolbar-support-possible-p) vm-use-toolbar
 	     (vm-toolbar-install-toolbar)))
 	mp
 	(n 0)
 	;; Just for laughs, make the update interval vary.
 	(modulus (+ (% (vm-abs (random)) 11) 10))
 	(mouse-track-func
-	    (and vm-mouse-track-summary
+	    (and (vm-mouse-support-possible-p)
-		 (vm-mouse-support-possible-p)
 		 (vm-mouse-fsfemacs-mouse-p)
 		 (function vm-mouse-set-mouse-track-highlight)))
 	summary)
 (setq mp m-list)
 (save-excursion
 		(insert vm-summary-no-=>)
 		(vm-tokenized-summary-insert (car mp) (vm-su-summary (car mp)))
 		(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
 					       (vm-su-start-of (car mp))
 					       (vm-su-end-of (car mp))))
 		(vm-set-su-end-of (car mp) (vm-marker (vm-su-end-of (car mp))))
 		(setq mp (cdr mp))))
 	  (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)
 (progn
 	(vm-copy-local-variables vm-summary-buffer 'vm-summary-show-threads)
 (defun vm-update-message-summary (m)
 (if (and (vm-su-start-of m)
 	   (marker-buffer (vm-su-start-of m)))
 (let ((modified (buffer-modified-p))
 	    (mouse-track-func
-	     (and vm-mouse-track-summary
+	     (and (vm-mouse-support-possible-p)
-		  (vm-mouse-support-possible-p)
 		  (vm-mouse-fsfemacs-mouse-p)
 		  (function vm-mouse-set-mouse-track-highlight)))
 	    summary)
 	(save-excursion
 	  (setq summary (vm-su-summary m))
 	    (unwind-protect
 		(save-excursion
 		  (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
 		  ;;    su-end-of region.
 		  ;;
 (defun vm-set-summary-pointer (m)
 (if vm-summary-buffer
 (let ((w (vm-get-visible-buffer-window vm-summary-buffer))
 	    (mouse-track-func
-	       (and vm-mouse-track-summary
+	       (and (vm-mouse-support-possible-p)
-		    (vm-mouse-support-possible-p)
 		    (vm-mouse-fsfemacs-mouse-p)
 		    (function vm-mouse-set-mouse-track-highlight)))
 	    (old-window nil))
 	(vm-save-buffer-excursion
 	  (unwind-protect
 		  (and w vm-auto-center-summary (vm-auto-center-summary))
 		  (run-hooks 'vm-summary-pointer-update-hook)))
 	    (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)))))
 (defun vm-auto-center-summary ()
 (if vm-auto-center-summary
 (insert tokens)
 (let (token)
 (while tokens
 	(setq token (car tokens))
 	(cond ((stringp token)
-	       (if vm-display-using-mime
+	       (insert token))
-		   (insert (vm-decode-mime-encoded-words-in-string token))
-		 (insert token)))
 	      ((eq token 'number)
 	       (insert (vm-padded-number-of message)))
 	      ((eq token 'mark)
 	       (insert (vm-su-mark message)))
 	      ((eq token 'thread-indent)
 		    ((= conv-spec ?*)
 		     (if tokenize
 			 (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)
 				   (string-to-int
 				    (substring format
 			     (list 'vm-truncate-string (car sexp)
 				   (string-to-int
 				    (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
 					   last-match-end
 					   (match-beginning 0))
 		sexp nil
 		sexp-fmt nil)))
 (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 "\\)")
 	  message (vm-real-message-of message))
 (save-excursion
 (set-buffer (vm-buffer-of (vm-real-message-of message)))
 (save-restriction
 	(widen)
 	(goto-char (vm-headers-of message))
 	(let ((case-fold-search t))
-	  (while (and (or (null contents) clump-sep)
+	  (while (and (re-search-forward regexp (vm-text-of message) t)
-		      (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 )))
 (defun vm-left-justify-string (string width)
 (if (>= (length string) width)
 (if (>= (length string) width)
 string
 (concat (make-string (- width (length string)) ?\ ) string)))
 (defun vm-truncate-string (string width)
-(cond
+(cond ((<= (length string) width)
-;; 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)
 	 string)
 	((< width 0)
 	 (substring string width))
 	(t
 	 (substring string 0 width))))
 (if (not (memq (vm-message-type-of message)
 		 '(From_ From_-with-Content-Length)))
 nil
 (save-excursion
 (set-buffer (vm-buffer-of (vm-real-message-of message)))
-(save-excursion
+(save-restriction
-	(save-restriction
+	(widen)
-	  (widen)
+	(goto-char (vm-start-of message))
-	  (goto-char (vm-start-of message))
+	(let ((case-fold-search nil))
-	  (let ((case-fold-search nil))
+	  (if (or (looking-at
-	    (if (or (looking-at
+		   ;; special case this so that the "remote from blah"
-		     ;; special case this so that the "remote from blah"
+		   ;; isn't included.
-		     ;; isn't included.
+		   "From [^ \t\n]*[ \t]+\\([^ \t\n].*\\) remote from .*")
-		     "From [^ \t\n]*[ \t]+\\([^ \t\n].*\\) remote from .*")
+		  (looking-at "From [^ \t\n]*[ \t]+\\([^ \t\n].*\\)"))
-		    (looking-at "From [^ \t\n]*[ \t]+\\([^ \t\n].*\\)"))
+	      (vm-buffer-substring-no-properties
-		(vm-buffer-substring-no-properties
+	       (match-beginning 1)
-		 (match-beginning 1)
+	       (match-end 1))))))))
-		 (match-end 1)))))))))
 (defun vm-parse-date (date)
 (let ((weekday "")
 	(monthday "")
 	(month "")
 (vm-set-monthday-of m (substring date (match-beginning 3) (match-end 3)))
 (vm-set-hour-of m (substring date (match-beginning 4) (match-end 4)))
 (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)))
+				       (match-end 6)))))
-	(vm-set-zone-of m "")))
 (t
 (setq vector (vm-parse-date date))
 (vm-set-weekday-of m (elt vector 0))
 (vm-set-monthday-of m (elt vector 1))
 (vm-su-do-month m (elt vector 2))
 (if (not (memq (vm-message-type-of message)
 		 '(From_ From_-with-Content-Length)))
 nil
 (save-excursion
 (set-buffer (vm-buffer-of message))
-(save-excursion
+(save-restriction
-	(save-restriction
+	(widen)
-	  (widen)
+	(goto-char (vm-start-of message))
-	  (goto-char (vm-start-of message))
+	(let ((case-fold-search nil))
-	  (let ((case-fold-search nil))
+	  (if (looking-at "From \\([^ \t\n]+\\)")
-	    (if (looking-at "From \\([^ \t\n]+\\)")
+	      (vm-buffer-substring-no-properties
-		(vm-buffer-substring-no-properties
+	       (match-beginning 1)
-		 (match-beginning 1)
+	       (match-end 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)
 	(progn
 	  (setq from "???")
 	    from (or (nth 1 pair) from)
 	    full-name (or full-name (nth 0 pair) from)))
 (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)))
 (defun vm-default-chop-full-name (address)
 (let ((from address)
 ;; it passed the tests
 (setq vm-chop-full-name-function 'mail-extract-address-components))
 (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)
+(let ((mail-use-rfc822 t) names addresses to cc all list)
-(setq to (or (vm-get-header-contents m "To:" ", ")
+(setq to (or (vm-get-header-contents m "To:")
-		 (vm-get-header-contents m "Apparently-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:
+(cond ((string= (car list) ""))
-(setq full-name (or (nth 0 (funcall vm-chop-full-name-function
+	    ((string-match "^\\(\"?\\([^<]+[^ \t\n\"]\\)\"?[ \t\n]+\\)?<\\([^>]+\\)>"
-					  (car list)))
+			   (car list))
-			  (car list)))
+	     (if (match-beginning 2)
-;; If double quoted are around the full name, fish the name out.
+		 (setq names
-(if (string-match "\\`\"\\([^\"]+\\)\"\\'" full-name)
+		       (cons
-	  (setq full-name
+			(substring (car list) (match-beginning 2)
-		(substring full-name (match-beginning 1) (match-end 1))))
+				   (match-end 2))
-(while (setq i (string-match "\n" full-name i))
+			names))
-	(aset full-name i ?\ ))
+	       (setq names
-(setq names (cons full-name 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 ", "))
 (vm-set-to-names-of m (mapconcat 'identity names ", "))))
 (defun vm-su-message-id (m)
 (or (vm-message-id-of m)
 (vm-set-message-id-of
 m
-(or (let ((id (vm-get-header-contents m "Message-Id:")))
+(or (vm-get-header-contents m "Message-Id:")
-	     (and id (car (vm-parse id "[^<]*\\(<[^>]+>\\)"))))
 	   ;; try running md5 on the message body to produce an ID
 	   ;; better than nothing.
 	   (save-excursion
 	     (set-buffer (vm-buffer-of (vm-real-message-of m)))
 	     (save-restriction
 (defun vm-su-subject (m)
 (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))
+	 (if vm-summary-subject-no-newlines
-	   (aset subject i ?\ ))
+	     (while (setq i (string-match "\n" subject i))
+	       (aset subject i ?\ )))
 	 subject ))))
 (defun vm-su-summary (m)
 (if (and (vm-virtual-message-p m) (not (vm-virtual-messages-of m)))
 (or (vm-virtual-summary-of m)
 (defun vm-fix-my-summary!!! ()
 (interactive)
 (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)
 (make-string (* (vm-th-thread-indentation m)
 		      vm-summary-thread-indent-level)

Mercurial > hg > xemacs-beta

comparison lisp/vm/vm-summary.el @ 70:131b0175ea99 r20-0b30