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