X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=wl%2Fwl-fldmgr.el;h=b5729308001171691917bdb95c6db67dbad538ff;hb=167053919d525e30162c34e574b6452bb858211b;hp=a4982286710e4741792e375980835892d901012b;hpb=b27be2664ccd84a3847dcad87b75f1183ebae621;p=elisp%2Fwanderlust.git diff --git a/wl/wl-fldmgr.el b/wl/wl-fldmgr.el index a498228..b572930 100644 --- a/wl/wl-fldmgr.el +++ b/wl/wl-fldmgr.el @@ -1,11 +1,10 @@ -;;; wl-fldmgr.el -- Folder manager for Wanderlust. +;;; wl-fldmgr.el --- Folder manager for Wanderlust. ;; Copyright 1998,1999,2000 Masahiro MURATA ;; Yuuichi Teranishi ;; Author: Masahiro MURATA ;; Keywords: mail, net news -;; Time-stamp: <2000-04-07 10:40:40 teranisi> ;; This file is part of Wanderlust (Yet Another Message Interface on Emacsen). @@ -26,14 +25,15 @@ ;; ;;; Commentary: -;; +;; ;;; Code: -;; +;; (require 'wl-folder) (require 'wl-summary) (require 'wl-highlight) +(require 'wl-version) (eval-when-compile (require 'wl-util)) @@ -46,25 +46,13 @@ (defvar wl-fldmgr-group-insert-opened nil) (defconst wl-fldmgr-folders-header - "# + (format + "# # Folder definition file -# This file is generated automatically by %s %s (%s). +# This file is generated automatically by %s. # -") - -(defconst wl-fldmgr-filter-completion-alist - '(("/last:") - ("/first:") - ("/since:") - ("/before:") - ("/from=") - ("/subject=") - ("/date=") - ("/to=") - ("/cc=") - ("/tocc=") - ("/body="))) +" (product-string-1 'wl-version t))) ;;; Initial setup @@ -104,7 +92,7 @@ (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 "Folder view was modified. Save current folders? "))) (wl-fldmgr-save-folders))) ;;; Macro and misc Function @@ -129,7 +117,7 @@ (defmacro wl-fldmgr-assign-id (entity &optional id) (` (let ((entity-id (or (, id) wl-folder-entity-id))) (put-text-property 0 (length (, entity)) - 'wl-folder-entity-id + 'wl-folder-entity-id entity-id (, entity))))) @@ -160,8 +148,8 @@ wl-folder-group-alist))) (defun wl-fldmgr-add-entity-hashtb (entities) - "update `wl-folder-entity-hashtb', `wl-folder-newsgroups-hashtb'. -return value is diffs '(new unread all)." + "Update `wl-folder-entity-hashtb', `wl-folder-newsgroups-hashtb'. +Return value is diffs '(new unread all)." (let* ((new-diff 0) (unread-diff 0) (all-diff 0) @@ -189,7 +177,7 @@ return value is diffs '(new unread all)." (list new-diff unread-diff all-diff))) (defun wl-fldmgr-delete-entity-hashtb (entities &optional clear) - "update `wl-folder-entity-hashtb'. + "Update `wl-folder-entity-hashtb'. return value is diffs '(-new -unread -all)." (let* ((new-diff 0) (unread-diff 0) @@ -364,13 +352,10 @@ return value is diffs '(-new -unread -all)." (defun wl-add-entity (key-path new entity prev-entity-id &optional errmes) (when (string= (caar key-path) (car entity)) - (mapcar - '(lambda (ent) + (let ((entities new)) + (while entities (wl-folder-entity-assign-id - ent - wl-folder-entity-id-name-hashtb - t)) - new) + (pop entities) wl-folder-entity-id-name-hashtb t))) (when (wl-add-entity-sub (cdr key-path) new entity errmes) ;; return value is non-nil (diffs) (wl-fldmgr-add-entity-hashtb new)))) @@ -416,21 +401,16 @@ return value is diffs '(-new -unread -all)." ;; do it (when access ;; remove from unsubscribe - (mapcar - '(lambda (x) - (cond - ((consp x) + (setq new2 new) + (while new2 + (if (consp (car new2)) (setq unsubscribes - (delete (wl-string-assoc (car x) unsubscribes) - unsubscribes))) - (t - (setq unsubscribes (delete (elmo-string x) unsubscribes))))) - new) -;; (setq new2 new) -;; (while new2 -;; (setq unsubscribes (delete (elmo-string (car new2)) unsubscribes)) -;; (setq new2 (cdr new2))) - (setcdr (cddr entity) (list unsubscribes)) + (delq (wl-string-assoc (car (car new2)) unsubscribes) + unsubscribes)) + (setq unsubscribes (delete (elmo-string (car new2)) + unsubscribes))) + (setq new2 (cdr new2))) + (setcdr (cddr entity) (list unsubscribes)) (wl-fldmgr-add-modified-access-list group)) (if (not key-path);; insert group top (if (cddr entity) @@ -455,7 +435,7 @@ return value is diffs '(-new -unread -all)." ;; return value is ;; (path indent-level (group . type) previous-entity-id target-entity) ;; previous-entity-id is (id-name-alist-prev-id . entity-alist-prev-id) -;; example: +;; example: ;; '((("Desktop" group) ("ML" group) "+ml/wl") '(3 2) ("ML" . group) nil "+ml/wl") (defun wl-fldmgr-get-path-from-buffer (&optional prev) @@ -465,27 +445,27 @@ return value is diffs '(-new -unread -all)." (save-excursion (beginning-of-line) (when prev -;; (wl-folder-next-entity-skip-invalid t) -;; (and (setq previous-entity -;; (wl-fldmgr-get-previous-entity wl-folder-entity -;; (wl-fldmgr-get-entity-id))) -;; ;; change entity to id -;; (setq previous-entity -;; (cons -;; (and (car previous-entity) -;; (wl-fldmgr-get-entity-id (car previous-entity))) -;; (and (cdr previous-entity) -;; (wl-fldmgr-get-entity-id (cdr previous-entity)))))) +;;; (wl-folder-next-entity-skip-invalid t) +;;; (and (setq previous-entity +;;; (wl-fldmgr-get-previous-entity wl-folder-entity +;;; (wl-fldmgr-get-entity-id))) +;;; ;; change entity to id +;;; (setq previous-entity +;;; (cons +;;; (and (car previous-entity) +;;; (wl-fldmgr-get-entity-id (car previous-entity))) +;;; (and (cdr previous-entity) +;;; (wl-fldmgr-get-entity-id (cdr previous-entity)))))) (wl-folder-prev-entity-skip-invalid)) (if (and prev (looking-at wl-folder-group-regexp) (string= (wl-match-buffer 2) "-")) (setq group-target nil) (if (and prev (bobp)) - (error "out of desktop group"))) + (error "Out of desktop group"))) (setq folder-path (wl-fldmgr-get-path wl-folder-entity (wl-folder-get-entity-from-buffer) - ;;(wl-fldmgr-get-entity-id) +;;; (wl-fldmgr-get-entity-id) group-target)) (let ((fp folder-path)) (while fp @@ -781,21 +761,24 @@ return value is diffs '(-new -unread -all)." (throw 'found (symbol-value atom))))) wl-fldmgr-add-completion-hashtb))) (pattern - (if (string-match "\\.$" - (car (elmo-network-get-spec - string nil nil nil))) + (if (string-match "\\.$" + (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)) @@ -806,8 +789,8 @@ 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 @@ -826,7 +809,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-completion-function (if wl-fldmgr-add-complete-with-current-folder-list (function wl-fldmgr-add-completion-subr))) tmp indent path diffs) @@ -839,8 +822,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)) @@ -856,18 +840,19 @@ return value is diffs '(-new -unread -all)." (save-excursion (beginning-of-line) (if (looking-at wl-folder-group-regexp) - (error "can't delete group folder")) + (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\"? " + (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-delete-folder entity) + (elmo-folder-delete folder) (wl-fldmgr-cut tmp nil t))))) (defun wl-fldmgr-rename () @@ -880,7 +865,7 @@ return value is diffs '(-new -unread -all)." ((looking-at wl-folder-group-regexp) ;; group (let* ((indent (wl-match-buffer 1)) (old-group (wl-folder-get-realname (wl-match-buffer 3))) - (group-entity (wl-folder-search-group-entity-by-name + (group-entity (wl-folder-search-group-entity-by-name old-group wl-folder-entity)) group) (if (eq (nth 1 group-entity) 'access) @@ -903,32 +888,48 @@ return value is diffs '(-new -unread -all)." (setcar group-entity group) (setcar (wl-string-assoc old-group wl-folder-group-alist) group) - ;;(setcdr (assq id wl-folder-entity-id-name-alist) group) +;;; (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")) (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))) - (error "already exists folder: %s" new-folder)) - (elmo-rename-folder old-folder new-folder) + (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) + (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) @@ -944,15 +945,17 @@ 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) (message "Can't insert access group") (setq group (or group-name (wl-fldmgr-read-string - (read-from-minibuffer + (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)))) @@ -990,9 +993,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 @@ -1011,39 +1015,25 @@ 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))) - (if (eq (cdr (nth 2 tmp)) 'access) - (message "Tan't change access group") - (let* ((entity (nth 4 tmp)) - (old-entity entity) - old-filter - filter new-entity) - (unless entity (error "no folder")) - (when (string-match "^\\(\\(/[^/]+/\\)+\\)\\(.*\\)" entity) - (setq old-filter (substring entity - (match-beginning 1) - (match-end 1))) - (setq old-entity (substring entity - (match-beginning 3) - (match-end 3)))) - (setq filter (completing-read "Filter: " - wl-fldmgr-filter-completion-alist - nil nil - (or old-filter "/"))) - (unless (or (string= filter "") - (string-match "/$" filter)) - (setq filter (concat filter "/"))) - (setq new-entity (concat filter old-entity)) - (let ((entity new-entity) - spec) - ;; check filter syntax - (while (eq - (car (setq spec (elmo-folder-get-spec entity))) - 'filter) - (setq entity (nth 2 spec)))) - (wl-fldmgr-add new-entity))))))) + (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 () (interactive) @@ -1058,7 +1048,7 @@ return value is diffs '(-new -unread -all)." (wl-folder-get-realname (wl-match-buffer 3)) 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)) (setcar (cddr entity) flist) (wl-fldmgr-add-modified-access-list (car entity)) (setq wl-fldmgr-modified t) @@ -1075,7 +1065,7 @@ 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) +;;; (wl-fldmgr-reconst-entity-hashtb t t) (message "Sorting...done") (set-buffer-modified-p nil))))) @@ -1142,8 +1132,8 @@ return value is diffs '(-new -unread -all)." (wl-fldmgr-delete-line) (when (wl-fldmgr-add folder) (wl-folder-maybe-load-folder-list folder) -;; (wl-folder-search-group-entity-by-name (car folder) -;; wl-folder-entity)) +;;; (wl-folder-search-group-entity-by-name (car folder) +;;; wl-folder-entity) (setq execed t))))) ((looking-at (format "^[ ]*%s\\(.*\\)" wl-folder-unsubscribe-mark)) (if (and type (> type 0)) @@ -1243,7 +1233,7 @@ return value is diffs '(-new -unread -all)." (old-petname (or (cdr pentry) "")) (change) petname) - (unless name (error "no folder")) + (unless name (error "No folder")) (if (and is-group (not (eq (nth 1 (wl-folder-search-group-entity-by-name name wl-folder-entity)) @@ -1273,19 +1263,19 @@ return value is diffs '(-new -unread -all)." (progn (if (string= old-petname "") (setq old-petname name)) - (while (wl-folder-buffer-search-group old-petname) - (beginning-of-line) + (while (wl-folder-buffer-search-group old-petname) + (beginning-of-line) (and (looking-at "^\\([ ]*\\)") (setq indent (wl-match-buffer 1))) (wl-fldmgr-delete-line) (wl-folder-insert-entity indent - (wl-folder-search-group-entity-by-name - name wl-folder-entity) + (wl-folder-search-group-entity-by-name + name wl-folder-entity) t))) (while (wl-folder-buffer-search-entity name searchname) (save-excursion - (beginning-of-line) + (beginning-of-line) (and (looking-at "^\\([ ]*\\)") (setq indent (wl-match-buffer 1))) (wl-fldmgr-delete-line)) @@ -1351,8 +1341,7 @@ return value is diffs '(-new -unread -all)." (message "Saving folders...") (set-buffer tmp-buf) (erase-buffer) - (insert (format wl-fldmgr-folders-header - wl-appname wl-version wl-codename)) + (insert wl-fldmgr-folders-header) (wl-fldmgr-delete-disused-petname) (setq save-petname-entities (wl-fldmgr-insert-folders-buffer "" (nth 2 wl-folder-entity))) @@ -1362,7 +1351,7 @@ return value is diffs '(-new -unread -all)." (if (and wl-fldmgr-make-backup (file-exists-p wl-folders-file)) (rename-file wl-folders-file (concat wl-folders-file ".bak") t)) - (let ((output-coding-system (mime-charset-to-coding-system + (let ((output-coding-system (mime-charset-to-coding-system wl-mime-charset))) (write-region (point-min) @@ -1370,7 +1359,7 @@ 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) (while access-list (setq entity (wl-folder-search-group-entity-by-name @@ -1385,6 +1374,7 @@ return value is diffs '(-new -unread -all)." (setq wl-fldmgr-modified-access-list nil) (message "Saving folders...done"))) -(provide 'wl-fldmgr) +(require 'product) +(product-provide (provide 'wl-fldmgr) (require 'wl-version)) ;;; wl-fldmgr.el ends here