From: keiichi <keiichi>
Date: Thu, 23 Dec 1999 10:09:06 +0000 (+0000)
Subject: Copy from Nana-gnus 6.13.
X-Git-Tag: nana-gnus-7_1_0_16~104
X-Git-Url: http://git.chise.org/cgi-bin/gitweb.cgi?a=commitdiff_plain;h=e4126aa234b9cc83f9727a39be9f12e2f69cd039;p=elisp%2Fgnus.git-

Copy from Nana-gnus 6.13.
---

diff --git a/lisp/gnus-bbdb.el b/lisp/gnus-bbdb.el
index 10b1acc..be73903 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 after Nana-gnus version 6.10.2.
 
 ;; 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 Nana-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,18 +29,20 @@
 ;;; Code:
 
 (require 'bbdb)
+(require 'bbdb-com)
 (require 'gnus)
 (require 'std11)
 (eval-when-compile
+  (defvar bbdb-pop-up-elided-display)	; default unbound.
   (require 'gnus-win))
 
-(defvar gnus-bbdb/decode-field-body-function 'eword-decode-string
+(defvar gnus-bbdb/decode-field-body-function 'nnheader-decode-field-body
   "*Field body decoder.")
 
 (defmacro gnus-bbdb/decode-field-body (field-body field-name)
   `(or (and (functionp gnus-bbdb/decode-field-body-function)
 	    (funcall gnus-bbdb/decode-field-body-function
-		     ,field-body))
+		     ,field-body ,field-name))
        ,field-body))
 
 ;;;###autoload
@@ -144,6 +146,74 @@ displaying the record corresponding to the sender of the current message."
       (set-buffer b)
       record)))
 
+;;;###autoload
+(defun gnus-bbdb/split-mail (header-field bbdb-field
+					  &optional regexp group)
+  "Mail split method for `nnmail-split-fancy'.
+HEADER-FIELED is a regexp or list of regexps as mail header field name
+for gathering mail addresses.  If HEADER-FIELED is a string, then it's
+used for just matching pattern.  If HEADER-FIELED 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 matcing group's
+BBDB-FEILD 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
+	     (mapconcat
+	      (lambda (lal)
+		(regexp-quote (std11-address-string lal)))
+	      (apply 'nconc
+		     (mapcar #'std11-parse-addresses-string
+			     header-values))
+	      "\\|")))
+	(unless (zerop (length address-regexp))
+	  (gnus-bbdb/split-mail-1 address-regexp bbdb-field regexp group))))))
+
+(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
 ;;