[emacs] manually add bbdb into lisp/bbdb/
[~bandali/configs] / lisp / bbdb / bbdb.el
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.
160 When this is non-nil, it should be a file name.
161 When BBDB reads `bbdb-file', it also checks this file,
162 and if it is newer than `bbdb-file', it loads this file.
163 When BBDB writes `bbdb-file', it also writes this file.
164
165 This feature allows one to keep the database in one place while using
166 different 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.
173 When 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'.
179 If you have more than one Emacs running at the same time, you might want
180 to 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.
187 If t and `bbdb-file' has changed on disk, while the database
188 has not been modified inside Emacs, revert the database automatically.
189 If nil or the database has been changed inside Emacs, always query
190 before 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.
197 If 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.
214 Run with one argument, the new record. This is called before the record is
215 added to the database, followed by a call of `bbdb-change-hook'.
216
217 If a record has been created by analyzing a mail message, hook functions
218 can use the variable `bbdb-update-records-address' to determine the header
219 and 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.
225 Run with one argument, the record. This is called before the database
226 is modified. If a new bbdb record is created, `bbdb-create-hook' is called
227 first, 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.
233 This function is called when loading a record into BBDB that has the same uuid
234 as an exisiting record. If nil use `bbdb-merge-records'.
235 This function should take two arguments RECORD1 and RECORD2, with RECORD2
236 being the already existing record. It should merge RECORD1 into RECORD2,
237 and 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'.
243 This 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.
249 Run with one argument, the record. This is called after the database
250 is modified. So if you want to modify a record when it is created or changed,
251 use 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.
257 Note 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.
273 Be very very certain you want to set this to t, because it will suppress
274 queries to alter record names, assign names to addresses, etc.
275 Lisp 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).
291 If it is an integer number, it is the number of lines used by BBDB.
292 If it is a fraction between 0.0 and 1.0 (inclusive), it is the fraction
293 of the tallest existing window that BBDB will take over.
294 If it is t use `display-buffer'/`pop-to-buffer' to create the BBDB window.
295 See 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.
302 Allowed values include nil (not dedicated) 'bbdb (weakly dedicated)
303 and 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.
322 The format of an element is (LAYOUT-NAME OPTION-ALIST).
323
324 By 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
328 OPTION-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
351 When you add a new layout FOO, you can write a corresponding layout
352 function `bbdb-display-record-layout-FOO'. If you do not write your own
353 layout 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.
430 This variable lets the case-sensitivity of the BBDB commands
431 be 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.
437 If first-last names are displayed as \"Firstname Lastname\".
438 If last-first names are displayed as \"Lastname, Firstname\".
439 This can be overriden per record via the xfield name-format,
440 which should take the same values.
441 See 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.
460 Each rule is a list (IDENTIFIER EDIT FORMAT FORMAT).
461 The first rule for which IDENTIFIER matches an address is used for editing
462 and formatting the address.
463
464 IDENTIFIER may be a list of countries.
465 IDENTIFIER may also be a function that is called with one arg, the address
466 to be used. The rule applies if the function returns non-nil.
467 See `bbdb-address-continental-p' for an example.
468 If IDENTIFIER is t, this rule always applies. Usually, this should be
469 the last rule that becomes a fall-back (default).
470
471 EDIT may be a function that is called with one argument, the address.
472 See `bbdb-edit-address-default' for an example.
473
474 EDIT may also be an editting format string. It is a string containing
475 the five letters s, c, p, S, and C that specify the order for editing
476 the five elements of an address:
477
478 s streets
479 c city
480 p postcode
481 S state
482 C country
483
484 The first FORMAT of each rule is used for multi-line layout, the second FORMAT
485 is used for one-line layout.
486
487 FORMAT may be a function that is called with one argument, the address.
488 See `bbdb-format-address-default' for an example.
489
490 FORMAT may also be a format string. It consists of formatting elements
491 separated by a delimiter defined via the first (and last) character of FORMAT.
492 Each 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
500 A formatting element will be applied only if the corresponding part
501 of the address is a non-empty string.
502
503 See 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.
518 Used by address format identifier `bbdb-address-continental-p'.
519 The regexp should match postcodes of the form CH-8052, NL-2300RA,
520 and 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).
526 This is used for fields which do not have an entry in `bbdb-separator-alist'.
527 Whitespace 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.
541 Each element is of the form (FIELD SPLIT-RE JOIN).
542 Whitespace surrounding SPLIT-RE is ignored.
543 For 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.
549 This should be a list of menu entries.
550 When set to a function, it is called with two arguments RECORD and FIELD
551 and it should either return nil or a list of menu entries.
552 Used 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.
563 You can also set this to a function returning a buffer name.
564 Here 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.
572 If a symbol this should be an xfield holding the name of the image file
573 associated with the record. If it is `name' or `fl-name', the first and last
574 name of the record are used as file name. If it is `lf-name', the last and
575 first name of the record are used as file name.
576 If a function it is called with one arg, the record, and it should return
577 the name of the image file.
578 The file is searched in the directories in `bbdb-image-path'.
579 File name suffixes are appended according to `bbdb-image-suffixes'.
580 See `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'.
598 If it is 'first-last read first and last name separately.
599 If it is 'last-first read last and first name separately.
600 With any other value read full name at once.
601 See 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.
612 Used to enhance dividing name strings into firstname and lastname parts.
613 Case 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.
623 Its 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.
630 Used to dividing name strings into firstname and lastname parts.
631 All 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.
641 Its 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.
647 If a mail address does not contain `[@%!]', append @`bbdb-default-domain' to it.
648
649 The address is not altered if `bbdb-default-domain' is nil
650 or 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.
657 The value 'nanp refers to the North American Numbering Plan.
658 The value nil refers to a free-style numbering plan.
659
660 You can have both styles of phone number in your database by providing a
661 prefix 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.
668 This 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.
682 In 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.
709 The 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.
733 Whether 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'.
744 This is a cons pair (WITHOUT-PREFIX . WITH-PREFIX).
745 The car is used if the command is called without a prefix.
746 The cdr is used if the command is called with a prefix.
747
748 WITHOUT-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
761 Any 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.
771 This 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
779 Any 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.
785 This 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
794 Any 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.
800 This is a cons pair (WITHOUT-PREFIX . WITH-PREFIX).
801 The car is used if the command is called without a prefix.
802 The cdr is used if the command is called with a prefix (and if the prefix
803 is not used for another purpose).
804
805 WITHOUT-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
837 Allowed 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
852 To initiate auto-updating of BBDB records, call `bbdb-mua-auto-update-init'
853 for 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.
864 These functions can select messages for further processing by BBDB,
865 The amount of subsequent processing is determined by `bbdb-update-records-p'.
866
867 Allowed values are (here ADDRESS is an email address selected
868 by `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.
893 Each element is of the form
894
895 (CLASS HEADER ...)
896
897 The symbol CLASS defines a class of headers.
898 The 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.
904 Otherwise 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.
910 Several BBDB commands extract either the sender or the recipients' email
911 addresses from a message according to `bbdb-message-headers'. If BBDB does not
912 find any email address in this subset of message headers (for example, because
913 an email address is excluded because of `bbdb-user-mail-address-re')
914 but `bbdb-message-try-all-headers' is t, then these commands will also consider
915 the 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.
921 The format of this alist is
922 ((HEADER-NAME . REGEXP) ...)
923 For example, if
924 ((\"From\" . \"@.*\\.maximegalon\\.edu\")
925 (\"Subject\" . \"time travel\"))
926 BBDB records are only created for messages sent by people at Maximegalon U.,
927 or people posting about time travel.
928 If t accept all messages. If nil do not accept any messages.
929
930 See 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.
938 The format of this alist is
939 ((HEADER-NAME . REGEXP) ... )
940 For example, if
941 ((\"From\" . \"mailer-daemon\")
942 ((\"To\" \"CC\") . \"mailing-list-1\\\\|mailing-list-2\"))
943 no BBDB records are created for messages from any mailer daemon,
944 or messages sent to or CCed to either of two mailing lists.
945 If t ignore all messages. If nil do not ignore any messages.
946
947 See 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.
958 Several BBDB commands extract either the sender or the recipients' email
959 addresses from a message according to `bbdb-message-headers'. Yet an email
960 address will be ignored if it matches `bbdb-user-mail-address-re'. This way
961 the commands will not operate on your own record.
962 See 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.
968 This handles messages where the real name differs from the name
969 in a BBDB record with the same mail address, as in \"John Smith <jqs@frob.com>\"
970 versus \"John Q. Smith <jqs@frob.com>\".
971 Allowed 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.
981 See 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.
992 Allowed 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.
1000 See 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.
1010 This handles messages where the mail address differs from the mail addresses
1011 in a BBDB record with the same name as in \"John Q. Smith <jqs@foo.com>\"
1012 versus \"John Q. Smith <jqs@bar.com>\".
1013 Allowed 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.
1023 See 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.
1034 A new mail address may either become the new primary mail address,
1035 when it is put at the beginning of the list of mail addresses.
1036 Or the new mail address is added at the end of the list of mail addresses.
1037 Allowed 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.
1045 See 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.
1055 When BBDB \"notices\" a message, the corresponding mail addresses are passed
1056 to this function first. It acts as a kind of \"filter\" to transform
1057 the mail addresses before they are compared against or added to the database.
1058 See `bbdb-canonicalize-mail-1' for a more complete example.
1059 If this function returns nil, BBDB assumes that there is no mail address.
1060
1061 See 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.
1067 For example, \"foo@bar.baz.com\" is redundant w.r.t. \"foo@baz.com\".
1068 This affects two things, whether a new redundant mail address is added
1069 to BBDB and whether an old mail address, which has become redundant
1070 because of a newly added mail address, is removed from BBDB.
1071
1072 Allowed 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.
1082 See 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.
1095 It 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.
1107 This means that the mail address in a message belongs to an existing BBDB record
1108 or to a record BBDB has created for the mail address.
1109
1110 Run with one argument, the record. It is up to the hook function
1111 to determine which MUA is used and to act appropriately.
1112 Hook functions can use the variable `bbdb-update-records-address'
1113 to determine the header and class of the mail address according
1114 to `bbdb-message-headers'. See `bbdb-auto-notes' for how to annotate records
1115 using `bbdb-update-records-address' and the headers of a mail message.
1116
1117 If a message contains multiple mail addresses belonging to one BBDB record,
1118 this hook is run for each mail address. Use `bbdb-notice-record-hook'
1119 if 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.
1125 This means that one of the mail addresses in a message belongs to an existing
1126 record or it is a record BBDB has created for the mail address. If a message
1127 contains multiple mail addresses belonging to one BBDB record, this hook
1128 is nonetheless run only once. Use `bbdb-notice-mail-hook' if you want to run
1129 a hook function for each mail address in a message.
1130
1131 Hook 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.
1152 This automatically annotates the BBDB record of the sender or recipient
1153 of a message based on the value of a header such as the Subject header.
1154 This requires that `bbdb-notice-mail-hook' contains `bbdb-auto-notes'
1155 and that the record already exists or `bbdb-update-records-p' returns such that
1156 the record will be created. Messages matching `bbdb-auto-notes-ignore-messages'
1157 are ignored.
1158
1159 The elements of this list are
1160
1161 (MUA FROM-TO HEADER ANNOTATE ...)
1162 (FROM-TO HEADER ANNOTATE ...)
1163 (HEADER ANNOTATE ...)
1164
1165 MUA is the active MUA or a list of MUAs (see `bbdb-mua').
1166 If MUA is missing or t, use this rule for all MUAs.
1167
1168 FROM-TO is a list of headers and/or header classes as in `bbdb-message-headers'.
1169 The record corresponding to a mail address of a message is considered for
1170 annotation if this mail address was found in a header matching FROM-TO.
1171 If FROM-TO is missing or t, records for each mail address are considered
1172 irrespective of where the mail address was found in a message.
1173
1174 HEADER is a message header that is considered for generating the annotation.
1175
1176 ANNOTATE 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
1182 REGEXP must match the value of HEADER for generating an annotation.
1183 However, if the value of HEADER also matches an element of
1184 `bbdb-auto-notes-ignore-headers' no annotation is generated.
1185
1186 The annotation will be added to FIELD of the respective record.
1187 FIELD defaults to `bbdb-default-xfield'.
1188
1189 STRING defines a replacement for the match of REGEXP in the value of HEADER.
1190 It may contain \\& or \\N specials used by `replace-match'.
1191 The resulting string becomes the annotation.
1192 If STRING is an integer N, the Nth matching subexpression is used.
1193 If STRING is a function, it will be called with one arg, the value of HEADER.
1194 The return value (which must be a string) is then used.
1195
1196 If REPLACE is t, the resulting string replaces the old contents of FIELD.
1197 If it is nil, the string is appended to the contents of FIELD (unless the
1198 annotation is already part of the content of field).
1199
1200 For example,
1201
1202 ((\"To\" (\"-vm@\" . \"VM mailing list\"))
1203 (\"Subject\" (\"sprocket\" . \"mail about sprockets\")
1204 (\"you bonehead\" . \"called me a bonehead\")))
1205
1206 will cause the text \"VM mailing list\" to be added to the notes field
1207 of the records corresponding to anyone you get mail from via one of the VM
1208 mailing lists.
1209
1210 If multiple clauses match the message, all of the corresponding strings
1211 will be added.
1212
1213 See also variables `bbdb-auto-notes-ignore-messages' and
1214 `bbdb-auto-notes-ignore-headers'.
1215
1216 For speed-up, the function `bbdb-auto-notes' actually use expanded rules
1217 stored in the internal variable `bbdb-auto-notes-rules-expanded'.
1218 If you change the value of `bbdb-auto-notes-rules' outside of customize,
1219 set `bbdb-auto-notes-rules-expanded' to nil, so that the expanded rules
1220 will 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'.
1251 The 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.
1264 See 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'.
1272 Each element is of the form
1273
1274 (HEADER . REGEXP)
1275
1276 For example,
1277
1278 (\"Organization\" . \"^Gatewayed from\\\\\|^Source only\")
1279
1280 will exclude the phony `Organization:' headers in GNU mailing-lists
1281 gatewayed to gnu.* newsgroups.
1282 See 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.
1290 If 'horiz, stack the window horizontally if there is room.
1291 If this is nil, BBDB is updated silently.
1292
1293 See 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).
1302 If it is an integer number, it is the number of lines used by BBDB.
1303 If it is a fraction between 0.0 and 1.0 (inclusive), it is the fraction
1304 of the tallest existing window that BBDB will take over.
1305 If it is t use `pop-to-buffer' to create the BBDB window.
1306 See 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).
1313 It is a cons pair (TOTAL . BBDB-SIZE).
1314 The window that will be considered for horizontal splitting must have
1315 at least TOTAL columns. BBDB-SIZE is the horizontal size of the BBDB window.
1316 If it is an integer number, it is the number of columns used by BBDB.
1317 If it is a fraction between 0 and 1, it is the fraction of the
1318 window 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.
1329 If an xfield is not in the alist, it is assigned weight 100, so all xfields
1330 with weights less then 100 will be in the beginning, and all xfields with
1331 weights 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.
1340 Each element is of the form (LABEL . MERGE-FUN).
1341 For 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'.
1352 For the RECORD matching the address of a message, `bbdb-mua-summary-unify'
1353 returns the first non-empty field value matching an element FIELD from this list.
1354 Each element FIELD may be a valid argument of `bbdb-record-field' for RECORD.
1355 In 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
1359 These provide a fallback if a message does not have a matching RECORD
1360 or 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.
1366 This may also be a function, called with one arg, the record, which should
1367 return the mark. See `bbdb-mua-summary-mark' and `bbdb-mua-summary-unify'.
1368 See 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.
1374 If nil do not mark message addresses known to BBDB.
1375 See `bbdb-mua-summary-mark' and `bbdb-mua-summary-unify'.
1376 See 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.
1383 For 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\".
1385 For VM, combine it with the %U specifier in `vm-summary-format' (see there),
1386 for example, use \"%n %*%a %-17.17UB %-3.3m %2d %4l/%-5c %I\\\"%s\\\"\\n\".
1387 This customization of `gnus-summary-line-format' / `vm-summary-format'
1388 is required to use `bbdb-mua-summary-unify'.
1389 Currently 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.
1395 For 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\".
1397 For VM, combine it with the %U specifier in `vm-summary-format' (see there),
1398 for example, use \"%n %*%a %Ub%-17.17F %-3.3m %2d %4l/%-5c %I\\\"%s\\\"\\n\".
1399 This customization of `gnus-summary-line-format' / `vm-summary-format'
1400 is required to use `bbdb-mua-summary-mark'.
1401 Currently 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.
1409 Allowed 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.
1431 If first-last format names as \"Firstname Lastname\".
1432 If last-first format names as \"Lastname, Firstname\".
1433 If `bbdb-mail-name' returns the full name as a single string, this takes
1434 precedence over `bbdb-mail-name-format'. Likewise, if the mail address itself
1435 includes 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.
1442 This may also be a function taking one argument, a record.
1443 If it returns the full mail name as a single string, this is used \"as is\".
1444 If it returns a cons pair (FIRST . LAST) with the first and last name
1445 for 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.
1452 Used 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.
1458 first: Generate one alias \"<alias>\" that expands to the first mail address
1459 of a record.
1460 star: Generate a second alias \"<alias>*\" that expands to all mail addresses
1461 of a record.
1462 all: 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.
1472 If non-nil do not use full name in mail address when same as mail.
1473 If 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'.
1486 If 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)
1493 If t, completion is done for all of the above.
1494 If 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.
1521 The function is called with two args the alias and the list
1522 of 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.
1540 If this is non-nil, it should be an alist of
1541 \(PREFIX . REPLACEMENT) elements. The first part of a phone number
1542 matching the regexp returned by evaluating PREFIX will be replaced by
1543 the corresponding REPLACEMENT when dialing."
1544 :group 'bbdb-utilities-dialing
1545 :type 'sexp)
1546
1547 (defcustom bbdb-dial-local-prefix nil
1548 "Local prefix digits.
1549 If this is non-nil, it should be a string of digits which your phone
1550 system requires before making local calls (for example, if your phone system
1551 requires you to dial 9 before making outside calls.) In BBDB's
1552 opinion, you're dialing a local number if it starts with a 0 after
1553 processing `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.
1560 If this is non-nil, it should be a string of digits which your phone
1561 system requires before making a long distance call (one not in your local
1562 area code). For example, in some areas you must dial 1 before an area
1563 code. Note that this is used to replace the + sign in phone numbers
1564 when 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.
1571 This function is used by `bbdb-dial-number'. It requires one
1572 argument which is a string for the number that is dialed.
1573 If nil then `bbdb-dial-number' uses the tel URI syntax passed to `browse-url'
1574 to 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.
1595 Each element should be a cons cell (KEY . FACE) with string KEY and face FACE.
1596 To use FACE for font-locking the name of a record,
1597 the xfield name-face of this record should have the value KEY.
1598 The value of name-face may also be a face which is then used directly.
1599 If 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.
1617 You 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.
1652 See 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'.
1699 It 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.
1704 In buffer `bbdb-file' this list includes all records.
1705 In the *BBDB* buffers it includes the records that are actually displayed
1706 and 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.
1711 Use `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.
1718 Hashes 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.
1746 This is a vector [APPEND-M APPEND INVERT-M INVERT ALL-M ALL].
1747 APPEND-M is the mode line info if `bbdb-append-display' is non-nil.
1748 INVERT-M is the mode line info if `bbdb-search-invert' is non-nil.
1749 ALL-M is the mode line info if `bbdb-do-all-records' is non-nil.
1750 APPEND, 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.
1754 Normally calls of `bbdb-change-hook' and updating of a record are suppressed,
1755 if an editing command did not really change the record. Bind this to t
1756 if 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.
1824 This 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.
1916 ARGS 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.
1922 If 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.
1940 SEPARATOR may be a regexp. SEPARATOR may also be a symbol
1941 \(a field name). Then look up the value in `bbdb-separator-alist'
1942 or use `bbdb-default-separator'.
1943 Whitespace around SEPARATOR is ignored unless SEPARATOR matches
1944 the string \" \\t\\n\".
1945 Almost 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.
1959 STRINGS may be strings or lists of strings. Empty strings are ignored.
1960 SEPARATOR may be a string.
1961 SEPARATOR may also be a symbol (a field name). Then look up the value
1962 of SEPARATOR in `bbdb-separator-alist' or use `bbdb-default-separator'.
1963 The 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).
1984 This 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.
1991 PROMPT is a string to prompt with.
1992 INIT appears as initial input which is useful for editing existing records.
1993 COLLECTION 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.
2016 The test for presence of ELEMENT is done with `equal'.
2017 The 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.
2025 The test for presence of ELEMENT is done with `eq'.
2026 The 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.
2034 The test for presence of ELEMENT is done with `equal'.
2035 The 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.
2044 If 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.
2062 Debugging is enabled if variable `bbdb-debug' is non-nil during compile.
2063 You 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.
2072 This macro is used with `prin1', `prin1-to-string', etc. in order to ensure
2073 printed 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.
2127 May 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.
2141 If SPEC is a function call it with args RECORD and STRING. Return value.
2142 If SPEC is a regexp, return 'query unless SPEC matches STRING.
2143 Otherwise return SPEC.
2144 Used 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.
2153 Return t if either SPEC equals t, or SPEC equals 'query and `bbdb-silent'
2154 is non-nil or `y-or-no-p' returns t using PROMPT.
2155 Used 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.
2162 COMPONENTS is a list (FULL-NAME CANONICAL-ADDRESS) as returned
2163 by `mail-extract-address-components'.
2164 Pass FULL-NAME through `bbdb-message-clean-name-function'
2165 and 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.
2178 This function behaves like `mail-extract-address-components', but it passes
2179 its return value through `bbdb-clean-address-components'.
2180 See 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.
2189 In general, this function behaves like the more sophisticated function
2190 `mail-extract-address-components'. Yet for an address `<Joe_Smith@foo.com>'
2191 lacking a real name the latter function returns the name \"Joe Smith\".
2192 This is useful when analyzing the headers of email messages we receive
2193 from the outside world. Yet when analyzing the mail addresses stored
2194 in BBDB, this pollutes the mail-aka space. So we define here
2195 an intentionally much simpler function for decomposing the names
2196 and 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.
2226 If the domain part of a mail address matches this regexp, the domain
2227 is replaced by the substring that actually matched this address.
2228
2229 Used 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'.
2235 However, this function is too specific to be useful for the general user.
2236 Take 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'.
2295 This 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.
2333 The function bbdb-NAME-ELT returns the element ELT in vector NAME.
2334 The function bbdb-NAME-set-ELT sets ELT.
2335 Also define a constant bbdb-NAME-length that holds the number of ELTS
2336 in 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. \
2354 Return VALUE.
2355 Do not call this function directly. Call instead `bbdb-record-set-field'
2356 which ensures the integrity of the database. Also, this makes your code
2357 more robust with respect to possible future changes of BBDB's innermost
2358 internals."
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.
2399 It 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'.
2421 KEY 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'.
2431 KEY must be a string or nil. Empty strings and nil are ignored.
2432 PREDICATE 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.
2447 PREDICATE 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.
2473 KEY 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'.
2485 This performs all initializations required for a new record.
2486 Do 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.
2513 Both 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.
2521 This throws an error if the name is already used by another record
2522 and `bbdb-allow-duplicates' is nil. If RECORD is non-nil, FIRST and LAST
2523 may 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.
2534 Return empty string if both the first and last name are nil.
2535 If the name is not available in the name cache, the name cache value
2536 is 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.
2543 If the name is not available in the name cache, the name cache value
2544 is 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.
2552 If FIRST or LAST are t use respective existing entries of RECORD.
2553 Set 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.
2579 Set 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.
2602 Return 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.
2609 Return 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.
2616 Return 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.
2625 Splitting 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.
2632 If VALUE is nil or an empty string, remove xfield LABEL from RECORD.
2633 Return 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.
2659 TYPE is a pseudo-code as in `bbdb-record-type'.
2660 If ABORT is non-nil, abort with error message if type checking fails.
2661 If EXTENDED is non-nil, consider extended atomic types which may include
2662 symbols, 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
2750 FIELD 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
2769 Any other symbol is interpreted as the label for an xfield.
2770 Then return the value of this xfield.
2771
2772 See 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.
2799 If MERGE is non-nil, merge VALUE with the current value of FIELD.
2800 If CHECK is non-nil, check syntactically whether FIELD may take VALUE.
2801 This function also updates the hash table. However, it does not update
2802 RECORD in the database. Use `bbdb-change-record' for that.
2803
2804 FIELD 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
2820 Any other symbol is interpreted as the label for an xfield.
2821 Then VALUE is the value of this xfield.
2822
2823 See 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.
2983 SEPARATOR 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.
3008 An element from L2 is added to L1 if CMP returns nil for all elements of L1.
3009 If 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.
3023 If LABEL has an entry in `bbdb-merge-xfield-function-alist', use it.
3024 If VALUE1 or VALUE2 is a substring of the other, return the longer one.
3025 Otherwise 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.
3043 Case is ignored. Return name as (FIRST . LAST).
3044 LAST 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.
3065 Do 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'.
3118 Ensure that this buffer is in sync with `bbdb-file'.
3119 Revert the buffer if necessary.
3120 If `bbdb-file-remote' is non-nil and it is newer than `bbdb-file',
3121 copy 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.
3205 If `bbdb-debug' was non-nil at compile-time, and `bbdb-buffer' is visible
3206 in a window, temporarilly switch to that window. So when we come out,
3207 that 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.
3222 If BBDB is out of sync try to revert.
3223 BBDB 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.
3239 This 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'.
3245 IGNORE-AUTO and NOCONFIRM have same meaning as in `revert-buffer'.
3246 See also variable `bbdb-auto-revert'.
3247 Return t if the reversion was successful (or not needed).
3248 Return 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.
3298 If `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.
3473 Return RECORD if RECORD got changed compared with the database,
3474 return nil otherwise.
3475 Hash RECORD if it is new. If RECORD is not new, it is the the caller's
3476 responsibility to update the hashtables for RECORD. (Up-to-date hashtables are
3477 ensured if the fields are modified by calling `bbdb-record-set-field'.)
3478 Redisplay RECORD if it is not new.
3479
3480 Args IGNORED are ignored and their use is discouraged.
3481 They 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.
3561 With COMPLETELY non-nil, also undisplay RECORD and remove it
3562 from 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.
3587 Do not call this function directly, call instead `bbdb-change-record'
3588 that 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.
3630 Do not call this function directly, call instead `bbdb-change-record'
3631 that 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.
3680 This is done by comparing the postcode to `bbdb-continental-postcode-regexp'.
3681
3682 This 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.
3691 This is the default format; it is used in the US, for example.
3692 The result looks like this:
3693 label: street
3694 street
3695 ...
3696 city, state postcode
3697 country.
3698
3699 This 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.
3713 The 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.
3765 If 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.
3773 For inserted text, set text property bbdb-field to FIELD.
3774 If TERMINATOR is non-nil use it to terminate the inserted text.
3775 If FACE is non-nil use it as FACE for inserted text.
3776 If INDENT and `bbdb-wrap-column' are integers, insert line breaks in between
3777 elements 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.
3803 If RECORD has an xfield name-face, its value is used for font-locking name.
3804 The value of name-face may be a face that is used directly.
3805 The value may also be a key in `bbdb-name-face-alist'. Then the
3806 corresponding 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.
3855 See `bbdb-layout-alist' for more info on layouts.
3856 FIELD-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.
3935 See `bbdb-layout-alist' for more info on layouts.
3936 FIELD-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.
4035 LAYOUT can be a symbol describing a layout in `bbdb-layout-alist'.
4036 If it is nil, use `bbdb-layout'.
4037 NUMBER is the number of RECORD among the displayed records.
4038 Move 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.
4090 If APPEND is non-nil append RECORDS to the already displayed records.
4091 Otherwise RECORDS overwrite the displayed records.
4092 SELECT 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.
4170 If 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.
4183 If SORT is t, usually because RECORD has a new sortkey, re-sort
4184 the displayed records.
4185 If 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.
4236 If SORT is t, usually because RECORD has a new sortkey, re-sort
4237 the displayed records.
4238 If 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.
4255 Finds the largest window on the screen, splits it, displaying the
4256 *BBDB* buffer in the bottom `bbdb-pop-up-window-size' lines (unless
4257 the *BBDB* buffer is already visible, in which case do nothing.)
4258 Select this window if SELECT is non-nil.
4259
4260 If `bbdb-mua-pop-up' is 'horiz, and the first window matching
4261 the predicate HORIZ-P is wider than the car of `bbdb-horiz-pop-up-window-size'
4262 then 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.
4333 If `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.
4347 Letters no longer insert themselves. Numbers are prefix arguments.
4348 You 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 \
4351 remove 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 \
4354 current line. If the current line is the\n\t first line of a record, then \
4355 delete the entire record.
4356 \\[bbdb-insert-field]\t Insert a new field into the current record. \
4357 Note 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 \
4359 previous 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 \
4362 displayed 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 \
4365 one-line\n\t listing, or a full multi-line listing.
4366 \\[bbdb-do-all-records]\\[bbdb-toggle-records-layout]\t Do that \
4367 for all displayed records.
4368 \\[bbdb-merge-records]\t Merge the contents of the current record with \
4369 some other, and then\n\t delete the current record.
4370 \\[bbdb-omit-record]\t Remove the current record from the display without \
4371 deleting it from\n\t the database. This is often a useful thing to do \
4372 before 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 \
4379 was saved.
4380 \\[bbdb-mail]\t Compose mail to the person represented by the \
4381 current record.
4382 \\[bbdb-do-all-records]\\[bbdb-mail]\t Compose mail \
4383 to 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 \
4387 displayed 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 \
4392 record.
4393
4394 For 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
4398 Important 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
4419 There 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.
4551 Return 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.
4586 With 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.
4594 With 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.
4600 With 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.
4612 With 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.
4618 If PROMPT is non-nil prompt before saving.
4619 If 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.
4634 With 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.
4658 This is not needed when using BBDB itself. It might be necessary,
4659 however, 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.
4694 List MUAS may include the following symbols to initialize the respective
4695 mail/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
4719 See also `bbdb-mua-auto-update-init'. The latter is a separate function
4720 as this allows one to initialize the auto update feature for some MUAs only,
4721 for 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