1 ;;; wl-folder.el --- Folder mode for Wanderlust.
3 ;; Copyright (C) 1998,1999,2000 Yuuichi Teranishi <teranisi@gohome.org>
4 ;; Copyright (C) 1998,1999,2000 Masahiro MURATA <muse@ba2.so-net.ne.jp>
6 ;; Author: Yuuichi Teranishi <teranisi@gohome.org>
7 ;; Masahiro MURATA <muse@ba2.so-net.ne.jp>
8 ;; Keywords: mail, net news
10 ;; This file is part of Wanderlust (Yet Another Message Interface on Emacsen).
12 ;; This program is free software; you can redistribute it and/or modify
13 ;; it under the terms of the GNU General Public License as published by
14 ;; the Free Software Foundation; either version 2, or (at your option)
17 ;; This program is distributed in the hope that it will be useful,
18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
20 ;; GNU General Public License for more details.
22 ;; You should have received a copy of the GNU General Public License
23 ;; along with GNU Emacs; see the file COPYING. If not, write to the
24 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
25 ;; Boston, MA 02111-1307, USA.
39 (require 'easymenu) ; needed here.
49 (defcustom wl-folder-init-hook nil
50 "A hook called after folder initialization is finished."
54 (defvar wl-folder-buffer-name "Folder")
55 (defvar wl-folder-entity nil) ; desktop entity.
56 (defvar wl-folder-group-alist nil) ; opened or closed
57 (defvar wl-folder-entity-id nil) ; id
58 (defvar wl-folder-entity-hashtb nil)
59 (defvar wl-folder-entity-id-name-hashtb nil)
60 (defvar wl-folder-elmo-folder-hashtb nil) ; name => elmo folder structure
62 (defvar wl-folder-newsgroups-hashtb nil)
63 (defvar wl-folder-info-alist-modified nil)
64 (defvar wl-folder-completion-function nil)
66 (defvar wl-folder-mode-map nil)
68 (defvar wl-folder-buffer-disp-summary nil)
69 (defvar wl-folder-buffer-cur-entity-id nil)
70 (defvar wl-folder-buffer-cur-path nil)
71 (defvar wl-folder-buffer-cur-point nil)
73 (make-variable-buffer-local 'wl-folder-buffer-disp-summary)
74 (make-variable-buffer-local 'wl-folder-buffer-cur-entity-id)
75 (make-variable-buffer-local 'wl-folder-buffer-cur-path)
76 (make-variable-buffer-local 'wl-folder-buffer-cur-point)
78 (defconst wl-folder-entity-regexp "^\\([ ]*\\)\\(\\[[\\+-]\\]\\)?\\([^\\[].+\\):[-*0-9]+/[-*0-9]+/[-*0-9]+")
79 (defconst wl-folder-group-regexp "^\\([ ]*\\)\\[\\([\\+-]\\)\\]\\(.+\\):[-0-9-]+/[0-9-]+/[0-9-]+\n")
80 ;; 1:indent 2:opened 3:group-name
81 (defconst wl-folder-unsync-regexp ":[^0\\*][0-9]*/[0-9\\*-]+/[0-9\\*-]+$")
83 (defvar wl-folder-mode-menu-spec
85 ["Enter Current Folder" wl-folder-jump-to-current-entity t]
86 ["Prev Folder" wl-folder-prev-entity t]
87 ["Next Folder" wl-folder-next-entity t]
88 ["Check Current Folder" wl-folder-check-current-entity t]
89 ["Sync Current Folder" wl-folder-sync-current-entity t]
90 ; ["Drop Current Folder" wl-folder-drop-unsync-current-entity t]
91 ["Prefetch Current Folder" wl-folder-prefetch-current-entity t]
92 ["Mark as Read all Current Folder" wl-folder-mark-as-read-all-current-entity t]
93 ["Expire Current Folder" wl-folder-expire-current-entity t]
94 ["Empty trash" wl-folder-empty-trash t]
95 ["Flush queue" wl-folder-flush-queue t]
96 ["Open All" wl-folder-open-all t]
97 ["Open All Unread folder" wl-folder-open-all-unread-folder t]
98 ["Close All" wl-folder-close-all t]
100 ["Add folder" wl-fldmgr-add t]
101 ["Add group" wl-fldmgr-make-group t]
102 ["Copy" wl-fldmgr-copy t]
103 ["Cut" wl-fldmgr-cut t]
104 ["Paste" wl-fldmgr-yank t]
105 ["Set petname" wl-fldmgr-set-petname t]
106 ["Rename" wl-fldmgr-rename t]
107 ["Save" wl-fldmgr-save-folders t]
109 ["Unsubscribe" wl-fldmgr-unsubscribe t]
110 ["Display all" wl-fldmgr-access-display-all t])
112 ["Write a message" wl-draft t]
114 ["Toggle Plug Status" wl-toggle-plugged t]
115 ["Change Plug Status" wl-plugged-change t]
117 ["Save Current Status" wl-save t]
118 ["Update Satus" wl-status-update t]
123 (defun wl-folder-setup-mouse ()
124 (define-key wl-folder-mode-map 'button2 'wl-folder-click)
125 (define-key wl-folder-mode-map 'button4 'wl-folder-prev-entity)
126 (define-key wl-folder-mode-map 'button5 'wl-folder-next-entity)
127 (define-key wl-folder-mode-map [(shift button4)]
128 'wl-folder-prev-unread)
129 (define-key wl-folder-mode-map [(shift button5)]
130 'wl-folder-next-unread))
131 (defun wl-folder-setup-mouse ()
132 (define-key wl-folder-mode-map [mouse-2] 'wl-folder-click)
133 (define-key wl-folder-mode-map [mouse-4] 'wl-folder-prev-entity)
134 (define-key wl-folder-mode-map [mouse-5] 'wl-folder-next-entity)
135 (define-key wl-folder-mode-map [S-mouse-4] 'wl-folder-prev-unread)
136 (define-key wl-folder-mode-map [S-mouse-5] 'wl-folder-next-unread)))
138 (if wl-folder-mode-map
140 (setq wl-folder-mode-map (make-sparse-keymap))
141 (define-key wl-folder-mode-map " " 'wl-folder-jump-to-current-entity)
142 ; (define-key wl-folder-mode-map "\M- " 'wl-folder-open-close)
143 (define-key wl-folder-mode-map "/" 'wl-folder-open-close)
144 (define-key wl-folder-mode-map "\C-m" 'wl-folder-jump-to-current-entity)
145 (define-key wl-folder-mode-map "\M-\C-m" 'wl-folder-update-recursive-current-entity)
146 (define-key wl-folder-mode-map "rc" 'wl-folder-mark-as-read-all-region)
147 (define-key wl-folder-mode-map "c" 'wl-folder-mark-as-read-all-current-entity)
148 (define-key wl-folder-mode-map "g" 'wl-folder-goto-folder)
149 (define-key wl-folder-mode-map "j" 'wl-folder-jump-to-current-entity)
150 (define-key wl-folder-mode-map "w" 'wl-draft)
151 (define-key wl-folder-mode-map "W" 'wl-folder-write-current-folder)
152 (define-key wl-folder-mode-map "\C-c\C-o" 'wl-jump-to-draft-buffer)
153 (define-key wl-folder-mode-map "\C-c\C-a" 'wl-addrmgr)
154 (define-key wl-folder-mode-map "rS" 'wl-folder-sync-region)
155 (define-key wl-folder-mode-map "S" 'wl-folder-sync-current-entity)
156 (define-key wl-folder-mode-map "rs" 'wl-folder-check-region)
157 (define-key wl-folder-mode-map "s" 'wl-folder-check-current-entity)
158 (define-key wl-folder-mode-map "I" 'wl-folder-prefetch-current-entity)
159 ; (define-key wl-folder-mode-map "D" 'wl-folder-drop-unsync-current-entity)
160 (define-key wl-folder-mode-map "p" 'wl-folder-prev-entity)
161 (define-key wl-folder-mode-map "n" 'wl-folder-next-entity)
162 (define-key wl-folder-mode-map "v" 'wl-folder-toggle-disp-summary)
163 (define-key wl-folder-mode-map "P" 'wl-folder-prev-unread)
164 (define-key wl-folder-mode-map "N" 'wl-folder-next-unread)
165 (define-key wl-folder-mode-map "J" 'wl-folder-jump-folder)
166 (define-key wl-folder-mode-map "f" 'wl-folder-goto-first-unread-folder)
167 (define-key wl-folder-mode-map "o" 'wl-folder-open-all-unread-folder)
168 (define-key wl-folder-mode-map "[" 'wl-folder-open-all)
169 (define-key wl-folder-mode-map "]" 'wl-folder-close-all)
170 (define-key wl-folder-mode-map "e" 'wl-folder-expire-current-entity)
171 (define-key wl-folder-mode-map "E" 'wl-folder-empty-trash)
172 (define-key wl-folder-mode-map "F" 'wl-folder-flush-queue)
173 (define-key wl-folder-mode-map "q" 'wl-exit)
174 (define-key wl-folder-mode-map "z" 'wl-folder-suspend)
175 (define-key wl-folder-mode-map "\M-t" 'wl-toggle-plugged)
176 (define-key wl-folder-mode-map "\C-t" 'wl-plugged-change)
177 (define-key wl-folder-mode-map "<" 'beginning-of-buffer)
178 (define-key wl-folder-mode-map ">" 'end-of-buffer)
180 (define-key wl-folder-mode-map "m" 'wl-fldmgr-mode-map)
181 (define-key wl-folder-mode-map "*" 'wl-fldmgr-make-multi)
182 (define-key wl-folder-mode-map "+" 'wl-fldmgr-make-group)
183 (define-key wl-folder-mode-map "|" 'wl-fldmgr-make-filter)
184 (define-key wl-folder-mode-map "\M-c" 'wl-fldmgr-copy)
185 (define-key wl-folder-mode-map "\M-w" 'wl-fldmgr-copy-region)
186 (define-key wl-folder-mode-map "\C-k" 'wl-fldmgr-cut)
187 (define-key wl-folder-mode-map "\C-w" 'wl-fldmgr-cut-region)
188 (define-key wl-folder-mode-map "\C-y" 'wl-fldmgr-yank)
189 (define-key wl-folder-mode-map "R" 'wl-fldmgr-rename)
190 (define-key wl-folder-mode-map "u" 'wl-fldmgr-unsubscribe)
191 (define-key wl-folder-mode-map "ru" 'wl-fldmgr-unsubscribe-region)
192 (define-key wl-folder-mode-map "U" 'wl-fldmgr-unsubscribe-region)
193 (define-key wl-folder-mode-map "l" 'wl-fldmgr-access-display-normal)
194 (define-key wl-folder-mode-map "L" 'wl-fldmgr-access-display-all)
195 (define-key wl-folder-mode-map "Z" 'wl-status-update)
196 (define-key wl-folder-mode-map "\C-x\C-s" 'wl-save)
197 (define-key wl-folder-mode-map "\M-s" 'wl-save)
198 (define-key wl-folder-mode-map "\C-xk" 'wl-folder-mimic-kill-buffer)
199 (define-key wl-folder-mode-map "\M-\C-a"
200 'wl-folder-goto-top-of-current-folder)
201 (define-key wl-folder-mode-map "\M-\C-e"
202 'wl-folder-goto-bottom-of-current-folder)
204 (wl-folder-setup-mouse)
208 "Menu used in Folder mode."
209 wl-folder-mode-menu-spec))
211 (defmacro wl-folder-unread-regex (group)
212 (` (concat "^[ ]*.+:[0-9\\*-]+/[^0\\*][0-9]*/[0-9\\*-]+$"
217 (defmacro wl-folder-buffer-group-p ()
218 (` (save-excursion (beginning-of-line)
219 (looking-at wl-folder-group-regexp))))
221 (defmacro wl-folder-folder-name ()
224 (if (or (looking-at "^[ ]*\\[[\\+-]\\]\\(.+\\):[-0-9\\*-]+/[0-9\\*-]+/[0-9\\*-]+\n")
225 (looking-at "^[ ]*\\([^\\[].+\\):.*\n"))
226 (wl-match-buffer 1)))))
228 (defmacro wl-folder-entity-name ()
231 (if (looking-at "^[ ]*\\([^\\[].+\\):.*\n")
232 (wl-match-buffer 1)))))
234 (defun wl-folder-buffer-search-group (group)
237 "^\\([ \t]*\\)\\[[\\+-]\\]"
238 (regexp-quote group) ":[-0-9-]+/[0-9-]+/[0-9-]+") nil t))
240 (defun wl-folder-buffer-search-entity (folder &optional searchname)
241 (let ((search (or searchname (wl-folder-get-petname folder))))
245 (regexp-quote search) ":[-0-9\\*-]+/[0-9\\*-]+/[0-9\\*-]+") nil t)))
247 (defsubst wl-folder-get-folder-name-by-id (entity-id &optional hashtb)
248 (and (numberp entity-id)
249 (elmo-get-hash-val (format "#%d" entity-id)
250 (or hashtb wl-folder-entity-id-name-hashtb))))
252 (defsubst wl-folder-set-id-name (entity-id entity &optional hashtb)
253 (and (numberp entity-id)
254 (elmo-set-hash-val (format "#%d" entity-id)
255 entity (or hashtb wl-folder-entity-id-name-hashtb))))
257 (defmacro wl-folder-get-entity-id (entity)
258 `(get-text-property 0 'wl-folder-entity-id ,entity))
260 (defmacro wl-folder-get-entity-from-buffer (&optional getid)
261 `(let ((id (get-text-property (point)
262 'wl-folder-entity-id)))
265 (wl-folder-get-folder-name-by-id id))))
267 (defmacro wl-folder-entity-exists-p (entity &optional hashtb)
268 (` (let ((sym (intern-soft (, entity)
269 (or (, hashtb) wl-folder-entity-hashtb))))
270 (and sym (boundp sym)))))
272 (defmacro wl-folder-clear-entity-info (entity &optional hashtb)
273 (` (let ((sym (intern-soft (, entity)
274 (or (, hashtb) wl-folder-entity-hashtb))))
278 (defmacro wl-folder-get-entity-info (entity &optional hashtb)
279 (` (elmo-get-hash-val (, entity) (or (, hashtb) wl-folder-entity-hashtb))))
281 (defmacro wl-folder-set-entity-info (entity value &optional hashtb)
282 (` (let* ((hashtb (or (, hashtb) wl-folder-entity-hashtb))
283 (info (wl-folder-get-entity-info (, entity) hashtb)))
284 (elmo-set-hash-val (, entity)
285 (if (< (length (, value)) 4)
286 (append (, value) (list (nth 3 info)))
290 (defun wl-folder-persistent-p (folder)
291 (or (and (wl-folder-search-entity-by-name folder wl-folder-entity
295 (let ((li wl-save-folder-list))
297 (if (string-match (car li) folder)
299 (setq li (cdr li)))))
301 (let ((li wl-no-save-folder-list))
303 (if (string-match (car li) folder)
305 (setq li (cdr li))))))))
307 ;;; ELMO folder structure with cache.
308 (defmacro wl-folder-get-elmo-folder (entity)
309 "Get elmo folder structure from entity."
310 (` (or (wl-folder-elmo-folder-cache-get (, entity))
311 (let* ((name (elmo-string (, entity)))
312 (folder (elmo-make-folder name)))
313 (wl-folder-elmo-folder-cache-put name folder)
316 (defmacro wl-folder-elmo-folder-cache-get (name &optional hashtb)
317 "Returns a elmo folder structure associated with NAME from HASHTB.
318 Default HASHTB is `wl-folder-elmo-folder-hashtb'."
319 (` (elmo-get-hash-val (, name)
320 (or (, hashtb) wl-folder-elmo-folder-hashtb))))
322 (defmacro wl-folder-elmo-folder-cache-put (name folder &optional hashtb)
323 "Get folder elmo folder structure on HASHTB for folder with NAME.
324 Default HASHTB is `wl-folder-elmo-folder-hashtb'."
325 (` (elmo-set-hash-val (, name) (, folder)
326 (or (, hashtb) wl-folder-elmo-folder-hashtb))))
328 (defun wl-folder-prev-entity ()
332 (defun wl-folder-next-entity ()
336 (defun wl-folder-prev-entity-skip-invalid (&optional hereto)
337 "move to previous entity. skip unsubscribed or removed entity."
341 (if (re-search-backward wl-folder-entity-regexp nil t)
343 (goto-char (point-min))))
345 (defun wl-folder-next-entity-skip-invalid (&optional hereto)
346 "Move to next entity. skip unsubscribed or removed entity."
351 (if (re-search-forward wl-folder-entity-regexp nil t)
353 (goto-char (point-max))))
355 (defun wl-folder-search-group-entity-by-name (name entity)
356 (wl-folder-search-entity-by-name name entity 'group))
358 (defun wl-folder-search-entity-by-name (name entity &optional type)
359 (let ((entities (list entity))
363 (setq entity (wl-pop entities))
366 (if (and (not (eq type 'folder))
367 (string= name (car entity)))
368 (throw 'done entity))
370 (wl-push entities entity-stack))
371 (setq entities (nth 2 entity)))
372 ((and (not (eq type 'group))
374 (if (string= name entity)
375 (throw 'done entity))))
377 (setq entities (wl-pop entity-stack)))))))
379 (defun wl-folder-search-entity-list-by-name (name entity &optional get-id)
380 (let ((entities (list entity))
381 entity-stack ret-val)
383 (setq entity (wl-pop entities))
387 (wl-push entities entity-stack))
388 (setq entities (nth 2 entity)))
390 (if (string= name entity)
391 (wl-append ret-val (if get-id
392 (list (wl-folder-get-entity-id entity))
395 (setq entities (wl-pop entity-stack))))
398 (defun wl-folder-get-prev-folder (id &optional unread)
399 (let ((name (if (stringp id)
401 (wl-folder-get-folder-name-by-id id)))
402 entity entity-stack last-entity finfo
403 (entities (list wl-folder-entity)))
406 (setq entity (wl-pop entities))
409 ;; (if (and (string= name (car entity))
410 ;; (eq id (wl-folder-get-entity-id (car entity))))
411 ;; (throw 'done last-entity))
413 (wl-push entities entity-stack))
414 (setq entities (nth 2 entity)))
416 (if (and (string= name entity)
417 ;; don't use eq, `id' is string on Nemacs.
418 (equal id (wl-folder-get-entity-id entity)))
419 (throw 'done last-entity))
421 (and (setq finfo (wl-folder-get-entity-info entity))
422 (and (nth 0 finfo)(nth 1 finfo))
423 (> (+ (nth 0 finfo)(nth 1 finfo)) 0)))
424 (setq last-entity entity))))
426 (setq entities (wl-pop entity-stack)))))))
428 (defun wl-folder-get-next-folder (id &optional unread)
429 (let ((name (if (stringp id)
431 (wl-folder-get-folder-name-by-id id)))
432 entity entity-stack found finfo
433 (entities (list wl-folder-entity)))
436 (setq entity (wl-pop entities))
439 ;;; (if (and (string= name (car entity))
440 ;;; (eq id (wl-folder-get-entity-id (car entity))))
443 (wl-push entities entity-stack))
444 (setq entities (nth 2 entity)))
447 (when (or (not unread)
448 (and (setq finfo (wl-folder-get-entity-info entity))
449 (and (nth 0 finfo)(nth 1 finfo))
450 (> (+ (nth 0 finfo)(nth 1 finfo)) 0)))
451 (throw 'done entity))
452 (if (and (string= name entity)
453 ;; don't use eq, `id' is string on Nemacs.
454 (equal id (wl-folder-get-entity-id entity)))
457 (setq entities (wl-pop entity-stack)))))))
459 (defun wl-folder-flush-queue ()
462 (let ((cur-buf (current-buffer))
463 (wl-auto-select-first nil)
466 (if elmo-enable-disconnected-operation
467 (elmo-dop-queue-flush 'force)) ; Try flushing all queue.
468 (if (not (elmo-folder-list-messages
469 (wl-folder-get-elmo-folder wl-queue-folder)))
470 (message "No sending queue exists.")
471 (if wl-stay-folder-window
472 (wl-folder-select-buffer
473 (wl-summary-get-buffer-create wl-queue-folder)))
474 (wl-summary-goto-folder-subr wl-queue-folder 'force-update nil)
476 (wl-draft-queue-flush)
477 (if (get-buffer-window cur-buf)
478 (select-window (get-buffer-window cur-buf)))
480 (if wl-stay-folder-window
481 (wl-folder-toggle-disp-summary 'off wl-queue-folder)
482 (switch-to-buffer cur-buf))))))
484 (defun wl-folder-empty-trash ()
487 (let ((cur-buf (current-buffer))
488 (wl-auto-select-first nil)
490 (if wl-stay-folder-window
491 (wl-folder-select-buffer
492 (wl-summary-get-buffer-create wl-trash-folder)))
493 (wl-summary-goto-folder-subr wl-trash-folder 'force-update nil nil t)
494 (setq trash-buf (current-buffer))
496 (setq emptied (wl-summary-delete-all-msgs))
498 (setq wl-thread-entities nil
499 wl-thread-entity-list nil)
500 (if wl-summary-cache-use (wl-summary-save-view-cache))
501 (elmo-folder-commit wl-summary-buffer-elmo-folder))
502 (if (get-buffer-window cur-buf)
503 (select-window (get-buffer-window cur-buf)))
506 (wl-folder-set-folder-updated wl-trash-folder '(0 0 0)))
507 (if wl-stay-folder-window
508 (wl-folder-toggle-disp-summary 'off wl-trash-folder)
509 (switch-to-buffer cur-buf))
511 (kill-buffer trash-buf)))))
513 (defun wl-folder-goto-top-of-current-folder (&optional arg)
514 "Move backward to the top of the current folder group.
515 Optional argument ARG is repeart count."
517 (if (re-search-backward
518 "^ *\\[[\\+-]\\]" nil t (if arg (prefix-numeric-value arg)))
520 (goto-char (point-min))))
522 (defun wl-folder-goto-bottom-of-current-folder (indent)
523 "Move forward to the bottom of the current folder group."
528 (if (looking-at "^ *")
529 (buffer-substring (match-beginning 0)(1- (match-end 0)))
533 (while (re-search-forward "^ *" nil t)
534 (if (<= (length (match-string 0))
538 (goto-char (point-max))))
540 (defsubst wl-folder-update-group (entity diffs &optional is-group)
542 (let ((path (wl-folder-get-path
544 (wl-folder-get-entity-id entity)
547 ;; delete itself from path
548 (setq path (delete (nth (- (length path) 1) path) path)))
549 (goto-char (point-min))
552 ;; goto the path line.
553 (if (or (eq (car path) 0) ; update desktop
554 (wl-folder-buffer-search-group
555 (wl-folder-get-petname
556 (if (stringp (car path))
558 (wl-folder-get-folder-name-by-id
561 (wl-folder-update-diff-line diffs)
563 (setq path (cdr path)))))))
565 (defun wl-folder-maybe-load-folder-list (entity)
566 (when (null (caddr entity))
568 (elmo-msgdb-flist-load (car entity)))
572 (wl-folder-entity-assign-id entity
573 wl-folder-entity-id-name-hashtb
575 (setq diffs (wl-fldmgr-add-entity-hashtb (list entity)))
576 (unless (equal diffs '(0 0 0))
577 (wl-folder-update-group (car entity) diffs t)))))))
579 (defsubst wl-folder-force-fetch-p (entity)
581 ((consp wl-force-fetch-folders)
582 (wl-string-match-member entity wl-force-fetch-folders))
584 wl-force-fetch-folders)))
586 (defun wl-folder-jump-to-current-entity (&optional arg)
587 "Enter the current folder. If optional ARG exists, update folder list."
590 (let (entity beg end indent opened fname err fld-name)
592 ((looking-at wl-folder-group-regexp)
594 (setq fname (wl-folder-get-realname (wl-match-buffer 3)))
595 (setq indent (wl-match-buffer 1))
596 (setq opened (wl-match-buffer 2))
597 (if (string= opened "+")
599 (setq entity (wl-folder-search-group-entity-by-name
604 (wl-folder-update-recursive-current-entity entity)
606 (setcdr (assoc (car entity) wl-folder-group-alist) t)
607 (if (eq 'access (cadr entity))
608 (wl-folder-maybe-load-folder-list entity))
609 ;(condition-case errobj
611 (if (or (wl-folder-force-fetch-p (car entity))
613 (eq 'access (cadr entity))
614 (null (caddr entity))))
615 (wl-folder-update-newest indent entity)
616 (wl-folder-insert-entity indent entity))
617 (wl-highlight-folder-path wl-folder-buffer-cur-path))
620 ; (setcdr (assoc fname wl-folder-group-alist) nil))
622 ; (elmo-display-error errobj t)
625 ; (setcdr (assoc fname wl-folder-group-alist) nil)))
627 (let ((buffer-read-only nil))
628 (delete-region (save-excursion (beginning-of-line)
630 (save-excursion (end-of-line)
636 (progn (wl-folder-goto-bottom-of-current-folder indent)
639 (setq entity (wl-folder-search-group-entity-by-name
642 (let ((buffer-read-only nil))
643 (delete-region beg end))
644 (setcdr (assoc (car entity) wl-folder-group-alist) nil)
645 (wl-folder-insert-entity indent entity) ; insert entity
647 (wl-highlight-folder-path wl-folder-buffer-cur-path)
648 ; (wl-delete-all-overlays)
649 ; (wl-highlight-folder-current-line)
651 ((setq fld-name (wl-folder-entity-name))
652 (wl-folder-set-current-entity-id
653 (get-text-property (point) 'wl-folder-entity-id))
654 (setq fld-name (wl-folder-get-folder-name-by-id
655 wl-folder-buffer-cur-entity-id))
656 (let ((summary-buf (wl-summary-get-buffer-create fld-name arg))
658 (if (or wl-stay-folder-window wl-summary-use-frame)
659 (wl-folder-select-buffer summary-buf)
661 (get-buffer-window summary-buf))
663 (wl-summary-goto-folder-subr fld-name
664 (wl-summary-get-sync-range
665 (wl-folder-get-elmo-folder fld-name))
667 (set-buffer-modified-p nil))
669 (defun wl-folder-close-entity (entity)
670 (let ((entities (list entity))
673 (setq entity (wl-pop entities))
676 (setcdr (assoc (car entity) wl-folder-group-alist) nil)
678 (wl-push entities entity-stack))
679 (setq entities (nth 2 entity))))
681 (setq entities (wl-pop entity-stack))))))
683 (defun wl-folder-update-recursive-current-entity (&optional entity)
685 (when (wl-folder-buffer-group-p)
687 ((string= (wl-match-buffer 2) "+")
691 (wl-folder-search-group-entity-by-name
692 (wl-folder-get-realname (wl-match-buffer 3))
694 (let ((inhibit-read-only t)
695 (entities (list entity))
696 entity-stack err indent)
697 (while (and entities (not err))
698 (setq entity (wl-pop entities))
701 (wl-folder-close-entity entity)
702 (setcdr (assoc (car entity) wl-folder-group-alist) t)
703 (unless (wl-folder-buffer-search-group
704 (wl-folder-get-petname (car entity)))
705 (error "%s: not found group" (car entity)))
706 (setq indent (wl-match-buffer 1))
707 (if (eq 'access (cadr entity))
708 (wl-folder-maybe-load-folder-list entity))
712 (condition-case errobj
713 (wl-folder-update-newest indent entity)
716 (setcdr (assoc (car entity) wl-folder-group-alist) nil))
718 (elmo-display-error errobj t)
721 (setcdr (assoc (car entity) wl-folder-group-alist) nil)))
723 (delete-region (save-excursion (beginning-of-line)
725 (save-excursion (end-of-line)
729 (wl-push entities entity-stack))
730 (setq entities (nth 2 entity))))
732 (setq entities (wl-pop entity-stack)))))
733 (set-buffer-modified-p nil)))
735 (wl-folder-jump-to-current-entity)))))
737 (defun wl-folder-no-auto-check-folder-p (folder)
740 (let ((li wl-auto-check-folder-list))
742 (if (string-match (car li) folder)
744 (setq li (cdr li)))))
747 (let ((li wl-auto-uncheck-folder-list))
749 (if (string-match (car li) folder)
750 (throw 'found t)) ; no check!
751 (setq li (cdr li))))))))
753 (defsubst wl-folder-add-folder-info (pre-value value)
755 (+ (or (nth 0 pre-value) 0) (or (nth 0 value) 0))
756 (+ (or (nth 1 pre-value) 0) (or (nth 1 value) 0))
757 (+ (or (nth 2 pre-value) 0) (or (nth 2 value) 0))))
759 (defun wl-folder-check-entity (entity &optional auto)
760 "Check unsync message number."
761 (let ((start-pos (point))
763 (run-hooks 'wl-folder-check-entity-pre-hook)
764 (if (and (consp entity) ;; group entity
765 wl-folder-check-async) ;; very fast
766 (setq ret-val (wl-folder-check-entity-async entity auto))
770 (let ((flist (if auto
772 'wl-folder-no-auto-check-folder-p
775 (wl-folder-check-entity-pre-hook nil)
776 (wl-folder-check-entity-hook nil)
780 (wl-folder-add-folder-info
782 (wl-folder-check-entity (car flist))))
783 (setq flist (cdr flist)))
784 ;(wl-folder-buffer-search-entity (car entity))
785 ;(wl-folder-update-line ret-val)
788 (message "Checking \"%s\"" entity)
789 (setq ret-val (wl-folder-check-one-entity
791 (goto-char start-pos)
794 (message "Uncheck(unplugged) \"%s\"" entity)))))
796 (message "Checking \"%s\" is done."
797 (if (consp entity) (car entity) entity)))
798 (run-hooks 'wl-folder-check-entity-hook)
801 (defun wl-folder-check-one-entity (entity)
802 (let* ((folder (wl-folder-get-elmo-folder entity))
803 (nums (condition-case err
804 (if (wl-string-match-member entity wl-strict-diff-folders)
805 (elmo-strict-folder-diff folder)
806 (elmo-folder-diff folder))
808 ;; maybe not exist folder.
809 (if (and (not (memq 'elmo-open-error
810 (get (car err) 'error-conditions)))
811 (not (elmo-folder-exists-p folder)))
812 (wl-folder-create-subr folder)
813 (signal (car err) (cdr err))))))
814 (new (elmo-diff-new nums))
815 (nums (cons (elmo-diff-unread nums) (elmo-diff-all nums)))
817 (if (and (eq wl-folder-notify-deleted 'sync)
819 (or (> 0 (car nums)) (> 0 (cdr nums))))
821 (wl-folder-sync-entity entity)
822 (setq nums (elmo-folder-diff folder)))
823 (unless wl-folder-notify-deleted
824 (setq unsync (if (car nums)
827 (setq nomif (if (cdr nums)
830 (setq nums (cons unsync nomif)))
831 (setq unread (or ;; If server diff, All unreads are
833 (if (elmo-folder-use-flag-p folder)
835 (elmo-folder-get-info-unread folder)
836 (wl-summary-count-unread (elmo-msgdb-mark-load
837 (elmo-folder-msgdb-path
839 (when new (setq unread (- unread new)))
840 (wl-folder-entity-hashtb-set wl-folder-entity-hashtb entity
841 (list (or new (car nums))
844 (get-buffer wl-folder-buffer-name)))
845 (setq wl-folder-info-alist-modified t)
847 (list (if wl-folder-notify-deleted
848 (or new (car nums) 0)
849 (max 0 (or new (car nums) 0)))
853 (defun wl-folder-check-entity-async (entity &optional auto)
854 (let ((elmo-nntp-groups-async t)
857 'wl-folder-no-auto-check-folder-p
858 (wl-folder-get-entity-list entity))
859 (wl-folder-get-entity-list entity)))
860 (nntp-connection-keys nil)
861 name folder folder-list
867 (setq folder (wl-folder-get-elmo-folder (car elist)))
868 (if (not (elmo-folder-plugged-p folder))
869 (message "Uncheck \"%s\"" (car elist))
871 (elmo-folder-get-primitive-list folder))
872 (cond ((elmo-folder-contains-type folder 'nntp)
873 (wl-append async-folder-list (list folder))
875 (when (eq (elmo-folder-type-internal (car folder-list))
879 (elmo-net-folder-server-internal
881 (setq server (elmo-net-folder-server-internal
883 (message "Checking on \"%s\"" server))
884 (setq nntp-connection-keys
885 (elmo-nntp-get-folders-info-prepare
887 nntp-connection-keys)))
888 (setq folder-list (cdr folder-list))))
890 (wl-append sync-folder-list (list folder)))))
891 (setq elist (cdr elist)))
892 ;; check local entity at first
893 (while (setq folder (pop sync-folder-list))
894 (if (not (elmo-folder-plugged-p folder))
895 (message "Uncheck \"%s\"" (elmo-folder-name-internal folder))
896 (message "Checking \"%s\"" (elmo-folder-name-internal folder))
898 (wl-folder-add-folder-info
900 (wl-folder-check-one-entity (elmo-folder-name-internal
904 ;; check network entity at last
905 (when async-folder-list
906 (elmo-nntp-get-folders-info nntp-connection-keys)
907 (while (setq folder (pop async-folder-list))
908 (if (not (elmo-folder-plugged-p folder))
909 (message "Uncheck \"%s\"" (elmo-folder-name-internal folder))
910 (message "Checking \"%s\"" (elmo-folder-name-internal folder))
912 (wl-folder-add-folder-info
914 (wl-folder-check-one-entity (elmo-folder-name-internal
921 (defun wl-folder-resume-entity-hashtb-by-finfo (entity-hashtb info-alist)
922 "Resume unread info for entity alist."
925 (setq info (nth 1 (car info-alist)))
926 (wl-folder-set-entity-info (caar info-alist)
927 (list (nth 2 info)(nth 3 info)(nth 1 info))
929 (setq info-alist (cdr info-alist)))))
931 (defun wl-folder-move-path (path)
932 (let ((fp (if (consp path)
935 (wl-folder-get-path wl-folder-entity path))))
936 (goto-char (point-min))
939 (when (equal (car fp)
940 (wl-folder-get-entity-from-buffer t))
942 (setq wl-folder-buffer-cur-point (point)))
944 (and wl-folder-buffer-cur-point
945 (goto-char wl-folder-buffer-cur-point))))
947 (defun wl-folder-set-current-entity-id (entity-id)
948 (let ((buf (get-buffer wl-folder-buffer-name)))
952 (setq wl-folder-buffer-cur-entity-id entity-id)
953 (setq wl-folder-buffer-cur-path (wl-folder-get-path wl-folder-entity
955 (wl-highlight-folder-path wl-folder-buffer-cur-path)
956 (and wl-folder-move-cur-folder
957 wl-folder-buffer-cur-point
958 (goto-char wl-folder-buffer-cur-point))))
959 (if (eq (current-buffer) buf)
960 (and wl-folder-move-cur-folder
961 wl-folder-buffer-cur-point
962 (goto-char wl-folder-buffer-cur-point)))))
964 (defun wl-folder-check-current-entity ()
965 "Check folder at position.
966 If current line is group folder, check all sub entries."
968 (let* ((entity-name (wl-folder-get-entity-from-buffer))
969 (group (wl-folder-buffer-group-p))
970 (desktop (string= entity-name wl-folder-desktop-name)))
972 (wl-folder-check-entity
974 (wl-folder-search-group-entity-by-name entity-name
979 (defun wl-folder-sync-entity (entity &optional unread-only)
980 "Synchronize the msgdb of ENTITY."
983 (let ((flist (nth 2 entity)))
985 (wl-folder-sync-entity (car flist) unread-only)
986 (setq flist (cdr flist)))))
988 (let* ((folder (wl-folder-get-elmo-folder entity))
989 (nums (wl-folder-get-entity-info entity))
990 (wl-summary-highlight (if (or (wl-summary-sticky-p folder)
991 (wl-summary-always-sticky-folder-p
993 wl-summary-highlight))
994 wl-auto-select-first new unread)
995 (setq new (or (car nums) 0))
996 (setq unread (or (cadr nums) 0))
997 (if (or (not unread-only)
998 (or (< 0 new) (< 0 unread)))
999 (let ((wl-summary-buffer-name (concat
1000 wl-summary-buffer-name
1001 (symbol-name this-command)))
1002 (wl-summary-use-frame nil)
1003 (wl-summary-always-sticky-folder-list nil))
1004 (save-window-excursion
1006 (wl-summary-goto-folder-subr entity
1007 (wl-summary-get-sync-range
1010 (wl-summary-exit)))))))))
1012 (defun wl-folder-sync-current-entity (&optional unread-only)
1013 "Synchronize the folder at position.
1014 If current line is group folder, check all subfolders."
1017 (let ((entity-name (wl-folder-get-entity-from-buffer))
1018 (group (wl-folder-buffer-group-p)))
1019 (when (and entity-name
1020 (y-or-n-p (format "Sync %s? " entity-name)))
1021 (wl-folder-sync-entity
1023 (wl-folder-search-group-entity-by-name entity-name
1027 (message "Syncing %s is done!" entity-name)))))
1029 (defun wl-folder-mark-as-read-all-entity (entity)
1030 "Mark as read all messages in the ENTITY."
1033 (let ((flist (nth 2 entity)))
1035 (wl-folder-mark-as-read-all-entity (car flist))
1036 (setq flist (cdr flist)))))
1038 (let* ((nums (wl-folder-get-entity-info entity))
1039 (folder (wl-folder-get-elmo-folder entity))
1040 (wl-summary-highlight (if (or (wl-summary-sticky-p folder)
1041 (wl-summary-always-sticky-folder-p
1043 wl-summary-highlight))
1044 wl-auto-select-first new unread)
1045 (setq new (or (car nums) 0))
1046 (setq unread (or (cadr nums) 0))
1047 (if (or (< 0 new) (< 0 unread))
1048 (save-window-excursion
1050 (let ((wl-summary-buffer-name (concat
1051 wl-summary-buffer-name
1052 (symbol-name this-command)))
1053 (wl-summary-use-frame nil)
1054 (wl-summary-always-sticky-folder-list nil))
1055 (wl-summary-goto-folder-subr entity
1056 (wl-summary-get-sync-range folder)
1058 (wl-summary-mark-as-read-all)
1059 (wl-summary-exit))))
1062 (defun wl-folder-mark-as-read-all-current-entity ()
1063 "Mark as read all messages in the folder at position.
1064 If current line is group folder, all subfolders are marked."
1067 (let ((entity-name (wl-folder-get-entity-from-buffer))
1068 (group (wl-folder-buffer-group-p))
1070 (when (and entity-name
1071 (y-or-n-p (format "Mark all messages in %s as read? " entity-name)))
1072 (wl-folder-mark-as-read-all-entity
1074 (wl-folder-search-group-entity-by-name entity-name
1077 (message "All messages in %s are marked!" entity-name)))))
1079 (defun wl-folder-check-region (beg end)
1088 (let ((inhibit-read-only t)
1090 (while (< (point) end)
1091 ;; normal folder entity
1092 (if (looking-at "^[\t ]*\\([^\\[]+\\):\\(.*\\)\n")
1094 (setq entity (wl-folder-get-entity-from-buffer))
1095 (if (not (elmo-folder-plugged-p (wl-folder-get-elmo-folder
1097 (message "Uncheck %s" entity)
1098 (message "Checking %s" entity)
1099 (wl-folder-check-one-entity entity)
1104 (defun wl-folder-sync-region (beg end)
1113 (while (< (point) end)
1114 ;; normal folder entity
1115 (if (looking-at "^[\t ]*\\([^\\[]+\\):\\(.*\\)\n")
1117 (let ((inhibit-read-only t)
1119 (setq entity (wl-folder-get-entity-from-buffer))
1120 (wl-folder-sync-entity entity)
1121 (message "Syncing %s is done!" entity)
1126 (defun wl-folder-mark-as-read-all-region (beg end)
1135 (while (< (point) end)
1136 ;; normal folder entity
1137 (if (looking-at "^[\t ]*\\([^\\[]+\\):\\(.*\\)\n")
1139 (let ((inhibit-read-only t)
1141 (setq entity (wl-folder-get-entity-from-buffer))
1142 (wl-folder-mark-as-read-all-entity entity)
1143 (message "All messages in %s are marked!" entity)
1148 (defsubst wl-create-access-init-load-p (folder)
1149 (let ((no-load-regexp (when (and
1150 (not wl-folder-init-load-access-folders)
1151 wl-folder-init-no-load-access-folders)
1152 (mapconcat 'identity
1153 wl-folder-init-no-load-access-folders
1155 (load-regexp (and wl-folder-init-load-access-folders
1156 (mapconcat 'identity
1157 wl-folder-init-load-access-folders
1159 (cond (load-regexp (string-match load-regexp folder))
1160 (t (not (and no-load-regexp
1161 (string-match no-load-regexp folder)))))))
1163 (defun wl-create-access-folder-entity (name)
1165 (when (wl-create-access-init-load-p name)
1166 (setq flists (elmo-msgdb-flist-load name)) ; load flist.
1167 (setq flist (car flists))
1169 (when (consp (car flist))
1170 (setcdr (cdar flist)
1171 (wl-create-access-folder-entity (caar flist))))
1172 (setq flist (cdr flist)))
1175 (defun wl-create-folder-entity-from-buffer ()
1176 "Create folder entity recursively."
1178 ((looking-at "^[ \t]*$") ; blank line
1179 (goto-char (+ 1(match-end 0)))
1181 ((looking-at "^#.*$") ; comment
1182 (goto-char (+ 1 (match-end 0)))
1184 ((looking-at "^[\t ]*\\(.+\\)[\t ]*{[\t ]*$") ; group definition
1185 (let (name entity flist)
1186 (setq name (wl-match-buffer 1))
1187 (goto-char (+ 1 (match-end 0)))
1188 (while (setq entity (wl-create-folder-entity-from-buffer))
1189 (unless (eq entity 'ignore)
1190 (wl-append flist (list entity))))
1191 (if (looking-at "^[\t ]*}[\t ]*$") ; end of group
1193 (goto-char (+ 1 (match-end 0)))
1194 (if (wl-string-assoc name wl-folder-petname-alist)
1195 (error "%s already defined as petname" name))
1196 (list name 'group flist))
1197 (error "Syntax error in folder definition"))))
1198 ((looking-at "^[\t ]*\\([^\t \n]+\\)[\t ]*/$") ; access it!
1200 (setq name (wl-match-buffer 1))
1201 (goto-char (+ 1 (match-end 0)))
1202 ; (condition-case ()
1204 ; (setq flist (elmo-list-folders name)))
1205 ; (error (message "Access to folder %s failed." name)))
1206 ;; (setq flist (elmo-msgdb-flist-load name)) ; load flist.
1207 ;; (setq unsublist (nth 1 flist))
1208 ;; (setq flist (car flist))
1209 ;; (list name 'access flist unsublist)))
1210 (append (list name 'access) (wl-create-access-folder-entity name))))
1211 ;((looking-at "^[\t ]*\\([^\t \n}]+\\)[\t ]*\\(\"[^\"]*\"\\)?[\t ]*$") ; normal folder entity
1212 ((looking-at "^[\t ]*=[ \t]+\\([^\n]+\\)$"); petname definition
1213 (goto-char (+ 1 (match-end 0)))
1214 (let ((rest (elmo-match-buffer 1))
1216 (when (string-match "\\(\"[^\"]*\"\\)[\t ]*$" rest)
1217 (setq petname (elmo-delete-char ?\" (elmo-match-string 1 rest)))
1218 (setq rest (substring rest 0 (match-beginning 0))))
1219 (when (string-match "^[\t ]*\\(.*[^\t ]+\\)[\t ]+$" rest)
1220 (wl-folder-append-petname (elmo-match-string 1 rest)
1223 ((looking-at "^[ \t]*}[ \t]*$") ; end of group
1225 ((looking-at "^.*$") ; normal folder entity
1226 (goto-char (+ 1 (match-end 0)))
1227 (let ((rest (elmo-match-buffer 0))
1229 (if (string-match "\\(\"[^\"]*\"\\)[\t ]*$" rest)
1231 (setq petname (elmo-delete-char ?\" (elmo-match-string 1 rest)))
1232 (setq rest (substring rest 0 (match-beginning 0)))
1233 (when (string-match "^[\t ]*\\(.*[^\t ]+\\)[\t ]+$" rest)
1234 (wl-folder-append-petname
1235 (setq realname (elmo-match-string 1 rest))
1238 (if (string-match "^[\t ]*\\(.+\\)$" rest)
1239 (elmo-match-string 1 rest)
1242 (defun wl-folder-create-folder-entity ()
1243 "Create folder entries."
1244 (let ((tmp-buf (get-buffer-create " *wl-folder-tmp*"))
1248 (with-current-buffer tmp-buf
1250 (insert-file-contents wl-folders-file)
1251 (goto-char (point-min))
1252 (while (and (not (eobp))
1253 (setq entity (wl-create-folder-entity-from-buffer)))
1254 (unless (eq entity 'ignore)
1255 (wl-append ret-val (list entity)))))
1256 (kill-buffer tmp-buf))
1258 (setq ret-val (list wl-folder-desktop-name 'group ret-val))))
1260 (defun wl-folder-entity-assign-id (entity &optional hashtb on-noid)
1261 (let ((hashtb (or hashtb
1262 (setq wl-folder-entity-id-name-hashtb
1263 (elmo-make-hash wl-folder-entity-id))))
1264 (entities (list entity))
1267 (setq entity (wl-pop entities))
1270 (when (not (and on-noid
1271 (get-text-property 0
1272 'wl-folder-entity-id
1274 (put-text-property 0 (length (car entity))
1275 'wl-folder-entity-id
1278 (wl-folder-set-id-name wl-folder-entity-id
1279 (car entity) hashtb))
1281 (wl-push entities entity-stack))
1282 (setq entities (nth 2 entity)))
1284 (when (not (and on-noid
1285 (get-text-property 0
1286 'wl-folder-entity-id
1288 (put-text-property 0 (length entity)
1289 'wl-folder-entity-id
1292 (wl-folder-set-id-name wl-folder-entity-id
1294 (setq wl-folder-entity-id (+ 1 wl-folder-entity-id))
1296 (setq entities (wl-pop entity-stack))))))
1298 (defun wl-folder-click (e)
1303 (wl-folder-jump-to-current-entity)))
1305 (defun wl-folder-select-buffer (buffer)
1306 (let ((gbw (get-buffer-window buffer))
1309 (progn (select-window gbw)
1311 (unless wl-summary-use-frame
1314 (split-window-horizontally wl-folder-window-width)
1318 (if wl-summary-use-frame
1319 (switch-to-buffer-other-frame buffer)
1320 (switch-to-buffer buffer))
1323 (defun wl-folder-toggle-disp-summary (&optional arg folder)
1325 (if (or (and folder (assoc folder wl-folder-group-alist))
1326 (and (interactive-p) (wl-folder-buffer-group-p)))
1327 (error "This command is not available on Group"))
1329 (let (wl-auto-select-first
1330 (wl-stay-folder-window t))
1333 (setq wl-folder-buffer-disp-summary t))
1335 (setq wl-folder-buffer-disp-summary nil)
1336 ;; hide wl-summary window.
1337 (let ((cur-buf (current-buffer))
1338 (summary-buffer (wl-summary-get-buffer folder)))
1339 (wl-folder-select-buffer summary-buffer)
1341 (select-window (get-buffer-window cur-buf))))
1343 (setq wl-folder-buffer-disp-summary
1344 (not wl-folder-buffer-disp-summary))
1345 (let ((cur-buf (current-buffer))
1347 (when (looking-at "^[ ]*\\([^\\[].+\\):.*\n")
1348 (setq folder-name (wl-folder-get-entity-from-buffer))
1349 (if wl-folder-buffer-disp-summary
1351 (wl-folder-select-buffer
1352 (wl-summary-get-buffer-create folder-name))
1354 (wl-summary-goto-folder-subr folder-name 'no-sync nil)
1355 (select-window (get-buffer-window cur-buf))))
1356 (wl-folder-select-buffer (wl-summary-get-buffer folder-name))
1358 (select-window (get-buffer-window cur-buf)))))))))
1360 (defun wl-folder-prev-unsync ()
1361 "Move cursor to the previous unsync folder."
1364 (setq start-point (point))
1366 (if (re-search-backward wl-folder-unsync-regexp nil t)
1368 (goto-char start-point)
1369 (message "No more unsync folder"))))
1371 (defun wl-folder-next-unsync (&optional plugged)
1372 "Move cursor to the next unsync."
1374 (let (start-point entity)
1375 (setq start-point (point))
1378 (while (re-search-forward wl-folder-unsync-regexp nil t)
1379 (if (or (wl-folder-buffer-group-p)
1382 (wl-folder-get-realname
1383 (wl-folder-folder-name)))
1384 (elmo-folder-plugged-p entity))
1387 (goto-char start-point)
1388 (message "No more unsync folder"))))
1390 (defun wl-folder-prev-unread (&optional group)
1391 "Move cursor to the previous unread folder."
1394 (setq start-point (point))
1396 (if (re-search-backward (wl-folder-unread-regex group) nil t)
1399 (wl-folder-folder-name))
1400 (goto-char start-point)
1401 (message "No more unread folder")
1404 (defun wl-folder-next-unread (&optional group)
1405 "Move cursor to the next unread folder."
1408 (setq start-point (point))
1410 (if (re-search-forward (wl-folder-unread-regex group) nil t)
1413 (wl-folder-folder-name))
1414 (goto-char start-point)
1415 (message "No more unread folder")
1418 (defun wl-folder-mode ()
1419 "Major mode for Wanderlust Folder.
1420 See Info under Wanderlust for full documentation.
1423 \\{wl-folder-mode-map}
1425 Entering Folder mode calls the value of `wl-folder-mode-hook'."
1427 (setq major-mode 'wl-folder-mode)
1428 (setq mode-name "Folder")
1429 (use-local-map wl-folder-mode-map)
1430 (setq buffer-read-only t)
1431 (setq inhibit-read-only nil)
1432 (setq truncate-lines t)
1433 (setq wl-folder-buffer-cur-entity-id nil
1434 wl-folder-buffer-cur-path nil
1435 wl-folder-buffer-cur-point nil)
1436 (wl-mode-line-buffer-identification)
1437 (easy-menu-add wl-folder-mode-menu)
1438 ;; This hook may contain the functions `wl-folder-init-icons' and
1439 ;; `wl-setup-folder' for reasons of system internal to accord
1440 ;; facilities for the Emacs variants.
1441 (run-hooks 'wl-folder-mode-hook))
1443 (defun wl-folder-append-petname (realname petname)
1445 ;; check group name.
1446 (if (wl-folder-search-group-entity-by-name petname wl-folder-entity)
1447 (error "%s already defined as group name" petname))
1448 (when (setq pentry (wl-string-assoc realname wl-folder-petname-alist))
1449 (setq wl-folder-petname-alist
1450 (delete pentry wl-folder-petname-alist)))
1451 (wl-append wl-folder-petname-alist
1452 (list (cons realname petname)))))
1454 (defun wl-folder (&optional arg)
1456 (let (initialize folder-buf)
1457 (if (setq folder-buf (get-buffer wl-folder-buffer-name))
1458 (if wl-folder-use-frame
1460 (save-selected-window
1461 (dolist (frame (visible-frame-list))
1462 (select-frame frame)
1463 (if (get-buffer-window folder-buf)
1464 (setq select-frame frame))))
1466 (select-frame select-frame)
1467 (switch-to-buffer folder-buf)))
1468 (switch-to-buffer folder-buf))
1469 (if wl-folder-use-frame
1470 (switch-to-buffer-other-frame
1471 (get-buffer-create wl-folder-buffer-name))
1472 (switch-to-buffer (get-buffer-create wl-folder-buffer-name)))
1473 (set-buffer wl-folder-buffer-name)
1476 (setq wl-folder-entity-id 0)
1477 (wl-folder-entity-assign-id wl-folder-entity)
1478 (setq wl-folder-entity-hashtb
1479 (wl-folder-create-entity-hashtb wl-folder-entity))
1480 (setq wl-folder-elmo-folder-hashtb (elmo-make-hash wl-folder-entity-id))
1481 (setq wl-folder-group-alist
1482 (wl-folder-create-group-alist wl-folder-entity))
1483 (setq wl-folder-newsgroups-hashtb
1484 (wl-folder-create-newsgroups-hashtb wl-folder-entity))
1485 (wl-folder-init-info-hashtb)
1486 (let ((inhibit-read-only t)
1487 (buffer-read-only nil))
1489 (setcdr (assoc (car wl-folder-entity) wl-folder-group-alist) t)
1491 (wl-folder-insert-entity " " wl-folder-entity)))
1493 (set-buffer-modified-p nil)
1494 (setq initialize t))
1497 (defun wl-folder-auto-check ()
1498 "Check and update folders in `wl-auto-check-folder-name'."
1500 (when (get-buffer wl-folder-buffer-name)
1501 (switch-to-buffer wl-folder-buffer-name)
1503 ((eq wl-auto-check-folder-name 'none))
1504 ((or (consp wl-auto-check-folder-name)
1505 (stringp wl-auto-check-folder-name))
1506 (let ((folder-list (if (consp wl-auto-check-folder-name)
1507 wl-auto-check-folder-name
1508 (list wl-auto-check-folder-name)))
1511 (if (setq entity (wl-folder-search-entity-by-name
1514 (wl-folder-check-entity entity 'auto))
1515 (setq folder-list (cdr folder-list)))))
1517 (wl-folder-check-entity wl-folder-entity 'auto)))))
1519 (defun wl-folder-set-folder-updated (name value)
1522 (if (setq buf (get-buffer wl-folder-buffer-name))
1523 (wl-folder-entity-hashtb-set
1524 wl-folder-entity-hashtb name value buf))
1525 (setq wl-folder-info-alist-modified t))))
1527 (defun wl-folder-calc-finfo (entity)
1528 ;; calcurate finfo without inserting.
1529 (let ((entities (list entity))
1531 new unread all nums)
1533 (setq entity (wl-pop entities))
1537 (wl-push entities entity-stack))
1538 (setq entities (nth 2 entity)))
1540 (setq nums (wl-folder-get-entity-info entity))
1541 (setq new (+ (or new 0) (or (nth 0 nums) 0)))
1542 (setq unread (+ (or unread 0)
1543 (or (and (nth 0 nums)(nth 1 nums)
1544 (+ (nth 0 nums)(nth 1 nums))) 0)))
1545 (setq all (+ (or all 0) (or (nth 2 nums) 0)))))
1547 (setq entities (wl-pop entity-stack))))
1548 (list new unread all)))
1550 (defsubst wl-folder-make-save-access-list (list)
1551 (mapcar '(lambda (x)
1554 (list (elmo-string (car x)) 'access))
1559 (defun wl-folder-update-newest (indent entity)
1560 (let (ret-val new unread all)
1563 (let ((inhibit-read-only t)
1564 (buffer-read-only nil)
1565 (flist (nth 2 entity))
1566 (as-opened (cdr (assoc (car entity) wl-folder-group-alist)))
1571 (let (update-flist flist-unsub new-flist removed group-name-end)
1572 (when (and (eq (cadr entity) 'access)
1573 (elmo-folder-plugged-p
1574 (wl-folder-get-elmo-folder (car entity))))
1575 (message "Fetching folder entries...")
1576 (when (setq new-flist
1577 (elmo-folder-list-subfolders
1578 (wl-folder-get-elmo-folder (car entity))
1581 wl-folder-hierarchy-access-folders)))
1583 (wl-folder-update-access-group entity new-flist))
1584 (setq flist (nth 1 update-flist))
1585 (when (car update-flist) ;; diff
1586 (setq flist-unsub (nth 2 update-flist))
1587 (setq removed (nth 3 update-flist))
1588 (elmo-msgdb-flist-save
1591 (wl-folder-make-save-access-list flist)
1592 (wl-folder-make-save-access-list flist-unsub)))
1593 (wl-folder-entity-assign-id
1595 wl-folder-entity-id-name-hashtb
1597 (setq wl-folder-entity-hashtb
1598 (wl-folder-create-entity-hashtb
1600 wl-folder-entity-hashtb
1602 (setq wl-folder-newsgroups-hashtb
1604 (wl-folder-create-newsgroups-hashtb
1606 wl-folder-newsgroups-hashtb))))
1607 (message "Fetching folder entries...done"))
1608 (wl-folder-insert-entity indent entity))))))))
1610 (defun wl-folder-insert-entity (indent entity &optional onlygroup)
1611 (let (ret-val new unread all)
1614 (let ((inhibit-read-only t)
1615 (buffer-read-only nil)
1616 (flist (nth 2 entity))
1617 (as-opened (cdr (assoc (car entity) wl-folder-group-alist)))
1620 ;;; (insert indent "[" (if as-opened "-" "+") "]" (car entity) "\n")
1621 ;;; (save-excursion (forward-line -1)
1622 ;;; (wl-highlight-folder-current-line))
1626 (let (update-flist flist-unsub new-flist removed group-name-end)
1627 ;;; (when (and (eq (cadr entity) 'access)
1629 ;;; (message "fetching folder entries...")
1630 ;;; (when (setq new-flist
1631 ;;; (elmo-list-folders
1632 ;;; (elmo-string (car entity))
1633 ;;; (wl-string-member
1635 ;;; wl-folder-hierarchy-access-folders)
1637 ;;; (setq update-flist
1638 ;;; (wl-folder-update-access-group entity new-flist))
1639 ;;; (setq flist (nth 1 update-flist))
1640 ;;; (when (car update-flist) ;; diff
1641 ;;; (setq flist-unsub (nth 2 update-flist))
1642 ;;; (setq removed (nth 3 update-flist))
1643 ;;; (elmo-msgdb-flist-save
1646 ;;; (wl-folder-make-save-access-list flist)
1647 ;;; (wl-folder-make-save-access-list flist-unsub)))
1649 ;;; ;; reconstruct wl-folder-entity-id-name-hashtb and
1650 ;;; ;; wl-folder-entity-hashtb
1652 ;;; (wl-folder-entity-assign-id
1654 ;;; wl-folder-entity-id-name-hashtb
1656 ;;; (setq wl-folder-entity-hashtb
1657 ;;; (wl-folder-create-entity-hashtb
1659 ;;; wl-folder-entity-hashtb
1661 ;;; (setq wl-folder-newsgroups-hashtb
1663 ;;; (wl-folder-create-newsgroups-hashtb
1665 ;;; wl-folder-newsgroups-hashtb))))
1666 ;;; (message "fetching folder entries...done"))
1667 (insert indent "[" (if as-opened "-" "+") "]"
1668 (wl-folder-get-petname (car entity)))
1669 (setq group-name-end (point))
1671 (put-text-property beg (point) 'wl-folder-entity-id
1672 (get-text-property 0 'wl-folder-entity-id
1678 wl-folder-removed-mark
1679 (if (listp (car removed))
1680 (concat "[+]" (caar removed))
1683 (save-excursion (forward-line -1)
1684 (wl-highlight-folder-current-line))
1685 (setq removed (cdr removed)))
1686 (remove-text-properties beg (point) '(wl-folder-entity-id)))
1687 (let* ((len (length flist))
1692 (wl-folder-insert-entity
1693 (concat indent " ") (car flist)))
1694 (setq new (+ (or new 0) (or (nth 0 ret-val) 0)))
1695 (setq unread (+ (or unread 0) (or (nth 1 ret-val) 0)))
1696 (setq all (+ (or all 0) (or (nth 2 ret-val) 0)))
1698 (> len elmo-display-progress-threshold))
1700 (elmo-display-progress
1701 'wl-folder-insert-entity "Inserting group %s..."
1702 (/ (* i 100) len) (car entity)))
1703 (setq flist (cdr flist))))
1705 (goto-char group-name-end)
1706 (delete-region (point) (save-excursion (end-of-line)
1708 (insert (format ":%d/%d/%d" (or new 0)
1709 (or unread 0) (or all 0)))
1710 (setq ret-val (list new unread all))
1711 (wl-highlight-folder-current-line ret-val)))
1712 (setq ret-val (wl-folder-calc-finfo entity))
1713 (insert indent "[" (if as-opened "-" "+") "]"
1714 (wl-folder-get-petname (car entity))
1716 (or (nth 0 ret-val) 0)
1717 (or (nth 1 ret-val) 0)
1718 (or (nth 2 ret-val) 0))
1720 (put-text-property beg (point) 'wl-folder-entity-id
1721 (get-text-property 0 'wl-folder-entity-id
1723 (save-excursion (forward-line -1)
1724 (wl-highlight-folder-current-line ret-val)))))
1726 (let* ((inhibit-read-only t)
1727 (buffer-read-only nil)
1728 (nums (wl-folder-get-entity-info entity))
1731 (insert indent (wl-folder-get-petname entity)
1732 (format ":%s/%s/%s\n"
1733 (or (setq new (nth 0 nums)) "*")
1734 (or (setq unread (and (nth 0 nums)(nth 1 nums)
1735 (+ (nth 0 nums)(nth 1 nums))))
1737 (or (setq all (nth 2 nums)) "*")))
1738 (put-text-property beg (point) 'wl-folder-entity-id
1739 (get-text-property 0 'wl-folder-entity-id entity))
1740 (save-excursion (forward-line -1)
1741 (wl-highlight-folder-current-line nums))
1742 (setq ret-val (list new unread all)))))
1743 (set-buffer-modified-p nil)
1746 (defun wl-folder-check-all ()
1748 (wl-folder-check-entity wl-folder-entity))
1750 (defun wl-folder-entity-hashtb-set (entity-hashtb name value buffer)
1757 (setq cur-val (wl-folder-get-entity-info name entity-hashtb))
1758 (setq new-diff (- (or (nth 0 value) 0) (or (nth 0 cur-val) 0)))
1761 (- (or (nth 1 value) 0) (or (nth 1 cur-val) 0))))
1762 (setq all-diff (- (or (nth 2 value) 0) (or (nth 2 cur-val) 0)))
1763 (setq diffs (list new-diff unread-diff all-diff))
1764 (unless (and (nth 0 cur-val)
1765 (equal diffs '(0 0 0)))
1766 (wl-folder-set-entity-info name value entity-hashtb)
1768 (with-current-buffer buffer
1770 (setq entity-list (wl-folder-search-entity-list-by-name
1771 name wl-folder-entity))
1773 (wl-folder-update-group (car entity-list) diffs)
1774 (setq entity-list (cdr entity-list)))
1775 (goto-char (point-min))
1776 (while (wl-folder-buffer-search-entity name)
1777 (wl-folder-update-line value))))))))
1779 (defun wl-folder-update-unread (folder unread)
1780 ; (save-window-excursion
1781 (let ((buf (get-buffer wl-folder-buffer-name))
1784 ;;(fld (elmo-string folder))
1785 value newvalue entity-list)
1786 ;;; Update folder-info
1787 ;;; (elmo-folder-set-info-hashtb fld nil nil nil unread)
1788 (setq cur-unread (or (nth 1 (wl-folder-get-entity-info folder)) 0))
1789 (setq unread-diff (- (or unread 0) cur-unread))
1790 (setq value (wl-folder-get-entity-info folder))
1791 (setq newvalue (list (nth 0 value)
1794 (wl-folder-set-entity-info folder newvalue)
1795 (setq wl-folder-info-alist-modified t)
1797 (not (eq unread-diff 0)))
1799 (with-current-buffer buf
1801 (setq entity-list (wl-folder-search-entity-list-by-name
1802 folder wl-folder-entity))
1804 (wl-folder-update-group (car entity-list) (list 0
1807 (setq entity-list (cdr entity-list)))
1808 (goto-char (point-min))
1809 (while (wl-folder-buffer-search-entity folder)
1810 (wl-folder-update-line newvalue))))))));)
1812 (defun wl-folder-create-entity-hashtb (entity &optional hashtb reconst)
1813 (let ((hashtb (or hashtb (elmo-make-hash wl-folder-entity-id)))
1814 (entities (list entity))
1817 (setq entity (wl-pop entities))
1821 (wl-push entities entity-stack))
1822 (setq entities (nth 2 entity)))
1824 (when (not (and reconst
1825 (wl-folder-get-entity-info entity)))
1826 (wl-folder-set-entity-info entity
1830 (setq entities (wl-pop entity-stack))))
1833 ;; Unsync number is reserved.
1834 ;;(defun wl-folder-reconstruct-entity-hashtb (entity &optional hashtb id-name)
1835 ;; (let* ((hashtb (or hashtb (elmo-make-hash wl-folder-entity-id)))
1836 ;; (entities (list entity))
1839 ;; (setq entity (wl-pop entities))
1843 ;; (wl-folder-set-id-name (wl-folder-get-entity-id (car entity))
1846 ;; (wl-push entities entity-stack))
1847 ;; (setq entities (nth 2 entity))
1849 ;; ((stringp entity)
1850 ;; (wl-folder-set-entity-info entity
1851 ;; (wl-folder-get-entity-info entity)
1854 ;; (wl-folder-set-id-name (wl-folder-get-entity-id entity)
1857 ;; (setq entities (wl-pop entity-stack))))
1860 (defun wl-folder-create-newsgroups-from-nntp-access (entity)
1861 (let ((flist (nth 2 entity))
1866 ((consp (car flist))
1867 (wl-folder-create-newsgroups-from-nntp-access (car flist)))
1870 (elmo-nntp-folder-group-internal
1871 (wl-folder-get-elmo-folder (car flist)))))))
1872 (setq flist (cdr flist)))
1875 (defun wl-folder-create-newsgroups-hashtb (entity &optional is-list info)
1876 "Create NNTP group hashtable for ENTITY."
1877 (let ((entities (if is-list entity (list entity)))
1878 entity-stack folder-list newsgroups newsgroup make-hashtb)
1879 (and info (message "Creating newsgroups..."))
1881 (setq entity (wl-pop entities))
1884 (if (eq (nth 1 entity) 'access)
1885 (when (eq (elmo-folder-type-internal
1886 (elmo-make-folder (car entity))) 'nntp)
1887 (wl-append newsgroups
1888 (wl-folder-create-newsgroups-from-nntp-access entity))
1889 (setq make-hashtb t))
1891 (wl-push entities entity-stack))
1892 (setq entities (nth 2 entity))))
1894 (setq folder-list (elmo-folder-get-primitive-list
1895 (elmo-make-folder entity)))
1897 (when (and (eq (elmo-folder-type-internal (car folder-list))
1899 (setq newsgroup (elmo-nntp-folder-group-internal
1900 (car folder-list))))
1901 (wl-append newsgroups (list (elmo-string newsgroup))))
1902 (setq folder-list (cdr folder-list)))))
1904 (setq entities (wl-pop entity-stack))))
1905 (and info (message "Creating newsgroups...done"))
1906 (if (or newsgroups make-hashtb)
1907 (elmo-setup-subscribed-newsgroups newsgroups))))
1909 (defun wl-folder-get-path (entity target-id &optional string)
1910 (let ((entities (list entity))
1911 entity-stack result-path)
1915 (setq entity (wl-pop entities))
1918 (if (and (or (not string) (string= string (car entity)))
1919 ;; don't use eq, `id' is string on Nemacs.
1920 (equal target-id (wl-folder-get-entity-id (car entity))))
1922 (wl-push target-id result-path))
1923 (wl-push (wl-folder-get-entity-id (car entity)) result-path))
1924 (wl-push entities entity-stack)
1925 (setq entities (nth 2 entity)))
1927 (if (and (or (not string) (string= string entity))
1928 ;; don't use eq, `id' is string on Nemacs.
1929 (equal target-id (wl-folder-get-entity-id entity)))
1931 (wl-push target-id result-path)))))
1933 (while (and entity-stack
1935 (setq result-path (cdr result-path))
1936 (setq entities (wl-pop entity-stack)))))))))
1938 (defun wl-folder-create-group-alist (entity)
1940 (let ((flist (nth 2 entity))
1941 (cur-alist (list (cons (car entity) nil)))
1944 (if (consp (car flist))
1945 (wl-append append-alist
1946 (wl-folder-create-group-alist (car flist))))
1947 (setq flist (cdr flist)))
1948 (append cur-alist append-alist))))
1950 (defun wl-folder-init-info-hashtb ()
1951 (let ((info-alist (and wl-folder-info-save
1952 (elmo-msgdb-finfo-load))))
1953 (elmo-folder-info-make-hashtb
1955 wl-folder-entity-hashtb)))
1956 ;;; (wl-folder-resume-entity-hashtb-by-finfo
1957 ;;; wl-folder-entity-hashtb
1960 (defun wl-folder-cleanup-variables ()
1961 (setq wl-folder-entity nil
1962 wl-folder-entity-hashtb nil
1963 wl-folder-entity-id-name-hashtb nil
1964 wl-folder-group-alist nil
1965 wl-folder-petname-alist nil
1966 wl-folder-newsgroups-hashtb nil
1967 wl-fldmgr-cut-entity-list nil
1968 wl-fldmgr-modified nil
1969 wl-fldmgr-modified-access-list nil
1973 (defun wl-make-plugged-alist ()
1974 (let ((entity-list (wl-folder-get-entity-list wl-folder-entity))
1975 (add (not wl-reset-plugged-alist)))
1977 (elmo-folder-set-plugged
1978 (wl-folder-get-elmo-folder (car entity-list)) wl-plugged add)
1979 (setq entity-list (cdr entity-list)))
1980 ;; smtp posting server
1981 (when wl-smtp-posting-server
1982 (elmo-set-plugged wl-plugged
1983 wl-smtp-posting-server ; server
1984 (or (and (boundp 'smtp-service) smtp-service)
1986 wl-smtp-connection-type
1987 nil nil "smtp" add))
1988 ;; nntp posting server
1989 (when wl-nntp-posting-server
1990 (elmo-set-plugged wl-plugged
1991 wl-nntp-posting-server
1992 wl-nntp-posting-stream-type
1993 wl-nntp-posting-port
1994 nil nil "nntp" add))
1995 (run-hooks 'wl-make-plugged-hook)))
1997 (defvar wl-folder-init-function 'wl-local-folder-init)
1999 (defun wl-folder-init ()
2000 "Return top-level folder entity."
2004 (funcall wl-folder-init-function))
2005 (run-hooks 'wl-folder-init-hook))
2007 (defun wl-local-folder-init ()
2008 "Initialize local folder."
2009 (message "Initializing folder...")
2010 (setq wl-folder-entity (wl-folder-create-folder-entity))
2011 (message "Initializing folder...done"))
2013 (defun wl-folder-get-realname (petname)
2017 wl-folder-petname-alist))
2020 (defun wl-folder-get-petname (name)
2024 wl-folder-petname-alist))
2027 (defun wl-folder-get-entity-with-petname ()
2028 (let ((alist wl-folder-petname-alist)
2029 (hashtb (copy-sequence wl-folder-entity-hashtb)))
2031 (wl-folder-set-entity-info (cdar alist) nil hashtb)
2032 (setq alist (cdr alist)))
2035 (defun wl-folder-get-newsgroups (folder)
2036 "Return Newsgroups field value string for FOLDER newsgroup.
2037 If FOLDER is multi, return comma separated string (cross post)."
2038 (let ((nlist (elmo-folder-newsgroups
2039 (wl-folder-get-elmo-folder folder))))
2041 (list nil nil (mapconcat 'identity nlist ","))
2044 (defun wl-folder-guess-mailing-list-by-refile-rule (entity)
2045 "Return ML address guess by FOLDER.
2046 Use `wl-subscribed-mailing-list' and `wl-refile-rule-alist'."
2048 (elmo-folder-get-primitive-list
2049 (wl-folder-get-elmo-folder entity)))
2051 (while (setq fld (car flist))
2052 (setq mladdr (wl-folder-guess-mailing-list-by-refile-rule-subr
2053 (elmo-folder-name-internal fld)))
2055 (setq to (if (stringp to)
2056 (concat to ", " mladdr)
2058 (setq flist (cdr flist)))
2063 (defun wl-folder-guess-mailing-list-by-refile-rule-subr (entity)
2064 (unless (memq (elmo-folder-type entity)
2066 (let ((rules wl-refile-rule-alist)
2069 (if (or (and (stringp (car (car rules)))
2070 (string-match "[Tt]o" (car (car rules))))
2071 (and (listp (car (car rules)))
2072 (elmo-string-matched-member "to" (car (car rules))
2074 (setq toalist (append toalist (cdr (car rules)))))
2075 (setq rules (cdr rules)))
2076 (setq tokey (car (rassoc entity toalist)))
2077 ;;; (setq histkey (car (rassoc folder wl-refile-alist)))
2078 ;; case-ignore search `wl-subscribed-mailing-list'
2080 (elmo-string-matched-member tokey wl-subscribed-mailing-list t)))))
2082 (defun wl-folder-guess-mailing-list-by-folder-name (entity)
2083 "Return ML address guess by FOLDER name's last hierarchy.
2084 Use `wl-subscribed-mailing-list'."
2086 (elmo-folder-get-primitive-list
2087 (wl-folder-get-elmo-folder entity)))
2089 (while (setq fld (car flist))
2090 (setq mladdr (wl-folder-guess-mailing-list-by-folder-name-subr
2091 (elmo-folder-name-internal fld)))
2093 (setq to (if (stringp to)
2094 (concat to ", " mladdr)
2096 (setq flist (cdr flist)))
2101 (defun wl-folder-guess-mailing-list-by-folder-name-subr (entity)
2102 (when (memq (elmo-folder-type entity)
2103 '(localdir imap4 maildir))
2104 (let (key foldername)
2105 ;; Get foldername and Remove folder type symbol.
2106 (setq foldername (substring entity 1))
2107 (if (string-match "@" foldername)
2108 (setq foldername (substring foldername 0 (match-beginning 0))))
2109 (when (string-match "[^\\./]+$" foldername)
2110 (setq key (regexp-quote
2111 (concat (substring foldername (match-beginning 0)) "@")))
2112 (elmo-string-matched-member
2113 key wl-subscribed-mailing-list 'case-ignore)))))
2115 (defun wl-folder-update-diff-line (diffs)
2116 (let ((inhibit-read-only t)
2117 (buffer-read-only nil)
2119 cur-unread new-unread
2124 (setq id (get-text-property (point) 'wl-folder-entity-id))
2125 (when (looking-at "^[ ]*\\(.*\\):\\([0-9\\*-]*\\)/\\([0-9\\*-]*\\)/\\([0-9\\*]*\\)")
2126 ;;(looking-at "^[ ]*\\([^\\[].+\\):\\([0-9\\*-]*/[0-9\\*-]*/[0-9\\*]*\\)")
2127 (setq cur-new (string-to-int
2128 (wl-match-buffer 2)))
2129 (setq cur-unread (string-to-int
2130 (wl-match-buffer 3)))
2131 (setq cur-all (string-to-int
2132 (wl-match-buffer 4)))
2133 (delete-region (match-beginning 2)
2135 (goto-char (match-beginning 2))
2136 (insert (format "%s/%s/%s"
2137 (setq new-new (+ cur-new (nth 0 diffs)))
2138 (setq new-unread (+ cur-unread (nth 1 diffs)))
2139 (setq new-all (+ cur-all (nth 2 diffs)))))
2140 (put-text-property (match-beginning 2) (point)
2141 'wl-folder-entity-id id)
2142 (if wl-use-highlight-mouse-line
2143 (put-text-property (match-beginning 2) (point)
2144 'mouse-face 'highlight))
2145 (wl-highlight-folder-group-line (list new-new new-unread new-all))
2146 (setq buffer-read-only t)
2147 (set-buffer-modified-p nil)))))
2149 (defun wl-folder-update-line (nums &optional is-group)
2150 (let ((inhibit-read-only t)
2151 (buffer-read-only nil)
2155 (setq id (get-text-property (point) 'wl-folder-entity-id))
2156 (if (looking-at "^[ ]*\\(.*\\):\\([0-9\\*-]*/[0-9\\*-]*/[0-9\\*]*\\)")
2157 ;;; (looking-at "^[ ]*\\([^\\[].+\\):\\([0-9\\*-]*/[0-9\\*-]*/[0-9\\*]*\\)")
2159 (delete-region (match-beginning 2)
2161 (goto-char (match-beginning 2))
2162 (insert (format "%s/%s/%s"
2163 (or (nth 0 nums) "*")
2164 (or (and (nth 0 nums)(nth 1 nums)
2165 (+ (nth 0 nums)(nth 1 nums)))
2167 (or (nth 2 nums) "*")))
2168 (put-text-property (match-beginning 2) (point)
2169 'wl-folder-entity-id id)
2171 ;; update only colors
2172 (wl-highlight-folder-group-line nums)
2173 (wl-highlight-folder-current-line nums))
2175 (set-buffer-modified-p nil))))))
2177 (defun wl-folder-goto-folder (&optional arg)
2179 (wl-folder-goto-folder-subr nil arg))
2181 (defun wl-folder-goto-folder-subr (&optional folder sticky)
2183 (let (summary-buf fld-name entity id error-selecting)
2184 ;;; (setq fld-name (wl-folder-get-entity-from-buffer))
2185 ;;; (if (or (null fld-name)
2186 ;;; (assoc fld-name wl-folder-group-alist))
2187 (setq fld-name wl-default-folder)
2188 (setq fld-name (or folder
2189 (wl-summary-read-folder fld-name)))
2190 (if (and (setq entity
2191 (wl-folder-search-entity-by-name fld-name
2194 (setq id (wl-folder-get-entity-id entity)))
2195 (wl-folder-set-current-entity-id id))
2196 (setq summary-buf (wl-summary-get-buffer-create fld-name sticky))
2197 (if (or wl-stay-folder-window wl-summary-use-frame)
2198 (wl-folder-select-buffer summary-buf)
2199 (if (and summary-buf
2200 (get-buffer-window summary-buf))
2202 (wl-summary-goto-folder-subr fld-name
2203 (wl-summary-get-sync-range
2204 (wl-folder-get-elmo-folder fld-name))
2207 (defun wl-folder-suspend ()
2209 (run-hooks 'wl-folder-suspend-hook)
2210 (wl-folder-info-save)
2211 (elmo-crosspost-message-alist-save)
2213 ;(if (fboundp 'mmelmo-cleanup-entity-buffers)
2214 ;(mmelmo-cleanup-entity-buffers))
2215 (bury-buffer wl-folder-buffer-name)
2216 (delete-windows-on wl-folder-buffer-name t))
2218 (defun wl-folder-info-save ()
2219 (when (and wl-folder-info-save
2220 wl-folder-info-alist-modified)
2221 (let ((entities (list wl-folder-entity))
2222 entity entity-stack info-alist info)
2224 (setq entity (wl-pop entities))
2228 (wl-push entities entity-stack))
2229 (setq entities (nth 2 entity)))
2231 (when (and (setq info (elmo-folder-get-info
2232 (wl-folder-get-elmo-folder entity)))
2233 (not (equal info '(nil))))
2235 (wl-append info-alist (list (list (elmo-string entity)
2236 (list (nth 3 info) ;; max
2237 (nth 2 info) ;; length
2239 (nth 1 info)) ;; unread
2242 (setq entities (wl-pop entity-stack))))
2243 (elmo-msgdb-finfo-save info-alist)
2244 (setq wl-folder-info-alist-modified nil))))
2246 (defun wl-folder-goto-first-unread-folder (&optional arg)
2248 (let ((entities (list wl-folder-entity))
2249 entity entity-stack ret-val
2254 (setq entity (wl-pop entities))
2258 (wl-push entities entity-stack))
2259 (setq entities (nth 2 entity)))
2261 (if (and (setq finfo (wl-folder-get-entity-info entity))
2262 (and (nth 0 finfo)(nth 1 finfo))
2263 (> (+ (nth 0 finfo)(nth 1 finfo)) 0))
2264 (throw 'done entity))
2265 (wl-append ret-val (list entity))))
2267 (setq entities (wl-pop entity-stack))))))
2271 (wl-folder-jump-folder first-entity)
2273 (wl-folder-goto-folder-subr first-entity))
2274 (message "No unread folder"))))
2276 (defun wl-folder-jump-folder (&optional fld-name noopen)
2279 (setq fld-name (wl-summary-read-folder wl-default-folder)))
2280 (goto-char (point-min))
2282 (wl-folder-open-folder fld-name))
2283 (and (wl-folder-buffer-search-entity fld-name)
2284 (beginning-of-line)))
2286 (defun wl-folder-get-entity-list (entity)
2287 (let ((entities (list entity))
2288 entity-stack ret-val)
2290 (setq entity (wl-pop entities))
2294 (wl-push entities entity-stack))
2295 (setq entities (nth 2 entity)))
2297 (wl-append ret-val (list entity))))
2299 (setq entities (wl-pop entity-stack))))
2302 (defun wl-folder-open-unread-folder (entity)
2304 (let ((alist (wl-folder-get-entity-list entity))
2306 finfo path-list path id)
2308 (when (and (setq finfo (wl-folder-get-entity-info (car alist)))
2309 (nth 0 finfo) (nth 1 finfo)
2310 (> (+ (nth 0 finfo)(nth 1 finfo)) 0))
2311 (setq unread (+ unread (+ (nth 0 finfo)(nth 1 finfo))))
2312 (setq id (wl-folder-get-entity-id (car alist)))
2313 (setq path (delete id (wl-folder-get-path
2317 (if (not (member path path-list))
2318 (wl-append path-list (list path))))
2319 (setq alist (cdr alist)))
2321 (wl-folder-open-folder-sub (car path-list))
2322 (setq path-list (cdr path-list)))
2323 (message "%s unread folder"
2324 (if (> unread 0) unread "No")))))
2326 (defun wl-folder-open-unread-current-entity ()
2328 (let ((entity-name (wl-folder-get-entity-from-buffer))
2329 (group (wl-folder-buffer-group-p)))
2331 (wl-folder-open-unread-folder
2333 (wl-folder-search-group-entity-by-name entity-name
2337 (defun wl-folder-open-only-unread-folder ()
2340 (wl-folder-prev-entity-skip-invalid t)
2341 (wl-folder-get-entity-from-buffer t))))
2342 (wl-folder-open-all-unread-folder)
2344 (goto-char (point-max))
2345 (while (and (re-search-backward
2346 "^[ ]*\\[[-]\\].+:0/0/[0-9-]+" nil t)
2348 (wl-folder-jump-to-current-entity) ;; close it
2350 (wl-folder-move-path id)
2353 (defun wl-folder-open-all-unread-folder (&optional arg)
2356 (wl-folder-prev-entity-skip-invalid t)
2357 (wl-folder-get-entity-from-buffer t))))
2358 (wl-folder-open-unread-folder wl-folder-entity)
2360 (wl-folder-move-path id)
2361 (goto-char (point-min))
2362 (wl-folder-next-unread t))))
2364 (defun wl-folder-open-folder (&optional fld-name)
2367 (setq fld-name (wl-summary-read-folder wl-default-folder)))
2368 (let* ((id (wl-folder-get-entity-id
2369 (wl-folder-search-entity-by-name fld-name wl-folder-entity
2371 (path (and id (wl-folder-get-path wl-folder-entity id))))
2373 (wl-folder-open-folder-sub path))))
2375 (defun wl-folder-open-folder-sub (path)
2376 (let ((inhibit-read-only t)
2377 (buffer-read-only nil)
2381 (goto-char (point-min))
2383 (wl-folder-buffer-search-group
2384 (wl-folder-get-petname
2385 (if (stringp (car path))
2387 (wl-folder-get-folder-name-by-id
2390 (setq path (cdr path))
2391 (if (and (looking-at wl-folder-group-regexp)
2392 (string= "+" (wl-match-buffer 2)));; closed group
2394 (setq indent (wl-match-buffer 1))
2395 (setq name (wl-folder-get-realname (wl-match-buffer 3)))
2396 (setq entity (wl-folder-search-group-entity-by-name
2400 (setcdr (assoc (car entity) wl-folder-group-alist) t)
2401 (if (eq 'access (cadr entity))
2402 (wl-folder-maybe-load-folder-list entity))
2403 (wl-folder-insert-entity indent entity)
2404 (delete-region (save-excursion (beginning-of-line)
2406 (save-excursion (end-of-line)
2408 (set-buffer-modified-p nil))))
2410 (defun wl-folder-open-all-pre ()
2411 (let ((entities (list wl-folder-entity))
2412 entity entity-stack group-entry)
2414 (setq entity (wl-pop entities))
2417 (unless (or (not (setq group-entry
2418 (assoc (car entity) wl-folder-group-alist)))
2420 (setcdr group-entry t)
2421 (when (eq 'access (cadr entity))
2422 (wl-folder-maybe-load-folder-list entity)))
2424 (wl-push entities entity-stack))
2425 (setq entities (nth 2 entity))))
2427 (setq entities (wl-pop entity-stack))))))
2429 (defun wl-folder-open-all (&optional refresh)
2431 (let* ((inhibit-read-only t)
2432 (buffer-read-only nil)
2433 (len (length wl-folder-group-alist))
2438 (wl-folder-prev-entity-skip-invalid t)
2439 (wl-folder-get-entity-from-buffer t)))
2440 (alist wl-folder-group-alist))
2442 (setcdr (pop alist) t))
2444 (wl-folder-insert-entity " " wl-folder-entity)
2445 (wl-folder-move-path id))
2446 (message "Opening all folders...")
2447 (wl-folder-open-all-pre)
2449 (goto-char (point-min))
2450 (while (re-search-forward
2451 "^\\([ ]*\\)\\[\\([+]\\)\\]\\(.+\\):[-0-9-]+/[0-9-]+/[0-9-]+\n"
2453 (setq indent (wl-match-buffer 1))
2454 (setq name (wl-folder-get-realname (wl-match-buffer 3)))
2455 (setq entity (wl-folder-search-group-entity-by-name
2459 (setcdr (assoc (car entity) wl-folder-group-alist) t)
2461 (wl-folder-insert-entity indent entity)
2462 (delete-region (save-excursion (beginning-of-line)
2464 (save-excursion (end-of-line)
2466 (when (> len elmo-display-progress-threshold)
2468 (if (or (zerop (% i 5)) (= i len))
2469 (elmo-display-progress
2470 'wl-folder-open-all "Opening all folders..."
2471 (/ (* i 100) len)))))
2472 (when (> len elmo-display-progress-threshold)
2473 (elmo-display-progress
2474 'wl-folder-open-all "Opening all folders..." 100))))
2475 (message "Opening all folders...done")
2476 (set-buffer-modified-p nil)))
2478 (defun wl-folder-close-all ()
2480 (let ((inhibit-read-only t)
2481 (buffer-read-only nil)
2482 (alist wl-folder-group-alist)
2484 (wl-folder-prev-entity-skip-invalid t)
2485 (wl-folder-get-entity-from-buffer t))))
2487 (setcdr (car alist) nil)
2488 (setq alist (cdr alist)))
2489 (setcdr (assoc (car wl-folder-entity) wl-folder-group-alist) t)
2491 (wl-folder-insert-entity " " wl-folder-entity)
2492 (wl-folder-move-path id)
2494 (set-buffer-modified-p nil)))
2496 (defun wl-folder-open-close ()
2497 "Open or close parent entity."
2501 (if (wl-folder-buffer-group-p)
2502 ;; if group (whether opend or closed.)
2503 (wl-folder-jump-to-current-entity)
2506 (setq indent (save-excursion
2507 (re-search-forward "\\([ ]*\\)." nil t)
2508 (wl-match-buffer 1)))
2509 (while (looking-at indent)
2511 (wl-folder-jump-to-current-entity))))
2513 (defsubst wl-folder-access-subscribe-p (group folder)
2514 (let (subscr regexp match)
2515 (if (setq subscr (wl-get-assoc-list-value
2516 wl-folder-access-subscribe-alist
2519 (setq regexp (mapconcat 'identity (cdr subscr) "\\|"))
2520 (setq match (string-match regexp folder))
2526 (defun wl-folder-update-access-group (entity new-flist)
2527 (let* ((flist (nth 2 entity))
2528 (unsubscribes (nth 3 entity))
2529 (len (+ (length flist) (length unsubscribes)))
2531 diff new-unsubscribes removes
2532 subscribed-list folder group entry)
2533 ;; check subscribed groups
2536 ((listp (car flist)) ;; group
2537 (setq group (elmo-string (caar flist)))
2539 ((assoc group new-flist) ;; found in new-flist
2540 (setq new-flist (delete (assoc group new-flist)
2542 (if (wl-folder-access-subscribe-p (car entity) group)
2543 (wl-append subscribed-list (list (car flist)))
2544 (wl-append new-unsubscribes (list (car flist)))
2547 (setq wl-folder-group-alist
2548 (delete (wl-string-assoc group wl-folder-group-alist)
2549 wl-folder-group-alist))
2550 (wl-append removes (list (list group))))))
2552 (setq folder (elmo-string (car flist)))
2554 ((member folder new-flist) ;; found in new-flist
2555 (setq new-flist (delete folder new-flist))
2556 (if (wl-folder-access-subscribe-p (car entity) folder)
2557 (wl-append subscribed-list (list (car flist)))
2558 (wl-append new-unsubscribes (list folder))
2561 (wl-append removes (list folder))))))
2562 (when (> len elmo-display-progress-threshold)
2564 (if (or (zerop (% i 10)) (= i len))
2565 (elmo-display-progress
2566 'wl-folder-update-access-group "Updating access group..."
2567 (/ (* i 100) len))))
2568 (setq flist (cdr flist)))
2569 ;; check unsubscribed groups
2572 ((listp (car unsubscribes))
2573 (when (setq entry (assoc (caar unsubscribes) new-flist))
2574 (setq new-flist (delete entry new-flist))
2575 (wl-append new-unsubscribes (list (car unsubscribes)))))
2577 (when (member (car unsubscribes) new-flist)
2578 (setq new-flist (delete (car unsubscribes) new-flist))
2579 (wl-append new-unsubscribes (list (car unsubscribes))))))
2580 (when (> len elmo-display-progress-threshold)
2582 (if (or (zerop (% i 10)) (= i len))
2583 (elmo-display-progress
2584 'wl-folder-update-access-group "Updating access group..."
2585 (/ (* i 100) len))))
2586 (setq unsubscribes (cdr unsubscribes)))
2588 (if (or new-flist removes)
2591 (mapcar '(lambda (x)
2592 (cond ((consp x) (list (car x) 'access))
2596 (let ((new-list new-flist))
2598 (if (not (wl-folder-access-subscribe-p
2600 (if (listp (car new-list))
2605 (wl-append new-unsubscribes (list (car new-list)))
2606 (setq new-flist (delete (car new-list) new-flist)))
2608 ((listp (car new-list))
2609 ;; check group exists
2610 (if (wl-string-assoc (caar new-list) wl-folder-group-alist)
2612 (message "%s: group already exists." (caar new-list))
2614 (wl-append new-unsubscribes (list (car new-list)))
2615 (setq new-flist (delete (car new-list) new-flist)))
2616 (wl-append wl-folder-group-alist
2617 (list (cons (caar new-list) nil)))))))
2618 (setq new-list (cdr new-list))))
2620 (message "%d new folder(s)." (length new-flist))
2621 (message "Updating access group...done"))
2622 (wl-append new-flist subscribed-list) ;; new is first
2623 (run-hooks 'wl-folder-update-access-group-hook)
2624 (setcdr (cdr entity) (list new-flist new-unsubscribes))
2625 (list diff new-flist new-unsubscribes removes)))
2627 (defun wl-folder-prefetch-entity (entity)
2628 "Prefetch all new messages in the ENTITY."
2631 (let ((flist (nth 2 entity))
2636 (setq result (wl-folder-prefetch-entity (car flist)))
2637 (setq sum-done (+ sum-done (car result)))
2638 (setq sum-all (+ sum-all (cdr result)))
2639 (setq flist (cdr flist)))
2640 (message "Prefetched %d/%d message(s) in \"%s\"."
2642 (wl-folder-get-petname (car entity)))
2643 (cons sum-done sum-all)))
2645 (let* ((folder (wl-folder-get-elmo-folder entity))
2646 (nums (wl-folder-get-entity-info entity))
2647 (wl-summary-highlight (if (or (wl-summary-sticky-p folder)
2648 (wl-summary-always-sticky-folder-p
2650 wl-summary-highlight))
2651 wl-summary-exit-next-move
2652 wl-auto-select-first ret-val
2654 (setq count (or (car nums) 0))
2655 (setq count (+ count (wl-folder-count-incorporates folder)))
2656 (if (or (null (car nums)) ; unknown
2658 (save-window-excursion
2660 (let ((wl-summary-buffer-name (concat
2661 wl-summary-buffer-name
2662 (symbol-name this-command)))
2663 (wl-summary-use-frame nil)
2664 (wl-summary-always-sticky-folder-list nil))
2665 (wl-summary-goto-folder-subr entity
2666 (wl-summary-get-sync-range
2669 (setq ret-val (wl-summary-incorporate))
2674 (defun wl-folder-count-incorporates (folder)
2675 (let ((marks (elmo-msgdb-mark-load
2676 (elmo-folder-msgdb-path folder)))
2679 (if (member (cadr (car marks))
2680 wl-summary-incorporate-marks)
2682 (setq marks (cdr marks)))
2685 (defun wl-folder-prefetch-current-entity (&optional no-check)
2686 "Prefetch all uncached messages in the folder at position.
2687 If current line is group folder, all subfolders are prefetched."
2690 (let ((entity-name (wl-folder-get-entity-from-buffer))
2691 (group (wl-folder-buffer-group-p))
2692 wl-folder-check-entity-hook
2697 (wl-folder-search-group-entity-by-name entity-name
2701 (wl-folder-check-entity entity))
2702 (wl-folder-prefetch-entity entity)))))
2704 ;(defun wl-folder-drop-unsync-entity (entity)
2705 ; "Drop all unsync messages in the ENTITY."
2708 ; (let ((flist (nth 2 entity)))
2710 ; (wl-folder-drop-unsync-entity (car flist))
2711 ; (setq flist (cdr flist)))))
2713 ; (let ((nums (wl-folder-get-entity-info entity))
2714 ; wl-summary-highlight wl-auto-select-first new)
2715 ; (setq new (or (car nums) 0))
2717 ; (save-window-excursion
2719 ; (let ((wl-summary-buffer-name (concat
2720 ; wl-summary-buffer-name
2721 ; (symbol-name this-command))))
2722 ; (wl-summary-goto-folder-subr entity 'no-sync nil)
2723 ; (wl-summary-drop-unsync)
2724 ; (wl-summary-exit)))))))))
2726 ;(defun wl-folder-drop-unsync-current-entity (&optional force-check)
2727 ; "Drop all unsync messages in the folder at position.
2728 ;If current line is group folder, all subfolders are dropped.
2729 ;If optional arg exists, don't check any folders."
2732 ; (let ((entity-name (wl-folder-get-entity-from-buffer))
2733 ; (group (wl-folder-buffer-group-p))
2734 ; wl-folder-check-entity-hook
2735 ; summary-buf entity)
2736 ; (when (and entity-name
2738 ; "Drop all unsync messages in %s? " entity-name)))
2741 ; (wl-folder-search-group-entity-by-name entity-name
2744 ; (if (null force-check)
2745 ; (wl-folder-check-entity entity))
2746 ; (wl-folder-drop-unsync-entity entity)
2747 ; (message "All unsync messages in %s are dropped!" entity-name)))))
2749 (defun wl-folder-write-current-folder ()
2750 "Write message to current folder's newsgroup or mailing-list.
2751 Call `wl-summary-write-current-folder' with current folder name."
2753 (unless (wl-folder-buffer-group-p)
2754 (wl-summary-write-current-folder
2755 (wl-folder-get-realname (wl-folder-entity-name)))))
2757 (defun wl-folder-mimic-kill-buffer ()
2758 "Kill the current (Folder) buffer with query."
2760 (let ((bufname (read-buffer (format "Kill buffer: (default %s) "
2762 wl-interactive-exit)
2763 (if (or (not bufname)
2764 (string-equal bufname "")
2765 (string-equal bufname (buffer-name)))
2767 (kill-buffer bufname))))
2769 (defun wl-folder-create-subr (folder)
2770 (if (y-or-n-p (format "Folder %s does not exist, create it? "
2771 (elmo-folder-name-internal folder)))
2774 (setq wl-folder-entity-hashtb
2775 (wl-folder-create-entity-hashtb
2776 (elmo-folder-name-internal folder)
2777 wl-folder-entity-hashtb))
2778 (unless (elmo-folder-create folder)
2779 (error "Create folder failed")))
2780 (error "Folder %s is not created" (elmo-folder-name-internal folder))))
2782 (defun wl-folder-confirm-existence (folder &optional force)
2784 (unless (elmo-folder-exists-p folder)
2785 (wl-folder-create-subr folder))
2786 (unless (or (wl-folder-entity-exists-p (elmo-folder-name-internal folder))
2787 (file-exists-p (elmo-folder-msgdb-path folder))
2788 (elmo-folder-exists-p folder))
2789 (wl-folder-create-subr folder))))
2792 (product-provide (provide 'wl-folder) (require 'wl-version))
2794 ;;; wl-folder.el ends here