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