X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=wl%2Fwl-folder.el;h=7edd76cf80f52efd2c175408a8cfa063c85fc825;hb=9122f42f7e85cdf260d2faa7eb5ffd1428b96a43;hp=91d52abfad9fb7cf36f77947569adc35e1375de4;hpb=fdd258ad5f142147f290dce3ccfd20e714d71c35;p=elisp%2Fwanderlust.git diff --git a/wl/wl-folder.el b/wl/wl-folder.el index 91d52ab..7edd76c 100644 --- a/wl/wl-folder.el +++ b/wl/wl-folder.el @@ -77,7 +77,7 @@ (make-variable-buffer-local 'wl-folder-buffer-cur-point) (defconst wl-folder-entity-regexp "^\\([ ]*\\)\\(\\[[\\+-]\\]\\)?\\([^\\[].+\\):[-*0-9]+/[-*0-9]+/[-*0-9]+") -(defconst wl-folder-group-regexp "^\\([ ]*\\)\\[\\([\\+-]\\)\\]\\(.+\\):[-0-9-]+/[0-9-]+/[0-9-]+\n") +(defconst wl-folder-group-regexp "^\\([ ]*\\)\\[\\([\\+-]\\)\\]\\(.+\\):[0-9-]+/[0-9-]+/[0-9-]+\n") ;; 1:indent 2:opened 3:group-name (defconst wl-folder-unsync-regexp ":[^0\\*][0-9]*/[0-9\\*-]+/[0-9\\*-]+$") @@ -225,13 +225,13 @@ wl-folder-mode-menu-spec)) (defmacro wl-folder-unread-regex (group) - (` (concat "^[ ]*.+:[0-9\\*-]+/[^0\\*][0-9]*/[0-9\\*-]+$" - (if (, group) - "\\|^[ ]*\\[[+-]\\]" - "")))) + `(concat "^[ ]*.+:[0-9\\*-]+/[^0\\*][0-9]*/[0-9\\*-]+$" + (if ,group + "\\|^[ ]*\\[[+-]\\]" + ""))) (defmacro wl-folder-buffer-group-p () - (` (get-text-property (point) 'wl-folder-is-group))) + '(get-text-property (point) 'wl-folder-is-group)) (defun wl-folder-buffer-search-group (group) (let ((prev-point (point)) @@ -281,24 +281,23 @@ (wl-folder-get-folder-name-by-id id)))) (defmacro wl-folder-entity-exists-p (entity &optional hashtb) - (` (let ((sym (intern-soft (, entity) - (or (, hashtb) wl-folder-entity-hashtb)))) - (and sym (boundp sym))))) + `(let ((sym (intern-soft ,entity (or ,hashtb wl-folder-entity-hashtb)))) + (and sym (boundp sym)))) (defmacro wl-folder-clear-entity-info (entity &optional hashtb) - (` (elmo-clear-hash-val (, entity) (or (, hashtb) wl-folder-entity-hashtb)))) + `(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)))) + `(elmo-get-hash-val ,entity (or ,hashtb wl-folder-entity-hashtb))) (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 (elmo-string (, entity)) - (if (< (length (, value)) 4) - (append (, value) (list (nth 3 info))) - (, value)) - hashtb)))) + `(let* ((hashtb (or ,hashtb wl-folder-entity-hashtb)) + (info (wl-folder-get-entity-info ,entity hashtb))) + (elmo-set-hash-val (elmo-string ,entity) + (if (< (length ,value) 4) + (append ,value (list (nth 3 info))) + ,value) + hashtb))) (defun wl-folder-persistent-p (folder) (or (and (wl-folder-search-entity-by-name folder wl-folder-entity @@ -321,14 +320,14 @@ (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'." - (` (elmo-get-hash-val (, name) - (or (, hashtb) wl-folder-elmo-folder-hashtb)))) + `(elmo-get-hash-val ,name + (or ,hashtb wl-folder-elmo-folder-hashtb))) (defmacro wl-folder-elmo-folder-cache-put (name folder &optional hashtb) "Get folder elmo folder structure on HASHTB for folder with NAME. Default HASHTB is `wl-folder-elmo-folder-hashtb'." - (` (elmo-set-hash-val (, name) (, folder) - (or (, hashtb) 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." @@ -865,19 +864,16 @@ Optional argument ARG is repeart count." (if (wl-string-match-member entity wl-strict-diff-folders) (elmo-strict-folder-diff folder) (elmo-folder-diff folder))) + (elmo-open-error + (signal (car err) (cdr err))) (error ;; maybe not exist folder. - (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))) + (if (not (elmo-folder-exists-p folder)) (wl-folder-create-subr folder) (signal (car err) (cdr err)))))) (new (elmo-diff-new nums)) (unread (elmo-diff-unread nums)) - (all (elmo-diff-all nums)) - unsync nomif) + (all (elmo-diff-all nums))) (if (and (eq wl-folder-notify-deleted 'sync) (or (and new (> 0 new)) (and unread (> 0 unread)) @@ -892,10 +888,11 @@ Optional argument ARG is repeart count." (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))) + (setq unread (if unread + (- unread (or new 0)) + (or (elmo-folder-get-info-unread folder) + (cdr (assq 'unread (elmo-folder-count-flags folder))) + 0))) (wl-folder-entity-hashtb-set wl-folder-entity-hashtb entity (list new unread all) (get-buffer wl-folder-buffer-name))) @@ -1765,9 +1762,9 @@ Entering Folder mode calls the value of `wl-folder-mode-hook'." (wl-highlight-folder-current-line)) (setq removed (cdr removed))) (remove-text-properties beg (point) '(wl-folder-entity-id))) - (let* ((len (length flist)) - (mes (> len 100)) - (i 0)) + (elmo-with-progress-display + (wl-folder-insert-entity (length flist)) + (format "Inserting group %s" (car entity)) (while flist (setq ret-val (wl-folder-insert-entity @@ -1775,15 +1772,8 @@ Entering Folder mode calls the value of `wl-folder-mode-hook'." (setq new (+ (or new 0) (or (nth 0 ret-val) 0))) (setq unread (+ (or unread 0) (or (nth 1 ret-val) 0))) (setq all (+ (or all 0) (or (nth 2 ret-val) 0))) - (when (and mes - (> len elmo-display-progress-threshold)) - (setq i (1+ i)) - (elmo-display-progress - 'wl-folder-insert-entity "Inserting group %s..." - (/ (* i 100) len) (car entity))) - (setq flist (cdr flist))) - (if (> len 0) - (message "Inserting group %s...done" (car entity)))) + (elmo-progress-notify 'wl-folder-insert-entity) + (setq flist (cdr flist)))) (save-excursion (goto-char group-name-end) (delete-region (point) (save-excursion (end-of-line) @@ -2208,11 +2198,11 @@ Use `wl-subscribed-mailing-list'." (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 + (setq cur-new (string-to-number (wl-match-buffer 2))) - (setq cur-unread (string-to-int + (setq cur-unread (string-to-number (wl-match-buffer 3))) - (setq cur-all (string-to-int + (setq cur-all (string-to-number (wl-match-buffer 4))) (delete-region (match-beginning 2) (match-end 4)) @@ -2553,37 +2543,30 @@ Use `wl-subscribed-mailing-list'." (erase-buffer) (wl-folder-insert-entity " " wl-folder-entity) (wl-folder-move-path id)) - (message "Opening all folders...") - (wl-folder-open-all-pre) - (save-excursion - (goto-char (point-min)) - (while (re-search-forward - "^\\([ ]*\\)\\[\\([+]\\)\\]\\(.+\\):[-0-9-]+/[0-9-]+/[0-9-]+$" - nil t) - (setq indent (wl-match-buffer 1)) - (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) - (beginning-of-line) - (wl-folder-insert-entity indent entity) - (delete-region (save-excursion (beginning-of-line) - (point)) - (save-excursion (end-of-line) - (+ 1 (point)))) - (when (> len elmo-display-progress-threshold) - (setq i (1+ i)) - (if (or (zerop (% i 5)) (= i len)) - (elmo-display-progress - 'wl-folder-open-all "Opening all folders..." - (/ (* i 100) len))))) - (when (> len elmo-display-progress-threshold) - (elmo-display-progress - 'wl-folder-open-all "Opening all folders..." 100)))) + (elmo-with-progress-display + (wl-folder-open-all (length wl-folder-group-alist)) + "Opening all folders" + (wl-folder-open-all-pre) + (save-excursion + (goto-char (point-min)) + (while (re-search-forward + "^\\([ ]*\\)\\[\\([+]\\)\\]\\(.+\\):[-0-9-]+/[0-9-]+/[0-9-]+$" + nil t) + (setq indent (wl-match-buffer 1)) + (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) + (beginning-of-line) + (wl-folder-insert-entity indent entity) + (delete-region (save-excursion (beginning-of-line) + (point)) + (save-excursion (end-of-line) + (+ 1 (point)))) + (elmo-progress-notify 'wl-folder-open-all))))) (wl-highlight-folder-path wl-folder-buffer-cur-path) - (message "Opening all folders...done") (set-buffer-modified-p nil))) (defun wl-folder-close-all () @@ -2637,101 +2620,91 @@ Use `wl-subscribed-mailing-list'." t))) (defun wl-folder-update-access-group (entity new-flist) - (let* ((flist (nth 2 entity)) - (unsubscribes (nth 3 entity)) - (len (+ (length flist) (length unsubscribes))) - (i 0) - diff new-unsubscribes removes - subscribed-list folder group entry) - ;; check subscribed groups - (while flist - (cond - ((listp (car flist)) ;; group - (setq group (elmo-string (caar flist))) + (let ((flist (nth 2 entity)) + (unsubscribes (nth 3 entity)) + diff new-unsubscribes removes + subscribed-list folder group entry) + (elmo-with-progress-display + (wl-folder-update-access-group (+ (length flist) (length unsubscribes))) + "Updating access group" + ;; check subscribed groups + (while flist (cond - ((assoc group new-flist) ;; found in new-flist - (setq new-flist (delete (assoc group new-flist) - new-flist)) - (if (wl-folder-access-subscribe-p (car entity) group) - (wl-append subscribed-list (list (car flist))) - (wl-append new-unsubscribes (list (car flist))) - (setq diff t))) - (t - (setq wl-folder-group-alist - (delete (wl-string-assoc group wl-folder-group-alist) - wl-folder-group-alist)) - (wl-append removes (list (list group)))))) - (t ;; folder - (setq folder (elmo-string (car flist))) + ((listp (car flist)) ;; group + (setq group (elmo-string (caar flist))) + (cond + ((assoc group new-flist) ;; found in new-flist + (setq new-flist (delete (assoc group new-flist) + new-flist)) + (if (wl-folder-access-subscribe-p (car entity) group) + (wl-append subscribed-list (list (car flist))) + (wl-append new-unsubscribes (list (car flist))) + (setq diff t))) + (t + (setq wl-folder-group-alist + (delete (wl-string-assoc group wl-folder-group-alist) + wl-folder-group-alist)) + (wl-append removes (list (list group)))))) + (t ;; folder + (setq folder (elmo-string (car flist))) + (cond + ((member folder new-flist) ;; found in new-flist + (setq new-flist (delete folder new-flist)) + (if (wl-folder-access-subscribe-p (car entity) folder) + (wl-append subscribed-list (list (car flist))) + (wl-append new-unsubscribes (list folder)) + (setq diff t))) + (t + (wl-append removes (list folder)))))) + (elmo-progress-notify 'wl-folder-update-access-group) + (setq flist (cdr flist))) + ;; check unsubscribed groups + (while unsubscribes (cond - ((member folder new-flist) ;; found in new-flist - (setq new-flist (delete folder new-flist)) - (if (wl-folder-access-subscribe-p (car entity) folder) - (wl-append subscribed-list (list (car flist))) - (wl-append new-unsubscribes (list folder)) - (setq diff t))) + ((listp (car unsubscribes)) + (when (setq entry (assoc (caar unsubscribes) new-flist)) + (setq new-flist (delete entry new-flist)) + (wl-append new-unsubscribes (list (car unsubscribes))))) (t - (wl-append removes (list folder)))))) - (when (> len elmo-display-progress-threshold) - (setq i (1+ i)) - (if (or (zerop (% i 10)) (= i len)) - (elmo-display-progress - 'wl-folder-update-access-group "Updating access group..." - (/ (* i 100) len)))) - (setq flist (cdr flist))) - ;; check unsubscribed groups - (while unsubscribes - (cond - ((listp (car unsubscribes)) - (when (setq entry (assoc (caar unsubscribes) new-flist)) - (setq new-flist (delete entry new-flist)) - (wl-append new-unsubscribes (list (car unsubscribes))))) - (t - (when (member (car unsubscribes) new-flist) - (setq new-flist (delete (car unsubscribes) new-flist)) - (wl-append new-unsubscribes (list (car unsubscribes)))))) - (when (> len elmo-display-progress-threshold) - (setq i (1+ i)) - (if (or (zerop (% i 10)) (= i len)) - (elmo-display-progress - 'wl-folder-update-access-group "Updating access group..." - (/ (* i 100) len)))) - (setq unsubscribes (cdr unsubscribes))) - ;; - (if (or new-flist removes) - (setq diff t)) - (setq new-flist - (mapcar '(lambda (x) - (cond ((consp x) (list (car x) 'access)) - (t x))) - new-flist)) - ;; check new groups - (let ((new-list new-flist)) - (while new-list - (if (not (wl-folder-access-subscribe-p - (car entity) - (if (listp (car new-list)) - (caar new-list) - (car new-list)))) - ;; auto unsubscribe - (progn - (wl-append new-unsubscribes (list (car new-list))) - (setq new-flist (delete (car new-list) new-flist))) - (cond - ((listp (car new-list)) - ;; check group exists - (if (wl-string-assoc (caar new-list) wl-folder-group-alist) - (progn - (message "%s: group already exists." (caar new-list)) - (sit-for 1) - (wl-append new-unsubscribes (list (car new-list))) - (setq new-flist (delete (car new-list) new-flist))) - (wl-append wl-folder-group-alist - (list (cons (caar new-list) nil))))))) - (setq new-list (cdr new-list)))) - (if new-flist - (message "%d new folder(s)." (length new-flist)) - (message "Updating access group...done")) + (when (member (car unsubscribes) new-flist) + (setq new-flist (delete (car unsubscribes) new-flist)) + (wl-append new-unsubscribes (list (car unsubscribes)))))) + (elmo-progress-notify 'wl-folder-update-access-group) + (setq unsubscribes (cdr unsubscribes))) + ;; + (if (or new-flist removes) + (setq diff t)) + (setq new-flist + (mapcar '(lambda (x) + (cond ((consp x) (list (car x) 'access)) + (t x))) + new-flist)) + ;; check new groups + (let ((new-list new-flist)) + (while new-list + (if (not (wl-folder-access-subscribe-p + (car entity) + (if (listp (car new-list)) + (caar new-list) + (car new-list)))) + ;; auto unsubscribe + (progn + (wl-append new-unsubscribes (list (car new-list))) + (setq new-flist (delete (car new-list) new-flist))) + (cond + ((listp (car new-list)) + ;; check group exists + (if (wl-string-assoc (caar new-list) wl-folder-group-alist) + (progn + (message "%s: group already exists." (caar new-list)) + (sit-for 1) + (wl-append new-unsubscribes (list (car new-list))) + (setq new-flist (delete (car new-list) new-flist))) + (wl-append wl-folder-group-alist + (list (cons (caar new-list) nil))))))) + (setq new-list (cdr new-list))))) + (when new-flist + (message "%d new folder(s)." (length new-flist))) (wl-append new-flist subscribed-list) ;; new is first (run-hooks 'wl-folder-update-access-group-hook) (setcdr (cdr entity) (list new-flist new-unsubscribes))