git.chise.org Git - elisp/gnus.git-/blob - lisp/gnus-bbdb.el

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