[Mew-dist 08708] Re: bbdb-ml.el, bbdb-ml-ext.el

[sen_ml at example.com]

今日、wl (0.10.0) とのテストを行った結果、不具合が生じたした。
問題を回避するために、bbdb-ml-ext.el に変更を加え、
インストール手順もかえました。

新しい bbdb-ml-ext.el を添付します。

インストール手順は、

  wl:

    (add-hook 'wl-init-hook
      (lambda ()
        (require 'bbdb-ml-ext)
        (bme-initialize "wl")))

を .wl に記述する。

  mew:

    (add-hook 'mew-init-hook
      (lambda ()
        (require 'bbdb-ml-ext)
        (bme-initialize "mew")))

を .emacs 等に記述する。

動作は、 mew (1.93)、wl (0.10.0) で確認しました。
-------------- 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

;;; to use this w/ mew, place:
;;;
;;; (add-hook 'mew-init-hook
;;;  (lambda ()
;;;    (require 'bbdb-ml-ext)
;;;    (bme-initialize "mew")))
;;;
;;; in an appropriate place -- e.g. .emacs
;;;
;;; to use this w/ wl, place:
;;;
;;; (add-hook 'wl-init-hook
;;;  (lambda ()
;;;    (require 'bbdb-ml-ext)
;;;    (bme-initialize "wl")))
;;;
;;; in an appropriate place -- e.g. .wl

;;; 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.2")

;; 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)))))

(defun bme-initialize (mail-client-string)
  (cond 
   ;; mew
   ((equal mail-client-string "mew")
    (progn
      (require 'mew-mailto)
      (defalias 'mail-client-mailto-compose-function
	'mew-mailto-summary-send)))
   ;; wl
   ((equal mail-client-string "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)