summaryrefslogtreecommitdiff
path: root/lisp
diff options
context:
space:
mode:
Diffstat (limited to 'lisp')
-rw-r--r--lisp/.gitignore2
-rw-r--r--lisp/Makefile.in194
-rw-r--r--lisp/bbdb-com.el3746
-rw-r--r--lisp/bbdb-ftp.el201
-rw-r--r--lisp/bbdb-gnus.el835
-rw-r--r--lisp/bbdb-gui.el530
-rw-r--r--lisp/bbdb-hooks.el713
-rw-r--r--lisp/bbdb-merge.el264
-rw-r--r--lisp/bbdb-mhe.el225
-rw-r--r--lisp/bbdb-migrate.el413
-rw-r--r--lisp/bbdb-print.el672
-rw-r--r--lisp/bbdb-reportmail.el107
-rw-r--r--lisp/bbdb-rmail.el202
-rw-r--r--lisp/bbdb-sc.el209
-rw-r--r--lisp/bbdb-snarf.el599
-rw-r--r--lisp/bbdb-srv.el285
-rw-r--r--lisp/bbdb-vm.el426
-rw-r--r--lisp/bbdb-w3.el61
-rw-r--r--lisp/bbdb-whois.el264
-rw-r--r--lisp/bbdb-xemacs.el114
-rw-r--r--lisp/bbdb.el3873
21 files changed, 13935 insertions, 0 deletions
diff --git a/lisp/.gitignore b/lisp/.gitignore
new file mode 100644
index 0000000..2aee78a
--- /dev/null
+++ b/lisp/.gitignore
@@ -0,0 +1,2 @@
+/Makefile
+/bbdb-autoloads.el
diff --git a/lisp/Makefile.in b/lisp/Makefile.in
new file mode 100644
index 0000000..80d620b
--- /dev/null
+++ b/lisp/Makefile.in
@@ -0,0 +1,194 @@
+@SET_MAKE@
+
+INSTALL = @INSTALL@
+INSTALL_PROGRAM = @INSTALL_PROGRAM@
+INSTALL_SCRIPT = @INSTALL_SCRIPT@
+INSTALL_DATA = @INSTALL_DATA@
+
+RM = @RM@
+LN_S = @LN_S@
+
+EMACS_PROG = @EMACS_PROG@ -no-site-file -no-init-file
+EMACS_FLAVOR = @EMACS_FLAVOR@
+
+GNUSDIR = @GNUSDIR@
+MHEDIR = @MHEDIR@
+VMDIR = @VMDIR@
+OTHERDIRS = @OTHERDIRS@
+
+PACKAGEDIR = @PACKAGEDIR@
+SYMLINKS = @SYMLINKS@
+LINKPATH = @LINKPATH@
+
+# this is lovely, isn't it? Surprisingly enough, it seems to work...
+VM = -eval '(if (> (length "$(VMDIR)") 0) \
+ (setq load-path (cons "$(VMDIR)" load-path)))'
+
+GNUS = -eval '(if (> (length "$(GNUSDIR)") 0) \
+ (setq load-path (cons "$(GNUSDIR)" load-path)))'
+
+MHE = -eval '(if (> (length "$(MHEDIR)") 0) \
+ (setq load-path (cons "$(MHEDIR)" load-path)))'
+
+PUSHPATH= -eval "`\
+ dir=\". $(OTHERDIRS)\"; \
+ echo \(setq load-path \(append \(list ; \
+ for i in $$dir ; do \
+ echo \(expand-file-name \\"$$i\\"\)\ ; \
+ done ;\
+ echo \) load-path\)\) ; \
+ `"
+
+.SUFFIXES: .elc .el .tar .Z .gz .uu
+
+DEPSRCS= bbdb-com.el bbdb-hooks.el bbdb-gnus.el bbdb-mhe.el \
+ bbdb-rmail.el bbdb-vm.el bbdb-ftp.el bbdb-whois.el \
+ bbdb-print.el bbdb-srv.el bbdb-reportmail.el \
+ bbdb-merge.el bbdb-migrate.el bbdb-gui.el
+
+ifeq ($(EMACS_FLAVOR),xemacs)
+DEPSRCS+= bbdb-xemacs.el
+endif
+
+DEPBINS= ${DEPSRCS:.el=.elc}
+SRCS= bbdb.el $(DEPSRCS)
+BINS= bbdb.elc $(DEPBINS)
+
+all: Makefile @BBDB_RMAIL@ @BBDB_GNUS@ @BBDB_VM@ @BBDB_MHE@ bbdb autoloadsc
+
+Makefile: Makefile.in
+ cd ..; ./config.status
+
+install-pkg: uninstall-pkg bbdb autoloadsc
+ @if test "x$(SYMLINKS)" = "xno" ; then \
+ mkdir -p -m 0755 $(PACKAGEDIR)/lisp/bbdb; \
+ for i in `ls *.elc` ; do \
+ $(INSTALL_DATA) `echo $$i | sed 's/c$$//g'` \
+ $(PACKAGEDIR)/lisp/bbdb ; \
+ $(INSTALL_DATA) $$i $(PACKAGEDIR)/lisp/bbdb ; \
+ done ; \
+ else \
+ if test "x$(LINKPATH)" = "x" ; then \
+ $(LN_S) `pwd` $(PACKAGEDIR)/lisp/bbdb ; \
+ else \
+ $(LN_S) $(LINKPATH)/lisp $(PACKAGEDIR)/lisp/bbdb ; \
+ fi ; \
+ fi
+
+uninstall-pkg:
+ -$(RM) -r $(PACKAGEDIR)/lisp/bbdb
+
+bbdb-autoloads.el: $(DEPSRCS)
+ @-$(RM) $@;
+ @echo "(provide 'bbdb-autoloads)" > $@;
+ @echo "(eval-when-compile" >> $@;
+ @echo " (condition-case ()" >> $@;
+ @echo " (require 'custom)" >> $@;
+ @echo " (error nil))" >> $@;
+ @echo " (if (and (featurep 'custom) (fboundp 'custom-declare-variable))()" >> $@;
+ @echo " (defmacro defgroup (&rest args)" >> $@;
+ @echo " nil)" >> $@;
+ @echo " (defmacro defcustom (var value doc &rest args)" >> $@;
+ @echo " \`(defvar ,var ,value ,doc))" >> $@;
+ @echo " (defmacro defface (var value doc &rest args)" >> $@;
+ @echo " \`(make-face ,var))" >> $@;
+ @echo " (defmacro define-widget (&rest args)" >> $@;
+ @echo " nil)))" >> $@;
+ @echo " " >> $@;
+ $(EMACS_PROG) -batch -q -l autoload \
+ --eval '(setq generated-autoload-file "'`pwd`'/$@")' \
+ --eval "(if (featurep 'xemacs) (delete-file generated-autoload-file))" \
+ --eval '(setq make-backup-files nil)' \
+ --eval '(setq autoload-package-name "bbdb")' \
+ -f batch-update-autoloads `pwd`
+
+bbdb-autoloads.elc: bbdb-autoloads.el
+ $(EMACS_PROG) -batch -q -f batch-byte-compile ./$^
+
+bbdb.elc: bbdb.el
+bbdb-com.elc: bbdb.elc bbdb-com.el
+bbdb-ftp.elc: bbdb.elc bbdb-ftp.el
+bbdb-gui.elc: bbdb.elc bbdb-gui.el
+bbdb-merge.elc: bbdb-merge.el
+bbdb-migrate.elc: bbdb.elc bbdb-migrate.el
+bbdb-print.elc: bbdb.elc bbdb-print.el
+bbdb-snarf.elc: bbdb.elc bbdb-snarf.el
+bbdb-whois.elc: bbdb.elc bbdb-whois.el
+bbdb-w3.elc: bbdb.elc bbdb-w3.el
+bbdb-xemacs.elc: bbdb.elc bbdb-xemacs.el
+
+.el.elc:
+ $(EMACS_PROG) -batch -q $(PUSHPATH) -l ./bbdb.elc -f batch-byte-compile $<
+
+bbdb.elc: bbdb.el
+ $(EMACS_PROG) -batch -q -f batch-byte-compile ./bbdb.el
+
+bbdb-gnus.elc: bbdb.elc bbdb-gnus.el
+ $(EMACS_PROG) -batch -q $(PUSHPATH) -l ./bbdb.elc $(GNUS) \
+ -f batch-byte-compile $(@:.elc=.el)
+bbdb-mhe.elc: bbdb.elc bbdb-mhe.el
+ $(EMACS_PROG) -batch -q $(PUSHPATH) -l ./bbdb.elc $(MHE) \
+ -f batch-byte-compile $(@:.elc=.el)
+bbdb-rmail.elc: bbdb.elc bbdb-rmail.el
+ $(EMACS_PROG) -batch -q $(PUSHPATH) -l ./bbdb.elc $(RMAIL) \
+ -f batch-byte-compile $(@:.elc=.el)
+bbdb-vm.elc: bbdb.elc bbdb-vm.el
+ $(EMACS_PROG) -batch -q $(PUSHPATH) -l ./bbdb.elc $(VM) \
+ -f batch-byte-compile $(@:.elc=.el)
+
+bbdb-srv.elc: bbdb.elc bbdb-srv.el
+ $(EMACS_PROG) -batch -q $(PUSHPATH) -l ./bbdb.elc -eval '(progn (or (fboundp (quote define-obsolete-variable-alias)) (if (locate-library "gnuserv-compat") (load "gnuserv-compat" t t))) (if (and (locate-library "gnuserv") (locate-library "itimer")) (byte-compile-file "bbdb-srv.el") (message "Optional package bbdb-srv skipped - gnuserv not found")))'
+
+bbdb-reportmail.elc: bbdb.elc bbdb-reportmail.el
+ $(EMACS_PROG) -batch -q $(PUSHPATH) -l ./bbdb.elc -eval '(if (locate-library "reportmail") (byte-compile-file "bbdb-reportmail.el") (message "Optional package bbdb-reportmail skipped - reportmail not found"))'
+
+bbdb-sc.elc: bbdb.elc bbdb-sc.el
+ $(EMACS_PROG) -batch -q $(PUSHPATH) -l ./bbdb.elc -eval '(if (locate-library "supercite") (byte-compile-file "bbdb-sc.el") (message "Optional package bbdb-sc skipped - supercite not found"))'
+
+# bbdb-hooks uses VM macros if it can find VM.
+
+bbdb-hooks.elc: bbdb.elc bbdb-hooks.el
+ $(EMACS_PROG) -batch -q $(PUSHPATH) -l ./bbdb.elc \
+ -eval "(and (not (string= \"$(VMDIR)\" \"\")) \
+ (setq load-path (cons \"$(VMDIR)\" load-path)) \
+ (load \"vm\" t t) \
+ (load \"vm-vars\" t t))" \
+ -f batch-byte-compile $(@:.elc=.el)
+
+autoloads: bbdb-autoloads.el
+
+autoloadsc: bbdb-autoloads.elc
+
+extras:: bbdb-print.elc bbdb-ftp.elc bbdb-whois.elc \
+ @BBDB_SRV@ @BBDB_REPORTMAIL@ bbdb-snarf.elc bbdb-w3.elc \
+ @BBDB_SC@ bbdb-merge.elc bbdb-migrate.elc bbdb-gui.elc
+ifeq ($(EMACS_FLAVOR),xemacs)
+extras:: bbdb-xemacs.elc
+endif
+
+bbdb: bbdb.elc bbdb-com.elc bbdb-hooks.elc autoloadsc extras
+
+rmail: bbdb bbdb-rmail.elc
+
+vm: bbdb bbdb-vm.elc
+
+mhe: bbdb bbdb-mhe.elc
+
+gnus: bbdb bbdb-gnus.elc
+
+# aliases
+mh: mhe
+mh-e: mhe
+
+# Assorted clean-up targets
+clean:
+ -$(RM) bbdb*.elc
+
+distclean: clean
+
+# Backward compatibility
+reallyclean: distclean
+
+cvsclean: distclean
+ -$(RM) bbdb-autoloads.el # Generated file
+ -$(RM) Makefile
diff --git a/lisp/bbdb-com.el b/lisp/bbdb-com.el
new file mode 100644
index 0000000..1939bd7
--- /dev/null
+++ b/lisp/bbdb-com.el
@@ -0,0 +1,3746 @@
+;;; -*- Mode:Emacs-Lisp -*-
+
+;;; This file is part of the Insidious Big Brother Database (aka BBDB),
+;;; copyright (c) 1991, 1992, 1993 Jamie Zawinski <jwz@netscape.com>.
+;;; It contains most of the user-level interactive commands for BBDB.
+;;; 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 2, 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
+;;; details.
+;;;
+;;; 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.
+
+(require 'cl)
+(require 'bbdb)
+;;(require 'bbdb-snarf) causes recursive compile, which I should fix.
+
+;; ARGH. fmh, dammit.
+(require
+ (eval-and-compile
+ (if (locate-library "mailabbrev")
+ (quote mailabbrev)
+ (quote mail-abbrevs))))
+
+;; compiler placating.
+;; not sure BBDB runs on anything old enough to use auto-fill-hook, mind.
+(eval-and-compile
+ (if (boundp 'auto-fill-function)
+ (fset 'bbdb-auto-fill-function 'auto-fill-function)
+ (fset 'bbdb-auto-fill-function 'auto-fill-hook))
+
+ (autoload 'mh-send "mh-e")
+ (autoload 'vm-session-initialization "vm-startup")
+ (autoload 'vm-mail-internal "vm-reply")
+ (autoload 'vm-mail "vm")
+ (autoload 'mew-send "mew")
+ (autoload 'bbdb-header-start "bbdb-hooks")
+ (autoload 'bbdb-extract-field-value "bbdb-hooks")
+ (autoload 'bbdb-fontify-buffer "bbdb-gui")
+ (autoload 'Info-goto-node "info")
+ ;; this is very unpleasant, but saves me doing a lot of rewriting
+ ;; for now. a big cleanup will happen for the next release, maybe.
+ ;; NB if emacs 21 or older emacsen or even things you bolt on have
+ ;; any of these functions, bad things will happen. Again, FITNR.
+ (if (featurep 'xemacs)
+ (progn
+ (fset 'bbdb-extent-string 'extent-string)
+ (fset 'bbdb-display-message 'display-message)
+ (fset 'bbdb-event-to-character 'event-to-character))
+ (fset 'bbdb-extent-string 'ignore)
+ (fset 'bbdb-display-message 'ignore)
+ (fset 'bbdb-event-to-character 'ignore)))
+
+(defvar bbdb-define-all-aliases-needs-rebuilt nil)
+
+(defcustom bbdb-extract-address-components-func
+ 'bbdb-rfc822-addresses
+ "Function called to parse one or more email addresses.
+See bbdb-extract-address-components for an example."
+ :group 'bbdb-noticing-records
+ :type 'function)
+
+(defcustom bbdb-default-country
+ '"Emacs";; what do you mean, it's not a country?
+ "*Default country to use if none is specified."
+ :group 'bbdb-record-creation
+ :type 'string) ;; wonder if there's a smart place to get this? TZ, maybe?
+
+(defmacro bbdb-grovel-elide-arg (arg)
+ (list 'if arg
+ (list 'not (list 'eq arg 0))
+ 'bbdb-display-layout))
+
+(defvar bbdb-search-invert nil
+ "Bind this variable to t in order to invert the result of `bbdb-search'.
+
+\(let ((bbdb-search-invert t))
+ \(bbdb-search records foo foo))")
+
+(defun bbdb-search-invert-p ()
+ "Return `bbdb-search-invert' and set it to nil.
+To set it on again, use `bbdb-search-invert-set'."
+ (let ((result bbdb-search-invert))
+ (setq bbdb-search-invert nil)
+ result))
+
+;;;###autoload
+(defun bbdb-search-invert-set ()
+ "Typing \\<bbdb-mode-map>\\[bbdb-search-invert-set] inverts the meaning of the next search command.
+Sets `bbdb-search-invert' to t.
+You will have to call this function again, if you want to
+do repeated inverted searches."
+ (interactive)
+ (setq bbdb-search-invert t)
+ (message (substitute-command-keys
+ "\\<bbdb-mode-map>\\[bbdb-search-invert-set] - ")))
+
+(defmacro bbdb-search (records &optional name company net notes phone)
+ "Search RECORDS for optional arguments NAME, COMPANY, NET, NOTES, PHONE.
+This macro only emits code for those things being searched for;
+literal nils at compile-time cause no code to be emitted.
+
+If you want to reverse the search, bind `bbdb-search-invert' to t."
+ (let (clauses)
+ ;; I didn't protect these vars from multiple evaluation because that
+ ;; actually generates *less efficient code* in elisp, because the extra
+ ;; bindings can't easily be optimized away without lexical scope. fmh.
+ (or (stringp name) (symbolp name) (error "name must be atomic"))
+ (or (stringp company) (symbolp company) (error "company must be atomic"))
+ (or (stringp net) (symbolp net) (error "net must be atomic"))
+ (or (stringp notes) (symbolp notes) (error "notes must be atomic"))
+ (or (stringp phone) (symbolp phone) (error "phone must be atomic"))
+ (if phone
+ (setq clauses
+ (cons
+ `(let ((rest-of-phones (bbdb-record-phones record))
+ (done nil))
+ (if rest-of-phones
+ (while (and rest-of-phones (not done))
+ (setq done (string-match ,phone
+ ;; way way wasteful...
+ (bbdb-phone-string
+ (car rest-of-phones)))
+ rest-of-phones (cdr rest-of-phones)))
+ ;; so that "^$" can be used to find entries that
+ ;; have no phones
+ (setq done (string-match ,phone "")))
+ done)
+ clauses)))
+ (if notes
+ (setq clauses
+ (cons
+ (` (if (stringp (, notes))
+ (string-match (, notes)
+ (or (bbdb-record-notes record) ""))
+ (if (eq (car (, notes)) '*)
+ (let ((fields all-fields) done tmp)
+ (if (bbdb-record-raw-notes record)
+ (while (and (not done) fields)
+ (setq tmp (bbdb-record-getprop
+ record (car fields))
+ done (and tmp (string-match
+ (cdr (, notes))
+ tmp))
+ fields (cdr fields)))
+ ;; so that "^$" can be used to find entries that
+ ;; have no notes
+ (setq done (string-match (cdr (, notes)) "")))
+ done)
+ (string-match (cdr (, notes))
+ (or (bbdb-record-getprop
+ record (car (, notes))) "")))))
+ clauses)))
+ (if name
+ (setq clauses
+ (append
+ (` ((string-match (, name) (or (bbdb-record-name record) ""))
+ (let ((rest-of-aka (bbdb-record-aka record))
+ (done nil))
+ (while (and rest-of-aka (not done))
+ (setq done (string-match (, name) (car rest-of-aka))
+ rest-of-aka (cdr rest-of-aka)))
+ done)))
+ clauses)))
+ (if net
+ (setq clauses
+ (cons
+ (` (let ((rest-of-nets (bbdb-record-net record))
+ (done nil))
+ (if rest-of-nets
+ (while (and rest-of-nets (not done))
+ (setq done (string-match (, net) (car rest-of-nets))
+ rest-of-nets (cdr rest-of-nets)))
+ ;; so that "^$" can be used to find entries that
+ ;; have no net addresses.
+ (setq done (string-match (, net) "")))
+ done))
+ clauses)))
+ (if company
+ (setq clauses
+ (cons
+ (` (string-match (, company)
+ (or (bbdb-record-company record) "")))
+ clauses)))
+
+ (` (let ((matches '())
+ (,@ (if notes
+ '((all-fields (cons 'notes
+ (mapcar (lambda (x) (intern (car x)))
+ (bbdb-propnames)))))
+ nil))
+ (case-fold-search bbdb-case-fold-search)
+ (records (, records))
+ (invert (bbdb-search-invert-p))
+ record)
+ (while records
+ (setq record (car records))
+ (if (or (and invert
+ (not (or (,@ clauses))))
+ (and (not invert)
+ (or (,@ clauses))))
+ (setq matches (cons record matches)))
+ (setq records (cdr records)))
+ (nreverse matches)))))
+
+(defun bbdb-search-prompt (prompt &rest rest)
+ (if (string-match "%m" prompt)
+ (setq prompt (replace-match (if bbdb-search-invert
+ "not matching"
+ "matching")
+ nil nil prompt)))
+ (read-string (apply 'format prompt rest)))
+
+;;;###autoload
+(defun bbdb (string elidep)
+ "Display all entries in the BBDB matching the regexp STRING
+in either the name(s), company, network address, or notes."
+ (interactive
+ (list (bbdb-search-prompt "Search records %m regexp: ")
+ current-prefix-arg))
+ (let* ((bbdb-display-layout (bbdb-grovel-elide-arg elidep))
+ (notes (cons '* string))
+ (records
+ (bbdb-search (bbdb-records) string string string notes
+ nil)))
+ (if records
+ (bbdb-display-records records)
+ ;; we could use error here, but it's not really an error.
+ (message "No records matching '%s'" string))))
+
+;;;###autoload
+(defun bbdb-name (string elidep)
+ "Display all entries in the BBDB matching the regexp STRING in the name
+\(or ``alternate'' names\)."
+ (interactive
+ (list (bbdb-search-prompt "Search records with names %m regexp: ")
+ current-prefix-arg))
+ (let ((bbdb-display-layout (bbdb-grovel-elide-arg elidep)))
+ (bbdb-display-records (bbdb-search (bbdb-records) string))))
+
+;;;###autoload
+(defun bbdb-company (string elidep)
+ "Display all entries in BBDB matching STRING in the company field."
+ (interactive
+ (list (bbdb-search-prompt "Search records with company %m regexp: ")
+ current-prefix-arg))
+ (let ((bbdb-display-layout (bbdb-grovel-elide-arg elidep)))
+ (bbdb-display-records (bbdb-search (bbdb-records) nil string))))
+
+;;;###autoload
+(defun bbdb-net (string elidep)
+ "Display all entries in BBDB matching regexp STRING in the network address."
+ (interactive
+ (list (bbdb-search-prompt "Search records with net address %m regexp: ")
+ current-prefix-arg))
+ (let ((bbdb-display-layout (bbdb-grovel-elide-arg elidep)))
+ (bbdb-display-records (bbdb-search (bbdb-records) nil nil string))))
+
+;;;###autoload
+(defun bbdb-notes (which string elidep)
+ "Display all entries in BBDB matching STRING in the named notes field."
+ (interactive
+ (let (field)
+ (list (setq field (completing-read "Notes field to search (RET for all): "
+ (append '(("notes")) (bbdb-propnames))
+ nil t))
+ (bbdb-search-prompt "Search records with %s %m regexp: "
+ (if (string= field "")
+ "one field"
+ field))
+ current-prefix-arg)))
+ (let ((bbdb-display-layout (bbdb-grovel-elide-arg elidep))
+ (notes (if (string= which "")
+ (cons '* string)
+ (cons (intern which) string))))
+ (bbdb-display-records (bbdb-search (bbdb-records) nil nil nil notes))))
+
+(defun bbdb-phones (string elidep)
+ "Display all entries in BBDB matching the regexp STRING in the phones field."
+ (interactive
+ (list (bbdb-search-prompt "Search records with phone %m regexp: ")
+ current-prefix-arg))
+ (let ((bbdb-display-layout (bbdb-grovel-elide-arg elidep)))
+ (bbdb-display-records
+ (bbdb-search (bbdb-records) nil nil nil nil string))))
+
+;;;###autoload
+(defun bbdb-changed (elidep)
+ "Display all entries in the bbdb database which have been changed since
+the database was last saved."
+ (interactive "P")
+ (let ((bbdb-display-layout (bbdb-grovel-elide-arg elidep))
+ (changed-records (bbdb-with-db-buffer bbdb-changed-records)))
+ (if (bbdb-search-invert-p)
+ (let ((recs (bbdb-records))
+ unchanged-records
+ r)
+ (while recs
+ (setq r (car recs)
+ recs (cdr recs))
+ (when (not (member r changed-records))
+ (setq changed-records (delete r changed-records)
+ unchanged-records (cons r unchanged-records))))
+ (bbdb-display-records unchanged-records))
+ (bbdb-display-records changed-records))))
+
+(defun bbdb-display (records)
+ "Prompts for and displays a single record (this is faster than searching.)"
+ (interactive (list (bbdb-completing-read-record "Display record of: ")))
+ (bbdb-display-records records))
+
+(defun bbdb-display-some (function)
+ "Display records according to FUNCTION. FUNCTION is called with one
+argument, the record, and should return nil if the record is not to be
+displayed. If the record is to be displayed, it (the record) should
+be returned."
+ (bbdb-display-records (delq nil (mapcar function (bbdb-records)))))
+
+;;; fancy redisplay
+
+;;;###autoload
+(defun bbdb-redisplay-records ()
+ "Regrinds the contents of the *BBDB* buffer, without scrolling.
+If possible, you should call `bbdb-redisplay-one-record' instead."
+ (let ((p (point))
+ (m (condition-case nil (mark) (error nil))))
+ (goto-char (window-start))
+ (let ((p2 (point)))
+ (bbdb-display-records-1 bbdb-records)
+ (goto-char p2)
+ (if m (set-mark m)))
+ (recenter 0)
+ (goto-char p)
+ (save-excursion
+ (run-hooks 'bbdb-list-hook))))
+
+(defun bbdb-redisplay-one-record (record &optional record-cons next-record-cons
+ delete-p)
+ "Regrind one record. The *BBDB* buffer must be current when this is called."
+ (bbdb-debug (if (not (eq (not (not delete-p))
+ (not (not (bbdb-record-deleted-p record)))))
+ (error "splorch.")))
+ (if (null record-cons) (setq record-cons (assq record bbdb-records)))
+ (if (null next-record-cons)
+ (setq next-record-cons (car (cdr (memq record-cons bbdb-records)))))
+ (if (null record-cons)
+ (bbdb-display-records (list record) nil t)
+ (let ((position (point))
+ (marker (nth 2 record-cons))
+ next-marker
+ (buffer-read-only nil))
+ (bbdb-debug
+ (if (null record-cons) (error "doubleplus ungood: record unexists!"))
+ (if (null marker) (error "doubleplus ungood: marker unexists!")))
+ (beginning-of-line)
+ (goto-char marker)
+ (remove-text-properties marker (or (nth 2 next-record-cons) (point-max))
+ '(bbdb-field nil))
+ (if delete-p nil
+ (bbdb-format-record (car record-cons) (car (cdr record-cons))))
+ (setq next-marker (or (nth 2 next-record-cons) (point-max)))
+ (delete-region (point) next-marker)
+ (if (< position next-marker)
+ (goto-char position))
+
+ (if (and bbdb-gui (not delete-p))
+ (bbdb-fontify-buffer (list record-cons
+ ;; the record ends here
+ (list nil nil next-marker))))
+ (save-excursion
+ (run-hooks 'bbdb-list-hook)))))
+
+;;; Parsing phone numbers
+;;; XXX this needs expansion to handle international prefixes properly
+;;; i.e. +353-number without discarding the +353 part. Problem being
+;;; that this will necessitate yet another change in the database
+;;; format for people who are using north american numbers.
+
+
+(defconst bbdb-phone-area-regexp "(?[ \t]*\\+?1?[ \t]*[-\(]?[ \t]*[-\(]?[ \t]*\\([2-9][0-9][0-9]\\)[ \t]*)?[-./ \t]*")
+(defconst bbdb-phone-main-regexp "\\([1-9][0-9][0-9]\\)[ \t]*[-.]?[ \t]*\\([0-9][0-9][0-9][0-9]\\)[ \t]*")
+
+(defconst bbdb-phone-ext-regexp "x?[ \t]*\\([0-9]+\\)[ \t]*")
+
+(defconst bbdb-phone-regexp-1 (concat "^[ \t]*" bbdb-phone-area-regexp bbdb-phone-main-regexp bbdb-phone-ext-regexp "$"))
+(defconst bbdb-phone-regexp-2 (concat "^[ \t]*" bbdb-phone-area-regexp bbdb-phone-main-regexp "$"))
+(defconst bbdb-phone-regexp-3 (concat "^[ \t]*" bbdb-phone-main-regexp bbdb-phone-ext-regexp "$"))
+(defconst bbdb-phone-regexp-4 (concat "^[ \t]*" bbdb-phone-main-regexp "$"))
+(defconst bbdb-phone-regexp-5 (concat "^[ \t]*" bbdb-phone-ext-regexp "$"))
+
+(defun bbdb-parse-phone-number (string &optional number-type)
+ "Parse a phone number from STRING and return a list of integers the form
+\(area-code exchange number) or (area-code exchange number extension).
+This is both lenient and strict in what it will parse - whitespace may
+appear (or not) between any of the groups of digits, parentheses around the
+area code are optional, as is a dash between the exchange and number, and
+a '1' preceeding the area code; but there must be three digits in the area
+code and exchange, and four in the number (if they are present). An error
+will be signalled if unparsable. All of these are unambigously parsable:
+
+ ( 415 ) 555 - 1212 x123 -> (415 555 1212 123)
+ (415)555-1212 123 -> (415 555 1212 123)
+ (1-415) 555-1212 123 -> (415 555 1212 123)
+ 1 (415)-555-1212 123 -> (415 555 1212 123)
+ 555-1212 123 -> (0 555 1212 123)
+ 555 1212 -> (0 555 1212)
+ 415 555 1212 -> (415 555 1212)
+ 1 415 555 1212 -> (415 555 1212)
+ 5551212 -> (0 555 1212)
+ 4155551212 -> (415 555 1212)
+ 4155551212123 -> (415 555 1212 123)
+ 5551212x123 -> (0 555 1212 123)
+ 1234 -> (0 0 0 1234)
+
+Note that \"4151212123\" is ambiguous; it could be interpreted either as
+\"(415) 121-2123\" or as \"415-1212 x123\".
+
+\(And uh, oh yeah, this does little if `bbdb-north-american-phone-numbers-p'
+is nil...\)"
+
+ (cond ((if number-type
+ (eq number-type 'euro)
+ (not bbdb-north-american-phone-numbers-p))
+ (list (bbdb-string-trim string)))
+ ((string-match bbdb-phone-regexp-1 string)
+ ;; (415) 555-1212 x123
+ (list (bbdb-subint string 1) (bbdb-subint string 2)
+ (bbdb-subint string 3) (bbdb-subint string 4)))
+ ((string-match bbdb-phone-regexp-2 string)
+ ;; (415) 555-1212
+ (list (bbdb-subint string 1) (bbdb-subint string 2)
+ (bbdb-subint string 3)))
+ ((string-match bbdb-phone-regexp-3 string)
+ ;; 555-1212 x123
+ (list 0 (bbdb-subint string 1) (bbdb-subint string 2)
+ (bbdb-subint string 3)))
+ ((string-match bbdb-phone-regexp-4 string)
+ ;; 555-1212
+ (list 0 (bbdb-subint string 1) (bbdb-subint string 2)))
+ ((string-match bbdb-phone-regexp-5 string)
+ ;; x123
+ (list 0 0 0 (bbdb-subint string 1)))
+ (t (error "phone number unparsable."))))
+
+;;; Parsing other things
+
+(defcustom bbdb-expand-mail-aliases t
+ "If non-nil, expand mail aliases in `bbdb-complete-name'."
+ :group 'bbdb-record-use
+ :type 'boolean)
+
+(defcustom bbdb-check-zip-codes-p t
+ "If non-nil, require legal zip codes when entering an address.
+The format of legal zip codes is determined by the variable
+`bbdb-legal-zip-codes'."
+ :group 'bbdb-record-creation
+ :type 'boolean)
+
+(defcustom bbdb-legal-zip-codes
+ '(;; empty string
+ "^$"
+ ;; Matches 1 to 6 digits.
+ "^[ \t\n]*[0-9][0-9]?[0-9]?[0-9]?[0-9]?[0-9]?[ \t\n]*$"
+ ;; Matches 5 digits and 3 or 4 digits.
+ "^[ \t\n]*\\([0-9][0-9][0-9][0-9][0-9]\\)[ \t\n]*-?[ \t\n]*\\([0-9][0-9][0-9][0-9]?\\)[ \t\n]*$"
+ ;; Match zip codes for Canada, UK, etc. (result is ("LL47" "U4B")).
+ "^[ \t\n]*\\([A-Za-z0-9]+\\)[ \t\n]+\\([A-Za-z0-9]+\\)[ \t\n]*$"
+ ;; Match zip codes for continental Europe. Examples "CH-8057"
+ ;; or "F - 83320" (result is ("CH" "8057") or ("F" "83320")).
+ ;; Support for "NL-2300RA" added at request from Carsten Dominik
+ ;; <dominik@astro.uva.nl>
+ "^[ \t\n]*\\([A-Z]+\\)[ \t\n]*-?[ \t\n]*\\([0-9]+ ?[A-Z]*\\)[ \t\n]*$"
+ ;; Match zip codes from Sweden where the five digits are grouped 3+2
+ ;; at the request from Mats Lofdahl <MLofdahl@solar.stanford.edu>.
+ ;; (result is ("SE" (133 36)))
+ "^[ \t\n]*\\([A-Z]+\\)[ \t\n]*-?[ \t\n]*\\([0-9]+\\)[ \t\n]+\\([0-9]+\\)[ \t\n]*$")
+ "List of regexps that match legal zip codes.
+Whether this is used at all depends on the variable `bbdb-check-zip-codes-p'."
+ :group 'bbdb-record-creation
+ :type '(repeat regexp))
+
+(defun bbdb-parse-zip-string (string)
+ "Check whether STRING is a legal zip code.
+Do this only if `bbdb-check-zip-codes-p' is non-nil."
+ (if (and bbdb-check-zip-codes-p
+ (not (memq t (mapcar (lambda (regexp)
+ ;; if it matches, (not (not index-of-match)) returns t
+ (not (not (string-match regexp string))))
+ bbdb-legal-zip-codes))))
+ (error "not a valid zip code.")
+ string))
+
+(defun bbdb-read-new-record ()
+ "Prompt for and return a completely new BBDB record.
+Doesn't insert it in to the database or update the hashtables, but does
+ensure that there will not be name collisions."
+ (bbdb-records) ; make sure database is loaded
+ (if bbdb-readonly-p
+ (error "The Insidious Big Brother Database is read-only."))
+ (let (firstname lastname)
+ (bbdb-error-retry
+ (progn
+ (if current-prefix-arg
+ (setq firstname (bbdb-read-string "First Name: ")
+ lastname (bbdb-read-string "Last Name: "))
+ (let ((names (bbdb-divide-name (bbdb-read-string "Name: "))))
+ (setq firstname (car names)
+ lastname (nth 1 names))))
+ (if (string= firstname "") (setq firstname nil))
+ (if (string= lastname "") (setq lastname nil))
+ (if (and bbdb-no-duplicates-p
+ (bbdb-gethash (bbdb-build-name firstname lastname)))
+ (error "%s %s is already in the database"
+ (or firstname "") (or lastname "")))))
+ (let ((company (bbdb-read-string "Company: "))
+ (net (bbdb-split (bbdb-read-string "Network Address: ") ","))
+ (addrs
+ (let (L L-tail str addr)
+ (while (not (string=
+ ""
+ (setq str
+ (bbdb-read-string
+ "Address Description [RET when no more]: "
+ ""
+ (mapcar (function (lambda(x) (list x)))
+ (bbdb-label-completion-list
+ "addresses"))))))
+ (setq addr (make-vector bbdb-address-length nil))
+ (bbdb-record-edit-address addr str)
+ (if L
+ (progn (setcdr L-tail (cons addr nil))
+ (setq L-tail (cdr L-tail)))
+ (setq L (cons addr nil)
+ L-tail L)))
+ L))
+ (phones
+ (let (L L-tail str)
+ (while (not (string=
+ ""
+ (setq str
+ (bbdb-read-string
+ "Phone Location [RET when no more]: "
+ ""
+ (mapcar (function (lambda(x) (list x)))
+ (bbdb-label-completion-list
+ "phones"))))))
+ (let* ((phonelist
+ (bbdb-error-retry
+ (bbdb-parse-phone-number
+ (read-string "Phone: "
+ (and (integerp bbdb-default-area-code)
+ (format "(%03d) "
+ bbdb-default-area-code))))))
+ (phone (apply 'vector str
+ (if (= 3 (length phonelist))
+ (nconc phonelist '(0))
+ phonelist))))
+ (if L
+ (progn (setcdr L-tail (cons phone nil))
+ (setq L-tail (cdr L-tail)))
+ (setq L (cons phone nil)
+ L-tail L))))
+ L))
+ (notes (bbdb-read-string "Additional Comments: ")))
+ (if (string= company "") (setq company nil))
+ (if (string= notes "") (setq notes nil))
+ (let ((record
+ (vector firstname lastname nil company phones addrs net notes
+ (make-vector bbdb-cache-length nil))))
+ record))))
+
+;;;###autoload
+(defun bbdb-create (record)
+ "Add a new entry to the bbdb database ; prompts for all relevant info
+using the echo area, inserts the new record in the db, sorted alphabetically,
+and offers to save the db file. DO NOT call this from a program. Call
+bbdb-create-internal instead."
+ (interactive (list (bbdb-read-new-record)))
+ (bbdb-invoke-hook 'bbdb-create-hook record)
+ (bbdb-change-record record t)
+ (bbdb-display-records (list record)))
+
+
+(defmacro bbdb-check-type (place predicate)
+ (list 'while (list 'not (list predicate place))
+ (nconc (cond ((eq (car-safe place) 'aref)
+ (list 'aset (nth 1 place) (nth 2 place)))
+ ((eq (car-safe place) 'car)
+ (list 'setcar (nth 1 place)))
+ ((eq (car-safe place) 'cdr)
+ (list 'setcdr (nth 1 place)))
+ (t (list 'setq place)))
+ (list
+ (list 'signal ''wrong-type-argument
+ (list 'list (list 'quote predicate) place))))))
+
+(defun bbdb-create-internal (name company net addrs phones notes)
+ "Adds a record to the database; this function does a fair amount of
+error-checking on the passed in values, so it's safe to call this from
+other programs.
+
+NAME is a string, the name of the person to add. An error is signalled
+if that name is already in use and `bbdb-no-duplicates-p' is t.
+COMPANY is a string or nil.
+NET is a comma-separated list of email addresses, or a list of strings.
+An error is signalled if that name is already in use.
+ADDRS is a list of address objects. An address is a vector of the form
+ [\"location\" (\"line1\" \"line2\" ... ) \"City\" \"State\" \"Zip\" \"Country\"].
+PHONES is a list of phone-number objects. A phone-number is a vector of
+the form
+ [\"location\" areacode prefix suffix extension-or-nil]
+or
+ [\"location\" \"phone-number\"]
+NOTES is a string, or an alist associating symbols with strings."
+ (let (firstname lastname aka)
+ (while (and (progn
+ (setq name (and name (bbdb-divide-name name))
+ firstname (car name)
+ lastname (nth 1 name))
+ (bbdb-gethash (bbdb-build-name firstname lastname)))
+ bbdb-no-duplicates-p)
+ (setq name (signal 'error
+ (list (format "%s %s is already in the database"
+ (or firstname "") (or lastname ""))))))
+ (and company (bbdb-check-type company stringp))
+ (if (stringp net)
+ (setq net (bbdb-split net ",")))
+ (if bbdb-no-duplicates-p
+ (let ((rest net))
+ (while rest
+ (while (bbdb-gethash (downcase (car rest)))
+ (setcar rest
+ (signal 'error (list (format
+ "%s is already in the database"
+ (car rest))))))
+ (setq rest (cdr rest)))))
+ (setq addrs
+ (mapcar
+ (lambda (addr)
+ (while (or (not (vectorp addr))
+ (/= (length addr) bbdb-address-length))
+ (setq addr (signal 'wrong-type-argument (list 'vectorp addr))))
+ (bbdb-check-type (aref addr 0) stringp) ;;; XXX use bbdb-addresses
+ (bbdb-check-type (aref addr 1) listp)
+ (bbdb-check-type (aref addr 2) stringp)
+ (bbdb-check-type (aref addr 3) stringp)
+ (bbdb-check-type (aref addr 4) stringp)
+ (bbdb-check-type (aref addr 5) stringp)
+ addr)
+ addrs))
+ (setq phones
+ (mapcar
+ (lambda (phone)
+ (while (or (not (vectorp phone))
+ (and (/= (length phone) 2)
+ (/= (length phone) bbdb-phone-length)))
+ (setq phone
+ (signal 'wrong-type-argument (list 'vectorp phone))))
+ (bbdb-check-type (aref phone 0) stringp)
+ (if (= 2 (length phone))
+ (bbdb-check-type (aref phone 1) stringp)
+ (bbdb-check-type (aref phone 1) integerp)
+ (bbdb-check-type (aref phone 2) integerp)
+ (bbdb-check-type (aref phone 3) integerp)
+ (and (aref phone 4) (bbdb-check-type (aref phone 4) integerp))
+ (if (eq 0 (aref phone 4)) (aset phone 4 nil)))
+ phone)
+ phones))
+ (or (stringp notes)
+ (setq notes
+ (mapcar (lambda (note)
+ (bbdb-check-type note consp)
+ (bbdb-check-type (car note) symbolp)
+ (if (consp (cdr note))
+ (setq note (cons (car note) (car (cdr note)))))
+ (bbdb-check-type (cdr note) stringp)
+ note)
+ notes)))
+ (let ((record
+ (vector firstname lastname aka company phones addrs net notes
+ (make-vector bbdb-cache-length nil))))
+ (bbdb-invoke-hook 'bbdb-create-hook record)
+ (bbdb-change-record record t)
+ record)))
+
+
+;;; bbdb-mode stuff
+
+(defun bbdb-current-record (&optional planning-on-modifying)
+ "Returns the record which the point is point at. In linear time, man..."
+ (if (and planning-on-modifying bbdb-readonly-p)
+ (error "The Insidious Big Brother Database is read-only."))
+ (if (not (equal bbdb-buffer-name (buffer-name (current-buffer))))
+ (error "this command only works while in the \"%s\" buffer."
+ bbdb-buffer-name))
+ (let ((p (point))
+ (rest bbdb-records)
+ (rec nil))
+ (while (and (cdr rest) (not rec))
+ (if (> (nth 2 (car (cdr rest))) p)
+ (setq rec (car (car rest))))
+ (setq rest (cdr rest)))
+ (or rec (car (car rest)))))
+
+
+;; yow, are we object oriented yet?
+(defun bbdb-record-get-field-internal (record field)
+ (cond ((eq field 'name) (bbdb-record-name record))
+ ((eq field 'net) (bbdb-record-net record))
+ ((eq field 'aka) (bbdb-record-aka record))
+ ((eq field 'phone) (bbdb-record-phones record))
+ ((eq field 'address) (bbdb-record-addresses record))
+ ((eq field 'property) (bbdb-record-raw-notes record))
+ (t (error "doubleplus ungood: unknown field type %s" field))))
+
+(defun bbdb-record-store-field-internal (record field value)
+ (cond ((eq field 'name) (error "doesn't work on names"))
+ ((eq field 'net) (bbdb-record-set-net record value))
+ ((eq field 'aka) (bbdb-record-set-aka record value))
+ ((eq field 'phone) (bbdb-record-set-phones record value))
+ ((eq field 'address) (bbdb-record-set-addresses record value))
+ ((eq field 'property) (bbdb-record-set-raw-notes record value))
+ (t (error "doubleplus ungood: unknown field type %s" field))))
+
+(defun bbdb-record-edit-field-internal (record field &optional which location)
+ (cond ((eq field 'name) (bbdb-record-edit-name record))
+ ((eq field 'company) (bbdb-record-edit-company record))
+ ((eq field 'net) (bbdb-record-edit-net record))
+ ((eq field 'aka) (bbdb-record-edit-aka record))
+ ((eq field 'phone) (bbdb-record-edit-phone which location))
+ ((eq field 'address) (bbdb-record-edit-address which location))
+ ((eq field 'property) (bbdb-record-edit-property record (car which)))
+ (t (error "doubleplus ungood: unknown field type %s" field))))
+
+
+(defun bbdb-current-field (&optional planning-on-modifying)
+ (or (bbdb-current-record planning-on-modifying)
+ (error "unperson"))
+ (delete 'field-name (get-text-property (point) 'bbdb-field)))
+
+;;;###autoload
+(defun bbdb-apply-next-command-to-all-records ()
+ "Typing \\<bbdb-mode-map>\\[bbdb-apply-next-command-to-all-records] \
+in the *BBDB* buffer makes the next command operate on all
+of the records currently displayed. \(Note that this only works for
+certain commands.\)"
+ (interactive)
+ (message (substitute-command-keys
+ "\\<bbdb-mode-map>\\[bbdb-apply-next-command-to-all-records] - "))
+ (setq prefix-arg current-prefix-arg
+ last-command this-command)
+ nil)
+
+(defmacro bbdb-do-all-records-p ()
+ "Whether the last command was `bbdb-apply-next-command-to-all-records'."
+ '(eq last-command 'bbdb-apply-next-command-to-all-records))
+
+
+(defvar bbdb-append-records nil)
+
+;;;###autoload
+(defun bbdb-append-records-p ()
+ (cond ((eq t bbdb-append-records))
+ ((numberp bbdb-append-records)
+ (setq bbdb-append-records
+ (1- bbdb-append-records))
+ (when (= 0 bbdb-append-records)
+ (when (not bbdb-silent-running)
+ (message "No further search results will be appended.")
+ (sit-for 2))
+ (setq bbdb-append-records nil))
+ t)
+ (bbdb-append-records
+ (setq bbdb-append-records nil)
+ t)
+ (t nil)))
+
+;;;###autoload
+(defun bbdb-append-records (arg)
+ "Typing \\<bbdb-mode-map>\\[bbdb-append-records] \
+in the *BBDB* buffer makes the next search/display command to append
+new records to those in the *BBDB* buffer.
+
+With an prefix arg (C-u) toggle between always append and no append.
+With an prefix arg that is a positive number append will be enabled for that
+many times.
+With any other argument append will be enabled once."
+ (interactive "P")
+ (message (substitute-command-keys
+ "\\<bbdb-mode-map>\\[bbdb-append-records] - "))
+ (setq bbdb-append-records
+ (cond ((and arg (listp arg))
+ (if (not bbdb-silent-running)
+ (if (not bbdb-append-records)
+ (message "Always append records.")
+ (message "Do not append records.")))
+ (not bbdb-append-records))
+ ((and (numberp arg) (< 1 arg))
+ (if (not bbdb-silent-running)
+ (message "Append records for the next %d times." arg))
+ arg)
+ (t 'once))))
+
+;;;###autoload
+(defun bbdb-insert-new-field (record name contents)
+ "Add a new field to the current record; the field type and contents
+are prompted for if not supplied.
+
+If you are inserting a new phone-number field, you can control whether
+it is a north american or european phone number by providing a prefix
+argument. A prefix arg of ^U means it's to be a euronumber, and any
+other prefix arg means it's to be a a structured north american number.
+Otherwise, which style is used is controlled by the variable
+`bbdb-north-american-phone-numbers-p'.
+
+If you are inserting a new net address, you can have BBDB append a
+default domain to any net address that does not contain one. Set
+`bbdb-default-domain' to a string such as \"mycompany.com\" (or,
+depending on your environment, (getenv \"DOMAINNAME\")), and
+\"@mycompany.com\" will be appended to an address that is entered as
+just a username. A prefix arg of ^U (or a `bbdb-default-domain'
+value of \"\", the default) means do not alter the address."
+ (interactive (let ((record (or (bbdb-current-record t)
+ (error "current record unexists!")))
+ (name "")
+ (completion-ignore-case t))
+ (while (string= name "")
+ (setq name
+ (downcase
+ (completing-read "Insert Field: "
+ (append '(("phone") ("address")
+ ("net") ("AKA") ("notes"))
+ (bbdb-propnames))
+ nil
+ nil ; used to be t
+ nil))))
+ (setq name (intern name))
+ (list record name (bbdb-prompt-for-new-field-value name))))
+ (if (null contents)
+ (setq contents (bbdb-prompt-for-new-field-value name)))
+
+ (cond ((eq name 'phone)
+ (bbdb-record-set-phones record
+ (nconc (bbdb-record-phones record)
+ (list contents))))
+ ((eq name 'address)
+ (bbdb-record-set-addresses record
+ (nconc (bbdb-record-addresses record)
+ (list contents))))
+ ((eq name 'net)
+ (if (bbdb-record-net record)
+ (error "There already are net addresses!"))
+ (if (stringp contents)
+ (setq contents (bbdb-split contents ",")))
+ ;; first detect any conflicts....
+ (if bbdb-no-duplicates-p
+ (let ((nets contents))
+ (while nets
+ (let ((old (bbdb-gethash (downcase (car nets)))))
+ (if (and old (not (eq old record)))
+ (error "net address \"%s\" is used by \"%s\""
+ (car nets)
+ (or (bbdb-record-name old)
+ (car (bbdb-record-net old))))))
+ (setq nets (cdr nets)))))
+ ;; then store.
+ (let ((nets contents))
+ (while nets
+ (bbdb-puthash (downcase (car nets)) record)
+ (setq nets (cdr nets))))
+ (bbdb-record-set-net record contents))
+ ((eq name 'aka)
+ (if (bbdb-record-aka record)
+ (error "there already are alternate names!"))
+ (if (stringp contents)
+ (setq contents (bbdb-split contents ";")))
+ ;; first detect any conflicts....
+ (if bbdb-no-duplicates-p
+ (let ((aka contents))
+ (while aka
+ (let ((old (bbdb-gethash (downcase (car aka)))))
+ (if (and old (not (eq old record)))
+ (error "alternate name \"%s\" is used by \"%s\""
+ (car aka)
+ (or (bbdb-record-name old)
+ (car (bbdb-record-net old))))))
+ (setq aka (cdr aka)))))
+ ;; then store.
+ (let ((aka contents))
+ (while aka
+ (bbdb-puthash (downcase (car aka)) record)
+ (setq aka (cdr aka))))
+ (bbdb-record-set-aka record contents))
+ ((eq name 'notes)
+ (if (bbdb-record-notes record) (error "there already are notes!"))
+ (bbdb-record-set-notes record contents))
+ ((assoc (symbol-name name) (bbdb-propnames))
+ (if (and (consp (bbdb-record-raw-notes record))
+ (assq name (bbdb-record-raw-notes record)))
+ (error "there is already a \"%s\" note!" name))
+ (bbdb-record-putprop record name contents))
+ (t (error "doubleplus ungood: unknow how to set slot %s" name)))
+ (bbdb-change-record record nil)
+; (bbdb-offer-save)
+ (let ((bbdb-display-layout nil))
+ (bbdb-redisplay-one-record record)))
+
+(defun bbdb-prompt-for-new-field-value (name)
+ (cond ((eq name 'net)
+ (let
+ ((n (bbdb-read-string "Net: ")))
+ (if (string-match "^mailto:" n)
+ (setq n (substring n (match-end 0))))
+ (if (or (eq nil bbdb-default-domain)
+ current-prefix-arg (string-match "[@%!]" n))
+ n
+ (concat n "@" bbdb-default-domain))))
+ ((eq name 'aka) (bbdb-read-string "Alternate Names: "))
+ ((eq name 'phone)
+ (let ((p (make-vector
+ (if (if current-prefix-arg
+ (numberp current-prefix-arg)
+ bbdb-north-american-phone-numbers-p)
+ bbdb-phone-length
+ 2)
+ 0)))
+ (aset p 0 nil)
+ (aset p 1
+ (if (= bbdb-phone-length (length p))
+ (if (integerp bbdb-default-area-code)
+ bbdb-default-area-code
+ 0)
+ nil))
+ (bbdb-record-edit-phone p)
+ p))
+ ((eq name 'address)
+ (let ((a (make-vector bbdb-address-length nil)))
+ (bbdb-record-edit-address a)
+ a))
+ ((eq name 'notes) (bbdb-read-string "Notes: "))
+ ((assoc (symbol-name name) (bbdb-propnames))
+ (bbdb-read-string (format "%s: " name)))
+ (t
+ (if (bbdb-y-or-n-p
+ (format "\"%s\" is an unknown field name. Define it? " name))
+ (bbdb-set-propnames
+ (append (bbdb-propnames) (list (list (symbol-name name)))))
+ (error "unknown field \"%s\"" name))
+ (bbdb-read-string (format "%s: " name)))))
+
+(defun bbdb-add-new-field (name)
+ "Programmatically add a new field called NAME. Returns the list of propnames."
+ ;; check that we don't have one already; if we do, return quietly.
+ (if (assoc (symbol-name name) (append '(("phone") ("address") ("net")
+ ("AKA") ("notes"))
+ (bbdb-propnames)))
+ bbdb-propnames
+ (bbdb-set-propnames (append (bbdb-propnames)
+ (list (list (symbol-name name)))))))
+
+;;;###autoload
+(defun bbdb-edit-current-field ()
+ "Edit the contents of the Insidious Big Brother Database field displayed on
+the current line (this is only meaningful in the \"*BBDB*\" buffer.) If the
+cursor is in the middle of a multi-line field, such as an address or comments
+section, then the entire field is edited, not just the current line."
+ (interactive)
+ ;; when at the end of the line take care of it
+ (if (and (eolp) (not (bobp)) (not (bbdb-current-field t)))
+ (backward-char 1))
+
+ (let* ((record (bbdb-current-record t))
+ (field (bbdb-current-field t))
+ need-to-sort)
+ (or field (error "on an unfield"))
+ (setq need-to-sort
+ (apply 'bbdb-record-edit-field-internal record field))
+ (bbdb-change-record record need-to-sort)
+ (bbdb-redisplay-one-record record)
+ ;; (bbdb-offer-save)
+ (if (and (eq 'property (car field))
+ (or (eq 'mail-alias (caadr field))
+ (eq 'net (caadr field))))
+ (setq bbdb-define-all-aliases-needs-rebuilt 'edit))
+ ))
+
+(defun bbdb-record-edit-name (bbdb-record)
+ (let (fn ln co need-to-sort new-name old-name)
+ (bbdb-error-retry
+ (progn
+ (if current-prefix-arg
+ (setq fn (bbdb-read-string "First Name: "
+ (bbdb-record-firstname bbdb-record))
+ ln (bbdb-read-string "Last Name: "
+ (bbdb-record-lastname bbdb-record)))
+ (let ((names (bbdb-divide-name
+ (bbdb-read-string "Name: "
+ (bbdb-record-name bbdb-record)))))
+ (setq fn (car names)
+ ln (nth 1 names))))
+ (setq need-to-sort
+ (or (not (string= fn
+ (or (bbdb-record-firstname bbdb-record) "")))
+ (not (string= ln
+ (or (bbdb-record-lastname bbdb-record) "")))))
+ (if (string= "" fn) (setq fn nil))
+ (if (string= "" ln) (setq ln nil))
+ ;; check for collisions
+ (setq new-name (if (and fn ln) (concat fn " " ln)
+ (or fn ln))
+ old-name (bbdb-record-name bbdb-record))
+ (if (and bbdb-no-duplicates-p
+ new-name
+ (not (and old-name (string= (downcase new-name)
+ (downcase old-name))))
+ (bbdb-gethash (downcase new-name)))
+ (error "%s is already in the database!" new-name))))
+ (setq co (bbdb-read-string "Company: "
+ (bbdb-record-company bbdb-record)))
+ (if (string= "" co) (setq co nil))
+ (setq need-to-sort
+ (or need-to-sort
+ (not (equal (if co (downcase co) "")
+ (downcase (or (bbdb-record-company bbdb-record)
+ ""))))))
+ ;;
+ ;; delete the old hash entry
+ (let ((name (bbdb-record-name bbdb-record))
+ (lfname (bbdb-record-lfname bbdb-record))
+ (company (bbdb-record-company bbdb-record)))
+ (if (> (length name) 0)
+ (bbdb-remhash (downcase name) bbdb-record))
+ (if (> (length lfname) 0)
+ (bbdb-remhash (downcase lfname) bbdb-record))
+ (if (> (length company) 0)
+ (bbdb-remhash (downcase company) bbdb-record)))
+ (bbdb-record-set-namecache bbdb-record nil)
+ (bbdb-record-set-firstname bbdb-record fn)
+ (bbdb-record-set-lastname bbdb-record ln)
+ (bbdb-record-set-company bbdb-record co)
+ ;; add a new hash entry
+ (when (or fn ln)
+ (bbdb-puthash (downcase (bbdb-record-name bbdb-record))
+ bbdb-record)
+ (if (and fn ln)
+ (bbdb-puthash (downcase (bbdb-record-lfname bbdb-record))
+ bbdb-record)))
+ need-to-sort))
+
+(defun bbdb-record-edit-company (bbdb-record)
+ (let ((co (bbdb-read-string "Company: " (bbdb-record-company bbdb-record)))
+ need-to-sort)
+
+ (if (string= "" co) (setq co nil))
+ (setq need-to-sort
+ (or need-to-sort
+ (not (equal (if co (downcase co) "")
+ (downcase (or (bbdb-record-company bbdb-record)
+ ""))))))
+
+ ;; delete the old hash entry
+ (let ((company (bbdb-record-company bbdb-record)))
+ (if (> (length company) 0)
+ (bbdb-remhash (downcase company) bbdb-record)))
+
+ (bbdb-record-set-company bbdb-record co)
+ ;; add a new hash entry
+ (bbdb-puthash (downcase (bbdb-record-name bbdb-record))
+ bbdb-record)
+
+ need-to-sort))
+
+(defun bbdb-address-edit-default (addr)
+ "Function to use for address editing.
+The sub-fields are queried using the default order and using the
+default names. Set `bbdb-address-editing-function' to an alternate
+address editing function if you don't like this function. It is
+mostly used for US style addresses.
+
+The sub-fields and the prompts used are:
+Street, line n: (nth n street)
+City: city
+State: state
+Zip Code: zip
+Country: country"
+ (let* ((str (let ((l) (s) (n 0))
+ (while (not (string= "" (setq s (bbdb-read-string
+ (format "Street, line %d: " (+ 1 n))
+ (nth n (bbdb-address-streets addr))))))
+ (setq l (append l (list s)))
+ (setq n (1+ n)))
+ l))
+ (cty (bbdb-read-string "City: " (bbdb-address-city addr)))
+ (ste (bbdb-read-string "State: " (bbdb-address-state addr)))
+ (zip (bbdb-error-retry
+ (bbdb-parse-zip-string
+ (bbdb-read-string "Zip Code: " (bbdb-address-zip-string addr)))))
+ (country (bbdb-read-string "Country: " (or (bbdb-address-country addr)
+ bbdb-default-country))))
+ (bbdb-address-set-streets addr str)
+ (bbdb-address-set-city addr cty)
+ (bbdb-address-set-state addr ste)
+ (bbdb-address-set-zip addr zip)
+ (if (string= "" (concat cty ste zip country (mapconcat 'identity str "")))
+ ;; user didn't enter anything. this causes a display bug. this
+ ;; is a temporary fix. Ideally, we'd simply discard the entire
+ ;; address entry, but that's going to require bigger hacking.
+ (bbdb-address-set-country addr "Emacs")
+ (bbdb-address-set-country addr country))
+ nil))
+
+(defun bbdb-address-edit-continental (addr)
+ "Function to use for address editing.
+The sub-fields are queried using the default order and using the
+default names. Set `bbdb-address-editing-function' to an alternate
+address editing function if you don't like this function. It is
+mostly used for US style addresses.
+
+The sub-fields and the prompts used are:
+Street, line n: (nth n street)
+City: city
+State: state
+Zip Code: zip
+Country: country"
+ (let* ((str (let ((l) (s) (n 0))
+ (while (not (string= "" (setq s (bbdb-read-string
+ (format "Street, line %d: " (+ 1 n))
+ (nth n (bbdb-address-streets addr))))))
+ (setq l (append l (list s)))
+ (setq n (1+ n)))
+ l))
+ (zip (bbdb-error-retry
+ (bbdb-parse-zip-string
+ (bbdb-read-string "Zip Code: " (bbdb-address-zip-string addr)))))
+ (cty (bbdb-read-string "City: " (bbdb-address-city addr)))
+ (ste "")
+ (country (bbdb-read-string "Country: " (or (bbdb-address-country addr)
+ bbdb-default-country))))
+ (bbdb-address-set-streets addr str)
+ (bbdb-address-set-city addr cty)
+ (bbdb-address-set-state addr ste)
+ (bbdb-address-set-zip addr zip)
+ (if (string= "" (concat cty ste zip country (mapconcat 'identity str "")))
+ ;; user didn't enter anything. this causes a display bug. this
+ ;; is a temporary fix. Ideally, we'd simply discard the entire
+ ;; address entry, but that's going to require bigger hacking.
+ (bbdb-address-set-country addr "Emacs")
+ (bbdb-address-set-country addr country))
+ nil))
+
+(defcustom bbdb-address-editing-function 'bbdb-address-edit-default
+ "Function to use for address editing.
+The function must accept a BBDB address as parameter and allow the
+user to edit it. This variable is called from `bbdb-record-edit-address'.
+The default value is the symbol `bbdb-address-edit-default'."
+ :group 'bbdb-record-creation
+ :type 'function)
+
+(defun bbdb-record-edit-address (addr &optional location)
+ "Edit an address ADDR.
+If optional parameter LOCATION is nil, edit the location sub-field
+of the address as well. The address itself is edited using the editing
+function in `bbdb-address-editing-function'."
+ (let ((loc
+ (or location (bbdb-read-string "Location: "
+ (or (bbdb-address-location addr)
+ (bbdb-label-completion-default
+ "addresses"))
+ (mapcar (function (lambda(x) (list x)))
+ (bbdb-label-completion-list
+ "addresses"))))))
+ (bbdb-address-set-location addr loc))
+ (if current-prefix-arg
+ (bbdb-address-edit-default addr)
+ (funcall bbdb-address-editing-function addr)))
+
+(defun bbdb-record-edit-phone (phone-number &optional location)
+ (let ((newl (or location
+ (bbdb-read-string "Location: "
+ (or (bbdb-phone-location phone-number)
+ (bbdb-label-completion-default
+ "phones"))
+ (mapcar (function (lambda(x) (list x)))
+ (bbdb-label-completion-list
+ "phones")))))
+ (newp (let ((bbdb-north-american-phone-numbers-p
+ (= (length phone-number) bbdb-phone-length)))
+ (bbdb-error-retry
+ (bbdb-parse-phone-number
+ (read-string "Phone: " (bbdb-phone-string phone-number)))))))
+ (bbdb-phone-set-location phone-number newl)
+ (bbdb-phone-set-area phone-number (nth 0 newp)) ; euronumbers too.
+ (if (= (length phone-number) 2)
+ nil
+ (bbdb-phone-set-exchange phone-number (nth 1 newp))
+ (bbdb-phone-set-suffix phone-number (nth 2 newp))
+ (bbdb-phone-set-extension phone-number (or (nth 3 newp) 0))))
+ nil)
+
+(defun bbdb-record-edit-net (bbdb-record)
+ (let ((str (bbdb-read-string "Net: "
+ (mapconcat (function identity)
+ (bbdb-record-net bbdb-record)
+ ", "))))
+ (let ((oldnets (bbdb-record-net bbdb-record))
+ (newnets (bbdb-split str ",")))
+ ;; first check for any conflicts...
+ (if bbdb-no-duplicates-p
+ (let ((rest newnets))
+ (while rest
+ (let ((old (delete bbdb-record (bbdb-gethash (downcase (car rest))))))
+ (if old
+ (error "net address \"%s\" is used by \"%s\""
+ (car rest) (mapconcat (lambda (r) (bbdb-record-name r))
+ old ", "))))
+ (setq rest (cdr rest)))))
+ ;; then update.
+ (let ((rest oldnets))
+ (while rest
+ (bbdb-remhash (downcase (car rest)) bbdb-record)
+ (setq rest (cdr rest))))
+ (let ((nets newnets))
+ (while nets
+ (bbdb-puthash (downcase (car nets)) bbdb-record)
+ (setq nets (cdr nets))))
+ (bbdb-record-set-net bbdb-record newnets)))
+ nil)
+
+(defun bbdb-record-edit-aka (bbdb-record)
+ (let ((str (bbdb-read-string "AKA: "
+ (mapconcat (function identity)
+ (bbdb-record-aka bbdb-record)
+ "; "))))
+ (let ((oldaka (bbdb-record-aka bbdb-record))
+ (newaka (bbdb-split str ";")))
+ ;; first check for any conflicts...
+ (if bbdb-no-duplicates-p
+ (let ((rest newaka))
+ (while rest
+ (let ((old (bbdb-gethash (downcase (car rest)))))
+ (if (and old (not (eq old bbdb-record)))
+ (error "alternate name address \"%s\" is used by \"%s\""
+ (car rest) (bbdb-record-name old))))
+ (setq rest (cdr rest)))))
+ ;; then update.
+ (let ((rest oldaka))
+ (while rest
+ (bbdb-remhash (downcase (car rest)) bbdb-record)
+ (setq rest (cdr rest))))
+ (let ((aka newaka))
+ (while aka
+ (bbdb-puthash (downcase (car aka)) bbdb-record)
+ (setq aka (cdr aka))))
+ (bbdb-record-set-aka bbdb-record newaka)))
+ nil)
+
+;;;###autoload
+(defun bbdb-record-edit-notes (bbdb-record &optional regrind)
+ (interactive (list (bbdb-current-record t) t))
+ (let ((notes (bbdb-read-string "Notes: " (bbdb-record-notes bbdb-record))))
+ (bbdb-record-set-notes bbdb-record (if (string= "" notes) nil notes)))
+ (if regrind
+ (save-excursion
+ (set-buffer bbdb-buffer-name)
+ (bbdb-redisplay-one-record bbdb-record)))
+ nil)
+
+;;;###autoload
+(defun bbdb-record-edit-property (bbdb-record &optional prop regrind)
+ (interactive (list (bbdb-current-record t) nil t))
+ (let* ((propnames (bbdb-propnames))
+ (propname (if prop (symbol-name prop)
+ (completing-read
+ (format "Edit property of %s: "
+ (bbdb-record-name bbdb-record))
+ (cons '("notes") propnames))))
+ (propsym (or prop (if (equal "" propname) 'notes (intern propname))))
+ (string (bbdb-read-string (format "%s: " propname)
+ (bbdb-record-getprop bbdb-record propsym))))
+ (bbdb-record-putprop bbdb-record propsym
+ (if (string= "" string) nil string)))
+ (if regrind
+ (save-excursion
+ (set-buffer bbdb-buffer-name)
+ (bbdb-redisplay-one-record bbdb-record)))
+ nil)
+
+
+(defsubst bbdb-field-equal (x y)
+ (if (and (consp x) (consp y))
+ (and (eq (car x) (car y))
+ (eq (car (cdr x)) (car (cdr y)))
+ (eq (car (cdr (cdr x))) (car (cdr (cdr y)))))
+ (eq x y)))
+
+(defun bbdb-next-field (&optional count planning-on-modifying)
+ (or count (setq count 1))
+ (beginning-of-line)
+ (let* ((record (bbdb-current-record planning-on-modifying))
+ (field (bbdb-current-field planning-on-modifying))
+ (next-record record)
+ (next-field field)
+ (signum (if (< count 0) -1 1))
+ (i 0))
+ (if (< count 0) (setq count (- count)))
+ (if field
+ (while (and next-field (< i count))
+ (while (bbdb-field-equal next-field field)
+ (forward-line signum)
+ (setq next-record (bbdb-current-record planning-on-modifying)
+ next-field (bbdb-current-field planning-on-modifying))
+ (or (eq next-record record)
+ (setq next-field nil)))
+ (setq i (1+ i))
+ (setq field next-field)))
+ next-field))
+
+;;;###autoload
+(defun bbdb-transpose-fields (&optional arg)
+ "This is like the `transpose-lines' command, but it is for BBDB fields.
+If the cursor is on a field of a BBDB record, that field and the previous
+field will be transposed.
+
+With argument ARG, takes previous line and moves it past ARG fields.
+With argument 0, interchanges field point is in with field mark is in.
+
+Both fields must be in the same record, and must be of the same basic type
+\(that is, you can use this command to change the order in which phone-number
+fields are listed, but you can't use it to make an address appear before a
+phone number; the order of field types is fixed.\)"
+ (interactive "p")
+ (let ((record (bbdb-current-record t))
+ moving-field position-after position-before
+ swap-p type list)
+ (if (/= arg 0)
+ (setq moving-field (or (bbdb-next-field -1 t)
+ (error "no previous field"))
+ position-after (bbdb-next-field arg t)
+ position-before (bbdb-next-field (if (< arg 0) -1 1) t))
+ ;; if arg is 0, swap fields at point and mark
+ (setq swap-p t)
+ (setq position-after (bbdb-current-field))
+ (save-excursion
+ (goto-char (mark))
+ (setq moving-field (bbdb-current-field))
+ (or (eq record (bbdb-current-record)) (error "not in the same record"))))
+ (if (< arg 0)
+ (let ((x position-after))
+ (setq position-after position-before
+ position-before x)
+ (forward-line 2)))
+ (setq type (car moving-field))
+ (or position-after position-before
+ (error "that would be out of the record!"))
+ (or (eq type (car position-after))
+ (eq type (car position-before))
+ (error "can't transpose fields of different types (%s and %s)"
+ type (if (eq type (car position-after))
+ (car position-before) (car position-after))))
+ (or (eq type (car position-after)) (setq position-after nil))
+ (or (eq type (car position-before)) (setq position-before nil))
+ (setq moving-field (nth 1 moving-field)
+ position-after (nth 1 position-after)
+ position-before (nth 1 position-before))
+ (cond ((memq type '(name aka net))
+ (error "there is only one %s field, so you can't transpose it"
+ type))
+ ((memq type '(phone address property))
+ (setq list (bbdb-record-get-field-internal record type)))
+ (t (error "doubleplus ungood: unknown field %s" type)))
+ (if swap-p
+ (let ((rest list))
+ (while rest
+ (cond ((eq (car rest) moving-field) (setcar rest position-after))
+ ((eq (car rest) position-after) (setcar rest moving-field)))
+ (setq rest (cdr rest))))
+ (if (eq position-before (car list))
+ (setq list (cons moving-field (delq moving-field list)))
+ (let ((rest list))
+ (while (and rest (not (eq position-after (car rest))))
+ (setq rest (cdr rest)))
+ (or rest (error "doubleplus ungood: couldn't reorder list"))
+ (let ((inhibit-quit t))
+ (setq list (delq moving-field list))
+ (setcdr rest (cons moving-field (cdr rest)))))))
+ (bbdb-record-store-field-internal record type list)
+ (bbdb-change-record record nil)
+ (bbdb-redisplay-one-record record)))
+
+
+;;;###autoload
+(defun bbdb-delete-current-field-or-record (&optional records noprompt)
+ "Delete the line which the cursor is on; actually, delete the field which
+that line represents from the database. If the cursor is on the first line
+of a database entry (the name/company line) then the entire entry will be
+deleted."
+ (interactive (list (if (bbdb-do-all-records-p)
+ (mapcar 'car bbdb-records)
+ (list (bbdb-current-record)))
+ current-prefix-arg))
+ (let* ((field (bbdb-current-field t))
+ (type (car field))
+ record
+ (name (cond ((null field) (error "on an unfield"))
+ ((eq type 'property) (symbol-name (car (nth 1 field))))
+ (t (symbol-name type)))))
+ (while records
+ (setq record (car records))
+ (if (eq type 'name)
+ (bbdb-delete-current-record record noprompt)
+ (if (not (or noprompt
+ (bbdb-y-or-n-p (format "delete this %s field (of %s)? "
+ name
+ (bbdb-record-name record)))))
+ nil
+ (cond ((memq type '(phone address))
+ (bbdb-record-store-field-internal
+ record type
+ (delq (nth 1 field)
+ (bbdb-record-get-field-internal record type))))
+ ((memq type '(net aka))
+ (let ((rest (bbdb-record-get-field-internal record type)))
+ (while rest
+ (bbdb-remhash (downcase (car rest)) record)
+ (setq rest (cdr rest))))
+ (bbdb-record-store-field-internal record type nil))
+ ((eq type 'property)
+ (bbdb-record-putprop record (car (nth 1 field)) nil))
+ (t (error "doubleplus ungood: unknown field type")))
+ (bbdb-change-record record nil)
+ (bbdb-redisplay-one-record record)))
+ (setq records (cdr records)))))
+
+;;;###autoload
+(defun bbdb-delete-current-record (recs &optional noprompt)
+ "Delete the entire bbdb database entry which the cursor is within.
+Pressing \\<bbdb-mode-map>\\[bbdb-apply-next-command-to-all-records] will
+delete all records listed in the BBDB buffer."
+ (interactive (list (if (bbdb-do-all-records-p)
+ (mapcar 'car bbdb-records)
+ (list (bbdb-current-record t)))
+ current-prefix-arg))
+ (if (not (listp recs))
+ (setq recs (list recs)))
+ (while recs
+ (let ((r (car recs)))
+ (setq recs (cdr recs))
+ (bbdb-debug (if (bbdb-record-deleted-p r)
+ (error "deleting deleted record")))
+ (if (or noprompt
+ (bbdb-y-or-n-p (format "delete the entire db entry of %s? "
+ (or (bbdb-record-name r)
+ (bbdb-record-company r)
+ (car (bbdb-record-net r))))))
+ (let* ((record-cons (assq r bbdb-records))
+ (next-record-cons (car (cdr (memq record-cons
+ bbdb-records)))))
+ (bbdb-debug (if (bbdb-record-deleted-p r)
+ (error "deleting deleted record")))
+ (bbdb-record-set-deleted-p r t)
+ (bbdb-delete-record-internal r)
+ (if (eq record-cons (car bbdb-records))
+ (setq bbdb-records (cdr bbdb-records))
+ (let ((rest bbdb-records))
+ (while (cdr rest)
+ (if (eq record-cons (car (cdr rest)))
+ (progn
+ (setcdr rest (cdr (cdr rest)))
+ (setq rest nil)))
+ (setq rest (cdr rest)))))
+ (bbdb-redisplay-one-record r record-cons next-record-cons t)
+ (bbdb-with-db-buffer
+ (setq bbdb-changed-records (delq r bbdb-changed-records)))
+ ;; (bbdb-offer-save)
+ )))))
+
+(defun bbdb-change-records-state-and-redisplay (desired-state records)
+ (let (rec)
+ (while records
+ (setq rec (car records))
+ (unless (eq desired-state (nth 1 rec))
+ (setcar (cdr rec) desired-state)
+ (bbdb-redisplay-one-record (car rec) rec))
+ (setq records (cdr records)))))
+
+;;;###autoload
+(defun bbdb-toggle-all-records-display-layout (arg &optional records)
+ "Show all the fields of all visible records.
+Like `bbdb-toggle-records-display-layout' but for all visible records."
+ (interactive "P")
+ (if (null records)
+ (setq records bbdb-records))
+ (let* ((record (bbdb-current-record))
+ (cons (assq record bbdb-records))
+ (current-state (nth 1 cons))
+ (layout-alist
+ (or (delete nil (mapcar (lambda (l)
+ (if (and (assoc 'toggle l)
+ (cdr (assoc 'toggle l)))
+ l))
+ bbdb-display-layout-alist))
+ bbdb-display-layout-alist))
+ (desired-state (assoc current-state layout-alist)))
+ (setq desired-state
+ (cond ((eq arg 0)
+ 'one-line)
+ ((null current-state)
+ 'multi-line)
+ ((null (cdr (memq desired-state layout-alist)))
+ (caar layout-alist))
+ (t
+ (caadr (memq desired-state layout-alist)))))
+ (message "Using %S layout" desired-state)
+ (bbdb-change-records-state-and-redisplay desired-state records)))
+
+;;;###autoload
+(defun bbdb-toggle-records-display-layout (arg)
+ "Toggle whether the current record is displayed expanded or elided
+\(multi-line or one-line display.\) With a numeric argument of 0, the
+current record will unconditionally be made elided; with any other argument,
+the current record will unconditionally be shown expanded.
+\\<bbdb-mode-map>
+If \"\\[bbdb-apply-next-command-to-all-records]\\[bbdb-toggle-records-display-layout]\" is \
+used instead of simply \"\\[bbdb-toggle-records-display-layout]\", then the state of all \
+records will
+be changed instead of just the one at point. In this case, an argument
+of 0 means that all records will unconditionally be made elided; any other
+numeric argument means that all of the records will unconditionally be shown
+expanded; and no numeric argument means that the records are made to be in
+the opposite state of the record under point."
+ (interactive "P")
+ (bbdb-toggle-all-records-display-layout
+ arg
+ (if (not (bbdb-do-all-records-p))
+ (list (assq (bbdb-current-record) bbdb-records)))))
+
+;;;###autoload
+(defun bbdb-display-all-records-completely
+ (arg &optional records)
+ "Show all the fields of all currently displayed records.
+The display layout `full-multi-line' is used for this."
+ (interactive "P")
+ (if (null records)
+ (setq records bbdb-records))
+ (let* ((record (bbdb-current-record))
+ (cons (assq record bbdb-records))
+ (current-state (nth 1 cons))
+ (desired-state
+ (cond ((not (eq current-state 'full-multi-line))
+ 'full-multi-line)
+ (t
+ 'multi-line))))
+ (bbdb-change-records-state-and-redisplay desired-state records)))
+
+;;;###autoload
+(defun bbdb-display-record-completely (arg)
+ "Show all the fields of the current record.
+The display layout `full-multi-line' is used for this."
+ (interactive "P")
+ (bbdb-display-all-records-completely
+ arg
+ (if (not (bbdb-do-all-records-p))
+ (list (assq (bbdb-current-record) bbdb-records)))))
+
+;;;###autoload
+(defun bbdb-display-record-with-layout (layout &optional records)
+ "Show all the fields of the current record using LAYOUT."
+ (interactive (list (completing-read "Layout: "
+ (mapcar (lambda (i)
+ (list (symbol-name (car i))))
+ bbdb-display-layout-alist))))
+ (when (stringp layout)
+ (setq layout (intern layout)))
+ (when (null records)
+ (setq records bbdb-records))
+ (bbdb-change-records-state-and-redisplay layout records))
+
+;;;###autoload
+(defun bbdb-omit-record (n)
+ "Remove the current record from the display without deleting it from the
+database. With a prefix argument, omit the next N records. If negative,
+omit backwards."
+ (interactive "p")
+ (while (not (= n 0))
+ (if (< n 0) (bbdb-prev-record 1))
+ (let* ((record (or (bbdb-current-record) (error "no records")))
+ (rest bbdb-records)
+ cons next prev-tail)
+ (while rest
+ (if (eq (car (car rest)) record)
+ (setq cons (car rest)
+ next (car (cdr rest))
+ rest nil)
+ (setq prev-tail rest
+ rest (cdr rest))))
+ (or record (error "can't find current record"))
+ (let ((buffer-read-only nil))
+ (delete-region (nth 2 cons) (if next (nth 2 next) (point-max))))
+ (if prev-tail
+ (setcdr prev-tail (cdr (cdr prev-tail)))
+ (setq bbdb-records (cdr bbdb-records)))
+ (setq n (if (> n 0) (1- n) (1+ n)))))
+ (bbdb-frob-mode-line (length bbdb-records)))
+
+;;; Fixing up bogus entries
+
+(defcustom bbdb-refile-notes-generate-alist '((creation-date . bbdb-refile-notes-string-least) (timestamp . bbdb-refile-notes-string-most))
+ "*An alist defining specific merging function, based on notes field."
+ :group 'bbdb-noticing-records
+ :type '(repeat (cons
+ (symbol :tag "Notes filed")
+ (hook :tag "Generating function"))))
+
+(defcustom bbdb-refile-notes-default-merge-function 'bbdb-refile-notes-default-merge-function
+ "*Default function to use for merging BBDB notes records.
+
+If the note field has an entry in `bbdb-refile-notes-generate-alist',
+that function will be used instead."
+ :group 'bbdb-noticing-records
+ :type 'function)
+
+
+(defun bbdb-refile-notes-default-merge-function (string1 string2)
+ "Returns the concatenation of STRING1 and STRING2"
+ (concat string1 "\n" string2))
+
+(defun bbdb-refile-notes-remove-duplicates (string1 string2)
+ "Concatenate STRING1 and STRING2, but remove duplicate lines."
+ (let ((note1 (split-string string1 "\n"))
+ (note2 (split-string string2 "\n")))
+ (while note2
+ (if (not (member (car note2) note1))
+ (setq note1 (cons (car note2) note1)))
+ (setq note2 (cdr note2)))
+ (mapconcat 'identity note1 "\n")))
+
+(defun bbdb-refile-notes-string-least (string1 string2)
+ "Returns the string that is lessp."
+ (if (string-lessp string1 string2)
+ string1
+ string2))
+
+(defun bbdb-refile-notes-string-most (string1 string2)
+ "Returns the string that is not lessp."
+ (if (string-lessp string1 string2)
+ string2
+ string1))
+
+(defun bbdb-merge-lists! (l1 l2 cmp &optional mod)
+ "Merge two lists l1 l2 (modifies l1) only adds elements from l2
+if cmp returns false for all elements of l1. If optional mod
+is provided it is applied to each element of l1 and l2 prior to cmp"
+ (if (null l1)
+ l2
+ (let ((end (last l1))
+ (src2 l2)
+ (chk (if mod (mapcar mod l1) (append l1 '()))))
+ (while src2
+ (let ((fail '())
+ (src1 chk)
+ (val (if mod (apply mod (car src2) '()) (car src2))))
+ (while src1
+ (if (apply cmp (car src1) val '())
+ (setq src1 '()
+ fail 't)
+ (setq src1 (cdr src1))))
+ (if fail '()
+ (setcdr end (cons (car src2) '()))
+ (setq end (cdr end)))
+ (setq src2 (cdr src2))))
+ l1)))
+
+(defun bbdb-merge-records (old-record new-record)
+ "Merge the contents of old-record into new-record, old-record
+remains unchanged. For name and company it queries about which to use
+if they differ. All other fields are concatenated. Idealy this would
+be better about checking for duplicate entries in other fields, as
+well as possibly querying about differing values.
+
+This function does nothing to ensure the integrity of the rest of the
+database, that is somebody elses problem (something like
+`bbdb-refile-record')."
+ (if (or (null new-record) (eq old-record new-record))
+ (error "those are the same"))
+ (let ((new-name (bbdb-record-name new-record))
+ (new-co (bbdb-record-company new-record))
+ (old-name (bbdb-record-name old-record))
+ (old-co (bbdb-record-company old-record))
+ (old-nets (bbdb-record-net old-record))
+ (old-aka (bbdb-record-aka old-record))
+ extra-name)
+ (let ((name
+ (cond ((= 0 (length old-name))
+ (cons (bbdb-record-firstname new-record)
+ (bbdb-record-lastname new-record)))
+ ((= 0 (length new-name))
+ (cons (bbdb-record-firstname old-record)
+ (bbdb-record-lastname old-record)))
+ ((string-equal (downcase old-name) (downcase new-name))
+ (cons (bbdb-record-firstname new-record)
+ (bbdb-record-lastname new-record)))
+ (t (prog1
+ (if (bbdb-y-or-n-p
+ (format "Use name \"%s\" instead of \"%s\"? "
+ old-name new-name))
+ (progn
+ (setq extra-name new-record)
+ (cons (bbdb-record-firstname old-record)
+ (bbdb-record-lastname old-record)))
+ (setq extra-name old-record)
+ (cons (bbdb-record-firstname new-record)
+ (bbdb-record-lastname new-record)))
+ (or (and bbdb-use-alternate-names
+ (bbdb-y-or-n-p
+ (format "Keep \"%s\" as an alternate name? "
+ (bbdb-record-name extra-name))))
+ (setq extra-name nil))))))
+ (comp (cond ((= 0 (length old-co)) new-co)
+ ((= 0 (length new-co)) old-co)
+ ((string-equal old-co new-co) new-co)
+ (t (if (bbdb-y-or-n-p
+ (format "Use company \"%s\" instead of \"%s\"? "
+ old-co new-co))
+ old-co new-co)))))
+
+ (if extra-name
+ (setq old-aka (cons (bbdb-record-name extra-name) old-aka)))
+
+ (bbdb-record-set-phones new-record
+ (bbdb-merge-lists!
+ (bbdb-record-phones new-record)
+ (bbdb-record-phones old-record)
+ 'equal))
+ (bbdb-record-set-addresses new-record
+ (bbdb-merge-lists!
+ (bbdb-record-addresses new-record)
+ (bbdb-record-addresses old-record)
+ 'equal))
+ (bbdb-record-set-company new-record comp)
+
+ (let ((n1 (bbdb-record-raw-notes new-record))
+ (n2 (bbdb-record-raw-notes old-record))
+ tmp)
+ (or (equal n1 n2)
+ (progn
+ (or (listp n1) (setq n1 (list (cons 'notes n1))))
+ (or (listp n2) (setq n2 (list (cons 'notes n2))))
+ (while n2
+ (if (setq tmp (assq (car (car n2)) n1))
+ (setcdr tmp
+ (funcall
+ (or (cdr (assq (car (car n2))
+ bbdb-refile-notes-generate-alist))
+ bbdb-refile-notes-default-merge-function)
+ (cdr tmp) (cdr (car n2))))
+ (setq n1 (nconc n1 (list (car n2)))))
+ (setq n2 (cdr n2)))
+ (bbdb-record-set-raw-notes new-record n1))))
+
+ (bbdb-record-set-firstname new-record (car name))
+ (bbdb-record-set-lastname new-record (cdr name))
+ (bbdb-record-set-namecache new-record nil)
+
+ (bbdb-record-set-net new-record
+ (bbdb-merge-lists!
+ (bbdb-record-net new-record) old-nets
+ 'string= 'downcase))
+ (bbdb-record-set-aka new-record
+ (bbdb-merge-lists!
+ (bbdb-record-aka new-record) old-aka
+ 'string= 'downcase))
+ new-record)))
+
+;;;###autoload
+(defun bbdb-refile-record (old-record new-record)
+ "Merge the current record into some other record; that is, delete the
+record under point after copying all of the data within it into some other
+record. this is useful if you realize that somehow a redundant record has
+gotten into the database, and you want to merge it with another.
+
+If both records have names and/or companies, you are asked which to use.
+Phone numbers, addresses, and network addresses are simply concatenated.
+The first record is the record under the point; the second is prompted for.
+Completion behaviour is as dictated by the variable `bbdb-completion-type'."
+ (interactive
+ (let ((r (bbdb-current-record))
+ name)
+ (setq name (bbdb-record-name r))
+ (list r
+ (if current-prefix-arg
+ (car (delq r (bbdb-search (bbdb-records) name nil)))
+ (bbdb-completing-read-one-record
+ (format "merge record \"%s\" into: "
+ (or (bbdb-record-name r) (car (bbdb-record-net r))
+ "???")) (list r))))))
+
+ (if (or (null new-record) (eq old-record new-record))
+ (error "those are the same"))
+ (setq new-record (bbdb-merge-records old-record new-record))
+
+ (bbdb-delete-current-record old-record 'noprompt)
+ (bbdb-change-record new-record t) ; don't always need-to-sort...
+ (let ((bbdb-display-layout nil))
+ (if (assq new-record bbdb-records)
+ (bbdb-redisplay-one-record new-record))
+ (bbdb-with-db-buffer
+ (if (not (memq new-record bbdb-changed-records))
+ (setq bbdb-changed-records
+ (cons new-record bbdb-changed-records))))
+ (if (null bbdb-records) ; nothing displayed, display something.
+ (bbdb-display-records (list new-record))))
+ (message "records merged."))
+
+;; sort the notes
+(defcustom bbdb-notes-sort-order
+ '((notes . 0) (www . 1) (ftp . 2) (gopher . 3) (telnet . 4) (mail-alias . 5)
+ (mail-folder . 6) (lpr . 7) (creation-date . 1000) (timestamp . 1001))
+ "*The order for sorting the notes.
+If a note is not in the alist, it is assigned weight 100, so all notes
+with weights less then 100 will be in the beginning, and all notes with
+weights more than 100 will be in the end."
+ :group 'bbdb-noticing-records
+ :type 'list)
+
+;;;###autoload
+(defun bbdb-sort-notes (rec)
+ "Sort the notes in the record according to `bbdb-notes-sort-order'.
+Can be used in `bbdb-change-hook'."
+ (flet ((kk (nt) (or (cdr (assq (car nt) bbdb-notes-sort-order)) 100)))
+ (bbdb-record-set-raw-notes
+ rec (sort (bbdb-record-raw-notes rec)
+ (lambda (aa bb) (< (kk aa) (kk bb)))))))
+
+;;;###autoload
+(defun bbdb-sort-phones (rec)
+ "Sort the phones in the record according to the location.
+Can be used in `bbdb-change-hook'."
+ (bbdb-record-set-phones
+ rec (sort (bbdb-record-phones rec)
+ (lambda (xx yy) (string< (aref xx 0) (aref yy 0))))))
+
+;;;###autoload
+(defun bbdb-sort-addresses (rec)
+ "Sort the addresses in the record according to the location.
+Can be used in `bbdb-change-hook'."
+ (bbdb-record-set-addresses
+ rec (sort (bbdb-record-addresses rec)
+ (lambda (xx yy) (string< (aref xx 0) (aref yy 0))))))
+
+
+;;; Send-Mail interface
+
+(defcustom bbdb-dwim-net-address-allow-redundancy nil
+ "*Non-nil means always use full name when sending mail, even if same as net."
+ :group 'bbdb
+ :type '(choice (const :tag "Disallow redundancy" nil)
+ (const :tag "Return only the net" 'netonly)
+ (const :tag "Allow redundancy" t)))
+
+(defcustom bbdb-dwim-net-address-title-field 'title
+ "*Non-nil should by a field to get the title from for prepending it."
+ :group 'bbdb
+ :type '(choice (const :tag "Do not append title." nil)
+ (const :tag "Append content of field 'title" 'title)
+ (symbol :tag "Field name")))
+
+;;;###autoload
+(defun bbdb-dwim-net-address (record &optional net)
+ "Return a string to use as the email address of the given record.
+It is formatted like \"Firstname Lastname <addr>\" unless both the first name
+and last name are constituents of the address, as in John.Doe@SomeHost, or the
+address is already in the form \"Name <foo>\" or \"foo (Name)\", in which case
+the address is used as-is.
+
+If the record has the field 'mail-name it is used instead of the record's name.
+
+If `bbdb-dwim-net-address-allow-redundancy' is non-nil, the name is always
+included. If `bbdb-dwim-net-address-allow-redundancy' is 'netonly the name is
+never included!
+
+A title is prepended from the field `bbdb-dwim-net-address-title-field' if it
+exists."
+ (or net (setq net (car (bbdb-record-net record))))
+ (or net (error "record unhas network addresses"))
+ (let* ((override (bbdb-record-getprop record 'mail-name))
+ (name (or override (bbdb-record-name record)))
+ title
+ fn ln (i 0))
+ (if override
+ (let ((both (bbdb-divide-name override)))
+ (setq fn (car both)
+ ln (car (cdr both)))
+ (if (equal fn "") (setq fn nil))
+ (if (equal ln "") (setq ln nil)))
+ (setq fn (bbdb-record-firstname record)
+ ln (bbdb-record-lastname record))
+ (if (setq title bbdb-dwim-net-address-title-field
+ title (if title (bbdb-record-getprop record title)))
+ (setq name (concat title " " name))))
+ ;; if the name contains backslashes or double-quotes, backslash them.
+ (if name
+ (while (setq i (string-match "[\\\"]" name i))
+ (setq name (concat (substring name 0 i) "\\" (substring name i))
+ i (+ i 2))))
+ (cond ((eq 'netonly bbdb-dwim-net-address-allow-redundancy)
+ net)
+ ((or (null name)
+ (if (not (or title bbdb-dwim-net-address-allow-redundancy))
+ (cond ((and fn ln)
+ (or (string-match
+ (concat "\\`[^!@%]*\\b" (regexp-quote fn)
+ "\\b[^!%@]+\\b" (regexp-quote ln) "\\b")
+ net)
+ (string-match
+ (concat "\\`[^!@%]*\\b" (regexp-quote ln)
+ "\\b[^!%@]+\\b" (regexp-quote fn) "\\b")
+ net)))
+ ((or fn ln)
+ (string-match
+ (concat "\\`[^!@%]*\\b" (regexp-quote (or fn ln)) "\\b")
+ net))))
+ ;; already in "foo <bar>" or "bar <foo>" format.
+ (string-match "\\`[ \t]*[^<]+[ \t]*<" net)
+ (string-match "\\`[ \t]*[^(]+[ \t]*(" net))
+ net)
+ ;; if the name contains control chars or RFC822 specials, it needs
+ ;; to be enclosed in quotes. Double-quotes and backslashes have
+ ;; already been escaped. This quotes a few extra characters as
+ ;; well (!,%, and $) just for common sense.
+ ((string-match "[][\000-\037\177()<>@,;:.!$%]" name)
+ (format "\"%s\" <%s>" name net))
+ (t
+ (format "%s <%s>" name net)))))
+
+
+(defun bbdb-send-mail-internal (&optional to subj records)
+ (let ((type (or bbdb-send-mail-style
+ ;; In Emacs, `compose-mail' gets whatever you've
+ ;; customized as your preferred `mail-user-agent'.
+ (cond ((fboundp 'compose-mail) 'compose-mail)
+ ((featurep 'mh-e) 'mh)
+ ((featurep 'vm) 'vm)
+ ((featurep 'message) 'message)
+ ((featurep 'mew) 'mew)
+ ((featurep 'gnus) 'gnus)
+ (t 'mail)))))
+ (cond
+ ((eq type 'mh)
+ (or (fboundp 'mh-send) (autoload 'mh-send "mh-e"))
+ (mh-send to "" (or subj "")))
+ ((eq type 'vm)
+ (cond ((not (fboundp 'vm-mail-internal))
+ (load-library "vm") ; 5.32 or later
+ (or (fboundp 'vm-mail-internal)
+ (load-library "vm-reply")))) ; 5.31 or earlier
+ (vm-session-initialization)
+ (if (not subj)
+ (vm-mail to)
+ (vm-mail-internal nil to subj)
+ (run-hooks 'vm-mail-hook)
+ (run-hooks 'vm-mail-mode-hook)))
+ ((eq type 'message)
+ (or (fboundp 'message-mail) (autoload 'message-mail "message"))
+ (message-mail to subj))
+ ((or (eq type 'mail) (eq type 'rmail))
+ (mail nil to subj))
+ ((eq type 'mew)
+ (or (fboundp 'mew-send) (load-library "mew"))
+ (mew-send to nil subj))
+ ((eq type 'compose-mail)
+ (compose-mail to subj))
+ ((eq type 'gnus)
+ (gnus-msg-mail to subj))
+ (t
+ (error "bbdb-send-mail-style must be vm, mh, message, compose-mail, or rmail")))))
+
+;;;###autoload
+(defun bbdb-send-mail (bbdb-record &optional subject)
+ "Compose a mail message to the person indicated by the current bbdb record.
+The first (most-recently-added) address is used if there are more than one.
+\\<bbdb-mode-map>
+If \"\\[bbdb-apply-next-command-to-all-records]\\[bbdb-send-mail]\" is \
+used instead of simply \"\\[bbdb-send-mail]\", then mail will be sent to \
+all of the
+folks listed in the *BBDB* buffer instead of just the person at point."
+ (interactive (list (if (bbdb-do-all-records-p)
+ (mapcar 'car bbdb-records)
+ (bbdb-current-record))))
+ (if (consp bbdb-record)
+ (bbdb-send-mail-many bbdb-record subject)
+ (bbdb-send-mail-1 bbdb-record subject)))
+
+
+(defun bbdb-send-mail-1 (bbdb-record &optional subject)
+ (if bbdb-inside-electric-display
+ (bbdb-electric-throw-to-execute
+ (list 'bbdb-send-mail bbdb-record subject)))
+ ;; else...
+
+ (cond ((null bbdb-record) (error "record unexists"))
+ ((null (bbdb-record-net bbdb-record))
+ (error "Current record unhas a network addresses."))
+ (t (bbdb-send-mail-internal (bbdb-dwim-net-address bbdb-record)
+ subject (list bbdb-record))
+ (if (re-search-backward "^Subject: $" nil t) (end-of-line)))))
+
+
+(defun bbdb-send-mail-many (records &optional subject)
+ (if bbdb-inside-electric-display
+ (bbdb-electric-throw-to-execute
+ (list 'bbdb-send-mail (list 'quote records) subject)))
+ ;; else...
+
+ (let ((good '()) (bad '())
+ (orec records))
+ (while records
+ (if (bbdb-record-net (car records))
+ (setq good (cons (car records) good))
+ (setq bad (cons (car records) bad)))
+ (setq records (cdr records)))
+ (bbdb-send-mail-internal
+ (mapconcat (lambda (x) (bbdb-dwim-net-address x))
+ (nreverse good) ",\n ")
+ subject orec)
+ (if (not bad) nil
+ (goto-char (point-max))
+ (let ((p (point))
+ (fill-prefix " ")
+ (fill-column 70))
+ (insert "*** Warning: No net addresses for "
+ (mapconcat (lambda (x) (bbdb-record-name x))
+ (nreverse bad) ", ") ".")
+ (fill-region-as-paragraph p (point))
+ (goto-char p))))
+ (if (re-search-backward "^Subject: $" nil t) (end-of-line)))
+
+
+(defun bbdb-yank-addresses ()
+ "CC the people displayed in the *BBDB* buffer on this message.
+The primary net-address of each of the records currently listed in the
+*BBDB* buffer (whether it is visible or not) will be appended to the
+CC: field of the current buffer (assuming the current buffer is a mail
+composition buffer.)"
+ (interactive)
+ (let ((addrs (save-excursion
+ (set-buffer bbdb-buffer-name)
+ (delq nil
+ (mapcar (lambda (x)
+ (if (bbdb-record-net (car x))
+ (bbdb-dwim-net-address (car x))
+ nil))
+ bbdb-records)))))
+ (goto-char (point-min))
+ ;; If there's a CC field, move to the end of it, inserting a comma if
+ ;; there are already addresses present.
+ ;; Otherwise, if there's an empty To: field, move to the end of it.
+ ;; Otherwise, insert an empty CC: field.
+ (if (re-search-forward "^CC:[ \t]*" nil t)
+ (if (eolp)
+ nil
+ (end-of-line)
+ (while (looking-at "\n[ \t]")
+ (forward-char) (end-of-line))
+ (insert ",\n")
+ (indent-relative))
+ (re-search-forward "^To:[ \t]*")
+ (if (eolp)
+ nil
+ (end-of-line)
+ (while (looking-at "\n[ \t]")
+ (forward-char) (end-of-line))
+ (insert ",\n")
+ (indent-relative))
+ (if (eolp)
+ nil
+ (end-of-line)
+ (while (looking-at "\n[ \t]")
+ (forward-char) (end-of-line))
+ (insert "\nCC:")
+ (indent-relative)))
+ ;; Now insert each of the addresses on its own line.
+ (while addrs
+ (insert (car addrs))
+ (if (cdr addrs) (progn (insert ",\n") (indent-relative)))
+ (setq addrs (cdr addrs)))))
+
+;;;###autoload
+(defun bbdb-show-all-recipients ()
+ "*Display BBDB records for all recipients of the message in this buffer."
+ (interactive)
+ (let ((marker (bbdb-header-start))
+ (fields '("from" "sender" "to" "cc" "bcc"
+ "resent-from" "resent-to" "resent-cc" "resent-bcc"))
+ addrs)
+ (message "Searching...")
+ (save-excursion
+ (set-buffer (marker-buffer marker))
+ (while fields
+ (goto-char marker)
+ (setq addrs (append (bbdb-split (or (bbdb-extract-field-value
+ (car fields))
+ "")
+ ",")
+ addrs)
+ fields (cdr fields))))
+ (let ((rest addrs)
+ (records '())
+ record)
+ (while rest
+ (setq record (bbdb-annotate-message-sender (car rest) t t t))
+ (if record (setq records (cons record records)))
+ (setq rest (cdr rest)))
+ (message "Sorting...")
+ (setq records (sort records (lambda (x y) (bbdb-record-lessp x y))))
+ (bbdb-display-records records))))
+
+
+;;; completion
+
+;;;###autoload
+(defun bbdb-completion-check-record (sym rec)
+ (let ((name (or (bbdb-record-name rec)
+ (bbdb-record-company rec)
+ ""))
+ (nets (bbdb-record-net rec))
+ ok)
+
+ (if (null bbdb-completion-type)
+ (setq ok 't)
+
+ (if (memq bbdb-completion-type
+ '(name primary-or-name name-or-primary))
+ (setq ok (string= sym (downcase name))))
+
+ ;; #### handle AKA, mail-name or mail-alias here?
+ (if ok '()
+ (when (eq bbdb-completion-type 'net)
+ (while (and nets (not ok))
+ (setq ok (string= sym (downcase (car nets)))
+ nets (cdr nets))))
+ (when (and nets (memq bbdb-completion-type
+ '(primary primary-or-name name-or-primary)))
+ (setq ok (string= sym (downcase (car nets)))))))
+ ok))
+
+
+;;;###autoload
+(defun bbdb-completion-predicate (symbol)
+ "For use as the third argument to `completing-read'.
+Obey the semantics of `bbdb-completion-type'."
+ (cond ((null bbdb-completion-type)
+ t)
+ ((not (boundp symbol))
+ nil)
+ (t
+ (let ((sym (symbol-name symbol))
+ (recs (symbol-value symbol))
+ ok)
+ (while (and recs (not ok))
+ (setq ok (bbdb-completion-check-record sym (car recs))
+ recs (cdr recs)))
+ ok))))
+
+(defun bbdb-completing-read-record (prompt &optional omit-records)
+ "Prompt for and return a record from the bbdb.
+Completion is done according to `bbdb-completion-type'. If the user
+just hits return, nil is returned. Otherwise, a valid response is forced."
+ (let* ((ht (bbdb-hashtable))
+ (completion-ignore-case 't)
+ (string (completing-read prompt ht 'bbdb-completion-predicate t))
+ (symbol (and (not (= 0 (length string)))
+ (intern-soft string ht))))
+ (if symbol
+ (if (and (boundp symbol) (symbol-value symbol))
+ (let ((recs (symbol-value symbol)) ret)
+ (while recs
+ (if (and (not (memq (car recs) omit-records))
+ (bbdb-completion-check-record (symbol-name symbol)
+ (car recs)))
+ (setq ret (cons (car recs) ret)))
+ (setq recs (cdr recs)))
+ ret)
+ (error "selecting deleted (unhashed) record \"%s\"!" symbol))
+ nil)))
+
+(defun bbdb-completing-read-one-record (prompt &optional omit-records)
+ "Prompt for and return a single record from the bbdb;
+completion is done according to `bbdb-completion-type'. If the user
+just hits return, nil is returned. Otherwise, a valid response is forced.
+if omit-records is non-nil it should be a list of records to dis-allow
+completion with."
+ (let ((records (bbdb-remove-memq-duplicates
+ (bbdb-completing-read-record prompt omit-records))))
+ (cond
+ ((eq (length records) 1)
+ (car records))
+ ((> (length records) 1)
+ (let ((count (length records))
+ prompts result)
+ (bbdb-display-records records)
+ (while (> count 0)
+ (setq prompts (cons (list (number-to-string count) count) prompts)
+ count (1- count)))
+ (setq result
+ (completing-read (format "Which duplicate record (1-%s): "
+ (length records))
+ prompts nil t "1"))
+ (nth (1- (string-to-number result)) records)))
+ (t
+ nil))))
+
+(defvar bbdb-read-addresses-with-completion-map
+ (let ((map (copy-keymap minibuffer-local-completion-map)))
+ (define-key map " " 'self-insert-command)
+ (define-key map "\t" 'bbdb-complete-name)
+ (define-key map "\M-\t" 'bbdb-complete-name)
+ map))
+
+;;;###autoload
+(defun bbdb-read-addresses-with-completion (prompt &optional default)
+ "Like `read-string', but allows `bbdb-complete-name' style completion."
+ (read-from-minibuffer prompt default
+ bbdb-read-addresses-with-completion-map))
+
+
+;; Internal use. Store the window configuration before we pop up the
+;; completion buffer.
+(defvar bbdb-complete-name-saved-window-config nil)
+
+;; Restore the saved window configuration
+(defun bbdb-complete-name-cleanup ()
+ (if bbdb-complete-name-saved-window-config
+ (progn
+ (if (get-buffer-window "*Completions*")
+ (progn
+ (set-window-configuration
+ bbdb-complete-name-saved-window-config)
+ (bury-buffer "*Completions*"))
+ )
+ (setq bbdb-complete-name-saved-window-config nil))))
+
+(defvar bbdb-complete-name-callback-data nil
+ "Stores the buffer and region start and end of the completed string.
+This is set in the *Completions* buffer.
+It is set in `bbdb-display-completion-list' and used in the advice
+`choose-completion-string'.")
+
+(make-variable-buffer-local 'bbdb-complete-name-callback-data)
+
+(defun bbdb-display-completion-list (list &optional callback data)
+ "Wrapper for `display-completion-list'.
+GNU Emacs requires DATA to be in a specific format, viz. (nth 1 data) should
+be a marker for the start of the region being completed."
+ ;; disgusting hack to make GNU Emacs nuke the bit you've typed
+ ;; when it inserts the completion.
+ (setq bbdb-complete-name-callback-data data)
+ (if (featurep 'xemacs)
+ (display-completion-list list :activate-callback callback
+ :user-data data)
+ (display-completion-list list)))
+
+(defadvice choose-completion-string (before bbdb-complete-fix activate)
+ "Deletes the completed string before replacing.
+We need to do this as we are abusing completion and it was not meant to work
+in buffer other than the mini buffer."
+ (when bbdb-complete-name-callback-data
+ (save-excursion
+ (set-buffer (car bbdb-complete-name-callback-data))
+ (apply 'delete-region (cdr bbdb-complete-name-callback-data)))))
+
+(defcustom bbdb-complete-name-allow-cycling t
+ "Whether to allow cycling of email addresses when calling
+`bbdb-complete-name' on a completed address in a composition buffer."
+ :group 'bbdb-mua-specific
+ :type 'boolean)
+
+(defun bbdb-complete-clicked-name (event extent user-data)
+ "Find the record for a name clicked in a completion buffer.
+Currently only used by XEmacs."
+ (let ((buffer (nth 0 user-data))
+ (bbdb-complete-name-allow-cycling nil)
+ (beg (nth 1 user-data))
+ (end (nth 2 user-data)))
+ (bbdb-complete-name-cleanup)
+ (set-buffer buffer)
+ (goto-char beg)
+ (delete-region beg end)
+ (insert (bbdb-extent-string extent))
+ (bbdb-complete-name beg)))
+
+
+(defun bbdb-list-overlap (l1 l2)
+ (let (ok)
+ (while (and (not ok) l1)
+ (if (memq (car l1) l2) (setq ok t l1 '())
+ (setq l1 (cdr l1))))
+ ok))
+
+(defun bbdb-remove-assoc-duplicates (l)
+ (if (null l) '()
+ (if (assoc (car (car l)) (cdr l))
+ (bbdb-remove-assoc-duplicates (cdr l))
+ (cons (car l) (bbdb-remove-assoc-duplicates (cdr l))))))
+
+(defcustom bbdb-complete-name-hooks nil
+ "List of functions called after a sucessful completion."
+ :group 'bbdb-mua-specific
+ :type 'boolean)
+
+(eval-when-compile (defvar auto-fill-hook))
+
+;;;###autoload
+(defun bbdb-complete-name (&optional start-pos)
+ "Complete the user full-name or net-address before point (up to the
+preceeding newline, colon, or comma, or the value of START-POS). If
+what has been typed is unique, insert an entry of the form \"User Name
+<net-addr>\" (although see documentation for
+bbdb-dwim-net-address-allow-redundancy). If it is a valid completion
+but not unique, a list of completions is displayed.
+
+If the completion is done and `bbdb-complete-name-allow-cycling' is
+true then cycle through the nets for the matching record.
+
+When called with a prefix arg then display a list of all nets.
+
+Completion behaviour can be controlled with `bbdb-completion-type'."
+ (interactive)
+
+ (let* ((end (point))
+ (beg (or start-pos
+ (save-excursion
+ (re-search-backward "\\(\\`\\|[\n:,]\\)[ \t]*")
+ (goto-char (match-end 0))
+ (point))))
+ (orig (buffer-substring beg end))
+ (typed (downcase orig))
+ (pattern (bbdb-string-trim typed))
+ (ht (bbdb-hashtable))
+ ;; make a list of possible completion strings
+ ;; (all-the-completions), and a flag to indicate if there's a
+ ;; single matching record or not (only-one-p)
+ (only-one-p t)
+ (all-the-completions nil)
+ (pred
+ (lambda (sym)
+ (when (bbdb-completion-predicate sym)
+ (if (and only-one-p
+ all-the-completions
+ (or
+ ;; not sure about this. more than one record
+ ;; attached to the symbol? does that happen?
+ (> (length (symbol-value sym)) 1)
+ ;; this is the doozy, though. multiple syms
+ ;; which all match the same record
+ (delete t (mapcar (lambda(x)
+ (equal (symbol-value x)
+ (symbol-value sym)))
+ all-the-completions))))
+ (setq only-one-p nil))
+ (if (not (memq sym all-the-completions))
+ (setq all-the-completions (cons sym all-the-completions))))))
+ (completion (progn (all-completions pattern ht pred) (try-completion pattern ht)))
+ (exact-match (eq completion t)))
+
+ (cond
+ ;; No matches found OR you're trying completion on an
+ ;; already-completed record. In the latter case, we might have to
+ ;; cycle through the nets for that record.
+ ((or (null completion)
+ (and bbdb-complete-name-allow-cycling
+ exact-match ;; which is a net of the record
+ (member orig
+ (bbdb-record-net
+ (car (symbol-value (intern-soft pattern ht)))))))
+ ;; Clean up the completion buffer, if it exists
+ (bbdb-complete-name-cleanup)
+ ;; Check for cycling
+ (or (catch 'bbdb-cycling-exit
+ ;; jump straight out if we're not cycling
+ (or bbdb-complete-name-allow-cycling
+ (throw 'bbdb-cycling-exit nil))
+
+ ;; find the record we're working on.
+ (let* ((addr (funcall bbdb-extract-address-components-func orig))
+ (rec
+ (if (listp addr)
+ ;; for now, we're ignoring the case where this
+ ;; returns more than one record. Ideally, the
+ ;; last expansion would be stored in a
+ ;; buffer-local variable, perhaps.
+ (car (bbdb-search-intertwingle (caar addr)
+ (cadar addr)))
+ nil)))
+ (or rec
+ (throw 'bbdb-cycling-exit nil))
+
+ (if current-prefix-arg
+ ;; use completion buffer
+ (let ((standard-output (get-buffer-create "*Completions*")))
+ ;; a previously existing buffer has to be cleaned first
+ (save-excursion (set-buffer standard-output)
+ (setq buffer-read-only nil)
+ (erase-buffer))
+ (display-completion-list
+ (mapcar (lambda (n) (bbdb-dwim-net-address rec n))
+ (bbdb-record-net rec)))
+ (delete-region beg end)
+ (switch-to-buffer standard-output))
+ ;; use next address
+ (let* ((addrs (bbdb-record-net rec))
+ (this-addr (or (cadr (member (car (cdar addr)) addrs))
+ (nth 0 addrs))))
+ (if (= (length addrs) 1)
+ ;; no alternatives. don't signal an error.
+ (throw 'bbdb-cycling-exit t)
+ ;; replace with new mail address
+ (delete-region beg end)
+ (insert (bbdb-dwim-net-address rec this-addr))
+ (run-hooks 'bbdb-complete-name-hooks)
+ (throw 'bbdb-cycling-exit t))))))
+
+ ;; FALL THROUGH
+ ;; Check mail aliases
+ (if (and bbdb-expand-mail-aliases (expand-abbrev))
+ ()
+ (when bbdb-complete-name-hooks
+ (message "completion for \"%s\" unfound." pattern)
+ (ding)))));; no matches, sorry!
+
+ ;; Match for a single record. If cycling is enabled then we don't
+ ;; care too much about the exact-match part.
+ ((and only-one-p (or exact-match bbdb-complete-name-allow-cycling))
+ (let* ((sym (if exact-match (intern-soft pattern ht) (car all-the-completions)))
+ (recs (symbol-value sym))
+ the-net match-recs lst primary matched)
+
+ (while recs
+ (when (bbdb-record-net (car recs))
+
+ ;; Did we match on name?
+ (let ((b-r-name (or (bbdb-record-name (car recs)) "")))
+ (if (string= pattern
+ (substring (downcase b-r-name) 0
+ (min (length b-r-name)
+ (length pattern))))
+ (setq match-recs (cons (car recs) match-recs)
+ matched t)))
+
+ ;; Did we match on lastname?
+ (let ((b-r-name (or (bbdb-record-lfname (car recs)) "")))
+ (if (string= pattern
+ (substring (downcase b-r-name) 0
+ (min (length b-r-name)
+ (length pattern))))
+ (setq match-recs (cons (car recs) match-recs)
+ matched t)))
+
+ ;; Did we match on aka?
+ (when (not matched)
+ (setq lst (bbdb-record-aka (car recs)))
+ (while lst
+ (if (string= pattern (substring (downcase (car lst)) 0
+ (min (length (downcase
+ (car
+ lst)))
+ (length pattern))))
+ (setq match-recs (append match-recs (list (car recs)))
+ matched t
+ lst '())
+ (setq lst (cdr lst)))))
+
+ ;; Name didn't match name so check net matching
+ (when (not matched)
+ (setq lst (bbdb-record-net (car recs)))
+ (setq primary t) ;; primary wins over secondary...
+ (while lst
+ (if (string= pattern (substring (downcase (car lst))
+ 0 (min (length
+ (downcase (car
+ lst)))
+ (length pattern))))
+ (setq the-net (car lst)
+ lst nil
+ match-recs
+ (if primary (cons (car recs) match-recs)
+ (append match-recs (list (car recs))))))
+ (setq lst (cdr lst)
+ primary nil))))
+
+ ;; loop to next rec
+ (setq recs (cdr recs)
+ matched nil))
+
+ (unless match-recs
+ (error "only exact matching record unhas net field"))
+
+ ;; now replace the text with the expansion
+ (delete-region beg end)
+ (insert (bbdb-dwim-net-address (car match-recs) the-net))
+
+ ;; if we're past fill-column, wrap at the previous comma.
+ (if (and
+ (bbdb-auto-fill-function)
+ (>= (current-column) fill-column))
+ (let ((p (point))
+ bol)
+ (save-excursion
+ (beginning-of-line)
+ (setq bol (point))
+ (goto-char p)
+ (if (search-backward "," bol t)
+ (progn
+ (forward-char 1)
+ (insert "\n "))))))
+
+ ;; Update the *BBDB* buffer if desired.
+ (if bbdb-completion-display-record
+ (let ((bbdb-gag-messages t))
+ (bbdb-display-records-1 match-recs t)))
+ (bbdb-complete-name-cleanup)
+
+ ;; call the exact-completion hook
+ (run-hooks 'bbdb-complete-name-hooks)))
+
+ ;; Partial match
+ ;; note, we can't use the trimmed version of the pattern here or
+ ;; we'll recurse infinitely on e.g. common first names
+ ((and (stringp completion) (not (string= typed completion)))
+ (delete-region beg end)
+ (insert completion)
+ (setq end (point))
+ (let ((last "")
+ (bbdb-complete-name-allow-cycling nil))
+ (while (and (stringp completion)
+ (not (string= completion last))
+ (setq last completion
+ pattern (downcase orig)
+ completion (progn (all-completions pattern ht pred) (try-completion pattern ht))))
+ (if (stringp completion)
+ (progn (delete-region beg end)
+ (insert completion))))
+ (bbdb-complete-name beg)))
+
+ ;; Exact match, but more than one record
+ (t
+ (or (eq (selected-window) (minibuffer-window))
+ (message "Making completion list..."))
+
+ (let (dwim-completions
+ uniq nets net name lfname akas)
+ ;; Now collect all the dwim-addresses for each completion, but only
+ ;; once for each record! Add it if the net is part of the completions
+ (bbdb-mapc
+ (lambda (sym)
+ (bbdb-mapc
+ (lambda (rec)
+ (when (not (member rec uniq))
+ (setq uniq (cons rec uniq)
+ nets (bbdb-record-net rec)
+ name (downcase (or (bbdb-record-name rec) ""))
+ lfname (downcase (or (bbdb-record-lfname rec) ""))
+ akas (mapcar 'downcase (bbdb-record-aka rec)))
+ (while nets
+ (setq net (car nets))
+ (when (cond
+ ;; primary
+ ((and (member bbdb-completion-type
+ '(primary primary-or-name))
+ (member (intern-soft (downcase net) ht)
+ all-the-completions))
+ (setq nets nil)
+ t)
+ ;; name
+ ((and name (member bbdb-completion-type
+ '(nil name primary-or-name))
+ (let ((cname (symbol-name sym)))
+ (or (string= cname name)
+ (string= cname lfname)
+ (member cname akas))))
+ (setq name nil)
+ t)
+ ;; net
+ ((and (member bbdb-completion-type
+ '(nil net))
+ (member (intern-soft (downcase net) ht)
+ all-the-completions)))
+ ;; (name-or-)primary
+ ((and (member bbdb-completion-type
+ '(name-or-primary))
+ (let ((cname (symbol-name sym)))
+ (or (string= cname name)
+ (string= cname lfname)
+ (member cname akas))))
+ (setq nets nil)
+ t)
+ )
+ (setq dwim-completions
+ (cons (bbdb-dwim-net-address rec net)
+ dwim-completions))
+ (if exact-match (setq nets nil)))
+ (setq nets (cdr nets)))))
+ (symbol-value sym)))
+ all-the-completions)
+
+ ;; if, after all that, we've only got one matching record...
+ (if (and dwim-completions (null (cdr dwim-completions)))
+ (progn
+ (delete-region beg end)
+ (insert (car dwim-completions))
+ (message ""))
+ ;; otherwise, pop up a completions window
+ (if (not (get-buffer-window "*Completions*"))
+ (setq bbdb-complete-name-saved-window-config
+ (current-window-configuration)))
+ (let ((arg (list (current-buffer)
+ (set-marker (make-marker) beg)
+ (set-marker (make-marker) end))))
+ (with-output-to-temp-buffer "*Completions*"
+ (bbdb-display-completion-list
+ dwim-completions
+ 'bbdb-complete-clicked-name
+ arg)))
+ (or (eq (selected-window) (minibuffer-window))
+ (message "Making completion list...done"))))))))
+
+;;;###autoload
+(defun bbdb-yank ()
+ "Insert the current contents of the *BBDB* buffer at point."
+ (interactive)
+ (insert (let ((b (current-buffer)))
+ (set-buffer bbdb-buffer-name)
+ (prog1 (buffer-string) (set-buffer b)))))
+
+
+;;; interface to mail-abbrevs.el.
+
+(defcustom bbdb-define-all-aliases-field 'mail-alias
+ "*The field which `bbdb-define-all-aliases' searches for."
+ :group 'bbdb
+ :type 'symbol)
+
+(defun bbdb-magic-net-* (include &optional exclude primary-only)
+ "Return list of expanded email addresses matching regexp INCLUDE.
+Exclude those matching the regexp EXCLUDE. When PRIMARY-ONLY is t
+only work on the primary net of records."
+ (let ((records (bbdb-records))
+ expanded
+ r n nets)
+ (while records
+ (setq r (car records)
+ nets (bbdb-record-net r))
+ (while nets
+ (setq n (car nets))
+ (if (and (not (= (aref n 0) ?\())
+ (not (= (aref n 1) ?/))
+ (string-match include n)
+ (or (not exclude) (not (string-match exclude n))))
+ (setq expanded (cons (bbdb-dwim-net-address r n) expanded)))
+ (setq nets (if primary-only nil (cdr nets))))
+ (setq records (cdr records)))
+ expanded))
+
+(defun bbdb-magic-net-1 (include &optional exclude)
+ "Return list of expanded primary nets matching regexp INCLUDE.
+Exclude those matching the regexp EXCLUDE."
+ (bbdb-magic-net-* include exclude t))
+
+;(and (pp (bbdb-collect-all-aliases) (get-buffer "*scratch*")) nil)
+(defun bbdb-collect-all-aliases ()
+ "Return an alist of (alias (rec1 emails) [(rec2 emails) ...]) elements.
+Does the magic alias handling described in `bbdb-define-all-aliases'."
+ (let* ((aliases-field bbdb-define-all-aliases-field)
+ (target (cons bbdb-define-all-aliases-field "."))
+ (records (bbdb-search (bbdb-records) nil nil nil target))
+ nets aliases result)
+ (dolist (r records)
+ (setq nets (bbdb-record-net r))
+ (if (null nets)
+ (if (not bbdb-silent-running)
+ (bbdb-warn
+ "record %S has no network address, but the aliases: %s"
+ (bbdb-record-name r)
+ (bbdb-record-getprop r aliases-field)))
+ (setq aliases (bbdb-split (bbdb-record-getprop r aliases-field) ","))
+ (while aliases
+ (let* ((alias (car aliases))
+ match item)
+ ;; extract the nets based on the alias
+ (cond ((string-match "^\\(.+\\)\\*$" alias)
+ ;; all nets of the record
+ (setq alias (match-string 1 alias)
+ item nets))
+ ((string-match "^\\(.+\\)\\[\\([0-9]+\\)\\]$" alias)
+ ;; the NTH net of the record
+ (setq item (string-to-number (match-string 2 alias))
+ item (list (or (nth item nets)
+ (error
+ "net[%d] for alias %S does not exist!"
+ item alias)))
+ alias (match-string 1 alias)))
+ ((string-match "^\\(.+\\)/\\(.+\\)$" alias)
+ ;; all nets of the record matching a regexp
+ (let ((r (match-string 2 alias)))
+ (setq alias (match-string 1 alias))
+ (setq item (mapcar (lambda (n)
+ (if (string-match r n)
+ n))
+ nets)
+ item (delete nil item))))
+ (t
+ (setq item (list (car nets)))))
+ (when item
+ (setq item (list r item))
+ (if (setq match (assoc alias result))
+ (nconc match (cons item nil))
+ (setq result (cons (list alias item) result))))
+ (setq aliases (cdr aliases))))))
+ result))
+
+(defun bbdb-expand-alias (alias-items aliases &optional seen-aliases)
+ "Return the list (alias record-list expanded-nets-list).
+
+ALIAS-ITEMS are elements of the list returned by `bbdb-collect-all-aliases'.
+Does the actual formatting and handling of magic nets as described in
+`bbdb-define-all-aliases'.
+
+Nets which do not contain an \"@\" and exist as alias in ALIASES are expanded
+recursively. SEEN-ALIASES will be filled with the aliases already seen and
+checked to detect cycles.
+
+Other nets are formatted by `bbdb-dwim-net-address'."
+ (let ((alias (car alias-items))
+ (items (cdr alias-items))
+ rec nets n r
+ records result)
+ (if (member alias seen-aliases)
+ (error "Alias cycle during recursive expansion. Alias %S already seen in %S"
+ alias seen-aliases))
+ (setq seen-aliases (cons alias seen-aliases))
+ (while items
+ (setq rec (car items)
+ nets (car (cdr rec))
+ rec (car rec)
+ records (cons rec records))
+ (while nets
+ (setq n (car nets))
+ (cond ((string-match "^\\([^/]+\\)/\\(.*\\)$" n)
+ (setq n (funcall (intern (format "bbdb-magic-net-%s"
+ (match-string 1 n)))
+ (match-string 2 n))))
+ ((= ?\( (aref n 0))
+ (setq r (read n))
+ (setq n (apply (intern (format "bbdb-magic-net-%s"
+ (car r)))
+ (cdr r))))
+ ((and (not (string-match "@" n)) (setq r (assoc n aliases)))
+ (setq n (bbdb-expand-alias r aliases seen-aliases)
+ records (append (nth 1 n) records)
+ n (nth 2 n)))
+ (t
+ (setq n (list (bbdb-dwim-net-address rec n)))))
+ (setq result (append n result))
+ (setq nets (cdr nets)))
+ (setq items (cdr items)))
+ (list alias records result)))
+
+;(and (pp (bbdb-expand-all-aliases) (get-buffer "*scratch*")) nil)
+(defun bbdb-all-aliases-expanded ()
+ "Return an alist (alias record-list net-list) elements."
+ (let ((aliases (reverse (bbdb-collect-all-aliases)))
+ as result)
+ (setq as aliases)
+ (while as
+ (setq result (cons (bbdb-expand-alias (car as) aliases) result))
+ (setq as (cdr as)))
+ result))
+
+;;;###autoload
+(defun bbdb-define-all-aliases ()
+ "Define mail aliases for some of the records in the database.
+Every record which has a `mail-alias' field \(but see
+`bbdb-define-all-aliases-field') will have a mail alias defined for it
+which is the contents of that field. If there are multiple
+comma-separated words in this field, then all of those words will be
+defined as aliases for that record.
+
+If multiple entries in the database have the same mail alias, then
+that alias expands to a comma-separated list of the primary network
+addresses of all of those people.
+
+An alias ending in \"*\" will expand to all the nets of the record.
+An alias ending in \"[NTH]\" will expand the the NTH net of the
+record.
+
+Special nets exist and expand to other nets using one of
+`bbdb-magic-net-*', `bbdb-magic-net-1' or `bbdb-magic-net-SOMETHING'.
+Magic nets may not contain any comma character. If you need one, please
+put it into a custom magic net function or use the octal escape
+sequence \"\\054\".
+
+Nets matching \"FUNCTION/ARG\" (i.e. containing at least one \"/\")
+will be passed to the function `bbdb-magic-net-FUNCTION' with the
+string argument ARG.
+
+Nets starting with a \"(\" will be considered as a lisp list where the
+first element is prefixed by `bbdb-magic-net-' and then called as a
+function with the rest of the list as arguments.
+
+Nets which do not contain an \"@\" character and also exist as aliases
+are expanded recursively. This can be used to define hierarchical
+aliases.
+
+Other nets are formatted by `bbdb-dwim-net-address'."
+ (interactive "")
+ (let* ((use-abbrev-p (fboundp 'define-mail-abbrev))
+ (abbrev-handler (if use-abbrev-p
+ 'define-mail-abbrev
+ 'define-mail-alias))
+ (abbrev-table (if use-abbrev-p
+ 'mail-abbrevs
+ 'mail-aliases))
+ (mail-alias-separator-string (if (boundp 'mail-alias-separator-string)
+ mail-alias-separator-string
+ ", "))
+ (aliases (bbdb-all-aliases-expanded))
+ records alias nets expansion)
+
+ (if use-abbrev-p
+ nil
+ ;; clear abbrev-table
+ (setq mail-aliases nil)
+ ;; arrange rebuilt if necessary, this should be done by
+ ;; mail-pre-abbrev-expand-hook, but there is none!
+ (defadvice sendmail-pre-abbrev-expand-hook
+ (before bbdb-rebuilt-all-aliases activate)
+ (bbdb-rebuilt-all-aliases)))
+
+ ;; iterate over the results and create the aliases
+ (while aliases
+ (setq alias (car aliases)
+ records (nth 1 alias)
+ nets (nth 2 alias)
+ alias (car alias)
+ expansion (mapconcat 'identity nets mail-alias-separator-string))
+ (funcall abbrev-handler alias expansion)
+ (setq alias (or (intern-soft (downcase alias)
+ (symbol-value abbrev-table))
+ (error "couldn't find the alias we just defined!")))
+ (or (eq (symbol-function alias) 'mail-abbrev-expand-hook)
+ (error "mail-aliases contains unexpected hook %s"
+ (symbol-function alias)))
+ (fset alias (list 'lambda '()
+ (list 'bbdb-mail-abbrev-expand-hook
+ alias (list 'quote
+ (mapcar (lambda (e)
+ (car (bbdb-record-net e)))
+ records)))))
+ (setq aliases (cdr aliases)))))
+
+;; We should be cleverer here and instead of rebuilding all aliases we should
+;; just do what's necessary, i.e. remove deleted records and add new records
+(defun bbdb-rebuilt-all-aliases ()
+ (let ((needs-rebuilt bbdb-define-all-aliases-needs-rebuilt))
+ (when needs-rebuilt
+ (if (not bbdb-silent-running)
+ (message "Rebuilding aliases due to %s aliases." needs-rebuilt))
+ (setq bbdb-define-all-aliases-needs-rebuilt nil)
+ (bbdb-define-all-aliases))))
+
+(defcustom bbdb-mail-abbrev-expand-hook nil
+ "*Hook or hooks invoked each time an alias is expanded.
+The hook is called with two arguments the alias and the list of nets."
+ :group 'bbdb-hooks
+ :type 'hook)
+
+(defun bbdb-mail-abbrev-expand-hook (alias nets)
+ "The abbrev-hook is called with a list of network addresses NETS.
+ALIAS and NETS is passed to the other hooks in `bbdb-mail-abbrev-expand-hook'.
+Thus we do not keep pointers to bbdb records, which would lose if
+the database was reverted. It uses `bbdb-search-simple' to convert
+these to records, which is plenty fast."
+ (when bbdb-completion-display-record
+ (let ((bbdb-gag-messages t))
+ (bbdb-display-records-1
+ (mapcar (lambda (n) (bbdb-search-simple nil n)) nets)
+ t)))
+ (run-hook-with-args 'bbdb-mail-abbrev-expand-hook alias nets)
+ (mail-abbrev-expand-hook))
+
+(defun bbdb-get-mail-aliases ()
+ "Return a list of mail aliases used in the BBDB.
+The format is suitable for `completing-read'."
+ (let* ((target (cons bbdb-define-all-aliases-field "."))
+ (records (bbdb-search (bbdb-records) nil nil nil target))
+ result aliases)
+ (while records
+ (setq aliases (bbdb-split
+ (bbdb-record-getprop (car records)
+ bbdb-define-all-aliases-field)
+ ","))
+ (while aliases
+ (add-to-list 'result (list (car aliases)))
+ (setq aliases (cdr aliases)))
+ (setq records (cdr records)))
+ result))
+
+;;;###autoload
+(defun bbdb-add-or-remove-mail-alias (&optional records newalias delete)
+ "Add NEWALIAS in all RECORDS or remove it if DELETE it t.
+When called with prefix argument it will remove the alias.
+We honor `bbdb-apply-next-command-to-all-records'!
+The new alias will only be added if it isn't there yet."
+ (interactive (list (if (bbdb-do-all-records-p) 'all 'one)
+ (completing-read
+ (format "%s mail alias: " (if current-prefix-arg "Remove" "Add"))
+ (bbdb-get-mail-aliases))
+ current-prefix-arg))
+ (setq newalias (bbdb-string-trim newalias))
+ (setq newalias (if (string= "" newalias) nil newalias))
+ (let* ((propsym bbdb-define-all-aliases-field)
+ (do-all-p (if (equal records 'one) nil t))
+ (records (cond ((equal records 'all) (mapcar 'car bbdb-records))
+ ((equal records 'one) (list (bbdb-current-record t)))
+ (t records))))
+ (while records
+ (let* ((record (car records))
+ (oldaliases (bbdb-record-getprop record propsym)))
+ (if oldaliases (setq oldaliases (bbdb-split oldaliases ",")))
+ (if delete (setq oldaliases (delete newalias oldaliases))
+ (add-to-list 'oldaliases newalias))
+ (setq oldaliases (bbdb-join oldaliases ", "))
+ (bbdb-record-putprop record propsym oldaliases))
+ (setq records (cdr records)))
+ (if do-all-p
+ (bbdb-redisplay-records)
+ (bbdb-redisplay-one-record (bbdb-current-record))))
+ (setq bbdb-define-all-aliases-needs-rebuilt
+ (if delete
+ 'deleted
+ (if (bbdb-record-net (bbdb-current-record))
+ 'new
+ nil))))
+
+;;; Dialing numbers from BBDB
+(defcustom bbdb-dial-local-prefix-alist
+ '(((if (integerp bbdb-default-area-code)
+ (format "(%03d)" bbdb-default-area-code)
+ (or bbdb-default-area-code ""))
+ ""))
+ "Mapping to remove local prefixes from numbers.
+If this is non-nil, it should be an alist of
+(PREFIX REPLACEMENT) elements. The first part of a phone number
+matching the regexp returned by evaluating PREFIX will be replaced by
+the corresponding REPLACEMENT when dialing."
+ :group 'bbdb-phone-dialing
+ :type 'sexp)
+
+(defcustom bbdb-dial-local-prefix nil
+ "Local prefix digits.
+If this is non-nil, it should be a string of digits which your phone
+system requires before making local calls (for example, if your phone system
+requires you to dial 9 before making outside calls.) In BBDB's
+opinion, you're dialing a local number if it starts with a 0 after
+processing bbdb-dial-local-prefix-alist."
+ :group 'bbdb-phone-dialing
+ :type '(choice (const :tag "No digits required" nil)
+ (string :tag "Dial this first" "9")))
+
+(defcustom bbdb-dial-long-distance-prefix nil
+ "Long distance prefix digits.
+If this is non-nil, it should be a string of digits which your phone
+system requires before making a long distance call (one not in your local
+area code). For example, in some areas you must dial 1 before an area
+code. Note that this is used to replace the + sign in phone numbers
+when dialling (international dialing prefix.)"
+ :group 'bbdb-phone-dialing
+ :type '(choice (const :tag "No digits required" nil)
+ (string :tag "Dial this first" "1")))
+
+(defcustom bbdb-sound-player nil
+ "The program to be used to play the sounds for the touch-tone digits."
+ :group 'bbdb-phone-dialing
+ :type '(choice (const :tag "No External Player" nil)
+ (file :tag "Sound Player" "/usr/local/bin/play")))
+
+(defcustom bbdb-sound-files
+ '["/usr/demo/SOUND/sounds/touchtone.0.au"
+ "/usr/demo/SOUND/sounds/touchtone.1.au"
+ "/usr/demo/SOUND/sounds/touchtone.2.au"
+ "/usr/demo/SOUND/sounds/touchtone.3.au"
+ "/usr/demo/SOUND/sounds/touchtone.4.au"
+ "/usr/demo/SOUND/sounds/touchtone.5.au"
+ "/usr/demo/SOUND/sounds/touchtone.6.au"
+ "/usr/demo/SOUND/sounds/touchtone.7.au"
+ "/usr/demo/SOUND/sounds/touchtone.8.au"
+ "/usr/demo/SOUND/sounds/touchtone.9.au"
+ "/usr/demo/SOUND/sounds/touchtone.pound.au"
+ "/usr/demo/SOUND/sounds/touchtone.star.au"]
+ "A vector of ten sound files to be used for dialing. They
+correspond to the 0, 1, 2, ... 9 digits, pound and star, respectively."
+ :group 'bbdb-phone-dialing
+ :type 'vector)
+
+(defcustom bbdb-modem-dial nil
+ "Type of dialing to use.
+If this value is nil, the audio device is used for dialing. Otherwise,
+this string is fed to the modem before the phone number digits."
+ :group 'bbdb-phone-dialing
+ :type '(choice (const :tag "audio" nil)
+ (string :tag "tone dialing" "ATDT ")
+ (string :tag "pulse dialing" "ATDP ")))
+
+(defcustom bbdb-modem-device "/dev/modem"
+ "The name of the modem device.
+This is only used if bbdb-modem-dial is set to something other than nil."
+ :group 'bbdb-phone-dialing
+ :type 'string)
+
+(defcustom bbdb-sound-volume 50
+ "The volume to play back dial tones at. The range is 0 to 100.
+This is only used if bbdb-modem-dial is set to nil."
+ :group 'bbdb-phone-dialing
+ :type 'integer)
+
+(defun bbdb-play-sound (num &optional volume)
+ "Play the specified touchtone number NUM at VOLUME.
+Uses external program `bbdb-sound-player' if set, otherwise
+try to use internal sound if available."
+ (if (and (not bbdb-sound-player) (featurep 'native-sound))
+ ;; This requires the sound files to be loaded via bbdb-xemacs.
+ (apply 'play-sound (list (intern (format "touchtone%d" num))
+ bbdb-sound-volume))
+ (if (and (not (featurep 'xemacs))
+ ;; We can't tell a priori if Emacs 21 facility will
+ ;; actually work.
+ (condition-case nil
+ (play-sound (list 'sound
+ :file (aref bbdb-sound-files
+ (string-to-number num))
+ :volume (or volume bbdb-sound-volume)))
+ (error nil)))
+ (if (and bbdb-sound-player
+ (file-exists-p bbdb-sound-player))
+ (call-process bbdb-sound-player nil nil nil
+ (aref bbdb-sound-files num))
+ (error "BBDB has no means of playing sound.")))))
+
+(eval-and-compile
+ (if (fboundp 'next-event)
+ (fset 'bbdb-next-event 'next-event)
+ (fset 'bbdb-next-event 'read-event)))
+
+(defun bbdb-dial-number (phone-string)
+ "Dial the number specified by PHONE-STRING.
+The number is dialed either by playing touchtones through the audio
+device using bbdb-sound-player, or by sending a dial sequence to
+bbdb-modem-device. # and * are dialed as-is, and a space is treated as
+a pause in the dial sequence."
+ (interactive "sDial number: ")
+ (let ((dialed ""))
+ (mapc
+ (lambda(d)
+ (if bbdb-modem-dial
+ (setq dialed
+ (concat dialed
+ (cond ((eq ? d) ",")
+ ((memq d '(?0 ?1 ?2 ?3 ?4 ?5 ?6 ?7 ?8 ?9 ?* ?#))
+ (format "%c" d))
+ (t ""))))
+ (cond
+ ((eq ?# d)
+ (bbdb-play-sound 10))
+ ((eq ?* d)
+ (bbdb-play-sound 11))
+ ((eq ? d)
+ ;; if we use sit-for, the user can interrupt!
+ (sleep-for 1)) ;; configurable?
+ ((memq d '(?0 ?1 ?2 ?3 ?4 ?5 ?6 ?7 ?8 ?9))
+ (bbdb-play-sound (- d ?0)))
+ (t)))) phone-string)
+
+ ;; tell the user that we're dialed, if we're using the modem
+ (if bbdb-modem-dial
+ (with-temp-buffer
+ (insert bbdb-modem-dial dialed ";\r\n")
+ (write-region (point-min) (point-max) bbdb-modem-device t)
+ (message "%s dialed. Pick up the phone now and hit any key ..."
+ phone-string)
+ (bbdb-next-event)
+ (erase-buffer)
+ (insert "ATH\r\n")
+ (write-region (point-min) (point-max) bbdb-modem-device t)))))
+
+;;;###autoload
+(defun bbdb-dial (phone force-area-code)
+ "Dial the number at point.
+If the point is at the beginning of a record, dial the first
+phone number. Does not dial the extension. Does not apply the
+transformations from bbdb-dial-local-prefix-alist if a prefix arg
+is given."
+ (interactive (list (bbdb-current-field)
+ current-prefix-arg))
+ (if (eq (car-safe phone) 'name)
+ (setq phone (car (bbdb-record-phones (bbdb-current-record)))))
+ (if (eq (car-safe phone) 'phone)
+ (setq phone (car (cdr phone))))
+ (or (vectorp phone) (error "not on a phone field"))
+
+ (let* ((number (bbdb-phone-string phone)) shortnumber)
+ (when (not force-area-code)
+ (let ((alist bbdb-dial-local-prefix-alist))
+ (while alist
+ (if (string-match (concat "^" (eval (caar alist))) number)
+ (setq shortnumber (concat (car (cdar alist))
+ (substring number (match-end 0)))
+ alist nil))
+ (setq alist (cdr alist)))))
+
+ ;; cut off the extension
+ (if (string-match "x[0-9]+$" number)
+ (setq number (substring number 0 (match-beginning 0))))
+
+ ;; This is terrifically Americanized...
+ ;; Leading 0 => local number (?)
+ (if (and (not shortnumber) bbdb-dial-local-prefix
+ (string-match "^0" number))
+ (setq number (concat bbdb-dial-local-prefix number)))
+
+ ;; Leading + => long distance/international number
+ (if (and (not shortnumber) bbdb-dial-long-distance-prefix
+ (string-match "^\+" number))
+ (setq number (concat bbdb-dial-long-distance-prefix " "
+ (substring number 1))))
+
+ ;; use the short number if it's available
+ (setq number (or shortnumber number))
+ (if (not bbdb-silent-running)
+ (message "Dialing %s" number))
+ (bbdb-dial-number number)))
+
+
+;; not sure what this is doing here...
+(defun bbdb-get-record (prompt)
+ "Get the current record or ask the user.
+To be used in `interactive' like this:
+(interactive (list (bbdb-get-record \"look up ...\")))"
+ (if (and (boundp 'bbdb-buffer-name)
+(string= bbdb-buffer-name (buffer-name)))
+(bbdb-current-record)
+(let (re (pr ""))
+ (while (not re)
+ (setq re (bbdb-completing-read-record (concat pr prompt)))
+ (unless re (ding)) (setq pr "Invalid response! ")) re)))
+
+;;; Finger, based on code by Sam Cramer <cramer@sun.com>.
+;;; Note that process-death bugs in 18.57 may make this eat up all the cpu...
+
+(defcustom bbdb-finger-buffer-name "*finger*"
+ "The buffer into which finger output should be directed."
+ :group 'bbdb-utilities-finger
+ :type 'string)
+
+(defun bbdb-finger-internal (address)
+ (message "Fingering %s..." address)
+ (condition-case condition
+ (let* ((@ (string-match "@" address))
+ (stream (open-network-stream
+ "finger" bbdb-finger-buffer-name
+ (if @ (substring address (1+ @)) "localhost")
+ "finger")))
+ (set-process-sentinel stream 'bbdb-finger-process-sentinel)
+ (princ (concat "finger " address "\n"))
+ (process-send-string
+ stream (concat;;"/W " ; cs.stanford.edu doesn't like this...
+ (if @ (substring address 0 @) address) "\n"))
+ (process-send-eof stream))
+ (error
+ (princ (format "error fingering %s: %s\n" address
+ (if (stringp condition) condition
+ (concat "\n" (nth 1 condition)
+ (if (cdr (cdr condition)) ": ")
+ (mapconcat '(lambda (x)
+ (if (stringp x) x
+ (bbdb-prin1-to-string x)))
+ (cdr (cdr condition)) ", ")))))
+ (bbdb-finger-process-sentinel nil nil)))) ; hackaroonie
+
+(defvar bbdb-remaining-addrs-to-finger)
+(defun bbdb-finger-process-sentinel (process s)
+ (save-excursion
+ (set-buffer bbdb-finger-buffer-name)
+ (goto-char (point-min))
+ (while (search-forward "\r" nil t)
+ (delete-char -1))
+ (if (and (boundp 'bbdb-remaining-addrs-to-finger)
+ bbdb-remaining-addrs-to-finger)
+ (let ((addr (car bbdb-remaining-addrs-to-finger)))
+ (setq bbdb-remaining-addrs-to-finger
+ (cdr bbdb-remaining-addrs-to-finger))
+ (goto-char (point-max))
+ (let ((standard-output (current-buffer)))
+ (princ "\n\n\^L\n")
+ (bbdb-finger-internal addr)))
+ (goto-char (point-max))
+ (message "Finger done."))))
+
+(defcustom bbdb-finger-host-field 'finger-host
+ "*The field for special net addresses used by \"\\[bbdb-finger]\"."
+ :group 'bbdb-utilities-finger
+ :type 'symbol)
+
+(defun bbdb-record-finger-host (record)
+ (let ((finger-host (and bbdb-finger-host-field
+ (bbdb-record-getprop record bbdb-finger-host-field))))
+ (if finger-host
+ (bbdb-split finger-host ",")
+ (bbdb-record-net record))))
+
+;;;###autoload
+(defun bbdb-finger (record &optional which-address)
+ "Finger the network address of a BBDB record.
+If this command is executed from the *BBDB* buffer, finger the network
+address of the record at point; otherwise, it prompts for a user.
+With a numeric prefix argument, finger the Nth network address of the
+current record\; with a prefix argument of ^U, finger all of them.
+The *finger* buffer is filled asynchronously, meaning that you don't
+have to wait around for it to finish\; but fingering another user before
+the first finger has finished could have unpredictable results.
+\\<bbdb-mode-map>
+If this command is executed from the *BBDB* buffer, it may be prefixed
+with \"\\[bbdb-apply-next-command-to-all-records]\" \(as in \
+\"\\[bbdb-apply-next-command-to-all-records]\\[bbdb-finger]\" instead of \
+simply \"\\[bbdb-finger]\"\), meaning to finger all of
+the users currently listed in the *BBDB* buffer instead of just the one
+at point. The numeric prefix argument has the same interpretation.
+
+You can define a special network address to \"finger\" by defining a
+field `finger-host' (default value of `bbdb-finger-host-field')."
+ (interactive (list (bbdb-get-record "BBDB Finger: ")
+ current-prefix-arg))
+ (if (not (consp record)) (setq record (list record)))
+ (let ((addrs nil))
+ (while record
+ (cond ((null which-address)
+ (setq addrs
+ (nconc addrs
+ (list (car (bbdb-record-finger-host (car record)))))))
+ ((stringp which-address)
+ (setq addrs (nconc addrs (list which-address))))
+ ((numberp which-address)
+ (setq addrs
+ (nconc addrs
+ (list (nth which-address
+ (bbdb-record-finger-host (car record)))))))
+ (t
+ (setq addrs
+ (nconc addrs
+ (copy-sequence (bbdb-record-finger-host
+ (car record)))))))
+ (setq record (cdr record)))
+ (if (car addrs)
+ (save-excursion
+ (with-output-to-temp-buffer bbdb-finger-buffer-name
+ (set-buffer bbdb-finger-buffer-name)
+ (make-local-variable 'bbdb-remaining-addrs-to-finger)
+ (setq bbdb-remaining-addrs-to-finger (cdr addrs))
+ (bbdb-finger-internal (car addrs))))
+ (error "Nothing to finger!"))))
+
+
+(defun bbdb-remove-duplicate-nets (records)
+ "*Remove duplicate nets from a record."
+ (interactive (if (bbdb-do-all-records-p)
+ (mapcar 'car bbdb-records)
+ (bbdb-current-record)))
+ (let (nets cnets)
+ (while records
+ (setq nets (bbdb-record-net (car records))
+ cnets nil)
+ (while nets
+ (add-to-list 'cnets (car nets))
+ (setq nets (cdr nets)))
+ (bbdb-record-set-net (car records) cnets)
+ (setq records (cdr records)))))
+
+(defun bbdb-find-duplicates (&optional fields)
+ "Find all records that have duplicate entries for given FIELDS.
+FIELDS should be a list of the symbols `name', `net', and/or `aka'.
+Note that overlap between these fields is noted if either is selected,
+most common case `aka' and `name'. If FIELDS is not given it
+defaults to all of them.
+
+The results of the search is returned as a list of records."
+ (setq fields (or fields '(name net aka)))
+ (let ((records (bbdb-records))
+ rec hash ret)
+ (while records
+ (setq rec (car records))
+
+ (when (and (memq 'name fields)
+ (bbdb-record-name rec)
+ (setq hash (bbdb-gethash (downcase (bbdb-record-name rec))))
+ (> (length hash) 1))
+ (setq ret (append hash ret))
+ (message "BBDB record `%s' causes duplicates, maybe it is equal to a company name."
+ (bbdb-record-name rec))
+ (sit-for 0))
+
+ (if (memq 'net fields)
+ (let ((nets (bbdb-record-net rec)))
+ (while nets
+ (setq hash (bbdb-gethash (downcase (car nets))))
+ (when (> (length hash) 1)
+ (setq ret (append hash ret))
+ (message "BBDB record `%s' has duplicate net `%s'."
+ (bbdb-record-name rec) (car nets))
+ (sit-for 0))
+ (setq nets (cdr nets)))))
+
+ (if (memq 'aka fields)
+ (let ((aka (bbdb-record-aka rec)))
+ (while aka
+ (setq hash (bbdb-gethash (downcase (car aka))))
+ (when (> (length hash) 1)
+ (setq ret (append hash ret))
+ (message "BBDB record `%s' has duplicate aka `%s'"
+ (bbdb-record-name rec) (car aka))
+ (sit-for 0))
+ (setq aka (cdr aka)))))
+
+ (setq records (cdr records)))
+ (reverse (bbdb-remove-memq-duplicates ret))))
+
+(defun bbdb-show-duplicates (&optional fields)
+ "*Find all records that have duplicate entries for given FIELDS.
+FIELDS should be a list of the symbols `name', `net', and/or `aka'.
+Note that overlap between these fields is noted if either is selected
+(most common case `aka' and `name'). If FIELDS is not given it
+defaults to all of them.
+
+The results are displayed in the bbdb buffer."
+ (interactive)
+ (setq fields (or fields '(name net aka)))
+ (bbdb-display-records (bbdb-find-duplicates fields)))
+
+;;; Time-based functions
+(defun bbdb-kill-older (date &optional compare function)
+ "*Apply FUNCTION to all records with timestamps older than DATE.
+The comparison is done with COMPARE. If FUNCTION is not specified, the
+selected records are deleted. If COMPARE is not specified,
+`string-lessp' is used.
+
+Example:
+ (bbdb-kill-older \"1997-01-01\")
+will delete all records with timestamps older than Jan 1 1997.
+
+Notes: 1. Records without timestamp fields will be ignored
+2. DATE must be in yyyy-mm-dd format."
+ (interactive "sKill records with timestamp older than (yyyy-mm-dd): \n")
+ (let ((records (bbdb-records)) timestamp
+ (fun (or function 'bbdb-delete-record-internal))
+ (cmp (or compare 'string-lessp)))
+ (while records
+ (if (and (setq timestamp (bbdb-record-getprop (car records) 'timestamp))
+ (funcall cmp timestamp date))
+ (funcall fun (car records)))
+ (setq records (cdr records)))))
+
+(defmacro bbdb-compare-records (cmpval field compare)
+ "Builds a lambda comparison function that takes one argument, REC.
+REC is returned if
+(COMPARE VALUE CMPVAL)
+is true, where VALUE is the value of the FIELD field of REC."
+ `(lambda (rec)
+(let ((val (bbdb-record-getprop rec ,field)))
+ (if (and val (,compare val ,cmpval))
+ rec nil))))
+
+;;;###autoload
+(defun bbdb-timestamp-older (date)
+ "*Display records with timestamp older than DATE.
+DATE must be in yyyy-mm-dd format."
+ (interactive "sOlder than date (yyyy-mm-dd): ")
+ (bbdb-display-some (bbdb-compare-records date 'timestamp string<)))
+
+;;;###autoload
+(defun bbdb-timestamp-newer (date)
+ "*Display records with timestamp newer than DATE.
+DATE must be in yyyy-mm-dd format."
+ (interactive "sNewer than date (yyyy-mm-dd): ")
+ (bbdb-display-some (bbdb-compare-records date 'timestamp string>)))
+
+;;;###autoload
+(defun bbdb-creation-older (date)
+ "*Display records with creation-date older than DATE.
+DATE must be in yyyy-mm-dd format."
+ (interactive "sOlder than date (yyyy-mm-dd): ")
+ (bbdb-display-some (bbdb-compare-records date 'creation-date string<)))
+
+;;;###autoload
+(defun bbdb-creation-newer (date)
+ "*Display records with creation-date newer than DATE.
+DATE must be in yyyy-mm-dd format."
+ (interactive "sNewer than date (yyyy-mm-dd): ")
+ (bbdb-display-some (bbdb-compare-records date 'creation-date string>)))
+
+;;;###autoload
+(defun bbdb-creation-no-change ()
+ "*Display records that have the same timestamp and creation-date."
+ (interactive)
+ (bbdb-display-some
+ (bbdb-compare-records (bbdb-record-getprop rec 'timestamp)
+ 'creation-date string=)))
+
+;;; Help and documentation
+
+(defcustom bbdb-info-file nil
+ "*Set this to the location of the bbdb info file, if it's not in the
+standard place."
+ :group 'bbdb
+ :type '(choice (const :tag "Standard location" nil)
+ (file :tag "New location")))
+
+;;;###autoload
+(defun bbdb-info ()
+ (interactive)
+ (require 'info)
+ (if bbdb-inside-electric-display
+ (bbdb-electric-throw-to-execute '(bbdb-info))
+ (let ((file (or bbdb-info-file "bbdb")))
+ (Info-goto-node (format "(%s)Top" file)))))
+
+;;;###autoload
+(defun bbdb-help ()
+ (interactive)
+ (message (substitute-command-keys "\\<bbdb-mode-map>\
+new field: \\[bbdb-insert-new-field]; \
+edit field: \\[bbdb-edit-current-field]; \
+delete field: \\[bbdb-delete-current-field-or-record]; \
+mode help: \\[describe-mode]; \
+info: \\[bbdb-info]")))
+
+
+(or (fboundp 'member);; v18 lossage
+ (defun member (item list)
+ (while (and list (not (equal item (car list)))) (setq list (cdr list)))
+ list))
+
+
+;;; If Sebastian Kremer's minibuffer history package is around, use it.
+(if (and (fboundp 'gmhist-make-magic)
+ (string-lessp emacs-version "19")) ; v19 has history built in
+ (mapc 'gmhist-make-magic
+ '(bbdb bbdb-name bbdb-company bbdb-net bbdb-changed)))
+
+;;;###autoload
+(defcustom bbdb-update-records-mode 'annotating
+ "Controls how `bbdb-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.
+
+There is a version of this variable for each MUA, which overrides this variable
+when set!
+
+This variable is also used for inter-function communication between the
+functions `bbdb-update-records' and `bbdb-prompt-for-create'."
+ :group 'bbdb-mua-specific
+ :group 'bbdb-noticing-records
+ :type '(choice (const :tag "annotating all messages"
+ annotating)
+ (const :tag "annotating no messages"
+ searching)
+ (sexp :tag "user defined")))
+
+(defvar bbdb-offer-to-create nil
+ "Used for inter-function communication between the functions
+`bbdb-update-records' and `bbdb-prompt-for-create'.")
+(defvar bbdb-address nil
+ "Used for inter-function communication between the functions
+`bbdb-update-records' and `bbdb-prompt-for-create'.")
+
+(defvar bbdb-update-address-class nil
+ "Class of currently processed address as in `bbdb-get-addresses-headers'.
+The `bbdb-notice-hook' and `bbdb-create-hook' functions may utilize this to
+treat updates in the right way.")
+
+(defvar bbdb-update-address-header nil
+ "Header the currently processed address was extracted from.
+The `bbdb-notice-hook' and `bbdb-create-hook' functions may utilize this to
+treat updates in the right way.")
+
+;;;###autoload
+(defun bbdb-update-records (addrs auto-create-p offer-to-create)
+ "Returns the records corresponding to the list of addresses ADDRS,
+creating or modifying them as necessary. A record will be created if
+AUTO-CREATE-P is non-nil or if OFFER-TO-CREATE is true and the user
+confirms the creation.
+
+`bbdb-update-records-mode' controls if records are updated or not.
+A MUA specific variable, e.g. `bbdb/vm-update-records-mode', can
+overwrite this.
+
+See also `bbdb-get-only-first-address-p' to limit the update to the
+sender of the message.
+
+When hitting C-g once you will not be asked any more for new people listed
+in this message, but it will search only for existing records. When hitting
+C-g again it will stop scanning."
+ (setq auto-create-p (bbdb-invoke-hook-for-value auto-create-p))
+
+ (let ((bbdb-records (bbdb-records))
+ (processed-addresses 0)
+ (bbdb-offer-to-create (or offer-to-create (eq 'prompt auto-create-p)))
+ (bbdb-update-records-mode
+ (if offer-to-create 'annotating
+ (if (listp bbdb-update-records-mode)
+ (eval bbdb-update-records-mode)
+ bbdb-update-records-mode)))
+ (addrslen (length addrs))
+ (bbdb-update-address-class nil)
+ (bbdb-update-address-header nil)
+ records hits)
+
+ (while addrs
+
+ (setq bbdb-address (car addrs)
+ bbdb-update-address-class (car bbdb-address)
+ bbdb-update-address-header (cadr bbdb-address)
+ bbdb-address (caddr bbdb-address))
+
+ (condition-case nil
+ (progn
+ (setq hits
+ (cond ((null (cadr bbdb-address))
+ ;; ignore emtpy addrs, e.g. (??? nil)
+ nil)
+ ((eq bbdb-update-records-mode 'annotating)
+ (list;; search might return a list
+ (bbdb-annotate-message-sender
+ bbdb-address t
+ (or auto-create-p offer-to-create)
+ (if (eq auto-create-p t)
+ nil
+ (if bbdb-offer-to-create
+ 'bbdb-prompt-for-create)))))
+ ((eq bbdb-update-records-mode 'searching)
+ ;; search for records having this net
+ (let ((net (concat "^"
+ (regexp-quote
+ (cadr bbdb-address))
+ "$"))
+ ;; there is no case for nets
+ (bbdb-case-fold-search t))
+ (bbdb-search bbdb-records nil nil net))))
+ processed-addresses (+ processed-addresses 1))
+
+ (when (and (not bbdb-silent-running)
+ (not bbdb-gag-messages)
+ (not (eq bbdb-offer-to-create 'q))
+ (= 0 (% processed-addresses 5)))
+ (let ((mess (format "Hit C-g to stop BBDB from %s. %d of %d addresses processed."
+ bbdb-update-records-mode processed-addresses addrslen)))
+ (if (featurep 'xemacs)
+ (bbdb-display-message 'progress mess)
+ (message mess)))
+ (sit-for 0)))
+
+ ;; o.k. there was a quit signal so how should we proceed now?
+ (quit (cond ((eq bbdb-update-records-mode 'annotating)
+ (setq bbdb-update-records-mode 'searching))
+ ((eq bbdb-update-records-mode 'searching)
+ nil)
+ ((eq bbdb-update-records-mode 'next)
+ (setq bbdb-update-records-mode 'annotating))
+ (t
+ (setq bbdb-update-records-mode 'quit)))
+ nil))
+
+ (while hits
+ ;; people should be listed only once so we use add-to-list
+ (if (car hits) (add-to-list 'records (car hits)))
+ (setq hits (cdr hits)))
+
+ (setq addrs (cdr addrs)))
+
+ ;; add-to-list adds at the front so we have to reverse the list in order
+ ;; to reflect the order of the records as they appear in the headers.
+ (setq records (nreverse records))
+
+ records))
+
+(defun bbdb-get-help-window (message)
+ "Display MESSAGE in a new window which is the last one in the current frame."
+ (bbdb-pop-up-bbdb-buffer)
+ (let ((b (get-buffer-create " *BBDB Help*"))
+ (w (get-buffer-window bbdb-buffer-name))
+ (selected (selected-window))
+ (lines (let ((l 2) (s 0))
+ (while (setq s (string-match "\n" message s))
+ (setq s (1+ s) l (1+ l)))
+ l)))
+ (unless w
+ (setq w (display-buffer b)))
+ (select-window w)
+ (switch-to-buffer b)
+ (setq buffer-read-only t)
+ (let ((buffer-read-only nil))
+ (erase-buffer)
+ (insert message))
+ (goto-char (point-min))
+ (let ((window-min-height 1))
+ (enlarge-window (- lines (window-height w))))
+ w))
+
+;; This is a hack. The function is called by bbdb-annotate-message-sender and
+;; uses the above variable in order to manipulate bbdb-update-records.
+;; Some cases are handled with signals in order to keep the changes in
+;; bbdb-annotate-message-sender as minimal as possible.
+
+(defun bbdb-prompt-for-create ()
+ "This function is used by `bbdb-update-records' to ask the user how to
+proceed the processing of records.
+
+It is called from `bbdb-annotate-message-sender' (PROMPT-FOR-CREATE arg) and
+returns `t' if the record should be created or `nil' otherwise. It honors a
+previous answer, e.g. \"!\" add all ..."
+ (let ((old-offer-to-create bbdb-offer-to-create)
+ event prompt)
+ (when bbdb-offer-to-create
+ (when (not (integerp bbdb-offer-to-create))
+ (setq prompt (format "%s is not in the db; add? (y,!,n,s,q,?) "
+ (or (car bbdb-address) (cadr bbdb-address))))
+ (while (not event)
+ (setq event (read-key-sequence prompt))
+ (if (featurep 'xemacs)
+ (setq event (bbdb-event-to-character (aref event 0)))
+ (setq event (if (stringp event) (aref event 0)))))
+
+ (setq bbdb-offer-to-create event))
+ (message "");; clear the message buffer
+
+ (cond ((eq bbdb-offer-to-create ?y)
+ (setq bbdb-offer-to-create old-offer-to-create)
+ t)
+ ((eq bbdb-offer-to-create ?!)
+ t)
+ ((or (eq bbdb-offer-to-create ?n)
+ (eq bbdb-offer-to-create ? ))
+ (setq bbdb-update-records-mode 'next
+ bbdb-offer-to-create old-offer-to-create)
+ (signal 'quit 'next))
+ ((eq bbdb-offer-to-create ?q)
+ (setq bbdb-update-records-mode 'quit)
+ (signal 'quit 'quit))
+ ((eq bbdb-offer-to-create ?s)
+ (setq bbdb-update-records-mode 'searching)
+ (signal 'quit 'searching))
+ (t
+ (save-window-excursion
+ (bbdb-get-help-window
+ "Your answer controls how BBDB updates/searches for records.
+
+Type ? for this help.
+Type y to add the current record.
+Type ! to add all remaining records.
+Type n to skip the current record. (You might also type space)
+Type s to switch from annotate to search mode.
+Type q to quit updating records. No more search or annotation is done.")
+ (bbdb-prompt-for-create)))))))
+
+;;;###autoload
+(defcustom bbdb-get-addresses-headers
+ '((authors . ("From" "Resent-From" "Reply-To"))
+ (recipients . ("Resent-To" "Resent-CC" "To" "CC" "BCC")))
+ "*List of headers to search for senders and recipients email addresses.
+The headers are grouped into two classes, the authors and the senders headers."
+ :group 'bbdb-mua-specific
+ :group 'bbdb-noticing-records
+ :type 'list)
+
+;;;###autoload
+(defcustom bbdb-get-only-first-address-p nil
+ "*If t `bbdb-update-records' will return only the first one.
+Changing this variable will show its effect only after clearing the
+`bbdb-message-cache' of a folder or closing and visiting it again."
+ :group 'bbdb-mua-specific
+ :group 'bbdb-noticing-records
+ :type 'boolean)
+
+(defun bbdb-get-addresses (only-first-address
+ uninteresting-senders
+ get-header-content-function
+ &rest get-header-content-function-args)
+ "Return a list of all addresses found in the headers of a message.
+With ONLY-FIRST-ADDRESS being t, it will only return the first found address.
+Addresses matching UNINTERESTING-SENDERS will be ignored.
+
+The client has to provide a GET-HEADER-CONTENT-FUNCTION and optional arguments
+\(GET-HEADER-CONTENT-FUNCTION-ARGS) to extract the header content. The first
+argument to this function if the header name sans."
+ (let ((headers bbdb-get-addresses-headers)
+ (ignore-senders (or bbdb-user-mail-names uninteresting-senders))
+ addrlist adlist fn ad
+ header-type header-fields header-content)
+ (while headers
+ (setq header-type (caar headers)
+ header-fields (cdar headers))
+ (while header-fields
+ (setq header-content (apply get-header-content-function
+ (car header-fields)
+ get-header-content-function-args))
+ (when header-content
+ (setq adlist (funcall bbdb-extract-address-components-func
+ header-content))
+ (while adlist
+ (setq fn (caar adlist)
+ ad (car (cdar adlist)))
+
+ ;; ignore uninteresting addresses, this is kinda gross!
+ (if (or (not (stringp ignore-senders))
+ (not (or (and fn (string-match ignore-senders fn))
+ (and ad (string-match ignore-senders ad)))))
+ (add-to-list 'addrlist
+ (list header-type
+ (car header-fields)
+ (car adlist))))
+
+ (if (and only-first-address addrlist)
+ (setq adlist nil headers nil)
+ (setq adlist (cdr adlist)))))
+ (setq header-fields (cdr header-fields)))
+ (setq headers (cdr headers)))
+ (nreverse addrlist)))
+
+(provide 'bbdb-com)
diff --git a/lisp/bbdb-ftp.el b/lisp/bbdb-ftp.el
new file mode 100644
index 0000000..1ac48d6
--- /dev/null
+++ b/lisp/bbdb-ftp.el
@@ -0,0 +1,201 @@
+;;; -*- Mode:Emacs-Lisp -*-
+
+;;; This file is an addition to the Insidious Big Brother Database
+;;; (aka BBDB), copyright (c) 1991, 1992 Jamie Zawinski
+;;; <jwz@netscape.com>.
+;;;
+;;; 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
+;;; details.
+;;;
+;;; 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.
+
+
+;;; This file was written by Ivan Vazquez <ivan@haldane.bu.edu>
+
+;;; This file adds the ability to define ftp-sites in a BBDB, much the same
+;;; way one adds a regular person's name to the BBDB. It also defines the
+;;; bbdb-ftp command which allows you to ftp a site that is in a bbdb-record.
+;;; You must have either EFS or ange-ftp in order to use this code. Ange-ftp
+;;; is available at archive.cis.ohio-state.edu in the
+;;; /pub/gnu/emacs/elisp-archive/packages directory. EFS ships with XEmacs.
+
+;;; Note that Ftp Site BBDB entries differ from regular entries by the
+;;; fact that the Name Field must have the ftp site preceeded by the
+;;; bbdb-ftp-site-name-designator-prefix. This defaults to "Ftp Site:"
+;;; BBDB Ftp Site entries also have two new fields added, the
+;;; ftp-dir slot, and the ftp-user slot. These are added to the notes
+;;; alist part of the bbdb-records, the original bbdb-record structure
+;;; remains untouched.
+
+;;; The following user-level commands are defined for use:
+;;;
+
+;;; bbdb-ftp - Use ange-ftp to open an ftp-connection to a BBDB
+;;; record's name. If this command is executed from the
+;;; *BBDB* buffer, ftp the site of the record at point;
+;;; otherwise, it prompts for an ftp-site.
+
+;;; bbdb-create-ftp-site -
+;;; Add a new ftp-site entry to the bbdb database; prompts
+;;; for all relevant info using the echo area, inserts the
+;;; new record in the db, sorted alphabetically.
+
+;;; The package can be installed by compiling and adding the following
+;;; two lines to your .emacs.
+
+;;; (autoload 'bbdb-ftp "bbdb-ftp" "Ftp BBDB Package" t)
+;;; (autoload 'bbdb-create-ftp-site "bbdb-ftp" "Ftp BBDB Package" t)
+
+(require 'bbdb)
+(require 'bbdb-com)
+
+;; There must be a better way
+(if (featurep 'efs-cu)
+ (require 'efs)
+ (require 'ange-ftp))
+
+(defcustom bbdb-default-ftp-user "anonymous"
+ "*The default login to use when ftp-ing."
+ :group 'bbdb-utilities-ftp
+ :type 'string)
+
+(defcustom bbdb-default-ftp-dir "/"
+ "*The default directory to open when ftp-ing."
+ :group 'bbdb-utilities-ftp
+ :type 'string)
+
+(defcustom bbdb-ftp-site-name-designator-prefix "Ftp Site: "
+ "*The prefix that all ftp sites in the bbdb will have in their name field."
+ :group 'bbdb-utilities-ftp
+ :type 'string)
+
+(defmacro defun-bbdb-raw-notes-accessor (slot)
+ "Expands into an accessor function for slots in the notes alist."
+ (let ((fn-name (intern (concat "bbdb-record-" (symbol-name slot)))))
+ (list 'defun fn-name (list 'record)
+ (list 'cdr
+ (list 'assoc (list 'quote slot)
+ (list 'bbdb-record-raw-notes 'record))))))
+
+(defun-bbdb-raw-notes-accessor ftp-dir)
+(defun-bbdb-raw-notes-accessor ftp-user)
+
+(defun bbdb-record-ftp-site (record)
+ "Accessor Function. Returns the ftp-site field of the BBDB record or nil."
+ (let* ((name (bbdb-record-name record))
+ (ftp-pfx-regexp (concat bbdb-ftp-site-name-designator-prefix " *"))
+ (ftp-site
+ (and (string-match ftp-pfx-regexp name)
+ (substring name (match-end 0)))))
+ ftp-site))
+
+(defun remove-leading-whitespace (string)
+ "Remove any spaces or tabs from only the start of the string."
+ (let ((space-char-code (string-to-char " "))
+ (tab-char-code ?\t)
+ (index 0))
+ (if string
+ (progn
+ (while (or (char-equal (elt string index) space-char-code)
+ (char-equal (elt string index) tab-char-code))
+ (setq index (+ index 1)))
+ (substring string index))
+ nil)))
+
+;;;###autoload
+(defun bbdb-ftp (bbdb-record &optional which)
+ "Use ange-ftp to open an ftp-connection to a BBDB record's name.
+If this command is executed from the *BBDB* buffer, ftp the site of
+the record at point; otherwise, it prompts for an ftp-site."
+ (interactive (list (bbdb-get-record "Visit (FTP): ")
+ (or current-prefix-arg 0)))
+ (if (bbdb-record-ftp-site bbdb-record)
+ (bbdb-ftp-internal bbdb-record)
+ (find-file-other-window
+ (read-string "fetch: " (bbdb-get-field bbdb-record 'ftp which)))))
+
+(defun bbdb-ftp-internal (bbdb-record)
+ (let* ((site (bbdb-record-ftp-site bbdb-record))
+ (dir (or (bbdb-record-ftp-dir bbdb-record) bbdb-default-ftp-dir))
+ (user (or (bbdb-record-ftp-user bbdb-record) bbdb-default-ftp-user))
+ (file-string (concat "/" user "@" site ":" dir )))
+ (if bbdb-inside-electric-display
+ (bbdb-electric-throw-to-execute (list 'bbdb-ftp-internal bbdb-record)))
+ (if site
+ (find-file-other-window file-string)
+ (error "Not an ftp site. Check bbdb-ftp-site-name-designator-prefix"))))
+
+(defun bbdb-read-new-ftp-site-record ()
+ "Prompt for and return a completely new BBDB record that is
+specifically an ftp site entry. Doesn't insert it in to the database
+or update the hashtables, but does insure that there will not be name
+collisions."
+ (bbdb-records) ; make sure database is loaded
+ (if bbdb-readonly-p (error "The Insidious Big Brother Database is read-only."))
+ (let (site dir user)
+ (bbdb-error-retry
+ (progn
+ (setq site (bbdb-read-string "Ftp Site: "))
+ ;; try and parse it out, in case the user typed in things like
+ ;; "ftp://user@site/directory/ or /user@site/directory
+ (if (string-match
+ "^\\([Ff][Tt][Pp]://\\|/\\)?\\([^@/]@\\)?\\([^/]+\\)\\(/[^/].*\\)?"
+ site)
+ (setq user (if (match-beginning 2)
+ (substring site (match-beginning 2)
+ (match-end 2)))
+ dir (if (match-beginning 4)
+ (substring site (match-beginning 4)
+ (match-end 4)))
+ site (substring site (match-beginning 3)
+ (match-end 3)))
+ (if (string-match "/" site)
+ (error "%s doesn't look like a valid site name." site)))
+ (setq site (concat bbdb-ftp-site-name-designator-prefix site))
+ (if (and bbdb-no-duplicates-p
+ (bbdb-gethash (downcase site)))
+ (error "%s is already in the database" site))))
+ (let* ((dir (or dir (bbdb-read-string "Ftp Directory: "
+ bbdb-default-ftp-dir)))
+ (user (or user (bbdb-read-string "Ftp Username: "
+ bbdb-default-ftp-user)))
+ (company (bbdb-read-string "Company: "))
+ (notes (bbdb-read-string "Additional Comments: "))
+ (names (bbdb-divide-name site))
+ (firstname (car names))
+ (lastname (nth 1 names)))
+ (if (string= user bbdb-default-ftp-user) (setq user nil))
+ (if (string= company "") (setq company nil))
+ (if (or (string= dir bbdb-default-ftp-dir) (string= dir ""))
+ (setq dir nil))
+ (if (string= notes "") (setq notes nil))
+
+ (let ((record
+ (vector firstname lastname nil company nil nil nil
+ (append
+ (if notes (list (cons 'notes notes)) nil)
+ (if dir (list (cons 'ftp-dir dir)) nil)
+ (if user (list (cons 'ftp-user user)) nil))
+ (make-vector bbdb-cache-length nil))))
+ record))))
+
+;;;###autoload
+(defun bbdb-create-ftp-site (record)
+ "Add a new ftp-site entry to the bbdb database.
+Prompts for all relevant info using the echo area,
+inserts the new record in the db, sorted alphabetically."
+ (interactive (list (bbdb-read-new-ftp-site-record)))
+ (bbdb-invoke-hook 'bbdb-create-hook record)
+ (bbdb-change-record record t)
+ (bbdb-display-records (list record)))
+
+(provide 'bbdb-ftp)
diff --git a/lisp/bbdb-gnus.el b/lisp/bbdb-gnus.el
new file mode 100644
index 0000000..0ea33db
--- /dev/null
+++ b/lisp/bbdb-gnus.el
@@ -0,0 +1,835 @@
+;;; -*- Mode:Emacs-Lisp -*-
+
+;;; This file is part of the Insidious Big Brother Database (aka BBDB),
+;;; copyright (c) 1991, 1992, 1993 Jamie Zawinski <jwz@netscape.com>.
+;;; Interface to Gnus. 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
+;;; details.
+;;;
+;;; 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.
+
+(require 'bbdb)
+(require 'bbdb-snarf)
+(require 'gnus)
+
+(eval-and-compile
+ (require 'bbdb-com)
+ (require 'rfc822))
+
+;; Cater for older emacs (19.34) with default Gnus installation.
+(eval-and-compile
+ (condition-case nil
+ (progn
+ (require 'gnus-win)
+ (require 'gnus-sum)
+ (require 'gnus-art))
+ (error nil)))
+
+;;; Compiler hushing
+(eval-when-compile
+ (defvar gnus-optional-headers)
+ (defvar gnus-summary-to-prefix))
+
+(defsubst bbdb/gnus-ignored-from-addresses ()
+ "Return the value of `gnus-ignored-from-addresses' handling both
+recent Gnus (>= 04/2007) and older ones."
+ (cond ((fboundp 'gnus-ignored-from-addresses)
+ (gnus-ignored-from-addresses))
+ ((boundp 'gnus-ignored-from-addresses)
+ gnus-ignored-from-addresses)
+ (t nil)))
+
+(defun bbdb/gnus-get-message-id ()
+ "Return the message-id of the current message."
+ (save-excursion
+ (set-buffer gnus-original-article-buffer)
+ (goto-char (point-min))
+ (let ((case-fold-search t))
+ (if (re-search-forward "^Message-ID:\\s-*\\(<.+>\\)" (point-max) t)
+ (match-string 1)))))
+
+(defcustom bbdb/gnus-update-records-mode 'annotating
+; '(if (gnus-new-flag msg) 'annotating 'searching)
+ "Controls how `bbdb/gnus-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."
+ :group 'bbdb-mua-specific-gnus
+ :type '(choice (const :tag "annotating all messages"
+ annotating)
+ (const :tag "annotating no messages"
+ searching)
+ (const :tag "annotating only new messages"
+ (if (equal ""
+ (gnus-summary-article-mark
+ (gnus-summary-article-number)))
+ 'annotating 'searching))
+ (sexp :tag "user defined")))
+
+
+;;;###autoload
+(defun bbdb/gnus-update-record (&optional offer-to-create)
+ "Return the record corresponding to the current Gnus message, creating
+or modifying it as necessary. A record will be created if
+bbdb/news-auto-create-p is non-nil, or if OFFER-TO-CREATE is true and
+the user confirms the creation."
+ (let* ((bbdb-get-only-first-address-p t)
+ (records (bbdb/gnus-update-records offer-to-create)))
+ (if records (car records) nil)))
+
+;;;###autoload
+(defun bbdb/gnus-update-records (&optional offer-to-create)
+ "Return the records corresponding to the current Gnus message, creating
+or modifying it as necessary. A record will be created if
+`bbdb/news-auto-create-p' is non-nil or if OFFER-TO-CREATE is true
+and the user confirms the creation.
+
+The variable `bbdb/gnus-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 ((bbdb-update-records-mode (or bbdb/gnus-update-records-mode
+ bbdb-update-records-mode))
+ (bbdb/gnus-offer-to-create offer-to-create)
+ ;; here we may distiguish between different type of messages
+ ;; for those that have no message id we have to find something
+ ;; else as message key.
+ (msg-id (bbdb/gnus-get-message-id))
+ records cache)
+ (save-excursion
+ (set-buffer gnus-article-buffer)
+
+ (if (and msg-id (not bbdb/gnus-offer-to-create))
+ (setq cache (bbdb-message-cache-lookup msg-id)))
+
+ (if cache
+ (setq records (if bbdb-get-only-first-address-p
+ (list (car cache))
+ cache))
+
+ (let ((bbdb-update-records-mode (or bbdb/gnus-update-records-mode
+ bbdb-update-records-mode)))
+ (setq records (bbdb-update-records
+ (bbdb-get-addresses
+ bbdb-get-only-first-address-p
+ (or (bbdb/gnus-ignored-from-addresses)
+ bbdb-user-mail-names)
+ 'gnus-fetch-field)
+ bbdb/news-auto-create-p
+ offer-to-create)))
+ (if (and bbdb-message-caching-enabled msg-id)
+ (bbdb-encache-message msg-id records))))
+ records))
+
+;;;###autoload
+(defun bbdb/gnus-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)."
+ (interactive (list (if bbdb-readonly-p
+ (error "The Insidious Big Brother Database is read-only.")
+ (read-string "Comments: "))))
+ (gnus-summary-select-article)
+ (bbdb-annotate-notes (bbdb/gnus-update-record t) string 'notes replace))
+
+(defun bbdb/gnus-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."
+ (interactive "P")
+ (gnus-summary-select-article)
+ (let ((record (or (bbdb/gnus-update-record t) (error "unperson"))))
+ (bbdb-display-records (list record))
+ (if arg
+ (bbdb-record-edit-property record nil t)
+ (bbdb-record-edit-notes record t))))
+
+;;;###autoload
+(defun bbdb/gnus-show-records (&optional address-class)
+ "Display the contents of the BBDB for all addresses of this message.
+This buffer will be in `bbdb-mode', with associated keybindings."
+ (interactive)
+ (gnus-summary-select-article)
+ (let ((bbdb-get-addresses-headers
+ (if address-class
+ (list (assoc address-class bbdb-get-addresses-headers))
+ bbdb-get-addresses-headers))
+ (bbdb/gnus-update-records-mode 'annotating)
+ (bbdb-message-cache nil)
+ (bbdb-user-mail-names nil)
+ (gnus-ignored-from-addresses nil)
+ records)
+ (setq records (bbdb/gnus-update-records t))
+ (if records
+ (bbdb-display-records records)
+ (bbdb-undisplay-records))
+ records))
+
+;;;###autoload
+(defun bbdb/gnus-show-all-recipients ()
+ "Show all recipients of this message. Counterpart to `bbdb/vm-show-sender'."
+ (interactive)
+ (let ((bbdb-get-only-first-address-p nil))
+ (bbdb/gnus-show-records 'recipients)))
+
+(defun bbdb/gnus-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."
+ (interactive "p")
+ (cond ((= 4 show-recipients)
+ (bbdb/gnus-show-all-recipients))
+ ((= 16 show-recipients)
+ (let ((bbdb-get-only-first-address-p nil))
+ (bbdb/gnus-show-records)))
+ (t
+ (if (null (bbdb/gnus-show-records 'authors))
+ (bbdb/gnus-show-all-recipients)))))
+
+(defun bbdb/gnus-pop-up-bbdb-buffer (&optional offer-to-create)
+ "Make the *BBDB* buffer be displayed along with the Gnus windows,
+displaying the record corresponding to the sender of the current message."
+ (let ((bbdb-gag-messages t)
+ (records (bbdb/gnus-update-records offer-to-create))
+ (bbdb-electric-p nil))
+
+ (when bbdb-use-pop-up
+ (let ((b (current-buffer)))
+ ;; display the bbdb buffer iff there is a record for this article.
+ (if records
+ (bbdb-pop-up-bbdb-buffer
+ (lambda (w)
+ (let ((b (current-buffer)))
+ (set-buffer (window-buffer w))
+ (prog1 (eq major-mode 'gnus-article-mode)
+ (set-buffer b)))))
+ (or bbdb-inside-electric-display
+ (not (get-buffer-window bbdb-buffer-name))
+ (let (w)
+ (delete-other-windows)
+ (gnus-configure-windows 'article)
+ (if (setq w (get-buffer-window gnus-summary-buffer))
+ (select-window w)))))
+ (set-buffer b))
+ (if records (bbdb-display-records records bbdb-pop-up-display-layout)))
+ records))
+
+;;
+;; Announcing BBDB entries in the summary buffer
+;;
+
+(defcustom bbdb/gnus-lines-and-from-length 18
+ "*The number of characters used to display From: info in Gnus, if you have
+set gnus-optional-headers to 'bbdb/gnus-lines-and-from."
+ :group 'bbdb-mua-specific-gnus
+ :type 'integer)
+
+(defcustom bbdb/gnus-summary-mark-known-posters t
+ "*If t, mark messages created by people with records in the BBDB.
+In Gnus, this marking will take place in the subject list (assuming
+`gnus-optional-headers' contains `bbdb/gnus-lines-and-from'). In Gnus, the
+marking will take place in the Summary buffer if the format code defined by
+`bbdb/gnus-summary-user-format-letter' is used in `gnus-summary-line-format'.
+This variable has no effect on the marking controlled by
+`bbdb/gnus-summary-in-bbdb-format-letter'."
+ :group 'bbdb-mua-specific-gnus
+ :type '(choice (const :tag "Mark known posters" t)
+ (const :tag "Do not mark known posters" nil)))
+(defvaralias 'bbdb/gnus-mark-known-posters
+ 'bbdb/gnus-summary-mark-known-posters)
+
+(defcustom bbdb/gnus-summary-known-poster-mark "+"
+ "This is the default character to prefix author names with if
+bbdb/gnus-summary-mark-known-posters is t. If the poster's record has
+an entry in the field named by bbdb-message-marker-field, then that will
+be used instead."
+ :group 'bbdb-mua-specific-gnus
+ :type 'character)
+
+(defcustom bbdb/gnus-summary-show-bbdb-names t
+ "*If both this variable and `bbdb/gnus-summary-prefer-real-names' are true,
+then for messages from authors who are in your database, the name
+displayed will be the primary name in the database, rather than the
+one in the From line of the message. This doesn't affect the names of
+people who aren't in the database, of course. (`gnus-optional-headers'
+must be `bbdb/gnus-lines-and-from' for Gnus users.)"
+ :group 'bbdb-mua-specific-gnus
+ :type 'boolean)
+(defvaralias 'bbdb/gnus-header-show-bbdb-names
+ 'bbdb/gnus-summary-show-bbdb-names)
+
+(defcustom bbdb/gnus-summary-prefer-bbdb-data t
+ "If t, then for posters who are in our BBDB, replace the information
+provided in the From header with data from the BBDB."
+ :group 'bbdb-mua-specific-gnus
+ :type 'boolean)
+
+(defcustom bbdb/gnus-summary-prefer-real-names t
+ "If t, then display the poster's name from the BBDB if we have one,
+otherwise display his/her primary net address if we have one. If it
+is set to the symbol bbdb, then real names will be used from the BBDB
+if present, otherwise the net address in the post will be used. If
+bbdb/gnus-summary-prefer-bbdb-data is nil, then this has no effect.
+See `bbdb/gnus-lines-and-from' for Gnus users, or
+`bbdb/gnus-summary-user-format-letter' for Gnus users."
+ :group 'bbdb-mua-specific-gnus
+ :type '(choice (const :tag "Prefer real names" t)
+ (const :tag "Prefer network addresses" nil)))
+(defvaralias 'bbdb/gnus-header-prefer-real-names
+ 'bbdb/gnus-summary-prefer-real-names)
+
+(defcustom bbdb/gnus-summary-user-format-letter "B"
+ "This is the gnus-user-format-function- that will be used to insert
+the information from the BBDB in the summary buffer (using
+`bbdb/gnus-summary-get-author'). This format code is meant to replace
+codes that insert sender names or addresses (like %A or %n). Unless
+you've already got other code using user format B, you might as well
+stick with the default. Additionally, if the value of this variable
+is nil, no format function will be installed for
+`bbdb/gnus-summary-get-author'. See also
+`bbdb/gnus-summary-in-bbdb-format-letter', which installs a format
+code for `bbdb/gnus-summary-author-in-bbdb'"
+ :group 'bbdb-mua-specific-gnus
+ :type 'character)
+
+(defcustom bbdb/gnus-summary-in-bbdb-format-letter "b"
+ "This is the gnus-user-format-function- that will be used to insert
+`bbdb/gnus-summary-known-poster-mark' (using
+`bbdb/gnus-summary-author-in-bbdb') if the poster is in the BBDB, and
+\" \" if not. If the value of this variable is nil, no format code
+will be installed for `bbdb/gnus-summary-author-in-bbdb'. See also
+`bbdb/gnus-summary-user-format-letter', which installs a format code
+for `bbdb/gnus-summary-get-author'."
+ :group 'bbdb-mua-specific-gnus
+ :type 'character)
+
+(defcustom bbdb-message-marker-field 'mark-char
+ "*The field whose value will be used to mark messages by this user in Gnus."
+ :group 'bbdb-mua-specific-gnus
+ :type 'symbol)
+
+(defun bbdb/gnus-summary-get-author (header)
+ "Given a Gnus message header, returns the appropriate piece of
+information to identify the author in a Gnus summary line, depending on
+the settings of the various configuration variables. See the
+documentation for the following variables for more details:
+ `bbdb/gnus-summary-mark-known-posters'
+ `bbdb/gnus-summary-known-poster-mark'
+ `bbdb/gnus-summary-prefer-bbdb-data'
+ `bbdb/gnus-summary-prefer-real-names'
+This function is meant to be used with the user function defined in
+ `bbdb/gnus-summary-user-format-letter'"
+ (let* ((from (mail-header-from header))
+ (to (let ((gifa (bbdb/gnus-ignored-from-addresses)))
+ (when (and gifa (string-match gifa from))
+ (let* ((extras (mail-header-extra header))
+ (to (or (cdr (assoc 'To extras))
+ (cdr (assoc 'CC extras))
+ (cdr (assoc 'Newgroups extras)))))
+ (if (and to (listp to))
+ (cdr (car to))
+ to)))))
+ (data (and bbdb/gnus-summary-show-bbdb-names
+ (condition-case nil
+ (mail-extract-address-components (or to from))
+ (error nil))))
+ (name (car data))
+ (net (car (cdr data)))
+ (record (and data
+ (bbdb-search-simple
+ name
+ (if (and net bbdb-canonicalize-net-hook)
+ (bbdb-canonicalize-address net)
+ net)))))
+
+ (if (and record name (member (downcase name) (bbdb-record-net record)))
+ ;; bogon!
+ (setq record nil))
+ (setq name
+ (or (and bbdb/gnus-summary-prefer-bbdb-data
+ (or (and bbdb/gnus-summary-prefer-real-names
+ (and record (bbdb-record-name record)))
+ (and record (bbdb-record-net record)
+ (nth 0 (bbdb-record-net record)))))
+ (and bbdb/gnus-summary-prefer-real-names
+ (or (and (equal bbdb/gnus-summary-prefer-real-names 'bbdb)
+ net)
+ name))
+ net from "**UNKNOWN**"))
+ (format "%s%s%s"
+ (if to
+ (if (and (boundp 'gnus-summary-to-prefix)
+ (stringp gnus-summary-to-prefix))
+ gnus-summary-to-prefix
+ "To: ")
+ "")
+ (or (and record bbdb/gnus-summary-mark-known-posters
+ (or (bbdb-record-getprop
+ record bbdb-message-marker-field)
+ bbdb/gnus-summary-known-poster-mark))
+ " ")
+ name)))
+
+;; DEBUG: (bbdb/gnus-summary-author-in-bbdb "From: simmonmt@acm.org")
+(defun bbdb/gnus-summary-author-in-bbdb (header)
+ "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 `bbdb/gnus-summary-known-poster-mark' otherwise."
+ (let* ((from (mail-header-from header))
+ (data (condition-case ()
+ (mail-extract-address-components from)
+ (error nil)))
+ (name (car data))
+ (net (cadr data))
+ record)
+ (if (and data
+ (setq record
+ (bbdb-search-simple
+ name (if (and net bbdb-canonicalize-net-hook)
+ (bbdb-canonicalize-address net)
+ net))))
+ (or (bbdb-record-getprop
+ record bbdb-message-marker-field)
+ bbdb/gnus-summary-known-poster-mark) " ")))
+
+;;
+;; Gnus-specific snarfing (see also bbdb-snarf.el)
+;;
+
+;;;###autoload
+(defun bbdb/gnus-snarf-signature ()
+ "Snarf signature from the corresponding *Article* buffer."
+ (interactive)
+ (save-excursion
+ ;; this is a little bogus, since it will remain set after you've
+ ;; quit Gnus
+ (or gnus-article-buffer (error "Not in Gnus!"))
+ ;; This is wrong for non-ASCII text. Why not use
+ ;; gnus-article-hide-signature?
+ (set-buffer gnus-original-article-buffer)
+ (save-restriction
+ (or (gnus-article-narrow-to-signature) (error "No signature!"))
+ (bbdb-snarf-region (point-min) (point-max)))))
+
+;;
+;; Scoring
+;;
+
+(defcustom bbdb/gnus-score-field 'gnus-score
+ "This variable contains the name of the BBDB field which should be
+checked for a score to add to the net addresses in the same record."
+ :group 'bbdb-mua-specific-gnus-scoring
+ :type 'symbol)
+
+(defcustom bbdb/gnus-score-default nil
+ "If this is set, then every net address in the BBDB that does not have
+an associated score field will be assigned this score. A value of nil
+implies a default score of zero."
+ :group 'bbdb-mua-specific-gnus-scoring
+ :type '(choice (const :tag "Do not assign default score")
+ (integer :tag "Assign this default score" 0)))
+
+(defvar bbdb/gnus-score-default-internal nil
+ "Internal variable for detecting changes to
+`bbdb/gnus-score-default'. You should not set this variable directly -
+set `bbdb/gnus-score-default' instead.")
+
+(defvar bbdb/gnus-score-alist nil
+ "The text version of the scoring structure returned by
+bbdb/gnus-score. This is built automatically from the BBDB.")
+
+(defvar bbdb/gnus-score-rebuild-alist t
+ "Set to t to rebuild bbdb/gnus-score-alist on the next call to
+bbdb/gnus-score. This will be set automatically if you change a BBDB
+record which contains a gnus-score field.")
+
+(defun bbdb/gnus-score-invalidate-alist (rec)
+ "This function is called through `bbdb-after-change-hook',
+and sets `bbdb/gnus-score-rebuild-alist' to t if the changed
+record contains a gnus-score field."
+ (if (bbdb-record-getprop rec bbdb/gnus-score-field)
+ (setq bbdb/gnus-score-rebuild-alist t)))
+
+;;;###autoload
+(defun bbdb/gnus-score (group)
+ "This returns a score alist for Gnus. A score pair will be made for
+every member of the net field in records which also have a gnus-score
+field. This allows the BBDB to serve as a supplemental global score
+file, with the advantage that it can keep up with multiple and changing
+addresses better than the traditionally static global scorefile."
+ (list (list
+ (condition-case nil
+ (read (bbdb/gnus-score-as-text group))
+ (error (setq bbdb/gnus-score-rebuild-alist t)
+ (message "Problem building BBDB score table.")
+ (ding) (sit-for 2)
+ nil)))))
+
+(defun bbdb/gnus-score-as-text (group)
+ "Returns a SCORE file format string built from the BBDB."
+ (cond ((or (cond ((/= (or bbdb/gnus-score-default 0)
+ (or bbdb/gnus-score-default-internal 0))
+ (setq bbdb/gnus-score-default-internal
+ bbdb/gnus-score-default)
+ t))
+ (not bbdb/gnus-score-alist)
+ bbdb/gnus-score-rebuild-alist)
+ (setq bbdb/gnus-score-rebuild-alist nil)
+ (setq bbdb/gnus-score-alist
+ (concat "((touched nil) (\"from\"\n"
+ (mapconcat
+ (lambda (rec)
+ (let ((score (or (bbdb-record-getprop rec
+ bbdb/gnus-score-field)
+ bbdb/gnus-score-default))
+ (net (bbdb-record-net rec)))
+ (if (not (and score net)) nil
+ (mapconcat
+ (lambda (addr)
+ (format "(\"%s\" %s)\n" addr score))
+ net ""))))
+ (bbdb-records) "")
+ "))"))))
+ bbdb/gnus-score-alist)
+
+;;;###autoload
+(defun bbdb/gnus-summary-show-all-recipients (not-elided)
+ "Display BBDB records for all recipients of the message."
+ (interactive "P")
+ (let ((bbdb-display-layout (or (not not-elided)
+ bbdb-pop-up-display-layout
+ bbdb-display-layout))
+ (bbdb-get-only-first-address-p nil))
+ (gnus-summary-select-article)
+ (bbdb/gnus-show-records 'recipients)))
+
+;;; from Brian Edmonds' gnus-bbdb.el
+;;;
+;;; Filing with gnus-folder REQUIRES (ding) 0.50 OR HIGHER
+;;;
+;;; To use this feature, you need to put this file somewhere in your
+;;; load-path and add the following lines of code to your .gnus file:
+;;;
+;;; (setq nnmail-split-methods 'bbdb/gnus-split-method)
+;;;
+;;; You should also examine the variables defvar'd below and customize
+;;; them to your taste. They're listed roughly in descending likelihood
+;;; of your wanting to change them. Once that is done, you need to add
+;;; filing information to your BBDB. There are two fields of interest:
+;;;
+;;; 1. gnus-private. This field contains the name of the group in which
+;;; mail to you from any of the addresses associated with this record
+;;; will be filed. Also, any self-copies of mail you send any of the
+;;; same addresses will be filed here.
+;;; 2. gnus-public. This field is used to keep mail from mailing lists
+;;; out of the private mailboxes. It should be added to a record for
+;;; the list submission address, and is formatted as follows:
+;;; "group regexp"
+;;; where group is where mail from the list should be filed, and
+;;; regexp is a regular expression which is checked against the
+;;; envelope sender (from the From_ header) to verify that this is
+;;; the copy which came from the list. For example, the entry for
+;;; the ding mailing list might be:
+;;; "mail.emacs.ding ding-request@ifi.uio.no"
+;;; Yes, the second part *is* a regexp, so those dots may match
+;;; something other than dots. Sue me.
+;;;
+;;; Note that you can also specify a gnus-private field for mailing list
+;;; addresses, in which case self-copies of mail you send to the list
+;;; will be filed there. Also, the field names can be changed below if
+;;; the defaults aren't hip enough for you. Lastly, if you specify a
+;;; gnus-private field for your *own* BBDB record, then all self-copies
+;;; of mail you send will be filed to that group.
+;;;
+;;; This documentation should probably be expanded and moved to a
+;;; separate file, but it's late, and *I* know what I'm trying to
+;;; say. :)
+
+;;; custom bits
+(defcustom bbdb/gnus-split-default-group "mail.misc"
+ "*If the BBDB doesn't indicate any group to spool a message to, it will
+be spooled to this group. If bbdb/gnus-split-crosspost-default is not
+nil, and if the BBDB did not indicate a specific group for one or more
+addresses, messages will be crossposted to this group in addition to any
+group(s) which the BBDB indicated."
+ :group 'bbdb-mua-specific-gnus-splitting
+ :type 'string)
+
+(defcustom bbdb/gnus-split-nomatch-function nil
+ "*This function will be called after searching the BBDB if no place to
+file the message could be found. It should return a group name (or list
+of group names) -- nnmail-split-fancy as provided with Gnus is an
+excellent choice."
+ :group 'bbdb-mua-specific-gnus-splitting
+ :type 'function)
+
+(defcustom bbdb/gnus-split-myaddr-regexp
+ (concat "^" (user-login-name) "$\\|^"
+ (user-login-name) "@\\([-a-z0-9]+\\.\\)*"
+ (or gnus-local-domain (message-make-domain)
+ (system-name) "") "$")
+ "*This regular expression should match your address as found in the
+From header of your mail. You should make sure gnus-local-domain or
+gnus-use-generic-from are set before loading this module, if they differ
+from (system-name). If you send mail/news from multiple addresses, then
+you'll likely have to set this yourself anyways."
+ :group 'bbdb-mua-specific-gnus-splitting
+ :type 'string)
+
+(defcustom bbdb/gnus-split-crosspost-default nil
+ "*If this variable is not nil, then if the BBDB could not identify a
+group for every mail address, messages will be filed in
+bbdb/gnus-split-default-group in addition to any group(s) which the BBDB
+identified."
+ :group 'bbdb-mua-specific-gnus-splitting
+ :type 'boolean)
+
+(defcustom bbdb/gnus-split-private-field 'gnus-private
+ "*This variable is used to determine the field to reference to find the
+associated group when saving private mail for a network address known to
+the BBDB. The value of the field should be the name of a mail group."
+ :group 'bbdb-mua-specific-gnus-splitting
+ :type 'string)
+
+(defcustom bbdb/gnus-split-public-field 'gnus-public
+ "*This variable is used to determine the field to reference to find the
+associated group when saving non-private mail (received from a mailing
+list) for a network address known to the BBDB. The value of the field
+should be the name of a mail group, followed by a space, and a regular
+expression to match on the envelope sender to verify that this mail came
+from the list in question."
+ :group 'bbdb-mua-specific-gnus-splitting
+ :type 'string)
+
+;; The split function works by assigning one of four spooling priorities
+;; to each group that is associated with an address in the message. The
+;; priorities are assigned as follows:
+;;
+;; 0. This priority is assigned when crosspost-default is nil to To/Cc
+;; addresses which have no private group defined in the BBDB. If the
+;; user's own address has no private group defined, then it will
+;; always be given this priority.
+;; 1. This priority is assigned to To/Cc addresses which have a private
+;; group defined in the BBDB. If crosspost-default is not nil, then
+;; To/Cc addresses which have no private group will also be assigned
+;; this priority. This is also assigned to the user's own address in
+;; the From position if a private group is defined for it.
+;; 2. This priority is assigned to From addresses which have a private
+;; group defined in the BBDB, except for the user's own address as
+;; described under priorities 0 and 1.
+;; 3. This priority is assigned to To/Cc addresses which have a public
+;; group defined in the BBDB, and whose associated regular expression
+;; matches the envelope sender (found in the header From_).
+;;
+;; The split function evaluates the spool priority for each address in
+;; the headers of the message, and returns as a list all the groups
+;; associated with the addresses which share the highest calculated
+;; priority.
+
+;;;#autoload
+(defun bbdb/gnus-split-method nil
+ "This function expects to be called in a buffer which contains a mail
+message to be spooled, and the buffer should be narrowed to the message
+headers. It returns a list of groups to which the message should be
+spooled, using the addresses in the headers and information from the
+BBDB."
+ (let ((prq (list (cons 0 nil) (cons 1 nil) (cons 2 nil) (cons 3 nil))))
+ ;; the From: header is special
+ (let* ((hdr (or (mail-fetch-field "resent-from")
+ (mail-fetch-field "from")
+ (user-login-name)))
+ (rv (bbdb/gnus-split-to-group hdr t)))
+ (setcdr (nth (cdr rv) prq) (cons (car rv) nil)))
+ ;; do the rest of the headers
+ (let ((hdr (or (concat (or (mail-fetch-field "resent-to" nil t)
+ (mail-fetch-field "to" nil t))
+ ", "
+ (mail-fetch-field "cc" nil t)
+ ", "
+ (mail-fetch-field "apparently-to" nil t))
+ "")))
+ (setq hdr (rfc822-addresses hdr))
+ (while hdr
+ (let* ((rv (bbdb/gnus-split-to-group (car hdr)))
+ (pr (nth (cdr rv) prq)))
+ (or (member (car rv) pr) (setcdr pr (cons (car rv) (cdr pr)))))
+ (setq hdr (cdr hdr))))
+ ;; find the highest non-empty queue
+ (setq prq (reverse prq))
+ (while (and prq (not (cdr (car prq)))) (setq prq (cdr prq)))
+ ;; and return...
+ (if (not (or (not (cdr (car prq)))
+ (and (equal (cdr (car prq)) (list bbdb/gnus-split-default-group))
+ (symbolp bbdb/gnus-split-nomatch-function)
+ (fboundp bbdb/gnus-split-nomatch-function))))
+ (cdr (car prq))
+ (goto-char (point-min))
+ (funcall bbdb/gnus-split-nomatch-function))))
+
+(defun bbdb/gnus-split-to-group (addr &optional source)
+ "This function is called from bbdb/gnus-split-method in order to
+determine the group and spooling priority for a single address."
+ (condition-case tmp
+ (progn
+ (setq tmp (mail-extract-address-components addr))
+ (let* ((nam (car tmp))
+ (net (if (not bbdb-canonicalize-net-hook) (car (cdr tmp))
+ (bbdb-canonicalize-address (car (cdr tmp)))))
+ (rec (bbdb-search-simple nam net))
+ pub prv rgx)
+ (if (not rec) nil
+ (setq prv (bbdb-record-getprop rec bbdb/gnus-split-private-field)
+ pub (bbdb-record-getprop rec bbdb/gnus-split-public-field))
+ (if (and pub (not source) (string-match "^\\([^ ]+\\) \\(.*\\)$" pub))
+ (setq rgx (substring pub (match-beginning 2) (match-end 2))
+ pub (substring pub (match-beginning 1) (match-end 1)))
+ (setq pub nil)))
+ (cond
+ ((and rgx pub
+ (goto-char (point-min))
+ (re-search-forward "^From: \\([^ \n]+\\)[ \n]" nil t)
+ (string-match rgx (buffer-substring (match-beginning 1)
+ (match-end 1))))
+ (cons pub 3))
+ (prv
+ (cons prv
+ (- 1 (if source -1 0)
+ (if (string-match bbdb/gnus-split-myaddr-regexp net) 1 0))))
+ (t
+ (cons bbdb/gnus-split-default-group
+ (if (string-match bbdb/gnus-split-myaddr-regexp net) 0
+ (if source 2 (if bbdb/gnus-split-crosspost-default 1 0))))))))
+ (error (cons bbdb/gnus-split-default-group 0))))
+
+;;
+;; Insinuation
+;;
+
+;;;###autoload
+(defun bbdb-insinuate-gnus ()
+ "Call this function to hook BBDB into Gnus."
+ (setq gnus-optional-headers 'bbdb/gnus-lines-and-from)
+ (add-hook 'gnus-article-prepare-hook 'bbdb/gnus-pop-up-bbdb-buffer)
+ (add-hook 'gnus-save-newsrc-hook 'bbdb-offer-save)
+ (define-key gnus-summary-mode-map ":" 'bbdb/gnus-show-sender)
+ (define-key gnus-summary-mode-map ";" 'bbdb/gnus-edit-notes)
+
+ ;; Set up user field for use in gnus-summary-line-format
+ (let ((get-author-user-fun (intern
+ (concat "gnus-user-format-function-"
+ bbdb/gnus-summary-user-format-letter)))
+ (in-bbdb-user-fun (intern
+ (concat "gnus-user-format-function-"
+ bbdb/gnus-summary-in-bbdb-format-letter))))
+ ; The big one - whole name
+ (cond (bbdb/gnus-summary-user-format-letter
+ (if (and (fboundp get-author-user-fun)
+ (not (eq (symbol-function get-author-user-fun)
+ 'bbdb/gnus-summary-get-author)))
+ (bbdb-warn
+ (format "`gnus-user-format-function-%s' already seems to be in use.
+Please redefine `bbdb/gnus-summary-user-format-letter' to a different letter."
+ bbdb/gnus-summary-user-format-letter))
+ (fset get-author-user-fun 'bbdb/gnus-summary-get-author))))
+
+ ; One tick. One tick only, please
+ (cond (bbdb/gnus-summary-in-bbdb-format-letter
+ (if (and (fboundp in-bbdb-user-fun)
+ (not (eq (symbol-function in-bbdb-user-fun)
+ 'bbdb/gnus-summary-author-in-bbdb)))
+ (bbdb-warn
+ (format "`gnus-user-format-function-%s' already seems to be in use.
+Redefine `bbdb/gnus-summary-in-bbdb-format-letter' to a different letter."
+ bbdb/gnus-summary-in-bbdb-format-letter))
+ (fset in-bbdb-user-fun 'bbdb/gnus-summary-author-in-bbdb)))))
+
+ ;; Scoring
+ (add-hook 'bbdb-after-change-hook 'bbdb/gnus-score-invalidate-alist)
+; (setq gnus-score-find-score-files-function
+; (if (boundp 'gnus-score-find-score-files-function)
+; (cond ((functionp gnus-score-find-score-files-function)
+; (list gnus-score-find-score-files-function
+; 'bbdb/gnus-score))
+; ((listp gnus-score-find-score-files-function)
+; (append gnus-score-find-score-files-function
+; 'bbdb/gnus-score))
+; (t 'bbdb/gnus-score))
+; 'bbdb/gnus-score))
+ )
+
+;; Uwe Brauer
+(defun bbdb/gnus-nnimap-folder-list-from-bbdb ()
+ "Return a list of \( \"From\" email-regexp imap-folder-name\) tuples
+based on the contents of the bbdb.
+
+The folder-name is the value of the 'imap attribute on the bbdb
+record; the email-regexp consists of all the email addresses for the
+bbdb record concatenated with with OR. bbdb records without a 'imap
+attribute are ignored.
+Here is an example of a relevant BBDB entry:
+
+Uwe Brauer
+ net: oub@mat.ucm.es
+ imap: testimap
+
+
+This function uses regexp-opt to generate the email-regexp which
+automatically regexp-quotes its arguments. Please note: in oder that
+this will work with the nnimap-split-fancy method you have to use
+macros, that is your setting will look like:
+
+\(setq
+ nnimap-split-rule 'nnimap-split-fancy
+ nnimap-split-inbox \"INBOX\"
+ nnimap-split-fancy
+ `\(|
+ ,@\(bbdb/gnus-nnimap-folder-list-from-bbdb\)
+ ...
+\)\)
+Note that `\( is the backquote NOT the quote '\(. "
+
+ ;(interactive)
+ (let ( ;; the raw-notes attribute of a bbdb record
+ notes-attr
+ ;; the value of the 'imap attribute of a bbdb record
+ folder-attr
+ ;; strings to put before and after the folder-attr
+ (folder-prefix "")
+ (folder-postfix "")
+ ;; a regexp matching all the email addresses from a bbdb record
+ email-regexp
+ ;; the list of (folder email) tuples to return
+ new-elmnt-list
+ )
+ ;; loop over the bbdb-records; if a imap attribute exists on
+ ;; the record, generate a regexp matching all the email addresses
+ ;; and add a tuple (folder email-regexp) to the new-elmnt-list
+ (dolist (record (bbdb-records))
+ (setq notes-attr (bbdb-record-raw-notes record))
+ (when (and (listp notes-attr)
+ (setq folder-attr (cdr (assq 'imap notes-attr))))
+ (setq email-regexp (regexp-opt (mapcar 'downcase
+ (bbdb-record-net record))))
+ (unless (zerop (length email-regexp))
+ (setq new-elmnt-list
+ (cons (list "From" email-regexp (concat folder-prefix
+ folder-attr folder-postfix))
+ new-elmnt-list)))))
+ new-elmnt-list))
+
+
+(provide 'bbdb-gnus)
diff --git a/lisp/bbdb-gui.el b/lisp/bbdb-gui.el
new file mode 100644
index 0000000..867bef5
--- /dev/null
+++ b/lisp/bbdb-gui.el
@@ -0,0 +1,530 @@
+;;; -*- Mode:Emacs-Lisp -*-
+;;; This file contains font and menu hacks for BBDB.
+
+;;; This file is the part of the Insidious Big Brother Database (aka BBDB),
+;;; copyright (c) 1992, 1993, 1994 Jamie Zawinski <jwz@netscape.com>.
+
+;;; 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 2, 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
+;;; details.
+;;;
+;;; 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.
+
+;;; This code is kind of kludgey, mostly because it needs to parse the contents
+;;; of the *BBDB* buffer, since BBDB doesn't save the buffer-positions of the
+;;; various fields when it fills in that buffer (doing that would be slow and
+;;; cons a lot, so it doesn't seem to be worth it.)
+
+(require 'bbdb)
+(require 'bbdb-com)
+
+(eval-and-compile
+ (if (featurep 'xemacs)
+ (require 'overlay)))
+
+;; compiler whinage. Some of this is legacy stuff that would probably
+;; be better deleted.
+(defvar scrollbar-height nil)
+
+;; MIGRATE XXX
+(eval-and-compile
+ (if (fboundp 'set-specifier)
+ (defalias 'bbdb-set-specifier 'set-specifier)
+ (defalias 'bbdb-set-specifier 'ignore))
+ (if (fboundp 'make-glyph)
+ (defalias 'bbdb-make-glyph 'make-glyph)
+ (defalias 'bbdb-make-glyph 'ignore))
+ (if (fboundp 'set-glyph-face)
+ (defalias 'bbdb-set-glyph-face 'set-glyph-face)
+ (defalias 'bbdb-set-glyph-face 'ignore))
+ (if (fboundp 'highlight-headers-x-face)
+ (defalias 'bbdb-highlight-headers-x-face 'highlight-headers-x-face)
+ (defalias 'bbdb-highlight-headers-x-face 'ignore))
+ (if (fboundp 'highlight-headers-x-face-to-pixmap)
+ (defalias 'bbdb-highlight-headers-x-face-to-pixmap
+ 'highlight-headers-x-face-to-pixmap)
+ (defalias 'bbdb-highlight-headers-x-face-to-pixmap 'ignore)))
+
+
+(if (featurep 'xemacs)
+ (progn
+ (define-key bbdb-mode-map 'button3 'bbdb-menu)
+ (define-key bbdb-mode-map 'button2
+ (lambda (e)
+ (interactive "e")
+ (mouse-set-point e)
+ (bbdb-toggle-records-display-layout nil))))
+ (define-key bbdb-mode-map [mouse-3] 'bbdb-menu)
+ (define-key bbdb-mode-map [mouse-2]
+ (lambda (e)
+ (interactive "e")
+ (mouse-set-point e)
+ (bbdb-toggle-records-display-layout nil))))
+
+(eval-and-compile
+ (if (fboundp 'find-face)
+ (defalias 'bbdb-find-face 'find-face)
+ (if (fboundp 'internal-find-face) ;; GRR.
+ ;; This should be facep in Emacs 21
+ (defalias 'bbdb-find-face 'internal-find-face)
+ (defalias 'bbdb-find-face 'ignore)))) ; noop - you probably don't HAVE faces.
+
+(or (bbdb-find-face 'bbdb-name)
+ (face-differs-from-default-p (make-face 'bbdb-name))
+ (set-face-underline-p 'bbdb-name t))
+
+(condition-case nil
+ (or (bbdb-find-face 'bbdb-company)
+ (face-differs-from-default-p (make-face 'bbdb-company))
+ (make-face-italic 'bbdb-company)) ;; this can fail on emacs
+ (error nil))
+
+(or (bbdb-find-face 'bbdb-field-value)
+ (make-face 'bbdb-field-value))
+
+(or (bbdb-find-face 'bbdb-field-name)
+ (face-differs-from-default-p (make-face 'bbdb-field-name))
+ (copy-face 'bold 'bbdb-field-name))
+
+;;; Extents vs. Overlays unhappiness
+;;; FIXME: see if VM is around, and call its extents code instead;
+;;; change bbdb-foo-extents below to vm-foo-extents, etc.
+(eval-and-compile
+ (if (fboundp 'make-extent)
+ (defalias 'bbdb-make-extent 'make-extent)
+ (defalias 'bbdb-make-extent 'make-overlay))
+
+ (if (fboundp 'delete-extent)
+ (defalias 'bbdb-delete-extent 'delete-extent)
+ (defalias 'bbdb-delete-extent 'delete-overlay))
+
+ (if (fboundp 'mapcar-extents)
+ (defmacro bbdb-list-extents() `(mapcar-extents 'identity))
+ (defun bbdb-list-extents()
+ (let ((o (overlay-lists))) (nconc (car o) (cdr o)))))
+
+ (if (fboundp 'mapcar-extents)
+ (defmacro bbdb-extents-in (s e)
+ (list 'mapcar-extents ''identity nil nil s e))
+ (defmacro bbdb-extents-in (s e)
+ (list 'overlays-in s e)))
+
+ (if (fboundp 'set-extent-property)
+ (defalias 'bbdb-set-extent-property 'set-extent-property)
+ (defun bbdb-set-extent-property( e p v )
+ (if (eq 'highlight p)
+ (if v
+ (overlay-put e 'mouse-face 'highlight)
+ (overlay-put e 'mouse-face nil)))
+ (overlay-put e p v)))
+
+ (if (fboundp 'extent-property)
+ (defalias 'bbdb-extent-property 'extent-property)
+ (defalias 'bbdb-extent-property 'overlay-get))
+
+ (if (fboundp 'extent-at)
+ (defalias 'bbdb-extent-at 'extent-at)
+ (defun bbdb-extent-at (pos buf tag) "NOT FULL XEMACS IMPLEMENTATION"
+ (let ((o (overlays-at pos))
+ minpri retval)
+ (while (car o)
+ (let ((x (car o)))
+ (and (overlayp x)
+ (overlay-get x tag)
+ (if (or (null minpri) (> minpri (overlay-get x 'priority)))
+ (setq retval x
+ minpri (overlay-get x 'priority))))
+ (setq o (cdr o))))
+ retval)))
+
+ (if (fboundp 'highlight-extent)
+ (defalias 'bbdb-highlight-extent 'highlight-extent)
+ (defalias 'bbdb-highlight-extent 'ignore)) ; XXX noop
+
+ (if (fboundp 'extent-start-position)
+ (defalias 'bbdb-extent-start-position 'extent-start-position)
+ (defalias 'bbdb-extent-start-position 'overlay-start))
+
+ (if (fboundp 'extent-end-position)
+ (defalias 'bbdb-extent-end-position 'extent-end-position)
+ (defalias 'bbdb-extent-end-position 'overlay-end))
+
+ (if (fboundp 'extent-face)
+ (defalias 'bbdb-extent-face 'extent-face)
+ (defun bbdb-extent-face (extent)
+ (overlay-get extent 'face)))
+
+ (if (fboundp 'set-extent-face)
+ (defalias 'bbdb-set-extent-face 'set-extent-face)
+ (defun bbdb-set-extent-face (extent face) "set the face for an overlay"
+ (overlay-put extent 'face face)))
+
+ (if (fboundp 'set-extent-begin-glyph)
+ (defalias 'bbdb-set-extent-begin-glyph 'set-extent-begin-glyph)
+ (defalias 'bbdb-set-extent-begin-glyph 'ignore)) ; XXX noop
+
+ (if (fboundp 'set-extent-end-glyph)
+ (defalias 'bbdb-set-extent-end-glyph 'set-extent-end-glyph)
+ (defalias 'bbdb-set-extent-end-glyph 'ignore))) ; XXX noop
+
+
+(eval-when-compile (defvar scrollbar-height))
+;;;###autoload
+(defun bbdb-fontify-buffer (&optional records)
+ (interactive)
+ (save-excursion
+ (set-buffer bbdb-buffer-name)
+ (if (featurep 'scrollbar)
+ (bbdb-set-specifier scrollbar-height (cons (current-buffer) 0)))
+
+ (let ((rest (or records bbdb-records))
+ record face
+ start end s e
+ multi-line-p
+ property
+ extent)
+
+ (while rest
+ (setq record (car (car rest))
+ multi-line-p (string-match "multi-line"
+ (symbol-name (nth 1 (car rest))))
+ face (and multi-line-p (bbdb-record-getprop record 'face))
+ start (marker-position (nth 2 (car rest)))
+ end (1- (or (nth 2 (car (cdr rest))) (point-max))))
+
+ (if (< start (point-min)) (setq start (point-min)))
+ (if (> end (point-max)) (setq end (point-max)))
+
+ (mapc (function (lambda(o)
+ (if (and o
+ (eq (bbdb-extent-property o 'data)
+ 'bbdb))
+ (bbdb-delete-extent o))))
+ (bbdb-extents-in start end))
+
+ (setq extent (bbdb-make-extent start end))
+ (bbdb-set-extent-property extent 'highlight t)
+ (bbdb-set-extent-property extent 'data 'bbdb)
+ ;; note that on GNU Emacs, once you hit the main overlay, you
+ ;; have to move off the record and back on again before it'll
+ ;; notice that you're on a more specific overlay. This is
+ ;; bogus, like most GNU Emacs GUI stuff.
+ (bbdb-set-extent-property extent 'priority 3)
+ (if face (bbdb-hack-x-face face extent))
+ (goto-char start)
+ (setq s start)
+ (setq property (cadr (member 'bbdb-field (text-properties-at s))))
+ (while (and s (< s end))
+ (setq e (or (next-single-property-change (1+ s) 'bbdb-field)
+ (point-max)))
+ (cond ((equal property '(name))
+ (setq extent (bbdb-make-extent s e))
+ (bbdb-set-extent-property extent 'priority 2)
+ (bbdb-set-extent-property extent 'data 'bbdb)
+ (bbdb-set-extent-face extent 'bbdb-name))
+ ((equal property '(company))
+ (setq extent (bbdb-make-extent s e))
+ (bbdb-set-extent-property extent 'priority 2)
+ (bbdb-set-extent-property extent 'data 'bbdb)
+ (bbdb-set-extent-face extent 'bbdb-company))
+ ((member 'field-name property)
+ (goto-char s)
+ (setq extent (bbdb-make-extent s e))
+ (bbdb-set-extent-property extent 'priority 2)
+ (bbdb-set-extent-property extent 'data 'bbdb)
+ (bbdb-set-extent-face extent 'bbdb-field-name))
+ (t
+ (setq extent (bbdb-make-extent start e))
+ (bbdb-set-extent-property extent 'priority 2)
+ (bbdb-set-extent-property extent 'data 'bbdb)
+ (bbdb-set-extent-face extent 'bbdb-field-value)))
+ (setq s e)
+ (while (and s (null (setq property
+ (cadr (member 'bbdb-field
+ (text-properties-at s))))))
+ (setq s (next-single-property-change s 'bbdb-field))))
+
+ (setq rest (cdr rest))
+ (if (null (caar rest))
+ (setq rest nil))))))
+
+;;; share the xface cache data with VM if it's around
+(defvar vm-xface-cache (make-vector 29 0))
+(eval-when-compile (defvar highlight-headers-hack-x-face-p))
+
+;; In Emacs 21, this could use the x-face support from Gnus.
+(defun bbdb-hack-x-face (face extent)
+ "Process a face property of a record and honour it.
+Not done for GNU Emacs just yet, since it doesn't have image support
+as of GNU Emacs 20.7"
+ (if (not (or (and (fboundp 'highlight-headers-hack-x-face-p)
+ (symbol-value (intern ;; compiler
+ "highlight-headers-hack-x-face-p"))) ;; ick.
+ (and (featurep 'xemacs)
+ (string-match "^21\\." emacs-version)))) ;; XXX
+ () ;; nothing doing
+ (setq face (bbdb-split face "\n"))
+ (while face
+ (cond
+
+ ;; ripped pretty much verbatim from VM; X Faces for recent XEmacsen.
+ ((string-match "^21\\." emacs-version) ;; XXX how far back can I go?
+ (condition-case nil
+ (let* ((h (concat "X-Face: " (car face))) ;; from vm-display-xface
+ (g (intern h vm-xface-cache)))
+ (if (bbdb-find-face 'vm-xface) ;; use the same face as VM
+ nil
+ (make-face 'vm-xface)
+ (set-face-background 'vm-xface "white")
+ (set-face-foreground 'vm-xface "black"))
+ (if (boundp g)
+ (setq g (symbol-value g))
+ (set g (bbdb-make-glyph
+ (list
+ (vector 'xface ':data h)))) ;; XXX use API
+ (setq g (symbol-value g))
+ (bbdb-set-glyph-face g 'vm-xface))
+ (bbdb-set-extent-property extent 'vm-xface t)
+ (bbdb-set-extent-begin-glyph extent g))
+ (error nil))) ;; looks like you don't have xface support, d00d
+
+ ;; requires lemacs 19.10 version of highlight-headers.el
+ ((fboundp 'highlight-headers-x-face) ; the 19.10 way
+ (bbdb-highlight-headers-x-face (car face) extent)
+ (let ((b (bbdb-extent-property extent 'begin-glyph)))
+ (cond (b ; I'd like this to be an end-glyph instead
+ (bbdb-set-extent-property extent 'begin-glyph nil)
+ (bbdb-set-extent-property extent 'end-glyph b)))))
+
+ ((fboundp 'highlight-headers-x-face-to-pixmap) ; the 19.13 way
+ (save-excursion
+ (set-buffer (get-buffer-create " *tmp*"))
+ (buffer-disable-undo (current-buffer))
+ (erase-buffer)
+ (insert (car face))
+ (bbdb-set-extent-begin-glyph extent nil)
+ (bbdb-set-extent-end-glyph extent
+ (bbdb-highlight-headers-x-face-to-pixmap
+ (point-min) (point-max)))
+ (erase-buffer))))
+
+ ;; more faces?
+ (setq face (cdr face))
+ (cond (face ; there are more, so clone the extent
+ (setq extent (bbdb-make-extent
+ (bbdb-extent-start-position extent)
+ (bbdb-extent-end-position extent)))
+ (bbdb-set-extent-property extent 'data 'bbdb))))))
+
+
+(defcustom bbdb-user-menu-commands nil
+ "User defined menu entries which should be appended to the BBDB menu.
+This should be a list of menu entries.
+When set to a fucntion the function gets called with two arguments the
+RECORD and the FIELD and it should either return nil or a list of menu
+entries."
+ :group 'bbdb-database
+ :type 'sexp)
+
+(defun build-bbdb-finger-menu (record)
+ (let ((addrs (bbdb-record-finger-host record)))
+ (if (cdr addrs)
+ (cons "Finger..."
+ (nconc
+ (mapcar (lambda (addr)
+ (vector addr (list 'bbdb-finger record addr)
+ t))
+ addrs)
+ (list "----"
+ (vector "Finger all addresses"
+ (list 'bbdb-finger record ''(4)) t))))
+ (vector (concat "Finger " (car addrs))
+ (list 'bbdb-finger record (car addrs)) t))))
+
+(defun build-bbdb-sendmail-menu (record)
+ (let ((addrs (bbdb-record-net record)))
+ (if (cdr addrs)
+ (cons "Send Mail..."
+ (mapcar (lambda (addr)
+ (vector addr (list 'bbdb-send-mail-internal
+ (bbdb-dwim-net-address record addr))
+ t))
+ addrs))
+ (vector (concat "Send mail to " (car addrs))
+ (list 'bbdb-send-mail-internal
+ (bbdb-dwim-net-address record (car addrs)))
+ t))))
+
+
+(defun build-bbdb-field-menu (record field)
+ (let ((type (car field)))
+ (nconc
+ (list
+ (concat "Commands for "
+ (cond ((eq type 'property)
+ (concat "\""
+ (symbol-name (if (consp (car (cdr field)))
+ (car (car (cdr field)))
+ (car (cdr field))))
+ "\" field:"))
+ ((eq type 'name) "Name field:")
+ ((eq type 'company) "Company field:")
+ ((eq type 'net) "Network Addresses field:")
+ ((eq type 'aka) "Alternate Names field:")
+ (t
+ (concat "\"" (aref (nth 1 field) 0) "\" "
+ (capitalize (symbol-name type)) " field:"))))
+ "-----"
+ ["Edit Field" bbdb-edit-current-field t]
+ )
+ (if (memq type '(name company))
+ nil
+ (list ["Delete Field" bbdb-delete-current-field-or-record t]))
+ (cond ((eq type 'phone)
+ (list (vector (concat "Dial " (bbdb-phone-string (car (cdr field))))
+ (list 'bbdb-dial (list 'quote field) nil) t)))
+ )
+ )))
+
+
+(defun build-bbdb-insert-field-menu (record)
+ (cons "Insert New Field..."
+ (mapcar
+ (lambda (field)
+ (let ((type (if (string= (car field) "AKA")
+ 'aka
+ (intern (car field)))))
+ (vector (car field)
+ (list 'bbdb-insert-new-field
+ record
+ (list 'quote type)
+ (list 'bbdb-prompt-for-new-field-value
+ (list 'quote type)))
+ (not
+ (or (and (eq type 'net) (bbdb-record-net record))
+ (and (eq type 'aka) (bbdb-record-aka record))
+ (and (eq type 'notes) (bbdb-record-notes record))
+ (and (consp (bbdb-record-raw-notes record))
+ (assq type (bbdb-record-raw-notes record))))))))
+ (append '(("phone") ("address") ("net") ("AKA") ("notes"))
+ (bbdb-propnames)))))
+
+
+(defun build-bbdb-menu (record field)
+ (delete
+ nil
+ (append
+ '("bbdb-menu" "Global BBDB Commands" "-----")
+ (list
+ ["Save BBDB" bbdb-save-db t]
+ ["Toggle All Records Display Layout"
+ bbdb-toggle-all-records-display-layout t]
+ ["Finger All Records" (bbdb-finger (mapcar 'car bbdb-records)) t]
+ ["BBDB Manual" bbdb-info t]
+ ["BBDB Quit" bbdb-bury-buffer t])
+ (if record
+ (list
+ "-----"
+ (concat "Commands for record \""
+ (bbdb-record-name record) "\":")
+ "-----"
+ (vector "Delete Record"
+ (list 'bbdb-delete-current-record record) t)
+ ["Toggle Records Display Layout" bbdb-toggle-records-display-layout t]
+ (if (and (not (eq 'full-multi-line
+ (nth 1 (assq record bbdb-records))))
+ (bbdb-display-layout-get-option 'multi-line 'omit))
+ ["Fully Display Record" bbdb-display-record-completely t])
+ ["Omit Record" bbdb-omit-record t]
+ ["Refile (Merge) Record" bbdb-refile-record t]
+ ))
+ (if record
+ (list (build-bbdb-finger-menu record)))
+ (if (bbdb-record-net record)
+ (list (build-bbdb-sendmail-menu record)))
+ (if record
+ (list (build-bbdb-insert-field-menu record)))
+ (if field
+ (cons "-----" (build-bbdb-field-menu record field)))
+ (if bbdb-user-menu-commands
+ (let ((menu (if (functionp bbdb-user-menu-commands)
+ (funcall bbdb-user-menu-commands record field)
+ bbdb-user-menu-commands)))
+ (if menu
+ (append ["-----"]
+ ["User Defined Commands"]
+ ["-----"]
+ menu)))))))
+
+(eval-and-compile
+ (if (fboundp 'popup-menu)
+ (progn
+ (fset 'bbdb-popup 'popup-menu)
+ (fset 'bbdb-desc-to-menu 'identity))
+ ;; This is really, REALLY ugly, but it saves me some coding and uses
+ ;; the correct keymap API instead of carnal knowledge of keymap
+ ;; structure.
+ (defun bbdb-desc-to-menu(desc)
+ (let ((map (make-sparse-keymap (car desc)))
+ (desc (reverse (cdr desc))) ;; throw away header, reorient list
+ (txtcount 0) elt elt-name)
+ (while (setq elt (car desc))
+ ;; fake a key binding name
+ (setq elt-name (intern (format "fake%d" txtcount))
+ txtcount (+ 1 txtcount))
+ (cond
+ ;; non-active entries in the menu
+ ((stringp elt)
+ (define-key map (vector elt-name) (list elt)))
+
+ ;; active entries in the menu
+ ((vectorp elt)
+ (define-key map (vector elt-name) (cons (aref elt 0) (aref elt 1))))
+
+ ;; submenus
+ ((listp elt)
+ (define-key map (vector elt-name)
+ (cons (car elt) (bbdb-desc-to-menu elt))))
+ )
+ (setq desc (cdr desc)))
+ map))
+ ;; this does the actual popping up & parsing nonsense
+ (defun bbdb-popup( desc &optional event )
+ (let ((map (bbdb-desc-to-menu desc)) result)
+ (setq result (x-popup-menu t map))
+ (if result
+ (let ((command (lookup-key map (vconcat result))))
+ ;; Clear out echoing, which perhaps shows a prefix arg.
+ (message "")
+ (if command
+ (if (commandp command)
+ (command-execute command)
+ (funcall 'eval command)))))))))
+
+;;;###autoload
+(defun bbdb-menu (event)
+ (interactive "e")
+ (mouse-set-point event)
+ (bbdb-popup
+ (save-window-excursion
+ (save-excursion
+ (let ((extent (or (bbdb-extent-at (point) (current-buffer) 'highlight)
+ (error "")))
+ record field)
+ (or (eq (bbdb-extent-property extent 'data) 'bbdb)
+ (error "not a bbdb extent"))
+ (bbdb-highlight-extent extent t)
+ (setq record (bbdb-current-record)
+ field (get-text-property (point) 'bbdb-field))
+ (build-bbdb-menu record field))))))
+
+;; tell everyone else we're here.
+(provide 'bbdb-gui)
diff --git a/lisp/bbdb-hooks.el b/lisp/bbdb-hooks.el
new file mode 100644
index 0000000..09b1e89
--- /dev/null
+++ b/lisp/bbdb-hooks.el
@@ -0,0 +1,713 @@
+;;; -*- Mode:Emacs-Lisp -*-
+
+;;; This file is part of the Insidious Big Brother Database (aka BBDB),
+;;; copyright (c) 1991, 1992, 1993 Jamie Zawinski <jwz@netscape.com>.
+;;; Various additional functionality for the BBDB. 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 2 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
+;;; details.
+;;;
+;;; 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.
+
+;;; This file lets you do stuff like
+;;;
+;;; o automatically update a "timestamp" field each time a record is
+;;; modified
+;;; o automatically add some string to the notes field(s) based on the
+;;; contents of header fields of the current message
+;;; o only automatically create entries when certain header fields
+;;; are matched
+;;; o don't automatically create entries when certain header fields
+;;; are matched
+;;;
+;;; Read the docstrings; read the texinfo file.
+
+(require 'bbdb)
+(require 'bbdb-com)
+(require 'bbdb-autoloads)
+(require 'mail-parse)
+
+(eval-when-compile
+ (condition-case()
+ (progn
+ (require 'gnus)
+ (require 'bbdb-gnus))
+ (error nil))
+ (condition-case()
+ (progn
+ (require 'vm)
+ (require 'vm-version)
+ (require 'bbdb-vm))
+ (error nil))
+ (autoload 'mh-show "mh-e")
+ (condition-case()
+ (require 'bbdb-rmail)
+ (error (message "Warning: Could not load RMAIL")))
+ (condition-case()
+ (require 'bbdb-mhe)
+ (error (message "Warning: Could not load MHE"))))
+
+(defvar rmail-buffer)
+(defvar mh-show-buffer)
+
+
+(defvar bbdb-time-internal-format "%Y-%m-%d"
+ "The internal date format.")
+
+;;;###autoload
+(defun bbdb-timestamp-hook (record)
+ "For use as a `bbdb-change-hook'; maintains a notes-field called `timestamp'
+for the given record which contains the time when it was last modified. If
+there is such a field there already, it is changed, otherwise it is added."
+ (bbdb-record-putprop record 'timestamp (format-time-string
+ bbdb-time-internal-format
+ (current-time))))
+
+;;;###autoload
+(defun bbdb-creation-date-hook (record)
+ "For use as a `bbdb-create-hook'; adds a notes-field called `creation-date'
+which is the current time string."
+ ;; hey buddy, we've known about your antics since the eighties...
+ (bbdb-record-putprop record 'creation-date (format-time-string
+ bbdb-time-internal-format
+ (current-time))))
+
+
+;;; Determining whether to create a record based on the content of the
+;;; current message.
+
+(eval-when-compile
+ (defvar vm-mail-buffer)
+ (defvar vm-message-pointer)
+ (autoload 'vm-start-of "vm")
+ (autoload 'bbdb/vm-pop-up-bbdb-buffer "bbdb-vm"))
+
+;;;###autoload
+(defun bbdb-header-start ()
+ "Returns a marker at the beginning of the header block of the current
+message. This will not necessarily be in the current buffer."
+ (cond ((memq major-mode
+ '(gnus-group-mode gnus-summary-mode gnus-article-mode))
+ (set-buffer (or gnus-original-article-buffer
+ gnus-article-buffer))
+ (point-min-marker))
+ ((memq major-mode '(vm-presentation-mode vm-mode vm-summary-mode))
+ (if vm-mail-buffer (set-buffer vm-mail-buffer))
+ (vm-start-of (car vm-message-pointer)))
+ ((memq major-mode '(rmail-mode rmail-summary-mode))
+ (if (and (boundp 'rmail-buffer) rmail-buffer)
+ (set-buffer rmail-buffer))
+ (point-min-marker))
+ ;; MH-E clause added by knabe.
+ ((eq major-mode 'mh-folder-mode)
+ (mh-show)
+ (set-buffer mh-show-buffer)
+ (point-min-marker))
+ (t (point-min-marker))
+ ))
+
+
+;;;###autoload
+(defun bbdb-extract-field-value (field-name)
+ "Given the name of a field (like \"Subject\") this returns the value of
+that field in the current message, or nil. This works whether you're in
+Gnus, Rmail, or VM. This works on multi-line fields, but if more than
+one field of the same name is present, only the last is returned. It is
+expected that the current buffer has a message in it, and (point) is at the
+beginning of the message headers."
+ ;; we can't special-case VM here to use its cache, because the cache has
+ ;; divided real-names from addresses; the actual From: and Subject: fields
+ ;; exist only in the message.
+ (save-excursion
+ (if (memq major-mode
+ '(gnus-summary-mode gnus-article-mode gnus-tree-mode))
+ (progn
+ (set-buffer (get-buffer gnus-original-article-buffer))
+ (goto-char (point-min))))
+ (setq field-name (concat (regexp-quote field-name) "[ \t]*:[ \t]*"))
+ (let ((case-fold-search t)
+ done)
+ (while (not (or done
+ (looking-at "\n") ; we're at BOL
+ (eobp)))
+ (if (looking-at field-name)
+ (progn
+ (goto-char (match-end 0))
+ (setq done (buffer-substring (point)
+ (progn (end-of-line) (point))))
+ (while (looking-at "\n[ \t]")
+ (setq done (concat done " "
+ (buffer-substring (match-end 0)
+ (progn (end-of-line 2) (point))))))))
+ (forward-line 1))
+ (and done
+ (mail-decode-encoded-word-string done)))))
+
+(defcustom bbdb-ignore-most-messages-alist '()
+ "*An alist describing which messages to automatically create BBDB
+records for. This only works if bbdb/news-auto-create-p or
+bbdb/mail-auto-create-p (or both) is 'bbdb-ignore-most-messages-hook.
+The format of this alist is
+ (( HEADER-NAME . REGEXP ) ... )
+for example,
+ ((\"From\" . \"@.*\\.maximegalon\\.edu\")
+ (\"Subject\" . \"time travel\"))
+will cause BBDB entries to be made only for messages sent by people at
+Maximegalon U., or (that's *or*) people posting about time travel.
+
+See also bbdb-ignore-some-messages-alist, which has the opposite effect."
+ :group 'bbdb-noticing-records
+ :type '(repeat (cons
+ (string :tag "Header name")
+ (regexp :tag "Regex to match on header value"))))
+
+
+(defcustom bbdb-ignore-some-messages-alist '()
+ "*An alist describing which messages *not* to automatically create
+BBDB records for. This only works if bbdb/news-auto-create-p or
+bbdb/mail-auto-create-p (or both) is 'bbdb-ignore-some-messages-hook.
+The format of this alist is
+ (( HEADER-NAME . REGEXP ) ... )
+for example,
+ ((\"From\" . \"mailer-daemon\")
+ (\"To\" . \"mailing-list-1\\\\|mailing-list-2\")
+ (\"CC\" . \"mailing-list-1\\\\|mailing-list-2\"))
+will cause BBDB entries to not be made for messages from any mailer daemon,
+or messages sent to or CCed to either of two mailing lists.
+
+See also bbdb-ignore-most-messages-alist, which has the opposite effect."
+ :group 'bbdb-noticing-records
+ :type '(repeat (cons
+ (string :tag "Header name")
+ (regexp :tag "Regex to match on header value"))))
+
+
+;;;###autoload
+(defun bbdb-ignore-most-messages-hook (&optional invert-sense)
+ "For use as the value of bbdb/news-auto-create-p or bbdb/mail-auto-create-p.
+This will automatically create BBDB entries for messages which match
+the bbdb-ignore-most-messages-alist (which see) and *no* others."
+ ;; don't need to optimize this to check the cache, because if
+ ;; bbdb/*-update-record uses the cache, this won't be called.
+ (let ((rest (if invert-sense
+ bbdb-ignore-some-messages-alist
+ bbdb-ignore-most-messages-alist))
+ (case-fold-search t)
+ (done nil)
+ (b (current-buffer))
+ (marker (bbdb-header-start))
+ field regexp fieldval)
+ (set-buffer (marker-buffer marker))
+ (save-restriction
+ (widen)
+ (while (and rest (not done))
+ (goto-char marker)
+ (setq field (car (car rest))
+ regexp (cdr (car rest))
+ fieldval (bbdb-extract-field-value field))
+ (if (and fieldval (string-match regexp fieldval))
+ (setq done t))
+ (setq rest (cdr rest))))
+ (set-buffer b)
+ (if invert-sense
+ (not done)
+ done)))
+
+;;; Provided by Bill Carpenter.
+(defvar bbdb-ignore-selected-messages-confirmation nil
+ "*If bbdb-ignore-selected-messages-hook is used as an auto-create-hook, this
+variable governs whether you are prompted for creation of BBDB entries.")
+
+;;;###autoload
+(defun bbdb-ignore-selected-messages-hook ()
+ "For use as a bbdb/news-auto-create-hook or bbdb/mail-auto-create-hook.
+This will automatically create BBDB entries for messages based on a
+combination of bbdb-ignore-some-messages-alist and
+bbdb-ignore-most-messages-alist. It first looks at the SOME list. If
+that doesn't disqualify a message, then it looks at the MOST list. If
+that qualifies the message, the record is auto-created, but a
+confirmation is conditionally sought, based on the value of
+`bbdb-ignore-selected-messages-confirmation'."
+ (if (bbdb-ignore-some-messages-hook)
+ ;; wasn't ruled out
+ (if (bbdb-ignore-most-messages-hook)
+ ;; was ruled in
+ (if bbdb-ignore-selected-messages-confirmation
+ (let ((case-fold-search t)
+ (marker (bbdb-header-start))
+ record-exists from)
+ (save-excursion
+ (set-buffer (marker-buffer marker))
+ (save-restriction
+ (widen)
+ (goto-char marker)
+ (setq from (bbdb-extract-field-value "FROM"))))
+ (setq record-exists (bbdb-annotate-message-sender from))
+ (or record-exists
+ (y-or-n-p (concat "Create BBDB record from " from "? "))))
+ ;; no confirmation desired so let it be
+ t)
+ nil)
+ nil))
+
+;;;###autoload
+(defun bbdb-ignore-some-messages-hook ()
+ "For use as a `bbdb/news-auto-create-hook' or `bbdb/mail-auto-create-hook'.
+This will automatically create BBDB entries for messages which do *not*
+match the `bbdb-ignore-some-messages-alist' (which see)."
+ (bbdb-ignore-most-messages-hook t))
+
+
+;;; Automatically add to the notes field based on the current message.
+
+(defcustom bbdb-auto-notes-alist nil
+ "*An alist which lets you have certain pieces of text automatically added
+to the BBDB record representing the sender of the current message based on
+the subject or other header fields. This only works if `bbdb-notice-hook'
+contains `bbdb-auto-notes-hook'. The format of this alist is
+
+ ((HEADER-NAME [ADDRESS-CLASS-LIST]
+ (REGEXP . STRING) ... )
+ ... )
+for example,
+ ((\"To\" (\"-vm@\" . \"VM mailing list\"))
+ (\"Subject\" (\"sprocket\" . \"mail about sprockets\")
+ (\"you bonehead\" . \"called me a bonehead\")))
+
+will cause the text \"VM mailing list\" to be added to the notes field of
+the record corresponding to anyone you get mail from via one of the VM
+mailing lists. If, that is, `bbdb/mail-auto-create-p' is set such that the
+record would have been created, or the record already existed.
+
+A ADDRESS-CLASS-LIST is optional and by default actions will be performed only
+for records of authors of a message. However, by giving an list of classes
+specified in `bbdb-get-addresses-headers'. Actions will then only be
+performed if the currently processed email is of a class listed in
+ADDRESS-CLASS-LIST. ADDRESS-CLASS-LIST might also be an alist with elements
+of the form (CLASS . HEADER) which allows actions only when the current
+address matches one of the elemets.
+
+The format of elements of this list may also be
+ (REGEXP FIELD-NAME STRING)
+or
+ (REGEXP FIELD-NAME STRING REPLACE-P)
+instead of
+ (REGEXP . STRING)
+
+meaning add the given string to the named field. The field-name may not
+be name, address, phone, or net (builtin fields) but must be either ``notes,''
+``company,'' or the name of a user-defined note-field.
+ (\"pattern\" . \"string to add\")
+is equivalent to
+ (\"pattern\" notes \"string to add\")
+
+STRING can contain \\& or \\N escapes like in function
+`replace-match'. For example, to automatically add the contents of the
+\"organization\" field of a message to the \"company\" field of a BBDB
+record, you can use this:
+
+ (\"Organization\" (\".*\" company \"\\\\&\"))
+
+\(Note you need two \\ to get a single \\ into a lisp string literal.\)
+
+If STRING is an integer N, the N'th matching subexpression is used, so
+the above example could be written more efficiently as
+
+ (\"Organization\" (\".*\" company 0))
+
+If STRING is neither a string or an integer, it should be a function, which
+will be called with the contents of the field. The result of that function
+call is used as the field value (the returned value must be a string.)
+
+If REPLACE-P is t, the string replaces the old contents instead of
+being appended to it.
+
+If multiple clauses match the message, all of the corresponding strings
+will be added.
+
+This works for news as well. You might want to arrange for this to have
+a different value when in mail as when in news.
+
+See also variables `bbdb-auto-notes-ignore' and `bbdb-auto-notes-ignore-all'."
+ :group 'bbdb-noticing-records
+ :type '(repeat
+ (bbdb-alist-with-header
+ (string :tag "Header name")
+ (repeat (choice
+ (cons :tag "Address Class"
+ (repeat (choice
+ (const authors)
+ (const recipients))))
+ (cons :tag "Value Pair"
+ (regexp :tag "Regexp to match on header value")
+ (string :tag "String for notes if regexp matches"))
+ (list :tag "Replacement list"
+ (regexp :tag "Regexp to match on header value")
+ (choice :tag "Record field"
+ (const notes :tag "Notes")
+ (const company :tag "Company")
+ (symbol :tag "Other"))
+ (choice :tag "Regexp match"
+ (string :tag "Replacement string")
+ (integer :tag "Subexpression match")
+ (function :tag "Callback Function"))
+ (choice :tag "Replace previous contents"
+ (const :tag "No" nil)
+ (const :tag "Yes" t))))))))
+
+(defcustom bbdb-auto-notes-ignore nil
+ "Alist of headers and regexps to ignore in `bbdb-auto-notes-hook'.
+Each element looks like
+
+ (HEADER . REGEXP)
+
+For example,
+
+ (\"Organization\" . \"^Gatewayed from\\\\\|^Source only\")
+
+would exclude the phony `Organization:' headers in GNU mailing-lists
+gatewayed to gnu.* newsgroups. Note that this exclusion applies only
+to a single field, not to the entire message. For that, use the variable
+`bbdb-auto-notes-ignore-all'."
+ :group 'bbdb-noticing-records
+ :type '(repeat (cons
+ (string :tag "Header name")
+ (regexp :tag "Regexp to match on header value"))))
+
+(defcustom bbdb-auto-notes-ignore-all nil
+ "Alist of headers and regexps which cause the entire message to be ignored
+in `bbdb-auto-notes-hook'. Each element looks like
+
+ (HEADER . REGEXP)
+
+For example,
+
+ (\"From\" . \"BLAT\\\\.COM\")
+
+would exclude any notes recording for message coming from BLAT.COM.
+Note that this is different from `bbdb-auto-notes-ignore', which applies
+only to a particular header field, rather than the entire message."
+ :group 'bbdb-noticing-records
+ :type '(repeat (cons
+ (string :tag "Header name")
+ (regexp :tag "Regexp to match on header value"))))
+
+
+;;;###autoload
+(defun bbdb-auto-notes-hook (record)
+ "For use as a `bbdb-notice-hook'. This might automatically add some text
+to the notes field of the BBDB record corresponding to the current record
+based on the header of the current message. See the documentation for
+the variables `bbdb-auto-notes-alist' and `bbdb-auto-notes-ignore'."
+ ;; This could stand to be faster...
+ ;; could optimize this to check the cache, and noop if this record is
+ ;; cached for any other message, but that's probably not the right thing.
+ (unless bbdb-readonly-p
+ (let ((rest bbdb-auto-notes-alist)
+ (ignore-all bbdb-auto-notes-ignore-all)
+ (case-fold-search t)
+ (b (current-buffer))
+ (marker (bbdb-header-start))
+ ignore
+ field pairs fieldval ; do all bindings here for speed
+ regexp string notes-field-name notes
+ replace-p)
+ (set-buffer (marker-buffer marker))
+ (save-restriction
+ (widen)
+ (goto-char marker)
+ (if (and (setq fieldval (bbdb-extract-field-value "From"))
+ (string-match (bbdb-user-mail-names) fieldval))
+ ;; Don't do anything if this message is from us. Note that we have
+ ;; to look at the message instead of the record, because the record
+ ;; will be of the recipient of the message if it is from us.
+ nil
+ ;; check the ignore-all pattern
+ (while (and ignore-all (not ignore))
+ (goto-char marker)
+ (setq field (car (car ignore-all))
+ regexp (cdr (car ignore-all))
+ fieldval (bbdb-extract-field-value field))
+ (if (and fieldval
+ (string-match regexp fieldval))
+ (setq ignore t)
+ (setq ignore-all (cdr ignore-all))))
+
+ (unless ignore ; ignore-all matched
+ (while rest ; while there are still clauses in the auto-notes alist
+ (goto-char marker)
+ (setq field (car (car rest)) ; name of header, e.g., "Subject"
+ pairs (cdr (car rest)) ; (REGEXP . STRING) or
+ ; (REGEXP FIELD-NAME STRING) or
+ ; (REGEXP FIELD-NAME STRING REPLACE-P)
+ fieldval (bbdb-extract-field-value field)) ; e.g., Subject line
+ (when fieldval
+ ;; we perform the auto notes stuff only for authors of a message
+ ;; or if explicitly requested
+ (if (or (symbolp (caar pairs)) (listp (caar pairs)))
+ (if (or (memq bbdb-update-address-class (car pairs))
+ (and (assoc bbdb-update-address-class (car pairs))
+ (string= bbdb-update-address-header
+ (cdr (assoc bbdb-update-address-class
+ (car pairs))))))
+ (setq pairs (cdr pairs))
+ (setq pairs nil))
+ (if (not (and (eq 'authors bbdb-update-address-class)
+ (string-match "From" bbdb-update-address-header)))
+ (setq pairs nil)))
+
+ ;; now handle the remaining pairs
+ (while pairs
+ (setq regexp (car (car pairs))
+ string (cdr (car pairs)))
+ (if (consp string) ; not just the (REGEXP . STRING) format
+ (setq notes-field-name (car string)
+ replace-p (nth 2 string) ; perhaps nil
+ string (nth 1 string))
+ ;; else it's simple (REGEXP . STRING)
+ (setq notes-field-name 'notes
+ replace-p nil))
+ (setq notes (bbdb-record-getprop record notes-field-name))
+ (let ((did-match
+ (and (string-match regexp fieldval)
+ ;; make sure it is not to be ignored
+ (let ((re (cdr (assoc field
+ bbdb-auto-notes-ignore))))
+ (if re
+ (not (string-match re fieldval))
+ t)))))
+ ;; An integer as STRING is an index into match-data:
+ ;; A function as STRING calls the function on fieldval:
+ (if did-match
+ (setq string
+ (cond ((integerp string) ; backward compat
+ (substring fieldval
+ (match-beginning string)
+ (match-end string)))
+ ((stringp string)
+ (bbdb-auto-expand-newtext fieldval string))
+ (t
+ (goto-char marker)
+ (let ((s (funcall string fieldval)))
+ (or (stringp s)
+ (null s)
+ (error "%s returned %s: not a string"
+ string s))
+ s)))))
+ ;; need expanded version of STRING here:
+ (if (and did-match
+ string ; A function as STRING may return nil
+ (not (and notes
+ ;; check that STRING is not already
+ ;; present in the NOTES field
+ (string-match
+ (regexp-quote string)
+ notes))))
+ (if replace-p
+ ;; replace old contents of field with STRING
+ (progn
+ (when (not bbdb-silent-running)
+ (if (eq notes-field-name 'notes)
+ (message "Replacing with note \"%s\"" string)
+ (message "Replacing field \"%s\" with \"%s\""
+ notes-field-name string)))
+ (bbdb-record-putprop record notes-field-name string)
+ (bbdb-maybe-update-display record))
+ ;; add STRING to old contents, don't replace
+ (when (not bbdb-silent-running)
+ (if (eq notes-field-name 'notes)
+ (message "Adding note \"%s\"" string)
+ (message "Adding \"%s\" to field \"%s\""
+ string notes-field-name)))
+ (bbdb-annotate-notes record string notes-field-name))))
+ (setq pairs (cdr pairs))))
+ (setq rest (cdr rest))))))
+ (set-buffer b))))
+
+(defun bbdb-auto-expand-newtext (string newtext)
+ ;; Expand \& and \1..\9 (referring to STRING) in NEWTEXT.
+ ;; Note that in Emacs 18 match data are clipped to current buffer
+ ;; size...so the buffer had better not be smaller than STRING (arrrrggggh!!)
+ (let ((pos 0)
+ (len (length newtext))
+ (expanded-newtext ""))
+ (while (< pos len)
+ (setq expanded-newtext
+ (concat expanded-newtext
+ (let ((c (aref newtext pos)))
+ (if (= ?\\ c)
+ (cond ((= ?\& (setq c (aref newtext
+ (setq pos (1+ pos)))))
+ (substring string
+ (match-beginning 0)
+ (match-end 0)))
+ ((and (>= c ?1)
+ (<= c ?9))
+ ;; return empty string if N'th
+ ;; sub-regexp did not match:
+ (let ((n (- c ?0)))
+ (if (match-beginning n)
+ (substring string
+ (match-beginning n)
+ (match-end n))
+ "")))
+ (t (char-to-string c)))
+ (char-to-string c)))))
+ (setq pos (1+ pos)))
+ expanded-newtext))
+
+
+;;; I use this as the value of bbdb-canonicalize-net-hook; it is provided
+;;; as an example for you to customize.
+
+(defcustom bbdb-canonical-hosts
+ (mapconcat 'regexp-quote
+ '("cs.cmu.edu" "ri.cmu.edu" "edrc.cmu.edu" "andrew.cmu.edu"
+ "mcom.com" "netscape.com" "cenatls.cena.dgac.fr"
+ "cenaath.cena.dgac.fr" "irit.fr" "enseeiht.fr" "inria.fr"
+ "cs.uiuc.edu" "xemacs.org")
+ "\\|")
+ "Certain sites have a single mail-host; for example, all mail originating
+at hosts whose names end in \".cs.cmu.edu\" can (and probably should) be
+addressed to \"user@cs.cmu.edu\" instead. This variable lists other hosts
+which behave the same way."
+ :group 'bbdb
+ :type '(regexp :tag "Regexp matching sites"))
+
+(defmacro bbdb-match-substring (string match)
+ (list 'substring string
+ (list 'match-beginning match) (list 'match-end match)))
+
+;;;###autoload
+(defun sample-bbdb-canonicalize-net-hook (addr)
+ (cond
+ ;;
+ ;; rewrite mail-drop hosts.
+ ;;
+ ((string-match
+ (concat "\\`\\([^@%!]+@\\).*\\.\\(" bbdb-canonical-hosts "\\)\\'")
+ addr)
+ (concat (bbdb-match-substring addr 1) (bbdb-match-substring addr 2)))
+ ;;
+ ;; Here at Lucid, our workstation names sometimes get into our email
+ ;; addresses in the form "jwz%thalidomide@lucid.com" (instead of simply
+ ;; "jwz@lucid.com"). This removes the workstation name.
+ ;;
+ ((string-match "\\`\\([^@%!]+\\)%[^@%!.]+@\\(lucid\\.com\\)\\'" addr)
+ (concat (bbdb-match-substring addr 1) "@" (bbdb-match-substring addr 2)))
+ ;;
+ ;; Another way that our local mailer is misconfigured: sometimes addresses
+ ;; which should look like "user@some.outside.host" end up looking like
+ ;; "user%some.outside.host" or even "user%some.outside.host@lucid.com"
+ ;; instead. This rule rewrites it into the original form.
+ ;;
+ ((string-match "\\`\\([^@%]+\\)%\\([^@%!]+\\)\\(@lucid\\.com\\)?\\'" addr)
+ (concat (bbdb-match-substring addr 1) "@" (bbdb-match-substring addr 2)))
+ ;;
+ ;; Sometimes I see addresses like "foobar.com!user@foobar.com".
+ ;; That's totally redundant, so this rewrites it as "user@foobar.com".
+ ;;
+ ((string-match "\\`\\([^@%!]+\\)!\\([^@%!]+[@%]\\1\\)\\'" addr)
+ (bbdb-match-substring addr 2))
+ ;;
+ ;; Sometimes I see addresses like "foobar.com!user". Turn it around.
+ ;;
+ ((string-match "\\`\\([^@%!.]+\\.[^@%!]+\\)!\\([^@%]+\\)\\'" addr)
+ (concat (bbdb-match-substring addr 2) "@" (bbdb-match-substring addr 1)))
+ ;;
+ ;; The mailer at hplb.hpl.hp.com tends to puke all over addresses which
+ ;; pass through mailing lists which are maintained there: it turns normal
+ ;; addresses like "user@foo.com" into "user%foo.com@hplb.hpl.hp.com".
+ ;; This reverses it. (I actually could have combined this rule with
+ ;; the similar lucid.com rule above, but then the regexp would have been
+ ;; more than 80 characters long...)
+ ;;
+ ((string-match "\\`\\([^@!]+\\)%\\([^@%!]+\\)@hplb\\.hpl\\.hp\\.com\\'"
+ addr)
+ (concat (bbdb-match-substring addr 1) "@" (bbdb-match-substring addr 2)))
+ ;;
+ ;; Another local mail-configuration botch: sometimes mail shows up
+ ;; with addresses like "user@workstation", where "workstation" is a
+ ;; local machine name. That should really be "user" or "user@netscape.com".
+ ;; (I'm told this one is due to a bug in SunOS 4.1.1 sendmail.)
+ ;;
+ ((string-match "\\`\\([^@%!]+\\)[@%][^@%!.]+\\'" addr)
+ (bbdb-match-substring addr 1))
+ ;;
+ ;; Sometimes I see addrs like "foo%somewhere%uunet.uu.net@somewhere.else".
+ ;; This is silly, because I know that I can send mail to uunet directly.
+ ;;
+ ((string-match ".%uunet\\.uu\\.net@[^@%!]+\\'" addr)
+ (concat (substring addr 0 (+ (match-beginning 0) 1)) "@UUNET.UU.NET"))
+ ;;
+ ;; Otherwise, leave it as it is. Returning a string EQ to the one passed
+ ;; in tells BBDB that we're done.
+ ;;
+ (t addr)))
+
+
+;;; Here's another approach; sometimes one gets mail from foo@bar.baz.com,
+;;; and then later gets mail from foo@baz.com. At this point, one would
+;;; like to delete the bar.baz.com address, since the baz.com address is
+;;; obviously superior. See also var `bbdb-canonicalize-redundant-nets-p'.
+;;;
+;;; Turn this on with
+;;; (add-hook 'bbdb-change-hook 'bbdb-delete-redundant-nets)
+
+(defun bbdb-delete-redundant-nets (record)
+ "Deletes redundant network addresses.
+For use as a value of `bbdb-change-hook'. See `bbdb-net-redundant-p'."
+ (let* ((nets (bbdb-record-net record))
+ (rest nets)
+ net new redundant)
+ (while rest
+ (setq net (car rest))
+ (if (bbdb-net-redundant-p net nets)
+ (setq redundant (cons net redundant))
+ (setq new (cons net new)))
+ (setq rest (cdr rest)))
+ (cond (redundant
+ (message "Deleting redundant nets %s..."
+ (mapconcat 'identity (nreverse redundant) ", "))
+ (setq new (nreverse new))
+ (bbdb-record-set-net record new)
+ t))))
+
+
+
+;;;###autoload
+(defun bbdb-force-record-create ()
+ "Force automatic creation of a BBDB records for the current message.
+You might add this to the reply hook of your MUA in order to automatically
+get records added for those people you reply to."
+ (interactive)
+ (let ((bbdb/mail-auto-create-p t)
+ (bbdb/news-auto-create-p t)
+ (bbdb-message-caching-enabled nil)
+ (bbdb/gnus-update-records-mode 'annotating)
+ (bbdb/rmail-update-records-mode 'annotating)
+ (bbdb/mhe-update-records-mode 'annotating)
+ (bbdb/vm-update-records-mode 'annotating))
+ (save-excursion
+ (cond ((member major-mode '(vm-mode vm-virtual-mode vm-summary-mode
+ vm-presentation-mode))
+ (bbdb/vm-pop-up-bbdb-buffer))
+ ((member major-mode '(gnus-summary-mode gnus-article-mode
+ gnus-tree-mode))
+ (bbdb/gnus-pop-up-bbdb-buffer))
+ ((member major-mode '(rmail-mode rmail-summary-mode))
+ (bbdb/rmail-pop-up-bbdb-buffer))
+ ((member major-mode '(mhe-mode mhe-summary-mode mh-folder-mode))
+ (bbdb/mh-pop-up-bbdb-buffer))
+ ))))
+
+(provide 'bbdb-hooks)
diff --git a/lisp/bbdb-merge.el b/lisp/bbdb-merge.el
new file mode 100644
index 0000000..ac90ae5
--- /dev/null
+++ b/lisp/bbdb-merge.el
@@ -0,0 +1,264 @@
+;;; BBDB merge/sync framework
+;;; GNU Public License to go here. This file is under GPL, thanks guys.
+;;; Copyright (c) 2000 Waider
+
+(require 'bbdb)
+(require 'bbdb-com)
+
+;;; to do:
+;;; smarter phone, notes and address merging.
+
+;;;###autoload
+(defun bbdb-merge-record (new-record &optional merge-record override)
+ "Generic merge function.
+
+Merges new-record into your bbdb, using DATE to check who's more
+up-to-date and OVERRIDE to decide who gets precedence if two dates
+match. DATE can be extracted from a notes if it's an alist with an
+element marked timestamp. Set OVERRIDE to 'new to allow the new record
+to stomp on existing data, 'old to preserve existing data or nil to
+merge both together. If it can't find a record to merge with, it will
+create a new record. If MERGE-RECORD is set, it's a record discovered
+by other means that should be merged with.
+
+Returns the Grand Unified Record."
+
+ (let* ((firstname (bbdb-record-firstname new-record))
+ (lastname (bbdb-record-lastname new-record))
+ (aka (bbdb-record-aka new-record))
+ (nets (bbdb-record-net new-record))
+ (addrs (bbdb-record-addresses new-record))
+ (phones (bbdb-record-phones new-record))
+ (company (bbdb-record-company new-record))
+ (notes (bbdb-record-raw-notes new-record))
+ (name (bbdb-string-trim (concat firstname " " lastname)))
+ (date (if (listp notes) (cdr (assq 'timestamp notes)) nil))
+ olddate)
+
+ ;; for convenience
+ (if (stringp notes)
+ (setq notes (list (cons 'notes notes))))
+
+ ;; See if we have a record that looks right, using an intertwingle
+ ;; search. Could probably parameterize that.
+ ;; bbdb-merge-search-function or some such.
+ (if (null merge-record)
+ (setq merge-record (bbdb-search-simple name nets)))
+
+ (if merge-record
+ (progn
+ ;; if date is unset, set it to the existing record's date.
+ (setq olddate (bbdb-record-getprop merge-record 'timestamp)
+ date (or date olddate))
+ ;; FIXME if date & olddate are STILL unset, set to today's date.
+
+ ;; if the old record is actually newer, invert the sense of override
+ (if (string-lessp olddate date)
+ (setq override (cond ((eq 'old override) 'new)
+ ((eq 'new override) 'old)
+ (t nil))))
+
+ (bbdb-record-set-firstname merge-record
+ (if (null override)
+ (bbdb-merge-strings (bbdb-record-firstname merge-record)
+ firstname " ")
+ (if (eq 'new override) firstname
+ (bbdb-record-firstname merge-record))))
+
+ (bbdb-record-set-lastname merge-record
+ (if (null override)
+ (bbdb-merge-strings (bbdb-record-lastname merge-record)
+ lastname " ")
+ (if (eq 'new override) lastname
+ (bbdb-record-lastname merge-record))))
+
+ (bbdb-record-set-company merge-record
+ (if (null override)
+ (bbdb-merge-strings (bbdb-record-company merge-record)
+ company " ")
+ (if (eq 'new override) company
+ (bbdb-record-company merge-record))))
+
+ (bbdb-record-set-aka
+ merge-record
+ (if (null override)
+ (bbdb-merge-lists!
+ (bbdb-record-aka merge-record)
+ (if (listp aka) aka (list aka)) 'string= 'downcase)
+ (if (eq 'new override) aka
+ (bbdb-record-aka merge-record))))
+
+ (bbdb-record-set-net
+ merge-record
+ (if (null override)
+ (bbdb-merge-lists!
+ (bbdb-record-net merge-record) nets 'string= 'downcase)
+ (if (eq 'new override) nets
+ (bbdb-record-net merge-record))))
+
+ (bbdb-record-set-phones
+ merge-record
+ (if (null override)
+ (bbdb-merge-lists!
+ (bbdb-record-phones merge-record) phones 'equal)
+ (if (eq 'new override) phones
+ (bbdb-record-phones merge-record))))
+
+ (bbdb-record-set-addresses
+ merge-record
+ (if (null override)
+ (bbdb-merge-lists!
+ (bbdb-record-addresses merge-record) addrs 'equal)
+ (if (eq 'new override) addrs
+ (bbdb-record-addresses merge-record))))
+
+ ;; lifted from bbdb-com.el
+ (let ((n1 (bbdb-record-raw-notes merge-record))
+ (n2 notes)
+ tmp
+ (bbdb-refile-notes-default-merge-function ;; XXX
+ 'bbdb-merge-strings))
+ (or (equal n1 n2)
+ (progn
+ (or (listp n1) (setq n1 (list (cons 'notes n1))))
+ (or (listp n2) (setq n2 (list (cons 'notes n2))))
+ (while n2
+ (if (setq tmp (assq (car (car n2)) n1))
+ (setcdr tmp
+ (funcall (or (cdr (assq (car (car n2))
+ bbdb-refile-notes-generate-alist))
+ bbdb-refile-notes-default-merge-function)
+ (cdr tmp) (cdr (car n2))))
+ (setq n1 (nconc n1 (list (car n2)))))
+ (setq n2 (cdr n2)))
+ (bbdb-record-set-raw-notes merge-record n1)))))
+
+ ;; we couldn't find a record, so create one
+ (setq merge-record
+ (bbdb-create-internal name company nets addrs phones notes))
+ ;; bite me, bbdb-create-internal
+ (bbdb-record-set-firstname merge-record firstname)
+ (bbdb-record-set-lastname merge-record lastname))
+
+ ;; more general bitingness
+ (if (equal (bbdb-record-firstname merge-record) "")
+ (bbdb-record-set-firstname merge-record nil))
+ (if (equal (bbdb-record-lastname merge-record) "")
+ (bbdb-record-set-lastname merge-record nil))
+
+ ;; fix up the in-memory copy.
+ (bbdb-change-record merge-record t)
+ (let ((name (bbdb-record-name merge-record))
+ (lfname (bbdb-record-lastname merge-record))
+ (company (bbdb-record-company merge-record)))
+ (if (> (length name) 0)
+ (bbdb-remhash (downcase name) merge-record))
+ (if (> (length lfname) 0)
+ (bbdb-remhash (downcase lfname) merge-record))
+ (if (> (length company) 0)
+ (bbdb-remhash (downcase company) merge-record)))
+ (bbdb-record-set-namecache merge-record nil)
+ (if (or (bbdb-record-lastname merge-record)
+ (bbdb-record-firstname merge-record))
+ (bbdb-puthash (downcase (bbdb-record-name merge-record)) merge-record))
+ (if (bbdb-record-company merge-record)
+ (bbdb-puthash (downcase (bbdb-record-company merge-record))
+ merge-record))
+ (bbdb-with-db-buffer
+ (if (not (memq merge-record bbdb-changed-records))
+ (setq bbdb-changed-records
+ (cons merge-record bbdb-changed-records))))
+
+ ;; your record, sir.
+ merge-record))
+
+;; fixme these could be a macros, I guess.
+(defun bbdb-instring( s1 s2 )
+;; (and case-fold-search
+;; (setq s1 (downcase s1)
+;; s2 (downcase s2)))
+ (catch 'done
+ (while (>= (length s1) (length s2))
+ (if (string= s2 (substring s1 0 (length s2)))
+ (throw 'done t)
+ (setq s1 (substring s1 1))))
+ (throw 'done nil)))
+
+(defun bbdb-merge-strings (s1 s2 &optional sep)
+ "Merge two strings together uniquely.
+If s1 doesn't contain s2, return s1+sep+s2."
+ (cond ((or (null s1) (string-equal s1 "")) s2)
+ ((or (null s2) (string-equal s2 "")) s1)
+ (t (if (bbdb-instring s2 s1) s1
+ (concat s1 (or sep "") s2)))))
+
+;;;###autoload
+(defun bbdb-merge-file (&optional bbdb-new override match-fun)
+ "Merge a bbdb file into the in-core bbdb."
+ (interactive "fMerge bbdb file: ")
+ (or bbdb-gag-messages
+ bbdb-silent-running
+ (message "Merging %s" bbdb-new))
+ ;; argh urgle private environment
+ (let* ((bbdb-live-file bbdb-file)
+ (bbdb-file bbdb-new)
+ (bbdb-live-buffer-name bbdb-buffer-name)
+ (bbdb-buffer-name "*BBDB-merge*")
+ (bbdb-buffer nil) ;; hack hack
+ (new-records (bbdb-records))
+ (bbdb-buffer nil) ;; hack hack
+ (bbdb-file bbdb-live-file)
+ (bbdb-buffer-name bbdb-live-buffer-name)
+ (bbdb-refile-notes-default-merge-function 'bbdb-merge-strings))
+
+ ;; merge everything
+ (mapc (lambda(rec)
+ (bbdb-merge-record rec
+ (and match-fun
+ (funcall match-fun rec))
+ override))
+ new-records))
+ ;; hack
+ (setq bbdb-buffer (or (get-file-buffer bbdb-file) nil)))
+
+(defun bbdb-add-or-update-phone ( record location phone-string )
+ "Add or update a phone number in the current record.
+
+Insert into RECORD phone number for LOCATION consisting of
+PHONE-STRING. Will automatically overwrite an existing phone entry for
+the same location."
+ (let* ((phone (make-vector (if bbdb-north-american-phone-numbers-p
+ bbdb-phone-length
+ 2)
+ nil)))
+ (if (= 2 (length phone))
+ (aset phone 1 phone-string)
+ (let ((newp (bbdb-parse-phone-number phone-string)))
+ (bbdb-phone-set-area phone (nth 0 newp))
+ (bbdb-phone-set-exchange phone (nth 1 newp))
+ (bbdb-phone-set-suffix phone (nth 2 newp))
+ (bbdb-phone-set-extension phone (or (nth 3 newp) 0))))
+ (bbdb-phone-set-location phone location)
+
+ ;; "phone" now contains a suitable record
+ ;; we need to check if this is already in the phones list
+ (let ((phones (bbdb-record-phones record))
+ phones-list)
+ (setq phones-list phones)
+ (while (car phones-list)
+ (if (string= (bbdb-phone-location (car phones-list))
+ location)
+ (setq phones (delete (car phones-list) phones)))
+ (setq phones-list (cdr phones-list)))
+
+
+ (bbdb-record-set-phones record
+ (nconc phones (list phone))))
+ (bbdb-change-record record nil)
+
+ ;; update display if record is visible
+ (and (get-buffer-window bbdb-buffer-name)
+ (bbdb-display-records (list record)))
+ nil))
+
+(provide 'bbdb-merge)
diff --git a/lisp/bbdb-mhe.el b/lisp/bbdb-mhe.el
new file mode 100644
index 0000000..717ae95
--- /dev/null
+++ b/lisp/bbdb-mhe.el
@@ -0,0 +1,225 @@
+;;; -*- Mode:Emacs-Lisp -*-
+
+;;; This file is part of the Insidious Big Brother Database (aka BBDB),
+;;; copyright (c) 1991 Todd Kaufmann <toad@cs.cmu.edu>
+;;; Interface to mh-e version 3.7 or later (modeled after bbdb-rmail).
+;;; Created 5-Mar-91;
+;;; Modified: 28-Jul-94 by Fritz Knabe <knabe@ecrc.de>
+;;; Jack Repenning <jackr@dblues.wpd.sgi.com>
+
+;;; 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
+;;; details.
+;;;
+;;; 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.
+
+(eval-and-compile
+ (require 'bbdb)
+ (require 'bbdb-com)
+ (require 'mail-utils)
+ ;; We advise several mh-e functions
+ (require 'mh-e)
+ (if (fboundp 'mh-version)
+ (require 'mh-comp)) ; For mh-e 4.x
+ (require 'advice))
+
+(defmacro bbdb/mh-cache-key (message)
+ "Return a (numeric) key for MESSAGE"
+ (`(let* ((attrs (file-attributes (, message)))
+ (status-time (nth 6 attrs))
+ (status-time-2 (cdr status-time))
+ (inode (nth 10 attrs)))
+ (logxor (if (integerp inode) ;; if inode is larger than an emacs int,
+ inode ;; it's returned as a dotted pair
+ (car inode))
+ (car status-time)
+ ;; We need the following test because XEmacs returns the
+ ;; status time as a dotted pair, whereas FSF and Epoch
+ ;; return it as list.
+ (if (integerp status-time-2)
+ status-time-2
+ (car status-time-2))))))
+
+;;;###autoload
+(defun bbdb/mh-update-record (&optional offer-to-create)
+ "Returns the record corresponding to the current MH message, creating or
+modifying it 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."
+ (save-excursion
+ (and mh-show-buffer (set-buffer mh-show-buffer))
+ (if bbdb-use-pop-up
+ (bbdb/mh-pop-up-bbdb-buffer offer-to-create)
+ (let ((msg (bbdb/mh-cache-key buffer-file-name))
+ records record)
+ (if (eq msg 0) (setq msg nil)) ; 0 could mean trouble; be safe.
+ (setq records (bbdb-message-cache-lookup msg))
+ (if records
+ (car records)
+ (let ((from (bbdb/mh-get-field "^From[ \t]*:")))
+ (if (or (string= "" from)
+ (string-match (bbdb-user-mail-names)
+ (mail-strip-quoted-names from)))
+ ;; if logged-in user sent this, use recipients.
+ (progn
+ (setq from (bbdb/mh-get-field "^To[ \t]*:"))
+ (if (or (string= "" from)
+ (string-match (bbdb-user-mail-names)
+ (mail-strip-quoted-names from)))
+ (setq from nil))))
+ (if from
+ (setq record
+ (bbdb-annotate-message-sender
+ from t
+ (or (bbdb-invoke-hook-for-value bbdb/mail-auto-create-p)
+ offer-to-create)
+ ;; ugh. what the hell?
+ (or offer-to-create
+ (bbdb-invoke-hook-for-value bbdb/mail-auto-create-p)))))
+ (if (and msg record) (bbdb-encache-message msg (list record)))
+ ;; return one record
+ record))))))
+
+;;;###autoload
+(defun bbdb/mh-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)."
+ (interactive (list (if bbdb-readonly-p
+ (error "The Insidious Big Brother Database is read-only.")
+ (read-string "Comments: "))))
+ (mh-show)
+ (let ((b (current-buffer))
+ (p (point)))
+ (set-buffer mh-show-buffer)
+ (bbdb-annotate-notes (bbdb/mh-update-record t) string 'notes replace)
+ (set-buffer b)
+ (goto-char p)))
+
+
+(defun bbdb/mh-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."
+ (interactive "P")
+ (mh-show)
+ (let ((b (current-buffer))
+ (p (point)))
+ (set-buffer mh-show-buffer)
+ (let (bbdb-electric-p (record (or (bbdb/mh-update-record t) (error ""))))
+ (bbdb-display-records (list record))
+ (if arg
+ (bbdb-record-edit-property record nil t)
+ (bbdb-record-edit-notes record t)))
+ (set-buffer b)
+ (goto-char p)))
+
+
+;;;###autoload
+(defun bbdb/mh-show-sender ()
+ "Display the contents of the BBDB for the sender of this message.
+This buffer will be in bbdb-mode, with associated keybindings."
+ (interactive)
+ (mh-show)
+ (let ((b (current-buffer))
+ (p (point)))
+ (set-buffer mh-show-buffer)
+ (let ((record (bbdb/mh-update-record t)))
+ (if record
+ (bbdb-display-records (list record))
+ (error "unperson")))
+ (set-buffer b)
+ (goto-char p)))
+
+
+(defun bbdb/mh-pop-up-bbdb-buffer (&optional offer-to-create)
+ "Make the *BBDB* buffer be displayed along with the MH window,
+displaying the record corresponding to the sender of the current message."
+ (bbdb-pop-up-bbdb-buffer
+ (function (lambda (w)
+ (let ((b (current-buffer)))
+ (set-buffer (window-buffer w))
+ (prog1 (eq major-mode 'mh-show-mode)
+ (set-buffer b))))))
+ (let ((bbdb-gag-messages t)
+ (bbdb-use-pop-up nil)
+ (bbdb-electric-p nil))
+ (let ((record (bbdb/mh-update-record offer-to-create)))
+ (bbdb-display-records (if record (list record) nil)
+ bbdb-pop-up-display-layout)
+ record)))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; this is a more strict version of mh-get-field which takes an regexp
+
+(defun bbdb/mh-get-field (field)
+ ;; Find and return the value of field FIELD (regexp) in the current buffer.
+ ;; Returns the empty string if the field is not in the message.
+ (let ((case-fold-search nil))
+ (goto-char (point-min))
+ (cond ((not (re-search-forward field nil t)) "")
+ ((looking-at "[\t ]*$") "")
+ (t (re-search-forward "[\t ]*\\([^\t \n].*\\)$" nil t)
+ (let ((field (buffer-substring (match-beginning 1) (match-end 1)))
+ (end-of-match (point)))
+ (forward-line)
+ (while (looking-at "[ \t]") (forward-line 1))
+ (backward-char 1)
+ (if (<= (point) end-of-match)
+ field
+ (format "%s%s" field
+ (buffer-substring end-of-match (point)))))))))
+
+(defadvice mh-process-commands (after mh-bbdb-process act)
+ (bbdb-offer-save))
+
+(defadvice mh-send (before mh-bbdb-send act)
+ (interactive (list
+ (bbdb-read-addresses-with-completion "To: ")
+ (bbdb-read-addresses-with-completion "Cc: ")
+ (read-string "Subject: "))))
+
+(defadvice mh-send-other-window (before mh-bbdb-send-other act)
+ (interactive (list
+ (bbdb-read-addresses-with-completion "To: ")
+ (bbdb-read-addresses-with-completion "Cc: ")
+ (read-string "Subject: "))))
+
+(defadvice mh-forward (before mh-bbdb-forward act)
+ (interactive (list (bbdb-read-addresses-with-completion "To: ")
+ (bbdb-read-addresses-with-completion "Cc: ")
+ (if current-prefix-arg
+ (mh-read-seq-default "Forward" t)
+ (mh-get-msg-num t)))))
+
+(defadvice mh-redistribute (before mh-bbdb-redist act)
+ (interactive (list
+ (bbdb-read-addresses-with-completion "Redist-To: ")
+ (bbdb-read-addresses-with-completion "Redist-Cc: ")
+ (mh-get-msg-num t))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; mail from bbdb-mode using mh
+
+;; these redefine the bbdb-send-mail functions to use mh-send.
+
+;;; Install bbdb into mh-e's show-message function
+
+;;;###autoload
+(defun bbdb-insinuate-mh ()
+ "Call this function to hook BBDB into MH-E."
+ (define-key mh-folder-mode-map ":" 'bbdb/mh-show-sender)
+ (define-key mh-folder-mode-map ";" 'bbdb/mh-edit-notes)
+ (define-key mh-letter-mode-map "\M-;" 'bbdb-complete-name)
+ (add-hook 'mh-show-hook 'bbdb/mh-update-record)
+ (define-key mh-letter-mode-map "\e\t" 'bbdb-complete-name))
+
+(provide 'bbdb-mhe)
diff --git a/lisp/bbdb-migrate.el b/lisp/bbdb-migrate.el
new file mode 100644
index 0000000..92c2504
--- /dev/null
+++ b/lisp/bbdb-migrate.el
@@ -0,0 +1,413 @@
+;;; -*- Mode:Emacs-Lisp -*-
+
+;;; This file contains the migration functions for the Insidious Big
+;;; Brother Database (aka BBDB), copyright (c) 1991, 1992, 1993, 1994
+;;; Jamie Zawinski <jwz@netscape.com>. See the file bbdb.texinfo for
+;;; documentation.
+;;;
+;;; 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 2, 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
+;;; details.
+;;;
+;;; 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.
+;;;
+
+(require 'bbdb)
+
+;;; Migrating the BBDB
+
+;; Features that have changed in the various database revs. Format:
+;; ((VERSION . DIFFERENCES) ... )
+(defconst bbdb-migration-features
+ '((3 . "* Date format for `creation-date' and `timestamp' has changed,
+ from \"dd mmm yy\" (ex: 25 Sep 97) to \"yyyy-mm-dd\" (ex: 1997-09-25).")
+ (4 . "* Country field added.")
+ (5 . "* More flexible street address.")
+ (6 . "* Zip codes are stored as plain strings.")))
+
+;;;###autoload
+(defun bbdb-migration-query (ondisk)
+ "Ask if the database is to be migrated.
+ONDISK is the version number of the database as currently stored on
+disk. Returns the version for the saved database."
+ (save-excursion
+ (let ((wc (current-window-configuration))
+ (buf (get-buffer-create "*BBDB Migration Info*"))
+ (newfeatures bbdb-migration-features)
+ (first t)
+ win update)
+ (set-buffer buf)
+ (erase-buffer)
+ (goto-char (point-min))
+ (insert (format "BBDB new data version notice:
+=============================
+
+Your BBDB data is stored in an older format (version %d). At this point,
+you have the option of either upgrading or continuing to save your data
+in your current format. Please note that if you elect the latter option,
+any changes made to your data using features intended for the newer
+versions will be lost. For your convenience, a list of file format
+changes introduced after version %d is shown below:\n\n" ondisk ondisk))
+ (while newfeatures
+ (if (> (caar newfeatures) ondisk)
+ (insert (concat (if first (setq first nil) "\n\n")
+ "New features in database version "
+ (format "%d" (caar newfeatures))
+ ":\n\n" (cdar newfeatures))))
+ (setq newfeatures (cdr newfeatures)))
+ (setq win (display-buffer buf))
+ (shrink-window-if-larger-than-buffer win)
+ (setq update
+ (y-or-n-p (concat "Upgrade BBDB to version "
+ (format "%d" bbdb-file-format)
+ "? ")))
+ (condition-case nil
+ (delete-window win)
+ ;; The window might be the only one on its frame. Hopefully, it's
+ ;; a dedicated window and the kill-buffer below will DTRT.
+ (error nil))
+ (kill-buffer buf)
+ (set-window-configuration wc)
+ (if update bbdb-file-format ondisk))))
+
+;;;###autoload
+(defun bbdb-migrate (records)
+ "Migrate the BBDB from the version on disk (the car of
+`bbdb-file-format-migration') to the current version (in
+`bbdb-file-format')."
+ (bbdb-mapc (bbdb-migrate-versions-lambda (car bbdb-file-format-migration))
+ records)
+ records)
+
+;;;###autoload
+(defun bbdb-unmigrate-record (record)
+ "Reverse-migrate a single record from the current version (in
+`bbdb-file-format') to the version to be saved (the cdr of
+`bbdb-file-format-migration')."
+ (funcall (bbdb-migrate-versions-lambda bbdb-file-format
+ (car bbdb-file-format-migration))
+ record)
+ record)
+
+(defconst bbdb-migration-spec
+ '((2 (bbdb-record-raw-notes bbdb-record-set-raw-notes
+ bbdb-migrate-change-dates))
+ (3 (bbdb-record-addresses bbdb-record-set-addresses
+ bbdb-migrate-add-country-field))
+ (4 (bbdb-record-addresses bbdb-record-set-addresses
+ bbdb-migrate-streets-to-list))
+ (5 (bbdb-record-addresses bbdb-record-set-addresses
+ bbdb-migrate-zip-codes-to-strings)))
+ "The alist of (version . migration-spec-list).
+See `bbdb-migrate-record-lambda' for details.")
+
+(defconst bbdb-unmigration-spec
+ '((2 (bbdb-record-raw-notes bbdb-record-set-raw-notes
+ bbdb-unmigrate-change-dates))
+ (3 (bbdb-record-addresses bbdb-record-set-addresses
+ bbdb-unmigrate-add-country-field))
+ (4 (bbdb-record-addresses bbdb-record-set-addresses
+ bbdb-unmigrate-streets-to-list))
+ (5 (bbdb-record-addresses bbdb-record-set-addresses
+ bbdb-unmigrate-zip-codes-to-strings)))
+ "The alist of (version . migration-spec-list).
+See `bbdb-migrate-record-lambda' for details.")
+
+(defun bbdb-migrate-record-lambda (changes)
+ "Return a function which will migrate a single record.
+CHANGES is a `migration-spec-list' containing entries of the form
+
+ (GET SET FUNCTION)
+
+where GET is the function to be used to retrieve the field to be
+modified, and SET is the function to be used to set the field to be
+modified. FUNCTION will be applied to the result of GET, and its
+results will be saved with SET."
+ (byte-compile `(lambda (rec)
+ ,@(mapcar (lambda (ch)
+ `(,(cadr ch) rec
+ (,(car (cddr ch))
+ (,(car ch) rec))))
+ changes)
+ rec)))
+
+(defun bbdb-migrate-versions-lambda (v0 &optional v1)
+ "Return the function to migrate from V0 to V1.
+V1 defaults to `bbdb-file-format'."
+ (setq v1 (or v1 bbdb-file-format))
+ (let ((vv v0) spec)
+ (while (/= vv v1)
+ (setq spec (append spec (cdr (assoc vv bbdb-migration-spec)))
+ vv (if (< v0 v1) (1+ vv) (1- vv))))
+ (bbdb-migrate-record-lambda spec)))
+
+(defun bbdb-migrate-zip-codes-to-strings (addrs)
+ "Make all zip codes plain strings.
+This uses the code that used to be in bbdb-address-zip-string."
+ ;; apply the function to all addresses in the list and return a
+ ;; modified list of addresses
+ (mapcar (lambda (addr)
+ (let ((zip (if (stringp (bbdb-address-zip addr))
+ (bbdb-address-zip addr)
+ ;; if not a string, make it a string...
+ (if (consp (bbdb-address-zip addr))
+ ;; if a cons cell with two strings
+ (if (and (stringp (car (bbdb-address-zip addr)))
+ (stringp (car (cdr (bbdb-address-zip addr)))))
+ ;; if the second string starts with 4 digits
+ (if (string-match "^[0-9][0-9][0-9][0-9]"
+ (car (cdr (bbdb-address-zip addr))))
+ (concat (car (bbdb-address-zip addr))
+ "-"
+ (car (cdr (bbdb-address-zip addr))))
+ ;; if ("abc" "efg")
+ (concat (car (bbdb-address-zip addr))
+ " "
+ (car (cdr (bbdb-address-zip addr)))))
+ ;; if ("SE" (123 45))
+ (if (and (stringp (nth 0 (bbdb-address-zip addr)))
+ (consp (nth 1 (bbdb-address-zip addr)))
+ (integerp (nth 0 (nth 1 (bbdb-address-zip addr))))
+ (integerp (nth 1 (nth 1 (bbdb-address-zip addr)))))
+ (format "%s-%d %d"
+ (nth 0 (bbdb-address-zip addr))
+ (nth 0 (nth 1 (bbdb-address-zip addr)))
+ (nth 1 (nth 1 (bbdb-address-zip addr))))
+ ;; if a cons cell with two numbers
+ (if (and (integerp (car (bbdb-address-zip addr)))
+ (integerp (car (cdr (bbdb-address-zip addr)))))
+ (format "%05d-%04d" (car (bbdb-address-zip addr))
+ (car (cdr (bbdb-address-zip addr))))
+ ;; else a cons cell with a string an a number (possible error
+ ;; if a cons cell with a number and a string -- note the
+ ;; order!)
+ (format "%s-%d" (car (bbdb-address-zip addr))
+ (car (cdr (bbdb-address-zip addr)))))))
+ ;; if nil or zero
+ (if (or (eq 0 (bbdb-address-zip addr))
+ (null (bbdb-address-zip addr)))
+ ""
+ ;; else a number, could be 3 to 5 digits (possible error: assuming
+ ;; no leading zeroes in zip codes)
+ (format "%d" (bbdb-address-zip addr)))))))
+ (bbdb-address-set-zip addr zip))
+ addr)
+ addrs))
+
+(defun bbdb-unmigrate-zip-codes-to-strings (addrs)
+ "Make zip code string into zip code datastructures.
+This uses the code that used to be in bbdb-parse-zip-string."
+ ;; apply the function to all addresses in the list and return a
+ ;; modified list of addresses
+ (mapcar (lambda (addr)
+ (let* ((string (bbdb-address-zip addr))
+ (zip (cond ((string-match "^[ \t\n]*$" string) 0)
+ ;; Matches 1 to 6 digits.
+ ((string-match "^[ \t\n]*[0-9][0-9]?[0-9]?[0-9]?[0-9]?[0-9]?[ \t\n]*$" string)
+ (string-to-number string))
+ ;; Matches 5 digits and 3 or 4 digits.
+ ((string-match "^[ \t\n]*\\([0-9][0-9][0-9][0-9][0-9]\\)[ \t\n]*-?[ \t\n]*\\([0-9][0-9][0-9][0-9]?\\)[ \t\n]*$" string)
+ (list (bbdb-subint string 1) (bbdb-subint string 2)))
+ ;; Match zip codes for Canada, UK, etc. (result is ("LL47" "U4B")).
+ ((string-match
+ "^[ \t\n]*\\([A-Za-z0-9]+\\)[ \t\n]+\\([A-Za-z0-9]+\\)[ \t\n]*$"
+ string)
+ (list (substring string (match-beginning 1) (match-end 1))
+ (substring string (match-beginning 2) (match-end 2))))
+ ;; Match zip codes for continental Europe. Examples "CH-8057"
+ ;; or "F - 83320" (result is ("CH" "8057") or ("F" "83320")).
+ ;; Support for "NL-2300RA" added at request from Carsten Dominik
+ ;; <dominik@astro.uva.nl>
+ ((string-match
+ "^[ \t\n]*\\([A-Z]+\\)[ \t\n]*-?[ \t\n]*\\([0-9]+ ?[A-Z]*\\)[ \t\n]*$" string)
+ (list (substring string (match-beginning 1) (match-end 1))
+ (substring string (match-beginning 2) (match-end 2))))
+ ;; Match zip codes from Sweden where the five digits are grouped 3+2
+ ;; at the request from Mats Lofdahl <MLofdahl@solar.stanford.edu>.
+ ;; (result is ("SE" (133 36)))
+ ((string-match
+ "^[ \t\n]*\\([A-Z]+\\)[ \t\n]*-?[ \t\n]*\\([0-9]+\\)[ \t\n]+\\([0-9]+\\)[ \t\n]*$" string)
+ (list (substring string (match-beginning 1) (match-end 1))
+ (list (bbdb-subint string 2)
+ (bbdb-subint string 3)))))))
+ (bbdb-address-set-zip addr zip)
+ addr))
+ addrs))
+
+(defun bbdb-migrate-change-dates (rec)
+ "Change date formats.
+Formats are changed in timestamp and creation-date fields from
+\"dd mmm yy\" to \"yyyy-mm-dd\". Assumes the notes are passed in as an
+argument."
+ (unless (stringp rec)
+ (bbdb-mapc (lambda (rr)
+ (when (memq (car rr) '(creation-date timestamp))
+ (bbdb-migrate-change-dates-change-field rr)))
+ rec)
+ rec))
+
+(defun bbdb-migrate-change-dates-change-field (field)
+ "Migrate the date field (the cdr of FIELD) from \"dd mmm yy\" to
+\"yyyy-mm-dd\"."
+ (let ((date (cdr field))
+ parsed)
+ ;; Verify and extract - this is fairly hideous
+ (and (equal (setq parsed (timezone-parse-date (concat date " 00:00:00")))
+ ["0" "0" "0" "0" nil])
+ (equal (setq parsed (timezone-parse-date date))
+ ["0" "0" "0" "0" nil])
+ (cond ((string-match
+ "^\\([0-9]\\{4\\}\\)[-/]\\([ 0-9]?[0-9]\\)[-/]\\([ 0-9]?[0-9]\\)" date)
+ (setq parsed (vector (string-to-number (match-string 1 date))
+ (string-to-number (match-string 2 date))
+ (string-to-number (match-string 3 date))))
+ ;; This should be fairly loud for GNU Emacs users
+ (bbdb-warn "BBDB is treating %s field value %s as %s %d %d"
+ (car field) (cdr field)
+ (upcase-initials
+ (downcase (car (rassoc (aref parsed 1)
+ timezone-months-assoc))))
+ (aref parsed 2) (aref parsed 0)))
+ ((string-match
+ "^\\([ 0-9]?[0-9]\\)[-/]\\([ 0-9]?[0-9]\\)[-/]\\([0-9]\\{4\\}\\)" date)
+ (setq parsed (vector (string-to-number (match-string 3 date))
+ (string-to-number (match-string 1 date))
+ (string-to-number (match-string 2 date))))
+ ;; This should be fairly loud for GNU Emacs users
+ (bbdb-warn "BBDB is treating %s field value %s as %s %d %d"
+ (car field) (cdr field)
+ (upcase-initials
+ (downcase (car (rassoc (aref parsed 1)
+ timezone-months-assoc))))
+ (aref parsed 2) (aref parsed 0)))
+ (t ["0" "0" "0" "0" nil])))
+
+ ;; I like numbers
+ (and (stringp (aref parsed 0))
+ (aset parsed 0 (string-to-number (aref parsed 0))))
+ (and (stringp (aref parsed 1))
+ (aset parsed 1 (string-to-number (aref parsed 1))))
+ (and (stringp (aref parsed 2))
+ (aset parsed 2 (string-to-number (aref parsed 2))))
+
+ ;; Sanity check
+ (cond ((and (< 0 (aref parsed 0))
+ (< 0 (aref parsed 1)) (>= 12 (aref parsed 1))
+ (< 0 (aref parsed 2))
+ (>= (timezone-last-day-of-month (aref parsed 1)
+ (aref parsed 0))
+ (aref parsed 2)))
+ (setcdr field (format "%04d-%02d-%02d" (aref parsed 0)
+ (aref parsed 1) (aref parsed 2)))
+ field)
+ (t
+ (error "BBDB cannot parse %s header value %S for upgrade"
+ field date)))))
+
+(defun bbdb-unmigrate-change-dates (rec)
+ "Change date formats.
+Formats are changed in timestamp and creation-date fields from
+\"yyyy-mm-dd\" to \"dd mmm yy\". Assumes the notes list is passed in
+as an argument."
+ (unless (stringp rec)
+ (bbdb-mapc (lambda (rr)
+ (when (memq (car rr) '(creation-date timestamp))
+ (bbdb-unmigrate-change-dates-change-field rr)))
+ rec)
+ rec))
+
+(defun bbdb-unmigrate-change-dates-change-field (field)
+ "Unmigrate the date field (the cdr of FIELD) from \"yyyy-mm-dd\" to
+\"yyyy-mm-dd\"."
+ (cons (car field) (bbdb-time-convert (cdr field) "%e %b %y")))
+
+(defun bbdb-migrate-add-country-field (addrl)
+ "Add a country field to each address in the address list."
+ (mapcar (lambda (addr) (vconcat addr [""])) addrl))
+
+(defun bbdb-unmigrate-add-country-field (addrl)
+ "Remove the country field from each address in the address list."
+ ;; Some version 4 zip codes will be illegal version 3 (as used in
+ ;; 2.00.06) zip codes. This problem has not been solved.
+ (mapcar (lambda (addr)
+ (let* ((len (1- (length addr)))
+ (new-addr (make-vector len nil))
+ (ii 0))
+ (while (< ii len)
+ (aset new-addr ii (aref addr ii))
+ (setq ii (1+ ii)))))
+ addrl))
+
+(defun bbdb-migrate-streets-to-list (addrl)
+ "Convert the streets to a list."
+ (mapcar (lambda (addr)
+ (vector (aref addr 0) ; tag
+ (delete nil (delete "" ; nuke empties
+ (list (aref addr 1) ; street1
+ (aref addr 2) ; street2
+ (aref addr 3))));street3
+ (aref addr 4) ; city
+ (aref addr 5) ; state
+ (aref addr 6) ; zip
+ (aref addr 7))) ; country
+ addrl))
+
+(defun bbdb-unmigrate-streets-to-list (addrl)
+ "Convert the street list to the street[1-3] format."
+ ;; Take all the old addresses, ie. the 5th field, and for each
+ ;; address, render the third element (a list of streets) as three
+ ;; vector elements (v4-style address). If there's more than 3
+ ;; lines, everything remaining gets crammed into the third, using
+ ;; commas to separate the bits. If there's less, fill out with nil.
+ (mapcar (lambda (addr)
+ (let ((streets (aref addr 1)))
+ (vector (aref addr 0) ; tag
+ (or (nth 0 streets) "")
+ (or (nth 1 streets) "")
+ (mapconcat 'identity (cddr streets) ", ")
+ (aref addr 2) ; city
+ (aref addr 3) ; state
+ (aref addr 4) ; zip
+ (aref addr 5)))) ; country
+ addrl))
+
+;;;###autoload
+(defun bbdb-migrate-rewrite-all (message-p &optional records)
+ "Rewrite each and every record in the bbdb file; this is necessary if we
+are updating an old file format. MESSAGE-P says whether to sound off
+for each record converted. If RECORDS is non-nil, its value will be
+used as the list of records to update."
+ ;; RECORDS is used by the migration mechanism. Since the migration
+ ;; mechanism is called from within bbdb-records, if we called
+ ;; bbdb-change-record, we'd recurse and die. We're therefore left
+ ;; with the slightly more palatable (but still not pretty) calling
+ ;; of bbdb-overwrite-record-internal.
+ (or records (setq records (bbdb-records)))
+ (let ((i 0))
+ (while records
+ (bbdb-overwrite-record-internal (car records) nil)
+ (if message-p (message "Updating %d: %s %s" (setq i (1+ i))
+ (bbdb-record-firstname (car records))
+ (bbdb-record-lastname (car records))))
+ (setq records (cdr records)))))
+(defalias 'bbdb-dry-heaves 'bbdb-migrate-rewrite-all)
+
+;;;###autoload
+(defun bbdb-migrate-update-file-version (old new)
+ "Change the `file-version' string from the OLD version to the NEW
+version."
+ (goto-char (point-min))
+ (if (re-search-forward (format "^;;; file-version: %d$" old) nil t)
+ (replace-match (format ";;; file-version: %d" new))
+ (error (format "Can't find file-version string in %s buffer for v%d migration"
+ bbdb-file new))))
+
+(provide 'bbdb-migrate)
diff --git a/lisp/bbdb-print.el b/lisp/bbdb-print.el
new file mode 100644
index 0000000..cda31ed
--- /dev/null
+++ b/lisp/bbdb-print.el
@@ -0,0 +1,672 @@
+;;; bbdb-print.el -- for printing BBDB databases using TeX.
+
+;;; Authors: Boris Goldowsky <boris@cs.rochester.edu>
+;;; Dirk Grunwald <grunwald@cs.colorado.edu>
+;;; Luigi Semenzato <luigi@paris.cs.berkeley.edu>
+;;; Copyright (C) 1993 Boris Goldowsky
+;;; Version: 3.92; 4Jan95
+
+;;; This file is part of the bbdb-print extensions to the Insidious
+;;; Big Brother Database, which is for use with GNU Emacs.
+;;;
+;;; 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
+;;; details.
+;;;
+;;; 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.
+
+;;; Commentary:
+;;;
+;;; In the *BBDB* buffer, type P to convert the listing to TeX
+;;; format. It will prompt you for a filename. Then run TeX on that
+;;; file and print it out.
+;;;
+;;; Bbdb-print understands one new bbdb field: tex-name. If it
+;;; exists, this will be used for the printed listing instead of the
+;;; name field of that record. This is designed for entering names
+;;; with lots of accents that would mess up mailers, or when for any
+;;; reason you want the printed version of the name to be different
+;;; from the version that appears on outgoing mail and in the *BBDB*
+;;; buffer. You may want to add tex-name to a omit list of the variable
+;;; bbdb-display-layout-alist so you only see it in the printout.
+;;; tex-name is exempted from the usual special-character quoting done by
+;;; bbdb-print; it is used verbatim.
+;;;
+;;; Not all fields or records need be printed. To not print a certain
+;;; field, add it to `bbdb-print-omit-fields' (which see). If after eliding
+;;; fields a record contains no interesting information, it will not
+;;; be printed at all; the variable `bbdb-print-require' determines
+;;; what is meant by "interesting" information. You can also restrict
+;;; printing to just the records currently in the *BBDB* buffer by
+;;; using *P instead of P.
+;;;
+;;; There are various options for the way the formatting is done; most
+;;; are controlled by the variable bbdb-print-alist. See its
+;;; documentation for the allowed options.
+
+;;; Installation:
+;;;
+;;; Put this file somewhere on your load-path. Put bbdb-print.tex and
+;;; bbdb-cols.tex somewhere on your TEXINPUTS path, or put absolute
+;;; pathnames into the variable bbdb-print-format-files (which see). Put
+;;; (add-hook 'bbdb-load-hook (function (lambda () (require 'bbdb-print))))
+;;; into your .emacs, or autoload it.
+;;;
+;;; This program was adapted for BBDB by Boris Goldowsky
+;;; <boris@cs.rochester.edu> and Dirk Grunwald
+;;; <grunwald@cs.colorado.edu> using a TeX format designed by Luigi
+;;; Semenzato <luigi@paris.cs.berkeley.edu>.
+;;; We are also grateful to numerous people on the bbdb-info
+;;; mailing list for suggestions and bug reports.
+
+;;; Code:
+
+(require 'bbdb)
+(require 'bbdb-com)
+
+;;; Variables:
+
+(defcustom bbdb-print-file-name "~/bbdb.tex"
+ "*Default file name for printouts of BBDB database."
+ :group 'bbdb-utilities-print
+ :type 'file)
+
+(defcustom bbdb-print-omit-fields '(omit tex-name aka mail-alias)
+ "*List of fields NOT to print in address list.
+See also bbdb-print-require."
+ :group 'bbdb-utilities-print
+ :type '(repeat (symbol :tag "Field to exclude")))
+
+(defcustom bbdb-print-require '(or address phone)
+ "*What fields are required for printing a record.
+This is evaluated for each record, and the record will be printed only
+if it returns non-nil. The symbols name, company, net, phone,
+address, and notes will be set to appropriate values when this is
+evaluated; they will be nil if the field does not exist or is elided.
+
+The value of this variable can be any lisp expression, but typically
+it will be used for a boolean combination of the field variables, as
+in the following simple examples:
+
+ Print only people whose phone numbers are known:
+ (setq bbdb-print-require 'phone)
+ Print people whose names AND companies are known:
+ (setq bbdb-print-require '(and name company))
+ Print people whose names, and either addresses OR phone numbers are known:
+ (setq bbdb-print-require '(and name (or address phone)))."
+ :group 'bbdb-utilities-print
+ :type '(choice (const :tag "Print all records" t)
+ (symbol :tag "Print all records with this field" phone)
+ (sexp :tag "Print only when this evaluates to non-nil"
+ '(or phone address phone))))
+
+(defun bbdb-print-field-shown-p (field)
+ (not (memq field bbdb-print-omit-fields)))
+
+(define-widget 'bbdb-print-alist-widget 'repeat
+ "For use in Customize"
+ :args `((choice
+ (cons :tag "Column specification" :value (column . 1)
+ (const :tag "Column mode" column)
+ (radio-button-choice (const :tag "One column" 1)
+ (const :tag "Two columns" 2)
+ (const :tag "Three columns" 3)
+ (const :tag "Four columns" 4)
+ (const :tag "Quad" quad)
+ (const :tag "Grid" grid)))
+ (cons :tag "Separator specification" :value (separator . 0)
+ (const :tag "Separator" separator)
+ (radio-button-choice (const :tag "None" 0)
+ (const :tag "Line" 1)
+ (const :tag "Boxed letters" 2)
+ (const :tag "Large boxed letters" 3)
+ (const :tag "Large letters" 4)
+ (const :tag "Letters with lines" 5)
+ (const :tag "Letters with suits" 6)
+ (const :tag "Boxed letters with suits" 7)))
+ (cons :tag "Omit certain area codes"
+ :value (omit-area-code . ,(concat "^("
+ (if (integerp bbdb-default-area-code)
+ (int-to-string bbdb-default-area-code)
+ "000") ") "))
+ (const :tag "Omit certain area codes" omit-area-code)
+ (regexp :tag "Pattern to omit"))
+ (cons :tag "Phone number location" :value (phone-on-first-line . t)
+ (const :tag "Phone number location" phone-on-first-line)
+ (choice (const :tag "First home number on same line as name" t)
+ (const :tag "Don't put the phone number on the name line" nil)
+ (regexp :tag "Use phone number whose location matches" "^work$")))
+ (cons :tag "Limit included phone numbers" :value (n-phones . 3)
+ (const :tag "Limit included phone numbers" n-phones)
+ (integer :tag "Maximum number to include" 3))
+ (cons :tag "Limit included addresses" :value (n-addresses . 3)
+ (const :tag "Limit included addresses" n-addresses)
+ (integer :tag "Maximum number to include" 3))
+ (cons :tag "Include additional TeX input files" :value (include-files . nil)
+ (const :tag "Additional TeX input files to include" include-files)
+ (repeat (file :tag "TeX file to include")))
+ (cons :tag "Font type selection" :value (ps-fonts . nil)
+ (const :tag "Select font type" ps-fonts)
+ (choice (const :tag "Use standard TeX fonts" nil)
+ (const :tag "Use Postscript fonts" t)))
+ (cons :tag "Font size selection" :value (font-size . 10)
+ (const :tag "Select font size" font-size)
+ (integer :tag "Font size in points" 10))
+ (cons :tag "Page height selection" :value (v-size . nil)
+ (const :tag "Select page height" v-size)
+ (choice (const :tag "Use TeX default" nil)
+ (string :tag "Height (must be valid TeX dimension)" "9in")))
+ (cons :tag "Page width selection" :value (h-size . nil)
+ (const :tag "Select page width" h-size)
+ (choice (const :tag "Use TeX default" nil)
+ (string :tag "Width (must be valid TeX dimension)" "6in")))
+ (cons :tag "Vertical offset (top margin)" :value (voffset . nil)
+ (const :tag "Select vertical offset (top margin)" voffset)
+ (choice (const :tag "Use TeX default" nil)
+ (string :tag "Vertical offset (must be valid TeX dimension)" "1in")))
+ (cons :tag "Horizontal offset (left margin)" :value (hoffset . nil)
+ (const :tag "Select horizontal offset (left margin)" hoffset)
+ (choice (const :tag "Use TeX default" nil)
+ (string :tag "Horizontal offset (must be valid TeX dimension)" "1in")))
+ (cons :tag "Quad format height" :value (quad-vsize . "")
+ (const :tag "Select height for quad format pages" quad-vsize)
+ (string :tag "Height (must be valid TeX dimension)"))
+ (cons :tag "Quad format width" :value (quad-hsize . "")
+ (const :tag "Select width for quad format pages" quad-hsize)
+ (string :tag "Width (must be valid TeX dimension)")))))
+
+(defcustom bbdb-print-alist
+ `((omit-area-code . ,(concat "^(" (if (integerp bbdb-default-area-code)
+ (int-to-string bbdb-default-area-code)
+ "000") ") "))
+ (phone-on-first-line . "^[ \t]*$")
+ (ps-fonts . nil)
+ (font-size . 6)
+ (quad-hsize . "3.15in")
+ (quad-vsize . "4.5in"))
+ "*Formatting options for `bbdb-print', all formats.
+This is an alist of the form ((option1 . value1) (option2 . value2) ...)
+
+You can have separate settings for brief and non-brief printouts;
+see the variables `bbdb-print-brief-alist' and `bbdb-print-full-alist'.
+Settings there will override the common settings in this variable.
+
+The possible options and legal values are:
+ - columns: 1, 2, 3, 4 or 'quad (4 little 2-column pages per sheet)
+ or 'grid (12 credit-card-sized pages per sheet).
+ - separator: 0-7, the style of heading for each letter.
+ 0=none, 1=line, 2=boxed letters, 3=large boxed letters, 4=large letters,
+ 5=letters with lines, 6=letters with suits, 7=boxed letters with suits.
+ - omit-area-code: a regular expression matching area codes to omit.
+ - phone-on-first-line: t means to put first phone number on the same
+ line with the name, nil means just the name. A string means to
+ use the first phone number whose \"location\" matches that string,
+ which should be a valid regular expression.
+ - n-phones: maximum number of phone numbers to include.
+ - n-addresses: maximum number of addresses to include.
+ - include-files: list of TeX files to \\input. If these filenames are not
+ absolute, the files must be located somewhere that TeX will find them.
+ - ps-fonts: nonnil means to use them, nil to use standard TeX fonts.
+ - font-size: in points, any integer (assuming fonts in that size exist!).
+ - hsize, vsize: horizontal dimension of pages. String value can be any valid
+ TeX dimension, or nil to use TeX's default.
+ - hoffset, voffset: shift TeX's output rightward (downward) by this distance
+ (any TeX dimension). Nil or 0 uses TeX's default positioning.
+ - quad-hsize, quad-vsize: for the quad format, horizontal and
+ vertical size of the little pages. These must be strings which
+ are valid TeX dimensions, eg \"10cm\"."
+ :group 'bbdb-utilities-print
+ :type 'bbdb-print-alist-widget)
+
+(defcustom bbdb-print-full-alist
+ '((columns . 3)
+ (separator . 2)
+ (include-files "bbdb-print" "bbdb-cols"))
+ "*Extra options for `bbdb-print' non-brief format.
+These supplement or override entries in `bbdb-print-alist'; see description
+of possible contents there."
+ :group 'bbdb-utilities-print
+ :type 'bbdb-print-alist-widget)
+
+(defcustom bbdb-print-brief-alist
+ '((columns . 1)
+ (separator . 1)
+ (n-phones . 2)
+ (n-addresses . 1)
+ (include-files "bbdb-print-brief" "bbdb-cols"))
+ "*Extra Options for `bbdb-print', brief format.
+These supplement or override entries in `bbdb-print-alist'; see description
+of possible contents there."
+ :group 'bbdb-utilities-print
+ :type 'bbdb-print-alist-widget)
+
+(defconst bbdb-print-filofax-alist
+ (append '((font-size . 12)
+ (columns . 2)
+ (voffset . "-2cm")
+ (hoffset . "-2cm")
+ (vsize . "27cm"))
+ bbdb-print-full-alist)
+ "Example setup for making pages for a Filofax binder.")
+
+
+(defcustom bbdb-print-prolog
+ (concat "%%%% ====== Phone/Address list in -*-TeX-*- Format =====\n"
+ "%%%% produced by bbdb-print, version 3.0\n\n")
+ "*TeX statements to include at the beginning of the `bbdb-print' file."
+ :group 'bbdb-utilities-print
+ :type '(text :format "%t:\n%v"))
+
+(defcustom bbdb-print-epilog "\\endaddresses\n\\bye\n"
+ "*TeX statements to include at the end of the `bbdb-print' file."
+ :group 'bbdb-utilities-print
+ :type '(text :format "%t:\n%v"))
+
+(defcustom bbdb-print-net 'primary
+ "*Indicates whether only the primary or all email addresses are printed.
+Symbol `primary' means print the primary email address only.
+Symbol `all' means print all email addresses."
+ :group 'bbdb-utilities-print
+ :type '(choice (const primary)
+ (const all)))
+
+;;; Functions:
+
+(defsubst bbdb-print-if-not-blank (string &rest more)
+ "If STRING is not null, then return it concatenated
+with rest of arguments. If it is null, then all arguments are
+ignored and the null string is returned."
+ (if (or (null string) (equal "" string))
+ ""
+ (apply 'concat string more)))
+
+;;;###autoload
+(defun bbdb-print (visible-records to-file brief)
+ "Make a TeX file for printing out the bbdb database.\\<bbdb-mode-map>
+If \"\\[bbdb-apply-next-command-to-all-records]\\[bbdb-print]\" is \
+used instead of simply \"\\[bbdb-print]\", then includes only the
+people currently in the *BBDB* buffer. With a prefix argument, makes
+a brief \(one-line-per-entry) printout.
+
+There are various variables for customizing the content & format of
+the printout, notably the variables `bbdb-print-alist' and
+`bbdb-print-require'. See the file bbdb-print.el for more information."
+ (interactive (list (bbdb-do-all-records-p)
+ (read-file-name "Print To File: "
+ (file-name-directory bbdb-print-file-name)
+ bbdb-print-file-name
+ nil
+ (file-name-nondirectory bbdb-print-file-name))
+ current-prefix-arg))
+ (setq bbdb-print-file-name (expand-file-name to-file))
+ (let* ((alist (append (if brief bbdb-print-brief-alist bbdb-print-full-alist)
+ bbdb-print-alist))
+ (records (if (not visible-records)
+ (bbdb-records)
+ (set-buffer bbdb-buffer-name)
+ (mapcar 'car bbdb-records)))
+ (psstring (if (cdr (assoc 'ps-fonts alist))
+ "ps" ""))
+ (columns (cdr (assoc 'columns alist)))
+ (current-letter t)
+ (pofl (cdr (assoc 'phone-on-first-line alist)))
+ (n-phones (cdr (assoc 'n-phones alist)))
+ (n-addresses (cdr (assoc 'n-addresses alist))))
+ (find-file bbdb-print-file-name)
+ (widen) (erase-buffer)
+ (insert bbdb-print-prolog)
+ (let ((dimens '(hsize vsize hoffset voffset))
+ val)
+ (while dimens
+ (setq val (cdr (assoc (car dimens) alist)))
+ (if val
+ (insert (format "\\%s=%s\n" (car dimens) val)))
+ (setq dimens (cdr dimens))))
+ (let ((infiles (cdr (assoc 'include-files alist))))
+ (while infiles
+ (insert (format "\\input %s\n" (car infiles)))
+ (setq infiles (cdr infiles))))
+ (insert (format "\n\\set%ssize{%d}\n"
+ psstring (cdr (assoc 'font-size alist)))
+ (format "\\setseparator{%d}\n"
+ (cdr (assoc 'separator alist)))
+ (cond ((eq 'quad columns)
+ (format "\\quadformat{%s}{%s}"
+ (cdr (assoc 'quad-hsize alist))
+ (cdr (assoc 'quad-vsize alist))))
+ ((eq 'grid columns) "\\grid")
+ ((= 4 columns) "\\fourcol")
+ ((= 3 columns) "\\threecol")
+ ((= 2 columns) "\\twocol")
+ ((= 1 columns) "\\onecol"))
+ ;; catcodes are font-encoding specific !
+ ;; Add more if you know them
+ (if (equal psstring "ps")
+ (concat "\n\n"
+ ;; Adobe Times and Courier
+ )
+ (concat "\n\n"
+ ;; ec fonts
+ "\\catcode`▀=\\active\\chardef▀=\"FF"))
+ "\n\n\\beginaddresses\n")
+ (while records
+ (setq current-letter
+ (bbdb-print-format-record (car records) current-letter
+ brief pofl n-phones n-addresses))
+ (setq records (cdr records)))
+ (insert bbdb-print-epilog)
+ (goto-char (point-min))))
+
+(defvar bbdb-address-print-formatting-alist
+ '((bbdb-address-is-continental . bbdb-print-format-address-continental)
+ (nil . bbdb-print-format-address-default))
+ "Alist of address identifying and address formatting functions for printing.
+The key is an identifying function which accepts an address. The
+associated value is a formatting function which inserts the formatted
+address in the current buffer. If the identifying function returns
+non-nil, the formatting function is called. The nil key is a default
+value will allways calls the associated formatting function. Therefore
+you should always have (nil . bbdb-print-format-address-default) as the
+last element in the alist.
+
+The functions must take one argument, the address.
+
+See also `bbdb-address-formatting-alist'.")
+
+(defun bbdb-print-format-address-continental (addr)
+ "Insert formated continental address ADDR in current buffer for printing.
+This format is used in western Europe, for example.
+
+This function is a possible formatting function for
+`bbdb-address-print-formatting-alist'.
+
+The result looks like this:
+ street
+ street
+ ...
+ zip city, state
+ country"
+ (insert
+ (format
+ "\\address{%s}\n"
+ (bbdb-print-tex-quote
+ (if addr
+ (concat
+ (mapconcat (function (lambda(str)
+ (if (= 0 (length (bbdb-string-trim str)))
+ ()
+ (concat str"\\\\\n"))))
+ (bbdb-address-streets addr)
+ "")
+ (let ((c (bbdb-address-city addr))
+ (s (bbdb-address-state addr))
+ (z (bbdb-address-zip addr)))
+ (if (or (> (length c) 0)
+ (> (length z) 0)
+ (> (length s) 0))
+ (concat z (if (and (> (length z) 0)
+ (> (length c) 0)) " " "")
+ c (if (and (or (> (length z) 0)
+ (> (length c) 0))
+ (> (length s) 0)) ", " "")
+ s "\\\\\n") ""))
+ (bbdb-print-if-not-blank (bbdb-address-country addr) "\\\\\n"))
+ "")))))
+
+(defun bbdb-print-format-address-default (addr)
+ "Insert formated address ADDR in current buffer for printing.
+This is the default format; it is used in the US, for example.
+
+This function is a possible formatting function for
+`bbdb-address-print-formatting-alist'.
+
+The result looks like this:
+ street
+ street
+ ...
+ city, state zip
+ country"
+ (insert
+ (format
+ "\\address{%s}\n"
+ (bbdb-print-tex-quote
+ (if addr
+ (concat
+ (mapconcat (function (lambda(str)
+ (if (= 0 (length (bbdb-string-trim str)))
+ ()
+ (concat str "\\\\\n"))))
+ (bbdb-address-streets addr)
+ "")
+ (let ((c (bbdb-address-city addr))
+ (s (bbdb-address-state addr))
+ (z (bbdb-address-zip addr)))
+ (if (or (> (length c) 0)
+ (> (length z) 0)
+ (> (length s) 0))
+ (concat c (if (and (> (length c) 0)
+ (> (length s) 0)) ", " "")
+ s (if (and (or (> (length c) 0)
+ (> (length s) 0))
+ (> (length z) 0)) " " "")
+ z "\\\\\n") ""))
+ (bbdb-print-if-not-blank (bbdb-address-country addr) "\\\\\n"))
+ "")))))
+
+(defun bbdb-print-format-record (record current-letter
+ brief pofl n-phones n-addresses)
+ "Insert the bbdb RECORD in TeX format.
+Second arg CURRENT-LETTER is the first letter of the sortkey of the previous
+record. If this is non-nil and RECORD begins differently, a section heading is
+output. If CURRENT-LETTER is t always produces a heading.
+3rd argument BRIEF is for 1-line-per-record printouts.
+Args 3-5 PHONE-ON-FIRST-LINE, N-PHONES, and N-ADDRESSES are the respective
+values from `bbdb-print-alist'.
+
+The return value is the new CURRENT-LETTER."
+
+ (bbdb-debug (if (bbdb-record-deleted-p record)
+ (error "plus ungood: tex formatting deleted record")))
+
+ (let* ((first-letter
+ (substring (concat (bbdb-record-sortkey record) "?") 0 1))
+ (name (and (bbdb-print-field-shown-p 'name)
+ (or (bbdb-record-getprop record 'tex-name)
+ (bbdb-print-tex-quote
+ (bbdb-record-name record)))))
+ (company (and (bbdb-print-field-shown-p 'company)
+ (bbdb-record-company record)))
+ (net (and (bbdb-print-field-shown-p 'net)
+ (bbdb-record-net record)))
+ (phone (and (bbdb-print-field-shown-p 'phone)
+ (bbdb-record-phones record)))
+ (address (and (bbdb-print-field-shown-p 'address)
+ (bbdb-record-addresses record)))
+ (notes (bbdb-record-raw-notes record)))
+
+ (if (not (eval bbdb-print-require))
+ nil ; lacks required fields
+
+ ;; Section header, if neccessary.
+
+ (if (and current-letter
+ (not (string-equal first-letter current-letter)))
+ (insert (format "\\goodbreak\n\\separator{%s}\n%%\n"
+ (bbdb-print-tex-quote (upcase first-letter)))))
+
+ (insert "\\beginrecord\n")
+
+ ;; if there is no name, use company instead
+ (if (and (not name) company)
+ (setq name (bbdb-print-tex-quote company)
+ company nil))
+
+ (let ((rightside ""))
+ (cond ((null phone))
+ ((eq t pofl)
+ (setq rightside (bbdb-print-phone-string (car phone))
+ phone (cdr phone)))
+ ((stringp pofl)
+ (let ((p (bbdb-print-front-if
+ (function (lambda (ph)
+ (string-match pofl (aref ph 0))))
+ phone)))
+ (if p
+ (setq rightside (bbdb-print-phone-string (car p))
+ phone (cdr p))))))
+ (insert (format "\\firstline{%s}{%s}\n"
+ name
+ (bbdb-print-tex-quote rightside))))
+
+ (if company
+ (insert (format "\\comp{%s}\n" (bbdb-print-tex-quote company))))
+
+ ;; Phone numbers
+
+ (if n-phones
+ (setq phone (bbdb-print-firstn (- n-phones (if pofl 1 0))
+ phone brief)))
+ (while phone
+ (if (car phone)
+ (let ((place (aref (car phone) 0))
+ (number (bbdb-print-phone-string (car phone))))
+ (insert (format "\\phone{%s%s}\n"
+ (bbdb-print-tex-quote
+ (bbdb-print-if-not-blank place ": "))
+ (bbdb-print-tex-quote number))))
+ (insert (format "\\phone{}\n")))
+ (setq phone (cdr phone)))
+
+ ;; Email address
+ ;; Make all dots legal line-breaks.
+
+ (when net
+ (let ((net-addrs
+ (cond ((eq bbdb-print-net 'primary)
+ (list (car net)))
+ ((eq bbdb-print-net 'all)
+ net)
+ (t nil))))
+ (insert
+ (format
+ "\\email{%s}\n"
+ (mapconcat
+ (lambda (net-addr)
+ (setq net-addr (bbdb-print-tex-quote net-addr))
+ (let ((start 0))
+ (while (string-match "\\." net-addr start)
+ (setq net-addr
+ (concat (substring net-addr 0 (match-beginning 0))
+ ".\\-"
+ (substring net-addr (match-end 0))))
+ (setq start (+ 2 (match-end 0)))))
+ net-addr)
+ net-addrs ", ")))))
+
+ ;; Addresses. FUTURE: If none left, should use phones instead.
+
+ (if n-addresses
+ (setq address
+ (bbdb-print-firstn n-addresses address brief)))
+ (while address
+ (bbdb-format-address (car address) 'printing)
+ (setq address (cdr address)))
+
+ ;; Notes
+
+ (if (stringp notes)
+ (setq notes (list (cons 'notes notes))))
+ (while notes
+ (let ((thisnote (car notes)))
+ (if (bbdb-print-field-shown-p (car thisnote))
+ (progn
+ (if (eq 'notes (car thisnote))
+ (insert (format "\\notes{%s}\n" (bbdb-print-tex-quote
+ (cdr thisnote))))
+ (insert (format "\\note{%s}{%s}\n"
+ (bbdb-print-tex-quote (symbol-name
+ (car thisnote)))
+ (bbdb-print-tex-quote (cdr thisnote))))))))
+ (setq notes (cdr notes)))
+
+ ;; Mark end of the record.
+
+ (insert "\\endrecord\n%\n")
+ (setq current-letter first-letter)))
+
+ current-letter)
+
+(defun bbdb-print-phone-string (phone)
+ "Format PHONE-NUMBER as a string, obeying omit-area-code setting.
+Omit-area-code is one of the allowed symbols in `bbdb-print-alist', which see."
+ (let ((str (bbdb-phone-string phone))
+ (omit (cdr (assoc 'omit-area-code bbdb-print-alist))))
+ (if (and omit (string-match omit str))
+ (substring str (match-end 0))
+ str)))
+
+(defun bbdb-print-front-if (func list)
+ "Move first elt of LIST satisfying FUNC to front.
+The car of the returned list is the first element that returned nonnil;
+The cdr is the rest of the list.
+But if the FUNC returns nil for every elements of the LIST, returns nil."
+ (cond ((null list) nil)
+ ((funcall func (car list))
+ list)
+ ((let ((rest (bbdb-print-front-if func (cdr list))))
+ (if rest
+ (cons (car rest)
+ (cons (car list) (cdr rest))))))))
+
+(defun bbdb-print-firstn (n list force)
+ "The first N elements of LIST.
+If 3rd arg FORCE is nonnil, will extend the list to length N if necessary, by
+adding nil's. If N is nil, just returns LIST."
+ (cond ((null n) list)
+ ((null list) (if force (make-list n nil) nil))
+ ((<= n 0) nil)
+ (t (cons (car list) (bbdb-print-firstn (1- n) (cdr list) force)))))
+
+(defun bbdb-print-tex-quote (string)
+ "Quote any unquoted TeX special characters that appear in STRING.
+In other words, # alone will be replaced by \\#, but \\^ will be left for
+TeX to process as an accent."
+ (if string
+ (save-excursion
+ (set-buffer (get-buffer-create " bbdb-print-tex-quote"))
+ (erase-buffer)
+ (insert string)
+ (goto-char (point-min))
+ (while (not (eobp))
+ (cond ((looking-at "[<>=]+")
+ (replace-match "$\\&$"))
+ ((and (looking-at "[#$%&_]")
+ (not (eq ?\\ (char-after (1- (point))))))
+ (insert "\\")
+ (forward-char 1))
+ ((and (looking-at "~")
+ (not (eq ?\\ (char-after (1- (point))))))
+ (insert "\\")
+ (forward-char 1)
+ (insert "{}"))
+ ((and (looking-at "[{}]")
+ (not (eq ?\\ (char-after (1- (point))))))
+ (insert "$\\")
+ (forward-char 1)
+ (insert "$"))
+ (t (forward-char 1))))
+ (buffer-string))))
+
+
+(provide 'bbdb-print)
+
+;;; bbdb-print ends here.
+
diff --git a/lisp/bbdb-reportmail.el b/lisp/bbdb-reportmail.el
new file mode 100644
index 0000000..baadb03
--- /dev/null
+++ b/lisp/bbdb-reportmail.el
@@ -0,0 +1,107 @@
+;; bbdb-reportmail.el --- Hooks the Insidious Big Brother Database
+;; into the Reportmail package
+
+;; Copyright (C) 1997 Christopher Kline
+
+;; Author: Christopher Kline <ckline@media.mit.edu>
+;; Maintainer: Christopher Kline <ckline@media.mit.edu>
+;; Version: 1.01
+;; Created: 25 Jun 1997
+;; Date: 26 Jun 1997
+
+;; Bbdb-reportmail 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 2, or (at your option)
+;; any later version.
+
+;; Bbdb-reportmail 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 details.
+
+;; 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, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Commentary:
+
+;; Bbdb-reportmail advises the reportmail package function
+;; display-time-get-field so that it attempts to replace the reported
+;; "from" and "to" fields with the name field (or mail-name, if it
+;; exists) of the corresponding BBDB record, if such a correspondence
+;; can be made.
+
+;; To use this, simply add the following lines AFTER you load in your
+;; bbdb, set bbdb variables, etc.
+;;
+;; (bbdb-insinuate-reportmail)
+;;
+;; (A require used to be necessary - it is no longer needed as long as
+;; bbdb-insinuate-reportmail is called)
+
+;;; History:
+
+;; v1.01 26 June 1997
+;; Fixed the advice so that if we are the message recipient, do
+;; nothing so that display-time-process-new-mail will correctly
+;; trap this case.
+;;
+;; v1.00 26 June 1997
+;; Initial release.
+
+;;-----------------------------------------------------------------------
+
+(require 'bbdb)
+(require 'reportmail)
+(require 'advice)
+(require 'mail-extr)
+
+(defun bbdb/reportmail-alternate-full-name (address)
+ (if address
+ (let ((entry (bbdb-search-simple nil address)))
+ (if entry
+ (or (bbdb-record-getprop entry 'mail-name)
+ (bbdb-record-name entry))))))
+
+(defadvice display-time-get-field
+ (around bbdb/reportmail-hack-display-time-get-field disable activate)
+ "Advises the `display-time-get-field' function in the reportmail package.
+If the field is \"from\" or \"to\", it tries to replace the value of the field
+with the name field of the corresponding BBDB entry, if one can be found.
+
+If no corresponding record can be found, the field value is left unaltered."
+ (let (gf-field)
+ ;; Get the original argument to display-time-get-field
+ (setq gf-field (ad-get-arg 0))
+ ;; Call the original display-time-get-field
+ ad-do-it
+ (if (or (string= gf-field "To") (string= gf-field "From"))
+ (setq ad-return-value
+ (or
+ ;; If this message is to me, then do nothing so
+ ;; reportmail can trap this case in
+ ;; display-time-process-new-mail
+ (if (display-time-member ad-return-value
+ display-time-my-addresses)
+ ad-return-value
+ nil)
+ ;; Is the sender/recipient in our BBDB?
+ (bbdb/reportmail-alternate-full-name
+ (car (cdr (mail-extract-address-components ad-return-value))))
+ ;; Can't find sender/recipient in BBDB; do nothing.
+ ad-return-value)
+ ))))
+
+;;;###autoload
+(defun bbdb-insinuate-reportmail ()
+ "Call this function to hook BBDB into reportmail."
+ (ad-enable-advice 'display-time-get-field 'around
+ 'bbdb/reportmail-hack-display-time-get-field)
+ (ad-activate 'display-time-get-field)
+ (message "Insinuated BBDB into Reportmail.")
+)
+
+(provide 'bbdb-reportmail)
+
+
diff --git a/lisp/bbdb-rmail.el b/lisp/bbdb-rmail.el
new file mode 100644
index 0000000..d6aab98
--- /dev/null
+++ b/lisp/bbdb-rmail.el
@@ -0,0 +1,202 @@
+;;; -*- Mode:Emacs-Lisp -*-
+
+;;; This file is part of the Insidious Big Brother Database (aka BBDB),
+;;; copyright (c) 1991, 1992 Jamie Zawinski <jwz@netscape.com>.
+;;; Interface to RMAIL. 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
+;;; details.
+;;;
+;;; 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.
+
+(require 'bbdb)
+(require 'bbdb-com)
+(require 'rmail)
+(load-library "rmailsum")
+(require 'mailheader)
+
+
+;;;###autoload
+(defun bbdb/rmail-update-record (&optional offer-to-create)
+ (let ((bbdb-get-only-first-address-p)
+ (records (bbdb/rmail-update-records offer-to-create)))
+ (if records (car records) nil)))
+
+(defun bbdb/rmail-get-header-content( header-field buf )
+ "Pull HEADER-FIELD out of BUF's mail header.
+BUF is actually the rmail buffer from which the current message should
+be extracted."
+ (save-excursion
+ (set-buffer buf)
+ (if (fboundp 'rmail-get-header) ; Emacs 23
+ (rmail-get-header header-field)
+ (save-restriction
+ (rmail-narrow-to-non-pruned-header)
+ (let ((headers (mail-header-extract))
+ (header (intern-soft (downcase header-field))))
+ (mail-header header headers))))))
+
+(defun bbdb/rmail-new-flag( buf )
+ "Returns t if the current message in buffer BUF is new."
+ (rmail-message-labels-p rmail-current-message ", ?\\(unseen\\),"))
+
+(defcustom bbdb/rmail-update-records-mode
+ '(if (bbdb/rmail-new-flag rmail-buffer) 'annotating 'searching)
+ "RMAIL-specific version of `bbdb-update-records-mode', which see."
+ :group 'bbdb-mua-specific-rmail
+ :type '(choice (const :tag "annotating all messages"
+ annotating)
+ (const :tag "annotating no messages"
+ searching)
+ (const :tag "annotating only new messages"
+ (if (bbdb/rmail-new-flag rmail-buffer) 'annotating 'searching))
+ (sexp :tag "user defined")))
+
+;;;###autoload
+(defun bbdb/rmail-update-records (&optional offer-to-create)
+ "Returns the records corresponding to the current RMAIL emssage,
+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/rmail-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 n this message, but it will search only for existing records.
+When hitting C-g again it will stop scanning."
+ (if (and (boundp 'rmail-buffer) rmail-buffer)
+ (set-buffer rmail-buffer)
+ (error "Not in an rmail buffer"))
+ (if rmail-current-message
+ (let ((bbdb/rmail-offer-to-create offer-to-create)
+ cache records)
+
+ (if (not bbdb/rmail-offer-to-create)
+ (setq cache (bbdb-message-cache-lookup
+ rmail-current-message)))
+
+ (if cache
+ (setq records (if bbdb-get-only-first-address-p
+ (list (car cache))
+ cache))
+
+ (let ((bbdb-update-records-mode (or
+ bbdb/rmail-update-records-mode
+ bbdb-update-records-mode)))
+ (setq records (bbdb-update-records
+ (bbdb-get-addresses
+ bbdb-get-only-first-address-p
+ ;; uninteresting-senders
+ user-mail-address
+ 'bbdb/rmail-get-header-content
+ rmail-buffer)
+ bbdb/mail-auto-create-p
+ offer-to-create))
+
+ (bbdb-encache-message rmail-current-message records)))
+ records))
+ )
+
+;;;###autoload
+(defun bbdb/rmail-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)."
+ (interactive (list (if bbdb-readonly-p
+ (error "The Insidious Big Brother Database is read-only.")
+ (read-string "Comments: "))))
+ (if (and (boundp 'rmail-buffer) rmail-buffer)
+ (set-buffer rmail-buffer))
+ (bbdb-annotate-notes (bbdb/rmail-update-record t) string 'notes replace))
+
+(defun bbdb/rmail-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."
+ (interactive "P")
+ (let ((record (or (bbdb/rmail-update-record t) (error ""))))
+ (bbdb-display-records (list record))
+ (if arg
+ (bbdb-record-edit-property record nil t)
+ (bbdb-record-edit-notes record t))))
+
+
+;;;###autoload
+(defun bbdb/rmail-show-sender ()
+ "Display the contents of the BBDB for the sender of this message.
+This buffer will be in bbdb-mode, with associated keybindings."
+ (interactive)
+ (if (and (boundp 'rmail-buffer) rmail-buffer)
+ (set-buffer rmail-buffer))
+ (let ((record (bbdb/rmail-update-record t)))
+ (if record
+ (bbdb-display-records (list record))
+ (error "unperson"))))
+
+(defun bbdb/rmail-pop-up-bbdb-buffer ( &optional offer-to-create )
+ "Make the *BBDB* buffer be displayed along with the RMAIL window(s).
+Displays the records corresponding to the sender respectively
+recipients of the current message.
+See `bbdb/rmail-get-addresses-headers' and
+'bbdb-get-only-first-address-p' for configuration of what is being
+displayed."
+ (save-excursion
+ (let ((bbdb-gag-messages t)
+ (bbdb-electric-p nil)
+ (records (bbdb/rmail-update-records offer-to-create))
+ (bbdb-buffer-name bbdb-buffer-name))
+
+ (when (and bbdb-use-pop-up records)
+ (bbdb-pop-up-bbdb-buffer
+ (function (lambda (w)
+ (let ((b (current-buffer)))
+ (set-buffer (window-buffer w))
+ (prog1 (eq major-mode 'rmail-mode)
+ (set-buffer b))))))
+
+ ;; Always update the records; if there are no records, empty
+ ;; the BBDB window. This should be generic, not MUA-specific.
+ (bbdb-display-records records bbdb-pop-up-display-layout))
+
+ (when (not records)
+ (bbdb-undisplay-records)
+ (if (get-buffer-window bbdb-buffer-name)
+ (delete-window (get-buffer-window bbdb-buffer-name)))))))
+
+;;;###autoload
+(defun bbdb-insinuate-rmail ()
+ "Call this function to hook BBDB into RMAIL."
+ (define-key rmail-mode-map ":" 'bbdb/rmail-show-sender)
+ (define-key rmail-mode-map ";" 'bbdb/rmail-edit-notes)
+ (define-key rmail-summary-mode-map ":" 'bbdb/rmail-show-sender)
+ (define-key rmail-summary-mode-map ";" 'bbdb/rmail-edit-notes)
+
+ (add-hook 'rmail-show-message-hook 'bbdb/rmail-pop-up-bbdb-buffer)
+
+ ;; We must patch into rmail-only-expunge to clear the cache, since
+ ;; expunging a message invalidates the cache (which is based on
+ ;; message numbers).
+ (defadvice rmail-only-expunge (before bbdb/rmail-only-expunge)
+ "Invalidate BBDB cache before expunging."
+ (setq bbdb-message-cache nil))
+
+ ;; Same for undigestifying.
+ (or (fboundp 'undigestify-rmail-message)
+ (autoload 'undigestify-rmail-message "undigest" nil t))
+ (if (eq (car-safe (symbol-function 'undigestify-rmail-message)) 'autoload)
+ (load (nth 1 (symbol-function 'undigestify-rmail-message))))
+ (defadvice undigestify-rmail-message (before bbdb/undigestify-rmail-message)
+ "Invalidate BBDB cache before undigestifying."
+ (setq bbdb-message-cache nil))
+ )
+
+(provide 'bbdb-rmail)
diff --git a/lisp/bbdb-sc.el b/lisp/bbdb-sc.el
new file mode 100644
index 0000000..6fe04ae
--- /dev/null
+++ b/lisp/bbdb-sc.el
@@ -0,0 +1,209 @@
+;;; -*- Mode:Emacs-Lisp -*-
+
+;;; This file is an addition to the Insidious Big Brother Database
+;;; (aka BBDB), copyright (c) 1991, 1992 Jamie Zawinski
+;;; <jwz@netscape.com>.
+;;;
+;;; 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
+;;; details.
+;;;
+;;; 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.
+
+
+;;; This file was written by Martin Sjolin <marsj@ida.liu.se>
+;;; based the original code by Tom Tromey <tromey@busco.lanl.gov>.
+;;;
+;;; Thanks to Richard Stanton <stanton@haas.berkeley.edu> for ideas
+;;; for improvements and to Michael D. Carney <carney@ltx-tr.com>
+;;; for testing and feedback.
+
+;;; This file adds the ability to define attributions for Supercite in
+;;; a BBDB, enables you to retrieve your standard attribution from
+;;; BBDB. If the from header in the mail to which you are replying
+;;; only contains the e-mail address, the personal name is lookup in
+;;; BBDB. You need Supercite to make this code work. The attribution
+;;; os is stored under the key `attribution' (unless you've changed
+;;; bbdb/sc-attribution-field).
+
+;;; To use enable this code you will have to the "sc-consult" to your
+;;; sc-preferred-attribution-list. This file sets variable if it is not
+;;; set and isues an warning message if "sc-consult" is not included.
+;;;
+;;; (setq sc-preferred-attribution-list
+;;; '("sc-lastchoice" "x-attribution" "sc-consult"
+;;; "initials" "firstname" "lastname"))
+;;;
+;;;
+;;; We also set the sc-attrib-selection-list below if is not bound, if
+;;; you have your own special sc-attrib-selection-list, please add
+;;; an expression as below:
+;;;
+;;; (setq sc-attrib-selection-list
+;;; '(("sc-from-address" ((".*" . (bbdb/sc-consult-attr
+;;; (sc-mail-field "sc-from-address")))))))
+;;;
+;;; And finally we set the sc-mail-glom-frame to enable the
+;;; fetching of the name of person when there is only an e-mail
+;;; address in the original mail:
+;;;
+;;; (setq sc-mail-glom-frame
+;;; '((begin (setq sc-mail-headers-start (point)))
+;;; ("^x-attribution:[ \t]+.*$" (sc-mail-fetch-field t) nil t)
+;;; ("^\\S +:.*$" (sc-mail-fetch-field) nil t)
+;;; ("^$" (progn (bbdb/sc-default)
+;;; (list 'abort '(step . 0))))
+;;; ("^[ \t]+" (sc-mail-append-field))
+;;; (sc-mail-warn-if-non-rfc822-p (sc-mail-error-in-mail-field))
+;;; (end (setq sc-mail-headers-end (point)))))
+;;;
+;;;
+
+;;;
+;;;
+
+;;; packages
+(require 'bbdb)
+(require 'supercite)
+
+;;; User variable(s)
+(defcustom bbdb/sc-replace-attr-p t
+ "t if you like to create a new BBDB entry when
+entering a non-default attribution, 'ask if the user
+should be asked before creation and NIL if we never create a new entry."
+ :group 'bbdb-utilities-supercite
+ :type '(choice (const "Create a new BBDB entry" t)
+ (const "Confirm new record creation" ask)
+ (const "Don't create a new entry" nil)))
+
+(defcustom bbdb/sc-attribution-field 'attribution
+ "The BBDB field used for Supercite attribution information."
+ :group 'bbdb-utilities-supercite
+ :type '(symbol :tag "Field name"))
+
+;;; Code starts
+(defcustom bbdb/sc-last-attribution ""
+ "Default attribution return by the SuperCite citation engine,
+used to compare against citation selected by the user."
+ :group 'bbdb-utilities-supercite
+ :type '(string :tag "Default citation" ""))
+
+(defun bbdb/sc-consult-attr (from)
+ "Extract citing information from BBDB using sc-consult where
+FROM is user e-mail address to look for in BBDB."
+ ;; if logged in user sent this, use recipients.
+ (let ((from (if (or (null from)
+ (string-match (bbdb-user-mail-names) from))
+ (car (cdr (mail-extract-address-components
+ (or (sc-mail-field "to") from))))
+ from)))
+ (if from
+ (let ((record (bbdb-search-simple nil from)))
+ (and record
+ (bbdb-record-getprop record bbdb/sc-attribution-field))))))
+
+(defun bbdb/sc-set-attr ()
+ "Add attribute to BBDB."
+ (let ((from (sc-mail-field "from"))
+ (address (sc-mail-field "sc-from-address"))
+ (attr (sc-mail-field "sc-attribution")))
+ (if (and from attr bbdb/sc-replace-attr-p
+ (not (string-equal attr bbdb/sc-last-attribution))
+ (not (string-match (bbdb-user-mail-names) address)))
+ (let* ((bbdb-notice-hook nil)
+ ;; avoid noticing any headers in the reply message
+ (record (bbdb-annotate-message-sender
+ from t
+ (bbdb-invoke-hook-for-value
+ bbdb/mail-auto-create-p) t)))
+ (if record
+ (let ((old (bbdb-record-getprop record 'attribution)))
+ ;; ignore if we have an value and same value
+ (if (and (not (and old (string-equal old attr)))
+ (or (not (eq bbdb/sc-replace-attr-p 'ask))
+ (y-or-n-p (concat "Change attribution " attr))))
+ (progn (bbdb-record-putprop record
+ bbdb/sc-attribution-field attr)
+ (bbdb-change-record record nil)))))))))
+
+;;; this is marked as autoload since someone managed to trip up Gnus
+;;; with it. I'm not clear this needs fixing, as you should be calling
+;;; bbdb-insinuate-sc if you're using supercite/BBDB. However.
+;;;###autoload
+(defun bbdb/sc-default ()
+ "If the current \"from\" field in `sc-mail-info' alist
+contains only an e-mail address, lookup e-mail address in
+BBDB, and prepend a new \"from\" field to `sc-mail-info'."
+ (let* ((from (sc-mail-field "from"))
+ (pair (and from (mail-extract-address-components from))))
+ (if (and pair (not (car pair)))
+ (let* ((record (bbdb-search-simple nil (car (cdr pair))))
+ (name (and record (bbdb-record-name record))))
+ (if name
+ (setq sc-mail-info
+ (cons (cons "from"
+ (format "%s (%s)" (car (cdr pair)) name))
+ sc-mail-info)))))))
+
+;;; setup the default setting of the variables
+(defun bbdb/sc-setup-variables ()
+ "Set up the various Supercite variables for the BBDB.
+`sc-preferred-attribution-list', `sc-attrib-selection-list', and
+`sc-mail-glom-frame' are set, but only if they have not previously
+been defined. It is strongly suggested that you not call this
+function directly, but that you use this function (specifically the
+settings contained herein) as an example. In other words, set these
+variables yourself, either in your Emacs configuration file or using
+Custom."
+
+ ;; check for sc-consult in sc-preferred-attribution-list
+ (if (boundp 'sc-preferred-attribution-list)
+ (or (member '"sc-consult" sc-preferred-attribution-list)
+ (bbdb-warn (concat "\"sc-consult\" not included in "
+ "sc-preferred-attribution-list. Attributions cannot"
+ "be gathered from the BBDB without \"sc-consult\""
+ "in sc-preferred-attribution-list")))
+ (defvar sc-preferred-attribution-list
+ '("sc-lastchoice" "x-attribution" "sc-consult"
+ "initials" "firstname" "lastname")))
+
+ ;; check sc-attrib-selection-list
+ (defvar sc-attrib-selection-list
+ '(("sc-from-address"
+ ((".*" . (bbdb/sc-consult-attr
+ (sc-mail-field "sc-from-address")))))))
+
+ ;; set sc-mail-glom-frame
+ (defvar sc-mail-glom-frame
+ '((begin (setq sc-mail-headers-start (point)))
+ ("^x-attribution:[ \t]+.*$" (sc-mail-fetch-field t) nil t)
+ ("^\\S +:.*$" (sc-mail-fetch-field) nil t)
+ ("^$" (progn (bbdb/sc-default)
+ (list 'abort '(step . 0))))
+ ("^[ \t]+" (sc-mail-append-field))
+ (sc-mail-warn-if-non-rfc822-p (sc-mail-error-in-mail-field))
+ (end (setq sc-mail-headers-end (point))))))
+
+;; insert our hooks - call me from your Emacs initialization file
+(defvar attribution) ;; dammit, supercite!
+;;;###autoload
+(defun bbdb-insinuate-sc ()
+ "Call this function to hook BBDB into Supercite."
+
+ (add-hook 'sc-post-hook 'bbdb/sc-set-attr)
+ (add-hook 'sc-attribs-postselect-hook
+ (function (lambda()
+ (setq bbdb/sc-last-attribution
+ (if sc-downcase-p
+ (downcase attribution) attribution))))))
+
+(provide 'bbdb-sc)
+;;; end of bbdb-sc.el
diff --git a/lisp/bbdb-snarf.el b/lisp/bbdb-snarf.el
new file mode 100644
index 0000000..bf9d969
--- /dev/null
+++ b/lisp/bbdb-snarf.el
@@ -0,0 +1,599 @@
+;;; bbdb-snarf.el -- convert free-form text to BBDB records
+
+;;;
+;;; Copyright (C) 1997 by John Heidemann <johnh@isi.edu>.
+;;;
+;;; This file 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 version 1.
+;;;
+;;; This file 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 details.
+;;;
+;;; 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.
+;;;
+
+;;;
+;;; bbdb-snarf is code to pick addresses, phones, and such out of a
+;;; free-form paragraphs. Things are recognized by context (web pages
+;;; start with http:// or www., for example). I wrote it because I
+;;; despise fill-in-the-blank forms (a la bbdb-create). (if I wanted
+;;; modes, I'd use vi :-).
+;;;
+;;; Eventually I'd like to be able to replace bbdb-mode with a free-form
+;;; text mode where bbdb-snarf merges in any changes you make.
+;;; I'm not there yet---merging is not good enough currently.
+;;; Currently bbdb-snarf is good for pulling postal addresses
+;;; from e-mail messages and converting other databases.
+;;;
+
+(require 'bbdb)
+(require 'bbdb-com)
+(require 'rfc822)
+(require 'mail-extr)
+
+(defconst bbdb-digit "[0-9]")
+(defvar bbdb-snarf-phone-regexp
+ (concat
+ "\\(([2-9][0-9][0-9])[-. ]?\\|[2-9][0-9][0-9][-. ]\\)?"
+ "[0-9][0-9][0-9][-. ][0-9][0-9][0-9][0-9]"
+ "\\( *\\(x\\|ext\\.?\\) *[0-9]+\\)?"
+ )
+ "regexp to match phones.")
+(defvar bbdb-snarf-zip-regexp
+ (concat
+ "\\<"
+ bbdb-digit bbdb-digit bbdb-digit bbdb-digit bbdb-digit
+ "\\(-" bbdb-digit bbdb-digit bbdb-digit bbdb-digit "\\)?"
+ "\\>$")
+ "regexp matching zip.")
+
+(defcustom bbdb-snarf-web-prop 'www
+ "What property bbdb should use for the web, or nil to not detect web URLs."
+ :group 'bbdb
+ :type 'symbol)
+
+(defun bbdb-snarf-address-lines ()
+ (let ((lines (bbdb-split (buffer-string) "\n")))
+ (if (>= bbdb-file-format 5) nil
+ (while (< (length lines) 3)
+ (setq lines (append lines (list nil))))
+ (if (> (length lines) 3)
+ (error "bbdb-snarf-address-lines: too many lines in address.")))
+ (delete-region (point-min) (point-max))
+ lines))
+
+(defun bbdb-snarf-make-address
+ (label address-lines city state zip country)
+ (if (>= bbdb-file-format 4)
+ (vector label address-lines city state zip country)
+ (if (>= bbdb-file-format 3)
+ (vector label address-lines city state zip)
+ (vector label
+ (nth 0 address-lines)
+ (nth 1 address-lines)
+ (nth 2 address-lines)
+ city state zip))))
+
+(defun bbdb-snarf-prune-empty-lines ()
+ (goto-char (point-min))
+ (while (re-search-forward "^[ \t]*\n" (point-max) t)
+ (replace-match "")))
+
+(defun delete-and-return-region (begin end)
+ (prog1
+ (buffer-substring begin end)
+ (delete-region begin end)))
+
+(defun bbdb-snarf-extract-label (default consume-p)
+ "Extract the label before the point, or return DEFAULT if no label.
+If CONSUME-P is set, delete the text, if found."
+ (interactive "sDefault label: ")
+ (let ((end (point-marker)))
+ (skip-chars-backward " \t")
+ (if (not (= (point) (point-min)))
+ (forward-char -1))
+ (if (looking-at ":")
+ (let* ((label-end (point))
+ (label (delete-and-return-region
+ (progn (skip-chars-backward "^\n,;") (point))
+ label-end)))
+ (delete-region (point) end)
+ label)
+ default)))
+
+(defun bbdb-snarf-parse-phone-number (phone)
+ "Fix the bogosity that is `bbdb-snarf-parse-phone-number'.
+It doesn't always return a normalized phone number.
+For (800) 555-1212 it returns a three element list."
+ (let ((try (bbdb-parse-phone-number phone)))
+ (if (= 3 (length try))
+ (nconc try '(0)))
+ try))
+
+;;;###autoload
+(defun bbdb-snarf (where)
+ "snarf up a bbdb record WHERE the point is.
+We assume things are line-broken and paragraph-bounded.
+The name comes first and other fields (address,
+phone, email, web pages) are recognized by context.
+
+Required context:
+ addresses end with \"City, State ZIP\" or \"City, State\"
+ phones match bbdb-snarf-phone-regexp
+ (currently US-style phones)
+ e-mail addresses have @'s in them
+ web sites are recognized by http:// or www.
+
+Address and phone context are currently US-specific;
+patches to internationalize these assumptions are welcome.
+
+\\[bbdb-snarf] is similar to \\[bbdb-whois-sentinel], but less specialized."
+ (interactive "d")
+ (bbdb-snarf-region
+ (progn (goto-char where) (forward-paragraph -1) (point))
+ (progn (forward-paragraph 1) (point))))
+
+;;;###autoload
+(defun bbdb-snarf-region (begin end)
+ "snarf up a bbdb record in the current region. See `bbdb-snarf' for
+more details."
+ (interactive "r")
+
+ (save-excursion
+ (let
+ ((buf (get-buffer-create " *BBDB snarf*"))
+ (text (buffer-substring-no-properties begin end))
+ phones nets web city state zip name address-lines
+ address-vector notes)
+ (set-buffer buf)
+ (erase-buffer)
+ (insert text)
+
+ ;; toss beginning and trailing space
+ (goto-char (point-min))
+ (while (re-search-forward "^[ \t]+" (point-max) t)
+ (replace-match ""))
+ (goto-char (point-min))
+ (while (re-search-forward "^\\s +$" (point-max) t)
+ (replace-match ""))
+
+ ;; first, pick out phone numbers
+ (goto-char (point-min))
+ (while (re-search-forward bbdb-snarf-phone-regexp (point-max) t)
+ (let (phone
+ (begin (match-beginning 0))
+ (end (match-end 0)))
+ (goto-char begin)
+ (forward-char -1)
+ (if (looking-at "[0-9A-Za-z]")
+ (goto-char end);; not really phone
+ (setq phone (bbdb-snarf-parse-phone-number
+ (delete-and-return-region begin end))
+ phones (append phones
+ (list (vconcat
+ (list (bbdb-snarf-extract-label
+ (bbdb-label-completion-default
+ 'phone) t))
+ phone)))))))
+
+ ;; next, web pages
+ (goto-char (point-min))
+ (if (and bbdb-snarf-web-prop
+ (re-search-forward "\\(http://\\|www\.\\)[^ \t\n]+"
+ (point-max) t))
+ (progn
+ (setq web (match-string 0)
+ notes (append notes (list (cons bbdb-snarf-web-prop web))))
+ (replace-match "")))
+
+ ;; next e-mail
+ (goto-char (point-min))
+ (while (re-search-forward "[^ \t\n<]+@[^ \t\n>]+" (point-max) t)
+ (setq nets (append nets (list (match-string 0))))
+ (replace-match ""))
+
+ (bbdb-snarf-prune-empty-lines)
+
+ ;; name
+ (goto-char (point-min))
+ ;; This check is horribly english-centric (I think)
+ (while (and (not (eobp)) (/= (char-syntax (char-after (point))) ?w))
+ (forward-line 1))
+ (if (re-search-forward "\\(\\sw\\|[ -\.,]\\)*\\sw" nil t)
+ (progn
+ (setq name (match-string 0))
+ (delete-region (match-beginning 0) (match-end 0))))
+
+ ;; address
+ (goto-char (point-min))
+ (cond
+ ;; city, state zip
+ ((re-search-forward bbdb-snarf-zip-regexp (point-max) t)
+ (save-excursion
+ (save-restriction
+ (let (mk)
+ (narrow-to-region (point-min) (match-end 0))
+ (goto-char (point-max))
+ ;; zip
+ (re-search-backward bbdb-snarf-zip-regexp (point-min) t)
+ (setq zip (bbdb-parse-zip-string (match-string 0)))
+ ;; state
+ (skip-chars-backward " \t")
+ (setq mk (point))
+ (skip-chars-backward "^ \t,")
+ (setq state (buffer-substring (point) mk))
+ ;; city
+ (skip-chars-backward " \t,")
+ (setq mk (point))
+ (beginning-of-line)
+ (setq city (buffer-substring (point) mk))
+ ;; toss it
+ (forward-char -1)
+ (delete-region (point) (point-max))
+ ;; address lines
+ (goto-char (point-min))
+ (setq address-lines (bbdb-snarf-address-lines)
+ address-vector (list (bbdb-snarf-make-address
+ (bbdb-label-completion-default
+ 'address)
+ address-lines
+ city
+ state
+ zip
+ "";; FIXME: snarf country
+ )))))))
+ ;; try for just city, state
+ ((re-search-forward "^\\(.*\\), \\([A-Z][A-Za-z]\\)$"
+ (point-max) t)
+ (save-excursion
+ (save-restriction
+ (setq city (match-string 1)
+ state (match-string 2))
+ (narrow-to-region (point-min) (match-end 0))
+ (goto-char (point-min))
+ (setq address-lines (bbdb-snarf-address-lines)
+ address-vector (list (bbdb-snarf-make-address
+ "address"
+ address-lines
+ city
+ state
+ 0
+ "";; FIXME: snarf country
+ ))))))
+ (t
+ (setq address-lines '(nil nil nil)
+ address-vector nil)))
+
+ ;; anything else -> notes
+ (bbdb-snarf-prune-empty-lines)
+ (if (/= (point-min) (point-max))
+ (setq notes (append notes (list (cons 'notes (buffer-string))))))
+
+ ;; debug
+ ; (goto-char (point-max))
+ ; (insert "\n\n"
+ ; "name: " name "\n"
+ ; "city: " city "\n"
+ ; "state: " state "\n"
+ ; "zip: " zip "\n")
+
+ (setq name (or name
+ (and nets (car (car (bbdb-rfc822-addresses (car nets)))))
+ "?"))
+
+ (bbdb-merge-interactively name
+ nil
+ nets
+ address-vector
+ phones
+ notes))))
+
+
+; (setq bbdb-snarf-test-cases "
+;
+; another test person
+; 1234 Gridley St.
+; Los Angeles, CA 91342
+; 555-1212
+; test@person.net
+; http://www.foo.bar/
+; other stuff about this person
+;
+; test person
+; 1234 Gridley St.
+; St. Los Angeles, CA 91342-1234
+; 555-1212
+; test@person.net
+;
+; x test person
+; 1234 Gridley St.
+; Los Angeles, California 91342-1234
+; 555-1212
+; test@person.net
+;
+; y test person
+; 1234 Gridley St.
+; Los Angeles, CA
+; 555-1212
+; test@person.net
+; "
+; "some test cases")
+
+
+
+(defun bbdb-merge-interactively (name company nets addrs phones notes)
+ "Interactively add a new record; arguments same as \\[bbdb-create-internal]."
+ (let*
+ ((f-l-name (bbdb-divide-name name))
+ (firstname (car f-l-name))
+ (lastname (nth 1 f-l-name))
+ (aka nil)
+ (new-record
+ (vector firstname lastname aka company phones addrs
+ (if (listp nets) nets (list nets)) notes
+ (make-vector bbdb-cache-length nil)))
+ (old-record (bbdb-search-simple name nets)))
+ (if old-record
+ (progn
+ (setq new-record (bbdb-merge-internally old-record new-record))
+ (bbdb-delete-record-internal old-record)))
+ ;; create new record
+ (bbdb-invoke-hook 'bbdb-create-hook new-record)
+ (bbdb-change-record new-record t)
+ (bbdb-hash-record new-record)
+ (bbdb-display-records (list new-record))))
+
+(defun bbdb-merge-internally (old-record new-record)
+ "Merge two records. NEW-RECORDS wins over OLD in cases of ties."
+ (if (and (null (bbdb-record-firstname new-record))
+ (bbdb-record-firstname old-record))
+ (bbdb-record-set-firstname new-record (bbdb-record-firstname old-record)))
+ (if (and (null (bbdb-record-lastname new-record))
+ (bbdb-record-lastname old-record))
+ (bbdb-record-set-lastname new-record (bbdb-record-lastname old-record)))
+ (if (and (null (bbdb-record-company new-record))
+ (bbdb-record-company old-record))
+ (bbdb-record-set-company new-record (bbdb-record-company old-record)))
+ ;; nets
+ (let ((old-nets (bbdb-record-net old-record))
+ (new-nets (bbdb-record-net new-record)))
+ (while old-nets
+ (if (not (member (car old-nets) new-nets))
+ (setq new-nets (append new-nets (list (car old-nets)))))
+ (setq old-nets (cdr old-nets)))
+ (bbdb-record-set-net new-record new-nets))
+ ;; addrs
+ (let ((old-addresses (bbdb-record-addresses old-record))
+ (new-addresses (bbdb-record-addresses new-record)))
+ (while old-addresses
+ (if (not (member (car old-addresses) new-addresses))
+ (setq new-addresses (append new-addresses (list (car old-addresses)))))
+ (setq old-addresses (cdr old-addresses)))
+ (bbdb-record-set-addresses new-record new-addresses))
+ ;; phones
+ (let ((old-phones (bbdb-record-phones old-record))
+ (new-phones (bbdb-record-phones new-record)))
+ (while old-phones
+ (if (not (member (car old-phones) new-phones))
+ (setq new-phones (append new-phones (list (car old-phones)))))
+ (setq old-phones (cdr old-phones)))
+ (bbdb-record-set-phones new-record new-phones))
+ ;; notes
+ (let ((old-notes (bbdb-record-raw-notes old-record))
+ (new-notes (bbdb-record-raw-notes new-record)))
+ (while old-notes
+ (if (not (member (car old-notes) new-notes))
+ (setq new-notes (append new-notes (list (car old-notes)))))
+ (setq old-notes (cdr old-notes)))
+ (bbdb-record-set-raw-notes new-record new-notes))
+ ;; return
+ new-record)
+
+;;----------------------------------------------------------------------------
+(defcustom bbdb-extract-address-component-regexps
+ '(
+ ;; "surname, firstname" <address> from Outlookers
+ ("\"\\([^\"]*\\)\"\\s-*<\\([^>]+\\)>"
+ (bbdb-clean-username (match-string 1 adstring)) 2)
+
+ ;; name <address>
+ ("\\([^<>,\t][^<>,]+[^<>, \t]\\)\\s-*<\\([^>]+\\)>"
+ 1 2)
+ ;; <address>
+ ("<\\([^>,]+\\)>" nil 1)
+ ;; address (name)
+ ("\\(\\b[^<\",()]+\\b\\)\\s-*(\\([^)]+\\))"
+ (car (mail-extract-address-components
+ (concat "\"" (match-string 2 adstring) "\"")))
+ 1)
+ ;; firstname.lastname@host
+ ("\\b\\(\\([^@ \t\n.]+\\.[^@ \t\n.]+\\)@[^@ \t\n]+\\)\\b"
+ (car (mail-extract-address-components
+ (concat "\"" (match-string 2 adstring) "\"")))
+ 1)
+ ;; user@host
+ ("\\b\\(\\([^@ \t\n]+\\)@[^@ \t\n]+\\)\\b"
+ nil 1)
+ ;; localaddress
+ ("\\b\\([^@ \t\n]+\\)\\b"
+ nil 1)
+ )
+ "*List of regexps matching headers.
+Each list element should have the form (REGEXP FULLNAME ADDRESS), where
+REGEXP matches the address while the actual address components should
+be a parenthesized expression.
+
+FULLNAME is a default string for addresses without full name or a
+number denoting parenthesized expression.
+ADDRESS is a number denoting the parenthesized expression matching the
+address.
+
+If FULLNAME or ADDRESS is a list it will be evaluated to return a
+string or nil. If its a function it will be called with the remaining
+address-string as argument."
+ :group 'bbdb-noticing-records
+ :type 'list)
+
+(defcustom bbdb-extract-address-component-ignore-regexp
+ "\\(\\(undisclosed\\|unlisted\\)[^,]*recipients\\)\\|no To-header on input"
+ "*A regexp matching addresses which should be ignored."
+ :group 'bbdb-noticing-records
+ :type 'string)
+
+(defcustom bbdb-extract-address-component-handler 'message
+ "*Specifies how `bbdb-extract-address-components' reports errors.
+
+A value of nil means ignore unparsable stuff and 'warn will report
+a warning, 'message will report a message in the minibuffer and all
+other value will fire a error.
+
+When set to a function it will be called with the remaining string in
+order to extract the address components and return the rest and the
+components as list or to do what ever it wants, e.g. send a complain
+to the author ...
+
+To skip known unparseable stuff you rather should set the variable
+`bbdb-extract-address-component-ignore-regexp' instead of disabling
+this handler."
+ :group 'bbdb-noticing-records
+ :type '(choice (const :tag "Ignore problems."
+ nil)
+ (const :tag "Warn about parsing problems."
+ 'warn)
+ (const :tag "Show a message about parsing problems."
+ 'message)
+ (function :tag "A user defined handler")))
+
+;;;###autoload
+(defun bbdb-extract-address-components (adstring &optional ignore-errors)
+ "Return a list of address components found in ADSTRING.
+If extracting fails one probably has to adjust the variable
+`bbdb-extract-address-component-regexps'."
+ (let ((case-fold-search t)
+ (fnadlist nil)
+ adcom-regexp
+ nomatch)
+
+ ;; Do some string cleanup and trimming
+ (setq adstring (bbdb-replace-in-string adstring "[\n\t]" " "))
+ (setq adstring (bbdb-replace-in-string adstring " " " "))
+ (setq adstring (bbdb-replace-in-string adstring "^ +" ""))
+
+ ;; scan the string
+ (while (not (string= "" adstring))
+ (setq adcom-regexp bbdb-extract-address-component-regexps
+ nomatch t)
+ (while adcom-regexp
+ (let ((regexp (caar adcom-regexp))
+ (fn (car (cdar adcom-regexp)))
+ (ad (cadr (cdar adcom-regexp))))
+ (cond ((string-match
+ (concat "^[^,]*\\("
+ bbdb-extract-address-component-ignore-regexp
+ "\\)[^,]*\\(,\\|$\\)")
+ adstring)
+ (setq adstring (substring adstring (match-end 0))
+ adcom-regexp nil
+ nomatch nil))
+ ((string-match (concat "^\\s-*" regexp "\\s-*\\(,\\|$\\)")
+ adstring)
+ (add-to-list 'fnadlist
+ (list (let ((n
+ (cond ((numberp fn)
+ (match-string fn adstring))
+ ((listp fn)
+ (save-match-data (eval fn)))
+ ((functionp fn)
+ (save-match-data
+ (funcall fn adstring)))
+ (t fn))))
+ (if (string= n "")
+ nil
+ n))
+ (let ((a
+ (cond ((numberp ad)
+ (match-string ad adstring))
+ ((listp ad)
+ (save-match-data (eval ad)))
+ ((functionp ad)
+ (save-match-data
+ (funcall ad adstring)))
+ (t ad))))
+ (if (string= a "")
+ nil
+ a))))
+; (save-match-data
+; (message "%S Match on %S to\n\t%S"
+; regexp adstring fnadlist))
+ (setq adstring (substring adstring (match-end 0))
+ adcom-regexp nil
+ nomatch nil)))
+ (setq adcom-regexp (cdr adcom-regexp))))
+
+ ;; Now handle problems
+ (if (and nomatch (not ignore-errors))
+ (cond ((equal bbdb-extract-address-component-handler nil))
+ ((equal bbdb-extract-address-component-handler 'warn)
+ (bbdb-warn "Cannot extract an address component at \"%s\".
+See `bbdb-extract-address-component-handler' for more information."
+ adstring))
+ ((equal bbdb-extract-address-component-handler 'message)
+ (message "Cannot extract an address component at \"%s\"."
+ adstring))
+ ((functionp bbdb-extract-address-component-handler)
+ (let ((result
+ (funcall bbdb-extract-address-component-handler
+ adstring)))
+ (if (and (listp result) (= 3 (length result)))
+ (progn (add-to-list 'fnadlist (cdr result))
+ (setq adstring (car result)
+ nomatch nil)))))
+ (t
+ (error "Cannot extract an address component at \"%30s\""
+ adstring))))
+
+ ;; ignore the bad junk
+ (if nomatch
+ (if (string-match "^[^,]*," adstring)
+ (setq adstring (substring adstring (match-end 0)))
+ (setq adstring ""))))
+
+ (delete '(nil nil) (nreverse fnadlist))))
+
+;;; alternative name parser
+;;;###autoload
+(defun bbdb-rfc822-addresses ( addrline &optional ignore-errors)
+ "Split ADDRLINE into a list of parsed addresses.
+
+You can't do this with rfc822.el in any sort of useful way because it discards
+the comments. You can't do this with mail-extr.el because the multiple address
+parsing in GNU Emacs appears to be broken beyond belief, and the XEmacs
+version doesn't support multiple addresses."
+ (let (addrs (start 0))
+ (setq addrline (concat addrline ",")) ;; kludge, to make parsing easier
+ ;; Addresses are separated by commas. This is probably the worst
+ ;; possible way to do this, but it does cut down on the amount of
+ ;; coding effort I have to duplicate. Basically, we split on
+ ;; commas, and then try and parse what we've found. Pathologically
+ ;; bad address lines will break this.
+ (while (string-match "\\([^,]+\\)," addrline start)
+ (let* ((thisaddr (substring addrline 0 (match-end 1)))
+ (comma (match-end 0)) ;; rfc822-addresses trashes match-data
+ (parsed (rfc822-addresses thisaddr)))
+ (if (string-match "(" (or (car parsed) "")) ;; rfc822 didn't like it.
+ (setq start comma)
+ (setq addrs
+ (append addrs (list
+ (mail-extract-address-components
+ thisaddr)))
+ ;; throw away what we just parsed
+ addrline (substring addrline comma)
+ start 0))))
+ addrs))
+
+(provide 'bbdb-snarf)
diff --git a/lisp/bbdb-srv.el b/lisp/bbdb-srv.el
new file mode 100644
index 0000000..d28235b
--- /dev/null
+++ b/lisp/bbdb-srv.el
@@ -0,0 +1,285 @@
+;;; -*- Mode:Emacs-Lisp -*-
+
+;;; This file is the part of the Insidious Big Brother Database (aka BBDB),
+;;; copyright (c) 1995 Jamie Zawinski <jwz@netscape.com>.
+;;; Invoking BBDB from another process, via `gnudoit'.
+;;; See the file bbdb.texinfo for documentation.
+;;;
+;;; 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 2, 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
+;;; details.
+;;;
+;;; 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.
+
+;;; This requires the `gnuserv' and `itimer' packages.
+;;;
+;;; To use:
+;;;
+;;; First, do `(gnuserv-start)' to initialize the emacs server process.
+;;; If you don't know what this does, see the doc for gnuserv.el.
+;;;
+;;; Then, an external process may invoke `gnudoit' in the following way:
+;;;
+;;; gnudoit '(bbdb-server "...all message headers..")'
+;;;
+;;; The bbdb-srv.perl program is a good choice for this; it takes a header
+;;; block on stdin, and converts them to a lisp string, taking care to
+;;; "sanitize" them so that hostile data can't take over the executing shell.
+;;;
+;;; The string should be a validly-formatted-and-quoted lisp string, and
+;;; should contain multiple lines, which are the headers of the message for
+;;; which a record should be displayed. It should contain at least a "From:"
+;;; header, or nothing will be displayed, but it should contain as many headers
+;;; as your various BBDB hooks might want access to.
+;;;
+;;; Records will not be displayed until no record has been requested for
+;;; `bbdb/srv-display-delay' seconds (default 2.) This is to prevent rapid
+;;; display of records from queueing up and swamping the emacs server process.
+;;;
+;;; Note that in order for this to build, itimer.el and gnuserv.el must be in
+;;; the build-path. The easiest way to achieve this is to set OTHERDIR to point
+;;; to the directory/ies they're in.
+
+;;; A trivial application of this is the shell command:
+;;;
+;;; echo 'From: Jamie Zawinski <jwz@netscape.com>' | bbdb-srv.perl
+;;;
+;;; which will cause the corresponding record to be displayed.
+;;; A more interesting application of this is:
+;;;
+;;; setenv NS_MSG_DISPLAY_HOOK bbdb-srv.perl
+;;;
+;;; which will hook BBDB up to Mozilla (Unix Netscape Mail and Netscape News
+;;; versions 3.0b2 and later only.)
+
+(require 'bbdb)
+(require 'bbdb-com)
+(require 'bbdb-hooks)
+
+
+(eval-when-compile
+ (require 'mail-utils) ;; for mail-strip-quoted-names
+ (require 'bbdb-gui) ;; for extents macros
+ (if (featurep 'xemacs)
+ ()
+ (fset 'set-keymap-name 'ignore)
+ (fset 'frame-lowest-window 'ignore)))
+
+;; newer version of gnuserv requires gnuserv-compat when using FSF emacs
+;; but you might be using an older version, and we can't tell until you
+;; crash it...
+(or (fboundp 'define-obsolete-variable-alias)
+ (if (locate-library "gnuserv-compat")
+ (require 'gnuserv-compat)))
+(require 'gnuserv)
+(require 'itimer)
+
+(defcustom bbdb/srv-auto-create-p nil
+ "*Like `bbdb/news-auto-create-p' and `bbdb/mail-auto-create-p',
+but for the case where the record is being displayed by some external
+process via the `gnudoit' mechanism.
+
+If this is t, then records will automatically be created; if this is a
+function name or lambda, then it is called with no arguments to decide
+whether an entry should be automatically created. You can use this to,
+for example, create or not create messages which have a particular subject.
+
+`bbdb/srv-auto-create-mail-news-dispatcher' is a good value for this --
+that function will try to decide if this is a mail message or a news
+message, and then run either `bbdb/news-auto-create-p' or
+`bbdb/mail-auto-create-p' as appropriate."
+ :group 'bbdb-utilities-server
+ :type '(choice (const :tag "Don't automatically create records" nil)
+ (const :tag "Automatically create records" t)
+ (sexp :tag "Use function to determine record creation"
+ bbdb/srv-auto-create-mail-news-dispatcher)))
+
+(defcustom bbdb/srv-display-delay 2
+ "*How long (in seconds) we must be idle before displaying a record."
+ :group 'bbdb-utilities-server
+ :type 'integer)
+
+(defvar bbdb/srv-pending-headers nil)
+(defvar bbdb/srv-pending-map
+ (and (fboundp 'bbdb-set-extent-property)
+ (condition-case nil
+ (let ((m (make-sparse-keymap)))
+ (set-keymap-name m 'bbdb/srv-pending-map)
+ (define-key m 'button1 'bbdb/srv-pending-add)
+ m)
+ (error nil))))
+
+(defun bbdb/srv-handle-headers (headers &optional create-p)
+ "Display (or create) the BBDB entry corresponding to the message headers.
+HEADERS should be a string containing an RFC822 header block; at least a
+\"From:\" header should be provided, but others will be made available to
+the various hooks (like `bbdb-notice-hook' and `bbdb/news-auto-create-p')."
+ (let ((buf "*bbdb-tmp*")
+ (record nil)
+ (bbdb-force-dialog-boxes t) ; affects bbdb-y-or-n-p
+ from)
+ (save-excursion
+ (set-buffer (or (get-buffer buf)
+ (progn
+ (setq buf (get-buffer-create buf))
+ (set-buffer buf)
+ (buffer-disable-undo buf)
+ buf)))
+ (erase-buffer)
+ (insert headers "\n\n")
+ (setq from (mail-fetch-field "from"))
+ (if (or (null from)
+ (string-match (bbdb-user-mail-names)
+ (mail-strip-quoted-names from)))
+ ;; if logged-in user sent this, use recipients.
+ (setq from (or (mail-fetch-field "to") from)))
+ (if from
+ (setq record
+ (bbdb-annotate-message-sender from t
+ (or create-p
+ (bbdb-invoke-hook-for-value
+ bbdb/srv-auto-create-p))
+ nil))))
+ (let ((w (get-buffer-window bbdb-buffer-name)))
+ (if w
+ nil
+ (setq w (selected-window))
+ (unwind-protect
+ (progn
+ (if (fboundp 'frame-lowest-window)
+ (select-window (frame-lowest-window)))
+ (bbdb-pop-up-bbdb-buffer))
+ (select-window w))
+ (setq w (get-buffer-window bbdb-buffer-name))
+ (if (fboundp 'set-window-dedicated-p)
+ (set-window-dedicated-p w bbdb-buffer-name))))
+ (cond (record
+ (let ((bbdb-gag-messages t)
+ (bbdb-use-pop-up nil)
+ (bbdb-electric-p nil)
+ (b (current-buffer)))
+ (save-window-excursion ;; needed to get around XEmacs 19.15 bug?
+ (bbdb-display-records (list record)) bbdb-pop-up-display-layout)
+ (set-buffer b)))
+ ((and from (not create-p) bbdb/srv-pending-map)
+ (setq bbdb/srv-pending-headers headers)
+ (save-excursion
+ (set-buffer bbdb-buffer-name)
+ (let ((buffer-read-only nil))
+ (erase-buffer)
+ (insert "\t\t\t")
+ (let ((p (point))
+ e)
+ (insert from)
+ (setq e (bbdb-make-extent p (point)))
+ (bbdb-set-extent-face e 'bold)
+ (bbdb-set-extent-property e 'highlight t)
+ (bbdb-set-extent-property e 'keymap bbdb/srv-pending-map)
+ )
+ (insert "\n\n\t\t\tClick to add to BBDB.")
+ ))))))
+
+(defun bbdb/srv-pending-add ()
+ (interactive "@")
+ (or bbdb/srv-pending-headers (error "lost headers?"))
+ (bbdb/srv-handle-headers bbdb/srv-pending-headers t))
+
+
+(defvar bbdb/srv-itimer-arg nil)
+(defun bbdb/srv-itimer ()
+ "Used as a timer function by bbdb/srv-handle-headers-with-delay.
+This invokes bbdb/srv-handle-headers with bbdb/srv-itimer-arg.
+We do it this way instead of by using a lambda to start-itimer so that
+we cons less."
+ (defvar current-itimer)
+ (if current-itimer (delete-itimer current-itimer))
+ (if bbdb/srv-itimer-arg
+ (bbdb/srv-handle-headers
+ (prog1 bbdb/srv-itimer-arg
+ (setq bbdb/srv-itimer-arg nil)))))
+
+;;;###autoload
+(defun bbdb/srv-handle-headers-with-delay (headers)
+ "Just like bbdb/srv-handle-headers, but only updates every few seconds.
+This is so that trying to display many records in succession won't queue them
+up, but will end up only displaying a record when no displays have been
+requested for a couple of seconds."
+ (let* ((name "bbdb-srv")
+ (itimer (get-itimer name)))
+ (setq bbdb/srv-itimer-arg headers)
+ (if itimer
+ ;; It hasn't gone off yet; just change what it's argument will be.
+ nil
+ ;; else, start the timer going again.
+ (start-itimer name 'bbdb/srv-itimer bbdb/srv-display-delay nil))
+ nil))
+
+;;;###autoload
+(defalias 'bbdb-srv 'bbdb/srv-handle-headers-with-delay)
+
+(autoload 'bbdb-header-start "bbdb-hooks")
+
+;;;###autoload
+(defun bbdb/srv-auto-create-mail-news-dispatcher ()
+ "For use as the value of bbdb/srv-auto-create-p.
+This will try to decide if this is a mail message or a news message, and then
+run either bbdb/news-auto-create-p or bbdb/mail-auto-create-p as appropriate.
+\(The heuristic is that news messages never have a Status or X-Mozilla-Status
+header; and that mail messages never have Path headers.)"
+ (let (mail-p)
+ (save-excursion
+ (let ((start (bbdb-header-start)))
+ (set-buffer (marker-buffer start))
+ (setq mail-p
+ (cond ((progn (goto-char start)
+ (bbdb-extract-field-value "Status"))
+ t)
+ ((progn (goto-char start)
+ (bbdb-extract-field-value "X-Mozilla-Status"))
+ t)
+ ((progn (goto-char start)
+ (bbdb-extract-field-value "Path"))
+ nil)
+ (t t))))) ; can't tell -- guess mail.
+ (bbdb-invoke-hook-for-value
+ (if mail-p bbdb/mail-auto-create-p bbdb/news-auto-create-p))))
+
+
+;; For caller-id stuff
+;;;###autoload
+(defun bbdb-srv-add-phone (phone-string &optional description record)
+ (let ((phone (make-vector (if bbdb-north-american-phone-numbers-p
+ bbdb-phone-length
+ 2)
+ nil)))
+ (setq record (if (stringp record)
+ (or (bbdb-search-simple record "")
+ (bbdb-create-internal record nil nil nil nil nil))
+ (bbdb-completing-read-record
+ (format "Add %s to: " phone-string))))
+ (if (= 2 (length phone))
+ (aset phone 1 phone-string)
+ (let ((newp (bbdb-parse-phone-number phone-string)))
+ (bbdb-phone-set-area phone (nth 0 newp))
+ (bbdb-phone-set-exchange phone (nth 1 newp))
+ (bbdb-phone-set-suffix phone (nth 2 newp))
+ (bbdb-phone-set-extension phone (or (nth 3 newp) 0))))
+ (bbdb-phone-set-location phone
+ (or description
+ (read-string "Phone number description: "
+ "cid")))
+ (bbdb-record-set-phones record
+ (nconc (bbdb-record-phones record) (list phone)))
+ (bbdb-change-record record nil)
+ (bbdb-display-records (list record))
+ record))
+
+(provide 'bbdb-srv)
diff --git a/lisp/bbdb-vm.el b/lisp/bbdb-vm.el
new file mode 100644
index 0000000..9ef279a
--- /dev/null
+++ b/lisp/bbdb-vm.el
@@ -0,0 +1,426 @@
+;;; -*- Mode:Emacs-Lisp -*-
+
+;;; This file is the part of the Insidious Big Brother Database (aka BBDB),
+;;; copyright (c) 1991, 1992, 1993 Jamie Zawinski <jwz@netscape.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
+;;; details.
+;;;
+;;; 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.
+
+(eval-and-compile
+ (require 'cl)
+ (require 'bbdb)
+ (require 'bbdb-com)
+ (require 'bbdb-snarf)
+ (require 'vm-version)
+ (require 'vm-macro)
+ (require 'vm-message)
+ (require 'vm-misc)
+ (require 'vm-undo)
+ (require 'vm-motion)
+ (require 'vm-summary)
+ (require 'vm-vars)
+ (require 'vm-folder)
+ (require 'vm-mime))
+
+(defun bbdb/vm-get-header-content (header-field msg)
+ (let ((content (vm-get-header-contents msg (concat header-field ":"))))
+ (if content
+ (vm-decode-mime-encoded-words-in-string content))))
+
+(defcustom bbdb/vm-update-records-mode
+; '(if (vm-new-flag msg) 'annotating 'searching)
+ 'annotating
+ "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."
+ :group 'bbdb-mua-specific-vm
+ :type '(choice (const :tag "annotating all messages"
+ annotating)
+ (const :tag "annotating no messages"
+ searching)
+ (const :tag "annotating only new messages"
+ (if (vm-new-flag msg) 'annotating 'searching))
+ (sexp :tag "user defined")))
+
+;;;###autoload
+(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)))
+
+;;;###autoload
+(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."
+ (vm-select-folder-buffer)
+ (vm-check-for-killed-summary)
+ (vm-error-if-folder-empty)
+ (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!
+ (bbdb/vm-offer-to-create offer-to-create)
+ cache records)
+
+ ;; 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))))
+
+ (if cache
+ (setq records (if bbdb-get-only-first-address-p
+ (list (car cache))
+ cache))
+
+ (let ((bbdb-update-records-mode (or bbdb/vm-update-records-mode
+ bbdb-update-records-mode)))
+ (setq records (bbdb-update-records
+ (bbdb-get-addresses bbdb-get-only-first-address-p
+ vm-summary-uninteresting-senders
+ 'bbdb/vm-get-header-content
+ (vm-real-message-of msg))
+ bbdb/mail-auto-create-p
+ offer-to-create))
+
+ (bbdb-encache-message msg records)))
+ records))
+
+;;;###autoload
+(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)."
+ (interactive
+ (list (if bbdb-readonly-p
+ (error "The Insidious Big Brother Database is read-only.")
+ (read-string "Comments: "))))
+ (vm-follow-summary-cursor)
+ (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."
+ (interactive "P")
+ (vm-follow-summary-cursor)
+ (let ((record (or (bbdb/vm-update-record t) (error "unperson"))))
+ (bbdb-display-records (list record))
+ (if arg
+ (bbdb-record-edit-property record nil t)
+ (bbdb-record-edit-notes record t))))
+
+;;;###autoload
+(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."
+ (interactive)
+ (vm-follow-summary-cursor)
+ (let ((bbdb-get-addresses-headers
+ (if address-class
+ (list (assoc address-class bbdb-get-addresses-headers))
+ bbdb-get-addresses-headers))
+ (bbdb/vm-update-records-mode 'annotating)
+ (bbdb-message-cache nil)
+ ;; should we move this to bbdb/vm-show-sender?
+ (bbdb-user-mail-names nil)
+ (vm-summary-uninteresting-senders nil)
+ records)
+ (setq records (bbdb/vm-update-records t))
+ (if records
+ (bbdb-display-records records)
+ (bbdb-undisplay-records))
+ records))
+
+;;;###autoload
+(defun bbdb/vm-show-all-recipients ()
+ "Show all recipients of this message. Counterpart to `bbdb/vm-show-sender'."
+ (interactive)
+ (let ((bbdb-get-only-first-address-p nil))
+ (bbdb/vm-show-records 'recipients)))
+
+;;;###autoload
+(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."
+ (interactive "p")
+ (cond ((= 4 show-recipients)
+ (bbdb/vm-show-all-recipients))
+ ((= 16 show-recipients)
+ (let ((bbdb-get-only-first-address-p nil))
+ (bbdb/vm-show-records)))
+ (t
+ (if (null (bbdb/vm-show-records 'authors))
+ (bbdb/vm-show-all-recipients)))))
+
+(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-get-addresses-headers' and 'bbdb-get-only-first-address-p' for
+configuration of what is being displayed."
+ (save-excursion
+ (let ((bbdb-gag-messages t)
+ (bbdb-electric-p nil)
+ (records (bbdb/vm-update-records offer-to-create))
+ (bbdb-buffer-name bbdb-buffer-name))
+
+ (when (and bbdb-use-pop-up records)
+ (bbdb-pop-up-bbdb-buffer
+ (function (lambda (w)
+ (let ((b (current-buffer)))
+ (set-buffer (window-buffer w))
+ (prog1 (member major-mode '(vm-mode vm-presentation-mode))
+ (set-buffer b))))))
+
+ ;; 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)
+ (bbdb-undisplay-records)
+ (if (get-buffer-window bbdb-buffer-name)
+ (delete-window (get-buffer-window bbdb-buffer-name)))))))
+
+
+;; By Alastair Burt <burt@dfki.uni-kl.de>
+;; 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.
+Respects vm-summary-uninteresting-senders."
+ (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))
+ (concat vm-summary-uninteresting-senders-arrow
+ (vm-summary-function-B m t))
+ (or (bbdb/vm-alternate-full-name (vm-su-from m))
+ (vm-su-full-name m))))
+ (or (bbdb/vm-alternate-full-name (if to-p (vm-su-to m) (vm-su-from m)))
+ (vm-decode-mime-encoded-words-in-string
+ (if to-p (vm-su-to-names m) (vm-su-full-name m))))))
+
+(defun bbdb/vm-alternate-full-name (address)
+ (if address
+ (let ((entry (bbdb-search-simple
+ nil
+ (if (and address bbdb-canonicalize-net-hook)
+ (bbdb-canonicalize-address address)
+ address))))
+ (if entry
+ (or (bbdb-record-getprop entry 'mail-name)
+ (bbdb-record-name entry))))))
+
+
+;; From: Mark Thomas <mthomas@jprc.com>
+;; Subject: auto-folder-alist from bbdb
+
+;;;###autoload
+(defcustom bbdb/vm-set-auto-folder-alist-field 'vm-folder
+ "*The field which `bbdb/vm-set-auto-folder-alist' searches for."
+ :group 'bbdb-mua-specific-vm
+ :type 'symbol)
+
+;;;###autoload
+(defcustom bbdb/vm-set-auto-folder-alist-headers '("From:" "To:" "CC:")
+ "*The headers used by `bbdb/vm-set-auto-folder-alist'.
+The order in this list is the order how matching will be performed!"
+ :group 'bbdb-mua-specific-vm
+ :type '(repeat (string :tag "header name")))
+
+;;;###autoload
+(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
+element (email-regexp . folder) to the `vm-auto-folder-alist'.
+
+The element gets added to the 'element-name' sublist of the
+`vm-auto-folder-alist'.
+
+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
+vm-folder attribute.
+
+If the first character of vm-folders value is a quote ' it will be
+parsed as lisp expression and is evaluated to return a folder name,
+e.g. define you own function `my-folder-name' and set it to
+ '(my-folder-name)"
+ (interactive)
+ (let* (;; we add the email-address/vm-folder-name pair to this
+ ;; sublist of the vm-auto-folder-alist variable
+ (headers (reverse bbdb/vm-set-auto-folder-alist-headers))
+ header
+ ;; grab the folder list from the vm-auto-folder-alist
+ folder-list
+ ;; the raw-notes and vm-folder attributes of the current bbdb
+ ;; record
+ notes-field folder
+ ;; a regexp matching all the email addresses from the bbdb
+ ;; record
+ email-regexp
+ ;;
+ records)
+
+ (setq records
+ (delete
+ nil
+ (mapcar (lambda (r)
+ (if (bbdb-record-getprop r bbdb/vm-set-auto-folder-alist-field)
+ r))
+ (bbdb-records))))
+
+ (while headers
+ (setq header (car headers) headers (cdr headers))
+ ;; create the folder-list in vm-auto-folder-alist if it doesn't exist
+ (setq folder-list (assoc header vm-auto-folder-alist))
+ (unless folder-list
+ (setq vm-auto-folder-alist (cons (list header)
+ vm-auto-folder-alist)
+ folder-list (assoc header vm-auto-folder-alist)))
+ (mapcar
+ (lambda (r)
+ (setq notes-field (bbdb-record-raw-notes r))
+ (when (and (listp notes-field)
+ (setq folder (cdr (assq bbdb/vm-set-auto-folder-alist-field
+ notes-field))))
+ ;; quote all the email addresses for the record and join them
+ ;; with OR
+ (setq email-regexp (regexp-opt (bbdb-record-net r)))
+ (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 (substring folder 1))))
+ (nconc folder-list (list (cons email-regexp folder))))))
+ records))))
+
+
+;;; bbdb/vm-auto-add-label
+;;; 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."
+ :group 'bbdb-mua-specific-vm
+ :type 'list)
+
+(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'."
+ :group 'bbdb-mua-specific-vm
+ :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)
+ (mapcar #'(lambda(x)
+ (and
+ (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)
+ bbdb/vm-auto-add-label-field)
+ ((symbolp bbdb/vm-auto-add-label-field)
+ (list bbdb/vm-auto-add-label-field))
+ (t (error "Bad value for bbdb/vm-auto-add-label-field"))
+ ))
+ (vm-add-message-labels
+ (mapconcat #'(lambda (l)
+ (cond ((stringp l)
+ (if (member l aliases)
+ l))
+ ((and (consp l)
+ (stringp (car l))
+ (stringp (cdr l)))
+ (if (member (car l) aliases)
+ (cdr l)))
+ (t
+ (error "Malformed bbdb/vm-auto-add-label-list")
+ )))
+ bbdb/vm-auto-add-label-list
+ " ")
+ 1))))
+
+
+;;; 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."
+ (interactive)
+ (let ((bbdb/mail-auto-create-p t)
+ (bbdb-message-caching-enabled nil))
+ (save-excursion
+ (vm-select-folder-buffer)
+ (bbdb/vm-pop-up-bbdb-buffer))))
+
+
+;;;###autoload
+(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))
+ (t
+ (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)))
+
+(provide 'bbdb-vm)
diff --git a/lisp/bbdb-w3.el b/lisp/bbdb-w3.el
new file mode 100644
index 0000000..4c9c8d4
--- /dev/null
+++ b/lisp/bbdb-w3.el
@@ -0,0 +1,61 @@
+;;; This file is part of the Insidious Big Brother Database (aka BBDB),
+;;; copyright (c) 1991, 1992, 1993 Jamie Zawinski <jwz@netscape.com>.
+;;; WWW-related functions for the BBDB. 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 2 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
+;;; details.
+;;;
+;;; 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.
+
+(require 'bbdb-com)
+(require 'browse-url)
+
+(defvar w3-mode-map)
+(eval-when-compile
+ (condition-case() (require 'url) (error (fset 'url-view-url 'ignore))))
+
+;;;###autoload
+(defun bbdb-www (rec &optional which)
+ "Visit URLs stored in the `www' field of the current record.
+\\[bbdb-apply-next-command-to-all-records]\\[bbdb-www] \
+means to try all records currently visible.
+Non-interactively, do all records if arg is nonnil."
+ (interactive (list (bbdb-get-record "Visit (WWW): ")
+ (or current-prefix-arg 0)))
+ (browse-url (read-string "fetch: "
+ (or (bbdb-get-field rec 'www which)
+ (bbdb-get-field rec 'ftp which)))))
+
+;;;###autoload
+(defun bbdb-www-grab-homepage (record)
+ "Grab the current URL and store it in the bbdb database"
+ (interactive (list (bbdb-completing-read-one-record
+ "Add WWW homepage for: ")))
+ ;; if there is no database record for this person, create one
+ (unless record
+ (setq record (bbdb-read-new-record))
+ (bbdb-invoke-hook 'bbdb-create-hook record))
+ (if (bbdb-record-getprop record 'www)
+ (bbdb-record-putprop
+ record 'www
+ (concat (bbdb-record-getprop record 'www) "," (url-view-url t)))
+ (bbdb-record-putprop record 'www (url-view-url t)))
+ (bbdb-change-record record t)
+ (bbdb-display-records (list record)))
+
+;;;###autoload
+(defun bbdb-insinuate-w3 ()
+ "Call this function to hook BBDB into W3."
+ (add-hook 'w3-mode-hook
+ (lambda () (define-key w3-mode-map ":" 'bbdb-www-grab-homepage))))
+
+(provide 'bbdb-w3)
diff --git a/lisp/bbdb-whois.el b/lisp/bbdb-whois.el
new file mode 100644
index 0000000..af4c34d
--- /dev/null
+++ b/lisp/bbdb-whois.el
@@ -0,0 +1,264 @@
+;;; bbdb-whois.el -- Big Brother gets a little help from Big Brother
+;;; This file is part of the Insidious Big Brother Database (aka BBDB).
+;;;
+;;; Copyright (C) 1992, 1993 Roland McGrath
+;;;
+;;; This program 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 2, or (at your option)
+;;; any later version.
+;;;
+;;; This program 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 details.
+;;;
+;;; A copy of the GNU General Public License can be obtained from this
+;;; program's author (send electronic mail to roland@gnu.ai.mit.edu) or
+;;; from the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA
+;;; 02139, USA.
+;;;
+;;; Send bug reports to bbdb@waider.ie
+
+(require 'bbdb-com)
+
+(defmacro bbdb-add-to-field (record field text)
+ (let ((get (intern (concat "bbdb-record-" (symbol-name field))))
+ (set (intern (concat "bbdb-record-set-" (symbol-name field)))))
+ `(let ((old (,get ,record))
+ (text ,text))
+ (or (member text old)
+ (,set ,record (nconc old (list text)))))))
+
+(defcustom bbdb-whois-server (or (and (boundp 'whois-server) whois-server)
+ "whois.geektools.com")
+ "*Server for \\[bbdb-whois] lookups."
+ :group 'bbdb-utilities
+ :type 'string)
+
+(defvar bbdb-whois-name nil
+ "Used to store the name during a whois call.")
+(make-variable-buffer-local 'bbdb-whois-name)
+(defvar bbdb-whois-record nil
+ "Used to store the record during a whois call.")
+(make-variable-buffer-local 'bbdb-whois-record)
+
+;;; main entry point. it'd be nice if we could bbdb-whois an arbitrary
+;;; name and make a record from that directly.
+
+;;;###autoload
+(defun bbdb-whois (the-record &optional server)
+ (interactive (list (bbdb-get-record "BBDB Whois: ")
+ (and current-prefix-arg
+ (read-string "Query whois server: "
+ bbdb-whois-server))))
+ (or server (setq server bbdb-whois-server))
+ (if (or (bbdb-record-lastname the-record) (bbdb-record-firstname the-record))
+ ;; XXX we seem to get called with a vector of nils.
+ (save-excursion
+ (set-buffer (generate-new-buffer " *bbdb-whois*"))
+ (set bbdb-whois-record the-record)
+ (set bbdb-whois-name
+ (if (bbdb-record-getprop the-record 'nic)
+ (concat "!" (bbdb-record-getprop the-record 'nic))
+ (concat (bbdb-record-lastname the-record) ", "
+ (bbdb-record-firstname the-record))))
+ (let ((proc (open-network-stream "whois" (current-buffer) server 43)))
+ (set-process-sentinel proc 'bbdb-whois-sentinel)
+ (process-send-string proc (concat bbdb-whois-name "\r\n"))))))
+
+;;; This function parses the results from the server.
+(defun bbdb-whois-sentinel (proc status)
+ (save-excursion
+ (let (rec)
+ (set-buffer (process-buffer proc))
+ (setq rec bbdb-whois-record)
+ (goto-char 1)
+
+ ;; check for multiple replies
+ ;; should maybe present a menu/completion buffer of multiples and do a
+ ;; refetch.
+ (if (not (re-search-forward "Record last updated" (point-max) t))
+ (if (re-search-forward "No match" (point-max) t)
+ (message "Can not find a whois record for `%s'" bbdb-whois-name)
+ (if (re-search-forward "Access Limit Exceeded" (point-max) t)
+ (message "Per-day access limit to %s exceeded."
+ bbdb-whois-server) ;; bah!
+ (message "%s is ambiguous to whois; try a different name"
+ bbdb-whois-name)))
+
+ ;; clean up & parse buffer, otherwise.
+ (while (re-search-forward "\r\n" (point-max) t)
+ (replace-match "\n"))
+ (goto-char 1)
+ (if (re-search-forward
+ (concat (if (string-match "^!" bbdb-whois-name)
+ (concat "(\\("
+ (regexp-quote (substring bbdb-whois-name 1))
+ "\\))")
+ (concat (regexp-quote bbdb-whois-name)
+ ".*(\\([A-Z0-9]+\\))"))
+ "\\s *\\(\\S +@\\S +\\)?$")
+ nil t)
+ (let ((net (if (match-beginning 2)
+ (downcase (buffer-substring (match-beginning 2)
+ (match-end 2)))))
+ (nic (buffer-substring (match-beginning 1) (match-end 1)))
+ (lines nil))
+ (if net
+ (bbdb-add-to-field rec net net))
+ (bbdb-record-putprop rec 'nic nic)
+
+ ;; Snarf company.
+ ;; not all nic records have companies, though.
+ (forward-line 1)
+ (back-to-indentation)
+ (let ((company (buffer-substring (point) (progn (end-of-line)
+ (point))))
+ (old (bbdb-record-company rec)))
+ (cond ((not old)
+ (bbdb-record-set-company rec company))
+ ((string= old company)
+ nil)
+ (t
+ (bbdb-record-putprop rec 'nic-organization company))))
+
+ ;; Read the address info into LINES.
+ (while (progn (forward-line 1)
+ (not (looking-at "^$")))
+ (back-to-indentation)
+ (setq lines (cons (buffer-substring (point)
+ (progn (end-of-line)
+ (point)))
+ lines)))
+
+ ;; Snarf phone number.
+ ;; phone, fax are presented, it seems, as
+ ;; +country area prefix number +country area prefix number
+ ;; we can look for the " +" and split there, I guess.
+ (if (car lines)
+ (let ((phones (car lines))
+ (n 1)
+ phone-numbers)
+ (while (string-match "^\\(.+\\) \\+" phones)
+ (setq phone-numbers
+ (append phone-numbers
+ (list (substring phones 0 (match-end 1))))
+ phones (substring phones (+ 1 (match-end 1)))))
+ (setq phone-numbers (append phone-numbers
+ (list phones)))
+
+ ;; now add each member of the list to the bbdb record
+ ;; it'd be nice if we could be smarter about this.
+ (mapc (function
+ (lambda(p)
+ (if (not (bbdb-find-phone
+ p (bbdb-record-phones rec)))
+ (let ((p-n
+ (vector (format "nic-phone-%d" n) p)))
+ (bbdb-add-to-field rec phones p-n)
+ (setq n (+ 1 n))))))
+ phone-numbers)
+
+ ;; throw away phones line from what we've snarfed
+ (setq lines (cdr lines))))
+
+ ;; Snarf address.
+ (if (car lines)
+ (let ((addr (make-vector bbdb-address-length nil))
+ (city "")
+ (state "")
+ (zip "")
+ (country ""))
+
+ ;; extract country
+ (if (string-match "^[A-Z][A-Z]$" (car lines))
+ (setq country (car lines) ;; could convert from ISO...
+ lines (cdr lines)))
+
+ ;; extract city, state, zip
+ ;; it would be nice if this could all use bbdb-snarf.
+ ;; or if NICs would hand out something machine
+ ;; readable, like <shudder> XML.
+ ;;
+ ;; note the zipcode check at the end of the regexp
+ ;; isn't really a zipcode check, because we don't do
+ ;; zipcode checks any more.
+ (if (string-match
+ "\\([^,]+\\),\\s *\\(\\S +\\)\\s *\\(.+\\)"
+ (car lines))
+ (setq city (substring (car lines)
+ (match-beginning 1)
+ (match-end 1))
+ state (substring (car lines)
+ (match-beginning 2)
+ (match-end 2))
+ zip (substring (car lines)
+ (match-beginning 3)
+ (match-end 3))
+ lines (cdr lines))
+ ;; otherwise we just stuff everything into the
+ ;; streets list and let the user clean it up. This
+ ;; would be nice to do heuristically, if I knew
+ ;; enough about variable address formats.
+ ;; (bbdb-snarf-grok-address (ADDR)) would be neat.
+ )
+
+ (bbdb-address-set-location addr "nic-address")
+ (bbdb-address-set-city addr (or city ""))
+ (bbdb-address-set-state addr (or state ""))
+ (bbdb-address-set-zip addr (or zip ""))
+ (bbdb-address-set-country addr (or country ""))
+ (setq lines (nreverse lines))
+ (bbdb-address-set-streets addr lines)
+
+ ;; should probably overwrite existing nic-address field.
+ (bbdb-add-to-field rec addresses addr)))
+
+ ;; Snarf any random notes.
+ (setq lines nil)
+ (while (progn
+ (forward-line 1)
+ (back-to-indentation)
+ (not (looking-at
+ "$\\|Record last updated on")))
+ (if (looking-at "Alternate mailbox: \\(\\S +\\)$")
+ (bbdb-add-to-field rec net
+ (buffer-substring (match-beginning 1)
+ (match-end 1)))
+ (setq lines (cons (buffer-substring (point)
+ (progn (end-of-line)
+ (point)))
+ lines))))
+ (if lines
+ (bbdb-record-putprop rec 'nic-notes
+ (mapconcat 'identity
+ (nreverse lines)
+ "\n")))
+
+ ;; Snarf the last-update date.
+ (if (re-search-forward "Record last updated on \\(\\S *\\)\\."
+ nil t)
+ (bbdb-record-putprop rec 'nic-updated
+ (buffer-substring (match-beginning 1)
+ (match-end 1))))
+
+ (save-excursion
+ (set-buffer bbdb-buffer-name)
+ (bbdb-redisplay-one-record rec)))
+ (message "No whois information for %s" bbdb-whois-name)))
+ (delete-process proc)
+ (kill-buffer (current-buffer)))))
+
+(defun bbdb-find-phone (string record)
+ "Return the vector entry if STRING is a phone number listed in RECORD."
+ (let ((phone nil)
+ (done nil))
+ (while (and record (not done))
+ (setq phone (car record))
+ (if (string= string (bbdb-phone-string phone))
+ (setq done phone))
+ (setq record (cdr record)))
+ done))
+
+(provide 'bbdb-whois)
diff --git a/lisp/bbdb-xemacs.el b/lisp/bbdb-xemacs.el
new file mode 100644
index 0000000..d828201
--- /dev/null
+++ b/lisp/bbdb-xemacs.el
@@ -0,0 +1,114 @@
+;;; -*- Mode:Emacs-Lisp -*-
+;;; This file contains some XEmacs-specific stuff for BBDB.
+
+;;; This file is the part of the Insidious Big Brother Database (aka BBDB),
+;;; copyright (c) 1992, 1993, 1994 Jamie Zawinski <jwz@netscape.com>.
+
+;;; 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 2, 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
+;;; details.
+;;;
+;;; 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.
+
+;;; This code is kind of kludgey, mostly because it needs to parse the contents
+;;; of the *BBDB* buffer, since BBDB doesn't save the buffer-positions of the
+;;; various fields when it fills in that buffer (doing that would be slow and
+;;; cons a lot, so it doesn't seem to be worth it.)
+
+(eval-and-compile
+ (if (not (featurep 'xemacs))
+ (error "This file only works in XEmacs.")))
+
+;; this makes no sense, long-term, but.
+(eval-when-compile
+ (or (featurep 'xemacs)
+ (fset 'load-sound-file 'ignore)))
+
+(require 'bbdb)
+(require 'bbdb-com)
+(require 'bbdb-gui) ;; load in the menu/font stuff
+
+;; Utility functions that mask others to provide XEmacs-specific functionality
+;;;###autoload
+(defun bbdb-xemacs-display-completion-list (list &optional callback data)
+ "Wrapper for `display-completion-list'.
+Allows callbacks on XEmacs `display-completion-list' is called with
+`:activate-callback CALLBACK' if CALLBACK is non-nil.
+`:user-data DATA' is also used if DATA is non-nil.
+Neither are used if CALLBACK is nil."
+ (cond ((and callback data)
+ (display-completion-list list
+ :activate-callback callback
+ :user-data data))
+ (callback
+ (display-completion-list list
+ :activate-callback callback))
+ (t
+ (display-completion-list list))))
+
+
+;; For native Xemacs sound support we can use these ...
+;;;###autoload
+(defcustom bbdb-sounds-directory (expand-file-name "~/.xemacs/etc/sounds")
+ "The directory to load the touchtone sound files from, or nil if none."
+ :group 'bbdb-phone-dialing
+ :type 'directory)
+
+;;;###autoload
+(defcustom bbdb-sound-volume 50
+ "Volume for playing sounds."
+ :group 'bbdb-phone-dialing
+ :type 'integer)
+
+;;;###autoload
+(defun bbdb-load-touchtones ()
+ "Load the touchtone sounds into `sound-alist'.
+The directory specified in `bbdb-sounds-directory' is searched for the files
+touchtone.*\\.\\(wav\\|au\\) as named in `bbdb-sound-files'.
+They are stored in `sound-alist' as touchtone0 to touchtone11."
+ (interactive)
+ (let (files
+ (nr 0))
+ (condition-case nil
+ (setq files
+ (directory-files bbdb-sounds-directory t
+ (if (and system-type
+ (string-match
+ "windows"
+ (format "%s" system-type)))
+ "touchtone.*\\.wav"
+ "touchtone.*\\.au")))
+ (error
+ ;; It is not a fatal error if we can't find the touchtones; it
+ ;; just prevents a particular, possibly little-used feature
+ ;; from working.
+ (bbdb-warn "Cannot find any touchtone sounds")
+ (setq files nil)))
+
+ (if (not files)
+ (progn
+ (message "No touchtone files found in `bbdb-sound-directory'!")
+ (sit-for 2))
+ ;; otherwise, load 'em up.
+ (while files
+ (load-sound-file (car files)
+ (intern (concat "touchtone" (format "%d" nr)))
+ bbdb-sound-volume)
+ (setq files (cdr files)
+ nr (1+ nr))))))
+
+(if (and bbdb-sounds-directory
+ (file-directory-p bbdb-sounds-directory)
+ (boundp 'xemacsp)
+ (featurep 'native-sound))
+ (bbdb-load-touchtones))
+
+(provide 'bbdb-xemacs)
diff --git a/lisp/bbdb.el b/lisp/bbdb.el
new file mode 100644
index 0000000..4b91509
--- /dev/null
+++ b/lisp/bbdb.el
@@ -0,0 +1,3873 @@
+;;; -*- Mode:Emacs-Lisp -*-
+;;; This file is the core of the Insidious Big Brother Database (aka BBDB),
+;;; copyright (c) 1991, 1992, 1993, 1994 Jamie Zawinski <jwz@netscape.com>.
+;;; See the file bbdb.texinfo for documentation.
+;;;
+;;; 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 2, 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
+;;; details.
+;;;
+;;; 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.
+;;;
+;;; ------------------------------------------------------------------------
+;;; | There is a mailing list for discussion of BBDB: |
+;;; | bbdb-info@lists.sourceforge.net |
+;;; | To join, send mail to bbdb-info-request@lists.sourceforge.net |
+;;; | (don't forget the "-request" part or you'll look silly in front of |
+;;; | lots of people who have the ability to remember it indefinitely...) |
+;;; | |
+;;; | There is also a second mailing list, to which only bug fixes and |
+;;; | new version announcements are sent; to be added to it, send mail to |
+;;; | bbdb-announce-request@lists.sourceforge.net. This is a very low |
+;;; | volume list, and if you're using BBDB, you really should be on it. |
+;;; | |
+;;; | When joining these lists or reporting bugs, please mention which |
+;;; | version you have. The preferred method of reporting bugs is to use |
+;;; | bbdb-submit-bug-report, which will include all useful version |
+;;; | information plus state information about how you have BBDB set up. |
+;;; ------------------------------------------------------------------------
+
+(require 'timezone)
+(eval-when-compile (require 'cl))
+
+(eval-when-compile ; pacify the compiler.
+ (autoload 'widget-group-match "wid-edit")
+ (autoload 'Electric-pop-up-window "electric")
+ (autoload 'Electric-command-loop "electric")
+ (autoload 'bbdb-migration-query "bbdb-migrate")
+ (autoload 'bbdb-migrate "bbdb-migrate")
+ (autoload 'bbdb-migrate-rewrite-all "bbdb-migrate")
+ (autoload 'bbdb-migrate-update-file-version "bbdb-migrate")
+ (autoload 'bbdb-unmigrate-record "bbdb-migrate")
+ (autoload 'bbdb-create-internal "bbdb-com")
+ (autoload 'bbdb-append-records-p "bbdb-com")
+ (autoload 'bbdb-redisplay-records "bbdb-com")
+ (autoload 'y-or-n-p-with-timeout "timer")
+ (autoload 'mail-position-on-field "sendmail")
+ (autoload 'bbdb-fontify-buffer "bbdb-gui")
+ (autoload 'vm-select-folder-buffer "vm-folder")
+
+ ;; can't use autoload for variables...
+ (defvar bbdb-define-all-aliases-needs-rebuilt) ;; bbdb-com
+ (defvar message-mode-map) ;; message.el
+ (defvar mail-mode-map) ;; sendmail.el
+ (defvar gnus-article-buffer) ;; gnus-art.el
+ (defvar temp-buffer-setup-hook nil)
+ (defvar buffer-file-coding-system nil)
+ (defvar coding-system-for-write nil)
+ )
+
+(defconst bbdb-version "2.36")
+
+
+(defmacro bbdb-eval-when (c &rest body)
+ "Emit BODY only if C is true."
+ (if (eval c)
+ (backquote (progn (\,@ body)))))
+
+(put 'bbdb-eval-when 'lisp-indent-hook 'defun)
+
+(defcustom bbdb-gui (if (fboundp 'display-color-p) ; Emacs 21
+ (display-color-p)
+ (not (null window-system))) ; wrong for XEmacs?
+ "*Non-nil means fontify the *BBDB* buffer."
+ :group 'bbdb
+ :type 'boolean)
+
+;; File format
+(defconst bbdb-file-format 6)
+(defvar bbdb-file-format-migration nil
+ "A cons of two elements: the version read, and the version to write.
+nil if the database was read in and is to be written in the current
+version.")
+
+(defvar bbdb-no-duplicates-p nil
+ "Should BBDB allow entries with duplicate names.
+This may lead to confusion when doing completion. If non-nil, it will
+prompt the users on how to merge records when duplicates are detected.")
+
+;; Definitions for things that aren't in all Emacsen and that I really
+;; would prefer not to live without.
+(eval-and-compile
+ (if (fboundp 'unless) nil
+ (defmacro unless (bool &rest forms) `(if ,bool nil ,@forms))
+ (defmacro when (bool &rest forms) `(if ,bool (progn ,@forms))))
+ (unless (fboundp 'save-current-buffer)
+ (defalias 'save-current-buffer 'save-excursion))
+ (if (fboundp 'mapc)
+ (defalias 'bbdb-mapc 'mapc)
+ (defalias 'bbdb-mapc 'mapcar))
+ )
+
+(unless (fboundp 'with-current-buffer)
+ (defmacro with-current-buffer (buf &rest body)
+ `(save-current-buffer (set-buffer ,buf) ,@body)))
+
+(unless (fboundp 'defvaralias)
+ (defun defvaralias (&rest args)))
+
+(defmacro string> (a b) (list 'not (list 'or (list 'string= a b)
+ (list 'string< a b))))
+
+(eval-and-compile
+ (or (fboundp 'set-keymap-prompt)
+ (fset 'set-keymap-prompt 'ignore)))
+
+(eval-and-compile
+ (if (fboundp 'replace-in-string)
+ (defalias 'bbdb-replace-in-string 'replace-in-string)
+ (if (fboundp 'replace-regexp-in-string) ; defined in e21
+ (defalias 'bbdb-replace-regexp-in-string 'replace-regexp-in-string)
+ ;; actually this is `dired-replace-in-string' slightly modified
+ ;; We're not defining the whole thing, just enough for our purposes.
+ (defun bbdb-replace-regexp-in-string (regexp newtext string &optional
+ fixedcase literal)
+ ;; Replace REGEXP with NEWTEXT everywhere in STRING and return result.
+ ;; NEWTEXT is taken literally---no \\DIGIT escapes will be recognized.
+ (let ((result "") (start 0) mb me)
+ (while (string-match regexp string start)
+ (setq mb (match-beginning 0)
+ me (match-end 0)
+ result (concat result (substring string start mb) newtext)
+ start me))
+ (concat result (substring string start)))))
+ (defun bbdb-replace-in-string (string regexp newtext &optional literal)
+ (bbdb-replace-regexp-in-string regexp newtext string nil literal))))
+
+(defun bbdb-prin1-to-string (object &optional noescape)
+ (let ((print-length nil)
+ (print-level nil))
+ (prin1-to-string object noescape)))
+
+(defun bbdb-prin1 (object &optional stream)
+ (let ((print-length nil)
+ (print-level nil))
+ (prin1 object stream)))
+
+;; this should really be in bbdb-com
+;;;###autoload
+(defun bbdb-submit-bug-report ()
+ "Submit a bug report, with pertinent information to the BBDB info list."
+ (interactive)
+ (require 'reporter)
+ (delete-other-windows)
+ (reporter-submit-bug-report
+ "bbdb-info@lists.sourceforge.net"
+ (concat "BBDB " bbdb-version)
+ (append
+ ;; non user variables
+ '(emacs-version
+ bbdb-file-format
+ bbdb-no-duplicates-p)
+ ;; user variables
+ (sort (apropos-internal "^bbdb"
+ 'user-variable-p)
+ (lambda (v1 v2) (string-lessp (format "%s" v1) (format "%s" v2))))
+ ;; see what the user had loaded
+ (list 'features)
+ )
+ nil
+ nil
+ "Please change the Subject header to a concise bug description.\nIn this report, remember to cover the basics, that is, what you expected to\nhappen and what in fact did happen. Please remove these\ninstructions from your message.")
+
+ ;; insert the backtrace buffer content if present
+ (let ((backtrace (get-buffer-create "*Backtrace*")))
+ (when backtrace
+ (goto-char (point-max))
+ (insert "\n\n")
+ (insert-buffer-substring backtrace)))
+
+ (goto-char (point-min))
+ (mail-position-on-field "Subject"))
+
+;; Make custom stuff work even without customize
+;; Courtesy of Hrvoje Niksic <hniksic@srce.hr>
+(eval-and-compile
+ (condition-case ()
+ (require 'custom)
+ (error nil))
+ (unless (and (featurep 'custom) (fboundp 'custom-declare-variable))
+ ;; We have the old custom-library, hack around it!
+ (defmacro defgroup (&rest args)
+ nil)
+ (defmacro defcustom (var value doc &rest args)
+ `(defvar ,var ,value ,doc))
+ (defmacro defface (var value doc &rest args)
+ `(make-face ,var))
+ (defmacro define-widget (&rest args)
+ nil)))
+
+(defconst bbdb-have-re-char-classes (string-match "[[:alpha:]]" "x")
+ "Non-nil if this Emacs supports regexp character classes.
+E.g. `[[:alnum:]]'.")
+
+;; Custom groups
+
+(defgroup bbdb nil
+ "The Insidious Big Brother Database."
+ :group 'news
+ :group 'mail)
+
+(put 'bbdb 'custom-loads '("bbdb-hooks" "bbdb-com"))
+
+(defgroup bbdb-hooks nil
+ "Hooks run at various times by the BBDB"
+ :group 'bbdb)
+
+(defgroup bbdb-record-display nil
+ "Variables that affect the display of BBDB records"
+ :group 'bbdb)
+
+(defgroup bbdb-record-creation nil
+ "Variables that affect the creation of BBDB records"
+ :group 'bbdb)
+
+(defgroup bbdb-noticing-records nil
+ "Variables that affect the noticing of new authors"
+ :group 'bbdb-record-creation)
+(put 'bbdb-noticing-records 'custom-loads '("bbdb-hooks"))
+
+(defgroup bbdb-record-use nil
+ "Variables that affect the use of BBDB records"
+ :group 'bbdb)
+
+(defgroup bbdb-database nil
+ "Variables that affect the database as a whole"
+ :group 'bbdb)
+
+(defgroup bbdb-saving nil
+ "Variables that affect saving of the BBDB"
+ :group 'bbdb-database)
+
+(defgroup bbdb-mua-specific nil
+ "MUA-specific customizations"
+ :group 'bbdb)
+
+(defgroup bbdb-mua-specific-gnus nil
+ "Gnus-specific BBDB customizations"
+ :group 'bbdb-mua-specific)
+
+(put 'bbdb-mua-specific-gnus 'custom-loads '("bbdb-gnus"))
+
+(defgroup bbdb-mua-specific-gnus-scoring nil
+ "Gnus-specific scoring BBDB customizations"
+ :group 'bbdb-mua-specific-gnus)
+
+(put 'bbdb-mua-specific-gnus-scoring 'custom-loads '("bbdb-gnus"))
+
+(defgroup bbdb-mua-specific-gnus-splitting nil
+ "Gnus-specific splitting BBDB customizations"
+ :group 'bbdb-mua-specific-gnus)
+
+(put 'bbdb-mua-specific-gnus-splitting 'custom-loads '("bbdb-gnus"))
+
+(defgroup bbdb-mua-specific-vm nil
+ "VM-specific BBDB customizations"
+ :group 'bbdb-mua-specific)
+
+(put 'bbdb-mua-specific-vm 'custom-loads '("bbdb-vm"))
+
+(defgroup bbdb-phone-dialing nil
+ "Customizations for phone number dialing"
+ :group 'bbdb)
+(put 'bbdb-phone-dialing 'custom-loads '("bbdb-com"))
+
+(defgroup bbdb-utilities nil
+ "Customize BBDB Utilities"
+ :group 'bbdb)
+
+(defgroup bbdb-utilities-finger nil
+ "Customizations for fingering from within the BBDB"
+ :group 'bbdb-utilities
+ :prefix "bbdb-finger")
+(put 'bbdb-utilities-finger 'custom-loads '("bbdb-com"))
+
+(defgroup bbdb-utilities-ftp nil
+ "Customizations for using FTP sites stored in BBDB records."
+ :group 'bbdb-utilities)
+(put 'bbdb-utilities-ftp 'custom-loads '("bbdb-ftp"))
+
+(defgroup bbdb-utilities-print nil
+ "Customizations for printing the BBDB."
+ :group 'bbdb-utilities
+ :prefix "bbdb-print")
+(put 'bbdb-utilities-print 'custom-loads '("bbdb-print"))
+
+(defgroup bbdb-utilities-supercite nil
+ "Customizations for using Supercite with the BBDB."
+ :group 'bbdb-utilities
+ :prefix "bbdb/sc")
+(if (or (featurep 'supercite)
+ (locate-library "supercite"))
+ (put 'bbdb-utilities-supercite 'custom-loads '("bbdb-sc")))
+
+(defgroup bbdb-utilities-server nil
+ "Customizations for interfacing with the BBDB from external programs."
+ :group 'bbdb-utilities
+ :prefix "bbdb/srv")
+(if (and (or (featurep 'gnuserv) (locate-library "gnuserv"))
+ (or (featurep 'itimer) (locate-library "itimer")))
+ (put 'bbdb-utilities-server 'custom-loads '("bbdb-srv")))
+
+;; BBDB custom widgets
+
+(define-widget 'bbdb-alist-with-header 'group
+ "My group"
+ :match 'bbdb-alist-with-header-match
+ :value-to-internal (lambda (widget value)
+ (if value (list (car value) (cdr value))))
+ :value-to-external (lambda (widget value)
+ (if value (append (list (car value)) (cadr value)))))
+
+(defun bbdb-alist-with-header-match (widget value)
+ (widget-group-match widget
+ (widget-apply widget :value-to-internal value)))
+
+;; Customizable variables
+
+(defcustom bbdb-file "~/.bbdb"
+ "*The name of the Insidious Big Brother Database file."
+ :group 'bbdb-database
+ :type 'file)
+
+;; this should be removed, and the following put in place:
+;; a hierarchical structure of bbdb files, some perhaps read-only,
+;; perhaps caching in the local bbdb. This way you could have, e.g. a
+;; company address book, with each person having access to it, and
+;; then a local address book with personal stuff in it.
+(defcustom bbdb-file-remote nil
+ "*The remote file to save the database to.
+When this is non-nil, it should be a file name.
+When BBDB reads `bbdb-file', it checks this file,
+ and if it is newer, downloads it.
+When BBDB writes `bbdb-file', it also writes this file.
+
+This feature allows one to keep the database in one place while using
+different computers, thus reducing the need for merging different files."
+ :group 'bbdb-database
+ :type '(choice (const :tag "none" nil)
+ (file :tag "remote file name")))
+
+(defcustom bbdb-file-remote-save-always t
+ "*Should the `bbdb-file-remote' file be saved whenever the database is saved?
+When nil, you will be asked."
+ :group 'bbdb-database
+ :type 'boolean)
+
+(defun bbdb-primep (num)
+ "Return t if NUM is a prime number."
+ (if (fboundp 'primep)
+ (primep num)
+ (and (numberp num) (> num 1) (= num (floor num))
+ (let ((lim (sqrt num)) (nu 2) (prime t))
+ (while (and prime (<= nu lim))
+ (setq prime (/= 0 (mod num nu))
+ nu (1+ nu)))
+ prime))))
+
+(defcustom bbdb-hashtable-size 1021
+ "*The size of the bbdb hashtable.
+BBDB hashtable is an obarray, so this must be a prime integer.
+Set this to a prime number (much) larger than the size of your database
+before loading it.
+If you change this variable outside `customize',
+you should reload `bbdb-file'."
+ :group 'bbdb-database
+ :type 'integer
+ :set (lambda (symb val)
+ (unless (bbdb-primep val)
+ (error "`%s' must be prime, not %s" symb val))
+ (set symb val)
+ (when (fboundp 'bbdb-records)
+ (bbdb-records))
+ val))
+
+(defcustom bbdb-default-area-code nil
+ "*The default area code to use when prompting for a new phone number.
+This variable also affects dialing."
+ :group 'bbdb-record-creation
+ :type '(choice (const :tag "none" nil)
+ (integer :tag "Default Area Code"))
+ :set (lambda( symb val )
+ (if (or (and (stringp val)
+ (string-match "^[0-9]+$" val))
+ (integerp val)
+ (null val))
+ (set symb val)
+ (error "%s must contain digits only." symb))))
+
+(defcustom bbdb-lastname-prefixes
+ '("von" "Von" "de" "De")
+ "*List of lastname prefixes recognized in name fields. Used to
+enhance dividing name strings into firstname and lastname parts."
+ :group 'bbdb-record-creation
+ :type '(repeat string))
+
+(defcustom bbdb-default-domain nil
+ "*The default domain to append when prompting for a new net address.
+If the address entered does not contain `[@%!]', `@bbdb-default-domain'
+will be appended to it.
+
+The address will not be altered if bbdb-default-domain remains at its
+default value of nil, or if one provides a prefix argument to the
+bbdb-insert-new-field command."
+ :group 'bbdb-record-creation
+ :type '(choice (const :tag "none" nil)
+ (string :tag "Domain" :value nil)))
+
+(defcustom bbdb-north-american-phone-numbers-p t
+ "*Set this to nil if you want to enter phone numbers that aren't the same
+syntax as those in North America (that is, [[1] nnn] nnn nnnn ['x' n*]).
+If this is true, then some error checking is done so that you can't enter
+incorrect phone numbers, and all phone numbers are pretty-printed the same
+way. European phone numbers don't have as strict a syntax, however, so
+this is a harder problem for them (on which I am punting).
+
+You can have both styles of phone number in your database by providing a
+prefix argument to the bbdb-insert-new-field command."
+ :group 'bbdb-record-creation
+ :type 'boolean)
+
+(defcustom bbdb-electric-p nil
+ "*Whether bbdb mode should be `electric' like `electric-buffer-list'."
+ :group 'bbdb-record-display
+ :type 'boolean)
+
+(defcustom bbdb-case-fold-search (default-value 'case-fold-search)
+ "*This is the value of `case-fold-search' used by `bbdb' and friends.
+This variable lets the case-sensitivity of ^S and of the bbdb
+commands be different."
+ :group 'bbdb
+ :type 'boolean)
+
+(defcustom bbdb/mail-auto-create-p t
+ "*If this is t, then MH, RMAIL, and VM will automatically
+create new bbdb records for people you receive mail from. If this
+is a function name or lambda, then it is called with no arguments
+to decide whether an entry should be automatically created. You
+can use this to, for example, not create records for messages
+which have reached you through a particular mailing list, or to
+only create records automatically if the mail has a particular
+subject."
+ :group 'bbdb-noticing-records
+ :type '(choice (const :tag "Automatically create" t)
+ (const :tag "Prompt before creating" prompt)
+ (const :tag "Do not automatically create" nil)
+ (function :tag "Create with function" bbdb-)))
+
+(defcustom bbdb/news-auto-create-p nil
+ "*If this is t, then Gnus will automatically create new bbdb
+records for people you receive mail from. If this is a function name
+or lambda, then it is called with no arguments to decide whether an
+entry should be automatically created. You can use this to, for
+example, create or not create messages which have a particular
+subject. If you want to autocreate messages based on the current
+newsgroup, it's probably a better idea to set this variable to t or
+nil from your `gnus-select-group-hook' instead."
+ :group 'bbdb-noticing-records
+ :type '(choice (const :tag "Automatically create" t)
+ (const :tag "Prompt before creating" prompt)
+ (const :tag "Do not automatically create" nil)
+ (function :tag "Create with function" bbdb-)))
+
+(defcustom bbdb-quiet-about-name-mismatches nil
+ "*If this is true, then BBDB will not prompt you when it notices a
+name change, that is, when the \"real name\" in a message doesn't correspond
+to a record already in the database with the same network address. As in,
+\"John Smith <jqs@frob.com>\" versus \"John Q. Smith <jqs@frob.com>\".
+Normally you will be asked if you want to change it.
+If set to a number it is the number of seconds to sit for while
+displaying the mismatch message.
+
+If set to a function it will be called with two arguments, the record and the
+new name and should return nil, t or a number.
+
+If none of the others it must be a sexp evaluating to nil, t or a number.
+
+Any other return value of the function or sexp will be considered as true."
+ :group 'bbdb-noticing-records
+ :type '(choice (const :tag "Prompt for name changes" nil)
+ (const :tag "Do not prompt for name changes" t)
+ (integer :tag
+ "Instead of prompting, warn for this many seconds")
+ (function :tag "User defined function")
+ (sexp :tag "User defined sexp")
+ (const :tag "Ignore records which has a 'readonly' field"
+ (assq 'readonly (bbdb-record-raw-notes record)))))
+
+(defcustom bbdb-use-alternate-names t
+ "*If this is true, then when bbdb notices a name change, it will ask you
+if you want both names to map to the same record."
+ :group 'bbdb-noticing-records
+ :type '(choice (const :tag "Ask to use alternate names field" t)
+ (const :tag "Use alternate names field without asking" nil)))
+
+(defcustom bbdb-readonly-p nil
+ "*If this is true, then nothing will attempt to change the bbdb database
+implicitly, and you will be prevented from doing it explicitly. If you have
+more than one emacs running at the same time, you might want to arrange for
+this to be set to t in all but one of them."
+ :group 'bbdb-database
+ :type '(choice (const :tag "Database is read-only" t)
+ (const :tag "Database is writable" nil)))
+
+(defcustom bbdb-continental-zip-regexp "^\\s *[A-Z][A-Z]?\\s *-\\s *[0-9][0-9][0-9]"
+ "Regexp matching continental zip codes.
+Addresses with zip codes matching the regexp will be formated using
+`bbdb-format-address-continental'. The regexp should match zip codes
+of the form CH-8052, NL-2300RA, and SE-132 54."
+ :group 'bbdb-record-display
+ :type 'regexp)
+
+(defcustom bbdb-auto-revert-p nil
+ "*If this variable is true and the BBDB file is noticed to have changed on
+disk, it will be automatically reverted without prompting you first. Otherwise
+you will be asked. (But if the file has changed and you hae made changes in
+memory as well, you will always be asked.)"
+ :group 'bbdb-saving
+ :type '(choice (const :tag "Revert unchanged database without prompting" t)
+ (const :tag "Ask before reverting database")))
+
+(defcustom bbdb-notice-auto-save-file nil
+ "*If this is true, then the BBDB will notice when its auto-save file is
+newer than the file is was read from, and will offer to revert."
+ :group 'bbdb-saving
+ :type '(choice (const :tag "Check auto-save file" t)
+ (const :tag "Do not check auto-save file" nil)))
+
+(defcustom bbdb-use-pop-up 'horizontal
+ "*If not nil, display a continuously-updating bbdb window while in VM, MH,
+RMAIL, Gnus or a composition buffer.
+
+If 'horizontal, stack the window horizontally and give it the number of lines
+specified by `bbdb-pop-up-target-lines'.
+If 'vertical, stack the window vertically and give it the number of rows
+specified by `bbdb-pop-up-target-columns'."
+ :group 'bbdb-record-display
+ :type '(choice (const :tag "Automatic BBDB window, stacked vertically" 'vertical)
+ (const :tag "Automatic BBDB window, stacked horizontally" 'horizontal)
+ (const :tag "No Automatic BBDB window" nil)))
+
+(defcustom bbdb-pop-up-target-lines 5
+ "*Desired number of lines in a horizontal BBDB buffer pop-up window.
+See `bbdb-use-pop-up' on how to select horizontal splitting."
+ :group 'bbdb-record-display
+ :type 'integer)
+
+(defcustom bbdb-pop-up-target-columns 20
+ "*Desired number of lines in a vertical BBDB buffer pop-up window.
+See `bbdb-use-pop-up' on how to select vertical splitting."
+ :group 'bbdb-record-display
+ :type 'integer)
+
+(defcustom bbdb-completion-type nil
+ "*Controls the behaviour of `bbdb-complete-name'. If nil, completion is
+done across the set of all full-names and user-ids in the bbdb-database;
+if the symbol 'name, completion is done on names only; if the symbol 'net,
+completion is done on network addresses only; if it is 'primary, then
+completion is done only across the set of primary network addresses (the
+first address in the list of addresses for a given user). If it is
+'primary-or-name, completion is done across primaries and real names."
+ :group 'bbdb-record-use
+ :type '(choice (const :tag "Complete across names and net addresses" nil)
+ (const :tag "Complete across names" name)
+ (const :tag "Complete across net addresses" net)
+ (const :tag "Complete across primary net addresses" primary)
+ (const :tag "Complete across names and primary net addresses"
+ primary-or-name)))
+
+(defcustom bbdb-completion-display-record t
+ "*Whether `bbdb-complete-name' (\\<mail-mode-map>\\[bbdb-complete-name]
+in mail-mode) will update the *BBDB* buffer to display the record whose email
+address has just been inserted."
+ :group 'bbdb-record-use
+ :type '(choice (const :tag "Update the BBDB buffer" t)
+ (const :tag "Don't update the BBDB buffer" nil)))
+
+(defcustom bbdb-user-mail-names nil
+ "*A regular expression identifying the addresses that belong to you.
+If a message from an address matching this is seen, the BBDB record for
+the To: line will be shown instead of the one for the From: line. If
+this is nil, it will default to the value of (user-login-name)."
+ :group 'bbdb-noticing-records
+ :type (list 'choice '(const :tag "Use value of (user-login-name)" nil)
+ (list 'regexp :tag "Pattern matching your addresses"
+ (or (user-login-name) "address"))))
+
+(defcustom bbdb-always-add-addresses 'ask
+ "*If this is true, then when the Insidious Big Brother Database notices
+a new email address for a person, it will automatically add it to the list of
+addresses. If it is 'ask, you will be asked whether to add it. If it is nil
+then new network addresses will never be automatically added nor the user will
+be asked.
+
+When set to a function name the function should return one of these values.
+
+See also the variable `bbdb-new-nets-always-primary' for control of whether
+the addresses go at the front of the list or the back."
+ :group 'bbdb-noticing-records
+ :type '(choice (const :tag "Automatically add new addresses" t)
+ (const :tag "Ask before adding new addresses" ask)
+ (const :tag "Never add new addresses" nil)
+ (const bbdb-ignore-some-messages-hook)
+ (const bbdb-ignore-most-messages-hook)))
+
+(defcustom bbdb-new-nets-always-primary nil
+ "*If this is true, then when the Insidious Big Brother Database adds a new
+address to a record, it will always add it to the front of the list of
+addresses, making it the primary address. If this is nil, you will be asked.
+If it is the symbol 'never (really, if it is any non-t, non-nil value) then
+new network addresses will always be added at the end of the list."
+ :group 'bbdb-noticing-records
+ :type '(choice (const :tag "New address automatically made primary" t)
+ (const :tag "Ask before making new address primary" nil)
+ (const :tag "Never make new address primary" never)))
+
+(defcustom bbdb-send-mail-style nil
+ "*Specifies which package should be used to send mail.
+Should be 'vm, 'mh, 'mail, 'message, or 'gnus (or nil, meaning guess.)"
+ :group 'bbdb-record-use
+ :type '(choice (const :tag "Use VM to send mail" vm)
+ (const :tag "Use MH-E to send mail" mh)
+ (const :tag "Use send-mail mode to send mail" mail)
+ (const :tag "Use Message to send mail" message)
+ (const :tag "Use Mew to send mail" mew)
+ (const :tag "Use compose-mail to send mail" compose-mail)
+ (const :tag "Use gnus to send mail" gnus)
+ (const :tag "Guess which package to use" nil)))
+
+(defcustom bbdb-offer-save t
+ "*If t, then certain actions will cause the BBDB to ask you whether
+you wish to save the database. If nil, then the offer to save will never
+be made. If not t and not nil, then any time it would ask you, it will
+just save it without asking."
+ :group 'bbdb-saving
+ :type '(choice (const :tag "Offer to save the database" t)
+ (const :tag "Never offer to save the database" nil)
+ (const :tag "Save database without asking" savenoprompt)))
+
+(defcustom bbdb-message-caching-enabled t
+ "*Whether caching of the message->bbdb-record association should be used
+for the interfaces which support it (VM, MH, and RMAIL). This can speed
+things up a lot. One implication of this variable being true is that the
+`bbdb-notice-hook' will not be called each time a message is selected, but
+only the first time. Likewise, if selecting a message would generate a
+question (whether to add an address, change the name, etc) you will only
+be asked that question the very first time the message is selected."
+ :group 'bbdb
+ :type '(choice (const :tag "Enable caching" t)
+ (const :tag "Disable caching" nil)))
+
+(defcustom bbdb-silent-running nil
+ "*If this is true, bbdb will suppress all its informational messages and
+queries. Be very very certain you want to set this, because it will suppress
+prompting to alter record names, assign names to addresses, etc."
+ :group 'bbdb
+ :type '(choice (const :tag "Run silently" t)
+ (const :tag "Disable silent running" nil)))
+
+(defcustom bbdb-mode-hook nil
+ "*Hook or hooks invoked when the *BBDB* buffer is created."
+ :group 'bbdb-hooks
+ :type 'hook)
+
+(defcustom bbdb-list-hook nil
+ "*Hook or hooks invoked after the `bbdb-list-buffer' is filled in.
+Invoked with no arguments."
+ :group 'bbdb-hooks
+ :type 'hook)
+
+(defcustom bbdb-create-hook 'bbdb-creation-date-hook
+ "*Hook or hooks invoked each time a new BBDB record is created. Invoked
+with one argument, the new record. This is called *before* the record is
+added to the database. Note that `bbdb-change-hook' will be called as well.
+
+Hook functions can use the variable `bbdb-update-address-class' to determine
+the class of an email address according to `bbdb-get-addresses-headers' and
+the variable `bbdb-update-address-header' is set to the header the email
+address was extracted from."
+ :group 'bbdb-hooks
+ :type 'hook)
+
+(defcustom bbdb-change-hook 'bbdb-timestamp-hook
+ "*Hook or hooks invoked each time a BBDB record is altered. Invoked with
+one argument, the record. This is called *before* the bbdb-database buffer
+is modified. Note that if a new bbdb record is created, both this hook and
+`bbdb-create-hook' will be called."
+ :group 'bbdb-hooks
+ :type 'hook)
+
+(defcustom bbdb-after-change-hook nil
+ "*Hook or hooks invoked each time a BBDB record is altered. Invoked with
+one argument, the record. This is called *after* the bbdb-database buffer
+is modified, so if you want to modify the record each time it is changed,
+you should use the `bbdb-change-hook' instead. Note that if a new bbdb
+record is created, both this hook and `bbdb-create-hook' will be called."
+ :group 'bbdb-hooks
+ :type 'hook)
+
+(defcustom bbdb-canonicalize-net-hook nil
+ "*If this is non-nil, it should be a function of one arg: a network address
+string. Whenever the Insidious Big Brother Database \"notices\" a message,
+the corresponding network address will be passed to this function first, as
+a kind of \"filter\" to do whatever transformations upon it you like before
+it is compared against or added to the database. For example: it is the case
+that CS.CMU.EDU is a valid return address for all mail originating at a
+machine in the .CS.CMU.EDU domain. So, if you wanted all such addresses to
+be canonically hashed as user@CS.CMU.EDU, instead of as user@host.CS.CMU.EDU,
+you might set this variable to a function like this:
+
+ (setq bbdb-canonicalize-net-hook
+ '(lambda (addr)
+ (cond ((string-match \"\\\\`\\\\([^@]+@\\\\).*\\\\.\\\\(CS\\\\.CMU\\\\.EDU\\\\)\\\\'\"
+ addr)
+ (concat (substring addr (match-beginning 1) (match-end 1))
+ (substring addr (match-beginning 2) (match-end 2))))
+ (t addr))))
+
+You could also use this function to rewrite UUCP-style addresses into domain-
+style addresses, or any number of things.
+
+This function will be called repeatedly until it returns a value EQ to the
+value passed in. So multiple rewrite rules might apply to a single address."
+ :group 'bbdb-hooks
+ :type 'function)
+
+(defcustom bbdb-canonicalize-redundant-nets-p t
+ "*If this is non-nil, redundant network addresses will be ignored.
+If a record has an address of the form foo@baz.com, setting this to t
+will cause subsequently-noticed addresses like foo@bar.baz.com to be
+ignored (since we already have a more general form of that address.)
+This is similar in function to one of the possible uses of the variable
+`bbdb-canonicalize-net-hook' but is somewhat more automatic. (This
+can't quite be implemented in terms of the canonicalize-net-hook because
+it needs access to the database to determine whether an address is
+redundant, and the canonicalize-net-hook is purely a textual manipulation
+which is performed before any database access.)"
+ :group 'bbdb-noticing-records
+ :type '(choice (const :tag "Ignore redundant addresses" t)
+ (const :tag "Don't ignore redundant addresses" nil)))
+
+(defcustom bbdb-notice-hook nil
+ "*Hook or hooks invoked each time a BBDB record is \"noticed\", that is,
+each time it is displayed by the news or mail interfaces. Invoked with
+one argument, the new record. The record need not have been modified for
+this to be called - use `bbdb-change-hook' for that. You can use this to,
+for example, add something to the notes field based on the subject of the
+current message. It is up to your hook to determine whether it is running
+in Gnus, VM, MH, or RMAIL, and to act appropriately.
+
+Also note that `bbdb-change-hook' will NOT be called as a result of any
+modifications you may make to the record inside this hook.
+
+Hook functions can use the variable `bbdb-update-address-class' to determine
+the class of an email address according to `bbdb-get-addresses-headers' and
+the variable `bbdb-update-address-header' is set to the header the email
+address was extracted from.
+
+Beware that if the variable `bbdb-message-caching-enabled' is true (a good
+idea) then when you are using VM, MH, or RMAIL, this hook will be called only
+the first time that message is selected. (The Gnus interface does not use
+caching.) When debugging the value of this hook, it is a good idea to set
+caching-enabled to nil."
+ :group 'bbdb-hooks
+ :type 'hook)
+
+(defcustom bbdb-after-read-db-hook nil
+ "*Hook or hooks invoked (with no arguments) just after the Insidious Big
+Brother Database is read in. Note that this can be called more than once if
+the BBDB is reverted."
+ :group 'bbdb-hooks
+ :type 'hook)
+
+(defcustom bbdb-load-hook nil
+ "*Hook or hooks invoked when the BBDB code is first loaded.
+
+WARNING: This hook will be run the first time you traverse the Custom menus
+ for the BBDB. As a result, nothing slow should be added to
+ this hook."
+ :group 'bbdb-hooks
+ :type 'hook)
+
+(defcustom bbdb-initialize-hook nil
+ "*Hook or hooks invoked (with no arguments) when the Insidious Big Brother
+Database initialization function `bbdb-initialize' is run."
+ :group 'bbdb-hooks
+ :type 'hook)
+
+;;;###autoload
+(defcustom bbdb-multiple-buffers nil
+ "When non-nil we create a new buffer of every buffer causing pop-ups.
+You can also set this to a function returning a buffer name."
+ :group 'bbdb-record-display
+ :type '(choice (const :tag "Disabled" nil)
+ (function :tag "Enabled" bbdb-multiple-buffers-default)
+ (function :tag "User defined function")))
+
+(defvar bbdb-mode-map nil
+ "Keymap for Insidious Big Brother Database listings.")
+(defvar bbdb-mode-search-map nil
+ "Keymap for Insidious Big Brother Database searching")
+
+;; iso-2022-7bit should be OK (but not optimal for Emacs, at least --
+;; emacs-mule would be better) with both Emacs 21 and XEmacs.
+(defcustom bbdb-file-coding-system
+ (bbdb-eval-when (fboundp 'coding-system-p)
+ (cond ((apply 'coding-system-p '(utf-8-emacs))
+ 'utf-8-emacs)
+ (t 'iso-8859-1)))
+ "Coding system used for reading and writing `bbdb-file'.
+This should not be changed by users.
+This should not be changed in between BBDB sessions, i.e. before loading the
+BBDB which was stored in a different coding system. Make a backup of your
+BBDB before changing this variable!"
+ :group 'bbdb
+ :type '(choice (const iso-8859-1)
+ (const utf-8-emacs)
+ (const iso-2022-7bit)))
+
+(defvar bbdb-suppress-changed-records-recording nil
+ "Whether to record changed records in variable `bbdb-changed-records'.
+
+If this is false, the BBDB will cease to remember which records are changed
+as the change happens. It will still remember that records have been changed,
+so the file will still be saved, but the changed records list, and the `!!'
+in the *BBDB* buffer modeline that it depends on, will no longer be updated.
+
+You should bind this variable, not set it; the `!!' is a useful user-
+interface feature, and should only be suppressed when changes need to be
+automatically made to BBDB records which the user will not care directly
+about.")
+
+
+;;; These are the buffer-local variables we use.
+;;; They are mentioned here so that the compiler doesn't warn about them
+;;; when byte-compile-warn-about-free-variables is on.
+
+(defvar bbdb-records nil)
+(defvar bbdb-changed-records nil)
+(defvar bbdb-end-marker nil)
+(defvar bbdb-hashtable nil)
+(defvar bbdb-propnames nil)
+(defvar bbdb-message-cache nil)
+(defvar bbdb-showing-changed-ones nil)
+(defvar bbdb-modified-p nil)
+(defvar bbdb-address-print-formatting-alist) ; "bbdb-print"
+
+(defvar bbdb-debug t)
+(defmacro bbdb-debug (&rest body)
+ ;; ## comment out the next line to turn off debugging.
+ ;; ## You really shouldn't do this! But it will speed things up.
+ (list 'and 'bbdb-debug (list 'let '((debug-on-error t)) (cons 'progn body)))
+ )
+
+
+;;; internal kludge to force queries to always happen with the mouse rather
+;;; than basing the decision on the last-input-event; bind this, don't set it.
+(defvar bbdb-force-dialog-boxes nil)
+
+(defun bbdb-y-or-n-p (prompt)
+ (prog1
+ (funcall
+ (cond ((and bbdb-force-dialog-boxes
+ (fboundp 'yes-or-no-p-dialog-box))
+ (when (and (fboundp 'raise-frame)
+ (not (frame-visible-p (selected-frame))))
+ (raise-frame (selected-frame)))
+ 'yes-or-no-p-dialog-box)
+ (t 'y-or-n-p))
+ prompt)
+ (message " ")))
+
+(defun bbdb-yes-or-no-p (prompt)
+ (prog1
+ (funcall (if (and bbdb-force-dialog-boxes
+ (fboundp 'yes-or-no-p-dialog-box))
+ 'yes-or-no-p-dialog-box
+ 'yes-or-no-p)
+ prompt)
+ (message " ")))
+
+(defun bbdb-invoke-hook (hook arg)
+ "Like `invoke-hooks', but invokes the given hook with one argument."
+ (if (and (boundp hook) (setq hook (symbol-value hook)))
+ (if (and (consp hook) (not (eq (car hook) 'lambda)))
+ (while hook
+ (funcall (car hook) arg)
+ (setq hook (cdr hook)))
+ (funcall hook arg))))
+
+(defun bbdb-invoke-hook-for-value (hook &rest args)
+ "If HOOK is a function, invoke it with ARGS. Otherwise return it as-is."
+ (cond ((eq hook nil) nil)
+ ((eq hook t) t)
+ ((functionp hook) (apply hook args))
+ (t hook)))
+
+(defmacro bbdb-defstruct (conc-name &rest slots)
+ "Make two functions, one for each slot. The functions are:
+ CONC-NAME + SLOT and CONC-NAME + `set-' + SLOT
+The first one is to be used to read the element named in SLOT, and the
+second is used to set it. Also make a constant
+ CONC-NAME + `length'
+that holds the number of slots."
+ (setq conc-name (symbol-name conc-name))
+ (let ((body '())
+ (i 0)
+ (L (length slots)))
+ (while slots
+ (setq body
+ (nconc body
+ (let ((readname (intern (concat conc-name (symbol-name (car slots)))))
+ (setname (intern (concat conc-name "set-" (symbol-name (car slots))))))
+ (list
+ (list 'defmacro readname '(vector)
+ (list 'list ''aref 'vector i))
+ (list 'defmacro setname '(vector value)
+ (if (string= setname "bbdb-record-set-net")
+ (list 'setq
+ 'bbdb-define-all-aliases-needs-rebuilt t))
+ (list 'list ''aset 'vector i 'value))
+ ;(list 'put (list 'quote readname) ''edebug-form-hook ''(form))
+ ;(list 'put (list 'quote setname) ''edebug-form-hook ''(form form))
+ ))))
+ (setq slots (cdr slots) i (1+ i)))
+ (setq body (nconc body (list (list 'defconst
+ (intern (concat conc-name "length"))
+ L))))
+ (cons 'progn body)))
+
+;;; When reading this code, beware that "cache" refers to two things.
+;;; It refers to the cache slot of bbdb-record structures, which is
+;;; used for computed properties of the records; and it also refers
+;;; to a message-id --> bbdb-record association list which speeds up
+;;; the RMAIL, VM, and MH interfaces.
+
+;; Build reading and setting functions for firstname, lastname, aka,
+;; company, phones, addresses, net, raw-notes, and cache. These are
+;; for accessing the high-level forms for the record.
+(bbdb-defstruct bbdb-record-
+ firstname lastname aka company
+ phones addresses net raw-notes
+ cache
+ )
+
+;; HACKHACK
+;;(defmacro bbdb-record-set-net (vector value)
+;; "We redefine the set-binding for 'net to detect changes"
+;; (list 'progn
+;; (list 'aset vector 6 value)
+;; (list 'setq 'bbdb-define-all-aliases-needs-rebuilt t)))
+
+(put 'company 'field-separator "; ")
+(put 'notes 'field-separator "\n")
+
+;; Build reading and setting functions for location, area, exchange,
+;; suffix, and extension. These are for accessing the elements of the
+;; individual phone number forms.
+(bbdb-defstruct bbdb-phone-
+ location area exchange suffix extension
+ )
+
+;; Build reading and setting functions for location, street, city,
+;; state, zip and country. These are for accessing the elements of
+;; the individual address forms.
+(bbdb-defstruct bbdb-address-
+ location streets city state zip country
+ )
+
+;; Build reading and setting functions for namecache (the full name of
+;; the person referred to by the record), sortkey (the concatenation
+;; of the elements used for sorting the record), marker, and
+;; deleted-p. These are for accessing the elements of the cache form,
+;; and are generally concatenations of data existing in separate parts
+;; of the record, stored here prebuilt for speed.
+(bbdb-defstruct bbdb-cache-
+ namecache sortkey marker deleted-p
+ )
+
+;; Build the namecache for a record
+(defsubst bbdb-record-name-1 (record)
+ (bbdb-cache-set-namecache (bbdb-record-cache record)
+ (let ((fname (bbdb-record-firstname record))
+ (lname (bbdb-record-lastname record)))
+ (if (> (length fname) 0)
+ (if (> (length lname) 0)
+ (concat fname " " lname)
+ fname)
+ lname))))
+
+;; Return the full name from a record. If the name is not available
+;; in the namecache, the namecache value is generated (and stored).
+(defun bbdb-record-name (record)
+ (or (bbdb-cache-namecache (bbdb-record-cache record))
+ (bbdb-record-name-1 record)))
+
+(defun bbdb-record-lfname (record)
+ (let ((fname (bbdb-record-firstname record))
+ (lname (bbdb-record-lastname record)))
+ (if (and (> (length fname) 0) (> (length lname) 0))
+ (concat lname " " fname)
+ nil)))
+
+;; Return the sortkey for a record, building (and storing) it if
+;; necessary.
+(defun bbdb-record-sortkey (record)
+ (or (bbdb-cache-sortkey (bbdb-record-cache record))
+ (bbdb-cache-set-sortkey (bbdb-record-cache record)
+ (downcase
+ (concat (bbdb-record-lastname record)
+ (bbdb-record-firstname record)
+ (bbdb-record-company record))))))
+
+(defmacro bbdb-record-marker (record)
+ (list 'bbdb-cache-marker (list 'bbdb-record-cache record)))
+
+(defmacro bbdb-record-deleted-p (record)
+ (list 'bbdb-cache-deleted-p (list 'bbdb-record-cache record)))
+
+(defmacro bbdb-record-set-deleted-p (record val)
+ (list 'bbdb-cache-set-deleted-p (list 'bbdb-record-cache record) val))
+
+(defmacro bbdb-record-set-namecache (record newval)
+ (list 'bbdb-cache-set-namecache (list 'bbdb-record-cache record) newval))
+
+(defmacro bbdb-record-set-sortkey (record newval)
+ (list 'bbdb-cache-set-sortkey (list 'bbdb-record-cache record) newval))
+
+(defmacro bbdb-record-set-marker (record newval)
+ (list 'bbdb-cache-set-marker (list 'bbdb-record-cache record) newval))
+
+
+;; The "notes" and "properties" accessors don't need to be fast.
+
+(defun bbdb-record-notes (record)
+ (if (consp (bbdb-record-raw-notes record))
+ (cdr (assq 'notes (bbdb-record-raw-notes record)))
+ (bbdb-record-raw-notes record)))
+
+;; this works on the 'company field as well.
+(defun bbdb-record-getprop (record property)
+ (if (memq property '(name address addresses phone phones net aka AKA))
+ (error "bbdb: cannot access the %s field this way" property))
+ (if (eq property 'company)
+ (bbdb-record-company record)
+ (if (consp (bbdb-record-raw-notes record))
+ (cdr (assq property (bbdb-record-raw-notes record)))
+ (if (and (eq property 'notes)
+ (stringp (bbdb-record-raw-notes record)))
+ (bbdb-record-raw-notes record)
+ nil))))
+
+(defun bbdb-get-field (rec field &optional nn)
+ "Get the N-th element (or all if nil) of the notes FIELD of the REC.
+If the note is absent, returns a zero length string."
+ (let ((note (or (bbdb-record-getprop rec field) "")))
+ (if nn
+ (nth nn (split-string note " ,;\t\n\f\r\v"))
+ note)))
+
+;; this works on the 'company field as well.
+(defun bbdb-record-putprop (record property newval)
+ (if (memq property '(name address addresses phone phones net aka AKA))
+ (error "bbdb: cannot annotate the %s field this way" property))
+ (if (eq property 'company)
+ (bbdb-record-set-company record
+ (bbdb-record-set-company record newval))
+ (if (and (eq property 'notes)
+ (not (consp (bbdb-record-raw-notes record))))
+ (bbdb-record-set-raw-notes record newval)
+ (or (listp (bbdb-record-raw-notes record))
+ (bbdb-record-set-raw-notes record
+ (list (cons 'notes (bbdb-record-raw-notes record)))))
+ (let ((old (assq property (bbdb-record-raw-notes record))))
+ (if old
+ (if newval
+ (setcdr old newval)
+ (bbdb-record-set-raw-notes record
+ (delq old (bbdb-record-raw-notes record))))
+ (and newval
+ (bbdb-record-set-raw-notes record
+ (append (bbdb-record-raw-notes record)
+ (list (cons property newval))))))))
+ ;; save some file space: if we ever end up with ((notes . "...")),
+ ;; replace it with the string.
+ (if (and (consp (bbdb-record-raw-notes record))
+ (null (cdr (bbdb-record-raw-notes record)))
+ (eq 'notes (car (car (bbdb-record-raw-notes record)))))
+ (bbdb-record-set-raw-notes record
+ (cdr (car (bbdb-record-raw-notes record)))))
+ )
+ ;; If we're changing the company, then we need to sort, since the company
+ ;; is the sortkey for nameless records. This should almost never matter...
+ (bbdb-change-record record (eq property 'company))
+ newval)
+
+(defun bbdb-record-set-notes (record newval)
+ (if (consp (bbdb-record-raw-notes record))
+ (bbdb-record-putprop record 'notes newval)
+ (bbdb-record-set-raw-notes record newval)
+ (bbdb-change-record record nil)))
+
+(defun bbdb-phone-string (phone)
+ (if (= 2 (length phone)) ; euronumbers....
+ (aref phone 1)
+ ;; numbers should come in two forms:
+ ;; ["where" 415 555 1212 99] or ["where" "the number"]
+ (if (stringp (aref phone 1))
+ (error "doubleplus ungood: euronumbers unwork"))
+ (concat (if (/= 0 (bbdb-phone-area phone))
+ (format "(%03d) " (bbdb-phone-area phone))
+ "")
+ (if (/= 0 (bbdb-phone-exchange phone))
+ (format "%03d-%04d"
+ (bbdb-phone-exchange phone) (bbdb-phone-suffix phone))
+ "")
+ (if (and (bbdb-phone-extension phone)
+ (/= 0 (bbdb-phone-extension phone)))
+ (format " x%d" (bbdb-phone-extension phone))
+ ""))))
+
+;; Legacy function. Used to convert a zip datastructure string into a
+;; formated string. As zip codes are plain strings now, use
+;; `bbdb-address-zip' instead.
+(defalias 'bbdb-address-zip-string 'bbdb-address-zip)
+
+(defmacro bbdb-record-lessp (record1 record2)
+ (list 'string< (list 'bbdb-record-sortkey record1)
+ (list 'bbdb-record-sortkey record2)))
+
+(defmacro bbdb-subint (string match-number)
+ (list 'string-to-number
+ (list 'substring string
+ (list 'match-beginning match-number)
+ (list 'match-end match-number))))
+
+(eval-and-compile
+ (if (fboundp 'display-error)
+ (fset 'bbdb-display-error 'display-error)
+ (defun bbdb-display-error(msg stream)
+ (message "Error: %s" (nth 1 msg)))))
+
+(defmacro bbdb-error-retry (form)
+ (list 'catch ''--bbdb-error-retry--
+ (list 'while ''t
+ (list 'condition-case '--c--
+ (list 'throw ''--bbdb-error-retry-- form)
+ '(error
+ (ding)
+ (let ((cursor-in-echo-area t))
+ (bbdb-display-error --c-- nil)
+ (sit-for 2)))))))
+
+;;; Completion on labels and field data
+
+;;; Realistically speaking, it doesn't make sense to offer minibuffer
+;;; completion for some fields - like ones that don't have labels!
+;;;
+;;; Also, I could probably do this with macros similar to the
+;;; def-struct stuff.
+(defcustom bbdb-default-label-list
+ '("Home" "Office" "Mobile" "Other")
+ "*Default list of labels for Address and Phone fields."
+ :group 'bbdb-record-creation
+ :type '(repeat string))
+
+(defcustom bbdb-phones-label-list
+ bbdb-default-label-list
+ "*List of labels for Phone field.
+The default value is `bbdb-default-label-list'."
+ :group 'bbdb-record-creation
+ :type '(repeat string))
+
+(defcustom bbdb-addresses-label-list
+ bbdb-default-label-list
+ "*List of labels for Address field.
+The default value is `bbdb-default-label-list'."
+ :group 'bbdb-record-creation
+ :type '(repeat string))
+
+(defun bbdb-label-completion-list (field)
+ "Figure out a completion list for the specified FIELD label.
+This evaluates the variable bbdb-FIELD-label-list, such
+as `bbdb-phones-label-list'."
+ (if (boundp (intern (format "bbdb-%s-label-list" field)))
+ (eval (intern (format "bbdb-%s-label-list" field)))
+ ;; special-case out the ones it doesn't make sense for here?
+ bbdb-default-label-list))
+
+(defun bbdb-label-completion-default (field)
+ "Figure out a default label from the completion list for FIELD.
+This evaluates the variable bbdb-default-FIELD-label, such
+as `bbdb-default-phones-label', if it exists, or it takes
+the first item from the list of completions for FIELD as
+returned by `bbdb-label-completion-list'."
+ (if (boundp (intern (format "bbdb-default-%s-label" field)))
+ (eval (intern (format "bbdb-default-%s-label" field)))
+ (nth 0 (bbdb-label-completion-list field))))
+
+;; These are so you can accumulate e.g. mail aliases or company names
+;; and have BBDB offer completion on them.
+(defun bbdb-data-completion-list (field)
+ "Figure out a completion list for the specified FIELD value.
+This evaluates the variable bbdb-FIELD-data-list, such
+as `bbdb-mail-alias-data-list', if it exists, or it uses
+`bbdb-default-label-list'."
+ (if (boundp (intern (format "bbdb-%s-data-list" field)))
+ (eval (intern (format "bbdb-%s-data-list" field)))
+ ;; special-case out the ones it doesn't make sense for here?
+ bbdb-default-label-list))
+
+(defun bbdb-data-completion-default (field)
+ "Figure out a default value from the completion list for FIELD.
+This evaluates the variable bbdb-default-FIELD-data, such
+as `bbdb-default-mail-alias-data', if it exists, or it takes
+the first item from the list of completions for FIELD as
+returned by `bbdb-data-completion-list'."
+ (if (boundp (intern (format "bbdb-default-%s-data" field)))
+ (eval (intern (format "bbdb-default-%s-data" field)))
+ (nth 0 (bbdb-label-completion-list field))))
+
+;;;
+(defvar bbdb-buffer nil)
+(defun bbdb-buffer ()
+ (if (and bbdb-buffer (buffer-live-p bbdb-buffer))
+ bbdb-buffer
+ (when (and bbdb-file-remote
+ (file-newer-than-file-p bbdb-file-remote bbdb-file))
+ (let ((coding-system-for-write bbdb-file-coding-system))
+ (copy-file bbdb-file-remote bbdb-file t t)))
+ (setq bbdb-buffer (find-file-noselect bbdb-file 'nowarn))))
+
+(defmacro bbdb-with-db-buffer (&rest body)
+ (cons 'with-current-buffer
+ (cons '(bbdb-buffer)
+ (if (and (boundp 'bbdb-debug) bbdb-debug)
+ ;; if we're debugging, and the .bbdb buffer is visible in
+ ;; a window, temporarilly switch to that window so that
+ ;; when we come out, that window has been scrolled to the
+ ;; record we've just modified. (make w-point = b-point)
+ (list
+ (list 'let '((w (and bbdb-debug
+ (get-buffer-window
+ (buffer-name
+ (get-buffer bbdb-file))))))
+ (list 'save-excursion
+ (cons 'save-window-excursion
+ (cons '(and w (select-window w))
+ body)))))
+ body))))
+
+(defsubst bbdb-string-trim (string)
+ "Lose leading and trailing whitespace. Also remove all properties
+from string."
+ (if (string-match "\\`[ \t\n]+" string)
+ (setq string (substring string (match-end 0))))
+ (if (string-match "[ \t\n]+\\'" string)
+ (setq string (substring string 0 (match-beginning 0))))
+ ;; This is not ideologically blasphemous. It is a bad function to
+ ;; use on regions of a buffer, but since this is our string, we can
+ ;; do whatever we want with it. --Colin
+ (set-text-properties 0 (length string) nil string)
+ string)
+
+(defun bbdb-read-string (prompt &optional default completions)
+ "Reads a string, trimming whitespace and text properties."
+ (bbdb-string-trim
+ (if completions
+ (completing-read prompt completions nil nil (cons default 0))
+ (bbdb-string-trim (read-string prompt default)))))
+
+;;; Address formatting.
+
+(defcustom bbdb-time-display-format "%d %b %Y"
+ "The format for the timestamp to be used in the creation-date and
+timestamp fields. See the documentation for `format-time-string'."
+ :group 'bbdb :type 'string)
+
+(defun bbdb-time-convert (date &optional format)
+ "Convert a date from the BBDB internal format to the format
+determined by FORMAT (or `bbdb-time-display-format' if FORMAT not
+present). Returns a string containing the date in the new format."
+ (let ((parts (bbdb-split date "-")))
+ (format-time-string (or format bbdb-time-display-format)
+ (encode-time 0 0 0 (string-to-number (caddr parts))
+ (string-to-number (cadr parts))
+ (string-to-number (car parts))))))
+
+(defalias 'bbdb-format-record-timestamp 'bbdb-time-convert)
+(defalias 'bbdb-format-record-creation-date 'bbdb-time-convert)
+
+(defconst bbdb-gag-messages nil
+ "Bind this to t to quiet things down - do not set it!")
+
+(defvar bbdb-buffer-name "*BBDB*")
+
+(defcustom bbdb-display-layout-alist
+ '((one-line (order . (phones mail-alias net notes))
+ (name-end . 24)
+ (toggle . t))
+ (multi-line (omit . (creation-date timestamp))
+ (toggle . t))
+ (pop-up-multi-line)
+ (full-multi-line))
+ "*An alist describing each display layout.
+The format of an element is (LAYOUT-NAME OPTION-ALIST).
+
+By default there are four different layout types used by BBDB, which are
+`one-line', `multi-line', `pop-up-multi-line' (used for pop-ups) and
+`full-multi-line' (showing all fields of a record).
+
+OPTION-ALIST specifies the options for the layout. Valid options are:
+
+ ------- Availability --------
+ Format one-line multi-line default if unset
+------------------------------------------------------------------------------
+ (toggle . BOOL) + + nil
+ (order . FIELD-LIST) + + '(phones ...)
+ (omit . FIELD-LIST) + + nil
+ (name-end . INTEGER) + - 40
+ (indentation . INTEGER) - + 14
+ (primary . BOOL) - + nil
+ (test . SEXP) + + nil
+
+- toggle: controls if this layout is included when toggeling the display layout
+- order: defines a user specific order for the fields, where `t' is a place
+ holder for all remaining fields
+- omit: is a list of fields which should not be displayed or `t' to exclude all
+ fields except those listed in the order option
+- name-end: sets the column where the name should end in one-line layout.
+- indentation: sets the level of indentation for multi-line display.
+- primary: controls wether only the primary net is shown or all are shown.
+- test: a lisp expression controlling wether the record is to be displayed.
+
+When you add a new layout FOO, you can write a corresponding layout
+function bbdb-format-record-layout-FOO. If you do not write your own
+layout function, the multi-line layout will be used."
+ :group 'bbdb
+ :type
+ `(repeat
+ (cons :tag "Layout Definition"
+ (choice :tag "Layout type"
+ (const one-line)
+ (const multi-line)
+ (const pop-up-multi-line)
+ (const full-multi-line)
+ (symbol))
+ (set :tag "Properties"
+ (cons :tag "Order"
+ (const :tag "List of fields to order by" order)
+ (repeat (choice (const phones)
+ (const addresses)
+ (const net)
+ (const AKA)
+ (const notes)
+ (symbol :tag "other")
+ (const :tag "Remaining fields" t))))
+ (choice :tag "Omit"
+ :value (omit . nil)
+ (cons :tag "List of fields to omit"
+ (const :tag "Fields not to display" omit)
+ (repeat (choice (const phones)
+ (const addresses)
+ (const net)
+ (const AKA)
+ (const notes)
+ (symbol :tag "other"))))
+ (const :tag "Exclude all fields except those listed in the order property" t))
+ (cons :tag "Indentation"
+ :value (indentation . 14)
+ (const :tag "Level of indentation for multi-line layout"
+ indentation)
+ (number :tag "Column"))
+ (cons :tag "End of name field"
+ :value (name-end . 24)
+ (const :tag "The column where the name should end in one-line layout"
+ name-end)
+ (number :tag "Column"))
+ (cons :tag "Toggle"
+ (const :tag "The layout is included when toggling display layout" toggle)
+ boolean)
+ (cons :tag "Primary Net Only"
+ (const :tag "Only the primary net address is included" primary)
+ boolean)
+ (cons :tag "Test"
+ (const :tag "Show only records passing this test" test)
+ (choice (const :tag "No test" nil)
+ (cons :tag "List of required fields"
+ (const :tag "Choose from the attributes in the following set:" and)
+ (set
+ (const name)
+ (const company)
+ (const net)
+ (const phones)
+ (const addresses)
+ (const notes)))
+ (sexp :tag "Lisp expression")))))))
+
+
+(defcustom bbdb-display-layout 'multi-line
+ "*The default display layout."
+ :group 'bbdb
+ :type '(choice (const one-line)
+ (const multi-line)
+ (const full-multi-line)
+ (symbol)))
+
+(defcustom bbdb-pop-up-display-layout 'one-line
+ "*The default display layout pop-up BBDB buffers, i.e. mail, news."
+ :group 'bbdb
+ :type '(choice (const one-line)
+ (const multi-line)
+ (const full-multi-line)
+ (symbol)))
+
+(defun bbdb-display-layout-get-option (layout option)
+ (let ((layout-spec (if (listp layout)
+ layout
+ (assoc layout bbdb-display-layout-alist)))
+ option-value)
+ (and layout-spec
+ (setq option-value (assoc option layout-spec))
+ (cdr option-value))))
+
+(defcustom bbdb-address-formatting-alist
+ '((bbdb-address-is-continental . bbdb-format-address-continental)
+ (nil . bbdb-format-address-default))
+ "Alist of address identifying and address formatting functions.
+The key is an identifying function which accepts an address. The
+associated value is a formatting function which inserts the formatted
+address in the current buffer. If the identifying function returns
+non-nil, the formatting function is called. When nil is used as the
+car, then the associated formatting function will always be called.
+Therefore you should always have (nil . bbdb-format-address-default) as
+the last element in the alist.
+
+All functions should take two arguments, the address and an indentation.
+The indentation argument may be optional.
+
+This alist is used in `bbdb-format-address'.
+
+See also `bbdb-address-print-formatting-alist'."
+ :group 'bbdb-record-display
+ :type '(repeat (cons function function)))
+
+(defvar bbdb-address-print-formatting-alist) ; "bbdb-print"
+
+(defun bbdb-address-is-continental (addr)
+ "Return non-nil if the address ADDR is a continental address.
+This is done by comparing the zip code to `bbdb-continental-zip-regexp'.
+
+This is a possible identifying function for
+`bbdb-address-formatting-alist' and
+`bbdb-address-print-formatting-alist'."
+ (string-match bbdb-continental-zip-regexp (bbdb-address-zip addr)))
+
+(defun bbdb-format-streets (addr indent)
+ "Insert street subfields of address ADDR in current buffer.
+This may be used by formatting functions listed in
+`bbdb-address-formatting-alist'."
+ (bbdb-mapc (lambda(str)
+ (indent-to indent)
+ (insert str "\n"))
+ (bbdb-address-streets addr)))
+
+(defun bbdb-format-address-continental (addr &optional indent)
+ "Insert formated continental address ADDR in current buffer.
+This format is used in western Europe, for example.
+
+This function is a possible formatting function for
+`bbdb-address-formatting-alist'.
+
+The result looks like this:
+ location: street
+ street
+ ...
+ zip city, state
+ country"
+ (setq indent (or indent 14))
+ (let (;(fmt (format " %%%ds: " indent))
+ (indent (+ 3 indent)))
+ ;(insert (format fmt (bbdb-address-location addr)))
+ (bbdb-format-streets addr indent)
+ (let ((c (bbdb-address-city addr))
+ (s (bbdb-address-state addr))
+ (z (bbdb-address-zip addr)))
+ (if (or (> (length c) 0)
+ (> (length z) 0)
+ (> (length s) 0))
+ (progn
+ (indent-to indent)
+ (insert z (if (and (> (length z) 0)
+ (> (length c) 0)) " " "")
+ c (if (and (or (> (length z) 0)
+ (> (length c) 0))
+ (> (length s) 0)) ", " "")
+ s "\n"))))
+ (let ((str (bbdb-address-country addr)))
+ (if (= 0 (length str)) nil
+ (indent-to indent) (insert str "\n")))))
+
+(defun bbdb-format-address-default (addr &optional indent)
+ "Insert formated address ADDR in current buffer.
+This is the default format; it is used in the US, for example.
+
+This function is a possible formatting function for
+`bbdb-address-formatting-alist'.
+
+The result looks like this:
+ location: street
+ street
+ ...
+ city, state zip
+ country"
+ (setq indent (or indent 14))
+ (let (;(fmt (format " %%%ds: " indent))
+ (indent (+ 3 indent)))
+; (insert (format fmt (bbdb-address-location addr)))
+ (bbdb-format-streets addr indent)
+ (let ((c (bbdb-address-city addr))
+ (s (bbdb-address-state addr))
+ (z (bbdb-address-zip addr)))
+ (if (or (> (length c) 0)
+ (> (length z) 0)
+ (> (length s) 0))
+ (progn
+ (indent-to indent)
+ (insert c (if (and (> (length c) 0)
+ (> (length s) 0)) ", " "")
+ s (if (and (or (> (length c) 0)
+ (> (length s) 0))
+ (> (length z) 0)) " " "")
+ z "\n"))))
+ (let ((str (bbdb-address-country addr)))
+ (if (= 0 (length str)) nil
+ (indent-to indent) (insert str "\n")))))
+
+(defun bbdb-format-address (addr &optional printing indent)
+ "Call appropriate formatting function for address ADDR.
+
+If optional second argument PRINTING is non-nil, this uses the alist
+`bbdb-address-print-formatting-alist' to determine how the address is to
+formatted and inserted into the current buffer. This is used by
+`bbdb-print-format-record'.
+
+If second argument PRINTING is nil, this uses the alist
+`bbdb-address-formatting-alist' to determine how the address is to
+formatted and inserted into the current buffer. This is used by
+`bbdb-format-record'."
+ ;; alist contains functions ((ident1 . format1) (ident2 . format2) ...)
+ ;; the first identifying-function is (caar alist)
+ ;; the first formatting-function is (cdar alist)
+ (let ((alist (if printing bbdb-address-print-formatting-alist
+ bbdb-address-formatting-alist)))
+ ;; while there a functions left and the current function does not
+ ;; identify the address, try the next function.
+ (while (and (caar alist)
+ (null (funcall (caar alist) addr)))
+ (setq alist (cdr alist)))
+ ;; if we haven't reached the end of functions, we got a hit.
+ (when alist
+ (if printing
+ (funcall (cdar alist) addr)
+ (funcall (cdar alist) addr indent)))))
+
+(defun bbdb-format-record-name-company (record)
+ (let ((name (or (bbdb-record-name record) "???"))
+ (company (bbdb-record-company record))
+ (start (point)))
+
+ (insert name)
+ (put-text-property start (point) 'bbdb-field '(name))
+
+ (when company
+ (insert " - ")
+ (setq start (point))
+ (insert company)
+ (put-text-property start (point) 'bbdb-field '(company)))))
+
+(defun bbdb-format-record-one-line-phones (layout record phone)
+ "Insert a formatted phone number for one-line display."
+ (let ((start (point)))
+ (insert (format "%s " (aref phone 1)))
+ (put-text-property start (point) 'bbdb-field
+ (list 'phone phone (aref phone 0)))
+ (setq start (point))
+ (insert (format "(%s)" (aref phone 0)))
+ (put-text-property start (point) 'bbdb-field
+ (list 'phone phone 'field-name))))
+
+(defun bbdb-format-record-one-line-net (layout record net)
+ "Insert a formatted list of nets for one-line display."
+ (let ((start (point)))
+ (insert net)
+ (put-text-property start (point) 'bbdb-field (list 'net net))))
+
+(defun bbdb-format-record-one-line-notes (layout record notes)
+ "Insert formatted notes for one-line display.
+Line breaks will be removed and white space trimmed."
+ (let ((start (point)))
+ (insert (bbdb-replace-in-string notes "[\r\n\t ]+" " "))
+ (put-text-property start (point) 'bbdb-field (list 'notes notes))))
+
+(defun bbdb-format-record-layout-one-line (layout record field-list)
+ "Record formatting function for the one-line layout.
+See `bbdb-display-layout-alist' for more."
+ ;; name and company
+ (bbdb-format-record-name-company record)
+ (let ((name-end (or (bbdb-display-layout-get-option layout 'name-end)
+ 40))
+ start end)
+ (save-excursion
+ (setq end (point))
+ (beginning-of-line)
+ (setq start (point)))
+ (when (> (- end start -1) name-end)
+ (put-text-property (+ start name-end -4) end 'invisible t)
+ (insert "..."))
+ ;; guarantee one space after name - company
+ (insert " ")
+ (indent-to name-end))
+ ;; rest of the fields
+ (let (start field contentfun formatfun values value)
+ (while field-list
+ (setq field (car field-list)
+ contentfun (intern (concat "bbdb-record-"
+ (symbol-name field))))
+ (if (fboundp contentfun)
+ (setq values (eval (list contentfun record)))
+ (setq values (bbdb-record-getprop record field)))
+ (when (and (eq field 'net)
+ (bbdb-display-layout-get-option layout 'primary))
+ (setq values (list (car values))))
+ (when values
+ (if (not (listp values)) (setq values (list values)))
+ (setq formatfun (intern (format "bbdb-format-record-%s-%s"
+ layout field)))
+ (while values
+ (setq start (point)
+ value (car values))
+ (if (fboundp formatfun)
+ (funcall formatfun layout record value)
+ (insert (format "%s" value))
+ (cond ((eq field 'addresses)
+ (put-text-property start (point) 'bbdb-field
+ (list 'address value)))
+ ((eq field 'phones)
+ (put-text-property start (point) 'bbdb-field
+ (list 'phone value)))
+ ((memq field '(name net aka))
+ (put-text-property start (point) 'bbdb-field
+ (list field value )))
+ (t
+ (put-text-property start (point) 'bbdb-field
+ (list 'property (list field value))))))
+ (setq values (cdr values))
+ (if values (insert ", ")))
+ (insert "; "))
+ (setq field-list (cdr field-list))))
+ ;; delete the trailing "; "
+ (backward-delete-char 2)
+ (insert "\n"))
+
+(defun bbdb-format-record-layout-multi-line (layout record field-list)
+ "Record formatting function for the multi-line layout.
+See `bbdb-display-layout-alist' for more."
+ (bbdb-format-record-name-company record)
+ (insert "\n")
+ (let* ((notes (bbdb-record-raw-notes record))
+ (indent (or (bbdb-display-layout-get-option layout 'indentation) 14))
+ (fmt (format " %%%ds: " indent))
+ start field)
+ (if (stringp notes)
+ (setq notes (list (cons 'notes notes))))
+ (while field-list
+ (setq field (car field-list)
+ start (point))
+ (cond ((eq field 'phones)
+ (let ((phones (bbdb-record-phones record))
+ loc phone)
+ (while phones
+ (setq phone (car phones)
+ start (point))
+ (setq loc (format fmt (bbdb-phone-location phone)))
+ (insert loc)
+ (put-text-property start (point) 'bbdb-field
+ (list 'phone phone 'field-name))
+ (setq start (point))
+ (insert (bbdb-phone-string phone) "\n")
+ (put-text-property start (point) 'bbdb-field
+ (list 'phone phone
+ (bbdb-phone-location phone)))
+ (setq phones (cdr phones))))
+ (setq start nil))
+ ((eq field 'addresses)
+ (let ((addrs (bbdb-record-addresses record))
+ loc addr)
+ (while addrs
+ (setq addr (car addrs)
+ start (point))
+ (setq loc (format fmt (bbdb-address-location addr)))
+ (insert loc)
+ (put-text-property start (point) 'bbdb-field
+ (list 'address addr 'field-name))
+ (setq start (point))
+ (bbdb-format-address addr nil indent)
+ (put-text-property start (point) 'bbdb-field
+ (list 'address addr
+ (bbdb-address-location addr)))
+ (setq addrs (cdr addrs))))
+ (setq start nil))
+ ((eq field 'net)
+ (let ((net (bbdb-record-net record)))
+ (when net
+ (insert (format fmt "net"))
+ (put-text-property start (point) 'bbdb-field
+ '(net field-name))
+ (setq start (point))
+ (if (bbdb-display-layout-get-option layout 'primary)
+ (insert (car net) "\n")
+ (insert (mapconcat (function identity) net ", ") "\n"))
+ (put-text-property start (point) 'bbdb-field '(net)))))
+ ((eq field 'aka)
+ (let ((aka (bbdb-record-aka record)))
+ (when aka
+ (insert (format fmt "AKA"))
+ (put-text-property start (point) 'bbdb-field
+ '(aka field-name))
+ (insert (mapconcat (function identity) aka ", ") "\n")
+ (setq start (point))
+ (put-text-property start (point) 'bbdb-field '(aka)))))
+ (t
+ (let ((note (assoc field notes))
+ (indent (length (format fmt "")))
+ p notefun)
+ (when note
+ (insert (format fmt field))
+ (put-text-property start (point) 'bbdb-field
+ (list 'property note 'field-name))
+ (setq start (point))
+ (setq p (point)
+ notefun (intern (format "bbdb-format-record-%s" field)))
+ (if (fboundp notefun)
+ (insert (funcall notefun (cdr note)))
+ (insert (cdr note)))
+ (save-excursion
+ (save-restriction
+ (narrow-to-region p (1- (point)))
+ (goto-char (1+ p))
+ (while (search-forward "\n" nil t)
+ (insert (make-string indent ?\ )))))
+ (insert "\n"))
+ (put-text-property start (point) 'bbdb-field
+ (list 'property note)))))
+ (setq field-list (cdr field-list)))))
+
+(defalias 'bbdb-format-record-layout-full-multi-line
+ 'bbdb-format-record-layout-multi-line)
+
+(defalias 'bbdb-format-record-layout-pop-up-multi-line
+ 'bbdb-format-record-layout-multi-line)
+
+(defun bbdb-format-record (record &optional layout)
+ "Insert a formatted version of RECORD into the current buffer.
+
+LAYOUT can be a symbol describing a layout in
+`bbdb-display-layout-alist'. For compatibility reasons, LAYOUT can
+also be nil or t, where t stands for the one-line, and nil for the
+multi-line layout."
+ (bbdb-debug (if (bbdb-record-deleted-p record)
+ (error "plus ungood: formatting deleted record")))
+ (setq layout (cond ((eq nil layout)
+ 'multi-line)
+ ((eq t layout)
+ 'one-line)
+ ((symbolp layout)
+ layout)
+ (t
+ (error "Unknown layout `%s'" layout))))
+ (let* ((layout-spec (assoc layout bbdb-display-layout-alist))
+ (test (bbdb-display-layout-get-option layout-spec 'test))
+ (omit-list (bbdb-display-layout-get-option layout-spec 'omit))
+ (order-list (bbdb-display-layout-get-option layout-spec 'order))
+ (all-fields (append '(phones addresses net aka)
+ (let ((raw-notes (bbdb-record-raw-notes record)))
+ (if (stringp raw-notes)
+ '(notes)
+ (mapcar (lambda (r) (car r)) raw-notes)))))
+ format-function field-list)
+ (when (or (not test)
+ ;; bind some variables for the test
+ (let ((name (bbdb-record-name record))
+ (company (bbdb-record-company record))
+ (net (bbdb-record-net record))
+ (phones (bbdb-record-phones record))
+ (addresses (bbdb-record-addresses record))
+ (notes (bbdb-record-raw-notes record)))
+ ;; this must evaluate to non-nil if the record is to be shown
+ (eval test)))
+ (if (functionp omit-list)
+ (setq omit-list (funcall omit-list record layout)))
+ (if (functionp order-list)
+ (setq order-list (funcall order-list record layout)))
+ ;; first omit unwanted fields
+ (when (and omit-list (or (not order-list) (memq t order-list)))
+ (if (not (listp omit-list))
+ ;; t => show nothing
+ (setq all-fields nil)
+ ;; listp => show all fields except those listed here
+ (while omit-list
+ (setq all-fields (delete (car omit-list) all-fields)
+ omit-list (cdr omit-list)))))
+ ;; then order them
+ (if (not order-list)
+ (setq field-list all-fields)
+ (if (not (memq t order-list))
+ (setq field-list order-list)
+ (setq order-list (reverse order-list))
+ (setq all-fields (delete nil (mapcar (lambda (f)
+ (if (memq f order-list)
+ nil
+ f))
+ all-fields)))
+ (while order-list
+ (if (eq t (car order-list))
+ (setq field-list (append all-fields field-list))
+ (setq field-list (cons (car order-list) field-list)))
+ (setq order-list (cdr order-list)))))
+ ;; call the actual format function
+ (setq format-function
+ (intern (format "bbdb-format-record-layout-%s" layout)))
+ (if (functionp format-function)
+ (funcall format-function layout record field-list)
+ (bbdb-format-record-layout-multi-line layout record field-list)))))
+
+(defun bbdb-frob-mode-line (n)
+ (setq
+ ;; identification
+ mode-line-buffer-identification
+ (if (> n 0)
+ (list 24 (buffer-name) ": "
+ (list 10 (format "%d/%d" n (length (bbdb-records))))
+ '(bbdb-showing-changed-ones " !!" " "))
+ (list (buffer-name) ": Insidious Big Brother Database v" bbdb-version " "
+ mode-line-modified "-"))
+ ;; modified indicator
+ mode-line-modified
+ '(bbdb-readonly-p "--%%%%-" (bbdb-modified-p "--**-" "-----"))))
+
+(defun bbdb-display-records-1 (records &optional append layout)
+ (setq append (or append (bbdb-append-records-p)))
+
+ (if (or (null records)
+ (consp (car records)))
+ nil
+
+ ;; add layout and a marker to the local list of records
+ (setq layout (or layout bbdb-display-layout))
+ (setq records (mapcar (lambda (x)
+ (list x layout (make-marker)))
+ records)))
+
+ (let ((b (current-buffer))
+ (temp-buffer-setup-hook nil)
+ (temp-buffer-show-function nil)
+ (first (car (car records))))
+
+ ;; just quiet a warning about unused vars
+ (and temp-buffer-setup-hook temp-buffer-show-function)
+
+ (bbdb-pop-up-bbdb-buffer)
+
+ (save-excursion
+ (set-buffer bbdb-buffer-name)
+ (let ((inhibit-read-only t)) (erase-buffer))
+
+ ;; If append is set, clear the buffer, otherwise do clean up.
+ (unless append (bbdb-undisplay-records))
+
+ ;; If we're appending these records to the ones already displayed,
+ ;; then first remove any duplicates, and then sort them.
+ (if append
+ (let ((rest records))
+ (while rest
+ (if (assq (car (car rest)) bbdb-records)
+ (setq records (delq (car rest) records)))
+ (setq rest (cdr rest)))
+ (setq records (append bbdb-records records))
+ (setq records
+ (sort records
+ (lambda (x y) (bbdb-record-lessp (car x) (car y)))))))
+ (make-local-variable 'mode-line-buffer-identification)
+ (make-local-variable 'mode-line-modified)
+ (set (make-local-variable 'bbdb-showing-changed-ones) nil)
+ (let ((done nil)
+ (rest records)
+ (changed (bbdb-changed-records)))
+ (while (and rest (not done))
+ (setq done (memq (car (car rest)) changed)
+ rest (cdr rest)))
+ (setq bbdb-showing-changed-ones done))
+ (bbdb-frob-mode-line (length records))
+ (and (not bbdb-gag-messages)
+ (not bbdb-silent-running)
+ (message "Formatting..."))
+ (bbdb-mode)
+ ;; this in in the *BBDB* buffer, remember, not the .bbdb buffer.
+ (set (make-local-variable 'bbdb-records) nil)
+ (setq bbdb-records records)
+ (let ((buffer-read-only nil)
+ prs)
+ (bbdb-debug (setq prs (bbdb-records)))
+ (setq truncate-lines t)
+ (while records
+ (bbdb-debug (if (not (memq (car (car records)) prs))
+ (error "record doubleplus unpresent!")))
+ (set-marker (nth 2 (car records)) (point))
+ (bbdb-format-record (nth 0 (car records))
+ (nth 1 (car records)))
+ (setq records (cdr records))))
+ (and (not bbdb-gag-messages)
+ (not bbdb-silent-running)
+ (message "Formatting...done.")))
+ (set-buffer bbdb-buffer-name)
+ (if (and append first)
+ (let ((cons (assq first bbdb-records))
+ (window (get-buffer-window (current-buffer))))
+ (if window (set-window-start window (nth 2 cons)))))
+ (bbdbq)
+ ;; this doesn't really belong here, but it's convenient ... and when
+ ;; using electric display it would not be called otherwise.
+ (save-excursion (run-hooks 'bbdb-list-hook))
+ (if bbdb-gui (bbdb-fontify-buffer))
+ (set-buffer-modified-p nil)
+ (setq buffer-read-only t)
+ (set-buffer b)))
+
+(defun bbdb-undisplay-records ()
+ (let ((bbdb-display-buffer (get-buffer bbdb-buffer-name)))
+ (if (bufferp bbdb-display-buffer)
+ (save-excursion
+ (set-buffer bbdb-display-buffer)
+ (setq bbdb-showing-changed-ones nil
+ mode-line-modified nil
+ bbdb-records nil
+ buffer-read-only nil)
+ (erase-buffer)
+ (setq buffer-read-only t)
+ (set-buffer-modified-p nil)))))
+
+ ;;; Electric display stuff
+
+(defvar bbdb-inside-electric-display nil)
+;; hack hack: a couple of specials that the electric stuff uses for state.
+(defvar bbdb-electric-execute-me)
+(defvar bbdb-electric-completed-normally)
+
+(defun electric-bbdb-display-records (records)
+ (require 'electric)
+ (let ((bbdb-electric-execute-me nil)) ; Hack alert! throw-to-execute sets this!
+ (let ((bbdb-inside-electric-display t)
+ buffer
+ bbdb-electric-completed-normally ; Hack alert! throw-to-execute sets this!
+ )
+ (save-excursion
+ (save-window-excursion
+ (save-window-excursion (bbdb-display-records-1 records))
+ (setq buffer (window-buffer (Electric-pop-up-window bbdb-buffer-name)))
+ (set-buffer buffer)
+ (if (not bbdb-gag-messages)
+ (message "<<< Press Space to bury the Insidious Big Brother Database list >>>"))
+ (catch 'Done
+ (while t
+ (catch 'Blow-off-the-error
+ (setq bbdb-electric-completed-normally nil)
+ (unwind-protect
+ (progn
+ (catch 'electric-bbdb-list-select
+ (Electric-command-loop 'electric-bbdb-list-select
+ "-> " t))
+ (setq bbdb-electric-completed-normally t))
+ ;; protected
+ (if bbdb-electric-completed-normally
+ (throw 'Done t)
+ (ding)
+ (message "BBDB-Quit")
+ (throw 'Blow-off-the-error t)
+ )))))
+ (bury-buffer buffer))))
+ (message " ")
+ (if bbdb-electric-execute-me
+ (eval bbdb-electric-execute-me)))
+ nil)
+
+(defun bbdb-electric-throw-to-execute (form-to-execute)
+ "Exit the `electric-command-loop' and evaluate the given form."
+ ;; Hack alert! These variables are bound only within the scope of
+ ;; bbdb-electric-display-records!
+ (if (not (boundp 'bbdb-electric-execute-me))
+ (error "plusungood: electrical short"))
+ (setq bbdb-electric-execute-me form-to-execute
+ bbdb-electric-completed-normally t)
+ (throw 'electric-bbdb-list-select t))
+
+
+(defun bbdb-done-command () (interactive)
+ (throw 'electric-bbdb-list-select t))
+
+(defun bbdb-bury-buffer ()
+ (interactive)
+ (if bbdb-inside-electric-display
+ (bbdb-done-command)
+ (bury-buffer)))
+
+(defun bbdb-display-records (records &optional layout append)
+ (let ((bbdb-window (get-buffer-window bbdb-buffer-name)))
+ (if (and bbdb-electric-p
+ ;; never be electric if the buffer is already on screen.
+ (not bbdb-window))
+ (progn
+ (define-key bbdb-mode-map " " 'bbdb-done-command)
+ (electric-bbdb-display-records records))
+ (bbdb-display-records-1 records append layout)
+ ;; don't smash keybinding if they invoked `bbdb-display'
+ ;; from inside an electric loop.
+ (unless bbdb-inside-electric-display
+ (define-key bbdb-mode-map " " 'undefined))
+ (if (and (not bbdb-gag-messages)
+ (not bbdb-window))
+ (message
+ (substitute-command-keys
+ (if (one-window-p t)
+ (if pop-up-windows
+ "Type \\[delete-other-windows] to unshow the bbdb-list window."
+ "Type \\[switch-to-buffer] RET to unshow the bbdb-list window.")
+ "Type \\[switch-to-buffer-other-window] RET to restore old contents of the bbdb-list window.")))))))
+
+(defun bbdbq ()
+ (if (not (zerop (logand (random) 31))) nil
+ (let ((v '["\104\157\156\47\164\40\163\165\163\160\145\143\164\40\171\157\
+\165\162\40\156\145\151\147\150\142\157\162\72\40\162\145\160\157\162\164\40\
+\150\151\155\41" "\146\156\157\162\144" "\103\157\156\163\165\155\145\40\55\55\
+\40\102\145\40\123\151\154\145\156\164\40\55\55\40\104\151\145" "\114\157\166\
+\145\40\102\151\147\40\102\162\157\164\150\145\162" "\114\145\145\40\110\141\
+\162\166\145\171\40\117\163\167\141\154\144\40\141\143\164\145\144\40\141\154\
+\157\156\145" "\101\114\114\40\131\117\125\122\40\102\101\123\105\40\101\122\
+\105\40\102\105\114\117\116\107\40\124\117\40\125\123" "\127\141\162\40\151\
+\163\40\120\145\141\143\145" "\106\162\145\145\144\157\155\40\151\163\40\123\
+\154\141\166\145\162\171" "\111\147\156\157\162\141\156\143\145\40\151\163\40\
+\123\164\162\145\156\147\164\150" "\120\162\157\154\145\163\40\141\156\144\40\
+\141\156\151\155\141\154\163\40\141\162\145\40\146\162\145\145"]))
+ (message (aref v (% (logand 255 (random)) (length v))))
+ (message " "))))
+
+(defmacro bbdb-hashtable ()
+ '(bbdb-with-db-buffer (bbdb-records nil t) bbdb-hashtable))
+
+(defun bbdb-changed-records ()
+ (bbdb-with-db-buffer (bbdb-records nil t) bbdb-changed-records))
+
+(defmacro bbdb-build-name (f l)
+ (list 'downcase
+ (list 'if (list '= (list 'length f) 0) l
+ (list 'if (list '= (list 'length l) 0) f
+ (list 'concat f " " l)))))
+
+(defun bbdb-remove! (e l)
+ (if (null l) l
+ (let ((ret l)
+ (n (cdr l)))
+ (while n
+ (if (eq e (car n))
+ (setcdr l (cdr n)) ; skip n
+ (setq l n)) ; keep n
+ (setq n (cdr n)))
+ (if (eq e (car ret)) (cdr ret)
+ ret))))
+
+(defun bbdb-remove-memq-duplicates (l)
+ (let (ret tail)
+ (setq ret (cons '() '())
+ tail ret)
+ (while l
+ (if (not (memq (car l) ret))
+ (setq tail (setcdr tail (cons (car l) '()))))
+ (setq l (cdr l)))
+ (cdr ret)))
+
+(defmacro bbdb-gethash (name &optional ht)
+ (list 'symbol-value
+ (list 'intern-soft name
+ (or ht '(bbdb-hashtable)))))
+
+(defmacro bbdb-puthash (name record &optional ht)
+ (list 'let (list (list 'sym (list 'intern name (or ht '(bbdb-hashtable)))))
+ (list 'set 'sym (list 'cons record
+ '(and (boundp sym) (symbol-value sym))))))
+
+(defmacro bbdb-remhash (name record &optional ht)
+ (list 'let (list (list 's (list 'intern-soft name
+ (or ht '(bbdb-hashtable)))))
+ (list 'and 's (list 'set 's (list 'bbdb-remove! record
+ (list 'symbol-value 's))))))
+
+(defsubst bbdb-search-intertwingle (name net)
+ "Find bbdb records matching NAME and NET.
+
+This is a more stringent version of bbdb-search-simple, which I am
+not inclined to modify for fear of damaging other code that currently
+relies on it. BBDB internals should be migrated to use this function
+to identify which record is referred to by a name/net combination,
+since search-simple has been overloaded with other functionality.
+
+The name comes from
+http://www.mozilla.org/blue-sky/misc/199805/intertwingle.html, which
+any budding BBDB hacker should be at least vaguely familiar with."
+ (bbdb-records t)
+ (if name (setq name (downcase name)))
+ (if net (setq net (downcase net))
+ (setq net ""))
+ (let ((net-recs (bbdb-gethash (downcase net)))
+ recs)
+ (while net-recs
+ (if (or (and (not name) net)
+ (string= name (downcase (bbdb-record-name (car net-recs)))))
+ (add-to-list 'recs (car net-recs)))
+ (setq net-recs (cdr net-recs)))
+ recs))
+
+(defsubst bbdb-search-simple (name net)
+ "name is a string; net is a string or list of strings."
+ (if (eq 0 (length name)) (setq name nil))
+ (if (eq 0 (length net)) (setq net nil))
+ (bbdb-records t) ; make sure db is parsed; don't check disk (faster)
+ (let ((name-recs (if name ;; filter out companies from hash
+ (let ((recs (bbdb-gethash (downcase name)))
+ answer)
+ (while recs
+ (let ((n-rec (car recs)))
+ (if (string= (downcase name)
+ (downcase
+ (or (bbdb-record-name
+ n-rec)
+ (bbdb-record-company
+ n-rec)
+ "")))
+ (setq answer (append recs (list n-rec))))
+ (setq recs (cdr recs))))
+ answer)))
+ (net-recs (if (stringp net) (bbdb-gethash (downcase net))
+ (let (answer)
+ (while (and net (null answer))
+ (setq answer (bbdb-gethash (downcase (car net)))
+ net (cdr net)))
+ answer)))
+ ret)
+ (if (not (and name-recs net-recs))
+ (or (and name-recs (car name-recs))
+ (and net-recs (car net-recs)))
+
+ (while name-recs
+ (let ((name-rec (car name-recs))
+ (nets net-recs))
+ (while nets
+ (if (eq (car nets) name-rec)
+ (setq nets '()
+ name-recs '()
+ ret name-rec)
+ (setq nets (cdr nets))))
+ (if name-recs (setq name-recs (cdr name-recs))
+ name-rec)))
+ ret)))
+
+(defun bbdb-net-convert (record)
+ "Given a record whose net field is a comma-separated string, convert it to
+a list of strings (the new way of doing things.) Returns the new list."
+ (bbdb-record-set-net record (bbdb-split (bbdb-record-net record) ",")))
+
+(defun bbdb-split (string separators)
+ "Return a list by splitting STRING at SEPARATORS.
+The inverse function of `bbdb-join'."
+ (let (result
+ (not-separators (concat "^" separators)))
+ (save-excursion
+ (set-buffer (get-buffer-create " *split*"))
+ (erase-buffer)
+ (insert string)
+ (goto-char (point-min))
+ (while (progn
+ (skip-chars-forward separators)
+ (skip-chars-forward " \t\n\r")
+ (not (eobp)))
+ (let ((begin (point))
+ p)
+ (skip-chars-forward not-separators)
+ (setq p (point))
+ (skip-chars-backward " \t\n\r")
+ (setq result (cons (buffer-substring begin (point)) result))
+ (goto-char p)))
+ (erase-buffer))
+ (nreverse result)))
+
+(defun bbdb-join (list separator)
+ "Join a LIST to a string where the list elements are separated by SEPARATOR.
+The inverse function of `bbdb-split'."
+ (when list
+ (mapconcat 'identity list separator)))
+
+(defsubst bbdb-hash-record (record)
+ "Insert the record in the appropriate hashtables. This must be called
+while the .bbdb buffer is selected."
+ (let ((name (bbdb-record-name-1 record)) ; faster version
+ (lfname (bbdb-record-lfname record))
+ (company (bbdb-record-company record))
+ (aka (bbdb-record-aka record))
+ (net (bbdb-record-net record)))
+ (if (> (length name) 0)
+ (bbdb-puthash (downcase name) record bbdb-hashtable))
+ (if (> (length lfname) 0)
+ (bbdb-puthash (downcase lfname) record bbdb-hashtable))
+ (if (> (length company) 0)
+ (bbdb-puthash (downcase company) record bbdb-hashtable))
+ (while aka
+ (bbdb-puthash (downcase (car aka)) record bbdb-hashtable)
+ (setq aka (cdr aka)))
+ (while net
+ (bbdb-puthash (downcase (car net)) record bbdb-hashtable)
+ (setq net (cdr net)))))
+
+
+;;; Reading the BBDB
+
+(defvar inside-bbdb-records nil
+ "Internal variable. Do not touch.")
+
+(defvar bbdb-write-file-hooks '(bbdb-write-file-hook-fn)
+ "*The list of functions added to `local-write-file-hooks' in `bbdb-file'.")
+
+(defun bbdb-records (&optional dont-check-disk already-in-db-buffer)
+ "Return a list of all bbdb records; read in and parse the db if necessary.
+This also notices if the disk file has changed out from under us, unless
+optional arg DONT-CHECK-DISK is non-nil (which is faster, but hazardous.)"
+ (if inside-bbdb-records
+ (let ((debug-on-error t))
+ (error "catastrophic: bbdb-records recursed")))
+ (let ((inside-bbdb-records t)
+ (buf (if already-in-db-buffer (current-buffer) (bbdb-buffer)))
+ shut-up)
+ (with-current-buffer buf
+ ;; make sure the BBDB in memory is not out of synch with disk.
+ (cond (dont-check-disk nil)
+ ((verify-visited-file-modtime buf) nil)
+ ((and bbdb-auto-revert-p (not (buffer-modified-p buf)))
+ (message "BBDB has changed on disk, reverting...")
+ (setq shut-up t)
+ (revert-buffer t t))
+ ;; hassle the user
+ ((bbdb-yes-or-no-p
+ (if (buffer-modified-p buf)
+ "BBDB has changed on disk; flush your changes and revert? "
+ "BBDB has changed on disk; revert? "))
+ (or (file-exists-p bbdb-file)
+ (error "bbdb: file %s no longer exists!!" bbdb-file))
+ (revert-buffer t t))
+ ;; this is the case where the .bbdb file has changed; the buffer
+ ;; has changed as well; and the user has answered "no" to the
+ ;; "flush your changes and revert" question. The only other
+ ;; alternative is to save the file right now. If they answer
+ ;; no to the following question, they will be asked the
+ ;; preceeding question again and again some large (but finite)
+ ;; number of times. `bbdb-records' is called a lot, you see...
+ ((buffer-modified-p buf)
+ ;; this prompts
+ (bbdb-save-db t t))
+ ;; otherwise, the buffer and file are inconsistent, but we let
+ ;; them stay that way.
+ )
+ (unless (assq 'bbdb-records (buffer-local-variables))
+ (set (make-local-variable 'bbdb-records) nil)
+ (set (make-local-variable 'bbdb-changed-records) nil)
+ (set (make-local-variable 'bbdb-end-marker) nil)
+ (set (make-local-variable 'bbdb-hashtable) nil)
+ (set (make-local-variable 'bbdb-propnames) nil)
+ (set (make-local-variable 'revert-buffer-function)
+ 'bbdb-revert-buffer)
+ (bbdb-mapc (lambda (ff) (add-hook 'local-write-file-hooks ff))
+ bbdb-write-file-hooks)
+ (setq bbdb-hashtable (make-vector bbdb-hashtable-size 0)))
+ (setq bbdb-modified-p (buffer-modified-p)
+ buffer-read-only bbdb-readonly-p)
+ (or bbdb-records
+ (cond ((= (point-min) (point-max)) ; special-case empty db
+ ;; this doesn't need to be insert-before-markers because
+ ;; there are no db-markers in this buffer.
+ (insert (format ";; -*-coding: %s;-*-\n;;; file-version: %d\n"
+ bbdb-file-coding-system bbdb-file-format))
+ (bbdb-flush-all-caches)
+ (setq bbdb-end-marker (point-marker))
+ ;;(run-hooks 'bbdb-after-read-db-hook) ; run this?
+ nil)
+ (t
+ (or shut-up bbdb-silent-running (message "Parsing BBDB..."))
+ (bbdb-flush-all-caches)
+ (cond ((and bbdb-notice-auto-save-file
+ (file-newer-than-file-p (make-auto-save-file-name)
+ buffer-file-name))
+ (if (bbdb-yes-or-no-p "BBDB auto-save file is newer; recover it? ")
+ (progn
+ (recover-file buffer-file-name)
+ (bury-buffer (current-buffer)) ; recover-file selects it
+ (auto-save-mode 1) ; turn autosave back on
+ (delete-file (make-auto-save-file-name))
+ (message "Auto-save mode is ON in BBDB buffer. Suggest you save it soon.")
+ (sleep-for 2))
+ ;; delete auto-save anyway, so we don't keep asking.
+ (condition-case nil
+ (delete-file (make-auto-save-file-name))
+ (file-error nil)))
+ ;; tail-recurse and try again
+ (let ((inside-bbdb-records nil))
+ (bbdb-records)))
+ (t
+ ;; normal case
+ (fillarray bbdb-hashtable 0)
+ (parse-bbdb-internal)))))))))
+
+(defun bbdb-revert-buffer (arg noconfirm)
+ ;; The .bbdb file's revert-buffer-function.
+ ;; Don't even think of calling this.
+ (kill-all-local-variables) ; clear db and caches.
+ (if (get-buffer bbdb-buffer-name) ; now contains invalid records; nukem.
+ (bbdb-undisplay-records))
+ (let ((revert-buffer-function nil)) ; don't loop.
+ (revert-buffer arg noconfirm)))
+
+(defun parse-bbdb-internal ()
+ (bbdb-debug (message "Parsing BBDB... (reading...)"))
+ (widen)
+ (goto-char (point-min))
+ ;; go to the point at which the first record begins
+ (cond ((eq (following-char) ?\[) nil)
+ ((search-forward "\n[" nil 0) (forward-char -1))
+ (t nil)) ;; no records
+ ;; look backwards for user-defined field names (for completion purposes.)
+ (save-excursion
+ (if (re-search-backward "^;+[ \t]*user-fields:[ \t]*\(" nil t)
+ (progn
+ (goto-char (1- (match-end 0)))
+ (setq bbdb-propnames
+ (mapcar (lambda (x) (list (symbol-name x)))
+ (read (point-marker)))))))
+ ;; look backwards for file version, and convert if necessary.
+ ;; (at least, I'll write this code if I ever change the file format again...)
+ (let ((v (save-excursion
+ (if (re-search-backward
+ "^;+[ \t]*file-version:[ \t]*\\([0-9]+\\)[ \t]*$" nil t)
+ (car (read-from-string
+ (buffer-substring
+ (match-beginning 1) (match-end 1))))))))
+ (if (null v) ; current version, but no file-version: line. Bootstrap it.
+ (let ((modp (buffer-modified-p)))
+ ;; This should never happen (not any more, anyway...)
+ (bbdb-debug (error "bbdb corrupted: no file-version line"))
+ (setq v 2)
+ (save-excursion
+ (if (re-search-backward "^;" nil t)
+ (forward-line 1)
+ (goto-char 1))
+ ;; remember, this goes before the begin-marker of the first
+ ;; record in the database!
+ (insert-before-markers
+ (format ";; -*-coding: %s;-*-\n;;; file-version: %d\n"
+ bbdb-file-coding-system bbdb-file-format)))
+ (set-buffer-modified-p modp)))
+ (cond ((< v bbdb-file-format)
+ (if bbdb-file-format-migration
+ ;; Sanity checking.
+ (if (/= (car bbdb-file-format-migration) v)
+ (error
+ (format
+ "BBDB file format has changed on disk from %d to %d!"
+ (car bbdb-file-format-migration) v)))
+ (setq bbdb-file-format-migration
+ (cons v (bbdb-migration-query v)))))
+ ((> v bbdb-file-format)
+ (error "BBDB version %s doesn't understand file format version %s."
+ bbdb-version v))
+ (t (setq bbdb-file-format-migration (cons bbdb-file-format
+ bbdb-file-format)))))
+ ;; A trap to catch a bug
+ ;;(assert (not (null (car bbdb-file-format-migration))))
+
+ (bbdb-debug
+ (or (eobp) (looking-at "[\[]")
+ (error "no following bracket: bbdb corrupted"))
+ (if (save-excursion
+ (save-restriction
+ (widen)
+ (save-excursion (search-backward "\n[" nil t))))
+ (error "bbdb corrupted: records before point")))
+
+ ;; Migrate only if we need to. Change the .bbdb buffer only if it
+ ;; is not to be saved in the newest version.
+ (if (= (car bbdb-file-format-migration) bbdb-file-format)
+ (parse-bbdb-frobnicate (parse-bbdb-read))
+ (let ((newrecs (parse-bbdb-frobnicate (bbdb-migrate (parse-bbdb-read)))))
+ (cond ((= (cdr bbdb-file-format-migration) bbdb-file-format)
+ (bbdb-migrate-rewrite-all nil newrecs)
+ (bbdb-migrate-update-file-version
+ (car bbdb-file-format-migration)
+ (cdr bbdb-file-format-migration))))
+ newrecs)))
+
+(defun parse-bbdb-read ()
+ ;; narrow the buffer to skip over the rubbish before the first record.
+ (narrow-to-region (point) (point-max))
+ (let ((records nil))
+ ;; insert parens so we can read the db in one fell swoop (down in C).
+ (let ((buffer-read-only nil)
+ (modp (buffer-modified-p))
+ ;; Make sure those parens get cleaned up.
+ ;; This code had better stay simple!
+ (inhibit-quit t))
+ (goto-char (point-min)) (insert "(\n")
+ (goto-char (point-max)) (insert "\n)")
+ (goto-char (point-min))
+ (setq records (read (current-buffer)))
+ (goto-char (point-min)) (delete-char 2)
+ (goto-char (point-max)) (delete-char -2)
+ (set-buffer-modified-p modp))
+ records))
+
+(defun parse-bbdb-frobnicate (records)
+ ;; now we have to come up with a marker for each record. Rather than
+ ;; calling read for each record, we read them at once (already done) and
+ ;; assume that the markers are at each newline. If this isn't the case,
+ ;; things can go *very* wrong.
+ (goto-char (point-min))
+ (while (looking-at "[ \t\n\f]*;")
+ (forward-line 1))
+ (widen)
+ (bbdb-debug (message "Parsing BBDB... (frobnicating...)"))
+ (setq bbdb-records records)
+ (let* ((head (cons '() records))
+ (rest head)
+ record)
+ (while (cdr rest)
+ (setq record (car (cdr rest)))
+ ;; yow, are we stack-driven yet?? Damn byte-compiler...
+ ;; Make a cache. Put it in the record. Put a marker in the cache.
+ ;; Add record to hash tables.
+ (bbdb-cache-set-marker
+ (bbdb-record-set-cache record (make-vector bbdb-cache-length nil))
+ (point-marker))
+ (forward-line 1)
+
+ ;; frob the label completion lists (and data completion when I,
+ ;; uh, get around to it, maybe. this stuff should probably be
+ ;; conditional, in case you're not running a 42GHz Pentium 69
+ ;; with chrome tailpipes)
+ (let ((ps (bbdb-record-phones record))
+ (pl (bbdb-label-completion-list "phones"))
+ (as (bbdb-record-addresses record))
+ (al (bbdb-label-completion-list "addresses")))
+ (while ps
+ (let ((l (bbdb-phone-location (car ps))))
+ (or (member l pl)
+ (setq bbdb-phones-label-list
+ (append (or bbdb-phones-label-list
+ bbdb-default-label-list)
+ (list l))
+ pl bbdb-phones-label-list)))
+ (setq ps (cdr ps)))
+ ;; Yes, I cut and pasted.
+ (while as
+ (let ((l (bbdb-address-location (car as))))
+ (or (member l al)
+ (setq bbdb-addresses-label-list
+ (append (or bbdb-addresses-label-list
+ bbdb-default-label-list)
+ (list l))
+ al bbdb-addresses-label-list)))
+ (setq as (cdr as))))
+
+ (if bbdb-no-duplicates-p
+ ;; warn the user that there is a duplicate...
+ (let* ((name (bbdb-record-name record))
+ (tmp (and name (bbdb-gethash (downcase name)
+ bbdb-hashtable))))
+ (if tmp (message "Duplicate BBDB record encountered: %s" name))))
+
+ (bbdb-hash-record record)
+ (setq rest (cdr rest))
+
+ (bbdb-debug
+ (if (and (cdr rest) (not (looking-at "[\[]")))
+ (error "bbdb corrupted: junk between records at %s" (point)))))
+ ;; In case we removed some of the leading entries...
+ (setq bbdb-records (cdr head)))
+ ;; all done.
+ (setq bbdb-end-marker (point-marker))
+ (run-hooks 'bbdb-after-read-db-hook)
+ (bbdb-debug (message "Parsing BBDB... (frobnicating...done)"))
+ bbdb-records)
+
+(defmacro bbdb-user-mail-names ()
+ "Returns a regexp matching the address of the logged-in user."
+ '(or bbdb-user-mail-names
+ (setq bbdb-user-mail-names
+ (concat "\\b" (regexp-quote (user-login-name)) "\\b"))))
+
+(defun bbdb-write-file-hook-fn ()
+ "This is just for `bbdb-write-file-hooks'. Keep it there."
+ ;; this is premature as the file isn't actually written yet; but it's just
+ ;; for the benefit of the mode-line of the *BBDB* buffer, and there isn't
+ ;; an after-write-file-hook, so it'll do.
+ (save-restriction
+ (widen)
+ (goto-char (point-min))
+
+ ;; this always rewrites the coding cookie, which is a bit
+ ;; wasteful, but safer than alternatives
+ (if (looking-at ";; *-\\*-coding:")
+ (delete-region (point) (progn (forward-line) (point))))
+ (insert-before-markers (format ";; -*-coding: %s;-*-\n"
+ bbdb-file-coding-system)))
+ (setq bbdb-modified-p nil
+ bbdb-changed-records nil
+ buffer-file-coding-system bbdb-file-coding-system)
+ (let ((buf (get-buffer bbdb-buffer-name)))
+ (when buf
+ (with-current-buffer buf
+ (setq bbdb-showing-changed-ones nil)
+ (set-buffer-modified-p nil))))
+ (when (and bbdb-file-remote
+ (or bbdb-file-remote-save-always
+ (y-or-n-p (format "Save the remote BBDB file %s too? "
+ bbdb-file-remote))))
+ ;; write the current buffer, which is `bbdb-file' (since this is called
+ ;; from its `local-write-file-hooks'), into the `bbdb-file-remote'.
+ (let ((coding-system-for-write bbdb-file-coding-system))
+ (write-region (point-min) (point-max) bbdb-file-remote))))
+
+(defun bbdb-delete-record-internal (record)
+ (if (null (bbdb-record-marker record)) (error "bbdb: marker unpresent"))
+ (bbdb-with-db-buffer
+ (if (or bbdb-suppress-changed-records-recording
+ (memq record bbdb-changed-records))
+ nil
+ (setq bbdb-changed-records (cons record bbdb-changed-records)))
+ (let ((tail (memq record bbdb-records)))
+ (if (null tail) (error "bbdb: unfound %s" record))
+ (setq bbdb-records (delq record bbdb-records))
+ (delete-region (bbdb-record-marker record)
+ (if (cdr tail)
+ (bbdb-record-marker (car (cdr tail)))
+ bbdb-end-marker))
+ (let ((name (bbdb-record-name record))
+ (lfname (bbdb-record-lfname record))
+ (company (bbdb-record-company record))
+ (aka (bbdb-record-aka record))
+ (nets (bbdb-record-net record)))
+ (if (> (length name) 0)
+ (bbdb-remhash (downcase name) record bbdb-hashtable))
+ (if (> (length company) 0)
+ (bbdb-remhash (downcase company) record bbdb-hashtable))
+ (if (> (length lfname) 0)
+ (bbdb-remhash (downcase lfname) record bbdb-hashtable))
+ (while nets
+ (bbdb-remhash (downcase (car nets)) record bbdb-hashtable)
+ (setq nets (cdr nets)))
+ (while aka
+ (bbdb-remhash (downcase (car aka)) record bbdb-hashtable)
+ (setq aka (cdr aka)))
+ )
+ (bbdb-record-set-sortkey record nil)
+ (setq bbdb-modified-p t))))
+
+(defun bbdb-insert-sorted (record records)
+ "Inserts the RECORD into the list of RECORDS, in order.
+Assumes the list is already sorted. Returns the new head."
+ (bbdb-debug (if (memq record records)
+ (error "doubleplus ununique: - %s" record)))
+ (let* ((rest (cons nil records))
+ (top rest))
+ (while (and (cdr rest)
+ (bbdb-record-lessp (nth 1 rest) record))
+ (setq rest (cdr rest)))
+ (setcdr rest (cons record (cdr rest)))
+ (cdr top)))
+
+(defun bbdb-insert-record-internal (record unmigrated)
+ (if (null (bbdb-record-marker record))
+ (bbdb-record-set-marker record (make-marker)))
+ (bbdb-with-db-buffer
+ (if (or bbdb-suppress-changed-records-recording
+ (memq record bbdb-changed-records))
+ nil
+ (setq bbdb-changed-records (cons record bbdb-changed-records)))
+ (let ((print-escape-newlines t))
+ (bbdb-record-set-sortkey record nil) ; just in case...
+ (setq bbdb-records
+ (bbdb-insert-sorted record bbdb-records))
+ (let ((next (car (cdr (memq record bbdb-records)))))
+ (goto-char (if next
+ (bbdb-record-marker next)
+ bbdb-end-marker))
+ ;; before printing the record, remove the cache \(we don't want that
+ ;; written to the file.\) Ater writing, put the cache back and update
+ ;; the cache's marker.
+ (let ((cache (bbdb-record-cache record))
+ (point (point)))
+ (bbdb-debug
+ (if (= point (point-min))
+ (error "doubleplus ungood: inserting at point-min (%s)" point))
+ (if (and (/= point bbdb-end-marker)
+ (not (looking-at "[\[]")))
+ (error "doubleplus ungood: not inserting before a record (%s)"
+ point)))
+ (bbdb-record-set-cache record nil)
+ (if unmigrated (bbdb-record-set-cache unmigrated nil))
+ (insert-before-markers (bbdb-prin1-to-string (or unmigrated record)) "\n")
+ (set-marker (bbdb-cache-marker cache) point)
+ (bbdb-record-set-cache record cache)
+;; (if (bbdb-record-name record)
+;; (bbdb-puthash (downcase (bbdb-record-name record)) record bbdb-hashtable))
+;; (let ((nets (bbdb-record-net record)))
+;; (while nets
+;; (bbdb-puthash (downcase (car nets)) record bbdb-hashtable)
+;; (setq nets (cdr nets))))
+ ;; This is marginally slower because it rebuilds the namecache,
+ ;; but it makes jbw's life easier. :-\)
+ (bbdb-hash-record record))
+ record))
+ (setq bbdb-modified-p t)))
+
+(defun bbdb-overwrite-record-internal (record unmigrated)
+ (bbdb-with-db-buffer
+ (if (or bbdb-suppress-changed-records-recording
+ (memq record bbdb-changed-records))
+ nil
+ (setq bbdb-changed-records (cons record bbdb-changed-records)))
+ (let ((print-escape-newlines t)
+ (tail bbdb-records))
+ ;; Look for record after RECORD in the database. Use the
+ ;; beginning marker of this record (or the marker for the end of
+ ;; the database if no next record) to determine where to stop
+ ;; deleting old copy of record
+ (while (and tail (not (eq record (car tail))))
+ (setq tail (cdr tail)))
+ (if (null tail) (error "bbdb: unfound %s" record))
+ (let ((cache (bbdb-record-cache record)))
+
+ (bbdb-debug
+ (if (<= (bbdb-cache-marker cache) (point-min))
+ (error "doubleplus ungood: cache marker is %s"
+ (bbdb-cache-marker cache)))
+ (goto-char (bbdb-cache-marker cache))
+ (if (and (/= (point) bbdb-end-marker)
+ (not (looking-at "[\[]")))
+ (error "doubleplus ungood: not inserting before a record (%s)"
+ (point))))
+
+ (goto-char (bbdb-cache-marker cache))
+ (bbdb-record-set-cache record nil)
+ (if unmigrated (bbdb-record-set-cache unmigrated nil))
+
+ (insert (bbdb-prin1-to-string (or unmigrated record)) "\n")
+ (delete-region (point)
+ (if (cdr tail)
+ (bbdb-record-marker (car (cdr tail)))
+ bbdb-end-marker))
+ (bbdb-record-set-cache record cache)
+
+ (bbdb-debug
+ (if (<= (if (cdr tail)
+ (bbdb-record-marker (car (cdr tail)))
+ bbdb-end-marker)
+ (bbdb-record-marker record))
+ (error "doubleplus ungood: overwrite unworks")))
+
+ (setq bbdb-modified-p t)
+ record))))
+
+(defvar inside-bbdb-change-record nil "hands off")
+(defvar inside-bbdb-notice-hook nil
+ "Internal variable; hands off.
+Set to t by the BBDB when inside the `bbdb-notice-hook'.
+
+Calls to the `bbdb-change-hook' are suppressed when this is non-nil.")
+
+(defun bbdb-change-record (record need-to-sort)
+ "Update the database after a change to the given record. Second arg
+NEED-TO-SORT is whether the name has changed. You still need to worry
+about updating the name hash-table."
+ (if inside-bbdb-change-record
+ record
+ (let ((inside-bbdb-change-record t)
+ unmigrated)
+ (or inside-bbdb-notice-hook
+ (bbdb-invoke-hook 'bbdb-change-hook record))
+ (bbdb-debug (if (bbdb-record-deleted-p record)
+ (error "bbdb: changing deleted record")))
+ (if (/= (cdr bbdb-file-format-migration) bbdb-file-format)
+ (bbdb-unmigrate-record (setq unmigrated (bbdb-copy-thing record))))
+ ;; Do the changing
+ (if (memq record (bbdb-records)) ; checks file synchronization too.
+ (if (not need-to-sort) ;; If we don't need to sort, overwrite it.
+ (progn
+ (bbdb-overwrite-record-internal record unmigrated)
+ (bbdb-debug
+ (if (not (memq record (bbdb-records)))
+ (error "Overwrite in change doesn't work"))))
+ ;; Since we do need to sort, delete then insert
+ (bbdb-delete-record-internal record)
+ (bbdb-debug
+ (if (memq record (bbdb-records))
+ (error "Delete in need-sort change doesn't work")))
+ (bbdb-insert-record-internal record unmigrated)
+ (bbdb-debug
+ (if (not (memq record (bbdb-records)))
+ (error "Insert in need-sort change doesn't work"))))
+ ;; Record isn't in database so add it.
+ (bbdb-insert-record-internal record unmigrated)
+ (bbdb-debug (if (not (memq record (bbdb-records)))
+ (error "Insert in change doesn't work"))))
+ (setq bbdb-modified-p t)
+ (bbdb-invoke-hook 'bbdb-after-change-hook record)
+ record)))
+
+(defun bbdb-copy-thing (thing)
+ "Copy a thing. Handles vectors, strings, markers, numbers, conses,
+lists, symbols, and nil. Raises an error if it finds something it
+doesn't know how to deal with."
+ (cond ((vectorp thing)
+ (let ((i 0)
+ (newvec (make-vector (length thing) nil)))
+ (while (< i (length thing))
+ (aset newvec i (bbdb-copy-thing (aref thing i)))
+ (setq i (1+ i)))
+ newvec))
+ ((stringp thing)
+ (copy-sequence thing))
+ ((markerp thing)
+ (copy-marker thing))
+ ((numberp thing)
+ thing)
+ ((consp thing)
+ (cons (bbdb-copy-thing (car thing))
+ (bbdb-copy-thing (cdr thing))))
+ ((listp thing)
+ (let ((i 0) newlist)
+ (while (< i (length thing))
+ (setq newlist (append newlist (list (bbdb-copy-thing
+ (nth i thing))))
+ i (1+ i)))
+ newlist))
+ ((symbolp thing)
+ thing)
+ ((eq nil thing)
+ nil)
+ (t
+ (error "Don't know how to copy %s" (prin1-to-string thing)))))
+
+(defmacro bbdb-propnames ()
+ '(bbdb-with-db-buffer bbdb-propnames))
+
+(defun bbdb-set-propnames (newval)
+ (bbdb-with-db-buffer
+ (setq bbdb-propnames newval)
+ (widen)
+ (goto-char (point-min))
+ (and (not (eq (following-char) ?\[))
+ (search-forward "\n[" nil 0))
+ (if (re-search-backward "^[ \t]*;+[ \t]*user-fields:[ \t]*\(" nil t)
+ (progn
+ (goto-char (1- (match-end 0)))
+ (delete-region (point) (progn (end-of-line) (point))))
+ (and (re-search-backward "^[ \t]*;.*\n" nil t)
+ (goto-char (match-end 0)))
+ ;; remember, this goes before the begin-marker of the first
+ ;; record in the database!
+ (insert-before-markers ";;; user-fields: \n")
+ (forward-char -1))
+ (bbdb-prin1 (mapcar (lambda (x) (intern (car x)))
+ bbdb-propnames)
+ (current-buffer))
+ bbdb-propnames))
+
+
+;;; BBDB mode
+
+(defun bbdb-mode ()
+ "Major mode for viewing and editing the Insidious Big Brother Database.
+Letters no longer insert themselves. Numbers are prefix arguments.
+You can move around using the usual cursor motion commands.
+\\<bbdb-mode-map>
+\\[bbdb-add-or-remove-mail-alias]\t Add new mail alias to visible records or \
+remove it.
+\\[bbdb-edit-current-field]\t Edit the field on the current line.
+\\[bbdb-record-edit-notes]\t Edit the `notes' field for the current record.
+\\[bbdb-delete-current-field-or-record]\t Delete the field on the \
+current line. If the current line is the\n\t first line of a record, then \
+delete the entire record.
+\\[bbdb-insert-new-field]\t Insert a new field into the current record. \
+Note that this\n\t will let you add new fields of your own as well.
+\\[bbdb-transpose-fields]\t Swap the field on the current line with the \
+previous field.
+\\[bbdb-dial]\t Dial the current phone field.
+\\[bbdb-next-record], \\[bbdb-prev-record]\t Move to the next or the previous \
+displayed record, respectively.
+\\[bbdb-create]\t Create a new record.
+\\[bbdb-toggle-records-display-layout]\t Toggle whether the current record is displayed in a \
+one-line\n\t listing, or a full multi-line listing.
+\\[bbdb-apply-next-command-to-all-records]\\[bbdb-toggle-records-display-layout]\t Do that \
+for all displayed records.
+\\[bbdb-refile-record]\t Merge the contents of the current record with \
+some other, and then\n\t delete the current record. See this command's \
+documentation.
+\\[bbdb-omit-record]\t Remove the current record from the display without \
+deleting it from\n\t the database. This is often a useful thing to do \
+before using one\n\t of the `*' commands.
+\\[bbdb]\t Search for records in the database (on all fields).
+\\[bbdb-net]\t Search for records by net address.
+\\[bbdb-company]\t Search for records by company.
+\\[bbdb-notes]\t Search for records by note.
+\\[bbdb-name]\t Search for records by name.
+\\[bbdb-changed]\t Display records that have changed since the database \
+was saved.
+\\[bbdb-send-mail]\t Compose mail to the person represented by the \
+current record.
+\\[bbdb-apply-next-command-to-all-records]\\[bbdb-send-mail]\t Compose mail \
+to everyone whose record is displayed.
+\\[bbdb-finger]\t Finger the net address of the current record.
+\\[bbdb-ftp]\t FTP to the curent records's `ftp' field.
+\\[bbdb-apply-next-command-to-all-records]\\[bbdb-finger]\t Finger the \
+net address of all displayed records.
+\\[bbdb-save-db]\t Save the BBDB file to disk.
+\\[bbdb-print]\t Create a TeX file containing a pretty-printed version \
+of all the\n\t records in the database.
+\\[bbdb-apply-next-command-to-all-records]\\[bbdb-print]\t Do that for the \
+displayed records only.
+\\[other-window]\t Move to another window.
+\\[bbdb-info]\t Read the Info documentation for BBDB.
+\\[bbdb-help]\t Display a one line command summary in the echo area.
+\\[bbdb-www]\t Visit Web sites listed in the `www' field(s) of the current \
+record.
+\\[bbdb-whois]\t run whois on the current record.
+
+For address completion using the names and net addresses in the database:
+\t in Sendmail mode, type \\<mail-mode-map>\\[bbdb-complete-name].
+\t in Message mode, type \\<message-mode-map>\\[bbdb-complete-name].
+
+Variables of note:
+\t bbdb-always-add-addresses
+\t bbdb-auto-revert-p
+\t bbdb-canonicalize-redundant-nets-p
+\t bbdb-case-fold-search
+\t bbdb-completion-type
+\t bbdb-default-area-code
+\t bbdb-default-domain
+\t bbdb-electric-p
+\t bbdb-display-layout
+\t bbdb-file
+\t bbdb-message-caching-enabled
+\t bbdb-new-nets-always-primary
+\t bbdb-north-american-phone-numbers-p
+\t bbdb-notice-auto-save-file
+\t bbdb-offer-save
+\t bbdb-pop-up-display-layout
+\t bbdb-pop-up-target-lines
+\t bbdb-quiet-about-name-mismatches
+\t bbdb-readonly-p
+\t bbdb-use-alternate-names
+\t bbdb-use-pop-up
+\t bbdb-user-mail-names
+\t bbdb/mail-auto-create-p
+\t bbdb/news-auto-create-p
+
+There are numerous hooks. M-x apropos ^bbdb.*hook RET
+
+The keybindings, more precisely:
+\\{bbdb-mode-map}"
+ (setq major-mode 'bbdb-mode)
+ (setq mode-name "BBDB")
+ (use-local-map bbdb-mode-map)
+ (run-hooks 'bbdb-mode-hook))
+
+;;; these should be in bbdb-com.el but they're so simple, why load it all.
+
+(defun bbdb-next-record (p)
+ "Move the cursor to the first line of the next BBDB record."
+ (interactive "p")
+ (if (< p 0)
+ (bbdb-prev-record (- p))
+ (forward-char)
+ (while (> p 0)
+ (or (re-search-forward "^[^ \t\n]" nil t)
+ (progn (beginning-of-line)
+ (error "no next record")))
+ (setq p (1- p)))
+ (beginning-of-line)))
+
+(defun bbdb-prev-record (p)
+ "Move the cursor to the first line of the previous BBDB record."
+ (interactive "p")
+ (if (< p 0)
+ (bbdb-next-record (- p))
+ (while (> p 0)
+ (or (re-search-backward "^[^ \t\n]" nil t)
+ (error "no previous record"))
+ (setq p (1- p)))))
+
+
+(defun bbdb-maybe-update-display (bbdb-record)
+ (save-excursion
+ (save-window-excursion
+ (let ((w (get-buffer-window bbdb-buffer-name))
+ (b (current-buffer)))
+ (if w
+ (unwind-protect
+ (progn (set-buffer bbdb-buffer-name)
+ (save-restriction
+ (if (assq bbdb-record bbdb-records)
+ (bbdb-redisplay-records))))
+ (set-buffer b)))))))
+
+(defcustom bbdb-notes-default-separator ", "
+ "*The default separator inserted by `bbdb-annotate-notes'.
+This is used for notes which do not have `field-separator' property set.
+E.g., if you want URLs to be separated by newlines, you can put
+ (put 'www 'field-separator \"\\n\")
+into your .emacs."
+ :group 'bbdb-noticing-records
+ :type 'string)
+
+(defun bbdb-annotate-notes (bbdb-record annotation &optional fieldname replace)
+ "Add an annotation to a record.
+Adds (or replaces, when the fourth argument REPLACE is non-nil)
+an ANNOTATION to the note FIELDNAME in BBDB-RECORD.
+Called by `bbdb-auto-notes-hook'."
+ (or bbdb-record (error "unperson"))
+ (setq annotation (bbdb-string-trim annotation))
+ (if (memq fieldname '(name address addresses phone phones net aka AKA))
+ (error "bbdb: cannot annotate the %s field this way" fieldname))
+ (or fieldname (setq fieldname 'notes))
+ (or (memq fieldname '(notes company))
+ (assoc (symbol-name fieldname) (bbdb-propnames))
+ (bbdb-set-propnames (append (bbdb-propnames)
+ (list (list (symbol-name fieldname))))))
+ (let ((notes (bbdb-string-trim
+ (or (bbdb-record-getprop bbdb-record fieldname) ""))))
+ (unless (or (string= "" annotation)
+ (string-match (regexp-quote annotation) notes))
+ (bbdb-record-putprop bbdb-record fieldname
+ (if (or replace (string= notes ""))
+ annotation
+ (concat notes
+ (or (get fieldname 'field-separator)
+ bbdb-notes-default-separator)
+ annotation)))
+ (bbdb-maybe-update-display bbdb-record))))
+
+(defun bbdb-offer-save ()
+ "Offer to save the Insidious Big Brother Database if it is modified."
+ (if bbdb-offer-save
+ (bbdb-save-db (eq bbdb-offer-save t))))
+
+(defcustom bbdb-save-db-timeout nil
+ "*If non-nil, then when `bbdb-save-db' is asking you whether to save the db,
+it will time out to `yes' after this many seconds. This only works if the
+function `y-or-n-p-with-timeout' is defined."
+ :group 'bbdb-save
+ :type '(choice (const :tag "Don't time out" nil)
+ (integer :tag "Time out after this many seconds" 5)))
+
+(defun bbdb-save-db (&optional prompt-first mention-if-not-saved)
+ "Save the DB if it is modified."
+ (interactive (list nil t))
+ (bbdb-with-db-buffer
+ (if (and (buffer-modified-p)
+ (or (null prompt-first)
+ (if bbdb-readonly-p
+ (bbdb-y-or-n-p
+ "Save the BBDB, even though it's supposedly read-only? ")
+ (if (and bbdb-save-db-timeout
+ (fboundp 'y-or-n-p-with-timeout))
+ (y-or-n-p-with-timeout
+ "Save the BBDB now? " bbdb-save-db-timeout t)
+ (bbdb-y-or-n-p "Save the BBDB now? ")))))
+ (save-buffer)
+ (if mention-if-not-saved (message "BBDB not saved")))))
+
+
+;;; mail and news interface
+
+(defun bbdb-clean-username (string)
+ "Strips garbage from the user full name string."
+ ;; This function is called a lot, and should be fast. But I'm loathe to
+ ;; remove any of the functionality in it.
+ (if (string-match "[@%!]" string) ; ain't no user name! It's an address!
+ (bbdb-string-trim string)
+ (let ((case-fold-search t))
+ ;; Take off leading and trailing non-alpha chars \(quotes, parens,
+ ;; digits, etc) and things which look like phone extensions \(like
+ ;; "x1234" and "ext. 1234". \)
+ ;; This doesn't work all the time because some of our friends in
+ ;; northern europe have brackets in their names...
+ (if (string-match (if bbdb-have-re-char-classes
+ "\\`[^[:alpha:]]+"
+ "\\`[^a-z]+")
+ string)
+ (setq string (substring string (match-end 0))))
+ (while (string-match
+ "\\(\\W+\\([Xx]\\|[Ee]xt\\.?\\)\\W*[-0-9]+\\|[^a-z]+\\)\\'"
+ string)
+ (setq string (substring string 0 (match-beginning 0))))
+ ;; replace tabs, multiple spaces, dots, and underscores with a single
+ ;; space, but don't replace ". " with " " because that could be an
+ ;; initial.
+ (while (string-match "\\(\t\\| +\\|\\(\\.\\)[^ \t_]\\|_+\\)" string)
+ (setq string (concat (substring string 0
+ (or (match-beginning 2)
+ (match-beginning 1)))
+ " "
+ (substring string (or (match-end 2)
+ (match-end 1))))))
+ ;; If the string contains trailing parenthesized comments, nuke 'em.
+ (if (string-match "[^ \t]\\([ \t]*\\((\\| -\\| #\\)\\)" string)
+ (progn
+ (setq string (substring string 0 (match-beginning 1)))
+ ;; lose rubbish this may have exposed.
+ (while
+ (string-match
+ "\\(\\W+\\([Xx]\\|[Ee]xt\\.?\\)\\W*[-0-9]+\\|[^a-z]+\\)\\'"
+ string)
+ (setq string (substring string 0 (match-beginning 0))))))
+ string)))
+
+;;; message-caching, to speed up the the mail interfaces
+
+(defvar bbdb-buffers-with-message-caches '()
+ "A list of all the buffers which have stuff on their `bbdb-message-cache'
+local variable. When we re-parse the `bbdb-file', we need to flush all of
+these caches.")
+
+(defun notice-buffer-with-cache (buffer)
+ (or (memq buffer bbdb-buffers-with-message-caches)
+ (progn
+ ;; First remove any deleted buffers which may have accumulated.
+ ;; This happens only when a buffer is added to the list, so it
+ ;; ought not happen that frequently (each time you read mail, say.)
+ (let ((rest bbdb-buffers-with-message-caches))
+ (while rest
+ (if (null (buffer-name (car rest)))
+ (setq bbdb-buffers-with-message-caches
+ (delq (car rest) bbdb-buffers-with-message-caches)))
+ (setq rest (cdr rest))))
+ ;; now add this buffer.
+ (setq bbdb-buffers-with-message-caches
+ (cons buffer bbdb-buffers-with-message-caches)))))
+
+(defvar bbdb-message-cache nil
+ "alist of (MESSAGE-KEY BBDB-RECORDS) cached in order to avoid updating
+messages each time they are visited. This is used by all MUAs, while the
+MESSAGE-KEY is specific to the MUA and the cache is local for each MUA or MUA
+folder.")
+
+(make-variable-buffer-local 'bbdb-message-cache)
+
+(defun bbdb-message-cache-lookup (message-key)
+ "Return cached BBDB records for MESSAGE-KEY.
+If not present or when the records have been modified return nil."
+ (bbdb-records)
+ (if bbdb-message-caching-enabled
+ (let ((records (assq message-key bbdb-message-cache))
+ (invalid nil))
+ (when records
+ (setq records (cdr records))
+ (bbdb-mapc (lambda (record)
+ (if (bbdb-record-deleted-p record)
+ (setq invalid t)))
+ records))
+ (if invalid nil records))))
+
+(defun bbdb-encache-message (message-key bbdb-records)
+ "Cache the BBDB-RECORDS for a message identified by MESSAGE-KEY and
+return them."
+ (and bbdb-message-caching-enabled
+ (car bbdb-records)
+ (add-to-list 'bbdb-message-cache (cons message-key bbdb-records))
+ (notice-buffer-with-cache (current-buffer)))
+ bbdb-records)
+
+(defun bbdb-decache-message (message-key)
+ "Remove an element form the cache."
+ (and bbdb-message-caching-enabled
+ (delq (assoc message-key bbdb-message-cache) bbdb-message-cache)))
+
+(defun bbdb-flush-all-caches ()
+ (bbdb-debug
+ (and bbdb-buffers-with-message-caches
+ (message "Flushing BBDB caches")))
+ (save-excursion
+ (while bbdb-buffers-with-message-caches
+ (if (buffer-name (car bbdb-buffers-with-message-caches))
+ (progn
+ (set-buffer (car bbdb-buffers-with-message-caches))
+ (setq bbdb-message-cache nil)))
+ (setq bbdb-buffers-with-message-caches
+ (cdr bbdb-buffers-with-message-caches)))))
+
+
+(defconst bbdb-name-gubbish
+ (concat "[-,. \t/\\]+\\("
+ "[JjSs]r\\.?"
+ "\\|V?\\(I\\.?\\)+V?"
+ (concat "\\|"
+ (regexp-opt bbdb-lastname-prefixes))
+ "\\)\\W*\\'"))
+
+(defun bbdb-divide-name (string)
+ "divide the string into a first name and a last name, cleverly."
+ ;; ## This shouldn't be here.
+ (if (string-match "\\W+\\([Xx]\\|[Ee]xt\\.?\\)\\W*[-0-9]+\\'" string)
+ (setq string (substring string 0 (match-beginning 0))))
+ (let* ((case-fold-search nil)
+ (str string)
+ (gubbish (string-match bbdb-name-gubbish string)))
+ (if gubbish
+ (setq gubbish (substring str gubbish)
+ str (substring string 0 (match-beginning 0))))
+ (if (string-match
+ (concat " +\\("
+ ;; start recognize some prefixes to lastnames
+ (if bbdb-lastname-prefixes
+ (concat "\\("
+ (regexp-opt bbdb-lastname-prefixes t)
+ "[ ]+\\)?"))
+ ;; end recognize some prefixes to lastnames
+ "\\([^ ]+ *- *\\)?[^ ]+\\)\\'") str)
+ (list (substring str 0 (match-beginning 0))
+ (concat
+ (substring str (match-beginning 1))
+ (or gubbish "")))
+ (list string ""))))
+
+(defun bbdb-check-alternate-name (possible-name record)
+ (let (aka)
+ (if (setq aka (bbdb-record-aka record))
+ (let ((down-name (downcase possible-name))
+ match)
+ (while aka
+ (if (equal down-name (downcase (car aka)))
+ (setq match (car aka)
+ aka nil)
+ (setq aka (cdr aka))))
+ match))))
+
+
+(defun bbdb-canonicalize-address (net)
+ ;; call the bbdb-canonicalize-net-hook repeatedly until it returns a
+ ;; value eq to the value passed in. This implies that it can't
+ ;; destructively modify the string.
+
+ ;; Hysterical Raisins: This is a function, not a hook. In order to
+ ;; make this hook a hook, we'll quietly convert a single function
+ ;; into a hook list. We should really warn the user that we're
+ ;; doing this, and advise them to update their configuration
+ ;; accordingly. For the release, maybe.
+ (if (functionp bbdb-canonicalize-net-hook)
+ (setq bbdb-canonicalize-net-hook (list bbdb-canonicalize-net-hook)))
+
+ ;; Now, do the hook run. Note, if you mess up, it's possible that
+ ;; BBDB will get stuck here oscillating between various definitions
+ ;; of the canonical address.
+ (while (not (equal net (setq net (run-hook-with-args
+ 'bbdb-canonicalize-net-hook net)))))
+
+ net)
+
+;; Mostly written by Rod Whitby.
+(defun bbdb-net-redundant-p (net old-nets)
+ "Returns non-nil if NET represents a sub-domain of one of the OLD-NETS.
+The returned value is the address which makes this one redundant.
+For example, \"foo@bar.baz.com\" is redundant w.r.t. \"foo@baz.com\",
+and \"foo@quux.bar.baz.com\" is redundant w.r.t. \"foo@bar.baz.com\"."
+ (let ((redundant-addr nil))
+ (while (and (not redundant-addr) old-nets)
+ ;; Calculate a host-regexp for each address in OLD-NETS
+ (let* ((old (car old-nets))
+ (host-index (string-match "@" old))
+ (name (and host-index (substring old 0 host-index)))
+ (host (and host-index (substring old (1+ host-index))))
+ ;; host-regexp is "^<name>@.*\.<host>$"
+ (host-regexp (and name host
+ (concat "\\`" (regexp-quote name)
+ "@.*\\." (regexp-quote host)
+ "\\'"))))
+ ;; If NET matches host-regexp, then it is redundant
+ (if (and host-regexp net
+ (string-match host-regexp net))
+ (setq redundant-addr old)))
+ (setq old-nets (cdr old-nets)))
+ redundant-addr))
+
+(defun bbdb-name-normalize (name)
+ "Return normalized NAME.
+NAME is converted to lower case and in a MULE enabled Emacs it is converted to
+UTF-8 or unibyte to unify the overlapping ISO-8859-* encodings.
+
+You may advice this function to allow more sophisticated normalizations."
+ (when name
+ (setq name (downcase name))
+ (cond ((functionp 'encode-coding-string)
+ (funcall 'encode-coding-string name 'utf-8))
+ ((functionp 'string-make-unibyte)
+ (funcall 'string-make-unibyte name))
+ (t
+ name))))
+
+(defun bbdb-name= (a b)
+ "Return t if the two names A and B are equal.
+Before comparing A and B they are normalized by calling the function
+`bbdb-name-normalize'."
+ (string= (bbdb-name-normalize a) (bbdb-name-normalize b)))
+
+
+(defun bbdb-annotate-message-sender (from &optional loudly create-p
+ prompt-to-create-p)
+ "Fills the record corresponding to the sender with as much info as possible.
+A record may be created by this; a record or nil is returned.
+If `bbdb-readonly-p' is true, then a record will never be created.
+If CREATE-P is true, then a record may be created, otherwise it won't.
+If PROMPT-TO-CREATE-P is true, then the user will be asked for confirmation
+before the record is created, otherwise it is created without confirmation
+\(assuming that CREATE-P is true\). "
+ (let* ((data (if (consp from)
+ from ; if from is a cons, it's pre-parsed (hack hack)
+ (mail-extract-address-components from)))
+ (name (car data))
+ (net (car (cdr data))))
+ (if (equal name net) (setq name nil))
+ (bbdb-debug
+ (if (equal name "") (error "mail-extr returned \"\" as name"))
+ (if (equal net "") (error "mail-extr returned \"\" as net")))
+
+ (if (and net bbdb-canonicalize-net-hook)
+ (setq net (bbdb-canonicalize-address net)))
+
+ (let ((change-p nil)
+ (record (or (bbdb-search-simple nil net)
+ (bbdb-search-simple name nil)))
+ (created-p nil)
+ (fname name)
+ (lname nil)
+ old-name
+ ignore-name-mismatch
+ bogon-mode)
+ (and record (setq old-name (bbdb-record-name record)))
+
+ ;; This is to prevent having losers like "John <blat@foop>" match
+ ;; against existing records like "Someone Else <john>".
+ ;;
+ ;; The solution implemented here is to never create or show records
+ ;; corresponding to a person who has a real-name which is the same
+ ;; as the network-address of someone in the db already. This is not
+ ;; a good solution.
+ (let (old-net)
+ (if (and record name (not (bbdb-name= name old-name)))
+ (progn
+ (setq old-net (bbdb-record-net record))
+ (while old-net
+ (if (bbdb-name= name (car old-net))
+ (progn
+ (setq bogon-mode t
+ old-net nil)
+ (message
+ "Ignoring bogon %s's name \"%s\" to avoid name-clash with \"%s\""
+ net name old-name)
+ (sit-for 2))
+ (setq old-net (cdr old-net)))))))
+
+ (if (or record
+ bbdb-readonly-p
+ (not create-p)
+ (not (or name net))
+ bogon-mode)
+ ;; no further action required
+ nil
+ ;; otherwise, the db is writable, and we may create a record.
+ ;; first try to get a reasonable default name if not given
+ ;; often I get things like <firstname>.<surname>@ ...
+ (if (or (null name) (and (stringp name) (string= "" name)))
+ (if (string-match "^[^@]+" net)
+ (setq name (bbdb-clean-username (match-string 0 net)))))
+ (setq record (if (or (null prompt-to-create-p)
+ (if (functionp prompt-to-create-p)
+ (bbdb-invoke-hook-for-value
+ prompt-to-create-p)
+ (bbdb-y-or-n-p
+ (format "%s is not in the db. Add? "
+ (or name net)))))
+ (make-vector bbdb-record-length nil))
+ created-p (not (null record)))
+ (if record
+ (bbdb-record-set-cache record (make-vector bbdb-cache-length nil)))
+ )
+ (if (or bogon-mode (null record))
+ nil
+ (bbdb-debug (if (bbdb-record-deleted-p record)
+ (error "nasty nasty deleted record nasty.")))
+ (if (and name
+ (not (bbdb-name= name old-name))
+ (or (null bbdb-use-alternate-names)
+ (not (bbdb-check-alternate-name name record)))
+ (let ((fullname (bbdb-divide-name name))
+ tmp)
+ (setq fname (car fullname)
+ lname (nth 1 fullname))
+ (not (and (equal (downcase fname)
+ (and (setq tmp
+ (bbdb-record-firstname record))
+ (downcase tmp)))
+ (equal (downcase lname)
+ (and (setq tmp
+ (bbdb-record-lastname record))
+ (downcase tmp)))))))
+
+ ;; have a message-name, not the same as old name.
+ (cond (bbdb-readonly-p nil);; skip if readonly
+
+ ;; ignore name mismatches?
+ ;; NB 'quiet' means 'don't ask', not 'don't mention'
+ ((and old-name
+ (setq ignore-name-mismatch bbdb-quiet-about-name-mismatches
+ ignore-name-mismatch
+ (cond
+ ((eq nil ignore-name-mismatch)
+ nil)
+ ((eq t ignore-name-mismatch)
+ 2)
+ ((numberp ignore-name-mismatch)
+ ignore-name-mismatch)
+ ((functionp ignore-name-mismatch)
+ (funcall ignore-name-mismatch record name))
+ (t
+ (eval ignore-name-mismatch)))))
+ (if (or bbdb-silent-running (eq t ignore-name-mismatch))
+ nil
+ (message "name mismatch: \"%s\" changed to \"%s\""
+ (bbdb-record-name record) name)
+ (if (numberp ignore-name-mismatch)
+ (sit-for ignore-name-mismatch))))
+ ((or created-p
+ (if bbdb-silent-running t
+ (if (null old-name)
+ (bbdb-y-or-n-p
+ (format "Assign name \"%s\" to address \"%s\"? "
+ name (car (bbdb-record-net record))))
+ (bbdb-y-or-n-p
+ (format "Change name \"%s\" to \"%s\"? "
+ old-name name)))))
+ (setq change-p 'sort)
+
+ ;; Keep old name?
+ (and old-name bbdb-use-alternate-names
+ (not (member old-name (bbdb-record-aka record)))
+ ;; Silent mode: just add it.
+ (if bbdb-silent-running
+ (bbdb-record-set-aka record
+ (cons old-name
+ (bbdb-record-aka
+ record)))
+ ;; prompt user otherwise.
+ (if (bbdb-y-or-n-p
+ (format "Keep name \"%s\" as an AKA? "
+ old-name))
+ (bbdb-record-set-aka record
+ (cons old-name
+ (bbdb-record-aka
+ record)))
+ (bbdb-remhash (downcase old-name) record))))
+
+ (bbdb-record-set-namecache record nil)
+ (bbdb-record-set-firstname record fname)
+ (bbdb-record-set-lastname record lname)
+ (bbdb-debug (or fname lname
+ (error "bbdb: should have a name by now")))
+ (bbdb-puthash (downcase (bbdb-record-name record)) record))
+
+ ;; not quiet about mismatches
+ ((and old-name bbdb-use-alternate-names
+ ;; dedupe
+ (not (member old-name (bbdb-record-aka record)))
+ (if (not bbdb-silent-running)
+ (bbdb-y-or-n-p
+ (format "Make \"%s\" an alternate for \"%s\"? "
+ name old-name))))
+ (setq change-p 'sort)
+ (bbdb-record-set-aka
+ record (cons name (bbdb-record-aka record)))
+ (bbdb-puthash (downcase name) record))))
+
+ ;; It's kind of a kludge that the "redundancy" concept is built in.
+ ;; Maybe I should just add a new hook here... The problem is that the
+ ;; canonicalize-net-hook is run before database lookup, and thus can't
+ ;; refer to the database to determine whether a net is redundant.
+ (if bbdb-canonicalize-redundant-nets-p
+ (setq net (or (bbdb-net-redundant-p net (bbdb-record-net record))
+ net)))
+
+ (if (and net (not bbdb-readonly-p))
+ (if (null (bbdb-record-net record))
+ ;; names are always a sure match, so don't bother prompting
+ ;; here.
+ (progn (bbdb-record-set-net record (list net))
+ (bbdb-puthash (downcase net) record) ; important!
+ (or change-p (setq change-p t)))
+ ;; new address; ask before adding.
+ (if (let ((rest-net (bbdb-record-net record))
+ (new (downcase net))
+ (match nil))
+ (while (and rest-net (null match))
+ (setq match (string= new (downcase (car rest-net)))
+ rest-net (cdr rest-net)))
+ match)
+ nil
+ (if (let ((bbdb-always-add-addresses
+ bbdb-always-add-addresses))
+ (if (functionp bbdb-always-add-addresses)
+ (setq bbdb-always-add-addresses
+ (funcall bbdb-always-add-addresses)))
+ (cond
+ ;; add it automatically
+ ((eq bbdb-always-add-addresses t)
+ t)
+ ;; do not add it
+ ((null bbdb-always-add-addresses)
+ nil)
+ ;; ask the user if it should be added
+ (t
+ (and
+ (not (equal net "???"))
+ (let ((the-first-bit
+ (format "Add address \"%s\" to \"" net))
+ ;; this groveling is to prevent the "(y or n)"
+ ;; from falling off the right edge of the
+ ;; screen.
+ (the-next-bit (mapconcat 'identity
+ (bbdb-record-net
+ record)
+ ", "))
+ (w (window-width (minibuffer-window))))
+ (if (> (+ (length the-first-bit)
+ (length the-next-bit) 15) w)
+ (setq the-next-bit
+ (concat
+ (substring
+ the-next-bit
+ 0 (max 0 (- w (length the-first-bit)
+ 20)))
+ "...")))
+ (bbdb-display-records (list record))
+ (if (bbdb-y-or-n-p (concat the-first-bit
+ the-next-bit
+ "\"? "))
+ ;; then add the new net
+ t
+ ;; else add a new record with the same name
+ (if (and create-p
+ (or (null prompt-to-create-p)
+ (if (functionp prompt-to-create-p)
+ (bbdb-invoke-hook-for-value
+ prompt-to-create-p)
+ (bbdb-y-or-n-p
+ (format
+ "Create a new record for %s? "
+ (bbdb-record-name record))))))
+ (setq record
+ (bbdb-create-internal name nil net
+ nil nil nil)))
+ nil))))))
+ ;; then modify an existing record
+ (let ((front-p (cond ((null bbdb-new-nets-always-primary)
+ (bbdb-y-or-n-p
+ (format
+ "Make \"%s\" the primary address? "
+ net)))
+ ((eq bbdb-new-nets-always-primary t)
+ t)
+ (t nil))))
+ (bbdb-record-set-net record
+ (if front-p
+ (cons net (bbdb-record-net
+ record))
+ (nconc (bbdb-record-net record)
+ (list net))))
+ (bbdb-puthash (downcase net) record) ; important!
+ (or change-p (setq change-p t)))))))
+
+ (bbdb-debug
+ (if (and change-p bbdb-readonly-p)
+ (error
+ "doubleplus ungood: how did we change anything in readonly mode?"
+ )))
+ (if (and loudly change-p (not bbdb-silent-running))
+ (if (eq change-p 'sort)
+ (message "noticed \"%s\"" (bbdb-record-name record))
+ (if (bbdb-record-name record)
+ (message "noticed %s's address \"%s\""
+ (bbdb-record-name record) net)
+ (message "noticed naked address \"%s\"" net))))
+
+ (if created-p
+ (bbdb-invoke-hook 'bbdb-create-hook record))
+
+ (if change-p
+ (bbdb-change-record record (eq change-p 'sort)))
+
+ ;; only invoke bbdb-notice-hook if we actually noticed something
+ (if record
+ (let ((inside-bbdb-notice-hook t))
+ (bbdb-invoke-hook 'bbdb-notice-hook record)))
+
+ record))))
+
+
+;;; window configuration hackery
+(defun bbdb-multiple-buffers-default ()
+ "Default function for guessing a better name for new *BBDB* buffers."
+ (cond ((memq major-mode '(vm-mode vm-summary-mode
+ vm-presentation-mode
+ vm-virtual-mode))
+ (vm-select-folder-buffer)
+ (buffer-name))
+ ((memq major-mode '(gnus-summary-mode gnus-group-mode))
+ (set-buffer gnus-article-buffer)
+ (buffer-name))
+ ((memq major-mode '(mail-mode vm-mail-mode message-mode))
+ "message composition")))
+
+(defun bbdb-multiple-buffers-set-name (&optional buffer-list new-name)
+ (setq new-name (or new-name
+ (concat " *BBDB " (funcall bbdb-multiple-buffers) "*"))
+ buffer-list (append (list (current-buffer)
+ (get-buffer-create new-name))
+ buffer-list))
+
+ (save-excursion
+ (while buffer-list
+ (set-buffer (car buffer-list))
+ (make-local-variable 'bbdb-buffer-name)
+ (setq bbdb-buffer-name new-name)
+ (setq buffer-list (cdr buffer-list)))))
+
+(defun bbdb-pop-up-bbdb-buffer (&optional predicate)
+ "Find the largest window on the screen, and split it, displaying the
+*BBDB* buffer in the bottom 'bbdb-pop-up-target-lines' lines (unless
+the *BBDB* buffer is already visible, in which case do nothing.)
+
+PREDICATE can be a function to select the right window for the split.
+
+`bbdb-use-pop-up' controls how to split the selected window and how many lines
+resp. columns it will get. If it is 'vertical a vertical split is done otherwise
+a horizontal.
+
+If `bbdb-multiple-buffers' is set we create a new BBDB buffer when not
+already within one. The new buffer-name starts with a space, i.e. it does
+not clutter the buffer-list."
+
+ (let ((current-window (selected-window))
+ (current-buffer (current-buffer))
+ new-bbdb-buffer-name
+ window)
+
+ ;; create new BBDB buffer if multiple buffers are desired.
+ (when (and bbdb-multiple-buffers (not (eq major-mode 'bbdb-mode)))
+ (bbdb-multiple-buffers-set-name (list current-buffer)))
+ (setq new-bbdb-buffer-name bbdb-buffer-name)
+
+
+ ;; now get the pop-up
+ (if (or (not bbdb-use-pop-up) (get-buffer-window new-bbdb-buffer-name))
+ ;; just create the buffer if necessary
+ (progn
+ (get-buffer-create new-bbdb-buffer-name)
+ (display-buffer new-bbdb-buffer-name))
+
+ ;; else find a window to split
+ (when predicate
+ (setq window current-window)
+ (while (and (not (funcall predicate window))
+ (not (eq current-window
+ (setq window (next-window window)))))))
+
+ ;; find the tallest window if none has been selected so far
+ (when (null window)
+ (let ((tallest-window current-window))
+ (while (not (eq current-window (setq window (next-window window))))
+ (if (> (window-height window) (window-height tallest-window))
+ (setq tallest-window window)))
+ (setq window tallest-window)))
+
+ ;; select it and split it...
+ (select-window window)
+ (cond ((eq bbdb-use-pop-up 'vertical)
+ (split-window-horizontally (- bbdb-pop-up-target-columns)))
+ (t
+ (let ((size (min
+ (- (window-height window) window-min-height 1)
+ (- (window-height window)
+ (max window-min-height
+ (1+ bbdb-pop-up-target-lines))))))
+ (setq size (if (> size 0) size window-min-height))
+ (split-window window size))))
+
+ ;; make gnus happy...
+ (if (memq major-mode
+ '(gnus-Group-mode gnus-Subject-mode gnus-Article-mode))
+ (goto-char (point-min)))
+
+ ;; goto the next window, the one created by the split and
+ ;; make it display the BBDB buffer
+ (select-window (next-window))
+ (let ((pop-up-windows nil))
+ (switch-to-buffer (get-buffer-create new-bbdb-buffer-name)))
+
+ ;; select the original window we were in
+ (select-window current-window)
+ ;; and make sure the original buffer is selected
+ (set-buffer current-buffer))))
+
+(defun bbdb-version (&optional arg)
+ "Return string describing the version of the BBDB that is running.
+When called interactively with a prefix argument, insert string at point."
+ (interactive "P")
+ (let ((version-string (format "BBDB version %s" bbdb-version)))
+ (cond
+ (arg
+ (insert (message version-string)))
+ ((interactive-p)
+ (message version-string))
+ (t version-string))))
+
+ ;;; resorting, which really shouldn't be necesary...
+
+(defun bbdb-record-lessp-fn (record1 record2) ; for use as a funarg
+ (bbdb-record-lessp record1 record2))
+
+(defun bbdb-resort-database ()
+ "*Resort BBDB database as a last resort.
+This is not be needed when using BBDB itself. It might be necessary
+after having used inferior software to add entries to the BBDB, however."
+ (interactive)
+ (let* ((records (copy-sequence (bbdb-records))))
+ (bbdb-with-db-buffer
+ (setq bbdb-records (sort bbdb-records 'bbdb-record-lessp-fn))
+ (if (equal records bbdb-records)
+ nil
+ (message "DANGER! BBDB was mis-sorted; it's being fixed...")
+ (goto-char (point-min))
+ (cond ((eq (following-char) ?\[) nil)
+ ((search-forward "\n[" nil 0) (forward-char -1)))
+ (delete-region (point) bbdb-end-marker)
+ (let ((print-escape-newlines t)
+ (standard-output (current-buffer))
+ (inhibit-quit t) ; really, don't fuck with this
+ record cache)
+ (setq records bbdb-records)
+ (while records
+ (setq record (car records)
+ cache (bbdb-record-cache record))
+ (bbdb-record-set-cache record nil)
+ (bbdb-prin1 (car records))
+ (bbdb-record-set-cache record cache)
+ (insert ?\n)
+ (setq records (cdr records))))
+ (kill-all-local-variables)
+ (error "the BBDB was mis-sorted: it has been repaired.")))))
+
+(defvar bbdb-init-forms
+ '((gnus ; gnus 3.15 or newer
+ (add-hook 'gnus-startup-hook 'bbdb-insinuate-gnus))
+ (mh-e ; MH-E
+ (add-hook 'mh-folder-mode-hook 'bbdb-insinuate-mh))
+ (rmail ; RMAIL
+ (add-hook 'rmail-mode-hook 'bbdb-insinuate-rmail))
+ (sendmail ; the standard mail user agent
+ (add-hook 'mail-setup-hook 'bbdb-insinuate-sendmail))
+ (vm-old ; the alternative mail reader
+ (add-hook 'vm-load-hook 'bbdb-insinuate-vm))
+ (vm ; newer versions don't have vm-load-hook
+ (progn (eval-after-load "vm" '(bbdb-insinuate-vm))))
+ (message ; the gnus mail user agent
+ (add-hook 'message-setup-hook 'bbdb-insinuate-message))
+ (reportmail ; mail notification
+ (add-hook 'reportmail-load-hook 'bbdb-insinuate-reportmail))
+ (sc ; message citation
+ (add-hook 'sc-load-hook 'bbdb-insinuate-sc))
+ (supercite ; same
+ (add-hook 'sc-load-hook 'bbdb-insinuate-sc))
+ (w3 ; WWW browser
+ (add-hook 'w3-load-hook 'bbdb-insinuate-w3)))
+ "The alist which maps features to insinuation forms.")
+
+;;;###autoload
+(defun bbdb-initialize (&rest to-insinuate)
+"*Initialize the BBDB. One or more of the following symbols can be
+passed as arguments to initiate the appropriate insinuations.
+
+ Initialization of mail/news readers:
+
+ gnus Initialize BBDB support for the gnus mail/news reader
+ version 3.15 or newer. If you pass the `gnus' symbol,
+ you should probably also pass the `message' symbol.
+ mh-e Initialize BBDB support for the MH-E mail reader.
+ rmail Initialize BBDB support for the RMAIL mail reader.
+ sendmail Initialize BBDB support for sendmail (M-x mail).
+ vm Initialize BBDB support for the VM mail reader.
+ NOTE: For the VM insinuation to work properly, you must
+ either call `bbdb-initialize' with the `vm' symbol from
+ within your VM initialization file (\"~/.vm\") or you
+ must call `bbdb-insinuate-vm' manually from within your
+ VM initialization file.
+
+ Initialization of miscellaneous package:
+
+ message Initialize BBDB support for Message mode.
+ reportmail Initialize BBDB support for the Reportmail mail
+ notification package.
+ sc or Initialize BBDB support for the Supercite message
+ supercite citation package.
+ w3 Initialize BBDB support for Web browsers."
+
+ (defalias 'advertized-bbdb-delete-current-field-or-record
+ 'bbdb-delete-current-field-or-record)
+
+ (require 'bbdb-autoloads)
+
+ (while to-insinuate
+ (let* ((feature (car to-insinuate))
+ (init (assq feature bbdb-init-forms)))
+ (setq to-insinuate (cdr to-insinuate))
+ (if init
+ (if (or (featurep feature) (locate-library (symbol-name feature)))
+ (eval (cadr init))
+ (bbdb-warn "cannot locate feature `%s'" feature))
+ (bbdb-warn "don't know how to insinuate `%s'" feature))))
+
+ ;; RMAIL, MHE, and VM interfaces might need these.
+ (autoload 'mail-strip-quoted-names "mail-utils")
+ (autoload 'mail-fetch-field "mail-utils")
+ ;; All of the interfaces need this.
+ (autoload 'mail-extract-address-components "mail-extr")
+
+ (run-hooks 'bbdb-initialize-hook))
+
+;; Initialize keymaps
+(unless bbdb-mode-search-map
+ (define-prefix-command 'bbdb-mode-search-map)
+ (if (fboundp 'set-keymap-prompt)
+ (set-keymap-prompt
+ bbdb-mode-search-map
+ "(Search [n]ame, [c]ompany, net [a]ddress, n[o]tes)?"))
+
+ (define-key bbdb-mode-search-map [(n)] 'bbdb-name)
+ (define-key bbdb-mode-search-map [(c)] 'bbdb-company)
+ (define-key bbdb-mode-search-map [(a)] 'bbdb-net)
+ (define-key bbdb-mode-search-map [(o)] 'bbdb-notes))
+
+(unless bbdb-mode-map
+ (setq bbdb-mode-map (make-keymap))
+ (suppress-keymap bbdb-mode-map)
+
+ (define-key bbdb-mode-map [(S)] 'bbdb-mode-search-map)
+
+ (define-key bbdb-mode-map [(*)] 'bbdb-apply-next-command-to-all-records)
+ (define-key bbdb-mode-map [(+)] 'bbdb-append-records)
+ (define-key bbdb-mode-map [(!)] 'bbdb-search-invert-set)
+ (define-key bbdb-mode-map [(a)] 'bbdb-add-or-remove-mail-alias)
+ (define-key bbdb-mode-map [(e)] 'bbdb-edit-current-field)
+ (define-key bbdb-mode-map [(n)] 'bbdb-next-record)
+ (define-key bbdb-mode-map [(p)] 'bbdb-prev-record)
+ (define-key bbdb-mode-map [(d)] 'bbdb-delete-current-field-or-record)
+ (define-key bbdb-mode-map [(control k)] 'bbdb-delete-current-field-or-record)
+ (define-key bbdb-mode-map [(control o)] 'bbdb-insert-new-field)
+ (define-key bbdb-mode-map [(s)] 'bbdb-save-db)
+ (define-key bbdb-mode-map [(control x) (control s)]
+ 'bbdb-save-db)
+ (define-key bbdb-mode-map [(r)] 'bbdb-refile-record)
+ (define-key bbdb-mode-map [(t)] 'bbdb-toggle-records-display-layout)
+ (define-key bbdb-mode-map [(T)] 'bbdb-display-record-completely)
+ (define-key bbdb-mode-map [(o)] 'bbdb-omit-record)
+ (define-key bbdb-mode-map [(?\;)] 'bbdb-record-edit-notes)
+ (define-key bbdb-mode-map [(m)] 'bbdb-send-mail)
+ (define-key bbdb-mode-map "\M-d" 'bbdb-dial)
+ (define-key bbdb-mode-map [(f)] 'bbdb-finger)
+ (define-key bbdb-mode-map [(F)] 'bbdb-ftp)
+ (define-key bbdb-mode-map [(i)] 'bbdb-info)
+ (define-key bbdb-mode-map [(??)] 'bbdb-help)
+ (define-key bbdb-mode-map [(q)] 'bbdb-bury-buffer)
+ (define-key bbdb-mode-map [(control x) (control t)]
+ 'bbdb-transpose-fields)
+ (define-key bbdb-mode-map [(w)] 'bbdb-www)
+ (define-key bbdb-mode-map [(W)] 'bbdb-whois)
+ (define-key bbdb-mode-map [(P)] 'bbdb-print)
+ (define-key bbdb-mode-map [(h)] 'other-window)
+ (define-key bbdb-mode-map [(=)] 'delete-other-windows)
+ (define-key bbdb-mode-map [(c)] 'bbdb-create)
+ (define-key bbdb-mode-map [(C)] 'bbdb-changed)
+ (define-key bbdb-mode-map [(b)] 'bbdb)
+
+ (define-key bbdb-mode-map [delete] 'scroll-down)
+ (define-key bbdb-mode-map " " 'scroll-up)
+ )
+
+
+;;; Support for the various Emacsen. This is for features that the
+;;; BBDB adds to itself for different Emacsen. For definitions of
+;;; functions that aren't present in various Emacsen (for example,
+;;; cadr for Emacs 19.34), see below
+(when (string-match "XEmacs\\|Lucid" emacs-version)
+ ;; Above
+ (fset 'bbdb-warn 'warn)
+
+ ;; bbdb-com.el
+ (fset 'bbdb-display-completion-list 'bbdb-xemacs-display-completion-list))
+
+(defun bbdb-insinuate-sendmail ()
+ "Call this function to hook BBDB into sendmail (that is, M-x mail)."
+ (define-key mail-mode-map "\M-\t" 'bbdb-complete-name))
+
+;;;###autoload
+(defun bbdb-insinuate-message ()
+ "Call this function to hook BBDB into `message-mode'."
+ (define-key message-mode-map "\M-\t" 'bbdb-complete-name))
+
+;;; Erm. says here that (require...) can take a noerror flag; why do
+;;; we have this function?
+(defmacro safe-require (thing)
+ (list 'condition-case nil (list 'require thing) '(file-error nil)))
+
+;; Wrappers for things that change for different Emacsen. Note: This
+;; is for things that get redefined that don't belong elsewhere. Some
+;; functions that get redefined live elsewhere in the source because
+;; it makes sense to put them there.
+
+(defun bbdb-warn (&rest args)
+ (beep 1)
+ (apply 'message args))
+
+
+(provide 'bbdb) ; provide before loading things which might require
+
+(run-hooks 'bbdb-load-hook)