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