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