[Mew-dist 15383] mew-search-mark-via-guess.el 0.1b

[sen_ml at example.com]

特定のメーリングリストからのメールを "?" `mew-summary-search-mark' で mark
するために指定する pick pattern を何度も入力するのが手間だったので、
current message から pick pattern を 推測するコードを書いて見ました。

インストール方法：

1) mew-search-mark-via-guess.el を load-path 上におく

2) .emacs に

     (add-hook 'mew-init-hook
               '(lambda ()
                  (require 'mew-search-mark-via-guess)
                  (define-key mew-summary-mode-map 
	                        "\C-c9?" ; 9 looks like g (g for guess)
			        'mew-search-mark-via-ml-guess)))

   を追加する。

試し方：

summary-mode で特定のメーリングリストからのメッセージに相当する行で

  C-c 9 ? 

ととなえてみてください。

＃ Mew 1.95b8x でしか試していませんが、1.94.x でも動くかもしれません。
-------------- next part --------------
;;; mew-search-mark-via-guess.el

;; Author: Sen Nagata <sen at example.com>
;; Keywords: Mew, search, mark, guess, ml
;; Version: 0.1b

;; Commentary:
;;
;;   Tired of typing in pick patterns for messages from mailing lists?
;; I was.  The result of my laziness is this code.
;;
;;   This code provides a command named `mew-search-mark-via-ml-guess'.
;; The command attempts to guess a suitable pick pattern that can be used
;; to identify messages posted to a particular mailing list.  
;;
;;   Note: Using it on messages that were not posted to a particular mailing 
;; list may or may not be useful ;-)
;;
;;   After examining some headers, the command constructs a pick pattern for 
;; use as a default pick pattern for the command `mew-summary-search-mark'.
;;
;;   For details of which headers are examined and precedence information, 
;; see the docstring for `mew-guess-ml-pick-pattern-helper'.

;; Installation:
;;
;;   -put this file in a driectory in your `load-path'
;;
;;   -put:
;;
;;     (add-hook 'mew-init-hook
;;               '(lambda ()
;;                  (require 'mew-search-mark-via-guess)
;;                  (define-key mew-summary-mode-map 
;;	                        "\C-c9?" ; 9 looks like g (g for guess)
;;			        'mew-search-mark-via-ml-guess)))
;;
;;    in your .emacs.

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

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

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; note: "smvg" stands for "search-mark-via-guess"

(defun mew-smvg-extract-list-id-value (list-id)
  (if (string-match "<\\([^>]+\\)>" list-id)
      (downcase (match-string 1 list-id))
    (error "Unable to extract a value for `%s'." list-id)))

(defun mew-smvg-extract-x-mailing-list-value (x-mailing-list)
  (if (string-match "<\\([^>]+\\)>" x-mailing-list)
      (downcase (match-string 1 x-mailing-list))
    (error "Unable to extract a value for `%s'." x-mailing-list)))

(defun mew-smvg-extract-x-ml-name-value (x-ml-name)
  (downcase x-ml-name))

(defun mew-smvg-extract-mailing-list-value (mailing-list)
  (if (string-match "list \\([^@]+@[^; ]+\\)" mailing-list)
      (downcase (match-string 1 mailing-list))
    (if (string-match "contact \\([^@]+@[^; ]+\\)" mailing-list)
	(downcase (match-string 1 mailing-list))
      (error "Unable to extract a value for `%s'." mailing-list))))

(defun mew-smvg-extract-sender-value (sender)
  (downcase sender))

(defun mew-smvg-extract-to-value (to)
  (downcase to))

(defun mew-make-simple-pick-pattern (name value)
  "Construct a simple pick pattern from NAME and VALUE.

NAME is a header name including the trailing colon.
VALUE is a (substring of a) header value."
  (if (not (string-match "^\\([^:]+\\):$" name))
      (error "The header name is incorrectly formatted: `%s'." name)
    (concat (match-string 1 name) "=" value)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun mew-guess-ml-pick-pattern-helper ()
  "Helper function for `mew-guess-ml-pick-pattern'.
Note: This function assumes it is called from `mew-guess-ml-pick-pattern'.

This function examines the headers for a particular message assumed to
be posted to a particular mailing list.  It returns a pick pattern meant to 
identify messages to the same particular mailing list.

The following headers are examined:

  List-Id
  X-Mailing-List
  X-ML-Name
  Mailing-List
  Sender
  To

Headers that appear earlier in the list take precedence over later headers."
  (let ((list-id 
	 (mew-header-get-value "List-Id:"))
	(x-mailing-list 
	 (mew-header-get-value "X-Mailing-List:"))
	(x-ml-name
	 (mew-header-get-value "X-ML-Name:"))
	(mailing-list
	 (mew-header-get-value "Mailing-List:"))
	(sender
	 (mew-header-get-value "Sender:"))
	(to
	 (mew-header-get-value "To:"))
	ml-guess-pattern)
    
    (setq ml-guess-pattern
	  (cond 

	   ;; best case, imo -- everyone should use this ;-)
	   (list-id
	    (mew-make-simple-pick-pattern 
	     "List-Id:" 
	     (mew-smvg-extract-list-id-value list-id)))
	   
	   ;; not great, but at least the header name is prefixed w/ "X-"
	   (x-mailing-list
	    (mew-make-simple-pick-pattern 
	     "X-Mailing-List:" 
	     (mew-smvg-extract-x-mailing-list-value x-mailing-list)))

	   ;; see comment for "X-Mailing-List:" above...
	   ;; most likely a mailing list run in japan or using mailing list
	   ;; software developed in japan
	   (x-ml-name
	    (mew-make-simple-pick-pattern 
	     "X-ML-Name:"
	     (mew-smvg-extract-x-ml-name-value x-ml-name)))
	   
	   ;; i smell ezmlm ;-)
	   (mailing-list
	    (mew-make-simple-pick-pattern 
	     "Mailing-List:"
	     (mew-smvg-extract-mailing-list-value mailing-list)))
	   
	   ;; second to last resort -- works surprisingly well on
	   ;; bsd-type lists
	   (sender
	    (mew-make-simple-pick-pattern 
	     "Sender:"
	     (mew-smvg-extract-sender-value sender)))
	   
	   ;; last resort -- this can catch some announcement lists
	   ;; could also look at From: -- but i won't for now
	   (to
	    (mew-make-simple-pick-pattern
	     "To:"
	     (mew-smvg-extract-to-value to)))
	   
	   ;; if none of the headers above exist, something is likely
	   ;; to be wrong w/ the message
	   (t
	    "")))

    ml-guess-pattern))

(defun mew-guess-ml-pick-pattern ()
  ;; 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-guess-ml-pick-pattern-helper)))
       ;; what we were after...
       pattern)
     ;; commented for debugging
;     )))
     )

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun mew-search-mark-via-ml-guess (&optional arg)
  "Pick messages according to a pick pattern which you input, 
then put the '*' mark onto them.  The default pattern is guessed by examining
the headers of the message.  See `mew-guess-ml-pick-pattern-helper' for
details.

If called with '\\[universal-argument]', execute 
'mew-summary-pick-with-external'. Otherwise, 'mew-summary-pick-with-imls' is 
called."
  (interactive "P")
  (let ((mew-pick-default-field (mew-guess-ml-pick-pattern)))
    (mew-summary-search-mark arg)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(provide 'mew-search-mark-via-guess)