[Mew-dist 14916] mew-pick-from-guess.el (was Re: Can Refile use X-ML-Name?)

[sen_ml at example.com]

From: <sen_ml at example.com>
Subject: [Mew-dist 14890] Re: Can Refile use X-ML-Name?
Date: Thu, 16 Nov 2000 15:04:58 +0900

> 最近ではすっかり mew-refile-guess-alist で明示的に指定する様にしています。

...

> あと、mew-refile-guess-alist の情報をもとに mew-search-summary-mark に渡す 
> pick pattern が生成できるといいと思っています。

ちょっとやってみました。「こんな感じの事がしたいの」的なデモコードとして
みてもらえるとうれしいです。

インストール方法は "Use the Source Luke" ;-)

＃ きょうから温泉に行くので三日ぐらい音信不通になるかも...誰も困らないって？


;;; mew-pick-from-guess.el -- pick based on guess information

;; Author: Sen Nagata <sen at example.com>
;; Keywords: Mew, pick, guess
;; Version: 0.1a -- proof-of-concept, quick hack, bad code
;; Note: This code is based on a lot of code from Mew itself that I didn't
;;       write.

;; Commentary:
;;
;;   This code provides a wrapper around `mew-summary-search-mark' that
;; has a default pick pattern based on information obtained from 
;; the current message in summary mode and `mew-refile-guess-alist'.  The 
;; purpose is to make it easy to mark exactly those messages which would be 
;; refiled to a particular folder based on the current message (and of course 
;; `mew-refile-guess-alist'.  Am I repeating myself?  Yes!
;;
;;   It's a very simple, rough, quick hack -- it's a proof of concept.  It 
;; will only work w/ particular types of values of `mew-refile-guess-alist'.
;;
;;   Recall from Mew info that `mew-refile-guess-alist' has the following 
;; general structure (actually, what I wrote here is a little different):
;;
;;    <rule> ::= '((<key> <alist>) (<key> <alist>) ...)
;;
;;    <alist> ::= ((<value> . <folder>|<rule>) (<value> . <folder>|<rule>) ...)
;;
;;   The code in this file will not deal w/ recursive uses of <rule>.  It may
;; also not work with <value>'s or <key>'s that are regular expressions (i.e. 
;; only strings are supported).
;;
;;   An example `mew-refile-guess-alist' that should work is:
;;
;; (setq mew-refile-guess-alist
;;       '(
;; 	;; List-Id:
;; 	("List-Id:"
;; 	 ("guile-user.gnu.org" . 
;; 	  "+ml/guile-user/")
;; 	 )
;; 	;; X-Mailing-List:
;; 	("X-Mailing-List:"
;; 	 ("gnupg-users at example.com" . 
;; 	  "+ml/gnupg-users/")
;; 	 )
;; 	;; X-ML-Name:
;; 	("X-ML-Name:"
;; 	 ("Mew-dist" . 
;; 	  "+ml/mew-dist/")
;; 	 )
;; 	;; Mailing-List:
;; 	("Mailing-List:"
;; 	 ("pgp-keyserver-folk-help at example.com" .
;; 	  "+ml/pgp-keyserver-folk")
;; 	 )
;; 	;; Sender:
;; 	("Sender:"
;; 	 ("owner-misc at example.com" .
;; 	  "+ml/openbsd-misc")
;; 	 )
;; 	;; likely to be spam
;; 	(nil . "+unsolicited")
;; 	))

;; Notes:
;;
;;   The code doesn't behave well if no <key>s match.  It probably doesn't
;; behave well in other situations too.  This is a demo ;-)

;; To use:
;;
;; -put this file in your load-path
;;
;; -put:
;;
;;    (add-hook 'mew-init-hook
;;              '(lambda ()
;;                  (require 'mew-pick-from-guess)
;;                  (define-key mew-summary-mode-map 
;;                              "k"
;;                              'mew-summary-search-mark-by-guess)))
;;
;;  in your .emacs

(eval-when-compile (require 'mew))

(defun mew-pick-pattern-from-alist ()
  (mew-pick-pattern-from-alist1 mew-refile-guess-alist))

;; implementation has been simplified not to deal w/ roughly the following 
;; kindof case:
;;
;;   <rule>  ::= '((<key> <alist>) (<key> <alist>) ...)
;;   <alist> ::= ((<value> . <rule>) (<value> . <rule>) ...)
;;
;; basically, it doesn't handle recursively specifying rules
(defun mew-pick-pattern-from-alist1 (alist)
  (let (name header sublist key val ent ret)
    (while alist
      (setq name (car (car alist)))
      (setq sublist (cdr (car alist)))
      (cond
       ((eq name t)
	(setq ret (cons sublist ret)))
       ((eq name nil)
	(or ret (setq ret (cons sublist ret))))
       (t
	(setq header (mew-header-get-value name))
	(if header
	    (while sublist
	      (setq key (car (car sublist)))
	      (setq val (cdr (car sublist)))
	      (if (and (stringp key) (string-match key header))
		  (cond
		   ((stringp val)
		    (setq ent 
			  (concat (substring name 0 (- (length name) 1))
				  "="
				  key)))))
	      (if ent
		  (if (listp ent)
		      (setq ret (nconc ent ret) ent nil)
		    (setq ret (cons ent ret))))
	      (setq sublist (cdr sublist))))))
      (setq alist (cdr alist)))
    (mew-uniq-list (nreverse ret))))

(defun mew-pick-pattern-from-msg-and-guess-alist ()
  ;; commented out for using a debugger...
;  (mew-summary-only
;   (mew-summary-msg-or-part
;    (mew-summary-not-in-draft
     (let (fld msg buf pattern)
       (save-excursion
	 ;; save the cursor position anyway
	 (mew-summary-goto-message)
	 ;; on the message
	 (setq fld (mew-summary-folder-name))
	 (setq msg (mew-summary-message-number)));; msg is never nil
       ;; show message if not displayed
       (if (null mew-summary-buffer-disp-msg)
	   (save-excursion
	     (mew-set-buffer-tmp)
	     (setq buf (current-buffer))
	     (mew-insert-message fld msg mew-cs-autoconv
				 mew-header-reasonable-size)
	     (goto-char (point-min))
	     (if (and (re-search-forward (concat "^$\\|^" mew-subj:) nil t)
		      (not (looking-at "^$")))
		 (let ((med (point)))
		   (forward-line)
		   (mew-header-goto-next)
		   (mew-header-decode-region mew-subj: med (point)))))
	 ;; need to make a cache or a message buffer.
	 (mew-summary-display nil)
	 ;; mew-cache-hit should be first since we want to get 
	 ;; information form the top level header.
	 (setq buf (or (mew-cache-hit fld msg) (mew-buffer-message))))

       (save-excursion
	 (set-buffer buf)
	 (setq pattern (mew-pick-pattern-from-alist)))
       ;; what we were after...
       pattern)
     ;; commented for debugging
;     )))
     )

(defun mew-summary-search-mark-by-guess (&optional arg)
  "Pick messages according to a pick pattern which you input or using
a pattern computed via the current message and `mew-refile-guess-alist', 
then put the '*' mark onto them. If called with '\\[universal-argument]', 
execute 'mew-summary-pick-with-external'. Otherwise, 
'mew-summary-pick-with-imls' is called.

Warning: this documentation may be wrong.  Use the source Luke!"
  (interactive "P")
  (let ((mew-pick-default-field (mew-pick-pattern-from-msg-and-guess-alist)))
    (mew-summary-search-mark arg)))

(provide 'mew-pick-from-guess)