diff options
author | Amin Bandali <bandali@gnu.org> | 2018-12-08 14:56:23 -0500 |
---|---|---|
committer | Amin Bandali <bandali@gnu.org> | 2018-12-08 14:56:23 -0500 |
commit | 1a5de666921e000b24ed02ffae5a03cc5caddc45 (patch) | |
tree | 6cb89634eb2d5218a04af71c47b50bda7460692f /lisp/bbdb/bbdb.el | |
parent | 17bbf85f47e0b02c250e112beb234653a7be57ab (diff) | |
download | configs-1a5de666921e000b24ed02ffae5a03cc5caddc45.tar.gz configs-1a5de666921e000b24ed02ffae5a03cc5caddc45.tar.xz configs-1a5de666921e000b24ed02ffae5a03cc5caddc45.zip |
[emacs] manually add bbdb into lisp/bbdb/
Diffstat (limited to '')
-rw-r--r-- | lisp/bbdb/bbdb.el | 4733 |
1 files changed, 4733 insertions, 0 deletions
diff --git a/lisp/bbdb/bbdb.el b/lisp/bbdb/bbdb.el new file mode 100644 index 0000000..e38ac17 --- /dev/null +++ b/lisp/bbdb/bbdb.el @@ -0,0 +1,4733 @@ +;;; bbdb.el --- core of BBDB -*- lexical-binding: t -*- + +;; Copyright (C) 2010-2017 Free Software Foundation, Inc. + +;; Version: 3.2 +;; 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: | +;; | bbdb-user@nongnu.org | +;; | 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) +(require 'bbdb-site) + +;; 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" "@%s\n@%p, @%c@, %S@\n%C@" "@%c@") + (("Australia") "scSpC" "@%s\n@%c@ %S@ %p@\n%C@" "@%c@") + (("Austria" "Germany" "Spain" "Switzerland") + "spcSC" "@%s\n@%p @%c@ (%S)@\n%C@" "@%c@") + (("Canada") "scSCp" "@%s\n@%c@, %S@\n%C@ %p@" "@%c@") + (("China") "scpSC" "@%s\n@%c@\n%p@ %S@\n%C@" "@%c@") ; English format + ; (("China") "CpScs" "@%C @%p\n@%S @%c@ %s@" "@%c@") ; Chinese format + (("India") "scpSC" "@%s\n@%c@ %p@ (%S)@\n%C@" "@%c@") + (("USA") "scSpC" "@%s\n@%c@, %S@ %p@\n%C@" "@%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 `[@%!]', 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 + ;; <dominik@astro.uva.nl> + "^[ \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 <MLofdahl@solar.stanford.edu>. + ;; (result is ("SE" (133 36))) + "^[ \t\n]*\\([A-Z]+\\)[ \t\n]*-?[ \t\n]*\\([0-9]+\\)[ \t\n]+\\([0-9]+\\)[ \t\n]*$") + "List of regexps that match legal 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 "\\`\\([^@]*\\)\\(@\\|\\'\\)" 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 <jqs@frob.com>\" +versus \"John Q. Smith <jqs@frob.com>\". +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 <jqs@foo.com>\" +versus \"John Q. Smith <jqs@bar.com>\". +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, \"foo@bar.baz.com\" is redundant w.r.t. \"foo@baz.com\". +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\" (\"-vm@\" . \"VM mailing list\")) + (\"Subject\" (\"sprocket\" . \"mail about sprockets\") + (\"you bonehead\" . \"called me a bonehead\"))) + +will cause the text \"VM mailing list\" to be added to the notes field +of the 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 `<Joe_Smith@foo.com>' +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 `<foo@bar>' first in order to handle the quite common + ;; form `"abc@xyz" <foo@bar>' (i.e. `@' as part of a comment) + ;; correctly. + (string-match "<\\([^@ \t<>]+[!@][^@ \t<>]+\\)>" mail) + (setq address (match-string 1 mail))) + ((string-match "\\b[^@ \t<>]+[!@][^@ \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 "\\`\\([^@%!]+@\\).*\\.\\(" 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 "jwz%thalidomide@lucid.com" (instead of simply + ;; "jwz@lucid.com"). This removes the workstation name. + ((string-match "\\`\\([^@%!]+\\)%[^@%!.]+@\\(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 "user@some.outside.host" end up looking like + ;; "user%some.outside.host" or even "user%some.outside.host@lucid.com" + ;; instead. This rule rewrites it into the original form. + ((string-match "\\`\\([^@%]+\\)%\\([^@%!]+\\)\\(@lucid\\.com\\)?\\'" address) + (concat (match-string 1 address) "@" (match-string 2 address))) + ;; + ;; Sometimes I see addresses like "foobar.com!user@foobar.com". + ;; That's totally redundant, so this rewrites it as "user@foobar.com". + ((string-match "\\`\\([^@%!]+\\)!\\([^@%!]+[@%]\\1\\)\\'" address) + (match-string 2 address)) + ;; + ;; Sometimes I see addresses like "foobar.com!user". Turn it around. + ((string-match "\\`\\([^@%!.]+\\.[^@%!]+\\)!\\([^@%]+\\)\\'" 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 "user@foo.com" into "user%foo.com@hplb.hpl.hp.com". + ;; This reverses it. (I actually could have combined this rule with + ;; the similar lucid.com rule above, but then the regexp would have been + ;; more than 80 characters long...) + ((string-match "\\`\\([^@!]+\\)%\\([^@%!]+\\)@hplb\\.hpl\\.hp\\.com\\'" + address) + (concat (match-string 1 address) "@" (match-string 2 address))) + ;; + ;; Another local mail-configuration botch: sometimes mail shows up + ;; with addresses like "user@workstation", where "workstation" is a + ;; local machine name. That should really be "user" or "user@netscape.com". + ;; (I'm told this one is due to a bug in SunOS 4.1.1 sendmail.) + ((string-match "\\`\\([^@%!]+\\)[@%][^@%!.]+\\'" address) + (match-string 1 address)) + ;; + ;; Sometimes I see addresses like "foo%somewhere%uunet.uu.net@somewhere.else". + ;; This is silly, because I know that I can send mail to uunet directly. + ((string-match ".%uunet\\.uu\\.net@[^@%!]+\\'" 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 "^\\([^@]+\\)@" 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* ((version + (if (string-match "\\`[ \t\n]*[1-9]" bbdb-version) + bbdb-version + (let ((source (find-function-noselect 'bbdb-version))) + (if 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 |