X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=wl%2Fwl-folder.el;h=4e53bb8d20bf6342bacd67fead019c70d8f82e27;hb=57f081e684a5f0a1de02c96bc61ec175784974bb;hp=d86f63e425a5c0cf3baf2276070a485eb8264f19;hpb=0fbd8fa3e611a5f03687ff7e11f98083d67bc1ce;p=elisp%2Fwanderlust.git diff --git a/wl/wl-folder.el b/wl/wl-folder.el index d86f63e..4e53bb8 100644 --- a/wl/wl-folder.el +++ b/wl/wl-folder.el @@ -46,6 +46,11 @@ (require 'wl) (require 'elmo-nntp)) +(defcustom wl-folder-init-hook nil + "A hook called after folder initialization is finished." + :type 'hook + :group 'wl) + (defvar wl-folder-buffer-name "Folder") (defvar wl-folder-entity nil) ; desktop entity. (defvar wl-folder-group-alist nil) ; opened or closed @@ -56,17 +61,18 @@ (defvar wl-folder-newsgroups-hashtb nil) (defvar wl-folder-info-alist-modified nil) -(defvar wl-folder-completion-function nil) (defvar wl-folder-mode-map nil) (defvar wl-folder-buffer-disp-summary nil) (defvar wl-folder-buffer-cur-entity-id nil) +(defvar wl-folder-buffer-last-visited-entity-id nil) (defvar wl-folder-buffer-cur-path nil) (defvar wl-folder-buffer-cur-point nil) (make-variable-buffer-local 'wl-folder-buffer-disp-summary) (make-variable-buffer-local 'wl-folder-buffer-cur-entity-id) +(make-variable-buffer-local 'wl-folder-buffer-last-visited-entity-id) (make-variable-buffer-local 'wl-folder-buffer-cur-path) (make-variable-buffer-local 'wl-folder-buffer-cur-point) @@ -84,10 +90,14 @@ ["Sync Current Folder" wl-folder-sync-current-entity t] ; ["Drop Current Folder" wl-folder-drop-unsync-current-entity t] ["Prefetch Current Folder" wl-folder-prefetch-current-entity t] + "----" ["Mark as Read all Current Folder" wl-folder-mark-as-read-all-current-entity t] ["Expire Current Folder" wl-folder-expire-current-entity t] + "----" + ["Go to Draft Folder" wl-folder-goto-draft-folder t] ["Empty trash" wl-folder-empty-trash t] ["Flush queue" wl-folder-flush-queue t] + "----" ["Open All" wl-folder-open-all t] ["Open All Unread folder" wl-folder-open-all-unread-folder t] ["Close All" wl-folder-close-all t] @@ -105,12 +115,15 @@ ["Display all" wl-fldmgr-access-display-all t]) "----" ["Write a message" wl-draft t] + ["Write for current folder" wl-folder-write-current-folder t] + "----" + ["Wanderlust NEWS" wl-news t] "----" ["Toggle Plug Status" wl-toggle-plugged t] ["Change Plug Status" wl-plugged-change t] "----" ["Save Current Status" wl-save t] - ["Update Satus" wl-status-update t] + ["Update Status" wl-status-update t] ["Exit" wl-exit t] )) @@ -137,15 +150,20 @@ ; (define-key wl-folder-mode-map "\M- " 'wl-folder-open-close) (define-key wl-folder-mode-map "/" 'wl-folder-open-close) (define-key wl-folder-mode-map "\C-m" 'wl-folder-jump-to-current-entity) + (define-key wl-folder-mode-map [(shift return)] 'wl-folder-jump-to-current-entity-with-arg) (define-key wl-folder-mode-map "\M-\C-m" 'wl-folder-update-recursive-current-entity) (define-key wl-folder-mode-map "rc" 'wl-folder-mark-as-read-all-region) (define-key wl-folder-mode-map "c" 'wl-folder-mark-as-read-all-current-entity) (define-key wl-folder-mode-map "g" 'wl-folder-goto-folder) + (define-key wl-folder-mode-map "G" 'wl-folder-goto-folder-sticky) (define-key wl-folder-mode-map "j" 'wl-folder-jump-to-current-entity) + (define-key wl-folder-mode-map "\C-i" 'wl-folder-revisit-last-visited-folder) (define-key wl-folder-mode-map "w" 'wl-draft) (define-key wl-folder-mode-map "W" 'wl-folder-write-current-folder) (define-key wl-folder-mode-map "\C-c\C-o" 'wl-jump-to-draft-buffer) (define-key wl-folder-mode-map "\C-c\C-a" 'wl-addrmgr) + (define-key wl-folder-mode-map "\C-c\C-p" 'wl-folder-jump-to-previous-summary) + (define-key wl-folder-mode-map "\C-c\C-n" 'wl-folder-jump-to-next-summary) (define-key wl-folder-mode-map "rS" 'wl-folder-sync-region) (define-key wl-folder-mode-map "S" 'wl-folder-sync-current-entity) (define-key wl-folder-mode-map "rs" 'wl-folder-check-region) @@ -165,8 +183,11 @@ (define-key wl-folder-mode-map "e" 'wl-folder-expire-current-entity) (define-key wl-folder-mode-map "E" 'wl-folder-empty-trash) (define-key wl-folder-mode-map "F" 'wl-folder-flush-queue) + (define-key wl-folder-mode-map "V" 'wl-folder-virtual) + (define-key wl-folder-mode-map "?" 'wl-folder-pick) (define-key wl-folder-mode-map "q" 'wl-exit) (define-key wl-folder-mode-map "z" 'wl-folder-suspend) + (define-key wl-folder-mode-map "x" 'wl-execute-temp-marks) (define-key wl-folder-mode-map "\M-t" 'wl-toggle-plugged) (define-key wl-folder-mode-map "\C-t" 'wl-plugged-change) (define-key wl-folder-mode-map "<" 'beginning-of-buffer) @@ -210,34 +231,34 @@ "")))) (defmacro wl-folder-buffer-group-p () - (` (save-excursion (beginning-of-line) - (looking-at wl-folder-group-regexp)))) - -(defmacro wl-folder-folder-name () - (` (save-excursion - (beginning-of-line) - (if (or (looking-at "^[ ]*\\[[\\+-]\\]\\(.+\\):[-0-9\\*-]+/[0-9\\*-]+/[0-9\\*-]+\n") - (looking-at "^[ ]*\\([^\\[].+\\):.*\n")) - (wl-match-buffer 1))))) - -(defmacro wl-folder-entity-name () - (` (save-excursion - (beginning-of-line) - (if (looking-at "^[ ]*\\([^\\[].+\\):.*\n") - (wl-match-buffer 1))))) + (` (get-text-property (point) 'wl-folder-is-group))) (defun wl-folder-buffer-search-group (group) - (re-search-forward - (concat - "^\\([ \t]*\\)\\[[\\+-]\\]" - (regexp-quote group) ":[-0-9-]+/[0-9-]+/[0-9-]+") nil t)) + (let ((prev-point (point)) + (group-regexp (concat + "^\\([ \t]*\\)\\[[\\+-]\\]" + (regexp-quote group) ":[-0-9-]+/[0-9-]+/[0-9-]+"))) + (or (catch 'found + (while (re-search-forward group-regexp nil t) + (if (wl-folder-buffer-group-p) + (throw 'found (point))))) + (progn ; not found + (goto-char prev-point) + nil)))) (defun wl-folder-buffer-search-entity (folder &optional searchname) - (let ((search (or searchname (wl-folder-get-petname folder)))) - (re-search-forward - (concat - "^[ \t]*" - (regexp-quote search) ":[-0-9\\*-]+/[0-9\\*-]+/[0-9\\*-]+") nil t))) + (let ((search (or searchname (wl-folder-get-petname folder))) + case-fold-search + result) + (catch 'found + (while (setq result + (re-search-forward + (concat + "^[ \t]*" + (regexp-quote search) ":[-0-9\\*-]+/[0-9\\*-]+/[0-9\\*-]+") + nil t)) + (when (string= (wl-folder-get-entity-from-buffer) folder) + (throw 'found result)))))) (defsubst wl-folder-get-folder-name-by-id (entity-id &optional hashtb) (and (numberp entity-id) @@ -250,19 +271,14 @@ entity (or hashtb wl-folder-entity-id-name-hashtb)))) (defmacro wl-folder-get-entity-id (entity) - (` (or (get-text-property 0 - 'wl-folder-entity-id - (, entity)) - (, entity)))) ;; for nemacs + `(get-text-property 0 'wl-folder-entity-id ,entity)) (defmacro wl-folder-get-entity-from-buffer (&optional getid) - (` (let ((id (get-text-property (point) - 'wl-folder-entity-id))) - (if (not id) ;; for nemacs - (wl-folder-get-realname (wl-folder-folder-name)) - (if (, getid) - id - (wl-folder-get-folder-name-by-id id)))))) + `(let ((id (get-text-property (point) + 'wl-folder-entity-id))) + (if ,getid + id + (wl-folder-get-folder-name-by-id id)))) (defmacro wl-folder-entity-exists-p (entity &optional hashtb) (` (let ((sym (intern-soft (, entity) @@ -270,10 +286,7 @@ (and sym (boundp sym))))) (defmacro wl-folder-clear-entity-info (entity &optional hashtb) - (` (let ((sym (intern-soft (, entity) - (or (, hashtb) wl-folder-entity-hashtb)))) - (if (boundp sym) - (makunbound sym))))) + (` (elmo-clear-hash-val (, entity) (or (, hashtb) wl-folder-entity-hashtb)))) (defmacro wl-folder-get-entity-info (entity &optional hashtb) (` (elmo-get-hash-val (, entity) (or (, hashtb) wl-folder-entity-hashtb)))) @@ -281,7 +294,7 @@ (defmacro wl-folder-set-entity-info (entity value &optional hashtb) (` (let* ((hashtb (or (, hashtb) wl-folder-entity-hashtb)) (info (wl-folder-get-entity-info (, entity) hashtb))) - (elmo-set-hash-val (, entity) + (elmo-set-hash-val (elmo-string (, entity)) (if (< (length (, value)) 4) (append (, value) (list (nth 3 info))) (, value)) @@ -305,14 +318,6 @@ (setq li (cdr li)))))))) ;;; ELMO folder structure with cache. -(defmacro wl-folder-get-elmo-folder (entity) - "Get elmo folder structure from entity." - (` (or (wl-folder-elmo-folder-cache-get (, entity)) - (let* ((name (elmo-string (, entity))) - (folder (elmo-make-folder name))) - (wl-folder-elmo-folder-cache-put name folder) - folder)))) - (defmacro wl-folder-elmo-folder-cache-get (name &optional hashtb) "Returns a elmo folder structure associated with NAME from HASHTB. Default HASHTB is `wl-folder-elmo-folder-hashtb'." @@ -325,6 +330,33 @@ Default HASHTB is `wl-folder-elmo-folder-hashtb'." (` (elmo-set-hash-val (, name) (, folder) (or (, hashtb) wl-folder-elmo-folder-hashtb)))) +(defun wl-draft-get-folder () + "A function to obtain `opened' draft elmo folder structure." + (if (and wl-draft-folder-internal + (string= (elmo-folder-name-internal wl-draft-folder-internal) + wl-draft-folder)) + wl-draft-folder-internal + (setq wl-draft-folder-internal (elmo-make-folder wl-draft-folder)) + (wl-folder-confirm-existence wl-draft-folder-internal) + (elmo-folder-open wl-draft-folder-internal 'load-msgdb) + wl-draft-folder-internal)) + +(defmacro wl-folder-get-elmo-folder (entity &optional no-cache) + "Get elmo folder structure from ENTITY." + `(if ,no-cache + (elmo-make-folder (elmo-string ,entity)) + (if (string= (elmo-string ,entity) wl-draft-folder) + (wl-draft-get-folder) + (or (wl-folder-elmo-folder-cache-get ,entity) + (let* ((name (elmo-string ,entity)) + (folder (elmo-make-folder name))) + (wl-folder-elmo-folder-cache-put name folder) + folder))))) + +(defsubst wl-folder-put-folder-property (beg end id is-group &optional object) + (put-text-property beg end 'wl-folder-entity-id id object) + (put-text-property beg end 'wl-folder-is-group is-group object)) + (defun wl-folder-prev-entity () (interactive) (forward-line -1)) @@ -334,7 +366,7 @@ Default HASHTB is `wl-folder-elmo-folder-hashtb'." (forward-line 1)) (defun wl-folder-prev-entity-skip-invalid (&optional hereto) - "move to previous entity. skip unsubscribed or removed entity." + "Move to previous entity. skip unsubscribed or removed entity." (interactive) (if hereto (end-of-line)) @@ -414,8 +446,7 @@ Default HASHTB is `wl-folder-elmo-folder-hashtb'." (setq entities (nth 2 entity))) ((stringp entity) (if (and (string= name entity) - ;; don't use eq, `id' is string on Nemacs. - (equal id (wl-folder-get-entity-id entity))) + (eq id (wl-folder-get-entity-id entity))) (throw 'done last-entity)) (if (or (not unread) (and (setq finfo (wl-folder-get-entity-info entity)) @@ -450,8 +481,7 @@ Default HASHTB is `wl-folder-elmo-folder-hashtb'." (> (+ (nth 0 finfo)(nth 1 finfo)) 0))) (throw 'done entity)) (if (and (string= name entity) - ;; don't use eq, `id' is string on Nemacs. - (equal id (wl-folder-get-entity-id entity))) + (eq id (wl-folder-get-entity-id entity))) (setq found t))))) (unless entities (setq entities (wl-pop entity-stack))))))) @@ -464,7 +494,7 @@ Default HASHTB is `wl-folder-elmo-folder-hashtb'." (wl-plugged t) emptied) (if elmo-enable-disconnected-operation - (elmo-dop-queue-flush 'force)) ; Try flushing all queue. + (elmo-dop-queue-flush)) (if (not (elmo-folder-list-messages (wl-folder-get-elmo-folder wl-queue-folder))) (message "No sending queue exists.") @@ -481,17 +511,31 @@ Default HASHTB is `wl-folder-elmo-folder-hashtb'." (wl-folder-toggle-disp-summary 'off wl-queue-folder) (switch-to-buffer cur-buf)))))) +(defun wl-folder-set-persistent-mark (folder number flag) + "Set a persistent mark which corresponds to the specified flag on message." + (let ((buffer (wl-summary-get-buffer folder)) + elmo-folder) + (if buffer + (with-current-buffer buffer + (wl-summary-set-persistent-mark flag number)) + ;; Parent buffer does not exist. + (when (setq elmo-folder (and folder + (wl-folder-get-elmo-folder folder))) + (elmo-folder-open elmo-folder 'load-msgdb) + (elmo-folder-set-flag elmo-folder (list wl-draft-parent-number) flag) + (elmo-folder-close elmo-folder))))) + (defun wl-folder-empty-trash () "Empty trash." (interactive) (let ((cur-buf (current-buffer)) (wl-auto-select-first nil) trash-buf emptied) + (wl-summary-goto-folder-subr wl-trash-folder 'force-update) + (setq trash-buf (wl-summary-get-buffer-create wl-trash-folder)) (if wl-stay-folder-window - (wl-folder-select-buffer - (wl-summary-get-buffer-create wl-trash-folder))) - (wl-summary-goto-folder-subr wl-trash-folder 'force-update nil nil t) - (setq trash-buf (current-buffer)) + (wl-folder-select-buffer trash-buf) + (switch-to-buffer trash-buf)) (unwind-protect (setq emptied (wl-summary-delete-all-msgs)) (when emptied @@ -537,7 +581,7 @@ Optional argument ARG is repeart count." (throw 'done t)) (goto-char (point-max)))) -(defsubst wl-folder-update-group (entity diffs &optional is-group) +(defun wl-folder-update-group (entity diffs &optional is-group) (save-excursion (let ((path (wl-folder-get-path wl-folder-entity @@ -583,72 +627,79 @@ Optional argument ARG is repeart count." (t wl-force-fetch-folders))) +(defun wl-folder-jump-to-current-entity-with-arg () + (interactive) + (wl-folder-jump-to-current-entity t)) + (defun wl-folder-jump-to-current-entity (&optional arg) "Enter the current folder. If optional ARG exists, update folder list." (interactive "P") - (beginning-of-line) - (let (entity beg end indent opened fname err fld-name) - (cond - ((looking-at wl-folder-group-regexp) - (save-excursion - (setq fname (wl-folder-get-realname (wl-match-buffer 3))) - (setq indent (wl-match-buffer 1)) - (setq opened (wl-match-buffer 2)) - (if (string= opened "+") - (progn - (setq entity (wl-folder-search-group-entity-by-name - fname - wl-folder-entity)) - (setq beg (point)) - (if arg - (wl-folder-update-recursive-current-entity entity) - ;; insert as opened - (setcdr (assoc (car entity) wl-folder-group-alist) t) - (if (eq 'access (cadr entity)) - (wl-folder-maybe-load-folder-list entity)) - ;(condition-case errobj - (progn - (if (or (wl-folder-force-fetch-p (car entity)) - (and - (eq 'access (cadr entity)) - (null (caddr entity)))) - (wl-folder-update-newest indent entity) - (wl-folder-insert-entity indent entity)) - (wl-highlight-folder-path wl-folder-buffer-cur-path)) - ; (quit - ; (setq err t) - ; (setcdr (assoc fname wl-folder-group-alist) nil)) - ; (error - ; (elmo-display-error errobj t) - ; (ding) - ; (setq err t) - ; (setcdr (assoc fname wl-folder-group-alist) nil))) - (if (not err) - (let ((buffer-read-only nil)) - (delete-region (save-excursion (beginning-of-line) - (point)) - (save-excursion (end-of-line) - (+ 1 (point)))))))) - (setq beg (point)) - (end-of-line) - (save-match-data - (setq end - (progn (wl-folder-goto-bottom-of-current-folder indent) - (beginning-of-line) - (point)))) - (setq entity (wl-folder-search-group-entity-by-name - fname - wl-folder-entity)) - (let ((buffer-read-only nil)) - (delete-region beg end)) - (setcdr (assoc (car entity) wl-folder-group-alist) nil) - (wl-folder-insert-entity indent entity) ; insert entity - (forward-line -1) - (wl-highlight-folder-path wl-folder-buffer-cur-path) -; (wl-delete-all-overlays) -; (wl-highlight-folder-current-line) - ))) - ((setq fld-name (wl-folder-entity-name)) + (let ((fld-name (wl-folder-get-entity-from-buffer)) + entity beg end indent opened err) + (unless fld-name + (error "No folder")) + (beginning-of-line) + (if (and (wl-folder-buffer-group-p) + (looking-at wl-folder-group-regexp)) + ;; folder group + (save-excursion + (setq indent (wl-match-buffer 1)) + (setq opened (wl-match-buffer 2)) + (if (string= opened "+") + (progn + (setq entity (wl-folder-search-group-entity-by-name + fld-name + wl-folder-entity)) + (setq beg (point)) + (if arg + (wl-folder-update-recursive-current-entity entity) + ;; insert as opened + (setcdr (assoc (car entity) wl-folder-group-alist) t) + (if (eq 'access (cadr entity)) + (wl-folder-maybe-load-folder-list entity)) + ;(condition-case errobj + (progn + (if (or (wl-folder-force-fetch-p (car entity)) + (and + (eq 'access (cadr entity)) + (null (caddr entity)))) + (wl-folder-update-newest indent entity) + (wl-folder-insert-entity indent entity)) + (wl-highlight-folder-path wl-folder-buffer-cur-path)) + ; (quit + ; (setq err t) + ; (setcdr (assoc fld-name wl-folder-group-alist) nil)) + ; (error + ; (elmo-display-error errobj t) + ; (ding) + ; (setq err t) + ; (setcdr (assoc fld-name wl-folder-group-alist) nil))) + (if (not err) + (let ((buffer-read-only nil)) + (delete-region (save-excursion (beginning-of-line) + (point)) + (save-excursion (end-of-line) + (+ 1 (point)))))))) + (setq beg (point)) + (end-of-line) + (save-match-data + (setq end + (progn (wl-folder-goto-bottom-of-current-folder indent) + (beginning-of-line) + (point)))) + (setq entity (wl-folder-search-group-entity-by-name + fld-name + wl-folder-entity)) + (let ((buffer-read-only nil)) + (delete-region beg end)) + (setcdr (assoc (car entity) wl-folder-group-alist) nil) + (wl-folder-insert-entity indent entity) ; insert entity + (forward-line -1) + (wl-highlight-folder-path wl-folder-buffer-cur-path) + ; (wl-delete-all-overlays) + ; (wl-highlight-folder-current-line) + )) + ;; ordinal folder (wl-folder-set-current-entity-id (get-text-property (point) 'wl-folder-entity-id)) (setq fld-name (wl-folder-get-folder-name-by-id @@ -663,7 +714,7 @@ Optional argument ARG is repeart count." (wl-summary-goto-folder-subr fld-name (wl-summary-get-sync-range (wl-folder-get-elmo-folder fld-name)) - nil arg t))))) + nil arg t)))) (set-buffer-modified-p nil)) (defun wl-folder-close-entity (entity) @@ -682,14 +733,16 @@ Optional argument ARG is repeart count." (defun wl-folder-update-recursive-current-entity (&optional entity) (interactive) - (when (wl-folder-buffer-group-p) + (beginning-of-line) + (when (and (wl-folder-buffer-group-p) + (looking-at wl-folder-group-regexp)) (cond ((string= (wl-match-buffer 2) "+") (save-excursion (if entity () (setq entity (wl-folder-search-group-entity-by-name - (wl-folder-get-realname (wl-match-buffer 3)) + (wl-folder-get-entity-from-buffer) wl-folder-entity))) (let ((inhibit-read-only t) (entities (list entity)) @@ -793,57 +846,56 @@ Optional argument ARG is repeart count." (t (message "Uncheck(unplugged) \"%s\"" entity))))) (if ret-val - (message "Checking \"%s\" is done." + (message "Checking \"%s\" is done" (if (consp entity) (car entity) entity))) (run-hooks 'wl-folder-check-entity-hook) ret-val)) -(defun wl-folder-check-one-entity (entity) - (let* ((folder (wl-folder-get-elmo-folder entity)) +(defun wl-folder-check-one-entity (entity &optional biff) + (let* ((folder (wl-folder-get-elmo-folder entity biff)) (nums (condition-case err - (if (wl-string-match-member entity wl-strict-diff-folders) - (elmo-strict-folder-diff folder) - (elmo-folder-diff folder)) + (progn + (if biff (elmo-folder-set-biff-internal folder t)) + (if (wl-string-match-member entity wl-strict-diff-folders) + (elmo-strict-folder-diff folder) + (elmo-folder-diff folder))) (error ;; maybe not exist folder. - (if (and (not (memq 'elmo-open-error - (get (car err) 'error-conditions))) + (if (and (not (or (memq 'elmo-open-error + (get (car err) 'error-conditions)) + (memq 'elmo-imap4-bye-error + (get (car err) 'error-conditions)))) (not (elmo-folder-exists-p folder))) (wl-folder-create-subr folder) (signal (car err) (cdr err)))))) - (new (elmo-diff-new nums)) - (nums (cons (elmo-diff-unread nums) (elmo-diff-all nums))) - unread unsync nomif) + (new (elmo-diff-new nums)) + (unread (elmo-diff-unread nums)) + (all (elmo-diff-all nums)) + unsync nomif) (if (and (eq wl-folder-notify-deleted 'sync) - (car nums) - (or (> 0 (car nums)) (> 0 (cdr nums)))) + (or (and new (> 0 new)) + (and unread (> 0 unread)) + (and all (> 0 all)))) (progn (wl-folder-sync-entity entity) - (setq nums (elmo-folder-diff folder))) + (setq nums (elmo-folder-diff folder) + new (elmo-diff-new nums) + unread (elmo-diff-unread nums) + all (elmo-diff-all nums))) (unless wl-folder-notify-deleted - (setq unsync (if (and (car nums) (> 0 (car nums))) 0 (car nums))) - (setq nomif (if (and (car nums) (> 0 (cdr nums))) 0 (cdr nums))) - (setq nums (cons unsync nomif))) - (setq unread (or ;; If server diff, All unreads are - ; treated as unsync. - (if (elmo-folder-use-flag-p folder) - (car nums)) - (elmo-folder-get-info-unread folder) - (wl-summary-count-unread (elmo-msgdb-mark-load - (elmo-folder-msgdb-path - folder))))) - (setq unread (min unread (- (or (cdr nums) 0) (or (car nums) 0)))) - (when new (setq unread (- unread new))) + (setq new (and new (max 0 new)) + unread (and unread (max 0 unread)) + all (and all (max 0 all)))) + (setq unread (or (and unread (- unread (or new 0))) + (elmo-folder-get-info-unread folder) + (or (cdr (assq 'unread + (elmo-folder-count-flags folder))) 0))) (wl-folder-entity-hashtb-set wl-folder-entity-hashtb entity - (list (or new (car nums)) - unread - (cdr nums)) + (list new unread all) (get-buffer wl-folder-buffer-name))) (setq wl-folder-info-alist-modified t) (sit-for 0) - (list (if wl-folder-notify-deleted - (car nums) - (or new (max (or (car nums) 0)))) unread (cdr nums)))) + (list new unread all))) (defun wl-folder-check-entity-async (entity &optional auto) (let ((elmo-nntp-groups-async t) @@ -940,21 +992,24 @@ Optional argument ARG is repeart count." (goto-char wl-folder-buffer-cur-point)))) (defun wl-folder-set-current-entity-id (entity-id) - (let ((buf (get-buffer wl-folder-buffer-name))) + (let* ((buf (get-buffer wl-folder-buffer-name)) + (buf-win (get-buffer-window buf))) (if buf - (save-excursion - (set-buffer buf) - (setq wl-folder-buffer-cur-entity-id entity-id) - (setq wl-folder-buffer-cur-path (wl-folder-get-path wl-folder-entity - entity-id)) - (wl-highlight-folder-path wl-folder-buffer-cur-path) - (and wl-folder-move-cur-folder - wl-folder-buffer-cur-point - (goto-char wl-folder-buffer-cur-point)))) - (if (eq (current-buffer) buf) - (and wl-folder-move-cur-folder - wl-folder-buffer-cur-point - (goto-char wl-folder-buffer-cur-point))))) + (save-current-buffer + (save-selected-window + (if buf-win + (select-window buf-win) + (set-buffer buf)) + (when (and wl-folder-buffer-cur-entity-id + (not (eq wl-folder-buffer-cur-entity-id entity-id))) + (setq wl-folder-buffer-last-visited-entity-id wl-folder-buffer-cur-entity-id)) + (setq wl-folder-buffer-cur-entity-id entity-id) + (setq wl-folder-buffer-cur-path + (wl-folder-get-path wl-folder-entity entity-id)) + (wl-highlight-folder-path wl-folder-buffer-cur-path) + (and wl-folder-move-cur-folder + wl-folder-buffer-cur-point + (goto-char wl-folder-buffer-cur-point))))))) (defun wl-folder-check-current-entity () "Check folder at position. @@ -986,14 +1041,21 @@ If current line is group folder, check all sub entries." (wl-summary-always-sticky-folder-p folder)) wl-summary-highlight)) - wl-auto-select-first new unread) + wl-auto-select-first new unread sticky) (setq new (or (car nums) 0)) (setq unread (or (cadr nums) 0)) (if (or (not unread-only) (or (< 0 new) (< 0 unread))) - (let ((wl-summary-buffer-name (concat - wl-summary-buffer-name - (symbol-name this-command))) + (let ((wl-summary-buffer-name + (if (setq sticky (get-buffer (wl-summary-sticky-buffer-name + (elmo-folder-name-internal + folder)))) + ;; Sticky folder exists. + (wl-summary-sticky-buffer-name + (elmo-folder-name-internal folder)) + (concat + wl-summary-buffer-name + (symbol-name this-command)))) (wl-summary-use-frame nil) (wl-summary-always-sticky-folder-list nil)) (save-window-excursion @@ -1002,7 +1064,9 @@ If current line is group folder, check all sub entries." (wl-summary-get-sync-range folder) nil nil nil t) - (wl-summary-exit))))))))) + (if sticky + (wl-summary-save-status) + (wl-summary-exit)))))))))) (defun wl-folder-sync-current-entity (&optional unread-only) "Synchronize the folder at position. @@ -1012,7 +1076,7 @@ If current line is group folder, check all subfolders." (let ((entity-name (wl-folder-get-entity-from-buffer)) (group (wl-folder-buffer-group-p))) (when (and entity-name - (y-or-n-p (format "Sync %s?" entity-name))) + (y-or-n-p (format "Sync %s? " entity-name))) (wl-folder-sync-entity (if group (wl-folder-search-group-entity-by-name entity-name @@ -1036,22 +1100,32 @@ If current line is group folder, check all subfolders." (wl-summary-always-sticky-folder-p folder)) wl-summary-highlight)) - wl-auto-select-first new unread) + wl-auto-select-first new unread sticky) (setq new (or (car nums) 0)) (setq unread (or (cadr nums) 0)) (if (or (< 0 new) (< 0 unread)) (save-window-excursion (save-excursion - (let ((wl-summary-buffer-name (concat - wl-summary-buffer-name - (symbol-name this-command))) + (let ((wl-summary-buffer-name + (if (setq sticky (get-buffer + (wl-summary-sticky-buffer-name + (elmo-folder-name-internal + folder)))) + ;; Sticky folder exists. + (wl-summary-sticky-buffer-name + (elmo-folder-name-internal folder)) + (concat + wl-summary-buffer-name + (symbol-name this-command)))) (wl-summary-use-frame nil) (wl-summary-always-sticky-folder-list nil)) (wl-summary-goto-folder-subr entity (wl-summary-get-sync-range folder) nil) (wl-summary-mark-as-read-all) - (wl-summary-exit)))) + (if sticky + (wl-summary-save-status) + (wl-summary-exit))))) (sit-for 0)))))) (defun wl-folder-mark-as-read-all-current-entity () @@ -1063,7 +1137,8 @@ If current line is group folder, all subfolders are marked." (group (wl-folder-buffer-group-p)) summary-buf) (when (and entity-name - (y-or-n-p (format "Mark all messages in %s as read?" entity-name))) + (y-or-n-p (format "Mark all messages in %s as read? " + entity-name))) (wl-folder-mark-as-read-all-entity (if group (wl-folder-search-group-entity-by-name entity-name @@ -1266,12 +1341,14 @@ If current line is group folder, all subfolders are marked." (get-text-property 0 'wl-folder-entity-id (car entity)))) - (put-text-property 0 (length (car entity)) - 'wl-folder-entity-id - wl-folder-entity-id - (car entity)) + (wl-folder-put-folder-property + 0 (length (car entity)) + wl-folder-entity-id + 'is-group + (car entity)) (wl-folder-set-id-name wl-folder-entity-id - (car entity) hashtb)) + (car entity) hashtb) + (setq wl-folder-entity-id (+ 1 wl-folder-entity-id))) (and entities (wl-push entities entity-stack)) (setq entities (nth 2 entity))) @@ -1280,13 +1357,14 @@ If current line is group folder, all subfolders are marked." (get-text-property 0 'wl-folder-entity-id entity))) - (put-text-property 0 (length entity) - 'wl-folder-entity-id - wl-folder-entity-id - entity) + (wl-folder-put-folder-property + 0 (length entity) + wl-folder-entity-id + nil + entity) (wl-folder-set-id-name wl-folder-entity-id - entity hashtb)))) - (setq wl-folder-entity-id (+ 1 wl-folder-entity-id)) + entity hashtb) + (setq wl-folder-entity-id (+ 1 wl-folder-entity-id))))) (unless entities (setq entities (wl-pop entity-stack)))))) @@ -1374,8 +1452,7 @@ If current line is group folder, all subfolders are marked." (if (or (wl-folder-buffer-group-p) (not plugged) (setq entity - (wl-folder-get-realname - (wl-folder-folder-name))) + (wl-folder-get-entity-from-buffer)) (elmo-folder-plugged-p entity)) (throw 'found t)))) (beginning-of-line) @@ -1391,7 +1468,7 @@ If current line is group folder, all subfolders are marked." (if (re-search-backward (wl-folder-unread-regex group) nil t) (progn (beginning-of-line) - (wl-folder-folder-name)) + (wl-folder-get-entity-from-buffer)) (goto-char start-point) (message "No more unread folder") nil))) @@ -1405,7 +1482,7 @@ If current line is group folder, all subfolders are marked." (if (re-search-forward (wl-folder-unread-regex group) nil t) (progn (beginning-of-line) - (wl-folder-folder-name)) + (wl-folder-get-entity-from-buffer)) (goto-char start-point) (message "No more unread folder") nil))) @@ -1436,18 +1513,14 @@ Entering Folder mode calls the value of `wl-folder-mode-hook'." (run-hooks 'wl-folder-mode-hook)) (defun wl-folder-append-petname (realname petname) - (let (pentry) - ;; check group name. - (if (wl-folder-search-group-entity-by-name petname wl-folder-entity) - (error "%s already defined as group name" petname)) - (when (setq pentry (wl-string-assoc realname wl-folder-petname-alist)) + (let ((pentry (wl-string-assoc realname wl-folder-petname-alist))) + (when pentry (setq wl-folder-petname-alist - (delete pentry wl-folder-petname-alist))) - (wl-append wl-folder-petname-alist - (list (cons realname petname))))) + (delete pentry wl-folder-petname-alist)))) + (wl-append wl-folder-petname-alist + (list (cons realname petname)))) -(defun wl-folder (&optional arg) - (interactive "P") +(defun wl-folder () (let (initialize folder-buf) (if (setq folder-buf (get-buffer wl-folder-buffer-name)) (if wl-folder-use-frame @@ -1462,12 +1535,22 @@ Entering Folder mode calls the value of `wl-folder-mode-hook'." (switch-to-buffer folder-buf))) (switch-to-buffer folder-buf)) (if wl-folder-use-frame - (switch-to-buffer-other-frame - (get-buffer-create wl-folder-buffer-name)) + (progn + (switch-to-buffer-other-frame + (get-buffer-create wl-folder-buffer-name)) + (let ((frame (selected-frame))) + (setq wl-delete-startup-frame-function + `(lambda () + (setq wl-delete-startup-frame-function nil) + (let ((frame ,frame)) + (if (eq (selected-frame) frame) + (delete-frame frame))))))) (switch-to-buffer (get-buffer-create wl-folder-buffer-name))) (set-buffer wl-folder-buffer-name) (wl-folder-mode) ;; Initialization. + (unless wl-folder-entity + (wl-folder-init)) (setq wl-folder-entity-id 0) (wl-folder-entity-assign-id wl-folder-entity) (setq wl-folder-entity-hashtb @@ -1513,8 +1596,8 @@ Entering Folder mode calls the value of `wl-folder-mode-hook'." (defun wl-folder-set-folder-updated (name value) (save-excursion - (let (buf) - (if (setq buf (get-buffer wl-folder-buffer-name)) + (let ((buf (get-buffer wl-folder-buffer-name))) + (if buf (wl-folder-entity-hashtb-set wl-folder-entity-hashtb name value buf)) (setq wl-folder-info-alist-modified t)))) @@ -1571,7 +1654,7 @@ Entering Folder mode calls the value of `wl-folder-mode-hook'." (when (setq new-flist (elmo-folder-list-subfolders (wl-folder-get-elmo-folder (car entity)) - (wl-string-member + (wl-string-match-member (car entity) wl-folder-hierarchy-access-folders))) (setq update-flist @@ -1660,12 +1743,15 @@ Entering Folder mode calls the value of `wl-folder-mode-hook'." ;;; wl-folder-newsgroups-hashtb)))) ;;; (message "fetching folder entries...done")) (insert indent "[" (if as-opened "-" "+") "]" - (wl-folder-get-petname (car entity))) + (if (eq (cadr entity) 'access) + (wl-folder-get-petname (car entity)) + (car entity))) (setq group-name-end (point)) (insert ":0/0/0\n") - (put-text-property beg (point) 'wl-folder-entity-id - (get-text-property 0 'wl-folder-entity-id - (car entity))) + (wl-folder-put-folder-property + beg (point) + (get-text-property 0 'wl-folder-entity-id (car entity)) + 'is-group) (when removed (setq beg (point)) (while removed @@ -1695,7 +1781,9 @@ Entering Folder mode calls the value of `wl-folder-mode-hook'." (elmo-display-progress 'wl-folder-insert-entity "Inserting group %s..." (/ (* i 100) len) (car entity))) - (setq flist (cdr flist)))) + (setq flist (cdr flist))) + (if (> len 0) + (message "Inserting group %s...done" (car entity)))) (save-excursion (goto-char group-name-end) (delete-region (point) (save-excursion (end-of-line) @@ -1706,15 +1794,18 @@ Entering Folder mode calls the value of `wl-folder-mode-hook'." (wl-highlight-folder-current-line ret-val))) (setq ret-val (wl-folder-calc-finfo entity)) (insert indent "[" (if as-opened "-" "+") "]" - (wl-folder-get-petname (car entity)) + (if (eq (cadr entity) 'access) + (wl-folder-get-petname (car entity)) + (car entity)) (format ":%d/%d/%d" (or (nth 0 ret-val) 0) (or (nth 1 ret-val) 0) (or (nth 2 ret-val) 0)) "\n") - (put-text-property beg (point) 'wl-folder-entity-id - (get-text-property 0 'wl-folder-entity-id - (car entity))) + (wl-folder-put-folder-property + beg (point) + (get-text-property 0 'wl-folder-entity-id (car entity)) + 'is-group) (save-excursion (forward-line -1) (wl-highlight-folder-current-line ret-val))))) ((stringp entity) @@ -1730,8 +1821,10 @@ Entering Folder mode calls the value of `wl-folder-mode-hook'." (+ (nth 0 nums)(nth 1 nums)))) "*") (or (setq all (nth 2 nums)) "*"))) - (put-text-property beg (point) 'wl-folder-entity-id - (get-text-property 0 'wl-folder-entity-id entity)) + (wl-folder-put-folder-property + beg (point) + (get-text-property 0 'wl-folder-entity-id entity) + nil) (save-excursion (forward-line -1) (wl-highlight-folder-current-line nums)) (setq ret-val (list new unread all))))) @@ -1743,13 +1836,11 @@ Entering Folder mode calls the value of `wl-folder-mode-hook'." (wl-folder-check-entity wl-folder-entity)) (defun wl-folder-entity-hashtb-set (entity-hashtb name value buffer) - (let (cur-val + (let ((cur-val (wl-folder-get-entity-info name entity-hashtb)) (new-diff 0) (unread-diff 0) (all-diff 0) - diffs - entity-list) - (setq cur-val (wl-folder-get-entity-info name entity-hashtb)) + diffs) (setq new-diff (- (or (nth 0 value) 0) (or (nth 0 cur-val) 0))) (setq unread-diff (+ new-diff @@ -1762,47 +1853,45 @@ Entering Folder mode calls the value of `wl-folder-mode-hook'." (save-match-data (with-current-buffer buffer (save-excursion - (setq entity-list (wl-folder-search-entity-list-by-name - name wl-folder-entity)) - (while entity-list - (wl-folder-update-group (car entity-list) diffs) - (setq entity-list (cdr entity-list))) + (let ((entity-list (wl-folder-search-entity-list-by-name + name wl-folder-entity))) + (while entity-list + (wl-folder-update-group (car entity-list) diffs) + (setq entity-list (cdr entity-list)))) (goto-char (point-min)) (while (wl-folder-buffer-search-entity name) (wl-folder-update-line value)))))))) (defun wl-folder-update-unread (folder unread) -; (save-window-excursion - (let ((buf (get-buffer wl-folder-buffer-name)) - cur-unread - (unread-diff 0) - ;;(fld (elmo-string folder)) - value newvalue entity-list) + (let ((buf (get-buffer wl-folder-buffer-name)) + (value (wl-folder-get-entity-info folder)) + cur-unread + (unread-diff 0) + newvalue) ;;; Update folder-info ;;; (elmo-folder-set-info-hashtb fld nil nil nil unread) - (setq cur-unread (or (nth 1 (wl-folder-get-entity-info folder)) 0)) - (setq unread-diff (- (or unread 0) cur-unread)) - (setq value (wl-folder-get-entity-info folder)) - (setq newvalue (list (nth 0 value) - unread - (nth 2 value))) - (wl-folder-set-entity-info folder newvalue) - (setq wl-folder-info-alist-modified t) - (when (and buf - (not (eq unread-diff 0))) - (save-match-data - (with-current-buffer buf - (save-excursion - (setq entity-list (wl-folder-search-entity-list-by-name - folder wl-folder-entity)) + (setq cur-unread (or (nth 1 value) 0)) + (setq unread-diff (- (or unread 0) cur-unread)) + (setq newvalue (list (nth 0 value) + unread + (nth 2 value))) + (wl-folder-set-entity-info folder newvalue) + (setq wl-folder-info-alist-modified t) + (when (and buf + (not (eq unread-diff 0))) + (save-match-data + (with-current-buffer buf + (save-excursion + (let ((entity-list (wl-folder-search-entity-list-by-name + folder wl-folder-entity))) (while entity-list (wl-folder-update-group (car entity-list) (list 0 unread-diff 0)) - (setq entity-list (cdr entity-list))) - (goto-char (point-min)) - (while (wl-folder-buffer-search-entity folder) - (wl-folder-update-line newvalue))))))));) + (setq entity-list (cdr entity-list)))) + (goto-char (point-min)) + (while (wl-folder-buffer-search-entity folder) + (wl-folder-update-line newvalue)))))))) (defun wl-folder-create-entity-hashtb (entity &optional hashtb reconst) (let ((hashtb (or hashtb (elmo-make-hash wl-folder-entity-id))) @@ -1911,8 +2000,7 @@ Entering Folder mode calls the value of `wl-folder-mode-hook'." (cond ((consp entity) (if (and (or (not string) (string= string (car entity))) - ;; don't use eq, `id' is string on Nemacs. - (equal target-id (wl-folder-get-entity-id (car entity)))) + (eq target-id (wl-folder-get-entity-id (car entity)))) (throw 'done (wl-push target-id result-path)) (wl-push (wl-folder-get-entity-id (car entity)) result-path)) @@ -1920,8 +2008,7 @@ Entering Folder mode calls the value of `wl-folder-mode-hook'." (setq entities (nth 2 entity))) ((stringp entity) (if (and (or (not string) (string= string entity)) - ;; don't use eq, `id' is string on Nemacs. - (equal target-id (wl-folder-get-entity-id entity))) + (eq target-id (wl-folder-get-entity-id entity))) (throw 'done (wl-push target-id result-path))))) (unless entities @@ -1996,7 +2083,8 @@ Entering Folder mode calls the value of `wl-folder-mode-hook'." (interactive) (if wl-use-acap (wl-acap-init) - (funcall wl-folder-init-function))) + (funcall wl-folder-init-function)) + (run-hooks 'wl-folder-init-hook)) (defun wl-local-folder-init () "Initialize local folder." @@ -2029,28 +2117,30 @@ Entering Folder mode calls the value of `wl-folder-mode-hook'." (defun wl-folder-get-newsgroups (folder) "Return Newsgroups field value string for FOLDER newsgroup. If FOLDER is multi, return comma separated string (cross post)." - (list nil nil (mapconcat 'identity - (elmo-folder-newsgroups - (wl-folder-get-elmo-folder folder)) - ","))) + (let ((nlist (elmo-folder-newsgroups + (wl-folder-get-elmo-folder folder)))) + (if nlist + (list nil nil (mapconcat 'identity nlist ",")) + nil))) (defun wl-folder-guess-mailing-list-by-refile-rule (entity) - "Return ML address guess by FOLDER. + "Return ML address guess by ENTITY. Use `wl-subscribed-mailing-list' and `wl-refile-rule-alist'." (let ((flist (elmo-folder-get-primitive-list (wl-folder-get-elmo-folder entity))) - fld ret mlist) + fld mladdr to) (while (setq fld (car flist)) - (if (setq ret - (wl-folder-guess-mailing-list-by-refile-rule-subr - (elmo-folder-name-internal fld))) - (setq mlist (if (stringp mlist) - (concat mlist ", " ret) - ret))) + (setq mladdr (wl-folder-guess-mailing-list-by-refile-rule-subr + (elmo-folder-name-internal fld))) + (when mladdr + (setq to (if (stringp to) + (concat to ", " mladdr) + mladdr))) (setq flist (cdr flist))) - (if mlist - (list mlist nil nil)))) + (if (stringp to) + (list to nil nil) + nil))) (defun wl-folder-guess-mailing-list-by-refile-rule-subr (entity) (unless (memq (elmo-folder-type entity) @@ -2072,22 +2162,23 @@ Use `wl-subscribed-mailing-list' and `wl-refile-rule-alist'." (elmo-string-matched-member tokey wl-subscribed-mailing-list t))))) (defun wl-folder-guess-mailing-list-by-folder-name (entity) - "Return ML address guess by FOLDER name's last hierarchy. + "Return ML address guess by ENTITY name's last hierarchy. Use `wl-subscribed-mailing-list'." (let ((flist (elmo-folder-get-primitive-list (wl-folder-get-elmo-folder entity))) - fld ret mlist) + fld mladdr to) (while (setq fld (car flist)) - (if (setq ret - (wl-folder-guess-mailing-list-by-folder-name-subr - (elmo-folder-name-internal fld))) - (setq mlist (if (stringp mlist) - (concat mlist ", " ret) - ret))) + (setq mladdr (wl-folder-guess-mailing-list-by-folder-name-subr + (elmo-folder-name-internal fld))) + (when mladdr + (setq to (if (stringp to) + (concat to ", " mladdr) + mladdr))) (setq flist (cdr flist))) - (if mlist - (list mlist nil nil)))) + (if (stringp to) + (list to nil nil) + nil))) (defun wl-folder-guess-mailing-list-by-folder-name-subr (entity) (when (memq (elmo-folder-type entity) @@ -2109,10 +2200,11 @@ Use `wl-subscribed-mailing-list'." cur-new new-new cur-unread new-unread cur-all new-all - id) + id is-group) (save-excursion (beginning-of-line) (setq id (get-text-property (point) 'wl-folder-entity-id)) + (setq is-group (get-text-property (point) 'wl-folder-is-group)) (when (looking-at "^[ ]*\\(.*\\):\\([0-9\\*-]*\\)/\\([0-9\\*-]*\\)/\\([0-9\\*]*\\)") ;;(looking-at "^[ ]*\\([^\\[].+\\):\\([0-9\\*-]*/[0-9\\*-]*/[0-9\\*]*\\)") (setq cur-new (string-to-int @@ -2128,8 +2220,7 @@ Use `wl-subscribed-mailing-list'." (setq new-new (+ cur-new (nth 0 diffs))) (setq new-unread (+ cur-unread (nth 1 diffs))) (setq new-all (+ cur-all (nth 2 diffs))))) - (put-text-property (match-beginning 2) (point) - 'wl-folder-entity-id id) + (wl-folder-put-folder-property (match-beginning 2) (point) id is-group) (if wl-use-highlight-mouse-line (put-text-property (match-beginning 2) (point) 'mouse-face 'highlight)) @@ -2140,10 +2231,11 @@ Use `wl-subscribed-mailing-list'." (defun wl-folder-update-line (nums &optional is-group) (let ((inhibit-read-only t) (buffer-read-only nil) - id) + id is-group) (save-excursion (beginning-of-line) (setq id (get-text-property (point) 'wl-folder-entity-id)) + (setq is-group (get-text-property (point) 'wl-folder-is-group)) (if (looking-at "^[ ]*\\(.*\\):\\([0-9\\*-]*/[0-9\\*-]*/[0-9\\*]*\\)") ;;; (looking-at "^[ ]*\\([^\\[].+\\):\\([0-9\\*-]*/[0-9\\*-]*/[0-9\\*]*\\)") (progn @@ -2156,8 +2248,7 @@ Use `wl-subscribed-mailing-list'." (+ (nth 0 nums)(nth 1 nums))) "*") (or (nth 2 nums) "*"))) - (put-text-property (match-beginning 2) (point) - 'wl-folder-entity-id id) + (wl-folder-put-folder-property (match-beginning 2) (point) id is-group) (if is-group ;; update only colors (wl-highlight-folder-group-line nums) @@ -2166,9 +2257,29 @@ Use `wl-subscribed-mailing-list'." (set-buffer-modified-p nil)))))) (defun wl-folder-goto-folder (&optional arg) + "Visit some folder." (interactive "P") (wl-folder-goto-folder-subr nil arg)) +(defun wl-folder-goto-folder-sticky () + "Visit some folder and make it sticky." + (interactive) + (wl-folder-goto-folder-subr nil t)) + +(defun wl-folder-goto-draft-folder (&optional arg) + "Visit draft folder." + (interactive "P") + (wl-folder-goto-folder-subr wl-draft-folder arg)) + +(defun wl-folder-revisit-last-visited-folder (&optional arg) + "Revisit last visited folder." + (interactive "P") + (let ((folder + (wl-folder-get-folder-name-by-id wl-folder-buffer-last-visited-entity-id))) + (if (and folder + (y-or-n-p (format "Revisit %s? " folder))) + (wl-folder-goto-folder-subr folder arg)))) + (defun wl-folder-goto-folder-subr (&optional folder sticky) (beginning-of-line) (let (summary-buf fld-name entity id error-selecting) @@ -2177,7 +2288,8 @@ Use `wl-subscribed-mailing-list'." ;;; (assoc fld-name wl-folder-group-alist)) (setq fld-name wl-default-folder) (setq fld-name (or folder - (wl-summary-read-folder fld-name))) + (let (this-command) + (wl-summary-read-folder fld-name)))) (if (and (setq entity (wl-folder-search-entity-by-name fld-name wl-folder-entity @@ -2204,6 +2316,10 @@ Use `wl-subscribed-mailing-list'." ;(if (fboundp 'mmelmo-cleanup-entity-buffers) ;(mmelmo-cleanup-entity-buffers)) (bury-buffer wl-folder-buffer-name) + (dolist (summary-buf (wl-collect-summary)) + (bury-buffer summary-buf)) + (dolist (draft-buf (wl-collect-draft)) + (bury-buffer draft-buf)) (delete-windows-on wl-folder-buffer-name t)) (defun wl-folder-info-save () @@ -2356,12 +2472,13 @@ Use `wl-subscribed-mailing-list'." (interactive) (if (not fld-name) (setq fld-name (wl-summary-read-folder wl-default-folder))) - (let* ((id (wl-folder-get-entity-id - (wl-folder-search-entity-by-name fld-name wl-folder-entity - 'folder))) - (path (and id (wl-folder-get-path wl-folder-entity id)))) - (if path - (wl-folder-open-folder-sub path)))) + (let ((entity (wl-folder-search-entity-by-name + fld-name wl-folder-entity 'folder))) + (if entity + (let* ((id (wl-folder-get-entity-id entity)) + (path (and id (wl-folder-get-path wl-folder-entity id)))) + (if path (wl-folder-open-folder-sub path))) + (message "%s: not found" fld-name)))) (defun wl-folder-open-folder-sub (path) (let ((inhibit-read-only t) @@ -2379,11 +2496,12 @@ Use `wl-subscribed-mailing-list'." (car path)))))) (beginning-of-line) (setq path (cdr path)) - (if (and (looking-at wl-folder-group-regexp) + (if (and (wl-folder-buffer-group-p) + (looking-at wl-folder-group-regexp) (string= "+" (wl-match-buffer 2)));; closed group (save-excursion (setq indent (wl-match-buffer 1)) - (setq name (wl-folder-get-realname (wl-match-buffer 3))) + (setq name (wl-folder-get-entity-from-buffer)) (setq entity (wl-folder-search-group-entity-by-name name wl-folder-entity)) @@ -2439,16 +2557,16 @@ Use `wl-subscribed-mailing-list'." (save-excursion (goto-char (point-min)) (while (re-search-forward - "^\\([ ]*\\)\\[\\([+]\\)\\]\\(.+\\):[-0-9-]+/[0-9-]+/[0-9-]+\n" + "^\\([ ]*\\)\\[\\([+]\\)\\]\\(.+\\):[-0-9-]+/[0-9-]+/[0-9-]+$" nil t) (setq indent (wl-match-buffer 1)) - (setq name (wl-folder-get-realname (wl-match-buffer 3))) + (setq name (wl-folder-get-entity-from-buffer)) (setq entity (wl-folder-search-group-entity-by-name name wl-folder-entity)) ;; insert as opened (setcdr (assoc (car entity) wl-folder-group-alist) t) - (forward-line -1) + (beginning-of-line) (wl-folder-insert-entity indent entity) (delete-region (save-excursion (beginning-of-line) (point)) @@ -2463,6 +2581,7 @@ Use `wl-subscribed-mailing-list'." (when (> len elmo-display-progress-threshold) (elmo-display-progress 'wl-folder-open-all "Opening all folders..." 100)))) + (wl-highlight-folder-path wl-folder-buffer-cur-path) (message "Opening all folders...done") (set-buffer-modified-p nil))) @@ -2481,25 +2600,27 @@ Use `wl-subscribed-mailing-list'." (erase-buffer) (wl-folder-insert-entity " " wl-folder-entity) (wl-folder-move-path id) + (wl-highlight-folder-path wl-folder-buffer-cur-path) (recenter) (set-buffer-modified-p nil))) (defun wl-folder-open-close () "Open or close parent entity." (interactive) - (save-excursion - (beginning-of-line) - (if (wl-folder-buffer-group-p) - ;; if group (whether opend or closed.) - (wl-folder-jump-to-current-entity) - ;; if folder - (let (indent) - (setq indent (save-excursion - (re-search-forward "\\([ ]*\\)." nil t) - (wl-match-buffer 1))) - (while (looking-at indent) - (forward-line -1))) - (wl-folder-jump-to-current-entity)))) + (unless (wl-folder-get-entity-from-buffer) + (error "No folder")) + (beginning-of-line) + (if (wl-folder-buffer-group-p) + ;; if group (whether opend or closed.) + (wl-folder-jump-to-current-entity) + ;; if folder + (let (indent) + (setq indent (save-excursion + (re-search-forward "\\([ ]*\\)." nil t) + (wl-match-buffer 1))) + (while (looking-at indent) + (forward-line -1))) + (wl-folder-jump-to-current-entity))) (defsubst wl-folder-access-subscribe-p (group folder) (let (subscr regexp match) @@ -2641,16 +2762,24 @@ Use `wl-subscribed-mailing-list'." wl-summary-highlight)) wl-summary-exit-next-move wl-auto-select-first ret-val - count) + count sticky) (setq count (or (car nums) 0)) (setq count (+ count (wl-folder-count-incorporates folder))) (if (or (null (car nums)) ; unknown (< 0 count)) (save-window-excursion (save-excursion - (let ((wl-summary-buffer-name (concat - wl-summary-buffer-name - (symbol-name this-command))) + (let ((wl-summary-buffer-name + (if (setq sticky (get-buffer + (wl-summary-sticky-buffer-name + (elmo-folder-name-internal + folder)))) + ;; Sticky folder exists. + (wl-summary-sticky-buffer-name + (elmo-folder-name-internal folder)) + (concat + wl-summary-buffer-name + (symbol-name this-command)))) (wl-summary-use-frame nil) (wl-summary-always-sticky-folder-list nil)) (wl-summary-goto-folder-subr entity @@ -2658,19 +2787,18 @@ Use `wl-subscribed-mailing-list'." folder) nil) (setq ret-val (wl-summary-incorporate)) - (wl-summary-exit) + (if sticky + (wl-summary-save-status) + (wl-summary-exit)) ret-val))) (cons 0 0)))))) (defun wl-folder-count-incorporates (folder) - (let ((marks (elmo-msgdb-mark-load - (elmo-folder-msgdb-path folder))) - (sum 0)) - (while marks - (if (member (cadr (car marks)) - wl-summary-incorporate-marks) - (incf sum)) - (setq marks (cdr marks))) + (let ((sum 0)) + (dolist (number (elmo-folder-list-flagged folder 'any)) + (when (member (wl-summary-message-mark folder number) + wl-summary-incorporate-marks) + (incf sum))) sum)) (defun wl-folder-prefetch-current-entity (&optional no-check) @@ -2726,7 +2854,7 @@ If current line is group folder, all subfolders are prefetched." ; summary-buf entity) ; (when (and entity-name ; (y-or-n-p (format -; "Drop all unsync messages in %s?" entity-name))) +; "Drop all unsync messages in %s? " entity-name))) ; (setq entity ; (if group ; (wl-folder-search-group-entity-by-name entity-name @@ -2743,7 +2871,7 @@ Call `wl-summary-write-current-folder' with current folder name." (interactive) (unless (wl-folder-buffer-group-p) (wl-summary-write-current-folder - (wl-folder-get-realname (wl-folder-entity-name))))) + (wl-folder-get-entity-from-buffer)))) (defun wl-folder-mimic-kill-buffer () "Kill the current (Folder) buffer with query." @@ -2758,29 +2886,164 @@ Call `wl-summary-write-current-folder' with current folder name." (kill-buffer bufname)))) (defun wl-folder-create-subr (folder) - (if (not (elmo-folder-creatable-p folder)) - (error "Folder %s is not found" (elmo-folder-name-internal folder)) - (if (y-or-n-p - (format "Folder %s does not exist, create it?" - (elmo-folder-name-internal folder))) - (progn - (setq wl-folder-entity-hashtb - (wl-folder-create-entity-hashtb - (elmo-folder-name-internal folder) - wl-folder-entity-hashtb)) - (unless (elmo-folder-create folder) - (error "Create folder failed"))) - (error "Folder %s is not created" (elmo-folder-name-internal folder))))) + (if (elmo-folder-creatable-p folder) + (if (y-or-n-p (format "Folder %s does not exist, create it? " + (elmo-folder-name-internal folder))) + (progn + (message "") + (setq wl-folder-entity-hashtb + (wl-folder-create-entity-hashtb + (elmo-folder-name-internal folder) + wl-folder-entity-hashtb)) + (unless (elmo-folder-create folder) + (error "Create folder failed"))) + (error "Folder %s is not created" (elmo-folder-name-internal folder))) + (error "Folder %s does not exist" (elmo-folder-name-internal folder)))) (defun wl-folder-confirm-existence (folder &optional force) (if force (unless (elmo-folder-exists-p folder) (wl-folder-create-subr folder)) (unless (or (wl-folder-entity-exists-p (elmo-folder-name-internal folder)) - (file-exists-p (elmo-folder-msgdb-path folder)) + (and (elmo-folder-msgdb-path folder) + (file-exists-p (elmo-folder-msgdb-path folder))) (elmo-folder-exists-p folder)) (wl-folder-create-subr folder)))) +(defun wl-folder-virtual () + "Goto virtual folder." + (interactive) + (let ((entity (wl-folder-get-entity-from-buffer))) + (if (wl-folder-buffer-group-p) + (setq entity + (concat + "*" + (mapconcat 'identity + (wl-folder-get-entity-list + (wl-folder-search-group-entity-by-name + entity + wl-folder-entity)) ",")))) + (unless entity (error "No folder")) + (wl-folder-goto-folder-subr + (concat "/" + (elmo-read-search-condition + wl-fldmgr-make-filter-default) + "/" entity)))) + +(defun wl-folder-pick () + (interactive) + (save-excursion + (let* ((condition (car (elmo-parse-search-condition + (elmo-read-search-condition + wl-summary-pick-field-default)))) + (entity (wl-folder-get-entity-from-buffer)) + (folder-list + (if (wl-folder-buffer-group-p) + (wl-folder-get-entity-list + (wl-folder-search-group-entity-by-name + entity + wl-folder-entity)) + (list entity))) + results ret) + (while (car folder-list) + (setq ret (elmo-folder-search + (wl-folder-get-elmo-folder (car folder-list)) + condition)) + (if ret + (setq results + (append results + (list (cons (car folder-list) ret))))) + (setq folder-list (cdr folder-list))) + (if results + (message "%s are picked." + (mapconcat '(lambda (res) + (format "%s(%d)" + (car res) + (length (cdr res)))) + results + ",")) + (message "No message was picked."))))) + +(defun wl-folder-jump-to-next-summary () + (interactive) + (when (wl-collect-summary) + (if (get-buffer-window (car (wl-collect-summary))) + (switch-to-buffer-other-window (car (wl-collect-summary)))) + (wl-summary-next-buffer))) + +(defun wl-folder-jump-to-previous-summary () + (interactive) + (when (wl-collect-summary) + (if (get-buffer-window (car (wl-collect-summary))) + (switch-to-buffer-other-window (car (wl-collect-summary)))) + (wl-summary-previous-buffer))) + +;;; +;; Completion +(defvar wl-folder-complete-folder-candidate nil) + +(defun wl-folder-complete-folder (string predicate flag) + (cond ((or (string-match "^\\(/[^/]*/\\)\\(.*\\)$" string) ; filter + (string-match "^\\(\*\\|\*.*,\\)\\([^,]*\\)$" string) ; multi + (string-match "^\\(|[^|]*|:?\\)\\(.*\\)$" string) ;pipe-src + (string-match "^\\(|\\)\\([^|]*\\)$" string)) ;pipe-dst + (let* ((str1 (match-string 1 string)) + (str2 (match-string 2 string)) + (str2-comp (wl-folder-complete-folder str2 predicate flag))) + (cond + ((listp str2-comp) ; flag=t + (mapcar (lambda (x) (concat str1 x)) str2-comp)) + ((stringp str2-comp) + (concat str1 str2-comp)) + (t + str2-comp)))) + ((string-match "^\\(/\\)\\([^/]*\\)$" string) ; filter-condition + (let* ((str1 (match-string 1 string)) + (str2 (match-string 2 string)) + (str2-comp + (wl-folder-complete-filter-condition str2 predicate flag))) + (cond + ((listp str2-comp) ; flag=t + (mapcar (lambda (x) (concat str1 x)) str2-comp)) + ((stringp str2-comp) + (concat str1 str2-comp)) + (t + str2-comp)))) + (t + (let ((candidate + (or wl-folder-complete-folder-candidate + (if (memq 'read-folder wl-use-folder-petname) + (wl-folder-get-entity-with-petname) + wl-folder-entity-hashtb)))) + (if (not flag) + (try-completion string candidate) + (all-completions string candidate)))))) + +(defun wl-folder-complete-filter-condition (string predicate flag) + (cond + ((string-match "^\\(.*|\\|.*&\\|.*!\\|.*(\\)\\([^:]*\\)$" string) + (let* ((str1 (match-string 1 string)) + (str2 (match-string 2 string)) + (str2-comp + (wl-folder-complete-filter-condition str2 predicate flag))) + (cond + ((listp str2-comp) ; flag=t + (mapcar (lambda (x) (concat str1 x)) str2-comp)) + ((stringp str2-comp) + (concat str1 str2-comp)) + (t + str2-comp)))) + (t + (let ((candidate + (mapcar (lambda (x) (list (concat (downcase x) ":"))) + (append '("last" "first" + "from" "subject" "to" "cc" "body" + "since" "before" "tocc") + elmo-msgdb-extra-fields)))) + (if (not flag) + (try-completion string candidate) + (all-completions string candidate)))))) + (require 'product) (product-provide (provide 'wl-folder) (require 'wl-version))