wl/wl-folder.el

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