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