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.
50 (unless (boundp ':file)
51 (set (make-local-variable ':file) nil))
52 (defun-maybe mmelmo-cleanup-entity-buffers ()))
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-newsgroups-hashtb nil)
61 (defvar wl-folder-info-alist-modified nil)
62 (defvar wl-folder-completion-func nil)
64 (defvar wl-folder-mode-map nil)
66 (defvar wl-folder-buffer-disp-summary nil)
67 (defvar wl-folder-buffer-cur-entity-id nil)
68 (defvar wl-folder-buffer-cur-path nil)
69 (defvar wl-folder-buffer-cur-point nil)
71 (make-variable-buffer-local 'wl-folder-buffer-disp-summary)
72 (make-variable-buffer-local 'wl-folder-buffer-cur-entity-id)
73 (make-variable-buffer-local 'wl-folder-buffer-cur-path)
74 (make-variable-buffer-local 'wl-folder-buffer-cur-point)
76 (defconst wl-folder-entity-regexp "^\\([ ]*\\)\\(\\[[\\+-]\\]\\)?\\([^\\[].+\\):[-*0-9]+/[-*0-9]+/[-*0-9]+")
77 (defconst wl-folder-group-regexp "^\\([ ]*\\)\\[\\([\\+-]\\)\\]\\(.+\\):[-0-9-]+/[0-9-]+/[0-9-]+\n")
78 ;; 1:indent 2:opened 3:group-name
79 (defconst wl-folder-unsync-regexp ":[^0\\*][0-9]*/[0-9\\*-]+/[0-9\\*-]+$")
81 (defvar wl-folder-mode-menu-spec
83 ["Enter Current Folder" wl-folder-jump-to-current-entity t]
84 ["Prev Folder" wl-folder-prev-entity t]
85 ["Next Folder" wl-folder-next-entity t]
86 ["Check Current Folder" wl-folder-check-current-entity t]
87 ["Sync Current Folder" wl-folder-sync-current-entity t]
88 ["Drop Current Folder" wl-folder-drop-unsync-current-entity t]
89 ["Prefetch Current Folder" wl-folder-prefetch-current-entity t]
90 ["Mark as Read all Current Folder" wl-folder-mark-as-read-all-current-entity t]
91 ["Expire Current Folder" wl-folder-expire-current-entity t]
92 ["Empty trash" wl-folder-empty-trash t]
93 ["Flush queue" wl-folder-flush-queue t]
94 ["Open All" wl-folder-open-all t]
95 ["Open All Unread folder" wl-folder-open-all-unread-folder t]
96 ["Close All" wl-folder-close-all t]
98 ["Add folder" wl-fldmgr-add t]
99 ["Add group" wl-fldmgr-make-group t]
100 ["Copy" wl-fldmgr-copy t]
101 ["Cut" wl-fldmgr-cut t]
102 ["Paste" wl-fldmgr-yank t]
103 ["Set petname" wl-fldmgr-set-petname t]
104 ["Rename" wl-fldmgr-rename t]
105 ["Save" wl-fldmgr-save-folders t]
107 ["Unsubscribe" wl-fldmgr-unsubscribe t]
108 ["Display all" wl-fldmgr-access-display-all t])
110 ["Write a message" wl-draft t]
112 ["Toggle Plug Status" wl-toggle-plugged t]
113 ["Change Plug Status" wl-plugged-change t]
115 ["Save Current Status" wl-save t]
116 ["Update Satus" wl-status-update t]
121 (defun wl-folder-setup-mouse ()
122 (define-key wl-folder-mode-map 'button2 'wl-folder-click)
123 (define-key wl-folder-mode-map 'button4 'wl-folder-prev-entity)
124 (define-key wl-folder-mode-map 'button5 'wl-folder-next-entity)
125 (define-key wl-folder-mode-map [(shift button4)]
126 'wl-folder-prev-unread)
127 (define-key wl-folder-mode-map [(shift button5)]
128 'wl-folder-next-unread))
130 (defun wl-folder-setup-mouse ())
131 (defun wl-folder-setup-mouse ()
132 (define-key wl-folder-mode-map [mouse-2] 'wl-folder-click)
133 (define-key wl-folder-mode-map [mouse-4] 'wl-folder-prev-entity)
134 (define-key wl-folder-mode-map [mouse-5] 'wl-folder-next-entity)
135 (define-key wl-folder-mode-map [S-mouse-4] 'wl-folder-prev-unread)
136 (define-key wl-folder-mode-map [S-mouse-5] 'wl-folder-next-unread))))
138 (if wl-folder-mode-map
140 (setq wl-folder-mode-map (make-sparse-keymap))
141 (define-key wl-folder-mode-map " " 'wl-folder-jump-to-current-entity)
142 ; (define-key wl-folder-mode-map "\M- " 'wl-folder-open-close)
143 (define-key wl-folder-mode-map "/" 'wl-folder-open-close)
144 (define-key wl-folder-mode-map "\C-m" 'wl-folder-jump-to-current-entity)
145 (define-key wl-folder-mode-map "\M-\C-m" 'wl-folder-update-recursive-current-entity)
146 (define-key wl-folder-mode-map "rc" 'wl-folder-mark-as-read-all-region)
147 (define-key wl-folder-mode-map "c" 'wl-folder-mark-as-read-all-current-entity)
148 (define-key wl-folder-mode-map "g" 'wl-folder-goto-folder)
149 (define-key wl-folder-mode-map "j" 'wl-folder-jump-to-current-entity)
150 (define-key wl-folder-mode-map "w" 'wl-draft)
151 (define-key wl-folder-mode-map "W" 'wl-folder-write-current-folder)
152 (define-key wl-folder-mode-map "\C-c\C-o" 'wl-jump-to-draft-buffer)
153 (define-key wl-folder-mode-map "rS" 'wl-folder-sync-region)
154 (define-key wl-folder-mode-map "S" 'wl-folder-sync-current-entity)
155 (define-key wl-folder-mode-map "rs" 'wl-folder-check-region)
156 (define-key wl-folder-mode-map "s" 'wl-folder-check-current-entity)
157 (define-key wl-folder-mode-map "I" 'wl-folder-prefetch-current-entity)
158 (define-key wl-folder-mode-map "D" 'wl-folder-drop-unsync-current-entity)
159 (define-key wl-folder-mode-map "p" 'wl-folder-prev-entity)
160 (define-key wl-folder-mode-map "n" 'wl-folder-next-entity)
161 (define-key wl-folder-mode-map "v" 'wl-folder-toggle-disp-summary)
162 (define-key wl-folder-mode-map "P" 'wl-folder-prev-unread)
163 (define-key wl-folder-mode-map "N" 'wl-folder-next-unread)
164 (define-key wl-folder-mode-map "J" 'wl-folder-jump-folder)
165 (define-key wl-folder-mode-map "f" 'wl-folder-goto-first-unread-folder)
166 (define-key wl-folder-mode-map "o" 'wl-folder-open-all-unread-folder)
167 (define-key wl-folder-mode-map "[" 'wl-folder-open-all)
168 (define-key wl-folder-mode-map "]" 'wl-folder-close-all)
169 (define-key wl-folder-mode-map "e" 'wl-folder-expire-current-entity)
170 (define-key wl-folder-mode-map "E" 'wl-folder-empty-trash)
171 (define-key wl-folder-mode-map "F" 'wl-folder-flush-queue)
172 (define-key wl-folder-mode-map "q" 'wl-exit)
173 (define-key wl-folder-mode-map "z" 'wl-folder-suspend)
174 (define-key wl-folder-mode-map "\M-t" 'wl-toggle-plugged)
175 (define-key wl-folder-mode-map "\C-t" 'wl-plugged-change)
176 (define-key wl-folder-mode-map "<" 'beginning-of-buffer)
177 (define-key wl-folder-mode-map ">" 'end-of-buffer)
180 (define-key wl-folder-mode-map "m" 'wl-fldmgr-mode-map))
181 (define-key wl-folder-mode-map "*" 'wl-fldmgr-make-multi)
182 (define-key wl-folder-mode-map "+" 'wl-fldmgr-make-group)
183 (define-key wl-folder-mode-map "|" 'wl-fldmgr-make-filter)
184 (define-key wl-folder-mode-map "\M-c" 'wl-fldmgr-copy)
185 (define-key wl-folder-mode-map "\M-w" 'wl-fldmgr-copy-region)
186 (define-key wl-folder-mode-map "\C-k" 'wl-fldmgr-cut)
187 (define-key wl-folder-mode-map "\C-w" 'wl-fldmgr-cut-region)
188 (define-key wl-folder-mode-map "\C-y" 'wl-fldmgr-yank)
189 (define-key wl-folder-mode-map "R" 'wl-fldmgr-rename)
190 (define-key wl-folder-mode-map "u" 'wl-fldmgr-unsubscribe)
191 (define-key wl-folder-mode-map "ru" 'wl-fldmgr-unsubscribe-region)
192 (define-key wl-folder-mode-map "U" 'wl-fldmgr-unsubscribe-region)
193 (define-key wl-folder-mode-map "l" 'wl-fldmgr-access-display-normal)
194 (define-key wl-folder-mode-map "L" 'wl-fldmgr-access-display-all)
195 (define-key wl-folder-mode-map "Z" 'wl-status-update)
196 (define-key wl-folder-mode-map "\C-x\C-s" 'wl-save)
197 (define-key wl-folder-mode-map "\M-s" 'wl-save)
198 (define-key wl-folder-mode-map "\C-xk" 'wl-folder-mimic-kill-buffer)
199 (define-key wl-folder-mode-map "\M-\C-a"
200 'wl-folder-goto-top-of-current-folder)
201 (define-key wl-folder-mode-map "\M-\C-e"
202 'wl-folder-goto-bottom-of-current-folder)
204 (wl-folder-setup-mouse)
208 "Menu used in Folder mode."
209 wl-folder-mode-menu-spec))
211 (defmacro wl-folder-unread-regex (group)
212 (` (concat "^[ ]*.+:[0-9\\*-]+/[^0\\*][0-9]*/[0-9\\*-]+$"
217 (defmacro wl-folder-buffer-group-p ()
218 (` (save-excursion (beginning-of-line)
219 (looking-at wl-folder-group-regexp))))
221 (defmacro wl-folder-folder-name ()
224 (if (or (looking-at "^[ ]*\\[[\\+-]\\]\\(.+\\):[-0-9\\*-]+/[0-9\\*-]+/[0-9\\*-]+\n")
225 (looking-at "^[ ]*\\([^\\[].+\\):.*\n"))
226 (wl-match-buffer 1)))))
228 (defmacro wl-folder-entity-name ()
231 (if (looking-at "^[ ]*\\([^\\[].+\\):.*\n")
232 (wl-match-buffer 1)))))
234 (defun wl-folder-buffer-search-group (group)
237 "^\\([ \t]*\\)\\[[\\+-]\\]"
238 (regexp-quote group) ":[-0-9-]+/[0-9-]+/[0-9-]+") nil t))
240 (defun wl-folder-buffer-search-entity (folder &optional searchname)
241 (let ((search (or searchname (wl-folder-get-petname folder))))
245 (regexp-quote search) ":[-0-9\\*-]+/[0-9\\*-]+/[0-9\\*-]+") nil t)))
247 (defsubst wl-folder-get-folder-name-by-id (entity-id &optional hashtb)
248 (and (numberp entity-id)
249 (elmo-get-hash-val (format "#%d" entity-id)
250 (or hashtb wl-folder-entity-id-name-hashtb))))
252 (defsubst wl-folder-set-id-name (entity-id entity &optional hashtb)
253 (and (numberp entity-id)
254 (elmo-set-hash-val (format "#%d" entity-id)
255 entity (or hashtb wl-folder-entity-id-name-hashtb))))
257 (defmacro wl-folder-get-entity-id (entity)
258 (` (or (get-text-property 0
261 (, entity)))) ;; for nemacs
263 (defmacro wl-folder-get-entity-from-buffer (&optional getid)
264 (` (let ((id (get-text-property (point)
265 'wl-folder-entity-id)))
266 (if (not id) ;; for nemacs
267 (wl-folder-get-realname (wl-folder-folder-name))
270 (wl-folder-get-folder-name-by-id id))))))
272 (defmacro wl-folder-entity-exists-p (entity &optional hashtb)
273 (` (let ((sym (intern-soft (, entity)
274 (or (, hashtb) wl-folder-entity-hashtb))))
275 (and sym (boundp sym)))))
277 (defmacro wl-folder-clear-entity-info (entity &optional hashtb)
278 (` (let ((sym (intern-soft (, entity)
279 (or (, hashtb) wl-folder-entity-hashtb))))
283 (defmacro wl-folder-get-entity-info (entity &optional hashtb)
284 (` (elmo-get-hash-val (, entity) (or (, hashtb) wl-folder-entity-hashtb))))
286 (defmacro wl-folder-set-entity-info (entity value &optional hashtb)
287 (` (let* ((hashtb (or (, hashtb) wl-folder-entity-hashtb))
288 (info (wl-folder-get-entity-info (, entity) hashtb)))
289 (elmo-set-hash-val (, entity)
290 (if (< (length (, value)) 4)
291 (append (, value) (list (nth 3 info)))
295 (defun wl-folder-persistent-p (folder)
296 (or (elmo-get-hash-val folder wl-folder-entity-hashtb) ; on Folder mode.
298 (let ((li wl-save-folder-list))
300 (if (string-match (car li) folder)
302 (setq li (cdr li)))))
304 (let ((li wl-no-save-folder-list))
306 (if (string-match (car li) folder)
308 (setq li (cdr li))))))))
310 (defun wl-folder-prev-entity ()
314 (defun wl-folder-next-entity ()
318 (defun wl-folder-prev-entity-skip-invalid (&optional hereto)
319 "move to previous entity. skip unsubscribed or removed entity."
323 (if (re-search-backward wl-folder-entity-regexp nil t)
325 (goto-char (point-min))))
327 (defun wl-folder-next-entity-skip-invalid (&optional hereto)
328 "Move to next entity. skip unsubscribed or removed entity."
333 (if (re-search-forward wl-folder-entity-regexp nil t)
335 (goto-char (point-max))))
337 (defun wl-folder-search-group-entity-by-name (name entity)
338 (wl-folder-search-entity-by-name name entity 'group))
340 (defun wl-folder-search-entity-by-name (name entity &optional type)
341 (let ((entities (list entity))
345 (setq entity (wl-pop entities))
348 (if (and (not (eq type 'folder))
349 (string= name (car entity)))
350 (throw 'done entity))
352 (wl-push entities entity-stack))
353 (setq entities (nth 2 entity)))
354 ((and (not (eq type 'group))
356 (if (string= name entity)
357 (throw 'done entity))))
359 (setq entities (wl-pop entity-stack)))))))
361 (defun wl-folder-search-entity-list-by-name (name entity &optional get-id)
362 (let ((entities (list entity))
363 entity-stack ret-val)
365 (setq entity (wl-pop entities))
369 (wl-push entities entity-stack))
370 (setq entities (nth 2 entity)))
372 (if (string= name entity)
373 (wl-append ret-val (if get-id
374 (list (wl-folder-get-entity-id entity))
377 (setq entities (wl-pop entity-stack))))
380 (defun wl-folder-get-prev-folder (id &optional unread)
381 (let ((name (if (stringp id)
383 (wl-folder-get-folder-name-by-id id)))
384 entity entity-stack last-entity finfo
385 (entities (list wl-folder-entity)))
388 (setq entity (wl-pop entities))
391 ;; (if (and (string= name (car entity))
392 ;; (eq id (wl-folder-get-entity-id (car entity))))
393 ;; (throw 'done last-entity))
395 (wl-push entities entity-stack))
396 (setq entities (nth 2 entity)))
398 (if (and (string= name entity)
399 ;; don't use eq, `id' is string on Nemacs.
400 (equal id (wl-folder-get-entity-id entity)))
401 (throw 'done last-entity))
403 (and (setq finfo (wl-folder-get-entity-info entity))
404 (and (nth 0 finfo)(nth 1 finfo))
405 (> (+ (nth 0 finfo)(nth 1 finfo)) 0)))
406 (setq last-entity entity))))
408 (setq entities (wl-pop entity-stack)))))))
410 (defun wl-folder-get-next-folder (id &optional unread)
411 (let ((name (if (stringp id)
413 (wl-folder-get-folder-name-by-id id)))
414 entity entity-stack found finfo
415 (entities (list wl-folder-entity)))
418 (setq entity (wl-pop entities))
421 ;;; (if (and (string= name (car entity))
422 ;;; (eq id (wl-folder-get-entity-id (car entity))))
425 (wl-push entities entity-stack))
426 (setq entities (nth 2 entity)))
429 (when (or (not unread)
430 (and (setq finfo (wl-folder-get-entity-info entity))
431 (and (nth 0 finfo)(nth 1 finfo))
432 (> (+ (nth 0 finfo)(nth 1 finfo)) 0)))
433 (throw 'done entity))
434 (if (and (string= name entity)
435 ;; don't use eq, `id' is string on Nemacs.
436 (equal id (wl-folder-get-entity-id entity)))
439 (setq entities (wl-pop entity-stack)))))))
441 (defun wl-folder-flush-queue ()
444 (let ((cur-buf (current-buffer))
445 (wl-auto-select-first nil)
448 (if elmo-enable-disconnected-operation
449 (elmo-dop-queue-flush 'force)) ; Try flushing all queue.
450 (if (not (elmo-list-folder wl-queue-folder))
451 (message "No sending queue exists.")
452 (if wl-stay-folder-window
453 (wl-folder-select-buffer
454 (wl-summary-get-buffer-create wl-queue-folder)))
455 (wl-summary-goto-folder-subr wl-queue-folder 'force-update nil)
457 (wl-draft-queue-flush)
458 (if (get-buffer-window cur-buf)
459 (select-window (get-buffer-window cur-buf)))
461 (if wl-stay-folder-window
462 (wl-folder-toggle-disp-summary 'off wl-queue-folder)
463 (switch-to-buffer cur-buf))))))
465 (defun wl-folder-empty-trash ()
468 (let ((cur-buf (current-buffer))
469 (wl-auto-select-first nil)
471 (if wl-stay-folder-window
472 (wl-folder-select-buffer
473 (wl-summary-get-buffer-create wl-trash-folder)))
474 (wl-summary-goto-folder-subr wl-trash-folder 'force-update nil nil t)
475 (setq trash-buf (current-buffer))
477 (setq emptied (wl-summary-delete-all-msgs))
479 (setq wl-thread-entities nil
480 wl-thread-entity-list nil)
481 (if wl-summary-cache-use (wl-summary-save-view-cache))
482 (wl-summary-msgdb-save))
483 (if (get-buffer-window cur-buf)
484 (select-window (get-buffer-window cur-buf)))
487 (wl-folder-set-folder-updated wl-trash-folder '(0 0 0)))
488 (if wl-stay-folder-window
489 (wl-folder-toggle-disp-summary 'off wl-trash-folder)
490 (switch-to-buffer cur-buf))
492 (kill-buffer trash-buf)))))
494 (defun wl-folder-goto-top-of-current-folder (&optional arg)
495 "Move backward to the top of the current folder group.
496 Optional argument ARG is repeart count."
498 (if (re-search-backward
499 "^ *\\[[\\+-]\\]" nil t (if arg (prefix-numeric-value arg)))
501 (goto-char (point-min))))
503 (defun wl-folder-goto-bottom-of-current-folder (indent)
504 "Move forward to the bottom of the current folder group."
509 (if (looking-at "^ *")
510 (buffer-substring (match-beginning 0)(1- (match-end 0)))
514 (while (re-search-forward "^ *" nil t)
515 (if (<= (length (match-string 0))
519 (goto-char (point-max))))
521 (defsubst wl-folder-update-group (entity diffs &optional is-group)
522 (let ((path (wl-folder-get-path
524 (wl-folder-get-entity-id entity)
527 ;; delete itself from path
528 (setq path (delete (nth (- (length path) 1) path) path)))
529 (goto-char (point-min))
532 ;; goto the path line.
533 (if (or (eq (car path) 0) ; update desktop
534 (wl-folder-buffer-search-group
535 (wl-folder-get-petname
536 (if (stringp (car path))
538 (wl-folder-get-folder-name-by-id
541 (wl-folder-update-diff-line diffs)
543 (setq path (cdr path))))))
545 (defun wl-folder-maybe-load-folder-list (entity)
546 (when (null (caddr entity))
548 (elmo-msgdb-flist-load (car entity)))
552 (wl-folder-entity-assign-id entity
553 wl-folder-entity-id-name-hashtb
555 (setq diffs (wl-fldmgr-add-entity-hashtb (list entity)))
556 (unless (equal diffs '(0 0 0))
557 (wl-folder-update-group (car entity) diffs t)))))))
559 (defsubst wl-folder-force-fetch-p (entity)
561 ((consp wl-force-fetch-folders)
562 (wl-string-match-member entity wl-force-fetch-folders))
564 wl-force-fetch-folders)))
566 (defun wl-folder-jump-to-current-entity (&optional arg)
567 "Enter the current folder. If optional ARG exists, update folder list."
570 (let (entity beg end indent opened fname err fld-name)
572 ((looking-at wl-folder-group-regexp)
574 (setq fname (wl-folder-get-realname (wl-match-buffer 3)))
575 (setq indent (wl-match-buffer 1))
576 (setq opened (wl-match-buffer 2))
577 (if (string= opened "+")
579 (setq entity (wl-folder-search-group-entity-by-name
584 (wl-folder-update-recursive-current-entity entity)
586 (setcdr (assoc (car entity) wl-folder-group-alist) t)
587 (if (eq 'access (cadr entity))
588 (wl-folder-maybe-load-folder-list entity))
589 (condition-case errobj
591 (if (or (wl-folder-force-fetch-p (car entity))
593 (eq 'access (cadr entity))
594 (null (caddr entity))))
595 (wl-folder-update-newest indent entity)
596 (wl-folder-insert-entity indent entity))
597 (wl-highlight-folder-path wl-folder-buffer-cur-path))
600 (setcdr (assoc fname wl-folder-group-alist) nil))
602 (elmo-display-error errobj t)
605 (setcdr (assoc fname wl-folder-group-alist) nil)))
607 (let ((buffer-read-only nil))
608 (delete-region (save-excursion (beginning-of-line)
610 (save-excursion (end-of-line)
616 (progn (wl-folder-goto-bottom-of-current-folder indent)
619 (setq entity (wl-folder-search-group-entity-by-name
622 (let ((buffer-read-only nil))
623 (delete-region beg end))
624 (setcdr (assoc (car entity) wl-folder-group-alist) nil)
625 (wl-folder-insert-entity indent entity) ; insert entity
627 (wl-highlight-folder-path wl-folder-buffer-cur-path)
628 ; (wl-delete-all-overlays)
629 ; (wl-highlight-folder-current-line)
631 ((setq fld-name (wl-folder-entity-name))
634 (wl-folder-set-current-entity-id
635 (wl-folder-get-entity-from-buffer))
636 (setq fld-name (wl-folder-get-realname fld-name)))
637 (wl-folder-set-current-entity-id
638 (get-text-property (point) 'wl-folder-entity-id))
639 (setq fld-name (wl-folder-get-folder-name-by-id
640 wl-folder-buffer-cur-entity-id)))
641 (let ((summary-buf (wl-summary-get-buffer-create fld-name arg))
643 (if wl-stay-folder-window
644 (wl-folder-select-buffer summary-buf)
646 (get-buffer-window summary-buf))
648 (wl-summary-goto-folder-subr fld-name
649 (wl-summary-get-sync-range fld-name)
651 (set-buffer-modified-p nil))
653 (defun wl-folder-close-entity (entity)
654 (let ((entities (list entity))
657 (setq entity (wl-pop entities))
660 (setcdr (assoc (car entity) wl-folder-group-alist) nil)
662 (wl-push entities entity-stack))
663 (setq entities (nth 2 entity))))
665 (setq entities (wl-pop entity-stack))))))
667 (defun wl-folder-update-recursive-current-entity (&optional entity)
669 (when (wl-folder-buffer-group-p)
671 ((string= (wl-match-buffer 2) "+")
675 (wl-folder-search-group-entity-by-name
676 (wl-folder-get-realname (wl-match-buffer 3))
678 (let ((inhibit-read-only t)
679 (entities (list entity))
680 entity-stack err indent)
681 (while (and entities (not err))
682 (setq entity (wl-pop entities))
685 (wl-folder-close-entity entity)
686 (setcdr (assoc (car entity) wl-folder-group-alist) t)
687 (unless (wl-folder-buffer-search-group
688 (wl-folder-get-petname (car entity)))
689 (error "%s: not found group" (car entity)))
690 (setq indent (wl-match-buffer 1))
691 (if (eq 'access (cadr entity))
692 (wl-folder-maybe-load-folder-list entity))
696 (condition-case errobj
697 (wl-folder-update-newest indent entity)
700 (setcdr (assoc (car entity) wl-folder-group-alist) nil))
702 (elmo-display-error errobj t)
705 (setcdr (assoc (car entity) wl-folder-group-alist) nil)))
707 (delete-region (save-excursion (beginning-of-line)
709 (save-excursion (end-of-line)
713 (wl-push entities entity-stack))
714 (setq entities (nth 2 entity))))
716 (setq entities (wl-pop entity-stack)))))
717 (set-buffer-modified-p nil)))
719 (wl-folder-jump-to-current-entity)))))
721 (defun wl-folder-no-auto-check-folder-p (folder)
724 (let ((li wl-auto-check-folder-list))
726 (if (string-match (car li) folder)
728 (setq li (cdr li)))))
731 (let ((li wl-auto-uncheck-folder-list))
733 (if (string-match (car li) folder)
734 (throw 'found t)) ; no check!
735 (setq li (cdr li))))))))
737 (defsubst wl-folder-add-folder-info (pre-value value)
739 (+ (or (nth 0 pre-value) 0) (or (nth 0 value) 0))
740 (+ (or (nth 1 pre-value) 0) (or (nth 1 value) 0))
741 (+ (or (nth 2 pre-value) 0) (or (nth 2 value) 0))))
743 (defun wl-folder-check-entity (entity &optional auto)
744 "Check unsync message number."
745 (let ((start-pos (point))
747 (run-hooks 'wl-folder-check-entity-pre-hook)
748 (if (and (consp entity) ;; group entity
749 wl-folder-check-async) ;; very fast
750 (setq ret-val (wl-folder-check-entity-async entity auto))
754 (let ((flist (if auto
756 'wl-folder-no-auto-check-folder-p
759 (wl-folder-check-entity-pre-hook nil)
760 (wl-folder-check-entity-hook nil)
764 (wl-folder-add-folder-info
766 (wl-folder-check-entity (car flist))))
767 (setq flist (cdr flist)))
768 ;(wl-folder-buffer-search-entity (car entity))
769 ;(wl-folder-update-line ret-val)
771 ((and (stringp entity)
772 (elmo-folder-plugged-p entity))
773 (message "Checking \"%s\"" entity)
774 (setq ret-val (wl-folder-check-one-entity entity))
775 (goto-char start-pos)
778 (message "Uncheck(unplugged) \"%s\"" entity)))))
780 (message "Checking \"%s\" is done."
781 (if (consp entity) (car entity) entity)))
782 (run-hooks 'wl-folder-check-entity-hook)
785 ;; All contained folders are imap4 and persistent flag, then
787 (defun wl-folder-use-server-diff-p (folder)
788 (let ((spec (elmo-folder-get-spec folder)))
790 ((eq (car spec) 'multi)
791 (let ((folders (cdr spec)))
794 (if (wl-folder-use-server-diff-p (car folders))
796 (setq folders (cdr folders)))
798 ((eq (car spec) 'filter)
799 (wl-folder-use-server-diff-p (nth 2 spec)))
800 ((eq (car spec) 'imap4)
801 (and wl-folder-use-server-diff
802 (elmo-imap4-use-flag-p spec)))
805 (defun wl-folder-check-one-entity (entity)
806 (let* ((elmo-use-server-diff (wl-folder-use-server-diff-p entity))
807 (nums (condition-case err
808 (if (wl-string-match-member entity wl-strict-diff-folders)
809 (elmo-strict-folder-diff entity)
810 (elmo-folder-diff entity))
812 ;; maybe not exist folder.
813 (if (and (not (memq 'elmo-open-error
814 (get (car err) 'error-conditions)))
815 (not (elmo-folder-exists-p entity)))
816 (wl-folder-create-subr entity)
817 (signal (car err) (cdr err))))))
819 (if (and (eq wl-folder-notify-deleted 'sync)
821 (or (> 0 (car nums)) (> 0 (cdr nums))))
823 (wl-folder-sync-entity entity)
824 (setq nums (elmo-folder-diff entity)))
825 (unless wl-folder-notify-deleted
826 (setq unsync (if (and (car nums) (> 0 (car nums))) 0 (car nums)))
827 (setq nomif (if (and (car nums) (> 0 (cdr nums))) 0 (cdr nums)))
828 (setq nums (cons unsync nomif)))
829 (wl-folder-entity-hashtb-set wl-folder-entity-hashtb entity
834 ;; If server diff, All unreads are
835 ;; treated as unsync.
836 (if elmo-use-server-diff 0)
837 (elmo-folder-get-info-unread entity)
838 (wl-summary-count-unread
839 (elmo-msgdb-mark-load
840 (elmo-msgdb-expand-path entity))
844 (setq wl-folder-info-alist-modified t)
846 (list (if wl-folder-notify-deleted
848 (max (or (car nums) 0))) unread (cdr nums))))
850 (defun wl-folder-check-entity-async (entity &optional auto)
851 (let ((elmo-nntp-groups-async t)
854 'wl-folder-no-auto-check-folder-p
855 (wl-folder-get-entity-list entity))
856 (wl-folder-get-entity-list entity)))
857 (nntp-connection-keys nil)
858 folder spec-list local-elist net-elist server
861 (if (not (elmo-folder-plugged-p (car elist)))
862 (message "Uncheck \"%s\"" (car elist))
864 (elmo-folder-get-primitive-spec-list (elmo-string (car elist))))
865 (cond ((assq 'nntp spec-list)
866 (wl-append net-elist (list (car elist)))
868 (when (eq (caar spec-list) 'nntp)
869 (when (not (string= server (elmo-nntp-spec-hostname (car spec-list))))
870 (setq server (elmo-nntp-spec-hostname (car spec-list)))
871 (message "Checking on \"%s\"" server))
872 (setq nntp-connection-keys
873 (elmo-nntp-get-folders-info-prepare
875 nntp-connection-keys)))
876 (setq spec-list (cdr spec-list))))
878 (wl-append local-elist (list (car elist))))))
879 (setq elist (cdr elist)))
880 ;; check local entity at first
881 (while (setq folder (pop local-elist))
882 (if (not (elmo-folder-plugged-p folder))
883 (message "Uncheck \"%s\"" folder)
884 (message "Checking \"%s\"" folder)
886 (wl-folder-add-folder-info
888 (wl-folder-check-one-entity folder)))
891 ;; check network entity at last
893 (elmo-nntp-get-folders-info nntp-connection-keys)
894 (while (setq folder (pop net-elist))
895 (if (not (elmo-folder-plugged-p folder))
896 (message "Uncheck \"%s\"" folder)
897 (message "Checking \"%s\"" folder)
899 (wl-folder-add-folder-info
901 (wl-folder-check-one-entity folder)))
907 (defun wl-folder-resume-entity-hashtb-by-finfo (entity-hashtb info-alist)
908 "Resume unread info for entity alist."
911 (setq info (nth 1 (car info-alist)))
912 (wl-folder-set-entity-info (caar info-alist)
913 (list (nth 2 info)(nth 3 info)(nth 1 info))
915 (setq info-alist (cdr info-alist)))))
917 (defun wl-folder-move-path (path)
918 (let ((fp (if (consp path)
921 (wl-folder-get-path wl-folder-entity path))))
922 (goto-char (point-min))
925 (when (equal (car fp)
926 (wl-folder-get-entity-from-buffer t))
928 (setq wl-folder-buffer-cur-point (point)))
930 (and wl-folder-buffer-cur-point
931 (goto-char wl-folder-buffer-cur-point))))
933 (defun wl-folder-set-current-entity-id (entity-id)
934 (let ((buf (get-buffer wl-folder-buffer-name)))
938 (setq wl-folder-buffer-cur-entity-id entity-id)
939 (setq wl-folder-buffer-cur-path (wl-folder-get-path wl-folder-entity
941 (wl-highlight-folder-path wl-folder-buffer-cur-path)
942 (and wl-folder-move-cur-folder
943 wl-folder-buffer-cur-point
944 (goto-char wl-folder-buffer-cur-point))))
945 (if (eq (current-buffer) buf)
946 (and wl-folder-move-cur-folder
947 wl-folder-buffer-cur-point
948 (goto-char wl-folder-buffer-cur-point)))))
950 (defun wl-folder-check-current-entity ()
951 "Check folder at position.
952 If current line is group folder, check all sub entries."
954 (let* ((entity-name (wl-folder-get-entity-from-buffer))
955 (group (wl-folder-buffer-group-p))
956 (desktop (string= entity-name wl-folder-desktop-name)))
958 (wl-folder-check-entity
960 (wl-folder-search-group-entity-by-name entity-name
965 (defun wl-folder-sync-entity (entity &optional unread-only)
966 "Synchronize the msgdb of ENTITY."
969 (let ((flist (nth 2 entity)))
971 (wl-folder-sync-entity (car flist) unread-only)
972 (setq flist (cdr flist)))))
974 (let ((nums (wl-folder-get-entity-info entity))
975 (wl-summary-highlight (if (or (wl-summary-sticky-p entity)
976 (wl-summary-always-sticky-folder-p
978 wl-summary-highlight))
979 wl-auto-select-first new unread)
980 (setq new (or (car nums) 0))
981 (setq unread (or (cadr nums) 0))
982 (if (or (not unread-only)
983 (or (< 0 new) (< 0 unread)))
984 (save-window-excursion
986 (wl-summary-goto-folder-subr entity
987 (wl-summary-get-sync-range entity)
989 (wl-summary-exit))))))))
991 (defun wl-folder-sync-current-entity (&optional unread-only)
992 "Synchronize the folder at position.
993 If current line is group folder, check all subfolders."
996 (let ((entity-name (wl-folder-get-entity-from-buffer))
997 (group (wl-folder-buffer-group-p)))
998 (when (and entity-name
999 (y-or-n-p (format "Sync %s?" entity-name)))
1000 (wl-folder-sync-entity
1002 (wl-folder-search-group-entity-by-name entity-name
1006 (message "Syncing %s is done!" entity-name)))))
1008 (defun wl-folder-mark-as-read-all-entity (entity)
1009 "Mark as read all messages in the ENTITY."
1012 (let ((flist (nth 2 entity)))
1014 (wl-folder-mark-as-read-all-entity (car flist))
1015 (setq flist (cdr flist)))))
1017 (let ((nums (wl-folder-get-entity-info entity))
1018 (wl-summary-highlight (if (or (wl-summary-sticky-p entity)
1019 (wl-summary-always-sticky-folder-p
1021 wl-summary-highlight))
1022 wl-auto-select-first new unread)
1023 (setq new (or (car nums) 0))
1024 (setq unread (or (cadr nums) 0))
1025 (if (or (< 0 new) (< 0 unread))
1026 (save-window-excursion
1028 (wl-summary-goto-folder-subr entity
1029 (wl-summary-get-sync-range entity)
1031 (wl-summary-mark-as-read-all)
1035 (defun wl-folder-mark-as-read-all-current-entity ()
1036 "Mark as read all messages in the folder at position.
1037 If current line is group folder, all subfolders are marked."
1040 (let ((entity-name (wl-folder-get-entity-from-buffer))
1041 (group (wl-folder-buffer-group-p))
1043 (when (and entity-name
1044 (y-or-n-p (format "Mark all messages in %s as read?" entity-name)))
1045 (wl-folder-mark-as-read-all-entity
1047 (wl-folder-search-group-entity-by-name entity-name
1050 (message "All messages in %s are marked!" entity-name)))))
1052 (defun wl-folder-check-region (beg end)
1061 (let ((inhibit-read-only t)
1063 (while (< (point) end)
1064 ;; normal folder entity
1065 (if (looking-at "^[\t ]*\\([^\\[]+\\):\\(.*\\)\n")
1067 (setq entity (wl-folder-get-entity-from-buffer))
1068 (if (not (elmo-folder-plugged-p entity))
1069 (message "Uncheck %s" entity)
1070 (message "Checking %s" entity)
1071 (wl-folder-check-one-entity entity)
1076 (defun wl-folder-sync-region (beg end)
1085 (while (< (point) end)
1086 ;; normal folder entity
1087 (if (looking-at "^[\t ]*\\([^\\[]+\\):\\(.*\\)\n")
1089 (let ((inhibit-read-only t)
1091 (setq entity (wl-folder-get-entity-from-buffer))
1092 (wl-folder-sync-entity entity)
1093 (message "Syncing %s is done!" entity)
1098 (defun wl-folder-mark-as-read-all-region (beg end)
1107 (while (< (point) end)
1108 ;; normal folder entity
1109 (if (looking-at "^[\t ]*\\([^\\[]+\\):\\(.*\\)\n")
1111 (let ((inhibit-read-only t)
1113 (setq entity (wl-folder-get-entity-from-buffer))
1114 (wl-folder-mark-as-read-all-entity entity)
1115 (message "All messages in %s are marked!" entity)
1120 (defsubst wl-create-access-init-load-p (folder)
1121 (let ((no-load-regexp (when (and
1122 (not wl-folder-init-load-access-folders)
1123 wl-folder-init-no-load-access-folders)
1124 (mapconcat 'identity
1125 wl-folder-init-no-load-access-folders
1127 (load-regexp (and wl-folder-init-load-access-folders
1128 (mapconcat 'identity
1129 wl-folder-init-load-access-folders
1131 (cond (load-regexp (string-match load-regexp folder))
1132 (t (not (and no-load-regexp
1133 (string-match no-load-regexp folder)))))))
1135 (defun wl-create-access-folder-entity (name)
1137 (when (wl-create-access-init-load-p name)
1138 (setq flists (elmo-msgdb-flist-load name)) ; load flist.
1139 (setq flist (car flists))
1141 (when (consp (car flist))
1142 (setcdr (cdar flist)
1143 (wl-create-access-folder-entity (caar flist))))
1144 (setq flist (cdr flist)))
1147 (defun wl-create-folder-entity-from-buffer ()
1148 "Create folder entity recursively."
1150 ((looking-at "^[ \t]*$") ; blank line
1151 (goto-char (+ 1(match-end 0)))
1153 ((looking-at "^#.*$") ; comment
1154 (goto-char (+ 1 (match-end 0)))
1156 ((looking-at "^[\t ]*\\(.+\\)[\t ]*{[\t ]*$") ; group definition
1157 (let (name entity flist)
1158 (setq name (wl-match-buffer 1))
1159 (goto-char (+ 1 (match-end 0)))
1160 (while (setq entity (wl-create-folder-entity-from-buffer))
1161 (unless (eq entity 'ignore)
1162 (wl-append flist (list entity))))
1163 (if (looking-at "^[\t ]*}[\t ]*$") ; end of group
1165 (goto-char (+ 1 (match-end 0)))
1166 (if (wl-string-assoc name wl-folder-petname-alist)
1167 (error "%s already defined as petname" name))
1168 (list name 'group flist))
1169 (error "Syntax error in folder definition"))))
1170 ((looking-at "^[\t ]*\\([^\t \n]+\\)[\t ]*/$") ; access it!
1172 (setq name (wl-match-buffer 1))
1173 (goto-char (+ 1 (match-end 0)))
1174 ; (condition-case ()
1176 ; (setq flist (elmo-list-folders name)))
1177 ; (error (message "Access to folder %s failed." name)))
1178 ;; (setq flist (elmo-msgdb-flist-load name)) ; load flist.
1179 ;; (setq unsublist (nth 1 flist))
1180 ;; (setq flist (car flist))
1181 ;; (list name 'access flist unsublist)))
1182 (append (list name 'access) (wl-create-access-folder-entity name))))
1183 ;((looking-at "^[\t ]*\\([^\t \n}]+\\)[\t ]*\\(\"[^\"]*\"\\)?[\t ]*$") ; normal folder entity
1184 ((looking-at "^[\t ]*=[ \t]+\\([^\n]+\\)$"); petname definition
1185 (goto-char (+ 1 (match-end 0)))
1186 (let ((rest (elmo-match-buffer 1))
1188 (when (string-match "\\(\"[^\"]*\"\\)[\t ]*$" rest)
1189 (setq petname (elmo-delete-char ?\" (elmo-match-string 1 rest)))
1190 (setq rest (substring rest 0 (match-beginning 0))))
1191 (when (string-match "^[\t ]*\\(.*[^\t ]+\\)[\t ]+$" rest)
1192 (wl-folder-append-petname (elmo-match-string 1 rest)
1195 ((looking-at "^[ \t]*}[ \t]*$") ; end of group
1197 ((looking-at "^.*$") ; normal folder entity
1198 (goto-char (+ 1 (match-end 0)))
1199 (let ((rest (elmo-match-buffer 0))
1201 (if (string-match "\\(\"[^\"]*\"\\)[\t ]*$" rest)
1203 (setq petname (elmo-delete-char ?\" (elmo-match-string 1 rest)))
1204 (setq rest (substring rest 0 (match-beginning 0)))
1205 (when (string-match "^[\t ]*\\(.*[^\t ]+\\)[\t ]+$" rest)
1206 (wl-folder-append-petname
1207 (setq realname (elmo-match-string 1 rest))
1210 (if (string-match "^[\t ]*\\(.+\\)$" rest)
1211 (elmo-match-string 1 rest)
1214 (defun wl-folder-create-folder-entity ()
1215 "Create folder entries."
1216 (let ((tmp-buf (get-buffer-create " *wl-folder-tmp*"))
1220 (with-current-buffer tmp-buf
1222 (insert-file-contents wl-folders-file)
1223 (goto-char (point-min))
1224 (while (and (not (eobp))
1225 (setq entity (wl-create-folder-entity-from-buffer)))
1226 (unless (eq entity 'ignore)
1227 (wl-append ret-val (list entity)))))
1228 (kill-buffer tmp-buf))
1230 (setq ret-val (list wl-folder-desktop-name 'group ret-val))))
1232 (defun wl-folder-entity-assign-id (entity &optional hashtb on-noid)
1233 (let ((hashtb (or hashtb
1234 (setq wl-folder-entity-id-name-hashtb
1235 (elmo-make-hash wl-folder-entity-id))))
1236 (entities (list entity))
1239 (setq entity (wl-pop entities))
1242 (when (not (and on-noid
1243 (get-text-property 0
1244 'wl-folder-entity-id
1246 (put-text-property 0 (length (car entity))
1247 'wl-folder-entity-id
1250 (wl-folder-set-id-name wl-folder-entity-id
1251 (car entity) hashtb))
1253 (wl-push entities entity-stack))
1254 (setq entities (nth 2 entity)))
1256 (when (not (and on-noid
1257 (get-text-property 0
1258 'wl-folder-entity-id
1260 (put-text-property 0 (length entity)
1261 'wl-folder-entity-id
1264 (wl-folder-set-id-name wl-folder-entity-id
1266 (setq wl-folder-entity-id (+ 1 wl-folder-entity-id))
1268 (setq entities (wl-pop entity-stack))))))
1270 (defun wl-folder-click (e)
1275 (wl-folder-jump-to-current-entity)))
1277 (defun wl-folder-select-buffer (buffer)
1278 (let ((gbw (get-buffer-window buffer))
1281 (progn (select-window gbw)
1285 (split-window-horizontally wl-folder-window-width)
1289 (switch-to-buffer buffer)
1293 (defun wl-folder-toggle-disp-summary (&optional arg folder)
1295 (if (or (and folder (assoc folder wl-folder-group-alist))
1296 (and (interactive-p) (wl-folder-buffer-group-p)))
1297 (error "This command is not available on Group"))
1299 (let (wl-auto-select-first)
1302 (setq wl-folder-buffer-disp-summary t))
1304 (setq wl-folder-buffer-disp-summary nil)
1305 ;; hide wl-summary window.
1306 (let ((cur-buf (current-buffer))
1307 (summary-buffer (wl-summary-get-buffer folder)))
1308 (wl-folder-select-buffer summary-buffer)
1310 (select-window (get-buffer-window cur-buf))))
1312 (setq wl-folder-buffer-disp-summary
1313 (not wl-folder-buffer-disp-summary))
1314 (let ((cur-buf (current-buffer))
1316 (when (looking-at "^[ ]*\\([^\\[].+\\):.*\n")
1317 (setq folder-name (wl-folder-get-entity-from-buffer))
1318 (if wl-folder-buffer-disp-summary
1320 (wl-folder-select-buffer
1321 (wl-summary-get-buffer-create folder-name))
1323 (wl-summary-goto-folder-subr folder-name 'no-sync nil)
1324 (select-window (get-buffer-window cur-buf))))
1325 (wl-folder-select-buffer (wl-summary-get-buffer folder-name))
1327 (select-window (get-buffer-window cur-buf)))))))))
1329 (defun wl-folder-prev-unsync ()
1330 "Move cursor to the previous unsync folder."
1333 (setq start-point (point))
1335 (if (re-search-backward wl-folder-unsync-regexp nil t)
1337 (goto-char start-point)
1338 (message "No more unsync folder"))))
1340 (defun wl-folder-next-unsync (&optional plugged)
1341 "Move cursor to the next unsync."
1343 (let (start-point entity)
1344 (setq start-point (point))
1347 (while (re-search-forward wl-folder-unsync-regexp nil t)
1348 (if (or (wl-folder-buffer-group-p)
1351 (wl-folder-get-realname
1352 (wl-folder-folder-name)))
1353 (elmo-folder-plugged-p entity))
1356 (goto-char start-point)
1357 (message "No more unsync folder"))))
1359 (defun wl-folder-prev-unread (&optional group)
1360 "Move cursor to the previous unread folder."
1363 (setq start-point (point))
1365 (if (re-search-backward (wl-folder-unread-regex group) nil t)
1368 (wl-folder-folder-name))
1369 (goto-char start-point)
1370 (message "No more unread folder")
1373 (defun wl-folder-next-unread (&optional group)
1374 "Move cursor to the next unread folder."
1377 (setq start-point (point))
1379 (if (re-search-forward (wl-folder-unread-regex group) nil t)
1382 (wl-folder-folder-name))
1383 (goto-char start-point)
1384 (message "No more unread folder")
1387 (defun wl-folder-mode ()
1388 "Major mode for Wanderlust Folder.
1389 See info under Wanderlust for full documentation.
1392 \\{wl-folder-mode-map}
1394 Entering Folder mode calls the value of `wl-folder-mode-hook'."
1396 (setq major-mode 'wl-folder-mode)
1397 (setq mode-name "Folder")
1398 (use-local-map wl-folder-mode-map)
1399 (setq buffer-read-only t)
1400 (setq inhibit-read-only nil)
1401 (setq truncate-lines t)
1402 (setq wl-folder-buffer-cur-entity-id nil
1403 wl-folder-buffer-cur-path nil
1404 wl-folder-buffer-cur-point nil)
1405 (wl-mode-line-buffer-identification)
1406 (easy-menu-add wl-folder-mode-menu)
1407 ;; This hook may contain the functions `wl-folder-init-icons' and
1408 ;; `wl-setup-folder' for reasons of system internal to accord
1409 ;; facilities for the Emacs variants.
1410 (run-hooks 'wl-folder-mode-hook))
1412 (defun wl-folder-append-petname (realname petname)
1414 ;; check group name.
1415 (if (wl-folder-search-group-entity-by-name petname wl-folder-entity)
1416 (error "%s already defined as group name" petname))
1417 (when (setq pentry (wl-string-assoc realname wl-folder-petname-alist))
1418 (setq wl-folder-petname-alist
1419 (delete pentry wl-folder-petname-alist)))
1420 (wl-append wl-folder-petname-alist
1421 (list (cons realname petname)))))
1423 (defun wl-folder (&optional arg)
1426 ;;; (delete-other-windows)
1427 (if (get-buffer wl-folder-buffer-name)
1428 (switch-to-buffer wl-folder-buffer-name)
1429 (switch-to-buffer (get-buffer-create wl-folder-buffer-name))
1432 (set-buffer wl-folder-buffer-name)
1433 (let ((inhibit-read-only t)
1434 (buffer-read-only nil))
1436 (setcdr (assoc (car wl-folder-entity) wl-folder-group-alist) t)
1438 (wl-folder-insert-entity " " wl-folder-entity)))
1439 (set-buffer-modified-p nil)
1441 (setq initialize t))
1444 (defun wl-folder-auto-check ()
1445 "Check and update folders in `wl-auto-check-folder-name'."
1447 (when (get-buffer wl-folder-buffer-name)
1448 (switch-to-buffer wl-folder-buffer-name)
1450 ((eq wl-auto-check-folder-name 'none))
1451 ((or (consp wl-auto-check-folder-name)
1452 (stringp wl-auto-check-folder-name))
1453 (let ((folder-list (if (consp wl-auto-check-folder-name)
1454 wl-auto-check-folder-name
1455 (list wl-auto-check-folder-name)))
1458 (if (setq entity (wl-folder-search-entity-by-name
1461 (wl-folder-check-entity entity 'auto))
1462 (setq folder-list (cdr folder-list)))))
1464 (wl-folder-check-entity wl-folder-entity 'auto)))))
1466 (defun wl-folder-set-folder-updated (name value)
1469 (if (setq buf (get-buffer wl-folder-buffer-name))
1470 (wl-folder-entity-hashtb-set
1471 wl-folder-entity-hashtb name value buf))
1472 ;;; (elmo-folder-set-info-hashtb (elmo-string name)
1477 (setq wl-folder-info-alist-modified t))))
1479 (defun wl-folder-calc-finfo (entity)
1480 ;; calcurate finfo without inserting.
1481 (let ((entities (list entity))
1483 new unread all nums)
1485 (setq entity (wl-pop entities))
1489 (wl-push entities entity-stack))
1490 (setq entities (nth 2 entity)))
1492 (setq nums (wl-folder-get-entity-info entity))
1493 (setq new (+ (or new 0) (or (nth 0 nums) 0)))
1494 (setq unread (+ (or unread 0)
1495 (or (and (nth 0 nums)(nth 1 nums)
1496 (+ (nth 0 nums)(nth 1 nums))) 0)))
1497 (setq all (+ (or all 0) (or (nth 2 nums) 0)))))
1499 (setq entities (wl-pop entity-stack))))
1500 (list new unread all)))
1502 (defsubst wl-folder-make-save-access-list (list)
1503 (mapcar '(lambda (x)
1506 (list (elmo-string (car x)) 'access))
1511 (defun wl-folder-update-newest (indent entity)
1512 (let (ret-val new unread all)
1515 (let ((inhibit-read-only t)
1516 (buffer-read-only nil)
1517 (flist (nth 2 entity))
1518 (as-opened (cdr (assoc (car entity) wl-folder-group-alist)))
1523 (let (update-flist flist-unsub new-flist removed group-name-end)
1524 (when (and (eq (cadr entity) 'access)
1525 (elmo-folder-plugged-p (car entity)))
1526 (message "Fetching folder entries...")
1527 (when (setq new-flist
1529 (elmo-string (car entity))
1532 wl-folder-hierarchy-access-folders)))
1534 (wl-folder-update-access-group entity new-flist))
1535 (setq flist (nth 1 update-flist))
1536 (when (car update-flist) ;; diff
1537 (setq flist-unsub (nth 2 update-flist))
1538 (setq removed (nth 3 update-flist))
1539 (elmo-msgdb-flist-save
1542 (wl-folder-make-save-access-list flist)
1543 (wl-folder-make-save-access-list flist-unsub)))
1544 (wl-folder-entity-assign-id
1546 wl-folder-entity-id-name-hashtb
1548 (setq wl-folder-entity-hashtb
1549 (wl-folder-create-entity-hashtb
1551 wl-folder-entity-hashtb
1553 (setq wl-folder-newsgroups-hashtb
1555 (wl-folder-create-newsgroups-hashtb
1557 wl-folder-newsgroups-hashtb))))
1558 (message "Fetching folder entries...done"))
1559 (wl-folder-insert-entity indent entity))))))))
1561 (defun wl-folder-insert-entity (indent entity &optional onlygroup)
1562 (let (ret-val new unread all)
1565 (let ((inhibit-read-only t)
1566 (buffer-read-only nil)
1567 (flist (nth 2 entity))
1568 (as-opened (cdr (assoc (car entity) wl-folder-group-alist)))
1571 ;;; (insert indent "[" (if as-opened "-" "+") "]" (car entity) "\n")
1572 ;;; (save-excursion (forward-line -1)
1573 ;;; (wl-highlight-folder-current-line))
1577 (let (update-flist flist-unsub new-flist removed group-name-end)
1578 ;;; (when (and (eq (cadr entity) 'access)
1580 ;;; (message "fetching folder entries...")
1581 ;;; (when (setq new-flist
1582 ;;; (elmo-list-folders
1583 ;;; (elmo-string (car entity))
1584 ;;; (wl-string-member
1586 ;;; wl-folder-hierarchy-access-folders)
1588 ;;; (setq update-flist
1589 ;;; (wl-folder-update-access-group entity new-flist))
1590 ;;; (setq flist (nth 1 update-flist))
1591 ;;; (when (car update-flist) ;; diff
1592 ;;; (setq flist-unsub (nth 2 update-flist))
1593 ;;; (setq removed (nth 3 update-flist))
1594 ;;; (elmo-msgdb-flist-save
1597 ;;; (wl-folder-make-save-access-list flist)
1598 ;;; (wl-folder-make-save-access-list flist-unsub)))
1600 ;;; ;; reconstruct wl-folder-entity-id-name-hashtb and
1601 ;;; ;; wl-folder-entity-hashtb
1603 ;;; (wl-folder-entity-assign-id
1605 ;;; wl-folder-entity-id-name-hashtb
1607 ;;; (setq wl-folder-entity-hashtb
1608 ;;; (wl-folder-create-entity-hashtb
1610 ;;; wl-folder-entity-hashtb
1612 ;;; (setq wl-folder-newsgroups-hashtb
1614 ;;; (wl-folder-create-newsgroups-hashtb
1616 ;;; wl-folder-newsgroups-hashtb))))
1617 ;;; (message "fetching folder entries...done"))
1618 (insert indent "[" (if as-opened "-" "+") "]"
1619 (wl-folder-get-petname (car entity)))
1620 (setq group-name-end (point))
1622 (put-text-property beg (point) 'wl-folder-entity-id
1623 (get-text-property 0 'wl-folder-entity-id
1629 wl-folder-removed-mark
1630 (if (listp (car removed))
1631 (concat "[+]" (caar removed))
1634 (save-excursion (forward-line -1)
1635 (wl-highlight-folder-current-line))
1636 (setq removed (cdr removed)))
1637 (remove-text-properties beg (point) '(wl-folder-entity-id)))
1638 (let* ((len (length flist))
1643 (wl-folder-insert-entity
1644 (concat indent " ") (car flist)))
1645 (setq new (+ (or new 0) (or (nth 0 ret-val) 0)))
1646 (setq unread (+ (or unread 0) (or (nth 1 ret-val) 0)))
1647 (setq all (+ (or all 0) (or (nth 2 ret-val) 0)))
1649 (> len elmo-display-progress-threshold))
1651 (elmo-display-progress
1652 'wl-folder-insert-entity "Inserting group %s..."
1653 (/ (* i 100) len) (car entity)))
1654 (setq flist (cdr flist))))
1656 (goto-char group-name-end)
1657 (delete-region (point) (save-excursion (end-of-line)
1659 (insert (format ":%d/%d/%d" (or new 0)
1660 (or unread 0) (or all 0)))
1661 (setq ret-val (list new unread all))
1662 (wl-highlight-folder-current-line ret-val)))
1663 (setq ret-val (wl-folder-calc-finfo entity))
1664 (insert indent "[" (if as-opened "-" "+") "]"
1665 (wl-folder-get-petname (car entity))
1667 (or (nth 0 ret-val) 0)
1668 (or (nth 1 ret-val) 0)
1669 (or (nth 2 ret-val) 0))
1671 (put-text-property beg (point) 'wl-folder-entity-id
1672 (get-text-property 0 'wl-folder-entity-id
1674 (save-excursion (forward-line -1)
1675 (wl-highlight-folder-current-line ret-val)))))
1677 (let* ((inhibit-read-only t)
1678 (buffer-read-only nil)
1679 (nums (wl-folder-get-entity-info entity))
1682 (insert indent (wl-folder-get-petname entity)
1683 (format ":%s/%s/%s\n"
1684 (or (setq new (nth 0 nums)) "*")
1685 (or (setq unread (and (nth 0 nums)(nth 1 nums)
1686 (+ (nth 0 nums)(nth 1 nums))))
1688 (or (setq all (nth 2 nums)) "*")))
1689 (put-text-property beg (point) 'wl-folder-entity-id
1690 (get-text-property 0 'wl-folder-entity-id entity))
1691 (save-excursion (forward-line -1)
1692 (wl-highlight-folder-current-line nums))
1693 (setq ret-val (list new unread all)))))
1694 (set-buffer-modified-p nil)
1697 (defun wl-folder-check-all ()
1699 (wl-folder-check-entity wl-folder-entity))
1701 (defun wl-folder-entity-hashtb-set (entity-hashtb name value buffer)
1708 (setq cur-val (wl-folder-get-entity-info name entity-hashtb))
1709 (setq new-diff (- (or (nth 0 value) 0) (or (nth 0 cur-val) 0)))
1712 (- (or (nth 1 value) 0) (or (nth 1 cur-val) 0))))
1713 (setq all-diff (- (or (nth 2 value) 0) (or (nth 2 cur-val) 0)))
1714 (setq diffs (list new-diff unread-diff all-diff))
1715 (unless (and (nth 0 cur-val)
1716 (equal diffs '(0 0 0)))
1717 (wl-folder-set-entity-info name value entity-hashtb)
1721 (setq entity-list (wl-folder-search-entity-list-by-name
1722 name wl-folder-entity))
1724 (wl-folder-update-group (car entity-list) diffs)
1725 (setq entity-list (cdr entity-list)))
1726 (goto-char (point-min))
1727 (while (wl-folder-buffer-search-entity name)
1728 (wl-folder-update-line value)))))))
1730 (defun wl-folder-update-unread (folder unread)
1731 (save-window-excursion
1732 (let ((buf (get-buffer wl-folder-buffer-name))
1735 ;;(fld (elmo-string folder))
1736 value newvalue entity-list)
1737 ;;; Update folder-info
1738 ;;; (elmo-folder-set-info-hashtb fld nil nil nil unread)
1739 (setq cur-unread (or (nth 1 (wl-folder-get-entity-info folder)) 0))
1740 (setq unread-diff (- (or unread 0) cur-unread))
1741 (setq value (wl-folder-get-entity-info folder))
1743 (setq newvalue (list (nth 0 value)
1746 (wl-folder-set-entity-info folder newvalue)
1747 (setq wl-folder-info-alist-modified t)
1749 (not (eq unread-diff 0)))
1754 (setq entity-list (wl-folder-search-entity-list-by-name
1755 folder wl-folder-entity))
1757 (wl-folder-update-group (car entity-list) (list 0
1760 (setq entity-list (cdr entity-list)))
1761 (goto-char (point-min))
1762 (while (wl-folder-buffer-search-entity folder)
1763 (wl-folder-update-line newvalue)))))))))
1765 (defun wl-folder-create-entity-hashtb (entity &optional hashtb reconst)
1766 (let ((hashtb (or hashtb (elmo-make-hash wl-folder-entity-id)))
1767 (entities (list entity))
1770 (setq entity (wl-pop entities))
1774 (wl-push entities entity-stack))
1775 (setq entities (nth 2 entity)))
1777 (when (not (and reconst
1778 (wl-folder-get-entity-info entity)))
1779 (wl-folder-set-entity-info entity
1783 (setq entities (wl-pop entity-stack))))
1786 ;; Unsync number is reserved.
1787 ;;(defun wl-folder-reconstruct-entity-hashtb (entity &optional hashtb id-name)
1788 ;; (let* ((hashtb (or hashtb (elmo-make-hash wl-folder-entity-id)))
1789 ;; (entities (list entity))
1792 ;; (setq entity (wl-pop entities))
1796 ;; (wl-folder-set-id-name (wl-folder-get-entity-id (car entity))
1799 ;; (wl-push entities entity-stack))
1800 ;; (setq entities (nth 2 entity))
1802 ;; ((stringp entity)
1803 ;; (wl-folder-set-entity-info entity
1804 ;; (wl-folder-get-entity-info entity)
1807 ;; (wl-folder-set-id-name (wl-folder-get-entity-id entity)
1810 ;; (setq entities (wl-pop entity-stack))))
1813 (defun wl-folder-create-newsgroups-from-nntp-access2 (entity)
1814 (let ((flist (nth 2 entity))
1823 (wl-folder-create-newsgroups-from-nntp-access2 fld)
1824 (nth 1 (elmo-folder-get-spec fld))))
1826 (elmo-nntp-make-groups-hashtb folders 1024))
1829 (defun wl-folder-create-newsgroups-from-nntp-access (entity)
1830 (let ((flist (nth 2 entity))
1835 ((consp (car flist))
1836 (wl-folder-create-newsgroups-from-nntp-access (car flist)))
1838 (list (nth 1 (elmo-folder-get-spec (car flist)))))))
1839 (setq flist (cdr flist)))
1842 (defun wl-folder-create-newsgroups-hashtb (entity &optional is-list info)
1843 (let ((entities (if is-list entity (list entity)))
1844 entity-stack spec-list folders fld make-hashtb)
1845 (and info (message "Creating newsgroups..."))
1847 (setq entity (wl-pop entities))
1850 (if (eq (nth 1 entity) 'access)
1851 (when (eq (elmo-folder-get-type (car entity)) 'nntp)
1853 (wl-folder-create-newsgroups-from-nntp-access entity))
1854 (setq make-hashtb t))
1856 (wl-push entities entity-stack))
1857 (setq entities (nth 2 entity))))
1859 (setq spec-list (elmo-folder-get-primitive-spec-list entity))
1861 (when (and (eq (caar spec-list) 'nntp)
1862 (setq fld (nth 1 (car spec-list))))
1863 (wl-append folders (list (elmo-string fld))))
1864 (setq spec-list (cdr spec-list)))))
1866 (setq entities (wl-pop entity-stack))))
1867 (and info (message "Creating newsgroups...done"))
1868 (if (or folders make-hashtb)
1869 (elmo-nntp-make-groups-hashtb folders))))
1871 (defun wl-folder-get-path (entity target-id &optional string)
1872 (let ((entities (list entity))
1873 entity-stack result-path)
1877 (setq entity (wl-pop entities))
1880 (if (and (or (not string) (string= string (car entity)))
1881 ;; don't use eq, `id' is string on Nemacs.
1882 (equal target-id (wl-folder-get-entity-id (car entity))))
1884 (wl-push target-id result-path))
1885 (wl-push (wl-folder-get-entity-id (car entity)) result-path))
1886 (wl-push entities entity-stack)
1887 (setq entities (nth 2 entity)))
1889 (if (and (or (not string) (string= string entity))
1890 ;; don't use eq, `id' is string on Nemacs.
1891 (equal target-id (wl-folder-get-entity-id entity)))
1893 (wl-push target-id result-path)))))
1895 (while (and entity-stack
1897 (setq result-path (cdr result-path))
1898 (setq entities (wl-pop entity-stack)))))))))
1900 (defun wl-folder-create-group-alist (entity)
1902 (let ((flist (nth 2 entity))
1903 (cur-alist (list (cons (car entity) nil)))
1906 (if (consp (car flist))
1907 (wl-append append-alist
1908 (wl-folder-create-group-alist (car flist))))
1909 (setq flist (cdr flist)))
1910 (append cur-alist append-alist))))
1912 (defun wl-folder-init-info-hashtb ()
1913 (let ((info-alist (and wl-folder-info-save
1914 (elmo-msgdb-finfo-load))))
1915 (elmo-folder-info-make-hashtb
1917 wl-folder-entity-hashtb)))
1918 ;;; (wl-folder-resume-entity-hashtb-by-finfo
1919 ;;; wl-folder-entity-hashtb
1922 (defun wl-folder-cleanup-variables ()
1923 (setq wl-folder-entity nil
1924 wl-folder-entity-hashtb nil
1925 wl-folder-entity-id-name-hashtb nil
1926 wl-folder-group-alist nil
1927 wl-folder-petname-alist nil
1928 wl-folder-newsgroups-hashtb nil
1929 wl-fldmgr-cut-entity-list nil
1930 wl-fldmgr-modified nil
1931 wl-fldmgr-modified-access-list nil
1935 (defun wl-make-plugged-alist ()
1936 (let ((entity-list (wl-folder-get-entity-list wl-folder-entity))
1937 (add (not wl-reset-plugged-alist)))
1939 (elmo-folder-set-plugged
1940 (elmo-string (car entity-list)) wl-plugged add)
1941 (setq entity-list (cdr entity-list)))
1942 ;; smtp posting server
1943 (when wl-smtp-posting-server
1944 (elmo-set-plugged wl-plugged
1945 wl-smtp-posting-server ; server
1946 (or (and (boundp 'smtp-service) smtp-service)
1948 nil nil "smtp" add))
1949 ;; nntp posting server
1950 (when wl-nntp-posting-server
1951 (elmo-set-plugged wl-plugged
1952 wl-nntp-posting-server
1953 elmo-default-nntp-port
1954 nil nil "nntp" add))
1955 (run-hooks 'wl-make-plugged-hook)))
1957 (defvar wl-folder-init-func 'wl-local-folder-init)
1959 (defun wl-folder-init ()
1960 "Call `wl-folder-init-func' function."
1962 (funcall wl-folder-init-func))
1964 (defun wl-local-folder-init ()
1965 "Initialize local folder."
1966 (message "Initializing folder...")
1968 (set-buffer wl-folder-buffer-name)
1969 (let ((entity (wl-folder-create-folder-entity))
1970 (inhibit-read-only t))
1971 (setq wl-folder-entity entity)
1972 (setq wl-folder-entity-id 0)
1973 (wl-folder-entity-assign-id wl-folder-entity)
1974 (setq wl-folder-entity-hashtb
1975 (wl-folder-create-entity-hashtb entity))
1976 (setq wl-folder-group-alist
1977 (wl-folder-create-group-alist entity))
1978 (setq wl-folder-newsgroups-hashtb
1979 (wl-folder-create-newsgroups-hashtb wl-folder-entity))
1980 (wl-folder-init-info-hashtb)))
1981 (message "Initializing folder...done"))
1983 (defun wl-folder-get-realname (petname)
1987 wl-folder-petname-alist))
1990 (defun wl-folder-get-petname (folder)
1994 wl-folder-petname-alist))
1997 (defun wl-folder-get-entity-with-petname ()
1998 (let ((alist wl-folder-petname-alist)
1999 (hashtb (copy-sequence wl-folder-entity-hashtb)))
2001 (wl-folder-set-entity-info (cdar alist) nil hashtb)
2002 (setq alist (cdr alist)))
2005 (defun wl-folder-get-newsgroups (folder)
2006 "Return Newsgroups field value string for FOLDER newsgroup.
2007 If FOLDER is multi, return comma separated string (cross post)."
2008 (let ((flist (elmo-folder-get-primitive-folder-list folder)) ; multi
2010 (while (setq fld (car flist))
2012 (cond ((eq 'nntp (elmo-folder-get-type fld))
2013 (nth 1 (elmo-folder-get-spec fld)))
2014 ((eq 'localnews (elmo-folder-get-type fld))
2015 (elmo-replace-in-string
2016 (nth 1 (elmo-folder-get-spec fld)) "/" "\\."))))
2018 (setq newsgroups (if (stringp newsgroups)
2019 (concat newsgroups "," ret)
2021 (setq flist (cdr flist)))
2022 (list nil nil newsgroups)))
2024 (defun wl-folder-guess-mailing-list-by-refile-rule (folder)
2025 "Return ML address guess by FOLDER.
2026 Use `wl-subscribed-mailing-list' and `wl-refile-rule-alist'.
2028 (setq folder (car (elmo-folder-get-primitive-folder-list folder)))
2029 (unless (memq (elmo-folder-get-type folder)
2031 (let ((rules wl-refile-rule-alist)
2032 mladdress tokey toalist histkey)
2034 (if (or (and (stringp (car (car rules)))
2035 (string-match "[Tt]o" (car (car rules))))
2036 (and (listp (car (car rules)))
2037 (elmo-string-matched-member "to" (car (car rules))
2039 (setq toalist (append toalist (cdr (car rules)))))
2040 (setq rules (cdr rules)))
2041 (setq tokey (car (rassoc folder toalist)))
2042 ;;; (setq histkey (car (rassoc folder wl-refile-alist)))
2043 ;; case-ignore search `wl-subscribed-mailing-list'
2046 (elmo-string-matched-member tokey wl-subscribed-mailing-list t)
2050 (defun wl-folder-guess-mailing-list-by-folder-name (folder)
2051 "Return ML address guess by FOLDER name's last hierarchy.
2052 Use `wl-subscribed-mailing-list'. Don't care multi."
2053 (setq folder (car (elmo-folder-get-primitive-folder-list folder)))
2054 (when (memq (elmo-folder-get-type folder)
2055 '(localdir imap4 maildir))
2056 (let (key mladdress)
2057 (when (string-match "[^\\./]+$" folder)
2058 (setq key (concat "^" (substring folder (match-beginning 0)) "@"))
2060 (elmo-string-matched-member
2061 key wl-subscribed-mailing-list 'case-ignore))
2062 (if (stringp mladdress)
2063 (list mladdress nil nil)
2066 (defun wl-folder-update-diff-line (diffs)
2067 (let ((inhibit-read-only t)
2068 (buffer-read-only nil)
2070 cur-unread new-unread
2075 (setq id (get-text-property (point) 'wl-folder-entity-id))
2076 (when (looking-at "^[ ]*\\(.*\\):\\([0-9\\*-]*\\)/\\([0-9\\*-]*\\)/\\([0-9\\*]*\\)")
2077 ;;(looking-at "^[ ]*\\([^\\[].+\\):\\([0-9\\*-]*/[0-9\\*-]*/[0-9\\*]*\\)")
2078 (setq cur-new (string-to-int
2079 (wl-match-buffer 2)))
2080 (setq cur-unread (string-to-int
2081 (wl-match-buffer 3)))
2082 (setq cur-all (string-to-int
2083 (wl-match-buffer 4)))
2084 (delete-region (match-beginning 2)
2086 (goto-char (match-beginning 2))
2087 (insert (format "%s/%s/%s"
2088 (setq new-new (+ cur-new (nth 0 diffs)))
2089 (setq new-unread (+ cur-unread (nth 1 diffs)))
2090 (setq new-all (+ cur-all (nth 2 diffs)))))
2091 (put-text-property (match-beginning 2) (point)
2092 'wl-folder-entity-id id)
2093 (if wl-use-highlight-mouse-line
2094 (put-text-property (match-beginning 2) (point)
2095 'mouse-face 'highlight))
2096 (wl-highlight-folder-group-line (list new-new new-unread new-all))
2097 (setq buffer-read-only t)
2098 (set-buffer-modified-p nil)))))
2100 (defun wl-folder-update-line (nums &optional is-group)
2101 (let ((inhibit-read-only t)
2102 (buffer-read-only nil)
2106 (setq id (get-text-property (point) 'wl-folder-entity-id))
2107 (if (looking-at "^[ ]*\\(.*\\):\\([0-9\\*-]*/[0-9\\*-]*/[0-9\\*]*\\)")
2108 ;;; (looking-at "^[ ]*\\([^\\[].+\\):\\([0-9\\*-]*/[0-9\\*-]*/[0-9\\*]*\\)")
2110 (delete-region (match-beginning 2)
2112 (goto-char (match-beginning 2))
2113 (insert (format "%s/%s/%s"
2114 (or (nth 0 nums) "*")
2115 (or (and (nth 0 nums)(nth 1 nums)
2116 (+ (nth 0 nums)(nth 1 nums)))
2118 (or (nth 2 nums) "*")))
2119 (put-text-property (match-beginning 2) (point)
2120 'wl-folder-entity-id id)
2122 ;; update only colors
2123 (wl-highlight-folder-group-line nums)
2124 (wl-highlight-folder-current-line nums))
2125 (set-buffer-modified-p nil))))))
2127 (defun wl-folder-goto-folder (&optional arg)
2129 (wl-folder-goto-folder-subr nil arg))
2131 (defun wl-folder-goto-folder-subr (&optional folder sticky)
2133 (let (summary-buf fld-name entity id error-selecting)
2134 ;;; (setq fld-name (wl-folder-get-entity-from-buffer))
2135 ;;; (if (or (null fld-name)
2136 ;;; (assoc fld-name wl-folder-group-alist))
2137 (setq fld-name wl-default-folder)
2138 (setq fld-name (or folder
2139 (wl-summary-read-folder fld-name)))
2140 (if (and (setq entity
2141 (wl-folder-search-entity-by-name fld-name
2144 (setq id (wl-folder-get-entity-id entity)))
2145 (wl-folder-set-current-entity-id id))
2146 (setq summary-buf (wl-summary-get-buffer-create fld-name sticky))
2147 (if wl-stay-folder-window
2148 (wl-folder-select-buffer summary-buf)
2149 (if (and summary-buf
2150 (get-buffer-window summary-buf))
2152 (wl-summary-goto-folder-subr fld-name
2153 (wl-summary-get-sync-range fld-name)
2156 (defun wl-folder-suspend ()
2158 (run-hooks 'wl-folder-suspend-hook)
2159 (wl-folder-info-save)
2160 (wl-crosspost-alist-save)
2162 (format "^\\(%s\\)$"
2163 (mapconcat 'identity
2164 (list (format "%s\\(:.*\\)?"
2165 (default-value 'wl-message-buf-name))
2166 wl-original-buf-name)
2168 (if (fboundp 'mmelmo-cleanup-entity-buffers)
2169 (mmelmo-cleanup-entity-buffers))
2170 (bury-buffer wl-folder-buffer-name)
2171 (delete-windows-on wl-folder-buffer-name t))
2173 (defun wl-folder-info-save ()
2174 (when (and wl-folder-info-save
2175 wl-folder-info-alist-modified)
2176 (let ((entities (list wl-folder-entity))
2177 entity entity-stack info-alist info)
2179 (setq entity (wl-pop entities))
2183 (wl-push entities entity-stack))
2184 (setq entities (nth 2 entity)))
2186 (when (and (setq info (elmo-folder-get-info entity))
2187 (not (equal info '(nil))))
2188 (wl-append info-alist (list (list (elmo-string entity)
2189 (list (nth 3 info) ;; max
2190 (nth 2 info) ;; length
2192 (nth 1 info)) ;; unread
2195 (setq entities (wl-pop entity-stack))))
2196 (elmo-msgdb-finfo-save info-alist)
2197 (setq wl-folder-info-alist-modified nil))))
2199 (defun wl-folder-goto-first-unread-folder (&optional arg)
2201 (let ((entities (list wl-folder-entity))
2202 entity entity-stack ret-val
2207 (setq entity (wl-pop entities))
2211 (wl-push entities entity-stack))
2212 (setq entities (nth 2 entity)))
2214 (if (and (setq finfo (wl-folder-get-entity-info entity))
2215 (and (nth 0 finfo)(nth 1 finfo))
2216 (> (+ (nth 0 finfo)(nth 1 finfo)) 0))
2217 (throw 'done entity))
2218 (wl-append ret-val (list entity))))
2220 (setq entities (wl-pop entity-stack))))))
2224 (wl-folder-jump-folder first-entity)
2226 (wl-folder-goto-folder-subr first-entity))
2227 (message "No unread folder"))))
2229 (defun wl-folder-jump-folder (&optional fld-name noopen)
2232 (setq fld-name (wl-summary-read-folder wl-default-folder)))
2233 (goto-char (point-min))
2235 (wl-folder-open-folder fld-name))
2236 (and (wl-folder-buffer-search-entity fld-name)
2237 (beginning-of-line)))
2239 (defun wl-folder-get-entity-list (entity)
2240 (let ((entities (list entity))
2241 entity-stack ret-val)
2243 (setq entity (wl-pop entities))
2247 (wl-push entities entity-stack))
2248 (setq entities (nth 2 entity)))
2250 (wl-append ret-val (list entity))))
2252 (setq entities (wl-pop entity-stack))))
2255 (defun wl-folder-open-unread-folder (entity)
2257 (let ((alist (wl-folder-get-entity-list entity))
2259 finfo path-list path id)
2261 (when (and (setq finfo (wl-folder-get-entity-info (car alist)))
2262 (nth 0 finfo) (nth 1 finfo)
2263 (> (+ (nth 0 finfo)(nth 1 finfo)) 0))
2264 (setq unread (+ unread (+ (nth 0 finfo)(nth 1 finfo))))
2265 (setq id (wl-folder-get-entity-id (car alist)))
2266 (setq path (delete id (wl-folder-get-path
2270 (if (not (member path path-list))
2271 (wl-append path-list (list path))))
2272 (setq alist (cdr alist)))
2274 (wl-folder-open-folder-sub (car path-list))
2275 (setq path-list (cdr path-list)))
2276 (message "%s unread folder"
2277 (if (> unread 0) unread "No")))))
2279 (defun wl-folder-open-unread-current-entity ()
2281 (let ((entity-name (wl-folder-get-entity-from-buffer))
2282 (group (wl-folder-buffer-group-p)))
2284 (wl-folder-open-unread-folder
2286 (wl-folder-search-group-entity-by-name entity-name
2290 (defun wl-folder-open-only-unread-folder ()
2293 (wl-folder-prev-entity-skip-invalid t)
2294 (wl-folder-get-entity-from-buffer t))))
2295 (wl-folder-open-all-unread-folder)
2297 (goto-char (point-max))
2298 (while (and (re-search-backward
2299 "^[ ]*\\[[-]\\].+:0/0/[0-9-]+" nil t)
2301 (wl-folder-jump-to-current-entity) ;; close it
2303 (wl-folder-move-path id)
2306 (defun wl-folder-open-all-unread-folder (&optional arg)
2309 (wl-folder-prev-entity-skip-invalid t)
2310 (wl-folder-get-entity-from-buffer t))))
2311 (wl-folder-open-unread-folder wl-folder-entity)
2313 (wl-folder-move-path id)
2314 (goto-char (point-min))
2315 (wl-folder-next-unread t))))
2317 (defun wl-folder-open-folder (&optional fld-name)
2320 (setq fld-name (wl-summary-read-folder wl-default-folder)))
2321 (let* ((id (wl-folder-get-entity-id
2322 (wl-folder-search-entity-by-name fld-name wl-folder-entity
2324 (path (and id (wl-folder-get-path wl-folder-entity id))))
2326 (wl-folder-open-folder-sub path))))
2328 (defun wl-folder-open-folder-sub (path)
2329 (let ((inhibit-read-only t)
2330 (buffer-read-only nil)
2334 (goto-char (point-min))
2336 (wl-folder-buffer-search-group
2337 (wl-folder-get-petname
2338 (if (stringp (car path))
2340 (wl-folder-get-folder-name-by-id
2343 (setq path (cdr path))
2344 (if (and (looking-at wl-folder-group-regexp)
2345 (string= "+" (wl-match-buffer 2)));; closed group
2347 (setq indent (wl-match-buffer 1))
2348 (setq name (wl-folder-get-realname (wl-match-buffer 3)))
2349 (setq entity (wl-folder-search-group-entity-by-name
2353 (setcdr (assoc (car entity) wl-folder-group-alist) t)
2354 (if (eq 'access (cadr entity))
2355 (wl-folder-maybe-load-folder-list entity))
2356 (wl-folder-insert-entity indent entity)
2357 (delete-region (save-excursion (beginning-of-line)
2359 (save-excursion (end-of-line)
2361 (set-buffer-modified-p nil))))
2363 (defun wl-folder-open-all-pre ()
2364 (let ((entities (list wl-folder-entity))
2365 entity entity-stack group-entry)
2367 (setq entity (wl-pop entities))
2370 (unless (or (not (setq group-entry
2371 (assoc (car entity) wl-folder-group-alist)))
2373 (setcdr group-entry t)
2374 (when (eq 'access (cadr entity))
2375 (wl-folder-maybe-load-folder-list entity)))
2377 (wl-push entities entity-stack))
2378 (setq entities (nth 2 entity))))
2380 (setq entities (wl-pop entity-stack))))))
2382 (defun wl-folder-open-all (&optional refresh)
2384 (let* ((inhibit-read-only t)
2385 (buffer-read-only nil)
2386 (len (length wl-folder-group-alist))
2391 (wl-folder-prev-entity-skip-invalid t)
2392 (wl-folder-get-entity-from-buffer t)))
2393 (alist wl-folder-group-alist))
2395 (setcdr (pop alist) t))
2397 (wl-folder-insert-entity " " wl-folder-entity)
2398 (wl-folder-move-path id))
2399 (message "Opening all folders...")
2400 (wl-folder-open-all-pre)
2402 (goto-char (point-min))
2403 (while (re-search-forward
2404 "^\\([ ]*\\)\\[\\([+]\\)\\]\\(.+\\):[-0-9-]+/[0-9-]+/[0-9-]+\n"
2406 (setq indent (wl-match-buffer 1))
2407 (setq name (wl-folder-get-realname (wl-match-buffer 3)))
2408 (setq entity (wl-folder-search-group-entity-by-name
2412 (setcdr (assoc (car entity) wl-folder-group-alist) t)
2414 (wl-folder-insert-entity indent entity)
2415 (delete-region (save-excursion (beginning-of-line)
2417 (save-excursion (end-of-line)
2419 (when (> len elmo-display-progress-threshold)
2421 (if (or (zerop (% i 5)) (= i len))
2422 (elmo-display-progress
2423 'wl-folder-open-all "Opening all folders..."
2424 (/ (* i 100) len)))))
2425 (when (> len elmo-display-progress-threshold)
2426 (elmo-display-progress
2427 'wl-folder-open-all "Opening all folders..." 100))))
2428 (message "Opening all folders...done")
2429 (set-buffer-modified-p nil)))
2431 (defun wl-folder-close-all ()
2433 (let ((inhibit-read-only t)
2434 (buffer-read-only nil)
2435 (alist wl-folder-group-alist)
2437 (wl-folder-prev-entity-skip-invalid t)
2438 (wl-folder-get-entity-from-buffer t))))
2440 (setcdr (car alist) nil)
2441 (setq alist (cdr alist)))
2442 (setcdr (assoc (car wl-folder-entity) wl-folder-group-alist) t)
2444 (wl-folder-insert-entity " " wl-folder-entity)
2445 (wl-folder-move-path id)
2447 (set-buffer-modified-p nil)))
2449 (defun wl-folder-open-close ()
2450 "Open or close parent entity."
2454 (if (wl-folder-buffer-group-p)
2455 ;; if group (whether opend or closed.)
2456 (wl-folder-jump-to-current-entity)
2459 (setq indent (save-excursion
2460 (re-search-forward "\\([ ]*\\)." nil t)
2461 (wl-match-buffer 1)))
2462 (while (looking-at indent)
2464 (wl-folder-jump-to-current-entity))))
2466 (defsubst wl-folder-access-subscribe-p (group folder)
2467 (let (subscr regexp match)
2468 (if (setq subscr (wl-get-assoc-list-value
2469 wl-folder-access-subscribe-alist
2472 (setq regexp (mapconcat 'identity (cdr subscr) "\\|"))
2473 (setq match (string-match regexp folder))
2479 (defun wl-folder-update-access-group (entity new-flist)
2480 (let* ((flist (nth 2 entity))
2481 (unsubscribes (nth 3 entity))
2482 (len (+ (length flist) (length unsubscribes)))
2484 diff new-unsubscribes removes
2485 subscribed-list folder group entry)
2486 ;; check subscribed groups
2489 ((listp (car flist)) ;; group
2490 (setq group (elmo-string (caar flist)))
2492 ((assoc group new-flist) ;; found in new-flist
2493 (setq new-flist (delete (assoc group new-flist)
2495 (if (wl-folder-access-subscribe-p (car entity) group)
2496 (wl-append subscribed-list (list (car flist)))
2497 (wl-append new-unsubscribes (list (car flist)))
2500 (setq wl-folder-group-alist
2501 (delete (wl-string-assoc group wl-folder-group-alist)
2502 wl-folder-group-alist))
2503 (wl-append removes (list (list group))))))
2505 (setq folder (elmo-string (car flist)))
2507 ((member folder new-flist) ;; found in new-flist
2508 (setq new-flist (delete folder new-flist))
2509 (if (wl-folder-access-subscribe-p (car entity) folder)
2510 (wl-append subscribed-list (list (car flist)))
2511 (wl-append new-unsubscribes (list folder))
2514 (wl-append removes (list folder))))))
2515 (when (> len elmo-display-progress-threshold)
2517 (if (or (zerop (% i 10)) (= i len))
2518 (elmo-display-progress
2519 'wl-folder-update-access-group "Updating access group..."
2520 (/ (* i 100) len))))
2521 (setq flist (cdr flist)))
2522 ;; check unsubscribed groups
2525 ((listp (car unsubscribes))
2526 (when (setq entry (assoc (caar unsubscribes) new-flist))
2527 (setq new-flist (delete entry new-flist))
2528 (wl-append new-unsubscribes (list (car unsubscribes)))))
2530 (when (member (car unsubscribes) new-flist)
2531 (setq new-flist (delete (car unsubscribes) new-flist))
2532 (wl-append new-unsubscribes (list (car unsubscribes))))))
2533 (when (> len elmo-display-progress-threshold)
2535 (if (or (zerop (% i 10)) (= i len))
2536 (elmo-display-progress
2537 'wl-folder-update-access-group "Updating access group..."
2538 (/ (* i 100) len))))
2539 (setq unsubscribes (cdr unsubscribes)))
2541 (if (or new-flist removes)
2544 (mapcar '(lambda (x)
2545 (cond ((consp x) (list (car x) 'access))
2549 (let ((new-list new-flist))
2551 (if (not (wl-folder-access-subscribe-p
2553 (if (listp (car new-list))
2558 (wl-append new-unsubscribes (list (car new-list)))
2559 (setq new-flist (delete (car new-list) new-flist)))
2561 ((listp (car new-list))
2562 ;; check group exists
2563 (if (wl-string-assoc (caar new-list) wl-folder-group-alist)
2565 (message "%s: group already exists." (caar new-list))
2567 (wl-append new-unsubscribes (list (car new-list)))
2568 (setq new-flist (delete (car new-list) new-flist)))
2569 (wl-append wl-folder-group-alist
2570 (list (cons (caar new-list) nil)))))))
2571 (setq new-list (cdr new-list))))
2573 (message "%d new folder(s)." (length new-flist))
2574 (message "Updating access group...done"))
2575 (wl-append new-flist subscribed-list) ;; new is first
2576 (run-hooks 'wl-folder-update-access-group-hook)
2577 (setcdr (cdr entity) (list new-flist new-unsubscribes))
2578 (list diff new-flist new-unsubscribes removes)))
2580 (defun wl-folder-prefetch-entity (entity)
2581 "Prefetch all new messages in the ENTITY."
2584 (let ((flist (nth 2 entity))
2589 (setq result (wl-folder-prefetch-entity (car flist)))
2590 (setq sum-done (+ sum-done (car result)))
2591 (setq sum-all (+ sum-all (cdr result)))
2592 (setq flist (cdr flist)))
2593 (message "Prefetched %d/%d message(s) in \"%s\"."
2595 (wl-folder-get-petname (car entity)))
2596 (cons sum-done sum-all)))
2598 (let ((nums (wl-folder-get-entity-info entity))
2599 (wl-summary-highlight (if (or (wl-summary-sticky-p entity)
2600 (wl-summary-always-sticky-folder-p
2602 wl-summary-highlight))
2603 wl-summary-exit-next-move
2604 wl-auto-select-first ret-val
2606 (setq count (or (car nums) 0))
2607 (setq count (+ count (wl-folder-count-incorporates entity)))
2608 (if (or (null (car nums)) ; unknown
2610 (save-window-excursion
2612 (wl-summary-goto-folder-subr entity
2613 (wl-summary-get-sync-range entity)
2615 (setq ret-val (wl-summary-incorporate))
2620 (defun wl-folder-count-incorporates (folder)
2621 (let ((marks (elmo-msgdb-mark-load (elmo-msgdb-expand-path folder)))
2624 (if (member (cadr (car marks))
2625 wl-summary-incorporate-marks)
2627 (setq marks (cdr marks)))
2630 (defun wl-folder-prefetch-current-entity (&optional no-check)
2631 "Prefetch all uncached messages in the folder at position.
2632 If current line is group folder, all subfolders are prefetched."
2635 (let ((entity-name (wl-folder-get-entity-from-buffer))
2636 (group (wl-folder-buffer-group-p))
2637 wl-folder-check-entity-hook
2642 (wl-folder-search-group-entity-by-name entity-name
2646 (wl-folder-check-entity entity))
2647 (wl-folder-prefetch-entity entity)))))
2649 (defun wl-folder-drop-unsync-entity (entity)
2650 "Drop all unsync messages in the ENTITY."
2653 (let ((flist (nth 2 entity)))
2655 (wl-folder-drop-unsync-entity (car flist))
2656 (setq flist (cdr flist)))))
2658 (let ((nums (wl-folder-get-entity-info entity))
2659 wl-summary-highlight wl-auto-select-first new)
2660 (setq new (or (car nums) 0))
2662 (save-window-excursion
2664 (wl-summary-goto-folder-subr entity 'no-sync nil)
2665 (wl-summary-drop-unsync)
2666 (wl-summary-exit))))))))
2668 (defun wl-folder-drop-unsync-current-entity (&optional force-check)
2669 "Drop all unsync messages in the folder at position.
2670 If current line is group folder, all subfolders are dropped.
2671 If optional arg exists, don't check any folders."
2674 (let ((entity-name (wl-folder-get-entity-from-buffer))
2675 (group (wl-folder-buffer-group-p))
2676 wl-folder-check-entity-hook
2678 (when (and entity-name
2680 "Drop all unsync messages in %s?" entity-name)))
2683 (wl-folder-search-group-entity-by-name entity-name
2686 (if (null force-check)
2687 (wl-folder-check-entity entity))
2688 (wl-folder-drop-unsync-entity entity)
2689 (message "All unsync messages in %s are dropped!" entity-name)))))
2691 (defun wl-folder-write-current-folder ()
2694 (unless (wl-folder-buffer-group-p)
2695 (wl-summary-write-current-folder (wl-folder-entity-name))))
2697 (defun wl-folder-mimic-kill-buffer ()
2698 "Kill the current (Folder) buffer with query."
2700 (let ((bufname (read-buffer (format "Kill buffer: (default %s) "
2702 wl-interactive-exit)
2703 (if (or (not bufname)
2704 (string-equal bufname "")
2705 (string-equal bufname (buffer-name)))
2707 (kill-buffer bufname))))
2709 (defun wl-folder-create-subr (entity)
2710 (if (not (elmo-folder-creatable-p entity))
2711 (error "Folder %s is not found" entity)
2713 (format "Folder %s does not exist, create it?"
2716 (setq wl-folder-entity-hashtb
2717 (wl-folder-create-entity-hashtb
2718 entity wl-folder-entity-hashtb))
2719 (unless (elmo-create-folder entity)
2720 (error "Create folder failed")))
2721 (error "Folder %s is not created" entity))))
2723 (defun wl-folder-confirm-existence (folder &optional force)
2725 (unless (elmo-folder-exists-p folder)
2726 (wl-folder-create-subr folder))
2727 (unless (or (wl-folder-entity-exists-p folder)
2728 (file-exists-p (elmo-msgdb-expand-path folder))
2729 (elmo-folder-exists-p folder))
2730 (wl-folder-create-subr folder))))
2733 (product-provide (provide 'wl-folder) (require 'wl-version))
2735 ;;; wl-folder.el ends here