T-gnus 6.15.24 revision 00.

[elisp/gnus.git-] / lisp / gnus-bbdb.el

diff --git a/lisp/gnus-bbdb.el b/lisp/gnus-bbdb.el
index be9a7bf..35dd546 100644 (file)
--- a/lisp/gnus-bbdb.el
+++ b/lisp/gnus-bbdb.el
@@ -1,68 +1,109 @@
-;;; -*- Mode:Emacs-Lisp -*-
+;; gnus-bbdb.el --- Interface to T-gnus

 
 

-;;; This file is part of Semi-gnus.
-;;; copyright (c) 1991, 1992, 1993 Jamie Zawinski <jwz@netscape.com>.
-;;;               1998             Keiichi Suzuki <kei-suzu@mail.wbs.ne.jp>
+;; 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,1999 Keiichi Suzuki <keiichi@nanap.org>

 
 

-;;; The Insidious Big Brother Database 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 1, or (at your
-;;; option) any later version.
-;;;
-;;; BBDB 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 GNU Emacs; see the file COPYING.  If not, write to
-;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+;; 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 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
+;; published by the Free Software Foundation; either version 2, or (at
+;; your option) any later version.
+
+;; 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 GNU Emacs; see the file COPYING.  If not, write to the
+;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Code:

 
 (require 'bbdb)
 
 (require 'bbdb)

+(require 'bbdb-com)

 (require 'gnus)
 (require 'gnus)

+(require 'std11)

 (eval-when-compile
 (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.")
+
+(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-name))
+       ,field-body))
+
+(defvar gnus-bbdb/extract-message-sender-function
+  'gnus-bbdb/extract-message-sender)
+
+(defun gnus-bbdb/extract-message-sender ()
+  (let ((from (mime-entity-fetch-field gnus-current-headers "from"))
+       to)
+    (when from
+      (setq from (gnus-bbdb/extract-address-components
+                 (gnus-bbdb/decode-field-body from 'From)))
+      (if (and (car (cdr from))
+              (string-match (bbdb-user-mail-names) (car (cdr from)))
+              ;; if logged-in user sent this, use recipients.
+              (setq to (mime-entity-fetch-field gnus-current-headers "to")))
+         (gnus-bbdb/extract-address-components
+          (gnus-bbdb/decode-field-body to 'To))
+       from))))

 
 ;;;###autoload
 (defun gnus-bbdb/update-record (&optional offer-to-create)
 
 ;;;###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 
+  "Return 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)
 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)

-    (let (from)
-      (save-restriction
-       (set-buffer gnus-original-article-buffer)
-       (setq from (mail-header-from mime-message-structure))
-       (when (or (null from)
-                 (string-match (bbdb-user-mail-names)
-                               (mail-strip-quoted-names from)))
-         ;; if logged-in user sent this, use recipients.
-         (widen)
-         (narrow-to-region (point-min)
-                           (progn (goto-char (point-min))
-                                  (or (search-forward "\n\n" nil t)
-                                      (error "message unexists"))
-                                  (- (point) 2)))
-         (let ((to (mail-fetch-field "to")))
-           (when to
-            (setq from (nnheader-decode-field-body to 'To 'unfolding))))))
-      (when from
-       (bbdb-annotate-message-sender from t
-                                     (or (bbdb-invoke-hook-for-value
-                                          bbdb/news-auto-create-p)
-                                         offer-to-create)
-                                     offer-to-create)))))
+    (let ((message-key
+          (intern (mail-header-id gnus-current-headers)))
+         record sender)
+      (or (and (setq record (bbdb-message-cache-lookup message-key))
+              (if (listp record)
+                  (nth 1 record)
+                record))
+         (when (setq sender
+                     (funcall gnus-bbdb/extract-message-sender-function))
+           (save-excursion
+             (setq record (bbdb-annotate-message-sender
+                           sender t
+                           (or (bbdb-invoke-hook-for-value
+                                bbdb/news-auto-create-p)
+                               offer-to-create)
+                           offer-to-create)))
+           (when record
+             ;; XXX: BBDB 2.3x not only redefines
+             ;; `bbdb-encache-message' as a macro but also the inherent
+             ;; semantics of message caching functions is changed, so
+             ;; the following calls are much the same here.
+             (if (functionp 'bbdb-encache-message)
+                 (car (bbdb-encache-message message-key (list record)))
+               (bbdb-encache-message message-key record))))))))

 
 ;;;###autoload
 (defun gnus-bbdb/annotate-sender (string &optional replace)
 
 ;;;###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.")
 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)
   (bbdb-annotate-notes (gnus-bbdb/update-record t) string 'notes replace))
 
 (defun gnus-bbdb/edit-notes (&optional arg)

@@ -83,41 +124,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))
   (let ((record (gnus-bbdb/update-record t)))
     (if record
        (bbdb-display-records (list record))

-       (error "unperson"))))
+      (error "unperson"))))

 
 
 (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."
 
 
 (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.
       ;; 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
 
 ;;
 ;; Announcing BBDB entries in the summary buffer

@@ -140,8 +266,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)))
   :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
 
 (defcustom gnus-bbdb/summary-known-poster-mark "+"
   "This is the default character to prefix author names with if

@@ -160,8 +288,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)
 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
 
 (defcustom gnus-bbdb/summary-prefer-bbdb-data t
   "If t, then for posters who are in our BBDB, replace the information

@@ -180,8 +310,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)))
   :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
 
 (defcustom gnus-bbdb/summary-user-format-letter "B"
   "This is the gnus-user-format-function- that will be used to insert

@@ -225,12 +357,13 @@ strings.  In the future this should change."
         (data (and (or gnus-bbdb/summary-mark-known-posters
                        gnus-bbdb/summary-show-bbdb-names)
                    (condition-case ()
         (data (and (or gnus-bbdb/summary-mark-known-posters
                        gnus-bbdb/summary-show-bbdb-names)
                    (condition-case ()

-                       (mail-extract-address-components from)
+                       (gnus-bbdb/extract-address-components from)

                      (error nil))))
         (name (car data))
         (net (car (cdr data)))
                      (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 net bbdb-canonicalize-net-hook)
                           (bbdb-canonicalize-address net)
                         net))))

@@ -240,7 +373,7 @@ strings.  In the future this should change."
        ;; bogon!
        (setq record nil))
 
        ;; 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)))
          (or (and gnus-bbdb/summary-prefer-bbdb-data
                   (or (and gnus-bbdb/summary-prefer-real-names
                            (and record (bbdb-record-name record)))

@@ -251,22 +384,22 @@ strings.  In the future this should change."
                            net)
                       name))
              net from "**UNKNOWN**"))
                            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
 
 (defun gnus-bbdb/summary-get-author (header)
   "Given a Gnus message header, returns the appropriate piece of

@@ -282,19 +415,20 @@ This function is meant to be used with the user function defined in
   (let* ((from (mail-header-from header))
         (data (and gnus-bbdb/summary-show-bbdb-names
                    (condition-case ()
   (let* ((from (mail-header-from header))
         (data (and gnus-bbdb/summary-show-bbdb-names
                    (condition-case ()

-                       (mail-extract-address-components from)
+                       (gnus-bbdb/extract-address-components from)

                      (error nil))))
         (name (car data))
         (net (car (cdr data)))
                      (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))
                       (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)))
          (or (and gnus-bbdb/summary-prefer-bbdb-data
                   (or (and gnus-bbdb/summary-prefer-real-names
                            (and record (bbdb-record-name record)))

@@ -318,7 +452,7 @@ This function is meant to be used with the user function defined in
   "Given a Gnus message header, returns a mark if the poster is in the BBDB, \" \" otherwise.  The mark itself is the value of the field indicated by `bbdb-message-marker-field' (`mark-char' by default) if the indicated field is in the poster's record, and `gnus-bbdb/summary-known-poster-mark' otherwise."
   (let* ((from (mail-header-from header))
         (data (condition-case ()
   "Given a Gnus message header, returns a mark if the poster is in the BBDB, \" \" otherwise.  The mark itself is the value of the field indicated by `bbdb-message-marker-field' (`mark-char' by default) if the indicated field is in the poster's record, and `gnus-bbdb/summary-known-poster-mark' otherwise."
   (let* ((from (mail-header-from header))
         (data (condition-case ()

-                  (mail-extract-address-components from)
+                  (gnus-bbdb/extract-address-components from)

                 (error nil)))
         (name (car data))
         (net (cadr data))
                 (error nil)))
         (name (car data))
         (net (cadr data))

@@ -380,12 +514,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
 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."
 
 (defun gnus-bbdb/score-as-text (group)
   "Returns a SCORE file format string built from the BBDB."

@@ -394,38 +528,29 @@ addresses better than the traditionally static global scorefile."
                    (setq gnus-bbdb/score-default-internal
                          gnus-bbdb/score-default)
                    t))
                    (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 ()
   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
 
 (defun gnus-bbdb/extract-field-value (field-name)
   "Given the name of a field (like \"Subject\") this returns the value of

@@ -438,8 +563,52 @@ beginning of the message headers."
   ;; divided real-names from addresses; the actual From: and Subject: fields
   ;; exist only in the message.
   (let (value)
   ;; 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))
-      (nnheader-decode-field-body value field-name 'unfolding))))
+    (when (setq value (mime-entity-fetch-field
+                      gnus-current-headers field-name))
+      (gnus-bbdb/decode-field-body value field-name))))
+
+;;; @ mail-extr
+;;;
+
+(defvar gnus-bbdb/canonicalize-full-name-methods
+  '(gnus-bbdb/canonicalize-dots
+    gnus-bbdb/canonicalize-spaces))
+
+(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))
+    (while (and phrase methods)
+      (setq phrase  (funcall (car methods) phrase)
+           methods (cdr methods)))
+    (if (string= address "") (setq address nil))
+    (if (string= phrase "") (setq phrase nil))
+    (when (or phrase address)
+      (list phrase address))))
+
+;;; @ full-name canonicalization methods
+;;;
+
+(defun gnus-bbdb/canonicalize-spaces (str)
+  (let (dest)
+    (while (string-match "\\s +" str)
+      (setq dest (cons (substring str 0 (match-beginning 0)) dest))
+      (setq str (substring str (match-end 0))))
+    (or (string= str "")
+       (setq dest (cons str dest)))
+    (setq dest (nreverse 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))))
+    (or (string= str "")
+       (setq dest (cons str dest)))
+    (setq dest (nreverse dest))
+    (mapconcat 'identity dest " ")))

 
 ;;
 ;; Insinuation
 
 ;;
 ;; Insinuation

@@ -453,6 +622,7 @@ beginning of the message headers."
     (add-to-list 'bbdb-extract-field-value-function-list
                 'gnus-bbdb/extract-field-value-init))
   (add-hook 'gnus-article-prepare-hook 'gnus-bbdb/update-record)
     (add-to-list 'bbdb-extract-field-value-function-list
                 'gnus-bbdb/extract-field-value-init))
   (add-hook 'gnus-article-prepare-hook 'gnus-bbdb/update-record)

+  (add-hook 'gnus-summary-exit-hook 'bbdb-flush-all-caches)

   (add-hook 'gnus-save-newsrc-hook 'bbdb-offer-save)
   (define-key gnus-summary-mode-map ":" 'gnus-bbdb/show-sender)
   (define-key gnus-summary-mode-map ";" 'gnus-bbdb/edit-notes)
   (add-hook 'gnus-save-newsrc-hook 'bbdb-offer-save)
   (define-key gnus-summary-mode-map ":" 'gnus-bbdb/show-sender)
   (define-key gnus-summary-mode-map ";" 'gnus-bbdb/edit-notes)

@@ -474,7 +644,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))))
 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)
     ; One tick.  One tick only, please
     (cond (gnus-bbdb/summary-in-bbdb-format-letter
           (if (and (fboundp in-bbdb-user-fun)

@@ -485,7 +655,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)))))
 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
   ;; Scoring
   (add-hook 'bbdb-after-change-hook 'gnus-bbdb/score-invalidate-alist)
 ;  (setq gnus-score-find-score-files-function