1 ;;; wl-fldmgr.el -- Folder manager for Wanderlust.
3 ;; Copyright 1998,1999,2000 Masahiro MURATA <muse@ba2.so-net.ne.jp>
4 ;; Yuuichi Teranishi <teranisi@gohome.org>
6 ;; Author: Masahiro MURATA <muse@ba2.so-net.ne.jp>
7 ;; Keywords: mail, net news
9 ;; This file is part of Wanderlust (Yet Another Message Interface on Emacsen).
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)
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.
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.
35 (require 'wl-highlight)
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)
48 (defconst wl-fldmgr-folders-header
51 # Folder definition file
52 # This file is generated automatically by %s.
59 (defvar wl-fldmgr-mode-map nil)
60 (if wl-fldmgr-mode-map
62 (define-prefix-command 'wl-fldmgr-mode-map)
63 (define-key wl-fldmgr-mode-map "\C-s" 'wl-fldmgr-save-folders)
64 (define-key wl-fldmgr-mode-map "m" 'wl-fldmgr-make-multi)
65 (define-key wl-fldmgr-mode-map "g" 'wl-fldmgr-make-group)
66 (define-key wl-fldmgr-mode-map "A" 'wl-fldmgr-make-access-group)
67 (define-key wl-fldmgr-mode-map "f" 'wl-fldmgr-make-filter)
68 (define-key wl-fldmgr-mode-map "p" 'wl-fldmgr-set-petname)
69 (define-key wl-fldmgr-mode-map "a" 'wl-fldmgr-add)
70 (define-key wl-fldmgr-mode-map "d" 'wl-fldmgr-delete)
71 (define-key wl-fldmgr-mode-map "R" 'wl-fldmgr-rename)
72 (define-key wl-fldmgr-mode-map "c" 'wl-fldmgr-copy)
73 (define-key wl-fldmgr-mode-map "k" 'wl-fldmgr-cut)
74 (define-key wl-fldmgr-mode-map "W" 'wl-fldmgr-copy-region)
75 (define-key wl-fldmgr-mode-map "\C-w" 'wl-fldmgr-cut-region)
76 (define-key wl-fldmgr-mode-map "y" 'wl-fldmgr-yank)
77 (define-key wl-fldmgr-mode-map "s" 'wl-fldmgr-sort)
78 (define-key wl-fldmgr-mode-map "l" 'wl-fldmgr-access-display-normal)
79 (define-key wl-fldmgr-mode-map "L" 'wl-fldmgr-access-display-all)
80 (define-key wl-fldmgr-mode-map "q" 'wl-fldmgr-clear-cut-entity-list)
81 (define-key wl-fldmgr-mode-map "r" 'wl-fldmgr-reconst-entity-hashtb)
82 (define-key wl-fldmgr-mode-map "u" 'wl-fldmgr-unsubscribe)
83 (define-key wl-fldmgr-mode-map "U" 'wl-fldmgr-unsubscribe-region))
85 (add-hook 'wl-folder-mode-hook 'wl-fldmgr-init)
87 (defun wl-fldmgr-init ()
88 (setq wl-fldmgr-cut-entity-list nil)
89 (setq wl-fldmgr-modified nil)
90 (setq wl-fldmgr-modified-access-list nil))
92 (defun wl-fldmgr-exit ()
93 (when (and wl-fldmgr-modified
94 (or (not wl-interactive-save-folders)
95 (y-or-n-p "Folder view was modified. Save current folders? ")))
96 (wl-fldmgr-save-folders)))
98 ;;; Macro and misc Function
101 (defmacro wl-fldmgr-delete-line ()
102 (` (delete-region (save-excursion (beginning-of-line)
104 (save-excursion (end-of-line)
107 (defmacro wl-fldmgr-make-indent (level)
108 (` (concat " " (make-string (* 2 (, level)) ? ))))
110 (defmacro wl-fldmgr-get-entity-id (&optional entity)
111 (` (get-text-property (if (, entity)
117 (defmacro wl-fldmgr-assign-id (entity &optional id)
118 (` (let ((entity-id (or (, id) wl-folder-entity-id)))
119 (put-text-property 0 (length (, entity))
124 (defsubst wl-fldmgr-read-string (str)
125 (if (string-match "\n" str)
126 (error "Not supported name: %s" str)
129 (defsubst wl-fldmgr-add-modified-access-list (group)
130 (if (not (member group wl-fldmgr-modified-access-list))
131 (wl-append wl-fldmgr-modified-access-list (list group))))
133 (defsubst wl-fldmgr-delete-modified-access-list (group)
134 (if (member group wl-fldmgr-modified-access-list)
135 (setq wl-fldmgr-modified-access-list
136 (delete group wl-fldmgr-modified-access-list))))
138 (defsubst wl-fldmgr-add-group (group)
139 (or (assoc group wl-folder-group-alist)
140 (wl-append wl-folder-group-alist
142 wl-fldmgr-group-insert-opened)))))
144 (defsubst wl-fldmgr-delete-group (group)
145 (wl-fldmgr-delete-modified-access-list group)
146 (setq wl-folder-group-alist
147 (delete (assoc group wl-folder-group-alist)
148 wl-folder-group-alist)))
150 (defun wl-fldmgr-add-entity-hashtb (entities)
151 "Update `wl-folder-entity-hashtb', `wl-folder-newsgroups-hashtb'.
152 Return value is diffs '(new unread all)."
156 val entity entity-stack)
157 (setq wl-folder-newsgroups-hashtb
158 (or (wl-folder-create-newsgroups-hashtb entities t)
159 wl-folder-newsgroups-hashtb))
161 (setq entity (wl-pop entities))
164 (wl-fldmgr-add-group (car entity))
166 (wl-push entities entity-stack))
167 (setq entities (nth 2 entity)))
169 (if (not (setq val (wl-folder-get-entity-info entity)))
170 (wl-folder-set-entity-info entity nil)
171 (setq new-diff (+ new-diff (or (nth 0 val) 0)))
172 (setq unread-diff (+ unread-diff (or (nth 1 val) 0)))
173 (setq all-diff (+ all-diff (or (nth 2 val) 0))))))
175 (setq entities (wl-pop entity-stack))))
176 (setq unread-diff (+ unread-diff new-diff))
177 (list new-diff unread-diff all-diff)))
179 (defun wl-fldmgr-delete-entity-hashtb (entities &optional clear)
180 "Update `wl-folder-entity-hashtb'.
181 return value is diffs '(-new -unread -all)."
188 (setq entity (wl-pop entities))
191 (wl-fldmgr-delete-group (car entity))
193 (wl-push entities entity-stack))
194 (setq entities (nth 2 entity)))
196 (when (setq val (wl-folder-get-entity-info entity))
197 (setq new-diff (+ new-diff (or (nth 0 val) 0)))
198 (setq unread-diff (+ unread-diff (or (nth 1 val) 0)))
199 (setq all-diff (+ all-diff (or (nth 2 val) 0)))
200 (and clear (wl-folder-clear-entity-info entity)))))
202 (setq entities (wl-pop entity-stack))))
203 (setq unread-diff (+ unread-diff new-diff))
204 (list (- 0 new-diff) (- 0 unread-diff) (- 0 all-diff))))
207 ;; example: '(("Desktop" group) ("+ml" access) "+ml/wl")
209 (defun wl-fldmgr-get-path (entity target-entity &optional group-target)
210 (let* ((target-id (wl-fldmgr-get-entity-id target-entity))
211 (entities (list entity))
212 entity-stack result-path)
216 (setq entity (wl-pop entities))
219 (if (and (string= target-entity (car entity))
220 (eq target-id (wl-fldmgr-get-entity-id (car entity))))
222 (wl-push (if group-target
224 (list (car entity) (nth 1 entity)))
226 (wl-push (list (car entity) (nth 1 entity))
228 (wl-push entities entity-stack)
229 (setq entities (nth 2 entity)))
231 (if (and (string= target-entity entity)
232 (eq target-id (wl-fldmgr-get-entity-id entity)))
234 (wl-push entity result-path)))))
236 (while (and entity-stack
238 (setq result-path (cdr result-path))
239 (setq entities (wl-pop entity-stack)))))))))
241 ;; (defun wl-fldmgr-get-previous-entity (entity key-id)
242 ;; (cdr (wl-fldmgr-get-previous-entity-internal '(nil . nil) entity key-id)))
244 ;; (defun wl-fldmgr-get-previous-entity-internal (result entity key-id)
247 ;; (if (eq key-id (wl-fldmgr-get-entity-id entity))
249 ;; (cons nil (cons entity entity))))
251 ;; (if (eq key-id (wl-fldmgr-get-entity-id (car entity)))
253 ;; (setcar result (car entity))
254 ;; (let ((flist (nth 2 entity))
256 ;; (while (and flist (not found))
257 ;; (if (car (setq return
258 ;; (wl-fldmgr-get-previous-entity-internal
259 ;; result (car flist) key-id)))
261 ;; (setq result (cdr return))
262 ;; (setq flist (cdr flist)))
263 ;; (cons found result))))))
265 ;; path is get `wl-fldmgr-get-path-from-buffer'.
266 (defun wl-fldmgr-update-group (path diffs)
268 (while (and path (consp (car path)))
269 (if (string= (caar path) wl-folder-desktop-name) ; update desktop
271 (goto-char (point-min))
272 (wl-folder-update-diff-line diffs))
273 ;; goto the path line.
274 (goto-char (point-min))
275 (if (wl-folder-buffer-search-group
276 (wl-folder-get-petname (caar path)))
277 (wl-folder-update-diff-line diffs)))
278 (setq path (cdr path)))))
280 ;;; Function for wl-folder-entity
284 ;; (wl-delete-entity '(("Desktop") ("ML") "+ml/wl") '("+ml/wl") wl-folder-entity)
285 ;; (wl-delete-entity '(("Desktop") "ML") '("+inbox" "ML") wl-folder-entity)
286 ;; (wl-delete-entity '(("Desktop") "ML") nil wl-folder-entity)
288 (defun wl-delete-entity (key-path delete-list entity &optional clear)
289 (let (wl-fldmgr-entity-list)
290 (when (and (string= (caar key-path) (car entity))
291 (wl-delete-entity-sub (cdr key-path) delete-list entity clear))
292 ;; return value is non-nil (diffs)
293 (wl-fldmgr-delete-entity-hashtb wl-fldmgr-entity-list clear))))
295 (defun wl-delete-entity-sub (key-path delete-list entity clear)
296 (let ((flist (nth 2 entity))
300 ((consp key);; into group
301 (if (setq next (assoc (car key) flist))
302 (wl-delete-entity-sub (cdr key-path)
308 ((stringp key) ;; delete entities
309 (if (not delete-list)
310 (setq delete-list (list key)))
311 (let* ((group (car entity))
312 (access (eq (nth 1 entity) 'access))
313 (unsubscribes (and access (nth 3 entity)))
318 (setq key (car delete-list))
319 (cond ((member key flist);; entity
320 (setq flist (delete key flist))
322 (wl-push key wl-fldmgr-cut-entity-list))
323 (wl-append wl-fldmgr-entity-list (list key))
325 ((setq cut-entity (assoc key flist));; group
326 (setq flist (delete cut-entity flist))
328 (wl-push cut-entity wl-fldmgr-cut-entity-list))
329 (wl-append wl-fldmgr-entity-list (list cut-entity))
333 (message "%s not found" key)
338 (wl-append unsubscribes
339 (list (list (elmo-string key) 'access nil)))
340 (wl-append unsubscribes (list (elmo-string key)))))
341 (setq delete-list (cdr delete-list))))
343 (setcdr (cdr entity) (list flist unsubscribes))
345 (wl-fldmgr-add-modified-access-list group))
350 ;; (wl-add-entity '(("Desktop") ("ML") "ml/wl") '("+ml/new") wl-folder-entity 12)
351 ;; (wl-add-entity '(("Desktop") "ML") '("+ml/new") wl-folder-entity 10)
353 (defun wl-add-entity (key-path new entity prev-entity-id &optional errmes)
354 (when (string= (caar key-path) (car entity))
355 (let ((entities new))
357 (wl-folder-entity-assign-id
358 (pop entities) wl-folder-entity-id-name-hashtb t)))
359 (when (wl-add-entity-sub (cdr key-path) new entity errmes)
360 ;; return value is non-nil (diffs)
361 (wl-fldmgr-add-entity-hashtb new))))
363 (defun wl-add-entity-sub (key-path new entity &optional errmes)
364 (let ((flist (nth 2 entity))
368 ((consp (car key-path));; into group
369 (if (setq entry (assoc (caar key-path) flist))
370 (if (not (wl-add-entity-sub (cdr key-path)
374 (throw 'success nil))
375 (and errmes (message "%s not found" (caar key-path)))
376 (throw 'success nil)))
380 (access (eq (nth 1 entity) 'access))
381 (unsubscribes (and access (nth 3 entity))))
385 ((stringp (car new2)) ;; folder
387 ((wl-string-member (car new2) flist)
388 (and errmes (message "%s: already exists" (car new2)))
389 (throw 'success nil))
391 (not (wl-string-member (car new2) unsubscribes)))
392 (and errmes (message "%s: not access group folder" (car new2)))
393 (throw 'success nil))))
396 (not (wl-string-assoc (caar new2) unsubscribes)))
397 (and errmes (message "%s: can't insert access group"
399 (throw 'success nil))))
400 (setq new2 (cdr new2)))
403 ;; remove from unsubscribe
406 (if (consp (car new2))
408 (delq (wl-string-assoc (car (car new2)) unsubscribes)
410 (setq unsubscribes (delete (elmo-string (car new2))
412 (setq new2 (cdr new2)))
413 (setcdr (cddr entity) (list unsubscribes))
414 (wl-fldmgr-add-modified-access-list group))
415 (if (not key-path);; insert group top
417 (setcar (cddr entity) (append new flist))
418 (setcdr (cdr entity) (list new)))
422 (setq akey (car flist))
423 (cond ((consp akey);; group
424 (if (equal (car key-path) (car akey))
427 (if (equal (car key-path) akey)
429 (setq flist (cdr flist))))
430 (setcdr flist (append new (cdr flist)))
431 (and errmes (message "%s not found" (car key-path)))
432 (throw 'success nil)))))))
433 (throw 'success t))))
436 ;; (path indent-level (group . type) previous-entity-id target-entity)
437 ;; previous-entity-id is (id-name-alist-prev-id . entity-alist-prev-id)
439 ;; '((("Desktop" group) ("ML" group) "+ml/wl") '(3 2) ("ML" . group) nil "+ml/wl")
441 (defun wl-fldmgr-get-path-from-buffer (&optional prev)
442 (let ((indent-level 0)
444 folder-path group-type previous-entity entity)
448 ;;; (wl-folder-next-entity-skip-invalid t)
449 ;;; (and (setq previous-entity
450 ;;; (wl-fldmgr-get-previous-entity wl-folder-entity
451 ;;; (wl-fldmgr-get-entity-id)))
452 ;;; ;; change entity to id
453 ;;; (setq previous-entity
455 ;;; (and (car previous-entity)
456 ;;; (wl-fldmgr-get-entity-id (car previous-entity)))
457 ;;; (and (cdr previous-entity)
458 ;;; (wl-fldmgr-get-entity-id (cdr previous-entity))))))
459 (wl-folder-prev-entity-skip-invalid))
461 (looking-at wl-folder-group-regexp)
462 (string= (wl-match-buffer 2) "-"))
463 (setq group-target nil)
464 (if (and prev (bobp))
465 (error "Out of desktop group")))
466 (setq folder-path (wl-fldmgr-get-path wl-folder-entity
467 (wl-folder-get-entity-from-buffer)
468 ;;; (wl-fldmgr-get-entity-id)
470 (let ((fp folder-path))
474 (setq indent-level (1+ indent-level))
475 (setq group-type (cons (caar fp) (nth 1 (car fp)))))
476 (setq entity (car fp)))
478 (list folder-path indent-level group-type previous-entity entity))))
483 (defun wl-fldmgr-clear-cut-entity-list ()
485 (setq wl-fldmgr-cut-entity-list nil)
486 (message "Cleared cut entity list"))
488 (defun wl-fldmgr-reconst-entity-hashtb (&optional arg nomes)
490 (or nomes (message "Reconstructing entity alist..."))
492 (setq wl-folder-entity-id 0)
493 (wl-folder-entity-assign-id wl-folder-entity))
494 (setq wl-folder-entity-hashtb
495 (wl-folder-create-entity-hashtb
497 wl-folder-entity-hashtb
499 ;; reset property on buffer
501 (let ((inhibit-read-only t)
504 (wl-folder-insert-entity " " wl-folder-entity)
505 (goto-char cur-point)
506 (set-buffer-modified-p nil)))
507 (or nomes (message "Reconstructing entity alist...done")))
510 (defun wl-fldmgr-cut-region ()
512 (let* ((p1 (region-beginning))
527 name pre-indent indent)
531 (and (looking-at "^\\([ ]*\\)")
532 (setq pre-indent (wl-match-buffer 1)))
533 (while (< (point) to)
534 (and (looking-at "^\\([ ]*\\)")
535 (setq indent (wl-match-buffer 1)))
536 (cond ((= (length pre-indent) (length indent))
537 (setq pre-indent indent)
538 (setq count (1+ count))
539 (and (setq name (wl-folder-get-entity-from-buffer))
540 (wl-append cut-list (list name)))
542 ((< (length pre-indent) (length indent))
543 (wl-folder-goto-bottom-of-current-folder pre-indent)
546 (setq errmes "bad region")
548 (unless (eq (point) to)
549 (setq errmes "bad region")
552 (let ((count2 (length cut-list))
556 (wl-folder-next-entity-skip-invalid t)
557 (setq tmp (wl-fldmgr-get-path-from-buffer)))
558 (setq path (car tmp))
560 (wl-delete-entity path cut-list wl-folder-entity))
563 (setq ent (looking-at wl-folder-entity-regexp))
564 (if (not (wl-fldmgr-cut (and ent tmp)
565 (and ent (pop cut-list))))
567 (setq count (1- count))))
569 (wl-push count2 wl-fldmgr-cut-entity-list))
571 (wl-fldmgr-update-group path diffs))
575 (message "%s" errmes))))
577 (defun wl-fldmgr-cut (&optional tmp entity clear)
582 (inhibit-read-only t)
585 (message "Can't remove desktop group")
586 (or tmp (setq tmp (wl-fldmgr-get-path-from-buffer)))
587 (setq path (car tmp))
590 (wl-fldmgr-delete-line)) ;; unsubscribe or removed folder
593 (wl-delete-entity path nil wl-folder-entity clear)))
594 (setq wl-fldmgr-modified t)
596 (if (looking-at wl-folder-group-regexp)
598 (let (beg end indent opened)
599 (setq indent (wl-match-buffer 1))
600 (setq opened (wl-match-buffer 2))
601 (if (string= opened "+")
602 (wl-fldmgr-delete-line)
608 (wl-folder-goto-bottom-of-current-folder indent)
611 (delete-region beg end)))
613 (wl-fldmgr-delete-line))
615 (wl-fldmgr-update-group path diffs))
616 (set-buffer-modified-p nil))
620 (defun wl-fldmgr-copy-region ()
622 (let* ((p1 (region-beginning))
643 (setq errmes "can't copy desktop group")
645 (and (looking-at "^\\([ ]*\\)")
646 (setq pre-indent (wl-match-buffer 1)))
647 (while (< (point) to)
648 (and (looking-at "^\\([ ]*\\)")
649 (setq indent (wl-match-buffer 1)))
650 (if (looking-at wl-folder-group-regexp)
652 (setq errmes "can't copy group folder")
654 (cond ((= (length pre-indent) (length indent))
655 (if (setq name (wl-folder-get-entity-from-buffer))
657 (setq pre-indent indent)
658 (wl-push name cut-list)))
660 ((< (length pre-indent) (length indent))
661 (wl-folder-goto-bottom-of-current-folder pre-indent)
664 (setq errmes "bad region")
666 (unless (eq (point) to)
667 (setq errmes "bad region")
670 (setq cut-list (reverse cut-list))
672 (setq name (pop cut-list))
673 (unless (wl-fldmgr-copy name)
675 (setq count (1+ count)))
676 (wl-push count wl-fldmgr-cut-entity-list)
677 (message "Copy %s folders" count)
680 (message "%s" errmes))))
682 (defun wl-fldmgr-copy (&optional ename)
688 (looking-at wl-folder-group-regexp))
689 (message "Can't copy group folder")
690 (let* ((name (or ename (wl-folder-get-entity-from-buffer)))
691 (entity (elmo-string name)))
693 (if (member entity wl-fldmgr-cut-entity-list)
694 (setq wl-fldmgr-cut-entity-list
695 (delete entity wl-fldmgr-cut-entity-list)))
696 (wl-push entity wl-fldmgr-cut-entity-list)
698 (message "Copy: %s" name))
702 (defun wl-fldmgr-yank ()
707 (message "Can't insert in the out of desktop group")
708 (let ((inhibit-read-only t)
709 (top (car wl-fldmgr-cut-entity-list))
710 tmp indent path count new
711 access new-list diffs)
713 (message "No cut buffer")
714 (setq tmp (wl-fldmgr-get-path-from-buffer t))
715 (setq path (car tmp))
716 (setq indent (wl-fldmgr-make-indent (nth 1 tmp)))
718 (setq count (pop wl-fldmgr-cut-entity-list))
722 (cut-list wl-fldmgr-cut-entity-list))
723 ;; check insert entity
725 (setq new (car cut-list))
726 (wl-push new new-list)
727 (when (consp new);; group
730 (message "Can't insert group in access")
732 ((wl-string-assoc (car new) wl-folder-group-alist)
733 (message "%s: group already exists" (car new))
735 (setq cut-list (cdr cut-list))
736 (setq count (1- count))))
739 path new-list wl-folder-entity (nth 3 tmp) t)))
742 (setq new (pop wl-fldmgr-cut-entity-list))
744 (wl-folder-insert-entity indent new)
745 (setq wl-fldmgr-modified t))
746 (setq count (1- count)))
747 (wl-fldmgr-update-group path diffs)
748 (set-buffer-modified-p nil))
750 (wl-push count wl-fldmgr-cut-entity-list)))))))
752 (defvar wl-fldmgr-add-completion-hashtb (make-vector 7 0))
754 (defun wl-fldmgr-add-completion-all-completions (string)
760 (if (string-match (symbol-name atom) string)
761 (throw 'found (symbol-value atom)))))
762 wl-fldmgr-add-completion-hashtb)))
764 (if (string-match "\\.$"
765 (car (elmo-network-get-spec
766 string nil nil nil nil)))
767 (substring string 0 (match-beginning 0))
768 (concat string nil))))
770 (setq table (elmo-list-folders pattern))
772 (or (/= (length table) 1)
773 (elmo-folder-exists-p (car table))))
775 (if (string-match "\\.[^\\.]+$" string)
776 (substring string 0 (match-beginning 0))
777 (char-to-string (aref string 0)))
778 table (elmo-list-folders pattern)))
779 (setq pattern (concat "^" (regexp-quote pattern)))
780 (unless (intern-soft pattern wl-fldmgr-add-completion-hashtb)
781 (set (intern pattern wl-fldmgr-add-completion-hashtb) table))
784 (defun wl-fldmgr-add-completion-subr (string predicate flag)
786 (if (string= string "")
787 (mapcar (function (lambda (spec)
788 (list (char-to-string (car spec)))))
790 (when (assq (aref string 0) elmo-spec-alist)
794 (wl-fldmgr-add-completion-all-completions string)
797 (try-completion string table predicate)
798 (if (eq flag 'lambda)
799 (eq t (try-completion string table predicate))
801 (all-completions string table predicate))))))
803 (defun wl-fldmgr-add (&optional name)
808 (inhibit-read-only t)
809 (wl-folder-completion-func
810 (if wl-fldmgr-add-complete-with-current-folder-list
811 (function wl-fldmgr-add-completion-subr)))
812 tmp indent path diffs)
814 (message "Can't insert in the out of desktop group")
815 (setq tmp (wl-fldmgr-get-path-from-buffer t))
816 (setq path (car tmp))
817 (setq indent (wl-fldmgr-make-indent (nth 1 tmp)))
819 (setq name (wl-fldmgr-read-string
820 (wl-summary-read-folder wl-default-folder "to add"))))
821 ;; maybe add elmo-plugged-alist.
823 (elmo-folder-set-plugged name wl-plugged t))
826 path (list name) wl-folder-entity (nth 3 tmp) t))
827 (wl-folder-insert-entity indent name)
828 (wl-fldmgr-update-group path diffs)
829 (setq wl-fldmgr-modified t)
830 (set-buffer-modified-p nil)
834 (defun wl-fldmgr-delete ()
838 (if (looking-at wl-folder-group-regexp)
839 (error "Can't delete group folder"))
840 (let* ((inhibit-read-only t)
841 (tmp (wl-fldmgr-get-path-from-buffer))
842 (entity (elmo-string (nth 4 tmp)))
843 (msgs (and (elmo-folder-exists-p entity)
844 (elmo-list-folder entity))))
845 (when (yes-or-no-p (format "%sDo you really delete \"%s\"? "
846 (if (> (length msgs) 0)
847 (format "%d msg(s) exists. " (length msgs))
850 (elmo-delete-folder entity)
851 (wl-fldmgr-cut tmp nil t)))))
853 (defun wl-fldmgr-rename ()
858 (message "Can't rename desktop group")
860 ((looking-at wl-folder-group-regexp) ;; group
861 (let* ((indent (wl-match-buffer 1))
862 (old-group (wl-folder-get-realname (wl-match-buffer 3)))
863 (group-entity (wl-folder-search-group-entity-by-name
864 old-group wl-folder-entity))
866 (if (eq (nth 1 group-entity) 'access)
867 (message "%s: can't rename access group folder" old-group)
868 (setq group (wl-fldmgr-read-string
869 (read-from-minibuffer "Rename: " old-group)))
870 (if (string-match "/$" group)
871 (message "Remove tail slash.")
873 ((or (string= group "")
874 (string= old-group group))
877 (if (wl-string-assoc group wl-folder-group-alist)
878 (message "%s: group already exists" group)
879 (let ((inhibit-read-only t)
880 (id (wl-fldmgr-get-entity-id
881 (car group-entity))))
882 (wl-fldmgr-assign-id group id)
883 (setcar group-entity group)
884 (setcar (wl-string-assoc old-group wl-folder-group-alist)
886 ;;; (setcdr (assq id wl-folder-entity-id-name-alist) group)
887 (wl-folder-set-id-name id group)
888 (wl-fldmgr-delete-line)
889 (wl-folder-insert-entity
892 (setq wl-fldmgr-modified t)
893 (set-buffer-modified-p nil)))))))))
895 (let* ((tmp (wl-fldmgr-get-path-from-buffer))
896 (old-folder (nth 4 tmp))
898 (if (eq (cdr (nth 2 tmp)) 'access)
899 (error "Can't rename access folder"))
901 (wl-fldmgr-read-string
902 (wl-summary-read-folder old-folder "to rename" t t old-folder)))
903 (if (or (wl-folder-entity-exists-p new-folder)
904 (file-exists-p (elmo-msgdb-expand-path new-folder)))
905 (error "Already exists folder: %s" new-folder))
906 (elmo-rename-folder old-folder new-folder)
907 (wl-folder-set-entity-info
909 (wl-folder-get-entity-info old-folder))
910 (when (wl-fldmgr-cut tmp nil t)
911 (wl-fldmgr-add new-folder))))))))
913 (defun wl-fldmgr-make-access-group ()
915 (wl-fldmgr-make-group nil t))
917 (defun wl-fldmgr-make-group (&optional group-name access)
922 (message "Can't insert in the out of desktop group")
923 (let ((inhibit-read-only t)
925 group tmp indent path new prev-id flist diffs)
926 (setq tmp (wl-fldmgr-get-path-from-buffer t))
927 (setq path (car tmp))
928 (setq indent (wl-fldmgr-make-indent (nth 1 tmp)))
929 (setq prev-id (nth 3 tmp))
930 (if (eq (cdr (nth 2 tmp)) 'access)
931 (message "Can't insert access group")
932 (setq group (or group-name
933 (wl-fldmgr-read-string
934 (read-from-minibuffer
935 (if access "Access Type Group: " "Group: ")))))
936 (when (or access (string-match "[\t ]*/$" group))
937 (setq group (if access group
938 (substring group 0 (match-beginning 0))))
940 (setq flist (wl-create-access-folder-entity group)))
941 (if (string= group "")
943 (if (wl-string-assoc group wl-folder-group-alist)
944 (message "%s: group already exists" group)
945 (setq new (append (list group type) flist))
946 (when (setq diffs (wl-add-entity path
950 (wl-folder-insert-entity indent new)
951 (wl-fldmgr-update-group path diffs)
952 (setq wl-fldmgr-modified t)
953 (set-buffer-modified-p nil)))))))))
955 (defun wl-fldmgr-make-multi ()
957 (if (not wl-fldmgr-cut-entity-list)
958 (message "No cut buffer")
959 (let ((cut-entity wl-fldmgr-cut-entity-list)
967 ((numberp (car cut-entity))
969 ((consp (car cut-entity))
970 (message "Can't make multi included group folder")
973 (let ((spec (elmo-folder-get-spec (car cut-entity)))
975 (if (eq (car spec) 'multi)
977 (substring (car cut-entity) 1)))
980 (or multi-fld (car cut-entity))
984 (setq cut-entity (cdr cut-entity)))
987 (setq new-entity (concat "*" new-entity))
988 (wl-fldmgr-add new-entity)))))
990 (defun wl-fldmgr-make-filter ()
994 (if (looking-at wl-folder-group-regexp)
995 (message "This folder is group")
996 (let ((tmp (wl-fldmgr-get-path-from-buffer))
998 (if (eq (cdr (nth 2 tmp)) 'access)
999 (message "Can't change access group")
1000 (setq entity (nth 4 tmp))
1001 (unless entity (error "No folder"))
1002 (wl-fldmgr-add (concat "/"
1003 (elmo-read-search-condition
1004 wl-fldmgr-make-filter-default)
1007 (defun wl-fldmgr-sort ()
1011 (let ((inhibit-read-only t)
1012 entity flist indent opened)
1013 (when (looking-at wl-folder-group-regexp)
1014 (setq indent (wl-match-buffer 1))
1015 (setq opened (wl-match-buffer 2))
1016 (setq entity (wl-folder-search-group-entity-by-name
1017 (wl-folder-get-realname (wl-match-buffer 3))
1019 (message "Sorting...")
1020 (setq flist (sort (nth 2 entity) wl-fldmgr-sort-func))
1021 (setcar (cddr entity) flist)
1022 (wl-fldmgr-add-modified-access-list (car entity))
1023 (setq wl-fldmgr-modified t)
1025 (when (string= opened "-")
1032 (wl-folder-goto-bottom-of-current-folder indent)
1035 (delete-region beg end)
1036 (wl-folder-insert-entity indent entity)))
1037 ;;; (wl-fldmgr-reconst-entity-hashtb t t)
1038 (message "Sorting...done")
1039 (set-buffer-modified-p nil)))))
1041 (defun wl-fldmgr-sort-standard (x y)
1042 (cond ((and (consp x) (not (consp y)))
1043 wl-fldmgr-sort-group-first)
1044 ((and (not (consp x)) (consp y))
1045 (not wl-fldmgr-sort-group-first))
1046 ((and (consp x) (consp y))
1047 (string-lessp (car x) (car y)))
1049 (string-lessp x y))))
1051 (defun wl-fldmgr-subscribe-region ()
1053 (wl-fldmgr-unsubscribe-region -1))
1055 (defun wl-fldmgr-unsubscribe-region (&optional arg)
1057 (let* ((p1 (region-beginning))
1071 (while (< (point) to)
1072 (setq count (1+ count))
1075 (message "Unsubscribe region...")
1076 (while (and (> count 0)
1077 (wl-fldmgr-unsubscribe (or arg 1) t))
1078 (setq count (1- count)))
1079 (message "Unsubscribe region...done")))
1081 (defun wl-fldmgr-subscribe ()
1083 (wl-fldmgr-unsubscribe -1))
1085 (defun wl-fldmgr-unsubscribe (&optional arg force)
1087 (let ((type (and arg (prefix-numeric-value arg)))
1091 (let ((inhibit-read-only t)
1095 ((looking-at (format "^[ ]*%s\\[[+-]\\]\\(.*\\)" wl-folder-unsubscribe-mark))
1096 (if (and type (> type 0))
1098 (setq folder (list (wl-match-buffer 1) 'access nil))
1099 (if (wl-string-assoc (car folder) wl-folder-group-alist)
1100 (message "%s: group already exists" (car folder))
1101 (wl-fldmgr-delete-line)
1102 (when (wl-fldmgr-add folder)
1103 (wl-folder-maybe-load-folder-list folder)
1104 ;;; (wl-folder-search-group-entity-by-name (car folder)
1105 ;;; wl-folder-entity)
1107 ((looking-at (format "^[ ]*%s\\(.*\\)" wl-folder-unsubscribe-mark))
1108 (if (and type (> type 0))
1110 (setq folder (wl-match-buffer 1))
1111 (wl-fldmgr-delete-line)
1112 (when (wl-fldmgr-add folder)
1115 (if (and type (< type 0))
1117 (setq is-group (looking-at wl-folder-group-regexp))
1118 (setq tmp (wl-fldmgr-get-path-from-buffer))
1119 (setq indent (wl-fldmgr-make-indent (nth 1 tmp)))
1120 (if (eq (cdr (nth 2 tmp)) 'access)
1121 (when (wl-fldmgr-cut tmp)
1122 (pop wl-fldmgr-cut-entity-list) ;; don't leave cut-list
1124 (insert indent wl-folder-unsubscribe-mark
1126 (concat "[+]" (nth 4 tmp))
1129 (save-excursion (forward-line -1)
1130 (wl-highlight-folder-current-line))
1131 (remove-text-properties beg (point) '(wl-folder-entity-id))
1132 (setq execed t))))))
1133 (set-buffer-modified-p nil)))
1134 (if (or force execed)
1139 (defun wl-fldmgr-access-display-normal (&optional arg)
1141 (wl-fldmgr-access-display-all (not arg)))
1143 (defun wl-fldmgr-access-display-all (&optional arg)
1145 (let ((id (save-excursion
1146 (wl-folder-prev-entity-skip-invalid t)
1147 (wl-fldmgr-get-entity-id))))
1150 (let ((inhibit-read-only t)
1151 entity indent opened
1153 (when (not (looking-at wl-folder-group-regexp))
1154 (wl-folder-goto-top-of-current-folder)
1155 (looking-at wl-folder-group-regexp))
1156 (setq indent (wl-match-buffer 1))
1157 (setq opened (wl-match-buffer 2))
1158 (setq entity (wl-folder-search-group-entity-by-name
1159 (wl-folder-get-realname (wl-match-buffer 3))
1161 (when (eq (nth 1 entity) 'access)
1163 (if (string= opened "-")
1170 (wl-folder-goto-bottom-of-current-folder indent)
1173 (delete-region beg end))
1174 (wl-fldmgr-delete-line)
1175 (setcdr (assoc (car entity) wl-folder-group-alist) t));; set open
1176 (wl-folder-insert-entity indent entity))
1178 (setq unsubscribes (nth 3 entity))
1182 (insert indent " " wl-folder-unsubscribe-mark
1183 (if (consp (car unsubscribes))
1184 (concat "[+]" (caar unsubscribes))
1187 (remove-text-properties beg (point) '(wl-folder-entity-id))
1188 (save-excursion (forward-line -1)
1189 (wl-highlight-folder-current-line))
1190 (setq unsubscribes (cdr unsubscribes))))
1191 (set-buffer-modified-p nil))))
1192 (wl-folder-move-path id)))
1194 (defun wl-fldmgr-set-petname ()
1198 (let* ((is-group (looking-at wl-folder-group-regexp))
1199 (name (wl-folder-get-entity-from-buffer))
1200 (searchname (wl-folder-get-petname name))
1201 (pentry (wl-string-assoc name wl-folder-petname-alist))
1202 (old-petname (or (cdr pentry) ""))
1205 (unless name (error "No folder"))
1207 (not (eq (nth 1 (wl-folder-search-group-entity-by-name
1208 name wl-folder-entity))
1210 (message "Can't set petname. please rename.")
1211 (setq petname (wl-fldmgr-read-string
1212 (read-from-minibuffer "Petname: " old-petname)))
1214 ((string= petname "")
1216 (setq wl-folder-petname-alist
1217 (delete pentry wl-folder-petname-alist))
1220 (if (string= petname old-petname)
1222 (if (or (rassoc petname wl-folder-petname-alist)
1223 (wl-string-assoc petname wl-folder-group-alist))
1224 (message "%s: already exists" petname)
1225 (wl-folder-append-petname name petname)
1228 (let ((inhibit-read-only t)
1230 (goto-char (point-min))
1233 (if (string= old-petname "")
1234 (setq old-petname name))
1235 (while (wl-folder-buffer-search-group old-petname)
1237 (and (looking-at "^\\([ ]*\\)")
1238 (setq indent (wl-match-buffer 1)))
1239 (wl-fldmgr-delete-line)
1240 (wl-folder-insert-entity
1242 (wl-folder-search-group-entity-by-name
1243 name wl-folder-entity)
1245 (while (wl-folder-buffer-search-entity name searchname)
1248 (and (looking-at "^\\([ ]*\\)")
1249 (setq indent (wl-match-buffer 1)))
1250 (wl-fldmgr-delete-line))
1251 (wl-folder-insert-entity indent name)))
1252 (setq wl-fldmgr-modified t)
1253 (set-buffer-modified-p nil)))))))
1255 ;;; Function for save folders
1258 (defun wl-fldmgr-insert-folders-buffer (indent entities &optional pet-entities)
1259 (let ((flist entities)
1262 (setq name (car flist))
1263 (cond ((stringp name)
1264 (if (setq petname (cdr (wl-string-assoc name wl-folder-petname-alist)))
1265 (wl-append pet-entities (list name)))
1268 (concat "\t\"" petname "\"")
1272 (let ((group (wl-folder-get-realname (car name)))
1273 (type (nth 1 name)))
1274 (if (not (string= group (car name))) ; petname.
1275 (wl-append pet-entities (list (car name))))
1276 (cond ((eq type 'group)
1277 (insert indent group "{\n")
1279 (wl-fldmgr-insert-folders-buffer
1280 (concat indent wl-fldmgr-folders-indent)
1281 (nth 2 name) pet-entities))
1282 (insert indent "}\n"))
1284 (insert indent group "/\n"))))))
1285 (setq flist (cdr flist))))
1288 (defun wl-fldmgr-insert-petname-buffer (pet-entities)
1289 (let ((alist wl-folder-petname-alist))
1291 (if (wl-string-member (caar alist) pet-entities)
1293 (insert "=\t" (caar alist) "\t\"" (cdar alist) "\"\n"))
1294 (setq alist (cdr alist)))))
1296 (defun wl-fldmgr-delete-disused-petname ()
1297 (let ((alist wl-folder-petname-alist))
1299 (unless (wl-folder-search-entity-by-name (caar alist) wl-folder-entity)
1300 (setq wl-folder-petname-alist
1301 (delete (car alist) wl-folder-petname-alist)))
1302 (setq alist (cdr alist)))))
1304 (defun wl-fldmgr-save-folders ()
1306 (let ((tmp-buf (get-buffer-create " *wl-fldmgr-tmp*"))
1307 (access-list wl-fldmgr-modified-access-list)
1309 save-petname-entities)
1310 (message "Saving folders...")
1311 (set-buffer tmp-buf)
1313 (insert wl-fldmgr-folders-header)
1314 (wl-fldmgr-delete-disused-petname)
1315 (setq save-petname-entities
1316 (wl-fldmgr-insert-folders-buffer "" (nth 2 wl-folder-entity)))
1317 (insert "\n# petname definition (group, folder in access group)\n")
1318 (wl-fldmgr-insert-petname-buffer save-petname-entities)
1319 (insert "\n# end of file.\n")
1320 (if (and wl-fldmgr-make-backup
1321 (file-exists-p wl-folders-file))
1322 (rename-file wl-folders-file (concat wl-folders-file ".bak") t))
1323 (let ((output-coding-system (mime-charset-to-coding-system
1331 (set-file-modes wl-folders-file (+ (* 64 6) (* 8 0) 0))) ; chmod 0600
1332 (kill-buffer tmp-buf)
1334 (setq entity (wl-folder-search-group-entity-by-name
1335 (car access-list) wl-folder-entity))
1336 (elmo-msgdb-flist-save
1339 (wl-folder-make-save-access-list (nth 2 entity))
1340 (wl-folder-make-save-access-list (nth 3 entity))))
1341 (setq access-list (cdr access-list)))
1342 (setq wl-fldmgr-modified nil)
1343 (setq wl-fldmgr-modified-access-list nil)
1344 (message "Saving folders...done")))
1347 (product-provide (provide 'wl-fldmgr) (require 'wl-version))
1349 ;;; wl-fldmgr.el ends here