diff lisp/vm/vm-virtual.el @ 100:4be1180a9e89 r20-1b2

Import from CVS: tag r20-1b2
author cvs
date Mon, 13 Aug 2007 09:15:11 +0200
parents 0d2f883870bc
children a145efe76779
line wrap: on
line diff
--- a/lisp/vm/vm-virtual.el	Mon Aug 13 09:13:58 2007 +0200
+++ b/lisp/vm/vm-virtual.el	Mon Aug 13 09:15:11 2007 +0200
@@ -31,223 +31,195 @@
 ;;
 ;; The messages in new-messages must all be in the same real folder.
 (defun vm-build-virtual-message-list (new-messages)
-  (let ((clauses (cdr vm-virtual-folder-definition))
-
-	(message-set (make-vector 311 0))
-	(vbuffer (current-buffer))
-	(mirrored vm-virtual-mirror)
-	(case-fold-search t)
-	(tail-cons (vm-last vm-message-list))
-	(new-message-list nil)
-
-	;; selectors
-	(any 'vm-vs-any)
-	(and 'vm-vs-and)
-	(or 'vm-vs-or)
-	(not 'vm-vs-not)
-	(header 'vm-vs-header)
-	(label 'vm-vs-label)
-	(text 'vm-vs-text)
-	(recipient 'vm-vs-recipient)
-	(author 'vm-vs-author)
-	(subject 'vm-vs-subject)
-	(sent-before 'vm-vs-sent-before)
-	(sent-after 'vm-vs-sent-after)
-	(more-chars-than 'vm-vs-more-chars-than)
-	(less-chars-than 'vm-vs-less-chars-than)
-	(more-lines-than 'vm-vs-more-lines-than)
-	(less-lines-than 'vm-vs-less-lines-than)
-	(new 'vm-vs-new)
-	(unread 'vm-vs-unread)
-	(read 'vm-vs-read)
-	(deleted 'vm-vs-deleted)
-	(replied 'vm-vs-replied)
-	(forwarded 'vm-vs-forwarded)
-	(filed 'vm-vs-filed)
-	(written 'vm-vs-written)
-	(edited 'vm-vs-edited)
-	(marked 'vm-vs-marked)
-
-	virtual location-vector
-	message mp folders folder
-	selectors sel-list selector arglist i
-	real-buffers-used)
-    ;; Since there is at most one virtual message in the folder
-    ;; buffer of a virtual folder, the location data vector (and
-    ;; the markers in it) of all virtual messages in a virtual
-    ;; folder is shared.  We initialize the vector here if it
-    ;; hasn't been created already.
-    (if vm-message-list
-	(setq location-vector (vm-location-data-of (car vm-message-pointer)))
-      (setq i 0
-	    location-vector (make-vector vm-location-data-vector-length nil))
-      (while (< i vm-location-data-vector-length)
-	(aset location-vector i (vm-marker nil))
-	(vm-increment i)))
-    ;; To keep track of the messages in a virtual folder to
-    ;; prevent duplicates we create and maintain a set that
-    ;; contain all the real messages.
-    (setq mp vm-message-list)
-    (while mp
-      (intern (vm-message-id-number-of (vm-real-message-of (car mp)))
-	      message-set)
-      (setq mp (cdr mp)))
-    ;; now select the messages
-    (save-excursion
-      (while clauses
-	(setq folders (car (car clauses))
-	      selectors (cdr (car clauses)))
-	(while folders
-	  (setq folder (car folders))
-	  (and (stringp folder)
-	       (setq folder (expand-file-name folder vm-folder-directory)))
-	  (and (listp folder)
-	       (setq folder (eval folder)))
-	  (cond
-	   ((null folder)
-	    ;; folder was a s-expr which returned nil
-	    ;; skip it
-	    nil )
-	   ((and (stringp folder) (file-directory-p folder))
-	    (setq folders (nconc folders
-				 (vm-delete-backup-file-names
-				  (vm-delete-auto-save-file-names
-				   (vm-delete-directory-file-names
-				    (directory-files folder t nil)))))))
-	   ((or (null new-messages)
-		;; If we're assimilating messages into an
-		;; existing virtual folder, only allow selectors
-		;; that would be normally applied to this folder.
-		(and (bufferp folder)
-		     (eq (vm-buffer-of (car new-messages)) folder))
-		(and (stringp folder)
-		     (eq (vm-buffer-of (car new-messages))
-			 ;; letter bomb protection
-			 ;; set inhibit-local-variables to t for v18 Emacses
-			 ;; set enable-local-variables to nil for newer Emacses
-			 (let ((inhibit-local-variables t)
-			       (enable-local-variables nil))
-			   (find-file-noselect folder)))))
-	    (set-buffer (or (and (bufferp folder) folder)
-			    (vm-get-file-buffer folder)
-			    (find-file-noselect folder)))
-	    (if (eq major-mode 'vm-virtual-mode)
-		(setq virtual t
-		      real-buffers-used
-		      (append vm-real-buffers real-buffers-used))
-	      (setq virtual nil)
-	      (if (not (memq (current-buffer) real-buffers-used))
-		  (setq real-buffers-used (cons (current-buffer)
-						real-buffers-used)))
-	      (if (not (eq major-mode 'vm-mode))
-		  (vm-mode)))
-	    ;; change (sexpr) into ("/file" "/file2" ...)
-	    ;; this assumes that there will never be (sexpr sexpr2)
-	    ;; in a virtual folder spec.
-	    (if (bufferp folder)
-		(if virtual
-		    (setcar (car clauses)
-			    (delq nil
-				  (mapcar 'buffer-file-name vm-real-buffers)))
-		  (if buffer-file-name
-		      (setcar (car clauses) (list buffer-file-name)))))
-	    ;; if new-messages non-nil use it instead of the
-	    ;; whole message list
-	    (setq mp (or new-messages vm-message-list))
-	    (while mp
-	      (if (and (not (intern-soft
-			     (vm-message-id-number-of
-			      (vm-real-message-of (car mp)))
-			     message-set))
-		       (if virtual
-			   (save-excursion
-			     (set-buffer
-			      (vm-buffer-of
-			       (vm-real-message-of
-				(car mp))))
-			     (apply 'vm-vs-or (car mp) selectors))
-			 (apply 'vm-vs-or (car mp) selectors)))
-		  (progn
-		    (intern
-		     (vm-message-id-number-of
-		      (vm-real-message-of (car mp)))
+  (vm-with-virtual-selector-variables
+   (let ((clauses (cdr vm-virtual-folder-definition))
+	 (message-set (make-vector 311 0))
+	 (vbuffer (current-buffer))
+	 (mirrored vm-virtual-mirror)
+	 (case-fold-search t)
+	 (tail-cons (vm-last vm-message-list))
+	 (new-message-list nil)
+	 virtual location-vector
+	 message mp folders folder
+	 selectors sel-list selector arglist i
+	 real-buffers-used)
+     ;; Since there is at most one virtual message in the folder
+     ;; buffer of a virtual folder, the location data vector (and
+     ;; the markers in it) of all virtual messages in a virtual
+     ;; folder is shared.  We initialize the vector here if it
+     ;; hasn't been created already.
+     (if vm-message-list
+	 (setq location-vector (vm-location-data-of (car vm-message-pointer)))
+       (setq i 0
+	     location-vector (make-vector vm-location-data-vector-length nil))
+       (while (< i vm-location-data-vector-length)
+	 (aset location-vector i (vm-marker nil))
+	 (vm-increment i)))
+     ;; To keep track of the messages in a virtual folder to
+     ;; prevent duplicates we create and maintain a set that
+     ;; contain all the real messages.
+     (setq mp vm-message-list)
+     (while mp
+       (intern (vm-message-id-number-of (vm-real-message-of (car mp)))
+	       message-set)
+       (setq mp (cdr mp)))
+     ;; now select the messages
+     (save-excursion
+       (while clauses
+	 (setq folders (car (car clauses))
+	       selectors (cdr (car clauses)))
+	 (while folders
+	   (setq folder (car folders))
+	   (and (stringp folder)
+		(setq folder (expand-file-name folder vm-folder-directory)))
+	   (and (listp folder)
+		(setq folder (eval folder)))
+	   (cond
+	    ((null folder)
+	     ;; folder was a s-expr which returned nil
+	     ;; skip it
+	     nil )
+	    ((and (stringp folder) (file-directory-p folder))
+	     (setq folders (nconc folders
+				  (vm-delete-backup-file-names
+				   (vm-delete-auto-save-file-names
+				    (vm-delete-directory-file-names
+				     (directory-files folder t nil)))))))
+	    ((or (null new-messages)
+		 ;; If we're assimilating messages into an
+		 ;; existing virtual folder, only allow selectors
+		 ;; that would be normally applied to this folder.
+		 (and (bufferp folder)
+		      (eq (vm-buffer-of (car new-messages)) folder))
+		 (and (stringp folder)
+		      (eq (vm-buffer-of (car new-messages))
+			  ;; letter bomb protection
+			  ;; set inhibit-local-variables to t for v18 Emacses
+			  ;; set enable-local-variables to nil
+			  ;; for newer Emacses
+			  (let ((inhibit-local-variables t)
+				(enable-local-variables nil))
+			    (find-file-noselect folder)))))
+	     (set-buffer (or (and (bufferp folder) folder)
+			     (vm-get-file-buffer folder)
+			     (find-file-noselect folder)))
+	     (if (eq major-mode 'vm-virtual-mode)
+		 (setq virtual t
+		       real-buffers-used
+		       (append vm-real-buffers real-buffers-used))
+	       (setq virtual nil)
+	       (if (not (memq (current-buffer) real-buffers-used))
+		   (setq real-buffers-used (cons (current-buffer)
+						 real-buffers-used)))
+	       (if (not (eq major-mode 'vm-mode))
+		   (vm-mode)))
+	     ;; change (sexpr) into ("/file" "/file2" ...)
+	     ;; this assumes that there will never be (sexpr sexpr2)
+	     ;; in a virtual folder spec.
+	     (if (bufferp folder)
+		 (if virtual
+		     (setcar (car clauses)
+			     (delq nil
+				   (mapcar 'buffer-file-name vm-real-buffers)))
+		   (if buffer-file-name
+		       (setcar (car clauses) (list buffer-file-name)))))
+	     ;; if new-messages non-nil use it instead of the
+	     ;; whole message list
+	     (setq mp (or new-messages vm-message-list))
+	     (while mp
+	       (if (and (not (intern-soft
+			      (vm-message-id-number-of
+			       (vm-real-message-of (car mp)))
+			      message-set))
+			(if virtual
+			    (save-excursion
+			      (set-buffer
+			       (vm-buffer-of
+				(vm-real-message-of
+				 (car mp))))
+			      (apply 'vm-vs-or (car mp) selectors))
+			  (apply 'vm-vs-or (car mp) selectors)))
+		   (progn
+		     (intern
+		      (vm-message-id-number-of
+		       (vm-real-message-of (car mp)))
 		      message-set)
-		    (setq message (copy-sequence
-				   (vm-real-message-of (car mp))))
-		    (if mirrored
-			()
-		      (vm-set-mirror-data-of
-		       message
-		       (make-vector vm-mirror-data-vector-length nil))
-		      (vm-set-virtual-messages-sym-of
-		       message (make-symbol "<v>"))
-		      (vm-set-virtual-messages-of message nil)
-		      (vm-set-attributes-of
-		       message
-		       (make-vector vm-attributes-vector-length nil)))
-		    (vm-set-location-data-of message location-vector)
-		    (vm-set-softdata-of
-		     message
-		     (make-vector vm-softdata-vector-length nil))
-		    (vm-set-real-message-sym-of
-		     message
-		     (vm-real-message-sym-of (car mp)))
-		    (vm-set-message-type-of message vm-folder-type)
-		    (vm-set-message-id-number-of message
-						 vm-message-id-number)
-		    (vm-increment vm-message-id-number)
-		    (vm-set-buffer-of message vbuffer)
-		    (vm-set-reverse-link-sym-of message (make-symbol "<--"))
-		    (vm-set-reverse-link-of message tail-cons)
-		    (if (null tail-cons)
-			(setq new-message-list (list message)
-			      tail-cons new-message-list)
-		      (setcdr tail-cons (list message))
-		      (if (null new-message-list)
-			  (setq new-message-list (cdr tail-cons)))
-		      (setq tail-cons (cdr tail-cons)))))
-	      (setq mp (cdr mp)))))
-	  (setq folders (cdr folders)))
-	(setq clauses (cdr clauses))))
-; this doesn't need to work currently, but it might someday
-;    (if virtual
-;	(setq real-buffers-used (vm-delete-duplicates real-buffers-used)))
-    (vm-increment vm-modification-counter)
-    ;; Until this point the user doesn't really have a virtual
-    ;; folder, as the virtual messages haven't been linked to the
-    ;; real messages, virtual buffers to the real buffers, and no
-    ;; message list has been installed.
-    ;;
-    ;; Now we tie it all together, with this section of code being
-    ;; uninterruptible.
-    (let ((inhibit-quit t)
-	  (label-obarray vm-label-obarray))
-      (if (null vm-real-buffers)
-	  (setq vm-real-buffers real-buffers-used))
-      (save-excursion
-	(while real-buffers-used
-	  (set-buffer (car real-buffers-used))
-	  ;; inherit the global label lists of all the associated
-	  ;; real folders.
-	  (mapatoms (function (lambda (x) (intern (symbol-name x)
-						  label-obarray)))
-		    vm-label-obarray)
-	  (if (not (memq vbuffer vm-virtual-buffers))
-	      (setq vm-virtual-buffers (cons vbuffer vm-virtual-buffers)))
-	  (setq real-buffers-used (cdr real-buffers-used))))
-      (setq mp new-message-list)
-      (while mp
-	(vm-set-virtual-messages-of
-	 (vm-real-message-of (car mp))
-	 (cons (car mp) (vm-virtual-messages-of (car mp))))
-	(setq mp (cdr mp)))
-      (if vm-message-list
-	  (progn
-	    (vm-set-summary-redo-start-point new-message-list)
-	    (vm-set-numbering-redo-start-point new-message-list))
-	(vm-set-summary-redo-start-point t)
-	(vm-set-numbering-redo-start-point t)
-	(setq vm-message-list new-message-list)))))
+		     (setq message (copy-sequence
+				    (vm-real-message-of (car mp))))
+		     (if mirrored
+			 ()
+		       (vm-set-mirror-data-of
+			message
+			(make-vector vm-mirror-data-vector-length nil))
+		       (vm-set-virtual-messages-sym-of
+			message (make-symbol "<v>"))
+		       (vm-set-virtual-messages-of message nil)
+		       (vm-set-attributes-of
+			message
+			(make-vector vm-attributes-vector-length nil)))
+		     (vm-set-location-data-of message location-vector)
+		     (vm-set-softdata-of
+		      message
+		      (make-vector vm-softdata-vector-length nil))
+		     (vm-set-real-message-sym-of
+		      message
+		      (vm-real-message-sym-of (car mp)))
+		     (vm-set-message-type-of message vm-folder-type)
+		     (vm-set-message-id-number-of message
+						  vm-message-id-number)
+		     (vm-increment vm-message-id-number)
+		     (vm-set-buffer-of message vbuffer)
+		     (vm-set-reverse-link-sym-of message (make-symbol "<--"))
+		     (vm-set-reverse-link-of message tail-cons)
+		     (if (null tail-cons)
+			 (setq new-message-list (list message)
+			       tail-cons new-message-list)
+		       (setcdr tail-cons (list message))
+		       (if (null new-message-list)
+			   (setq new-message-list (cdr tail-cons)))
+		       (setq tail-cons (cdr tail-cons)))))
+	       (setq mp (cdr mp)))))
+	   (setq folders (cdr folders)))
+	 (setq clauses (cdr clauses))))
+     ;; this doesn't need to work currently, but it might someday
+     ;; (if virtual
+     ;;	    (setq real-buffers-used (vm-delete-duplicates real-buffers-used)))
+     (vm-increment vm-modification-counter)
+     ;; Until this point the user doesn't really have a virtual
+     ;; folder, as the virtual messages haven't been linked to the
+     ;; real messages, virtual buffers to the real buffers, and no
+     ;; message list has been installed.
+     ;;
+     ;; Now we tie it all together, with this section of code being
+     ;; uninterruptible.
+     (let ((inhibit-quit t)
+	   (label-obarray vm-label-obarray))
+       (if (null vm-real-buffers)
+	   (setq vm-real-buffers real-buffers-used))
+       (save-excursion
+	 (while real-buffers-used
+	   (set-buffer (car real-buffers-used))
+	   ;; inherit the global label lists of all the associated
+	   ;; real folders.
+	   (mapatoms (function (lambda (x) (intern (symbol-name x)
+						   label-obarray)))
+		     vm-label-obarray)
+	   (if (not (memq vbuffer vm-virtual-buffers))
+	       (setq vm-virtual-buffers (cons vbuffer vm-virtual-buffers)))
+	   (setq real-buffers-used (cdr real-buffers-used))))
+       (setq mp new-message-list)
+       (while mp
+	 (vm-set-virtual-messages-of
+	  (vm-real-message-of (car mp))
+	  (cons (car mp) (vm-virtual-messages-of (car mp))))
+	 (setq mp (cdr mp)))
+       (if vm-message-list
+	   (progn
+	     (vm-set-summary-redo-start-point new-message-list)
+	     (vm-set-numbering-redo-start-point new-message-list))
+	 (vm-set-summary-redo-start-point t)
+	 (vm-set-numbering-redo-start-point t)
+	 (setq vm-message-list new-message-list))))))
 
 (defun vm-create-virtual-folder (selector &optional arg read-only)
   "Create a new virtual folder from messages in the current folder.