Mercurial > hg > xemacs-beta
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.