1 ;;; wl-folder.el --- Folder mode for Wanderlust.
3 ;; Copyright (C) 1998,1999,2000 Yuuichi Teranishi <teranisi@gohome.org>
4 ;; Copyright (C) 1998,1999,2000 Masahiro MURATA <muse@ba2.so-net.ne.jp>
6 ;; Author: Yuuichi Teranishi <teranisi@gohome.org>
7 ;; Masahiro MURATA <muse@ba2.so-net.ne.jp>
8 ;; Keywords: mail, net news
10 ;; This file is part of Wanderlust (Yet Another Message Interface on Emacsen).
12 ;; This program is free software; you can redistribute it and/or modify
13 ;; it under the terms of the GNU General Public License as published by
14 ;; the Free Software Foundation; either version 2, or (at your option)
17 ;; This program is distributed in the hope that it will be useful,
18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
20 ;; GNU General Public License for more details.
22 ;; You should have received a copy of the GNU General Public License
23 ;; along with GNU Emacs; see the file COPYING. If not, write to the
24 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
25 ;; Boston, MA 02111-1307, USA.
39 (require 'easymenu) ; needed here.
49 (defvar wl-folder-buffer-name "Folder")
50 (defvar wl-folder-entity nil) ; desktop entity.
51 (defvar wl-folder-group-alist nil) ; opened or closed
52 (defvar wl-folder-entity-id nil) ; id
53 (defvar wl-folder-entity-hashtb nil)
54 (defvar wl-folder-entity-id-name-hashtb nil)
55 (defvar wl-folder-elmo-folder-hashtb nil) ; name => elmo folder structure
57 (defvar wl-folder-newsgroups-hashtb nil)
58 (defvar wl-folder-info-alist-modified nil)
59 (defvar wl-folder-completion-function nil)
61 (defvar wl-folder-mode-map nil)
63 (defvar wl-folder-buffer-disp-summary nil)
64 (defvar wl-folder-buffer-cur-entity-id nil)
65 (defvar wl-folder-buffer-cur-path nil)
66 (defvar wl-folder-buffer-cur-point nil)
68 (make-variable-buffer-local 'wl-folder-buffer-disp-summary)
69 (make-variable-buffer-local 'wl-folder-buffer-cur-entity-id)
70 (make-variable-buffer-local 'wl-folder-buffer-cur-path)
71 (make-variable-buffer-local 'wl-folder-buffer-cur-point)
73 (defconst wl-folder-entity-regexp "^\\([ ]*\\)\\(\\[[\\+-]\\]\\)?\\([^\\[].+\\):[-*0-9]+/[-*0-9]+/[-*0-9]+")
74 (defconst wl-folder-group-regexp "^\\([ ]*\\)\\[\\([\\+-]\\)\\]\\(.+\\):[-0-9-]+/[0-9-]+/[0-9-]+\n")
75 ;; 1:indent 2:opened 3:group-name
76 (defconst wl-folder-unsync-regexp ":[^0\\*][0-9]*/[0-9\\*-]+/[0-9\\*-]+$")
78 (defvar wl-folder-mode-menu-spec
80 ["Enter Current Folder" wl-folder-jump-to-current-entity t]
81 ["Prev Folder" wl-folder-prev-entity t]
82 ["Next Folder" wl-folder-next-entity t]
83 ["Check Current Folder" wl-folder-check-current-entity t]
84 ["Sync Current Folder" wl-folder-sync-current-entity t]
85 ; ["Drop Current Folder" wl-folder-drop-unsync-current-entity t]
86 ["Prefetch Current Folder" wl-folder-prefetch-current-entity t]
87 ["Mark as Read all Current Folder" wl-folder-mark-as-read-all-current-entity t]
88 ["Expire Current Folder" wl-folder-expire-current-entity t]
89 ["Empty trash" wl-folder-empty-trash t]
90 ["Flush queue" wl-folder-flush-queue t]
91 ["Open All" wl-folder-open-all t]
92 ["Open All Unread folder" wl-folder-open-all-unread-folder t]
93 ["Close All" wl-folder-close-all t]
95 ["Add folder" wl-fldmgr-add t]
96 ["Add group" wl-fldmgr-make-group t]
97 ["Copy" wl-fldmgr-copy t]
98 ["Cut" wl-fldmgr-cut t]
99 ["Paste" wl-fldmgr-yank t]
100 ["Set petname" wl-fldmgr-set-petname t]
101 ["Rename" wl-fldmgr-rename t]
102 ["Save" wl-fldmgr-save-folders t]
104 ["Unsubscribe" wl-fldmgr-unsubscribe t]
105 ["Display all" wl-fldmgr-access-display-all t])
107 ["Write a message" wl-draft t]
109 ["Toggle Plug Status" wl-toggle-plugged t]
110 ["Change Plug Status" wl-plugged-change t]
112 ["Save Current Status" wl-save t]
113 ["Update Satus" wl-status-update t]
118 (defun wl-folder-setup-mouse ()
119 (define-key wl-folder-mode-map 'button2 'wl-folder-click)
120 (define-key wl-folder-mode-map 'button4 'wl-folder-prev-entity)
121 (define-key wl-folder-mode-map 'button5 'wl-folder-next-entity)
122 (define-key wl-folder-mode-map [(shift button4)]
123 'wl-folder-prev-unread)
124 (define-key wl-folder-mode-map [(shift button5)]
125 'wl-folder-next-unread))
126 (defun wl-folder-setup-mouse ()
127 (define-key wl-folder-mode-map [mouse-2] 'wl-folder-click)
128 (define-key wl-folder-mode-map [mouse-4] 'wl-folder-prev-entity)
129 (define-key wl-folder-mode-map [mouse-5] 'wl-folder-next-entity)
130 (define-key wl-folder-mode-map [S-mouse-4] 'wl-folder-prev-unread)
131 (define-key wl-folder-mode-map [S-mouse-5] 'wl-folder-next-unread)))
133 (if wl-folder-mode-map
135 (setq wl-folder-mode-map (make-sparse-keymap))
136 (define-key wl-folder-mode-map " " 'wl-folder-jump-to-current-entity)
137 ; (define-key wl-folder-mode-map "\M- " 'wl-folder-open-close)
138 (define-key wl-folder-mode-map "/" 'wl-folder-open-close)
139 (define-key wl-folder-mode-map "\C-m" 'wl-folder-jump-to-current-entity)
140 (define-key wl-folder-mode-map "\M-\C-m" 'wl-folder-update-recursive-current-entity)
141 (define-key wl-folder-mode-map "rc" 'wl-folder-mark-as-read-all-region)
142 (define-key wl-folder-mode-map "c" 'wl-folder-mark-as-read-all-current-entity)
143 (define-key wl-folder-mode-map "g" 'wl-folder-goto-folder)
144 (define-key wl-folder-mode-map "j" 'wl-folder-jump-to-current-entity)
145 (define-key wl-folder-mode-map "w" 'wl-draft)
146 (define-key wl-folder-mode-map "W" 'wl-folder-write-current-folder)
147 (define-key wl-folder-mode-map "\C-c\C-o" 'wl-jump-to-draft-buffer)
148 (define-key wl-folder-mode-map "\C-c\C-a" 'wl-addrmgr)
149 (define-key wl-folder-mode-map "rS" 'wl-folder-sync-region)
150 (define-key wl-folder-mode-map "S" 'wl-folder-sync-current-entity)
151 (define-key wl-folder-mode-map "rs" 'wl-folder-check-region)
152 (define-key wl-folder-mode-map "s" 'wl-folder-check-current-entity)
153 (define-key wl-folder-mode-map "I" 'wl-folder-prefetch-current-entity)
154 ; (define-key wl-folder-mode-map "D" 'wl-folder-drop-unsync-current-entity)
155 (define-key wl-folder-mode-map "p" 'wl-folder-prev-entity)
156 (define-key wl-folder-mode-map "n" 'wl-folder-next-entity)
157 (define-key wl-folder-mode-map "v" 'wl-folder-toggle-disp-summary)
158 (define-key wl-folder-mode-map "P" 'wl-folder-prev-unread)
159 (define-key wl-folder-mode-map "N" 'wl-folder-next-unread)
160 (define-key wl-folder-mode-map "J" 'wl-folder-jump-folder)
161 (define-key wl-folder-mode-map "f" 'wl-folder-goto-first-unread-folder)
162 (define-key wl-folder-mode-map "o" 'wl-folder-open-all-unread-folder)
163 (define-key wl-folder-mode-map "[" 'wl-folder-open-all)
164 (define-key wl-folder-mode-map "]" 'wl-folder-close-all)
165 (define-key wl-folder-mode-map "e" 'wl-folder-expire-current-entity)
166 (define-key wl-folder-mode-map "E" 'wl-folder-empty-trash)
167 (define-key wl-folder-mode-map "F" 'wl-folder-flush-queue)
168 (define-key wl-folder-mode-map "q" 'wl-exit)
169 (define-key wl-folder-mode-map "z" 'wl-folder-suspend)
170 (define-key wl-folder-mode-map "\M-t" 'wl-toggle-plugged)
171 (define-key wl-folder-mode-map "\C-t" 'wl-plugged-change)
172 (define-key wl-folder-mode-map "<" 'beginning-of-buffer)
173 (define-key wl-folder-mode-map ">" 'end-of-buffer)
175 (define-key wl-folder-mode-map "m" 'wl-fldmgr-mode-map)
176 (define-key wl-folder-mode-map "*" 'wl-fldmgr-make-multi)
177 (define-key wl-folder-mode-map "+" 'wl-fldmgr-make-group)
178 (define-key wl-folder-mode-map "|" 'wl-fldmgr-make-filter)
179 (define-key wl-folder-mode-map "\M-c" 'wl-fldmgr-copy)
180 (define-key wl-folder-mode-map "\M-w" 'wl-fldmgr-copy-region)
181 (define-key wl-folder-mode-map "\C-k" 'wl-fldmgr-cut)
182 (define-key wl-folder-mode-map "\C-w" 'wl-fldmgr-cut-region)
183 (define-key wl-folder-mode-map "\C-y" 'wl-fldmgr-yank)
184 (define-key wl-folder-mode-map "R" 'wl-fldmgr-rename)
185 (define-key wl-folder-mode-map "u" 'wl-fldmgr-unsubscribe)
186 (define-key wl-folder-mode-map "ru" 'wl-fldmgr-unsubscribe-region)
187 (define-key wl-folder-mode-map "U" 'wl-fldmgr-unsubscribe-region)
188 (define-key wl-folder-mode-map "l" 'wl-fldmgr-access-display-normal)
189 (define-key wl-folder-mode-map "L" 'wl-fldmgr-access-display-all)
190 (define-key wl-folder-mode-map "Z" 'wl-status-update)
191 (define-key wl-folder-mode-map "\C-x\C-s" 'wl-save)
192 (define-key wl-folder-mode-map "\M-s" 'wl-save)
193 (define-key wl-folder-mode-map "\C-xk" 'wl-folder-mimic-kill-buffer)
194 (define-key wl-folder-mode-map "\M-\C-a"
195 'wl-folder-goto-top-of-current-folder)
196 (define-key wl-folder-mode-map "\M-\C-e"
197 'wl-folder-goto-bottom-of-current-folder)
199 (wl-folder-setup-mouse)
203 "Menu used in Folder mode."
204 wl-folder-mode-menu-spec))
206 (defmacro wl-folder-unread-regex (group)
207 (` (concat "^[ ]*.+:[0-9\\*-]+/[^0\\*][0-9]*/[0-9\\*-]+$"
212 (defmacro wl-folder-buffer-group-p ()
213 (` (save-excursion (beginning-of-line)
214 (looking-at wl-folder-group-regexp))))
216 (defmacro wl-folder-folder-name ()
219 (if (or (looking-at "^[ ]*\\[[\\+-]\\]\\(.+\\):[-0-9\\*-]+/[0-9\\*-]+/[0-9\\*-]+\n")
220 (looking-at "^[ ]*\\([^\\[].+\\):.*\n"))
221 (wl-match-buffer 1)))))
223 (defmacro wl-folder-entity-name ()
226 (if (looking-at "^[ ]*\\([^\\[].+\\):.*\n")
227 (wl-match-buffer 1)))))
229 (defun wl-folder-buffer-search-group (group)
232 "^\\([ \t]*\\)\\[[\\+-]\\]"
233 (regexp-quote group) ":[-0-9-]+/[0-9-]+/[0-9-]+") nil t))
235 (defun wl-folder-buffer-search-entity (folder &optional searchname)
236 (let ((search (or searchname (wl-folder-get-petname folder))))
240 (regexp-quote search) ":[-0-9\\*-]+/[0-9\\*-]+/[0-9\\*-]+") nil t)))
242 (defsubst wl-folder-get-folder-name-by-id (entity-id &optional hashtb)
243 (and (numberp entity-id)
244 (elmo-get-hash-val (format "#%d" entity-id)
245 (or hashtb wl-folder-entity-id-name-hashtb))))
247 (defsubst wl-folder-set-id-name (entity-id entity &optional hashtb)
248 (and (numberp entity-id)
249 (elmo-set-hash-val (format "#%d" entity-id)
250 entity (or hashtb wl-folder-entity-id-name-hashtb))))
252 (defmacro wl-folder-get-entity-id (entity)
253 `(get-text-property 0 'wl-folder-entity-id ,entity))
255 (defmacro wl-folder-get-entity-from-buffer (&optional getid)
256 `(let ((id (get-text-property (point)
257 'wl-folder-entity-id)))
260 (wl-folder-get-folder-name-by-id id))))
262 (defmacro wl-folder-entity-exists-p (entity &optional hashtb)
263 (` (let ((sym (intern-soft (, entity)
264 (or (, hashtb) wl-folder-entity-hashtb))))
265 (and sym (boundp sym)))))
267 (defmacro wl-folder-clear-entity-info (entity &optional hashtb)
268 (` (let ((sym (intern-soft (, entity)
269 (or (, hashtb) wl-folder-entity-hashtb))))
273 (defmacro wl-folder-get-entity-info (entity &optional hashtb)
274 (` (elmo-get-hash-val (, entity) (or (, hashtb) wl-folder-entity-hashtb))))
276 (defmacro wl-folder-set-entity-info (entity value &optional hashtb)
277 (` (let* ((hashtb (or (, hashtb) wl-folder-entity-hashtb))
278 (info (wl-folder-get-entity-info (, entity) hashtb)))
279 (elmo-set-hash-val (, entity)
280 (if (< (length (, value)) 4)
281 (append (, value) (list (nth 3 info)))
285 (defun wl-folder-persistent-p (folder)
286 (or (and (wl-folder-search-entity-by-name folder wl-folder-entity
290 (let ((li wl-save-folder-list))
292 (if (string-match (car li) folder)
294 (setq li (cdr li)))))
296 (let ((li wl-no-save-folder-list))
298 (if (string-match (car li) folder)
300 (setq li (cdr li))))))))
302 ;;; ELMO folder structure with cache.
303 (defmacro wl-folder-get-elmo-folder (entity)
304 "Get elmo folder structure from entity."
305 (` (or (wl-folder-elmo-folder-cache-get (, entity))
306 (let* ((name (elmo-string (, entity)))
307 (folder (elmo-make-folder name)))
308 (wl-folder-elmo-folder-cache-put name folder)
311 (defmacro wl-folder-elmo-folder-cache-get (name &optional hashtb)
312 "Returns a elmo folder structure associated with NAME from HASHTB.
313 Default HASHTB is `wl-folder-elmo-folder-hashtb'."
314 (` (elmo-get-hash-val (, name)
315 (or (, hashtb) wl-folder-elmo-folder-hashtb))))
317 (defmacro wl-folder-elmo-folder-cache-put (name folder &optional hashtb)
318 "Get folder elmo folder structure on HASHTB for folder with NAME.
319 Default HASHTB is `wl-folder-elmo-folder-hashtb'."
320 (` (elmo-set-hash-val (, name) (, folder)
321 (or (, hashtb) wl-folder-elmo-folder-hashtb))))
323 (defun wl-folder-prev-entity ()
327 (defun wl-folder-next-entity ()
331 (defun wl-folder-prev-entity-skip-invalid (&optional hereto)
332 "move to previous entity. skip unsubscribed or removed entity."
336 (if (re-search-backward wl-folder-entity-regexp nil t)
338 (goto-char (point-min))))
340 (defun wl-folder-next-entity-skip-invalid (&optional hereto)
341 "Move to next entity. skip unsubscribed or removed entity."
346 (if (re-search-forward wl-folder-entity-regexp nil t)
348 (goto-char (point-max))))
350 (defun wl-folder-search-group-entity-by-name (name entity)
351 (wl-folder-search-entity-by-name name entity 'group))
353 (defun wl-folder-search-entity-by-name (name entity &optional type)
354 (let ((entities (list entity))
358 (setq entity (wl-pop entities))
361 (if (and (not (eq type 'folder))
362 (string= name (car entity)))
363 (throw 'done entity))
365 (wl-push entities entity-stack))
366 (setq entities (nth 2 entity)))
367 ((and (not (eq type 'group))
369 (if (string= name entity)
370 (throw 'done entity))))
372 (setq entities (wl-pop entity-stack)))))))
374 (defun wl-folder-search-entity-list-by-name (name entity &optional get-id)
375 (let ((entities (list entity))
376 entity-stack ret-val)
378 (setq entity (wl-pop entities))
382 (wl-push entities entity-stack))
383 (setq entities (nth 2 entity)))
385 (if (string= name entity)
386 (wl-append ret-val (if get-id
387 (list (wl-folder-get-entity-id entity))
390 (setq entities (wl-pop entity-stack))))
393 (defun wl-folder-get-prev-folder (id &optional unread)
394 (let ((name (if (stringp id)
396 (wl-folder-get-folder-name-by-id id)))
397 entity entity-stack last-entity finfo
398 (entities (list wl-folder-entity)))
401 (setq entity (wl-pop entities))
404 ;; (if (and (string= name (car entity))
405 ;; (eq id (wl-folder-get-entity-id (car entity))))
406 ;; (throw 'done last-entity))
408 (wl-push entities entity-stack))
409 (setq entities (nth 2 entity)))
411 (if (and (string= name entity)
412 ;; don't use eq, `id' is string on Nemacs.
413 (equal id (wl-folder-get-entity-id entity)))
414 (throw 'done last-entity))
416 (and (setq finfo (wl-folder-get-entity-info entity))
417 (and (nth 0 finfo)(nth 1 finfo))
418 (> (+ (nth 0 finfo)(nth 1 finfo)) 0)))
419 (setq last-entity entity))))
421 (setq entities (wl-pop entity-stack)))))))
423 (defun wl-folder-get-next-folder (id &optional unread)
424 (let ((name (if (stringp id)
426 (wl-folder-get-folder-name-by-id id)))
427 entity entity-stack found finfo
428 (entities (list wl-folder-entity)))
431 (setq entity (wl-pop entities))
434 ;;; (if (and (string= name (car entity))
435 ;;; (eq id (wl-folder-get-entity-id (car entity))))
438 (wl-push entities entity-stack))
439 (setq entities (nth 2 entity)))
442 (when (or (not unread)
443 (and (setq finfo (wl-folder-get-entity-info entity))
444 (and (nth 0 finfo)(nth 1 finfo))
445 (> (+ (nth 0 finfo)(nth 1 finfo)) 0)))
446 (throw 'done entity))
447 (if (and (string= name entity)
448 ;; don't use eq, `id' is string on Nemacs.
449 (equal id (wl-folder-get-entity-id entity)))
452 (setq entities (wl-pop entity-stack)))))))
454 (defun wl-folder-flush-queue ()
457 (let ((cur-buf (current-buffer))
458 (wl-auto-select-first nil)
461 (if elmo-enable-disconnected-operation
462 (elmo-dop-queue-flush 'force)) ; Try flushing all queue.
463 (if (not (elmo-folder-list-messages
464 (wl-folder-get-elmo-folder wl-queue-folder)))
465 (message "No sending queue exists.")
466 (if wl-stay-folder-window
467 (wl-folder-select-buffer
468 (wl-summary-get-buffer-create wl-queue-folder)))
469 (wl-summary-goto-folder-subr wl-queue-folder 'force-update nil)
471 (wl-draft-queue-flush)
472 (if (get-buffer-window cur-buf)
473 (select-window (get-buffer-window cur-buf)))
475 (if wl-stay-folder-window
476 (wl-folder-toggle-disp-summary 'off wl-queue-folder)
477 (switch-to-buffer cur-buf))))))
479 (defun wl-folder-empty-trash ()
482 (let ((cur-buf (current-buffer))
483 (wl-auto-select-first nil)
485 (if wl-stay-folder-window
486 (wl-folder-select-buffer
487 (wl-summary-get-buffer-create wl-trash-folder)))
488 (wl-summary-goto-folder-subr wl-trash-folder 'force-update nil nil t)
489 (setq trash-buf (current-buffer))
491 (setq emptied (wl-summary-delete-all-msgs))
493 (setq wl-thread-entities nil
494 wl-thread-entity-list nil)
495 (if wl-summary-cache-use (wl-summary-save-view-cache))
496 (elmo-folder-commit wl-summary-buffer-elmo-folder))
497 (if (get-buffer-window cur-buf)
498 (select-window (get-buffer-window cur-buf)))
501 (wl-folder-set-folder-updated wl-trash-folder '(0 0 0)))
502 (if wl-stay-folder-window
503 (wl-folder-toggle-disp-summary 'off wl-trash-folder)
504 (switch-to-buffer cur-buf))
506 (kill-buffer trash-buf)))))
508 (defun wl-folder-goto-top-of-current-folder (&optional arg)
509 "Move backward to the top of the current folder group.
510 Optional argument ARG is repeart count."
512 (if (re-search-backward
513 "^ *\\[[\\+-]\\]" nil t (if arg (prefix-numeric-value arg)))
515 (goto-char (point-min))))
517 (defun wl-folder-goto-bottom-of-current-folder (indent)
518 "Move forward to the bottom of the current folder group."
523 (if (looking-at "^ *")
524 (buffer-substring (match-beginning 0)(1- (match-end 0)))
528 (while (re-search-forward "^ *" nil t)
529 (if (<= (length (match-string 0))
533 (goto-char (point-max))))
535 (defsubst wl-folder-update-group (entity diffs &optional is-group)
537 (let ((path (wl-folder-get-path
539 (wl-folder-get-entity-id entity)
542 ;; delete itself from path
543 (setq path (delete (nth (- (length path) 1) path) path)))
544 (goto-char (point-min))
547 ;; goto the path line.
548 (if (or (eq (car path) 0) ; update desktop
549 (wl-folder-buffer-search-group
550 (wl-folder-get-petname
551 (if (stringp (car path))
553 (wl-folder-get-folder-name-by-id
556 (wl-folder-update-diff-line diffs)
558 (setq path (cdr path)))))))
560 (defun wl-folder-maybe-load-folder-list (entity)
561 (when (null (caddr entity))
563 (elmo-msgdb-flist-load (car entity)))
567 (wl-folder-entity-assign-id entity
568 wl-folder-entity-id-name-hashtb
570 (setq diffs (wl-fldmgr-add-entity-hashtb (list entity)))
571 (unless (equal diffs '(0 0 0))
572 (wl-folder-update-group (car entity) diffs t)))))))
574 (defsubst wl-folder-force-fetch-p (entity)
576 ((consp wl-force-fetch-folders)
577 (wl-string-match-member entity wl-force-fetch-folders))
579 wl-force-fetch-folders)))
581 (defun wl-folder-jump-to-current-entity (&optional arg)
582 "Enter the current folder. If optional ARG exists, update folder list."
585 (let (entity beg end indent opened fname err fld-name)
587 ((looking-at wl-folder-group-regexp)
589 (setq fname (wl-folder-get-realname (wl-match-buffer 3)))
590 (setq indent (wl-match-buffer 1))
591 (setq opened (wl-match-buffer 2))
592 (if (string= opened "+")
594 (setq entity (wl-folder-search-group-entity-by-name
599 (wl-folder-update-recursive-current-entity entity)
601 (setcdr (assoc (car entity) wl-folder-group-alist) t)
602 (if (eq 'access (cadr entity))
603 (wl-folder-maybe-load-folder-list entity))
604 ;(condition-case errobj
606 (if (or (wl-folder-force-fetch-p (car entity))
608 (eq 'access (cadr entity))
609 (null (caddr entity))))
610 (wl-folder-update-newest indent entity)
611 (wl-folder-insert-entity indent entity))
612 (wl-highlight-folder-path wl-folder-buffer-cur-path))
615 ; (setcdr (assoc fname wl-folder-group-alist) nil))
617 ; (elmo-display-error errobj t)
620 ; (setcdr (assoc fname wl-folder-group-alist) nil)))
622 (let ((buffer-read-only nil))
623 (delete-region (save-excursion (beginning-of-line)
625 (save-excursion (end-of-line)
631 (progn (wl-folder-goto-bottom-of-current-folder indent)
634 (setq entity (wl-folder-search-group-entity-by-name
637 (let ((buffer-read-only nil))
638 (delete-region beg end))
639 (setcdr (assoc (car entity) wl-folder-group-alist) nil)
640 (wl-folder-insert-entity indent entity) ; insert entity
642 (wl-highlight-folder-path wl-folder-buffer-cur-path)
643 ; (wl-delete-all-overlays)
644 ; (wl-highlight-folder-current-line)
646 ((setq fld-name (wl-folder-entity-name))
647 (wl-folder-set-current-entity-id
648 (get-text-property (point) 'wl-folder-entity-id))
649 (setq fld-name (wl-folder-get-folder-name-by-id
650 wl-folder-buffer-cur-entity-id))
651 (let ((summary-buf (wl-summary-get-buffer-create fld-name arg))
653 (if (or wl-stay-folder-window wl-summary-use-frame)
654 (wl-folder-select-buffer summary-buf)
656 (get-buffer-window summary-buf))
658 (wl-summary-goto-folder-subr fld-name
659 (wl-summary-get-sync-range
660 (wl-folder-get-elmo-folder fld-name))
662 (set-buffer-modified-p nil))
664 (defun wl-folder-close-entity (entity)
665 (let ((entities (list entity))
668 (setq entity (wl-pop entities))
671 (setcdr (assoc (car entity) wl-folder-group-alist) nil)
673 (wl-push entities entity-stack))
674 (setq entities (nth 2 entity))))
676 (setq entities (wl-pop entity-stack))))))
678 (defun wl-folder-update-recursive-current-entity (&optional entity)
680 (when (wl-folder-buffer-group-p)
682 ((string= (wl-match-buffer 2) "+")
686 (wl-folder-search-group-entity-by-name
687 (wl-folder-get-realname (wl-match-buffer 3))
689 (let ((inhibit-read-only t)
690 (entities (list entity))
691 entity-stack err indent)
692 (while (and entities (not err))
693 (setq entity (wl-pop entities))
696 (wl-folder-close-entity entity)
697 (setcdr (assoc (car entity) wl-folder-group-alist) t)
698 (unless (wl-folder-buffer-search-group
699 (wl-folder-get-petname (car entity)))
700 (error "%s: not found group" (car entity)))
701 (setq indent (wl-match-buffer 1))
702 (if (eq 'access (cadr entity))
703 (wl-folder-maybe-load-folder-list entity))
707 (condition-case errobj
708 (wl-folder-update-newest indent entity)
711 (setcdr (assoc (car entity) wl-folder-group-alist) nil))
713 (elmo-display-error errobj t)
716 (setcdr (assoc (car entity) wl-folder-group-alist) nil)))
718 (delete-region (save-excursion (beginning-of-line)
720 (save-excursion (end-of-line)
724 (wl-push entities entity-stack))
725 (setq entities (nth 2 entity))))
727 (setq entities (wl-pop entity-stack)))))
728 (set-buffer-modified-p nil)))
730 (wl-folder-jump-to-current-entity)))))
732 (defun wl-folder-no-auto-check-folder-p (folder)
735 (let ((li wl-auto-check-folder-list))
737 (if (string-match (car li) folder)
739 (setq li (cdr li)))))
742 (let ((li wl-auto-uncheck-folder-list))
744 (if (string-match (car li) folder)
745 (throw 'found t)) ; no check!
746 (setq li (cdr li))))))))
748 (defsubst wl-folder-add-folder-info (pre-value value)
750 (+ (or (nth 0 pre-value) 0) (or (nth 0 value) 0))
751 (+ (or (nth 1 pre-value) 0) (or (nth 1 value) 0))
752 (+ (or (nth 2 pre-value) 0) (or (nth 2 value) 0))))
754 (defun wl-folder-check-entity (entity &optional auto)
755 "Check unsync message number."
756 (let ((start-pos (point))
758 (run-hooks 'wl-folder-check-entity-pre-hook)
759 (if (and (consp entity) ;; group entity
760 wl-folder-check-async) ;; very fast
761 (setq ret-val (wl-folder-check-entity-async entity auto))
765 (let ((flist (if auto
767 'wl-folder-no-auto-check-folder-p
770 (wl-folder-check-entity-pre-hook nil)
771 (wl-folder-check-entity-hook nil)
775 (wl-folder-add-folder-info
777 (wl-folder-check-entity (car flist))))
778 (setq flist (cdr flist)))
779 ;(wl-folder-buffer-search-entity (car entity))
780 ;(wl-folder-update-line ret-val)
783 (message "Checking \"%s\"" entity)
784 (setq ret-val (wl-folder-check-one-entity
786 (goto-char start-pos)
789 (message "Uncheck(unplugged) \"%s\"" entity)))))
791 (message "Checking \"%s\" is done."
792 (if (consp entity) (car entity) entity)))
793 (run-hooks 'wl-folder-check-entity-hook)
796 (defun wl-folder-check-one-entity (entity)
797 (let* ((folder (wl-folder-get-elmo-folder entity))
798 (nums (condition-case err
799 (if (wl-string-match-member entity wl-strict-diff-folders)
800 (elmo-strict-folder-diff folder)
801 (elmo-folder-diff folder))
803 ;; maybe not exist folder.
804 (if (and (not (memq 'elmo-open-error
805 (get (car err) 'error-conditions)))
806 (not (elmo-folder-exists-p folder)))
807 (wl-folder-create-subr folder)
808 (signal (car err) (cdr err))))))
809 (new (elmo-diff-new nums))
810 (nums (cons (elmo-diff-unread nums) (elmo-diff-all nums)))
812 (if (and (eq wl-folder-notify-deleted 'sync)
814 (or (> 0 (car nums)) (> 0 (cdr nums))))
816 (wl-folder-sync-entity entity)
817 (setq nums (elmo-folder-diff folder)))
818 (unless wl-folder-notify-deleted
819 (setq unsync (if (car nums)
822 (setq nomif (if (cdr nums)
825 (setq nums (cons unsync nomif)))
826 (setq unread (or ;; If server diff, All unreads are
828 (if (elmo-folder-use-flag-p folder)
830 (elmo-folder-get-info-unread folder)
831 (wl-summary-count-unread (elmo-msgdb-mark-load
832 (elmo-folder-msgdb-path
834 (setq unread (min unread (- (or (cdr nums) 0) (or (car nums) 0))))
835 (when new (setq unread (- unread new)))
836 (wl-folder-entity-hashtb-set wl-folder-entity-hashtb entity
837 (list (or new (car nums))
840 (get-buffer wl-folder-buffer-name)))
841 (setq wl-folder-info-alist-modified t)
843 (list (if wl-folder-notify-deleted
845 (max 0 (or new (car nums))))
849 (defun wl-folder-check-entity-async (entity &optional auto)
850 (let ((elmo-nntp-groups-async t)
853 'wl-folder-no-auto-check-folder-p
854 (wl-folder-get-entity-list entity))
855 (wl-folder-get-entity-list entity)))
856 (nntp-connection-keys nil)
857 name folder folder-list
863 (setq folder (wl-folder-get-elmo-folder (car elist)))
864 (if (not (elmo-folder-plugged-p folder))
865 (message "Uncheck \"%s\"" (car elist))
867 (elmo-folder-get-primitive-list folder))
868 (cond ((elmo-folder-contains-type folder 'nntp)
869 (wl-append async-folder-list (list folder))
871 (when (eq (elmo-folder-type-internal (car folder-list))
875 (elmo-net-folder-server-internal
877 (setq server (elmo-net-folder-server-internal
879 (message "Checking on \"%s\"" server))
880 (setq nntp-connection-keys
881 (elmo-nntp-get-folders-info-prepare
883 nntp-connection-keys)))
884 (setq folder-list (cdr folder-list))))
886 (wl-append sync-folder-list (list folder)))))
887 (setq elist (cdr elist)))
888 ;; check local entity at first
889 (while (setq folder (pop sync-folder-list))
890 (if (not (elmo-folder-plugged-p folder))
891 (message "Uncheck \"%s\"" (elmo-folder-name-internal folder))
892 (message "Checking \"%s\"" (elmo-folder-name-internal folder))
894 (wl-folder-add-folder-info
896 (wl-folder-check-one-entity (elmo-folder-name-internal
900 ;; check network entity at last
901 (when async-folder-list
902 (elmo-nntp-get-folders-info nntp-connection-keys)
903 (while (setq folder (pop async-folder-list))
904 (if (not (elmo-folder-plugged-p folder))
905 (message "Uncheck \"%s\"" (elmo-folder-name-internal folder))
906 (message "Checking \"%s\"" (elmo-folder-name-internal folder))
908 (wl-folder-add-folder-info
910 (wl-folder-check-one-entity (elmo-folder-name-internal
917 (defun wl-folder-resume-entity-hashtb-by-finfo (entity-hashtb info-alist)
918 "Resume unread info for entity alist."
921 (setq info (nth 1 (car info-alist)))
922 (wl-folder-set-entity-info (caar info-alist)
923 (list (nth 2 info)(nth 3 info)(nth 1 info))
925 (setq info-alist (cdr info-alist)))))
927 (defun wl-folder-move-path (path)
928 (let ((fp (if (consp path)
931 (wl-folder-get-path wl-folder-entity path))))
932 (goto-char (point-min))
935 (when (equal (car fp)
936 (wl-folder-get-entity-from-buffer t))
938 (setq wl-folder-buffer-cur-point (point)))
940 (and wl-folder-buffer-cur-point
941 (goto-char wl-folder-buffer-cur-point))))
943 (defun wl-folder-set-current-entity-id (entity-id)
944 (let ((buf (get-buffer wl-folder-buffer-name)))
948 (setq wl-folder-buffer-cur-entity-id entity-id)
949 (setq wl-folder-buffer-cur-path (wl-folder-get-path wl-folder-entity
951 (wl-highlight-folder-path wl-folder-buffer-cur-path)
952 (and wl-folder-move-cur-folder
953 wl-folder-buffer-cur-point
954 (goto-char wl-folder-buffer-cur-point))))
955 (if (eq (current-buffer) buf)
956 (and wl-folder-move-cur-folder
957 wl-folder-buffer-cur-point
958 (goto-char wl-folder-buffer-cur-point)))))
960 (defun wl-folder-check-current-entity ()
961 "Check folder at position.
962 If current line is group folder, check all sub entries."
964 (let* ((entity-name (wl-folder-get-entity-from-buffer))
965 (group (wl-folder-buffer-group-p))
966 (desktop (string= entity-name wl-folder-desktop-name)))
968 (wl-folder-check-entity
970 (wl-folder-search-group-entity-by-name entity-name
975 (defun wl-folder-sync-entity (entity &optional unread-only)
976 "Synchronize the msgdb of ENTITY."
979 (let ((flist (nth 2 entity)))
981 (wl-folder-sync-entity (car flist) unread-only)
982 (setq flist (cdr flist)))))
984 (let* ((folder (wl-folder-get-elmo-folder entity))
985 (nums (wl-folder-get-entity-info entity))
986 (wl-summary-highlight (if (or (wl-summary-sticky-p folder)
987 (wl-summary-always-sticky-folder-p
989 wl-summary-highlight))
990 wl-auto-select-first new unread)
991 (setq new (or (car nums) 0))
992 (setq unread (or (cadr nums) 0))
993 (if (or (not unread-only)
994 (or (< 0 new) (< 0 unread)))
995 (let ((wl-summary-buffer-name (concat
996 wl-summary-buffer-name
997 (symbol-name this-command)))
998 (wl-summary-use-frame nil)
999 (wl-summary-always-sticky-folder-list nil))
1000 (save-window-excursion
1002 (wl-summary-goto-folder-subr entity
1003 (wl-summary-get-sync-range
1006 (wl-summary-exit)))))))))
1008 (defun wl-folder-sync-current-entity (&optional unread-only)
1009 "Synchronize the folder at position.
1010 If current line is group folder, check all subfolders."
1013 (let ((entity-name (wl-folder-get-entity-from-buffer))
1014 (group (wl-folder-buffer-group-p)))
1015 (when (and entity-name
1016 (y-or-n-p (format "Sync %s?" entity-name)))
1017 (wl-folder-sync-entity
1019 (wl-folder-search-group-entity-by-name entity-name
1023 (message "Syncing %s is done!" entity-name)))))
1025 (defun wl-folder-mark-as-read-all-entity (entity)
1026 "Mark as read all messages in the ENTITY."
1029 (let ((flist (nth 2 entity)))
1031 (wl-folder-mark-as-read-all-entity (car flist))
1032 (setq flist (cdr flist)))))
1034 (let* ((nums (wl-folder-get-entity-info entity))
1035 (folder (wl-folder-get-elmo-folder entity))
1036 (wl-summary-highlight (if (or (wl-summary-sticky-p folder)
1037 (wl-summary-always-sticky-folder-p
1039 wl-summary-highlight))
1040 wl-auto-select-first new unread)
1041 (setq new (or (car nums) 0))
1042 (setq unread (or (cadr nums) 0))
1043 (if (or (< 0 new) (< 0 unread))
1044 (save-window-excursion
1046 (let ((wl-summary-buffer-name (concat
1047 wl-summary-buffer-name
1048 (symbol-name this-command)))
1049 (wl-summary-use-frame nil)
1050 (wl-summary-always-sticky-folder-list nil))
1051 (wl-summary-goto-folder-subr entity
1052 (wl-summary-get-sync-range folder)
1054 (wl-summary-mark-as-read-all)
1055 (wl-summary-exit))))
1058 (defun wl-folder-mark-as-read-all-current-entity ()
1059 "Mark as read all messages in the folder at position.
1060 If current line is group folder, all subfolders are marked."
1063 (let ((entity-name (wl-folder-get-entity-from-buffer))
1064 (group (wl-folder-buffer-group-p))
1066 (when (and entity-name
1067 (y-or-n-p (format "Mark all messages in %s as read?" entity-name)))
1068 (wl-folder-mark-as-read-all-entity
1070 (wl-folder-search-group-entity-by-name entity-name
1073 (message "All messages in %s are marked!" entity-name)))))
1075 (defun wl-folder-check-region (beg end)
1084 (let ((inhibit-read-only t)
1086 (while (< (point) end)
1087 ;; normal folder entity
1088 (if (looking-at "^[\t ]*\\([^\\[]+\\):\\(.*\\)\n")
1090 (setq entity (wl-folder-get-entity-from-buffer))
1091 (if (not (elmo-folder-plugged-p (wl-folder-get-elmo-folder
1093 (message "Uncheck %s" entity)
1094 (message "Checking %s" entity)
1095 (wl-folder-check-one-entity entity)
1100 (defun wl-folder-sync-region (beg end)
1109 (while (< (point) end)
1110 ;; normal folder entity
1111 (if (looking-at "^[\t ]*\\([^\\[]+\\):\\(.*\\)\n")
1113 (let ((inhibit-read-only t)
1115 (setq entity (wl-folder-get-entity-from-buffer))
1116 (wl-folder-sync-entity entity)
1117 (message "Syncing %s is done!" entity)
1122 (defun wl-folder-mark-as-read-all-region (beg end)
1131 (while (< (point) end)
1132 ;; normal folder entity
1133 (if (looking-at "^[\t ]*\\([^\\[]+\\):\\(.*\\)\n")
1135 (let ((inhibit-read-only t)
1137 (setq entity (wl-folder-get-entity-from-buffer))
1138 (wl-folder-mark-as-read-all-entity entity)
1139 (message "All messages in %s are marked!" entity)
1144 (defsubst wl-create-access-init-load-p (folder)
1145 (let ((no-load-regexp (when (and
1146 (not wl-folder-init-load-access-folders)
1147 wl-folder-init-no-load-access-folders)
1148 (mapconcat 'identity
1149 wl-folder-init-no-load-access-folders
1151 (load-regexp (and wl-folder-init-load-access-folders
1152 (mapconcat 'identity
1153 wl-folder-init-load-access-folders
1155 (cond (load-regexp (string-match load-regexp folder))
1156 (t (not (and no-load-regexp
1157 (string-match no-load-regexp folder)))))))
1159 (defun wl-create-access-folder-entity (name)
1161 (when (wl-create-access-init-load-p name)
1162 (setq flists (elmo-msgdb-flist-load name)) ; load flist.
1163 (setq flist (car flists))
1165 (when (consp (car flist))
1166 (setcdr (cdar flist)
1167 (wl-create-access-folder-entity (caar flist))))
1168 (setq flist (cdr flist)))
1171 (defun wl-create-folder-entity-from-buffer ()
1172 "Create folder entity recursively."
1174 ((looking-at "^[ \t]*$") ; blank line
1175 (goto-char (+ 1(match-end 0)))
1177 ((looking-at "^#.*$") ; comment
1178 (goto-char (+ 1 (match-end 0)))
1180 ((looking-at "^[\t ]*\\(.+\\)[\t ]*{[\t ]*$") ; group definition
1181 (let (name entity flist)
1182 (setq name (wl-match-buffer 1))
1183 (goto-char (+ 1 (match-end 0)))
1184 (while (setq entity (wl-create-folder-entity-from-buffer))
1185 (unless (eq entity 'ignore)
1186 (wl-append flist (list entity))))
1187 (if (looking-at "^[\t ]*}[\t ]*$") ; end of group
1189 (goto-char (+ 1 (match-end 0)))
1190 (if (wl-string-assoc name wl-folder-petname-alist)
1191 (error "%s already defined as petname" name))
1192 (list name 'group flist))
1193 (error "Syntax error in folder definition"))))
1194 ((looking-at "^[\t ]*\\([^\t \n]+\\)[\t ]*/$") ; access it!
1196 (setq name (wl-match-buffer 1))
1197 (goto-char (+ 1 (match-end 0)))
1198 ; (condition-case ()
1200 ; (setq flist (elmo-list-folders name)))
1201 ; (error (message "Access to folder %s failed." name)))
1202 ;; (setq flist (elmo-msgdb-flist-load name)) ; load flist.
1203 ;; (setq unsublist (nth 1 flist))
1204 ;; (setq flist (car flist))
1205 ;; (list name 'access flist unsublist)))
1206 (append (list name 'access) (wl-create-access-folder-entity name))))
1207 ;((looking-at "^[\t ]*\\([^\t \n}]+\\)[\t ]*\\(\"[^\"]*\"\\)?[\t ]*$") ; normal folder entity
1208 ((looking-at "^[\t ]*=[ \t]+\\([^\n]+\\)$"); petname definition
1209 (goto-char (+ 1 (match-end 0)))
1210 (let ((rest (elmo-match-buffer 1))
1212 (when (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 (elmo-match-string 1 rest)
1219 ((looking-at "^[ \t]*}[ \t]*$") ; end of group
1221 ((looking-at "^.*$") ; normal folder entity
1222 (goto-char (+ 1 (match-end 0)))
1223 (let ((rest (elmo-match-buffer 0))
1225 (if (string-match "\\(\"[^\"]*\"\\)[\t ]*$" rest)
1227 (setq petname (elmo-delete-char ?\" (elmo-match-string 1 rest)))
1228 (setq rest (substring rest 0 (match-beginning 0)))
1229 (when (string-match "^[\t ]*\\(.*[^\t ]+\\)[\t ]+$" rest)
1230 (wl-folder-append-petname
1231 (setq realname (elmo-match-string 1 rest))
1234 (if (string-match "^[\t ]*\\(.+\\)$" rest)
1235 (elmo-match-string 1 rest)
1238 (defun wl-folder-create-folder-entity ()
1239 "Create folder entries."
1240 (let ((tmp-buf (get-buffer-create " *wl-folder-tmp*"))
1244 (with-current-buffer tmp-buf
1246 (insert-file-contents wl-folders-file)
1247 (goto-char (point-min))
1248 (while (and (not (eobp))
1249 (setq entity (wl-create-folder-entity-from-buffer)))
1250 (unless (eq entity 'ignore)
1251 (wl-append ret-val (list entity)))))
1252 (kill-buffer tmp-buf))
1254 (setq ret-val (list wl-folder-desktop-name 'group ret-val))))
1256 (defun wl-folder-entity-assign-id (entity &optional hashtb on-noid)
1257 (let ((hashtb (or hashtb
1258 (setq wl-folder-entity-id-name-hashtb
1259 (elmo-make-hash wl-folder-entity-id))))
1260 (entities (list entity))
1263 (setq entity (wl-pop entities))
1266 (when (not (and on-noid
1267 (get-text-property 0
1268 'wl-folder-entity-id
1270 (put-text-property 0 (length (car entity))
1271 'wl-folder-entity-id
1274 (wl-folder-set-id-name wl-folder-entity-id
1275 (car entity) hashtb))
1277 (wl-push entities entity-stack))
1278 (setq entities (nth 2 entity)))
1280 (when (not (and on-noid
1281 (get-text-property 0
1282 'wl-folder-entity-id
1284 (put-text-property 0 (length entity)
1285 'wl-folder-entity-id
1288 (wl-folder-set-id-name wl-folder-entity-id
1290 (setq wl-folder-entity-id (+ 1 wl-folder-entity-id))
1292 (setq entities (wl-pop entity-stack))))))
1294 (defun wl-folder-click (e)
1299 (wl-folder-jump-to-current-entity)))
1301 (defun wl-folder-select-buffer (buffer)
1302 (let ((gbw (get-buffer-window buffer))
1305 (progn (select-window gbw)
1307 (unless wl-summary-use-frame
1310 (split-window-horizontally wl-folder-window-width)
1314 (if wl-summary-use-frame
1315 (switch-to-buffer-other-frame buffer)
1316 (switch-to-buffer buffer))
1319 (defun wl-folder-toggle-disp-summary (&optional arg folder)
1321 (if (or (and folder (assoc folder wl-folder-group-alist))
1322 (and (interactive-p) (wl-folder-buffer-group-p)))
1323 (error "This command is not available on Group"))
1325 (let (wl-auto-select-first
1326 (wl-stay-folder-window t))
1329 (setq wl-folder-buffer-disp-summary t))
1331 (setq wl-folder-buffer-disp-summary nil)
1332 ;; hide wl-summary window.
1333 (let ((cur-buf (current-buffer))
1334 (summary-buffer (wl-summary-get-buffer folder)))
1335 (wl-folder-select-buffer summary-buffer)
1337 (select-window (get-buffer-window cur-buf))))
1339 (setq wl-folder-buffer-disp-summary
1340 (not wl-folder-buffer-disp-summary))
1341 (let ((cur-buf (current-buffer))
1343 (when (looking-at "^[ ]*\\([^\\[].+\\):.*\n")
1344 (setq folder-name (wl-folder-get-entity-from-buffer))
1345 (if wl-folder-buffer-disp-summary
1347 (wl-folder-select-buffer
1348 (wl-summary-get-buffer-create folder-name))
1350 (wl-summary-goto-folder-subr folder-name 'no-sync nil)
1351 (select-window (get-buffer-window cur-buf))))
1352 (wl-folder-select-buffer (wl-summary-get-buffer folder-name))
1354 (select-window (get-buffer-window cur-buf)))))))))
1356 (defun wl-folder-prev-unsync ()
1357 "Move cursor to the previous unsync folder."
1360 (setq start-point (point))
1362 (if (re-search-backward wl-folder-unsync-regexp nil t)
1364 (goto-char start-point)
1365 (message "No more unsync folder"))))
1367 (defun wl-folder-next-unsync (&optional plugged)
1368 "Move cursor to the next unsync."
1370 (let (start-point entity)
1371 (setq start-point (point))
1374 (while (re-search-forward wl-folder-unsync-regexp nil t)
1375 (if (or (wl-folder-buffer-group-p)
1378 (wl-folder-get-realname
1379 (wl-folder-folder-name)))
1380 (elmo-folder-plugged-p entity))
1383 (goto-char start-point)
1384 (message "No more unsync folder"))))
1386 (defun wl-folder-prev-unread (&optional group)
1387 "Move cursor to the previous unread folder."
1390 (setq start-point (point))
1392 (if (re-search-backward (wl-folder-unread-regex group) nil t)
1395 (wl-folder-folder-name))
1396 (goto-char start-point)
1397 (message "No more unread folder")
1400 (defun wl-folder-next-unread (&optional group)
1401 "Move cursor to the next unread folder."
1404 (setq start-point (point))
1406 (if (re-search-forward (wl-folder-unread-regex group) nil t)
1409 (wl-folder-folder-name))
1410 (goto-char start-point)
1411 (message "No more unread folder")
1414 (defun wl-folder-mode ()
1415 "Major mode for Wanderlust Folder.
1416 See Info under Wanderlust for full documentation.
1419 \\{wl-folder-mode-map}
1421 Entering Folder mode calls the value of `wl-folder-mode-hook'."
1423 (setq major-mode 'wl-folder-mode)
1424 (setq mode-name "Folder")
1425 (use-local-map wl-folder-mode-map)
1426 (setq buffer-read-only t)
1427 (setq inhibit-read-only nil)
1428 (setq truncate-lines t)
1429 (setq wl-folder-buffer-cur-entity-id nil
1430 wl-folder-buffer-cur-path nil
1431 wl-folder-buffer-cur-point nil)
1432 (wl-mode-line-buffer-identification)
1433 (easy-menu-add wl-folder-mode-menu)
1434 ;; This hook may contain the functions `wl-folder-init-icons' and
1435 ;; `wl-setup-folder' for reasons of system internal to accord
1436 ;; facilities for the Emacs variants.
1437 (run-hooks 'wl-folder-mode-hook))
1439 (defun wl-folder-append-petname (realname petname)
1441 ;; check group name.
1442 (if (wl-folder-search-group-entity-by-name petname wl-folder-entity)
1443 (error "%s already defined as group name" petname))
1444 (when (setq pentry (wl-string-assoc realname wl-folder-petname-alist))
1445 (setq wl-folder-petname-alist
1446 (delete pentry wl-folder-petname-alist)))
1447 (wl-append wl-folder-petname-alist
1448 (list (cons realname petname)))))
1450 (defun wl-folder (&optional arg)
1452 (let (initialize folder-buf)
1453 (if (setq folder-buf (get-buffer wl-folder-buffer-name))
1454 (if wl-folder-use-frame
1456 (save-selected-window
1457 (dolist (frame (visible-frame-list))
1458 (select-frame frame)
1459 (if (get-buffer-window folder-buf)
1460 (setq select-frame frame))))
1462 (select-frame select-frame)
1463 (switch-to-buffer folder-buf)))
1464 (switch-to-buffer folder-buf))
1465 (if wl-folder-use-frame
1466 (switch-to-buffer-other-frame
1467 (get-buffer-create wl-folder-buffer-name))
1468 (switch-to-buffer (get-buffer-create wl-folder-buffer-name)))
1469 (set-buffer wl-folder-buffer-name)
1472 (setq wl-folder-entity-id 0)
1473 (wl-folder-entity-assign-id wl-folder-entity)
1474 (setq wl-folder-entity-hashtb
1475 (wl-folder-create-entity-hashtb wl-folder-entity))
1476 (setq wl-folder-elmo-folder-hashtb (elmo-make-hash wl-folder-entity-id))
1477 (setq wl-folder-group-alist
1478 (wl-folder-create-group-alist wl-folder-entity))
1479 (setq wl-folder-newsgroups-hashtb
1480 (wl-folder-create-newsgroups-hashtb wl-folder-entity))
1481 (wl-folder-init-info-hashtb)
1482 (let ((inhibit-read-only t)
1483 (buffer-read-only nil))
1485 (setcdr (assoc (car wl-folder-entity) wl-folder-group-alist) t)
1487 (wl-folder-insert-entity " " wl-folder-entity)))
1489 (set-buffer-modified-p nil)
1490 (setq initialize t))
1493 (defun wl-folder-auto-check ()
1494 "Check and update folders in `wl-auto-check-folder-name'."
1496 (when (get-buffer wl-folder-buffer-name)
1497 (switch-to-buffer wl-folder-buffer-name)
1499 ((eq wl-auto-check-folder-name 'none))
1500 ((or (consp wl-auto-check-folder-name)
1501 (stringp wl-auto-check-folder-name))
1502 (let ((folder-list (if (consp wl-auto-check-folder-name)
1503 wl-auto-check-folder-name
1504 (list wl-auto-check-folder-name)))
1507 (if (setq entity (wl-folder-search-entity-by-name
1510 (wl-folder-check-entity entity 'auto))
1511 (setq folder-list (cdr folder-list)))))
1513 (wl-folder-check-entity wl-folder-entity 'auto)))))
1515 (defun wl-folder-set-folder-updated (name value)
1518 (if (setq buf (get-buffer wl-folder-buffer-name))
1519 (wl-folder-entity-hashtb-set
1520 wl-folder-entity-hashtb name value buf))
1521 (setq wl-folder-info-alist-modified t))))
1523 (defun wl-folder-calc-finfo (entity)
1524 ;; calcurate finfo without inserting.
1525 (let ((entities (list entity))
1527 new unread all nums)
1529 (setq entity (wl-pop entities))
1533 (wl-push entities entity-stack))
1534 (setq entities (nth 2 entity)))
1536 (setq nums (wl-folder-get-entity-info entity))
1537 (setq new (+ (or new 0) (or (nth 0 nums) 0)))
1538 (setq unread (+ (or unread 0)
1539 (or (and (nth 0 nums)(nth 1 nums)
1540 (+ (nth 0 nums)(nth 1 nums))) 0)))
1541 (setq all (+ (or all 0) (or (nth 2 nums) 0)))))
1543 (setq entities (wl-pop entity-stack))))
1544 (list new unread all)))
1546 (defsubst wl-folder-make-save-access-list (list)
1547 (mapcar '(lambda (x)
1550 (list (elmo-string (car x)) 'access))
1555 (defun wl-folder-update-newest (indent entity)
1556 (let (ret-val new unread all)
1559 (let ((inhibit-read-only t)
1560 (buffer-read-only nil)
1561 (flist (nth 2 entity))
1562 (as-opened (cdr (assoc (car entity) wl-folder-group-alist)))
1567 (let (update-flist flist-unsub new-flist removed group-name-end)
1568 (when (and (eq (cadr entity) 'access)
1569 (elmo-folder-plugged-p
1570 (wl-folder-get-elmo-folder (car entity))))
1571 (message "Fetching folder entries...")
1572 (when (setq new-flist
1573 (elmo-folder-list-subfolders
1574 (wl-folder-get-elmo-folder (car entity))
1577 wl-folder-hierarchy-access-folders)))
1579 (wl-folder-update-access-group entity new-flist))
1580 (setq flist (nth 1 update-flist))
1581 (when (car update-flist) ;; diff
1582 (setq flist-unsub (nth 2 update-flist))
1583 (setq removed (nth 3 update-flist))
1584 (elmo-msgdb-flist-save
1587 (wl-folder-make-save-access-list flist)
1588 (wl-folder-make-save-access-list flist-unsub)))
1589 (wl-folder-entity-assign-id
1591 wl-folder-entity-id-name-hashtb
1593 (setq wl-folder-entity-hashtb
1594 (wl-folder-create-entity-hashtb
1596 wl-folder-entity-hashtb
1598 (setq wl-folder-newsgroups-hashtb
1600 (wl-folder-create-newsgroups-hashtb
1602 wl-folder-newsgroups-hashtb))))
1603 (message "Fetching folder entries...done"))
1604 (wl-folder-insert-entity indent entity))))))))
1606 (defun wl-folder-insert-entity (indent entity &optional onlygroup)
1607 (let (ret-val new unread all)
1610 (let ((inhibit-read-only t)
1611 (buffer-read-only nil)
1612 (flist (nth 2 entity))
1613 (as-opened (cdr (assoc (car entity) wl-folder-group-alist)))
1616 ;;; (insert indent "[" (if as-opened "-" "+") "]" (car entity) "\n")
1617 ;;; (save-excursion (forward-line -1)
1618 ;;; (wl-highlight-folder-current-line))
1622 (let (update-flist flist-unsub new-flist removed group-name-end)
1623 ;;; (when (and (eq (cadr entity) 'access)
1625 ;;; (message "fetching folder entries...")
1626 ;;; (when (setq new-flist
1627 ;;; (elmo-list-folders
1628 ;;; (elmo-string (car entity))
1629 ;;; (wl-string-member
1631 ;;; wl-folder-hierarchy-access-folders)
1633 ;;; (setq update-flist
1634 ;;; (wl-folder-update-access-group entity new-flist))
1635 ;;; (setq flist (nth 1 update-flist))
1636 ;;; (when (car update-flist) ;; diff
1637 ;;; (setq flist-unsub (nth 2 update-flist))
1638 ;;; (setq removed (nth 3 update-flist))
1639 ;;; (elmo-msgdb-flist-save
1642 ;;; (wl-folder-make-save-access-list flist)
1643 ;;; (wl-folder-make-save-access-list flist-unsub)))
1645 ;;; ;; reconstruct wl-folder-entity-id-name-hashtb and
1646 ;;; ;; wl-folder-entity-hashtb
1648 ;;; (wl-folder-entity-assign-id
1650 ;;; wl-folder-entity-id-name-hashtb
1652 ;;; (setq wl-folder-entity-hashtb
1653 ;;; (wl-folder-create-entity-hashtb
1655 ;;; wl-folder-entity-hashtb
1657 ;;; (setq wl-folder-newsgroups-hashtb
1659 ;;; (wl-folder-create-newsgroups-hashtb
1661 ;;; wl-folder-newsgroups-hashtb))))
1662 ;;; (message "fetching folder entries...done"))
1663 (insert indent "[" (if as-opened "-" "+") "]"
1664 (wl-folder-get-petname (car entity)))
1665 (setq group-name-end (point))
1667 (put-text-property beg (point) 'wl-folder-entity-id
1668 (get-text-property 0 'wl-folder-entity-id
1674 wl-folder-removed-mark
1675 (if (listp (car removed))
1676 (concat "[+]" (caar removed))
1679 (save-excursion (forward-line -1)
1680 (wl-highlight-folder-current-line))
1681 (setq removed (cdr removed)))
1682 (remove-text-properties beg (point) '(wl-folder-entity-id)))
1683 (let* ((len (length flist))
1688 (wl-folder-insert-entity
1689 (concat indent " ") (car flist)))
1690 (setq new (+ (or new 0) (or (nth 0 ret-val) 0)))
1691 (setq unread (+ (or unread 0) (or (nth 1 ret-val) 0)))
1692 (setq all (+ (or all 0) (or (nth 2 ret-val) 0)))
1694 (> len elmo-display-progress-threshold))
1696 (elmo-display-progress
1697 'wl-folder-insert-entity "Inserting group %s..."
1698 (/ (* i 100) len) (car entity)))
1699 (setq flist (cdr flist))))
1701 (goto-char group-name-end)
1702 (delete-region (point) (save-excursion (end-of-line)
1704 (insert (format ":%d/%d/%d" (or new 0)
1705 (or unread 0) (or all 0)))
1706 (setq ret-val (list new unread all))
1707 (wl-highlight-folder-current-line ret-val)))
1708 (setq ret-val (wl-folder-calc-finfo entity))
1709 (insert indent "[" (if as-opened "-" "+") "]"
1710 (wl-folder-get-petname (car entity))
1712 (or (nth 0 ret-val) 0)
1713 (or (nth 1 ret-val) 0)
1714 (or (nth 2 ret-val) 0))
1716 (put-text-property beg (point) 'wl-folder-entity-id
1717 (get-text-property 0 'wl-folder-entity-id
1719 (save-excursion (forward-line -1)
1720 (wl-highlight-folder-current-line ret-val)))))
1722 (let* ((inhibit-read-only t)
1723 (buffer-read-only nil)
1724 (nums (wl-folder-get-entity-info entity))
1727 (insert indent (wl-folder-get-petname entity)
1728 (format ":%s/%s/%s\n"
1729 (or (setq new (nth 0 nums)) "*")
1730 (or (setq unread (and (nth 0 nums)(nth 1 nums)
1731 (+ (nth 0 nums)(nth 1 nums))))
1733 (or (setq all (nth 2 nums)) "*")))
1734 (put-text-property beg (point) 'wl-folder-entity-id
1735 (get-text-property 0 'wl-folder-entity-id entity))
1736 (save-excursion (forward-line -1)
1737 (wl-highlight-folder-current-line nums))
1738 (setq ret-val (list new unread all)))))
1739 (set-buffer-modified-p nil)
1742 (defun wl-folder-check-all ()
1744 (wl-folder-check-entity wl-folder-entity))
1746 (defun wl-folder-entity-hashtb-set (entity-hashtb name value buffer)
1753 (setq cur-val (wl-folder-get-entity-info name entity-hashtb))
1754 (setq new-diff (- (or (nth 0 value) 0) (or (nth 0 cur-val) 0)))
1757 (- (or (nth 1 value) 0) (or (nth 1 cur-val) 0))))
1758 (setq all-diff (- (or (nth 2 value) 0) (or (nth 2 cur-val) 0)))
1759 (setq diffs (list new-diff unread-diff all-diff))
1760 (unless (and (nth 0 cur-val)
1761 (equal diffs '(0 0 0)))
1762 (wl-folder-set-entity-info name value entity-hashtb)
1764 (with-current-buffer buffer
1766 (setq entity-list (wl-folder-search-entity-list-by-name
1767 name wl-folder-entity))
1769 (wl-folder-update-group (car entity-list) diffs)
1770 (setq entity-list (cdr entity-list)))
1771 (goto-char (point-min))
1772 (while (wl-folder-buffer-search-entity name)
1773 (wl-folder-update-line value))))))))
1775 (defun wl-folder-update-unread (folder unread)
1776 ; (save-window-excursion
1777 (let ((buf (get-buffer wl-folder-buffer-name))
1780 ;;(fld (elmo-string folder))
1781 value newvalue entity-list)
1782 ;;; Update folder-info
1783 ;;; (elmo-folder-set-info-hashtb fld nil nil nil unread)
1784 (setq cur-unread (or (nth 1 (wl-folder-get-entity-info folder)) 0))
1785 (setq unread-diff (- (or unread 0) cur-unread))
1786 (setq value (wl-folder-get-entity-info folder))
1787 (setq newvalue (list (nth 0 value)
1790 (wl-folder-set-entity-info folder newvalue)
1791 (setq wl-folder-info-alist-modified t)
1793 (not (eq unread-diff 0)))
1795 (with-current-buffer buf
1797 (setq entity-list (wl-folder-search-entity-list-by-name
1798 folder wl-folder-entity))
1800 (wl-folder-update-group (car entity-list) (list 0
1803 (setq entity-list (cdr entity-list)))
1804 (goto-char (point-min))
1805 (while (wl-folder-buffer-search-entity folder)
1806 (wl-folder-update-line newvalue))))))));)
1808 (defun wl-folder-create-entity-hashtb (entity &optional hashtb reconst)
1809 (let ((hashtb (or hashtb (elmo-make-hash wl-folder-entity-id)))
1810 (entities (list entity))
1813 (setq entity (wl-pop entities))
1817 (wl-push entities entity-stack))
1818 (setq entities (nth 2 entity)))
1820 (when (not (and reconst
1821 (wl-folder-get-entity-info entity)))
1822 (wl-folder-set-entity-info entity
1826 (setq entities (wl-pop entity-stack))))
1829 ;; Unsync number is reserved.
1830 ;;(defun wl-folder-reconstruct-entity-hashtb (entity &optional hashtb id-name)
1831 ;; (let* ((hashtb (or hashtb (elmo-make-hash wl-folder-entity-id)))
1832 ;; (entities (list entity))
1835 ;; (setq entity (wl-pop entities))
1839 ;; (wl-folder-set-id-name (wl-folder-get-entity-id (car entity))
1842 ;; (wl-push entities entity-stack))
1843 ;; (setq entities (nth 2 entity))
1845 ;; ((stringp entity)
1846 ;; (wl-folder-set-entity-info entity
1847 ;; (wl-folder-get-entity-info entity)
1850 ;; (wl-folder-set-id-name (wl-folder-get-entity-id entity)
1853 ;; (setq entities (wl-pop entity-stack))))
1856 (defun wl-folder-create-newsgroups-from-nntp-access (entity)
1857 (let ((flist (nth 2 entity))
1862 ((consp (car flist))
1863 (wl-folder-create-newsgroups-from-nntp-access (car flist)))
1866 (elmo-nntp-folder-group-internal
1867 (wl-folder-get-elmo-folder (car flist)))))))
1868 (setq flist (cdr flist)))
1871 (defun wl-folder-create-newsgroups-hashtb (entity &optional is-list info)
1872 "Create NNTP group hashtable for ENTITY."
1873 (let ((entities (if is-list entity (list entity)))
1874 entity-stack folder-list newsgroups newsgroup make-hashtb)
1875 (and info (message "Creating newsgroups..."))
1877 (setq entity (wl-pop entities))
1880 (if (eq (nth 1 entity) 'access)
1881 (when (eq (elmo-folder-type-internal
1882 (elmo-make-folder (car entity))) 'nntp)
1883 (wl-append newsgroups
1884 (wl-folder-create-newsgroups-from-nntp-access entity))
1885 (setq make-hashtb t))
1887 (wl-push entities entity-stack))
1888 (setq entities (nth 2 entity))))
1890 (setq folder-list (elmo-folder-get-primitive-list
1891 (elmo-make-folder entity)))
1893 (when (and (eq (elmo-folder-type-internal (car folder-list))
1895 (setq newsgroup (elmo-nntp-folder-group-internal
1896 (car folder-list))))
1897 (wl-append newsgroups (list (elmo-string newsgroup))))
1898 (setq folder-list (cdr folder-list)))))
1900 (setq entities (wl-pop entity-stack))))
1901 (and info (message "Creating newsgroups...done"))
1902 (if (or newsgroups make-hashtb)
1903 (elmo-setup-subscribed-newsgroups newsgroups))))
1905 (defun wl-folder-get-path (entity target-id &optional string)
1906 (let ((entities (list entity))
1907 entity-stack result-path)
1911 (setq entity (wl-pop entities))
1914 (if (and (or (not string) (string= string (car entity)))
1915 ;; don't use eq, `id' is string on Nemacs.
1916 (equal target-id (wl-folder-get-entity-id (car entity))))
1918 (wl-push target-id result-path))
1919 (wl-push (wl-folder-get-entity-id (car entity)) result-path))
1920 (wl-push entities entity-stack)
1921 (setq entities (nth 2 entity)))
1923 (if (and (or (not string) (string= string entity))
1924 ;; don't use eq, `id' is string on Nemacs.
1925 (equal target-id (wl-folder-get-entity-id entity)))
1927 (wl-push target-id result-path)))))
1929 (while (and entity-stack
1931 (setq result-path (cdr result-path))
1932 (setq entities (wl-pop entity-stack)))))))))
1934 (defun wl-folder-create-group-alist (entity)
1936 (let ((flist (nth 2 entity))
1937 (cur-alist (list (cons (car entity) nil)))
1940 (if (consp (car flist))
1941 (wl-append append-alist
1942 (wl-folder-create-group-alist (car flist))))
1943 (setq flist (cdr flist)))
1944 (append cur-alist append-alist))))
1946 (defun wl-folder-init-info-hashtb ()
1947 (let ((info-alist (and wl-folder-info-save
1948 (elmo-msgdb-finfo-load))))
1949 (elmo-folder-info-make-hashtb
1951 wl-folder-entity-hashtb)))
1952 ;;; (wl-folder-resume-entity-hashtb-by-finfo
1953 ;;; wl-folder-entity-hashtb
1956 (defun wl-folder-cleanup-variables ()
1957 (setq wl-folder-entity nil
1958 wl-folder-entity-hashtb nil
1959 wl-folder-entity-id-name-hashtb nil
1960 wl-folder-group-alist nil
1961 wl-folder-petname-alist nil
1962 wl-folder-newsgroups-hashtb nil
1963 wl-fldmgr-cut-entity-list nil
1964 wl-fldmgr-modified nil
1965 wl-fldmgr-modified-access-list nil
1969 (defun wl-make-plugged-alist ()
1970 (let ((entity-list (wl-folder-get-entity-list wl-folder-entity))
1971 (add (not wl-reset-plugged-alist)))
1973 (elmo-folder-set-plugged
1974 (wl-folder-get-elmo-folder (car entity-list)) wl-plugged add)
1975 (setq entity-list (cdr entity-list)))
1976 ;; smtp posting server
1977 (when wl-smtp-posting-server
1978 (elmo-set-plugged wl-plugged
1979 wl-smtp-posting-server ; server
1980 (or (and (boundp 'smtp-service) smtp-service)
1982 wl-smtp-connection-type
1983 nil nil "smtp" add))
1984 ;; nntp posting server
1985 (when wl-nntp-posting-server
1986 (elmo-set-plugged wl-plugged
1987 wl-nntp-posting-server
1988 wl-nntp-posting-stream-type
1989 wl-nntp-posting-port
1990 nil nil "nntp" add))
1991 (run-hooks 'wl-make-plugged-hook)))
1993 (defvar wl-folder-init-function 'wl-local-folder-init)
1995 (defun wl-folder-init ()
1996 "Return top-level folder entity."
2000 (funcall wl-folder-init-function)))
2002 (defun wl-local-folder-init ()
2003 "Initialize local folder."
2004 (message "Initializing folder...")
2005 (setq wl-folder-entity (wl-folder-create-folder-entity))
2006 (message "Initializing folder...done"))
2008 (defun wl-folder-get-realname (petname)
2012 wl-folder-petname-alist))
2015 (defun wl-folder-get-petname (name)
2019 wl-folder-petname-alist))
2022 (defun wl-folder-get-entity-with-petname ()
2023 (let ((alist wl-folder-petname-alist)
2024 (hashtb (copy-sequence wl-folder-entity-hashtb)))
2026 (wl-folder-set-entity-info (cdar alist) nil hashtb)
2027 (setq alist (cdr alist)))
2030 (defun wl-folder-get-newsgroups (folder)
2031 "Return Newsgroups field value string for FOLDER newsgroup.
2032 If FOLDER is multi, return comma separated string (cross post)."
2033 (let ((nlist (elmo-folder-newsgroups
2034 (wl-folder-get-elmo-folder folder))))
2036 (list nil nil (mapconcat 'identity nlist ","))
2039 (defun wl-folder-guess-mailing-list-by-refile-rule (entity)
2040 "Return ML address guess by FOLDER.
2041 Use `wl-subscribed-mailing-list' and `wl-refile-rule-alist'."
2043 (elmo-folder-get-primitive-list
2044 (wl-folder-get-elmo-folder entity)))
2046 (while (setq fld (car flist))
2047 (setq mladdr (wl-folder-guess-mailing-list-by-refile-rule-subr
2048 (elmo-folder-name-internal fld)))
2050 (setq to (if (stringp to)
2051 (concat to ", " mladdr)
2053 (setq flist (cdr flist)))
2058 (defun wl-folder-guess-mailing-list-by-refile-rule-subr (entity)
2059 (unless (memq (elmo-folder-type entity)
2061 (let ((rules wl-refile-rule-alist)
2064 (if (or (and (stringp (car (car rules)))
2065 (string-match "[Tt]o" (car (car rules))))
2066 (and (listp (car (car rules)))
2067 (elmo-string-matched-member "to" (car (car rules))
2069 (setq toalist (append toalist (cdr (car rules)))))
2070 (setq rules (cdr rules)))
2071 (setq tokey (car (rassoc entity toalist)))
2072 ;;; (setq histkey (car (rassoc folder wl-refile-alist)))
2073 ;; case-ignore search `wl-subscribed-mailing-list'
2075 (elmo-string-matched-member tokey wl-subscribed-mailing-list t)))))
2077 (defun wl-folder-guess-mailing-list-by-folder-name (entity)
2078 "Return ML address guess by FOLDER name's last hierarchy.
2079 Use `wl-subscribed-mailing-list'."
2081 (elmo-folder-get-primitive-list
2082 (wl-folder-get-elmo-folder entity)))
2084 (while (setq fld (car flist))
2085 (setq mladdr (wl-folder-guess-mailing-list-by-folder-name-subr
2086 (elmo-folder-name-internal fld)))
2088 (setq to (if (stringp to)
2089 (concat to ", " mladdr)
2091 (setq flist (cdr flist)))
2096 (defun wl-folder-guess-mailing-list-by-folder-name-subr (entity)
2097 (when (memq (elmo-folder-type entity)
2098 '(localdir imap4 maildir))
2099 (let (key foldername)
2100 ;; Get foldername and Remove folder type symbol.
2101 (setq foldername (substring entity 1))
2102 (if (string-match "@" foldername)
2103 (setq foldername (substring foldername 0 (match-beginning 0))))
2104 (when (string-match "[^\\./]+$" foldername)
2105 (setq key (regexp-quote
2106 (concat (substring foldername (match-beginning 0)) "@")))
2107 (elmo-string-matched-member
2108 key wl-subscribed-mailing-list 'case-ignore)))))
2110 (defun wl-folder-update-diff-line (diffs)
2111 (let ((inhibit-read-only t)
2112 (buffer-read-only nil)
2114 cur-unread new-unread
2119 (setq id (get-text-property (point) 'wl-folder-entity-id))
2120 (when (looking-at "^[ ]*\\(.*\\):\\([0-9\\*-]*\\)/\\([0-9\\*-]*\\)/\\([0-9\\*]*\\)")
2121 ;;(looking-at "^[ ]*\\([^\\[].+\\):\\([0-9\\*-]*/[0-9\\*-]*/[0-9\\*]*\\)")
2122 (setq cur-new (string-to-int
2123 (wl-match-buffer 2)))
2124 (setq cur-unread (string-to-int
2125 (wl-match-buffer 3)))
2126 (setq cur-all (string-to-int
2127 (wl-match-buffer 4)))
2128 (delete-region (match-beginning 2)
2130 (goto-char (match-beginning 2))
2131 (insert (format "%s/%s/%s"
2132 (setq new-new (+ cur-new (nth 0 diffs)))
2133 (setq new-unread (+ cur-unread (nth 1 diffs)))
2134 (setq new-all (+ cur-all (nth 2 diffs)))))
2135 (put-text-property (match-beginning 2) (point)
2136 'wl-folder-entity-id id)
2137 (if wl-use-highlight-mouse-line
2138 (put-text-property (match-beginning 2) (point)
2139 'mouse-face 'highlight))
2140 (wl-highlight-folder-group-line (list new-new new-unread new-all))
2141 (setq buffer-read-only t)
2142 (set-buffer-modified-p nil)))))
2144 (defun wl-folder-update-line (nums &optional is-group)
2145 (let ((inhibit-read-only t)
2146 (buffer-read-only nil)
2150 (setq id (get-text-property (point) 'wl-folder-entity-id))
2151 (if (looking-at "^[ ]*\\(.*\\):\\([0-9\\*-]*/[0-9\\*-]*/[0-9\\*]*\\)")
2152 ;;; (looking-at "^[ ]*\\([^\\[].+\\):\\([0-9\\*-]*/[0-9\\*-]*/[0-9\\*]*\\)")
2154 (delete-region (match-beginning 2)
2156 (goto-char (match-beginning 2))
2157 (insert (format "%s/%s/%s"
2158 (or (nth 0 nums) "*")
2159 (or (and (nth 0 nums)(nth 1 nums)
2160 (+ (nth 0 nums)(nth 1 nums)))
2162 (or (nth 2 nums) "*")))
2163 (put-text-property (match-beginning 2) (point)
2164 'wl-folder-entity-id id)
2166 ;; update only colors
2167 (wl-highlight-folder-group-line nums)
2168 (wl-highlight-folder-current-line nums))
2170 (set-buffer-modified-p nil))))))
2172 (defun wl-folder-goto-folder (&optional arg)
2174 (wl-folder-goto-folder-subr nil arg))
2176 (defun wl-folder-goto-folder-subr (&optional folder sticky)
2178 (let (summary-buf fld-name entity id error-selecting)
2179 ;;; (setq fld-name (wl-folder-get-entity-from-buffer))
2180 ;;; (if (or (null fld-name)
2181 ;;; (assoc fld-name wl-folder-group-alist))
2182 (setq fld-name wl-default-folder)
2183 (setq fld-name (or folder
2184 (wl-summary-read-folder fld-name)))
2185 (if (and (setq entity
2186 (wl-folder-search-entity-by-name fld-name
2189 (setq id (wl-folder-get-entity-id entity)))
2190 (wl-folder-set-current-entity-id id))
2191 (setq summary-buf (wl-summary-get-buffer-create fld-name sticky))
2192 (if (or wl-stay-folder-window wl-summary-use-frame)
2193 (wl-folder-select-buffer summary-buf)
2194 (if (and summary-buf
2195 (get-buffer-window summary-buf))
2197 (wl-summary-goto-folder-subr fld-name
2198 (wl-summary-get-sync-range
2199 (wl-folder-get-elmo-folder fld-name))
2202 (defun wl-folder-suspend ()
2204 (run-hooks 'wl-folder-suspend-hook)
2205 (wl-folder-info-save)
2206 (elmo-crosspost-message-alist-save)
2208 ;(if (fboundp 'mmelmo-cleanup-entity-buffers)
2209 ;(mmelmo-cleanup-entity-buffers))
2210 (bury-buffer wl-folder-buffer-name)
2211 (delete-windows-on wl-folder-buffer-name t))
2213 (defun wl-folder-info-save ()
2214 (when (and wl-folder-info-save
2215 wl-folder-info-alist-modified)
2216 (let ((entities (list wl-folder-entity))
2217 entity entity-stack info-alist info)
2219 (setq entity (wl-pop entities))
2223 (wl-push entities entity-stack))
2224 (setq entities (nth 2 entity)))
2226 (when (and (setq info (elmo-folder-get-info
2227 (wl-folder-get-elmo-folder entity)))
2228 (not (equal info '(nil))))
2230 (wl-append info-alist (list (list (elmo-string entity)
2231 (list (nth 3 info) ;; max
2232 (nth 2 info) ;; length
2234 (nth 1 info)) ;; unread
2237 (setq entities (wl-pop entity-stack))))
2238 (elmo-msgdb-finfo-save info-alist)
2239 (setq wl-folder-info-alist-modified nil))))
2241 (defun wl-folder-goto-first-unread-folder (&optional arg)
2243 (let ((entities (list wl-folder-entity))
2244 entity entity-stack ret-val
2249 (setq entity (wl-pop entities))
2253 (wl-push entities entity-stack))
2254 (setq entities (nth 2 entity)))
2256 (if (and (setq finfo (wl-folder-get-entity-info entity))
2257 (and (nth 0 finfo)(nth 1 finfo))
2258 (> (+ (nth 0 finfo)(nth 1 finfo)) 0))
2259 (throw 'done entity))
2260 (wl-append ret-val (list entity))))
2262 (setq entities (wl-pop entity-stack))))))
2266 (wl-folder-jump-folder first-entity)
2268 (wl-folder-goto-folder-subr first-entity))
2269 (message "No unread folder"))))
2271 (defun wl-folder-jump-folder (&optional fld-name noopen)
2274 (setq fld-name (wl-summary-read-folder wl-default-folder)))
2275 (goto-char (point-min))
2277 (wl-folder-open-folder fld-name))
2278 (and (wl-folder-buffer-search-entity fld-name)
2279 (beginning-of-line)))
2281 (defun wl-folder-get-entity-list (entity)
2282 (let ((entities (list entity))
2283 entity-stack ret-val)
2285 (setq entity (wl-pop entities))
2289 (wl-push entities entity-stack))
2290 (setq entities (nth 2 entity)))
2292 (wl-append ret-val (list entity))))
2294 (setq entities (wl-pop entity-stack))))
2297 (defun wl-folder-open-unread-folder (entity)
2299 (let ((alist (wl-folder-get-entity-list entity))
2301 finfo path-list path id)
2303 (when (and (setq finfo (wl-folder-get-entity-info (car alist)))
2304 (nth 0 finfo) (nth 1 finfo)
2305 (> (+ (nth 0 finfo)(nth 1 finfo)) 0))
2306 (setq unread (+ unread (+ (nth 0 finfo)(nth 1 finfo))))
2307 (setq id (wl-folder-get-entity-id (car alist)))
2308 (setq path (delete id (wl-folder-get-path
2312 (if (not (member path path-list))
2313 (wl-append path-list (list path))))
2314 (setq alist (cdr alist)))
2316 (wl-folder-open-folder-sub (car path-list))
2317 (setq path-list (cdr path-list)))
2318 (message "%s unread folder"
2319 (if (> unread 0) unread "No")))))
2321 (defun wl-folder-open-unread-current-entity ()
2323 (let ((entity-name (wl-folder-get-entity-from-buffer))
2324 (group (wl-folder-buffer-group-p)))
2326 (wl-folder-open-unread-folder
2328 (wl-folder-search-group-entity-by-name entity-name
2332 (defun wl-folder-open-only-unread-folder ()
2335 (wl-folder-prev-entity-skip-invalid t)
2336 (wl-folder-get-entity-from-buffer t))))
2337 (wl-folder-open-all-unread-folder)
2339 (goto-char (point-max))
2340 (while (and (re-search-backward
2341 "^[ ]*\\[[-]\\].+:0/0/[0-9-]+" nil t)
2343 (wl-folder-jump-to-current-entity) ;; close it
2345 (wl-folder-move-path id)
2348 (defun wl-folder-open-all-unread-folder (&optional arg)
2351 (wl-folder-prev-entity-skip-invalid t)
2352 (wl-folder-get-entity-from-buffer t))))
2353 (wl-folder-open-unread-folder wl-folder-entity)
2355 (wl-folder-move-path id)
2356 (goto-char (point-min))
2357 (wl-folder-next-unread t))))
2359 (defun wl-folder-open-folder (&optional fld-name)
2362 (setq fld-name (wl-summary-read-folder wl-default-folder)))
2363 (let* ((id (wl-folder-get-entity-id
2364 (wl-folder-search-entity-by-name fld-name wl-folder-entity
2366 (path (and id (wl-folder-get-path wl-folder-entity id))))
2368 (wl-folder-open-folder-sub path))))
2370 (defun wl-folder-open-folder-sub (path)
2371 (let ((inhibit-read-only t)
2372 (buffer-read-only nil)
2376 (goto-char (point-min))
2378 (wl-folder-buffer-search-group
2379 (wl-folder-get-petname
2380 (if (stringp (car path))
2382 (wl-folder-get-folder-name-by-id
2385 (setq path (cdr path))
2386 (if (and (looking-at wl-folder-group-regexp)
2387 (string= "+" (wl-match-buffer 2)));; closed group
2389 (setq indent (wl-match-buffer 1))
2390 (setq name (wl-folder-get-realname (wl-match-buffer 3)))
2391 (setq entity (wl-folder-search-group-entity-by-name
2395 (setcdr (assoc (car entity) wl-folder-group-alist) t)
2396 (if (eq 'access (cadr entity))
2397 (wl-folder-maybe-load-folder-list entity))
2398 (wl-folder-insert-entity indent entity)
2399 (delete-region (save-excursion (beginning-of-line)
2401 (save-excursion (end-of-line)
2403 (set-buffer-modified-p nil))))
2405 (defun wl-folder-open-all-pre ()
2406 (let ((entities (list wl-folder-entity))
2407 entity entity-stack group-entry)
2409 (setq entity (wl-pop entities))
2412 (unless (or (not (setq group-entry
2413 (assoc (car entity) wl-folder-group-alist)))
2415 (setcdr group-entry t)
2416 (when (eq 'access (cadr entity))
2417 (wl-folder-maybe-load-folder-list entity)))
2419 (wl-push entities entity-stack))
2420 (setq entities (nth 2 entity))))
2422 (setq entities (wl-pop entity-stack))))))
2424 (defun wl-folder-open-all (&optional refresh)
2426 (let* ((inhibit-read-only t)
2427 (buffer-read-only nil)
2428 (len (length wl-folder-group-alist))
2433 (wl-folder-prev-entity-skip-invalid t)
2434 (wl-folder-get-entity-from-buffer t)))
2435 (alist wl-folder-group-alist))
2437 (setcdr (pop alist) t))
2439 (wl-folder-insert-entity " " wl-folder-entity)
2440 (wl-folder-move-path id))
2441 (message "Opening all folders...")
2442 (wl-folder-open-all-pre)
2444 (goto-char (point-min))
2445 (while (re-search-forward
2446 "^\\([ ]*\\)\\[\\([+]\\)\\]\\(.+\\):[-0-9-]+/[0-9-]+/[0-9-]+\n"
2448 (setq indent (wl-match-buffer 1))
2449 (setq name (wl-folder-get-realname (wl-match-buffer 3)))
2450 (setq entity (wl-folder-search-group-entity-by-name
2454 (setcdr (assoc (car entity) wl-folder-group-alist) t)
2456 (wl-folder-insert-entity indent entity)
2457 (delete-region (save-excursion (beginning-of-line)
2459 (save-excursion (end-of-line)
2461 (when (> len elmo-display-progress-threshold)
2463 (if (or (zerop (% i 5)) (= i len))
2464 (elmo-display-progress
2465 'wl-folder-open-all "Opening all folders..."
2466 (/ (* i 100) len)))))
2467 (when (> len elmo-display-progress-threshold)
2468 (elmo-display-progress
2469 'wl-folder-open-all "Opening all folders..." 100))))
2470 (message "Opening all folders...done")
2471 (set-buffer-modified-p nil)))
2473 (defun wl-folder-close-all ()
2475 (let ((inhibit-read-only t)
2476 (buffer-read-only nil)
2477 (alist wl-folder-group-alist)
2479 (wl-folder-prev-entity-skip-invalid t)
2480 (wl-folder-get-entity-from-buffer t))))
2482 (setcdr (car alist) nil)
2483 (setq alist (cdr alist)))
2484 (setcdr (assoc (car wl-folder-entity) wl-folder-group-alist) t)
2486 (wl-folder-insert-entity " " wl-folder-entity)
2487 (wl-folder-move-path id)
2489 (set-buffer-modified-p nil)))
2491 (defun wl-folder-open-close ()
2492 "Open or close parent entity."
2496 (if (wl-folder-buffer-group-p)
2497 ;; if group (whether opend or closed.)
2498 (wl-folder-jump-to-current-entity)
2501 (setq indent (save-excursion
2502 (re-search-forward "\\([ ]*\\)." nil t)
2503 (wl-match-buffer 1)))
2504 (while (looking-at indent)
2506 (wl-folder-jump-to-current-entity))))
2508 (defsubst wl-folder-access-subscribe-p (group folder)
2509 (let (subscr regexp match)
2510 (if (setq subscr (wl-get-assoc-list-value
2511 wl-folder-access-subscribe-alist
2514 (setq regexp (mapconcat 'identity (cdr subscr) "\\|"))
2515 (setq match (string-match regexp folder))
2521 (defun wl-folder-update-access-group (entity new-flist)
2522 (let* ((flist (nth 2 entity))
2523 (unsubscribes (nth 3 entity))
2524 (len (+ (length flist) (length unsubscribes)))
2526 diff new-unsubscribes removes
2527 subscribed-list folder group entry)
2528 ;; check subscribed groups
2531 ((listp (car flist)) ;; group
2532 (setq group (elmo-string (caar flist)))
2534 ((assoc group new-flist) ;; found in new-flist
2535 (setq new-flist (delete (assoc group new-flist)
2537 (if (wl-folder-access-subscribe-p (car entity) group)
2538 (wl-append subscribed-list (list (car flist)))
2539 (wl-append new-unsubscribes (list (car flist)))
2542 (setq wl-folder-group-alist
2543 (delete (wl-string-assoc group wl-folder-group-alist)
2544 wl-folder-group-alist))
2545 (wl-append removes (list (list group))))))
2547 (setq folder (elmo-string (car flist)))
2549 ((member folder new-flist) ;; found in new-flist
2550 (setq new-flist (delete folder new-flist))
2551 (if (wl-folder-access-subscribe-p (car entity) folder)
2552 (wl-append subscribed-list (list (car flist)))
2553 (wl-append new-unsubscribes (list folder))
2556 (wl-append removes (list folder))))))
2557 (when (> len elmo-display-progress-threshold)
2559 (if (or (zerop (% i 10)) (= i len))
2560 (elmo-display-progress
2561 'wl-folder-update-access-group "Updating access group..."
2562 (/ (* i 100) len))))
2563 (setq flist (cdr flist)))
2564 ;; check unsubscribed groups
2567 ((listp (car unsubscribes))
2568 (when (setq entry (assoc (caar unsubscribes) new-flist))
2569 (setq new-flist (delete entry new-flist))
2570 (wl-append new-unsubscribes (list (car unsubscribes)))))
2572 (when (member (car unsubscribes) new-flist)
2573 (setq new-flist (delete (car unsubscribes) new-flist))
2574 (wl-append new-unsubscribes (list (car unsubscribes))))))
2575 (when (> len elmo-display-progress-threshold)
2577 (if (or (zerop (% i 10)) (= i len))
2578 (elmo-display-progress
2579 'wl-folder-update-access-group "Updating access group..."
2580 (/ (* i 100) len))))
2581 (setq unsubscribes (cdr unsubscribes)))
2583 (if (or new-flist removes)
2586 (mapcar '(lambda (x)
2587 (cond ((consp x) (list (car x) 'access))
2591 (let ((new-list new-flist))
2593 (if (not (wl-folder-access-subscribe-p
2595 (if (listp (car new-list))
2600 (wl-append new-unsubscribes (list (car new-list)))
2601 (setq new-flist (delete (car new-list) new-flist)))
2603 ((listp (car new-list))
2604 ;; check group exists
2605 (if (wl-string-assoc (caar new-list) wl-folder-group-alist)
2607 (message "%s: group already exists." (caar new-list))
2609 (wl-append new-unsubscribes (list (car new-list)))
2610 (setq new-flist (delete (car new-list) new-flist)))
2611 (wl-append wl-folder-group-alist
2612 (list (cons (caar new-list) nil)))))))
2613 (setq new-list (cdr new-list))))
2615 (message "%d new folder(s)." (length new-flist))
2616 (message "Updating access group...done"))
2617 (wl-append new-flist subscribed-list) ;; new is first
2618 (run-hooks 'wl-folder-update-access-group-hook)
2619 (setcdr (cdr entity) (list new-flist new-unsubscribes))
2620 (list diff new-flist new-unsubscribes removes)))
2622 (defun wl-folder-prefetch-entity (entity)
2623 "Prefetch all new messages in the ENTITY."
2626 (let ((flist (nth 2 entity))
2631 (setq result (wl-folder-prefetch-entity (car flist)))
2632 (setq sum-done (+ sum-done (car result)))
2633 (setq sum-all (+ sum-all (cdr result)))
2634 (setq flist (cdr flist)))
2635 (message "Prefetched %d/%d message(s) in \"%s\"."
2637 (wl-folder-get-petname (car entity)))
2638 (cons sum-done sum-all)))
2640 (let* ((folder (wl-folder-get-elmo-folder entity))
2641 (nums (wl-folder-get-entity-info entity))
2642 (wl-summary-highlight (if (or (wl-summary-sticky-p folder)
2643 (wl-summary-always-sticky-folder-p
2645 wl-summary-highlight))
2646 wl-summary-exit-next-move
2647 wl-auto-select-first ret-val
2649 (setq count (or (car nums) 0))
2650 (setq count (+ count (wl-folder-count-incorporates folder)))
2651 (if (or (null (car nums)) ; unknown
2653 (save-window-excursion
2655 (let ((wl-summary-buffer-name (concat
2656 wl-summary-buffer-name
2657 (symbol-name this-command)))
2658 (wl-summary-use-frame nil)
2659 (wl-summary-always-sticky-folder-list nil))
2660 (wl-summary-goto-folder-subr entity
2661 (wl-summary-get-sync-range
2664 (setq ret-val (wl-summary-incorporate))
2669 (defun wl-folder-count-incorporates (folder)
2670 (let ((marks (elmo-msgdb-mark-load
2671 (elmo-folder-msgdb-path folder)))
2674 (if (member (cadr (car marks))
2675 wl-summary-incorporate-marks)
2677 (setq marks (cdr marks)))
2680 (defun wl-folder-prefetch-current-entity (&optional no-check)
2681 "Prefetch all uncached messages in the folder at position.
2682 If current line is group folder, all subfolders are prefetched."
2685 (let ((entity-name (wl-folder-get-entity-from-buffer))
2686 (group (wl-folder-buffer-group-p))
2687 wl-folder-check-entity-hook
2692 (wl-folder-search-group-entity-by-name entity-name
2696 (wl-folder-check-entity entity))
2697 (wl-folder-prefetch-entity entity)))))
2699 ;(defun wl-folder-drop-unsync-entity (entity)
2700 ; "Drop all unsync messages in the ENTITY."
2703 ; (let ((flist (nth 2 entity)))
2705 ; (wl-folder-drop-unsync-entity (car flist))
2706 ; (setq flist (cdr flist)))))
2708 ; (let ((nums (wl-folder-get-entity-info entity))
2709 ; wl-summary-highlight wl-auto-select-first new)
2710 ; (setq new (or (car nums) 0))
2712 ; (save-window-excursion
2714 ; (let ((wl-summary-buffer-name (concat
2715 ; wl-summary-buffer-name
2716 ; (symbol-name this-command))))
2717 ; (wl-summary-goto-folder-subr entity 'no-sync nil)
2718 ; (wl-summary-drop-unsync)
2719 ; (wl-summary-exit)))))))))
2721 ;(defun wl-folder-drop-unsync-current-entity (&optional force-check)
2722 ; "Drop all unsync messages in the folder at position.
2723 ;If current line is group folder, all subfolders are dropped.
2724 ;If optional arg exists, don't check any folders."
2727 ; (let ((entity-name (wl-folder-get-entity-from-buffer))
2728 ; (group (wl-folder-buffer-group-p))
2729 ; wl-folder-check-entity-hook
2730 ; summary-buf entity)
2731 ; (when (and entity-name
2733 ; "Drop all unsync messages in %s?" entity-name)))
2736 ; (wl-folder-search-group-entity-by-name entity-name
2739 ; (if (null force-check)
2740 ; (wl-folder-check-entity entity))
2741 ; (wl-folder-drop-unsync-entity entity)
2742 ; (message "All unsync messages in %s are dropped!" entity-name)))))
2744 (defun wl-folder-write-current-folder ()
2745 "Write message to current folder's newsgroup or mailing-list.
2746 Call `wl-summary-write-current-folder' with current folder name."
2748 (unless (wl-folder-buffer-group-p)
2749 (wl-summary-write-current-folder
2750 (wl-folder-get-realname (wl-folder-entity-name)))))
2752 (defun wl-folder-mimic-kill-buffer ()
2753 "Kill the current (Folder) buffer with query."
2755 (let ((bufname (read-buffer (format "Kill buffer: (default %s) "
2757 wl-interactive-exit)
2758 (if (or (not bufname)
2759 (string-equal bufname "")
2760 (string-equal bufname (buffer-name)))
2762 (kill-buffer bufname))))
2764 (defun wl-folder-create-subr (folder)
2765 (if (not (elmo-folder-creatable-p folder))
2766 (error "Folder %s is not found" (elmo-folder-name-internal folder))
2768 (format "Folder %s does not exist, create it?"
2769 (elmo-folder-name-internal folder)))
2771 (setq wl-folder-entity-hashtb
2772 (wl-folder-create-entity-hashtb
2773 (elmo-folder-name-internal folder)
2774 wl-folder-entity-hashtb))
2775 (unless (elmo-folder-create folder)
2776 (error "Create folder failed")))
2777 (error "Folder %s is not created" (elmo-folder-name-internal folder)))))
2779 (defun wl-folder-confirm-existence (folder &optional force)
2781 (unless (elmo-folder-exists-p folder)
2782 (wl-folder-create-subr folder))
2783 (unless (or (wl-folder-entity-exists-p (elmo-folder-name-internal folder))
2784 (file-exists-p (elmo-folder-msgdb-path folder))
2785 (elmo-folder-exists-p folder))
2786 (wl-folder-create-subr folder))))
2789 (product-provide (provide 'wl-folder) (require 'wl-version))
2791 ;;; wl-folder.el ends here