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-last-visited-entity-id nil)
70 (defvar wl-folder-buffer-cur-path nil)
71 (defvar wl-folder-buffer-cur-point nil)
73 (make-variable-buffer-local 'wl-folder-buffer-disp-summary)
74 (make-variable-buffer-local 'wl-folder-buffer-cur-entity-id)
75 (make-variable-buffer-local 'wl-folder-buffer-last-visited-entity-id)
76 (make-variable-buffer-local 'wl-folder-buffer-cur-path)
77 (make-variable-buffer-local 'wl-folder-buffer-cur-point)
79 (defconst wl-folder-entity-regexp "^\\([ ]*\\)\\(\\[[\\+-]\\]\\)?\\([^\\[].+\\):[-*0-9]+/[-*0-9]+/[-*0-9]+")
80 (defconst wl-folder-group-regexp "^\\([ ]*\\)\\[\\([\\+-]\\)\\]\\(.+\\):[-0-9-]+/[0-9-]+/[0-9-]+\n")
81 ;; 1:indent 2:opened 3:group-name
82 (defconst wl-folder-unsync-regexp ":[^0\\*][0-9]*/[0-9\\*-]+/[0-9\\*-]+$")
84 (defvar wl-folder-mode-menu-spec
86 ["Enter Current Folder" wl-folder-jump-to-current-entity t]
87 ["Prev Folder" wl-folder-prev-entity t]
88 ["Next Folder" wl-folder-next-entity t]
89 ["Check Current Folder" wl-folder-check-current-entity t]
90 ["Sync Current Folder" wl-folder-sync-current-entity t]
91 ; ["Drop Current Folder" wl-folder-drop-unsync-current-entity t]
92 ["Prefetch Current Folder" wl-folder-prefetch-current-entity t]
94 ["Mark as Read all Current Folder" wl-folder-mark-as-read-all-current-entity t]
95 ["Expire Current Folder" wl-folder-expire-current-entity t]
97 ["Go to Draft Folder" wl-folder-goto-draft-folder t]
98 ["Empty trash" wl-folder-empty-trash t]
99 ["Flush queue" wl-folder-flush-queue t]
101 ["Open All" wl-folder-open-all t]
102 ["Open All Unread folder" wl-folder-open-all-unread-folder t]
103 ["Close All" wl-folder-close-all t]
105 ["Add folder" wl-fldmgr-add t]
106 ["Add group" wl-fldmgr-make-group t]
107 ["Copy" wl-fldmgr-copy t]
108 ["Cut" wl-fldmgr-cut t]
109 ["Paste" wl-fldmgr-yank t]
110 ["Set petname" wl-fldmgr-set-petname t]
111 ["Rename" wl-fldmgr-rename t]
112 ["Save" wl-fldmgr-save-folders t]
114 ["Unsubscribe" wl-fldmgr-unsubscribe t]
115 ["Display all" wl-fldmgr-access-display-all t])
117 ["Write a message" wl-draft t]
118 ["Write for current folder" wl-folder-write-current-folder t]
120 ["Wanderlust NEWS" wl-news t]
122 ["Toggle Plug Status" wl-toggle-plugged t]
123 ["Change Plug Status" wl-plugged-change t]
125 ["Save Current Status" wl-save t]
126 ["Update Status" wl-status-update t]
131 (defun wl-folder-setup-mouse ()
132 (define-key wl-folder-mode-map 'button2 'wl-folder-click)
133 (define-key wl-folder-mode-map 'button4 'wl-folder-prev-entity)
134 (define-key wl-folder-mode-map 'button5 'wl-folder-next-entity)
135 (define-key wl-folder-mode-map [(shift button4)]
136 'wl-folder-prev-unread)
137 (define-key wl-folder-mode-map [(shift button5)]
138 'wl-folder-next-unread))
139 (defun wl-folder-setup-mouse ()
140 (define-key wl-folder-mode-map [mouse-2] 'wl-folder-click)
141 (define-key wl-folder-mode-map [mouse-4] 'wl-folder-prev-entity)
142 (define-key wl-folder-mode-map [mouse-5] 'wl-folder-next-entity)
143 (define-key wl-folder-mode-map [S-mouse-4] 'wl-folder-prev-unread)
144 (define-key wl-folder-mode-map [S-mouse-5] 'wl-folder-next-unread)))
146 (if wl-folder-mode-map
148 (setq wl-folder-mode-map (make-sparse-keymap))
149 (define-key wl-folder-mode-map " " 'wl-folder-jump-to-current-entity)
150 ; (define-key wl-folder-mode-map "\M- " 'wl-folder-open-close)
151 (define-key wl-folder-mode-map "/" 'wl-folder-open-close)
152 (define-key wl-folder-mode-map "\C-m" 'wl-folder-jump-to-current-entity)
153 (define-key wl-folder-mode-map [(shift return)] 'wl-folder-jump-to-current-entity-with-arg)
154 (define-key wl-folder-mode-map "\M-\C-m" 'wl-folder-update-recursive-current-entity)
155 (define-key wl-folder-mode-map "rc" 'wl-folder-mark-as-read-all-region)
156 (define-key wl-folder-mode-map "c" 'wl-folder-mark-as-read-all-current-entity)
157 (define-key wl-folder-mode-map "g" 'wl-folder-goto-folder)
158 (define-key wl-folder-mode-map "G" 'wl-folder-goto-folder-sticky)
159 (define-key wl-folder-mode-map "j" 'wl-folder-jump-to-current-entity)
160 (define-key wl-folder-mode-map "\C-i" 'wl-folder-revisit-last-visited-folder)
161 (define-key wl-folder-mode-map "w" 'wl-draft)
162 (define-key wl-folder-mode-map "W" 'wl-folder-write-current-folder)
163 (define-key wl-folder-mode-map "\C-c\C-o" 'wl-jump-to-draft-buffer)
164 (define-key wl-folder-mode-map "\C-c\C-a" 'wl-addrmgr)
165 (define-key wl-folder-mode-map "\C-c\C-p" 'wl-folder-jump-to-previous-summary)
166 (define-key wl-folder-mode-map "\C-c\C-n" 'wl-folder-jump-to-next-summary)
167 (define-key wl-folder-mode-map "rS" 'wl-folder-sync-region)
168 (define-key wl-folder-mode-map "S" 'wl-folder-sync-current-entity)
169 (define-key wl-folder-mode-map "rs" 'wl-folder-check-region)
170 (define-key wl-folder-mode-map "s" 'wl-folder-check-current-entity)
171 (define-key wl-folder-mode-map "I" 'wl-folder-prefetch-current-entity)
172 ; (define-key wl-folder-mode-map "D" 'wl-folder-drop-unsync-current-entity)
173 (define-key wl-folder-mode-map "p" 'wl-folder-prev-entity)
174 (define-key wl-folder-mode-map "n" 'wl-folder-next-entity)
175 (define-key wl-folder-mode-map "v" 'wl-folder-toggle-disp-summary)
176 (define-key wl-folder-mode-map "P" 'wl-folder-prev-unread)
177 (define-key wl-folder-mode-map "N" 'wl-folder-next-unread)
178 (define-key wl-folder-mode-map "J" 'wl-folder-jump-folder)
179 (define-key wl-folder-mode-map "f" 'wl-folder-goto-first-unread-folder)
180 (define-key wl-folder-mode-map "o" 'wl-folder-open-all-unread-folder)
181 (define-key wl-folder-mode-map "[" 'wl-folder-open-all)
182 (define-key wl-folder-mode-map "]" 'wl-folder-close-all)
183 (define-key wl-folder-mode-map "e" 'wl-folder-expire-current-entity)
184 (define-key wl-folder-mode-map "E" 'wl-folder-empty-trash)
185 (define-key wl-folder-mode-map "F" 'wl-folder-flush-queue)
186 (define-key wl-folder-mode-map "V" 'wl-folder-virtual)
187 (define-key wl-folder-mode-map "?" 'wl-folder-pick)
188 (define-key wl-folder-mode-map "q" 'wl-exit)
189 (define-key wl-folder-mode-map "z" 'wl-folder-suspend)
190 (define-key wl-folder-mode-map "\M-t" 'wl-toggle-plugged)
191 (define-key wl-folder-mode-map "\C-t" 'wl-plugged-change)
192 (define-key wl-folder-mode-map "<" 'beginning-of-buffer)
193 (define-key wl-folder-mode-map ">" 'end-of-buffer)
195 (define-key wl-folder-mode-map "m" 'wl-fldmgr-mode-map)
196 (define-key wl-folder-mode-map "*" 'wl-fldmgr-make-multi)
197 (define-key wl-folder-mode-map "+" 'wl-fldmgr-make-group)
198 (define-key wl-folder-mode-map "|" 'wl-fldmgr-make-filter)
199 (define-key wl-folder-mode-map "\M-c" 'wl-fldmgr-copy)
200 (define-key wl-folder-mode-map "\M-w" 'wl-fldmgr-copy-region)
201 (define-key wl-folder-mode-map "\C-k" 'wl-fldmgr-cut)
202 (define-key wl-folder-mode-map "\C-w" 'wl-fldmgr-cut-region)
203 (define-key wl-folder-mode-map "\C-y" 'wl-fldmgr-yank)
204 (define-key wl-folder-mode-map "R" 'wl-fldmgr-rename)
205 (define-key wl-folder-mode-map "u" 'wl-fldmgr-unsubscribe)
206 (define-key wl-folder-mode-map "ru" 'wl-fldmgr-unsubscribe-region)
207 (define-key wl-folder-mode-map "U" 'wl-fldmgr-unsubscribe-region)
208 (define-key wl-folder-mode-map "l" 'wl-fldmgr-access-display-normal)
209 (define-key wl-folder-mode-map "L" 'wl-fldmgr-access-display-all)
210 (define-key wl-folder-mode-map "Z" 'wl-status-update)
211 (define-key wl-folder-mode-map "\C-x\C-s" 'wl-save)
212 (define-key wl-folder-mode-map "\M-s" 'wl-save)
213 (define-key wl-folder-mode-map "\C-xk" 'wl-folder-mimic-kill-buffer)
214 (define-key wl-folder-mode-map "\M-\C-a"
215 'wl-folder-goto-top-of-current-folder)
216 (define-key wl-folder-mode-map "\M-\C-e"
217 'wl-folder-goto-bottom-of-current-folder)
219 (wl-folder-setup-mouse)
223 "Menu used in Folder mode."
224 wl-folder-mode-menu-spec))
226 (defmacro wl-folder-unread-regex (group)
227 (` (concat "^[ ]*.+:[0-9\\*-]+/[^0\\*][0-9]*/[0-9\\*-]+$"
232 (defmacro wl-folder-buffer-group-p ()
233 (` (get-text-property (point) 'wl-folder-is-group)))
235 (defun wl-folder-buffer-search-group (group)
236 (let ((prev-point (point))
237 (group-regexp (concat
238 "^\\([ \t]*\\)\\[[\\+-]\\]"
239 (regexp-quote group) ":[-0-9-]+/[0-9-]+/[0-9-]+")))
241 (while (re-search-forward group-regexp nil t)
242 (if (wl-folder-buffer-group-p)
243 (throw 'found (point)))))
245 (goto-char prev-point)
248 (defun wl-folder-buffer-search-entity (folder &optional searchname)
249 (let ((search (or searchname (wl-folder-get-petname folder)))
254 (regexp-quote search) ":[-0-9\\*-]+/[0-9\\*-]+/[0-9\\*-]+") nil t)))
256 (defsubst wl-folder-get-folder-name-by-id (entity-id &optional hashtb)
257 (and (numberp entity-id)
258 (elmo-get-hash-val (format "#%d" entity-id)
259 (or hashtb wl-folder-entity-id-name-hashtb))))
261 (defsubst wl-folder-set-id-name (entity-id entity &optional hashtb)
262 (and (numberp entity-id)
263 (elmo-set-hash-val (format "#%d" entity-id)
264 entity (or hashtb wl-folder-entity-id-name-hashtb))))
266 (defmacro wl-folder-get-entity-id (entity)
267 `(get-text-property 0 'wl-folder-entity-id ,entity))
269 (defmacro wl-folder-get-entity-from-buffer (&optional getid)
270 `(let ((id (get-text-property (point)
271 'wl-folder-entity-id)))
274 (wl-folder-get-folder-name-by-id id))))
276 (defmacro wl-folder-entity-exists-p (entity &optional hashtb)
277 (` (let ((sym (intern-soft (, entity)
278 (or (, hashtb) wl-folder-entity-hashtb))))
279 (and sym (boundp sym)))))
281 (defmacro wl-folder-clear-entity-info (entity &optional hashtb)
282 (` (let ((sym (intern-soft (, entity)
283 (or (, hashtb) wl-folder-entity-hashtb))))
287 (defmacro wl-folder-get-entity-info (entity &optional hashtb)
288 (` (elmo-get-hash-val (, entity) (or (, hashtb) wl-folder-entity-hashtb))))
290 (defmacro wl-folder-set-entity-info (entity value &optional hashtb)
291 (` (let* ((hashtb (or (, hashtb) wl-folder-entity-hashtb))
292 (info (wl-folder-get-entity-info (, entity) hashtb)))
293 (elmo-set-hash-val (elmo-string (, entity))
294 (if (< (length (, value)) 4)
295 (append (, value) (list (nth 3 info)))
299 (defun wl-folder-persistent-p (folder)
300 (or (and (wl-folder-search-entity-by-name folder wl-folder-entity
304 (let ((li wl-save-folder-list))
306 (if (string-match (car li) folder)
308 (setq li (cdr li)))))
310 (let ((li wl-no-save-folder-list))
312 (if (string-match (car li) folder)
314 (setq li (cdr li))))))))
316 ;;; ELMO folder structure with cache.
317 (defmacro wl-folder-elmo-folder-cache-get (name &optional hashtb)
318 "Returns a elmo folder structure associated with NAME from HASHTB.
319 Default HASHTB is `wl-folder-elmo-folder-hashtb'."
320 (` (elmo-get-hash-val (, name)
321 (or (, hashtb) wl-folder-elmo-folder-hashtb))))
323 (defmacro wl-folder-elmo-folder-cache-put (name folder &optional hashtb)
324 "Get folder elmo folder structure on HASHTB for folder with NAME.
325 Default HASHTB is `wl-folder-elmo-folder-hashtb'."
326 (` (elmo-set-hash-val (, name) (, folder)
327 (or (, hashtb) wl-folder-elmo-folder-hashtb))))
329 (defun wl-draft-get-folder ()
330 "A function to obtain `opened' draft elmo folder structure."
331 (if (and wl-draft-folder-internal
332 (string= (elmo-folder-name-internal wl-draft-folder-internal)
334 wl-draft-folder-internal
335 (setq wl-draft-folder-internal (elmo-make-folder wl-draft-folder))
336 (wl-folder-confirm-existence wl-draft-folder-internal)
337 (elmo-folder-open wl-draft-folder-internal 'load-msgdb)
338 wl-draft-folder-internal))
340 (defmacro wl-folder-get-elmo-folder (entity &optional no-cache)
341 "Get elmo folder structure from ENTITY."
343 (elmo-make-folder (elmo-string ,entity))
344 (if (string= (elmo-string ,entity) wl-draft-folder)
345 (wl-draft-get-folder)
346 (or (wl-folder-elmo-folder-cache-get ,entity)
347 (let* ((name (elmo-string ,entity))
348 (folder (elmo-make-folder name)))
349 (wl-folder-elmo-folder-cache-put name folder)
352 (defsubst wl-folder-put-folder-property (beg end id is-group &optional object)
353 (put-text-property beg end 'wl-folder-entity-id id object)
354 (put-text-property beg end 'wl-folder-is-group is-group object))
356 (defun wl-folder-prev-entity ()
360 (defun wl-folder-next-entity ()
364 (defun wl-folder-prev-entity-skip-invalid (&optional hereto)
365 "Move to previous entity. skip unsubscribed or removed entity."
369 (if (re-search-backward wl-folder-entity-regexp nil t)
371 (goto-char (point-min))))
373 (defun wl-folder-next-entity-skip-invalid (&optional hereto)
374 "Move to next entity. skip unsubscribed or removed entity."
379 (if (re-search-forward wl-folder-entity-regexp nil t)
381 (goto-char (point-max))))
383 (defun wl-folder-search-group-entity-by-name (name entity)
384 (wl-folder-search-entity-by-name name entity 'group))
386 (defun wl-folder-search-entity-by-name (name entity &optional type)
387 (let ((entities (list entity))
391 (setq entity (wl-pop entities))
394 (if (and (not (eq type 'folder))
395 (string= name (car entity)))
396 (throw 'done entity))
398 (wl-push entities entity-stack))
399 (setq entities (nth 2 entity)))
400 ((and (not (eq type 'group))
402 (if (string= name entity)
403 (throw 'done entity))))
405 (setq entities (wl-pop entity-stack)))))))
407 (defun wl-folder-search-entity-list-by-name (name entity &optional get-id)
408 (let ((entities (list entity))
409 entity-stack ret-val)
411 (setq entity (wl-pop entities))
415 (wl-push entities entity-stack))
416 (setq entities (nth 2 entity)))
418 (if (string= name entity)
419 (wl-append ret-val (if get-id
420 (list (wl-folder-get-entity-id entity))
423 (setq entities (wl-pop entity-stack))))
426 (defun wl-folder-get-prev-folder (id &optional unread)
427 (let ((name (if (stringp id)
429 (wl-folder-get-folder-name-by-id id)))
430 entity entity-stack last-entity finfo
431 (entities (list wl-folder-entity)))
434 (setq entity (wl-pop entities))
437 ;; (if (and (string= name (car entity))
438 ;; (eq id (wl-folder-get-entity-id (car entity))))
439 ;; (throw 'done last-entity))
441 (wl-push entities entity-stack))
442 (setq entities (nth 2 entity)))
444 (if (and (string= name entity)
445 (eq id (wl-folder-get-entity-id entity)))
446 (throw 'done last-entity))
448 (and (setq finfo (wl-folder-get-entity-info entity))
449 (and (nth 0 finfo)(nth 1 finfo))
450 (> (+ (nth 0 finfo)(nth 1 finfo)) 0)))
451 (setq last-entity entity))))
453 (setq entities (wl-pop entity-stack)))))))
455 (defun wl-folder-get-next-folder (id &optional unread)
456 (let ((name (if (stringp id)
458 (wl-folder-get-folder-name-by-id id)))
459 entity entity-stack found finfo
460 (entities (list wl-folder-entity)))
463 (setq entity (wl-pop entities))
466 ;;; (if (and (string= name (car entity))
467 ;;; (eq id (wl-folder-get-entity-id (car entity))))
470 (wl-push entities entity-stack))
471 (setq entities (nth 2 entity)))
474 (when (or (not unread)
475 (and (setq finfo (wl-folder-get-entity-info entity))
476 (and (nth 0 finfo)(nth 1 finfo))
477 (> (+ (nth 0 finfo)(nth 1 finfo)) 0)))
478 (throw 'done entity))
479 (if (and (string= name entity)
480 (eq id (wl-folder-get-entity-id entity)))
483 (setq entities (wl-pop entity-stack)))))))
485 (defun wl-folder-flush-queue ()
488 (let ((cur-buf (current-buffer))
489 (wl-auto-select-first nil)
492 (if elmo-enable-disconnected-operation
493 (elmo-dop-queue-flush))
494 (if (not (elmo-folder-list-messages
495 (wl-folder-get-elmo-folder wl-queue-folder)))
496 (message "No sending queue exists.")
497 (if wl-stay-folder-window
498 (wl-folder-select-buffer
499 (wl-summary-get-buffer-create wl-queue-folder)))
500 (wl-summary-goto-folder-subr wl-queue-folder 'force-update nil)
502 (wl-draft-queue-flush)
503 (if (get-buffer-window cur-buf)
504 (select-window (get-buffer-window cur-buf)))
506 (if wl-stay-folder-window
507 (wl-folder-toggle-disp-summary 'off wl-queue-folder)
508 (switch-to-buffer cur-buf))))))
510 (defun wl-folder-empty-trash ()
513 (let ((cur-buf (current-buffer))
514 (wl-auto-select-first nil)
516 (wl-summary-goto-folder-subr wl-trash-folder 'force-update)
517 (setq trash-buf (wl-summary-get-buffer-create wl-trash-folder))
518 (if wl-stay-folder-window
519 (wl-folder-select-buffer trash-buf)
520 (switch-to-buffer trash-buf))
522 (setq emptied (wl-summary-delete-all-msgs))
524 (setq wl-thread-entities nil
525 wl-thread-entity-list nil)
526 (if wl-summary-cache-use (wl-summary-save-view-cache))
527 (elmo-folder-commit wl-summary-buffer-elmo-folder))
528 (if (get-buffer-window cur-buf)
529 (select-window (get-buffer-window cur-buf)))
532 (wl-folder-set-folder-updated wl-trash-folder '(0 0 0)))
533 (if wl-stay-folder-window
534 (wl-folder-toggle-disp-summary 'off wl-trash-folder)
535 (switch-to-buffer cur-buf))
537 (kill-buffer trash-buf)))))
539 (defun wl-folder-goto-top-of-current-folder (&optional arg)
540 "Move backward to the top of the current folder group.
541 Optional argument ARG is repeart count."
543 (if (re-search-backward
544 "^ *\\[[\\+-]\\]" nil t (if arg (prefix-numeric-value arg)))
546 (goto-char (point-min))))
548 (defun wl-folder-goto-bottom-of-current-folder (indent)
549 "Move forward to the bottom of the current folder group."
554 (if (looking-at "^ *")
555 (buffer-substring (match-beginning 0)(1- (match-end 0)))
559 (while (re-search-forward "^ *" nil t)
560 (if (<= (length (match-string 0))
564 (goto-char (point-max))))
566 (defsubst wl-folder-update-group (entity diffs &optional is-group)
568 (let ((path (wl-folder-get-path
570 (wl-folder-get-entity-id entity)
573 ;; delete itself from path
574 (setq path (delete (nth (- (length path) 1) path) path)))
575 (goto-char (point-min))
578 ;; goto the path line.
579 (if (or (eq (car path) 0) ; update desktop
580 (wl-folder-buffer-search-group
581 (wl-folder-get-petname
582 (if (stringp (car path))
584 (wl-folder-get-folder-name-by-id
587 (wl-folder-update-diff-line diffs)
589 (setq path (cdr path)))))))
591 (defun wl-folder-maybe-load-folder-list (entity)
592 (when (null (caddr entity))
594 (elmo-msgdb-flist-load (car entity)))
598 (wl-folder-entity-assign-id entity
599 wl-folder-entity-id-name-hashtb
601 (setq diffs (wl-fldmgr-add-entity-hashtb (list entity)))
602 (unless (equal diffs '(0 0 0))
603 (wl-folder-update-group (car entity) diffs t)))))))
605 (defsubst wl-folder-force-fetch-p (entity)
607 ((consp wl-force-fetch-folders)
608 (wl-string-match-member entity wl-force-fetch-folders))
610 wl-force-fetch-folders)))
612 (defun wl-folder-jump-to-current-entity-with-arg ()
614 (wl-folder-jump-to-current-entity t))
616 (defun wl-folder-jump-to-current-entity (&optional arg)
617 "Enter the current folder. If optional ARG exists, update folder list."
620 (let (entity beg end indent opened fname err fld-name)
621 (if (and (wl-folder-buffer-group-p)
622 (looking-at wl-folder-group-regexp))
625 (setq fname (wl-folder-get-entity-from-buffer))
626 (setq indent (wl-match-buffer 1))
627 (setq opened (wl-match-buffer 2))
628 (if (string= opened "+")
630 (setq entity (wl-folder-search-group-entity-by-name
635 (wl-folder-update-recursive-current-entity entity)
637 (setcdr (assoc (car entity) wl-folder-group-alist) t)
638 (if (eq 'access (cadr entity))
639 (wl-folder-maybe-load-folder-list entity))
640 ;(condition-case errobj
642 (if (or (wl-folder-force-fetch-p (car entity))
644 (eq 'access (cadr entity))
645 (null (caddr entity))))
646 (wl-folder-update-newest indent entity)
647 (wl-folder-insert-entity indent entity))
648 (wl-highlight-folder-path wl-folder-buffer-cur-path))
651 ; (setcdr (assoc fname wl-folder-group-alist) nil))
653 ; (elmo-display-error errobj t)
656 ; (setcdr (assoc fname wl-folder-group-alist) nil)))
658 (let ((buffer-read-only nil))
659 (delete-region (save-excursion (beginning-of-line)
661 (save-excursion (end-of-line)
667 (progn (wl-folder-goto-bottom-of-current-folder indent)
670 (setq entity (wl-folder-search-group-entity-by-name
673 (let ((buffer-read-only nil))
674 (delete-region beg end))
675 (setcdr (assoc (car entity) wl-folder-group-alist) nil)
676 (wl-folder-insert-entity indent entity) ; insert entity
678 (wl-highlight-folder-path wl-folder-buffer-cur-path)
679 ; (wl-delete-all-overlays)
680 ; (wl-highlight-folder-current-line)
683 (setq fld-name (wl-folder-get-entity-from-buffer))
684 (wl-folder-set-current-entity-id
685 (get-text-property (point) 'wl-folder-entity-id))
686 (setq fld-name (wl-folder-get-folder-name-by-id
687 wl-folder-buffer-cur-entity-id))
688 (let ((summary-buf (wl-summary-get-buffer-create fld-name arg))
690 (if (or wl-stay-folder-window wl-summary-use-frame)
691 (wl-folder-select-buffer summary-buf)
693 (get-buffer-window summary-buf))
695 (wl-summary-goto-folder-subr fld-name
696 (wl-summary-get-sync-range
697 (wl-folder-get-elmo-folder fld-name))
699 (set-buffer-modified-p nil))
701 (defun wl-folder-close-entity (entity)
702 (let ((entities (list entity))
705 (setq entity (wl-pop entities))
708 (setcdr (assoc (car entity) wl-folder-group-alist) nil)
710 (wl-push entities entity-stack))
711 (setq entities (nth 2 entity))))
713 (setq entities (wl-pop entity-stack))))))
715 (defun wl-folder-update-recursive-current-entity (&optional entity)
718 (when (and (wl-folder-buffer-group-p)
719 (looking-at wl-folder-group-regexp))
721 ((string= (wl-match-buffer 2) "+")
725 (wl-folder-search-group-entity-by-name
726 (wl-folder-get-entity-from-buffer)
728 (let ((inhibit-read-only t)
729 (entities (list entity))
730 entity-stack err indent)
731 (while (and entities (not err))
732 (setq entity (wl-pop entities))
735 (wl-folder-close-entity entity)
736 (setcdr (assoc (car entity) wl-folder-group-alist) t)
737 (unless (wl-folder-buffer-search-group
738 (wl-folder-get-petname (car entity)))
739 (error "%s: not found group" (car entity)))
740 (setq indent (wl-match-buffer 1))
741 (if (eq 'access (cadr entity))
742 (wl-folder-maybe-load-folder-list entity))
746 (condition-case errobj
747 (wl-folder-update-newest indent entity)
750 (setcdr (assoc (car entity) wl-folder-group-alist) nil))
752 (elmo-display-error errobj t)
755 (setcdr (assoc (car entity) wl-folder-group-alist) nil)))
757 (delete-region (save-excursion (beginning-of-line)
759 (save-excursion (end-of-line)
763 (wl-push entities entity-stack))
764 (setq entities (nth 2 entity))))
766 (setq entities (wl-pop entity-stack)))))
767 (set-buffer-modified-p nil)))
769 (wl-folder-jump-to-current-entity)))))
771 (defun wl-folder-no-auto-check-folder-p (folder)
774 (let ((li wl-auto-check-folder-list))
776 (if (string-match (car li) folder)
778 (setq li (cdr li)))))
781 (let ((li wl-auto-uncheck-folder-list))
783 (if (string-match (car li) folder)
784 (throw 'found t)) ; no check!
785 (setq li (cdr li))))))))
787 (defsubst wl-folder-add-folder-info (pre-value value)
789 (+ (or (nth 0 pre-value) 0) (or (nth 0 value) 0))
790 (+ (or (nth 1 pre-value) 0) (or (nth 1 value) 0))
791 (+ (or (nth 2 pre-value) 0) (or (nth 2 value) 0))))
793 (defun wl-folder-check-entity (entity &optional auto)
794 "Check unsync message number."
795 (let ((start-pos (point))
797 (run-hooks 'wl-folder-check-entity-pre-hook)
798 (if (and (consp entity) ;; group entity
799 wl-folder-check-async) ;; very fast
800 (setq ret-val (wl-folder-check-entity-async entity auto))
804 (let ((flist (if auto
806 'wl-folder-no-auto-check-folder-p
809 (wl-folder-check-entity-pre-hook nil)
810 (wl-folder-check-entity-hook nil)
814 (wl-folder-add-folder-info
816 (wl-folder-check-entity (car flist))))
817 (setq flist (cdr flist)))
818 ;(wl-folder-buffer-search-entity (car entity))
819 ;(wl-folder-update-line ret-val)
822 (message "Checking \"%s\"" entity)
823 (setq ret-val (wl-folder-check-one-entity
825 (goto-char start-pos)
828 (message "Uncheck(unplugged) \"%s\"" entity)))))
830 (message "Checking \"%s\" is done"
831 (if (consp entity) (car entity) entity)))
832 (run-hooks 'wl-folder-check-entity-hook)
835 (defun wl-folder-check-one-entity (entity &optional biff)
836 (let* ((folder (wl-folder-get-elmo-folder entity biff))
837 (nums (condition-case err
839 (if biff (elmo-folder-set-biff-internal folder t))
840 (if (wl-string-match-member entity wl-strict-diff-folders)
841 (elmo-strict-folder-diff folder)
842 (elmo-folder-diff folder)))
844 ;; maybe not exist folder.
845 (if (and (not (or (memq 'elmo-open-error
846 (get (car err) 'error-conditions))
847 (memq 'elmo-imap4-bye-error
848 (get (car err) 'error-conditions))))
849 (not (elmo-folder-exists-p folder)))
850 (wl-folder-create-subr folder)
851 (signal (car err) (cdr err))))))
852 (new (elmo-diff-new nums))
853 (unread (elmo-diff-unread nums))
854 (all (elmo-diff-all nums))
856 (if (and (eq wl-folder-notify-deleted 'sync)
857 (or (and new (> 0 new))
858 (and unread (> 0 unread))
859 (and all (> 0 all))))
861 (wl-folder-sync-entity entity)
862 (setq nums (elmo-folder-diff folder)
863 new (elmo-diff-new nums)
864 unread (elmo-diff-unread nums)
865 all (elmo-diff-all nums)))
866 (unless wl-folder-notify-deleted
867 (setq new (and new (max 0 new))
868 unread (and unread (max 0 unread))
869 all (and all (max 0 all))))
870 (setq unread (or (and unread (- unread (or new 0)))
871 (elmo-folder-get-info-unread folder)
872 (nth 1 (elmo-folder-count-flags folder))))
873 (wl-folder-entity-hashtb-set wl-folder-entity-hashtb entity
874 (list new unread all)
875 (get-buffer wl-folder-buffer-name)))
876 (setq wl-folder-info-alist-modified t)
878 (list new unread all)))
880 (defun wl-folder-check-entity-async (entity &optional auto)
881 (let ((elmo-nntp-groups-async t)
884 'wl-folder-no-auto-check-folder-p
885 (wl-folder-get-entity-list entity))
886 (wl-folder-get-entity-list entity)))
887 (nntp-connection-keys nil)
888 name folder folder-list
894 (setq folder (wl-folder-get-elmo-folder (car elist)))
895 (if (not (elmo-folder-plugged-p folder))
896 (message "Uncheck \"%s\"" (car elist))
898 (elmo-folder-get-primitive-list folder))
899 (cond ((elmo-folder-contains-type folder 'nntp)
900 (wl-append async-folder-list (list folder))
902 (when (eq (elmo-folder-type-internal (car folder-list))
906 (elmo-net-folder-server-internal
908 (setq server (elmo-net-folder-server-internal
910 (message "Checking on \"%s\"" server))
911 (setq nntp-connection-keys
912 (elmo-nntp-get-folders-info-prepare
914 nntp-connection-keys)))
915 (setq folder-list (cdr folder-list))))
917 (wl-append sync-folder-list (list folder)))))
918 (setq elist (cdr elist)))
919 ;; check local entity at first
920 (while (setq folder (pop sync-folder-list))
921 (if (not (elmo-folder-plugged-p folder))
922 (message "Uncheck \"%s\"" (elmo-folder-name-internal folder))
923 (message "Checking \"%s\"" (elmo-folder-name-internal folder))
925 (wl-folder-add-folder-info
927 (wl-folder-check-one-entity (elmo-folder-name-internal
931 ;; check network entity at last
932 (when async-folder-list
933 (elmo-nntp-get-folders-info nntp-connection-keys)
934 (while (setq folder (pop async-folder-list))
935 (if (not (elmo-folder-plugged-p folder))
936 (message "Uncheck \"%s\"" (elmo-folder-name-internal folder))
937 (message "Checking \"%s\"" (elmo-folder-name-internal folder))
939 (wl-folder-add-folder-info
941 (wl-folder-check-one-entity (elmo-folder-name-internal
948 (defun wl-folder-resume-entity-hashtb-by-finfo (entity-hashtb info-alist)
949 "Resume unread info for entity alist."
952 (setq info (nth 1 (car info-alist)))
953 (wl-folder-set-entity-info (caar info-alist)
954 (list (nth 2 info)(nth 3 info)(nth 1 info))
956 (setq info-alist (cdr info-alist)))))
958 (defun wl-folder-move-path (path)
959 (let ((fp (if (consp path)
962 (wl-folder-get-path wl-folder-entity path))))
963 (goto-char (point-min))
966 (when (equal (car fp)
967 (wl-folder-get-entity-from-buffer t))
969 (setq wl-folder-buffer-cur-point (point)))
971 (and wl-folder-buffer-cur-point
972 (goto-char wl-folder-buffer-cur-point))))
974 (defun wl-folder-set-current-entity-id (entity-id)
975 (let* ((buf (get-buffer wl-folder-buffer-name))
976 (buf-win (get-buffer-window buf)))
979 (save-selected-window
981 (select-window buf-win)
983 (when (and wl-folder-buffer-cur-entity-id
984 (not (eq wl-folder-buffer-last-visited-entity-id
985 wl-folder-buffer-cur-entity-id)))
986 (setq wl-folder-buffer-last-visited-entity-id wl-folder-buffer-cur-entity-id))
987 (setq wl-folder-buffer-cur-entity-id entity-id)
988 (setq wl-folder-buffer-cur-path
989 (wl-folder-get-path wl-folder-entity entity-id))
990 (wl-highlight-folder-path wl-folder-buffer-cur-path)
991 (and wl-folder-move-cur-folder
992 wl-folder-buffer-cur-point
993 (goto-char wl-folder-buffer-cur-point)))))))
995 (defun wl-folder-check-current-entity ()
996 "Check folder at position.
997 If current line is group folder, check all sub entries."
999 (let* ((entity-name (wl-folder-get-entity-from-buffer))
1000 (group (wl-folder-buffer-group-p))
1001 (desktop (string= entity-name wl-folder-desktop-name)))
1003 (wl-folder-check-entity
1005 (wl-folder-search-group-entity-by-name entity-name
1010 (defun wl-folder-sync-entity (entity &optional unread-only)
1011 "Synchronize the msgdb of ENTITY."
1014 (let ((flist (nth 2 entity)))
1016 (wl-folder-sync-entity (car flist) unread-only)
1017 (setq flist (cdr flist)))))
1019 (let* ((folder (wl-folder-get-elmo-folder entity))
1020 (nums (wl-folder-get-entity-info entity))
1021 (wl-summary-highlight (if (or (wl-summary-sticky-p folder)
1022 (wl-summary-always-sticky-folder-p
1024 wl-summary-highlight))
1025 wl-auto-select-first new unread sticky)
1026 (setq new (or (car nums) 0))
1027 (setq unread (or (cadr nums) 0))
1028 (if (or (not unread-only)
1029 (or (< 0 new) (< 0 unread)))
1030 (let ((wl-summary-buffer-name
1031 (if (setq sticky (get-buffer (wl-summary-sticky-buffer-name
1032 (elmo-folder-name-internal
1034 ;; Sticky folder exists.
1035 (wl-summary-sticky-buffer-name
1036 (elmo-folder-name-internal folder))
1038 wl-summary-buffer-name
1039 (symbol-name this-command))))
1040 (wl-summary-use-frame nil)
1041 (wl-summary-always-sticky-folder-list nil))
1042 (save-window-excursion
1044 (wl-summary-goto-folder-subr entity
1045 (wl-summary-get-sync-range
1049 (wl-summary-save-status)
1050 (wl-summary-exit))))))))))
1052 (defun wl-folder-sync-current-entity (&optional unread-only)
1053 "Synchronize the folder at position.
1054 If current line is group folder, check all subfolders."
1057 (let ((entity-name (wl-folder-get-entity-from-buffer))
1058 (group (wl-folder-buffer-group-p)))
1059 (when (and entity-name
1060 (y-or-n-p (format "Sync %s? " entity-name)))
1061 (wl-folder-sync-entity
1063 (wl-folder-search-group-entity-by-name entity-name
1067 (message "Syncing %s is done!" entity-name)))))
1069 (defun wl-folder-mark-as-read-all-entity (entity)
1070 "Mark as read all messages in the ENTITY."
1073 (let ((flist (nth 2 entity)))
1075 (wl-folder-mark-as-read-all-entity (car flist))
1076 (setq flist (cdr flist)))))
1078 (let* ((nums (wl-folder-get-entity-info entity))
1079 (folder (wl-folder-get-elmo-folder entity))
1080 (wl-summary-highlight (if (or (wl-summary-sticky-p folder)
1081 (wl-summary-always-sticky-folder-p
1083 wl-summary-highlight))
1084 wl-auto-select-first new unread sticky)
1085 (setq new (or (car nums) 0))
1086 (setq unread (or (cadr nums) 0))
1087 (if (or (< 0 new) (< 0 unread))
1088 (save-window-excursion
1090 (let ((wl-summary-buffer-name
1091 (if (setq sticky (get-buffer
1092 (wl-summary-sticky-buffer-name
1093 (elmo-folder-name-internal
1095 ;; Sticky folder exists.
1096 (wl-summary-sticky-buffer-name
1097 (elmo-folder-name-internal folder))
1099 wl-summary-buffer-name
1100 (symbol-name this-command))))
1101 (wl-summary-use-frame nil)
1102 (wl-summary-always-sticky-folder-list nil))
1103 (wl-summary-goto-folder-subr entity
1104 (wl-summary-get-sync-range folder)
1106 (wl-summary-mark-as-read-all)
1108 (wl-summary-save-status)
1109 (wl-summary-exit)))))
1112 (defun wl-folder-mark-as-read-all-current-entity ()
1113 "Mark as read all messages in the folder at position.
1114 If current line is group folder, all subfolders are marked."
1117 (let ((entity-name (wl-folder-get-entity-from-buffer))
1118 (group (wl-folder-buffer-group-p))
1120 (when (and entity-name
1121 (y-or-n-p (format "Mark all messages in %s as read? "
1123 (wl-folder-mark-as-read-all-entity
1125 (wl-folder-search-group-entity-by-name entity-name
1128 (message "All messages in %s are marked!" entity-name)))))
1130 (defun wl-folder-check-region (beg end)
1139 (let ((inhibit-read-only t)
1141 (while (< (point) end)
1142 ;; normal folder entity
1143 (if (looking-at "^[\t ]*\\([^\\[]+\\):\\(.*\\)\n")
1145 (setq entity (wl-folder-get-entity-from-buffer))
1146 (if (not (elmo-folder-plugged-p (wl-folder-get-elmo-folder
1148 (message "Uncheck %s" entity)
1149 (message "Checking %s" entity)
1150 (wl-folder-check-one-entity entity)
1155 (defun wl-folder-sync-region (beg end)
1164 (while (< (point) end)
1165 ;; normal folder entity
1166 (if (looking-at "^[\t ]*\\([^\\[]+\\):\\(.*\\)\n")
1168 (let ((inhibit-read-only t)
1170 (setq entity (wl-folder-get-entity-from-buffer))
1171 (wl-folder-sync-entity entity)
1172 (message "Syncing %s is done!" entity)
1177 (defun wl-folder-mark-as-read-all-region (beg end)
1186 (while (< (point) end)
1187 ;; normal folder entity
1188 (if (looking-at "^[\t ]*\\([^\\[]+\\):\\(.*\\)\n")
1190 (let ((inhibit-read-only t)
1192 (setq entity (wl-folder-get-entity-from-buffer))
1193 (wl-folder-mark-as-read-all-entity entity)
1194 (message "All messages in %s are marked!" entity)
1199 (defsubst wl-create-access-init-load-p (folder)
1200 (let ((no-load-regexp (when (and
1201 (not wl-folder-init-load-access-folders)
1202 wl-folder-init-no-load-access-folders)
1203 (mapconcat 'identity
1204 wl-folder-init-no-load-access-folders
1206 (load-regexp (and wl-folder-init-load-access-folders
1207 (mapconcat 'identity
1208 wl-folder-init-load-access-folders
1210 (cond (load-regexp (string-match load-regexp folder))
1211 (t (not (and no-load-regexp
1212 (string-match no-load-regexp folder)))))))
1214 (defun wl-create-access-folder-entity (name)
1216 (when (wl-create-access-init-load-p name)
1217 (setq flists (elmo-msgdb-flist-load name)) ; load flist.
1218 (setq flist (car flists))
1220 (when (consp (car flist))
1221 (setcdr (cdar flist)
1222 (wl-create-access-folder-entity (caar flist))))
1223 (setq flist (cdr flist)))
1226 (defun wl-create-folder-entity-from-buffer ()
1227 "Create folder entity recursively."
1229 ((looking-at "^[ \t]*$") ; blank line
1230 (goto-char (+ 1(match-end 0)))
1232 ((looking-at "^#.*$") ; comment
1233 (goto-char (+ 1 (match-end 0)))
1235 ((looking-at "^[\t ]*\\(.+\\)[\t ]*{[\t ]*$") ; group definition
1236 (let (name entity flist)
1237 (setq name (wl-match-buffer 1))
1238 (goto-char (+ 1 (match-end 0)))
1239 (while (setq entity (wl-create-folder-entity-from-buffer))
1240 (unless (eq entity 'ignore)
1241 (wl-append flist (list entity))))
1242 (if (looking-at "^[\t ]*}[\t ]*$") ; end of group
1244 (goto-char (+ 1 (match-end 0)))
1245 (if (wl-string-assoc name wl-folder-petname-alist)
1246 (error "%s already defined as petname" name))
1247 (list name 'group flist))
1248 (error "Syntax error in folder definition"))))
1249 ((looking-at "^[\t ]*\\([^\t \n]+\\)[\t ]*/$") ; access it!
1251 (setq name (wl-match-buffer 1))
1252 (goto-char (+ 1 (match-end 0)))
1253 ; (condition-case ()
1255 ; (setq flist (elmo-list-folders name)))
1256 ; (error (message "Access to folder %s failed." name)))
1257 ;; (setq flist (elmo-msgdb-flist-load name)) ; load flist.
1258 ;; (setq unsublist (nth 1 flist))
1259 ;; (setq flist (car flist))
1260 ;; (list name 'access flist unsublist)))
1261 (append (list name 'access) (wl-create-access-folder-entity name))))
1262 ;((looking-at "^[\t ]*\\([^\t \n}]+\\)[\t ]*\\(\"[^\"]*\"\\)?[\t ]*$") ; normal folder entity
1263 ((looking-at "^[\t ]*=[ \t]+\\([^\n]+\\)$"); petname definition
1264 (goto-char (+ 1 (match-end 0)))
1265 (let ((rest (elmo-match-buffer 1))
1267 (when (string-match "\\(\"[^\"]*\"\\)[\t ]*$" rest)
1268 (setq petname (elmo-delete-char ?\" (elmo-match-string 1 rest)))
1269 (setq rest (substring rest 0 (match-beginning 0))))
1270 (when (string-match "^[\t ]*\\(.*[^\t ]+\\)[\t ]+$" rest)
1271 (wl-folder-append-petname (elmo-match-string 1 rest)
1274 ((looking-at "^[ \t]*}[ \t]*$") ; end of group
1276 ((looking-at "^.*$") ; normal folder entity
1277 (goto-char (+ 1 (match-end 0)))
1278 (let ((rest (elmo-match-buffer 0))
1280 (if (string-match "\\(\"[^\"]*\"\\)[\t ]*$" rest)
1282 (setq petname (elmo-delete-char ?\" (elmo-match-string 1 rest)))
1283 (setq rest (substring rest 0 (match-beginning 0)))
1284 (when (string-match "^[\t ]*\\(.*[^\t ]+\\)[\t ]+$" rest)
1285 (wl-folder-append-petname
1286 (setq realname (elmo-match-string 1 rest))
1289 (if (string-match "^[\t ]*\\(.+\\)$" rest)
1290 (elmo-match-string 1 rest)
1293 (defun wl-folder-create-folder-entity ()
1294 "Create folder entries."
1295 (let ((tmp-buf (get-buffer-create " *wl-folder-tmp*"))
1299 (with-current-buffer tmp-buf
1301 (insert-file-contents wl-folders-file)
1302 (goto-char (point-min))
1303 (while (and (not (eobp))
1304 (setq entity (wl-create-folder-entity-from-buffer)))
1305 (unless (eq entity 'ignore)
1306 (wl-append ret-val (list entity)))))
1307 (kill-buffer tmp-buf))
1309 (setq ret-val (list wl-folder-desktop-name 'group ret-val))))
1311 (defun wl-folder-entity-assign-id (entity &optional hashtb on-noid)
1312 (let ((hashtb (or hashtb
1313 (setq wl-folder-entity-id-name-hashtb
1314 (elmo-make-hash wl-folder-entity-id))))
1315 (entities (list entity))
1318 (setq entity (wl-pop entities))
1321 (when (not (and on-noid
1322 (get-text-property 0
1323 'wl-folder-entity-id
1325 (wl-folder-put-folder-property
1326 0 (length (car entity))
1330 (wl-folder-set-id-name wl-folder-entity-id
1331 (car entity) hashtb))
1333 (wl-push entities entity-stack))
1334 (setq entities (nth 2 entity)))
1336 (when (not (and on-noid
1337 (get-text-property 0
1338 'wl-folder-entity-id
1340 (wl-folder-put-folder-property
1345 (wl-folder-set-id-name wl-folder-entity-id
1347 (setq wl-folder-entity-id (+ 1 wl-folder-entity-id))
1349 (setq entities (wl-pop entity-stack))))))
1351 (defun wl-folder-click (e)
1356 (wl-folder-jump-to-current-entity)))
1358 (defun wl-folder-select-buffer (buffer)
1359 (let ((gbw (get-buffer-window buffer))
1362 (progn (select-window gbw)
1364 (unless wl-summary-use-frame
1367 (split-window-horizontally wl-folder-window-width)
1371 (if wl-summary-use-frame
1372 (switch-to-buffer-other-frame buffer)
1373 (switch-to-buffer buffer))
1376 (defun wl-folder-toggle-disp-summary (&optional arg folder)
1378 (if (or (and folder (assoc folder wl-folder-group-alist))
1379 (and (interactive-p) (wl-folder-buffer-group-p)))
1380 (error "This command is not available on Group"))
1382 (let (wl-auto-select-first
1383 (wl-stay-folder-window t))
1386 (setq wl-folder-buffer-disp-summary t))
1388 (setq wl-folder-buffer-disp-summary nil)
1389 ;; hide wl-summary window.
1390 (let ((cur-buf (current-buffer))
1391 (summary-buffer (wl-summary-get-buffer folder)))
1392 (wl-folder-select-buffer summary-buffer)
1394 (select-window (get-buffer-window cur-buf))))
1396 (setq wl-folder-buffer-disp-summary
1397 (not wl-folder-buffer-disp-summary))
1398 (let ((cur-buf (current-buffer))
1400 (when (looking-at "^[ ]*\\([^\\[].+\\):.*\n")
1401 (setq folder-name (wl-folder-get-entity-from-buffer))
1402 (if wl-folder-buffer-disp-summary
1404 (wl-folder-select-buffer
1405 (wl-summary-get-buffer-create folder-name))
1407 (wl-summary-goto-folder-subr folder-name 'no-sync nil)
1408 (select-window (get-buffer-window cur-buf))))
1409 (wl-folder-select-buffer (wl-summary-get-buffer folder-name))
1411 (select-window (get-buffer-window cur-buf)))))))))
1413 (defun wl-folder-prev-unsync ()
1414 "Move cursor to the previous unsync folder."
1417 (setq start-point (point))
1419 (if (re-search-backward wl-folder-unsync-regexp nil t)
1421 (goto-char start-point)
1422 (message "No more unsync folder"))))
1424 (defun wl-folder-next-unsync (&optional plugged)
1425 "Move cursor to the next unsync."
1427 (let (start-point entity)
1428 (setq start-point (point))
1431 (while (re-search-forward wl-folder-unsync-regexp nil t)
1432 (if (or (wl-folder-buffer-group-p)
1435 (wl-folder-get-entity-from-buffer))
1436 (elmo-folder-plugged-p entity))
1439 (goto-char start-point)
1440 (message "No more unsync folder"))))
1442 (defun wl-folder-prev-unread (&optional group)
1443 "Move cursor to the previous unread folder."
1446 (setq start-point (point))
1448 (if (re-search-backward (wl-folder-unread-regex group) nil t)
1451 (wl-folder-get-entity-from-buffer))
1452 (goto-char start-point)
1453 (message "No more unread folder")
1456 (defun wl-folder-next-unread (&optional group)
1457 "Move cursor to the next unread folder."
1460 (setq start-point (point))
1462 (if (re-search-forward (wl-folder-unread-regex group) nil t)
1465 (wl-folder-get-entity-from-buffer))
1466 (goto-char start-point)
1467 (message "No more unread folder")
1470 (defun wl-folder-mode ()
1471 "Major mode for Wanderlust Folder.
1472 See Info under Wanderlust for full documentation.
1475 \\{wl-folder-mode-map}
1477 Entering Folder mode calls the value of `wl-folder-mode-hook'."
1479 (setq major-mode 'wl-folder-mode)
1480 (setq mode-name "Folder")
1481 (use-local-map wl-folder-mode-map)
1482 (setq buffer-read-only t)
1483 (setq inhibit-read-only nil)
1484 (setq truncate-lines t)
1485 (setq wl-folder-buffer-cur-entity-id nil
1486 wl-folder-buffer-cur-path nil
1487 wl-folder-buffer-cur-point nil)
1488 (wl-mode-line-buffer-identification)
1489 (easy-menu-add wl-folder-mode-menu)
1490 ;; This hook may contain the functions `wl-folder-init-icons' and
1491 ;; `wl-setup-folder' for reasons of system internal to accord
1492 ;; facilities for the Emacs variants.
1493 (run-hooks 'wl-folder-mode-hook))
1495 (defun wl-folder-append-petname (realname petname)
1497 ;; check group name.
1498 (if (wl-folder-search-group-entity-by-name petname wl-folder-entity)
1499 (error "%s already defined as group name" petname))
1500 (when (setq pentry (wl-string-assoc realname wl-folder-petname-alist))
1501 (setq wl-folder-petname-alist
1502 (delete pentry wl-folder-petname-alist)))
1503 (wl-append wl-folder-petname-alist
1504 (list (cons realname petname)))))
1506 (defun wl-folder (&optional arg)
1508 (let (initialize folder-buf)
1509 (if (setq folder-buf (get-buffer wl-folder-buffer-name))
1510 (if wl-folder-use-frame
1512 (save-selected-window
1513 (dolist (frame (visible-frame-list))
1514 (select-frame frame)
1515 (if (get-buffer-window folder-buf)
1516 (setq select-frame frame))))
1518 (select-frame select-frame)
1519 (switch-to-buffer folder-buf)))
1520 (switch-to-buffer folder-buf))
1521 (if wl-folder-use-frame
1523 (switch-to-buffer-other-frame
1524 (get-buffer-create wl-folder-buffer-name))
1525 (let ((frame (selected-frame)))
1526 (setq wl-delete-startup-frame-function
1528 (setq wl-delete-startup-frame-function nil)
1529 (let ((frame ,frame))
1530 (if (eq (selected-frame) frame)
1531 (delete-frame frame)))))))
1532 (switch-to-buffer (get-buffer-create wl-folder-buffer-name)))
1533 (set-buffer wl-folder-buffer-name)
1536 (setq wl-folder-entity-id 0)
1537 (wl-folder-entity-assign-id wl-folder-entity)
1538 (setq wl-folder-entity-hashtb
1539 (wl-folder-create-entity-hashtb wl-folder-entity))
1540 (setq wl-folder-elmo-folder-hashtb (elmo-make-hash wl-folder-entity-id))
1541 (setq wl-folder-group-alist
1542 (wl-folder-create-group-alist wl-folder-entity))
1543 (setq wl-folder-newsgroups-hashtb
1544 (wl-folder-create-newsgroups-hashtb wl-folder-entity))
1545 (wl-folder-init-info-hashtb)
1546 (let ((inhibit-read-only t)
1547 (buffer-read-only nil))
1549 (setcdr (assoc (car wl-folder-entity) wl-folder-group-alist) t)
1551 (wl-folder-insert-entity " " wl-folder-entity)))
1553 (set-buffer-modified-p nil)
1554 (setq initialize t))
1557 (defun wl-folder-auto-check ()
1558 "Check and update folders in `wl-auto-check-folder-name'."
1560 (when (get-buffer wl-folder-buffer-name)
1561 (switch-to-buffer wl-folder-buffer-name)
1563 ((eq wl-auto-check-folder-name 'none))
1564 ((or (consp wl-auto-check-folder-name)
1565 (stringp wl-auto-check-folder-name))
1566 (let ((folder-list (if (consp wl-auto-check-folder-name)
1567 wl-auto-check-folder-name
1568 (list wl-auto-check-folder-name)))
1571 (if (setq entity (wl-folder-search-entity-by-name
1574 (wl-folder-check-entity entity 'auto))
1575 (setq folder-list (cdr folder-list)))))
1577 (wl-folder-check-entity wl-folder-entity 'auto)))))
1579 (defun wl-folder-set-folder-updated (name value)
1582 (if (setq buf (get-buffer wl-folder-buffer-name))
1583 (wl-folder-entity-hashtb-set
1584 wl-folder-entity-hashtb name value buf))
1585 (setq wl-folder-info-alist-modified t))))
1587 (defun wl-folder-calc-finfo (entity)
1588 ;; calcurate finfo without inserting.
1589 (let ((entities (list entity))
1591 new unread all nums)
1593 (setq entity (wl-pop entities))
1597 (wl-push entities entity-stack))
1598 (setq entities (nth 2 entity)))
1600 (setq nums (wl-folder-get-entity-info entity))
1601 (setq new (+ (or new 0) (or (nth 0 nums) 0)))
1602 (setq unread (+ (or unread 0)
1603 (or (and (nth 0 nums)(nth 1 nums)
1604 (+ (nth 0 nums)(nth 1 nums))) 0)))
1605 (setq all (+ (or all 0) (or (nth 2 nums) 0)))))
1607 (setq entities (wl-pop entity-stack))))
1608 (list new unread all)))
1610 (defsubst wl-folder-make-save-access-list (list)
1611 (mapcar '(lambda (x)
1614 (list (elmo-string (car x)) 'access))
1619 (defun wl-folder-update-newest (indent entity)
1620 (let (ret-val new unread all)
1623 (let ((inhibit-read-only t)
1624 (buffer-read-only nil)
1625 (flist (nth 2 entity))
1626 (as-opened (cdr (assoc (car entity) wl-folder-group-alist)))
1631 (let (update-flist flist-unsub new-flist removed group-name-end)
1632 (when (and (eq (cadr entity) 'access)
1633 (elmo-folder-plugged-p
1634 (wl-folder-get-elmo-folder (car entity))))
1635 (message "Fetching folder entries...")
1636 (when (setq new-flist
1637 (elmo-folder-list-subfolders
1638 (wl-folder-get-elmo-folder (car entity))
1639 (wl-string-match-member
1641 wl-folder-hierarchy-access-folders)))
1643 (wl-folder-update-access-group entity new-flist))
1644 (setq flist (nth 1 update-flist))
1645 (when (car update-flist) ;; diff
1646 (setq flist-unsub (nth 2 update-flist))
1647 (setq removed (nth 3 update-flist))
1648 (elmo-msgdb-flist-save
1651 (wl-folder-make-save-access-list flist)
1652 (wl-folder-make-save-access-list flist-unsub)))
1653 (wl-folder-entity-assign-id
1655 wl-folder-entity-id-name-hashtb
1657 (setq wl-folder-entity-hashtb
1658 (wl-folder-create-entity-hashtb
1660 wl-folder-entity-hashtb
1662 (setq wl-folder-newsgroups-hashtb
1664 (wl-folder-create-newsgroups-hashtb
1666 wl-folder-newsgroups-hashtb))))
1667 (message "Fetching folder entries...done"))
1668 (wl-folder-insert-entity indent entity))))))))
1670 (defun wl-folder-insert-entity (indent entity &optional onlygroup)
1671 (let (ret-val new unread all)
1674 (let ((inhibit-read-only t)
1675 (buffer-read-only nil)
1676 (flist (nth 2 entity))
1677 (as-opened (cdr (assoc (car entity) wl-folder-group-alist)))
1680 ;;; (insert indent "[" (if as-opened "-" "+") "]" (car entity) "\n")
1681 ;;; (save-excursion (forward-line -1)
1682 ;;; (wl-highlight-folder-current-line))
1686 (let (update-flist flist-unsub new-flist removed group-name-end)
1687 ;;; (when (and (eq (cadr entity) 'access)
1689 ;;; (message "fetching folder entries...")
1690 ;;; (when (setq new-flist
1691 ;;; (elmo-list-folders
1692 ;;; (elmo-string (car entity))
1693 ;;; (wl-string-member
1695 ;;; wl-folder-hierarchy-access-folders)
1697 ;;; (setq update-flist
1698 ;;; (wl-folder-update-access-group entity new-flist))
1699 ;;; (setq flist (nth 1 update-flist))
1700 ;;; (when (car update-flist) ;; diff
1701 ;;; (setq flist-unsub (nth 2 update-flist))
1702 ;;; (setq removed (nth 3 update-flist))
1703 ;;; (elmo-msgdb-flist-save
1706 ;;; (wl-folder-make-save-access-list flist)
1707 ;;; (wl-folder-make-save-access-list flist-unsub)))
1709 ;;; ;; reconstruct wl-folder-entity-id-name-hashtb and
1710 ;;; ;; wl-folder-entity-hashtb
1712 ;;; (wl-folder-entity-assign-id
1714 ;;; wl-folder-entity-id-name-hashtb
1716 ;;; (setq wl-folder-entity-hashtb
1717 ;;; (wl-folder-create-entity-hashtb
1719 ;;; wl-folder-entity-hashtb
1721 ;;; (setq wl-folder-newsgroups-hashtb
1723 ;;; (wl-folder-create-newsgroups-hashtb
1725 ;;; wl-folder-newsgroups-hashtb))))
1726 ;;; (message "fetching folder entries...done"))
1727 (insert indent "[" (if as-opened "-" "+") "]"
1728 (if (eq (cadr entity) 'access)
1729 (wl-folder-get-petname (car entity))
1731 (setq group-name-end (point))
1733 (wl-folder-put-folder-property
1735 (get-text-property 0 'wl-folder-entity-id (car entity))
1741 wl-folder-removed-mark
1742 (if (listp (car removed))
1743 (concat "[+]" (caar removed))
1746 (save-excursion (forward-line -1)
1747 (wl-highlight-folder-current-line))
1748 (setq removed (cdr removed)))
1749 (remove-text-properties beg (point) '(wl-folder-entity-id)))
1750 (let* ((len (length flist))
1755 (wl-folder-insert-entity
1756 (concat indent " ") (car flist)))
1757 (setq new (+ (or new 0) (or (nth 0 ret-val) 0)))
1758 (setq unread (+ (or unread 0) (or (nth 1 ret-val) 0)))
1759 (setq all (+ (or all 0) (or (nth 2 ret-val) 0)))
1761 (> len elmo-display-progress-threshold))
1763 (elmo-display-progress
1764 'wl-folder-insert-entity "Inserting group %s..."
1765 (/ (* i 100) len) (car entity)))
1766 (setq flist (cdr flist)))
1768 (message "Inserting group %s...done" (car entity))))
1770 (goto-char group-name-end)
1771 (delete-region (point) (save-excursion (end-of-line)
1773 (insert (format ":%d/%d/%d" (or new 0)
1774 (or unread 0) (or all 0)))
1775 (setq ret-val (list new unread all))
1776 (wl-highlight-folder-current-line ret-val)))
1777 (setq ret-val (wl-folder-calc-finfo entity))
1778 (insert indent "[" (if as-opened "-" "+") "]"
1779 (if (eq (cadr entity) 'access)
1780 (wl-folder-get-petname (car entity))
1783 (or (nth 0 ret-val) 0)
1784 (or (nth 1 ret-val) 0)
1785 (or (nth 2 ret-val) 0))
1787 (wl-folder-put-folder-property
1789 (get-text-property 0 'wl-folder-entity-id (car entity))
1791 (save-excursion (forward-line -1)
1792 (wl-highlight-folder-current-line ret-val)))))
1794 (let* ((inhibit-read-only t)
1795 (buffer-read-only nil)
1796 (nums (wl-folder-get-entity-info entity))
1799 (insert indent (wl-folder-get-petname entity)
1800 (format ":%s/%s/%s\n"
1801 (or (setq new (nth 0 nums)) "*")
1802 (or (setq unread (and (nth 0 nums)(nth 1 nums)
1803 (+ (nth 0 nums)(nth 1 nums))))
1805 (or (setq all (nth 2 nums)) "*")))
1806 (wl-folder-put-folder-property
1808 (get-text-property 0 'wl-folder-entity-id entity)
1810 (save-excursion (forward-line -1)
1811 (wl-highlight-folder-current-line nums))
1812 (setq ret-val (list new unread all)))))
1813 (set-buffer-modified-p nil)
1816 (defun wl-folder-check-all ()
1818 (wl-folder-check-entity wl-folder-entity))
1820 (defun wl-folder-entity-hashtb-set (entity-hashtb name value buffer)
1821 (let ((cur-val (wl-folder-get-entity-info name entity-hashtb))
1826 (setq new-diff (- (or (nth 0 value) 0) (or (nth 0 cur-val) 0)))
1829 (- (or (nth 1 value) 0) (or (nth 1 cur-val) 0))))
1830 (setq all-diff (- (or (nth 2 value) 0) (or (nth 2 cur-val) 0)))
1831 (setq diffs (list new-diff unread-diff all-diff))
1832 (unless (and (nth 0 cur-val)
1833 (equal diffs '(0 0 0)))
1834 (wl-folder-set-entity-info name value entity-hashtb)
1836 (with-current-buffer buffer
1838 (let ((entity-list (wl-folder-search-entity-list-by-name
1839 name wl-folder-entity)))
1841 (wl-folder-update-group (car entity-list) diffs)
1842 (setq entity-list (cdr entity-list))))
1843 (goto-char (point-min))
1844 (while (wl-folder-buffer-search-entity name)
1845 (wl-folder-update-line value))))))))
1847 (defun wl-folder-update-unread (folder unread)
1848 (let ((buf (get-buffer wl-folder-buffer-name))
1849 (value (wl-folder-get-entity-info folder))
1853 ;;; Update folder-info
1854 ;;; (elmo-folder-set-info-hashtb fld nil nil nil unread)
1855 (setq cur-unread (or (nth 1 value) 0))
1856 (setq unread-diff (- (or unread 0) cur-unread))
1857 (setq newvalue (list (nth 0 value)
1860 (wl-folder-set-entity-info folder newvalue)
1861 (setq wl-folder-info-alist-modified t)
1863 (not (eq unread-diff 0)))
1865 (with-current-buffer buf
1867 (let ((entity-list (wl-folder-search-entity-list-by-name
1868 folder wl-folder-entity)))
1870 (wl-folder-update-group (car entity-list) (list 0
1873 (setq entity-list (cdr entity-list))))
1874 (goto-char (point-min))
1875 (while (wl-folder-buffer-search-entity folder)
1876 (wl-folder-update-line newvalue))))))))
1878 (defun wl-folder-create-entity-hashtb (entity &optional hashtb reconst)
1879 (let ((hashtb (or hashtb (elmo-make-hash wl-folder-entity-id)))
1880 (entities (list entity))
1883 (setq entity (wl-pop entities))
1887 (wl-push entities entity-stack))
1888 (setq entities (nth 2 entity)))
1890 (when (not (and reconst
1891 (wl-folder-get-entity-info entity)))
1892 (wl-folder-set-entity-info entity
1896 (setq entities (wl-pop entity-stack))))
1899 ;; Unsync number is reserved.
1900 ;;(defun wl-folder-reconstruct-entity-hashtb (entity &optional hashtb id-name)
1901 ;; (let* ((hashtb (or hashtb (elmo-make-hash wl-folder-entity-id)))
1902 ;; (entities (list entity))
1905 ;; (setq entity (wl-pop entities))
1909 ;; (wl-folder-set-id-name (wl-folder-get-entity-id (car entity))
1912 ;; (wl-push entities entity-stack))
1913 ;; (setq entities (nth 2 entity))
1915 ;; ((stringp entity)
1916 ;; (wl-folder-set-entity-info entity
1917 ;; (wl-folder-get-entity-info entity)
1920 ;; (wl-folder-set-id-name (wl-folder-get-entity-id entity)
1923 ;; (setq entities (wl-pop entity-stack))))
1926 (defun wl-folder-create-newsgroups-from-nntp-access (entity)
1927 (let ((flist (nth 2 entity))
1932 ((consp (car flist))
1933 (wl-folder-create-newsgroups-from-nntp-access (car flist)))
1936 (elmo-nntp-folder-group-internal
1937 (wl-folder-get-elmo-folder (car flist)))))))
1938 (setq flist (cdr flist)))
1941 (defun wl-folder-create-newsgroups-hashtb (entity &optional is-list info)
1942 "Create NNTP group hashtable for ENTITY."
1943 (let ((entities (if is-list entity (list entity)))
1944 entity-stack folder-list newsgroups newsgroup make-hashtb)
1945 (and info (message "Creating newsgroups..."))
1947 (setq entity (wl-pop entities))
1950 (if (eq (nth 1 entity) 'access)
1951 (when (eq (elmo-folder-type-internal
1952 (elmo-make-folder (car entity))) 'nntp)
1953 (wl-append newsgroups
1954 (wl-folder-create-newsgroups-from-nntp-access entity))
1955 (setq make-hashtb t))
1957 (wl-push entities entity-stack))
1958 (setq entities (nth 2 entity))))
1960 (setq folder-list (elmo-folder-get-primitive-list
1961 (elmo-make-folder entity)))
1963 (when (and (eq (elmo-folder-type-internal (car folder-list))
1965 (setq newsgroup (elmo-nntp-folder-group-internal
1966 (car folder-list))))
1967 (wl-append newsgroups (list (elmo-string newsgroup))))
1968 (setq folder-list (cdr folder-list)))))
1970 (setq entities (wl-pop entity-stack))))
1971 (and info (message "Creating newsgroups...done"))
1972 (if (or newsgroups make-hashtb)
1973 (elmo-setup-subscribed-newsgroups newsgroups))))
1975 (defun wl-folder-get-path (entity target-id &optional string)
1976 (let ((entities (list entity))
1977 entity-stack result-path)
1981 (setq entity (wl-pop entities))
1984 (if (and (or (not string) (string= string (car entity)))
1985 (eq target-id (wl-folder-get-entity-id (car entity))))
1987 (wl-push target-id result-path))
1988 (wl-push (wl-folder-get-entity-id (car entity)) result-path))
1989 (wl-push entities entity-stack)
1990 (setq entities (nth 2 entity)))
1992 (if (and (or (not string) (string= string entity))
1993 (eq target-id (wl-folder-get-entity-id entity)))
1995 (wl-push target-id result-path)))))
1997 (while (and entity-stack
1999 (setq result-path (cdr result-path))
2000 (setq entities (wl-pop entity-stack)))))))))
2002 (defun wl-folder-create-group-alist (entity)
2004 (let ((flist (nth 2 entity))
2005 (cur-alist (list (cons (car entity) nil)))
2008 (if (consp (car flist))
2009 (wl-append append-alist
2010 (wl-folder-create-group-alist (car flist))))
2011 (setq flist (cdr flist)))
2012 (append cur-alist append-alist))))
2014 (defun wl-folder-init-info-hashtb ()
2015 (let ((info-alist (and wl-folder-info-save
2016 (elmo-msgdb-finfo-load))))
2017 (elmo-folder-info-make-hashtb
2019 wl-folder-entity-hashtb)))
2020 ;;; (wl-folder-resume-entity-hashtb-by-finfo
2021 ;;; wl-folder-entity-hashtb
2024 (defun wl-folder-cleanup-variables ()
2025 (setq wl-folder-entity nil
2026 wl-folder-entity-hashtb nil
2027 wl-folder-entity-id-name-hashtb nil
2028 wl-folder-group-alist nil
2029 wl-folder-petname-alist nil
2030 wl-folder-newsgroups-hashtb nil
2031 wl-fldmgr-cut-entity-list nil
2032 wl-fldmgr-modified nil
2033 wl-fldmgr-modified-access-list nil
2037 (defun wl-make-plugged-alist ()
2038 (let ((entity-list (wl-folder-get-entity-list wl-folder-entity))
2039 (add (not wl-reset-plugged-alist)))
2041 (elmo-folder-set-plugged
2042 (wl-folder-get-elmo-folder (car entity-list)) wl-plugged add)
2043 (setq entity-list (cdr entity-list)))
2044 ;; smtp posting server
2045 (when wl-smtp-posting-server
2046 (elmo-set-plugged wl-plugged
2047 wl-smtp-posting-server ; server
2048 (or (and (boundp 'smtp-service) smtp-service)
2050 wl-smtp-connection-type
2051 nil nil "smtp" add))
2052 ;; nntp posting server
2053 (when wl-nntp-posting-server
2054 (elmo-set-plugged wl-plugged
2055 wl-nntp-posting-server
2056 wl-nntp-posting-stream-type
2057 wl-nntp-posting-port
2058 nil nil "nntp" add))
2059 (run-hooks 'wl-make-plugged-hook)))
2061 (defvar wl-folder-init-function 'wl-local-folder-init)
2063 (defun wl-folder-init ()
2064 "Return top-level folder entity."
2068 (funcall wl-folder-init-function))
2069 (run-hooks 'wl-folder-init-hook))
2071 (defun wl-local-folder-init ()
2072 "Initialize local folder."
2073 (message "Initializing folder...")
2074 (setq wl-folder-entity (wl-folder-create-folder-entity))
2075 (message "Initializing folder...done"))
2077 (defun wl-folder-get-realname (petname)
2081 wl-folder-petname-alist))
2084 (defun wl-folder-get-petname (name)
2088 wl-folder-petname-alist))
2091 (defun wl-folder-get-entity-with-petname ()
2092 (let ((alist wl-folder-petname-alist)
2093 (hashtb (copy-sequence wl-folder-entity-hashtb)))
2095 (wl-folder-set-entity-info (cdar alist) nil hashtb)
2096 (setq alist (cdr alist)))
2099 (defun wl-folder-get-newsgroups (folder)
2100 "Return Newsgroups field value string for FOLDER newsgroup.
2101 If FOLDER is multi, return comma separated string (cross post)."
2102 (let ((nlist (elmo-folder-newsgroups
2103 (wl-folder-get-elmo-folder folder))))
2105 (list nil nil (mapconcat 'identity nlist ","))
2108 (defun wl-folder-guess-mailing-list-by-refile-rule (entity)
2109 "Return ML address guess by ENTITY.
2110 Use `wl-subscribed-mailing-list' and `wl-refile-rule-alist'."
2112 (elmo-folder-get-primitive-list
2113 (wl-folder-get-elmo-folder entity)))
2115 (while (setq fld (car flist))
2116 (setq mladdr (wl-folder-guess-mailing-list-by-refile-rule-subr
2117 (elmo-folder-name-internal fld)))
2119 (setq to (if (stringp to)
2120 (concat to ", " mladdr)
2122 (setq flist (cdr flist)))
2127 (defun wl-folder-guess-mailing-list-by-refile-rule-subr (entity)
2128 (unless (memq (elmo-folder-type entity)
2130 (let ((rules wl-refile-rule-alist)
2133 (if (or (and (stringp (car (car rules)))
2134 (string-match "[Tt]o" (car (car rules))))
2135 (and (listp (car (car rules)))
2136 (elmo-string-matched-member "to" (car (car rules))
2138 (setq toalist (append toalist (cdr (car rules)))))
2139 (setq rules (cdr rules)))
2140 (setq tokey (car (rassoc entity toalist)))
2141 ;;; (setq histkey (car (rassoc folder wl-refile-alist)))
2142 ;; case-ignore search `wl-subscribed-mailing-list'
2144 (elmo-string-matched-member tokey wl-subscribed-mailing-list t)))))
2146 (defun wl-folder-guess-mailing-list-by-folder-name (entity)
2147 "Return ML address guess by ENTITY name's last hierarchy.
2148 Use `wl-subscribed-mailing-list'."
2150 (elmo-folder-get-primitive-list
2151 (wl-folder-get-elmo-folder entity)))
2153 (while (setq fld (car flist))
2154 (setq mladdr (wl-folder-guess-mailing-list-by-folder-name-subr
2155 (elmo-folder-name-internal fld)))
2157 (setq to (if (stringp to)
2158 (concat to ", " mladdr)
2160 (setq flist (cdr flist)))
2165 (defun wl-folder-guess-mailing-list-by-folder-name-subr (entity)
2166 (when (memq (elmo-folder-type entity)
2167 '(localdir imap4 maildir))
2168 (let (key foldername)
2169 ;; Get foldername and Remove folder type symbol.
2170 (setq foldername (substring entity 1))
2171 (if (string-match "@" foldername)
2172 (setq foldername (substring foldername 0 (match-beginning 0))))
2173 (when (string-match "[^\\./]+$" foldername)
2174 (setq key (regexp-quote
2175 (concat (substring foldername (match-beginning 0)) "@")))
2176 (elmo-string-matched-member
2177 key wl-subscribed-mailing-list 'case-ignore)))))
2179 (defun wl-folder-update-diff-line (diffs)
2180 (let ((inhibit-read-only t)
2181 (buffer-read-only nil)
2183 cur-unread new-unread
2188 (setq id (get-text-property (point) 'wl-folder-entity-id))
2189 (setq is-group (get-text-property (point) 'wl-folder-is-group))
2190 (when (looking-at "^[ ]*\\(.*\\):\\([0-9\\*-]*\\)/\\([0-9\\*-]*\\)/\\([0-9\\*]*\\)")
2191 ;;(looking-at "^[ ]*\\([^\\[].+\\):\\([0-9\\*-]*/[0-9\\*-]*/[0-9\\*]*\\)")
2192 (setq cur-new (string-to-int
2193 (wl-match-buffer 2)))
2194 (setq cur-unread (string-to-int
2195 (wl-match-buffer 3)))
2196 (setq cur-all (string-to-int
2197 (wl-match-buffer 4)))
2198 (delete-region (match-beginning 2)
2200 (goto-char (match-beginning 2))
2201 (insert (format "%s/%s/%s"
2202 (setq new-new (+ cur-new (nth 0 diffs)))
2203 (setq new-unread (+ cur-unread (nth 1 diffs)))
2204 (setq new-all (+ cur-all (nth 2 diffs)))))
2205 (wl-folder-put-folder-property (match-beginning 2) (point) id is-group)
2206 (if wl-use-highlight-mouse-line
2207 (put-text-property (match-beginning 2) (point)
2208 'mouse-face 'highlight))
2209 (wl-highlight-folder-group-line (list new-new new-unread new-all))
2210 (setq buffer-read-only t)
2211 (set-buffer-modified-p nil)))))
2213 (defun wl-folder-update-line (nums &optional is-group)
2214 (let ((inhibit-read-only t)
2215 (buffer-read-only nil)
2219 (setq id (get-text-property (point) 'wl-folder-entity-id))
2220 (setq is-group (get-text-property (point) 'wl-folder-is-group))
2221 (if (looking-at "^[ ]*\\(.*\\):\\([0-9\\*-]*/[0-9\\*-]*/[0-9\\*]*\\)")
2222 ;;; (looking-at "^[ ]*\\([^\\[].+\\):\\([0-9\\*-]*/[0-9\\*-]*/[0-9\\*]*\\)")
2224 (delete-region (match-beginning 2)
2226 (goto-char (match-beginning 2))
2227 (insert (format "%s/%s/%s"
2228 (or (nth 0 nums) "*")
2229 (or (and (nth 0 nums)(nth 1 nums)
2230 (+ (nth 0 nums)(nth 1 nums)))
2232 (or (nth 2 nums) "*")))
2233 (wl-folder-put-folder-property (match-beginning 2) (point) id is-group)
2235 ;; update only colors
2236 (wl-highlight-folder-group-line nums)
2237 (wl-highlight-folder-current-line nums))
2239 (set-buffer-modified-p nil))))))
2241 (defun wl-folder-goto-folder (&optional arg)
2242 "Visit some folder."
2244 (wl-folder-goto-folder-subr nil arg))
2246 (defun wl-folder-goto-folder-sticky ()
2247 "Visit some folder and make it sticky."
2249 (wl-folder-goto-folder-subr nil t))
2251 (defun wl-folder-goto-draft-folder (&optional arg)
2252 "Visit draft folder."
2254 (wl-folder-goto-folder-subr wl-draft-folder arg))
2256 (defun wl-folder-revisit-last-visited-folder (&optional arg)
2257 "Revisit last visited folder."
2260 (wl-folder-get-folder-name-by-id wl-folder-buffer-last-visited-entity-id)))
2262 (y-or-n-p (format "Revisit %s? " folder)))
2263 (wl-folder-goto-folder-subr folder arg))))
2265 (defun wl-folder-goto-folder-subr (&optional folder sticky)
2267 (let (summary-buf fld-name entity id error-selecting)
2268 ;;; (setq fld-name (wl-folder-get-entity-from-buffer))
2269 ;;; (if (or (null fld-name)
2270 ;;; (assoc fld-name wl-folder-group-alist))
2271 (setq fld-name wl-default-folder)
2272 (setq fld-name (or folder
2274 (wl-summary-read-folder fld-name))))
2275 (if (and (setq entity
2276 (wl-folder-search-entity-by-name fld-name
2279 (setq id (wl-folder-get-entity-id entity)))
2280 (wl-folder-set-current-entity-id id))
2281 (setq summary-buf (wl-summary-get-buffer-create fld-name sticky))
2282 (if (or wl-stay-folder-window wl-summary-use-frame)
2283 (wl-folder-select-buffer summary-buf)
2284 (if (and summary-buf
2285 (get-buffer-window summary-buf))
2287 (wl-summary-goto-folder-subr fld-name
2288 (wl-summary-get-sync-range
2289 (wl-folder-get-elmo-folder fld-name))
2292 (defun wl-folder-suspend ()
2294 (run-hooks 'wl-folder-suspend-hook)
2295 (wl-folder-info-save)
2296 (elmo-crosspost-message-alist-save)
2298 ;(if (fboundp 'mmelmo-cleanup-entity-buffers)
2299 ;(mmelmo-cleanup-entity-buffers))
2300 (bury-buffer wl-folder-buffer-name)
2301 (dolist (summary-buf (wl-collect-summary))
2302 (bury-buffer summary-buf))
2303 (dolist (draft-buf (wl-collect-draft))
2304 (bury-buffer draft-buf))
2305 (delete-windows-on wl-folder-buffer-name t))
2307 (defun wl-folder-info-save ()
2308 (when (and wl-folder-info-save
2309 wl-folder-info-alist-modified)
2310 (let ((entities (list wl-folder-entity))
2311 entity entity-stack info-alist info)
2313 (setq entity (wl-pop entities))
2317 (wl-push entities entity-stack))
2318 (setq entities (nth 2 entity)))
2320 (when (and (setq info (elmo-folder-get-info
2321 (wl-folder-get-elmo-folder entity)))
2322 (not (equal info '(nil))))
2324 (wl-append info-alist (list (list (elmo-string entity)
2325 (list (nth 3 info) ;; max
2326 (nth 2 info) ;; length
2328 (nth 1 info)) ;; unread
2331 (setq entities (wl-pop entity-stack))))
2332 (elmo-msgdb-finfo-save info-alist)
2333 (setq wl-folder-info-alist-modified nil))))
2335 (defun wl-folder-goto-first-unread-folder (&optional arg)
2337 (let ((entities (list wl-folder-entity))
2338 entity entity-stack ret-val
2343 (setq entity (wl-pop entities))
2347 (wl-push entities entity-stack))
2348 (setq entities (nth 2 entity)))
2350 (if (and (setq finfo (wl-folder-get-entity-info entity))
2351 (and (nth 0 finfo)(nth 1 finfo))
2352 (> (+ (nth 0 finfo)(nth 1 finfo)) 0))
2353 (throw 'done entity))
2354 (wl-append ret-val (list entity))))
2356 (setq entities (wl-pop entity-stack))))))
2360 (wl-folder-jump-folder first-entity)
2362 (wl-folder-goto-folder-subr first-entity))
2363 (message "No unread folder"))))
2365 (defun wl-folder-jump-folder (&optional fld-name noopen)
2368 (setq fld-name (wl-summary-read-folder wl-default-folder)))
2369 (goto-char (point-min))
2371 (wl-folder-open-folder fld-name))
2372 (and (wl-folder-buffer-search-entity fld-name)
2373 (beginning-of-line)))
2375 (defun wl-folder-get-entity-list (entity)
2376 (let ((entities (list entity))
2377 entity-stack ret-val)
2379 (setq entity (wl-pop entities))
2383 (wl-push entities entity-stack))
2384 (setq entities (nth 2 entity)))
2386 (wl-append ret-val (list entity))))
2388 (setq entities (wl-pop entity-stack))))
2391 (defun wl-folder-open-unread-folder (entity)
2393 (let ((alist (wl-folder-get-entity-list entity))
2395 finfo path-list path id)
2397 (when (and (setq finfo (wl-folder-get-entity-info (car alist)))
2398 (nth 0 finfo) (nth 1 finfo)
2399 (> (+ (nth 0 finfo)(nth 1 finfo)) 0))
2400 (setq unread (+ unread (+ (nth 0 finfo)(nth 1 finfo))))
2401 (setq id (wl-folder-get-entity-id (car alist)))
2402 (setq path (delete id (wl-folder-get-path
2406 (if (not (member path path-list))
2407 (wl-append path-list (list path))))
2408 (setq alist (cdr alist)))
2410 (wl-folder-open-folder-sub (car path-list))
2411 (setq path-list (cdr path-list)))
2412 (message "%s unread folder"
2413 (if (> unread 0) unread "No")))))
2415 (defun wl-folder-open-unread-current-entity ()
2417 (let ((entity-name (wl-folder-get-entity-from-buffer))
2418 (group (wl-folder-buffer-group-p)))
2420 (wl-folder-open-unread-folder
2422 (wl-folder-search-group-entity-by-name entity-name
2426 (defun wl-folder-open-only-unread-folder ()
2429 (wl-folder-prev-entity-skip-invalid t)
2430 (wl-folder-get-entity-from-buffer t))))
2431 (wl-folder-open-all-unread-folder)
2433 (goto-char (point-max))
2434 (while (and (re-search-backward
2435 "^[ ]*\\[[-]\\].+:0/0/[0-9-]+" nil t)
2437 (wl-folder-jump-to-current-entity) ;; close it
2439 (wl-folder-move-path id)
2442 (defun wl-folder-open-all-unread-folder (&optional arg)
2445 (wl-folder-prev-entity-skip-invalid t)
2446 (wl-folder-get-entity-from-buffer t))))
2447 (wl-folder-open-unread-folder wl-folder-entity)
2449 (wl-folder-move-path id)
2450 (goto-char (point-min))
2451 (wl-folder-next-unread t))))
2453 (defun wl-folder-open-folder (&optional fld-name)
2456 (setq fld-name (wl-summary-read-folder wl-default-folder)))
2457 (let* ((id (wl-folder-get-entity-id
2458 (wl-folder-search-entity-by-name fld-name wl-folder-entity
2460 (path (and id (wl-folder-get-path wl-folder-entity id))))
2462 (wl-folder-open-folder-sub path))))
2464 (defun wl-folder-open-folder-sub (path)
2465 (let ((inhibit-read-only t)
2466 (buffer-read-only nil)
2470 (goto-char (point-min))
2472 (wl-folder-buffer-search-group
2473 (wl-folder-get-petname
2474 (if (stringp (car path))
2476 (wl-folder-get-folder-name-by-id
2479 (setq path (cdr path))
2480 (if (and (wl-folder-buffer-group-p)
2481 (looking-at wl-folder-group-regexp)
2482 (string= "+" (wl-match-buffer 2)));; closed group
2484 (setq indent (wl-match-buffer 1))
2485 (setq name (wl-folder-get-entity-from-buffer))
2486 (setq entity (wl-folder-search-group-entity-by-name
2490 (setcdr (assoc (car entity) wl-folder-group-alist) t)
2491 (if (eq 'access (cadr entity))
2492 (wl-folder-maybe-load-folder-list entity))
2493 (wl-folder-insert-entity indent entity)
2494 (delete-region (save-excursion (beginning-of-line)
2496 (save-excursion (end-of-line)
2498 (set-buffer-modified-p nil))))
2500 (defun wl-folder-open-all-pre ()
2501 (let ((entities (list wl-folder-entity))
2502 entity entity-stack group-entry)
2504 (setq entity (wl-pop entities))
2507 (unless (or (not (setq group-entry
2508 (assoc (car entity) wl-folder-group-alist)))
2510 (setcdr group-entry t)
2511 (when (eq 'access (cadr entity))
2512 (wl-folder-maybe-load-folder-list entity)))
2514 (wl-push entities entity-stack))
2515 (setq entities (nth 2 entity))))
2517 (setq entities (wl-pop entity-stack))))))
2519 (defun wl-folder-open-all (&optional refresh)
2521 (let* ((inhibit-read-only t)
2522 (buffer-read-only nil)
2523 (len (length wl-folder-group-alist))
2528 (wl-folder-prev-entity-skip-invalid t)
2529 (wl-folder-get-entity-from-buffer t)))
2530 (alist wl-folder-group-alist))
2532 (setcdr (pop alist) t))
2534 (wl-folder-insert-entity " " wl-folder-entity)
2535 (wl-folder-move-path id))
2536 (message "Opening all folders...")
2537 (wl-folder-open-all-pre)
2539 (goto-char (point-min))
2540 (while (re-search-forward
2541 "^\\([ ]*\\)\\[\\([+]\\)\\]\\(.+\\):[-0-9-]+/[0-9-]+/[0-9-]+$"
2543 (setq indent (wl-match-buffer 1))
2544 (setq name (wl-folder-get-entity-from-buffer))
2545 (setq entity (wl-folder-search-group-entity-by-name
2549 (setcdr (assoc (car entity) wl-folder-group-alist) t)
2551 (wl-folder-insert-entity indent entity)
2552 (delete-region (save-excursion (beginning-of-line)
2554 (save-excursion (end-of-line)
2556 (when (> len elmo-display-progress-threshold)
2558 (if (or (zerop (% i 5)) (= i len))
2559 (elmo-display-progress
2560 'wl-folder-open-all "Opening all folders..."
2561 (/ (* i 100) len)))))
2562 (when (> len elmo-display-progress-threshold)
2563 (elmo-display-progress
2564 'wl-folder-open-all "Opening all folders..." 100))))
2565 (wl-highlight-folder-path wl-folder-buffer-cur-path)
2566 (message "Opening all folders...done")
2567 (set-buffer-modified-p nil)))
2569 (defun wl-folder-close-all ()
2571 (let ((inhibit-read-only t)
2572 (buffer-read-only nil)
2573 (alist wl-folder-group-alist)
2575 (wl-folder-prev-entity-skip-invalid t)
2576 (wl-folder-get-entity-from-buffer t))))
2578 (setcdr (car alist) nil)
2579 (setq alist (cdr alist)))
2580 (setcdr (assoc (car wl-folder-entity) wl-folder-group-alist) t)
2582 (wl-folder-insert-entity " " wl-folder-entity)
2583 (wl-folder-move-path id)
2584 (wl-highlight-folder-path wl-folder-buffer-cur-path)
2586 (set-buffer-modified-p nil)))
2588 (defun wl-folder-open-close ()
2589 "Open or close parent entity."
2593 (if (wl-folder-buffer-group-p)
2594 ;; if group (whether opend or closed.)
2595 (wl-folder-jump-to-current-entity)
2598 (setq indent (save-excursion
2599 (re-search-forward "\\([ ]*\\)." nil t)
2600 (wl-match-buffer 1)))
2601 (while (looking-at indent)
2603 (wl-folder-jump-to-current-entity))))
2605 (defsubst wl-folder-access-subscribe-p (group folder)
2606 (let (subscr regexp match)
2607 (if (setq subscr (wl-get-assoc-list-value
2608 wl-folder-access-subscribe-alist
2611 (setq regexp (mapconcat 'identity (cdr subscr) "\\|"))
2612 (setq match (string-match regexp folder))
2618 (defun wl-folder-update-access-group (entity new-flist)
2619 (let* ((flist (nth 2 entity))
2620 (unsubscribes (nth 3 entity))
2621 (len (+ (length flist) (length unsubscribes)))
2623 diff new-unsubscribes removes
2624 subscribed-list folder group entry)
2625 ;; check subscribed groups
2628 ((listp (car flist)) ;; group
2629 (setq group (elmo-string (caar flist)))
2631 ((assoc group new-flist) ;; found in new-flist
2632 (setq new-flist (delete (assoc group new-flist)
2634 (if (wl-folder-access-subscribe-p (car entity) group)
2635 (wl-append subscribed-list (list (car flist)))
2636 (wl-append new-unsubscribes (list (car flist)))
2639 (setq wl-folder-group-alist
2640 (delete (wl-string-assoc group wl-folder-group-alist)
2641 wl-folder-group-alist))
2642 (wl-append removes (list (list group))))))
2644 (setq folder (elmo-string (car flist)))
2646 ((member folder new-flist) ;; found in new-flist
2647 (setq new-flist (delete folder new-flist))
2648 (if (wl-folder-access-subscribe-p (car entity) folder)
2649 (wl-append subscribed-list (list (car flist)))
2650 (wl-append new-unsubscribes (list folder))
2653 (wl-append removes (list folder))))))
2654 (when (> len elmo-display-progress-threshold)
2656 (if (or (zerop (% i 10)) (= i len))
2657 (elmo-display-progress
2658 'wl-folder-update-access-group "Updating access group..."
2659 (/ (* i 100) len))))
2660 (setq flist (cdr flist)))
2661 ;; check unsubscribed groups
2664 ((listp (car unsubscribes))
2665 (when (setq entry (assoc (caar unsubscribes) new-flist))
2666 (setq new-flist (delete entry new-flist))
2667 (wl-append new-unsubscribes (list (car unsubscribes)))))
2669 (when (member (car unsubscribes) new-flist)
2670 (setq new-flist (delete (car unsubscribes) new-flist))
2671 (wl-append new-unsubscribes (list (car unsubscribes))))))
2672 (when (> len elmo-display-progress-threshold)
2674 (if (or (zerop (% i 10)) (= i len))
2675 (elmo-display-progress
2676 'wl-folder-update-access-group "Updating access group..."
2677 (/ (* i 100) len))))
2678 (setq unsubscribes (cdr unsubscribes)))
2680 (if (or new-flist removes)
2683 (mapcar '(lambda (x)
2684 (cond ((consp x) (list (car x) 'access))
2688 (let ((new-list new-flist))
2690 (if (not (wl-folder-access-subscribe-p
2692 (if (listp (car new-list))
2697 (wl-append new-unsubscribes (list (car new-list)))
2698 (setq new-flist (delete (car new-list) new-flist)))
2700 ((listp (car new-list))
2701 ;; check group exists
2702 (if (wl-string-assoc (caar new-list) wl-folder-group-alist)
2704 (message "%s: group already exists." (caar new-list))
2706 (wl-append new-unsubscribes (list (car new-list)))
2707 (setq new-flist (delete (car new-list) new-flist)))
2708 (wl-append wl-folder-group-alist
2709 (list (cons (caar new-list) nil)))))))
2710 (setq new-list (cdr new-list))))
2712 (message "%d new folder(s)." (length new-flist))
2713 (message "Updating access group...done"))
2714 (wl-append new-flist subscribed-list) ;; new is first
2715 (run-hooks 'wl-folder-update-access-group-hook)
2716 (setcdr (cdr entity) (list new-flist new-unsubscribes))
2717 (list diff new-flist new-unsubscribes removes)))
2719 (defun wl-folder-prefetch-entity (entity)
2720 "Prefetch all new messages in the ENTITY."
2723 (let ((flist (nth 2 entity))
2728 (setq result (wl-folder-prefetch-entity (car flist)))
2729 (setq sum-done (+ sum-done (car result)))
2730 (setq sum-all (+ sum-all (cdr result)))
2731 (setq flist (cdr flist)))
2732 (message "Prefetched %d/%d message(s) in \"%s\"."
2734 (wl-folder-get-petname (car entity)))
2735 (cons sum-done sum-all)))
2737 (let* ((folder (wl-folder-get-elmo-folder entity))
2738 (nums (wl-folder-get-entity-info entity))
2739 (wl-summary-highlight (if (or (wl-summary-sticky-p folder)
2740 (wl-summary-always-sticky-folder-p
2742 wl-summary-highlight))
2743 wl-summary-exit-next-move
2744 wl-auto-select-first ret-val
2746 (setq count (or (car nums) 0))
2747 (setq count (+ count (wl-folder-count-incorporates folder)))
2748 (if (or (null (car nums)) ; unknown
2750 (save-window-excursion
2752 (let ((wl-summary-buffer-name
2753 (if (setq sticky (get-buffer
2754 (wl-summary-sticky-buffer-name
2755 (elmo-folder-name-internal
2757 ;; Sticky folder exists.
2758 (wl-summary-sticky-buffer-name
2759 (elmo-folder-name-internal folder))
2761 wl-summary-buffer-name
2762 (symbol-name this-command))))
2763 (wl-summary-use-frame nil)
2764 (wl-summary-always-sticky-folder-list nil))
2765 (wl-summary-goto-folder-subr entity
2766 (wl-summary-get-sync-range
2769 (setq ret-val (wl-summary-incorporate))
2771 (wl-summary-save-status)
2776 (defun wl-folder-count-incorporates (folder)
2778 (dolist (number (elmo-folder-list-flagged folder 'any))
2779 (when (member (wl-summary-message-mark folder number)
2780 wl-summary-incorporate-marks)
2784 (defun wl-folder-prefetch-current-entity (&optional no-check)
2785 "Prefetch all uncached messages in the folder at position.
2786 If current line is group folder, all subfolders are prefetched."
2789 (let ((entity-name (wl-folder-get-entity-from-buffer))
2790 (group (wl-folder-buffer-group-p))
2791 wl-folder-check-entity-hook
2796 (wl-folder-search-group-entity-by-name entity-name
2800 (wl-folder-check-entity entity))
2801 (wl-folder-prefetch-entity entity)))))
2803 ;(defun wl-folder-drop-unsync-entity (entity)
2804 ; "Drop all unsync messages in the ENTITY."
2807 ; (let ((flist (nth 2 entity)))
2809 ; (wl-folder-drop-unsync-entity (car flist))
2810 ; (setq flist (cdr flist)))))
2812 ; (let ((nums (wl-folder-get-entity-info entity))
2813 ; wl-summary-highlight wl-auto-select-first new)
2814 ; (setq new (or (car nums) 0))
2816 ; (save-window-excursion
2818 ; (let ((wl-summary-buffer-name (concat
2819 ; wl-summary-buffer-name
2820 ; (symbol-name this-command))))
2821 ; (wl-summary-goto-folder-subr entity 'no-sync nil)
2822 ; (wl-summary-drop-unsync)
2823 ; (wl-summary-exit)))))))))
2825 ;(defun wl-folder-drop-unsync-current-entity (&optional force-check)
2826 ; "Drop all unsync messages in the folder at position.
2827 ;If current line is group folder, all subfolders are dropped.
2828 ;If optional arg exists, don't check any folders."
2831 ; (let ((entity-name (wl-folder-get-entity-from-buffer))
2832 ; (group (wl-folder-buffer-group-p))
2833 ; wl-folder-check-entity-hook
2834 ; summary-buf entity)
2835 ; (when (and entity-name
2837 ; "Drop all unsync messages in %s? " entity-name)))
2840 ; (wl-folder-search-group-entity-by-name entity-name
2843 ; (if (null force-check)
2844 ; (wl-folder-check-entity entity))
2845 ; (wl-folder-drop-unsync-entity entity)
2846 ; (message "All unsync messages in %s are dropped!" entity-name)))))
2848 (defun wl-folder-write-current-folder ()
2849 "Write message to current folder's newsgroup or mailing-list.
2850 Call `wl-summary-write-current-folder' with current folder name."
2852 (unless (wl-folder-buffer-group-p)
2853 (wl-summary-write-current-folder
2854 (wl-folder-get-entity-from-buffer))))
2856 (defun wl-folder-mimic-kill-buffer ()
2857 "Kill the current (Folder) buffer with query."
2859 (let ((bufname (read-buffer (format "Kill buffer: (default %s) "
2861 wl-interactive-exit)
2862 (if (or (not bufname)
2863 (string-equal bufname "")
2864 (string-equal bufname (buffer-name)))
2866 (kill-buffer bufname))))
2868 (defun wl-folder-create-subr (folder)
2869 (if (elmo-folder-creatable-p folder)
2870 (if (y-or-n-p (format "Folder %s does not exist, create it? "
2871 (elmo-folder-name-internal folder)))
2874 (setq wl-folder-entity-hashtb
2875 (wl-folder-create-entity-hashtb
2876 (elmo-folder-name-internal folder)
2877 wl-folder-entity-hashtb))
2878 (unless (elmo-folder-create folder)
2879 (error "Create folder failed")))
2880 (error "Folder %s is not created" (elmo-folder-name-internal folder)))
2881 (error "Folder %s does not exist" (elmo-folder-name-internal folder))))
2883 (defun wl-folder-confirm-existence (folder &optional force)
2885 (unless (elmo-folder-exists-p folder)
2886 (wl-folder-create-subr folder))
2887 (unless (or (wl-folder-entity-exists-p (elmo-folder-name-internal folder))
2888 (and (elmo-folder-msgdb-path folder)
2889 (file-exists-p (elmo-folder-msgdb-path folder)))
2890 (elmo-folder-exists-p folder))
2891 (wl-folder-create-subr folder))))
2893 (defun wl-folder-virtual ()
2894 "Goto virtual folder."
2896 (let ((entity (wl-folder-get-entity-from-buffer)))
2897 (if (wl-folder-buffer-group-p)
2901 (mapconcat 'identity
2902 (wl-folder-get-entity-list
2903 (wl-folder-search-group-entity-by-name
2905 wl-folder-entity)) ","))))
2906 (unless entity (error "No folder"))
2907 (wl-folder-goto-folder-subr
2909 (elmo-read-search-condition
2910 wl-fldmgr-make-filter-default)
2913 (defun wl-folder-pick ()
2916 (let* ((condition (car (elmo-parse-search-condition
2917 (elmo-read-search-condition
2918 wl-summary-pick-field-default))))
2919 (entity (wl-folder-get-entity-from-buffer))
2921 (if (wl-folder-buffer-group-p)
2922 (wl-folder-get-entity-list
2923 (wl-folder-search-group-entity-by-name
2928 (while (car folder-list)
2929 (setq ret (elmo-folder-search
2930 (wl-folder-get-elmo-folder (car folder-list))
2935 (list (cons (car folder-list) ret)))))
2936 (setq folder-list (cdr folder-list)))
2938 (message "%s are picked."
2939 (mapconcat '(lambda (res)
2942 (length (cdr res))))
2945 (message "No message was picked.")))))
2947 (defun wl-folder-jump-to-next-summary ()
2949 (when (wl-collect-summary)
2950 (if (get-buffer-window (car (wl-collect-summary)))
2951 (switch-to-buffer-other-window (car (wl-collect-summary))))
2952 (wl-summary-next-buffer)))
2954 (defun wl-folder-jump-to-previous-summary ()
2956 (when (wl-collect-summary)
2957 (if (get-buffer-window (car (wl-collect-summary)))
2958 (switch-to-buffer-other-window (car (wl-collect-summary))))
2959 (wl-summary-previous-buffer)))
2963 (defvar wl-folder-complete-folder-candidate nil)
2965 (defun wl-folder-complete-folder (string predicate flag)
2966 (cond ((or (string-match "^\\(/[^/]*/\\)\\(.*\\)$" string) ; filter
2967 (string-match "^\\(\*\\|\*.*,\\)\\([^,]*\\)$" string) ; multi
2968 (string-match "^\\(|[^|]*|:?\\)\\(.*\\)$" string) ;pipe-src
2969 (string-match "^\\(|\\)\\([^|]*\\)$" string)) ;pipe-dst
2970 (let* ((str1 (match-string 1 string))
2971 (str2 (match-string 2 string))
2972 (str2-comp (wl-folder-complete-folder str2 predicate flag)))
2974 ((listp str2-comp) ; flag=t
2975 (mapcar (lambda (x) (concat str1 x)) str2-comp))
2976 ((stringp str2-comp)
2977 (concat str1 str2-comp))
2980 ((string-match "^\\(/\\)\\([^/]*\\)$" string) ; filter-condition
2981 (let* ((str1 (match-string 1 string))
2982 (str2 (match-string 2 string))
2984 (wl-folder-complete-filter-condition str2 predicate flag)))
2986 ((listp str2-comp) ; flag=t
2987 (mapcar (lambda (x) (concat str1 x)) str2-comp))
2988 ((stringp str2-comp)
2989 (concat str1 str2-comp))
2994 (or wl-folder-complete-folder-candidate
2995 (if (memq 'read-folder wl-use-folder-petname)
2996 (wl-folder-get-entity-with-petname)
2997 wl-folder-entity-hashtb))))
2999 (try-completion string candidate)
3000 (all-completions string candidate))))))
3002 (defun wl-folder-complete-filter-condition (string predicate flag)
3004 ((string-match "^\\(.*|\\|.*&\\|.*!\\|.*(\\)\\([^:]*\\)$" string)
3005 (let* ((str1 (match-string 1 string))
3006 (str2 (match-string 2 string))
3008 (wl-folder-complete-filter-condition str2 predicate flag)))
3010 ((listp str2-comp) ; flag=t
3011 (mapcar (lambda (x) (concat str1 x)) str2-comp))
3012 ((stringp str2-comp)
3013 (concat str1 str2-comp))
3018 (mapcar (lambda (x) (list (concat (downcase x) ":")))
3019 (append '("last" "first"
3020 "from" "subject" "to" "cc" "body"
3021 "since" "before" "tocc")
3022 elmo-msgdb-extra-fields))))
3024 (try-completion string candidate)
3025 (all-completions string candidate))))))
3028 (product-provide (provide 'wl-folder) (require 'wl-version))
3030 ;;; wl-folder.el ends here