[Mew-dist 15082] mew-mlm.el 0.1q (experimental release)
sen_ml at example.com
sen_ml at example.com
2000年 11月 27日 (月) 10:51:31 JST
mew-mlm.el に機能を追加しました:
mew-summary-search-mark ライクな
mew-mlm-search-mark-via-list-choice
mew-mlm-search-mark-via-guess
mew-refile-guess-* 系の
mew-refile-guess-by-ml
メーリングリストとのやりとりのための
mew-mlm-help
mew-mlm-subscribe
mew-mlm-post
mew-mlm-owner
あと、keybinding と menu もとりあえず定義しておいたので、試しやすく
なったと思います。
＃ menu は summary-mode のメニューの中に忍び込ませて起きました。
では
-------------- next part --------------
;;; mew-mlm.el -- mailing list mgmt support
;; Author: Sen Nagata <sen at example.com>
;; Keywords: Mew, mailing list management
;; Version: 0.1q
;; Note: Some of this code is based on code in Mew.
;; Prerequisites:
;;
;; Mew-1.95bX (X >= 78)
;; mew-browse.el (see contrib for Mew)
;; Usage:
;;
;; 1) put this file in your load-path
;;
;; 2) put:
;;
;; (add-hook 'mew-init-hook
;; '(lambda ()
;; (require 'mew-mlm)))
;;
;; in your .emacs.
;; Commands and functions to try:
;;
;; Mailing list information management commands
;;
;; `mew-mlm-add-entry-via-guess-interactively'
;; `mew-mlm-edit-entry-via-guess-interactively'
;; `mew-mlm-edit-entry-interactively'
;; `mew-mlm-delete-entry-interactively'
;;
;; Mailing list interaction commands
;;
;; `mew-mlm-help'
;; `mew-mlm-unsubscribe'
;; `mew-mlm-subscribe'
;; `mew-mlm-post'
;; `mew-mlm-owner'
;; `mew-mlm-unsubscribe-from-this-list'
;; `mew-mlm-post-to-this-list'
;;
;; Search-Mark commands
;;
;; `mew-mlm-search-mark-via-list-choice'
;; `mew-mlm-search-mark-via-guess'
;;
;; Refile-Guess function:
;;
;; `mew-refile-guess-by-ml'
;;
;; Note: There is now a submenu in the Mew menu from which you can
;; access some of these commands.
;; NEAR-TERM TODO:
;;
;; -consider custom prompt functions for each field in entry. when
;; prompting for parents, limit possibilities to existing keys in
;; `mew-mlm-master-alist'
;;
;; -note that list actions may be tied to non-mailto urls. modify
;; code to handle those cases.
;;
;; -additional list action functions:
;;
;; -use browser to visit archive
;; -search remote (web only?) archive
;; -search local folder
;;
;; -functions which guess list first, then perform list actions
;;
;; -test ;-)
;;
;; MEDIUM-TERM TODO:
;;
;; -split this code into multiple files?
;;
;; -additional keybindings and menus
;;
;; -want a nicer user interface for manipulating the contents of
;; mew-mlm-master-alist -- e.g. widget-based. it seems like forms mode
;; ought to handle lisp data structures...alternatively, create a
;; specific mode (cf. mhc)
;;
;; -check user input for list-* fields. e.g. don't accept strings that
;; don't contain urls, for instance. how about for other fields?
;;
;; -for guessing possible values for creating a new entry, consider
;; providing alternatives for each field using completion on seemingly
;; meaningful values extracted from message
;;
;; -could store filter-info as a string (i.e. like a header line)
;;
;; -store values to help construct urls to perform searches of archives.
;; support multiple locations to search?
;;
;; -for replacement of an existing entry, consider comparing the new
;; entry contents w/ the old entry contents. if they are the same,
;; there's no need to change anything.
;;
;; LONG-TERM TODO:
;;
;; -function which tries to extract ml info from help messages for
;; various mailing list packages. e.g. with cursor on a help message in
;; summary mode, execute `mew-mlm-merge-unsubscribe-info-from-message'
;; or some such. is it a good idea to try to merge multiple pieces of
;; info (e.g. unsubscribe info and subscribe info)?
;;
;; -store values to point to other entries for handling lists that split,
;; move machines, change mailing list software, etc. note that this will
;; require altering the functions which manipulate entries in
;; `mew-mlm-master-alist' in order to maintain integrity of "associations".
;; e.g. when removing an entry, need to do something about all entries
;; that "point to" the entry about to be removed.
;;
;; -fetching and importing archives
;;
;; -add relevant `mew-summary-msg' etc. macros to appropriate places
;;
;; UNKNOWN TODO:
;;
;; -accumulate iist admin address info in entry so admin messages can
;; also be refiled easily?
;;
;; -option for not saving changes to `mew-mlm-master-alist'?
;;
;; -function to check the contents of `mew-mlm-master-alist' and report
;; on contents (e.g. number of entries, missing info, possible
;; inconsistencies, etc.)
;;
;; -currently have entry selectors which get passed entries. would it
;; be better to have entry selectors which get passed keys? how about
;; having both?
;;
;; -rewrite code using more functions from Mew
;;
;; -providing ability to choose from various values via completion is
;; good. however, it would be nice to be able to indicate some kind of
;; priority or preference among choices. cf. items further to the left
;; in a list are considered better choices in RFC 2369 header values.
;;
;; -list status? defunct, alive, etc.
;;
;; -subscription status? subscribed, unsubscribed, etc.
;;
;; -making a version of this that's usable from other mail clients in
;; addition to mew
;;
;; -import/export functions to an external data format -- XML for
;; non-emacs mail clients? note: issue of exporting sensitive data:
;; auth-info and some (un)subscription info contain user addresses and/or
;; names. could decide not to store the info in `mew-mlm-master-alist',
;; but instead as attachments when the editing mode is complete...
;;
;; -does it make sense to suggest that `mew-browse-url-mailto' handle
;; urls enclosed in brackets? probably not. may be a new function
;; to operate on objects near/around point.
;;
;; -for a function like `mew-mlm-unsubscribe', could decide not to show
;; items that don't have unsubscribe info (in completion lists for example)
;;
;; -editing of filter information. specific mode for editing and
;; viewing (cf. mhc) should take care of this concern?
;;
;; -provide some way of viewing contents of `mew-mlm-master-alist'.
;; specific mode for editing and viewing (cf. mhc) should take care of
;; this concern?
;;
;; -function for adding entry from scratch w/o guessing. specific mode
;; for editting and viewing (cf. mhc) should take care of this concern?
;;
;; -store folder to refile into?
;;
;; -for folder naming, perhaps allow the calculated value to be overridden
;; by a stored value. some list-ids are long; will that cause any problems
;; (limit of 255 chars)? ponder how to deal w/ changes in name of
;; key for list...
;;
;; -folder renaming potentially affects information stored in a number of
;; places. some of these are:
;;
;; .mew-folder-list
;; .mew-folder-alist
;; .mew-refile-msgid-alist
;; .mew-refile-from-alist
;;
;; if you don't think of these things as a "log", changing their contents
;; doesn't seem too bad.
;;
;; -edit .mew-alias mode?
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; dependencies
(eval-when-compile
(require 'mew)
(require 'mew-browse)) ; for `mew-browse-url-mailto' (see SRC/contrib)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; variable definitions
(defvar mew-mlm-master-alist nil
"Alist for storing mailing list information.
Each key is a string identifying a single mailing list. Each associated
value stores information for a single mailing list.
See the definition of `mew-mlm-make-entry' for structural details
of each entry.
Note that the alist is initialized from and stored in
`mew-mlm-master-alist-file'.
Note: expect the stored data format to change a bit.")
(defvar mew-mlm-master-alist-file ".mew-mlm-master-alist"
"File for initializing and storing `mew-mlm-master-alist'.")
(defvar mew-mlm-guess-alist nil
"Constructed alist for storing guess information.
This alist is constructed from `mew-mlm-master-alist'. It's integrity should
be maintained by the code in this file. It is not intended to altered
directly.")
(defvar mew-mlm-folder-prefix "+ml/"
"Prefix string used to construct the folder associated with a particular
mailing list.
For a given list, `mew-mlm-compute-folder-name' is used to compute the
corresponding folder. Change this prefix string or redefine
`mew-mlm-folder-name' to change folder name computing behavior.
`mew-mlm-entry:folder' determines the folder associated with a particular
mailing list. Currently, the function calls `mew-mlm-computer-folder-name'.
To change folder naming behavior, change `mew-mlm-entry:folder' -- e.g.
a stored value for a folder name could be queried and if that doesn't
exist, a folder name could be computed.")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; secondary storage (persistence) functions
(defun mew-mlm-load-master-alist ()
"Load `mew-mlm-master-alist' from `mew-mlm-master-alist-file'."
(interactive)
(setq mew-mlm-master-alist (mew-lisp-load mew-mlm-master-alist-file)))
(defun mew-mlm-save-master-alist ()
"Save `mew-mlm-master-alist' to `mew-mlm-master-alist-file'."
(interactive)
(mew-lisp-save mew-mlm-master-alist-file mew-mlm-master-alist))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; constructors and selectors for entries of `mew-mlm-master-alist'
;; no mutators?
;; expect this to change (number and type of fields)
(defun mew-mlm-make-entry (key
help unsubscribe subscribe post owner archive
filter-info auth-info search-list parents)
"Construct an entry from arguments.
KEY is a string to identify the entry. One possible choice would be
the List-Id value. This might not be the best choice, but it's what
will be used for the moment.
HELP, UNSUBSCRIBE, SUBSCRIBE, POST, OWNER, and ARCHIVE are lists of
strings containing angle-bracket enclosed URLs. These arguments
represent the corresponding List-* header values from RFC 2369.
An example value for POST is \"<mailto:mew-dist at example.com>\".
FILTER-INFO is a cons cell. The car and cdr are strings representing
the mail header name (includes colon) and corresponding header value
that are used to identify which mailing list a particular message is
associated with.
AUTH-INFO is a string. It contains user authentication info for the
given list. The format of the string is free-form for the moment.
For example, it might contain a user name and password.
SEARCH-LIST is a list. Each element is a cons cell. The car and cdr
are strings that are concatenated on the left and right sides of a
URL-escaped search string to form a URL (HTTP being the main use) that
when accessed should return search results.
PARENTS is a list. Each element is a string corresponding to the key
of some other \"parent\" entry in `mew-mlm-master-alist'. The purpose of
this field is to provide a means of supporting associations between lists
which are historically related. Examples of historical relations are:
1) A list was moved from one machine to another, and the machine's
DNS name was changed. Consequently, the List-Id value changes.
2) Software used to host a list was changed. Consequently, List-*
information changed.
3) List splits into two pieces.
4) The membership from two mailing lists was merged into one list.
Note that SEARCH-LIST and PARENTS functionality is currently
unimplemented.
This is a low-level utility function intended for use by other functions."
(cons key (list (cons "help" help)
(cons "unsubscribe" unsubscribe)
(cons "subscribe" subscribe)
(cons "post" post)
(cons "owner" owner)
(cons "archive" archive)
(cons "filter-info" filter-info)
(cons "auth-info" auth-info)
(cons "search-list" search-list)
(cons "parents" parents))))
;; the selectors could probably all be defined via macros -- but edebug
;; usage becomes complicated, so forget it.
(defun mew-mlm-entry:key (entry)
(car entry))
;; TODO: rewrite selectors below in terms of this function?
(defun mew-mlm-entry-field (entry field-name)
(cdr (assoc field-name (cdr entry))))
(defun mew-mlm-entry:help (entry)
(cdr (assoc "help" (cdr entry))))
(defun mew-mlm-entry:unsubscribe (entry)
(cdr (assoc "unsubscribe" (cdr entry))))
(defun mew-mlm-entry:subscribe (entry)
(cdr (assoc "subscribe" (cdr entry))))
(defun mew-mlm-entry:post (entry)
(cdr (assoc "post" (cdr entry))))
(defun mew-mlm-entry:owner (entry)
(cdr (assoc "owner" (cdr entry))))
(defun mew-mlm-entry:archive (entry)
(cdr (assoc "archive" (cdr entry))))
(defun mew-mlm-entry:filter-info (entry)
(cdr (assoc "filter-info" (cdr entry))))
(defun mew-mlm-entry:auth-info (entry)
(cdr (assoc "auth-info" (cdr entry))))
(defun mew-mlm-entry:search-list (entry)
(cdr (assoc "search-list" (cdr entry))))
(defun mew-mlm-entry:parents (entry)
(cdr (assoc "parents" (cdr entry))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; folder naming
;; TODO: first attempt at naming folders
(defun mew-mlm-compute-folder-name (entry)
(concat mew-mlm-folder-prefix (mew-mlm-entry:key entry)))
(defun mew-mlm-entry:folder (entry)
;; TODO: could check for stored value before computing
(mew-mlm-compute-folder-name entry))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; string manipulation functions
;; TODO: perhaps should return nil instead of calling `error' for functions
;; in this section
;; TODO: figure out when to use `error' and when to use `message'
(defun mew-mlm-extract-abes-from-string (string)
"Extract an abes (angle-bracket-enclosed string) from STRING."
(if (string-match "\\(<[^>]+>\\)" string)
(match-string 1 string)
(error "`%s' does not appear to contain an angle-bracket-enclosed string."
string)))
(defun mew-mlm-strip-enclosing-angle-brackets (abes)
"Strip enclosing angle brackets from ABES (angle-bracket-enclosed string)."
(if (string-match "^<\\([^>]+\\)>$" abes)
(match-string 1 abes)
(error "`%s' does not appear to be an angle-bracket-enclosed string."
abes)))
;; TODO: should work for most simple cases
(defun mew-mlm-extract-address-from-string (string)
"Extract an email address from STRING."
(if (string-match "<\\([^@]+@[^@]+\\)>" string)
(match-string 1 string)
(if (string-match "\\([^ \t@<]+@[^ \t@>]+\\)" string)
(match-string 1 string)
(error "`%s' does not appear to contain an address." string))))
;; TODO: quick hack -- haven't checked standards
(defun mew-mlm-make-list-id-from-address (address)
"Convert ADDRESS into a list-id value.
ADDRESS is a simple email address (i.e. user at example.com).
Returns a list-id value on success, nil otherwise."
(if (string-match "^\\([^@]+\\)@\\([^@]+\\)$" address)
(concat (match-string 1 address)
"."
(match-string 2 address))
nil))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; prompting-related functions
(defun mew-mlm-string-to-list (string)
"Convert a comma-separated string into a list."
(split-string string ",[ \t]+"))
(defun mew-mlm-list-to-string (list)
"Convert a list into a comma-separated list."
(mapconcat (lambda (elt) elt) list ", "))
(defun mew-mlm-list-to-alist (list)
"Convert LIST into an alist.
Each element of LIST becomes a key in alist. Each value associated with
each key is nil."
(mapcar (lambda (elt)
(cons elt nil))
list))
(defun mew-mlm-prompt-for-string (prompt default)
"Prompt user for a string value represented as a string.
PROMPT is the minibuffer prompt. DEFAULT is a default string."
(read-from-minibuffer prompt default))
;; TODO: consider possible "escaping commas (separators)" issue
(defun mew-mlm-prompt-for-list (prompt default-list)
"Prompt user for a list value represented as a string.
PROMPT is the minibuffer prompt. DEFAULT-LIST is a list of values used
to create a default string.
The string is split on commas to create multiple elements for a list.
By using commas, the user can express multiple values as a string.
Spaces are not a good choice because individual values are likely to contain
them."
(mew-mlm-string-to-list
(read-from-minibuffer prompt (mew-mlm-list-to-string default-list))))
;; TODO: probably ok to allow list to have only one element
(defun mew-mlm-prompt-from-list-with-default (prompt list default)
"Prompt user for a choice from LIST.
PROMPT is used to construct the prompt.
DEFAULT is displayed and used as a default value.
Supports completion."
(if (and (not (null list)) (listp list))
(completing-read
(format (concat prompt " (%s): ") default)
(mew-mlm-list-to-alist list)
nil t nil nil default)
(error "List empty or argument not list.")))
(defun mew-mlm-prompt-for-header-line (prompt default)
"Prompt user for a header line.
PROMPT is used as a prompt.
DEFAULT is displayed and used as a default value.
Returns a cons cell if successful. The car is the header name and the
cdr is the header value.
If unsuccessful at reading a proper header line, return nil.
Think of a header line as a complete header line from a mail message."
(let* ((input
(read-from-minibuffer prompt default nil nil nil default))
name value)
(if (string-match "\\([^:]+:\\)[ ]+\\([^ ]+.*\\)" input)
(cons (match-string 1 input)
(match-string 2 input))
nil)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; functions related to manipulating `mew-mlm-master-alist'
(defun mew-mlm-get-entry (key)
"Retrieve entry keyed to KEY from `mew-mlm-master-alist'.
This is a low-level utility function intended for use by other functions."
(let ((entry (assoc key mew-mlm-master-alist)))
(if (not entry)
(error "There is no entry with key `%s'." key)
entry)))
(defun mew-mlm-key-exists-p (key)
"Check existence for entry keyed to KEY.
If entry exists, return t, otherwise return nil."
(if (assoc key mew-mlm-master-alist)
t
nil))
(defun mew-mlm-delete-entry (key)
"Delete entry keyed to KEY from `mew-mlm-master-alist'.
This is a low-level utility function intended for use by other functions."
(let ((entry (mew-mlm-get-entry key)))
(if entry
(progn
;; see doc for `delq' for explanation of `setq' in following line
(setq mew-mlm-master-alist (delq entry mew-mlm-master-alist))
(setq mew-mlm-guess-alist (mew-mlm-make-guess-alist)))
;; redundant given the definition of `mew-mlm-get-entry'?
(error "There is no entry with key `%s'." key))))
(defun mew-mlm-add-new-entry (entry)
"Add a new entry to `mew-mlm-master-alist'.
This is a low-level utility function intended for use by other functions."
(if (assoc (car entry) mew-mlm-master-alist)
(error "An entry with the key `%s' already exists." (car entry))
(progn
(setq mew-mlm-master-alist
(cons entry mew-mlm-master-alist))
(setq mew-mlm-guess-alist (mew-mlm-make-guess-alist)))))
(defun mew-mlm-replace-entry (from-entry to-entry)
"Replace entry FROM-ENTRY with entry TO-ENTRY in `mew-mlm-master-alist'.
This is a low-level utility function intended for use by other functions."
;; see doc for `delq' for explanation of `setq' in following line
(setq mew-mlm-master-alist
(delq from-entry mew-mlm-master-alist))
(setq mew-mlm-master-alist
(cons to-entry mew-mlm-master-alist))
(setq mew-mlm-guess-alist (mew-mlm-make-guess-alist)))
;; TODO: decide whether second argument should be optional
(defun mew-mlm-copy-and-morph-entry (entry check-for-key)
"Allow the user to create a new entry based on ENTRY.
If CHECK-FOR-KEY is t, the existence of the user-specified
key is checked for in `mew-mlm-master-alist'.
This is a helper function for `mew-mlm-add-entry-via-guess-interactively'
and `mew-mlm-edit-entry-interactively'."
(let ((key (mew-mlm-entry:key entry))
(help (mew-mlm-entry:help entry))
(unsubscribe (mew-mlm-entry:unsubscribe entry))
(subscribe (mew-mlm-entry:subscribe entry))
(post (mew-mlm-entry:post entry))
(owner (mew-mlm-entry:owner entry))
(archive (mew-mlm-entry:archive entry))
(filter-info (mew-mlm-entry:filter-info entry))
(auth-info (mew-mlm-entry:auth-info entry))
(search-list (mew-mlm-entry:search-list entry))
(parents (mew-mlm-entry:parents entry))
key-good)
(while (not key-good)
(setq key
(mew-mlm-prompt-for-string "Key: " key))
(if (equal key "")
(progn
(message "The empty string is not allowed as a key.")
(sit-for 1))
(if (and check-for-key
(mew-mlm-key-exists-p key))
(progn
(message "That key exists already.")
(sit-for 1))
(setq key-good t))))
(setq help
(mew-mlm-prompt-for-list "Help: " help)
unsubscribe
(mew-mlm-prompt-for-list "Unsubscribe: " unsubscribe)
subscribe
(mew-mlm-prompt-for-list "Subscribe: " subscribe)
post
(mew-mlm-prompt-for-list "Post: " post)
owner
(mew-mlm-prompt-for-list "Owner: " owner)
archive
(mew-mlm-prompt-for-list "Archive: " archive)
filter-info
(mew-mlm-prompt-for-header-line
"Filter info: "
(concat (car filter-info) " " (cdr filter-info))))
(mew-mlm-make-entry key
help unsubscribe subscribe post owner archive
filter-info auth-info search-list parents)))
(defun mew-mlm-add-entry-via-guess-interactively ()
"Interactively add a new entry to `mew-mlm-master-alist'.
Never call this non-interactively."
(interactive)
; (mew-summary-msg
(let* ((default-entry (mew-mlm-make-entry-from-message))
(key (mew-mlm-entry:key default-entry)))
;; TODO: perhaps offer choice of overwriting or changing key eventually
(if (mew-mlm-key-exists-p key)
(message "Entry with key `%s' already exists." key)
(mew-mlm-add-new-entry
(mew-mlm-copy-and-morph-entry default-entry t))))
; )
)
(defun mew-mlm-edit-entry-via-guess-interactively ()
"Interactively edit an existing entry identified by guessing the
mailing list associated with the current message.
Never call this non-interactively."
(interactive)
; (mew-summary-msg
(let ((ml-key (mew-mlm-guess-list-from-message)))
(if ml-key
(let* ((entry (mew-mlm-get-entry ml-key))
(new-entry (mew-mlm-copy-and-morph-entry entry nil)))
(mew-mlm-replace-entry entry new-entry))
;; TODO: unnecessary
(message "Not editing any entry.")
))
; )
)
(defun mew-mlm-edit-entry-interactively (key)
"Interactively edit an existing entry keyed to KEY in `mew-mlm-master-alist'.
Supports completion on KEY.
Never call this non-interactively."
(interactive
(list
(completing-read "Edit entry with key: " mew-mlm-master-alist nil t)))
(if (not (equal key ""))
(let* ((entry (mew-mlm-get-entry key))
(new-entry (mew-mlm-copy-and-morph-entry entry nil)))
(mew-mlm-replace-entry entry new-entry))
(message "Not editing any entry.")))
(defun mew-mlm-delete-entry-interactively (key)
"Interactively delete entry keyed to KEY from `mew-mlm-master-alist'.
Supports completion."
(interactive
(list
(completing-read "Delete entry with key: " mew-mlm-master-alist nil t)))
(if (not (equal key ""))
(mew-mlm-delete-entry key)
(message "Not deleting any entry.")))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; functions for manipulating `mew-mlm-guess-alist'
(defun mew-mlm-make-guess-entry (header)
"Constructor for an entry of `mew-mlm-guess-alist'.
HEADER is a message header name (with colon)."
(cons header nil))
(defun mew-mlm-add-value-to-guess-entry (guess-entry value)
"Add VALUE to GUESS-ENTRY.
GUESS-ENTRY is an entry created by `mew-mlm-make-guess-entry'.
VALUE is a cons cell. The car is a message header value. The cdr is
a key for an entry in `mew-mlm-master-alist'."
(setcdr guess-entry
(cons value (cdr guess-entry))))
;; TODO: decide policy regarding whether to allow ml-entries that
;; have no filter-info
(defun mew-mlm-make-guess-alist ()
"Constructor for `mew-mlm-guess-alist'.
Each key is a message header name. Each value is an alist of elements
representing message header values and corresponding key strings for
entries in `mew-mlm-master-alist'. So each element is a cons cell."
(let (alist)
(mapcar
(function
(lambda (ml-entry)
;; TODO: write selectors for filter-info portion of ml-entry?
(let* ((header-name (car (mew-mlm-entry:filter-info ml-entry)))
(header-value (cdr (mew-mlm-entry:filter-info ml-entry)))
(ml-key (mew-mlm-entry:key ml-entry))
(guess-entry (assoc header-name alist)))
(if (not guess-entry)
;; no guess-entry, so create a new one and add it to
;; alist
(progn
(setq guess-entry (mew-mlm-make-guess-entry header-name))
(setq alist
(cons guess-entry alist))))
;; TODO: check for duplicates before adding?
(mew-mlm-add-value-to-guess-entry
guess-entry
(cons header-value ml-key)))))
mew-mlm-master-alist)
;; less confusing this way
alist))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; guessing -- some code in this section could do w/ a serious rewrite
;; based on `mew-summary-refile-body'
;; TODO: carved out `auto' stuff -- put it back in?
(defun mew-mlm-examine-message (function &rest args)
"Examine the current message using FUNCTION.
Returns the return value of FUNCTION, if successeful.
Should only be used in summary mode with cursor on a message row."
(let (msg buf fld ml-key)
(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)
(apply function args))))
(defun mew-mlm-guess-list-from-message-helper (alist)
"Identify mailing list candidates using current message headers and ALIST.
Each key in ALIST is a header name. Each value in ALIST is a cons
cell. The cdr is a key from `mew-mlm-master-alist', and the car is
a substring of a header value that aids in identifying the mailing
list associated with the key.
ALIST is typically `mew-mlm-guess-alist'.
Returns a list of guesses. Each guess is a key for `mew-mlm-master-alist'.
For most cases the returned list is expected to have a single element.
If there are multiple elements, it is likely that there is some
inconsistency/duplication in `mew-mlm-master-alist' or there is
something fishy about the headers of the current message."
(let (name header sublist key val ent ret)
(while alist
(setq name (car (car alist)))
(setq sublist (cdr (car alist)))
(if (stringp name)
(progn
(setq header (mew-header-get-value name))
(if header
(while sublist
(setq key (car (car sublist)))
(setq val (cdr (car sublist)))
;; TODO: possible to simplify?
(if (and (stringp key)
(string-match key header)
(stringp val))
(setq ent val))
(if ent
(progn
(setq ret (cons ent ret))
(setq ent nil)))
(setq sublist (cdr sublist)))))
;; problem in alist structure? name should be a string
(error "Expected a string, but encountered `%S'." name))
(setq alist (cdr alist)))
(mew-uniq-list (nreverse ret))))
(defun mew-mlm-guess-list-from-message ()
"Guess the mailing list the current message is associated with.
Returns a key for `mew-mlm-master-alist' associated with the guessed
mailing list.
This is a helper function for `mew-mlm-guess-list-from-message', and
assumes that preparations have been made for examining the current
message (via `mew-mlm-examine-message')."
(let* ((ml-guess-list (mew-mlm-examine-message
(function mew-mlm-guess-list-from-message-helper)
mew-mlm-guess-alist))
(n-guesses (length ml-guess-list)))
(cond ((= n-guesses 1)
(car ml-guess-list))
((> n-guesses 1)
(mew-mlm-prompt-from-list-with-default
"Mailing list" ml-guess-list (car ml-guess-list)))
;; TODO: should an offer be made to register a new entry in
;; `mew-mlm-master-alist'?
((= n-guesses 0)
(progn
(message "Unable to identify mailing list.")
(sit-for 1)
nil))
(t
(error "Should not reach this point in code.")))))
(defun mew-mlm-make-filter-info (header-name header-value)
"Constructor for filter information.
Returns a cons cell. The car is a string representing the header
name (including colon) and the cdr is a string representing the
corresponding header value."
(cons header-name header-value))
;; TODO: consider using some of the extraction functions
(defun mew-mlm-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)))
;; TODO: consider using some of the extraction functions
(defun mew-mlm-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-mlm-extract-x-ml-name-value (x-ml-name)
;; as-is
(downcase x-ml-name))
(defun mew-mlm-extract-mailing-list-value (mailing-list)
;; unfortunately, kind of messy
(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-mlm-extract-sender-value (sender)
;; as-is
(downcase (mew-mlm-extract-address-from-string sender)))
(defun mew-mlm-make-entry-from-message-helper ()
"Extract header info from current message and construct an entry.
This is a helper function for `mew-mlm-make-entry-from-message',
and assumes that preparations have been made for examining the current
message (via `mew-mlm-examine-message')."
(let ((help
(mew-mlm-string-to-list
(or (mew-header-get-value "List-Help:") "")))
(unsubscribe
(mew-mlm-string-to-list
(or (mew-header-get-value "List-Unsubscribe:") "")))
(subscribe
(mew-mlm-string-to-list
(or (mew-header-get-value "List-Subscribe:") "")))
(post
(mew-mlm-string-to-list
(or (mew-header-get-value "List-Post:") "")))
(owner
(mew-mlm-string-to-list
(or (mew-header-get-value "List-Owner:") "")))
(archive
(mew-mlm-string-to-list
(or (mew-header-get-value "List-Archive:") "")))
(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:"))
filter-info key)
;; derive some filter-info
;;
;; base the filter-info decision on the first header name
;; that matches from the following headers (in order):
;;
;; List-Id:
;; X-Mailing-List:
;; X-ML-Name:
;; Mailing-List:
;; Sender:
;;
;; this should cover most cases.
;; NOTE: the following code depends on the fact that
;; mew-header-get-value returns nil for no match
(setq filter-info
(cond (list-id
(mew-mlm-make-filter-info
"List-Id:"
(mew-mlm-extract-list-id-value list-id)))
(x-mailing-list
(mew-mlm-make-filter-info
"X-Mailing-List:"
(mew-mlm-extract-x-mailing-list-value x-mailing-list)))
(x-ml-name
(mew-mlm-make-filter-info
"X-ML-Name:"
(mew-mlm-extract-x-ml-name-value x-ml-name)))
(mailing-list
(mew-mlm-make-filter-info
"Mailing-List:"
(mew-mlm-extract-mailing-list-value mailing-list)))
(sender
(mew-mlm-make-filter-info
"Sender:"
(mew-mlm-extract-sender-value sender)))
(t nil)))
;; TODO: handle this more gracefully
;; check that we got something
(if (not filter-info)
(message "Unable to guess filter information."))
;; guess a value for key
(if list-id
(setq key (mew-mlm-extract-list-id-value list-id))
(let (to)
(setq to (mew-header-get-value "To:"))
(if to
(setq key
(downcase
(mew-mlm-make-list-id-from-address
(mew-mlm-extract-address-from-string to))))
(setq key ""))))
(mew-mlm-make-entry key
help unsubscribe subscribe post owner archive
filter-info "" nil nil)))
(defun mew-mlm-make-entry-from-message ()
"Extract header info from message and construct an entry.
Returns a partially-constructed entry (key is empty string) almost
suitable for addition to `mew-mlm-master-alist'."
(mew-mlm-examine-message
(function mew-mlm-make-entry-from-message-helper)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; refiling
;;
;; by ml returns guess or nil
;;
;; TODO: consider merging portions of this w/
;; `mew-mlm-guess-list-from-message'
(defun mew-refile-guess-by-ml ()
"Guess a refile folder for the current message.
Returns folder name on success, nil for failure."
(let* ((ml-guess-list (mew-mlm-guess-list-from-message-helper
mew-mlm-guess-alist))
(n-guesses (length ml-guess-list))
ml-guess)
(setq ml-guess
(cond ((= n-guesses 1)
(car ml-guess-list))
((> n-guesses 1)
(mew-mlm-prompt-from-list-with-default
"Mailing list" ml-guess-list (car ml-guess-list)))
((= n-guesses 0)
nil)
(t
(error "Should not reach this point in code."))))
(if ml-guess
(mew-mlm-entry:folder (mew-mlm-get-entry ml-guess))
nil)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; list action (e.g. post, unsubscribe, etc.) functions
;; TODO: check for action-name?
(defun mew-mlm-list-action (action-name)
"Create a message to perform list ACTION-NAME via list identified by ML-KEY."
;; TODO: write prompt-for-existing-key function
(let ((ml-key (completing-read
(format "List action `%s' for: " action-name)
mew-mlm-master-alist nil t)))
(if (not (equal ml-key ""))
(let* ((entry (mew-mlm-get-entry ml-key))
(action-field-value (mew-mlm-entry-field entry action-name))
(n-choices (length action-field-value))
(choice))
(if (null action-field-value)
(message "No information available for list action `%s'."
action-name)
(if (listp action-field-value)
;; non-empty list (checked for nil already)
(progn
(cond ((> n-choices 1)
(setq choice
(mew-mlm-prompt-from-list-with-default
(format "List action `%s' choice" action-name)
action-field-value
(car action-field-value))))
((= n-choices 1)
(setq choice
(car action-field-value))))
;; TODO: non-mailto url possible -- fix
(mew-browse-url-mailto
(mew-mlm-strip-enclosing-angle-brackets
(mew-mlm-extract-abes-from-string choice))))
;; value in mew-mlm-master-alist corrupted?
(error "Expected a list value, but got `%S'."
action-field-value))))
(message "Canceled action."))))
(defun mew-mlm-help ()
"Create a message to get the help message from list identified by ML-KEY.
Supports completion on ML-KEY."
(interactive)
(mew-mlm-list-action "help"))
(defun mew-mlm-unsubscribe ()
"Create a message to unsubscribe from list identified by ML-KEY.
Supports completion on ML-KEY."
(interactive)
(mew-mlm-list-action "unsubscribe"))
(defun mew-mlm-subscribe ()
"Create a message to subscribe to list identified by ML-KEY.
Supports completion on ML-KEY."
(interactive)
(mew-mlm-list-action "subscribe"))
(defun mew-mlm-post ()
"Create a message to post to list identified by ML-KEY.
Supports completion on ML-KEY."
(interactive)
(mew-mlm-list-action "post"))
(defun mew-mlm-owner ()
"Create a message to contact owner of the list identified by ML-KEY.
Supports completion on ML-KEY."
(interactive)
(mew-mlm-list-action "owner"))
;; TODO: for multiple pieces of posting info, offer choices by completion?
;; TODO: option for prompting user w/ guess before creating message?
(defun mew-mlm-post-to-this-list ()
"Create a message to post to \"this list\".
\"This list\" refers to the list associated with the current message,
if any."
(interactive)
;; TODO: if guessing fails, prompt user w/ list choices?
(let* ((ml-key (mew-mlm-guess-list-from-message))
(post (mew-mlm-entry:post (mew-mlm-get-entry ml-key))))
(if (listp post)
(mew-browse-url-mailto
(mew-mlm-strip-enclosing-angle-brackets
(mew-mlm-extract-abes-from-string (car post))))
;; TODO: could try to guess post info from To: or Cc: header...
;; TODO: could also offer to some how learn the correct posting info
(message "No post information available."))))
(defun mew-mlm-unsubscribe-from-this-list ()
"Create a message to unsubscribe from \"this list\"."
(interactive)
(let ((ml-key (mew-mlm-guess-list-from-message))
unsubscribe)
(if (not ml-key)
;; TODO: unnecessary because mew-mlm-guess-list-from-message
;; displays a relevant message?
(message "Could not guess list associated with the current message.")
(progn
(setq unsubscribe (mew-mlm-entry:unsubscribe
(mew-mlm-get-entry ml-key)))
(if (listp unsubscribe)
(mew-browse-url-mailto
(mew-mlm-strip-enclosing-angle-brackets
(mew-mlm-extract-abes-from-string (car unsubscribe))))
(message "No unsubscribe information availabe."))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; search mark
;; wrapper around `mew-summary-search-mark'
(defun mew-mlm-search-mark-via-list-choice (&optional arg)
"Pick messages according to a pick pattern which you input then put
the '*' mark onto them. The default pattern is looked up in
`mew-mlm-master-alist' after the user specifies which mailing list's
pattern to use.
If called with '\\[universal-argument]', execute
'mew-summary-pick-with-external'. Otherwise, 'mew-summary-pick-with-imls'
is called."
(interactive "P")
; (mew-summary-only
(let (ml-key mew-pick-default-field key-good)
(while (not key-good)
(setq ml-key
(completing-read "List: " mew-mlm-master-alist nil t))
(if (equal ml-key "")
(progn
(message "The empty string is not allowed as a key.")
(sit-for 1))
(setq key-good t)))
;; TODO: check whether ml-entry exists? -- consistency check...
(let* ((ml-entry (mew-mlm-get-entry ml-key))
(filter-info (mew-mlm-entry:filter-info ml-entry)))
;; TODO: does this check need to happen elsewhere?
(if filter-info
(let ((name (car filter-info))
(value (cdr filter-info)))
(setq mew-pick-default-field
(concat
(substring name 0 (- (length name) 1))
"="
value)))
(progn
(message "No filter-info for the list `%s'." ml-key)
(sit-for 1))))
(mew-summary-search-mark arg))
; )
)
;; wrapper around `mew-summary-search-mark'
(defun mew-mlm-search-mark-via-guess (&optional arg)
"Pick messages according to a pick pattern which you input, then put
the '*' mark onto them. The default pattern is looked up in
`mew-mlm-master-alist' after the mailing list associated with the
current message is guessed.
If called with '\\[universal-argument]', execute
'mew-summary-pick-with-external'. Otherwise, 'mew-summary-pick-with-imls'
is called."
(interactive "P")
; (mew-summary-only
(let ((ml-key (mew-mlm-guess-list-from-message))
mew-pick-default-field)
(if ml-key
;; TODO: check whether ml-entry exists?
(let* ((ml-entry (mew-mlm-get-entry ml-key))
(filter-info (mew-mlm-entry:filter-info ml-entry)))
;; TODO: does this check need to happen elsewhere?
(if filter-info
(let ((name (car filter-info))
(value (cdr filter-info)))
(setq mew-pick-default-field
(concat
(substring name 0 (- (length name) 1))
"="
value)))
(progn
(message "No filter-info for the list `%s'." ml-key)
(sit-for 1)))))
(mew-summary-search-mark arg))
; )
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; intialization function
(defun mew-mlm-setup ()
"Initialization of this package."
;; initialize `mew-mlm-master-alist'
(mew-mlm-load-master-alist)
;; build `mew-mlm-guess-alist'
(setq mew-mlm-guess-alist (mew-mlm-make-guess-alist))
;; save when quitting
(add-hook 'mew-quit-hook 'mew-mlm-save-master-alist))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; main ;-)
;; keybindings
(if (not mew-summary-mode-map)
(message "Unable to add definitions to `mew-summary-mode-map'.")
;; manipulate mailing list info
(define-key mew-summary-mode-map "\C-cega"
'mew-mlm-add-entry-via-guess-interactively)
(define-key mew-summary-mode-map "\C-cege"
'mew-mlm-edit-entry-via-guess-interactively)
(define-key mew-summary-mode-map "\C-cee"
'mew-mlm-edit-entry-interactively)
(define-key mew-summary-mode-map "\C-ced"
'mew-mlm-delete-entry-interactively)
;; message creation
(define-key mew-summary-mode-map "\C-cmh"
'mew-mlm-help)
(define-key mew-summary-mode-map "\C-cmu"
'mew-mlm-unsubscribe)
(define-key mew-summary-mode-map "\C-cms"
'mew-mlm-subscribe)
(define-key mew-summary-mode-map "\C-cmp"
'mew-mlm-post)
(define-key mew-summary-mode-map "\C-cmo"
'mew-mlm-owner)
;; search then mark
(define-key mew-summary-mode-map "\C-c?g"
'mew-mlm-search-mark-via-guess)
(define-key mew-summary-mode-map "\C-c?c"
'mew-mlm-search-mark-via-list-choice))
;; menus
(if (not mew-summary-mode-menu-spec)
(message "Unable to add definitions to `mew-summary-mode-menu-spec'.")
(setq mew-summary-mode-menu-spec
(append
mew-summary-mode-menu-spec
'("----"
("MLM"
["Add Entry via Guess"
mew-mlm-add-entry-via-guess-interactively (mew-summary-p)]
["Edit Entry via Guess"
mew-mlm-edit-entry-via-guess-interactively (mew-summary-p)]
["Edit Entry"
mew-mlm-edit-entry-interactively (mew-summary-p)]
["Delete Entry"
mew-mlm-delete-entry-interactively (mew-summary-p)]
"----"
["Create Help Message"
mew-mlm-help]
["Create Unsubscribe Message"
mew-mlm-unsubscribe]
["Create Subscribe Message"
mew-mlm-subscribe]
["Create Message to Post to List"
mew-mlm-post]
["Create Message to Owner"
mew-mlm-owner]
"----"
["Search via Guess then Mark"
mew-mlm-search-mark-via-guess (mew-summary-p)]
["Search via Choice then Mark"
mew-mlm-search-mark-via-list-choice (mew-summary-p)])
)))
;; code from mew-gemacs.el -- will this work w/ XEmacs?
(easy-menu-define
mew-summary-mode-menu
mew-summary-mode-map
"Menu used in Summary mode."
mew-summary-mode-menu-spec))
(mew-mlm-setup)
(provide 'mew-mlm)
Mew-dist メーリングリストの案内