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) ,(string-to-char " "))))
 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 "to add"))))
 835         ;; maybe add elmo-plugged-alist.
 836         (elmo-folder-set-plugged (wl-folder-get-elmo-folder
 837                                   (if (listp name) (car name) name))
 838                                  wl-plugged t)
 839         (when (setq diffs
 840                     (wl-add-entity
 841                      path (list name) wl-folder-entity (nth 3 tmp) t))
 842           (wl-folder-insert-entity indent name)
 843           (wl-fldmgr-update-group path diffs)
 844           (setq wl-fldmgr-modified t)
 845           (set-buffer-modified-p nil)
 846           (setq ret-val t)))
 847       ret-val)))
 848
 849 (defun wl-fldmgr-delete ()
 850   (interactive)
 851   (save-excursion
 852     (beginning-of-line)
 853     (if (wl-folder-buffer-group-p)
 854         (error "Can't delete group folder"))
 855     (let* ((inhibit-read-only t)
 856            (tmp (wl-fldmgr-get-path-from-buffer))
 857            (entity (elmo-string (nth 4 tmp)))
 858            (folder (wl-folder-get-elmo-folder entity)))
 859       (when (elmo-folder-delete folder)
 860         (wl-folder-clear-entity-info entity)
 861         (wl-fldmgr-cut tmp nil t)
 862         (wl-fldmgr-save-access-list)))))
 863
 864 (defun wl-fldmgr-rename ()
 865   (interactive)
 866   (save-excursion
 867     (beginning-of-line)
 868     (if (bobp)
 869         (message "Can't rename desktop group")
 870       (cond
 871        ((and (wl-folder-buffer-group-p)
 872              (looking-at wl-folder-group-regexp)) ;; group
 873         (let* ((indent (wl-match-buffer 1))
 874                (old-group (wl-folder-get-entity-from-buffer))
 875                (group-entity (wl-folder-search-group-entity-by-name
 876                               old-group wl-folder-entity))
 877                group)
 878           (if (eq (nth 1 group-entity) 'access)
 879               (message "%s: can't rename access group folder" old-group)
 880             (setq group (wl-fldmgr-read-string
 881                          (read-from-minibuffer "Rename: " old-group)))
 882             (if (string-match "/$" group)
 883                 (message "Remove tail slash.")
 884               (cond
 885                ((or (string= group "")
 886                     (string= old-group group))
 887                 nil)
 888                (t
 889                 (if (wl-string-assoc group wl-folder-group-alist)
 890                     (message "%s: group already exists" group)
 891                   (let ((inhibit-read-only t)
 892                         (id (wl-fldmgr-get-entity-id
 893                              (car group-entity))))
 894                     (wl-fldmgr-assign-id group id)
 895                     (setcar group-entity group)
 896                     (setcar (wl-string-assoc old-group wl-folder-group-alist)
 897                             group)
 898 ;;;                 (setcdr (assq id wl-folder-entity-id-name-alist) group)
 899                     (wl-folder-set-id-name id group)
 900                     (wl-fldmgr-delete-line)
 901                     (wl-folder-insert-entity
 902                      indent
 903                      group-entity t)
 904                     (setq wl-fldmgr-modified t)
 905                     (set-buffer-modified-p nil)))))))))
 906        (t ;; folder
 907         (let* ((tmp (wl-fldmgr-get-path-from-buffer))
 908                (old-folder (nth 4 tmp))
 909                new-folder)
 910           (unless old-folder (error "No folder"))
 911           (setq new-folder
 912                 (wl-fldmgr-read-string
 913                  (wl-summary-read-folder old-folder "to rename" t t old-folder)))
 914           (if (or (wl-folder-entity-exists-p new-folder)
 915                   (file-exists-p (elmo-folder-msgdb-path
 916                                   (wl-folder-get-elmo-folder new-folder))))
 917               (error "Already exists folder: %s" new-folder))
 918           (if (and (eq (cdr (nth 2 tmp)) 'access)
 919                    (null wl-fldmgr-allow-rename-access-group)
 920                    (null (string-match
 921                           (format "^%s" (regexp-quote (car (nth 2 tmp))))
 922                           new-folder)))
 923               (error "Can't rename access folder"))
 924           (elmo-folder-rename (wl-folder-get-elmo-folder old-folder)
 925                               new-folder)
 926           (wl-folder-set-entity-info
 927            new-folder
 928            (wl-folder-get-entity-info old-folder))
 929           (wl-folder-clear-entity-info old-folder)
 930           (setq wl-folder-info-alist-modified t)
 931           (if (eq (cdr (nth 2 tmp)) 'access)
 932
 933               ;; force update access group
 934               (progn
 935                 (wl-folder-open-close)
 936                 (wl-folder-jump-to-current-entity t)
 937                 (message "%s is renamed to %s" old-folder new-folder)
 938                 (sit-for 1))
 939             ;; update folder list
 940             (when (wl-fldmgr-cut tmp nil t)
 941               (wl-fldmgr-add new-folder)))))))))
 942
 943 (defun wl-fldmgr-make-access-group ()
 944   (interactive)
 945   (wl-fldmgr-make-group nil t))
 946
 947 (defun wl-fldmgr-make-group (&optional group-name access)
 948   (interactive)
 949   (save-excursion
 950     (beginning-of-line)
 951     (if (bobp)
 952         (message "Can't insert in the out of desktop group")
 953       (let ((inhibit-read-only t)
 954             (type 'group)
 955             group tmp indent path new prev-id flist diffs)
 956         (setq tmp (wl-fldmgr-get-path-from-buffer t))
 957         (setq path (car tmp))
 958         (setq indent (wl-fldmgr-make-indent (nth 1 tmp)))
 959         (setq prev-id (nth 3 tmp))
 960         (if (eq (cdr (nth 2 tmp)) 'access)
 961             (message "Can't insert access group")
 962           (setq group (or group-name
 963                           (wl-fldmgr-read-string
 964                            (read-from-minibuffer
 965                             (if access "Access Type Group: " "Group: ")))))
 966           ;; To check the folder name is correct.
 967           (if access (elmo-make-folder group))
 968           (when (or access (string-match "[\t ]*/$" group))
 969             (setq group (if access group
 970                           (substring group 0 (match-beginning 0))))
 971             (setq type 'access)
 972             (setq flist (wl-create-access-folder-entity group)))
 973           (if (string= group "")
 974               nil
 975             (if (wl-string-assoc group wl-folder-group-alist)
 976                 (message "%s: group already exists" group)
 977               (setq new (append (list group type) flist))
 978               (when (setq diffs (wl-add-entity path
 979                                                (list new)
 980                                                wl-folder-entity
 981                                                prev-id))
 982                 (wl-folder-insert-entity indent new)
 983                 (wl-fldmgr-update-group path diffs)
 984                 (setq wl-fldmgr-modified t)
 985                 (set-buffer-modified-p nil)))))))))
 986
 987 (defun wl-fldmgr-make-multi ()
 988   (interactive)
 989   (if (not wl-fldmgr-cut-entity-list)
 990       (message "No cut buffer")
 991     (let ((cut-entity wl-fldmgr-cut-entity-list)
 992           (new-entity "")
 993           (first t)
 994           status)
 995       (setq status
 996             (catch 'done
 997               (while cut-entity
 998                 (cond
 999                  ((numberp (car cut-entity))
1000                   nil)
1001                  ((consp (car cut-entity))
1002                   (message "Can't make multi included group folder")
1003                   (throw 'done nil))
1004                  (t
1005                   (let ((folder (wl-folder-get-elmo-folder
1006                                  (car cut-entity)))
1007                         multi-fld)
1008                     (if (eq (elmo-folder-type-internal folder) 'multi)
1009                         (setq multi-fld
1010                               (substring (car cut-entity) 1)))
1011                     (setq new-entity
1012                           (format "%s%s%s"
1013                                   (or multi-fld (car cut-entity))
1014                                   (if first "" ",")
1015                                   new-entity))
1016                     (setq first nil))))
1017                 (setq cut-entity (cdr cut-entity)))
1018               (throw 'done t)))
1019       (when status
1020         (setq new-entity (concat "*" new-entity))
1021         (wl-fldmgr-add new-entity)))))
1022
1023 (defun wl-fldmgr-make-filter ()
1024   (interactive)
1025   (save-excursion
1026     (beginning-of-line)
1027     (let ((tmp (wl-fldmgr-get-path-from-buffer))
1028           entity)
1029       (if (eq (cdr (nth 2 tmp)) 'access)
1030           (message "Can't change access group")
1031         (if (wl-folder-buffer-group-p)
1032             (setq entity
1033                   (concat
1034                    "*"
1035                    (mapconcat 'identity
1036                               (wl-folder-get-entity-list
1037                                (wl-folder-search-group-entity-by-name
1038                                 (nth 4 tmp)
1039                                 wl-folder-entity)) ",")))
1040           (setq entity (nth 4 tmp)))
1041         (unless entity (error "No folder"))
1042         (wl-fldmgr-add (concat "/"
1043                                (wl-read-search-condition
1044                                 wl-fldmgr-make-filter-default)
1045                                "/" entity))))))
1046
1047 (defun wl-fldmgr-sort (&optional arg)
1048   (interactive "P")
1049   (save-excursion
1050     (beginning-of-line)
1051     (let ((inhibit-read-only t)
1052           entity flist indent opened)
1053       (when (and (wl-folder-buffer-group-p)
1054                  (looking-at wl-folder-group-regexp)
1055                  (prog1
1056                      (y-or-n-p (format "Sort subfolders of %s? "
1057                                        (wl-folder-get-entity-from-buffer)))
1058                    (message nil)))
1059         (setq indent (wl-match-buffer 1))
1060         (setq opened (wl-match-buffer 2))
1061         (setq entity (wl-folder-search-group-entity-by-name
1062                       (wl-folder-get-entity-from-buffer)
1063                       wl-folder-entity))
1064         (message "Sorting...")
1065         (setq flist (sort (nth 2 entity) wl-fldmgr-sort-function))
1066         (when arg (setq flist (nreverse flist)))
1067         (setcar (cddr entity) flist)
1068         (wl-fldmgr-add-modified-access-list (car entity))
1069         (setq wl-fldmgr-modified t)
1070         (when (string= opened "-")
1071           (let (beg end)
1072             (setq beg (point))
1073             (end-of-line)
1074             (save-match-data
1075               (setq end
1076                     (progn
1077                       (wl-folder-goto-bottom-of-current-folder indent)
1078                       (beginning-of-line)
1079                       (point))))
1080             (delete-region beg end)
1081             (wl-folder-insert-entity indent entity)))
1082         (message "Sorting...done")
1083         (set-buffer-modified-p nil)))))
1084
1085 (defun wl-fldmgr-sort-standard (x y)
1086   (cond ((and (consp x) (not (consp y)))
1087          wl-fldmgr-sort-group-first)
1088         ((and (not (consp x)) (consp y))
1089          (not wl-fldmgr-sort-group-first))
1090         ((and (consp x) (consp y))
1091          (string-lessp (car x) (car y)))
1092         (t
1093          (string-lessp x y))))
1094
1095 (defun wl-fldmgr-subscribe-region ()
1096   (interactive)
1097   (wl-fldmgr-unsubscribe-region -1))
1098
1099 (defun wl-fldmgr-unsubscribe-region (&optional arg)
1100   (interactive "P")
1101   (let* ((p1 (region-beginning))
1102          (p2 (region-end))
1103          (r1 (progn
1104                (goto-char p1)
1105                (beginning-of-line)
1106                (point)))
1107          (r2 (progn
1108                (goto-char p2)
1109                (beginning-of-line)
1110                (point)))
1111          (from (min r1 r2))
1112          (to (max r1 r2))
1113          (count 0))
1114     (goto-char from)
1115     (while (< (point) to)
1116       (setq count (1+ count))
1117       (forward-line))
1118     (goto-char from)
1119     (message "Unsubscribe region...")
1120     (while (and (> count 0)
1121                 (wl-fldmgr-unsubscribe (or arg 1) t))
1122       (setq count (1- count)))
1123     (message "Unsubscribe region...done")))
1124
1125 (defun wl-fldmgr-subscribe ()
1126   (interactive)
1127   (wl-fldmgr-unsubscribe -1))
1128
1129 (defun wl-fldmgr-unsubscribe (&optional arg force)
1130   (interactive "P")
1131   (let ((type (and arg (prefix-numeric-value arg)))
1132         execed is-group)
1133     (save-excursion
1134       (beginning-of-line)
1135       (let ((inhibit-read-only t)
1136             folder
1137             tmp indent beg)
1138         (cond
1139          ((looking-at (format "^[ ]*%s\\[[+-]\\]\\(.*\\)" wl-folder-unsubscribe-mark))
1140           (if (and type (> type 0))
1141               nil
1142             (setq folder (list (wl-match-buffer 1) 'access nil))
1143             (if (wl-string-assoc (car folder) wl-folder-group-alist)
1144                 (message "%s: group already exists" (car folder))
1145               (wl-fldmgr-delete-line)
1146               (when (wl-fldmgr-add folder)
1147                 (wl-folder-maybe-load-folder-list folder)
1148 ;;;             (wl-folder-search-group-entity-by-name (car folder)
1149 ;;;                                                    wl-folder-entity)
1150                 (setq execed t)))))
1151          ((looking-at (format "^[ ]*%s\\(.*\\)" wl-folder-unsubscribe-mark))
1152           (if (and type (> type 0))
1153               nil
1154             (setq folder (wl-match-buffer 1))
1155             (wl-fldmgr-delete-line)
1156             (when (wl-fldmgr-add folder)
1157               (setq execed t))))
1158          (t
1159           (if (and type (< type 0))
1160               nil
1161             (setq is-group (wl-folder-buffer-group-p))
1162             (setq tmp (wl-fldmgr-get-path-from-buffer))
1163             (setq indent (wl-fldmgr-make-indent (nth 1 tmp)))
1164             (if (eq (cdr (nth 2 tmp)) 'access)
1165                 (when (wl-fldmgr-cut tmp)
1166                   ;; don't leave cut-list
1167                   (setq wl-fldmgr-cut-entity-list (cdr wl-fldmgr-cut-entity-list))
1168                   (setq beg (point))
1169                   (insert indent wl-folder-unsubscribe-mark
1170                           (if is-group
1171                               (concat "[+]" (nth 4 tmp))
1172                             (nth 4 tmp))
1173                           "\n")
1174                   (save-excursion (forward-line -1)
1175                                   (wl-highlight-folder-current-line))
1176                   (remove-text-properties beg (point) '(wl-folder-entity-id))
1177                   (setq execed t))
1178               (message "not an access group folder")))))
1179         (set-buffer-modified-p nil)))
1180     (if (or force execed)
1181         (progn
1182           (forward-line)
1183           t))))
1184
1185 (defun wl-fldmgr-access-display-normal (&optional arg)
1186   (interactive "P")
1187   (wl-fldmgr-access-display-all (not arg)))
1188
1189 (defun wl-fldmgr-access-display-all (&optional arg)
1190   (interactive "P")
1191   (let ((id (save-excursion
1192               (wl-folder-prev-entity-skip-invalid t)
1193               (wl-fldmgr-get-entity-id))))
1194     (save-excursion
1195     (beginning-of-line)
1196     (let ((inhibit-read-only t)
1197           entity indent opened
1198           unsubscribes beg)
1199       (when (not
1200              (and (wl-folder-buffer-group-p)
1201                   (looking-at wl-folder-group-regexp)))
1202         (wl-folder-goto-top-of-current-folder)
1203         (looking-at wl-folder-group-regexp))
1204       (setq indent (wl-match-buffer 1))
1205       (setq opened (wl-match-buffer 2))
1206       (setq entity (wl-folder-search-group-entity-by-name
1207                     (wl-folder-get-entity-from-buffer)
1208                     wl-folder-entity))
1209       (when (eq (nth 1 entity) 'access)
1210         (save-excursion
1211           (if (string= opened "-")
1212               (let (beg end)
1213                 (setq beg (point))
1214                 (end-of-line)
1215                 (save-match-data
1216                   (setq end
1217                         (progn
1218                           (wl-folder-goto-bottom-of-current-folder indent)
1219                           (beginning-of-line)
1220                           (point))))
1221                 (delete-region beg end))
1222             (wl-fldmgr-delete-line)
1223             (setcdr (assoc (car entity) wl-folder-group-alist) t));; set open
1224           (wl-folder-insert-entity indent entity))
1225         (when (not arg)
1226           (setq unsubscribes (nth 3 entity))
1227           (forward-line)
1228           (while unsubscribes
1229             (setq beg (point))
1230             (insert indent "  " wl-folder-unsubscribe-mark
1231                     (if (consp (car unsubscribes))
1232                         (concat "[+]" (caar unsubscribes))
1233                       (car unsubscribes))
1234                     "\n")
1235             (remove-text-properties beg (point) '(wl-folder-entity-id))
1236             (save-excursion (forward-line -1)
1237                             (wl-highlight-folder-current-line))
1238             (setq unsubscribes (cdr unsubscribes))))
1239         (set-buffer-modified-p nil))))
1240     (wl-folder-move-path id)))
1241
1242 (defun wl-fldmgr-set-petname ()
1243   (interactive)
1244   (save-excursion
1245     (beginning-of-line)
1246       (let* ((is-group (wl-folder-buffer-group-p))
1247              (name (wl-folder-get-entity-from-buffer))
1248              (searchname (wl-folder-get-petname name))
1249              (pentry (wl-string-assoc name wl-folder-petname-alist))
1250              (old-petname (or (cdr pentry) ""))
1251              (change)
1252              petname)
1253         (unless name (error "No folder"))
1254         (if (and is-group
1255                  (not (eq (nth 1 (wl-folder-search-group-entity-by-name
1256                                   name wl-folder-entity))
1257                           'access)))
1258             (message "Can't set petname. please rename.")
1259         (setq petname (wl-fldmgr-read-string
1260                        (read-from-minibuffer "Petname: " old-petname)))
1261         (cond
1262          ((string= petname "")
1263           (when pentry
1264             (setq wl-folder-petname-alist
1265                   (delete pentry wl-folder-petname-alist))
1266             (setq change t)))
1267          (t
1268           (if (string= petname old-petname)
1269               nil
1270             (if (or (rassoc petname wl-folder-petname-alist)
1271                     (and is-group
1272                          (wl-string-assoc petname wl-folder-group-alist)))
1273                 (message "%s: already exists" petname)
1274               (wl-folder-append-petname name petname)
1275               (setq change t)))))
1276         (when change
1277           (let ((inhibit-read-only t)
1278                 indent)
1279             (goto-char (point-min))
1280             (if is-group
1281                 (progn
1282                   (if (string= old-petname "")
1283                       (setq old-petname name))
1284                   (while (wl-folder-buffer-search-group old-petname)
1285                     (beginning-of-line)
1286                     (and (looking-at "^\\([ ]*\\)")
1287                          (setq indent (wl-match-buffer 1)))
1288                     (wl-fldmgr-delete-line)
1289                     (wl-folder-insert-entity
1290                      indent
1291                      (wl-folder-search-group-entity-by-name
1292                       name wl-folder-entity)
1293                      t)))
1294               (while (wl-folder-buffer-search-entity name searchname)
1295                 (save-excursion
1296                   (beginning-of-line)
1297                   (and (looking-at "^\\([ ]*\\)")
1298                        (setq indent (wl-match-buffer 1)))
1299                   (wl-fldmgr-delete-line))
1300                 (wl-folder-insert-entity indent name)))
1301             (setq wl-fldmgr-modified t)
1302             (set-buffer-modified-p nil)))))))
1303
1304 ;;; Function for save folders
1305 ;;
1306
1307 (defun wl-fldmgr-insert-folders-buffer (indent entities &optional pet-entities)
1308   (let ((flist entities)
1309         name petname)
1310     (while flist
1311       (setq name (car flist))
1312       (cond ((stringp name)
1313              (if (setq petname (cdr (wl-string-assoc name wl-folder-petname-alist)))
1314                  (wl-append pet-entities (list name)))
1315              (insert indent name
1316                      (if petname
1317                          (concat "\t\"" petname "\"")
1318                        "")
1319                      "\n"))
1320             ((consp name)
1321              (let ((group (car name))
1322                    (type (nth 1 name)))
1323                (cond ((eq type 'group)
1324                       (insert indent group "{\n")
1325                       (setq pet-entities
1326                             (wl-fldmgr-insert-folders-buffer
1327                              (concat indent wl-fldmgr-folders-indent)
1328                              (nth 2 name) pet-entities))
1329                       (insert indent "}\n"))
1330                      ((eq type 'access)
1331                       (insert indent group "/\n"))))))
1332       (setq flist (cdr flist))))
1333   pet-entities)
1334
1335 (defun wl-fldmgr-insert-petname-buffer (pet-entities)
1336   (let ((alist wl-folder-petname-alist))
1337     (while alist
1338       (if (wl-string-member (caar alist) pet-entities)
1339           nil
1340         (insert "=\t" (caar alist) "\t\"" (cdar alist) "\"\n"))
1341       (setq alist (cdr alist)))))
1342
1343 (defun wl-fldmgr-delete-disused-petname ()
1344   (let ((alist wl-folder-petname-alist))
1345     (while alist
1346       (unless (wl-folder-search-entity-by-name (caar alist) wl-folder-entity)
1347         (setq wl-folder-petname-alist
1348               (delete (car alist) wl-folder-petname-alist)))
1349       (setq alist (cdr alist)))))
1350
1351 (defun wl-fldmgr-save-folders ()
1352   (interactive)
1353   (let ((tmp-buf (get-buffer-create " *wl-fldmgr-tmp*"))
1354         save-petname-entities)
1355     (message "Saving folders...")
1356     (set-buffer tmp-buf)
1357     (erase-buffer)
1358     (insert wl-fldmgr-folders-header)
1359     (wl-fldmgr-delete-disused-petname)
1360     (setq save-petname-entities
1361           (wl-fldmgr-insert-folders-buffer "" (nth 2 wl-folder-entity)))
1362     (insert "\n# petname definition (access group, folder in access group)\n")
1363     (wl-fldmgr-insert-petname-buffer save-petname-entities)
1364     (insert "\n# end of file.\n")
1365     (if (and wl-fldmgr-make-backup
1366              (file-exists-p wl-folders-file))
1367         (rename-file wl-folders-file (concat wl-folders-file ".bak") t))
1368     (let ((output-coding-system (mime-charset-to-coding-system
1369                                  wl-mime-charset)))
1370       (write-region
1371        (point-min)
1372        (point-max)
1373        wl-folders-file
1374        nil
1375        'no-msg)
1376       (set-file-modes wl-folders-file (+ (* 64 6) (* 8 0) 0))) ; chmod 0600
1377     (kill-buffer tmp-buf)
1378     (wl-fldmgr-save-access-list)
1379     (setq wl-fldmgr-modified nil)
1380     (message "Saving folders...done")))
1381
1382 (defun wl-fldmgr-save-access-list ()
1383   (let ((access-list wl-fldmgr-modified-access-list)
1384         entity)
1385     (while access-list
1386       (setq entity (wl-folder-search-group-entity-by-name
1387                     (car access-list) wl-folder-entity))
1388       (elmo-msgdb-flist-save
1389        (car access-list)
1390        (list
1391         (wl-folder-make-save-access-list (nth 2 entity))
1392         (wl-folder-make-save-access-list (nth 3 entity))))
1393       (setq access-list (cdr access-list)))
1394     (setq wl-fldmgr-modified-access-list nil)))
1395
1396 (require 'product)
1397 (product-provide (provide 'wl-fldmgr) (require 'wl-version))
1398
1399 ;;; wl-fldmgr.el ends here