summaryrefslogtreecommitdiff
path: root/lisp/bbdb-com.el
diff options
context:
space:
mode:
Diffstat (limited to 'lisp/bbdb-com.el')
-rw-r--r--lisp/bbdb-com.el3746
1 files changed, 3746 insertions, 0 deletions
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)