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