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