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))
127 (defun wl-folder-setup-mouse ())
128 (defun wl-folder-setup-mouse ()
129 (define-key wl-folder-mode-map [mouse-2] 'wl-folder-click)
130 (define-key wl-folder-mode-map [mouse-4] 'wl-folder-prev-entity)
131 (define-key wl-folder-mode-map [mouse-5] 'wl-folder-next-entity)
132 (define-key wl-folder-mode-map [S-mouse-4] 'wl-folder-prev-unread)
133 (define-key wl-folder-mode-map [S-mouse-5] 'wl-folder-next-unread))))
135 (if wl-folder-mode-map
137 (setq wl-folder-mode-map (make-sparse-keymap))
138 (define-key wl-folder-mode-map " " 'wl-folder-jump-to-current-entity)
139 ; (define-key wl-folder-mode-map "\M- " 'wl-folder-open-close)
140 (define-key wl-folder-mode-map "/" 'wl-folder-open-close)
141 (define-key wl-folder-mode-map "\C-m" 'wl-folder-jump-to-current-entity)
142 (define-key wl-folder-mode-map "\M-\C-m" 'wl-folder-update-recursive-current-entity)
143 (define-key wl-folder-mode-map "rc" 'wl-folder-mark-as-read-all-region)
144 (define-key wl-folder-mode-map "c" 'wl-folder-mark-as-read-all-current-entity)
145 (define-key wl-folder-mode-map "g" 'wl-folder-goto-folder)
146 (define-key wl-folder-mode-map "j" 'wl-folder-jump-to-current-entity)
147 (define-key wl-folder-mode-map "w" 'wl-draft)
148 (define-key wl-folder-mode-map "W" 'wl-folder-write-current-folder)
149 (define-key wl-folder-mode-map "\C-c\C-o" 'wl-jump-to-draft-buffer)
150 (define-key wl-folder-mode-map "rS" 'wl-folder-sync-region)
151 (define-key wl-folder-mode-map "S" 'wl-folder-sync-current-entity)
152 (define-key wl-folder-mode-map "rs" 'wl-folder-check-region)
153 (define-key wl-folder-mode-map "s" 'wl-folder-check-current-entity)
154 (define-key wl-folder-mode-map "I" 'wl-folder-prefetch-current-entity)
155 ; (define-key wl-folder-mode-map "D" 'wl-folder-drop-unsync-current-entity)
156 (define-key wl-folder-mode-map "p" 'wl-folder-prev-entity)
157 (define-key wl-folder-mode-map "n" 'wl-folder-next-entity)
158 (define-key wl-folder-mode-map "v" 'wl-folder-toggle-disp-summary)
159 (define-key wl-folder-mode-map "P" 'wl-folder-prev-unread)
160 (define-key wl-folder-mode-map "N" 'wl-folder-next-unread)
161 (define-key wl-folder-mode-map "J" 'wl-folder-jump-folder)
162 (define-key wl-folder-mode-map "f" 'wl-folder-goto-first-unread-folder)
163 (define-key wl-folder-mode-map "o" 'wl-folder-open-all-unread-folder)
164 (define-key wl-folder-mode-map "[" 'wl-folder-open-all)
165 (define-key wl-folder-mode-map "]" 'wl-folder-close-all)
166 (define-key wl-folder-mode-map "e" 'wl-folder-expire-current-entity)
167 (define-key wl-folder-mode-map "E" 'wl-folder-empty-trash)
168 (define-key wl-folder-mode-map "F" 'wl-folder-flush-queue)
169 (define-key wl-folder-mode-map "q" 'wl-exit)
170 (define-key wl-folder-mode-map "z" 'wl-folder-suspend)
171 (define-key wl-folder-mode-map "\M-t" 'wl-toggle-plugged)
172 (define-key wl-folder-mode-map "\C-t" 'wl-plugged-change)
173 (define-key wl-folder-mode-map "<" 'beginning-of-buffer)
174 (define-key wl-folder-mode-map ">" 'end-of-buffer)
177 (define-key wl-folder-mode-map "m" 'wl-fldmgr-mode-map))
178 (define-key wl-folder-mode-map "*" 'wl-fldmgr-make-multi)
179 (define-key wl-folder-mode-map "+" 'wl-fldmgr-make-group)
180 (define-key wl-folder-mode-map "|" 'wl-fldmgr-make-filter)
181 (define-key wl-folder-mode-map "\M-c" 'wl-fldmgr-copy)
182 (define-key wl-folder-mode-map "\M-w" 'wl-fldmgr-copy-region)
183 (define-key wl-folder-mode-map "\C-k" 'wl-fldmgr-cut)
184 (define-key wl-folder-mode-map "\C-w" 'wl-fldmgr-cut-region)
185 (define-key wl-folder-mode-map "\C-y" 'wl-fldmgr-yank)
186 (define-key wl-folder-mode-map "R" 'wl-fldmgr-rename)
187 (define-key wl-folder-mode-map "u" 'wl-fldmgr-unsubscribe)
188 (define-key wl-folder-mode-map "ru" 'wl-fldmgr-unsubscribe-region)
189 (define-key wl-folder-mode-map "U" 'wl-fldmgr-unsubscribe-region)
190 (define-key wl-folder-mode-map "l" 'wl-fldmgr-access-display-normal)
191 (define-key wl-folder-mode-map "L" 'wl-fldmgr-access-display-all)
192 (define-key wl-folder-mode-map "Z" 'wl-status-update)
193 (define-key wl-folder-mode-map "\C-x\C-s" 'wl-save)
194 (define-key wl-folder-mode-map "\M-s" 'wl-save)
195 (define-key wl-folder-mode-map "\C-xk" 'wl-folder-mimic-kill-buffer)
196 (define-key wl-folder-mode-map "\M-\C-a"
197 'wl-folder-goto-top-of-current-folder)
198 (define-key wl-folder-mode-map "\M-\C-e"
199 'wl-folder-goto-bottom-of-current-folder)
201 (wl-folder-setup-mouse)
205 "Menu used in Folder mode."
206 wl-folder-mode-menu-spec))
208 (defmacro wl-folder-unread-regex (group)
209 (` (concat "^[ ]*.+:[0-9\\*-]+/[^0\\*][0-9]*/[0-9\\*-]+$"
214 (defmacro wl-folder-buffer-group-p ()
215 (` (save-excursion (beginning-of-line)
216 (looking-at wl-folder-group-regexp))))
218 (defmacro wl-folder-folder-name ()
221 (if (or (looking-at "^[ ]*\\[[\\+-]\\]\\(.+\\):[-0-9\\*-]+/[0-9\\*-]+/[0-9\\*-]+\n")
222 (looking-at "^[ ]*\\([^\\[].+\\):.*\n"))
223 (wl-match-buffer 1)))))
225 (defmacro wl-folder-entity-name ()
228 (if (looking-at "^[ ]*\\([^\\[].+\\):.*\n")
229 (wl-match-buffer 1)))))
231 (defun wl-folder-buffer-search-group (group)
234 "^\\([ \t]*\\)\\[[\\+-]\\]"
235 (regexp-quote group) ":[-0-9-]+/[0-9-]+/[0-9-]+") nil t))
237 (defun wl-folder-buffer-search-entity (folder &optional searchname)
238 (let ((search (or searchname (wl-folder-get-petname folder))))
242 (regexp-quote search) ":[-0-9\\*-]+/[0-9\\*-]+/[0-9\\*-]+") nil t)))
244 (defsubst wl-folder-get-folder-name-by-id (entity-id &optional hashtb)
245 (and (numberp entity-id)
246 (elmo-get-hash-val (format "#%d" entity-id)
247 (or hashtb wl-folder-entity-id-name-hashtb))))
249 (defsubst wl-folder-set-id-name (entity-id entity &optional hashtb)
250 (and (numberp entity-id)
251 (elmo-set-hash-val (format "#%d" entity-id)
252 entity (or hashtb wl-folder-entity-id-name-hashtb))))
254 (defmacro wl-folder-get-entity-id (entity)
255 (` (or (get-text-property 0
258 (, entity)))) ;; for nemacs
260 (defmacro wl-folder-get-entity-from-buffer (&optional getid)
261 (` (let ((id (get-text-property (point)
262 'wl-folder-entity-id)))
263 (if (not id) ;; for nemacs
264 (wl-folder-get-realname (wl-folder-folder-name))
267 (wl-folder-get-folder-name-by-id id))))))
269 (defmacro wl-folder-entity-exists-p (entity &optional hashtb)
270 (` (let ((sym (intern-soft (, entity)
271 (or (, hashtb) wl-folder-entity-hashtb))))
272 (and sym (boundp sym)))))
274 (defmacro wl-folder-clear-entity-info (entity &optional hashtb)
275 (` (let ((sym (intern-soft (, entity)
276 (or (, hashtb) wl-folder-entity-hashtb))))
280 (defmacro wl-folder-get-entity-info (entity &optional hashtb)
281 (` (elmo-get-hash-val (, entity) (or (, hashtb) wl-folder-entity-hashtb))))
283 (defmacro wl-folder-set-entity-info (entity value &optional hashtb)
284 (` (let* ((hashtb (or (, hashtb) wl-folder-entity-hashtb))
285 (info (wl-folder-get-entity-info (, entity) hashtb)))
286 (elmo-set-hash-val (, entity)
287 (if (< (length (, value)) 4)
288 (append (, value) (list (nth 3 info)))
292 (defun wl-folder-persistent-p (folder)
293 (or (and (wl-folder-search-entity-by-name folder wl-folder-entity
297 (let ((li wl-save-folder-list))
299 (if (string-match (car li) folder)
301 (setq li (cdr li)))))
303 (let ((li wl-no-save-folder-list))
305 (if (string-match (car li) folder)
307 (setq li (cdr li))))))))
309 ;;; ELMO folder structure with cache.
310 (defmacro wl-folder-get-elmo-folder (entity)
311 "Get elmo folder structure from entity."
312 (` (or (wl-folder-elmo-folder-cache-get (, entity))
313 (let* ((name (elmo-string (, entity)))
314 (folder (elmo-make-folder name)))
315 (wl-folder-elmo-folder-cache-put name folder)
318 (defmacro wl-folder-elmo-folder-cache-get (name &optional hashtb)
319 "Returns a elmo folder structure associated with NAME from HASHTB.
320 Default HASHTB is `wl-folder-elmo-folder-hashtb'."
321 (` (elmo-get-hash-val (, name)
322 (or (, hashtb) wl-folder-elmo-folder-hashtb))))
324 (defmacro wl-folder-elmo-folder-cache-put (name folder &optional hashtb)
325 "Get folder elmo folder structure on HASHTB for folder with NAME.
326 Default HASHTB is `wl-folder-elmo-folder-hashtb'."
327 (` (elmo-set-hash-val (, name) (, folder)
328 (or (, hashtb) wl-folder-elmo-folder-hashtb))))
330 (defun wl-folder-prev-entity ()
334 (defun wl-folder-next-entity ()
338 (defun wl-folder-prev-entity-skip-invalid (&optional hereto)
339 "move to previous entity. skip unsubscribed or removed entity."
343 (if (re-search-backward wl-folder-entity-regexp nil t)
345 (goto-char (point-min))))
347 (defun wl-folder-next-entity-skip-invalid (&optional hereto)
348 "Move to next entity. skip unsubscribed or removed entity."
353 (if (re-search-forward wl-folder-entity-regexp nil t)
355 (goto-char (point-max))))
357 (defun wl-folder-search-group-entity-by-name (name entity)
358 (wl-folder-search-entity-by-name name entity 'group))
360 (defun wl-folder-search-entity-by-name (name entity &optional type)
361 (let ((entities (list entity))
365 (setq entity (wl-pop entities))
368 (if (and (not (eq type 'folder))
369 (string= name (car entity)))
370 (throw 'done entity))
372 (wl-push entities entity-stack))
373 (setq entities (nth 2 entity)))
374 ((and (not (eq type 'group))
376 (if (string= name entity)
377 (throw 'done entity))))
379 (setq entities (wl-pop entity-stack)))))))
381 (defun wl-folder-search-entity-list-by-name (name entity &optional get-id)
382 (let ((entities (list entity))
383 entity-stack ret-val)
385 (setq entity (wl-pop entities))
389 (wl-push entities entity-stack))
390 (setq entities (nth 2 entity)))
392 (if (string= name entity)
393 (wl-append ret-val (if get-id
394 (list (wl-folder-get-entity-id entity))
397 (setq entities (wl-pop entity-stack))))
400 (defun wl-folder-get-prev-folder (id &optional unread)
401 (let ((name (if (stringp id)
403 (wl-folder-get-folder-name-by-id id)))
404 entity entity-stack last-entity finfo
405 (entities (list wl-folder-entity)))
408 (setq entity (wl-pop entities))
411 ;; (if (and (string= name (car entity))
412 ;; (eq id (wl-folder-get-entity-id (car entity))))
413 ;; (throw 'done last-entity))
415 (wl-push entities entity-stack))
416 (setq entities (nth 2 entity)))
418 (if (and (string= name entity)
419 ;; don't use eq, `id' is string on Nemacs.
420 (equal id (wl-folder-get-entity-id entity)))
421 (throw 'done last-entity))
423 (and (setq finfo (wl-folder-get-entity-info entity))
424 (and (nth 0 finfo)(nth 1 finfo))
425 (> (+ (nth 0 finfo)(nth 1 finfo)) 0)))
426 (setq last-entity entity))))
428 (setq entities (wl-pop entity-stack)))))))
430 (defun wl-folder-get-next-folder (id &optional unread)
431 (let ((name (if (stringp id)
433 (wl-folder-get-folder-name-by-id id)))
434 entity entity-stack found finfo
435 (entities (list wl-folder-entity)))
438 (setq entity (wl-pop entities))
441 ;;; (if (and (string= name (car entity))
442 ;;; (eq id (wl-folder-get-entity-id (car entity))))
445 (wl-push entities entity-stack))
446 (setq entities (nth 2 entity)))
449 (when (or (not unread)
450 (and (setq finfo (wl-folder-get-entity-info entity))
451 (and (nth 0 finfo)(nth 1 finfo))
452 (> (+ (nth 0 finfo)(nth 1 finfo)) 0)))
453 (throw 'done entity))
454 (if (and (string= name entity)
455 ;; don't use eq, `id' is string on Nemacs.
456 (equal id (wl-folder-get-entity-id entity)))
459 (setq entities (wl-pop entity-stack)))))))
461 (defun wl-folder-flush-queue ()
464 (let ((cur-buf (current-buffer))
465 (wl-auto-select-first nil)
468 (if elmo-enable-disconnected-operation
469 (elmo-dop-queue-flush 'force)) ; Try flushing all queue.
470 (if (not (elmo-folder-list-messages
471 (wl-folder-get-elmo-folder wl-queue-folder)))
472 (message "No sending queue exists.")
473 (if wl-stay-folder-window
474 (wl-folder-select-buffer
475 (wl-summary-get-buffer-create wl-queue-folder)))
476 (wl-summary-goto-folder-subr wl-queue-folder 'force-update nil)
478 (wl-draft-queue-flush)
479 (if (get-buffer-window cur-buf)
480 (select-window (get-buffer-window cur-buf)))
482 (if wl-stay-folder-window
483 (wl-folder-toggle-disp-summary 'off wl-queue-folder)
484 (switch-to-buffer cur-buf))))))
486 (defun wl-folder-empty-trash ()
489 (let ((cur-buf (current-buffer))
490 (wl-auto-select-first nil)
492 (if wl-stay-folder-window
493 (wl-folder-select-buffer
494 (wl-summary-get-buffer-create wl-trash-folder)))
495 (wl-summary-goto-folder-subr wl-trash-folder 'force-update nil nil t)
496 (setq trash-buf (current-buffer))
498 (setq emptied (wl-summary-delete-all-msgs))
500 (setq wl-thread-entities nil
501 wl-thread-entity-list nil)
502 (if wl-summary-cache-use (wl-summary-save-view-cache))
503 (elmo-folder-commit wl-summary-buffer-elmo-folder))
504 (if (get-buffer-window cur-buf)
505 (select-window (get-buffer-window cur-buf)))
508 (wl-folder-set-folder-updated wl-trash-folder '(0 0 0)))
509 (if wl-stay-folder-window
510 (wl-folder-toggle-disp-summary 'off wl-trash-folder)
511 (switch-to-buffer cur-buf))
513 (kill-buffer trash-buf)))))
515 (defun wl-folder-goto-top-of-current-folder (&optional arg)
516 "Move backward to the top of the current folder group.
517 Optional argument ARG is repeart count."
519 (if (re-search-backward
520 "^ *\\[[\\+-]\\]" nil t (if arg (prefix-numeric-value arg)))
522 (goto-char (point-min))))
524 (defun wl-folder-goto-bottom-of-current-folder (indent)
525 "Move forward to the bottom of the current folder group."
530 (if (looking-at "^ *")
531 (buffer-substring (match-beginning 0)(1- (match-end 0)))
535 (while (re-search-forward "^ *" nil t)
536 (if (<= (length (match-string 0))
540 (goto-char (point-max))))
542 (defsubst wl-folder-update-group (entity diffs &optional is-group)
544 (let ((path (wl-folder-get-path
546 (wl-folder-get-entity-id entity)
549 ;; delete itself from path
550 (setq path (delete (nth (- (length path) 1) path) path)))
551 (goto-char (point-min))
554 ;; goto the path line.
555 (if (or (eq (car path) 0) ; update desktop
556 (wl-folder-buffer-search-group
557 (wl-folder-get-petname
558 (if (stringp (car path))
560 (wl-folder-get-folder-name-by-id
563 (wl-folder-update-diff-line diffs)
565 (setq path (cdr path)))))))
567 (defun wl-folder-maybe-load-folder-list (entity)
568 (when (null (caddr entity))
570 (elmo-msgdb-flist-load (car entity)))
574 (wl-folder-entity-assign-id entity
575 wl-folder-entity-id-name-hashtb
577 (setq diffs (wl-fldmgr-add-entity-hashtb (list entity)))
578 (unless (equal diffs '(0 0 0))
579 (wl-folder-update-group (car entity) diffs t)))))))
581 (defsubst wl-folder-force-fetch-p (entity)
583 ((consp wl-force-fetch-folders)
584 (wl-string-match-member entity wl-force-fetch-folders))
586 wl-force-fetch-folders)))
588 (defun wl-folder-jump-to-current-entity (&optional arg)
589 "Enter the current folder. If optional ARG exists, update folder list."
592 (let (entity beg end indent opened fname err fld-name)
594 ((looking-at wl-folder-group-regexp)
596 (setq fname (wl-folder-get-realname (wl-match-buffer 3)))
597 (setq indent (wl-match-buffer 1))
598 (setq opened (wl-match-buffer 2))
599 (if (string= opened "+")
601 (setq entity (wl-folder-search-group-entity-by-name
606 (wl-folder-update-recursive-current-entity entity)
608 (setcdr (assoc (car entity) wl-folder-group-alist) t)
609 (if (eq 'access (cadr entity))
610 (wl-folder-maybe-load-folder-list entity))
611 ;(condition-case errobj
613 (if (or (wl-folder-force-fetch-p (car entity))
615 (eq 'access (cadr entity))
616 (null (caddr entity))))
617 (wl-folder-update-newest indent entity)
618 (wl-folder-insert-entity indent entity))
619 (wl-highlight-folder-path wl-folder-buffer-cur-path))
622 ; (setcdr (assoc fname wl-folder-group-alist) nil))
624 ; (elmo-display-error errobj t)
627 ; (setcdr (assoc fname wl-folder-group-alist) nil)))
629 (let ((buffer-read-only nil))
630 (delete-region (save-excursion (beginning-of-line)
632 (save-excursion (end-of-line)
638 (progn (wl-folder-goto-bottom-of-current-folder indent)
641 (setq entity (wl-folder-search-group-entity-by-name
644 (let ((buffer-read-only nil))
645 (delete-region beg end))
646 (setcdr (assoc (car entity) wl-folder-group-alist) nil)
647 (wl-folder-insert-entity indent entity) ; insert entity
649 (wl-highlight-folder-path wl-folder-buffer-cur-path)
650 ; (wl-delete-all-overlays)
651 ; (wl-highlight-folder-current-line)
653 ((setq fld-name (wl-folder-entity-name))
656 (wl-folder-set-current-entity-id
657 (wl-folder-get-entity-from-buffer))
658 (setq fld-name (wl-folder-get-realname fld-name)))
659 (wl-folder-set-current-entity-id
660 (get-text-property (point) 'wl-folder-entity-id))
661 (setq fld-name (wl-folder-get-folder-name-by-id
662 wl-folder-buffer-cur-entity-id)))
663 (let ((summary-buf (wl-summary-get-buffer-create fld-name arg))
665 (if wl-stay-folder-window
666 (wl-folder-select-buffer summary-buf)
668 (get-buffer-window summary-buf))
670 (wl-summary-goto-folder-subr fld-name
671 (wl-summary-get-sync-range
672 (wl-folder-get-elmo-folder fld-name))
674 (set-buffer-modified-p nil))
676 (defun wl-folder-close-entity (entity)
677 (let ((entities (list entity))
680 (setq entity (wl-pop entities))
683 (setcdr (assoc (car entity) wl-folder-group-alist) nil)
685 (wl-push entities entity-stack))
686 (setq entities (nth 2 entity))))
688 (setq entities (wl-pop entity-stack))))))
690 (defun wl-folder-update-recursive-current-entity (&optional entity)
692 (when (wl-folder-buffer-group-p)
694 ((string= (wl-match-buffer 2) "+")
698 (wl-folder-search-group-entity-by-name
699 (wl-folder-get-realname (wl-match-buffer 3))
701 (let ((inhibit-read-only t)
702 (entities (list entity))
703 entity-stack err indent)
704 (while (and entities (not err))
705 (setq entity (wl-pop entities))
708 (wl-folder-close-entity entity)
709 (setcdr (assoc (car entity) wl-folder-group-alist) t)
710 (unless (wl-folder-buffer-search-group
711 (wl-folder-get-petname (car entity)))
712 (error "%s: not found group" (car entity)))
713 (setq indent (wl-match-buffer 1))
714 (if (eq 'access (cadr entity))
715 (wl-folder-maybe-load-folder-list entity))
719 (condition-case errobj
720 (wl-folder-update-newest indent entity)
723 (setcdr (assoc (car entity) wl-folder-group-alist) nil))
725 (elmo-display-error errobj t)
728 (setcdr (assoc (car entity) wl-folder-group-alist) nil)))
730 (delete-region (save-excursion (beginning-of-line)
732 (save-excursion (end-of-line)
736 (wl-push entities entity-stack))
737 (setq entities (nth 2 entity))))
739 (setq entities (wl-pop entity-stack)))))
740 (set-buffer-modified-p nil)))
742 (wl-folder-jump-to-current-entity)))))
744 (defun wl-folder-no-auto-check-folder-p (folder)
747 (let ((li wl-auto-check-folder-list))
749 (if (string-match (car li) folder)
751 (setq li (cdr li)))))
754 (let ((li wl-auto-uncheck-folder-list))
756 (if (string-match (car li) folder)
757 (throw 'found t)) ; no check!
758 (setq li (cdr li))))))))
760 (defsubst wl-folder-add-folder-info (pre-value value)
762 (+ (or (nth 0 pre-value) 0) (or (nth 0 value) 0))
763 (+ (or (nth 1 pre-value) 0) (or (nth 1 value) 0))
764 (+ (or (nth 2 pre-value) 0) (or (nth 2 value) 0))))
766 (defun wl-folder-check-entity (entity &optional auto)
767 "Check unsync message number."
768 (let ((start-pos (point))
770 (run-hooks 'wl-folder-check-entity-pre-hook)
771 (if (and (consp entity) ;; group entity
772 wl-folder-check-async) ;; very fast
773 (setq ret-val (wl-folder-check-entity-async entity auto))
777 (let ((flist (if auto
779 'wl-folder-no-auto-check-folder-p
782 (wl-folder-check-entity-pre-hook nil)
783 (wl-folder-check-entity-hook nil)
787 (wl-folder-add-folder-info
789 (wl-folder-check-entity (car flist))))
790 (setq flist (cdr flist)))
791 ;(wl-folder-buffer-search-entity (car entity))
792 ;(wl-folder-update-line ret-val)
795 (message "Checking \"%s\"" entity)
796 (setq ret-val (wl-folder-check-one-entity
798 (goto-char start-pos)
801 (message "Uncheck(unplugged) \"%s\"" entity)))))
803 (message "Checking \"%s\" is done."
804 (if (consp entity) (car entity) entity)))
805 (run-hooks 'wl-folder-check-entity-hook)
808 (defun wl-folder-check-one-entity (entity)
809 (let* ((folder (wl-folder-get-elmo-folder entity))
810 (nums (condition-case err
811 (if (wl-string-match-member entity wl-strict-diff-folders)
812 (elmo-strict-folder-diff folder)
813 (elmo-folder-diff folder))
815 ;; maybe not exist folder.
816 (if (and (not (memq 'elmo-open-error
817 (get (car err) 'error-conditions)))
818 (not (elmo-folder-exists-p folder)))
819 (wl-folder-create-subr folder)
820 (signal (car err) (cdr err))))))
822 (if (and (eq wl-folder-notify-deleted 'sync)
824 (or (> 0 (car nums)) (> 0 (cdr nums))))
826 (wl-folder-sync-entity entity)
827 (setq nums (elmo-folder-diff folder)))
828 (unless wl-folder-notify-deleted
829 (setq unsync (if (and (car nums) (> 0 (car nums))) 0 (car nums)))
830 (setq nomif (if (and (car nums) (> 0 (cdr nums))) 0 (cdr nums)))
831 (setq nums (cons unsync nomif)))
832 (setq unread (or ;; If server diff, All unreads are
834 (if (elmo-folder-use-flag-p folder)
836 (elmo-folder-get-info-unread folder)
837 (wl-summary-count-unread (elmo-msgdb-mark-load
838 (elmo-folder-msgdb-path
840 (setq unread (min unread (- (or (cdr nums) 0) (or (car nums) 0))))
841 (wl-folder-entity-hashtb-set wl-folder-entity-hashtb entity
845 (get-buffer wl-folder-buffer-name)))
846 (setq wl-folder-info-alist-modified t)
848 (list (if wl-folder-notify-deleted
850 (max (or (car nums) 0))) unread (cdr nums))))
852 (defun wl-folder-check-entity-async (entity &optional auto)
853 (let ((elmo-nntp-groups-async t)
856 'wl-folder-no-auto-check-folder-p
857 (wl-folder-get-entity-list entity))
858 (wl-folder-get-entity-list entity)))
859 (nntp-connection-keys nil)
860 name folder folder-list
866 (setq folder (wl-folder-get-elmo-folder (car elist)))
867 (if (not (elmo-folder-plugged-p folder))
868 (message "Uncheck \"%s\"" (car elist))
870 (elmo-folder-get-primitive-list folder))
871 (cond ((elmo-folder-contains-type folder 'nntp)
872 (wl-append async-folder-list (list folder))
874 (when (eq (elmo-folder-type-internal (car folder-list))
878 (elmo-net-folder-server-internal
880 (setq server (elmo-net-folder-server-internal
882 (message "Checking on \"%s\"" server))
883 (setq nntp-connection-keys
884 (elmo-nntp-get-folders-info-prepare
886 nntp-connection-keys)))
887 (setq folder-list (cdr folder-list))))
889 (wl-append sync-folder-list (list folder)))))
890 (setq elist (cdr elist)))
891 ;; check local entity at first
892 (while (setq folder (pop sync-folder-list))
893 (if (not (elmo-folder-plugged-p folder))
894 (message "Uncheck \"%s\"" (elmo-folder-name-internal folder))
895 (message "Checking \"%s\"" (elmo-folder-name-internal folder))
897 (wl-folder-add-folder-info
899 (wl-folder-check-one-entity (elmo-folder-name-internal
903 ;; check network entity at last
904 (when async-folder-list
905 (elmo-nntp-get-folders-info nntp-connection-keys)
906 (while (setq folder (pop async-folder-list))
907 (if (not (elmo-folder-plugged-p folder))
908 (message "Uncheck \"%s\"" (elmo-folder-name-internal folder))
909 (message "Checking \"%s\"" (elmo-folder-name-internal folder))
911 (wl-folder-add-folder-info
913 (wl-folder-check-one-entity (elmo-folder-name-internal
920 (defun wl-folder-resume-entity-hashtb-by-finfo (entity-hashtb info-alist)
921 "Resume unread info for entity alist."
924 (setq info (nth 1 (car info-alist)))
925 (wl-folder-set-entity-info (caar info-alist)
926 (list (nth 2 info)(nth 3 info)(nth 1 info))
928 (setq info-alist (cdr info-alist)))))
930 (defun wl-folder-move-path (path)
931 (let ((fp (if (consp path)
934 (wl-folder-get-path wl-folder-entity path))))
935 (goto-char (point-min))
938 (when (equal (car fp)
939 (wl-folder-get-entity-from-buffer t))
941 (setq wl-folder-buffer-cur-point (point)))
943 (and wl-folder-buffer-cur-point
944 (goto-char wl-folder-buffer-cur-point))))
946 (defun wl-folder-set-current-entity-id (entity-id)
947 (let ((buf (get-buffer wl-folder-buffer-name)))
951 (setq wl-folder-buffer-cur-entity-id entity-id)
952 (setq wl-folder-buffer-cur-path (wl-folder-get-path wl-folder-entity
954 (wl-highlight-folder-path wl-folder-buffer-cur-path)
955 (and wl-folder-move-cur-folder
956 wl-folder-buffer-cur-point
957 (goto-char wl-folder-buffer-cur-point))))
958 (if (eq (current-buffer) buf)
959 (and wl-folder-move-cur-folder
960 wl-folder-buffer-cur-point
961 (goto-char wl-folder-buffer-cur-point)))))
963 (defun wl-folder-check-current-entity ()
964 "Check folder at position.
965 If current line is group folder, check all sub entries."
967 (let* ((entity-name (wl-folder-get-entity-from-buffer))
968 (group (wl-folder-buffer-group-p))
969 (desktop (string= entity-name wl-folder-desktop-name)))
971 (wl-folder-check-entity
973 (wl-folder-search-group-entity-by-name entity-name
978 (defun wl-folder-sync-entity (entity &optional unread-only)
979 "Synchronize the msgdb of ENTITY."
982 (let ((flist (nth 2 entity)))
984 (wl-folder-sync-entity (car flist) unread-only)
985 (setq flist (cdr flist)))))
987 (let* ((folder (wl-folder-get-elmo-folder entity))
988 (nums (wl-folder-get-entity-info entity))
989 (wl-summary-highlight (if (or (wl-summary-sticky-p folder)
990 (wl-summary-always-sticky-folder-p
992 wl-summary-highlight))
993 wl-auto-select-first new unread)
994 (setq new (or (car nums) 0))
995 (setq unread (or (cadr nums) 0))
996 (if (or (not unread-only)
997 (or (< 0 new) (< 0 unread)))
998 (let ((wl-summary-buffer-name (concat
999 wl-summary-buffer-name
1000 (symbol-name this-command))))
1001 (save-window-excursion
1003 (wl-summary-goto-folder-subr entity
1004 (wl-summary-get-sync-range
1007 (wl-summary-exit)))))))))
1009 (defun wl-folder-sync-current-entity (&optional unread-only)
1010 "Synchronize the folder at position.
1011 If current line is group folder, check all subfolders."
1014 (let ((entity-name (wl-folder-get-entity-from-buffer))
1015 (group (wl-folder-buffer-group-p)))
1016 (when (and entity-name
1017 (y-or-n-p (format "Sync %s?" entity-name)))
1018 (wl-folder-sync-entity
1020 (wl-folder-search-group-entity-by-name entity-name
1024 (message "Syncing %s is done!" entity-name)))))
1026 (defun wl-folder-mark-as-read-all-entity (entity)
1027 "Mark as read all messages in the ENTITY."
1030 (let ((flist (nth 2 entity)))
1032 (wl-folder-mark-as-read-all-entity (car flist))
1033 (setq flist (cdr flist)))))
1035 (let* ((nums (wl-folder-get-entity-info entity))
1036 (folder (wl-folder-get-elmo-folder entity))
1037 (wl-summary-highlight (if (or (wl-summary-sticky-p folder)
1038 (wl-summary-always-sticky-folder-p
1040 wl-summary-highlight))
1041 wl-auto-select-first new unread)
1042 (setq new (or (car nums) 0))
1043 (setq unread (or (cadr nums) 0))
1044 (if (or (< 0 new) (< 0 unread))
1045 (save-window-excursion
1047 (let ((wl-summary-buffer-name (concat
1048 wl-summary-buffer-name
1049 (symbol-name this-command))))
1050 (wl-summary-goto-folder-subr entity
1051 (wl-summary-get-sync-range folder)
1053 (wl-summary-mark-as-read-all)
1054 (wl-summary-exit))))
1057 (defun wl-folder-mark-as-read-all-current-entity ()
1058 "Mark as read all messages in the folder at position.
1059 If current line is group folder, all subfolders are marked."
1062 (let ((entity-name (wl-folder-get-entity-from-buffer))
1063 (group (wl-folder-buffer-group-p))
1065 (when (and entity-name
1066 (y-or-n-p (format "Mark all messages in %s as read?" entity-name)))
1067 (wl-folder-mark-as-read-all-entity
1069 (wl-folder-search-group-entity-by-name entity-name
1072 (message "All messages in %s are marked!" entity-name)))))
1074 (defun wl-folder-check-region (beg end)
1083 (let ((inhibit-read-only t)
1085 (while (< (point) end)
1086 ;; normal folder entity
1087 (if (looking-at "^[\t ]*\\([^\\[]+\\):\\(.*\\)\n")
1089 (setq entity (wl-folder-get-entity-from-buffer))
1090 (if (not (elmo-folder-plugged-p (wl-folder-get-elmo-folder
1092 (message "Uncheck %s" entity)
1093 (message "Checking %s" entity)
1094 (wl-folder-check-one-entity entity)
1099 (defun wl-folder-sync-region (beg end)
1108 (while (< (point) end)
1109 ;; normal folder entity
1110 (if (looking-at "^[\t ]*\\([^\\[]+\\):\\(.*\\)\n")
1112 (let ((inhibit-read-only t)
1114 (setq entity (wl-folder-get-entity-from-buffer))
1115 (wl-folder-sync-entity entity)
1116 (message "Syncing %s is done!" entity)
1121 (defun wl-folder-mark-as-read-all-region (beg end)
1130 (while (< (point) end)
1131 ;; normal folder entity
1132 (if (looking-at "^[\t ]*\\([^\\[]+\\):\\(.*\\)\n")
1134 (let ((inhibit-read-only t)
1136 (setq entity (wl-folder-get-entity-from-buffer))
1137 (wl-folder-mark-as-read-all-entity entity)
1138 (message "All messages in %s are marked!" entity)
1143 (defsubst wl-create-access-init-load-p (folder)
1144 (let ((no-load-regexp (when (and
1145 (not wl-folder-init-load-access-folders)
1146 wl-folder-init-no-load-access-folders)
1147 (mapconcat 'identity
1148 wl-folder-init-no-load-access-folders
1150 (load-regexp (and wl-folder-init-load-access-folders
1151 (mapconcat 'identity
1152 wl-folder-init-load-access-folders
1154 (cond (load-regexp (string-match load-regexp folder))
1155 (t (not (and no-load-regexp
1156 (string-match no-load-regexp folder)))))))
1158 (defun wl-create-access-folder-entity (name)
1160 (when (wl-create-access-init-load-p name)
1161 (setq flists (elmo-msgdb-flist-load name)) ; load flist.
1162 (setq flist (car flists))
1164 (when (consp (car flist))
1165 (setcdr (cdar flist)
1166 (wl-create-access-folder-entity (caar flist))))
1167 (setq flist (cdr flist)))
1170 (defun wl-create-folder-entity-from-buffer ()
1171 "Create folder entity recursively."
1173 ((looking-at "^[ \t]*$") ; blank line
1174 (goto-char (+ 1(match-end 0)))
1176 ((looking-at "^#.*$") ; comment
1177 (goto-char (+ 1 (match-end 0)))
1179 ((looking-at "^[\t ]*\\(.+\\)[\t ]*{[\t ]*$") ; group definition
1180 (let (name entity flist)
1181 (setq name (wl-match-buffer 1))
1182 (goto-char (+ 1 (match-end 0)))
1183 (while (setq entity (wl-create-folder-entity-from-buffer))
1184 (unless (eq entity 'ignore)
1185 (wl-append flist (list entity))))
1186 (if (looking-at "^[\t ]*}[\t ]*$") ; end of group
1188 (goto-char (+ 1 (match-end 0)))
1189 (if (wl-string-assoc name wl-folder-petname-alist)
1190 (error "%s already defined as petname" name))
1191 (list name 'group flist))
1192 (error "Syntax error in folder definition"))))
1193 ((looking-at "^[\t ]*\\([^\t \n]+\\)[\t ]*/$") ; access it!
1195 (setq name (wl-match-buffer 1))
1196 (goto-char (+ 1 (match-end 0)))
1197 ; (condition-case ()
1199 ; (setq flist (elmo-list-folders name)))
1200 ; (error (message "Access to folder %s failed." name)))
1201 ;; (setq flist (elmo-msgdb-flist-load name)) ; load flist.
1202 ;; (setq unsublist (nth 1 flist))
1203 ;; (setq flist (car flist))
1204 ;; (list name 'access flist unsublist)))
1205 (append (list name 'access) (wl-create-access-folder-entity name))))
1206 ;((looking-at "^[\t ]*\\([^\t \n}]+\\)[\t ]*\\(\"[^\"]*\"\\)?[\t ]*$") ; normal folder entity
1207 ((looking-at "^[\t ]*=[ \t]+\\([^\n]+\\)$"); petname definition
1208 (goto-char (+ 1 (match-end 0)))
1209 (let ((rest (elmo-match-buffer 1))
1211 (when (string-match "\\(\"[^\"]*\"\\)[\t ]*$" rest)
1212 (setq petname (elmo-delete-char ?\" (elmo-match-string 1 rest)))
1213 (setq rest (substring rest 0 (match-beginning 0))))
1214 (when (string-match "^[\t ]*\\(.*[^\t ]+\\)[\t ]+$" rest)
1215 (wl-folder-append-petname (elmo-match-string 1 rest)
1218 ((looking-at "^[ \t]*}[ \t]*$") ; end of group
1220 ((looking-at "^.*$") ; normal folder entity
1221 (goto-char (+ 1 (match-end 0)))
1222 (let ((rest (elmo-match-buffer 0))
1224 (if (string-match "\\(\"[^\"]*\"\\)[\t ]*$" rest)
1226 (setq petname (elmo-delete-char ?\" (elmo-match-string 1 rest)))
1227 (setq rest (substring rest 0 (match-beginning 0)))
1228 (when (string-match "^[\t ]*\\(.*[^\t ]+\\)[\t ]+$" rest)
1229 (wl-folder-append-petname
1230 (setq realname (elmo-match-string 1 rest))
1233 (if (string-match "^[\t ]*\\(.+\\)$" rest)
1234 (elmo-match-string 1 rest)
1237 (defun wl-folder-create-folder-entity ()
1238 "Create folder entries."
1239 (let ((tmp-buf (get-buffer-create " *wl-folder-tmp*"))
1243 (with-current-buffer tmp-buf
1245 (insert-file-contents wl-folders-file)
1246 (goto-char (point-min))
1247 (while (and (not (eobp))
1248 (setq entity (wl-create-folder-entity-from-buffer)))
1249 (unless (eq entity 'ignore)
1250 (wl-append ret-val (list entity)))))
1251 (kill-buffer tmp-buf))
1253 (setq ret-val (list wl-folder-desktop-name 'group ret-val))))
1255 (defun wl-folder-entity-assign-id (entity &optional hashtb on-noid)
1256 (let ((hashtb (or hashtb
1257 (setq wl-folder-entity-id-name-hashtb
1258 (elmo-make-hash wl-folder-entity-id))))
1259 (entities (list entity))
1262 (setq entity (wl-pop entities))
1265 (when (not (and on-noid
1266 (get-text-property 0
1267 'wl-folder-entity-id
1269 (put-text-property 0 (length (car entity))
1270 'wl-folder-entity-id
1273 (wl-folder-set-id-name wl-folder-entity-id
1274 (car entity) hashtb))
1276 (wl-push entities entity-stack))
1277 (setq entities (nth 2 entity)))
1279 (when (not (and on-noid
1280 (get-text-property 0
1281 'wl-folder-entity-id
1283 (put-text-property 0 (length entity)
1284 'wl-folder-entity-id
1287 (wl-folder-set-id-name wl-folder-entity-id
1289 (setq wl-folder-entity-id (+ 1 wl-folder-entity-id))
1291 (setq entities (wl-pop entity-stack))))))
1293 (defun wl-folder-click (e)
1298 (wl-folder-jump-to-current-entity)))
1300 (defun wl-folder-select-buffer (buffer)
1301 (let ((gbw (get-buffer-window buffer))
1304 (progn (select-window gbw)
1308 (split-window-horizontally wl-folder-window-width)
1312 (switch-to-buffer buffer)
1316 (defun wl-folder-toggle-disp-summary (&optional arg folder)
1318 (if (or (and folder (assoc folder wl-folder-group-alist))
1319 (and (interactive-p) (wl-folder-buffer-group-p)))
1320 (error "This command is not available on Group"))
1322 (let (wl-auto-select-first
1323 (wl-stay-folder-window t))
1326 (setq wl-folder-buffer-disp-summary t))
1328 (setq wl-folder-buffer-disp-summary nil)
1329 ;; hide wl-summary window.
1330 (let ((cur-buf (current-buffer))
1331 (summary-buffer (wl-summary-get-buffer folder)))
1332 (wl-folder-select-buffer summary-buffer)
1334 (select-window (get-buffer-window cur-buf))))
1336 (setq wl-folder-buffer-disp-summary
1337 (not wl-folder-buffer-disp-summary))
1338 (let ((cur-buf (current-buffer))
1340 (when (looking-at "^[ ]*\\([^\\[].+\\):.*\n")
1341 (setq folder-name (wl-folder-get-entity-from-buffer))
1342 (if wl-folder-buffer-disp-summary
1344 (wl-folder-select-buffer
1345 (wl-summary-get-buffer-create folder-name))
1347 (wl-summary-goto-folder-subr folder-name 'no-sync nil)
1348 (select-window (get-buffer-window cur-buf))))
1349 (wl-folder-select-buffer (wl-summary-get-buffer folder-name))
1351 (select-window (get-buffer-window cur-buf)))))))))
1353 (defun wl-folder-prev-unsync ()
1354 "Move cursor to the previous unsync folder."
1357 (setq start-point (point))
1359 (if (re-search-backward wl-folder-unsync-regexp nil t)
1361 (goto-char start-point)
1362 (message "No more unsync folder"))))
1364 (defun wl-folder-next-unsync (&optional plugged)
1365 "Move cursor to the next unsync."
1367 (let (start-point entity)
1368 (setq start-point (point))
1371 (while (re-search-forward wl-folder-unsync-regexp nil t)
1372 (if (or (wl-folder-buffer-group-p)
1375 (wl-folder-get-realname
1376 (wl-folder-folder-name)))
1377 (elmo-folder-plugged-p entity))
1380 (goto-char start-point)
1381 (message "No more unsync folder"))))
1383 (defun wl-folder-prev-unread (&optional group)
1384 "Move cursor to the previous unread folder."
1387 (setq start-point (point))
1389 (if (re-search-backward (wl-folder-unread-regex group) nil t)
1392 (wl-folder-folder-name))
1393 (goto-char start-point)
1394 (message "No more unread folder")
1397 (defun wl-folder-next-unread (&optional group)
1398 "Move cursor to the next unread folder."
1401 (setq start-point (point))
1403 (if (re-search-forward (wl-folder-unread-regex group) nil t)
1406 (wl-folder-folder-name))
1407 (goto-char start-point)
1408 (message "No more unread folder")
1411 (defun wl-folder-mode ()
1412 "Major mode for Wanderlust Folder.
1413 See Info under Wanderlust for full documentation.
1416 \\{wl-folder-mode-map}
1418 Entering Folder mode calls the value of `wl-folder-mode-hook'."
1420 (setq major-mode 'wl-folder-mode)
1421 (setq mode-name "Folder")
1422 (use-local-map wl-folder-mode-map)
1423 (setq buffer-read-only t)
1424 (setq inhibit-read-only nil)
1425 (setq truncate-lines t)
1426 (setq wl-folder-buffer-cur-entity-id nil
1427 wl-folder-buffer-cur-path nil
1428 wl-folder-buffer-cur-point nil)
1429 (wl-mode-line-buffer-identification)
1430 (easy-menu-add wl-folder-mode-menu)
1431 ;; This hook may contain the functions `wl-folder-init-icons' and
1432 ;; `wl-setup-folder' for reasons of system internal to accord
1433 ;; facilities for the Emacs variants.
1434 (run-hooks 'wl-folder-mode-hook))
1436 (defun wl-folder-append-petname (realname petname)
1438 ;; check group name.
1439 (if (wl-folder-search-group-entity-by-name petname wl-folder-entity)
1440 (error "%s already defined as group name" petname))
1441 (when (setq pentry (wl-string-assoc realname wl-folder-petname-alist))
1442 (setq wl-folder-petname-alist
1443 (delete pentry wl-folder-petname-alist)))
1444 (wl-append wl-folder-petname-alist
1445 (list (cons realname petname)))))
1447 (defun wl-folder (&optional arg)
1450 (if (get-buffer wl-folder-buffer-name)
1451 (switch-to-buffer wl-folder-buffer-name)
1452 (switch-to-buffer (get-buffer-create wl-folder-buffer-name))
1453 (set-buffer wl-folder-buffer-name)
1457 (let ((inhibit-read-only t)
1458 (buffer-read-only nil))
1460 (setcdr (assoc (car wl-folder-entity) wl-folder-group-alist) t)
1462 (wl-folder-insert-entity " " wl-folder-entity)))
1463 (set-buffer-modified-p nil)
1464 (setq initialize t))
1467 (defun wl-folder-auto-check ()
1468 "Check and update folders in `wl-auto-check-folder-name'."
1470 (when (get-buffer wl-folder-buffer-name)
1471 (switch-to-buffer wl-folder-buffer-name)
1473 ((eq wl-auto-check-folder-name 'none))
1474 ((or (consp wl-auto-check-folder-name)
1475 (stringp wl-auto-check-folder-name))
1476 (let ((folder-list (if (consp wl-auto-check-folder-name)
1477 wl-auto-check-folder-name
1478 (list wl-auto-check-folder-name)))
1481 (if (setq entity (wl-folder-search-entity-by-name
1484 (wl-folder-check-entity entity 'auto))
1485 (setq folder-list (cdr folder-list)))))
1487 (wl-folder-check-entity wl-folder-entity 'auto)))))
1489 (defun wl-folder-set-folder-updated (name value)
1492 (if (setq buf (get-buffer wl-folder-buffer-name))
1493 (wl-folder-entity-hashtb-set
1494 wl-folder-entity-hashtb name value buf))
1495 (setq wl-folder-info-alist-modified t))))
1497 (defun wl-folder-calc-finfo (entity)
1498 ;; calcurate finfo without inserting.
1499 (let ((entities (list entity))
1501 new unread all nums)
1503 (setq entity (wl-pop entities))
1507 (wl-push entities entity-stack))
1508 (setq entities (nth 2 entity)))
1510 (setq nums (wl-folder-get-entity-info entity))
1511 (setq new (+ (or new 0) (or (nth 0 nums) 0)))
1512 (setq unread (+ (or unread 0)
1513 (or (and (nth 0 nums)(nth 1 nums)
1514 (+ (nth 0 nums)(nth 1 nums))) 0)))
1515 (setq all (+ (or all 0) (or (nth 2 nums) 0)))))
1517 (setq entities (wl-pop entity-stack))))
1518 (list new unread all)))
1520 (defsubst wl-folder-make-save-access-list (list)
1521 (mapcar '(lambda (x)
1524 (list (elmo-string (car x)) 'access))
1529 (defun wl-folder-update-newest (indent entity)
1530 (let (ret-val new unread all)
1533 (let ((inhibit-read-only t)
1534 (buffer-read-only nil)
1535 (flist (nth 2 entity))
1536 (as-opened (cdr (assoc (car entity) wl-folder-group-alist)))
1541 (let (update-flist flist-unsub new-flist removed group-name-end)
1542 (when (and (eq (cadr entity) 'access)
1543 (elmo-folder-plugged-p
1544 (wl-folder-get-elmo-folder (car entity))))
1545 (message "Fetching folder entries...")
1546 (when (setq new-flist
1547 (elmo-folder-list-subfolders
1548 (wl-folder-get-elmo-folder (car entity))
1551 wl-folder-hierarchy-access-folders)))
1553 (wl-folder-update-access-group entity new-flist))
1554 (setq flist (nth 1 update-flist))
1555 (when (car update-flist) ;; diff
1556 (setq flist-unsub (nth 2 update-flist))
1557 (setq removed (nth 3 update-flist))
1558 (elmo-msgdb-flist-save
1561 (wl-folder-make-save-access-list flist)
1562 (wl-folder-make-save-access-list flist-unsub)))
1563 (wl-folder-entity-assign-id
1565 wl-folder-entity-id-name-hashtb
1567 (setq wl-folder-entity-hashtb
1568 (wl-folder-create-entity-hashtb
1570 wl-folder-entity-hashtb
1572 (setq wl-folder-newsgroups-hashtb
1574 (wl-folder-create-newsgroups-hashtb
1576 wl-folder-newsgroups-hashtb))))
1577 (message "Fetching folder entries...done"))
1578 (wl-folder-insert-entity indent entity))))))))
1580 (defun wl-folder-insert-entity (indent entity &optional onlygroup)
1581 (let (ret-val new unread all)
1584 (let ((inhibit-read-only t)
1585 (buffer-read-only nil)
1586 (flist (nth 2 entity))
1587 (as-opened (cdr (assoc (car entity) wl-folder-group-alist)))
1590 ;;; (insert indent "[" (if as-opened "-" "+") "]" (car entity) "\n")
1591 ;;; (save-excursion (forward-line -1)
1592 ;;; (wl-highlight-folder-current-line))
1596 (let (update-flist flist-unsub new-flist removed group-name-end)
1597 ;;; (when (and (eq (cadr entity) 'access)
1599 ;;; (message "fetching folder entries...")
1600 ;;; (when (setq new-flist
1601 ;;; (elmo-list-folders
1602 ;;; (elmo-string (car entity))
1603 ;;; (wl-string-member
1605 ;;; wl-folder-hierarchy-access-folders)
1607 ;;; (setq update-flist
1608 ;;; (wl-folder-update-access-group entity new-flist))
1609 ;;; (setq flist (nth 1 update-flist))
1610 ;;; (when (car update-flist) ;; diff
1611 ;;; (setq flist-unsub (nth 2 update-flist))
1612 ;;; (setq removed (nth 3 update-flist))
1613 ;;; (elmo-msgdb-flist-save
1616 ;;; (wl-folder-make-save-access-list flist)
1617 ;;; (wl-folder-make-save-access-list flist-unsub)))
1619 ;;; ;; reconstruct wl-folder-entity-id-name-hashtb and
1620 ;;; ;; wl-folder-entity-hashtb
1622 ;;; (wl-folder-entity-assign-id
1624 ;;; wl-folder-entity-id-name-hashtb
1626 ;;; (setq wl-folder-entity-hashtb
1627 ;;; (wl-folder-create-entity-hashtb
1629 ;;; wl-folder-entity-hashtb
1631 ;;; (setq wl-folder-newsgroups-hashtb
1633 ;;; (wl-folder-create-newsgroups-hashtb
1635 ;;; wl-folder-newsgroups-hashtb))))
1636 ;;; (message "fetching folder entries...done"))
1637 (insert indent "[" (if as-opened "-" "+") "]"
1638 (wl-folder-get-petname (car entity)))
1639 (setq group-name-end (point))
1641 (put-text-property beg (point) 'wl-folder-entity-id
1642 (get-text-property 0 'wl-folder-entity-id
1648 wl-folder-removed-mark
1649 (if (listp (car removed))
1650 (concat "[+]" (caar removed))
1653 (save-excursion (forward-line -1)
1654 (wl-highlight-folder-current-line))
1655 (setq removed (cdr removed)))
1656 (remove-text-properties beg (point) '(wl-folder-entity-id)))
1657 (let* ((len (length flist))
1662 (wl-folder-insert-entity
1663 (concat indent " ") (car flist)))
1664 (setq new (+ (or new 0) (or (nth 0 ret-val) 0)))
1665 (setq unread (+ (or unread 0) (or (nth 1 ret-val) 0)))
1666 (setq all (+ (or all 0) (or (nth 2 ret-val) 0)))
1668 (> len elmo-display-progress-threshold))
1670 (elmo-display-progress
1671 'wl-folder-insert-entity "Inserting group %s..."
1672 (/ (* i 100) len) (car entity)))
1673 (setq flist (cdr flist))))
1675 (goto-char group-name-end)
1676 (delete-region (point) (save-excursion (end-of-line)
1678 (insert (format ":%d/%d/%d" (or new 0)
1679 (or unread 0) (or all 0)))
1680 (setq ret-val (list new unread all))
1681 (wl-highlight-folder-current-line ret-val)))
1682 (setq ret-val (wl-folder-calc-finfo entity))
1683 (insert indent "[" (if as-opened "-" "+") "]"
1684 (wl-folder-get-petname (car entity))
1686 (or (nth 0 ret-val) 0)
1687 (or (nth 1 ret-val) 0)
1688 (or (nth 2 ret-val) 0))
1690 (put-text-property beg (point) 'wl-folder-entity-id
1691 (get-text-property 0 'wl-folder-entity-id
1693 (save-excursion (forward-line -1)
1694 (wl-highlight-folder-current-line ret-val)))))
1696 (let* ((inhibit-read-only t)
1697 (buffer-read-only nil)
1698 (nums (wl-folder-get-entity-info entity))
1701 (insert indent (wl-folder-get-petname entity)
1702 (format ":%s/%s/%s\n"
1703 (or (setq new (nth 0 nums)) "*")
1704 (or (setq unread (and (nth 0 nums)(nth 1 nums)
1705 (+ (nth 0 nums)(nth 1 nums))))
1707 (or (setq all (nth 2 nums)) "*")))
1708 (put-text-property beg (point) 'wl-folder-entity-id
1709 (get-text-property 0 'wl-folder-entity-id entity))
1710 (save-excursion (forward-line -1)
1711 (wl-highlight-folder-current-line nums))
1712 (setq ret-val (list new unread all)))))
1713 (set-buffer-modified-p nil)
1716 (defun wl-folder-check-all ()
1718 (wl-folder-check-entity wl-folder-entity))
1720 (defun wl-folder-entity-hashtb-set (entity-hashtb name value buffer)
1727 (setq cur-val (wl-folder-get-entity-info name entity-hashtb))
1728 (setq new-diff (- (or (nth 0 value) 0) (or (nth 0 cur-val) 0)))
1731 (- (or (nth 1 value) 0) (or (nth 1 cur-val) 0))))
1732 (setq all-diff (- (or (nth 2 value) 0) (or (nth 2 cur-val) 0)))
1733 (setq diffs (list new-diff unread-diff all-diff))
1734 (unless (and (nth 0 cur-val)
1735 (equal diffs '(0 0 0)))
1736 (wl-folder-set-entity-info name value entity-hashtb)
1738 (with-current-buffer buffer
1740 (setq entity-list (wl-folder-search-entity-list-by-name
1741 name wl-folder-entity))
1743 (wl-folder-update-group (car entity-list) diffs)
1744 (setq entity-list (cdr entity-list)))
1745 (goto-char (point-min))
1746 (while (wl-folder-buffer-search-entity name)
1747 (wl-folder-update-line value))))))))
1749 (defun wl-folder-update-unread (folder unread)
1750 ; (save-window-excursion
1751 (let ((buf (get-buffer wl-folder-buffer-name))
1754 ;;(fld (elmo-string folder))
1755 value newvalue entity-list)
1756 ;;; Update folder-info
1757 ;;; (elmo-folder-set-info-hashtb fld nil nil nil unread)
1758 (setq cur-unread (or (nth 1 (wl-folder-get-entity-info folder)) 0))
1759 (setq unread-diff (- (or unread 0) cur-unread))
1760 (setq value (wl-folder-get-entity-info folder))
1761 (setq newvalue (list (nth 0 value)
1764 (wl-folder-set-entity-info folder newvalue)
1765 (setq wl-folder-info-alist-modified t)
1767 (not (eq unread-diff 0)))
1769 (with-current-buffer buf
1771 (setq entity-list (wl-folder-search-entity-list-by-name
1772 folder wl-folder-entity))
1774 (wl-folder-update-group (car entity-list) (list 0
1777 (setq entity-list (cdr entity-list)))
1778 (goto-char (point-min))
1779 (while (wl-folder-buffer-search-entity folder)
1780 (wl-folder-update-line newvalue))))))));)
1782 (defun wl-folder-create-entity-hashtb (entity &optional hashtb reconst)
1783 (let ((hashtb (or hashtb (elmo-make-hash wl-folder-entity-id)))
1784 (entities (list entity))
1787 (setq entity (wl-pop entities))
1791 (wl-push entities entity-stack))
1792 (setq entities (nth 2 entity)))
1794 (when (not (and reconst
1795 (wl-folder-get-entity-info entity)))
1796 (wl-folder-set-entity-info entity
1800 (setq entities (wl-pop entity-stack))))
1803 ;; Unsync number is reserved.
1804 ;;(defun wl-folder-reconstruct-entity-hashtb (entity &optional hashtb id-name)
1805 ;; (let* ((hashtb (or hashtb (elmo-make-hash wl-folder-entity-id)))
1806 ;; (entities (list entity))
1809 ;; (setq entity (wl-pop entities))
1813 ;; (wl-folder-set-id-name (wl-folder-get-entity-id (car entity))
1816 ;; (wl-push entities entity-stack))
1817 ;; (setq entities (nth 2 entity))
1819 ;; ((stringp entity)
1820 ;; (wl-folder-set-entity-info entity
1821 ;; (wl-folder-get-entity-info entity)
1824 ;; (wl-folder-set-id-name (wl-folder-get-entity-id entity)
1827 ;; (setq entities (wl-pop entity-stack))))
1830 (defun wl-folder-create-newsgroups-from-nntp-access (entity)
1831 (let ((flist (nth 2 entity))
1836 ((consp (car flist))
1837 (wl-folder-create-newsgroups-from-nntp-access (car flist)))
1840 (elmo-nntp-folder-group-internal
1841 (wl-folder-get-elmo-folder (car flist)))))))
1842 (setq flist (cdr flist)))
1845 (defun wl-folder-create-newsgroups-hashtb (entity &optional is-list info)
1846 "Create NNTP group hashtable for ENTITY."
1847 (let ((entities (if is-list entity (list entity)))
1848 entity-stack folder-list newsgroups newsgroup make-hashtb)
1849 (and info (message "Creating newsgroups..."))
1851 (setq entity (wl-pop entities))
1854 (if (eq (nth 1 entity) 'access)
1855 (when (eq (elmo-folder-type-internal
1856 (elmo-make-folder (car entity))) 'nntp)
1857 (wl-append newsgroups
1858 (wl-folder-create-newsgroups-from-nntp-access entity))
1859 (setq make-hashtb t))
1861 (wl-push entities entity-stack))
1862 (setq entities (nth 2 entity))))
1864 (setq folder-list (elmo-folder-get-primitive-list
1865 (elmo-make-folder entity)))
1867 (when (and (eq (elmo-folder-type-internal (car folder-list))
1869 (setq newsgroup (elmo-nntp-folder-group-internal
1870 (car folder-list))))
1871 (wl-append newsgroups (list (elmo-string newsgroup))))
1872 (setq folder-list (cdr folder-list)))))
1874 (setq entities (wl-pop entity-stack))))
1875 (and info (message "Creating newsgroups...done"))
1876 (if (or newsgroups make-hashtb)
1877 (elmo-setup-subscribed-newsgroups newsgroups))))
1879 (defun wl-folder-get-path (entity target-id &optional string)
1880 (let ((entities (list entity))
1881 entity-stack result-path)
1885 (setq entity (wl-pop entities))
1888 (if (and (or (not string) (string= string (car entity)))
1889 ;; don't use eq, `id' is string on Nemacs.
1890 (equal target-id (wl-folder-get-entity-id (car entity))))
1892 (wl-push target-id result-path))
1893 (wl-push (wl-folder-get-entity-id (car entity)) result-path))
1894 (wl-push entities entity-stack)
1895 (setq entities (nth 2 entity)))
1897 (if (and (or (not string) (string= string entity))
1898 ;; don't use eq, `id' is string on Nemacs.
1899 (equal target-id (wl-folder-get-entity-id entity)))
1901 (wl-push target-id result-path)))))
1903 (while (and entity-stack
1905 (setq result-path (cdr result-path))
1906 (setq entities (wl-pop entity-stack)))))))))
1908 (defun wl-folder-create-group-alist (entity)
1910 (let ((flist (nth 2 entity))
1911 (cur-alist (list (cons (car entity) nil)))
1914 (if (consp (car flist))
1915 (wl-append append-alist
1916 (wl-folder-create-group-alist (car flist))))
1917 (setq flist (cdr flist)))
1918 (append cur-alist append-alist))))
1920 (defun wl-folder-init-info-hashtb ()
1921 (let ((info-alist (and wl-folder-info-save
1922 (elmo-msgdb-finfo-load))))
1923 (elmo-folder-info-make-hashtb
1925 wl-folder-entity-hashtb)))
1926 ;;; (wl-folder-resume-entity-hashtb-by-finfo
1927 ;;; wl-folder-entity-hashtb
1930 (defun wl-folder-cleanup-variables ()
1931 (setq wl-folder-entity nil
1932 wl-folder-entity-hashtb nil
1933 wl-folder-entity-id-name-hashtb nil
1934 wl-folder-group-alist nil
1935 wl-folder-petname-alist nil
1936 wl-folder-newsgroups-hashtb nil
1937 wl-fldmgr-cut-entity-list nil
1938 wl-fldmgr-modified nil
1939 wl-fldmgr-modified-access-list nil
1943 (defun wl-make-plugged-alist ()
1944 (let ((entity-list (wl-folder-get-entity-list wl-folder-entity))
1945 (add (not wl-reset-plugged-alist)))
1947 (elmo-folder-set-plugged
1948 (wl-folder-get-elmo-folder (car entity-list)) wl-plugged add)
1949 (setq entity-list (cdr entity-list)))
1950 ;; smtp posting server
1951 (when wl-smtp-posting-server
1952 (elmo-set-plugged wl-plugged
1953 wl-smtp-posting-server ; server
1954 (or (and (boundp 'smtp-service) smtp-service)
1956 wl-smtp-connection-type
1957 nil nil "smtp" add))
1958 ;; nntp posting server
1959 (when wl-nntp-posting-server
1960 (elmo-set-plugged wl-plugged
1961 wl-nntp-posting-server
1962 wl-nntp-posting-stream-type
1963 wl-nntp-posting-port
1964 nil nil "nntp" add))
1965 (run-hooks 'wl-make-plugged-hook)))
1967 (defvar wl-folder-init-function 'wl-local-folder-init)
1969 (defun wl-folder-init ()
1970 "Call `wl-folder-init-function' function."
1972 (funcall wl-folder-init-function))
1974 (defun wl-local-folder-init ()
1975 "Initialize local folder."
1976 (message "Initializing folder...")
1978 (set-buffer wl-folder-buffer-name)
1979 (let ((entity (wl-folder-create-folder-entity))
1980 (inhibit-read-only t))
1981 (setq wl-folder-entity entity)
1982 (setq wl-folder-entity-id 0)
1983 (wl-folder-entity-assign-id wl-folder-entity)
1984 (setq wl-folder-entity-hashtb
1985 (wl-folder-create-entity-hashtb entity))
1986 (setq wl-folder-elmo-folder-hashtb (elmo-make-hash wl-folder-entity-id))
1987 (setq wl-folder-group-alist
1988 (wl-folder-create-group-alist entity))
1989 (setq wl-folder-newsgroups-hashtb
1990 (wl-folder-create-newsgroups-hashtb wl-folder-entity))
1991 (wl-folder-init-info-hashtb)))
1992 (message "Initializing folder...done"))
1994 (defun wl-folder-get-realname (petname)
1998 wl-folder-petname-alist))
2001 (defun wl-folder-get-petname (name)
2005 wl-folder-petname-alist))
2008 (defun wl-folder-get-entity-with-petname ()
2009 (let ((alist wl-folder-petname-alist)
2010 (hashtb (copy-sequence wl-folder-entity-hashtb)))
2012 (wl-folder-set-entity-info (cdar alist) nil hashtb)
2013 (setq alist (cdr alist)))
2016 (defun wl-folder-get-newsgroups (folder)
2017 "Return Newsgroups field value string for FOLDER newsgroup.
2018 If FOLDER is multi, return comma separated string (cross post)."
2019 (let ((flist (elmo-folder-get-primitive-list
2020 (wl-folder-get-elmo-folder folder))) ; multi
2022 (while (setq fld (car flist))
2024 (cond ((eq 'nntp (elmo-folder-type-internal fld))
2025 (elmo-nntp-folder-group-internal fld))
2026 ((eq 'localnews (elmo-folder-type-internal fld))
2027 (elmo-replace-in-string
2028 (elmo-nntp-folder-group-internal fld)
2031 (setq newsgroups (if (stringp newsgroups)
2032 (concat newsgroups "," ret)
2034 (setq flist (cdr flist)))
2035 (list nil nil newsgroups)))
2037 (defun wl-folder-guess-mailing-list-by-refile-rule (folder)
2038 "Return ML address guess by FOLDER.
2039 Use `wl-subscribed-mailing-list' and `wl-refile-rule-alist'.
2042 (elmo-folder-get-primitive-list
2043 (wl-folder-get-elmo-folder folder))))
2044 (unless (memq (elmo-folder-type-internal folder)
2046 (let ((rules wl-refile-rule-alist)
2047 mladdress tokey toalist histkey)
2049 (if (or (and (stringp (car (car rules)))
2050 (string-match "[Tt]o" (car (car rules))))
2051 (and (listp (car (car rules)))
2052 (elmo-string-matched-member "to" (car (car rules))
2054 (setq toalist (append toalist (cdr (car rules)))))
2055 (setq rules (cdr rules)))
2056 (setq tokey (car (rassoc folder toalist)))
2057 ;;; (setq histkey (car (rassoc folder wl-refile-alist)))
2058 ;; case-ignore search `wl-subscribed-mailing-list'
2061 (elmo-string-matched-member tokey wl-subscribed-mailing-list t)
2065 (defun wl-folder-guess-mailing-list-by-folder-name (folder)
2066 "Return ML address guess by FOLDER name's last hierarchy.
2067 Use `wl-subscribed-mailing-list'."
2068 ;; Don't care multi folder. FIX ME
2069 (setq folder (car (elmo-folder-get-primitive-list
2070 (wl-folder-get-elmo-folder folder))))
2071 (when (memq (elmo-folder-type-internal folder)
2072 '(localdir imap4 maildir))
2073 (let (key mladdress foldername)
2074 ;; Get foldername and Remove folder type symbol.
2075 (setq foldername (substring (elmo-folder-name-internal folder) 1))
2076 (when (string-match "[^\\./]+$" foldername)
2077 (setq key (regexp-quote
2078 (concat (substring foldername (match-beginning 0)) "@")))
2080 (elmo-string-matched-member
2081 key wl-subscribed-mailing-list 'case-ignore))
2082 (if (stringp mladdress)
2083 (list mladdress nil nil)
2086 (defun wl-folder-update-diff-line (diffs)
2087 (let ((inhibit-read-only t)
2088 (buffer-read-only nil)
2090 cur-unread new-unread
2095 (setq id (get-text-property (point) 'wl-folder-entity-id))
2096 (when (looking-at "^[ ]*\\(.*\\):\\([0-9\\*-]*\\)/\\([0-9\\*-]*\\)/\\([0-9\\*]*\\)")
2097 ;;(looking-at "^[ ]*\\([^\\[].+\\):\\([0-9\\*-]*/[0-9\\*-]*/[0-9\\*]*\\)")
2098 (setq cur-new (string-to-int
2099 (wl-match-buffer 2)))
2100 (setq cur-unread (string-to-int
2101 (wl-match-buffer 3)))
2102 (setq cur-all (string-to-int
2103 (wl-match-buffer 4)))
2104 (delete-region (match-beginning 2)
2106 (goto-char (match-beginning 2))
2107 (insert (format "%s/%s/%s"
2108 (setq new-new (+ cur-new (nth 0 diffs)))
2109 (setq new-unread (+ cur-unread (nth 1 diffs)))
2110 (setq new-all (+ cur-all (nth 2 diffs)))))
2111 (put-text-property (match-beginning 2) (point)
2112 'wl-folder-entity-id id)
2113 (if wl-use-highlight-mouse-line
2114 (put-text-property (match-beginning 2) (point)
2115 'mouse-face 'highlight))
2116 (wl-highlight-folder-group-line (list new-new new-unread new-all))
2117 (setq buffer-read-only t)
2118 (set-buffer-modified-p nil)))))
2120 (defun wl-folder-update-line (nums &optional is-group)
2121 (let ((inhibit-read-only t)
2122 (buffer-read-only nil)
2126 (setq id (get-text-property (point) 'wl-folder-entity-id))
2127 (if (looking-at "^[ ]*\\(.*\\):\\([0-9\\*-]*/[0-9\\*-]*/[0-9\\*]*\\)")
2128 ;;; (looking-at "^[ ]*\\([^\\[].+\\):\\([0-9\\*-]*/[0-9\\*-]*/[0-9\\*]*\\)")
2130 (delete-region (match-beginning 2)
2132 (goto-char (match-beginning 2))
2133 (insert (format "%s/%s/%s"
2134 (or (nth 0 nums) "*")
2135 (or (and (nth 0 nums)(nth 1 nums)
2136 (+ (nth 0 nums)(nth 1 nums)))
2138 (or (nth 2 nums) "*")))
2139 (put-text-property (match-beginning 2) (point)
2140 'wl-folder-entity-id id)
2142 ;; update only colors
2143 (wl-highlight-folder-group-line nums)
2144 (wl-highlight-folder-current-line nums))
2146 (set-buffer-modified-p nil))))))
2148 (defun wl-folder-goto-folder (&optional arg)
2150 (wl-folder-goto-folder-subr nil arg))
2152 (defun wl-folder-goto-folder-subr (&optional folder sticky)
2154 (let (summary-buf fld-name entity id error-selecting)
2155 ;;; (setq fld-name (wl-folder-get-entity-from-buffer))
2156 ;;; (if (or (null fld-name)
2157 ;;; (assoc fld-name wl-folder-group-alist))
2158 (setq fld-name wl-default-folder)
2159 (setq fld-name (or folder
2160 (wl-summary-read-folder fld-name)))
2161 (if (and (setq entity
2162 (wl-folder-search-entity-by-name fld-name
2165 (setq id (wl-folder-get-entity-id entity)))
2166 (wl-folder-set-current-entity-id id))
2167 (setq summary-buf (wl-summary-get-buffer-create fld-name sticky))
2168 (if wl-stay-folder-window
2169 (wl-folder-select-buffer summary-buf)
2170 (if (and summary-buf
2171 (get-buffer-window summary-buf))
2173 (wl-summary-goto-folder-subr fld-name
2174 (wl-summary-get-sync-range
2175 (wl-folder-get-elmo-folder fld-name))
2178 (defun wl-folder-suspend ()
2180 (run-hooks 'wl-folder-suspend-hook)
2181 (wl-folder-info-save)
2182 (elmo-crosspost-message-alist-save)
2184 ;(if (fboundp 'mmelmo-cleanup-entity-buffers)
2185 ;(mmelmo-cleanup-entity-buffers))
2186 (bury-buffer wl-folder-buffer-name)
2187 (delete-windows-on wl-folder-buffer-name t))
2189 (defun wl-folder-info-save ()
2190 (when (and wl-folder-info-save
2191 wl-folder-info-alist-modified)
2192 (let ((entities (list wl-folder-entity))
2193 entity entity-stack info-alist info)
2195 (setq entity (wl-pop entities))
2199 (wl-push entities entity-stack))
2200 (setq entities (nth 2 entity)))
2202 (when (and (setq info (elmo-folder-get-info
2203 (wl-folder-get-elmo-folder entity)))
2204 (not (equal info '(nil))))
2206 (wl-append info-alist (list (list (elmo-string entity)
2207 (list (nth 3 info) ;; max
2208 (nth 2 info) ;; length
2210 (nth 1 info)) ;; unread
2213 (setq entities (wl-pop entity-stack))))
2214 (elmo-msgdb-finfo-save info-alist)
2215 (setq wl-folder-info-alist-modified nil))))
2217 (defun wl-folder-goto-first-unread-folder (&optional arg)
2219 (let ((entities (list wl-folder-entity))
2220 entity entity-stack ret-val
2225 (setq entity (wl-pop entities))
2229 (wl-push entities entity-stack))
2230 (setq entities (nth 2 entity)))
2232 (if (and (setq finfo (wl-folder-get-entity-info entity))
2233 (and (nth 0 finfo)(nth 1 finfo))
2234 (> (+ (nth 0 finfo)(nth 1 finfo)) 0))
2235 (throw 'done entity))
2236 (wl-append ret-val (list entity))))
2238 (setq entities (wl-pop entity-stack))))))
2242 (wl-folder-jump-folder first-entity)
2244 (wl-folder-goto-folder-subr first-entity))
2245 (message "No unread folder"))))
2247 (defun wl-folder-jump-folder (&optional fld-name noopen)
2250 (setq fld-name (wl-summary-read-folder wl-default-folder)))
2251 (goto-char (point-min))
2253 (wl-folder-open-folder fld-name))
2254 (and (wl-folder-buffer-search-entity fld-name)
2255 (beginning-of-line)))
2257 (defun wl-folder-get-entity-list (entity)
2258 (let ((entities (list entity))
2259 entity-stack ret-val)
2261 (setq entity (wl-pop entities))
2265 (wl-push entities entity-stack))
2266 (setq entities (nth 2 entity)))
2268 (wl-append ret-val (list entity))))
2270 (setq entities (wl-pop entity-stack))))
2273 (defun wl-folder-open-unread-folder (entity)
2275 (let ((alist (wl-folder-get-entity-list entity))
2277 finfo path-list path id)
2279 (when (and (setq finfo (wl-folder-get-entity-info (car alist)))
2280 (nth 0 finfo) (nth 1 finfo)
2281 (> (+ (nth 0 finfo)(nth 1 finfo)) 0))
2282 (setq unread (+ unread (+ (nth 0 finfo)(nth 1 finfo))))
2283 (setq id (wl-folder-get-entity-id (car alist)))
2284 (setq path (delete id (wl-folder-get-path
2288 (if (not (member path path-list))
2289 (wl-append path-list (list path))))
2290 (setq alist (cdr alist)))
2292 (wl-folder-open-folder-sub (car path-list))
2293 (setq path-list (cdr path-list)))
2294 (message "%s unread folder"
2295 (if (> unread 0) unread "No")))))
2297 (defun wl-folder-open-unread-current-entity ()
2299 (let ((entity-name (wl-folder-get-entity-from-buffer))
2300 (group (wl-folder-buffer-group-p)))
2302 (wl-folder-open-unread-folder
2304 (wl-folder-search-group-entity-by-name entity-name
2308 (defun wl-folder-open-only-unread-folder ()
2311 (wl-folder-prev-entity-skip-invalid t)
2312 (wl-folder-get-entity-from-buffer t))))
2313 (wl-folder-open-all-unread-folder)
2315 (goto-char (point-max))
2316 (while (and (re-search-backward
2317 "^[ ]*\\[[-]\\].+:0/0/[0-9-]+" nil t)
2319 (wl-folder-jump-to-current-entity) ;; close it
2321 (wl-folder-move-path id)
2324 (defun wl-folder-open-all-unread-folder (&optional arg)
2327 (wl-folder-prev-entity-skip-invalid t)
2328 (wl-folder-get-entity-from-buffer t))))
2329 (wl-folder-open-unread-folder wl-folder-entity)
2331 (wl-folder-move-path id)
2332 (goto-char (point-min))
2333 (wl-folder-next-unread t))))
2335 (defun wl-folder-open-folder (&optional fld-name)
2338 (setq fld-name (wl-summary-read-folder wl-default-folder)))
2339 (let* ((id (wl-folder-get-entity-id
2340 (wl-folder-search-entity-by-name fld-name wl-folder-entity
2342 (path (and id (wl-folder-get-path wl-folder-entity id))))
2344 (wl-folder-open-folder-sub path))))
2346 (defun wl-folder-open-folder-sub (path)
2347 (let ((inhibit-read-only t)
2348 (buffer-read-only nil)
2352 (goto-char (point-min))
2354 (wl-folder-buffer-search-group
2355 (wl-folder-get-petname
2356 (if (stringp (car path))
2358 (wl-folder-get-folder-name-by-id
2361 (setq path (cdr path))
2362 (if (and (looking-at wl-folder-group-regexp)
2363 (string= "+" (wl-match-buffer 2)));; closed group
2365 (setq indent (wl-match-buffer 1))
2366 (setq name (wl-folder-get-realname (wl-match-buffer 3)))
2367 (setq entity (wl-folder-search-group-entity-by-name
2371 (setcdr (assoc (car entity) wl-folder-group-alist) t)
2372 (if (eq 'access (cadr entity))
2373 (wl-folder-maybe-load-folder-list entity))
2374 (wl-folder-insert-entity indent entity)
2375 (delete-region (save-excursion (beginning-of-line)
2377 (save-excursion (end-of-line)
2379 (set-buffer-modified-p nil))))
2381 (defun wl-folder-open-all-pre ()
2382 (let ((entities (list wl-folder-entity))
2383 entity entity-stack group-entry)
2385 (setq entity (wl-pop entities))
2388 (unless (or (not (setq group-entry
2389 (assoc (car entity) wl-folder-group-alist)))
2391 (setcdr group-entry t)
2392 (when (eq 'access (cadr entity))
2393 (wl-folder-maybe-load-folder-list entity)))
2395 (wl-push entities entity-stack))
2396 (setq entities (nth 2 entity))))
2398 (setq entities (wl-pop entity-stack))))))
2400 (defun wl-folder-open-all (&optional refresh)
2402 (let* ((inhibit-read-only t)
2403 (buffer-read-only nil)
2404 (len (length wl-folder-group-alist))
2409 (wl-folder-prev-entity-skip-invalid t)
2410 (wl-folder-get-entity-from-buffer t)))
2411 (alist wl-folder-group-alist))
2413 (setcdr (pop alist) t))
2415 (wl-folder-insert-entity " " wl-folder-entity)
2416 (wl-folder-move-path id))
2417 (message "Opening all folders...")
2418 (wl-folder-open-all-pre)
2420 (goto-char (point-min))
2421 (while (re-search-forward
2422 "^\\([ ]*\\)\\[\\([+]\\)\\]\\(.+\\):[-0-9-]+/[0-9-]+/[0-9-]+\n"
2424 (setq indent (wl-match-buffer 1))
2425 (setq name (wl-folder-get-realname (wl-match-buffer 3)))
2426 (setq entity (wl-folder-search-group-entity-by-name
2430 (setcdr (assoc (car entity) wl-folder-group-alist) t)
2432 (wl-folder-insert-entity indent entity)
2433 (delete-region (save-excursion (beginning-of-line)
2435 (save-excursion (end-of-line)
2437 (when (> len elmo-display-progress-threshold)
2439 (if (or (zerop (% i 5)) (= i len))
2440 (elmo-display-progress
2441 'wl-folder-open-all "Opening all folders..."
2442 (/ (* i 100) len)))))
2443 (when (> len elmo-display-progress-threshold)
2444 (elmo-display-progress
2445 'wl-folder-open-all "Opening all folders..." 100))))
2446 (message "Opening all folders...done")
2447 (set-buffer-modified-p nil)))
2449 (defun wl-folder-close-all ()
2451 (let ((inhibit-read-only t)
2452 (buffer-read-only nil)
2453 (alist wl-folder-group-alist)
2455 (wl-folder-prev-entity-skip-invalid t)
2456 (wl-folder-get-entity-from-buffer t))))
2458 (setcdr (car alist) nil)
2459 (setq alist (cdr alist)))
2460 (setcdr (assoc (car wl-folder-entity) wl-folder-group-alist) t)
2462 (wl-folder-insert-entity " " wl-folder-entity)
2463 (wl-folder-move-path id)
2465 (set-buffer-modified-p nil)))
2467 (defun wl-folder-open-close ()
2468 "Open or close parent entity."
2472 (if (wl-folder-buffer-group-p)
2473 ;; if group (whether opend or closed.)
2474 (wl-folder-jump-to-current-entity)
2477 (setq indent (save-excursion
2478 (re-search-forward "\\([ ]*\\)." nil t)
2479 (wl-match-buffer 1)))
2480 (while (looking-at indent)
2482 (wl-folder-jump-to-current-entity))))
2484 (defsubst wl-folder-access-subscribe-p (group folder)
2485 (let (subscr regexp match)
2486 (if (setq subscr (wl-get-assoc-list-value
2487 wl-folder-access-subscribe-alist
2490 (setq regexp (mapconcat 'identity (cdr subscr) "\\|"))
2491 (setq match (string-match regexp folder))
2497 (defun wl-folder-update-access-group (entity new-flist)
2498 (let* ((flist (nth 2 entity))
2499 (unsubscribes (nth 3 entity))
2500 (len (+ (length flist) (length unsubscribes)))
2502 diff new-unsubscribes removes
2503 subscribed-list folder group entry)
2504 ;; check subscribed groups
2507 ((listp (car flist)) ;; group
2508 (setq group (elmo-string (caar flist)))
2510 ((assoc group new-flist) ;; found in new-flist
2511 (setq new-flist (delete (assoc group new-flist)
2513 (if (wl-folder-access-subscribe-p (car entity) group)
2514 (wl-append subscribed-list (list (car flist)))
2515 (wl-append new-unsubscribes (list (car flist)))
2518 (setq wl-folder-group-alist
2519 (delete (wl-string-assoc group wl-folder-group-alist)
2520 wl-folder-group-alist))
2521 (wl-append removes (list (list group))))))
2523 (setq folder (elmo-string (car flist)))
2525 ((member folder new-flist) ;; found in new-flist
2526 (setq new-flist (delete folder new-flist))
2527 (if (wl-folder-access-subscribe-p (car entity) folder)
2528 (wl-append subscribed-list (list (car flist)))
2529 (wl-append new-unsubscribes (list folder))
2532 (wl-append removes (list folder))))))
2533 (when (> len elmo-display-progress-threshold)
2535 (if (or (zerop (% i 10)) (= i len))
2536 (elmo-display-progress
2537 'wl-folder-update-access-group "Updating access group..."
2538 (/ (* i 100) len))))
2539 (setq flist (cdr flist)))
2540 ;; check unsubscribed groups
2543 ((listp (car unsubscribes))
2544 (when (setq entry (assoc (caar unsubscribes) new-flist))
2545 (setq new-flist (delete entry new-flist))
2546 (wl-append new-unsubscribes (list (car unsubscribes)))))
2548 (when (member (car unsubscribes) new-flist)
2549 (setq new-flist (delete (car unsubscribes) new-flist))
2550 (wl-append new-unsubscribes (list (car unsubscribes))))))
2551 (when (> len elmo-display-progress-threshold)
2553 (if (or (zerop (% i 10)) (= i len))
2554 (elmo-display-progress
2555 'wl-folder-update-access-group "Updating access group..."
2556 (/ (* i 100) len))))
2557 (setq unsubscribes (cdr unsubscribes)))
2559 (if (or new-flist removes)
2562 (mapcar '(lambda (x)
2563 (cond ((consp x) (list (car x) 'access))
2567 (let ((new-list new-flist))
2569 (if (not (wl-folder-access-subscribe-p
2571 (if (listp (car new-list))
2576 (wl-append new-unsubscribes (list (car new-list)))
2577 (setq new-flist (delete (car new-list) new-flist)))
2579 ((listp (car new-list))
2580 ;; check group exists
2581 (if (wl-string-assoc (caar new-list) wl-folder-group-alist)
2583 (message "%s: group already exists." (caar new-list))
2585 (wl-append new-unsubscribes (list (car new-list)))
2586 (setq new-flist (delete (car new-list) new-flist)))
2587 (wl-append wl-folder-group-alist
2588 (list (cons (caar new-list) nil)))))))
2589 (setq new-list (cdr new-list))))
2591 (message "%d new folder(s)." (length new-flist))
2592 (message "Updating access group...done"))
2593 (wl-append new-flist subscribed-list) ;; new is first
2594 (run-hooks 'wl-folder-update-access-group-hook)
2595 (setcdr (cdr entity) (list new-flist new-unsubscribes))
2596 (list diff new-flist new-unsubscribes removes)))
2598 (defun wl-folder-prefetch-entity (entity)
2599 "Prefetch all new messages in the ENTITY."
2602 (let ((flist (nth 2 entity))
2607 (setq result (wl-folder-prefetch-entity (car flist)))
2608 (setq sum-done (+ sum-done (car result)))
2609 (setq sum-all (+ sum-all (cdr result)))
2610 (setq flist (cdr flist)))
2611 (message "Prefetched %d/%d message(s) in \"%s\"."
2613 (wl-folder-get-petname (car entity)))
2614 (cons sum-done sum-all)))
2616 (let ((nums (wl-folder-get-entity-info entity))
2617 (wl-summary-highlight (if (or (wl-summary-sticky-p entity)
2618 (wl-summary-always-sticky-folder-p
2620 wl-summary-highlight))
2621 wl-summary-exit-next-move
2622 wl-auto-select-first ret-val
2624 (setq count (or (car nums) 0))
2625 (setq count (+ count (wl-folder-count-incorporates entity)))
2626 (if (or (null (car nums)) ; unknown
2628 (save-window-excursion
2630 (let ((wl-summary-buffer-name (concat
2631 wl-summary-buffer-name
2632 (symbol-name this-command))))
2633 (wl-summary-goto-folder-subr entity
2634 (wl-summary-get-sync-range entity)
2636 (setq ret-val (wl-summary-incorporate))
2641 (defun wl-folder-count-incorporates (folder)
2642 (let ((marks (elmo-msgdb-mark-load
2643 (elmo-folder-msgdb-path
2644 (wl-folder-get-elmo-folder folder))))
2647 (if (member (cadr (car marks))
2648 wl-summary-incorporate-marks)
2650 (setq marks (cdr marks)))
2653 (defun wl-folder-prefetch-current-entity (&optional no-check)
2654 "Prefetch all uncached messages in the folder at position.
2655 If current line is group folder, all subfolders are prefetched."
2658 (let ((entity-name (wl-folder-get-entity-from-buffer))
2659 (group (wl-folder-buffer-group-p))
2660 wl-folder-check-entity-hook
2665 (wl-folder-search-group-entity-by-name entity-name
2669 (wl-folder-check-entity entity))
2670 (wl-folder-prefetch-entity entity)))))
2672 ;(defun wl-folder-drop-unsync-entity (entity)
2673 ; "Drop all unsync messages in the ENTITY."
2676 ; (let ((flist (nth 2 entity)))
2678 ; (wl-folder-drop-unsync-entity (car flist))
2679 ; (setq flist (cdr flist)))))
2681 ; (let ((nums (wl-folder-get-entity-info entity))
2682 ; wl-summary-highlight wl-auto-select-first new)
2683 ; (setq new (or (car nums) 0))
2685 ; (save-window-excursion
2687 ; (let ((wl-summary-buffer-name (concat
2688 ; wl-summary-buffer-name
2689 ; (symbol-name this-command))))
2690 ; (wl-summary-goto-folder-subr entity 'no-sync nil)
2691 ; (wl-summary-drop-unsync)
2692 ; (wl-summary-exit)))))))))
2694 ;(defun wl-folder-drop-unsync-current-entity (&optional force-check)
2695 ; "Drop all unsync messages in the folder at position.
2696 ;If current line is group folder, all subfolders are dropped.
2697 ;If optional arg exists, don't check any folders."
2700 ; (let ((entity-name (wl-folder-get-entity-from-buffer))
2701 ; (group (wl-folder-buffer-group-p))
2702 ; wl-folder-check-entity-hook
2703 ; summary-buf entity)
2704 ; (when (and entity-name
2706 ; "Drop all unsync messages in %s?" entity-name)))
2709 ; (wl-folder-search-group-entity-by-name entity-name
2712 ; (if (null force-check)
2713 ; (wl-folder-check-entity entity))
2714 ; (wl-folder-drop-unsync-entity entity)
2715 ; (message "All unsync messages in %s are dropped!" entity-name)))))
2717 (defun wl-folder-write-current-folder ()
2718 "Write message to current folder's newsgroup or mailing-list.
2719 Call `wl-summary-write-current-folder' with current folder name."
2721 (unless (wl-folder-buffer-group-p)
2722 (wl-summary-write-current-folder
2723 (wl-folder-get-realname (wl-folder-entity-name)))))
2725 (defun wl-folder-mimic-kill-buffer ()
2726 "Kill the current (Folder) buffer with query."
2728 (let ((bufname (read-buffer (format "Kill buffer: (default %s) "
2730 wl-interactive-exit)
2731 (if (or (not bufname)
2732 (string-equal bufname "")
2733 (string-equal bufname (buffer-name)))
2735 (kill-buffer bufname))))
2737 (defun wl-folder-create-subr (folder)
2738 (if (not (elmo-folder-creatable-p folder))
2739 (error "Folder %s is not found" (elmo-folder-name-internal folder))
2741 (format "Folder %s does not exist, create it?"
2742 (elmo-folder-name-internal folder)))
2744 (setq wl-folder-entity-hashtb
2745 (wl-folder-create-entity-hashtb
2746 (elmo-folder-name-internal folder)
2747 wl-folder-entity-hashtb))
2748 (unless (elmo-folder-create folder)
2749 (error "Create folder failed")))
2750 (error "Folder %s is not created" (elmo-folder-name-internal folder)))))
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 (elmo-folder-name-internal folder))
2757 (file-exists-p (elmo-folder-msgdb-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