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