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)
65 (defvar wl-folder-mode-map nil)
67 (defvar wl-folder-buffer-disp-summary nil)
68 (defvar wl-folder-buffer-cur-entity-id nil)
69 (defvar wl-folder-buffer-last-visited-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-last-visited-entity-id)
76 (make-variable-buffer-local 'wl-folder-buffer-cur-path)
77 (make-variable-buffer-local 'wl-folder-buffer-cur-point)
79 (defconst wl-folder-entity-regexp "^\\([ ]*\\)\\(\\[[\\+-]\\]\\)?\\([^\\[].+\\):[-*0-9]+/[-*0-9]+/[-*0-9]+")
80 (defconst wl-folder-group-regexp "^\\([ ]*\\)\\[\\([\\+-]\\)\\]\\(.+\\):[-0-9-]+/[0-9-]+/[0-9-]+\n")
81 ;; 1:indent 2:opened 3:group-name
82 (defconst wl-folder-unsync-regexp ":[^0\\*][0-9]*/[0-9\\*-]+/[0-9\\*-]+$")
84 (defvar wl-folder-mode-menu-spec
86 ["Enter Current Folder" wl-folder-jump-to-current-entity t]
87 ["Prev Folder" wl-folder-prev-entity t]
88 ["Next Folder" wl-folder-next-entity t]
89 ["Check Current Folder" wl-folder-check-current-entity t]
90 ["Sync Current Folder" wl-folder-sync-current-entity t]
91 ; ["Drop Current Folder" wl-folder-drop-unsync-current-entity t]
92 ["Prefetch Current Folder" wl-folder-prefetch-current-entity t]
94 ["Mark as Read all Current Folder" wl-folder-mark-as-read-all-current-entity t]
95 ["Expire Current Folder" wl-folder-expire-current-entity t]
97 ["Go to Draft Folder" wl-folder-goto-draft-folder t]
98 ["Empty trash" wl-folder-empty-trash t]
99 ["Flush queue" wl-folder-flush-queue t]
101 ["Open All" wl-folder-open-all t]
102 ["Open All Unread folder" wl-folder-open-all-unread-folder t]
103 ["Close All" wl-folder-close-all t]
105 ["Add folder" wl-fldmgr-add t]
106 ["Add group" wl-fldmgr-make-group t]
107 ["Copy" wl-fldmgr-copy t]
108 ["Cut" wl-fldmgr-cut t]
109 ["Paste" wl-fldmgr-yank t]
110 ["Set petname" wl-fldmgr-set-petname t]
111 ["Rename" wl-fldmgr-rename t]
112 ["Save" wl-fldmgr-save-folders t]
114 ["Unsubscribe" wl-fldmgr-unsubscribe t]
115 ["Display all" wl-fldmgr-access-display-all t])
117 ["Write a message" wl-draft t]
118 ["Write for current folder" wl-folder-write-current-folder t]
120 ["Wanderlust NEWS" wl-news t]
122 ["Toggle Plug Status" wl-toggle-plugged t]
123 ["Change Plug Status" wl-plugged-change t]
125 ["Save Current Status" wl-save t]
126 ["Update Status" wl-status-update t]
131 (defun wl-folder-setup-mouse ()
132 (define-key wl-folder-mode-map 'button2 'wl-folder-click)
133 (define-key wl-folder-mode-map 'button4 'wl-folder-prev-entity)
134 (define-key wl-folder-mode-map 'button5 'wl-folder-next-entity)
135 (define-key wl-folder-mode-map [(shift button4)]
136 'wl-folder-prev-unread)
137 (define-key wl-folder-mode-map [(shift button5)]
138 'wl-folder-next-unread))
139 (defun wl-folder-setup-mouse ()
140 (define-key wl-folder-mode-map [mouse-2] 'wl-folder-click)
141 (define-key wl-folder-mode-map [mouse-4] 'wl-folder-prev-entity)
142 (define-key wl-folder-mode-map [mouse-5] 'wl-folder-next-entity)
143 (define-key wl-folder-mode-map [S-mouse-4] 'wl-folder-prev-unread)
144 (define-key wl-folder-mode-map [S-mouse-5] 'wl-folder-next-unread)))
146 (if wl-folder-mode-map
148 (setq wl-folder-mode-map (make-sparse-keymap))
149 (define-key wl-folder-mode-map " " 'wl-folder-jump-to-current-entity)
150 ; (define-key wl-folder-mode-map "\M- " 'wl-folder-open-close)
151 (define-key wl-folder-mode-map "/" 'wl-folder-open-close)
152 (define-key wl-folder-mode-map "\C-m" 'wl-folder-jump-to-current-entity)
153 (define-key wl-folder-mode-map [(shift return)] 'wl-folder-jump-to-current-entity-with-arg)
154 (define-key wl-folder-mode-map "\M-\C-m" 'wl-folder-update-recursive-current-entity)
155 (define-key wl-folder-mode-map "rc" 'wl-folder-mark-as-read-all-region)
156 (define-key wl-folder-mode-map "c" 'wl-folder-mark-as-read-all-current-entity)
157 (define-key wl-folder-mode-map "g" 'wl-folder-goto-folder)
158 (define-key wl-folder-mode-map "G" 'wl-folder-goto-folder-sticky)
159 (define-key wl-folder-mode-map "j" 'wl-folder-jump-to-current-entity)
160 (define-key wl-folder-mode-map "\C-i" 'wl-folder-revisit-last-visited-folder)
161 (define-key wl-folder-mode-map "w" 'wl-draft)
162 (define-key wl-folder-mode-map "W" 'wl-folder-write-current-folder)
163 (define-key wl-folder-mode-map "\C-c\C-o" 'wl-jump-to-draft-buffer)
164 (define-key wl-folder-mode-map "\C-c\C-a" 'wl-addrmgr)
165 (define-key wl-folder-mode-map "\C-c\C-p" 'wl-folder-jump-to-previous-summary)
166 (define-key wl-folder-mode-map "\C-c\C-n" 'wl-folder-jump-to-next-summary)
167 (define-key wl-folder-mode-map "rS" 'wl-folder-sync-region)
168 (define-key wl-folder-mode-map "S" 'wl-folder-sync-current-entity)
169 (define-key wl-folder-mode-map "rs" 'wl-folder-check-region)
170 (define-key wl-folder-mode-map "s" 'wl-folder-check-current-entity)
171 (define-key wl-folder-mode-map "I" 'wl-folder-prefetch-current-entity)
172 ; (define-key wl-folder-mode-map "D" 'wl-folder-drop-unsync-current-entity)
173 (define-key wl-folder-mode-map "p" 'wl-folder-prev-entity)
174 (define-key wl-folder-mode-map "n" 'wl-folder-next-entity)
175 (define-key wl-folder-mode-map "v" 'wl-folder-toggle-disp-summary)
176 (define-key wl-folder-mode-map "P" 'wl-folder-prev-unread)
177 (define-key wl-folder-mode-map "N" 'wl-folder-next-unread)
178 (define-key wl-folder-mode-map "J" 'wl-folder-jump-folder)
179 (define-key wl-folder-mode-map "f" 'wl-folder-goto-first-unread-folder)
180 (define-key wl-folder-mode-map "o" 'wl-folder-open-all-unread-folder)
181 (define-key wl-folder-mode-map "[" 'wl-folder-open-all)
182 (define-key wl-folder-mode-map "]" 'wl-folder-close-all)
183 (define-key wl-folder-mode-map "e" 'wl-folder-expire-current-entity)
184 (define-key wl-folder-mode-map "E" 'wl-folder-empty-trash)
185 (define-key wl-folder-mode-map "F" 'wl-folder-flush-queue)
186 (define-key wl-folder-mode-map "V" 'wl-folder-virtual)
187 (define-key wl-folder-mode-map "?" 'wl-folder-pick)
188 (define-key wl-folder-mode-map "q" 'wl-exit)
189 (define-key wl-folder-mode-map "z" 'wl-folder-suspend)
190 (define-key wl-folder-mode-map "x" 'wl-execute-temp-marks)
191 (define-key wl-folder-mode-map "\M-t" 'wl-toggle-plugged)
192 (define-key wl-folder-mode-map "\C-t" 'wl-plugged-change)
193 (define-key wl-folder-mode-map "<" 'beginning-of-buffer)
194 (define-key wl-folder-mode-map ">" 'end-of-buffer)
196 (define-key wl-folder-mode-map "m" 'wl-fldmgr-mode-map)
197 (define-key wl-folder-mode-map "*" 'wl-fldmgr-make-multi)
198 (define-key wl-folder-mode-map "+" 'wl-fldmgr-make-group)
199 (define-key wl-folder-mode-map "|" 'wl-fldmgr-make-filter)
200 (define-key wl-folder-mode-map "\M-c" 'wl-fldmgr-copy)
201 (define-key wl-folder-mode-map "\M-w" 'wl-fldmgr-copy-region)
202 (define-key wl-folder-mode-map "\C-k" 'wl-fldmgr-cut)
203 (define-key wl-folder-mode-map "\C-w" 'wl-fldmgr-cut-region)
204 (define-key wl-folder-mode-map "\C-y" 'wl-fldmgr-yank)
205 (define-key wl-folder-mode-map "R" 'wl-fldmgr-rename)
206 (define-key wl-folder-mode-map "u" 'wl-fldmgr-unsubscribe)
207 (define-key wl-folder-mode-map "ru" 'wl-fldmgr-unsubscribe-region)
208 (define-key wl-folder-mode-map "U" 'wl-fldmgr-unsubscribe-region)
209 (define-key wl-folder-mode-map "l" 'wl-fldmgr-access-display-normal)
210 (define-key wl-folder-mode-map "L" 'wl-fldmgr-access-display-all)
211 (define-key wl-folder-mode-map "Z" 'wl-status-update)
212 (define-key wl-folder-mode-map "\C-x\C-s" 'wl-save)
213 (define-key wl-folder-mode-map "\M-s" 'wl-save)
214 (define-key wl-folder-mode-map "\C-xk" 'wl-folder-mimic-kill-buffer)
215 (define-key wl-folder-mode-map "\M-\C-a"
216 'wl-folder-goto-top-of-current-folder)
217 (define-key wl-folder-mode-map "\M-\C-e"
218 'wl-folder-goto-bottom-of-current-folder)
220 (wl-folder-setup-mouse)
224 "Menu used in Folder mode."
225 wl-folder-mode-menu-spec))
227 (defmacro wl-folder-unread-regex (group)
228 (` (concat "^[ ]*.+:[0-9\\*-]+/[^0\\*][0-9]*/[0-9\\*-]+$"
233 (defmacro wl-folder-buffer-group-p ()
234 (` (get-text-property (point) 'wl-folder-is-group)))
236 (defun wl-folder-buffer-search-group (group)
237 (let ((prev-point (point))
238 (group-regexp (concat
239 "^\\([ \t]*\\)\\[[\\+-]\\]"
240 (regexp-quote group) ":[-0-9-]+/[0-9-]+/[0-9-]+")))
242 (while (re-search-forward group-regexp nil t)
243 (if (wl-folder-buffer-group-p)
244 (throw 'found (point)))))
246 (goto-char prev-point)
249 (defun wl-folder-buffer-search-entity (folder &optional searchname)
250 (let ((search (or searchname (wl-folder-get-petname folder)))
258 (regexp-quote search) ":[-0-9\\*-]+/[0-9\\*-]+/[0-9\\*-]+")
260 (when (string= (wl-folder-get-entity-from-buffer) folder)
261 (throw 'found result))))))
263 (defsubst wl-folder-get-folder-name-by-id (entity-id &optional hashtb)
264 (and (numberp entity-id)
265 (elmo-get-hash-val (format "#%d" entity-id)
266 (or hashtb wl-folder-entity-id-name-hashtb))))
268 (defsubst wl-folder-set-id-name (entity-id entity &optional hashtb)
269 (and (numberp entity-id)
270 (elmo-set-hash-val (format "#%d" entity-id)
271 entity (or hashtb wl-folder-entity-id-name-hashtb))))
273 (defmacro wl-folder-get-entity-id (entity)
274 `(get-text-property 0 'wl-folder-entity-id ,entity))
276 (defmacro wl-folder-get-entity-from-buffer (&optional getid)
277 `(let ((id (get-text-property (point)
278 'wl-folder-entity-id)))
281 (wl-folder-get-folder-name-by-id id))))
283 (defmacro wl-folder-entity-exists-p (entity &optional hashtb)
284 (` (let ((sym (intern-soft (, entity)
285 (or (, hashtb) wl-folder-entity-hashtb))))
286 (and sym (boundp sym)))))
288 (defmacro wl-folder-clear-entity-info (entity &optional hashtb)
289 (` (elmo-clear-hash-val (, entity) (or (, hashtb) wl-folder-entity-hashtb))))
291 (defmacro wl-folder-get-entity-info (entity &optional hashtb)
292 (` (elmo-get-hash-val (, entity) (or (, hashtb) wl-folder-entity-hashtb))))
294 (defmacro wl-folder-set-entity-info (entity value &optional hashtb)
295 (` (let* ((hashtb (or (, hashtb) wl-folder-entity-hashtb))
296 (info (wl-folder-get-entity-info (, entity) hashtb)))
297 (elmo-set-hash-val (elmo-string (, entity))
298 (if (< (length (, value)) 4)
299 (append (, value) (list (nth 3 info)))
303 (defun wl-folder-persistent-p (folder)
304 (or (and (wl-folder-search-entity-by-name folder wl-folder-entity
308 (let ((li wl-save-folder-list))
310 (if (string-match (car li) folder)
312 (setq li (cdr li)))))
314 (let ((li wl-no-save-folder-list))
316 (if (string-match (car li) folder)
318 (setq li (cdr li))))))))
320 ;;; ELMO folder structure with cache.
321 (defmacro wl-folder-elmo-folder-cache-get (name &optional hashtb)
322 "Returns a elmo folder structure associated with NAME from HASHTB.
323 Default HASHTB is `wl-folder-elmo-folder-hashtb'."
324 (` (elmo-get-hash-val (, name)
325 (or (, hashtb) wl-folder-elmo-folder-hashtb))))
327 (defmacro wl-folder-elmo-folder-cache-put (name folder &optional hashtb)
328 "Get folder elmo folder structure on HASHTB for folder with NAME.
329 Default HASHTB is `wl-folder-elmo-folder-hashtb'."
330 (` (elmo-set-hash-val (, name) (, folder)
331 (or (, hashtb) wl-folder-elmo-folder-hashtb))))
333 (defun wl-draft-get-folder ()
334 "A function to obtain `opened' draft elmo folder structure."
335 (if (and wl-draft-folder-internal
336 (string= (elmo-folder-name-internal wl-draft-folder-internal)
338 wl-draft-folder-internal
339 (setq wl-draft-folder-internal (wl-folder-make-elmo-folder
341 (wl-folder-confirm-existence wl-draft-folder-internal)
342 (elmo-folder-open wl-draft-folder-internal 'load-msgdb)
343 wl-draft-folder-internal))
345 (defun wl-folder-mime-charset (folder-name)
346 (or (wl-get-assoc-list-value wl-folder-mime-charset-alist folder-name)
349 (defun wl-folder-make-elmo-folder (folder-name)
350 (elmo-make-folder folder-name nil (wl-folder-mime-charset folder-name)))
352 (defsubst wl-folder-get-elmo-folder (entity &optional no-cache)
353 "Get elmo folder structure from ENTITY."
354 (let ((name (elmo-string entity)))
356 (wl-folder-make-elmo-folder name)
357 (if (string= name wl-draft-folder)
358 (wl-draft-get-folder)
359 (or (wl-folder-elmo-folder-cache-get name)
360 (let ((folder (wl-folder-make-elmo-folder name)))
361 (wl-folder-elmo-folder-cache-put name folder)
364 (defsubst wl-folder-put-folder-property (beg end id is-group &optional object)
365 (put-text-property beg end 'wl-folder-entity-id id object)
366 (put-text-property beg end 'wl-folder-is-group is-group object))
368 (defun wl-folder-prev-entity ()
372 (defun wl-folder-next-entity ()
376 (defun wl-folder-prev-entity-skip-invalid (&optional hereto)
377 "Move to previous entity. skip unsubscribed or removed entity."
381 (if (re-search-backward wl-folder-entity-regexp nil t)
383 (goto-char (point-min))))
385 (defun wl-folder-next-entity-skip-invalid (&optional hereto)
386 "Move to next entity. skip unsubscribed or removed entity."
391 (if (re-search-forward wl-folder-entity-regexp nil t)
393 (goto-char (point-max))))
395 (defun wl-folder-search-group-entity-by-name (name entity)
396 (wl-folder-search-entity-by-name name entity 'group))
398 (defun wl-folder-search-entity-by-name (name entity &optional type)
399 (let ((entities (list entity))
403 (setq entity (wl-pop entities))
406 (if (and (not (eq type 'folder))
407 (string= name (car entity)))
408 (throw 'done entity))
410 (wl-push entities entity-stack))
411 (setq entities (nth 2 entity)))
412 ((and (not (eq type 'group))
414 (if (string= name entity)
415 (throw 'done entity))))
417 (setq entities (wl-pop entity-stack)))))))
419 (defun wl-folder-search-entity-list-by-name (name entity &optional get-id)
420 (let ((entities (list entity))
421 entity-stack ret-val)
423 (setq entity (wl-pop entities))
427 (wl-push entities entity-stack))
428 (setq entities (nth 2 entity)))
430 (if (string= name entity)
431 (wl-append ret-val (if get-id
432 (list (wl-folder-get-entity-id entity))
435 (setq entities (wl-pop entity-stack))))
438 (defun wl-folder-get-prev-folder (id &optional unread)
439 (let ((name (if (stringp id)
441 (wl-folder-get-folder-name-by-id id)))
442 entity entity-stack last-entity finfo
443 (entities (list wl-folder-entity)))
446 (setq entity (wl-pop entities))
449 ;; (if (and (string= name (car entity))
450 ;; (eq id (wl-folder-get-entity-id (car entity))))
451 ;; (throw 'done last-entity))
453 (wl-push entities entity-stack))
454 (setq entities (nth 2 entity)))
456 (if (and (string= name entity)
457 (eq id (wl-folder-get-entity-id entity)))
458 (throw 'done last-entity))
460 (and (setq finfo (wl-folder-get-entity-info entity))
461 (and (nth 0 finfo)(nth 1 finfo))
462 (> (+ (nth 0 finfo)(nth 1 finfo)) 0)))
463 (setq last-entity entity))))
465 (setq entities (wl-pop entity-stack)))))))
467 (defun wl-folder-get-next-folder (id &optional unread)
468 (let ((name (if (stringp id)
470 (wl-folder-get-folder-name-by-id id)))
471 entity entity-stack found finfo
472 (entities (list wl-folder-entity)))
475 (setq entity (wl-pop entities))
478 ;;; (if (and (string= name (car entity))
479 ;;; (eq id (wl-folder-get-entity-id (car entity))))
482 (wl-push entities entity-stack))
483 (setq entities (nth 2 entity)))
486 (when (or (not unread)
487 (and (setq finfo (wl-folder-get-entity-info entity))
488 (and (nth 0 finfo)(nth 1 finfo))
489 (> (+ (nth 0 finfo)(nth 1 finfo)) 0)))
490 (throw 'done entity))
491 (if (and (string= name entity)
492 (eq id (wl-folder-get-entity-id entity)))
495 (setq entities (wl-pop entity-stack)))))))
497 (defun wl-folder-flush-queue ()
500 (let ((cur-buf (current-buffer))
501 (wl-auto-select-first nil)
504 (if elmo-enable-disconnected-operation
505 (elmo-dop-queue-flush))
506 (if (not (elmo-folder-list-messages
507 (wl-folder-get-elmo-folder wl-queue-folder)))
508 (message "No sending queue exists.")
509 (if wl-stay-folder-window
510 (wl-folder-select-buffer
511 (wl-summary-get-buffer-create wl-queue-folder)))
512 (wl-summary-goto-folder-subr wl-queue-folder 'force-update nil)
514 (wl-draft-queue-flush)
515 (if (get-buffer-window cur-buf)
516 (select-window (get-buffer-window cur-buf)))
518 (if wl-stay-folder-window
519 (wl-folder-toggle-disp-summary 'off wl-queue-folder)
520 (switch-to-buffer cur-buf))))))
522 (defun wl-folder-set-persistent-mark (folder number flag)
523 "Set a persistent mark which corresponds to the specified flag on message."
524 (let ((buffer (wl-summary-get-buffer folder)))
526 (with-current-buffer buffer
527 (wl-summary-set-persistent-mark flag number))
528 ;; Parent buffer does not exist.
529 (let ((elmo-folder (wl-folder-get-elmo-folder folder)))
530 (elmo-folder-open elmo-folder 'load-msgdb)
531 (elmo-folder-set-flag elmo-folder (list wl-draft-parent-number) flag)
532 (elmo-folder-close elmo-folder)))))
534 (defun wl-folder-empty-trash ()
537 (let ((cur-buf (current-buffer))
538 (wl-auto-select-first nil)
540 (wl-summary-goto-folder-subr wl-trash-folder 'force-update)
541 (setq trash-buf (wl-summary-get-buffer-create wl-trash-folder))
542 (if wl-stay-folder-window
543 (wl-folder-select-buffer trash-buf)
544 (switch-to-buffer trash-buf))
546 (setq emptied (wl-summary-delete-all-msgs))
548 (setq wl-thread-entities nil
549 wl-thread-entity-list nil)
550 (if wl-summary-cache-use (wl-summary-save-view-cache))
551 (elmo-folder-commit wl-summary-buffer-elmo-folder))
552 (if (get-buffer-window cur-buf)
553 (select-window (get-buffer-window cur-buf)))
556 (wl-folder-set-folder-updated wl-trash-folder '(0 0 0)))
557 (if wl-stay-folder-window
558 (wl-folder-toggle-disp-summary 'off wl-trash-folder)
559 (switch-to-buffer cur-buf))
561 (kill-buffer trash-buf)))))
563 (defun wl-folder-goto-top-of-current-folder (&optional arg)
564 "Move backward to the top of the current folder group.
565 Optional argument ARG is repeart count."
567 (if (re-search-backward
568 "^ *\\[[\\+-]\\]" nil t (if arg (prefix-numeric-value arg)))
570 (goto-char (point-min))))
572 (defun wl-folder-goto-bottom-of-current-folder (indent)
573 "Move forward to the bottom of the current folder group."
578 (if (looking-at "^ *")
579 (buffer-substring (match-beginning 0)(1- (match-end 0)))
583 (while (re-search-forward "^ *" nil t)
584 (if (<= (length (match-string 0))
588 (goto-char (point-max))))
590 (defun wl-folder-update-group (entity diffs &optional is-group)
592 (let ((path (wl-folder-get-path
594 (wl-folder-get-entity-id entity)
597 ;; delete itself from path
598 (setq path (delete (nth (- (length path) 1) path) path)))
599 (goto-char (point-min))
602 ;; goto the path line.
603 (if (or (eq (car path) 0) ; update desktop
604 (wl-folder-buffer-search-group
605 (wl-folder-get-petname
606 (if (stringp (car path))
608 (wl-folder-get-folder-name-by-id
611 (wl-folder-update-diff-line diffs)
613 (setq path (cdr path)))))))
615 (defun wl-folder-maybe-load-folder-list (entity)
616 (when (null (caddr entity))
618 (elmo-msgdb-flist-load (car entity)))
622 (wl-folder-entity-assign-id entity
623 wl-folder-entity-id-name-hashtb
625 (setq diffs (wl-fldmgr-add-entity-hashtb (list entity)))
626 (unless (equal diffs '(0 0 0))
627 (wl-folder-update-group (car entity) diffs t)))))))
629 (defsubst wl-folder-force-fetch-p (entity)
631 ((consp wl-force-fetch-folders)
632 (wl-string-match-member entity wl-force-fetch-folders))
634 wl-force-fetch-folders)))
636 (defun wl-folder-jump-to-current-entity-with-arg ()
638 (wl-folder-jump-to-current-entity t))
640 (defun wl-folder-jump-to-current-entity (&optional arg)
641 "Enter the current folder. If optional ARG exists, update folder list."
643 (let ((fld-name (wl-folder-get-entity-from-buffer))
644 entity beg end indent opened err)
648 (if (and (wl-folder-buffer-group-p)
649 (looking-at wl-folder-group-regexp))
652 (setq indent (wl-match-buffer 1))
653 (setq opened (wl-match-buffer 2))
654 (if (string= opened "+")
656 (setq entity (wl-folder-search-group-entity-by-name
661 (wl-folder-update-recursive-current-entity entity)
663 (setcdr (assoc (car entity) wl-folder-group-alist) t)
664 (if (eq 'access (cadr entity))
665 (wl-folder-maybe-load-folder-list entity))
666 ;(condition-case errobj
668 (if (or (wl-folder-force-fetch-p (car entity))
670 (eq 'access (cadr entity))
671 (null (caddr entity))))
672 (wl-folder-update-newest indent entity)
673 (wl-folder-insert-entity indent entity))
674 (wl-highlight-folder-path wl-folder-buffer-cur-path))
677 ; (setcdr (assoc fld-name wl-folder-group-alist) nil))
679 ; (elmo-display-error errobj t)
682 ; (setcdr (assoc fld-name wl-folder-group-alist) nil)))
684 (let ((buffer-read-only nil))
685 (delete-region (save-excursion (beginning-of-line)
687 (save-excursion (end-of-line)
693 (progn (wl-folder-goto-bottom-of-current-folder indent)
696 (setq entity (wl-folder-search-group-entity-by-name
699 (let ((buffer-read-only nil))
700 (delete-region beg end))
701 (setcdr (assoc (car entity) wl-folder-group-alist) nil)
702 (wl-folder-insert-entity indent entity) ; insert entity
704 (wl-highlight-folder-path wl-folder-buffer-cur-path)
705 ; (wl-delete-all-overlays)
706 ; (wl-highlight-folder-current-line)
709 (wl-folder-set-current-entity-id
710 (get-text-property (point) 'wl-folder-entity-id))
711 (setq fld-name (wl-folder-get-folder-name-by-id
712 wl-folder-buffer-cur-entity-id))
713 (let ((summary-buf (wl-summary-get-buffer-create fld-name arg))
715 (if (or wl-stay-folder-window wl-summary-use-frame)
716 (wl-folder-select-buffer summary-buf)
718 (get-buffer-window summary-buf))
720 (wl-summary-goto-folder-subr fld-name
721 (wl-summary-get-sync-range
722 (wl-folder-get-elmo-folder fld-name))
724 (set-buffer-modified-p nil))
726 (defun wl-folder-close-entity (entity)
727 (let ((entities (list entity))
730 (setq entity (wl-pop entities))
733 (setcdr (assoc (car entity) wl-folder-group-alist) nil)
735 (wl-push entities entity-stack))
736 (setq entities (nth 2 entity))))
738 (setq entities (wl-pop entity-stack))))))
740 (defun wl-folder-update-recursive-current-entity (&optional entity)
743 (when (and (wl-folder-buffer-group-p)
744 (looking-at wl-folder-group-regexp))
746 ((string= (wl-match-buffer 2) "+")
750 (wl-folder-search-group-entity-by-name
751 (wl-folder-get-entity-from-buffer)
753 (let ((inhibit-read-only t)
754 (entities (list entity))
755 entity-stack err indent)
756 (while (and entities (not err))
757 (setq entity (wl-pop entities))
760 (wl-folder-close-entity entity)
761 (setcdr (assoc (car entity) wl-folder-group-alist) t)
762 (unless (wl-folder-buffer-search-group
763 (wl-folder-get-petname (car entity)))
764 (error "%s: not found group" (car entity)))
765 (setq indent (wl-match-buffer 1))
766 (if (eq 'access (cadr entity))
767 (wl-folder-maybe-load-folder-list entity))
771 (condition-case errobj
772 (wl-folder-update-newest indent entity)
775 (setcdr (assoc (car entity) wl-folder-group-alist) nil))
777 (elmo-display-error errobj t)
780 (setcdr (assoc (car entity) wl-folder-group-alist) nil)))
782 (delete-region (save-excursion (beginning-of-line)
784 (save-excursion (end-of-line)
788 (wl-push entities entity-stack))
789 (setq entities (nth 2 entity))))
791 (setq entities (wl-pop entity-stack)))))
792 (set-buffer-modified-p nil)))
794 (wl-folder-jump-to-current-entity)))))
796 (defun wl-folder-no-auto-check-folder-p (folder)
799 (let ((li wl-auto-check-folder-list))
801 (if (string-match (car li) folder)
803 (setq li (cdr li)))))
806 (let ((li wl-auto-uncheck-folder-list))
808 (if (string-match (car li) folder)
809 (throw 'found t)) ; no check!
810 (setq li (cdr li))))))))
812 (defsubst wl-folder-add-folder-info (pre-value value)
814 (+ (or (nth 0 pre-value) 0) (or (nth 0 value) 0))
815 (+ (or (nth 1 pre-value) 0) (or (nth 1 value) 0))
816 (+ (or (nth 2 pre-value) 0) (or (nth 2 value) 0))))
818 (defun wl-folder-check-entity (entity &optional auto)
819 "Check unsync message number."
820 (let ((start-pos (point))
822 (run-hooks 'wl-folder-check-entity-pre-hook)
823 (if (and (consp entity) ;; group entity
824 wl-folder-check-async) ;; very fast
825 (setq ret-val (wl-folder-check-entity-async entity auto))
829 (let ((flist (if auto
831 'wl-folder-no-auto-check-folder-p
834 (wl-folder-check-entity-pre-hook nil)
835 (wl-folder-check-entity-hook nil)
839 (wl-folder-add-folder-info
841 (wl-folder-check-entity (car flist))))
842 (setq flist (cdr flist)))
843 ;(wl-folder-buffer-search-entity (car entity))
844 ;(wl-folder-update-line ret-val)
847 (message "Checking \"%s\"" entity)
848 (setq ret-val (wl-folder-check-one-entity
850 (goto-char start-pos)
853 (message "Uncheck(unplugged) \"%s\"" entity)))))
855 (message "Checking \"%s\" is done"
856 (if (consp entity) (car entity) entity)))
857 (run-hooks 'wl-folder-check-entity-hook)
860 (defun wl-folder-check-one-entity (entity &optional biff)
861 (let* ((folder (wl-folder-get-elmo-folder entity biff))
862 (nums (condition-case err
864 (if biff (elmo-folder-set-biff-internal folder t))
865 (if (wl-string-match-member entity wl-strict-diff-folders)
866 (elmo-strict-folder-diff folder)
867 (elmo-folder-diff folder)))
869 (signal (car err) (cdr err)))
871 ;; maybe not exist folder.
872 (if (not (elmo-folder-exists-p folder))
873 (wl-folder-create-subr folder)
874 (signal (car err) (cdr err))))))
875 (new (elmo-diff-new nums))
876 (unread (elmo-diff-unread nums))
877 (all (elmo-diff-all nums)))
878 (if (and (eq wl-folder-notify-deleted 'sync)
879 (or (and new (> 0 new))
880 (and unread (> 0 unread))
881 (and all (> 0 all))))
883 (wl-folder-sync-entity entity)
884 (setq nums (elmo-folder-diff folder)
885 new (elmo-diff-new nums)
886 unread (elmo-diff-unread nums)
887 all (elmo-diff-all nums)))
888 (unless wl-folder-notify-deleted
889 (setq new (and new (max 0 new))
890 unread (and unread (max 0 unread))
891 all (and all (max 0 all))))
892 (setq unread (if unread
893 (- unread (or new 0))
894 (or (elmo-folder-get-info-unread folder)
895 (cdr (assq 'unread (elmo-folder-count-flags folder)))
897 (wl-folder-entity-hashtb-set wl-folder-entity-hashtb entity
898 (list new unread all)
899 (get-buffer wl-folder-buffer-name)))
900 (setq wl-folder-info-alist-modified t)
902 (list new unread all)))
904 (defun wl-folder-check-entity-async (entity &optional auto)
905 (let ((elmo-nntp-groups-async t)
908 'wl-folder-no-auto-check-folder-p
909 (wl-folder-get-entity-list entity))
910 (wl-folder-get-entity-list entity)))
911 (nntp-connection-keys nil)
912 name folder folder-list
918 (setq folder (wl-folder-get-elmo-folder (car elist)))
919 (if (not (elmo-folder-plugged-p folder))
920 (message "Uncheck \"%s\"" (car elist))
922 (elmo-folder-get-primitive-list folder))
923 (cond ((elmo-folder-contains-type folder 'nntp)
924 (wl-append async-folder-list (list folder))
926 (when (eq (elmo-folder-type-internal (car folder-list))
930 (elmo-net-folder-server-internal
932 (setq server (elmo-net-folder-server-internal
934 (message "Checking on \"%s\"" server))
935 (setq nntp-connection-keys
936 (elmo-nntp-get-folders-info-prepare
938 nntp-connection-keys)))
939 (setq folder-list (cdr folder-list))))
941 (wl-append sync-folder-list (list folder)))))
942 (setq elist (cdr elist)))
943 ;; check local entity at first
944 (while (setq folder (pop sync-folder-list))
945 (if (not (elmo-folder-plugged-p folder))
946 (message "Uncheck \"%s\"" (elmo-folder-name-internal folder))
947 (message "Checking \"%s\"" (elmo-folder-name-internal folder))
949 (wl-folder-add-folder-info
951 (wl-folder-check-one-entity (elmo-folder-name-internal
955 ;; check network entity at last
956 (when async-folder-list
957 (elmo-nntp-get-folders-info nntp-connection-keys)
958 (while (setq folder (pop async-folder-list))
959 (if (not (elmo-folder-plugged-p folder))
960 (message "Uncheck \"%s\"" (elmo-folder-name-internal folder))
961 (message "Checking \"%s\"" (elmo-folder-name-internal folder))
963 (wl-folder-add-folder-info
965 (wl-folder-check-one-entity (elmo-folder-name-internal
972 (defun wl-folder-resume-entity-hashtb-by-finfo (entity-hashtb info-alist)
973 "Resume unread info for entity alist."
976 (setq info (nth 1 (car info-alist)))
977 (wl-folder-set-entity-info (caar info-alist)
978 (list (nth 2 info)(nth 3 info)(nth 1 info))
980 (setq info-alist (cdr info-alist)))))
982 (defun wl-folder-move-path (path)
983 (let ((fp (if (consp path)
986 (wl-folder-get-path wl-folder-entity path))))
987 (goto-char (point-min))
990 (when (equal (car fp)
991 (wl-folder-get-entity-from-buffer t))
993 (setq wl-folder-buffer-cur-point (point)))
995 (and wl-folder-buffer-cur-point
996 (goto-char wl-folder-buffer-cur-point))))
998 (defun wl-folder-set-current-entity-id (entity-id)
999 (let* ((buf (get-buffer wl-folder-buffer-name))
1000 (buf-win (get-buffer-window buf)))
1002 (save-current-buffer
1003 (save-selected-window
1005 (select-window buf-win)
1007 (when (and wl-folder-buffer-cur-entity-id
1008 (not (eq wl-folder-buffer-cur-entity-id entity-id)))
1009 (setq wl-folder-buffer-last-visited-entity-id wl-folder-buffer-cur-entity-id))
1010 (setq wl-folder-buffer-cur-entity-id entity-id)
1011 (setq wl-folder-buffer-cur-path
1012 (wl-folder-get-path wl-folder-entity entity-id))
1013 (wl-highlight-folder-path wl-folder-buffer-cur-path)
1014 (and wl-folder-move-cur-folder
1015 wl-folder-buffer-cur-point
1016 (goto-char wl-folder-buffer-cur-point)))))))
1018 (defun wl-folder-check-current-entity ()
1019 "Check folder at position.
1020 If current line is group folder, check all sub entries."
1022 (let* ((entity-name (wl-folder-get-entity-from-buffer))
1023 (group (wl-folder-buffer-group-p))
1024 (desktop (string= entity-name wl-folder-desktop-name)))
1026 (wl-folder-check-entity
1028 (wl-folder-search-group-entity-by-name entity-name
1033 (defun wl-folder-sync-entity (entity &optional unread-only)
1034 "Synchronize the msgdb of ENTITY."
1037 (let ((flist (nth 2 entity)))
1039 (wl-folder-sync-entity (car flist) unread-only)
1040 (setq flist (cdr flist)))))
1042 (let* ((folder (wl-folder-get-elmo-folder entity))
1043 (nums (wl-folder-get-entity-info entity))
1044 (new (or (car nums) 0))
1045 (unread (or (cadr nums) 0)))
1046 (when (or (not unread-only)
1047 (or (> new 0) (> unread 0)))
1048 (let ((summary (wl-summary-get-buffer entity))
1049 (range (wl-summary-get-sync-range folder)))
1051 (save-selected-window
1052 (with-current-buffer summary
1053 (let ((win (get-buffer-window summary t)))
1055 (select-window win)))
1056 (wl-summary-sync 'unset-cursor range)
1057 (wl-summary-save-status)))
1058 (elmo-folder-open folder 'load-msgdb)
1061 (elmo-folder-synchronize folder nil (eq range 'all))
1062 (wl-folder-set-folder-updated
1066 (or (cdr (assq 'unread (elmo-folder-count-flags folder)))
1068 (elmo-folder-length folder))))
1069 (elmo-folder-close folder)))))))))
1071 (defun wl-folder-sync-current-entity (&optional unread-only)
1072 "Synchronize the folder at position.
1073 If current line is group folder, check all subfolders."
1076 (let ((entity-name (wl-folder-get-entity-from-buffer))
1077 (group (wl-folder-buffer-group-p)))
1078 (when (and entity-name
1079 (y-or-n-p (format "Sync %s? " entity-name)))
1080 (wl-folder-sync-entity
1082 (wl-folder-search-group-entity-by-name entity-name
1086 (message "Syncing %s is done!" entity-name)))))
1088 (defun wl-folder-mark-as-read-all-entity (entity)
1089 "Mark as read all messages in the ENTITY."
1092 (let ((flist (nth 2 entity)))
1094 (wl-folder-mark-as-read-all-entity (car flist))
1095 (setq flist (cdr flist)))))
1097 (let* ((folder (wl-folder-get-elmo-folder entity))
1098 (nums (wl-folder-get-entity-info entity))
1099 (new (or (car nums) 0))
1100 (unread (or (cadr nums) 0)))
1101 (when (or (> new 0) (> unread 0))
1102 (let ((summary (wl-summary-get-buffer entity))
1103 (range (wl-summary-get-sync-range folder)))
1105 (save-selected-window
1106 (with-current-buffer summary
1107 (let ((win (get-buffer-window summary t)))
1109 (select-window win)))
1110 (wl-summary-sync 'unset-cursor range)
1111 (wl-summary-mark-as-read-all)
1112 (wl-summary-save-status)))
1113 (elmo-folder-open folder 'load-msgdb)
1116 (elmo-folder-synchronize folder nil (eq range 'all))
1117 (elmo-folder-unset-flag
1119 (elmo-folder-list-flagged folder 'unread 'in-msgdb)
1121 (wl-folder-set-folder-updated
1123 (list 0 0 (elmo-folder-length folder))))
1124 (elmo-folder-close folder)))))))))
1126 (defun wl-folder-mark-as-read-all-current-entity ()
1127 "Mark as read all messages in the folder at position.
1128 If current line is group folder, all subfolders are marked."
1131 (let ((entity-name (wl-folder-get-entity-from-buffer))
1132 (group (wl-folder-buffer-group-p))
1134 (when (and entity-name
1135 (y-or-n-p (format "Mark all messages in %s as read? "
1137 (wl-folder-mark-as-read-all-entity
1139 (wl-folder-search-group-entity-by-name entity-name
1142 (message "All messages in %s are marked!" entity-name)))))
1144 (defun wl-folder-check-region (beg end)
1153 (let ((inhibit-read-only t)
1155 (while (< (point) end)
1156 ;; normal folder entity
1157 (if (looking-at "^[\t ]*\\([^\\[]+\\):\\(.*\\)\n")
1159 (setq entity (wl-folder-get-entity-from-buffer))
1160 (if (not (elmo-folder-plugged-p (wl-folder-get-elmo-folder
1162 (message "Uncheck %s" entity)
1163 (message "Checking %s" entity)
1164 (wl-folder-check-one-entity entity)
1169 (defun wl-folder-sync-region (beg end)
1178 (while (< (point) end)
1179 ;; normal folder entity
1180 (if (looking-at "^[\t ]*\\([^\\[]+\\):\\(.*\\)\n")
1182 (let ((inhibit-read-only t)
1184 (setq entity (wl-folder-get-entity-from-buffer))
1185 (wl-folder-sync-entity entity)
1186 (message "Syncing %s is done!" entity)
1191 (defun wl-folder-mark-as-read-all-region (beg end)
1200 (while (< (point) end)
1201 ;; normal folder entity
1202 (if (looking-at "^[\t ]*\\([^\\[]+\\):\\(.*\\)\n")
1204 (let ((inhibit-read-only t)
1206 (setq entity (wl-folder-get-entity-from-buffer))
1207 (wl-folder-mark-as-read-all-entity entity)
1208 (message "All messages in %s are marked!" entity)
1213 (defsubst wl-create-access-init-load-p (folder)
1214 (let ((no-load-regexp (when (and
1215 (not wl-folder-init-load-access-folders)
1216 wl-folder-init-no-load-access-folders)
1217 (mapconcat 'identity
1218 wl-folder-init-no-load-access-folders
1220 (load-regexp (and wl-folder-init-load-access-folders
1221 (mapconcat 'identity
1222 wl-folder-init-load-access-folders
1224 (cond (load-regexp (string-match load-regexp folder))
1225 (t (not (and no-load-regexp
1226 (string-match no-load-regexp folder)))))))
1228 (defun wl-create-access-folder-entity (name)
1230 (when (wl-create-access-init-load-p name)
1231 (setq flists (elmo-msgdb-flist-load name)) ; load flist.
1232 (setq flist (car flists))
1234 (when (consp (car flist))
1235 (setcdr (cdar flist)
1236 (wl-create-access-folder-entity (caar flist))))
1237 (setq flist (cdr flist)))
1240 (defun wl-create-folder-entity-from-buffer ()
1241 "Create folder entity recursively."
1243 ((looking-at "^[ \t]*$") ; blank line
1244 (goto-char (+ 1(match-end 0)))
1246 ((looking-at "^#.*$") ; comment
1247 (goto-char (+ 1 (match-end 0)))
1249 ((looking-at "^[\t ]*\\(.+\\)[\t ]*{[\t ]*$") ; group definition
1250 (let (name entity flist)
1251 (setq name (wl-match-buffer 1))
1252 (goto-char (+ 1 (match-end 0)))
1253 (while (setq entity (wl-create-folder-entity-from-buffer))
1254 (unless (eq entity 'ignore)
1255 (wl-append flist (list entity))))
1256 (if (looking-at "^[\t ]*}[\t ]*$") ; end of group
1258 (goto-char (+ 1 (match-end 0)))
1259 (if (wl-string-assoc name wl-folder-petname-alist)
1260 (error "%s already defined as petname" name))
1261 (list name 'group flist))
1262 (error "Syntax error in folder definition"))))
1263 ((looking-at "^[\t ]*\\([^\t \n]+\\)[\t ]*/$") ; access it!
1265 (setq name (wl-match-buffer 1))
1266 (goto-char (+ 1 (match-end 0)))
1267 ; (condition-case ()
1269 ; (setq flist (elmo-list-folders name)))
1270 ; (error (message "Access to folder %s failed." name)))
1271 ;; (setq flist (elmo-msgdb-flist-load name)) ; load flist.
1272 ;; (setq unsublist (nth 1 flist))
1273 ;; (setq flist (car flist))
1274 ;; (list name 'access flist unsublist)))
1275 (append (list name 'access) (wl-create-access-folder-entity name))))
1276 ;((looking-at "^[\t ]*\\([^\t \n}]+\\)[\t ]*\\(\"[^\"]*\"\\)?[\t ]*$") ; normal folder entity
1277 ((looking-at "^[\t ]*=[ \t]+\\([^\n]+\\)$"); petname definition
1278 (goto-char (+ 1 (match-end 0)))
1279 (let ((rest (elmo-match-buffer 1))
1281 (when (string-match "\\(\"[^\"]*\"\\)[\t ]*$" rest)
1282 (setq petname (elmo-delete-char ?\" (elmo-match-string 1 rest)))
1283 (setq rest (substring rest 0 (match-beginning 0))))
1284 (when (string-match "^[\t ]*\\(.*[^\t ]+\\)[\t ]+$" rest)
1285 (wl-folder-append-petname (elmo-match-string 1 rest)
1288 ((looking-at "^[ \t]*}[ \t]*$") ; end of group
1290 ((looking-at "^.*$") ; normal folder entity
1291 (goto-char (+ 1 (match-end 0)))
1292 (let ((rest (elmo-match-buffer 0))
1294 (if (string-match "\\(\"[^\"]*\"\\)[\t ]*$" rest)
1296 (setq petname (elmo-delete-char ?\" (elmo-match-string 1 rest)))
1297 (setq rest (substring rest 0 (match-beginning 0)))
1298 (when (string-match "^[\t ]*\\(.*[^\t ]+\\)[\t ]+$" rest)
1299 (wl-folder-append-petname
1300 (setq realname (elmo-match-string 1 rest))
1303 (if (string-match "^[\t ]*\\(.+\\)$" rest)
1304 (elmo-match-string 1 rest)
1307 (defun wl-folder-create-folder-entity ()
1308 "Create folder entries."
1309 (let ((tmp-buf (get-buffer-create " *wl-folder-tmp*"))
1313 (with-current-buffer tmp-buf
1315 (insert-file-contents wl-folders-file)
1316 (goto-char (point-min))
1317 (while (and (not (eobp))
1318 (setq entity (wl-create-folder-entity-from-buffer)))
1319 (unless (eq entity 'ignore)
1320 (wl-append ret-val (list entity)))))
1321 (kill-buffer tmp-buf))
1323 (setq ret-val (list wl-folder-desktop-name 'group ret-val))))
1325 (defun wl-folder-entity-assign-id (entity &optional hashtb on-noid)
1326 (let ((hashtb (or hashtb
1327 (setq wl-folder-entity-id-name-hashtb
1328 (elmo-make-hash wl-folder-entity-id))))
1329 (entities (list entity))
1332 (setq entity (wl-pop entities))
1335 (when (not (and on-noid
1336 (get-text-property 0
1337 'wl-folder-entity-id
1339 (wl-folder-put-folder-property
1340 0 (length (car entity))
1344 (wl-folder-set-id-name wl-folder-entity-id
1345 (car entity) hashtb)
1346 (setq wl-folder-entity-id (+ 1 wl-folder-entity-id)))
1348 (wl-push entities entity-stack))
1349 (setq entities (nth 2 entity)))
1351 (when (not (and on-noid
1352 (get-text-property 0
1353 'wl-folder-entity-id
1355 (wl-folder-put-folder-property
1360 (wl-folder-set-id-name wl-folder-entity-id
1362 (setq wl-folder-entity-id (+ 1 wl-folder-entity-id)))))
1364 (setq entities (wl-pop entity-stack))))))
1366 (defun wl-folder-click (e)
1371 (wl-folder-jump-to-current-entity)))
1373 (defun wl-folder-select-buffer (buffer)
1374 (let ((gbw (get-buffer-window buffer))
1377 (progn (select-window gbw)
1379 (unless wl-summary-use-frame
1382 (split-window-horizontally wl-folder-window-width)
1386 (if wl-summary-use-frame
1387 (switch-to-buffer-other-frame buffer)
1388 (switch-to-buffer buffer))
1391 (defun wl-folder-toggle-disp-summary (&optional arg folder)
1393 (if (or (and folder (assoc folder wl-folder-group-alist))
1394 (and (interactive-p) (wl-folder-buffer-group-p)))
1395 (error "This command is not available on Group"))
1397 (let (wl-auto-select-first
1398 (wl-stay-folder-window t))
1401 (setq wl-folder-buffer-disp-summary t))
1403 (setq wl-folder-buffer-disp-summary nil)
1404 ;; hide wl-summary window.
1405 (let ((cur-buf (current-buffer))
1406 (summary-buffer (wl-summary-get-buffer folder)))
1407 (when summary-buffer
1408 (wl-folder-select-buffer summary-buffer)
1410 (select-window (get-buffer-window cur-buf))))
1412 (setq wl-folder-buffer-disp-summary
1413 (not wl-folder-buffer-disp-summary))
1414 (let ((cur-buf (current-buffer))
1416 (when (looking-at "^[ ]*\\([^\\[].+\\):.*\n")
1417 (setq folder-name (wl-folder-get-entity-from-buffer))
1418 (if wl-folder-buffer-disp-summary
1420 (wl-folder-select-buffer
1421 (wl-summary-get-buffer-create folder-name))
1423 (wl-summary-goto-folder-subr folder-name 'no-sync nil)
1424 (select-window (get-buffer-window cur-buf))))
1425 (let ((summary-buffer (wl-summary-get-buffer folder-name)))
1426 (when summary-buffer
1427 (wl-folder-select-buffer summary-buffer)
1429 (select-window (get-buffer-window cur-buf))))))))))
1431 (defun wl-folder-prev-unsync ()
1432 "Move cursor to the previous unsync folder."
1435 (setq start-point (point))
1437 (if (re-search-backward wl-folder-unsync-regexp nil t)
1439 (goto-char start-point)
1440 (message "No more unsync folder"))))
1442 (defun wl-folder-next-unsync (&optional plugged)
1443 "Move cursor to the next unsync."
1445 (let (start-point entity)
1446 (setq start-point (point))
1449 (while (re-search-forward wl-folder-unsync-regexp nil t)
1450 (if (or (wl-folder-buffer-group-p)
1453 (wl-folder-get-entity-from-buffer))
1454 (elmo-folder-plugged-p entity))
1457 (goto-char start-point)
1458 (message "No more unsync folder"))))
1460 (defun wl-folder-prev-unread (&optional group)
1461 "Move cursor to the previous unread folder."
1464 (setq start-point (point))
1466 (if (re-search-backward (wl-folder-unread-regex group) nil t)
1469 (wl-folder-get-entity-from-buffer))
1470 (goto-char start-point)
1471 (message "No more unread folder")
1474 (defun wl-folder-next-unread (&optional group)
1475 "Move cursor to the next unread folder."
1478 (setq start-point (point))
1480 (if (re-search-forward (wl-folder-unread-regex group) nil t)
1483 (wl-folder-get-entity-from-buffer))
1484 (goto-char start-point)
1485 (message "No more unread folder")
1488 (defun wl-folder-mode ()
1489 "Major mode for Wanderlust Folder.
1490 See Info under Wanderlust for full documentation.
1493 \\{wl-folder-mode-map}
1495 Entering Folder mode calls the value of `wl-folder-mode-hook'."
1497 (setq major-mode 'wl-folder-mode)
1498 (setq mode-name "Folder")
1499 (use-local-map wl-folder-mode-map)
1500 (setq buffer-read-only t)
1501 (setq inhibit-read-only nil)
1502 (setq truncate-lines t)
1503 (setq wl-folder-buffer-cur-entity-id nil
1504 wl-folder-buffer-cur-path nil
1505 wl-folder-buffer-cur-point nil)
1506 (wl-mode-line-buffer-identification)
1507 (easy-menu-add wl-folder-mode-menu)
1508 ;; This hook may contain the functions `wl-folder-init-icons' and
1509 ;; `wl-setup-folder' for reasons of system internal to accord
1510 ;; facilities for the Emacs variants.
1511 (run-hooks 'wl-folder-mode-hook))
1513 (defun wl-folder-append-petname (realname petname)
1514 (let ((pentry (wl-string-assoc realname wl-folder-petname-alist)))
1516 (setq wl-folder-petname-alist
1517 (delete pentry wl-folder-petname-alist))))
1518 (wl-append wl-folder-petname-alist
1519 (list (cons realname petname))))
1522 (let (initialize folder-buf)
1523 (if (setq folder-buf (get-buffer wl-folder-buffer-name))
1524 (if wl-folder-use-frame
1526 (save-selected-window
1527 (dolist (frame (visible-frame-list))
1528 (select-frame frame)
1529 (if (get-buffer-window folder-buf)
1530 (setq select-frame frame))))
1532 (select-frame select-frame)
1533 (switch-to-buffer folder-buf)))
1534 (switch-to-buffer folder-buf))
1535 (if wl-folder-use-frame
1537 (switch-to-buffer-other-frame
1538 (get-buffer-create wl-folder-buffer-name))
1539 (let ((frame (selected-frame)))
1540 (setq wl-delete-startup-frame-function
1542 (setq wl-delete-startup-frame-function nil)
1543 (let ((frame ,frame))
1544 (if (eq (selected-frame) frame)
1545 (delete-frame frame)))))))
1546 (switch-to-buffer (get-buffer-create wl-folder-buffer-name)))
1547 (set-buffer wl-folder-buffer-name)
1550 (unless wl-folder-entity
1552 (setq wl-folder-entity-id 0)
1553 (wl-folder-entity-assign-id wl-folder-entity)
1554 (setq wl-folder-entity-hashtb
1555 (wl-folder-create-entity-hashtb wl-folder-entity))
1556 (setq wl-folder-elmo-folder-hashtb (elmo-make-hash wl-folder-entity-id))
1557 (setq wl-folder-group-alist
1558 (wl-folder-create-group-alist wl-folder-entity))
1559 (setq wl-folder-newsgroups-hashtb
1560 (wl-folder-create-newsgroups-hashtb wl-folder-entity))
1561 (wl-folder-init-info-hashtb)
1562 (let ((inhibit-read-only t)
1563 (buffer-read-only nil))
1565 (setcdr (assoc (car wl-folder-entity) wl-folder-group-alist) t)
1567 (wl-folder-insert-entity " " wl-folder-entity)))
1569 (set-buffer-modified-p nil)
1570 (setq initialize t))
1573 (defun wl-folder-auto-check ()
1574 "Check and update folders in `wl-auto-check-folder-name'."
1576 (when (get-buffer wl-folder-buffer-name)
1577 (switch-to-buffer wl-folder-buffer-name)
1579 ((eq wl-auto-check-folder-name 'none))
1580 ((or (consp wl-auto-check-folder-name)
1581 (stringp wl-auto-check-folder-name))
1582 (let ((folder-list (if (consp wl-auto-check-folder-name)
1583 wl-auto-check-folder-name
1584 (list wl-auto-check-folder-name)))
1587 (if (setq entity (wl-folder-search-entity-by-name
1590 (wl-folder-check-entity entity 'auto))
1591 (setq folder-list (cdr folder-list)))))
1593 (wl-folder-check-entity wl-folder-entity 'auto)))))
1595 (defun wl-folder-set-folder-updated (name value)
1597 (let ((buf (get-buffer wl-folder-buffer-name)))
1599 (wl-folder-entity-hashtb-set
1600 wl-folder-entity-hashtb name value buf))
1601 (setq wl-folder-info-alist-modified t))))
1603 (defun wl-folder-calc-finfo (entity)
1604 ;; calcurate finfo without inserting.
1605 (let ((entities (list entity))
1607 new unread all nums)
1609 (setq entity (wl-pop entities))
1613 (wl-push entities entity-stack))
1614 (setq entities (nth 2 entity)))
1616 (setq nums (wl-folder-get-entity-info entity))
1617 (setq new (+ (or new 0) (or (nth 0 nums) 0)))
1618 (setq unread (+ (or unread 0)
1619 (or (and (nth 0 nums)(nth 1 nums)
1620 (+ (nth 0 nums)(nth 1 nums))) 0)))
1621 (setq all (+ (or all 0) (or (nth 2 nums) 0)))))
1623 (setq entities (wl-pop entity-stack))))
1624 (list new unread all)))
1626 (defsubst wl-folder-make-save-access-list (list)
1627 (mapcar '(lambda (x)
1630 (list (elmo-string (car x)) 'access))
1635 (defun wl-folder-update-newest (indent entity)
1636 (let (ret-val new unread all)
1639 (let ((inhibit-read-only t)
1640 (buffer-read-only nil)
1641 (flist (nth 2 entity))
1642 (as-opened (cdr (assoc (car entity) wl-folder-group-alist)))
1647 (let (update-flist flist-unsub new-flist removed group-name-end)
1648 (when (and (eq (cadr entity) 'access)
1649 (elmo-folder-plugged-p
1650 (wl-folder-get-elmo-folder (car entity))))
1651 (message "Fetching folder entries...")
1652 (when (setq new-flist
1653 (elmo-folder-list-subfolders
1654 (wl-folder-get-elmo-folder (car entity))
1655 (wl-string-match-member
1657 wl-folder-hierarchy-access-folders)))
1659 (wl-folder-update-access-group entity new-flist))
1660 (setq flist (nth 1 update-flist))
1661 (when (car update-flist) ;; diff
1662 (setq flist-unsub (nth 2 update-flist))
1663 (setq removed (nth 3 update-flist))
1664 (elmo-msgdb-flist-save
1667 (wl-folder-make-save-access-list flist)
1668 (wl-folder-make-save-access-list flist-unsub)))
1669 (wl-folder-entity-assign-id
1671 wl-folder-entity-id-name-hashtb
1673 (setq wl-folder-entity-hashtb
1674 (wl-folder-create-entity-hashtb
1676 wl-folder-entity-hashtb
1678 (setq wl-folder-newsgroups-hashtb
1680 (wl-folder-create-newsgroups-hashtb
1682 wl-folder-newsgroups-hashtb))))
1683 (message "Fetching folder entries...done"))
1684 (wl-folder-insert-entity indent entity))))))))
1686 (defun wl-folder-insert-entity (indent entity &optional onlygroup)
1687 (let (ret-val new unread all)
1690 (let ((inhibit-read-only t)
1691 (buffer-read-only nil)
1692 (flist (nth 2 entity))
1693 (as-opened (cdr (assoc (car entity) wl-folder-group-alist)))
1696 ;;; (insert indent "[" (if as-opened "-" "+") "]" (car entity) "\n")
1697 ;;; (save-excursion (forward-line -1)
1698 ;;; (wl-highlight-folder-current-line))
1702 (let (update-flist flist-unsub new-flist removed group-name-end)
1703 ;;; (when (and (eq (cadr entity) 'access)
1705 ;;; (message "fetching folder entries...")
1706 ;;; (when (setq new-flist
1707 ;;; (elmo-list-folders
1708 ;;; (elmo-string (car entity))
1709 ;;; (wl-string-member
1711 ;;; wl-folder-hierarchy-access-folders)
1713 ;;; (setq update-flist
1714 ;;; (wl-folder-update-access-group entity new-flist))
1715 ;;; (setq flist (nth 1 update-flist))
1716 ;;; (when (car update-flist) ;; diff
1717 ;;; (setq flist-unsub (nth 2 update-flist))
1718 ;;; (setq removed (nth 3 update-flist))
1719 ;;; (elmo-msgdb-flist-save
1722 ;;; (wl-folder-make-save-access-list flist)
1723 ;;; (wl-folder-make-save-access-list flist-unsub)))
1725 ;;; ;; reconstruct wl-folder-entity-id-name-hashtb and
1726 ;;; ;; wl-folder-entity-hashtb
1728 ;;; (wl-folder-entity-assign-id
1730 ;;; wl-folder-entity-id-name-hashtb
1732 ;;; (setq wl-folder-entity-hashtb
1733 ;;; (wl-folder-create-entity-hashtb
1735 ;;; wl-folder-entity-hashtb
1737 ;;; (setq wl-folder-newsgroups-hashtb
1739 ;;; (wl-folder-create-newsgroups-hashtb
1741 ;;; wl-folder-newsgroups-hashtb))))
1742 ;;; (message "fetching folder entries...done"))
1743 (insert indent "[" (if as-opened "-" "+") "]"
1744 (if (eq (cadr entity) 'access)
1745 (wl-folder-get-petname (car entity))
1747 (setq group-name-end (point))
1749 (wl-folder-put-folder-property
1751 (get-text-property 0 'wl-folder-entity-id (car entity))
1757 wl-folder-removed-mark
1758 (if (listp (car removed))
1759 (concat "[+]" (caar removed))
1762 (save-excursion (forward-line -1)
1763 (wl-highlight-folder-current-line))
1764 (setq removed (cdr removed)))
1765 (remove-text-properties beg (point) '(wl-folder-entity-id)))
1766 (elmo-with-progress-display
1767 (wl-folder-insert-entity (length flist))
1768 (format "Inserting group %s" (car entity))
1771 (wl-folder-insert-entity
1772 (concat indent " ") (car flist)))
1773 (setq new (+ (or new 0) (or (nth 0 ret-val) 0)))
1774 (setq unread (+ (or unread 0) (or (nth 1 ret-val) 0)))
1775 (setq all (+ (or all 0) (or (nth 2 ret-val) 0)))
1776 (elmo-progress-notify 'wl-folder-insert-entity)
1777 (setq flist (cdr flist))))
1779 (goto-char group-name-end)
1780 (delete-region (point) (save-excursion (end-of-line)
1782 (insert (format ":%d/%d/%d" (or new 0)
1783 (or unread 0) (or all 0)))
1784 (setq ret-val (list new unread all))
1785 (wl-highlight-folder-current-line ret-val)))
1786 (setq ret-val (wl-folder-calc-finfo entity))
1787 (insert indent "[" (if as-opened "-" "+") "]"
1788 (if (eq (cadr entity) 'access)
1789 (wl-folder-get-petname (car entity))
1792 (or (nth 0 ret-val) 0)
1793 (or (nth 1 ret-val) 0)
1794 (or (nth 2 ret-val) 0))
1796 (wl-folder-put-folder-property
1798 (get-text-property 0 'wl-folder-entity-id (car entity))
1800 (save-excursion (forward-line -1)
1801 (wl-highlight-folder-current-line ret-val)))))
1803 (let* ((inhibit-read-only t)
1804 (buffer-read-only nil)
1805 (nums (wl-folder-get-entity-info entity))
1808 (insert indent (wl-folder-get-petname entity)
1809 (format ":%s/%s/%s\n"
1810 (or (setq new (nth 0 nums)) "*")
1811 (or (setq unread (and (nth 0 nums)(nth 1 nums)
1812 (+ (nth 0 nums)(nth 1 nums))))
1814 (or (setq all (nth 2 nums)) "*")))
1815 (wl-folder-put-folder-property
1817 (get-text-property 0 'wl-folder-entity-id entity)
1819 (save-excursion (forward-line -1)
1820 (wl-highlight-folder-current-line nums))
1821 (setq ret-val (list new unread all)))))
1822 (set-buffer-modified-p nil)
1825 (defun wl-folder-check-all ()
1827 (wl-folder-check-entity wl-folder-entity))
1829 (defun wl-folder-entity-hashtb-set (entity-hashtb name value buffer)
1830 (let ((cur-val (wl-folder-get-entity-info name entity-hashtb))
1835 (setq new-diff (- (or (nth 0 value) 0) (or (nth 0 cur-val) 0)))
1838 (- (or (nth 1 value) 0) (or (nth 1 cur-val) 0))))
1839 (setq all-diff (- (or (nth 2 value) 0) (or (nth 2 cur-val) 0)))
1840 (setq diffs (list new-diff unread-diff all-diff))
1841 (unless (and (nth 0 cur-val)
1842 (equal diffs '(0 0 0)))
1843 (wl-folder-set-entity-info name value entity-hashtb)
1845 (with-current-buffer buffer
1847 (let ((entity-list (wl-folder-search-entity-list-by-name
1848 name wl-folder-entity)))
1850 (wl-folder-update-group (car entity-list) diffs)
1851 (setq entity-list (cdr entity-list))))
1852 (goto-char (point-min))
1853 (while (wl-folder-buffer-search-entity name)
1854 (wl-folder-update-line value))))))))
1856 (defun wl-folder-update-unread (folder unread)
1857 (let ((buf (get-buffer wl-folder-buffer-name))
1858 (value (wl-folder-get-entity-info folder))
1862 ;;; Update folder-info
1863 ;;; (elmo-folder-set-info-hashtb fld nil nil nil unread)
1864 (setq cur-unread (or (nth 1 value) 0))
1865 (setq unread-diff (- (or unread 0) cur-unread))
1866 (setq newvalue (list (nth 0 value)
1869 (wl-folder-set-entity-info folder newvalue)
1870 (setq wl-folder-info-alist-modified t)
1872 (not (eq unread-diff 0)))
1874 (with-current-buffer buf
1876 (let ((entity-list (wl-folder-search-entity-list-by-name
1877 folder wl-folder-entity)))
1879 (wl-folder-update-group (car entity-list) (list 0
1882 (setq entity-list (cdr entity-list))))
1883 (goto-char (point-min))
1884 (while (wl-folder-buffer-search-entity folder)
1885 (wl-folder-update-line newvalue))))))))
1887 (defun wl-folder-create-entity-hashtb (entity &optional hashtb reconst)
1888 (let ((hashtb (or hashtb (elmo-make-hash wl-folder-entity-id)))
1889 (entities (list entity))
1892 (setq entity (wl-pop entities))
1896 (wl-push entities entity-stack))
1897 (setq entities (nth 2 entity)))
1899 (when (not (and reconst
1900 (wl-folder-get-entity-info entity)))
1901 (wl-folder-set-entity-info entity
1905 (setq entities (wl-pop entity-stack))))
1908 ;; Unsync number is reserved.
1909 ;;(defun wl-folder-reconstruct-entity-hashtb (entity &optional hashtb id-name)
1910 ;; (let* ((hashtb (or hashtb (elmo-make-hash wl-folder-entity-id)))
1911 ;; (entities (list entity))
1914 ;; (setq entity (wl-pop entities))
1918 ;; (wl-folder-set-id-name (wl-folder-get-entity-id (car entity))
1921 ;; (wl-push entities entity-stack))
1922 ;; (setq entities (nth 2 entity))
1924 ;; ((stringp entity)
1925 ;; (wl-folder-set-entity-info entity
1926 ;; (wl-folder-get-entity-info entity)
1929 ;; (wl-folder-set-id-name (wl-folder-get-entity-id entity)
1932 ;; (setq entities (wl-pop entity-stack))))
1935 (defun wl-folder-create-newsgroups-from-nntp-access (entity)
1936 (let ((flist (nth 2 entity))
1941 ((consp (car flist))
1942 (wl-folder-create-newsgroups-from-nntp-access (car flist)))
1945 (elmo-nntp-folder-group-internal
1946 (wl-folder-get-elmo-folder (car flist)))))))
1947 (setq flist (cdr flist)))
1950 (defun wl-folder-create-newsgroups-hashtb (entity &optional is-list info)
1951 "Create NNTP group hashtable for ENTITY."
1952 (let ((entities (if is-list entity (list entity)))
1953 entity-stack folder-list newsgroups newsgroup make-hashtb)
1954 (and info (message "Creating newsgroups..."))
1956 (setq entity (wl-pop entities))
1959 (if (eq (nth 1 entity) 'access)
1960 (when (eq (elmo-folder-type-internal
1961 (elmo-make-folder (car entity))) 'nntp)
1962 (wl-append newsgroups
1963 (wl-folder-create-newsgroups-from-nntp-access entity))
1964 (setq make-hashtb t))
1966 (wl-push entities entity-stack))
1967 (setq entities (nth 2 entity))))
1969 (setq folder-list (elmo-folder-get-primitive-list
1970 (elmo-make-folder entity)))
1972 (when (and (eq (elmo-folder-type-internal (car folder-list))
1974 (setq newsgroup (elmo-nntp-folder-group-internal
1975 (car folder-list))))
1976 (wl-append newsgroups (list (elmo-string newsgroup))))
1977 (setq folder-list (cdr folder-list)))))
1979 (setq entities (wl-pop entity-stack))))
1980 (and info (message "Creating newsgroups...done"))
1981 (if (or newsgroups make-hashtb)
1982 (elmo-setup-subscribed-newsgroups newsgroups))))
1984 (defun wl-folder-get-path (entity target-id &optional string)
1985 (let ((entities (list entity))
1986 entity-stack result-path)
1990 (setq entity (wl-pop entities))
1993 (if (and (or (not string) (string= string (car entity)))
1994 (eq target-id (wl-folder-get-entity-id (car entity))))
1996 (wl-push target-id result-path))
1997 (wl-push (wl-folder-get-entity-id (car entity)) result-path))
1998 (wl-push entities entity-stack)
1999 (setq entities (nth 2 entity)))
2001 (if (and (or (not string) (string= string entity))
2002 (eq target-id (wl-folder-get-entity-id entity)))
2004 (wl-push target-id result-path)))))
2006 (while (and entity-stack
2008 (setq result-path (cdr result-path))
2009 (setq entities (wl-pop entity-stack)))))))))
2011 (defun wl-folder-create-group-alist (entity)
2013 (let ((flist (nth 2 entity))
2014 (cur-alist (list (cons (car entity) nil)))
2017 (if (consp (car flist))
2018 (wl-append append-alist
2019 (wl-folder-create-group-alist (car flist))))
2020 (setq flist (cdr flist)))
2021 (append cur-alist append-alist))))
2023 (defun wl-folder-init-info-hashtb ()
2024 (let ((info-alist (and wl-folder-info-save
2025 (elmo-msgdb-finfo-load))))
2026 (elmo-folder-info-make-hashtb
2028 wl-folder-entity-hashtb)))
2029 ;;; (wl-folder-resume-entity-hashtb-by-finfo
2030 ;;; wl-folder-entity-hashtb
2033 (defun wl-folder-cleanup-variables ()
2034 (setq wl-folder-entity nil
2035 wl-folder-entity-hashtb nil
2036 wl-folder-entity-id-name-hashtb nil
2037 wl-folder-group-alist nil
2038 wl-folder-petname-alist nil
2039 wl-folder-newsgroups-hashtb nil
2040 wl-fldmgr-cut-entity-list nil
2041 wl-fldmgr-modified nil
2042 wl-fldmgr-modified-access-list nil
2046 (defun wl-make-plugged-alist ()
2047 (let ((entity-list (wl-folder-get-entity-list wl-folder-entity))
2048 (add (not wl-reset-plugged-alist)))
2050 (elmo-folder-set-plugged
2051 (wl-folder-get-elmo-folder (car entity-list)) wl-plugged add)
2052 (setq entity-list (cdr entity-list)))
2053 ;; smtp posting server
2054 (when wl-smtp-posting-server
2055 (elmo-set-plugged wl-plugged
2056 wl-smtp-posting-server ; server
2057 (or wl-smtp-posting-port
2058 (and (boundp 'smtp-service) smtp-service)
2060 wl-smtp-connection-type
2061 nil nil "smtp" add))
2062 ;; nntp posting server
2063 (when wl-nntp-posting-server
2064 (elmo-set-plugged wl-plugged
2065 wl-nntp-posting-server
2066 wl-nntp-posting-port
2067 wl-nntp-posting-stream-type
2068 nil nil "nntp" add))
2069 (run-hooks 'wl-make-plugged-hook)))
2071 (defvar wl-folder-init-function 'wl-local-folder-init)
2073 (defun wl-folder-init ()
2074 "Return top-level folder entity."
2078 (funcall wl-folder-init-function))
2079 (run-hooks 'wl-folder-init-hook))
2081 (defun wl-local-folder-init ()
2082 "Initialize local folder."
2083 (message "Initializing folder...")
2084 (setq wl-folder-entity (wl-folder-create-folder-entity))
2085 (message "Initializing folder...done"))
2087 (defun wl-folder-get-realname (petname)
2091 wl-folder-petname-alist))
2094 (defun wl-folder-get-petname (name)
2098 wl-folder-petname-alist))
2101 (defun wl-folder-get-entity-with-petname ()
2102 (let ((alist wl-folder-petname-alist)
2103 (hashtb (copy-sequence wl-folder-entity-hashtb)))
2105 (wl-folder-set-entity-info (cdar alist) nil hashtb)
2106 (setq alist (cdr alist)))
2109 (defun wl-folder-get-newsgroups (folder)
2110 "Return Newsgroups field value string for FOLDER newsgroup.
2111 If FOLDER is multi, return comma separated string (cross post)."
2112 (let ((nlist (elmo-folder-newsgroups
2113 (wl-folder-get-elmo-folder folder))))
2115 (list nil nil (mapconcat 'identity nlist ","))
2118 (defun wl-folder-guess-mailing-list-by-refile-rule (entity)
2119 "Return ML address guess by ENTITY.
2120 Use `wl-subscribed-mailing-list' and `wl-refile-rule-alist'."
2122 (elmo-folder-get-primitive-list
2123 (wl-folder-get-elmo-folder entity)))
2125 (while (setq fld (car flist))
2126 (setq mladdr (wl-folder-guess-mailing-list-by-refile-rule-subr
2127 (elmo-folder-name-internal fld)))
2129 (setq to (if (stringp to)
2130 (concat to ", " mladdr)
2132 (setq flist (cdr flist)))
2137 (defun wl-folder-guess-mailing-list-by-refile-rule-subr (entity)
2138 (unless (memq (elmo-folder-type entity)
2140 (let ((rules wl-refile-rule-alist)
2143 (if (or (and (stringp (car (car rules)))
2144 (string-match "[Tt]o" (car (car rules))))
2145 (and (listp (car (car rules)))
2146 (elmo-string-matched-member "to" (car (car rules))
2148 (setq toalist (append toalist (cdr (car rules)))))
2149 (setq rules (cdr rules)))
2150 (setq tokey (car (rassoc entity toalist)))
2151 ;;; (setq histkey (car (rassoc folder wl-refile-alist)))
2152 ;; case-ignore search `wl-subscribed-mailing-list'
2154 (elmo-string-matched-member tokey wl-subscribed-mailing-list t)))))
2156 (defun wl-folder-guess-mailing-list-by-folder-name (entity)
2157 "Return ML address guess by ENTITY name's last hierarchy.
2158 Use `wl-subscribed-mailing-list'."
2160 (elmo-folder-get-primitive-list
2161 (wl-folder-get-elmo-folder entity)))
2163 (while (setq fld (car flist))
2164 (setq mladdr (wl-folder-guess-mailing-list-by-folder-name-subr
2165 (elmo-folder-name-internal fld)))
2167 (setq to (if (stringp to)
2168 (concat to ", " mladdr)
2170 (setq flist (cdr flist)))
2175 (defun wl-folder-guess-mailing-list-by-folder-name-subr (entity)
2176 (when (memq (elmo-folder-type entity)
2177 '(localdir imap4 maildir))
2178 (let (key foldername)
2179 ;; Get foldername and Remove folder type symbol.
2180 (setq foldername (substring entity 1))
2181 (if (string-match "@" foldername)
2182 (setq foldername (substring foldername 0 (match-beginning 0))))
2183 (when (string-match "[^\\./]+$" foldername)
2184 (setq key (regexp-quote
2185 (concat (substring foldername (match-beginning 0)) "@")))
2186 (elmo-string-matched-member
2187 key wl-subscribed-mailing-list 'case-ignore)))))
2189 (defun wl-folder-update-diff-line (diffs)
2190 (let ((inhibit-read-only t)
2191 (buffer-read-only nil)
2193 cur-unread new-unread
2198 (setq id (get-text-property (point) 'wl-folder-entity-id))
2199 (setq is-group (get-text-property (point) 'wl-folder-is-group))
2200 (when (looking-at "^[ ]*\\(.*\\):\\([0-9\\*-]*\\)/\\([0-9\\*-]*\\)/\\([0-9\\*]*\\)")
2201 ;;(looking-at "^[ ]*\\([^\\[].+\\):\\([0-9\\*-]*/[0-9\\*-]*/[0-9\\*]*\\)")
2202 (setq cur-new (string-to-int
2203 (wl-match-buffer 2)))
2204 (setq cur-unread (string-to-int
2205 (wl-match-buffer 3)))
2206 (setq cur-all (string-to-int
2207 (wl-match-buffer 4)))
2208 (delete-region (match-beginning 2)
2210 (goto-char (match-beginning 2))
2211 (insert (format "%s/%s/%s"
2212 (setq new-new (+ cur-new (nth 0 diffs)))
2213 (setq new-unread (+ cur-unread (nth 1 diffs)))
2214 (setq new-all (+ cur-all (nth 2 diffs)))))
2215 (wl-folder-put-folder-property (match-beginning 2) (point) id is-group)
2216 (if wl-use-highlight-mouse-line
2217 (put-text-property (match-beginning 2) (point)
2218 'mouse-face 'highlight))
2219 (wl-highlight-folder-group-line (list new-new new-unread new-all))
2220 (setq buffer-read-only t)
2221 (set-buffer-modified-p nil)))))
2223 (defun wl-folder-update-line (nums &optional is-group)
2224 (let ((inhibit-read-only t)
2225 (buffer-read-only nil)
2229 (setq id (get-text-property (point) 'wl-folder-entity-id))
2230 (setq is-group (get-text-property (point) 'wl-folder-is-group))
2231 (if (looking-at "^[ ]*\\(.*\\):\\([0-9\\*-]*/[0-9\\*-]*/[0-9\\*]*\\)")
2232 ;;; (looking-at "^[ ]*\\([^\\[].+\\):\\([0-9\\*-]*/[0-9\\*-]*/[0-9\\*]*\\)")
2234 (delete-region (match-beginning 2)
2236 (goto-char (match-beginning 2))
2237 (insert (format "%s/%s/%s"
2238 (or (nth 0 nums) "*")
2239 (or (and (nth 0 nums)(nth 1 nums)
2240 (+ (nth 0 nums)(nth 1 nums)))
2242 (or (nth 2 nums) "*")))
2243 (wl-folder-put-folder-property (match-beginning 2) (point) id is-group)
2245 ;; update only colors
2246 (wl-highlight-folder-group-line nums)
2247 (wl-highlight-folder-current-line nums))
2249 (set-buffer-modified-p nil))))))
2251 (defun wl-folder-goto-folder (&optional arg)
2252 "Visit some folder."
2254 (wl-folder-goto-folder-subr nil arg))
2256 (defun wl-folder-goto-folder-sticky ()
2257 "Visit some folder and make it sticky."
2259 (wl-folder-goto-folder-subr nil t))
2261 (defun wl-folder-goto-draft-folder (&optional arg)
2262 "Visit draft folder."
2264 (wl-folder-goto-folder-subr wl-draft-folder arg))
2266 (defun wl-folder-revisit-last-visited-folder (&optional arg)
2267 "Revisit last visited folder."
2270 (wl-folder-get-folder-name-by-id wl-folder-buffer-last-visited-entity-id)))
2272 (y-or-n-p (format "Revisit %s? " folder)))
2273 (wl-folder-goto-folder-subr folder arg))))
2275 (defun wl-folder-goto-folder-subr (&optional folder sticky)
2277 (let (summary-buf fld-name entity id error-selecting)
2278 ;;; (setq fld-name (wl-folder-get-entity-from-buffer))
2279 ;;; (if (or (null fld-name)
2280 ;;; (assoc fld-name wl-folder-group-alist))
2281 (setq fld-name wl-default-folder)
2282 (setq fld-name (or folder
2284 (wl-summary-read-folder fld-name))))
2285 (if (and (setq entity
2286 (wl-folder-search-entity-by-name fld-name
2289 (setq id (wl-folder-get-entity-id entity)))
2290 (wl-folder-set-current-entity-id id))
2291 (setq summary-buf (wl-summary-get-buffer-create fld-name sticky))
2292 (if (or wl-stay-folder-window wl-summary-use-frame)
2293 (wl-folder-select-buffer summary-buf)
2294 (if (and summary-buf
2295 (get-buffer-window summary-buf))
2297 (wl-summary-goto-folder-subr fld-name
2298 (wl-summary-get-sync-range
2299 (wl-folder-get-elmo-folder fld-name))
2302 (defun wl-folder-suspend ()
2304 (run-hooks 'wl-folder-suspend-hook)
2305 (wl-folder-info-save)
2306 (elmo-crosspost-message-alist-save)
2308 ;(if (fboundp 'mmelmo-cleanup-entity-buffers)
2309 ;(mmelmo-cleanup-entity-buffers))
2310 (bury-buffer wl-folder-buffer-name)
2311 (dolist (summary-buf (wl-collect-summary))
2312 (bury-buffer summary-buf))
2313 (dolist (draft-buf (wl-collect-draft))
2314 (bury-buffer draft-buf))
2315 (delete-windows-on wl-folder-buffer-name t))
2317 (defun wl-folder-info-save ()
2318 (when (and wl-folder-info-save
2319 wl-folder-info-alist-modified)
2320 (let ((entities (list wl-folder-entity))
2321 entity entity-stack info-alist info)
2323 (setq entity (wl-pop entities))
2327 (wl-push entities entity-stack))
2328 (setq entities (nth 2 entity)))
2330 (when (and (setq info (elmo-folder-get-info
2331 (wl-folder-get-elmo-folder entity)))
2332 (not (equal info '(nil))))
2334 (wl-append info-alist (list (list (elmo-string entity)
2335 (list (nth 3 info) ;; max
2336 (nth 2 info) ;; length
2338 (nth 1 info)) ;; unread
2341 (setq entities (wl-pop entity-stack))))
2342 (elmo-msgdb-finfo-save info-alist)
2343 (setq wl-folder-info-alist-modified nil))))
2345 (defun wl-folder-goto-first-unread-folder (&optional arg)
2347 (let ((entities (list wl-folder-entity))
2348 entity entity-stack ret-val
2353 (setq entity (wl-pop entities))
2357 (wl-push entities entity-stack))
2358 (setq entities (nth 2 entity)))
2360 (if (and (setq finfo (wl-folder-get-entity-info entity))
2361 (and (nth 0 finfo)(nth 1 finfo))
2362 (> (+ (nth 0 finfo)(nth 1 finfo)) 0))
2363 (throw 'done entity))
2364 (wl-append ret-val (list entity))))
2366 (setq entities (wl-pop entity-stack))))))
2370 (wl-folder-jump-folder first-entity)
2372 (wl-folder-goto-folder-subr first-entity))
2373 (message "No unread folder"))))
2375 (defun wl-folder-jump-folder (&optional fld-name noopen)
2378 (setq fld-name (wl-summary-read-folder wl-default-folder)))
2379 (goto-char (point-min))
2381 (wl-folder-open-folder fld-name))
2382 (and (wl-folder-buffer-search-entity fld-name)
2383 (beginning-of-line)))
2385 (defun wl-folder-get-entity-list (entity)
2386 (let ((entities (list entity))
2387 entity-stack ret-val)
2389 (setq entity (wl-pop entities))
2393 (wl-push entities entity-stack))
2394 (setq entities (nth 2 entity)))
2396 (wl-append ret-val (list entity))))
2398 (setq entities (wl-pop entity-stack))))
2401 (defun wl-folder-open-unread-folder (entity)
2403 (let ((alist (wl-folder-get-entity-list entity))
2405 finfo path-list path id)
2407 (when (and (setq finfo (wl-folder-get-entity-info (car alist)))
2408 (nth 0 finfo) (nth 1 finfo)
2409 (> (+ (nth 0 finfo)(nth 1 finfo)) 0))
2410 (setq unread (+ unread (+ (nth 0 finfo)(nth 1 finfo))))
2411 (setq id (wl-folder-get-entity-id (car alist)))
2412 (setq path (delete id (wl-folder-get-path
2416 (if (not (member path path-list))
2417 (wl-append path-list (list path))))
2418 (setq alist (cdr alist)))
2420 (wl-folder-open-folder-sub (car path-list))
2421 (setq path-list (cdr path-list)))
2422 (message "%s unread folder"
2423 (if (> unread 0) unread "No")))))
2425 (defun wl-folder-open-unread-current-entity ()
2427 (let ((entity-name (wl-folder-get-entity-from-buffer))
2428 (group (wl-folder-buffer-group-p)))
2430 (wl-folder-open-unread-folder
2432 (wl-folder-search-group-entity-by-name entity-name
2436 (defun wl-folder-open-only-unread-folder ()
2439 (wl-folder-prev-entity-skip-invalid t)
2440 (wl-folder-get-entity-from-buffer t))))
2441 (wl-folder-open-all-unread-folder)
2443 (goto-char (point-max))
2444 (while (and (re-search-backward
2445 "^[ ]*\\[[-]\\].+:0/0/[0-9-]+" nil t)
2447 (wl-folder-jump-to-current-entity) ;; close it
2449 (wl-folder-move-path id)
2452 (defun wl-folder-open-all-unread-folder (&optional arg)
2455 (wl-folder-prev-entity-skip-invalid t)
2456 (wl-folder-get-entity-from-buffer t))))
2457 (wl-folder-open-unread-folder wl-folder-entity)
2459 (wl-folder-move-path id)
2460 (goto-char (point-min))
2461 (wl-folder-next-unread t))))
2463 (defun wl-folder-open-folder (&optional fld-name)
2466 (setq fld-name (wl-summary-read-folder wl-default-folder)))
2467 (let ((entity (wl-folder-search-entity-by-name
2468 fld-name wl-folder-entity 'folder)))
2470 (let* ((id (wl-folder-get-entity-id entity))
2471 (path (and id (wl-folder-get-path wl-folder-entity id))))
2472 (if path (wl-folder-open-folder-sub path)))
2473 (message "%s: not found" fld-name))))
2475 (defun wl-folder-open-folder-sub (path)
2476 (let ((inhibit-read-only t)
2477 (buffer-read-only nil)
2481 (goto-char (point-min))
2483 (wl-folder-buffer-search-group
2484 (wl-folder-get-petname
2485 (if (stringp (car path))
2487 (wl-folder-get-folder-name-by-id
2490 (setq path (cdr path))
2491 (if (and (wl-folder-buffer-group-p)
2492 (looking-at wl-folder-group-regexp)
2493 (string= "+" (wl-match-buffer 2)));; closed group
2495 (setq indent (wl-match-buffer 1))
2496 (setq name (wl-folder-get-entity-from-buffer))
2497 (setq entity (wl-folder-search-group-entity-by-name
2501 (setcdr (assoc (car entity) wl-folder-group-alist) t)
2502 (if (eq 'access (cadr entity))
2503 (wl-folder-maybe-load-folder-list entity))
2504 (wl-folder-insert-entity indent entity)
2505 (delete-region (save-excursion (beginning-of-line)
2507 (save-excursion (end-of-line)
2509 (set-buffer-modified-p nil))))
2511 (defun wl-folder-open-all-pre ()
2512 (let ((entities (list wl-folder-entity))
2513 entity entity-stack group-entry)
2515 (setq entity (wl-pop entities))
2518 (unless (or (not (setq group-entry
2519 (assoc (car entity) wl-folder-group-alist)))
2521 (setcdr group-entry t)
2522 (when (eq 'access (cadr entity))
2523 (wl-folder-maybe-load-folder-list entity)))
2525 (wl-push entities entity-stack))
2526 (setq entities (nth 2 entity))))
2528 (setq entities (wl-pop entity-stack))))))
2530 (defun wl-folder-open-all (&optional refresh)
2532 (let* ((inhibit-read-only t)
2533 (buffer-read-only nil)
2534 (len (length wl-folder-group-alist))
2539 (wl-folder-prev-entity-skip-invalid t)
2540 (wl-folder-get-entity-from-buffer t)))
2541 (alist wl-folder-group-alist))
2543 (setcdr (pop alist) t))
2545 (wl-folder-insert-entity " " wl-folder-entity)
2546 (wl-folder-move-path id))
2547 (elmo-with-progress-display
2548 (wl-folder-open-all (length wl-folder-group-alist))
2549 "Opening all folders"
2550 (wl-folder-open-all-pre)
2552 (goto-char (point-min))
2553 (while (re-search-forward
2554 "^\\([ ]*\\)\\[\\([+]\\)\\]\\(.+\\):[-0-9-]+/[0-9-]+/[0-9-]+$"
2556 (setq indent (wl-match-buffer 1))
2557 (setq name (wl-folder-get-entity-from-buffer))
2558 (setq entity (wl-folder-search-group-entity-by-name
2562 (setcdr (assoc (car entity) wl-folder-group-alist) t)
2564 (wl-folder-insert-entity indent entity)
2565 (delete-region (save-excursion (beginning-of-line)
2567 (save-excursion (end-of-line)
2569 (elmo-progress-notify 'wl-folder-open-all)))))
2570 (wl-highlight-folder-path wl-folder-buffer-cur-path)
2571 (set-buffer-modified-p nil)))
2573 (defun wl-folder-close-all ()
2575 (let ((inhibit-read-only t)
2576 (buffer-read-only nil)
2577 (alist wl-folder-group-alist)
2579 (wl-folder-prev-entity-skip-invalid t)
2580 (wl-folder-get-entity-from-buffer t))))
2582 (setcdr (car alist) nil)
2583 (setq alist (cdr alist)))
2584 (setcdr (assoc (car wl-folder-entity) wl-folder-group-alist) t)
2586 (wl-folder-insert-entity " " wl-folder-entity)
2587 (wl-folder-move-path id)
2588 (wl-highlight-folder-path wl-folder-buffer-cur-path)
2590 (set-buffer-modified-p nil)))
2592 (defun wl-folder-open-close ()
2593 "Open or close parent entity."
2595 (unless (wl-folder-get-entity-from-buffer)
2596 (error "No folder"))
2598 (if (wl-folder-buffer-group-p)
2599 ;; if group (whether opend or closed.)
2600 (wl-folder-jump-to-current-entity)
2603 (setq indent (save-excursion
2604 (re-search-forward "\\([ ]*\\)." nil t)
2605 (wl-match-buffer 1)))
2606 (while (looking-at indent)
2608 (wl-folder-jump-to-current-entity)))
2610 (defsubst wl-folder-access-subscribe-p (group folder)
2611 (let (subscr regexp match)
2612 (if (setq subscr (wl-get-assoc-list-value
2613 wl-folder-access-subscribe-alist
2616 (setq regexp (mapconcat 'identity (cdr subscr) "\\|"))
2617 (setq match (string-match regexp folder))
2623 (defun wl-folder-update-access-group (entity new-flist)
2624 (let ((flist (nth 2 entity))
2625 (unsubscribes (nth 3 entity))
2626 diff new-unsubscribes removes
2627 subscribed-list folder group entry)
2628 (elmo-with-progress-display
2629 (wl-folder-update-access-group (+ (length flist) (length unsubscribes)))
2630 "Updating access group"
2631 ;; check subscribed groups
2634 ((listp (car flist)) ;; group
2635 (setq group (elmo-string (caar flist)))
2637 ((assoc group new-flist) ;; found in new-flist
2638 (setq new-flist (delete (assoc group new-flist)
2640 (if (wl-folder-access-subscribe-p (car entity) group)
2641 (wl-append subscribed-list (list (car flist)))
2642 (wl-append new-unsubscribes (list (car flist)))
2645 (setq wl-folder-group-alist
2646 (delete (wl-string-assoc group wl-folder-group-alist)
2647 wl-folder-group-alist))
2648 (wl-append removes (list (list group))))))
2650 (setq folder (elmo-string (car flist)))
2652 ((member folder new-flist) ;; found in new-flist
2653 (setq new-flist (delete folder new-flist))
2654 (if (wl-folder-access-subscribe-p (car entity) folder)
2655 (wl-append subscribed-list (list (car flist)))
2656 (wl-append new-unsubscribes (list folder))
2659 (wl-append removes (list folder))))))
2660 (elmo-progress-notify 'wl-folder-update-access-group)
2661 (setq flist (cdr flist)))
2662 ;; check unsubscribed groups
2665 ((listp (car unsubscribes))
2666 (when (setq entry (assoc (caar unsubscribes) new-flist))
2667 (setq new-flist (delete entry new-flist))
2668 (wl-append new-unsubscribes (list (car unsubscribes)))))
2670 (when (member (car unsubscribes) new-flist)
2671 (setq new-flist (delete (car unsubscribes) new-flist))
2672 (wl-append new-unsubscribes (list (car unsubscribes))))))
2673 (elmo-progress-notify 'wl-folder-update-access-group)
2674 (setq unsubscribes (cdr unsubscribes)))
2676 (if (or new-flist removes)
2679 (mapcar '(lambda (x)
2680 (cond ((consp x) (list (car x) 'access))
2684 (let ((new-list new-flist))
2686 (if (not (wl-folder-access-subscribe-p
2688 (if (listp (car new-list))
2693 (wl-append new-unsubscribes (list (car new-list)))
2694 (setq new-flist (delete (car new-list) new-flist)))
2696 ((listp (car new-list))
2697 ;; check group exists
2698 (if (wl-string-assoc (caar new-list) wl-folder-group-alist)
2700 (message "%s: group already exists." (caar new-list))
2702 (wl-append new-unsubscribes (list (car new-list)))
2703 (setq new-flist (delete (car new-list) new-flist)))
2704 (wl-append wl-folder-group-alist
2705 (list (cons (caar new-list) nil)))))))
2706 (setq new-list (cdr new-list)))))
2708 (message "%d new folder(s)." (length new-flist)))
2709 (wl-append new-flist subscribed-list) ;; new is first
2710 (run-hooks 'wl-folder-update-access-group-hook)
2711 (setcdr (cdr entity) (list new-flist new-unsubscribes))
2712 (list diff new-flist new-unsubscribes removes)))
2714 (defun wl-folder-prefetch-entity (entity)
2715 "Prefetch all new messages in the ENTITY."
2718 (let ((flist (nth 2 entity))
2723 (setq result (wl-folder-prefetch-entity (car flist)))
2724 (setq sum-done (+ sum-done (car result)))
2725 (setq sum-all (+ sum-all (cdr result)))
2726 (setq flist (cdr flist)))
2727 (message "Prefetched %d/%d message(s) in \"%s\"."
2729 (wl-folder-get-petname (car entity)))
2730 (cons sum-done sum-all)))
2732 (let* ((folder (wl-folder-get-elmo-folder entity))
2733 (nums (wl-folder-get-entity-info entity))
2734 (wl-summary-highlight (if (or (wl-summary-sticky-p folder)
2735 (wl-summary-always-sticky-folder-p
2737 wl-summary-highlight))
2738 wl-summary-exit-next-move
2739 wl-auto-select-first ret-val
2741 (setq count (or (car nums) 0))
2742 (setq count (+ count (wl-folder-count-incorporates folder)))
2743 (if (or (null (car nums)) ; unknown
2745 (save-window-excursion
2747 (let ((wl-summary-buffer-name
2748 (if (setq sticky (get-buffer
2749 (wl-summary-sticky-buffer-name
2750 (elmo-folder-name-internal
2752 ;; Sticky folder exists.
2753 (wl-summary-sticky-buffer-name
2754 (elmo-folder-name-internal folder))
2756 wl-summary-buffer-name
2757 (symbol-name this-command))))
2758 (wl-summary-use-frame nil)
2759 (wl-summary-always-sticky-folder-list nil))
2760 (wl-summary-goto-folder-subr entity
2761 (wl-summary-get-sync-range
2764 (setq ret-val (wl-summary-incorporate))
2766 (wl-summary-save-status)
2771 (defun wl-folder-count-incorporates (folder)
2773 (dolist (number (elmo-folder-list-flagged folder 'any))
2774 (when (member (wl-summary-message-mark folder number)
2775 wl-summary-incorporate-marks)
2779 (defun wl-folder-prefetch-current-entity (&optional no-check)
2780 "Prefetch all uncached messages in the folder at position.
2781 If current line is group folder, all subfolders are prefetched."
2784 (let ((entity-name (wl-folder-get-entity-from-buffer))
2785 (group (wl-folder-buffer-group-p))
2786 wl-folder-check-entity-hook
2791 (wl-folder-search-group-entity-by-name entity-name
2795 (wl-folder-check-entity entity))
2796 (wl-folder-prefetch-entity entity)))))
2798 ;(defun wl-folder-drop-unsync-entity (entity)
2799 ; "Drop all unsync messages in the ENTITY."
2802 ; (let ((flist (nth 2 entity)))
2804 ; (wl-folder-drop-unsync-entity (car flist))
2805 ; (setq flist (cdr flist)))))
2807 ; (let ((nums (wl-folder-get-entity-info entity))
2808 ; wl-summary-highlight wl-auto-select-first new)
2809 ; (setq new (or (car nums) 0))
2811 ; (save-window-excursion
2813 ; (let ((wl-summary-buffer-name (concat
2814 ; wl-summary-buffer-name
2815 ; (symbol-name this-command))))
2816 ; (wl-summary-goto-folder-subr entity 'no-sync nil)
2817 ; (wl-summary-drop-unsync)
2818 ; (wl-summary-exit)))))))))
2820 ;(defun wl-folder-drop-unsync-current-entity (&optional force-check)
2821 ; "Drop all unsync messages in the folder at position.
2822 ;If current line is group folder, all subfolders are dropped.
2823 ;If optional arg exists, don't check any folders."
2826 ; (let ((entity-name (wl-folder-get-entity-from-buffer))
2827 ; (group (wl-folder-buffer-group-p))
2828 ; wl-folder-check-entity-hook
2829 ; summary-buf entity)
2830 ; (when (and entity-name
2832 ; "Drop all unsync messages in %s? " entity-name)))
2835 ; (wl-folder-search-group-entity-by-name entity-name
2838 ; (if (null force-check)
2839 ; (wl-folder-check-entity entity))
2840 ; (wl-folder-drop-unsync-entity entity)
2841 ; (message "All unsync messages in %s are dropped!" entity-name)))))
2843 (defun wl-folder-write-current-folder ()
2844 "Write message to current folder's newsgroup or mailing-list.
2845 Call `wl-summary-write-current-folder' with current folder name."
2847 (unless (wl-folder-buffer-group-p)
2848 (wl-summary-write-current-folder
2849 (wl-folder-get-entity-from-buffer))))
2851 (defun wl-folder-mimic-kill-buffer ()
2852 "Kill the current (Folder) buffer with query."
2854 (let ((bufname (read-buffer (format "Kill buffer: (default %s) "
2856 wl-interactive-exit)
2857 (if (or (not bufname)
2858 (string-equal bufname "")
2859 (string-equal bufname (buffer-name)))
2861 (kill-buffer bufname))))
2863 (defun wl-folder-create-subr (folder)
2864 (let ((name (elmo-folder-name-internal folder)))
2865 (unless (elmo-folder-creatable-p folder)
2866 (error "Folder %s does not exist" name))
2867 (unless (y-or-n-p (format "Folder %s does not exist, create it? " name))
2868 (error "Folder %s is not created" name))
2870 (setq wl-folder-entity-hashtb
2871 (wl-folder-create-entity-hashtb name wl-folder-entity-hashtb))
2872 (unless (elmo-folder-create folder)
2873 (error "Create folder failed"))))
2875 (defun wl-folder-confirm-existence (folder &optional force)
2877 (unless (elmo-folder-exists-p folder)
2878 (wl-folder-create-subr folder))
2879 (unless (or (wl-folder-entity-exists-p (elmo-folder-name-internal folder))
2880 (and (elmo-folder-msgdb-path folder)
2881 (file-exists-p (elmo-folder-msgdb-path folder)))
2882 (elmo-folder-exists-p folder))
2883 (wl-folder-create-subr folder))))
2885 (defun wl-folder-virtual ()
2886 "Goto virtual folder."
2888 (let ((entity (wl-folder-get-entity-from-buffer)))
2889 (if (wl-folder-buffer-group-p)
2893 (mapconcat 'identity
2894 (wl-folder-get-entity-list
2895 (wl-folder-search-group-entity-by-name
2897 wl-folder-entity)) ","))))
2898 (unless entity (error "No folder"))
2899 (wl-folder-goto-folder-subr
2901 (wl-read-search-condition
2902 wl-fldmgr-make-filter-default)
2905 (defun wl-folder-pick ()
2908 (let* ((condition (car (elmo-parse-search-condition
2909 (wl-read-search-condition
2910 wl-summary-pick-field-default))))
2911 (entity (wl-folder-get-entity-from-buffer))
2913 (if (wl-folder-buffer-group-p)
2914 (wl-folder-get-entity-list
2915 (wl-folder-search-group-entity-by-name
2920 (while (car folder-list)
2921 (setq ret (elmo-folder-search
2922 (wl-folder-get-elmo-folder (car folder-list))
2927 (list (cons (car folder-list) ret)))))
2928 (setq folder-list (cdr folder-list)))
2930 (message "%s are picked."
2931 (mapconcat '(lambda (res)
2934 (length (cdr res))))
2937 (message "No message was picked.")))))
2939 (defun wl-folder-jump-to-next-summary ()
2941 (when (wl-collect-summary)
2942 (if (get-buffer-window (car (wl-collect-summary)))
2943 (switch-to-buffer-other-window (car (wl-collect-summary))))
2944 (wl-summary-next-buffer)))
2946 (defun wl-folder-jump-to-previous-summary ()
2948 (when (wl-collect-summary)
2949 (if (get-buffer-window (car (wl-collect-summary)))
2950 (switch-to-buffer-other-window (car (wl-collect-summary))))
2951 (wl-summary-previous-buffer)))
2955 (defvar wl-folder-complete-folder-candidate nil)
2957 (defun wl-folder-complete-folder (string predicate flag)
2958 (cond ((or (string-match "^\\(/[^/]*/\\)\\(.*\\)$" string) ; filter
2959 (string-match "^\\(\*\\|\*.*,\\)\\([^,]*\\)$" string) ; multi
2960 (string-match "^\\(|[^|]*|:?\\)\\(.*\\)$" string) ;pipe-src
2961 (string-match "^\\(|\\)\\([^|]*\\)$" string)) ;pipe-dst
2962 (let* ((str1 (match-string 1 string))
2963 (str2 (match-string 2 string))
2964 (str2-comp (wl-folder-complete-folder str2 predicate flag)))
2966 ((listp str2-comp) ; flag=t
2967 (mapcar (lambda (x) (concat str1 x)) str2-comp))
2968 ((stringp str2-comp)
2969 (concat str1 str2-comp))
2972 ((string-match "^\\(/\\)\\([^/]*\\)$" string) ; filter-condition
2973 (let* ((str1 (match-string 1 string))
2974 (str2 (match-string 2 string))
2976 (wl-folder-complete-filter-condition str2 predicate flag)))
2978 ((listp str2-comp) ; flag=t
2979 (mapcar (lambda (x) (concat str1 x)) str2-comp))
2980 ((stringp str2-comp)
2981 (concat str1 str2-comp))
2986 (or wl-folder-complete-folder-candidate
2987 (if (memq 'read-folder wl-use-folder-petname)
2988 (wl-folder-get-entity-with-petname)
2989 wl-folder-entity-hashtb))))
2991 (try-completion string candidate)
2992 (all-completions string candidate))))))
2994 (defun wl-folder-complete-filter-condition (string predicate flag)
2996 ((string-match "^\\(.*|\\|.*&\\|.*(\\)\\([^:]*\\)$" string)
2997 (let* ((str1 (match-string 1 string))
2998 (str2 (match-string 2 string))
3000 (wl-folder-complete-filter-condition str2 predicate flag)))
3002 ((listp str2-comp) ; flag=t
3003 (mapcar (lambda (x) (concat str1 x)) str2-comp))
3004 ((stringp str2-comp)
3005 (concat str1 str2-comp))
3010 (mapcar (lambda (x) (list (concat (downcase x) ":")))
3011 (wl-search-condition-fields))))
3013 (try-completion string candidate)
3014 (all-completions string candidate))))))
3017 (product-provide (provide 'wl-folder) (require 'wl-version))
3019 ;;; wl-folder.el ends here