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