X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=wl%2Fwl-fldmgr.el;h=b84d9ed5203204ba4681a97eea41169b61576e40;hb=312d0ff8909b01d453beb51511df90d7a8a3a9bc;hp=c871c7805087b610ebcac4e517ba3d9288960ce0;hpb=a10e1abfc9834048bc0569ca2f61df3dd048669f;p=elisp%2Fwanderlust.git

diff --git a/wl/wl-fldmgr.el b/wl/wl-fldmgr.el
index c871c78..b84d9ed 100644
--- a/wl/wl-fldmgr.el
+++ b/wl/wl-fldmgr.el
@@ -1,4 +1,4 @@
-;;; wl-fldmgr.el -- Folder manager for Wanderlust.
+;;; wl-fldmgr.el --- Folder manager for Wanderlust.
 
 ;; Copyright 1998,1999,2000 Masahiro MURATA <muse@ba2.so-net.ne.jp>
 ;;                          Yuuichi Teranishi <teranisi@gohome.org>
@@ -25,10 +25,10 @@
 ;;
 
 ;;; Commentary:
-;; 
+;;
 
 ;;; Code:
-;; 
+;;
 
 (require 'wl-folder)
 (require 'wl-summary)
@@ -46,12 +46,16 @@
 (defvar wl-fldmgr-group-insert-opened nil)
 
 (defconst wl-fldmgr-folders-header
-  "#
+  (format
+   "#
 # Folder definition file
 # This file is generated automatically by %s.
 #
+# If you edit this file by hand, be sure that comment lines
+# will be washed out by wl-fldmgr.
+#
 
-")
+" (product-string-1 'wl-version t)))
 
 ;;; Initial setup
 
@@ -91,7 +95,12 @@
 (defun wl-fldmgr-exit ()
   (when (and wl-fldmgr-modified
 	     (or (not wl-interactive-save-folders)
-		 (y-or-n-p "Folder view was modified.  Save current folders? ")))
+		 (y-or-n-p
+		  (concat "Folder view was modified"
+			  (and wl-fldmgr-cut-entity-list
+			       (format " (%s in cut stack)"
+				       (length wl-fldmgr-cut-entity-list)))
+			  ".  Save current folders? "))))
     (wl-fldmgr-save-folders)))
 
 ;;; Macro and misc Function
@@ -239,7 +248,7 @@ return value is diffs '(-new -unread -all)."
 
 ;; (defun wl-fldmgr-get-previous-entity (entity key-id)
 ;;   (cdr (wl-fldmgr-get-previous-entity-internal '(nil . nil) entity key-id)))
-;; 
+;;
 ;; (defun wl-fldmgr-get-previous-entity-internal (result entity key-id)
 ;;   (cond
 ;;    ((stringp entity)
@@ -332,7 +341,7 @@ return value is diffs '(-new -unread -all)."
 		   (message "%s not found" key)
 		   (setq update nil)
 		   (throw 'done t)))
-	    (when access
+	    (when (and access (not clear))
 	      (if is-group
 		  (wl-append unsubscribes
 			     (list (list (elmo-string key) 'access nil)))
@@ -383,11 +392,11 @@ return value is diffs '(-new -unread -all)."
 	    (cond
 	     ((stringp (car new2)) ;; folder
 	      (cond
-	       ((wl-string-member (car new2) flist)
+	       ((elmo-string-member (car new2) flist)
 		(and errmes (message "%s: already exists" (car new2)))
 		(throw 'success nil))
 	       ((and access
-		     (not (wl-string-member (car new2) unsubscribes)))
+		     (not (elmo-string-member (car new2) unsubscribes)))
 		(and errmes (message "%s: not access group folder" (car new2)))
 		(throw 'success nil))))
 	     (t			   ;; group
@@ -409,7 +418,7 @@ return value is diffs '(-new -unread -all)."
 		(setq unsubscribes (delete (elmo-string (car new2))
 					   unsubscribes)))
 	      (setq new2 (cdr new2)))
- 	    (setcdr (cddr entity) (list unsubscribes))
+	    (setcdr (cddr entity) (list unsubscribes))
 	    (wl-fldmgr-add-modified-access-list group))
 	  (if (not key-path);; insert group top
 	      (if (cddr entity)
@@ -457,6 +466,7 @@ return value is diffs '(-new -unread -all)."
 ;;;			 (wl-fldmgr-get-entity-id (cdr previous-entity))))))
 	(wl-folder-prev-entity-skip-invalid))
       (if (and prev
+	       (wl-folder-buffer-group-p)
 	       (looking-at wl-folder-group-regexp)
 	       (string= (wl-match-buffer 2) "-"))
 	  (setq group-target nil)
@@ -592,7 +602,8 @@ return value is diffs '(-new -unread -all)."
 		    (wl-delete-entity path nil wl-folder-entity clear)))
 	  (setq wl-fldmgr-modified t)
 	  ;;
-	  (if (looking-at wl-folder-group-regexp)
+	  (if (and (wl-folder-buffer-group-p)
+		   (looking-at wl-folder-group-regexp))
 	      ;; group
 	      (let (beg end indent opened)
 		(setq indent (wl-match-buffer 1))
@@ -646,7 +657,7 @@ return value is diffs '(-new -unread -all)."
 	(while (< (point) to)
 	  (and (looking-at "^\\([ ]*\\)")
 	       (setq indent (wl-match-buffer 1)))
-	  (if (looking-at wl-folder-group-regexp)
+	  (if (wl-folder-buffer-group-p)
 	      (progn
 		(setq errmes "can't copy group folder")
 		(throw 'err t)))
@@ -684,7 +695,7 @@ return value is diffs '(-new -unread -all)."
     (beginning-of-line)
     (let ((ret-val nil))
       (if (and (not ename)
-	       (looking-at wl-folder-group-regexp))
+	       (wl-folder-buffer-group-p))
 	  (message "Can't copy group folder")
 	(let* ((name (or ename (wl-folder-get-entity-from-buffer)))
 	       (entity (elmo-string name)))
@@ -761,20 +772,23 @@ return value is diffs '(-new -unread -all)."
 	    wl-fldmgr-add-completion-hashtb)))
 	(pattern
 	 (if (string-match "\\.$"
-			   (car (elmo-network-get-spec
-				 string nil nil nil nil)))
+			   (elmo-folder-prefix-internal
+			    (wl-folder-get-elmo-folder string)))
 	     (substring string 0 (match-beginning 0))
 	   (concat string nil))))
     (or table
-	(setq table (elmo-list-folders pattern))
+	(setq table (elmo-folder-list-subfolders
+		     (wl-folder-get-elmo-folder pattern)))
 	(and table
 	     (or (/= (length table) 1)
-		 (elmo-folder-exists-p (car table))))
+		 (elmo-folder-exists-p (wl-folder-get-elmo-folder
+					(car table)))))
 	(setq pattern
 	      (if (string-match "\\.[^\\.]+$" string)
 		  (substring string 0 (match-beginning 0))
 		(char-to-string (aref string 0)))
-	      table (elmo-list-folders pattern)))
+	      table (elmo-folder-list-subfolders
+		     (wl-folder-get-elmo-folder pattern))))
     (setq pattern (concat "^" (regexp-quote pattern)))
     (unless (intern-soft pattern wl-fldmgr-add-completion-hashtb)
       (set (intern pattern wl-fldmgr-add-completion-hashtb) table))
@@ -785,19 +799,20 @@ return value is diffs '(-new -unread -all)."
 	 (if (string= string "")
 	     (mapcar (function (lambda (spec)
 				 (list (char-to-string (car spec)))))
-		     elmo-spec-alist)
-	   (when (assq (aref string 0) elmo-spec-alist)
+		     elmo-folder-type-alist)
+	   (when (assq (aref string 0) elmo-folder-type-alist)
 	     (delq nil (mapcar
 			(function list)
 			(condition-case nil
 			    (wl-fldmgr-add-completion-all-completions string)
 			  (error nil))))))))
-    (if (null flag)
-	(try-completion string table predicate)
-      (if (eq flag 'lambda)
-	  (eq t (try-completion string table predicate))
-	(if flag
-	    (all-completions string table predicate))))))
+    (cond
+     ((null flag)
+      (try-completion string table predicate))
+     ((eq flag 'lambda)
+      (eq t (try-completion string table predicate)))
+     (t
+      (all-completions string table predicate)))))
 
 (defun wl-fldmgr-add (&optional name)
   (interactive)
@@ -805,7 +820,7 @@ return value is diffs '(-new -unread -all)."
     (beginning-of-line)
     (let ((ret-val nil)
 	  (inhibit-read-only t)
-	  (wl-folder-completion-func
+	  (wl-folder-complete-folder-candidate
 	   (if wl-fldmgr-add-complete-with-current-folder-list
 	       (function wl-fldmgr-add-completion-subr)))
 	  tmp indent path diffs)
@@ -818,8 +833,9 @@ return value is diffs '(-new -unread -all)."
 	    (setq name (wl-fldmgr-read-string
 			(wl-summary-read-folder wl-default-folder "to add"))))
 	;; maybe add elmo-plugged-alist.
-	(when (stringp name)
-	  (elmo-folder-set-plugged name wl-plugged t))
+	(elmo-folder-set-plugged (wl-folder-get-elmo-folder
+				  (if (listp name) (car name) name))
+				 wl-plugged t)
 	(when (setq diffs
 		    (wl-add-entity
 		     path (list name) wl-folder-entity (nth 3 tmp) t))
@@ -834,20 +850,16 @@ return value is diffs '(-new -unread -all)."
   (interactive)
   (save-excursion
     (beginning-of-line)
-    (if (looking-at wl-folder-group-regexp)
+    (if (wl-folder-buffer-group-p)
 	(error "Can't delete group folder"))
     (let* ((inhibit-read-only t)
 	   (tmp (wl-fldmgr-get-path-from-buffer))
 	   (entity (elmo-string (nth 4 tmp)))
-	   (msgs (and (elmo-folder-exists-p entity)
-		      (elmo-list-folder entity))))
-      (when (yes-or-no-p (format "%sDo you really delete \"%s\"? "
-				 (if (> (length msgs) 0)
-				     (format "%d msg(s) exists. " (length msgs))
-				   "")
-				 entity))
-	(elmo-delete-folder entity)
-	(wl-fldmgr-cut tmp nil t)))))
+	   (folder (wl-folder-get-elmo-folder entity)))
+      (when (elmo-folder-delete folder)
+	(wl-folder-clear-entity-info entity)
+	(wl-fldmgr-cut tmp nil t)
+	(wl-fldmgr-save-access-list)))))
 
 (defun wl-fldmgr-rename ()
   (interactive)
@@ -856,9 +868,10 @@ return value is diffs '(-new -unread -all)."
     (if (bobp)
 	(message "Can't rename desktop group")
       (cond
-       ((looking-at wl-folder-group-regexp) ;; group
+       ((and (wl-folder-buffer-group-p)
+	     (looking-at wl-folder-group-regexp)) ;; group
 	(let* ((indent (wl-match-buffer 1))
-	       (old-group (wl-folder-get-realname (wl-match-buffer 3)))
+	       (old-group (wl-folder-get-entity-from-buffer))
 	       (group-entity (wl-folder-search-group-entity-by-name
 			      old-group wl-folder-entity))
 	       group)
@@ -885,29 +898,47 @@ return value is diffs '(-new -unread -all)."
 ;;;		    (setcdr (assq id wl-folder-entity-id-name-alist) group)
 		    (wl-folder-set-id-name id group)
 		    (wl-fldmgr-delete-line)
- 		    (wl-folder-insert-entity
- 		     indent
- 		     group-entity t)
+		    (wl-folder-insert-entity
+		     indent
+		     group-entity t)
 		    (setq wl-fldmgr-modified t)
 		    (set-buffer-modified-p nil)))))))))
        (t ;; folder
 	(let* ((tmp (wl-fldmgr-get-path-from-buffer))
 	       (old-folder (nth 4 tmp))
 	       new-folder)
-	  (if (eq (cdr (nth 2 tmp)) 'access)
-	      (error "Can't rename access folder"))
+	  (unless old-folder (error "No folder"))
 	  (setq new-folder
 		(wl-fldmgr-read-string
 		 (wl-summary-read-folder old-folder "to rename" t t old-folder)))
 	  (if (or (wl-folder-entity-exists-p new-folder)
-		  (file-exists-p (elmo-msgdb-expand-path new-folder)))
+		  (file-exists-p (elmo-folder-msgdb-path
+				  (wl-folder-get-elmo-folder new-folder))))
 	      (error "Already exists folder: %s" new-folder))
-	  (elmo-rename-folder old-folder new-folder)
+	  (if (and (eq (cdr (nth 2 tmp)) 'access)
+		   (null wl-fldmgr-allow-rename-access-group)
+		   (null (string-match
+			  (format "^%s" (regexp-quote (car (nth 2 tmp))))
+			  new-folder)))
+	      (error "Can't rename access folder"))
+	  (elmo-folder-rename (wl-folder-get-elmo-folder old-folder)
+			      new-folder)
 	  (wl-folder-set-entity-info
 	   new-folder
 	   (wl-folder-get-entity-info old-folder))
-	  (when (wl-fldmgr-cut tmp nil t)
-	    (wl-fldmgr-add new-folder))))))))
+	  (wl-folder-clear-entity-info old-folder)
+	  (setq wl-folder-info-alist-modified t)
+	  (if (eq (cdr (nth 2 tmp)) 'access)
+
+	      ;; force update access group
+	      (progn
+		(wl-folder-open-close)
+		(wl-folder-jump-to-current-entity t)
+		(message "%s is renamed to %s" old-folder new-folder)
+		(sit-for 1))
+	    ;; update folder list
+	    (when (wl-fldmgr-cut tmp nil t)
+	      (wl-fldmgr-add new-folder)))))))))
 
 (defun wl-fldmgr-make-access-group ()
   (interactive)
@@ -923,7 +954,7 @@ return value is diffs '(-new -unread -all)."
 	    (type 'group)
 	    group tmp indent path new prev-id flist diffs)
 	(setq tmp (wl-fldmgr-get-path-from-buffer t))
-    	(setq path (car tmp))
+	(setq path (car tmp))
 	(setq indent (wl-fldmgr-make-indent (nth 1 tmp)))
 	(setq prev-id (nth 3 tmp))
 	(if (eq (cdr (nth 2 tmp)) 'access)
@@ -932,6 +963,8 @@ return value is diffs '(-new -unread -all)."
 			  (wl-fldmgr-read-string
 			   (read-from-minibuffer
 			    (if access "Access Type Group: " "Group: ")))))
+	  ;; To check the folder name is correct.
+	  (if access (elmo-make-folder group))
 	  (when (or access (string-match "[\t ]*/$" group))
 	    (setq group (if access group
 			  (substring group 0 (match-beginning 0))))
@@ -969,9 +1002,10 @@ return value is diffs '(-new -unread -all)."
 		  (message "Can't make multi included group folder")
 		  (throw 'done nil))
 		 (t
-		  (let ((spec (elmo-folder-get-spec (car cut-entity)))
+		  (let ((folder (wl-folder-get-elmo-folder
+				 (car cut-entity)))
 			multi-fld)
-		    (if (eq (car spec) 'multi)
+		    (if (eq (elmo-folder-type-internal folder) 'multi)
 			(setq multi-fld
 			      (substring (car cut-entity) 1)))
 		    (setq new-entity
@@ -990,37 +1024,49 @@ return value is diffs '(-new -unread -all)."
   (interactive)
   (save-excursion
     (beginning-of-line)
-    (if (looking-at wl-folder-group-regexp)
-	(message "This folder is group")
-      (let ((tmp (wl-fldmgr-get-path-from-buffer))
-	    entity)
-	(if (eq (cdr (nth 2 tmp)) 'access)
-	    (message "Can't change access group")
-	  (setq entity (nth 4 tmp))
-	  (unless entity (error "No folder"))
-	  (wl-fldmgr-add (concat "/"
-				 (elmo-read-search-condition
-				  wl-fldmgr-make-filter-default)
-				 "/" entity)))))))
-
-(defun wl-fldmgr-sort ()
-  (interactive)
+    (let ((tmp (wl-fldmgr-get-path-from-buffer))
+	  entity)
+      (if (eq (cdr (nth 2 tmp)) 'access)
+	  (message "Can't change access group")
+	(if (wl-folder-buffer-group-p)
+	    (setq entity
+		  (concat
+		   "*"
+		   (mapconcat 'identity
+			      (wl-folder-get-entity-list
+			       (wl-folder-search-group-entity-by-name
+				(nth 4 tmp)
+				wl-folder-entity)) ",")))
+	  (setq entity (nth 4 tmp)))
+	(unless entity (error "No folder"))
+	(wl-fldmgr-add (concat "/"
+			       (elmo-read-search-condition
+				wl-fldmgr-make-filter-default)
+			       "/" entity))))))
+
+(defun wl-fldmgr-sort (&optional arg)
+  (interactive "P")
   (save-excursion
     (beginning-of-line)
     (let ((inhibit-read-only t)
 	  entity flist indent opened)
-      (when (looking-at wl-folder-group-regexp)
+      (when (and (wl-folder-buffer-group-p)
+		 (looking-at wl-folder-group-regexp)
+		 (prog1
+		     (y-or-n-p (format "Sort subfolders of %s? "
+				       (wl-folder-get-entity-from-buffer)))
+		   (message nil)))
 	(setq indent (wl-match-buffer 1))
 	(setq opened (wl-match-buffer 2))
 	(setq entity (wl-folder-search-group-entity-by-name
-		      (wl-folder-get-realname (wl-match-buffer 3))
+		      (wl-folder-get-entity-from-buffer)
 		      wl-folder-entity))
 	(message "Sorting...")
-	(setq flist (sort (nth 2 entity) wl-fldmgr-sort-func))
+	(setq flist (sort (nth 2 entity) wl-fldmgr-sort-function))
+	(when arg (setq flist (nreverse flist)))
 	(setcar (cddr entity) flist)
 	(wl-fldmgr-add-modified-access-list (car entity))
 	(setq wl-fldmgr-modified t)
-	;;
 	(when (string= opened "-")
 	  (let (beg end)
 	    (setq beg (point))
@@ -1033,7 +1079,6 @@ return value is diffs '(-new -unread -all)."
 		      (point))))
 	    (delete-region beg end)
 	    (wl-folder-insert-entity indent entity)))
-;;;	(wl-fldmgr-reconst-entity-hashtb t t)
 	(message "Sorting...done")
 	(set-buffer-modified-p nil)))))
 
@@ -1113,12 +1158,13 @@ return value is diffs '(-new -unread -all)."
 	 (t
 	  (if (and type (< type 0))
 	      nil
-	    (setq is-group (looking-at wl-folder-group-regexp))
+	    (setq is-group (wl-folder-buffer-group-p))
 	    (setq tmp (wl-fldmgr-get-path-from-buffer))
 	    (setq indent (wl-fldmgr-make-indent (nth 1 tmp)))
 	    (if (eq (cdr (nth 2 tmp)) 'access)
 		(when (wl-fldmgr-cut tmp)
-		  (pop wl-fldmgr-cut-entity-list)  ;; don't leave cut-list
+		  ;; don't leave cut-list
+		  (setq wl-fldmgr-cut-entity-list (cdr wl-fldmgr-cut-entity-list))
 		  (setq beg (point))
 		  (insert indent wl-folder-unsubscribe-mark
 			  (if is-group
@@ -1128,7 +1174,8 @@ return value is diffs '(-new -unread -all)."
 		  (save-excursion (forward-line -1)
 				  (wl-highlight-folder-current-line))
 		  (remove-text-properties beg (point) '(wl-folder-entity-id))
-		  (setq execed t))))))
+		  (setq execed t))
+	      (message "not an access group folder")))))
 	(set-buffer-modified-p nil)))
     (if (or force execed)
 	(progn
@@ -1149,13 +1196,15 @@ return value is diffs '(-new -unread -all)."
     (let ((inhibit-read-only t)
 	  entity indent opened
 	  unsubscribes beg)
-      (when (not (looking-at wl-folder-group-regexp))
+      (when (not
+	     (and (wl-folder-buffer-group-p)
+		  (looking-at wl-folder-group-regexp)))
 	(wl-folder-goto-top-of-current-folder)
 	(looking-at wl-folder-group-regexp))
       (setq indent (wl-match-buffer 1))
       (setq opened (wl-match-buffer 2))
       (setq entity (wl-folder-search-group-entity-by-name
-		    (wl-folder-get-realname (wl-match-buffer 3))
+		    (wl-folder-get-entity-from-buffer)
 		    wl-folder-entity))
       (when (eq (nth 1 entity) 'access)
 	(save-excursion
@@ -1194,7 +1243,7 @@ return value is diffs '(-new -unread -all)."
   (interactive)
   (save-excursion
     (beginning-of-line)
-      (let* ((is-group (looking-at wl-folder-group-regexp))
+      (let* ((is-group (wl-folder-buffer-group-p))
 	     (name (wl-folder-get-entity-from-buffer))
 	     (searchname (wl-folder-get-petname name))
 	     (pentry (wl-string-assoc name wl-folder-petname-alist))
@@ -1219,7 +1268,8 @@ return value is diffs '(-new -unread -all)."
 	  (if (string= petname old-petname)
 	      nil
 	    (if (or (rassoc petname wl-folder-petname-alist)
-		    (wl-string-assoc petname wl-folder-group-alist))
+		    (and is-group
+			 (wl-string-assoc petname wl-folder-group-alist)))
 		(message "%s: already exists" petname)
 	      (wl-folder-append-petname name petname)
 	      (setq change t)))))
@@ -1268,10 +1318,8 @@ return value is diffs '(-new -unread -all)."
 		       "")
 		     "\n"))
 	    ((consp name)
-	     (let ((group (wl-folder-get-realname (car name)))
+	     (let ((group (car name))
 		   (type (nth 1 name)))
-	       (if (not (string= group (car name))) ; petname.
-		   (wl-append pet-entities (list (car name))))
 	       (cond ((eq type 'group)
 		      (insert indent group "{\n")
 		      (setq pet-entities
@@ -1303,17 +1351,15 @@ return value is diffs '(-new -unread -all)."
 (defun wl-fldmgr-save-folders ()
   (interactive)
   (let ((tmp-buf (get-buffer-create " *wl-fldmgr-tmp*"))
-	(access-list wl-fldmgr-modified-access-list)
-	entity
 	save-petname-entities)
     (message "Saving folders...")
     (set-buffer tmp-buf)
     (erase-buffer)
-    (insert (format wl-fldmgr-folders-header (wl-version t)))
+    (insert wl-fldmgr-folders-header)
     (wl-fldmgr-delete-disused-petname)
     (setq save-petname-entities
 	  (wl-fldmgr-insert-folders-buffer "" (nth 2 wl-folder-entity)))
-    (insert "\n# petname definition (group, folder in access group)\n")
+    (insert "\n# petname definition (access group, folder in access group)\n")
     (wl-fldmgr-insert-petname-buffer save-petname-entities)
     (insert "\n# end of file.\n")
     (if (and wl-fldmgr-make-backup
@@ -1327,8 +1373,15 @@ return value is diffs '(-new -unread -all)."
        wl-folders-file
        nil
        'no-msg)
-      (set-file-modes wl-folders-file 384)) ; 600
+      (set-file-modes wl-folders-file (+ (* 64 6) (* 8 0) 0))) ; chmod 0600
     (kill-buffer tmp-buf)
+    (wl-fldmgr-save-access-list)
+    (setq wl-fldmgr-modified nil)
+    (message "Saving folders...done")))
+
+(defun wl-fldmgr-save-access-list ()
+  (let ((access-list wl-fldmgr-modified-access-list)
+	entity)
     (while access-list
       (setq entity (wl-folder-search-group-entity-by-name
 		    (car access-list) wl-folder-entity))
@@ -1338,9 +1391,7 @@ return value is diffs '(-new -unread -all)."
 	(wl-folder-make-save-access-list (nth 2 entity))
 	(wl-folder-make-save-access-list (nth 3 entity))))
       (setq access-list (cdr access-list)))
-    (setq wl-fldmgr-modified nil)
-    (setq wl-fldmgr-modified-access-list nil)
-    (message "Saving folders...done")))
+    (setq wl-fldmgr-modified-access-list nil)))
 
 (require 'product)
 (product-provide (provide 'wl-fldmgr) (require 'wl-version))