[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Emacs-diffs] scratch/eudc-bbdb-3 9bfbbd4 01/15: BBDB: Import BBDB 3
|
From: |
Thomas Fitzsimmons |
|
Subject: |
[Emacs-diffs] scratch/eudc-bbdb-3 9bfbbd4 01/15: BBDB: Import BBDB 3 |
|
Date: |
Tue, 21 Nov 2017 23:47:50 -0500 (EST) |
branch: scratch/eudc-bbdb-3
commit 9bfbbd499eaae79412e0973f992ec8230210b8b5
Author: Thomas Fitzsimmons <address@hidden>
Commit: Thomas Fitzsimmons <address@hidden>
BBDB: Import BBDB 3
Import revision 5ac6dbf7e9676d1e239b4f66fad54711e8da4341 from
the externals/bbdb branch of
git.sv.gnu.org:/srv/git/emacs/elpa.git.
* doc/misc/bbdb.texi,
lisp/bbdb/bbdb-anniv.el,
lisp/bbdb/bbdb-com.el,
lisp/bbdb/bbdb-ispell.el,
lisp/bbdb/bbdb-message.el,
lisp/bbdb/bbdb-mhe.el,
lisp/bbdb/bbdb-migrate.el,
lisp/bbdb/bbdb-mu4e.el,
lisp/bbdb/bbdb-mua.el,
lisp/bbdb/bbdb-pgp.el,
lisp/bbdb/bbdb-rmail.el,
lisp/bbdb/bbdb-snarf.el,
lisp/bbdb/bbdb-tex.el,
lisp/bbdb/bbdb-wl.el,
lisp/bbdb/bbdb.el,
lisp/bbdb/tex/bbdb.sty: New files.
* .gitignore: Add lisp/bbdb/subdirs.el.
---
.gitignore | 1 +
doc/misc/bbdb.texi | 92 +
lisp/bbdb/bbdb-anniv.el | 211 ++
lisp/bbdb/bbdb-com.el | 2825 +++++++++++++++++++++++++++
lisp/bbdb/bbdb-ispell.el | 127 ++
lisp/bbdb/bbdb-message.el | 56 +
lisp/bbdb/bbdb-mhe.el | 99 +
lisp/bbdb/bbdb-migrate.el | 282 +++
lisp/bbdb/bbdb-mu4e.el | 44 +
lisp/bbdb/bbdb-mua.el | 1062 ++++++++++
lisp/bbdb/bbdb-pgp.el | 238 +++
lisp/bbdb/bbdb-rmail.el | 62 +
lisp/bbdb/bbdb-snarf.el | 488 +++++
lisp/bbdb/bbdb-tex.el | 570 ++++++
lisp/bbdb/bbdb-wl.el | 53 +
lisp/bbdb/bbdb.el | 4730 +++++++++++++++++++++++++++++++++++++++++++++
lisp/bbdb/tex/bbdb.sty | 89 +
17 files changed, 11029 insertions(+)
diff --git a/.gitignore b/.gitignore
index 7426082..ca96266 100644
--- a/.gitignore
+++ b/.gitignore
@@ -75,6 +75,7 @@ src/lisp.mk
# Lisp-level sources built by 'make'.
*cus-load.el
*loaddefs.el
+lisp/bbdb/subdirs.el
lisp/cedet/semantic/bovine/c-by.el
lisp/cedet/semantic/bovine/make-by.el
lisp/cedet/semantic/bovine/scm-by.el
diff --git a/doc/misc/bbdb.texi b/doc/misc/bbdb.texi
new file mode 100644
index 0000000..f8191b3
--- /dev/null
+++ b/doc/misc/bbdb.texi
@@ -0,0 +1,92 @@
+\input texinfo @c -*-texinfo-*-
address@hidden %**start of header
address@hidden bbdb.info
address@hidden Insidious Big Brother Database (BBDB) User Manual
address@hidden %**end of header
+
address@hidden
+This file documents the Insidious Big Brother Database (BBDB)
+
+Copyright (C) 2011-2017 Roland Winkler <winkler@@gnu.org>
+
address@hidden
+Permission is granted to copy, distribute and/or modify this document
+under the terms of the GNU Free Documentation License, Version 1.3
+or any later version published by the Free Software Foundation;
+with the Invariant Section being ``GNU GENERAL PUBLIC LICENSE,''
+A copy of the license is included in the section entitled
+``GNU Free Documentation License.''
address@hidden quotation
address@hidden copying
+
address@hidden Emacs misc features
address@hidden
+* BBDB: (bbdb). Insidious Big Brother Database (BBDB).
address@hidden direntry
+
address@hidden
address@hidden Insidious Big Brother Database (BBDB) User Manual
address@hidden
address@hidden 0pt plus 1filll
address@hidden
address@hidden titlepage
+
address@hidden Output the table of the contents at the beginning.
address@hidden
+
address@hidden
address@hidden Top, First Chapter, (dir), (dir)
address@hidden BBDB User Manual
+
address@hidden
address@hidden ifnottex
+
address@hidden
+* First Chapter:: The first chapter is the only chapter
+ in this sample.
+
+Appendices
+* Copying:: The GNU General Public License gives you
permission
+ to redistribute GNU Emacs on certain terms;
+ it also explains that there is no warranty.
+* GNU Free Documentation License:: The license for this documentation.
+* Index:: Complete index.
+
+
+
+
address@hidden menu
+
address@hidden First Chapter, Copying, Top, Top
address@hidden First Chapter
+
address@hidden chapter, first
+
+This is the first chapter.
address@hidden index entry, another
+
+Here is a numbered list.
+
address@hidden
address@hidden
+This is the first item.
+
address@hidden
+This is the second item.
address@hidden enumerate
+
+
address@hidden Copying, GNU Free Documentation License, First Chapter, Top
address@hidden GNU GENERAL PUBLIC LICENSE
address@hidden gpl.texi
+
address@hidden GNU Free Documentation License, Index, Copying, Top
address@hidden GNU Free Documentation License
address@hidden doclicense.texi
+
address@hidden Index, , GNU Free Documentation License, Top
address@hidden Index
+
address@hidden cp
+
address@hidden
diff --git a/lisp/bbdb/bbdb-anniv.el b/lisp/bbdb/bbdb-anniv.el
new file mode 100644
index 0000000..14d007c
--- /dev/null
+++ b/lisp/bbdb/bbdb-anniv.el
@@ -0,0 +1,211 @@
+;;; bbdb-anniv.el --- get anniversaries from BBDB -*- lexical-binding: t -*-
+
+;; Copyright (C) 2011-2017 Free Software Foundation, Inc.
+
+;; This file is part of the Insidious Big Brother Database (aka BBDB),
+
+;; BBDB 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 3 of the License, 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 BBDB. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;; Anniversaries are stored in xfields as defined via `bbdb-anniv-alist'.
+;; Each such field may contain multiple anniversaries entries with separators
+;; defined via `bbdb-separator-alist' (newlines by default).
+;; Each anniversary entry is a string DATE followed by optional TEXT.
+;; DATE may take the same format as the date of ordinary diary entries.
+;; In particular, `calendar-date-style' is obeyed via `diary-date-forms'.
+;; If `bbdb-anniv-alist' has a non-nil FORM for this type of anniversary,
+;; FORM is used to display the anniversary entry in the diary buffer.
+;; If FORM is nil, TEXT is used instead to display the anniversary entry
+;; in the diary buffer.
+;;
+;; To display BBDB anniversaries in the Emacs diary,
+;; call `bbdb-initialize' with arg `anniv'.
+;;
+;; See the BBDB info manual for documentation.
+
+;;; Code:
+
+(require 'bbdb)
+(require 'bbdb-com)
+(require 'diary-lib)
+(eval-when-compile
+ (require 'cl-lib))
+
+(defcustom bbdb-anniv-alist
+ '((birthday . "%n's %d%s birthday")
+ (wedding . "%n's %d%s wedding anniversary")
+ (anniversary))
+ "Alist of rules for formatting anniversaries in the diary buffer.
+Each element is of the form (LABEL . FORM).
+LABEL is the xfield where this type of anniversaries is stored.
+FORM is a format string with the following substitutions:
+ %n name of the record
+ %d number of years
+ %s ordinal suffix (st, nd, rd, th) for the year.
+ %t the optional text following the date string in field LABEL.
+If FORM is nil, use the text following the date string in field LABEL
+as format string."
+ :type '(repeat (cons :tag "Rule"
+ (symbol :tag "Label")
+ (choice (string)
+ (const nil))))
+ :group 'bbdb-utilities-anniv)
+
+;; `bbdb-anniv-diary-entries' becomes a member of `diary-list-entries-hook'.
+;; When this hook is run by `diary-list-entries', the variable `original-date'
+;; is bound to the value of arg DATE of `diary-list-entries'.
+;; Also, `number' is arg NUMBER of `diary-list-entries'.
+;; `diary-list-entries' selects the entries for NUMBER days starting with DATE.
+
+(defvar original-date) ; defined in diary-lib
+(with-no-warnings (defvar number)) ; defined in diary-lib
+
+;;;###autoload
+(defun bbdb-anniv-diary-entries ()
+ "Add anniversaries from BBDB records to `diary-list-entries'.
+This obeys `calendar-date-style' via `diary-date-forms'.
+To enable this feature, put the following into your .emacs:
+
+ \(add-hook 'diary-list-entries-hook 'bbdb-anniv-diary-entries)"
+ ;; Loop over NUMBER dates starting from ORGINAL-DATE.
+ (let* ((num-date (1- (calendar-absolute-from-gregorian original-date)))
+ (end-date (+ num-date number)))
+ (while (<= (setq num-date (1+ num-date)) end-date)
+ (let* ((date (calendar-gregorian-from-absolute num-date))
+ (dd (calendar-extract-day date))
+ (mm (calendar-extract-month date))
+ (yy (calendar-extract-year date))
+ ;; We construct a regexp that only uses shy groups,
+ ;; except for the part of the regexp matching the year.
+ ;; This way we can grab the year from the date string.
+ (year "\\([0-9]+\\)\\|\\*")
+ (dayname (format "%s\\|%s\\.?" (calendar-day-name date)
+ (calendar-day-name date 'abbrev)))
+ (lex-env `((day . ,(format "0*%d" dd))
+ (month . ,(format "0*%d" mm)) (year . ,year)
+ (dayname . ,dayname)
+ (monthname . ,(format "%s\\|%s" (calendar-month-name
mm)
+ (calendar-month-name mm
'abbrev)))))
+ ;; Require that the matched date is at the beginning of the
string.
+ (fmt (format "\\`%s?\\(?:%%s\\)"
+ (regexp-quote diary-nonmarking-symbol)))
+ date-forms)
+
+ (cl-flet ((fun (date-form)
+ (push (cons (format fmt
+ (mapconcat (lambda (form) (eval
form lex-env))
+ (if (eq (car date-form)
'backup)
+ (cdr date-form)
date-form)
+ "\\)\\(?:"))
+ (eq (car date-form) 'backup))
+ date-forms)))
+ (mapc #'fun diary-date-forms)
+
+ ;; The anniversary of February 29 is considered to be March 1
+ ;; in non-leap years. So we search for February 29, too.
+ (when (and (= mm 3) (= dd 1)
+ (not (calendar-leap-year-p yy)))
+ (setq lex-env `((day . "0*29") (month . "0*2") (year . ,year)
+ (dayname . ,dayname)
+ (monthname . ,(format "%s\\|%s"
(calendar-month-name 2)
+ (calendar-month-name 2
'abbrev)))))
+ (mapc #'fun diary-date-forms)))
+
+ (dolist (record (bbdb-records))
+ (dolist (rule bbdb-anniv-alist)
+ (dolist (anniv (bbdb-record-xfield-split record (car rule)))
+ (let ((date-forms date-forms)
+ (anniv-string (concat anniv " X")) ; for backup forms
+ (case-fold-search t)
+ form yr text)
+ (while (setq form (pop date-forms))
+ (when (string-match (car form) anniv-string)
+ (setq date-forms nil
+ yr (match-string 1 anniv-string)
+ yr (if (and yr (string-match-p "[0-9]+" yr))
+ (- yy (string-to-number yr))
+ 100) ; as in `diary-anniversary'
+ ;; For backup forms we should search backward in
+ ;; anniv-string from (match-end 0) for "\\<".
+ ;; That gets too complicated here!
+ ;; Yet for the default value of `diary-date-forms'
+ ;; this would matter only if anniv-string started
+ ;; with a time. That is rather rare for
anniversaries.
+ ;; Then we may simply step backward by one character.
+ text (substring anniv-string (if (cdr form) ; backup
+ (1- (match-end 0))
+ (match-end 0))
+ -1)
+ text (replace-regexp-in-string "\\`[ \t]+" "" text)
+ text (replace-regexp-in-string "[ \t]+\\'" "" text))
+ (if (cdr rule)
+ (setq text (replace-regexp-in-string "%t" text (cdr
rule))))
+ ;; Add the anniversaries to `diary-entries-list'.
+ (if (and (numberp yr) (< 0 (length text)))
+ (diary-add-to-list
+ date
+ ;; `diary-add-to-list' expects an arg SPECIFIER for
being
+ ;; able to jump to the location of the entry in the
diary
+ ;; file. Here we only have BBDB records. So we use
+ ;; an empty string for SPECIFIER, but instead we
`propertize'
+ ;; the STRING passed to `diary-add-to-list'.
+ (propertize
+ (format
+ ;; Text substitution similar to `diary-anniversary'.
+ (replace-regexp-in-string "%n" (bbdb-record-name
record) text)
+ yr (diary-ordinal-suffix yr))
+ 'diary-goto-entry (list 'bbdb-display-records (list
record)))
+ ""))))))))))))
+
+;; based on `diary-goto-entry'
+(defun bbdb-anniv-goto-entry (button)
+ "Jump to the diary entry for the BUTTON at point.
+The character at point may have a text property `diary-goto-entry'
+which should be a list (FUNCTION ARG1 ARG2 ...). Then call FUNCTION
+with args ARG1, ARG2, ... to locate the entry. Otherwise follow
+the rules used by `diary-goto-entry'."
+ (let* ((fun-call (get-text-property (overlay-start button)
+ 'diary-goto-entry))
+ (locator (button-get button 'locator))
+ (marker (car locator))
+ markbuf file)
+ (cond (fun-call
+ (apply (car fun-call) (cdr fun-call)))
+ ;; If marker pointing to diary location is valid, use that.
+ ((and marker (setq markbuf (marker-buffer marker)))
+ (pop-to-buffer markbuf)
+ (goto-char (marker-position marker)))
+ ;; Marker is invalid (eg buffer has been killed).
+ ((and (setq file (cadr locator))
+ (file-exists-p file)
+ (find-file-other-window file))
+ (when (eq major-mode (default-value 'major-mode)) (diary-mode))
+ (goto-char (point-min))
+ (if (re-search-forward (format "%s.*\\(%s\\)"
+ (regexp-quote (nth 2 locator))
+ (regexp-quote (nth 3 locator)))
+ nil t)
+ (goto-char (match-beginning 1))))
+ (t
+ (message "Unable to locate this diary entry")))))
+
+;; `diary-goto-entry-function' is rather inflexible if multiple packages
+;; want to use it for its purposes: this variable can be hijacked
+;; only once. Here our function `bbdb-anniv-goto-entry' should work
+;; for other packages, too.
+(setq diary-goto-entry-function 'bbdb-anniv-goto-entry)
+
+(provide 'bbdb-anniv)
+
+;;; bbdb-anniv.el ends here
diff --git a/lisp/bbdb/bbdb-com.el b/lisp/bbdb/bbdb-com.el
new file mode 100644
index 0000000..cf8eefa
--- /dev/null
+++ b/lisp/bbdb/bbdb-com.el
@@ -0,0 +1,2825 @@
+;;; bbdb-com.el --- user-level commands of BBDB -*- lexical-binding: t -*-
+
+;; Copyright (C) 2010-2017 Free Software Foundation, Inc.
+
+;; This file is part of the Insidious Big Brother Database (aka BBDB),
+
+;; BBDB 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 3 of the License, 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 BBDB. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;; This file contains most of the user-level interactive commands for BBDB.
+;; See the BBDB info manual for documentation.
+
+;;; Code:
+
+(require 'bbdb)
+(require 'mailabbrev)
+
+(declare-function build-mail-aliases "mailalias")
+(declare-function browse-url-url-at-point "browse-url")
+
+(require 'crm)
+(defvar bbdb-crm-local-completion-map
+ (let ((map (make-sparse-keymap)))
+ (set-keymap-parent map crm-local-completion-map)
+ (define-key map " " 'self-insert-command)
+ map)
+ "Keymap used for BBDB crm completions.")
+
+(defun bbdb-get-records (prompt)
+ "If inside the *BBDB* buffer get the current records.
+In other buffers ask the user."
+ (if (string= bbdb-buffer-name (buffer-name))
+ (bbdb-do-records)
+ (bbdb-completing-read-records prompt)))
+
+;; Note about the arg RECORDS of various BBDB commands:
+;; - Usually, RECORDS is a list of records. (Interactively,
+;; this list of records is set up by `bbdb-do-records'.)
+;; - If these commands are used, e.g., in `bbdb-create-hook' or
+;; `bbdb-change-hook', they will be called with one arg, a single record.
+;; So depending on context the value of RECORDS will be a single record
+;; or a list of records, and we want to handle both cases.
+;; So we pass RECORDS to `bbdb-record-list' to handle both cases.
+(defun bbdb-record-list (records &optional full)
+ "Ensure that RECORDS is a list of records.
+If RECORDS is a single record turn it into a list.
+If FULL is non-nil, assume that RECORDS include display information."
+ (if records
+ (if full
+ (if (vectorp (car records)) (list records) records)
+ (if (vectorp records) (list records) records))))
+
+;; Note about BBDB prefix commands:
+;; `bbdb-do-all-records', `bbdb-append-display' and `bbdb-search-invert'
+;; are fake prefix commands. They need not precede the main commands.
+;; Also, `bbdb-append-display' can act on multiple commands.
+
+(defun bbdb-prefix-message ()
+ "Display a message about selected BBDB prefix commands."
+ (let ((msg (bbdb-concat " " (elt bbdb-modeline-info 1)
+ (elt bbdb-modeline-info 3)
+ (elt bbdb-modeline-info 5))))
+ (unless (string= "" msg) (message "%s" msg))))
+
+;;;###autoload
+(defun bbdb-do-all-records (&optional arg)
+ "Command prefix for operating on all records currently displayed.
+With prefix ARG a positive number, operate on all records.
+With prefix ARG a negative number, operate on current record only.
+This only works for certain commands."
+ (interactive "P")
+ (setq bbdb-do-all-records
+ (or (and (numberp arg) (< 0 arg))
+ (and (not (numberp arg)) (not bbdb-do-all-records))))
+ (aset bbdb-modeline-info 4 (if bbdb-do-all-records "all"))
+ (aset bbdb-modeline-info 5
+ (if bbdb-do-all-records
+ (substitute-command-keys
+ "\\<bbdb-mode-map>\\[bbdb-do-all-records]")))
+ (bbdb-prefix-message))
+
+;;;###autoload
+(defun bbdb-do-records (&optional full)
+ "Return list of records to operate on.
+Normally this list includes only the current record.
+It includes all currently displayed records if the command prefix \
+\\<bbdb-mode-map>\\[bbdb-do-all-records] is used.
+If FULL is non-nil, the list of records includes display information."
+ (if bbdb-do-all-records
+ (progn
+ (setq bbdb-do-all-records nil)
+ (aset bbdb-modeline-info 4 nil)
+ (aset bbdb-modeline-info 5 nil)
+ (if full bbdb-records (mapcar 'car bbdb-records)))
+ (list (bbdb-current-record full))))
+
+;;;###autoload
+(defun bbdb-append-display-p ()
+ "Return variable `bbdb-append-display' and reset."
+ (let ((job (cond ((eq t bbdb-append-display))
+ ((numberp bbdb-append-display)
+ (setq bbdb-append-display (1- bbdb-append-display))
+ (if (zerop bbdb-append-display)
+ (setq bbdb-append-display nil))
+ t)
+ (bbdb-append-display
+ (setq bbdb-append-display nil)
+ t))))
+ (cond ((numberp bbdb-append-display)
+ (aset bbdb-modeline-info 0
+ (format "(add %dx)" bbdb-append-display)))
+ ((not bbdb-append-display)
+ (aset bbdb-modeline-info 0 nil)
+ (aset bbdb-modeline-info 1 nil)))
+ job))
+
+;;;###autoload
+(defun bbdb-append-display (&optional arg)
+ "Toggle appending next searched records in the *BBDB* buffer.
+With prefix ARG \\[universal-argument] always append.
+With ARG a positive number append for that many times.
+With ARG a negative number do not append."
+ (interactive "P")
+ (setq bbdb-append-display
+ (cond ((and arg (listp arg)) t)
+ ((and (numberp arg) (< 1 arg)) arg)
+ ((or (and (numberp arg) (< arg 0)) bbdb-append-display) nil)
+ (t 'once)))
+ (aset bbdb-modeline-info 0
+ (cond ((numberp bbdb-append-display)
+ (format "(add %dx)" bbdb-append-display))
+ ((eq t bbdb-append-display) "Add")
+ (bbdb-append-display "add")
+ (t nil)))
+ (aset bbdb-modeline-info 1
+ (if bbdb-append-display
+ (substitute-command-keys
+ "\\<bbdb-mode-map>\\[bbdb-append-display]")))
+ (bbdb-prefix-message))
+
+(defsubst bbdb-layout-prefix ()
+ "Set the LAYOUT arg interactively using the prefix arg."
+ (cond ((eq current-prefix-arg 0) 'one-line)
+ (current-prefix-arg 'multi-line)
+ (t bbdb-layout)))
+
+(defun bbdb-search-invert-p ()
+ "Return variable `bbdb-search-invert' and set it to nil.
+To set it again, use command `bbdb-search-invert'."
+ (let ((result bbdb-search-invert))
+ (setq bbdb-search-invert nil)
+ (aset bbdb-modeline-info 2 nil)
+ (aset bbdb-modeline-info 3 nil)
+ result))
+
+;;;###autoload
+(defun bbdb-search-invert (&optional arg)
+ "Toggle inversion of the next search command.
+With prefix ARG a positive number, invert next search.
+With prefix ARG a negative number, do not invert next search."
+ (interactive "P")
+ (setq bbdb-search-invert
+ (or (and (numberp arg) (< 0 arg))
+ (and (not (numberp arg)) (not bbdb-search-invert))))
+ (aset bbdb-modeline-info 2 (if bbdb-search-invert "inv"))
+ (aset bbdb-modeline-info 3 (if bbdb-search-invert
+ (substitute-command-keys
+ "\\<bbdb-mode-map>\\[bbdb-search-invert]")))
+ (bbdb-prefix-message))
+
+(defmacro bbdb-search (records &rest spec)
+ "Search RECORDS for fields matching SPEC.
+The following keywords are supported in SPEC to search fields in RECORDS
+matching the regexps RE:
+
+:name RE Match RE against first-last name.
+:name-fl RE Match RE against last-first name.
+:all-names RE Match RE against first-last, last-first, and aka.
+:affix RE Match RE against affixes.
+:aka RE Match RE against akas.
+:organization RE Match RE against organizations.
+:mail RE Match RE against mail addresses.
+:xfield RE Match RE against `bbdb-default-xfield'.
+ RE may also be a cons (LABEL . REGEXP).
+ Then REGEXP is matched against xfield LABEL.
+ If LABEL is '* then RE is matched against all xfields.
+:creation-date RE Match RE against creation-date.
+:timestamp RE Match RE against timestamp.
+
+Each of these keywords may appear multiple times.
+Other keywords:
+
+:bool BOOL Combine the search for multiple fields using BOOL.
+ BOOL may be either `or' (match either field)
+ or `and' (match all fields) with default `or'.
+
+To reverse the search, bind `bbdb-search-invert' to t.
+See also `bbdb-message-search' for fast searches using `bbdb-hashtable'
+but not allowing for regexps.
+
+For backward compatibility, SPEC may also consist of the optional args
+ NAME ORGANIZATION MAIL XFIELD PHONE ADDRESS
+which is equivalent to
+ :all-names NAME :organization ORGANIZATION :mail MAIL
+ :xfield XFIELD :phone PHONE :address ADDRESS
+This usage is discouraged."
+ (when (not (keywordp (car spec)))
+ ;; Old format for backward compatibility
+ (unless (get 'bbdb-search 'bbdb-outdated)
+ (put 'bbdb-search 'bbdb-outdated t)
+ (message "Outdated usage of `bbdb-search'")
+ (sit-for 2))
+ (let (newspec val)
+ (dolist (key '(:all-names :organization :mail :xfield :phone :address))
+ (if (setq val (pop spec))
+ (push (list key val) newspec)))
+ (setq spec (apply 'append newspec))))
+
+ (let* ((count 0)
+ (sym-list (mapcar (lambda (_)
+ (make-symbol
+ (format "bbdb-re-%d" (setq count (1+ count)))))
+ spec))
+ (bool (make-symbol "bool"))
+ (not-invert (make-symbol "not-invert"))
+ (matches (make-symbol "matches"))
+ keyw re-list clauses)
+ (set bool ''or) ; default
+
+ ;; Check keys.
+ (while (keywordp (setq keyw (car spec)))
+ (setq spec (cdr spec))
+ (pcase keyw
+ (`:name
+ (let ((sym (pop sym-list)))
+ (push `(,sym ,(pop spec)) re-list)
+ (push `(string-match ,sym (bbdb-record-name record)) clauses)))
+
+ (`:name-lf
+ (let ((sym (pop sym-list)))
+ (push `(,sym ,(pop spec)) re-list)
+ (push `(string-match ,sym (bbdb-record-name-lf record)) clauses)))
+
+ (`:all-names
+ (let ((sym (pop sym-list)))
+ (push `(,sym ,(pop spec)) re-list)
+ (push `(or (string-match ,sym (bbdb-record-name record))
+ (string-match ,sym (bbdb-record-name-lf record))
+ (let ((akas (bbdb-record-field record 'aka-all))
+ aka done)
+ (while (and (setq aka (pop akas)) (not done))
+ (setq done (string-match ,sym aka)))
+ done))
+ clauses)))
+
+ (`:affix
+ (let ((sym (pop sym-list)))
+ (push `(,sym ,(pop spec)) re-list)
+ (push `(let ((affixs (bbdb-record-field record 'affix-all))
+ affix done)
+ (if affix
+ (while (and (setq affix (pop affixs)) (not done))
+ (setq done (string-match ,sym affix)))
+ ;; so that "^$" matches records without affix
+ (setq done (string-match ,sym "")))
+ done)
+ clauses)))
+
+ (`:aka
+ (let ((sym (pop sym-list)))
+ (push `(,sym ,(pop spec)) re-list)
+ (push `(let ((akas (bbdb-record-field record 'aka-all))
+ aka done)
+ (if aka
+ (while (and (setq aka (pop akas)) (not done))
+ (setq done (string-match ,sym aka)))
+ ;; so that "^$" matches records without aka
+ (setq done (string-match ,sym "")))
+ done)
+ clauses)))
+
+ (`:organization
+ (let ((sym (pop sym-list)))
+ (push `(,sym ,(pop spec)) re-list)
+ (push `(let ((organizations (bbdb-record-organization record))
+ org done)
+ (if organizations
+ (while (and (setq org (pop organizations)) (not done))
+ (setq done (string-match ,sym org)))
+ ;; so that "^$" matches records without organizations
+ (setq done (string-match ,sym "")))
+ done)
+ clauses)))
+
+ (`:phone
+ (let ((sym (pop sym-list)))
+ (push `(,sym ,(pop spec)) re-list)
+ (push `(let ((phones (bbdb-record-phone record))
+ ph done)
+ (if phones
+ (while (and (setq ph (pop phones)) (not done))
+ (setq done (string-match ,sym
+ (bbdb-phone-string ph))))
+ ;; so that "^$" matches records without phones
+ (setq done (string-match ,sym "")))
+ done)
+ clauses)))
+
+ (`:address
+ (let ((sym (pop sym-list)))
+ (push `(,sym ,(pop spec)) re-list)
+ (push `(let ((addresses (bbdb-record-address record))
+ a done)
+ (if addresses
+ (while (and (setq a (pop addresses)) (not done))
+ (setq done (string-match ,sym
+ (bbdb-format-address a 2))))
+ ;; so that "^$" matches records without addresses
+ (setq done (string-match ,sym "")))
+ done)
+ clauses)))
+
+ (`:mail
+ (let ((sym (pop sym-list)))
+ (push `(,sym ,(pop spec)) re-list)
+ (push `(let ((mails (bbdb-record-mail record))
+ (bbdb-case-fold-search t) ; there is no case for mails
+ m done)
+ (if mails
+ (while (and (setq m (pop mails)) (not done))
+ (setq done (string-match ,sym m)))
+ ;; so that "^$" matches records without mail
+ (setq done (string-match ,sym "")))
+ done)
+ clauses)))
+
+ (`:xfield
+ (let ((sym (pop sym-list)))
+ (push `(,sym ,(pop spec)) re-list)
+ (push `(cond ((stringp ,sym)
+ ;; check xfield `bbdb-default-xfield'
+ ;; "^$" matches records without notes field
+ (string-match ,sym
+ (or (bbdb-record-xfield-string
+ record bbdb-default-xfield) "")))
+ ((eq (car ,sym) '*)
+ ;; check all xfields
+ (let ((labels bbdb-xfield-label-list) done tmp)
+ (while (and (not done) labels)
+ (setq tmp (bbdb-record-xfield-string record (car
labels))
+ done (and tmp (string-match (cdr ,sym)
+ tmp))
+ labels (cdr labels)))
+ done))
+ (t ; check one field
+ (string-match (cdr ,sym)
+ (or (bbdb-record-xfield-string
+ record (car ,sym)) ""))))
+ clauses)))
+
+ (`:creation-date
+ (let ((sym (pop sym-list)))
+ (push `(,sym ,(pop spec)) re-list)
+ (push `(string-match ,sym (bbdb-record-creation-date record))
+ clauses)))
+
+ (`:timestamp
+ (let ((sym (pop sym-list)))
+ (push `(,sym ,(pop spec)) re-list)
+ (push `(string-match ,sym (bbdb-record-timestamp record))
+ clauses)))
+
+ (`:bool
+ (set bool (pop spec)))
+
+ ;; Do we need other keywords?
+
+ (_ (error "Keyword `%s' undefines" keyw))))
+
+ `(let ((case-fold-search bbdb-case-fold-search)
+ (,not-invert (not (bbdb-search-invert-p)))
+ ,@re-list ,matches)
+ ;; Are there any use cases for `bbdb-search' where BOOL is only
+ ;; known at run time? A smart byte compiler will hopefully
+ ;; simplify the code below if we know BOOL already at compile time.
+ ;; Alternatively, BOOL could also be a user function that
+ ;; defines more complicated boolian expressions. Yet then we loose
+ ;; the efficiency of `and' and `or' that evaluate its arguments
+ ;; as needed. We would need instead boolian macros that the compiler
+ ;; can analyze at compile time.
+ (if (eq 'and ,(symbol-value bool))
+ (dolist (record ,records)
+ (unless (eq ,not-invert (not (and ,@clauses)))
+ (push record ,matches)))
+ (dolist (record ,records)
+ (unless (eq ,not-invert (not (or ,@clauses)))
+ (push record ,matches))))
+ (nreverse ,matches))))
+
+(defun bbdb-search-read (&optional field)
+ "Read regexp to search FIELD values of records."
+ (read-string (format "Search records%s %smatching regexp: "
+ (if field (concat " with " field) "")
+ (if bbdb-search-invert "not " ""))))
+
+;;;###autoload
+(defun bbdb (regexp &optional layout)
+ "Display all records in the BBDB matching REGEXP
+in either the name(s), organization, address, phone, mail, or xfields."
+ (interactive (list (bbdb-search-read) (bbdb-layout-prefix)))
+ (let ((records (bbdb-search (bbdb-records) :all-names regexp
+ :organization regexp :mail regexp
+ :xfield (cons '* regexp)
+ :phone regexp :address regexp :bool 'or)))
+ (if records
+ (bbdb-display-records records layout nil t)
+ (message "No records matching '%s'" regexp))))
+
+;;;###autoload
+(defun bbdb-search-name (regexp &optional layout)
+ "Display all records in the BBDB matching REGEXP in the name
+\(or ``alternate'' names\)."
+ (interactive (list (bbdb-search-read "names") (bbdb-layout-prefix)))
+ (bbdb-display-records (bbdb-search (bbdb-records) :all-names regexp) layout))
+
+;;;###autoload
+(defun bbdb-search-organization (regexp &optional layout)
+ "Display all records in the BBDB matching REGEXP in the organization field."
+ (interactive (list (bbdb-search-read "organization") (bbdb-layout-prefix)))
+ (bbdb-display-records (bbdb-search (bbdb-records) :organization regexp)
+ layout))
+
+;;;###autoload
+(defun bbdb-search-address (regexp &optional layout)
+ "Display all records in the BBDB matching REGEXP in the address fields."
+ (interactive (list (bbdb-search-read "address") (bbdb-layout-prefix)))
+ (bbdb-display-records (bbdb-search (bbdb-records) :address regexp)
+ layout))
+
+;;;###autoload
+(defun bbdb-search-mail (regexp &optional layout)
+ "Display all records in the BBDB matching REGEXP in the mail address."
+ (interactive (list (bbdb-search-read "mail address") (bbdb-layout-prefix)))
+ (bbdb-display-records (bbdb-search (bbdb-records) :mail regexp) layout))
+
+;;;###autoload
+(defun bbdb-search-phone (regexp &optional layout)
+ "Display all records in the BBDB matching REGEXP in the phones field."
+ (interactive (list (bbdb-search-read "phone") (bbdb-layout-prefix)))
+ (bbdb-display-records
+ (bbdb-search (bbdb-records) :phone regexp) layout))
+
+;;;###autoload
+(defun bbdb-search-xfields (field regexp &optional layout)
+ "Display all BBDB records for which xfield FIELD matches REGEXP."
+ (interactive
+ (let ((field (completing-read "Xfield to search (RET for all): "
+ (mapcar 'list bbdb-xfield-label-list) nil t)))
+ (list (if (string= field "") '* (intern field))
+ (bbdb-search-read (if (string= field "")
+ "any xfield"
+ field))
+ (bbdb-layout-prefix))))
+ (bbdb-display-records (bbdb-search (bbdb-records) :xfield (cons field
regexp))
+ layout))
+(define-obsolete-function-alias 'bbdb-search-notes 'bbdb-search-xfields "3.0")
+
+;;;###autoload
+(defun bbdb-search-changed (&optional layout)
+ ;; FIXME: "changes" in BBDB lingo are often called "modifications"
+ ;; in Emacs lingo
+ "Display records which have been changed since BBDB was last saved."
+ (interactive (list (bbdb-layout-prefix)))
+ (if (bbdb-search-invert-p)
+ (let (unchanged-records)
+ (dolist (record (bbdb-records))
+ (unless (memq record bbdb-changed-records)
+ (push record unchanged-records)))
+ (bbdb-display-records unchanged-records layout))
+ (bbdb-display-records bbdb-changed-records layout)))
+
+(defun bbdb-search-prog (fun &optional layout)
+ "Search records using function FUN.
+FUN is called with one argument, the record, and should return
+the record to be displayed or nil otherwise."
+ (bbdb-display-records (delq nil (mapcar fun (bbdb-records))) layout))
+
+
+;; clean-up functions
+
+;; Sometimes one gets mail from address@hidden, and then later gets mail
+;; from address@hidden At this point, one would like to delete the bar.baz.com
+;; address, since the baz.com address is obviously superior.
+
+(defun bbdb-mail-redundant-re (mail)
+ "Return a regexp matching redundant variants of email address MAIL.
+For example, \"address@hidden" is redundant w.r.t. \"address@hidden".
+Return nil if MAIL is not a valid plain email address.
+In particular, ignore addresses \"Joe Smith <address@hidden>\"."
+ (let* ((match (string-match "\\`\\([^ ]+\\)@\\(.+\\)\\'" mail))
+ (name (and match (match-string 1 mail)))
+ (host (and match (match-string 2 mail))))
+ (if (and name host)
+ (concat (regexp-quote name) "@.*\\." (regexp-quote host)))))
+
+(defun bbdb-delete-redundant-mails (records &optional query update)
+ "Delete redundant or duplicate mails from RECORDS.
+For example, \"address@hidden" is redundant w.r.t. \"address@hidden".
+Duplicates may (but should not) occur if we feed BBDB automatically.
+Interactively, use BBDB prefix \
+\\<bbdb-mode-map>\\[bbdb-do-all-records], see `bbdb-do-all-records'.
+If QUERY is non-nil (as in interactive calls, unless we use a prefix arg)
+query before deleting the redundant mail addresses.
+If UPDATE is non-nil (as in interactive calls) update the database.
+Otherwise, this is the caller's responsiblity.
+
+Noninteractively, this may be used as an element of `bbdb-notice-record-hook'
+or `bbdb-change-hook'. However, see also `bbdb-ignore-redundant-mails',
+which is probably more suited for your needs."
+ (interactive (list (bbdb-do-records) (not current-prefix-arg) t))
+ (bbdb-editable)
+ (dolist (record (bbdb-record-list records))
+ (let (mails redundant okay)
+ ;; We do not look at the canonicalized mail addresses of RECORD.
+ ;; An address "Joe Smith <address@hidden>" can only be entered manually
+ ;; into BBDB, and we assume that this is what the user wants.
+ ;; Anyway, if a mail field contains all the elements
+ ;; address@hidden, "Joe Smith <address@hidden>", "Jonathan Smith
<address@hidden>"
+ ;; we do not know which address to keep and which ones to throw.
+ (dolist (mail (bbdb-record-mail record))
+ (if (assoc-string mail mails t) ; duplicate mail address
+ (push mail redundant)
+ (push mail mails)))
+ (let ((mail-re (delq nil (mapcar 'bbdb-mail-redundant-re mails)))
+ (case-fold-search t))
+ (if (not (cdr mail-re)) ; at most one mail-re address to consider
+ (setq okay (nreverse mails))
+ (setq mail-re (concat "\\`\\(?:" (mapconcat 'identity mail-re "\\|")
+ "\\)\\'"))
+ (dolist (mail mails)
+ (if (string-match mail-re mail) ; redundant mail address
+ (push mail redundant)
+ (push mail okay)))))
+ (let ((form (format "redundant mail%s %s"
+ (if (< 1 (length redundant)) "s" "")
+ (bbdb-concat 'mail (nreverse redundant)))))
+ (when (and redundant
+ (or (not query)
+ (y-or-n-p (format "Delete %s: " form))))
+ (unless query (message "Deleting %s" form))
+ (bbdb-record-set-field record 'mail okay)
+ (when update
+ (bbdb-change-record record)))))))
+(define-obsolete-function-alias 'bbdb-delete-duplicate-mails
+ 'bbdb-delete-redundant-mails "3.0")
+
+(defun bbdb-search-duplicates (&optional fields)
+ "Search all records that have duplicate entries for FIELDS.
+The list FIELDS may contain the symbols `name', `mail', and `aka'.
+If FIELDS is nil use all these fields. With prefix, query for FIELDS.
+The search results are displayed in the BBDB buffer."
+ (interactive (list (if current-prefix-arg
+ (list (intern (completing-read "Field: "
+ '("name" "mail" "aka")
+ nil t))))))
+ (setq fields (or fields '(name mail aka)))
+ (let (hash ret)
+ (dolist (record (bbdb-records))
+
+ (when (and (memq 'name fields)
+ (bbdb-record-name record)
+ (setq hash (bbdb-gethash (bbdb-record-name record)
+ '(fl-name lf-name aka)))
+ (> (length hash) 1))
+ (setq ret (append hash ret))
+ (message "BBDB record `%s' has duplicate name."
+ (bbdb-record-name record))
+ (sit-for 0))
+
+ (if (memq 'mail fields)
+ (dolist (mail (bbdb-record-mail-canon record))
+ (setq hash (bbdb-gethash mail '(mail)))
+ (when (> (length hash) 1)
+ (setq ret (append hash ret))
+ (message "BBDB record `%s' has duplicate mail `%s'."
+ (bbdb-record-name record) mail)
+ (sit-for 0))))
+
+ (if (memq 'aka fields)
+ (dolist (aka (bbdb-record-aka record))
+ (setq hash (bbdb-gethash aka '(fl-name lf-name aka)))
+ (when (> (length hash) 1)
+ (setq ret (append hash ret))
+ (message "BBDB record `%s' has duplicate aka `%s'"
+ (bbdb-record-name record) aka)
+ (sit-for 0)))))
+
+ (bbdb-display-records (sort (delete-dups ret)
+ 'bbdb-record-lessp))))
+
+(defun bbdb-fix-records (records)
+ "Fix broken RECORDS.
+Interactively, use BBDB prefix \
+\\<bbdb-mode-map>\\[bbdb-do-all-records], see `bbdb-do-all-records'."
+ (interactive (list (bbdb-do-records)))
+ (bbdb-editable)
+ (dolist (record (bbdb-record-list records))
+ ;; For the fields which take a list of strings (affix, organization,
+ ;; aka, and mail) `bbdb=record-set-field' calls `bbdb-list-strings'
+ ;; which removes all elements from such a list which are not non-empty
+ ;; strings. This should fix most problems with these fields.
+ (bbdb-record-set-field record 'affix (bbdb-record-affix record))
+ (bbdb-record-set-field record 'organization (bbdb-record-organization
record))
+ (bbdb-record-set-field record 'aka (bbdb-record-aka record))
+ (bbdb-record-set-field record 'mail (bbdb-record-mail record))
+ (bbdb-change-record record))
+ (bbdb-sort-records))
+
+(defun bbdb-touch-records (records)
+ "Touch RECORDS by calling `bbdb-change-hook' unconditionally.
+Interactively, use BBDB prefix \
+\\<bbdb-mode-map>\\[bbdb-do-all-records], see `bbdb-do-all-records'."
+ (interactive (list (bbdb-do-records)))
+ (bbdb-editable)
+ (let ((bbdb-update-unchanged-records t))
+ (dolist (record (bbdb-record-list records))
+ (bbdb-change-record record))))
+
+;;; Time-based functions
+
+(defmacro bbdb-compare-records (cmpval label compare)
+ "Builds a lambda comparison function that takes one argument, RECORD.
+RECORD is returned if (COMPARE VALUE CMPVAL) is t, where VALUE
+is the value of field LABEL of RECORD."
+ `(lambda (record)
+ (let ((val (bbdb-record-field record ,label)))
+ (if (and val (,compare val ,cmpval))
+ record))))
+
+(defsubst bbdb-string> (a b)
+ (not (or (string= a b)
+ (string< a b))))
+
+;;;###autoload
+(defun bbdb-timestamp-older (date &optional layout)
+ "Display records with timestamp older than DATE.
+DATE must be in yyyy-mm-dd format."
+ (interactive (list (read-string "Timestamp older than: (yyyy-mm-dd) ")
+ (bbdb-layout-prefix)))
+ (bbdb-search-prog (bbdb-compare-records date 'timestamp string<) layout))
+
+;;;###autoload
+(defun bbdb-timestamp-newer (date &optional layout)
+ "Display records with timestamp newer than DATE.
+DATE must be in yyyy-mm-dd format."
+ (interactive (list (read-string "Timestamp newer than: (yyyy-mm-dd) ")
+ (bbdb-layout-prefix)))
+ (bbdb-search-prog (bbdb-compare-records date 'timestamp bbdb-string>)
layout))
+
+;;;###autoload
+(defun bbdb-creation-older (date &optional layout)
+ "Display records with creation-date older than DATE.
+DATE must be in yyyy-mm-dd format."
+ (interactive (list (read-string "Creation older than: (yyyy-mm-dd) ")
+ (bbdb-layout-prefix)))
+ (bbdb-search-prog (bbdb-compare-records date 'creation-date string<) layout))
+
+;;;###autoload
+(defun bbdb-creation-newer (date &optional layout)
+ "Display records with creation-date newer than DATE.
+DATE must be in yyyy-mm-dd format."
+ (interactive (list (read-string "Creation newer than: (yyyy-mm-dd) ")
+ (bbdb-layout-prefix)))
+ (bbdb-search-prog (bbdb-compare-records date 'creation-date bbdb-string>)
layout))
+
+;;;###autoload
+(defun bbdb-creation-no-change (&optional layout)
+ "Display records that have the same timestamp and creation-date."
+ (interactive (list (bbdb-layout-prefix)))
+ (bbdb-search-prog
+ ;; RECORD is bound in `bbdb-compare-records'.
+ (bbdb-compare-records (bbdb-record-timestamp record)
+ 'creation-date string=)
+ layout))
+
+;;; 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.
+
+(defsubst bbdb-subint (string num)
+ "Used for parsing phone numbers."
+ (string-to-number (match-string num string)))
+
+(defun bbdb-parse-phone (string &optional style)
+ "Parse a phone number from STRING and return a list of integers the form
+\(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).
+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 0)
+ 415 555 1212 -> (415 555 1212 0)
+ 1 415 555 1212 -> (415 555 1212 0)
+ 5551212 -> (0 555 1212 0)
+ 4155551212 -> (415 555 1212 0)
+ 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\".
+
+Return a list containing four numbers or one string."
+
+ ;; RW: Missing parts of NANP numbers are replaced by zeros.
+ ;; Is this always correct? What about an extension zero?
+ ;; Should we use nil instead of zeros?
+ (unless style (setq style bbdb-phone-style))
+ (let ((area-regexp (concat "(?[ \t]*\\+?1?[ \t]*[-\(]?[ \t]*[-\(]?[ \t]*"
+ "\\([2-9][0-9][0-9]\\)[ \t]*)?[-./ \t]*"))
+ (main-regexp (concat "\\([1-9][0-9][0-9]\\)[ \t]*[-.]?[ \t]*"
+ "\\([0-9][0-9][0-9][0-9]\\)[ \t]*"))
+ (ext-regexp "x?[ \t]*\\([0-9]+\\)[ \t]*"))
+ (cond ((not (eq style 'nanp))
+ (list (bbdb-string-trim string)))
+ ((string-match ;; (415) 555-1212 x123
+ (concat "^[ \t]*" area-regexp main-regexp ext-regexp "$") string)
+ (list (bbdb-subint string 1) (bbdb-subint string 2)
+ (bbdb-subint string 3) (bbdb-subint string 4)))
+ ;; (415) 555-1212
+ ((string-match (concat "^[ \t]*" area-regexp main-regexp "$") string)
+ (list (bbdb-subint string 1) (bbdb-subint string 2)
+ (bbdb-subint string 3) 0))
+ ;; 555-1212 x123
+ ((string-match (concat "^[ \t]*" main-regexp ext-regexp "$") string)
+ (list 0 (bbdb-subint string 1) (bbdb-subint string 2)
+ (bbdb-subint string 3)))
+ ;; 555-1212
+ ((string-match (concat "^[ \t]*" main-regexp "$") string)
+ (list 0 (bbdb-subint string 1) (bbdb-subint string 2) 0))
+ ;; x123
+ ((string-match (concat "^[ \t]*" ext-regexp "$") string)
+ (list 0 0 0 (bbdb-subint string 1)))
+ ;; We trust the user she knows what she wants
+ (t (list (bbdb-string-trim string))))))
+
+(defun bbdb-message-search (name mail)
+ "Return list of BBDB records matching NAME and/or MAIL.
+First try to find a record matching both NAME and MAIL.
+If this fails try to find a record matching MAIL.
+If this fails try to find a record matching NAME.
+NAME may match FIRST_LAST, LAST_FIRST or AKA.
+
+This function performs a fast search using `bbdb-hashtable'.
+NAME and MAIL must be strings or nil.
+See `bbdb-search' for searching records with regexps."
+ (when (or name mail)
+ (bbdb-buffer) ; make sure database is loaded and up-to-date
+ (let ((mrecords (if mail (bbdb-gethash mail '(mail))))
+ (nrecords (if name (bbdb-gethash name '(fl-name lf-name aka)))))
+ ;; (1) records matching NAME and MAIL
+ (or (and mrecords nrecords
+ (let (records)
+ (dolist (record nrecords)
+ (mapc (lambda (mr) (if (and (eq record mr)
+ (not (memq record records)))
+ (push record records)))
+ mrecords))
+ records))
+ ;; (2) records matching MAIL
+ mrecords
+ ;; (3) records matching NAME
+ nrecords))))
+
+(defun bbdb-read-record (&optional first-and-last)
+ "Read and return a new BBDB record.
+Does not insert it into the database or update the hashtables,
+but does ensure that there will not be name collisions."
+ (bbdb-editable)
+ (let ((record (bbdb-empty-record)))
+ (let (name)
+ (bbdb-error-retry
+ (setq name (bbdb-read-name first-and-last))
+ (bbdb-check-name (car name) (cdr name)))
+ (bbdb-record-set-firstname record (car name))
+ (bbdb-record-set-lastname record (cdr name)))
+
+ ;; organization
+ (bbdb-record-set-organization record (bbdb-read-organization))
+
+ ;; mail
+ (bbdb-record-set-mail
+ record (bbdb-split 'mail (bbdb-read-string "E-Mail Addresses: ")))
+ ;; address
+ (let (addresses label address)
+ (while (not (string= ""
+ (setq label
+ (bbdb-read-string
+ "Snail Mail Address Label [RET when done]: "
+ nil
+ bbdb-address-label-list))))
+ (setq address (make-vector bbdb-address-length nil))
+ (bbdb-record-edit-address address label t)
+ (push address addresses))
+ (bbdb-record-set-address record (nreverse addresses)))
+
+ ;; phones
+ (let (phones phone-list label)
+ (while (not (string= ""
+ (setq label
+ (bbdb-read-string
+ "Phone Label [RET when done]: " nil
+ bbdb-phone-label-list))))
+ (setq phone-list
+ (bbdb-error-retry
+ (bbdb-parse-phone
+ (read-string "Phone: "
+ (and (integerp bbdb-default-area-code)
+ (format "(%03d) "
+ bbdb-default-area-code))))))
+ (push (apply 'vector label phone-list) phones))
+ (bbdb-record-set-phone record (nreverse phones)))
+
+ ;; `bbdb-default-xfield'
+ (let ((xfield (bbdb-read-xfield bbdb-default-xfield)))
+ (unless (string= "" xfield)
+ (bbdb-record-set-xfields
+ record (list (cons bbdb-default-xfield xfield)))))
+
+ record))
+
+(defun bbdb-read-name (&optional first-and-last dfirst dlast)
+ "Read name for a record from minibuffer.
+FIRST-AND-LAST controls the reading mode:
+If it is 'first-last read first and last name separately.
+If it is 'last-first read last and first name separately.
+If it is 'fullname read full name at once.
+If it is t read name parts separately, obeying `bbdb-read-name-format' if
possible.
+Otherwise use `bbdb-read-name-format'.
+DFIRST and DLAST are default values for the first and last name.
+Return cons with first and last name."
+ (unless (memq first-and-last '(first-last last-first fullname))
+ ;; We do not yet know how to read the name
+ (setq first-and-last
+ (if (and first-and-last
+ (not (memq bbdb-read-name-format '(first-last last-first))))
+ 'first-last
+ bbdb-read-name-format)))
+ (let ((name (cond ((eq first-and-last 'last-first)
+ (let (fn ln)
+ (setq ln (bbdb-read-string "Last Name: " dlast)
+ fn (bbdb-read-string "First Name: " dfirst))
+ (cons fn ln)))
+ ((eq first-and-last 'first-last)
+ (cons (bbdb-read-string "First Name: " dfirst)
+ (bbdb-read-string "Last Name: " dlast)))
+ (t
+ (bbdb-divide-name (bbdb-read-string
+ "Name: " (bbdb-concat 'name-first-last
+ dfirst
dlast)))))))
+ (if (string= (car name) "") (setcar name nil))
+ (if (string= (cdr name) "") (setcdr name nil))
+ name))
+
+;;;###autoload
+(defun bbdb-create (record)
+ "Add a new RECORD to BBDB.
+When called interactively read all relevant info.
+Do not call this from a program; call `bbdb-create-internal' instead."
+ (interactive (list (bbdb-read-record current-prefix-arg)))
+ (bbdb-change-record record)
+ (bbdb-display-records (list record)))
+
+(defsubst bbdb-split-maybe (separator string)
+ "Split STRING into list of substrings bounded by matches for SEPARATORS.
+If STRING is a list, return STRING. Throw error if STRING is neither a string
+nor a list."
+ (cond ((stringp string)
+ (bbdb-split separator string))
+ ((listp string) string)
+ (t (error "Cannot convert %s to list" string))))
+
+;;;###autoload
+(defun bbdb-create-internal (&rest spec)
+ "Add a new record to the database and return it.
+
+The following keywords are supported in SPEC:
+:name VAL String or a cons cell (FIRST . LAST), the name of the
person.
+ An error is thrown if VAL is already in use
+ and `bbdb-allow-duplicates' is nil.
+:affix VAL List of strings.
+:aka VAL List of strings.
+:organization VAL List of strings.
+:mail VAL String with comma-separated mail address
+ or a list of strings.
+ An error is thrown if a mail address in MAIL is already
+ in use and `bbdb-allow-duplicates' is nil.
+:phone VAL List of phone-number objects. A phone-number is a vector
+ [\"label\" areacode prefix suffix extension-or-nil]
+ or [\"label\" \"phone-number\"]
+:address VAL List of addresses. An address is a vector of the form
+ \[\"label\" (\"line1\" \"line2\" ... ) \"City\"
+ \"State\" \"Postcode\" \"Country\"].
+:xfields VAL Alist associating symbols with strings.
+:uuid VAL String, the uuid.
+:creation-date VAL String, the creation date.
+:check If present, throw an error if a field value is not
+ syntactically correct."
+ (bbdb-editable)
+ (let ((record (bbdb-empty-record))
+ (record-type (cdr bbdb-record-type))
+ (check (prog1 (memq :check spec)
+ (setq spec (delq :check spec))))
+ keyw)
+
+ ;; Check keys.
+ (while (keywordp (setq keyw (car spec)))
+ (setq spec (cdr spec))
+ (pcase keyw
+ (`:name
+ (let ((name (pop spec)))
+ (cond ((stringp name)
+ (setq name (bbdb-divide-name name)))
+ (check (bbdb-check-type name '(or (const nil)
+ (cons string string))
+ t)))
+ (let ((firstname (car name))
+ (lastname (cdr name)))
+ (bbdb-check-name firstname lastname) ; check for duplicates
+ (bbdb-record-set-firstname record firstname)
+ (bbdb-record-set-lastname record lastname))))
+
+ (`:affix
+ (let ((affix (bbdb-split-maybe 'affix (pop spec))))
+ (if check (bbdb-check-type affix (bbdb-record-affix record-type) t))
+ (bbdb-record-set-affix record affix)))
+
+ (`:organization
+ (let ((organization (bbdb-split-maybe 'organization (pop spec))))
+ (if check (bbdb-check-type
+ organization (bbdb-record-organization record-type) t))
+ (bbdb-record-set-organization record organization)))
+
+ (`:aka
+ (let ((aka (bbdb-split-maybe 'aka (pop spec))))
+ (if check (bbdb-check-type aka (bbdb-record-aka record-type) t))
+ (bbdb-record-set-aka record aka)))
+
+ (`:mail
+ (let ((mail (bbdb-split-maybe 'mail (pop spec))))
+ (if check (bbdb-check-type mail (bbdb-record-mail record-type) t))
+ (unless bbdb-allow-duplicates
+ (dolist (elt mail)
+ (if (bbdb-gethash elt '(mail))
+ (error "%s is already in the database" elt))))
+ (bbdb-record-set-mail record mail)))
+
+ (`:phone
+ (let ((phone (pop spec)))
+ (if check (bbdb-check-type phone (bbdb-record-phone record-type) t))
+ (bbdb-record-set-phone phone record)))
+
+ (`:address
+ (let ((address (pop spec)))
+ (if check (bbdb-check-type address (bbdb-record-address
record-type) t))
+ (bbdb-record-set-address record address)))
+
+ (`:xfields
+ (let ((xfields (pop spec)))
+ (if check (bbdb-check-type xfields (bbdb-record-xfields
record-type) t))
+ (bbdb-record-set-xfields record xfields)))
+
+ (`:uuid
+ (let ((uuid (pop spec)))
+ (if check (bbdb-check-type uuid (bbdb-record-uuid record-type) t))
+ (bbdb-record-set-uuid record uuid)))
+
+ (`:creation-date
+ (let ((creation-date (pop spec)))
+ (if check (bbdb-check-type
+ creation-date (bbdb-record-creation-date record-type) t))
+ (bbdb-record-set-creation-date record creation-date)))
+
+ (_ (error "Keyword `%s' undefined" keyw))))
+
+ (bbdb-change-record record)))
+
+;;;###autoload
+(defun bbdb-insert-field (record field value)
+ "For RECORD, add a new FIELD with value VALUE.
+Interactively, read FIELD and VALUE; RECORD is the current record.
+A non-nil prefix arg is passed on to `bbdb-read-field' as FLAG (see there)."
+ (interactive
+ (let* ((_ (bbdb-editable))
+ (record (or (bbdb-current-record)
+ (error "Point not on a record")))
+ (list (append bbdb-xfield-label-list
+ '(affix organization aka phone address mail)))
+ (field "")
+ (completion-ignore-case t)
+ (present (mapcar 'car (bbdb-record-xfields record))))
+ (if (bbdb-record-affix record) (push 'affix present))
+ (if (bbdb-record-organization record) (push 'organization present))
+ (if (bbdb-record-mail record) (push 'mail present))
+ (if (bbdb-record-aka record) (push 'aka present))
+ (dolist (field present)
+ (setq list (remq field list)))
+ (setq list (mapcar 'symbol-name list))
+ (while (string= field "")
+ (setq field (downcase (completing-read "Insert Field: " list))))
+ (setq field (intern field))
+ (if (memq field present)
+ (error "Field \"%s\" already exists" field))
+ (list record field (bbdb-read-field record field current-prefix-arg))))
+
+ (cond (;; affix
+ (eq field 'affix)
+ (if (bbdb-record-affix record)
+ (error "Affix field exists already"))
+ (if (stringp value)
+ (setq value (bbdb-split 'affix value)))
+ (bbdb-record-set-field record 'affix value))
+ ;; organization
+ ((eq field 'organization)
+ (if (bbdb-record-organization record)
+ (error "Organization field exists already"))
+ (if (stringp value)
+ (setq value (bbdb-split 'organization value)))
+ (bbdb-record-set-field record 'organization value))
+ ;; phone
+ ((eq field 'phone)
+ (bbdb-record-set-field record 'phone
+ (nconc (bbdb-record-phone record)
+ (list value))))
+ ;; address
+ ((eq field 'address)
+ (bbdb-record-set-field record 'address
+ (nconc (bbdb-record-address record)
+ (list value))))
+ ;; mail
+ ((eq field 'mail)
+ (if (bbdb-record-mail record)
+ (error "Mail field exists already"))
+ (if (stringp value)
+ (setq value (bbdb-split 'mail value)))
+ (bbdb-record-set-field record 'mail value))
+ ;; AKA
+ ((eq field 'aka)
+ (if (bbdb-record-aka record)
+ (error "Alternate names field exists already"))
+ (if (stringp value)
+ (setq value (bbdb-split 'aka value)))
+ (bbdb-record-set-field record 'aka value))
+ ;; xfields
+ ((assq field (bbdb-record-xfields record))
+ (error "Xfield \"%s\" already exists" field))
+ (t
+ (bbdb-record-set-xfield record field value)))
+ (unless (bbdb-change-record record)
+ (message "Record unchanged")))
+
+(defun bbdb-read-field (record field &optional flag)
+ "For RECORD read new FIELD interactively.
+- The phone number style is controlled via `bbdb-phone-style'.
+ A prefix FLAG inverts the style,
+- If a mail address lacks a domain, append `bbdb-default-domain'
+ if this variable non-nil. With prefix FLAG do not alter the mail address.
+- The value of an xfield is a string. With prefix FLAG the value may be
+ any lisp object."
+ (let* ((init-f (intern-soft (concat "bbdb-init-" (symbol-name field))))
+ (init (if (and init-f (functionp init-f))
+ (funcall init-f record))))
+ (cond (;; affix
+ (eq field 'affix) (bbdb-read-string "Affix: " init))
+ ;; organization
+ ((eq field 'organization) (bbdb-read-organization init))
+ ;; mail
+ ((eq field 'mail)
+ (let ((mail (bbdb-read-string "Mail: " init)))
+ (if (string-match "^mailto:"; mail)
+ (setq mail (substring mail (match-end 0))))
+ (if (or (not bbdb-default-domain)
+ flag (string-match "address@hidden" mail))
+ mail
+ (concat mail "@" bbdb-default-domain))))
+ ;; AKA
+ ((eq field 'aka) (bbdb-read-string "Alternate Names: " init))
+ ;; Phone
+ ((eq field 'phone)
+ (let ((bbdb-phone-style
+ (if flag (if (eq bbdb-phone-style 'nanp) nil 'nanp)
+ bbdb-phone-style)))
+ (apply 'vector
+ (bbdb-read-string "Label: " nil bbdb-phone-label-list)
+ (bbdb-error-retry
+ (bbdb-parse-phone
+ (read-string "Phone: "
+ (and (integerp bbdb-default-area-code)
+ (format "(%03d) "
+ bbdb-default-area-code))))))))
+ ;; Address
+ ((eq field 'address)
+ (let ((address (make-vector bbdb-address-length nil)))
+ (bbdb-record-edit-address address nil t)
+ address))
+ ;; xfield
+ ((or (memq field bbdb-xfield-label-list)
+ ;; New xfield
+ (y-or-n-p
+ (format "\"%s\" is an unknown field name. Define it? " field))
+ (error "Aborted"))
+ (bbdb-read-xfield field init flag)))))
+
+;;;###autoload
+(defun bbdb-edit-field (record field &optional value flag)
+ "Edit the contents of FIELD of RECORD.
+If point is in the middle of a multi-line field (e.g., address),
+then the entire field is edited, not just the current line.
+For editing phone numbers or addresses, VALUE must be the phone number
+or address that gets edited. An error is thrown when attempting to edit
+a phone number or address with VALUE being nil.
+
+- The value of an xfield is a string. With prefix FLAG the value may be
+ any lisp object."
+ (interactive
+ (save-excursion
+ (bbdb-editable)
+ ;; when at the end of the line take care of it
+ (if (and (eolp) (not (bobp)) (not (bbdb-current-field)))
+ (backward-char 1))
+ (let* ((field-l (bbdb-current-field))
+ (field (car field-l))
+ (value (nth 1 field-l)))
+ (unless field (error "Point not in a field"))
+ (list (bbdb-current-record)
+ (if (memq field '(name affix organization aka mail phone address
+ uuid creation-date timestamp))
+ field ; not an xfield
+ (elt value 0)) ; xfield
+ value current-prefix-arg))))
+ (let (edit-str)
+ (cond ((memq field '(firstname lastname xfields))
+ ;; FIXME: We could also edit first and last names.
+ (error "Field `%s' not editable this way." field))
+ ((eq field 'name)
+ (bbdb-error-retry
+ (bbdb-record-set-field
+ record 'name
+ (bbdb-read-name
+ (if flag
+ ;; Here we try to obey the name-format xfield for
+ ;; editing the name field. Is this useful? Or is this
+ ;; irritating overkill and we better obey consistently
+ ;; `bbdb-read-name-format'?
+ (or (bbdb-record-xfield-intern record 'name-format)
+ flag))
+ (bbdb-record-firstname record)
+ (bbdb-record-lastname record)))))
+
+ ((eq field 'phone)
+ (unless value (error "No phone specified"))
+ (bbdb-record-edit-phone (bbdb-record-phone record) value))
+ ((eq field 'address)
+ (unless value (error "No address specified"))
+ (bbdb-record-edit-address value nil flag))
+ ((eq field 'organization)
+ (bbdb-record-set-field
+ record field
+ (bbdb-read-organization
+ (bbdb-concat field (bbdb-record-organization record)))))
+ ((setq edit-str (assq field '((affix . "Affix")
+ (mail . "Mail") (aka . "AKA"))))
+ (bbdb-record-set-field
+ record field
+ (bbdb-split field (bbdb-read-string
+ (format "%s: " (cdr edit-str))
+ (bbdb-concat field
+ (bbdb-record-field record
field))))))
+ ((eq field 'uuid)
+ (bbdb-record-set-field
+ record 'uuid (bbdb-read-string "uuid (edit at your own risk): "
(bbdb-record-uuid record))))
+ ((eq field 'creation-date)
+ (bbdb-record-set-creation-date
+ record (bbdb-read-string "creation-date: "
(bbdb-record-creation-date record))))
+ ;; The timestamp is set automatically whenever we save a modified
record.
+ ;; So any editing gets overwritten.
+ ((eq field 'timestamp)) ; do nothing
+ (t ; xfield
+ (bbdb-record-set-xfield
+ record field
+ (bbdb-read-xfield field (bbdb-record-xfield record field) flag))))
+ (cond ((eq field 'timestamp)
+ (message "timestamp not editable"))
+ ((bbdb-change-record record))
+ (t (message "Record unchanged")))))
+
+(defun bbdb-edit-foo (record field &optional nvalue)
+ "For RECORD edit some FIELD (mostly interactively).
+FIELD may take the same values as the elements of the variable `bbdb-edit-foo'.
+If FIELD is 'phone or 'address, NVALUE should be an integer in order to edit
+the NVALUEth phone or address field; otherwise insert a new phone or address
+field.
+
+Interactively, if called without a prefix, the value of FIELD is the car
+of the variable `bbdb-edit-foo'. When called with a prefix, the value
+of FIELD is the cdr of this variable. Then use minibuffer completion
+to select the field."
+ (interactive
+ (let* ((_ (bbdb-editable))
+ (record (bbdb-current-record))
+ (tmp (if current-prefix-arg (cdr bbdb-edit-foo) (car bbdb-edit-foo)))
+ (field (if (memq tmp '(current-fields all-fields))
+ ;; Do not require match so that we can define new xfields.
+ (intern (completing-read
+ "Edit field: " (mapcar 'list (if (eq tmp
'all-fields)
+ (append '(name
affix organization aka mail phone address uuid creation-date)
+
bbdb-xfield-label-list)
+ (append (if
(bbdb-record-affix record) '(affix))
+ (if
(bbdb-record-organization record) '(organization))
+ (if
(bbdb-record-aka record) '(aka))
+ (if
(bbdb-record-mail record) '(mail))
+ (if
(bbdb-record-phone record) '(phone))
+ (if
(bbdb-record-address record) '(address))
+ (mapcar
'car (bbdb-record-xfields record))
+ '(name
uuid creation-date))))))
+ tmp))
+ ;; Multiple phone and address fields may use the same label.
+ ;; So we cannot use these labels to uniquely identify
+ ;; a phone or address field. So instead we number these fields
+ ;; consecutively. But we do use the labels to annotate the numbers
+ ;; (available starting from GNU Emacs 24.1).
+ (nvalue (cond ((eq field 'phone)
+ (let* ((phones (bbdb-record-phone record))
+ (collection (cons (cons "new" "new phone #")
+ (mapcar (lambda (n)
+ (cons (format "%d"
n) (bbdb-phone-label (nth n phones))))
+ (number-sequence 0
(1- (length phones))))))
+ (completion-extra-properties
+ `(:annotation-function
+ (lambda (s) (format " (%s)" (cdr (assoc s
',collection)))))))
+ (if (< 0 (length phones))
+ (completing-read "Phone field: " collection nil
t)
+ "new")))
+ ((eq field 'address)
+ (let* ((addresses (bbdb-record-address record))
+ (collection (cons (cons "new" "new address")
+ (mapcar (lambda (n)
+ (cons (format "%d"
n) (bbdb-address-label (nth n addresses))))
+ (number-sequence 0
(1- (length addresses))))))
+ (completion-extra-properties
+ `(:annotation-function
+ (lambda (s) (format " (%s)" (cdr (assoc s
',collection)))))))
+ (if (< 0 (length addresses))
+ (completing-read "Address field: " collection
nil t)
+ "new"))))))
+ (list record field (and (stringp nvalue)
+ (if (string= "new" nvalue)
+ 'new
+ (string-to-number nvalue))))))
+
+ (if (memq field '(firstname lastname name-lf aka-all mail-aka mail-canon))
+ (error "Field `%s' illegal" field))
+ (let ((value (if (numberp nvalue)
+ (nth nvalue (cond ((eq field 'phone) (bbdb-record-phone
record))
+ ((eq field 'address) (bbdb-record-address
record))
+ (t (error "%s: nvalue %s meaningless"
field nvalue)))))))
+ (if (and (numberp nvalue) (not value))
+ (error "%s: nvalue %s out of range" field nvalue))
+ (if (or (memq field '(name uuid creation-date))
+ (and (eq field 'affix) (bbdb-record-affix record))
+ (and (eq field 'organization) (bbdb-record-organization record))
+ (and (eq field 'mail) (bbdb-record-mail record))
+ (and (eq field 'aka) (bbdb-record-aka record))
+ (assq field (bbdb-record-xfields record))
+ value)
+ (bbdb-edit-field record field value)
+ (bbdb-insert-field record field
+ (bbdb-read-field record field)))))
+
+(defun bbdb-read-xfield (field &optional init sexp)
+ "Read xfield FIELD with optional INIT.
+This calls bbdb-read-xfield-FIELD if it exists."
+ (let ((read-fun (intern-soft (format "bbdb-read-xfield-%s" field))))
+ (cond ((fboundp read-fun)
+ (funcall read-fun init))
+ ((and (not sexp) (string-or-null-p init))
+ (bbdb-read-string (format "%s: " field) init))
+ (t (read-minibuffer (format "%s (sexp): " field)
+ (prin1-to-string init))))))
+
+(defun bbdb-read-organization (&optional init)
+ "Read organization."
+ (if (string< "24.3" (substring emacs-version 0 4))
+ (let ((crm-separator
+ (concat "[ \t\n]*"
+ (cadr (assq 'organization bbdb-separator-alist))
+ "[ \t\n]*"))
+ (crm-local-completion-map bbdb-crm-local-completion-map))
+ (completing-read-multiple "Organizations: " bbdb-organization-list
+ nil nil init))
+ (bbdb-split 'organization (bbdb-read-string "Organizations: " init))))
+
+(defun bbdb-record-edit-address (address &optional label ignore-country)
+ "Edit ADDRESS.
+If LABEL is nil, edit the label sub-field of the address as well.
+If the country field of ADDRESS is nonempty and IGNORE-COUNTRY is nil,
+use the rule from `bbdb-address-format-list' matching this country.
+Otherwise, use the default rule according to `bbdb-address-format-list'."
+ (unless label
+ (setq label (bbdb-read-string "Label: "
+ (bbdb-address-label address)
+ bbdb-address-label-list)))
+ (let ((country (or (bbdb-address-country address) ""))
+ new-addr edit)
+ (unless (or ignore-country (string= "" country))
+ (let ((list bbdb-address-format-list)
+ identifier elt)
+ (while (and (not edit) (setq elt (pop list)))
+ (setq identifier (car elt))
+ (if (or (and (listp identifier)
+ (member-ignore-case country identifier))
+ (and (functionp identifier)
+ (funcall identifier address)))
+ (setq edit (nth 1 elt))))))
+ (unless edit
+ (setq edit (nth 1 (assq t bbdb-address-format-list))))
+ (unless edit (error "No address editing function defined"))
+ (if (functionp edit)
+ (setq new-addr (funcall edit address))
+ (setq new-addr (make-vector 5 ""))
+ (dolist (elt (string-to-list edit))
+ (cond ((eq elt ?s)
+ (aset new-addr 0 (bbdb-edit-address-street
+ (bbdb-address-streets address))))
+ ((eq elt ?c)
+ (aset new-addr 1 (bbdb-read-string
+ "City: " (bbdb-address-city address)
+ bbdb-city-list)))
+ ((eq elt ?S)
+ (aset new-addr 2 (bbdb-read-string
+ "State: " (bbdb-address-state address)
+ bbdb-state-list)))
+ ((eq elt ?p)
+ (aset new-addr 3
+ (bbdb-error-retry
+ (bbdb-parse-postcode
+ (bbdb-read-string
+ "Postcode: " (bbdb-address-postcode address)
+ bbdb-postcode-list)))))
+ ((eq elt ?C)
+ (aset new-addr 4
+ (bbdb-read-string
+ "Country: " (or (bbdb-address-country address)
+ bbdb-default-country)
+ bbdb-country-list))))))
+ (bbdb-address-set-label address label)
+ (bbdb-address-set-streets address (elt new-addr 0))
+ (bbdb-address-set-city address (elt new-addr 1))
+ (bbdb-address-set-state address (elt new-addr 2))
+ (bbdb-address-set-postcode address (elt new-addr 3))
+ (if (string= "" (bbdb-concat "" (elt new-addr 0) (elt new-addr 1)
+ (elt new-addr 2) (elt new-addr 3)
+ (elt new-addr 4)))
+ ;; User did not enter anything. this causes a display bug.
+ ;; The following is a temporary fix. Ideally, we would simply discard
+ ;; the entire address, but that requires bigger hacking.
+ (bbdb-address-set-country address "Emacs")
+ (bbdb-address-set-country address (elt new-addr 4)))))
+
+(defun bbdb-edit-address-street (streets)
+ "Edit list STREETS."
+ (let ((n 0) street list)
+ (while (not (string= "" (setq street
+ (bbdb-read-string
+ (format "Street, line %d: " (1+ n))
+ (nth n streets) bbdb-street-list))))
+ (push street list)
+ (setq n (1+ n)))
+ (reverse list)))
+
+;; This function can provide some guidance for writing
+;; your own address editing function
+(defun bbdb-edit-address-default (address)
+ "Function to use for address editing.
+The sub-fields and the prompts used are:
+Street, line n: (nth n street)
+City: city
+State: state
+Postcode: postcode
+Country: country"
+ (list (bbdb-edit-address-street (bbdb-address-streets address))
+ (bbdb-read-string "City: " (bbdb-address-city address) bbdb-city-list)
+ (bbdb-read-string "State: " (bbdb-address-state address)
+ bbdb-state-list)
+ (bbdb-error-retry
+ (bbdb-parse-postcode
+ (bbdb-read-string "Postcode: " (bbdb-address-postcode address)
+ bbdb-postcode-list)))
+ (bbdb-read-string "Country: " (or (bbdb-address-country address)
+ bbdb-default-country)
+ bbdb-country-list)))
+
+(defun bbdb-record-edit-phone (phones phone)
+ "For list PHONES edit PHONE number."
+ ;; Phone numbers are special. They are vectors with either
+ ;; two or four elements. We do not know whether after editing PHONE
+ ;; we still have a number requiring the same format as PHONE.
+ ;; So we take all numbers PHONES of the record so that we can
+ ;; replace the element PHONE in PHONES.
+ (setcar (memq phone phones)
+ (apply 'vector
+ (bbdb-read-string "Label: "
+ (bbdb-phone-label phone)
+ bbdb-phone-label-list)
+ (bbdb-error-retry
+ (bbdb-parse-phone
+ (read-string "Phone: " (bbdb-phone-string phone)))))))
+
+;; (bbdb-list-transpose '(a b c d) 1 3)
+(defun bbdb-list-transpose (list i j)
+ "For LIST transpose elements I and J destructively.
+I and J start with zero. Return the modified LIST."
+ (if (eq i j)
+ list ; ignore that i, j could be invalid
+ (let (a b c)
+ ;; Travel down LIST only once
+ (if (> i j) (setq a i i j j a)); swap
+ (setq a (nthcdr i list)
+ b (nthcdr (- j i) a)
+ c (car b))
+ (unless b (error "Args %i, %i beyond length of list." i j))
+ (setcar b (car a))
+ (setcar a c)
+ list)))
+
+(defun bbdb-ident-point (&optional point)
+ "Return identifier (RECNUM FIELD NUM) for position POINT.
+If POINT is nil use current value of point.
+RECNUM is the number of the record (starting from zero).
+FIELD is the field type.
+If FIELD's value is a list, NUM is the position of the subfield within FIELD.
+If any of these terms is not defined at POINT, the respective value is nil."
+ (unless point (setq point (point)))
+ (let ((recnum (get-text-property point 'bbdb-record-number))
+ (field (get-text-property point 'bbdb-field)))
+ (cond ((not field)
+ (list recnum nil nil))
+ ((eq (car field) 'name)
+ (list recnum 'name nil))
+ ((not (nth 1 field))
+ (list recnum (car field) nil))
+ (t
+ (let* ((record (car (nth recnum bbdb-records)))
+ (fields (bbdb-record-field record (car field)))
+ (val (nth 1 field))
+ (num 0) done elt)
+ ;; For xfields we only check the label because the rest of VAL
+ ;; can be anything. (xfields are unique within a record.)
+ (if (eq 'xfields (car field))
+ (setq val (car val)
+ fields (mapcar 'car fields)))
+ (while (and (not done) (setq elt (pop fields)))
+ (if (eq val elt)
+ (setq done t)
+ (setq num (1+ num))))
+ (unless done (error "Field %s not found" val))
+ (list recnum (car field) num))))))
+
+;;;###autoload
+(defun bbdb-transpose-fields (arg)
+ "Transpose previous and current field of a BBDB record.
+With numeric prefix ARG, take previous field and move it past ARG fields.
+With region active or ARG 0, transpose field point is in and 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 numbers
+or email addresses are listed, but you cannot use it to make an address appear
+before a phone number; the order of field types is fixed).
+
+If the current field is the name field, transpose first and last name,
+irrespective of the value of ARG."
+ ;; This functionality is inspired by `transpose-lines'.
+ (interactive "p")
+ (bbdb-editable)
+ (let* ((ident (bbdb-ident-point))
+ (record (and (car ident) (car (nth (car ident) bbdb-records))))
+ num1 num2)
+ (cond ((not (car ident))
+ (error "Point not in BBDB record"))
+ ((not (nth 1 ident))
+ (error "Point not in BBDB field"))
+ ((eq 'name (nth 1 ident))
+ ;; Transpose firstname and lastname
+ (bbdb-record-set-name record (bbdb-record-lastname record)
+ (bbdb-record-firstname record)))
+ ((not (integerp arg))
+ (error "Arg `%s' not an integer" arg))
+ ((not (nth 2 ident))
+ (error "Point not in a transposable field"))
+ (t
+ (if (or (use-region-p) (zerop arg))
+ (let ((ident2 (bbdb-ident-point
+ (or (mark) (error "No mark set in this
buffer")))))
+ (unless (and (eq (car ident) (car ident2))
+ (eq (cadr ident) (cadr ident2))
+ (integerp (nth 2 ident2)))
+ (error "Mark (or point) not on transposable field"))
+ (setq num1 (nth 2 ident)
+ num2 (nth 2 ident2)))
+ (setq num1 (1- (nth 2 ident))
+ num2 (+ num1 arg))
+ (if (or (< (min num1 num2) 0)
+ (>= (max num1 num2) (length (bbdb-record-field
+ record (nth 1 ident)))))
+ (error "Cannot transpose fields of different types")))
+ (bbdb-record-set-field
+ record (nth 1 ident)
+ (bbdb-list-transpose (bbdb-record-field record (nth 1 ident))
+ num1 num2))))
+ (bbdb-change-record record)))
+
+;;;###autoload
+(defun bbdb-delete-field-or-record (records field &optional noprompt)
+ "For RECORDS delete FIELD.
+If FIELD is the `name' field, delete RECORDS from datanbase.
+Interactively, use BBDB prefix \
+\\<bbdb-mode-map>\\[bbdb-do-all-records], see `bbdb-do-all-records',
+and FIELD is the field point is on.
+If prefix NOPROMPT is non-nil, do not confirm deletion."
+ ;; The value of FIELD is whatever `bbdb-current-field' returns.
+ ;; This way we can identify more accurately what really needs
+ ;; to be done.
+ (interactive
+ (list (bbdb-do-records) (bbdb-current-field) current-prefix-arg))
+ (bbdb-editable)
+ (unless field (error "Not a field"))
+ (setq records (bbdb-record-list records))
+ (let* ((type (car field))
+ (type-x (if (eq type 'xfields)
+ (car (nth 1 field))
+ type)))
+ (if (eq type 'name)
+ (bbdb-delete-records records noprompt)
+ (if (memq type '(firstname lastname))
+ (error "Cannot delete field `%s'" type))
+ (dolist (record records)
+ (when (or noprompt
+ (y-or-n-p (format "delete this `%s' field (of %s)? "
+ type-x (bbdb-record-name record))))
+ (cond ((memq type '(phone address))
+ (bbdb-record-set-field
+ record type
+ ;; We use `delete' which deletes all phone and address
+ ;; fields equal to the current one. This works for
+ ;; multiple records.
+ (delete (nth 1 field)
+ (bbdb-record-field record type))))
+ ((memq type '(affix organization mail aka))
+ (bbdb-record-set-field record type nil))
+ ((eq type 'xfields)
+ (bbdb-record-set-xfield record type-x nil))
+ (t (error "Unknown field %s" type)))
+ (bbdb-change-record record))))))
+
+;;;###autoload
+(defun bbdb-delete-records (records &optional noprompt)
+ "Delete RECORDS.
+Interactively, use BBDB prefix \
+\\<bbdb-mode-map>\\[bbdb-do-all-records], see `bbdb-do-all-records'.
+If prefix NOPROMPT is non-nil, do not confirm deletion."
+ (interactive (list (bbdb-do-records) current-prefix-arg))
+ (bbdb-editable)
+ (let ((all-records (bbdb-with-db-buffer bbdb-records)))
+ (dolist (record (bbdb-record-list records))
+ (cond ((not (memq record all-records))
+ ;; Possibly we changed RECORD before deleting it.
+ ;; Otherwise, do nothing if RECORD is unknown to BBDB.
+ (setq bbdb-changed-records (delq record bbdb-changed-records)))
+ ((or noprompt
+ (y-or-n-p (format "Delete the BBDB record of %s? "
+ (or (bbdb-record-name record)
+ (car (bbdb-record-mail record))))))
+ (bbdb-delete-record-internal record t)
+ (setq bbdb-changed-records (delq record
bbdb-changed-records)))))))
+
+;;;###autoload
+(defun bbdb-display-all-records (&optional layout)
+ "Show all records.
+If invoked in a *BBDB* buffer point stays on the currently visible record.
+Inverse of `bbdb-display-current-record'."
+ (interactive (list (bbdb-layout-prefix)))
+ (let ((current (ignore-errors (bbdb-current-record))))
+ (bbdb-display-records (bbdb-records) layout)
+ (when (setq current (assq current bbdb-records))
+ (redisplay) ; Strange display bug??
+ (goto-char (nth 2 current)))))
+ ;; (set-window-point (selected-window) (nth 2 current)))))
+
+;;;###autoload
+(defun bbdb-display-current-record (&optional layout)
+ "Narrow to current record. Inverse of `bbdb-display-all-records'."
+ (interactive (list (bbdb-layout-prefix)))
+ (bbdb-display-records (list (bbdb-current-record)) layout))
+
+(defun bbdb-change-records-layout (records layout)
+ (dolist (record records)
+ (unless (eq layout (nth 1 record))
+ (setcar (cdr record) layout)
+ (bbdb-redisplay-record (car record)))))
+
+;;;###autoload
+(defun bbdb-toggle-records-layout (records &optional arg)
+ "Toggle layout of RECORDS (elided or expanded).
+Interactively, use BBDB prefix \
+\\<bbdb-mode-map>\\[bbdb-do-all-records], see `bbdb-do-all-records'.
+With prefix ARG 0, RECORDS are displayed elided.
+With any other non-nil ARG, RECORDS are displayed expanded."
+ (interactive (list (bbdb-do-records t) current-prefix-arg))
+ (let* ((record (bbdb-current-record))
+ (current-layout (nth 1 (assq record bbdb-records)))
+ (layout-alist
+ ;; Try to consider only those layouts that have the `toggle'
+ ;; option set
+ (or (delq nil (mapcar (lambda (l)
+ (if (and (assq 'toggle l)
+ (cdr (assq 'toggle l)))
+ l))
+ bbdb-layout-alist))
+ bbdb-layout-alist))
+ (layout
+ (cond ((eq arg 0)
+ 'one-line)
+ ((null current-layout)
+ 'multi-line)
+ ;; layout is not the last element of layout-alist
+ ;; and we switch to the following element of layout-alist
+ ((caar (cdr (memq (assq current-layout layout-alist)
+ layout-alist))))
+ (t ; layout is the last element of layout-alist
+ ;; and we switch to the first element of layout-alist
+ (caar layout-alist)))))
+ (message "Using %S layout" layout)
+ (bbdb-change-records-layout (bbdb-record-list records t) layout)))
+
+;;;###autoload
+(defun bbdb-display-records-completely (records)
+ "Display RECORDS using layout `full-multi-line' (i.e., display all fields).
+Interactively, use BBDB prefix \
+\\<bbdb-mode-map>\\[bbdb-do-all-records], see `bbdb-do-all-records'."
+ (interactive (list (bbdb-do-records t)))
+ (let* ((record (bbdb-current-record))
+ (current-layout (nth 1 (assq record bbdb-records)))
+ (layout (if (not (eq current-layout 'full-multi-line))
+ 'full-multi-line
+ 'multi-line)))
+ (bbdb-change-records-layout (bbdb-record-list records t) layout)))
+
+;;;###autoload
+(defun bbdb-display-records-with-layout (records layout)
+ "Display RECORDS using LAYOUT.
+Interactively, use BBDB prefix \
+\\<bbdb-mode-map>\\[bbdb-do-all-records], see `bbdb-do-all-records'."
+ (interactive
+ (list (bbdb-do-records t)
+ (intern (completing-read "Layout: "
+ (mapcar (lambda (i)
+ (list (symbol-name (car i))))
+ bbdb-layout-alist)))))
+ (bbdb-change-records-layout (bbdb-record-list records t) layout))
+
+;;;###autoload
+(defun bbdb-omit-record (n)
+ "Remove current record from the display without deleting it from BBDB.
+With prefix N, omit the next N records. If negative, omit backwards."
+ (interactive "p")
+ (let ((num (get-text-property (if (and (not (bobp)) (eobp))
+ (1- (point)) (point))
+ 'bbdb-record-number)))
+ (if (> n 0)
+ (setq n (min n (- (length bbdb-records) num)))
+ (setq n (min (- n) num))
+ (bbdb-prev-record n))
+ (dotimes (_i n)
+ (bbdb-redisplay-record (bbdb-current-record) nil t))))
+
+;;; Fixing up bogus records
+
+;;;###autoload
+(defun bbdb-merge-records (record1 record2)
+ "Merge RECORD1 into RECORD2, then delete RECORD1 and return RECORD2.
+If both records have name fields ask which one to use.
+Concatenate other fields, ignoring duplicates.
+RECORD1 need not be known to BBDB, its hash and cache are ignored.
+Update hash and cache for RECORD2.
+
+Interactively, RECORD1 is the current record; prompt for RECORD2.
+With prefix, RECORD2 defaults to the first record with the same name."
+ (interactive
+ (let* ((_ (bbdb-editable))
+ (record1 (bbdb-current-record))
+ (name (bbdb-record-name record1))
+ (record2 (and current-prefix-arg
+ ;; take the first record with the same name
+ (car (delq record1
+ (bbdb-search (bbdb-records) :all-names
name))))))
+ (when record2
+ (message "Merge current record with duplicate record `%s'" name)
+ (sit-for 1))
+ (list record1
+ (or record2
+ (bbdb-completing-read-record
+ (format "merge record \"%s\" into: "
+ (or (bbdb-record-name record1)
+ (car (bbdb-record-mail record1))
+ "???"))
+ (list record1))))))
+
+ (bbdb-editable)
+ (cond ((eq record1 record2) (error "Records are equal"))
+ ((null record2) (error "No record to merge with")))
+
+ ;; Merge names
+ (let* ((new-name (bbdb-record-name record2))
+ (old-name (bbdb-record-name record1))
+ (old-aka (bbdb-record-aka record1))
+ extra-name
+ (name
+ (cond ((or (string= "" old-name)
+ (bbdb-string= old-name new-name))
+ (cons (bbdb-record-firstname record2)
+ (bbdb-record-lastname record2)))
+ ((string= "" new-name)
+ (cons (bbdb-record-firstname record1)
+ (bbdb-record-lastname record1)))
+ (t (prog1
+ (if (y-or-n-p
+ (format "Use name \"%s\" instead of \"%s\"? "
+ old-name new-name))
+ (progn
+ (setq extra-name new-name)
+ (cons (bbdb-record-firstname record1)
+ (bbdb-record-lastname record1)))
+ (setq extra-name old-name)
+ (cons (bbdb-record-firstname record2)
+ (bbdb-record-lastname record2)))
+ (unless (bbdb-eval-spec
+ (bbdb-add-job bbdb-add-aka record2 extra-name)
+ (format "Keep \"%s\" as an alternate name? "
+ extra-name))
+ (setq extra-name nil)))))))
+
+ (bbdb-record-set-name record2 (car name) (cdr name))
+
+ (if extra-name (push extra-name old-aka))
+ ;; It is better to delete RECORD1 at the end.
+ ;; So we must temporarily allow duplicates in RECORD2.
+ (let ((bbdb-allow-duplicates t))
+ (bbdb-record-set-field record2 'aka old-aka t)))
+
+ ;; Merge other stuff
+ (bbdb-record-set-field record2 'affix
+ (bbdb-record-affix record1) t)
+ (bbdb-record-set-field record2 'organization
+ (bbdb-record-organization record1) t)
+ (bbdb-record-set-field record2 'phone
+ (bbdb-record-phone record1) t)
+ (bbdb-record-set-field record2 'address
+ (bbdb-record-address record1) t)
+ (let ((bbdb-allow-duplicates t))
+ (bbdb-record-set-field record2 'mail
+ (bbdb-record-mail record1) t))
+ (bbdb-record-set-field record2 'xfields
+ (bbdb-record-xfields record1) t)
+
+ ;; `bbdb-delete-records' does nothing if RECORD1 is not known to BBDB.
+ (bbdb-delete-records (list record1) 'noprompt)
+ (bbdb-change-record record2)
+ record2)
+
+;; The following sorting functions are also intended for use
+;; in `bbdb-change-hook'. Then they will be called with one arg, the record.
+
+;;;###autoload
+(defun bbdb-sort-addresses (records &optional update)
+ "Sort the addresses in RECORDS according to the label.
+Interactively, use BBDB prefix \
+\\<bbdb-mode-map>\\[bbdb-do-all-records], see `bbdb-do-all-records'.
+If UPDATE is non-nil (as in interactive calls) update the database.
+Otherwise, this is the caller's responsiblity (for example, when used
+in `bbdb-change-hook')."
+ (interactive (list (bbdb-do-records) t))
+ (bbdb-editable)
+ (dolist (record (bbdb-record-list records))
+ (bbdb-record-set-address
+ record (sort (bbdb-record-address record)
+ (lambda (xx yy) (string< (aref xx 0) (aref yy 0)))))
+ (if update
+ (bbdb-change-record record))))
+
+;;;###autoload
+(defun bbdb-sort-phones (records &optional update)
+ "Sort the phones in RECORDS according to the label.
+Interactively, use BBDB prefix \
+\\<bbdb-mode-map>\\[bbdb-do-all-records], see `bbdb-do-all-records'.
+If UPDATE is non-nil (as in interactive calls) update the database.
+Otherwise, this is the caller's responsiblity (for example, when used
+in `bbdb-change-hook')."
+ (interactive (list (bbdb-do-records) t))
+ (bbdb-editable)
+ (dolist (record (bbdb-record-list records))
+ (bbdb-record-set-phone
+ record (sort (bbdb-record-phone record)
+ (lambda (xx yy) (string< (aref xx 0) (aref yy 0)))))
+ (if update
+ (bbdb-change-record record))))
+
+;;;###autoload
+(defun bbdb-sort-xfields (records &optional update)
+ "Sort the xfields in RECORDS according to `bbdb-xfields-sort-order'.
+Interactively, use BBDB prefix \
+\\<bbdb-mode-map>\\[bbdb-do-all-records], see `bbdb-do-all-records'.
+If UPDATE is non-nil (as in interactive calls) update the database.
+Otherwise, this is the caller's responsiblity (for example, when used
+in `bbdb-change-hook')."
+ (interactive (list (bbdb-do-records) t))
+ (bbdb-editable)
+ (dolist (record (bbdb-record-list records))
+ (bbdb-record-set-xfields
+ record (sort (bbdb-record-xfields record)
+ (lambda (a b)
+ (< (or (cdr (assq (car a) bbdb-xfields-sort-order)) 100)
+ (or (cdr (assq (car b) bbdb-xfields-sort-order))
100)))))
+ (if update
+ (bbdb-change-record record))))
+(define-obsolete-function-alias 'bbdb-sort-notes 'bbdb-sort-xfields "3.0")
+
+;;; Send-Mail interface
+
+;;;###autoload
+(defun bbdb-dwim-mail (record &optional mail)
+ ;; Do What I Mean!
+ "Return a string to use as the mail address of RECORD.
+The name in the mail address is formatted obeying `bbdb-mail-name-format'
+and `bbdb-mail-name'. However, if both the first name and last name
+are constituents of the address as in address@hidden,
+and `bbdb-mail-avoid-redundancy' is non-nil, then the address is used as is
+and `bbdb-mail-name-format' and `bbdb-mail-name' are ignored.
+If `bbdb-mail-avoid-redundancy' is 'mail-only the name is never included.
+MAIL may be a mail address to be used for RECORD.
+If MAIL is an integer, use the MAILth mail address of RECORD.
+If MAIL is nil use the first mail address of RECORD."
+ (unless mail
+ (let ((mails (bbdb-record-mail record)))
+ (setq mail (or (and (integerp mail) (nth mail mails))
+ (car mails)))))
+ (unless mail (error "Record has no mail addresses"))
+ (let (name fn ln)
+ (cond ((let ((address (bbdb-decompose-bbdb-address mail)))
+ ;; We need to know whether we should quote the name part of MAIL
+ ;; because of special characters.
+ (if (car address)
+ (setq mail (cadr address)
+ name (car address)
+ ln name))))
+ ((functionp bbdb-mail-name)
+ (setq name (funcall bbdb-mail-name record))
+ (if (consp name)
+ (setq fn (car name) ln (cdr name)
+ name (if (eq bbdb-mail-name-format 'first-last)
+ (bbdb-concat 'name-first-last fn ln)
+ (bbdb-concat 'name-last-first ln fn)))
+ (let ((pair (bbdb-divide-name name)))
+ (setq fn (car pair) ln (cdr pair)))))
+ ((setq name (bbdb-record-xfield record bbdb-mail-name))
+ (let ((pair (bbdb-divide-name name)))
+ (setq fn (car pair) ln (cdr pair))))
+ (t
+ (setq name (if (eq bbdb-mail-name-format 'first-last)
+ (bbdb-record-name record)
+ (bbdb-record-name-lf record))
+ fn (bbdb-record-firstname record)
+ ln (bbdb-record-lastname record))))
+ (if (or (not name) (equal "" name)
+ (eq 'mail-only bbdb-mail-avoid-redundancy)
+ (and bbdb-mail-avoid-redundancy
+ (cond ((and fn ln)
+ (let ((fnq (regexp-quote fn))
+ (lnq (regexp-quote ln)))
+ (or (string-match (concat "address@hidden" fnq
+ "address@hidden" lnq "\\b")
+ mail)
+ (string-match (concat "address@hidden" lnq
+ "address@hidden" fnq "\\b")
+ mail))))
+ ((or fn ln)
+ (string-match (concat "address@hidden"
+ (regexp-quote (or fn ln)) "\\b")
+ mail)))))
+ mail
+ ;; If the name contains backslashes or double-quotes, backslash them.
+ (setq name (replace-regexp-in-string "[\\\"]" "\\\\\\&" name))
+ ;; If the name contains control chars or RFC822 specials, it needs
+ ;; to be enclosed in quotes. This quotes a few extra characters as
+ ;; well (!,%, and $) just for common sense.
+ ;; `define-mail-alias' uses regexp "[^- !#$%&'*+/0-9=?A-Za-z^_`{|}~]".
+ (format (if (string-match "[][[:cntrl:]\177()<>@,;:.!$%[:nonascii:]]"
name)
+ "\"%s\" <%s>"
+ "%s <%s>")
+ name mail))))
+
+(defun bbdb-compose-mail (&rest args)
+ "Start composing a mail message to send.
+Use `bbdb-mail-user-agent' or (if nil) use `mail-user-agent'.
+ARGS are passed to `compose-mail'."
+ (let ((mail-user-agent (or bbdb-mail-user-agent mail-user-agent)))
+ (apply 'compose-mail args)))
+
+;;;###autoload
+(defun bbdb-mail (records &optional subject n verbose)
+ "Compose a mail message to RECORDS (optional: using SUBJECT).
+Interactively, use BBDB prefix \
+\\<bbdb-mode-map>\\[bbdb-do-all-records], see `bbdb-do-all-records'.
+By default, the first mail addresses of RECORDS are used.
+If prefix N is a number, use Nth mail address of RECORDS (starting from 1).
+If prefix N is C-u (t noninteractively) use all mail addresses of RECORDS.
+If VERBOSE is non-nil (as in interactive calls) be verbose."
+ (interactive (list (bbdb-do-records) nil
+ (or (consp current-prefix-arg)
+ current-prefix-arg)
+ t))
+ (setq records (bbdb-record-list records))
+ (if (not records)
+ (if verbose (message "No records"))
+ (let ((to (bbdb-mail-address records n nil verbose)))
+ (unless (string= "" to)
+ (bbdb-compose-mail to subject)))))
+
+(defun bbdb-mail-address (records &optional n kill-ring-save verbose)
+ "Return mail addresses of RECORDS as a string.
+Interactively, use BBDB prefix \
+\\<bbdb-mode-map>\\[bbdb-do-all-records], see `bbdb-do-all-records'.
+By default, the first mail addresses of RECORDS are used.
+If prefix N is a number, use Nth mail address of RECORDS (starting from 1).
+If prefix N is C-u (t noninteractively) use all mail addresses of RECORDS.
+If KILL-RING-SAVE is non-nil (as in interactive calls), copy mail addresses
+to kill ring. If VERBOSE is non-nil (as in interactive calls) be verbose."
+ (interactive (list (bbdb-do-records)
+ (or (consp current-prefix-arg)
+ current-prefix-arg)
+ t t))
+ (setq records (bbdb-record-list records))
+ (if (not records)
+ (progn (if verbose (message "No records")) "")
+ (let ((good "") bad)
+ (dolist (record records)
+ (let ((mails (bbdb-record-mail record)))
+ (cond ((not mails)
+ (push record bad))
+ ((eq n t)
+ (setq good (bbdb-concat ",\n\t"
+ good
+ (mapcar (lambda (mail)
+ (bbdb-dwim-mail record
mail))
+ mails))))
+ (t
+ (setq good (bbdb-concat ",\n\t" good
+ (bbdb-dwim-mail record (or (and (numberp n)
+ (nth (1- n) mails))
+ (car mails)))))))))
+ (when (and bad verbose)
+ (message "No mail addresses for %s."
+ (mapconcat 'bbdb-record-name (nreverse bad) ", "))
+ (unless (string= "" good) (sit-for 2)))
+ (when (and kill-ring-save (not (string= good "")))
+ (kill-new good)
+ (if verbose (message "%s" good)))
+ good)))
+
+;; Is there better way to yank selected mail addresses from the BBDB
+;; buffer into a message buffer? We need some kind of a link between
+;; the BBDB buffer and the message buffer, where the mail addresses
+;; are supposed to go. Then we could browse the BBDB buffer and copy
+;; selected mail addresses from the BBDB buffer into a message buffer.
+
+(defun bbdb-mail-yank ()
+ "CC the people displayed in the *BBDB* buffer on this mail message.
+The primary mail of each of the records currently listed in the
+*BBDB* buffer will be appended to the CC: field of the current buffer."
+ (interactive)
+ (let ((addresses (with-current-buffer bbdb-buffer-name
+ (delq nil
+ (mapcar (lambda (x)
+ (if (bbdb-record-mail (car x))
+ (bbdb-dwim-mail (car x))))
+ bbdb-records))))
+ (case-fold-search t))
+ (goto-char (point-min))
+ (if (re-search-forward "^CC:[ \t]*" nil t)
+ ;; We have a CC field. Move to the end of it, inserting a comma
+ ;; if there are already addresses present.
+ (unless (eolp)
+ (end-of-line)
+ (while (looking-at "\n[ \t]")
+ (forward-char) (end-of-line))
+ (insert ",\n")
+ (indent-relative))
+ ;; Otherwise, if there is an empty To: field, move to the end of it.
+ (unless (and (re-search-forward "^To:[ \t]*" nil t)
+ (eolp))
+ ;; Otherwise, insert an empty CC: field.
+ (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 addresses
+ (insert (car addresses))
+ (when (cdr addresses) (insert ",\n") (indent-relative))
+ (setq addresses (cdr addresses)))))
+(define-obsolete-function-alias 'bbdb-yank-addresses 'bbdb-mail-yank "3.0")
+
+;;; completion
+
+;;;###autoload
+(defun bbdb-completion-predicate (key records)
+ "For use as the third argument to `completing-read'.
+Obey `bbdb-completion-list'."
+ (cond ((null bbdb-completion-list)
+ nil)
+ ((eq t bbdb-completion-list)
+ t)
+ (t
+ (catch 'bbdb-hash-ok
+ (dolist (record records)
+ (bbdb-hash-p key record bbdb-completion-list))
+ nil))))
+
+(defun bbdb-completing-read-records (prompt &optional omit-records)
+ "Read and return list of records from the bbdb.
+Completion is done according to `bbdb-completion-list'. If the user
+just hits return, nil is returned. Otherwise, a valid response is forced."
+ (let* ((completion-ignore-case t)
+ (string (completing-read prompt bbdb-hashtable
+ 'bbdb-completion-predicate t)))
+ (unless (string= "" string)
+ (let (records)
+ (dolist (record (gethash string bbdb-hashtable))
+ (if (not (memq record omit-records))
+ (push record records)))
+ (delete-dups records)))))
+
+(defun bbdb-completing-read-record (prompt &optional omit-records)
+ "Prompt for and return a single record from the bbdb;
+completion is done according to `bbdb-completion-list'. 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-completing-read-records prompt omit-records)))
+ (cond ((eq (length records) 1)
+ (car records))
+ ((> (length records) 1)
+ (bbdb-display-records records 'one-line)
+ (let* ((count (length records))
+ (result (completing-read
+ (format "Which record (1-%s): " count)
+ (mapcar 'number-to-string (number-sequence 1 count))
+ nil t)))
+ (nth (1- (string-to-number result)) records))))))
+
+;;;###autoload
+(defun bbdb-completing-read-mails (prompt &optional init)
+ "Like `read-string', but allows `bbdb-complete-mail' style completion."
+ (read-from-minibuffer prompt init
+ bbdb-completing-read-mails-map))
+
+(defconst bbdb-quoted-string-syntax-table
+ (let ((st (make-syntax-table)))
+ (modify-syntax-entry ?\\ "\\" st)
+ (modify-syntax-entry ?\" "\"" st)
+ st)
+ "Syntax-table to parse matched quotes. Used by `bbdb-complete-mail'.")
+
+;;;###autoload
+(defun bbdb-complete-mail (&optional beg cycle-completion-buffer)
+ "In a mail buffer, complete the user name or mail before point.
+Completion happens up to the preceeding colon, comma, or BEG.
+Return non-nil if there is a valid completion, else return nil.
+
+Completion behaviour obeys `bbdb-completion-list' (see there).
+If what has been typed matches a unique BBDB record, insert an address
+formatted by `bbdb-dwim-mail' (see there). Also, display this record
+if `bbdb-completion-display-record' is non-nil,
+If what has been typed is a valid completion but does not match
+a unique record, display a list of completions.
+If the completion is done and `bbdb-complete-mail-allow-cycling' is t
+then cycle through the mails for the matching record. If BBDB
+would format a given address different from what we have in the mail buffer,
+the first round of cycling reformats the address accordingly, then we cycle
+through the mails for the matching record.
+With prefix CYCLE-COMPLETION-BUFFER non-nil, display a list of all mails
+available for cycling.
+
+Set the variable `bbdb-complete-mail' non-nil for enabling this feature
+as part of the MUA insinuation."
+ (interactive (list nil current-prefix-arg))
+
+ (bbdb-buffer) ; Make sure the database is initialized.
+
+ ;; Completion should begin after the preceding comma (separating
+ ;; two addresses) or colon (separating the header field name
+ ;; from the header field body). We want to ignore these characters
+ ;; if they appear inside a quoted string (RFC 5322, Sec. 3.2.4).
+ ;; Note also that a quoted string may span multiple lines
+ ;; (RFC 5322, Sec. 2.2.3).
+ ;; So to be save, we go back to the beginning of the header field body
+ ;; (past the colon, when we are certainly not inside a quoted string),
+ ;; then we parse forward, looking for commas not inside a quoted string
+ ;; and positioned before END. - This fails with an unbalanced quote.
+ ;; But an unbalanced quote is bound to fail anyway.
+ (when (and (not beg)
+ (<= (point)
+ (save-restriction ; `mail-header-end'
+ (widen)
+ (save-excursion
+ (rfc822-goto-eoh)
+ (point)))))
+ (let ((end (point))
+ start pnt state)
+ (save-excursion
+ ;; A header field name must appear at the beginning of a line,
+ ;; and it must be terminated by a colon.
+ (re-search-backward "^[^ \t\n:][^:]*:[ \t\n]+")
+ (setq beg (match-end 0)
+ start beg)
+ (goto-char beg)
+ ;; If we are inside a syntactically correct header field,
+ ;; all continuation lines in between the field name and point
+ ;; must begin with a white space character.
+ (if (re-search-forward "\n[^ \t]" end t)
+ ;; An invalid header is identified via BEG set to nil.
+ (setq beg nil)
+ ;; Parse field body up to END
+ (with-syntax-table bbdb-quoted-string-syntax-table
+ (while (setq pnt (re-search-forward ",[ \t\n]*" end t))
+ (setq state (parse-partial-sexp start pnt nil nil state)
+ start pnt)
+ (unless (nth 3 state) (setq beg pnt))))))))
+
+ ;; Do we have a meaningful way to set BEG if we are not in a message header?
+ (unless beg
+ (message "Not a valid buffer position for mail completion")
+ (sit-for 1))
+
+ (let* ((end (point))
+ (done (unless beg 'nothing))
+ (orig (and beg (buffer-substring beg end)))
+ (completion-ignore-case t)
+ (completion (and orig
+ (try-completion orig bbdb-hashtable
+ 'bbdb-completion-predicate)))
+ all-completions dwim-completions one-record)
+
+ (unless done
+ ;; We get fooled if a partial COMPLETION matches "," (for example,
+ ;; a comma in lf-name). Such a partial COMPLETION cannot be protected
+ ;; by quoting. Then the comma gets interpreted as BEG.
+ ;; So we never perform partial completion beyond the first comma.
+ ;; This works even if we have just one record matching ORIG (thus
+ ;; allowing dwim-completion) because ORIG is a substring of COMPLETION
+ ;; even after COMPLETION got truncated; and ORIG by itself must be
+ ;; sufficient to identify this record.
+ ;; Yet if multiple records match ORIG we can only offer a *Completions*
+ ;; buffer.
+ (if (and (stringp completion)
+ (string-match "," completion))
+ (setq completion (substring completion 0 (match-beginning 0))))
+
+ (setq all-completions (all-completions orig bbdb-hashtable
+ 'bbdb-completion-predicate))
+ ;; Resolve the records matching ORIG:
+ ;; Multiple completions may match the same record
+ (let ((records (delete-dups
+ (apply 'append (mapcar (lambda (compl)
+ (gethash compl bbdb-hashtable))
+ all-completions)))))
+ ;; Is there only one matching record?
+ (setq one-record (and (not (cdr records))
+ (car records))))
+
+ ;; Clean up *Completions* buffer window, if it exists
+ (let ((window (get-buffer-window "*Completions*")))
+ (if (window-live-p window)
+ (quit-window nil window)))
+
+ (cond
+ ;; Match for a single record
+ (one-record
+ (let ((completion-list (if (eq t bbdb-completion-list)
+ '(fl-name lf-name mail aka organization)
+ bbdb-completion-list))
+ (mails (bbdb-record-mail one-record))
+ mail elt)
+ (if (not mails)
+ (progn
+ (message "Matching record has no mail field")
+ (sit-for 1)
+ (setq done 'nothing))
+
+ ;; Determine the mail address of ONE-RECORD to use for ADDRESS.
+ ;; Do we have a preferential order for the following tests?
+ ;; (1) If ORIG matches name, AKA, or organization of ONE-RECORD,
+ ;; then ADDRESS will be the first mail address of ONE-RECORD.
+ (if (try-completion orig
+ (append
+ (if (memq 'fl-name completion-list)
+ (list (or (bbdb-record-name one-record)
"")))
+ (if (memq 'lf-name completion-list)
+ (list (or (bbdb-record-name-lf
one-record) "")))
+ (if (memq 'aka completion-list)
+ (bbdb-record-field one-record 'aka-all))
+ (if (memq 'organization completion-list)
+ (bbdb-record-organization one-record))))
+ (setq mail (car mails)))
+ ;; (2) If ORIG matches one or multiple mail addresses of
ONE-RECORD,
+ ;; then we take the first one matching ORIG.
+ ;; We got here with MAIL nil only if `bbdb-completion-list'
+ ;; includes 'mail or 'primary.
+ (unless mail
+ (while (setq elt (pop mails))
+ (if (try-completion orig (list elt))
+ (setq mail elt
+ mails nil))))
+ ;; This error message indicates a bug!
+ (unless mail (error "No match for %s" orig))
+
+ (let ((dwim-mail (bbdb-dwim-mail one-record mail)))
+ (if (string= dwim-mail orig)
+ ;; We get here if `bbdb-mail-avoid-redundancy' is 'mail-only
+ ;; and `bbdb-completion-list' includes 'mail.
+ (unless (and bbdb-complete-mail-allow-cycling
+ (< 1 (length (bbdb-record-mail one-record))))
+ (setq done 'unchanged))
+ ;; Replace the text with the expansion
+ (delete-region beg end)
+ (insert dwim-mail)
+ (bbdb-complete-mail-cleanup dwim-mail beg)
+ (setq done 'unique))))))
+
+ ;; Partial completion
+ ((and (stringp completion)
+ (not (bbdb-string= orig completion)))
+ (delete-region beg end)
+ (insert completion)
+ (setq done 'partial))
+
+ ;; Partial match not allowing further partial completion
+ (completion
+ (let ((completion-list (if (eq t bbdb-completion-list)
+ '(fl-name lf-name mail aka organization)
+ bbdb-completion-list)))
+ ;; Now collect all the dwim-addresses for each completion.
+ ;; Add it if the mail is part of the completions
+ (dolist (key all-completions)
+ (dolist (record (gethash key bbdb-hashtable))
+ (let ((mails (bbdb-record-mail record))
+ accept)
+ (when mails
+ (dolist (field completion-list)
+ (cond ((eq field 'fl-name)
+ (if (bbdb-string= key (bbdb-record-name record))
+ (push (car mails) accept)))
+ ((eq field 'lf-name)
+ (if (bbdb-string= key (bbdb-cache-lf-name
+ (bbdb-record-cache record)))
+ (push (car mails) accept)))
+ ((eq field 'aka)
+ (if (member-ignore-case key (bbdb-record-field
+ record 'aka-all))
+ (push (car mails) accept)))
+ ((eq field 'organization)
+ (if (member-ignore-case key
(bbdb-record-organization
+ record))
+ (push (car mails) accept)))
+ ((eq field 'primary)
+ (if (bbdb-string= key (car mails))
+ (push (car mails) accept)))
+ ((eq field 'mail)
+ (dolist (mail mails)
+ (if (bbdb-string= key mail)
+ (push mail accept))))))
+ (dolist (mail (delete-dups accept))
+ (push (bbdb-dwim-mail record mail) dwim-completions))))))
+
+ (setq dwim-completions (sort (delete-dups dwim-completions)
+ 'string-lessp))
+ (cond ((not dwim-completions)
+ (message "Matching record has no mail field")
+ (sit-for 1)
+ (setq done 'nothing))
+ ;; DWIM-COMPLETIONS may contain only one element,
+ ;; if multiple completions match the same record.
+ ;; Then we may proceed with DONE set to `unique'.
+ ((eq 1 (length dwim-completions))
+ (delete-region beg end)
+ (insert (car dwim-completions))
+ (bbdb-complete-mail-cleanup (car dwim-completions) beg)
+ (setq done 'unique))
+ (t (setq done 'choose)))))))
+
+ ;; By now, we have considered all possiblities to perform a completion.
+ ;; If nonetheless we haven't done anything so far, consider cycling.
+ ;;
+ ;; Completion and cycling are really two very separate things.
+ ;; Completion is controlled by the user variable `bbdb-completion-list'.
+ ;; Cycling assumes that ORIG already holds a valid RFC 822 mail address.
+ ;; Therefore cycling may consider different records than completion.
+ (when (and (not done) bbdb-complete-mail-allow-cycling)
+ ;; find the record we are working on.
+ (let* ((address (bbdb-extract-address-components orig))
+ (record (car (bbdb-message-search
+ (car address) (cadr address)))))
+ (if (and record
+ (setq dwim-completions
+ (mapcar (lambda (m) (bbdb-dwim-mail record m))
+ (bbdb-record-mail record))))
+ (cond ((and (= 1 (length dwim-completions))
+ (string= orig (car dwim-completions)))
+ (setq done 'unchanged))
+ (cycle-completion-buffer ; use completion buffer
+ (setq done 'cycle-choose))
+ ;; Reformatting / Clean up:
+ ;; If the canonical mail address (nth 1 address)
+ ;; matches the Nth canonical mail address of RECORD,
+ ;; but ORIG is not `equal' to (bbdb-dwim-mail record n),
+ ;; then we replace ORIG by (bbdb-dwim-mail record n).
+ ;; For example, the address "JOHN SMITH <address@hidden>"
+ ;; gets reformatted as "John Smith <address@hidden>".
+ ;; We attempt this reformatting before the yet more
+ ;; aggressive proper cycling.
+ ((let* ((cmails (bbdb-record-mail-canon record))
+ (len (length cmails))
+ mail dwim-mail)
+ (while (and (not done)
+ (setq mail (pop cmails)))
+ (when (and (bbdb-string= mail (nth 1 address)) ; ignore
case
+ (not (string= orig (setq dwim-mail
+ (nth (- len 1
(length cmails))
+
dwim-completions)))))
+ (delete-region beg end)
+ (insert dwim-mail)
+ (bbdb-complete-mail-cleanup dwim-mail beg)
+ (setq done 'reformat)))
+ done))
+
+ (t
+ ;; ORIG is `equal' to an element of DWIM-COMPLETIONS
+ ;; Use the next element of DWIM-COMPLETIONS.
+ (let ((dwim-mail (or (nth 1 (member orig dwim-completions))
+ (nth 0 dwim-completions))))
+ ;; replace with new mail address
+ (delete-region beg end)
+ (insert dwim-mail)
+ (bbdb-complete-mail-cleanup dwim-mail beg)
+ (setq done 'cycle)))))))
+
+ (when (member done '(choose cycle-choose))
+ ;; Pop up a completions window using DWIM-COMPLETIONS.
+ ;; `completion-in-region' does not work here as DWIM-COMPLETIONS
+ ;; is not a collection for completion in the usual sense, but it
+ ;; is really a list of replacements.
+ (let ((status (not (eq (selected-window) (minibuffer-window))))
+ (completion-base-position (list beg end))
+ ;; We first call the default value of
+ ;; `completion-list-insert-choice-function'
+ ;; before performing our own stuff.
+ (completion-list-insert-choice-function
+ `(lambda (beg end text)
+ ,(if (boundp 'completion-list-insert-choice-function)
+ `(funcall ',completion-list-insert-choice-function
+ beg end text))
+ (bbdb-complete-mail-cleanup text beg))))
+ (if status (message "Making completion list..."))
+ (with-output-to-temp-buffer "*Completions*"
+ (display-completion-list dwim-completions))
+ (if status (message "Making completion list...done"))))
+
+ ;; If DONE is `nothing' return nil so that possibly some other code
+ ;; can take over.
+ (unless (eq done 'nothing)
+ done)))
+
+;;;###autoload
+(define-obsolete-function-alias 'bbdb-complete-name 'bbdb-complete-mail "3.0")
+
+(defun bbdb-complete-mail-cleanup (mail beg)
+ "Clean up after inserting MAIL at position BEG.
+If we are past `fill-column', wrap at the previous comma."
+ (if (and (not (auto-fill-function))
+ (>= (current-column) fill-column))
+ (save-excursion
+ (goto-char beg)
+ (when (search-backward "," (line-beginning-position) t)
+ (forward-char 1)
+ (insert "\n")
+ (indent-relative)
+ (if (looking-at "[ \t\n]+")
+ (delete-region (point) (match-end 0))))))
+ (if (or bbdb-completion-display-record bbdb-complete-mail-hook)
+ (let* ((address (bbdb-extract-address-components mail))
+ (records (bbdb-message-search (car address) (nth 1 address))))
+ ;; Update the *BBDB* buffer if desired.
+ (if bbdb-completion-display-record
+ (let ((bbdb-silent-internal t))
+ ;; FIXME: This pops up *BBDB* before removing *Completions*
+ (bbdb-display-records records nil t)))
+ ;; `bbdb-complete-mail-hook' may access MAIL, ADDRESS, and RECORDS.
+ (run-hooks 'bbdb-complete-mail-hook))))
+
+;;; interface to mail-abbrevs.el.
+
+;;;###autoload
+(defun bbdb-mail-aliases (&optional force-rebuilt noisy)
+ "Define mail aliases for the records in the database.
+Define a mail alias for every record that has a `mail-alias' field
+which is the contents of that field.
+If there are multiple comma-separated words in the `mail-alias' field,
+then all of those words will be defined as aliases for that person.
+
+If multiple records in the database have the same mail alias,
+then that alias expands to a comma-separated list of the mail addresses
+of all of these people.
+Add this command to `mail-setup-hook'.
+
+Mail aliases are (re)built only if `bbdb-mail-aliases-need-rebuilt' is non-nil
+because the database was newly loaded or it has been edited.
+Rebuilding the aliases is enforced if prefix FORCE-REBUILT is t."
+ (interactive (list current-prefix-arg t))
+ ;; Build `mail-aliases' if not yet done.
+ ;; Note: `mail-abbrevs-setup' rebuilds the mail-aliases only if
+ ;; `mail-personal-alias-file' has changed. So it would not do anything
+ ;; if we want to rebuild the mail-aliases because of changes in BBDB.
+ (if (or force-rebuilt (eq t mail-aliases)) (build-mail-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
+ ;; Calling `bbdb-records' can change `bbdb-mail-aliases-need-rebuilt'
+ (let ((records (bbdb-search (bbdb-records) :xfield (cons
bbdb-mail-alias-field ".")))
+ results match)
+ (if (not (or force-rebuilt bbdb-mail-aliases-need-rebuilt))
+ (if noisy (message "BBDB mail alias: nothing to do"))
+ (setq bbdb-mail-aliases-need-rebuilt nil)
+
+ ;; collect an alist of (alias rec1 [rec2 ...])
+ (dolist (record records)
+ (if (bbdb-record-mail record)
+ (dolist (alias (bbdb-record-xfield-split record
bbdb-mail-alias-field))
+ (if (setq match (assoc alias results))
+ ;; If an alias appears more than once, we collect all records
+ ;; that refer to it.
+ (nconc match (list record))
+ (push (list alias record) results)))
+ (unless bbdb-silent
+ (bbdb-warn "record %S has no mail address, but the aliases: %s"
+ (bbdb-record-name record)
+ (bbdb-record-xfield record bbdb-mail-alias-field))
+ (sit-for 1))))
+
+ ;; Iterate over the results and create the aliases
+ (dolist (result results)
+ (let* ((aliasstem (car result))
+ (expansions
+ (if (cddr result)
+ ;; for group aliases we just take all the primary mails
+ ;; and define only one expansion!
+ (list (mapconcat (lambda (record) (bbdb-dwim-mail record))
+ (cdr result) mail-alias-separator-string))
+ ;; this is an alias for a single person so deal with it
+ ;; according to `bbdb-mail-alias'
+ (let* ((record (nth 1 result))
+ (mails (bbdb-record-mail record)))
+ (if (or (eq 'first bbdb-mail-alias)
+ (not (cdr mails)))
+ ;; Either we want to define only one alias for
+ ;; the first mail address or there is anyway
+ ;; only one address. In either case, we take
+ ;; take only the first address.
+ (list (bbdb-dwim-mail record (car mails)))
+ ;; We need to deal with more than one mail address...
+ (let* ((all (mapcar (lambda (m) (bbdb-dwim-mail record
m))
+ mails))
+ (star (bbdb-concat mail-alias-separator-string
all)))
+ (if (eq 'star bbdb-mail-alias)
+ (list star (car all))
+ ;; if `bbdb-mail-alias' is 'all, we create
+ ;; two aliases for the primary mail address
+ (cons star (cons (car all) all))))))))
+ (count -1) ; n=-1: <alias>*; n=0: <alias>; n>0: <alias>n
+ (len (length expansions))
+ alias f-alias)
+
+ ;; create the aliases for each expansion
+ (dolist (expansion expansions)
+ (cond ((or (= 1 len)
+ (= count 0))
+ (setq alias aliasstem))
+ ((= count -1) ;; all the mails of a record
+ (setq alias (concat aliasstem "*")))
+ (t ;; <alias>n for each mail of a record
+ (setq alias (format "%s%s" aliasstem count))))
+ (setq count (1+ count))
+
+ (bbdb-pushnew (cons alias expansion) mail-aliases)
+
+ (define-mail-abbrev alias expansion)
+ (unless (setq f-alias (intern-soft (downcase alias) mail-abbrevs))
+ (error "Cannot find the alias"))
+
+ ;; `define-mail-abbrev' initializes f-alias to be
+ ;; `mail-abbrev-expand-hook'. We replace this by
+ ;; `bbdb-mail-abbrev-expand-hook'
+ (unless (eq (symbol-function f-alias) 'mail-abbrev-expand-hook)
+ (error "mail-aliases contains unexpected hook %s"
+ (symbol-function f-alias)))
+ ;; `bbdb-mail-abbrev-hook' is called with mail addresses instead of
+ ;; bbdb records to avoid keeping pointers to records, which would
+ ;; lose if the database was reverted.
+ ;; `bbdb-mail-abbrev-hook' uses `bbdb-message-search' to convert
+ ;; these mail addresses to records, which is plenty fast.
+ ;; FIXME: The value of arg MAILS for `bbdb-mail-abbrev-hook'
+ ;; is wrong. Currently it is based on the list of records that have
+ ;; referenced ALIASTEM and we simply take the first mail address
+ ;; from each of these records.
+ ;; Then `bbdb-message-search' will find the correct records
+ ;; (assuming that each mail address appears only once in the
+ ;; database). Nonethless, arg MAILS for `bbdb-mail-abbrev-hook'
+ ;; does not, in general, contain the actual mail addresses
+ ;; of EXPANSION. So what we would need is to go back from
+ ;; EXPANSION to the mail addresses it contains (which is tricky
+ ;; because mail addresses in the database can be shortcuts for
+ ;; the addresses in EXPANSION).
+ (fset f-alias `(lambda ()
+ (bbdb-mail-abbrev-expand-hook
+ ,alias
+ ',(mapcar (lambda (r) (car (bbdb-record-mail r)))
+ (cdr result))))))))
+
+ (if noisy (message "BBDB mail alias: rebuilding done")))))
+
+(defun bbdb-mail-abbrev-expand-hook (alias mails)
+ (run-hook-with-args 'bbdb-mail-abbrev-expand-hook alias mails)
+ (mail-abbrev-expand-hook)
+ (when bbdb-completion-display-record
+ (let ((bbdb-silent-internal t))
+ (bbdb-display-records
+ (apply 'append
+ (mapcar (lambda (mail) (bbdb-message-search nil mail)) mails))
+ nil t))))
+
+(defun bbdb-get-mail-aliases ()
+ "Return a list of mail aliases used in the BBDB."
+ (let ((records (bbdb-search (bbdb-records) :xfield (cons
bbdb-mail-alias-field ".")))
+ result)
+ (dolist (record records)
+ (dolist (alias (bbdb-record-xfield-split record bbdb-mail-alias-field))
+ (bbdb-pushnew alias result)))
+ result))
+
+;;;###autoload
+(defsubst bbdb-mail-alias-list (alias)
+ (if (stringp alias)
+ (bbdb-split bbdb-mail-alias-field alias)
+ alias))
+
+(defun bbdb-add-mail-alias (records &optional alias delete)
+ "Add ALIAS to RECORDS.
+If prefix DELETE is non-nil, remove ALIAS from RECORDS.
+Interactively, use BBDB prefix \
+\\<bbdb-mode-map>\\[bbdb-do-all-records], see `bbdb-do-all-records'.
+Arg ALIAS is ignored if list RECORDS contains more than one record.
+Instead read ALIAS interactively for each record in RECORDS.
+If the function `bbdb-init-mail-alias' is defined, it is called with
+one arg RECORD to define the default value for ALIAS of RECORD."
+ (interactive (list (bbdb-do-records) nil current-prefix-arg))
+ (bbdb-editable)
+ (setq records (bbdb-record-list records))
+ (if (< 1 (length records)) (setq alias nil))
+ (let* ((tmp (intern-soft
+ (concat "bbdb-init-" (symbol-name bbdb-mail-alias-field))))
+ (init-f (if (functionp tmp) tmp)))
+ (dolist (record records)
+ (let ((r-a-list (bbdb-record-xfield-split record bbdb-mail-alias-field))
+ (alias alias)
+ a-list)
+ (if alias
+ (setq a-list (bbdb-mail-alias-list alias))
+ (when init-f
+ (setq a-list (bbdb-mail-alias-list (funcall init-f record))
+ alias (if a-list (bbdb-concat bbdb-mail-alias-field
a-list))))
+ (let ((crm-separator
+ (concat "[ \t\n]*"
+ (cadr (assq bbdb-mail-alias-field
bbdb-separator-alist))
+ "[ \t\n]*"))
+ (crm-local-completion-map bbdb-crm-local-completion-map)
+ (prompt (format "%s mail alias:%s " (if delete "Remove" "Add")
+ (if alias (format " (default %s)" alias) "")))
+ (collection (if delete
+ (or r-a-list (error "Record has no alias"))
+ (bbdb-get-mail-aliases))))
+ (setq a-list (if (string< "24.3" (substring emacs-version 0 4))
+ (completing-read-multiple prompt collection nil
+ delete nil nil alias)
+ (bbdb-split bbdb-mail-alias-field
+ (completing-read prompt collection nil
+ delete nil nil
alias))))))
+ (dolist (a a-list)
+ (if delete
+ (setq r-a-list (delete a r-a-list))
+ ;; Add alias only if it is not there yet
+ (bbdb-pushnew a r-a-list)))
+ ;; This also handles `bbdb-mail-aliases-need-rebuilt'
+ (bbdb-record-set-xfield record bbdb-mail-alias-field
+ (bbdb-concat bbdb-mail-alias-field r-a-list))
+ (bbdb-change-record record)))))
+
+;;; Dialing numbers from BBDB
+
+(defun bbdb-dial-number (phone-string)
+ "Dial the number specified by PHONE-STRING.
+This uses the tel URI syntax passed to `browse-url' to make the call.
+If `bbdb-dial-function' is non-nil then that is called to make the phone call."
+ (interactive "sDial number: ")
+ (if bbdb-dial-function
+ (funcall bbdb-dial-function phone-string)
+ (browse-url (concat "tel:" phone-string))))
+
+;;;###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.
+Use rules from `bbdb-dial-local-prefix-alist' unless prefix FORCE-AREA-CODE
+is non-nil. Do not dial the extension."
+ (interactive (list (bbdb-current-field) current-prefix-arg))
+ (if (eq (car-safe phone) 'name)
+ (setq phone (car (bbdb-record-phone (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)
+
+ ;; cut off the extension
+ (if (string-match "x[0-9]+$" number)
+ (setq number (substring number 0 (match-beginning 0))))
+
+ (unless force-area-code
+ (let ((alist bbdb-dial-local-prefix-alist) prefix)
+ (while (setq prefix (pop alist))
+ (if (string-match (concat "^" (eval (car prefix))) number)
+ (setq shortnumber (concat (cdr prefix)
+ (substring number (match-end 0)))
+ alist nil)))))
+
+ (if shortnumber
+ (setq number shortnumber)
+
+ ;; This is terrifically Americanized...
+ ;; Leading 0 => local number (?)
+ (if (and bbdb-dial-local-prefix
+ (string-match "^0" number))
+ (setq number (concat bbdb-dial-local-prefix number)))
+
+ ;; Leading + => long distance/international number
+ (if (and bbdb-dial-long-distance-prefix
+ (string-match "^\+" number))
+ (setq number (concat bbdb-dial-long-distance-prefix " "
+ (substring number 1)))))
+
+ (unless bbdb-silent
+ (message "Dialing %s" number))
+ (bbdb-dial-number number)))
+
+;;; url interface
+
+;;;###autoload
+(defun bbdb-browse-url (records &optional which)
+ "Brwose URLs stored in the `url' field of RECORDS.
+Interactively, use BBDB prefix \
+\\<bbdb-mode-map>\\[bbdb-do-all-records], see `bbdb-do-all-records'.
+Prefix WHICH specifies which URL in field `url' is used (starting from 0).
+Default is the first URL."
+ (interactive (list (bbdb-get-records "Visit (URL): ")
+ (and current-prefix-arg
+ (prefix-numeric-value current-prefix-arg))))
+ (unless which (setq which 0))
+ (dolist (record (bbdb-record-list records))
+ (let ((url (bbdb-record-xfield-split record 'url)))
+ (when url
+ (setq url (read-string "fetch: " (nth which url)))
+ (unless (string= "" url)
+ (browse-url url))))))
+
+;;;###autoload
+(defun bbdb-grab-url (record url)
+ "Grab URL and store it in RECORD."
+ (interactive (let ((url (browse-url-url-at-point)))
+ (unless url (error "No URL at point"))
+ (list (bbdb-completing-read-record
+ (format "Add `%s' for: " url))
+ url)))
+ (bbdb-record-set-field record 'url url t)
+ (bbdb-change-record record)
+ (bbdb-display-records (list record)))
+
+;;; Copy to kill ring
+
+;;;###autoload
+(defun bbdb-copy-records-as-kill (records)
+ "Copy RECORDS to kill ring.
+Interactively, use BBDB prefix \
+\\<bbdb-mode-map>\\[bbdb-do-all-records], see `bbdb-do-all-records'."
+ (interactive (list (bbdb-do-records t)))
+ (let (drec)
+ (dolist (record (bbdb-record-list records t))
+ (push (buffer-substring (nth 2 record)
+ (or (nth 2 (car (cdr (memq record
bbdb-records))))
+ (point-max)))
+ drec))
+ (kill-new (replace-regexp-in-string
+ "[ \t\n]*\\'" "\n"
+ (mapconcat 'identity (nreverse drec) "")))))
+
+;;;###autoload
+(defun bbdb-copy-fields-as-kill (records field &optional num)
+ "For RECORDS copy values of FIELD at point to kill ring.
+If FIELD is an address or phone with a label, copy only field values
+with the same label. With numeric prefix NUM, if the value of FIELD
+is a list, copy only the NUMth list element.
+Interactively, use BBDB prefix \
+\\<bbdb-mode-map>\\[bbdb-do-all-records], see `bbdb-do-all-records'."
+ (interactive
+ (list (bbdb-do-records t) (bbdb-current-field)
+ (and current-prefix-arg
+ (prefix-numeric-value current-prefix-arg))))
+ (unless field (error "Not a field"))
+ (let* ((type (if (eq (car field) 'xfields)
+ (car (nth 1 field))
+ (car field)))
+ (label (if (memq type '(phone address))
+ (aref (cadr field) 0)))
+ (ident (and (< 1 (length records))
+ (not (eq type 'name))))
+ val-list)
+ (dolist (record (bbdb-record-list records))
+ (let ((raw-val (bbdb-record-field (car record) type))
+ value)
+ (if raw-val
+ (cond ((eq type 'phone)
+ (dolist (elt raw-val)
+ (if (equal label (aref elt 0))
+ (push (bbdb-phone-string elt) value)))
+ (setq value (bbdb-concat 'phone (nreverse value))))
+ ((eq type 'address)
+ (dolist (elt raw-val)
+ (if (equal label (aref elt 0))
+ (push (bbdb-format-address
+ elt (if (eq (nth 1 record) 'one-line) 3 2))
+ value)))
+ (setq value (bbdb-concat 'address (nreverse value))))
+ ((consp raw-val)
+ (setq value (if num (nth num raw-val)
+ (bbdb-concat type raw-val))))
+ (t (setq value raw-val))))
+ (if value
+ (push (if ident
+ (bbdb-concat 'name-field
+ (bbdb-record-name (car record)) value)
+ value) val-list))))
+ (let ((str (bbdb-concat 'record (nreverse val-list))))
+ (kill-new str)
+ (message "%s" str))))
+
+;;; Help and documentation
+
+;;;###autoload
+(defun bbdb-info ()
+ (interactive)
+ (info (format "(%s)Top" (or bbdb-info-file "bbdb"))))
+
+;;;###autoload
+(defun bbdb-help ()
+ (interactive)
+ (message (substitute-command-keys "\\<bbdb-mode-map>\
+new field: \\[bbdb-insert-field]; \
+edit field: \\[bbdb-edit-field]; \
+delete field: \\[bbdb-delete-field-or-record]; \
+mode help: \\[describe-mode]; \
+info: \\[bbdb-info]")))
+
+(provide 'bbdb-com)
+
+;;; bbdb-com.el ends here
diff --git a/lisp/bbdb/bbdb-ispell.el b/lisp/bbdb/bbdb-ispell.el
new file mode 100644
index 0000000..88ba022
--- /dev/null
+++ b/lisp/bbdb/bbdb-ispell.el
@@ -0,0 +1,127 @@
+;;; bbdb-ispell.el --- export names from BBDB to personal ispell dictionaries
-*- lexical-binding: t -*-
+
+;; Copyright (C) 2011-2017 Free Software Foundation, Inc.
+
+;; Author: Ivan Kanis <address@hidden>
+
+;; This file is part of the Insidious Big Brother Database (aka BBDB),
+
+;; BBDB 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 3 of the License, 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 BBDB. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; Names are often not recognized by the standard ispell dictionaries.
+;; `bbdb-ispell-export' exports the names from your BBDB records to your
+;; personal ispell dictionaries.
+;; The personal dictionaries are in `bbdb-ispell-dictionary-list'
+;; The BBDB fields for this are in `bbdb-ispell-field-list'.
+;; Exclude words via `bbdb-ispell-min-word-length' and `bbdb-ispell-ignore-re'.
+;;
+;; Bugs:
+;; Save your personal directories before running this code. I had my
+;; dictionary truncated while debugging. It shouldn't happen
+;; but better be safe than sorry...
+;;
+;; See the BBDB info manual for documentation.
+
+;;; Code:
+
+(require 'ispell)
+(require 'bbdb)
+
+(defcustom bbdb-ispell-dictionary-list '("default")
+ "List of ispell personal dictionaries.
+Allowed elements are as in the return value of `ispell-valid-dictionary-list'."
+ :group 'bbdb-utilities-ispell
+ :type (cons 'set (mapcar (lambda (dict) `(string ,dict))
+ (ispell-valid-dictionary-list))))
+
+(defcustom bbdb-ispell-field-list '(name organization aka)
+ "List of fields of each BBDB record considered for the personal dictionary."
+ :group 'bbdb-utilities-ispell
+ :type (list 'repeat
+ (append '(choice) (mapcar (lambda (field) `(const ,field))
+ '(name organization affix aka address))
+ '((symbol :tag "xfield")))))
+
+(defcustom bbdb-ispell-min-word-length 3
+ "Words with fewer characters are ignored."
+ :group 'bbdb-utilities-ispell
+ :type 'number)
+
+(defcustom bbdb-ispell-ignore-re "[^[:alpha:]]"
+ "Words matching this regexp are ignored."
+ :group 'bbdb-utilities-ispell
+ :type 'regexp)
+
+;; Internal variable
+(defvar bbdb-ispell-word-list nil
+ "List of words extracted from the BBDB records.")
+
+;;;###autoload
+(defun bbdb-ispell-export ()
+ "Export BBDB records to ispell personal dictionaries."
+ (interactive)
+ (message "Exporting to personal dictionary...")
+ (let (bbdb-ispell-word-list)
+ ;; Collect words from BBDB records.
+ (dolist (record (bbdb-records))
+ (dolist (field bbdb-ispell-field-list)
+ (bbdb-ispell-collect-words (bbdb-record-field record field))))
+
+ ;; Update personal dictionaries
+ (dolist (dict (or bbdb-ispell-dictionary-list '("default")))
+ (ispell-change-dictionary dict)
+ ;; Initialize variables and dicts alists
+ (ispell-set-spellchecker-params)
+ (ispell-init-process)
+ ;; put in verbose mode
+ (ispell-send-string "%\n")
+ (let (new)
+ (dolist (word (delete-dups bbdb-ispell-word-list))
+ (ispell-send-string (concat "^" word "\n"))
+ (while (progn
+ (ispell-accept-output)
+ (not (string= "" (car ispell-filter)))))
+ ;; remove extra \n
+ (setq ispell-filter (cdr ispell-filter))
+ (when (and ispell-filter
+ (listp ispell-filter)
+ (not (eq (ispell-parse-output (car ispell-filter)) t)))
+ ;; ok the word doesn't exist, add it
+ (ispell-send-string (concat "*" word "\n"))
+ (setq new t)))
+ (when new
+ ;; Save dictionary:
+ ;; aspell doesn't tell us when it completed the saving.
+ ;; So we send it another word for spellchecking.
+ (ispell-send-string "#\n^hello\n")
+ (while (progn
+ (ispell-accept-output)
+ (not (string= "" (car ispell-filter)))))))))
+ (message "Exporting to personal dictionary...done"))
+
+(defun bbdb-ispell-collect-words (field)
+ "Parse BBDB FIELD and collect words in `bbdb-ispell-word-list'."
+ ;; Ignore everything in FIELD that is not a string or a sequence.
+ (cond ((stringp field)
+ (dolist (word (split-string field))
+ (if (and (>= (length word) bbdb-ispell-min-word-length)
+ (not (string-match bbdb-ispell-ignore-re word)))
+ (push word bbdb-ispell-word-list))))
+ ((sequencep field) (mapc 'bbdb-ispell-collect-words field))))
+
+(provide 'bbdb-ispell)
+
+;;; bbdb-ispell.el ends here
diff --git a/lisp/bbdb/bbdb-message.el b/lisp/bbdb/bbdb-message.el
new file mode 100644
index 0000000..75885ca
--- /dev/null
+++ b/lisp/bbdb/bbdb-message.el
@@ -0,0 +1,56 @@
+;;; bbdb-message.el --- BBDB interface to Mail Composition Packages. -*-
lexical-binding: t -*-
+
+;; Copyright (C) 2010-2017 Free Software Foundation, Inc.
+
+;; This file is part of the Insidious Big Brother Database (aka BBDB),
+
+;; BBDB 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 3 of the License, 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 BBDB. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;; This file contains the BBDB interface to Mail Composition Packages.
+;;; See the BBDB info manual for documentation.
+
+;;; Code:
+
+(require 'bbdb)
+(require 'message)
+(require 'sendmail)
+
+;;;###autoload
+(defun bbdb-insinuate-message ()
+ "Hook BBDB into Message Mode.
+Do not call this in your init file. Use `bbdb-initialize'."
+ ;; Suggestions welcome: What are good keybindings for the following
+ ;; commands that do not collide with existing bindings?
+ ;; (define-key message-mode-map "'" 'bbdb-mua-display-recipients)
+ ;; (define-key message-mode-map ";" 'bbdb-mua-edit-field-recipients)
+ ;; (define-key message-mode-map "/" 'bbdb)
+ (if bbdb-complete-mail
+ (define-key message-mode-map "\M-\t" 'bbdb-complete-mail)))
+
+;;;###autoload
+(defun bbdb-insinuate-mail ()
+ "Hook BBDB into Mail Mode.
+Do not call this in your init file. Use `bbdb-initialize'."
+ ;; Suggestions welcome: What are good keybindings for the following
+ ;; commands that do not collide with existing bindings?
+ ;; (define-key mail-mode-map "'" 'bbdb-mua-display-recipients)
+ ;; (define-key mail-mode-map ";" 'bbdb-mua-edit-field-recipients)
+ ;; (define-key mail-mode-map "/" 'bbdb)
+ (if bbdb-complete-mail
+ (define-key mail-mode-map "\M-\t" 'bbdb-complete-mail)))
+
+(provide 'bbdb-message)
+
+;;; bbdb-message.el ends here
diff --git a/lisp/bbdb/bbdb-mhe.el b/lisp/bbdb/bbdb-mhe.el
new file mode 100644
index 0000000..ed9cada
--- /dev/null
+++ b/lisp/bbdb/bbdb-mhe.el
@@ -0,0 +1,99 @@
+;;; bbdb-mhe.el --- BBDB interface to mh-e -*- lexical-binding: t -*-
+
+;; Copyright (C) 2010-2017 Free Software Foundation, Inc.
+
+;; This file is part of the Insidious Big Brother Database (aka BBDB),
+
+;; BBDB 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 3 of the License, 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 BBDB. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;; This file contains the BBDB interface to mh-e.
+;;; See the BBDB info manual for documentation.
+
+;;; Code:
+
+(require 'bbdb)
+(require 'bbdb-com)
+(require 'bbdb-mua)
+(require 'mh-e)
+(if (fboundp 'mh-version)
+ (require 'mh-comp)) ; For mh-e 4.x
+(require 'advice)
+
+;; A simplified `mail-fetch-field'. We could use instead (like rmail):
+;; (mail-header (intern-soft (downcase header)) (mail-header-extract))
+(defun bbdb/mh-header (header)
+ "Find and return the value of HEADER in the current buffer.
+Returns the empty string if HEADER is not in the message."
+ (let ((case-fold-search t))
+ (goto-char (point-min))
+ ;; This will be fooled if HEADER appears in the body of the message.
+ ;; Also, it fails if HEADER appears more than once.
+ (cond ((not (re-search-forward header nil t)) "")
+ ((looking-at "[\t ]*$") "")
+ (t (re-search-forward "[ \t]*\\([^ \t\n].*\\)$" nil t)
+ (let ((start (match-beginning 1)))
+ (while (progn (forward-line 1)
+ (looking-at "[ \t]")))
+ (backward-char 1)
+ (buffer-substring-no-properties start (point)))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Use BBDB for interactive spec of MH-E commands
+
+(defadvice mh-send (before mh-bbdb-send act)
+ (interactive
+ (list (bbdb-completing-read-mails "To: ")
+ (bbdb-completing-read-mails "Cc: ")
+ (read-string "Subject: "))))
+
+(defadvice mh-send-other-window (before mh-bbdb-send-other act)
+ (interactive
+ (list (bbdb-completing-read-mails "To: ")
+ (bbdb-completing-read-mails "Cc: ")
+ (read-string "Subject: "))))
+
+(defadvice mh-forward (before mh-bbdb-forward act)
+ (interactive
+ (list (bbdb-completing-read-mails "To: ")
+ (bbdb-completing-read-mails "Cc: ")
+ (if current-prefix-arg
+ (mh-read-seq-default "Forward" t)
+ (mh-get-msg-num t)))))
+
+(defadvice mh-redistribute (before mh-bbdb-redist act)
+ (interactive
+ (list (bbdb-completing-read-mails "Redist-To: ")
+ (bbdb-completing-read-mails "Redist-Cc: ")
+ (mh-get-msg-num t))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;;###autoload
+(defun bbdb-insinuate-mh ()
+ "Call this function to hook BBDB into MH-E.
+Do not call this in your init file. Use `bbdb-initialize'."
+ (define-key mh-folder-mode-map ":" 'bbdb-mua-display-sender)
+ (define-key mh-folder-mode-map ";" 'bbdb-mua-edit-field-sender)
+ ;; Do we need keybindings for more commands? Suggestions welcome.
+ ;; (define-key mh-folder-mode-map ":" 'bbdb-mua-display-records)
+ ;; (define-key mh-folder-mode-map "'" 'bbdb-mua-display-recipients)
+ ;; (define-key mh-folder-mode-map ";" 'bbdb-mua-edit-field-recipients)
+ (when bbdb-complete-mail
+ (define-key mh-letter-mode-map "\M-;" 'bbdb-complete-mail)
+ (define-key mh-letter-mode-map "\e\t" 'bbdb-complete-mail)))
+
+(provide 'bbdb-mhe)
+
+;;; bbdb-mhe.el ends here
diff --git a/lisp/bbdb/bbdb-migrate.el b/lisp/bbdb/bbdb-migrate.el
new file mode 100644
index 0000000..7bce4da
--- /dev/null
+++ b/lisp/bbdb/bbdb-migrate.el
@@ -0,0 +1,282 @@
+;;; bbdb-migrate.el --- migration functions for BBDB -*- lexical-binding: t -*-
+
+;; Copyright (C) 2010-2017 Free Software Foundation, Inc.
+
+;; This file is part of the Insidious Big Brother Database (aka BBDB),
+
+;; BBDB 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 3 of the License, 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 BBDB. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;; This file contains the migration functions for BBDB.
+;;; See the BBDB info manual for documentation.
+
+;; Changes in `bbdb-file-format':
+;; 3 Date format for `creation-date' and `timestamp' changed
+;; from "dd mmm yy" (ex: 25 Sep 97) to "yyyy-mm-dd" (ex: 1997-09-25).
+;; 4 Country field added.
+;; 5 Streets are lists.
+;; 6 Postcodes are plain strings.
+;; 7 New field `affix'. Organizations are a list.
+;; Xfields is always a list.
+;; (8 Skipped format in "official BBDB": Some BBDB users introduced
+;; an xfield uuid in their format 8. To bring them back, we jump
+;; straight from 7 to 9.)
+;; 9 New field uuid. Make `creation-date' and `timestamp' immutable fields.
+
+
+;;; Code:
+
+(require 'bbdb)
+
+;;; Migrating the BBDB
+
+(defvar bbdb-migrate-uuid-xfield 'uuid
+ "Xfield holding a uuid in file format 8.")
+
+;;;###autoload
+(defun bbdb-migrate (records old)
+ "Migrate RECORDS from format OLD to `bbdb-file-format'."
+ ;; Some BBDB files were corrupted by random outer layers of
+ ;; parentheses surrounding the actual correct data. We attempt to
+ ;; compensate for this.
+ (while (and (consp records)
+ (listp (car records))
+ (null (cdr records)))
+ (setq records (car records)))
+
+ ;; `bbdb-migrate-lambda' uses the usual functions to access and set
+ ;; the fields of a record. So if a new record format changes
+ ;; the set of fields, we need to make these changes first.
+
+ ;; Format 7: Add new field `affix'.
+ (if (< old 7)
+ (let (new-records)
+ (dolist (record records)
+ (push (vector (elt record 0) (elt record 1) nil
+ (elt record 2) (elt record 3) (elt record 4)
+ (elt record 5) (elt record 6) (elt record 7)
+ (elt record 8))
+ new-records))
+ (setq records (nreverse new-records))))
+
+ ;; Format 9: New field `uuid'.
+ ;; Make `creation-date' and `timestamp' immutable fields.
+ (if (< old 9)
+ (let (new-records)
+ (dolist (record records)
+ (let ((uuid (or (cdr (assq bbdb-migrate-uuid-xfield (elt record 8)))
+ (bbdb-uuid)))
+ (creation-date (or (cdr (assq 'creation-date (elt record 8)))
+ (format-time-string bbdb-time-stamp-format
nil t)))
+ (timestamp (or (cdr (assq 'timestamp (elt record 8)))
+ (format-time-string bbdb-time-stamp-format nil
t))))
+ (push (vector (elt record 0) (elt record 1) (elt record 2)
+ (elt record 3) (elt record 4) (elt record 5)
+ (elt record 6) (elt record 7)
+ (let ((xfields (elt record 8)))
+ (dolist (elt '(uuid creation-date timestamp))
+ (setq xfields (assq-delete-all elt xfields)))
+ xfields)
+ uuid creation-date timestamp
+ (elt record 9))
+ new-records)))
+ (setq records (nreverse new-records))))
+
+ (mapc (bbdb-migrate-lambda old) records)
+ records)
+
+(defconst bbdb-migrate-alist
+ '((3 (bbdb-record-xfields bbdb-record-set-xfields
+ bbdb-migrate-dates))
+ (4 (bbdb-record-address bbdb-record-set-address
+ bbdb-migrate-add-country))
+ (5 (bbdb-record-address bbdb-record-set-address
+ bbdb-migrate-streets-to-list))
+ (6 (bbdb-record-address bbdb-record-set-address
+ bbdb-migrate-postcode-to-string))
+ (7 (bbdb-record-xfields bbdb-record-set-xfields
+ bbdb-migrate-xfields-to-list)
+ (bbdb-record-organization bbdb-record-set-organization
+ bbdb-migrate-organization-to-list)))
+ ;; Formats 8 and 9: do nothing
+ "Alist (VERSION . CHANGES).
+CHANGES is a list with elements (GET SET FUNCTION) that expands
+to action (SET record (FUNCTION (GET record))).")
+
+(defun bbdb-migrate-lambda (old)
+ "Return the function to migrate from OLD to `bbdb-file-format'.
+The manipulations are defined by `bbdb-migrate-alist'."
+ (let (spec)
+ (while (<= old bbdb-file-format)
+ (setq spec (append spec (cdr (assoc old bbdb-migrate-alist)))
+ old (1+ old)))
+ `(lambda (record)
+ ,@(mapcar (lambda (change)
+ ;; (SET record (FUNCTION (GET record)))
+ `(,(nth 1 change) record ; SET
+ (,(nth 2 change) ; FUNCTION
+ (,(nth 0 change) record)))) ; GET
+ spec)
+ record)))
+
+(defun bbdb-migrate-postcode-to-string (addresses)
+ "Make all postcodes plain strings.
+This uses the code that used to be in `bbdb-address-postcode'."
+ ;; apply the function to all addresses in the list and return a
+ ;; modified list of addresses
+ (mapcar (lambda (address)
+ (let ((postcode (bbdb-address-postcode address)))
+ (bbdb-address-set-postcode
+ address
+ (cond ((stringp postcode)
+ postcode)
+ ;; nil or zero
+ ((or (zerop postcode)
+ (null postcode))
+ "")
+ ;; a number
+ ((numberp postcode)
+ (format "%d" postcode))
+ ;; list with two strings
+ ((and (stringp (nth 0 postcode))
+ (stringp (nth 1 postcode)))
+ ;; the second string starts with 4 digits
+ (if (string-match "^[0-9][0-9][0-9][0-9]"
+ (nth 1 postcode))
+ (format "%s-%s" (nth 0 postcode) (nth 1 postcode))
+ ;; ("abc" "efg")
+ (format "%s %s" (nth 0 postcode) (nth 1 postcode))))
+ ;; list with two numbers
+ ((and (integerp (nth 0 postcode))
+ (integerp (nth 1 postcode)))
+ (format "%05d-%04d" (nth 0 postcode) (nth 1 postcode)))
+ ;; list with a string and a number
+ ((and (stringp (nth 0 postcode))
+ (integerp (nth 1 postcode)))
+ (format "%s-%d" (nth 0 postcode) (nth 1 postcode)))
+ ;; ("SE" (123 45))
+ ((and (stringp (nth 0 postcode))
+ (integerp (nth 0 (nth 1 postcode)))
+ (integerp (nth 1 (nth 1 postcode))))
+ (format "%s-%d %d" (nth 0 postcode) (nth 0 (nth 1
postcode))
+ (nth 1 (nth 1 postcode))))
+ ;; last possibility
+ (t (format "%s" postcode)))))
+ address)
+ addresses))
+
+(defun bbdb-migrate-dates (xfields)
+ "Change date formats.
+Formats are changed in timestamp and creation-date fields from
+\"dd mmm yy\" to \"yyyy-mm-dd\"."
+ (unless (stringp xfields)
+ (mapc (lambda (xfield)
+ (when (memq (car xfield) '(creation-date timestamp))
+ (bbdb-migrate-date xfield)))
+ xfields)
+ xfields))
+
+(defun bbdb-migrate-date (field)
+ "Convert date field FIELD from \"dd mmm yy\" to \"yyyy-mm-dd\"."
+ (let* ((date (cdr field))
+ (parsed (timezone-parse-date (concat date " 00:00:00"))))
+ ;; If `timezone-parse-date' cannot make sense of its arg DATE
+ ;; it returns ["0" "0" "0" "0" nil].
+ (if (equal parsed ["0" "0" "0" "0" nil])
+ (setq parsed (timezone-parse-date date)))
+ (when (equal parsed ["0" "0" "0" "0" nil])
+ (cond ((string-match
+ "^\\([0-9]\\{4\\}\\)[-/]\\([ 0-9]?[0-9]\\)[-/]\\([
0-9]?[0-9]\\)" date)
+ (setq parsed (vector (match-string 1 date) (match-string 2 date)
+ (match-string 3 date))))
+ ((string-match
+ "^\\([ 0-9]?[0-9]\\)[-/]\\([
0-9]?[0-9]\\)[-/]\\([0-9]\\{4\\}\\)" date)
+ (setq parsed (vector (match-string 3 date) (match-string 1 date)
+ (match-string 2 date))))))
+
+ ;; We need numbers for the following sanity check
+ (dotimes (i 3)
+ (if (stringp (aref parsed i))
+ (aset parsed i (string-to-number (aref parsed i)))))
+
+ ;; Sanity check
+ (if (and (< 0 (aref parsed 0))
+ (< 0 (aref parsed 1)) (< (aref parsed 1) 13)
+ (< 0 (aref parsed 2))
+ (<= (aref parsed 2)
+ (timezone-last-day-of-month (aref parsed 1) (aref parsed 0))))
+ (setcdr field (format "%04d-%02d-%02d" (aref parsed 0)
+ (aref parsed 1) (aref parsed 2)))
+ (error "BBDB cannot parse %s header value %S for upgrade"
+ field date))))
+
+(defun bbdb-migrate-add-country (addrl)
+ "Add a country field to each address in the address list."
+ (mapcar (lambda (address) (vconcat address [bbdb-default-country])) addrl))
+
+(defun bbdb-migrate-streets-to-list (addrl)
+ "Convert the streets to a list."
+ (mapcar (lambda (address)
+ (vector (aref address 0) ; key
+ (delq nil (delete "" ; nuke empties
+ (list (aref address 1) ; street1
+ (aref address 2) ; street2
+ (aref address 3))));street3
+ (aref address 4) ; city
+ (aref address 5) ; state
+ (aref address 6) ; postcode
+ (aref address 7))) ; country
+ addrl))
+
+(defun bbdb-migrate-xfields-to-list (xfields)
+ "Migrate XFIELDS to list."
+ (if (stringp xfields)
+ `((notes . ,xfields))
+ xfields))
+
+(defun bbdb-migrate-organization-to-list (organization)
+ "Migrate ORGANIZATION to list."
+ (if (stringp organization)
+ (bbdb-split 'organization organization)
+ organization))
+
+;;;###autoload
+(defun bbdb-undocumented-variables (&optional name-space message)
+ "Return list of undocumented variables in NAME-SPACE.
+NAME-SPACE defaults to \"bbdb-\". Use a prefix arg to specify NAME-SPACE
+interactively. If MESSAGE is non-nil (as in interactive calls) display
+the list in the message area.
+
+This command may come handy to identify BBDB variables in your init file
+that are not used anymore by the current version of BBDB. Yet this fails
+for outdated BBDB variables that are set via your personal `custom-file'."
+ (interactive (list (if current-prefix-arg
+ (read-string "Name space: ")) t))
+ (let ((re (concat "\\`" (or name-space "bbdb-"))) list)
+ (mapatoms (lambda (vv)
+ (if (and (boundp vv)
+ (string-match re (symbol-name vv))
+ (not (get vv 'variable-documentation))
+ (not (get vv 'byte-obsolete-variable)))
+ (push vv list))))
+ (if message
+ (if list
+ (apply 'message (concat "Undocumented variables: "
+ (mapconcat (lambda (_m) "%s") list " "))
list)
+ (message "No undocumented variables `%s...'" name-space)))
+ list))
+
+(provide 'bbdb-migrate)
+
+;;; bbdb-migrate.el ends here
diff --git a/lisp/bbdb/bbdb-mu4e.el b/lisp/bbdb/bbdb-mu4e.el
new file mode 100644
index 0000000..dfada41
--- /dev/null
+++ b/lisp/bbdb/bbdb-mu4e.el
@@ -0,0 +1,44 @@
+;;; bbdb-mu4e.el --- BBDB interface to mu4e -*- lexical-binding: t -*-
+
+;; Copyright (C) 2015-2017 Free Software Foundation, Inc.
+
+;; This file is part of the Insidious Big Brother Database (aka BBDB),
+
+;; BBDB 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 3 of the License, 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 BBDB. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;; This file contains the BBDB interface to mu4e.
+;; See the BBDB info manual for documentation.
+
+;;; Code:
+
+(require 'bbdb)
+(if t (require 'mu4e-view))
+
+(defvar mu4e-view-mode-map)
+
+;;;###autoload
+(defun bbdb-insinuate-mu4e ()
+ "Hook BBDB into mu4e.
+Do not call this in your init file. Use `bbdb-initialize'."
+ ;; Tackle headers later
+ ;; (define-key mu4e-headers-mode-map ":" 'bbdb-mua-display-sender)
+ ;; (define-key mu4e-headers-mode-map ";" 'bbdb-mua-edit-field-sender)
+ ;; Do we need keybindings for more commands? Suggestions welcome.
+ (define-key mu4e-view-mode-map ":" 'bbdb-mua-display-sender)
+ (define-key mu4e-view-mode-map ";" 'bbdb-mua-edit-field-sender))
+
+(provide 'bbdb-mu4e)
+
+;;; bbdb-mu4e.el ends here
diff --git a/lisp/bbdb/bbdb-mua.el b/lisp/bbdb/bbdb-mua.el
new file mode 100644
index 0000000..dc57fd8
--- /dev/null
+++ b/lisp/bbdb/bbdb-mua.el
@@ -0,0 +1,1062 @@
+;;; bbdb-mua.el --- various MUA functionality for BBDB -*- lexical-binding: t
-*-
+
+;; Copyright (C) 2010-2017 Free Software Foundation, Inc.
+
+;; This file is part of the Insidious Big Brother Database (aka BBDB),
+
+;; BBDB 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 3 of the License, 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 BBDB. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;; This file provides various additional functionality for BBDB
+;; See the BBDB info manual for documentation.
+
+;; This file lets you do stuff like
+;;
+;; o automatically add some string to some field(s) based on the
+;; contents of header fields of the current message
+;; o only automatically create records when certain header fields
+;; are matched
+;; o do not automatically create records when certain header fields
+;; are matched
+;;
+;; Read the docstrings; read the texinfo file.
+
+;;; Code:
+
+(require 'bbdb)
+(require 'bbdb-com)
+
+(declare-function gnus-fetch-original-field "gnus-utils")
+(declare-function gnus-summary-select-article "gnus-sum")
+(defvar gnus-article-buffer)
+
+(declare-function bbdb/vm-header "bbdb-vm")
+(declare-function vm-follow-summary-cursor "vm-motion")
+(declare-function vm-select-folder-buffer "vm-macro")
+(declare-function vm-check-for-killed-summary "vm-misc")
+(declare-function vm-error-if-folder-empty "vm-misc")
+
+(declare-function bbdb/rmail-header "bbdb-rmail")
+(defvar rmail-buffer)
+
+(declare-function bbdb/mh-header "bbdb-mhe")
+(declare-function mh-show "mh-show")
+(defvar mh-show-buffer)
+
+(defvar mu4e~view-buffer-name)
+
+(declare-function bbdb/wl-header "bbdb-wl")
+
+(declare-function message-field-value "message")
+(declare-function mail-decode-encoded-word-string "mail-parse")
+
+(defconst bbdb-mua-mode-alist
+ '((vm vm-mode vm-virtual-mode vm-summary-mode vm-presentation-mode)
+ (gnus gnus-summary-mode gnus-article-mode gnus-tree-mode)
+ (rmail rmail-mode rmail-summary-mode)
+ (mh mhe-mode mhe-summary-mode mh-folder-mode)
+ (mu4e mu4e-view-mode) ; Tackle `mu4e-headers-mode' later
+ (wl wl-summary-mode wl-draft-mode)
+ (message message-mode mu4e-compose-mode notmuch-message-mode)
+ (mail mail-mode))
+ "Alist of MUA modes supported by BBDB.
+Each element is of the form (MUA MODE MODE ...), where MODEs are used by MUA.")
+
+(defun bbdb-mua ()
+ "For the current message return the MUA.
+Return values include
+ gnus Newsreader Gnus
+ rmail Reading Mail in Emacs
+ vm Viewmail
+ mh Emacs interface to the MH mail system (aka MH-E)
+ mu4e Mu4e
+ wl Wanderlust
+ message Mail and News composition mode that goes with Gnus
+ mail Emacs Mail Mode."
+ (let ((mm-alist bbdb-mua-mode-alist)
+ elt mua)
+ (while (setq elt (pop mm-alist))
+ (if (memq major-mode (cdr elt))
+ (setq mua (car elt)
+ mm-alist nil)))
+ (or mua (error "BBDB: MUA `%s' not supported" major-mode))))
+
+;;;###autoload
+(defun bbdb-message-header (header)
+ "For the current message return the value of HEADER.
+MIME encoded headers are decoded. Return nil if HEADER does not exist."
+ ;; RW: If HEADER was allowed to be a regexp and the content of multiple
+ ;; matching headers was concatenated as in `message-field-value',
+ ;; this would simplify the usage of `bbdb-accept-message-alist' and
+ ;; `bbdb-ignore-message-alist'.
+ ;; RW: If this function had a remember table, it could look up the value
+ ;; of a header if we request the value of the same header multiple times.
+ ;; (We would reset the remember table each time we move on to a new message.)
+ (let* ((mua (bbdb-mua))
+ (val (cond (;; It seems that `gnus-fetch-field' fetches decoded
content of
+ ;; `gnus-visible-headers', ignoring
`gnus-ignored-headers'.
+ ;; Here we use instead `gnus-fetch-original-field' that
fetches
+ ;; the encoded content of `gnus-original-article-buffer'.
+ ;; Decoding makes this possibly a bit slower, but
something like
+ ;; `bbdb-select-message' does not get fooled by an
apparent
+ ;; absence of some headers.
+ ;; See
http://permalink.gmane.org/gmane.emacs.gnus.general/78741
+ (eq mua 'gnus) (gnus-fetch-original-field header))
+ ((eq mua 'vm) (bbdb/vm-header header))
+ ((eq mua 'rmail) (bbdb/rmail-header header))
+ ((eq mua 'mh) (bbdb/mh-header header))
+ ((eq mua 'mu4e) (message-field-value header))
+ ((eq mua 'wl) (bbdb/wl-header header))
+ ((memq mua '(message mail)) (message-field-value header))
+ (t (error "BBDB/%s: header function undefined" mua)))))
+ (if val (mail-decode-encoded-word-string val))))
+
+(defsubst bbdb-message-header-re (header regexp)
+ "Return non-nil if REGEXP matches value of HEADER."
+ (let ((val (bbdb-message-header header))
+ (case-fold-search t)) ; RW: Is this what we want?
+ (and val (string-match regexp val))))
+
+;;; Update database
+
+;;;###autoload
+(defun bbdb-accept-message (&optional invert)
+ "For use with variable `bbdb-mua-update-interactive-p' and friends.
+Return the value of variable `bbdb-update-records-p' for messages matching
+`bbdb-accept-message-alist'. If INVERT is non-nil, accept messages
+not matching `bbdb-ignore-message-alist'."
+ (let ((rest (if invert bbdb-ignore-message-alist
+ bbdb-accept-message-alist))
+ done elt)
+ (if (eq rest t)
+ (setq done t)
+ (while (and (setq elt (pop rest)) (not done))
+ (dolist (header (if (stringp (car elt)) (list (car elt)) (car elt)))
+ (if (bbdb-message-header-re header (cdr elt))
+ (setq done t)))))
+ (if invert (setq done (not done)))
+ (if done bbdb-update-records-p)))
+
+;;;###autoload
+(defun bbdb-ignore-message (&optional invert)
+ "For use with variable `bbdb-mua-update-interactive-p' and friends.
+Return the value of variable `bbdb-update-records-p' for messages not matching
+`bbdb-ignore-message-alist'. If INVERT is non-nil, accept messages
+matching `bbdb-accept-message-alist'."
+ (bbdb-accept-message (not invert)))
+
+;;;###autoload
+(defun bbdb-select-message ()
+ "For use with variable `bbdb-mua-update-interactive-p' and friends.
+Return the value of variable `bbdb-update-records-p' for messages both matching
+`bbdb-accept-message-alist' and not matching `bbdb-ignore-message-alist'."
+ (and (bbdb-accept-message)
+ (bbdb-ignore-message)))
+
+(defun bbdb-get-address-components (&optional header-class ignore-address)
+ "Extract mail addresses from a message.
+Return list with elements (NAME EMAIL HEADER HEADER-CLASS MUA).
+HEADER-CLASS is defined in `bbdb-message-headers'. If HEADER-CLASS is nil,
+use all classes in `bbdb-message-headers'.
+If regexp IGNORE-ADDRESS matches NAME or EMAIL of an address, this address
+is ignored. If IGNORE-ADDRESS is nil, use value of
`bbdb-user-mail-address-re'."
+ ;; We do not use `bbdb-message-all-addresses' here because only when we
+ ;; have compared the addresses with the records in BBDB do we know which
+ ;; address(es) are relevant for us.
+ (let ((message-headers (if header-class
+ (list (assoc header-class bbdb-message-headers))
+ bbdb-message-headers))
+ (mua (bbdb-mua))
+ (ignore-address (or ignore-address bbdb-user-mail-address-re))
+ address-list name mail mail-list content)
+ (dolist (headers message-headers)
+ (dolist (header (cdr headers))
+ (when (setq content (bbdb-message-header header))
+ ;; Always extract all addresses because we do not know yet which
+ ;; address might match IGNORE-ADDRESS.
+ (dolist (address (bbdb-extract-address-components content t))
+ ;; We canonicalize name and mail as early as possible.
+ (setq name (car address)
+ mail (cadr address))
+ ;; ignore uninteresting addresses
+ (unless (or (and (stringp ignore-address)
+ (or (and name (string-match ignore-address name))
+ (and mail (string-match ignore-address
mail))))
+ (and mail (member-ignore-case mail mail-list)))
+ ;; Add each address only once. (Use MAIL-LIST for book keeping.)
+ ;; Thus if we care about whether an address gets associated with
+ ;; one or another header, the order of elements in
+ ;; `bbdb-message-headers' is relevant. The "most important"
+ ;; headers should be first in `bbdb-message-headers'.
+ (if mail (push mail mail-list))
+ (push (list name mail header (car headers) mua)
address-list))))))
+ (or (nreverse address-list)
+ (and header-class bbdb-message-try-all-headers
+ ;; Try again the remaining header classes
+ (let ((bbdb-message-headers
+ (remove (assoc header-class bbdb-message-headers)
+ bbdb-message-headers)))
+ (bbdb-get-address-components nil ignore-address))))))
+
+;;;###autoload
+(defun bbdb-update-records (address-list &optional update-p sort)
+ "Return the list of BBDB records matching ADDRESS-LIST.
+ADDRESS-LIST is a list of mail addresses. (It can be extracted from
+a mail message using `bbdb-get-address-components'.)
+UPDATE-P may take the following values:
+ search Search for existing records matching ADDRESS.
+ update Search for existing records matching ADDRESS;
+ update name and mail field if necessary.
+ query Search for existing records matching ADDRESS;
+ query for creation of a new record if the record does not
exist.
+ create or t Search for existing records matching ADDRESS;
+ create a new record if it does not yet exist.
+ nil Do nothing.
+ a function This functions will be called with no arguments.
+ It should return one of the above values.
+
+If SORT is non-nil, sort records according to `bbdb-record-lessp'.
+Ottherwise, the records are ordered according to ADDRESS-LIST.
+
+Usually this function is called by the wrapper `bbdb-mua-update-records'."
+ ;; UPDATE-P allows filtering of complete messages.
+ ;; Filtering of individual addresses within an accepted message
+ ;; is done by `bbdb-get-address-components' using
`bbdb-user-mail-address-re'.
+ ;; We resolve UPDATE-P repeatedly. This is needed, for example,
+ ;; with the chain `bbdb-mua-auto-update-p' -> `bbdb-select-message'
+ ;; -> `bbdb-update-records-p'.
+ (while (and (functionp update-p)
+ ;; Bad! `search' is a function in `cl-seq.el'.
+ (not (eq update-p 'search)))
+ (setq update-p (funcall update-p)))
+ (cond ((eq t update-p)
+ (setq update-p 'create))
+ ((not (memq update-p '(search update query create nil)))
+ (error "Illegal value of arg update-p: %s" update-p)))
+
+ (let (;; `bbdb-update-records-p' and `bbdb-offer-to-create' are used here
+ ;; as internal variables for communication with `bbdb-query-create'.
+ ;; This does not affect the value of the global user variable
+ ;; `bbdb-update-records-p'.
+ (bbdb-offer-to-create 'start)
+ (bbdb-update-records-p update-p)
+ address records)
+
+ (when update-p
+ (while (setq address (pop address-list))
+ (let* ((bbdb-update-records-address address)
+ hits
+ (task
+ (catch 'done
+ (setq hits
+ ;; We put the call of `bbdb-notice-mail-hook'
+ ;; into `bbdb-annotate-message' so that this hook
+ ;; runs only if the user agreed to change a record.
+ (cond ((or bbdb-read-only
+ (eq bbdb-update-records-p 'search))
+ ;; Search for records having this mail address
+ ;; but do not modify an existing record.
+ ;; This does not run `bbdb-notice-mail-hook'.
+ (bbdb-message-search (car address)
+ (cadr address)))
+ ((eq bbdb-update-records-p 'update)
+ (bbdb-annotate-message address 'update))
+ ((eq bbdb-update-records-p 'query)
+ (bbdb-annotate-message
+ address 'bbdb-query-create))
+ ((eq bbdb-update-records-p 'create)
+ (bbdb-annotate-message address 'create))))
+ nil)))
+ (cond ((eq task 'quit)
+ (setq address-list nil))
+ ((not (eq task 'next))
+ (dolist (hit (delq nil (nreverse hits)))
+ (bbdb-pushnew hit records))))
+ (if (and records (not bbdb-message-all-addresses))
+ (setq address-list nil))))
+ (setq records
+ (if sort (sort records 'bbdb-record-lessp)
+ ;; Make RECORDS a list ordered like ADDRESS-LIST.
+ (nreverse records))))
+
+ ;; `bbdb-message-search' might yield multiple records
+ (if (and records (not bbdb-message-all-addresses))
+ (setq records (list (car records))))
+
+ (unless bbdb-read-only
+ (bbdb-editable)
+ (dolist (record records)
+ (run-hook-with-args 'bbdb-notice-record-hook record)))
+
+ records))
+
+(defun bbdb-query-create ()
+ "Interactive query used by `bbdb-update-records'.
+Return t if the record should be created or `nil' otherwise.
+Honor previous answers such as `!'."
+ (let ((task bbdb-offer-to-create))
+ ;; If we have remembered what the user typed previously,
+ ;; `bbdb-offer-to-create' holds a character, i.e., a number.
+ ;; -- Right now, we only remember "!".
+ (when (not (integerp task))
+ (let ((prompt (format "%s is not in BBDB; add? (y,!,n,s,q,?) "
+ (or (nth 0 bbdb-update-records-address)
+ (nth 1 bbdb-update-records-address))))
+ event)
+ (while (not event)
+ (setq event (read-key-sequence prompt))
+ (setq event (if (stringp event) (aref event 0))))
+ (setq task event)
+ (message ""))) ; clear the message buffer
+
+ (cond ((eq task ?y)
+ t)
+ ((eq task ?!)
+ (setq bbdb-offer-to-create task)
+ t)
+ ((or (eq task ?n)
+ (eq task ?\s))
+ (throw 'done 'next))
+ ((or (eq task ?q)
+ (eq task ?\a)) ; ?\a = C-g
+ (throw 'done 'quit))
+ ((eq task ?s)
+ (setq bbdb-update-records-p 'search)
+ (throw 'done 'next))
+ (t ; any other key sequence
+ (save-window-excursion
+ (let* ((buffer (get-buffer-create " *BBDB Help*"))
+ (window (or (get-buffer-window buffer)
+ (split-window (get-lru-window)))))
+ (with-current-buffer buffer
+ (special-mode)
+ (let (buffer-read-only)
+ (erase-buffer)
+ (insert
+ "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.")
+ (set-buffer-modified-p nil)
+ (goto-char (point-min)))
+ (set-window-buffer window buffer)
+ (fit-window-to-buffer window)))
+ ;; Try again!
+ (bbdb-query-create))))))
+
+
+
+(defun bbdb-annotate-message (address &optional update-p)
+ "Fill the records for message ADDRESS with as much info as possible.
+If a record for ADDRESS does not yet exist, UPDATE-P controls whether
+a new record is created for ADDRESS. UPDATE-P may take the values:
+ update or nil Update existing records, never create a new record.
+ query Query interactively whether to create a new record.
+ create or t Create a new record.
+ a function This functions will be called with no arguments.
+ It should return one of the above values.
+Return the records matching ADDRESS or nil."
+ (let* ((mail (nth 1 address)) ; possibly nil
+ (name (unless (equal mail (car address))
+ (car address)))
+ (records (bbdb-message-search name mail))
+ created-p new-records)
+ (if (and (not records) (functionp update-p))
+ (setq update-p (funcall update-p)))
+ (cond ((eq t update-p) (setq update-p 'create))
+ ((not update-p) (setq update-p 'update)))
+
+ ;; Create a new record if nothing else fits.
+ ;; In this way, we can fill the slots of the new record with
+ ;; the same code that updates the slots of existing records.
+ (unless (or records
+ (eq update-p 'update)
+ (not (or name mail)))
+ ;; If there is no name, try to use the mail address as name
+ (if (and bbdb-message-mail-as-name mail
+ (or (null name)
+ (string= "" name)))
+ (setq name (funcall bbdb-message-clean-name-function mail)))
+ (if (or (eq update-p 'create)
+ (and (eq update-p 'query)
+ (y-or-n-p (format "%s is not in the BBDB. Add? "
+ (or name mail)))))
+ (setq records (list (bbdb-empty-record))
+ created-p t)))
+
+ (dolist (record records)
+ (let* ((old-name (bbdb-record-name record))
+ (fullname (bbdb-divide-name (or name "")))
+ (fname (car fullname))
+ (lname (cdr fullname))
+ (mail mail) ;; possibly changed below
+ (created-p created-p)
+ (update-p update-p)
+ change-p add-mails add-name ignore-redundant)
+
+ ;; Analyze the name part of the record.
+ (cond ((or (not name)
+ ;; The following tests can differ for more complicated names
+ (bbdb-string= name old-name)
+ (and (equal fname (bbdb-record-firstname record)) ; possibly
+ (equal lname (bbdb-record-lastname record))) ; nil
+ (member-ignore-case name (bbdb-record-aka record)))) ; do
nothing
+
+ (created-p ; new record
+ (bbdb-record-set-field record 'name (cons fname lname)))
+
+ ((not (setq add-name (bbdb-add-job bbdb-add-name record name))))
; do nothing
+
+ ((numberp add-name)
+ (unless bbdb-silent
+ (message "name mismatch: \"%s\" changed to \"%s\""
+ old-name name)
+ (sit-for add-name)))
+
+ ((bbdb-eval-spec add-name
+ (if old-name
+ (format "Change name \"%s\" to \"%s\"? "
+ old-name name)
+ (format "Assign name \"%s\" to address
\"%s\"? "
+ name (car (bbdb-record-mail
record)))))
+ ;; Keep old-name as AKA?
+ (when (and old-name
+ (not (member-ignore-case old-name (bbdb-record-aka
record))))
+ (if (bbdb-eval-spec (bbdb-add-job bbdb-add-aka record
old-name)
+ (format "Keep name \"%s\" as an AKA? "
old-name))
+ (bbdb-record-set-field
+ record 'aka (cons old-name (bbdb-record-aka record)))
+ (bbdb-remhash old-name record)))
+ (bbdb-record-set-field record 'name (cons fname lname))
+ (setq change-p 'name))
+
+ ;; make new name an AKA?
+ ((and old-name
+ (not (member-ignore-case name (bbdb-record-aka record)))
+ (bbdb-eval-spec (bbdb-add-job bbdb-add-aka record name)
+ (format "Make \"%s\" an alternate for
\"%s\"? "
+ name old-name)))
+ (bbdb-record-set-field
+ record 'aka (cons name (bbdb-record-aka record)))
+ (setq change-p 'name)))
+
+ ;; Is MAIL redundant compared with the mail addresses
+ ;; that are already known for RECORD?
+ (if (and mail
+ (setq ignore-redundant
+ (bbdb-add-job bbdb-ignore-redundant-mails record mail)))
+ (let ((mails (bbdb-record-mail-canon record))
+ (case-fold-search t) redundant ml re)
+ (while (setq ml (pop mails))
+ (if (and (setq re (bbdb-mail-redundant-re ml))
+ (string-match re mail))
+ (setq redundant ml mails nil)))
+ (if redundant
+ (cond ((numberp ignore-redundant)
+ (unless bbdb-silent
+ (message "%s: redundant mail `%s'"
+ (bbdb-record-name record) mail)
+ (sit-for ignore-redundant)))
+ ((or (eq t ignore-redundant)
+ bbdb-silent
+ (y-or-n-p (format "Ignore redundant mail %s?"
mail)))
+ (setq mail redundant))))))
+
+ ;; Analyze the mail part of the new records
+ (cond ((or (not mail) (equal mail "???")
+ (member-ignore-case mail (bbdb-record-mail-canon record))))
; do nothing
+
+ (created-p ; new record
+ (bbdb-record-set-field record 'mail (list mail)))
+
+ ((not (setq add-mails (bbdb-add-job bbdb-add-mails record
mail)))) ; do nothing
+
+ ((numberp add-mails)
+ (unless bbdb-silent
+ (message "%s: new address `%s'"
+ (bbdb-record-name record) mail)
+ (sit-for add-mails)))
+
+ ((or (eq add-mails t) ; add it automatically
+ bbdb-silent
+ (y-or-n-p (format "Add address \"%s\" to %s? " mail
+ (bbdb-record-name record)))
+ (and (or (and (functionp update-p)
+ (progn (setq update-p (funcall update-p))
nil))
+ (memq update-p '(t create))
+ (and (eq update-p 'query)
+ (y-or-n-p
+ (format "Create a new record for %s? "
+ (bbdb-record-name record)))))
+ (progn
+ (setq record (bbdb-empty-record))
+ (bbdb-record-set-name record fname lname)
+ (setq created-p t))))
+
+ (let ((mails (bbdb-record-mail record)))
+ (if ignore-redundant
+ ;; Does the new address MAIL make an old address
redundant?
+ (let ((mail-re (bbdb-mail-redundant-re mail))
+ (case-fold-search t) okay redundant)
+ (dolist (ml mails)
+ (if (string-match mail-re ml) ; redundant mail address
+ (push ml redundant)
+ (push ml okay)))
+ (let ((form (format "redundant mail%s %s"
+ (if (< 1 (length redundant)) "s" "")
+ (bbdb-concat 'mail (nreverse
redundant))))
+ (name (bbdb-record-name record)))
+ (if redundant
+ (cond ((numberp ignore-redundant)
+ (unless bbdb-silent
+ (message "%s: %s" name form)
+ (sit-for ignore-redundant)))
+ ((or (eq t ignore-redundant)
+ bbdb-silent
+ (y-or-n-p (format "Delete %s: " form)))
+ (if (eq t ignore-redundant)
+ (message "%s: deleting %s" name form))
+ (setq mails okay)))))))
+
+ ;; then modify RECORD
+ (bbdb-record-set-field
+ record 'mail
+ (if (and mails
+ (bbdb-eval-spec (bbdb-add-job bbdb-new-mails-primary
+ record mail)
+ (format "Make \"%s\" the primary
address? " mail)))
+ (cons mail mails)
+ (nconc mails (list mail))))
+ (unless change-p (setq change-p t)))))
+
+ (cond (created-p
+ (unless bbdb-silent
+ (if (bbdb-record-name record)
+ (message "created %s's record with address \"%s\""
+ (bbdb-record-name record) mail)
+ (message "created record with naked address \"%s\"" mail)))
+ (bbdb-change-record record))
+
+ (change-p
+ (unless bbdb-silent
+ (cond ((eq change-p 'name)
+ (message "noticed \"%s\"" (bbdb-record-name record)))
+ ((bbdb-record-name record)
+ (message "noticed %s's address \"%s\""
+ (bbdb-record-name record) mail))
+ (t
+ (message "noticed naked address \"%s\"" mail))))
+ (bbdb-change-record record)))
+
+ (run-hook-with-args 'bbdb-notice-mail-hook record)
+ (push record new-records)))
+
+ (nreverse new-records)))
+
+(defun bbdb-mua-update-records (&optional header-class update-p sort)
+ "Wrapper for `bbdb-update-records'.
+HEADER-CLASS is defined in `bbdb-message-headers'. If it is nil,
+use all classes in `bbdb-message-headers'.
+UPDATE-P is defined in `bbdb-update-records'.
+If SORT is non-nil, sort records according to `bbdb-record-lessp'."
+ (let ((mua (bbdb-mua)))
+ (save-current-buffer
+ (cond ;; VM
+ ((eq mua 'vm)
+ (vm-select-folder-buffer)
+ (vm-check-for-killed-summary)
+ (vm-error-if-folder-empty)
+ (let ((enable-local-variables t)) ; ...or vm bind this to nil.
+ (bbdb-update-records (bbdb-get-address-components header-class)
+ update-p sort)))
+ ;; Gnus
+ ((eq mua 'gnus)
+ (set-buffer gnus-article-buffer)
+ (bbdb-update-records (bbdb-get-address-components header-class)
+ update-p sort))
+ ;; MH-E
+ ((eq mua 'mh)
+ (if mh-show-buffer (set-buffer mh-show-buffer))
+ (bbdb-update-records (bbdb-get-address-components header-class)
+ update-p sort))
+ ;; Rmail
+ ((eq mua 'rmail)
+ (set-buffer rmail-buffer)
+ (bbdb-update-records (bbdb-get-address-components header-class)
+ update-p sort))
+ ;; mu4e
+ ((eq mua 'mu4e)
+ (set-buffer mu4e~view-buffer-name)
+ (bbdb-update-records (bbdb-get-address-components header-class)
+ update-p sort))
+ ;; Wanderlust
+ ((eq mua 'wl)
+ (bbdb-update-records (bbdb-get-address-components header-class)
+ update-p sort))
+ ;; Message and Mail
+ ((memq mua '(message mail))
+ (bbdb-update-records (bbdb-get-address-components header-class)
+ update-p sort))))))
+
+(defmacro bbdb-mua-wrapper (&rest body)
+ "Perform BODY in a MUA buffer."
+ (declare (debug t))
+ `(let ((mua (bbdb-mua)))
+ ;; Here we replicate BODY multiple times which gets clumsy
+ ;; for a larger BODY!
+ (cond ((eq mua 'gnus)
+ ;; This fails in *Article* buffers, where
+ ;; `gnus-article-read-summary-keys' provides an additional wrapper
+ (save-current-buffer
+ (gnus-summary-select-article) ; sets buffer `gnus-summary-buffer'
+ ,@body))
+ ((memq mua '(mail message rmail mh vm mu4e wl))
+ (cond ((eq mua 'vm) (vm-follow-summary-cursor))
+ ((eq mua 'mh) (mh-show)))
+ ;; rmail, mail, message, mu4e and wl do not require any wrapper
+ ,@body))))
+
+(defun bbdb-mua-update-interactive-p ()
+ "Interactive spec for arg UPDATE-P of `bbdb-mua-display-records' and friends.
+If these commands are called without a prefix, the value of their arg
+UPDATE-P is the car of the variable `bbdb-mua-update-interactive-p'.
+Called with a prefix, the value of UPDATE-P is the cdr of this variable."
+ (let ((update-p (if current-prefix-arg
+ (cdr bbdb-mua-update-interactive-p)
+ (car bbdb-mua-update-interactive-p))))
+ (if (eq update-p 'read)
+ (let ((str (completing-read "Action: " '((query) (search) (create))
+ nil t)))
+ (unless (string= "" str) (intern str))) ; nil otherwise
+ update-p)))
+
+(defun bbdb-mua-window-p ()
+ "Return lambda function matching the MUA window.
+This return value can be used as arg HORIZ-P of `bbdb-display-records'."
+ (let ((mm-alist bbdb-mua-mode-alist)
+ elt fun)
+ (while (setq elt (cdr (pop mm-alist)))
+ (if (memq major-mode elt)
+ (setq fun `(lambda (window)
+ (with-current-buffer (window-buffer window)
+ (memq major-mode ',elt)))
+ mm-alist nil)))
+ fun))
+
+;;;###autoload
+(defun bbdb-mua-display-records (&optional header-class update-p all)
+ "Display the BBDB record(s) for the addresses in this message.
+This looks into the headers of a message according to HEADER-CLASS.
+Then for the mail addresses found the corresponding BBDB records are displayed.
+UPDATE-P determines whether only existing BBDB records are displayed
+or whether also new records are created for these mail addresses.
+
+HEADER-CLASS is defined in `bbdb-message-headers'. If it is nil,
+use all classes in `bbdb-message-headers'.
+UPDATE-P may take the same values as `bbdb-update-records-p'.
+For interactive calls, see function `bbdb-mua-update-interactive-p'.
+If ALL is non-nil, bind `bbdb-message-all-addresses' to ALL."
+ (interactive (list nil (bbdb-mua-update-interactive-p)))
+ (let ((bbdb-pop-up-window-size bbdb-mua-pop-up-window-size)
+ (bbdb-message-all-addresses (or all bbdb-message-all-addresses))
+ records)
+ (bbdb-mua-wrapper
+ (setq records (bbdb-mua-update-records header-class update-p t)))
+ (if records (bbdb-display-records records nil nil nil (bbdb-mua-window-p)))
+ records))
+
+;; The following commands are some frontends for `bbdb-mua-display-records',
+;; which is always doing the real work. In your init file, you can further
+;; modify or adapt these simple commands to your liking.
+
+;;;###autoload
+(defun bbdb-mua-display-sender (&optional update-p)
+ "Display the BBDB record(s) for the sender of this message.
+UPDATE-P may take the same values as `bbdb-update-records-p'.
+For interactive calls, see function `bbdb-mua-update-interactive-p'."
+ (interactive (list (bbdb-mua-update-interactive-p)))
+ (bbdb-mua-display-records 'sender update-p))
+
+;;;###autoload
+(defun bbdb-mua-display-recipients (&optional update-p)
+ "Display the BBDB record(s) for the recipients of this message.
+UPDATE-P may take the same values as `bbdb-update-records-p'.
+For interactive calls, see function `bbdb-mua-update-interactive-p'."
+ (interactive (list (bbdb-mua-update-interactive-p)))
+ (bbdb-mua-display-records 'recipients update-p))
+
+;;;###autoload
+(defun bbdb-mua-display-all-records (&optional update-p)
+ "Display the BBDB record(s) for all addresses in this message.
+UPDATE-P may take the same values as `bbdb-update-records-p'.
+For interactive calls, see function `bbdb-mua-update-interactive-p'."
+ (interactive (list (bbdb-mua-update-interactive-p)))
+ (bbdb-mua-display-records nil update-p t))
+
+;;;###autoload
+(defun bbdb-mua-display-all-recipients (&optional update-p)
+ "Display BBDB records for all recipients of this message.
+UPDATE-P may take the same values as `bbdb-update-records-p'.
+For interactive calls, see function `bbdb-mua-update-interactive-p'."
+ (interactive (list (bbdb-mua-update-interactive-p)))
+ (bbdb-mua-display-records 'recipients update-p t))
+
+;; The commands `bbdb-annotate-record' and `bbdb-mua-edit-field'
+;; have kind of similar goals, yet they use rather different strategies.
+;; `bbdb-annotate-record' is less obtrusive. It does not display
+;; the records it operates on, nor does it display the content
+;; of the field before or after adding or replacing the annotation.
+;; Hence the user needs to know what she is doing.
+;; `bbdb-mua-edit-field' is more explicit: It displays the records
+;; as well as the current content of the field that gets edited.
+
+;; In principle, this function can be used not only with MUAs.
+(defun bbdb-annotate-record (record annotation &optional field replace)
+ "In RECORD add an ANNOTATION to field FIELD.
+FIELD defaults to `bbdb-annotate-field'.
+If REPLACE is non-nil, ANNOTATION replaces the content of FIELD.
+If ANNOTATION is an empty string and REPLACE is non-nil, delete FIELD."
+ (if (memq field '(name firstname lastname phone address xfields))
+ (error "Field `%s' illegal" field))
+ (setq annotation (bbdb-string-trim annotation))
+ (cond ((memq field '(affix organization mail aka))
+ (setq annotation (list annotation)))
+ ((not field) (setq field bbdb-annotate-field)))
+ (bbdb-record-set-field record field annotation (not replace))
+ (bbdb-change-record record))
+
+;; FIXME: For interactive calls of the following commands, the arg UPDATE-P
+;; should have the same meaning as for `bbdb-mua-display-records',
+;; that is, it should use `bbdb-mua-update-interactive-p'.
+;; But here the prefix arg is already used in a different way.
+;; We could possibly solve this problem if all `bbdb-mua-*' commands
+;; used another prefix arg that is consistently used only for
+;; `bbdb-mua-update-interactive-p'.
+;; Yet this prefix arg must be defined within the key space of the MUA(s).
+;; This results in lots of conflicts...
+;;
+;; Current workaround:
+;; These commands use merely the car of `bbdb-mua-update-interactive-p'.
+;; If one day someone proposes a smart solution to this problem (suggestions
+;; welcome!), this solution will hopefully include the current workaround
+;; as a subset of all its features.
+
+(defun bbdb-mua-annotate-field-interactive ()
+ "Interactive specification for `bbdb-mua-annotate-sender' and friends."
+ (bbdb-editable)
+ (let ((field (if (eq 'all-fields bbdb-annotate-field)
+ (intern (completing-read
+ "Field: "
+ (mapcar 'symbol-name
+ (append '(affix organization mail aka)
+ bbdb-xfield-label-list))))
+ bbdb-annotate-field)))
+ (list (read-string (format "Annotate `%s': " field))
+ field current-prefix-arg
+ (car bbdb-mua-update-interactive-p))))
+
+;;;###autoload
+(defun bbdb-mua-annotate-sender (annotation &optional field replace update-p)
+ "Add ANNOTATION to field FIELD of the BBDB record(s) of message sender(s).
+FIELD defaults to `bbdb-annotate-field'.
+If REPLACE is non-nil, ANNOTATION replaces the content of FIELD.
+UPDATE-P may take the same values as `bbdb-update-records-p'.
+For interactive calls, use car of `bbdb-mua-update-interactive-p'."
+ (interactive (bbdb-mua-annotate-field-interactive))
+ (bbdb-mua-wrapper
+ (dolist (record (bbdb-mua-update-records 'sender update-p))
+ (bbdb-annotate-record record annotation field replace))))
+
+;;;###autoload
+(defun bbdb-mua-annotate-recipients (annotation &optional field replace
+ update-p)
+ "Add ANNOTATION to field FIELD of the BBDB records of message recipients.
+FIELD defaults to `bbdb-annotate-field'.
+If REPLACE is non-nil, ANNOTATION replaces the content of FIELD.
+UPDATE-P may take the same values as `bbdb-update-records-p'.
+For interactive calls, use car of `bbdb-mua-update-interactive-p'."
+ (interactive (bbdb-mua-annotate-field-interactive))
+ (bbdb-mua-wrapper
+ (dolist (record (bbdb-mua-update-records 'recipients update-p))
+ (bbdb-annotate-record record annotation field replace))))
+
+(defun bbdb-mua-edit-field-interactive ()
+ "Interactive specification for command `bbdb-mua-edit-field' and friends."
+ (bbdb-editable)
+ (list (if (eq 'all-fields bbdb-mua-edit-field)
+ (intern (completing-read
+ "Field: "
+ (mapcar 'symbol-name
+ (append '(name affix organization aka mail)
+ bbdb-xfield-label-list))))
+ bbdb-mua-edit-field)
+ (bbdb-mua-update-interactive-p)))
+
+;;;###autoload
+(defun bbdb-mua-edit-field (&optional field update-p header-class)
+ "Edit FIELD of the BBDB record(s) of message sender(s) or recipients.
+FIELD defaults to value of variable `bbdb-mua-edit-field'.
+UPDATE-P may take the same values as `bbdb-update-records-p'.
+For interactive calls, see function `bbdb-mua-update-interactive-p'.
+HEADER-CLASS is defined in `bbdb-message-headers'. If it is nil,
+use all classes in `bbdb-message-headers'."
+ (interactive (bbdb-mua-edit-field-interactive))
+ (cond ((memq field '(firstname lastname address phone xfields))
+ (error "Field `%s' not editable this way" field))
+ ((not field)
+ (setq field bbdb-mua-edit-field)))
+ (bbdb-mua-wrapper
+ (let ((records (bbdb-mua-update-records header-class update-p))
+ (bbdb-pop-up-window-size bbdb-mua-pop-up-window-size))
+ (when records
+ (bbdb-display-records records nil nil nil (bbdb-mua-window-p))
+ (dolist (record records)
+ (bbdb-edit-field record field))))))
+
+;;;###autoload
+(defun bbdb-mua-edit-field-sender (&optional field update-p)
+ "Edit FIELD of record corresponding to sender of this message.
+FIELD defaults to value of variable `bbdb-mua-edit-field'.
+UPDATE-P may take the same values as `bbdb-update-records-p'.
+For interactive calls, see function `bbdb-mua-update-interactive-p'."
+ (interactive (bbdb-mua-edit-field-interactive))
+ (bbdb-mua-edit-field field update-p 'sender))
+
+;;;###autoload
+(defun bbdb-mua-edit-field-recipients (&optional field update-p)
+ "Edit FIELD of record corresponding to recipient of this message.
+FIELD defaults to value of variable `bbdb-mua-edit-field'.
+UPDATE-P may take the same values as `bbdb-update-records-p'.
+For interactive calls, see function `bbdb-mua-update-interactive-p'."
+ (interactive (bbdb-mua-edit-field-interactive))
+ (bbdb-mua-edit-field field update-p 'recipients))
+
+;; Functions for noninteractive use in MUA hooks
+
+;;;###autoload
+(defun bbdb-mua-auto-update (&optional header-class update-p)
+ "Update BBDB automatically based on incoming and outgoing messages.
+This looks into the headers of a message according to HEADER-CLASS.
+Then for the mail addresses found the corresponding BBDB records are updated.
+UPDATE-P determines whether only existing BBDB records are taken
+or whether also new records are created for these mail addresses.
+Return matching records.
+
+HEADER-CLASS is defined in `bbdb-message-headers'. If it is nil,
+use all classes in `bbdb-message-headers'.
+UPDATE-P may take the same values as `bbdb-mua-auto-update-p'.
+If UPDATE-P is nil, use `bbdb-mua-auto-update-p' (which see).
+
+If `bbdb-mua-pop-up' is non-nil, BBDB pops up the *BBDB* buffer
+along with the MUA window(s), displaying the matching records
+using `bbdb-pop-up-layout'.
+If this is nil, BBDB is updated silently.
+
+This function is intended for noninteractive use via appropriate MUA hooks.
+Call `bbdb-mua-auto-update-init' in your init file to put this function
+into the respective MUA hooks.
+See `bbdb-mua-display-records' and friends for interactive commands."
+ (let* ((bbdb-silent-internal t)
+ (records (bbdb-mua-update-records header-class
+ (or update-p
+ bbdb-mua-auto-update-p)))
+ (bbdb-pop-up-window-size bbdb-mua-pop-up-window-size))
+ (if bbdb-mua-pop-up
+ (if records
+ (bbdb-display-records records bbdb-pop-up-layout
+ nil nil (bbdb-mua-window-p))
+ ;; If there are no records, empty the BBDB window.
+ (bbdb-undisplay-records)))
+ records))
+
+;; Should the following be replaced by a minor mode??
+;; Or should we make this function interactive in some other way?
+
+;;;###autoload
+(defun bbdb-mua-auto-update-init (&rest muas)
+ "For MUAS add `bbdb-mua-auto-update' to their presentation hook.
+If a MUA is not an element of MUAS, `bbdb-mua-auto-update' is removed
+from the respective presentation hook.
+
+Call this function in your init file to use the auto update feature with MUAS.
+This function is separate from the general function `bbdb-initialize'
+as this allows one to initialize the auto update feature for some MUAs only,
+for example only for outgoing messages.
+
+See `bbdb-mua-auto-update' for details about the auto update feature."
+ (dolist (mua '((message . message-send-hook)
+ (mail . mail-send-hook)
+ (rmail . rmail-show-message-hook)
+ (gnus . gnus-article-prepare-hook)
+ (mh . mh-show-hook)
+ (vm . vm-select-message-hook)
+ (wl . wl-message-redisplay-hook)))
+ (if (memq (car mua) muas)
+ (add-hook (cdr mua) 'bbdb-mua-auto-update)
+ (remove-hook (cdr mua) 'bbdb-mua-auto-update))))
+
+;;;###autoload
+(defun bbdb-auto-notes (record)
+ "Automatically annotate RECORD based on the headers of the current message.
+See the variables `bbdb-auto-notes-rules', `bbdb-auto-notes-ignore-messages'
+and `bbdb-auto-notes-ignore-headers'.
+For use as an element of `bbdb-notice-record-hook'."
+ ;; This code re-evaluates the annotations each time a message is viewed.
+ ;; It would be faster if we could somehow store (permanently?) that we
+ ;; have already annotated a message.
+ (let ((case-fold-search t))
+ (unless (or bbdb-read-only
+ ;; check the ignore-messages pattern
+ (let ((ignore-messages bbdb-auto-notes-ignore-messages)
+ ignore rule)
+ (while (and (not ignore) (setq rule (pop ignore-messages)))
+ (if (cond ((functionp rule)
+ ;; RULE may use `bbdb-update-records-address'
+ (funcall rule record))
+ ((symbolp rule)
+ (eq rule (nth 4 bbdb-update-records-address)))
+ ((eq 1 (safe-length rule))
+ (bbdb-message-header-re (car rule) (cdr rule)))
+ ((eq 2 (safe-length rule))
+ (and (eq (car rule) (nth 4
bbdb-update-records-address))
+ (bbdb-message-header-re (nth 1 rule) (nth
2 rule)))))
+ (setq ignore t)))
+ ignore))
+ (bbdb-editable)
+
+ ;; For speed-up expanded rules are stored in
`bbdb-auto-notes-rules-expanded'.
+ (when (and bbdb-auto-notes-rules
+ (not bbdb-auto-notes-rules-expanded))
+ (let (expanded mua from-to header)
+ (dolist (rule bbdb-auto-notes-rules)
+ ;; Which MUA do we want?
+ (if (or (stringp (car rule))
+ (stringp (nth 1 rule)))
+ (setq mua t)
+ (setq mua (if (symbolp (car rule)) (listp (car rule)) (car rule))
+ rule (cdr rule)))
+ ;; Which FROM-TO headers do we want?
+ (if (stringp (car rule))
+ (setq from-to t)
+ (setq from-to (car rule)
+ rule (cdr rule)))
+ (setq header (car rule))
+ (let (string field replace elt-e)
+ (dolist (elt (cdr rule))
+ (if (consp (setq string (cdr elt)))
+ (setq field (car string) ; (REGEXP FIELD-NAME STRING
REPLACE)
+ replace (nth 2 string) ; perhaps nil
+ string (nth 1 string))
+ ;; else it's simple (REGEXP . STRING)
+ (setq field bbdb-default-xfield
+ replace nil))
+ (push (list (car elt) field string replace) elt-e))
+ (push (append (list mua from-to header) (nreverse elt-e))
expanded)))
+ (setq bbdb-auto-notes-rules-expanded (nreverse expanded))))
+
+ (dolist (rule bbdb-auto-notes-rules-expanded)
+ (let ((mua (car rule)) (from-to (nth 1 rule)) (header (nth 2 rule))
+ hd-val string annotation)
+ (when (and (or (eq mua t)
+ (memq (nth 4 bbdb-update-records-address) mua))
+ (or (eq from-to t)
+ (member-ignore-case
+ (nth 2 bbdb-update-records-address) from-to)
+ (memq (nth 3 bbdb-update-records-address) from-to))
+ (setq hd-val (bbdb-message-header header)))
+ (dolist (elt (nthcdr 3 rule))
+ (when (and (string-match (car elt) hd-val)
+ (let ((ignore (cdr (assoc-string
+ header
+ bbdb-auto-notes-ignore-headers
t))))
+ (not (and ignore (string-match ignore hd-val)))))
+ (setq string (nth 2 elt)
+ annotation
+ (cond ((integerp string)
+ (match-string string hd-val))
+ ((stringp string)
+ (replace-match string nil nil hd-val))
+ ((functionp string)
+ (funcall string hd-val))
+ (t (error "Illegal value: %s" string))))
+ (bbdb-annotate-record record annotation
+ (nth 1 elt) (nth 3 elt))))))))))
+
+;;; Mark BBDB records in the MUA summary buffer
+
+(defun bbdb-mua-summary-unify (address)
+ "Unify mail ADDRESS displayed for a message in the MUA Summary buffer.
+Typically ADDRESS refers to the value of the From header of a message.
+If ADDRESS matches a record in BBDB display a unified name instead of ADDRESS
+in the MUA Summary buffer.
+
+Unification uses `bbdb-mua-summary-unification-list' (see there).
+The first match in this list becomes the text string displayed
+for a message in the MUA Summary buffer instead of ADDRESS.
+If variable `bbdb-mua-summary-mark' is non-nil use it to precede known
addresses.
+Return the unified mail address.
+
+Currently this works with Gnus and VM. It requires the BBDB insinuation
+of these MUAs. Also, the MUA Summary format string must use
+`bbdb-mua-summary-unify-format-letter' (see there)."
+ ;; ADDRESS is analyzed as in `bbdb-get-address-components'.
+ (let* ((data (bbdb-extract-address-components address))
+ (name (car data))
+ (mail (cadr data))
+ (record (car (bbdb-message-search name mail)))
+ (u-list bbdb-mua-summary-unification-list)
+ elt val)
+ (while (setq elt (pop u-list))
+ (setq val (cond ((eq elt 'message-name) name)
+ ((eq elt 'message-mail) mail)
+ ((eq elt 'message-address) address)
+ (record (let ((result (bbdb-record-field record elt)))
+ (if (stringp result) result
+ (car result)))))) ; RESULT is list.
+ (if val (setq u-list nil)))
+ (format "%s%s"
+ (cond ((not bbdb-mua-summary-mark) "")
+ ((not record) " ")
+ ((functionp bbdb-mua-summary-mark-field)
+ (funcall bbdb-mua-summary-mark-field record))
+ ((bbdb-record-xfield record bbdb-mua-summary-mark-field))
+ (t bbdb-mua-summary-mark))
+ (or val name mail address "**UNKNOWN**"))))
+
+(defun bbdb-mua-summary-mark (address)
+ "In the MUA Summary buffer mark messages matching a BBDB record.
+ADDRESS typically refers to the value of the From header of a message.
+If ADDRESS matches a record in BBDB return a mark, \" \" otherwise.
+The mark itself is the value of the xfield `bbdb-mua-summary-mark-field'
+if this xfield is in the poster's record, and `bbdb-mua-summary-mark'
otherwise."
+ (if (not bbdb-mua-summary-mark)
+ "" ; for consistency
+ ;; ADDRESS is analyzed as in `bbdb-get-address-components'.
+ (let* ((data (bbdb-extract-address-components address))
+ (record (car (bbdb-message-search (car data) (cadr data)))))
+ (if record
+ (or (when (functionp bbdb-mua-summary-mark-field)
+ (funcall bbdb-mua-summary-mark-field record)
+ t)
+ (bbdb-record-xfield record bbdb-mua-summary-mark-field)
+ bbdb-mua-summary-mark)
+ " "))))
+
+(provide 'bbdb-mua)
+
+;;; bbdb-mua.el ends here
diff --git a/lisp/bbdb/bbdb-pgp.el b/lisp/bbdb/bbdb-pgp.el
new file mode 100644
index 0000000..0881388
--- /dev/null
+++ b/lisp/bbdb/bbdb-pgp.el
@@ -0,0 +1,238 @@
+;;; bbdb-pgp.el --- use BBDB to handle PGP preferences -*- lexical-binding: t
-*-
+
+;; Copyright (C) 2013-2017 Free Software Foundation, Inc.
+
+;; This file is part of the Insidious Big Brother Database (aka BBDB),
+
+;; BBDB 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 3 of the License, 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 BBDB. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;; It is believed that encrypted mail works best if all mail between
+;; individuals is encrypted - even concerning matters that are not
+;; confidential. The reasoning is that confidential messages cannot
+;; then be easily spotted and decryption efforts concentrated on them.
+;; Some people therefore prefer to have all their email encrypted.
+;; This package allows you to mark the BBDB entries for those
+;; individuals so that messages will be (signed or) encrypted
+;; when they are sent.
+
+;;; Usage:
+;; Add the xfield pgp-mail (see `bbdb-pgp-field') with the value
+;; `sign' or `encrypt' to the BBDB records of the message recipients.
+;; If the value is `sign-query' or `encrypt-query', this will query
+;; whether to send signed or encrypted messages.
+;;
+;; Then call `bbdb-pgp' on outgoing message to add MML tags,
+;; see info node `(message)security'. For all message recipients
+;; in `bbdb-pgp-headers', this command grabs the action in `bbdb-pgp-field'
+;; of their BBDB records. If this proposes multiple actions,
+;; perform the action which appears first in `bbdb-pgp-ranked-actions'.
+;; If this proposes no action at all, use `bbdb-pgp-default'.
+;; The variable `bbdb-pgp-method' defines the method which is actually used
+;; for signing and encrypting, see also `bbdb-pgp-method-alist'.
+;;
+;; `bbdb-pgp' works with both `mail-mode' and `message-mode' to send
+;; signed or encrypted mail.
+;;
+;; To run `bbdb-pgp' automatically when sending a message,
+;; use `bbdb-initialize' with arg `pgp' to add this function
+;; to `message-send-hook' and `mail-send-hook'.
+;; Yet see info node `(message)Signing and encryption' why you
+;; might not want to rely for encryption on a hook function
+;; which runs just before the message is sent, that is, you might want
+;; to call the command `bbdb-pgp' manually, then call `mml-preview'.
+;;
+;; A thought: For these hooks we could define a wrapper that calls
+;; first `bbdb-pgp', then `mml-preview' for preview. The wrapper should
+;; abort the sending of the message if the preview is not getting
+;; the user's approval. Yet this might require some recursive editing mode
+;; so that the user can browse the preview before approving it.
+;;
+;;; Todo:
+;; Spot incoming PGP-signed or encrypted messages and prompt for adding
+;; `bbdb-pgp-field' to the senders' BBDB records; similar to how
+;; bbdb-sc.el maintains attribution preferences.
+
+;;; Code:
+
+(require 'message)
+(require 'bbdb-com)
+
+(defcustom bbdb-pgp-field 'pgp-mail
+ "BBDB xfield holding the PGP action.
+If the recipient of a message has this xfield in his/her BBDB record,
+its value determines whether `bbdb-pgp' signs or encrypts the message.
+The value of this xfield should be one of the following symbols:
+ sign Sign the message
+ sign-query Query whether to sign the message
+ encrypt Encrypt the message
+ encrypt-query Query whether to encrypt the message
+If the xfield is absent use `bbdb-pgp-default'.
+See also info node `(message)security'."
+ :type '(symbol :tag "BBDB xfield")
+ :group 'bbdb-utilities-pgp)
+
+(defcustom bbdb-pgp-default nil
+ "Default action when sending a message and the recipients are not in BBDB.
+This should be one of the following symbols:
+ nil Do nothing
+ sign Sign the message
+ sign-query Query whether to sign the message
+ encrypt Encrypt the message
+ encrypt-query Query whether to encrypt the message
+See info node `(message)security'."
+ :type '(choice
+ (const :tag "Do Nothing" nil)
+ (const :tag "Encrypt" encrypt)
+ (const :tag "Query encryption" encrypt-query)
+ (const :tag "Sign" sign)
+ (const :tag "Query signing" sign-query))
+ :group 'bbdb-utilities-pgp)
+
+(defcustom bbdb-pgp-ranked-actions
+ '(encrypt-query sign-query encrypt sign)
+ "Ranked list of actions when sending a message.
+If a message has multiple recipients such that their BBDB records specify
+different actions for this message, `bbdb-pgp' will perform the action
+which appears first in `bbdb-pgp-ranked-actions'.
+This list should include the following four symbols:
+ sign Sign the message
+ sign-query Query whether to sign the message
+ encrypt Encrypt the message
+ encrypt-query Query whether to encrypt the message."
+ :type '(repeat (symbol :tag "Action"))
+ :group 'bbdb-utilities-pgp)
+
+(defcustom bbdb-pgp-headers '("To" "Cc")
+ "Message headers to look at."
+ :type '(repeat (string :tag "Message header"))
+ :group 'bbdb-utilities-pgp)
+
+(defcustom bbdb-pgp-method 'pgpmime
+ "Method for signing and encrypting messages.
+It should be one of the keys of `bbdb-pgp-method-alist'.
+The default methods include
+ pgp Add MML tags for PGP format
+ pgpauto Add MML tags for PGP-auto format
+ pgpmime Add MML tags for PGP/MIME
+ smime Add MML tags for S/MIME
+See info node `(message)security'."
+ :type '(choice
+ (const :tag "MML PGP" pgp)
+ (const :tag "MML PGP-auto" pgpauto)
+ (const :tag "MML PGP/MIME" pgpmime)
+ (const :tag "MML S/MIME" smime)
+ (symbol :tag "Custom"))
+ :group 'bbdb-utilities-pgp)
+
+(defcustom bbdb-pgp-method-alist
+ '((pgp mml-secure-message-sign-pgp
+ mml-secure-message-encrypt-pgp)
+ (pgpmime mml-secure-message-sign-pgpmime
+ mml-secure-message-encrypt-pgpmime)
+ (smime mml-secure-message-sign-smime
+ mml-secure-message-encrypt-smime)
+ (pgpauto mml-secure-message-sign-pgpauto
+ mml-secure-message-encrypt-pgpauto))
+ "Alist of methods for signing and encrypting a message with `bbdb-pgp'.
+Each method is a list (KEY SIGN ENCRYPT).
+The symbol KEY identifies the method. The function SIGN signs the message;
+the function ENCRYPT encrypts it. These functions take no arguments.
+The default methods include
+ pgp Add MML tags for PGP format
+ pgpauto Add MML tags for PGP-auto format
+ pgpmime Add MML tags for PGP/MIME
+ smime Add MML tags for S/MIME
+See info node `(message)security'."
+ :type '(repeat (list (symbol :tag "Key")
+ (symbol :tag "Sign method")
+ (symbol :tag "Encrypt method")))
+ :group 'bbdb-utilities-pgp)
+
+;;;###autoload
+(defun bbdb-read-xfield-pgp-mail (&optional init)
+ "Set `bbdb-pgp-field', requiring match with `bbdb-pgp-ranked-actions'."
+ (bbdb-read-string "PGP action: " init
+ (mapcar 'list bbdb-pgp-ranked-actions) t))
+
+;;;###autoload
+(defun bbdb-pgp ()
+ "Add PGP MML tags to a message according to the recipients' BBDB records.
+For all message recipients in `bbdb-pgp-headers', this grabs the action
+in `bbdb-pgp-field' of their BBDB records. If this proposes multiple actions,
+perform the action which appears first in `bbdb-pgp-ranked-actions'.
+If this proposes no action at all, use `bbdb-pgp-default'.
+The variable `bbdb-pgp-method' defines the method which is actually used
+for signing and encrypting.
+
+This command works with both `mail-mode' and `message-mode' to send
+signed or encrypted mail.
+
+To run this command automatically when sending a message,
+use `bbdb-initialize' with arg `pgp' to add this function
+to `message-send-hook' and `mail-send-hook'.
+Yet see info node `(message)Signing and encryption' why you
+might not want to rely for encryption on a hook function
+which runs just before the message is sent, that is, you might want
+to call the command `bbdb-pgp' manually, then call `mml-preview'."
+ (interactive)
+ (save-excursion
+ (save-restriction
+ (widen)
+ (message-narrow-to-headers)
+ (when mail-aliases
+ ;; (sendmail-sync-aliases) ; needed?
+ (expand-mail-aliases (point-min) (point-max)))
+ (let ((actions
+ (or (delq nil
+ (delete-dups
+ (mapcar
+ (lambda (record)
+ (bbdb-record-xfield-intern record bbdb-pgp-field))
+ (delete-dups
+ (apply 'nconc
+ (mapcar
+ (lambda (address)
+ (bbdb-message-search (car address)
+ (cadr address)))
+ (bbdb-extract-address-components
+ (mapconcat
+ (lambda (header)
+ (mail-fetch-field header nil t))
+ bbdb-pgp-headers ", ")
+ t)))))))
+ (and bbdb-pgp-default
+ (list bbdb-pgp-default)))))
+ (when actions
+ (widen) ; after analyzing the headers
+ (let ((ranked-actions bbdb-pgp-ranked-actions)
+ action)
+ (while ranked-actions
+ (if (memq (setq action (pop ranked-actions)) actions)
+ (cond ((or (eq action 'sign)
+ (and (eq action 'sign-query)
+ (y-or-n-p "Sign message? ")))
+ (funcall (nth 1 (assq bbdb-pgp-method
+ bbdb-pgp-method-alist)))
+ (setq ranked-actions nil))
+ ((or (eq action 'encrypt)
+ (and (eq action 'encrypt-query)
+ (y-or-n-p "Encrypt message? ")))
+ (funcall (nth 2 (assq bbdb-pgp-method
+ bbdb-pgp-method-alist)))
+ (setq ranked-actions nil)))))))))))
+
+(provide 'bbdb-pgp)
+
+;;; bbdb-pgp.el ends here
diff --git a/lisp/bbdb/bbdb-rmail.el b/lisp/bbdb/bbdb-rmail.el
new file mode 100644
index 0000000..69c92ac
--- /dev/null
+++ b/lisp/bbdb/bbdb-rmail.el
@@ -0,0 +1,62 @@
+;;; bbdb-rmail.el --- BBDB interface to Rmail -*- lexical-binding: t -*-
+
+;; Copyright (C) 2010-2017 Free Software Foundation, Inc.
+
+;; This file is part of the Insidious Big Brother Database (aka BBDB),
+
+;; BBDB 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 3 of the License, 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 BBDB. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;; This file contains the BBDB interface to Rmail.
+;;; See the BBDB info manual for documentation.
+
+;;; Code:
+
+(require 'bbdb)
+(require 'bbdb-com)
+(require 'bbdb-mua)
+(require 'rmail)
+(require 'rmailsum)
+(require 'mailheader)
+
+(defun bbdb/rmail-new-flag ()
+ "Returns t if the current message in buffer BUF is new."
+ (rmail-message-labels-p rmail-current-message ", ?\\(unseen\\),"))
+
+(defun bbdb/rmail-header (header)
+ "Pull HEADER out of Rmail header."
+ (with-current-buffer rmail-buffer
+ (if (fboundp 'rmail-get-header) ; Emacs 23
+ (rmail-get-header header)
+ (save-restriction
+ (with-no-warnings (rmail-narrow-to-non-pruned-header))
+ (mail-header (intern-soft (downcase header))
+ (mail-header-extract))))))
+
+;;;###autoload
+(defun bbdb-insinuate-rmail ()
+ "Hook BBDB into RMAIL.
+Do not call this in your init file. Use `bbdb-initialize'."
+ ;; Do we need keybindings for more commands? Suggestions welcome.
+ ;; (define-key rmail-mode-map ":" 'bbdb-mua-display-records)
+ ;; (define-key rmail-mode-map "'" 'bbdb-mua-display-recipients)
+ (define-key rmail-mode-map ":" 'bbdb-mua-display-sender)
+ (define-key rmail-mode-map ";" 'bbdb-mua-edit-field-sender)
+ ;; (define-key rmail-mode-map ";" 'bbdb-mua-edit-field-recipients)
+ (define-key rmail-summary-mode-map ":" 'bbdb-mua-display-sender)
+ (define-key rmail-summary-mode-map ";" 'bbdb-mua-edit-field-sender))
+
+(provide 'bbdb-rmail)
+
+;;; bbdb-rmail.el ends here
diff --git a/lisp/bbdb/bbdb-snarf.el b/lisp/bbdb/bbdb-snarf.el
new file mode 100644
index 0000000..7649501
--- /dev/null
+++ b/lisp/bbdb/bbdb-snarf.el
@@ -0,0 +1,488 @@
+;;; bbdb-snarf.el --- convert free-form text to BBDB records -*-
lexical-binding: t -*-
+
+;; Copyright (C) 2010-2017 Free Software Foundation, Inc.
+
+;; This file is part of the Insidious Big Brother Database (aka BBDB),
+
+;; BBDB 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 3 of the License, 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 BBDB. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; The commands `bbdb-snarf', `bbdb-snarf-yank' and `bbdb-snarf-paragraph'
+;; create BBDB records by picking the name, addresses, phones, etc.
+;; out of a (buffer) string. Things are recognized by context (e.g., URLs
+;; start with http:// or www.). See `bbdb-snarf-rule-alist' for details.
+;;
+;; The rule `eu' should work out of the box for many continental
+;; European countries. It can be further customized by defining
+;; a suitable postcode regexp passed to `bbdb-snarf-address-eu'.
+;; `mail' is a simple rule that can pick a single mail address from,
+;; say, a long list of mail addresses in a message.
+;;
+;; RW: `bbdb-snarf' is an interesting proof of concept. Yet I find
+;; its snarfing algorithms often too simplistic to be useful in real life.
+;; How can this possibly be improved? Suggestions welcome.
+
+;;; Code:
+
+(require 'bbdb-com)
+
+(defcustom bbdb-snarf-rule-alist
+ '((us bbdb-snarf-surrounding-space
+ bbdb-snarf-phone-nanp
+ bbdb-snarf-url
+ bbdb-snarf-mail
+ bbdb-snarf-empty-lines
+ bbdb-snarf-name
+ bbdb-snarf-address-us
+ bbdb-snarf-empty-lines
+ bbdb-snarf-notes
+ bbdb-snarf-name-mail) ; currently useless
+ (eu bbdb-snarf-surrounding-space
+ bbdb-snarf-phone-eu
+ bbdb-snarf-url
+ bbdb-snarf-mail
+ bbdb-snarf-empty-lines
+ bbdb-snarf-name
+ bbdb-snarf-address-eu
+ bbdb-snarf-empty-lines
+ bbdb-snarf-notes
+ bbdb-snarf-name-mail) ; currently useless
+ (mail bbdb-snarf-mail-address))
+ "Alist of rules for snarfing.
+Each rule is of the form (KEY FUNCTION FUNCTION ...).
+The symbol KEY identifies the rule, see also `bbdb-snarf-rule-default'.
+
+Snarfing is a cumulative process. The text is copied to a temporary
+snarf buffer that becomes current during snarfing.
+Each FUNCTION is called with one arg, the RECORD we are snarfing,
+and with point at the beginning of the snarf buffer. FUNCTION should populate
+the fields of RECORD. It may delete the part of the snarf buffer
+that it has processed so that the remaining FUNCTIONs operate only
+on those parts that were not yet snarfed. The order of the FUNCTION calls
+in a rule is then crucial.
+Unlike other parts of BBDB, FUNCTIONs need not update the cache and
+hash table for RECORD which is done at the end by `bbdb-snarf'."
+ :group 'bbdb-utilities-snarf
+ :type '(repeat (cons (symbol :tag "Key")
+ (repeat (function :tag "Snarf function")))))
+
+(defcustom bbdb-snarf-rule-default 'us
+ "Default rule for snarfing."
+ :group 'bbdb-utilities-snarf
+ :type 'symbol)
+
+(defcustom bbdb-snarf-name-regexp
+ "^[ \t'\"]*\\([- .,[:word:]]*[[:word:]]\\)"
+ "Regexp matching a name. Case is ignored.
+The first subexpression becomes the name."
+ :group 'bbdb-utilities-snarf
+ :type 'regexp)
+
+(defcustom bbdb-snarf-mail-regexp
+ (concat "\\(?:\\(?:mailto:\\|e?mail:?\\)[ \t]*\\)?"
+ "<?\\([^ \t\n<address@hidden \t\n>]+\\)>?")
+ "Regexp matching a mail address. Case is ignored.
+The first subexpression becomes the mail address."
+ :group 'bbdb-utilities-snarf
+ :type 'regexp)
+
+(defcustom bbdb-snarf-phone-nanp-regexp
+ (concat "\\(?:phone:?[ \t]*\\)?"
+ "\\(\\(?:([2-9][0-9][0-9])[-. ]?\\|[2-9][0-9][0-9][-. ]\\)?"
+ "[0-9][0-9][0-9][-. ][0-9][0-9][0-9][0-9]"
+ "\\(?: *\\(?:x\\|ext\\.?\\) *[0-9]+\\)?\\)")
+ "Regexp matching a NANP phone number. Case is ignored.
+NANP is the North American Numbering Plan used in North and Central America.
+The first subexpression becomes the phone number."
+ :group 'bbdb-utilities-snarf
+ :type 'regexp)
+
+(defcustom bbdb-snarf-phone-eu-regexp
+ (concat "\\(?:phone?:?[ \t]*\\)?"
+ "\\(\\(?:\\+[1-9]\\|(\\)[-0-9()\s]+\\)")
+ "Regexp matching a European phone number.
+The first subexpression becomes the phone number."
+ :group 'bbdb-utilities-snarf
+ :type 'regexp)
+
+(defcustom bbdb-snarf-postcode-us-regexp
+ ;; US postcode appears at end of line
+ (concat "\\(\\<[0-9][0-9][0-9][0-9][0-9]"
+ "\\(-[0-9][0-9][0-9][0-9]\\)?"
+ "\\>\\)$")
+ "Regexp matching US postcodes.
+The first subexpression becomes the postcode."
+ :group 'bbdb-utilities-snarf
+ :type 'regexp)
+
+(defcustom bbdb-snarf-address-us-country nil
+ "Country to use for US addresses. If nil leave country blank."
+ :group 'bbdb-utilities-snarf
+ :type '(choice (const :tag "Leave blank" nil)
+ (string :tag "Country")))
+
+(defcustom bbdb-snarf-postcode-eu-regexp
+ "^\\([0-9][0-9][0-9][0-9][0-9]?\\)" ; four or five digits
+ "Regexp matching many European postcodes.
+`bbdb-snarf-address-eu' assumes that the address appears at the beginning
+of a line followed by the name of the city."
+ :group 'bbdb-utilities-snarf
+ :type 'regexp)
+
+(defcustom bbdb-snarf-address-eu-country nil
+ "Country to use for EU addresses. If nil leave country blank."
+ :group 'bbdb-utilities-snarf
+ :type '(choice (const :tag "Leave blank" nil)
+ (string :tag "Country")))
+
+(defcustom bbdb-snarf-default-label-alist
+ '((phone . "work") (address . "work"))
+ "Default labels for snarfing.
+This is an alist where each element is a cons pair (FIELD . LABEL).
+The symbol FIELD denotes a record field like `phone' or `address'.
+The string LABEL denotes the default label for FIELD."
+ :group 'bbdb-utilities-snarf
+ :type '(repeat (cons (symbol :tag "Field")
+ (string :tag "Label"))))
+
+(defcustom bbdb-snarf-url 'url
+ "What xfield BBDB should use for URLs, or nil to not snarf URLs."
+ :group 'bbdb-utilities-snarf
+ :type 'symbol)
+
+(defcustom bbdb-snarf-url-regexp "\\(\\(?:http://\\|www\\.\\)[^ \t\n]+\\)"
+ "Regexp matching a URL. Case is ignored.
+The first subexpression becomes the URL."
+ :group 'bbdb-utilities-snarf
+ :type 'regexp)
+
+(defun bbdb-snarf-surrounding-space (_record)
+ "Discard beginning and trailing space when snarfing RECORD."
+ (while (re-search-forward "^[ \t]+" nil t)
+ (replace-match ""))
+ (goto-char (point-min))
+ (while (re-search-forward "\\s-+$" nil t)
+ (replace-match "")))
+
+(defun bbdb-snarf-empty-lines (_record)
+ "Discard empty lines when snarfing RECORD."
+ (while (re-search-forward "^[ \t]*\n" nil t)
+ (replace-match "")))
+
+(defun bbdb-snarf-name (record)
+ "Snarf name for RECORD."
+ (if (and (not (bbdb-record-lastname record))
+ (let ((case-fold-search t))
+ (re-search-forward bbdb-snarf-name-regexp nil t)))
+ (let ((name (match-string 1)))
+ (replace-match "")
+ (setq name (bbdb-divide-name name))
+ (bbdb-record-set-firstname record (car name))
+ (bbdb-record-set-lastname record (cdr name)))))
+
+(defun bbdb-snarf-name-mail (record)
+ "Snarf name from mail address for RECORD."
+ ;; Fixme: This is currently useless because `bbdb-snarf-mail-regexp'
+ ;; cannot handle names in RFC 5322-like addresses "John Smith
<address@hidden>".
+ (let ((name (bbdb-record-lastname record)))
+ (when (and (not name)
+ (bbdb-record-mail record)
+ (setq name (car (bbdb-extract-address-components
+ (car (bbdb-record-mail record)))))
+ (setq name (bbdb-divide-name name)))
+ (bbdb-record-set-firstname record (car name))
+ (bbdb-record-set-lastname record (cadr name)))))
+
+(defun bbdb-snarf-mail-address (record)
+ "Snarf name and mail address for RECORD."
+ ;; The voodoo of `mail-extract-address-components' makes
+ ;; the following quite powerful. If this function is used as part of
+ ;; a more complex rule, the buffer should be narrowed appropriately.
+ (let* ((data (bbdb-extract-address-components (buffer-string)))
+ (name (and (car data) (bbdb-divide-name (car data)))))
+ (bbdb-record-set-firstname record (car name))
+ (bbdb-record-set-lastname record (cdr name))
+ (bbdb-record-set-mail record (list (cadr data)))
+ (delete-region (point-min) (point-max))))
+
+(defun bbdb-snarf-mail (record)
+ "Snarf mail addresses for RECORD.
+This uses the first subexpresion of `bbdb-snarf-mail-regexp'."
+ (let ((case-fold-search t) mails)
+ (while (re-search-forward bbdb-snarf-mail-regexp nil t)
+ (push (match-string 1) mails)
+ (replace-match ""))
+ (bbdb-record-set-mail record (nconc (bbdb-record-mail record) mails))))
+
+(defun bbdb-snarf-label (field)
+ "Extract the label before point, or return default label for FIELD."
+ (save-match-data
+ (if (looking-back "\\(?:^\\|[,:]\\)\\([^\n,:]+\\):[ \t]*"
+ (line-beginning-position))
+ (prog1 (match-string 1)
+ (delete-region (match-beginning 1) (match-end 0)))
+ (cdr (assq field bbdb-snarf-default-label-alist)))))
+
+(defun bbdb-snarf-phone-nanp (record)
+ "Snarf NANP phone numbers for RECORD.
+NANP is the North American Numbering Plan used in North and Central America.
+This uses the first subexpresion of `bbdb-snarf-phone-nanp-regexp'."
+ (let ((case-fold-search t) phones)
+ (while (re-search-forward bbdb-snarf-phone-nanp-regexp nil t)
+ (goto-char (match-beginning 0))
+ (if (save-match-data
+ (looking-back "[0-9A-Z]" nil)) ;; not really an NANP phone number
+ (goto-char (match-end 0))
+ (push (vconcat (list (bbdb-snarf-label 'phone))
+ (save-match-data
+ (bbdb-parse-phone (match-string 1))))
+ phones)
+ (replace-match "")))
+ (bbdb-record-set-phone record (nconc (bbdb-record-phone record)
+ (nreverse phones)))))
+
+(defun bbdb-snarf-phone-eu (record &optional phone-regexp)
+ "Snarf European phone numbers for RECORD.
+PHONE-REGEXP is the regexp to match a phone number.
+It defaults to `bbdb-snarf-phone-eu-regexp'."
+ (let ((case-fold-search t) phones)
+ (while (re-search-forward (or phone-regexp
+ bbdb-snarf-phone-eu-regexp) nil t)
+ (goto-char (match-beginning 0))
+ (push (vector (bbdb-snarf-label 'phone)
+ (match-string 1))
+ phones)
+ (replace-match ""))
+ (bbdb-record-set-phone record (nconc (bbdb-record-phone record)
+ (nreverse phones)))))
+
+(defun bbdb-snarf-streets (address)
+ "Snarf streets for ADDRESS. This assumes a narrowed region."
+ (bbdb-address-set-streets address (bbdb-split "\n" (buffer-string)))
+ (delete-region (point-min) (point-max)))
+
+(defun bbdb-snarf-address-us (record)
+ "Snarf a US address for RECORD."
+ (let ((address (make-vector bbdb-address-length nil)))
+ (cond ((re-search-forward bbdb-snarf-postcode-us-regexp nil t)
+ ;; Streets, City, State Postcode
+ (save-restriction
+ (narrow-to-region (point-min) (match-end 0))
+ ;; Postcode
+ (goto-char (match-beginning 0))
+ (bbdb-address-set-postcode address
+ (bbdb-parse-postcode (match-string 1)))
+ ;; State
+ (skip-chars-backward " \t")
+ (let ((pos (point)))
+ (skip-chars-backward "^ \t,")
+ (bbdb-address-set-state address (buffer-substring (point) pos)))
+ ;; City
+ (skip-chars-backward " \t,")
+ (let ((pos (point)))
+ (beginning-of-line)
+ (bbdb-address-set-city address (buffer-substring (point) pos)))
+ ;; Toss it
+ (forward-char -1)
+ (delete-region (point) (point-max))
+ ;; Streets
+ (goto-char (point-min))
+ (bbdb-snarf-streets address)))
+ ;; Try for just Streets, City, State
+ ((let (case-fold-search)
+ (re-search-forward "^\\(.*\\), \\([A-Z][A-Za-z]\\)$" nil t))
+ (bbdb-address-set-city address (match-string 1))
+ (bbdb-address-set-state address (match-string 2))
+ (replace-match "")
+ (save-restriction
+ (narrow-to-region (point-min) (match-beginning 0))
+ (goto-char (point-min))
+ (bbdb-snarf-streets address))))
+ (when (bbdb-address-city address)
+ (if bbdb-snarf-address-us-country
+ (bbdb-address-set-country address bbdb-snarf-address-us-country))
+ ;; Fixme: There are no labels anymore. `bbdb-snarf-streets' snarfed
+ ;; everything that was left!
+ (bbdb-address-set-label address (bbdb-snarf-label 'address))
+ (bbdb-record-set-address record
+ (nconc (bbdb-record-address record)
+ (list address))))))
+
+(defun bbdb-snarf-address-eu (record &optional postcode-regexp country)
+ "Snarf a European address for RECORD.
+POSTCODE-REGEXP is a regexp matching the postcode assumed to appear
+at the beginning of a line followed by the name of the city. This format
+is used in many continental European countries.
+POSTCODE-REGEXP defaults to `bbdb-snarf-postcode-eu-regexp'.
+COUNTRY is the country to use. It defaults to
`bbdb-snarf-address-eu-country'."
+ (when (re-search-forward (or postcode-regexp
+ bbdb-snarf-postcode-eu-regexp) nil t)
+ (let ((address (make-vector bbdb-address-length nil)))
+ (save-restriction
+ (goto-char (match-end 0))
+ (narrow-to-region (point-min) (line-end-position))
+ ;; Postcode
+ (bbdb-address-set-postcode address (match-string 1))
+ ;; City
+ (skip-chars-forward " \t")
+ (bbdb-address-set-city address (buffer-substring (point) (point-max)))
+ ;; Toss it
+ (delete-region (match-beginning 0) (point-max))
+ ;; Streets
+ (goto-char (point-min))
+ (bbdb-snarf-streets address))
+ (unless country (setq country bbdb-snarf-address-eu-country))
+ (if country (bbdb-address-set-country address country))
+ (bbdb-address-set-label address (bbdb-snarf-label 'address))
+ (bbdb-record-set-address record
+ (nconc (bbdb-record-address record)
+ (list address))))))
+
+(defun bbdb-snarf-url (record)
+ "Snarf URL for RECORD.
+This uses the first subexpresion of `bbdb-snarf-url-regexp'."
+ (when (and bbdb-snarf-url
+ (let ((case-fold-search t))
+ (re-search-forward bbdb-snarf-url-regexp nil t)))
+ (bbdb-record-set-xfields
+ record
+ (nconc (bbdb-record-xfields record)
+ (list (cons bbdb-snarf-url (match-string 1)))))
+ (replace-match "")))
+
+(defun bbdb-snarf-notes (record)
+ "Snarf notes for RECORD."
+ (when (/= (point-min) (point-max))
+ (bbdb-record-set-xfields
+ record
+ (nconc (bbdb-record-xfields record)
+ (list (cons bbdb-default-xfield (buffer-string)))))
+ (erase-buffer)))
+
+(defsubst bbdb-snarf-rule-interactive ()
+ "Read snarf rule interactively."
+ (intern
+ (completing-read
+ (format "Rule: (default `%s') " bbdb-snarf-rule-default)
+ bbdb-snarf-rule-alist nil t nil nil
+ (symbol-name bbdb-snarf-rule-default))))
+
+;;;###autoload
+(defun bbdb-snarf-paragraph (pos &optional rule)
+ "Snarf BBDB record from paragraph around position POS using RULE.
+The paragraph is the one that contains POS or follows POS.
+Interactively POS is the position of point.
+RULE defaults to `bbdb-snarf-rule-default'.
+See `bbdb-snarf-rule-alist' for details."
+ (interactive (list (point) (bbdb-snarf-rule-interactive)))
+ (bbdb-snarf (save-excursion
+ (goto-char pos)
+ ;; similar to `mark-paragraph'
+ (let ((end (progn (forward-paragraph 1) (point))))
+ (buffer-substring-no-properties
+ (progn (backward-paragraph 1) (point))
+ end)))
+ rule))
+
+;;;###autoload
+(defun bbdb-snarf-yank (&optional rule)
+ "Snarf a BBDB record from latest kill using RULE.
+The latest kill may also be a window system selection, see `current-kill'.
+RULE defaults to `bbdb-snarf-rule-default'.
+See `bbdb-snarf-rule-alist' for details."
+ (interactive (list (bbdb-snarf-rule-interactive)))
+ (bbdb-snarf (current-kill 0) rule))
+
+;;;###autoload
+(defun bbdb-snarf (string &optional rule)
+ "Snarf a BBDB record in STRING using RULE. Display and return this record.
+Interactively, STRING is the current region.
+RULE defaults to `bbdb-snarf-rule-default'.
+See `bbdb-snarf-rule-alist' for details."
+ (interactive
+ (list (buffer-substring-no-properties (region-beginning) (region-end))
+ (bbdb-snarf-rule-interactive)))
+
+ (bbdb-editable)
+ (let ((record (bbdb-empty-record)))
+ (with-current-buffer (get-buffer-create " *BBDB Snarf*")
+ (erase-buffer)
+ (insert (substring-no-properties string))
+ (mapc (lambda (fun)
+ (goto-char (point-min))
+ (funcall fun record))
+ (cdr (assq (or rule bbdb-snarf-rule-default)
+ bbdb-snarf-rule-alist))))
+ (let ((old-record (car (bbdb-message-search
+ (bbdb-concat 'name-first-last
+ (bbdb-record-firstname record)
+ (bbdb-record-lastname record))
+ (car (bbdb-record-mail record))))))
+ ;; Install RECORD after searching for OLD-RECORD
+ (bbdb-change-record record)
+ (if old-record (bbdb-merge-records old-record record)))
+ (bbdb-display-records (list record))
+ record))
+
+;; Some test cases
+;;
+;; US:
+;;
+;; another test person
+;; 1234 Gridley St.
+;; Los Angeles, CA 91342
+;; 555-1212
+;; address@hidden
+;; http://www.foo.bar/
+;; other stuff about this person
+;;
+;; test person
+;; 1234 Gridley St.
+;; St. Los Angeles, CA 91342-1234
+;; 555-1212
+;; <address@hidden>
+;;
+;; x test person
+;; 1234 Gridley St.
+;; Los Angeles, California 91342-1234
+;; work: 555-1212
+;; home: 555-1213
+;; address@hidden
+;;
+;; y test person
+;; 1234 Gridley St.
+;; Los Angeles, CA
+;; 555-1212
+;; address@hidden
+;;
+;; z test person
+;; 555-1212
+;; address@hidden
+;;
+;; EU:
+;;
+;; Maja Musterfrau
+;; Strasse 15
+;; 12345 Ort
+;; +49 12345
+;; phon: (110) 123 456
+;; mobile: (123) 456 789
+;; address@hidden
+;; http://www.xxx.xx
+;; notes bla bla bla
+
+(provide 'bbdb-snarf)
+
+;;; bbdb-snarf.el ends here
diff --git a/lisp/bbdb/bbdb-tex.el b/lisp/bbdb/bbdb-tex.el
new file mode 100644
index 0000000..f1984be
--- /dev/null
+++ b/lisp/bbdb/bbdb-tex.el
@@ -0,0 +1,570 @@
+;;; bbdb-tex.el --- feed BBDB into LaTeX -*- lexical-binding: t -*-
+
+;; Copyright (C) 2010-2017 Free Software Foundation, Inc.
+
+;; Authors: Boris Goldowsky <address@hidden>
+;; Dirk Grunwald <address@hidden>
+;; Luigi Semenzato <address@hidden>
+
+;; This file is part of the Insidious Big Brother Database (aka BBDB),
+
+;; BBDB 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 3 of the License, 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 BBDB. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; This file lets you feed BBDB into LaTeX.
+;; See the BBDB info manual for documentation.
+;;
+;; In the *BBDB* buffer, type M-x `bbdb-tex' to convert the listing
+;; to LaTeX format.
+;;
+;; TeX macros appearing in the output:
+;; \name{first}{last}
+;; \organization{foo bar}
+;; \affix{foo bar}
+;; \aka{foo bar}
+;; \phone{key}{123 456 7890}
+;; \address{key}{foo bar}
+;; address@hidden <address@hidden>}
+;; \xfield{key}{value}
+;; Each macro may appear multiple times.
+;;
+;; The detailed grammar of the output is defined in `bbdb-tex-alist'.
+;; The output starts with a prolog where you can specify LaTeX packages
+;; and other customizations in the usual way. The above macros should get
+;; defined, too. By default, this happens in the style file bbdb.sty that
+;; is shipped with BBDB.
+;;
+;; The body of the output contains the BBDB records. Usually, the records
+;; are placed inside some "bbdb" environment. You can customize which fields
+;; of each record should appear in the listing and in which order.
+;; Also, you can put separators between individual fields. A separator macro
+;; can also separate records when the first character of the last name differs
+;; from the first character of the last name of the previous record.
+;; The listing ends with an epilog.
+
+;; A few notes on "advanced usage" of `bbdb-tex':
+;;
+;; It should be possible to use `bbdb-tex' with all the bells and whistles
+;; of LaTeX by loading the appropriate LaTeX style files and packages or
+;; embedding the output of `bbdb-tex' into more complex LaTeX documents.
+;; For this you can customize the rules in `bbdb-tex-alist' and use
+;; customized style files for interpreting the TeX macros used by `bbdb-tex'.
+;;
+;; Generally, lisp customizations for `bbdb-tex' are intended to provide
control
+;; of *what* appears in the TeX listing. But there are no lisp customization
+;; options to control the actual layout that should be handled by LaTeX.
+;; BBDB is shipped with one basic LaTeX style file bbdb.sty to handle
+;; the TeX macros listed above. You should customize this LaTeX style file
+;; to match your taste and / or your needs. Note also that `bbdb-tex-alist'
+;; allows you to specify an arbitrary number of rules that may use different
+;; style files for the above TeX macros.
+
+;; Generally, it will be advantageous to make all relevant style files
+;; and packages known to LaTeX by putting them in the appropriate directories
+;; of your TeX installation. Likely, the user variable `bbdb-tex-path'
+;; should not be used in such advanced cases. The main purpose of the
+;; inlining mechanism provided via `bbdb-tex-path' is that we can ship
+;; and install BBDB without worrying about the tricky question where to
+;; (auto-) install the basic style file bbdb.sty shipped with BBDB so that
+;; TeX finds it. Most often, it will be best to manually install even bbdb.sty
+;; in a directory where TeX finds it and bind `bbdb-tex-path' to t to fully
+;; suppress the inlining.
+;;
+;; Before generating the TeX output, the field values of a record are massaged
+;; by `bbdb-tex-field' that passes these values by default to
`bbdb-tex-replace',
+;; see also `bbdb-tex-replace-list'. Instead the user may also define
functions
+;; `bbdb-tex-output-...' that take precedence, see `bbdb-tex-field'.
+;;
+;; `bbdb-tex' understands one new BBDB xfield: tex-name, see also
+;; `bbdb-tex-name'. If this xfield is defined for a record,
+;; this will be used for the TeXed listing instead of the name field
+;; of that record. The value of the xfield tex-name is used verbatim,
+;; it does not see `bbdb-tex-field' and `bbdb-tex-replace-list'.
+;;
+;;
+;; This program was adapted for BBDB by Boris Goldowsky
+;; <address@hidden> and Dirk Grunwald
+;; <address@hidden> using a TeX format designed by Luigi
+;; Semenzato <address@hidden>.
+;; We are also grateful to numerous people on the bbdb-info
+;; mailing list for suggestions and bug reports.
+
+;;; Code:
+
+(require 'bbdb)
+(require 'bbdb-com)
+
+;;; Variables:
+
+(defcustom bbdb-tex-name 'tex-name
+ "Xfield holding the name in TeX format.
+The string in this field gets split into first and last name
+using `bbdb-separator-alist'. The separator defaults to \"#\"."
+ :group 'bbdb-utilities-tex
+ :type '(symbol :tag "Xfield"))
+
+(defcustom bbdb-tex-alist
+ `((multi-line
+ (demand (or address phone))
+ (prolog ,(concat "\\documentclass{article}\n\\usepackage{bbdb}\n"
+ "\\usepackage{multicol}\n"
+ "\\begin{document}\n\\begin{multicols}{2}"))
+ (record "\\begin{bbdbrecord}" name organization ; affix aka
+ (address t) (phone t) (mail t)
+ (xfields t nil
+ (omit ,bbdb-tex-name mail-alias creation-date timestamp))
+ "\\end{bbdbrecord}\n")
+ (separator "\\bbdbseparator{%s}\n")
+ (epilog ,(concat "\\noindent\\hrulefill\\\\\nPrinted \\today\n"
+ "\\end{multicols}\n\\end{document}"))
+ (options (bbdb-tex-linebreak "\\\\\\\\\n")
+ (bbdb-tex-address-layout 2)))
+
+ (one-line
+ (demand phone)
+ (prolog ,(concat "\\documentclass{article}\n\\usepackage{bbdb}\n"
+ "\\begin{document}\n\\begin{bbdb}{llllll}"))
+ (record name "&" (organization 1) "&" (phone 2 "&") "&" (mail 1)
+ "&" (address 1) "\\\\")
+ (separator "\\bbdbseparator{%s}")
+ (epilog "\\end{bbdb}\n\\end{document}")
+ (options (bbdb-tex-linebreak ", ")
+ (bbdb-tex-address-layout 3)))
+
+ (phone
+ (demand phone)
+ (prolog ,(concat "\\documentclass{article}\n\\usepackage{bbdb}\n"
+ "\\begin{document}\n\\begin{bbdb}{ll}"))
+ (record name "&" (phone 2 "&") "\\\\")
+ (separator "\\bbdbseparator{%s}")
+ (epilog "\\end{bbdb}\n\\end{document}")
+ (options (bbdb-tex-linebreak ", ")
+ (bbdb-tex-address-layout 3)))
+
+ (example ; another rule with more examples
+ (demand (or address phone))
+ (prolog ,(concat "\\documentclass{article}\n\\usepackage{bbdb}\n"
+ "\\usepackage{multicol}\n"
+ "\\begin{document}\n\\begin{multicols}{2}"))
+ (record "\\begin{bbdbrecord}" name organization
+ (address 1 nil (omit "work"))
+ (phone 2 nil (admit "home" "cell"))
+ (mail t)
+ (birthday t)
+ (xfields t nil
+ (omit ,bbdb-tex-name mail-alias creation-date timestamp))
+ "\\end{bbdbrecord}\n")
+ (separator "\\bbdbseparator{%s}\n")
+ (epilog ,(concat "\\noindent\\hrulefill\\\\\nPrinted \\today\n"
+ "\\end{multicols}\n\\end{document}"))
+ (options (bbdb-tex-linebreak "\\\\\\\\\n")
+ (bbdb-tex-address-layout 2))))
+
+ "Alist of rules for passing BBDB to LaTeX.
+Each rule has the form (RULE LIST1 LIST2 ...).
+The symbol RULE identifies the rule.
+The remainder are lists LIST that should have one of these forms:
+
+ (demand FORM)
+
+ Here FORM is a lisp expression. A record will be TeXed only
+ if evaluating FORM yields a non-nil value for this record.
+ When FORM is evaluated, the symbols name, affix, organization, mail,
+ phone, address, and xfields are set to the corresponding values
+ of this record; these symbols are nil if the respective field
+ does not exist for this record.
+
+ (prolog STRING)
+
+ The string STRING is inserted at the beginning of the buffer.
+ If STRING contains the substring \"\\usepackage{foo}\" and
+ a file \"foo.sty\" exists within `bbdb-tex-path', replace
+ \"\\usepackage{foo}\" with the content of the file \"foo.sty\",
+ surrounded by \"\\makeatletter\" and \"\\makeatother\".
+ Note: This fails with more sophisticated LaTeX style files
+ using, e.g., optional arguments for the \"\\usepackage\" macro.
+
+ (record ELT1 ELT2 ...)
+
+ Here ELT may be one of the following:
+
+ IF ELT is name, this expands to \"\\name{first}{last}\"
+
+ If ELT is affix, organization, or aka, ELT expands to \"\\ELT{value}\".
+ Here the elements of ELT are concatenated to get one value.
+
+ If ELT is the key of an xfield, ELT expands to \"\\xfield{ELT}{value}\".
+
+ If ELT is a string, this is inserted \"as is\" in the TeX buffer.
+
+ ELT may also be a loop (FLD COUNT [SEPARATOR] [OPT...])
+ looping over the values of FLD.
+
+ If FLD is mail, this expands to \"\\mail{short}{long}\",
+ such as \"address@hidden <address@hidden>}\",
+ If FLD is phone, this expands to \"\\phone{key}{number}\"
+ If FLD is address, this expands to \"\\address{key}{value}\".
+ If FLD is xfields, this expands to \"\\xfield{key}{value}\".
+ If FLD is the key of an xfield, split the value of FLD
+ using `bbdb-separator-alist' to generate a list of values,
+ which then expand to \"\\xfield{FLD}{value}\".
+
+ If COUNT is a number, process at most COUNT values of FLD.
+ IF COUNT is t, process all values of FLD.
+
+ If SEPARATOR is non-nil, it is a string that is inserted between
+ the values of FLD. Insert COUNT - 1 instances of SEPARATOR,
+ even if there are fewer values of FLD.
+
+ If FLD is mail, phone, address, or xfields,
+ OPT may be a list (admit KEY ...) or (omit KEY ...).
+ Then a value is admitted or omitted if its key KEY is listed here.
+
+ (separator STRING)
+
+ When the first letter of the records' sortkey increases compared with
+ the previous record in the TeX listing, the new letter is formatted
+ using the format string STRING to generate a separator macro.
+
+ (epilog STRING)
+
+ The string STRING is inserted at the end of the buffer."
+ :group 'bbdb-utilities-tex)
+
+(defcustom bbdb-tex-rule-default 'multi-line
+ "Default rule for BBDB tex.
+This symbol should be a key in `bbdb-tex-alist'."
+ :group 'bbdb-utilities-tex
+ :type '(symbol :tag "rule"))
+
+;; FIXME
+;; (defcustom bbdb-tex-empty-fields nil
+;; "If non-nil generate TeX output even for empty fields."
+;; :group 'bbdb-utilities-tex)
+
+(defcustom bbdb-tex-replace-list
+ '(("[#$%&_]" . "\\\\\\&")
+ ("<" . "\\\\textless ")
+ (">" . "\\\\textgreater ")
+ ("~" . "\\\\textasciitilde ")
+ ("{" . "\\\\textbraceleft ")
+ ("}" . "\\\\textbraceright "))
+ "Replacement list for TeX's special characters.
+Each element is of the form (REGEXP . REPLACE)."
+ :group 'bbdb-utilities-tex
+ :type '(repeat (cons regexp string)))
+
+(defcustom bbdb-tex-linebreak "\\\\\\\\\n"
+ "Replacement for linebreaks."
+ :group 'bbdb-utilities-tex
+ :type 'string)
+
+(defcustom bbdb-tex-address-format-list bbdb-address-format-list
+ "List of address formatting rules for `bbdb-tex'.
+Each element may take the same values as in `bbdb-address-format-list'.
+The elements EDIT of `bbdb-address-format-list' are ignored."
+ :group 'bbdb-utilities-tex
+ :type '(repeat (list (choice (const :tag "Default" t)
+ (function :tag "Function")
+ (repeat (string)))
+ (choice (string)
+ (function :tag "Function"))
+ (choice (string)
+ (function :tag "Function"))
+ (choice (string)
+ (function :tag "Function")))))
+
+(defcustom bbdb-tex-address-layout 2
+ "Address layout according to `bbdb-tex-address-format-list'.
+2 is multi-line layout, 3 is one-line layout."
+ :group 'bbdb-utilities-tex)
+
+(defcustom bbdb-tex-file "~/bbdb.tex"
+ "Default file name for TeXing BBDB."
+ :group 'bbdb-utilities-tex
+ :type 'file)
+
+(defcustom bbdb-tex-path
+ (let ((d (if load-file-name
+ (expand-file-name "tex/" (file-name-directory load-file-name))
+ (let ((f (locate-file "tex/bbdb.sty" load-path)))
+ (if f (file-name-directory f))))))
+ (if d (list d)))
+ "List of directories with the BBDB TeX files.
+If this is t assume that these files reside in directories
+that are part of the regular TeX search path"
+ :group 'bbdb-utilities-tex
+ :type '(choice (const :tag "Files in TeX path" t)
+ (repeat (directory :tag "Directory"))))
+
+;;; Internal variables
+
+(defvar bbdb-tex-rule-last bbdb-tex-rule-default
+ "Last rule used for TeXing BBDB.")
+
+(defvar bbdb-tex-file-last bbdb-tex-file
+ "Last used TeX file")
+
+;;; Functions:
+
+;; While we use `bbdb-tex-replace' only once in `bbdb-tex-field',
+;; we keep it as a separate function so that it can also be used
+;; inside user-defined functions `bbdb-tex-output-...'.
+(defun bbdb-tex-replace (string)
+ "Apply replacement rules `bbdb-tex-replace-list' to STRING.
+Also, replace linebreaks by `bbdb-tex-linebreak'."
+ (if (not string)
+ ""
+ (dolist (elt bbdb-tex-replace-list)
+ (setq string (replace-regexp-in-string (car elt) (cdr elt) string)))
+ (replace-regexp-in-string "\n" bbdb-tex-linebreak string)))
+
+(defun bbdb-tex-field (field str)
+ "Massage string STR for LaTeX.
+By default, STR is passed to `bbdb-tex-replace'.
+The user may also define a function `bbdb-tex-output-FIELD'
+that takes precedence."
+ (let ((fun (intern-soft (format "bbdb-tex-output-%s" field))))
+ (if fun
+ (funcall fun str)
+ (bbdb-tex-replace str))))
+
+(defun bbdb-tex-list (list rule fun)
+ "Use function FUN to generate output for LIST according to RULE.
+LIST is a list of field values such as a list of addresses.
+RULE is an element of a record list as in `bbdb-tex-alist'
+used to select the elements of LIST that get processed by calling FUN."
+ (let ((admit (cdr (assq 'admit rule)))
+ (omit (cdr (assq 'omit rule)))
+ (num (if (numberp (nth 1 rule)) (nth 1 rule)))
+ (sep (if (nth 2 rule) (concat (nth 2 rule) "\n")))
+ (i -1)
+ new-list elt)
+
+ ;; Select the relevant elements of LIST.
+ (cond (admit
+ (dolist (l list)
+ (if (member (elt l 0) admit)
+ (push l new-list)))
+ (setq new-list (nreverse new-list)))
+
+ (omit
+ (dolist (l list)
+ (unless (member (elt l 0) omit)
+ (push l new-list)))
+ (setq new-list (nreverse new-list)))
+
+ (t
+ (setq new-list list)))
+
+ (cond ((not num)
+ (insert (mapconcat fun new-list (or sep ""))))
+ ((not sep)
+ (while (and (< (setq i (1+ i)) num)
+ (setq elt (pop new-list)))
+ (insert (funcall fun elt))))
+ (t
+ (while (< (setq i (1+ i)) num)
+ (if (setq elt (pop new-list))
+ (insert (funcall fun elt)))
+ (if (< (1+ i) num)
+ (insert sep)))))))
+
+;;;###autoload
+(defun bbdb-tex (records file rule)
+ "Generate FILE for TeXing RECORDS.
+Interactively, use BBDB prefix \
+\\<bbdb-mode-map>\\[bbdb-do-all-records], see `bbdb-do-all-records'.
+RULE should be an element of `bbdb-tex-alist'."
+ (interactive
+ (list (bbdb-do-records)
+ (read-file-name
+ (format "TeX file: (default %s) "
+ (abbreviate-file-name bbdb-tex-file-last))
+ (file-name-directory bbdb-tex-file-last)
+ bbdb-tex-file-last)
+ (intern (completing-read (format "Rule: (default %s) "
+ bbdb-tex-rule-last)
+ bbdb-tex-alist nil t
+ nil nil (symbol-name bbdb-tex-rule-last)))))
+ ;; Remember our choice for `bbdb-tex-file-last'.
+ (setq bbdb-tex-file-last (expand-file-name file))
+
+ (find-file bbdb-tex-file-last)
+ (let* ((buffer-undo-list t)
+ (rule (assq rule bbdb-tex-alist))
+ (demand (nth 1 (assq 'demand rule)))
+ (separator (nth 1 (assq 'separator rule)))
+ current-letter p-symbols p-values)
+ (erase-buffer)
+
+ ;; Options
+ (dolist (option (cdr (assq 'options rule)))
+ (push (car option) p-symbols)
+ (push (cadr option) p-values))
+ (cl-progv p-symbols p-values
+
+ ;; Prolog
+ (let ((prolog (nth 1 (assq 'prolog rule))))
+ (when prolog
+ (insert prolog)
+ (when (consp bbdb-tex-path)
+ (goto-char (point-min))
+ (while (re-search-forward "\\\\usepackage[ \t\n]*{\\([^}]+\\)}"
nil t)
+ (let ((sty (locate-file (match-string 1) bbdb-tex-path
'(".sty"))))
+ (when sty
+ (replace-match (format "\n\\\\makeatletter\n%% begin %s\n%%
end %s\n\\\\makeatother\n" sty sty))
+ (save-excursion
+ (forward-line -2)
+ (insert-file-contents sty))))))
+ (goto-char (point-max))
+ (unless (bolp) (insert "\n"))
+ (insert "% end BBDB prolog\n")))
+
+ ;; Process Records
+ (dolist (record (bbdb-record-list records))
+ (let* ((first-letter
+ (substring (bbdb-record-sortkey record) 0 1))
+ (firstname (bbdb-record-firstname record))
+ (lastname (bbdb-record-lastname record))
+ (name (bbdb-record-name record))
+ (name-lf (bbdb-record-name-lf record))
+ (organization (bbdb-record-organization record))
+ (affix (bbdb-record-affix record))
+ (aka (bbdb-record-aka record))
+ (mail (bbdb-record-mail record))
+ (phone (bbdb-record-phone record))
+ (address (bbdb-record-address record))
+ (xfields (bbdb-record-xfields record))
+ (lex-env `((firstname . ,firstname) (lastname . ,lastname)
+ (name . ,name) (name-lf . ,name-lf) (aka . ,aka)
+ (organization . ,organization) (affix . ,affix)
+ (mail . ,mail) (phone . ,phone)
+ (address . ,address) (xfields . ,xfields)))
+ (bbdb-address-format-list bbdb-tex-address-format-list))
+
+ ;; A record is processed only if the form DEMAND
+ ;; evaluates to a non-nil value.
+ (when (or (not demand)
+ (eval demand lex-env))
+
+ ;; Separator
+ (if (and separator
+ (not (and current-letter
+ (equal first-letter current-letter))))
+ (insert (format separator (upcase first-letter)) "\n"))
+ (setq current-letter first-letter)
+
+ (dolist (elt (cdr (assq 'record rule)))
+ (cond ((stringp elt)
+ (insert elt "\n"))
+
+ ((eq elt 'name) ; name of record
+ (let ((tex-name (and bbdb-tex-name
+ (bbdb-record-field record
bbdb-tex-name)))
+ (fmt "\\name{%s}{%s}\n"))
+ (if tex-name
+ (let ((first-last (bbdb-split bbdb-tex-name
tex-name)))
+ (cond ((eq 2 (length first-last))
+ (insert (format fmt (car first-last) (cadr
first-last))))
+ ((eq 1 (length first-last))
+ (insert (format fmt "" (car first-last))))
+ (t (error "TeX name %s cannot be split"
tex-name))))
+ (insert (format fmt
+ (bbdb-tex-field 'firstname firstname)
+ (bbdb-tex-field 'lastname
lastname))))))
+
+ ;; organization, affix or aka as single string
+ ((memq elt '(organization affix aka))
+ (let ((val (bbdb-record-field record elt)))
+ (if val
+ (insert (format "\\%s{%s}\n" elt
+ (bbdb-tex-field elt (bbdb-concat
elt val)))))))
+
+ ;; organization, affix or aka as list of strings
+ ((memq (car elt) '(organization affix aka))
+ (bbdb-tex-list
+ (bbdb-record-field record (car elt))
+ elt
+ `(lambda (o)
+ (format "\\%s{%s}\n" ',(car elt)
+ (bbdb-tex-field ',(car elt) o)))))
+
+ ((eq (car elt) 'mail) ; mail
+ (bbdb-tex-list
+ mail elt
+ (lambda (m)
+ (format "\\mail{%s}{%s}\n"
+ ;; No processing of plain mail address
+ (nth 1 (bbdb-decompose-bbdb-address m))
+ (bbdb-tex-field 'mail m)))))
+
+ ((eq (car elt) 'address) ; address
+ (bbdb-tex-list
+ address elt
+ (lambda (a)
+ (format "\\address{%s}{%s}\n"
+ (bbdb-tex-field 'address-label
(bbdb-address-label a))
+ (bbdb-tex-field 'address (bbdb-format-address
+ a
bbdb-tex-address-layout))))))
+
+ ((eq (car elt) 'phone) ; phone
+ (bbdb-tex-list
+ phone elt
+ (lambda (p)
+ (format "\\phone{%s}{%s}\n"
+ (bbdb-tex-field 'phone-label (bbdb-phone-label
p))
+ (bbdb-tex-field 'phone (bbdb-phone-string
p))))))
+
+ ((eq (car elt) 'xfields) ; list of xfields
+ (bbdb-tex-list
+ (bbdb-record-field record 'xfields)
+ elt
+ (lambda (x)
+ (format "\\xfield{%s}{%s}\n"
+ (bbdb-tex-field 'xfield-label (symbol-name
(car x)))
+ (bbdb-tex-field 'xfield (cdr x))))))
+
+ ((symbolp elt) ; xfield as single string
+ ;; The value of an xfield may be a sexp instead of a
string.
+ ;; Ideally, a sexp should be formatted by `pp-to-string',
+ ;; then printed verbatim.
+ (let ((val (format "%s" (bbdb-record-field record elt))))
+ (if val
+ (insert (format "\\xfield{%s}{%s}\n" elt
+ (bbdb-tex-field elt (bbdb-concat
elt val)))))))
+
+ ((consp elt) ; xfield as list of strings
+ (bbdb-tex-list
+ (bbdb-split (car elt)
+ (format "%s" (bbdb-record-field record (car
elt))))
+ elt
+ `(lambda (x)
+ (format "\\xfield{%s}{%s}\n" ',(car elt)
+ (bbdb-tex-field ',(car elt) x)))))
+
+ (t (error "Rule `%s' undefined" elt)))))))
+
+ ;; Epilog
+ (let ((epilog (nth 1 (assq 'epilog rule))))
+ (when epilog
+ (insert "% begin BBDB epilog\n" epilog)
+ (unless (bolp) (insert "\n"))))))
+ (setq buffer-undo-list nil)
+ (save-buffer))
+
+(provide 'bbdb-tex)
+
+;;; bbdb-tex.el ends here
diff --git a/lisp/bbdb/bbdb-wl.el b/lisp/bbdb/bbdb-wl.el
new file mode 100644
index 0000000..e24b8af
--- /dev/null
+++ b/lisp/bbdb/bbdb-wl.el
@@ -0,0 +1,53 @@
+;;; bbdb-wl.el --- BBDB interface to Wanderlust -*- lexical-binding: t -*-
+
+;; Copyright (C) 2015-2017 Free Software Foundation, Inc.
+
+;; This file is part of the Insidious Big Brother Database (aka BBDB),
+
+;; BBDB 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 3 of the License, 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 BBDB. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;; This file contains the BBDB interface to Wl.
+;; See the BBDB info manual for documentation.
+
+;;; Code:
+
+(require 'bbdb)
+(require 'bbdb-mua)
+
+(defvar wl-summary-mode-map)
+(defvar wl-draft-mode-map)
+(defvar wl-summary-buffer-elmo-folder)
+(declare-function wl-summary-message-number "wl-summary")
+(declare-function elmo-message-entity "elmo-msgdb")
+(declare-function elmo-message-entity-field "elmo-msgdb")
+
+(defun bbdb/wl-header (header)
+ (elmo-message-entity-field
+ (elmo-message-entity wl-summary-buffer-elmo-folder
+ (wl-summary-message-number))
+ (intern (downcase header)) 'string))
+
+;;;###autoload
+(defun bbdb-insinuate-wl ()
+ "Hook BBDB into Wanderlust."
+ (define-key wl-summary-mode-map (kbd ":") #'bbdb-mua-display-sender)
+ (define-key wl-summary-mode-map (kbd ";") #'bbdb-mua-edit-field-sender)
+ (when bbdb-complete-mail
+ (define-key wl-draft-mode-map (kbd "M-;") #'bbdb-complete-mail)
+ (define-key wl-draft-mode-map (kbd "M-<tab>") #'bbdb-complete-mail)))
+
+(provide 'bbdb-wl)
+
+;;; bbdb-wl.el ends here
diff --git a/lisp/bbdb/bbdb.el b/lisp/bbdb/bbdb.el
new file mode 100644
index 0000000..2c49e3c
--- /dev/null
+++ b/lisp/bbdb/bbdb.el
@@ -0,0 +1,4730 @@
+;;; bbdb.el --- core of BBDB -*- lexical-binding: t -*-
+
+;; Copyright (C) 2010-2017 Free Software Foundation, Inc.
+
+;; Version: 0
+;; Package-Requires: ((emacs "24"))
+
+;; This file is part of the Insidious Big Brother Database (aka BBDB),
+
+;; BBDB 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 3 of the License, 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 BBDB. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; This file is the core of the Insidious Big Brother Database (aka BBDB),
+;; See the BBDB info manual for documentation.
+;;
+;; -----------------------------------------------------------------------
+;; | There is a mailing list for discussion of BBDB: |
+;; | address@hidden |
+;; | To join, go to https://lists.nongnu.org/mailman/listinfo/bbdb-user |
+;; | |
+;; | When joining this list or reporting bugs, please mention which |
+;; | version of BBDB you have. |
+;; -----------------------------------------------------------------------
+
+;;; Code:
+
+(require 'timezone)
+
+;; When running BBDB, we have (require 'bbdb-autoloads)
+(declare-function widget-group-match "wid-edit")
+(declare-function bbdb-migrate "bbdb-migrate")
+(declare-function bbdb-do-records "bbdb-com")
+(declare-function bbdb-append-display-p "bbdb-com")
+(declare-function bbdb-toggle-records-layout "bbdb-com")
+(declare-function bbdb-dwim-mail "bbdb-com")
+(declare-function bbdb-layout-prefix "bbdb-com")
+(declare-function bbdb-completing-read-records "bbdb-com")
+(declare-function bbdb-merge-records "bbdb-com")
+(declare-function mail-position-on-field "sendmail")
+(declare-function vm-select-folder-buffer "vm-folder")
+
+;; cannot use autoload for variables...
+(defvar message-mode-map) ;; message.el
+(defvar mail-mode-map) ;; sendmail.el
+(defvar gnus-article-buffer) ;; gnus-art.el
+
+;; Custom groups
+
+(defgroup bbdb nil
+ "The Insidious Big Brother Database."
+ :group 'news
+ :group 'mail)
+
+(defgroup bbdb-record-display nil
+ "Variables that affect the display of BBDB records"
+ :group 'bbdb)
+
+(defgroup bbdb-record-edit nil
+ "Variables that affect the editing of BBDB records"
+ :group 'bbdb)
+
+(defgroup bbdb-sendmail nil
+ "Variables that affect sending mail."
+ :group 'bbdb)
+
+(defgroup bbdb-mua nil
+ "Variables that specify the BBDB-MUA interface"
+ :group 'bbdb)
+
+(defgroup bbdb-mua-gnus nil
+ "Gnus-specific BBDB customizations"
+ :group 'bbdb-mua)
+(put 'bbdb-mua-gnus 'custom-loads '(bbdb-gnus))
+
+(defgroup bbdb-mua-gnus-scoring nil
+ "Gnus-specific scoring BBDB customizations"
+ :group 'bbdb-mua-gnus)
+(put 'bbdb-mua-gnus-scoring 'custom-loads '(bbdb-gnus))
+
+(defgroup bbdb-mua-gnus-splitting nil
+ "Gnus-specific splitting BBDB customizations"
+ :group 'bbdb-mua-gnus)
+(put 'bbdb-mua-gnus-splitting 'custom-loads '(bbdb-gnus))
+
+(defgroup bbdb-mua-vm nil
+ "VM-specific BBDB customizations"
+ :group 'bbdb-mua)
+(put 'bbdb-mua-vm 'custom-loads '(bbdb-vm))
+
+(defgroup bbdb-mua-message nil
+ "Message-specific BBDB customizations"
+ :group 'bbdb-mua)
+(put 'bbdb-mua-message 'custom-loads '(bbdb-message))
+
+(defgroup bbdb-utilities nil
+ "Customizations for BBDB Utilities"
+ :group 'bbdb)
+
+(defgroup bbdb-utilities-dialing nil
+ "BBDB Customizations for phone number dialing"
+ :group 'bbdb)
+
+(defgroup bbdb-utilities-tex nil
+ "Customizations for TeXing BBDB."
+ :group 'bbdb)
+(put 'bbdb-utilities-tex 'custom-loads '(bbdb-tex))
+
+(defgroup bbdb-utilities-anniv nil
+ "Customizations for BBDB Anniversaries"
+ :group 'bbdb-utilities)
+(put 'bbdb-utilities-anniv 'custom-loads '(bbdb-anniv))
+
+(defgroup bbdb-utilities-ispell nil
+ "Customizations for BBDB ispell interface"
+ :group 'bbdb-utilities)
+(put 'bbdb-utilities-ispell 'custom-loads '(bbdb-ispell))
+
+(defgroup bbdb-utilities-snarf nil
+ "Customizations for BBDB snarf"
+ :group 'bbdb-utilities)
+(put 'bbdb-utilities-snarf 'custom-loads '(bbdb-snarf))
+
+(defgroup bbdb-utilities-pgp nil
+ "Customizations for BBDB pgp"
+ :group 'bbdb-utilities)
+(put 'bbdb-utilities-pgp 'custom-loads '(bbdb-pgp))
+
+(defgroup bbdb-utilities-sc nil
+ "Customizations for using Supercite with the BBDB."
+ :group 'bbdb-utilities
+ :prefix "bbdb-sc")
+(put 'bbdb-utilities-sc 'custom-loads '(bbdb-sc))
+
+;;; Customizable variables
+(defcustom bbdb-file (locate-user-emacs-file "bbdb" ".bbdb")
+ "The name of the Insidious Big Brother Database file."
+ :group 'bbdb
+ :type 'file)
+
+;; This should be removed, and the following put in place:
+;; a hierarchical structure of bbdb files, some perhaps read-only,
+;; perhaps caching in the local bbdb. This way one could have, e.g. an
+;; organization address book, with each person having access to it, and
+;; then a local address book with personal stuff in it.
+(defcustom bbdb-file-remote nil
+ "The remote file to save the BBDB database to.
+When this is non-nil, it should be a file name.
+When BBDB reads `bbdb-file', it also checks this file,
+and if it is newer than `bbdb-file', it loads this file.
+When BBDB writes `bbdb-file', it also writes this file.
+
+This feature allows one to keep the database in one place while using
+different computers, thus reducing the need for merging different files."
+ :group 'bbdb
+ :type '(choice (const :tag "none" nil)
+ (file :tag "remote file name")))
+
+(defcustom bbdb-file-remote-save-always t
+ "If t `bbdb-file-remote' is saved automatically when `bbdb-file' is saved.
+When nil, ask."
+ :group 'bbdb
+ :type 'boolean)
+
+(defcustom bbdb-read-only nil
+ "If t then BBDB will not modify `bbdb-file'.
+If you have more than one Emacs running at the same time, you might want
+to set this to t in all but one of them."
+ :group 'bbdb
+ :type '(choice (const :tag "Database is read-only" t)
+ (const :tag "Database is writable" nil)))
+
+(defcustom bbdb-auto-revert nil
+ "If t revert unchanged database without querying.
+If t and `bbdb-file' has changed on disk, while the database
+has not been modified inside Emacs, revert the database automatically.
+If nil or the database has been changed inside Emacs, always query
+before reverting."
+ :group 'bbdb
+ :type '(choice (const :tag "Revert unchanged database without querying" t)
+ (const :tag "Ask before reverting database" nil)))
+
+(defcustom bbdb-check-auto-save-file nil
+ "If t BBDB will check its auto-save file.
+If this file is newer than `bbdb-file', BBDB will offer to revert."
+ :group 'bbdb
+ :type '(choice (const :tag "Check auto-save file" t)
+ (const :tag "Do not check auto-save file" nil)))
+
+(defcustom bbdb-before-save-hook nil
+ "Hook run before saving `bbdb-file'."
+ :group 'bbdb
+ :type 'hook)
+
+(defcustom bbdb-after-save-hook nil
+ "Hook run after saving `bbdb-file'."
+ :group 'bbdb
+ :type 'hook)
+
+(defcustom bbdb-create-hook nil
+ "*Hook run each time a new BBDB record is created.
+Run with one argument, the new record. This is called before the record is
+added to the database, followed by a call of `bbdb-change-hook'.
+
+If a record has been created by analyzing a mail message, hook functions
+can use the variable `bbdb-update-records-address' to determine the header
+and class of the mail address according to `bbdb-message-headers'."
+ :group 'bbdb
+ :type 'hook)
+
+(defcustom bbdb-change-hook nil
+ "*Hook run each time a BBDB record is changed.
+Run with one argument, the record. This is called before the database
+is modified. If a new bbdb record is created, `bbdb-create-hook' is called
+first, followed by a call of this hook."
+ :group 'bbdb
+ :type 'hook)
+
+(defcustom bbdb-merge-records-function nil
+ "If non-nil, a function for merging two records.
+This function is called when loading a record into BBDB that has the same uuid
+as an exisiting record. If nil use `bbdb-merge-records'.
+This function should take two arguments RECORD1 and RECORD2, with RECORD2
+being the already existing record. It should merge RECORD1 into RECORD2,
+and return RECORD2."
+ :group 'bbdb
+ :type 'function)
+
+(defcustom bbdb-time-stamp-format "%Y-%m-%d %T %z"
+ "The BBDB time stamp format. See `format-time-string'.
+This function is called with arg UNIVERSAL being non-nil."
+ :group 'bbdb
+ :type 'string)
+
+(defcustom bbdb-after-change-hook nil
+ "Hook run each time a BBDB record is changed.
+Run with one argument, the record. This is called after the database
+is modified. So if you want to modify a record when it is created or changed,
+use instead `bbdb-create-hook' and / or `bbdb-change-hook'."
+ :group 'bbdb
+ :type 'hook)
+
+(defcustom bbdb-after-read-db-hook nil
+ "Hook run (with no arguments) after `bbdb-file' is read.
+Note that this can be called more than once if the BBDB is reverted."
+ :group 'bbdb
+ :type 'hook)
+
+(defcustom bbdb-initialize-hook nil
+ "Normal hook run after the BBDB initialization function `bbdb-initialize'."
+ :group 'bbdb
+ :type 'hook)
+
+(defcustom bbdb-mode-hook nil
+ "Normal hook run when the *BBDB* buffer is created."
+ :group 'bbdb
+ :type 'hook)
+
+(defcustom bbdb-silent nil
+ "If t, BBDB suppresses all its informational messages and queries.
+Be very very certain you want to set this to t, because it will suppress
+queries to alter record names, assign names to addresses, etc.
+Lisp Hackers: See also `bbdb-silent-internal'."
+ :group 'bbdb
+ :type '(choice (const :tag "Run silently" t)
+ (const :tag "Disable silent running" nil)))
+
+(defcustom bbdb-info-file nil
+ "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 "Nonstandard location")))
+
+
+;;; Record display
+
+(defcustom bbdb-pop-up-window-size 0.5
+ "Vertical size of BBDB window (vertical split).
+If it is an integer number, it is the number of lines used by BBDB.
+If it is a fraction between 0.0 and 1.0 (inclusive), it is the fraction
+of the tallest existing window that BBDB will take over.
+If it is t use `display-buffer'/`pop-to-buffer' to create the BBDB window.
+See also `bbdb-mua-pop-up-window-size'."
+ :group 'bbdb-record-display
+ :type '(choice (number :tag "BBDB window size")
+ (const :tag "Use `pop-to-buffer'" t)))
+
+(defcustom bbdb-dedicated-window nil
+ "Make *BBDB* window a dedicated window.
+Allowed values include nil (not dedicated) 'bbdb (weakly dedicated)
+and t (strongly dedicated)."
+ :group 'bbdb-record-display
+ :type '(choice (const :tag "BBDB window not dedicated" nil)
+ (const :tag "BBDB window weakly dedicated" bbdb)
+ (const :tag "BBDB window strongly dedicated" t)))
+
+(defcustom bbdb-layout-alist
+ '((one-line (order . (phone mail-alias mail notes))
+ (name-end . 24)
+ (toggle . t))
+ (multi-line (omit . (uuid creation-date timestamp
+ name-format name-face))
+ (toggle . t)
+ (indentation . 21))
+ (pop-up-multi-line (omit . (uuid creation-date timestamp
+ name-format name-face))
+ (indentation . 21))
+ (full-multi-line (indentation . 21)))
+ "Alist describing each display layout.
+The format of an element is (LAYOUT-NAME OPTION-ALIST).
+
+By default there are four different layout types used by BBDB, which are
+`one-line', `multi-line', `pop-up-multi-line' (used for pop-ups) and
+`full-multi-line' (showing all fields of a record).
+
+OPTION-ALIST specifies the options for the layout. Valid options are:
+
+ ------- Availability --------
+ Format one-line multi-line default if unset
+------------------------------------------------------------------------------
+ (toggle . BOOL) + + nil
+ (order . FIELD-LIST) + + '(phone ...)
+ (omit . FIELD-LIST) + + nil
+ (name-end . INTEGER) + - 40
+ (indentation . INTEGER) - + 21
+ (primary . BOOL) - + nil
+ (display-p . FUNCTION) + + nil
+
+- toggle: controls if this layout is included when toggeling the layout
+- order: defines a user specific order for the fields, where t is a place
+ holder for all remaining fields
+- omit: is a list of xfields which should not be displayed
+ or t to exclude all xfields except those listed in the order option
+- name-end: sets the column where the name should end in one-line layout.
+- indentation: sets the level of indentation for multi-line display.
+- primary: controls whether only the primary mail is shown or all are shown.
+- display-p: a function controlling whether the record is to be displayed.
+
+When you add a new layout FOO, you can write a corresponding layout
+function `bbdb-display-record-layout-FOO'. If you do not write your own
+layout function, the multi-line layout will be used."
+ :group 'bbdb-record-display
+ :type
+ `(repeat
+ (cons :tag "Layout Definition"
+ (choice :tag "Layout type"
+ (const one-line)
+ (const multi-line)
+ (const pop-up-multi-line)
+ (const full-multi-line)
+ (symbol))
+ (set :tag "Properties"
+ (cons :tag "Order"
+ (const :tag "List of fields to order by" order)
+ (repeat (choice (const phone)
+ (const address)
+ (const mail)
+ (const AKA)
+ (const notes)
+ (symbol :tag "other")
+ (const :tag "Remaining fields" t))))
+ (choice :tag "Omit"
+ :value (omit . nil)
+ (cons :tag "List of fields to omit"
+ (const :tag "Fields not to display" omit)
+ (repeat (choice (const phone)
+ (const address)
+ (const mail)
+ (const AKA)
+ (const notes)
+ (symbol :tag "other"))))
+ (const :tag "Exclude all fields except those listed in
the order note" t))
+ (cons :tag "Indentation"
+ :value (indentation . 14)
+ (const :tag "Level of indentation for multi-line layout"
+ indentation)
+ (number :tag "Column"))
+ (cons :tag "End of name field"
+ :value (name-end . 24)
+ (const :tag "The column where the name should end in
one-line layout"
+ name-end)
+ (number :tag "Column"))
+ (cons :tag "Toggle"
+ (const :tag "The layout is included when toggling layout"
toggle)
+ boolean)
+ (cons :tag "Primary Mail Only"
+ (const :tag "Only the primary mail address is included"
primary)
+ boolean)
+ (cons :tag "Display-p"
+ (const :tag "Show only records passing this test"
display-p)
+ (choice (const :tag "No test" nil)
+ (function :tag "Predicate")))))))
+
+(defcustom bbdb-layout 'multi-line
+ "Default display layout."
+ :group 'bbdb-record-display
+ :type '(choice (const one-line)
+ (const multi-line)
+ (const full-multi-line)
+ (symbol)))
+
+(defcustom bbdb-pop-up-layout 'pop-up-multi-line
+ "Default layout for pop-up BBDB buffers (mail, news, etc.)."
+ :group 'bbdb-record-display
+ :type '(choice (const one-line)
+ (const multi-line)
+ (const full-multi-line)
+ (symbol)))
+
+(defcustom bbdb-wrap-column nil
+ "Wrap column for multi-line display. If nil do not wrap lines."
+ :group 'bbdb-record-display
+ :type '(choice (const :tag "No line wrapping" nil)
+ (number :tag "Wrap column")))
+
+(defcustom bbdb-case-fold-search (default-value 'case-fold-search)
+ "Value of `case-fold-search' used by BBDB and friends.
+This variable lets the case-sensitivity of the BBDB commands
+be different from standard commands like command `isearch-forward'."
+ :group 'bbdb-record-display
+ :type 'boolean)
+
+(defcustom bbdb-name-format 'first-last
+ "Format for displaying names.
+If first-last names are displayed as \"Firstname Lastname\".
+If last-first names are displayed as \"Lastname, Firstname\".
+This can be overriden per record via the xfield name-format,
+which should take the same values.
+See also `bbdb-read-name-format'."
+ :group 'bbdb-record-display
+ :type '(choice (const :tag "Firstname Lastname" first-last)
+ (const :tag "Lastname, Firstname" last-first)))
+
+;; See http://en.wikipedia.org/wiki/Postal_address
+;;
http://www.upu.int/en/activities/addressing/postal-addressing-systems-in-member-countries.html
+(defcustom bbdb-address-format-list
+ '((("Argentina") "spcSC" "@address@hidden, @%c@, address@hidden@" "@%c@")
+ (("Australia") "scSpC" "@address@hidden@ %S@ address@hidden@" "@%c@")
+ (("Austria" "Germany" "Spain" "Switzerland")
+ "spcSC" "@address@hidden @%c@ (%S)@\n%C@" "@%c@")
+ (("Canada") "scSCp" "@address@hidden@, address@hidden@ %p@" "@%c@")
+ (("China") "scpSC" "@address@hidden@\n%p@ address@hidden@" "@%c@") ;
English format
+ ; (("China") "CpScs" "@%C @address@hidden @%c@ %s@" "@%c@") ; Chinese
format
+ (("India") "scpSC" "@address@hidden@ %p@ (%S)@\n%C@" "@%c@")
+ (("USA") "scSpC" "@address@hidden@, %S@ address@hidden@" "@%c@")
+ (t bbdb-edit-address-default bbdb-format-address-default "@%c@"))
+ "List of address editing and formatting rules for BBDB.
+Each rule is a list (IDENTIFIER EDIT FORMAT FORMAT).
+The first rule for which IDENTIFIER matches an address is used for editing
+and formatting the address.
+
+IDENTIFIER may be a list of countries.
+IDENTIFIER may also be a function that is called with one arg, the address
+to be used. The rule applies if the function returns non-nil.
+See `bbdb-address-continental-p' for an example.
+If IDENTIFIER is t, this rule always applies. Usually, this should be
+the last rule that becomes a fall-back (default).
+
+EDIT may be a function that is called with one argument, the address.
+See `bbdb-edit-address-default' for an example.
+
+EDIT may also be an editting format string. It is a string containing
+the five letters s, c, p, S, and C that specify the order for editing
+the five elements of an address:
+
+s streets
+c city
+p postcode
+S state
+C country
+
+The first FORMAT of each rule is used for multi-line layout, the second FORMAT
+is used for one-line layout.
+
+FORMAT may be a function that is called with one argument, the address.
+See `bbdb-format-address-default' for an example.
+
+FORMAT may also be a format string. It consists of formatting elements
+separated by a delimiter defined via the first (and last) character of FORMAT.
+Each formatting element may contain one of the following format specifiers:
+
+%s streets (used repeatedly for each street part)
+%c city
+%p postcode
+%S state
+%C country
+
+A formatting element will be applied only if the corresponding part
+of the address is a non-empty string.
+
+See also `bbdb-tex-address-format-list'."
+ :group 'bbdb-record-display
+ :type '(repeat (list (choice (const :tag "Default" t)
+ (function :tag "Function")
+ (repeat (string)))
+ (choice (string)
+ (function :tag "Function"))
+ (choice (string)
+ (function :tag "Function"))
+ (choice (string)
+ (function :tag "Function")))))
+
+(defcustom bbdb-continental-postcode-regexp
+ "^\\s *[A-Z][A-Z]?\\s *-\\s *[0-9][0-9][0-9]"
+ "Regexp matching continental postcodes.
+Used by address format identifier `bbdb-address-continental-p'.
+The regexp should match postcodes of the form CH-8052, NL-2300RA,
+and SE-132 54."
+ :group 'bbdb-record-display
+ :type 'regexp)
+
+(defcustom bbdb-default-separator '("[,;]" ", ")
+ "The default field separator. It is a list (SPLIT-RE JOIN).
+This is used for fields which do not have an entry in `bbdb-separator-alist'.
+Whitespace surrounding SPLIT-RE is ignored."
+ :group 'bbdb-record-display
+ :type '(list regexp string))
+
+(defcustom bbdb-separator-alist
+ '((record "\n\n" "\n\n") ; used by `bbdb-copy-fields-as-kill'
+ (name-first-last "[ ,;]" " ") (name-last-first "[ ,;]" ", ")
+ (name-field ":\n" ":\n") ; used by `bbdb-copy-fields-as-kill'
+ (phone "[,;]" ", ") (address ";\n" ";\n") ; ditto
+ (organization "[,;]" ", ") (affix "[,;]" ", ") (aka "[,;]" ", ")
+ (mail "[,;]" ", ") (mail-alias "[,;]" ", ") (vm-folder "[,;]" ", ")
+ (birthday "\n" "\n") (wedding "\n" "\n") (anniversary "\n" "\n")
+ (notes "\n" "\n") (tex-name "#" " # "))
+ "Alist of field separators.
+Each element is of the form (FIELD SPLIT-RE JOIN).
+Whitespace surrounding SPLIT-RE is ignored.
+For fields lacking an entry here `bbdb-default-separator' is used instead."
+ :group 'bbdb-record-display
+ :type '(repeat (list symbol regexp string)))
+
+(defcustom bbdb-user-menu-commands nil
+ "User defined menu entries which should be appended to the BBDB menu.
+This should be a list of menu entries.
+When set to a function, it is called with two arguments RECORD and FIELD
+and it should either return nil or a list of menu entries.
+Used by `bbdb-mouse-menu'."
+ :group 'bbdb-record-display
+ :type 'sexp)
+
+(defcustom bbdb-display-hook nil
+ "Hook run after the *BBDB* is filled in."
+ :group 'bbdb-record-display
+ :type 'hook)
+
+(defcustom bbdb-multiple-buffers nil
+ "When non-nil we create a new buffer of every buffer causing pop-ups.
+You can also set this to a function returning a buffer name.
+Here a value may be the predefined function `bbdb-multiple-buffers-default'."
+ :group 'bbdb-record-display
+ :type '(choice (const :tag "Disabled" nil)
+ (function :tag "Enabled" bbdb-multiple-buffers-default)
+ (function :tag "User defined function")))
+
+(defcustom bbdb-image nil
+ "If non-nil display records with an image.
+If a symbol this should be an xfield holding the name of the image file
+associated with the record. If it is `name' or `fl-name', the first and last
+name of the record are used as file name. If it is `lf-name', the last and
+first name of the record are used as file name.
+If a function it is called with one arg, the record, and it should return
+the name of the image file.
+The file is searched in the directories in `bbdb-image-path'.
+File name suffixes are appended according to `bbdb-image-suffixes'.
+See `locate-file'."
+ :group 'bbdb-record-display
+ :type '(choice (const :tag "Disabled" nil)
+ (function :tag "User defined function")
+ (symbol :tag "Record field")))
+
+(defcustom bbdb-image-path nil
+ "List of directories to search for `bbdb-image'."
+ :group 'bbdb-record-display
+ :type '(repeat (directory)))
+
+(defcustom bbdb-image-suffixes '(".png" ".jpg" ".gif" ".xpm")
+ "List of file name suffixes searched for `bbdb-image'."
+ :group 'bbdb-record-display
+ :type '(repeat (string :tag "File suffix")))
+
+(defcustom bbdb-read-name-format 'fullname
+ "Default format for reading names via `bbdb-read-name'.
+If it is 'first-last read first and last name separately.
+If it is 'last-first read last and first name separately.
+With any other value read full name at once.
+See also `bbdb-name-format'."
+ :group 'bbdb-record-display
+ :type '(choice (const :tag "Firstname Lastname" first-last)
+ (const :tag "Lastname, Firstname" last-first)
+ (const :tag "Full name" fullname)))
+
+
+;;; Record editing
+(defcustom bbdb-lastname-prefixes
+ '("von" "de" "di")
+ "List of lastname prefixes recognized in name fields.
+Used to enhance dividing name strings into firstname and lastname parts.
+Case is ignored."
+ :group 'bbdb-record-edit
+ :type '(repeat string))
+
+(defcustom bbdb-lastname-re
+ (concat "[- \t]*\\(\\(?:\\<"
+ (regexp-opt bbdb-lastname-prefixes)
+ ;; multiple last names concatenated by `-'
+ "\\>[- \t]+\\)?\\(?:\\w+[ \t]*-[ \t]*\\)*\\w+\\)\\'")
+ "Regexp matching the last name of a full name.
+Its first parenthetical subexpression becomes the last name."
+ :group 'bbdb-record-edit
+ :type 'regexp)
+
+(defcustom bbdb-lastname-suffixes
+ '("Jr" "Sr" "II" "III")
+ "List of lastname suffixes recognized in name fields.
+Used to dividing name strings into firstname and lastname parts.
+All suffixes are complemented by optional `.'. Case is ignored."
+ :group 'bbdb-record-edit
+ :type '(repeat string))
+
+(defcustom bbdb-lastname-suffix-re
+ (concat "[-,. \t/\\]+\\("
+ (regexp-opt bbdb-lastname-suffixes)
+ ;; suffices are complemented by optional `.'.
+ "\\.?\\)\\W*\\'")
+ "Regexp matching the suffix of a last name.
+Its first parenthetical subexpression becomes the suffix."
+ :group 'bbdb-record-edit
+ :type 'regexp)
+
+(defcustom bbdb-default-domain nil
+ "Default domain to append when reading a new mail address.
+If a mail address does not contain address@hidden', append
@`bbdb-default-domain' to it.
+
+The address is not altered if `bbdb-default-domain' is nil
+or if a prefix argument is given to the command `bbdb-insert-field'."
+ :group 'bbdb-record-edit
+ :type '(choice (const :tag "none" nil)
+ (string :tag "Default Domain")))
+
+(defcustom bbdb-phone-style 'nanp
+ "Phone numbering plan assumed by BBDB.
+The value 'nanp refers to the North American Numbering Plan.
+The value nil refers to a free-style numbering plan.
+
+You can have both styles of phone number in your database by providing a
+prefix argument to the command `bbdb-insert-field'."
+ :group 'bbdb-record-edit
+ :type '(choice (const :tag "NANP" nanp)
+ (const :tag "none" nil)))
+
+(defcustom bbdb-default-area-code nil
+ "Default area code to use when reading a new phone number.
+This variable also affects dialing."
+ :group 'bbdb-record-edit
+ :type '(choice (const :tag "none" nil)
+ (integer :tag "Default Area Code"))
+ :set (lambda( symb val )
+ (if (or (and (stringp val)
+ (string-match "^[0-9]+$" val))
+ (integerp val)
+ (null val))
+ (set symb val)
+ (error "%s must contain digits only." symb))))
+
+(defcustom bbdb-allow-duplicates nil
+ "When non-nil BBDB allows records with duplicate names and email addresses.
+In rare cases, this may lead to confusion with BBDB's MUA interface."
+ :group 'bbdb-record-edit
+ :type 'boolean)
+
+(defcustom bbdb-default-label-list '("home" "work" "other")
+ "Default list of labels for Address and Phone fields."
+ :group 'bbdb-record-edit
+ :type '(repeat string))
+
+(defcustom bbdb-address-label-list bbdb-default-label-list
+ "List of labels for Address field."
+ :group 'bbdb-record-edit
+ :type '(repeat string))
+
+(defcustom bbdb-phone-label-list '("home" "work" "cell" "other")
+ "List of labels for Phone field."
+ :group 'bbdb-record-edit
+ :type '(repeat string))
+
+(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-edit
+ :type '(choice (const :tag "None" nil)
+ (string :tag "Default Country")))
+
+(defcustom bbdb-check-postcode t
+ "If non-nil, require legal postcodes when entering an address.
+The format of legal postcodes is determined by the variable
+`bbdb-legal-postcodes'."
+ :group 'bbdb-record-edit
+ :type 'boolean)
+
+(defcustom bbdb-legal-postcodes
+ '(;; 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 postcodes for Canada, UK, etc. (result is ("LL47" "U4B")).
+ "^[ \t\n]*\\([A-Za-z0-9]+\\)[ \t\n]+\\([A-Za-z0-9]+\\)[ \t\n]*$"
+ ;; Match postcodes 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
+ ;; <address@hidden>
+ "^[ \t\n]*\\([A-Z]+\\)[ \t\n]*-?[ \t\n]*\\([0-9]+ ?[A-Z]*\\)[ \t\n]*$"
+ ;; Match postcodes from Sweden where the five digits are grouped 3+2
+ ;; at the request from Mats Lofdahl <address@hidden>.
+ ;; (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 postcodes.
+Whether this is used at all depends on the variable `bbdb-check-postcode'."
+ :group 'bbdb-record-edit
+ :type '(repeat regexp))
+
+(defcustom bbdb-default-xfield 'notes
+ "Default xfield when editing BBDB records."
+ :group 'bbdb-record-edit
+ :type '(symbol :tag "Xfield"))
+
+(defcustom bbdb-edit-foo (cons bbdb-default-xfield 'current-fields)
+ "Fields to edit with command `bbdb-edit-foo'.
+This is a cons pair (WITHOUT-PREFIX . WITH-PREFIX).
+The car is used if the command is called without a prefix.
+The cdr is used if the command is called with a prefix.
+
+WITHOUT-PREFIX and WITH-PREFIX may take the values:
+ name The full name
+ affix The list of affixes
+ organization The list of organizations
+ aka the list of AKAs
+ mail the list of email addresses
+ phone the list of phone numbers
+ address the list of addresses
+ current-fields Read the field to edit using a completion table
+ that includes all fields of the current record.
+ all-fields Read the field to edit using a completion table
+ that includes all fields currently known to BBDB.
+
+Any other symbol is interpreted as the label of an xfield."
+ :group 'bbdb-record-edit
+ :type '(cons (symbol :tag "Field without prefix")
+ (symbol :tag "Field with prefix")))
+
+
+;;; MUA interface
+
+(defcustom bbdb-annotate-field bbdb-default-xfield
+ "Field to annotate via `bbdb-annotate-record' and friends.
+This may take the values:
+ affix The list of affixes
+ organization The list of organizations
+ aka the list of AKAs
+ mail the list of email addresses
+ all-fields Read the field to edit using a completion table
+ that includes all fields currently known to BBDB.
+
+Any other symbol is interpreted as the label of an xfield."
+ :group 'bbdb-mua
+ :type '(symbol :tag "Field to annotate"))
+
+(defcustom bbdb-mua-edit-field bbdb-default-xfield
+ "Field to edit with command `bbdb-mua-edit-field' and friends.
+This may take the values:
+ name The full name
+ affix The list of affixes
+ organization The list of organizations
+ aka the list of AKAs
+ mail the list of email addresses
+ all-fields Read the field to edit using a completion table
+ that includes all fields currently known to BBDB.
+
+Any other symbol is interpreted as the label of an xfield."
+ :group 'bbdb-mua
+ :type '(symbol :tag "Field to edit"))
+
+(defcustom bbdb-mua-update-interactive-p '(search . query)
+ "How BBDB's interactive MUA commands update BBDB records.
+This is a cons pair (WITHOUT-PREFIX . WITH-PREFIX).
+The car is used if the command is called without a prefix.
+The cdr is used if the command is called with a prefix (and if the prefix
+ is not used for another purpose).
+
+WITHOUT-PREFIX and WITH-PREFIX may take the values
+\(here ADDRESS is an email address found in a message):
+ nil Do nothing.
+ search Search for existing records matching ADDRESS.
+ update Search for existing records matching ADDRESS;
+ update name and mail field if necessary.
+ query Search for existing records matching ADDRESS;
+ query for creation of a new record if the record does not
exist.
+ create or t Search for existing records matching ADDRESS;
+ create a new record if it does not yet exist.
+ a function This functions will be called with no arguments.
+ It should return one of the above values.
+ read Read the value interactively."
+ :group 'bbdb-mua
+ :type '(cons (choice (const :tag "do nothing" nil)
+ (const :tag "search for existing records" search)
+ (const :tag "update existing records" update)
+ (const :tag "query annotation of all messages" query)
+ (const :tag "annotate all messages" create)
+ (function :tag "User-defined function")
+ (const :tag "read arg interactively" read))
+ (choice (const :tag "do nothing" nil)
+ (const :tag "search for existing records" search)
+ (const :tag "update existing records" update)
+ (const :tag "query annotation of all messages" query)
+ (const :tag "annotate all messages" create)
+ (function :tag "User-defined function")
+ (const :tag "read arg interactively" read))))
+
+(defcustom bbdb-mua-auto-update-p 'bbdb-select-message
+ "How `bbdb-mua-auto-update' updates BBDB records automatically.
+
+Allowed values are (here ADDRESS is an email address found in a message):
+ nil Do nothing.
+ search Search for existing records matching ADDRESS.
+ update Search for existing records matching ADDRESS;
+ update name and mail field if necessary.
+ query Search for existing records matching ADDRESS;
+ query for creation of a new record if the record does not
exist.
+ create or t Search for existing records matching ADDRESS;
+ create a new record if it does not yet exist.
+ a function This functions will be called with no arguments.
+ It should return one of the above values.
+ For an example, see `bbdb-select-message' with
+ `bbdb-mua-update-records-p', `bbdb-accept-message-alist'
+ and `bbdb-ignore-message-alist'.
+
+To initiate auto-updating of BBDB records, call `bbdb-mua-auto-update-init'
+for the respective MUAs in your init file."
+ :group 'bbdb-mua
+ :type '(choice (const :tag "do nothing" nil)
+ (const :tag "search for existing records" search)
+ (const :tag "update existing records" update)
+ (const :tag "query annotation of all messages" query)
+ (const :tag "annotate all messages" create)
+ (function :tag "User-defined function")))
+
+(defcustom bbdb-update-records-p 'search
+ "Return value for `bbdb-select-message' and friends.
+These functions can select messages for further processing by BBDB,
+The amount of subsequent processing is determined by `bbdb-update-records-p'.
+
+Allowed values are (here ADDRESS is an email address selected
+by `bbdb-select-message'):
+ nil Do nothing.
+ search Search for existing records matching ADDRESS.
+ update Search for existing records matching ADDRESS;
+ update name and mail field if necessary.
+ query Search for existing records matching ADDRESS;
+ query for creation of a new record if the record does not
exist.
+ create or t Search for existing records matching ADDRESS;
+ create a new record if it does not yet exist.
+ a function This functions will be called with no arguments.
+ It should return one of the above values."
+ ;; Also: Used for communication between `bbdb-update-records'
+ ;; and `bbdb-query-create'.
+ :group 'bbdb-mua
+ :type '(choice (const :tag "do nothing" nil)
+ (const :tag "search for existing records" search)
+ (const :tag "update existing records" update)
+ (const :tag "query annotation of all messages" query)
+ (const :tag "annotate all messages" create)
+ (function :tag "User-defined function")))
+
+(defcustom bbdb-message-headers
+ '((sender "From" "Resent-From" "Reply-To" "Sender")
+ (recipients "Resent-To" "Resent-CC" "To" "CC" "BCC"))
+ "Alist of headers to search for sender and recipients mail addresses.
+Each element is of the form
+
+ (CLASS HEADER ...)
+
+The symbol CLASS defines a class of headers.
+The strings HEADER belong to CLASS."
+ :group 'bbdb-mua
+ :type 'list)
+
+(defcustom bbdb-message-all-addresses nil
+ "If t `bbdb-update-records' returns all mail addresses of a message.
+Otherwise this function returns only the first mail address of each message."
+ :group 'bbdb-mua
+ :type 'boolean)
+
+(defcustom bbdb-message-try-all-headers nil
+ "If t try all message headers to extract an email address from a message.
+Several BBDB commands extract either the sender or the recipients' email
+addresses from a message according to `bbdb-message-headers'. If BBDB does not
+find any email address in this subset of message headers (for example, because
+an email address is excluded because of `bbdb-user-mail-address-re')
+but `bbdb-message-try-all-headers' is t, then these commands will also consider
+the email addresses in the remaining headers."
+ :group 'bbdb-mua
+ :type 'boolean)
+
+(defcustom bbdb-accept-message-alist t
+ "Alist describing which messages to automatically create BBDB records for.
+The format of this alist is
+ ((HEADER-NAME . REGEXP) ...)
+For example, if
+ ((\"From\" . \"@.*\\.maximegalon\\.edu\")
+ (\"Subject\" . \"time travel\"))
+BBDB records are only created for messages sent by people at Maximegalon U.,
+or people posting about time travel.
+If t accept all messages. If nil do not accept any messages.
+
+See also `bbdb-ignore-message-alist', which has the opposite effect."
+ :group 'bbdb-mua
+ :type '(repeat (cons
+ (string :tag "Header name")
+ (regexp :tag "Regexp to match on header value"))))
+
+(defcustom bbdb-ignore-message-alist nil
+ "Alist describing which messages not to automatically create BBDB records
for.
+The format of this alist is
+ ((HEADER-NAME . REGEXP) ... )
+For example, if
+ ((\"From\" . \"mailer-daemon\")
+ ((\"To\" \"CC\") . \"mailing-list-1\\\\|mailing-list-2\"))
+no BBDB records are created for messages from any mailer daemon,
+or messages sent to or CCed to either of two mailing lists.
+If t ignore all messages. If nil do not ignore any messages.
+
+See also `bbdb-accept-message-alist', which has the opposite effect."
+ :group 'bbdb-mua
+ :type '(repeat (cons
+ (string :tag "Header name")
+ (regexp :tag "Regexp to match on header value"))))
+
+(defcustom bbdb-user-mail-address-re
+ (and (stringp user-mail-address)
+ (string-match "\\`\\(address@hidden)\\(@\\|\\'\\)" user-mail-address)
+ (concat "\\<" (regexp-quote (match-string 1 user-mail-address)) "\\>"))
+ "A regular expression matching your mail addresses.
+Several BBDB commands extract either the sender or the recipients' email
+addresses from a message according to `bbdb-message-headers'. Yet an email
+address will be ignored if it matches `bbdb-user-mail-address-re'. This way
+the commands will not operate on your own record.
+See also `bbdb-message-try-all-headers'."
+ :group 'bbdb-mua
+ :type '(regexp :tag "Regexp matching your mail addresses"))
+
+(defcustom bbdb-add-name 'query
+ "How to handle new names for existing BBDB records.
+This handles messages where the real name differs from the name
+in a BBDB record with the same mail address, as in \"John Smith
<address@hidden>\"
+versus \"John Q. Smith <address@hidden>\".
+Allowed values are:
+ t Automatically change the name to the new value.
+ query Query whether to use the new name.
+ nil Ignore the new name.
+ a number Number of seconds BBDB displays the name mismatch.
+ (without further action).
+ a function This is called with two args, the record and the new name.
+ It should return one of the above values.
+ a regexp If the new name matches this regexp ignore it.
+ Otherwise query to add it.
+See also `bbdb-add-aka'."
+ :group 'bbdb-mua
+ :type '(choice (const :tag "Automatically use the new name" t)
+ (const :tag "Query for name changes" query)
+ (const :tag "Ignore the new name" nil)
+ (integer :tag "Number of seconds to display name mismatch")
+ (function :tag "Function for analyzing name handling")
+ (regexp :tag "If the new name matches this regexp ignore
it.")))
+
+(defcustom bbdb-add-aka 'query
+ "How to handle alternate names for existing BBDB records.
+Allowed values are:
+ t Automatically store alternate names as AKA.
+ query Query whether to store alternate names as an AKA.
+ nil Ignore alternate names.
+ a function This is called with two args, the record and the new name.
+ It should return one of the above values.
+ a regexp If the alternate name matches this regexp ignore it.
+ Otherwise query to add it.
+See also `bbdb-add-name'."
+ :group 'bbdb-mua
+ :type '(choice (const :tag "Automatically store alternate names as AKA" t)
+ (const :tag "Query for alternate names" query)
+ (const :tag "Ignore alternate names" nil)
+ (function :tag "Function for alternate name handling")
+ (regexp :tag "If the alternate name matches this regexp
ignore it.")))
+
+(defcustom bbdb-add-mails 'query
+ "How to handle new mail addresses for existing BBDB records.
+This handles messages where the mail address differs from the mail addresses
+in a BBDB record with the same name as in \"John Q. Smith <address@hidden>\"
+versus \"John Q. Smith <address@hidden>\".
+Allowed values are:
+ t Automatically add new mail addresses to the list of mail
addresses.
+ query Query whether to add it.
+ nil Ignore new mail addresses.
+ a number Number of seconds BBDB displays the new address
+ (without further action).
+ a function This is called with two args, the record and the new mail address.
+ It should return one of the above values.
+ a regexp If the new mail address matches this regexp ignore the new
address.
+ Otherwise query to add it.
+See also `bbdb-new-mails-primary' and `bbdb-ignore-redundant-mails'."
+ :group 'bbdb-mua
+ :type '(choice (const :tag "Automatically add new mail addresses" t)
+ (const :tag "Query before adding new mail addresses" query)
+ (const :tag "Never add new mail addresses" nil)
+ (number :tag "Number of seconds to display new addresses")
+ (function :tag "Function for analyzing name handling")
+ (regexp :tag "If the new address matches this regexp ignore
it.")))
+
+(defcustom bbdb-new-mails-primary 'query
+ "Where to put new mail addresses for existing BBDB records.
+A new mail address may either become the new primary mail address,
+when it is put at the beginning of the list of mail addresses.
+Or the new mail address is added at the end of the list of mail addresses.
+Allowed values are:
+ t Make a new address automatically the primary address.
+ query Query whether to make it the primary address.
+ nil Add the new address to the end of the list.
+ a function This is called with two args, the record and the new mail address.
+ It should return one of the above values.
+ a regexp If the new mail address matches this regexp put it at the end.
+ Otherwise query to make it the primary address.
+See also `bbdb-add-mails'."
+ :group 'bbdb-mua
+ :type '(choice (const :tag "New address automatically made primary" t)
+ (const :tag "Query before making a new address primary" query)
+ (const :tag "Do not make new address primary" nil)
+ (function :tag "Function for analyzing primary handling")
+ (regexp :tag "If the new mail address matches this regexp put
it at the end.")))
+
+(defcustom bbdb-canonicalize-mail-function nil
+ "If non-nil, it should be a function of one arg: a mail address string.
+When BBDB \"notices\" a message, the corresponding mail addresses are passed
+to this function first. It acts as a kind of \"filter\" to transform
+the mail addresses before they are compared against or added to the database.
+See `bbdb-canonicalize-mail-1' for a more complete example.
+If this function returns nil, BBDB assumes that there is no mail address.
+
+See also `bbdb-ignore-redundant-mails'."
+ :group 'bbdb-mua
+ :type 'function)
+
+(defcustom bbdb-ignore-redundant-mails 'query
+ "How to handle redundant mail addresses for existing BBDB records.
+For example, \"address@hidden" is redundant w.r.t. \"address@hidden".
+This affects two things, whether a new redundant mail address is added
+to BBDB and whether an old mail address, which has become redundant
+because of a newly added mail address, is removed from BBDB.
+
+Allowed values are:
+ t Automatically ignore redundant mail addresses.
+ query Query whether to ignore them.
+ nil Do not ignore redundant mail addresses.
+ a number Number of seconds BBDB displays redundant mail addresses
+ (without further action).
+ a function This is called with two args, the record and the new mail address.
+ It should return one of the above values.
+ a regexp If the new mail address matches this regexp never ignore
+ this mail address. Otherwise query to ignore it.
+See also `bbdb-add-mails' and `bbdb-canonicalize-mail-function'."
+ :group 'bbdb-mua
+ :type '(choice (const :tag "Automatically ignore redundant mail addresses" t)
+ (const :tag "Query whether to ignore them" query)
+ (const :tag "Do not ignore redundant mail addresses" nil)
+ (number :tag "Number of seconds to display redundant
addresses")
+ (function :tag "Function for handling redundant mail
addresses")
+ (regexp :tag "If the new address matches this regexp never
ignore it.")))
+(define-obsolete-variable-alias 'bbdb-canonicalize-redundant-mails
+ 'bbdb-ignore-redundant-mails "3.0")
+
+(defcustom bbdb-message-clean-name-function 'bbdb-message-clean-name-default
+ "Function to clean up the name in the header of a message.
+It takes one argument, the name as extracted by
+`mail-extract-address-components'."
+ :group 'bbdb-mua
+ :type 'function)
+
+(defcustom bbdb-message-mail-as-name t
+ "If non-nil use mail address of message as fallback for name of new records."
+ :group 'bbdb-mua
+ :type 'boolean)
+
+(defcustom bbdb-notice-mail-hook nil
+ "Hook run each time a mail address of a record is \"noticed\" in a message.
+This means that the mail address in a message belongs to an existing BBDB
record
+or to a record BBDB has created for the mail address.
+
+Run with one argument, the record. It is up to the hook function
+to determine which MUA is used and to act appropriately.
+Hook functions can use the variable `bbdb-update-records-address'
+to determine the header and class of the mail address according
+to `bbdb-message-headers'. See `bbdb-auto-notes' for how to annotate records
+using `bbdb-update-records-address' and the headers of a mail message.
+
+If a message contains multiple mail addresses belonging to one BBDB record,
+this hook is run for each mail address. Use `bbdb-notice-record-hook'
+if you want to notice each record only once per message."
+ :group 'bbdb-mua
+ :type 'hook)
+
+(defcustom bbdb-notice-record-hook nil
+ "Hook run each time a BBDB record is \"noticed\" in a message.
+This means that one of the mail addresses in a message belongs to an existing
+record or it is a record BBDB has created for the mail address. If a message
+contains multiple mail addresses belonging to one BBDB record, this hook
+is nonetheless run only once. Use `bbdb-notice-mail-hook' if you want to run
+a hook function for each mail address in a message.
+
+Hook is run with one argument, the record."
+ :group 'bbdb-mua
+ :type 'hook)
+
+(define-widget 'bbdb-alist-with-header 'group
+ "My group"
+ :match 'bbdb-alist-with-header-match
+ :value-to-internal (lambda (_widget value)
+ (if value (list (car value) (cdr value))))
+ :value-to-external (lambda (_widget value)
+ (if value (append (list (car value)) (cadr value)))))
+
+(defun bbdb-alist-with-header-match (widget value)
+ (widget-group-match widget
+ (widget-apply widget :value-to-internal value)))
+
+(defvar bbdb-auto-notes-rules-expanded nil
+ "Expanded `bbdb-auto-notes-rules'.") ; Internal variable
+
+(defcustom bbdb-auto-notes-rules nil
+ "List of rules for adding notes to records of mail addresses of messages.
+This automatically annotates the BBDB record of the sender or recipient
+of a message based on the value of a header such as the Subject header.
+This requires that `bbdb-notice-mail-hook' contains `bbdb-auto-notes'
+and that the record already exists or `bbdb-update-records-p' returns such that
+the record will be created. Messages matching
`bbdb-auto-notes-ignore-messages'
+are ignored.
+
+The elements of this list are
+
+ (MUA FROM-TO HEADER ANNOTATE ...)
+ (FROM-TO HEADER ANNOTATE ...)
+ (HEADER ANNOTATE ...)
+
+MUA is the active MUA or a list of MUAs (see `bbdb-mua').
+If MUA is missing or t, use this rule for all MUAs.
+
+FROM-TO is a list of headers and/or header classes as in
`bbdb-message-headers'.
+The record corresponding to a mail address of a message is considered for
+annotation if this mail address was found in a header matching FROM-TO.
+If FROM-TO is missing or t, records for each mail address are considered
+irrespective of where the mail address was found in a message.
+
+HEADER is a message header that is considered for generating the annotation.
+
+ANNOTATE may take the following values:
+
+ (REGEXP . STRING) [this is equivalent to (REGEXP notes STRING)]
+ (REGEXP FIELD STRING)
+ (REGEXP FIELD STRING REPLACE)
+
+REGEXP must match the value of HEADER for generating an annotation.
+However, if the value of HEADER also matches an element of
+`bbdb-auto-notes-ignore-headers' no annotation is generated.
+
+The annotation will be added to FIELD of the respective record.
+FIELD defaults to `bbdb-default-xfield'.
+
+STRING defines a replacement for the match of REGEXP in the value of HEADER.
+It may contain \\& or \\N specials used by `replace-match'.
+The resulting string becomes the annotation.
+If STRING is an integer N, the Nth matching subexpression is used.
+If STRING is a function, it will be called with one arg, the value of HEADER.
+The return value (which must be a string) is then used.
+
+If REPLACE is t, the resulting string replaces the old contents of FIELD.
+If it is nil, the string is appended to the contents of FIELD (unless the
+annotation is already part of the content of field).
+
+For example,
+
+ ((\"To\" (\"address@hidden" . \"VM mailing list\"))
+ (\"Subject\" (\"sprocket\" . \"mail about sprockets\")
+ (\"you bonehead\" . \"called me a bonehead\")))
+
+will cause the text \"VM mailing list\" to be added to the notes field
+of the records corresponding to anyone you get mail from via one of the VM
+mailing lists.
+
+If multiple clauses match the message, all of the corresponding strings
+will be added.
+
+See also variables `bbdb-auto-notes-ignore-messages' and
+`bbdb-auto-notes-ignore-headers'.
+
+For speed-up, the function `bbdb-auto-notes' actually use expanded rules
+stored in the internal variable `bbdb-auto-notes-rules-expanded'.
+If you change the value of `bbdb-auto-notes-rules' outside of customize,
+set `bbdb-auto-notes-rules-expanded' to nil, so that the expanded rules
+will be re-evaluated."
+ :group 'bbdb-mua
+ :set (lambda (symbol value)
+ (set-default symbol value)
+ (setq bbdb-auto-notes-rules-expanded nil))
+ :type '(repeat
+ (bbdb-alist-with-header
+ (repeat (choice
+ (const sender)
+ (const recipients)))
+ (string :tag "Header name")
+ (repeat (choice
+ (cons :tag "Value Pair"
+ (regexp :tag "Regexp to match on header value")
+ (string :tag "String for notes if regexp matches"))
+ (list :tag "Replacement list"
+ (regexp :tag "Regexp to match on header value")
+ (choice :tag "Record field"
+ (const notes :tag "xfields")
+ (const organization :tag "Organization")
+ (symbol :tag "Other"))
+ (choice :tag "Regexp match"
+ (string :tag "Replacement string")
+ (integer :tag "Subexpression match")
+ (function :tag "Callback Function"))
+ (choice :tag "Replace previous contents"
+ (const :tag "No" nil)
+ (const :tag "Yes" t))))))))
+
+(defcustom bbdb-auto-notes-ignore-messages nil
+ "List of rules for ignoring entire messages in `bbdb-auto-notes'.
+The elements may have the following values:
+ a function This function is called with one arg, the record
+ that would be annotated.
+ Ignore this message if the function returns non-nil.
+ This function may use `bbdb-update-records-address'.
+ MUA Ignore messages from MUA (see `bbdb-mua').
+ (HEADER . REGEXP) Ignore messages where HEADER matches REGEXP.
+ For example, (\"From\" . bbdb-user-mail-address-re)
+ disables any recording of notes for mail addresses
+ found in messages coming from yourself, see
+ `bbdb-user-mail-address-re'.
+ (MUA HEADER REGEXP) Ignore messages from MUA where HEADER
+ matches REGEXP.
+See also `bbdb-auto-notes-ignore-headers'."
+ :group 'bbdb-mua
+ :type '(repeat (cons
+ (string :tag "Header name")
+ (regexp :tag "Regexp to match on header value"))))
+
+(defcustom bbdb-auto-notes-ignore-headers nil
+ "Alist of headers and regexps to ignore in `bbdb-auto-notes'.
+Each element is of the form
+
+ (HEADER . REGEXP)
+
+For example,
+
+ (\"Organization\" . \"^Gatewayed from\\\\\|^Source only\")
+
+will exclude the phony `Organization:' headers in GNU mailing-lists
+gatewayed to gnu.* newsgroups.
+See also `bbdb-auto-notes-ignore-messages'."
+ :group 'bbdb-mua
+ :type '(repeat (cons
+ (string :tag "Header name")
+ (regexp :tag "Regexp to match on header value"))))
+
+(defcustom bbdb-mua-pop-up t
+ "If non-nil, display an auto-updated BBDB window while using a MUA.
+If 'horiz, stack the window horizontally if there is room.
+If this is nil, BBDB is updated silently.
+
+See also `bbdb-mua-pop-up-window-size' and `bbdb-horiz-pop-up-window-size'."
+ :group 'bbdb-mua
+ :type '(choice (const :tag "MUA BBDB window stacked vertically" t)
+ (const :tag "MUA BBDB window stacked horizontally" horiz)
+ (const :tag "No MUA BBDB window" nil)))
+(define-obsolete-variable-alias 'bbdb-message-pop-up 'bbdb-mua-pop-up "3.0")
+
+(defcustom bbdb-mua-pop-up-window-size bbdb-pop-up-window-size
+ "Vertical size of MUA pop-up BBDB window (vertical split).
+If it is an integer number, it is the number of lines used by BBDB.
+If it is a fraction between 0.0 and 1.0 (inclusive), it is the fraction
+of the tallest existing window that BBDB will take over.
+If it is t use `pop-to-buffer' to create the BBDB window.
+See also `bbdb-pop-up-window-size'."
+ :group 'bbdb-mua
+ :type '(choice (number :tag "BBDB window size")
+ (const :tag "Use `pop-to-buffer'" t)))
+
+(defcustom bbdb-horiz-pop-up-window-size '(112 . 0.3)
+ "Horizontal size of a MUA pop-up BBDB window (horizontal split).
+It is a cons pair (TOTAL . BBDB-SIZE).
+The window that will be considered for horizontal splitting must have
+at least TOTAL columns. BBDB-SIZE is the horizontal size of the BBDB window.
+If it is an integer number, it is the number of columns used by BBDB.
+If it is a fraction between 0 and 1, it is the fraction of the
+window width that BBDB will take over."
+ :group 'bbdb-mua
+ :type '(cons (number :tag "Total number of columns")
+ (number :tag "Horizontal size of BBDB window")))
+
+
+;;; xfields processing
+(defcustom bbdb-xfields-sort-order
+ '((notes . 0) (url . 1) (ftp . 2) (gopher . 3) (telnet . 4) (mail-alias . 5)
+ (mail-folder . 6) (lpr . 7))
+ "The order for sorting the xfields.
+If an xfield is not in the alist, it is assigned weight 100, so all xfields
+with weights less then 100 will be in the beginning, and all xfields with
+weights more than 100 will be in the end."
+ :group 'bbdb-mua
+ :type '(repeat (cons
+ (symbol :tag "xfield")
+ (number :tag "Weight"))))
+(define-obsolete-variable-alias 'bbdb-notes-sort-order
'bbdb-xfields-sort-order "3.0")
+
+(defcustom bbdb-merge-xfield-function-alist nil
+ "Alist defining merging functions for particular xfields.
+Each element is of the form (LABEL . MERGE-FUN).
+For merging xfield LABEL, this will use MERGE-FUN."
+ :group 'bbdb-mua
+ :type '(repeat (cons
+ (symbol :tag "xfield")
+ (function :tag "merge function"))))
+(define-obsolete-variable-alias 'bbdb-merge-notes-function-alist
+ 'bbdb-merge-xfield-function-alist "3.0")
+
+(defcustom bbdb-mua-summary-unification-list
+ '(name mail message-name message-mail message-address)
+ "List of FIELDs considered by `bbdb-mua-summary-unify'.
+For the RECORD matching the address of a message, `bbdb-mua-summary-unify'
+returns the first non-empty field value matching an element FIELD from this
list.
+Each element FIELD may be a valid argument of `bbdb-record-field' for RECORD.
+In addition, this list may also include the following elements:
+ message-name The name in the address of the message
+ message-mail The mail in the address of the message
+ message-address The complete address of the message
+These provide a fallback if a message does not have a matching RECORD
+or if some FIELD of RECORD is empty."
+ :group 'bbdb-mua
+ :type '(repeat (symbol :tag "Field")))
+
+(defcustom bbdb-mua-summary-mark-field 'mark-char
+ "BBDB xfield whose value is used to mark message addresses known to BBDB.
+This may also be a function, called with one arg, the record, which should
+return the mark. See `bbdb-mua-summary-mark' and `bbdb-mua-summary-unify'.
+See also `bbdb-mua-summary-mark'."
+ :group 'bbdb-mua-gnus
+ :type 'symbol)
+
+(defcustom bbdb-mua-summary-mark "+"
+ "Default mark for message addresses known to BBDB.
+If nil do not mark message addresses known to BBDB.
+See `bbdb-mua-summary-mark' and `bbdb-mua-summary-unify'.
+See also `bbdb-mua-summary-mark-field'."
+ :group 'bbdb-mua
+ :type '(choice (string :tag "Mark used")
+ (const :tag "Do not mark known posters" nil)))
+
+(defcustom bbdb-mua-summary-unify-format-letter "B"
+ "Letter required for `bbdb-mua-summary-unify' in the MUA Summary format
string.
+For Gnus, combine it with the %u specifier in `gnus-summary-line-format'
+\(see there), for example use \"%U%R%z%I%(%[%4L: %-23,23uB%]%) %s\\n\".
+For VM, combine it with the %U specifier in `vm-summary-format' (see there),
+for example, use \"%n %*%a %-17.17UB %-3.3m %2d %4l/%-5c %I\\\"%s\\\"\\n\".
+This customization of `gnus-summary-line-format' / `vm-summary-format'
+is required to use `bbdb-mua-summary-unify'.
+Currently no other MUAs support this BBDB feature."
+ :group 'bbdb-mua
+ :type 'string)
+
+(defcustom bbdb-mua-summary-mark-format-letter "b"
+ "Letter required for `bbdb-mua-summary-mark' in the MUA Summary format
string.
+For Gnus, combine it with the %u specifier in `gnus-summary-line-format'
+\(see there), for example, use \"%U%R%z%I%(%[%4L: %ub%-23,23f%]%) %s\\n\".
+For VM, combine it with the %U specifier in `vm-summary-format' (see there),
+for example, use \"%n %*%a %Ub%-17.17F %-3.3m %2d %4l/%-5c %I\\\"%s\\\"\\n\".
+This customization of `gnus-summary-line-format' / `vm-summary-format'
+is required to use `bbdb-mua-summary-mark'.
+Currently no other MUAs support this BBDB feature."
+ :group 'bbdb-mua
+ :type 'string)
+
+
+;;; Sending mail
+(defcustom bbdb-mail-user-agent mail-user-agent
+ "Mail user agent used by BBDB.
+Allowed values are those allowed for `mail-user-agent'."
+ :group 'bbdb-sendmail
+ :type '(radio (function-item :tag "Message package"
+ :format "%t\n"
+ message-user-agent)
+ (function-item :tag "Mail package"
+ :format "%t\n"
+ sendmail-user-agent)
+ (function-item :tag "Emacs interface to MH"
+ :format "%t\n"
+ mh-e-user-agent)
+ (function-item :tag "Message with full Gnus features"
+ :format "%t\n"
+ gnus-user-agent)
+ (function-item :tag "VM"
+ :format "%t\n"
+ vm-user-agent)
+ (function :tag "Other")
+ (const :tag "Default" nil)))
+
+(defcustom bbdb-mail-name-format 'first-last
+ "Format for names when sending mail.
+If first-last format names as \"Firstname Lastname\".
+If last-first format names as \"Lastname, Firstname\".
+If `bbdb-mail-name' returns the full name as a single string, this takes
+precedence over `bbdb-mail-name-format'. Likewise, if the mail address itself
+includes a name, this is not reformatted."
+ :group 'bbdb-sendmail
+ :type '(choice (const :tag "Firstname Lastname" first-last)
+ (const :tag "Lastname, Firstname" last-first)))
+
+(defcustom bbdb-mail-name 'mail-name
+ "Xfield holding the full name for a record when sending mail.
+This may also be a function taking one argument, a record.
+If it returns the full mail name as a single string, this is used \"as is\".
+If it returns a cons pair (FIRST . LAST) with the first and last name
+for this record, these are formatted obeying `bbdb-mail-name-format'."
+ :group 'bbdb-sendmail
+ :type '(choice (symbol :tag "xfield")
+ (function :tag "mail name function")))
+
+(defcustom bbdb-mail-alias-field 'mail-alias
+ "Xfield holding the mail alias for a record.
+Used by `bbdb-mail-aliases'. See also `bbdb-mail-alias'."
+ :group 'bbdb-sendmail
+ :type 'symbol)
+
+(defcustom bbdb-mail-alias 'first
+ "Defines which mail aliases are generated for a BBDB record.
+first: Generate one alias \"<alias>\" that expands to the first mail address
+ of a record.
+star: Generate a second alias \"<alias>*\" that expands to all mail addresses
+ of a record.
+all: Generate the aliases \"<alias>\" and \"<alias>*\" (as for 'star)
+ and aliases \"<alias>n\" for each mail address, where n is the position
+ of the mail address of a record."
+ :group 'bbdb-sendmail
+ :type '(choice (symbol :tag "Only first" first)
+ (symbol :tag "<alias>* for all mails" star)
+ (symbol :tag "All aliases" all)))
+
+(defcustom bbdb-mail-avoid-redundancy nil
+ "Mail address to use for BBDB records when sending mail.
+If non-nil do not use full name in mail address when same as mail.
+If value is mail-only never use full name."
+ :group 'bbdb-sendmail
+ :type '(choice (const :tag "Allow redundancy" nil)
+ (const :tag "Never use full name" mail-only)
+ (const :tag "Avoid redundancy" t)))
+
+(defcustom bbdb-complete-mail t
+ "If t MUA insinuation provides key binding for command `bbdb-complete-mail'."
+ :group 'bbdb-sendmail
+ :type 'boolean)
+
+(defcustom bbdb-completion-list t
+ "Controls the behaviour of `bbdb-complete-mail'.
+If a list of symbols, it specifies which fields to complete. Symbols include
+ fl-name (= first and last name)
+ lf-name (= last and first name)
+ organization
+ aka
+ mail (= all email addresses of each record)
+ primary (= first email address of each record)
+If t, completion is done for all of the above.
+If nil, no completion is offered."
+ ;; These symbols match the fields for which BBDB provides entries in
+ ;; `bbdb-hashtable'.
+ :group 'bbdb-sendmail
+ :type '(choice (const :tag "No Completion" nil)
+ (const :tag "Complete across all fields" t)
+ (repeat :tag "Field"
+ (choice (const fl-name)
+ (const lf-name)
+ (const aka)
+ (const organization)
+ (const primary)
+ (const mail)))))
+
+(defcustom bbdb-complete-mail-allow-cycling nil
+ "If non-nil cycle mail addresses when calling `bbdb-complete-mail'."
+ :group 'bbdb-sendmail
+ :type 'boolean)
+
+(defcustom bbdb-complete-mail-hook nil
+ "List of functions called after a sucessful completion."
+ :group 'bbdb-sendmail
+ :type 'hook)
+
+(defcustom bbdb-mail-abbrev-expand-hook nil
+ ;; Replacement for function `mail-abbrev-expand-hook'.
+ "Function (not hook) run each time an alias is expanded.
+The function is called with two args the alias and the list
+of corresponding mail addresses."
+ :group 'bbdb-sendmail
+ :type 'function)
+
+(defcustom bbdb-completion-display-record t
+ "If non-nil `bbdb-complete-mail' displays the BBDB record after completion."
+ :group 'bbdb-sendmail
+ :type '(choice (const :tag "Update the BBDB buffer" t)
+ (const :tag "Do not update the BBDB buffer" nil)))
+
+
+;;;Dialing
+(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-utilities-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-utilities-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-utilities-dialing
+ :type '(choice (const :tag "No digits required" nil)
+ (string :tag "Dial this first" "1")))
+
+(defcustom bbdb-dial-function nil
+ "If non-nil this should be a function used for dialing phone numbers.
+This function is used by `bbdb-dial-number'. It requires one
+argument which is a string for the number that is dialed.
+If nil then `bbdb-dial-number' uses the tel URI syntax passed to `browse-url'
+to make the call."
+ :group 'bbdb-utilities-dialing
+ :type 'function)
+
+
+;; Faces for font-lock
+(defgroup bbdb-faces nil
+ "Faces used by BBDB."
+ :group 'bbdb
+ :group 'faces)
+
+(defface bbdb-name
+ '((t (:inherit font-lock-function-name-face)))
+ "Face used for BBDB names."
+ :group 'bbdb-faces)
+
+;; KEY needs to match the value of the xfield name-face, which is a string.
+;; To avoid confusion, we make KEY a string, too, though symbols might be
+;; faster.
+(defcustom bbdb-name-face-alist nil
+ "Alist used for font-locking the name of a record.
+Each element should be a cons cell (KEY . FACE) with string KEY and face FACE.
+To use FACE for font-locking the name of a record,
+the xfield name-face of this record should have the value KEY.
+The value of name-face may also be a face which is then used directly.
+If none of these schemes succeeds, the face `bbdb-name' is used."
+ :group 'bbdb-faces
+ :type '(repeat (cons (symbol :tag "Key") (face :tag "Face"))))
+
+(defface bbdb-organization
+ '((t (:inherit font-lock-comment-face)))
+ "Face used for BBDB names."
+ :group 'bbdb-faces)
+
+(defface bbdb-field-name
+ '((t (:inherit font-lock-variable-name-face)))
+ "Face used for BBDB names."
+ :group 'bbdb-faces)
+
+;;; Internal variables
+(eval-and-compile
+ (defvar bbdb-debug t
+ "Enable debugging if non-nil during compile time.
+You really should not disable debugging. But it will speed things up."))
+
+(defconst bbdb-file-format 9
+ "BBDB file format.")
+
+(defconst bbdb-record-type
+ '(vector (or string (const nil)) ; first name
+ (or string (const nil)) ; last name
+ (repeat string) ; affix
+ (repeat string) ; aka
+ (repeat string) ; organization
+ (repeat (or (vector string string)
+ (vector string integer integer integer integer))) ;
phone
+ (repeat (vector string (repeat string) string string
+ string string)) ; address
+ (repeat string) ; mail
+ (repeat (cons symbol sexp)) ; xfields
+ (cons symbol string) ; uuid
+ (cons symbol string) ; creation-date
+ (cons symbol string) ; timestamp
+ sexp) ; cache
+ "Pseudo-code for the structure of a record. Used by `bbdb-check-type'.")
+
+(defconst bbdb-file-coding-system 'utf-8
+ "Coding system used for reading and writing `bbdb-file'.")
+
+(defvar bbdb-mail-aliases-need-rebuilt nil
+ "Non-nil if mail aliases need to be rebuilt.")
+
+(defvar bbdb-buffer nil "Buffer visiting `bbdb-file'.")
+
+(defvar bbdb-buffer-name "*BBDB*" "Name of the BBDB buffer.")
+
+(defvar bbdb-silent-internal nil
+ "Bind this to t to quiet things down - do not set it.
+See also `bbdb-silent'.")
+
+(defvar bbdb-init-forms
+ '((gnus ; gnus 3.15 or newer
+ (add-hook 'gnus-startup-hook 'bbdb-insinuate-gnus))
+ (mh-e ; MH-E
+ (add-hook 'mh-folder-mode-hook 'bbdb-insinuate-mh))
+ (rmail ; RMAIL
+ (add-hook 'rmail-mode-hook 'bbdb-insinuate-rmail))
+ (vm ; newer versions of vm do not have
`vm-load-hook'
+ (eval-after-load "vm" '(bbdb-insinuate-vm)))
+ (mail ; the standard mail user agent
+ (add-hook 'mail-setup-hook 'bbdb-insinuate-mail))
+ (sendmail
+ (progn (message "BBDB: sendmail insinuation deprecated. Use mail.")
+ (add-hook 'mail-setup-hook 'bbdb-insinuate-mail)))
+ (message ; the gnus mail user agent
+ (add-hook 'message-setup-hook 'bbdb-insinuate-message))
+ (mu4e ; the mu4e user agent
+ (add-hook 'mu4e-main-mode-hook 'bbdb-insinuate-mu4e))
+
+ (sc ; supercite
+ (add-hook 'sc-load-hook 'bbdb-insinuate-sc))
+ (anniv ; anniversaries
+ (add-hook 'diary-list-entries-hook 'bbdb-anniv-diary-entries))
+ (pgp ; pgp-mail
+ (progn
+ (add-hook 'message-send-hook 'bbdb-pgp)
+ (add-hook 'mail-send-hook 'bbdb-pgp)))
+ (wl
+ (add-hook 'wl-init-hook 'bbdb-insinuate-wl)))
+ "Alist mapping features to insinuation forms.")
+
+(defvar bbdb-search-invert nil
+ "Bind this variable to t in order to invert the result of `bbdb-search'.")
+
+(defvar bbdb-do-all-records nil
+ "Controls the behavior of the command `bbdb-do-all-records'.")
+
+(defvar bbdb-append-display nil
+ "Controls the behavior of the command `bbdb-append-display'.")
+
+(defvar bbdb-offer-to-create nil
+ "For communication between `bbdb-update-records' and `bbdb-query-create'.")
+
+(defvar bbdb-update-records-address nil
+ "For communication between `bbdb-update-records' and `bbdb-query-create'.
+It is a list with elements (NAME MAIL HEADER HEADER-CLASS MUA).")
+
+;;; Buffer-local variables for the database.
+(defvar bbdb-records nil
+ "BBDB records list.
+In buffer `bbdb-file' this list includes all records.
+In the *BBDB* buffers it includes the records that are actually displayed
+and its elements are (RECORD DISPLAY-FORMAT MARKER-POS).")
+(make-variable-buffer-local 'bbdb-records)
+
+(defvar bbdb-changed-records nil
+ "List of records that has been changed since BBDB was last saved.
+Use `bbdb-search-changed' to display these records.")
+
+(defvar bbdb-end-marker nil
+ "Marker holding the buffer position of the end of the last record.")
+
+(defvar bbdb-hashtable (make-hash-table :test 'equal)
+ "Hash table for BBDB records.
+Hashes the fields first-last-name, last-first-name, organization, aka, and
mail.")
+
+(defvar bbdb-uuid-table (make-hash-table :test 'equal)
+ "Hash table for uuid's of BBDB records.")
+
+(defvar bbdb-xfield-label-list nil
+ "List of labels for xfields.")
+
+(defvar bbdb-organization-list nil
+ "List of organizations known to BBDB.")
+
+(defvar bbdb-street-list nil
+ "List of streets known to BBDB.")
+
+(defvar bbdb-city-list nil
+ "List of cities known to BBDB.")
+
+(defvar bbdb-state-list nil
+ "List of states known to BBDB.")
+
+(defvar bbdb-postcode-list nil
+ "List of post codes known to BBDB.")
+
+(defvar bbdb-country-list nil
+ "List of countries known to BBDB.")
+
+(defvar bbdb-modeline-info (make-vector 6 nil)
+ "Precalculated mode line info for BBDB commands.
+This is a vector [APPEND-M APPEND INVERT-M INVERT ALL-M ALL].
+APPEND-M is the mode line info if `bbdb-append-display' is non-nil.
+INVERT-M is the mode line info if `bbdb-search-invert' is non-nil.
+ALL-M is the mode line info if `bbdb-do-all-records' is non-nil.
+APPEND, INVERT, and ALL appear in the message area.")
+
+(defvar bbdb-update-unchanged-records nil
+ "If non-nil update unchanged records in the database.
+Normally calls of `bbdb-change-hook' and updating of a record are suppressed,
+if an editing command did not really change the record. Bind this to t
+if you want to call `bbdb-change-hook' and update the record unconditionally.")
+
+;;; Keymap
+(defvar bbdb-mode-map
+ (let ((km (make-sparse-keymap)))
+ (define-key km "*" 'bbdb-do-all-records)
+ (define-key km "+" 'bbdb-append-display)
+ (define-key km "!" 'bbdb-search-invert)
+ (define-key km "a" 'bbdb-add-mail-alias)
+ (define-key km "A" 'bbdb-mail-aliases)
+ (define-key km "c" 'bbdb-create)
+ (define-key km "e" 'bbdb-edit-field)
+ (define-key km ";" 'bbdb-edit-foo)
+ (define-key km "n" 'bbdb-next-record)
+ (define-key km "p" 'bbdb-prev-record)
+ (define-key km "N" 'bbdb-next-field)
+ (define-key km "\t" 'bbdb-next-field) ; TAB
+ (define-key km "P" 'bbdb-prev-field)
+ (define-key km "\d" 'bbdb-prev-field) ; DEL
+ (define-key km "d" 'bbdb-delete-field-or-record)
+ (define-key km "\C-k" 'bbdb-delete-field-or-record)
+ (define-key km "i" 'bbdb-insert-field)
+ (define-key km "s" 'bbdb-save)
+ (define-key km "\C-x\C-s" 'bbdb-save)
+ (define-key km "t" 'bbdb-toggle-records-layout)
+ (define-key km "T" 'bbdb-display-records-completely)
+ (define-key km "o" 'bbdb-omit-record)
+ (define-key km "m" 'bbdb-mail)
+ (define-key km "M" 'bbdb-mail-address)
+ (define-key km "\M-d" 'bbdb-dial)
+ (define-key km "h" 'bbdb-info)
+ (define-key km "?" 'bbdb-help)
+ ;; (define-key km "q" 'quit-window) ; part of `special-mode' bindings
+ (define-key km "\C-x\C-t" 'bbdb-transpose-fields)
+ (define-key km "Cr" 'bbdb-copy-records-as-kill)
+ (define-key km "Cf" 'bbdb-copy-fields-as-kill)
+ (define-key km "u" 'bbdb-browse-url)
+ (define-key km "\C-c\C-t" 'bbdb-tex)
+ (define-key km "=" 'delete-other-windows)
+
+ ;; Search keys
+ (define-key km "b" 'bbdb)
+ (define-key km "/1" 'bbdb-display-records)
+ (define-key km "/n" 'bbdb-search-name)
+ (define-key km "/o" 'bbdb-search-organization)
+ (define-key km "/p" 'bbdb-search-phone)
+ (define-key km "/a" 'bbdb-search-address)
+ (define-key km "/m" 'bbdb-search-mail)
+ (define-key km "/N" 'bbdb-search-xfields)
+ (define-key km "/x" 'bbdb-search-xfields)
+ (define-key km "/c" 'bbdb-search-changed)
+ (define-key km "/d" 'bbdb-search-duplicates)
+ (define-key km "\C-xnw" 'bbdb-display-all-records)
+ (define-key km "\C-xnd" 'bbdb-display-current-record)
+
+ (define-key km [delete] 'scroll-down) ; 24.1: part of `special-mode'
+ (define-key km " " 'scroll-up) ; 24.1: part of `special-mode'
+
+ (define-key km [mouse-3] 'bbdb-mouse-menu)
+ (define-key km [mouse-2] (lambda (event)
+ ;; Toggle record layout
+ (interactive "e")
+ (save-excursion
+ (posn-set-point (event-end event))
+ (bbdb-toggle-records-layout
+ (bbdb-do-records t) current-prefix-arg))))
+ km)
+ "Keymap for Insidious Big Brother Database.
+This is a child of `special-mode-map'.")
+
+(easy-menu-define
+ bbdb-menu bbdb-mode-map "BBDB Menu"
+ '("BBDB"
+ ("Display"
+ ["Previous field" bbdb-prev-field t]
+ ["Next field" bbdb-next-field t]
+ ["Previous record" bbdb-prev-record t]
+ ["Next record" bbdb-next-record t]
+ "--"
+ ["Show all records" bbdb-display-all-records t]
+ ["Show current record" bbdb-display-current-record t]
+ ["Omit record" bbdb-omit-record t]
+ "--"
+ ["Toggle layout" bbdb-toggle-records-layout t]
+ ["Show all fields" bbdb-display-records-completely t])
+ ("Searching"
+ ["General search" bbdb t]
+ ["Search one record" bbdb-display-records t]
+ ["Search name" bbdb-search-name t]
+ ["Search organization" bbdb-search-organization t]
+ ["Search phone" bbdb-search-phone t]
+ ["Search address" bbdb-search-address t]
+ ["Search mail" bbdb-search-mail t]
+ ["Search xfields" bbdb-search-xfields t]
+ ["Search changed records" bbdb-search-changed t]
+ ["Search duplicates" bbdb-search-duplicates t]
+ "--"
+ ["Old time stamps" bbdb-timestamp-older t]
+ ["New time stamps" bbdb-timestamp-newer t]
+ ["Old creation date" bbdb-creation-older t]
+ ["New creation date" bbdb-creation-newer t]
+ ["Creation date = time stamp" bbdb-creation-no-change t]
+ "--"
+ ["Append search" bbdb-append-display t]
+ ["Invert search" bbdb-search-invert t])
+ ("Mail"
+ ["Send mail" bbdb-mail t]
+ ["Save mail address" bbdb-mail-address t]
+ "--"
+ ["Add mail alias" bbdb-add-mail-alias t]
+ ["(Re-)Build mail aliases" bbdb-mail-aliases t])
+ ("Use database"
+ ["Prefix: do all records" bbdb-do-all-records t]
+ "--"
+ ["Send mail" bbdb-mail t]
+ ["Dial phone number" bbdb-dial t]
+ ["Browse URL" bbdb-browse-url t]
+ ["Copy records as kill" bbdb-copy-records-as-kill t]
+ ["Copy fields as kill" bbdb-copy-fields-as-kill t]
+ "--"
+ ["TeX records" bbdb-tex t])
+ ("Manipulate database"
+ ["Prefix: do all records" bbdb-do-all-records t]
+ "--"
+ ["Create new record" bbdb-create t]
+ ["Edit current field" bbdb-edit-field t]
+ ["Insert new field" bbdb-insert-field t]
+ ["Edit some field" bbdb-edit-foo t]
+ ["Transpose fields" bbdb-transpose-fields t]
+ ["Delete record or field" bbdb-delete-field-or-record t]
+ "--"
+ ["Sort addresses" bbdb-sort-addresses t]
+ ["Sort phones" bbdb-sort-phones t]
+ ["Sort xfields" bbdb-sort-xfields t]
+ ["Merge records" bbdb-merge-records t]
+ ["Sort database" bbdb-sort-records t]
+ ["Delete duplicate mails" bbdb-delete-redundant-mails t]
+ "--"
+ ["Save BBDB" bbdb-save t]
+ ["Revert BBDB" revert-buffer t])
+ ("Help"
+ ["Brief help" bbdb-help t]
+ ["BBDB Manual" bbdb-info t])
+ "--"
+ ["Quit" quit-window t]))
+
+(defvar bbdb-completing-read-mails-map
+ (let ((map (copy-keymap minibuffer-local-completion-map)))
+ (define-key map " " 'self-insert-command)
+ (define-key map "\t" 'bbdb-complete-mail)
+ (define-key map "\M-\t" 'bbdb-complete-mail)
+ map)
+ "Keymap used by `bbdb-completing-read-mails'.")
+
+
+
+;;; Helper functions
+
+(defun bbdb-warn (&rest args)
+ "Display a message at the bottom of the screen.
+ARGS are passed to `message'."
+ (ding t)
+ (apply 'message args))
+
+(defun bbdb-string-trim (string &optional null)
+ "Remove leading and trailing whitespace and all properties from STRING.
+If STRING is nil return an empty string unless NULL is non-nil."
+ (if (null string)
+ (unless null "")
+ (setq string (substring-no-properties string))
+ (if (string-match "\\`[ \t\n]+" string)
+ (setq string (substring-no-properties string (match-end 0))))
+ (if (string-match "[ \t\n]+\\'" string)
+ (setq string (substring-no-properties string 0 (match-beginning 0))))
+ (unless (and null (string= "" string))
+ string)))
+
+(defsubst bbdb-string= (str1 str2)
+ "Return t if strings STR1 and STR2 are equal, ignoring case."
+ (and (stringp str1) (stringp str2)
+ (eq t (compare-strings str1 0 nil str2 0 nil t))))
+
+(defun bbdb-split (separator string)
+ "Split STRING into list of substrings bounded by matches for SEPARATORS.
+SEPARATOR may be a regexp. SEPARATOR may also be a symbol
+\(a field name). Then look up the value in `bbdb-separator-alist'
+or use `bbdb-default-separator'.
+Whitespace around SEPARATOR is ignored unless SEPARATOR matches
+the string \" \\t\\n\".
+Almost the inverse function of `bbdb-concat'."
+ (if (symbolp separator)
+ (setq separator (car (or (cdr (assq separator bbdb-separator-alist))
+ bbdb-default-separator))))
+ (if (<= 24.4 (string-to-number emacs-version))
+ ;; `split-string' applied to an empty STRING gives nil.
+ (split-string string separator t
+ (unless (string-match separator " \t\n") "[ \t\n]*"))
+ (unless (string-match separator " \t\n")
+ (setq separator (concat "[ \t\n]*" separator "[ \t\n]*")))
+ (split-string (bbdb-string-trim string) separator t)))
+
+(defun bbdb-concat (separator &rest strings)
+ "Concatenate STRINGS to a string sticking in SEPARATOR.
+STRINGS may be strings or lists of strings. Empty strings are ignored.
+SEPARATOR may be a string.
+SEPARATOR may also be a symbol (a field name). Then look up the value
+of SEPARATOR in `bbdb-separator-alist' or use `bbdb-default-separator'.
+The inverse function of `bbdb-split'."
+ (if (symbolp separator)
+ (setq separator (nth 1 (or (cdr (assq separator bbdb-separator-alist))
+ bbdb-default-separator))))
+ (mapconcat 'identity
+ (delete "" (apply 'append (mapcar (lambda (x) (if (stringp x)
+ (list x) x))
+ strings))) separator))
+
+(defun bbdb-list-strings (list)
+ "Remove all elements from LIST which are not non-empty strings."
+ (let (new-list)
+ (dolist (elt list)
+ (if (and (stringp elt) (not (string= "" elt)))
+ (push elt new-list)))
+ (nreverse new-list)))
+
+;; A call of `indent-region' swallows any indentation
+;; that might be part of the field itself. So we indent manually.
+(defsubst bbdb-indent-string (string column)
+ "Indent nonempty lines in STRING to COLUMN (except first line).
+This happens in addition to any pre-defined indentation of STRING."
+ (replace-regexp-in-string "\n\\([^\n]\\)"
+ (concat "\n" (make-string column ?\s) "\\1")
+ string))
+
+(defun bbdb-read-string (prompt &optional init collection require-match)
+ "Read a string, trimming whitespace and text properties.
+PROMPT is a string to prompt with.
+INIT appears as initial input which is useful for editing existing records.
+COLLECTION and REQUIRE-MATCH have the same meaning as in `completing-read'."
+ (bbdb-string-trim
+ (if collection
+ ;; Hack: In `minibuffer-local-completion-map' remove
+ ;; the binding of SPC to `minibuffer-complete-word'
+ ;; and of ? to `minibuffer-completion-help'.
+ (minibuffer-with-setup-hook
+ (lambda ()
+ (use-local-map
+ (let ((map (make-sparse-keymap)))
+ (set-keymap-parent map (current-local-map))
+ (define-key map " " nil)
+ (define-key map "?" nil)
+ map)))
+ (completing-read prompt collection nil require-match init))
+ (read-string prompt init))))
+
+;; The following macros implement variants of `pushnew' (till emacs 24.2)
+;; or `cl-pushnew' (since emacs 24.3). To be compatible with older and newer
+;; versions of emacs we use our own macros. We call these macros often.
+;; So we keep them simple. Nothing fancy is needed here.
+(defmacro bbdb-pushnew (element listname)
+ "Add ELEMENT to the value of LISTNAME if it isn't there yet.
+The test for presence of ELEMENT is done with `equal'.
+The return value is the new value of LISTNAME."
+ `(let ((elt ,element))
+ (if (member elt ,listname)
+ ,listname
+ (setq ,listname (cons elt ,listname)))))
+
+(defmacro bbdb-pushnewq (element listname)
+ "Add ELEMENT to the value of LISTNAME if it isn't there yet.
+The test for presence of ELEMENT is done with `eq'.
+The return value is the new value of LISTNAME."
+ `(let ((elt ,element))
+ (if (memq elt ,listname)
+ ,listname
+ (setq ,listname (cons elt ,listname)))))
+
+(defmacro bbdb-pushnewt (element listname)
+ "Add ELEMENT to the value of LISTNAME if it isn't there yet and non-nil.
+The test for presence of ELEMENT is done with `equal'.
+The return value is the new value of LISTNAME."
+ `(let ((elt ,element))
+ (if (or (not elt)
+ (member elt ,listname))
+ ,listname
+ (setq ,listname (cons elt ,listname)))))
+
+(defun bbdb-current-record (&optional full)
+ "Return the record point is at.
+If FULL is non-nil record includes the display information."
+ (unless (eq major-mode 'bbdb-mode)
+ (error "This only works while in BBDB buffers."))
+ (let ((num (get-text-property (if (and (not (bobp)) (eobp))
+ (1- (point)) (point))
+ 'bbdb-record-number))
+ record)
+ (unless num (error "Not a BBDB record"))
+ (setq record (nth num bbdb-records))
+ (if full record (car record))))
+
+(defun bbdb-current-field ()
+ "Return current field point is on."
+ (unless (bbdb-current-record) (error "Not a BBDB record"))
+ (get-text-property (point) 'bbdb-field))
+
+(defmacro bbdb-debug (&rest body)
+ "Excecute BODY just like `progn' with debugging capability.
+Debugging is enabled if variable `bbdb-debug' is non-nil during compile.
+You really should not disable debugging. But it will speed things up."
+ (declare (indent 0))
+ (if bbdb-debug ; compile-time switch
+ `(let ((debug-on-error t))
+ ,@body)))
+
+;; inspired by `gnus-bind-print-variables'
+(defmacro bbdb-with-print-loadably (&rest body)
+ "Bind print-* variables for BBDB and evaluate BODY.
+This macro is used with `prin1', `prin1-to-string', etc. in order to ensure
+printed Lisp objects are loadable by BBDB."
+ (declare (indent 0))
+ `(let ((print-escape-newlines t) ;; BBDB needs this!
+ print-escape-nonascii print-escape-multibyte
+ print-quoted print-length print-level)
+ ;; print-circle print-gensym
+ ;; print-continuous-numbering
+ ;; print-number-table
+ ;; float-output-format
+ ,@body))
+
+(defun bbdb-timestamp (_record)
+ ""
+ (unless (get 'bbdb-timestamp 'bbdb-obsolete)
+ (put 'bbdb-timestamp 'bbdb-obsolete t)
+ (message "Function `bbdb-timestamp' is obsolete. Remove it from any
hooks.")
+ (sit-for 2)))
+(make-obsolete 'bbdb-timestamp nil "2017-08-09")
+
+(defun bbdb-creation-date (_record)
+ ""
+ (unless (get 'bbdb-creation-date 'bbdb-obsolete)
+ (put 'bbdb-creation-date 'bbdb-obsolete t)
+ (message "Function `bbdb-creation-date' is obsolete. Remove it from any
hooks.")
+ (sit-for 2)))
+(make-obsolete 'bbdb-creation-date nil "2017-08-09")
+
+;; Copied from org-id.el
+(defun bbdb-uuid ()
+ "Return string with random (version 4) UUID."
+ (let ((rnd (md5 (format "%s%s%s%s%s%s%s"
+ (random)
+ (current-time)
+ (user-uid)
+ (emacs-pid)
+ (user-full-name)
+ user-mail-address
+ (recent-keys)))))
+ (format "%s-%s-4%s-%s%s-%s"
+ (substring rnd 0 8)
+ (substring rnd 8 12)
+ (substring rnd 13 16)
+ (format "%x"
+ (logior
+ #b10000000
+ (logand
+ #b10111111
+ (string-to-number
+ (substring rnd 16 18) 16))))
+ (substring rnd 18 20)
+ (substring rnd 20 32))))
+
+(defun bbdb-multiple-buffers-default ()
+ "Default function for guessing a name for new *BBDB* buffers.
+May be used as value of variable `bbdb-multiple-buffers'."
+ (save-current-buffer
+ (cond ((memq major-mode '(vm-mode vm-summary-mode vm-presentation-mode
+ vm-virtual-mode))
+ (vm-select-folder-buffer)
+ (buffer-name))
+ ((memq major-mode '(gnus-summary-mode gnus-group-mode))
+ (set-buffer gnus-article-buffer)
+ (buffer-name))
+ ((memq major-mode '(mail-mode vm-mail-mode message-mode))
+ "message composition"))))
+
+(defsubst bbdb-add-job (spec record string)
+ "Internal function: Evaluate SPEC for RECORD and STRING.
+If SPEC is a function call it with args RECORD and STRING. Return value.
+If SPEC is a regexp, return 'query unless SPEC matches STRING.
+Otherwise return SPEC.
+Used with variable `bbdb-add-name' and friends."
+ (cond ((functionp spec)
+ (funcall spec record string))
+ ((stringp spec)
+ (unless (string-match spec string) 'query)) ; be least aggressive
+ (spec)))
+
+(defsubst bbdb-eval-spec (spec prompt)
+ "Internal function: Evaluate SPEC using PROMPT.
+Return t if either SPEC equals t, or SPEC equals 'query and `bbdb-silent'
+is non-nil or `y-or-no-p' returns t using PROMPT.
+Used with return values of `bbdb-add-job'."
+ (or (eq spec t)
+ (and (eq spec 'query)
+ (or bbdb-silent (y-or-n-p prompt)))))
+
+(defun bbdb-clean-address-components (components)
+ "Clean mail address COMPONENTS.
+COMPONENTS is a list (FULL-NAME CANONICAL-ADDRESS) as returned
+by `mail-extract-address-components'.
+Pass FULL-NAME through `bbdb-message-clean-name-function'
+and CANONICAL-ADDRESS through `bbdb-canonicalize-mail-function'."
+ (list (if (car components)
+ (if bbdb-message-clean-name-function
+ (funcall bbdb-message-clean-name-function (car components))
+ (car components)))
+ (if (cadr components)
+ (if bbdb-canonicalize-mail-function
+ (funcall bbdb-canonicalize-mail-function (cadr components))
+ ;; Minimalistic clean-up
+ (bbdb-string-trim (cadr components))))))
+
+(defun bbdb-extract-address-components (address &optional all)
+ "Given an RFC-822 address ADDRESS, extract full name and canonical address.
+This function behaves like `mail-extract-address-components', but it passes
+its return value through `bbdb-clean-address-components'.
+See also `bbdb-decompose-bbdb-address'."
+ (if all
+ (mapcar 'bbdb-clean-address-components
+ (mail-extract-address-components address t))
+ (bbdb-clean-address-components (mail-extract-address-components address))))
+
+;; Inspired by `gnus-extract-address-components' from gnus-utils.
+(defun bbdb-decompose-bbdb-address (mail)
+ "Given an RFC-822 address MAIL, extract full name and canonical address.
+In general, this function behaves like the more sophisticated function
+`mail-extract-address-components'. Yet for an address `<address@hidden>'
+lacking a real name the latter function returns the name \"Joe Smith\".
+This is useful when analyzing the headers of email messages we receive
+from the outside world. Yet when analyzing the mail addresses stored
+in BBDB, this pollutes the mail-aka space. So we define here
+an intentionally much simpler function for decomposing the names
+and canonical addresses in the mail field of BBDB records."
+ (let (name address)
+ ;; First find the address - the thing with the @ in it.
+ (cond (;; Check `<address@hidden>' first in order to handle the quite
common
+ ;; form `"address@hidden" <address@hidden>' (i.e. `@' as part of a
comment)
+ ;; correctly.
+ (string-match "<\\([^@ \t<>address@hidden@ \t<>]+\\)>" mail)
+ (setq address (match-string 1 mail)))
+ ((string-match "\\b[^@ \t<>address@hidden@ \t<>]+\\b" mail)
+ (setq address (match-string 0 mail))))
+ ;; Then check whether the `name <address>' format is used.
+ (and address
+ ;; Linear white space is not required.
+ (string-match (concat "[ \t]*<" (regexp-quote address) ">") mail)
+ (setq name (substring mail 0 (match-beginning 0)))
+ ;; Strip any quotes mail the name.
+ (string-match "^\".*\"$" name)
+ (setq name (substring name 1 (1- (match-end 0)))))
+ ;; If not, then check whether the `address (name)' format is used.
+ (or name
+ (and (string-match "(\\([^)]+\\))" mail)
+ (setq name (match-string 1 mail))))
+ (list (if (equal name "") nil name) (or address mail))))
+
+;;; Massage of mail addresses
+
+(defcustom bbdb-canonical-hosts
+ ;; Example
+ (regexp-opt '("cs.cmu.edu" "ri.cmu.edu"))
+ "Regexp matching the canonical part of the domain part of a mail address.
+If the domain part of a mail address matches this regexp, the domain
+is replaced by the substring that actually matched this address.
+
+Used by `bbdb-canonicalize-mail-1'. See also `bbdb-ignore-redundant-mails'."
+ :group 'bbdb-mua
+ :type '(regexp :tag "Regexp matching sites"))
+
+(defun bbdb-canonicalize-mail-1 (address)
+ "Example of `bbdb-canonicalize-mail-function'.
+However, this function is too specific to be useful for the general user.
+Take it as a source of inspiration for what can be done."
+ (setq address (bbdb-string-trim address))
+ (cond
+ ;; Rewrite mail-drop hosts.
+ ;; RW: The following is now also handled by `bbdb-ignore-redundant-mails'
+ ((string-match
+ (concat "\\`\\(address@hidden@\\).*\\.\\(" bbdb-canonical-hosts "\\)\\'")
+ address)
+ (concat (match-string 1 address) (match-string 2 address)))
+ ;;
+ ;; Here at Lucid, our workstation names sometimes get into our mail
+ ;; addresses in the form "address@hidden" (instead of simply
+ ;; "address@hidden"). This removes the workstation name.
+ ((string-match "\\`\\(address@hidden)address@hidden@\\(lucid\\.com\\)\\'"
address)
+ (concat (match-string 1 address) "@" (match-string 2 address)))
+ ;;
+ ;; Another way that our local mailer is misconfigured: sometimes addresses
+ ;; which should look like "address@hidden" end up looking like
+ ;; "user%some.outside.host" or even "address@hidden"
+ ;; instead. This rule rewrites it into the original form.
+ ((string-match
"\\`\\(address@hidden)%\\(address@hidden)\\(@lucid\\.com\\)?\\'" address)
+ (concat (match-string 1 address) "@" (match-string 2 address)))
+ ;;
+ ;; Sometimes I see addresses like "address@hidden".
+ ;; That's totally redundant, so this rewrites it as "address@hidden".
+ ((string-match "\\`\\(address@hidden)!\\(address@hidden@%]\\1\\)\\'"
address)
+ (match-string 2 address))
+ ;;
+ ;; Sometimes I see addresses like "foobar.com!user". Turn it around.
+ ((string-match "\\`\\(address@hidden@%!]+\\)!\\(address@hidden)\\'" address)
+ (concat (match-string 2 address) "@" (match-string 1 address)))
+ ;;
+ ;; The mailer at hplb.hpl.hp.com tends to puke all over addresses which
+ ;; pass through mailing lists which are maintained there: it turns normal
+ ;; addresses like "address@hidden" into "address@hidden".
+ ;; This reverses it. (I actually could have combined this rule with
+ ;; the similar lucid.com rule above, but then the regexp would have been
+ ;; more than 80 characters long...)
+ ((string-match
"\\`\\(address@hidden)%\\(address@hidden)@hplb\\.hpl\\.hp\\.com\\'"
+ address)
+ (concat (match-string 1 address) "@" (match-string 2 address)))
+ ;;
+ ;; Another local mail-configuration botch: sometimes mail shows up
+ ;; with addresses like "address@hidden", where "workstation" is a
+ ;; local machine name. That should really be "user" or "address@hidden".
+ ;; (I'm told this one is due to a bug in SunOS 4.1.1 sendmail.)
+ ((string-match "\\`\\(address@hidden)address@hidden@%!.]+\\'" address)
+ (match-string 1 address))
+ ;;
+ ;; Sometimes I see addresses like "address@hidden".
+ ;; This is silly, because I know that I can send mail to uunet directly.
+ ((string-match "address@hidden@%!]+\\'" address)
+ (concat (substring address 0 (+ (match-beginning 0) 1)) "@UUNET.UU.NET"))
+ ;;
+ ;; Otherwise, leave it as it is.
+ (t address)))
+
+(defun bbdb-message-clean-name-default (name)
+ "Default function for `bbdb-message-clean-name-function'.
+This strips garbage from the user full NAME string."
+ ;; Remove leading non-alpha chars
+ (if (string-match "\\`[^[:alpha:]]+" name)
+ (setq name (substring name (match-end 0))))
+
+ (if (string-match "^\\(address@hidden)@" name)
+ ;; The name is really a mail address and we use the part preceeding "@".
+ ;; Everything following "@" is ignored.
+ (setq name (match-string 1 name)))
+
+ ;; Replace "firstname.surname" by "firstname surname".
+ ;; Do not replace ". " with " " because that could be an initial.
+ (setq name (replace-regexp-in-string "\\.\\([^ ]\\)" " \\1" name))
+
+ ;; Replace tabs, spaces, and underscores with a single space.
+ (setq name (replace-regexp-in-string "[ \t\n_]+" " " name))
+
+ ;; Remove trailing comments separated by "(" or " [-#]"
+ ;; This does not work all the time because some of our friends in
+ ;; northern europe have brackets in their names...
+ (if (string-match "[^ \t]\\([ \t]*\\((\\| [-#]\\)\\)" name)
+ (setq name (substring name 0 (match-beginning 1))))
+
+ ;; Remove phone extensions (like "x1234" and "ext. 1234")
+ (let ((case-fold-search t))
+ (setq name (replace-regexp-in-string
+ "\\W+\\(x\\|ext\\.?\\)\\W*[-0-9]+" "" name)))
+
+ ;; Remove trailing non-alpha chars
+ (if (string-match "[^[:alpha:]]+\\'" name)
+ (setq name (substring name 0 (match-beginning 0))))
+
+ ;; Remove text properties
+ (substring-no-properties name))
+
+;; BBDB data structure
+(defmacro bbdb-defstruct (name &rest elts)
+ "Define two functions to operate on vector NAME for each symbol ELT in ELTS.
+The function bbdb-NAME-ELT returns the element ELT in vector NAME.
+The function bbdb-NAME-set-ELT sets ELT.
+Also define a constant bbdb-NAME-length that holds the number of ELTS
+in vector NAME."
+ (declare (indent 1))
+ (let* ((count 0)
+ (sname (symbol-name name))
+ (uname (upcase sname))
+ (cname (concat "bbdb-" sname "-"))
+ body)
+ (dolist (elt elts)
+ (let* ((selt (symbol-name elt))
+ (setname (intern (concat cname "set-" selt))))
+ (push (list 'defsubst (intern (concat cname selt)) `(,name)
+ (format "For BBDB %s read element %i `%s'."
+ uname count selt)
+ ;; Use `elt' instead of `aref' so that these functions
+ ;; also work for the `bbdb-record-type' pseudo-code.
+ `(elt ,name ,count)) body)
+ (push (list 'defsubst setname `(,name value)
+ (format "For BBDB %s set element %i `%s' to VALUE. \
+Return VALUE.
+Do not call this function directly. Call instead `bbdb-record-set-field'
+which ensures the integrity of the database. Also, this makes your code
+more robust with respect to possible future changes of BBDB's innermost
+internals."
+ uname count selt)
+ `(aset ,name ,count value)) body))
+ (setq count (1+ count)))
+ (push (list 'defconst (intern (concat cname "length")) count
+ (concat "Length of BBDB `" sname "'.")) body)
+ (cons 'progn body)))
+
+;; Define RECORD:
+(bbdb-defstruct record
+ firstname lastname affix aka organization phone address mail xfields
+ uuid creation-date timestamp cache)
+
+;; Define PHONE:
+(bbdb-defstruct phone
+ label area exchange suffix extension)
+
+;; Define ADDRESS:
+(bbdb-defstruct address
+ label streets city state postcode country)
+
+;; Define record CACHE:
+;; - fl-name (first and last name of the person referred to by the record),
+;; - lf-name (last and first name of the person referred to by the record),
+;; - mail-aka (list of names associated with mail addresses)
+;; - mail-canon (list of canonical mail addresses)
+;; - sortkey (the concatenation of the elements used for sorting the record),
+;; - marker (position of beginning of record in `bbdb-file')
+(bbdb-defstruct cache
+ fl-name lf-name mail-aka mail-canon sortkey marker)
+
+(defsubst bbdb-record-mail-aka (record)
+ "Record cache function: Return mail-aka for RECORD."
+ (bbdb-cache-mail-aka (bbdb-record-cache record)))
+
+(defsubst bbdb-record-mail-canon (record)
+ "Record cache function: Return mail-canon for RECORD."
+ (bbdb-cache-mail-canon (bbdb-record-cache record)))
+
+(defun bbdb-empty-record ()
+ "Return a new empty record structure with a cache.
+It is the caller's responsibility to make the new record known to BBDB."
+ (let ((record (make-vector bbdb-record-length nil)))
+ (bbdb-record-set-cache record (make-vector bbdb-cache-length nil))
+ record))
+
+;; `bbdb-hashtable' associates with each KEY a list of matching records.
+;; KEY includes fl-name, lf-name, organizations, AKAs and email addresses.
+;; When loading the database the hash table is initialized by calling
+;; `bbdb-hash-record' for each record. This function is also called
+;; when new records are added to the database.
+;; `bbdb-delete-record-internal' with arg REMHASH non-nil removes a record
+;; from the hash table (besides deleting the record from the database).
+;; When an existing record is modified, the code that modifies the record
+;; needs to update the hash table, too. This includes removing the outdated
+;; associations between KEYs and record as well as adding the new associations.
+;; This is one reason to modify records by calling `bbdb-record-set-field'
+;; which properly updates the hash table.
+;; The hash table can be accessed via `bbdb-gethash'
+;; and via functions like `completing-read'.
+
+(defun bbdb-puthash (key record)
+ "Associate RECORD with KEY in `bbdb-hashtable'.
+KEY must be a string or nil. Empty strings and nil are ignored."
+ (if (and key (not (string= "" key))) ; do not hash empty strings
+ (let* ((key (downcase key))
+ (records (gethash key bbdb-hashtable)))
+ (puthash key (if records (bbdb-pushnewq record records)
+ (list record))
+ bbdb-hashtable))))
+
+(defun bbdb-gethash (key &optional predicate)
+ "Return list of records associated with KEY in `bbdb-hashtable'.
+KEY must be a string or nil. Empty strings and nil are ignored.
+PREDICATE may take the same values as `bbdb-completion-list'."
+ (when (and key (not (string= "" key)))
+ (let* ((key (downcase key))
+ (all-records (gethash key bbdb-hashtable))
+ records)
+ (if (or (not predicate) (eq t predicate))
+ all-records
+ (dolist (record all-records)
+ (if (catch 'bbdb-hash-ok
+ (bbdb-hash-p key record predicate))
+ (push record records)))
+ records))))
+
+(defun bbdb-hash-p (key record predicate)
+ "Throw `bbdb-hash-ok' non-nil if KEY matches RECORD acording to PREDICATE.
+PREDICATE may take the same values as the elements of `bbdb-completion-list'."
+ (if (and (memq 'fl-name predicate)
+ (bbdb-string= key (or (bbdb-record-name record) "")))
+ (throw 'bbdb-hash-ok 'fl-name))
+ (if (and (memq 'lf-name predicate)
+ (bbdb-string= key (or (bbdb-record-name-lf record) "")))
+ (throw 'bbdb-hash-ok 'lf-name))
+ (if (memq 'organization predicate)
+ (mapc (lambda (organization) (if (bbdb-string= key organization)
+ (throw 'bbdb-hash-ok 'organization)))
+ (bbdb-record-organization record)))
+ (if (memq 'aka predicate)
+ (mapc (lambda (aka) (if (bbdb-string= key aka)
+ (throw 'bbdb-hash-ok 'aka)))
+ (bbdb-record-field record 'aka-all)))
+ (if (and (memq 'primary predicate)
+ (bbdb-string= key (car (bbdb-record-mail-canon record))))
+ (throw 'bbdb-hash-ok 'primary))
+ (if (memq 'mail predicate)
+ (mapc (lambda (mail) (if (bbdb-string= key mail)
+ (throw 'bbdb-hash-ok 'mail)))
+ (bbdb-record-mail-canon record)))
+ nil)
+
+(defun bbdb-remhash (key record)
+ "Remove RECORD from list of records associated with KEY.
+KEY must be a string or nil. Empty strings and nil are ignored."
+ (if (and key (not (string= "" key)))
+ (let* ((key (downcase key))
+ (records (gethash key bbdb-hashtable)))
+ (when records
+ (setq records (delq record records))
+ (if records
+ (puthash key records bbdb-hashtable)
+ (remhash key bbdb-hashtable))))))
+
+(defun bbdb-hash-record (record)
+ "Insert RECORD in `bbdb-hashtable'.
+This performs all initializations required for a new record.
+Do not call this for existing records that require updating."
+ (bbdb-puthash (bbdb-record-name record) record)
+ (bbdb-puthash (bbdb-record-name-lf record) record)
+ (dolist (organization (bbdb-record-organization record))
+ (bbdb-puthash organization record))
+ (dolist (aka (bbdb-record-aka record))
+ (bbdb-puthash aka record))
+ (bbdb-puthash-mail record)
+ (puthash (bbdb-record-uuid record) record bbdb-uuid-table))
+
+(defun bbdb-puthash-mail (record)
+ "For RECORD put mail into `bbdb-hashtable'."
+ (let (mail-aka mail-canon address)
+ (dolist (mail (bbdb-record-mail record))
+ (setq address (bbdb-decompose-bbdb-address mail))
+ (when (car address)
+ (push (car address) mail-aka)
+ (bbdb-puthash (car address) record))
+ (push (nth 1 address) mail-canon)
+ (bbdb-puthash (nth 1 address) record))
+ (bbdb-cache-set-mail-aka (bbdb-record-cache record)
+ (nreverse mail-aka))
+ (bbdb-cache-set-mail-canon (bbdb-record-cache record)
+ (nreverse mail-canon))))
+
+(defun bbdb-hash-update (record old new)
+ "Update hash for RECORD. Remove OLD, insert NEW.
+Both OLD and NEW are lists of values."
+ (dolist (elt old)
+ (bbdb-remhash elt record))
+ (dolist (elt new)
+ (bbdb-puthash elt record)))
+
+(defun bbdb-check-name (first last &optional record)
+ "Check whether the name FIRST LAST is a valid name.
+This throws an error if the name is already used by another record
+and `bbdb-allow-duplicates' is nil. If RECORD is non-nil, FIRST and LAST
+may correspond to RECORD without raising an error."
+ ;; Are there more useful checks for names beyond checking for duplicates?
+ (unless bbdb-allow-duplicates
+ (let* ((name (bbdb-concat 'name-first-last first last))
+ (records (bbdb-gethash name '(fl-name lf-name aka))))
+ (if (or (and (not record) records)
+ (remq record records))
+ (error "%s is already in BBDB" name)))))
+
+(defun bbdb-record-name (record)
+ "Record cache function: Return the full name FIRST_LAST of RECORD.
+Return empty string if both the first and last name are nil.
+If the name is not available in the name cache, the name cache value
+is generated and stored."
+ (or (bbdb-cache-fl-name (bbdb-record-cache record))
+ ;; Build the name cache for a record.
+ (bbdb-record-set-name record t t)))
+
+(defun bbdb-record-name-lf (record)
+ "Record cache function: Return the full name LAST_FIRST of RECORD.
+If the name is not available in the name cache, the name cache value
+is generated and stored."
+ (or (bbdb-cache-lf-name (bbdb-record-cache record))
+ ;; Build the name cache for a record.
+ (progn (bbdb-record-set-name record t t)
+ (bbdb-cache-lf-name (bbdb-record-cache record)))))
+
+(defun bbdb-record-set-name (record first last)
+ "Record cache function: For RECORD set full name based on FIRST and LAST.
+If FIRST or LAST are t use respective existing entries of RECORD.
+Set full name in cache and hash. Return first-last name."
+ (let* ((cache (bbdb-record-cache record))
+ (fl-name (bbdb-cache-fl-name cache))
+ (lf-name (bbdb-cache-lf-name cache)))
+ (if fl-name (bbdb-remhash fl-name record))
+ (if lf-name (bbdb-remhash lf-name record)))
+ (if (eq t first)
+ (setq first (bbdb-record-firstname record))
+ (bbdb-record-set-firstname record first))
+ (if (eq t last)
+ (setq last (bbdb-record-lastname record))
+ (bbdb-record-set-lastname record last))
+ (let ((fl-name (bbdb-concat 'name-first-last first last))
+ (lf-name (bbdb-concat 'name-last-first last first))
+ (cache (bbdb-record-cache record)))
+ ;; Set cache of RECORD
+ (bbdb-cache-set-fl-name cache fl-name)
+ (bbdb-cache-set-lf-name cache lf-name)
+ ;; Set hash. For convenience, the hash contains the full name
+ ;; as first-last and last-fist.
+ (bbdb-puthash fl-name record)
+ (bbdb-puthash lf-name record)
+ fl-name))
+
+(defun bbdb-record-sortkey (record)
+ "Record cache function: Return the sortkey for RECORD.
+Set and store it if necessary."
+ (or (bbdb-cache-sortkey (bbdb-record-cache record))
+ (bbdb-record-set-sortkey record)))
+
+(defun bbdb-record-set-sortkey (record)
+ "Record cache function: Set and return RECORD's sortkey."
+ (bbdb-cache-set-sortkey
+ (bbdb-record-cache record)
+ (downcase
+ (bbdb-concat "" (bbdb-record-lastname record)
+ (bbdb-record-firstname record)
+ (bbdb-record-organization record)))))
+
+(defsubst bbdb-record-marker (record)
+ "Record cache function: Return the marker for RECORD."
+ (bbdb-cache-marker (bbdb-record-cache record)))
+
+(defsubst bbdb-record-set-marker (record marker)
+ "Record cache function: Set and return RECORD's MARKER."
+ (bbdb-cache-set-marker (bbdb-record-cache record) marker))
+
+(defsubst bbdb-record-xfield (record label)
+ "For RECORD return value of xfield LABEL.
+Return nil if xfield LABEL is undefined."
+ (cdr (assq label (bbdb-record-xfields record))))
+
+;; The values of xfields are normally strings. The following function
+;; comes handy if we want to treat these values as symbols.
+(defun bbdb-record-xfield-intern (record label)
+ "For RECORD return interned value of xfield LABEL.
+Return nil if xfield LABEL does not exist."
+ (let ((value (bbdb-record-xfield record label)))
+ ;; If VALUE is not a string, return whatever it is.
+ (if (stringp value) (intern value) value)))
+
+(defun bbdb-record-xfield-string (record label)
+ "For RECORD return value of xfield LABEL as string.
+Return nil if xfield LABEL does not exist."
+ (let ((value (bbdb-record-xfield record label)))
+ (if (string-or-null-p value)
+ value
+ (let ((print-escape-newlines t))
+ (prin1-to-string value)))))
+
+(defsubst bbdb-record-xfield-split (record label)
+ "For RECORD return value of xfield LABEL split as a list.
+Splitting is based on `bbdb-separator-alist'."
+ (let ((val (bbdb-record-xfield record label)))
+ (cond ((stringp val) (bbdb-split label val))
+ (val (error "Cannot split `%s'" val)))))
+
+(defun bbdb-record-set-xfield (record label value)
+ "For RECORD set xfield LABEL to VALUE.
+If VALUE is nil or an empty string, remove xfield LABEL from RECORD.
+Return VALUE."
+ ;; In principle we can also have xfield labels `name' or `mail', etc.
+ ;; Yet the actual code would get rather confused. So we throw an error.
+ (if (memq label '(name firstname lastname affix organization
+ mail aka phone address xfields))
+ (error "xfield label `%s' illegal" label))
+ (if (eq label 'mail-alias)
+ (setq bbdb-mail-aliases-need-rebuilt 'edit))
+ (if (stringp value) (setq value (bbdb-string-trim value t)))
+ (let ((old-xfield (assq label (bbdb-record-xfields record))))
+ ;; Do nothing if both OLD-XFIELD and VALUE are nil.
+ (cond ((and old-xfield value) ; update
+ (setcdr old-xfield value))
+ (value ; new xfield
+ (bbdb-pushnewq label bbdb-xfield-label-list)
+ (bbdb-record-set-xfields record
+ (append (bbdb-record-xfields record)
+ (list (cons label value)))))
+ (old-xfield ; remove
+ (bbdb-record-set-xfields record
+ (delq old-xfield
+ (bbdb-record-xfields record))))))
+ value)
+
+(defun bbdb-check-type (object type &optional abort extended)
+ "Return non-nil if OBJECT is of type TYPE.
+TYPE is a pseudo-code as in `bbdb-record-type'.
+If ABORT is non-nil, abort with error message if type checking fails.
+If EXTENDED is non-nil, consider extended atomic types which may include
+symbols, numbers, markers, and strings."
+ (let (tmp)
+ ;; Add more predicates? Compare info node `(elisp.info)Type Predicates'.
+ (or (cond ((eq type 'symbol) (symbolp object))
+ ((eq type 'integer) (integerp object))
+ ((eq type 'marker) (markerp object))
+ ((eq type 'number) (numberp object))
+ ((eq type 'string) (stringp object))
+ ((eq type 'sexp) t) ; matches always
+ ((eq type 'face) (facep object))
+ ;; not quite a type
+ ((eq type 'bound) (and (symbolp object) (boundp object)))
+ ((eq type 'function) (functionp object))
+ ((eq type 'vector) (vectorp object))
+ ((and extended
+ (cond ((symbolp type) (setq tmp (eq type object)) t)
+ ((or (numberp type) (markerp type))
+ (setq tmp (= type object)) t)
+ ((stringp type)
+ (setq tmp (and (stringp object)
+ (string= type object))) t)))
+ tmp)
+ ((not (consp type))
+ (error "Atomic type `%s' undefined" type))
+ ((eq 'const (setq tmp (car type)))
+ (equal (nth 1 type) object))
+ ((eq tmp 'cons)
+ (and (consp object)
+ (bbdb-check-type (car object) (nth 1 type) abort extended)
+ (bbdb-check-type (cdr object) (nth 2 type) abort
extended)))
+ ((eq tmp 'list)
+ (and (listp object)
+ (eq (length (cdr type)) (length object))
+ (let ((type (cdr type)) (object object) (ok t))
+ (while type
+ (unless (bbdb-check-type (pop object) (pop type)
+ abort extended)
+ (setq ok nil type nil)))
+ ok)))
+ ((eq tmp 'repeat)
+ (and (listp object)
+ (let ((tp (nth 1 type)) (object object) (ok t))
+ (while object
+ (unless (bbdb-check-type (pop object) tp abort
extended)
+ (setq ok nil object nil)))
+ ok)))
+ ((eq tmp 'vector)
+ (and (vectorp object)
+ (let* ((i 0) (type (cdr type))
+ (ok (eq (length object) (length type))))
+ (when ok
+ (while type
+ (if (bbdb-check-type (aref object i) (pop type)
+ abort extended)
+ (setq i (1+ i))
+ (setq ok nil type nil)))
+ ok))))
+ ((eq tmp 'or) ; like customize `choice' type
+ (let ((type (cdr type)) ok)
+ (while type
+ (if (bbdb-check-type object (pop type) nil extended)
+ (setq ok t type nil)))
+ ok))
+ ;; User-defined predicate
+ ((eq tmp 'user-p) (funcall (nth 1 type) object))
+ (t (error "Compound type `%s' undefined" tmp)))
+ (and abort
+ (error "Type mismatch: expect %s, got `%s'" type object)))))
+
+;; (bbdb-check-type 'bar 'symbol)
+;; (bbdb-check-type 'bar 'bar)
+;; (bbdb-check-type "foo" 'symbol t)
+;; (bbdb-check-type "foo" '(or symbol string))
+;; (bbdb-check-type nil '(const nil))
+;; (bbdb-check-type '(bar . "foo") '(cons symbol string))
+;; (bbdb-check-type '(bar "foo") '(list symbol string))
+;; (bbdb-check-type '("bar" "foo") '(repeat string))
+;; (bbdb-check-type (vector 'bar "foo") '(vector symbol string))
+;; (bbdb-check-type (vector 'bar "foo") 'vector)
+;; (bbdb-check-type '(bar (bar . "foo")) '(list symbol (cons symbol string)))
+;; (bbdb-check-type '("aa" . "bb") '(or (const nil) (cons string string)) t)
+;; (bbdb-check-type nil '(or nil (cons string string)) t t)
+;; (bbdb-check-type "foo" '(user-p (lambda (a) (stringp a))))
+;; (bbdb-check-type 'set 'function)
+
+(defun bbdb-record-field (record field)
+ "For RECORD return the value of FIELD.
+
+FIELD may take the following values
+ firstname Return the first name of RECORD
+ lastname Return the last name of RECORD
+ name Return the full name of RECORD (first name first)
+ name-lf Return the full name of RECORD (last name first)
+ affix Return the list of affixes
+ organization Return the list of organizations
+ aka Return the list of AKAs
+ aka-all Return the list of AKAs plus mail-akas.
+ mail Return the list of email addresses
+ mail-aka Return the list of name parts in mail addresses
+ mail-canon Return the list of canonical mail addresses.
+ phone Return the list of phone numbers
+ address Return the list of addresses
+ uuid Return the uuid of RECORD
+ creation-date Return the creation-date
+ timestamp Return the timestamp
+ xfields Return the list of all xfields
+
+Any other symbol is interpreted as the label for an xfield.
+Then return the value of this xfield.
+
+See also `bbdb-record-set-field'."
+ (cond ((eq field 'firstname) (bbdb-record-firstname record))
+ ((eq field 'lastname) (bbdb-record-lastname record))
+ ((eq field 'name) (bbdb-record-name record))
+ ((eq field 'name-lf) (bbdb-record-name-lf record))
+ ((eq field 'affix) (bbdb-record-affix record))
+ ((eq field 'organization) (bbdb-record-organization record))
+ ((eq field 'mail) (bbdb-record-mail record))
+ ((eq field 'mail-canon) (bbdb-record-mail-canon record)) ; derived
(cached) field
+ ((eq field 'mail-aka) (bbdb-record-mail-aka record)) ; derived
(cached) field
+ ((eq field 'aka) (bbdb-record-aka record))
+ ((eq field 'aka-all) (append (bbdb-record-aka record) ; derived field
+ (bbdb-record-mail-aka record)))
+ ((eq field 'phone) (bbdb-record-phone record))
+ ((eq field 'address) (bbdb-record-address record))
+ ((eq field 'uuid) (bbdb-record-uuid record))
+ ((eq field 'creation-date) (bbdb-record-creation-date record))
+ ((eq field 'timestamp) (bbdb-record-timestamp record))
+ ;; Return all xfields
+ ((eq field 'xfields) (bbdb-record-xfields record))
+ ;; Return xfield FIELD (e.g., `notes') or nil if FIELD is not defined.
+ ((symbolp field) (bbdb-record-xfield record field))
+ (t (error "Unknown field type `%s'" field))))
+(define-obsolete-function-alias 'bbdb-record-get-field 'bbdb-record-field
"3.0")
+
+(defun bbdb-record-set-field (record field value &optional merge check)
+ "For RECORD set FIELD to VALUE. Return VALUE.
+If MERGE is non-nil, merge VALUE with the current value of FIELD.
+If CHECK is non-nil, check syntactically whether FIELD may take VALUE.
+This function also updates the hash table. However, it does not update
+RECORD in the database. Use `bbdb-change-record' for that.
+
+FIELD may take the following values
+ firstname VALUE is the first name of RECORD
+ lastname VALUE is the last name of RECORD
+ name VALUE is the full name of RECORD either as one string
+ or as a cons pair (FIRST . LAST)
+ affix VALUE is the list of affixes
+ organization VALUE is the list of organizations
+ aka VALUE is the list of AKAs
+ mail VALUE is the list of email addresses
+ phone VALUE is the list of phone numbers
+ address VALUE is the list of addresses
+ uuid VALUE is the uuid of RECORD
+ creation-date VALUE is the creation-date
+ timestamp VALUE is the timestamp
+ xfields VALUE is the list of all xfields
+
+Any other symbol is interpreted as the label for an xfield.
+Then VALUE is the value of this xfield.
+
+See also `bbdb-record-field'."
+ (bbdb-editable)
+ (if (memq field '(name-lf mail-aka mail-canon aka-all))
+ (error "`%s' is not allowed as the name of a field" field))
+ (let ((record-type (cdr bbdb-record-type)))
+ (cond ((eq field 'firstname) ; First name
+ (if merge (error "Does not merge names"))
+ (if check (bbdb-check-type value (bbdb-record-firstname
record-type) t))
+ (bbdb-check-name value (bbdb-record-lastname record) record)
+ (bbdb-record-set-name record value t))
+
+ ;; Last name
+ ((eq field 'lastname)
+ (if merge (error "Does not merge names"))
+ (if check (bbdb-check-type value (bbdb-record-lastname record-type)
t))
+ (bbdb-check-name (bbdb-record-firstname record) value record)
+ (bbdb-record-set-name record t value))
+
+ ;; Name
+ ((eq field 'name)
+ (if merge (error "Does not merge names"))
+ (if (stringp value)
+ (setq value (bbdb-divide-name value))
+ (if check (bbdb-check-type value '(cons string string) t)))
+ (let ((fn (car value)) (ln (cdr value)))
+ (bbdb-check-name fn ln record)
+ (bbdb-record-set-name record fn ln)))
+
+ ;; Affix
+ ((eq field 'affix)
+ (if merge (setq value (bbdb-merge-lists (bbdb-record-affix record)
+ value 'bbdb-string=)))
+ (if check (bbdb-check-type value (bbdb-record-affix record-type) t))
+ (setq value (bbdb-list-strings value))
+ (bbdb-record-set-affix record value))
+
+ ;; Organization
+ ((eq field 'organization)
+ (if merge (setq value (bbdb-merge-lists (bbdb-record-organization
record)
+ value 'bbdb-string=)))
+ (if check (bbdb-check-type value (bbdb-record-organization
record-type) t))
+ (setq value (bbdb-list-strings value))
+ (bbdb-hash-update record (bbdb-record-organization record) value)
+ (dolist (organization value)
+ (bbdb-pushnew organization bbdb-organization-list))
+ (bbdb-record-set-organization record value))
+
+ ;; AKA
+ ((eq field 'aka)
+ (if merge (setq value (bbdb-merge-lists (bbdb-record-aka record)
+ value 'bbdb-string=)))
+ (if check (bbdb-check-type value (bbdb-record-aka record-type) t))
+ (setq value (bbdb-list-strings value))
+ (unless bbdb-allow-duplicates
+ (dolist (aka value)
+ (let ((old (remq record (bbdb-gethash aka '(fl-name lf-name
aka)))))
+ (if old (error "Alternate name address \"%s\" is used by
\"%s\""
+ aka (mapconcat 'bbdb-record-name old ", "))))))
+ (bbdb-hash-update record (bbdb-record-aka record) value)
+ (bbdb-record-set-aka record value))
+
+ ;; Mail
+ ((eq field 'mail)
+ (if merge (setq value (bbdb-merge-lists (bbdb-record-mail record)
+ value 'bbdb-string=)))
+ (if check (bbdb-check-type value (bbdb-record-mail record-type) t))
+ (setq value (bbdb-list-strings value))
+ (unless bbdb-allow-duplicates
+ (dolist (mail value)
+ (let ((old (remq record (bbdb-gethash mail '(mail)))))
+ (if old (error "Mail address \"%s\" is used by \"%s\""
+ mail (mapconcat 'bbdb-record-name old ",
"))))))
+ (dolist (aka (bbdb-record-mail-aka record))
+ (bbdb-remhash aka record))
+ (dolist (mail (bbdb-record-mail-canon record))
+ (bbdb-remhash mail record))
+ (bbdb-record-set-mail record value)
+ (bbdb-puthash-mail record))
+
+ ;; Phone
+ ((eq field 'phone)
+ (if merge (setq value (bbdb-merge-lists (bbdb-record-phone record)
+ value 'equal)))
+ (if check (bbdb-check-type value (bbdb-record-phone record-type) t))
+ (dolist (phone value)
+ (bbdb-pushnew (bbdb-phone-label phone) bbdb-phone-label-list))
+ (bbdb-record-set-phone record value))
+
+ ;; Address
+ ((eq field 'address)
+ (if merge (setq value (bbdb-merge-lists (bbdb-record-address record)
+ value 'equal)))
+ (if check (bbdb-check-type value (bbdb-record-address record-type)
t))
+ (dolist (address value)
+ (bbdb-pushnew (bbdb-address-label address)
bbdb-address-label-list)
+ (mapc (lambda (street) (bbdb-pushnewt street bbdb-street-list))
+ (bbdb-address-streets address))
+ (bbdb-pushnewt (bbdb-address-city address) bbdb-city-list)
+ (bbdb-pushnewt (bbdb-address-state address) bbdb-state-list)
+ (bbdb-pushnewt (bbdb-address-postcode address) bbdb-postcode-list)
+ (bbdb-pushnewt (bbdb-address-country address) bbdb-country-list))
+ (bbdb-record-set-address record value))
+
+ ;; uuid
+ ((eq field 'uuid)
+ ;; MERGE not meaningful
+ (if check (bbdb-check-type value (bbdb-record-uuid record-type) t))
+ (let ((old-uuid (bbdb-record-uuid record)))
+ (unless (string= old-uuid value)
+ (remhash old-uuid bbdb-uuid-table)
+ (bbdb-record-set-uuid record value)
+ (puthash value record bbdb-uuid-table))))
+
+ ;; creation-date
+ ((eq field 'creation-date)
+ ;; MERGE not meaningful
+ (if check (bbdb-check-type value (bbdb-record-creation-date
record-type) t))
+ (bbdb-record-set-creation-date record value))
+
+ ;; timestamp
+ ((eq field 'timestamp)
+ ;; MERGE not meaningful
+ (if check (bbdb-check-type value (bbdb-record-timestamp
record-type) t))
+ (bbdb-record-set-timestamp record value))
+
+ ;; all xfields
+ ((eq field 'xfields)
+ (if merge
+ (let ((xfields (bbdb-record-xfields record))
+ xfield)
+ (dolist (nv value)
+ (if (setq xfield (assq (car nv) xfields))
+ (setcdr xfield (bbdb-merge-xfield
+ (car nv) (cdr xfield) (cdr nv)))
+ (setq xfields (append xfields (list nv)))))
+ (setq value xfields)))
+ (if check (bbdb-check-type value (bbdb-record-xfields record-type)
t))
+ (let (new-xfields)
+ (dolist (xfield value)
+ ;; Ignore junk
+ (when (and (cdr xfield) (not (equal "" (cdr xfield))))
+ (push xfield new-xfields)
+ (bbdb-pushnewq (car xfield) bbdb-xfield-label-list)))
+ (bbdb-record-set-xfields record (nreverse new-xfields))))
+
+ ;; Single xfield
+ ((symbolp field)
+ (if merge
+ (setq value (bbdb-merge-xfield field (bbdb-record-xfield record
field)
+ value)))
+ ;; The following test always succeeds
+ ;; (if check (bbdb-check-type value 'sexp t))
+ ;; This removes xfield FIELD if its value is nil.
+ (bbdb-record-set-xfield record field value))
+
+ (t (error "Unknown field type `%s'" field)))))
+
+;; Currently unused (but possible entry for `bbdb-merge-xfield-function-alist')
+(defun bbdb-merge-concat (string1 string2 &optional separator)
+ "Return the concatenation of STRING1 and STRING2.
+SEPARATOR defaults to \"\\n\"."
+ (concat string1 (or separator "\n") string2))
+
+;; Currently unused (but possible entry for `bbdb-merge-xfield-function-alist')
+(defun bbdb-merge-concat-remove-duplicates (string1 string2)
+ "Concatenate STRING1 and STRING2, but remove duplicate lines."
+ (let ((lines (split-string string1 "\n")))
+ (dolist (line (split-string string2 "\n"))
+ (bbdb-pushnew line lines))
+ (bbdb-concat "\n" lines)))
+
+(defun bbdb-merge-string-least (string1 string2)
+ "Return the string out of STRING1 and STRING2 that is `string-lessp'."
+ (if (string-lessp string1 string2)
+ string1
+ string2))
+
+(defun bbdb-merge-string-most (string1 string2)
+ "Return the string out of STRING1 and STRING2 that is not `string-lessp'."
+ (if (string-lessp string1 string2)
+ string2
+ string1))
+
+(defun bbdb-merge-lists (l1 l2 cmp)
+ "Merge two lists L1 and L2 based on comparison CMP.
+An element from L2 is added to L1 if CMP returns nil for all elements of L1.
+If L1 or L2 are not lists, they are replaced by (list L1) and (list L2)."
+ (let (merge)
+ (unless (listp l1) (setq l1 (list l1)))
+ (dolist (e2 (if (listp l2) l2 (list l2)))
+ (let ((ll1 l1) e1 fail)
+ (while (setq e1 (pop ll1))
+ (if (funcall cmp e1 e2)
+ (setq ll1 nil
+ fail t)))
+ (unless fail (push e2 merge))))
+ (append l1 (nreverse merge))))
+
+(defun bbdb-merge-xfield (label value1 value2)
+ "For LABEL merge VALUE1 with VALUE2.
+If LABEL has an entry in `bbdb-merge-xfield-function-alist', use it.
+If VALUE1 or VALUE2 is a substring of the other, return the longer one.
+Otherwise use `bbdb-concat'. Return nil if we have nothing to merge."
+ (if (stringp value1) (setq value1 (bbdb-string-trim value1 t)))
+ (if (stringp value2) (setq value2 (bbdb-string-trim value2 t)))
+ (cond ((and value1 value2)
+ (let ((fun (cdr (assq label bbdb-merge-xfield-function-alist))))
+ (cond (fun (funcall fun value1 value2))
+ ((not (and (stringp value1) (stringp value2)))
+ (cons value1 value2)) ; concatenate lists
+ ((string-match (regexp-quote value1) value2) value2)
+ ((string-match (regexp-quote value2) value1) value1)
+ (t (bbdb-concat label value1 value2)))))
+ (value1)
+ (value2)))
+
+;;; Parsing other things
+
+(defun bbdb-divide-name (string)
+ "Divide STRING into a first name and a last name.
+Case is ignored. Return name as (FIRST . LAST).
+LAST is always a string (possibly empty). FIRST may be nil."
+ (let ((case-fold-search t)
+ first suffix)
+ ;; Separate a suffix.
+ (if (string-match bbdb-lastname-suffix-re string)
+ (setq suffix (concat " " (match-string 1 string))
+ string (substring string 0 (match-beginning 0))))
+ (cond ((string-match "\\`\\(.+\\),[ \t\n]*\\(.+\\)\\'" string)
+ ;; If STRING contains a comma, this probably means that STRING
+ ;; is of the form "Last, First".
+ (setq first (match-string 2 string)
+ string (match-string 1 string)))
+ ((string-match bbdb-lastname-re string)
+ (setq first (and (not (zerop (match-beginning 0)))
+ (substring string 0 (match-beginning 0)))
+ string (match-string 1 string))))
+ (cons (and first (bbdb-string-trim first))
+ (bbdb-string-trim (concat string suffix)))))
+
+(defun bbdb-parse-postcode (string)
+ "Check whether STRING is a legal postcode.
+Do this only if `bbdb-check-postcode' is non-nil."
+ (if bbdb-check-postcode
+ (let ((postcodes bbdb-legal-postcodes) re done)
+ (while (setq re (pop postcodes))
+ (if (string-match re string)
+ (setq done t postcodes nil)))
+ (if done string
+ (error "not a valid postcode.")))
+ string))
+
+(defun bbdb-phone-string (phone)
+ "Massage string PHONE into a standard format."
+ ;; Phone numbers should come in two forms:
+ (if (= 2 (length phone))
+ ;; (1) ["where" "the number"]
+ (if (stringp (aref phone 1))
+ (aref phone 1)
+ (error "Not a valid phone number: %s" (aref phone 1)))
+ ;; (2) ["where" 415 555 1212 99]
+ (unless (and (integerp (aref phone 2))
+ (integerp (aref phone 3)))
+ (error "Not an NANP number: %s %s" (aref phone 2) (aref phone 3)))
+ (concat (if (/= 0 (bbdb-phone-area phone))
+ (format "(%03d) " (bbdb-phone-area phone))
+ "")
+ (if (/= 0 (bbdb-phone-exchange phone))
+ (format "%03d-%04d"
+ (bbdb-phone-exchange phone) (bbdb-phone-suffix phone))
+ "")
+ (if (and (bbdb-phone-extension phone)
+ (/= 0 (bbdb-phone-extension phone)))
+ (format " x%d" (bbdb-phone-extension phone))
+ ""))))
+
+(defsubst bbdb-record-lessp (record1 record2)
+ (string< (bbdb-record-sortkey record1)
+ (bbdb-record-sortkey record2)))
+
+(defmacro bbdb-error-retry (&rest body)
+ "Repeatedly execute BODY ignoring errors till no error occurs."
+ `(catch '--bbdb-error-retry--
+ (while t
+ (condition-case --c--
+ (throw '--bbdb-error-retry-- (progn ,@body))
+ (error (ding)
+ (message "Error: %s" (nth 1 --c--))
+ (sit-for 2))))))
+
+
+;;; Reading and Writing the BBDB
+
+(defun bbdb-buffer ()
+ "Return buffer that visits the BBDB file `bbdb-file'.
+Ensure that this buffer is in sync with `bbdb-file'.
+Revert the buffer if necessary.
+If `bbdb-file-remote' is non-nil and it is newer than `bbdb-file',
+copy it to `bbdb-file'."
+ (unless (buffer-live-p bbdb-buffer)
+ (if (and bbdb-file-remote
+ (file-newer-than-file-p bbdb-file-remote bbdb-file))
+ (copy-file bbdb-file-remote bbdb-file t t))
+
+ (with-current-buffer (setq bbdb-buffer (find-file-noselect bbdb-file))
+
+ ;; Check whether auto-save file is newer than `bbdb-file'
+ ;; Do this only when reading `bbdb-file'.
+ (let ((auto-save-file (make-auto-save-file-name)))
+ (when (and bbdb-check-auto-save-file
+ (file-newer-than-file-p auto-save-file buffer-file-name))
+ (recover-file buffer-file-name) ; this queries
+ (bury-buffer) ; `recover-file' selects `bbdb-buffer'
+ (auto-save-mode 1) ; turn auto-save back on
+ ;; Delete auto-save file even if the user rejected to recover it,
+ ;; so we do not keep asking.
+ (condition-case nil
+ (delete-file auto-save-file)
+ (file-error nil))))))
+
+ ;; Make sure `bbdb-buffer' is not out of sync with disk.
+ (with-current-buffer bbdb-buffer
+ (cond ((verify-visited-file-modtime))
+ ((bbdb-revert-buffer))
+ ;; This is the case where `bbdb-file' has changed; the buffer
+ ;; has changed as well; and the user has answered "no" to the
+ ;; "flush your changes and revert" question. The only other
+ ;; alternative is to save the file right now. If they answer
+ ;; no to the following question, they will be asked the
+ ;; preceeding question again and again some large (but finite)
+ ;; number of times. `bbdb-buffer' is called a lot, you see...
+ ((buffer-modified-p)
+ ;; this queries
+ (bbdb-save t t))
+ (t ; Buffer and file are inconsistent, but we let them stay that way
+ (message "Continuing with inconsistent BBDB buffers")))
+
+ ;; `bbdb-revert-buffer' kills all local variables.
+ (unless (assq 'bbdb-records (buffer-local-variables))
+ ;; We are reading / reverting `bbdb-buffer'.
+ (set (make-local-variable 'revert-buffer-function)
+ 'bbdb-revert-buffer)
+
+ (setq buffer-file-coding-system bbdb-file-coding-system
+ buffer-read-only bbdb-read-only
+ bbdb-mail-aliases-need-rebuilt 'parse
+ bbdb-changed-records nil)
+
+ ;; `bbdb-before-save-hook' and `bbdb-after-save-hook' are user variables.
+ ;; To avoid confusion, we hide the hook functions `bbdb-before-save'
+ ;; and `bbdb-after-save' from the user as these are essential for BBDB.
+ (dolist (hook (cons 'bbdb-before-save bbdb-before-save-hook))
+ (add-hook 'before-save-hook hook nil t))
+ (dolist (hook (cons 'bbdb-after-save bbdb-after-save-hook))
+ (add-hook 'after-save-hook hook nil t))
+
+ (clrhash bbdb-hashtable)
+ (clrhash bbdb-uuid-table)
+
+ (if (/= (point-min) (point-max))
+ (bbdb-parse-records) ; normal case: nonempty db
+ ;; Empty db: the following does not require `insert-before-markers'
+ ;; because there are no db-markers in this buffer.
+ (insert (format (concat ";; -*- mode: Emacs-Lisp; coding: %s; -*-"
+ "\n;;; file-format: %d\n")
+ bbdb-file-coding-system bbdb-file-format))
+ ;; We pretend that `bbdb-buffer' is still unmodified,
+ ;; so that we will (auto-)save it only if we also add records to it.
+ (set-buffer-modified-p nil)
+ (setq bbdb-end-marker (point-marker)
+ ;; Setting `bbdb-records' makes it buffer-local,
+ ;; so that we can use it as a test whether we have
+ ;; initialized BBDB.
+ bbdb-records nil))
+
+ (run-hooks 'bbdb-after-read-db-hook)))
+
+ ;; return `bbdb-buffer'
+ bbdb-buffer)
+
+(defmacro bbdb-with-db-buffer (&rest body)
+ "Execute the forms in BODY with `bbdb-buffer' temporarily current.
+If `bbdb-debug' was non-nil at compile-time, and `bbdb-buffer' is visible
+in a window, temporarilly switch to that window. So when we come out,
+that window has been scrolled to the record we have just modified."
+ (declare (indent 0))
+ (if bbdb-debug
+ `(let* ((buffer (bbdb-buffer))
+ (window (get-buffer-window buffer)))
+ (if window
+ (with-selected-window window
+ ,@body)
+ (with-current-buffer buffer
+ ,@body)))
+ `(with-current-buffer (bbdb-buffer)
+ ,@body)))
+
+(defun bbdb-editable ()
+ "Ensure that BBDB is editable, otherwise throw an error.
+If BBDB is out of sync try to revert.
+BBDB is not editable if it is read-only."
+ (if bbdb-read-only (error "BBDB is read-only"))
+ (let ((buffer (bbdb-buffer))) ; this reverts if necessary / possible
+ ;; Is the following possible? Superfluous tests do not hurt.
+ ;; It is relevant only for editing commands in a BBDB buffer,
+ ;; but not for MUA-related editing functions.
+ (if (and (eq major-mode 'bbdb-mode)
+ bbdb-records
+ (not (memq (caar bbdb-records)
+ (with-current-buffer buffer bbdb-records))))
+ (error "BBDB is out of sync")))
+ t)
+
+;;;###autoload
+(defsubst bbdb-records ()
+ "Return a list of all BBDB records; read in and parse the db if necessary.
+This function also notices if the corresponding file on disk has been
modified."
+ (with-current-buffer (bbdb-buffer)
+ bbdb-records))
+
+(defun bbdb-revert-buffer (&optional ignore-auto noconfirm)
+ "The `revert-buffer-function' for `bbdb-buffer' visiting `bbdb-file'.
+IGNORE-AUTO and NOCONFIRM have same meaning as in `revert-buffer'.
+See also variable `bbdb-auto-revert'.
+Return t if the reversion was successful (or not needed).
+Return nil otherwise."
+ (interactive (list (not current-prefix-arg))) ; as in `revert-buffer'
+ (unless (buffer-live-p bbdb-buffer)
+ (error "No live BBDB buffer to revert"))
+ (with-current-buffer bbdb-buffer
+ (cond ((not buffer-file-number)
+ ;; We have not yet created `bbdb-file'
+ (when (or noconfirm
+ (yes-or-no-p "Flush your changes? "))
+ (erase-buffer)
+ (kill-all-local-variables) ; clear database
+ (bbdb-buffer) ; re-initialize
+ (set-buffer-modified-p nil)
+ (bbdb-undisplay-records t)))
+ ;; If nothing has changed do nothing, return t.
+ ((and (verify-visited-file-modtime)
+ (not (buffer-modified-p))))
+ ((or (and (not (verify-visited-file-modtime bbdb-buffer))
+ ;; File changed on disk
+ (or noconfirm
+ (and bbdb-auto-revert
+ (not (buffer-modified-p)))
+ (yes-or-no-p
+ (if (buffer-modified-p)
+ "BBDB changed on disk; flush your changes and
revert? "
+ "BBDB changed on disk; revert? "))))
+ (and (verify-visited-file-modtime bbdb-buffer)
+ ;; File not changed on disk, but buffer modified
+ (buffer-modified-p)
+ (or noconfirm
+ (yes-or-no-p "Flush your changes and revert BBDB? "))))
+ (unless (file-exists-p bbdb-file)
+ (error "BBDB: file %s no longer exists" bbdb-file))
+ (kill-all-local-variables) ; clear database
+ ;; `revert-buffer-function' has the permanent-local property
+ ;; So to avoid looping, we need to bind it to nil explicitly.
+ (let (revert-buffer-function)
+ (revert-buffer ignore-auto t))
+ (bbdb-buffer) ; re-initialize
+ (bbdb-undisplay-records t)
+ t)))) ; return nil if the user rejected to revert
+
+(defun bbdb-goto-first-record ()
+ "Go to where first record begins, Move to end of file if no records."
+ (goto-char (point-min))
+ (if (search-forward "\n[" nil 'move)
+ (forward-char -1)))
+
+(defun bbdb-parse-records ()
+ "Parse BBDB records and initialize various internal variables.
+If `bbdb-file' uses an outdated format, migrate to `bbdb-file-format'."
+ (save-excursion
+ (save-restriction
+ (widen)
+ (bbdb-goto-first-record)
+ (let* ((file (abbreviate-file-name buffer-file-name))
+ (file-format (save-excursion
+ (if (re-search-backward
+ "^;+[ \t]*file-\\(format\\|version\\):[
\t]*\\([0-9]+\\)[ \t]*$" nil t)
+ (string-to-number (match-string 2))
+ ;; No file-format line.
+ (error "BBDB corrupted: no file-format line"))))
+ (migrate (< file-format bbdb-file-format))
+ records)
+ (if (> file-format bbdb-file-format)
+ (error "%s understands file format %s but not %s."
+ (bbdb-version) bbdb-file-format file-format))
+
+ (if (and migrate
+ (not (yes-or-no-p
+ (format (concat "Migrate `%s' to BBDB file format %s "
+ "(back-up recommended)? ")
+ file bbdb-file-format))))
+ (progn
+ (message "Abort loading %s" file)
+ (sleep-for 2)
+ (setq bbdb-records nil
+ ;; Avoid unexpected surprises
+ buffer-read-only t)
+ 'abort)
+
+ (or (eobp) (looking-at "\\[")
+ (error "BBDB corrupted: no following bracket"))
+
+ (unless bbdb-silent (message "Parsing BBDB file `%s'..." file))
+
+ ;; narrow the buffer to skip over the rubbish before the first
record.
+ (narrow-to-region (point) (point-max))
+ (let ((modp (buffer-modified-p))
+ ;; Make sure those parens get cleaned up.
+ ;; This code had better stay simple!
+ (inhibit-quit t)
+ (buffer-undo-list t)
+ buffer-read-only)
+ (goto-char (point-min)) (insert "(\n")
+ (goto-char (point-max)) (insert "\n)")
+ (goto-char (point-min))
+ (unwind-protect
+ (setq records (read (current-buffer)))
+ (goto-char (point-min)) (delete-char 2)
+ (goto-char (point-max)) (delete-char -2)
+ (set-buffer-modified-p modp)))
+ (widen)
+
+ ;; Migrate if `bbdb-file' is outdated.
+ (if migrate (setq records (bbdb-migrate records file-format)))
+
+ ;; We could first set `bbdb-phone-label-list' and
+ ;; `bbdb-address-label-list' to their customized values. Bother?
+ (setq bbdb-records records
+ bbdb-xfield-label-list nil
+ bbdb-organization-list nil
+ bbdb-street-list nil
+ bbdb-city-list nil
+ bbdb-state-list nil
+ bbdb-postcode-list nil
+ bbdb-country-list nil)
+
+ (bbdb-goto-first-record)
+ (dolist (record records)
+ ;; We assume that the markers for each record need to go at each
+ ;; newline. If this is not the case, things can go *very* wrong.
+ (bbdb-debug
+ (unless (looking-at "\\[")
+ (error "BBDB corrupted: junk between records at %s" (point))))
+
+ (bbdb-cache-set-marker
+ (bbdb-record-set-cache record (make-vector bbdb-cache-length nil))
+ (point-marker))
+ (forward-line 1)
+
+ ;; Every record must have a unique uuid in `bbdb-uuid-table'.
+ (if (gethash (bbdb-record-uuid record) bbdb-uuid-table)
+ ;; Is there a more useful action than throwing an error?
+ ;; We are just loading BBDB, so we are not yet ready
+ ;; for sophisticated solutions.
+ (error "Duplicate UUID %s" (bbdb-record-uuid record)))
+
+ ;; Set the completion lists
+ (dolist (phone (bbdb-record-phone record))
+ (bbdb-pushnew (bbdb-phone-label phone) bbdb-phone-label-list))
+ (dolist (address (bbdb-record-address record))
+ (bbdb-pushnew (bbdb-address-label address)
bbdb-address-label-list)
+ (mapc (lambda (street) (bbdb-pushnewt street bbdb-street-list))
+ (bbdb-address-streets address))
+ (bbdb-pushnewt (bbdb-address-city address) bbdb-city-list)
+ (bbdb-pushnewt (bbdb-address-state address) bbdb-state-list)
+ (bbdb-pushnewt (bbdb-address-postcode address)
bbdb-postcode-list)
+ (bbdb-pushnewt (bbdb-address-country address) bbdb-country-list))
+ (dolist (xfield (bbdb-record-xfields record))
+ (bbdb-pushnewq (car xfield) bbdb-xfield-label-list))
+ (dolist (organization (bbdb-record-organization record))
+ (bbdb-pushnew organization bbdb-organization-list))
+
+ (let ((name (bbdb-concat 'name-first-last
+ (bbdb-record-firstname record)
+ (bbdb-record-lastname record))))
+ (when (and (not bbdb-allow-duplicates)
+ (bbdb-gethash name '(fl-name aka)))
+ ;; This does not check for duplicate mail fields.
+ ;; Yet under normal circumstances, this should really
+ ;; not be necessary each time BBDB is loaded as BBDB checks
+ ;; whether creating a new record or modifying an existing one
+ ;; results in duplicates.
+ ;; Alternatively, you can use `bbdb-search-duplicates'.
+ (message "Duplicate BBDB record encountered: %s" name)
+ (sit-for 1)))
+
+ ;; If `bbdb-allow-duplicates' is non-nil, we allow that two records
+ ;; (with different uuids) refer to the same person (same name
etc.).
+ ;; Such duplicate records are always hashed.
+ ;; Otherwise, an unhashed record would not be available for things
+ ;; like completion (and we would not know which record to keeep
+ ;; and which one to hide). We trust the user she knows what
+ ;; she wants if she keeps duplicate records in the database though
+ ;; `bbdb-allow-duplicates' is nil.
+ (bbdb-hash-record record))
+
+ ;; Note that `bbdb-xfield-label-list' serves two purposes:
+ ;; - check whether an xfield is new to BBDB
+ ;; - list of known xfields for minibuffer completion
+ ;; Only in the latter case, we might want to exclude
+ ;; those xfields that are handled automatically.
+ ;; So the following is not a satisfactory solution.
+
+ ;; (dolist (label (bbdb-layout-get-option 'multi-line 'omit))
+ ;; (setq bbdb-xfield-label-list (delq label
bbdb-xfield-label-list)))
+
+ ;; `bbdb-end-marker' allows to put comments at the end of `bbdb-file'
+ ;; that are ignored.
+ (setq bbdb-end-marker (point-marker))
+
+ (when migrate
+ (dolist (record bbdb-records)
+ (bbdb-overwrite-record-internal record))
+ ;; update file format
+ (goto-char (point-min))
+ (if (re-search-forward (format "^;;; file-\\(version\\|format\\):
%d$"
+ file-format)
+ nil t)
+ (replace-match (format ";;; file-format: %d"
bbdb-file-format))))
+
+ (unless bbdb-silent (message "Parsing BBDB file `%s'...done" file))
+ bbdb-records)))))
+
+(defun bbdb-before-save ()
+ "Run before saving `bbdb-file' as buffer-local part of `before-save-hook'."
+ (when (and bbdb-file-remote
+ (or bbdb-file-remote-save-always
+ (y-or-n-p (format "Save the remote BBDB file %s too? "
+ bbdb-file-remote))))
+ ;; Write the current buffer `bbdb-file' into `bbdb-file-remote'.
+ (let ((coding-system-for-write bbdb-file-coding-system))
+ (write-region (point-min) (point-max) bbdb-file-remote))))
+
+(defun bbdb-after-save ()
+ "Run after saving `bbdb-file' as buffer-local part of `after-save-hook'."
+ (setq bbdb-changed-records nil)
+ (dolist (buffer (buffer-list))
+ (with-current-buffer buffer
+ (if (eq major-mode 'bbdb-mode)
+ (set-buffer-modified-p nil)))))
+
+(defun bbdb-change-record (record &rest ignored)
+ "Update the database after a change of RECORD.
+Return RECORD if RECORD got changed compared with the database,
+return nil otherwise.
+Hash RECORD if it is new. If RECORD is not new, it is the the caller's
+responsibility to update the hashtables for RECORD. (Up-to-date hashtables are
+ensured if the fields are modified by calling `bbdb-record-set-field'.)
+Redisplay RECORD if it is not new.
+
+Args IGNORED are ignored and their use is discouraged.
+They are present only for backward compatibility."
+ (when (and ignored (get 'bbdb-change-record 'bbdb-outdated))
+ (put 'bbdb-change-record 'bbdb-outdated t)
+ (message "Outdated usage of `bbdb-change-record'")
+ (sit-for 2))
+
+ (if bbdb-read-only
+ (error "The Insidious Big Brother Database is read-only."))
+ ;; The call of `bbdb-records' checks file synchronization.
+ ;; If RECORD refers to an existing record that has been changed,
+ ;; yet in the meanwhile we reverted the BBDB file, then RECORD
+ ;; no longer refers to a record in `bbdb-records'. RECORD will then
+ ;; be treated as new, when we try to merge it with the known record.
+ (let ((tail (memq record (bbdb-records))))
+ (if tail ; RECORD is not new
+ ;; If the string we currently have for RECORD in `bbdb-buffer'
+ ;; is `equal' to the string we would write to `bbdb-buffer',
+ ;; we really did not change RECORD at all. So we don't update RECORD
+ ;; unless `bbdb-update-unchanged-records' tells us to do so anyway.
+ ;; Also, we only call `bbdb-change-hook' and `bbdb-after-change-hook'
+ ;; if RECORD got changed.
+ (when (or bbdb-update-unchanged-records
+ (not (string= (bbdb-with-db-buffer
+ (buffer-substring-no-properties
+ (bbdb-record-marker record)
+ (1- (if (cdr tail)
+ (bbdb-record-marker (cadr tail))
+ bbdb-end-marker))))
+ (let ((cache (bbdb-record-cache record))
+ (inhibit-quit t))
+ (bbdb-record-set-cache record nil)
+ (prog1 (bbdb-with-print-loadably
+ (prin1-to-string record))
+ (bbdb-record-set-cache record cache))))))
+ (bbdb-record-set-timestamp
+ record (format-time-string bbdb-time-stamp-format nil t))
+ (run-hook-with-args 'bbdb-change-hook record)
+ (let ((sort (not (equal (bbdb-cache-sortkey (bbdb-record-cache
record))
+ (bbdb-record-set-sortkey record)))))
+ (if (not sort) ;; If we do not need to sort, overwrite RECORD.
+ (bbdb-overwrite-record-internal record)
+ ;; Since we need to sort, delete then insert RECORD.
+ ;; Do not mess with the hash tables here.
+ ;; We assume they got updated by the caller.
+ (bbdb-delete-record-internal record)
+ (bbdb-insert-record-internal record))
+ (bbdb-pushnewq record bbdb-changed-records)
+ (run-hook-with-args 'bbdb-after-change-hook record)
+ (bbdb-redisplay-record-globally record sort))
+ record)
+
+ ;; Record is new and not yet in BBDB.
+ (unless (bbdb-record-cache record)
+ (bbdb-record-set-cache record (make-vector bbdb-cache-length nil)))
+ (unless (bbdb-record-uuid record)
+ (bbdb-record-set-uuid record (bbdb-uuid)))
+ (unless (bbdb-record-creation-date record)
+ (bbdb-record-set-creation-date
+ record (format-time-string bbdb-time-stamp-format nil t))
+ (run-hook-with-args 'bbdb-create-hook record))
+
+ (let ((old-record (gethash (bbdb-record-uuid record) bbdb-uuid-table)))
+ (if old-record
+ ;; RECORD is really OLD-RECORD. Merge and return OLD-RECORD.
+ (if bbdb-merge-records-function
+ (funcall bbdb-merge-records-function record old-record)
+ (bbdb-merge-records record old-record))
+
+ ;; RECORD is really new.
+ (bbdb-record-set-timestamp
+ record (format-time-string bbdb-time-stamp-format nil t))
+ (run-hook-with-args 'bbdb-change-hook record)
+ (bbdb-insert-record-internal record)
+ (bbdb-hash-record record)
+ (bbdb-pushnewq record bbdb-changed-records)
+ (run-hook-with-args 'bbdb-after-change-hook record)
+ record)))))
+
+(defun bbdb-delete-record-internal (record &optional completely)
+ "Delete RECORD in the database file.
+With COMPLETELY non-nil, also undisplay RECORD and remove it
+from the hash table."
+ (unless (bbdb-record-marker record) (error "BBDB: marker absent"))
+ (if completely (bbdb-redisplay-record-globally record nil t))
+ (bbdb-with-db-buffer
+ (barf-if-buffer-read-only)
+ (let ((tail (memq record bbdb-records))
+ (inhibit-quit t))
+ (unless tail (error "BBDB record absent: %s" record))
+ (delete-region (bbdb-record-marker record)
+ (if (cdr tail)
+ (bbdb-record-marker (car (cdr tail)))
+ bbdb-end-marker))
+ (setq bbdb-records (delq record bbdb-records))
+ (when completely
+ (bbdb-remhash (bbdb-record-name record) record)
+ (bbdb-remhash (bbdb-record-name-lf record) record)
+ (dolist (organization (bbdb-record-organization record))
+ (bbdb-remhash organization record))
+ (dolist (mail (bbdb-record-mail-canon record))
+ (bbdb-remhash mail record))
+ (dolist (aka (bbdb-record-field record 'aka-all))
+ (bbdb-remhash aka record))))))
+
+(defun bbdb-insert-record-internal (record)
+ "Insert RECORD into the database file. Return RECORD.
+Do not call this function directly, call instead `bbdb-change-record'
+that calls the hooks, too."
+ (unless (bbdb-record-marker record)
+ (bbdb-record-set-marker record (make-marker)))
+ (bbdb-with-db-buffer
+ (barf-if-buffer-read-only)
+ ;; splice record into `bbdb-records'
+ (bbdb-debug (if (memq record bbdb-records)
+ (error "BBDB record not unique: - %s" record)))
+ (if (or (not bbdb-records) ; first record in new database
+ (bbdb-record-lessp record (car bbdb-records)))
+ (push record bbdb-records)
+ (let ((records bbdb-records))
+ (while (and (cdr records)
+ (bbdb-record-lessp (nth 1 records) record))
+ (setq records (cdr records)))
+ (setcdr records (cons record (cdr records)))))
+
+ (let ((next (car (cdr (memq record bbdb-records)))))
+ (goto-char (if next
+ (bbdb-record-marker next)
+ bbdb-end-marker)))
+ ;; Before writing the record, remove the cache (we do not want that
+ ;; written to the file.) After writing, put the cache back and update
+ ;; the cache's marker.
+ (let ((cache (bbdb-record-cache record))
+ (point (point))
+ (inhibit-quit t))
+ (bbdb-debug
+ (if (= point (point-min))
+ (error "Inserting at point-min (%s)" point))
+ (if (and (/= point bbdb-end-marker)
+ (not (looking-at "^\\[")))
+ (error "Not inserting before a record (%s)" point)))
+ (bbdb-record-set-cache record nil)
+ (insert-before-markers
+ (bbdb-with-print-loadably (prin1-to-string record)) "\n")
+ (set-marker (bbdb-cache-marker cache) point)
+ (bbdb-record-set-cache record cache))
+ record))
+
+(defun bbdb-overwrite-record-internal (record)
+ "Overwrite RECORD in the database file. Return RECORD.
+Do not call this function directly, call instead `bbdb-change-record'
+that calls the hooks, too."
+ (bbdb-with-db-buffer
+ (barf-if-buffer-read-only)
+ (let* ((tail (memq record bbdb-records))
+ (_ (unless tail (error "BBDB record absent: %s" record)))
+ (cache (bbdb-record-cache record))
+ (inhibit-quit t))
+ (bbdb-debug
+ (if (<= (bbdb-cache-marker cache) (point-min))
+ (error "Cache marker is %s" (bbdb-cache-marker cache))))
+ (goto-char (bbdb-cache-marker cache))
+ (bbdb-debug
+ (if (and (/= (point) bbdb-end-marker)
+ (not (looking-at "\\[")))
+ (error "Not inserting before a record (%s)" (point))))
+
+ (bbdb-record-set-cache record nil)
+ (insert (bbdb-with-print-loadably (prin1-to-string record)) "\n")
+ (delete-region (point)
+ (if (cdr tail)
+ (bbdb-record-marker (car (cdr tail)))
+ bbdb-end-marker))
+ (bbdb-record-set-cache record cache)
+
+ (bbdb-debug
+ (if (<= (if (cdr tail)
+ (bbdb-record-marker (car (cdr tail)))
+ bbdb-end-marker)
+ (bbdb-record-marker record))
+ (error "Overwrite failed")))
+
+ record)))
+
+;; Record formatting:
+;; This does not insert anything into the *BBDB* buffer,
+;; which is handled in a second step by the display functions.
+
+(defun bbdb-layout-get-option (layout option)
+ "For LAYOUT return value of OPTION according to `bbdb-layout-alist'."
+ (let ((layout-spec (if (listp layout)
+ layout
+ (assq layout bbdb-layout-alist)))
+ option-value)
+ (and layout-spec
+ (setq option-value (assq option layout-spec))
+ (cdr option-value))))
+
+(defun bbdb-address-continental-p (address)
+ "Return non-nil if ADDRESS is a continental address.
+This is done by comparing the postcode to `bbdb-continental-postcode-regexp'.
+
+This is a possible identifying function for
+`bbdb-address-format-list' and `bbdb-tex-address-format-list'."
+ (string-match bbdb-continental-postcode-regexp
+ (bbdb-address-postcode address)))
+
+;; This function can provide some guidance for writing
+;; your own address formatting function
+(defun bbdb-format-address-default (address)
+ "Return formatted ADDRESS as a string.
+This is the default format; it is used in the US, for example.
+The result looks like this:
+ label: street
+ street
+ ...
+ city, state postcode
+ country.
+
+This function is a possible formatting function for
+`bbdb-address-format-list'."
+ (let ((country (bbdb-address-country address))
+ (streets (bbdb-address-streets address)))
+ (concat (if streets
+ (concat (mapconcat 'identity streets "\n") "\n"))
+ (bbdb-concat ", " (bbdb-address-city address)
+ (bbdb-concat " " (bbdb-address-state address)
+ (bbdb-address-postcode address)))
+ (unless (or (not country) (string= "" country))
+ (concat "\n" country)))))
+
+(defun bbdb-format-address (address layout)
+ "Format ADDRESS using LAYOUT. Return result as a string.
+The formatting rules are defined in `bbdb-address-format-list'."
+ (let ((list bbdb-address-format-list)
+ (country (bbdb-address-country address))
+ elt string)
+ (while (and (not string) (setq elt (pop list)))
+ (let ((identifier (car elt))
+ (format (nth layout elt))
+ ;; recognize case for format identifiers
+ case-fold-search str)
+ (when (or (eq t identifier) ; default
+ (and (functionp identifier)
+ (funcall identifier address))
+ (and country
+ (listp identifier)
+ ;; ignore case for countries
+ (member-ignore-case country identifier)))
+ (cond ((functionp format)
+ (setq string (funcall format address)))
+ ((stringp format)
+ (setq string "")
+ (dolist (form (split-string (substring format 1 -1)
+ (substring format 0 1) t))
+ (cond ((string-match "%s" form) ; street
+ (mapc (lambda (s) (setq string (concat string
(format form s))))
+ (bbdb-address-streets address)))
+ ((string-match "%c" form) ; city
+ (unless (or (not (setq str (bbdb-address-city
address))) (string= "" str))
+ (setq string (concat string (format
(replace-regexp-in-string "%c" "%s" form) str)))))
+ ((string-match "%p" form) ; postcode
+ (unless (or (not (setq str (bbdb-address-postcode
address))) (string= "" str))
+ (setq string (concat string (format
(replace-regexp-in-string "%p" "%s" form) str)))))
+ ((string-match "%S" form) ; state
+ (unless (or (not (setq str (bbdb-address-state
address))) (string= "" str))
+ (setq string (concat string (format
(replace-regexp-in-string "%S" "%s" form t) str)))))
+ ((string-match "%C" form) ; country
+ (unless (or (not country) (string= "" country))
+ (setq string (concat string (format
(replace-regexp-in-string "%C" "%s" form t) country)))))
+ (t (error "Malformed address format element %s"
form)))))
+ (t (error "Malformed address format %s" format))))))
+ (unless string
+ (error "No match of `bbdb-address-format-list'"))
+ string))
+
+;;; Record display:
+;; This inserts formatted (pieces of) records into the BBDB buffer.
+
+(defsubst bbdb-field-property (start field)
+ "Set text property bbdb-field of text between START and point to FIELD."
+ (put-text-property start (point) 'bbdb-field field))
+
+(defsubst bbdb-display-text (text field &optional face)
+ "Insert TEXT at point. Set its text property bbdb-field to FIELD.
+If FACE is non-nil, also add face FACE."
+ (let ((start (point)))
+ (insert text)
+ (bbdb-field-property start field)
+ (if face (put-text-property start (point) 'face face))))
+
+(defun bbdb-display-list (list field &optional terminator face indent)
+ "Insert elements of LIST at point.
+For inserted text, set text property bbdb-field to FIELD.
+If TERMINATOR is non-nil use it to terminate the inserted text.
+If FACE is non-nil use it as FACE for inserted text.
+If INDENT and `bbdb-wrap-column' are integers, insert line breaks in between
+elements of LIST if otherwise inserted text exceeds `bbdb-wrap-column'."
+ ;; `truncate-lines' is fine for one-line layout. But it is annyoing
+ ;; for records that are displayed with multi-line layout.
+ ;; Non-nil `word-wrap' would be much nicer. How can we switch between
+ ;; non-nil `truncate-lines' and non-nil `word-wrap' on a per-record basis?
+ ;; The following code is an alternative solution using `bbdb-wrap-column'.
+ (let* ((separator (nth 1 (or (cdr (assq field bbdb-separator-alist))
+ bbdb-default-separator)))
+ (indent-flag (and (integerp bbdb-wrap-column)
+ (integerp indent)))
+ (prefix (if indent-flag
+ (concat separator "\n" (make-string indent ?\s))))
+ elt)
+ (while (setq elt (pop list))
+ (bbdb-display-text elt (list field elt) face)
+ (cond ((and list indent-flag
+ (> (+ (current-column) (length (car list)))
+ bbdb-wrap-column))
+ (bbdb-display-text prefix (list field) face))
+ (list
+ (bbdb-display-text separator (list field) face))
+ (terminator
+ (bbdb-display-text terminator (list field) face))))))
+
+(defun bbdb-display-name-organization (record)
+ "Insert name, affix, and organization of RECORD.
+If RECORD has an xfield name-face, its value is used for font-locking name.
+The value of name-face may be a face that is used directly.
+The value may also be a key in `bbdb-name-face-alist'. Then the
+corresponding cdr is used. If none of these schemes succeeds the face
+`bbdb-face' is used."
+ ;; Should this be further customizable? We could build the following
+ ;; from a customizable list containing function calls and strings.
+ ;; Name
+ (let ((name (if (eq 'last-first
+ (or (bbdb-record-xfield-intern record 'name-format)
+ bbdb-name-format))
+ (bbdb-record-name-lf record)
+ ;; default: Firstname Lastname
+ (bbdb-record-name record)))
+ (name-face (bbdb-record-xfield record 'name-face)))
+ (if (string= "" name) (setq name "???"))
+ (bbdb-display-text name (list 'name name)
+ (if name-face
+ (cond ((facep name-face) name-face)
+ ((cdr (assoc name-face bbdb-name-face-alist)))
+ (t 'bbdb-name))
+ 'bbdb-name)))
+ ;; Affix
+ (let ((affix (bbdb-record-affix record)))
+ (when affix
+ (insert ", ")
+ (bbdb-display-list affix 'affix)))
+ ;; Organization
+ (let ((organization (bbdb-record-organization record)))
+ (when organization
+ (insert " - ")
+ (bbdb-display-list organization 'organization nil
+ 'bbdb-organization)))
+ ;; Image
+ (if (and bbdb-image (display-images-p))
+ (let ((image (cond ((functionp bbdb-image)
+ (funcall bbdb-image record))
+ ((memq bbdb-image '(name fl-name))
+ (bbdb-record-name record))
+ ((eq bbdb-image 'lf-name)
+ (bbdb-record-name-lf record))
+ (t
+ (bbdb-record-xfield record bbdb-image)))))
+ (when (and image
+ (setq image (locate-file image bbdb-image-path
+ bbdb-image-suffixes))
+ (setq image (create-image image)))
+ (insert " ")
+ (insert-image image)))))
+
+(defun bbdb-display-record-one-line (record layout field-list)
+ "Format RECORD for the one-line FORMAT using LAYOUT.
+See `bbdb-layout-alist' for more info on layouts.
+FIELD-LIST is the list of actually displayed FIELDS."
+ ;; Name, affix, and organizations
+ (bbdb-display-name-organization record)
+ (let ((name-end (or (bbdb-layout-get-option layout 'name-end)
+ 40))
+ (start (line-beginning-position)))
+ (when (> (- (point) start -1) name-end)
+ (put-text-property (+ start name-end -4) (point) 'invisible t)
+ (insert "..."))
+ (indent-to name-end))
+ ;; rest of the fields
+ (let (formatfun start)
+ (dolist (field field-list)
+ (cond (;; customized formatting
+ (setq formatfun (intern-soft (format "bbdb-display-%s-one-line"
field)))
+ (funcall formatfun record))
+ ;; phone
+ ((eq field 'phone)
+ (let ((phones (bbdb-record-phone record)) phone)
+ (if phones
+ (while (setq phone (pop phones))
+ (bbdb-display-text (format "%s " (aref phone 0))
+ `(phone ,phone field-label)
+ 'bbdb-field-name)
+ (bbdb-display-text (format "%s%s" (aref phone 1)
+ (if phones " " "; "))
+ `(phone ,phone))))))
+ ;; address
+ ((eq field 'address)
+ (dolist (address (bbdb-record-address record))
+ (setq start (point))
+ (insert (bbdb-format-address address 3))
+ (bbdb-field-property start `(address ,address))
+ (insert "; ")))
+ ;; mail
+ ((eq field 'mail)
+ (let ((mail (bbdb-record-mail record)))
+ (if mail
+ (bbdb-display-list (if (bbdb-layout-get-option layout
'primary)
+ (list (car mail)) mail)
+ 'mail "; "))))
+ ;; AKA
+ ((eq field 'aka)
+ (let ((aka (bbdb-record-aka record)))
+ (if aka
+ (bbdb-display-list aka 'aka "; "))))
+ ;; uuid
+ ((eq field 'uuid)
+ (let ((uuid (bbdb-record-uuid record)))
+ (bbdb-display-text (format "%s; " uuid) `(uuid ,uuid))))
+ ;; creation-date
+ ((eq field 'creation-date)
+ (let ((creation-date (bbdb-record-creation-date record)))
+ (bbdb-display-text (format "%s; " creation-date)
`(creation-date ,creation-date))))
+ ;; timestamp
+ ((eq field 'timestamp)
+ (let ((timestamp (bbdb-record-timestamp record)))
+ (bbdb-display-text (format "%s; " timestamp) `(timestamp
,timestamp))))
+ ;; xfields
+ (t
+ (let* ((xfield (assq field (bbdb-record-xfields record)))
+ (value (cdr xfield)))
+ (if value
+ (bbdb-display-text
+ (concat (if (stringp value)
+ (replace-regexp-in-string
+ "\n" "; " value)
+ ;; value of xfield is a sexp
+ (let ((print-escape-newlines t))
+ (prin1-to-string value)))
+ "; ")
+ `(xfields ,xfield)))))))
+ ;; delete the trailing "; "
+ (if (looking-back "; " nil)
+ (backward-delete-char 2))
+ (insert "\n")))
+
+(defun bbdb-display-record-multi-line (record layout field-list)
+ "Format RECORD for the multi-line FORMAT using LAYOUT.
+See `bbdb-layout-alist' for more info on layouts.
+FIELD-LIST is the list of actually displayed FIELDS."
+ (bbdb-display-name-organization record)
+ (insert "\n")
+ (let* ((indent (or (bbdb-layout-get-option layout 'indentation) 21))
+ ;; The format string FMT adds three extra characters.
+ ;; So we subtract those from the value of INDENT.
+ (fmt (format " %%%ds: " (- indent 3)))
+ start formatfun)
+ (dolist (field field-list)
+ (setq start (point))
+ (cond (;; customized formatting
+ (setq formatfun (intern-soft (format "bbdb-display-%s-multi-line"
field)))
+ (funcall formatfun record indent))
+ ;; phone
+ ((eq field 'phone)
+ (dolist (phone (bbdb-record-phone record))
+ (bbdb-display-text (format fmt (concat "phone ("
+ (bbdb-phone-label phone)
+ ")"))
+ `(phone ,phone field-label)
+ 'bbdb-field-name)
+ (bbdb-display-text (concat (bbdb-phone-string phone) "\n")
+ `(phone ,phone))))
+ ;; address
+ ((eq field 'address)
+ (dolist (address (bbdb-record-address record))
+ (bbdb-display-text (format fmt (concat "address ("
+ (bbdb-address-label
address)
+ ")"))
+ `(address ,address field-label)
+ 'bbdb-field-name)
+ (setq start (point))
+ (insert (bbdb-indent-string (bbdb-format-address address 2)
indent)
+ "\n")
+ (bbdb-field-property start `(address ,address))))
+ ;; mail
+ ((eq field 'mail)
+ (let ((mail (bbdb-record-mail record)))
+ (when mail
+ (bbdb-display-text (format fmt "mail") '(mail nil field-label)
+ 'bbdb-field-name)
+ (bbdb-display-list (if (bbdb-layout-get-option layout
'primary)
+ (list (car mail)) mail)
+ 'mail "\n" nil indent))))
+ ;; AKA
+ ((eq field 'aka)
+ (let ((aka (bbdb-record-aka record)))
+ (when aka
+ (bbdb-display-text (format fmt "AKA") '(aka nil field-label)
+ 'bbdb-field-name)
+ (bbdb-display-list aka 'aka "\n"))))
+ ;; uuid
+ ((eq field 'uuid)
+ (let ((uuid (bbdb-record-uuid record)))
+ (bbdb-display-text (format fmt "uuid") `(uuid ,uuid field-label)
+ 'bbdb-field-name)
+ (bbdb-display-text (format "%s\n" uuid) `(uuid ,uuid))))
+ ;; creation-date
+ ((eq field 'creation-date)
+ (let ((creation-date (bbdb-record-creation-date record)))
+ (bbdb-display-text (format fmt "creation-date") `(creation-date
,creation-date field-label)
+ 'bbdb-field-name)
+ (bbdb-display-text (format "%s\n" creation-date)
`(creation-date ,creation-date))))
+ ;; timestamp
+ ((eq field 'timestamp)
+ (let ((timestamp (bbdb-record-timestamp record)))
+ (bbdb-display-text (format fmt "timestamp") `(timestamp
,timestamp field-label)
+ 'bbdb-field-name)
+ (bbdb-display-text (format "%s\n" timestamp) `(timestamp
,timestamp))))
+ ;; xfields
+ (t
+ (let* ((xfield (assq field (bbdb-record-xfields record)))
+ (value (cdr xfield)))
+ (when value
+ (bbdb-display-text (format fmt field)
+ `(xfields ,xfield field-label)
+ 'bbdb-field-name)
+ (setq start (point))
+ (insert (bbdb-indent-string
+ (if (stringp value)
+ value
+ ;; value of xfield is a sexp
+ (let ((string (pp-to-string value)))
+ (if (string-match "[ \t\n]+\\'" string)
+ (substring-no-properties
+ string 0 (match-beginning 0))
+ string)))
+ indent) "\n")
+ (bbdb-field-property start `(xfields ,xfield)))))))
+ (insert "\n")))
+
+(defalias 'bbdb-display-record-full-multi-line
+ 'bbdb-display-record-multi-line)
+
+(defalias 'bbdb-display-record-pop-up-multi-line
+ 'bbdb-display-record-multi-line)
+
+(defun bbdb-display-record (record layout number)
+ "Insert a formatted RECORD into the current buffer at point.
+LAYOUT can be a symbol describing a layout in `bbdb-layout-alist'.
+If it is nil, use `bbdb-layout'.
+NUMBER is the number of RECORD among the displayed records.
+Move point to the end of the inserted record."
+ (unless layout (setq layout bbdb-layout))
+ (unless (assq layout bbdb-layout-alist)
+ (error "Unknown layout `%s'" layout))
+ (let ((display-p (bbdb-layout-get-option layout 'display-p))
+ (omit-list (bbdb-layout-get-option layout 'omit)) ; omitted fields
+ (order-list (bbdb-layout-get-option layout 'order)); requested field
order
+ (all-fields (append '(phone address mail aka) ; default field order
+ (mapcar 'car (bbdb-record-xfields record))
+ '(uuid creation-date timestamp)))
+ (beg (point))
+ format-function field-list)
+ (when (or (not display-p)
+ (and display-p
+ (funcall display-p)))
+ (if (functionp omit-list)
+ (setq omit-list (funcall omit-list record layout)))
+ (if (functionp order-list)
+ (setq order-list (funcall order-list record layout)))
+ ;; first omit unwanted fields
+ (when (and omit-list (or (not order-list) (memq t order-list)))
+ (if (listp omit-list)
+ ;; show all fields except those listed here
+ (dolist (omit omit-list)
+ (setq all-fields (delq omit all-fields)))
+ (setq all-fields nil))) ; show nothing
+ ;; then order them
+ (cond ((not order-list)
+ (setq field-list all-fields))
+ ((not (memq t order-list))
+ (setq field-list order-list))
+ (t
+ (setq order-list (reverse order-list)
+ all-fields (delq nil (mapcar (lambda (f)
+ (unless (memq f order-list)
+ f))
+ all-fields)))
+ (dolist (order order-list)
+ (if (eq t order)
+ (setq field-list (append all-fields field-list))
+ (push order field-list)))))
+ ;; call the actual format function
+ (setq format-function
+ (intern-soft (format "bbdb-display-record-%s" layout)))
+ (if (functionp format-function)
+ (funcall format-function record layout field-list)
+ (bbdb-display-record-multi-line record layout field-list))
+ (put-text-property beg (point) 'bbdb-record-number number))))
+
+(defun bbdb-display-records (records &optional layout append
+ select horiz-p)
+ "Display RECORDS using LAYOUT.
+If APPEND is non-nil append RECORDS to the already displayed records.
+Otherwise RECORDS overwrite the displayed records.
+SELECT and HORIZ-P have the same meaning as in `bbdb-pop-up-window'."
+ (interactive (list (bbdb-completing-read-records "Display records: ")
+ (bbdb-layout-prefix)))
+ (if (bbdb-append-display-p) (setq append t))
+ ;; `bbdb-redisplay-record' calls `bbdb-display-records'
+ ;; with display information already amended to RECORDS.
+ (unless (or (null records)
+ (consp (car records)))
+ ;; add layout and a marker to the local list of records
+ (setq layout (or layout bbdb-layout)
+ records (mapcar (lambda (record)
+ (list record layout (make-marker)))
+ records)))
+
+ (let ((first-new (caar records)) ; first new record
+ new-name)
+
+ ;; If `bbdb-multiple-buffers' is non-nil we create a new BBDB buffer
+ ;; when not already within one. The new buffer name starts with a space,
+ ;; i.e. it does not clutter the buffer list.
+ (when (and bbdb-multiple-buffers
+ (not (assq 'bbdb-buffer-name (buffer-local-variables))))
+ (setq new-name (concat " *BBDB " (if (functionp bbdb-multiple-buffers)
+ (funcall bbdb-multiple-buffers)
+ (buffer-name))
+ "*"))
+ ;; `bbdb-buffer-name' becomes buffer-local in the current buffer
+ ;; as well as in the buffer `bbdb-buffer-name'
+ (set (make-local-variable 'bbdb-buffer-name) new-name))
+
+ (with-current-buffer (get-buffer-create bbdb-buffer-name) ; *BBDB*
+ ;; If we are appending RECORDS to the ones already displayed,
+ ;; then first remove any duplicates, and then sort them.
+ (if append
+ (let ((old-rec (mapcar 'car bbdb-records)))
+ (dolist (record records)
+ (unless (memq (car record) old-rec)
+ (push record bbdb-records)))
+ (setq records
+ (sort bbdb-records
+ (lambda (x y) (bbdb-record-lessp (car x) (car y)))))))
+
+ (bbdb-mode)
+ ;; Normally `bbdb-records' is the only BBDB-specific buffer-local
variable
+ ;; in the *BBDB* buffer. It is intentionally not permanent-local.
+ ;; A value of nil indicates that we need to (re)process the records.
+ (setq bbdb-records records)
+ (if new-name
+ (set (make-local-variable 'bbdb-buffer-name) new-name))
+
+ (unless (or bbdb-silent-internal bbdb-silent)
+ (message "Formatting BBDB..."))
+ (let ((record-number 0)
+ buffer-read-only all-records)
+ (erase-buffer)
+ (bbdb-debug (setq all-records (bbdb-records)))
+ (dolist (record records)
+ (bbdb-debug (unless (memq (car record) all-records)
+ (error "Record %s does not exist" (car record))))
+ (set-marker (nth 2 record) (point))
+ (bbdb-display-record (nth 0 record) (nth 1 record) record-number)
+ (setq record-number (1+ record-number)))
+
+ (run-hooks 'bbdb-display-hook))
+
+ (unless (or bbdb-silent-internal bbdb-silent)
+ (message "Formatting BBDB...done."))
+ (set-buffer-modified-p nil)
+
+ (bbdb-pop-up-window select horiz-p)
+ (if (not first-new)
+ (goto-char (point-min))
+ ;; Put point on first new record in *BBDB* buffer.
+ (goto-char (nth 2 (assq first-new bbdb-records)))
+ (set-window-start (get-buffer-window (current-buffer)) (point))))))
+
+(defun bbdb-undisplay-records (&optional all-buffers)
+ "Undisplay records in *BBDB* buffer, leaving this buffer empty.
+If ALL-BUFFERS is non-nil undisplay records in all BBDB buffers."
+ (dolist (buffer (cond (all-buffers (buffer-list))
+ ((let ((buffer (get-buffer bbdb-buffer-name)))
+ (and (buffer-live-p buffer) (list buffer))))))
+ (with-current-buffer buffer
+ (when (eq major-mode 'bbdb-mode)
+ (let (buffer-read-only)
+ (erase-buffer))
+ (setq bbdb-records nil)
+ (set-buffer-modified-p nil)))))
+
+(defun bbdb-redisplay-record (record &optional sort delete-p)
+ "Redisplay RECORD in current BBDB buffer.
+If SORT is t, usually because RECORD has a new sortkey, re-sort
+the displayed records.
+If DELETE-P is non-nil RECORD is removed from the BBDB buffer."
+ ;; For deletion in the *BBDB* buffer we use the full information
+ ;; about the record in the database. Therefore, we need to delete
+ ;; the record in the *BBDB* buffer before deleting the record in
+ ;; the database.
+ ;; FIXME: If point is initially inside RECORD, `bbdb-redisplay-record'
+ ;; puts point at the beginning of the redisplayed RECORD.
+ ;; Ideally, `bbdb-redisplay-record' should put point such that it
+ ;; matches the previous value `bbdb-ident-point'.
+ (let ((full-record (assq record bbdb-records)))
+ (unless full-record
+ (error "Record `%s' not displayed" (bbdb-record-name record)))
+ (if (and sort (not delete-p))
+ ;; FIXME: For records requiring re-sorting it may be more efficient
+ ;; to insert these records in their proper location instead of
+ ;; re-displaying all records.
+ (bbdb-display-records (list record) nil t)
+ (let ((marker (nth 2 full-record))
+ (end-marker (nth 2 (car (cdr (memq full-record bbdb-records)))))
+ buffer-read-only record-number)
+ ;; If point is inside record, put it at the beginning of the record.
+ (if (and (<= marker (point))
+ (< (point) (or end-marker (point-max))))
+ (goto-char marker))
+ (save-excursion
+ (goto-char marker)
+ (setq record-number (get-text-property (point) 'bbdb-record-number))
+ (unless delete-p
+ ;; First insert the reformatted record, then delete the old one,
+ ;; so that the marker of this record cannot collapse with the
+ ;; marker of the subsequent record
+ (bbdb-display-record (car full-record) (nth 1 full-record)
+ record-number))
+ (delete-region (point) (or end-marker (point-max)))
+ ;; If we deleted a record we need to update the subsequent
+ ;; record numbers.
+ (when delete-p
+ (let* ((markers (append (mapcar (lambda (x) (nth 2 x))
+ (cdr (memq full-record
bbdb-records)))
+ (list (point-max))))
+ (start (pop markers)))
+ (dolist (end markers)
+ (put-text-property start end
+ 'bbdb-record-number record-number)
+ (setq start end
+ record-number (1+ record-number))))
+ (setq bbdb-records (delq full-record bbdb-records)))
+ (run-hooks 'bbdb-display-hook))))))
+
+(defun bbdb-redisplay-record-globally (record &optional sort delete-p)
+ "Redisplay RECORD in all BBDB buffers.
+If SORT is t, usually because RECORD has a new sortkey, re-sort
+the displayed records.
+If DELETE-P is non-nil RECORD is removed from the BBDB buffers."
+ (dolist (buffer (buffer-list))
+ (with-current-buffer buffer
+ (if (and (eq major-mode 'bbdb-mode)
+ (memq record (mapcar 'car bbdb-records)))
+ (let ((window (get-buffer-window bbdb-buffer-name)))
+ (if window
+ (with-selected-window window
+ (bbdb-redisplay-record record sort delete-p))
+ (bbdb-redisplay-record record sort delete-p)))))))
+(define-obsolete-function-alias 'bbdb-maybe-update-display
+ 'bbdb-redisplay-record-globally "3.0")
+
+
+;;; window configuration hackery
+(defun bbdb-pop-up-window (&optional select horiz-p)
+ "Display *BBDB* buffer by popping up a new window.
+Finds the largest window on the screen, splits it, displaying the
+*BBDB* buffer in the bottom `bbdb-pop-up-window-size' lines (unless
+the *BBDB* buffer is already visible, in which case do nothing.)
+Select this window if SELECT is non-nil.
+
+If `bbdb-mua-pop-up' is 'horiz, and the first window matching
+the predicate HORIZ-P is wider than the car of `bbdb-horiz-pop-up-window-size'
+then the window will be split horizontally rather than vertically."
+ (let ((buffer (get-buffer bbdb-buffer-name)))
+ (unless buffer
+ (error "No %s buffer to display" bbdb-buffer-name))
+ (cond ((let ((window (get-buffer-window buffer t)))
+ ;; We already have a BBDB window so that at most we select it
+ (and window
+ (or (not select) (select-window window)))))
+
+ ;; try horizontal split
+ ((and (eq bbdb-mua-pop-up 'horiz)
+ horiz-p
+ (>= (frame-width) (car bbdb-horiz-pop-up-window-size))
+ (let ((window-list (window-list))
+ (b-width (cdr bbdb-horiz-pop-up-window-size))
+ (search t) s-window)
+ (while (and (setq s-window (pop window-list))
+ (setq search (not (funcall horiz-p s-window)))))
+ (unless (or search (<= (window-width s-window)
+ (car bbdb-horiz-pop-up-window-size)))
+ (condition-case nil ; `split-window' might fail
+ (let ((window (split-window
+ s-window
+ (if (integerp b-width)
+ (- (window-width s-window) b-width)
+ (round (* (- 1 b-width) (window-width
s-window))))
+ t))) ; horizontal split
+ (set-window-buffer window buffer)
+ (cond (bbdb-dedicated-window
+ (set-window-dedicated-p window
bbdb-dedicated-window))
+ ((fboundp 'display-buffer-record-window) ; GNU
Emacs >= 24.1
+ (set-window-prev-buffers window nil)
+ (display-buffer-record-window 'window window
buffer)))
+ (if select (select-window window))
+ t)
+ (error nil))))))
+
+ ((eq t bbdb-pop-up-window-size)
+ (bbdb-pop-up-window-simple buffer select))
+
+ (t ;; vertical split
+ (let* ((window (selected-window))
+ (window-height (window-height window)))
+ ;; find the tallest window...
+ (mapc (lambda (w)
+ (let ((w-height (window-height w)))
+ (if (> w-height window-height)
+ (setq window w window-height w-height))))
+ (window-list))
+ (condition-case nil
+ (progn
+ (unless (eql bbdb-pop-up-window-size 1.0)
+ (setq window (split-window ; might fail
+ window
+ (if (integerp bbdb-pop-up-window-size)
+ (- window-height 1 ; for mode line
+ (max window-min-height
bbdb-pop-up-window-size))
+ (round (* (- 1 bbdb-pop-up-window-size)
+ window-height))))))
+ (set-window-buffer window buffer) ; might fail
+ (cond (bbdb-dedicated-window
+ (set-window-dedicated-p window
bbdb-dedicated-window))
+ ((and (fboundp 'display-buffer-record-window) ; GNU
Emacs >= 24.1
+ (not (eql bbdb-pop-up-window-size 1.0)))
+ (set-window-prev-buffers window nil)
+ (display-buffer-record-window 'window window
buffer)))
+ (if select (select-window window)))
+ (error (bbdb-pop-up-window-simple buffer select))))))))
+
+(defun bbdb-pop-up-window-simple (buffer select)
+ "Display BUFFER in some window, selecting it if SELECT is non-nil.
+If `bbdb-dedicated-window' is non-nil, mark the window as dedicated."
+ (let ((window (if select
+ (progn (pop-to-buffer buffer)
+ (get-buffer-window))
+ (display-buffer buffer))))
+ (if bbdb-dedicated-window
+ (set-window-dedicated-p window bbdb-dedicated-window))))
+
+
+;;; BBDB mode
+
+;;;###autoload
+(define-derived-mode bbdb-mode special-mode "BBDB"
+ "Major mode for viewing and editing the Insidious Big Brother Database.
+Letters no longer insert themselves. Numbers are prefix arguments.
+You can move around using the usual cursor motion commands.
+\\<bbdb-mode-map>
+\\[bbdb-add-mail-alias]\t Add new mail alias to visible records or \
+remove it.
+\\[bbdb-edit-field]\t Edit the field on the current line.
+\\[bbdb-delete-field-or-record]\t Delete the field on the \
+current line. If the current line is the\n\t first line of a record, then \
+delete the entire record.
+\\[bbdb-insert-field]\t Insert a new field into the current record. \
+Note that this\n\t will let you add new fields of your own as well.
+\\[bbdb-transpose-fields]\t Swap the field on the current line with the \
+previous field.
+\\[bbdb-dial]\t Dial the current phone field.
+\\[bbdb-next-record], \\[bbdb-prev-record]\t Move to the next or the previous \
+displayed record, respectively.
+\\[bbdb-create]\t Create a new record.
+\\[bbdb-toggle-records-layout]\t Toggle whether the current record is
displayed in a \
+one-line\n\t listing, or a full multi-line listing.
+\\[bbdb-do-all-records]\\[bbdb-toggle-records-layout]\t Do that \
+for all displayed records.
+\\[bbdb-merge-records]\t Merge the contents of the current record with \
+some other, and then\n\t delete the current record.
+\\[bbdb-omit-record]\t Remove the current record from the display without \
+deleting it from\n\t the database. This is often a useful thing to do \
+before using one\n\t of the `*' commands.
+\\[bbdb]\t Search for records in the database (on all fields).
+\\[bbdb-search-mail]\t Search for records by mail address.
+\\[bbdb-search-organization]\t Search for records by organization.
+\\[bbdb-search-xfields]\t Search for records by xfields.
+\\[bbdb-search-name]\t Search for records by name.
+\\[bbdb-search-changed]\t Display records that have changed since the database
\
+was saved.
+\\[bbdb-mail]\t Compose mail to the person represented by the \
+current record.
+\\[bbdb-do-all-records]\\[bbdb-mail]\t Compose mail \
+to everyone whose record is displayed.
+\\[bbdb-save]\t Save the BBDB file to disk.
+\\[bbdb-tex]\t Create a TeX listing of the current record.
+\\[bbdb-do-all-records]\\[bbdb-tex]\t Do that for all \
+displayed record.
+\\[other-window]\t Move to another window.
+\\[bbdb-info]\t Read the Info documentation for BBDB.
+\\[bbdb-help]\t Display a one line command summary in the echo area.
+\\[bbdb-browse-url]\t Visit Web sites listed in the `url' field(s) of the
current \
+record.
+
+For address completion using the names and mail addresses in the database:
+\t in Mail mode, type \\<mail-mode-map>\\[bbdb-complete-mail].
+\t in Message mode, type \\<message-mode-map>\\[bbdb-complete-mail].
+
+Important variables:
+\t `bbdb-auto-revert'
+\t `bbdb-ignore-redundant-mails'
+\t `bbdb-case-fold-search'
+\t `bbdb-completion-list'
+\t `bbdb-default-area-code'
+\t `bbdb-default-domain'
+\t `bbdb-layout'
+\t `bbdb-file'
+\t `bbdb-phone-style'
+\t `bbdb-check-auto-save-file'
+\t `bbdb-pop-up-layout'
+\t `bbdb-pop-up-window-size'
+\t `bbdb-add-name'
+\t `bbdb-add-aka'
+\t `bbdb-add-mails'
+\t `bbdb-new-mails-primary'
+\t `bbdb-read-only'
+\t `bbdb-mua-pop-up'
+\t `bbdb-user-mail-address-re'
+
+There are numerous hooks. M-x apropos ^bbdb.*hook RET
+
+\\{bbdb-mode-map}"
+ (setq truncate-lines t
+ default-directory (file-name-directory bbdb-file)
+ mode-line-buffer-identification
+ (list 24 (buffer-name) " "
+ '(:eval (format "%d/%d/%d"
+ (1+ (or (get-text-property
+ (point) 'bbdb-record-number) -1))
+ (length bbdb-records)
+ ;; This code gets called a lot.
+ ;; So we keep it as simple as possible.
+ (with-current-buffer bbdb-buffer
+ (length bbdb-records))))
+ '(:eval (concat " "
+ (bbdb-concat " " (elt bbdb-modeline-info 0)
+ (elt bbdb-modeline-info 2)
+ (elt bbdb-modeline-info 4)))))
+ mode-line-modified
+ ;; For the mode-line we want to be fast. So we skip the checks
+ ;; performed by `bbdb-with-db-buffer'.
+ '(:eval (if (buffer-modified-p bbdb-buffer)
+ (if bbdb-read-only "%*" "**")
+ (if bbdb-read-only "%%" "--"))))
+ ;; `bbdb-revert-buffer' acts on `bbdb-buffer'. Yet this command is usually
+ ;; called from the *BBDB* buffer.
+ (set (make-local-variable 'revert-buffer-function)
+ 'bbdb-revert-buffer)
+ (add-hook 'post-command-hook 'force-mode-line-update nil t))
+
+
+
+(defun bbdb-sendmail-menu (record)
+ "Menu items for email addresses of RECORD."
+ (let ((mails (bbdb-record-mail record)))
+ (list
+ (if (cdr mails)
+ ;; Submenu for multiple mail addresses
+ (cons "Send mail to..."
+ (mapcar (lambda (address)
+ (vector address `(bbdb-compose-mail
+ ,(bbdb-dwim-mail record address))
+ t))
+ mails))
+ ;; Single entry for single mail address
+ (vector (concat "Send mail to " (car mails))
+ `(bbdb-compose-mail ,(bbdb-dwim-mail record (car mails)))
+ t)))))
+
+(defun bbdb-field-menu (record field)
+ "Menu items specifically for FIELD of RECORD."
+ (let ((type (car field)))
+ (append
+ (list
+ (format "Commands for %s Field:"
+ (cond ((eq type 'xfields)
+ (format "\"%s\"" (symbol-name (car (nth 1 field)))))
+ ((eq type 'name) "Name")
+ ((eq type 'affix) "Affix")
+ ((eq type 'organization) "Organization")
+ ((eq type 'aka) "Alternate Names")
+ ((eq type 'mail) "Mail Addresses")
+ ((memq type '(address phone))
+ (format "\"%s\" %s" (aref (nth 1 field) 0)
+ (capitalize (symbol-name type)))))))
+ (cond ((eq type 'phone)
+ (list (vector (concat "Dial " (bbdb-phone-string (nth 1 field)))
+ `(bbdb-dial ',field nil) t)))
+ ((eq type 'xfields)
+ (let* ((field (cadr field))
+ (type (car field)))
+ (cond ((eq type 'url )
+ (list (vector (format "Browse \"%s\"" (cdr field))
+ `(bbdb-browse-url ,record) t)))))))
+ '(["Edit Field" bbdb-edit-field t])
+ (unless (eq type 'name)
+ '(["Delete Field" bbdb-delete-field-or-record t])))))
+
+(defun bbdb-insert-field-menu (record)
+ "Submenu for inserting a new field for RECORD."
+ (cons "Insert New Field..."
+ (mapcar
+ (lambda (field)
+ (if (stringp field) field
+ (vector (symbol-name field)
+ `(bbdb-insert-field
+ ,record ',field (bbdb-read-field ,record ',field
+ ,current-prefix-arg))
+ (not (or (and (eq field 'affix) (bbdb-record-affix
record))
+ (and (eq field 'organization)
+ (bbdb-record-organization record))
+ (and (eq field 'mail) (bbdb-record-mail record))
+ (and (eq field 'aka) (bbdb-record-aka record))
+ (assq field (bbdb-record-xfields record)))))))
+ (append '(affix organization aka phone address mail)
+ '("--") bbdb-xfield-label-list))))
+
+(defun bbdb-mouse-menu (event)
+ "BBDB mouse menu for EVENT,"
+ (interactive "e")
+ (mouse-set-point event)
+ (let* ((record (bbdb-current-record))
+ (field (bbdb-current-field))
+ (menu (if (and record field (functionp bbdb-user-menu-commands))
+ (funcall bbdb-user-menu-commands record field)
+ bbdb-user-menu-commands)))
+ (if record
+ (popup-menu
+ (append
+ (list
+ (format "Commands for record \"%s\":" (bbdb-record-name record))
+ ["Delete Record" bbdb-delete-records t]
+ ["Toggle Record Display Layout" bbdb-toggle-records-layout t]
+ (if (and (not (eq 'full-multi-line
+ (nth 1 (assq record bbdb-records))))
+ (bbdb-layout-get-option 'multi-line 'omit))
+ ["Fully Display Record" bbdb-display-records-completely t])
+ ["Omit Record" bbdb-omit-record t]
+ ["Merge Record" bbdb-merge-records t])
+ (if (bbdb-record-mail record)
+ (bbdb-sendmail-menu record))
+ (list "--" (bbdb-insert-field-menu record))
+ (if field
+ (cons "--" (bbdb-field-menu record field)))
+ (if menu
+ (append '("--" "User Defined Commands") menu)))))))
+
+
+
+(defun bbdb-scan-property (property predicate n)
+ "Scan for change of PROPERTY matching PREDICATE for N times.
+Return position of beginning of matching interval."
+ (let ((fun (if (< 0 n) 'next-single-property-change
+ 'previous-single-property-change))
+ (limit (if (< 0 n) (point-max) (point-min)))
+ (nn (abs n))
+ (i 0)
+ (opoint (point))
+ npoint)
+ ;; For backward search, move point to beginning of interval with PROPERTY.
+ (if (and (<= n 0)
+ (< (point-min) opoint)
+ (let ((prop (get-text-property opoint property)))
+ (and (eq prop (get-text-property (1- opoint) property))
+ (funcall predicate prop))))
+ (setq opoint (previous-single-property-change opoint property nil
limit)))
+ (if (zerop n)
+ opoint ; Return beginning of interval point is in
+ (while (and (< i nn)
+ (let (done)
+ (while (and (not done)
+ (setq npoint (funcall fun opoint property nil
limit)))
+ (cond ((and (/= opoint npoint)
+ (funcall predicate (get-text-property
+ npoint property)))
+ (setq opoint npoint done t))
+ ((= opoint npoint)
+ ;; Search reached beg or end of buffer: abort.
+ (setq done t i nn npoint nil))
+ (t (setq opoint npoint))))
+ done))
+ (setq i (1+ i)))
+ npoint)))
+
+(defun bbdb-next-record (n)
+ "Move point to the beginning of the next BBDB record.
+With prefix N move forward N records."
+ (interactive "p")
+ (let ((npoint (bbdb-scan-property 'bbdb-record-number 'integerp n)))
+ (if npoint (goto-char npoint)
+ (error "No %s record" (if (< 0 n) "next" "previous")))))
+
+(defun bbdb-prev-record (n)
+ "Move point to the beginning of the previous BBDB record.
+With prefix N move backwards N records."
+ (interactive "p")
+ (bbdb-next-record (- n)))
+
+(defun bbdb-next-field (n)
+ "Move point to next (sub)field.
+With prefix N move forward N (sub)fields."
+ (interactive "p")
+ (let ((npoint (bbdb-scan-property
+ 'bbdb-field
+ (lambda (p) (and (nth 1 p)
+ (not (eq (nth 2 p) 'field-label))))
+ n)))
+ (if npoint (goto-char npoint)
+ (error "No %s field" (if (< 0 n) "next" "previous")))))
+
+(defun bbdb-prev-field (n)
+ "Move point to previous (sub)field.
+With prefix N move backwards N (sub)fields."
+ (interactive "p")
+ (bbdb-next-field (- n)))
+
+(defun bbdb-save (&optional prompt noisy)
+ "Save the BBDB if it is modified.
+If PROMPT is non-nil prompt before saving.
+If NOISY is non-nil as in interactive calls issue status messages."
+ (interactive (list nil t))
+ (bbdb-with-db-buffer
+ (if (buffer-modified-p)
+ (if (or (not prompt)
+ (y-or-n-p
+ (if bbdb-read-only
+ "Save the BBDB, even though it is supposedly read-only? "
+ "Save the BBDB now? ")))
+ (save-buffer))
+ (if noisy (message "(No BBDB changes need to be saved)")))))
+
+;;;###autoload
+(defun bbdb-version (&optional arg)
+ "Return string describing the version of BBDB.
+With prefix ARG, insert string at point."
+ (interactive (list (or (and current-prefix-arg 1) t)))
+ (let* ((source (find-function-noselect 'bbdb-version))
+ (version
+ (when source
+ (with-current-buffer (car source)
+ (prog1
+ (save-excursion
+ (goto-char (point-min))
+ (when (re-search-forward "^;;+ *Version: \\(.*\\)" nil t)
+ (match-string-no-properties 1)))
+ (unless (get-buffer-window nil t)
+ (kill-buffer (current-buffer)))))))
+ (version-string (format "BBDB version %s" (or version "<unknown>"))))
+ (cond ((numberp arg) (insert (message version-string)))
+ ((eq t arg) (message version-string))
+ (t version-string))))
+
+
+
+(defun bbdb-sort-records ()
+ "Sort BBDB database.
+This is not needed when using BBDB itself. It might be necessary,
+however, after having used other programs to add records to the BBDB."
+ (interactive)
+ (let* ((records (copy-sequence (bbdb-records))))
+ (bbdb-with-db-buffer
+ (setq bbdb-records (sort bbdb-records 'bbdb-record-lessp))
+ (if (equal records bbdb-records)
+ (message "BBDB already sorted properly")
+ (message "BBDB was mis-sorted; fixing...")
+ (bbdb-goto-first-record)
+ (delete-region (point) bbdb-end-marker)
+ (let ((buf (current-buffer))
+ (inhibit-quit t) ; really, don't mess with this
+ cache)
+ (dolist (record bbdb-records)
+ ;; Before printing the record, remove cache (we do not want that
+ ;; written to the file.) Ater writing, put the cache back
+ ;; and update the cache's marker.
+ (setq cache (bbdb-record-cache record))
+ (set-marker (bbdb-cache-marker cache) (point))
+ (bbdb-record-set-cache record nil)
+ (bbdb-with-print-loadably (prin1 record buf))
+ (bbdb-record-set-cache record cache)
+ (insert ?\n)))
+ (dolist (buffer (buffer-list))
+ (with-current-buffer buffer
+ (if (eq major-mode 'bbdb-mode)
+ ; Redisplay all records
+ (bbdb-display-records nil nil t))))
+ (message "BBDB was mis-sorted; fixing...done")))))
+
+
+
+;;;###autoload
+(defun bbdb-initialize (&rest muas)
+ "Initialize BBDB for MUAS and miscellaneous packages.
+List MUAS may include the following symbols to initialize the respective
+mail/news readers, composers, and miscellaneous packages:
+ gnus Gnus mail/news reader.
+ mh-e MH-E mail reader.
+ mu4e Mu4e mail reader.
+ rmail Rmail mail reader.
+ vm VM mail reader.
+ mail Mail (M-x mail).
+ message Message mode.
+ wl Wanderlust mail reader.
+
+ anniv Anniversaries in Emacs diary.
+
+ sc Supercite. However, this is not the full story.
+ See bbdb-sc.el for how to fully hook BBDB into Supercite.
+
+ pgp PGP support: this adds `bbdb-pgp' to `message-send-hook'
+ and `mail-send-hook' so that `bbdb-pgp' runs automatically
+ when a message is sent.
+ Yet see info node `(message)Signing and encryption'
+ why you might not want to rely for encryption on a hook
+ function which runs just before the message is sent,
+ that is, you might want to call the command `bbdb-pgp' manually,
+ then call `mml-preview'.
+
+See also `bbdb-mua-auto-update-init'. The latter is a separate function
+as this allows one to initialize the auto update feature for some MUAs only,
+for example only for outgoing messages."
+ (dolist (mua muas)
+ (let ((init (assq mua bbdb-init-forms)))
+ (if init
+ ;; Should we make sure that each insinuation happens only once?
+ (eval (cadr init))
+ (bbdb-warn "Do not know how to insinuate `%s'" mua))))
+ (run-hooks 'bbdb-initialize-hook))
+
+
+(provide 'bbdb)
+
+;;; bbdb.el ends here
diff --git a/lisp/bbdb/tex/bbdb.sty b/lisp/bbdb/tex/bbdb.sty
new file mode 100644
index 0000000..8165e78
--- /dev/null
+++ b/lisp/bbdb/tex/bbdb.sty
@@ -0,0 +1,89 @@
+% bbdb.sty --- basic LaTeX style for TeXing BBDB
+%
+% Copyright (C) 2017 Roland Winkler <address@hidden>
+%
+% This file is part of the Insidious Big Brother Database (aka BBDB),
+%
+% BBDB 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 3 of the License, 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 BBDB. If not, see <http://www.gnu.org/licenses/>.
+
+%% Commentary:
+%
+% This file defines a basic LaTeX style for TeXing BBDB.
+
address@hidden, #1}}
address@hidden
address@hidden:} #1}
address@hidden:} #1}
address@hidden:} #2}
address@hidden
+ \texttt{#2}%
+ \else
+ \href{mailto:#1}{\texttt{#2}}%
+ \fi}
address@hidden:} #2}
address@hidden:} #2}
+
+% address@hidden
address@hidden
address@hidden@address@hidden #1\rule{0pt}{2.2ex}\ \hrulefill}\\}
+
+\RequirePackage{longtable}
+\newenvironment{bbdb}[1]{%
address@hidden
address@hidden
address@hidden
address@hidden
address@hidden
address@hidden
address@hidden
address@hidden
address@hidden
address@hidden@{}}}%
+{\\ \hline address@hidden \today}\\ \hline\end{longtable}}
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
address@hidden, #1}\dotfill\par}}
address@hidden
address@hidden@par{\emph{affix:} #1}}
address@hidden@par{\emph{aka:} #1}}
address@hidden:} #2\par}
address@hidden
+ \texttt{#2}%
+ \else
+ \href{mailto:#1}{\texttt{#2}}%
+ \fi\par}
address@hidden 1em\parindent -\leftskip#1\par}}
address@hidden@par{\emph{#1:} #2}}
address@hidden@par{\emph{#1:} #2}}
+
+\newenvironment{bbdbrecord}{%
+\smallbreak
+\parskip 0pt
+\parindent 0pt
address@hidden
address@hidden
address@hidden
address@hidden
address@hidden
address@hidden
address@hidden
address@hidden
+
+\newcommand*{\bbdbseparator}[1]{\vspace{3ex}\noindent
+ \fbox{\parbox{\dimexpr\linewidth-2\fboxrule-2\fboxsep}%
+ {\centering\textbf{#1}}}%
+ \vspace{1ex}}
+
+% \endinput % Fails when inlining this file.
- [Emacs-diffs] scratch/eudc-bbdb-3 06c3557 08/15: EUDC: Require bbdb and bbdb-com without ignoring errors, (continued)
- [Emacs-diffs] scratch/eudc-bbdb-3 06c3557 08/15: EUDC: Require bbdb and bbdb-com without ignoring errors, Thomas Fitzsimmons, 2017/11/21
- [Emacs-diffs] scratch/eudc-bbdb-3 2beb511 04/15: EUDC: Wrap long line in BBDB backend, Thomas Fitzsimmons, 2017/11/21
- [Emacs-diffs] scratch/eudc-bbdb-3 f529b7d 07/15: EUDC: Fix issues reported by checkdoc, Thomas Fitzsimmons, 2017/11/21
- [Emacs-diffs] scratch/eudc-bbdb-3 262dce0 09/15: EUDC: Remove external BBDB function declarations, Thomas Fitzsimmons, 2017/11/21
- [Emacs-diffs] scratch/eudc-bbdb-3 69e8cb9 15/15: EUDC: Port eudc-export.el to BBDB >= 3, Thomas Fitzsimmons, 2017/11/21
- [Emacs-diffs] scratch/eudc-bbdb-3 f1ab95d 12/15: EUDC: Require bbdb, bbdb-com without NOERROR, Thomas Fitzsimmons, 2017/11/21
- [Emacs-diffs] scratch/eudc-bbdb-3 c80692b 05/15: EUDC: Keep phone and address lists in BBDB-order, Thomas Fitzsimmons, 2017/11/21
- [Emacs-diffs] scratch/eudc-bbdb-3 05257b9 10/15: EUDC: Port BBDB backend to BBDB >= 3, Thomas Fitzsimmons, 2017/11/21
- [Emacs-diffs] scratch/eudc-bbdb-3 6e680a7 06/15: EUDC: Print multiple BBDB addresses properly, Thomas Fitzsimmons, 2017/11/21
- [Emacs-diffs] scratch/eudc-bbdb-3 eaf20ca 13/15: EUDC: Fix whitespace in eudc-export.el, Thomas Fitzsimmons, 2017/11/21
- [Emacs-diffs] scratch/eudc-bbdb-3 9bfbbd4 01/15: BBDB: Import BBDB 3,
Thomas Fitzsimmons <=