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