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: <00/04/28 11:53:33 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                     (elmo-display-progress
1655                      'wl-folder-insert-entity "Inserting group %s..."
1656                      (/ (* i 100) len) (car entity)))
1657                   ;(elmo-display-progress
1658                   ; 'wl-folder-insert-entity "Inserting group %s..."
1659                   ; 100 (car entity))
1660                   (setq flist (cdr flist)))
1661                 (when mes (message "")))
1662               (save-excursion
1663                 (goto-char group-name-end)
1664                 (delete-region (point) (save-excursion (end-of-line)
1665                                                        (point)))
1666                 (insert (format ":%d/%d/%d" (or new 0)
1667                                 (or unread 0) (or all 0)))
1668                 (setq ret-val (list new unread all))
1669                 (wl-highlight-folder-current-line ret-val)))
1670           (setq ret-val (wl-folder-calc-finfo entity))
1671           (insert indent "[" (if as-opened "-" "+") "]"
1672                   (wl-folder-get-petname (car entity))
1673                   (format ":%d/%d/%d"
1674                           (or (nth 0 ret-val) 0)
1675                           (or (nth 1 ret-val) 0)
1676                           (or (nth 2 ret-val) 0))
1677                   "\n")
1678           (put-text-property beg (point) 'wl-folder-entity-id
1679                              (get-text-property 0 'wl-folder-entity-id
1680                                                 (car entity)))
1681           (save-excursion (forward-line -1)
1682                           (wl-highlight-folder-current-line ret-val)))))
1683      ((stringp entity)
1684       (let* ((inhibit-read-only t)
1685              (buffer-read-only nil)
1686              (nums (wl-folder-get-entity-info entity))
1687              beg)
1688         (setq beg (point))
1689         (insert indent (wl-folder-get-petname entity)
1690                 (format ":%s/%s/%s\n"
1691                         (or (setq new (nth 0 nums)) "*")
1692                         (or (setq unread (and (nth 0 nums)(nth 1 nums)
1693                                               (+ (nth 0 nums)(nth 1 nums))))
1694                             "*")
1695                         (or (setq all (nth 2 nums)) "*")))
1696         (put-text-property beg (point) 'wl-folder-entity-id
1697                            (get-text-property 0 'wl-folder-entity-id entity))
1698         (save-excursion (forward-line -1)
1699                         (wl-highlight-folder-current-line nums))
1700         (setq ret-val (list new unread all)))))
1701     (set-buffer-modified-p nil)
1702     ret-val))
1703
1704 (defun wl-folder-check-all ()
1705   (interactive)
1706   (wl-folder-check-entity wl-folder-entity))
1707
1708 (defun wl-folder-entity-hashtb-set (entity-hashtb name value buffer)
1709   (let (cur-val
1710         (new-diff 0)
1711         (unread-diff 0)
1712         (all-diff 0)
1713         diffs
1714         entity-list)
1715     (setq cur-val (wl-folder-get-entity-info name entity-hashtb))
1716     (setq new-diff    (- (or (nth 0 value) 0) (or (nth 0 cur-val) 0)))
1717     (setq unread-diff
1718           (+ new-diff
1719              (- (or (nth 1 value) 0) (or (nth 1 cur-val) 0))))
1720     (setq all-diff    (- (or (nth 2 value) 0) (or (nth 2 cur-val) 0)))
1721     (setq diffs (list new-diff unread-diff all-diff))
1722     (unless (and (nth 0 cur-val)
1723                  (equal diffs '(0 0 0)))
1724       (wl-folder-set-entity-info name value entity-hashtb)
1725       (save-match-data
1726         (save-excursion
1727           (set-buffer buffer)
1728           (setq entity-list (wl-folder-search-entity-list-by-name
1729                              name wl-folder-entity))
1730           (while entity-list
1731             (wl-folder-update-group (car entity-list) diffs)
1732             (setq entity-list (cdr entity-list)))
1733           (goto-char (point-min))
1734           (while (wl-folder-buffer-search-entity name)
1735             (wl-folder-update-line value)))))))
1736
1737 (defun wl-folder-update-unread (folder unread)
1738   (save-window-excursion
1739     (let ((buf (get-buffer wl-folder-buffer-name))
1740           cur-unread
1741           (unread-diff 0)
1742           ;;(fld (elmo-string folder))
1743           value newvalue entity-list)
1744       ;; Update folder-info
1745       ;;(elmo-folder-set-info-hashtb fld nil nil nil unread)
1746       (setq cur-unread (or (nth 1 (wl-folder-get-entity-info folder)) 0))
1747       (setq unread-diff (- (or unread 0) cur-unread))
1748       (setq value (wl-folder-get-entity-info folder))
1749
1750       (setq newvalue (list (nth 0 value)
1751                            unread
1752                            (nth 2 value)))
1753       (wl-folder-set-entity-info folder newvalue)
1754       (setq wl-folder-info-alist-modified t)
1755       (when (and buf
1756                  (not (eq unread-diff 0)))
1757         (save-match-data
1758           (save-excursion
1759             (set-buffer buf)
1760             (save-excursion
1761               (setq entity-list (wl-folder-search-entity-list-by-name
1762                                  folder wl-folder-entity))
1763               (while entity-list
1764                 (wl-folder-update-group (car entity-list) (list 0
1765                                                                 unread-diff
1766                                                                 0))
1767                 (setq entity-list (cdr entity-list)))
1768               (goto-char (point-min))
1769               (while (wl-folder-buffer-search-entity folder)
1770                 (wl-folder-update-line newvalue)))))))))
1771
1772 (defun wl-folder-create-entity-hashtb (entity &optional hashtb reconst)
1773   (let* ((hashtb (or hashtb (elmo-make-hash wl-folder-entity-id)))
1774          (entities (list entity))
1775          entity-stack)
1776     (while entities
1777       (setq entity (wl-pop entities))
1778       (cond
1779        ((consp entity)
1780         (and entities
1781              (wl-push entities entity-stack))
1782         (setq entities (nth 2 entity)))
1783        ((stringp entity)
1784         (when (not (and reconst
1785                         (wl-folder-get-entity-info entity)))
1786           (wl-folder-set-entity-info entity
1787                                      nil
1788                                      hashtb))))
1789       (unless entities
1790         (setq entities (wl-pop entity-stack))))
1791     hashtb))
1792
1793 ;; Unsync number is reserved.
1794 ;; (defun wl-folder-reconstruct-entity-hashtb (entity &optional hashtb id-name)
1795 ;;   (let* ((hashtb (or hashtb (elmo-make-hash wl-folder-entity-id)))
1796 ;;       (entities (list entity))
1797 ;;       entity-stack)
1798 ;;     (while entities
1799 ;;       (setq entity (wl-pop entities))
1800 ;;       (cond
1801 ;;        ((consp entity)
1802 ;;      (if id-name
1803 ;;          (wl-folder-set-id-name (wl-folder-get-entity-id (car entity))
1804 ;;                                 (car entity)))
1805 ;;      (and entities
1806 ;;           (wl-push entities entity-stack))
1807 ;;      (setq entities (nth 2 entity))
1808 ;;      )
1809 ;;        ((stringp entity)
1810 ;;      (wl-folder-set-entity-info entity
1811 ;;                           (wl-folder-get-entity-info entity)
1812 ;;                           hashtb)
1813 ;;      (if id-name
1814 ;;          (wl-folder-set-id-name (wl-folder-get-entity-id entity)
1815 ;;                                 entity))))
1816 ;;       (unless entities
1817 ;;      (setq entities (wl-pop entity-stack))))
1818 ;;     hashtb))
1819
1820 (defun wl-folder-create-newsgroups-from-nntp-access2 (entity)
1821   (let ((flist (nth 2 entity))
1822         folders)
1823     (and
1824      (setq folders
1825            (delq
1826             nil
1827             (mapcar
1828              '(lambda (fld)
1829                 (if (consp fld)
1830                     (wl-folder-create-newsgroups-from-nntp-access2 fld)
1831                   (nth 1 (elmo-folder-get-spec fld))))
1832              flist)))
1833      (elmo-nntp-make-groups-hashtb folders 1024))
1834     nil))
1835
1836 (defun wl-folder-create-newsgroups-from-nntp-access (entity)
1837   (let ((flist (nth 2 entity))
1838         folders)
1839     (while flist
1840       (wl-append folders
1841                  (cond
1842                   ((consp (car flist))
1843                    (wl-folder-create-newsgroups-from-nntp-access (car flist)))
1844                   (t
1845                    (list (nth 1 (elmo-folder-get-spec (car flist)))))))
1846       (setq flist (cdr flist)))
1847     folders))
1848
1849 (defun wl-folder-create-newsgroups-hashtb (entity &optional is-list info)
1850   (let ((entities (if is-list entity (list entity)))
1851         entity-stack spec-list folders fld make-hashtb)
1852     (and info (message "Creating newsgroups..."))
1853     (while entities
1854       (setq entity (wl-pop entities))
1855       (cond
1856        ((consp entity)
1857         (if (eq (nth 1 entity) 'access)
1858             (when (eq (elmo-folder-get-type (car entity)) 'nntp)
1859               (wl-append folders
1860                          (wl-folder-create-newsgroups-from-nntp-access entity))
1861               (setq make-hashtb t))
1862           (and entities
1863                (wl-push entities entity-stack))
1864           (setq entities (nth 2 entity))))
1865        ((stringp entity)
1866         (setq spec-list (elmo-folder-get-primitive-spec-list entity))
1867         (while spec-list
1868           (when (and (eq (caar spec-list) 'nntp)
1869                      (setq fld (nth 1 (car spec-list))))
1870             (wl-append folders (list (elmo-string fld))))
1871           (setq spec-list (cdr spec-list)))))
1872       (unless entities
1873         (setq entities (wl-pop entity-stack))))
1874     (and info (message "Creating newsgroups...done"))
1875     (if (or folders make-hashtb)
1876         (elmo-nntp-make-groups-hashtb folders))))
1877
1878 (defun wl-folder-get-path (entity target-id &optional string)
1879   (let* ((entities (list entity))
1880          entity-stack result-path)
1881     (reverse
1882      (catch 'done
1883        (while entities
1884          (setq entity (wl-pop entities))
1885          (cond
1886           ((consp entity)
1887            (if (and (or (not string) (string= string (car entity)))
1888                     ;; don't use eq, `id' is string on Nemacs.
1889                     (equal target-id (wl-folder-get-entity-id (car entity))))
1890                (throw 'done
1891                       (wl-push target-id result-path))
1892              (wl-push (wl-folder-get-entity-id (car entity)) result-path))
1893            (wl-push entities entity-stack)
1894            (setq entities (nth 2 entity)))
1895           ((stringp entity)
1896            (if (and (or (not string) (string= string entity))
1897                     ;; don't use eq, `id' is string on Nemacs.
1898                     (equal target-id (wl-folder-get-entity-id entity)))
1899                (throw 'done
1900                       (wl-push target-id result-path)))))
1901          (unless entities
1902            (while (and entity-stack
1903                        (not entities))
1904              (setq result-path (cdr result-path))
1905              (setq entities (wl-pop entity-stack)))))))))
1906
1907 (defun wl-folder-create-group-alist (entity)
1908   (if (consp entity)
1909       (let ((flist (nth 2 entity)) cur-alist append-alist)
1910         (setq cur-alist (list (cons (car entity) nil)))
1911         (while flist
1912           (if (consp (car flist))
1913               (wl-append append-alist
1914                          (wl-folder-create-group-alist (car flist))))
1915           (setq flist (cdr flist)))
1916         (append cur-alist append-alist))))
1917
1918 (defun wl-folder-init-info-hashtb ()
1919   (let ((info-alist (and wl-folder-info-save
1920                          (elmo-msgdb-finfo-load))))
1921     (elmo-folder-info-make-hashtb
1922      info-alist
1923      wl-folder-entity-hashtb)))
1924 ;;     (wl-folder-resume-entity-hashtb-by-finfo
1925 ;;      wl-folder-entity-hashtb
1926 ;;      info-alist)))
1927
1928 (defun wl-folder-cleanup-variables ()
1929   (setq wl-folder-entity nil
1930         wl-folder-entity-hashtb nil
1931         wl-folder-entity-id-name-hashtb nil
1932         wl-folder-group-alist nil
1933         wl-folder-petname-alist nil
1934         wl-folder-newsgroups-hashtb nil
1935         wl-fldmgr-cut-entity-list nil
1936         wl-fldmgr-modified nil
1937         wl-fldmgr-modified-access-list nil
1938         wl-score-cache nil
1939         ))
1940
1941 (defun wl-make-plugged-alist ()
1942   (let ((entity-list (wl-folder-get-entity-list wl-folder-entity))
1943         (add (not wl-reset-plugged-alist)))
1944     (while entity-list
1945       (elmo-folder-set-plugged
1946        (elmo-string (car entity-list)) wl-plugged add)
1947       (setq entity-list (cdr entity-list)))
1948     ;; smtp posting server
1949     (when wl-smtp-posting-server
1950       (elmo-set-plugged wl-plugged
1951                         wl-smtp-posting-server  ; server
1952                         (or (and (boundp 'smtp-service) smtp-service)
1953                             "smtp")     ; port
1954                         nil nil "smtp" add))
1955     ;; nntp posting server
1956     (when wl-nntp-posting-server
1957       (elmo-set-plugged wl-plugged
1958                         wl-nntp-posting-server
1959                         elmo-default-nntp-port
1960                         nil nil "nntp" add))
1961     (wl-plugged-init-icons)
1962     ;; user setting
1963     (run-hooks 'wl-make-plugged-hook)))
1964
1965 (defvar wl-folder-init-func 'wl-local-folder-init)
1966
1967 (defun wl-folder-init ()
1968   (interactive)
1969   (funcall wl-folder-init-func))
1970
1971 (defun wl-local-folder-init ()
1972   (message "Initializing folder...")
1973   (save-excursion
1974     (let* ((entity (wl-folder-create-folder-entity))
1975            (inhibit-read-only t))
1976       (setq wl-folder-entity entity)
1977       (setq wl-folder-entity-id 0)
1978       (wl-folder-entity-assign-id wl-folder-entity)
1979       (setq wl-folder-entity-hashtb
1980             (wl-folder-create-entity-hashtb entity))
1981       (setq wl-folder-group-alist
1982             (wl-folder-create-group-alist entity))
1983       (setq wl-folder-newsgroups-hashtb
1984             (wl-folder-create-newsgroups-hashtb wl-folder-entity))
1985       (wl-folder-init-info-hashtb)
1986       (setq wl-folder-buffer-cur-entity-id nil
1987             wl-folder-buffer-cur-path nil
1988             wl-folder-buffer-cur-point nil)))
1989   (message "Initializing folder...done."))
1990
1991 (defun wl-folder-get-realname (petname)
1992   (or (car
1993        (wl-string-rassoc
1994         petname
1995         wl-folder-petname-alist))
1996       petname))
1997
1998 (defun wl-folder-get-petname (folder)
1999   (or (cdr
2000        (wl-string-assoc
2001         folder
2002         wl-folder-petname-alist))
2003       folder))
2004
2005 (defun wl-folder-get-entity-with-petname ()
2006   (let ((alist wl-folder-petname-alist)
2007         (hashtb (copy-sequence wl-folder-entity-hashtb)))
2008     (while alist
2009       (wl-folder-set-entity-info (cdar alist) nil hashtb)
2010       (setq alist (cdr alist)))
2011     hashtb))
2012
2013 (defun wl-folder-update-diff-line (diffs)
2014   (let ((inhibit-read-only t)
2015         (buffer-read-only nil)
2016         cur-new new-new
2017         cur-unread new-unread
2018         cur-all new-all
2019         id)
2020     (save-excursion
2021       (beginning-of-line)
2022       (setq id (get-text-property (point) 'wl-folder-entity-id))
2023       (when (looking-at "^[ ]*\\(.*\\):\\([0-9\\*-]*\\)/\\([0-9\\*-]*\\)/\\([0-9\\*]*\\)")
2024         ;;(looking-at "^[ ]*\\([^\\[].+\\):\\([0-9\\*-]*/[0-9\\*-]*/[0-9\\*]*\\)")
2025         (setq cur-new (string-to-int
2026                        (wl-match-buffer 2)))
2027         (setq cur-unread (string-to-int
2028                           (wl-match-buffer 3)))
2029         (setq cur-all (string-to-int
2030                        (wl-match-buffer 4)))
2031         (delete-region (match-beginning 2)
2032                        (match-end 4))
2033         (goto-char (match-beginning 2))
2034         (insert (format "%s/%s/%s"
2035                         (setq new-new (+ cur-new (nth 0 diffs)))
2036                         (setq new-unread (+ cur-unread (nth 1 diffs)))
2037                         (setq new-all (+ cur-all (nth 2 diffs)))))
2038         (put-text-property (match-beginning 2) (point)
2039                            'wl-folder-entity-id id)
2040         (if wl-use-highlight-mouse-line
2041             (put-text-property (match-beginning 2) (point)
2042                                'mouse-face 'highlight))
2043         (wl-highlight-folder-group-line (list new-new new-unread new-all))
2044         (setq buffer-read-only t)
2045         (set-buffer-modified-p nil)))))
2046
2047 (defun wl-folder-update-line (nums &optional is-group)
2048   (let ((inhibit-read-only t)
2049         (buffer-read-only nil)
2050         id)
2051     (save-excursion
2052       (beginning-of-line)
2053       (setq id (get-text-property (point) 'wl-folder-entity-id))
2054       (if (looking-at "^[ ]*\\(.*\\):\\([0-9\\*-]*/[0-9\\*-]*/[0-9\\*]*\\)")
2055           ;;(looking-at "^[ ]*\\([^\\[].+\\):\\([0-9\\*-]*/[0-9\\*-]*/[0-9\\*]*\\)")
2056           (progn
2057             (delete-region (match-beginning 2)
2058                            (match-end 2))
2059             (goto-char (match-beginning 2))
2060             (insert (format "%s/%s/%s"
2061                             (or (nth 0 nums) "*")
2062                             (or (and (nth 0 nums)(nth 1 nums)
2063                                      (+ (nth 0 nums)(nth 1 nums)))
2064                                 "*")
2065                             (or (nth 2 nums) "*")))
2066             (put-text-property (match-beginning 2) (point)
2067                                'wl-folder-entity-id id)
2068             (if is-group
2069                 ;; update only colors
2070                 (wl-highlight-folder-group-line nums)
2071               (wl-highlight-folder-current-line nums))
2072             (set-buffer-modified-p nil))))))
2073
2074 (defun wl-folder-goto-folder (&optional arg)
2075   (interactive "P")
2076   (wl-folder-goto-folder-subr nil arg))
2077
2078 (defun wl-folder-goto-folder-subr (&optional folder sticky)
2079   (beginning-of-line)
2080   (let (summary-buf fld-name entity id error-selecting)
2081 ;;    (setq fld-name (wl-folder-get-entity-from-buffer))
2082 ;;    (if (or (null fld-name)
2083 ;;          (assoc fld-name wl-folder-group-alist))
2084     (setq fld-name wl-default-folder)
2085     (setq fld-name (or folder
2086                        (wl-summary-read-folder fld-name)))
2087     (if (and (setq entity
2088                    (wl-folder-search-entity-by-name fld-name
2089                                                     wl-folder-entity
2090                                                     'folder))
2091              (setq id (wl-folder-get-entity-id entity)))
2092         (wl-folder-set-current-entity-id id))
2093     (setq summary-buf (wl-summary-get-buffer-create fld-name sticky))
2094     (if wl-stay-folder-window
2095         (wl-folder-select-buffer summary-buf)
2096       (if (and summary-buf
2097                (get-buffer-window summary-buf))
2098           (delete-window)))
2099     (wl-summary-goto-folder-subr fld-name
2100                                  (wl-summary-get-sync-range fld-name)
2101                                  nil sticky t)))
2102
2103 (defun wl-folder-suspend ()
2104   (interactive)
2105   (run-hooks 'wl-folder-suspend-hook)
2106   (wl-folder-info-save)
2107   (wl-crosspost-alist-save)
2108   (wl-kill-buffers
2109    (format "^\\(%s\\)$"
2110            (mapconcat 'identity
2111                       (list (format "%s\\(:.*\\)?"
2112                                     (default-value 'wl-message-buf-name))
2113                             wl-original-buf-name)
2114                       "\\|")))
2115   (if (fboundp 'mmelmo-cleanup-entity-buffers)
2116       (mmelmo-cleanup-entity-buffers))
2117   (bury-buffer wl-folder-buffer-name)
2118   (delete-windows-on wl-folder-buffer-name t))
2119
2120 (defun wl-folder-info-save ()
2121   (when (and wl-folder-info-save
2122              wl-folder-info-alist-modified)
2123     (let ((entities (list wl-folder-entity))
2124           entity entity-stack info-alist info)
2125       (while entities
2126         (setq entity (wl-pop entities))
2127         (cond
2128          ((consp entity)
2129           (and entities
2130                (wl-push entities entity-stack))
2131           (setq entities (nth 2 entity)))
2132          ((stringp entity)
2133           (when (and (setq info (elmo-folder-get-info entity))
2134                      (not (equal info '(nil))))
2135             (wl-append info-alist (list (list (elmo-string entity)
2136                                               (list (nth 3 info)  ;; max
2137                                                     (nth 2 info)  ;; length
2138                                                     (nth 0 info)  ;; new
2139                                                     (nth 1 info)) ;; unread
2140                                               ))))))
2141         (unless entities
2142           (setq entities (wl-pop entity-stack))))
2143       (elmo-msgdb-finfo-save info-alist)
2144       (setq wl-folder-info-alist-modified nil))))
2145
2146 (defun wl-folder-goto-first-unread-folder (&optional arg)
2147   (interactive "P")
2148   (let ((entities (list wl-folder-entity))
2149         entity entity-stack ret-val
2150         first-entity finfo)
2151     (setq first-entity
2152           (catch 'done
2153             (while entities
2154               (setq entity (wl-pop entities))
2155               (cond
2156                ((consp entity)
2157                 (and entities
2158                      (wl-push entities entity-stack))
2159                 (setq entities (nth 2 entity)))
2160                ((stringp entity)
2161                 (if (and (setq finfo (wl-folder-get-entity-info entity))
2162                          (and (nth 0 finfo)(nth 1 finfo))
2163                          (> (+ (nth 0 finfo)(nth 1 finfo)) 0))
2164                     (throw 'done entity))
2165                 (wl-append ret-val (list entity))))
2166               (unless entities
2167                 (setq entities (wl-pop entity-stack))))))
2168     (if first-entity
2169         (progn
2170           (when arg
2171             (wl-folder-jump-folder first-entity)
2172             (sit-for 0))
2173           (wl-folder-goto-folder-subr first-entity))
2174       (message "No unread folder"))))
2175
2176 (defun wl-folder-jump-folder (&optional fld-name noopen)
2177   (interactive)
2178   (if (not fld-name)
2179       (setq fld-name (wl-summary-read-folder wl-default-folder)))
2180   (goto-char (point-min))
2181   (if (not noopen)
2182       (wl-folder-open-folder fld-name))
2183   (and (wl-folder-buffer-search-entity fld-name)
2184        (beginning-of-line)))
2185
2186 (defun wl-folder-get-entity-list (entity)
2187   (let ((entities (list entity))
2188         entity-stack ret-val)
2189     (while entities
2190       (setq entity (wl-pop entities))
2191       (cond
2192        ((consp entity)
2193         (and entities
2194              (wl-push entities entity-stack))
2195         (setq entities (nth 2 entity)))
2196        ((stringp entity)
2197         (wl-append ret-val (list entity))))
2198       (unless entities
2199         (setq entities (wl-pop entity-stack))))
2200     ret-val))
2201
2202 (defun wl-folder-open-unread-folder (entity)
2203   (save-excursion
2204     (let ((alist (wl-folder-get-entity-list entity))
2205           (unread 0)
2206           finfo path-list path id)
2207       (while alist
2208         (when (and (setq finfo (wl-folder-get-entity-info (car alist)))
2209                    (nth 0 finfo) (nth 1 finfo)
2210                    (> (+ (nth 0 finfo)(nth 1 finfo)) 0))
2211           (setq unread (+ unread (+ (nth 0 finfo)(nth 1 finfo))))
2212           (setq id (wl-folder-get-entity-id (car alist)))
2213           (setq path (delete id (wl-folder-get-path
2214                                  wl-folder-entity
2215                                  id
2216                                  (car alist))))
2217           (if (not (member path path-list))
2218               (wl-append path-list (list path))))
2219         (setq alist (cdr alist)))
2220       (while path-list
2221         (wl-folder-open-folder-sub (car path-list))
2222         (setq path-list (cdr path-list)))
2223       (message "%s unread folder"
2224                (if (> unread 0) unread "No")))))
2225
2226 (defun wl-folder-open-unread-current-entity ()
2227   (interactive)
2228   (let ((entity-name (wl-folder-get-entity-from-buffer))
2229         (group (wl-folder-buffer-group-p)))
2230     (when entity-name
2231       (wl-folder-open-unread-folder
2232        (if group
2233            (wl-folder-search-group-entity-by-name entity-name
2234                                                   wl-folder-entity)
2235          entity-name)))))
2236
2237 (defun wl-folder-open-only-unread-folder ()
2238   (interactive)
2239   (let ((id (progn
2240               (wl-folder-prev-entity-skip-invalid t)
2241               (wl-folder-get-entity-from-buffer t))))
2242     (wl-folder-open-all-unread-folder)
2243     (save-excursion
2244       (goto-char (point-max))
2245       (while (and (re-search-backward
2246                    "^[ ]*\\[[-]\\].+:0/0/[0-9-]+" nil t)
2247                   (not (bobp)))
2248         (wl-folder-jump-to-current-entity) ;; close it
2249         ))
2250     (wl-folder-move-path id)
2251     (recenter)))
2252
2253 (defun wl-folder-open-all-unread-folder (&optional arg)
2254   (interactive "P")
2255   (let ((id (progn
2256               (wl-folder-prev-entity-skip-invalid t)
2257               (wl-folder-get-entity-from-buffer t))))
2258     (wl-folder-open-unread-folder wl-folder-entity)
2259     (if (not arg)
2260         (wl-folder-move-path id)
2261       (goto-char (point-min))
2262       (wl-folder-next-unread t))))
2263
2264 (defun wl-folder-open-folder (&optional fld-name)
2265   (interactive)
2266   (if (not fld-name)
2267       (setq fld-name (wl-summary-read-folder wl-default-folder)))
2268   (let* ((id (wl-folder-get-entity-id
2269               (wl-folder-search-entity-by-name fld-name wl-folder-entity
2270                                                'folder)))
2271          (path (and id (wl-folder-get-path wl-folder-entity id))))
2272       (if path
2273           (wl-folder-open-folder-sub path))))
2274
2275 (defun wl-folder-open-folder-sub (path)
2276   (let ((inhibit-read-only t)
2277         (buffer-read-only nil)
2278         indent name entity
2279         err)
2280     (save-excursion
2281       (goto-char (point-min))
2282       (while (and path
2283                   (wl-folder-buffer-search-group
2284                    (wl-folder-get-petname
2285                     (if (stringp (car path))
2286                         (car path)
2287                       (wl-folder-get-folder-name-by-id
2288                        (car path))))))
2289         (beginning-of-line)
2290         (setq path (cdr path))
2291         (if (and (looking-at wl-folder-group-regexp)
2292                  (string= "+" (wl-match-buffer 2)));; closed group
2293             (save-excursion
2294               (setq indent (wl-match-buffer 1))
2295               (setq name (wl-folder-get-realname (wl-match-buffer 3)))
2296               (setq entity (wl-folder-search-group-entity-by-name
2297                             name
2298                             wl-folder-entity))
2299               ;; insert as opened
2300               (setcdr (assoc (car entity) wl-folder-group-alist) t)
2301               (if (eq 'access (cadr entity))
2302                   (wl-folder-maybe-load-folder-list entity))
2303               (wl-folder-insert-entity indent entity)
2304               (delete-region (save-excursion (beginning-of-line)
2305                                              (point))
2306                              (save-excursion (end-of-line)
2307                                              (+ 1 (point)))))))
2308       (set-buffer-modified-p nil))))
2309
2310 (defun wl-folder-open-all-pre ()
2311   (let ((entities (list wl-folder-entity))
2312         entity entity-stack group-entry)
2313     (while entities
2314       (setq entity (wl-pop entities))
2315       (cond
2316        ((consp entity)
2317         (unless (or (not (setq group-entry
2318                                (assoc (car entity) wl-folder-group-alist)))
2319                     (cdr group-entry))
2320           (setcdr group-entry t)
2321           (when (eq 'access (cadr entity))
2322             (wl-folder-maybe-load-folder-list entity)))
2323         (and entities
2324              (wl-push entities entity-stack))
2325         (setq entities (nth 2 entity))))
2326       (unless entities
2327         (setq entities (wl-pop entity-stack))))))
2328
2329 (defun wl-folder-open-all (&optional refresh)
2330   (interactive "P")
2331   (let* ((inhibit-read-only t)
2332          (buffer-read-only nil)
2333          (len (length wl-folder-group-alist))
2334          (i 0)
2335          indent name entity)
2336     (if refresh
2337         (let ((id (progn
2338                     (wl-folder-prev-entity-skip-invalid t)
2339                     (wl-folder-get-entity-from-buffer t))))
2340           (mapcar '(lambda (x)
2341                      (setcdr x t))
2342                   wl-folder-group-alist)
2343           (erase-buffer)
2344           (wl-folder-insert-entity " " wl-folder-entity)
2345           (wl-folder-move-path id))
2346       (message "Opening all folders...")
2347       (wl-folder-open-all-pre)
2348       (save-excursion
2349         (goto-char (point-min))
2350         (while (re-search-forward
2351                 "^\\([ ]*\\)\\[\\([+]\\)\\]\\(.+\\):[-0-9-]+/[0-9-]+/[0-9-]+\n"
2352                 nil t)
2353           (setq indent (wl-match-buffer 1))
2354           (setq name (wl-folder-get-realname (wl-match-buffer 3)))
2355           (setq entity (wl-folder-search-group-entity-by-name
2356                         name
2357                         wl-folder-entity))
2358           ;; insert as opened
2359           (setcdr (assoc (car entity) wl-folder-group-alist) t)
2360           (forward-line -1)
2361           (wl-folder-insert-entity indent entity)
2362           (delete-region (save-excursion (beginning-of-line)
2363                                          (point))
2364                          (save-excursion (end-of-line)
2365                                          (+ 1 (point))))
2366           (setq i (1+ i))
2367           (and (zerop (% i 10))
2368                (elmo-display-progress
2369                 'wl-folder-open-all "Opening all folders..."
2370                 (/ (* i 100) len))))))
2371     (elmo-display-progress
2372      'wl-folder-open-all "Opening all folders..." 100)
2373     (set-buffer-modified-p nil)))
2374
2375 (defun wl-folder-close-all ()
2376   (interactive)
2377   (let ((inhibit-read-only t)
2378         (buffer-read-only nil)
2379         (alist wl-folder-group-alist)
2380         (id (progn
2381               (wl-folder-prev-entity-skip-invalid t)
2382               (wl-folder-get-entity-from-buffer t))))
2383     (while alist
2384       (setcdr (car alist) nil)
2385       (setq alist (cdr alist)))
2386     (setcdr (assoc (car wl-folder-entity) wl-folder-group-alist) t)
2387     (erase-buffer)
2388     (wl-folder-insert-entity " " wl-folder-entity)
2389     (wl-folder-move-path id)
2390     (recenter)
2391     (set-buffer-modified-p nil)))
2392
2393 (defun wl-folder-open-close ()
2394   "open or close parent entity."
2395   (interactive)
2396   (save-excursion
2397     (beginning-of-line)
2398     (if (wl-folder-buffer-group-p)
2399         ;; if group (whether opend or closed.)
2400         (wl-folder-jump-to-current-entity)
2401       ;; if folder
2402       (let (indent)
2403         (setq indent (save-excursion
2404                        (re-search-forward "\\([ ]*\\)." nil t)
2405                        (wl-match-buffer 1)))
2406         (while (looking-at indent)
2407           (forward-line -1)))
2408       (wl-folder-jump-to-current-entity))))
2409
2410 (defsubst wl-folder-access-subscribe-p (group folder)
2411   (let (subscr regexp match)
2412     (if (setq subscr (wl-get-assoc-list-value
2413                       wl-folder-access-subscribe-alist
2414                       group))
2415         (progn
2416           (setq regexp (mapconcat 'identity (cdr subscr) "\\|"))
2417           (setq match (string-match regexp folder))
2418           (if (car subscr)
2419               match
2420             (not match)))
2421       t)))
2422
2423 (defun wl-folder-update-access-group (entity new-flist)
2424   (let* ((flist (nth 2 entity))
2425          (unsubscribes (nth 3 entity))
2426          (len (+ (length flist) (length unsubscribes)))
2427          (i 0)
2428          diff new-unsubscribes removes
2429          subscribed-list folder group entry)
2430     ;; check subscribed groups
2431     (while flist
2432       (cond
2433        ((listp (car flist))     ;; group
2434         (setq group (elmo-string (caar flist)))
2435         (cond
2436          ((assoc group new-flist)       ;; found in new-flist
2437           (setq new-flist (delete (assoc group new-flist)
2438                                   new-flist))
2439           (if (wl-folder-access-subscribe-p (car entity) group)
2440               (wl-append subscribed-list (list (car flist)))
2441             (wl-append new-unsubscribes (list (car flist)))
2442             (setq diff t)))
2443          (t
2444           (setq wl-folder-group-alist
2445                 (delete (wl-string-assoc group wl-folder-group-alist)
2446                         wl-folder-group-alist))
2447           (wl-append removes (list (list group))))))
2448        (t                       ;; folder
2449         (setq folder (elmo-string (car flist)))
2450         (cond
2451          ((member folder new-flist)     ;; found in new-flist
2452           (setq new-flist (delete folder new-flist))
2453           (if (wl-folder-access-subscribe-p (car entity) folder)
2454               (wl-append subscribed-list (list (car flist)))
2455             (wl-append new-unsubscribes (list folder))
2456             (setq diff t)))
2457          (t
2458           (wl-append removes (list folder))))))
2459       (setq i (1+ i))
2460       (and (zerop (% i 10))
2461            (elmo-display-progress
2462             'wl-folder-update-access-group "Updating access group..."
2463             (/ (* i 100) len)))
2464       (setq flist (cdr flist)))
2465     ;; check unsubscribed groups
2466     (while unsubscribes
2467       (cond
2468        ((listp (car unsubscribes))
2469         (when (setq entry (assoc (caar unsubscribes) new-flist))
2470           (setq new-flist (delete entry new-flist))
2471           (wl-append new-unsubscribes (list (car unsubscribes)))))
2472        (t
2473         (when (member (car unsubscribes) new-flist)
2474           (setq new-flist (delete (car unsubscribes) new-flist))
2475           (wl-append new-unsubscribes (list (car unsubscribes))))))
2476       (setq i (1+ i))
2477       (and (zerop (% i 10))
2478            (elmo-display-progress
2479             'wl-folder-update-access-group "Updating access group..."
2480             (/ (* i 100) len)))
2481       (setq unsubscribes (cdr unsubscribes)))
2482     (elmo-display-progress
2483      'wl-folder-update-access-group "Updating access group..."
2484      100)
2485     ;;
2486     (if (or new-flist removes)
2487         (setq diff t))
2488     (setq new-flist
2489           (mapcar '(lambda (x)
2490                      (cond ((consp x) (list (car x) 'access))
2491                            (t x)))
2492                   new-flist))
2493     ;; check new groups
2494     (let ((new-list new-flist))
2495       (while new-list
2496         (if (not (wl-folder-access-subscribe-p
2497                   (car entity)
2498                   (if (listp (car new-list))
2499                       (caar new-list)
2500                     (car new-list))))
2501             ;; auto unsubscribe
2502             (progn
2503               (wl-append new-unsubscribes (list (car new-list)))
2504               (setq new-flist (delete (car new-list) new-flist)))
2505           (cond
2506            ((listp (car new-list))
2507             ;; check group exists
2508             (if (wl-string-assoc (caar new-list) wl-folder-group-alist)
2509                 (progn
2510                   (message "%s: group already exists." (caar new-list))
2511                   (sit-for 1)
2512                   (wl-append new-unsubscribes (list (car new-list)))
2513                   (setq new-flist (delete (car new-list) new-flist)))
2514               (wl-append wl-folder-group-alist
2515                          (list (cons (caar new-list) nil)))))))
2516         (setq new-list (cdr new-list))))
2517     (if new-flist
2518         (message "%d new folder(s)." (length new-flist))
2519       (message "Updating access group...done"))
2520     (wl-append new-flist subscribed-list)       ;; new is first
2521     (run-hooks 'wl-folder-update-access-group-hook)
2522     (setcdr (cdr entity) (list new-flist new-unsubscribes))
2523     (list diff new-flist new-unsubscribes removes)))
2524
2525 (defun wl-folder-prefetch-entity (entity)
2526   "Prefetch all new messages in the ENTITY"
2527   (cond
2528    ((consp entity)
2529     (let ((flist (nth 2 entity))
2530           (sum-done 0)
2531           (sum-all 0)
2532           result)
2533       (while flist
2534         (setq result (wl-folder-prefetch-entity (car flist)))
2535         (setq sum-done (+ sum-done (car result)))
2536         (setq sum-all (+ sum-all (cdr result)))
2537         (setq flist (cdr flist)))
2538       (message "Prefetched %d/%d message(s) in \"%s\"."
2539                sum-done sum-all
2540                (wl-folder-get-petname (car entity)))
2541       (cons sum-done sum-all)))
2542    ((stringp entity)
2543     (let ((nums (wl-folder-get-entity-info entity))
2544           (wl-summary-highlight (if (or (wl-summary-sticky-p entity)
2545                                         (wl-summary-always-sticky-folder-p
2546                                          entity))
2547                                     wl-summary-highlight))
2548           wl-summary-exit-next-move
2549           wl-auto-select-first ret-val
2550           count)
2551       (setq count (or (car nums) 0))
2552       (setq count (+ count (wl-folder-count-incorporates entity)))
2553       (if (< 0 count)
2554           (save-window-excursion
2555             (save-excursion
2556               (wl-summary-goto-folder-subr entity
2557                                            (wl-summary-get-sync-range entity)
2558                                            nil)
2559               (setq ret-val (wl-summary-incorporate))
2560               (wl-summary-exit)
2561               ret-val))
2562         (cons 0 0))))))
2563
2564 (defun wl-folder-count-incorporates (folder)
2565   (let ((sum 0))
2566     (mapcar '(lambda (x)
2567                (if (member (cadr x)
2568                            wl-summary-incorporate-marks)
2569                    (incf sum)))
2570             (elmo-msgdb-mark-load (elmo-msgdb-expand-path folder)))
2571     sum))
2572
2573 (defun wl-folder-prefetch-current-entity (&optional no-check)
2574   "Prefetch all uncached messages in the folder at position.
2575 If current line is group folder, all subfolders are prefetched."
2576   (interactive "P")
2577   (save-excursion
2578     (let ((entity-name (wl-folder-get-entity-from-buffer))
2579           (group (wl-folder-buffer-group-p))
2580           wl-folder-check-entity-hook
2581           summary-buf entity)
2582       (when entity-name
2583         (setq entity
2584               (if group
2585                   (wl-folder-search-group-entity-by-name entity-name
2586                                                          wl-folder-entity)
2587                 entity-name))
2588         (if (not no-check)
2589             (wl-folder-check-entity entity))
2590         (wl-folder-prefetch-entity entity)))))
2591
2592 (defun wl-folder-drop-unsync-entity (entity)
2593   "Drop all unsync messages in the ENTITY"
2594   (cond
2595    ((consp entity)
2596     (let ((flist (nth 2 entity)))
2597       (while flist
2598         (wl-folder-drop-unsync-entity (car flist))
2599         (setq flist (cdr flist)))))
2600    ((stringp entity)
2601     (let ((nums (wl-folder-get-entity-info entity))
2602           wl-summary-highlight wl-auto-select-first new)
2603       (setq new (or (car nums) 0))
2604       (if (< 0 new)
2605           (save-window-excursion
2606             (save-excursion
2607               (wl-summary-goto-folder-subr entity 'no-sync nil)
2608               (wl-summary-drop-unsync)
2609               (wl-summary-exit))))))))
2610
2611 (defun wl-folder-drop-unsync-current-entity (&optional force-check)
2612   "Drop all unsync messages in the folder at position.
2613 If current line is group folder, all subfolders are dropped.
2614 If optional arg exists, don't check any folders."
2615   (interactive "P")
2616   (save-excursion
2617     (let ((entity-name (wl-folder-get-entity-from-buffer))
2618           (group (wl-folder-buffer-group-p))
2619           wl-folder-check-entity-hook
2620           summary-buf entity)
2621       (when (and entity-name
2622                  (y-or-n-p (format
2623                             "Drop all unsync messages in %s?" entity-name)))
2624         (setq entity
2625               (if group
2626                   (wl-folder-search-group-entity-by-name entity-name
2627                                                          wl-folder-entity)
2628                 entity-name))
2629         (if (null force-check)
2630             (wl-folder-check-entity entity))
2631         (wl-folder-drop-unsync-entity entity)
2632         (message "All unsync messages in %s are dropped!" entity-name)))))
2633
2634 (defun wl-folder-write-current-newsgroup ()
2635   (interactive)
2636   (wl-summary-write-current-newsgroup (wl-folder-entity-name)))
2637
2638 (defun wl-folder-mimic-kill-buffer ()
2639   "Kill the current (Folder) buffer with query."
2640   (interactive)
2641   (let ((bufname (read-buffer (format "Kill buffer: (default %s) "
2642                                       (buffer-name))))
2643         wl-interactive-exit)
2644     (if (or (not bufname)
2645             (string-equal bufname "")
2646             (string-equal bufname (buffer-name)))
2647         (wl-exit)
2648       (kill-buffer bufname))))
2649
2650 (defun wl-folder-confirm-existence (fld &optional ignore-error)
2651   (if (or (wl-folder-entity-exists-p fld)
2652           (file-exists-p (elmo-msgdb-expand-path fld)))
2653       ()
2654     (if ignore-error
2655         (condition-case nil
2656             (if (elmo-folder-exists-p fld)
2657                 ()
2658               (if (elmo-folder-creatable-p fld)
2659                   (if (y-or-n-p
2660                        (format "Folder %s does not exist, create it?" fld))
2661                       (progn
2662                         (setq wl-folder-entity-hashtb
2663                               (wl-folder-create-entity-hashtb
2664                                fld
2665                                wl-folder-entity-hashtb))
2666                         (elmo-create-folder fld)))))
2667           (error))
2668       (if (elmo-folder-exists-p fld)
2669           ()
2670         (if (not (elmo-folder-creatable-p fld))
2671             (error "Folder %s is not found" fld)
2672           (if (y-or-n-p
2673                (format "Folder %s does not exist, create it?" fld))
2674               (progn
2675                 (setq wl-folder-entity-hashtb
2676                       (wl-folder-create-entity-hashtb
2677                        fld
2678                        wl-folder-entity-hashtb))
2679                 (unless (elmo-create-folder fld)
2680                   (error "Create folder failed")))
2681             (error "Folder is not created")))))))
2682
2683 (provide 'wl-folder)
2684
2685 ;;; wl-folder.el ends here