diff options
Diffstat (limited to 'lisp')
| -rw-r--r-- | lisp/.gitignore | 2 | ||||
| -rw-r--r-- | lisp/Makefile.in | 194 | ||||
| -rw-r--r-- | lisp/bbdb-com.el | 3746 | ||||
| -rw-r--r-- | lisp/bbdb-ftp.el | 201 | ||||
| -rw-r--r-- | lisp/bbdb-gnus.el | 835 | ||||
| -rw-r--r-- | lisp/bbdb-gui.el | 530 | ||||
| -rw-r--r-- | lisp/bbdb-hooks.el | 713 | ||||
| -rw-r--r-- | lisp/bbdb-merge.el | 264 | ||||
| -rw-r--r-- | lisp/bbdb-mhe.el | 225 | ||||
| -rw-r--r-- | lisp/bbdb-migrate.el | 413 | ||||
| -rw-r--r-- | lisp/bbdb-print.el | 672 | ||||
| -rw-r--r-- | lisp/bbdb-reportmail.el | 107 | ||||
| -rw-r--r-- | lisp/bbdb-rmail.el | 202 | ||||
| -rw-r--r-- | lisp/bbdb-sc.el | 209 | ||||
| -rw-r--r-- | lisp/bbdb-snarf.el | 599 | ||||
| -rw-r--r-- | lisp/bbdb-srv.el | 285 | ||||
| -rw-r--r-- | lisp/bbdb-vm.el | 426 | ||||
| -rw-r--r-- | lisp/bbdb-w3.el | 61 | ||||
| -rw-r--r-- | lisp/bbdb-whois.el | 264 | ||||
| -rw-r--r-- | lisp/bbdb-xemacs.el | 114 | ||||
| -rw-r--r-- | lisp/bbdb.el | 3873 |
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) |