X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Fgnus-bbdb.el;h=d8d696044b36823736f7775efbbef35babe705b8;hb=29d5f44c1b8941959c487877893196ec52b3a969;hp=6caef296cbccc3284e3137a22603be8e384de2ce;hpb=f5e767982ebad2499b626b7ba2c53305b3846bf7;p=elisp%2Fgnus.git-

diff --git a/lisp/gnus-bbdb.el b/lisp/gnus-bbdb.el
index 6caef29..d8d6960 100644
--- a/lisp/gnus-bbdb.el
+++ b/lisp/gnus-bbdb.el
@@ -1,15 +1,15 @@
-;; gnus-bbdb.el --- Interface to Semi-gnus
+;; gnus-bbdb.el --- Interface to T-gnus
 
 ;; Copyright (c) 1991,1992,1993 Jamie Zawinski <jwz@netscape.com>.
 ;; Copyright (C) 1995,1996,1997 Shuhei KOBAYASHI
 ;; Copyright (C) 1997,1998 MORIOKA Tomohiko
-;; Copyright (C) 1998 Keiichi Suzuki <kei-suzu@mail.wbs.ne.jp>
+;; Copyright (C) 1998,1999 Keiichi Suzuki <keiichi@nanap.org>
 
-;; Author: Keiichi Suzuki <kei-suzu@mail.wbs.ne.jp>
+;; Author: Keiichi Suzuki <keiichi@nanap.org>
 ;; Author: Shuhei KOBAYASHI <shuhei-k@jaist.ac.jp>
 ;; Keywords: BBDB, MIME, multimedia, multilingual, mail, news
 
-;; This file is part of Semi-gnus.
+;; This file is part of T-gnus.
 
 ;; This program is free software; you can redistribute it and/or
 ;; modify it under the terms of the GNU General Public License as
@@ -29,10 +29,13 @@
 ;;; Code:
 
 (require 'bbdb)
+(require 'bbdb-com)
 (require 'gnus)
 (require 'std11)
 (eval-when-compile
-  (require 'gnus-win))
+  (defvar bbdb-pop-up-elided-display)	; default unbound.
+  (require 'gnus-win)
+  (require 'cl))
 
 (defvar gnus-bbdb/decode-field-body-function 'nnheader-decode-field-body
   "*Field body decoder.")
@@ -45,49 +48,41 @@
 
 ;;;###autoload
 (defun gnus-bbdb/update-record (&optional offer-to-create)
-  "returns the record corresponding to the current GNUS message, creating 
-or modifying it as necessary.  A record will be created if 
+  "returns the record corresponding to the current GNUS message, creating
+or modifying it as necessary.  A record will be created if
 bbdb/news-auto-create-p is non-nil, or if OFFER-TO-CREATE is true and
 the user confirms the creation."
   (if bbdb-use-pop-up
       (gnus-bbdb/pop-up-bbdb-buffer offer-to-create)
-    (save-excursion
-      (save-restriction
-	(let (from)
-	  (set-buffer gnus-original-article-buffer)
-	  (widen)
-	  (narrow-to-region (point-min)
-			    (progn (goto-char (point-min))
-				   (or (search-forward "\n\n" nil t)
-				       (error "message unexists"))
-				   (- (point) 2)))
-	  (when (setq from (mail-fetch-field "from"))
-	    (setq from (gnus-bbdb/extract-address-components
-			(gnus-bbdb/decode-field-body from 'From))))
-	  (when (and (car (cdr from))
-		     (string-match (bbdb-user-mail-names)
-				   (car (cdr from))))
-	    ;; if logged-in user sent this, use recipients.
-	    (let ((to (mail-fetch-field "to")))
-	      (when to
-		(setq from
-		      (gnus-bbdb/extract-address-components
-		       (gnus-bbdb/decode-field-body to 'To))))))
-	(when from
+    (let ((from (mime-entity-fetch-field gnus-current-headers "from")))
+      (when from
+	(setq from (gnus-bbdb/extract-address-components
+		    (gnus-bbdb/decode-field-body from 'From))))
+      (when (and (car (cdr from))
+		 (string-match (bbdb-user-mail-names)
+			       (car (cdr from))))
+	;; if logged-in user sent this, use recipients.
+	(let ((to (mime-entity-fetch-field gnus-current-headers "to")))
+	  (when to
+	    (setq from
+		  (gnus-bbdb/extract-address-components
+		   (gnus-bbdb/decode-field-body to 'To))))))
+      (when from
+	(save-excursion
 	  (bbdb-annotate-message-sender from t
 					(or (bbdb-invoke-hook-for-value
 					     bbdb/news-auto-create-p)
 					    offer-to-create)
-					offer-to-create)))))))
+					offer-to-create))))))
 
 ;;;###autoload
 (defun gnus-bbdb/annotate-sender (string &optional replace)
-  "Add a line to the end of the Notes field of the BBDB record 
+  "Add a line to the end of the Notes field of the BBDB record
 corresponding to the sender of this message.  If REPLACE is non-nil,
 replace the existing notes entry (if any)."
   (interactive (list (if bbdb-readonly-p
 			 (error "The Insidious Big Brother Database is read-only.")
-			 (read-string "Comments: "))))
+		       (read-string "Comments: "))))
   (bbdb-annotate-notes (gnus-bbdb/update-record t) string 'notes replace))
 
 (defun gnus-bbdb/edit-notes (&optional arg)
@@ -108,43 +103,126 @@ This buffer will be in bbdb-mode, with associated keybindings."
   (let ((record (gnus-bbdb/update-record t)))
     (if record
 	(bbdb-display-records (list record))
-	(error "unperson"))))
+      (error "unperson"))))
 
-;; Avoid byte-compile warning.
-(defvar bbdb-pop-up-elided-display)
 
 (defun gnus-bbdb/pop-up-bbdb-buffer (&optional offer-to-create)
   "Make the *BBDB* buffer be displayed along with the GNUS windows,
 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 (gnus-bbdb/update-record offer-to-create))
-	  (bbdb-elided-display (bbdb-pop-up-elided-display))
-	  (b (current-buffer)))
+  (let* ((bbdb-gag-messages t)
+	 (bbdb-electric-p nil)
+	 (record
+	  (let (bbdb-use-pop-up)
+	    (gnus-bbdb/update-record offer-to-create)))
+	 (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-elided-display bbdb-display-layout))
+    (save-current-buffer
       ;; display the bbdb buffer iff there is a record for this article.
-      (cond (record
-	     (bbdb-pop-up-bbdb-buffer
-	      (function (lambda (w)
-			  (let ((b (current-buffer)))
-			    (set-buffer (window-buffer w))
-			    (prog1 (or (eq major-mode 'mime-veiw-mode)
-				       (eq major-mode 'gnus-article-mode))
-				   (set-buffer b))))))
-	     (bbdb-display-records (list record)))
-	    (t
-	     (or bbdb-inside-electric-display
-		 (not (get-buffer-window bbdb-buffer-name))
-		 (let (w)
-		   (delete-other-windows)
-		   (if (assq 'article gnus-buffer-configuration)
-		       (gnus-configure-windows 'article)
-		     (gnus-configure-windows 'SelectArticle))
-		   (if (setq w (get-buffer-window gnus-summary-buffer))
-		       (select-window w))
-		   ))))
-      (set-buffer b)
-      record)))
+      (cond
+       (record
+	(bbdb-pop-up-bbdb-buffer
+	 (lambda (w)
+	   (with-current-buffer (window-buffer w)
+	     (memq major-mode
+		   '(mime-view-mode gnus-article-mode)))))
+	(bbdb-display-records (list record)))
+       ((and (not bbdb-inside-electric-display)
+	     (get-buffer-window bbdb-buffer-name))
+	(delete-other-windows)
+	(if (assq 'article gnus-buffer-configuration)
+	    (gnus-configure-windows 'article)
+	  (gnus-configure-windows 'SelectArticle))
+	(let ((w (get-buffer-window gnus-summary-buffer)))
+	  (if w (select-window w))))))
+    record))
+
+;;;###autoload
+(defun gnus-bbdb/split-mail (header-field bbdb-field
+					  &optional regexp group)
+  "Mail split method for `nnmail-split-fancy'.
+HEADER-FIELD is a regexp or list of regexps as mail header field name
+for gathering mail addresses.  If HEADER-FIELD is a string, then it's
+used for just matching pattern.  If HEADER-FIELD is a list of strings,
+then these strings have priorities in the order.
+
+BBDB-FIELD is field name of BBDB.
+Optional argument REGEXP is regexp string for matching BBDB-FIELD value.
+If REGEXP is nil or not specified, then all BBDB-FIELD value is matched.
+
+If GROUP is nil or not specified, then BBDB-FIELD value is returned as
+group name.  If GROUP is a symbol `&', then list of all matching group's
+BBDB-FIELD values is returned.  Otherwise, GROUP is returned."
+  (if (listp header-field)
+      (if (eq group '&)
+	  (gnus-bbdb/split-mail (mapconcat 'identity header-field "\\|")
+				bbdb-field regexp group)
+	(let (rest)
+	  (while (and header-field
+		      (null (setq rest (gnus-bbdb/split-mail
+					(car header-field) bbdb-field
+					regexp group))))
+	    (setq header-field (cdr header-field)))
+	  rest))
+    (let ((pat (concat "^\\(" header-field "\\):[ \t]"))
+	  header-values)
+      (goto-char (point-min))
+      (while (re-search-forward pat nil t)
+	(setq header-values (cons (buffer-substring (point)
+						    (std11-field-end))
+				  header-values)))
+      (let ((address-regexp
+	     (with-temp-buffer
+	       (let (lal)
+		 (while header-values
+		   (setq lal (std11-parse-addresses-string
+			      (pop header-values)))
+		   (while lal
+		     (gnus-bbdb/insert-address-regexp (pop lal)))))
+	       (buffer-string))))
+	(unless (zerop (length address-regexp))
+	  (gnus-bbdb/split-mail-1 address-regexp bbdb-field regexp group))))))
+
+(defun gnus-bbdb/insert-address-regexp (address)
+  "Insert string of address part from parsed ADDRESS of RFC 822."
+  (cond ((eq (car address) 'group)
+	 (setq address (cdr address))
+	 (while address
+	   (gnus-bbdb/insert-address-regexp (pop address))))
+	((eq (car address) 'mailbox)
+	 (unless (eq (point) (point-min))
+	   (insert "\\|"))
+	 (let ((addr (nth 1 address)))
+	   (insert (regexp-quote (std11-addr-to-string
+				  (if (eq (car addr) 'phrase-route-addr)
+				      (nth 2 addr)
+				    (cdr addr)))))))))
+
+(defun gnus-bbdb/split-mail-1 (address-regexp bbdb-field regexp group)
+  (let ((records (bbdb-search (bbdb-records) nil nil address-regexp))
+	prop rest)
+    (or regexp (setq regexp ""))
+    (catch 'done
+      (cond
+       ((eq group '&)
+	(while records
+	  (when (and (setq prop (bbdb-record-getprop (car records) bbdb-field))
+		     (string-match regexp prop)
+		     (not (member prop rest)))
+	    (setq rest (cons prop rest)))
+	  (setq records (cdr records)))
+	(throw 'done (when rest (cons '& rest))))
+       (t
+	(while records
+	  (when (or (null bbdb-field)
+		    (and (setq prop (bbdb-record-getprop (car records)
+							 bbdb-field))
+			 (string-match regexp prop)))
+	    (throw 'done (or group prop)))
+	  (setq records (cdr records))))))))
 
 ;;
 ;; Announcing BBDB entries in the summary buffer
@@ -167,8 +245,10 @@ This variable has no effect on the marking controlled by
   :group 'bbdb-mua-specific-gnus
   :type '(choice (const :tag "Mark known posters" t)
 		 (const :tag "Do not mark known posters" nil)))
-(defvaralias 'gnus-bbdb/mark-known-posters
-  'gnus-bbdb/summary-mark-known-posters)
+(static-when (and (fboundp 'defvaralias)
+		  (subrp (symbol-function 'defvaralias)))
+  (defvaralias 'gnus-bbdb/mark-known-posters
+    'gnus-bbdb/summary-mark-known-posters))
 
 (defcustom gnus-bbdb/summary-known-poster-mark "+"
   "This is the default character to prefix author names with if
@@ -187,8 +267,10 @@ people who aren't in the database, of course.  (`gnus-optional-headers'
 must be `gnus-bbdb/lines-and-from' for GNUS users.)"
   :group 'bbdb-mua-specific-gnus
   :type 'boolean)
-(defvaralias 'gnus-bbdb/header-show-bbdb-names
-  'gnus-bbdb/summary-show-bbdb-names)
+(static-when (and (fboundp 'defvaralias)
+		  (subrp (symbol-function 'defvaralias)))
+  (defvaralias 'gnus-bbdb/header-show-bbdb-names
+    'gnus-bbdb/summary-show-bbdb-names))
 
 (defcustom gnus-bbdb/summary-prefer-bbdb-data t
   "If t, then for posters who are in our BBDB, replace the information
@@ -207,8 +289,10 @@ See `gnus-bbdb/lines-and-from' for GNUS users, or
   :group 'bbdb-mua-specific-gnus
   :type '(choice (const :tag "Prefer real names" t)
 		 (const :tag "Prefer network addresses" nil)))
-(defvaralias 'gnus-bbdb/header-prefer-real-names
-  'gnus-bbdb/summary-prefer-real-names)
+(static-when (and (fboundp 'defvaralias)
+		  (subrp (symbol-function 'defvaralias)))
+  (defvaralias 'gnus-bbdb/header-prefer-real-names
+    'gnus-bbdb/summary-prefer-real-names))
 
 (defcustom gnus-bbdb/summary-user-format-letter "B"
   "This is the gnus-user-format-function- that will be used to insert
@@ -256,8 +340,9 @@ strings.  In the future this should change."
 		      (error nil))))
 	 (name (car data))
 	 (net (car (cdr data)))
-	 (record (and data 
-		      (bbdb-search-simple name 
+	 (record (and data
+		      (bbdb-search-simple
+		       name
 		       (if (and net bbdb-canonicalize-net-hook)
 			   (bbdb-canonicalize-address net)
 			 net))))
@@ -267,7 +352,7 @@ strings.  In the future this should change."
 	;; bogon!
 	(setq record nil))
 
-    (setq name 
+    (setq name
 	  (or (and gnus-bbdb/summary-prefer-bbdb-data
 		   (or (and gnus-bbdb/summary-prefer-real-names
 			    (and record (bbdb-record-name record)))
@@ -278,22 +363,22 @@ strings.  In the future this should change."
 			    net)
 		       name))
 	      net from "**UNKNOWN**"))
-      ;; GNUS can't cope with extra square-brackets appearing in the summary.
-      (if (and name (string-match "[][]" name))
-	  (progn (setq name (copy-sequence name))
-		 (while (string-match "[][]" name)
-		   (aset name (match-beginning 0) ? ))))
-      (setq string (format "%s%3d:%s"
-			   (if (and record gnus-bbdb/summary-mark-known-posters)
-			       (or (bbdb-record-getprop
-				    record bbdb-message-marker-field)
-				   "*")
-			     " ")
-			   lines (or name from))
-	    L (length string))
-      (cond ((> L length) (substring string 0 length))
-	    ((< L length) (concat string (make-string (- length L) ? )))
-	    (t string))))
+    ;; GNUS can't cope with extra square-brackets appearing in the summary.
+    (if (and name (string-match "[][]" name))
+	(progn (setq name (copy-sequence name))
+	       (while (string-match "[][]" name)
+		 (aset name (match-beginning 0) ? ))))
+    (setq string (format "%s%3d:%s"
+			 (if (and record gnus-bbdb/summary-mark-known-posters)
+			     (or (bbdb-record-getprop
+				  record bbdb-message-marker-field)
+				 "*")
+			   " ")
+			 lines (or name from))
+	  L (length string))
+    (cond ((> L length) (substring string 0 length))
+	  ((< L length) (concat string (make-string (- length L) ? )))
+	  (t string))))
 
 (defun gnus-bbdb/summary-get-author (header)
   "Given a Gnus message header, returns the appropriate piece of
@@ -313,15 +398,16 @@ This function is meant to be used with the user function defined in
 		      (error nil))))
 	 (name (car data))
 	 (net (car (cdr data)))
-	 (record (and data 
-		      (bbdb-search-simple name 
+	 (record (and data
+		      (bbdb-search-simple
+		       name
 		       (if (and net bbdb-canonicalize-net-hook)
 			   (bbdb-canonicalize-address net)
 			 net)))))
     (if (and record name (member (downcase name) (bbdb-record-net record)))
 	;; bogon!
 	(setq record nil))
-    (setq name 
+    (setq name
 	  (or (and gnus-bbdb/summary-prefer-bbdb-data
 		   (or (and gnus-bbdb/summary-prefer-real-names
 			    (and record (bbdb-record-name record)))
@@ -407,12 +493,12 @@ field.  This allows the BBDB to serve as a supplemental global score
 file, with the advantage that it can keep up with multiple and changing
 addresses better than the traditionally static global scorefile."
   (list (list
-   (condition-case nil
-       (read (gnus-bbdb/score-as-text group))
-     (error (setq gnus-bbdb/score-rebuild-alist t)
-	    (message "Problem building BBDB score table.")
-	    (ding) (sit-for 2)
-	    nil)))))
+	 (condition-case nil
+	     (read (gnus-bbdb/score-as-text group))
+	   (error (setq gnus-bbdb/score-rebuild-alist t)
+		  (message "Problem building BBDB score table.")
+		  (ding) (sit-for 2)
+		  nil)))))
 
 (defun gnus-bbdb/score-as-text (group)
   "Returns a SCORE file format string built from the BBDB."
@@ -421,38 +507,29 @@ addresses better than the traditionally static global scorefile."
 		    (setq gnus-bbdb/score-default-internal
 			  gnus-bbdb/score-default)
 		    t))
-	    (not gnus-bbdb/score-alist)
-	    gnus-bbdb/score-rebuild-alist)
-    (setq gnus-bbdb/score-rebuild-alist nil)
-    (setq gnus-bbdb/score-alist
-	  (concat "((touched nil) (\"from\"\n"
-		  (mapconcat
-		   (lambda (rec)
-		     (let ((score (or (bbdb-record-getprop rec
-							   gnus-bbdb/score-field)
-				      gnus-bbdb/score-default))
-			   (net (bbdb-record-net rec)))
-		       (if (not (and score net)) nil
-			 (mapconcat
-			  (lambda (addr)
-			    (concat "(\"" addr "\" " score ")\n"))
-			  net ""))))
-		   (bbdb-records) "")
-		  "))"))))
+	     (not gnus-bbdb/score-alist)
+	     gnus-bbdb/score-rebuild-alist)
+	 (setq gnus-bbdb/score-rebuild-alist nil)
+	 (setq gnus-bbdb/score-alist
+	       (concat "((touched nil) (\"from\"\n"
+		       (mapconcat
+			(lambda (rec)
+			  (let ((score (or (bbdb-record-getprop
+					    rec
+					    gnus-bbdb/score-field)
+					   gnus-bbdb/score-default))
+				(net (bbdb-record-net rec)))
+			    (if (not (and score net)) nil
+			      (mapconcat
+			       (lambda (addr)
+				 (concat "(\"" addr "\" " score ")\n"))
+			       net ""))))
+			(bbdb-records) "")
+		       "))"))))
   gnus-bbdb/score-alist)
 
 (defun gnus-bbdb/extract-field-value-init ()
-  (when (or (and (eq (current-buffer) (get-buffer gnus-article-buffer))
-		 (buffer-live-p gnus-original-article-buffer)
-		 (set-buffer gnus-original-article-buffer))
-	    (eq (current-buffer) (get-buffer gnus-original-article-buffer)))
-    (widen)
-    (narrow-to-region (point-min)
-		      (progn (goto-char (point-min))
-			     (or (search-forward "\n\n" nil t)
-				 (error "message unexists"))
-			     (- (point) 2)))
-    'gnus-bbdb/extract-field-value))
+  (function gnus-bbdb/extract-field-value))
 
 (defun gnus-bbdb/extract-field-value (field-name)
   "Given the name of a field (like \"Subject\") this returns the value of
@@ -465,7 +542,8 @@ beginning of the message headers."
   ;; divided real-names from addresses; the actual From: and Subject: fields
   ;; exist only in the message.
   (let (value)
-    (when (setq value (mail-fetch-field field-name))
+    (when (setq value (mime-entity-fetch-field
+		       gnus-current-headers field-name))
       (gnus-bbdb/decode-field-body value field-name))))
 
 ;;; @ mail-extr
@@ -477,17 +555,16 @@ beginning of the message headers."
 
 (defun gnus-bbdb/extract-address-components (str)
   (let* ((ret     (std11-extract-address-components str))
-         (phrase  (car ret))
-         (address (car (cdr ret)))
-         (methods gnus-bbdb/canonicalize-full-name-methods))
+	 (phrase  (car ret))
+	 (address (car (cdr ret)))
+	 (methods gnus-bbdb/canonicalize-full-name-methods))
     (while (and phrase methods)
       (setq phrase  (funcall (car methods) phrase)
-            methods (cdr methods)))
+	    methods (cdr methods)))
     (if (string= address "") (setq address nil))
     (if (string= phrase "") (setq phrase nil))
     (when (or phrase address)
-      (list phrase address))
-    ))
+      (list phrase address))))
 
 ;;; @ full-name canonicalization methods
 ;;;
@@ -496,25 +573,21 @@ beginning of the message headers."
   (let (dest)
     (while (string-match "\\s +" str)
       (setq dest (cons (substring str 0 (match-beginning 0)) dest))
-      (setq str (substring str (match-end 0)))
-      )
+      (setq str (substring str (match-end 0))))
     (or (string= str "")
-        (setq dest (cons str dest)))
+	(setq dest (cons str dest)))
     (setq dest (nreverse dest))
-    (mapconcat 'identity dest " ")
-    ))
+    (mapconcat 'identity dest " ")))
 
 (defun gnus-bbdb/canonicalize-dots (str)
   (let (dest)
     (while (string-match "\\." str)
       (setq dest (cons (substring str 0 (match-end 0)) dest))
-      (setq str (substring str (match-end 0)))
-      )
+      (setq str (substring str (match-end 0))))
     (or (string= str "")
-        (setq dest (cons str dest)))
+	(setq dest (cons str dest)))
     (setq dest (nreverse dest))
-    (mapconcat 'identity dest " ")
-    ))
+    (mapconcat 'identity dest " ")))
 
 ;;
 ;; Insinuation
@@ -549,7 +622,7 @@ beginning of the message headers."
 Please redefine `gnus-bbdb/summary-user-format-letter' to a different letter."
 			gnus-bbdb/summary-user-format-letter))
 	     (fset get-author-user-fun 'gnus-bbdb/summary-get-author))))
-    
+
     ; One tick.  One tick only, please
     (cond (gnus-bbdb/summary-in-bbdb-format-letter
 	   (if (and (fboundp in-bbdb-user-fun)
@@ -560,7 +633,7 @@ Please redefine `gnus-bbdb/summary-user-format-letter' to a different letter."
 Redefine `gnus-bbdb/summary-in-bbdb-format-letter' to a different letter."
 			gnus-bbdb/summary-in-bbdb-format-letter))
 	     (fset in-bbdb-user-fun 'gnus-bbdb/summary-author-in-bbdb)))))
-  
+
   ;; Scoring
   (add-hook 'bbdb-after-change-hook 'gnus-bbdb/score-invalidate-alist)
 ;  (setq gnus-score-find-score-files-function