1 ;;; wl-folder.el --- Folder mode for Wanderlust.
3 ;; Copyright (C) 1998,1999,2000 Yuuichi Teranishi <teranisi@gohome.org>
4 ;; Copyright (C) 1998,1999,2000 Masahiro MURATA <muse@ba2.so-net.ne.jp>
6 ;; Author: Yuuichi Teranishi <teranisi@gohome.org>
7 ;; Masahiro MURATA <muse@ba2.so-net.ne.jp>
8 ;; Keywords: mail, net news
10 ;; This file is part of Wanderlust (Yet Another Message Interface on Emacsen).
12 ;; This program is free software; you can redistribute it and/or modify
13 ;; it under the terms of the GNU General Public License as published by
14 ;; the Free Software Foundation; either version 2, or (at your option)
17 ;; This program is distributed in the hope that it will be useful,
18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
20 ;; GNU General Public License for more details.
22 ;; You should have received a copy of the GNU General Public License
23 ;; along with GNU Emacs; see the file COPYING. If not, write to the
24 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
25 ;; Boston, MA 02111-1307, USA.
39 (require 'easymenu) ; needed here.
49 (defcustom wl-folder-init-hook nil
50 "A hook called after folder initialization is finished."
54 (defvar wl-folder-buffer-name "Folder")
55 (defvar wl-folder-entity nil) ; desktop entity.
56 (defvar wl-folder-group-alist nil) ; opened or closed
57 (defvar wl-folder-entity-id nil) ; id
58 (defvar wl-folder-entity-hashtb nil)
59 (defvar wl-folder-entity-id-name-hashtb nil)
60 (defvar wl-folder-elmo-folder-hashtb nil) ; name => elmo folder structure
62 (defvar wl-folder-newsgroups-hashtb nil)
63 (defvar wl-folder-info-alist-modified nil)
65 (defvar wl-folder-mode-map nil)
67 (defvar wl-folder-buffer-disp-summary nil)
68 (defvar wl-folder-buffer-cur-entity-id nil)
69 (defvar wl-folder-buffer-cur-path nil)
70 (defvar wl-folder-buffer-cur-point nil)
72 (make-variable-buffer-local 'wl-folder-buffer-disp-summary)
73 (make-variable-buffer-local 'wl-folder-buffer-cur-entity-id)
74 (make-variable-buffer-local 'wl-folder-buffer-cur-path)
75 (make-variable-buffer-local 'wl-folder-buffer-cur-point)
77 (defconst wl-folder-entity-regexp "^\\([ ]*\\)\\(\\[[\\+-]\\]\\)?\\([^\\[].+\\):[-*0-9]+/[-*0-9]+/[-*0-9]+")
78 (defconst wl-folder-group-regexp "^\\([ ]*\\)\\[\\([\\+-]\\)\\]\\(.+\\):[-0-9-]+/[0-9-]+/[0-9-]+\n")
79 ;; 1:indent 2:opened 3:group-name
80 (defconst wl-folder-unsync-regexp ":[^0\\*][0-9]*/[0-9\\*-]+/[0-9\\*-]+$")
82 (defvar wl-folder-mode-menu-spec
84 ["Enter Current Folder" wl-folder-jump-to-current-entity t]
85 ["Prev Folder" wl-folder-prev-entity t]
86 ["Next Folder" wl-folder-next-entity t]
87 ["Check Current Folder" wl-folder-check-current-entity t]
88 ["Sync Current Folder" wl-folder-sync-current-entity t]
89 ; ["Drop Current Folder" wl-folder-drop-unsync-current-entity t]
90 ["Prefetch Current Folder" wl-folder-prefetch-current-entity t]
92 ["Mark as Read all Current Folder" wl-folder-mark-as-read-all-current-entity t]
93 ["Expire Current Folder" wl-folder-expire-current-entity t]
95 ["Go to Draft Folder" wl-folder-goto-draft-folder t]
96 ["Empty trash" wl-folder-empty-trash t]
97 ["Flush queue" wl-folder-flush-queue t]
99 ["Open All" wl-folder-open-all t]
100 ["Open All Unread folder" wl-folder-open-all-unread-folder t]
101 ["Close All" wl-folder-close-all t]
103 ["Add folder" wl-fldmgr-add t]
104 ["Add group" wl-fldmgr-make-group t]
105 ["Copy" wl-fldmgr-copy t]
106 ["Cut" wl-fldmgr-cut t]
107 ["Paste" wl-fldmgr-yank t]
108 ["Set petname" wl-fldmgr-set-petname t]
109 ["Rename" wl-fldmgr-rename t]
110 ["Save" wl-fldmgr-save-folders t]
112 ["Unsubscribe" wl-fldmgr-unsubscribe t]
113 ["Display all" wl-fldmgr-access-display-all t])
115 ["Write a message" wl-draft t]
116 ["Write for current folder" wl-folder-write-current-folder t]
118 ["Wanderlust NEWS" wl-news t]
120 ["Toggle Plug Status" wl-toggle-plugged t]
121 ["Change Plug Status" wl-plugged-change t]
123 ["Save Current Status" wl-save t]
124 ["Update Status" wl-status-update t]
129 (defun wl-folder-setup-mouse ()
130 (define-key wl-folder-mode-map 'button2 'wl-folder-click)
131 (define-key wl-folder-mode-map 'button4 'wl-folder-prev-entity)
132 (define-key wl-folder-mode-map 'button5 'wl-folder-next-entity)
133 (define-key wl-folder-mode-map [(shift button4)]
134 'wl-folder-prev-unread)
135 (define-key wl-folder-mode-map [(shift button5)]
136 'wl-folder-next-unread))
137 (defun wl-folder-setup-mouse ()
138 (define-key wl-folder-mode-map [mouse-2] 'wl-folder-click)
139 (define-key wl-folder-mode-map [mouse-4] 'wl-folder-prev-entity)
140 (define-key wl-folder-mode-map [mouse-5] 'wl-folder-next-entity)
141 (define-key wl-folder-mode-map [S-mouse-4] 'wl-folder-prev-unread)
142 (define-key wl-folder-mode-map [S-mouse-5] 'wl-folder-next-unread)))
144 (if wl-folder-mode-map
146 (setq wl-folder-mode-map (make-sparse-keymap))
147 (define-key wl-folder-mode-map " " 'wl-folder-jump-to-current-entity)
148 ; (define-key wl-folder-mode-map "\M- " 'wl-folder-open-close)
149 (define-key wl-folder-mode-map "/" 'wl-folder-open-close)
150 (define-key wl-folder-mode-map "\C-m" 'wl-folder-jump-to-current-entity)
151 (define-key wl-folder-mode-map [(shift return)] 'wl-folder-jump-to-current-entity-with-arg)
152 (define-key wl-folder-mode-map "\M-\C-m" 'wl-folder-update-recursive-current-entity)
153 (define-key wl-folder-mode-map "rc" 'wl-folder-mark-as-read-all-region)
154 (define-key wl-folder-mode-map "c" 'wl-folder-mark-as-read-all-current-entity)
155 (define-key wl-folder-mode-map "g" 'wl-folder-goto-folder)
156 (define-key wl-folder-mode-map "G" 'wl-folder-goto-folder-sticky)
157 (define-key wl-folder-mode-map "j" 'wl-folder-jump-to-current-entity)
158 (define-key wl-folder-mode-map "w" 'wl-draft)
159 (define-key wl-folder-mode-map "W" 'wl-folder-write-current-folder)
160 (define-key wl-folder-mode-map "\C-c\C-o" 'wl-jump-to-draft-buffer)
161 (define-key wl-folder-mode-map "\C-c\C-a" 'wl-addrmgr)
162 (define-key wl-folder-mode-map "\C-c\C-p" 'wl-folder-jump-to-previous-summary)
163 (define-key wl-folder-mode-map "\C-c\C-n" 'wl-folder-jump-to-next-summary)
164 (define-key wl-folder-mode-map "rS" 'wl-folder-sync-region)
165 (define-key wl-folder-mode-map "S" 'wl-folder-sync-current-entity)
166 (define-key wl-folder-mode-map "rs" 'wl-folder-check-region)
167 (define-key wl-folder-mode-map "s" 'wl-folder-check-current-entity)
168 (define-key wl-folder-mode-map "I" 'wl-folder-prefetch-current-entity)
169 ; (define-key wl-folder-mode-map "D" 'wl-folder-drop-unsync-current-entity)
170 (define-key wl-folder-mode-map "p" 'wl-folder-prev-entity)
171 (define-key wl-folder-mode-map "n" 'wl-folder-next-entity)
172 (define-key wl-folder-mode-map "v" 'wl-folder-toggle-disp-summary)
173 (define-key wl-folder-mode-map "P" 'wl-folder-prev-unread)
174 (define-key wl-folder-mode-map "N" 'wl-folder-next-unread)
175 (define-key wl-folder-mode-map "J" 'wl-folder-jump-folder)
176 (define-key wl-folder-mode-map "f" 'wl-folder-goto-first-unread-folder)
177 (define-key wl-folder-mode-map "o" 'wl-folder-open-all-unread-folder)
178 (define-key wl-folder-mode-map "[" 'wl-folder-open-all)
179 (define-key wl-folder-mode-map "]" 'wl-folder-close-all)
180 (define-key wl-folder-mode-map "e" 'wl-folder-expire-current-entity)
181 (define-key wl-folder-mode-map "E" 'wl-folder-empty-trash)
182 (define-key wl-folder-mode-map "F" 'wl-folder-flush-queue)
183 (define-key wl-folder-mode-map "V" 'wl-folder-virtual)
184 (define-key wl-folder-mode-map "?" 'wl-folder-pick)
185 (define-key wl-folder-mode-map "q" 'wl-exit)
186 (define-key wl-folder-mode-map "z" 'wl-folder-suspend)
187 (define-key wl-folder-mode-map "\M-t" 'wl-toggle-plugged)
188 (define-key wl-folder-mode-map "\C-t" 'wl-plugged-change)
189 (define-key wl-folder-mode-map "<" 'beginning-of-buffer)
190 (define-key wl-folder-mode-map ">" 'end-of-buffer)
192 (define-key wl-folder-mode-map "m" 'wl-fldmgr-mode-map)
193 (define-key wl-folder-mode-map "*" 'wl-fldmgr-make-multi)
194 (define-key wl-folder-mode-map "+" 'wl-fldmgr-make-group)
195 (define-key wl-folder-mode-map "|" 'wl-fldmgr-make-filter)
196 (define-key wl-folder-mode-map "\M-c" 'wl-fldmgr-copy)
197 (define-key wl-folder-mode-map "\M-w" 'wl-fldmgr-copy-region)
198 (define-key wl-folder-mode-map "\C-k" 'wl-fldmgr-cut)
199 (define-key wl-folder-mode-map "\C-w" 'wl-fldmgr-cut-region)
200 (define-key wl-folder-mode-map "\C-y" 'wl-fldmgr-yank)
201 (define-key wl-folder-mode-map "R" 'wl-fldmgr-rename)
202 (define-key wl-folder-mode-map "u" 'wl-fldmgr-unsubscribe)
203 (define-key wl-folder-mode-map "ru" 'wl-fldmgr-unsubscribe-region)
204 (define-key wl-folder-mode-map "U" 'wl-fldmgr-unsubscribe-region)
205 (define-key wl-folder-mode-map "l" 'wl-fldmgr-access-display-normal)
206 (define-key wl-folder-mode-map "L" 'wl-fldmgr-access-display-all)
207 (define-key wl-folder-mode-map "Z" 'wl-status-update)
208 (define-key wl-folder-mode-map "\C-x\C-s" 'wl-save)
209 (define-key wl-folder-mode-map "\M-s" 'wl-save)
210 (define-key wl-folder-mode-map "\C-xk" 'wl-folder-mimic-kill-buffer)
211 (define-key wl-folder-mode-map "\M-\C-a"
212 'wl-folder-goto-top-of-current-folder)
213 (define-key wl-folder-mode-map "\M-\C-e"
214 'wl-folder-goto-bottom-of-current-folder)
216 (wl-folder-setup-mouse)
220 "Menu used in Folder mode."
221 wl-folder-mode-menu-spec))
223 (defmacro wl-folder-unread-regex (group)
224 (` (concat "^[ ]*.+:[0-9\\*-]+/[^0\\*][0-9]*/[0-9\\*-]+$"
229 (defmacro wl-folder-buffer-group-p ()
230 (` (get-text-property (point) 'wl-folder-is-group)))
232 (defmacro wl-folder-folder-name ()
235 (if (or (looking-at "^[ ]*\\[[\\+-]\\]\\(.+\\):[-0-9\\*-]+/[0-9\\*-]+/[0-9\\*-]+\n")
236 (looking-at "^[ ]*\\([^\\[].+\\):.*\n"))
237 (wl-match-buffer 1)))))
239 (defmacro wl-folder-entity-name ()
242 (if (looking-at "^[ ]*\\([^\\[].+\\):.*\n")
243 (wl-match-buffer 1)))))
245 (defun wl-folder-buffer-search-group (group)
246 (let ((prev-point (point))
247 (group-regexp (concat
248 "^\\([ \t]*\\)\\[[\\+-]\\]"
249 (regexp-quote group) ":[-0-9-]+/[0-9-]+/[0-9-]+")))
251 (while (re-search-forward group-regexp nil t)
252 (if (wl-folder-buffer-group-p)
253 (throw 'found (point)))))
255 (goto-char prev-point)
258 (defun wl-folder-buffer-search-entity (folder &optional searchname)
259 (let ((search (or searchname (wl-folder-get-petname folder)))
264 (regexp-quote search) ":[-0-9\\*-]+/[0-9\\*-]+/[0-9\\*-]+") nil t)))
266 (defsubst wl-folder-get-folder-name-by-id (entity-id &optional hashtb)
267 (and (numberp entity-id)
268 (elmo-get-hash-val (format "#%d" entity-id)
269 (or hashtb wl-folder-entity-id-name-hashtb))))
271 (defsubst wl-folder-set-id-name (entity-id entity &optional hashtb)
272 (and (numberp entity-id)
273 (elmo-set-hash-val (format "#%d" entity-id)
274 entity (or hashtb wl-folder-entity-id-name-hashtb))))
276 (defmacro wl-folder-get-entity-id (entity)
277 `(get-text-property 0 'wl-folder-entity-id ,entity))
279 (defmacro wl-folder-get-entity-from-buffer (&optional getid)
280 `(let ((id (get-text-property (point)
281 'wl-folder-entity-id)))
284 (wl-folder-get-folder-name-by-id id))))
286 (defmacro wl-folder-entity-exists-p (entity &optional hashtb)
287 (` (let ((sym (intern-soft (, entity)
288 (or (, hashtb) wl-folder-entity-hashtb))))
289 (and sym (boundp sym)))))
291 (defmacro wl-folder-clear-entity-info (entity &optional hashtb)
292 (` (let ((sym (intern-soft (, entity)
293 (or (, hashtb) wl-folder-entity-hashtb))))
297 (defmacro wl-folder-get-entity-info (entity &optional hashtb)
298 (` (elmo-get-hash-val (, entity) (or (, hashtb) wl-folder-entity-hashtb))))
300 (defmacro wl-folder-set-entity-info (entity value &optional hashtb)
301 (` (let* ((hashtb (or (, hashtb) wl-folder-entity-hashtb))
302 (info (wl-folder-get-entity-info (, entity) hashtb)))
303 (elmo-set-hash-val (elmo-string (, entity))
304 (if (< (length (, value)) 4)
305 (append (, value) (list (nth 3 info)))
309 (defun wl-folder-persistent-p (folder)
310 (or (and (wl-folder-search-entity-by-name folder wl-folder-entity
314 (let ((li wl-save-folder-list))
316 (if (string-match (car li) folder)
318 (setq li (cdr li)))))
320 (let ((li wl-no-save-folder-list))
322 (if (string-match (car li) folder)
324 (setq li (cdr li))))))))
326 ;;; ELMO folder structure with cache.
327 (defmacro wl-folder-elmo-folder-cache-get (name &optional hashtb)
328 "Returns a elmo folder structure associated with NAME from HASHTB.
329 Default HASHTB is `wl-folder-elmo-folder-hashtb'."
330 (` (elmo-get-hash-val (, name)
331 (or (, hashtb) wl-folder-elmo-folder-hashtb))))
333 (defmacro wl-folder-elmo-folder-cache-put (name folder &optional hashtb)
334 "Get folder elmo folder structure on HASHTB for folder with NAME.
335 Default HASHTB is `wl-folder-elmo-folder-hashtb'."
336 (` (elmo-set-hash-val (, name) (, folder)
337 (or (, hashtb) wl-folder-elmo-folder-hashtb))))
339 (defmacro wl-folder-get-elmo-folder (entity &optional no-cache)
340 "Get elmo folder structure from ENTITY."
342 (elmo-make-folder (elmo-string (, entity)))
343 (or (wl-folder-elmo-folder-cache-get (, entity))
344 (let* ((name (elmo-string (, entity)))
345 (folder (elmo-make-folder name)))
346 (wl-folder-elmo-folder-cache-put name folder)
349 (defsubst wl-folder-put-folder-property (beg end id is-group &optional object)
350 (put-text-property beg end 'wl-folder-entity-id id object)
351 (put-text-property beg end 'wl-folder-is-group is-group object))
353 (defun wl-folder-prev-entity ()
357 (defun wl-folder-next-entity ()
361 (defun wl-folder-prev-entity-skip-invalid (&optional hereto)
362 "Move to previous entity. skip unsubscribed or removed entity."
366 (if (re-search-backward wl-folder-entity-regexp nil t)
368 (goto-char (point-min))))
370 (defun wl-folder-next-entity-skip-invalid (&optional hereto)
371 "Move to next entity. skip unsubscribed or removed entity."
376 (if (re-search-forward wl-folder-entity-regexp nil t)
378 (goto-char (point-max))))
380 (defun wl-folder-search-group-entity-by-name (name entity)
381 (wl-folder-search-entity-by-name name entity 'group))
383 (defun wl-folder-search-entity-by-name (name entity &optional type)
384 (let ((entities (list entity))
388 (setq entity (wl-pop entities))
391 (if (and (not (eq type 'folder))
392 (string= name (car entity)))
393 (throw 'done entity))
395 (wl-push entities entity-stack))
396 (setq entities (nth 2 entity)))
397 ((and (not (eq type 'group))
399 (if (string= name entity)
400 (throw 'done entity))))
402 (setq entities (wl-pop entity-stack)))))))
404 (defun wl-folder-search-entity-list-by-name (name entity &optional get-id)
405 (let ((entities (list entity))
406 entity-stack ret-val)
408 (setq entity (wl-pop entities))
412 (wl-push entities entity-stack))
413 (setq entities (nth 2 entity)))
415 (if (string= name entity)
416 (wl-append ret-val (if get-id
417 (list (wl-folder-get-entity-id entity))
420 (setq entities (wl-pop entity-stack))))
423 (defun wl-folder-get-prev-folder (id &optional unread)
424 (let ((name (if (stringp id)
426 (wl-folder-get-folder-name-by-id id)))
427 entity entity-stack last-entity finfo
428 (entities (list wl-folder-entity)))
431 (setq entity (wl-pop entities))
434 ;; (if (and (string= name (car entity))
435 ;; (eq id (wl-folder-get-entity-id (car entity))))
436 ;; (throw 'done last-entity))
438 (wl-push entities entity-stack))
439 (setq entities (nth 2 entity)))
441 (if (and (string= name entity)
442 (eq id (wl-folder-get-entity-id entity)))
443 (throw 'done last-entity))
445 (and (setq finfo (wl-folder-get-entity-info entity))
446 (and (nth 0 finfo)(nth 1 finfo))
447 (> (+ (nth 0 finfo)(nth 1 finfo)) 0)))
448 (setq last-entity entity))))
450 (setq entities (wl-pop entity-stack)))))))
452 (defun wl-folder-get-next-folder (id &optional unread)
453 (let ((name (if (stringp id)
455 (wl-folder-get-folder-name-by-id id)))
456 entity entity-stack found finfo
457 (entities (list wl-folder-entity)))
460 (setq entity (wl-pop entities))
463 ;;; (if (and (string= name (car entity))
464 ;;; (eq id (wl-folder-get-entity-id (car entity))))
467 (wl-push entities entity-stack))
468 (setq entities (nth 2 entity)))
471 (when (or (not unread)
472 (and (setq finfo (wl-folder-get-entity-info entity))
473 (and (nth 0 finfo)(nth 1 finfo))
474 (> (+ (nth 0 finfo)(nth 1 finfo)) 0)))
475 (throw 'done entity))
476 (if (and (string= name entity)
477 (eq id (wl-folder-get-entity-id entity)))
480 (setq entities (wl-pop entity-stack)))))))
482 (defun wl-folder-flush-queue ()
485 (let ((cur-buf (current-buffer))
486 (wl-auto-select-first nil)
489 (if elmo-enable-disconnected-operation
490 (elmo-dop-queue-flush))
491 (if (not (elmo-folder-list-messages
492 (wl-folder-get-elmo-folder wl-queue-folder)))
493 (message "No sending queue exists.")
494 (if wl-stay-folder-window
495 (wl-folder-select-buffer
496 (wl-summary-get-buffer-create wl-queue-folder)))
497 (wl-summary-goto-folder-subr wl-queue-folder 'force-update nil)
499 (wl-draft-queue-flush)
500 (if (get-buffer-window cur-buf)
501 (select-window (get-buffer-window cur-buf)))
503 (if wl-stay-folder-window
504 (wl-folder-toggle-disp-summary 'off wl-queue-folder)
505 (switch-to-buffer cur-buf))))))
507 (defun wl-folder-empty-trash ()
510 (let ((cur-buf (current-buffer))
511 (wl-auto-select-first nil)
513 (wl-summary-goto-folder-subr wl-trash-folder 'force-update)
514 (setq trash-buf (wl-summary-get-buffer-create wl-trash-folder))
515 (if wl-stay-folder-window
516 (wl-folder-select-buffer trash-buf)
517 (switch-to-buffer trash-buf))
519 (setq emptied (wl-summary-delete-all-msgs))
521 (setq wl-thread-entities nil
522 wl-thread-entity-list nil)
523 (if wl-summary-cache-use (wl-summary-save-view-cache))
524 (elmo-folder-commit wl-summary-buffer-elmo-folder))
525 (if (get-buffer-window cur-buf)
526 (select-window (get-buffer-window cur-buf)))
529 (wl-folder-set-folder-updated wl-trash-folder '(0 0 0)))
530 (if wl-stay-folder-window
531 (wl-folder-toggle-disp-summary 'off wl-trash-folder)
532 (switch-to-buffer cur-buf))
534 (kill-buffer trash-buf)))))
536 (defun wl-folder-goto-top-of-current-folder (&optional arg)
537 "Move backward to the top of the current folder group.
538 Optional argument ARG is repeart count."
540 (if (re-search-backward
541 "^ *\\[[\\+-]\\]" nil t (if arg (prefix-numeric-value arg)))
543 (goto-char (point-min))))
545 (defun wl-folder-goto-bottom-of-current-folder (indent)
546 "Move forward to the bottom of the current folder group."
551 (if (looking-at "^ *")
552 (buffer-substring (match-beginning 0)(1- (match-end 0)))
556 (while (re-search-forward "^ *" nil t)
557 (if (<= (length (match-string 0))
561 (goto-char (point-max))))
563 (defsubst wl-folder-update-group (entity diffs &optional is-group)
565 (let ((path (wl-folder-get-path
567 (wl-folder-get-entity-id entity)
570 ;; delete itself from path
571 (setq path (delete (nth (- (length path) 1) path) path)))
572 (goto-char (point-min))
575 ;; goto the path line.
576 (if (or (eq (car path) 0) ; update desktop
577 (wl-folder-buffer-search-group
578 (wl-folder-get-petname
579 (if (stringp (car path))
581 (wl-folder-get-folder-name-by-id
584 (wl-folder-update-diff-line diffs)
586 (setq path (cdr path)))))))
588 (defun wl-folder-maybe-load-folder-list (entity)
589 (when (null (caddr entity))
591 (elmo-msgdb-flist-load (car entity)))
595 (wl-folder-entity-assign-id entity
596 wl-folder-entity-id-name-hashtb
598 (setq diffs (wl-fldmgr-add-entity-hashtb (list entity)))
599 (unless (equal diffs '(0 0 0))
600 (wl-folder-update-group (car entity) diffs t)))))))
602 (defsubst wl-folder-force-fetch-p (entity)
604 ((consp wl-force-fetch-folders)
605 (wl-string-match-member entity wl-force-fetch-folders))
607 wl-force-fetch-folders)))
609 (defun wl-folder-jump-to-current-entity-with-arg ()
611 (wl-folder-jump-to-current-entity t))
613 (defun wl-folder-jump-to-current-entity (&optional arg)
614 "Enter the current folder. If optional ARG exists, update folder list."
617 (let (entity beg end indent opened fname err fld-name)
619 ((and (wl-folder-buffer-group-p)
620 (looking-at wl-folder-group-regexp))
622 (setq fname (wl-folder-get-realname (wl-match-buffer 3)))
623 (setq indent (wl-match-buffer 1))
624 (setq opened (wl-match-buffer 2))
625 (if (string= opened "+")
627 (setq entity (wl-folder-search-group-entity-by-name
632 (wl-folder-update-recursive-current-entity entity)
634 (setcdr (assoc (car entity) wl-folder-group-alist) t)
635 (if (eq 'access (cadr entity))
636 (wl-folder-maybe-load-folder-list entity))
637 ;(condition-case errobj
639 (if (or (wl-folder-force-fetch-p (car entity))
641 (eq 'access (cadr entity))
642 (null (caddr entity))))
643 (wl-folder-update-newest indent entity)
644 (wl-folder-insert-entity indent entity))
645 (wl-highlight-folder-path wl-folder-buffer-cur-path))
648 ; (setcdr (assoc fname wl-folder-group-alist) nil))
650 ; (elmo-display-error errobj t)
653 ; (setcdr (assoc fname wl-folder-group-alist) nil)))
655 (let ((buffer-read-only nil))
656 (delete-region (save-excursion (beginning-of-line)
658 (save-excursion (end-of-line)
664 (progn (wl-folder-goto-bottom-of-current-folder indent)
667 (setq entity (wl-folder-search-group-entity-by-name
670 (let ((buffer-read-only nil))
671 (delete-region beg end))
672 (setcdr (assoc (car entity) wl-folder-group-alist) nil)
673 (wl-folder-insert-entity indent entity) ; insert entity
675 (wl-highlight-folder-path wl-folder-buffer-cur-path)
676 ; (wl-delete-all-overlays)
677 ; (wl-highlight-folder-current-line)
679 ((setq fld-name (wl-folder-entity-name))
680 (wl-folder-set-current-entity-id
681 (get-text-property (point) 'wl-folder-entity-id))
682 (setq fld-name (wl-folder-get-folder-name-by-id
683 wl-folder-buffer-cur-entity-id))
684 (let ((summary-buf (wl-summary-get-buffer-create fld-name arg))
686 (if (or wl-stay-folder-window wl-summary-use-frame)
687 (wl-folder-select-buffer summary-buf)
689 (get-buffer-window summary-buf))
691 (wl-summary-goto-folder-subr fld-name
692 (wl-summary-get-sync-range
693 (wl-folder-get-elmo-folder fld-name))
695 (set-buffer-modified-p nil))
697 (defun wl-folder-close-entity (entity)
698 (let ((entities (list entity))
701 (setq entity (wl-pop entities))
704 (setcdr (assoc (car entity) wl-folder-group-alist) nil)
706 (wl-push entities entity-stack))
707 (setq entities (nth 2 entity))))
709 (setq entities (wl-pop entity-stack))))))
711 (defun wl-folder-update-recursive-current-entity (&optional entity)
714 (when (and (wl-folder-buffer-group-p)
715 (looking-at wl-folder-group-regexp))
717 ((string= (wl-match-buffer 2) "+")
721 (wl-folder-search-group-entity-by-name
722 (wl-folder-get-realname (wl-match-buffer 3))
724 (let ((inhibit-read-only t)
725 (entities (list entity))
726 entity-stack err indent)
727 (while (and entities (not err))
728 (setq entity (wl-pop entities))
731 (wl-folder-close-entity entity)
732 (setcdr (assoc (car entity) wl-folder-group-alist) t)
733 (unless (wl-folder-buffer-search-group
734 (wl-folder-get-petname (car entity)))
735 (error "%s: not found group" (car entity)))
736 (setq indent (wl-match-buffer 1))
737 (if (eq 'access (cadr entity))
738 (wl-folder-maybe-load-folder-list entity))
742 (condition-case errobj
743 (wl-folder-update-newest indent entity)
746 (setcdr (assoc (car entity) wl-folder-group-alist) nil))
748 (elmo-display-error errobj t)
751 (setcdr (assoc (car entity) wl-folder-group-alist) nil)))
753 (delete-region (save-excursion (beginning-of-line)
755 (save-excursion (end-of-line)
759 (wl-push entities entity-stack))
760 (setq entities (nth 2 entity))))
762 (setq entities (wl-pop entity-stack)))))
763 (set-buffer-modified-p nil)))
765 (wl-folder-jump-to-current-entity)))))
767 (defun wl-folder-no-auto-check-folder-p (folder)
770 (let ((li wl-auto-check-folder-list))
772 (if (string-match (car li) folder)
774 (setq li (cdr li)))))
777 (let ((li wl-auto-uncheck-folder-list))
779 (if (string-match (car li) folder)
780 (throw 'found t)) ; no check!
781 (setq li (cdr li))))))))
783 (defsubst wl-folder-add-folder-info (pre-value value)
785 (+ (or (nth 0 pre-value) 0) (or (nth 0 value) 0))
786 (+ (or (nth 1 pre-value) 0) (or (nth 1 value) 0))
787 (+ (or (nth 2 pre-value) 0) (or (nth 2 value) 0))))
789 (defun wl-folder-check-entity (entity &optional auto)
790 "Check unsync message number."
791 (let ((start-pos (point))
793 (run-hooks 'wl-folder-check-entity-pre-hook)
794 (if (and (consp entity) ;; group entity
795 wl-folder-check-async) ;; very fast
796 (setq ret-val (wl-folder-check-entity-async entity auto))
800 (let ((flist (if auto
802 'wl-folder-no-auto-check-folder-p
805 (wl-folder-check-entity-pre-hook nil)
806 (wl-folder-check-entity-hook nil)
810 (wl-folder-add-folder-info
812 (wl-folder-check-entity (car flist))))
813 (setq flist (cdr flist)))
814 ;(wl-folder-buffer-search-entity (car entity))
815 ;(wl-folder-update-line ret-val)
818 (message "Checking \"%s\"" entity)
819 (setq ret-val (wl-folder-check-one-entity
821 (goto-char start-pos)
824 (message "Uncheck(unplugged) \"%s\"" entity)))))
826 (message "Checking \"%s\" is done."
827 (if (consp entity) (car entity) entity)))
828 (run-hooks 'wl-folder-check-entity-hook)
831 (defun wl-folder-check-one-entity (entity &optional biff)
832 (let* ((folder (wl-folder-get-elmo-folder entity biff))
833 (nums (condition-case err
835 (if biff (elmo-folder-set-biff-internal folder t))
836 (if (wl-string-match-member entity wl-strict-diff-folders)
837 (elmo-strict-folder-diff folder)
838 (elmo-folder-diff folder)))
840 ;; maybe not exist folder.
841 (if (and (not (memq 'elmo-open-error
842 (get (car err) 'error-conditions)))
843 (not (elmo-folder-exists-p folder)))
844 (wl-folder-create-subr folder)
845 (signal (car err) (cdr err))))))
846 (new (elmo-diff-new nums))
847 (unread (elmo-diff-unread nums))
848 (all (elmo-diff-all nums))
850 (if (and (eq wl-folder-notify-deleted 'sync)
851 (or (and new (> 0 new))
852 (and unread (> 0 unread))
853 (and all (> 0 all))))
855 (wl-folder-sync-entity entity)
856 (setq nums (elmo-folder-diff folder)
857 new (elmo-diff-new nums)
858 unread (elmo-diff-unread nums)
859 all (elmo-diff-all nums)))
860 (unless wl-folder-notify-deleted
861 (setq new (and new (max 0 new))
862 unread (and unread (max 0 unread))
863 all (and all (max 0 all))))
864 (setq unread (or (and unread (- unread (or new 0)))
865 (elmo-folder-get-info-unread folder)
866 (cdr (wl-summary-count-unread))))
867 (wl-folder-entity-hashtb-set wl-folder-entity-hashtb entity
868 (list new unread all)
869 (get-buffer wl-folder-buffer-name)))
870 (setq wl-folder-info-alist-modified t)
872 (list new unread all)))
874 (defun wl-folder-check-entity-async (entity &optional auto)
875 (let ((elmo-nntp-groups-async t)
878 'wl-folder-no-auto-check-folder-p
879 (wl-folder-get-entity-list entity))
880 (wl-folder-get-entity-list entity)))
881 (nntp-connection-keys nil)
882 name folder folder-list
888 (setq folder (wl-folder-get-elmo-folder (car elist)))
889 (if (not (elmo-folder-plugged-p folder))
890 (message "Uncheck \"%s\"" (car elist))
892 (elmo-folder-get-primitive-list folder))
893 (cond ((elmo-folder-contains-type folder 'nntp)
894 (wl-append async-folder-list (list folder))
896 (when (eq (elmo-folder-type-internal (car folder-list))
900 (elmo-net-folder-server-internal
902 (setq server (elmo-net-folder-server-internal
904 (message "Checking on \"%s\"" server))
905 (setq nntp-connection-keys
906 (elmo-nntp-get-folders-info-prepare
908 nntp-connection-keys)))
909 (setq folder-list (cdr folder-list))))
911 (wl-append sync-folder-list (list folder)))))
912 (setq elist (cdr elist)))
913 ;; check local entity at first
914 (while (setq folder (pop sync-folder-list))
915 (if (not (elmo-folder-plugged-p folder))
916 (message "Uncheck \"%s\"" (elmo-folder-name-internal folder))
917 (message "Checking \"%s\"" (elmo-folder-name-internal folder))
919 (wl-folder-add-folder-info
921 (wl-folder-check-one-entity (elmo-folder-name-internal
925 ;; check network entity at last
926 (when async-folder-list
927 (elmo-nntp-get-folders-info nntp-connection-keys)
928 (while (setq folder (pop async-folder-list))
929 (if (not (elmo-folder-plugged-p folder))
930 (message "Uncheck \"%s\"" (elmo-folder-name-internal folder))
931 (message "Checking \"%s\"" (elmo-folder-name-internal folder))
933 (wl-folder-add-folder-info
935 (wl-folder-check-one-entity (elmo-folder-name-internal
942 (defun wl-folder-resume-entity-hashtb-by-finfo (entity-hashtb info-alist)
943 "Resume unread info for entity alist."
946 (setq info (nth 1 (car info-alist)))
947 (wl-folder-set-entity-info (caar info-alist)
948 (list (nth 2 info)(nth 3 info)(nth 1 info))
950 (setq info-alist (cdr info-alist)))))
952 (defun wl-folder-move-path (path)
953 (let ((fp (if (consp path)
956 (wl-folder-get-path wl-folder-entity path))))
957 (goto-char (point-min))
960 (when (equal (car fp)
961 (wl-folder-get-entity-from-buffer t))
963 (setq wl-folder-buffer-cur-point (point)))
965 (and wl-folder-buffer-cur-point
966 (goto-char wl-folder-buffer-cur-point))))
968 (defun wl-folder-set-current-entity-id (entity-id)
969 (let* ((buf (get-buffer wl-folder-buffer-name))
970 (buf-win (get-buffer-window buf)))
973 (save-selected-window
975 (select-window buf-win)
977 (setq wl-folder-buffer-cur-entity-id entity-id)
978 (setq wl-folder-buffer-cur-path
979 (wl-folder-get-path wl-folder-entity entity-id))
980 (wl-highlight-folder-path wl-folder-buffer-cur-path)
981 (and wl-folder-move-cur-folder
982 wl-folder-buffer-cur-point
983 (goto-char wl-folder-buffer-cur-point)))))))
985 (defun wl-folder-check-current-entity ()
986 "Check folder at position.
987 If current line is group folder, check all sub entries."
989 (let* ((entity-name (wl-folder-get-entity-from-buffer))
990 (group (wl-folder-buffer-group-p))
991 (desktop (string= entity-name wl-folder-desktop-name)))
993 (wl-folder-check-entity
995 (wl-folder-search-group-entity-by-name entity-name
1000 (defun wl-folder-sync-entity (entity &optional unread-only)
1001 "Synchronize the msgdb of ENTITY."
1004 (let ((flist (nth 2 entity)))
1006 (wl-folder-sync-entity (car flist) unread-only)
1007 (setq flist (cdr flist)))))
1009 (let* ((folder (wl-folder-get-elmo-folder entity))
1010 (nums (wl-folder-get-entity-info entity))
1011 (wl-summary-highlight (if (or (wl-summary-sticky-p folder)
1012 (wl-summary-always-sticky-folder-p
1014 wl-summary-highlight))
1015 wl-auto-select-first new unread sticky)
1016 (setq new (or (car nums) 0))
1017 (setq unread (or (cadr nums) 0))
1018 (if (or (not unread-only)
1019 (or (< 0 new) (< 0 unread)))
1020 (let ((wl-summary-buffer-name
1021 (if (setq sticky (get-buffer (wl-summary-sticky-buffer-name
1022 (elmo-folder-name-internal
1024 ;; Sticky folder exists.
1025 (wl-summary-sticky-buffer-name
1026 (elmo-folder-name-internal folder))
1028 wl-summary-buffer-name
1029 (symbol-name this-command))))
1030 (wl-summary-use-frame nil)
1031 (wl-summary-always-sticky-folder-list nil))
1032 (save-window-excursion
1034 (wl-summary-goto-folder-subr entity
1035 (wl-summary-get-sync-range
1039 (wl-summary-save-status)
1040 (wl-summary-exit))))))))))
1042 (defun wl-folder-sync-current-entity (&optional unread-only)
1043 "Synchronize the folder at position.
1044 If current line is group folder, check all subfolders."
1047 (let ((entity-name (wl-folder-get-entity-from-buffer))
1048 (group (wl-folder-buffer-group-p)))
1049 (when (and entity-name
1050 (y-or-n-p (format "Sync %s? " entity-name)))
1051 (wl-folder-sync-entity
1053 (wl-folder-search-group-entity-by-name entity-name
1057 (message "Syncing %s is done!" entity-name)))))
1059 (defun wl-folder-mark-as-read-all-entity (entity)
1060 "Mark as read all messages in the ENTITY."
1063 (let ((flist (nth 2 entity)))
1065 (wl-folder-mark-as-read-all-entity (car flist))
1066 (setq flist (cdr flist)))))
1068 (let* ((nums (wl-folder-get-entity-info entity))
1069 (folder (wl-folder-get-elmo-folder entity))
1070 (wl-summary-highlight (if (or (wl-summary-sticky-p folder)
1071 (wl-summary-always-sticky-folder-p
1073 wl-summary-highlight))
1074 wl-auto-select-first new unread sticky)
1075 (setq new (or (car nums) 0))
1076 (setq unread (or (cadr nums) 0))
1077 (if (or (< 0 new) (< 0 unread))
1078 (save-window-excursion
1080 (let ((wl-summary-buffer-name
1081 (if (setq sticky (get-buffer
1082 (wl-summary-sticky-buffer-name
1083 (elmo-folder-name-internal
1085 ;; Sticky folder exists.
1086 (wl-summary-sticky-buffer-name
1087 (elmo-folder-name-internal folder))
1089 wl-summary-buffer-name
1090 (symbol-name this-command))))
1091 (wl-summary-use-frame nil)
1092 (wl-summary-always-sticky-folder-list nil))
1093 (wl-summary-goto-folder-subr entity
1094 (wl-summary-get-sync-range folder)
1096 (wl-summary-mark-as-read-all)
1098 (wl-summary-save-status)
1099 (wl-summary-exit)))))
1102 (defun wl-folder-mark-as-read-all-current-entity ()
1103 "Mark as read all messages in the folder at position.
1104 If current line is group folder, all subfolders are marked."
1107 (let ((entity-name (wl-folder-get-entity-from-buffer))
1108 (group (wl-folder-buffer-group-p))
1110 (when (and entity-name
1111 (y-or-n-p (format "Mark all messages in %s as read? " entity-name)))
1112 (wl-folder-mark-as-read-all-entity
1114 (wl-folder-search-group-entity-by-name entity-name
1117 (message "All messages in %s are marked!" entity-name)))))
1119 (defun wl-folder-check-region (beg end)
1128 (let ((inhibit-read-only t)
1130 (while (< (point) end)
1131 ;; normal folder entity
1132 (if (looking-at "^[\t ]*\\([^\\[]+\\):\\(.*\\)\n")
1134 (setq entity (wl-folder-get-entity-from-buffer))
1135 (if (not (elmo-folder-plugged-p (wl-folder-get-elmo-folder
1137 (message "Uncheck %s" entity)
1138 (message "Checking %s" entity)
1139 (wl-folder-check-one-entity entity)
1144 (defun wl-folder-sync-region (beg end)
1153 (while (< (point) end)
1154 ;; normal folder entity
1155 (if (looking-at "^[\t ]*\\([^\\[]+\\):\\(.*\\)\n")
1157 (let ((inhibit-read-only t)
1159 (setq entity (wl-folder-get-entity-from-buffer))
1160 (wl-folder-sync-entity entity)
1161 (message "Syncing %s is done!" entity)
1166 (defun wl-folder-mark-as-read-all-region (beg end)
1175 (while (< (point) end)
1176 ;; normal folder entity
1177 (if (looking-at "^[\t ]*\\([^\\[]+\\):\\(.*\\)\n")
1179 (let ((inhibit-read-only t)
1181 (setq entity (wl-folder-get-entity-from-buffer))
1182 (wl-folder-mark-as-read-all-entity entity)
1183 (message "All messages in %s are marked!" entity)
1188 (defsubst wl-create-access-init-load-p (folder)
1189 (let ((no-load-regexp (when (and
1190 (not wl-folder-init-load-access-folders)
1191 wl-folder-init-no-load-access-folders)
1192 (mapconcat 'identity
1193 wl-folder-init-no-load-access-folders
1195 (load-regexp (and wl-folder-init-load-access-folders
1196 (mapconcat 'identity
1197 wl-folder-init-load-access-folders
1199 (cond (load-regexp (string-match load-regexp folder))
1200 (t (not (and no-load-regexp
1201 (string-match no-load-regexp folder)))))))
1203 (defun wl-create-access-folder-entity (name)
1205 (when (wl-create-access-init-load-p name)
1206 (setq flists (elmo-msgdb-flist-load name)) ; load flist.
1207 (setq flist (car flists))
1209 (when (consp (car flist))
1210 (setcdr (cdar flist)
1211 (wl-create-access-folder-entity (caar flist))))
1212 (setq flist (cdr flist)))
1215 (defun wl-create-folder-entity-from-buffer ()
1216 "Create folder entity recursively."
1218 ((looking-at "^[ \t]*$") ; blank line
1219 (goto-char (+ 1(match-end 0)))
1221 ((looking-at "^#.*$") ; comment
1222 (goto-char (+ 1 (match-end 0)))
1224 ((looking-at "^[\t ]*\\(.+\\)[\t ]*{[\t ]*$") ; group definition
1225 (let (name entity flist)
1226 (setq name (wl-match-buffer 1))
1227 (goto-char (+ 1 (match-end 0)))
1228 (while (setq entity (wl-create-folder-entity-from-buffer))
1229 (unless (eq entity 'ignore)
1230 (wl-append flist (list entity))))
1231 (if (looking-at "^[\t ]*}[\t ]*$") ; end of group
1233 (goto-char (+ 1 (match-end 0)))
1234 (if (wl-string-assoc name wl-folder-petname-alist)
1235 (error "%s already defined as petname" name))
1236 (list name 'group flist))
1237 (error "Syntax error in folder definition"))))
1238 ((looking-at "^[\t ]*\\([^\t \n]+\\)[\t ]*/$") ; access it!
1240 (setq name (wl-match-buffer 1))
1241 (goto-char (+ 1 (match-end 0)))
1242 ; (condition-case ()
1244 ; (setq flist (elmo-list-folders name)))
1245 ; (error (message "Access to folder %s failed." name)))
1246 ;; (setq flist (elmo-msgdb-flist-load name)) ; load flist.
1247 ;; (setq unsublist (nth 1 flist))
1248 ;; (setq flist (car flist))
1249 ;; (list name 'access flist unsublist)))
1250 (append (list name 'access) (wl-create-access-folder-entity name))))
1251 ;((looking-at "^[\t ]*\\([^\t \n}]+\\)[\t ]*\\(\"[^\"]*\"\\)?[\t ]*$") ; normal folder entity
1252 ((looking-at "^[\t ]*=[ \t]+\\([^\n]+\\)$"); petname definition
1253 (goto-char (+ 1 (match-end 0)))
1254 (let ((rest (elmo-match-buffer 1))
1256 (when (string-match "\\(\"[^\"]*\"\\)[\t ]*$" rest)
1257 (setq petname (elmo-delete-char ?\" (elmo-match-string 1 rest)))
1258 (setq rest (substring rest 0 (match-beginning 0))))
1259 (when (string-match "^[\t ]*\\(.*[^\t ]+\\)[\t ]+$" rest)
1260 (wl-folder-append-petname (elmo-match-string 1 rest)
1263 ((looking-at "^[ \t]*}[ \t]*$") ; end of group
1265 ((looking-at "^.*$") ; normal folder entity
1266 (goto-char (+ 1 (match-end 0)))
1267 (let ((rest (elmo-match-buffer 0))
1269 (if (string-match "\\(\"[^\"]*\"\\)[\t ]*$" rest)
1271 (setq petname (elmo-delete-char ?\" (elmo-match-string 1 rest)))
1272 (setq rest (substring rest 0 (match-beginning 0)))
1273 (when (string-match "^[\t ]*\\(.*[^\t ]+\\)[\t ]+$" rest)
1274 (wl-folder-append-petname
1275 (setq realname (elmo-match-string 1 rest))
1278 (if (string-match "^[\t ]*\\(.+\\)$" rest)
1279 (elmo-match-string 1 rest)
1282 (defun wl-folder-create-folder-entity ()
1283 "Create folder entries."
1284 (let ((tmp-buf (get-buffer-create " *wl-folder-tmp*"))
1288 (with-current-buffer tmp-buf
1290 (insert-file-contents wl-folders-file)
1291 (goto-char (point-min))
1292 (while (and (not (eobp))
1293 (setq entity (wl-create-folder-entity-from-buffer)))
1294 (unless (eq entity 'ignore)
1295 (wl-append ret-val (list entity)))))
1296 (kill-buffer tmp-buf))
1298 (setq ret-val (list wl-folder-desktop-name 'group ret-val))))
1300 (defun wl-folder-entity-assign-id (entity &optional hashtb on-noid)
1301 (let ((hashtb (or hashtb
1302 (setq wl-folder-entity-id-name-hashtb
1303 (elmo-make-hash wl-folder-entity-id))))
1304 (entities (list entity))
1307 (setq entity (wl-pop entities))
1310 (when (not (and on-noid
1311 (get-text-property 0
1312 'wl-folder-entity-id
1314 (wl-folder-put-folder-property
1315 0 (length (car entity))
1319 (wl-folder-set-id-name wl-folder-entity-id
1320 (car entity) hashtb))
1322 (wl-push entities entity-stack))
1323 (setq entities (nth 2 entity)))
1325 (when (not (and on-noid
1326 (get-text-property 0
1327 'wl-folder-entity-id
1329 (wl-folder-put-folder-property
1334 (wl-folder-set-id-name wl-folder-entity-id
1336 (setq wl-folder-entity-id (+ 1 wl-folder-entity-id))
1338 (setq entities (wl-pop entity-stack))))))
1340 (defun wl-folder-click (e)
1345 (wl-folder-jump-to-current-entity)))
1347 (defun wl-folder-select-buffer (buffer)
1348 (let ((gbw (get-buffer-window buffer))
1351 (progn (select-window gbw)
1353 (unless wl-summary-use-frame
1356 (split-window-horizontally wl-folder-window-width)
1360 (if wl-summary-use-frame
1361 (switch-to-buffer-other-frame buffer)
1362 (switch-to-buffer buffer))
1365 (defun wl-folder-toggle-disp-summary (&optional arg folder)
1367 (if (or (and folder (assoc folder wl-folder-group-alist))
1368 (and (interactive-p) (wl-folder-buffer-group-p)))
1369 (error "This command is not available on Group"))
1371 (let (wl-auto-select-first
1372 (wl-stay-folder-window t))
1375 (setq wl-folder-buffer-disp-summary t))
1377 (setq wl-folder-buffer-disp-summary nil)
1378 ;; hide wl-summary window.
1379 (let ((cur-buf (current-buffer))
1380 (summary-buffer (wl-summary-get-buffer folder)))
1381 (wl-folder-select-buffer summary-buffer)
1383 (select-window (get-buffer-window cur-buf))))
1385 (setq wl-folder-buffer-disp-summary
1386 (not wl-folder-buffer-disp-summary))
1387 (let ((cur-buf (current-buffer))
1389 (when (looking-at "^[ ]*\\([^\\[].+\\):.*\n")
1390 (setq folder-name (wl-folder-get-entity-from-buffer))
1391 (if wl-folder-buffer-disp-summary
1393 (wl-folder-select-buffer
1394 (wl-summary-get-buffer-create folder-name))
1396 (wl-summary-goto-folder-subr folder-name 'no-sync nil)
1397 (select-window (get-buffer-window cur-buf))))
1398 (wl-folder-select-buffer (wl-summary-get-buffer folder-name))
1400 (select-window (get-buffer-window cur-buf)))))))))
1402 (defun wl-folder-prev-unsync ()
1403 "Move cursor to the previous unsync folder."
1406 (setq start-point (point))
1408 (if (re-search-backward wl-folder-unsync-regexp nil t)
1410 (goto-char start-point)
1411 (message "No more unsync folder"))))
1413 (defun wl-folder-next-unsync (&optional plugged)
1414 "Move cursor to the next unsync."
1416 (let (start-point entity)
1417 (setq start-point (point))
1420 (while (re-search-forward wl-folder-unsync-regexp nil t)
1421 (if (or (wl-folder-buffer-group-p)
1424 (wl-folder-get-realname
1425 (wl-folder-folder-name)))
1426 (elmo-folder-plugged-p entity))
1429 (goto-char start-point)
1430 (message "No more unsync folder"))))
1432 (defun wl-folder-prev-unread (&optional group)
1433 "Move cursor to the previous unread folder."
1436 (setq start-point (point))
1438 (if (re-search-backward (wl-folder-unread-regex group) nil t)
1441 (wl-folder-folder-name))
1442 (goto-char start-point)
1443 (message "No more unread folder")
1446 (defun wl-folder-next-unread (&optional group)
1447 "Move cursor to the next unread folder."
1450 (setq start-point (point))
1452 (if (re-search-forward (wl-folder-unread-regex group) nil t)
1455 (wl-folder-folder-name))
1456 (goto-char start-point)
1457 (message "No more unread folder")
1460 (defun wl-folder-mode ()
1461 "Major mode for Wanderlust Folder.
1462 See Info under Wanderlust for full documentation.
1465 \\{wl-folder-mode-map}
1467 Entering Folder mode calls the value of `wl-folder-mode-hook'."
1469 (setq major-mode 'wl-folder-mode)
1470 (setq mode-name "Folder")
1471 (use-local-map wl-folder-mode-map)
1472 (setq buffer-read-only t)
1473 (setq inhibit-read-only nil)
1474 (setq truncate-lines t)
1475 (setq wl-folder-buffer-cur-entity-id nil
1476 wl-folder-buffer-cur-path nil
1477 wl-folder-buffer-cur-point nil)
1478 (wl-mode-line-buffer-identification)
1479 (easy-menu-add wl-folder-mode-menu)
1480 ;; This hook may contain the functions `wl-folder-init-icons' and
1481 ;; `wl-setup-folder' for reasons of system internal to accord
1482 ;; facilities for the Emacs variants.
1483 (run-hooks 'wl-folder-mode-hook))
1485 (defun wl-folder-append-petname (realname petname)
1487 ;; check group name.
1488 (if (wl-folder-search-group-entity-by-name petname wl-folder-entity)
1489 (error "%s already defined as group name" petname))
1490 (when (setq pentry (wl-string-assoc realname wl-folder-petname-alist))
1491 (setq wl-folder-petname-alist
1492 (delete pentry wl-folder-petname-alist)))
1493 (wl-append wl-folder-petname-alist
1494 (list (cons realname petname)))))
1496 (defun wl-folder (&optional arg)
1498 (let (initialize folder-buf)
1499 (if (setq folder-buf (get-buffer wl-folder-buffer-name))
1500 (if wl-folder-use-frame
1502 (save-selected-window
1503 (dolist (frame (visible-frame-list))
1504 (select-frame frame)
1505 (if (get-buffer-window folder-buf)
1506 (setq select-frame frame))))
1508 (select-frame select-frame)
1509 (switch-to-buffer folder-buf)))
1510 (switch-to-buffer folder-buf))
1511 (if wl-folder-use-frame
1513 (switch-to-buffer-other-frame
1514 (get-buffer-create wl-folder-buffer-name))
1515 (let ((frame (selected-frame)))
1516 (setq wl-delete-startup-frame-function
1518 (setq wl-delete-startup-frame-function nil)
1519 (let ((frame ,frame))
1520 (if (eq (selected-frame) frame)
1521 (delete-frame frame)))))))
1522 (switch-to-buffer (get-buffer-create wl-folder-buffer-name)))
1523 (set-buffer wl-folder-buffer-name)
1526 (setq wl-folder-entity-id 0)
1527 (wl-folder-entity-assign-id wl-folder-entity)
1528 (setq wl-folder-entity-hashtb
1529 (wl-folder-create-entity-hashtb wl-folder-entity))
1530 (setq wl-folder-elmo-folder-hashtb (elmo-make-hash wl-folder-entity-id))
1531 (setq wl-folder-group-alist
1532 (wl-folder-create-group-alist wl-folder-entity))
1533 (setq wl-folder-newsgroups-hashtb
1534 (wl-folder-create-newsgroups-hashtb wl-folder-entity))
1535 (wl-folder-init-info-hashtb)
1536 (let ((inhibit-read-only t)
1537 (buffer-read-only nil))
1539 (setcdr (assoc (car wl-folder-entity) wl-folder-group-alist) t)
1541 (wl-folder-insert-entity " " wl-folder-entity)))
1543 (set-buffer-modified-p nil)
1544 (setq initialize t))
1547 (defun wl-folder-auto-check ()
1548 "Check and update folders in `wl-auto-check-folder-name'."
1550 (when (get-buffer wl-folder-buffer-name)
1551 (switch-to-buffer wl-folder-buffer-name)
1553 ((eq wl-auto-check-folder-name 'none))
1554 ((or (consp wl-auto-check-folder-name)
1555 (stringp wl-auto-check-folder-name))
1556 (let ((folder-list (if (consp wl-auto-check-folder-name)
1557 wl-auto-check-folder-name
1558 (list wl-auto-check-folder-name)))
1561 (if (setq entity (wl-folder-search-entity-by-name
1564 (wl-folder-check-entity entity 'auto))
1565 (setq folder-list (cdr folder-list)))))
1567 (wl-folder-check-entity wl-folder-entity 'auto)))))
1569 (defun wl-folder-set-folder-updated (name value)
1572 (if (setq buf (get-buffer wl-folder-buffer-name))
1573 (wl-folder-entity-hashtb-set
1574 wl-folder-entity-hashtb name value buf))
1575 (setq wl-folder-info-alist-modified t))))
1577 (defun wl-folder-calc-finfo (entity)
1578 ;; calcurate finfo without inserting.
1579 (let ((entities (list entity))
1581 new unread all nums)
1583 (setq entity (wl-pop entities))
1587 (wl-push entities entity-stack))
1588 (setq entities (nth 2 entity)))
1590 (setq nums (wl-folder-get-entity-info entity))
1591 (setq new (+ (or new 0) (or (nth 0 nums) 0)))
1592 (setq unread (+ (or unread 0)
1593 (or (and (nth 0 nums)(nth 1 nums)
1594 (+ (nth 0 nums)(nth 1 nums))) 0)))
1595 (setq all (+ (or all 0) (or (nth 2 nums) 0)))))
1597 (setq entities (wl-pop entity-stack))))
1598 (list new unread all)))
1600 (defsubst wl-folder-make-save-access-list (list)
1601 (mapcar '(lambda (x)
1604 (list (elmo-string (car x)) 'access))
1609 (defun wl-folder-update-newest (indent entity)
1610 (let (ret-val new unread all)
1613 (let ((inhibit-read-only t)
1614 (buffer-read-only nil)
1615 (flist (nth 2 entity))
1616 (as-opened (cdr (assoc (car entity) wl-folder-group-alist)))
1621 (let (update-flist flist-unsub new-flist removed group-name-end)
1622 (when (and (eq (cadr entity) 'access)
1623 (elmo-folder-plugged-p
1624 (wl-folder-get-elmo-folder (car entity))))
1625 (message "Fetching folder entries...")
1626 (when (setq new-flist
1627 (elmo-folder-list-subfolders
1628 (wl-folder-get-elmo-folder (car entity))
1629 (wl-string-match-member
1631 wl-folder-hierarchy-access-folders)))
1633 (wl-folder-update-access-group entity new-flist))
1634 (setq flist (nth 1 update-flist))
1635 (when (car update-flist) ;; diff
1636 (setq flist-unsub (nth 2 update-flist))
1637 (setq removed (nth 3 update-flist))
1638 (elmo-msgdb-flist-save
1641 (wl-folder-make-save-access-list flist)
1642 (wl-folder-make-save-access-list flist-unsub)))
1643 (wl-folder-entity-assign-id
1645 wl-folder-entity-id-name-hashtb
1647 (setq wl-folder-entity-hashtb
1648 (wl-folder-create-entity-hashtb
1650 wl-folder-entity-hashtb
1652 (setq wl-folder-newsgroups-hashtb
1654 (wl-folder-create-newsgroups-hashtb
1656 wl-folder-newsgroups-hashtb))))
1657 (message "Fetching folder entries...done"))
1658 (wl-folder-insert-entity indent entity))))))))
1660 (defun wl-folder-insert-entity (indent entity &optional onlygroup)
1661 (let (ret-val new unread all)
1664 (let ((inhibit-read-only t)
1665 (buffer-read-only nil)
1666 (flist (nth 2 entity))
1667 (as-opened (cdr (assoc (car entity) wl-folder-group-alist)))
1670 ;;; (insert indent "[" (if as-opened "-" "+") "]" (car entity) "\n")
1671 ;;; (save-excursion (forward-line -1)
1672 ;;; (wl-highlight-folder-current-line))
1676 (let (update-flist flist-unsub new-flist removed group-name-end)
1677 ;;; (when (and (eq (cadr entity) 'access)
1679 ;;; (message "fetching folder entries...")
1680 ;;; (when (setq new-flist
1681 ;;; (elmo-list-folders
1682 ;;; (elmo-string (car entity))
1683 ;;; (wl-string-member
1685 ;;; wl-folder-hierarchy-access-folders)
1687 ;;; (setq update-flist
1688 ;;; (wl-folder-update-access-group entity new-flist))
1689 ;;; (setq flist (nth 1 update-flist))
1690 ;;; (when (car update-flist) ;; diff
1691 ;;; (setq flist-unsub (nth 2 update-flist))
1692 ;;; (setq removed (nth 3 update-flist))
1693 ;;; (elmo-msgdb-flist-save
1696 ;;; (wl-folder-make-save-access-list flist)
1697 ;;; (wl-folder-make-save-access-list flist-unsub)))
1699 ;;; ;; reconstruct wl-folder-entity-id-name-hashtb and
1700 ;;; ;; wl-folder-entity-hashtb
1702 ;;; (wl-folder-entity-assign-id
1704 ;;; wl-folder-entity-id-name-hashtb
1706 ;;; (setq wl-folder-entity-hashtb
1707 ;;; (wl-folder-create-entity-hashtb
1709 ;;; wl-folder-entity-hashtb
1711 ;;; (setq wl-folder-newsgroups-hashtb
1713 ;;; (wl-folder-create-newsgroups-hashtb
1715 ;;; wl-folder-newsgroups-hashtb))))
1716 ;;; (message "fetching folder entries...done"))
1717 (insert indent "[" (if as-opened "-" "+") "]"
1718 (wl-folder-get-petname (car entity)))
1719 (setq group-name-end (point))
1721 (wl-folder-put-folder-property
1723 (get-text-property 0 'wl-folder-entity-id (car entity))
1729 wl-folder-removed-mark
1730 (if (listp (car removed))
1731 (concat "[+]" (caar removed))
1734 (save-excursion (forward-line -1)
1735 (wl-highlight-folder-current-line))
1736 (setq removed (cdr removed)))
1737 (remove-text-properties beg (point) '(wl-folder-entity-id)))
1738 (let* ((len (length flist))
1743 (wl-folder-insert-entity
1744 (concat indent " ") (car flist)))
1745 (setq new (+ (or new 0) (or (nth 0 ret-val) 0)))
1746 (setq unread (+ (or unread 0) (or (nth 1 ret-val) 0)))
1747 (setq all (+ (or all 0) (or (nth 2 ret-val) 0)))
1749 (> len elmo-display-progress-threshold))
1751 (elmo-display-progress
1752 'wl-folder-insert-entity "Inserting group %s..."
1753 (/ (* i 100) len) (car entity)))
1754 (setq flist (cdr flist))))
1756 (goto-char group-name-end)
1757 (delete-region (point) (save-excursion (end-of-line)
1759 (insert (format ":%d/%d/%d" (or new 0)
1760 (or unread 0) (or all 0)))
1761 (setq ret-val (list new unread all))
1762 (wl-highlight-folder-current-line ret-val)))
1763 (setq ret-val (wl-folder-calc-finfo entity))
1764 (insert indent "[" (if as-opened "-" "+") "]"
1765 (wl-folder-get-petname (car entity))
1767 (or (nth 0 ret-val) 0)
1768 (or (nth 1 ret-val) 0)
1769 (or (nth 2 ret-val) 0))
1771 (wl-folder-put-folder-property
1773 (get-text-property 0 'wl-folder-entity-id (car entity))
1775 (save-excursion (forward-line -1)
1776 (wl-highlight-folder-current-line ret-val)))))
1778 (let* ((inhibit-read-only t)
1779 (buffer-read-only nil)
1780 (nums (wl-folder-get-entity-info entity))
1783 (insert indent (wl-folder-get-petname entity)
1784 (format ":%s/%s/%s\n"
1785 (or (setq new (nth 0 nums)) "*")
1786 (or (setq unread (and (nth 0 nums)(nth 1 nums)
1787 (+ (nth 0 nums)(nth 1 nums))))
1789 (or (setq all (nth 2 nums)) "*")))
1790 (wl-folder-put-folder-property
1792 (get-text-property 0 'wl-folder-entity-id entity)
1794 (save-excursion (forward-line -1)
1795 (wl-highlight-folder-current-line nums))
1796 (setq ret-val (list new unread all)))))
1797 (set-buffer-modified-p nil)
1800 (defun wl-folder-check-all ()
1802 (wl-folder-check-entity wl-folder-entity))
1804 (defun wl-folder-entity-hashtb-set (entity-hashtb name value buffer)
1811 (setq cur-val (wl-folder-get-entity-info name entity-hashtb))
1812 (setq new-diff (- (or (nth 0 value) 0) (or (nth 0 cur-val) 0)))
1815 (- (or (nth 1 value) 0) (or (nth 1 cur-val) 0))))
1816 (setq all-diff (- (or (nth 2 value) 0) (or (nth 2 cur-val) 0)))
1817 (setq diffs (list new-diff unread-diff all-diff))
1818 (unless (and (nth 0 cur-val)
1819 (equal diffs '(0 0 0)))
1820 (wl-folder-set-entity-info name value entity-hashtb)
1822 (with-current-buffer buffer
1824 (setq entity-list (wl-folder-search-entity-list-by-name
1825 name wl-folder-entity))
1827 (wl-folder-update-group (car entity-list) diffs)
1828 (setq entity-list (cdr entity-list)))
1829 (goto-char (point-min))
1830 (while (wl-folder-buffer-search-entity name)
1831 (wl-folder-update-line value))))))))
1833 (defun wl-folder-update-unread (folder unread)
1834 ; (save-window-excursion
1835 (let ((buf (get-buffer wl-folder-buffer-name))
1838 ;;(fld (elmo-string folder))
1839 value newvalue entity-list)
1840 ;;; Update folder-info
1841 ;;; (elmo-folder-set-info-hashtb fld nil nil nil unread)
1842 (setq cur-unread (or (nth 1 (wl-folder-get-entity-info folder)) 0))
1843 (setq unread-diff (- (or unread 0) cur-unread))
1844 (setq value (wl-folder-get-entity-info folder))
1845 (setq newvalue (list (nth 0 value)
1848 (wl-folder-set-entity-info folder newvalue)
1849 (setq wl-folder-info-alist-modified t)
1851 (not (eq unread-diff 0)))
1853 (with-current-buffer buf
1855 (setq entity-list (wl-folder-search-entity-list-by-name
1856 folder wl-folder-entity))
1858 (wl-folder-update-group (car entity-list) (list 0
1861 (setq entity-list (cdr entity-list)))
1862 (goto-char (point-min))
1863 (while (wl-folder-buffer-search-entity folder)
1864 (wl-folder-update-line newvalue))))))));)
1866 (defun wl-folder-create-entity-hashtb (entity &optional hashtb reconst)
1867 (let ((hashtb (or hashtb (elmo-make-hash wl-folder-entity-id)))
1868 (entities (list entity))
1871 (setq entity (wl-pop entities))
1875 (wl-push entities entity-stack))
1876 (setq entities (nth 2 entity)))
1878 (when (not (and reconst
1879 (wl-folder-get-entity-info entity)))
1880 (wl-folder-set-entity-info entity
1884 (setq entities (wl-pop entity-stack))))
1887 ;; Unsync number is reserved.
1888 ;;(defun wl-folder-reconstruct-entity-hashtb (entity &optional hashtb id-name)
1889 ;; (let* ((hashtb (or hashtb (elmo-make-hash wl-folder-entity-id)))
1890 ;; (entities (list entity))
1893 ;; (setq entity (wl-pop entities))
1897 ;; (wl-folder-set-id-name (wl-folder-get-entity-id (car entity))
1900 ;; (wl-push entities entity-stack))
1901 ;; (setq entities (nth 2 entity))
1903 ;; ((stringp entity)
1904 ;; (wl-folder-set-entity-info entity
1905 ;; (wl-folder-get-entity-info entity)
1908 ;; (wl-folder-set-id-name (wl-folder-get-entity-id entity)
1911 ;; (setq entities (wl-pop entity-stack))))
1914 (defun wl-folder-create-newsgroups-from-nntp-access (entity)
1915 (let ((flist (nth 2 entity))
1920 ((consp (car flist))
1921 (wl-folder-create-newsgroups-from-nntp-access (car flist)))
1924 (elmo-nntp-folder-group-internal
1925 (wl-folder-get-elmo-folder (car flist)))))))
1926 (setq flist (cdr flist)))
1929 (defun wl-folder-create-newsgroups-hashtb (entity &optional is-list info)
1930 "Create NNTP group hashtable for ENTITY."
1931 (let ((entities (if is-list entity (list entity)))
1932 entity-stack folder-list newsgroups newsgroup make-hashtb)
1933 (and info (message "Creating newsgroups..."))
1935 (setq entity (wl-pop entities))
1938 (if (eq (nth 1 entity) 'access)
1939 (when (eq (elmo-folder-type-internal
1940 (elmo-make-folder (car entity))) 'nntp)
1941 (wl-append newsgroups
1942 (wl-folder-create-newsgroups-from-nntp-access entity))
1943 (setq make-hashtb t))
1945 (wl-push entities entity-stack))
1946 (setq entities (nth 2 entity))))
1948 (setq folder-list (elmo-folder-get-primitive-list
1949 (elmo-make-folder entity)))
1951 (when (and (eq (elmo-folder-type-internal (car folder-list))
1953 (setq newsgroup (elmo-nntp-folder-group-internal
1954 (car folder-list))))
1955 (wl-append newsgroups (list (elmo-string newsgroup))))
1956 (setq folder-list (cdr folder-list)))))
1958 (setq entities (wl-pop entity-stack))))
1959 (and info (message "Creating newsgroups...done"))
1960 (if (or newsgroups make-hashtb)
1961 (elmo-setup-subscribed-newsgroups newsgroups))))
1963 (defun wl-folder-get-path (entity target-id &optional string)
1964 (let ((entities (list entity))
1965 entity-stack result-path)
1969 (setq entity (wl-pop entities))
1972 (if (and (or (not string) (string= string (car entity)))
1973 (eq target-id (wl-folder-get-entity-id (car entity))))
1975 (wl-push target-id result-path))
1976 (wl-push (wl-folder-get-entity-id (car entity)) result-path))
1977 (wl-push entities entity-stack)
1978 (setq entities (nth 2 entity)))
1980 (if (and (or (not string) (string= string entity))
1981 (eq target-id (wl-folder-get-entity-id entity)))
1983 (wl-push target-id result-path)))))
1985 (while (and entity-stack
1987 (setq result-path (cdr result-path))
1988 (setq entities (wl-pop entity-stack)))))))))
1990 (defun wl-folder-create-group-alist (entity)
1992 (let ((flist (nth 2 entity))
1993 (cur-alist (list (cons (car entity) nil)))
1996 (if (consp (car flist))
1997 (wl-append append-alist
1998 (wl-folder-create-group-alist (car flist))))
1999 (setq flist (cdr flist)))
2000 (append cur-alist append-alist))))
2002 (defun wl-folder-init-info-hashtb ()
2003 (let ((info-alist (and wl-folder-info-save
2004 (elmo-msgdb-finfo-load))))
2005 (elmo-folder-info-make-hashtb
2007 wl-folder-entity-hashtb)))
2008 ;;; (wl-folder-resume-entity-hashtb-by-finfo
2009 ;;; wl-folder-entity-hashtb
2012 (defun wl-folder-cleanup-variables ()
2013 (setq wl-folder-entity nil
2014 wl-folder-entity-hashtb nil
2015 wl-folder-entity-id-name-hashtb nil
2016 wl-folder-group-alist nil
2017 wl-folder-petname-alist nil
2018 wl-folder-newsgroups-hashtb nil
2019 wl-fldmgr-cut-entity-list nil
2020 wl-fldmgr-modified nil
2021 wl-fldmgr-modified-access-list nil
2025 (defun wl-make-plugged-alist ()
2026 (let ((entity-list (wl-folder-get-entity-list wl-folder-entity))
2027 (add (not wl-reset-plugged-alist)))
2029 (elmo-folder-set-plugged
2030 (wl-folder-get-elmo-folder (car entity-list)) wl-plugged add)
2031 (setq entity-list (cdr entity-list)))
2032 ;; smtp posting server
2033 (when wl-smtp-posting-server
2034 (elmo-set-plugged wl-plugged
2035 wl-smtp-posting-server ; server
2036 (or (and (boundp 'smtp-service) smtp-service)
2038 wl-smtp-connection-type
2039 nil nil "smtp" add))
2040 ;; nntp posting server
2041 (when wl-nntp-posting-server
2042 (elmo-set-plugged wl-plugged
2043 wl-nntp-posting-server
2044 wl-nntp-posting-stream-type
2045 wl-nntp-posting-port
2046 nil nil "nntp" add))
2047 (run-hooks 'wl-make-plugged-hook)))
2049 (defvar wl-folder-init-function 'wl-local-folder-init)
2051 (defun wl-folder-init ()
2052 "Return top-level folder entity."
2056 (funcall wl-folder-init-function))
2057 (run-hooks 'wl-folder-init-hook))
2059 (defun wl-local-folder-init ()
2060 "Initialize local folder."
2061 (message "Initializing folder...")
2062 (setq wl-folder-entity (wl-folder-create-folder-entity))
2063 (message "Initializing folder...done"))
2065 (defun wl-folder-get-realname (petname)
2069 wl-folder-petname-alist))
2072 (defun wl-folder-get-petname (name)
2076 wl-folder-petname-alist))
2079 (defun wl-folder-get-entity-with-petname ()
2080 (let ((alist wl-folder-petname-alist)
2081 (hashtb (copy-sequence wl-folder-entity-hashtb)))
2083 (wl-folder-set-entity-info (cdar alist) nil hashtb)
2084 (setq alist (cdr alist)))
2087 (defun wl-folder-get-newsgroups (folder)
2088 "Return Newsgroups field value string for FOLDER newsgroup.
2089 If FOLDER is multi, return comma separated string (cross post)."
2090 (let ((nlist (elmo-folder-newsgroups
2091 (wl-folder-get-elmo-folder folder))))
2093 (list nil nil (mapconcat 'identity nlist ","))
2096 (defun wl-folder-guess-mailing-list-by-refile-rule (entity)
2097 "Return ML address guess by ENTITY.
2098 Use `wl-subscribed-mailing-list' and `wl-refile-rule-alist'."
2100 (elmo-folder-get-primitive-list
2101 (wl-folder-get-elmo-folder entity)))
2103 (while (setq fld (car flist))
2104 (setq mladdr (wl-folder-guess-mailing-list-by-refile-rule-subr
2105 (elmo-folder-name-internal fld)))
2107 (setq to (if (stringp to)
2108 (concat to ", " mladdr)
2110 (setq flist (cdr flist)))
2115 (defun wl-folder-guess-mailing-list-by-refile-rule-subr (entity)
2116 (unless (memq (elmo-folder-type entity)
2118 (let ((rules wl-refile-rule-alist)
2121 (if (or (and (stringp (car (car rules)))
2122 (string-match "[Tt]o" (car (car rules))))
2123 (and (listp (car (car rules)))
2124 (elmo-string-matched-member "to" (car (car rules))
2126 (setq toalist (append toalist (cdr (car rules)))))
2127 (setq rules (cdr rules)))
2128 (setq tokey (car (rassoc entity toalist)))
2129 ;;; (setq histkey (car (rassoc folder wl-refile-alist)))
2130 ;; case-ignore search `wl-subscribed-mailing-list'
2132 (elmo-string-matched-member tokey wl-subscribed-mailing-list t)))))
2134 (defun wl-folder-guess-mailing-list-by-folder-name (entity)
2135 "Return ML address guess by ENTITY name's last hierarchy.
2136 Use `wl-subscribed-mailing-list'."
2138 (elmo-folder-get-primitive-list
2139 (wl-folder-get-elmo-folder entity)))
2141 (while (setq fld (car flist))
2142 (setq mladdr (wl-folder-guess-mailing-list-by-folder-name-subr
2143 (elmo-folder-name-internal fld)))
2145 (setq to (if (stringp to)
2146 (concat to ", " mladdr)
2148 (setq flist (cdr flist)))
2153 (defun wl-folder-guess-mailing-list-by-folder-name-subr (entity)
2154 (when (memq (elmo-folder-type entity)
2155 '(localdir imap4 maildir))
2156 (let (key foldername)
2157 ;; Get foldername and Remove folder type symbol.
2158 (setq foldername (substring entity 1))
2159 (if (string-match "@" foldername)
2160 (setq foldername (substring foldername 0 (match-beginning 0))))
2161 (when (string-match "[^\\./]+$" foldername)
2162 (setq key (regexp-quote
2163 (concat (substring foldername (match-beginning 0)) "@")))
2164 (elmo-string-matched-member
2165 key wl-subscribed-mailing-list 'case-ignore)))))
2167 (defun wl-folder-update-diff-line (diffs)
2168 (let ((inhibit-read-only t)
2169 (buffer-read-only nil)
2171 cur-unread new-unread
2176 (setq id (get-text-property (point) 'wl-folder-entity-id))
2177 (setq is-group (get-text-property (point) 'wl-folder-is-group))
2178 (when (looking-at "^[ ]*\\(.*\\):\\([0-9\\*-]*\\)/\\([0-9\\*-]*\\)/\\([0-9\\*]*\\)")
2179 ;;(looking-at "^[ ]*\\([^\\[].+\\):\\([0-9\\*-]*/[0-9\\*-]*/[0-9\\*]*\\)")
2180 (setq cur-new (string-to-int
2181 (wl-match-buffer 2)))
2182 (setq cur-unread (string-to-int
2183 (wl-match-buffer 3)))
2184 (setq cur-all (string-to-int
2185 (wl-match-buffer 4)))
2186 (delete-region (match-beginning 2)
2188 (goto-char (match-beginning 2))
2189 (insert (format "%s/%s/%s"
2190 (setq new-new (+ cur-new (nth 0 diffs)))
2191 (setq new-unread (+ cur-unread (nth 1 diffs)))
2192 (setq new-all (+ cur-all (nth 2 diffs)))))
2193 (wl-folder-put-folder-property (match-beginning 2) (point) id is-group)
2194 (if wl-use-highlight-mouse-line
2195 (put-text-property (match-beginning 2) (point)
2196 'mouse-face 'highlight))
2197 (wl-highlight-folder-group-line (list new-new new-unread new-all))
2198 (setq buffer-read-only t)
2199 (set-buffer-modified-p nil)))))
2201 (defun wl-folder-update-line (nums &optional is-group)
2202 (let ((inhibit-read-only t)
2203 (buffer-read-only nil)
2207 (setq id (get-text-property (point) 'wl-folder-entity-id))
2208 (setq is-group (get-text-property (point) 'wl-folder-is-group))
2209 (if (looking-at "^[ ]*\\(.*\\):\\([0-9\\*-]*/[0-9\\*-]*/[0-9\\*]*\\)")
2210 ;;; (looking-at "^[ ]*\\([^\\[].+\\):\\([0-9\\*-]*/[0-9\\*-]*/[0-9\\*]*\\)")
2212 (delete-region (match-beginning 2)
2214 (goto-char (match-beginning 2))
2215 (insert (format "%s/%s/%s"
2216 (or (nth 0 nums) "*")
2217 (or (and (nth 0 nums)(nth 1 nums)
2218 (+ (nth 0 nums)(nth 1 nums)))
2220 (or (nth 2 nums) "*")))
2221 (put-text-property (match-beginning 2) (point) id is-group)
2223 ;; update only colors
2224 (wl-highlight-folder-group-line nums)
2225 (wl-highlight-folder-current-line nums))
2227 (set-buffer-modified-p nil))))))
2229 (defun wl-folder-goto-folder (&optional arg)
2231 (wl-folder-goto-folder-subr nil arg))
2233 (defun wl-folder-goto-folder-sticky ()
2235 (wl-folder-goto-folder-subr nil t))
2237 (defun wl-folder-goto-draft-folder (&optional arg)
2239 (wl-folder-goto-folder-subr wl-draft-folder arg))
2241 (defun wl-folder-goto-folder-subr (&optional folder sticky)
2243 (let (summary-buf fld-name entity id error-selecting)
2244 ;;; (setq fld-name (wl-folder-get-entity-from-buffer))
2245 ;;; (if (or (null fld-name)
2246 ;;; (assoc fld-name wl-folder-group-alist))
2247 (setq fld-name wl-default-folder)
2248 (setq fld-name (or folder
2250 (wl-summary-read-folder fld-name))))
2251 (if (and (setq entity
2252 (wl-folder-search-entity-by-name fld-name
2255 (setq id (wl-folder-get-entity-id entity)))
2256 (wl-folder-set-current-entity-id id))
2257 (setq summary-buf (wl-summary-get-buffer-create fld-name sticky))
2258 (if (or wl-stay-folder-window wl-summary-use-frame)
2259 (wl-folder-select-buffer summary-buf)
2260 (if (and summary-buf
2261 (get-buffer-window summary-buf))
2263 (wl-summary-goto-folder-subr fld-name
2264 (wl-summary-get-sync-range
2265 (wl-folder-get-elmo-folder fld-name))
2268 (defun wl-folder-suspend ()
2270 (run-hooks 'wl-folder-suspend-hook)
2271 (wl-folder-info-save)
2272 (elmo-crosspost-message-alist-save)
2274 ;(if (fboundp 'mmelmo-cleanup-entity-buffers)
2275 ;(mmelmo-cleanup-entity-buffers))
2276 (bury-buffer wl-folder-buffer-name)
2277 (dolist (summary-buf (wl-collect-summary))
2278 (bury-buffer summary-buf))
2279 (dolist (draft-buf (wl-collect-draft))
2280 (bury-buffer draft-buf))
2281 (delete-windows-on wl-folder-buffer-name t))
2283 (defun wl-folder-info-save ()
2284 (when (and wl-folder-info-save
2285 wl-folder-info-alist-modified)
2286 (let ((entities (list wl-folder-entity))
2287 entity entity-stack info-alist info)
2289 (setq entity (wl-pop entities))
2293 (wl-push entities entity-stack))
2294 (setq entities (nth 2 entity)))
2296 (when (and (setq info (elmo-folder-get-info
2297 (wl-folder-get-elmo-folder entity)))
2298 (not (equal info '(nil))))
2300 (wl-append info-alist (list (list (elmo-string entity)
2301 (list (nth 3 info) ;; max
2302 (nth 2 info) ;; length
2304 (nth 1 info)) ;; unread
2307 (setq entities (wl-pop entity-stack))))
2308 (elmo-msgdb-finfo-save info-alist)
2309 (setq wl-folder-info-alist-modified nil))))
2311 (defun wl-folder-goto-first-unread-folder (&optional arg)
2313 (let ((entities (list wl-folder-entity))
2314 entity entity-stack ret-val
2319 (setq entity (wl-pop entities))
2323 (wl-push entities entity-stack))
2324 (setq entities (nth 2 entity)))
2326 (if (and (setq finfo (wl-folder-get-entity-info entity))
2327 (and (nth 0 finfo)(nth 1 finfo))
2328 (> (+ (nth 0 finfo)(nth 1 finfo)) 0))
2329 (throw 'done entity))
2330 (wl-append ret-val (list entity))))
2332 (setq entities (wl-pop entity-stack))))))
2336 (wl-folder-jump-folder first-entity)
2338 (wl-folder-goto-folder-subr first-entity))
2339 (message "No unread folder"))))
2341 (defun wl-folder-jump-folder (&optional fld-name noopen)
2344 (setq fld-name (wl-summary-read-folder wl-default-folder)))
2345 (goto-char (point-min))
2347 (wl-folder-open-folder fld-name))
2348 (and (wl-folder-buffer-search-entity fld-name)
2349 (beginning-of-line)))
2351 (defun wl-folder-get-entity-list (entity)
2352 (let ((entities (list entity))
2353 entity-stack ret-val)
2355 (setq entity (wl-pop entities))
2359 (wl-push entities entity-stack))
2360 (setq entities (nth 2 entity)))
2362 (wl-append ret-val (list entity))))
2364 (setq entities (wl-pop entity-stack))))
2367 (defun wl-folder-open-unread-folder (entity)
2369 (let ((alist (wl-folder-get-entity-list entity))
2371 finfo path-list path id)
2373 (when (and (setq finfo (wl-folder-get-entity-info (car alist)))
2374 (nth 0 finfo) (nth 1 finfo)
2375 (> (+ (nth 0 finfo)(nth 1 finfo)) 0))
2376 (setq unread (+ unread (+ (nth 0 finfo)(nth 1 finfo))))
2377 (setq id (wl-folder-get-entity-id (car alist)))
2378 (setq path (delete id (wl-folder-get-path
2382 (if (not (member path path-list))
2383 (wl-append path-list (list path))))
2384 (setq alist (cdr alist)))
2386 (wl-folder-open-folder-sub (car path-list))
2387 (setq path-list (cdr path-list)))
2388 (message "%s unread folder"
2389 (if (> unread 0) unread "No")))))
2391 (defun wl-folder-open-unread-current-entity ()
2393 (let ((entity-name (wl-folder-get-entity-from-buffer))
2394 (group (wl-folder-buffer-group-p)))
2396 (wl-folder-open-unread-folder
2398 (wl-folder-search-group-entity-by-name entity-name
2402 (defun wl-folder-open-only-unread-folder ()
2405 (wl-folder-prev-entity-skip-invalid t)
2406 (wl-folder-get-entity-from-buffer t))))
2407 (wl-folder-open-all-unread-folder)
2409 (goto-char (point-max))
2410 (while (and (re-search-backward
2411 "^[ ]*\\[[-]\\].+:0/0/[0-9-]+" nil t)
2413 (wl-folder-jump-to-current-entity) ;; close it
2415 (wl-folder-move-path id)
2418 (defun wl-folder-open-all-unread-folder (&optional arg)
2421 (wl-folder-prev-entity-skip-invalid t)
2422 (wl-folder-get-entity-from-buffer t))))
2423 (wl-folder-open-unread-folder wl-folder-entity)
2425 (wl-folder-move-path id)
2426 (goto-char (point-min))
2427 (wl-folder-next-unread t))))
2429 (defun wl-folder-open-folder (&optional fld-name)
2432 (setq fld-name (wl-summary-read-folder wl-default-folder)))
2433 (let* ((id (wl-folder-get-entity-id
2434 (wl-folder-search-entity-by-name fld-name wl-folder-entity
2436 (path (and id (wl-folder-get-path wl-folder-entity id))))
2438 (wl-folder-open-folder-sub path))))
2440 (defun wl-folder-open-folder-sub (path)
2441 (let ((inhibit-read-only t)
2442 (buffer-read-only nil)
2446 (goto-char (point-min))
2448 (wl-folder-buffer-search-group
2449 (wl-folder-get-petname
2450 (if (stringp (car path))
2452 (wl-folder-get-folder-name-by-id
2455 (setq path (cdr path))
2456 (if (and (wl-folder-buffer-group-p)
2457 (looking-at wl-folder-group-regexp)
2458 (string= "+" (wl-match-buffer 2)));; closed group
2460 (setq indent (wl-match-buffer 1))
2461 (setq name (wl-folder-get-realname (wl-match-buffer 3)))
2462 (setq entity (wl-folder-search-group-entity-by-name
2466 (setcdr (assoc (car entity) wl-folder-group-alist) t)
2467 (if (eq 'access (cadr entity))
2468 (wl-folder-maybe-load-folder-list entity))
2469 (wl-folder-insert-entity indent entity)
2470 (delete-region (save-excursion (beginning-of-line)
2472 (save-excursion (end-of-line)
2474 (set-buffer-modified-p nil))))
2476 (defun wl-folder-open-all-pre ()
2477 (let ((entities (list wl-folder-entity))
2478 entity entity-stack group-entry)
2480 (setq entity (wl-pop entities))
2483 (unless (or (not (setq group-entry
2484 (assoc (car entity) wl-folder-group-alist)))
2486 (setcdr group-entry t)
2487 (when (eq 'access (cadr entity))
2488 (wl-folder-maybe-load-folder-list entity)))
2490 (wl-push entities entity-stack))
2491 (setq entities (nth 2 entity))))
2493 (setq entities (wl-pop entity-stack))))))
2495 (defun wl-folder-open-all (&optional refresh)
2497 (let* ((inhibit-read-only t)
2498 (buffer-read-only nil)
2499 (len (length wl-folder-group-alist))
2504 (wl-folder-prev-entity-skip-invalid t)
2505 (wl-folder-get-entity-from-buffer t)))
2506 (alist wl-folder-group-alist))
2508 (setcdr (pop alist) t))
2510 (wl-folder-insert-entity " " wl-folder-entity)
2511 (wl-folder-move-path id))
2512 (message "Opening all folders...")
2513 (wl-folder-open-all-pre)
2515 (goto-char (point-min))
2516 (while (re-search-forward
2517 "^\\([ ]*\\)\\[\\([+]\\)\\]\\(.+\\):[-0-9-]+/[0-9-]+/[0-9-]+\n"
2519 (setq indent (wl-match-buffer 1))
2520 (setq name (wl-folder-get-realname (wl-match-buffer 3)))
2521 (setq entity (wl-folder-search-group-entity-by-name
2525 (setcdr (assoc (car entity) wl-folder-group-alist) t)
2527 (wl-folder-insert-entity indent entity)
2528 (delete-region (save-excursion (beginning-of-line)
2530 (save-excursion (end-of-line)
2532 (when (> len elmo-display-progress-threshold)
2534 (if (or (zerop (% i 5)) (= i len))
2535 (elmo-display-progress
2536 'wl-folder-open-all "Opening all folders..."
2537 (/ (* i 100) len)))))
2538 (when (> len elmo-display-progress-threshold)
2539 (elmo-display-progress
2540 'wl-folder-open-all "Opening all folders..." 100))))
2541 (wl-highlight-folder-path wl-folder-buffer-cur-path)
2542 (message "Opening all folders...done")
2543 (set-buffer-modified-p nil)))
2545 (defun wl-folder-close-all ()
2547 (let ((inhibit-read-only t)
2548 (buffer-read-only nil)
2549 (alist wl-folder-group-alist)
2551 (wl-folder-prev-entity-skip-invalid t)
2552 (wl-folder-get-entity-from-buffer t))))
2554 (setcdr (car alist) nil)
2555 (setq alist (cdr alist)))
2556 (setcdr (assoc (car wl-folder-entity) wl-folder-group-alist) t)
2558 (wl-folder-insert-entity " " wl-folder-entity)
2559 (wl-folder-move-path id)
2560 (wl-highlight-folder-path wl-folder-buffer-cur-path)
2562 (set-buffer-modified-p nil)))
2564 (defun wl-folder-open-close ()
2565 "Open or close parent entity."
2569 (if (wl-folder-buffer-group-p)
2570 ;; if group (whether opend or closed.)
2571 (wl-folder-jump-to-current-entity)
2574 (setq indent (save-excursion
2575 (re-search-forward "\\([ ]*\\)." nil t)
2576 (wl-match-buffer 1)))
2577 (while (looking-at indent)
2579 (wl-folder-jump-to-current-entity))))
2581 (defsubst wl-folder-access-subscribe-p (group folder)
2582 (let (subscr regexp match)
2583 (if (setq subscr (wl-get-assoc-list-value
2584 wl-folder-access-subscribe-alist
2587 (setq regexp (mapconcat 'identity (cdr subscr) "\\|"))
2588 (setq match (string-match regexp folder))
2594 (defun wl-folder-update-access-group (entity new-flist)
2595 (let* ((flist (nth 2 entity))
2596 (unsubscribes (nth 3 entity))
2597 (len (+ (length flist) (length unsubscribes)))
2599 diff new-unsubscribes removes
2600 subscribed-list folder group entry)
2601 ;; check subscribed groups
2604 ((listp (car flist)) ;; group
2605 (setq group (elmo-string (caar flist)))
2607 ((assoc group new-flist) ;; found in new-flist
2608 (setq new-flist (delete (assoc group new-flist)
2610 (if (wl-folder-access-subscribe-p (car entity) group)
2611 (wl-append subscribed-list (list (car flist)))
2612 (wl-append new-unsubscribes (list (car flist)))
2615 (setq wl-folder-group-alist
2616 (delete (wl-string-assoc group wl-folder-group-alist)
2617 wl-folder-group-alist))
2618 (wl-append removes (list (list group))))))
2620 (setq folder (elmo-string (car flist)))
2622 ((member folder new-flist) ;; found in new-flist
2623 (setq new-flist (delete folder new-flist))
2624 (if (wl-folder-access-subscribe-p (car entity) folder)
2625 (wl-append subscribed-list (list (car flist)))
2626 (wl-append new-unsubscribes (list folder))
2629 (wl-append removes (list folder))))))
2630 (when (> len elmo-display-progress-threshold)
2632 (if (or (zerop (% i 10)) (= i len))
2633 (elmo-display-progress
2634 'wl-folder-update-access-group "Updating access group..."
2635 (/ (* i 100) len))))
2636 (setq flist (cdr flist)))
2637 ;; check unsubscribed groups
2640 ((listp (car unsubscribes))
2641 (when (setq entry (assoc (caar unsubscribes) new-flist))
2642 (setq new-flist (delete entry new-flist))
2643 (wl-append new-unsubscribes (list (car unsubscribes)))))
2645 (when (member (car unsubscribes) new-flist)
2646 (setq new-flist (delete (car unsubscribes) new-flist))
2647 (wl-append new-unsubscribes (list (car unsubscribes))))))
2648 (when (> len elmo-display-progress-threshold)
2650 (if (or (zerop (% i 10)) (= i len))
2651 (elmo-display-progress
2652 'wl-folder-update-access-group "Updating access group..."
2653 (/ (* i 100) len))))
2654 (setq unsubscribes (cdr unsubscribes)))
2656 (if (or new-flist removes)
2659 (mapcar '(lambda (x)
2660 (cond ((consp x) (list (car x) 'access))
2664 (let ((new-list new-flist))
2666 (if (not (wl-folder-access-subscribe-p
2668 (if (listp (car new-list))
2673 (wl-append new-unsubscribes (list (car new-list)))
2674 (setq new-flist (delete (car new-list) new-flist)))
2676 ((listp (car new-list))
2677 ;; check group exists
2678 (if (wl-string-assoc (caar new-list) wl-folder-group-alist)
2680 (message "%s: group already exists." (caar new-list))
2682 (wl-append new-unsubscribes (list (car new-list)))
2683 (setq new-flist (delete (car new-list) new-flist)))
2684 (wl-append wl-folder-group-alist
2685 (list (cons (caar new-list) nil)))))))
2686 (setq new-list (cdr new-list))))
2688 (message "%d new folder(s)." (length new-flist))
2689 (message "Updating access group...done"))
2690 (wl-append new-flist subscribed-list) ;; new is first
2691 (run-hooks 'wl-folder-update-access-group-hook)
2692 (setcdr (cdr entity) (list new-flist new-unsubscribes))
2693 (list diff new-flist new-unsubscribes removes)))
2695 (defun wl-folder-prefetch-entity (entity)
2696 "Prefetch all new messages in the ENTITY."
2699 (let ((flist (nth 2 entity))
2704 (setq result (wl-folder-prefetch-entity (car flist)))
2705 (setq sum-done (+ sum-done (car result)))
2706 (setq sum-all (+ sum-all (cdr result)))
2707 (setq flist (cdr flist)))
2708 (message "Prefetched %d/%d message(s) in \"%s\"."
2710 (wl-folder-get-petname (car entity)))
2711 (cons sum-done sum-all)))
2713 (let* ((folder (wl-folder-get-elmo-folder entity))
2714 (nums (wl-folder-get-entity-info entity))
2715 (wl-summary-highlight (if (or (wl-summary-sticky-p folder)
2716 (wl-summary-always-sticky-folder-p
2718 wl-summary-highlight))
2719 wl-summary-exit-next-move
2720 wl-auto-select-first ret-val
2722 (setq count (or (car nums) 0))
2723 (setq count (+ count (wl-folder-count-incorporates folder)))
2724 (if (or (null (car nums)) ; unknown
2726 (save-window-excursion
2728 (let ((wl-summary-buffer-name
2729 (if (setq sticky (get-buffer
2730 (wl-summary-sticky-buffer-name
2731 (elmo-folder-name-internal
2733 ;; Sticky folder exists.
2734 (wl-summary-sticky-buffer-name
2735 (elmo-folder-name-internal folder))
2737 wl-summary-buffer-name
2738 (symbol-name this-command))))
2739 (wl-summary-use-frame nil)
2740 (wl-summary-always-sticky-folder-list nil))
2741 (wl-summary-goto-folder-subr entity
2742 (wl-summary-get-sync-range
2745 (setq ret-val (wl-summary-incorporate))
2747 (wl-summary-save-status)
2752 (defun wl-folder-count-incorporates (folder)
2753 (let ((marks (elmo-msgdb-mark-load
2754 (elmo-folder-msgdb-path folder)))
2757 (if (member (cadr (car marks))
2758 wl-summary-incorporate-marks)
2760 (setq marks (cdr marks)))
2763 (defun wl-folder-prefetch-current-entity (&optional no-check)
2764 "Prefetch all uncached messages in the folder at position.
2765 If current line is group folder, all subfolders are prefetched."
2768 (let ((entity-name (wl-folder-get-entity-from-buffer))
2769 (group (wl-folder-buffer-group-p))
2770 wl-folder-check-entity-hook
2775 (wl-folder-search-group-entity-by-name entity-name
2779 (wl-folder-check-entity entity))
2780 (wl-folder-prefetch-entity entity)))))
2782 ;(defun wl-folder-drop-unsync-entity (entity)
2783 ; "Drop all unsync messages in the ENTITY."
2786 ; (let ((flist (nth 2 entity)))
2788 ; (wl-folder-drop-unsync-entity (car flist))
2789 ; (setq flist (cdr flist)))))
2791 ; (let ((nums (wl-folder-get-entity-info entity))
2792 ; wl-summary-highlight wl-auto-select-first new)
2793 ; (setq new (or (car nums) 0))
2795 ; (save-window-excursion
2797 ; (let ((wl-summary-buffer-name (concat
2798 ; wl-summary-buffer-name
2799 ; (symbol-name this-command))))
2800 ; (wl-summary-goto-folder-subr entity 'no-sync nil)
2801 ; (wl-summary-drop-unsync)
2802 ; (wl-summary-exit)))))))))
2804 ;(defun wl-folder-drop-unsync-current-entity (&optional force-check)
2805 ; "Drop all unsync messages in the folder at position.
2806 ;If current line is group folder, all subfolders are dropped.
2807 ;If optional arg exists, don't check any folders."
2810 ; (let ((entity-name (wl-folder-get-entity-from-buffer))
2811 ; (group (wl-folder-buffer-group-p))
2812 ; wl-folder-check-entity-hook
2813 ; summary-buf entity)
2814 ; (when (and entity-name
2816 ; "Drop all unsync messages in %s? " entity-name)))
2819 ; (wl-folder-search-group-entity-by-name entity-name
2822 ; (if (null force-check)
2823 ; (wl-folder-check-entity entity))
2824 ; (wl-folder-drop-unsync-entity entity)
2825 ; (message "All unsync messages in %s are dropped!" entity-name)))))
2827 (defun wl-folder-write-current-folder ()
2828 "Write message to current folder's newsgroup or mailing-list.
2829 Call `wl-summary-write-current-folder' with current folder name."
2831 (unless (wl-folder-buffer-group-p)
2832 (wl-summary-write-current-folder
2833 (wl-folder-get-realname (wl-folder-entity-name)))))
2835 (defun wl-folder-mimic-kill-buffer ()
2836 "Kill the current (Folder) buffer with query."
2838 (let ((bufname (read-buffer (format "Kill buffer: (default %s) "
2840 wl-interactive-exit)
2841 (if (or (not bufname)
2842 (string-equal bufname "")
2843 (string-equal bufname (buffer-name)))
2845 (kill-buffer bufname))))
2847 (defun wl-folder-create-subr (folder)
2848 (if (elmo-folder-creatable-p folder)
2849 (if (y-or-n-p (format "Folder %s does not exist, create it? "
2850 (elmo-folder-name-internal folder)))
2853 (setq wl-folder-entity-hashtb
2854 (wl-folder-create-entity-hashtb
2855 (elmo-folder-name-internal folder)
2856 wl-folder-entity-hashtb))
2857 (unless (elmo-folder-create folder)
2858 (error "Create folder failed")))
2859 (error "Folder %s is not created" (elmo-folder-name-internal folder)))
2860 (error "Folder %s does not exist" (elmo-folder-name-internal folder))))
2862 (defun wl-folder-confirm-existence (folder &optional force)
2864 (unless (elmo-folder-exists-p folder)
2865 (wl-folder-create-subr folder))
2866 (unless (or (wl-folder-entity-exists-p (elmo-folder-name-internal folder))
2867 (file-exists-p (elmo-folder-msgdb-path folder))
2868 (elmo-folder-exists-p folder))
2869 (wl-folder-create-subr folder))))
2871 (defun wl-folder-virtual ()
2872 "Goto virtual folder."
2874 (let ((entity (wl-folder-get-entity-from-buffer)))
2875 (if (wl-folder-buffer-group-p)
2879 (mapconcat 'identity
2880 (wl-folder-get-entity-list
2881 (wl-folder-search-group-entity-by-name
2883 wl-folder-entity)) ","))))
2884 (unless entity (error "No folder"))
2885 (wl-folder-goto-folder-subr
2887 (elmo-read-search-condition
2888 wl-fldmgr-make-filter-default)
2891 (defun wl-folder-pick ()
2894 (let* ((condition (car (elmo-parse-search-condition
2895 (elmo-read-search-condition
2896 wl-summary-pick-field-default))))
2897 (entity (wl-folder-get-entity-from-buffer))
2899 (if (wl-folder-buffer-group-p)
2900 (wl-folder-get-entity-list
2901 (wl-folder-search-group-entity-by-name
2906 (while (car folder-list)
2907 (setq ret (elmo-folder-search
2908 (wl-folder-get-elmo-folder (car folder-list))
2913 (list (cons (car folder-list) ret)))))
2914 (setq folder-list (cdr folder-list)))
2916 (message "%s are picked."
2917 (mapconcat '(lambda (res)
2920 (length (cdr res))))
2923 (message "No message was picked.")))))
2925 (defun wl-folder-jump-to-next-summary ()
2927 (when (wl-collect-summary)
2928 (if (get-buffer-window (car (wl-collect-summary)))
2929 (switch-to-buffer-other-window (car (wl-collect-summary))))
2930 (wl-summary-next-buffer)))
2932 (defun wl-folder-jump-to-previous-summary ()
2934 (when (wl-collect-summary)
2935 (if (get-buffer-window (car (wl-collect-summary)))
2936 (switch-to-buffer-other-window (car (wl-collect-summary))))
2937 (wl-summary-previous-buffer)))
2941 (defvar wl-folder-complete-folder-candidate nil)
2943 (defun wl-folder-complete-folder (string predicate flag)
2944 (cond ((or (string-match "^\\(/[^/]*/\\)\\(.*\\)$" string) ; filter
2945 (string-match "^\\(\*\\|\*.*,\\)\\([^,]*\\)$" string) ; multi
2946 (string-match "^\\(|[^|]*|:?\\)\\(.*\\)$" string) ;pipe-src
2947 (string-match "^\\(|\\)\\([^|]*\\)$" string)) ;pipe-dst
2948 (let* ((str1 (match-string 1 string))
2949 (str2 (match-string 2 string))
2950 (str2-comp (wl-folder-complete-folder str2 predicate flag)))
2952 ((listp str2-comp) ; flag=t
2953 (mapcar (lambda (x) (concat str1 x)) str2-comp))
2954 ((stringp str2-comp)
2955 (concat str1 str2-comp))
2958 ((string-match "^\\(/\\)\\([^/]*\\)$" string) ; filter-condition
2959 (let* ((str1 (match-string 1 string))
2960 (str2 (match-string 2 string))
2962 (wl-folder-complete-filter-condition str2 predicate flag)))
2964 ((listp str2-comp) ; flag=t
2965 (mapcar (lambda (x) (concat str1 x)) str2-comp))
2966 ((stringp str2-comp)
2967 (concat str1 str2-comp))
2972 (or wl-folder-complete-folder-candidate
2973 (if (memq 'read-folder wl-use-folder-petname)
2974 (wl-folder-get-entity-with-petname)
2975 wl-folder-entity-hashtb))))
2977 (try-completion string candidate)
2978 (all-completions string candidate))))))
2980 (defun wl-folder-complete-filter-condition (string predicate flag)
2982 ((string-match "^\\(.*|\\|.*&\\|.*!\\|.*(\\)\\([^:]*\\)$" string)
2983 (let* ((str1 (match-string 1 string))
2984 (str2 (match-string 2 string))
2986 (wl-folder-complete-filter-condition str2 predicate flag)))
2988 ((listp str2-comp) ; flag=t
2989 (mapcar (lambda (x) (concat str1 x)) str2-comp))
2990 ((stringp str2-comp)
2991 (concat str1 str2-comp))
2996 (mapcar (lambda (x) (list (concat (downcase x) ":")))
2997 (append '("last" "first"
2998 "from" "subject" "to" "cc" "body"
2999 "since" "before" "tocc")
3000 elmo-msgdb-extra-fields))))
3002 (try-completion string candidate)
3003 (all-completions string candidate))))))
3006 (product-provide (provide 'wl-folder) (require 'wl-version))
3008 ;;; wl-folder.el ends here