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

   1 ;; gnus-bbdb.el --- Interface to T-gnus
   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 T-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     (let ((from (mime-entity-fetch-field gnus-current-headers "from")))
  58       (when from
  59         (setq from (gnus-bbdb/extract-address-components
  60                     (gnus-bbdb/decode-field-body from 'From))))
  61       (when (and (car (cdr from))
  62                  (string-match (bbdb-user-mail-names)
  63                                (car (cdr from))))
  64         ;; if logged-in user sent this, use recipients.
  65         (let ((to (mime-entity-fetch-field gnus-current-headers "to")))
  66           (when to
  67             (setq from
  68                   (gnus-bbdb/extract-address-components
  69                    (gnus-bbdb/decode-field-body to 'To))))))
  70       (when from
  71         (save-excursion
  72           (bbdb-annotate-message-sender from t
  73                                         (or (bbdb-invoke-hook-for-value
  74                                              bbdb/news-auto-create-p)
  75                                             offer-to-create)
  76                                         offer-to-create))))))
  77
  78 ;;;###autoload
  79 (defun gnus-bbdb/annotate-sender (string &optional replace)
  80   "Add a line to the end of the Notes field of the BBDB record
  81 corresponding to the sender of this message.  If REPLACE is non-nil,
  82 replace the existing notes entry (if any)."
  83   (interactive (list (if bbdb-readonly-p
  84                          (error "The Insidious Big Brother Database is read-only.")
  85                        (read-string "Comments: "))))
  86   (bbdb-annotate-notes (gnus-bbdb/update-record t) string 'notes replace))
  87
  88 (defun gnus-bbdb/edit-notes (&optional arg)
  89   "Edit the notes field or (with a prefix arg) a user-defined field
  90 of the BBDB record corresponding to the sender of this message."
  91   (interactive "P")
  92   (let ((record (or (gnus-bbdb/update-record t) (error ""))))
  93     (bbdb-display-records (list record))
  94     (if arg
  95         (bbdb-record-edit-property record nil t)
  96       (bbdb-record-edit-notes record t))))
  97
  98 ;;;###autoload
  99 (defun gnus-bbdb/show-sender ()
 100   "Display the contents of the BBDB for the sender of this message.
 101 This buffer will be in bbdb-mode, with associated keybindings."
 102   (interactive)
 103   (let ((record (gnus-bbdb/update-record t)))
 104     (if record
 105         (bbdb-display-records (list record))
 106       (error "unperson"))))
 107
 108
 109 (defun gnus-bbdb/pop-up-bbdb-buffer (&optional offer-to-create)
 110   "Make the *BBDB* buffer be displayed along with the GNUS windows,
 111 displaying the record corresponding to the sender of the current message."
 112   (let* ((bbdb-gag-messages t)
 113          (bbdb-electric-p nil)
 114          (record
 115           (let (bbdb-use-pop-up)
 116             (gnus-bbdb/update-record offer-to-create)))
 117          (bbdb-display-layout
 118           (cond ((boundp 'bbdb-pop-up-display-layout)
 119                  (symbol-value 'bbdb-pop-up-display-layout))
 120                 ((boundp 'bbdb-pop-up-elided-display)
 121                  (symbol-value 'bbdb-pop-up-elided-display))))
 122          (bbdb-elided-display bbdb-display-layout))
 123     (save-current-buffer
 124       ;; display the bbdb buffer iff there is a record for this article.
 125       (cond
 126        (record
 127         (bbdb-pop-up-bbdb-buffer
 128          (lambda (w)
 129            (with-current-buffer (window-buffer w)
 130              (memq major-mode
 131                    '(mime-view-mode gnus-article-mode)))))
 132         (bbdb-display-records (list record)))
 133        ((and (not bbdb-inside-electric-display)
 134              (get-buffer-window bbdb-buffer-name))
 135         (delete-other-windows)
 136         (if (assq 'article gnus-buffer-configuration)
 137             (gnus-configure-windows 'article)
 138           (gnus-configure-windows 'SelectArticle))
 139         (let ((w (get-buffer-window gnus-summary-buffer)))
 140           (if w (select-window w))))))
 141     record))
 142
 143 ;;;###autoload
 144 (defun gnus-bbdb/split-mail (header-field bbdb-field
 145                                           &optional regexp group)
 146   "Mail split method for `nnmail-split-fancy'.
 147 HEADER-FIELD is a regexp or list of regexps as mail header field name
 148 for gathering mail addresses.  If HEADER-FIELD is a string, then it's
 149 used for just matching pattern.  If HEADER-FIELD is a list of strings,
 150 then these strings have priorities in the order.
 151
 152 BBDB-FIELD is field name of BBDB.
 153 Optional argument REGEXP is regexp string for matching BBDB-FIELD value.
 154 If REGEXP is nil or not specified, then all BBDB-FIELD value is matched.
 155
 156 If GROUP is nil or not specified, then BBDB-FIELD value is returned as
 157 group name.  If GROUP is a symbol `&', then list of all matching group's
 158 BBDB-FIELD values is returned.  Otherwise, GROUP is returned."
 159   (if (listp header-field)
 160       (if (eq group '&)
 161           (gnus-bbdb/split-mail (mapconcat 'identity header-field "\\|")
 162                                 bbdb-field regexp group)
 163         (let (rest)
 164           (while (and header-field
 165                       (null (setq rest (gnus-bbdb/split-mail
 166                                         (car header-field) bbdb-field
 167                                         regexp group))))
 168             (setq header-field (cdr header-field)))
 169           rest))
 170     (let ((pat (concat "^\\(" header-field "\\):[ \t]"))
 171           header-values)
 172       (goto-char (point-min))
 173       (while (re-search-forward pat nil t)
 174         (setq header-values (cons (buffer-substring (point)
 175                                                     (std11-field-end))
 176                                   header-values)))
 177       (let ((address-regexp
 178              (with-temp-buffer
 179                (let (lal)
 180                  (while header-values
 181                    (setq lal (std11-parse-addresses-string
 182                               (pop header-values)))
 183                    (while lal
 184                      (gnus-bbdb/insert-address-regexp (pop lal)))))
 185                (buffer-string))))
 186         (unless (zerop (length address-regexp))
 187           (gnus-bbdb/split-mail-1 address-regexp bbdb-field regexp group))))))
 188
 189 (defun gnus-bbdb/insert-address-regexp (address)
 190   "Insert string of address part from parsed ADDRESS of RFC 822."
 191   (cond ((eq (car address) 'group)
 192          (setq address (cdr address))
 193          (while address
 194            (gnus-bbdb/insert-address-regexp (pop address))))
 195         ((eq (car address) 'mailbox)
 196          (unless (eq (point) (point-min))
 197            (insert "\\|"))
 198          (let ((addr (nth 1 address)))
 199            (insert (regexp-quote (std11-addr-to-string
 200                                   (if (eq (car addr) 'phrase-route-addr)
 201                                       (nth 2 addr)
 202                                     (cdr addr)))))))))
 203
 204 (defun gnus-bbdb/split-mail-1 (address-regexp bbdb-field regexp group)
 205   (let ((records (bbdb-search (bbdb-records) nil nil address-regexp))
 206         prop rest)
 207     (or regexp (setq regexp ""))
 208     (catch 'done
 209       (cond
 210        ((eq group '&)
 211         (while records
 212           (when (and (setq prop (bbdb-record-getprop (car records) bbdb-field))
 213                      (string-match regexp prop)
 214                      (not (member prop rest)))
 215             (setq rest (cons prop rest)))
 216           (setq records (cdr records)))
 217         (throw 'done (when rest (cons '& rest))))
 218        (t
 219         (while records
 220           (when (or (null bbdb-field)
 221                     (and (setq prop (bbdb-record-getprop (car records)
 222                                                          bbdb-field))
 223                          (string-match regexp prop)))
 224             (throw 'done (or group prop)))
 225           (setq records (cdr records))))))))
 226
 227 ;;
 228 ;; Announcing BBDB entries in the summary buffer
 229 ;;
 230
 231 (defcustom gnus-bbdb/lines-and-from-length 18
 232   "*The number of characters used to display From: info in Gnus, if you have
 233 set gnus-optional-headers to 'gnus-bbdb/lines-and-from."
 234   :group 'bbdb-mua-specific-gnus
 235   :type 'integer)
 236
 237 (defcustom gnus-bbdb/summary-mark-known-posters t
 238   "*If t, mark messages created by people with records in the BBDB.
 239 In GNUS, this marking will take place in the subject list (assuming
 240 `gnus-optional-headers' contains `gnus-bbdb/lines-and-from').  In Gnus, the
 241 marking will take place in the Summary buffer if the format code defined by
 242 `gnus-bbdb/summary-user-format-letter' is used in `gnus-summary-line-format'.
 243 This variable has no effect on the marking controlled by
 244 `gnus-bbdb/summary-in-bbdb-format-letter'."
 245   :group 'bbdb-mua-specific-gnus
 246   :type '(choice (const :tag "Mark known posters" t)
 247                  (const :tag "Do not mark known posters" nil)))
 248 (static-when (and (fboundp 'defvaralias)
 249                   (subrp (symbol-function 'defvaralias)))
 250   (defvaralias 'gnus-bbdb/mark-known-posters
 251     'gnus-bbdb/summary-mark-known-posters))
 252
 253 (defcustom gnus-bbdb/summary-known-poster-mark "+"
 254   "This is the default character to prefix author names with if
 255 gnus-bbdb/summary-mark-known-posters is t.  If the poster's record has
 256 an entry in the field named by bbdb-message-marker-field, then that will
 257 be used instead."
 258   :group 'bbdb-mua-specific-gnus
 259   :type 'character)
 260
 261 (defcustom gnus-bbdb/summary-show-bbdb-names t
 262   "*If both this variable and `gnus-bbdb/summary-prefer-real-names' are true,
 263 then for messages from authors who are in your database, the name
 264 displayed will be the primary name in the database, rather than the
 265 one in the From line of the message.  This doesn't affect the names of
 266 people who aren't in the database, of course.  (`gnus-optional-headers'
 267 must be `gnus-bbdb/lines-and-from' for GNUS users.)"
 268   :group 'bbdb-mua-specific-gnus
 269   :type 'boolean)
 270 (static-when (and (fboundp 'defvaralias)
 271                   (subrp (symbol-function 'defvaralias)))
 272   (defvaralias 'gnus-bbdb/header-show-bbdb-names
 273     'gnus-bbdb/summary-show-bbdb-names))
 274
 275 (defcustom gnus-bbdb/summary-prefer-bbdb-data t
 276   "If t, then for posters who are in our BBDB, replace the information
 277 provided in the From header with data from the BBDB."
 278   :group 'bbdb-mua-specific-gnus
 279   :type 'boolean)
 280
 281 (defcustom gnus-bbdb/summary-prefer-real-names t
 282   "If t, then display the poster's name from the BBDB if we have one,
 283 otherwise display his/her primary net address if we have one.  If it
 284 is set to the symbol bbdb, then real names will be used from the BBDB
 285 if present, otherwise the net address in the post will be used.  If
 286 gnus-bbdb/summary-prefer-bbdb-data is nil, then this has no effect.
 287 See `gnus-bbdb/lines-and-from' for GNUS users, or
 288 `gnus-bbdb/summary-user-format-letter' for Gnus users."
 289   :group 'bbdb-mua-specific-gnus
 290   :type '(choice (const :tag "Prefer real names" t)
 291                  (const :tag "Prefer network addresses" nil)))
 292 (static-when (and (fboundp 'defvaralias)
 293                   (subrp (symbol-function 'defvaralias)))
 294   (defvaralias 'gnus-bbdb/header-prefer-real-names
 295     'gnus-bbdb/summary-prefer-real-names))
 296
 297 (defcustom gnus-bbdb/summary-user-format-letter "B"
 298   "This is the gnus-user-format-function- that will be used to insert
 299 the information from the BBDB in the summary buffer (using
 300 `gnus-bbdb/summary-get-author').  This format code is meant to replace
 301 codes that insert sender names or addresses (like %A or %n). Unless
 302 you've alread got other code using user format B, you might as well
 303 stick with the default.  Additionally, if the value of this variable
 304 is nil, no format function will be installed for
 305 `gnus-bbdb/summary-get-author'.  See also
 306 `gnus-bbdb/summary-in-bbdb-format-letter', which installs a format
 307 code for `gnus-bbdb/summary-author-in-bbdb'"
 308   :group 'bbdb-mua-specific-gnus
 309   :type 'character)
 310
 311 (defcustom gnus-bbdb/summary-in-bbdb-format-letter "b"
 312   "This is the gnus-user-format-function- that will be used to insert
 313 `gnus-bbdb/summary-known-poster-mark' (using
 314 `gnus-bbdb/summary-author-in-bbdb') if the poster is in the BBDB, and
 315 \" \" if not.  If the value of this variable is nil, no format code
 316 will be installed for `gnus-bbdb/summary-author-in-bbdb'.  See also
 317 `gnus-bbdb/summary-user-format-letter', which installs a format code
 318 for `gnus-bbdb/summary-get-author'."
 319   :group 'bbdb-mua-specific-gnus
 320   :type 'character)
 321
 322 (defcustom bbdb-message-marker-field 'mark-char
 323   "*The field whose value will be used to mark messages by this user in Gnus."
 324   :group 'bbdb-mua-specific-gnus
 325   :type 'symbol)
 326
 327 ;;;###autoload
 328 (defun gnus-bbdb/lines-and-from (header)
 329   "Useful as the value of gnus-optional-headers in *GNUS* (not Gnus).
 330 NOTE: This variable no longer seems to be present in Gnus.  It seems
 331 to have been replaced by `message-default-headers', which only takes
 332 strings.  In the future this should change."
 333   (let* ((length gnus-bbdb/lines-and-from-length)
 334          (lines (mail-header-lines header))
 335          (from (mail-header-from header))
 336          (data (and (or gnus-bbdb/summary-mark-known-posters
 337                         gnus-bbdb/summary-show-bbdb-names)
 338                     (condition-case ()
 339                         (gnus-bbdb/extract-address-components from)
 340                       (error nil))))
 341          (name (car data))
 342          (net (car (cdr data)))
 343          (record (and data
 344                       (bbdb-search-simple
 345                        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
 403                        name
 404                        (if (and net bbdb-canonicalize-net-hook)
 405                            (bbdb-canonicalize-address net)
 406                          net)))))
 407     (if (and record name (member (downcase name) (bbdb-record-net record)))
 408         ;; bogon!
 409         (setq record nil))
 410     (setq name
 411           (or (and gnus-bbdb/summary-prefer-bbdb-data
 412                    (or (and gnus-bbdb/summary-prefer-real-names
 413                             (and record (bbdb-record-name record)))
 414                        (and record (bbdb-record-net record)
 415                             (nth 0 (bbdb-record-net record)))))
 416               (and gnus-bbdb/summary-prefer-real-names
 417                    (or (and (equal gnus-bbdb/summary-prefer-real-names 'bbdb)
 418                             net)
 419                        name))
 420               net from "**UNKNOWN**"))
 421     (format "%s%s"
 422             (or (and record gnus-bbdb/summary-mark-known-posters
 423                      (or (bbdb-record-getprop
 424                           record bbdb-message-marker-field)
 425                          gnus-bbdb/summary-known-poster-mark))
 426                 " ")
 427             name)))
 428
 429 ;; DEBUG: (gnus-bbdb/summary-author-in-bbdb "From: simmonmt@acm.org")
 430 (defun gnus-bbdb/summary-author-in-bbdb (header)
 431   "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."
 432   (let* ((from (mail-header-from header))
 433          (data (condition-case ()
 434                    (gnus-bbdb/extract-address-components from)
 435                  (error nil)))
 436          (name (car data))
 437          (net (cadr data))
 438          record)
 439     (if (and data
 440              (setq record
 441                    (bbdb-search-simple
 442                     name (if (and net bbdb-canonicalize-net-hook)
 443                              (bbdb-canonicalize-address net)
 444                            net))))
 445         (or (bbdb-record-getprop
 446              record bbdb-message-marker-field)
 447             gnus-bbdb/summary-known-poster-mark) " ")))
 448
 449 ;;
 450 ;; Scoring
 451 ;;
 452
 453 (defcustom gnus-bbdb/score-field 'gnus-score
 454   "This variable contains the name of the BBDB field which should be
 455 checked for a score to add to the net addresses in the same record."
 456   :group 'bbdb-mua-specific-gnus-scoring
 457   :type 'symbol)
 458
 459 (defcustom gnus-bbdb/score-default nil
 460   "If this is set, then every net address in the BBDB that does not have
 461 an associated score field will be assigned this score.  A value of nil
 462 implies a default score of zero."
 463   :group 'bbdb-mua-specific-gnus-scoring
 464   :type '(choice (const :tag "Do not assign default score")
 465                  (integer :tag "Assign this default score" 0)))
 466
 467 (defvar gnus-bbdb/score-default-internal nil
 468   "Internal variable for detecting changes to
 469 `gnus-bbdb/score-default'.  You should not set this variable directly -
 470 set `gnus-bbdb/score-default' instead.")
 471
 472 (defvar gnus-bbdb/score-alist nil
 473   "The text version of the scoring structure returned by
 474 gnus-bbdb/score.  This is built automatically from the BBDB.")
 475
 476 (defvar gnus-bbdb/score-rebuild-alist t
 477   "Set to t to rebuild gnus-bbdb/score-alist on the next call to
 478 gnus-bbdb/score.  This will be set automatically if you change a BBDB
 479 record which contains a gnus-score field.")
 480
 481 (defun gnus-bbdb/score-invalidate-alist (rec)
 482   "This function is called through bbdb-after-change-hook, and sets
 483 gnus-bbdb/score-rebuild-alist to t if the changed record contains a
 484 gnus-score field."
 485   (if (bbdb-record-getprop rec gnus-bbdb/score-field)
 486       (setq gnus-bbdb/score-rebuild-alist t)))
 487
 488 ;;;###autoload
 489 (defun gnus-bbdb/score (group)
 490   "This returns a score alist for GNUS.  A score pair will be made for
 491 every member of the net field in records which also have a gnus-score
 492 field.  This allows the BBDB to serve as a supplemental global score
 493 file, with the advantage that it can keep up with multiple and changing
 494 addresses better than the traditionally static global scorefile."
 495   (list (list
 496          (condition-case nil
 497              (read (gnus-bbdb/score-as-text group))
 498            (error (setq gnus-bbdb/score-rebuild-alist t)
 499                   (message "Problem building BBDB score table.")
 500                   (ding) (sit-for 2)
 501                   nil)))))
 502
 503 (defun gnus-bbdb/score-as-text (group)
 504   "Returns a SCORE file format string built from the BBDB."
 505   (cond ((or (cond ((/= (or gnus-bbdb/score-default 0)
 506                         (or gnus-bbdb/score-default-internal 0))
 507                     (setq gnus-bbdb/score-default-internal
 508                           gnus-bbdb/score-default)
 509                     t))
 510              (not gnus-bbdb/score-alist)
 511              gnus-bbdb/score-rebuild-alist)
 512          (setq gnus-bbdb/score-rebuild-alist nil)
 513          (setq gnus-bbdb/score-alist
 514                (concat "((touched nil) (\"from\"\n"
 515                        (mapconcat
 516                         (lambda (rec)
 517                           (let ((score (or (bbdb-record-getprop
 518                                             rec
 519                                             gnus-bbdb/score-field)
 520                                            gnus-bbdb/score-default))
 521                                 (net (bbdb-record-net rec)))
 522                             (if (not (and score net)) nil
 523                               (mapconcat
 524                                (lambda (addr)
 525                                  (concat "(\"" addr "\" " score ")\n"))
 526                                net ""))))
 527                         (bbdb-records) "")
 528                        "))"))))
 529   gnus-bbdb/score-alist)
 530
 531 (defun gnus-bbdb/extract-field-value-init ()
 532   (function gnus-bbdb/extract-field-value))
 533
 534 (defun gnus-bbdb/extract-field-value (field-name)
 535   "Given the name of a field (like \"Subject\") this returns the value of
 536 that field in the current message, or nil.  This works whether you're in
 537 Semi-gnus, Rmail, or VM.  This works on multi-line fields, but if more than
 538 one field of the same name is present, only the last is returned.  It is
 539 expected that the current buffer has a message in it, and (point) is at the
 540 beginning of the message headers."
 541   ;; we can't special-case VM here to use its cache, because the cache has
 542   ;; divided real-names from addresses; the actual From: and Subject: fields
 543   ;; exist only in the message.
 544   (let (value)
 545     (when (setq value (mime-entity-fetch-field
 546                        gnus-current-headers field-name))
 547       (gnus-bbdb/decode-field-body value field-name))))
 548
 549 ;;; @ mail-extr
 550 ;;;
 551
 552 (defvar gnus-bbdb/canonicalize-full-name-methods
 553   '(gnus-bbdb/canonicalize-dots
 554     gnus-bbdb/canonicalize-spaces))
 555
 556 (defun gnus-bbdb/extract-address-components (str)
 557   (let* ((ret     (std11-extract-address-components str))
 558          (phrase  (car ret))
 559          (address (car (cdr ret)))
 560          (methods gnus-bbdb/canonicalize-full-name-methods))
 561     (while (and phrase methods)
 562       (setq phrase  (funcall (car methods) phrase)
 563             methods (cdr methods)))
 564     (if (string= address "") (setq address nil))
 565     (if (string= phrase "") (setq phrase nil))
 566     (when (or phrase address)
 567       (list phrase address))))
 568
 569 ;;; @ full-name canonicalization methods
 570 ;;;
 571
 572 (defun gnus-bbdb/canonicalize-spaces (str)
 573   (let (dest)
 574     (while (string-match "\\s +" str)
 575       (setq dest (cons (substring str 0 (match-beginning 0)) dest))
 576       (setq str (substring str (match-end 0))))
 577     (or (string= str "")
 578         (setq dest (cons str dest)))
 579     (setq dest (nreverse dest))
 580     (mapconcat 'identity dest " ")))
 581
 582 (defun gnus-bbdb/canonicalize-dots (str)
 583   (let (dest)
 584     (while (string-match "\\." str)
 585       (setq dest (cons (substring str 0 (match-end 0)) dest))
 586       (setq str (substring str (match-end 0))))
 587     (or (string= str "")
 588         (setq dest (cons str dest)))
 589     (setq dest (nreverse dest))
 590     (mapconcat 'identity dest " ")))
 591
 592 ;;
 593 ;; Insinuation
 594 ;;
 595
 596 ;;;###autoload
 597 (defun gnus-bbdb-insinuate ()
 598   "Call this function to hook BBDB into Semi-gnus."
 599 ;;  (setq gnus-optional-headers 'gnus-bbdb/lines-and-from)
 600   (when (boundp 'bbdb-extract-field-value-function-list)
 601     (add-to-list 'bbdb-extract-field-value-function-list
 602                  'gnus-bbdb/extract-field-value-init))
 603   (add-hook 'gnus-article-prepare-hook 'gnus-bbdb/update-record)
 604   (add-hook 'gnus-save-newsrc-hook 'bbdb-offer-save)
 605   (define-key gnus-summary-mode-map ":" 'gnus-bbdb/show-sender)
 606   (define-key gnus-summary-mode-map ";" 'gnus-bbdb/edit-notes)
 607
 608   ;; Set up user field for use in gnus-summary-line-format
 609   (let ((get-author-user-fun (intern
 610                               (concat "gnus-user-format-function-"
 611                                       gnus-bbdb/summary-user-format-letter)))
 612         (in-bbdb-user-fun (intern
 613                            (concat "gnus-user-format-function-"
 614                                    gnus-bbdb/summary-in-bbdb-format-letter))))
 615                                         ; The big one - whole name
 616     (cond (gnus-bbdb/summary-user-format-letter
 617            (if (and (fboundp get-author-user-fun)
 618                     (not (eq (symbol-function get-author-user-fun)
 619                              'gnus-bbdb/summary-get-author)))
 620                (bbdb-warn
 621                 (format "`gnus-user-format-function-%s' already seems to be in use.
 622 Please redefine `gnus-bbdb/summary-user-format-letter' to a different letter."
 623                         gnus-bbdb/summary-user-format-letter))
 624              (fset get-author-user-fun 'gnus-bbdb/summary-get-author))))
 625
 626     ; One tick.  One tick only, please
 627     (cond (gnus-bbdb/summary-in-bbdb-format-letter
 628            (if (and (fboundp in-bbdb-user-fun)
 629                     (not (eq (symbol-function in-bbdb-user-fun)
 630                              'gnus-bbdb/summary-author-in-bbdb)))
 631                (bbdb-warn
 632                 (format "`gnus-user-format-function-%s' already seems to be in use.
 633 Redefine `gnus-bbdb/summary-in-bbdb-format-letter' to a different letter."
 634                         gnus-bbdb/summary-in-bbdb-format-letter))
 635              (fset in-bbdb-user-fun 'gnus-bbdb/summary-author-in-bbdb)))))
 636
 637   ;; Scoring
 638   (add-hook 'bbdb-after-change-hook 'gnus-bbdb/score-invalidate-alist)
 639 ;  (setq gnus-score-find-score-files-function
 640 ;       (if (boundp 'gnus-score-find-score-files-function)
 641 ;           (cond ((functionp gnus-score-find-score-files-function)
 642 ;                  (list gnus-score-find-score-files-function
 643 ;                        'gnus-bbdb/score))
 644 ;                 ((listp gnus-score-find-score-files-function)
 645 ;                  (append gnus-score-find-score-files-function
 646 ;                          'gnus-bbdb/score))
 647 ;                 (t 'gnus-bbdb/score))
 648 ;         'gnus-bbdb/score))
 649   )
 650
 651 ;;;###autoload
 652 (defun gnus-bbdb-insinuate-message ()
 653   "Call this function to hook BBDB into message-mode."
 654   (define-key message-mode-map "\M-\t" 'bbdb-complete-name))
 655
 656 (provide 'gnus-bbdb)