Mercurial > hg > xemacs-beta
diff lisp/vm/vm-virtual.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-virtual.el Mon Aug 13 09:00:04 2007 +0200 +++ b/lisp/vm/vm-virtual.el Mon Aug 13 09:02:59 2007 +0200 @@ -1,5 +1,5 @@ ;;; Virtual folders for VM -;;; Copyright (C) 1990-1997 Kyle E. Jones +;;; Copyright (C) 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 @@ -31,197 +31,218 @@ ;; ;; The messages in new-messages must all be in the same real folder. (defun vm-build-virtual-message-list (new-messages) - (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) - (let ((inhibit-local-variables t) - (enable-local-variables nil)) - (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))) + (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 (vm-real-message-of (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)) + (if (null vm-real-buffers) + (setq vm-real-buffers real-buffers-used)) + (save-excursion + (while real-buffers-used + (set-buffer (car real-buffers-used)) + (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. @@ -248,13 +269,7 @@ (list name (list (list (list 'get-buffer (buffer-name))) (if arg (list selector arg) (list selector)))))) - (vm-visit-virtual-folder name read-only)) - ;; have to do this again here because the known virtual - ;; folder menu is now hosed because we installed it while - ;; vm-virtual-folder-alist was bound to the temp value above - (if vm-use-menus - (vm-menu-install-known-virtual-folders-menu))) - + (vm-visit-virtual-folder name read-only))) (defun vm-apply-virtual-folder (name &optional read-only) "Apply the selectors of a named virtual folder to the current folder @@ -281,12 +296,7 @@ (setq clauses (cdr clauses))) (setcar vfolder (format "%s/%s" (buffer-name) (car vfolder))) (setq vm-virtual-folder-alist (list vfolder)) - (vm-visit-virtual-folder (car vfolder) read-only)) - ;; have to do this again here because the known virtual - ;; folder menu is now hosed because we installed it while - ;; vm-virtual-folder-alist was bound to the temp value above - (if vm-use-menus - (vm-menu-install-known-virtual-folders-menu))) + (vm-visit-virtual-folder (car vfolder) read-only))) (defun vm-toggle-virtual-mirror () (interactive) @@ -342,6 +352,15 @@ (vm-display nil nil '(vm-virtual-help) '(vm-virtual-help)) (message "VV = visit, VA = apply selectors, VC = create, VM = toggle virtual mirror")) +(defun vm-delete-directory-file-names (list) + (vm-delete 'file-directory-p list)) + +(defun vm-delete-backup-file-names (list) + (vm-delete 'backup-file-name-p list)) + +(defun vm-delete-auto-save-file-names (list) + (vm-delete 'auto-save-file-name-p list)) + (defun vm-vs-or (m &rest selectors) (let ((result nil) selector arglist) (while selectors @@ -388,8 +407,8 @@ (save-excursion (save-restriction (widen) - (goto-char (vm-headers-of (vm-real-message-of m))) - (re-search-forward arg (vm-text-of (vm-real-message-of m)) t)))) + (goto-char (vm-headers-of m)) + (re-search-forward arg (vm-text-of m) t)))) (defun vm-vs-label (m arg) (vm-member arg (vm-labels-of m))) @@ -398,8 +417,8 @@ (save-excursion (save-restriction (widen) - (goto-char (vm-text-of (vm-real-message-of m))) - (re-search-forward arg (vm-text-end-of (vm-real-message-of m)) t)))) + (goto-char (vm-text-of m)) + (re-search-forward arg (vm-text-end-of m) t)))) (defun vm-vs-more-chars-than (m arg) (> (string-to-int (vm-su-byte-count m)) arg)) @@ -466,8 +485,6 @@ vm-label-obarray) nil))))) (t (setq arg (read-string prompt)))))) - (or (fboundp (intern (concat "vm-vs-" (symbol-name selector)))) - (error "Invalid selector")) (list selector arg))) ;; clear away links between real and virtual folders when @@ -519,28 +536,22 @@ (setq vm-real-buffers (delq b vm-real-buffers)) ;; set the message pointer to a new value if it is ;; now invalid. - (cond - ((and vm-message-pointer - (equal "Q" (vm-message-id-number-of - (car vm-message-pointer)))) - (vm-garbage-collect-message) - (setq vmp vm-message-pointer) - (while (and vm-message-pointer - (equal "Q" (vm-message-id-number-of - (car vm-message-pointer)))) - (setq vm-message-pointer - (cdr vm-message-pointer))) - ;; if there were no good messages ahead, try going - ;; backward. - (if (null vm-message-pointer) - (progn - (setq vm-message-pointer vmp) - (while (and vm-message-pointer - (equal "Q" (vm-message-id-number-of - (car vm-message-pointer)))) - (setq vm-message-pointer - (vm-reverse-link-of - (car vm-message-pointer)))))))) + (setq vmp vm-message-pointer) + (while (and vm-message-pointer + (equal "Q" (vm-message-id-number-of + (car vm-message-pointer)))) + (setq vm-message-pointer + (cdr vm-message-pointer))) + ;; if there were no good messages ahead, try going + ;; backward. + (if (null vm-message-pointer) + (progn + (setq vm-message-pointer vmp) + (while (and vm-message-pointer + (equal "Q" (vm-message-id-number-of + (car vm-message-pointer)))) + (setq vm-message-pointer + (vm-reverse-link-of (car vm-message-pointer)))))) ;; expunge the virtual messages associated with ;; real messages that are going away. (setq vm-message-list