X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=wl%2Fwl-refile.el;h=bba8e51804a9de022531d9a56b6d8fad375ae96b;hb=167053919d525e30162c34e574b6452bb858211b;hp=836fe54319d93d8975778c12f96c6877ce8446e7;hpb=1e366a559be4aec4ad4d3cf3e954b8e62a20d2f3;p=elisp%2Fwanderlust.git diff --git a/wl/wl-refile.el b/wl/wl-refile.el index 836fe54..bba8e51 100644 --- a/wl/wl-refile.el +++ b/wl/wl-refile.el @@ -1,10 +1,9 @@ -;;; wl-refile.el -- Refile modules for Wanderlust. +;;; wl-refile.el --- Refile modules for Wanderlust. -;; Copyright 1998,1999,2000 Yuuichi Teranishi +;; Copyright (C) 1998,1999,2000 Yuuichi Teranishi ;; Author: Yuuichi Teranishi ;; Keywords: mail, net news -;; Time-stamp: <00/03/23 19:07:28 teranisi> ;; This file is part of Wanderlust (Yet Another Message Interface on Emacsen). @@ -25,65 +24,76 @@ ;; ;;; Commentary: -;; +;; ;;; Code: -;; +;; (require 'wl-vars) (require 'wl-util) -(provide 'wl-refile) - (defvar wl-refile-alist nil) (defvar wl-refile-alist-file-name "refile-alist") ;; should be renamed to "refile-from-alist" (defvar wl-refile-msgid-alist nil) (defvar wl-refile-msgid-alist-file-name "refile-msgid-alist") +(defvar wl-refile-subject-alist nil) +(defvar wl-refile-subject-alist-file-name "refile-subject-alist") (defvar wl-refile-alist-max-length 1000) (defun wl-refile-alist-setup () - (setq wl-refile-alist - (elmo-object-load - (expand-file-name wl-refile-alist-file-name - elmo-msgdb-dir))) - (setq wl-refile-msgid-alist - (elmo-object-load - (expand-file-name wl-refile-msgid-alist-file-name - elmo-msgdb-dir)))) - -(defun wl-refile-alist-save (file-name alist) - (save-excursion - (let ((filename (expand-file-name file-name - elmo-msgdb-dir)) - (tmp-buffer (get-buffer-create " *wl-refile-alist-tmp*"))) - (set-buffer tmp-buffer) - (erase-buffer) - (if (> (length alist) wl-refile-alist-max-length) - (setcdr (nthcdr (1- wl-refile-alist-max-length) alist) nil)) - (prin1 alist tmp-buffer) - (princ "\n" tmp-buffer) - (if (file-writable-p filename) - (write-region (point-min) (point-max) - filename nil 'no-msg) - (message (format "%s is not writable." filename))) - (kill-buffer tmp-buffer)))) + (let ((flist wl-refile-guess-functions)) + (while flist + (cond + ((eq (car flist) 'wl-refile-guess-by-history) + (setq wl-refile-alist + (elmo-object-load + (expand-file-name wl-refile-alist-file-name + elmo-msgdb-directory) elmo-mime-charset))) + ((eq (car flist) 'wl-refile-guess-by-msgid) + (setq wl-refile-msgid-alist + (elmo-object-load + (expand-file-name wl-refile-msgid-alist-file-name + elmo-msgdb-directory) elmo-mime-charset))) + ((eq (car flist) 'wl-refile-guess-by-subject) + (setq wl-refile-subject-alist + (elmo-object-load + (expand-file-name wl-refile-subject-alist-file-name + elmo-msgdb-directory) elmo-mime-charset)))) + (setq flist (cdr flist))))) + +(defun wl-refile-alist-save () + (if wl-refile-alist + (wl-refile-alist-save-file + wl-refile-alist-file-name wl-refile-alist)) + (if wl-refile-msgid-alist + (wl-refile-alist-save-file + wl-refile-msgid-alist-file-name wl-refile-msgid-alist)) + (if wl-refile-subject-alist + (wl-refile-alist-save-file + wl-refile-subject-alist-file-name wl-refile-subject-alist))) + +(defun wl-refile-alist-save-file (file-name alist) + (if (> (length alist) wl-refile-alist-max-length) + (setcdr (nthcdr (1- wl-refile-alist-max-length) alist) nil)) + (elmo-object-save (expand-file-name file-name elmo-msgdb-directory) + alist elmo-mime-charset)) (defun wl-refile-learn (entity dst) (let (tocc-list from key hit ml) (setq dst (elmo-string dst)) - (setq tocc-list + (setq tocc-list (mapcar (function - (lambda (entity) + (lambda (entity) (downcase (wl-address-header-extract-address entity)))) - (wl-parse-addresses + (wl-parse-addresses (concat (elmo-msgdb-overview-entity-get-to entity) "," (elmo-msgdb-overview-entity-get-cc entity))))) (while tocc-list - (if (wl-string-member - (car tocc-list) + (if (wl-string-member + (car tocc-list) (mapcar (function downcase) wl-subscribed-mailing-list)) (setq ml (car tocc-list) tocc-list nil) @@ -91,19 +101,25 @@ (if ml (setq key ml) ; subscribed entity!! (or (wl-address-user-mail-address-p - (setq from - (downcase + (setq from + (downcase (wl-address-header-extract-address - (elmo-msgdb-overview-entity-get-from + (elmo-msgdb-overview-entity-get-from entity))))) - (setq key from))) - (if (not ml) - (wl-refile-msgid-learn entity dst)) - (if key - (if (setq hit (assoc key wl-refile-alist)) - (setcdr hit dst) - (setq wl-refile-alist - (nconc wl-refile-alist (list (cons key dst)))))))) + (setq key from)) + (if (or wl-refile-msgid-alist + (memq 'wl-refile-guess-by-msgid + wl-refile-guess-functions)) + (wl-refile-msgid-learn entity dst)) + (if (or wl-refile-subject-alist + (memq 'wl-refile-guess-by-subject + wl-refile-guess-functions)) + (wl-refile-subject-learn entity dst))) + (when key + (if (setq hit (assoc key wl-refile-alist)) + (setq wl-refile-alist (delq hit wl-refile-alist))) + (setq wl-refile-alist (cons (cons key dst) + wl-refile-alist))))) (defun wl-refile-msgid-learn (entity dst) (let ((key (elmo-msgdb-overview-entity-get-id entity)) @@ -115,59 +131,99 @@ (setq wl-refile-msgid-alist (cons (cons key dst) wl-refile-msgid-alist)))))) +(defun wl-refile-subject-learn (entity dst) + (let ((subject (wl-summary-subject-filter-func-internal + (elmo-msgdb-overview-entity-get-subject entity))) + hit) + (setq dst (elmo-string dst)) + (if (and subject (not (string= subject ""))) + (if (setq hit (assoc subject wl-refile-subject-alist)) + (setcdr hit dst) + (setq wl-refile-subject-alist (cons (cons subject dst) + wl-refile-subject-alist)))))) + ;; ;; refile guess ;; -(defvar wl-refile-guess-func-list +(defvar wl-refile-guess-functions '(wl-refile-guess-by-rule wl-refile-guess-by-msgid + wl-refile-guess-by-subject wl-refile-guess-by-history) "*Functions in this list are used for guessing refile destination folder.") +;; 2000-11-05: *-func-list -> *-functions +(elmo-define-obsolete-variable 'wl-refile-guess-func-list + 'wl-refile-guess-functions) + (defun wl-refile-guess (entity) - (let ((flist wl-refile-guess-func-list) guess) + (let ((flist wl-refile-guess-functions) guess) (while flist (if (setq guess (funcall (car flist) entity)) (setq flist nil) (setq flist (cdr flist)))) guess)) +(defun wl-refile-evaluate-rule (rule entity) + "Return 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 (stringp value) + (string-match + (car (car pairs)) + value) + (setq guess (wl-expand-newtext + (wl-refile-evaluate-rule (cdr (car pairs)) + entity) + value))) + (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 + (let ((tocc-list (mapcar (function (lambda (entity) (downcase (wl-address-header-extract-address entity)))) - (wl-parse-addresses + (wl-parse-addresses (concat (elmo-msgdb-overview-entity-get-to entity) "," (elmo-msgdb-overview-entity-get-cc entity))))) @@ -187,18 +243,26 @@ (if (string-match "\\([^@]+\\)@[^@]+" address) (wl-match-string 1 address) address)) - + (defun wl-refile-guess-by-from (entity) (let ((from (downcase (wl-address-header-extract-address (elmo-msgdb-overview-entity-get-from entity))))) ;; search from alist (or (cdr (assoc from wl-refile-alist)) - (format "%s/%s" wl-refile-default-from-folder + (format "%s/%s" wl-refile-default-from-folder (wl-refile-get-account-part-from-address from))))) - + (defun wl-refile-guess-by-msgid (entity) (cdr (assoc (elmo-msgdb-overview-entity-get-references entity) wl-refile-msgid-alist))) +(defun wl-refile-guess-by-subject (entity) + (cdr (assoc (wl-summary-subject-filter-func-internal + (elmo-msgdb-overview-entity-get-subject entity)) + wl-refile-subject-alist))) + +(require 'product) +(product-provide (provide 'wl-refile) (require 'wl-version)) + ;;; wl-refile.el ends here