wl/wl-folder.el

   1 ;;; wl-folder.el -- Folder mode for Wanderlust.
   2
   3 ;; Copyright 1998,1999,2000 Yuuichi Teranishi <teranisi@gohome.org>
   4
   5 ;; Author: Yuuichi Teranishi <teranisi@gohome.org>
   6 ;; Keywords: mail, net news
   7 ;; Time-stamp: <2000-04-07 09:30:54 teranisi>
   8
   9 ;; This file is part of Wanderlust (Yet Another Message Interface on Emacsen).
  10
  11 ;; This program is free software; you can redistribute it and/or modify
  12 ;; it under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation; either version 2, or (at your option)
  14 ;; any later version.
  15 ;;
  16 ;; This program is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;; GNU General Public License for more details.
  20 ;;
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  23 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  24 ;; Boston, MA 02111-1307, USA.
  25 ;;
  26
  27 ;;; Commentary:
  28 ;;
  29
  30 ;;; Code:
  31 ;;
  32
  33 (require 'elmo-vars)
  34 (require 'elmo-util)
  35 (require 'elmo2)
  36 (require 'wl-vars)
  37 (condition-case ()
  38     (require 'easymenu) ; needed here.
  39   (error))
  40
  41 (eval-when-compile
  42   (require 'cl)
  43   (require 'wl-util)
  44   (provide 'wl-folder)
  45   (require 'wl)
  46   (require 'elmo-nntp)
  47   (if wl-use-semi
  48       (require 'mmelmo))
  49   (unless (boundp ':file)
  50     (set (make-local-variable ':file) nil))
  51   (defun-maybe mmelmo-cleanup-entity-buffers ()))
  52
  53 (defvar wl-folder-buffer-name "Folder")
  54 (defvar wl-folder-entity nil)           ; desktop entity.
  55 (defvar wl-folder-group-alist nil)      ; opened or closed
  56 (defvar wl-folder-entity-id nil) ; id
  57 (defvar wl-folder-entity-hashtb nil)
  58 (defvar wl-folder-entity-id-name-hashtb nil)
  59 (defvar wl-folder-newsgroups-hashtb nil)
  60 (defvar wl-folder-info-alist-modified nil)
  61 (defvar wl-folder-completion-func nil)
  62
  63 (defvar wl-folder-mode-map nil)
  64
  65 (defvar wl-folder-opened-glyph nil)
  66 (defvar wl-folder-closed-glyph nil)
  67 (defvar wl-folder-nntp-glyph nil)
  68 (defvar wl-folder-imap4-glyph nil)
  69 (defvar wl-folder-pop3-glyph nil)
  70 (defvar wl-folder-localdir-glyph nil)
  71 (defvar wl-folder-localnews-glyph nil)
  72 (defvar wl-folder-internal-glyph nil)
  73 (defvar wl-folder-multi-glyph nil)
  74 (defvar wl-folder-filter-glyph nil)
  75 (defvar wl-folder-archive-glyph nil)
  76 (defvar wl-folder-pipe-glyph nil)
  77 (defvar wl-folder-maildir-glyph nil)
  78 (defvar wl-folder-trash-empty-glyph nil)
  79 (defvar wl-folder-trash-glyph nil)
  80 (defvar wl-folder-draft-glyph nil)
  81 (defvar wl-folder-queue-glyph nil)
  82
  83 (defvar wl-folder-buffer-disp-summary nil)
  84 (make-variable-buffer-local 'wl-folder-buffer-disp-summary)
  85 (defvar wl-folder-buffer-cur-entity-id nil)
  86 (make-variable-buffer-local 'wl-folder-buffer-cur-entity-id)
  87 (defvar wl-folder-buffer-cur-path nil)
  88 (make-variable-buffer-local 'wl-folder-buffer-cur-entity-id)
  89 (defvar wl-folder-buffer-cur-point nil)
  90 (make-variable-buffer-local 'wl-folder-buffer-cur-point)
  91
  92 (defconst wl-folder-entity-regexp "^\\([ ]*\\)\\(\\[[\\+-]\\]\\)?\\([^\\[].+\\):[-*0-9]+/[-*0-9]+/[-*0-9]+")
  93 (defconst wl-folder-group-regexp  "^\\([ ]*\\)\\[\\([\\+-]\\)\\]\\(.+\\):[-0-9-]+/[0-9-]+/[0-9-]+\n")
  94 ;;                              1:indent 2:opened 3:group-name
  95 (defconst wl-folder-unsync-regexp ":[^0\\*][0-9]*/[0-9\\*-]+/[0-9\\*-]+$")
  96
  97 (defvar wl-folder-mode-menu-spec
  98   '("Folder"
  99     ["Enter Current Folder" wl-folder-jump-to-current-entity t]
 100     ["Prev Folder"          wl-folder-prev-entity t]
 101     ["Next Folder"          wl-folder-next-entity t]
 102     ["Check Current Folder" wl-folder-check-current-entity t]
 103     ["Sync Current Folder"  wl-folder-sync-current-entity t]
 104     ["Drop Current Folder" wl-folder-drop-unsync-current-entity t]
 105     ["Prefetch Current Folder" wl-folder-prefetch-current-entity t]
 106     ["Mark as Read all Current Folder" wl-folder-mark-as-read-all-current-entity t]
 107     ["Expire Current Folder" wl-folder-expire-current-entity t]
 108     ["Empty trash" wl-folder-empty-trash t]
 109     ["Flush queue" wl-folder-flush-queue t]
 110     ["Open All" wl-folder-open-all t]
 111     ["Open All Unread folder" wl-folder-open-all-unread-folder t]
 112     ["Close All" wl-folder-close-all t]
 113     ("Folder Manager"
 114      ["Add folder" wl-fldmgr-add t]
 115      ["Add group" wl-fldmgr-make-group t]
 116      ["Copy" wl-fldmgr-copy t]
 117      ["Cut" wl-fldmgr-cut t]
 118      ["Paste" wl-fldmgr-yank t]
 119      ["Set petname" wl-fldmgr-set-petname t]
 120      ["Rename" wl-fldmgr-rename t]
 121      ["Save" wl-fldmgr-save-folders t]
 122      "----"
 123      ["Unsubscribe" wl-fldmgr-unsubscribe t]
 124      ["Display all" wl-fldmgr-access-display-all t])
 125     "----"
 126     ["Write a message" wl-draft t]
 127     "----"
 128     ["Toggle Plug Status" wl-toggle-plugged t]
 129     ["Change Plug Status" wl-plugged-change t]
 130     "----"
 131     ["Save Current Status"  wl-save t]
 132     ["Update Satus"         wl-status-update t]
 133     ["Exit"                 wl-exit t]
 134     ))
 135
 136 (if wl-on-xemacs
 137     (defun wl-folder-setup-mouse ()
 138       (define-key wl-folder-mode-map 'button2 'wl-folder-click)
 139       (define-key wl-folder-mode-map 'button4 'wl-folder-prev-entity)
 140       (define-key wl-folder-mode-map 'button5 'wl-folder-next-entity)
 141       (define-key wl-folder-mode-map [(shift button4)]
 142         'wl-folder-prev-unread)
 143       (define-key wl-folder-mode-map [(shift button5)]
 144         'wl-folder-next-unread))
 145   (if wl-on-nemacs
 146       (defun wl-folder-setup-mouse ())
 147     (defun wl-folder-setup-mouse ()
 148       (define-key wl-folder-mode-map [mouse-2] 'wl-folder-click)
 149       (define-key wl-folder-mode-map [mouse-4] 'wl-folder-prev-entity)
 150       (define-key wl-folder-mode-map [mouse-5] 'wl-folder-next-entity)
 151       (define-key wl-folder-mode-map [S-mouse-4] 'wl-folder-prev-unread)
 152       (define-key wl-folder-mode-map [S-mouse-5] 'wl-folder-next-unread))))
 153
 154 (if wl-folder-mode-map
 155     nil
 156   (setq wl-folder-mode-map (make-sparse-keymap))
 157   (define-key wl-folder-mode-map " "    'wl-folder-jump-to-current-entity)
 158 ;  (define-key wl-folder-mode-map "\M- " 'wl-folder-open-close)
 159   (define-key wl-folder-mode-map "/"    'wl-folder-open-close)
 160   (define-key wl-folder-mode-map "\C-m" 'wl-folder-jump-to-current-entity)
 161   (define-key wl-folder-mode-map "\M-\C-m" 'wl-folder-update-recursive-current-entity)
 162   (define-key wl-folder-mode-map "rc"    'wl-folder-mark-as-read-all-region)
 163   (define-key wl-folder-mode-map "c"    'wl-folder-mark-as-read-all-current-entity)
 164   (define-key wl-folder-mode-map "g"    'wl-folder-goto-folder)
 165   (define-key wl-folder-mode-map "j"    'wl-folder-jump-to-current-entity)
 166   (define-key wl-folder-mode-map "w"    'wl-draft)
 167   (define-key wl-folder-mode-map "W"    'wl-folder-write-current-newsgroup)
 168   (define-key wl-folder-mode-map "\C-c\C-o" 'wl-jump-to-draft-buffer)
 169   (define-key wl-folder-mode-map "rS"   'wl-folder-sync-region)
 170   (define-key wl-folder-mode-map "S"    'wl-folder-sync-current-entity)
 171   (define-key wl-folder-mode-map "rs"   'wl-folder-check-region)
 172   (define-key wl-folder-mode-map "s"    'wl-folder-check-current-entity)
 173   (define-key wl-folder-mode-map "I"    'wl-folder-prefetch-current-entity)
 174   (define-key wl-folder-mode-map "D"    'wl-folder-drop-unsync-current-entity)
 175   (define-key wl-folder-mode-map "p"    'wl-folder-prev-entity)
 176   (define-key wl-folder-mode-map "n"    'wl-folder-next-entity)
 177   (define-key wl-folder-mode-map "v"    'wl-folder-toggle-disp-summary)
 178   (define-key wl-folder-mode-map "P"    'wl-folder-prev-unread)
 179   (define-key wl-folder-mode-map "N"    'wl-folder-next-unread)
 180   (define-key wl-folder-mode-map "J"    'wl-folder-jump-folder)
 181   (define-key wl-folder-mode-map "f"    'wl-folder-goto-first-unread-folder)
 182   (define-key wl-folder-mode-map "o"    'wl-folder-open-all-unread-folder)
 183   (define-key wl-folder-mode-map "["    'wl-folder-open-all)
 184   (define-key wl-folder-mode-map "]"    'wl-folder-close-all)
 185   (define-key wl-folder-mode-map "e"    'wl-folder-expire-current-entity)
 186   (define-key wl-folder-mode-map "E"    'wl-folder-empty-trash)
 187   (define-key wl-folder-mode-map "F"    'wl-folder-flush-queue)
 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 "\M-t" 'wl-toggle-plugged)
 191   (define-key wl-folder-mode-map "\C-t" 'wl-plugged-change)
 192   (define-key wl-folder-mode-map "<"    'beginning-of-buffer)
 193   (define-key wl-folder-mode-map ">"    'end-of-buffer)
 194   ;; wl-fldmgr
 195   (unless wl-on-nemacs
 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   (wl-folder-setup-mouse)
 216   (easy-menu-define
 217    wl-folder-mode-menu
 218    wl-folder-mode-map
 219    "Menu used in Folder mode."
 220    wl-folder-mode-menu-spec))
 221
 222 (defmacro wl-folder-unread-regex (group)
 223   (` (concat "^[ ]*.+:[0-9\\*-]+/[^0\\*][0-9]*/[0-9\\*-]+$"
 224              (if (, group)
 225                  "\\|^[ ]*\\[[+-]\\]"
 226                ""))))
 227
 228 (defmacro wl-folder-buffer-group-p ()
 229   (` (save-excursion (beginning-of-line)
 230                      (looking-at wl-folder-group-regexp))))
 231
 232 (defmacro wl-folder-folder-name ()
 233   (` (save-excursion
 234        (beginning-of-line)
 235        (if (or (looking-at "^[ ]*\\[[\\+-]\\]\\(.+\\):[-0-9\\*-]+/[0-9\\*-]+/[0-9\\*-]+\n")
 236                (looking-at "^[ ]*\\([^\\[].+\\):.*\n"))
 237            (wl-match-buffer 1)))))
 238
 239 (defmacro wl-folder-entity-name ()
 240   (` (save-excursion
 241        (beginning-of-line)
 242        (if (looking-at "^[ ]*\\([^\\[].+\\):.*\n")
 243            (wl-match-buffer 1)))))
 244
 245 (defun wl-folder-buffer-search-group (group)
 246   (re-search-forward
 247    (concat
 248     "^\\([ \t]*\\)\\[[\\+-]\\]"
 249     (regexp-quote group) ":[-0-9-]+/[0-9-]+/[0-9-]+") nil t))
 250
 251 (defun wl-folder-buffer-search-entity (folder &optional searchname)
 252   (let ((search (or searchname (wl-folder-get-petname folder))))
 253     (re-search-forward
 254      (concat
 255       "^[ \t]*"
 256       (regexp-quote search) ":[-0-9\\*-]+/[0-9\\*-]+/[0-9\\*-]+") nil t)))
 257
 258 (defsubst wl-folder-get-folder-name-by-id (entity-id &optional hashtb)
 259   (and (numberp entity-id)
 260        (elmo-get-hash-val (format "#%d" entity-id)
 261                           (or hashtb wl-folder-entity-id-name-hashtb))))
 262
 263 (defsubst wl-folder-set-id-name (entity-id entity &optional hashtb)
 264   (and (numberp entity-id)
 265        (elmo-set-hash-val (format "#%d" entity-id)
 266                           entity (or hashtb wl-folder-entity-id-name-hashtb))))
 267
 268 (defmacro wl-folder-get-entity-id (entity)
 269   (` (or (get-text-property 0
 270                             'wl-folder-entity-id
 271                             (, entity))
 272          (, entity)))) ;; for nemacs
 273
 274 (defmacro wl-folder-get-entity-from-buffer (&optional getid)
 275   (` (let ((id (get-text-property (point)
 276                                   'wl-folder-entity-id)))
 277        (if (not id) ;; for nemacs
 278            (wl-folder-get-realname (wl-folder-folder-name))
 279          (if (, getid)
 280              id
 281            (wl-folder-get-folder-name-by-id id))))))
 282
 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)))))
 287
 288 (defmacro wl-folder-clear-entity-info (entity &optional hashtb)
 289   (` (let ((sym (intern-soft (, entity)
 290                              (or (, hashtb) wl-folder-entity-hashtb))))
 291        (if (boundp sym)
 292            (makunbound sym)))))
 293
 294 (defmacro wl-folder-get-entity-info (entity &optional hashtb)
 295   (` (elmo-get-hash-val (, entity) (or (, hashtb) wl-folder-entity-hashtb))))
 296
 297 (defmacro wl-folder-set-entity-info (entity value &optional hashtb)
 298   (` (let* ((hashtb (or (, hashtb) wl-folder-entity-hashtb))
 299             (info (wl-folder-get-entity-info (, entity) hashtb)))
 300        (elmo-set-hash-val (, entity)
 301                           (if (< (length (, value)) 4)
 302                               (append (, value) (list (nth 3 info)))
 303                             (, value))
 304                           hashtb))))
 305
 306 (defun wl-folder-persistent-p (folder)
 307   (or (elmo-get-hash-val folder wl-folder-entity-hashtb) ; on Folder mode.
 308       (catch 'found
 309         (let ((li wl-save-folder-list))
 310           (while li
 311             (if (string-match (car li) folder)
 312                 (throw 'found t))
 313             (setq li (cdr li)))))
 314       (not (catch 'found
 315              (let ((li wl-no-save-folder-list))
 316                (while li
 317                  (if (string-match (car li) folder)
 318                      (throw 'found t))
 319                  (setq li (cdr li))))))))
 320
 321 (defun wl-folder-prev-entity ()
 322   (interactive)
 323   (forward-line -1))
 324
 325 (defun wl-folder-next-entity ()
 326   (interactive)
 327   (forward-line 1))
 328
 329 (defun wl-folder-prev-entity-skip-invalid (&optional hereto)
 330   "move to previous entity. skip unsubscribed or removed entity."
 331   (interactive)
 332   (if hereto
 333       (end-of-line))
 334   (if (re-search-backward wl-folder-entity-regexp nil t)
 335       (beginning-of-line)
 336     (goto-char (point-min))))
 337
 338 (defun wl-folder-next-entity-skip-invalid (&optional hereto)
 339   "move to next entity. skip unsubscribed or removed entity."
 340   (interactive)
 341   (beginning-of-line)
 342   (if (not hereto)
 343       (forward-line 1))
 344   (if (re-search-forward wl-folder-entity-regexp nil t)
 345       (beginning-of-line)
 346     (goto-char (point-max))))
 347
 348 (defun wl-folder-search-group-entity-by-name (name entity)
 349   (wl-folder-search-entity-by-name name entity 'group))
 350
 351 (defun wl-folder-search-entity-by-name (name entity &optional type)
 352   (let ((entities (list entity))
 353         entity-stack)
 354     (catch 'done
 355       (while entities
 356         (setq entity (wl-pop entities))
 357         (cond
 358          ((consp entity)
 359           (if (and (not (eq type 'folder))
 360                    (string= name (car entity)))
 361               (throw 'done entity))
 362           (and entities
 363                (wl-push entities entity-stack))
 364           (setq entities (nth 2 entity)))
 365          ((and (not (eq type 'group))
 366                (stringp entity))
 367           (if (string= name entity)
 368               (throw 'done entity))))
 369         (unless entities
 370           (setq entities (wl-pop entity-stack)))))))
 371
 372 (defun wl-folder-search-entity-list-by-name (name entity &optional get-id)
 373   (let ((entities (list entity))
 374         entity-stack ret-val)
 375     (while entities
 376       (setq entity (wl-pop entities))
 377       (cond
 378        ((consp entity)
 379         (and entities
 380              (wl-push entities entity-stack))
 381         (setq entities (nth 2 entity)))
 382        ((stringp entity)
 383         (if (string= name entity)
 384             (wl-append ret-val (if get-id
 385                                    (list (wl-folder-get-entity-id entity))
 386                                  (list entity))))))
 387       (unless entities
 388         (setq entities (wl-pop entity-stack))))
 389     ret-val))
 390
 391 (defun wl-folder-get-prev-folder (id &optional unread)
 392   (let ((name (if (stringp id)
 393                   id
 394                 (wl-folder-get-folder-name-by-id id)))
 395         entity entity-stack last-entity finfo
 396         (entities (list wl-folder-entity)))
 397     (catch 'done
 398       (while entities
 399         (setq entity (wl-pop entities))
 400         (cond
 401          ((consp entity)
 402 ;;        (if (and (string= name (car entity))
 403 ;;                 (eq id (wl-folder-get-entity-id (car entity))))
 404 ;;            (throw 'done last-entity))
 405           (and entities
 406                (wl-push entities entity-stack))
 407           (setq entities (nth 2 entity)))
 408          ((stringp entity)
 409           (if (and (string= name entity)
 410                    ;; don't use eq, `id' is string on Nemacs.
 411                    (equal id (wl-folder-get-entity-id entity)))
 412               (throw 'done last-entity))
 413           (if (or (not unread)
 414                   (and (setq finfo (wl-folder-get-entity-info entity))
 415                        (and (nth 0 finfo)(nth 1 finfo))
 416                        (> (+ (nth 0 finfo)(nth 1 finfo)) 0)))
 417               (setq last-entity entity))))
 418         (unless entities
 419           (setq entities (wl-pop entity-stack)))))))
 420
 421 (defun wl-folder-get-next-folder (id &optional unread)
 422   (let ((name (if (stringp id)
 423                   id
 424                 (wl-folder-get-folder-name-by-id id)))
 425         entity entity-stack found finfo
 426         (entities (list wl-folder-entity)))
 427     (catch 'done
 428       (while entities
 429         (setq entity (wl-pop entities))
 430         (cond
 431          ((consp entity)
 432 ;;        (if (and (string= name (car entity))
 433 ;;                 (eq id (wl-folder-get-entity-id (car entity))))
 434 ;;            (setq found t))
 435           (and entities
 436                (wl-push entities entity-stack))
 437           (setq entities (nth 2 entity)))
 438          ((stringp entity)
 439           (if found
 440               (when (or (not unread)
 441                         (and (setq finfo (wl-folder-get-entity-info entity))
 442                              (and (nth 0 finfo)(nth 1 finfo))
 443                              (> (+ (nth 0 finfo)(nth 1 finfo)) 0)))
 444                 (throw 'done entity))
 445             (if (and (string= name entity)
 446                      ;; don't use eq, `id' is string on Nemacs.
 447                      (equal id (wl-folder-get-entity-id entity)))
 448                 (setq found t)))))
 449         (unless entities
 450           (setq entities (wl-pop entity-stack)))))))
 451
 452 (defun wl-folder-flush-queue ()
 453   "Flush queue."
 454   (interactive)
 455   (let ((cur-buf (current-buffer))
 456         (wl-auto-select-first nil)
 457         (wl-plugged t)
 458         emptied)
 459     (if elmo-enable-disconnected-operation
 460         (elmo-dop-queue-flush 'force)) ; Try flushing all queue.
 461     (if (not (elmo-list-folder wl-queue-folder))
 462         (message "No sending queue exists.")
 463       (if wl-stay-folder-window
 464           (wl-folder-select-buffer
 465            (wl-summary-get-buffer-create wl-queue-folder)))
 466       (wl-summary-goto-folder-subr wl-queue-folder 'force-update nil)
 467       (unwind-protect
 468           (wl-draft-queue-flush)
 469         (if (get-buffer-window cur-buf)
 470             (select-window (get-buffer-window cur-buf)))
 471         (set-buffer cur-buf)
 472         (if wl-stay-folder-window
 473             (wl-folder-toggle-disp-summary 'off wl-queue-folder)
 474           (switch-to-buffer cur-buf))))))
 475
 476 (defun wl-folder-empty-trash ()
 477   "Empty trash."
 478   (interactive)
 479   (let ((cur-buf (current-buffer))
 480         (wl-auto-select-first nil)
 481         trash-buf emptied)
 482     (if wl-stay-folder-window
 483         (wl-folder-select-buffer
 484          (wl-summary-get-buffer-create wl-trash-folder)))
 485     (wl-summary-goto-folder-subr wl-trash-folder 'force-update nil nil t)
 486     (setq trash-buf (current-buffer))
 487     (unwind-protect
 488         (setq emptied (wl-summary-delete-all-msgs))
 489       (when emptied
 490         (setq wl-thread-entities nil
 491               wl-thread-entity-list nil)
 492         (if wl-summary-cache-use (wl-summary-save-view-cache))
 493         (wl-summary-msgdb-save))
 494       (if (get-buffer-window cur-buf)
 495           (select-window (get-buffer-window cur-buf)))
 496       (set-buffer cur-buf)
 497       (if emptied
 498           (wl-folder-set-folder-updated wl-trash-folder '(0 0 0)))
 499       (if wl-stay-folder-window
 500           (wl-folder-toggle-disp-summary 'off wl-trash-folder)
 501         (switch-to-buffer cur-buf))
 502       (and trash-buf
 503            (kill-buffer trash-buf)))))
 504
 505 (defun wl-folder-goto-top-of-current-folder ()
 506   (if (re-search-backward "^\\([ ]*\\)\\[\\([\\+-]\\)\\]\\(.+\\)\n" nil t)
 507       (beginning-of-line)
 508     (goto-char (point-min))))
 509
 510 (defun wl-folder-goto-bottom-of-current-folder (indent)
 511   (if (catch 'done
 512         (while (re-search-forward "^\\([ ]*\\)[^ ]" nil t)
 513           (if (<= (length (wl-match-buffer 1))
 514                   (length indent))
 515               (throw 'done nil)))
 516         (throw 'done t))
 517       (goto-char (point-max))))
 518
 519 (defsubst wl-folder-update-group (entity diffs &optional is-group)
 520   (let ((path (wl-folder-get-path
 521                wl-folder-entity
 522                (wl-folder-get-entity-id entity)
 523                entity)))
 524     (if (not is-group)
 525         ;; delete itself from path
 526         (setq path (delete (nth (- (length path) 1) path) path)))
 527     (goto-char (point-min))
 528     (catch 'done
 529       (while path
 530         ;; goto the path line.
 531         (if (or (eq (car path) 0) ; update desktop
 532                 (wl-folder-buffer-search-group
 533                  (wl-folder-get-petname
 534                   (if (stringp (car path))
 535                       (car path)
 536                     (wl-folder-get-folder-name-by-id
 537                      (car path))))))
 538             ;; update it.
 539             (wl-folder-update-diff-line diffs)
 540           (throw 'done t))
 541         (setq path (cdr path))))))
 542
 543 (defun wl-folder-maybe-load-folder-list (entity)
 544   (when (null (caddr entity))
 545     (setcdr (cdr entity)
 546             (elmo-msgdb-flist-load (car entity)))
 547     (when (cddr entity)
 548       (let (diffs)
 549         (save-excursion
 550           (wl-folder-entity-assign-id entity
 551                                       wl-folder-entity-id-name-hashtb
 552                                       t)
 553           (setq diffs (wl-fldmgr-add-entity-hashtb (list entity)))
 554           (unless (equal diffs '(0 0 0))
 555             (wl-folder-update-group (car entity) diffs t)))))))
 556
 557 (defsubst wl-folder-force-fetch-p (entity)
 558   (cond
 559    ((consp wl-force-fetch-folders)
 560     (wl-string-match-member entity wl-force-fetch-folders))
 561    (t
 562     wl-force-fetch-folders)))
 563
 564 (defun wl-folder-jump-to-current-entity (&optional arg)
 565   "Enter the current folder. If optional arg exists, update folder list. "
 566   (interactive "P")
 567   (beginning-of-line)
 568   (let (entity beg end indent opened fname err fld-name)
 569     (cond
 570      ((looking-at wl-folder-group-regexp)
 571       (save-excursion
 572         (setq fname (wl-folder-get-realname (wl-match-buffer 3)))
 573         (setq indent (wl-match-buffer 1))
 574         (setq opened (wl-match-buffer 2))
 575         (if (string= opened "+")
 576             (progn
 577               (setq entity (wl-folder-search-group-entity-by-name
 578                             fname
 579                             wl-folder-entity))
 580               (setq beg (point))
 581               (if arg
 582                   (wl-folder-update-recursive-current-entity entity)
 583               ;; insert as opened
 584               (setcdr (assoc (car entity) wl-folder-group-alist) t)
 585               (if (eq 'access (cadr entity))
 586                   (wl-folder-maybe-load-folder-list entity))
 587               (condition-case errobj
 588                   (progn
 589                     (if (or (wl-folder-force-fetch-p (car entity))
 590                             (and
 591                              (eq 'access (cadr entity))
 592                              (null (caddr entity))))
 593                         (wl-folder-update-newest indent entity)
 594                       (wl-folder-insert-entity indent entity))
 595                     (wl-highlight-folder-path wl-folder-buffer-cur-path))
 596                 (quit
 597                  (setq err t)
 598                  (setcdr (assoc fname wl-folder-group-alist) nil))
 599                 (error
 600                  (elmo-display-error errobj t)
 601                  (ding)
 602                  (setq err t)
 603                  (setcdr (assoc fname wl-folder-group-alist) nil)))
 604               (if (not err)
 605                   (let ((buffer-read-only nil))
 606                     (delete-region (save-excursion (beginning-of-line)
 607                                                    (point))
 608                                    (save-excursion (end-of-line)
 609                                                    (+ 1 (point))))))))
 610           (setq beg (point))
 611           (end-of-line)
 612           (save-match-data
 613             (setq end
 614                   (progn (wl-folder-goto-bottom-of-current-folder indent)
 615                          (beginning-of-line)
 616                          (point))))
 617           (setq entity (wl-folder-search-group-entity-by-name
 618                         fname
 619                         wl-folder-entity))
 620           (let ((buffer-read-only nil))
 621             (delete-region beg end))
 622           (setcdr (assoc (car entity) wl-folder-group-alist) nil)
 623           (wl-folder-insert-entity indent entity) ; insert entity
 624           (forward-line -1)
 625           (wl-highlight-folder-path wl-folder-buffer-cur-path)
 626 ;         (wl-delete-all-overlays)
 627 ;         (wl-highlight-folder-current-line)
 628           )))
 629      ((setq fld-name (wl-folder-entity-name))
 630       (if wl-on-nemacs
 631           (progn
 632             (wl-folder-set-current-entity-id
 633              (wl-folder-get-entity-from-buffer))
 634             (setq fld-name (wl-folder-get-realname fld-name)))
 635         (wl-folder-set-current-entity-id
 636          (get-text-property (point) 'wl-folder-entity-id))
 637         (setq fld-name (wl-folder-get-folder-name-by-id
 638                         wl-folder-buffer-cur-entity-id)))
 639       (let ((summary-buf (wl-summary-get-buffer-create fld-name arg))
 640             error-selecting)
 641         (if wl-stay-folder-window
 642             (wl-folder-select-buffer summary-buf)
 643           (if (and summary-buf
 644                    (get-buffer-window summary-buf))
 645               (delete-window)))
 646         (wl-summary-goto-folder-subr fld-name
 647                                      (wl-summary-get-sync-range fld-name)
 648                                      nil arg t)))))
 649   (set-buffer-modified-p nil))
 650
 651 (defun wl-folder-close-entity (entity)
 652   (let ((entities (list entity))
 653         entity-stack)
 654     (while entities
 655       (setq entity (wl-pop entities))
 656       (cond
 657        ((consp entity)
 658         (setcdr (assoc (car entity) wl-folder-group-alist) nil)
 659         (and entities
 660              (wl-push entities entity-stack))
 661         (setq entities (nth 2 entity))))
 662       (unless entities
 663         (setq entities (wl-pop entity-stack))))))
 664
 665 (defun wl-folder-update-recursive-current-entity (&optional entity)
 666   (interactive)
 667   (when (wl-folder-buffer-group-p)
 668     (cond
 669      ((string= (wl-match-buffer 2) "+")
 670       (save-excursion
 671         (if entity ()
 672           (setq entity
 673                 (wl-folder-search-group-entity-by-name
 674                  (wl-folder-get-realname (wl-match-buffer 3))
 675                  wl-folder-entity)))
 676         (let ((inhibit-read-only t)
 677               (entities (list entity))
 678               entity-stack err indent)
 679           (while (and entities (not err))
 680             (setq entity (wl-pop entities))
 681             (cond
 682              ((consp entity)
 683               (wl-folder-close-entity entity)
 684               (setcdr (assoc (car entity) wl-folder-group-alist) t)
 685               (unless (wl-folder-buffer-search-group
 686                        (wl-folder-get-petname (car entity)))
 687                 (error "%s: not found group" (car entity)))
 688               (setq indent (wl-match-buffer 1))
 689               (if (eq 'access (cadr entity))
 690                   (wl-folder-maybe-load-folder-list entity))
 691               (beginning-of-line)
 692               (setq err nil)
 693               (save-excursion
 694                 (condition-case errobj
 695                     (wl-folder-update-newest indent entity)
 696                   (quit
 697                    (setq err t)
 698                    (setcdr (assoc (car entity) wl-folder-group-alist) nil))
 699                   (error
 700                    (elmo-display-error errobj t)
 701                    (ding)
 702                    (setq err t)
 703                    (setcdr (assoc (car entity) wl-folder-group-alist) nil)))
 704                 (if (not err)
 705                     (delete-region (save-excursion (beginning-of-line)
 706                                                    (point))
 707                                    (save-excursion (end-of-line)
 708                                                    (+ 1 (point))))))
 709               ;;
 710               (and entities
 711                    (wl-push entities entity-stack))
 712               (setq entities (nth 2 entity))))
 713             (unless entities
 714               (setq entities (wl-pop entity-stack)))))
 715         (set-buffer-modified-p nil)))
 716      (t
 717       (wl-folder-jump-to-current-entity)))))
 718
 719 (defun wl-folder-no-auto-check-folder-p (folder)
 720   (if (stringp folder)
 721       (if (catch 'found
 722             (let ((li wl-auto-check-folder-list))
 723               (while li
 724                 (if (string-match (car li) folder)
 725                     (throw 'found t))
 726                 (setq li (cdr li)))))
 727           nil
 728         (catch 'found
 729           (let ((li wl-auto-uncheck-folder-list))
 730             (while li
 731               (if (string-match (car li) folder)
 732                   (throw 'found t))     ; no check!
 733               (setq li (cdr li))))))))
 734
 735 (defsubst wl-folder-add-folder-info (pre-value value)
 736   (list
 737    (+ (or (nth 0 pre-value) 0) (or (nth 0 value) 0))
 738    (+ (or (nth 1 pre-value) 0) (or (nth 1 value) 0))
 739    (+ (or (nth 2 pre-value) 0) (or (nth 2 value) 0))))
 740
 741 (defun wl-folder-check-entity (entity &optional auto)
 742   "Check unsync message number."
 743   (let ((start-pos (point))
 744         ret-val)
 745     (run-hooks 'wl-folder-check-entity-pre-hook)
 746     (if (and (consp entity)             ;; group entity
 747              wl-folder-check-async)     ;; very fast
 748         (setq ret-val (wl-folder-check-entity-async entity auto))
 749       (save-excursion
 750         (cond
 751          ((consp entity)
 752           (let ((flist (if auto
 753                            (elmo-delete-if
 754                             'wl-folder-no-auto-check-folder-p
 755                             (nth 2 entity))
 756                          (nth 2 entity)))
 757                 (wl-folder-check-entity-pre-hook nil)
 758                 (wl-folder-check-entity-hook nil)
 759                 new unread all)
 760             (while flist
 761               (setq ret-val
 762                     (wl-folder-add-folder-info
 763                      ret-val
 764                      (wl-folder-check-entity (car flist))))
 765               (setq flist (cdr flist)))
 766             ;(wl-folder-buffer-search-entity (car entity))
 767             ;(wl-folder-update-line ret-val)
 768             ))
 769          ((and (stringp entity)
 770                (elmo-folder-plugged-p entity))
 771           (message "Checking \"%s\"" entity)
 772           (setq ret-val (wl-folder-check-one-entity entity))
 773           (goto-char start-pos)
 774           (sit-for 0))
 775          (t
 776           (message "Uncheck(unplugged) \"%s\"" entity)))))
 777     (if ret-val
 778         (message "Checking \"%s\" is done."
 779                  (if (consp entity) (car entity) entity)))
 780     (run-hooks 'wl-folder-check-entity-hook)
 781     ret-val))
 782
 783 ;; All contained folders are imap4 and persistent flag, then
 784 ;; use server diff.
 785 (defun wl-folder-use-server-diff-p (folder)
 786   (let ((spec (elmo-folder-get-spec folder)))
 787     (cond
 788      ((eq (car spec) 'multi)
 789       (let ((folders (cdr spec)))
 790         (catch 'done
 791           (while folders
 792             (if (wl-folder-use-server-diff-p (car folders))
 793                 (throw 'done t))
 794             (setq folders (cdr folders)))
 795           nil)))
 796     ((eq (car spec) 'filter)
 797      (wl-folder-use-server-diff-p (nth 2 spec)))
 798     ((eq (car spec) 'imap4)
 799      (and wl-folder-use-server-diff
 800           (elmo-imap4-use-flag-p spec)))
 801     (t nil))))
 802
 803 (defun wl-folder-check-one-entity (entity)
 804   (let* ((elmo-use-server-diff (wl-folder-use-server-diff-p entity))
 805          (nums (condition-case err
 806                    (if (wl-string-member entity wl-strict-diff-folders)
 807                        (elmo-strict-folder-diff entity)
 808                      (elmo-folder-diff entity))
 809                  (error
 810                   ;; maybe not exist folder.
 811                   (if (not (elmo-folder-exists-p entity))
 812                       (if (not (elmo-folder-creatable-p entity))
 813                           (error "Folder %s is not found" entity)
 814                         (if (y-or-n-p
 815                              (format "Folder %s does not exist, create it?"
 816                                      entity))
 817                             (progn
 818                               (unless (elmo-create-folder entity)
 819                                 (error "Create folder failed"))
 820                               ;; one more try.
 821                               (if (wl-string-member entity wl-strict-diff-folders)
 822                                   (elmo-strict-folder-diff entity)
 823                                 (elmo-folder-diff entity)))
 824                           (error "Folder is not created")))
 825                     (signal (car err) (cdr err))))))
 826          unread unsync nomif)
 827     (if (and (eq wl-folder-notify-deleted 'sync)
 828              (car nums)
 829              (or (> 0 (car nums)) (> 0 (cdr nums))))
 830         (progn
 831           (wl-folder-sync-entity entity)
 832           (setq nums (elmo-folder-diff entity)))
 833       (unless wl-folder-notify-deleted
 834         (setq unsync (if (and (car nums) (> 0 (car nums))) 0 (car nums)))
 835         (setq nomif (if (and (car nums) (> 0 (cdr nums))) 0 (cdr nums)))
 836         (setq nums (cons unsync nomif)))
 837       (wl-folder-entity-hashtb-set wl-folder-entity-hashtb entity
 838                                    (list (car nums)
 839                                          (setq
 840                                           unread
 841                                           (or
 842                                            ;; If server diff, All unreads are
 843                                            ;; treated as unsync.
 844                                            (if elmo-use-server-diff 0)
 845                                            (elmo-folder-get-info-unread entity)
 846                                            (wl-summary-count-unread
 847                                             (elmo-msgdb-mark-load
 848                                              (elmo-msgdb-expand-path entity))
 849                                             entity)))
 850                                          (cdr nums))
 851                                    (current-buffer)))
 852     (setq wl-folder-info-alist-modified t)
 853     (sit-for 0)
 854     (list (if wl-folder-notify-deleted
 855               (car nums)
 856             (max (or (car nums) 0))) unread (cdr nums))))
 857
 858 (defun wl-folder-check-entity-async (entity &optional auto)
 859   (let ((elmo-nntp-groups-async t)
 860         (elist (if auto
 861                    (elmo-delete-if
 862                     'wl-folder-no-auto-check-folder-p
 863                     (wl-folder-get-entity-list entity))
 864                  (wl-folder-get-entity-list entity)))
 865         (nntp-connection-keys nil)
 866         folder spec-list local-elist net-elist server
 867         ret-val)
 868     (while elist
 869       (if (not (elmo-folder-plugged-p (car elist)))
 870           (message "Uncheck \"%s\"" (car elist))
 871         (setq spec-list
 872               (elmo-folder-get-primitive-spec-list (elmo-string (car elist))))
 873         (cond ((assq 'nntp spec-list)
 874                (wl-append net-elist (list (car elist)))
 875                (while spec-list
 876                  (when (eq (caar spec-list) 'nntp)
 877                    (when (not (string= server (nth 2 (car spec-list))))
 878                      (setq server (nth 2 (car spec-list)))
 879                      (message "Checking on \"%s\"" server))
 880                    (setq nntp-connection-keys
 881                          (elmo-nntp-get-folders-info-prepare
 882                           (car spec-list)
 883                           nntp-connection-keys)))
 884                  (setq spec-list (cdr spec-list))))
 885               (t
 886                (wl-append local-elist (list (car elist))))))
 887       (setq elist (cdr elist)))
 888     ;; check local entity at first
 889     (while (setq folder (pop local-elist))
 890       (if (not (elmo-folder-plugged-p folder))
 891           (message "Uncheck \"%s\"" folder)
 892         (message "Checking \"%s\"" folder)
 893         (setq ret-val
 894               (wl-folder-add-folder-info
 895                ret-val
 896                (wl-folder-check-one-entity folder)))
 897         ;;(sit-for 0)
 898         ))
 899     ;; check network entity at last
 900     (when net-elist
 901       (elmo-nntp-get-folders-info nntp-connection-keys)
 902       (while (setq folder (pop net-elist))
 903         (if (not (elmo-folder-plugged-p folder))
 904             (message "Uncheck \"%s\"" folder)
 905           (message "Checking \"%s\"" folder)
 906           (setq ret-val
 907                 (wl-folder-add-folder-info
 908                  ret-val
 909                  (wl-folder-check-one-entity folder)))
 910           ;;(sit-for 0)
 911           )))
 912     ret-val))
 913
 914 ;;
 915 (defun wl-folder-resume-entity-hashtb-by-finfo (entity-hashtb info-alist)
 916   "Resume unread info for entity alist."
 917   (let (info)
 918     (while info-alist
 919       (setq info (nth 1 (car info-alist)))
 920       (wl-folder-set-entity-info (caar info-alist)
 921                                  (list (nth 2 info)(nth 3 info)(nth 1 info))
 922                                  entity-hashtb)
 923       (setq info-alist (cdr info-alist)))))
 924
 925 (defun wl-folder-move-path (path)
 926   (let ((fp (if (consp path)
 927                 path
 928               ;; path is entity-id
 929               (wl-folder-get-path wl-folder-entity path))))
 930     (goto-char (point-min))
 931     (while (and fp
 932                 (not (eobp)))
 933       (when (equal (car fp)
 934                    (wl-folder-get-entity-from-buffer t))
 935         (setq fp (cdr fp))
 936         (setq wl-folder-buffer-cur-point (point)))
 937       (forward-line 1))
 938     (and wl-folder-buffer-cur-point
 939          (goto-char wl-folder-buffer-cur-point))))
 940
 941 (defun wl-folder-set-current-entity-id (entity-id)
 942   (let ((buf (get-buffer wl-folder-buffer-name)))
 943     (if buf
 944         (save-excursion
 945           (set-buffer buf)
 946           (setq wl-folder-buffer-cur-entity-id entity-id)
 947           (setq wl-folder-buffer-cur-path (wl-folder-get-path wl-folder-entity
 948                                                               entity-id))
 949           (wl-highlight-folder-path wl-folder-buffer-cur-path)
 950           (and wl-folder-move-cur-folder
 951                wl-folder-buffer-cur-point
 952                (goto-char wl-folder-buffer-cur-point))))
 953     (if (eq (current-buffer) buf)
 954         (and wl-folder-move-cur-folder
 955              wl-folder-buffer-cur-point
 956              (goto-char wl-folder-buffer-cur-point)))))
 957
 958 (defun wl-folder-check-current-entity ()
 959   "Check folder at position.
 960 If current line is group folder, check all sub entries."
 961   (interactive)
 962   (let* ((entity-name (wl-folder-get-entity-from-buffer))
 963          (group (wl-folder-buffer-group-p))
 964          (desktop (string= entity-name wl-folder-desktop-name)))
 965     (when entity-name
 966       (wl-folder-check-entity
 967        (if group
 968            (wl-folder-search-group-entity-by-name entity-name
 969                                                   wl-folder-entity)
 970          entity-name)
 971        desktop))))
 972
 973 (defun wl-folder-sync-entity (entity &optional unread-only)
 974   "Synchronize the msgdb of ENTITY."
 975   (cond
 976    ((consp entity)
 977     (let ((flist (nth 2 entity)))
 978       (while flist
 979         (wl-folder-sync-entity (car flist) unread-only)
 980         (setq flist (cdr flist)))))
 981    ((stringp entity)
 982     (let ((nums (wl-folder-get-entity-info entity))
 983           (wl-summary-highlight (if (or (wl-summary-sticky-p entity)
 984                                         (wl-summary-always-sticky-folder-p
 985                                          entity))
 986                                     wl-summary-highlight))
 987           wl-auto-select-first new unread)
 988       (setq new (or (car nums) 0))
 989       (setq unread (or (cadr nums) 0))
 990       (if (or (not unread-only)
 991               (or (< 0 new) (< 0 unread)))
 992           (save-window-excursion
 993             (save-excursion
 994               (wl-summary-goto-folder-subr entity
 995                                            (wl-summary-get-sync-range entity)
 996                                            nil nil nil t)
 997               (wl-summary-exit))))))))
 998
 999 (defun wl-folder-sync-current-entity (&optional unread-only)
1000   "Synchronize the folder at position.
1001 If current line is group folder, check all subfolders."
1002   (interactive "P")
1003   (save-excursion
1004     (let ((entity-name (wl-folder-get-entity-from-buffer))
1005           (group (wl-folder-buffer-group-p)))
1006       (when (and entity-name
1007                  (y-or-n-p (format "Sync %s?" entity-name)))
1008         (wl-folder-sync-entity
1009          (if group
1010              (wl-folder-search-group-entity-by-name entity-name
1011                                                     wl-folder-entity)
1012            entity-name)
1013          unread-only)
1014         (message "Syncing %s is done!" entity-name)))))
1015
1016 (defun wl-folder-mark-as-read-all-entity (entity)
1017   "Mark as read all messages in the ENTITY"
1018   (cond
1019    ((consp entity)
1020     (let ((flist (nth 2 entity)))
1021       (while flist
1022         (wl-folder-mark-as-read-all-entity (car flist))
1023         (setq flist (cdr flist)))))
1024    ((stringp entity)
1025     (let ((nums (wl-folder-get-entity-info entity))
1026           (wl-summary-highlight (if (or (wl-summary-sticky-p entity)
1027                                         (wl-summary-always-sticky-folder-p
1028                                          entity))
1029                                     wl-summary-highlight))
1030           wl-auto-select-first new unread)
1031       (setq new (or (car nums) 0))
1032       (setq unread (or (cadr nums) 0))
1033       (if (or (< 0 new) (< 0 unread))
1034         (save-window-excursion
1035           (save-excursion
1036             (wl-summary-goto-folder-subr entity
1037                                          (wl-summary-get-sync-range entity)
1038                                          nil)
1039             (wl-summary-mark-as-read-all)
1040             (wl-summary-exit)))
1041         (sit-for 0))))))
1042
1043 (defun wl-folder-mark-as-read-all-current-entity ()
1044   "Mark as read all messages in the folder at position.
1045 If current line is group folder, all subfolders are marked."
1046   (interactive)
1047   (save-excursion
1048     (let ((entity-name (wl-folder-get-entity-from-buffer))
1049           (group (wl-folder-buffer-group-p))
1050           summary-buf)
1051       (when (and entity-name
1052                  (y-or-n-p (format "Mark all messages in %s as read?" entity-name)))
1053         (wl-folder-mark-as-read-all-entity
1054          (if group
1055              (wl-folder-search-group-entity-by-name entity-name
1056                                                     wl-folder-entity)
1057            entity-name))
1058         (message "All messages in %s are marked!" entity-name)))))
1059
1060 (defun wl-folder-check-region (beg end)
1061   (interactive "r")
1062   (goto-char beg)
1063   (beginning-of-line)
1064   (setq beg (point))
1065   (goto-char end)
1066   (beginning-of-line)
1067   (setq end (point))
1068   (goto-char beg)
1069   (let ((inhibit-read-only t)
1070         entity)
1071     (while (< (point) end)
1072       ;; normal folder entity
1073       (if (looking-at "^[\t ]*\\([^\\[]+\\):\\(.*\\)\n")
1074           (save-excursion
1075             (setq entity (wl-folder-get-entity-from-buffer))
1076             (if (not (elmo-folder-plugged-p entity))
1077                 (message "Uncheck %s" entity)
1078               (message "Checking %s" entity)
1079               (wl-folder-check-one-entity entity)
1080               (sit-for 0))))
1081       (forward-line 1)))
1082   (message ""))
1083
1084 (defun wl-folder-sync-region (beg end)
1085   (interactive "r")
1086   (goto-char beg)
1087   (beginning-of-line)
1088   (setq beg (point))
1089   (goto-char end)
1090   (end-of-line)
1091   (setq end (point))
1092   (goto-char beg)
1093   (while (< (point) end)
1094     ;; normal folder entity
1095     (if (looking-at "^[\t ]*\\([^\\[]+\\):\\(.*\\)\n")
1096         (save-excursion
1097           (let ((inhibit-read-only t)
1098                 entity)
1099             (setq entity (wl-folder-get-entity-from-buffer))
1100             (wl-folder-sync-entity entity)
1101             (message "Syncing %s is done!" entity)
1102             (sit-for 0))))
1103     (forward-line 1))
1104   (message ""))
1105
1106 (defun wl-folder-mark-as-read-all-region (beg end)
1107   (interactive "r")
1108   (goto-char beg)
1109   (beginning-of-line)
1110   (setq beg (point))
1111   (goto-char end)
1112   (end-of-line)
1113   (setq end (point))
1114   (goto-char beg)
1115   (while (< (point) end)
1116     ;; normal folder entity
1117     (if (looking-at "^[\t ]*\\([^\\[]+\\):\\(.*\\)\n")
1118         (save-excursion
1119           (let ((inhibit-read-only t)
1120                 entity)
1121             (setq entity (wl-folder-get-entity-from-buffer))
1122             (wl-folder-mark-as-read-all-entity entity)
1123             (message "All messages in %s are marked!" entity)
1124             (sit-for 0))))
1125     (forward-line 1))
1126   (message ""))
1127
1128 (defsubst wl-create-access-init-load-p (folder)
1129   (let ((no-load-regexp (when (and
1130                                (not wl-folder-init-load-access-folders)
1131                                wl-folder-init-no-load-access-folders)
1132                           (mapconcat 'identity
1133                                      wl-folder-init-no-load-access-folders
1134                                      "\\|")))
1135         (load-regexp (and wl-folder-init-load-access-folders
1136                           (mapconcat 'identity
1137                                      wl-folder-init-load-access-folders
1138                                      "\\|"))))
1139     (cond (load-regexp (string-match load-regexp folder))
1140           (t (not (and no-load-regexp
1141                        (string-match no-load-regexp folder)))))))
1142
1143 (defun wl-create-access-folder-entity (name)
1144   (let (flists flist)
1145     (when (wl-create-access-init-load-p name)
1146       (setq flists (elmo-msgdb-flist-load name)) ; load flist.
1147       (setq flist (car flists))
1148       (while flist
1149         (when (consp (car flist))
1150           (setcdr (cdar flist)
1151                   (wl-create-access-folder-entity (caar flist))))
1152         (setq flist (cdr flist)))
1153       flists)))
1154
1155 (defun wl-create-folder-entity-from-buffer ()
1156   "Create folder entity recursively."
1157   (cond
1158    ((looking-at "^[ \t]*$")             ; blank line
1159     (goto-char (+ 1(match-end 0)))
1160     'ignore)
1161    ((looking-at "^#.*$")                ; comment
1162     (goto-char (+ 1 (match-end 0)))
1163     'ignore)
1164    ((looking-at "^[\t ]*\\(.+\\)[\t ]*{[\t ]*$") ; group definition
1165     (let (name entity flist)
1166       (setq name (wl-match-buffer 1))
1167       (goto-char (+ 1 (match-end 0)))
1168       (while (setq entity (wl-create-folder-entity-from-buffer))
1169         (unless (eq entity 'ignore)
1170           (wl-append flist (list entity))))
1171       (if (looking-at "^[\t ]*}[\t ]*$") ; end of group
1172           (progn
1173             (goto-char (+ 1 (match-end 0)))
1174             (if (wl-string-assoc name wl-folder-petname-alist)
1175                 (error "%s already defined as petname" name))
1176             (list name 'group flist))
1177         (error "Syntax error in folder definition"))))
1178    ((looking-at "^[\t ]*\\([^\t \n]+\\)[\t ]*/$") ; access it!
1179     (let (name)
1180       (setq name (wl-match-buffer 1))
1181       (goto-char (+ 1 (match-end 0)))
1182 ;      (condition-case ()
1183 ;         (unwind-protect
1184 ;             (setq flist (elmo-list-folders name)))
1185 ;       (error (message "Access to folder %s failed." name)))
1186 ;;       (setq flist (elmo-msgdb-flist-load name)) ; load flist.
1187 ;;       (setq unsublist (nth 1 flist))
1188 ;;       (setq flist (car flist))
1189 ;;       (list name 'access flist unsublist)))
1190       (append (list name 'access) (wl-create-access-folder-entity name))))
1191    ;((looking-at "^[\t ]*\\([^\t \n}]+\\)[\t ]*\\(\"[^\"]*\"\\)?[\t ]*$") ; normal folder entity
1192    ((looking-at "^[\t ]*=[ \t]+\\([^\n]+\\)$"); petname definition
1193     (goto-char (+ 1 (match-end 0)))
1194     (let ((rest (elmo-match-buffer 1))
1195           petname)
1196       (when (string-match "\\(\"[^\"]*\"\\)[\t ]*$" rest)
1197         (setq petname (elmo-delete-char ?\" (elmo-match-string 1 rest)))
1198         (setq rest (substring rest 0 (match-beginning 0))))
1199       (when (string-match "^[\t ]*\\(.*[^\t ]+\\)[\t ]+$" rest)
1200         (wl-folder-append-petname (elmo-match-string 1 rest)
1201                                   petname))
1202       'ignore))
1203    ((looking-at "^[ \t]*}[ \t]*$") ; end of group
1204     nil)
1205    ((looking-at "^.*$") ; normal folder entity
1206     (goto-char (+ 1 (match-end 0)))
1207     (let ((rest (elmo-match-buffer 0))
1208           realname petname)
1209       (if (string-match "\\(\"[^\"]*\"\\)[\t ]*$" rest)
1210           (progn
1211             (setq petname (elmo-delete-char ?\" (elmo-match-string 1 rest)))
1212             (setq rest (substring rest 0 (match-beginning 0)))
1213             (when (string-match "^[\t ]*\\(.*[^\t ]+\\)[\t ]+$" rest)
1214               (wl-folder-append-petname
1215                (setq realname (elmo-match-string 1 rest))
1216                petname)
1217               realname))
1218         (if (string-match "^[\t ]*\\(.+\\)$" rest)
1219             (elmo-match-string 1 rest)
1220           rest))))))
1221
1222 (defun wl-folder-create-folder-entity ()
1223   "Create folder entries."
1224   (let ((tmp-buf (get-buffer-create " *wl-folder-tmp*"))
1225         entity ret-val)
1226     (condition-case ()
1227         (progn
1228           (set-buffer tmp-buf)
1229           (erase-buffer)
1230           (insert-file-contents wl-folders-file)
1231           (goto-char (point-min))
1232           (while (and (not (eobp))
1233                       (setq entity (wl-create-folder-entity-from-buffer)))
1234             (unless (eq entity 'ignore)
1235               (wl-append ret-val (list entity))))
1236           (kill-buffer tmp-buf))
1237       (file-error nil))
1238     (setq ret-val (list wl-folder-desktop-name 'group ret-val))))
1239
1240 (defun wl-folder-entity-assign-id (entity &optional hashtb on-noid)
1241   (let* ((hashtb (or hashtb
1242                      (setq wl-folder-entity-id-name-hashtb
1243                            (elmo-make-hash wl-folder-entity-id))))
1244          (entities (list entity))
1245          entity-stack)
1246     (while entities
1247       (setq entity (wl-pop entities))
1248       (cond
1249        ((consp entity)
1250         (when (not (and on-noid
1251                         (get-text-property 0
1252                                            'wl-folder-entity-id
1253                                            (car entity))))
1254           (put-text-property 0 (length (car entity))
1255                              'wl-folder-entity-id
1256                              wl-folder-entity-id
1257                              (car entity))
1258           (wl-folder-set-id-name wl-folder-entity-id
1259                                  (car entity) hashtb))
1260         (and entities
1261              (wl-push entities entity-stack))
1262         (setq entities (nth 2 entity)))
1263        ((stringp entity)
1264         (when (not (and on-noid
1265                         (get-text-property 0
1266                                            'wl-folder-entity-id
1267                                            entity)))
1268           (put-text-property 0 (length entity)
1269                              'wl-folder-entity-id
1270                              wl-folder-entity-id
1271                              entity)
1272           (wl-folder-set-id-name wl-folder-entity-id
1273                                  entity hashtb))))
1274       (setq wl-folder-entity-id (+ 1 wl-folder-entity-id))
1275       (unless entities
1276         (setq entities (wl-pop entity-stack))))))
1277
1278 (defun wl-folder-click (e)
1279   (interactive "e")
1280   (mouse-set-point e)
1281   (beginning-of-line)
1282   (save-excursion
1283     (wl-folder-jump-to-current-entity)))
1284
1285 (defun wl-folder-select-buffer (buffer)
1286   (let ((gbw (get-buffer-window buffer))
1287         ret-val)
1288     (if gbw
1289         (progn (select-window gbw)
1290                (setq ret-val t))
1291       (condition-case ()
1292           (unwind-protect
1293               (split-window-horizontally wl-folder-window-width)
1294             (other-window 1))
1295         (error nil)))
1296     (set-buffer buffer)
1297     (switch-to-buffer buffer)
1298     ret-val
1299     ))
1300
1301 (defun wl-folder-toggle-disp-summary (&optional arg folder)
1302   (interactive)
1303   (if (or (and folder (assoc folder wl-folder-group-alist))
1304           (and (interactive-p) (wl-folder-buffer-group-p)))
1305       (error "This command is not available on Group"))
1306   (beginning-of-line)
1307   (let (wl-auto-select-first)
1308     (cond
1309      ((eq arg 'on)
1310       (setq wl-folder-buffer-disp-summary t))
1311      ((eq arg 'off)
1312       (setq wl-folder-buffer-disp-summary nil)
1313       ;; hide wl-summary window.
1314       (let ((cur-buf (current-buffer))
1315             (summary-buffer (wl-summary-get-buffer folder)))
1316         (wl-folder-select-buffer summary-buffer)
1317         (delete-window)
1318         (select-window (get-buffer-window cur-buf))))
1319      (t
1320       (setq wl-folder-buffer-disp-summary
1321             (not wl-folder-buffer-disp-summary))
1322       (let ((cur-buf (current-buffer))
1323             folder-name)
1324         (when (looking-at "^[ ]*\\([^\\[].+\\):.*\n")
1325           (setq folder-name (wl-folder-get-entity-from-buffer))
1326           (if wl-folder-buffer-disp-summary
1327               (progn
1328                 (wl-folder-select-buffer
1329                  (wl-summary-get-buffer-create folder-name))
1330                 (unwind-protect
1331                     (wl-summary-goto-folder-subr folder-name 'no-sync nil)
1332                   (select-window (get-buffer-window cur-buf))))
1333             (wl-folder-select-buffer (wl-summary-get-buffer folder-name))
1334             (delete-window)
1335             (select-window (get-buffer-window cur-buf)))))))))
1336
1337 (defun wl-folder-prev-unsync ()
1338   "move cursor to the previous unsync folder."
1339   (interactive)
1340   (let (start-point)
1341     (setq start-point (point))
1342     (beginning-of-line)
1343     (if (re-search-backward wl-folder-unsync-regexp nil t)
1344         (beginning-of-line)
1345       (goto-char start-point)
1346       (message "No more unsync folder"))))
1347
1348 (defun wl-folder-next-unsync (&optional plugged)
1349   "move cursor to the next unsync."
1350   (interactive)
1351   (let (start-point entity)
1352     (setq start-point (point))
1353     (end-of-line)
1354     (if (catch 'found
1355           (while (re-search-forward wl-folder-unsync-regexp nil t)
1356             (if (or (wl-folder-buffer-group-p)
1357                     (not plugged)
1358                     (setq entity
1359                           (wl-folder-get-realname
1360                            (wl-folder-folder-name)))
1361                     (elmo-folder-plugged-p entity))
1362                 (throw 'found t))))
1363         (beginning-of-line)
1364       (goto-char start-point)
1365       (message "No more unsync folder"))))
1366
1367 (defun wl-folder-prev-unread (&optional group)
1368   "move cursor to the previous unread folder."
1369   (interactive "P")
1370   (let (start-point)
1371     (setq start-point (point))
1372     (beginning-of-line)
1373     (if (re-search-backward (wl-folder-unread-regex group) nil t)
1374         (progn
1375           (beginning-of-line)
1376           (wl-folder-folder-name))
1377       (goto-char start-point)
1378       (message "No more unread folder")
1379       nil)))
1380
1381 (defun wl-folder-next-unread (&optional group)
1382   "move cursor to the next unread folder."
1383   (interactive "P")
1384   (let (start-point)
1385     (setq start-point (point))
1386     (end-of-line)
1387     (if (re-search-forward (wl-folder-unread-regex group) nil t)
1388         (progn
1389           (beginning-of-line)
1390           (wl-folder-folder-name))
1391       (goto-char start-point)
1392       (message "No more unread folder")
1393       nil)))
1394
1395 (defun wl-folder-mode ()
1396   "Major mode for Wanderlust Folder.
1397 See info under Wanderlust for full documentation.
1398
1399 Special commands:
1400 \\{wl-folder-mode-map}
1401
1402 Entering Folder mode calls the value of `wl-folder-mode-hook'."
1403   (interactive)
1404   (setq major-mode 'wl-folder-mode)
1405   (setq mode-name "Folder")
1406   (use-local-map wl-folder-mode-map)
1407   (setq buffer-read-only t)
1408   (setq inhibit-read-only nil)
1409   (setq truncate-lines t)
1410   (when wl-show-plug-status-on-modeline
1411     (setq mode-line-format (wl-make-modeline)))
1412   (easy-menu-add wl-folder-mode-menu)
1413   (wl-xmas-setup-folder)
1414   (run-hooks 'wl-folder-mode-hook))
1415
1416 (defun wl-folder-append-petname (realname petname)
1417   (let (pentry)
1418     ;; check group name.
1419     (if (wl-folder-search-group-entity-by-name petname wl-folder-entity)
1420         (error "%s already defined as group name" petname))
1421     (when (setq pentry (wl-string-assoc realname wl-folder-petname-alist))
1422       (setq wl-folder-petname-alist
1423             (delete pentry wl-folder-petname-alist)))
1424     (wl-append wl-folder-petname-alist
1425                (list (cons realname petname)))))
1426
1427 (defun wl-folder (&optional arg)
1428   (interactive "P")
1429   (let (initialize)
1430 ;  (delete-other-windows)
1431   (if (get-buffer wl-folder-buffer-name)
1432       (switch-to-buffer  wl-folder-buffer-name)
1433     (switch-to-buffer (get-buffer-create wl-folder-buffer-name))
1434     (setq mode-line-buffer-identification '("Wanderlust: %12b"))
1435     (wl-folder-mode)
1436     (wl-folder-init)
1437     (wl-folder-init-icons)
1438     (set-buffer wl-folder-buffer-name)
1439     (let ((inhibit-read-only t)
1440           (buffer-read-only nil))
1441       (erase-buffer)
1442       (setcdr (assoc (car wl-folder-entity) wl-folder-group-alist) t)
1443       (save-excursion
1444         (wl-folder-insert-entity " " wl-folder-entity)))
1445     (set-buffer-modified-p nil)
1446     (sit-for 0)
1447     (setq initialize t))
1448   (if (not arg)
1449       (progn
1450         (run-hooks 'wl-auto-check-folder-pre-hook)
1451         (cond
1452          ((eq wl-auto-check-folder-name 'none))
1453          ((or (consp wl-auto-check-folder-name)
1454               (stringp wl-auto-check-folder-name))
1455           (let ((folder-list (if (consp wl-auto-check-folder-name)
1456                                  wl-auto-check-folder-name
1457                                (list wl-auto-check-folder-name)))
1458                 entity)
1459             (while folder-list
1460               (if (setq entity (wl-folder-search-entity-by-name
1461                                 (car folder-list)
1462                                 wl-folder-entity))
1463                   (wl-folder-check-entity entity 'auto))
1464               (setq folder-list (cdr folder-list)))))
1465          (t
1466           (wl-folder-check-entity wl-folder-entity 'auto)))
1467         (run-hooks 'wl-auto-check-folder-hook)))
1468   initialize))
1469
1470 (defun wl-folder-set-folder-updated (name value)
1471   (save-excursion
1472     (let (buf)
1473       (if (setq buf (get-buffer wl-folder-buffer-name))
1474           (wl-folder-entity-hashtb-set
1475            wl-folder-entity-hashtb name value buf))
1476 ;;       (elmo-folder-set-info-hashtb (elmo-string name)
1477 ;;                                nil
1478 ;;                                (nth 2 value)
1479 ;;                                (nth 0 value)
1480 ;;                                (nth 1 value))
1481       (setq wl-folder-info-alist-modified t))))
1482
1483 (defun wl-folder-calc-finfo (entity)
1484   ;; calcurate finfo without inserting.
1485   (let ((entities (list entity))
1486         entity-stack
1487         new unread all nums)
1488     (while entities
1489       (setq entity (wl-pop entities))
1490       (cond
1491        ((consp entity)
1492         (and entities
1493              (wl-push entities entity-stack))
1494         (setq entities (nth 2 entity)))
1495        ((stringp entity)
1496         (setq nums (wl-folder-get-entity-info entity))
1497         (setq new    (+ (or new 0) (or (nth 0 nums) 0)))
1498         (setq unread (+ (or unread 0)
1499                         (or (and (nth 0 nums)(nth 1 nums)
1500                                  (+ (nth 0 nums)(nth 1 nums))) 0)))
1501         (setq all    (+ (or all 0) (or (nth 2 nums) 0)))))
1502       (unless entities
1503         (setq entities (wl-pop entity-stack))))
1504     (list new unread all)))
1505
1506 (defsubst wl-folder-make-save-access-list (list)
1507   (mapcar '(lambda (x)
1508              (cond
1509               ((consp x)
1510                (list (elmo-string (car x)) 'access))
1511               (t
1512                (elmo-string x))))
1513           list))
1514
1515 (defun wl-folder-update-newest (indent entity)
1516   (let (ret-val new unread all)
1517     (cond
1518      ((consp entity)
1519       (let ((inhibit-read-only t)
1520             (buffer-read-only nil)
1521             (flist (nth 2 entity))
1522             (as-opened (cdr (assoc (car entity) wl-folder-group-alist)))
1523             beg
1524             )
1525         (setq beg (point))
1526         (if as-opened
1527             (let (update-flist flist-unsub new-flist removed group-name-end)
1528               (when (and (eq (cadr entity) 'access)
1529                          (elmo-folder-plugged-p (car entity)))
1530                 (message "Fetching folder entries...")
1531                 (when (setq new-flist
1532                             (elmo-list-folders
1533                              (elmo-string (car entity))
1534                              (wl-string-member
1535                               (car entity)
1536                               wl-folder-hierarchy-access-folders)))
1537                   (setq update-flist
1538                         (wl-folder-update-access-group entity new-flist))
1539                   (setq flist (nth 1 update-flist))
1540                   (when (car update-flist) ;; diff
1541                     (setq flist-unsub (nth 2 update-flist))
1542                     (setq removed (nth 3 update-flist))
1543                     (elmo-msgdb-flist-save
1544                      (car entity)
1545                      (list
1546                       (wl-folder-make-save-access-list flist)
1547                       (wl-folder-make-save-access-list flist-unsub)))
1548                     (wl-folder-entity-assign-id
1549                      entity
1550                      wl-folder-entity-id-name-hashtb
1551                      t)
1552                     (setq wl-folder-entity-hashtb
1553                           (wl-folder-create-entity-hashtb
1554                            entity
1555                            wl-folder-entity-hashtb
1556                            t))
1557                     (setq wl-folder-newsgroups-hashtb
1558                           (or
1559                            (wl-folder-create-newsgroups-hashtb
1560                             entity nil)
1561                            wl-folder-newsgroups-hashtb))))
1562                 (message "Fetching folder entries...done."))
1563               (wl-folder-insert-entity indent entity))))))))
1564
1565 (defun wl-folder-insert-entity (indent entity &optional onlygroup)
1566   (let (ret-val new unread all)
1567     (cond
1568      ((consp entity)
1569       (let ((inhibit-read-only t)
1570             (buffer-read-only nil)
1571             (flist (nth 2 entity))
1572             (as-opened (cdr (assoc (car entity) wl-folder-group-alist)))
1573             beg
1574             )
1575 ;      (insert indent "[" (if as-opened "-" "+") "]" (car entity) "\n")
1576 ;      (save-excursion (forward-line -1)
1577 ;                     (wl-highlight-folder-current-line))
1578         (setq beg (point))
1579         (if (and as-opened
1580                  (not onlygroup))
1581             (let (update-flist flist-unsub new-flist removed group-name-end)
1582 ;             (when (and (eq (cadr entity) 'access)
1583 ;                        newest)
1584 ;               (message "fetching folder entries...")
1585 ;               (when (setq new-flist
1586 ;                           (elmo-list-folders
1587 ;                            (elmo-string (car entity))
1588 ;                            (wl-string-member
1589 ;                             (car entity)
1590 ;                             wl-folder-hierarchy-access-folders)
1591 ;                            ))
1592 ;                 (setq update-flist
1593 ;                       (wl-folder-update-access-group entity new-flist))
1594 ;                 (setq flist (nth 1 update-flist))
1595 ;                 (when (car update-flist) ;; diff
1596 ;                   (setq flist-unsub (nth 2 update-flist))
1597 ;                   (setq removed (nth 3 update-flist))
1598 ;                   (elmo-msgdb-flist-save
1599 ;                    (car entity)
1600 ;                    (list
1601 ;                     (wl-folder-make-save-access-list flist)
1602 ;                     (wl-folder-make-save-access-list flist-unsub)))
1603 ;                   ;;
1604 ;                   ;; reconstruct wl-folder-entity-id-name-hashtb and
1605 ;                   ;;           wl-folder-entity-hashtb
1606 ;                   ;;
1607 ;                   (wl-folder-entity-assign-id
1608 ;                    entity
1609 ;                    wl-folder-entity-id-name-hashtb
1610 ;                    t)
1611 ;                   (setq wl-folder-entity-hashtb
1612 ;                         (wl-folder-create-entity-hashtb
1613 ;                          entity
1614 ;                          wl-folder-entity-hashtb
1615 ;                          t))
1616 ;                   (setq wl-folder-newsgroups-hashtb
1617 ;                         (or
1618 ;                          (wl-folder-create-newsgroups-hashtb
1619 ;                           entity nil)
1620 ;                          wl-folder-newsgroups-hashtb))))
1621 ;               (message "fetching folder entries...done."))
1622               (insert indent "[" (if as-opened "-" "+") "]"
1623                       (wl-folder-get-petname (car entity)))
1624               (setq group-name-end (point))
1625               (insert ":0/0/0\n")
1626               (put-text-property beg (point) 'wl-folder-entity-id
1627                                  (get-text-property 0 'wl-folder-entity-id
1628                                                     (car entity)))
1629               (when removed
1630                 (setq beg (point))
1631                 (while removed
1632                   (insert indent "  "
1633                           wl-folder-removed-mark
1634                           (if (listp (car removed))
1635                               (concat "[+]" (caar removed))
1636                             (car removed))
1637                           "\n")
1638                   (save-excursion (forward-line -1)
1639                                   (wl-highlight-folder-current-line))
1640                   (setq removed (cdr removed)))
1641                 (remove-text-properties beg (point) '(wl-folder-entity-id)))
1642               (let* ((len (length flist))
1643                      (mes (> len 100))
1644                      (i 0))
1645                 (while flist
1646                   (setq ret-val
1647                         (wl-folder-insert-entity
1648                          (concat indent "  ") (car flist)))
1649                   (setq new    (+ (or new 0) (or (nth 0 ret-val) 0)))
1650                   (setq unread (+ (or unread 0) (or (nth 1 ret-val) 0)))
1651                   (setq all    (+ (or all 0) (or (nth 2 ret-val) 0)))
1652                   (when mes
1653                     (setq i (1+ i))
1654                     (and (zerop (% i 10))
1655                          (elmo-display-progress
1656                           'wl-folder-insert-entity "Inserting group %s..."
1657                           (/ (* i 100) len) (car entity))))
1658                   (setq flist (cdr flist)))
1659                 (when mes (message "")))
1660               (save-excursion
1661                 (goto-char group-name-end)
1662                 (delete-region (point) (save-excursion (end-of-line)
1663                                                        (point)))
1664                 (insert (format ":%d/%d/%d" (or new 0)
1665                                 (or unread 0) (or all 0)))
1666                 (setq ret-val (list new unread all))
1667                 (wl-highlight-folder-current-line ret-val)))
1668           (setq ret-val (wl-folder-calc-finfo entity))
1669           (insert indent "[" (if as-opened "-" "+") "]"
1670                   (wl-folder-get-petname (car entity))
1671                   (format ":%d/%d/%d"
1672                           (or (nth 0 ret-val) 0)
1673                           (or (nth 1 ret-val) 0)
1674                           (or (nth 2 ret-val) 0))
1675                   "\n")
1676           (put-text-property beg (point) 'wl-folder-entity-id
1677                              (get-text-property 0 'wl-folder-entity-id
1678                                                 (car entity)))
1679           (save-excursion (forward-line -1)
1680                           (wl-highlight-folder-current-line ret-val)))))
1681      ((stringp entity)
1682       (let* ((inhibit-read-only t)
1683              (buffer-read-only nil)
1684              (nums (wl-folder-get-entity-info entity))
1685              beg)
1686         (setq beg (point))
1687         (insert indent (wl-folder-get-petname entity)
1688                 (format ":%s/%s/%s\n"
1689                         (or (setq new (nth 0 nums)) "*")
1690                         (or (setq unread (and (nth 0 nums)(nth 1 nums)
1691                                               (+ (nth 0 nums)(nth 1 nums))))
1692                             "*")
1693                         (or (setq all (nth 2 nums)) "*")))
1694         (put-text-property beg (point) 'wl-folder-entity-id
1695                            (get-text-property 0 'wl-folder-entity-id entity))
1696         (save-excursion (forward-line -1)
1697                         (wl-highlight-folder-current-line nums))
1698         (setq ret-val (list new unread all)))))
1699     (set-buffer-modified-p nil)
1700     ret-val))
1701
1702 (defun wl-folder-check-all ()
1703   (interactive)
1704   (wl-folder-check-entity wl-folder-entity))
1705
1706 (defun wl-folder-entity-hashtb-set (entity-hashtb name value buffer)
1707   (let (cur-val
1708         (new-diff 0)
1709         (unread-diff 0)
1710         (all-diff 0)
1711         diffs
1712         entity-list)
1713     (setq cur-val (wl-folder-get-entity-info name entity-hashtb))
1714     (setq new-diff    (- (or (nth 0 value) 0) (or (nth 0 cur-val) 0)))
1715     (setq unread-diff
1716           (+ new-diff
1717              (- (or (nth 1 value) 0) (or (nth 1 cur-val) 0))))
1718     (setq all-diff    (- (or (nth 2 value) 0) (or (nth 2 cur-val) 0)))
1719     (setq diffs (list new-diff unread-diff all-diff))
1720     (unless (and (nth 0 cur-val)
1721                  (equal diffs '(0 0 0)))
1722       (wl-folder-set-entity-info name value entity-hashtb)
1723       (save-match-data
1724         (save-excursion
1725           (set-buffer buffer)
1726           (setq entity-list (wl-folder-search-entity-list-by-name
1727                              name wl-folder-entity))
1728           (while entity-list
1729             (wl-folder-update-group (car entity-list) diffs)
1730             (setq entity-list (cdr entity-list)))
1731           (goto-char (point-min))
1732           (while (wl-folder-buffer-search-entity name)
1733             (wl-folder-update-line value)))))))
1734
1735 (defun wl-folder-update-unread (folder unread)
1736   (save-window-excursion
1737     (let ((buf (get-buffer wl-folder-buffer-name))
1738           cur-unread
1739           (unread-diff 0)
1740           ;;(fld (elmo-string folder))
1741           value newvalue entity-list)
1742       ;; Update folder-info
1743       ;;(elmo-folder-set-info-hashtb fld nil nil nil unread)
1744       (setq cur-unread (or (nth 1 (wl-folder-get-entity-info folder)) 0))
1745       (setq unread-diff (- (or unread 0) cur-unread))
1746       (setq value (wl-folder-get-entity-info folder))
1747
1748       (setq newvalue (list (nth 0 value)
1749                            unread
1750                            (nth 2 value)))
1751       (wl-folder-set-entity-info folder newvalue)
1752       (setq wl-folder-info-alist-modified t)
1753       (when (and buf
1754                  (not (eq unread-diff 0)))
1755         (save-match-data
1756           (save-excursion
1757             (set-buffer buf)
1758             (save-excursion
1759               (setq entity-list (wl-folder-search-entity-list-by-name
1760                                  folder wl-folder-entity))
1761               (while entity-list
1762                 (wl-folder-update-group (car entity-list) (list 0
1763                                                                 unread-diff
1764                                                                 0))
1765                 (setq entity-list (cdr entity-list)))
1766               (goto-char (point-min))
1767               (while (wl-folder-buffer-search-entity folder)
1768                 (wl-folder-update-line newvalue)))))))))
1769
1770 (defun wl-folder-create-entity-hashtb (entity &optional hashtb reconst)
1771   (let* ((hashtb (or hashtb (elmo-make-hash wl-folder-entity-id)))
1772          (entities (list entity))
1773          entity-stack)
1774     (while entities
1775       (setq entity (wl-pop entities))
1776       (cond
1777        ((consp entity)
1778         (and entities
1779              (wl-push entities entity-stack))
1780         (setq entities (nth 2 entity)))
1781        ((stringp entity)
1782         (when (not (and reconst
1783                         (wl-folder-get-entity-info entity)))
1784           (wl-folder-set-entity-info entity
1785                                      nil
1786                                      hashtb))))
1787       (unless entities
1788         (setq entities (wl-pop entity-stack))))
1789     hashtb))
1790
1791 ;; Unsync number is reserved.
1792 ;; (defun wl-folder-reconstruct-entity-hashtb (entity &optional hashtb id-name)
1793 ;;   (let* ((hashtb (or hashtb (elmo-make-hash wl-folder-entity-id)))
1794 ;;       (entities (list entity))
1795 ;;       entity-stack)
1796 ;;     (while entities
1797 ;;       (setq entity (wl-pop entities))
1798 ;;       (cond
1799 ;;        ((consp entity)
1800 ;;      (if id-name
1801 ;;          (wl-folder-set-id-name (wl-folder-get-entity-id (car entity))
1802 ;;                                 (car entity)))
1803 ;;      (and entities
1804 ;;           (wl-push entities entity-stack))
1805 ;;      (setq entities (nth 2 entity))
1806 ;;      )
1807 ;;        ((stringp entity)
1808 ;;      (wl-folder-set-entity-info entity
1809 ;;                           (wl-folder-get-entity-info entity)
1810 ;;                           hashtb)
1811 ;;      (if id-name
1812 ;;          (wl-folder-set-id-name (wl-folder-get-entity-id entity)
1813 ;;                                 entity))))
1814 ;;       (unless entities
1815 ;;      (setq entities (wl-pop entity-stack))))
1816 ;;     hashtb))
1817
1818 (defun wl-folder-create-newsgroups-from-nntp-access2 (entity)
1819   (let ((flist (nth 2 entity))
1820         folders)
1821     (and
1822      (setq folders
1823            (delq
1824             nil
1825             (mapcar
1826              '(lambda (fld)
1827                 (if (consp fld)
1828                     (wl-folder-create-newsgroups-from-nntp-access2 fld)
1829                   (nth 1 (elmo-folder-get-spec fld))))
1830              flist)))
1831      (elmo-nntp-make-groups-hashtb folders 1024))
1832     nil))
1833
1834 (defun wl-folder-create-newsgroups-from-nntp-access (entity)
1835   (let ((flist (nth 2 entity))
1836         folders)
1837     (while flist
1838       (wl-append folders
1839                  (cond
1840                   ((consp (car flist))
1841                    (wl-folder-create-newsgroups-from-nntp-access (car flist)))
1842                   (t
1843                    (list (nth 1 (elmo-folder-get-spec (car flist)))))))
1844       (setq flist (cdr flist)))
1845     folders))
1846
1847 (defun wl-folder-create-newsgroups-hashtb (entity &optional is-list info)
1848   (let ((entities (if is-list entity (list entity)))
1849         entity-stack spec-list folders fld make-hashtb)
1850     (and info (message "Creating newsgroups..."))
1851     (while entities
1852       (setq entity (wl-pop entities))
1853       (cond
1854        ((consp entity)
1855         (if (eq (nth 1 entity) 'access)
1856             (when (eq (elmo-folder-get-type (car entity)) 'nntp)
1857               (wl-append folders
1858                          (wl-folder-create-newsgroups-from-nntp-access entity))
1859               (setq make-hashtb t))
1860           (and entities
1861                (wl-push entities entity-stack))
1862           (setq entities (nth 2 entity))))
1863        ((stringp entity)
1864         (setq spec-list (elmo-folder-get-primitive-spec-list entity))
1865         (while spec-list
1866           (when (and (eq (caar spec-list) 'nntp)
1867                      (setq fld (nth 1 (car spec-list))))
1868             (wl-append folders (list (elmo-string fld))))
1869           (setq spec-list (cdr spec-list)))))
1870       (unless entities
1871         (setq entities (wl-pop entity-stack))))
1872     (and info (message "Creating newsgroups...done"))
1873     (if (or folders make-hashtb)
1874         (elmo-nntp-make-groups-hashtb folders))))
1875
1876 (defun wl-folder-get-path (entity target-id &optional string)
1877   (let* ((entities (list entity))
1878          entity-stack result-path)
1879     (reverse
1880      (catch 'done
1881        (while entities
1882          (setq entity (wl-pop entities))
1883          (cond
1884           ((consp entity)
1885            (if (and (or (not string) (string= string (car entity)))
1886                     ;; don't use eq, `id' is string on Nemacs.
1887                     (equal target-id (wl-folder-get-entity-id (car entity))))
1888                (throw 'done
1889                       (wl-push target-id result-path))
1890              (wl-push (wl-folder-get-entity-id (car entity)) result-path))
1891            (wl-push entities entity-stack)
1892            (setq entities (nth 2 entity)))
1893           ((stringp entity)
1894            (if (and (or (not string) (string= string entity))
1895                     ;; don't use eq, `id' is string on Nemacs.
1896                     (equal target-id (wl-folder-get-entity-id entity)))
1897                (throw 'done
1898                       (wl-push target-id result-path)))))
1899          (unless entities
1900            (while (and entity-stack
1901                        (not entities))
1902              (setq result-path (cdr result-path))
1903              (setq entities (wl-pop entity-stack)))))))))
1904
1905 (defun wl-folder-create-group-alist (entity)
1906   (if (consp entity)
1907       (let ((flist (nth 2 entity)) cur-alist append-alist)
1908         (setq cur-alist (list (cons (car entity) nil)))
1909         (while flist
1910           (if (consp (car flist))
1911               (wl-append append-alist
1912                          (wl-folder-create-group-alist (car flist))))
1913           (setq flist (cdr flist)))
1914         (append cur-alist append-alist))))
1915
1916 (defun wl-folder-init-info-hashtb ()
1917   (let ((info-alist (and wl-folder-info-save
1918                          (elmo-msgdb-finfo-load))))
1919     (elmo-folder-info-make-hashtb
1920      info-alist
1921      wl-folder-entity-hashtb)))
1922 ;;     (wl-folder-resume-entity-hashtb-by-finfo
1923 ;;      wl-folder-entity-hashtb
1924 ;;      info-alist)))
1925
1926 (defun wl-folder-cleanup-variables ()
1927   (setq wl-folder-entity nil
1928         wl-folder-entity-hashtb nil
1929         wl-folder-entity-id-name-hashtb nil
1930         wl-folder-group-alist nil
1931         wl-folder-petname-alist nil
1932         wl-folder-newsgroups-hashtb nil
1933         wl-fldmgr-cut-entity-list nil
1934         wl-fldmgr-modified nil
1935         wl-fldmgr-modified-access-list nil
1936         wl-score-cache nil
1937         ))
1938
1939 (defun wl-make-plugged-alist ()
1940   (let ((entity-list (wl-folder-get-entity-list wl-folder-entity))
1941         (add (not wl-reset-plugged-alist)))
1942     (while entity-list
1943       (elmo-folder-set-plugged
1944        (elmo-string (car entity-list)) wl-plugged add)
1945       (setq entity-list (cdr entity-list)))
1946     ;; smtp posting server
1947     (when wl-smtp-posting-server
1948       (elmo-set-plugged wl-plugged
1949                         wl-smtp-posting-server  ; server
1950                         (or (and (boundp 'smtp-service) smtp-service)
1951                             "smtp")     ; port
1952                         nil nil "smtp" add))
1953     ;; nntp posting server
1954     (when wl-nntp-posting-server
1955       (elmo-set-plugged wl-plugged
1956                         wl-nntp-posting-server
1957                         elmo-default-nntp-port
1958                         nil nil "nntp" add))
1959     (wl-plugged-init-icons)
1960     ;; user setting
1961     (run-hooks 'wl-make-plugged-hook)))
1962
1963 (defvar wl-folder-init-func 'wl-local-folder-init)
1964
1965 (defun wl-folder-init ()
1966   (interactive)
1967   (funcall wl-folder-init-func))
1968
1969 (defun wl-local-folder-init ()
1970   (message "Initializing folder...")
1971   (save-excursion
1972     (let* ((entity (wl-folder-create-folder-entity))
1973            (inhibit-read-only t))
1974       (setq wl-folder-entity entity)
1975       (setq wl-folder-entity-id 0)
1976       (wl-folder-entity-assign-id wl-folder-entity)
1977       (setq wl-folder-entity-hashtb
1978             (wl-folder-create-entity-hashtb entity))
1979       (setq wl-folder-group-alist
1980             (wl-folder-create-group-alist entity))
1981       (setq wl-folder-newsgroups-hashtb
1982             (wl-folder-create-newsgroups-hashtb wl-folder-entity))
1983       (wl-folder-init-info-hashtb)
1984       (setq wl-folder-buffer-cur-entity-id nil
1985             wl-folder-buffer-cur-path nil
1986             wl-folder-buffer-cur-point nil)))
1987   (message "Initializing folder...done."))
1988
1989 (defun wl-folder-get-realname (petname)
1990   (or (car
1991        (wl-string-rassoc
1992         petname
1993         wl-folder-petname-alist))
1994       petname))
1995
1996 (defun wl-folder-get-petname (folder)
1997   (or (cdr
1998        (wl-string-assoc
1999         folder
2000         wl-folder-petname-alist))
2001       folder))
2002
2003 (defun wl-folder-get-entity-with-petname ()
2004   (let ((alist wl-folder-petname-alist)
2005         (hashtb (copy-sequence wl-folder-entity-hashtb)))
2006     (while alist
2007       (wl-folder-set-entity-info (cdar alist) nil hashtb)
2008       (setq alist (cdr alist)))
2009     hashtb))
2010
2011 (defun wl-folder-update-diff-line (diffs)
2012   (let ((inhibit-read-only t)
2013         (buffer-read-only nil)
2014         cur-new new-new
2015         cur-unread new-unread
2016         cur-all new-all
2017         id)
2018     (save-excursion
2019       (beginning-of-line)
2020       (setq id (get-text-property (point) 'wl-folder-entity-id))
2021       (when (looking-at "^[ ]*\\(.*\\):\\([0-9\\*-]*\\)/\\([0-9\\*-]*\\)/\\([0-9\\*]*\\)")
2022         ;;(looking-at "^[ ]*\\([^\\[].+\\):\\([0-9\\*-]*/[0-9\\*-]*/[0-9\\*]*\\)")
2023         (setq cur-new (string-to-int
2024                        (wl-match-buffer 2)))
2025         (setq cur-unread (string-to-int
2026                           (wl-match-buffer 3)))
2027         (setq cur-all (string-to-int
2028                        (wl-match-buffer 4)))
2029         (delete-region (match-beginning 2)
2030                        (match-end 4))
2031         (goto-char (match-beginning 2))
2032         (insert (format "%s/%s/%s"
2033                         (setq new-new (+ cur-new (nth 0 diffs)))
2034                         (setq new-unread (+ cur-unread (nth 1 diffs)))
2035                         (setq new-all (+ cur-all (nth 2 diffs)))))
2036         (put-text-property (match-beginning 2) (point)
2037                            'wl-folder-entity-id id)
2038         (if wl-use-highlight-mouse-line
2039             (put-text-property (match-beginning 2) (point)
2040                                'mouse-face 'highlight))
2041         (wl-highlight-folder-group-line (list new-new new-unread new-all))
2042         (setq buffer-read-only t)
2043         (set-buffer-modified-p nil)))))
2044
2045 (defun wl-folder-update-line (nums &optional is-group)
2046   (let ((inhibit-read-only t)
2047         (buffer-read-only nil)
2048         id)
2049     (save-excursion
2050       (beginning-of-line)
2051       (setq id (get-text-property (point) 'wl-folder-entity-id))
2052       (if (looking-at "^[ ]*\\(.*\\):\\([0-9\\*-]*/[0-9\\*-]*/[0-9\\*]*\\)")
2053           ;;(looking-at "^[ ]*\\([^\\[].+\\):\\([0-9\\*-]*/[0-9\\*-]*/[0-9\\*]*\\)")
2054           (progn
2055             (delete-region (match-beginning 2)
2056                            (match-end 2))
2057             (goto-char (match-beginning 2))
2058             (insert (format "%s/%s/%s"
2059                             (or (nth 0 nums) "*")
2060                             (or (and (nth 0 nums)(nth 1 nums)
2061                                      (+ (nth 0 nums)(nth 1 nums)))
2062                                 "*")
2063                             (or (nth 2 nums) "*")))
2064             (put-text-property (match-beginning 2) (point)
2065                                'wl-folder-entity-id id)
2066             (if is-group
2067                 ;; update only colors
2068                 (wl-highlight-folder-group-line nums)
2069               (wl-highlight-folder-current-line nums))
2070             (set-buffer-modified-p nil))))))
2071
2072 (defun wl-folder-goto-folder (&optional arg)
2073   (interactive "P")
2074   (wl-folder-goto-folder-subr nil arg))
2075
2076 (defun wl-folder-goto-folder-subr (&optional folder sticky)
2077   (beginning-of-line)
2078   (let (summary-buf fld-name entity id error-selecting)
2079 ;;    (setq fld-name (wl-folder-get-entity-from-buffer))
2080 ;;    (if (or (null fld-name)
2081 ;;          (assoc fld-name wl-folder-group-alist))
2082     (setq fld-name wl-default-folder)
2083     (setq fld-name (or folder
2084                        (wl-summary-read-folder fld-name)))
2085     (if (and (setq entity
2086                    (wl-folder-search-entity-by-name fld-name
2087                                                     wl-folder-entity
2088                                                     'folder))
2089              (setq id (wl-folder-get-entity-id entity)))
2090         (wl-folder-set-current-entity-id id))
2091     (setq summary-buf (wl-summary-get-buffer-create fld-name sticky))
2092     (if wl-stay-folder-window
2093         (wl-folder-select-buffer summary-buf)
2094       (if (and summary-buf
2095                (get-buffer-window summary-buf))
2096           (delete-window)))
2097     (wl-summary-goto-folder-subr fld-name
2098                                  (wl-summary-get-sync-range fld-name)
2099                                  nil sticky t)))
2100
2101 (defun wl-folder-suspend ()
2102   (interactive)
2103   (run-hooks 'wl-folder-suspend-hook)
2104   (wl-folder-info-save)
2105   (wl-crosspost-alist-save)
2106   (wl-kill-buffers
2107    (format "^\\(%s\\)$"
2108            (mapconcat 'identity
2109                       (list (format "%s\\(:.*\\)?"
2110                                     (default-value 'wl-message-buf-name))
2111                             wl-original-buf-name)
2112                       "\\|")))
2113   (if (fboundp 'mmelmo-cleanup-entity-buffers)
2114       (mmelmo-cleanup-entity-buffers))
2115   (bury-buffer wl-folder-buffer-name)
2116   (delete-windows-on wl-folder-buffer-name t))
2117
2118 (defun wl-folder-info-save ()
2119   (when (and wl-folder-info-save
2120              wl-folder-info-alist-modified)
2121     (let ((entities (list wl-folder-entity))
2122           entity entity-stack info-alist info)
2123       (while entities
2124         (setq entity (wl-pop entities))
2125         (cond
2126          ((consp entity)
2127           (and entities
2128                (wl-push entities entity-stack))
2129           (setq entities (nth 2 entity)))
2130          ((stringp entity)
2131           (when (and (setq info (elmo-folder-get-info entity))
2132                      (not (equal info '(nil))))
2133             (wl-append info-alist (list (list (elmo-string entity)
2134                                               (list (nth 3 info)  ;; max
2135                                                     (nth 2 info)  ;; length
2136                                                     (nth 0 info)  ;; new
2137                                                     (nth 1 info)) ;; unread
2138                                               ))))))
2139         (unless entities
2140           (setq entities (wl-pop entity-stack))))
2141       (elmo-msgdb-finfo-save info-alist)
2142       (setq wl-folder-info-alist-modified nil))))
2143
2144 (defun wl-folder-goto-first-unread-folder (&optional arg)
2145   (interactive "P")
2146   (let ((entities (list wl-folder-entity))
2147         entity entity-stack ret-val
2148         first-entity finfo)
2149     (setq first-entity
2150           (catch 'done
2151             (while entities
2152               (setq entity (wl-pop entities))
2153               (cond
2154                ((consp entity)
2155                 (and entities
2156                      (wl-push entities entity-stack))
2157                 (setq entities (nth 2 entity)))
2158                ((stringp entity)
2159                 (if (and (setq finfo (wl-folder-get-entity-info entity))
2160                          (and (nth 0 finfo)(nth 1 finfo))
2161                          (> (+ (nth 0 finfo)(nth 1 finfo)) 0))
2162                     (throw 'done entity))
2163                 (wl-append ret-val (list entity))))
2164               (unless entities
2165                 (setq entities (wl-pop entity-stack))))))
2166     (if first-entity
2167         (progn
2168           (when arg
2169             (wl-folder-jump-folder first-entity)
2170             (sit-for 0))
2171           (wl-folder-goto-folder-subr first-entity))
2172       (message "No unread folder"))))
2173
2174 (defun wl-folder-jump-folder (&optional fld-name noopen)
2175   (interactive)
2176   (if (not fld-name)
2177       (setq fld-name (wl-summary-read-folder wl-default-folder)))
2178   (goto-char (point-min))
2179   (if (not noopen)
2180       (wl-folder-open-folder fld-name))
2181   (and (wl-folder-buffer-search-entity fld-name)
2182        (beginning-of-line)))
2183
2184 (defun wl-folder-get-entity-list (entity)
2185   (let ((entities (list entity))
2186         entity-stack ret-val)
2187     (while entities
2188       (setq entity (wl-pop entities))
2189       (cond
2190        ((consp entity)
2191         (and entities
2192              (wl-push entities entity-stack))
2193         (setq entities (nth 2 entity)))
2194        ((stringp entity)
2195         (wl-append ret-val (list entity))))
2196       (unless entities
2197         (setq entities (wl-pop entity-stack))))
2198     ret-val))
2199
2200 (defun wl-folder-open-unread-folder (entity)
2201   (save-excursion
2202     (let ((alist (wl-folder-get-entity-list entity))
2203           (unread 0)
2204           finfo path-list path id)
2205       (while alist
2206         (when (and (setq finfo (wl-folder-get-entity-info (car alist)))
2207                    (nth 0 finfo) (nth 1 finfo)
2208                    (> (+ (nth 0 finfo)(nth 1 finfo)) 0))
2209           (setq unread (+ unread (+ (nth 0 finfo)(nth 1 finfo))))
2210           (setq id (wl-folder-get-entity-id (car alist)))
2211           (setq path (delete id (wl-folder-get-path
2212                                  wl-folder-entity
2213                                  id
2214                                  (car alist))))
2215           (if (not (member path path-list))
2216               (wl-append path-list (list path))))
2217         (setq alist (cdr alist)))
2218       (while path-list
2219         (wl-folder-open-folder-sub (car path-list))
2220         (setq path-list (cdr path-list)))
2221       (message "%s unread folder"
2222                (if (> unread 0) unread "No")))))
2223
2224 (defun wl-folder-open-unread-current-entity ()
2225   (interactive)
2226   (let ((entity-name (wl-folder-get-entity-from-buffer))
2227         (group (wl-folder-buffer-group-p)))
2228     (when entity-name
2229       (wl-folder-open-unread-folder
2230        (if group
2231            (wl-folder-search-group-entity-by-name entity-name
2232                                                   wl-folder-entity)
2233          entity-name)))))
2234
2235 (defun wl-folder-open-only-unread-folder ()
2236   (interactive)
2237   (let ((id (progn
2238               (wl-folder-prev-entity-skip-invalid t)
2239               (wl-folder-get-entity-from-buffer t))))
2240     (wl-folder-open-all-unread-folder)
2241     (save-excursion
2242       (goto-char (point-max))
2243       (while (and (re-search-backward
2244                    "^[ ]*\\[[-]\\].+:0/0/[0-9-]+" nil t)
2245                   (not (bobp)))
2246         (wl-folder-jump-to-current-entity) ;; close it
2247         ))
2248     (wl-folder-move-path id)
2249     (recenter)))
2250
2251 (defun wl-folder-open-all-unread-folder (&optional arg)
2252   (interactive "P")
2253   (let ((id (progn
2254               (wl-folder-prev-entity-skip-invalid t)
2255               (wl-folder-get-entity-from-buffer t))))
2256     (wl-folder-open-unread-folder wl-folder-entity)
2257     (if (not arg)
2258         (wl-folder-move-path id)
2259       (goto-char (point-min))
2260       (wl-folder-next-unread t))))
2261
2262 (defun wl-folder-open-folder (&optional fld-name)
2263   (interactive)
2264   (if (not fld-name)
2265       (setq fld-name (wl-summary-read-folder wl-default-folder)))
2266   (let* ((id (wl-folder-get-entity-id
2267               (wl-folder-search-entity-by-name fld-name wl-folder-entity
2268                                                'folder)))
2269          (path (and id (wl-folder-get-path wl-folder-entity id))))
2270       (if path
2271           (wl-folder-open-folder-sub path))))
2272
2273 (defun wl-folder-open-folder-sub (path)
2274   (let ((inhibit-read-only t)
2275         (buffer-read-only nil)
2276         indent name entity
2277         err)
2278     (save-excursion
2279       (goto-char (point-min))
2280       (while (and path
2281                   (wl-folder-buffer-search-group
2282                    (wl-folder-get-petname
2283                     (if (stringp (car path))
2284                         (car path)
2285                       (wl-folder-get-folder-name-by-id
2286                        (car path))))))
2287         (beginning-of-line)
2288         (setq path (cdr path))
2289         (if (and (looking-at wl-folder-group-regexp)
2290                  (string= "+" (wl-match-buffer 2)));; closed group
2291             (save-excursion
2292               (setq indent (wl-match-buffer 1))
2293               (setq name (wl-folder-get-realname (wl-match-buffer 3)))
2294               (setq entity (wl-folder-search-group-entity-by-name
2295                             name
2296                             wl-folder-entity))
2297               ;; insert as opened
2298               (setcdr (assoc (car entity) wl-folder-group-alist) t)
2299               (if (eq 'access (cadr entity))
2300                   (wl-folder-maybe-load-folder-list entity))
2301               (wl-folder-insert-entity indent entity)
2302               (delete-region (save-excursion (beginning-of-line)
2303                                              (point))
2304                              (save-excursion (end-of-line)
2305                                              (+ 1 (point)))))))
2306       (set-buffer-modified-p nil))))
2307
2308 (defun wl-folder-open-all-pre ()
2309   (let ((entities (list wl-folder-entity))
2310         entity entity-stack group-entry)
2311     (while entities
2312       (setq entity (wl-pop entities))
2313       (cond
2314        ((consp entity)
2315         (unless (or (not (setq group-entry
2316                                (assoc (car entity) wl-folder-group-alist)))
2317                     (cdr group-entry))
2318           (setcdr group-entry t)
2319           (when (eq 'access (cadr entity))
2320             (wl-folder-maybe-load-folder-list entity)))
2321         (and entities
2322              (wl-push entities entity-stack))
2323         (setq entities (nth 2 entity))))
2324       (unless entities
2325         (setq entities (wl-pop entity-stack))))))
2326
2327 (defun wl-folder-open-all (&optional refresh)
2328   (interactive "P")
2329   (let* ((inhibit-read-only t)
2330          (buffer-read-only nil)
2331          (len (length wl-folder-group-alist))
2332          (i 0)
2333          indent name entity)
2334     (if refresh
2335         (let ((id (progn
2336                     (wl-folder-prev-entity-skip-invalid t)
2337                     (wl-folder-get-entity-from-buffer t))))
2338           (mapcar '(lambda (x)
2339                      (setcdr x t))
2340                   wl-folder-group-alist)
2341           (erase-buffer)
2342           (wl-folder-insert-entity " " wl-folder-entity)
2343           (wl-folder-move-path id))
2344       (message "Opening all folders...")
2345       (wl-folder-open-all-pre)
2346       (save-excursion
2347         (goto-char (point-min))
2348         (while (re-search-forward
2349                 "^\\([ ]*\\)\\[\\([+]\\)\\]\\(.+\\):[-0-9-]+/[0-9-]+/[0-9-]+\n"
2350                 nil t)
2351           (setq indent (wl-match-buffer 1))
2352           (setq name (wl-folder-get-realname (wl-match-buffer 3)))
2353           (setq entity (wl-folder-search-group-entity-by-name
2354                         name
2355                         wl-folder-entity))
2356           ;; insert as opened
2357           (setcdr (assoc (car entity) wl-folder-group-alist) t)
2358           (forward-line -1)
2359           (wl-folder-insert-entity indent entity)
2360           (delete-region (save-excursion (beginning-of-line)
2361                                          (point))
2362                          (save-excursion (end-of-line)
2363                                          (+ 1 (point))))
2364           (setq i (1+ i))
2365           (and (zerop (% i 10))
2366                (elmo-display-progress
2367                 'wl-folder-open-all "Opening all folders..."
2368                 (/ (* i 100) len))))))
2369     (message "Opening all folders...done")
2370     (set-buffer-modified-p nil)))
2371
2372 (defun wl-folder-close-all ()
2373   (interactive)
2374   (let ((inhibit-read-only t)
2375         (buffer-read-only nil)
2376         (alist wl-folder-group-alist)
2377         (id (progn
2378               (wl-folder-prev-entity-skip-invalid t)
2379               (wl-folder-get-entity-from-buffer t))))
2380     (while alist
2381       (setcdr (car alist) nil)
2382       (setq alist (cdr alist)))
2383     (setcdr (assoc (car wl-folder-entity) wl-folder-group-alist) t)
2384     (erase-buffer)
2385     (wl-folder-insert-entity " " wl-folder-entity)
2386     (wl-folder-move-path id)
2387     (recenter)
2388     (set-buffer-modified-p nil)))
2389
2390 (defun wl-folder-open-close ()
2391   "open or close parent entity."
2392   (interactive)
2393   (save-excursion
2394     (beginning-of-line)
2395     (if (wl-folder-buffer-group-p)
2396         ;; if group (whether opend or closed.)
2397         (wl-folder-jump-to-current-entity)
2398       ;; if folder
2399       (let (indent)
2400         (setq indent (save-excursion
2401                        (re-search-forward "\\([ ]*\\)." nil t)
2402                        (wl-match-buffer 1)))
2403         (while (looking-at indent)
2404           (forward-line -1)))
2405       (wl-folder-jump-to-current-entity))))
2406
2407 (defsubst wl-folder-access-subscribe-p (group folder)
2408   (let (subscr regexp match)
2409     (if (setq subscr (wl-get-assoc-list-value
2410                       wl-folder-access-subscribe-alist
2411                       group))
2412         (progn
2413           (setq regexp (mapconcat 'identity (cdr subscr) "\\|"))
2414           (setq match (string-match regexp folder))
2415           (if (car subscr)
2416               match
2417             (not match)))
2418       t)))
2419
2420 (defun wl-folder-update-access-group (entity new-flist)
2421   (let* ((flist (nth 2 entity))
2422          (unsubscribes (nth 3 entity))
2423          (len (+ (length flist) (length unsubscribes)))
2424          (i 0)
2425          diff new-unsubscribes removes
2426          subscribed-list folder group entry)
2427     ;; check subscribed groups
2428     (while flist
2429       (cond
2430        ((listp (car flist))     ;; group
2431         (setq group (elmo-string (caar flist)))
2432         (cond
2433          ((assoc group new-flist)       ;; found in new-flist
2434           (setq new-flist (delete (assoc group new-flist)
2435                                   new-flist))
2436           (if (wl-folder-access-subscribe-p (car entity) group)
2437               (wl-append subscribed-list (list (car flist)))
2438             (wl-append new-unsubscribes (list (car flist)))
2439             (setq diff t)))
2440          (t
2441           (setq wl-folder-group-alist
2442                 (delete (wl-string-assoc group wl-folder-group-alist)
2443                         wl-folder-group-alist))
2444           (wl-append removes (list (list group))))))
2445        (t                       ;; folder
2446         (setq folder (elmo-string (car flist)))
2447         (cond
2448          ((member folder new-flist)     ;; found in new-flist
2449           (setq new-flist (delete folder new-flist))
2450           (if (wl-folder-access-subscribe-p (car entity) folder)
2451               (wl-append subscribed-list (list (car flist)))
2452             (wl-append new-unsubscribes (list folder))
2453             (setq diff t)))
2454          (t
2455           (wl-append removes (list folder))))))
2456       (setq i (1+ i))
2457       (and (zerop (% i 10))
2458            (elmo-display-progress
2459             'wl-folder-update-access-group "Updating access group..."
2460             (/ (* i 100) len)))
2461       (setq flist (cdr flist)))
2462     ;; check unsubscribed groups
2463     (while unsubscribes
2464       (cond
2465        ((listp (car unsubscribes))
2466         (when (setq entry (assoc (caar unsubscribes) new-flist))
2467           (setq new-flist (delete entry new-flist))
2468           (wl-append new-unsubscribes (list (car unsubscribes)))))
2469        (t
2470         (when (member (car unsubscribes) new-flist)
2471           (setq new-flist (delete (car unsubscribes) new-flist))
2472           (wl-append new-unsubscribes (list (car unsubscribes))))))
2473       (setq i (1+ i))
2474       (and (zerop (% i 10))
2475            (elmo-display-progress
2476             'wl-folder-update-access-group "Updating access group..."
2477             (/ (* i 100) len)))
2478       (setq unsubscribes (cdr unsubscribes)))
2479     ;;
2480     (if (or new-flist removes)
2481         (setq diff t))
2482     (setq new-flist
2483           (mapcar '(lambda (x)
2484                      (cond ((consp x) (list (car x) 'access))
2485                            (t x)))
2486                   new-flist))
2487     ;; check new groups
2488     (let ((new-list new-flist))
2489       (while new-list
2490         (if (not (wl-folder-access-subscribe-p
2491                   (car entity)
2492                   (if (listp (car new-list))
2493                       (caar new-list)
2494                     (car new-list))))
2495             ;; auto unsubscribe
2496             (progn
2497               (wl-append new-unsubscribes (list (car new-list)))
2498               (setq new-flist (delete (car new-list) new-flist)))
2499           (cond
2500            ((listp (car new-list))
2501             ;; check group exists
2502             (if (wl-string-assoc (caar new-list) wl-folder-group-alist)
2503                 (progn
2504                   (message "%s: group already exists." (caar new-list))
2505                   (sit-for 1)
2506                   (wl-append new-unsubscribes (list (car new-list)))
2507                   (setq new-flist (delete (car new-list) new-flist)))
2508               (wl-append wl-folder-group-alist
2509                          (list (cons (caar new-list) nil)))))))
2510         (setq new-list (cdr new-list))))
2511     (if new-flist
2512         (message "%d new folder(s)." (length new-flist))
2513       (message "Updating access group...done"))
2514     (wl-append new-flist subscribed-list)       ;; new is first
2515     (run-hooks 'wl-folder-update-access-group-hook)
2516     (setcdr (cdr entity) (list new-flist new-unsubscribes))
2517     (list diff new-flist new-unsubscribes removes)))
2518
2519 (defun wl-folder-prefetch-entity (entity)
2520   "Prefetch all new messages in the ENTITY"
2521   (cond
2522    ((consp entity)
2523     (let ((flist (nth 2 entity))
2524           (sum-done 0)
2525           (sum-all 0)
2526           result)
2527       (while flist
2528         (setq result (wl-folder-prefetch-entity (car flist)))
2529         (setq sum-done (+ sum-done (car result)))
2530         (setq sum-all (+ sum-all (cdr result)))
2531         (setq flist (cdr flist)))
2532       (message "Prefetched %d/%d message(s) in \"%s\"."
2533                sum-done sum-all
2534                (wl-folder-get-petname (car entity)))
2535       (cons sum-done sum-all)))
2536    ((stringp entity)
2537     (let ((nums (wl-folder-get-entity-info entity))
2538           (wl-summary-highlight (if (or (wl-summary-sticky-p entity)
2539                                         (wl-summary-always-sticky-folder-p
2540                                          entity))
2541                                     wl-summary-highlight))
2542           wl-summary-exit-next-move
2543           wl-auto-select-first ret-val
2544           count)
2545       (setq count (or (car nums) 0))
2546       (setq count (+ count (wl-folder-count-incorporates entity)))
2547       (if (< 0 count)
2548           (save-window-excursion
2549             (save-excursion
2550               (wl-summary-goto-folder-subr entity
2551                                            (wl-summary-get-sync-range entity)
2552                                            nil)
2553               (setq ret-val (wl-summary-incorporate))
2554               (wl-summary-exit)
2555               ret-val))
2556         (cons 0 0))))))
2557
2558 (defun wl-folder-count-incorporates (folder)
2559   (let ((sum 0))
2560     (mapcar '(lambda (x)
2561                (if (member (cadr x)
2562                            wl-summary-incorporate-marks)
2563                    (incf sum)))
2564             (elmo-msgdb-mark-load (elmo-msgdb-expand-path folder)))
2565     sum))
2566
2567 (defun wl-folder-prefetch-current-entity (&optional no-check)
2568   "Prefetch all uncached messages in the folder at position.
2569 If current line is group folder, all subfolders are prefetched."
2570   (interactive "P")
2571   (save-excursion
2572     (let ((entity-name (wl-folder-get-entity-from-buffer))
2573           (group (wl-folder-buffer-group-p))
2574           wl-folder-check-entity-hook
2575           summary-buf entity)
2576       (when entity-name
2577         (setq entity
2578               (if group
2579                   (wl-folder-search-group-entity-by-name entity-name
2580                                                          wl-folder-entity)
2581                 entity-name))
2582         (if (not no-check)
2583             (wl-folder-check-entity entity))
2584         (wl-folder-prefetch-entity entity)))))
2585
2586 (defun wl-folder-drop-unsync-entity (entity)
2587   "Drop all unsync messages in the ENTITY"
2588   (cond
2589    ((consp entity)
2590     (let ((flist (nth 2 entity)))
2591       (while flist
2592         (wl-folder-drop-unsync-entity (car flist))
2593         (setq flist (cdr flist)))))
2594    ((stringp entity)
2595     (let ((nums (wl-folder-get-entity-info entity))
2596           wl-summary-highlight wl-auto-select-first new)
2597       (setq new (or (car nums) 0))
2598       (if (< 0 new)
2599           (save-window-excursion
2600             (save-excursion
2601               (wl-summary-goto-folder-subr entity 'no-sync nil)
2602               (wl-summary-drop-unsync)
2603               (wl-summary-exit))))))))
2604
2605 (defun wl-folder-drop-unsync-current-entity (&optional force-check)
2606   "Drop all unsync messages in the folder at position.
2607 If current line is group folder, all subfolders are dropped.
2608 If optional arg exists, don't check any folders."
2609   (interactive "P")
2610   (save-excursion
2611     (let ((entity-name (wl-folder-get-entity-from-buffer))
2612           (group (wl-folder-buffer-group-p))
2613           wl-folder-check-entity-hook
2614           summary-buf entity)
2615       (when (and entity-name
2616                  (y-or-n-p (format
2617                             "Drop all unsync messages in %s?" entity-name)))
2618         (setq entity
2619               (if group
2620                   (wl-folder-search-group-entity-by-name entity-name
2621                                                          wl-folder-entity)
2622                 entity-name))
2623         (if (null force-check)
2624             (wl-folder-check-entity entity))
2625         (wl-folder-drop-unsync-entity entity)
2626         (message "All unsync messages in %s are dropped!" entity-name)))))
2627
2628 (defun wl-folder-write-current-newsgroup ()
2629   (interactive)
2630   (wl-summary-write-current-newsgroup (wl-folder-entity-name)))
2631
2632 (defun wl-folder-mimic-kill-buffer ()
2633   "Kill the current (Folder) buffer with query."
2634   (interactive)
2635   (let ((bufname (read-buffer (format "Kill buffer: (default %s) "
2636                                       (buffer-name))))
2637         wl-interactive-exit)
2638     (if (or (not bufname)
2639             (string-equal bufname "")
2640             (string-equal bufname (buffer-name)))
2641         (wl-exit)
2642       (kill-buffer bufname))))
2643
2644 (defun wl-folder-confirm-existence (fld &optional ignore-error)
2645   (if (or (wl-folder-entity-exists-p fld)
2646           (file-exists-p (elmo-msgdb-expand-path fld)))
2647       ()
2648     (if ignore-error
2649         (condition-case nil
2650             (if (elmo-folder-exists-p fld)
2651                 ()
2652               (if (elmo-folder-creatable-p fld)
2653                   (if (y-or-n-p
2654                        (format "Folder %s does not exist, create it?" fld))
2655                       (progn
2656                         (setq wl-folder-entity-hashtb
2657                               (wl-folder-create-entity-hashtb
2658                                fld
2659                                wl-folder-entity-hashtb))
2660                         (elmo-create-folder fld)))))
2661           (error))
2662       (if (elmo-folder-exists-p fld)
2663           ()
2664         (if (not (elmo-folder-creatable-p fld))
2665             (error "Folder %s is not found" fld)
2666           (if (y-or-n-p
2667                (format "Folder %s does not exist, create it?" fld))
2668               (progn
2669                 (setq wl-folder-entity-hashtb
2670                       (wl-folder-create-entity-hashtb
2671                        fld
2672                        wl-folder-entity-hashtb))
2673                 (unless (elmo-create-folder fld)
2674                   (error "Create folder failed")))
2675             (error "Folder is not created")))))))
2676
2677 (provide 'wl-folder)
2678
2679 ;;; wl-folder.el ends here