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