cgit.sxemacs.org Git - packages/blob - xemacs-packages/bbdb/lisp/bbdb-hooks.el

   1 ;;; -*- Mode:Emacs-Lisp -*-
   2
   3 ;;; This file is part of the Insidious Big Brother Database (aka BBDB),
   4 ;;; copyright (c) 1991, 1992, 1993 Jamie Zawinski <jwz@netscape.com>.
   5 ;;; Various additional functionality for the BBDB.  See bbdb.texinfo.
   6
   7 ;;; The Insidious Big Brother Database is free software; you can redistribute
   8 ;;; it and/or modify it under the terms of the GNU General Public License as
   9 ;;; published by the Free Software Foundation; either version 2 or (at your
  10 ;;; option) any later version.
  11 ;;;
  12 ;;; BBDB is distributed in the hope that it will be useful, but WITHOUT ANY
  13 ;;; WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
  14 ;;; FOR A PARTICULAR PURPOSE.  See the GNU General Public License for more
  15 ;;; details.
  16 ;;;
  17 ;;; You should have received a copy of the GNU General Public License
  18 ;;; along with GNU Emacs; see the file COPYING.  If not, write to
  19 ;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  20
  21 ;;; This file lets you do stuff like
  22 ;;;
  23 ;;; o  automatically update a "timestamp" field each time a record is
  24 ;;;        modified
  25 ;;; o  automatically add some string to the notes field(s) based on the
  26 ;;;    contents of header fields of the current message
  27 ;;; o  only automatically create entries when certain header fields
  28 ;;;    are matched
  29 ;;; o  don't automatically create entries when certain header fields
  30 ;;;    are matched
  31 ;;;
  32 ;;; Read the docstrings; read the texinfo file.
  33
  34 ;;
  35 ;; $Id: bbdb-hooks.el,v 1.7 2007-02-23 20:24:07 fenk Exp $
  36 ;;
  37
  38 (require 'bbdb)
  39 (require 'bbdb-com)
  40 (require 'mail-parse)
  41
  42 (eval-when-compile
  43   (condition-case()
  44       (progn
  45         (require 'gnus)
  46         (require 'bbdb-gnus))
  47     (error nil))
  48   (condition-case()
  49       (progn
  50         (require 'vm)
  51         (require 'bbdb-vm))
  52     (error nil))
  53   (autoload 'mh-show "mh-e")
  54   (condition-case()
  55       (require 'bbdb-rmail)
  56     (error nil)))
  57
  58 (defvar rmail-buffer)
  59 (defvar mh-show-buffer)
  60
  61
  62 (defvar bbdb-time-internal-format "%Y-%m-%d"
  63   "The internal date format.")
  64
  65 ;;;###autoload
  66 (defun bbdb-timestamp-hook (record)
  67   "For use as a `bbdb-change-hook'; maintains a notes-field called `timestamp'
  68 for the given record which contains the time when it was last modified.  If
  69 there is such a field there already, it is changed, otherwise it is added."
  70   (bbdb-record-putprop record 'timestamp (format-time-string
  71                       bbdb-time-internal-format
  72                       (current-time))))
  73
  74 ;;;###autoload
  75 (defun bbdb-creation-date-hook (record)
  76   "For use as a `bbdb-create-hook'; adds a notes-field called `creation-date'
  77 which is the current time string."
  78   ;; hey buddy, we've known about your antics since the eighties...
  79   (bbdb-record-putprop record 'creation-date (format-time-string
  80                           bbdb-time-internal-format
  81                           (current-time))))
  82
  83 \f
  84 ;;; Determining whether to create a record based on the content of the
  85 ;;; current message.
  86
  87 (eval-when-compile
  88   (defvar vm-mail-buffer)
  89   (defvar vm-message-pointer)
  90   (autoload 'vm-start-of "vm")
  91   (autoload 'bbdb/vm-pop-up-bbdb-buffer "bbdb-vm"))
  92
  93 ;;;###autoload
  94 (defun bbdb-header-start ()
  95   "Returns a marker at the beginning of the header block of the current
  96 message.  This will not necessarily be in the current buffer."
  97   (cond ((memq major-mode
  98                '(gnus-group-mode gnus-summary-mode gnus-article-mode))
  99          (set-buffer (or gnus-original-article-buffer
 100                          gnus-article-buffer))
 101          (point-min-marker))
 102         ((memq major-mode '(vm-presentation-mode vm-mode vm-summary-mode))
 103          (if vm-mail-buffer (set-buffer vm-mail-buffer))
 104          (vm-start-of (car vm-message-pointer)))
 105         ((memq major-mode '(rmail-mode rmail-summary-mode))
 106          (if (and (boundp 'rmail-buffer) rmail-buffer)
 107              (set-buffer rmail-buffer))
 108          (point-min-marker))
 109         ;; MH-E clause added by knabe.
 110         ((eq major-mode 'mh-folder-mode)
 111          (mh-show)
 112          (set-buffer mh-show-buffer)
 113          (point-min-marker))
 114         (t (point-min-marker))
 115         ))
 116
 117
 118 ;;;###autoload
 119 (defun bbdb-extract-field-value (field-name)
 120   "Given the name of a field (like \"Subject\") this returns the value of
 121 that field in the current message, or nil.  This works whether you're in
 122 Gnus, Rmail, or VM.  This works on multi-line fields, but if more than
 123 one field of the same name is present, only the last is returned.  It is
 124 expected that the current buffer has a message in it, and (point) is at the
 125 beginning of the message headers."
 126   ;; we can't special-case VM here to use its cache, because the cache has
 127   ;; divided real-names from addresses; the actual From: and Subject: fields
 128   ;; exist only in the message.
 129   (save-excursion
 130     (if (memq major-mode
 131               '(gnus-summary-mode gnus-article-mode gnus-tree-mode))
 132         (progn
 133           (set-buffer (get-buffer gnus-original-article-buffer))
 134           (goto-char (point-min))))
 135     (setq field-name (concat (regexp-quote field-name) "[ \t]*:[ \t]*"))
 136     (let ((case-fold-search t)
 137           done)
 138       (while (not (or done
 139               (looking-at "\n") ; we're at BOL
 140               (eobp)))
 141         (if (looking-at field-name)
 142         (progn
 143           (goto-char (match-end 0))
 144           (setq done (buffer-substring (point)
 145                        (progn (end-of-line) (point))))
 146           (while (looking-at "\n[ \t]")
 147             (setq done (concat done " "
 148                  (buffer-substring (match-end 0)
 149                    (progn (end-of-line 2) (point))))))))
 150         (forward-line 1))
 151       (and done
 152            (mail-decode-encoded-word-string done)))))
 153
 154 (defcustom bbdb-ignore-most-messages-alist '()
 155   "*An alist describing which messages to automatically create BBDB
 156 records for.  This only works if bbdb/news-auto-create-p or
 157 bbdb/mail-auto-create-p (or both) is 'bbdb-ignore-most-messages-hook.
 158 The format of this alist is
 159    (( HEADER-NAME . REGEXP ) ... )
 160 for example,
 161    ((\"From\" . \"@.*\\.maximegalon\\.edu\")
 162     (\"Subject\" . \"time travel\"))
 163 will cause BBDB entries to be made only for messages sent by people at
 164 Maximegalon U., or (that's *or*) people posting about time travel.
 165
 166 See also bbdb-ignore-some-messages-alist, which has the opposite effect."
 167   :group 'bbdb-noticing-records
 168   :type '(repeat (cons
 169           (string :tag "Header name")
 170           (regexp :tag "Regex to match on header value"))))
 171
 172
 173 (defcustom bbdb-ignore-some-messages-alist '()
 174   "*An alist describing which messages *not* to automatically create
 175 BBDB records for.  This only works if bbdb/news-auto-create-p or
 176 bbdb/mail-auto-create-p (or both) is 'bbdb-ignore-some-messages-hook.
 177 The format of this alist is
 178    (( HEADER-NAME . REGEXP ) ... )
 179 for example,
 180    ((\"From\" . \"mailer-daemon\")
 181     (\"To\" . \"mailing-list-1\\\\|mailing-list-2\")
 182     (\"CC\" . \"mailing-list-1\\\\|mailing-list-2\"))
 183 will cause BBDB entries to not be made for messages from any mailer daemon,
 184 or messages sent to or CCed to either of two mailing lists.
 185
 186 See also bbdb-ignore-most-messages-alist, which has the opposite effect."
 187   :group 'bbdb-noticing-records
 188   :type '(repeat (cons
 189           (string :tag "Header name")
 190           (regexp :tag "Regex to match on header value"))))
 191
 192
 193 ;;;###autoload
 194 (defun bbdb-ignore-most-messages-hook (&optional invert-sense)
 195   "For use as the value of bbdb/news-auto-create-p or bbdb/mail-auto-create-p.
 196 This will automatically create BBDB entries for messages which match
 197 the bbdb-ignore-most-messages-alist (which see) and *no* others."
 198   ;; don't need to optimize this to check the cache, because if
 199   ;; bbdb/*-update-record uses the cache, this won't be called.
 200   (let ((rest (if invert-sense
 201           bbdb-ignore-some-messages-alist
 202           bbdb-ignore-most-messages-alist))
 203         (case-fold-search t)
 204         (done nil)
 205         (b (current-buffer))
 206         (marker (bbdb-header-start))
 207         field regexp fieldval)
 208     (set-buffer (marker-buffer marker))
 209     (save-restriction
 210       (widen)
 211       (while (and rest (not done))
 212         (goto-char marker)
 213         (setq field (car (car rest))
 214               regexp (cdr (car rest))
 215               fieldval (bbdb-extract-field-value field))
 216         (if (and fieldval (string-match regexp fieldval))
 217             (setq done t))
 218         (setq rest (cdr rest))))
 219     (set-buffer b)
 220     (if invert-sense
 221         (not done)
 222       done)))
 223
 224 ;;; Provided by Bill Carpenter.
 225 (defvar bbdb-ignore-selected-messages-confirmation nil
 226   "*If bbdb-ignore-selected-messages-hook is used as an auto-create-hook, this
 227 variable governs whether you are prompted for creation of BBDB entries.")
 228
 229 ;;;###autoload
 230 (defun bbdb-ignore-selected-messages-hook ()
 231   "For use as a bbdb/news-auto-create-hook or bbdb/mail-auto-create-hook.
 232 This will automatically create BBDB entries for messages based on a
 233 combination of bbdb-ignore-some-messages-alist and
 234 bbdb-ignore-most-messages-alist.  It first looks at the SOME list.  If
 235 that doesn't disqualify a message, then it looks at the MOST list.  If
 236 that qualifies the message, the record is auto-created, but a
 237 confirmation is conditionally sought, based on the value of
 238 `bbdb-ignore-selected-messages-confirmation'."
 239   (if (bbdb-ignore-some-messages-hook)
 240       ;; wasn't ruled out
 241       (if (bbdb-ignore-most-messages-hook)
 242           ;; was ruled in
 243           (if bbdb-ignore-selected-messages-confirmation
 244               (let ((case-fold-search t)
 245                     (marker (bbdb-header-start))
 246                     record-exists from)
 247                 (save-excursion
 248                   (set-buffer (marker-buffer marker))
 249                   (save-restriction
 250                     (widen)
 251                     (goto-char marker)
 252                     (setq from (bbdb-extract-field-value "FROM"))))
 253                 (setq record-exists (bbdb-annotate-message-sender from))
 254                 (or record-exists
 255                     (y-or-n-p (concat "Create BBDB record from " from "? "))))
 256             ;; no confirmation desired so let it be
 257             t)
 258         nil)
 259     nil))
 260
 261 ;;;###autoload
 262 (defun bbdb-ignore-some-messages-hook ()
 263   "For use as a `bbdb/news-auto-create-hook' or `bbdb/mail-auto-create-hook'.
 264 This will automatically create BBDB entries for messages which do *not*
 265 match the `bbdb-ignore-some-messages-alist' (which see)."
 266   (bbdb-ignore-most-messages-hook t))
 267
 268 \f
 269 ;;; Automatically add to the notes field based on the current message.
 270
 271 (defcustom bbdb-auto-notes-alist nil
 272   "*An alist which lets you have certain pieces of text automatically added
 273 to the BBDB record representing the sender of the current message based on
 274 the subject or other header fields.  This only works if `bbdb-notice-hook'
 275 contains `bbdb-auto-notes-hook'.  The format of this alist is
 276
 277    ((HEADER-NAME [ADDRESS-CLASS-LIST]
 278        (REGEXP . STRING) ... )
 279       ... )
 280 for example,
 281    ((\"To\" (\"-vm@\" . \"VM mailing list\"))
 282     (\"Subject\" (\"sprocket\" . \"mail about sprockets\")
 283                (\"you bonehead\" . \"called me a bonehead\")))
 284
 285 will cause the text \"VM mailing list\" to be added to the notes field of
 286 the record corresponding to anyone you get mail from via one of the VM
 287 mailing lists.  If, that is, `bbdb/mail-auto-create-p' is set such that the
 288 record would have been created, or the record already existed.
 289
 290 A ADDRESS-CLASS-LIST is optional and by default actions will be performed only
 291 for records of authors of a message.  However, by giving an list of classes
 292 specified in `bbdb-get-addresses-headers'.  Actions will then only be
 293 performed if the currently processed email is of a class listed in
 294 ADDRESS-CLASS-LIST.  ADDRESS-CLASS-LIST might also be an alist with elements
 295 of the form (CLASS . HEADER) which allows actions only when the current
 296 address matches one of the elemets.
 297
 298 The format of elements of this list may also be
 299        (REGEXP FIELD-NAME STRING)
 300 or
 301        (REGEXP FIELD-NAME STRING REPLACE-P)
 302 instead of
 303        (REGEXP . STRING)
 304
 305 meaning add the given string to the named field.  The field-name may not
 306 be name, address, phone, or net (builtin fields) but must be either ``notes,''
 307 ``company,'' or the name of a user-defined note-field.
 308        (\"pattern\" . \"string to add\")
 309 is equivalent to
 310        (\"pattern\" notes \"string to add\")
 311
 312 STRING can contain \\& or \\N escapes like in function
 313 `replace-match'.  For example, to automatically add the contents of the
 314 \"organization\" field of a message to the \"company\" field of a BBDB
 315 record, you can use this:
 316
 317         (\"Organization\" (\".*\" company \"\\\\&\"))
 318
 319 \(Note you need two \\ to get a single \\ into a lisp string literal.\)
 320
 321 If STRING is an integer N, the N'th matching subexpression is used, so
 322 the above example could be written more efficiently as
 323
 324         (\"Organization\" (\".*\" company 0))
 325
 326 If STRING is neither a string or an integer, it should be a function, which
 327 will be called with the contents of the field.  The result of that function
 328 call is used as the field value (the returned value must be a string.)
 329
 330 If REPLACE-P is t, the string replaces the old contents instead of
 331 being appended to it.
 332
 333 If multiple clauses match the message, all of the corresponding strings
 334 will be added.
 335
 336 This works for news as well.  You might want to arrange for this to have
 337 a different value when in mail as when in news.
 338
 339 See also variables `bbdb-auto-notes-ignore' and `bbdb-auto-notes-ignore-all'."
 340   :group 'bbdb-noticing-records
 341   :type '(repeat
 342           (bbdb-alist-with-header
 343            (string :tag "Header name")
 344            (repeat (choice
 345                     (cons :tag "Address Class"
 346                           (repeat (choice
 347                                    (const authors)
 348                                    (const recipients))))
 349                     (cons :tag "Value Pair"
 350                           (regexp :tag "Regexp to match on header value")
 351                           (string :tag "String for notes if regexp matches"))
 352                     (list :tag "Replacement list"
 353                           (regexp :tag "Regexp to match on header value")
 354                           (choice :tag "Record field"
 355                                   (const notes :tag "Notes")
 356                                   (const company :tag "Company")
 357                                   (symbol :tag "Other"))
 358                           (choice :tag "Regexp match"
 359                                   (string :tag "Replacement string")
 360                                   (integer :tag "Subexpression match")
 361                                   (function :tag "Callback Function"))
 362                           (choice :tag "Replace previous contents"
 363                                   (const :tag "No" nil)
 364                                   (const :tag "Yes" t))))))))
 365
 366 (defcustom bbdb-auto-notes-ignore nil
 367   "Alist of headers and regexps to ignore in `bbdb-auto-notes-hook'.
 368 Each element looks like
 369
 370     (HEADER . REGEXP)
 371
 372 For example,
 373
 374     (\"Organization\" . \"^Gatewayed from\\\\\|^Source only\")
 375
 376 would exclude the phony `Organization:' headers in GNU mailing-lists
 377 gatewayed to gnu.* newsgroups.  Note that this exclusion applies only
 378 to a single field, not to the entire message.  For that, use the variable
 379 `bbdb-auto-notes-ignore-all'."
 380   :group 'bbdb-noticing-records
 381   :type '(repeat (cons
 382           (string :tag "Header name")
 383           (regexp :tag "Regexp to match on header value"))))
 384
 385 (defcustom bbdb-auto-notes-ignore-all nil
 386   "Alist of headers and regexps which cause the entire message to be ignored
 387 in `bbdb-auto-notes-hook'.  Each element looks like
 388
 389     (HEADER . REGEXP)
 390
 391 For example,
 392
 393     (\"From\" . \"BLAT\\\\.COM\")
 394
 395 would exclude any notes recording for message coming from BLAT.COM.
 396 Note that this is different from `bbdb-auto-notes-ignore', which applies
 397 only to a particular header field, rather than the entire message."
 398   :group 'bbdb-noticing-records
 399   :type '(repeat (cons
 400           (string :tag "Header name")
 401           (regexp :tag "Regexp to match on header value"))))
 402
 403
 404 ;;;###autoload
 405 (defun bbdb-auto-notes-hook (record)
 406   "For use as a `bbdb-notice-hook'.  This might automatically add some text
 407 to the notes field of the BBDB record corresponding to the current record
 408 based on the header of the current message.  See the documentation for
 409 the variables `bbdb-auto-notes-alist' and `bbdb-auto-notes-ignore'."
 410   ;; This could stand to be faster...
 411   ;; could optimize this to check the cache, and noop if this record is
 412   ;; cached for any other message, but that's probably not the right thing.
 413   (unless bbdb-readonly-p
 414    (let ((rest bbdb-auto-notes-alist)
 415          (ignore-all bbdb-auto-notes-ignore-all)
 416          (case-fold-search t)
 417          (b (current-buffer))
 418          (marker (bbdb-header-start))
 419          ignore
 420          field pairs fieldval  ; do all bindings here for speed
 421          regexp string notes-field-name notes
 422          replace-p)
 423     (set-buffer (marker-buffer marker))
 424     (save-restriction
 425       (widen)
 426       (goto-char marker)
 427       (if (and (setq fieldval (bbdb-extract-field-value "From"))
 428                (string-match (bbdb-user-mail-names) fieldval))
 429           ;; Don't do anything if this message is from us.  Note that we have
 430           ;; to look at the message instead of the record, because the record
 431           ;; will be of the recipient of the message if it is from us.
 432           nil
 433         ;; check the ignore-all pattern
 434         (while (and ignore-all (not ignore))
 435           (goto-char marker)
 436           (setq field (car (car ignore-all))
 437                 regexp (cdr (car ignore-all))
 438                 fieldval (bbdb-extract-field-value field))
 439           (if (and fieldval
 440                    (string-match regexp fieldval))
 441               (setq ignore t)
 442             (setq ignore-all (cdr ignore-all))))
 443
 444         (unless ignore          ; ignore-all matched
 445          (while rest ; while there are still clauses in the auto-notes alist
 446           (goto-char marker)
 447           (setq field (car (car rest))  ; name of header, e.g., "Subject"
 448                 pairs (cdr (car rest))  ; (REGEXP . STRING) or
 449                                         ; (REGEXP FIELD-NAME STRING) or
 450                                         ; (REGEXP FIELD-NAME STRING REPLACE-P)
 451                 fieldval (bbdb-extract-field-value field)) ; e.g., Subject line
 452           (when fieldval
 453             ;; we perform the auto notes stuff only for authors of a message
 454             ;; or if explicitly requested
 455             (if (or (symbolp (caar pairs)) (listp (caar pairs)))
 456                 (if (or (memq bbdb-update-address-class (car pairs))
 457                         (and (assoc bbdb-update-address-class (car pairs))
 458                              (string= bbdb-update-address-header
 459                                       (cdr (assoc bbdb-update-address-class
 460                                                   (car pairs))))))
 461                     (setq pairs (cdr pairs))
 462                   (setq pairs nil))
 463               (if (not (and (eq 'authors bbdb-update-address-class)
 464                             (string-match "From" bbdb-update-address-header)))
 465                   (setq pairs nil)))
 466
 467             ;; now handle the remaining pairs
 468             (while pairs
 469               (setq regexp (car (car pairs))
 470                     string (cdr (car pairs)))
 471               (if (consp string) ; not just the (REGEXP . STRING) format
 472                   (setq notes-field-name (car string)
 473                         replace-p (nth 2 string) ; perhaps nil
 474                         string (nth 1 string))
 475                   ;; else it's simple (REGEXP . STRING)
 476                   (setq notes-field-name 'notes
 477                         replace-p nil))
 478               (setq notes (bbdb-record-getprop record notes-field-name))
 479               (let ((did-match
 480                      (and (string-match regexp fieldval)
 481                           ;; make sure it is not to be ignored
 482                           (let ((re (cdr (assoc field
 483                                                 bbdb-auto-notes-ignore))))
 484                             (if re
 485                                 (not (string-match re fieldval))
 486                                 t)))))
 487                 ;; An integer as STRING is an index into match-data:
 488                 ;; A function as STRING calls the function on fieldval:
 489                 (if did-match
 490                     (setq string
 491                           (cond ((integerp string) ; backward compat
 492                                  (substring fieldval
 493                                             (match-beginning string)
 494                                             (match-end string)))
 495                                 ((stringp string)
 496                                  (bbdb-auto-expand-newtext fieldval string))
 497                                 (t
 498                                  (goto-char marker)
 499                                  (let ((s (funcall string fieldval)))
 500                                    (or (stringp s)
 501                                        (null s)
 502                                        (error "%s returned %s: not a string"
 503                                               string s))
 504                                    s)))))
 505                 ;; need expanded version of STRING here:
 506                 (if (and did-match
 507                          string ; A function as STRING may return nil
 508                          (not (and notes
 509                                    ;; check that STRING is not already
 510                                    ;; present in the NOTES field
 511                                    (string-match
 512                                     (regexp-quote string)
 513                                     notes))))
 514                     (if replace-p
 515                         ;; replace old contents of field with STRING
 516                         (progn
 517                           (when (not bbdb-silent-running)
 518                             (if (eq notes-field-name 'notes)
 519                                 (message "Replacing with note \"%s\"" string)
 520                               (message "Replacing field \"%s\" with \"%s\""
 521                                        notes-field-name string)))
 522                           (bbdb-record-putprop record notes-field-name string)
 523                           (bbdb-maybe-update-display record))
 524                         ;; add STRING to old contents, don't replace
 525                       (when (not bbdb-silent-running)
 526                         (if (eq notes-field-name 'notes)
 527                             (message "Adding note \"%s\"" string)
 528                           (message "Adding \"%s\" to field \"%s\""
 529                                    string notes-field-name)))
 530                       (bbdb-annotate-notes record string notes-field-name))))
 531               (setq pairs (cdr pairs))))
 532           (setq rest (cdr rest))))))
 533     (set-buffer b))))
 534
 535 (defun bbdb-auto-expand-newtext (string newtext)
 536   ;; Expand \& and \1..\9 (referring to STRING) in NEWTEXT.
 537   ;; Note that in Emacs 18 match data are clipped to current buffer
 538   ;; size...so the buffer had better not be smaller than STRING (arrrrggggh!!)
 539   (let ((pos 0)
 540     (len (length newtext))
 541     (expanded-newtext ""))
 542     (while (< pos len)
 543       (setq expanded-newtext
 544         (concat expanded-newtext
 545             (let ((c (aref newtext pos)))
 546               (if (= ?\\ c)
 547               (cond ((= ?\& (setq c (aref newtext
 548                               (setq pos (1+ pos)))))
 549                  (substring string
 550                         (match-beginning 0)
 551                         (match-end 0)))
 552                 ((and (>= c ?1)
 553                       (<= c ?9))
 554                  ;; return empty string if N'th
 555                  ;; sub-regexp did not match:
 556                  (let ((n (- c ?0)))
 557                    (if (match-beginning n)
 558                        (substring string
 559                           (match-beginning n)
 560                           (match-end n))
 561                      "")))
 562                 (t (char-to-string c)))
 563             (char-to-string c)))))
 564       (setq pos (1+ pos)))
 565     expanded-newtext))
 566
 567 \f
 568 ;;; I use this as the value of bbdb-canonicalize-net-hook; it is provided
 569 ;;; as an example for you to customize.
 570
 571 (defcustom bbdb-canonical-hosts
 572   (mapconcat 'regexp-quote
 573          '("cs.cmu.edu" "ri.cmu.edu" "edrc.cmu.edu" "andrew.cmu.edu"
 574            "mcom.com" "netscape.com" "cenatls.cena.dgac.fr"
 575            "cenaath.cena.dgac.fr" "irit.fr" "enseeiht.fr" "inria.fr"
 576            "cs.uiuc.edu" "xemacs.org")
 577          "\\|")
 578   "Certain sites have a single mail-host; for example, all mail originating
 579 at hosts whose names end in \".cs.cmu.edu\" can (and probably should) be
 580 addressed to \"user@cs.cmu.edu\" instead.  This variable lists other hosts
 581 which behave the same way."
 582   :group 'bbdb
 583   :type '(regexp :tag "Regexp matching sites"))
 584
 585 (defmacro bbdb-match-substring (string match)
 586   (list 'substring string
 587     (list 'match-beginning match) (list 'match-end match)))
 588
 589 ;;;###autoload
 590 (defun sample-bbdb-canonicalize-net-hook (addr)
 591   (cond
 592    ;;
 593    ;; rewrite mail-drop hosts.
 594    ;;
 595    ((string-match
 596      (concat "\\`\\([^@%!]+@\\).*\\.\\(" bbdb-canonical-hosts "\\)\\'")
 597      addr)
 598     (concat (bbdb-match-substring addr 1) (bbdb-match-substring addr 2)))
 599    ;;
 600    ;; Here at Lucid, our workstation names sometimes get into our email
 601    ;; addresses in the form "jwz%thalidomide@lucid.com" (instead of simply
 602    ;; "jwz@lucid.com").  This removes the workstation name.
 603    ;;
 604    ((string-match "\\`\\([^@%!]+\\)%[^@%!.]+@\\(lucid\\.com\\)\\'" addr)
 605     (concat (bbdb-match-substring addr 1) "@" (bbdb-match-substring addr 2)))
 606    ;;
 607    ;; Another way that our local mailer is misconfigured: sometimes addresses
 608    ;; which should look like "user@some.outside.host" end up looking like
 609    ;; "user%some.outside.host" or even "user%some.outside.host@lucid.com"
 610    ;; instead.  This rule rewrites it into the original form.
 611    ;;
 612    ((string-match "\\`\\([^@%]+\\)%\\([^@%!]+\\)\\(@lucid\\.com\\)?\\'" addr)
 613     (concat (bbdb-match-substring addr 1) "@" (bbdb-match-substring addr 2)))
 614    ;;
 615    ;; Sometimes I see addresses like "foobar.com!user@foobar.com".
 616    ;; That's totally redundant, so this rewrites it as "user@foobar.com".
 617    ;;
 618    ((string-match "\\`\\([^@%!]+\\)!\\([^@%!]+[@%]\\1\\)\\'" addr)
 619     (bbdb-match-substring addr 2))
 620    ;;
 621    ;; Sometimes I see addresses like "foobar.com!user".  Turn it around.
 622    ;;
 623    ((string-match "\\`\\([^@%!.]+\\.[^@%!]+\\)!\\([^@%]+\\)\\'" addr)
 624     (concat (bbdb-match-substring addr 2) "@" (bbdb-match-substring addr 1)))
 625    ;;
 626    ;; The mailer at hplb.hpl.hp.com tends to puke all over addresses which
 627    ;; pass through mailing lists which are maintained there: it turns normal
 628    ;; addresses like "user@foo.com" into "user%foo.com@hplb.hpl.hp.com".
 629    ;; This reverses it.  (I actually could have combined this rule with
 630    ;; the similar lucid.com rule above, but then the regexp would have been
 631    ;; more than 80 characters long...)
 632    ;;
 633    ((string-match "\\`\\([^@!]+\\)%\\([^@%!]+\\)@hplb\\.hpl\\.hp\\.com\\'"
 634           addr)
 635     (concat (bbdb-match-substring addr 1) "@" (bbdb-match-substring addr 2)))
 636    ;;
 637    ;; Another local mail-configuration botch: sometimes mail shows up
 638    ;; with addresses like "user@workstation", where "workstation" is a
 639    ;; local machine name.  That should really be "user" or "user@netscape.com".
 640    ;; (I'm told this one is due to a bug in SunOS 4.1.1 sendmail.)
 641    ;;
 642    ((string-match "\\`\\([^@%!]+\\)[@%][^@%!.]+\\'" addr)
 643     (bbdb-match-substring addr 1))
 644    ;;
 645    ;; Sometimes I see addrs like "foo%somewhere%uunet.uu.net@somewhere.else".
 646    ;; This is silly, because I know that I can send mail to uunet directly.
 647    ;;
 648    ((string-match ".%uunet\\.uu\\.net@[^@%!]+\\'" addr)
 649     (concat (substring addr 0 (+ (match-beginning 0) 1)) "@UUNET.UU.NET"))
 650    ;;
 651    ;; Otherwise, leave it as it is.  Returning a string EQ to the one passed
 652    ;; in tells BBDB that we're done.
 653    ;;
 654    (t addr)))
 655
 656 \f
 657 ;;; Here's another approach; sometimes one gets mail from foo@bar.baz.com,
 658 ;;; and then later gets mail from foo@baz.com.  At this point, one would
 659 ;;; like to delete the bar.baz.com address, since the baz.com address is
 660 ;;; obviously superior.  See also var `bbdb-canonicalize-redundant-nets-p'.
 661 ;;;
 662 ;;; Turn this on with
 663 ;;;   (add-hook 'bbdb-change-hook 'bbdb-delete-redundant-nets)
 664
 665 (defun bbdb-delete-redundant-nets (record)
 666   "Deletes redundant network addresses.
 667 For use as a value of `bbdb-change-hook'.  See `bbdb-net-redundant-p'."
 668   (let* ((nets (bbdb-record-net record))
 669      (rest nets)
 670      net new redundant)
 671     (while rest
 672       (setq net (car rest))
 673       (if (bbdb-net-redundant-p net nets)
 674       (setq redundant (cons net redundant))
 675     (setq new (cons net new)))
 676       (setq rest (cdr rest)))
 677     (cond (redundant
 678        (message "Deleting redundant nets %s..."
 679             (mapconcat 'identity (nreverse redundant) ", "))
 680        (setq new (nreverse new))
 681        (bbdb-record-set-net record new)
 682        t))))
 683
 684
 685 \f
 686 ;;;###autoload
 687 (defun bbdb-force-record-create ()
 688   "Force automatic creation of a BBDB records for the current message.
 689 You might add this to the reply hook of your MUA in order to automatically
 690 get records added for those people you reply to."
 691   (interactive)
 692   (let ((bbdb/mail-auto-create-p t)
 693         (bbdb/news-auto-create-p t)
 694         (bbdb-message-caching-enabled nil)
 695         (bbdb/gnus-update-records-mode 'annotating)
 696         (bbdb/rmail-update-records-mode 'annotating)
 697         (bbdb/mhe-update-records-mode 'annotating)
 698         (bbdb/vm-update-records-mode 'annotating))
 699     (save-excursion
 700       (cond ((member major-mode '(vm-mode vm-virtual-mode vm-summary-mode
 701                                           vm-presentation-mode))
 702              (bbdb/vm-pop-up-bbdb-buffer))
 703             ((member major-mode '(gnus-summary-mode gnus-article-mode
 704                                                     gnus-tree-mode))
 705              (bbdb/gnus-pop-up-bbdb-buffer))
 706             ((member major-mode '(rmail-mode rmail-summary-mode))
 707              (bbdb/rmail-pop-up-bbdb-buffer))
 708             ((member major-mode '(mhe-mode mhe-summary-mode mh-folder-mode))
 709              (bbdb/mh-pop-up-bbdb-buffer))
 710             ))))
 711
 712 (provide 'bbdb-hooks)