Commits

Anonymous committed 781b350

2001-09-07 Steve Youngs <youngs@xemacs.org>

* Sync with VM-6.96.

Comments (0)

Files changed (16)

+2001-09-07  Steve Youngs  <youngs@xemacs.org>
+
+	* Sync with VM-6.96.
+
 2001-07-26  Steve Youngs  <youngs@xemacs.org>
 
 	* Sync with VM-6.95.
 # Boston, MA 02111-1307, USA.
 
 VERSION = 6.95
-AUTHOR_VERSION = 6.95
+AUTHOR_VERSION = 6.96
 MAINTAINER = XEmacs Development Team <xemacs-beta@xemacs.org>
 PACKAGE = vm
 PKG_TYPE = regular
 ;;; Message encapsulation
-;;; Copyright (C) 1989, 1990, 1993, 1994, 1997 Kyle E. Jones
+;;; Copyright (C) 1989, 1990, 1993, 1994, 1997, 2001 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
 	    (goto-char start)
 	    (setq n (length message-list))
 	    (insert
-	     (format "This is a digest, %d messages, MIME encapsulation.\n"
-		     n)))
+	     (format "This is a digest, %d message%s, MIME encapsulation.\n"
+		     n (if (= n 1) "" "s"))))
 	  (goto-char start))
 	boundary )))
 
 ;;; Editing VM messages
-;;; Copyright (C) 1990, 1991, 1993, 1994, 1997 Kyle E. Jones
+;;; Copyright (C) 1990, 1991, 1993, 1994, 1997, 2001 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
   (vm-check-for-killed-summary)
   (vm-check-for-killed-presentation)
   (vm-error-if-folder-empty)
-  (let ((mlist (vm-select-marked-or-prefixed-messages count))
-	(buffers-needing-thread-sort (make-vector 29 0))
+  (let ((mlist (vm-select-marked-or-prefixed-messages count)))
+    (vm-discard-cached-data-internal mlist))
+  (vm-display nil nil '(vm-discard-cached-data) '(vm-discard-cached-data))
+  (vm-update-summary-and-mode-line))
+
+(defun vm-discard-cached-data-internal (mlist)
+  (let ((buffers-needing-thread-sort (make-vector 29 0))
 	m)
     (while mlist
       (setq m (vm-real-message-of (car mlist)))
       (mapatoms (function (lambda (s)
 			    (set-buffer (get-buffer (symbol-name s)))
 			    (vm-sort-messages "thread")))
-		buffers-needing-thread-sort)))
-  (vm-display nil nil '(vm-discard-cached-data) '(vm-discard-cached-data))
-  (vm-update-summary-and-mode-line))
+		buffers-needing-thread-sort))))
 
 (defun vm-edit-message-end ()
   "End the edit of a message and copy the result to its folder."
 ;;; VM folder related functions
-;;; Copyright (C) 1989-1998 Kyle E. Jones
+;;; Copyright (C) 1989-2001 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
 	  (let ((vm-inhibit-write-file-hook t))
 	    (save-buffer prefix))
 	  (vm-set-buffer-modified-p nil)
+	  ;; clear the modified flag in virtual folders if all the
+	  ;; real buffers assocaited with them are unmodified.
+	  (let ((b-list vm-virtual-buffers) rb-list one-modified)
+	    (save-excursion
+	      (while b-list
+		(if (null (cdr (vm-buffer-variable-value (car b-list)
+							 'vm-real-buffers)))
+		    (vm-set-buffer-modified-p nil (car b-list))
+		  (set-buffer (car b-list))
+		  (setq rb-list vm-real-buffers one-modified nil)
+		  (while rb-list
+		    (if (buffer-modified-p (car rb-list))
+			(setq one-modified t rb-list nil)
+		      (setq rb-list (cdr rb-list))))
+		  (if (not one-modified)
+		      (vm-set-buffer-modified-p nil (car b-list))))
+		(setq b-list (cdr b-list)))))
 	  (vm-clear-modification-flag-undos)
 	  (setq vm-messages-not-on-disk 0)
 	  (setq vm-block-new-mail nil)
 (defun vm-display-startup-message ()
   (if (sit-for 5)
       (let ((lines vm-startup-message-lines))
-	(message "VM %s, Copyright (C) 2000 Kyle E. Jones; type ? for help"
-		 vm-version)
+	(message "VM %s, Copyright %s 2001 Kyle E. Jones; type ? for help"
+		 vm-version (if vm-xemacs-p "\251" "(C)"))
 	(setq vm-startup-message-displayed t)
 	(while (and (sit-for 4) lines)
 	  (message (substitute-command-keys (car lines)))
 ;;; Simple IMAP4 (RFC 2060) client for VM
-;;; Copyright (C) 1998 Kyle E. Jones
+;;; Copyright (C) 1998, 2001 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
 	(imap-retrieved-messages vm-imap-retrieved-messages)
 	(did-delete nil)
 	(source-nopwd (vm-imapdrop-sans-password source))
+	(use-rfc822-peek nil)
 	auto-expunge x select source-list uid
 	can-delete read-write uid-validity
 	mailbox mailbox-count message-size response
 		      (throw 'skip t)))
 		(message "Retrieving message %d (of %d) from %s..."
 			 n mailbox-count imapdrop)
-		(condition-case data
+		(if use-rfc822-peek
 		    (progn
-		      (vm-imap-send-command process
-					    (format "FETCH %d (BODY.PEEK[])"
-						    n))
-		      (vm-imap-retrieve-to-crashbox process destination
-						    statblob t))
-		  (vm-imap-protocol-error
-		   (message "FETCH %d (BODY.PEEK[]) failed, trying RFC822.PEEK"
-			    n)
-		   (vm-imap-send-command process
-					 (format
-					  "FETCH %d (RFC822.PEEK)" n))
-		   (vm-imap-retrieve-to-crashbox process destination
-						 statblob nil)))
-
+		       (vm-imap-send-command process
+					     (format
+					      "FETCH %d (RFC822.PEEK)" n))
+		       (vm-imap-retrieve-to-crashbox process destination
+						     statblob nil))
+		  (condition-case data
+		      (progn
+			(vm-imap-send-command process
+					      (format "FETCH %d (BODY.PEEK[])"
+						      n))
+			(vm-imap-retrieve-to-crashbox process destination
+						      statblob t))
+		    (vm-imap-protocol-error
+		     (vm-imap-send-command process
+					   (format "FETCH %d (RFC822.PEEK)" n))
+		     (vm-imap-retrieve-to-crashbox process destination
+						   statblob nil))))
 		(vm-increment retrieved)
 		(and b-per-session
 		     (setq retrieved-bytes (+ retrieved-bytes message-size)))
 			       (concat
 				(vm-xor-string secret ipad) challenge)))))
 			   answer (vm-mime-base64-encode-string answer))
-		     (vm-imap-send-command process answer)
+		     (vm-imap-send-command process answer nil t)
 		     (and (null (vm-imap-read-ok-response process))
 			  (progn
 			    (setq vm-imap-passwords
   (vm-set-imap-stat-y-got o (vm-imap-stat-x-got o))
   (vm-set-imap-stat-y-need o (vm-imap-stat-x-need o)))
 
-(defun vm-imap-send-command (process command)
+(defun vm-imap-send-command (process command &optional tag no-tag)
   (goto-char (point-max))
-  (insert-before-markers "VM ")
+  (or no-tag (insert-before-markers (or tag "VM") " "))
   (let ((case-fold-search t))
     (if (string-match "^LOGIN" command)
 	(insert-before-markers "LOGIN <parameters omitted>\r\n")
       (insert-before-markers command "\r\n")))
   (setq vm-imap-read-point (point))
-  (process-send-string process "VM ")
-  (process-send-string process command)
-  (process-send-string process "\r\n"))
+  ;; previously we had a process-send-string call for each string
+  ;; to avoid extra consing but that caused a lot of packet overhead.
+  (if no-tag
+      (process-send-string process (format "%s\r\n" command))
+    (process-send-string process (format "%s %s\r\n" (or tag "VM") command))))
 
 (defun vm-imap-select-mailbox (process mailbox &optional just-examine)
   (let ((imap-buffer (current-buffer))
 	      (cond ((vm-imap-response-matches response '* 'atom 'FETCH 'list)
 		     (setq fetch-response response
 			   need-header nil))
-		    ((vm-imap-response-matches response 'VM 'OK 'FETCH)
+		    ((vm-imap-response-matches response 'VM 'OK)
 		     (setq need-ok nil))))
 	    (if need-header
 		(vm-imap-protocol-error "FETCH OK sent before FETCH response"))
 ;;; MIME support functions
-;;; Copyright (C) 1997-1998, 2000 Kyle E. Jones
+;;; Copyright (C) 1997-1998, 2000, 2001 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
     (let ((default-filename
 	    (if (vm-mime-get-disposition-parameter layout "filename")
 		nil
-	      (vm-mime-get-parameter layout "name"))))
-      (vm-mime-send-body-to-file layout default-filename)))
+	      (vm-mime-get-parameter layout "name")))
+	  (file nil))
+      (setq file (vm-mime-send-body-to-file layout default-filename))
+      (if vm-mime-delete-after-saving
+	  (let ((vm-mime-confirm-delete nil))
+	    ;; we don't care if the delete fails
+	    (condition-case nil
+		(vm-delete-mime-object (expand-file-name file))
+	      (error nil))))))
   t )
 (fset 'vm-mime-display-button-application/octet-stream
       'vm-mime-display-internal-application/octet-stream)
 		  file)
 	      (let ((last-command last-command)
 		    (this-command this-command))
-		(setq file (read-file-name "Yank from folder: " dir nil t)))
+		(setq file (read-file-name "Attach message from folder: "
+					   dir nil t)))
 	      (save-excursion
 		(set-buffer
 		 (let ((coding-system-for-read (vm-binary-coding-system)))
 ;;; Miscellaneous functions for VM
-;;; Copyright (C) 1989-1997 Kyle E. Jones
+;;; Copyright (C) 1989-2001 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
 
 (defun vm-parse (string regexp &optional matchn)
   (or matchn (setq matchn 1))
-  (let (list)
+  (let (list tem)
     (store-match-data nil)
     (while (string-match regexp string (match-end 0))
-      (setq list (cons (substring string (match-beginning matchn)
-				  (match-end matchn)) list)))
+      (if (not (consp matchn))
+	  (setq list (cons (substring string (match-beginning matchn)
+				      (match-end matchn)) list))
+	(setq tem matchn)
+	(while tem
+	  (if (match-beginning (car tem))
+	      (setq list (cons (substring string
+					  (match-beginning (car tem))
+					  (match-end (car tem))) list)
+		    tem nil)
+	    (setq tem (cdr tem))))))
     (nreverse list)))
 
 (defun vm-parse-addresses (string)
       (insert-before-markers "PASS <omitted>\r\n")
     (insert-before-markers command "\r\n"))
   (setq vm-pop-read-point (point))
-  (process-send-string process command)
-  (process-send-string process "\r\n"))
+  (process-send-string process (format "%s\r\n" command)))
 
 (defun vm-pop-read-response (process &optional return-response-string)
   (let ((case-fold-search nil)
 ;;; Mailing, forwarding, and replying commands for VM
-;;; Copyright (C) 1989-1998 Kyle E. Jones
+;;; Copyright (C) 1989-2001 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
       (message "No composition buffers found"))))
 
 (defun vm-mail-to-mailto-url (url)
-  (let ((address (car (vm-parse url "^mailto:\\(.+\\)"))))
-    (setq address (vm-url-decode-string address))
+  (let ((list (vm-parse url "^mailto:\\([^?]+\\)\\??\\|\\([^&]+\\)&?"
+			'(1 2)))
+	to subject in-reply-to cc references newsgroups body
+	tem header value header-list)
+    (setq to (car list)
+	  to (vm-url-decode-string to)
+	  list (cdr list))
+    (while list
+      (setq tem (vm-parse (car list) "\\([^=]+\\)=?"))
+      (if (null (nth 1 tem))
+	  nil
+	(setq header (downcase (vm-url-decode-string (car tem)))
+	      value (vm-url-decode-string (nth 1 tem)))
+	(if (member header '("subject" "in-reply-to" "cc"
+			     "references" "newsgroups" "body"))
+	    ;; set the variable let-bound above
+	    (set (intern header) value)
+	  ;; we'll insert the header later
+	  (setq header-list (cons header (cons value header-list)))))
+      (setq list (cdr list)))
     (vm-select-folder-buffer)
     (vm-check-for-killed-summary)
-    (vm-mail-internal nil address)
+    (vm-mail-internal nil to subject in-reply-to cc references newsgroups)
+    (save-excursion
+      (goto-char (point-min))
+      (while header-list
+	(insert (car header-list) ": ")
+	(capitalize-region (point) (save-excursion (beginning-of-line) (point)))
+	(insert (nth 1 header-list) "\n")
+	(setq header-list (nthcdr 2 header-list)))
+      (if (null body)
+	  nil
+	(mail-text)
+	(save-excursion (insert (vm-url-decode-string body) "\n"))
+	;; CRLF to LF for line breaks in the body
+	(while (search-forward "\r\n" nil t)
+	  (replace-match "\n"))))
     (run-hooks 'vm-mail-hook)
     (run-hooks 'vm-mail-mode-hook)))
 
 (defun vm-mode (&optional read-only)
   "Major mode for reading mail.
 
-This is VM 6.95.
+This is VM 6.96.
 
 Commands:
    h - summarize folder contents
 		      m
 		      (vm-mouse-set-mouse-track-highlight
 		       (vm-su-start-of m)
-		       (vm-su-end-of m))))
+		       (vm-su-end-of m)
+		       (vm-su-summary-mouse-track-overlay-of m))))
 		(vm-set-su-start-of m (vm-marker (vm-su-start-of m)))
 		(vm-set-su-end-of m (vm-marker (vm-su-end-of m)))
 		(setq mp (cdr mp))))
     ;; The local variable name `vm-su-message' is mandatory here for
     ;; the format s-expression to work.
     (let ((vm-su-message message))
-      (eval (cdr match)))))
+      (if (or tokenize (null vm-display-using-mime))
+	  (eval (cdr match))
+	(vm-decode-mime-encoded-words-in-string (eval (cdr match)))))))
 
 (defun vm-summary-compile-format (format tokenize)
   (let ((return-value (vm-summary-compile-format-1 format tokenize)))
 ;;; Thread support for VM
-;;; Copyright (C) 1994 Kyle E. Jones
+;;; Copyright (C) 1994, 2001 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
 (defun vm-thread-list (message)
   (let ((done nil)
 	(m message)
+	(loop-recovery-point nil)
 	thread-list id-sym subject-sym loop-sym root-date)
     (save-excursion
       (set-buffer (vm-buffer-of m))
+      (fillarray vm-thread-loop-obarray 0)
       (setq id-sym (intern (vm-su-message-id m) vm-thread-obarray)
 	    thread-list (list id-sym))
-      (fillarray vm-thread-loop-obarray 0)
+      (set (intern (symbol-name id-sym) vm-thread-loop-obarray) t)
       (while (not done)
-	(setq loop-sym (intern (symbol-name id-sym) vm-thread-loop-obarray))
-	(if (boundp loop-sym)
-	    ;; loop detected, bail...
-	    (setq done t)
-	  (set loop-sym t)
-	  (if (and (boundp id-sym) (symbol-value id-sym))
-	      (progn
-		(setq id-sym (symbol-value id-sym)
-		      thread-list (cons id-sym thread-list)
-		      m (car (get id-sym 'messages))))
-	    (if (null m)
-		(setq done t)
-	      (if (null vm-thread-using-subject)
-		  nil
-		(setq subject-sym
-		      (intern (vm-so-sortable-subject m)
-			      vm-thread-subject-obarray))
-		(if (or (not (boundp subject-sym))
-			(eq (aref (symbol-value subject-sym) 0) id-sym))
-		    (setq done t)
-		  (setq id-sym (aref (symbol-value subject-sym) 0)
-			thread-list (cons id-sym thread-list)
+	(if (and (boundp id-sym) (symbol-value id-sym))
+	    (progn
+	      (setq id-sym (symbol-value id-sym)
+		    loop-sym (intern (symbol-name id-sym)
+				     vm-thread-loop-obarray))
+	      (if (boundp loop-sym)
+		  ;; loop detected, bail...
+		  (setq done t
+			thread-list (or loop-recovery-point thread-list))
+		(set loop-sym t)
+		(setq thread-list (cons id-sym thread-list)
+		      m (car (get id-sym 'messages)))))
+	  (if (null m)
+	      (setq done t)
+	    (if (null vm-thread-using-subject)
+		nil
+	      (setq subject-sym
+		    (intern (vm-so-sortable-subject m)
+			    vm-thread-subject-obarray))
+	      (if (or (not (boundp subject-sym))
+		      (eq (aref (symbol-value subject-sym) 0) id-sym))
+		  (setq done t)
+		(setq id-sym (aref (symbol-value subject-sym) 0)
+		      loop-recovery-point (or loop-recovery-point
+					      thread-list)
+		      loop-sym (intern (symbol-name id-sym)
+				       vm-thread-loop-obarray))
+		(if (boundp loop-sym)
+		    ;; loop detected, bail...
+		    (setq done t
+			  thread-list (or loop-recovery-point thread-list))
+		  (set loop-sym t)
+		  (setq thread-list (cons id-sym thread-list)
 			m (car (get id-sym 'messages)))))))))
       ;; save the date of the oldest message in this thread
       (setq root-date (get id-sym 'oldest-date))
 ;;; Toolbar related functions and commands
-;;; Copyright (C) 1995-1997, 2000 Kyle E. Jones
+;;; Copyright (C) 1995-1997, 2000, 2001 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
     ("\\.au$"		.	"audio/basic")
     ("\\.mpe?g$" 	.	"video/mpeg")
     ("\\.mov$" 		.	"video/quicktime")
-    ("\\.ps$"		.	"application/postscript")
+    ("\\.e?ps$"		.	"application/postscript")
     ("\\.pdf$"		.	"application/pdf")
     ("\\.xls$"		.	"application/vnd.ms-excel")
    )
 
 (provide 'vm-version)
 
-(defconst vm-version "6.95"
+(defconst vm-version "6.96"
   "Version number of VM.")
 
 (defun vm-version ()
  
 (defun vm-toolbar-support-possible-p ()
   (or (and vm-xemacs-p (featurep 'toolbar))
-      (and vm-fsfemacs-p (fboundp 'tool-bar-mode))))
+      (and vm-fsfemacs-p (fboundp 'tool-bar-mode) (boundp 'tool-bar-map))))
 
 (defun vm-multiple-fonts-possible-p ()
   (cond (vm-xemacs-p