X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=utils%2Fbbdb-wl.el;h=a054e555279adcbf01f8d048a14420cff1770d40;hb=3292cda093d45703dd7adcbf612000796397855d;hp=edc483f85a721282547ce0be74c8dffa71a616cd;hpb=6a922a71b819f0c7b0d2e2435df5b0a768466c64;p=elisp%2Fwanderlust.git

diff --git a/utils/bbdb-wl.el b/utils/bbdb-wl.el
index edc483f..a054e55 100644
--- a/utils/bbdb-wl.el
+++ b/utils/bbdb-wl.el
@@ -1,6 +1,6 @@
 ;;; bbdb-wl.el -- BBDB interface to Wanderlust
 
-;; Copyright 1998,1999,2000 Yuuichi Teranishi <teranisi@gohome.org>
+;; Copyright (C) 1998,1999,2000 Yuuichi Teranishi <teranisi@gohome.org>
 
 ;; Author: Yuuichi Teranishi <teranisi@gohome.org>
 ;; Keywords: mail, news, database
@@ -8,7 +8,7 @@
 ;;; Commentary:
 ;;
 ;;  Insert the following lines in your ~/.wl
-;; 
+;;
 ;;  (require 'bbdb-wl)
 ;;  (bbdb-wl-setup)
 
@@ -17,26 +17,41 @@
 
 ;; bbdb setup.
 (eval-when-compile
+  (require 'static)
   (require 'mime-setup)
   (require 'elmo-vars)
   (require 'elmo-util)
-  (require 'bbdb)
   (require 'wl-summary)
   (require 'wl-message)
   (require 'wl-draft)
   (require 'wl-address)
-  (defvar bbdb-pop-up-elided-display nil)
-  (or (fboundp 'bbdb-extract-field-value-internal)
-      (defun bbdb-extract-field-value-internal (field))))
+  (require 'bbdb-com)
+  (defvar bbdb-pop-up-elided-display nil))
+
+(require 'bbdb)
 
 (defvar bbdb-wl-get-update-record-hook nil)
+(defvar bbdb-wl-folder-regexp nil)
+(defvar bbdb-wl-ignore-folder-regexp nil)
+
+(defvar bbdb-wl-canonicalize-full-name-function
+  #'bbdb-wl-canonicalize-spaces-and-dots
+  "Way to canonicalize full name.")
 
+(defun bbdb-wl-canonicalize-spaces-and-dots (string)
+  (while (and string (string-match "  +\\|[\f\t\n\r\v]+\\|\\." string))
+    (setq string (replace-match " " nil t string)))
+  (and string (string-match "^ " string)
+       (setq string (replace-match "" nil t string)))
+  string)
+
+;;;###autoload
 (defun bbdb-wl-setup ()
-  (require 'bbdb)
   (add-hook 'wl-message-redisplay-hook 'bbdb-wl-get-update-record)
   (add-hook 'wl-summary-exit-hook 'bbdb-wl-hide-bbdb-buffer)
   (add-hook 'wl-message-window-deleted-hook 'bbdb-wl-hide-bbdb-buffer)
   (add-hook 'wl-exit-hook 'bbdb-wl-exit)
+  (add-hook 'wl-save-hook 'bbdb-offer-save)
   (add-hook 'wl-summary-toggle-disp-off-hook 'bbdb-wl-hide-bbdb-buffer)
   (add-hook 'wl-summary-toggle-disp-folder-on-hook 'bbdb-wl-hide-bbdb-buffer)
   (add-hook 'wl-summary-toggle-disp-folder-off-hook 'bbdb-wl-hide-bbdb-buffer)
@@ -53,19 +68,41 @@
 	    (function
 	     (lambda ()
 ;;;	       (local-set-key "\M-\t" 'bbdb-complete-name)
-	       (define-key (current-local-map) "\M-\t" 'bbdb-complete-name)
-	       ))))
+	       (define-key (current-local-map) "\M-\t" 'bbdb-complete-name))))
+  (require 'bbdb)
+  (bbdb-initialize)
+
+  (if (not (boundp 'bbdb-get-addresses-from-headers))
+      (defvar bbdb-get-addresses-from-headers
+	'("From" "Resent-From" "Reply-To")))
+
+  (if (not (boundp 'bbdb-get-addresses-to-headers))
+      (defvar bbdb-get-addresses-to-headers
+	'("Resent-To" "Resent-CC" "To" "CC" "BCC")))
+
+  (if (not (boundp 'bbdb-get-addresses-headers))
+      (defvar bbdb-get-addresses-headers
+	(append bbdb-get-addresses-from-headers
+		bbdb-get-addresses-to-headers))))
 
 (defun bbdb-wl-exit ()
   (let (bbdb-buf)
     (if (setq bbdb-buf (get-buffer bbdb-buffer-name))
 	(kill-buffer bbdb-buf)))
-  (bbdb-save-db t))
+  (bbdb-offer-save))
 
 (defun bbdb-wl-get-update-record ()
-  (set-buffer (wl-message-get-original-buffer))
-  (bbdb-wl-update-record)
-  (run-hooks 'bbdb-wl-get-update-record-hook))
+  (let ((folder-name (with-current-buffer
+			 wl-message-buffer-cur-summary-buffer
+		       (wl-summary-buffer-folder-name))))
+    (if (and (or (null bbdb-wl-folder-regexp)
+		 (string-match bbdb-wl-folder-regexp folder-name))
+	     (not (and bbdb-wl-ignore-folder-regexp
+		       (string-match bbdb-wl-ignore-folder-regexp
+				     folder-name))))
+	(with-current-buffer (wl-message-get-original-buffer)
+	  (bbdb-wl-update-record)
+	  (run-hooks 'bbdb-wl-get-update-record-hook)))))
 
 (defun bbdb-wl-hide-bbdb-buffer ()
   (let (bbdb-buf bbdb-win)
@@ -81,7 +118,7 @@
 		      (save-excursion
 			(if (buffer-live-p  wl-current-summary-buffer)
 			    (set-buffer wl-current-summary-buffer))
-			wl-message-buf-name)))
+			wl-message-buffer)))
 	    (cur-win (selected-window))
 	    (b (current-buffer)))
 	(and mes-win (select-window mes-win))
@@ -98,8 +135,16 @@
 	(let ((pop-up-windows nil))
 	  (switch-to-buffer (get-buffer-create bbdb-buffer-name)))))))
 
+(defun bbdb-wl-get-petname (from)
+  "For `wl-summary-get-petname-function'."
+  (let* ((address (wl-address-header-extract-address from))
+	 (record (bbdb-search-simple nil address)))
+    (and record
+	 (or (bbdb-record-name record)
+	     (car (bbdb-record-name record))))))
+
 (defun bbdb-wl-from-func (string)
-  "A candidate From field STRING.  For `wl-summary-from-func'."
+  "A candidate From field STRING.  For `wl-summary-from-function'."
   (let ((hit (bbdb-search-simple nil (wl-address-header-extract-address
 				      string)))
 	first-name last-name from-str)
@@ -117,11 +162,121 @@
 	  from-str)
       string)))
 
+(defun bbdb-wl-get-addresses-1 (&optional only-first-address)
+  "Return real name and email address of sender respectively recipients.
+If an address matches `bbdb-user-mail-names' it will be ignored.
+The headers to search can be configured by `bbdb-get-addresses-headers'.
+For BBDB 2.33 or earlier."
+  (save-excursion
+    (save-restriction
+      (std11-narrow-to-header)
+      (let ((headers bbdb-get-addresses-headers)
+	    (uninteresting-senders bbdb-user-mail-names)
+	    addrlist header structures structure fn ad)
+	(while headers
+	  (setq header (std11-fetch-field (car headers)))
+	  (when header
+	    (setq structures (std11-parse-addresses-string
+			      (std11-unfold-string header)))
+	    (while (and (setq structure (car structures))
+			(eq (car structure) 'mailbox))
+	      (setq fn (std11-full-name-string structure)
+		    fn (and fn
+			    (with-temp-buffer ; to keep raw buffer unibyte.
+			      (set-buffer-multibyte
+			       default-enable-multibyte-characters)
+			      (eword-decode-string
+			       (decode-mime-charset-string
+				fn wl-mime-charset))))
+                    fn (funcall bbdb-wl-canonicalize-full-name-function fn)
+		    ad (std11-address-string structure))
+	      ;; ignore uninteresting addresses, this is kinda gross!
+	      (when (or (not (stringp uninteresting-senders))
+			(not
+			 (or
+			  (and fn (string-match uninteresting-senders fn))
+			  (and ad (string-match uninteresting-senders ad)))))
+		(add-to-list 'addrlist (list fn ad)))
+	      (if (and only-first-address addrlist)
+		  (setq structures nil headers nil)
+		(setq structures (cdr structures)))))
+	  (setq headers (cdr headers)))
+	(nreverse addrlist)))))
+
+(defun bbdb-wl-get-addresses-2 (&optional only-first-address)
+  "Return real name and email address of sender respectively recipients.
+If an address matches `bbdb-user-mail-names' it will be ignored.
+The headers to search can be configured by `bbdb-get-addresses-headers'.
+For BBDB 2.34 or later."
+  (save-excursion
+    (save-restriction
+      (std11-narrow-to-header)
+      (let ((headers bbdb-get-addresses-headers)
+	    (uninteresting-senders bbdb-user-mail-names)
+	    addrlist header structures structure fn ad
+	    header-type header-fields header-content)
+	(while headers
+	  (setq header-type (caar headers)
+		header-fields (cdar headers))
+	  (while header-fields
+	    (setq header-content (std11-fetch-field (car header-fields)))
+	    (when header-content
+	      (setq structures (std11-parse-addresses-string
+				(std11-unfold-string header-content)))
+	      (while (and (setq structure (car structures))
+			  (eq (car structure) 'mailbox))
+                (setq fn (std11-full-name-string structure)
+		      fn (and fn
+			      (with-temp-buffer ; to keep raw buffer unibyte.
+				(set-buffer-multibyte
+				 default-enable-multibyte-characters)
+				(eword-decode-string
+				 (decode-mime-charset-string
+				  fn wl-mime-charset))))
+		      fn (funcall bbdb-wl-canonicalize-full-name-function fn)
+		      ad (std11-address-string structure))
+		;; ignore uninteresting addresses, this is kinda gross!
+		(when (or (not (stringp uninteresting-senders))
+			  (not
+			   (or
+			    (and fn
+				 (string-match uninteresting-senders fn))
+			    (and ad
+				 (string-match uninteresting-senders ad)))))
+		  (add-to-list 'addrlist (list header-type
+					       (car header-fields)
+					       (list fn ad))))
+		(if (and only-first-address addrlist)
+		    (setq structures nil headers nil)
+		  (setq structures (cdr structures)))))
+	    (setq header-fields (cdr header-fields)))
+	  (setq headers (cdr headers)))
+	(nreverse addrlist)))))
+
+(defun bbdb-wl-get-addresses (&optional only-first-address)
+  "Return real name and email address of sender respectively recipients.
+If an address matches `bbdb-user-mail-names' it will be ignored.
+The headers to search can be configured by `bbdb-get-addresses-headers'."
+  (if (string< bbdb-version "2.34")
+      (bbdb-wl-get-addresses-1)
+    (bbdb-wl-get-addresses-2)))
+
 (defun bbdb-wl-update-record (&optional offer-to-create)
   "Returns the record corresponding to the current WL message,
 creating or modifying it as necessary.  A record will be created if
 bbdb/mail-auto-create-p is non-nil, or if OFFER-TO-CREATE is true and
 the user confirms the creation."
+  (let* ((bbdb-get-only-first-address-p t)
+	 (records (bbdb-wl-update-records offer-to-create)))
+    (if (and records (listp records))
+	(car records)
+      records)))
+
+(defun bbdb-wl-update-records (&optional offer-to-create)
+  "Returns the records corresponding to the current WL message,
+creating or modifying it as necessary.  A record will be created if
+bbdb/mail-auto-create-p is non-nil, or if OFFER-TO-CREATE is true and
+the user confirms the creation."
   (save-excursion
     (if bbdb-use-pop-up
 	(bbdb-wl-pop-up-bbdb-buffer offer-to-create)
@@ -131,37 +286,47 @@ the user confirms the creation."
 		(save-excursion
 		  (if (buffer-live-p wl-current-summary-buffer)
 		      (set-buffer wl-current-summary-buffer))
-		  wl-message-buf-name))
+		  wl-message-buffer))
 	       (intern (format
 			"%s-%d"
 			wl-current-summary-buffer
-			wl-message-buffer-cur-number)))))
-	(or (bbdb-message-cache-lookup key nil)
-	    (and key
-		 (let* ((from (or (std11-field-body "From") ""))
-			(addr (and from
-				   (nth 1 (std11-extract-address-components
-					   from)))))
-		   (if (or (null from)
-			   (null addr)
-			   (string-match (bbdb-user-mail-names) addr))
-		       (setq from (or (std11-field-body "To") from)))
-		   (with-temp-buffer ; to keep raw buffer unibyte.
-		     (elmo-set-buffer-multibyte
-		      default-enable-multibyte-characters)
-		     (setq from (eword-decode-string
-				 (decode-mime-charset-string
-				  from
-				  wl-mime-charset))))
-		   (if from
-		       (bbdb-encache-message
-			key
-			(bbdb-annotate-message-sender
-			 from t
-			 (or (bbdb-invoke-hook-for-value
-			      bbdb/mail-auto-create-p)
-			     offer-to-create)
-			 offer-to-create))))))))))
+			wl-message-buffer-cur-number))))
+	    record)
+	(or (progn (setq record (bbdb-message-cache-lookup key))
+		   (if (listp record) (nth 1 record) record))
+	    (static-if (not (fboundp 'bbdb-update-records))
+		(let* ((from (or (std11-field-body "From") ""))
+		       (addr (and from
+				  (nth 1 (std11-extract-address-components
+					  from)))))
+		  (if (or (null from)
+			  (null addr)
+			  (string-match (bbdb-user-mail-names) addr))
+		      (setq from (or (std11-field-body "To") from)))
+		  (with-temp-buffer ; to keep raw buffer unibyte.
+		    (set-buffer-multibyte
+		     default-enable-multibyte-characters)
+		    (setq from (eword-decode-string
+				(decode-mime-charset-string
+				 from
+				 wl-mime-charset))))
+		  (if from
+		      (bbdb-encache-message
+		       key
+		       (bbdb-annotate-message-sender
+			from t
+			(or (bbdb-invoke-hook-for-value
+			     bbdb/mail-auto-create-p)
+			    offer-to-create)
+			offer-to-create))))
+	      (bbdb-encache-message
+	       key
+	       (bbdb-update-records (bbdb-wl-get-addresses
+				     bbdb-get-only-first-address-p)
+				    (or (bbdb-invoke-hook-for-value
+					 bbdb/mail-auto-create-p)
+					offer-to-create)
+				    offer-to-create))))))))
 
 (defun bbdb-wl-annotate-sender (string)
   "Add a line to the end of the Notes field of the BBDB record
@@ -176,7 +341,7 @@ corresponding to the sender of this message."
   "Edit the notes field or (with a prefix arg) a user-defined field
 of the BBDB record corresponding to the sender of this message."
   (interactive "P")
-  (wl-summary-redisplay)
+  (wl-summary-set-message-buffer-or-redisplay)
   (set-buffer (wl-message-get-original-buffer))
   (let ((record (or (bbdb-wl-update-record t) (error ""))))
     (bbdb-display-records (list record))
@@ -184,23 +349,61 @@ of the BBDB record corresponding to the sender of this message."
 	(bbdb-record-edit-property record nil t)
       (bbdb-record-edit-notes record t))))
 
-(defun bbdb-wl-show-sender ()
+(defun bbdb-wl-show-records (&optional headers)
   "Display the contents of the BBDB for the sender of this message.
 This buffer will be in `bbdb-mode', with associated keybindings."
   (interactive)
-  (wl-summary-redisplay)
+  (wl-summary-set-message-buffer-or-redisplay)
   (set-buffer (wl-message-get-original-buffer))
-  (let ((record (bbdb-wl-update-record t))
-	bbdb-win)
-    (if record
+  (let ((bbdb-get-addresses-headers (or headers bbdb-get-addresses-headers))
+	(bbdb-update-records-mode 'annotating)
+	(bbdb-message-cache nil)
+	(bbdb-user-mail-names nil)
+	records bbdb-win)
+    (setq records (bbdb-wl-update-records t))
+    (if records
 	(progn
 	  (bbdb-wl-pop-up-bbdb-buffer)
-	  (bbdb-display-records (list record)))
-      (error "Unperson"))
+	  (bbdb-display-records (if (listp records) records
+				  (list records))))
+      (bbdb-undisplay-records))
     (setq bbdb-win (get-buffer-window (get-buffer bbdb-buffer-name)))
     (and bbdb-win
-	 (select-window bbdb-win))))
+	 (select-window bbdb-win))
+    records))
+
+(defun bbdb-wl-address-headers-spec (address-class)
+  "Return address headers structure for ADDRESS-CLASS."
+  (if (string< bbdb-version "2.34")
+      (cond
+       ((eq address-class 'recipients)
+	bbdb-get-addresses-to-headers)
+       ((eq address-class 'authors)
+	bbdb-get-addresses-from-headers)
+       (t
+	(append bbdb-get-addresses-to-headers
+		bbdb-get-addresses-from-headers)))
+    (list (assoc address-class bbdb-get-addresses-headers))))
 
+(defun bbdb-wl-show-all-recipients ()
+  "Show all recipients of this message. Counterpart to `bbdb/vm-show-sender'."
+  (interactive)
+  (bbdb-wl-show-records (bbdb-wl-address-headers-spec 'recipients)))
+
+(defun bbdb-wl-show-sender (&optional show-recipients)
+  "Display the contents of the BBDB for the senders of this message.
+With a prefix argument show the recipients instead,
+with two prefix arguments show all records.
+This buffer will be in `bbdb-mode', with associated keybindings."
+  (interactive "p")
+  (cond ((= 4 show-recipients)
+	 (bbdb-wl-show-all-recipients))
+	((= 16 show-recipients)
+	 (bbdb-wl-show-records))
+	(t
+	 (if (null (bbdb-wl-show-records
+		    (bbdb-wl-address-headers-spec 'authors)))
+	     (bbdb-wl-show-all-recipients)))))
 
 (defun bbdb-wl-pop-up-bbdb-buffer (&optional offer-to-create)
   "Make the *BBDB* buffer be displayed along with the WL window(s),
@@ -211,7 +414,7 @@ displaying the record corresponding to the sender of the current message."
 		    (save-excursion
 		      (if (buffer-live-p  wl-current-summary-buffer)
 			  (set-buffer wl-current-summary-buffer))
-		      wl-message-buf-name)))
+		      wl-message-buffer)))
 	  (cur-win (selected-window))
 	  (b (current-buffer)))
       (and mes-win
@@ -235,12 +438,22 @@ displaying the record corresponding to the sender of the current message."
   (let ((bbdb-gag-messages t)
 	(bbdb-use-pop-up nil)
 	(bbdb-electric-p nil))
-    (let ((record (bbdb-wl-update-record offer-to-create))
-	  (bbdb-elided-display (bbdb-pop-up-elided-display))
-	  (b (current-buffer)))
-      (bbdb-display-records (if record (list record) nil))
+    (let* ((records (static-if (fboundp 'bbdb-update-records)
+			(bbdb-wl-update-records offer-to-create)
+		      (bbdb-wl-update-record offer-to-create)))
+	   ;; BBDB versions v2.33 and later.
+	   (bbdb-display-layout
+	    (cond ((boundp 'bbdb-pop-up-display-layout)
+		   (symbol-value 'bbdb-pop-up-display-layout))
+		  ((boundp 'bbdb-pop-up-elided-display)
+		   (symbol-value 'bbdb-pop-up-elided-display))))
+	   ;; BBDB versions prior to v2.33,
+	   (bbdb-elided-display bbdb-display-layout)
+	   (b (current-buffer)))
+      (bbdb-display-records (if (listp records) records
+			      (list records)))
       (set-buffer b)
-      record)))
+      records)))
 
 (defun bbdb-wl-send-mail-internal (&optional to subj records)
   (unwind-protect
@@ -249,26 +462,28 @@ displaying the record corresponding to the sender of the current message."
 
 ;;; @ bbdb-extract-field-value -- stolen from tm-bbdb.
 ;;;
-(and (not (fboundp 'bbdb-extract-field-value-internal))
-;;;  (not (fboundp 'PLEASE_REPLACE_WITH_SEMI-BASED_MIME-BBDB)) ;; mime-bbdb
-    (progn
-;;;   (require 'bbdb-hooks) ; not provided.
-;;;   (or (fboundp 'bbdb-extract-field-value) ; defined as autoload
-      (or (fboundp 'bbdb-header-start)
-          (load "bbdb-hooks"))
-      (fset 'bbdb-extract-field-value-internal
-	    (cond
-	     ((fboundp 'tm:bbdb-extract-field-value)
-	      (symbol-function 'tm:bbdb-extract-field-value))
-	     (t (symbol-function 'bbdb-extract-field-value))))
-      (defun bbdb-extract-field-value (field)
-	(let ((value (bbdb-extract-field-value-internal field)))
-	  (with-temp-buffer ; to keep raw buffer unibyte.
-	    (elmo-set-buffer-multibyte
-	     default-enable-multibyte-characters)
-	    (and value
-		 (eword-decode-string value)))))
-      ))
+(eval-and-compile
+  (if (fboundp 'bbdb-wl-extract-field-value-internal)
+;;(if (fboundp 'PLEASE_REPLACE_WITH_SEMI-BASED_MIME-BBDB)) ;; mime-bbdb
+      nil
+    (if (and (string< bbdb-version "1.58")
+	     ;;(not (fboundp 'bbdb-extract-field-value) ;; defined as autoload
+	     (not (fboundp 'bbdb-header-start)))
+	(load "bbdb-hooks")
+      (require 'bbdb-hooks))
+    (fset 'bbdb-wl-extract-field-value-internal
+	  (cond
+	   ((fboundp 'tm:bbdb-extract-field-value)
+	    (symbol-function 'tm:bbdb-extract-field-value))
+	   (t (symbol-function 'bbdb-extract-field-value))))
+    (defun bbdb-extract-field-value (field)
+      (let ((value (bbdb-wl-extract-field-value-internal field)))
+	(with-temp-buffer ; to keep raw buffer unibyte.
+	  (set-buffer-multibyte
+	   default-enable-multibyte-characters)
+	  (and value
+	       (eword-decode-string value)))))
+    ))
 
 
 (provide 'bbdb-wl)