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