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