[Mew-dist 08706] bbdb-ml.el, bbdb-ml-ext.el
sen_ml at example.com
sen_ml at example.com
1999年 5月 4日 (火) 22:03:32 JST
メーリングリスト情報 (参加、脱会方法、その他) を保存、管理等する
ためのコード、bbdb-ml.el と bbdb-ml-ext.el を書いてみました。
bbdb を使用しているので、使用するには、.emacs 等に:
(require 'bbdb)
(bbdb-initialize)
(require 'bbdb-ml)
(require 'bbdb-ml-ext)
と記述し、適当な場所に bbdb-ml.el と bbdb-ml-ext.el を置いて下さい。
mew で使用するには、
(setq bme-mail-client "mew")
wl で使用するには、
(setq bme-mail-client "wl")
と .emacs に記述してやって下さい。
emacs を起動し、mew か wl を起動し、Shift Mouse Button 2 と
やってみて下さい。
＃ Shift Mouse Button 2 がいやな人は bbdb-ml-ext.el の最後の
方をいじって下さい。ほんとうは、global-map を使わない方が
良いのでしょうね。
bbdb-ml.el を使用するには、bbdb が必要です。2.00 でテストしたつもりです。
bbdb-ml-ext.el を使用するには、bbdb, bbdb-ml の他に mew-mailto.el
(mew の場合)、wl-mailto.el (wl の場合) が必要です。
bbdb-ml.el と bbdb-ml-ext.el、あと、.bbdb のサンプルを添付します。
P.S. wl が 0.10.0 になってからはテストしていません。最後にテストしたのは
0.9.8 です。mew の方は、1.93 でテストしました。
-------------- next part --------------
;;; file-version: 3
["Mailing List:" "wl" nil nil nil nil nil ((ml-type . "fml") (ml-help . "mailto:wl-ctl at example.com?body=%23%20guide") (ml-unsubscribe . "mailto:wl-ctl at example.com?body=unsubscribe%0aend") (ml-subscribe . "mailto:wl-ctl at example.com?body=%23%20subscribe%20firstname%20lastname") (ml-post . "mailto:wl at example.com") (ml-owner . "mailto:wl-admin at example.com") (ml-archive . "http://lists.airs.net/wl/archive/") (creation-date . "1999-05-04") (timestamp . "1999-05-04")) nil]
["Mailing List:" "mew-dist" nil nil nil nil nil ((ml-type . "fml") (ml-unsubscribe . "mailto:mew-dist-ctl at example.com?body=unsubscribe%20name") (ml-subscribe . "mailto:mew-dist-ctl at example.com?body=subscribe%20name") (ml-post . "mailto:mew-dist at example.com") (ml-archive . "http://www.mew.org/Win32/search-j.html") (creation-date . "1999-05-01") (timestamp . "1999-05-01")) nil]
["Mailing List:" "mgp-users-jp" nil nil nil nil nil ((ml-type . "fml") (ml-help . "mailto:mgp-users-jp-ctl at example.com?body=%23%20help") (ml-unsubscribe . "mailto:mgp-users-jp-ctl at example.com?body=%23%20bye") (ml-subscribe . "mailto:mgp-users-jp-ctl at example.com?body=%23%20subscribe%20firstname%20lastname") (ml-post . "mailto:mgp-users-jp at example.com") (ml-owner . "mailto:mgp-users-jp-admin at example.com") (ml-archive . "http://www.mew.org/search/index-j.html") (creation-date . "1999-05-02") (timestamp . "1999-05-02")) nil]
["Mailing List:" "mgp-users" nil nil nil nil nil ((ml-type . "fml") (ml-help . "mailto:mgp-users-ctl at example.com?body=%23%20help") (ml-unsubscribe . "mailto:mgp-users-ctl at example.com?body=%23%20bye") (ml-subscribe . "mailto:mgp-users-ctl at example.com?body=%23%20subscribe%20firstname%20lastname") (ml-post . "mailto:mgp-users at example.com") (ml-owner . "mailto:mgp-users-admin at example.com") (creation-date . "1999-05-02") (timestamp . "1999-05-02")) nil]
-------------- next part --------------
;;; -*- emacs-lisp -*-
;;; This file is an addition to the Insidious Big Brother Database
;;; (aka BBDB), copyright (c) 1991, 1992 Jamie Zawinski
;;; <jwz at example.com>.
;;;
;;; Copyright (C) 1999 Sen Nagata <sen at example.com>
;;; This program is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU General Public License as
;;; published by the Free Software Foundation; either version 2 of
;;; the License.
;;; This program is distributed in the hope that it will be
;;; useful, but WITHOUT ANY WARRANTY; without even the implied
;;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
;;; PURPOSE. See the GNU General Public License for more details.
;;; You should have received a copy of the GNU General Public
;;; License along with this program; if not, write to the Free
;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston,
;;; MA 02111-1307 USA
;;; This file was heavily based on bbdb-ftp.el by Ivan Vazquez
;;; <ivan at example.com>
;;; This file adds the ability to define mailing lists in a BBDB, much the same
;;; way one adds a regular person's name to the BBDB. See RFC 2369.
;;; Note that Mailing List BBDB entries differ from regular entries by the
;;; fact that the Name Field must have the mailing list name preceeded by the
;;; bbdb-mailing-list-name-designator-prefix. This defaults to
;;; "Mailing List:" BBDB Mailing List entries also have some new fields added:
;;;
;;; ml-type
;;; ml-help
;;; ml-unsubscribe
;;; ml-subscribe
;;; ml-post
;;; ml-owner
;;; ml-archive
;;;
;;; These are added to the notes alist part of the bbdb-records, the original
;;; bbdb-record structure remains untouched.
;;; The following user-level commands are defined for use:
;;;
;;; bbdb-create-mailing-list -
;;; Add a new mailing-list entry to the bbdb database; prompts
;;; for all relevant info using the echo area, inserts the
;;; new record in the db, sorted alphabetically.
;;; TODO: implement the following:
;;; The package can be installed by compiling and adding the following
;;; line to your .emacs.
;;; (autoload 'bbdb-create-mailing-list "bbdb-ml" "Mailing List BBDB Package" t)
(require 'bbdb)
(defconst bbdb-ml-version "bbdb-ml.el 0.1")
;; based this on something in bbdb.el
(defgroup bbdb-utilities-ml nil
"Customizations for using mailing lists stored in BBDB records."
:group 'bbdb-utilities)
(put 'bbdb-utilities-ml 'custom-loads '("bbdb-ml"))
(defcustom bbdb-default-mailto-command-prefix "mailto:"
"*The prefix for a mailing list mailto url command."
:group 'bbdb-utilities-ml
:type 'string)
(defcustom bbdb-default-http-command-prefix "http://"
"*The prefix for a mailing list http url command."
:group 'bbdb-utilities-ml
:type 'string)
(defcustom bbdb-mailing-list-name-designator-prefix "Mailing List: "
"*The prefix that all mailing lists in the bbdb will have in their name
field."
:group 'bbdb-utilities-ml
:type 'string)
(defmacro defun-bbdb-raw-notes-accessor (slot)
"Expands into an accessor function for slots in the notes alist."
(let ((fn-name (intern (concat "bbdb-record-" (symbol-name slot)))))
(list 'defun fn-name (list 'record)
(list 'cdr
(list 'assoc (list 'quote slot)
(list 'bbdb-record-raw-notes 'record))))))
;; (defun-bbdb-raw-notes-accessor ml-type) expands to:
;;
;; (defun bbdb-record-ml-type (record)
;; (cdr (assoc (quote ml-type) (bbdb-record-raw-notes record))))
(defvar bbdb-ml-field-prefix "ml-")
(defvar bbdb-ml-notes-action-name-list
'("help"
"unsubscribe"
"subscribe"
"post"
"owner"
"archive")
"List of actions for mailing list records.")
;; check passed value?
(defun bbdb-ml-action-name-to-symbol (action-name)
"Return symbol corresponding to ACTION-NAME."
(intern (concat bbdb-ml-field-prefix (downcase action-name))))
;; check passed value?
(defun bbdb-ml-symbol-to-action-name (symbol)
"Return action name corresponding to SYMBOL."
(substring (symbol-name symbol)
(length bbdb-ml-field-prefix)))
;; check passed value?
(defun bbdb-ml-action-name-to-symbol-name (action-name)
"Return symbol name corresponding to ACTION-NAME."
(symbol-name
(intern
(concat bbdb-ml-field-prefix (downcase action-name)))))
;; check passed value?
(defun bbdb-ml-symbol-name-to-action-name (symbol-name)
"Return action name corresponding to SYMBOL-NAME."
(substring symbol-name
(length bbdb-ml-field-prefix)))
(defvar bbdb-ml-notes-fieldname-alist
(cons (cons "ml-type" nil)
(mapcar
(lambda (x)
(cons
(bbdb-ml-action-name-to-symbol-name x)
nil))
bbdb-ml-notes-action-name-list))
"List of notes fields for mailing list records.")
; TODO: can't we do the following programmatically based on some list?
(defun-bbdb-raw-notes-accessor ml-type)
(defun-bbdb-raw-notes-accessor ml-help)
(defun-bbdb-raw-notes-accessor ml-unsubscribe)
(defun-bbdb-raw-notes-accessor ml-subscribe)
(defun-bbdb-raw-notes-accessor ml-post)
(defun-bbdb-raw-notes-accessor ml-owner)
(defun-bbdb-raw-notes-accessor ml-archive)
(defun bbdb-record-mailing-list (record)
"Acessor Function. Returns the mailing-list field of the BBDB record or
nil."
(let* ((name (bbdb-record-name record))
(ml-pfx-regexp (concat bbdb-mailing-list-name-designator-prefix " *"))
(mailing-list
(and (string-match ml-pfx-regexp name)
(substring name (match-end 0)))))
mailing-list))
(defun remove-leading-whitespace (string)
"Remove any spaces or tabs from only the start of the string."
(let ((space-char-code (string-to-char " "))
(tab-char-code ?\t)
(index 0))
(if string
(progn
(while (or (char-equal (elt string index) space-char-code)
(char-equal (elt string index) tab-char-code))
(setq index (+ index 1)))
(substring string index))
nil)))
(defun bbdb-read-new-mailing-list-record ()
"Prompt for and return a completely new bbdb-record that is
specifically a mailing list entry. Doesn't insert it in to the database
or update the hashtables, but does insure that there will not be name
collisions."
(bbdb-records) ; make sure database is loaded
(if bbdb-readonly-p
(error "The Insidious Big Brother Database is read-only."))
(let (mailing-list)
(bbdb-error-retry
(progn
(setq mailing-list
(bbdb-read-string "Mailing List: "))
(setq mailing-list
(concat bbdb-mailing-list-name-designator-prefix mailing-list))
(if (bbdb-gethash (downcase mailing-list))
(error "%s is already in the database" mailing-list))))
(let* ((ml-type
(bbdb-read-string "ML type: "))
(ml-help
(bbdb-read-string "Help URL: "
bbdb-default-mailto-command-prefix))
(ml-unsubscribe
(bbdb-read-string "Unsubscription URL: "
bbdb-default-mailto-command-prefix))
(ml-subscribe
(bbdb-read-string "Subscription URL: "
bbdb-default-mailto-command-prefix))
(ml-post
(bbdb-read-string "Post URL: "
bbdb-default-mailto-command-prefix))
(ml-owner
(bbdb-read-string "Owner URL: "
bbdb-default-mailto-command-prefix))
(ml-archive
(bbdb-read-string "Archive URL: "
bbdb-default-http-command-prefix))
(company
(bbdb-read-string "Company: "))
(notes
(bbdb-read-string "Additional Comments: "))
(names (bbdb-divide-name mailing-list))
(firstname (car names))
(lastname (nth 1 names)))
(if (string= company "")
(setq company nil))
(if (string= ml-type "")
(setq ml-type nil))
(if (or (string= ml-help bbdb-default-mailto-command-prefix)
(string= ml-help ""))
(setq ml-help nil))
(if (or (string= ml-unsubscribe bbdb-default-mailto-command-prefix)
(string= ml-unsubscribe ""))
(setq ml-unsubscribe nil))
(if (or (string= ml-subscribe bbdb-default-mailto-command-prefix)
(string= ml-subscribe ""))
(setq ml-subscribe nil))
(if (or (string= ml-post bbdb-default-mailto-command-prefix)
(string= ml-post ""))
(setq ml-post nil))
(if (or (string= ml-owner bbdb-default-mailto-command-prefix)
(string= ml-owner ""))
(setq ml-owner nil))
(if (or (string= ml-archive bbdb-default-http-command-prefix)
(string= ml-archive ""))
(setq ml-archive nil))
(if (string= notes "")
(setq notes nil))
(let ((record
(vector firstname lastname nil company nil nil nil
(append
(if notes
(list (cons 'notes notes)) nil)
(if ml-type
(list (cons 'ml-type ml-type)) nil)
(if ml-help
(list (cons 'ml-help ml-help)) nil)
(if ml-unsubscribe
(list (cons 'ml-unsubscribe ml-unsubscribe)) nil)
(if ml-subscribe
(list (cons 'ml-subscribe ml-subscribe)) nil)
(if ml-post
(list (cons 'ml-post ml-post)) nil)
(if ml-owner
(list (cons 'ml-owner ml-owner)) nil)
(if ml-archive
(list (cons 'ml-archive ml-archive)) nil))
(make-vector bbdb-cache-length nil))))
record))
))
(defun bbdb-create-mailing-list (record)
"Add a new mailing-list entry to the bbdb database; prompts for all
relevant info using the echo area, inserts the new record in the db,
sorted alphabetically."
(interactive (list (bbdb-read-new-mailing-list-record)))
(bbdb-invoke-hook 'bbdb-create-hook record)
(bbdb-change-record record t)
(bbdb-display-records (list record)))
(provide 'bbdb-ml)
-------------- next part --------------
;;; -*- emacs-lisp -*-
;;; This file is an addition to the Insidious Big Brother Database
;;; (aka BBDB), copyright (c) 1991, 1992 Jamie Zawinski
;;; <jwz at example.com>.
;;; Copyright (C) 1999 Sen Nagata <sen at example.com>
;;; This program is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU General Public License as
;;; published by the Free Software Foundation; either version 2 of
;;; the License.
;;; This program is distributed in the hope that it will be
;;; useful, but WITHOUT ANY WARRANTY; without even the implied
;;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
;;; PURPOSE. See the GNU General Public License for more details.
;;; You should have received a copy of the GNU General Public
;;; License along with this program; if not, write to the Free
;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston,
;;; MA 02111-1307 USA
;;; The following user-level commands are defined for use:
;;;
;;; bbdb-ml-help
;;; bbdb-ml-unsubscribe
;;; bbdb-ml-subscribe
;;; bbdb-ml-post
;;; bbdb-ml-owner
;;; bbdb-ml.el is required
;;;
;;; if mew is going to be used, mew-mailto.el is required
;;; if wl is going to be used, wl-mailto.el is required
;;; TODO: work on naming in this file...
;; this file uses a macro from bbdb-ml.el
(eval-when-compile
(require 'bbdb-ml))
;; bme stands for 'bbdb-ml-ext'
(defconst bbdb-ml-ext-version "bbdb-ml-ext.el 0.1")
;; ah recusrion, wonderful recursion
(defun sln-collapse-list (target-list)
"Return a list of elements from TARGET-LIST w/ nil elements removed. The
order of the returned elements is preserved."
(if (null target-list)
nil
(if (car target-list)
(cons (car target-list)
(sln-collapse-list (cdr target-list)))
(sln-collapse-list (cdr target-list)))))
(defvar bme-mail-client "mew"
"String identifying mail client. E.g. mew, wl, etc.")
(cond
;; mew
((equal bme-mail-client "mew")
(progn
(require 'mew-mailto)
(defalias 'mail-client-mailto-compose-function
'mew-mailto-summary-send)))
;; wl
((equal bme-mail-client "wl")
(progn
(require 'wl-mailto)
(defalias 'mail-client-mailto-compose-function
'wl-mailto-draft))))
(defvar bme-ml-records-alist nil
"Association list of mailing list records.")
(defun bme-make-ml-records-alist ()
;(interactive)
(sln-collapse-list
(mapcar
(lambda (x)
;; (if (equal bbdb-mailing-list-name-designator-prefix
;; bbdb-mailing-list-name-designator-prefix contains a trailing space
;; while the value of the firstname field doesn't...
(if (equal "Mailing List:"
(bbdb-record-firstname x))
(cons (bbdb-record-lastname x) x)))
(bbdb-records))))
;(setq bme-ml-records-alist (bme-make-ml-records-alist))
(defun bme-get-record-for (mailing-list-name)
(cdr (assoc mailing-list-name
; bme-ml-records-alist
(bme-make-ml-records-alist)
)))
(defun bme-make-field-alist (fieldname)
(sln-collapse-list
(mapcar
(lambda (x)
(if x
(let* ((ml-name (car x))
(record (cdr x))
(fn-name (intern (concat "bbdb-record-" fieldname)))
(fieldvalue (funcall fn-name record)))
(if fieldvalue
(cons ml-name fieldvalue)))))
; bme-ml-records-alist
(bme-make-ml-records-alist)
)))
(defun bme-prompt-for-action ()
(let ((action
;; can't we get completing-read to not accept non-completing input?
(completing-read
"Action: "
(mapcar
(lambda (x)
(cons x nil))
bbdb-ml-notes-action-name-list)
nil
;; must choose from alist
t)))
(if (equal action "")
(error "No value for an action was specified")
action)))
(defun bme-prompt-for-mailing-list-with (action-name)
(let ((ml-field-alist
(bme-make-field-alist
(bbdb-ml-action-name-to-symbol-name action-name)))
mailing-list-name)
(if ml-field-alist
(progn
(setq mailing-list-name
(completing-read "Mailing List: " ml-field-alist nil t))
(if (equal mailing-list-name "")
(error "No value for a mailing list was specified")
mailing-list-name))
(error "No mailing lists w/ action %s defined" action-name))))
(defun bme-retrive-value-for (action-name mailing-list-name)
(interactive
(let* ((action-name
(bme-prompt-for-action))
(mailing-list-name
(bme-prompt-for-mailing-list-with action-name)))
(list action-name mailing-list-name)))
(let (lookup-function-name lookup-function looked-up-result)
(setq lookup-function-name
(concat "bbdb-record-"
(bbdb-ml-action-name-to-symbol-name action-name)))
;; quite defensive
(setq lookup-function
(intern-soft lookup-function-name))
(if lookup-function
(setq looked-up-result
(funcall
lookup-function
(bme-get-record-for mailing-list-name)))
;; shouldn't reach this point
(message "Function named: %s not found" lookup-function-name)))
)
(defun bme-do-action (action-name mailing-list-name)
(interactive
(let* ((action-name
(bme-prompt-for-action))
(mailing-list-name
(bme-prompt-for-mailing-list-with action-name)))
(list action-name mailing-list-name)))
(let ((field-value
(bme-retrive-value-for action-name mailing-list-name)))
; (message "%s for %s is: %s"
; action-name
; mailing-list-name
; field-value)
(mail-client-mailto-compose-function field-value)
)
)
;; the macro should expand to something like:
;;
;; (defun bbdb-ml-subscribe (mailing-list-name)
;; (interactive
;; (list
;; (bme-prompt-for-mailing-list-with "subscribe")))
;;
;; (bme-do-action "subscribe" mailing-list-name))
(defmacro defun-bme-do-action (action-name)
"Expands into a function for performing an action."
(let* ((fn-name (intern (concat
"bbdb-" "ml-" action-name))))
(list 'defun fn-name (list 'mailing-list-name)
(list 'interactive
(list 'list
(list 'bme-prompt-for-mailing-list-with
action-name)))
(list 'bme-do-action
action-name
'mailing-list-name)))
)
(defun-bme-do-action "help")
(defun-bme-do-action "unsubscribe")
(defun-bme-do-action "subscribe")
(defun-bme-do-action "post")
(defun-bme-do-action "owner")
;(defun-bme-do-action "archive")
(defun bme-popup-menu-emacs (mouse-event)
(interactive "e")
(let (command-name)
(setq command-name
(x-popup-menu mouse-event
'("Test BBDB Menu"
("Create Message"
("Help message" . bbdb-ml-help)
("Unsubscribe message" . bbdb-ml-unsubscribe)
("Subscribe message" . bbdb-ml-subscribe)
("Post message" . bbdb-ml-post)
("Owner message" . bbdb-ml-owner)
;("Archive message" . bbdb-ml-archive)
)
("Extras"
("Create mailing list record" .
bbdb-create-mailing-list))
)))
(if command-name
(command-execute command-name)
(message "No command selected"))))
(defun bme-popup-menu-xemacs (mouse-event)
(interactive "e")
(popup-menu '("Test BBDB Menu"
("Create Message"
["Help message" bbdb-ml-help t]
["Unsubscribe message" bbdb-ml-unsubscribe t]
["Subscribe message" bbdb-ml-subscribe t]
["Post message" bbdb-ml-post t]
["Owner message" bbdb-ml-owner t]
)
("Extras"
["Create mailing list record" bbdb-create-mailing-list t]
))))
(if (string-match "^XEmacs" (emacs-version))
;; xemacs
(progn
(defalias 'bme-popup-menu 'bme-popup-menu-xemacs)
(define-key global-map [(shift button2)] 'bme-popup-menu))
;; vanilla emacs
(progn
(defalias 'bme-popup-menu 'bme-popup-menu-emacs)
(define-key global-map [S-down-mouse-2] 'bme-popup-menu))
)
(provide 'bbdb-ml-ext)
Mew-dist メーリングリストの案内