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                ((elmo-string-member (car new2) flist)
 391                 (and errmes (message "%s: already exists" (car new2)))
 392                 (throw 'success nil))
 393                ((and access
 394                      (not (elmo-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                (wl-folder-buffer-group-p)
 465                (looking-at wl-folder-group-regexp)
 466                (string= (wl-match-buffer 2) "-"))
 467           (setq group-target nil)
 468         (if (and prev (bobp))
 469             (error "Out of desktop group")))
 470       (setq folder-path (wl-fldmgr-get-path wl-folder-entity
 471                                             (wl-folder-get-entity-from-buffer)
 472 ;;;                                         (wl-fldmgr-get-entity-id)
 473                                             group-target))
 474       (let ((fp folder-path))
 475         (while fp
 476           (if (consp (car fp))
 477               (progn
 478                 (setq indent-level (1+ indent-level))
 479                 (setq group-type (cons (caar fp) (nth 1 (car fp)))))
 480             (setq entity (car fp)))
 481           (setq fp (cdr fp))))
 482       (list folder-path indent-level group-type previous-entity entity))))
 483
 484 ;;; Command
 485 ;;
 486
 487 (defun wl-fldmgr-clear-cut-entity-list ()
 488   (interactive)
 489   (setq wl-fldmgr-cut-entity-list nil)
 490   (message "Cleared cut entity list"))
 491
 492 (defun wl-fldmgr-reconst-entity-hashtb (&optional arg nomes)
 493   (interactive "P")
 494   (or nomes (message "Reconstructing entity alist..."))
 495   (when (not arg)
 496     (setq wl-folder-entity-id 0)
 497     (wl-folder-entity-assign-id wl-folder-entity))
 498   (setq wl-folder-entity-hashtb
 499         (wl-folder-create-entity-hashtb
 500          wl-folder-entity
 501          wl-folder-entity-hashtb
 502          t))
 503   ;; reset property on buffer
 504   (when (not arg)
 505     (let ((inhibit-read-only t)
 506           (cur-point (point)))
 507       (erase-buffer)
 508       (wl-folder-insert-entity " " wl-folder-entity)
 509       (goto-char cur-point)
 510       (set-buffer-modified-p nil)))
 511   (or nomes (message "Reconstructing entity alist...done")))
 512
 513
 514 (defun wl-fldmgr-cut-region ()
 515   (interactive)
 516   (let* ((p1 (region-beginning))
 517          (p2 (region-end))
 518          (r1 (progn
 519                (goto-char p1)
 520                (beginning-of-line)
 521                (point)))
 522          (r2 (progn
 523                (goto-char p2)
 524                (beginning-of-line)
 525                (point)))
 526          (from (min r1 r2))
 527          (to (max r1 r2))
 528          (count 0)
 529          (errmes nil)
 530          (cut-list nil)
 531          name pre-indent indent)
 532     (catch 'err
 533       (save-excursion
 534         (goto-char from)
 535         (and (looking-at "^\\([ ]*\\)")
 536              (setq pre-indent (wl-match-buffer 1)))
 537         (while (< (point) to)
 538           (and (looking-at "^\\([ ]*\\)")
 539                (setq indent (wl-match-buffer 1)))
 540           (cond ((= (length pre-indent) (length indent))
 541                  (setq pre-indent indent)
 542                  (setq count (1+ count))
 543                  (and (setq name (wl-folder-get-entity-from-buffer))
 544                       (wl-append cut-list (list name)))
 545                  (forward-line 1))
 546                 ((< (length pre-indent) (length indent))
 547                  (wl-folder-goto-bottom-of-current-folder pre-indent)
 548                  (beginning-of-line))
 549                 (t
 550                  (setq errmes "bad region")
 551                  (throw 'err t))))
 552         (unless (eq (point) to)
 553           (setq errmes "bad region")
 554           (throw 'err t)))
 555       (save-excursion
 556         (let ((count2 (length cut-list))
 557               tmp path ent diffs)
 558           (goto-char from)
 559           (save-excursion
 560             (wl-folder-next-entity-skip-invalid t)
 561             (setq tmp (wl-fldmgr-get-path-from-buffer)))
 562           (setq path (car tmp))
 563           (setq diffs
 564                 (wl-delete-entity path cut-list wl-folder-entity))
 565           (catch 'done
 566             (while (> count 0)
 567               (setq ent (looking-at wl-folder-entity-regexp))
 568               (if (not (wl-fldmgr-cut (and ent tmp)
 569                                       (and ent (pop cut-list))))
 570                   (throw 'done nil))
 571               (setq count (1- count))))
 572           (if (> count2 0)
 573               (wl-push count2 wl-fldmgr-cut-entity-list))
 574           (if diffs
 575               (wl-fldmgr-update-group path diffs))
 576           t))
 577       (throw 'err nil))
 578     (if errmes
 579         (message "%s" errmes))))
 580
 581 (defun wl-fldmgr-cut (&optional tmp entity clear)
 582   (interactive)
 583   (save-excursion
 584     (beginning-of-line)
 585     (let ((ret-val nil)
 586           (inhibit-read-only t)
 587           path diffs)
 588       (if (bobp)
 589           (message "Can't remove desktop group")
 590         (or tmp (setq tmp (wl-fldmgr-get-path-from-buffer)))
 591         (setq path (car tmp))
 592         (if (not path)
 593             (if (not (eobp))
 594                 (wl-fldmgr-delete-line))   ;; unsubscribe or removed folder
 595           (if (not entity)
 596               (setq diffs
 597                     (wl-delete-entity path nil wl-folder-entity clear)))
 598           (setq wl-fldmgr-modified t)
 599           ;;
 600           (if (and (wl-folder-buffer-group-p)
 601                    (looking-at wl-folder-group-regexp))
 602               ;; group
 603               (let (beg end indent opened)
 604                 (setq indent (wl-match-buffer 1))
 605                 (setq opened (wl-match-buffer 2))
 606                 (if (string= opened "+")
 607                     (wl-fldmgr-delete-line)
 608                   (setq beg (point))
 609                   (end-of-line)
 610                   (save-match-data
 611                     (setq end
 612                           (progn
 613                             (wl-folder-goto-bottom-of-current-folder indent)
 614                             (beginning-of-line)
 615                             (point))))
 616                   (delete-region beg end)))
 617             ;; entity
 618             (wl-fldmgr-delete-line))
 619           (if diffs
 620               (wl-fldmgr-update-group path diffs))
 621           (set-buffer-modified-p nil))
 622         (setq ret-val t))
 623       ret-val)))
 624
 625 (defun wl-fldmgr-copy-region ()
 626   (interactive)
 627   (let* ((p1 (region-beginning))
 628          (p2 (region-end))
 629          (r1 (progn
 630                (goto-char p1)
 631                (beginning-of-line)
 632                (point)))
 633          (r2 (progn
 634                (goto-char p2)
 635                (beginning-of-line)
 636                (point)))
 637          (from (min r1 r2))
 638          (to (max r1 r2))
 639          (errmes nil)
 640          (cut-list nil)
 641          (count 0)
 642          name
 643          pre-indent indent)
 644     (catch 'err
 645       (save-excursion
 646         (goto-char from)
 647         (when (bobp)
 648           (setq errmes "can't copy desktop group")
 649           (throw 'err t))
 650         (and (looking-at "^\\([ ]*\\)")
 651              (setq pre-indent (wl-match-buffer 1)))
 652         (while (< (point) to)
 653           (and (looking-at "^\\([ ]*\\)")
 654                (setq indent (wl-match-buffer 1)))
 655           (if (wl-folder-buffer-group-p)
 656               (progn
 657                 (setq errmes "can't copy group folder")
 658                 (throw 'err t)))
 659           (cond ((= (length pre-indent) (length indent))
 660                  (if (setq name (wl-folder-get-entity-from-buffer))
 661                      (progn
 662                        (setq pre-indent indent)
 663                        (wl-push name cut-list)))
 664                  (forward-line 1))
 665                 ((< (length pre-indent) (length indent))
 666                  (wl-folder-goto-bottom-of-current-folder pre-indent)
 667                  (beginning-of-line))
 668                 (t
 669                  (setq errmes "bad region")
 670                  (throw 'err t))))
 671         (unless (eq (point) to)
 672           (setq errmes "bad region")
 673           (throw 'err t)))
 674       (catch 'done
 675         (setq cut-list (reverse cut-list))
 676         (while cut-list
 677           (setq name (pop cut-list))
 678           (unless (wl-fldmgr-copy name)
 679             (throw 'done nil))
 680           (setq count (1+ count)))
 681         (wl-push count wl-fldmgr-cut-entity-list)
 682         (message "Copy %s folders" count)
 683         (throw 'err nil)))
 684     (if errmes
 685         (message "%s" errmes))))
 686
 687 (defun wl-fldmgr-copy (&optional ename)
 688   (interactive "P")
 689   (save-excursion
 690     (beginning-of-line)
 691     (let ((ret-val nil))
 692       (if (and (not ename)
 693                (wl-folder-buffer-group-p))
 694           (message "Can't copy group folder")
 695         (let* ((name (or ename (wl-folder-get-entity-from-buffer)))
 696                (entity (elmo-string name)))
 697           (when name
 698             (if (member entity wl-fldmgr-cut-entity-list)
 699                 (setq wl-fldmgr-cut-entity-list
 700                       (delete entity wl-fldmgr-cut-entity-list)))
 701             (wl-push entity wl-fldmgr-cut-entity-list)
 702             (or ename
 703                 (message "Copy: %s" name))
 704             (setq ret-val t))))
 705       ret-val)))
 706
 707 (defun wl-fldmgr-yank ()
 708   (interactive)
 709   (save-excursion
 710     (beginning-of-line)
 711     (if (bobp)
 712         (message "Can't insert in the out of desktop group")
 713       (let ((inhibit-read-only t)
 714             (top (car wl-fldmgr-cut-entity-list))
 715             tmp indent path count new
 716             access new-list diffs)
 717         (if (not top)
 718             (message "No cut buffer")
 719           (setq tmp (wl-fldmgr-get-path-from-buffer t))
 720           (setq path (car tmp))
 721           (setq indent (wl-fldmgr-make-indent (nth 1 tmp)))
 722           (if (numberp top)
 723               (setq count (pop wl-fldmgr-cut-entity-list))
 724             (setq count 1))
 725           (if (catch 'err
 726                 (let ((count count)
 727                       (cut-list wl-fldmgr-cut-entity-list))
 728                   ;; check insert entity
 729                   (while (> count 0)
 730                     (setq new (car cut-list))
 731                     (wl-push new new-list)
 732                     (when (consp new);; group
 733                       (cond
 734                        (access
 735                         (message "Can't insert group in access")
 736                         (throw 'err t))
 737                        ((wl-string-assoc (car new) wl-folder-group-alist)
 738                         (message "%s: group already exists" (car new))
 739                         (throw 'err t))))
 740                     (setq cut-list (cdr cut-list))
 741                     (setq count (1- count))))
 742                 (if (not (setq diffs
 743                                (wl-add-entity
 744                                 path new-list wl-folder-entity (nth 3 tmp) t)))
 745                     (throw 'err t))
 746                 (while (> count 0)
 747                   (setq new (pop wl-fldmgr-cut-entity-list))
 748                   (save-excursion
 749                     (wl-folder-insert-entity indent new)
 750                     (setq wl-fldmgr-modified t))
 751                   (setq count (1- count)))
 752                 (wl-fldmgr-update-group path diffs)
 753                 (set-buffer-modified-p nil))
 754               ;; error
 755               (wl-push count wl-fldmgr-cut-entity-list)))))))
 756
 757 (defvar wl-fldmgr-add-completion-hashtb (make-vector 7 0))
 758
 759 (defun wl-fldmgr-add-completion-all-completions (string)
 760   (let ((table
 761          (catch 'found
 762            (mapatoms
 763             (function
 764              (lambda (atom)
 765                (if (string-match (symbol-name atom) string)
 766                    (throw 'found (symbol-value atom)))))
 767             wl-fldmgr-add-completion-hashtb)))
 768         (pattern
 769          (if (string-match "\\.$"
 770                            (elmo-folder-prefix-internal
 771                             (wl-folder-get-elmo-folder string)))
 772              (substring string 0 (match-beginning 0))
 773            (concat string nil))))
 774     (or table
 775         (setq table (elmo-folder-list-subfolders
 776                      (wl-folder-get-elmo-folder pattern)))
 777         (and table
 778              (or (/= (length table) 1)
 779                  (elmo-folder-exists-p (wl-folder-get-elmo-folder
 780                                         (car table)))))
 781         (setq pattern
 782               (if (string-match "\\.[^\\.]+$" string)
 783                   (substring string 0 (match-beginning 0))
 784                 (char-to-string (aref string 0)))
 785               table (elmo-folder-list-subfolders
 786                      (wl-folder-get-elmo-folder pattern))))
 787     (setq pattern (concat "^" (regexp-quote pattern)))
 788     (unless (intern-soft pattern wl-fldmgr-add-completion-hashtb)
 789       (set (intern pattern wl-fldmgr-add-completion-hashtb) table))
 790     table))
 791
 792 (defun wl-fldmgr-add-completion-subr (string predicate flag)
 793   (let ((table
 794          (if (string= string "")
 795              (mapcar (function (lambda (spec)
 796                                  (list (char-to-string (car spec)))))
 797                      elmo-folder-type-alist)
 798            (when (assq (aref string 0) elmo-folder-type-alist)
 799              (delq nil (mapcar
 800                         (function list)
 801                         (condition-case nil
 802                             (wl-fldmgr-add-completion-all-completions string)
 803                           (error nil))))))))
 804     (cond
 805      ((null flag)
 806       (try-completion string table predicate))
 807      ((eq flag 'lambda)
 808       (eq t (try-completion string table predicate)))
 809      (t
 810       (all-completions string table predicate)))))
 811
 812 (defun wl-fldmgr-add (&optional name)
 813   (interactive)
 814   (save-excursion
 815     (beginning-of-line)
 816     (let ((ret-val nil)
 817           (inhibit-read-only t)
 818           (wl-folder-complete-folder-candidate
 819            (if wl-fldmgr-add-complete-with-current-folder-list
 820                (function wl-fldmgr-add-completion-subr)))
 821           tmp indent path diffs)
 822       (if (bobp)
 823           (message "Can't insert in the out of desktop group")
 824         (setq tmp (wl-fldmgr-get-path-from-buffer t))
 825         (setq path (car tmp))
 826         (setq indent (wl-fldmgr-make-indent (nth 1 tmp)))
 827         (or name
 828             (setq name (wl-fldmgr-read-string
 829                         (wl-summary-read-folder wl-default-folder "to add"))))
 830         ;; maybe add elmo-plugged-alist.
 831         (elmo-folder-set-plugged (wl-folder-get-elmo-folder
 832                                   (if (listp name) (car name) name))
 833                                  wl-plugged t)
 834         (when (setq diffs
 835                     (wl-add-entity
 836                      path (list name) wl-folder-entity (nth 3 tmp) t))
 837           (wl-folder-insert-entity indent name)
 838           (wl-fldmgr-update-group path diffs)
 839           (setq wl-fldmgr-modified t)
 840           (set-buffer-modified-p nil)
 841           (setq ret-val t)))
 842       ret-val)))
 843
 844 (defun wl-fldmgr-delete ()
 845   (interactive)
 846   (save-excursion
 847     (beginning-of-line)
 848     (if (wl-folder-buffer-group-p)
 849         (error "Can't delete group folder"))
 850     (let* ((inhibit-read-only t)
 851            (tmp (wl-fldmgr-get-path-from-buffer))
 852            (entity (elmo-string (nth 4 tmp)))
 853            (folder (wl-folder-get-elmo-folder entity)))
 854       (when (elmo-folder-delete folder)
 855         (wl-fldmgr-cut tmp nil t)))))
 856
 857 (defun wl-fldmgr-rename ()
 858   (interactive)
 859   (save-excursion
 860     (beginning-of-line)
 861     (if (bobp)
 862         (message "Can't rename desktop group")
 863       (cond
 864        ((and (wl-folder-buffer-group-p)
 865              (looking-at wl-folder-group-regexp)) ;; group
 866         (let* ((indent (wl-match-buffer 1))
 867                (old-group (wl-folder-get-entity-from-buffer))
 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           (unless old-folder (error "No folder"))
 904           (setq new-folder
 905                 (wl-fldmgr-read-string
 906                  (wl-summary-read-folder old-folder "to rename" t t old-folder)))
 907           (if (or (wl-folder-entity-exists-p new-folder)
 908                   (file-exists-p (elmo-folder-msgdb-path
 909                                   (wl-folder-get-elmo-folder new-folder))))
 910               (error "Already exists folder: %s" new-folder))
 911           (if (and (eq (cdr (nth 2 tmp)) 'access)
 912                    (null wl-fldmgr-allow-rename-access-group)
 913                    (null (string-match
 914                           (format "^%s" (regexp-quote (car (nth 2 tmp))))
 915                           new-folder)))
 916               (error "Can't rename access folder"))
 917           (elmo-folder-rename (wl-folder-get-elmo-folder old-folder)
 918                               new-folder)
 919           (wl-folder-set-entity-info
 920            new-folder
 921            (wl-folder-get-entity-info old-folder))
 922           (wl-folder-clear-entity-info old-folder)
 923           (if (eq (cdr (nth 2 tmp)) 'access)
 924
 925               ;; force update access group
 926               (progn
 927                 (wl-folder-open-close)
 928                 (wl-folder-jump-to-current-entity t)
 929                 (message "%s is renamed to %s" old-folder new-folder)
 930                 (sit-for 1))
 931             ;; update folder list
 932             (when (wl-fldmgr-cut tmp nil t)
 933               (wl-fldmgr-add new-folder)))))))))
 934
 935 (defun wl-fldmgr-make-access-group ()
 936   (interactive)
 937   (wl-fldmgr-make-group nil t))
 938
 939 (defun wl-fldmgr-make-group (&optional group-name access)
 940   (interactive)
 941   (save-excursion
 942     (beginning-of-line)
 943     (if (bobp)
 944         (message "Can't insert in the out of desktop group")
 945       (let ((inhibit-read-only t)
 946             (type 'group)
 947             group tmp indent path new prev-id flist diffs)
 948         (setq tmp (wl-fldmgr-get-path-from-buffer t))
 949         (setq path (car tmp))
 950         (setq indent (wl-fldmgr-make-indent (nth 1 tmp)))
 951         (setq prev-id (nth 3 tmp))
 952         (if (eq (cdr (nth 2 tmp)) 'access)
 953             (message "Can't insert access group")
 954           (setq group (or group-name
 955                           (wl-fldmgr-read-string
 956                            (read-from-minibuffer
 957                             (if access "Access Type Group: " "Group: ")))))
 958           ;; To check the folder name is correct.
 959           (if access (elmo-make-folder group))
 960           (when (or access (string-match "[\t ]*/$" group))
 961             (setq group (if access group
 962                           (substring group 0 (match-beginning 0))))
 963             (setq type 'access)
 964             (setq flist (wl-create-access-folder-entity group)))
 965           (if (string= group "")
 966               nil
 967             (if (wl-string-assoc group wl-folder-group-alist)
 968                 (message "%s: group already exists" group)
 969               (setq new (append (list group type) flist))
 970               (when (setq diffs (wl-add-entity path
 971                                                (list new)
 972                                                wl-folder-entity
 973                                                prev-id))
 974                 (wl-folder-insert-entity indent new)
 975                 (wl-fldmgr-update-group path diffs)
 976                 (setq wl-fldmgr-modified t)
 977                 (set-buffer-modified-p nil)))))))))
 978
 979 (defun wl-fldmgr-make-multi ()
 980   (interactive)
 981   (if (not wl-fldmgr-cut-entity-list)
 982       (message "No cut buffer")
 983     (let ((cut-entity wl-fldmgr-cut-entity-list)
 984           (new-entity "")
 985           (first t)
 986           status)
 987       (setq status
 988             (catch 'done
 989               (while cut-entity
 990                 (cond
 991                  ((numberp (car cut-entity))
 992                   nil)
 993                  ((consp (car cut-entity))
 994                   (message "Can't make multi included group folder")
 995                   (throw 'done nil))
 996                  (t
 997                   (let ((folder (wl-folder-get-elmo-folder
 998                                  (car cut-entity)))
 999                         multi-fld)
1000                     (if (eq (elmo-folder-type-internal folder) 'multi)
1001                         (setq multi-fld
1002                               (substring (car cut-entity) 1)))
1003                     (setq new-entity
1004                           (format "%s%s%s"
1005                                   (or multi-fld (car cut-entity))
1006                                   (if first "" ",")
1007                                   new-entity))
1008                     (setq first nil))))
1009                 (setq cut-entity (cdr cut-entity)))
1010               (throw 'done t)))
1011       (when status
1012         (setq new-entity (concat "*" new-entity))
1013         (wl-fldmgr-add new-entity)))))
1014
1015 (defun wl-fldmgr-make-filter ()
1016   (interactive)
1017   (save-excursion
1018     (beginning-of-line)
1019     (let ((tmp (wl-fldmgr-get-path-from-buffer))
1020           entity)
1021       (if (eq (cdr (nth 2 tmp)) 'access)
1022           (message "Can't change access group")
1023         (if (wl-folder-buffer-group-p)
1024             (setq entity
1025                   (concat
1026                    "*"
1027                    (mapconcat 'identity
1028                               (wl-folder-get-entity-list
1029                                (wl-folder-search-group-entity-by-name
1030                                 (nth 4 tmp)
1031                                 wl-folder-entity)) ",")))
1032           (setq entity (nth 4 tmp)))
1033         (unless entity (error "No folder"))
1034         (wl-fldmgr-add (concat "/"
1035                                (elmo-read-search-condition
1036                                 wl-fldmgr-make-filter-default)
1037                                "/" entity))))))
1038
1039 (defun wl-fldmgr-sort (&optional arg)
1040   (interactive "P")
1041   (save-excursion
1042     (beginning-of-line)
1043     (let ((inhibit-read-only t)
1044           entity flist indent opened)
1045       (when (and (wl-folder-buffer-group-p)
1046                  (looking-at wl-folder-group-regexp))
1047         (setq indent (wl-match-buffer 1))
1048         (setq opened (wl-match-buffer 2))
1049         (setq entity (wl-folder-search-group-entity-by-name
1050                       (wl-folder-get-entity-from-buffer)
1051                       wl-folder-entity))
1052         (message "Sorting...")
1053         (setq flist (sort (nth 2 entity) wl-fldmgr-sort-function))
1054         (when arg (setq flist (nreverse flist)))
1055         (setcar (cddr entity) flist)
1056         (wl-fldmgr-add-modified-access-list (car entity))
1057         (setq wl-fldmgr-modified t)
1058         (when (string= opened "-")
1059           (let (beg end)
1060             (setq beg (point))
1061             (end-of-line)
1062             (save-match-data
1063               (setq end
1064                     (progn
1065                       (wl-folder-goto-bottom-of-current-folder indent)
1066                       (beginning-of-line)
1067                       (point))))
1068             (delete-region beg end)
1069             (wl-folder-insert-entity indent entity)))
1070         (message "Sorting...done")
1071         (set-buffer-modified-p nil)))))
1072
1073 (defun wl-fldmgr-sort-standard (x y)
1074   (cond ((and (consp x) (not (consp y)))
1075          wl-fldmgr-sort-group-first)
1076         ((and (not (consp x)) (consp y))
1077          (not wl-fldmgr-sort-group-first))
1078         ((and (consp x) (consp y))
1079          (string-lessp (car x) (car y)))
1080         (t
1081          (string-lessp x y))))
1082
1083 (defun wl-fldmgr-subscribe-region ()
1084   (interactive)
1085   (wl-fldmgr-unsubscribe-region -1))
1086
1087 (defun wl-fldmgr-unsubscribe-region (&optional arg)
1088   (interactive "P")
1089   (let* ((p1 (region-beginning))
1090          (p2 (region-end))
1091          (r1 (progn
1092                (goto-char p1)
1093                (beginning-of-line)
1094                (point)))
1095          (r2 (progn
1096                (goto-char p2)
1097                (beginning-of-line)
1098                (point)))
1099          (from (min r1 r2))
1100          (to (max r1 r2))
1101          (count 0))
1102     (goto-char from)
1103     (while (< (point) to)
1104       (setq count (1+ count))
1105       (forward-line))
1106     (goto-char from)
1107     (message "Unsubscribe region...")
1108     (while (and (> count 0)
1109                 (wl-fldmgr-unsubscribe (or arg 1) t))
1110       (setq count (1- count)))
1111     (message "Unsubscribe region...done")))
1112
1113 (defun wl-fldmgr-subscribe ()
1114   (interactive)
1115   (wl-fldmgr-unsubscribe -1))
1116
1117 (defun wl-fldmgr-unsubscribe (&optional arg force)
1118   (interactive "P")
1119   (let ((type (and arg (prefix-numeric-value arg)))
1120         execed is-group)
1121     (save-excursion
1122       (beginning-of-line)
1123       (let ((inhibit-read-only t)
1124             folder
1125             tmp indent beg)
1126         (cond
1127          ((looking-at (format "^[ ]*%s\\[[+-]\\]\\(.*\\)" wl-folder-unsubscribe-mark))
1128           (if (and type (> type 0))
1129               nil
1130             (setq folder (list (wl-match-buffer 1) 'access nil))
1131             (if (wl-string-assoc (car folder) wl-folder-group-alist)
1132                 (message "%s: group already exists" (car folder))
1133               (wl-fldmgr-delete-line)
1134               (when (wl-fldmgr-add folder)
1135                 (wl-folder-maybe-load-folder-list folder)
1136 ;;;             (wl-folder-search-group-entity-by-name (car folder)
1137 ;;;                                                    wl-folder-entity)
1138                 (setq execed t)))))
1139          ((looking-at (format "^[ ]*%s\\(.*\\)" wl-folder-unsubscribe-mark))
1140           (if (and type (> type 0))
1141               nil
1142             (setq folder (wl-match-buffer 1))
1143             (wl-fldmgr-delete-line)
1144             (when (wl-fldmgr-add folder)
1145               (setq execed t))))
1146          (t
1147           (if (and type (< type 0))
1148               nil
1149             (setq is-group (wl-folder-buffer-group-p))
1150             (setq tmp (wl-fldmgr-get-path-from-buffer))
1151             (setq indent (wl-fldmgr-make-indent (nth 1 tmp)))
1152             (if (eq (cdr (nth 2 tmp)) 'access)
1153                 (when (wl-fldmgr-cut tmp)
1154                   (pop wl-fldmgr-cut-entity-list)  ;; don't leave cut-list
1155                   (setq beg (point))
1156                   (insert indent wl-folder-unsubscribe-mark
1157                           (if is-group
1158                               (concat "[+]" (nth 4 tmp))
1159                             (nth 4 tmp))
1160                           "\n")
1161                   (save-excursion (forward-line -1)
1162                                   (wl-highlight-folder-current-line))
1163                   (remove-text-properties beg (point) '(wl-folder-entity-id))
1164                   (setq execed t))))))
1165         (set-buffer-modified-p nil)))
1166     (if (or force execed)
1167         (progn
1168           (forward-line)
1169           t))))
1170
1171 (defun wl-fldmgr-access-display-normal (&optional arg)
1172   (interactive "P")
1173   (wl-fldmgr-access-display-all (not arg)))
1174
1175 (defun wl-fldmgr-access-display-all (&optional arg)
1176   (interactive "P")
1177   (let ((id (save-excursion
1178               (wl-folder-prev-entity-skip-invalid t)
1179               (wl-fldmgr-get-entity-id))))
1180     (save-excursion
1181     (beginning-of-line)
1182     (let ((inhibit-read-only t)
1183           entity indent opened
1184           unsubscribes beg)
1185       (when (not
1186              (and (wl-folder-buffer-group-p)
1187                   (looking-at wl-folder-group-regexp)))
1188         (wl-folder-goto-top-of-current-folder)
1189         (looking-at wl-folder-group-regexp))
1190       (setq indent (wl-match-buffer 1))
1191       (setq opened (wl-match-buffer 2))
1192       (setq entity (wl-folder-search-group-entity-by-name
1193                     (wl-folder-get-entity-from-buffer)
1194                     wl-folder-entity))
1195       (when (eq (nth 1 entity) 'access)
1196         (save-excursion
1197           (if (string= opened "-")
1198               (let (beg end)
1199                 (setq beg (point))
1200                 (end-of-line)
1201                 (save-match-data
1202                   (setq end
1203                         (progn
1204                           (wl-folder-goto-bottom-of-current-folder indent)
1205                           (beginning-of-line)
1206                           (point))))
1207                 (delete-region beg end))
1208             (wl-fldmgr-delete-line)
1209             (setcdr (assoc (car entity) wl-folder-group-alist) t));; set open
1210           (wl-folder-insert-entity indent entity))
1211         (when (not arg)
1212           (setq unsubscribes (nth 3 entity))
1213           (forward-line)
1214           (while unsubscribes
1215             (setq beg (point))
1216             (insert indent "  " wl-folder-unsubscribe-mark
1217                     (if (consp (car unsubscribes))
1218                         (concat "[+]" (caar unsubscribes))
1219                       (car unsubscribes))
1220                     "\n")
1221             (remove-text-properties beg (point) '(wl-folder-entity-id))
1222             (save-excursion (forward-line -1)
1223                             (wl-highlight-folder-current-line))
1224             (setq unsubscribes (cdr unsubscribes))))
1225         (set-buffer-modified-p nil))))
1226     (wl-folder-move-path id)))
1227
1228 (defun wl-fldmgr-set-petname ()
1229   (interactive)
1230   (save-excursion
1231     (beginning-of-line)
1232       (let* ((is-group (wl-folder-buffer-group-p))
1233              (name (wl-folder-get-entity-from-buffer))
1234              (searchname (wl-folder-get-petname name))
1235              (pentry (wl-string-assoc name wl-folder-petname-alist))
1236              (old-petname (or (cdr pentry) ""))
1237              (change)
1238              petname)
1239         (unless name (error "No folder"))
1240         (if (and is-group
1241                  (not (eq (nth 1 (wl-folder-search-group-entity-by-name
1242                                   name wl-folder-entity))
1243                           'access)))
1244             (message "Can't set petname. please rename.")
1245         (setq petname (wl-fldmgr-read-string
1246                        (read-from-minibuffer "Petname: " old-petname)))
1247         (cond
1248          ((string= petname "")
1249           (when pentry
1250             (setq wl-folder-petname-alist
1251                   (delete pentry wl-folder-petname-alist))
1252             (setq change t)))
1253          (t
1254           (if (string= petname old-petname)
1255               nil
1256             (if (or (rassoc petname wl-folder-petname-alist)
1257                     (wl-string-assoc petname wl-folder-group-alist))
1258                 (message "%s: already exists" petname)
1259               (wl-folder-append-petname name petname)
1260               (setq change t)))))
1261         (when change
1262           (let ((inhibit-read-only t)
1263                 indent)
1264             (goto-char (point-min))
1265             (if is-group
1266                 (progn
1267                   (if (string= old-petname "")
1268                       (setq old-petname name))
1269                   (while (wl-folder-buffer-search-group old-petname)
1270                     (beginning-of-line)
1271                     (and (looking-at "^\\([ ]*\\)")
1272                          (setq indent (wl-match-buffer 1)))
1273                     (wl-fldmgr-delete-line)
1274                     (wl-folder-insert-entity
1275                      indent
1276                      (wl-folder-search-group-entity-by-name
1277                       name wl-folder-entity)
1278                      t)))
1279               (while (wl-folder-buffer-search-entity name searchname)
1280                 (save-excursion
1281                   (beginning-of-line)
1282                   (and (looking-at "^\\([ ]*\\)")
1283                        (setq indent (wl-match-buffer 1)))
1284                   (wl-fldmgr-delete-line))
1285                 (wl-folder-insert-entity indent name)))
1286             (setq wl-fldmgr-modified t)
1287             (set-buffer-modified-p nil)))))))
1288
1289 ;;; Function for save folders
1290 ;;
1291
1292 (defun wl-fldmgr-insert-folders-buffer (indent entities &optional pet-entities)
1293   (let ((flist entities)
1294         name petname)
1295     (while flist
1296       (setq name (car flist))
1297       (cond ((stringp name)
1298              (if (setq petname (cdr (wl-string-assoc name wl-folder-petname-alist)))
1299                  (wl-append pet-entities (list name)))
1300              (insert indent name
1301                      (if petname
1302                          (concat "\t\"" petname "\"")
1303                        "")
1304                      "\n"))
1305             ((consp name)
1306              (let ((group (car name))
1307                    (type (nth 1 name)))
1308                (cond ((eq type 'group)
1309                       (insert indent group "{\n")
1310                       (setq pet-entities
1311                             (wl-fldmgr-insert-folders-buffer
1312                              (concat indent wl-fldmgr-folders-indent)
1313                              (nth 2 name) pet-entities))
1314                       (insert indent "}\n"))
1315                      ((eq type 'access)
1316                       (insert indent group "/\n"))))))
1317       (setq flist (cdr flist))))
1318   pet-entities)
1319
1320 (defun wl-fldmgr-insert-petname-buffer (pet-entities)
1321   (let ((alist wl-folder-petname-alist))
1322     (while alist
1323       (if (wl-string-member (caar alist) pet-entities)
1324           nil
1325         (insert "=\t" (caar alist) "\t\"" (cdar alist) "\"\n"))
1326       (setq alist (cdr alist)))))
1327
1328 (defun wl-fldmgr-delete-disused-petname ()
1329   (let ((alist wl-folder-petname-alist))
1330     (while alist
1331       (unless (wl-folder-search-entity-by-name (caar alist) wl-folder-entity)
1332         (setq wl-folder-petname-alist
1333               (delete (car alist) wl-folder-petname-alist)))
1334       (setq alist (cdr alist)))))
1335
1336 (defun wl-fldmgr-save-folders ()
1337   (interactive)
1338   (let ((tmp-buf (get-buffer-create " *wl-fldmgr-tmp*"))
1339         (access-list wl-fldmgr-modified-access-list)
1340         entity
1341         save-petname-entities)
1342     (message "Saving folders...")
1343     (set-buffer tmp-buf)
1344     (erase-buffer)
1345     (insert wl-fldmgr-folders-header)
1346     (wl-fldmgr-delete-disused-petname)
1347     (setq save-petname-entities
1348           (wl-fldmgr-insert-folders-buffer "" (nth 2 wl-folder-entity)))
1349     (insert "\n# petname definition (access group, folder in access group)\n")
1350     (wl-fldmgr-insert-petname-buffer save-petname-entities)
1351     (insert "\n# end of file.\n")
1352     (if (and wl-fldmgr-make-backup
1353              (file-exists-p wl-folders-file))
1354         (rename-file wl-folders-file (concat wl-folders-file ".bak") t))
1355     (let ((output-coding-system (mime-charset-to-coding-system
1356                                  wl-mime-charset)))
1357       (write-region
1358        (point-min)
1359        (point-max)
1360        wl-folders-file
1361        nil
1362        'no-msg)
1363       (set-file-modes wl-folders-file (+ (* 64 6) (* 8 0) 0))) ; chmod 0600
1364     (kill-buffer tmp-buf)
1365     (while access-list
1366       (setq entity (wl-folder-search-group-entity-by-name
1367                     (car access-list) wl-folder-entity))
1368       (elmo-msgdb-flist-save
1369        (car access-list)
1370        (list
1371         (wl-folder-make-save-access-list (nth 2 entity))
1372         (wl-folder-make-save-access-list (nth 3 entity))))
1373       (setq access-list (cdr access-list)))
1374     (setq wl-fldmgr-modified nil)
1375     (setq wl-fldmgr-modified-access-list nil)
1376     (message "Saving folders...done")))
1377
1378 (require 'product)
1379 (product-provide (provide 'wl-fldmgr) (require 'wl-version))
1380
1381 ;;; wl-fldmgr.el ends here