[emacs] manually add bbdb into lisp/bbdb/
[~bandali/configs] / lisp / bbdb / bbdb.el
... / ...
CommitLineData
1;;; bbdb.el --- core of BBDB -*- lexical-binding: t -*-
2
3;; Copyright (C) 2010-2017 Free Software Foundation, Inc.
4
5;; Version: 3.2
6;; Package-Requires: ((emacs "24"))
7
8;; This file is part of the Insidious Big Brother Database (aka BBDB),
9
10;; BBDB is free software: you can redistribute it and/or modify
11;; it under the terms of the GNU General Public License as published by
12;; the Free Software Foundation, either version 3 of the License, or
13;; (at your option) any later version.
14
15;; BBDB is distributed in the hope that it will be useful,
16;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18;; GNU General Public License for more details.
19
20;; You should have received a copy of the GNU General Public License
21;; along with BBDB. If not, see <http://www.gnu.org/licenses/>.
22
23;;; Commentary:
24
25;; This file is the core of the Insidious Big Brother Database (aka BBDB),
26;; See the BBDB info manual for documentation.
27;;
28;; -----------------------------------------------------------------------
29;; | There is a mailing list for discussion of BBDB: |
30;; | bbdb-user@nongnu.org |
31;; | To join, go to https://lists.nongnu.org/mailman/listinfo/bbdb-user |
32;; | |
33;; | When joining this list or reporting bugs, please mention which |
34;; | version of BBDB you have. |
35;; -----------------------------------------------------------------------
36
37;;; Code:
38
39(require 'timezone)
40(require 'bbdb-site)
41
42;; When running BBDB, we have (require 'bbdb-autoloads)
43(declare-function widget-group-match "wid-edit")
44(declare-function bbdb-migrate "bbdb-migrate")
45(declare-function bbdb-do-records "bbdb-com")
46(declare-function bbdb-append-display-p "bbdb-com")
47(declare-function bbdb-toggle-records-layout "bbdb-com")
48(declare-function bbdb-dwim-mail "bbdb-com")
49(declare-function bbdb-layout-prefix "bbdb-com")
50(declare-function bbdb-completing-read-records "bbdb-com")
51(declare-function bbdb-merge-records "bbdb-com")
52(declare-function mail-position-on-field "sendmail")
53(declare-function vm-select-folder-buffer "vm-folder")
54
55;; cannot use autoload for variables...
56(defvar message-mode-map) ;; message.el
57(defvar mail-mode-map) ;; sendmail.el
58(defvar gnus-article-buffer) ;; gnus-art.el
59
60;; Custom groups
61
62(defgroup bbdb nil
63 "The Insidious Big Brother Database."
64 :group 'news
65 :group 'mail)
66
67(defgroup bbdb-record-display nil
68 "Variables that affect the display of BBDB records"
69 :group 'bbdb)
70
71(defgroup bbdb-record-edit nil
72 "Variables that affect the editing of BBDB records"
73 :group 'bbdb)
74
75(defgroup bbdb-sendmail nil
76 "Variables that affect sending mail."
77 :group 'bbdb)
78
79(defgroup bbdb-mua nil
80 "Variables that specify the BBDB-MUA interface"
81 :group 'bbdb)
82
83(defgroup bbdb-mua-gnus nil
84 "Gnus-specific BBDB customizations"
85 :group 'bbdb-mua)
86(put 'bbdb-mua-gnus 'custom-loads '(bbdb-gnus))
87
88(defgroup bbdb-mua-gnus-scoring nil
89 "Gnus-specific scoring BBDB customizations"
90 :group 'bbdb-mua-gnus)
91(put 'bbdb-mua-gnus-scoring 'custom-loads '(bbdb-gnus))
92
93(defgroup bbdb-mua-gnus-splitting nil
94 "Gnus-specific splitting BBDB customizations"
95 :group 'bbdb-mua-gnus)
96(put 'bbdb-mua-gnus-splitting 'custom-loads '(bbdb-gnus))
97
98(defgroup bbdb-mua-vm nil
99 "VM-specific BBDB customizations"
100 :group 'bbdb-mua)
101(put 'bbdb-mua-vm 'custom-loads '(bbdb-vm))
102
103(defgroup bbdb-mua-message nil
104 "Message-specific BBDB customizations"
105 :group 'bbdb-mua)
106(put 'bbdb-mua-message 'custom-loads '(bbdb-message))
107
108(defgroup bbdb-utilities nil
109 "Customizations for BBDB Utilities"
110 :group 'bbdb)
111
112(defgroup bbdb-utilities-dialing nil
113 "BBDB Customizations for phone number dialing"
114 :group 'bbdb)
115
116(defgroup bbdb-utilities-tex nil
117 "Customizations for TeXing BBDB."
118 :group 'bbdb)
119(put 'bbdb-utilities-tex 'custom-loads '(bbdb-tex))
120
121(defgroup bbdb-utilities-anniv nil
122 "Customizations for BBDB Anniversaries"
123 :group 'bbdb-utilities)
124(put 'bbdb-utilities-anniv 'custom-loads '(bbdb-anniv))
125
126(defgroup bbdb-utilities-ispell nil
127 "Customizations for BBDB ispell interface"
128 :group 'bbdb-utilities)
129(put 'bbdb-utilities-ispell 'custom-loads '(bbdb-ispell))
130
131(defgroup bbdb-utilities-snarf nil
132 "Customizations for BBDB snarf"
133 :group 'bbdb-utilities)
134(put 'bbdb-utilities-snarf 'custom-loads '(bbdb-snarf))
135
136(defgroup bbdb-utilities-pgp nil
137 "Customizations for BBDB pgp"
138 :group 'bbdb-utilities)
139(put 'bbdb-utilities-pgp 'custom-loads '(bbdb-pgp))
140
141(defgroup bbdb-utilities-sc nil
142 "Customizations for using Supercite with the BBDB."
143 :group 'bbdb-utilities
144 :prefix "bbdb-sc")
145(put 'bbdb-utilities-sc 'custom-loads '(bbdb-sc))
146
147;;; Customizable variables
148(defcustom bbdb-file (locate-user-emacs-file "bbdb" ".bbdb")
149 "The name of the Insidious Big Brother Database file."
150 :group 'bbdb
151 :type 'file)
152
153;; This should be removed, and the following put in place:
154;; a hierarchical structure of bbdb files, some perhaps read-only,
155;; perhaps caching in the local bbdb. This way one could have, e.g. an
156;; organization address book, with each person having access to it, and
157;; then a local address book with personal stuff in it.
158(defcustom bbdb-file-remote nil
159 "The remote file to save the BBDB database to.
160When this is non-nil, it should be a file name.
161When BBDB reads `bbdb-file', it also checks this file,
162and if it is newer than `bbdb-file', it loads this file.
163When BBDB writes `bbdb-file', it also writes this file.
164
165This feature allows one to keep the database in one place while using
166different computers, thus reducing the need for merging different files."
167 :group 'bbdb
168 :type '(choice (const :tag "none" nil)
169 (file :tag "remote file name")))
170
171(defcustom bbdb-file-remote-save-always t
172 "If t `bbdb-file-remote' is saved automatically when `bbdb-file' is saved.
173When nil, ask."
174 :group 'bbdb
175 :type 'boolean)
176
177(defcustom bbdb-read-only nil
178 "If t then BBDB will not modify `bbdb-file'.
179If you have more than one Emacs running at the same time, you might want
180to set this to t in all but one of them."
181 :group 'bbdb
182 :type '(choice (const :tag "Database is read-only" t)
183 (const :tag "Database is writable" nil)))
184
185(defcustom bbdb-auto-revert nil
186 "If t revert unchanged database without querying.
187If t and `bbdb-file' has changed on disk, while the database
188has not been modified inside Emacs, revert the database automatically.
189If nil or the database has been changed inside Emacs, always query
190before reverting."
191 :group 'bbdb
192 :type '(choice (const :tag "Revert unchanged database without querying" t)
193 (const :tag "Ask before reverting database" nil)))
194
195(defcustom bbdb-check-auto-save-file nil
196 "If t BBDB will check its auto-save file.
197If this file is newer than `bbdb-file', BBDB will offer to revert."
198 :group 'bbdb
199 :type '(choice (const :tag "Check auto-save file" t)
200 (const :tag "Do not check auto-save file" nil)))
201
202(defcustom bbdb-before-save-hook nil
203 "Hook run before saving `bbdb-file'."
204 :group 'bbdb
205 :type 'hook)
206
207(defcustom bbdb-after-save-hook nil
208 "Hook run after saving `bbdb-file'."
209 :group 'bbdb
210 :type 'hook)
211
212(defcustom bbdb-create-hook nil
213 "*Hook run each time a new BBDB record is created.
214Run with one argument, the new record. This is called before the record is
215added to the database, followed by a call of `bbdb-change-hook'.
216
217If a record has been created by analyzing a mail message, hook functions
218can use the variable `bbdb-update-records-address' to determine the header
219and class of the mail address according to `bbdb-message-headers'."
220 :group 'bbdb
221 :type 'hook)
222
223(defcustom bbdb-change-hook nil
224 "*Hook run each time a BBDB record is changed.
225Run with one argument, the record. This is called before the database
226is modified. If a new bbdb record is created, `bbdb-create-hook' is called
227first, followed by a call of this hook."
228 :group 'bbdb
229 :type 'hook)
230
231(defcustom bbdb-merge-records-function nil
232 "If non-nil, a function for merging two records.
233This function is called when loading a record into BBDB that has the same uuid
234as an exisiting record. If nil use `bbdb-merge-records'.
235This function should take two arguments RECORD1 and RECORD2, with RECORD2
236being the already existing record. It should merge RECORD1 into RECORD2,
237and return RECORD2."
238 :group 'bbdb
239 :type 'function)
240
241(defcustom bbdb-time-stamp-format "%Y-%m-%d %T %z"
242 "The BBDB time stamp format. See `format-time-string'.
243This function is called with arg UNIVERSAL being non-nil."
244 :group 'bbdb
245 :type 'string)
246
247(defcustom bbdb-after-change-hook nil
248 "Hook run each time a BBDB record is changed.
249Run with one argument, the record. This is called after the database
250is modified. So if you want to modify a record when it is created or changed,
251use instead `bbdb-create-hook' and / or `bbdb-change-hook'."
252 :group 'bbdb
253 :type 'hook)
254
255(defcustom bbdb-after-read-db-hook nil
256 "Hook run (with no arguments) after `bbdb-file' is read.
257Note that this can be called more than once if the BBDB is reverted."
258 :group 'bbdb
259 :type 'hook)
260
261(defcustom bbdb-initialize-hook nil
262 "Normal hook run after the BBDB initialization function `bbdb-initialize'."
263 :group 'bbdb
264 :type 'hook)
265
266(defcustom bbdb-mode-hook nil
267 "Normal hook run when the *BBDB* buffer is created."
268 :group 'bbdb
269 :type 'hook)
270
271(defcustom bbdb-silent nil
272 "If t, BBDB suppresses all its informational messages and queries.
273Be very very certain you want to set this to t, because it will suppress
274queries to alter record names, assign names to addresses, etc.
275Lisp Hackers: See also `bbdb-silent-internal'."
276 :group 'bbdb
277 :type '(choice (const :tag "Run silently" t)
278 (const :tag "Disable silent running" nil)))
279
280(defcustom bbdb-info-file nil
281 "Location of the bbdb info file, if it's not in the standard place."
282 :group 'bbdb
283 :type '(choice (const :tag "Standard location" nil)
284 (file :tag "Nonstandard location")))
285
286\f
287;;; Record display
288
289(defcustom bbdb-pop-up-window-size 0.5
290 "Vertical size of BBDB window (vertical split).
291If it is an integer number, it is the number of lines used by BBDB.
292If it is a fraction between 0.0 and 1.0 (inclusive), it is the fraction
293of the tallest existing window that BBDB will take over.
294If it is t use `display-buffer'/`pop-to-buffer' to create the BBDB window.
295See also `bbdb-mua-pop-up-window-size'."
296 :group 'bbdb-record-display
297 :type '(choice (number :tag "BBDB window size")
298 (const :tag "Use `pop-to-buffer'" t)))
299
300(defcustom bbdb-dedicated-window nil
301 "Make *BBDB* window a dedicated window.
302Allowed values include nil (not dedicated) 'bbdb (weakly dedicated)
303and t (strongly dedicated)."
304 :group 'bbdb-record-display
305 :type '(choice (const :tag "BBDB window not dedicated" nil)
306 (const :tag "BBDB window weakly dedicated" bbdb)
307 (const :tag "BBDB window strongly dedicated" t)))
308
309(defcustom bbdb-layout-alist
310 '((one-line (order . (phone mail-alias mail notes))
311 (name-end . 24)
312 (toggle . t))
313 (multi-line (omit . (uuid creation-date timestamp
314 name-format name-face))
315 (toggle . t)
316 (indentation . 21))
317 (pop-up-multi-line (omit . (uuid creation-date timestamp
318 name-format name-face))
319 (indentation . 21))
320 (full-multi-line (indentation . 21)))
321 "Alist describing each display layout.
322The format of an element is (LAYOUT-NAME OPTION-ALIST).
323
324By default there are four different layout types used by BBDB, which are
325`one-line', `multi-line', `pop-up-multi-line' (used for pop-ups) and
326`full-multi-line' (showing all fields of a record).
327
328OPTION-ALIST specifies the options for the layout. Valid options are:
329
330 ------- Availability --------
331 Format one-line multi-line default if unset
332------------------------------------------------------------------------------
333 (toggle . BOOL) + + nil
334 (order . FIELD-LIST) + + '(phone ...)
335 (omit . FIELD-LIST) + + nil
336 (name-end . INTEGER) + - 40
337 (indentation . INTEGER) - + 21
338 (primary . BOOL) - + nil
339 (display-p . FUNCTION) + + nil
340
341- toggle: controls if this layout is included when toggeling the layout
342- order: defines a user specific order for the fields, where t is a place
343 holder for all remaining fields
344- omit: is a list of xfields which should not be displayed
345 or t to exclude all xfields except those listed in the order option
346- name-end: sets the column where the name should end in one-line layout.
347- indentation: sets the level of indentation for multi-line display.
348- primary: controls whether only the primary mail is shown or all are shown.
349- display-p: a function controlling whether the record is to be displayed.
350
351When you add a new layout FOO, you can write a corresponding layout
352function `bbdb-display-record-layout-FOO'. If you do not write your own
353layout function, the multi-line layout will be used."
354 :group 'bbdb-record-display
355 :type
356 `(repeat
357 (cons :tag "Layout Definition"
358 (choice :tag "Layout type"
359 (const one-line)
360 (const multi-line)
361 (const pop-up-multi-line)
362 (const full-multi-line)
363 (symbol))
364 (set :tag "Properties"
365 (cons :tag "Order"
366 (const :tag "List of fields to order by" order)
367 (repeat (choice (const phone)
368 (const address)
369 (const mail)
370 (const AKA)
371 (const notes)
372 (symbol :tag "other")
373 (const :tag "Remaining fields" t))))
374 (choice :tag "Omit"
375 :value (omit . nil)
376 (cons :tag "List of fields to omit"
377 (const :tag "Fields not to display" omit)
378 (repeat (choice (const phone)
379 (const address)
380 (const mail)
381 (const AKA)
382 (const notes)
383 (symbol :tag "other"))))
384 (const :tag "Exclude all fields except those listed in the order note" t))
385 (cons :tag "Indentation"
386 :value (indentation . 14)
387 (const :tag "Level of indentation for multi-line layout"
388 indentation)
389 (number :tag "Column"))
390 (cons :tag "End of name field"
391 :value (name-end . 24)
392 (const :tag "The column where the name should end in one-line layout"
393 name-end)
394 (number :tag "Column"))
395 (cons :tag "Toggle"
396 (const :tag "The layout is included when toggling layout" toggle)
397 boolean)
398 (cons :tag "Primary Mail Only"
399 (const :tag "Only the primary mail address is included" primary)
400 boolean)
401 (cons :tag "Display-p"
402 (const :tag "Show only records passing this test" display-p)
403 (choice (const :tag "No test" nil)
404 (function :tag "Predicate")))))))
405
406(defcustom bbdb-layout 'multi-line
407 "Default display layout."
408 :group 'bbdb-record-display
409 :type '(choice (const one-line)
410 (const multi-line)
411 (const full-multi-line)
412 (symbol)))
413
414(defcustom bbdb-pop-up-layout 'pop-up-multi-line
415 "Default layout for pop-up BBDB buffers (mail, news, etc.)."
416 :group 'bbdb-record-display
417 :type '(choice (const one-line)
418 (const multi-line)
419 (const full-multi-line)
420 (symbol)))
421
422(defcustom bbdb-wrap-column nil
423 "Wrap column for multi-line display. If nil do not wrap lines."
424 :group 'bbdb-record-display
425 :type '(choice (const :tag "No line wrapping" nil)
426 (number :tag "Wrap column")))
427
428(defcustom bbdb-case-fold-search (default-value 'case-fold-search)
429 "Value of `case-fold-search' used by BBDB and friends.
430This variable lets the case-sensitivity of the BBDB commands
431be different from standard commands like command `isearch-forward'."
432 :group 'bbdb-record-display
433 :type 'boolean)
434
435(defcustom bbdb-name-format 'first-last
436 "Format for displaying names.
437If first-last names are displayed as \"Firstname Lastname\".
438If last-first names are displayed as \"Lastname, Firstname\".
439This can be overriden per record via the xfield name-format,
440which should take the same values.
441See also `bbdb-read-name-format'."
442 :group 'bbdb-record-display
443 :type '(choice (const :tag "Firstname Lastname" first-last)
444 (const :tag "Lastname, Firstname" last-first)))
445
446;; See http://en.wikipedia.org/wiki/Postal_address
447;; http://www.upu.int/en/activities/addressing/postal-addressing-systems-in-member-countries.html
448(defcustom bbdb-address-format-list
449 '((("Argentina") "spcSC" "@%s\n@%p, @%c@, %S@\n%C@" "@%c@")
450 (("Australia") "scSpC" "@%s\n@%c@ %S@ %p@\n%C@" "@%c@")
451 (("Austria" "Germany" "Spain" "Switzerland")
452 "spcSC" "@%s\n@%p @%c@ (%S)@\n%C@" "@%c@")
453 (("Canada") "scSCp" "@%s\n@%c@, %S@\n%C@ %p@" "@%c@")
454 (("China") "scpSC" "@%s\n@%c@\n%p@ %S@\n%C@" "@%c@") ; English format
455 ; (("China") "CpScs" "@%C @%p\n@%S @%c@ %s@" "@%c@") ; Chinese format
456 (("India") "scpSC" "@%s\n@%c@ %p@ (%S)@\n%C@" "@%c@")
457 (("USA") "scSpC" "@%s\n@%c@, %S@ %p@\n%C@" "@%c@")
458 (t bbdb-edit-address-default bbdb-format-address-default "@%c@"))
459 "List of address editing and formatting rules for BBDB.
460Each rule is a list (IDENTIFIER EDIT FORMAT FORMAT).
461The first rule for which IDENTIFIER matches an address is used for editing
462and formatting the address.
463
464IDENTIFIER may be a list of countries.
465IDENTIFIER may also be a function that is called with one arg, the address
466to be used. The rule applies if the function returns non-nil.
467See `bbdb-address-continental-p' for an example.
468If IDENTIFIER is t, this rule always applies. Usually, this should be
469the last rule that becomes a fall-back (default).
470
471EDIT may be a function that is called with one argument, the address.
472See `bbdb-edit-address-default' for an example.
473
474EDIT may also be an editting format string. It is a string containing
475the five letters s, c, p, S, and C that specify the order for editing
476the five elements of an address:
477
478s streets
479c city
480p postcode
481S state
482C country
483
484The first FORMAT of each rule is used for multi-line layout, the second FORMAT
485is used for one-line layout.
486
487FORMAT may be a function that is called with one argument, the address.
488See `bbdb-format-address-default' for an example.
489
490FORMAT may also be a format string. It consists of formatting elements
491separated by a delimiter defined via the first (and last) character of FORMAT.
492Each formatting element may contain one of the following format specifiers:
493
494%s streets (used repeatedly for each street part)
495%c city
496%p postcode
497%S state
498%C country
499
500A formatting element will be applied only if the corresponding part
501of the address is a non-empty string.
502
503See also `bbdb-tex-address-format-list'."
504 :group 'bbdb-record-display
505 :type '(repeat (list (choice (const :tag "Default" t)
506 (function :tag "Function")
507 (repeat (string)))
508 (choice (string)
509 (function :tag "Function"))
510 (choice (string)
511 (function :tag "Function"))
512 (choice (string)
513 (function :tag "Function")))))
514
515(defcustom bbdb-continental-postcode-regexp
516 "^\\s *[A-Z][A-Z]?\\s *-\\s *[0-9][0-9][0-9]"
517 "Regexp matching continental postcodes.
518Used by address format identifier `bbdb-address-continental-p'.
519The regexp should match postcodes of the form CH-8052, NL-2300RA,
520and SE-132 54."
521 :group 'bbdb-record-display
522 :type 'regexp)
523
524(defcustom bbdb-default-separator '("[,;]" ", ")
525 "The default field separator. It is a list (SPLIT-RE JOIN).
526This is used for fields which do not have an entry in `bbdb-separator-alist'.
527Whitespace surrounding SPLIT-RE is ignored."
528 :group 'bbdb-record-display
529 :type '(list regexp string))
530
531(defcustom bbdb-separator-alist
532 '((record "\n\n" "\n\n") ; used by `bbdb-copy-fields-as-kill'
533 (name-first-last "[ ,;]" " ") (name-last-first "[ ,;]" ", ")
534 (name-field ":\n" ":\n") ; used by `bbdb-copy-fields-as-kill'
535 (phone "[,;]" ", ") (address ";\n" ";\n") ; ditto
536 (organization "[,;]" ", ") (affix "[,;]" ", ") (aka "[,;]" ", ")
537 (mail "[,;]" ", ") (mail-alias "[,;]" ", ") (vm-folder "[,;]" ", ")
538 (birthday "\n" "\n") (wedding "\n" "\n") (anniversary "\n" "\n")
539 (notes "\n" "\n") (tex-name "#" " # "))
540 "Alist of field separators.
541Each element is of the form (FIELD SPLIT-RE JOIN).
542Whitespace surrounding SPLIT-RE is ignored.
543For fields lacking an entry here `bbdb-default-separator' is used instead."
544 :group 'bbdb-record-display
545 :type '(repeat (list symbol regexp string)))
546
547(defcustom bbdb-user-menu-commands nil
548 "User defined menu entries which should be appended to the BBDB menu.
549This should be a list of menu entries.
550When set to a function, it is called with two arguments RECORD and FIELD
551and it should either return nil or a list of menu entries.
552Used by `bbdb-mouse-menu'."
553 :group 'bbdb-record-display
554 :type 'sexp)
555
556(defcustom bbdb-display-hook nil
557 "Hook run after the *BBDB* is filled in."
558 :group 'bbdb-record-display
559 :type 'hook)
560
561(defcustom bbdb-multiple-buffers nil
562 "When non-nil we create a new buffer of every buffer causing pop-ups.
563You can also set this to a function returning a buffer name.
564Here a value may be the predefined function `bbdb-multiple-buffers-default'."
565 :group 'bbdb-record-display
566 :type '(choice (const :tag "Disabled" nil)
567 (function :tag "Enabled" bbdb-multiple-buffers-default)
568 (function :tag "User defined function")))
569
570(defcustom bbdb-image nil
571 "If non-nil display records with an image.
572If a symbol this should be an xfield holding the name of the image file
573associated with the record. If it is `name' or `fl-name', the first and last
574name of the record are used as file name. If it is `lf-name', the last and
575first name of the record are used as file name.
576If a function it is called with one arg, the record, and it should return
577the name of the image file.
578The file is searched in the directories in `bbdb-image-path'.
579File name suffixes are appended according to `bbdb-image-suffixes'.
580See `locate-file'."
581 :group 'bbdb-record-display
582 :type '(choice (const :tag "Disabled" nil)
583 (function :tag "User defined function")
584 (symbol :tag "Record field")))
585
586(defcustom bbdb-image-path nil
587 "List of directories to search for `bbdb-image'."
588 :group 'bbdb-record-display
589 :type '(repeat (directory)))
590
591(defcustom bbdb-image-suffixes '(".png" ".jpg" ".gif" ".xpm")
592 "List of file name suffixes searched for `bbdb-image'."
593 :group 'bbdb-record-display
594 :type '(repeat (string :tag "File suffix")))
595
596(defcustom bbdb-read-name-format 'fullname
597 "Default format for reading names via `bbdb-read-name'.
598If it is 'first-last read first and last name separately.
599If it is 'last-first read last and first name separately.
600With any other value read full name at once.
601See also `bbdb-name-format'."
602 :group 'bbdb-record-display
603 :type '(choice (const :tag "Firstname Lastname" first-last)
604 (const :tag "Lastname, Firstname" last-first)
605 (const :tag "Full name" fullname)))
606
607\f
608;;; Record editing
609(defcustom bbdb-lastname-prefixes
610 '("von" "de" "di")
611 "List of lastname prefixes recognized in name fields.
612Used to enhance dividing name strings into firstname and lastname parts.
613Case is ignored."
614 :group 'bbdb-record-edit
615 :type '(repeat string))
616
617(defcustom bbdb-lastname-re
618 (concat "[- \t]*\\(\\(?:\\<"
619 (regexp-opt bbdb-lastname-prefixes)
620 ;; multiple last names concatenated by `-'
621 "\\>[- \t]+\\)?\\(?:\\w+[ \t]*-[ \t]*\\)*\\w+\\)\\'")
622 "Regexp matching the last name of a full name.
623Its first parenthetical subexpression becomes the last name."
624 :group 'bbdb-record-edit
625 :type 'regexp)
626
627(defcustom bbdb-lastname-suffixes
628 '("Jr" "Sr" "II" "III")
629 "List of lastname suffixes recognized in name fields.
630Used to dividing name strings into firstname and lastname parts.
631All suffixes are complemented by optional `.'. Case is ignored."
632 :group 'bbdb-record-edit
633 :type '(repeat string))
634
635(defcustom bbdb-lastname-suffix-re
636 (concat "[-,. \t/\\]+\\("
637 (regexp-opt bbdb-lastname-suffixes)
638 ;; suffices are complemented by optional `.'.
639 "\\.?\\)\\W*\\'")
640 "Regexp matching the suffix of a last name.
641Its first parenthetical subexpression becomes the suffix."
642 :group 'bbdb-record-edit
643 :type 'regexp)
644
645(defcustom bbdb-default-domain nil
646 "Default domain to append when reading a new mail address.
647If a mail address does not contain `[@%!]', append @`bbdb-default-domain' to it.
648
649The address is not altered if `bbdb-default-domain' is nil
650or if a prefix argument is given to the command `bbdb-insert-field'."
651 :group 'bbdb-record-edit
652 :type '(choice (const :tag "none" nil)
653 (string :tag "Default Domain")))
654
655(defcustom bbdb-phone-style 'nanp
656 "Phone numbering plan assumed by BBDB.
657The value 'nanp refers to the North American Numbering Plan.
658The value nil refers to a free-style numbering plan.
659
660You can have both styles of phone number in your database by providing a
661prefix argument to the command `bbdb-insert-field'."
662 :group 'bbdb-record-edit
663 :type '(choice (const :tag "NANP" nanp)
664 (const :tag "none" nil)))
665
666(defcustom bbdb-default-area-code nil
667 "Default area code to use when reading a new phone number.
668This variable also affects dialing."
669 :group 'bbdb-record-edit
670 :type '(choice (const :tag "none" nil)
671 (integer :tag "Default Area Code"))
672 :set (lambda( symb val )
673 (if (or (and (stringp val)
674 (string-match "^[0-9]+$" val))
675 (integerp val)
676 (null val))
677 (set symb val)
678 (error "%s must contain digits only." symb))))
679
680(defcustom bbdb-allow-duplicates nil
681 "When non-nil BBDB allows records with duplicate names and email addresses.
682In rare cases, this may lead to confusion with BBDB's MUA interface."
683 :group 'bbdb-record-edit
684 :type 'boolean)
685
686(defcustom bbdb-default-label-list '("home" "work" "other")
687 "Default list of labels for Address and Phone fields."
688 :group 'bbdb-record-edit
689 :type '(repeat string))
690
691(defcustom bbdb-address-label-list bbdb-default-label-list
692 "List of labels for Address field."
693 :group 'bbdb-record-edit
694 :type '(repeat string))
695
696(defcustom bbdb-phone-label-list '("home" "work" "cell" "other")
697 "List of labels for Phone field."
698 :group 'bbdb-record-edit
699 :type '(repeat string))
700
701(defcustom bbdb-default-country "Emacs";; what do you mean, it's not a country?
702 "Default country to use if none is specified."
703 :group 'bbdb-record-edit
704 :type '(choice (const :tag "None" nil)
705 (string :tag "Default Country")))
706
707(defcustom bbdb-check-postcode t
708 "If non-nil, require legal postcodes when entering an address.
709The format of legal postcodes is determined by the variable
710`bbdb-legal-postcodes'."
711 :group 'bbdb-record-edit
712 :type 'boolean)
713
714(defcustom bbdb-legal-postcodes
715 '(;; empty string
716 "^$"
717 ;; Matches 1 to 6 digits.
718 "^[ \t\n]*[0-9][0-9]?[0-9]?[0-9]?[0-9]?[0-9]?[ \t\n]*$"
719 ;; Matches 5 digits and 3 or 4 digits.
720 "^[ \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]*$"
721 ;; Match postcodes for Canada, UK, etc. (result is ("LL47" "U4B")).
722 "^[ \t\n]*\\([A-Za-z0-9]+\\)[ \t\n]+\\([A-Za-z0-9]+\\)[ \t\n]*$"
723 ;; Match postcodes for continental Europe. Examples "CH-8057"
724 ;; or "F - 83320" (result is ("CH" "8057") or ("F" "83320")).
725 ;; Support for "NL-2300RA" added at request from Carsten Dominik
726 ;; <dominik@astro.uva.nl>
727 "^[ \t\n]*\\([A-Z]+\\)[ \t\n]*-?[ \t\n]*\\([0-9]+ ?[A-Z]*\\)[ \t\n]*$"
728 ;; Match postcodes from Sweden where the five digits are grouped 3+2
729 ;; at the request from Mats Lofdahl <MLofdahl@solar.stanford.edu>.
730 ;; (result is ("SE" (133 36)))
731 "^[ \t\n]*\\([A-Z]+\\)[ \t\n]*-?[ \t\n]*\\([0-9]+\\)[ \t\n]+\\([0-9]+\\)[ \t\n]*$")
732 "List of regexps that match legal postcodes.
733Whether this is used at all depends on the variable `bbdb-check-postcode'."
734 :group 'bbdb-record-edit
735 :type '(repeat regexp))
736
737(defcustom bbdb-default-xfield 'notes
738 "Default xfield when editing BBDB records."
739 :group 'bbdb-record-edit
740 :type '(symbol :tag "Xfield"))
741
742(defcustom bbdb-edit-foo (cons bbdb-default-xfield 'current-fields)
743 "Fields to edit with command `bbdb-edit-foo'.
744This is a cons pair (WITHOUT-PREFIX . WITH-PREFIX).
745The car is used if the command is called without a prefix.
746The cdr is used if the command is called with a prefix.
747
748WITHOUT-PREFIX and WITH-PREFIX may take the values:
749 name The full name
750 affix The list of affixes
751 organization The list of organizations
752 aka the list of AKAs
753 mail the list of email addresses
754 phone the list of phone numbers
755 address the list of addresses
756 current-fields Read the field to edit using a completion table
757 that includes all fields of the current record.
758 all-fields Read the field to edit using a completion table
759 that includes all fields currently known to BBDB.
760
761Any other symbol is interpreted as the label of an xfield."
762 :group 'bbdb-record-edit
763 :type '(cons (symbol :tag "Field without prefix")
764 (symbol :tag "Field with prefix")))
765
766\f
767;;; MUA interface
768
769(defcustom bbdb-annotate-field bbdb-default-xfield
770 "Field to annotate via `bbdb-annotate-record' and friends.
771This may take the values:
772 affix The list of affixes
773 organization The list of organizations
774 aka the list of AKAs
775 mail the list of email addresses
776 all-fields Read the field to edit using a completion table
777 that includes all fields currently known to BBDB.
778
779Any other symbol is interpreted as the label of an xfield."
780 :group 'bbdb-mua
781 :type '(symbol :tag "Field to annotate"))
782
783(defcustom bbdb-mua-edit-field bbdb-default-xfield
784 "Field to edit with command `bbdb-mua-edit-field' and friends.
785This may take the values:
786 name The full name
787 affix The list of affixes
788 organization The list of organizations
789 aka the list of AKAs
790 mail the list of email addresses
791 all-fields Read the field to edit using a completion table
792 that includes all fields currently known to BBDB.
793
794Any other symbol is interpreted as the label of an xfield."
795 :group 'bbdb-mua
796 :type '(symbol :tag "Field to edit"))
797
798(defcustom bbdb-mua-update-interactive-p '(search . query)
799 "How BBDB's interactive MUA commands update BBDB records.
800This is a cons pair (WITHOUT-PREFIX . WITH-PREFIX).
801The car is used if the command is called without a prefix.
802The cdr is used if the command is called with a prefix (and if the prefix
803 is not used for another purpose).
804
805WITHOUT-PREFIX and WITH-PREFIX may take the values
806\(here ADDRESS is an email address found in a message):
807 nil Do nothing.
808 search Search for existing records matching ADDRESS.
809 update Search for existing records matching ADDRESS;
810 update name and mail field if necessary.
811 query Search for existing records matching ADDRESS;
812 query for creation of a new record if the record does not exist.
813 create or t Search for existing records matching ADDRESS;
814 create a new record if it does not yet exist.
815 a function This functions will be called with no arguments.
816 It should return one of the above values.
817 read Read the value interactively."
818 :group 'bbdb-mua
819 :type '(cons (choice (const :tag "do nothing" nil)
820 (const :tag "search for existing records" search)
821 (const :tag "update existing records" update)
822 (const :tag "query annotation of all messages" query)
823 (const :tag "annotate all messages" create)
824 (function :tag "User-defined function")
825 (const :tag "read arg interactively" read))
826 (choice (const :tag "do nothing" nil)
827 (const :tag "search for existing records" search)
828 (const :tag "update existing records" update)
829 (const :tag "query annotation of all messages" query)
830 (const :tag "annotate all messages" create)
831 (function :tag "User-defined function")
832 (const :tag "read arg interactively" read))))
833
834(defcustom bbdb-mua-auto-update-p 'bbdb-select-message
835 "How `bbdb-mua-auto-update' updates BBDB records automatically.
836
837Allowed values are (here ADDRESS is an email address found in a message):
838 nil Do nothing.
839 search Search for existing records matching ADDRESS.
840 update Search for existing records matching ADDRESS;
841 update name and mail field if necessary.
842 query Search for existing records matching ADDRESS;
843 query for creation of a new record if the record does not exist.
844 create or t Search for existing records matching ADDRESS;
845 create a new record if it does not yet exist.
846 a function This functions will be called with no arguments.
847 It should return one of the above values.
848 For an example, see `bbdb-select-message' with
849 `bbdb-mua-update-records-p', `bbdb-accept-message-alist'
850 and `bbdb-ignore-message-alist'.
851
852To initiate auto-updating of BBDB records, call `bbdb-mua-auto-update-init'
853for the respective MUAs in your init file."
854 :group 'bbdb-mua
855 :type '(choice (const :tag "do nothing" nil)
856 (const :tag "search for existing records" search)
857 (const :tag "update existing records" update)
858 (const :tag "query annotation of all messages" query)
859 (const :tag "annotate all messages" create)
860 (function :tag "User-defined function")))
861
862(defcustom bbdb-update-records-p 'search
863 "Return value for `bbdb-select-message' and friends.
864These functions can select messages for further processing by BBDB,
865The amount of subsequent processing is determined by `bbdb-update-records-p'.
866
867Allowed values are (here ADDRESS is an email address selected
868by `bbdb-select-message'):
869 nil Do nothing.
870 search Search for existing records matching ADDRESS.
871 update Search for existing records matching ADDRESS;
872 update name and mail field if necessary.
873 query Search for existing records matching ADDRESS;
874 query for creation of a new record if the record does not exist.
875 create or t Search for existing records matching ADDRESS;
876 create a new record if it does not yet exist.
877 a function This functions will be called with no arguments.
878 It should return one of the above values."
879 ;; Also: Used for communication between `bbdb-update-records'
880 ;; and `bbdb-query-create'.
881 :group 'bbdb-mua
882 :type '(choice (const :tag "do nothing" nil)
883 (const :tag "search for existing records" search)
884 (const :tag "update existing records" update)
885 (const :tag "query annotation of all messages" query)
886 (const :tag "annotate all messages" create)
887 (function :tag "User-defined function")))
888
889(defcustom bbdb-message-headers
890 '((sender "From" "Resent-From" "Reply-To" "Sender")
891 (recipients "Resent-To" "Resent-CC" "To" "CC" "BCC"))
892 "Alist of headers to search for sender and recipients mail addresses.
893Each element is of the form
894
895 (CLASS HEADER ...)
896
897The symbol CLASS defines a class of headers.
898The strings HEADER belong to CLASS."
899 :group 'bbdb-mua
900 :type 'list)
901
902(defcustom bbdb-message-all-addresses nil
903 "If t `bbdb-update-records' returns all mail addresses of a message.
904Otherwise this function returns only the first mail address of each message."
905 :group 'bbdb-mua
906 :type 'boolean)
907
908(defcustom bbdb-message-try-all-headers nil
909 "If t try all message headers to extract an email address from a message.
910Several BBDB commands extract either the sender or the recipients' email
911addresses from a message according to `bbdb-message-headers'. If BBDB does not
912find any email address in this subset of message headers (for example, because
913an email address is excluded because of `bbdb-user-mail-address-re')
914but `bbdb-message-try-all-headers' is t, then these commands will also consider
915the email addresses in the remaining headers."
916 :group 'bbdb-mua
917 :type 'boolean)
918
919(defcustom bbdb-accept-message-alist t
920 "Alist describing which messages to automatically create BBDB records for.
921The format of this alist is
922 ((HEADER-NAME . REGEXP) ...)
923For example, if
924 ((\"From\" . \"@.*\\.maximegalon\\.edu\")
925 (\"Subject\" . \"time travel\"))
926BBDB records are only created for messages sent by people at Maximegalon U.,
927or people posting about time travel.
928If t accept all messages. If nil do not accept any messages.
929
930See also `bbdb-ignore-message-alist', which has the opposite effect."
931 :group 'bbdb-mua
932 :type '(repeat (cons
933 (string :tag "Header name")
934 (regexp :tag "Regexp to match on header value"))))
935
936(defcustom bbdb-ignore-message-alist nil
937 "Alist describing which messages not to automatically create BBDB records for.
938The format of this alist is
939 ((HEADER-NAME . REGEXP) ... )
940For example, if
941 ((\"From\" . \"mailer-daemon\")
942 ((\"To\" \"CC\") . \"mailing-list-1\\\\|mailing-list-2\"))
943no BBDB records are created for messages from any mailer daemon,
944or messages sent to or CCed to either of two mailing lists.
945If t ignore all messages. If nil do not ignore any messages.
946
947See also `bbdb-accept-message-alist', which has the opposite effect."
948 :group 'bbdb-mua
949 :type '(repeat (cons
950 (string :tag "Header name")
951 (regexp :tag "Regexp to match on header value"))))
952
953(defcustom bbdb-user-mail-address-re
954 (and (stringp user-mail-address)
955 (string-match "\\`\\([^@]*\\)\\(@\\|\\'\\)" user-mail-address)
956 (concat "\\<" (regexp-quote (match-string 1 user-mail-address)) "\\>"))
957 "A regular expression matching your mail addresses.
958Several BBDB commands extract either the sender or the recipients' email
959addresses from a message according to `bbdb-message-headers'. Yet an email
960address will be ignored if it matches `bbdb-user-mail-address-re'. This way
961the commands will not operate on your own record.
962See also `bbdb-message-try-all-headers'."
963 :group 'bbdb-mua
964 :type '(regexp :tag "Regexp matching your mail addresses"))
965
966(defcustom bbdb-add-name 'query
967 "How to handle new names for existing BBDB records.
968This handles messages where the real name differs from the name
969in a BBDB record with the same mail address, as in \"John Smith <jqs@frob.com>\"
970versus \"John Q. Smith <jqs@frob.com>\".
971Allowed values are:
972 t Automatically change the name to the new value.
973 query Query whether to use the new name.
974 nil Ignore the new name.
975 a number Number of seconds BBDB displays the name mismatch.
976 (without further action).
977 a function This is called with two args, the record and the new name.
978 It should return one of the above values.
979 a regexp If the new name matches this regexp ignore it.
980 Otherwise query to add it.
981See also `bbdb-add-aka'."
982 :group 'bbdb-mua
983 :type '(choice (const :tag "Automatically use the new name" t)
984 (const :tag "Query for name changes" query)
985 (const :tag "Ignore the new name" nil)
986 (integer :tag "Number of seconds to display name mismatch")
987 (function :tag "Function for analyzing name handling")
988 (regexp :tag "If the new name matches this regexp ignore it.")))
989
990(defcustom bbdb-add-aka 'query
991 "How to handle alternate names for existing BBDB records.
992Allowed values are:
993 t Automatically store alternate names as AKA.
994 query Query whether to store alternate names as an AKA.
995 nil Ignore alternate names.
996 a function This is called with two args, the record and the new name.
997 It should return one of the above values.
998 a regexp If the alternate name matches this regexp ignore it.
999 Otherwise query to add it.
1000See also `bbdb-add-name'."
1001 :group 'bbdb-mua
1002 :type '(choice (const :tag "Automatically store alternate names as AKA" t)
1003 (const :tag "Query for alternate names" query)
1004 (const :tag "Ignore alternate names" nil)
1005 (function :tag "Function for alternate name handling")
1006 (regexp :tag "If the alternate name matches this regexp ignore it.")))
1007
1008(defcustom bbdb-add-mails 'query
1009 "How to handle new mail addresses for existing BBDB records.
1010This handles messages where the mail address differs from the mail addresses
1011in a BBDB record with the same name as in \"John Q. Smith <jqs@foo.com>\"
1012versus \"John Q. Smith <jqs@bar.com>\".
1013Allowed values are:
1014 t Automatically add new mail addresses to the list of mail addresses.
1015 query Query whether to add it.
1016 nil Ignore new mail addresses.
1017 a number Number of seconds BBDB displays the new address
1018 (without further action).
1019 a function This is called with two args, the record and the new mail address.
1020 It should return one of the above values.
1021 a regexp If the new mail address matches this regexp ignore the new address.
1022 Otherwise query to add it.
1023See also `bbdb-new-mails-primary' and `bbdb-ignore-redundant-mails'."
1024 :group 'bbdb-mua
1025 :type '(choice (const :tag "Automatically add new mail addresses" t)
1026 (const :tag "Query before adding new mail addresses" query)
1027 (const :tag "Never add new mail addresses" nil)
1028 (number :tag "Number of seconds to display new addresses")
1029 (function :tag "Function for analyzing name handling")
1030 (regexp :tag "If the new address matches this regexp ignore it.")))
1031
1032(defcustom bbdb-new-mails-primary 'query
1033 "Where to put new mail addresses for existing BBDB records.
1034A new mail address may either become the new primary mail address,
1035when it is put at the beginning of the list of mail addresses.
1036Or the new mail address is added at the end of the list of mail addresses.
1037Allowed values are:
1038 t Make a new address automatically the primary address.
1039 query Query whether to make it the primary address.
1040 nil Add the new address to the end of the list.
1041 a function This is called with two args, the record and the new mail address.
1042 It should return one of the above values.
1043 a regexp If the new mail address matches this regexp put it at the end.
1044 Otherwise query to make it the primary address.
1045See also `bbdb-add-mails'."
1046 :group 'bbdb-mua
1047 :type '(choice (const :tag "New address automatically made primary" t)
1048 (const :tag "Query before making a new address primary" query)
1049 (const :tag "Do not make new address primary" nil)
1050 (function :tag "Function for analyzing primary handling")
1051 (regexp :tag "If the new mail address matches this regexp put it at the end.")))
1052
1053(defcustom bbdb-canonicalize-mail-function nil
1054 "If non-nil, it should be a function of one arg: a mail address string.
1055When BBDB \"notices\" a message, the corresponding mail addresses are passed
1056to this function first. It acts as a kind of \"filter\" to transform
1057the mail addresses before they are compared against or added to the database.
1058See `bbdb-canonicalize-mail-1' for a more complete example.
1059If this function returns nil, BBDB assumes that there is no mail address.
1060
1061See also `bbdb-ignore-redundant-mails'."
1062 :group 'bbdb-mua
1063 :type 'function)
1064
1065(defcustom bbdb-ignore-redundant-mails 'query
1066 "How to handle redundant mail addresses for existing BBDB records.
1067For example, \"foo@bar.baz.com\" is redundant w.r.t. \"foo@baz.com\".
1068This affects two things, whether a new redundant mail address is added
1069to BBDB and whether an old mail address, which has become redundant
1070because of a newly added mail address, is removed from BBDB.
1071
1072Allowed values are:
1073 t Automatically ignore redundant mail addresses.
1074 query Query whether to ignore them.
1075 nil Do not ignore redundant mail addresses.
1076 a number Number of seconds BBDB displays redundant mail addresses
1077 (without further action).
1078 a function This is called with two args, the record and the new mail address.
1079 It should return one of the above values.
1080 a regexp If the new mail address matches this regexp never ignore
1081 this mail address. Otherwise query to ignore it.
1082See also `bbdb-add-mails' and `bbdb-canonicalize-mail-function'."
1083 :group 'bbdb-mua
1084 :type '(choice (const :tag "Automatically ignore redundant mail addresses" t)
1085 (const :tag "Query whether to ignore them" query)
1086 (const :tag "Do not ignore redundant mail addresses" nil)
1087 (number :tag "Number of seconds to display redundant addresses")
1088 (function :tag "Function for handling redundant mail addresses")
1089 (regexp :tag "If the new address matches this regexp never ignore it.")))
1090(define-obsolete-variable-alias 'bbdb-canonicalize-redundant-mails
1091 'bbdb-ignore-redundant-mails "3.0")
1092
1093(defcustom bbdb-message-clean-name-function 'bbdb-message-clean-name-default
1094 "Function to clean up the name in the header of a message.
1095It takes one argument, the name as extracted by
1096`mail-extract-address-components'."
1097 :group 'bbdb-mua
1098 :type 'function)
1099
1100(defcustom bbdb-message-mail-as-name t
1101 "If non-nil use mail address of message as fallback for name of new records."
1102 :group 'bbdb-mua
1103 :type 'boolean)
1104
1105(defcustom bbdb-notice-mail-hook nil
1106 "Hook run each time a mail address of a record is \"noticed\" in a message.
1107This means that the mail address in a message belongs to an existing BBDB record
1108or to a record BBDB has created for the mail address.
1109
1110Run with one argument, the record. It is up to the hook function
1111to determine which MUA is used and to act appropriately.
1112Hook functions can use the variable `bbdb-update-records-address'
1113to determine the header and class of the mail address according
1114to `bbdb-message-headers'. See `bbdb-auto-notes' for how to annotate records
1115using `bbdb-update-records-address' and the headers of a mail message.
1116
1117If a message contains multiple mail addresses belonging to one BBDB record,
1118this hook is run for each mail address. Use `bbdb-notice-record-hook'
1119if you want to notice each record only once per message."
1120 :group 'bbdb-mua
1121 :type 'hook)
1122
1123(defcustom bbdb-notice-record-hook nil
1124 "Hook run each time a BBDB record is \"noticed\" in a message.
1125This means that one of the mail addresses in a message belongs to an existing
1126record or it is a record BBDB has created for the mail address. If a message
1127contains multiple mail addresses belonging to one BBDB record, this hook
1128is nonetheless run only once. Use `bbdb-notice-mail-hook' if you want to run
1129a hook function for each mail address in a message.
1130
1131Hook is run with one argument, the record."
1132 :group 'bbdb-mua
1133 :type 'hook)
1134
1135(define-widget 'bbdb-alist-with-header 'group
1136 "My group"
1137 :match 'bbdb-alist-with-header-match
1138 :value-to-internal (lambda (_widget value)
1139 (if value (list (car value) (cdr value))))
1140 :value-to-external (lambda (_widget value)
1141 (if value (append (list (car value)) (cadr value)))))
1142
1143(defun bbdb-alist-with-header-match (widget value)
1144 (widget-group-match widget
1145 (widget-apply widget :value-to-internal value)))
1146
1147(defvar bbdb-auto-notes-rules-expanded nil
1148 "Expanded `bbdb-auto-notes-rules'.") ; Internal variable
1149
1150(defcustom bbdb-auto-notes-rules nil
1151 "List of rules for adding notes to records of mail addresses of messages.
1152This automatically annotates the BBDB record of the sender or recipient
1153of a message based on the value of a header such as the Subject header.
1154This requires that `bbdb-notice-mail-hook' contains `bbdb-auto-notes'
1155and that the record already exists or `bbdb-update-records-p' returns such that
1156the record will be created. Messages matching `bbdb-auto-notes-ignore-messages'
1157are ignored.
1158
1159The elements of this list are
1160
1161 (MUA FROM-TO HEADER ANNOTATE ...)
1162 (FROM-TO HEADER ANNOTATE ...)
1163 (HEADER ANNOTATE ...)
1164
1165MUA is the active MUA or a list of MUAs (see `bbdb-mua').
1166If MUA is missing or t, use this rule for all MUAs.
1167
1168FROM-TO is a list of headers and/or header classes as in `bbdb-message-headers'.
1169The record corresponding to a mail address of a message is considered for
1170annotation if this mail address was found in a header matching FROM-TO.
1171If FROM-TO is missing or t, records for each mail address are considered
1172irrespective of where the mail address was found in a message.
1173
1174HEADER is a message header that is considered for generating the annotation.
1175
1176ANNOTATE may take the following values:
1177
1178 (REGEXP . STRING) [this is equivalent to (REGEXP notes STRING)]
1179 (REGEXP FIELD STRING)
1180 (REGEXP FIELD STRING REPLACE)
1181
1182REGEXP must match the value of HEADER for generating an annotation.
1183However, if the value of HEADER also matches an element of
1184`bbdb-auto-notes-ignore-headers' no annotation is generated.
1185
1186The annotation will be added to FIELD of the respective record.
1187FIELD defaults to `bbdb-default-xfield'.
1188
1189STRING defines a replacement for the match of REGEXP in the value of HEADER.
1190It may contain \\& or \\N specials used by `replace-match'.
1191The resulting string becomes the annotation.
1192If STRING is an integer N, the Nth matching subexpression is used.
1193If STRING is a function, it will be called with one arg, the value of HEADER.
1194The return value (which must be a string) is then used.
1195
1196If REPLACE is t, the resulting string replaces the old contents of FIELD.
1197If it is nil, the string is appended to the contents of FIELD (unless the
1198annotation is already part of the content of field).
1199
1200For example,
1201
1202 ((\"To\" (\"-vm@\" . \"VM mailing list\"))
1203 (\"Subject\" (\"sprocket\" . \"mail about sprockets\")
1204 (\"you bonehead\" . \"called me a bonehead\")))
1205
1206will cause the text \"VM mailing list\" to be added to the notes field
1207of the records corresponding to anyone you get mail from via one of the VM
1208mailing lists.
1209
1210If multiple clauses match the message, all of the corresponding strings
1211will be added.
1212
1213See also variables `bbdb-auto-notes-ignore-messages' and
1214`bbdb-auto-notes-ignore-headers'.
1215
1216For speed-up, the function `bbdb-auto-notes' actually use expanded rules
1217stored in the internal variable `bbdb-auto-notes-rules-expanded'.
1218If you change the value of `bbdb-auto-notes-rules' outside of customize,
1219set `bbdb-auto-notes-rules-expanded' to nil, so that the expanded rules
1220will be re-evaluated."
1221 :group 'bbdb-mua
1222 :set (lambda (symbol value)
1223 (set-default symbol value)
1224 (setq bbdb-auto-notes-rules-expanded nil))
1225 :type '(repeat
1226 (bbdb-alist-with-header
1227 (repeat (choice
1228 (const sender)
1229 (const recipients)))
1230 (string :tag "Header name")
1231 (repeat (choice
1232 (cons :tag "Value Pair"
1233 (regexp :tag "Regexp to match on header value")
1234 (string :tag "String for notes if regexp matches"))
1235 (list :tag "Replacement list"
1236 (regexp :tag "Regexp to match on header value")
1237 (choice :tag "Record field"
1238 (const notes :tag "xfields")
1239 (const organization :tag "Organization")
1240 (symbol :tag "Other"))
1241 (choice :tag "Regexp match"
1242 (string :tag "Replacement string")
1243 (integer :tag "Subexpression match")
1244 (function :tag "Callback Function"))
1245 (choice :tag "Replace previous contents"
1246 (const :tag "No" nil)
1247 (const :tag "Yes" t))))))))
1248
1249(defcustom bbdb-auto-notes-ignore-messages nil
1250 "List of rules for ignoring entire messages in `bbdb-auto-notes'.
1251The elements may have the following values:
1252 a function This function is called with one arg, the record
1253 that would be annotated.
1254 Ignore this message if the function returns non-nil.
1255 This function may use `bbdb-update-records-address'.
1256 MUA Ignore messages from MUA (see `bbdb-mua').
1257 (HEADER . REGEXP) Ignore messages where HEADER matches REGEXP.
1258 For example, (\"From\" . bbdb-user-mail-address-re)
1259 disables any recording of notes for mail addresses
1260 found in messages coming from yourself, see
1261 `bbdb-user-mail-address-re'.
1262 (MUA HEADER REGEXP) Ignore messages from MUA where HEADER
1263 matches REGEXP.
1264See also `bbdb-auto-notes-ignore-headers'."
1265 :group 'bbdb-mua
1266 :type '(repeat (cons
1267 (string :tag "Header name")
1268 (regexp :tag "Regexp to match on header value"))))
1269
1270(defcustom bbdb-auto-notes-ignore-headers nil
1271 "Alist of headers and regexps to ignore in `bbdb-auto-notes'.
1272Each element is of the form
1273
1274 (HEADER . REGEXP)
1275
1276For example,
1277
1278 (\"Organization\" . \"^Gatewayed from\\\\\|^Source only\")
1279
1280will exclude the phony `Organization:' headers in GNU mailing-lists
1281gatewayed to gnu.* newsgroups.
1282See also `bbdb-auto-notes-ignore-messages'."
1283 :group 'bbdb-mua
1284 :type '(repeat (cons
1285 (string :tag "Header name")
1286 (regexp :tag "Regexp to match on header value"))))
1287
1288(defcustom bbdb-mua-pop-up t
1289 "If non-nil, display an auto-updated BBDB window while using a MUA.
1290If 'horiz, stack the window horizontally if there is room.
1291If this is nil, BBDB is updated silently.
1292
1293See also `bbdb-mua-pop-up-window-size' and `bbdb-horiz-pop-up-window-size'."
1294 :group 'bbdb-mua
1295 :type '(choice (const :tag "MUA BBDB window stacked vertically" t)
1296 (const :tag "MUA BBDB window stacked horizontally" horiz)
1297 (const :tag "No MUA BBDB window" nil)))
1298(define-obsolete-variable-alias 'bbdb-message-pop-up 'bbdb-mua-pop-up "3.0")
1299
1300(defcustom bbdb-mua-pop-up-window-size bbdb-pop-up-window-size
1301 "Vertical size of MUA pop-up BBDB window (vertical split).
1302If it is an integer number, it is the number of lines used by BBDB.
1303If it is a fraction between 0.0 and 1.0 (inclusive), it is the fraction
1304of the tallest existing window that BBDB will take over.
1305If it is t use `pop-to-buffer' to create the BBDB window.
1306See also `bbdb-pop-up-window-size'."
1307 :group 'bbdb-mua
1308 :type '(choice (number :tag "BBDB window size")
1309 (const :tag "Use `pop-to-buffer'" t)))
1310
1311(defcustom bbdb-horiz-pop-up-window-size '(112 . 0.3)
1312 "Horizontal size of a MUA pop-up BBDB window (horizontal split).
1313It is a cons pair (TOTAL . BBDB-SIZE).
1314The window that will be considered for horizontal splitting must have
1315at least TOTAL columns. BBDB-SIZE is the horizontal size of the BBDB window.
1316If it is an integer number, it is the number of columns used by BBDB.
1317If it is a fraction between 0 and 1, it is the fraction of the
1318window width that BBDB will take over."
1319 :group 'bbdb-mua
1320 :type '(cons (number :tag "Total number of columns")
1321 (number :tag "Horizontal size of BBDB window")))
1322
1323\f
1324;;; xfields processing
1325(defcustom bbdb-xfields-sort-order
1326 '((notes . 0) (url . 1) (ftp . 2) (gopher . 3) (telnet . 4) (mail-alias . 5)
1327 (mail-folder . 6) (lpr . 7))
1328 "The order for sorting the xfields.
1329If an xfield is not in the alist, it is assigned weight 100, so all xfields
1330with weights less then 100 will be in the beginning, and all xfields with
1331weights more than 100 will be in the end."
1332 :group 'bbdb-mua
1333 :type '(repeat (cons
1334 (symbol :tag "xfield")
1335 (number :tag "Weight"))))
1336(define-obsolete-variable-alias 'bbdb-notes-sort-order 'bbdb-xfields-sort-order "3.0")
1337
1338(defcustom bbdb-merge-xfield-function-alist nil
1339 "Alist defining merging functions for particular xfields.
1340Each element is of the form (LABEL . MERGE-FUN).
1341For merging xfield LABEL, this will use MERGE-FUN."
1342 :group 'bbdb-mua
1343 :type '(repeat (cons
1344 (symbol :tag "xfield")
1345 (function :tag "merge function"))))
1346(define-obsolete-variable-alias 'bbdb-merge-notes-function-alist
1347 'bbdb-merge-xfield-function-alist "3.0")
1348
1349(defcustom bbdb-mua-summary-unification-list
1350 '(name mail message-name message-mail message-address)
1351 "List of FIELDs considered by `bbdb-mua-summary-unify'.
1352For the RECORD matching the address of a message, `bbdb-mua-summary-unify'
1353returns the first non-empty field value matching an element FIELD from this list.
1354Each element FIELD may be a valid argument of `bbdb-record-field' for RECORD.
1355In addition, this list may also include the following elements:
1356 message-name The name in the address of the message
1357 message-mail The mail in the address of the message
1358 message-address The complete address of the message
1359These provide a fallback if a message does not have a matching RECORD
1360or if some FIELD of RECORD is empty."
1361 :group 'bbdb-mua
1362 :type '(repeat (symbol :tag "Field")))
1363
1364(defcustom bbdb-mua-summary-mark-field 'mark-char
1365 "BBDB xfield whose value is used to mark message addresses known to BBDB.
1366This may also be a function, called with one arg, the record, which should
1367return the mark. See `bbdb-mua-summary-mark' and `bbdb-mua-summary-unify'.
1368See also `bbdb-mua-summary-mark'."
1369 :group 'bbdb-mua-gnus
1370 :type 'symbol)
1371
1372(defcustom bbdb-mua-summary-mark "+"
1373 "Default mark for message addresses known to BBDB.
1374If nil do not mark message addresses known to BBDB.
1375See `bbdb-mua-summary-mark' and `bbdb-mua-summary-unify'.
1376See also `bbdb-mua-summary-mark-field'."
1377 :group 'bbdb-mua
1378 :type '(choice (string :tag "Mark used")
1379 (const :tag "Do not mark known posters" nil)))
1380
1381(defcustom bbdb-mua-summary-unify-format-letter "B"
1382 "Letter required for `bbdb-mua-summary-unify' in the MUA Summary format string.
1383For Gnus, combine it with the %u specifier in `gnus-summary-line-format'
1384\(see there), for example use \"%U%R%z%I%(%[%4L: %-23,23uB%]%) %s\\n\".
1385For VM, combine it with the %U specifier in `vm-summary-format' (see there),
1386for example, use \"%n %*%a %-17.17UB %-3.3m %2d %4l/%-5c %I\\\"%s\\\"\\n\".
1387This customization of `gnus-summary-line-format' / `vm-summary-format'
1388is required to use `bbdb-mua-summary-unify'.
1389Currently no other MUAs support this BBDB feature."
1390 :group 'bbdb-mua
1391 :type 'string)
1392
1393(defcustom bbdb-mua-summary-mark-format-letter "b"
1394 "Letter required for `bbdb-mua-summary-mark' in the MUA Summary format string.
1395For Gnus, combine it with the %u specifier in `gnus-summary-line-format'
1396\(see there), for example, use \"%U%R%z%I%(%[%4L: %ub%-23,23f%]%) %s\\n\".
1397For VM, combine it with the %U specifier in `vm-summary-format' (see there),
1398for example, use \"%n %*%a %Ub%-17.17F %-3.3m %2d %4l/%-5c %I\\\"%s\\\"\\n\".
1399This customization of `gnus-summary-line-format' / `vm-summary-format'
1400is required to use `bbdb-mua-summary-mark'.
1401Currently no other MUAs support this BBDB feature."
1402 :group 'bbdb-mua
1403 :type 'string)
1404
1405\f
1406;;; Sending mail
1407(defcustom bbdb-mail-user-agent mail-user-agent
1408 "Mail user agent used by BBDB.
1409Allowed values are those allowed for `mail-user-agent'."
1410 :group 'bbdb-sendmail
1411 :type '(radio (function-item :tag "Message package"
1412 :format "%t\n"
1413 message-user-agent)
1414 (function-item :tag "Mail package"
1415 :format "%t\n"
1416 sendmail-user-agent)
1417 (function-item :tag "Emacs interface to MH"
1418 :format "%t\n"
1419 mh-e-user-agent)
1420 (function-item :tag "Message with full Gnus features"
1421 :format "%t\n"
1422 gnus-user-agent)
1423 (function-item :tag "VM"
1424 :format "%t\n"
1425 vm-user-agent)
1426 (function :tag "Other")
1427 (const :tag "Default" nil)))
1428
1429(defcustom bbdb-mail-name-format 'first-last
1430 "Format for names when sending mail.
1431If first-last format names as \"Firstname Lastname\".
1432If last-first format names as \"Lastname, Firstname\".
1433If `bbdb-mail-name' returns the full name as a single string, this takes
1434precedence over `bbdb-mail-name-format'. Likewise, if the mail address itself
1435includes a name, this is not reformatted."
1436 :group 'bbdb-sendmail
1437 :type '(choice (const :tag "Firstname Lastname" first-last)
1438 (const :tag "Lastname, Firstname" last-first)))
1439
1440(defcustom bbdb-mail-name 'mail-name
1441 "Xfield holding the full name for a record when sending mail.
1442This may also be a function taking one argument, a record.
1443If it returns the full mail name as a single string, this is used \"as is\".
1444If it returns a cons pair (FIRST . LAST) with the first and last name
1445for this record, these are formatted obeying `bbdb-mail-name-format'."
1446 :group 'bbdb-sendmail
1447 :type '(choice (symbol :tag "xfield")
1448 (function :tag "mail name function")))
1449
1450(defcustom bbdb-mail-alias-field 'mail-alias
1451 "Xfield holding the mail alias for a record.
1452Used by `bbdb-mail-aliases'. See also `bbdb-mail-alias'."
1453 :group 'bbdb-sendmail
1454 :type 'symbol)
1455
1456(defcustom bbdb-mail-alias 'first
1457 "Defines which mail aliases are generated for a BBDB record.
1458first: Generate one alias \"<alias>\" that expands to the first mail address
1459 of a record.
1460star: Generate a second alias \"<alias>*\" that expands to all mail addresses
1461 of a record.
1462all: Generate the aliases \"<alias>\" and \"<alias>*\" (as for 'star)
1463 and aliases \"<alias>n\" for each mail address, where n is the position
1464 of the mail address of a record."
1465 :group 'bbdb-sendmail
1466 :type '(choice (symbol :tag "Only first" first)
1467 (symbol :tag "<alias>* for all mails" star)
1468 (symbol :tag "All aliases" all)))
1469
1470(defcustom bbdb-mail-avoid-redundancy nil
1471 "Mail address to use for BBDB records when sending mail.
1472If non-nil do not use full name in mail address when same as mail.
1473If value is mail-only never use full name."
1474 :group 'bbdb-sendmail
1475 :type '(choice (const :tag "Allow redundancy" nil)
1476 (const :tag "Never use full name" mail-only)
1477 (const :tag "Avoid redundancy" t)))
1478
1479(defcustom bbdb-complete-mail t
1480 "If t MUA insinuation provides key binding for command `bbdb-complete-mail'."
1481 :group 'bbdb-sendmail
1482 :type 'boolean)
1483
1484(defcustom bbdb-completion-list t
1485 "Controls the behaviour of `bbdb-complete-mail'.
1486If a list of symbols, it specifies which fields to complete. Symbols include
1487 fl-name (= first and last name)
1488 lf-name (= last and first name)
1489 organization
1490 aka
1491 mail (= all email addresses of each record)
1492 primary (= first email address of each record)
1493If t, completion is done for all of the above.
1494If nil, no completion is offered."
1495 ;; These symbols match the fields for which BBDB provides entries in
1496 ;; `bbdb-hashtable'.
1497 :group 'bbdb-sendmail
1498 :type '(choice (const :tag "No Completion" nil)
1499 (const :tag "Complete across all fields" t)
1500 (repeat :tag "Field"
1501 (choice (const fl-name)
1502 (const lf-name)
1503 (const aka)
1504 (const organization)
1505 (const primary)
1506 (const mail)))))
1507
1508(defcustom bbdb-complete-mail-allow-cycling nil
1509 "If non-nil cycle mail addresses when calling `bbdb-complete-mail'."
1510 :group 'bbdb-sendmail
1511 :type 'boolean)
1512
1513(defcustom bbdb-complete-mail-hook nil
1514 "List of functions called after a sucessful completion."
1515 :group 'bbdb-sendmail
1516 :type 'hook)
1517
1518(defcustom bbdb-mail-abbrev-expand-hook nil
1519 ;; Replacement for function `mail-abbrev-expand-hook'.
1520 "Function (not hook) run each time an alias is expanded.
1521The function is called with two args the alias and the list
1522of corresponding mail addresses."
1523 :group 'bbdb-sendmail
1524 :type 'function)
1525
1526(defcustom bbdb-completion-display-record t
1527 "If non-nil `bbdb-complete-mail' displays the BBDB record after completion."
1528 :group 'bbdb-sendmail
1529 :type '(choice (const :tag "Update the BBDB buffer" t)
1530 (const :tag "Do not update the BBDB buffer" nil)))
1531
1532\f
1533;;;Dialing
1534(defcustom bbdb-dial-local-prefix-alist
1535 '(((if (integerp bbdb-default-area-code)
1536 (format "(%03d)" bbdb-default-area-code)
1537 (or bbdb-default-area-code ""))
1538 . ""))
1539 "Mapping to remove local prefixes from numbers.
1540If this is non-nil, it should be an alist of
1541\(PREFIX . REPLACEMENT) elements. The first part of a phone number
1542matching the regexp returned by evaluating PREFIX will be replaced by
1543the corresponding REPLACEMENT when dialing."
1544 :group 'bbdb-utilities-dialing
1545 :type 'sexp)
1546
1547(defcustom bbdb-dial-local-prefix nil
1548 "Local prefix digits.
1549If this is non-nil, it should be a string of digits which your phone
1550system requires before making local calls (for example, if your phone system
1551requires you to dial 9 before making outside calls.) In BBDB's
1552opinion, you're dialing a local number if it starts with a 0 after
1553processing `bbdb-dial-local-prefix-alist'."
1554 :group 'bbdb-utilities-dialing
1555 :type '(choice (const :tag "No digits required" nil)
1556 (string :tag "Dial this first" "9")))
1557
1558(defcustom bbdb-dial-long-distance-prefix nil
1559 "Long distance prefix digits.
1560If this is non-nil, it should be a string of digits which your phone
1561system requires before making a long distance call (one not in your local
1562area code). For example, in some areas you must dial 1 before an area
1563code. Note that this is used to replace the + sign in phone numbers
1564when dialling (international dialing prefix.)"
1565 :group 'bbdb-utilities-dialing
1566 :type '(choice (const :tag "No digits required" nil)
1567 (string :tag "Dial this first" "1")))
1568
1569(defcustom bbdb-dial-function nil
1570 "If non-nil this should be a function used for dialing phone numbers.
1571This function is used by `bbdb-dial-number'. It requires one
1572argument which is a string for the number that is dialed.
1573If nil then `bbdb-dial-number' uses the tel URI syntax passed to `browse-url'
1574to make the call."
1575 :group 'bbdb-utilities-dialing
1576 :type 'function)
1577
1578\f
1579;; Faces for font-lock
1580(defgroup bbdb-faces nil
1581 "Faces used by BBDB."
1582 :group 'bbdb
1583 :group 'faces)
1584
1585(defface bbdb-name
1586 '((t (:inherit font-lock-function-name-face)))
1587 "Face used for BBDB names."
1588 :group 'bbdb-faces)
1589
1590;; KEY needs to match the value of the xfield name-face, which is a string.
1591;; To avoid confusion, we make KEY a string, too, though symbols might be
1592;; faster.
1593(defcustom bbdb-name-face-alist nil
1594 "Alist used for font-locking the name of a record.
1595Each element should be a cons cell (KEY . FACE) with string KEY and face FACE.
1596To use FACE for font-locking the name of a record,
1597the xfield name-face of this record should have the value KEY.
1598The value of name-face may also be a face which is then used directly.
1599If none of these schemes succeeds, the face `bbdb-name' is used."
1600 :group 'bbdb-faces
1601 :type '(repeat (cons (symbol :tag "Key") (face :tag "Face"))))
1602
1603(defface bbdb-organization
1604 '((t (:inherit font-lock-comment-face)))
1605 "Face used for BBDB names."
1606 :group 'bbdb-faces)
1607
1608(defface bbdb-field-name
1609 '((t (:inherit font-lock-variable-name-face)))
1610 "Face used for BBDB names."
1611 :group 'bbdb-faces)
1612
1613;;; Internal variables
1614(eval-and-compile
1615 (defvar bbdb-debug t
1616 "Enable debugging if non-nil during compile time.
1617You really should not disable debugging. But it will speed things up."))
1618
1619(defconst bbdb-file-format 9
1620 "BBDB file format.")
1621
1622(defconst bbdb-record-type
1623 '(vector (or string (const nil)) ; first name
1624 (or string (const nil)) ; last name
1625 (repeat string) ; affix
1626 (repeat string) ; aka
1627 (repeat string) ; organization
1628 (repeat (or (vector string string)
1629 (vector string integer integer integer integer))) ; phone
1630 (repeat (vector string (repeat string) string string
1631 string string)) ; address
1632 (repeat string) ; mail
1633 (repeat (cons symbol sexp)) ; xfields
1634 (cons symbol string) ; uuid
1635 (cons symbol string) ; creation-date
1636 (cons symbol string) ; timestamp
1637 sexp) ; cache
1638 "Pseudo-code for the structure of a record. Used by `bbdb-check-type'.")
1639
1640(defconst bbdb-file-coding-system 'utf-8
1641 "Coding system used for reading and writing `bbdb-file'.")
1642
1643(defvar bbdb-mail-aliases-need-rebuilt nil
1644 "Non-nil if mail aliases need to be rebuilt.")
1645
1646(defvar bbdb-buffer nil "Buffer visiting `bbdb-file'.")
1647
1648(defvar bbdb-buffer-name "*BBDB*" "Name of the BBDB buffer.")
1649
1650(defvar bbdb-silent-internal nil
1651 "Bind this to t to quiet things down - do not set it.
1652See also `bbdb-silent'.")
1653
1654(defvar bbdb-init-forms
1655 '((gnus ; gnus 3.15 or newer
1656 (add-hook 'gnus-startup-hook 'bbdb-insinuate-gnus))
1657 (mh-e ; MH-E
1658 (add-hook 'mh-folder-mode-hook 'bbdb-insinuate-mh))
1659 (rmail ; RMAIL
1660 (add-hook 'rmail-mode-hook 'bbdb-insinuate-rmail))
1661 (vm ; newer versions of vm do not have `vm-load-hook'
1662 (eval-after-load "vm" '(bbdb-insinuate-vm)))
1663 (mail ; the standard mail user agent
1664 (add-hook 'mail-setup-hook 'bbdb-insinuate-mail))
1665 (sendmail
1666 (progn (message "BBDB: sendmail insinuation deprecated. Use mail.")
1667 (add-hook 'mail-setup-hook 'bbdb-insinuate-mail)))
1668 (message ; the gnus mail user agent
1669 (add-hook 'message-setup-hook 'bbdb-insinuate-message))
1670 (mu4e ; the mu4e user agent
1671 (add-hook 'mu4e-main-mode-hook 'bbdb-insinuate-mu4e))
1672
1673 (sc ; supercite
1674 (add-hook 'sc-load-hook 'bbdb-insinuate-sc))
1675 (anniv ; anniversaries
1676 (add-hook 'diary-list-entries-hook 'bbdb-anniv-diary-entries))
1677 (pgp ; pgp-mail
1678 (progn
1679 (add-hook 'message-send-hook 'bbdb-pgp)
1680 (add-hook 'mail-send-hook 'bbdb-pgp)))
1681 (wl
1682 (add-hook 'wl-init-hook 'bbdb-insinuate-wl)))
1683 "Alist mapping features to insinuation forms.")
1684
1685(defvar bbdb-search-invert nil
1686 "Bind this variable to t in order to invert the result of `bbdb-search'.")
1687
1688(defvar bbdb-do-all-records nil
1689 "Controls the behavior of the command `bbdb-do-all-records'.")
1690
1691(defvar bbdb-append-display nil
1692 "Controls the behavior of the command `bbdb-append-display'.")
1693
1694(defvar bbdb-offer-to-create nil
1695 "For communication between `bbdb-update-records' and `bbdb-query-create'.")
1696
1697(defvar bbdb-update-records-address nil
1698 "For communication between `bbdb-update-records' and `bbdb-query-create'.
1699It is a list with elements (NAME MAIL HEADER HEADER-CLASS MUA).")
1700
1701;;; Buffer-local variables for the database.
1702(defvar bbdb-records nil
1703 "BBDB records list.
1704In buffer `bbdb-file' this list includes all records.
1705In the *BBDB* buffers it includes the records that are actually displayed
1706and its elements are (RECORD DISPLAY-FORMAT MARKER-POS).")
1707(make-variable-buffer-local 'bbdb-records)
1708
1709(defvar bbdb-changed-records nil
1710 "List of records that has been changed since BBDB was last saved.
1711Use `bbdb-search-changed' to display these records.")
1712
1713(defvar bbdb-end-marker nil
1714 "Marker holding the buffer position of the end of the last record.")
1715
1716(defvar bbdb-hashtable (make-hash-table :test 'equal)
1717 "Hash table for BBDB records.
1718Hashes the fields first-last-name, last-first-name, organization, aka, and mail.")
1719
1720(defvar bbdb-uuid-table (make-hash-table :test 'equal)
1721 "Hash table for uuid's of BBDB records.")
1722
1723(defvar bbdb-xfield-label-list nil
1724 "List of labels for xfields.")
1725
1726(defvar bbdb-organization-list nil
1727 "List of organizations known to BBDB.")
1728
1729(defvar bbdb-street-list nil
1730 "List of streets known to BBDB.")
1731
1732(defvar bbdb-city-list nil
1733 "List of cities known to BBDB.")
1734
1735(defvar bbdb-state-list nil
1736 "List of states known to BBDB.")
1737
1738(defvar bbdb-postcode-list nil
1739 "List of post codes known to BBDB.")
1740
1741(defvar bbdb-country-list nil
1742 "List of countries known to BBDB.")
1743
1744(defvar bbdb-modeline-info (make-vector 6 nil)
1745 "Precalculated mode line info for BBDB commands.
1746This is a vector [APPEND-M APPEND INVERT-M INVERT ALL-M ALL].
1747APPEND-M is the mode line info if `bbdb-append-display' is non-nil.
1748INVERT-M is the mode line info if `bbdb-search-invert' is non-nil.
1749ALL-M is the mode line info if `bbdb-do-all-records' is non-nil.
1750APPEND, INVERT, and ALL appear in the message area.")
1751
1752(defvar bbdb-update-unchanged-records nil
1753 "If non-nil update unchanged records in the database.
1754Normally calls of `bbdb-change-hook' and updating of a record are suppressed,
1755if an editing command did not really change the record. Bind this to t
1756if you want to call `bbdb-change-hook' and update the record unconditionally.")
1757
1758;;; Keymap
1759(defvar bbdb-mode-map
1760 (let ((km (make-sparse-keymap)))
1761 (define-key km "*" 'bbdb-do-all-records)
1762 (define-key km "+" 'bbdb-append-display)
1763 (define-key km "!" 'bbdb-search-invert)
1764 (define-key km "a" 'bbdb-add-mail-alias)
1765 (define-key km "A" 'bbdb-mail-aliases)
1766 (define-key km "c" 'bbdb-create)
1767 (define-key km "e" 'bbdb-edit-field)
1768 (define-key km ";" 'bbdb-edit-foo)
1769 (define-key km "n" 'bbdb-next-record)
1770 (define-key km "p" 'bbdb-prev-record)
1771 (define-key km "N" 'bbdb-next-field)
1772 (define-key km "\t" 'bbdb-next-field) ; TAB
1773 (define-key km "P" 'bbdb-prev-field)
1774 (define-key km "\d" 'bbdb-prev-field) ; DEL
1775 (define-key km "d" 'bbdb-delete-field-or-record)
1776 (define-key km "\C-k" 'bbdb-delete-field-or-record)
1777 (define-key km "i" 'bbdb-insert-field)
1778 (define-key km "s" 'bbdb-save)
1779 (define-key km "\C-x\C-s" 'bbdb-save)
1780 (define-key km "t" 'bbdb-toggle-records-layout)
1781 (define-key km "T" 'bbdb-display-records-completely)
1782 (define-key km "o" 'bbdb-omit-record)
1783 (define-key km "m" 'bbdb-mail)
1784 (define-key km "M" 'bbdb-mail-address)
1785 (define-key km "\M-d" 'bbdb-dial)
1786 (define-key km "h" 'bbdb-info)
1787 (define-key km "?" 'bbdb-help)
1788 ;; (define-key km "q" 'quit-window) ; part of `special-mode' bindings
1789 (define-key km "\C-x\C-t" 'bbdb-transpose-fields)
1790 (define-key km "Cr" 'bbdb-copy-records-as-kill)
1791 (define-key km "Cf" 'bbdb-copy-fields-as-kill)
1792 (define-key km "u" 'bbdb-browse-url)
1793 (define-key km "\C-c\C-t" 'bbdb-tex)
1794 (define-key km "=" 'delete-other-windows)
1795
1796 ;; Search keys
1797 (define-key km "b" 'bbdb)
1798 (define-key km "/1" 'bbdb-display-records)
1799 (define-key km "/n" 'bbdb-search-name)
1800 (define-key km "/o" 'bbdb-search-organization)
1801 (define-key km "/p" 'bbdb-search-phone)
1802 (define-key km "/a" 'bbdb-search-address)
1803 (define-key km "/m" 'bbdb-search-mail)
1804 (define-key km "/N" 'bbdb-search-xfields)
1805 (define-key km "/x" 'bbdb-search-xfields)
1806 (define-key km "/c" 'bbdb-search-changed)
1807 (define-key km "/d" 'bbdb-search-duplicates)
1808 (define-key km "\C-xnw" 'bbdb-display-all-records)
1809 (define-key km "\C-xnd" 'bbdb-display-current-record)
1810
1811 (define-key km [delete] 'scroll-down) ; 24.1: part of `special-mode'
1812 (define-key km " " 'scroll-up) ; 24.1: part of `special-mode'
1813
1814 (define-key km [mouse-3] 'bbdb-mouse-menu)
1815 (define-key km [mouse-2] (lambda (event)
1816 ;; Toggle record layout
1817 (interactive "e")
1818 (save-excursion
1819 (posn-set-point (event-end event))
1820 (bbdb-toggle-records-layout
1821 (bbdb-do-records t) current-prefix-arg))))
1822 km)
1823 "Keymap for Insidious Big Brother Database.
1824This is a child of `special-mode-map'.")
1825
1826(easy-menu-define
1827 bbdb-menu bbdb-mode-map "BBDB Menu"
1828 '("BBDB"
1829 ("Display"
1830 ["Previous field" bbdb-prev-field t]
1831 ["Next field" bbdb-next-field t]
1832 ["Previous record" bbdb-prev-record t]
1833 ["Next record" bbdb-next-record t]
1834 "--"
1835 ["Show all records" bbdb-display-all-records t]
1836 ["Show current record" bbdb-display-current-record t]
1837 ["Omit record" bbdb-omit-record t]
1838 "--"
1839 ["Toggle layout" bbdb-toggle-records-layout t]
1840 ["Show all fields" bbdb-display-records-completely t])
1841 ("Searching"
1842 ["General search" bbdb t]
1843 ["Search one record" bbdb-display-records t]
1844 ["Search name" bbdb-search-name t]
1845 ["Search organization" bbdb-search-organization t]
1846 ["Search phone" bbdb-search-phone t]
1847 ["Search address" bbdb-search-address t]
1848 ["Search mail" bbdb-search-mail t]
1849 ["Search xfields" bbdb-search-xfields t]
1850 ["Search changed records" bbdb-search-changed t]
1851 ["Search duplicates" bbdb-search-duplicates t]
1852 "--"
1853 ["Old time stamps" bbdb-timestamp-older t]
1854 ["New time stamps" bbdb-timestamp-newer t]
1855 ["Old creation date" bbdb-creation-older t]
1856 ["New creation date" bbdb-creation-newer t]
1857 ["Creation date = time stamp" bbdb-creation-no-change t]
1858 "--"
1859 ["Append search" bbdb-append-display t]
1860 ["Invert search" bbdb-search-invert t])
1861 ("Mail"
1862 ["Send mail" bbdb-mail t]
1863 ["Save mail address" bbdb-mail-address t]
1864 "--"
1865 ["Add mail alias" bbdb-add-mail-alias t]
1866 ["(Re-)Build mail aliases" bbdb-mail-aliases t])
1867 ("Use database"
1868 ["Prefix: do all records" bbdb-do-all-records t]
1869 "--"
1870 ["Send mail" bbdb-mail t]
1871 ["Dial phone number" bbdb-dial t]
1872 ["Browse URL" bbdb-browse-url t]
1873 ["Copy records as kill" bbdb-copy-records-as-kill t]
1874 ["Copy fields as kill" bbdb-copy-fields-as-kill t]
1875 "--"
1876 ["TeX records" bbdb-tex t])
1877 ("Manipulate database"
1878 ["Prefix: do all records" bbdb-do-all-records t]
1879 "--"
1880 ["Create new record" bbdb-create t]
1881 ["Edit current field" bbdb-edit-field t]
1882 ["Insert new field" bbdb-insert-field t]
1883 ["Edit some field" bbdb-edit-foo t]
1884 ["Transpose fields" bbdb-transpose-fields t]
1885 ["Delete record or field" bbdb-delete-field-or-record t]
1886 "--"
1887 ["Sort addresses" bbdb-sort-addresses t]
1888 ["Sort phones" bbdb-sort-phones t]
1889 ["Sort xfields" bbdb-sort-xfields t]
1890 ["Merge records" bbdb-merge-records t]
1891 ["Sort database" bbdb-sort-records t]
1892 ["Delete duplicate mails" bbdb-delete-redundant-mails t]
1893 "--"
1894 ["Save BBDB" bbdb-save t]
1895 ["Revert BBDB" revert-buffer t])
1896 ("Help"
1897 ["Brief help" bbdb-help t]
1898 ["BBDB Manual" bbdb-info t])
1899 "--"
1900 ["Quit" quit-window t]))
1901
1902(defvar bbdb-completing-read-mails-map
1903 (let ((map (copy-keymap minibuffer-local-completion-map)))
1904 (define-key map " " 'self-insert-command)
1905 (define-key map "\t" 'bbdb-complete-mail)
1906 (define-key map "\M-\t" 'bbdb-complete-mail)
1907 map)
1908 "Keymap used by `bbdb-completing-read-mails'.")
1909
1910\f
1911
1912;;; Helper functions
1913
1914(defun bbdb-warn (&rest args)
1915 "Display a message at the bottom of the screen.
1916ARGS are passed to `message'."
1917 (ding t)
1918 (apply 'message args))
1919
1920(defun bbdb-string-trim (string &optional null)
1921 "Remove leading and trailing whitespace and all properties from STRING.
1922If STRING is nil return an empty string unless NULL is non-nil."
1923 (if (null string)
1924 (unless null "")
1925 (setq string (substring-no-properties string))
1926 (if (string-match "\\`[ \t\n]+" string)
1927 (setq string (substring-no-properties string (match-end 0))))
1928 (if (string-match "[ \t\n]+\\'" string)
1929 (setq string (substring-no-properties string 0 (match-beginning 0))))
1930 (unless (and null (string= "" string))
1931 string)))
1932
1933(defsubst bbdb-string= (str1 str2)
1934 "Return t if strings STR1 and STR2 are equal, ignoring case."
1935 (and (stringp str1) (stringp str2)
1936 (eq t (compare-strings str1 0 nil str2 0 nil t))))
1937
1938(defun bbdb-split (separator string)
1939 "Split STRING into list of substrings bounded by matches for SEPARATORS.
1940SEPARATOR may be a regexp. SEPARATOR may also be a symbol
1941\(a field name). Then look up the value in `bbdb-separator-alist'
1942or use `bbdb-default-separator'.
1943Whitespace around SEPARATOR is ignored unless SEPARATOR matches
1944the string \" \\t\\n\".
1945Almost the inverse function of `bbdb-concat'."
1946 (if (symbolp separator)
1947 (setq separator (car (or (cdr (assq separator bbdb-separator-alist))
1948 bbdb-default-separator))))
1949 (if (<= 24.4 (string-to-number emacs-version))
1950 ;; `split-string' applied to an empty STRING gives nil.
1951 (split-string string separator t
1952 (unless (string-match separator " \t\n") "[ \t\n]*"))
1953 (unless (string-match separator " \t\n")
1954 (setq separator (concat "[ \t\n]*" separator "[ \t\n]*")))
1955 (split-string (bbdb-string-trim string) separator t)))
1956
1957(defun bbdb-concat (separator &rest strings)
1958 "Concatenate STRINGS to a string sticking in SEPARATOR.
1959STRINGS may be strings or lists of strings. Empty strings are ignored.
1960SEPARATOR may be a string.
1961SEPARATOR may also be a symbol (a field name). Then look up the value
1962of SEPARATOR in `bbdb-separator-alist' or use `bbdb-default-separator'.
1963The inverse function of `bbdb-split'."
1964 (if (symbolp separator)
1965 (setq separator (nth 1 (or (cdr (assq separator bbdb-separator-alist))
1966 bbdb-default-separator))))
1967 (mapconcat 'identity
1968 (delete "" (apply 'append (mapcar (lambda (x) (if (stringp x)
1969 (list x) x))
1970 strings))) separator))
1971
1972(defun bbdb-list-strings (list)
1973 "Remove all elements from LIST which are not non-empty strings."
1974 (let (new-list)
1975 (dolist (elt list)
1976 (if (and (stringp elt) (not (string= "" elt)))
1977 (push elt new-list)))
1978 (nreverse new-list)))
1979
1980;; A call of `indent-region' swallows any indentation
1981;; that might be part of the field itself. So we indent manually.
1982(defsubst bbdb-indent-string (string column)
1983 "Indent nonempty lines in STRING to COLUMN (except first line).
1984This happens in addition to any pre-defined indentation of STRING."
1985 (replace-regexp-in-string "\n\\([^\n]\\)"
1986 (concat "\n" (make-string column ?\s) "\\1")
1987 string))
1988
1989(defun bbdb-read-string (prompt &optional init collection require-match)
1990 "Read a string, trimming whitespace and text properties.
1991PROMPT is a string to prompt with.
1992INIT appears as initial input which is useful for editing existing records.
1993COLLECTION and REQUIRE-MATCH have the same meaning as in `completing-read'."
1994 (bbdb-string-trim
1995 (if collection
1996 ;; Hack: In `minibuffer-local-completion-map' remove
1997 ;; the binding of SPC to `minibuffer-complete-word'
1998 ;; and of ? to `minibuffer-completion-help'.
1999 (minibuffer-with-setup-hook
2000 (lambda ()
2001 (use-local-map
2002 (let ((map (make-sparse-keymap)))
2003 (set-keymap-parent map (current-local-map))
2004 (define-key map " " nil)
2005 (define-key map "?" nil)
2006 map)))
2007 (completing-read prompt collection nil require-match init))
2008 (read-string prompt init))))
2009
2010;; The following macros implement variants of `pushnew' (till emacs 24.2)
2011;; or `cl-pushnew' (since emacs 24.3). To be compatible with older and newer
2012;; versions of emacs we use our own macros. We call these macros often.
2013;; So we keep them simple. Nothing fancy is needed here.
2014(defmacro bbdb-pushnew (element listname)
2015 "Add ELEMENT to the value of LISTNAME if it isn't there yet.
2016The test for presence of ELEMENT is done with `equal'.
2017The return value is the new value of LISTNAME."
2018 `(let ((elt ,element))
2019 (if (member elt ,listname)
2020 ,listname
2021 (setq ,listname (cons elt ,listname)))))
2022
2023(defmacro bbdb-pushnewq (element listname)
2024 "Add ELEMENT to the value of LISTNAME if it isn't there yet.
2025The test for presence of ELEMENT is done with `eq'.
2026The return value is the new value of LISTNAME."
2027 `(let ((elt ,element))
2028 (if (memq elt ,listname)
2029 ,listname
2030 (setq ,listname (cons elt ,listname)))))
2031
2032(defmacro bbdb-pushnewt (element listname)
2033 "Add ELEMENT to the value of LISTNAME if it isn't there yet and non-nil.
2034The test for presence of ELEMENT is done with `equal'.
2035The return value is the new value of LISTNAME."
2036 `(let ((elt ,element))
2037 (if (or (not elt)
2038 (member elt ,listname))
2039 ,listname
2040 (setq ,listname (cons elt ,listname)))))
2041
2042(defun bbdb-current-record (&optional full)
2043 "Return the record point is at.
2044If FULL is non-nil record includes the display information."
2045 (unless (eq major-mode 'bbdb-mode)
2046 (error "This only works while in BBDB buffers."))
2047 (let ((num (get-text-property (if (and (not (bobp)) (eobp))
2048 (1- (point)) (point))
2049 'bbdb-record-number))
2050 record)
2051 (unless num (error "Not a BBDB record"))
2052 (setq record (nth num bbdb-records))
2053 (if full record (car record))))
2054
2055(defun bbdb-current-field ()
2056 "Return current field point is on."
2057 (unless (bbdb-current-record) (error "Not a BBDB record"))
2058 (get-text-property (point) 'bbdb-field))
2059
2060(defmacro bbdb-debug (&rest body)
2061 "Excecute BODY just like `progn' with debugging capability.
2062Debugging is enabled if variable `bbdb-debug' is non-nil during compile.
2063You really should not disable debugging. But it will speed things up."
2064 (declare (indent 0))
2065 (if bbdb-debug ; compile-time switch
2066 `(let ((debug-on-error t))
2067 ,@body)))
2068
2069;; inspired by `gnus-bind-print-variables'
2070(defmacro bbdb-with-print-loadably (&rest body)
2071 "Bind print-* variables for BBDB and evaluate BODY.
2072This macro is used with `prin1', `prin1-to-string', etc. in order to ensure
2073printed Lisp objects are loadable by BBDB."
2074 (declare (indent 0))
2075 `(let ((print-escape-newlines t) ;; BBDB needs this!
2076 print-escape-nonascii print-escape-multibyte
2077 print-quoted print-length print-level)
2078 ;; print-circle print-gensym
2079 ;; print-continuous-numbering
2080 ;; print-number-table
2081 ;; float-output-format
2082 ,@body))
2083
2084(defun bbdb-timestamp (_record)
2085 ""
2086 (unless (get 'bbdb-timestamp 'bbdb-obsolete)
2087 (put 'bbdb-timestamp 'bbdb-obsolete t)
2088 (message "Function `bbdb-timestamp' is obsolete. Remove it from any hooks.")
2089 (sit-for 2)))
2090(make-obsolete 'bbdb-timestamp nil "2017-08-09")
2091
2092(defun bbdb-creation-date (_record)
2093 ""
2094 (unless (get 'bbdb-creation-date 'bbdb-obsolete)
2095 (put 'bbdb-creation-date 'bbdb-obsolete t)
2096 (message "Function `bbdb-creation-date' is obsolete. Remove it from any hooks.")
2097 (sit-for 2)))
2098(make-obsolete 'bbdb-creation-date nil "2017-08-09")
2099
2100;; Copied from org-id.el
2101(defun bbdb-uuid ()
2102 "Return string with random (version 4) UUID."
2103 (let ((rnd (md5 (format "%s%s%s%s%s%s%s"
2104 (random)
2105 (current-time)
2106 (user-uid)
2107 (emacs-pid)
2108 (user-full-name)
2109 user-mail-address
2110 (recent-keys)))))
2111 (format "%s-%s-4%s-%s%s-%s"
2112 (substring rnd 0 8)
2113 (substring rnd 8 12)
2114 (substring rnd 13 16)
2115 (format "%x"
2116 (logior
2117 #b10000000
2118 (logand
2119 #b10111111
2120 (string-to-number
2121 (substring rnd 16 18) 16))))
2122 (substring rnd 18 20)
2123 (substring rnd 20 32))))
2124
2125(defun bbdb-multiple-buffers-default ()
2126 "Default function for guessing a name for new *BBDB* buffers.
2127May be used as value of variable `bbdb-multiple-buffers'."
2128 (save-current-buffer
2129 (cond ((memq major-mode '(vm-mode vm-summary-mode vm-presentation-mode
2130 vm-virtual-mode))
2131 (vm-select-folder-buffer)
2132 (buffer-name))
2133 ((memq major-mode '(gnus-summary-mode gnus-group-mode))
2134 (set-buffer gnus-article-buffer)
2135 (buffer-name))
2136 ((memq major-mode '(mail-mode vm-mail-mode message-mode))
2137 "message composition"))))
2138
2139(defsubst bbdb-add-job (spec record string)
2140 "Internal function: Evaluate SPEC for RECORD and STRING.
2141If SPEC is a function call it with args RECORD and STRING. Return value.
2142If SPEC is a regexp, return 'query unless SPEC matches STRING.
2143Otherwise return SPEC.
2144Used with variable `bbdb-add-name' and friends."
2145 (cond ((functionp spec)
2146 (funcall spec record string))
2147 ((stringp spec)
2148 (unless (string-match spec string) 'query)) ; be least aggressive
2149 (spec)))
2150
2151(defsubst bbdb-eval-spec (spec prompt)
2152 "Internal function: Evaluate SPEC using PROMPT.
2153Return t if either SPEC equals t, or SPEC equals 'query and `bbdb-silent'
2154is non-nil or `y-or-no-p' returns t using PROMPT.
2155Used with return values of `bbdb-add-job'."
2156 (or (eq spec t)
2157 (and (eq spec 'query)
2158 (or bbdb-silent (y-or-n-p prompt)))))
2159
2160(defun bbdb-clean-address-components (components)
2161 "Clean mail address COMPONENTS.
2162COMPONENTS is a list (FULL-NAME CANONICAL-ADDRESS) as returned
2163by `mail-extract-address-components'.
2164Pass FULL-NAME through `bbdb-message-clean-name-function'
2165and CANONICAL-ADDRESS through `bbdb-canonicalize-mail-function'."
2166 (list (if (car components)
2167 (if bbdb-message-clean-name-function
2168 (funcall bbdb-message-clean-name-function (car components))
2169 (car components)))
2170 (if (cadr components)
2171 (if bbdb-canonicalize-mail-function
2172 (funcall bbdb-canonicalize-mail-function (cadr components))
2173 ;; Minimalistic clean-up
2174 (bbdb-string-trim (cadr components))))))
2175
2176(defun bbdb-extract-address-components (address &optional all)
2177 "Given an RFC-822 address ADDRESS, extract full name and canonical address.
2178This function behaves like `mail-extract-address-components', but it passes
2179its return value through `bbdb-clean-address-components'.
2180See also `bbdb-decompose-bbdb-address'."
2181 (if all
2182 (mapcar 'bbdb-clean-address-components
2183 (mail-extract-address-components address t))
2184 (bbdb-clean-address-components (mail-extract-address-components address))))
2185
2186;; Inspired by `gnus-extract-address-components' from gnus-utils.
2187(defun bbdb-decompose-bbdb-address (mail)
2188 "Given an RFC-822 address MAIL, extract full name and canonical address.
2189In general, this function behaves like the more sophisticated function
2190`mail-extract-address-components'. Yet for an address `<Joe_Smith@foo.com>'
2191lacking a real name the latter function returns the name \"Joe Smith\".
2192This is useful when analyzing the headers of email messages we receive
2193from the outside world. Yet when analyzing the mail addresses stored
2194in BBDB, this pollutes the mail-aka space. So we define here
2195an intentionally much simpler function for decomposing the names
2196and canonical addresses in the mail field of BBDB records."
2197 (let (name address)
2198 ;; First find the address - the thing with the @ in it.
2199 (cond (;; Check `<foo@bar>' first in order to handle the quite common
2200 ;; form `"abc@xyz" <foo@bar>' (i.e. `@' as part of a comment)
2201 ;; correctly.
2202 (string-match "<\\([^@ \t<>]+[!@][^@ \t<>]+\\)>" mail)
2203 (setq address (match-string 1 mail)))
2204 ((string-match "\\b[^@ \t<>]+[!@][^@ \t<>]+\\b" mail)
2205 (setq address (match-string 0 mail))))
2206 ;; Then check whether the `name <address>' format is used.
2207 (and address
2208 ;; Linear white space is not required.
2209 (string-match (concat "[ \t]*<" (regexp-quote address) ">") mail)
2210 (setq name (substring mail 0 (match-beginning 0)))
2211 ;; Strip any quotes mail the name.
2212 (string-match "^\".*\"$" name)
2213 (setq name (substring name 1 (1- (match-end 0)))))
2214 ;; If not, then check whether the `address (name)' format is used.
2215 (or name
2216 (and (string-match "(\\([^)]+\\))" mail)
2217 (setq name (match-string 1 mail))))
2218 (list (if (equal name "") nil name) (or address mail))))
2219
2220;;; Massage of mail addresses
2221
2222(defcustom bbdb-canonical-hosts
2223 ;; Example
2224 (regexp-opt '("cs.cmu.edu" "ri.cmu.edu"))
2225 "Regexp matching the canonical part of the domain part of a mail address.
2226If the domain part of a mail address matches this regexp, the domain
2227is replaced by the substring that actually matched this address.
2228
2229Used by `bbdb-canonicalize-mail-1'. See also `bbdb-ignore-redundant-mails'."
2230 :group 'bbdb-mua
2231 :type '(regexp :tag "Regexp matching sites"))
2232
2233(defun bbdb-canonicalize-mail-1 (address)
2234 "Example of `bbdb-canonicalize-mail-function'.
2235However, this function is too specific to be useful for the general user.
2236Take it as a source of inspiration for what can be done."
2237 (setq address (bbdb-string-trim address))
2238 (cond
2239 ;; Rewrite mail-drop hosts.
2240 ;; RW: The following is now also handled by `bbdb-ignore-redundant-mails'
2241 ((string-match
2242 (concat "\\`\\([^@%!]+@\\).*\\.\\(" bbdb-canonical-hosts "\\)\\'")
2243 address)
2244 (concat (match-string 1 address) (match-string 2 address)))
2245 ;;
2246 ;; Here at Lucid, our workstation names sometimes get into our mail
2247 ;; addresses in the form "jwz%thalidomide@lucid.com" (instead of simply
2248 ;; "jwz@lucid.com"). This removes the workstation name.
2249 ((string-match "\\`\\([^@%!]+\\)%[^@%!.]+@\\(lucid\\.com\\)\\'" address)
2250 (concat (match-string 1 address) "@" (match-string 2 address)))
2251 ;;
2252 ;; Another way that our local mailer is misconfigured: sometimes addresses
2253 ;; which should look like "user@some.outside.host" end up looking like
2254 ;; "user%some.outside.host" or even "user%some.outside.host@lucid.com"
2255 ;; instead. This rule rewrites it into the original form.
2256 ((string-match "\\`\\([^@%]+\\)%\\([^@%!]+\\)\\(@lucid\\.com\\)?\\'" address)
2257 (concat (match-string 1 address) "@" (match-string 2 address)))
2258 ;;
2259 ;; Sometimes I see addresses like "foobar.com!user@foobar.com".
2260 ;; That's totally redundant, so this rewrites it as "user@foobar.com".
2261 ((string-match "\\`\\([^@%!]+\\)!\\([^@%!]+[@%]\\1\\)\\'" address)
2262 (match-string 2 address))
2263 ;;
2264 ;; Sometimes I see addresses like "foobar.com!user". Turn it around.
2265 ((string-match "\\`\\([^@%!.]+\\.[^@%!]+\\)!\\([^@%]+\\)\\'" address)
2266 (concat (match-string 2 address) "@" (match-string 1 address)))
2267 ;;
2268 ;; The mailer at hplb.hpl.hp.com tends to puke all over addresses which
2269 ;; pass through mailing lists which are maintained there: it turns normal
2270 ;; addresses like "user@foo.com" into "user%foo.com@hplb.hpl.hp.com".
2271 ;; This reverses it. (I actually could have combined this rule with
2272 ;; the similar lucid.com rule above, but then the regexp would have been
2273 ;; more than 80 characters long...)
2274 ((string-match "\\`\\([^@!]+\\)%\\([^@%!]+\\)@hplb\\.hpl\\.hp\\.com\\'"
2275 address)
2276 (concat (match-string 1 address) "@" (match-string 2 address)))
2277 ;;
2278 ;; Another local mail-configuration botch: sometimes mail shows up
2279 ;; with addresses like "user@workstation", where "workstation" is a
2280 ;; local machine name. That should really be "user" or "user@netscape.com".
2281 ;; (I'm told this one is due to a bug in SunOS 4.1.1 sendmail.)
2282 ((string-match "\\`\\([^@%!]+\\)[@%][^@%!.]+\\'" address)
2283 (match-string 1 address))
2284 ;;
2285 ;; Sometimes I see addresses like "foo%somewhere%uunet.uu.net@somewhere.else".
2286 ;; This is silly, because I know that I can send mail to uunet directly.
2287 ((string-match ".%uunet\\.uu\\.net@[^@%!]+\\'" address)
2288 (concat (substring address 0 (+ (match-beginning 0) 1)) "@UUNET.UU.NET"))
2289 ;;
2290 ;; Otherwise, leave it as it is.
2291 (t address)))
2292
2293(defun bbdb-message-clean-name-default (name)
2294 "Default function for `bbdb-message-clean-name-function'.
2295This strips garbage from the user full NAME string."
2296 ;; Remove leading non-alpha chars
2297 (if (string-match "\\`[^[:alpha:]]+" name)
2298 (setq name (substring name (match-end 0))))
2299
2300 (if (string-match "^\\([^@]+\\)@" name)
2301 ;; The name is really a mail address and we use the part preceeding "@".
2302 ;; Everything following "@" is ignored.
2303 (setq name (match-string 1 name)))
2304
2305 ;; Replace "firstname.surname" by "firstname surname".
2306 ;; Do not replace ". " with " " because that could be an initial.
2307 (setq name (replace-regexp-in-string "\\.\\([^ ]\\)" " \\1" name))
2308
2309 ;; Replace tabs, spaces, and underscores with a single space.
2310 (setq name (replace-regexp-in-string "[ \t\n_]+" " " name))
2311
2312 ;; Remove trailing comments separated by "(" or " [-#]"
2313 ;; This does not work all the time because some of our friends in
2314 ;; northern europe have brackets in their names...
2315 (if (string-match "[^ \t]\\([ \t]*\\((\\| [-#]\\)\\)" name)
2316 (setq name (substring name 0 (match-beginning 1))))
2317
2318 ;; Remove phone extensions (like "x1234" and "ext. 1234")
2319 (let ((case-fold-search t))
2320 (setq name (replace-regexp-in-string
2321 "\\W+\\(x\\|ext\\.?\\)\\W*[-0-9]+" "" name)))
2322
2323 ;; Remove trailing non-alpha chars
2324 (if (string-match "[^[:alpha:]]+\\'" name)
2325 (setq name (substring name 0 (match-beginning 0))))
2326
2327 ;; Remove text properties
2328 (substring-no-properties name))
2329
2330;; BBDB data structure
2331(defmacro bbdb-defstruct (name &rest elts)
2332 "Define two functions to operate on vector NAME for each symbol ELT in ELTS.
2333The function bbdb-NAME-ELT returns the element ELT in vector NAME.
2334The function bbdb-NAME-set-ELT sets ELT.
2335Also define a constant bbdb-NAME-length that holds the number of ELTS
2336in vector NAME."
2337 (declare (indent 1))
2338 (let* ((count 0)
2339 (sname (symbol-name name))
2340 (uname (upcase sname))
2341 (cname (concat "bbdb-" sname "-"))
2342 body)
2343 (dolist (elt elts)
2344 (let* ((selt (symbol-name elt))
2345 (setname (intern (concat cname "set-" selt))))
2346 (push (list 'defsubst (intern (concat cname selt)) `(,name)
2347 (format "For BBDB %s read element %i `%s'."
2348 uname count selt)
2349 ;; Use `elt' instead of `aref' so that these functions
2350 ;; also work for the `bbdb-record-type' pseudo-code.
2351 `(elt ,name ,count)) body)
2352 (push (list 'defsubst setname `(,name value)
2353 (format "For BBDB %s set element %i `%s' to VALUE. \
2354Return VALUE.
2355Do not call this function directly. Call instead `bbdb-record-set-field'
2356which ensures the integrity of the database. Also, this makes your code
2357more robust with respect to possible future changes of BBDB's innermost
2358internals."
2359 uname count selt)
2360 `(aset ,name ,count value)) body))
2361 (setq count (1+ count)))
2362 (push (list 'defconst (intern (concat cname "length")) count
2363 (concat "Length of BBDB `" sname "'.")) body)
2364 (cons 'progn body)))
2365
2366;; Define RECORD:
2367(bbdb-defstruct record
2368 firstname lastname affix aka organization phone address mail xfields
2369 uuid creation-date timestamp cache)
2370
2371;; Define PHONE:
2372(bbdb-defstruct phone
2373 label area exchange suffix extension)
2374
2375;; Define ADDRESS:
2376(bbdb-defstruct address
2377 label streets city state postcode country)
2378
2379;; Define record CACHE:
2380;; - fl-name (first and last name of the person referred to by the record),
2381;; - lf-name (last and first name of the person referred to by the record),
2382;; - mail-aka (list of names associated with mail addresses)
2383;; - mail-canon (list of canonical mail addresses)
2384;; - sortkey (the concatenation of the elements used for sorting the record),
2385;; - marker (position of beginning of record in `bbdb-file')
2386(bbdb-defstruct cache
2387 fl-name lf-name mail-aka mail-canon sortkey marker)
2388
2389(defsubst bbdb-record-mail-aka (record)
2390 "Record cache function: Return mail-aka for RECORD."
2391 (bbdb-cache-mail-aka (bbdb-record-cache record)))
2392
2393(defsubst bbdb-record-mail-canon (record)
2394 "Record cache function: Return mail-canon for RECORD."
2395 (bbdb-cache-mail-canon (bbdb-record-cache record)))
2396
2397(defun bbdb-empty-record ()
2398 "Return a new empty record structure with a cache.
2399It is the caller's responsibility to make the new record known to BBDB."
2400 (let ((record (make-vector bbdb-record-length nil)))
2401 (bbdb-record-set-cache record (make-vector bbdb-cache-length nil))
2402 record))
2403
2404;; `bbdb-hashtable' associates with each KEY a list of matching records.
2405;; KEY includes fl-name, lf-name, organizations, AKAs and email addresses.
2406;; When loading the database the hash table is initialized by calling
2407;; `bbdb-hash-record' for each record. This function is also called
2408;; when new records are added to the database.
2409;; `bbdb-delete-record-internal' with arg REMHASH non-nil removes a record
2410;; from the hash table (besides deleting the record from the database).
2411;; When an existing record is modified, the code that modifies the record
2412;; needs to update the hash table, too. This includes removing the outdated
2413;; associations between KEYs and record as well as adding the new associations.
2414;; This is one reason to modify records by calling `bbdb-record-set-field'
2415;; which properly updates the hash table.
2416;; The hash table can be accessed via `bbdb-gethash'
2417;; and via functions like `completing-read'.
2418
2419(defun bbdb-puthash (key record)
2420 "Associate RECORD with KEY in `bbdb-hashtable'.
2421KEY must be a string or nil. Empty strings and nil are ignored."
2422 (if (and key (not (string= "" key))) ; do not hash empty strings
2423 (let* ((key (downcase key))
2424 (records (gethash key bbdb-hashtable)))
2425 (puthash key (if records (bbdb-pushnewq record records)
2426 (list record))
2427 bbdb-hashtable))))
2428
2429(defun bbdb-gethash (key &optional predicate)
2430 "Return list of records associated with KEY in `bbdb-hashtable'.
2431KEY must be a string or nil. Empty strings and nil are ignored.
2432PREDICATE may take the same values as `bbdb-completion-list'."
2433 (when (and key (not (string= "" key)))
2434 (let* ((key (downcase key))
2435 (all-records (gethash key bbdb-hashtable))
2436 records)
2437 (if (or (not predicate) (eq t predicate))
2438 all-records
2439 (dolist (record all-records)
2440 (if (catch 'bbdb-hash-ok
2441 (bbdb-hash-p key record predicate))
2442 (push record records)))
2443 records))))
2444
2445(defun bbdb-hash-p (key record predicate)
2446 "Throw `bbdb-hash-ok' non-nil if KEY matches RECORD acording to PREDICATE.
2447PREDICATE may take the same values as the elements of `bbdb-completion-list'."
2448 (if (and (memq 'fl-name predicate)
2449 (bbdb-string= key (or (bbdb-record-name record) "")))
2450 (throw 'bbdb-hash-ok 'fl-name))
2451 (if (and (memq 'lf-name predicate)
2452 (bbdb-string= key (or (bbdb-record-name-lf record) "")))
2453 (throw 'bbdb-hash-ok 'lf-name))
2454 (if (memq 'organization predicate)
2455 (mapc (lambda (organization) (if (bbdb-string= key organization)
2456 (throw 'bbdb-hash-ok 'organization)))
2457 (bbdb-record-organization record)))
2458 (if (memq 'aka predicate)
2459 (mapc (lambda (aka) (if (bbdb-string= key aka)
2460 (throw 'bbdb-hash-ok 'aka)))
2461 (bbdb-record-field record 'aka-all)))
2462 (if (and (memq 'primary predicate)
2463 (bbdb-string= key (car (bbdb-record-mail-canon record))))
2464 (throw 'bbdb-hash-ok 'primary))
2465 (if (memq 'mail predicate)
2466 (mapc (lambda (mail) (if (bbdb-string= key mail)
2467 (throw 'bbdb-hash-ok 'mail)))
2468 (bbdb-record-mail-canon record)))
2469 nil)
2470
2471(defun bbdb-remhash (key record)
2472 "Remove RECORD from list of records associated with KEY.
2473KEY must be a string or nil. Empty strings and nil are ignored."
2474 (if (and key (not (string= "" key)))
2475 (let* ((key (downcase key))
2476 (records (gethash key bbdb-hashtable)))
2477 (when records
2478 (setq records (delq record records))
2479 (if records
2480 (puthash key records bbdb-hashtable)
2481 (remhash key bbdb-hashtable))))))
2482
2483(defun bbdb-hash-record (record)
2484 "Insert RECORD in `bbdb-hashtable'.
2485This performs all initializations required for a new record.
2486Do not call this for existing records that require updating."
2487 (bbdb-puthash (bbdb-record-name record) record)
2488 (bbdb-puthash (bbdb-record-name-lf record) record)
2489 (dolist (organization (bbdb-record-organization record))
2490 (bbdb-puthash organization record))
2491 (dolist (aka (bbdb-record-aka record))
2492 (bbdb-puthash aka record))
2493 (bbdb-puthash-mail record)
2494 (puthash (bbdb-record-uuid record) record bbdb-uuid-table))
2495
2496(defun bbdb-puthash-mail (record)
2497 "For RECORD put mail into `bbdb-hashtable'."
2498 (let (mail-aka mail-canon address)
2499 (dolist (mail (bbdb-record-mail record))
2500 (setq address (bbdb-decompose-bbdb-address mail))
2501 (when (car address)
2502 (push (car address) mail-aka)
2503 (bbdb-puthash (car address) record))
2504 (push (nth 1 address) mail-canon)
2505 (bbdb-puthash (nth 1 address) record))
2506 (bbdb-cache-set-mail-aka (bbdb-record-cache record)
2507 (nreverse mail-aka))
2508 (bbdb-cache-set-mail-canon (bbdb-record-cache record)
2509 (nreverse mail-canon))))
2510
2511(defun bbdb-hash-update (record old new)
2512 "Update hash for RECORD. Remove OLD, insert NEW.
2513Both OLD and NEW are lists of values."
2514 (dolist (elt old)
2515 (bbdb-remhash elt record))
2516 (dolist (elt new)
2517 (bbdb-puthash elt record)))
2518
2519(defun bbdb-check-name (first last &optional record)
2520 "Check whether the name FIRST LAST is a valid name.
2521This throws an error if the name is already used by another record
2522and `bbdb-allow-duplicates' is nil. If RECORD is non-nil, FIRST and LAST
2523may correspond to RECORD without raising an error."
2524 ;; Are there more useful checks for names beyond checking for duplicates?
2525 (unless bbdb-allow-duplicates
2526 (let* ((name (bbdb-concat 'name-first-last first last))
2527 (records (bbdb-gethash name '(fl-name lf-name aka))))
2528 (if (or (and (not record) records)
2529 (remq record records))
2530 (error "%s is already in BBDB" name)))))
2531
2532(defun bbdb-record-name (record)
2533 "Record cache function: Return the full name FIRST_LAST of RECORD.
2534Return empty string if both the first and last name are nil.
2535If the name is not available in the name cache, the name cache value
2536is generated and stored."
2537 (or (bbdb-cache-fl-name (bbdb-record-cache record))
2538 ;; Build the name cache for a record.
2539 (bbdb-record-set-name record t t)))
2540
2541(defun bbdb-record-name-lf (record)
2542 "Record cache function: Return the full name LAST_FIRST of RECORD.
2543If the name is not available in the name cache, the name cache value
2544is generated and stored."
2545 (or (bbdb-cache-lf-name (bbdb-record-cache record))
2546 ;; Build the name cache for a record.
2547 (progn (bbdb-record-set-name record t t)
2548 (bbdb-cache-lf-name (bbdb-record-cache record)))))
2549
2550(defun bbdb-record-set-name (record first last)
2551 "Record cache function: For RECORD set full name based on FIRST and LAST.
2552If FIRST or LAST are t use respective existing entries of RECORD.
2553Set full name in cache and hash. Return first-last name."
2554 (let* ((cache (bbdb-record-cache record))
2555 (fl-name (bbdb-cache-fl-name cache))
2556 (lf-name (bbdb-cache-lf-name cache)))
2557 (if fl-name (bbdb-remhash fl-name record))
2558 (if lf-name (bbdb-remhash lf-name record)))
2559 (if (eq t first)
2560 (setq first (bbdb-record-firstname record))
2561 (bbdb-record-set-firstname record first))
2562 (if (eq t last)
2563 (setq last (bbdb-record-lastname record))
2564 (bbdb-record-set-lastname record last))
2565 (let ((fl-name (bbdb-concat 'name-first-last first last))
2566 (lf-name (bbdb-concat 'name-last-first last first))
2567 (cache (bbdb-record-cache record)))
2568 ;; Set cache of RECORD
2569 (bbdb-cache-set-fl-name cache fl-name)
2570 (bbdb-cache-set-lf-name cache lf-name)
2571 ;; Set hash. For convenience, the hash contains the full name
2572 ;; as first-last and last-fist.
2573 (bbdb-puthash fl-name record)
2574 (bbdb-puthash lf-name record)
2575 fl-name))
2576
2577(defun bbdb-record-sortkey (record)
2578 "Record cache function: Return the sortkey for RECORD.
2579Set and store it if necessary."
2580 (or (bbdb-cache-sortkey (bbdb-record-cache record))
2581 (bbdb-record-set-sortkey record)))
2582
2583(defun bbdb-record-set-sortkey (record)
2584 "Record cache function: Set and return RECORD's sortkey."
2585 (bbdb-cache-set-sortkey
2586 (bbdb-record-cache record)
2587 (downcase
2588 (bbdb-concat "" (bbdb-record-lastname record)
2589 (bbdb-record-firstname record)
2590 (bbdb-record-organization record)))))
2591
2592(defsubst bbdb-record-marker (record)
2593 "Record cache function: Return the marker for RECORD."
2594 (bbdb-cache-marker (bbdb-record-cache record)))
2595
2596(defsubst bbdb-record-set-marker (record marker)
2597 "Record cache function: Set and return RECORD's MARKER."
2598 (bbdb-cache-set-marker (bbdb-record-cache record) marker))
2599
2600(defsubst bbdb-record-xfield (record label)
2601 "For RECORD return value of xfield LABEL.
2602Return nil if xfield LABEL is undefined."
2603 (cdr (assq label (bbdb-record-xfields record))))
2604
2605;; The values of xfields are normally strings. The following function
2606;; comes handy if we want to treat these values as symbols.
2607(defun bbdb-record-xfield-intern (record label)
2608 "For RECORD return interned value of xfield LABEL.
2609Return nil if xfield LABEL does not exist."
2610 (let ((value (bbdb-record-xfield record label)))
2611 ;; If VALUE is not a string, return whatever it is.
2612 (if (stringp value) (intern value) value)))
2613
2614(defun bbdb-record-xfield-string (record label)
2615 "For RECORD return value of xfield LABEL as string.
2616Return nil if xfield LABEL does not exist."
2617 (let ((value (bbdb-record-xfield record label)))
2618 (if (string-or-null-p value)
2619 value
2620 (let ((print-escape-newlines t))
2621 (prin1-to-string value)))))
2622
2623(defsubst bbdb-record-xfield-split (record label)
2624 "For RECORD return value of xfield LABEL split as a list.
2625Splitting is based on `bbdb-separator-alist'."
2626 (let ((val (bbdb-record-xfield record label)))
2627 (cond ((stringp val) (bbdb-split label val))
2628 (val (error "Cannot split `%s'" val)))))
2629
2630(defun bbdb-record-set-xfield (record label value)
2631 "For RECORD set xfield LABEL to VALUE.
2632If VALUE is nil or an empty string, remove xfield LABEL from RECORD.
2633Return VALUE."
2634 ;; In principle we can also have xfield labels `name' or `mail', etc.
2635 ;; Yet the actual code would get rather confused. So we throw an error.
2636 (if (memq label '(name firstname lastname affix organization
2637 mail aka phone address xfields))
2638 (error "xfield label `%s' illegal" label))
2639 (if (eq label 'mail-alias)
2640 (setq bbdb-mail-aliases-need-rebuilt 'edit))
2641 (if (stringp value) (setq value (bbdb-string-trim value t)))
2642 (let ((old-xfield (assq label (bbdb-record-xfields record))))
2643 ;; Do nothing if both OLD-XFIELD and VALUE are nil.
2644 (cond ((and old-xfield value) ; update
2645 (setcdr old-xfield value))
2646 (value ; new xfield
2647 (bbdb-pushnewq label bbdb-xfield-label-list)
2648 (bbdb-record-set-xfields record
2649 (append (bbdb-record-xfields record)
2650 (list (cons label value)))))
2651 (old-xfield ; remove
2652 (bbdb-record-set-xfields record
2653 (delq old-xfield
2654 (bbdb-record-xfields record))))))
2655 value)
2656
2657(defun bbdb-check-type (object type &optional abort extended)
2658 "Return non-nil if OBJECT is of type TYPE.
2659TYPE is a pseudo-code as in `bbdb-record-type'.
2660If ABORT is non-nil, abort with error message if type checking fails.
2661If EXTENDED is non-nil, consider extended atomic types which may include
2662symbols, numbers, markers, and strings."
2663 (let (tmp)
2664 ;; Add more predicates? Compare info node `(elisp.info)Type Predicates'.
2665 (or (cond ((eq type 'symbol) (symbolp object))
2666 ((eq type 'integer) (integerp object))
2667 ((eq type 'marker) (markerp object))
2668 ((eq type 'number) (numberp object))
2669 ((eq type 'string) (stringp object))
2670 ((eq type 'sexp) t) ; matches always
2671 ((eq type 'face) (facep object))
2672 ;; not quite a type
2673 ((eq type 'bound) (and (symbolp object) (boundp object)))
2674 ((eq type 'function) (functionp object))
2675 ((eq type 'vector) (vectorp object))
2676 ((and extended
2677 (cond ((symbolp type) (setq tmp (eq type object)) t)
2678 ((or (numberp type) (markerp type))
2679 (setq tmp (= type object)) t)
2680 ((stringp type)
2681 (setq tmp (and (stringp object)
2682 (string= type object))) t)))
2683 tmp)
2684 ((not (consp type))
2685 (error "Atomic type `%s' undefined" type))
2686 ((eq 'const (setq tmp (car type)))
2687 (equal (nth 1 type) object))
2688 ((eq tmp 'cons)
2689 (and (consp object)
2690 (bbdb-check-type (car object) (nth 1 type) abort extended)
2691 (bbdb-check-type (cdr object) (nth 2 type) abort extended)))
2692 ((eq tmp 'list)
2693 (and (listp object)
2694 (eq (length (cdr type)) (length object))
2695 (let ((type (cdr type)) (object object) (ok t))
2696 (while type
2697 (unless (bbdb-check-type (pop object) (pop type)
2698 abort extended)
2699 (setq ok nil type nil)))
2700 ok)))
2701 ((eq tmp 'repeat)
2702 (and (listp object)
2703 (let ((tp (nth 1 type)) (object object) (ok t))
2704 (while object
2705 (unless (bbdb-check-type (pop object) tp abort extended)
2706 (setq ok nil object nil)))
2707 ok)))
2708 ((eq tmp 'vector)
2709 (and (vectorp object)
2710 (let* ((i 0) (type (cdr type))
2711 (ok (eq (length object) (length type))))
2712 (when ok
2713 (while type
2714 (if (bbdb-check-type (aref object i) (pop type)
2715 abort extended)
2716 (setq i (1+ i))
2717 (setq ok nil type nil)))
2718 ok))))
2719 ((eq tmp 'or) ; like customize `choice' type
2720 (let ((type (cdr type)) ok)
2721 (while type
2722 (if (bbdb-check-type object (pop type) nil extended)
2723 (setq ok t type nil)))
2724 ok))
2725 ;; User-defined predicate
2726 ((eq tmp 'user-p) (funcall (nth 1 type) object))
2727 (t (error "Compound type `%s' undefined" tmp)))
2728 (and abort
2729 (error "Type mismatch: expect %s, got `%s'" type object)))))
2730
2731;; (bbdb-check-type 'bar 'symbol)
2732;; (bbdb-check-type 'bar 'bar)
2733;; (bbdb-check-type "foo" 'symbol t)
2734;; (bbdb-check-type "foo" '(or symbol string))
2735;; (bbdb-check-type nil '(const nil))
2736;; (bbdb-check-type '(bar . "foo") '(cons symbol string))
2737;; (bbdb-check-type '(bar "foo") '(list symbol string))
2738;; (bbdb-check-type '("bar" "foo") '(repeat string))
2739;; (bbdb-check-type (vector 'bar "foo") '(vector symbol string))
2740;; (bbdb-check-type (vector 'bar "foo") 'vector)
2741;; (bbdb-check-type '(bar (bar . "foo")) '(list symbol (cons symbol string)))
2742;; (bbdb-check-type '("aa" . "bb") '(or (const nil) (cons string string)) t)
2743;; (bbdb-check-type nil '(or nil (cons string string)) t t)
2744;; (bbdb-check-type "foo" '(user-p (lambda (a) (stringp a))))
2745;; (bbdb-check-type 'set 'function)
2746
2747(defun bbdb-record-field (record field)
2748 "For RECORD return the value of FIELD.
2749
2750FIELD may take the following values
2751 firstname Return the first name of RECORD
2752 lastname Return the last name of RECORD
2753 name Return the full name of RECORD (first name first)
2754 name-lf Return the full name of RECORD (last name first)
2755 affix Return the list of affixes
2756 organization Return the list of organizations
2757 aka Return the list of AKAs
2758 aka-all Return the list of AKAs plus mail-akas.
2759 mail Return the list of email addresses
2760 mail-aka Return the list of name parts in mail addresses
2761 mail-canon Return the list of canonical mail addresses.
2762 phone Return the list of phone numbers
2763 address Return the list of addresses
2764 uuid Return the uuid of RECORD
2765 creation-date Return the creation-date
2766 timestamp Return the timestamp
2767 xfields Return the list of all xfields
2768
2769Any other symbol is interpreted as the label for an xfield.
2770Then return the value of this xfield.
2771
2772See also `bbdb-record-set-field'."
2773 (cond ((eq field 'firstname) (bbdb-record-firstname record))
2774 ((eq field 'lastname) (bbdb-record-lastname record))
2775 ((eq field 'name) (bbdb-record-name record))
2776 ((eq field 'name-lf) (bbdb-record-name-lf record))
2777 ((eq field 'affix) (bbdb-record-affix record))
2778 ((eq field 'organization) (bbdb-record-organization record))
2779 ((eq field 'mail) (bbdb-record-mail record))
2780 ((eq field 'mail-canon) (bbdb-record-mail-canon record)) ; derived (cached) field
2781 ((eq field 'mail-aka) (bbdb-record-mail-aka record)) ; derived (cached) field
2782 ((eq field 'aka) (bbdb-record-aka record))
2783 ((eq field 'aka-all) (append (bbdb-record-aka record) ; derived field
2784 (bbdb-record-mail-aka record)))
2785 ((eq field 'phone) (bbdb-record-phone record))
2786 ((eq field 'address) (bbdb-record-address record))
2787 ((eq field 'uuid) (bbdb-record-uuid record))
2788 ((eq field 'creation-date) (bbdb-record-creation-date record))
2789 ((eq field 'timestamp) (bbdb-record-timestamp record))
2790 ;; Return all xfields
2791 ((eq field 'xfields) (bbdb-record-xfields record))
2792 ;; Return xfield FIELD (e.g., `notes') or nil if FIELD is not defined.
2793 ((symbolp field) (bbdb-record-xfield record field))
2794 (t (error "Unknown field type `%s'" field))))
2795(define-obsolete-function-alias 'bbdb-record-get-field 'bbdb-record-field "3.0")
2796
2797(defun bbdb-record-set-field (record field value &optional merge check)
2798 "For RECORD set FIELD to VALUE. Return VALUE.
2799If MERGE is non-nil, merge VALUE with the current value of FIELD.
2800If CHECK is non-nil, check syntactically whether FIELD may take VALUE.
2801This function also updates the hash table. However, it does not update
2802RECORD in the database. Use `bbdb-change-record' for that.
2803
2804FIELD may take the following values
2805 firstname VALUE is the first name of RECORD
2806 lastname VALUE is the last name of RECORD
2807 name VALUE is the full name of RECORD either as one string
2808 or as a cons pair (FIRST . LAST)
2809 affix VALUE is the list of affixes
2810 organization VALUE is the list of organizations
2811 aka VALUE is the list of AKAs
2812 mail VALUE is the list of email addresses
2813 phone VALUE is the list of phone numbers
2814 address VALUE is the list of addresses
2815 uuid VALUE is the uuid of RECORD
2816 creation-date VALUE is the creation-date
2817 timestamp VALUE is the timestamp
2818 xfields VALUE is the list of all xfields
2819
2820Any other symbol is interpreted as the label for an xfield.
2821Then VALUE is the value of this xfield.
2822
2823See also `bbdb-record-field'."
2824 (bbdb-editable)
2825 (if (memq field '(name-lf mail-aka mail-canon aka-all))
2826 (error "`%s' is not allowed as the name of a field" field))
2827 (let ((record-type (cdr bbdb-record-type)))
2828 (cond ((eq field 'firstname) ; First name
2829 (if merge (error "Does not merge names"))
2830 (if check (bbdb-check-type value (bbdb-record-firstname record-type) t))
2831 (bbdb-check-name value (bbdb-record-lastname record) record)
2832 (bbdb-record-set-name record value t))
2833
2834 ;; Last name
2835 ((eq field 'lastname)
2836 (if merge (error "Does not merge names"))
2837 (if check (bbdb-check-type value (bbdb-record-lastname record-type) t))
2838 (bbdb-check-name (bbdb-record-firstname record) value record)
2839 (bbdb-record-set-name record t value))
2840
2841 ;; Name
2842 ((eq field 'name)
2843 (if merge (error "Does not merge names"))
2844 (if (stringp value)
2845 (setq value (bbdb-divide-name value))
2846 (if check (bbdb-check-type value '(cons string string) t)))
2847 (let ((fn (car value)) (ln (cdr value)))
2848 (bbdb-check-name fn ln record)
2849 (bbdb-record-set-name record fn ln)))
2850
2851 ;; Affix
2852 ((eq field 'affix)
2853 (if merge (setq value (bbdb-merge-lists (bbdb-record-affix record)
2854 value 'bbdb-string=)))
2855 (if check (bbdb-check-type value (bbdb-record-affix record-type) t))
2856 (setq value (bbdb-list-strings value))
2857 (bbdb-record-set-affix record value))
2858
2859 ;; Organization
2860 ((eq field 'organization)
2861 (if merge (setq value (bbdb-merge-lists (bbdb-record-organization record)
2862 value 'bbdb-string=)))
2863 (if check (bbdb-check-type value (bbdb-record-organization record-type) t))
2864 (setq value (bbdb-list-strings value))
2865 (bbdb-hash-update record (bbdb-record-organization record) value)
2866 (dolist (organization value)
2867 (bbdb-pushnew organization bbdb-organization-list))
2868 (bbdb-record-set-organization record value))
2869
2870 ;; AKA
2871 ((eq field 'aka)
2872 (if merge (setq value (bbdb-merge-lists (bbdb-record-aka record)
2873 value 'bbdb-string=)))
2874 (if check (bbdb-check-type value (bbdb-record-aka record-type) t))
2875 (setq value (bbdb-list-strings value))
2876 (unless bbdb-allow-duplicates
2877 (dolist (aka value)
2878 (let ((old (remq record (bbdb-gethash aka '(fl-name lf-name aka)))))
2879 (if old (error "Alternate name address \"%s\" is used by \"%s\""
2880 aka (mapconcat 'bbdb-record-name old ", "))))))
2881 (bbdb-hash-update record (bbdb-record-aka record) value)
2882 (bbdb-record-set-aka record value))
2883
2884 ;; Mail
2885 ((eq field 'mail)
2886 (if merge (setq value (bbdb-merge-lists (bbdb-record-mail record)
2887 value 'bbdb-string=)))
2888 (if check (bbdb-check-type value (bbdb-record-mail record-type) t))
2889 (setq value (bbdb-list-strings value))
2890 (unless bbdb-allow-duplicates
2891 (dolist (mail value)
2892 (let ((old (remq record (bbdb-gethash mail '(mail)))))
2893 (if old (error "Mail address \"%s\" is used by \"%s\""
2894 mail (mapconcat 'bbdb-record-name old ", "))))))
2895 (dolist (aka (bbdb-record-mail-aka record))
2896 (bbdb-remhash aka record))
2897 (dolist (mail (bbdb-record-mail-canon record))
2898 (bbdb-remhash mail record))
2899 (bbdb-record-set-mail record value)
2900 (bbdb-puthash-mail record))
2901
2902 ;; Phone
2903 ((eq field 'phone)
2904 (if merge (setq value (bbdb-merge-lists (bbdb-record-phone record)
2905 value 'equal)))
2906 (if check (bbdb-check-type value (bbdb-record-phone record-type) t))
2907 (dolist (phone value)
2908 (bbdb-pushnew (bbdb-phone-label phone) bbdb-phone-label-list))
2909 (bbdb-record-set-phone record value))
2910
2911 ;; Address
2912 ((eq field 'address)
2913 (if merge (setq value (bbdb-merge-lists (bbdb-record-address record)
2914 value 'equal)))
2915 (if check (bbdb-check-type value (bbdb-record-address record-type) t))
2916 (dolist (address value)
2917 (bbdb-pushnew (bbdb-address-label address) bbdb-address-label-list)
2918 (mapc (lambda (street) (bbdb-pushnewt street bbdb-street-list))
2919 (bbdb-address-streets address))
2920 (bbdb-pushnewt (bbdb-address-city address) bbdb-city-list)
2921 (bbdb-pushnewt (bbdb-address-state address) bbdb-state-list)
2922 (bbdb-pushnewt (bbdb-address-postcode address) bbdb-postcode-list)
2923 (bbdb-pushnewt (bbdb-address-country address) bbdb-country-list))
2924 (bbdb-record-set-address record value))
2925
2926 ;; uuid
2927 ((eq field 'uuid)
2928 ;; MERGE not meaningful
2929 (if check (bbdb-check-type value (bbdb-record-uuid record-type) t))
2930 (let ((old-uuid (bbdb-record-uuid record)))
2931 (unless (string= old-uuid value)
2932 (remhash old-uuid bbdb-uuid-table)
2933 (bbdb-record-set-uuid record value)
2934 (puthash value record bbdb-uuid-table))))
2935
2936 ;; creation-date
2937 ((eq field 'creation-date)
2938 ;; MERGE not meaningful
2939 (if check (bbdb-check-type value (bbdb-record-creation-date record-type) t))
2940 (bbdb-record-set-creation-date record value))
2941
2942 ;; timestamp
2943 ((eq field 'timestamp)
2944 ;; MERGE not meaningful
2945 (if check (bbdb-check-type value (bbdb-record-timestamp record-type) t))
2946 (bbdb-record-set-timestamp record value))
2947
2948 ;; all xfields
2949 ((eq field 'xfields)
2950 (if merge
2951 (let ((xfields (bbdb-record-xfields record))
2952 xfield)
2953 (dolist (nv value)
2954 (if (setq xfield (assq (car nv) xfields))
2955 (setcdr xfield (bbdb-merge-xfield
2956 (car nv) (cdr xfield) (cdr nv)))
2957 (setq xfields (append xfields (list nv)))))
2958 (setq value xfields)))
2959 (if check (bbdb-check-type value (bbdb-record-xfields record-type) t))
2960 (let (new-xfields)
2961 (dolist (xfield value)
2962 ;; Ignore junk
2963 (when (and (cdr xfield) (not (equal "" (cdr xfield))))
2964 (push xfield new-xfields)
2965 (bbdb-pushnewq (car xfield) bbdb-xfield-label-list)))
2966 (bbdb-record-set-xfields record (nreverse new-xfields))))
2967
2968 ;; Single xfield
2969 ((symbolp field)
2970 (if merge
2971 (setq value (bbdb-merge-xfield field (bbdb-record-xfield record field)
2972 value)))
2973 ;; The following test always succeeds
2974 ;; (if check (bbdb-check-type value 'sexp t))
2975 ;; This removes xfield FIELD if its value is nil.
2976 (bbdb-record-set-xfield record field value))
2977
2978 (t (error "Unknown field type `%s'" field)))))
2979
2980;; Currently unused (but possible entry for `bbdb-merge-xfield-function-alist')
2981(defun bbdb-merge-concat (string1 string2 &optional separator)
2982 "Return the concatenation of STRING1 and STRING2.
2983SEPARATOR defaults to \"\\n\"."
2984 (concat string1 (or separator "\n") string2))
2985
2986;; Currently unused (but possible entry for `bbdb-merge-xfield-function-alist')
2987(defun bbdb-merge-concat-remove-duplicates (string1 string2)
2988 "Concatenate STRING1 and STRING2, but remove duplicate lines."
2989 (let ((lines (split-string string1 "\n")))
2990 (dolist (line (split-string string2 "\n"))
2991 (bbdb-pushnew line lines))
2992 (bbdb-concat "\n" lines)))
2993
2994(defun bbdb-merge-string-least (string1 string2)
2995 "Return the string out of STRING1 and STRING2 that is `string-lessp'."
2996 (if (string-lessp string1 string2)
2997 string1
2998 string2))
2999
3000(defun bbdb-merge-string-most (string1 string2)
3001 "Return the string out of STRING1 and STRING2 that is not `string-lessp'."
3002 (if (string-lessp string1 string2)
3003 string2
3004 string1))
3005
3006(defun bbdb-merge-lists (l1 l2 cmp)
3007 "Merge two lists L1 and L2 based on comparison CMP.
3008An element from L2 is added to L1 if CMP returns nil for all elements of L1.
3009If L1 or L2 are not lists, they are replaced by (list L1) and (list L2)."
3010 (let (merge)
3011 (unless (listp l1) (setq l1 (list l1)))
3012 (dolist (e2 (if (listp l2) l2 (list l2)))
3013 (let ((ll1 l1) e1 fail)
3014 (while (setq e1 (pop ll1))
3015 (if (funcall cmp e1 e2)
3016 (setq ll1 nil
3017 fail t)))
3018 (unless fail (push e2 merge))))
3019 (append l1 (nreverse merge))))
3020
3021(defun bbdb-merge-xfield (label value1 value2)
3022 "For LABEL merge VALUE1 with VALUE2.
3023If LABEL has an entry in `bbdb-merge-xfield-function-alist', use it.
3024If VALUE1 or VALUE2 is a substring of the other, return the longer one.
3025Otherwise use `bbdb-concat'. Return nil if we have nothing to merge."
3026 (if (stringp value1) (setq value1 (bbdb-string-trim value1 t)))
3027 (if (stringp value2) (setq value2 (bbdb-string-trim value2 t)))
3028 (cond ((and value1 value2)
3029 (let ((fun (cdr (assq label bbdb-merge-xfield-function-alist))))
3030 (cond (fun (funcall fun value1 value2))
3031 ((not (and (stringp value1) (stringp value2)))
3032 (cons value1 value2)) ; concatenate lists
3033 ((string-match (regexp-quote value1) value2) value2)
3034 ((string-match (regexp-quote value2) value1) value1)
3035 (t (bbdb-concat label value1 value2)))))
3036 (value1)
3037 (value2)))
3038
3039;;; Parsing other things
3040
3041(defun bbdb-divide-name (string)
3042 "Divide STRING into a first name and a last name.
3043Case is ignored. Return name as (FIRST . LAST).
3044LAST is always a string (possibly empty). FIRST may be nil."
3045 (let ((case-fold-search t)
3046 first suffix)
3047 ;; Separate a suffix.
3048 (if (string-match bbdb-lastname-suffix-re string)
3049 (setq suffix (concat " " (match-string 1 string))
3050 string (substring string 0 (match-beginning 0))))
3051 (cond ((string-match "\\`\\(.+\\),[ \t\n]*\\(.+\\)\\'" string)
3052 ;; If STRING contains a comma, this probably means that STRING
3053 ;; is of the form "Last, First".
3054 (setq first (match-string 2 string)
3055 string (match-string 1 string)))
3056 ((string-match bbdb-lastname-re string)
3057 (setq first (and (not (zerop (match-beginning 0)))
3058 (substring string 0 (match-beginning 0)))
3059 string (match-string 1 string))))
3060 (cons (and first (bbdb-string-trim first))
3061 (bbdb-string-trim (concat string suffix)))))
3062
3063(defun bbdb-parse-postcode (string)
3064 "Check whether STRING is a legal postcode.
3065Do this only if `bbdb-check-postcode' is non-nil."
3066 (if bbdb-check-postcode
3067 (let ((postcodes bbdb-legal-postcodes) re done)
3068 (while (setq re (pop postcodes))
3069 (if (string-match re string)
3070 (setq done t postcodes nil)))
3071 (if done string
3072 (error "not a valid postcode.")))
3073 string))
3074
3075(defun bbdb-phone-string (phone)
3076 "Massage string PHONE into a standard format."
3077 ;; Phone numbers should come in two forms:
3078 (if (= 2 (length phone))
3079 ;; (1) ["where" "the number"]
3080 (if (stringp (aref phone 1))
3081 (aref phone 1)
3082 (error "Not a valid phone number: %s" (aref phone 1)))
3083 ;; (2) ["where" 415 555 1212 99]
3084 (unless (and (integerp (aref phone 2))
3085 (integerp (aref phone 3)))
3086 (error "Not an NANP number: %s %s" (aref phone 2) (aref phone 3)))
3087 (concat (if (/= 0 (bbdb-phone-area phone))
3088 (format "(%03d) " (bbdb-phone-area phone))
3089 "")
3090 (if (/= 0 (bbdb-phone-exchange phone))
3091 (format "%03d-%04d"
3092 (bbdb-phone-exchange phone) (bbdb-phone-suffix phone))
3093 "")
3094 (if (and (bbdb-phone-extension phone)
3095 (/= 0 (bbdb-phone-extension phone)))
3096 (format " x%d" (bbdb-phone-extension phone))
3097 ""))))
3098
3099(defsubst bbdb-record-lessp (record1 record2)
3100 (string< (bbdb-record-sortkey record1)
3101 (bbdb-record-sortkey record2)))
3102
3103(defmacro bbdb-error-retry (&rest body)
3104 "Repeatedly execute BODY ignoring errors till no error occurs."
3105 `(catch '--bbdb-error-retry--
3106 (while t
3107 (condition-case --c--
3108 (throw '--bbdb-error-retry-- (progn ,@body))
3109 (error (ding)
3110 (message "Error: %s" (nth 1 --c--))
3111 (sit-for 2))))))
3112
3113\f
3114;;; Reading and Writing the BBDB
3115
3116(defun bbdb-buffer ()
3117 "Return buffer that visits the BBDB file `bbdb-file'.
3118Ensure that this buffer is in sync with `bbdb-file'.
3119Revert the buffer if necessary.
3120If `bbdb-file-remote' is non-nil and it is newer than `bbdb-file',
3121copy it to `bbdb-file'."
3122 (unless (buffer-live-p bbdb-buffer)
3123 (if (and bbdb-file-remote
3124 (file-newer-than-file-p bbdb-file-remote bbdb-file))
3125 (copy-file bbdb-file-remote bbdb-file t t))
3126
3127 (with-current-buffer (setq bbdb-buffer (find-file-noselect bbdb-file))
3128
3129 ;; Check whether auto-save file is newer than `bbdb-file'
3130 ;; Do this only when reading `bbdb-file'.
3131 (let ((auto-save-file (make-auto-save-file-name)))
3132 (when (and bbdb-check-auto-save-file
3133 (file-newer-than-file-p auto-save-file buffer-file-name))
3134 (recover-file buffer-file-name) ; this queries
3135 (bury-buffer) ; `recover-file' selects `bbdb-buffer'
3136 (auto-save-mode 1) ; turn auto-save back on
3137 ;; Delete auto-save file even if the user rejected to recover it,
3138 ;; so we do not keep asking.
3139 (condition-case nil
3140 (delete-file auto-save-file)
3141 (file-error nil))))))
3142
3143 ;; Make sure `bbdb-buffer' is not out of sync with disk.
3144 (with-current-buffer bbdb-buffer
3145 (cond ((verify-visited-file-modtime))
3146 ((bbdb-revert-buffer))
3147 ;; This is the case where `bbdb-file' has changed; the buffer
3148 ;; has changed as well; and the user has answered "no" to the
3149 ;; "flush your changes and revert" question. The only other
3150 ;; alternative is to save the file right now. If they answer
3151 ;; no to the following question, they will be asked the
3152 ;; preceeding question again and again some large (but finite)
3153 ;; number of times. `bbdb-buffer' is called a lot, you see...
3154 ((buffer-modified-p)
3155 ;; this queries
3156 (bbdb-save t t))
3157 (t ; Buffer and file are inconsistent, but we let them stay that way
3158 (message "Continuing with inconsistent BBDB buffers")))
3159
3160 ;; `bbdb-revert-buffer' kills all local variables.
3161 (unless (assq 'bbdb-records (buffer-local-variables))
3162 ;; We are reading / reverting `bbdb-buffer'.
3163 (set (make-local-variable 'revert-buffer-function)
3164 'bbdb-revert-buffer)
3165
3166 (setq buffer-file-coding-system bbdb-file-coding-system
3167 buffer-read-only bbdb-read-only
3168 bbdb-mail-aliases-need-rebuilt 'parse
3169 bbdb-changed-records nil)
3170
3171 ;; `bbdb-before-save-hook' and `bbdb-after-save-hook' are user variables.
3172 ;; To avoid confusion, we hide the hook functions `bbdb-before-save'
3173 ;; and `bbdb-after-save' from the user as these are essential for BBDB.
3174 (dolist (hook (cons 'bbdb-before-save bbdb-before-save-hook))
3175 (add-hook 'before-save-hook hook nil t))
3176 (dolist (hook (cons 'bbdb-after-save bbdb-after-save-hook))
3177 (add-hook 'after-save-hook hook nil t))
3178
3179 (clrhash bbdb-hashtable)
3180 (clrhash bbdb-uuid-table)
3181
3182 (if (/= (point-min) (point-max))
3183 (bbdb-parse-records) ; normal case: nonempty db
3184 ;; Empty db: the following does not require `insert-before-markers'
3185 ;; because there are no db-markers in this buffer.
3186 (insert (format (concat ";; -*- mode: Emacs-Lisp; coding: %s; -*-"
3187 "\n;;; file-format: %d\n")
3188 bbdb-file-coding-system bbdb-file-format))
3189 ;; We pretend that `bbdb-buffer' is still unmodified,
3190 ;; so that we will (auto-)save it only if we also add records to it.
3191 (set-buffer-modified-p nil)
3192 (setq bbdb-end-marker (point-marker)
3193 ;; Setting `bbdb-records' makes it buffer-local,
3194 ;; so that we can use it as a test whether we have
3195 ;; initialized BBDB.
3196 bbdb-records nil))
3197
3198 (run-hooks 'bbdb-after-read-db-hook)))
3199
3200 ;; return `bbdb-buffer'
3201 bbdb-buffer)
3202
3203(defmacro bbdb-with-db-buffer (&rest body)
3204 "Execute the forms in BODY with `bbdb-buffer' temporarily current.
3205If `bbdb-debug' was non-nil at compile-time, and `bbdb-buffer' is visible
3206in a window, temporarilly switch to that window. So when we come out,
3207that window has been scrolled to the record we have just modified."
3208 (declare (indent 0))
3209 (if bbdb-debug
3210 `(let* ((buffer (bbdb-buffer))
3211 (window (get-buffer-window buffer)))
3212 (if window
3213 (with-selected-window window
3214 ,@body)
3215 (with-current-buffer buffer
3216 ,@body)))
3217 `(with-current-buffer (bbdb-buffer)
3218 ,@body)))
3219
3220(defun bbdb-editable ()
3221 "Ensure that BBDB is editable, otherwise throw an error.
3222If BBDB is out of sync try to revert.
3223BBDB is not editable if it is read-only."
3224 (if bbdb-read-only (error "BBDB is read-only"))
3225 (let ((buffer (bbdb-buffer))) ; this reverts if necessary / possible
3226 ;; Is the following possible? Superfluous tests do not hurt.
3227 ;; It is relevant only for editing commands in a BBDB buffer,
3228 ;; but not for MUA-related editing functions.
3229 (if (and (eq major-mode 'bbdb-mode)
3230 bbdb-records
3231 (not (memq (caar bbdb-records)
3232 (with-current-buffer buffer bbdb-records))))
3233 (error "BBDB is out of sync")))
3234 t)
3235
3236;;;###autoload
3237(defsubst bbdb-records ()
3238 "Return a list of all BBDB records; read in and parse the db if necessary.
3239This function also notices if the corresponding file on disk has been modified."
3240 (with-current-buffer (bbdb-buffer)
3241 bbdb-records))
3242
3243(defun bbdb-revert-buffer (&optional ignore-auto noconfirm)
3244 "The `revert-buffer-function' for `bbdb-buffer' visiting `bbdb-file'.
3245IGNORE-AUTO and NOCONFIRM have same meaning as in `revert-buffer'.
3246See also variable `bbdb-auto-revert'.
3247Return t if the reversion was successful (or not needed).
3248Return nil otherwise."
3249 (interactive (list (not current-prefix-arg))) ; as in `revert-buffer'
3250 (unless (buffer-live-p bbdb-buffer)
3251 (error "No live BBDB buffer to revert"))
3252 (with-current-buffer bbdb-buffer
3253 (cond ((not buffer-file-number)
3254 ;; We have not yet created `bbdb-file'
3255 (when (or noconfirm
3256 (yes-or-no-p "Flush your changes? "))
3257 (erase-buffer)
3258 (kill-all-local-variables) ; clear database
3259 (bbdb-buffer) ; re-initialize
3260 (set-buffer-modified-p nil)
3261 (bbdb-undisplay-records t)))
3262 ;; If nothing has changed do nothing, return t.
3263 ((and (verify-visited-file-modtime)
3264 (not (buffer-modified-p))))
3265 ((or (and (not (verify-visited-file-modtime bbdb-buffer))
3266 ;; File changed on disk
3267 (or noconfirm
3268 (and bbdb-auto-revert
3269 (not (buffer-modified-p)))
3270 (yes-or-no-p
3271 (if (buffer-modified-p)
3272 "BBDB changed on disk; flush your changes and revert? "
3273 "BBDB changed on disk; revert? "))))
3274 (and (verify-visited-file-modtime bbdb-buffer)
3275 ;; File not changed on disk, but buffer modified
3276 (buffer-modified-p)
3277 (or noconfirm
3278 (yes-or-no-p "Flush your changes and revert BBDB? "))))
3279 (unless (file-exists-p bbdb-file)
3280 (error "BBDB: file %s no longer exists" bbdb-file))
3281 (kill-all-local-variables) ; clear database
3282 ;; `revert-buffer-function' has the permanent-local property
3283 ;; So to avoid looping, we need to bind it to nil explicitly.
3284 (let (revert-buffer-function)
3285 (revert-buffer ignore-auto t))
3286 (bbdb-buffer) ; re-initialize
3287 (bbdb-undisplay-records t)
3288 t)))) ; return nil if the user rejected to revert
3289
3290(defun bbdb-goto-first-record ()
3291 "Go to where first record begins, Move to end of file if no records."
3292 (goto-char (point-min))
3293 (if (search-forward "\n[" nil 'move)
3294 (forward-char -1)))
3295
3296(defun bbdb-parse-records ()
3297 "Parse BBDB records and initialize various internal variables.
3298If `bbdb-file' uses an outdated format, migrate to `bbdb-file-format'."
3299 (save-excursion
3300 (save-restriction
3301 (widen)
3302 (bbdb-goto-first-record)
3303 (let* ((file (abbreviate-file-name buffer-file-name))
3304 (file-format (save-excursion
3305 (if (re-search-backward
3306 "^;+[ \t]*file-\\(format\\|version\\):[ \t]*\\([0-9]+\\)[ \t]*$" nil t)
3307 (string-to-number (match-string 2))
3308 ;; No file-format line.
3309 (error "BBDB corrupted: no file-format line"))))
3310 (migrate (< file-format bbdb-file-format))
3311 records)
3312 (if (> file-format bbdb-file-format)
3313 (error "%s understands file format %s but not %s."
3314 (bbdb-version) bbdb-file-format file-format))
3315
3316 (if (and migrate
3317 (not (yes-or-no-p
3318 (format (concat "Migrate `%s' to BBDB file format %s "
3319 "(back-up recommended)? ")
3320 file bbdb-file-format))))
3321 (progn
3322 (message "Abort loading %s" file)
3323 (sleep-for 2)
3324 (setq bbdb-records nil
3325 ;; Avoid unexpected surprises
3326 buffer-read-only t)
3327 'abort)
3328
3329 (or (eobp) (looking-at "\\[")
3330 (error "BBDB corrupted: no following bracket"))
3331
3332 (unless bbdb-silent (message "Parsing BBDB file `%s'..." file))
3333
3334 ;; narrow the buffer to skip over the rubbish before the first record.
3335 (narrow-to-region (point) (point-max))
3336 (let ((modp (buffer-modified-p))
3337 ;; Make sure those parens get cleaned up.
3338 ;; This code had better stay simple!
3339 (inhibit-quit t)
3340 (buffer-undo-list t)
3341 buffer-read-only)
3342 (goto-char (point-min)) (insert "(\n")
3343 (goto-char (point-max)) (insert "\n)")
3344 (goto-char (point-min))
3345 (unwind-protect
3346 (setq records (read (current-buffer)))
3347 (goto-char (point-min)) (delete-char 2)
3348 (goto-char (point-max)) (delete-char -2)
3349 (set-buffer-modified-p modp)))
3350 (widen)
3351
3352 ;; Migrate if `bbdb-file' is outdated.
3353 (if migrate (setq records (bbdb-migrate records file-format)))
3354
3355 ;; We could first set `bbdb-phone-label-list' and
3356 ;; `bbdb-address-label-list' to their customized values. Bother?
3357 (setq bbdb-records records
3358 bbdb-xfield-label-list nil
3359 bbdb-organization-list nil
3360 bbdb-street-list nil
3361 bbdb-city-list nil
3362 bbdb-state-list nil
3363 bbdb-postcode-list nil
3364 bbdb-country-list nil)
3365
3366 (bbdb-goto-first-record)
3367 (dolist (record records)
3368 ;; We assume that the markers for each record need to go at each
3369 ;; newline. If this is not the case, things can go *very* wrong.
3370 (bbdb-debug
3371 (unless (looking-at "\\[")
3372 (error "BBDB corrupted: junk between records at %s" (point))))
3373
3374 (bbdb-cache-set-marker
3375 (bbdb-record-set-cache record (make-vector bbdb-cache-length nil))
3376 (point-marker))
3377 (forward-line 1)
3378
3379 ;; Every record must have a unique uuid in `bbdb-uuid-table'.
3380 (if (gethash (bbdb-record-uuid record) bbdb-uuid-table)
3381 ;; Is there a more useful action than throwing an error?
3382 ;; We are just loading BBDB, so we are not yet ready
3383 ;; for sophisticated solutions.
3384 (error "Duplicate UUID %s" (bbdb-record-uuid record)))
3385
3386 ;; Set the completion lists
3387 (dolist (phone (bbdb-record-phone record))
3388 (bbdb-pushnew (bbdb-phone-label phone) bbdb-phone-label-list))
3389 (dolist (address (bbdb-record-address record))
3390 (bbdb-pushnew (bbdb-address-label address) bbdb-address-label-list)
3391 (mapc (lambda (street) (bbdb-pushnewt street bbdb-street-list))
3392 (bbdb-address-streets address))
3393 (bbdb-pushnewt (bbdb-address-city address) bbdb-city-list)
3394 (bbdb-pushnewt (bbdb-address-state address) bbdb-state-list)
3395 (bbdb-pushnewt (bbdb-address-postcode address) bbdb-postcode-list)
3396 (bbdb-pushnewt (bbdb-address-country address) bbdb-country-list))
3397 (dolist (xfield (bbdb-record-xfields record))
3398 (bbdb-pushnewq (car xfield) bbdb-xfield-label-list))
3399 (dolist (organization (bbdb-record-organization record))
3400 (bbdb-pushnew organization bbdb-organization-list))
3401
3402 (let ((name (bbdb-concat 'name-first-last
3403 (bbdb-record-firstname record)
3404 (bbdb-record-lastname record))))
3405 (when (and (not bbdb-allow-duplicates)
3406 (bbdb-gethash name '(fl-name aka)))
3407 ;; This does not check for duplicate mail fields.
3408 ;; Yet under normal circumstances, this should really
3409 ;; not be necessary each time BBDB is loaded as BBDB checks
3410 ;; whether creating a new record or modifying an existing one
3411 ;; results in duplicates.
3412 ;; Alternatively, you can use `bbdb-search-duplicates'.
3413 (message "Duplicate BBDB record encountered: %s" name)
3414 (sit-for 1)))
3415
3416 ;; If `bbdb-allow-duplicates' is non-nil, we allow that two records
3417 ;; (with different uuids) refer to the same person (same name etc.).
3418 ;; Such duplicate records are always hashed.
3419 ;; Otherwise, an unhashed record would not be available for things
3420 ;; like completion (and we would not know which record to keeep
3421 ;; and which one to hide). We trust the user she knows what
3422 ;; she wants if she keeps duplicate records in the database though
3423 ;; `bbdb-allow-duplicates' is nil.
3424 (bbdb-hash-record record))
3425
3426 ;; Note that `bbdb-xfield-label-list' serves two purposes:
3427 ;; - check whether an xfield is new to BBDB
3428 ;; - list of known xfields for minibuffer completion
3429 ;; Only in the latter case, we might want to exclude
3430 ;; those xfields that are handled automatically.
3431 ;; So the following is not a satisfactory solution.
3432
3433 ;; (dolist (label (bbdb-layout-get-option 'multi-line 'omit))
3434 ;; (setq bbdb-xfield-label-list (delq label bbdb-xfield-label-list)))
3435
3436 ;; `bbdb-end-marker' allows to put comments at the end of `bbdb-file'
3437 ;; that are ignored.
3438 (setq bbdb-end-marker (point-marker))
3439
3440 (when migrate
3441 (dolist (record bbdb-records)
3442 (bbdb-overwrite-record-internal record))
3443 ;; update file format
3444 (goto-char (point-min))
3445 (if (re-search-forward (format "^;;; file-\\(version\\|format\\): %d$"
3446 file-format)
3447 nil t)
3448 (replace-match (format ";;; file-format: %d" bbdb-file-format))))
3449
3450 (unless bbdb-silent (message "Parsing BBDB file `%s'...done" file))
3451 bbdb-records)))))
3452
3453(defun bbdb-before-save ()
3454 "Run before saving `bbdb-file' as buffer-local part of `before-save-hook'."
3455 (when (and bbdb-file-remote
3456 (or bbdb-file-remote-save-always
3457 (y-or-n-p (format "Save the remote BBDB file %s too? "
3458 bbdb-file-remote))))
3459 ;; Write the current buffer `bbdb-file' into `bbdb-file-remote'.
3460 (let ((coding-system-for-write bbdb-file-coding-system))
3461 (write-region (point-min) (point-max) bbdb-file-remote))))
3462
3463(defun bbdb-after-save ()
3464 "Run after saving `bbdb-file' as buffer-local part of `after-save-hook'."
3465 (setq bbdb-changed-records nil)
3466 (dolist (buffer (buffer-list))
3467 (with-current-buffer buffer
3468 (if (eq major-mode 'bbdb-mode)
3469 (set-buffer-modified-p nil)))))
3470
3471(defun bbdb-change-record (record &rest ignored)
3472 "Update the database after a change of RECORD.
3473Return RECORD if RECORD got changed compared with the database,
3474return nil otherwise.
3475Hash RECORD if it is new. If RECORD is not new, it is the the caller's
3476responsibility to update the hashtables for RECORD. (Up-to-date hashtables are
3477ensured if the fields are modified by calling `bbdb-record-set-field'.)
3478Redisplay RECORD if it is not new.
3479
3480Args IGNORED are ignored and their use is discouraged.
3481They are present only for backward compatibility."
3482 (when (and ignored (get 'bbdb-change-record 'bbdb-outdated))
3483 (put 'bbdb-change-record 'bbdb-outdated t)
3484 (message "Outdated usage of `bbdb-change-record'")
3485 (sit-for 2))
3486
3487 (if bbdb-read-only
3488 (error "The Insidious Big Brother Database is read-only."))
3489 ;; The call of `bbdb-records' checks file synchronization.
3490 ;; If RECORD refers to an existing record that has been changed,
3491 ;; yet in the meanwhile we reverted the BBDB file, then RECORD
3492 ;; no longer refers to a record in `bbdb-records'. RECORD will then
3493 ;; be treated as new, when we try to merge it with the known record.
3494 (let ((tail (memq record (bbdb-records))))
3495 (if tail ; RECORD is not new
3496 ;; If the string we currently have for RECORD in `bbdb-buffer'
3497 ;; is `equal' to the string we would write to `bbdb-buffer',
3498 ;; we really did not change RECORD at all. So we don't update RECORD
3499 ;; unless `bbdb-update-unchanged-records' tells us to do so anyway.
3500 ;; Also, we only call `bbdb-change-hook' and `bbdb-after-change-hook'
3501 ;; if RECORD got changed.
3502 (when (or bbdb-update-unchanged-records
3503 (not (string= (bbdb-with-db-buffer
3504 (buffer-substring-no-properties
3505 (bbdb-record-marker record)
3506 (1- (if (cdr tail)
3507 (bbdb-record-marker (cadr tail))
3508 bbdb-end-marker))))
3509 (let ((cache (bbdb-record-cache record))
3510 (inhibit-quit t))
3511 (bbdb-record-set-cache record nil)
3512 (prog1 (bbdb-with-print-loadably
3513 (prin1-to-string record))
3514 (bbdb-record-set-cache record cache))))))
3515 (bbdb-record-set-timestamp
3516 record (format-time-string bbdb-time-stamp-format nil t))
3517 (run-hook-with-args 'bbdb-change-hook record)
3518 (let ((sort (not (equal (bbdb-cache-sortkey (bbdb-record-cache record))
3519 (bbdb-record-set-sortkey record)))))
3520 (if (not sort) ;; If we do not need to sort, overwrite RECORD.
3521 (bbdb-overwrite-record-internal record)
3522 ;; Since we need to sort, delete then insert RECORD.
3523 ;; Do not mess with the hash tables here.
3524 ;; We assume they got updated by the caller.
3525 (bbdb-delete-record-internal record)
3526 (bbdb-insert-record-internal record))
3527 (bbdb-pushnewq record bbdb-changed-records)
3528 (run-hook-with-args 'bbdb-after-change-hook record)
3529 (bbdb-redisplay-record-globally record sort))
3530 record)
3531
3532 ;; Record is new and not yet in BBDB.
3533 (unless (bbdb-record-cache record)
3534 (bbdb-record-set-cache record (make-vector bbdb-cache-length nil)))
3535 (unless (bbdb-record-uuid record)
3536 (bbdb-record-set-uuid record (bbdb-uuid)))
3537 (unless (bbdb-record-creation-date record)
3538 (bbdb-record-set-creation-date
3539 record (format-time-string bbdb-time-stamp-format nil t))
3540 (run-hook-with-args 'bbdb-create-hook record))
3541
3542 (let ((old-record (gethash (bbdb-record-uuid record) bbdb-uuid-table)))
3543 (if old-record
3544 ;; RECORD is really OLD-RECORD. Merge and return OLD-RECORD.
3545 (if bbdb-merge-records-function
3546 (funcall bbdb-merge-records-function record old-record)
3547 (bbdb-merge-records record old-record))
3548
3549 ;; RECORD is really new.
3550 (bbdb-record-set-timestamp
3551 record (format-time-string bbdb-time-stamp-format nil t))
3552 (run-hook-with-args 'bbdb-change-hook record)
3553 (bbdb-insert-record-internal record)
3554 (bbdb-hash-record record)
3555 (bbdb-pushnewq record bbdb-changed-records)
3556 (run-hook-with-args 'bbdb-after-change-hook record)
3557 record)))))
3558
3559(defun bbdb-delete-record-internal (record &optional completely)
3560 "Delete RECORD in the database file.
3561With COMPLETELY non-nil, also undisplay RECORD and remove it
3562from the hash table."
3563 (unless (bbdb-record-marker record) (error "BBDB: marker absent"))
3564 (if completely (bbdb-redisplay-record-globally record nil t))
3565 (bbdb-with-db-buffer
3566 (barf-if-buffer-read-only)
3567 (let ((tail (memq record bbdb-records))
3568 (inhibit-quit t))
3569 (unless tail (error "BBDB record absent: %s" record))
3570 (delete-region (bbdb-record-marker record)
3571 (if (cdr tail)
3572 (bbdb-record-marker (car (cdr tail)))
3573 bbdb-end-marker))
3574 (setq bbdb-records (delq record bbdb-records))
3575 (when completely
3576 (bbdb-remhash (bbdb-record-name record) record)
3577 (bbdb-remhash (bbdb-record-name-lf record) record)
3578 (dolist (organization (bbdb-record-organization record))
3579 (bbdb-remhash organization record))
3580 (dolist (mail (bbdb-record-mail-canon record))
3581 (bbdb-remhash mail record))
3582 (dolist (aka (bbdb-record-field record 'aka-all))
3583 (bbdb-remhash aka record))))))
3584
3585(defun bbdb-insert-record-internal (record)
3586 "Insert RECORD into the database file. Return RECORD.
3587Do not call this function directly, call instead `bbdb-change-record'
3588that calls the hooks, too."
3589 (unless (bbdb-record-marker record)
3590 (bbdb-record-set-marker record (make-marker)))
3591 (bbdb-with-db-buffer
3592 (barf-if-buffer-read-only)
3593 ;; splice record into `bbdb-records'
3594 (bbdb-debug (if (memq record bbdb-records)
3595 (error "BBDB record not unique: - %s" record)))
3596 (if (or (not bbdb-records) ; first record in new database
3597 (bbdb-record-lessp record (car bbdb-records)))
3598 (push record bbdb-records)
3599 (let ((records bbdb-records))
3600 (while (and (cdr records)
3601 (bbdb-record-lessp (nth 1 records) record))
3602 (setq records (cdr records)))
3603 (setcdr records (cons record (cdr records)))))
3604
3605 (let ((next (car (cdr (memq record bbdb-records)))))
3606 (goto-char (if next
3607 (bbdb-record-marker next)
3608 bbdb-end-marker)))
3609 ;; Before writing the record, remove the cache (we do not want that
3610 ;; written to the file.) After writing, put the cache back and update
3611 ;; the cache's marker.
3612 (let ((cache (bbdb-record-cache record))
3613 (point (point))
3614 (inhibit-quit t))
3615 (bbdb-debug
3616 (if (= point (point-min))
3617 (error "Inserting at point-min (%s)" point))
3618 (if (and (/= point bbdb-end-marker)
3619 (not (looking-at "^\\[")))
3620 (error "Not inserting before a record (%s)" point)))
3621 (bbdb-record-set-cache record nil)
3622 (insert-before-markers
3623 (bbdb-with-print-loadably (prin1-to-string record)) "\n")
3624 (set-marker (bbdb-cache-marker cache) point)
3625 (bbdb-record-set-cache record cache))
3626 record))
3627
3628(defun bbdb-overwrite-record-internal (record)
3629 "Overwrite RECORD in the database file. Return RECORD.
3630Do not call this function directly, call instead `bbdb-change-record'
3631that calls the hooks, too."
3632 (bbdb-with-db-buffer
3633 (barf-if-buffer-read-only)
3634 (let* ((tail (memq record bbdb-records))
3635 (_ (unless tail (error "BBDB record absent: %s" record)))
3636 (cache (bbdb-record-cache record))
3637 (inhibit-quit t))
3638 (bbdb-debug
3639 (if (<= (bbdb-cache-marker cache) (point-min))
3640 (error "Cache marker is %s" (bbdb-cache-marker cache))))
3641 (goto-char (bbdb-cache-marker cache))
3642 (bbdb-debug
3643 (if (and (/= (point) bbdb-end-marker)
3644 (not (looking-at "\\[")))
3645 (error "Not inserting before a record (%s)" (point))))
3646
3647 (bbdb-record-set-cache record nil)
3648 (insert (bbdb-with-print-loadably (prin1-to-string record)) "\n")
3649 (delete-region (point)
3650 (if (cdr tail)
3651 (bbdb-record-marker (car (cdr tail)))
3652 bbdb-end-marker))
3653 (bbdb-record-set-cache record cache)
3654
3655 (bbdb-debug
3656 (if (<= (if (cdr tail)
3657 (bbdb-record-marker (car (cdr tail)))
3658 bbdb-end-marker)
3659 (bbdb-record-marker record))
3660 (error "Overwrite failed")))
3661
3662 record)))
3663
3664;; Record formatting:
3665;; This does not insert anything into the *BBDB* buffer,
3666;; which is handled in a second step by the display functions.
3667
3668(defun bbdb-layout-get-option (layout option)
3669 "For LAYOUT return value of OPTION according to `bbdb-layout-alist'."
3670 (let ((layout-spec (if (listp layout)
3671 layout
3672 (assq layout bbdb-layout-alist)))
3673 option-value)
3674 (and layout-spec
3675 (setq option-value (assq option layout-spec))
3676 (cdr option-value))))
3677
3678(defun bbdb-address-continental-p (address)
3679 "Return non-nil if ADDRESS is a continental address.
3680This is done by comparing the postcode to `bbdb-continental-postcode-regexp'.
3681
3682This is a possible identifying function for
3683`bbdb-address-format-list' and `bbdb-tex-address-format-list'."
3684 (string-match bbdb-continental-postcode-regexp
3685 (bbdb-address-postcode address)))
3686
3687;; This function can provide some guidance for writing
3688;; your own address formatting function
3689(defun bbdb-format-address-default (address)
3690 "Return formatted ADDRESS as a string.
3691This is the default format; it is used in the US, for example.
3692The result looks like this:
3693 label: street
3694 street
3695 ...
3696 city, state postcode
3697 country.
3698
3699This function is a possible formatting function for
3700`bbdb-address-format-list'."
3701 (let ((country (bbdb-address-country address))
3702 (streets (bbdb-address-streets address)))
3703 (concat (if streets
3704 (concat (mapconcat 'identity streets "\n") "\n"))
3705 (bbdb-concat ", " (bbdb-address-city address)
3706 (bbdb-concat " " (bbdb-address-state address)
3707 (bbdb-address-postcode address)))
3708 (unless (or (not country) (string= "" country))
3709 (concat "\n" country)))))
3710
3711(defun bbdb-format-address (address layout)
3712 "Format ADDRESS using LAYOUT. Return result as a string.
3713The formatting rules are defined in `bbdb-address-format-list'."
3714 (let ((list bbdb-address-format-list)
3715 (country (bbdb-address-country address))
3716 elt string)
3717 (while (and (not string) (setq elt (pop list)))
3718 (let ((identifier (car elt))
3719 (format (nth layout elt))
3720 ;; recognize case for format identifiers
3721 case-fold-search str)
3722 (when (or (eq t identifier) ; default
3723 (and (functionp identifier)
3724 (funcall identifier address))
3725 (and country
3726 (listp identifier)
3727 ;; ignore case for countries
3728 (member-ignore-case country identifier)))
3729 (cond ((functionp format)
3730 (setq string (funcall format address)))
3731 ((stringp format)
3732 (setq string "")
3733 (dolist (form (split-string (substring format 1 -1)
3734 (substring format 0 1) t))
3735 (cond ((string-match "%s" form) ; street
3736 (mapc (lambda (s) (setq string (concat string (format form s))))
3737 (bbdb-address-streets address)))
3738 ((string-match "%c" form) ; city
3739 (unless (or (not (setq str (bbdb-address-city address))) (string= "" str))
3740 (setq string (concat string (format (replace-regexp-in-string "%c" "%s" form) str)))))
3741 ((string-match "%p" form) ; postcode
3742 (unless (or (not (setq str (bbdb-address-postcode address))) (string= "" str))
3743 (setq string (concat string (format (replace-regexp-in-string "%p" "%s" form) str)))))
3744 ((string-match "%S" form) ; state
3745 (unless (or (not (setq str (bbdb-address-state address))) (string= "" str))
3746 (setq string (concat string (format (replace-regexp-in-string "%S" "%s" form t) str)))))
3747 ((string-match "%C" form) ; country
3748 (unless (or (not country) (string= "" country))
3749 (setq string (concat string (format (replace-regexp-in-string "%C" "%s" form t) country)))))
3750 (t (error "Malformed address format element %s" form)))))
3751 (t (error "Malformed address format %s" format))))))
3752 (unless string
3753 (error "No match of `bbdb-address-format-list'"))
3754 string))
3755
3756;;; Record display:
3757;; This inserts formatted (pieces of) records into the BBDB buffer.
3758
3759(defsubst bbdb-field-property (start field)
3760 "Set text property bbdb-field of text between START and point to FIELD."
3761 (put-text-property start (point) 'bbdb-field field))
3762
3763(defsubst bbdb-display-text (text field &optional face)
3764 "Insert TEXT at point. Set its text property bbdb-field to FIELD.
3765If FACE is non-nil, also add face FACE."
3766 (let ((start (point)))
3767 (insert text)
3768 (bbdb-field-property start field)
3769 (if face (put-text-property start (point) 'face face))))
3770
3771(defun bbdb-display-list (list field &optional terminator face indent)
3772 "Insert elements of LIST at point.
3773For inserted text, set text property bbdb-field to FIELD.
3774If TERMINATOR is non-nil use it to terminate the inserted text.
3775If FACE is non-nil use it as FACE for inserted text.
3776If INDENT and `bbdb-wrap-column' are integers, insert line breaks in between
3777elements of LIST if otherwise inserted text exceeds `bbdb-wrap-column'."
3778 ;; `truncate-lines' is fine for one-line layout. But it is annyoing
3779 ;; for records that are displayed with multi-line layout.
3780 ;; Non-nil `word-wrap' would be much nicer. How can we switch between
3781 ;; non-nil `truncate-lines' and non-nil `word-wrap' on a per-record basis?
3782 ;; The following code is an alternative solution using `bbdb-wrap-column'.
3783 (let* ((separator (nth 1 (or (cdr (assq field bbdb-separator-alist))
3784 bbdb-default-separator)))
3785 (indent-flag (and (integerp bbdb-wrap-column)
3786 (integerp indent)))
3787 (prefix (if indent-flag
3788 (concat separator "\n" (make-string indent ?\s))))
3789 elt)
3790 (while (setq elt (pop list))
3791 (bbdb-display-text elt (list field elt) face)
3792 (cond ((and list indent-flag
3793 (> (+ (current-column) (length (car list)))
3794 bbdb-wrap-column))
3795 (bbdb-display-text prefix (list field) face))
3796 (list
3797 (bbdb-display-text separator (list field) face))
3798 (terminator
3799 (bbdb-display-text terminator (list field) face))))))
3800
3801(defun bbdb-display-name-organization (record)
3802 "Insert name, affix, and organization of RECORD.
3803If RECORD has an xfield name-face, its value is used for font-locking name.
3804The value of name-face may be a face that is used directly.
3805The value may also be a key in `bbdb-name-face-alist'. Then the
3806corresponding cdr is used. If none of these schemes succeeds the face
3807`bbdb-face' is used."
3808 ;; Should this be further customizable? We could build the following
3809 ;; from a customizable list containing function calls and strings.
3810 ;; Name
3811 (let ((name (if (eq 'last-first
3812 (or (bbdb-record-xfield-intern record 'name-format)
3813 bbdb-name-format))
3814 (bbdb-record-name-lf record)
3815 ;; default: Firstname Lastname
3816 (bbdb-record-name record)))
3817 (name-face (bbdb-record-xfield record 'name-face)))
3818 (if (string= "" name) (setq name "???"))
3819 (bbdb-display-text name (list 'name name)
3820 (if name-face
3821 (cond ((facep name-face) name-face)
3822 ((cdr (assoc name-face bbdb-name-face-alist)))
3823 (t 'bbdb-name))
3824 'bbdb-name)))
3825 ;; Affix
3826 (let ((affix (bbdb-record-affix record)))
3827 (when affix
3828 (insert ", ")
3829 (bbdb-display-list affix 'affix)))
3830 ;; Organization
3831 (let ((organization (bbdb-record-organization record)))
3832 (when organization
3833 (insert " - ")
3834 (bbdb-display-list organization 'organization nil
3835 'bbdb-organization)))
3836 ;; Image
3837 (if (and bbdb-image (display-images-p))
3838 (let ((image (cond ((functionp bbdb-image)
3839 (funcall bbdb-image record))
3840 ((memq bbdb-image '(name fl-name))
3841 (bbdb-record-name record))
3842 ((eq bbdb-image 'lf-name)
3843 (bbdb-record-name-lf record))
3844 (t
3845 (bbdb-record-xfield record bbdb-image)))))
3846 (when (and image
3847 (setq image (locate-file image bbdb-image-path
3848 bbdb-image-suffixes))
3849 (setq image (create-image image)))
3850 (insert " ")
3851 (insert-image image)))))
3852
3853(defun bbdb-display-record-one-line (record layout field-list)
3854 "Format RECORD for the one-line FORMAT using LAYOUT.
3855See `bbdb-layout-alist' for more info on layouts.
3856FIELD-LIST is the list of actually displayed FIELDS."
3857 ;; Name, affix, and organizations
3858 (bbdb-display-name-organization record)
3859 (let ((name-end (or (bbdb-layout-get-option layout 'name-end)
3860 40))
3861 (start (line-beginning-position)))
3862 (when (> (- (point) start -1) name-end)
3863 (put-text-property (+ start name-end -4) (point) 'invisible t)
3864 (insert "..."))
3865 (indent-to name-end))
3866 ;; rest of the fields
3867 (let (formatfun start)
3868 (dolist (field field-list)
3869 (cond (;; customized formatting
3870 (setq formatfun (intern-soft (format "bbdb-display-%s-one-line" field)))
3871 (funcall formatfun record))
3872 ;; phone
3873 ((eq field 'phone)
3874 (let ((phones (bbdb-record-phone record)) phone)
3875 (if phones
3876 (while (setq phone (pop phones))
3877 (bbdb-display-text (format "%s " (aref phone 0))
3878 `(phone ,phone field-label)
3879 'bbdb-field-name)
3880 (bbdb-display-text (format "%s%s" (aref phone 1)
3881 (if phones " " "; "))
3882 `(phone ,phone))))))
3883 ;; address
3884 ((eq field 'address)
3885 (dolist (address (bbdb-record-address record))
3886 (setq start (point))
3887 (insert (bbdb-format-address address 3))
3888 (bbdb-field-property start `(address ,address))
3889 (insert "; ")))
3890 ;; mail
3891 ((eq field 'mail)
3892 (let ((mail (bbdb-record-mail record)))
3893 (if mail
3894 (bbdb-display-list (if (bbdb-layout-get-option layout 'primary)
3895 (list (car mail)) mail)
3896 'mail "; "))))
3897 ;; AKA
3898 ((eq field 'aka)
3899 (let ((aka (bbdb-record-aka record)))
3900 (if aka
3901 (bbdb-display-list aka 'aka "; "))))
3902 ;; uuid
3903 ((eq field 'uuid)
3904 (let ((uuid (bbdb-record-uuid record)))
3905 (bbdb-display-text (format "%s; " uuid) `(uuid ,uuid))))
3906 ;; creation-date
3907 ((eq field 'creation-date)
3908 (let ((creation-date (bbdb-record-creation-date record)))
3909 (bbdb-display-text (format "%s; " creation-date) `(creation-date ,creation-date))))
3910 ;; timestamp
3911 ((eq field 'timestamp)
3912 (let ((timestamp (bbdb-record-timestamp record)))
3913 (bbdb-display-text (format "%s; " timestamp) `(timestamp ,timestamp))))
3914 ;; xfields
3915 (t
3916 (let* ((xfield (assq field (bbdb-record-xfields record)))
3917 (value (cdr xfield)))
3918 (if value
3919 (bbdb-display-text
3920 (concat (if (stringp value)
3921 (replace-regexp-in-string
3922 "\n" "; " value)
3923 ;; value of xfield is a sexp
3924 (let ((print-escape-newlines t))
3925 (prin1-to-string value)))
3926 "; ")
3927 `(xfields ,xfield)))))))
3928 ;; delete the trailing "; "
3929 (if (looking-back "; " nil)
3930 (backward-delete-char 2))
3931 (insert "\n")))
3932
3933(defun bbdb-display-record-multi-line (record layout field-list)
3934 "Format RECORD for the multi-line FORMAT using LAYOUT.
3935See `bbdb-layout-alist' for more info on layouts.
3936FIELD-LIST is the list of actually displayed FIELDS."
3937 (bbdb-display-name-organization record)
3938 (insert "\n")
3939 (let* ((indent (or (bbdb-layout-get-option layout 'indentation) 21))
3940 ;; The format string FMT adds three extra characters.
3941 ;; So we subtract those from the value of INDENT.
3942 (fmt (format " %%%ds: " (- indent 3)))
3943 start formatfun)
3944 (dolist (field field-list)
3945 (setq start (point))
3946 (cond (;; customized formatting
3947 (setq formatfun (intern-soft (format "bbdb-display-%s-multi-line" field)))
3948 (funcall formatfun record indent))
3949 ;; phone
3950 ((eq field 'phone)
3951 (dolist (phone (bbdb-record-phone record))
3952 (bbdb-display-text (format fmt (concat "phone ("
3953 (bbdb-phone-label phone)
3954 ")"))
3955 `(phone ,phone field-label)
3956 'bbdb-field-name)
3957 (bbdb-display-text (concat (bbdb-phone-string phone) "\n")
3958 `(phone ,phone))))
3959 ;; address
3960 ((eq field 'address)
3961 (dolist (address (bbdb-record-address record))
3962 (bbdb-display-text (format fmt (concat "address ("
3963 (bbdb-address-label address)
3964 ")"))
3965 `(address ,address field-label)
3966 'bbdb-field-name)
3967 (setq start (point))
3968 (insert (bbdb-indent-string (bbdb-format-address address 2) indent)
3969 "\n")
3970 (bbdb-field-property start `(address ,address))))
3971 ;; mail
3972 ((eq field 'mail)
3973 (let ((mail (bbdb-record-mail record)))
3974 (when mail
3975 (bbdb-display-text (format fmt "mail") '(mail nil field-label)
3976 'bbdb-field-name)
3977 (bbdb-display-list (if (bbdb-layout-get-option layout 'primary)
3978 (list (car mail)) mail)
3979 'mail "\n" nil indent))))
3980 ;; AKA
3981 ((eq field 'aka)
3982 (let ((aka (bbdb-record-aka record)))
3983 (when aka
3984 (bbdb-display-text (format fmt "AKA") '(aka nil field-label)
3985 'bbdb-field-name)
3986 (bbdb-display-list aka 'aka "\n"))))
3987 ;; uuid
3988 ((eq field 'uuid)
3989 (let ((uuid (bbdb-record-uuid record)))
3990 (bbdb-display-text (format fmt "uuid") `(uuid ,uuid field-label)
3991 'bbdb-field-name)
3992 (bbdb-display-text (format "%s\n" uuid) `(uuid ,uuid))))
3993 ;; creation-date
3994 ((eq field 'creation-date)
3995 (let ((creation-date (bbdb-record-creation-date record)))
3996 (bbdb-display-text (format fmt "creation-date") `(creation-date ,creation-date field-label)
3997 'bbdb-field-name)
3998 (bbdb-display-text (format "%s\n" creation-date) `(creation-date ,creation-date))))
3999 ;; timestamp
4000 ((eq field 'timestamp)
4001 (let ((timestamp (bbdb-record-timestamp record)))
4002 (bbdb-display-text (format fmt "timestamp") `(timestamp ,timestamp field-label)
4003 'bbdb-field-name)
4004 (bbdb-display-text (format "%s\n" timestamp) `(timestamp ,timestamp))))
4005 ;; xfields
4006 (t
4007 (let* ((xfield (assq field (bbdb-record-xfields record)))
4008 (value (cdr xfield)))
4009 (when value
4010 (bbdb-display-text (format fmt field)
4011 `(xfields ,xfield field-label)
4012 'bbdb-field-name)
4013 (setq start (point))
4014 (insert (bbdb-indent-string
4015 (if (stringp value)
4016 value
4017 ;; value of xfield is a sexp
4018 (let ((string (pp-to-string value)))
4019 (if (string-match "[ \t\n]+\\'" string)
4020 (substring-no-properties
4021 string 0 (match-beginning 0))
4022 string)))
4023 indent) "\n")
4024 (bbdb-field-property start `(xfields ,xfield)))))))
4025 (insert "\n")))
4026
4027(defalias 'bbdb-display-record-full-multi-line
4028 'bbdb-display-record-multi-line)
4029
4030(defalias 'bbdb-display-record-pop-up-multi-line
4031 'bbdb-display-record-multi-line)
4032
4033(defun bbdb-display-record (record layout number)
4034 "Insert a formatted RECORD into the current buffer at point.
4035LAYOUT can be a symbol describing a layout in `bbdb-layout-alist'.
4036If it is nil, use `bbdb-layout'.
4037NUMBER is the number of RECORD among the displayed records.
4038Move point to the end of the inserted record."
4039 (unless layout (setq layout bbdb-layout))
4040 (unless (assq layout bbdb-layout-alist)
4041 (error "Unknown layout `%s'" layout))
4042 (let ((display-p (bbdb-layout-get-option layout 'display-p))
4043 (omit-list (bbdb-layout-get-option layout 'omit)) ; omitted fields
4044 (order-list (bbdb-layout-get-option layout 'order)); requested field order
4045 (all-fields (append '(phone address mail aka) ; default field order
4046 (mapcar 'car (bbdb-record-xfields record))
4047 '(uuid creation-date timestamp)))
4048 (beg (point))
4049 format-function field-list)
4050 (when (or (not display-p)
4051 (and display-p
4052 (funcall display-p)))
4053 (if (functionp omit-list)
4054 (setq omit-list (funcall omit-list record layout)))
4055 (if (functionp order-list)
4056 (setq order-list (funcall order-list record layout)))
4057 ;; first omit unwanted fields
4058 (when (and omit-list (or (not order-list) (memq t order-list)))
4059 (if (listp omit-list)
4060 ;; show all fields except those listed here
4061 (dolist (omit omit-list)
4062 (setq all-fields (delq omit all-fields)))
4063 (setq all-fields nil))) ; show nothing
4064 ;; then order them
4065 (cond ((not order-list)
4066 (setq field-list all-fields))
4067 ((not (memq t order-list))
4068 (setq field-list order-list))
4069 (t
4070 (setq order-list (reverse order-list)
4071 all-fields (delq nil (mapcar (lambda (f)
4072 (unless (memq f order-list)
4073 f))
4074 all-fields)))
4075 (dolist (order order-list)
4076 (if (eq t order)
4077 (setq field-list (append all-fields field-list))
4078 (push order field-list)))))
4079 ;; call the actual format function
4080 (setq format-function
4081 (intern-soft (format "bbdb-display-record-%s" layout)))
4082 (if (functionp format-function)
4083 (funcall format-function record layout field-list)
4084 (bbdb-display-record-multi-line record layout field-list))
4085 (put-text-property beg (point) 'bbdb-record-number number))))
4086
4087(defun bbdb-display-records (records &optional layout append
4088 select horiz-p)
4089 "Display RECORDS using LAYOUT.
4090If APPEND is non-nil append RECORDS to the already displayed records.
4091Otherwise RECORDS overwrite the displayed records.
4092SELECT and HORIZ-P have the same meaning as in `bbdb-pop-up-window'."
4093 (interactive (list (bbdb-completing-read-records "Display records: ")
4094 (bbdb-layout-prefix)))
4095 (if (bbdb-append-display-p) (setq append t))
4096 ;; `bbdb-redisplay-record' calls `bbdb-display-records'
4097 ;; with display information already amended to RECORDS.
4098 (unless (or (null records)
4099 (consp (car records)))
4100 ;; add layout and a marker to the local list of records
4101 (setq layout (or layout bbdb-layout)
4102 records (mapcar (lambda (record)
4103 (list record layout (make-marker)))
4104 records)))
4105
4106 (let ((first-new (caar records)) ; first new record
4107 new-name)
4108
4109 ;; If `bbdb-multiple-buffers' is non-nil we create a new BBDB buffer
4110 ;; when not already within one. The new buffer name starts with a space,
4111 ;; i.e. it does not clutter the buffer list.
4112 (when (and bbdb-multiple-buffers
4113 (not (assq 'bbdb-buffer-name (buffer-local-variables))))
4114 (setq new-name (concat " *BBDB " (if (functionp bbdb-multiple-buffers)
4115 (funcall bbdb-multiple-buffers)
4116 (buffer-name))
4117 "*"))
4118 ;; `bbdb-buffer-name' becomes buffer-local in the current buffer
4119 ;; as well as in the buffer `bbdb-buffer-name'
4120 (set (make-local-variable 'bbdb-buffer-name) new-name))
4121
4122 (with-current-buffer (get-buffer-create bbdb-buffer-name) ; *BBDB*
4123 ;; If we are appending RECORDS to the ones already displayed,
4124 ;; then first remove any duplicates, and then sort them.
4125 (if append
4126 (let ((old-rec (mapcar 'car bbdb-records)))
4127 (dolist (record records)
4128 (unless (memq (car record) old-rec)
4129 (push record bbdb-records)))
4130 (setq records
4131 (sort bbdb-records
4132 (lambda (x y) (bbdb-record-lessp (car x) (car y)))))))
4133
4134 (bbdb-mode)
4135 ;; Normally `bbdb-records' is the only BBDB-specific buffer-local variable
4136 ;; in the *BBDB* buffer. It is intentionally not permanent-local.
4137 ;; A value of nil indicates that we need to (re)process the records.
4138 (setq bbdb-records records)
4139 (if new-name
4140 (set (make-local-variable 'bbdb-buffer-name) new-name))
4141
4142 (unless (or bbdb-silent-internal bbdb-silent)
4143 (message "Formatting BBDB..."))
4144 (let ((record-number 0)
4145 buffer-read-only all-records)
4146 (erase-buffer)
4147 (bbdb-debug (setq all-records (bbdb-records)))
4148 (dolist (record records)
4149 (bbdb-debug (unless (memq (car record) all-records)
4150 (error "Record %s does not exist" (car record))))
4151 (set-marker (nth 2 record) (point))
4152 (bbdb-display-record (nth 0 record) (nth 1 record) record-number)
4153 (setq record-number (1+ record-number)))
4154
4155 (run-hooks 'bbdb-display-hook))
4156
4157 (unless (or bbdb-silent-internal bbdb-silent)
4158 (message "Formatting BBDB...done."))
4159 (set-buffer-modified-p nil)
4160
4161 (bbdb-pop-up-window select horiz-p)
4162 (if (not first-new)
4163 (goto-char (point-min))
4164 ;; Put point on first new record in *BBDB* buffer.
4165 (goto-char (nth 2 (assq first-new bbdb-records)))
4166 (set-window-start (get-buffer-window (current-buffer)) (point))))))
4167
4168(defun bbdb-undisplay-records (&optional all-buffers)
4169 "Undisplay records in *BBDB* buffer, leaving this buffer empty.
4170If ALL-BUFFERS is non-nil undisplay records in all BBDB buffers."
4171 (dolist (buffer (cond (all-buffers (buffer-list))
4172 ((let ((buffer (get-buffer bbdb-buffer-name)))
4173 (and (buffer-live-p buffer) (list buffer))))))
4174 (with-current-buffer buffer
4175 (when (eq major-mode 'bbdb-mode)
4176 (let (buffer-read-only)
4177 (erase-buffer))
4178 (setq bbdb-records nil)
4179 (set-buffer-modified-p nil)))))
4180
4181(defun bbdb-redisplay-record (record &optional sort delete-p)
4182 "Redisplay RECORD in current BBDB buffer.
4183If SORT is t, usually because RECORD has a new sortkey, re-sort
4184the displayed records.
4185If DELETE-P is non-nil RECORD is removed from the BBDB buffer."
4186 ;; For deletion in the *BBDB* buffer we use the full information
4187 ;; about the record in the database. Therefore, we need to delete
4188 ;; the record in the *BBDB* buffer before deleting the record in
4189 ;; the database.
4190 ;; FIXME: If point is initially inside RECORD, `bbdb-redisplay-record'
4191 ;; puts point at the beginning of the redisplayed RECORD.
4192 ;; Ideally, `bbdb-redisplay-record' should put point such that it
4193 ;; matches the previous value `bbdb-ident-point'.
4194 (let ((full-record (assq record bbdb-records)))
4195 (unless full-record
4196 (error "Record `%s' not displayed" (bbdb-record-name record)))
4197 (if (and sort (not delete-p))
4198 ;; FIXME: For records requiring re-sorting it may be more efficient
4199 ;; to insert these records in their proper location instead of
4200 ;; re-displaying all records.
4201 (bbdb-display-records (list record) nil t)
4202 (let ((marker (nth 2 full-record))
4203 (end-marker (nth 2 (car (cdr (memq full-record bbdb-records)))))
4204 buffer-read-only record-number)
4205 ;; If point is inside record, put it at the beginning of the record.
4206 (if (and (<= marker (point))
4207 (< (point) (or end-marker (point-max))))
4208 (goto-char marker))
4209 (save-excursion
4210 (goto-char marker)
4211 (setq record-number (get-text-property (point) 'bbdb-record-number))
4212 (unless delete-p
4213 ;; First insert the reformatted record, then delete the old one,
4214 ;; so that the marker of this record cannot collapse with the
4215 ;; marker of the subsequent record
4216 (bbdb-display-record (car full-record) (nth 1 full-record)
4217 record-number))
4218 (delete-region (point) (or end-marker (point-max)))
4219 ;; If we deleted a record we need to update the subsequent
4220 ;; record numbers.
4221 (when delete-p
4222 (let* ((markers (append (mapcar (lambda (x) (nth 2 x))
4223 (cdr (memq full-record bbdb-records)))
4224 (list (point-max))))
4225 (start (pop markers)))
4226 (dolist (end markers)
4227 (put-text-property start end
4228 'bbdb-record-number record-number)
4229 (setq start end
4230 record-number (1+ record-number))))
4231 (setq bbdb-records (delq full-record bbdb-records)))
4232 (run-hooks 'bbdb-display-hook))))))
4233
4234(defun bbdb-redisplay-record-globally (record &optional sort delete-p)
4235 "Redisplay RECORD in all BBDB buffers.
4236If SORT is t, usually because RECORD has a new sortkey, re-sort
4237the displayed records.
4238If DELETE-P is non-nil RECORD is removed from the BBDB buffers."
4239 (dolist (buffer (buffer-list))
4240 (with-current-buffer buffer
4241 (if (and (eq major-mode 'bbdb-mode)
4242 (memq record (mapcar 'car bbdb-records)))
4243 (let ((window (get-buffer-window bbdb-buffer-name)))
4244 (if window
4245 (with-selected-window window
4246 (bbdb-redisplay-record record sort delete-p))
4247 (bbdb-redisplay-record record sort delete-p)))))))
4248(define-obsolete-function-alias 'bbdb-maybe-update-display
4249 'bbdb-redisplay-record-globally "3.0")
4250\f
4251
4252;;; window configuration hackery
4253(defun bbdb-pop-up-window (&optional select horiz-p)
4254 "Display *BBDB* buffer by popping up a new window.
4255Finds the largest window on the screen, splits it, displaying the
4256*BBDB* buffer in the bottom `bbdb-pop-up-window-size' lines (unless
4257the *BBDB* buffer is already visible, in which case do nothing.)
4258Select this window if SELECT is non-nil.
4259
4260If `bbdb-mua-pop-up' is 'horiz, and the first window matching
4261the predicate HORIZ-P is wider than the car of `bbdb-horiz-pop-up-window-size'
4262then the window will be split horizontally rather than vertically."
4263 (let ((buffer (get-buffer bbdb-buffer-name)))
4264 (unless buffer
4265 (error "No %s buffer to display" bbdb-buffer-name))
4266 (cond ((let ((window (get-buffer-window buffer t)))
4267 ;; We already have a BBDB window so that at most we select it
4268 (and window
4269 (or (not select) (select-window window)))))
4270
4271 ;; try horizontal split
4272 ((and (eq bbdb-mua-pop-up 'horiz)
4273 horiz-p
4274 (>= (frame-width) (car bbdb-horiz-pop-up-window-size))
4275 (let ((window-list (window-list))
4276 (b-width (cdr bbdb-horiz-pop-up-window-size))
4277 (search t) s-window)
4278 (while (and (setq s-window (pop window-list))
4279 (setq search (not (funcall horiz-p s-window)))))
4280 (unless (or search (<= (window-width s-window)
4281 (car bbdb-horiz-pop-up-window-size)))
4282 (condition-case nil ; `split-window' might fail
4283 (let ((window (split-window
4284 s-window
4285 (if (integerp b-width)
4286 (- (window-width s-window) b-width)
4287 (round (* (- 1 b-width) (window-width s-window))))
4288 t))) ; horizontal split
4289 (set-window-buffer window buffer)
4290 (cond (bbdb-dedicated-window
4291 (set-window-dedicated-p window bbdb-dedicated-window))
4292 ((fboundp 'display-buffer-record-window) ; GNU Emacs >= 24.1
4293 (set-window-prev-buffers window nil)
4294 (display-buffer-record-window 'window window buffer)))
4295 (if select (select-window window))
4296 t)
4297 (error nil))))))
4298
4299 ((eq t bbdb-pop-up-window-size)
4300 (bbdb-pop-up-window-simple buffer select))
4301
4302 (t ;; vertical split
4303 (let* ((window (selected-window))
4304 (window-height (window-height window)))
4305 ;; find the tallest window...
4306 (mapc (lambda (w)
4307 (let ((w-height (window-height w)))
4308 (if (> w-height window-height)
4309 (setq window w window-height w-height))))
4310 (window-list))
4311 (condition-case nil
4312 (progn
4313 (unless (eql bbdb-pop-up-window-size 1.0)
4314 (setq window (split-window ; might fail
4315 window
4316 (if (integerp bbdb-pop-up-window-size)
4317 (- window-height 1 ; for mode line
4318 (max window-min-height bbdb-pop-up-window-size))
4319 (round (* (- 1 bbdb-pop-up-window-size)
4320 window-height))))))
4321 (set-window-buffer window buffer) ; might fail
4322 (cond (bbdb-dedicated-window
4323 (set-window-dedicated-p window bbdb-dedicated-window))
4324 ((and (fboundp 'display-buffer-record-window) ; GNU Emacs >= 24.1
4325 (not (eql bbdb-pop-up-window-size 1.0)))
4326 (set-window-prev-buffers window nil)
4327 (display-buffer-record-window 'window window buffer)))
4328 (if select (select-window window)))
4329 (error (bbdb-pop-up-window-simple buffer select))))))))
4330
4331(defun bbdb-pop-up-window-simple (buffer select)
4332 "Display BUFFER in some window, selecting it if SELECT is non-nil.
4333If `bbdb-dedicated-window' is non-nil, mark the window as dedicated."
4334 (let ((window (if select
4335 (progn (pop-to-buffer buffer)
4336 (get-buffer-window))
4337 (display-buffer buffer))))
4338 (if bbdb-dedicated-window
4339 (set-window-dedicated-p window bbdb-dedicated-window))))
4340
4341\f
4342;;; BBDB mode
4343
4344;;;###autoload
4345(define-derived-mode bbdb-mode special-mode "BBDB"
4346 "Major mode for viewing and editing the Insidious Big Brother Database.
4347Letters no longer insert themselves. Numbers are prefix arguments.
4348You can move around using the usual cursor motion commands.
4349\\<bbdb-mode-map>
4350\\[bbdb-add-mail-alias]\t Add new mail alias to visible records or \
4351remove it.
4352\\[bbdb-edit-field]\t Edit the field on the current line.
4353\\[bbdb-delete-field-or-record]\t Delete the field on the \
4354current line. If the current line is the\n\t first line of a record, then \
4355delete the entire record.
4356\\[bbdb-insert-field]\t Insert a new field into the current record. \
4357Note that this\n\t will let you add new fields of your own as well.
4358\\[bbdb-transpose-fields]\t Swap the field on the current line with the \
4359previous field.
4360\\[bbdb-dial]\t Dial the current phone field.
4361\\[bbdb-next-record], \\[bbdb-prev-record]\t Move to the next or the previous \
4362displayed record, respectively.
4363\\[bbdb-create]\t Create a new record.
4364\\[bbdb-toggle-records-layout]\t Toggle whether the current record is displayed in a \
4365one-line\n\t listing, or a full multi-line listing.
4366\\[bbdb-do-all-records]\\[bbdb-toggle-records-layout]\t Do that \
4367for all displayed records.
4368\\[bbdb-merge-records]\t Merge the contents of the current record with \
4369some other, and then\n\t delete the current record.
4370\\[bbdb-omit-record]\t Remove the current record from the display without \
4371deleting it from\n\t the database. This is often a useful thing to do \
4372before using one\n\t of the `*' commands.
4373\\[bbdb]\t Search for records in the database (on all fields).
4374\\[bbdb-search-mail]\t Search for records by mail address.
4375\\[bbdb-search-organization]\t Search for records by organization.
4376\\[bbdb-search-xfields]\t Search for records by xfields.
4377\\[bbdb-search-name]\t Search for records by name.
4378\\[bbdb-search-changed]\t Display records that have changed since the database \
4379was saved.
4380\\[bbdb-mail]\t Compose mail to the person represented by the \
4381current record.
4382\\[bbdb-do-all-records]\\[bbdb-mail]\t Compose mail \
4383to everyone whose record is displayed.
4384\\[bbdb-save]\t Save the BBDB file to disk.
4385\\[bbdb-tex]\t Create a TeX listing of the current record.
4386\\[bbdb-do-all-records]\\[bbdb-tex]\t Do that for all \
4387displayed record.
4388\\[other-window]\t Move to another window.
4389\\[bbdb-info]\t Read the Info documentation for BBDB.
4390\\[bbdb-help]\t Display a one line command summary in the echo area.
4391\\[bbdb-browse-url]\t Visit Web sites listed in the `url' field(s) of the current \
4392record.
4393
4394For address completion using the names and mail addresses in the database:
4395\t in Mail mode, type \\<mail-mode-map>\\[bbdb-complete-mail].
4396\t in Message mode, type \\<message-mode-map>\\[bbdb-complete-mail].
4397
4398Important variables:
4399\t `bbdb-auto-revert'
4400\t `bbdb-ignore-redundant-mails'
4401\t `bbdb-case-fold-search'
4402\t `bbdb-completion-list'
4403\t `bbdb-default-area-code'
4404\t `bbdb-default-domain'
4405\t `bbdb-layout'
4406\t `bbdb-file'
4407\t `bbdb-phone-style'
4408\t `bbdb-check-auto-save-file'
4409\t `bbdb-pop-up-layout'
4410\t `bbdb-pop-up-window-size'
4411\t `bbdb-add-name'
4412\t `bbdb-add-aka'
4413\t `bbdb-add-mails'
4414\t `bbdb-new-mails-primary'
4415\t `bbdb-read-only'
4416\t `bbdb-mua-pop-up'
4417\t `bbdb-user-mail-address-re'
4418
4419There are numerous hooks. M-x apropos ^bbdb.*hook RET
4420
4421\\{bbdb-mode-map}"
4422 (setq truncate-lines t
4423 default-directory (file-name-directory bbdb-file)
4424 mode-line-buffer-identification
4425 (list 24 (buffer-name) " "
4426 '(:eval (format "%d/%d/%d"
4427 (1+ (or (get-text-property
4428 (point) 'bbdb-record-number) -1))
4429 (length bbdb-records)
4430 ;; This code gets called a lot.
4431 ;; So we keep it as simple as possible.
4432 (with-current-buffer bbdb-buffer
4433 (length bbdb-records))))
4434 '(:eval (concat " "
4435 (bbdb-concat " " (elt bbdb-modeline-info 0)
4436 (elt bbdb-modeline-info 2)
4437 (elt bbdb-modeline-info 4)))))
4438 mode-line-modified
4439 ;; For the mode-line we want to be fast. So we skip the checks
4440 ;; performed by `bbdb-with-db-buffer'.
4441 '(:eval (if (buffer-modified-p bbdb-buffer)
4442 (if bbdb-read-only "%*" "**")
4443 (if bbdb-read-only "%%" "--"))))
4444 ;; `bbdb-revert-buffer' acts on `bbdb-buffer'. Yet this command is usually
4445 ;; called from the *BBDB* buffer.
4446 (set (make-local-variable 'revert-buffer-function)
4447 'bbdb-revert-buffer)
4448 (add-hook 'post-command-hook 'force-mode-line-update nil t))
4449
4450\f
4451
4452(defun bbdb-sendmail-menu (record)
4453 "Menu items for email addresses of RECORD."
4454 (let ((mails (bbdb-record-mail record)))
4455 (list
4456 (if (cdr mails)
4457 ;; Submenu for multiple mail addresses
4458 (cons "Send mail to..."
4459 (mapcar (lambda (address)
4460 (vector address `(bbdb-compose-mail
4461 ,(bbdb-dwim-mail record address))
4462 t))
4463 mails))
4464 ;; Single entry for single mail address
4465 (vector (concat "Send mail to " (car mails))
4466 `(bbdb-compose-mail ,(bbdb-dwim-mail record (car mails)))
4467 t)))))
4468
4469(defun bbdb-field-menu (record field)
4470 "Menu items specifically for FIELD of RECORD."
4471 (let ((type (car field)))
4472 (append
4473 (list
4474 (format "Commands for %s Field:"
4475 (cond ((eq type 'xfields)
4476 (format "\"%s\"" (symbol-name (car (nth 1 field)))))
4477 ((eq type 'name) "Name")
4478 ((eq type 'affix) "Affix")
4479 ((eq type 'organization) "Organization")
4480 ((eq type 'aka) "Alternate Names")
4481 ((eq type 'mail) "Mail Addresses")
4482 ((memq type '(address phone))
4483 (format "\"%s\" %s" (aref (nth 1 field) 0)
4484 (capitalize (symbol-name type)))))))
4485 (cond ((eq type 'phone)
4486 (list (vector (concat "Dial " (bbdb-phone-string (nth 1 field)))
4487 `(bbdb-dial ',field nil) t)))
4488 ((eq type 'xfields)
4489 (let* ((field (cadr field))
4490 (type (car field)))
4491 (cond ((eq type 'url )
4492 (list (vector (format "Browse \"%s\"" (cdr field))
4493 `(bbdb-browse-url ,record) t)))))))
4494 '(["Edit Field" bbdb-edit-field t])
4495 (unless (eq type 'name)
4496 '(["Delete Field" bbdb-delete-field-or-record t])))))
4497
4498(defun bbdb-insert-field-menu (record)
4499 "Submenu for inserting a new field for RECORD."
4500 (cons "Insert New Field..."
4501 (mapcar
4502 (lambda (field)
4503 (if (stringp field) field
4504 (vector (symbol-name field)
4505 `(bbdb-insert-field
4506 ,record ',field (bbdb-read-field ,record ',field
4507 ,current-prefix-arg))
4508 (not (or (and (eq field 'affix) (bbdb-record-affix record))
4509 (and (eq field 'organization)
4510 (bbdb-record-organization record))
4511 (and (eq field 'mail) (bbdb-record-mail record))
4512 (and (eq field 'aka) (bbdb-record-aka record))
4513 (assq field (bbdb-record-xfields record)))))))
4514 (append '(affix organization aka phone address mail)
4515 '("--") bbdb-xfield-label-list))))
4516
4517(defun bbdb-mouse-menu (event)
4518 "BBDB mouse menu for EVENT,"
4519 (interactive "e")
4520 (mouse-set-point event)
4521 (let* ((record (bbdb-current-record))
4522 (field (bbdb-current-field))
4523 (menu (if (and record field (functionp bbdb-user-menu-commands))
4524 (funcall bbdb-user-menu-commands record field)
4525 bbdb-user-menu-commands)))
4526 (if record
4527 (popup-menu
4528 (append
4529 (list
4530 (format "Commands for record \"%s\":" (bbdb-record-name record))
4531 ["Delete Record" bbdb-delete-records t]
4532 ["Toggle Record Display Layout" bbdb-toggle-records-layout t]
4533 (if (and (not (eq 'full-multi-line
4534 (nth 1 (assq record bbdb-records))))
4535 (bbdb-layout-get-option 'multi-line 'omit))
4536 ["Fully Display Record" bbdb-display-records-completely t])
4537 ["Omit Record" bbdb-omit-record t]
4538 ["Merge Record" bbdb-merge-records t])
4539 (if (bbdb-record-mail record)
4540 (bbdb-sendmail-menu record))
4541 (list "--" (bbdb-insert-field-menu record))
4542 (if field
4543 (cons "--" (bbdb-field-menu record field)))
4544 (if menu
4545 (append '("--" "User Defined Commands") menu)))))))
4546
4547\f
4548
4549(defun bbdb-scan-property (property predicate n)
4550 "Scan for change of PROPERTY matching PREDICATE for N times.
4551Return position of beginning of matching interval."
4552 (let ((fun (if (< 0 n) 'next-single-property-change
4553 'previous-single-property-change))
4554 (limit (if (< 0 n) (point-max) (point-min)))
4555 (nn (abs n))
4556 (i 0)
4557 (opoint (point))
4558 npoint)
4559 ;; For backward search, move point to beginning of interval with PROPERTY.
4560 (if (and (<= n 0)
4561 (< (point-min) opoint)
4562 (let ((prop (get-text-property opoint property)))
4563 (and (eq prop (get-text-property (1- opoint) property))
4564 (funcall predicate prop))))
4565 (setq opoint (previous-single-property-change opoint property nil limit)))
4566 (if (zerop n)
4567 opoint ; Return beginning of interval point is in
4568 (while (and (< i nn)
4569 (let (done)
4570 (while (and (not done)
4571 (setq npoint (funcall fun opoint property nil limit)))
4572 (cond ((and (/= opoint npoint)
4573 (funcall predicate (get-text-property
4574 npoint property)))
4575 (setq opoint npoint done t))
4576 ((= opoint npoint)
4577 ;; Search reached beg or end of buffer: abort.
4578 (setq done t i nn npoint nil))
4579 (t (setq opoint npoint))))
4580 done))
4581 (setq i (1+ i)))
4582 npoint)))
4583
4584(defun bbdb-next-record (n)
4585 "Move point to the beginning of the next BBDB record.
4586With prefix N move forward N records."
4587 (interactive "p")
4588 (let ((npoint (bbdb-scan-property 'bbdb-record-number 'integerp n)))
4589 (if npoint (goto-char npoint)
4590 (error "No %s record" (if (< 0 n) "next" "previous")))))
4591
4592(defun bbdb-prev-record (n)
4593 "Move point to the beginning of the previous BBDB record.
4594With prefix N move backwards N records."
4595 (interactive "p")
4596 (bbdb-next-record (- n)))
4597
4598(defun bbdb-next-field (n)
4599 "Move point to next (sub)field.
4600With prefix N move forward N (sub)fields."
4601 (interactive "p")
4602 (let ((npoint (bbdb-scan-property
4603 'bbdb-field
4604 (lambda (p) (and (nth 1 p)
4605 (not (eq (nth 2 p) 'field-label))))
4606 n)))
4607 (if npoint (goto-char npoint)
4608 (error "No %s field" (if (< 0 n) "next" "previous")))))
4609
4610(defun bbdb-prev-field (n)
4611 "Move point to previous (sub)field.
4612With prefix N move backwards N (sub)fields."
4613 (interactive "p")
4614 (bbdb-next-field (- n)))
4615
4616(defun bbdb-save (&optional prompt noisy)
4617 "Save the BBDB if it is modified.
4618If PROMPT is non-nil prompt before saving.
4619If NOISY is non-nil as in interactive calls issue status messages."
4620 (interactive (list nil t))
4621 (bbdb-with-db-buffer
4622 (if (buffer-modified-p)
4623 (if (or (not prompt)
4624 (y-or-n-p
4625 (if bbdb-read-only
4626 "Save the BBDB, even though it is supposedly read-only? "
4627 "Save the BBDB now? ")))
4628 (save-buffer))
4629 (if noisy (message "(No BBDB changes need to be saved)")))))
4630
4631;;;###autoload
4632(defun bbdb-version (&optional arg)
4633 "Return string describing the version of BBDB.
4634With prefix ARG, insert string at point."
4635 (interactive (list (or (and current-prefix-arg 1) t)))
4636 (let* ((version
4637 (if (string-match "\\`[ \t\n]*[1-9]" bbdb-version)
4638 bbdb-version
4639 (let ((source (find-function-noselect 'bbdb-version)))
4640 (if source
4641 (with-current-buffer (car source)
4642 (prog1 (save-excursion
4643 (goto-char (point-min))
4644 (when (re-search-forward
4645 "^;;+ *Version: \\(.*\\)" nil t)
4646 (match-string-no-properties 1)))
4647 (unless (get-buffer-window nil t)
4648 (kill-buffer (current-buffer)))))))))
4649 (version-string (format "BBDB version %s" (or version "<unknown>"))))
4650 (cond ((numberp arg) (insert (message version-string)))
4651 ((eq t arg) (message version-string))
4652 (t version-string))))
4653
4654\f
4655
4656(defun bbdb-sort-records ()
4657 "Sort BBDB database.
4658This is not needed when using BBDB itself. It might be necessary,
4659however, after having used other programs to add records to the BBDB."
4660 (interactive)
4661 (let* ((records (copy-sequence (bbdb-records))))
4662 (bbdb-with-db-buffer
4663 (setq bbdb-records (sort bbdb-records 'bbdb-record-lessp))
4664 (if (equal records bbdb-records)
4665 (message "BBDB already sorted properly")
4666 (message "BBDB was mis-sorted; fixing...")
4667 (bbdb-goto-first-record)
4668 (delete-region (point) bbdb-end-marker)
4669 (let ((buf (current-buffer))
4670 (inhibit-quit t) ; really, don't mess with this
4671 cache)
4672 (dolist (record bbdb-records)
4673 ;; Before printing the record, remove cache (we do not want that
4674 ;; written to the file.) Ater writing, put the cache back
4675 ;; and update the cache's marker.
4676 (setq cache (bbdb-record-cache record))
4677 (set-marker (bbdb-cache-marker cache) (point))
4678 (bbdb-record-set-cache record nil)
4679 (bbdb-with-print-loadably (prin1 record buf))
4680 (bbdb-record-set-cache record cache)
4681 (insert ?\n)))
4682 (dolist (buffer (buffer-list))
4683 (with-current-buffer buffer
4684 (if (eq major-mode 'bbdb-mode)
4685 ; Redisplay all records
4686 (bbdb-display-records nil nil t))))
4687 (message "BBDB was mis-sorted; fixing...done")))))
4688
4689\f
4690
4691;;;###autoload
4692(defun bbdb-initialize (&rest muas)
4693 "Initialize BBDB for MUAS and miscellaneous packages.
4694List MUAS may include the following symbols to initialize the respective
4695mail/news readers, composers, and miscellaneous packages:
4696 gnus Gnus mail/news reader.
4697 mh-e MH-E mail reader.
4698 mu4e Mu4e mail reader.
4699 rmail Rmail mail reader.
4700 vm VM mail reader.
4701 mail Mail (M-x mail).
4702 message Message mode.
4703 wl Wanderlust mail reader.
4704
4705 anniv Anniversaries in Emacs diary.
4706
4707 sc Supercite. However, this is not the full story.
4708 See bbdb-sc.el for how to fully hook BBDB into Supercite.
4709
4710 pgp PGP support: this adds `bbdb-pgp' to `message-send-hook'
4711 and `mail-send-hook' so that `bbdb-pgp' runs automatically
4712 when a message is sent.
4713 Yet see info node `(message)Signing and encryption'
4714 why you might not want to rely for encryption on a hook
4715 function which runs just before the message is sent,
4716 that is, you might want to call the command `bbdb-pgp' manually,
4717 then call `mml-preview'.
4718
4719See also `bbdb-mua-auto-update-init'. The latter is a separate function
4720as this allows one to initialize the auto update feature for some MUAs only,
4721for example only for outgoing messages."
4722 (dolist (mua muas)
4723 (let ((init (assq mua bbdb-init-forms)))
4724 (if init
4725 ;; Should we make sure that each insinuation happens only once?
4726 (eval (cadr init))
4727 (bbdb-warn "Do not know how to insinuate `%s'" mua))))
4728 (run-hooks 'bbdb-initialize-hook))
4729
4730\f
4731(provide 'bbdb)
4732
4733;;; bbdb.el ends here