git.chise.org Git - elisp/gnus.git-/blob - lisp/gnus-bbdb.el

   1 ;; gnus-bbdb.el --- Interface to after Nana-gnus version 6.10.2.
   2
   3 ;; Copyright (c) 1991,1992,1993 Jamie Zawinski <jwz@netscape.com>.
   4 ;; Copyright (C) 1995,1996,1997 Shuhei KOBAYASHI
   5 ;; Copyright (C) 1997,1998 MORIOKA Tomohiko
   6 ;; Copyright (C) 1998,1999 Keiichi Suzuki <keiichi@nanap.org>
   7
   8 ;; Author: Keiichi Suzuki <keiichi@nanap.org>
   9 ;; Author: Shuhei KOBAYASHI <shuhei-k@jaist.ac.jp>
  10 ;; Keywords: BBDB, MIME, multimedia, multilingual, mail, news
  11
  12 ;; This file is part of Nana-gnus.
  13
  14 ;; This program is free software; you can redistribute it and/or
  15 ;; modify it under the terms of the GNU General Public License as
  16 ;; published by the Free Software Foundation; either version 2, or (at
  17 ;; your option) any later version.
  18
  19 ;; This program is distributed in the hope that it will be useful, but
  20 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  21 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  22 ;; General Public License for more details.
  23
  24 ;; You should have received a copy of the GNU General Public License
  25 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  26 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  27 ;; Boston, MA 02111-1307, USA.
  28
  29 ;;; Code:
  30
  31 (require 'bbdb)
  32 (require 'bbdb-com)
  33 (require 'gnus)
  34 (require 'std11)
  35 (eval-when-compile
  36   (defvar bbdb-pop-up-elided-display)   ; default unbound.
  37   (require 'gnus-win)
  38   (require 'cl))
  39
  40 (defvar gnus-bbdb/decode-field-body-function 'nnheader-decode-field-body
  41   "*Field body decoder.")
  42
  43 (defmacro gnus-bbdb/decode-field-body (field-body field-name)
  44   `(or (and (functionp gnus-bbdb/decode-field-body-function)
  45             (funcall gnus-bbdb/decode-field-body-function
  46                      ,field-body ,field-name))
  47        ,field-body))
  48
  49 ;;;###autoload
  50 (defun gnus-bbdb/update-record (&optional offer-to-create)
  51   "returns the record corresponding to the current GNUS message, creating
  52 or modifying it as necessary.  A record will be created if
  53 bbdb/news-auto-create-p is non-nil, or if OFFER-TO-CREATE is true and
  54 the user confirms the creation."
  55   (if bbdb-use-pop-up
  56       (gnus-bbdb/pop-up-bbdb-buffer offer-to-create)
  57     (save-excursion
  58       (let (from)
  59         (set-buffer gnus-original-article-buffer)
  60         (save-restriction
  61           (widen)
  62           (narrow-to-region (point-min)
  63                             (progn (goto-char (point-min))
  64                                    (or (search-forward "\n\n" nil t)
  65                                        (error "message unexists"))
  66                                    (- (point) 2)))
  67           (when (setq from (mail-fetch-field "from"))
  68             (setq from (gnus-bbdb/extract-address-components
  69                         (gnus-bbdb/decode-field-body from 'From))))
  70           (when (and (car (cdr from))
  71                      (string-match (bbdb-user-mail-names)
  72                                    (car (cdr from))))
  73             ;; if logged-in user sent this, use recipients.
  74             (let ((to (mail-fetch-field "to")))
  75               (when to
  76                 (setq from
  77                       (gnus-bbdb/extract-address-components
  78                        (gnus-bbdb/decode-field-body to 'To))))))
  79         (when from
  80           (bbdb-annotate-message-sender from t
  81                                         (or (bbdb-invoke-hook-for-value
  82                                              bbdb/news-auto-create-p)
  83                                             offer-to-create)
  84                                         offer-to-create)))))) )
  85
  86 ;;;###autoload
  87 (defun gnus-bbdb/annotate-sender (string &optional replace)
  88   "Add a line to the end of the Notes field of the BBDB record
  89 corresponding to the sender of this message.  If REPLACE is non-nil,
  90 replace the existing notes entry (if any)."
  91   (interactive (list (if bbdb-readonly-p
  92                          (error "The Insidious Big Brother Database is read-only.")
  93                          (read-string "Comments: "))))
  94   (bbdb-annotate-notes (gnus-bbdb/update-record t) string 'notes replace))
  95
  96 (defun gnus-bbdb/edit-notes (&optional arg)
  97   "Edit the notes field or (with a prefix arg) a user-defined field
  98 of the BBDB record corresponding to the sender of this message."
  99   (interactive "P")
 100   (let ((record (or (gnus-bbdb/update-record t) (error ""))))
 101     (bbdb-display-records (list record))
 102     (if arg
 103         (bbdb-record-edit-property record nil t)
 104       (bbdb-record-edit-notes record t))))
 105
 106 ;;;###autoload
 107 (defun gnus-bbdb/show-sender ()
 108   "Display the contents of the BBDB for the sender of this message.
 109 This buffer will be in bbdb-mode, with associated keybindings."
 110   (interactive)
 111   (let ((record (gnus-bbdb/update-record t)))
 112     (if record
 113         (bbdb-display-records (list record))
 114         (error "unperson"))))
 115
 116
 117 (defun gnus-bbdb/pop-up-bbdb-buffer (&optional offer-to-create)
 118   "Make the *BBDB* buffer be displayed along with the GNUS windows,
 119 displaying the record corresponding to the sender of the current message."
 120   (let ((bbdb-gag-messages t)
 121         (bbdb-use-pop-up nil)
 122         (bbdb-electric-p nil))
 123     (let ((record (gnus-bbdb/update-record offer-to-create))
 124           (bbdb-elided-display (bbdb-pop-up-elided-display))
 125           (b (current-buffer)))
 126       ;; display the bbdb buffer iff there is a record for this article.
 127       (cond (record
 128              (bbdb-pop-up-bbdb-buffer
 129               (function (lambda (w)
 130                           (let ((b (current-buffer)))
 131                             (set-buffer (window-buffer w))
 132                             (prog1 (or (eq major-mode 'mime-veiw-mode)
 133                                        (eq major-mode 'gnus-article-mode))
 134                                    (set-buffer b))))))
 135              (bbdb-display-records (list record)))
 136             (t
 137              (or bbdb-inside-electric-display
 138                  (not (get-buffer-window bbdb-buffer-name))
 139                  (let (w)
 140                    (delete-other-windows)
 141                    (if (assq 'article gnus-buffer-configuration)
 142                        (gnus-configure-windows 'article)
 143                      (gnus-configure-windows 'SelectArticle))
 144                    (if (setq w (get-buffer-window gnus-summary-buffer))
 145                        (select-window w))
 146                    ))))
 147       (set-buffer b)
 148       record)))
 149
 150 ;;;###autoload
 151 (defun gnus-bbdb/split-mail (header-field bbdb-field
 152                                           &optional regexp group)
 153   "Mail split method for `nnmail-split-fancy'.
 154 HEADER-FIELED is a regexp or list of regexps as mail header field name
 155 for gathering mail addresses.  If HEADER-FIELED is a string, then it's
 156 used for just matching pattern.  If HEADER-FIELED is a list of strings,
 157 then these strings have priorities in the order.
 158
 159 BBDB-FIELD is field name of BBDB.
 160 Optional argument REGEXP is regexp string for matching BBDB-FIELD value.
 161 If REGEXP is nil or not specified, then all BBDB-FIELD value is matched.
 162
 163 If GROUP is nil or not specified, then BBDB-FIELD value is returned as
 164 group name.  If GROUP is a symbol `&', then list of all matcing group's
 165 BBDB-FEILD values is returned.  Otherwise, GROUP is returned."
 166   (if (listp header-field)
 167       (if (eq group '&)
 168           (gnus-bbdb/split-mail (mapconcat 'identity header-field "\\|")
 169                                 bbdb-field regexp group)
 170         (let (rest)
 171           (while (and header-field
 172                       (null (setq rest (gnus-bbdb/split-mail
 173                                         (car header-field) bbdb-field
 174                                         regexp group))))
 175             (setq header-field (cdr header-field)))
 176           rest))
 177     (let ((pat (concat "^\\(" header-field "\\):[ \t]"))
 178           header-values)
 179       (goto-char (point-min))
 180       (while (re-search-forward pat nil t)
 181         (setq header-values (cons (buffer-substring (point)
 182                                                 (std11-field-end))
 183                                   header-values)))
 184       (let ((address-regexp
 185              (with-temp-buffer
 186                (let (lal)
 187                  (while header-values
 188                    (setq lal (std11-parse-addresses-string
 189                               (pop header-values)))
 190                    (while lal
 191                      (gnus-bbdb/insert-address-regexp (pop lal)))))
 192                (buffer-string))))
 193         (unless (zerop (length address-regexp))
 194           (gnus-bbdb/split-mail-1 address-regexp bbdb-field regexp group))))))
 195
 196 (defun gnus-bbdb/insert-address-regexp (address)
 197   "Insert string of address part from parsed ADDRESS of RFC 822."
 198   (cond ((eq (car address) 'group)
 199          (setq address (cdr address))
 200          (while address
 201            (gnus-bbdb/insert-address-regexp (pop address))))
 202         ((eq (car address) 'mailbox)
 203          (unless (eq (point) (point-min))
 204            (insert "\\|"))
 205          (let ((addr (nth 1 address)))
 206            (insert (std11-addr-to-string
 207                     (if (eq (car addr) 'phrase-route-addr)
 208                         (nth 2 addr)
 209                       (cdr addr))))))))
 210
 211 (defun gnus-bbdb/split-mail-1 (address-regexp bbdb-field regexp group)
 212   (let ((records (bbdb-search (bbdb-records) nil nil address-regexp))
 213         prop rest)
 214     (or regexp (setq regexp ""))
 215     (catch 'done
 216       (cond
 217        ((eq group '&)
 218         (while records
 219           (when (and (setq prop (bbdb-record-getprop (car records) bbdb-field))
 220                      (string-match regexp prop)
 221                      (not (member prop rest)))
 222             (setq rest (cons prop rest)))
 223           (setq records (cdr records)))
 224         (throw 'done (when rest (cons '& rest))))
 225        (t
 226         (while records
 227           (when (or (null bbdb-field)
 228                     (and (setq prop (bbdb-record-getprop (car records)
 229                                                          bbdb-field))
 230                          (string-match regexp prop)))
 231             (throw 'done (or group prop)))
 232           (setq records (cdr records))))))))
 233
 234 ;;
 235 ;; Announcing BBDB entries in the summary buffer
 236 ;;
 237
 238 (defcustom gnus-bbdb/lines-and-from-length 18
 239   "*The number of characters used to display From: info in Gnus, if you have
 240 set gnus-optional-headers to 'gnus-bbdb/lines-and-from."
 241   :group 'bbdb-mua-specific-gnus
 242   :type 'integer)
 243
 244 (defcustom gnus-bbdb/summary-mark-known-posters t
 245   "*If t, mark messages created by people with records in the BBDB.
 246 In GNUS, this marking will take place in the subject list (assuming
 247 `gnus-optional-headers' contains `gnus-bbdb/lines-and-from').  In Gnus, the
 248 marking will take place in the Summary buffer if the format code defined by
 249 `gnus-bbdb/summary-user-format-letter' is used in `gnus-summary-line-format'.
 250 This variable has no effect on the marking controlled by
 251 `gnus-bbdb/summary-in-bbdb-format-letter'."
 252   :group 'bbdb-mua-specific-gnus
 253   :type '(choice (const :tag "Mark known posters" t)
 254                  (const :tag "Do not mark known posters" nil)))
 255 (defvaralias 'gnus-bbdb/mark-known-posters
 256   'gnus-bbdb/summary-mark-known-posters)
 257
 258 (defcustom gnus-bbdb/summary-known-poster-mark "+"
 259   "This is the default character to prefix author names with if
 260 gnus-bbdb/summary-mark-known-posters is t.  If the poster's record has
 261 an entry in the field named by bbdb-message-marker-field, then that will
 262 be used instead."
 263   :group 'bbdb-mua-specific-gnus
 264   :type 'character)
 265
 266 (defcustom gnus-bbdb/summary-show-bbdb-names t
 267   "*If both this variable and `gnus-bbdb/summary-prefer-real-names' are true,
 268 then for messages from authors who are in your database, the name
 269 displayed will be the primary name in the database, rather than the
 270 one in the From line of the message.  This doesn't affect the names of
 271 people who aren't in the database, of course.  (`gnus-optional-headers'
 272 must be `gnus-bbdb/lines-and-from' for GNUS users.)"
 273   :group 'bbdb-mua-specific-gnus
 274   :type 'boolean)
 275 (defvaralias 'gnus-bbdb/header-show-bbdb-names
 276   'gnus-bbdb/summary-show-bbdb-names)
 277
 278 (defcustom gnus-bbdb/summary-prefer-bbdb-data t
 279   "If t, then for posters who are in our BBDB, replace the information
 280 provided in the From header with data from the BBDB."
 281   :group 'bbdb-mua-specific-gnus
 282   :type 'boolean)
 283
 284 (defcustom gnus-bbdb/summary-prefer-real-names t
 285   "If t, then display the poster's name from the BBDB if we have one,
 286 otherwise display his/her primary net address if we have one.  If it
 287 is set to the symbol bbdb, then real names will be used from the BBDB
 288 if present, otherwise the net address in the post will be used.  If
 289 gnus-bbdb/summary-prefer-bbdb-data is nil, then this has no effect.
 290 See `gnus-bbdb/lines-and-from' for GNUS users, or
 291 `gnus-bbdb/summary-user-format-letter' for Gnus users."
 292   :group 'bbdb-mua-specific-gnus
 293   :type '(choice (const :tag "Prefer real names" t)
 294                  (const :tag "Prefer network addresses" nil)))
 295 (defvaralias 'gnus-bbdb/header-prefer-real-names
 296   'gnus-bbdb/summary-prefer-real-names)
 297
 298 (defcustom gnus-bbdb/summary-user-format-letter "B"
 299   "This is the gnus-user-format-function- that will be used to insert
 300 the information from the BBDB in the summary buffer (using
 301 `gnus-bbdb/summary-get-author').  This format code is meant to replace
 302 codes that insert sender names or addresses (like %A or %n). Unless
 303 you've alread got other code using user format B, you might as well
 304 stick with the default.  Additionally, if the value of this variable
 305 is nil, no format function will be installed for
 306 `gnus-bbdb/summary-get-author'.  See also
 307 `gnus-bbdb/summary-in-bbdb-format-letter', which installs a format
 308 code for `gnus-bbdb/summary-author-in-bbdb'"
 309   :group 'bbdb-mua-specific-gnus
 310   :type 'character)
 311
 312 (defcustom gnus-bbdb/summary-in-bbdb-format-letter "b"
 313   "This is the gnus-user-format-function- that will be used to insert
 314 `gnus-bbdb/summary-known-poster-mark' (using
 315 `gnus-bbdb/summary-author-in-bbdb') if the poster is in the BBDB, and
 316 \" \" if not.  If the value of this variable is nil, no format code
 317 will be installed for `gnus-bbdb/summary-author-in-bbdb'.  See also
 318 `gnus-bbdb/summary-user-format-letter', which installs a format code
 319 for `gnus-bbdb/summary-get-author'."
 320   :group 'bbdb-mua-specific-gnus
 321   :type 'character)
 322
 323 (defcustom bbdb-message-marker-field 'mark-char
 324   "*The field whose value will be used to mark messages by this user in Gnus."
 325   :group 'bbdb-mua-specific-gnus
 326   :type 'symbol)
 327
 328 ;;;###autoload
 329 (defun gnus-bbdb/lines-and-from (header)
 330   "Useful as the value of gnus-optional-headers in *GNUS* (not Gnus).
 331 NOTE: This variable no longer seems to be present in Gnus.  It seems
 332 to have been replaced by `message-default-headers', which only takes
 333 strings.  In the future this should change."
 334   (let* ((length gnus-bbdb/lines-and-from-length)
 335          (lines (mail-header-lines header))
 336          (from (mail-header-from header))
 337          (data (and (or gnus-bbdb/summary-mark-known-posters
 338                         gnus-bbdb/summary-show-bbdb-names)
 339                     (condition-case ()
 340                         (gnus-bbdb/extract-address-components from)
 341                       (error nil))))
 342          (name (car data))
 343          (net (car (cdr data)))
 344          (record (and data
 345                       (bbdb-search-simple name
 346                        (if (and net bbdb-canonicalize-net-hook)
 347                            (bbdb-canonicalize-address net)
 348                          net))))
 349          string L)
 350
 351     (if (and record name (member (downcase name) (bbdb-record-net record)))
 352         ;; bogon!
 353         (setq record nil))
 354
 355     (setq name
 356           (or (and gnus-bbdb/summary-prefer-bbdb-data
 357                    (or (and gnus-bbdb/summary-prefer-real-names
 358                             (and record (bbdb-record-name record)))
 359                        (and record (bbdb-record-net record)
 360                             (nth 0 (bbdb-record-net record)))))
 361               (and gnus-bbdb/summary-prefer-real-names
 362                    (or (and (equal gnus-bbdb/summary-prefer-real-names 'bbdb)
 363                             net)
 364                        name))
 365               net from "**UNKNOWN**"))
 366       ;; GNUS can't cope with extra square-brackets appearing in the summary.
 367       (if (and name (string-match "[][]" name))
 368           (progn (setq name (copy-sequence name))
 369                  (while (string-match "[][]" name)
 370                    (aset name (match-beginning 0) ? ))))
 371       (setq string (format "%s%3d:%s"
 372                            (if (and record gnus-bbdb/summary-mark-known-posters)
 373                                (or (bbdb-record-getprop
 374                                     record bbdb-message-marker-field)
 375                                    "*")
 376                              " ")
 377                            lines (or name from))
 378             L (length string))
 379       (cond ((> L length) (substring string 0 length))
 380             ((< L length) (concat string (make-string (- length L) ? )))
 381             (t string))))
 382
 383 (defun gnus-bbdb/summary-get-author (header)
 384   "Given a Gnus message header, returns the appropriate piece of
 385 information to identify the author in a Gnus summary line, depending on
 386 the settings of the various configuration variables.  See the
 387 documentation for the following variables for more details:
 388   `gnus-bbdb/summary-mark-known-posters'
 389   `gnus-bbdb/summary-known-poster-mark'
 390   `gnus-bbdb/summary-prefer-bbdb-data'
 391   `gnus-bbdb/summary-prefer-real-names'
 392 This function is meant to be used with the user function defined in
 393   `gnus-bbdb/summary-user-format-letter'"
 394   (let* ((from (mail-header-from header))
 395          (data (and gnus-bbdb/summary-show-bbdb-names
 396                     (condition-case ()
 397                         (gnus-bbdb/extract-address-components from)
 398                       (error nil))))
 399          (name (car data))
 400          (net (car (cdr data)))
 401          (record (and data
 402                       (bbdb-search-simple name
 403                        (if (and net bbdb-canonicalize-net-hook)
 404                            (bbdb-canonicalize-address net)
 405                          net)))))
 406     (if (and record name (member (downcase name) (bbdb-record-net record)))
 407         ;; bogon!
 408         (setq record nil))
 409     (setq name
 410           (or (and gnus-bbdb/summary-prefer-bbdb-data
 411                    (or (and gnus-bbdb/summary-prefer-real-names
 412                             (and record (bbdb-record-name record)))
 413                        (and record (bbdb-record-net record)
 414                             (nth 0 (bbdb-record-net record)))))
 415               (and gnus-bbdb/summary-prefer-real-names
 416                    (or (and (equal gnus-bbdb/summary-prefer-real-names 'bbdb)
 417                             net)
 418                        name))
 419               net from "**UNKNOWN**"))
 420     (format "%s%s"
 421             (or (and record gnus-bbdb/summary-mark-known-posters
 422                      (or (bbdb-record-getprop
 423                           record bbdb-message-marker-field)
 424                          gnus-bbdb/summary-known-poster-mark))
 425                 " ")
 426             name)))
 427
 428 ;; DEBUG: (gnus-bbdb/summary-author-in-bbdb "From: simmonmt@acm.org")
 429 (defun gnus-bbdb/summary-author-in-bbdb (header)
 430   "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."
 431   (let* ((from (mail-header-from header))
 432          (data (condition-case ()
 433                    (gnus-bbdb/extract-address-components from)
 434                  (error nil)))
 435          (name (car data))
 436          (net (cadr data))
 437          record)
 438     (if (and data
 439              (setq record
 440                    (bbdb-search-simple
 441                     name (if (and net bbdb-canonicalize-net-hook)
 442                              (bbdb-canonicalize-address net)
 443                            net))))
 444         (or (bbdb-record-getprop
 445              record bbdb-message-marker-field)
 446             gnus-bbdb/summary-known-poster-mark) " ")))
 447
 448 ;;
 449 ;; Scoring
 450 ;;
 451
 452 (defcustom gnus-bbdb/score-field 'gnus-score
 453   "This variable contains the name of the BBDB field which should be
 454 checked for a score to add to the net addresses in the same record."
 455   :group 'bbdb-mua-specific-gnus-scoring
 456   :type 'symbol)
 457
 458 (defcustom gnus-bbdb/score-default nil
 459   "If this is set, then every net address in the BBDB that does not have
 460 an associated score field will be assigned this score.  A value of nil
 461 implies a default score of zero."
 462   :group 'bbdb-mua-specific-gnus-scoring
 463   :type '(choice (const :tag "Do not assign default score")
 464                  (integer :tag "Assign this default score" 0)))
 465
 466 (defvar gnus-bbdb/score-default-internal nil
 467   "Internal variable for detecting changes to
 468 `gnus-bbdb/score-default'.  You should not set this variable directly -
 469 set `gnus-bbdb/score-default' instead.")
 470
 471 (defvar gnus-bbdb/score-alist nil
 472   "The text version of the scoring structure returned by
 473 gnus-bbdb/score.  This is built automatically from the BBDB.")
 474
 475 (defvar gnus-bbdb/score-rebuild-alist t
 476   "Set to t to rebuild gnus-bbdb/score-alist on the next call to
 477 gnus-bbdb/score.  This will be set automatically if you change a BBDB
 478 record which contains a gnus-score field.")
 479
 480 (defun gnus-bbdb/score-invalidate-alist (rec)
 481   "This function is called through bbdb-after-change-hook, and sets
 482 gnus-bbdb/score-rebuild-alist to t if the changed record contains a
 483 gnus-score field."
 484   (if (bbdb-record-getprop rec gnus-bbdb/score-field)
 485       (setq gnus-bbdb/score-rebuild-alist t)))
 486
 487 ;;;###autoload
 488 (defun gnus-bbdb/score (group)
 489   "This returns a score alist for GNUS.  A score pair will be made for
 490 every member of the net field in records which also have a gnus-score
 491 field.  This allows the BBDB to serve as a supplemental global score
 492 file, with the advantage that it can keep up with multiple and changing
 493 addresses better than the traditionally static global scorefile."
 494   (list (list
 495    (condition-case nil
 496        (read (gnus-bbdb/score-as-text group))
 497      (error (setq gnus-bbdb/score-rebuild-alist t)
 498             (message "Problem building BBDB score table.")
 499             (ding) (sit-for 2)
 500             nil)))))
 501
 502 (defun gnus-bbdb/score-as-text (group)
 503   "Returns a SCORE file format string built from the BBDB."
 504   (cond ((or (cond ((/= (or gnus-bbdb/score-default 0)
 505                         (or gnus-bbdb/score-default-internal 0))
 506                     (setq gnus-bbdb/score-default-internal
 507                           gnus-bbdb/score-default)
 508                     t))
 509             (not gnus-bbdb/score-alist)
 510             gnus-bbdb/score-rebuild-alist)
 511     (setq gnus-bbdb/score-rebuild-alist nil)
 512     (setq gnus-bbdb/score-alist
 513           (concat "((touched nil) (\"from\"\n"
 514                   (mapconcat
 515                    (lambda (rec)
 516                      (let ((score (or (bbdb-record-getprop rec
 517                                                            gnus-bbdb/score-field)
 518                                       gnus-bbdb/score-default))
 519                            (net (bbdb-record-net rec)))
 520                        (if (not (and score net)) nil
 521                          (mapconcat
 522                           (lambda (addr)
 523                             (concat "(\"" addr "\" " score ")\n"))
 524                           net ""))))
 525                    (bbdb-records) "")
 526                   "))"))))
 527   gnus-bbdb/score-alist)
 528
 529 (defun gnus-bbdb/extract-field-value-init ()
 530   (when (or (and (eq (current-buffer) (get-buffer gnus-article-buffer))
 531                  (buffer-live-p gnus-original-article-buffer)
 532                  (set-buffer gnus-original-article-buffer))
 533             (eq (current-buffer) (get-buffer gnus-original-article-buffer)))
 534     (widen)
 535     (narrow-to-region (point-min)
 536                       (progn (goto-char (point-min))
 537                              (or (search-forward "\n\n" nil t)
 538                                  (error "message unexists"))
 539                              (- (point) 2)))
 540     'gnus-bbdb/extract-field-value))
 541
 542 (defun gnus-bbdb/extract-field-value (field-name)
 543   "Given the name of a field (like \"Subject\") this returns the value of
 544 that field in the current message, or nil.  This works whether you're in
 545 Semi-gnus, Rmail, or VM.  This works on multi-line fields, but if more than
 546 one field of the same name is present, only the last is returned.  It is
 547 expected that the current buffer has a message in it, and (point) is at the
 548 beginning of the message headers."
 549   ;; we can't special-case VM here to use its cache, because the cache has
 550   ;; divided real-names from addresses; the actual From: and Subject: fields
 551   ;; exist only in the message.
 552   (let (value)
 553     (when (setq value (mail-fetch-field field-name))
 554       (gnus-bbdb/decode-field-body value field-name))))
 555
 556 ;;; @ mail-extr
 557 ;;;
 558
 559 (defvar gnus-bbdb/canonicalize-full-name-methods
 560   '(gnus-bbdb/canonicalize-dots
 561     gnus-bbdb/canonicalize-spaces))
 562
 563 (defun gnus-bbdb/extract-address-components (str)
 564   (let* ((ret     (std11-extract-address-components str))
 565          (phrase  (car ret))
 566          (address (car (cdr ret)))
 567          (methods gnus-bbdb/canonicalize-full-name-methods))
 568     (while (and phrase methods)
 569       (setq phrase  (funcall (car methods) phrase)
 570             methods (cdr methods)))
 571     (if (string= address "") (setq address nil))
 572     (if (string= phrase "") (setq phrase nil))
 573     (when (or phrase address)
 574       (list phrase address))
 575     ))
 576
 577 ;;; @ full-name canonicalization methods
 578 ;;;
 579
 580 (defun gnus-bbdb/canonicalize-spaces (str)
 581   (let (dest)
 582     (while (string-match "\\s +" str)
 583       (setq dest (cons (substring str 0 (match-beginning 0)) dest))
 584       (setq str (substring str (match-end 0)))
 585       )
 586     (or (string= str "")
 587         (setq dest (cons str dest)))
 588     (setq dest (nreverse dest))
 589     (mapconcat 'identity dest " ")
 590     ))
 591
 592 (defun gnus-bbdb/canonicalize-dots (str)
 593   (let (dest)
 594     (while (string-match "\\." str)
 595       (setq dest (cons (substring str 0 (match-end 0)) dest))
 596       (setq str (substring str (match-end 0)))
 597       )
 598     (or (string= str "")
 599         (setq dest (cons str dest)))
 600     (setq dest (nreverse dest))
 601     (mapconcat 'identity dest " ")
 602     ))
 603
 604 ;;
 605 ;; Insinuation
 606 ;;
 607
 608 ;;;###autoload
 609 (defun gnus-bbdb-insinuate ()
 610   "Call this function to hook BBDB into Semi-gnus."
 611 ;;  (setq gnus-optional-headers 'gnus-bbdb/lines-and-from)
 612   (when (boundp 'bbdb-extract-field-value-function-list)
 613     (add-to-list 'bbdb-extract-field-value-function-list
 614                  'gnus-bbdb/extract-field-value-init))
 615   (add-hook 'gnus-article-prepare-hook 'gnus-bbdb/update-record)
 616   (add-hook 'gnus-save-newsrc-hook 'bbdb-offer-save)
 617   (define-key gnus-summary-mode-map ":" 'gnus-bbdb/show-sender)
 618   (define-key gnus-summary-mode-map ";" 'gnus-bbdb/edit-notes)
 619
 620   ;; Set up user field for use in gnus-summary-line-format
 621   (let ((get-author-user-fun (intern
 622                               (concat "gnus-user-format-function-"
 623                                       gnus-bbdb/summary-user-format-letter)))
 624         (in-bbdb-user-fun (intern
 625                            (concat "gnus-user-format-function-"
 626                                    gnus-bbdb/summary-in-bbdb-format-letter))))
 627                                         ; The big one - whole name
 628     (cond (gnus-bbdb/summary-user-format-letter
 629            (if (and (fboundp get-author-user-fun)
 630                     (not (eq (symbol-function get-author-user-fun)
 631                              'gnus-bbdb/summary-get-author)))
 632                (bbdb-warn
 633                 (format "`gnus-user-format-function-%s' already seems to be in use.
 634 Please redefine `gnus-bbdb/summary-user-format-letter' to a different letter."
 635                         gnus-bbdb/summary-user-format-letter))
 636              (fset get-author-user-fun 'gnus-bbdb/summary-get-author))))
 637
 638     ; One tick.  One tick only, please
 639     (cond (gnus-bbdb/summary-in-bbdb-format-letter
 640            (if (and (fboundp in-bbdb-user-fun)
 641                     (not (eq (symbol-function in-bbdb-user-fun)
 642                              'gnus-bbdb/summary-author-in-bbdb)))
 643                (bbdb-warn
 644                 (format "`gnus-user-format-function-%s' already seems to be in use.
 645 Redefine `gnus-bbdb/summary-in-bbdb-format-letter' to a different letter."
 646                         gnus-bbdb/summary-in-bbdb-format-letter))
 647              (fset in-bbdb-user-fun 'gnus-bbdb/summary-author-in-bbdb)))))
 648
 649   ;; Scoring
 650   (add-hook 'bbdb-after-change-hook 'gnus-bbdb/score-invalidate-alist)
 651 ;  (setq gnus-score-find-score-files-function
 652 ;       (if (boundp 'gnus-score-find-score-files-function)
 653 ;           (cond ((functionp gnus-score-find-score-files-function)
 654 ;                  (list gnus-score-find-score-files-function
 655 ;                        'gnus-bbdb/score))
 656 ;                 ((listp gnus-score-find-score-files-function)
 657 ;                  (append gnus-score-find-score-files-function
 658 ;                          'gnus-bbdb/score))
 659 ;                 (t 'gnus-bbdb/score))
 660 ;         'gnus-bbdb/score))
 661   )
 662
 663 ;;;###autoload
 664 (defun gnus-bbdb-insinuate-message ()
 665   "Call this function to hook BBDB into message-mode."
 666   (define-key message-mode-map "\M-\t" 'bbdb-complete-name))
 667
 668 (provide 'gnus-bbdb)