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))
843 (get-buffer wl-folder-buffer-name)))
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 (let ((wl-summary-buffer-name (concat
985 wl-summary-buffer-name
986 (symbol-name this-command)))
987 (wl-message-buf-name (concat wl-message-buf-name
988 (symbol-name this-command))))
989 (save-window-excursion
991 (wl-summary-goto-folder-subr entity
992 (wl-summary-get-sync-range entity)
994 (wl-summary-exit)))))))))
996 (defun wl-folder-sync-current-entity (&optional unread-only)
997 "Synchronize the folder at position.
998 If current line is group folder, check all subfolders."
1001 (let ((entity-name (wl-folder-get-entity-from-buffer))
1002 (group (wl-folder-buffer-group-p)))
1003 (when (and entity-name
1004 (y-or-n-p (format "Sync %s?" entity-name)))
1005 (wl-folder-sync-entity
1007 (wl-folder-search-group-entity-by-name entity-name
1011 (message "Syncing %s is done!" entity-name)))))
1013 (defun wl-folder-mark-as-read-all-entity (entity)
1014 "Mark as read all messages in the ENTITY."
1017 (let ((flist (nth 2 entity)))
1019 (wl-folder-mark-as-read-all-entity (car flist))
1020 (setq flist (cdr flist)))))
1022 (let ((nums (wl-folder-get-entity-info entity))
1023 (wl-summary-highlight (if (or (wl-summary-sticky-p entity)
1024 (wl-summary-always-sticky-folder-p
1026 wl-summary-highlight))
1027 wl-auto-select-first new unread)
1028 (setq new (or (car nums) 0))
1029 (setq unread (or (cadr nums) 0))
1030 (if (or (< 0 new) (< 0 unread))
1031 (let ((wl-summary-buffer-name (concat
1032 wl-summary-buffer-name
1033 (symbol-name this-command)))
1034 (wl-message-buf-name (concat wl-message-buf-name
1035 (symbol-name this-command))))
1036 (save-window-excursion
1038 (wl-summary-goto-folder-subr entity
1039 (wl-summary-get-sync-range entity)
1041 (wl-summary-mark-as-read-all)
1042 (wl-summary-exit))))
1045 (defun wl-folder-mark-as-read-all-current-entity ()
1046 "Mark as read all messages in the folder at position.
1047 If current line is group folder, all subfolders are marked."
1050 (let ((entity-name (wl-folder-get-entity-from-buffer))
1051 (group (wl-folder-buffer-group-p))
1053 (when (and entity-name
1054 (y-or-n-p (format "Mark all messages in %s as read?" entity-name)))
1055 (wl-folder-mark-as-read-all-entity
1057 (wl-folder-search-group-entity-by-name entity-name
1060 (message "All messages in %s are marked!" entity-name)))))
1062 (defun wl-folder-check-region (beg end)
1071 (let ((inhibit-read-only t)
1073 (while (< (point) end)
1074 ;; normal folder entity
1075 (if (looking-at "^[\t ]*\\([^\\[]+\\):\\(.*\\)\n")
1077 (setq entity (wl-folder-get-entity-from-buffer))
1078 (if (not (elmo-folder-plugged-p entity))
1079 (message "Uncheck %s" entity)
1080 (message "Checking %s" entity)
1081 (wl-folder-check-one-entity entity)
1086 (defun wl-folder-sync-region (beg end)
1095 (while (< (point) end)
1096 ;; normal folder entity
1097 (if (looking-at "^[\t ]*\\([^\\[]+\\):\\(.*\\)\n")
1099 (let ((inhibit-read-only t)
1101 (setq entity (wl-folder-get-entity-from-buffer))
1102 (wl-folder-sync-entity entity)
1103 (message "Syncing %s is done!" entity)
1108 (defun wl-folder-mark-as-read-all-region (beg end)
1117 (while (< (point) end)
1118 ;; normal folder entity
1119 (if (looking-at "^[\t ]*\\([^\\[]+\\):\\(.*\\)\n")
1121 (let ((inhibit-read-only t)
1123 (setq entity (wl-folder-get-entity-from-buffer))
1124 (wl-folder-mark-as-read-all-entity entity)
1125 (message "All messages in %s are marked!" entity)
1130 (defsubst wl-create-access-init-load-p (folder)
1131 (let ((no-load-regexp (when (and
1132 (not wl-folder-init-load-access-folders)
1133 wl-folder-init-no-load-access-folders)
1134 (mapconcat 'identity
1135 wl-folder-init-no-load-access-folders
1137 (load-regexp (and wl-folder-init-load-access-folders
1138 (mapconcat 'identity
1139 wl-folder-init-load-access-folders
1141 (cond (load-regexp (string-match load-regexp folder))
1142 (t (not (and no-load-regexp
1143 (string-match no-load-regexp folder)))))))
1145 (defun wl-create-access-folder-entity (name)
1147 (when (wl-create-access-init-load-p name)
1148 (setq flists (elmo-msgdb-flist-load name)) ; load flist.
1149 (setq flist (car flists))
1151 (when (consp (car flist))
1152 (setcdr (cdar flist)
1153 (wl-create-access-folder-entity (caar flist))))
1154 (setq flist (cdr flist)))
1157 (defun wl-create-folder-entity-from-buffer ()
1158 "Create folder entity recursively."
1160 ((looking-at "^[ \t]*$") ; blank line
1161 (goto-char (+ 1(match-end 0)))
1163 ((looking-at "^#.*$") ; comment
1164 (goto-char (+ 1 (match-end 0)))
1166 ((looking-at "^[\t ]*\\(.+\\)[\t ]*{[\t ]*$") ; group definition
1167 (let (name entity flist)
1168 (setq name (wl-match-buffer 1))
1169 (goto-char (+ 1 (match-end 0)))
1170 (while (setq entity (wl-create-folder-entity-from-buffer))
1171 (unless (eq entity 'ignore)
1172 (wl-append flist (list entity))))
1173 (if (looking-at "^[\t ]*}[\t ]*$") ; end of group
1175 (goto-char (+ 1 (match-end 0)))
1176 (if (wl-string-assoc name wl-folder-petname-alist)
1177 (error "%s already defined as petname" name))
1178 (list name 'group flist))
1179 (error "Syntax error in folder definition"))))
1180 ((looking-at "^[\t ]*\\([^\t \n]+\\)[\t ]*/$") ; access it!
1182 (setq name (wl-match-buffer 1))
1183 (goto-char (+ 1 (match-end 0)))
1184 ; (condition-case ()
1186 ; (setq flist (elmo-list-folders name)))
1187 ; (error (message "Access to folder %s failed." name)))
1188 ;; (setq flist (elmo-msgdb-flist-load name)) ; load flist.
1189 ;; (setq unsublist (nth 1 flist))
1190 ;; (setq flist (car flist))
1191 ;; (list name 'access flist unsublist)))
1192 (append (list name 'access) (wl-create-access-folder-entity name))))
1193 ;((looking-at "^[\t ]*\\([^\t \n}]+\\)[\t ]*\\(\"[^\"]*\"\\)?[\t ]*$") ; normal folder entity
1194 ((looking-at "^[\t ]*=[ \t]+\\([^\n]+\\)$"); petname definition
1195 (goto-char (+ 1 (match-end 0)))
1196 (let ((rest (elmo-match-buffer 1))
1198 (when (string-match "\\(\"[^\"]*\"\\)[\t ]*$" rest)
1199 (setq petname (elmo-delete-char ?\" (elmo-match-string 1 rest)))
1200 (setq rest (substring rest 0 (match-beginning 0))))
1201 (when (string-match "^[\t ]*\\(.*[^\t ]+\\)[\t ]+$" rest)
1202 (wl-folder-append-petname (elmo-match-string 1 rest)
1205 ((looking-at "^[ \t]*}[ \t]*$") ; end of group
1207 ((looking-at "^.*$") ; normal folder entity
1208 (goto-char (+ 1 (match-end 0)))
1209 (let ((rest (elmo-match-buffer 0))
1211 (if (string-match "\\(\"[^\"]*\"\\)[\t ]*$" rest)
1213 (setq petname (elmo-delete-char ?\" (elmo-match-string 1 rest)))
1214 (setq rest (substring rest 0 (match-beginning 0)))
1215 (when (string-match "^[\t ]*\\(.*[^\t ]+\\)[\t ]+$" rest)
1216 (wl-folder-append-petname
1217 (setq realname (elmo-match-string 1 rest))
1220 (if (string-match "^[\t ]*\\(.+\\)$" rest)
1221 (elmo-match-string 1 rest)
1224 (defun wl-folder-create-folder-entity ()
1225 "Create folder entries."
1226 (let ((tmp-buf (get-buffer-create " *wl-folder-tmp*"))
1230 (with-current-buffer tmp-buf
1232 (insert-file-contents wl-folders-file)
1233 (goto-char (point-min))
1234 (while (and (not (eobp))
1235 (setq entity (wl-create-folder-entity-from-buffer)))
1236 (unless (eq entity 'ignore)
1237 (wl-append ret-val (list entity)))))
1238 (kill-buffer tmp-buf))
1240 (setq ret-val (list wl-folder-desktop-name 'group ret-val))))
1242 (defun wl-folder-entity-assign-id (entity &optional hashtb on-noid)
1243 (let ((hashtb (or hashtb
1244 (setq wl-folder-entity-id-name-hashtb
1245 (elmo-make-hash wl-folder-entity-id))))
1246 (entities (list entity))
1249 (setq entity (wl-pop entities))
1252 (when (not (and on-noid
1253 (get-text-property 0
1254 'wl-folder-entity-id
1256 (put-text-property 0 (length (car entity))
1257 'wl-folder-entity-id
1260 (wl-folder-set-id-name wl-folder-entity-id
1261 (car entity) hashtb))
1263 (wl-push entities entity-stack))
1264 (setq entities (nth 2 entity)))
1266 (when (not (and on-noid
1267 (get-text-property 0
1268 'wl-folder-entity-id
1270 (put-text-property 0 (length entity)
1271 'wl-folder-entity-id
1274 (wl-folder-set-id-name wl-folder-entity-id
1276 (setq wl-folder-entity-id (+ 1 wl-folder-entity-id))
1278 (setq entities (wl-pop entity-stack))))))
1280 (defun wl-folder-click (e)
1285 (wl-folder-jump-to-current-entity)))
1287 (defun wl-folder-select-buffer (buffer)
1288 (let ((gbw (get-buffer-window buffer))
1291 (progn (select-window gbw)
1293 (unless wl-folder-use-frame
1296 (split-window-horizontally wl-folder-window-width)
1300 (if wl-folder-use-frame
1301 (switch-to-buffer-other-frame buffer)
1302 (switch-to-buffer buffer))
1305 (defun wl-folder-toggle-disp-summary (&optional arg folder)
1307 (if (or (and folder (assoc folder wl-folder-group-alist))
1308 (and (interactive-p) (wl-folder-buffer-group-p)))
1309 (error "This command is not available on Group"))
1311 (let (wl-auto-select-first)
1314 (setq wl-folder-buffer-disp-summary t))
1316 (setq wl-folder-buffer-disp-summary nil)
1317 ;; hide wl-summary window.
1318 (let ((cur-buf (current-buffer))
1319 (summary-buffer (wl-summary-get-buffer folder)))
1320 (wl-folder-select-buffer summary-buffer)
1322 (select-window (get-buffer-window cur-buf))))
1324 (setq wl-folder-buffer-disp-summary
1325 (not wl-folder-buffer-disp-summary))
1326 (let ((cur-buf (current-buffer))
1328 (when (looking-at "^[ ]*\\([^\\[].+\\):.*\n")
1329 (setq folder-name (wl-folder-get-entity-from-buffer))
1330 (if wl-folder-buffer-disp-summary
1332 (wl-folder-select-buffer
1333 (wl-summary-get-buffer-create folder-name))
1335 (wl-summary-goto-folder-subr folder-name 'no-sync nil)
1336 (select-window (get-buffer-window cur-buf))))
1337 (wl-folder-select-buffer (wl-summary-get-buffer folder-name))
1339 (select-window (get-buffer-window cur-buf)))))))))
1341 (defun wl-folder-prev-unsync ()
1342 "Move cursor to the previous unsync folder."
1345 (setq start-point (point))
1347 (if (re-search-backward wl-folder-unsync-regexp nil t)
1349 (goto-char start-point)
1350 (message "No more unsync folder"))))
1352 (defun wl-folder-next-unsync (&optional plugged)
1353 "Move cursor to the next unsync."
1355 (let (start-point entity)
1356 (setq start-point (point))
1359 (while (re-search-forward wl-folder-unsync-regexp nil t)
1360 (if (or (wl-folder-buffer-group-p)
1363 (wl-folder-get-realname
1364 (wl-folder-folder-name)))
1365 (elmo-folder-plugged-p entity))
1368 (goto-char start-point)
1369 (message "No more unsync folder"))))
1371 (defun wl-folder-prev-unread (&optional group)
1372 "Move cursor to the previous unread folder."
1375 (setq start-point (point))
1377 (if (re-search-backward (wl-folder-unread-regex group) nil t)
1380 (wl-folder-folder-name))
1381 (goto-char start-point)
1382 (message "No more unread folder")
1385 (defun wl-folder-next-unread (&optional group)
1386 "Move cursor to the next unread folder."
1389 (setq start-point (point))
1391 (if (re-search-forward (wl-folder-unread-regex group) nil t)
1394 (wl-folder-folder-name))
1395 (goto-char start-point)
1396 (message "No more unread folder")
1399 (defun wl-folder-mode ()
1400 "Major mode for Wanderlust Folder.
1401 See Info under Wanderlust for full documentation.
1404 \\{wl-folder-mode-map}
1406 Entering Folder mode calls the value of `wl-folder-mode-hook'."
1408 (setq major-mode 'wl-folder-mode)
1409 (setq mode-name "Folder")
1410 (use-local-map wl-folder-mode-map)
1411 (setq buffer-read-only t)
1412 (setq inhibit-read-only nil)
1413 (setq truncate-lines t)
1414 (setq wl-folder-buffer-cur-entity-id nil
1415 wl-folder-buffer-cur-path nil
1416 wl-folder-buffer-cur-point nil)
1417 (wl-mode-line-buffer-identification)
1418 (easy-menu-add wl-folder-mode-menu)
1419 ;; This hook may contain the functions `wl-folder-init-icons' and
1420 ;; `wl-setup-folder' for reasons of system internal to accord
1421 ;; facilities for the Emacs variants.
1422 (run-hooks 'wl-folder-mode-hook))
1424 (defun wl-folder-append-petname (realname petname)
1426 ;; check group name.
1427 (if (wl-folder-search-group-entity-by-name petname wl-folder-entity)
1428 (error "%s already defined as group name" petname))
1429 (when (setq pentry (wl-string-assoc realname wl-folder-petname-alist))
1430 (setq wl-folder-petname-alist
1431 (delete pentry wl-folder-petname-alist)))
1432 (wl-append wl-folder-petname-alist
1433 (list (cons realname petname)))))
1435 (defun wl-folder (&optional arg)
1438 ;;; (delete-other-windows)
1439 (if (get-buffer wl-folder-buffer-name)
1440 (switch-to-buffer wl-folder-buffer-name)
1441 (switch-to-buffer (get-buffer-create wl-folder-buffer-name))
1444 (set-buffer wl-folder-buffer-name)
1445 (let ((inhibit-read-only t)
1446 (buffer-read-only nil))
1448 (setcdr (assoc (car wl-folder-entity) wl-folder-group-alist) t)
1450 (wl-folder-insert-entity " " wl-folder-entity)))
1451 (set-buffer-modified-p nil)
1453 (setq initialize t))
1456 (defun wl-folder-auto-check ()
1457 "Check and update folders in `wl-auto-check-folder-name'."
1459 (when (get-buffer wl-folder-buffer-name)
1460 (switch-to-buffer wl-folder-buffer-name)
1462 ((eq wl-auto-check-folder-name 'none))
1463 ((or (consp wl-auto-check-folder-name)
1464 (stringp wl-auto-check-folder-name))
1465 (let ((folder-list (if (consp wl-auto-check-folder-name)
1466 wl-auto-check-folder-name
1467 (list wl-auto-check-folder-name)))
1470 (if (setq entity (wl-folder-search-entity-by-name
1473 (wl-folder-check-entity entity 'auto))
1474 (setq folder-list (cdr folder-list)))))
1476 (wl-folder-check-entity wl-folder-entity 'auto)))))
1478 (defun wl-folder-set-folder-updated (name value)
1481 (if (setq buf (get-buffer wl-folder-buffer-name))
1482 (wl-folder-entity-hashtb-set
1483 wl-folder-entity-hashtb name value buf))
1484 ;;; (elmo-folder-set-info-hashtb (elmo-string name)
1489 (setq wl-folder-info-alist-modified t))))
1491 (defun wl-folder-calc-finfo (entity)
1492 ;; calcurate finfo without inserting.
1493 (let ((entities (list entity))
1495 new unread all nums)
1497 (setq entity (wl-pop entities))
1501 (wl-push entities entity-stack))
1502 (setq entities (nth 2 entity)))
1504 (setq nums (wl-folder-get-entity-info entity))
1505 (setq new (+ (or new 0) (or (nth 0 nums) 0)))
1506 (setq unread (+ (or unread 0)
1507 (or (and (nth 0 nums)(nth 1 nums)
1508 (+ (nth 0 nums)(nth 1 nums))) 0)))
1509 (setq all (+ (or all 0) (or (nth 2 nums) 0)))))
1511 (setq entities (wl-pop entity-stack))))
1512 (list new unread all)))
1514 (defsubst wl-folder-make-save-access-list (list)
1515 (mapcar '(lambda (x)
1518 (list (elmo-string (car x)) 'access))
1523 (defun wl-folder-update-newest (indent entity)
1524 (let (ret-val new unread all)
1527 (let ((inhibit-read-only t)
1528 (buffer-read-only nil)
1529 (flist (nth 2 entity))
1530 (as-opened (cdr (assoc (car entity) wl-folder-group-alist)))
1535 (let (update-flist flist-unsub new-flist removed group-name-end)
1536 (when (and (eq (cadr entity) 'access)
1537 (elmo-folder-plugged-p (car entity)))
1538 (message "Fetching folder entries...")
1539 (when (setq new-flist
1541 (elmo-string (car entity))
1544 wl-folder-hierarchy-access-folders)))
1546 (wl-folder-update-access-group entity new-flist))
1547 (setq flist (nth 1 update-flist))
1548 (when (car update-flist) ;; diff
1549 (setq flist-unsub (nth 2 update-flist))
1550 (setq removed (nth 3 update-flist))
1551 (elmo-msgdb-flist-save
1554 (wl-folder-make-save-access-list flist)
1555 (wl-folder-make-save-access-list flist-unsub)))
1556 (wl-folder-entity-assign-id
1558 wl-folder-entity-id-name-hashtb
1560 (setq wl-folder-entity-hashtb
1561 (wl-folder-create-entity-hashtb
1563 wl-folder-entity-hashtb
1565 (setq wl-folder-newsgroups-hashtb
1567 (wl-folder-create-newsgroups-hashtb
1569 wl-folder-newsgroups-hashtb))))
1570 (message "Fetching folder entries...done"))
1571 (wl-folder-insert-entity indent entity))))))))
1573 (defun wl-folder-insert-entity (indent entity &optional onlygroup)
1574 (let (ret-val new unread all)
1577 (let ((inhibit-read-only t)
1578 (buffer-read-only nil)
1579 (flist (nth 2 entity))
1580 (as-opened (cdr (assoc (car entity) wl-folder-group-alist)))
1583 ;;; (insert indent "[" (if as-opened "-" "+") "]" (car entity) "\n")
1584 ;;; (save-excursion (forward-line -1)
1585 ;;; (wl-highlight-folder-current-line))
1589 (let (update-flist flist-unsub new-flist removed group-name-end)
1590 ;;; (when (and (eq (cadr entity) 'access)
1592 ;;; (message "fetching folder entries...")
1593 ;;; (when (setq new-flist
1594 ;;; (elmo-list-folders
1595 ;;; (elmo-string (car entity))
1596 ;;; (wl-string-member
1598 ;;; wl-folder-hierarchy-access-folders)
1600 ;;; (setq update-flist
1601 ;;; (wl-folder-update-access-group entity new-flist))
1602 ;;; (setq flist (nth 1 update-flist))
1603 ;;; (when (car update-flist) ;; diff
1604 ;;; (setq flist-unsub (nth 2 update-flist))
1605 ;;; (setq removed (nth 3 update-flist))
1606 ;;; (elmo-msgdb-flist-save
1609 ;;; (wl-folder-make-save-access-list flist)
1610 ;;; (wl-folder-make-save-access-list flist-unsub)))
1612 ;;; ;; reconstruct wl-folder-entity-id-name-hashtb and
1613 ;;; ;; wl-folder-entity-hashtb
1615 ;;; (wl-folder-entity-assign-id
1617 ;;; wl-folder-entity-id-name-hashtb
1619 ;;; (setq wl-folder-entity-hashtb
1620 ;;; (wl-folder-create-entity-hashtb
1622 ;;; wl-folder-entity-hashtb
1624 ;;; (setq wl-folder-newsgroups-hashtb
1626 ;;; (wl-folder-create-newsgroups-hashtb
1628 ;;; wl-folder-newsgroups-hashtb))))
1629 ;;; (message "fetching folder entries...done"))
1630 (insert indent "[" (if as-opened "-" "+") "]"
1631 (wl-folder-get-petname (car entity)))
1632 (setq group-name-end (point))
1634 (put-text-property beg (point) 'wl-folder-entity-id
1635 (get-text-property 0 'wl-folder-entity-id
1641 wl-folder-removed-mark
1642 (if (listp (car removed))
1643 (concat "[+]" (caar removed))
1646 (save-excursion (forward-line -1)
1647 (wl-highlight-folder-current-line))
1648 (setq removed (cdr removed)))
1649 (remove-text-properties beg (point) '(wl-folder-entity-id)))
1650 (let* ((len (length flist))
1655 (wl-folder-insert-entity
1656 (concat indent " ") (car flist)))
1657 (setq new (+ (or new 0) (or (nth 0 ret-val) 0)))
1658 (setq unread (+ (or unread 0) (or (nth 1 ret-val) 0)))
1659 (setq all (+ (or all 0) (or (nth 2 ret-val) 0)))
1661 (> len elmo-display-progress-threshold))
1663 (elmo-display-progress
1664 'wl-folder-insert-entity "Inserting group %s..."
1665 (/ (* i 100) len) (car entity)))
1666 (setq flist (cdr flist))))
1668 (goto-char group-name-end)
1669 (delete-region (point) (save-excursion (end-of-line)
1671 (insert (format ":%d/%d/%d" (or new 0)
1672 (or unread 0) (or all 0)))
1673 (setq ret-val (list new unread all))
1674 (wl-highlight-folder-current-line ret-val)))
1675 (setq ret-val (wl-folder-calc-finfo entity))
1676 (insert indent "[" (if as-opened "-" "+") "]"
1677 (wl-folder-get-petname (car entity))
1679 (or (nth 0 ret-val) 0)
1680 (or (nth 1 ret-val) 0)
1681 (or (nth 2 ret-val) 0))
1683 (put-text-property beg (point) 'wl-folder-entity-id
1684 (get-text-property 0 'wl-folder-entity-id
1686 (save-excursion (forward-line -1)
1687 (wl-highlight-folder-current-line ret-val)))))
1689 (let* ((inhibit-read-only t)
1690 (buffer-read-only nil)
1691 (nums (wl-folder-get-entity-info entity))
1694 (insert indent (wl-folder-get-petname entity)
1695 (format ":%s/%s/%s\n"
1696 (or (setq new (nth 0 nums)) "*")
1697 (or (setq unread (and (nth 0 nums)(nth 1 nums)
1698 (+ (nth 0 nums)(nth 1 nums))))
1700 (or (setq all (nth 2 nums)) "*")))
1701 (put-text-property beg (point) 'wl-folder-entity-id
1702 (get-text-property 0 'wl-folder-entity-id entity))
1703 (save-excursion (forward-line -1)
1704 (wl-highlight-folder-current-line nums))
1705 (setq ret-val (list new unread all)))))
1706 (set-buffer-modified-p nil)
1709 (defun wl-folder-check-all ()
1711 (wl-folder-check-entity wl-folder-entity))
1713 (defun wl-folder-entity-hashtb-set (entity-hashtb name value buffer)
1720 (setq cur-val (wl-folder-get-entity-info name entity-hashtb))
1721 (setq new-diff (- (or (nth 0 value) 0) (or (nth 0 cur-val) 0)))
1724 (- (or (nth 1 value) 0) (or (nth 1 cur-val) 0))))
1725 (setq all-diff (- (or (nth 2 value) 0) (or (nth 2 cur-val) 0)))
1726 (setq diffs (list new-diff unread-diff all-diff))
1727 (unless (and (nth 0 cur-val)
1728 (equal diffs '(0 0 0)))
1729 (wl-folder-set-entity-info name value entity-hashtb)
1733 (setq entity-list (wl-folder-search-entity-list-by-name
1734 name wl-folder-entity))
1736 (wl-folder-update-group (car entity-list) diffs)
1737 (setq entity-list (cdr entity-list)))
1738 (goto-char (point-min))
1739 (while (wl-folder-buffer-search-entity name)
1740 (wl-folder-update-line value)))))))
1742 (defun wl-folder-update-unread (folder unread)
1743 (save-window-excursion
1744 (let ((buf (get-buffer wl-folder-buffer-name))
1747 ;;(fld (elmo-string folder))
1748 value newvalue entity-list)
1749 ;;; Update folder-info
1750 ;;; (elmo-folder-set-info-hashtb fld nil nil nil unread)
1751 (setq cur-unread (or (nth 1 (wl-folder-get-entity-info folder)) 0))
1752 (setq unread-diff (- (or unread 0) cur-unread))
1753 (setq value (wl-folder-get-entity-info folder))
1755 (setq newvalue (list (nth 0 value)
1758 (wl-folder-set-entity-info folder newvalue)
1759 (setq wl-folder-info-alist-modified t)
1761 (not (eq unread-diff 0)))
1766 (setq entity-list (wl-folder-search-entity-list-by-name
1767 folder wl-folder-entity))
1769 (wl-folder-update-group (car entity-list) (list 0
1772 (setq entity-list (cdr entity-list)))
1773 (goto-char (point-min))
1774 (while (wl-folder-buffer-search-entity folder)
1775 (wl-folder-update-line newvalue)))))))))
1777 (defun wl-folder-create-entity-hashtb (entity &optional hashtb reconst)
1778 (let ((hashtb (or hashtb (elmo-make-hash wl-folder-entity-id)))
1779 (entities (list entity))
1782 (setq entity (wl-pop entities))
1786 (wl-push entities entity-stack))
1787 (setq entities (nth 2 entity)))
1789 (when (not (and reconst
1790 (wl-folder-get-entity-info entity)))
1791 (wl-folder-set-entity-info entity
1795 (setq entities (wl-pop entity-stack))))
1798 ;; Unsync number is reserved.
1799 ;;(defun wl-folder-reconstruct-entity-hashtb (entity &optional hashtb id-name)
1800 ;; (let* ((hashtb (or hashtb (elmo-make-hash wl-folder-entity-id)))
1801 ;; (entities (list entity))
1804 ;; (setq entity (wl-pop entities))
1808 ;; (wl-folder-set-id-name (wl-folder-get-entity-id (car entity))
1811 ;; (wl-push entities entity-stack))
1812 ;; (setq entities (nth 2 entity))
1814 ;; ((stringp entity)
1815 ;; (wl-folder-set-entity-info entity
1816 ;; (wl-folder-get-entity-info entity)
1819 ;; (wl-folder-set-id-name (wl-folder-get-entity-id entity)
1822 ;; (setq entities (wl-pop entity-stack))))
1825 (defun wl-folder-create-newsgroups-from-nntp-access2 (entity)
1826 (let ((flist (nth 2 entity))
1835 (wl-folder-create-newsgroups-from-nntp-access2 fld)
1836 (nth 1 (elmo-folder-get-spec fld))))
1838 (elmo-nntp-make-groups-hashtb folders 1024))
1841 (defun wl-folder-create-newsgroups-from-nntp-access (entity)
1842 (let ((flist (nth 2 entity))
1847 ((consp (car flist))
1848 (wl-folder-create-newsgroups-from-nntp-access (car flist)))
1850 (list (nth 1 (elmo-folder-get-spec (car flist)))))))
1851 (setq flist (cdr flist)))
1854 (defun wl-folder-create-newsgroups-hashtb (entity &optional is-list info)
1855 (let ((entities (if is-list entity (list entity)))
1856 entity-stack spec-list folders fld make-hashtb)
1857 (and info (message "Creating newsgroups..."))
1859 (setq entity (wl-pop entities))
1862 (if (eq (nth 1 entity) 'access)
1863 (when (eq (elmo-folder-get-type (car entity)) 'nntp)
1865 (wl-folder-create-newsgroups-from-nntp-access entity))
1866 (setq make-hashtb t))
1868 (wl-push entities entity-stack))
1869 (setq entities (nth 2 entity))))
1871 (setq spec-list (elmo-folder-get-primitive-spec-list entity))
1873 (when (and (eq (caar spec-list) 'nntp)
1874 (setq fld (nth 1 (car spec-list))))
1875 (wl-append folders (list (elmo-string fld))))
1876 (setq spec-list (cdr spec-list)))))
1878 (setq entities (wl-pop entity-stack))))
1879 (and info (message "Creating newsgroups...done"))
1880 (if (or folders make-hashtb)
1881 (elmo-nntp-make-groups-hashtb folders))))
1883 (defun wl-folder-get-path (entity target-id &optional string)
1884 (let ((entities (list entity))
1885 entity-stack result-path)
1889 (setq entity (wl-pop entities))
1892 (if (and (or (not string) (string= string (car entity)))
1893 ;; don't use eq, `id' is string on Nemacs.
1894 (equal target-id (wl-folder-get-entity-id (car entity))))
1896 (wl-push target-id result-path))
1897 (wl-push (wl-folder-get-entity-id (car entity)) result-path))
1898 (wl-push entities entity-stack)
1899 (setq entities (nth 2 entity)))
1901 (if (and (or (not string) (string= string entity))
1902 ;; don't use eq, `id' is string on Nemacs.
1903 (equal target-id (wl-folder-get-entity-id entity)))
1905 (wl-push target-id result-path)))))
1907 (while (and entity-stack
1909 (setq result-path (cdr result-path))
1910 (setq entities (wl-pop entity-stack)))))))))
1912 (defun wl-folder-create-group-alist (entity)
1914 (let ((flist (nth 2 entity))
1915 (cur-alist (list (cons (car entity) nil)))
1918 (if (consp (car flist))
1919 (wl-append append-alist
1920 (wl-folder-create-group-alist (car flist))))
1921 (setq flist (cdr flist)))
1922 (append cur-alist append-alist))))
1924 (defun wl-folder-init-info-hashtb ()
1925 (let ((info-alist (and wl-folder-info-save
1926 (elmo-msgdb-finfo-load))))
1927 (elmo-folder-info-make-hashtb
1929 wl-folder-entity-hashtb)))
1930 ;;; (wl-folder-resume-entity-hashtb-by-finfo
1931 ;;; wl-folder-entity-hashtb
1934 (defun wl-folder-cleanup-variables ()
1935 (setq wl-folder-entity nil
1936 wl-folder-entity-hashtb nil
1937 wl-folder-entity-id-name-hashtb nil
1938 wl-folder-group-alist nil
1939 wl-folder-petname-alist nil
1940 wl-folder-newsgroups-hashtb nil
1941 wl-fldmgr-cut-entity-list nil
1942 wl-fldmgr-modified nil
1943 wl-fldmgr-modified-access-list nil
1947 (defun wl-make-plugged-alist ()
1948 (let ((entity-list (wl-folder-get-entity-list wl-folder-entity))
1949 (add (not wl-reset-plugged-alist)))
1951 (elmo-folder-set-plugged
1952 (elmo-string (car entity-list)) wl-plugged add)
1953 (setq entity-list (cdr entity-list)))
1954 ;; smtp posting server
1955 (when wl-smtp-posting-server
1956 (elmo-set-plugged wl-plugged
1957 wl-smtp-posting-server ; server
1958 (or (and (boundp 'smtp-service) smtp-service)
1960 nil nil "smtp" add))
1961 ;; nntp posting server
1962 (when wl-nntp-posting-server
1963 (elmo-set-plugged wl-plugged
1964 wl-nntp-posting-server
1965 elmo-default-nntp-port
1966 nil nil "nntp" add))
1967 (run-hooks 'wl-make-plugged-hook)))
1969 (defvar wl-folder-init-func 'wl-local-folder-init)
1971 (defun wl-folder-init ()
1972 "Call `wl-folder-init-func' function."
1974 (funcall wl-folder-init-func))
1976 (defun wl-local-folder-init ()
1977 "Initialize local folder."
1978 (message "Initializing folder...")
1980 (set-buffer wl-folder-buffer-name)
1981 (let ((entity (wl-folder-create-folder-entity))
1982 (inhibit-read-only t))
1983 (setq wl-folder-entity entity)
1984 (setq wl-folder-entity-id 0)
1985 (wl-folder-entity-assign-id wl-folder-entity)
1986 (setq wl-folder-entity-hashtb
1987 (wl-folder-create-entity-hashtb entity))
1988 (setq wl-folder-group-alist
1989 (wl-folder-create-group-alist entity))
1990 (setq wl-folder-newsgroups-hashtb
1991 (wl-folder-create-newsgroups-hashtb wl-folder-entity))
1992 (wl-folder-init-info-hashtb)))
1993 (message "Initializing folder...done"))
1995 (defun wl-folder-get-realname (petname)
1999 wl-folder-petname-alist))
2002 (defun wl-folder-get-petname (folder)
2006 wl-folder-petname-alist))
2009 (defun wl-folder-get-entity-with-petname ()
2010 (let ((alist wl-folder-petname-alist)
2011 (hashtb (copy-sequence wl-folder-entity-hashtb)))
2013 (wl-folder-set-entity-info (cdar alist) nil hashtb)
2014 (setq alist (cdr alist)))
2017 (defun wl-folder-get-newsgroups (folder)
2018 "Return Newsgroups field value string for FOLDER newsgroup.
2019 If FOLDER is multi, return comma separated string (cross post)."
2020 (let ((flist (elmo-folder-get-primitive-folder-list folder)) ; multi
2022 (while (setq fld (car flist))
2024 (cond ((eq 'nntp (elmo-folder-get-type fld))
2025 (nth 1 (elmo-folder-get-spec fld)))
2026 ((eq 'localnews (elmo-folder-get-type fld))
2027 (elmo-replace-in-string
2028 (nth 1 (elmo-folder-get-spec fld)) "/" "\\."))))
2030 (setq newsgroups (if (stringp newsgroups)
2031 (concat newsgroups "," ret)
2033 (setq flist (cdr flist)))
2034 (list nil nil newsgroups)))
2036 (defun wl-folder-guess-mailing-list-by-refile-rule (folder)
2037 "Return ML address guess by FOLDER.
2038 Use `wl-subscribed-mailing-list' and `wl-refile-rule-alist'.
2040 (setq folder (car (elmo-folder-get-primitive-folder-list folder)))
2041 (unless (memq (elmo-folder-get-type folder)
2043 (let ((rules wl-refile-rule-alist)
2044 mladdress tokey toalist histkey)
2046 (if (or (and (stringp (car (car rules)))
2047 (string-match "[Tt]o" (car (car rules))))
2048 (and (listp (car (car rules)))
2049 (elmo-string-matched-member "to" (car (car rules))
2051 (setq toalist (append toalist (cdr (car rules)))))
2052 (setq rules (cdr rules)))
2053 (setq tokey (car (rassoc folder toalist)))
2054 ;;; (setq histkey (car (rassoc folder wl-refile-alist)))
2055 ;; case-ignore search `wl-subscribed-mailing-list'
2058 (elmo-string-matched-member tokey wl-subscribed-mailing-list t)
2062 (defun wl-folder-guess-mailing-list-by-folder-name (folder)
2063 "Return ML address guess by FOLDER name's last hierarchy.
2064 Use `wl-subscribed-mailing-list'."
2065 (setq folder (car (elmo-folder-get-primitive-folder-list folder)))
2066 (when (memq (elmo-folder-get-type folder)
2067 '(localdir imap4 maildir))
2068 (let (key mladdress)
2069 (setq folder ; make folder name simple
2070 (if (eq 'imap4 (elmo-folder-get-type folder))
2071 (elmo-imap4-spec-mailbox (elmo-imap4-get-spec folder))
2072 (substring folder 1)))
2073 (when (string-match "[^\\./]+$" folder) ; last hierarchy
2074 (setq key (regexp-quote
2075 (concat (substring folder (match-beginning 0)) "@")))
2077 (elmo-string-matched-member
2078 key wl-subscribed-mailing-list 'case-ignore))
2079 (if (stringp mladdress)
2080 (list mladdress nil nil)
2083 (defun wl-folder-update-diff-line (diffs)
2084 (let ((inhibit-read-only t)
2085 (buffer-read-only nil)
2087 cur-unread new-unread
2092 (setq id (get-text-property (point) 'wl-folder-entity-id))
2093 (when (looking-at "^[ ]*\\(.*\\):\\([0-9\\*-]*\\)/\\([0-9\\*-]*\\)/\\([0-9\\*]*\\)")
2094 ;;(looking-at "^[ ]*\\([^\\[].+\\):\\([0-9\\*-]*/[0-9\\*-]*/[0-9\\*]*\\)")
2095 (setq cur-new (string-to-int
2096 (wl-match-buffer 2)))
2097 (setq cur-unread (string-to-int
2098 (wl-match-buffer 3)))
2099 (setq cur-all (string-to-int
2100 (wl-match-buffer 4)))
2101 (delete-region (match-beginning 2)
2103 (goto-char (match-beginning 2))
2104 (insert (format "%s/%s/%s"
2105 (setq new-new (+ cur-new (nth 0 diffs)))
2106 (setq new-unread (+ cur-unread (nth 1 diffs)))
2107 (setq new-all (+ cur-all (nth 2 diffs)))))
2108 (put-text-property (match-beginning 2) (point)
2109 'wl-folder-entity-id id)
2110 (if wl-use-highlight-mouse-line
2111 (put-text-property (match-beginning 2) (point)
2112 'mouse-face 'highlight))
2113 (wl-highlight-folder-group-line (list new-new new-unread new-all))
2114 (setq buffer-read-only t)
2115 (set-buffer-modified-p nil)))))
2117 (defun wl-folder-update-line (nums &optional is-group)
2118 (let ((inhibit-read-only t)
2119 (buffer-read-only nil)
2123 (setq id (get-text-property (point) 'wl-folder-entity-id))
2124 (if (looking-at "^[ ]*\\(.*\\):\\([0-9\\*-]*/[0-9\\*-]*/[0-9\\*]*\\)")
2125 ;;; (looking-at "^[ ]*\\([^\\[].+\\):\\([0-9\\*-]*/[0-9\\*-]*/[0-9\\*]*\\)")
2127 (delete-region (match-beginning 2)
2129 (goto-char (match-beginning 2))
2130 (insert (format "%s/%s/%s"
2131 (or (nth 0 nums) "*")
2132 (or (and (nth 0 nums)(nth 1 nums)
2133 (+ (nth 0 nums)(nth 1 nums)))
2135 (or (nth 2 nums) "*")))
2136 (put-text-property (match-beginning 2) (point)
2137 'wl-folder-entity-id id)
2139 ;; update only colors
2140 (wl-highlight-folder-group-line nums)
2141 (wl-highlight-folder-current-line nums))
2142 (set-buffer-modified-p nil))))))
2144 (defun wl-folder-goto-folder (&optional arg)
2146 (wl-folder-goto-folder-subr nil arg))
2148 (defun wl-folder-goto-folder-subr (&optional folder sticky)
2150 (let (summary-buf fld-name entity id error-selecting)
2151 ;;; (setq fld-name (wl-folder-get-entity-from-buffer))
2152 ;;; (if (or (null fld-name)
2153 ;;; (assoc fld-name wl-folder-group-alist))
2154 (setq fld-name wl-default-folder)
2155 (setq fld-name (or folder
2156 (wl-summary-read-folder fld-name)))
2157 (if (and (setq entity
2158 (wl-folder-search-entity-by-name fld-name
2161 (setq id (wl-folder-get-entity-id entity)))
2162 (wl-folder-set-current-entity-id id))
2163 (setq summary-buf (wl-summary-get-buffer-create fld-name sticky))
2164 (if wl-stay-folder-window
2165 (wl-folder-select-buffer summary-buf)
2166 (if (and summary-buf
2167 (get-buffer-window summary-buf))
2169 (wl-summary-goto-folder-subr fld-name
2170 (wl-summary-get-sync-range fld-name)
2173 (defun wl-folder-suspend ()
2175 (run-hooks 'wl-folder-suspend-hook)
2176 (wl-folder-info-save)
2177 (wl-crosspost-alist-save)
2179 (format "^\\(%s\\)$"
2180 (mapconcat 'identity
2181 (list (format "%s\\(:.*\\)?"
2182 (default-value 'wl-message-buf-name))
2183 wl-original-buf-name)
2185 (if (fboundp 'mmelmo-cleanup-entity-buffers)
2186 (mmelmo-cleanup-entity-buffers))
2187 (bury-buffer wl-folder-buffer-name)
2188 (delete-windows-on wl-folder-buffer-name t))
2190 (defun wl-folder-info-save ()
2191 (when (and wl-folder-info-save
2192 wl-folder-info-alist-modified)
2193 (let ((entities (list wl-folder-entity))
2194 entity entity-stack info-alist info)
2196 (setq entity (wl-pop entities))
2200 (wl-push entities entity-stack))
2201 (setq entities (nth 2 entity)))
2203 (when (and (setq info (elmo-folder-get-info entity))
2204 (not (equal info '(nil))))
2205 (wl-append info-alist (list (list (elmo-string entity)
2206 (list (nth 3 info) ;; max
2207 (nth 2 info) ;; length
2209 (nth 1 info)) ;; unread
2212 (setq entities (wl-pop entity-stack))))
2213 (elmo-msgdb-finfo-save info-alist)
2214 (setq wl-folder-info-alist-modified nil))))
2216 (defun wl-folder-goto-first-unread-folder (&optional arg)
2218 (let ((entities (list wl-folder-entity))
2219 entity entity-stack ret-val
2224 (setq entity (wl-pop entities))
2228 (wl-push entities entity-stack))
2229 (setq entities (nth 2 entity)))
2231 (if (and (setq finfo (wl-folder-get-entity-info entity))
2232 (and (nth 0 finfo)(nth 1 finfo))
2233 (> (+ (nth 0 finfo)(nth 1 finfo)) 0))
2234 (throw 'done entity))
2235 (wl-append ret-val (list entity))))
2237 (setq entities (wl-pop entity-stack))))))
2241 (wl-folder-jump-folder first-entity)
2243 (wl-folder-goto-folder-subr first-entity))
2244 (message "No unread folder"))))
2246 (defun wl-folder-jump-folder (&optional fld-name noopen)
2249 (setq fld-name (wl-summary-read-folder wl-default-folder)))
2250 (goto-char (point-min))
2252 (wl-folder-open-folder fld-name))
2253 (and (wl-folder-buffer-search-entity fld-name)
2254 (beginning-of-line)))
2256 (defun wl-folder-get-entity-list (entity)
2257 (let ((entities (list entity))
2258 entity-stack ret-val)
2260 (setq entity (wl-pop entities))
2264 (wl-push entities entity-stack))
2265 (setq entities (nth 2 entity)))
2267 (wl-append ret-val (list entity))))
2269 (setq entities (wl-pop entity-stack))))
2272 (defun wl-folder-open-unread-folder (entity)
2274 (let ((alist (wl-folder-get-entity-list entity))
2276 finfo path-list path id)
2278 (when (and (setq finfo (wl-folder-get-entity-info (car alist)))
2279 (nth 0 finfo) (nth 1 finfo)
2280 (> (+ (nth 0 finfo)(nth 1 finfo)) 0))
2281 (setq unread (+ unread (+ (nth 0 finfo)(nth 1 finfo))))
2282 (setq id (wl-folder-get-entity-id (car alist)))
2283 (setq path (delete id (wl-folder-get-path
2287 (if (not (member path path-list))
2288 (wl-append path-list (list path))))
2289 (setq alist (cdr alist)))
2291 (wl-folder-open-folder-sub (car path-list))
2292 (setq path-list (cdr path-list)))
2293 (message "%s unread folder"
2294 (if (> unread 0) unread "No")))))
2296 (defun wl-folder-open-unread-current-entity ()
2298 (let ((entity-name (wl-folder-get-entity-from-buffer))
2299 (group (wl-folder-buffer-group-p)))
2301 (wl-folder-open-unread-folder
2303 (wl-folder-search-group-entity-by-name entity-name
2307 (defun wl-folder-open-only-unread-folder ()
2310 (wl-folder-prev-entity-skip-invalid t)
2311 (wl-folder-get-entity-from-buffer t))))
2312 (wl-folder-open-all-unread-folder)
2314 (goto-char (point-max))
2315 (while (and (re-search-backward
2316 "^[ ]*\\[[-]\\].+:0/0/[0-9-]+" nil t)
2318 (wl-folder-jump-to-current-entity) ;; close it
2320 (wl-folder-move-path id)
2323 (defun wl-folder-open-all-unread-folder (&optional arg)
2326 (wl-folder-prev-entity-skip-invalid t)
2327 (wl-folder-get-entity-from-buffer t))))
2328 (wl-folder-open-unread-folder wl-folder-entity)
2330 (wl-folder-move-path id)
2331 (goto-char (point-min))
2332 (wl-folder-next-unread t))))
2334 (defun wl-folder-open-folder (&optional fld-name)
2337 (setq fld-name (wl-summary-read-folder wl-default-folder)))
2338 (let* ((id (wl-folder-get-entity-id
2339 (wl-folder-search-entity-by-name fld-name wl-folder-entity
2341 (path (and id (wl-folder-get-path wl-folder-entity id))))
2343 (wl-folder-open-folder-sub path))))
2345 (defun wl-folder-open-folder-sub (path)
2346 (let ((inhibit-read-only t)
2347 (buffer-read-only nil)
2351 (goto-char (point-min))
2353 (wl-folder-buffer-search-group
2354 (wl-folder-get-petname
2355 (if (stringp (car path))
2357 (wl-folder-get-folder-name-by-id
2360 (setq path (cdr path))
2361 (if (and (looking-at wl-folder-group-regexp)
2362 (string= "+" (wl-match-buffer 2)));; closed group
2364 (setq indent (wl-match-buffer 1))
2365 (setq name (wl-folder-get-realname (wl-match-buffer 3)))
2366 (setq entity (wl-folder-search-group-entity-by-name
2370 (setcdr (assoc (car entity) wl-folder-group-alist) t)
2371 (if (eq 'access (cadr entity))
2372 (wl-folder-maybe-load-folder-list entity))
2373 (wl-folder-insert-entity indent entity)
2374 (delete-region (save-excursion (beginning-of-line)
2376 (save-excursion (end-of-line)
2378 (set-buffer-modified-p nil))))
2380 (defun wl-folder-open-all-pre ()
2381 (let ((entities (list wl-folder-entity))
2382 entity entity-stack group-entry)
2384 (setq entity (wl-pop entities))
2387 (unless (or (not (setq group-entry
2388 (assoc (car entity) wl-folder-group-alist)))
2390 (setcdr group-entry t)
2391 (when (eq 'access (cadr entity))
2392 (wl-folder-maybe-load-folder-list entity)))
2394 (wl-push entities entity-stack))
2395 (setq entities (nth 2 entity))))
2397 (setq entities (wl-pop entity-stack))))))
2399 (defun wl-folder-open-all (&optional refresh)
2401 (let* ((inhibit-read-only t)
2402 (buffer-read-only nil)
2403 (len (length wl-folder-group-alist))
2408 (wl-folder-prev-entity-skip-invalid t)
2409 (wl-folder-get-entity-from-buffer t)))
2410 (alist wl-folder-group-alist))
2412 (setcdr (pop alist) t))
2414 (wl-folder-insert-entity " " wl-folder-entity)
2415 (wl-folder-move-path id))
2416 (message "Opening all folders...")
2417 (wl-folder-open-all-pre)
2419 (goto-char (point-min))
2420 (while (re-search-forward
2421 "^\\([ ]*\\)\\[\\([+]\\)\\]\\(.+\\):[-0-9-]+/[0-9-]+/[0-9-]+\n"
2423 (setq indent (wl-match-buffer 1))
2424 (setq name (wl-folder-get-realname (wl-match-buffer 3)))
2425 (setq entity (wl-folder-search-group-entity-by-name
2429 (setcdr (assoc (car entity) wl-folder-group-alist) t)
2431 (wl-folder-insert-entity indent entity)
2432 (delete-region (save-excursion (beginning-of-line)
2434 (save-excursion (end-of-line)
2436 (when (> len elmo-display-progress-threshold)
2438 (if (or (zerop (% i 5)) (= i len))
2439 (elmo-display-progress
2440 'wl-folder-open-all "Opening all folders..."
2441 (/ (* i 100) len)))))
2442 (when (> len elmo-display-progress-threshold)
2443 (elmo-display-progress
2444 'wl-folder-open-all "Opening all folders..." 100))))
2445 (message "Opening all folders...done")
2446 (set-buffer-modified-p nil)))
2448 (defun wl-folder-close-all ()
2450 (let ((inhibit-read-only t)
2451 (buffer-read-only nil)
2452 (alist wl-folder-group-alist)
2454 (wl-folder-prev-entity-skip-invalid t)
2455 (wl-folder-get-entity-from-buffer t))))
2457 (setcdr (car alist) nil)
2458 (setq alist (cdr alist)))
2459 (setcdr (assoc (car wl-folder-entity) wl-folder-group-alist) t)
2461 (wl-folder-insert-entity " " wl-folder-entity)
2462 (wl-folder-move-path id)
2464 (set-buffer-modified-p nil)))
2466 (defun wl-folder-open-close ()
2467 "Open or close parent entity."
2471 (if (wl-folder-buffer-group-p)
2472 ;; if group (whether opend or closed.)
2473 (wl-folder-jump-to-current-entity)
2476 (setq indent (save-excursion
2477 (re-search-forward "\\([ ]*\\)." nil t)
2478 (wl-match-buffer 1)))
2479 (while (looking-at indent)
2481 (wl-folder-jump-to-current-entity))))
2483 (defsubst wl-folder-access-subscribe-p (group folder)
2484 (let (subscr regexp match)
2485 (if (setq subscr (wl-get-assoc-list-value
2486 wl-folder-access-subscribe-alist
2489 (setq regexp (mapconcat 'identity (cdr subscr) "\\|"))
2490 (setq match (string-match regexp folder))
2496 (defun wl-folder-update-access-group (entity new-flist)
2497 (let* ((flist (nth 2 entity))
2498 (unsubscribes (nth 3 entity))
2499 (len (+ (length flist) (length unsubscribes)))
2501 diff new-unsubscribes removes
2502 subscribed-list folder group entry)
2503 ;; check subscribed groups
2506 ((listp (car flist)) ;; group
2507 (setq group (elmo-string (caar flist)))
2509 ((assoc group new-flist) ;; found in new-flist
2510 (setq new-flist (delete (assoc group new-flist)
2512 (if (wl-folder-access-subscribe-p (car entity) group)
2513 (wl-append subscribed-list (list (car flist)))
2514 (wl-append new-unsubscribes (list (car flist)))
2517 (setq wl-folder-group-alist
2518 (delete (wl-string-assoc group wl-folder-group-alist)
2519 wl-folder-group-alist))
2520 (wl-append removes (list (list group))))))
2522 (setq folder (elmo-string (car flist)))
2524 ((member folder new-flist) ;; found in new-flist
2525 (setq new-flist (delete folder new-flist))
2526 (if (wl-folder-access-subscribe-p (car entity) folder)
2527 (wl-append subscribed-list (list (car flist)))
2528 (wl-append new-unsubscribes (list folder))
2531 (wl-append removes (list folder))))))
2532 (when (> len elmo-display-progress-threshold)
2534 (if (or (zerop (% i 10)) (= i len))
2535 (elmo-display-progress
2536 'wl-folder-update-access-group "Updating access group..."
2537 (/ (* i 100) len))))
2538 (setq flist (cdr flist)))
2539 ;; check unsubscribed groups
2542 ((listp (car unsubscribes))
2543 (when (setq entry (assoc (caar unsubscribes) new-flist))
2544 (setq new-flist (delete entry new-flist))
2545 (wl-append new-unsubscribes (list (car unsubscribes)))))
2547 (when (member (car unsubscribes) new-flist)
2548 (setq new-flist (delete (car unsubscribes) new-flist))
2549 (wl-append new-unsubscribes (list (car unsubscribes))))))
2550 (when (> len elmo-display-progress-threshold)
2552 (if (or (zerop (% i 10)) (= i len))
2553 (elmo-display-progress
2554 'wl-folder-update-access-group "Updating access group..."
2555 (/ (* i 100) len))))
2556 (setq unsubscribes (cdr unsubscribes)))
2558 (if (or new-flist removes)
2561 (mapcar '(lambda (x)
2562 (cond ((consp x) (list (car x) 'access))
2566 (let ((new-list new-flist))
2568 (if (not (wl-folder-access-subscribe-p
2570 (if (listp (car new-list))
2575 (wl-append new-unsubscribes (list (car new-list)))
2576 (setq new-flist (delete (car new-list) new-flist)))
2578 ((listp (car new-list))
2579 ;; check group exists
2580 (if (wl-string-assoc (caar new-list) wl-folder-group-alist)
2582 (message "%s: group already exists." (caar new-list))
2584 (wl-append new-unsubscribes (list (car new-list)))
2585 (setq new-flist (delete (car new-list) new-flist)))
2586 (wl-append wl-folder-group-alist
2587 (list (cons (caar new-list) nil)))))))
2588 (setq new-list (cdr new-list))))
2590 (message "%d new folder(s)." (length new-flist))
2591 (message "Updating access group...done"))
2592 (wl-append new-flist subscribed-list) ;; new is first
2593 (run-hooks 'wl-folder-update-access-group-hook)
2594 (setcdr (cdr entity) (list new-flist new-unsubscribes))
2595 (list diff new-flist new-unsubscribes removes)))
2597 (defun wl-folder-prefetch-entity (entity)
2598 "Prefetch all new messages in the ENTITY."
2601 (let ((flist (nth 2 entity))
2606 (setq result (wl-folder-prefetch-entity (car flist)))
2607 (setq sum-done (+ sum-done (car result)))
2608 (setq sum-all (+ sum-all (cdr result)))
2609 (setq flist (cdr flist)))
2610 (message "Prefetched %d/%d message(s) in \"%s\"."
2612 (wl-folder-get-petname (car entity)))
2613 (cons sum-done sum-all)))
2615 (let ((nums (wl-folder-get-entity-info entity))
2616 (wl-summary-highlight (if (or (wl-summary-sticky-p entity)
2617 (wl-summary-always-sticky-folder-p
2619 wl-summary-highlight))
2620 wl-summary-exit-next-move
2621 wl-auto-select-first ret-val
2623 (setq count (or (car nums) 0))
2624 (setq count (+ count (wl-folder-count-incorporates entity)))
2625 (if (or (null (car nums)) ; unknown
2627 (let ((wl-summary-buffer-name (concat
2628 wl-summary-buffer-name
2629 (symbol-name this-command)))
2630 (wl-message-buf-name (concat wl-message-buf-name
2631 (symbol-name this-command))))
2632 (save-window-excursion
2634 (wl-summary-goto-folder-subr entity
2635 (wl-summary-get-sync-range entity)
2637 (setq ret-val (wl-summary-incorporate))
2642 (defun wl-folder-count-incorporates (folder)
2643 (let ((marks (elmo-msgdb-mark-load (elmo-msgdb-expand-path folder)))
2646 (if (member (cadr (car marks))
2647 wl-summary-incorporate-marks)
2649 (setq marks (cdr marks)))
2652 (defun wl-folder-prefetch-current-entity (&optional no-check)
2653 "Prefetch all uncached messages in the folder at position.
2654 If current line is group folder, all subfolders are prefetched."
2657 (let ((entity-name (wl-folder-get-entity-from-buffer))
2658 (group (wl-folder-buffer-group-p))
2659 wl-folder-check-entity-hook
2664 (wl-folder-search-group-entity-by-name entity-name
2668 (wl-folder-check-entity entity))
2669 (wl-folder-prefetch-entity entity)))))
2671 (defun wl-folder-drop-unsync-entity (entity)
2672 "Drop all unsync messages in the ENTITY."
2675 (let ((flist (nth 2 entity)))
2677 (wl-folder-drop-unsync-entity (car flist))
2678 (setq flist (cdr flist)))))
2680 (let ((nums (wl-folder-get-entity-info entity))
2681 wl-summary-highlight wl-auto-select-first new)
2682 (setq new (or (car nums) 0))
2684 (let ((wl-summary-buffer-name (concat
2685 wl-summary-buffer-name
2686 (symbol-name this-command)))
2687 (wl-message-buf-name (concat wl-message-buf-name
2688 (symbol-name this-command))))
2689 (save-window-excursion
2691 (wl-summary-goto-folder-subr entity 'no-sync nil)
2692 (wl-summary-drop-unsync)
2693 (wl-summary-exit)))))))))
2695 (defun wl-folder-drop-unsync-current-entity (&optional force-check)
2696 "Drop all unsync messages in the folder at position.
2697 If current line is group folder, all subfolders are dropped.
2698 If optional arg exists, don't check any folders."
2701 (let ((entity-name (wl-folder-get-entity-from-buffer))
2702 (group (wl-folder-buffer-group-p))
2703 wl-folder-check-entity-hook
2705 (when (and entity-name
2707 "Drop all unsync messages in %s?" entity-name)))
2710 (wl-folder-search-group-entity-by-name entity-name
2713 (if (null force-check)
2714 (wl-folder-check-entity entity))
2715 (wl-folder-drop-unsync-entity entity)
2716 (message "All unsync messages in %s are dropped!" entity-name)))))
2718 (defun wl-folder-write-current-folder ()
2719 "Write message to current folder's newsgroup or mailing-list.
2720 Call `wl-summary-write-current-folder' with current folder name."
2722 (unless (wl-folder-buffer-group-p)
2723 (wl-summary-write-current-folder
2724 (wl-folder-get-realname (wl-folder-entity-name)))))
2726 (defun wl-folder-mimic-kill-buffer ()
2727 "Kill the current (Folder) buffer with query."
2729 (let ((bufname (read-buffer (format "Kill buffer: (default %s) "
2731 wl-interactive-exit)
2732 (if (or (not bufname)
2733 (string-equal bufname "")
2734 (string-equal bufname (buffer-name)))
2736 (kill-buffer bufname))))
2738 (defun wl-folder-create-subr (entity)
2739 (if (not (elmo-folder-creatable-p entity))
2740 (error "Folder %s is not found" entity)
2742 (format "Folder %s does not exist, create it?"
2745 (setq wl-folder-entity-hashtb
2746 (wl-folder-create-entity-hashtb
2747 entity wl-folder-entity-hashtb))
2748 (unless (elmo-create-folder entity)
2749 (error "Create folder failed")))
2750 (error "Folder %s is not created" entity))))
2752 (defun wl-folder-confirm-existence (folder &optional force)
2754 (unless (elmo-folder-exists-p folder)
2755 (wl-folder-create-subr folder))
2756 (unless (or (wl-folder-entity-exists-p folder)
2757 (file-exists-p (elmo-msgdb-expand-path folder))
2758 (elmo-folder-exists-p folder))
2759 (wl-folder-create-subr folder))))
2762 (product-provide (provide 'wl-folder) (require 'wl-version))
2764 ;;; wl-folder.el ends here