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