From: teranisi Date: Tue, 4 Apr 2000 04:40:40 +0000 (+0000) Subject: * wl-summary.el (wl-summary-print-destination): X-Git-Tag: wl-1_1_1~66 X-Git-Url: http://git.chise.org/cgi-bin/gitweb.cgi?a=commitdiff_plain;h=15dcdc8f245eac9f08b29ef28d7b7406be084f8c;p=elisp%2Fwanderlust.git * wl-summary.el (wl-summary-print-destination): Duplicate folder string to avoid putting text-property on original string. * wl-refile.el (wl-refile-get-field-value): New function. (wl-refile-evaluate-rule): New function; Evaluate refile rule recursively. (wl-refile-guess-by-rule): Use wl-refile-evaluate-rule. * wl-summary.el (wl-summary-auto-refile-check-refile-rule-alist-subr): New function; Check existence of a target folder recursively. (wl-summary-auto-refile-check-refile-rule-alist): Use wl-summary-auto-refile-check-refile-rule-alist-subr. --- diff --git a/wl/ChangeLog b/wl/ChangeLog index 7485720..2a998e5 100644 --- a/wl/ChangeLog +++ b/wl/ChangeLog @@ -1,3 +1,18 @@ +2000-04-04 Yuuichi Teranishi + + * wl-summary.el (wl-summary-print-destination): + Duplicate folder string to avoid putting text-property on + original string. + + * wl-refile.el (wl-refile-get-field-value): New function. + (wl-refile-evaluate-rule): New function; + Evaluate refile rule recursively. + (wl-refile-guess-by-rule): Use wl-refile-evaluate-rule. + * wl-summary.el (wl-summary-auto-refile-check-refile-rule-alist-subr): + New function; Check existence of a target folder recursively. + (wl-summary-auto-refile-check-refile-rule-alist): + Use wl-summary-auto-refile-check-refile-rule-alist-subr. + 2000-03-30 Yuuichi Teranishi * wl-demo.el (wl-title-logo): Refer wl-icon-dir. diff --git a/wl/wl-refile.el b/wl/wl-refile.el index 836fe54..b144b14 100644 --- a/wl/wl-refile.el +++ b/wl/wl-refile.el @@ -4,7 +4,7 @@ ;; Author: Yuuichi Teranishi ;; Keywords: mail, net news -;; Time-stamp: <00/03/23 19:07:28 teranisi> +;; Time-stamp: <2000-04-04 11:38:57 teranisi> ;; This file is part of Wanderlust (Yet Another Message Interface on Emacsen). @@ -132,35 +132,56 @@ (setq flist (cdr flist)))) guess)) +(defun wl-refile-evaluate-rule (rule entity) + "Returns folder string if RULE is matched to ENTITY. +If RULE does not match ENTITY, returns nil." + (let ((case-fold-search t) + fields guess pairs value) + (cond + ((stringp rule) rule) + ((listp (car rule)) + (setq fields (car rule)) + (while fields + (if (setq guess (wl-refile-evaluate-rule (append (list (car fields)) + (cdr rule)) + entity)) + (setq fields nil) + (setq fields (cdr fields)))) + guess) + ((stringp (car rule)) + (setq pairs (cdr rule)) + (setq value (wl-refile-get-field-value entity (car rule))) + (while pairs + (if (and (string-match + (car (car pairs)) + value) + (setq guess (wl-refile-evaluate-rule (cdr (car pairs)) + entity))) + (setq pairs nil) + (setq pairs (cdr pairs)))) + guess) + (t (error "Invalid structure for wl-refile-rule-alist"))))) + +(defun wl-refile-get-field-value (entity field) + "Get FIELD value from ENTITY." + (let ((field (downcase field)) + (fixed-fields '("from" "subject" "to" "cc"))) + (if (member field fixed-fields) + (funcall (symbol-function + (intern (concat + "elmo-msgdb-overview-entity-get-" + field))) + entity) + (elmo-msgdb-overview-entity-get-extra-field entity field)))) + (defun wl-refile-guess-by-rule (entity) (let ((rules wl-refile-rule-alist) - (rule-set) (field) (field-cont)) - (catch 'found - (while rules - (setq rule-set (cdr (car rules)) - field (car (car rules))) - (cond ((string-match field "From") - (setq field-cont - (elmo-msgdb-overview-entity-get-from entity))) - ((string-match field "Subject") - (setq field-cont - (elmo-msgdb-overview-entity-get-subject entity))) - ((string-match field "To") - (setq field-cont - (elmo-msgdb-overview-entity-get-to entity))) - ((string-match field "Cc") - (setq field-cont - (elmo-msgdb-overview-entity-get-cc entity))) - (t - (setq field-cont - (elmo-msgdb-overview-entity-get-extra-field - entity (downcase field))))) - (if field-cont - (while rule-set - (if (string-match (car (car rule-set)) field-cont) - (throw 'found (cdr (car rule-set))) - (setq rule-set (cdr rule-set))))) - (setq rules (cdr rules)))))) + guess) + (while rules + (if (setq guess (wl-refile-evaluate-rule (car rules) entity)) + (setq rules nil) + (setq rules (cdr rules)))) + guess)) (defun wl-refile-guess-by-history (entity) (let ((tocc-list diff --git a/wl/wl-summary.el b/wl/wl-summary.el index b62d9c5..5aaf9ad 100644 --- a/wl/wl-summary.el +++ b/wl/wl-summary.el @@ -4,7 +4,7 @@ ;; Author: Yuuichi Teranishi ;; Keywords: mail, net news -;; Time-stamp: <00/03/22 01:00:41 teranisi> +;; Time-stamp: <2000-04-04 13:36:01 teranisi> ;; This file is part of Wanderlust (Yet Another Message Interface on Emacsen). @@ -3247,6 +3247,7 @@ If optional argument NUMBER is specified, mark message specified by NUMBER." "Print refile destination on line." (wl-summary-remove-destination) (let ((inhibit-read-only t) + (folder (copy-sequence folder)) (buffer-read-only nil) len rs re c) (setq len (string-width folder)) @@ -3403,18 +3404,34 @@ If optional argument NUMBER is specified, mark message specified by NUMBER." (defsubst wl-summary-no-auto-refile-message-p (msg mark-alist) (member (cadr (assq msg mark-alist)) wl-summary-auto-refile-skip-marks)) +(defun wl-summary-auto-refile-check-refile-rule-alist-subr (rule dsts) + "Collect destination folders from rule." + (if (stringp rule) + (if (member rule dsts) + dsts + (setq dsts (cons rule dsts))) + ;; A rule. + (let (pairs sub-dsts) + (setq pairs (cdr rule)) + (while pairs + (setq dsts + (wl-summary-auto-refile-check-refile-rule-alist-subr + (cdr (car pairs)) dsts)) + (setq pairs (cdr pairs)))) + dsts)) + (defun wl-summary-auto-refile-check-refile-rule-alist () (when wl-refile-rule-alist (message "Checking destination folders...") - (let ((ralist wl-refile-rule-alist) - pairs dsts) - (while ralist - (setq pairs (cdr (car ralist))) - (while pairs - (if (not (member (cdr (car pairs)) dsts)) - (setq dsts (cons (cdr (car pairs)) dsts))) - (setq pairs (cdr pairs))) - (setq ralist (cdr ralist))) + (let ((rules wl-refile-rule-alist) + dsts) + (while rules + (setq dsts + (append + (wl-summary-auto-refile-check-refile-rule-alist-subr + (car rules) nil) + dsts)) + (setq rules (cdr rules))) (mapcar 'wl-folder-confirm-existence dsts))