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