wl/wl-folder.el

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