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