X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=wl%2Fwl-fldmgr.el;h=821e14415f0c1f0738b77074b57479a59bd29358;hb=b3084c46ef2a8c1392139a342031994f4c452917;hp=71986d1251b66de77ea07ccc3e84201dfc9d28eb;hpb=f2440089ec36013d4ef5e5fd518725abb0fe7269;p=elisp%2Fwanderlust.git diff --git a/wl/wl-fldmgr.el b/wl/wl-fldmgr.el index 71986d1..821e144 100644 --- a/wl/wl-fldmgr.el +++ b/wl/wl-fldmgr.el @@ -51,6 +51,9 @@ # 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))) @@ -92,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 @@ -240,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) @@ -333,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))) @@ -384,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 @@ -458,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) @@ -593,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)) @@ -647,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))) @@ -685,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,7 +771,7 @@ return value is diffs '(-new -unread -all)." (throw 'found (symbol-value atom))))) wl-fldmgr-add-completion-hashtb))) (pattern - (if (string-match "\\.$" + (if (string-match "\\.$" (elmo-folder-prefix-internal (wl-folder-get-elmo-folder string))) (substring string 0 (match-beginning 0)) @@ -796,12 +806,13 @@ return value is diffs '(-new -unread -all)." (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) @@ -809,7 +820,7 @@ return value is diffs '(-new -unread -all)." (beginning-of-line) (let ((ret-val nil) (inhibit-read-only t) - (wl-folder-completion-function + (wl-folder-complete-folder-candidate (if wl-fldmgr-add-complete-with-current-folder-list (function wl-fldmgr-add-completion-subr))) tmp indent path diffs) @@ -839,21 +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))) - (folder (wl-folder-get-elmo-folder entity)) - (msgs (and (elmo-folder-exists-p folder) - (elmo-folder-list-messages folder)))) - (when (yes-or-no-p (format "%sDo you really want to delete \"%s\"? " - (if (> (length msgs) 0) - (format "%d msg(s) exists. " (length msgs)) - "") - entity)) - (elmo-folder-delete folder) - (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) @@ -862,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) @@ -900,8 +907,7 @@ return value is diffs '(-new -unread -all)." (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))) @@ -909,13 +915,30 @@ return value is diffs '(-new -unread -all)." (file-exists-p (elmo-folder-msgdb-path (wl-folder-get-elmo-folder new-folder)))) (error "Already exists folder: %s" 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) @@ -1001,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 "/" + (wl-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-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)) @@ -1044,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))))) @@ -1124,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 @@ -1139,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 @@ -1160,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 @@ -1205,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)) @@ -1230,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))))) @@ -1279,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 @@ -1314,8 +1351,6 @@ 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) @@ -1324,7 +1359,7 @@ return value is diffs '(-new -unread -all)." (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 @@ -1340,6 +1375,13 @@ return value is diffs '(-new -unread -all)." 'no-msg) (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)) @@ -1349,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))