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