wl/wl-fldmgr.el

   1 ;;; wl-fldmgr.el -- Folder manager for Wanderlust.
   2
   3 ;; Copyright 1998,1999,2000 Masahiro MURATA <muse@ba2.so-net.ne.jp>
   4 ;;                          Yuuichi Teranishi <teranisi@gohome.org>
   5
   6 ;; Author: Masahiro MURATA <muse@ba2.so-net.ne.jp>
   7 ;; Keywords: mail, net news
   8 ;; Time-stamp: <00/03/14 19:34:28 teranisi>
   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 'wl-folder)
  35 (require 'wl-summary)
  36 (require 'wl-highlight)
  37 (eval-when-compile
  38   (require 'wl-util))
  39
  40 ;;; Global Variable
  41
  42 (defvar wl-fldmgr-modified nil)
  43 (defvar wl-fldmgr-modified-access-list nil)
  44 (defvar wl-fldmgr-cut-entity-list nil)
  45 (defvar wl-fldmgr-entity-list nil)
  46 (defvar wl-fldmgr-group-insert-opened nil)
  47
  48 (defconst wl-fldmgr-folders-header
  49   "#
  50 # Folder definition file
  51 # This file is generated automatically by %s %s (%s).
  52 #
  53
  54 ")
  55
  56 (defconst wl-fldmgr-filter-completion-alist
  57   '(("/last:")
  58     ("/first:")
  59     ("/since:")
  60     ("/before:")
  61     ("/from=")
  62     ("/subject=")
  63     ("/date=")
  64     ("/to=")
  65     ("/cc=")
  66     ("/tocc=")
  67     ("/body=")))
  68
  69 ;;; Initial setup
  70
  71 (defvar wl-fldmgr-mode-map nil)
  72 (if wl-fldmgr-mode-map
  73     nil
  74   (define-prefix-command 'wl-fldmgr-mode-map)
  75   (define-key wl-fldmgr-mode-map "\C-s"   'wl-fldmgr-save-folders)
  76   (define-key wl-fldmgr-mode-map "m"      'wl-fldmgr-make-multi)
  77   (define-key wl-fldmgr-mode-map "g"      'wl-fldmgr-make-group)
  78   (define-key wl-fldmgr-mode-map "A"      'wl-fldmgr-make-access-group)
  79   (define-key wl-fldmgr-mode-map "f"      'wl-fldmgr-make-filter)
  80   (define-key wl-fldmgr-mode-map "p"      'wl-fldmgr-set-petname)
  81   (define-key wl-fldmgr-mode-map "a"      'wl-fldmgr-add)
  82   (define-key wl-fldmgr-mode-map "d"      'wl-fldmgr-delete)
  83   (define-key wl-fldmgr-mode-map "R"      'wl-fldmgr-rename)
  84   (define-key wl-fldmgr-mode-map "c"      'wl-fldmgr-copy)
  85   (define-key wl-fldmgr-mode-map "k"      'wl-fldmgr-cut)
  86   (define-key wl-fldmgr-mode-map "W"      'wl-fldmgr-copy-region)
  87   (define-key wl-fldmgr-mode-map "\C-w"   'wl-fldmgr-cut-region)
  88   (define-key wl-fldmgr-mode-map "y"      'wl-fldmgr-yank)
  89   (define-key wl-fldmgr-mode-map "s"      'wl-fldmgr-sort)
  90   (define-key wl-fldmgr-mode-map "l"      'wl-fldmgr-access-display-normal)
  91   (define-key wl-fldmgr-mode-map "L"      'wl-fldmgr-access-display-all)
  92   (define-key wl-fldmgr-mode-map "q"      'wl-fldmgr-clear-cut-entity-list)
  93   (define-key wl-fldmgr-mode-map "r"      'wl-fldmgr-reconst-entity-hashtb)
  94   (define-key wl-fldmgr-mode-map "u"      'wl-fldmgr-unsubscribe)
  95   (define-key wl-fldmgr-mode-map "U"      'wl-fldmgr-unsubscribe-region))
  96
  97 (add-hook 'wl-folder-mode-hook 'wl-fldmgr-init)
  98
  99 (defun wl-fldmgr-init ()
 100   (setq wl-fldmgr-cut-entity-list nil)
 101   (setq wl-fldmgr-modified nil)
 102   (setq wl-fldmgr-modified-access-list nil))
 103
 104 (defun wl-fldmgr-exit ()
 105   (when (and wl-fldmgr-modified
 106              (or (not wl-interactive-save-folders)
 107                  (y-or-n-p "Folder view was modified. Save current folders? ")))
 108     (wl-fldmgr-save-folders)))
 109
 110 ;;; Macro and misc Function
 111 ;;
 112
 113 (defmacro wl-fldmgr-delete-line ()
 114   (` (delete-region (save-excursion (beginning-of-line)
 115                                     (point))
 116                     (save-excursion (end-of-line)
 117                                     (+ 1 (point))))))
 118
 119 (defmacro wl-fldmgr-make-indent (level)
 120   (` (concat " " (make-string (* 2 (, level)) ? ))))
 121
 122 (defmacro wl-fldmgr-get-entity-id (&optional entity)
 123   (` (get-text-property (if (, entity)
 124                             0
 125                           (point))
 126                         'wl-folder-entity-id
 127                         (, entity))))
 128
 129 (defmacro wl-fldmgr-assign-id (entity &optional id)
 130   (` (let ((entity-id (or (, id) wl-folder-entity-id)))
 131        (put-text-property 0 (length (, entity))
 132                           'wl-folder-entity-id
 133                           entity-id
 134                           (, entity)))))
 135
 136 (defsubst wl-fldmgr-read-string (str)
 137   (if (string-match "\n" str)
 138       (error "Not supported name: %s" str)
 139     (elmo-string str)))
 140
 141 (defsubst wl-fldmgr-add-modified-access-list (group)
 142   (if (not (member group wl-fldmgr-modified-access-list))
 143       (wl-append wl-fldmgr-modified-access-list (list group))))
 144
 145 (defsubst wl-fldmgr-delete-modified-access-list (group)
 146   (if (member group wl-fldmgr-modified-access-list)
 147       (setq wl-fldmgr-modified-access-list
 148             (delete group wl-fldmgr-modified-access-list))))
 149
 150 (defsubst wl-fldmgr-add-group (group)
 151   (or (assoc group wl-folder-group-alist)
 152       (wl-append wl-folder-group-alist
 153                  (list (cons group
 154                              wl-fldmgr-group-insert-opened)))))
 155
 156 (defsubst wl-fldmgr-delete-group (group)
 157   (wl-fldmgr-delete-modified-access-list group)
 158   (setq wl-folder-group-alist
 159         (delete (assoc group wl-folder-group-alist)
 160                 wl-folder-group-alist)))
 161
 162 (defun wl-fldmgr-add-entity-hashtb (entities)
 163   "update `wl-folder-entity-hashtb', `wl-folder-newsgroups-hashtb'.
 164 return value is diffs '(new unread all)."
 165   (let* ((new-diff 0)
 166          (unread-diff 0)
 167          (all-diff 0)
 168          val entity entity-stack)
 169     (setq wl-folder-newsgroups-hashtb
 170           (or (wl-folder-create-newsgroups-hashtb entities t)
 171               wl-folder-newsgroups-hashtb))
 172     (while entities
 173       (setq entity (wl-pop entities))
 174       (cond
 175        ((consp entity)
 176         (wl-fldmgr-add-group (car entity))
 177         (and entities
 178              (wl-push entities entity-stack))
 179         (setq entities (nth 2 entity)))
 180        ((stringp entity)
 181         (if (not (setq val (wl-folder-get-entity-info entity)))
 182             (wl-folder-set-entity-info entity nil)
 183           (setq new-diff    (+ new-diff    (or (nth 0 val) 0)))
 184           (setq unread-diff (+ unread-diff (or (nth 1 val) 0)))
 185           (setq all-diff    (+ all-diff    (or (nth 2 val) 0))))))
 186       (unless entities
 187         (setq entities (wl-pop entity-stack))))
 188     (setq unread-diff (+ unread-diff new-diff))
 189     (list new-diff unread-diff all-diff)))
 190
 191 (defun wl-fldmgr-delete-entity-hashtb (entities &optional clear)
 192   "update `wl-folder-entity-hashtb'.
 193 return value is diffs '(-new -unread -all)."
 194   (let* ((new-diff 0)
 195          (unread-diff 0)
 196          (all-diff 0)
 197          entity val
 198          entity-stack)
 199     (while entities
 200       (setq entity (wl-pop entities))
 201       (cond
 202        ((consp entity)
 203         (wl-fldmgr-delete-group (car entity))
 204         (and entities
 205              (wl-push entities entity-stack))
 206         (setq entities (nth 2 entity)))
 207        ((stringp entity)
 208         (when (setq val (wl-folder-get-entity-info entity))
 209           (setq new-diff    (+ new-diff    (or (nth 0 val) 0)))
 210           (setq unread-diff (+ unread-diff (or (nth 1 val) 0)))
 211           (setq all-diff    (+ all-diff    (or (nth 2 val) 0)))
 212           (and clear (wl-folder-clear-entity-info entity)))))
 213       (unless entities
 214         (setq entities (wl-pop entity-stack))))
 215     (setq unread-diff (+ unread-diff new-diff))
 216     (list (- 0 new-diff) (- 0 unread-diff) (- 0 all-diff))))
 217
 218 ;; return value
 219 ;; example: '(("Desktop" group) ("+ml" access) "+ml/wl")
 220
 221 (defun wl-fldmgr-get-path (entity target-entity &optional group-target)
 222   (let* ((target-id (wl-fldmgr-get-entity-id target-entity))
 223          (entities (list entity))
 224          entity-stack result-path)
 225     (reverse
 226      (catch 'done
 227        (while entities
 228          (setq entity (wl-pop entities))
 229          (cond
 230           ((consp entity)
 231            (if (and (string= target-entity (car entity))
 232                     (eq target-id (wl-fldmgr-get-entity-id (car entity))))
 233                (throw 'done
 234                       (wl-push (if group-target
 235                                    (car entity)
 236                                  (list (car entity) (nth 1 entity)))
 237                                result-path))
 238              (wl-push (list (car entity) (nth 1 entity))
 239                       result-path))
 240            (wl-push entities entity-stack)
 241            (setq entities (nth 2 entity)))
 242           ((stringp entity)
 243            (if (and (string= target-entity entity)
 244                     (eq target-id (wl-fldmgr-get-entity-id entity)))
 245                (throw 'done
 246                       (wl-push entity result-path)))))
 247          (unless entities
 248            (while (and entity-stack
 249                        (not entities))
 250              (setq result-path (cdr result-path))
 251              (setq entities (wl-pop entity-stack)))))))))
 252
 253 ;; (defun wl-fldmgr-get-previous-entity (entity key-id)
 254 ;;   (cdr (wl-fldmgr-get-previous-entity-internal '(nil . nil) entity key-id)))
 255 ;;
 256 ;; (defun wl-fldmgr-get-previous-entity-internal (result entity key-id)
 257 ;;   (cond
 258 ;;    ((stringp entity)
 259 ;;     (if (eq key-id (wl-fldmgr-get-entity-id entity))
 260 ;;      (cons t result)
 261 ;;       (cons nil (cons entity entity))))
 262 ;;    ((consp entity)
 263 ;;     (if (eq key-id (wl-fldmgr-get-entity-id (car entity)))
 264 ;;      (cons t result)
 265 ;;       (setcar result (car entity))
 266 ;;       (let ((flist (nth 2 entity))
 267 ;;          return found)
 268 ;;      (while (and flist (not found))
 269 ;;        (if (car (setq return
 270 ;;                       (wl-fldmgr-get-previous-entity-internal
 271 ;;                        result (car flist) key-id)))
 272 ;;            (setq found t))
 273 ;;        (setq result (cdr return))
 274 ;;        (setq flist (cdr flist)))
 275 ;;      (cons found result))))))
 276
 277 ;; path is get `wl-fldmgr-get-path-from-buffer'.
 278 (defun wl-fldmgr-update-group (path diffs)
 279   (save-excursion
 280     (while (and path (consp (car path)))
 281       (if (string= (caar path) wl-folder-desktop-name) ; update desktop
 282           (progn
 283             (goto-char (point-min))
 284             (wl-folder-update-diff-line diffs))
 285         ;; goto the path line.
 286         (goto-char (point-min))
 287         (if (wl-folder-buffer-search-group
 288              (wl-folder-get-petname (caar path)))
 289             (wl-folder-update-diff-line diffs)))
 290       (setq path (cdr path)))))
 291
 292 ;;; Function for wl-folder-entity
 293 ;;
 294
 295 ;; usage:
 296 ;; (wl-delete-entity '(("Desktop") ("ML") "+ml/wl") '("+ml/wl") wl-folder-entity)
 297 ;; (wl-delete-entity '(("Desktop") "ML") '("+inbox" "ML") wl-folder-entity)
 298 ;; (wl-delete-entity '(("Desktop") "ML") nil wl-folder-entity)
 299
 300 (defun wl-delete-entity (key-path delete-list entity &optional clear)
 301   (let (wl-fldmgr-entity-list)
 302     (when (and (string= (caar key-path) (car entity))
 303                (wl-delete-entity-sub (cdr key-path) delete-list entity clear))
 304       ;; return value is non-nil (diffs)
 305       (wl-fldmgr-delete-entity-hashtb wl-fldmgr-entity-list clear))))
 306
 307 (defun wl-delete-entity-sub (key-path delete-list entity clear)
 308   (let ((flist (nth 2 entity))
 309         (key (car key-path))
 310         next)
 311     (cond
 312      ((consp key);; into group
 313       (if (setq next (assoc (car key) flist))
 314           (wl-delete-entity-sub (cdr key-path)
 315                                 delete-list
 316                                 next
 317                                 clear)
 318         ;; not found
 319         nil))
 320      ((stringp key) ;; delete entities
 321       (if (not delete-list)
 322           (setq delete-list (list key)))
 323       (let* ((group (car entity))
 324              (access (eq (nth 1 entity) 'access))
 325              (unsubscribes (and access (nth 3 entity)))
 326              (update t)
 327              cut-entity is-group)
 328         (catch 'done
 329           (while delete-list
 330             (setq key (car delete-list))
 331             (cond ((member key flist);; entity
 332                    (setq flist (delete key flist))
 333                    (unless clear
 334                      (wl-push key wl-fldmgr-cut-entity-list))
 335                    (wl-append wl-fldmgr-entity-list (list key))
 336                    (setq is-group nil))
 337                   ((setq cut-entity (assoc key flist));; group
 338                    (setq flist (delete cut-entity flist))
 339                    (unless clear
 340                      (wl-push cut-entity wl-fldmgr-cut-entity-list))
 341                    (wl-append wl-fldmgr-entity-list (list cut-entity))
 342                    (setq is-group t))
 343                   (t
 344                    ;; not found
 345                    (message "%s not found" key)
 346                    (setq update nil)
 347                    (throw 'done t)))
 348             (when access
 349               (if is-group
 350                   (wl-append unsubscribes
 351                              (list (list (elmo-string key) 'access nil)))
 352                 (wl-append unsubscribes (list (elmo-string key)))))
 353             (setq delete-list (cdr delete-list))))
 354         (when update
 355           (setcdr (cdr entity) (list flist unsubscribes))
 356           (when access
 357             (wl-fldmgr-add-modified-access-list group))
 358           t
 359           ))))))
 360
 361 ;; usage:
 362 ;; (wl-add-entity '(("Desktop") ("ML") "ml/wl") '("+ml/new") wl-folder-entity 12)
 363 ;; (wl-add-entity '(("Desktop") "ML") '("+ml/new")  wl-folder-entity 10)
 364
 365 (defun wl-add-entity (key-path new entity prev-entity-id &optional errmes)
 366   (when (string= (caar key-path) (car entity))
 367     (mapcar
 368      '(lambda (ent)
 369         (wl-folder-entity-assign-id
 370          ent
 371          wl-folder-entity-id-name-hashtb
 372          t))
 373      new)
 374     (when (wl-add-entity-sub (cdr key-path) new entity errmes)
 375       ;; return value is non-nil (diffs)
 376       (wl-fldmgr-add-entity-hashtb new))))
 377
 378 (defun wl-add-entity-sub (key-path new entity &optional errmes)
 379   (let ((flist (nth 2 entity))
 380         entry)
 381     (catch 'success
 382       (cond
 383        ((consp (car key-path));; into group
 384         (if (setq entry (assoc (caar key-path) flist))
 385             (if (not (wl-add-entity-sub (cdr key-path)
 386                                         new
 387                                         entry
 388                                         errmes))
 389                 (throw 'success nil))
 390           (and errmes (message "%s not found" (caar key-path)))
 391           (throw 'success nil)))
 392        (t;; insert entities
 393         (let* ((new2 new)
 394                (group (car entity))
 395                (access (eq (nth 1 entity) 'access))
 396                (unsubscribes (and access (nth 3 entity))))
 397           ;; check
 398           (while new2
 399             (cond
 400              ((stringp (car new2)) ;; folder
 401               (cond
 402                ((wl-string-member (car new2) flist)
 403                 (and errmes (message "%s: already exists" (car new2)))
 404                 (throw 'success nil))
 405                ((and access
 406                      (not (wl-string-member (car new2) unsubscribes)))
 407                 (and errmes (message "%s: not access group folder" (car new2)))
 408                 (throw 'success nil))))
 409              (t                    ;; group
 410               (when (and access
 411                          (not (wl-string-assoc (caar new2) unsubscribes)))
 412                 (and errmes (message "%s: can't insert access group"
 413                                      (caar new2)))
 414                 (throw 'success nil))))
 415             (setq new2 (cdr new2)))
 416           ;; do it
 417           (when access
 418             ;; remove from unsubscribe
 419             (mapcar
 420              '(lambda (x)
 421                 (cond
 422                  ((consp x)
 423                   (setq unsubscribes
 424                         (delete (wl-string-assoc (car x) unsubscribes)
 425                                 unsubscribes)))
 426                  (t
 427                   (setq unsubscribes (delete (elmo-string x) unsubscribes)))))
 428              new)
 429 ;;          (setq new2 new)
 430 ;;          (while new2
 431 ;;            (setq unsubscribes (delete (elmo-string (car new2)) unsubscribes))
 432 ;;            (setq new2 (cdr new2)))
 433             (setcdr (cddr entity) (list unsubscribes))
 434             (wl-fldmgr-add-modified-access-list group))
 435           (if (not key-path);; insert group top
 436               (if (cddr entity)
 437                   (setcar (cddr entity) (append new flist))
 438                 (setcdr (cdr entity) (list new)))
 439             (let (akey)
 440               (if (catch 'done
 441                     (while flist
 442                       (setq akey (car flist))
 443                       (cond ((consp akey);; group
 444                              (if (equal (car key-path) (car akey))
 445                                  (throw 'done t)))
 446                             (t
 447                              (if (equal (car key-path) akey)
 448                                  (throw 'done t))))
 449                       (setq flist (cdr flist))))
 450                   (setcdr flist (append new (cdr flist)))
 451                 (and errmes (message "%s not found" (car key-path)))
 452                 (throw 'success nil)))))))
 453       (throw 'success t))))
 454
 455 ;; return value is
 456 ;; (path indent-level (group . type) previous-entity-id target-entity)
 457 ;; previous-entity-id is (id-name-alist-prev-id . entity-alist-prev-id)
 458 ;; example:
 459 ;; '((("Desktop" group) ("ML" group) "+ml/wl") '(3 2) ("ML" . group) nil "+ml/wl")
 460
 461 (defun wl-fldmgr-get-path-from-buffer (&optional prev)
 462   (let ((indent-level 0)
 463         (group-target t)
 464         folder-path group-type previous-entity entity)
 465     (save-excursion
 466       (beginning-of-line)
 467       (when prev
 468 ;;      (wl-folder-next-entity-skip-invalid t)
 469 ;;      (and (setq previous-entity
 470 ;;                 (wl-fldmgr-get-previous-entity wl-folder-entity
 471 ;;                                                (wl-fldmgr-get-entity-id)))
 472 ;;           ;; change entity to id
 473 ;;           (setq previous-entity
 474 ;;                 (cons
 475 ;;                  (and (car previous-entity)
 476 ;;                       (wl-fldmgr-get-entity-id (car previous-entity)))
 477 ;;                  (and (cdr previous-entity)
 478 ;;                       (wl-fldmgr-get-entity-id (cdr previous-entity))))))
 479         (wl-folder-prev-entity-skip-invalid))
 480       (if (and prev
 481                (looking-at wl-folder-group-regexp)
 482                (string= (wl-match-buffer 2) "-"))
 483           (setq group-target nil)
 484         (if (and prev (bobp))
 485             (error "out of desktop group")))
 486       (setq folder-path (wl-fldmgr-get-path wl-folder-entity
 487                                             (wl-folder-get-entity-from-buffer)
 488                                             ;;(wl-fldmgr-get-entity-id)
 489                                             group-target))
 490       (let ((fp folder-path))
 491         (while fp
 492           (if (consp (car fp))
 493               (progn
 494                 (setq indent-level (1+ indent-level))
 495                 (setq group-type (cons (caar fp) (nth 1 (car fp)))))
 496             (setq entity (car fp)))
 497           (setq fp (cdr fp))))
 498       (list folder-path indent-level group-type previous-entity entity))))
 499
 500 ;;; Command
 501 ;;
 502
 503 (defun wl-fldmgr-clear-cut-entity-list ()
 504   (interactive)
 505   (setq wl-fldmgr-cut-entity-list nil)
 506   (message "Cleared cut entity list"))
 507
 508 (defun wl-fldmgr-reconst-entity-hashtb (&optional arg nomes)
 509   (interactive "P")
 510   (or nomes (message "Reconstructing entity alist..."))
 511   (when (not arg)
 512     (setq wl-folder-entity-id 0)
 513     (wl-folder-entity-assign-id wl-folder-entity))
 514   (setq wl-folder-entity-hashtb
 515         (wl-folder-create-entity-hashtb
 516          wl-folder-entity
 517          wl-folder-entity-hashtb
 518          t))
 519   ;; reset property on buffer
 520   (when (not arg)
 521     (let ((inhibit-read-only t)
 522           (cur-point (point)))
 523       (erase-buffer)
 524       (wl-folder-insert-entity " " wl-folder-entity)
 525       (goto-char cur-point)
 526       (set-buffer-modified-p nil)))
 527   (or nomes (message "Reconstructing entity alist...done")))
 528
 529
 530 (defun wl-fldmgr-cut-region ()
 531   (interactive)
 532   (let* ((p1 (region-beginning))
 533          (p2 (region-end))
 534          (r1 (progn
 535                (goto-char p1)
 536                (beginning-of-line)
 537                (point)))
 538          (r2 (progn
 539                (goto-char p2)
 540                (beginning-of-line)
 541                (point)))
 542          (from (min r1 r2))
 543          (to (max r1 r2))
 544          (count 0)
 545          (errmes nil)
 546          (cut-list nil)
 547          name pre-indent indent)
 548     (catch 'err
 549       (save-excursion
 550         (goto-char from)
 551         (and (looking-at "^\\([ ]*\\)")
 552              (setq pre-indent (wl-match-buffer 1)))
 553         (while (< (point) to)
 554           (and (looking-at "^\\([ ]*\\)")
 555                (setq indent (wl-match-buffer 1)))
 556           (cond ((= (length pre-indent) (length indent))
 557                  (setq pre-indent indent)
 558                  (setq count (1+ count))
 559                  (and (setq name (wl-folder-get-entity-from-buffer))
 560                       (wl-append cut-list (list name)))
 561                  (forward-line 1))
 562                 ((< (length pre-indent) (length indent))
 563                  (wl-folder-goto-bottom-of-current-folder pre-indent)
 564                  (beginning-of-line))
 565                 (t
 566                  (setq errmes "bad region")
 567                  (throw 'err t))))
 568         (unless (eq (point) to)
 569           (setq errmes "bad region")
 570           (throw 'err t)))
 571       (save-excursion
 572         (let ((count2 (length cut-list))
 573               tmp path ent diffs)
 574           (goto-char from)
 575           (save-excursion
 576             (wl-folder-next-entity-skip-invalid t)
 577             (setq tmp (wl-fldmgr-get-path-from-buffer)))
 578           (setq path (car tmp))
 579           (setq diffs
 580                 (wl-delete-entity path cut-list wl-folder-entity))
 581           (catch 'done
 582             (while (> count 0)
 583               (setq ent (looking-at wl-folder-entity-regexp))
 584               (if (not (wl-fldmgr-cut (and ent tmp)
 585                                       (and ent (pop cut-list))))
 586                   (throw 'done nil))
 587               (setq count (1- count))))
 588           (if (> count2 0)
 589               (wl-push count2 wl-fldmgr-cut-entity-list))
 590           (if diffs
 591               (wl-fldmgr-update-group path diffs))
 592           t))
 593       (throw 'err nil))
 594     (if errmes
 595         (message "%s" errmes))))
 596
 597 (defun wl-fldmgr-cut (&optional tmp entity clear)
 598   (interactive)
 599   (save-excursion
 600     (beginning-of-line)
 601     (let ((ret-val nil)
 602           (inhibit-read-only t)
 603           path diffs)
 604       (if (bobp)
 605           (message "Can't remove desktop group")
 606         (or tmp (setq tmp (wl-fldmgr-get-path-from-buffer)))
 607         (setq path (car tmp))
 608         (if (not path)
 609             (if (not (eobp))
 610                 (wl-fldmgr-delete-line))   ;; unsubscribe or removed folder
 611           (if (not entity)
 612               (setq diffs
 613                     (wl-delete-entity path nil wl-folder-entity clear)))
 614           (setq wl-fldmgr-modified t)
 615           ;;
 616           (if (looking-at wl-folder-group-regexp)
 617               ;; group
 618               (let (beg end indent opened)
 619                 (setq indent (wl-match-buffer 1))
 620                 (setq opened (wl-match-buffer 2))
 621                 (if (string= opened "+")
 622                     (wl-fldmgr-delete-line)
 623                   (setq beg (point))
 624                   (end-of-line)
 625                   (save-match-data
 626                     (setq end
 627                           (progn
 628                             (wl-folder-goto-bottom-of-current-folder indent)
 629                             (beginning-of-line)
 630                             (point))))
 631                   (delete-region beg end)))
 632             ;; entity
 633             (wl-fldmgr-delete-line))
 634           (if diffs
 635               (wl-fldmgr-update-group path diffs))
 636           (set-buffer-modified-p nil))
 637         (setq ret-val t))
 638       ret-val)))
 639
 640 (defun wl-fldmgr-copy-region ()
 641   (interactive)
 642   (let* ((p1 (region-beginning))
 643          (p2 (region-end))
 644          (r1 (progn
 645                (goto-char p1)
 646                (beginning-of-line)
 647                (point)))
 648          (r2 (progn
 649                (goto-char p2)
 650                (beginning-of-line)
 651                (point)))
 652          (from (min r1 r2))
 653          (to (max r1 r2))
 654          (errmes nil)
 655          (cut-list nil)
 656          (count 0)
 657          name
 658          pre-indent indent)
 659     (catch 'err
 660       (save-excursion
 661         (goto-char from)
 662         (when (bobp)
 663           (setq errmes "can't copy desktop group")
 664           (throw 'err t))
 665         (and (looking-at "^\\([ ]*\\)")
 666              (setq pre-indent (wl-match-buffer 1)))
 667         (while (< (point) to)
 668           (and (looking-at "^\\([ ]*\\)")
 669                (setq indent (wl-match-buffer 1)))
 670           (if (looking-at wl-folder-group-regexp)
 671               (progn
 672                 (setq errmes "can't copy group folder")
 673                 (throw 'err t)))
 674           (cond ((= (length pre-indent) (length indent))
 675                  (if (setq name (wl-folder-get-entity-from-buffer))
 676                      (progn
 677                        (setq pre-indent indent)
 678                        (wl-push name cut-list)))
 679                  (forward-line 1))
 680                 ((< (length pre-indent) (length indent))
 681                  (wl-folder-goto-bottom-of-current-folder pre-indent)
 682                  (beginning-of-line))
 683                 (t
 684                  (setq errmes "bad region")
 685                  (throw 'err t))))
 686         (unless (eq (point) to)
 687           (setq errmes "bad region")
 688           (throw 'err t)))
 689       (catch 'done
 690         (setq cut-list (reverse cut-list))
 691         (while cut-list
 692           (setq name (pop cut-list))
 693           (unless (wl-fldmgr-copy name)
 694             (throw 'done nil))
 695           (setq count (1+ count)))
 696         (wl-push count wl-fldmgr-cut-entity-list)
 697         (message "Copy %s folders" count)
 698         (throw 'err nil)))
 699     (if errmes
 700         (message "%s" errmes))))
 701
 702 (defun wl-fldmgr-copy (&optional ename)
 703   (interactive "P")
 704   (save-excursion
 705     (beginning-of-line)
 706     (let ((ret-val nil))
 707       (if (and (not ename)
 708                (looking-at wl-folder-group-regexp))
 709           (message "Can't copy group folder")
 710         (let* ((name (or ename (wl-folder-get-entity-from-buffer)))
 711                (entity (elmo-string name)))
 712           (when name
 713             (if (member entity wl-fldmgr-cut-entity-list)
 714                 (setq wl-fldmgr-cut-entity-list
 715                       (delete entity wl-fldmgr-cut-entity-list)))
 716             (wl-push entity wl-fldmgr-cut-entity-list)
 717             (or ename
 718                 (message "Copy: %s" name))
 719             (setq ret-val t))))
 720       ret-val)))
 721
 722 (defun wl-fldmgr-yank ()
 723   (interactive)
 724   (save-excursion
 725     (beginning-of-line)
 726     (if (bobp)
 727         (message "Can't insert in the out of desktop group")
 728       (let ((inhibit-read-only t)
 729             (top (car wl-fldmgr-cut-entity-list))
 730             tmp indent path count new
 731             access new-list diffs)
 732         (if (not top)
 733             (message "No cut buffer")
 734           (setq tmp (wl-fldmgr-get-path-from-buffer t))
 735           (setq path (car tmp))
 736           (setq indent (wl-fldmgr-make-indent (nth 1 tmp)))
 737           (if (numberp top)
 738               (setq count (pop wl-fldmgr-cut-entity-list))
 739             (setq count 1))
 740           (if (catch 'err
 741                 (let ((count count)
 742                       (cut-list wl-fldmgr-cut-entity-list))
 743                   ;; check insert entity
 744                   (while (> count 0)
 745                     (setq new (car cut-list))
 746                     (wl-push new new-list)
 747                     (when (consp new);; group
 748                       (cond
 749                        (access
 750                         (message "Can't insert group in access")
 751                         (throw 'err t))
 752                        ((wl-string-assoc (car new) wl-folder-group-alist)
 753                         (message "%s: group already exists" (car new))
 754                         (throw 'err t))))
 755                     (setq cut-list (cdr cut-list))
 756                     (setq count (1- count))))
 757                 (if (not (setq diffs
 758                                (wl-add-entity
 759                                 path new-list wl-folder-entity (nth 3 tmp) t)))
 760                     (throw 'err t))
 761                 (while (> count 0)
 762                   (setq new (pop wl-fldmgr-cut-entity-list))
 763                   (save-excursion
 764                     (wl-folder-insert-entity indent new)
 765                     (setq wl-fldmgr-modified t))
 766                   (setq count (1- count)))
 767                 (wl-fldmgr-update-group path diffs)
 768                 (set-buffer-modified-p nil))
 769               ;; error
 770               (wl-push count wl-fldmgr-cut-entity-list)))))))
 771
 772 (defvar wl-fldmgr-add-completion-hashtb (make-vector 7 0))
 773
 774 (defun wl-fldmgr-add-completion-all-completions (string)
 775   (let ((table
 776          (catch 'found
 777            (mapatoms
 778             (function
 779              (lambda (atom)
 780                (if (string-match (symbol-name atom) string)
 781                    (throw 'found (symbol-value atom)))))
 782             wl-fldmgr-add-completion-hashtb)))
 783         (pattern
 784          (if (string-match "\\.$"
 785                            (car (elmo-network-get-spec
 786                                  string nil nil nil)))
 787              (substring string 0 (match-beginning 0))
 788            (concat string nil))))
 789     (or table
 790         (setq table (elmo-list-folders pattern))
 791         (and table
 792              (or (/= (length table) 1)
 793                  (elmo-folder-exists-p (car table))))
 794         (setq pattern
 795               (if (string-match "\\.[^\\.]+$" string)
 796                   (substring string 0 (match-beginning 0))
 797                 (char-to-string (aref string 0)))
 798               table (elmo-list-folders pattern)))
 799     (setq pattern (concat "^" (regexp-quote pattern)))
 800     (unless (intern-soft pattern wl-fldmgr-add-completion-hashtb)
 801       (set (intern pattern wl-fldmgr-add-completion-hashtb) table))
 802     table))
 803
 804 (defun wl-fldmgr-add-completion-subr (string predicate flag)
 805   (let ((table
 806          (if (string= string "")
 807              (mapcar (function (lambda (spec)
 808                                  (list (char-to-string (car spec)))))
 809                      elmo-spec-alist)
 810            (when (assq (aref string 0) elmo-spec-alist)
 811              (delq nil (mapcar
 812                         (function list)
 813                         (condition-case nil
 814                             (wl-fldmgr-add-completion-all-completions string)
 815                           (error nil))))))))
 816     (if (null flag)
 817         (try-completion string table predicate)
 818       (if (eq flag 'lambda)
 819           (eq t (try-completion string table predicate))
 820         (if flag
 821             (all-completions string table predicate))))))
 822
 823 (defun wl-fldmgr-add (&optional name)
 824   (interactive)
 825   (save-excursion
 826     (beginning-of-line)
 827     (let ((ret-val nil)
 828           (inhibit-read-only t)
 829           (wl-folder-completion-func (function wl-fldmgr-add-completion-subr))
 830           tmp indent path diffs)
 831       (if (bobp)
 832           (message "Can't insert in the out of desktop group")
 833         (setq tmp (wl-fldmgr-get-path-from-buffer t))
 834         (setq path (car tmp))
 835         (setq indent (wl-fldmgr-make-indent (nth 1 tmp)))
 836         (or name
 837             (setq name (wl-fldmgr-read-string
 838                         (wl-summary-read-folder wl-default-folder "to add"))))
 839         ;; maybe add elmo-plugged-alist.
 840         (when (stringp name)
 841           (elmo-folder-set-plugged name wl-plugged t))
 842         (when (setq diffs
 843                     (wl-add-entity
 844                      path (list name) wl-folder-entity (nth 3 tmp) t))
 845           (wl-folder-insert-entity indent name)
 846           (wl-fldmgr-update-group path diffs)
 847           (setq wl-fldmgr-modified t)
 848           (set-buffer-modified-p nil)
 849           (setq ret-val t)))
 850       ret-val)))
 851
 852 (defun wl-fldmgr-delete ()
 853   (interactive)
 854   (save-excursion
 855     (beginning-of-line)
 856     (if (looking-at wl-folder-group-regexp)
 857         (error "can't delete group folder"))
 858     (let* ((inhibit-read-only t)
 859            (tmp (wl-fldmgr-get-path-from-buffer))
 860            (entity (elmo-string (nth 4 tmp)))
 861            (msgs (and (elmo-folder-exists-p entity)
 862                       (elmo-list-folder entity))))
 863       (when (yes-or-no-p (format "%sDo you really delete \"%s\"? "
 864                                  (if (> (length msgs) 0)
 865                                      (format "%d msg(s) exists. " (length msgs))
 866                                    "")
 867                                  entity))
 868         (elmo-delete-folder entity)
 869         (wl-fldmgr-cut tmp nil t)))))
 870
 871 (defun wl-fldmgr-rename ()
 872   (interactive)
 873   (save-excursion
 874     (beginning-of-line)
 875     (if (bobp)
 876         (message "Can't rename desktop group")
 877       (cond
 878        ((looking-at wl-folder-group-regexp) ;; group
 879         (let* ((indent (wl-match-buffer 1))
 880                (old-group (wl-folder-get-realname (wl-match-buffer 3)))
 881                (group-entity (wl-folder-search-group-entity-by-name
 882                               old-group wl-folder-entity))
 883                group)
 884           (if (eq (nth 1 group-entity) 'access)
 885               (message "%s: can't rename access group folder" old-group)
 886             (setq group (wl-fldmgr-read-string
 887                          (read-from-minibuffer "Rename: " old-group)))
 888             (if (string-match "/$" group)
 889                 (message "Remove tail slash.")
 890               (cond
 891                ((or (string= group "")
 892                     (string= old-group group))
 893                 nil)
 894                (t
 895                 (if (wl-string-assoc group wl-folder-group-alist)
 896                     (message "%s: group already exists" group)
 897                   (let ((inhibit-read-only t)
 898                         (id (wl-fldmgr-get-entity-id
 899                              (car group-entity))))
 900                     (wl-fldmgr-assign-id group id)
 901                     (setcar group-entity group)
 902                     (setcar (wl-string-assoc old-group wl-folder-group-alist)
 903                             group)
 904                     ;;(setcdr (assq id wl-folder-entity-id-name-alist) group)
 905                     (wl-folder-set-id-name id group)
 906                     (wl-fldmgr-delete-line)
 907                     (wl-folder-insert-entity
 908                      indent
 909                      group-entity t)
 910                     (setq wl-fldmgr-modified t)
 911                     (set-buffer-modified-p nil)))))))))
 912        (t ;; folder
 913         (let* ((tmp (wl-fldmgr-get-path-from-buffer))
 914                (old-folder (nth 4 tmp))
 915                new-folder)
 916           (if (eq (cdr (nth 2 tmp)) 'access)
 917               (error "can't rename access folder"))
 918           (setq new-folder
 919                 (wl-fldmgr-read-string
 920                  (wl-summary-read-folder old-folder "to rename" t t old-folder)))
 921           (if (or (wl-folder-entity-exists-p new-folder)
 922                   (file-exists-p (elmo-msgdb-expand-path new-folder)))
 923               (error "already exists folder: %s" new-folder))
 924           (elmo-rename-folder old-folder new-folder)
 925           (wl-folder-set-entity-info
 926            new-folder
 927            (wl-folder-get-entity-info old-folder))
 928           (when (wl-fldmgr-cut tmp nil t)
 929             (wl-fldmgr-add new-folder))))))))
 930
 931 (defun wl-fldmgr-make-access-group ()
 932   (interactive)
 933   (wl-fldmgr-make-group nil t))
 934
 935 (defun wl-fldmgr-make-group (&optional group-name access)
 936   (interactive)
 937   (save-excursion
 938     (beginning-of-line)
 939     (if (bobp)
 940         (message "Can't insert in the out of desktop group")
 941       (let ((inhibit-read-only t)
 942             (type 'group)
 943             group tmp indent path new prev-id flist diffs)
 944         (setq tmp (wl-fldmgr-get-path-from-buffer t))
 945         (setq path (car tmp))
 946         (setq indent (wl-fldmgr-make-indent (nth 1 tmp)))
 947         (setq prev-id (nth 3 tmp))
 948         (if (eq (cdr (nth 2 tmp)) 'access)
 949             (message "Can't insert access group")
 950           (setq group (or group-name
 951                           (wl-fldmgr-read-string
 952                            (read-from-minibuffer
 953                             (if access "Access Type Group: " "Group: ")))))
 954           (when (or access (string-match "[\t ]*/$" group))
 955             (setq group (if access group
 956                           (substring group 0 (match-beginning 0))))
 957             (setq type 'access)
 958             (setq flist (wl-create-access-folder-entity group)))
 959           (if (string= group "")
 960               nil
 961             (if (wl-string-assoc group wl-folder-group-alist)
 962                 (message "%s: group already exists" group)
 963               (setq new (append (list group type) flist))
 964               (when (setq diffs (wl-add-entity path
 965                                                (list new)
 966                                                wl-folder-entity
 967                                                prev-id))
 968                 (wl-folder-insert-entity indent new)
 969                 (wl-fldmgr-update-group path diffs)
 970                 (setq wl-fldmgr-modified t)
 971                 (set-buffer-modified-p nil)))))))))
 972
 973 (defun wl-fldmgr-make-multi ()
 974   (interactive)
 975   (if (not wl-fldmgr-cut-entity-list)
 976       (message "No cut buffer")
 977     (let ((cut-entity wl-fldmgr-cut-entity-list)
 978           (new-entity "")
 979           (first t)
 980           status)
 981       (setq status
 982             (catch 'done
 983               (while cut-entity
 984                 (cond
 985                  ((numberp (car cut-entity))
 986                   nil)
 987                  ((consp (car cut-entity))
 988                   (message "Can't make multi included group folder")
 989                   (throw 'done nil))
 990                  (t
 991                   (let ((spec (elmo-folder-get-spec (car cut-entity)))
 992                         multi-fld)
 993                     (if (eq (car spec) 'multi)
 994                         (setq multi-fld
 995                               (substring (car cut-entity) 1)))
 996                     (setq new-entity
 997                           (format "%s%s%s"
 998                                   (or multi-fld (car cut-entity))
 999                                   (if first "" ",")
1000                                   new-entity))
1001                     (setq first nil))))
1002                 (setq cut-entity (cdr cut-entity)))
1003               (throw 'done t)))
1004       (when status
1005         (setq new-entity (concat "*" new-entity))
1006         (wl-fldmgr-add new-entity)))))
1007
1008 (defun wl-fldmgr-make-filter ()
1009   (interactive)
1010   (save-excursion
1011     (beginning-of-line)
1012     (if (looking-at wl-folder-group-regexp)
1013         (message "This folder is group")
1014       (let ((tmp (wl-fldmgr-get-path-from-buffer)))
1015         (if (eq (cdr (nth 2 tmp)) 'access)
1016             (message "Tan't change access group")
1017           (let* ((entity (nth 4 tmp))
1018                  (old-entity entity)
1019                  old-filter
1020                  filter new-entity)
1021             (unless entity (error "no folder"))
1022             (when (string-match "^\\(\\(/[^/]+/\\)+\\)\\(.*\\)" entity)
1023               (setq old-filter (substring entity
1024                                           (match-beginning 1)
1025                                           (match-end 1)))
1026               (setq old-entity (substring entity
1027                                           (match-beginning 3)
1028                                           (match-end 3))))
1029             (setq filter (completing-read "Filter: "
1030                                           wl-fldmgr-filter-completion-alist
1031                                           nil nil
1032                                           (or old-filter "/")))
1033             (unless (or (string= filter "")
1034                         (string-match "/$" filter))
1035               (setq filter (concat filter "/")))
1036             (setq new-entity (concat filter old-entity))
1037             (let ((entity new-entity)
1038                   spec)
1039               ;; check filter syntax
1040               (while (eq
1041                       (car (setq spec (elmo-folder-get-spec entity)))
1042                       'filter)
1043                 (setq entity (nth 2 spec))))
1044             (wl-fldmgr-add new-entity)))))))
1045
1046 (defun wl-fldmgr-sort ()
1047   (interactive)
1048   (save-excursion
1049     (beginning-of-line)
1050     (let ((inhibit-read-only t)
1051           entity flist indent opened)
1052       (when (looking-at wl-folder-group-regexp)
1053         (setq indent (wl-match-buffer 1))
1054         (setq opened (wl-match-buffer 2))
1055         (setq entity (wl-folder-search-group-entity-by-name
1056                       (wl-folder-get-realname (wl-match-buffer 3))
1057                       wl-folder-entity))
1058         (message "Sorting...")
1059         (setq flist (sort (nth 2 entity) wl-fldmgr-sort-func))
1060         (setcar (cddr entity) flist)
1061         (wl-fldmgr-add-modified-access-list (car entity))
1062         (setq wl-fldmgr-modified t)
1063         ;;
1064         (when (string= opened "-")
1065           (let (beg end)
1066             (setq beg (point))
1067             (end-of-line)
1068             (save-match-data
1069               (setq end
1070                     (progn
1071                       (wl-folder-goto-bottom-of-current-folder indent)
1072                       (beginning-of-line)
1073                       (point))))
1074             (delete-region beg end)
1075             (wl-folder-insert-entity indent entity)))
1076         ;;(wl-fldmgr-reconst-entity-hashtb t t)
1077         (message "Sorting...done")
1078         (set-buffer-modified-p nil)))))
1079
1080 (defun wl-fldmgr-sort-standard (x y)
1081   (cond ((and (consp x) (not (consp y)))
1082          wl-fldmgr-sort-group-first)
1083         ((and (not (consp x)) (consp y))
1084          (not wl-fldmgr-sort-group-first))
1085         ((and (consp x) (consp y))
1086          (string-lessp (car x) (car y)))
1087         (t
1088          (string-lessp x y))))
1089
1090 (defun wl-fldmgr-subscribe-region ()
1091   (interactive)
1092   (wl-fldmgr-unsubscribe-region -1))
1093
1094 (defun wl-fldmgr-unsubscribe-region (&optional arg)
1095   (interactive "P")
1096   (let* ((p1 (region-beginning))
1097          (p2 (region-end))
1098          (r1 (progn
1099                (goto-char p1)
1100                (beginning-of-line)
1101                (point)))
1102          (r2 (progn
1103                (goto-char p2)
1104                (beginning-of-line)
1105                (point)))
1106          (from (min r1 r2))
1107          (to (max r1 r2))
1108          (count 0))
1109     (goto-char from)
1110     (while (< (point) to)
1111       (setq count (1+ count))
1112       (forward-line))
1113     (goto-char from)
1114     (message "Unsubscribe region...")
1115     (while (and (> count 0)
1116                 (wl-fldmgr-unsubscribe (or arg 1) t))
1117       (setq count (1- count)))
1118     (message "Unsubscribe region...done")))
1119
1120 (defun wl-fldmgr-subscribe ()
1121   (interactive)
1122   (wl-fldmgr-unsubscribe -1))
1123
1124 (defun wl-fldmgr-unsubscribe (&optional arg force)
1125   (interactive "P")
1126   (let ((type (and arg (prefix-numeric-value arg)))
1127         execed is-group)
1128     (save-excursion
1129       (beginning-of-line)
1130       (let ((inhibit-read-only t)
1131             folder
1132             tmp indent beg)
1133         (cond
1134          ((looking-at (format "^[ ]*%s\\[[+-]\\]\\(.*\\)" wl-folder-unsubscribe-mark))
1135           (if (and type (> type 0))
1136               nil
1137             (setq folder (list (wl-match-buffer 1) 'access nil))
1138             (if (wl-string-assoc (car folder) wl-folder-group-alist)
1139                 (message "%s: group already exists" (car folder))
1140               (wl-fldmgr-delete-line)
1141               (when (wl-fldmgr-add folder)
1142                 (wl-folder-maybe-load-folder-list folder)
1143 ;;               (wl-folder-search-group-entity-by-name (car folder)
1144 ;;                                                      wl-folder-entity))
1145                 (setq execed t)))))
1146          ((looking-at (format "^[ ]*%s\\(.*\\)" wl-folder-unsubscribe-mark))
1147           (if (and type (> type 0))
1148               nil
1149             (setq folder (wl-match-buffer 1))
1150             (wl-fldmgr-delete-line)
1151             (when (wl-fldmgr-add folder)
1152               (setq execed t))))
1153          (t
1154           (if (and type (< type 0))
1155               nil
1156             (setq is-group (looking-at wl-folder-group-regexp))
1157             (setq tmp (wl-fldmgr-get-path-from-buffer))
1158             (setq indent (wl-fldmgr-make-indent (nth 1 tmp)))
1159             (if (eq (cdr (nth 2 tmp)) 'access)
1160                 (when (wl-fldmgr-cut tmp)
1161                   (pop wl-fldmgr-cut-entity-list)  ;; don't leave cut-list
1162                   (setq beg (point))
1163                   (insert indent wl-folder-unsubscribe-mark
1164                           (if is-group
1165                               (concat "[+]" (nth 4 tmp))
1166                             (nth 4 tmp))
1167                           "\n")
1168                   (save-excursion (forward-line -1)
1169                                   (wl-highlight-folder-current-line))
1170                   (remove-text-properties beg (point) '(wl-folder-entity-id))
1171                   (setq execed t))))))
1172         (set-buffer-modified-p nil)))
1173     (if (or force execed)
1174         (progn
1175           (forward-line)
1176           t))))
1177
1178 (defun wl-fldmgr-access-display-normal (&optional arg)
1179   (interactive "P")
1180   (wl-fldmgr-access-display-all (not arg)))
1181
1182 (defun wl-fldmgr-access-display-all (&optional arg)
1183   (interactive "P")
1184   (let ((id (save-excursion
1185               (wl-folder-prev-entity-skip-invalid t)
1186               (wl-fldmgr-get-entity-id))))
1187     (save-excursion
1188     (beginning-of-line)
1189     (let ((inhibit-read-only t)
1190           entity indent opened
1191           unsubscribes beg)
1192       (when (not (looking-at wl-folder-group-regexp))
1193         (wl-folder-goto-top-of-current-folder)
1194         (looking-at wl-folder-group-regexp))
1195       (setq indent (wl-match-buffer 1))
1196       (setq opened (wl-match-buffer 2))
1197       (setq entity (wl-folder-search-group-entity-by-name
1198                     (wl-folder-get-realname (wl-match-buffer 3))
1199                     wl-folder-entity))
1200       (when (eq (nth 1 entity) 'access)
1201         (save-excursion
1202           (if (string= opened "-")
1203               (let (beg end)
1204                 (setq beg (point))
1205                 (end-of-line)
1206                 (save-match-data
1207                   (setq end
1208                         (progn
1209                           (wl-folder-goto-bottom-of-current-folder indent)
1210                           (beginning-of-line)
1211                           (point))))
1212                 (delete-region beg end))
1213             (wl-fldmgr-delete-line)
1214             (setcdr (assoc (car entity) wl-folder-group-alist) t));; set open
1215           (wl-folder-insert-entity indent entity))
1216         (when (not arg)
1217           (setq unsubscribes (nth 3 entity))
1218           (forward-line)
1219           (while unsubscribes
1220             (setq beg (point))
1221             (insert indent "  " wl-folder-unsubscribe-mark
1222                     (if (consp (car unsubscribes))
1223                         (concat "[+]" (caar unsubscribes))
1224                       (car unsubscribes))
1225                     "\n")
1226             (remove-text-properties beg (point) '(wl-folder-entity-id))
1227             (save-excursion (forward-line -1)
1228                             (wl-highlight-folder-current-line))
1229             (setq unsubscribes (cdr unsubscribes))))
1230         (set-buffer-modified-p nil))))
1231     (wl-folder-move-path id)))
1232
1233 (defun wl-fldmgr-set-petname ()
1234   (interactive)
1235   (save-excursion
1236     (beginning-of-line)
1237       (let* ((is-group (looking-at wl-folder-group-regexp))
1238              (name (wl-folder-get-entity-from-buffer))
1239              (searchname (wl-folder-get-petname name))
1240              (pentry (wl-string-assoc name wl-folder-petname-alist))
1241              (old-petname (or (cdr pentry) ""))
1242              (change)
1243              petname)
1244         (unless name (error "no folder"))
1245         (if (and is-group
1246                  (not (eq (nth 1 (wl-folder-search-group-entity-by-name
1247                                   name wl-folder-entity))
1248                           'access)))
1249             (message "Can't set petname. please rename.")
1250         (setq petname (wl-fldmgr-read-string
1251                        (read-from-minibuffer "Petname: " old-petname)))
1252         (cond
1253          ((string= petname "")
1254           (when pentry
1255             (setq wl-folder-petname-alist
1256                   (delete pentry wl-folder-petname-alist))
1257             (setq change t)))
1258          (t
1259           (if (string= petname old-petname)
1260               nil
1261             (if (or (rassoc petname wl-folder-petname-alist)
1262                     (wl-string-assoc petname wl-folder-group-alist))
1263                 (message "%s: already exists" petname)
1264               (wl-folder-append-petname name petname)
1265               (setq change t)))))
1266         (when change
1267           (let ((inhibit-read-only t)
1268                 indent)
1269             (goto-char (point-min))
1270             (if is-group
1271                 (progn
1272                   (if (string= old-petname "")
1273                       (setq old-petname name))
1274                   (while (wl-folder-buffer-search-group old-petname)
1275                     (beginning-of-line)
1276                     (and (looking-at "^\\([ ]*\\)")
1277                          (setq indent (wl-match-buffer 1)))
1278                     (wl-fldmgr-delete-line)
1279                     (wl-folder-insert-entity
1280                      indent
1281                      (wl-folder-search-group-entity-by-name
1282                       name wl-folder-entity)
1283                      t)))
1284               (while (wl-folder-buffer-search-entity name searchname)
1285                 (save-excursion
1286                   (beginning-of-line)
1287                   (and (looking-at "^\\([ ]*\\)")
1288                        (setq indent (wl-match-buffer 1)))
1289                   (wl-fldmgr-delete-line))
1290                 (wl-folder-insert-entity indent name)))
1291             (setq wl-fldmgr-modified t)
1292             (set-buffer-modified-p nil)))))))
1293
1294 ;;; Function for save folders
1295 ;;
1296
1297 (defun wl-fldmgr-insert-folders-buffer (indent entities &optional pet-entities)
1298   (let ((flist entities)
1299         name petname)
1300     (while flist
1301       (setq name (car flist))
1302       (cond ((stringp name)
1303              (if (setq petname (cdr (wl-string-assoc name wl-folder-petname-alist)))
1304                  (wl-append pet-entities (list name)))
1305              (insert indent name
1306                      (if petname
1307                          (concat "\t\"" petname "\"")
1308                        "")
1309                      "\n"))
1310             ((consp name)
1311              (let ((group (wl-folder-get-realname (car name)))
1312                    (type (nth 1 name)))
1313                (if (not (string= group (car name))) ; petname.
1314                    (wl-append pet-entities (list (car name))))
1315                (cond ((eq type 'group)
1316                       (insert indent group "{\n")
1317                       (setq pet-entities
1318                             (wl-fldmgr-insert-folders-buffer
1319                              (concat indent wl-fldmgr-folders-indent)
1320                              (nth 2 name) pet-entities))
1321                       (insert indent "}\n"))
1322                      ((eq type 'access)
1323                       (insert indent group "/\n"))))))
1324       (setq flist (cdr flist))))
1325   pet-entities)
1326
1327 (defun wl-fldmgr-insert-petname-buffer (pet-entities)
1328   (let ((alist wl-folder-petname-alist))
1329     (while alist
1330       (if (wl-string-member (caar alist) pet-entities)
1331           nil
1332         (insert "=\t" (caar alist) "\t\"" (cdar alist) "\"\n"))
1333       (setq alist (cdr alist)))))
1334
1335 (defun wl-fldmgr-delete-disused-petname ()
1336   (let ((alist wl-folder-petname-alist))
1337     (while alist
1338       (unless (wl-folder-search-entity-by-name (caar alist) wl-folder-entity)
1339         (setq wl-folder-petname-alist
1340               (delete (car alist) wl-folder-petname-alist)))
1341       (setq alist (cdr alist)))))
1342
1343 (defun wl-fldmgr-save-folders ()
1344   (interactive)
1345   (let ((tmp-buf (get-buffer-create " *wl-fldmgr-tmp*"))
1346         (access-list wl-fldmgr-modified-access-list)
1347         entity
1348         save-petname-entities)
1349     (message "Saving folders...")
1350     (set-buffer tmp-buf)
1351     (erase-buffer)
1352     (insert (format wl-fldmgr-folders-header
1353                     wl-appname wl-version wl-codename))
1354     (wl-fldmgr-delete-disused-petname)
1355     (setq save-petname-entities
1356           (wl-fldmgr-insert-folders-buffer "" (nth 2 wl-folder-entity)))
1357     (insert "\n# petname definition (group, folder in access group)\n")
1358     (wl-fldmgr-insert-petname-buffer save-petname-entities)
1359     (insert "\n# end of file.\n")
1360     (if (and wl-fldmgr-make-backup
1361              (file-exists-p wl-folders-file))
1362         (rename-file wl-folders-file (concat wl-folders-file ".bak") t))
1363     (let ((output-coding-system (mime-charset-to-coding-system
1364                                  wl-mime-charset)))
1365       (write-region
1366        (point-min)
1367        (point-max)
1368        wl-folders-file
1369        nil
1370        'no-msg)
1371       (set-file-modes wl-folders-file 384)) ; 600
1372     (kill-buffer tmp-buf)
1373     (while access-list
1374       (setq entity (wl-folder-search-group-entity-by-name
1375                     (car access-list) wl-folder-entity))
1376       (elmo-msgdb-flist-save
1377        (car access-list)
1378        (list
1379         (wl-folder-make-save-access-list (nth 2 entity))
1380         (wl-folder-make-save-access-list (nth 3 entity))))
1381       (setq access-list (cdr access-list)))
1382     (setq wl-fldmgr-modified nil)
1383     (setq wl-fldmgr-modified-access-list nil)
1384     (message "Saving folders...done")))
1385
1386 (provide 'wl-fldmgr)
1387
1388 ;;; wl-fldmgr.el ends here