wl/wl-folder.el

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