X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=wl%2Fwl-folder.el;h=9722be7383db4d81cd7170d42877846b4f44e783;hb=792117ed11a4e4977d87b2b10e5bee3bf99a154b;hp=232da5b9706884eeb719414466929c056d9abba2;hpb=904f224e492403eb92709aa60d90858c2d1b714d;p=elisp%2Fwanderlust.git diff --git a/wl/wl-folder.el b/wl/wl-folder.el index 232da5b..9722be7 100644 --- a/wl/wl-folder.el +++ b/wl/wl-folder.el @@ -1,8 +1,10 @@ -;;; wl-folder.el -- Folder mode for Wanderlust. +;;; wl-folder.el --- Folder mode for Wanderlust. -;; Copyright 1998,1999,2000 Yuuichi Teranishi +;; Copyright (C) 1998,1999,2000 Yuuichi Teranishi +;; Copyright (C) 1998,1999,2000 Masahiro MURATA ;; Author: Yuuichi Teranishi +;; Masahiro MURATA ;; Keywords: mail, net news ;; This file is part of Wanderlust (Yet Another Message Interface on Emacsen). @@ -24,14 +26,14 @@ ;; ;;; Commentary: -;; +;; ;;; Code: -;; +;; (require 'elmo-vars) (require 'elmo-util) -(require 'elmo2) +(require 'elmo) (require 'wl-vars) (condition-case () (require 'easymenu) ; needed here. @@ -42,12 +44,12 @@ (require 'wl-util) (provide 'wl-folder) (require 'wl) - (require 'elmo-nntp) - (if wl-use-semi - (require 'mmelmo)) - (unless (boundp ':file) - (set (make-local-variable ':file) nil)) - (defun-maybe mmelmo-cleanup-entity-buffers ())) + (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. @@ -55,37 +57,22 @@ (defvar wl-folder-entity-id nil) ; id (defvar wl-folder-entity-hashtb nil) (defvar wl-folder-entity-id-name-hashtb nil) +(defvar wl-folder-elmo-folder-hashtb nil) ; name => elmo folder structure + (defvar wl-folder-newsgroups-hashtb nil) (defvar wl-folder-info-alist-modified nil) -(defvar wl-folder-completion-func nil) +(defvar wl-folder-completion-function nil) (defvar wl-folder-mode-map nil) -(defvar wl-folder-opened-glyph nil) -(defvar wl-folder-closed-glyph nil) -(defvar wl-folder-nntp-glyph nil) -(defvar wl-folder-imap4-glyph nil) -(defvar wl-folder-pop3-glyph nil) -(defvar wl-folder-localdir-glyph nil) -(defvar wl-folder-localnews-glyph nil) -(defvar wl-folder-internal-glyph nil) -(defvar wl-folder-multi-glyph nil) -(defvar wl-folder-filter-glyph nil) -(defvar wl-folder-archive-glyph nil) -(defvar wl-folder-pipe-glyph nil) -(defvar wl-folder-maildir-glyph nil) -(defvar wl-folder-trash-empty-glyph nil) -(defvar wl-folder-trash-glyph nil) -(defvar wl-folder-draft-glyph nil) -(defvar wl-folder-queue-glyph nil) - (defvar wl-folder-buffer-disp-summary nil) -(make-variable-buffer-local 'wl-folder-buffer-disp-summary) (defvar wl-folder-buffer-cur-entity-id nil) -(make-variable-buffer-local 'wl-folder-buffer-cur-entity-id) (defvar wl-folder-buffer-cur-path nil) -(make-variable-buffer-local 'wl-folder-buffer-cur-entity-id) (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-cur-path) (make-variable-buffer-local 'wl-folder-buffer-cur-point) (defconst wl-folder-entity-regexp "^\\([ ]*\\)\\(\\[[\\+-]\\]\\)?\\([^\\[].+\\):[-*0-9]+/[-*0-9]+/[-*0-9]+") @@ -100,7 +87,7 @@ ["Next Folder" wl-folder-next-entity t] ["Check Current Folder" wl-folder-check-current-entity t] ["Sync Current Folder" wl-folder-sync-current-entity t] - ["Drop Current Folder" wl-folder-drop-unsync-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] @@ -137,18 +124,16 @@ (define-key wl-folder-mode-map 'button2 'wl-folder-click) (define-key wl-folder-mode-map 'button4 'wl-folder-prev-entity) (define-key wl-folder-mode-map 'button5 'wl-folder-next-entity) - (define-key wl-folder-mode-map [(shift button4)] + (define-key wl-folder-mode-map [(shift button4)] 'wl-folder-prev-unread) - (define-key wl-folder-mode-map [(shift button5)] + (define-key wl-folder-mode-map [(shift button5)] 'wl-folder-next-unread)) - (if wl-on-nemacs - (defun wl-folder-setup-mouse ()) - (defun wl-folder-setup-mouse () - (define-key wl-folder-mode-map [mouse-2] 'wl-folder-click) - (define-key wl-folder-mode-map [mouse-4] 'wl-folder-prev-entity) - (define-key wl-folder-mode-map [mouse-5] 'wl-folder-next-entity) - (define-key wl-folder-mode-map [S-mouse-4] 'wl-folder-prev-unread) - (define-key wl-folder-mode-map [S-mouse-5] 'wl-folder-next-unread)))) + (defun wl-folder-setup-mouse () + (define-key wl-folder-mode-map [mouse-2] 'wl-folder-click) + (define-key wl-folder-mode-map [mouse-4] 'wl-folder-prev-entity) + (define-key wl-folder-mode-map [mouse-5] 'wl-folder-next-entity) + (define-key wl-folder-mode-map [S-mouse-4] 'wl-folder-prev-unread) + (define-key wl-folder-mode-map [S-mouse-5] 'wl-folder-next-unread))) (if wl-folder-mode-map nil @@ -163,14 +148,15 @@ (define-key wl-folder-mode-map "g" 'wl-folder-goto-folder) (define-key wl-folder-mode-map "j" 'wl-folder-jump-to-current-entity) (define-key wl-folder-mode-map "w" 'wl-draft) - (define-key wl-folder-mode-map "W" 'wl-folder-write-current-newsgroup) + (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 "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) (define-key wl-folder-mode-map "s" 'wl-folder-check-current-entity) (define-key wl-folder-mode-map "I" 'wl-folder-prefetch-current-entity) - (define-key wl-folder-mode-map "D" 'wl-folder-drop-unsync-current-entity) +; (define-key wl-folder-mode-map "D" 'wl-folder-drop-unsync-current-entity) (define-key wl-folder-mode-map "p" 'wl-folder-prev-entity) (define-key wl-folder-mode-map "n" 'wl-folder-next-entity) (define-key wl-folder-mode-map "v" 'wl-folder-toggle-disp-summary) @@ -185,14 +171,13 @@ (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 "q" 'wl-exit) - (define-key wl-folder-mode-map "z" 'wl-folder-suspend) + (define-key wl-folder-mode-map "z" 'wl-folder-suspend) (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) (define-key wl-folder-mode-map ">" 'end-of-buffer) ;; wl-fldmgr - (unless wl-on-nemacs - (define-key wl-folder-mode-map "m" 'wl-fldmgr-mode-map)) + (define-key wl-folder-mode-map "m" 'wl-fldmgr-mode-map) (define-key wl-folder-mode-map "*" 'wl-fldmgr-make-multi) (define-key wl-folder-mode-map "+" 'wl-fldmgr-make-group) (define-key wl-folder-mode-map "|" 'wl-fldmgr-make-filter) @@ -211,6 +196,11 @@ (define-key wl-folder-mode-map "\C-x\C-s" 'wl-save) (define-key wl-folder-mode-map "\M-s" 'wl-save) (define-key wl-folder-mode-map "\C-xk" 'wl-folder-mimic-kill-buffer) + (define-key wl-folder-mode-map "\M-\C-a" + 'wl-folder-goto-top-of-current-folder) + (define-key wl-folder-mode-map "\M-\C-e" + 'wl-folder-goto-bottom-of-current-folder) + (wl-folder-setup-mouse) (easy-menu-define wl-folder-mode-menu @@ -243,14 +233,14 @@ (defun wl-folder-buffer-search-group (group) (re-search-forward - (concat + (concat "^\\([ \t]*\\)\\[[\\+-]\\]" (regexp-quote group) ":[-0-9-]+/[0-9-]+/[0-9-]+") nil t)) (defun wl-folder-buffer-search-entity (folder &optional searchname) (let ((search (or searchname (wl-folder-get-petname folder)))) (re-search-forward - (concat + (concat "^[ \t]*" (regexp-quote search) ":[-0-9\\*-]+/[0-9\\*-]+/[0-9\\*-]+") nil t))) @@ -265,19 +255,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) @@ -303,7 +288,9 @@ hashtb)))) (defun wl-folder-persistent-p (folder) - (or (elmo-get-hash-val folder wl-folder-entity-hashtb) ; on Folder mode. + (or (and (wl-folder-search-entity-by-name folder wl-folder-entity + 'folder) + t) ; on Folder mode. (catch 'found (let ((li wl-save-folder-list)) (while li @@ -317,6 +304,27 @@ (throw 'found t)) (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'." + (` (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)))) + (defun wl-folder-prev-entity () (interactive) (forward-line -1)) @@ -335,7 +343,7 @@ (goto-char (point-min)))) (defun wl-folder-next-entity-skip-invalid (&optional hereto) - "move to next entity. skip unsubscribed or removed entity." + "Move to next entity. skip unsubscribed or removed entity." (interactive) (beginning-of-line) (if (not hereto) @@ -398,9 +406,9 @@ (setq entity (wl-pop entities)) (cond ((consp entity) -;; (if (and (string= name (car entity)) -;; (eq id (wl-folder-get-entity-id (car entity)))) -;; (throw 'done last-entity)) +;; (if (and (string= name (car entity)) +;; (eq id (wl-folder-get-entity-id (car entity)))) +;; (throw 'done last-entity)) (and entities (wl-push entities entity-stack)) (setq entities (nth 2 entity))) @@ -428,9 +436,9 @@ (setq entity (wl-pop entities)) (cond ((consp entity) -;; (if (and (string= name (car entity)) -;; (eq id (wl-folder-get-entity-id (car entity)))) -;; (setq found t)) +;;; (if (and (string= name (car entity)) +;;; (eq id (wl-folder-get-entity-id (car entity)))) +;;; (setq found t)) (and entities (wl-push entities entity-stack)) (setq entities (nth 2 entity))) @@ -457,10 +465,11 @@ emptied) (if elmo-enable-disconnected-operation (elmo-dop-queue-flush 'force)) ; Try flushing all queue. - (if (not (elmo-list-folder wl-queue-folder)) + (if (not (elmo-folder-list-messages + (wl-folder-get-elmo-folder wl-queue-folder))) (message "No sending queue exists.") (if wl-stay-folder-window - (wl-folder-select-buffer + (wl-folder-select-buffer (wl-summary-get-buffer-create wl-queue-folder))) (wl-summary-goto-folder-subr wl-queue-folder 'force-update nil) (unwind-protect @@ -479,7 +488,7 @@ (wl-auto-select-first nil) trash-buf emptied) (if wl-stay-folder-window - (wl-folder-select-buffer + (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)) @@ -489,7 +498,7 @@ (setq wl-thread-entities nil wl-thread-entity-list nil) (if wl-summary-cache-use (wl-summary-save-view-cache)) - (wl-summary-msgdb-save)) + (elmo-folder-commit wl-summary-buffer-elmo-folder)) (if (get-buffer-window cur-buf) (select-window (get-buffer-window cur-buf))) (set-buffer cur-buf) @@ -498,46 +507,60 @@ (if wl-stay-folder-window (wl-folder-toggle-disp-summary 'off wl-trash-folder) (switch-to-buffer cur-buf)) - (and trash-buf + (and trash-buf (kill-buffer trash-buf))))) -(defun wl-folder-goto-top-of-current-folder () - (if (re-search-backward "^\\([ ]*\\)\\[\\([\\+-]\\)\\]\\(.+\\)\n" nil t) +(defun wl-folder-goto-top-of-current-folder (&optional arg) + "Move backward to the top of the current folder group. +Optional argument ARG is repeart count." + (interactive "P") + (if (re-search-backward + "^ *\\[[\\+-]\\]" nil t (if arg (prefix-numeric-value arg))) (beginning-of-line) (goto-char (point-min)))) (defun wl-folder-goto-bottom-of-current-folder (indent) + "Move forward to the bottom of the current folder group." + (interactive + (let ((indent + (save-excursion + (beginning-of-line) + (if (looking-at "^ *") + (buffer-substring (match-beginning 0)(1- (match-end 0))) + "")))) + (list indent))) (if (catch 'done - (while (re-search-forward "^\\([ ]*\\)[^ ]" nil t) - (if (<= (length (wl-match-buffer 1)) + (while (re-search-forward "^ *" nil t) + (if (<= (length (match-string 0)) (length indent)) (throw 'done nil))) (throw 'done t)) (goto-char (point-max)))) (defsubst wl-folder-update-group (entity diffs &optional is-group) - (let ((path (wl-folder-get-path - wl-folder-entity - (wl-folder-get-entity-id entity) - entity))) - (if (not is-group) - ;; delete itself from path - (setq path (delete (nth (- (length path) 1) path) path))) - (goto-char (point-min)) - (catch 'done - (while path - ;; goto the path line. - (if (or (eq (car path) 0) ; update desktop - (wl-folder-buffer-search-group - (wl-folder-get-petname - (if (stringp (car path)) - (car path) - (wl-folder-get-folder-name-by-id - (car path)))))) - ;; update it. - (wl-folder-update-diff-line diffs) - (throw 'done t)) - (setq path (cdr path)))))) + (save-excursion + (let ((path (wl-folder-get-path + wl-folder-entity + (wl-folder-get-entity-id entity) + entity))) + (if (not is-group) + ;; delete itself from path + (setq path (delete (nth (- (length path) 1) path) path))) + (goto-char (point-min)) + (catch 'done + (while path + ;; goto the path line. + (if (or (eq (car path) 0) ; update desktop + (wl-folder-buffer-search-group + (wl-folder-get-petname + (if (stringp (car path)) + (car path) + (wl-folder-get-folder-name-by-id + (car path)))))) + ;; update it. + (wl-folder-update-diff-line diffs) + (throw 'done t)) + (setq path (cdr path))))))) (defun wl-folder-maybe-load-folder-list (entity) (when (null (caddr entity)) @@ -561,11 +584,11 @@ wl-force-fetch-folders))) (defun wl-folder-jump-to-current-entity (&optional arg) - "Enter the current folder. If optional arg exists, update folder list. " + "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 + (cond ((looking-at wl-folder-group-regexp) (save-excursion (setq fname (wl-folder-get-realname (wl-match-buffer 3))) @@ -573,39 +596,39 @@ (setq opened (wl-match-buffer 2)) (if (string= opened "+") (progn - (setq entity (wl-folder-search-group-entity-by-name + (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)))))))) + ;; 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 @@ -613,7 +636,7 @@ (progn (wl-folder-goto-bottom-of-current-folder indent) (beginning-of-line) (point)))) - (setq entity (wl-folder-search-group-entity-by-name + (setq entity (wl-folder-search-group-entity-by-name fname wl-folder-entity)) (let ((buffer-read-only nil)) @@ -626,24 +649,20 @@ ; (wl-highlight-folder-current-line) ))) ((setq fld-name (wl-folder-entity-name)) - (if wl-on-nemacs - (progn - (wl-folder-set-current-entity-id - (wl-folder-get-entity-from-buffer)) - (setq fld-name (wl-folder-get-realname fld-name))) - (wl-folder-set-current-entity-id - (get-text-property (point) 'wl-folder-entity-id)) - (setq fld-name (wl-folder-get-folder-name-by-id - wl-folder-buffer-cur-entity-id))) + (wl-folder-set-current-entity-id + (get-text-property (point) 'wl-folder-entity-id)) + (setq fld-name (wl-folder-get-folder-name-by-id + wl-folder-buffer-cur-entity-id)) (let ((summary-buf (wl-summary-get-buffer-create fld-name arg)) error-selecting) - (if wl-stay-folder-window + (if (or wl-stay-folder-window wl-summary-use-frame) (wl-folder-select-buffer summary-buf) (if (and summary-buf (get-buffer-window summary-buf)) (delete-window))) - (wl-summary-goto-folder-subr fld-name - (wl-summary-get-sync-range fld-name) + (wl-summary-goto-folder-subr fld-name + (wl-summary-get-sync-range + (wl-folder-get-elmo-folder fld-name)) nil arg t))))) (set-buffer-modified-p nil)) @@ -667,50 +686,50 @@ (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-entity))) - (let ((inhibit-read-only t) - (entities (list entity)) - entity-stack err indent) - (while (and entities (not err)) - (setq entity (wl-pop entities)) - (cond - ((consp entity) - (wl-folder-close-entity entity) - (setcdr (assoc (car entity) wl-folder-group-alist) t) - (unless (wl-folder-buffer-search-group - (wl-folder-get-petname (car entity))) - (error "%s: not found group" (car entity))) - (setq indent (wl-match-buffer 1)) - (if (eq 'access (cadr entity)) - (wl-folder-maybe-load-folder-list entity)) - (beginning-of-line) - (setq err nil) - (save-excursion - (condition-case errobj - (wl-folder-update-newest indent entity) - (quit - (setq err t) - (setcdr (assoc (car entity) wl-folder-group-alist) nil)) - (error - (elmo-display-error errobj t) - (ding) - (setq err t) - (setcdr (assoc (car entity) wl-folder-group-alist) nil))) - (if (not err) - (delete-region (save-excursion (beginning-of-line) - (point)) - (save-excursion (end-of-line) - (+ 1 (point)))))) - ;; - (and entities - (wl-push entities entity-stack)) - (setq entities (nth 2 entity)))) - (unless entities - (setq entities (wl-pop entity-stack))))) + (if entity () + (setq entity + (wl-folder-search-group-entity-by-name + (wl-folder-get-realname (wl-match-buffer 3)) + wl-folder-entity))) + (let ((inhibit-read-only t) + (entities (list entity)) + entity-stack err indent) + (while (and entities (not err)) + (setq entity (wl-pop entities)) + (cond + ((consp entity) + (wl-folder-close-entity entity) + (setcdr (assoc (car entity) wl-folder-group-alist) t) + (unless (wl-folder-buffer-search-group + (wl-folder-get-petname (car entity))) + (error "%s: not found group" (car entity))) + (setq indent (wl-match-buffer 1)) + (if (eq 'access (cadr entity)) + (wl-folder-maybe-load-folder-list entity)) + (beginning-of-line) + (setq err nil) + (save-excursion + (condition-case errobj + (wl-folder-update-newest indent entity) + (quit + (setq err t) + (setcdr (assoc (car entity) wl-folder-group-alist) nil)) + (error + (elmo-display-error errobj t) + (ding) + (setq err t) + (setcdr (assoc (car entity) wl-folder-group-alist) nil))) + (if (not err) + (delete-region (save-excursion (beginning-of-line) + (point)) + (save-excursion (end-of-line) + (+ 1 (point)))))) + ;; + (and entities + (wl-push entities entity-stack)) + (setq entities (nth 2 entity)))) + (unless entities + (setq entities (wl-pop entity-stack))))) (set-buffer-modified-p nil))) (t (wl-folder-jump-to-current-entity))))) @@ -748,7 +767,7 @@ (save-excursion (cond ((consp entity) - (let ((flist (if auto + (let ((flist (if auto (elmo-delete-if 'wl-folder-no-auto-check-folder-p (nth 2 entity)) @@ -765,94 +784,71 @@ ;(wl-folder-buffer-search-entity (car entity)) ;(wl-folder-update-line ret-val) )) - ((and (stringp entity) - (elmo-folder-plugged-p entity)) + ((stringp entity) (message "Checking \"%s\"" entity) - (setq ret-val (wl-folder-check-one-entity entity)) + (setq ret-val (wl-folder-check-one-entity + entity)) (goto-char start-pos) (sit-for 0)) (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)) -;; All contained folders are imap4 and persistent flag, then -;; use server diff. -(defun wl-folder-use-server-diff-p (folder) - (let ((spec (elmo-folder-get-spec folder))) - (cond - ((eq (car spec) 'multi) - (let ((folders (cdr spec))) - (catch 'done - (while folders - (if (wl-folder-use-server-diff-p (car folders)) - (throw 'done t)) - (setq folders (cdr folders))) - nil))) - ((eq (car spec) 'filter) - (wl-folder-use-server-diff-p (nth 2 spec))) - ((eq (car spec) 'imap4) - (and wl-folder-use-server-diff - (elmo-imap4-use-flag-p spec))) - (t nil)))) - (defun wl-folder-check-one-entity (entity) - (let* ((elmo-use-server-diff (wl-folder-use-server-diff-p entity)) + (let* ((folder (wl-folder-get-elmo-folder entity)) (nums (condition-case err - (if (wl-string-member entity wl-strict-diff-folders) - (elmo-strict-folder-diff entity) - (elmo-folder-diff entity)) + (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 (not (elmo-folder-exists-p entity)) - (if (not (elmo-folder-creatable-p entity)) - (error "Folder %s is not found" entity) - (if (y-or-n-p - (format "Folder %s does not exist, create it?" - entity)) - (progn - (unless (elmo-create-folder entity) - (error "Create folder failed")) - ;; one more try. - (if (wl-string-member entity wl-strict-diff-folders) - (elmo-strict-folder-diff entity) - (elmo-folder-diff entity))) - (error "Folder is not created"))) + (if (and (not (memq 'elmo-open-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) (if (and (eq wl-folder-notify-deleted 'sync) (car nums) (or (> 0 (car nums)) (> 0 (cdr nums)))) (progn (wl-folder-sync-entity entity) - (setq nums (elmo-folder-diff entity))) + (setq nums (elmo-folder-diff folder))) (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 unsync (if (car nums) + (max 0 (car nums)) + nil)) + (setq nomif (if (cdr nums) + (max 0 (cdr nums)) + nil)) (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))))) + (when new (setq unread (- unread new))) (wl-folder-entity-hashtb-set wl-folder-entity-hashtb entity - (list (car nums) - (setq - unread - (or - ;; If server diff, All unreads are - ;; treated as unsync. - (if elmo-use-server-diff 0) - (elmo-folder-get-info-unread entity) - (wl-summary-count-unread - (elmo-msgdb-mark-load - (elmo-msgdb-expand-path entity)) - entity))) + (list (or new (car nums)) + unread (cdr nums)) - (current-buffer))) + (get-buffer wl-folder-buffer-name))) (setq wl-folder-info-alist-modified t) (sit-for 0) (list (if wl-folder-notify-deleted - (car nums) - (max (or (car nums) 0))) unread (cdr nums)))) + (or new (car nums) 0) + (max 0 (or new (car nums) 0))) + unread + (cdr nums)))) (defun wl-folder-check-entity-async (entity &optional auto) (let ((elmo-nntp-groups-async t) @@ -862,50 +858,61 @@ (wl-folder-get-entity-list entity)) (wl-folder-get-entity-list entity))) (nntp-connection-keys nil) - folder spec-list local-elist net-elist server + name folder folder-list + sync-folder-list + async-folder-list + server ret-val) (while elist - (if (not (elmo-folder-plugged-p (car elist))) + (setq folder (wl-folder-get-elmo-folder (car elist))) + (if (not (elmo-folder-plugged-p folder)) (message "Uncheck \"%s\"" (car elist)) - (setq spec-list - (elmo-folder-get-primitive-spec-list (elmo-string (car elist)))) - (cond ((assq 'nntp spec-list) - (wl-append net-elist (list (car elist))) - (while spec-list - (when (eq (caar spec-list) 'nntp) - (when (not (string= server (nth 2 (car spec-list)))) - (setq server (nth 2 (car spec-list))) + (setq folder-list + (elmo-folder-get-primitive-list folder)) + (cond ((elmo-folder-contains-type folder 'nntp) + (wl-append async-folder-list (list folder)) + (while folder-list + (when (eq (elmo-folder-type-internal (car folder-list)) + 'nntp) + (when (not (string= + server + (elmo-net-folder-server-internal + (car folder-list)))) + (setq server (elmo-net-folder-server-internal + (car folder-list))) (message "Checking on \"%s\"" server)) (setq nntp-connection-keys (elmo-nntp-get-folders-info-prepare - (car spec-list) + (car folder-list) nntp-connection-keys))) - (setq spec-list (cdr spec-list)))) + (setq folder-list (cdr folder-list)))) (t - (wl-append local-elist (list (car elist)))))) + (wl-append sync-folder-list (list folder))))) (setq elist (cdr elist))) ;; check local entity at first - (while (setq folder (pop local-elist)) + (while (setq folder (pop sync-folder-list)) (if (not (elmo-folder-plugged-p folder)) - (message "Uncheck \"%s\"" folder) - (message "Checking \"%s\"" folder) + (message "Uncheck \"%s\"" (elmo-folder-name-internal folder)) + (message "Checking \"%s\"" (elmo-folder-name-internal folder)) (setq ret-val (wl-folder-add-folder-info ret-val - (wl-folder-check-one-entity folder))) + (wl-folder-check-one-entity (elmo-folder-name-internal + folder)))) ;;(sit-for 0) )) ;; check network entity at last - (when net-elist + (when async-folder-list (elmo-nntp-get-folders-info nntp-connection-keys) - (while (setq folder (pop net-elist)) + (while (setq folder (pop async-folder-list)) (if (not (elmo-folder-plugged-p folder)) - (message "Uncheck \"%s\"" folder) - (message "Checking \"%s\"" folder) + (message "Uncheck \"%s\"" (elmo-folder-name-internal folder)) + (message "Checking \"%s\"" (elmo-folder-name-internal folder)) (setq ret-val (wl-folder-add-folder-info ret-val - (wl-folder-check-one-entity folder))) + (wl-folder-check-one-entity (elmo-folder-name-internal + folder)))) ;;(sit-for 0) ))) ret-val)) @@ -940,7 +947,7 @@ (defun wl-folder-set-current-entity-id (entity-id) (let ((buf (get-buffer wl-folder-buffer-name))) (if buf - (save-excursion + (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 @@ -955,7 +962,7 @@ (goto-char wl-folder-buffer-cur-point))))) (defun wl-folder-check-current-entity () - "Check folder at position. + "Check folder at position. If current line is group folder, check all sub entries." (interactive) (let* ((entity-name (wl-folder-get-entity-from-buffer)) @@ -978,32 +985,39 @@ If current line is group folder, check all sub entries." (wl-folder-sync-entity (car flist) unread-only) (setq flist (cdr flist))))) ((stringp entity) - (let ((nums (wl-folder-get-entity-info entity)) - (wl-summary-highlight (if (or (wl-summary-sticky-p entity) - (wl-summary-always-sticky-folder-p - entity)) - wl-summary-highlight)) - wl-auto-select-first new unread) + (let* ((folder (wl-folder-get-elmo-folder entity)) + (nums (wl-folder-get-entity-info entity)) + (wl-summary-highlight (if (or (wl-summary-sticky-p folder) + (wl-summary-always-sticky-folder-p + folder)) + wl-summary-highlight)) + wl-auto-select-first new unread) (setq new (or (car nums) 0)) (setq unread (or (cadr nums) 0)) (if (or (not unread-only) (or (< 0 new) (< 0 unread))) - (save-window-excursion - (save-excursion - (wl-summary-goto-folder-subr entity - (wl-summary-get-sync-range entity) - nil nil nil t) - (wl-summary-exit)))))))) + (let ((wl-summary-buffer-name (concat + wl-summary-buffer-name + (symbol-name this-command))) + (wl-summary-use-frame nil) + (wl-summary-always-sticky-folder-list nil)) + (save-window-excursion + (save-excursion + (wl-summary-goto-folder-subr entity + (wl-summary-get-sync-range + folder) + nil nil nil t) + (wl-summary-exit))))))))) (defun wl-folder-sync-current-entity (&optional unread-only) - "Synchronize the folder at position. + "Synchronize the folder at position. If current line is group folder, check all subfolders." (interactive "P") (save-excursion (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 @@ -1013,7 +1027,7 @@ If current line is group folder, check all subfolders." (message "Syncing %s is done!" entity-name))))) (defun wl-folder-mark-as-read-all-entity (entity) - "Mark as read all messages in the ENTITY" + "Mark as read all messages in the ENTITY." (cond ((consp entity) (let ((flist (nth 2 entity))) @@ -1021,26 +1035,32 @@ If current line is group folder, check all subfolders." (wl-folder-mark-as-read-all-entity (car flist)) (setq flist (cdr flist))))) ((stringp entity) - (let ((nums (wl-folder-get-entity-info entity)) - (wl-summary-highlight (if (or (wl-summary-sticky-p entity) - (wl-summary-always-sticky-folder-p - entity)) - wl-summary-highlight)) - wl-auto-select-first new unread) + (let* ((nums (wl-folder-get-entity-info entity)) + (folder (wl-folder-get-elmo-folder entity)) + (wl-summary-highlight (if (or (wl-summary-sticky-p folder) + (wl-summary-always-sticky-folder-p + folder)) + wl-summary-highlight)) + wl-auto-select-first new unread) (setq new (or (car nums) 0)) (setq unread (or (cadr nums) 0)) (if (or (< 0 new) (< 0 unread)) - (save-window-excursion - (save-excursion - (wl-summary-goto-folder-subr entity - (wl-summary-get-sync-range entity) - nil) - (wl-summary-mark-as-read-all) - (wl-summary-exit))) + (save-window-excursion + (save-excursion + (let ((wl-summary-buffer-name (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)))) (sit-for 0)))))) (defun wl-folder-mark-as-read-all-current-entity () - "Mark as read all messages in the folder at position. + "Mark as read all messages in the folder at position. If current line is group folder, all subfolders are marked." (interactive) (save-excursion @@ -1048,7 +1068,7 @@ 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 @@ -1069,10 +1089,11 @@ If current line is group folder, all subfolders are marked." entity) (while (< (point) end) ;; normal folder entity - (if (looking-at "^[\t ]*\\([^\\[]+\\):\\(.*\\)\n") + (if (looking-at "^[\t ]*\\([^\\[]+\\):\\(.*\\)\n") (save-excursion (setq entity (wl-folder-get-entity-from-buffer)) - (if (not (elmo-folder-plugged-p entity)) + (if (not (elmo-folder-plugged-p (wl-folder-get-elmo-folder + entity))) (message "Uncheck %s" entity) (message "Checking %s" entity) (wl-folder-check-one-entity entity) @@ -1091,7 +1112,7 @@ If current line is group folder, all subfolders are marked." (goto-char beg) (while (< (point) end) ;; normal folder entity - (if (looking-at "^[\t ]*\\([^\\[]+\\):\\(.*\\)\n") + (if (looking-at "^[\t ]*\\([^\\[]+\\):\\(.*\\)\n") (save-excursion (let ((inhibit-read-only t) entity) @@ -1113,7 +1134,7 @@ If current line is group folder, all subfolders are marked." (goto-char beg) (while (< (point) end) ;; normal folder entity - (if (looking-at "^[\t ]*\\([^\\[]+\\):\\(.*\\)\n") + (if (looking-at "^[\t ]*\\([^\\[]+\\):\\(.*\\)\n") (save-excursion (let ((inhibit-read-only t) entity) @@ -1167,7 +1188,7 @@ If current line is group folder, all subfolders are marked." (while (setq entity (wl-create-folder-entity-from-buffer)) (unless (eq entity 'ignore) (wl-append flist (list entity)))) - (if (looking-at "^[\t ]*}[\t ]*$") ; end of group + (if (looking-at "^[\t ]*}[\t ]*$") ; end of group (progn (goto-char (+ 1 (match-end 0))) (if (wl-string-assoc name wl-folder-petname-alist) @@ -1187,7 +1208,7 @@ If current line is group folder, all subfolders are marked." ;; (setq flist (car flist)) ;; (list name 'access flist unsublist))) (append (list name 'access) (wl-create-access-folder-entity name)))) - ;((looking-at "^[\t ]*\\([^\t \n}]+\\)[\t ]*\\(\"[^\"]*\"\\)?[\t ]*$") ; normal folder entity + ;((looking-at "^[\t ]*\\([^\t \n}]+\\)[\t ]*\\(\"[^\"]*\"\\)?[\t ]*$") ; normal folder entity ((looking-at "^[\t ]*=[ \t]+\\([^\n]+\\)$"); petname definition (goto-char (+ 1 (match-end 0))) (let ((rest (elmo-match-buffer 1)) @@ -1224,24 +1245,24 @@ If current line is group folder, all subfolders are marked." entity ret-val) (condition-case () (progn - (set-buffer tmp-buf) - (erase-buffer) - (insert-file-contents wl-folders-file) - (goto-char (point-min)) - (while (and (not (eobp)) - (setq entity (wl-create-folder-entity-from-buffer))) - (unless (eq entity 'ignore) - (wl-append ret-val (list entity)))) + (with-current-buffer tmp-buf + (erase-buffer) + (insert-file-contents wl-folders-file) + (goto-char (point-min)) + (while (and (not (eobp)) + (setq entity (wl-create-folder-entity-from-buffer))) + (unless (eq entity 'ignore) + (wl-append ret-val (list entity))))) (kill-buffer tmp-buf)) (file-error nil)) (setq ret-val (list wl-folder-desktop-name 'group ret-val)))) (defun wl-folder-entity-assign-id (entity &optional hashtb on-noid) - (let* ((hashtb (or hashtb - (setq wl-folder-entity-id-name-hashtb - (elmo-make-hash wl-folder-entity-id)))) - (entities (list entity)) - entity-stack) + (let ((hashtb (or hashtb + (setq wl-folder-entity-id-name-hashtb + (elmo-make-hash wl-folder-entity-id)))) + (entities (list entity)) + entity-stack) (while entities (setq entity (wl-pop entities)) (cond @@ -1251,7 +1272,7 @@ If current line is group folder, all subfolders are marked." 'wl-folder-entity-id (car entity)))) (put-text-property 0 (length (car entity)) - 'wl-folder-entity-id + 'wl-folder-entity-id wl-folder-entity-id (car entity)) (wl-folder-set-id-name wl-folder-entity-id @@ -1264,8 +1285,8 @@ 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 + (put-text-property 0 (length entity) + 'wl-folder-entity-id wl-folder-entity-id entity) (wl-folder-set-id-name wl-folder-entity-id @@ -1283,19 +1304,21 @@ If current line is group folder, all subfolders are marked." (defun wl-folder-select-buffer (buffer) (let ((gbw (get-buffer-window buffer)) - ret-val) + exists) (if gbw (progn (select-window gbw) - (setq ret-val t)) - (condition-case () - (unwind-protect - (split-window-horizontally wl-folder-window-width) - (other-window 1)) - (error nil))) + (setq exists t)) + (unless wl-summary-use-frame + (condition-case () + (unwind-protect + (split-window-horizontally wl-folder-window-width) + (other-window 1)) + (error nil)))) (set-buffer buffer) - (switch-to-buffer buffer) - ret-val - )) + (if wl-summary-use-frame + (switch-to-buffer-other-frame buffer) + (switch-to-buffer buffer)) + exists)) (defun wl-folder-toggle-disp-summary (&optional arg folder) (interactive) @@ -1303,7 +1326,8 @@ If current line is group folder, all subfolders are marked." (and (interactive-p) (wl-folder-buffer-group-p))) (error "This command is not available on Group")) (beginning-of-line) - (let (wl-auto-select-first) + (let (wl-auto-select-first + (wl-stay-folder-window t)) (cond ((eq arg 'on) (setq wl-folder-buffer-disp-summary t)) @@ -1316,7 +1340,7 @@ If current line is group folder, all subfolders are marked." (delete-window) (select-window (get-buffer-window cur-buf)))) (t - (setq wl-folder-buffer-disp-summary + (setq wl-folder-buffer-disp-summary (not wl-folder-buffer-disp-summary)) (let ((cur-buf (current-buffer)) folder-name) @@ -1324,7 +1348,7 @@ If current line is group folder, all subfolders are marked." (setq folder-name (wl-folder-get-entity-from-buffer)) (if wl-folder-buffer-disp-summary (progn - (wl-folder-select-buffer + (wl-folder-select-buffer (wl-summary-get-buffer-create folder-name)) (unwind-protect (wl-summary-goto-folder-subr folder-name 'no-sync nil) @@ -1334,7 +1358,7 @@ If current line is group folder, all subfolders are marked." (select-window (get-buffer-window cur-buf))))))))) (defun wl-folder-prev-unsync () - "move cursor to the previous unsync folder." + "Move cursor to the previous unsync folder." (interactive) (let (start-point) (setq start-point (point)) @@ -1345,7 +1369,7 @@ If current line is group folder, all subfolders are marked." (message "No more unsync folder")))) (defun wl-folder-next-unsync (&optional plugged) - "move cursor to the next unsync." + "Move cursor to the next unsync." (interactive) (let (start-point entity) (setq start-point (point)) @@ -1364,7 +1388,7 @@ If current line is group folder, all subfolders are marked." (message "No more unsync folder")))) (defun wl-folder-prev-unread (&optional group) - "move cursor to the previous unread folder." + "Move cursor to the previous unread folder." (interactive "P") (let (start-point) (setq start-point (point)) @@ -1378,7 +1402,7 @@ If current line is group folder, all subfolders are marked." nil))) (defun wl-folder-next-unread (&optional group) - "move cursor to the next unread folder." + "Move cursor to the next unread folder." (interactive "P") (let (start-point) (setq start-point (point)) @@ -1393,7 +1417,7 @@ If current line is group folder, all subfolders are marked." (defun wl-folder-mode () "Major mode for Wanderlust Folder. -See info under Wanderlust for full documentation. +See Info under Wanderlust for full documentation. Special commands: \\{wl-folder-mode-map} @@ -1406,10 +1430,14 @@ Entering Folder mode calls the value of `wl-folder-mode-hook'." (setq buffer-read-only t) (setq inhibit-read-only nil) (setq truncate-lines t) - (when wl-show-plug-status-on-modeline - (setq mode-line-format (wl-make-modeline))) + (setq wl-folder-buffer-cur-entity-id nil + wl-folder-buffer-cur-path nil + wl-folder-buffer-cur-point nil) + (wl-mode-line-buffer-identification) (easy-menu-add wl-folder-mode-menu) - (wl-xmas-setup-folder) + ;; This hook may contain the functions `wl-folder-init-icons' and + ;; `wl-setup-folder' for reasons of system internal to accord + ;; facilities for the Emacs variants. (run-hooks 'wl-folder-mode-hook)) (defun wl-folder-append-petname (realname petname) @@ -1425,58 +1453,75 @@ Entering Folder mode calls the value of `wl-folder-mode-hook'." (defun wl-folder (&optional arg) (interactive "P") - (let (initialize) -; (delete-other-windows) - (if (get-buffer wl-folder-buffer-name) - (switch-to-buffer wl-folder-buffer-name) - (switch-to-buffer (get-buffer-create wl-folder-buffer-name)) - (setq mode-line-buffer-identification '("Wanderlust: %12b")) - (wl-folder-mode) - (wl-folder-init) - (wl-folder-init-icons) - (set-buffer wl-folder-buffer-name) - (let ((inhibit-read-only t) - (buffer-read-only nil)) - (erase-buffer) - (setcdr (assoc (car wl-folder-entity) wl-folder-group-alist) t) - (save-excursion - (wl-folder-insert-entity " " wl-folder-entity))) - (set-buffer-modified-p nil) - (sit-for 0) - (setq initialize t)) - (if (not arg) - (progn - (run-hooks 'wl-auto-check-folder-pre-hook) - (cond - ((eq wl-auto-check-folder-name 'none)) - ((or (consp wl-auto-check-folder-name) - (stringp wl-auto-check-folder-name)) - (let ((folder-list (if (consp wl-auto-check-folder-name) - wl-auto-check-folder-name - (list wl-auto-check-folder-name))) - entity) - (while folder-list - (if (setq entity (wl-folder-search-entity-by-name - (car folder-list) - wl-folder-entity)) - (wl-folder-check-entity entity 'auto)) - (setq folder-list (cdr folder-list))))) - (t - (wl-folder-check-entity wl-folder-entity 'auto))) - (run-hooks 'wl-auto-check-folder-hook))) - initialize)) + (let (initialize folder-buf) + (if (setq folder-buf (get-buffer wl-folder-buffer-name)) + (if wl-folder-use-frame + (let (select-frame) + (save-selected-window + (dolist (frame (visible-frame-list)) + (select-frame frame) + (if (get-buffer-window folder-buf) + (setq select-frame frame)))) + (if select-frame + (select-frame select-frame) + (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)) + (switch-to-buffer (get-buffer-create wl-folder-buffer-name))) + (set-buffer wl-folder-buffer-name) + (wl-folder-mode) + ;; Initialization. + (setq wl-folder-entity-id 0) + (wl-folder-entity-assign-id wl-folder-entity) + (setq wl-folder-entity-hashtb + (wl-folder-create-entity-hashtb wl-folder-entity)) + (setq wl-folder-elmo-folder-hashtb (elmo-make-hash wl-folder-entity-id)) + (setq wl-folder-group-alist + (wl-folder-create-group-alist wl-folder-entity)) + (setq wl-folder-newsgroups-hashtb + (wl-folder-create-newsgroups-hashtb wl-folder-entity)) + (wl-folder-init-info-hashtb) + (let ((inhibit-read-only t) + (buffer-read-only nil)) + (erase-buffer) + (setcdr (assoc (car wl-folder-entity) wl-folder-group-alist) t) + (save-excursion + (wl-folder-insert-entity " " wl-folder-entity))) + (sit-for 0) + (set-buffer-modified-p nil) + (setq initialize t)) + initialize)) + +(defun wl-folder-auto-check () + "Check and update folders in `wl-auto-check-folder-name'." + (interactive) + (when (get-buffer wl-folder-buffer-name) + (switch-to-buffer wl-folder-buffer-name) + (cond + ((eq wl-auto-check-folder-name 'none)) + ((or (consp wl-auto-check-folder-name) + (stringp wl-auto-check-folder-name)) + (let ((folder-list (if (consp wl-auto-check-folder-name) + wl-auto-check-folder-name + (list wl-auto-check-folder-name))) + entity) + (while folder-list + (if (setq entity (wl-folder-search-entity-by-name + (car folder-list) + wl-folder-entity)) + (wl-folder-check-entity entity 'auto)) + (setq folder-list (cdr folder-list))))) + (t + (wl-folder-check-entity wl-folder-entity 'auto))))) (defun wl-folder-set-folder-updated (name value) (save-excursion (let (buf) (if (setq buf (get-buffer wl-folder-buffer-name)) - (wl-folder-entity-hashtb-set + (wl-folder-entity-hashtb-set wl-folder-entity-hashtb name value buf)) -;; (elmo-folder-set-info-hashtb (elmo-string name) -;; nil -;; (nth 2 value) -;; (nth 0 value) -;; (nth 1 value)) (setq wl-folder-info-alist-modified t)))) (defun wl-folder-calc-finfo (entity) @@ -1513,7 +1558,7 @@ Entering Folder mode calls the value of `wl-folder-mode-hook'." (defun wl-folder-update-newest (indent entity) (let (ret-val new unread all) - (cond + (cond ((consp entity) (let ((inhibit-read-only t) (buffer-read-only nil) @@ -1525,11 +1570,12 @@ Entering Folder mode calls the value of `wl-folder-mode-hook'." (if as-opened (let (update-flist flist-unsub new-flist removed group-name-end) (when (and (eq (cadr entity) 'access) - (elmo-folder-plugged-p (car entity))) + (elmo-folder-plugged-p + (wl-folder-get-elmo-folder (car entity)))) (message "Fetching folder entries...") (when (setq new-flist - (elmo-list-folders - (elmo-string (car entity)) + (elmo-folder-list-subfolders + (wl-folder-get-elmo-folder (car entity)) (wl-string-member (car entity) wl-folder-hierarchy-access-folders))) @@ -1540,7 +1586,7 @@ Entering Folder mode calls the value of `wl-folder-mode-hook'." (setq flist-unsub (nth 2 update-flist)) (setq removed (nth 3 update-flist)) (elmo-msgdb-flist-save - (car entity) + (car entity) (list (wl-folder-make-save-access-list flist) (wl-folder-make-save-access-list flist-unsub))) @@ -1558,12 +1604,12 @@ Entering Folder mode calls the value of `wl-folder-mode-hook'." (wl-folder-create-newsgroups-hashtb entity nil) wl-folder-newsgroups-hashtb)))) - (message "Fetching folder entries...done.")) + (message "Fetching folder entries...done")) (wl-folder-insert-entity indent entity)))))))) (defun wl-folder-insert-entity (indent entity &optional onlygroup) (let (ret-val new unread all) - (cond + (cond ((consp entity) (let ((inhibit-read-only t) (buffer-read-only nil) @@ -1571,64 +1617,64 @@ Entering Folder mode calls the value of `wl-folder-mode-hook'." (as-opened (cdr (assoc (car entity) wl-folder-group-alist))) beg ) -; (insert indent "[" (if as-opened "-" "+") "]" (car entity) "\n") -; (save-excursion (forward-line -1) -; (wl-highlight-folder-current-line)) +;;; (insert indent "[" (if as-opened "-" "+") "]" (car entity) "\n") +;;; (save-excursion (forward-line -1) +;;; (wl-highlight-folder-current-line)) (setq beg (point)) (if (and as-opened (not onlygroup)) (let (update-flist flist-unsub new-flist removed group-name-end) -; (when (and (eq (cadr entity) 'access) -; newest) -; (message "fetching folder entries...") -; (when (setq new-flist -; (elmo-list-folders -; (elmo-string (car entity)) -; (wl-string-member -; (car entity) -; wl-folder-hierarchy-access-folders) -; )) -; (setq update-flist -; (wl-folder-update-access-group entity new-flist)) -; (setq flist (nth 1 update-flist)) -; (when (car update-flist) ;; diff -; (setq flist-unsub (nth 2 update-flist)) -; (setq removed (nth 3 update-flist)) -; (elmo-msgdb-flist-save -; (car entity) -; (list -; (wl-folder-make-save-access-list flist) -; (wl-folder-make-save-access-list flist-unsub))) -; ;; -; ;; reconstruct wl-folder-entity-id-name-hashtb and -; ;; wl-folder-entity-hashtb -; ;; -; (wl-folder-entity-assign-id -; entity -; wl-folder-entity-id-name-hashtb -; t) -; (setq wl-folder-entity-hashtb -; (wl-folder-create-entity-hashtb -; entity -; wl-folder-entity-hashtb -; t)) -; (setq wl-folder-newsgroups-hashtb -; (or -; (wl-folder-create-newsgroups-hashtb -; entity nil) -; wl-folder-newsgroups-hashtb)))) -; (message "fetching folder entries...done.")) - (insert indent "[" (if as-opened "-" "+") "]" +;;; (when (and (eq (cadr entity) 'access) +;;; newest) +;;; (message "fetching folder entries...") +;;; (when (setq new-flist +;;; (elmo-list-folders +;;; (elmo-string (car entity)) +;;; (wl-string-member +;;; (car entity) +;;; wl-folder-hierarchy-access-folders) +;;; )) +;;; (setq update-flist +;;; (wl-folder-update-access-group entity new-flist)) +;;; (setq flist (nth 1 update-flist)) +;;; (when (car update-flist) ;; diff +;;; (setq flist-unsub (nth 2 update-flist)) +;;; (setq removed (nth 3 update-flist)) +;;; (elmo-msgdb-flist-save +;;; (car entity) +;;; (list +;;; (wl-folder-make-save-access-list flist) +;;; (wl-folder-make-save-access-list flist-unsub))) +;;; ;; +;;; ;; reconstruct wl-folder-entity-id-name-hashtb and +;;; ;; wl-folder-entity-hashtb +;;; ;; +;;; (wl-folder-entity-assign-id +;;; entity +;;; wl-folder-entity-id-name-hashtb +;;; t) +;;; (setq wl-folder-entity-hashtb +;;; (wl-folder-create-entity-hashtb +;;; entity +;;; wl-folder-entity-hashtb +;;; t)) +;;; (setq wl-folder-newsgroups-hashtb +;;; (or +;;; (wl-folder-create-newsgroups-hashtb +;;; entity nil) +;;; wl-folder-newsgroups-hashtb)))) +;;; (message "fetching folder entries...done")) + (insert indent "[" (if as-opened "-" "+") "]" (wl-folder-get-petname (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 + (get-text-property 0 'wl-folder-entity-id (car entity))) (when removed (setq beg (point)) (while removed - (insert indent " " + (insert indent " " wl-folder-removed-mark (if (listp (car removed)) (concat "[+]" (caar removed)) @@ -1643,21 +1689,18 @@ Entering Folder mode calls the value of `wl-folder-mode-hook'." (i 0)) (while flist (setq ret-val - (wl-folder-insert-entity + (wl-folder-insert-entity (concat indent " ") (car flist))) (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 mes + (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))) - (when mes - (elmo-display-progress - 'wl-folder-insert-entity "Inserting group %s..." - 100 (car entity)))) + (setq flist (cdr flist)))) (save-excursion (goto-char group-name-end) (delete-region (point) (save-excursion (end-of-line) @@ -1667,15 +1710,15 @@ Entering Folder mode calls the value of `wl-folder-mode-hook'." (setq ret-val (list new unread all)) (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)) - (format ":%d/%d/%d" + (insert indent "[" (if as-opened "-" "+") "]" + (wl-folder-get-petname (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 + (get-text-property 0 'wl-folder-entity-id (car entity))) (save-excursion (forward-line -1) (wl-highlight-folder-current-line ret-val))))) @@ -1686,7 +1729,7 @@ Entering Folder mode calls the value of `wl-folder-mode-hook'." beg) (setq beg (point)) (insert indent (wl-folder-get-petname entity) - (format ":%s/%s/%s\n" + (format ":%s/%s/%s\n" (or (setq new (nth 0 nums)) "*") (or (setq unread (and (nth 0 nums)(nth 1 nums) (+ (nth 0 nums)(nth 1 nums)))) @@ -1705,7 +1748,7 @@ 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 (new-diff 0) (unread-diff 0) (all-diff 0) @@ -1713,7 +1756,7 @@ Entering Folder mode calls the value of `wl-folder-mode-hook'." entity-list) (setq cur-val (wl-folder-get-entity-info name entity-hashtb)) (setq new-diff (- (or (nth 0 value) 0) (or (nth 0 cur-val) 0))) - (setq unread-diff + (setq unread-diff (+ new-diff (- (or (nth 1 value) 0) (or (nth 1 cur-val) 0)))) (setq all-diff (- (or (nth 2 value) 0) (or (nth 2 cur-val) 0))) @@ -1722,30 +1765,29 @@ Entering Folder mode calls the value of `wl-folder-mode-hook'." (equal diffs '(0 0 0))) (wl-folder-set-entity-info name value entity-hashtb) (save-match-data - (save-excursion - (set-buffer buffer) - (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))) - (goto-char (point-min)) - (while (wl-folder-buffer-search-entity name) - (wl-folder-update-line value))))))) + (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))) + (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 +; (save-window-excursion (let ((buf (get-buffer wl-folder-buffer-name)) cur-unread (unread-diff 0) ;;(fld (elmo-string folder)) value newvalue entity-list) - ;; Update folder-info - ;;(elmo-folder-set-info-hashtb fld nil nil nil unread) +;;; 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))) @@ -1754,8 +1796,7 @@ Entering Folder mode calls the value of `wl-folder-mode-hook'." (when (and buf (not (eq unread-diff 0))) (save-match-data - (save-excursion - (set-buffer buf) + (with-current-buffer buf (save-excursion (setq entity-list (wl-folder-search-entity-list-by-name folder wl-folder-entity)) @@ -1766,12 +1807,12 @@ Entering Folder mode calls the value of `wl-folder-mode-hook'." (setq entity-list (cdr entity-list))) (goto-char (point-min)) (while (wl-folder-buffer-search-entity folder) - (wl-folder-update-line newvalue))))))))) + (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))) - (entities (list entity)) - entity-stack) + (let ((hashtb (or hashtb (elmo-make-hash wl-folder-entity-id))) + (entities (list entity)) + entity-stack) (while entities (setq entity (wl-pop entities)) (cond @@ -1790,47 +1831,31 @@ Entering Folder mode calls the value of `wl-folder-mode-hook'." hashtb)) ;; Unsync number is reserved. -;; (defun wl-folder-reconstruct-entity-hashtb (entity &optional hashtb id-name) -;; (let* ((hashtb (or hashtb (elmo-make-hash wl-folder-entity-id))) -;; (entities (list entity)) -;; entity-stack) -;; (while entities -;; (setq entity (wl-pop entities)) -;; (cond -;; ((consp entity) -;; (if id-name -;; (wl-folder-set-id-name (wl-folder-get-entity-id (car entity)) -;; (car entity))) -;; (and entities -;; (wl-push entities entity-stack)) -;; (setq entities (nth 2 entity)) -;; ) -;; ((stringp entity) -;; (wl-folder-set-entity-info entity -;; (wl-folder-get-entity-info entity) -;; hashtb) -;; (if id-name -;; (wl-folder-set-id-name (wl-folder-get-entity-id entity) -;; entity)))) -;; (unless entities -;; (setq entities (wl-pop entity-stack)))) -;; hashtb)) - -(defun wl-folder-create-newsgroups-from-nntp-access2 (entity) - (let ((flist (nth 2 entity)) - folders) - (and - (setq folders - (delq - nil - (mapcar - '(lambda (fld) - (if (consp fld) - (wl-folder-create-newsgroups-from-nntp-access2 fld) - (nth 1 (elmo-folder-get-spec fld)))) - flist))) - (elmo-nntp-make-groups-hashtb folders 1024)) - nil)) +;;(defun wl-folder-reconstruct-entity-hashtb (entity &optional hashtb id-name) +;; (let* ((hashtb (or hashtb (elmo-make-hash wl-folder-entity-id))) +;; (entities (list entity)) +;; entity-stack) +;; (while entities +;; (setq entity (wl-pop entities)) +;; (cond +;; ((consp entity) +;; (if id-name +;; (wl-folder-set-id-name (wl-folder-get-entity-id (car entity)) +;; (car entity))) +;; (and entities +;; (wl-push entities entity-stack)) +;; (setq entities (nth 2 entity)) +;; ) +;; ((stringp entity) +;; (wl-folder-set-entity-info entity +;; (wl-folder-get-entity-info entity) +;; hashtb) +;; (if id-name +;; (wl-folder-set-id-name (wl-folder-get-entity-id entity) +;; entity)))) +;; (unless entities +;; (setq entities (wl-pop entity-stack)))) +;; hashtb)) (defun wl-folder-create-newsgroups-from-nntp-access (entity) (let ((flist (nth 2 entity)) @@ -1841,42 +1866,49 @@ Entering Folder mode calls the value of `wl-folder-mode-hook'." ((consp (car flist)) (wl-folder-create-newsgroups-from-nntp-access (car flist))) (t - (list (nth 1 (elmo-folder-get-spec (car flist))))))) + (list + (elmo-nntp-folder-group-internal + (wl-folder-get-elmo-folder (car flist))))))) (setq flist (cdr flist))) folders)) (defun wl-folder-create-newsgroups-hashtb (entity &optional is-list info) + "Create NNTP group hashtable for ENTITY." (let ((entities (if is-list entity (list entity))) - entity-stack spec-list folders fld make-hashtb) + entity-stack folder-list newsgroups newsgroup make-hashtb) (and info (message "Creating newsgroups...")) (while entities (setq entity (wl-pop entities)) (cond ((consp entity) (if (eq (nth 1 entity) 'access) - (when (eq (elmo-folder-get-type (car entity)) 'nntp) - (wl-append folders + (when (eq (elmo-folder-type-internal + (elmo-make-folder (car entity))) 'nntp) + (wl-append newsgroups (wl-folder-create-newsgroups-from-nntp-access entity)) (setq make-hashtb t)) (and entities (wl-push entities entity-stack)) (setq entities (nth 2 entity)))) ((stringp entity) - (setq spec-list (elmo-folder-get-primitive-spec-list entity)) - (while spec-list - (when (and (eq (caar spec-list) 'nntp) - (setq fld (nth 1 (car spec-list)))) - (wl-append folders (list (elmo-string fld)))) - (setq spec-list (cdr spec-list))))) + (setq folder-list (elmo-folder-get-primitive-list + (elmo-make-folder entity))) + (while folder-list + (when (and (eq (elmo-folder-type-internal (car folder-list)) + 'nntp) + (setq newsgroup (elmo-nntp-folder-group-internal + (car folder-list)))) + (wl-append newsgroups (list (elmo-string newsgroup)))) + (setq folder-list (cdr folder-list))))) (unless entities (setq entities (wl-pop entity-stack)))) (and info (message "Creating newsgroups...done")) - (if (or folders make-hashtb) - (elmo-nntp-make-groups-hashtb folders)))) + (if (or newsgroups make-hashtb) + (elmo-setup-subscribed-newsgroups newsgroups)))) (defun wl-folder-get-path (entity target-id &optional string) - (let* ((entities (list entity)) - entity-stack result-path) + (let ((entities (list entity)) + entity-stack result-path) (reverse (catch 'done (while entities @@ -1905,8 +1937,9 @@ Entering Folder mode calls the value of `wl-folder-mode-hook'." (defun wl-folder-create-group-alist (entity) (if (consp entity) - (let ((flist (nth 2 entity)) cur-alist append-alist) - (setq cur-alist (list (cons (car entity) nil))) + (let ((flist (nth 2 entity)) + (cur-alist (list (cons (car entity) nil))) + append-alist) (while flist (if (consp (car flist)) (wl-append append-alist @@ -1920,9 +1953,9 @@ Entering Folder mode calls the value of `wl-folder-mode-hook'." (elmo-folder-info-make-hashtb info-alist wl-folder-entity-hashtb))) -;; (wl-folder-resume-entity-hashtb-by-finfo -;; wl-folder-entity-hashtb -;; info-alist))) +;;; (wl-folder-resume-entity-hashtb-by-finfo +;;; wl-folder-entity-hashtb +;;; info-alist))) (defun wl-folder-cleanup-variables () (setq wl-folder-entity nil @@ -1942,7 +1975,7 @@ Entering Folder mode calls the value of `wl-folder-mode-hook'." (add (not wl-reset-plugged-alist))) (while entity-list (elmo-folder-set-plugged - (elmo-string (car entity-list)) wl-plugged add) + (wl-folder-get-elmo-folder (car entity-list)) wl-plugged add) (setq entity-list (cdr entity-list))) ;; smtp posting server (when wl-smtp-posting-server @@ -1950,56 +1983,46 @@ Entering Folder mode calls the value of `wl-folder-mode-hook'." wl-smtp-posting-server ; server (or (and (boundp 'smtp-service) smtp-service) "smtp") ; port + wl-smtp-connection-type nil nil "smtp" add)) ;; nntp posting server (when wl-nntp-posting-server (elmo-set-plugged wl-plugged wl-nntp-posting-server - elmo-default-nntp-port + wl-nntp-posting-stream-type + wl-nntp-posting-port nil nil "nntp" add)) - (wl-plugged-init-icons) - ;; user setting (run-hooks 'wl-make-plugged-hook))) -(defvar wl-folder-init-func 'wl-local-folder-init) +(defvar wl-folder-init-function 'wl-local-folder-init) (defun wl-folder-init () + "Return top-level folder entity." (interactive) - (funcall wl-folder-init-func)) + (if wl-use-acap + (wl-acap-init) + (funcall wl-folder-init-function)) + (run-hooks 'wl-folder-init-hook)) (defun wl-local-folder-init () + "Initialize local folder." (message "Initializing folder...") - (save-excursion - (let* ((entity (wl-folder-create-folder-entity)) - (inhibit-read-only t)) - (setq wl-folder-entity entity) - (setq wl-folder-entity-id 0) - (wl-folder-entity-assign-id wl-folder-entity) - (setq wl-folder-entity-hashtb - (wl-folder-create-entity-hashtb entity)) - (setq wl-folder-group-alist - (wl-folder-create-group-alist entity)) - (setq wl-folder-newsgroups-hashtb - (wl-folder-create-newsgroups-hashtb wl-folder-entity)) - (wl-folder-init-info-hashtb) - (setq wl-folder-buffer-cur-entity-id nil - wl-folder-buffer-cur-path nil - wl-folder-buffer-cur-point nil))) - (message "Initializing folder...done.")) + (setq wl-folder-entity (wl-folder-create-folder-entity)) + (message "Initializing folder...done")) (defun wl-folder-get-realname (petname) - (or (car - (wl-string-rassoc + (or (car + (wl-string-rassoc petname wl-folder-petname-alist)) petname)) -(defun wl-folder-get-petname (folder) - (or (cdr - (wl-string-assoc - folder +(defun wl-folder-get-petname (name) + (or (cdr + (wl-string-assoc + name wl-folder-petname-alist)) - folder)) + name)) (defun wl-folder-get-entity-with-petname () (let ((alist wl-folder-petname-alist) @@ -2009,6 +2032,86 @@ Entering Folder mode calls the value of `wl-folder-mode-hook'." (setq alist (cdr alist))) hashtb)) +(defun wl-folder-get-newsgroups (folder) + "Return Newsgroups field value string for FOLDER newsgroup. +If FOLDER is multi, return comma separated string (cross post)." + (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. +Use `wl-subscribed-mailing-list' and `wl-refile-rule-alist'." + (let ((flist + (elmo-folder-get-primitive-list + (wl-folder-get-elmo-folder entity))) + fld mladdr to) + (while (setq fld (car flist)) + (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 (stringp to) + (list to nil nil) + nil))) + +(defun wl-folder-guess-mailing-list-by-refile-rule-subr (entity) + (unless (memq (elmo-folder-type entity) + '(localnews nntp)) + (let ((rules wl-refile-rule-alist) + tokey toalist) + (while rules + (if (or (and (stringp (car (car rules))) + (string-match "[Tt]o" (car (car rules)))) + (and (listp (car (car rules))) + (elmo-string-matched-member "to" (car (car rules)) + 'case-ignore))) + (setq toalist (append toalist (cdr (car rules))))) + (setq rules (cdr rules))) + (setq tokey (car (rassoc entity toalist))) +;;; (setq histkey (car (rassoc folder wl-refile-alist))) + ;; case-ignore search `wl-subscribed-mailing-list' + (if (stringp tokey) + (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. +Use `wl-subscribed-mailing-list'." + (let ((flist + (elmo-folder-get-primitive-list + (wl-folder-get-elmo-folder entity))) + fld mladdr to) + (while (setq fld (car flist)) + (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 (stringp to) + (list to nil nil) + nil))) + +(defun wl-folder-guess-mailing-list-by-folder-name-subr (entity) + (when (memq (elmo-folder-type entity) + '(localdir imap4 maildir)) + (let (key foldername) + ;; Get foldername and Remove folder type symbol. + (setq foldername (substring entity 1)) + (if (string-match "@" foldername) + (setq foldername (substring foldername 0 (match-beginning 0)))) + (when (string-match "[^\\./]+$" foldername) + (setq key (regexp-quote + (concat (substring foldername (match-beginning 0)) "@"))) + (elmo-string-matched-member + key wl-subscribed-mailing-list 'case-ignore))))) + (defun wl-folder-update-diff-line (diffs) (let ((inhibit-read-only t) (buffer-read-only nil) @@ -2019,24 +2122,24 @@ Entering Folder mode calls the value of `wl-folder-mode-hook'." (save-excursion (beginning-of-line) (setq id (get-text-property (point) 'wl-folder-entity-id)) - (when (looking-at "^[ ]*\\(.*\\):\\([0-9\\*-]*\\)/\\([0-9\\*-]*\\)/\\([0-9\\*]*\\)") - ;;(looking-at "^[ ]*\\([^\\[].+\\):\\([0-9\\*-]*/[0-9\\*-]*/[0-9\\*]*\\)") - (setq cur-new (string-to-int + (when (looking-at "^[ ]*\\(.*\\):\\([0-9\\*-]*\\)/\\([0-9\\*-]*\\)/\\([0-9\\*]*\\)") + ;;(looking-at "^[ ]*\\([^\\[].+\\):\\([0-9\\*-]*/[0-9\\*-]*/[0-9\\*]*\\)") + (setq cur-new (string-to-int (wl-match-buffer 2))) - (setq cur-unread (string-to-int + (setq cur-unread (string-to-int (wl-match-buffer 3))) - (setq cur-all (string-to-int + (setq cur-all (string-to-int (wl-match-buffer 4))) (delete-region (match-beginning 2) (match-end 4)) (goto-char (match-beginning 2)) - (insert (format "%s/%s/%s" + (insert (format "%s/%s/%s" (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) - (if wl-use-highlight-mouse-line + (if wl-use-highlight-mouse-line (put-text-property (match-beginning 2) (point) 'mouse-face 'highlight)) (wl-highlight-folder-group-line (list new-new new-unread new-all)) @@ -2050,13 +2153,13 @@ Entering Folder mode calls the value of `wl-folder-mode-hook'." (save-excursion (beginning-of-line) (setq id (get-text-property (point) 'wl-folder-entity-id)) - (if (looking-at "^[ ]*\\(.*\\):\\([0-9\\*-]*/[0-9\\*-]*/[0-9\\*]*\\)") - ;;(looking-at "^[ ]*\\([^\\[].+\\):\\([0-9\\*-]*/[0-9\\*-]*/[0-9\\*]*\\)") + (if (looking-at "^[ ]*\\(.*\\):\\([0-9\\*-]*/[0-9\\*-]*/[0-9\\*]*\\)") +;;; (looking-at "^[ ]*\\([^\\[].+\\):\\([0-9\\*-]*/[0-9\\*-]*/[0-9\\*]*\\)") (progn (delete-region (match-beginning 2) (match-end 2)) (goto-char (match-beginning 2)) - (insert (format "%s/%s/%s" + (insert (format "%s/%s/%s" (or (nth 0 nums) "*") (or (and (nth 0 nums)(nth 1 nums) (+ (nth 0 nums)(nth 1 nums))) @@ -2068,6 +2171,7 @@ Entering Folder mode calls the value of `wl-folder-mode-hook'." ;; update only colors (wl-highlight-folder-group-line nums) (wl-highlight-folder-current-line nums)) + (beginning-of-line) (set-buffer-modified-p nil)))))) (defun wl-folder-goto-folder (&optional arg) @@ -2077,9 +2181,9 @@ Entering Folder mode calls the value of `wl-folder-mode-hook'." (defun wl-folder-goto-folder-subr (&optional folder sticky) (beginning-of-line) (let (summary-buf fld-name entity id error-selecting) -;; (setq fld-name (wl-folder-get-entity-from-buffer)) -;; (if (or (null fld-name) -;; (assoc fld-name wl-folder-group-alist)) +;;; (setq fld-name (wl-folder-get-entity-from-buffer)) +;;; (if (or (null fld-name) +;;; (assoc fld-name wl-folder-group-alist)) (setq fld-name wl-default-folder) (setq fld-name (or folder (wl-summary-read-folder fld-name))) @@ -2090,29 +2194,24 @@ Entering Folder mode calls the value of `wl-folder-mode-hook'." (setq id (wl-folder-get-entity-id entity))) (wl-folder-set-current-entity-id id)) (setq summary-buf (wl-summary-get-buffer-create fld-name sticky)) - (if wl-stay-folder-window + (if (or wl-stay-folder-window wl-summary-use-frame) (wl-folder-select-buffer summary-buf) (if (and summary-buf (get-buffer-window summary-buf)) (delete-window))) - (wl-summary-goto-folder-subr fld-name - (wl-summary-get-sync-range fld-name) + (wl-summary-goto-folder-subr fld-name + (wl-summary-get-sync-range + (wl-folder-get-elmo-folder fld-name)) nil sticky t))) (defun wl-folder-suspend () (interactive) (run-hooks 'wl-folder-suspend-hook) (wl-folder-info-save) - (wl-crosspost-alist-save) - (wl-kill-buffers - (format "^\\(%s\\)$" - (mapconcat 'identity - (list (format "%s\\(:.*\\)?" - (default-value 'wl-message-buf-name)) - wl-original-buf-name) - "\\|"))) - (if (fboundp 'mmelmo-cleanup-entity-buffers) - (mmelmo-cleanup-entity-buffers)) + (elmo-crosspost-message-alist-save) + (elmo-quit) + ;(if (fboundp 'mmelmo-cleanup-entity-buffers) + ;(mmelmo-cleanup-entity-buffers)) (bury-buffer wl-folder-buffer-name) (delete-windows-on wl-folder-buffer-name t)) @@ -2129,14 +2228,16 @@ Entering Folder mode calls the value of `wl-folder-mode-hook'." (wl-push entities entity-stack)) (setq entities (nth 2 entity))) ((stringp entity) - (when (and (setq info (elmo-folder-get-info entity)) + (when (and (setq info (elmo-folder-get-info + (wl-folder-get-elmo-folder entity))) (not (equal info '(nil)))) - (wl-append info-alist (list (list (elmo-string entity) - (list (nth 3 info) ;; max - (nth 2 info) ;; length - (nth 0 info) ;; new - (nth 1 info)) ;; unread - )))))) + (if (listp info) + (wl-append info-alist (list (list (elmo-string entity) + (list (nth 3 info) ;; max + (nth 2 info) ;; length + (nth 0 info) ;; new + (nth 1 info)) ;; unread + ))))))) (unless entities (setq entities (wl-pop entity-stack)))) (elmo-msgdb-finfo-save info-alist) @@ -2283,7 +2384,7 @@ Entering Folder mode calls the value of `wl-folder-mode-hook'." (wl-folder-get-petname (if (stringp (car path)) (car path) - (wl-folder-get-folder-name-by-id + (wl-folder-get-folder-name-by-id (car path)))))) (beginning-of-line) (setq path (cdr path)) @@ -2335,10 +2436,10 @@ Entering Folder mode calls the value of `wl-folder-mode-hook'." (if refresh (let ((id (progn (wl-folder-prev-entity-skip-invalid t) - (wl-folder-get-entity-from-buffer t)))) - (mapcar '(lambda (x) - (setcdr x t)) - wl-folder-group-alist) + (wl-folder-get-entity-from-buffer t))) + (alist wl-folder-group-alist)) + (while alist + (setcdr (pop alist) t)) (erase-buffer) (wl-folder-insert-entity " " wl-folder-entity) (wl-folder-move-path id)) @@ -2362,13 +2463,16 @@ Entering Folder mode calls the value of `wl-folder-mode-hook'." (point)) (save-excursion (end-of-line) (+ 1 (point)))) - (setq i (1+ i)) - (and (zerop (% i 10)) - (elmo-display-progress - 'wl-folder-open-all "Opening all folders..." - (/ (* i 100) len)))))) - (elmo-display-progress - 'wl-folder-open-all "Opening all folders..." 100) + (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)))) + (message "Opening all folders...done") (set-buffer-modified-p nil))) (defun wl-folder-close-all () @@ -2390,7 +2494,7 @@ Entering Folder mode calls the value of `wl-folder-mode-hook'." (set-buffer-modified-p nil))) (defun wl-folder-open-close () - "open or close parent entity." + "Open or close parent entity." (interactive) (save-excursion (beginning-of-line) @@ -2455,11 +2559,12 @@ Entering Folder mode calls the value of `wl-folder-mode-hook'." (setq diff t))) (t (wl-append removes (list folder)))))) - (setq i (1+ i)) - (and (zerop (% i 10)) - (elmo-display-progress - 'wl-folder-update-access-group "Updating access group..." - (/ (* i 100) len))) + (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 @@ -2472,15 +2577,13 @@ Entering Folder mode calls the value of `wl-folder-mode-hook'." (when (member (car unsubscribes) new-flist) (setq new-flist (delete (car unsubscribes) new-flist)) (wl-append new-unsubscribes (list (car unsubscribes)))))) - (setq i (1+ i)) - (and (zerop (% i 10)) - (elmo-display-progress - 'wl-folder-update-access-group "Updating access group..." - (/ (* i 100) len))) + (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))) - (elmo-display-progress - 'wl-folder-update-access-group "Updating access group..." - 100) ;; (if (or new-flist removes) (setq diff t)) @@ -2522,55 +2625,65 @@ Entering Folder mode calls the value of `wl-folder-mode-hook'." (list diff new-flist new-unsubscribes removes))) (defun wl-folder-prefetch-entity (entity) - "Prefetch all new messages in the ENTITY" + "Prefetch all new messages in the ENTITY." (cond ((consp entity) (let ((flist (nth 2 entity)) (sum-done 0) - (sum-all 0) + (sum-all 0) result) (while flist (setq result (wl-folder-prefetch-entity (car flist))) (setq sum-done (+ sum-done (car result))) (setq sum-all (+ sum-all (cdr result))) (setq flist (cdr flist))) - (message "Prefetched %d/%d message(s) in \"%s\"." - sum-done sum-all + (message "Prefetched %d/%d message(s) in \"%s\"." + sum-done sum-all (wl-folder-get-petname (car entity))) (cons sum-done sum-all))) ((stringp entity) - (let ((nums (wl-folder-get-entity-info entity)) - (wl-summary-highlight (if (or (wl-summary-sticky-p entity) - (wl-summary-always-sticky-folder-p - entity)) - wl-summary-highlight)) - wl-summary-exit-next-move - wl-auto-select-first ret-val - count) + (let* ((folder (wl-folder-get-elmo-folder entity)) + (nums (wl-folder-get-entity-info entity)) + (wl-summary-highlight (if (or (wl-summary-sticky-p folder) + (wl-summary-always-sticky-folder-p + folder)) + wl-summary-highlight)) + wl-summary-exit-next-move + wl-auto-select-first ret-val + count) (setq count (or (car nums) 0)) - (setq count (+ count (wl-folder-count-incorporates entity))) - (if (< 0 count) + (setq count (+ count (wl-folder-count-incorporates folder))) + (if (or (null (car nums)) ; unknown + (< 0 count)) (save-window-excursion (save-excursion - (wl-summary-goto-folder-subr entity - (wl-summary-get-sync-range entity) - nil) - (setq ret-val (wl-summary-incorporate)) - (wl-summary-exit) - ret-val)) + (let ((wl-summary-buffer-name (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) + (setq ret-val (wl-summary-incorporate)) + (wl-summary-exit) + ret-val))) (cons 0 0)))))) (defun wl-folder-count-incorporates (folder) - (let ((sum 0)) - (mapcar '(lambda (x) - (if (member (cadr x) - wl-summary-incorporate-marks) - (incf sum))) - (elmo-msgdb-mark-load (elmo-msgdb-expand-path 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))) sum)) (defun wl-folder-prefetch-current-entity (&optional no-check) - "Prefetch all uncached messages in the folder at position. + "Prefetch all uncached messages in the folder at position. If current line is group folder, all subfolders are prefetched." (interactive "P") (save-excursion @@ -2588,51 +2701,58 @@ If current line is group folder, all subfolders are prefetched." (wl-folder-check-entity entity)) (wl-folder-prefetch-entity entity))))) -(defun wl-folder-drop-unsync-entity (entity) - "Drop all unsync messages in the ENTITY" - (cond - ((consp entity) - (let ((flist (nth 2 entity))) - (while flist - (wl-folder-drop-unsync-entity (car flist)) - (setq flist (cdr flist))))) - ((stringp entity) - (let ((nums (wl-folder-get-entity-info entity)) - wl-summary-highlight wl-auto-select-first new) - (setq new (or (car nums) 0)) - (if (< 0 new) - (save-window-excursion - (save-excursion - (wl-summary-goto-folder-subr entity 'no-sync nil) - (wl-summary-drop-unsync) - (wl-summary-exit)))))))) - -(defun wl-folder-drop-unsync-current-entity (&optional force-check) - "Drop all unsync messages in the folder at position. -If current line is group folder, all subfolders are dropped. -If optional arg exists, don't check any folders." - (interactive "P") - (save-excursion - (let ((entity-name (wl-folder-get-entity-from-buffer)) - (group (wl-folder-buffer-group-p)) - wl-folder-check-entity-hook - summary-buf entity) - (when (and entity-name - (y-or-n-p (format - "Drop all unsync messages in %s?" entity-name))) - (setq entity - (if group - (wl-folder-search-group-entity-by-name entity-name - wl-folder-entity) - entity-name)) - (if (null force-check) - (wl-folder-check-entity entity)) - (wl-folder-drop-unsync-entity entity) - (message "All unsync messages in %s are dropped!" entity-name))))) - -(defun wl-folder-write-current-newsgroup () +;(defun wl-folder-drop-unsync-entity (entity) +; "Drop all unsync messages in the ENTITY." +; (cond +; ((consp entity) +; (let ((flist (nth 2 entity))) +; (while flist +; (wl-folder-drop-unsync-entity (car flist)) +; (setq flist (cdr flist))))) +; ((stringp entity) +; (let ((nums (wl-folder-get-entity-info entity)) +; wl-summary-highlight wl-auto-select-first new) +; (setq new (or (car nums) 0)) +; (if (< 0 new) +; (save-window-excursion +; (save-excursion +; (let ((wl-summary-buffer-name (concat +; wl-summary-buffer-name +; (symbol-name this-command)))) +; (wl-summary-goto-folder-subr entity 'no-sync nil) +; (wl-summary-drop-unsync) +; (wl-summary-exit))))))))) + +;(defun wl-folder-drop-unsync-current-entity (&optional force-check) +; "Drop all unsync messages in the folder at position. +;If current line is group folder, all subfolders are dropped. +;If optional arg exists, don't check any folders." +; (interactive "P") +; (save-excursion +; (let ((entity-name (wl-folder-get-entity-from-buffer)) +; (group (wl-folder-buffer-group-p)) +; wl-folder-check-entity-hook +; summary-buf entity) +; (when (and entity-name +; (y-or-n-p (format +; "Drop all unsync messages in %s? " entity-name))) +; (setq entity +; (if group +; (wl-folder-search-group-entity-by-name entity-name +; wl-folder-entity) +; entity-name)) +; (if (null force-check) +; (wl-folder-check-entity entity)) +; (wl-folder-drop-unsync-entity entity) +; (message "All unsync messages in %s are dropped!" entity-name))))) + +(defun wl-folder-write-current-folder () + "Write message to current folder's newsgroup or mailing-list. +Call `wl-summary-write-current-folder' with current folder name." (interactive) - (wl-summary-write-current-newsgroup (wl-folder-entity-name))) + (unless (wl-folder-buffer-group-p) + (wl-summary-write-current-folder + (wl-folder-get-realname (wl-folder-entity-name))))) (defun wl-folder-mimic-kill-buffer () "Kill the current (Folder) buffer with query." @@ -2646,39 +2766,29 @@ If optional arg exists, don't check any folders." (wl-exit) (kill-buffer bufname)))) -(defun wl-folder-confirm-existence (fld &optional ignore-error) - (if (or (wl-folder-entity-exists-p fld) - (file-exists-p (elmo-msgdb-expand-path fld))) - () - (if ignore-error - (condition-case nil - (if (elmo-folder-exists-p fld) - () - (if (elmo-folder-creatable-p fld) - (if (y-or-n-p - (format "Folder %s does not exist, create it?" fld)) - (progn - (setq wl-folder-entity-hashtb - (wl-folder-create-entity-hashtb - fld - wl-folder-entity-hashtb)) - (elmo-create-folder fld))))) - (error)) - (if (elmo-folder-exists-p fld) - () - (if (not (elmo-folder-creatable-p fld)) - (error "Folder %s is not found" fld) - (if (y-or-n-p - (format "Folder %s does not exist, create it?" fld)) - (progn - (setq wl-folder-entity-hashtb - (wl-folder-create-entity-hashtb - fld - wl-folder-entity-hashtb)) - (unless (elmo-create-folder fld) - (error "Create folder failed"))) - (error "Folder is not created"))))))) - -(provide 'wl-folder) +(defun wl-folder-create-subr (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)))) + +(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)) + (elmo-folder-exists-p folder)) + (wl-folder-create-subr folder)))) + +(require 'product) +(product-provide (provide 'wl-folder) (require 'wl-version)) ;;; wl-folder.el ends here