;;; -*- Mode:Emacs-Lisp -*-
;;; This file is the part of the Insidious Big Brother Database (aka BBDB),
;;; copyright (c) 1991, 1992, 1993 Jamie Zawinski <email@example.com>.
;;; Interface to VM (View Mail) 5.31 or greater. See bbdb.texinfo.
;;; The Insidious Big Brother Database is free software; you can redistribute
;;; it and/or modify it under the terms of the GNU General Public License as
;;; published by the Free Software Foundation; either version 1, or (at your
;;; option) any later version.
;;; BBDB is distributed in the hope that it will be useful, but WITHOUT ANY
;;; WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
;;; FOR A PARTICULAR PURPOSE. See the GNU General Public License for more
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Emacs; see the file COPYING. If not, write to
;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
(if (not (fboundp 'vm-record-and-change-message-pointer))
(if (not (fboundp 'vm-su-from))
(or (boundp 'vm-mode-map)
(defun bbdb/vm-get-header-content (header-field msg)
(let ((content (vm-get-header-contents msg (concat header-field ":"))))
'(if (vm-new-flag msg) 'annotating 'searching)
"Controls how `bbdb/vm-update-records' processes email addresses.
Set this to an expression which evaluates either to 'searching or
'annotating. When set to 'annotating email addresses will be fed to
`bbdb-annotate-message-sender' in order to update existing records or create
new ones. A value of 'searching will search just for existing records having
the right net.
The default is to annotate only new messages."
:type '(choice (const :tag "annotating all messages"
(const :tag "annotating no messages"
(const :tag "annotating only new messages"
(if (vm-new-flag msg) 'annotating 'searching))
(sexp :tag "user defined")))
(defun bbdb/vm-update-record (&optional offer-to-create)
(let* ((bbdb-get-only-first-address-p t)
(records (bbdb/vm-update-records offer-to-create)))
(if records (car records) nil)))
(defun bbdb/vm-update-records (&optional offer-to-create)
"Returns the records corresponding to the current VM message,
creating or modifying them as necessary. A record will be created if
bbdb/mail-auto-create-p is non-nil or if OFFER-TO-CREATE is true, and
the user confirms the creation.
The variable `bbdb/vm-update-records-mode' controls what actions
are performed and it might override `bbdb-update-records-mode'.
When hitting C-g once you will not be asked anymore for new people listed
in this message, but it will search only for existing records. When hitting
C-g again it will stop scanning."
(let ((msg (car vm-message-pointer))
(enable-local-variables t) ; ...or vm bind this to nil.
(inhibit-quit nil) ; vm better not bind this to t!
;; ignore cache if we may be creating a record, since the cache
;; may otherwise tell us that the user didn't want a record for
;; this person.
(if (not bbdb/vm-offer-to-create)
(setq cache (and msg (bbdb-message-cache-lookup msg))))
(setq records (if bbdb-get-only-first-address-p
(list (car cache))
(let ((bbdb-update-records-mode (or bbdb/vm-update-records-mode
(setq records (bbdb-update-records
(bbdb-encache-message msg records)))
(defun bbdb/vm-annotate-sender (string &optional replace)
"Add a line to the end of the Notes field of the BBDB record
corresponding to the sender of this message. If REPLACE is non-nil,
replace the existing notes entry (if any)."
(list (if bbdb-readonly-p
(error "The Insidious Big Brother Database is read-only.")
(read-string "Comments: "))))
(let ((record (or (bbdb/vm-update-record t) (error "unperson"))))
(bbdb-annotate-notes record string 'notes replace)))
(defun bbdb/vm-edit-notes (&optional arg)
"Edit the notes field or (with a prefix arg) a user-defined field
of the BBDB record corresponding to the sender of this message."
(let ((record (or (bbdb/vm-update-record t) (error "unperson"))))
(bbdb-display-records (list record))
(bbdb-record-edit-property record nil t)
(bbdb-record-edit-notes record t))))
(defun bbdb/vm-show-records (&optional address-class)
"Display the contents of the BBDB for the sender of this message.
This buffer will be in bbdb-mode, with associated keybindings."
(list (assoc address-class bbdb-get-addresses-headers))
;; should we move this to bbdb/vm-show-sender?
(setq records (bbdb/vm-update-records t))
(defun bbdb/vm-show-all-recipients ()
"Show all recipients of this message. Counterpart to `bbdb/vm-show-sender'."
(defun bbdb/vm-show-sender (&optional show-recipients)
"Display the contents of the BBDB for the senders of this message.
With a prefix argument show the recipients instead,
with two prefix arguments show all records.
This buffer will be in `bbdb-mode', with associated keybindings."
(cond ((= 4 show-recipients)
((= 16 show-recipients)
(if (null (bbdb/vm-show-records 'authors))
(defun bbdb/vm-pop-up-bbdb-buffer (&optional offer-to-create)
"Make the *BBDB* buffer be displayed along with the VM window(s).
Displays the records corresponding to the sender respectively
recipients of the current message.
See `bbdb/vm-get-addresses-headers' and 'bbdb-get-only-first-address-p' for
configuration of what is being displayed."
(let ((bbdb-gag-messages t)
(records (bbdb/vm-update-records offer-to-create))
(when (and bbdb-use-pop-up records)
(function (lambda (w)
(let ((b (current-buffer)))
(set-buffer (window-buffer w))
(prog1 (eq major-mode 'vm-mode)
;; Always update the records; if there are no records, empty the
;; BBDB window. This should be generic, not VM-specific.
(bbdb-display-records records bbdb-pop-up-display-layout))
(when (not records)
(if (get-buffer-window bbdb-buffer-name)
(delete-window (get-buffer-window bbdb-buffer-name)))))))
;; By Alastair Burt <firstname.lastname@example.org>
;; vm 5.40 and newer support a new summary format, %U<letter>, to call
;; a user-provided function. Use "%-17.17UB" instead of "%-17.17F" to
;; have your VM summary buffers display BBDB's idea of the sender's full
;; name instead of the name (or lack thereof) in the message itself.
(defun vm-summary-function-B (m &optional to-p)
"Given a VM message returns the BBDB name of the sender.
(if (and vm-summary-uninteresting-senders (not to-p))
(let ((case-fold-search nil))
(if (string-match vm-summary-uninteresting-senders (vm-su-from m))
(vm-summary-function-B m t))
(or (bbdb/vm-alternate-full-name (vm-su-from m))
(or (bbdb/vm-alternate-full-name (if to-p (vm-su-to m) (vm-su-from m)))
(if to-p (vm-su-to-names m) (vm-su-full-name m))))))
(defun bbdb/vm-alternate-full-name (address)
(let ((entry (bbdb-search-simple
(if (and address bbdb-canonicalize-net-hook)
(or (bbdb-record-getprop entry 'mail-name)
;; From: Mark Thomas <email@example.com>
;; Subject: auto-folder-alist from bbdb
(defcustom bbdb/vm-set-auto-folder-alist-field 'vm-folder
"*The field which `bbdb/vm-set-auto-folder-alist' searches for."
(defun bbdb/vm-set-auto-folder-alist ()
"Create a `vm-auto-folder-alist' according to the records in the bbdb.
For each record that has a 'vm-folder' attribute, add an
\(email-regexp . folder) element to the `vm-auto-folder-alist'.
The element gets added to the 'element-name' sublist of the
The car of the element consists of all the email addresses for the
bbdb record concatenated with OR; the cdr is the value of the
If the first character of vm-folders value is a quote (') it will be
parsed a lisp expression and consequently one may do his own tweaks
in order to get a nice folder name.
The only processing this defun does to the email address is to
`regexp-quote' it; if your email circle is small enough, you could
consider using just the user part of the email address --- the part
before the @."
(let* (;; we add the email-address/vm-folder-name pair to this
;; sublist of the vm-auto-folder-alist variable
;; grab the folder list from the vm-auto-folder-alist
(folder-list (assoc element-name vm-auto-folder-alist))
;; the raw-notes and vm-folder attributes of the current bbdb
;; a regexp matching all the email addresses from the bbdb
;; create the folder-list in vm-auto-folder-alist if it doesn't exist
(setq vm-auto-folder-alist (append vm-auto-folder-alist
(list (list element-name)))
folder-list (assoc element-name vm-auto-folder-alist)))
(dolist (record (bbdb-records))
(setq notes-field (bbdb-record-raw-notes record))
(when (and (listp notes-field)
(setq folder (cdr (assq bbdb/vm-set-auto-folder-alist-field
;; quote all the email addresses for the record and join them
;; with OR
(setq email-regexp (mapconcat '(lambda (addr)
(bbdb-record-net record) "\\|"))
(unless (or (zerop (length email-regexp))
(assoc email-regexp folder-list))
;; be careful: nconc modifies the list in place
(if (equal (elt folder 0) ?\')
(setq folder (read folder)))
(nconc folder-list (list (cons email-regexp folder))))))))
;;; Howard Melman, contributed Jun 16 2000
(defcustom bbdb/vm-auto-add-label-list nil
"*List used by `bbdb/vm-auto-add-label' to automatically label messages.
Each element in the list is either a string or a list of two strings.
If a single string then it is used as both the field value to check for
and the label to apply to the message. If a list of two strings, the first
is the field value to search for and the second is the label to apply."
(defcustom bbdb/vm-auto-add-label-field bbdb-define-all-aliases-field
"*Fields used by `bbdb/vm-auto-add-label' to automatically label messages.
Value is either a single symbol or a list of symbols of bbdb fields that
`bbdb/vm-auto-add-label' uses to check for labels to apply to messages.
Defaults to `bbdb-define-all-aliases-field' which is typically `mail-alias'."
:type '(choice symbol list))
(defun bbdb/vm-auto-add-label (record)
"Automatically add labels to messages based on the mail-alias field.
Add this to `bbdb-notice-hook' and if using VM each message that bbdb
notices will be checked. If the sender has a value in the
bbdb/vm-auto-add-label-field in their BBDB record that
matches a value in `bbdb/vm-auto-add-label-list' then a VM
label will be added to the message.
This works great when `bbdb-user-mail-names' is set. As a result
mail that you send to people (and copy yourself on) is labeled as well.
This is how you hook it in.
;; (add-hook 'bbdb-notice-hook 'bbdb/vm-auto-add-label)
(let (field aliases sep)
(and (eq major-mode 'vm-mode)
(setq field (bbdb-record-getprop record x))
(setq sep (or (get x 'field-separator) ","))
(setq aliases (append aliases (bbdb-split field sep)))))
(cond ((listp bbdb/vm-auto-add-label-field)
(t (error "Bad value for bbdb/vm-auto-add-label-field"))
(mapconcat #'(lambda (l)
(cond ((stringp l)
(if (member l aliases)
((and (consp l)
(stringp (car l))
(stringp (cdr l)))
(if (member (car l) aliases)
(error "Malformed bbdb/vm-auto-add-label-list")
;;; Automatically add a record for replies.
;;; Contributed by Robert Fenk, 27 Oct 2000. It only took me 8 months to put
;;; it in the source...
;;; (add-hook 'vm-reply-hook 'bbdb/vm-force-create) to enable it. You could
;;; presumably hook it elsewhere as well.
(defun bbdb/vm-force-create ()
"Force automatic adding of a bbdb entry for current message."
(let ((bbdb/mail-auto-create-p t)
(defun bbdb-insinuate-vm ()
"Call this function to hook BBDB into VM."
(cond ((boundp 'vm-select-message-hook) ; VM 5.36+
(add-hook 'vm-select-message-hook 'bbdb/vm-pop-up-bbdb-buffer))
((boundp 'vm-show-message-hook) ; VM 5.32.L+
(add-hook 'vm-show-message-hook 'bbdb/vm-pop-up-bbdb-buffer))
(error "vm versions older than 5.36 no longer supported")))
(define-key vm-mode-map ":" 'bbdb/vm-show-sender)
;; (define-key vm-mode-map "'" 'bbdb/vm-show-all-recipients) ;; not yet
(define-key vm-mode-map ";" 'bbdb/vm-edit-notes)
(define-key vm-mode-map "/" 'bbdb)
;; VM used to inherit from mail-mode-map, so bbdb-insinuate-sendmail
;; did this. Kyle, you loser.
(if (boundp 'vm-mail-mode-map)
(define-key vm-mail-mode-map "\M-\t" 'bbdb-complete-name)))