[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[elpa] externals/ebdb b25edb9 002/350: Squash "prep" branch, push to Git
From: |
Eric Abrahamsen |
Subject: |
[elpa] externals/ebdb b25edb9 002/350: Squash "prep" branch, push to Github |
Date: |
Mon, 14 Aug 2017 11:45:50 -0400 (EDT) |
branch: externals/ebdb
commit b25edb9b7e52abff4b47b21efe56b13667050fd7
Author: Eric Abrahamsen <address@hidden>
Commit: Eric Abrahamsen <address@hidden>
Squash "prep" branch, push to Github
---
README.org | 83 ++
company-ebdb.el | 61 +
ebdb-anniv.el | 162 ++
ebdb-chn.el | 129 ++
ebdb-com.el | 2907 ++++++++++++++++++++++++++++++++++++
ebdb-format.el | 415 ++++++
ebdb-gnorb.el | 60 +
ebdb-gnus.el | 480 ++++++
ebdb-i18n.el | 738 +++++++++
ebdb-ispell.el | 112 ++
ebdb-message.el | 77 +
ebdb-mhe.el | 122 ++
ebdb-migrate.el | 629 ++++++++
ebdb-mu4e.el | 52 +
ebdb-mua.el | 1527 +++++++++++++++++++
ebdb-org.el | 109 ++
ebdb-pgp.el | 199 +++
ebdb-rmail.el | 71 +
ebdb-vcard.el | 234 +++
ebdb-vm.el | 363 +++++
ebdb.el | 4450 +++++++++++++++++++++++++++++++++++++++++++++++++++++++
ebdb.org | 160 ++
22 files changed, 13140 insertions(+)
diff --git a/README.org b/README.org
new file mode 100644
index 0000000..f889818
--- /dev/null
+++ b/README.org
@@ -0,0 +1,83 @@
+
+* EBDB
+EBDB is a EIEIO port of the BBDB package for Emacs.
+
+In plain English: it is a re-write of the Insidious Big Brother
+Database -- Emacs' principle contact management/addressbook program --
+using Emacs Lisp's (relatively new) object oriented libraries. The "E"
+is vaguely meant to signify "EIEIO".
+** Why Did You Do This?
+In part to gain practice in writing object-oriented Elisp. The EIEIO
+and generic-function libraries are based on Common Lisp's
[[https://en.wikipedia.org/wiki/Common_Lisp_Object_System][CLOS system]],
+which I think is the
[[http://www.gigamonkeys.com/book/object-reorientation-generic-functions.html][cat's
pyjamas]].
+
+Also, a database/record-keeping library is an excellent candidate for
+the object-oriented programming approach. By making databases, records
+and fields into classes (and by making sure that the library code
+itself is agnostic as possible about those classes), third-party
+developers can easily create new subclasses, and new behavior for
+existing classes. By loading external packages, users can augment the
+behavior of EBDB without having to use hooks or even customization
+options.
+** Okay, But What's Cool About It Right Now?
+EBDB as it stands provides a few enhancements over BBDB.
+
+1. Multiple databases. It's possible to load contacts from more than
+ one database.
+2. Records are identified by UUID. Combined with multiple database
+ support, this means that single records can live in more than one
+ database. The loading routine checks for duplicate records and does
+ its best to automatically merge them. Loading, editing and saving
+ records into multiple databases should all work transparently.
+3. Organizations are top-level records. To be precise, both "people"
+ and "organizations" are subclasses of an abstract parent class
+ (other record classes are planned). A person record can have a
+ "role" at an organization, and that role can contain an arbitrary
+ amount of metadata.
+4. Records can have relations to other records.
+5. ebdb-i18n.el. This pluggable internationalization framework allows
+ developers to write country-specific libraries providing different
+ behavior for records and fields depending on nationality.
+6. High configurability. EBDB has many customization options (though
+ fewer than BBDB had), but users and developers who are familiar
+ with generic functions can use them to fundamentally alter the
+ behavior and appearance of EBDB with very little code, and fairly
+ low risk of breakage. Want to prepend the string "Hi my name is "
+ to all the contact names in your *BBDB* buffer? That would be three
+ lines of code.
+7. A native Vcard database class is on its way.
+** What Are the Drawbacks?
+
+Buggy code! Potential data loss! This is still very much alpha. Many
+of the auxiliary packages also haven't been updated to work with the
+new system.
+
+Also, many of the customization options are likely to change as the
+package gets through beta to something stable.
+
+Other than that, load and save times are a bit slow, and the database
+persistence file is significantly larger than it was in BBDB. In part
+this is because there's simply more data being recorded, and the
+persistence format is verbose. It's likely that optimizations can be
+made to reduce load times.
+** I Still Want to Try This, Is There A Migration Scheme?
+Yes, EBDB will read and migrate from a BBDB v3 data file. Actually,
+EBDB preserves the BBDB's old migration routines, so theoretically you
+could go from a BBDB v2 file, through BBDB v3, straight to EBDB. I
+wouldn't recommend that, though. To migrate:
+
+1. Load the EBDB code while your BBDB customizations are still in
+ place -- specifically, the `bbdb-file' option should point to your
+ existing BBDB v3 file.
+2. Back up that file.
+3. Set `ebdb-sources' to a non-existent file name, where you'd like to
+ keep the new database.
+4. Run `ebdb-load'. You'll be prompted to create the new database, and
+ migrate to the new format. It will take a surprisingly long time.
+5. If there were any migration failures, you'll get a "*BBDB
+ Migration*" buffer containing the records which couldn't be
+ migrated. Migration bug reports are very welcome.
+
+Once you're migrated, load MUA interaction by simply requiring the
+relevant libraries, ie ebdb-gnus or ebdb-message. There's no more
+`initialize' or `auto-update-init'.
diff --git a/company-ebdb.el b/company-ebdb.el
new file mode 100644
index 0000000..a1c2e06
--- /dev/null
+++ b/company-ebdb.el
@@ -0,0 +1,61 @@
+;;; company-ebdb.el --- company-mode completion backend for EBDB in
message-mode
+
+;; Copyright (C) 2013-2014, 2016 Free Software Foundation, Inc.
+
+;; Author: Jan Tatarik <address@hidden>
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+(require 'company)
+(require 'cl-lib)
+
+(declare-function ebdb-record-get-field "ebdb")
+(declare-function ebdb-records "ebdb")
+(declare-function ebdb-dwim-mail "ebdb-com")
+(declare-function ebdb-search "ebdb-com")
+
+(defgroup company-ebdb nil
+ "Completion backend for EBDB."
+ :group 'company)
+
+(defcustom company-ebdb-modes '(message-mode)
+ "Major modes in which `company-ebdb' may complete."
+ :type '(repeat (symbol :tag "Major mode"))
+ :package-version '(company . "0.8.8"))
+
+(defun company-ebdb--candidates (arg)
+ (cl-mapcan (lambda (record)
+ (mapcar (lambda (mail) (ebdb-dwim-mail record mail))
+ (ebdb-record-get-field record 'mail)))
+ (eval '(ebdb-search (ebdb-records) arg nil arg))))
+
+;;;###autoload
+(defun company-ebdb (command &optional arg &rest ignore)
+ "`company-mode' completion backend for EBDB."
+ (interactive (list 'interactive))
+ (cl-case command
+ (interactive (company-begin-backend 'company-ebdb))
+ (prefix (and (memq major-mode company-ebdb-modes)
+ (featurep 'ebdb-com)
+ (looking-back "^\\(To\\|Cc\\|Bcc\\): *.*? *\\([^,;]*\\)"
+ (line-beginning-position))
+ (match-string-no-properties 2)))
+ (candidates (company-ebdb--candidates arg))
+ (sorted t)
+ (no-cache t)))
+
+(provide 'company-ebdb)
+;;; company-ebdb.el ends here
diff --git a/ebdb-anniv.el b/ebdb-anniv.el
new file mode 100644
index 0000000..9c155cd
--- /dev/null
+++ b/ebdb-anniv.el
@@ -0,0 +1,162 @@
+;;; ebdb-anniv.el --- Getting anniversaries from EBDB contacts -*-
lexical-binding: t; -*-
+
+;; Copyright (C) 2016 Free Software Foundation, Inc.
+
+;; Author: Eric Abrahamsen <address@hidden>
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; Support for getting anniversaries (birth, wedding, etc) from EBDB
+;; contacts.
+
+;;; Code:
+
+(require 'ebdb)
+(require 'ebdb-com)
+(require 'diary-lib)
+
+(defcustom ebdb-anniv-alist
+ '((birthday . "%n's %d%s birthday")
+ (wedding . "%n's %d%s wedding anniversary")
+ (anniversary))
+ "Alist of rules for formatting anniversaries in the diary buffer.
+Each element is of the form (LABEL . FORM).
+LABEL is the xfield where this type of anniversaries is stored.
+FORM is a format string with the following substitutions:
+ %n name of the record
+ %d number of years
+ %s ordinal suffix (st, nd, rd, th) for the year.
+ %t the optional text following the date string in field LABEL.
+If FORM is nil, use the text following the date string in field LABEL
+as format string."
+ :type '(repeat (cons :tag "Rule"
+ (symbol :tag "Label")
+ (choice (string)
+ (const nil))))
+ :group 'ebdb-utilities-anniv)
+
+;; `ebdb-anniv-diary-entries' becomes a member of `diary-list-entries-hook'.
+;; When this hook is run by `diary-list-entries', the variable `original-date'
+;; is bound to the value of arg DATE of `diary-list-entries'.
+;; Also, `number' is arg NUMBER of `diary-list-entries'.
+;; `diary-list-entries' selects the entries for NUMBER days starting with DATE.
+
+(defvar original-date) ; defined in diary-lib
+(with-no-warnings (defvar number)) ; defined in diary-lib
+
+;;;###autoload
+(defun ebdb-anniv-diary-entries ()
+ "Add anniversaries from EBDB records to `diary-list-entries'.
+This obeys `calendar-date-style' via `diary-date-forms'.
+To enable this feature, put the following into your .emacs:
+
+ \(add-hook 'diary-list-entries-hook 'ebdb-anniv-diary-entries)"
+ ;; Loop over NUMBER dates starting from ORGINAL-DATE.
+ (let* ((num-date (1- (calendar-absolute-from-gregorian original-date)))
+ (end-date (+ num-date number)))
+ (while (<= (setq num-date (1+ num-date)) end-date)
+ (let* ((date (calendar-gregorian-from-absolute num-date))
+ ;; The following variables may be used by `diary-date-forms'.
+ (day (calendar-extract-day date))
+ (month (calendar-extract-month date))
+ (current-year (calendar-extract-year date))
+ (non-leap (and (= month 3) (= day 1)
+ (not (calendar-leap-year-p current-year))))
+ (dayname (format "%s\\|%s\\.?" (calendar-day-name date)
+ (calendar-day-name date 'abbrev)))
+ (monthname (format "%s\\|%s" (calendar-month-name month)
+ (calendar-month-name month 'abbrev)))
+ (day (format "0*%d" day))
+ (month (format "0*%d" month))
+ ;; We could use an explicitly numbered group to match the year.
+ ;; This requires emacs 23.
+ (year "\\([0-9]+\\)\\|\\*")
+ date-forms)
+
+ (dolist (date-form diary-date-forms)
+ ;; Require that the matched date is at the beginning of the string.
+ ;; Use shy groups so that we can grab the year more easily.
+ (push (cons (format "\\`%s?\\(?:%s\\)"
+ (regexp-quote diary-nonmarking-symbol)
+ (mapconcat 'eval (if (eq (car date-form) 'backup)
+ (cdr date-form) date-form)
+ "\\)\\(?:"))
+ (eq (car date-form) 'backup))
+ date-forms))
+
+ ;; The anniversary of February 29 is considered to be March 1
+ ;; in non-leap years. So we search for February 29, too.
+ (when non-leap
+ (let* ((day "0*29") (month "0*2")
+ (monthname (format "%s\\|%s" (calendar-month-name 2)
+ (calendar-month-name 2 'abbrev))))
+ (dolist (date-form diary-date-forms)
+ (push (cons (format "\\`%s?\\(?:%s\\)"
+ (regexp-quote diary-nonmarking-symbol)
+ (mapconcat 'eval (if (eq (car date-form)
'backup)
+ (cdr date-form)
date-form)
+ "\\)\\(?:"))
+ (eq (car date-form) 'backup))
+ date-forms))))
+
+ (dolist (record (ebdb-records))
+ (dolist (rule ebdb-anniv-alist)
+ (dolist (anniv (ebdb-record-xfield-split record (car rule)))
+ (let ((date-forms date-forms)
+ (anniv-string (concat anniv " X")) ; for backup forms
+ (case-fold-search t)
+ form yy text)
+ (while (setq form (pop date-forms))
+ (when (string-match (car form) anniv-string)
+ (setq date-forms nil
+ yy (match-string 1 anniv-string)
+ yy (if (and yy (string-match-p "[0-9]+" yy))
+ (- current-year (string-to-number yy))
+ 100) ; as in `diary-anniversary'
+ ;; For backup forms we should search backward in
+ ;; anniv-string from (match-end 0) for "\\<".
+ ;; That gets too complicated here!
+ ;; Yet for the default value of `diary-date-forms'
+ ;; this would matter only if anniv-string started
+ ;; with a time. That is rather rare for
anniversaries.
+ ;; Then we may simply step backward by one character.
+ text (substring anniv-string (if (cdr form) ; backup
+ (1- (match-end 0))
+ (match-end 0)) -1)
+ text (replace-regexp-in-string "\\`[ \t]+" "" text)
+ text (replace-regexp-in-string "[ \t]+\\'" "" text))
+ (if (cdr rule)
+ (setq text (replace-regexp-in-string "%t" text (cdr
rule))))))
+ ;; Add the anniversaries to `diary-entries-list'.
+ (if (and yy (> yy 0) (< 0 (length text)))
+ (diary-add-to-list
+ date
+ (format
+ ;; Text substitution similar to `diary-anniversary'.
+ (replace-regexp-in-string "%n" (ebdb-record-name record)
text)
+ yy (diary-ordinal-suffix yy))
+ ;; It would be nice to have a SPECIFIER that allowed us
to jump
+ ;; from the diary display buffer to the respective EBDB
record.
+ ;; Yet it seems that diary-lib does not support this for
us.
+ ;; So we use instead an empty string. When clicking on
the
+ ;; anniversary entry in the diary display buffer, this
give us
+ ;; the message "Unable to locate this diary entry".
+ ""))))))))))
+
+(add-hook 'diary-list-entries-hook 'ebdb-anniv-diary-entries)
+
+(provide 'ebdb-anniv)
+;;; ebdb-anniv.el ends here
diff --git a/ebdb-chn.el b/ebdb-chn.el
new file mode 100644
index 0000000..fa3418d
--- /dev/null
+++ b/ebdb-chn.el
@@ -0,0 +1,129 @@
+;;; ebdb-chn.el --- China-specific internationalization support for EBDB -*-
lexical-binding: t; -*-
+
+;; Copyright (C) 2016 Free Software Foundation, Inc.
+
+;; Author: Eric Abrahamsen <address@hidden>
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; Bits of code for making EBDB nicer to use with China-based
+;; contacts, both for handling Chinese characters, and for formatting
+;; of phones and addresses. Be aware that using this library will
+;; incur a non-neglible slowdown at load time. It shouldn't have any
+;; real impact on search and completion times.
+
+;;; Code:
+
+(require 'chinese-pyim-dictools)
+
+;; This isn't all of them, but it seems like a reasonable subset. See
+;; https://en.wikipedia.org/wiki/Chinese_compound_surname for a fuller
+;; list.
+(defvar ebdb-china-compound-surnames
+ '("慕容" "上官" "司马" "欧阳" "司徒" "司空" "西门" "爱新觉罗")
+ "A list of Chinese surnames that are longer than one
+ character.")
+
+(cl-defmethod ebdb-parse-i18n ((class (subclass ebdb-field-name-complex))
+ (string string)
+ (script (eql han)))
+ (let (surname given-names)
+ (if (string-match (format "\\`\\(%s\\)\\(.*\\)\\'" (regexp-opt
ebdb-china-compound-surnames)) string)
+ (setq surname (match-string 1 string)
+ given-names (match-string 2 string))
+ (setq surname (substring string 0 1)
+ given-names (substring string 1)))
+
+ (make-instance 'ebdb-field-name-complex
+ :surname surname
+ :given-names (list given-names))))
+
+(cl-defmethod ebdb-string-i18n ((field ebdb-field-name-complex)
+ (script (eql han)))
+ "Properly format names in Chinese characters.
+
+This should only run once, at init time, or any time a record's
+name is changed. The value ends up in the 'name-string slot of
+the record cache."
+ (with-slots (surname given-names) field
+ (format "%s%s" surname (car given-names))))
+
+(cl-defmethod ebdb-china-handle-name ((field ebdb-field-name-complex)
+ (record ebdb-record)
+ add-or-del)
+ "Add or remove a hash for a Chinese-character name.
+
+This function is called by both the `ebdb-init-i18n' and
+`ebdb-delete-i18n' methods. It checks if the name is in Chinese
+characters, and if it is, converts it into pinyin, and either
+adds or removes a hash entry for the record under that name. It
+also adds the pinyin to the record's name cache, so searchs via
+pinyin will find the record."
+ ;; We use `pyim-hanzi2pinyin-simple' because it's cheaper, and
+ ;; because checking for multiple character pronunciations isn't
+ ;; really helpful in people's names.
+ (let ((fl-py (pyim-hanzi2pinyin-simple (ebdb-name-fl field)))
+ (lf-py (pyim-hanzi2pinyin-simple
+ ;; Don't use `ebdb-name-lf', because there's no sense
+ ;; in having the comma in there.
+ (concat (ebdb-name-last field)
+ " "
+ (ebdb-name-given field t))))
+ (name-string (ebdb-string field))
+ hashfunc listfunc)
+ (if (eql add-or-del 'add)
+ (progn
+ (setq hashfunc #'ebdb-puthash
+ listfunc #'object-add-to-list))
+ (setq hashfunc #'ebdb-remhash
+ listfunc #'object-remove-from-list))
+ (funcall hashfunc fl-py record)
+ (funcall hashfunc lf-py record)
+ (funcall hashfunc name-string record)
+ (funcall listfunc (ebdb-record-cache record) 'alt-names fl-py)
+ (funcall listfunc (ebdb-record-cache record) 'alt-names name-string)
+ (funcall listfunc (ebdb-record-cache record) 'alt-names lf-py)))
+
+(cl-defmethod ebdb-china-handle-name ((field ebdb-field-name-simple)
+ (record ebdb-record)
+ add-or-del)
+ "Add or remove a hash for a Chinese-character name."
+ ;; We use `pyim-hanzi2pinyin-simple' because it's cheaper, and
+ ;; because checking for multiple character pronunciations isn't
+ ;; really helpful in people's names.
+ (let ((name-string (ebdb-string field))
+ hashfunc listfunc)
+ (if (eql add-or-del 'add)
+ (progn
+ (setq hashfunc #'ebdb-puthash
+ listfunc #'object-add-to-list))
+ (setq hashfunc #'ebdb-remhash
+ listfunc #'object-remove-from-list))
+ (funcall hashfunc name-string record)
+ (funcall listfunc (ebdb-record-cache record) 'alt-names name-string)))
+
+(cl-defmethod ebdb-init-i18n ((field ebdb-field-name)
+ record
+ (script (eql han)))
+ (ebdb-china-handle-name field record 'add))
+
+(cl-defmethod ebdb-delete-i18n ((field ebdb-field-name)
+ record
+ (scrip (eql han)))
+ (ebdb-china-handle-name field record 'del))
+
+(provide 'ebdb-chn)
+;;; ebdb-chn.el ends here
diff --git a/ebdb-com.el b/ebdb-com.el
new file mode 100644
index 0000000..0bcec03
--- /dev/null
+++ b/ebdb-com.el
@@ -0,0 +1,2907 @@
+;;; ebdb-com.el --- User-level commands of EBDB -*- lexical-binding: t;
-*-
+
+;; Copyright (C) 2016 Free Software Foundation, Inc.
+
+;; Author: Eric Abrahamsen <address@hidden>
+;; Keywords: convenience, mail
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; This file contains most of the user-level interactive commands for
+;; EBDB, including the *EBDB* buffer and ebdb-mode.
+
+;;; Code:
+
+(require 'ebdb)
+(require 'ebdb-format)
+(require 'mailabbrev)
+
+(eval-and-compile
+ (autoload 'build-mail-aliases "mailalias")
+ (autoload 'browse-url-url-at-point "browse-url"))
+
+(require 'crm)
+(defvar ebdb-crm-local-completion-map
+ (let ((map (make-sparse-keymap)))
+ (set-keymap-parent map crm-local-completion-map)
+ (define-key map " " 'self-insert-command)
+ map)
+ "Keymap used for EBDB crm completions.")
+
+;; Customizations for display routines
+
+(defgroup ebdb-record-display nil
+ "Variables that affect the display of EBDB records"
+ :group 'ebdb)
+
+(defcustom ebdb-pop-up-window-size 0.5
+ "Vertical size of EBDB window (vertical split).
+If it is an integer number, it is the number of lines used by EBDB.
+If it is a fraction between 0.0 and 1.0 (inclusive), it is the fraction
+of the tallest existing window that EBDB will take over.
+If it is t use `display-buffer'/`pop-to-buffer' to create the EBDB window.
+See also `ebdb-mua-pop-up-window-size'."
+ :group 'ebdb-record-display
+ :type '(choice (number :tag "EBDB window size")
+ (const :tag "Use `pop-to-buffer'" t)))
+
+(defcustom ebdb-horiz-pop-up-window-size '(112 . 0.3)
+ "Horizontal size of a pop-up EBDB window (horizontal split).
+It is a cons pair (TOTAL . EBDB-SIZE).
+The window that will be considered for horizontal splitting must have
+at least TOTAL columns. EBDB-SIZE is the horizontal size of the EBDB window.
+If it is an integer number, it is the number of columns used by EBDB.
+If it is a fraction between 0 and 1, it is the fraction of the
+window width that EBDB will take over."
+ :group 'ebdb-mua
+ :type '(cons (number :tag "Total number of columns")
+ (number :tag "Horizontal size of EBDB window")))
+
+(defcustom ebdb-dedicated-window nil
+ "Make *EBDB* window a dedicated window.
+Allowed values include nil (not dedicated) 'ebdb (weakly dedicated)
+and t (strongly dedicated)."
+ :group 'ebdb-record-display
+ :type '(choice (const :tag "EBDB window not dedicated" nil)
+ (const :tag "EBDB window weakly dedicated" ebdb)
+ (const :tag "EBDB window strongly dedicated" t)))
+
+(defcustom ebdb-fill-field-values 't
+ "If t, fill particularly long field values so that they fit
+within the *EBDB* buffer."
+ :group 'ebdb-record-display
+ ;; TODO: When we have a 'pop-up and 'user buffer distinction, give
+ ;; this option more potential values.
+ :type '(choice (const :tag "Always fill" nil)
+ (const :tag "Never fill" t)))
+
+(defcustom ebdb-user-menu-commands nil
+ "User defined menu entries which should be appended to the EBDB menu.
+This should be a list of menu entries.
+When set to a function, it is called with two arguments RECORD and FIELD
+and it should either return nil or a list of menu entries.
+Used by `ebdb-mouse-menu'."
+ :group 'ebdb-record-display
+ :type 'sexp)
+
+(defcustom ebdb-display-hook nil
+ "Hook run after the *EBDB* is filled in."
+ :group 'ebdb-record-display
+ :type 'hook)
+
+(defcustom ebdb-multiple-buffers nil
+ "When non-nil we create a new buffer of every buffer causing pop-ups.
+You can also set this to a function returning a buffer name.
+Here a value may be the predefined function `ebdb-multiple-buffers-default'."
+ :group 'ebdb-record-display
+ :type '(choice (const :tag "Disabled" nil)
+ (function :tag "Enabled" ebdb-multiple-buffers-default)
+ (function :tag "User defined function")))
+
+;; Faces for font-lock
+(defgroup ebdb-faces nil
+ "Faces used by EBDB."
+ :group 'ebdb
+ :group 'faces)
+
+(defface ebdb-person-name
+ '((t (:inherit font-lock-function-name-face)))
+ "Face used for EBDB person names."
+ :group 'ebdb-faces)
+
+(defface ebdb-organization-name
+ '((t (:inherit font-lock-comment-face)))
+ "Face used for EBDB organization names."
+ :group 'ebdb-faces)
+
+(defcustom ebdb-name-face-alist '((ebdb-record-person . ebdb-person-name)
+ (ebdb-record-organization .
ebdb-organization-name))
+ "Alist matching record class types to the face that should be
+ used to font-lock their names in the *EBDB* buffer."
+ :group 'ebdb-faces
+ :type '(repeat (cons (ebdb-record :tag "Record type") (face :tag "Face"))))
+
+(defface ebdb-marked
+ '((t (:background "LightBlue")))
+ "Face used for currently-marked records."
+ :group 'ebdb-faces)
+
+(defface ebdb-label
+ '((t (:inherit font-lock-variable-name-face)))
+ "Face used for EBDB field labels."
+ :group 'ebdb-faces)
+
+(defface ebdb-field-url
+ '((t (:inherit link)))
+ "Face used for clickable links/URLs in field values."
+ :group 'ebdb-faces)
+
+(defface ebdb-defunct
+ '((t (:inherit font-lock-comment-face)))
+ "Face used to display defunct roles and mails."
+ :group 'ebdb-faces)
+
+(defface ebdb-mail-primary
+ '((t (:inherit font-lock-builtin-face)))
+ "Face used to display a record's primary mail address."
+ :group 'ebdb-faces)
+
+(defface ebdb-db-char
+ '((t (:inherit shadow)))
+ "Face used to display a databases's identifying character string."
+ :group 'ebdb-faces)
+
+(defvar ebdb-buffer-name "*EBDB*" "Name of the EBDB buffer.")
+
+;;; Buffer-local variables for the database.
+(defvar ebdb-records nil
+ "EBDB records list.
+
+In the *EBDB* buffers it includes the records that are actually displayed
+and its elements are (RECORD DISPLAY-FORMAT MARKER-POS MARK).")
+(make-variable-buffer-local 'ebdb-records)
+
+(defvar ebdb-append-display nil
+ "Controls the behavior of the command `ebdb-append-display'.")
+
+(defvar ebdb-modeline-info (make-vector 4 nil)
+ "Precalculated mode line info for EBDB commands.
+This is a vector [APPEND-M APPEND INVERT-M INVERT].
+APPEND-M is the mode line info if `ebdb-append-display' is non-nil.
+INVERT-M is the mode line info if `ebdb-search-invert' is non-nil.")
+
+(defun ebdb-get-records (prompt)
+ "If inside the *EBDB* buffer get the current records.
+In other buffers ask the user."
+ (if (string= ebdb-buffer-name (buffer-name))
+ (ebdb-do-records)
+ (ebdb-completing-read-records prompt)))
+
+;; Note about the arg RECORDS of various EBDB commands:
+;; - Usually, RECORDS is a list of records. (Interactively,
+;; this list of records is set up by `ebdb-do-records'.)
+;; - If these commands are used, e.g., in `ebdb-create-hook' or
+;; `ebdb-change-hook', they will be called with one arg, a single record.
+;; So depending on context the value of RECORDS will be a single record
+;; or a list of records, and we want to handle both cases.
+;; So we pass RECORDS to `ebdb-record-list' to handle both cases.
+(defun ebdb-record-list (records &optional full)
+ "Ensure that RECORDS is a list of records.
+If RECORDS is a single record turn it into a list.
+If FULL is non-nil, assume that RECORDS include display information."
+ (if records
+ (if full
+ (if (vectorp (car records)) (list records) records)
+ (if (vectorp records) (list records) records))))
+
+;; Note about EBDB prefix commands:
+;; `ebdb-do-all-records', `ebdb-append-display' and `ebdb-search-invert'
+;; are fake prefix commands. They need not precede the main commands.
+;; Also, `ebdb-append-display' can act on multiple commands.
+
+(defun ebdb-prefix-message ()
+ "Display a message about selected EBDB prefix commands."
+ (let ((msg (ebdb-concat " " (elt ebdb-modeline-info 1)
+ (elt ebdb-modeline-info 3))))
+ (unless (string= "" msg) (message "%s" msg))))
+
+;;;###autoload
+(defun ebdb-do-records (&optional full)
+ "Return list of records to operate on.
+Normally this list includes only the current record, but if any
+records in the current buffer are marked, they are returned
+instead. If FULL is non-nil, the list of records includes
+display information."
+ (let* ((marked (seq-filter (lambda (r) (nth 3 r)) ebdb-records))
+ (recs (or marked (list (ebdb-current-record t)))))
+ (if full recs (mapcar 'car recs))))
+
+;;;###autoload
+(defun ebdb-append-display-p ()
+ "Return variable `ebdb-append-display' and reset."
+ (let ((job (cond ((eq t ebdb-append-display))
+ ((numberp ebdb-append-display)
+ (setq ebdb-append-display (1- ebdb-append-display))
+ (if (zerop ebdb-append-display)
+ (setq ebdb-append-display nil))
+ t)
+ (ebdb-append-display
+ (setq ebdb-append-display nil)
+ t))))
+ (cond ((numberp ebdb-append-display)
+ (aset ebdb-modeline-info 0
+ (format "(add %dx)" ebdb-append-display)))
+ ((not ebdb-append-display)
+ (aset ebdb-modeline-info 0 nil)
+ (aset ebdb-modeline-info 1 nil)))
+ job))
+
+;;;###autoload
+(defun ebdb-append-display (&optional arg)
+ "Toggle appending next searched records in the *EBDB* buffer.
+With prefix ARG \\[universal-argument] always append.
+With ARG a positive number append for that many times.
+With ARG a negative number do not append."
+ (interactive "P")
+ (setq ebdb-append-display
+ (cond ((and arg (listp arg)) t)
+ ((and (numberp arg) (< 1 arg)) arg)
+ ((or (and (numberp arg) (< arg 0)) ebdb-append-display) nil)
+ (t 'once)))
+ (aset ebdb-modeline-info 0
+ (cond ((numberp ebdb-append-display)
+ (format "(add %dx)" ebdb-append-display))
+ ((eq t ebdb-append-display) "Add")
+ (ebdb-append-display "add")
+ (t nil)))
+ (aset ebdb-modeline-info 1
+ (if ebdb-append-display
+ (substitute-command-keys
+ "\\<ebdb-mode-map>\\[ebdb-append-display]")))
+ (ebdb-prefix-message))
+
+;;; Keymap
+(defvar ebdb-mode-map
+ (let ((km (make-sparse-keymap)))
+ (define-key km "*" 'ebdb-do-all-records)
+ (define-key km "+" 'ebdb-append-display)
+ (define-key km "!" 'ebdb-search-invert)
+ (define-key km "a" 'ebdb-record-action)
+ (define-key km "A" 'ebdb-mail-aliases)
+ (define-key km "c" 'ebdb-create)
+ (define-key km "e" 'ebdb-edit-field)
+ (define-key km ";" 'ebdb-edit-foo)
+ (define-key km "n" 'ebdb-next-record)
+ (define-key km "p" 'ebdb-prev-record)
+ (define-key km "N" 'ebdb-next-field)
+ (define-key km "\t" 'ebdb-next-field) ; TAB
+ (define-key km "P" 'ebdb-prev-field)
+ (define-key km "\d" 'ebdb-prev-field) ; DEL
+ (define-key km "d" 'ebdb-delete-field-or-record)
+ (define-key km "\C-k" 'ebdb-delete-field-or-record)
+ (define-key km "i" 'ebdb-insert-field)
+ (define-key km (kbd "RET") 'ebdb-follow-related)
+ (define-key km "s" 'ebdb-save)
+ (define-key km "\C-x\C-s" 'ebdb-save)
+ (define-key km "t" 'ebdb-toggle-records-format)
+ (define-key km "T" 'ebdb-display-records-completely)
+ (define-key km (kbd "#") 'ebdb-toggle-record-mark)
+ (define-key km "o" 'ebdb-omit-record)
+ (define-key km "m" 'ebdb-mail)
+ (define-key km "M" 'ebdb-mail-address)
+ (define-key km "\M-d" 'ebdb-dial)
+ (define-key km "h" 'ebdb-info)
+ (define-key km "?" 'ebdb-help)
+ ;; (define-key km "q" 'quit-window) ; part of `special-mode' bindings
+ (define-key km "\C-x\C-t" 'ebdb-transpose-fields)
+ (define-key km "Cr" 'ebdb-copy-records-as-kill)
+ (define-key km "Cf" 'ebdb-copy-fields-as-kill)
+ (define-key km "u" 'ebdb-browse-url)
+ ;; (define-key km "P" 'ebdb-print)
+ (define-key km "=" 'delete-other-windows)
+
+ ;; Search keys
+ (define-key km "b" 'ebdb)
+ (define-key km "/1" 'ebdb-display-records)
+ (define-key km "/n" 'ebdb-search-name)
+ (define-key km "/o" 'ebdb-search-organization)
+ (define-key km "/p" 'ebdb-search-phone)
+ (define-key km "/a" 'ebdb-search-address)
+ (define-key km "/m" 'ebdb-search-mail)
+ (define-key km "/N" 'ebdb-search-user-fields)
+ (define-key km "/x" 'ebdb-search-user-fields)
+ (define-key km "/c" 'ebdb-search-changed)
+ (define-key km "/d" 'ebdb-search-duplicates)
+ (define-key km "\C-xnw" 'ebdb-display-all-records)
+ (define-key km "\C-xnd" 'ebdb-display-current-record)
+
+ (define-key km [delete] 'scroll-down) ; 24.1: part of `special-mode'
+ (define-key km " " 'scroll-up) ; 24.1: part of `special-mode'
+
+ (define-key km [mouse-3] 'ebdb-mouse-menu)
+ (define-key km [mouse-2] (lambda (event)
+ ;; Toggle record format
+ (interactive "e")
+ (save-excursion
+ (posn-set-point (event-end event))
+ (ebdb-toggle-records-format
+ (ebdb-do-records t) current-prefix-arg))))
+ km)
+ "Keymap for Insidious Big Brother Database.
+This is a child of `special-mode-map'.")
+
+(defun ebdb-current-record (&optional full)
+ "Return the record point is at.
+If FULL is non-nil record includes the display information."
+ (unless (eq major-mode 'ebdb-mode)
+ (error "This only works while in EBDB buffers."))
+ (let ((num (get-text-property (if (and (not (bobp)) (eobp))
+ (1- (point)) (point))
+ 'ebdb-record-number))
+ record)
+ (unless num (error "Not a EBDB record"))
+ (setq record (nth num ebdb-records))
+ (if full record (car record))))
+
+(defun ebdb-current-field ()
+ "Return current field point is on."
+ (unless (ebdb-current-record) (error "Not a EBDB record"))
+ (or (get-text-property (point) 'ebdb-field)
+ (get-text-property
+ (next-single-property-change (line-beginning-position)
+ 'ebdb-field nil
+ (line-end-position))
+ 'ebdb-field)))
+
+;;; *EBDB* formatting
+
+(defclass ebdb-formatter-ebdb (ebdb-formatter)
+ nil
+ :documentation
+ "Abstract formatter base class for *EBDB* buffer(s)."
+ :abstract t)
+
+(defclass ebdb-formatter-ebdb-oneline (ebdb-formatter-ebdb)
+ nil
+ :documentation
+ "Single line formatter for *EBDB* buffers.")
+
+(defclass ebdb-formatter-ebdb-multiline (ebdb-formatter-ebdb)
+ nil
+ :documentation
+ "Multi-line formatter for *EBDB* buffers.")
+
+(defcustom ebdb-default-multiline-formatter
+ (make-instance 'ebdb-formatter-ebdb-multiline
+ :object-name "multiline formatter")
+ "The default multiline formatter for *EBDB* buffers."
+ :type 'ebdb-formatter-ebdb-multiline
+ :group 'ebdb-record-display)
+
+(defcustom ebdb-default-oneline-formatter
+ (make-instance 'ebdb-formatter-ebdb-oneline
+ :object-name "oneline formatter"
+ :include '(ebdb-field-mail))
+ "The default oneline formatter of *EBDB* buffers."
+ :type 'ebdb-formatter-ebdb-oneline
+ :group 'ebdb-record-display)
+
+(defun ebdb-available-ebdb-formatters ()
+ "A list of formatters available in the *EBDB* buffer.
+
+This list is also used for toggling layouts."
+ (seq-filter
+ (lambda (f) (object-of-class-p f 'ebdb-formatter-ebdb))
+ ebdb-formatter-tracker))
+
+(defsubst ebdb-formatter-prefix ()
+ "Select a formatter interactively using the prefix arg."
+ (cond (current-prefix-arg ebdb-default-oneline-formatter)
+ (t ebdb-default-multiline-formatter)))
+
+;; *EBDB* buffer formatting.
+
+(cl-defmethod ebdb-record-db-char-string ((record ebdb-record))
+ (let* ((dbs (slot-value (ebdb-record-cache record) 'database))
+ (char-string
+ (copy-sequence
+ (mapconcat
+ (lambda (d)
+ (when (slot-value d 'buffer-char)
+ (slot-value d 'buffer-char)))
+ dbs ""))))
+ (add-face-text-property 0 (length char-string) 'ebdb-db-char nil
char-string)
+ char-string))
+
+(cl-defmethod ebdb-fmt-field-label ((_fmt ebdb-formatter-ebdb)
+ (field ebdb-field-phone)
+ (_style (eql oneline))
+ (_record ebdb-record))
+ (format "phone (%s)" (eieio-object-name-string field)))
+
+(cl-defmethod ebdb-fmt-field-label ((_fmt ebdb-formatter-ebdb)
+ (field ebdb-field-address)
+ (_style (eql oneline))
+ (_record ebdb-record))
+ (format "address (%s)" (eieio-object-name-string field)))
+
+;; In these methods, `copy-sequence' is used because otherwise the
+;; text property is actually set on the field's slot value itself
+;; (which leads to it getting written to the database, ugh).
+
+(cl-defmethod ebdb-fmt-field :around ((_fmt ebdb-formatter-ebdb)
+ (field ebdb-field)
+ _style
+ (_record ebdb-record))
+ "Put the 'ebdb-field text property on FIELD. The value of the
+property is the field instance itself."
+ (let ((val-string (copy-sequence (cl-call-next-method))))
+ (put-text-property 0 (length val-string) 'ebdb-field field val-string)
+ val-string))
+
+(cl-defmethod ebdb-fmt-field ((_fmt ebdb-formatter-ebdb)
+ (field ebdb-field-url)
+ _style
+ (_record ebdb-record))
+ "Add an appropriate face to url fields."
+ (let ((value (copy-sequence (ebdb-string field))))
+ (add-face-text-property 0 (length value) 'ebdb-field-url nil value)
+ value))
+
+(cl-defmethod ebdb-fmt-field ((_fmt ebdb-formatter-ebdb)
+ (field ebdb-field-mail)
+ _style
+ (_record ebdb-record))
+ "Add an appropriate face to primary and defunct mails."
+ (let* ((priority (slot-value field 'priority))
+ (value (copy-sequence (ebdb-string field)))
+ (face (cond
+ ((eq priority 'primary) 'ebdb-mail-primary)
+ ((eq priority 'defunct) 'ebdb-defunct)
+ (t nil))))
+ (when face
+ (add-face-text-property 0 (length value) face nil value))
+ value))
+
+(cl-defmethod ebdb-fmt-field ((fmt ebdb-formatter-ebdb)
+ (field ebdb-field-role)
+ _style
+ (record ebdb-record-organization))
+ (let ((person (ebdb-gethash (slot-value field 'record-uuid) 'uuid))
+ (mail (slot-value field 'mail)))
+ (if mail
+ (format "%s (%s)"
+ (ebdb-string person)
+ (ebdb-fmt-field fmt mail 'oneline record))
+ (ebdb-string person))))
+
+(cl-defmethod ebdb-fmt-field ((fmt ebdb-formatter-ebdb)
+ (field ebdb-field-role)
+ _style
+ (record ebdb-record-person))
+ (let ((org (ebdb-gethash (slot-value field 'org-uuid) 'uuid))
+ (mail (slot-value field 'mail)))
+ (if mail
+ (format "%s (%s)"
+ (ebdb-string org)
+ (ebdb-fmt-field fmt mail 'oneline record))
+ (ebdb-string org))))
+
+(defsubst ebdb-indent-string (string column)
+ "Indent nonempty lines in STRING to COLUMN (except first line).
+This happens in addition to any pre-defined indentation of STRING."
+ (replace-regexp-in-string "\n\\([^\n]\\)"
+ (concat "\n" (make-string column ?\s) "\\1")
+ string))
+
+;;; Record display:
+;;; This inserts formatted (pieces of) records into the EBDB buffer.
+
+(cl-defmethod ebdb-fmt-record-body ((_fmt ebdb-formatter-ebdb-multiline)
+ (_record ebdb-record)
+ (field-list list))
+ (let* ((indent
+ (if field-list
+ (apply #'max (mapcar (lambda (f)
+ (string-width (car f)))
+ field-list))
+ 0))
+ (label-fmt (format " %%%ds" indent))
+ ;; `window-text-width' doesn't work for pop-up buffers,
+ ;; they're not displayed yet! How do we resolve this...?
+ (fill-column (window-text-width))
+ (fill-prefix (make-string (+ 3 indent) ?\s))
+ (paragraph-start "[^:]+:[^\n]+$"))
+
+ (dolist (c field-list)
+ (insert (format label-fmt (car c)))
+ (put-text-property (line-beginning-position) (point) 'face 'ebdb-label)
+ (insert
+ (concat
+ ": "
+ ;; If I understood the mechanics of filling better, I
+ ;; could probably do away with `ebdb-indent-string'
+ ;; altogether.
+ (ebdb-indent-string (cdr c) (+ indent 3))))
+ ;; If there are newlines in the value string, assume the field
+ ;; knows what's it's doing re filling and formatting.
+ (unless (or (string-match-p "\n" (cdr c))
+ (null ebdb-fill-field-values))
+ (fill-paragraph))
+ (insert "\n"))))
+
+(cl-defmethod ebdb-fmt-record-body ((_fmt ebdb-formatter-ebdb-oneline)
+ (_record ebdb-record)
+ (field-list list))
+ (insert " ")
+ (insert (mapconcat #'cdr field-list ", ")))
+
+(cl-defmethod ebdb-fmt-record-header ((_fmt ebdb-formatter-ebdb)
+ (record ebdb-record)
+ (field-list list))
+ "Insert header for RECORD."
+ ;; Name
+ (let ((record-class (eieio-object-class-name record))
+ (db-chars (ebdb-record-db-char-string record))
+ step)
+ (when db-chars
+ (insert db-chars " "))
+ (setq step (point))
+ (insert (slot-value (ebdb-record-cache record) 'name-string))
+ (add-text-properties (line-beginning-position) (point)
+ '(ebdb-record record-class))
+ (add-text-properties step (point)
+ (list
+ 'face (cdr (assoc record-class
ebdb-name-face-alist)))))
+ ;; Everything else
+ (when field-list
+ (insert " - ")
+ (insert
+ (mapconcat
+ (lambda (f)
+ ;; We need to special-case image field, because it is inserted
+ ;; differently. Conveniently, this also allows us to always
+ ;; keep the image at the end of the header.
+ (unless (eql (plist-get f :class) 'ebdb-field-image)
+ (cdr f)))
+ field-list
+ ", "))
+ ;; TODO: Check if image is in field-list, not if it exists!
+ (when (and (slot-boundp record 'image)
+ (slot-value record 'image)
+ (display-images-p))
+ (let ((image (ebdb-field-image-get (slot-value record 'image) record)))
+ (when image
+ (insert " ")
+ (insert-image image))))))
+
+(cl-defmethod ebdb-fmt-record-header :after ((_fmt
ebdb-formatter-ebdb-multiline)
+ (_record ebdb-record)
+ _field-list)
+ (insert "\n"))
+
+(cl-defmethod ebdb-fmt-record ((fmt ebdb-formatter-ebdb)
+ (record ebdb-record))
+ (let ((field-plist
+ (ebdb-fmt-process-fields
+ fmt record
+ (ebdb-fmt-sort-fields
+ fmt record
+ (ebdb-fmt-collect-fields
+ fmt record))))
+ (header-classes (cdr (assoc (eieio-object-class-name record)
+ (slot-value fmt 'header))))
+ header-fields body-fields)
+ (dolist (f field-plist)
+ (push (ebdb-fmt-compose-field fmt f record)
+ (if (ebdb-class-in-list-p (plist-get f :class) header-classes)
+ header-fields
+ body-fields)))
+ (ebdb-fmt-record-header
+ fmt
+ record
+ header-fields)
+
+ (ebdb-fmt-record-body
+ fmt
+ record
+ body-fields)
+ (insert "\n")))
+
+(defun ebdb-display-records (records &optional fmt append
+ select horiz-p)
+ "Display RECORDS using FMT.
+If APPEND is non-nil append RECORDS to the already displayed records.
+Otherwise RECORDS overwrite the displayed records.
+SELECT and HORIZ-P have the same meaning as in `ebdb-pop-up-window'."
+ (interactive (list (ebdb-completing-read-records "Display records: ")
+ (ebdb-formatter-prefix)))
+ (if (ebdb-append-display-p) (setq append t))
+ ;; `ebdb-redisplay-record' calls `ebdb-display-records'
+ ;; with display information already amended to RECORDS.
+ (unless (or (null records)
+ (consp (car records)))
+ ;; add fmt and a marker to the local list of records
+ (setq records (mapcar (lambda (record)
+ (list record fmt (make-marker) nil))
+ records)))
+
+ (let ((first-new (caar records)) ; first new record
+ new-name)
+
+ ;; If `ebdb-multiple-buffers' is non-nil we create a new EBDB buffer
+ ;; when not already within one. The new buffer name starts with a space,
+ ;; i.e. it does not clutter the buffer list.
+ (when (and ebdb-multiple-buffers
+ (not (assq 'ebdb-buffer-name (buffer-local-variables))))
+ (setq new-name (concat " *EBDB " (if (functionp ebdb-multiple-buffers)
+ (funcall ebdb-multiple-buffers)
+ (buffer-name))
+ "*"))
+ ;; `ebdb-buffer-name' becomes buffer-local in the current buffer
+ ;; as well as in the buffer `ebdb-buffer-name'
+ (set (make-local-variable 'ebdb-buffer-name) new-name))
+
+ (with-current-buffer (get-buffer-create ebdb-buffer-name) ; *EBDB*
+ ;; If we are appending RECORDS to the ones already displayed,
+ ;; then first remove any duplicates, and then sort them.
+ (if append
+ (let ((old-rec (mapcar 'car ebdb-records)))
+ (dolist (record records)
+ (unless (memq (car record) old-rec)
+ (push record ebdb-records)))
+ (setq records
+ (sort ebdb-records
+ (lambda (x y) (ebdb-record-lessp (car x) (car y)))))))
+
+ (ebdb-mode)
+ ;; Normally `ebdb-records' is the only EBDB-specific buffer-local
variable
+ ;; in the *EBDB* buffer. It is intentionally not permanent-local.
+ ;; A value of nil indicates that we need to (re)process the records.
+ (setq ebdb-records records)
+ (if new-name
+ (set (make-local-variable 'ebdb-buffer-name) new-name))
+
+ (unless (or ebdb-silent-internal ebdb-silent)
+ (message "Formatting EBDB..."))
+ (let ((record-number 0)
+ (fmt ebdb-default-multiline-formatter)
+ buffer-read-only all-records start)
+ (erase-buffer)
+ (ebdb-debug (setq all-records (ebdb-records)))
+ (insert (ebdb-fmt-header fmt records))
+ (dolist (record records)
+ (ebdb-debug (unless (memq (car record) all-records)
+ (error "Record %s does not exist" (car record))))
+ (setq start (set-marker (nth 2 record) (point)))
+ (ebdb-fmt-record fmt (car record))
+ (put-text-property start (point) 'ebdb-record-number record-number)
+ (setq record-number (1+ record-number)))
+ (insert (ebdb-fmt-footer fmt records))
+ (run-hooks 'ebdb-display-hook))
+
+ (unless (or ebdb-silent-internal ebdb-silent)
+ (message "Formatting EBDB...done."))
+ (set-buffer-modified-p nil)
+
+ (ebdb-pop-up-window select horiz-p)
+ (if (not first-new)
+ (goto-char (point-min))
+ ;; Put point on first new record in *EBDB* buffer.
+ (goto-char (nth 2 (assq first-new ebdb-records)))
+ (set-window-start (get-buffer-window (current-buffer)) (point))))))
+
+(defun ebdb-undisplay-records (&optional all-buffers)
+ "Undisplay records in *EBDB* buffer, leaving this buffer empty.
+If ALL-BUFFERS is non-nil undisplay records in all EBDB buffers."
+ (dolist (buffer (cond (all-buffers (buffer-list))
+ ((let ((buffer (get-buffer ebdb-buffer-name)))
+ (and (buffer-live-p buffer) (list buffer))))))
+ (with-current-buffer buffer
+ (when (eq major-mode 'ebdb-mode)
+ (let (buffer-read-only)
+ (erase-buffer))
+ (setq ebdb-records nil)
+ (set-buffer-modified-p nil)))))
+
+(defun ebdb-redisplay-record (record &optional sort delete-p)
+ "Redisplay RECORD in current EBDB buffer.
+If SORT is t, usually because RECORD has a new sortkey, re-sort
+the displayed records.
+If DELETE-P is non-nil RECORD is removed from the EBDB buffer."
+ ;; For deletion in the *EBDB* buffer we use the full information
+ ;; about the record in the database. Therefore, we need to delete
+ ;; the record in the *EBDB* buffer before deleting the record in
+ ;; the database.
+ (let ((full-record (assq record ebdb-records)))
+ (unless full-record
+ (error "Record `%s' not displayed" (ebdb-record-name record)))
+ (if (and sort (not delete-p))
+ ;; FIXME: For records requiring re-sorting it may be more efficient
+ ;; to insert these records in their proper location instead of
+ ;; re-displaying all records.
+ (ebdb-display-records (list record) nil t)
+ (let ((marker (nth 2 full-record))
+ (end-marker (nth 2 (car (cdr (memq full-record ebdb-records)))))
+ (fmt (nth 1 full-record))
+ buffer-read-only record-number)
+ ;; If point is inside record, put it at the beginning of the record.
+ (if (and (<= marker (point))
+ (< (point) (or end-marker (point-max))))
+ (goto-char marker))
+ (save-excursion
+ (goto-char marker)
+ (setq record-number (get-text-property (point) 'ebdb-record-number))
+ (unless delete-p
+ ;; First insert the reformatted record, then delete the old one,
+ ;; so that the marker of this record cannot collapse with the
+ ;; marker of the subsequent record
+ (ebdb-fmt-record fmt (car full-record))
+ (put-text-property marker (point) 'ebdb-record-number record-number)
+ (when (eq (nth 3 full-record) 'mark)
+ (add-face-text-property
+ marker
+ (next-property-change marker nil (line-end-position) )
+ 'ebdb-marked)))
+ (delete-region (point) (or end-marker (point-max)))
+ ;; If we deleted a record we need to update the subsequent
+ ;; record numbers.
+ (when delete-p
+ (let* ((markers (append (mapcar (lambda (x) (nth 2 x))
+ (cdr (memq full-record
ebdb-records)))
+ (list (point-max))))
+ (start (pop markers)))
+ (dolist (end markers)
+ (put-text-property start end
+ 'ebdb-record-number record-number)
+ (setq start end
+ record-number (1+ record-number))))
+ (setq ebdb-records (delq full-record ebdb-records)))
+ (run-hooks 'ebdb-display-hook))))))
+
+(defun ebdb-redisplay-record-globally (record &optional sort delete-p)
+ "Redisplay RECORD in all EBDB buffers.
+If SORT is t, usually because RECORD has a new sortkey, re-sort
+the displayed records.
+If DELETE-P is non-nil RECORD is removed from the EBDB buffers."
+ (dolist (buffer (buffer-list))
+ (with-current-buffer buffer
+ (if (and (eq major-mode 'ebdb-mode)
+ (memq record (mapcar 'car ebdb-records)))
+ (let ((window (get-buffer-window ebdb-buffer-name)))
+ (if window
+ (with-selected-window window
+ (ebdb-redisplay-record record sort delete-p))
+ (ebdb-redisplay-record record sort delete-p)))))))
+
+(easy-menu-define
+ ebdb-menu ebdb-mode-map "EBDB Menu"
+ '("EBDB"
+ ("Display"
+ ["Previous field" ebdb-prev-field t]
+ ["Next field" ebdb-next-field t]
+ ["Previous record" ebdb-prev-record t]
+ ["Next record" ebdb-next-record t]
+ "--"
+ ["Show all records" ebdb-display-all-records t]
+ ["Show current record" ebdb-display-current-record t]
+ ["Omit record" ebdb-omit-record t]
+ ["Toggle record mark" ebdb-toggle-record-mark t]
+ "--"
+ ["Toggle layout" ebdb-toggle-records-format t]
+ ["Show all fields" ebdb-display-records-completely t])
+ ("Searching"
+ ["General search" ebdb t]
+ ["Search one record" ebdb-display-records t]
+ ["Search name" ebdb-search-name t]
+ ["Search organization" ebdb-search-organization t]
+ ["Search phone" ebdb-search-phone t]
+ ["Search address" ebdb-search-address t]
+ ["Search mail" ebdb-search-mail t]
+ ["Search xfields" ebdb-search-xfields t]
+ ["Search changed records" ebdb-search-changed t]
+ ["Search duplicates" ebdb-search-duplicates t]
+ "--"
+ ["Old time stamps" ebdb-timestamp-older t]
+ ["New time stamps" ebdb-timestamp-newer t]
+ ["Old creation date" ebdb-creation-older t]
+ ["New creation date" ebdb-creation-newer t]
+ ["Creation date = time stamp" ebdb-creation-no-change t]
+ "--"
+ ["Append search" ebdb-append-display t]
+ ["Invert search" ebdb-search-invert t])
+ ("Mail"
+ ["Send mail" ebdb-mail t]
+ ["Save mail address" ebdb-mail-address t]
+ "--"
+ ["Add mail alias" ebdb-add-mail-alias t]
+ ["(Re-)Build mail aliases" ebdb-mail-aliases t])
+ ("Use database"
+ ["Prefix: do all records" ebdb-do-all-records t]
+ "--"
+ ["Send mail" ebdb-mail t]
+ ["Dial phone number" ebdb-dial t]
+ ["Browse URL" ebdb-browse-url t]
+ ["Copy records as kill" ebdb-copy-records-as-kill t]
+ ["Copy fields as kill" ebdb-copy-fields-as-kill t]
+ ["Follow relation" ebdb-follow-related t]
+ "--"
+ ["Print records" ebdb-print t])
+ ("Manipulate database"
+ ["Prefix: do all records" ebdb-do-all-records t]
+ "--"
+ ["Create new record" ebdb-create t]
+ ["Edit current field" ebdb-edit-field t]
+ ["Insert new field" ebdb-insert-field t]
+ ["Edit some field" ebdb-edit-foo t]
+ ["Transpose fields" ebdb-transpose-fields t]
+ ["Delete record or field" ebdb-delete-field-or-record t]
+ "--"
+ ["Sort addresses" ebdb-sort-addresses t]
+ ["Sort phones" ebdb-sort-phones t]
+ ["Sort xfields" ebdb-sort-xfields t]
+ ["Merge records" ebdb-merge-records t]
+ ["Sort database" ebdb-sort-records t]
+ ["Delete duplicate mails" ebdb-delete-redundant-mails t]
+ "--"
+ ["Save EBDB" ebdb-save t]
+ ["Revert EBDB" revert-buffer t])
+ ("Help"
+ ["Brief help" ebdb-help t]
+ ["EBDB Manual" ebdb-info t])
+ "--"
+ ["Quit" quit-window t]))
+
+(defvar ebdb-completing-read-mails-map
+ (let ((map (copy-keymap minibuffer-local-completion-map)))
+ (define-key map " " 'self-insert-command)
+ (define-key map "\t" 'ebdb-complete-mail)
+ (define-key map "\M-\t" 'ebdb-complete-mail)
+ map)
+ "Keymap used by `ebdb-completing-read-mails'.")
+
+;;; window configuration hackery
+(defun ebdb-pop-up-window (&optional select horiz-p)
+ "Display *EBDB* buffer by popping up a new window.
+Finds the largest window on the screen, splits it, displaying the
+*EBDB* buffer in the bottom `ebdb-pop-up-window-size' lines (unless
+the *EBDB* buffer is already visible, in which case do nothing.)
+Select this window if SELECT is non-nil.
+
+If `ebdb-mua-pop-up' is 'horiz, and the first window matching
+the predicate HORIZ-P is wider than the car of `ebdb-horiz-pop-up-window-size'
+then the window will be split horizontally rather than vertically."
+ (let ((buffer (get-buffer ebdb-buffer-name)))
+ (unless buffer
+ (error "No %s buffer to display" ebdb-buffer-name))
+ (cond ((let ((window (get-buffer-window buffer t)))
+ ;; We already have a EBDB window so that at most we select it
+ (and window
+ (or (not select) (select-window window)))))
+
+ ;; try horizontal split
+ ((and horiz-p
+ (>= (frame-width) (car ebdb-horiz-pop-up-window-size))
+ (let ((window-list (window-list))
+ (b-width (cdr ebdb-horiz-pop-up-window-size))
+ (search t) s-window)
+ (while (and (setq s-window (pop window-list))
+ (setq search (not (funcall horiz-p s-window)))))
+ (unless (or search (<= (window-width s-window)
+ (car ebdb-horiz-pop-up-window-size)))
+ (condition-case nil ; `split-window' might fail
+ (let ((window (split-window
+ s-window
+ (if (integerp b-width)
+ (- (window-width s-window) b-width)
+ (round (* (- 1 b-width) (window-width
s-window))))
+ t))) ; horizontal split
+ (set-window-buffer window buffer)
+ (cond (ebdb-dedicated-window
+ (set-window-dedicated-p window
ebdb-dedicated-window))
+ ((fboundp 'display-buffer-record-window) ; GNU
Emacs >= 24.1
+ (set-window-prev-buffers window nil)
+ (display-buffer-record-window 'window window
buffer)))
+ (if select (select-window window))
+ t)
+ (error nil))))))
+
+ ((eq t ebdb-pop-up-window-size)
+ (ebdb-pop-up-window-simple buffer select))
+
+ (t ;; vertical split
+ (let* ((window (selected-window))
+ (window-height (window-height window)))
+ ;; find the tallest window...
+ (mapc (lambda (w)
+ (let ((w-height (window-height w)))
+ (if (> w-height window-height)
+ (setq window w window-height w-height))))
+ (window-list))
+ (condition-case nil
+ (progn
+ (unless (eql ebdb-pop-up-window-size 1.0)
+ (setq window (split-window ; might fail
+ window
+ (if (integerp ebdb-pop-up-window-size)
+ (- window-height 1 ; for mode line
+ (max window-min-height
ebdb-pop-up-window-size))
+ (round (* (- 1 ebdb-pop-up-window-size)
+ window-height))))))
+ (set-window-buffer window buffer) ; might fail
+ (cond (ebdb-dedicated-window
+ (set-window-dedicated-p window
ebdb-dedicated-window))
+ ((and (fboundp 'display-buffer-record-window) ; GNU
Emacs >= 24.1
+ (not (eql ebdb-pop-up-window-size 1.0)))
+ (set-window-prev-buffers window nil)
+ (display-buffer-record-window 'window window
buffer)))
+ (if select (select-window window)))
+ (error (ebdb-pop-up-window-simple buffer select))))))))
+
+(defun ebdb-pop-up-window-simple (buffer select)
+ "Display BUFFER in some window, selecting it if SELECT is non-nil.
+If `ebdb-dedicated-window' is non-nil, mark the window as dedicated."
+ (let ((window (if select
+ (progn (pop-to-buffer buffer)
+ (get-buffer-window))
+ (display-buffer buffer))))
+ (if ebdb-dedicated-window
+ (set-window-dedicated-p window ebdb-dedicated-window))))
+
+
+;;; EBDB mode
+
+;;;###autoload
+(define-derived-mode ebdb-mode special-mode "EBDB"
+ "Major mode for viewing and editing the Insidious Big Brother Database.
+Letters no longer insert themselves. Numbers are prefix arguments.
+You can move around using the usual cursor motion commands.
+\\<ebdb-mode-map>
+\\[ebdb-add-mail-alias]\t Add new mail alias to visible records or \
+remove it.
+\\[ebdb-edit-field]\t Edit the field on the current line.
+\\[ebdb-delete-field-or-record]\t Delete the field on the \
+current line. If the current line is the\n\t first line of a record, then \
+delete the entire record.
+\\[ebdb-insert-field]\t Insert a new field into the current record. \
+Note that this\n\t will let you add new fields of your own as well.
+\\[ebdb-transpose-fields]\t Swap the field on the current line with the \
+previous field.
+\\[ebdb-dial]\t Dial the current phone field.
+\\[ebdb-next-record], \\[ebdb-prev-record]\t Move to the next or the previous \
+displayed record, respectively.
+\\[ebdb-create]\t Create a new record.
+\\[ebdb-toggle-records-format]\t Toggle whether the current record is
displayed in a \
+one-line\n\t listing, or a full multi-line listing.
+\\[ebdb-do-all-records]\\[ebdb-toggle-records-format]\t Do that \
+for all displayed records.
+\\[ebdb-merge-records]\t Merge the contents of the current record with \
+some other, and then\n\t delete the current record.
+\\[ebdb-omit-record]\t Remove the current record from the display without \
+deleting it from\n\t the database. This is often a useful thing to do \
+before using one\n\t of the `*' commands.
+\\[ebdb]\t Search for records in the database (on all fields).
+\\[ebdb-search-mail]\t Search for records by mail address.
+\\[ebdb-search-organization]\t Search for records by organization.
+\\[ebdb-search-xfields]\t Search for records by xfields.
+\\[ebdb-search-name]\t Search for records by name.
+\\[ebdb-search-changed]\t Display records that have changed since the database
\
+was saved.
+\\[ebdb-mail]\t Compose mail to the person represented by the \
+current record.
+\\[ebdb-do-all-records]\\[ebdb-mail]\t Compose mail \
+to everyone whose record is displayed.
+\\[ebdb-save]\t Save the EBDB file to disk.
+\\[ebdb-print]\t Create a TeX file containing a pretty-printed version \
+of all the\n\t records in the database.
+\\[ebdb-do-all-records]\\[ebdb-print]\t Do that for the \
+displayed records only.
+\\[other-window]\t Move to another window.
+\\[ebdb-info]\t Read the Info documentation for EBDB.
+\\[ebdb-help]\t Display a one line command summary in the echo area.
+\\[ebdb-browse-url]\t Visit Web sites listed in the `url' field(s) of the
current \
+record.
+
+For address completion using the names and mail addresses in the database:
+\t in Sendmail mode, type \\<mail-mode-map>\\[ebdb-complete-mail].
+\t in Message mode, type \\<message-mode-map>\\[ebdb-complete-mail].
+
+Important variables:
+\t `ebdb-auto-revert'
+\t `ebdb-ignore-redundant-mails'
+\t `ebdb-case-fold-search'
+\t `ebdb-completion-list'
+\t `ebdb-default-domain'
+\t `ebdb-layout'
+\t `ebdb-file'
+\t `ebdb-check-auto-save-file'
+\t `ebdb-pop-up-layout'
+\t `ebdb-pop-up-window-size'
+\t `ebdb-add-name'
+\t `ebdb-add-aka'
+\t `ebdb-add-mails'
+\t `ebdb-new-mails-primary'
+\t `ebdb-read-only'
+\t `ebdb-mua-pop-up'
+\t `ebdb-user-mail-address-re'
+
+There are numerous hooks. M-x apropos ^ebdb.*hook RET
+
+\\{ebdb-mode-map}"
+ (setq truncate-lines t
+ mode-line-buffer-identification
+ (list 24 (buffer-name) " "
+ '(:eval (format "%d/%d/%d"
+ (1+ (or (get-text-property
+ (point) 'ebdb-record-number) -1))
+ (length ebdb-records)
+ (length (ebdb-records))))
+ '(:eval (concat " "
+ (ebdb-concat " " (elt ebdb-modeline-info 0)
+ (elt ebdb-modeline-info 2)))))
+ mode-line-modified
+ ;; For the mode-line we want to be fast. So we skip the checks
+ ;; performed by `ebdb-with-db-buffer'.
+ '(:eval (if (object-assoc t 'dirty ebdb-db-list) "**" "--")))
+ ;; `ebdb-revert-buffer' acts on `ebdb-buffer'. Yet this command is usually
+ ;; called from the *EBDB* buffer.
+ ;; (set (make-local-variable 'revert-buffer-function)
+ ;; 'ebdb-revert-buffer)
+ (add-hook 'post-command-hook 'force-mode-line-update nil t))
+
+
+
+(defun ebdb-sendmail-menu (record)
+ "Menu items for email addresses of RECORD."
+ (let ((mails (ebdb-record-mail record)))
+ (list
+ (if (cdr mails)
+ ;; Submenu for multiple mail addresses
+ (cons "Send mail to..."
+ (mapcar (lambda (address)
+ (vector address `(ebdb-compose-mail
+ ,(ebdb-dwim-mail record address))
+ t))
+ mails))
+ ;; Single entry for single mail address
+ (vector (concat "Send mail to " (car mails))
+ `(ebdb-compose-mail ,(ebdb-dwim-mail record (car mails)))
+ t)))))
+
+;; (defun ebdb-field-menu (record field)
+;; "Menu items specifically for FIELD of RECORD."
+;; (let ((type (car field)))
+;; (append
+;; (list
+;; (format "Commands for %s Field:"
+;; (cond ((eq type 'xfields)
+;; (format "\"%s\"" (symbol-name (car (nth 1 field)))))
+;; ((eq type 'name) "Name")
+;; ((eq type 'affix) "Affix")
+;; ((eq type 'organization) "Organization")
+;; ((eq type 'aka) "Alternate Names")
+;; ((eq type 'mail) "Mail Addresses")
+;; ((memq type '(address phone))
+;; (format "\"%s\" %s" (aref (nth 1 field) 0)
+;; (capitalize (symbol-name type)))))))
+;; (cond ((eq type 'phone)
+;; (list (vector (concat "Dial " (ebdb-string (nth 1 field)))
+;; `(ebdb-dial ',field nil) t)))
+;; ((eq type 'xfields)
+;; (let* ((field (cadr field))
+;; (type (car field)))
+;; (cond ((eq type 'url )
+;; (list (vector (format "Browse \"%s\"" (cdr field))
+;; `(ebdb-browse-url ,record) t)))))))
+;; '(["Edit Field" ebdb-edit-field t])
+;; (unless (eq type 'name)
+;; '(["Delete Field" ebdb-delete-field-or-record t])))))
+
+(defun ebdb-insert-field-menu (record)
+ "Submenu for inserting a new field for RECORD."
+ (cons "Insert New Field..."
+ (mapcar
+ (lambda (field)
+ (if (stringp field) field
+ (vector (symbol-name field)
+ `(ebdb-insert-field
+ ,record ',field (ebdb-read-field ,record ',field
+ ,current-prefix-arg))
+ (not (or (and (eq field 'organization)
+ (ebdb-record-organizations record))
+ (and (eq field 'mail) (ebdb-record-mail record))
+ (and (eq field 'aka) (ebdb-record-aka record))
+ (assq field (ebdb-record-user-fields
record)))))))
+ (append '(affix organization aka phone address mail)
+ '("--") ebdb-user-label-list))))
+
+(defun ebdb-mouse-menu (event)
+ "EBDB mouse menu for EVENT,"
+ (interactive "e")
+ (mouse-set-point event)
+ (let* ((record (ebdb-current-record))
+ (field (ebdb-current-field))
+ (menu (if (and record field (functionp ebdb-user-menu-commands))
+ (funcall ebdb-user-menu-commands record field)
+ ebdb-user-menu-commands)))
+ (if record
+ (popup-menu
+ (append
+ (list
+ (format "Commands for record \"%s\":" (ebdb-record-name record))
+ ["Delete Record" ebdb-delete-records t]
+ ["Toggle Record Display Layout" ebdb-toggle-records-format t]
+ ["Fully Display Record" ebdb-display-records-completely t]
+ ["Omit Record" ebdb-omit-record t]
+ ["Merge Record" ebdb-merge-records t])
+ (if (ebdb-record-mail record)
+ (ebdb-sendmail-menu record))
+ (list "--" (ebdb-insert-field-menu record))
+ (if field
+ (cons "--" (ebdb-field-menu record field)))
+ (if menu
+ (append '("--" "User Defined Commands") menu)))))))
+
+(defun ebdb-scan-property (property predicate n)
+ "Scan for change of PROPERTY matching PREDICATE for N times.
+Return position of beginning of matching interval."
+ (let ((fun (if (< 0 n) 'next-single-property-change
+ 'previous-single-property-change))
+ (limit (if (< 0 n) (point-max) (point-min)))
+ (nn (abs n))
+ (i 0)
+ (opoint (point))
+ npoint)
+ ;; For backward search, move point to beginning of interval with PROPERTY.
+ (if (and (<= n 0)
+ (< (point-min) opoint)
+ (let ((prop (get-text-property opoint property)))
+ (and (eq prop (get-text-property (1- opoint) property))
+ (funcall predicate prop))))
+ (setq opoint (previous-single-property-change opoint property nil
limit)))
+ (if (zerop n)
+ opoint ; Return beginning of interval point is in
+ (while (and (< i nn)
+ (let (done)
+ (while (and (not done)
+ (setq npoint (funcall fun opoint property nil
limit)))
+ (cond ((and (/= opoint npoint)
+ (funcall predicate (get-text-property
+ npoint property)))
+ (setq opoint npoint done t))
+ ((= opoint npoint)
+ ;; Search reached beg or end of buffer: abort.
+ (setq done t i nn npoint nil))
+ (t (setq opoint npoint))))
+ done))
+ (setq i (1+ i)))
+ npoint)))
+
+(defun ebdb-next-record (n)
+ "Move point to the beginning of the next EBDB record.
+With prefix N move forward N records."
+ (interactive "p")
+ (let ((npoint (ebdb-scan-property 'ebdb-record-number 'integerp n)))
+ (if npoint (goto-char npoint)
+ (error "No %s record" (if (< 0 n) "next" "previous")))))
+
+(defun ebdb-prev-record (n)
+ "Move point to the beginning of the previous EBDB record.
+With prefix N move backwards N records."
+ (interactive "p")
+ (ebdb-next-record (- n)))
+
+(defun ebdb-next-field (n)
+ "Move point to next (sub)field.
+With prefix N move forward N (sub)fields."
+ (interactive "p")
+ (let ((npoint (ebdb-scan-property
+ 'ebdb-field
+ ;; TODO: This is unnecessary.
+ #'identity
+ n)))
+ (if npoint (goto-char npoint)
+ (error "No %s field" (if (< 0 n) "next" "previous")))))
+
+(defun ebdb-prev-field (n)
+ "Move point to previous (sub)field.
+With prefix N move backwards N (sub)fields."
+ (interactive "p")
+ (ebdb-next-field (- n)))
+
+(defun ebdb-follow-related (record field)
+ "If point is on a role or relationship field, display the
+ related record."
+ (interactive (list (ebdb-current-record)
+ (ebdb-current-field)))
+ (let ((related (ebdb-record-related record field)))
+ (if related
+ (ebdb-display-records (cons related
+ (mapcar #'car ebdb-records))
+ ebdb-default-multiline-formatter
+ t)
+ (message "Field %s provides no relationships"
+ (ebdb-field-readable-name field)))))
+
+(defun ebdb-toggle-record-mark (record &optional mark)
+ "Mark or unmark RECORD."
+ (interactive
+ (list (ebdb-current-record t)
+ 'mark))
+ (setf (nth 3 record) (if (nth 3 record) nil mark))
+ (ebdb-redisplay-record (car record)))
+
+(defun ebdb-toggle-all-record-marks ()
+ "Reverse the marked status of all records."
+ (interactive)
+ (mapcar
+ (lambda (rec)
+ (ebdb-toggle-record-mark rec 'mark))
+ ebdb-records))
+
+
+;; clean-up functions
+
+;;; Sometimes one gets mail from address@hidden, and then later gets mail
+;;; from address@hidden At this point, one would like to delete the
bar.baz.com
+;;; address, since the baz.com address is obviously superior.
+
+(defun ebdb-mail-redundant-re (mail)
+ "Return a regexp matching redundant variants of email address MAIL.
+For example, \"address@hidden" is redundant w.r.t. \"address@hidden".
+Return nil if MAIL is not a valid plain email address.
+In particular, ignore addresses \"Joe Smith <address@hidden>\"."
+ (let* ((match (string-match "\\`\\([^ ]+\\)@\\(.+\\)\\'" mail))
+ (name (and match (match-string 1 mail)))
+ (host (and match (match-string 2 mail))))
+ (if (and name host)
+ (concat (regexp-quote name) "@.*\\." (regexp-quote host)))))
+
+(defun ebdb-delete-redundant-mails (records &optional query update)
+ "Delete redundant or duplicate mails from RECORDS.
+For example, \"address@hidden" is redundant w.r.t. \"address@hidden".
+Duplicates may (but should not) occur if we feed EBDB automatically.
+Interactively, use EBDB prefix \
+\\<ebdb-mode-map>\\[ebdb-do-all-records], see `ebdb-do-all-records'.
+If QUERY is non-nil (as in interactive calls, unless we use a prefix arg)
+query before deleting the redundant mail addresses.
+If UPDATE is non-nil (as in interactive calls) update the database.
+Otherwise, this is the caller's responsiblity.
+
+Noninteractively, this may be used as an element of `ebdb-notice-record-hook'
+or `ebdb-change-hook'. However, see also `ebdb-ignore-redundant-mails',
+which is probably more suited for your needs."
+ (interactive (list (ebdb-do-records) (not current-prefix-arg) t))
+ (dolist (record (ebdb-record-list records))
+ (let (mails redundant okay)
+ ;; We do not look at the canonicalized mail addresses of RECORD.
+ ;; An address "Joe Smith <address@hidden>" can only be entered manually
+ ;; into EBDB, and we assume that this is what the user wants.
+ ;; Anyway, if a mail field contains all the elements
+ ;; address@hidden, "Joe Smith <address@hidden>", "Jonathan Smith
<address@hidden>"
+ ;; we do not know which address to keep and which ones to throw.
+ (dolist (mail (ebdb-record-mail record))
+ (if (assoc-string mail mails t) ; duplicate mail address
+ (push mail redundant)
+ (push mail mails)))
+ (let ((mail-re (delq nil (mapcar 'ebdb-mail-redundant-re mails)))
+ (case-fold-search t))
+ (if (not (cdr mail-re)) ; at most one mail-re address to consider
+ (setq okay (nreverse mails))
+ (setq mail-re (concat "\\`\\(?:" (mapconcat 'identity mail-re "\\|")
+ "\\)\\'"))
+ (dolist (mail mails)
+ (if (string-match mail-re mail) ; redundant mail address
+ (push mail redundant)
+ (push mail okay)))))
+ (let ((form (format "redundant mail%s %s"
+ (if (< 1 (length redundant)) "s" "")
+ (ebdb-concat 'mail (nreverse redundant)))))
+ (when (and redundant
+ (or (not query)
+ (y-or-n-p (format "Delete %s: " form))))
+ (unless query (message "Deleting %s" form))
+ (ebdb-record-set-field record 'mail okay)
+ (when update
+ (ebdb-change-record record)))))))
+
+(defun ebdb-search-duplicates (&optional fields)
+ "Search all records that have duplicate entries for FIELDS.
+The list FIELDS may contain the symbols `name', `mail', and `aka'.
+If FIELDS is nil use all these fields. With prefix, query for FIELDS.
+The search results are displayed in the EBDB buffer."
+ (interactive (list (if current-prefix-arg
+ (list (intern (completing-read "Field: "
+ '("name" "mail" "aka")
+ nil t))))))
+ (setq fields (or fields '(name mail aka)))
+ (let (hash ret)
+ (dolist (record (ebdb-records))
+
+ (when (and (memq 'name fields)
+ (ebdb-record-name record)
+ (setq hash (ebdb-gethash (ebdb-record-name record)
+ '(fl-name lf-name aka)))
+ (> (length hash) 1))
+ (setq ret (append hash ret))
+ (message "EBDB record `%s' has duplicate name."
+ (ebdb-record-name record))
+ (sit-for 0))
+
+ (if (memq 'mail fields)
+ (dolist (mail (ebdb-record-mail-canon record))
+ (setq hash (ebdb-gethash mail '(mail)))
+ (when (> (length hash) 1)
+ (setq ret (append hash ret))
+ (message "EBDB record `%s' has duplicate mail `%s'."
+ (ebdb-record-name record) mail)
+ (sit-for 0))))
+
+ (if (memq 'aka fields)
+ (dolist (aka (ebdb-record-aka record))
+ (setq hash (ebdb-gethash aka '(fl-name lf-name aka)))
+ (when (> (length hash) 1)
+ (setq ret (append hash ret))
+ (message "EBDB record `%s' has duplicate aka `%s'"
+ (ebdb-record-name record) aka)
+ (sit-for 0)))))
+
+ (ebdb-display-records (sort (delete-dups ret)
+ 'ebdb-record-lessp))))
+
+(defun ebdb-touch-records (records)
+ "Touch RECORDS by calling `ebdb-change-hook' unconditionally."
+ (interactive (list (ebdb-do-records)))
+ (dolist (record (ebdb-record-list records))
+ (setf (slot-value record 'dirty) t)))
+
+;;; Time-based functions
+
+(defmacro ebdb-compare-records (cmpval label compare)
+ "Builds a lambda comparison function that takes one argument, RECORD.
+RECORD is returned if (COMPARE VALUE CMPVAL) is t, where VALUE
+is the value of xfield LABEL of RECORD."
+ `(lambda (record)
+ (let ((val (ebdb-record-field record ,label)))
+ (if (and val (,compare val ,cmpval))
+ record))))
+
+(defsubst ebdb-string> (a b)
+ (not (or (string= a b)
+ (string< a b))))
+
+;;;###autoload
+(defun ebdb-timestamp-older (date &optional fmt)
+ "Display records with timestamp older than DATE.
+DATE must be in yyyy-mm-dd format."
+ (interactive (list (read-string "Older than date (yyyy-mm-dd): ")
+ (ebdb-formatter-prefix)))
+ (ebdb-search-prog (ebdb-compare-records date 'timestamp 'time-less-p) fmt))
+
+;;;###autoload
+(defun ebdb-timestamp-newer (date &optional fmt)
+ "Display records with timestamp newer than DATE.
+DATE must be in yyyy-mm-dd format."
+ (interactive (list (read-string "Newer than date (yyyy-mm-dd): ")
+ (ebdb-formatter-prefix)))
+ (ebdb-search-prog (ebdb-compare-records date 'timestamp
+ (lambda (l r) (null (time-less-p l
r))))
+ fmt))
+
+;;;###autoload
+(defun ebdb-creation-older (date &optional fmt)
+ "Display records with creation-date older than DATE.
+DATE must be in yyyy-mm-dd format."
+ (interactive (list (read-string "Older than date (yyyy-mm-dd): ")
+ (ebdb-formatter-prefix)))
+ (ebdb-search-prog (ebdb-compare-records date 'creation-date string<) fmt))
+
+;;;###autoload
+(defun ebdb-creation-newer (date &optional fmt)
+ "Display records with creation-date newer than DATE.
+DATE must be in yyyy-mm-dd format."
+ (interactive (list (read-string "Newer than date (yyyy-mm-dd): ")
+ (ebdb-formatter-prefix)))
+ (ebdb-search-prog (ebdb-compare-records date 'creation-date ebdb-string>)
fmt))
+
+;;;###autoload
+(defun ebdb-creation-no-change (&optional fmt)
+ "Display records that have the same timestamp and creation-date."
+ (interactive (list (ebdb-formatter-prefix)))
+ (ebdb-search-prog
+ ;; RECORD is bound in `ebdb-search-prog'.
+ (ebdb-compare-records (ebdb-record-field record 'timestamp)
+ 'creation-date 'equal) fmt))
+
+;;; Parsing phone numbers
+;;; XXX this needs expansion to handle international prefixes properly
+;;; i.e. +353-number without discarding the +353 part. Problem being
+;;; that this will necessitate yet another change in the database
+;;; format for people who are using north american numbers.
+
+(defsubst ebdb-subint (string num)
+ "Used for parsing phone numbers."
+ (string-to-number (match-string num string)))
+
+(defun ebdb-message-search (name mail)
+ "Return list of EBDB records matching NAME and/or MAIL.
+First try to find a record matching both NAME and MAIL.
+If this fails try to find a record matching MAIL.
+If this fails try to find a record matching NAME.
+NAME may match FIRST_LAST, LAST_FIRST or AKA.
+
+This function performs a fast search using `ebdb-hashtable'.
+NAME and MAIL must be strings or nil.
+See `ebdb-search' for searching records with regexps."
+ (when (or name mail)
+ (unless ebdb-db-list
+ (ebdb-load))
+ (let ((mrecords (if mail (ebdb-gethash mail '(mail))))
+ (nrecords (if name (ebdb-gethash name '(fl-name lf-name aka)))))
+ ;; (1) records matching NAME and MAIL
+ (or (and mrecords nrecords
+ (let (records)
+ (dolist (record nrecords)
+ (mapc (lambda (mr) (if (and (eq record mr)
+ (not (memq record records)))
+ (push record records)))
+ mrecords))
+ records))
+ ;; (2) records matching MAIL
+ mrecords
+ ;; (3) records matching NAME
+ nrecords))))
+
+(defmacro ebdb-with-record-edits (spec &rest body)
+ "Run BODY on all records listed in the cdr of SPEC.
+
+This macro checks that each record is editable; ie, that it
+doesn't belong to a read-only database. It also throws an error
+and bails out if any of the database are unsynced.
+
+Then bind each editable record to the car of SPEC in turn, run
+`ebdb-change-hook' on the record, excecute BODY, run
+`ebdb-after-change-hook', and redisplay the record.
+
+SPEC should look like the first argument to `dolist'. This macro
+should be called as:
+
+\(ebdb-with-record-edits (r record-list)
+ ...\)
+
+Note that RECORD-LIST will be replaced with the list of
+actually-editable records."
+ (declare (indent 1) (debug ((symbolp form) body)))
+ (let ((editable-records (cl-gensym))
+ (bad-dbs (cl-gensym))
+ (good-dbs (cl-gensym))
+ (fields-from-head (cl-gensym)))
+ `(let ((,fields-from-head 0)
+ ,editable-records ,bad-dbs ,good-dbs)
+ ;; This is a trick for keeping point from jumping all over the
+ ;; place when fields are added/deleted/edited. We record how
+ ;; many fields away from the record header point is, and after
+ ;; the editing process we go to that number again.
+ (save-excursion
+ (while (null (get-text-property (line-beginning-position)
'ebdb-record))
+ (condition-case nil
+ (ebdb-prev-field 1)
+ (error (forward-line -1)))
+ (cl-incf ,fields-from-head)))
+ (dolist (r ,(nth 1 spec))
+ (unless
+ ;; "Unless the record has a bum database..."
+ (catch 'bad
+ ;; Return nil unless we throw a 'bad.
+ (dolist (d (slot-value (ebdb-record-cache r) 'database) nil)
+ (cond ((object-assoc (slot-value d 'file) 'file ,good-dbs))
+ ((object-assoc (slot-value d 'file) 'file ,bad-dbs)
+ (throw 'bad t))
+ (t
+ (if (ebdb-db-editable d t t)
+ (push d ,good-dbs)
+ (push d ,bad-dbs)
+ (throw 'bad t))))))
+ ;; No bum database, it's okay.
+ (push r ,editable-records)))
+ (dolist (,(car spec) ,editable-records)
+ (run-hook-with-args 'ebdb-change-hook ,(car spec))
+ ,@body
+ (run-hook-with-args 'ebdb-after-change-hook ,(car spec))
+ (ebdb-redisplay-record-globally ,(car spec)))
+ (dotimes (_i ,fields-from-head)
+ (ebdb-next-field 1)))))
+
+;;;###autoload
+(defun ebdb-create (arg &optional db record-class)
+ "Create a new EBDB record.
+
+With no prefix argument, assume that we're creating a record in
+the first database found in `ebdb-db-list', using its default
+record class.
+
+With a prefix arg, prompt for the database to use (assuming there
+is more than one), and prompt for the record class to use."
+ (interactive "P")
+ (let* ((db
+ (or db
+ (if (or (= 1 (length ebdb-db-list))
+ (null arg))
+ (car ebdb-db-list)
+ (ebdb-prompt-for-db))))
+ (record-class
+ (or record-class
+ (if arg
+ (eieio-read-subclass "Use which record class? " 'ebdb-record
nil t)
+ (if db
+ (slot-value db 'record-class)
+ 'ebdb-record-person))))
+ (record (ebdb-read record-class)))
+ (condition-case nil
+ (progn
+ (ebdb-db-editable db nil t)
+ (run-hook-with-args 'ebdb-create-hook record)
+ (run-hook-with-args 'ebdb-change-hook record)
+ (ebdb-db-add-record db record)
+ (ebdb-init record)
+ (run-hook-with-args 'ebdb-after-change-hook record)
+ (ebdb-display-records (list record)))
+ (ebdb-readonly-db
+ (message "%s is read-only" (ebdb-string db)))
+ (ebdb-unsynced-db
+ (message "%s is out of sync" (ebdb-string db))))))
+
+;;;###autoload
+(defun ebdb-insert-field (records)
+ (interactive
+ (list (ebdb-do-records)))
+ (pcase-let
+ ((`(,label (,_slot . ,class))
+ (ebdb-prompt-for-field-type
+ (ebdb-record-field-slot-query
+ (eieio-object-class (car records))))))
+ (let
+ ((field (ebdb-read class
+ (when (equal class 'ebdb-field-user-simple)
+ `(:object-name ,label))))
+ new-slot)
+ (ebdb-with-record-edits (r records)
+ ;; If we're adding the same field to many different records, of
+ ;; different classes, it's possible that some of the records
+ ;; won't accept this field, or will accept it in a different
+ ;; slot.
+ (condition-case nil
+ (progn
+ (setq new-slot (car (ebdb-record-field-slot-query
+ (eieio-object-class r) `(nil . ,class))))
+ (ebdb-record-insert-field r new-slot field))
+ (ebdb-unacceptable-field
+ (message "Record %s cannot accept field %s" (ebdb-string r) field)
+ (sit-for 2)))))))
+
+;; TODO: Allow editing of multiple record fields simultaneously.
+;;;###autoload
+(defun ebdb-edit-field (record field)
+ "Edit the field under point. If point is on the name header of
+the record, change the name of the record."
+ (interactive
+ (save-excursion
+ (let* ((field (or (get-text-property (point) 'ebdb-record)
+ (ebdb-current-field)
+ (user-error "Point not in a field"))))
+ (list (ebdb-current-record)
+ field))))
+ (ebdb-with-record-edits (r (list record))
+ (if (eieio-object-p field)
+ (ebdb-record-change-field record field)
+ (ebdb-record-change-name record))))
+
+;;;###autoload
+(defun ebdb-edit-foo (record field)
+ "For RECORD edit some FIELD (mostly interactively).
+
+Interactively, if called without a prefix, edit the notes field
+of RECORD. When called with a prefix, prompt the user for a
+field to edit."
+ (interactive
+ (let* ((record (ebdb-current-record))
+ field field-list)
+ (if current-prefix-arg
+ (setq field-list
+ (mapcar
+ (lambda (f)
+ (let ((field (cdr f)))
+ (cons (concat
+ (ebdb-field-readable-name field)
+ (when (slot-exists-p field 'object-name)
+ (format " (%s)" (slot-value field 'object-name)))
+ " "
+ (car (split-string (ebdb-string field) "\n")))
+ (cdr f))))
+ (ebdb-record-current-fields record))
+ field
+ (cdr
+ (assoc
+ (completing-read
+ "Field: "
+ field-list)
+ field-list)))
+ (setq field (ebdb-record-field record 'notes)))
+ (list record field)))
+ (ebdb-with-record-edits (r (list record))
+ (if field
+ (ebdb-record-change-field record field)
+ ;; This is wrong, we need to rework `ebdb-insert-field' so we can
+ ;; call it with these arguments. Shouldn't be doing low-level
+ ;; work here.
+ (setq field (ebdb-read ebdb-default-notes-class))
+ (ebdb-record-insert-field record 'notes field))))
+
+;; (ebdb-list-transpose '(a b c d) 1 3)
+(defun ebdb-list-transpose (list i j)
+ "For LIST transpose elements I and J destructively.
+I and J start with zero. Return the modified LIST."
+ (if (eq i j)
+ list ; ignore that i, j could be invalid
+ (let (a b c)
+ ;; Travel down LIST only once
+ (if (> i j) (setq a i i j j a)); swap
+ (setq a (nthcdr i list)
+ b (nthcdr (- j i) a)
+ c (car b))
+ (unless b (error "Args %i, %i beyond length of list." i j))
+ (setcar b (car a))
+ (setcar a c)
+ list)))
+
+;;;###autoload
+(defun ebdb-delete-field-or-record (records field &optional noprompt)
+ "For RECORDS delete FIELD.
+If FIELD is the `name' field, delete RECORDS from datanbase.
+Interactively, use EBDB prefix \
+\\<ebdb-mode-map>\\[ebdb-do-all-records], see `ebdb-do-all-records',
+and FIELD is the field point is on.
+If prefix NOPROMPT is non-nil, do not confirm deletion."
+ ;; The value of FIELD is whatever `ebdb-current-field' returns.
+ ;; This way we can identify more accurately what really needs
+ ;; to be done.
+ (interactive
+ (list (ebdb-do-records) (ebdb-current-field) current-prefix-arg))
+ (unless field (error "Not a field"))
+ (setq records (ebdb-record-list records))
+ ;; TODO: Will this delete the record if we try to delete an AKA? We
+ ;; need a less ambiguous way of knowing if the record should be
+ ;; deleted. Probably `ebdb-fmt-record-header' should lay some
+ ;; special text property on the header name, and we should check for
+ ;; that.
+ (if (get-text-property (point) 'ebdb-record)
+ (ebdb-delete-records records noprompt)
+ (ebdb-with-record-edits (record records)
+ (when (or noprompt
+ (y-or-n-p (format "Delete this `%s' field (of %s)? "
+ (ebdb-field-readable-name field)
+ (ebdb-record-name record))))
+ (ebdb-record-delete-field
+ record (car (ebdb-record-field-slot-query
+ (eieio-object-class record)
+ (cons nil (eieio-object-class field))))
+ field))
+ (ebdb-redisplay-record-globally record))))
+
+;;;###autoload
+(defun ebdb-delete-records (records &optional noprompt)
+ "Delete RECORDS.
+Interactively, use EBDB prefix \
+\\<ebdb-mode-map>\\[ebdb-do-all-records], see `ebdb-do-all-records'.
+If prefix NOPROMPT is non-nil, do not confirm deletion."
+ (interactive (list (ebdb-do-records) current-prefix-arg))
+ (dolist (record (ebdb-record-list records))
+ (when (or noprompt
+ (y-or-n-p (format "Delete the EBDB record of %s? "
+ (ebdb-string record))))
+ (ebdb-delete record)
+ (ebdb-redisplay-record-globally record nil t))))
+
+;;;###autoload
+(defun ebdb-display-all-records (&optional fmt)
+ "Show all records.
+If invoked in a *EBDB* buffer point stays on the currently visible record.
+Inverse of `ebdb-display-current-record'."
+ (interactive (list (ebdb-formatter-prefix)))
+ (let ((current (ignore-errors (ebdb-current-record))))
+ (ebdb-display-records (ebdb-records) fmt)
+ (when (setq current (assq current ebdb-records))
+ (redisplay) ; Strange display bug??
+ (goto-char (nth 2 current)))))
+ ;; (set-window-point (selected-window) (nth 2 current)))))
+
+;;;###autoload
+(defun ebdb-display-current-record (&optional fmt)
+ "Narrow to current record. Inverse of `ebdb-display-all-records'."
+ (interactive (list (ebdb-formatter-prefix)))
+ (ebdb-display-records (list (ebdb-current-record)) fmt))
+
+(defun ebdb-change-records-fmt (records fmt)
+ (dolist (record records)
+ (unless (eq fmt (nth 1 record))
+ (setf (nth 1 record) fmt)
+ (ebdb-redisplay-record (car record)))))
+
+;;;###autoload
+(defun ebdb-toggle-records-format (records &optional arg)
+ "Toggle fmt of RECORDS (elided or expanded).
+Interactively, use EBDB prefix \
+\\<ebdb-mode-map>\\[ebdb-do-all-records], see `ebdb-do-all-records'.
+With prefix ARG 0, RECORDS are displayed elided.
+With any other non-nil ARG, RECORDS are displayed expanded."
+ (interactive (list (ebdb-do-records t) current-prefix-arg))
+ (let* ((current-fmt (nth 1 (assq (ebdb-current-record) ebdb-records)))
+ (formatters (ebdb-available-ebdb-formatters))
+ (fmt
+ (cond ((eq arg 0)
+ ebdb-default-oneline-formatter)
+ ((or (null current-fmt)
+ (null (memq current-fmt formatters)))
+ ebdb-default-multiline-formatter)
+ ;; layout is not the last element of layout-alist
+ ;; and we switch to the following element of layout-alist
+ ((let ((idx (cl-position current-fmt formatters)))
+ (if (= (1+ idx) (length formatters))
+ (car formatters)
+ (nth (1+ idx) formatters)))))))
+ (message "Using %S layout" (ebdb-string fmt))
+ (ebdb-change-records-fmt (ebdb-record-list records t) fmt)))
+
+;;;###autoload
+(defun ebdb-display-records-completely (records)
+ "Display RECORDS using layout `full-multi-line' (i.e., display all fields).
+Interactively, use EBDB prefix \
+\\<ebdb-mode-map>\\[ebdb-do-all-records], see `ebdb-do-all-records'."
+ (interactive (list (ebdb-do-records t)))
+ (let* ((record (ebdb-current-record))
+ (current-fmt (nth 1 (assq record ebdb-records)))
+ ;; TODO: Something weird happens with duplication of
+ ;; formatter objects when we do this.
+ (fmt (clone current-fmt :include nil :exclude nil)))
+ (ebdb-change-records-fmt (ebdb-record-list records t) fmt)))
+
+;;;###autoload
+(defun ebdb-display-records-with-fmt (records fmt)
+ "Display RECORDS using FMT. "
+ (interactive
+ (list (ebdb-do-records t)
+ (cdr (assoc-string
+ (completing-read "Format: "
+ (mapcar #'ebdb-string
+ (ebdb-available-ebdb-formatters)))
+ (mapcar
+ (lambda (s) (cons (ebdb-string s) s))
+ (ebdb-available-ebdb-formatters))))))
+ (ebdb-change-records-fmt (ebdb-record-list records t) fmt))
+
+;;;###autoload
+(defun ebdb-omit-record (n)
+ "Remove current record from the display without deleting it from EBDB.
+With prefix N, omit the next N records. If negative, omit backwards."
+ (interactive "p")
+ (let ((num (get-text-property (if (and (not (bobp)) (eobp))
+ (1- (point)) (point))
+ 'ebdb-record-number)))
+ (if (> n 0)
+ (setq n (min n (- (length ebdb-records) num)))
+ (setq n (min (- n) num))
+ (ebdb-prev-record n))
+ (dotimes (_ n)
+ (ebdb-redisplay-record (ebdb-current-record) nil t))))
+
+;; Entry points to EBDB
+
+;;;###autoload
+(defun ebdb (regexp &optional fmt)
+ "Display all records in the EBDB matching REGEXP
+in either the name(s), organization, address, phone, mail, or xfields."
+ (interactive (list (ebdb-search-read) (ebdb-formatter-prefix)))
+ (let ((records (ebdb-search (ebdb-records) regexp regexp regexp
+ regexp (cons '* regexp) regexp regexp)))
+ (if records
+ (ebdb-display-records records fmt nil t)
+ (message "No records matching '%s'" regexp))))
+
+;;;###autoload
+(defun ebdb-search-name (regexp &optional fmt)
+ "Display all records in the EBDB matching REGEXP in the name
+\(or ``alternate'' names\)."
+ (interactive (list (ebdb-search-read "names") (ebdb-formatter-prefix)))
+ (ebdb-display-records (ebdb-search (ebdb-records) regexp) fmt))
+
+;;;###autoload
+(defun ebdb-search-organization (regexp &optional fmt)
+ "Display all records in the EBDB matching REGEXP in the organization field."
+ (interactive (list (ebdb-search-read "organization")
(ebdb-formatter-prefix)))
+ (ebdb-display-records
+ (ebdb-search (ebdb-records 'ebdb-record-organization t)
+ regexp)
+ fmt))
+
+;;;###autoload
+(defun ebdb-search-address (regexp &optional fmt)
+ "Display all records in the EBDB matching REGEXP in the address fields."
+ (interactive (list (ebdb-search-read "address") (ebdb-formatter-prefix)))
+ (ebdb-display-records
+ (seq-filter
+ (lambda (r)
+ (ebdb-record-search r 'address regexp))
+ (ebdb-records))
+ fmt))
+
+;;;###autoload
+(defun ebdb-search-mail (regexp &optional fmt)
+ "Display all records in the EBDB matching REGEXP in the mail address."
+ (interactive (list (ebdb-search-read "mail address")
(ebdb-formatter-prefix)))
+ (ebdb-display-records
+ (seq-filter
+ (lambda (r)
+ (ebdb-record-search r 'mail regexp))
+ (ebdb-records))
+ fmt))
+
+;;;###autoload
+(defun ebdb-search-phone (regexp &optional fmt)
+ "Display all records in the EBDB matching REGEXP in the phones field."
+ (interactive (list (ebdb-search-read "phone") (ebdb-formatter-prefix)))
+ (ebdb-display-records
+ (seq-filter
+ (lambda (r)
+ (ebdb-record-search r 'phone regexp))
+ (ebdb-records))
+ fmt))
+
+;;;###autoload
+(defun ebdb-search-notes (regexp &optional fmt)
+ "Display all records in the EBDB matching REGEXP in the phones field."
+ (interactive (list (ebdb-search-read "notes") (ebdb-formatter-prefix)))
+ (ebdb-display-records
+ (seq-filter
+ (lambda (r)
+ (ebdb-record-search r 'notes regexp))
+ (ebdb-records))
+ fmt))
+
+;;;###autoload
+(defun ebdb-search-user-fields (field regexp &optional fmt)
+ "Display all EBDB records for which user field FIELD matches REGEXP."
+ (interactive
+ ;; TODO: Refactor this with `ebdb-prompt-for-field-type'
+ (let* ((field-alist
+ (append
+ (mapcar
+ (lambda (f)
+ (cons
+ (ebdb-field-readable-name (intern (car f)))
+ (intern (car f))))
+ (eieio-build-class-alist 'ebdb-field-user t))
+ (mapcar
+ (lambda (l)
+ (cons l 'ebdb-field-user-simple))
+ ebdb-user-label-list)))
+ (field (assoc (completing-read "Field to search (RET for all): "
+ field-alist
+ nil t)
+ field-alist)))
+ (list (if (null field) '* field)
+ (ebdb-search-read (if (null field)
+ "any user field"
+ (car field)))
+ (ebdb-formatter-prefix))))
+ (ebdb-display-records (ebdb-search (ebdb-records) nil nil nil nil
+ (cons field regexp))
+ fmt))
+
+;;;###autoload
+(defun ebdb-search-changed (&optional fmt)
+ ;; FIXME: "changes" in EBDB lingo are often called "modifications"
+ ;; in Emacs lingo
+ "Display records which have been changed since EBDB was last saved."
+ (interactive (list (ebdb-formatter-prefix)))
+ (let ((dirty (ebdb-dirty-records)))
+ (if (ebdb-search-invert-p)
+ (let (unchanged-records)
+ (dolist (record (ebdb-records))
+ (unless (memq record dirty)
+ (push record unchanged-records)))
+ (ebdb-display-records unchanged-records fmt))
+ (ebdb-display-records dirty fmt))))
+
+(defun ebdb-search-prog (function &optional fmt)
+ "Search records using FUNCTION.
+FUNCTION is called with one argument, the record, and should return
+the record to be displayed or nil otherwise."
+ (ebdb-display-records (seq-filter function (ebdb-records)) fmt))
+
+;;; Send-Mail interface
+
+;;;###autoload
+(defun ebdb-dwim-mail (record &optional mail)
+ ;; Do What I Mean!
+ "Return a string to use as the mail address of RECORD.
+The name in the mail address is formatted obeying `ebdb-mail-name-format'
+and `ebdb-mail-name'. However, if both the first name and last name
+are constituents of the address as in address@hidden,
+and `ebdb-mail-avoid-redundancy' is non-nil, then the address is used as is
+and `ebdb-mail-name-format' and `ebdb-mail-name' are ignored.
+If `ebdb-mail-avoid-redundancy' is 'mail-only the name is never included.
+MAIL may be a mail address to be used for RECORD.
+If MAIL is an integer, use the MAILth mail address of RECORD.
+If MAIL is nil use RECORD's primary mail address."
+ (unless mail
+ (let ((mails (ebdb-record-mail record t)))
+ (setq mail (or (and (integerp mail) (nth mail mails))
+ (object-assoc 'primary 'priority mails)
+ (car mails)))))
+ (unless mail (error "Record has no mail addresses"))
+ (let ((mail-aka (slot-value mail 'aka))
+ name fn ln)
+ (setq mail (slot-value mail 'mail))
+ (cond (mail-aka
+ (setq name mail-aka))
+ ((functionp ebdb-mail-name)
+ (setq name (funcall ebdb-mail-name record))
+ (if (consp name)
+ (setq fn (car name) ln (cdr name)
+ name (if (eq ebdb-mail-name-format 'first-last)
+ (ebdb-concat 'name-first-last fn ln)
+ (ebdb-concat 'name-last-first ln fn)))
+ (let ((pair (ebdb-divide-name name)))
+ (setq fn (car pair) ln (cdr pair)))))
+ ((setq name (ebdb-record-user-field record ebdb-mail-name))
+ (let ((pair (ebdb-divide-name name)))
+ (setq fn (car pair) ln (cdr pair))))
+ (t
+ (setq name (if (eq ebdb-mail-name-format 'first-last)
+ (ebdb-record-name record)
+ (ebdb-name-lf (slot-value record 'name)))
+ fn (ebdb-record-firstname record)
+ ln (ebdb-record-lastname record))))
+ (if (or (not name) (equal "" name)
+ (eq 'mail-only ebdb-mail-avoid-redundancy)
+ (and ebdb-mail-avoid-redundancy
+ (cond ((and fn ln)
+ (let ((fnq (regexp-quote fn))
+ (lnq (regexp-quote ln)))
+ (or (string-match (concat "address@hidden" fnq
+ "address@hidden" lnq "\\b")
+ mail)
+ (string-match (concat "address@hidden" lnq
+ "address@hidden" fnq "\\b")
+ mail))))
+ ((or fn ln)
+ (string-match (concat "address@hidden"
+ (regexp-quote (or fn ln)) "\\b")
+ mail)))))
+ mail
+ ;; If the name contains backslashes or double-quotes, backslash them.
+ (setq name (replace-regexp-in-string "[\\\"]" "\\\\\\&" name))
+ ;; If the name contains control chars or RFC822 specials, it needs
+ ;; to be enclosed in quotes. This quotes a few extra characters as
+ ;; well (!,%, and $) just for common sense.
+ ;; `define-mail-alias' uses regexp "[^- !#$%&'*+/0-9=?A-Za-z^_`{|}~]".
+ (format (if (string-match "[][[:cntrl:]\177()<>@,;:.!$%[:nonascii:]]"
name)
+ "\"%s\" <%s>"
+ "%s <%s>")
+ name mail))))
+
+(defun ebdb-compose-mail (&rest args)
+ "Start composing a mail message to send."
+ (apply 'compose-mail args))
+
+;;;###autoload
+(defun ebdb-mail (records &optional subject n verbose)
+ "Compose a mail message to RECORDS (optional: using SUBJECT).
+Interactively, use EBDB prefix \
+\\<ebdb-mode-map>\\[ebdb-do-all-records], see `ebdb-do-all-records'.
+By default, the first mail addresses of RECORDS are used.
+If prefix N is a number, use Nth mail address of RECORDS (starting from 1).
+If prefix N is C-u (t noninteractively) use all mail addresses of RECORDS.
+If VERBOSE is non-nil (as in interactive calls) be verbose."
+ (interactive (list (ebdb-do-records) nil
+ (or (consp current-prefix-arg)
+ current-prefix-arg)
+ t))
+ (setq records (ebdb-record-list records))
+ (if (not records)
+ (if verbose (message "No records"))
+ (let ((to (ebdb-mail-address records n nil verbose)))
+ (unless (string= "" to)
+ (ebdb-compose-mail to subject)))))
+
+(defun ebdb-mail-address (records &optional n kill-ring-save verbose)
+ "Return mail addresses of RECORDS as a string.
+Interactively, use EBDB prefix \
+\\<ebdb-mode-map>\\[ebdb-do-all-records], see `ebdb-do-all-records'.
+By default, the first mail addresses of RECORDS are used.
+If prefix N is a number, use Nth mail address of RECORDS (starting from 1).
+If prefix N is C-u (t noninteractively) use all mail addresses of RECORDS.
+If KILL-RING-SAVE is non-nil (as in interactive calls), copy mail addresses
+to kill ring. If VERBOSE is non-nil (as in interactive calls) be verbose."
+ (interactive (list (ebdb-do-records)
+ (or (consp current-prefix-arg)
+ current-prefix-arg)
+ t t))
+ (setq records (ebdb-record-list records))
+ (if (not records)
+ (progn (if verbose (message "No records")) "")
+ (let ((good "") bad)
+ (dolist (record records)
+ (let ((mails (ebdb-record-mail record t)))
+ (cond ((not mails)
+ (push record bad))
+ ((eq n t)
+ (setq good (ebdb-concat ",\n\t"
+ good
+ (mapcar (lambda (mail)
+ (ebdb-dwim-mail record
mail))
+ mails))))
+ (t
+ (setq good (ebdb-concat ",\n\t" good
+ (ebdb-dwim-mail record (and (numberp n)
+ (nth (1- n)
mails)))))))))
+ (when (and bad verbose)
+ (message "No mail addresses for %s."
+ (mapconcat 'ebdb-string (nreverse bad) ", "))
+ (unless (string= "" good) (sit-for 2)))
+ (when (and kill-ring-save (not (string= good "")))
+ (kill-new good)
+ (if verbose (message "%s" good)))
+ good)))
+
+;; Is there better way to yank selected mail addresses from the EBDB
+;; buffer into a message buffer? We need some kind of a link between
+;; the EBDB buffer and the message buffer, where the mail addresses
+;; are supposed to go. Then we could browse the EBDB buffer and copy
+;; selected mail addresses from the EBDB buffer into a message buffer.
+
+(defun ebdb-mail-yank ()
+ "CC the people displayed in the *EBDB* buffer on this mail message.
+The primary mail of each of the records currently listed in the
+*EBDB* buffer will be appended to the CC: field of the current buffer."
+ (interactive)
+ (let ((addresses (with-current-buffer ebdb-buffer-name
+ (delq nil
+ (mapcar (lambda (x)
+ (if (ebdb-record-mail (car x))
+ (ebdb-dwim-mail (car x))))
+ ebdb-records))))
+ (case-fold-search t))
+ (goto-char (point-min))
+ (if (re-search-forward "^CC:[ \t]*" nil t)
+ ;; We have a CC field. Move to the end of it, inserting a comma
+ ;; if there are already addresses present.
+ (unless (eolp)
+ (end-of-line)
+ (while (looking-at "\n[ \t]")
+ (forward-char) (end-of-line))
+ (insert ",\n")
+ (indent-relative))
+ ;; Otherwise, if there is an empty To: field, move to the end of it.
+ (unless (and (re-search-forward "^To:[ \t]*" nil t)
+ (eolp))
+ ;; Otherwise, insert an empty CC: field.
+ (end-of-line)
+ (while (looking-at "\n[ \t]")
+ (forward-char) (end-of-line))
+ (insert "\nCC:")
+ (indent-relative)))
+ ;; Now insert each of the addresses on its own line.
+ (while addresses
+ (insert (car addresses))
+ (when (cdr addresses) (insert ",\n") (indent-relative))
+ (setq addresses (cdr addresses)))))
+(define-obsolete-function-alias 'ebdb-yank-addresses 'ebdb-mail-yank)
+
+;;; completion
+
+;;;###autoload
+(defun ebdb-completion-predicate (key records)
+ "For use as the third argument to `completing-read'.
+Obey `ebdb-completion-list'."
+ (cond ((null ebdb-completion-list)
+ nil)
+ ((eq t ebdb-completion-list)
+ t)
+ (t
+ (catch 'ebdb-hash-ok
+ (dolist (record records)
+ (ebdb-hash-p key record ebdb-completion-list))
+ nil))))
+
+(defun ebdb-completing-read-records (prompt &optional omit-records)
+ "Read and return list of records from the ebdb.
+Completion is done according to `ebdb-completion-list'. If the user
+just hits return, nil is returned. Otherwise, a valid response is forced."
+ (let* ((completion-ignore-case t)
+ (string (completing-read prompt ebdb-hashtable
+ 'ebdb-completion-predicate t)))
+ (unless (string= "" string)
+ (let (records)
+ (dolist (record (gethash string ebdb-hashtable))
+ (when (and (not (memq record omit-records))
+ (not (memq record records)))
+ (push record records)))
+ records))))
+
+
+(defun ebdb-completing-read-record (prompt &optional omit-records)
+ "Prompt for and return a single record from the ebdb;
+completion is done according to `ebdb-completion-list'. If the user
+just hits return, nil is returned. Otherwise, a valid response is forced.
+If OMIT-RECORDS is non-nil it should be a list of records to dis-allow
+completion with."
+ (let ((records (ebdb-completing-read-records prompt omit-records)))
+ (cond ((eq (length records) 1)
+ (car records))
+ ((> (length records) 1)
+ (ebdb-display-records records ebdb-default-oneline-formatter)
+ (let* ((count (length records))
+ (result (completing-read
+ (format "Which record (1-%s): " count)
+ (mapcar 'number-to-string (number-sequence 1 count))
+ nil t)))
+ (nth (1- (string-to-number result)) records))))))
+
+;;;###autoload
+(defun ebdb-completing-read-mails (prompt &optional init)
+ "Like `read-string', but allows `ebdb-complete-mail' style completion."
+ (read-from-minibuffer prompt init
+ ebdb-completing-read-mails-map))
+
+(defconst ebdb-quoted-string-syntax-table
+ (let ((st (make-syntax-table)))
+ (modify-syntax-entry ?\\ "\\" st)
+ (modify-syntax-entry ?\" "\"" st)
+ st)
+ "Syntax-table to parse matched quotes. Used by `ebdb-complete-mail'.")
+
+;;;###autoload
+(defun ebdb-complete-mail (&optional beg cycle-completion-buffer)
+ "In a mail buffer, complete the user name or mail before point.
+Completion happens up to the preceeding colon, comma, or BEG.
+Return non-nil if there is a valid completion, else return nil.
+
+Completion behaviour obeys `ebdb-completion-list' (see there).
+If what has been typed matches a unique EBDB record, insert an address
+formatted by `ebdb-dwim-mail' (see there). Also, display this record
+if `ebdb-completion-display-record' is non-nil,
+If what has been typed is a valid completion but does not match
+a unique record, display a list of completions.
+If the completion is done and `ebdb-complete-mail-allow-cycling' is t
+then cycle through the mails for the matching record. If EBDB
+would format a given address different from what we have in the mail buffer,
+the first round of cycling reformats the address accordingly, then we cycle
+through the mails for the matching record.
+With prefix CYCLE-COMPLETION-BUFFER non-nil, display a list of all mails
+available for cycling.
+
+Set the variable `ebdb-complete-mail' non-nil for enabling this feature
+as part of the MUA insinuation."
+ (interactive (list nil current-prefix-arg))
+
+ (unless ebdb-db-list
+ (ebdb-load))
+
+ ;; Completion should begin after the preceding comma (separating
+ ;; two addresses) or colon (separating the header field name
+ ;; from the header field body). We want to ignore these characters
+ ;; if they appear inside a quoted string (RFC 5322, Sec. 3.2.4).
+ ;; Note also that a quoted string may span multiple lines
+ ;; (RFC 5322, Sec. 2.2.3).
+ ;; So to be save, we go back to the beginning of the header field body
+ ;; (past the colon, when we are certainly not inside a quoted string),
+ ;; then we parse forward, looking for commas not inside a quoted string
+ ;; and positioned before END. - This fails with an unbalanced quote.
+ ;; But an unbalanced quote is bound to fail anyway.
+ (when (and (not beg)
+ (<= (point)
+ (save-restriction ; `mail-header-end'
+ (widen)
+ (save-excursion
+ (rfc822-goto-eoh)
+ (point)))))
+ (let ((end (point))
+ start pnt state)
+ (save-excursion
+ ;; A header field name must appear at the beginning of a line,
+ ;; and it must be terminated by a colon.
+ (re-search-backward "^[^ \t\n:][^:]*:[ \t\n]+")
+ (setq beg (match-end 0)
+ start beg)
+ (goto-char beg)
+ ;; If we are inside a syntactically correct header field,
+ ;; all continuation lines in between the field name and point
+ ;; must begin with a white space character.
+ (if (re-search-forward "\n[^ \t]" end t)
+ ;; An invalid header is identified via BEG set to nil.
+ (setq beg nil)
+ ;; Parse field body up to END
+ (with-syntax-table ebdb-quoted-string-syntax-table
+ (while (setq pnt (re-search-forward ",[ \t\n]*" end t))
+ (setq state (parse-partial-sexp start pnt nil nil state)
+ start pnt)
+ (unless (nth 3 state) (setq beg pnt))))))))
+
+ ;; Do we have a meaningful way to set BEG if we are not in a message header?
+ (unless beg
+ (message "Not a valid buffer position for mail completion")
+ (sit-for 1))
+
+ (let* ((end (point))
+ (done (unless beg 'nothing))
+ (orig (and beg (buffer-substring-no-properties beg end)))
+ (completion-ignore-case t)
+ (completion (and orig
+ (try-completion orig ebdb-hashtable
+ 'ebdb-completion-predicate)))
+ all-completions dwim-completions one-record)
+
+ (unless done
+ ;; We get fooled if a partial COMPLETION matches "," (for example,
+ ;; a comma in lf-name). Such a partial COMPLETION cannot be protected
+ ;; by quoting. Then the comma gets interpreted as BEG.
+ ;; So we never perform partial completion beyond the first comma.
+ ;; This works even if we have just one record matching ORIG (thus
+ ;; allowing dwim-completion) because ORIG is a substring of COMPLETION
+ ;; even after COMPLETION got truncated; and ORIG by itself must be
+ ;; sufficient to identify this record.
+ ;; Yet if multiple records match ORIG we can only offer a *Completions*
+ ;; buffer.
+ (if (and (stringp completion)
+ (string-match "," completion))
+ (setq completion (substring completion 0 (match-beginning 0))))
+
+ (setq all-completions (all-completions orig ebdb-hashtable
+ 'ebdb-completion-predicate))
+
+ ;; Resolve the records matching ORIG:
+ ;; Multiple completions may match the same record
+ (let ((records (delete-dups
+ (apply 'append (mapcar (lambda (compl)
+ (gethash compl ebdb-hashtable))
+ all-completions)))))
+ ;; Is there only one matching record?
+ (setq one-record (and (not (cdr records))
+ (car records))))
+
+ ;; Clean up *Completions* buffer window, if it exists
+ (let ((window (get-buffer-window "*Completions*")))
+ (if (window-live-p window)
+ (quit-window nil window)))
+
+ (cond
+ ;; Match for a single record
+ (one-record
+ (let ((completion-list (if (eq t ebdb-completion-list)
+ '(name alt-names mail aka organization)
+ ebdb-completion-list))
+ (mails (ebdb-record-mail one-record t))
+ mail elt)
+ (if (not mails)
+ (progn
+ (message "Matching record has no mail field")
+ (sit-for 1)
+ (setq done 'nothing))
+
+ ;; Determine the mail address of ONE-RECORD to use for ADDRESS.
+ ;; Do we have a preferential order for the following tests?
+ ;; (1) If ORIG matches name, AKA, or organization of ONE-RECORD,
+ ;; then ADDRESS will be the first mail address of ONE-RECORD.
+ (if (try-completion orig
+ (append
+ (if (memq 'name completion-list)
+ (list (or (ebdb-record-name one-record)
"")))
+ (if (memq 'alt-names completion-list)
+ (or (ebdb-record-alt-names one-record)
(list "")))
+ (if (memq 'organization completion-list)
+ (ebdb-record-organizations one-record))))
+ (setq mail (car mails)))
+ ;; (2) If ORIG matches one or multiple mail addresses of
ONE-RECORD,
+ ;; then we take the first one matching ORIG.
+ ;; We got here with MAIL nil only if `ebdb-completion-list'
+ ;; includes 'mail or 'primary.
+ (unless mail
+ (while (setq elt (pop mails))
+ (if (try-completion orig (list (ebdb-string elt)))
+ (setq mail elt
+ mails nil))))
+ ;; This error message indicates a bug!
+ (unless mail (error "No match for %s" orig))
+
+ (let ((dwim-mail (ebdb-dwim-mail one-record mail)))
+ (if (string= dwim-mail orig)
+ ;; We get here if `ebdb-mail-avoid-redundancy' is 'mail-only
+ ;; and `ebdb-completion-list' includes 'mail.
+ (unless (and ebdb-complete-mail-allow-cycling
+ (< 1 (length (ebdb-record-mail one-record))))
+ (setq done 'unchanged))
+ ;; Replace the text with the expansion
+ (delete-region beg end)
+ (insert dwim-mail)
+ (ebdb-complete-mail-cleanup dwim-mail beg)
+ (setq done 'unique))))))
+
+ ;; Partial completion
+ ((and (stringp completion)
+ (not (ebdb-string= orig completion)))
+ (delete-region beg end)
+ (insert completion)
+ (setq done 'partial))
+
+ ;; Partial match not allowing further partial completion
+ (completion
+ (let ((completion-list (if (eq t ebdb-completion-list)
+ '(name alt-names mail organization)
+ ebdb-completion-list)))
+ ;; Now collect all the dwim-addresses for each completion.
+ ;; Add it if the mail is part of the completions
+ (dolist (key all-completions)
+ (dolist (record (gethash key ebdb-hashtable))
+ (let ((mails (ebdb-record-mail record t))
+ accept)
+ (when mails
+ (dolist (field completion-list)
+ (cond ((eq field 'name)
+ (if (ebdb-string= key (ebdb-record-name record))
+ (push (car mails) accept)))
+ ((eq field 'alt-names)
+ (if (member-ignore-case
+ key (ebdb-record-alt-names record))
+ (push (car mails) accept)))
+ ((eq field 'organization)
+ (if (member-ignore-case key
(ebdb-record-organizations
+ record))
+ (push (car mails) accept)))
+ ((eq field 'primary)
+ (if (ebdb-string= key (ebdb-string
+ (car mails)))
+ (push (car mails) accept)))
+ ((eq field 'mail)
+ (dolist (mail mails)
+ (if (ebdb-string= key
+ (ebdb-string mail))
+ (push mail accept))))))
+ (dolist (mail (delete-dups accept))
+ (push (ebdb-dwim-mail record mail) dwim-completions))))))
+
+ (setq dwim-completions (sort (delete-dups dwim-completions)
+ 'string-lessp))
+ (cond ((not dwim-completions)
+ (message "Matching record has no mail field")
+ (sit-for 1)
+ (setq done 'nothing))
+ ;; DWIM-COMPLETIONS may contain only one element,
+ ;; if multiple completions match the same record.
+ ;; Then we may proceed with DONE set to `unique'.
+ ((eq 1 (length dwim-completions))
+ (delete-region beg end)
+ (insert (car dwim-completions))
+ (ebdb-complete-mail-cleanup (car dwim-completions) beg)
+ (setq done 'unique))
+ (t (setq done 'choose)))))))
+
+ ;; By now, we have considered all possiblities to perform a completion.
+ ;; If nonetheless we haven't done anything so far, consider cycling.
+ ;;
+ ;; Completion and cycling are really two very separate things.
+ ;; Completion is controlled by the user variable `ebdb-completion-list'.
+ ;; Cycling assumes that ORIG already holds a valid RFC 822 mail address.
+ ;; Therefore cycling may consider different records than completion.
+ (when (and (not done) ebdb-complete-mail-allow-cycling)
+ ;; find the record we are working on.
+ (let* ((address (ebdb-extract-address-components orig))
+ (record (car (ebdb-message-search
+ (car address) (cadr address)))))
+ (if (and record
+ (setq dwim-completions
+ (mapcar (lambda (m) (ebdb-dwim-mail record m))
+ (ebdb-record-mail record t))))
+ (cond ((and (= 1 (length dwim-completions))
+ (string= orig (car dwim-completions)))
+ (setq done 'unchanged))
+ (cycle-completion-buffer ; use completion buffer
+ (setq done 'cycle-choose))
+ ;; Reformatting / Clean up:
+ ;; If the canonical mail address (nth 1 address)
+ ;; matches the Nth canonical mail address of RECORD,
+ ;; but ORIG is not `equal' to (ebdb-dwim-mail record n),
+ ;; then we replace ORIG by (ebdb-dwim-mail record n).
+ ;; For example, the address "JOHN SMITH <address@hidden>"
+ ;; gets reformatted as "John Smith <address@hidden>".
+ ;; We attempt this reformatting before the yet more
+ ;; aggressive proper cycling.
+ ((let* ((canon (car (member-ignore-case
+ (nth 1 address)
+ (ebdb-record-mail-canon record))))
+ (dwim-mail (let ((case-fold-search t))
+ (seq-find (lambda (d)
+ (string-match-p canon d))
+ dwim-completions))))
+ (when (not (string= orig dwim-mail))
+ (delete-region beg end)
+ (insert dwim-mail)
+ (ebdb-complete-mail-cleanup dwim-mail beg)
+ (setq done 'reformat))
+ done))
+ (t
+ ;; ORIG is `equal' to an element of DWIM-COMPLETIONS
+ ;; Use the next element of DWIM-COMPLETIONS.
+ (let ((dwim-mail (or (nth 1 (member orig dwim-completions))
+ (nth 0 dwim-completions))))
+ ;; replace with new mail address
+ (delete-region beg end)
+ (insert dwim-mail)
+ (ebdb-complete-mail-cleanup dwim-mail beg)
+ (setq done 'cycle)))))))
+
+ (when (member done '(choose cycle-choose))
+ ;; Pop up a completions window using DWIM-COMPLETIONS.
+ ;; Too bad: The following requires at least GNU Emacs 23.2
+ ;; which introduced the variable `completion-base-position'.
+ ;; For an older Emacs there is really no satisfactory workaround
+ ;; (see GNU Emacs bug #4699), unless we use something radical like
+ ;; advicing `choose-completion-string' (used by EBDB v2).
+ (if (string< (substring emacs-version 0 4) "23.2")
+ (message "*Completions* buffer requires at least GNU Emacs 23.2")
+ ;; `completion-in-region' does not work here as `dwim-completions'
+ ;; is not a collection for completion in the usual sense, but it
+ ;; is really a list of replacements.
+ (let ((status (not (eq (selected-window) (minibuffer-window))))
+ (completion-base-position (list beg end))
+ ;; If we even have `completion-list-insert-choice-function'
+ ;; (introduced in GNU Emacs 24.1) that is yet better.
+ ;; Then we first call the default value of this variable
+ ;; before performing our own stuff.
+ (completion-list-insert-choice-function
+ `(lambda (beg end text)
+ ,(if (boundp 'completion-list-insert-choice-function)
+ `(funcall ',completion-list-insert-choice-function
+ beg end text))
+ (ebdb-complete-mail-cleanup text beg))))
+ (if status (message "Making completion list..."))
+ (with-output-to-temp-buffer "*Completions*"
+ (display-completion-list dwim-completions))
+ (if status (message "Making completion list...done")))))
+
+ ;; If DONE is `nothing' return nil so that possibly some other code
+ ;; can take over.
+ (unless (eq done 'nothing)
+ done)))
+
+(defun ebdb-complete-mail-cleanup (mail beg)
+ "Clean up after inserting MAIL at position BEG.
+If we are past `fill-column', wrap at the previous comma."
+ (if (and (not (auto-fill-function))
+ (>= (current-column) fill-column))
+ (save-excursion
+ (goto-char beg)
+ (when (search-backward "," (line-beginning-position) t)
+ (forward-char 1)
+ (insert "\n")
+ (indent-relative)
+ (if (looking-at "[ \t\n]+")
+ (delete-region (point) (match-end 0))))))
+ (if (or ebdb-completion-display-record ebdb-complete-mail-hook)
+ (let* ((address (ebdb-extract-address-components mail))
+ (records (ebdb-message-search (car address) (nth 1 address))))
+ ;; Update the *EBDB* buffer if desired.
+ (if ebdb-completion-display-record
+ (let ((ebdb-silent-internal t))
+ ;; FIXME: This pops up *EBDB* before removing *Completions*
+ (ebdb-display-records records nil t)))
+ ;; `ebdb-complete-mail-hook' may access MAIL, ADDRESS, and RECORDS.
+ (run-hooks 'ebdb-complete-mail-hook))))
+
+;;; interface to mail-abbrevs.el.
+
+;; Just stub this out for now.
+;;;###autoload
+(defun ebdb-mail-aliases (&optional _force-rebuilt _noisy)
+ t)
+;; (defun ebdb-mail-aliases (&optional force-rebuilt noisy)
+;; "Define mail aliases for the records in the database.
+;; Define a mail alias for every record that has a `mail-alias' field
+;; which is the contents of that field.
+;; If there are multiple comma-separated words in the `mail-alias' field,
+;; then all of those words will be defined as aliases for that person.
+
+;; If multiple records in the database have the same mail alias,
+;; then that alias expands to a comma-separated list of the mail addresses
+;; of all of these people.
+;; Add this command to `mail-setup-hook'.
+
+;; Mail aliases are (re)built only if `ebdb-mail-aliases-need-rebuilt' is
non-nil
+;; because the database was newly loaded or it has been edited.
+;; Rebuilding the aliases is enforced if prefix FORCE-REBUILT is t."
+;; (interactive (list current-prefix-arg t))
+;; ;; Build `mail-aliases' if not yet done.
+;; ;; Note: `mail-abbrevs-setup' rebuilds the mail-aliases only if
+;; ;; `mail-personal-alias-file' has changed. So it would not do anything
+;; ;; if we want to rebuild the mail-aliases because of changes in EBDB.
+;; (if (or force-rebuilt (eq t mail-aliases)) (build-mail-aliases))
+
+;; ;; We should be cleverer here and instead of rebuilding all aliases
+;; ;; we should just do what's necessary, i.e. remove deleted records
+;; ;; and add new records
+;; ;; Calling `ebdb-records' can change `ebdb-mail-aliases-need-rebuilt'
+;; (let ((records (ebdb-search (ebdb-records) nil nil nil
+;; (cons ebdb-mail-alias-field ".")))
+;; results match)
+;; (if (not (or force-rebuilt ebdb-mail-aliases-need-rebuilt))
+;; (if noisy (message "EBDB mail alias: nothing to do"))
+;; (setq ebdb-mail-aliases-need-rebuilt nil)
+
+;; ;; collect an alist of (alias rec1 [rec2 ...])
+;; (dolist (record records)
+;; (if (ebdb-record-mail record)
+;; (dolist (alias (ebdb-record-xfield-split record
ebdb-mail-alias-field))
+;; (if (setq match (assoc alias results))
+;; ;; If an alias appears more than once, we collect all
records
+;; ;; that refer to it.
+;; (nconc match (list record))
+;; (push (list alias record) results)))
+;; (unless ebdb-silent
+;; (ebdb-warn "record %S has no mail address, but the aliases: %s"
+;; (ebdb-record-name record)
+;; (ebdb-record-xfield record ebdb-mail-alias-field))
+;; (sit-for 1))))
+
+;; ;; Iterate over the results and create the aliases
+;; (dolist (result results)
+;; (let* ((aliasstem (car result))
+;; (expansions
+;; (if (cddr result)
+;; ;; for group aliases we just take all the primary mails
+;; ;; and define only one expansion!
+;; (list (mapconcat (lambda (record) (ebdb-dwim-mail
record))
+;; (cdr result)
mail-alias-separator-string))
+;; ;; this is an alias for a single person so deal with it
+;; ;; according to `ebdb-mail-alias'
+;; (let* ((record (nth 1 result))
+;; (mails (ebdb-record-mail record)))
+;; (if (or (eq 'first ebdb-mail-alias)
+;; (not (cdr mails)))
+;; ;; Either we want to define only one alias for
+;; ;; the first mail address or there is anyway
+;; ;; only one address. In either case, we take
+;; ;; take only the first address.
+;; (list (ebdb-dwim-mail record (car mails)))
+;; ;; We need to deal with more than one mail address...
+;; (let* ((all (mapcar (lambda (m) (ebdb-dwim-mail
record m))
+;; mails))
+;; (star (ebdb-concat mail-alias-separator-string
all)))
+;; (if (eq 'star ebdb-mail-alias)
+;; (list star (car all))
+;; ;; if `ebdb-mail-alias' is 'all, we create
+;; ;; two aliases for the primary mail address
+;; (cons star (cons (car all) all))))))))
+;; (count -1) ; n=-1: <alias>*; n=0: <alias>; n>0: <alias>n
+;; (len (length expansions))
+;; alias f-alias)
+
+;; ;; create the aliases for each expansion
+;; (dolist (expansion expansions)
+;; (cond ((or (= 1 len)
+;; (= count 0))
+;; (setq alias aliasstem))
+;; ((= count -1) ;; all the mails of a record
+;; (setq alias (concat aliasstem "*")))
+;; (t ;; <alias>n for each mail of a record
+;; (setq alias (format "%s%s" aliasstem count))))
+;; (setq count (1+ count))
+
+;; (add-to-list 'mail-aliases (cons alias expansion))
+
+;; (define-mail-abbrev alias expansion)
+;; (unless (setq f-alias (intern-soft (downcase alias)
mail-abbrevs))
+;; (error "Cannot find the alias"))
+
+;; ;; `define-mail-abbrev' initializes f-alias to be
+;; ;; `mail-abbrev-expand-hook'. We replace this by
+;; ;; `ebdb-mail-abbrev-expand-hook'
+;; (unless (eq (symbol-function f-alias) 'mail-abbrev-expand-hook)
+;; (error "mail-aliases contains unexpected hook %s"
+;; (symbol-function f-alias)))
+;; ;; `ebdb-mail-abbrev-hook' is called with mail addresses
instead of
+;; ;; ebdb records to avoid keeping pointers to records, which
would
+;; ;; lose if the database was reverted.
+;; ;; `ebdb-mail-abbrev-hook' uses `ebdb-message-search' to convert
+;; ;; these mail addresses to records, which is plenty fast.
+;; ;; FIXME: The value of arg MAILS for `ebdb-mail-abbrev-hook'
+;; ;; is wrong. Currently it is based on the list of records that
have
+;; ;; referenced ALIASTEM and we simply take the first mail address
+;; ;; from each of these records.
+;; ;; Then `ebdb-message-search' will find the correct records
+;; ;; (assuming that each mail address appears only once in the
+;; ;; database). Nonethless, arg MAILS for `ebdb-mail-abbrev-hook'
+;; ;; does not, in general, contain the actual mail addresses
+;; ;; of EXPANSION. So what we would need is to go back from
+;; ;; EXPANSION to the mail addresses it contains (which is tricky
+;; ;; because mail addresses in the database can be shortcuts for
+;; ;; the addresses in EXPANSION).
+;; (fset f-alias `(lambda ()
+;; (ebdb-mail-abbrev-expand-hook
+;; ,alias
+;; ',(mapcar (lambda (r) (car (ebdb-record-mail
r)))
+;; (cdr result))))))))
+
+;; (if noisy (message "EBDB mail alias: rebuilding done")))))
+
+;; (defun ebdb-mail-abbrev-expand-hook (alias mails)
+;; (run-hook-with-args 'ebdb-mail-abbrev-expand-hook alias mails)
+;; (mail-abbrev-expand-hook)
+;; (when ebdb-completion-display-record
+;; (let ((ebdb-silent-internal t))
+;; (ebdb-display-records
+;; (apply 'append
+;; (mapcar (lambda (mail) (ebdb-message-search nil mail)) mails))
+;; nil t))))
+
+;; (defun ebdb-get-mail-aliases ()
+;; "Return a list of mail aliases used in the EBDB."
+;; (let ((records (ebdb-search (ebdb-records) nil nil nil
+;; (cons ebdb-mail-alias-field ".")))
+;; result)
+;; (dolist (record records result)
+;; (dolist (alias (ebdb-record-xfield-split record
ebdb-mail-alias-field))
+;; (add-to-list 'result alias)))))
+
+;; ;;;###autoload
+;; (defsubst ebdb-mail-alias-list (alias)
+;; (if (stringp alias)
+;; (ebdb-split ebdb-mail-alias-field alias)
+;; alias))
+
+;; (defun ebdb-add-mail-alias (records &optional alias delete)
+;; "Add ALIAS to RECORDS.
+;; If prefix DELETE is non-nil, remove ALIAS from RECORDS.
+;; Interactively, use EBDB prefix \
+;; \\<ebdb-mode-map>\\[ebdb-do-all-records], see `ebdb-do-all-records'.
+;; Arg ALIAS is ignored if list RECORDS contains more than one record.
+;; Instead read ALIAS interactively for each record in RECORDS.
+;; If the function `ebdb-init-mail-alias' is defined, it is called with
+;; one arg RECORD to define the default value for ALIAS of RECORD."
+;; (interactive (list (ebdb-do-records) nil current-prefix-arg))
+;; (ebdb-editable)
+;; (setq records (ebdb-record-list records))
+;; (if (< 1 (length records)) (setq alias nil))
+;; (let* ((tmp (intern-soft
+;; (concat "ebdb-init-" (symbol-name ebdb-mail-alias-field))))
+;; (init-f (if (functionp tmp) tmp)))
+;; (dolist (record records)
+;; (let ((r-a-list (ebdb-record-xfield-split record
ebdb-mail-alias-field))
+;; (alias alias)
+;; a-list)
+;; (if alias
+;; (setq a-list (ebdb-mail-alias-list alias))
+;; (when init-f
+;; (setq a-list (ebdb-mail-alias-list (funcall init-f record))
+;; alias (if a-list (ebdb-concat ebdb-mail-alias-field
a-list))))
+;; (let ((crm-separator
+;; (concat "[ \t\n]*"
+;; (cadr (assq ebdb-mail-alias-field
ebdb-separator-alist))
+;; "[ \t\n]*"))
+;; (crm-local-completion-map ebdb-crm-local-completion-map)
+;; (prompt (format "%s mail alias:%s " (if delete "Remove"
"Add")
+;; (if alias (format " (default %s)" alias)
"")))
+;; (collection (if delete
+;; (or r-a-list (error "Record has no alias"))
+;; (ebdb-get-mail-aliases))))
+;; (setq a-list (if (string< "24.3" (substring emacs-version 0 4))
+;; (completing-read-multiple prompt collection nil
+;; delete nil nil alias)
+;; (ebdb-split ebdb-mail-alias-field
+;; (completing-read prompt collection nil
+;; delete nil nil
alias))))))
+;; (dolist (a a-list)
+;; (if delete
+;; (setq r-a-list (delete a r-a-list))
+;; ;; Add alias only if it is not there yet
+;; (add-to-list 'r-a-list a)))
+;; ;; This also handles `ebdb-mail-aliases-need-rebuilt'
+;; (ebdb-record-set-xfield record ebdb-mail-alias-field
+;; (ebdb-concat ebdb-mail-alias-field
r-a-list))
+;; (ebdb-change-record record)))))
+
+;;; Actions
+
+(defun ebdb-record-action (arg record field)
+ "Ask FIELD of RECORD to perform an action.
+
+With ARG, use ARG an an index into FIELD's list of actions."
+ (interactive (list current-prefix-arg
+ (ebdb-current-record)
+ (ebdb-current-field)))
+ (ebdb-action field record arg))
+
+
+;;; Dialing numbers from EBDB
+
+(defun ebdb-dial-number (phone-string)
+ "Dial the number specified by PHONE-STRING.
+This uses the tel URI syntax passed to `browse-url' to make the call.
+If `ebdb-dial-function' is non-nil then that is called to make the phone call."
+ (interactive "sDial number: ")
+ (if ebdb-dial-function
+ (funcall ebdb-dial-function phone-string)
+ (browse-url (concat "tel:" phone-string))))
+
+;;;###autoload
+(defun ebdb-dial (phone force-area-code)
+ "Dial the number at point.
+If the point is at the beginning of a record, dial the first phone number.
+Use rules from `ebdb-dial-local-prefix-alist' unless prefix FORCE-AREA-CODE
+is non-nil. Do not dial the extension."
+ (interactive (list (ebdb-current-field) current-prefix-arg))
+ (if (eq phone 'ebdb-record-name)
+ (setq phone (car (ebdb-record-phone (ebdb-current-record)))))
+ (or (and (eieio-object-p phone)
+ (object-of-class-p phone 'ebdb-field-phone))
+ (error "Not on a phone field"))
+
+ (let ((number (ebdb-string phone))
+ shortnumber)
+
+ ;; cut off the extension
+ (if (string-match "x[0-9]+$" number)
+ (setq number (substring number 0 (match-beginning 0))))
+
+ (unless force-area-code
+ (let ((alist ebdb-dial-local-prefix-alist) prefix)
+ (while (setq prefix (pop alist))
+ (if (string-match (concat "^" (eval (car prefix))) number)
+ (setq shortnumber (concat (cdr prefix)
+ (substring number (match-end 0)))
+ alist nil)))))
+
+ (if shortnumber
+ (setq number shortnumber)
+
+ ;; This is terrifically Americanized...
+ ;; Leading 0 => local number (?)
+ (if (and ebdb-dial-local-prefix
+ (string-match "^0" number))
+ (setq number (concat ebdb-dial-local-prefix number)))
+
+ ;; Leading + => long distance/international number
+ (if (and ebdb-dial-long-distance-prefix
+ (string-match "^\+" number))
+ (setq number (concat ebdb-dial-long-distance-prefix " "
+ (substring number 1)))))
+
+ (unless ebdb-silent
+ (message "Dialing %s" number))
+ (ebdb-dial-number number)))
+
+;;; url interface
+
+;;;###autoload
+(defun ebdb-browse-url (records &optional which)
+ "Browse URLs stored in the `url' field of RECORDS.
+Interactively, use EBDB prefix \
+\\<ebdb-mode-map>\\[ebdb-do-all-records], see `ebdb-do-all-records'.
+Prefix WHICH specifies which URL in field `url' is used (starting from 0).
+Default is the first URL."
+ (interactive (list (ebdb-get-records "Visit (URL): ")
+ (and current-prefix-arg
+ (prefix-numeric-value current-prefix-arg))))
+ (unless which (setq which 0))
+ (dolist (record (ebdb-record-list records))
+ (let ((url (ebdb-record-xfield-split record 'url)))
+ (when url
+ (setq url (read-string "fetch: " (nth which url)))
+ (unless (string= "" url)
+ (browse-url url))))))
+
+;;;###autoload
+(defun ebdb-grab-url (record url label)
+ "Grab URL and store it in RECORD."
+ (interactive (let ((url (browse-url-url-at-point)))
+ (unless url (error "No URL at point"))
+ (list (ebdb-completing-read-record
+ (format "Add `%s' for: " url))
+ url
+ (ebdb-read-string "URL label: "
+ nil ebdb-url-label-list))))
+ (let ((url-field (make-instance 'ebdb-field-url :url url :object-name
label)))
+ (ebdb-record-insert-field record 'fields url-field)
+ (ebdb-display-records (list record))))
+
+;;; Copy to kill ring
+
+;;;###autoload
+(defun ebdb-copy-records-as-kill (records)
+ "Copy RECORDS to kill ring.
+Interactively, use EBDB prefix \
+\\<ebdb-mode-map>\\[ebdb-do-all-records], see `ebdb-do-all-records'."
+ (interactive (list (ebdb-do-records t)))
+ (let (drec)
+ (dolist (record (ebdb-record-list records t))
+ (push (buffer-substring (nth 2 record)
+ (or (nth 2 (car (cdr (memq record
ebdb-records))))
+ (point-max)))
+ drec))
+ (kill-new (replace-regexp-in-string
+ "[ \t\n]*\\'" "\n"
+ (mapconcat 'identity (nreverse drec) "")))))
+
+;;;###autoload
+(defun ebdb-copy-fields-as-kill (records field &optional num)
+ "For RECORDS copy values of FIELD at point to kill ring.
+If FIELD is an address or phone with a label, copy only field values
+with the same label. With numeric prefix NUM, if the value of FIELD
+is a list, copy only the NUMth list element.
+Interactively, use EBDB prefix \
+\\<ebdb-mode-map>\\[ebdb-do-all-records], see `ebdb-do-all-records'."
+ (interactive
+ (list (ebdb-do-records t) (ebdb-current-field)
+ (and current-prefix-arg
+ (prefix-numeric-value current-prefix-arg))))
+ (unless field (error "Not a field"))
+ (let ((field-class (eieio-object-class field))
+ val-list fields)
+ ;; Store the first field string, then pop the record list. If
+ ;; there's only one record, this keeps things simpler.
+ (push (ebdb-string field) val-list)
+ (setq records (cdr (ebdb-record-list records)))
+ (dolist (record records)
+ (setq fields
+ (seq-filter
+ (lambda (f)
+ (same-class-p f field-class))
+ (mapcar #'cdr (ebdb-record-current-fields (car record)))))
+ (when (object-of-class-p field 'ebdb-field-labeled)
+ (setq fields
+ (seq-filter
+ (lambda (f)
+ (string= (eieio-object-name-string f)
+ (eieio-object-name-string field)))
+ fields)))
+ (when (and num (> 1 (length fields)))
+ (setq fields (list (nth num fields))))
+ (dolist (f fields)
+ (push (ebdb-string f) val-list)))
+ (let ((str (ebdb-concat 'record (nreverse val-list))))
+ (kill-new str)
+ (message "%s" str))))
+
+
+
+;;; Help and documentation
+
+;;;###autoload
+(defun ebdb-info ()
+ (interactive)
+ (info (format "(%s)Top" (or ebdb-info-file "ebdb"))))
+
+;;;###autoload
+(defun ebdb-help ()
+ (interactive)
+ (message (substitute-command-keys "\\<ebdb-mode-map>\
+new field: \\[ebdb-insert-field]; \
+edit field: \\[ebdb-edit-field]; \
+delete field: \\[ebdb-delete-field-or-record]; \
+mode help: \\[describe-mode]; \
+info: \\[ebdb-info]")))
+
+(provide 'ebdb-com)
+;;; ebdb-com.el ends here
diff --git a/ebdb-format.el b/ebdb-format.el
new file mode 100644
index 0000000..2461afa
--- /dev/null
+++ b/ebdb-format.el
@@ -0,0 +1,415 @@
+;;; ebdb-format.el --- Formatting/exporting EBDB records -*- lexical-binding:
t; -*-
+
+;; Copyright (C) 2016 Free Software Foundation, Inc.
+
+;; Author: Eric Abrahamsen <address@hidden>
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; This file contains code for take record objects and turning them
+;; into text, somehow. It provides the basic framework that is used
+;; for creating the *EBDB* buffer as well as exporting to vcard,
+;; latex, and html formats.
+
+;;; Code:
+
+(require 'ebdb)
+;; qp = quoted-printable, might not end up needing this.
+(require 'qp)
+
+(defvar ebdb-formatter-tracker nil
+ "Variable for holding all instantiated formatters.")
+
+(defclass ebdb-formatter (eieio-named eieio-instance-tracker)
+ ((tracking-symbol :initform ebdb-formatter-tracker)
+ (coding-system
+ :type symbol
+ :initarg :coding-system
+ :initform nil
+ :documentation "The coding system for the formatted
+ file/buffer/stream.")
+ ;; TODO: Provide for "psuedo field classes" like 'primary-mail and
+ ;; 'role-mail.
+ (include
+ :type list
+ :initarg :include
+ :initform nil
+ :documentation "A list of field classes to include. If both
+ \"include\" and \"exclude\" are given, the \"exclude\" slot
+ will be ignored.")
+ (exclude
+ :type list
+ :initarg :exclude
+ :initform '(ebdb-field-uuid ebdb-field-timestamp ebdb-field-creation-date)
+ :documentation "A list of field classes to exclude.")
+ (sort
+ :type list
+ :initarg :sort
+ :initform '(ebdb-field-mail ebdb-field-phone ebdb-field-address "_"
ebdb-field-notes))
+ (primary
+ :type boolean
+ :initarg :primary
+ :initform nil)
+ (header
+ :type list
+ :initarg :header
+ :initform '((ebdb-record-person ebdb-field-role ebdb-field-image)
+ (ebdb-record-organization ebdb-field-domain ebdb-field-image))
+ :documentation "A list of field classes which will be output
+ in the header of the record, grouped by record class type.")
+ (combine
+ :type list
+ :initarg :combine
+ :initform '(ebdb-field-mail ebdb-field-phone)
+ :documentation "A list of field classes which should be
+ output with all instances grouped together.")
+ (collapse
+ :type list
+ :initarg :collapse
+ :initform nil
+ :documentation "A list of field classes which should be
+ \"collapsed\". What this means is up to the formatter, but it
+ generally indicates that most of the field contents will
+ hidden unless the user takes some action, such as clicking or
+ hitting <TAB>. (Currently unimplemented.)"))
+ :abstract t
+ :documentation "Abstract base class for EBDB formatters.
+ Subclass this to produce real formatters.")
+
+(eieio-oset-default 'ebdb-formatter 'coding-system buffer-file-coding-system)
+
+(cl-defmethod ebdb-string ((fmt ebdb-formatter))
+ (slot-value fmt 'object-name))
+
+(defgeneric ebdb-fmt-header (fmt records)
+ "Insert a string at the beginning of the list of records.")
+
+(defgeneric ebdb-fmt-footer (fmt records)
+ "Insert a string at the end of the list of records.")
+
+(defgeneric ebdb-fmt-record (fmt record)
+ "Handle the insertion of formatted RECORD.
+
+This method collects all the fields to be output for RECORD,
+groups them into header fields and body fields, and then calls
+`ebdb-fmt-record-header' and `ebdb-fmt-record-body' with the two
+lists, respectively.")
+
+(defgeneric ebdb-fmt-record-header (fmt record fields)
+ "Format a header for RECORD, using the fields in FIELDS.")
+
+(defgeneric ebdb-fmt-record-body (fmt record fields)
+ "Format the body of RECORD, using the fields in FIELDS.")
+
+(defgeneric ebdb-fmt-collect-fields (fmt record &optional fields)
+ "Return a list of RECORD's FIELDS to be formatted.
+
+Each element of FIELDS is either a single field instance, or a
+list of field instances. Which fields are present, how they're
+sorted, and how they're combined into lists is determined by the
+\"exclude\" and \"sort\" slots of FMT.")
+
+(defgeneric ebdb-fmt-process-fields (fmt record &optional fields))
+
+(defgeneric ebdb-fmt-sort-fields (fmt record &optional fields))
+
+;; Do we still need this now that formatters and specs are collapsed?
+(defgeneric ebdb-fmt-compose-field (fmt field-cons record))
+
+(defgeneric ebdb-fmt-field (fmt field style record)
+ "Format FIELD value of RECORD.
+
+This method only returns the string value of FIELD itself,
+possibly with text properties attached.")
+
+(defgeneric ebdb-fmt-field-label (fmt field-or-class style record)
+ "Format a field label, using formatter FMT.
+
+FIELD-OR-CLASS is a field class or a field instance, and STYLE is
+a symbol indicating a style of some sort, such as 'compact or
+'expanded.")
+
+;;; Basic method implementations
+
+(cl-defmethod ebdb-fmt-header (_fmt _records)
+ "")
+
+(cl-defmethod ebdb-fmt-footer (_fmt _records)
+ "")
+
+(cl-defmethod ebdb-fmt-compose-field ((fmt ebdb-formatter)
+ field-plist
+ (record ebdb-record))
+ "Turn FIELD-PLIST into a list structure suitable for formatting.
+
+The FIELD-PLIST structure is that returned by
+`ebdb-fmt-collect-fields'. It is a plist with three
+keys: :class, :style, and :inst.
+
+This function passes the class and field instances to FMT,
+which formats them appropriately."
+ (let* ((style (plist-get field-plist :style))
+ (inst (plist-get field-plist :inst))
+ (label (ebdb-fmt-field-label fmt
+ (if (= 1 (length inst))
+ (car inst)
+ (plist-get field-plist :class))
+ style
+ record)))
+ (cons label
+ (mapconcat
+ (lambda (f)
+ (ebdb-fmt-field fmt f style record))
+ inst
+ ", "))))
+
+(cl-defmethod ebdb-fmt-field-label ((fmt ebdb-formatter)
+ (cls (subclass ebdb-field))
+ _style
+ (record ebdb-record))
+ (ebdb-field-readable-name cls))
+
+(cl-defmethod ebdb-fmt-field-label ((fmt ebdb-formatter)
+ (field ebdb-field)
+ _style
+ (record ebdb-record))
+ (ebdb-field-readable-name field))
+
+(cl-defmethod ebdb-fmt-field-label ((fmt ebdb-formatter)
+ (field ebdb-field-labeled)
+ _style
+ (record ebdb-record))
+ (eieio-object-name-string field))
+
+(cl-defmethod ebdb-fmt-field-label ((fmt ebdb-formatter)
+ (field ebdb-field-labeled)
+ (style (eql compact))
+ (record ebdb-record))
+ (ebdb-field-readable-name field))
+
+(cl-defmethod ebdb-fmt-field ((fmt ebdb-formatter)
+ (field ebdb-field-labeled)
+ (style (eql compact))
+ (record ebdb-record))
+ (format "(%s) %s"
+ (eieio-object-name-string field)
+ (ebdb-fmt-field fmt field 'oneline record)))
+
+(cl-defmethod ebdb-fmt-field ((fmt ebdb-formatter)
+ (field ebdb-field)
+ (style (eql oneline))
+ (record ebdb-record))
+ (car (split-string (ebdb-string field) "\n")))
+
+(cl-defmethod ebdb-fmt-field ((fmt ebdb-formatter)
+ (field ebdb-field)
+ _style
+ (record ebdb-record))
+ "The base implementation for FIELD simply returns the value of
+ `ebdb-string'."
+ (ebdb-string field))
+
+(cl-defmethod ebdb-fmt-collect-fields ((fmt ebdb-formatter)
+ (record ebdb-record)
+ &optional field-list)
+ (let (f-class)
+ (with-slots (fields notes uuid creation-date timestamp) record
+ (with-slots (exclude include) fmt
+ (dolist (f (append fields (list notes uuid creation-date timestamp)))
+ (when f
+ (setq f-class (eieio-object-class-name f))
+ (when (if include
+ (ebdb-class-in-list-p f-class include)
+ (null (ebdb-class-in-list-p f-class exclude)))
+ (push f field-list))))
+ field-list))))
+
+(cl-defmethod ebdb-fmt-collect-fields ((fmt ebdb-formatter)
+ (record ebdb-record-entity)
+ &optional field-list)
+ (with-slots (include exclude primary) fmt
+ (with-slots (mail phone address) record
+ (when (and mail
+ (if include
+ (memq 'ebdb-field-mail include)
+ (null (memq 'ebdb-field-mail exclude))))
+ (if primary
+ (push (object-assoc 'primary 'priority mail) field-list)
+ (dolist (m mail)
+ (push m field-list))))
+ (when (and phone
+ (if include
+ (memq 'ebdb-field-phone include)
+ (null (memq 'ebdb-field-phone exclude))))
+ (dolist (p phone)
+ (push p field-list)))
+ (when (and address
+ (if include
+ (memq 'ebdb-field-address include)
+ (null (memq 'ebdb-field-address exclude))))
+ (dolist (a address)
+ (push a field-list)))
+ (cl-call-next-method fmt record field-list))))
+
+(cl-defmethod ebdb-fmt-collect-fields ((fmt ebdb-formatter)
+ (record ebdb-record-person)
+ &optional field-list)
+
+ (with-slots (exclude include) fmt
+ (with-slots (aka organizations relations) record
+ (when (and aka
+ (if include
+ (memq 'ebdb-field-name include)
+ (null (memq 'ebdb-field-name exclude))))
+ (dolist (n aka)
+ (push n field-list)))
+ (when (and organizations
+ (if include
+ (memq 'ebdb-field-role include)
+ (null (memq 'ebdb-field-role exclude))))
+ (dolist (r organizations)
+ (push r field-list)))
+ (when (and relations
+ (if include
+ (memq 'ebdb-field-relation include)
+ (null (memq 'ebdb-field-relation exclude))))
+ (dolist (r relations)
+ (push r field-list)))
+ (cl-call-next-method fmt record field-list))))
+
+(cl-defmethod ebdb-fmt-collect-fields ((fmt ebdb-formatter)
+ (record ebdb-record-organization)
+ &optional field-list)
+ (with-slots (exclude include) fmt
+ (when (and (slot-value record 'domain)
+ (if include
+ (memq 'ebdb-field-domain include)
+ (null (memq 'ebdb-field-domain exclude))))
+ (push (slot-value record 'domain) field-list))
+ (let ((roles (gethash (ebdb-record-uuid record) ebdb-org-hashtable)))
+ (when (and roles
+ (if include
+ (memq 'ebdb-field-role include)
+ (null (memq 'ebdb-field-role exclude))))
+ (dolist (r roles)
+ (push (cdr r) field-list)))
+ (cl-call-next-method fmt record field-list))))
+
+(cl-defmethod ebdb-fmt-sort-fields ((fmt ebdb-formatter)
+ (record ebdb-record)
+ field-list)
+ (let ((sort (slot-value fmt 'sort))
+ f acc outlist)
+ (when sort
+ (dolist (s sort)
+ (if (symbolp s)
+ (progn
+ (setq class (cl--find-class s))
+ (while (setq f (pop field-list))
+ (if (same-class-p f class)
+ (push f outlist)
+ (push f acc)))
+ (setq field-list acc
+ acc nil))
+ ;; We assume this is the "_" value. Actually, anything
+ ;; would do as a catchall placeholder.
+ (dolist (fld field-list)
+ (setq class (eieio-object-class-name fld))
+ (unless (memq class sort)
+ ;; This isn't enough -- field still need to be grouped
+ ;; by field class.
+ (push fld outlist)))))
+ (setq field-list (nreverse outlist)))
+ field-list))
+
+(cl-defmethod ebdb-fmt-process-fields ((fmt ebdb-formatter)
+ (record ebdb-record)
+ field-list)
+ "Process FIELD-LIST for FMT.
+
+At present that means handling the combine and collapse slots of
+FMT.
+
+This method assumes that fields in FIELD-LIST have already been
+grouped by field class."
+ (let (outlist cls f acc)
+ (with-slots (combine collapse) fmt
+ (when combine
+ (while (setq f (pop field-list))
+ (setq cls (eieio-object-class-name f))
+ (if (null (ebdb-class-in-list-p cls combine))
+ (push f outlist)
+ (push f acc)
+ (while (and field-list (same-class-p (car field-list)
(eieio-object-class f)))
+ (push (setq f (pop field-list)) acc))
+ (push `(:class ,cls :style compact :inst ,acc) outlist)
+ (setq acc nil)))
+ (setq field-list (nreverse outlist)
+ outlist nil))
+ (dolist (f field-list)
+ (if (listp f)
+ (push f outlist)
+ (setq cls (eieio-object-class-name f))
+ (push (list :class cls
+ :inst (list f)
+ :style
+ (cond
+ ((ebdb-class-in-list-p cls collapse) 'collapse)
+ (t 'oneline)))
+ outlist)))
+ outlist)))
+
+;;; Basic export routines
+
+(defcustom ebdb-format-buffer-name "*EBDB Format*"
+ "Default name of buffer in which to display formatted records."
+ :type 'string
+ :group 'ebdb-record-display)
+
+(defun ebdb-prompt-for-formatter ()
+ (interactive)
+ (let ((collection
+ (mapcar
+ (lambda (formatter)
+ (cons (slot-value formatter 'object-name) formatter))
+ ebdb-formatter-tracker)))
+ (cdr (assoc (completing-read "Use formatter: " collection)
+ collection))))
+
+;;;###autoload
+(defun ebdb-format-to-tmp-buffer (&optional formatter records)
+ (interactive
+ (list (ebdb-prompt-for-formatter)
+ (ebdb-do-records)))
+ (let ((buf (get-buffer-create ebdb-format-buffer-name))
+ (fmt-coding (slot-value formatter 'coding-system)))
+ (with-current-buffer buf
+ (erase-buffer)
+ (insert (ebdb-fmt-header formatter records))
+ (dolist (r records)
+ (insert (ebdb-fmt-record formatter r)))
+ (insert (ebdb-fmt-footer formatter records))
+ (set-buffer-file-coding-system fmt-coding))
+ (pop-to-buffer buf)))
+
+;;;###autoload
+(defun ebdb-format-all-records (&optional formatter)
+ (interactive
+ (list (ebdb-prompt-for-formatter)))
+ (ebdb-format-to-tmp-buffer formatter (ebdb-records)))
+
+(provide 'ebdb-format)
+;;; ebdb-format.el ends here
diff --git a/ebdb-gnorb.el b/ebdb-gnorb.el
new file mode 100644
index 0000000..dbae6bb
--- /dev/null
+++ b/ebdb-gnorb.el
@@ -0,0 +1,60 @@
+;;; ebdb-gnorb.el --- Utilities for connecting EBDB to Gnorb -*-
lexical-binding: t; -*-
+
+;; Copyright (C) 2016 Free Software Foundation, Inc.
+
+;; Author: Eric Abrahamsen <address@hidden>
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; Bits and pieces useful for tying EBDB in with Gnorb. This file
+;; will eventually be moved to the Gnorb package.
+
+;;; Code:
+
+(cl-defstruct gnorb-ebdb-link
+ subject date group id)
+
+(defclass gnorb-ebdb-field-messages (ebdb-field-user)
+ ((messages
+ :type (list-of gnorb-ebdb-link)
+ :initarg :messages
+ :initform nil))
+ :human-readable "gnorb messages")
+
+(cl-defmethod ebdb-string ((_field gnorb-ebdb-field-messages))
+ "Some messages")
+
+(defcustom gnorb-ebdb-org-tag-field 'org-tags
+ "The name (as a symbol) of the field to use for org tags."
+ :group 'gnorb-ebdb
+ :type 'symbol)
+
+(defclass gnorb-ebdb-field-tags (ebdb-field-user)
+ ((tags
+ :type (list-of string)
+ :initarg :tags
+ :initform nil))
+ :human-readable "gnorb tags")
+
+(cl-defmethod ebdb-string ((field gnorb-ebdb-field-tags))
+ (ebdb-concat 'gnorb-ebdb-field-tags (slot-value field 'tags)))
+
+(cl-defmethod ebdb-read ((field (subclass gnorb-ebdb-field-tags)) &optional
slots obj)
+ (let ((val (ebdb-read-string "Tags: " (when obj (ebdb-string obj))
+ (org-global-tags-completion-table))))
+ (cl-call-next-method field (plist-put slots :tags (split-string val)))))
+
+(provide 'ebdb-gnorb)
diff --git a/ebdb-gnus.el b/ebdb-gnus.el
new file mode 100644
index 0000000..aa4ac35
--- /dev/null
+++ b/ebdb-gnus.el
@@ -0,0 +1,480 @@
+;;; ebdb-gnus.el --- Gnus interface to EBDB -*- lexical-binding: t;
-*-
+
+;; Copyright (C) 2016 Free Software Foundation, Inc.
+
+;; Author: Eric Abrahamsen <address@hidden>
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; Code for interaction with Gnus.
+
+;;; Code:
+
+(require 'ebdb-com)
+(require 'ebdb-mua)
+(require 'gnus)
+
+(defgroup ebdb-mua nil
+ "Variables that specify the EBDB-MUA interface"
+ :group 'ebdb)
+
+(defgroup ebdb-mua-gnus nil
+ "Gnus-specific EBDB customizations"
+ :group 'ebdb-mua)
+(put 'ebdb-mua-gnus 'custom-loads '(ebdb-gnus))
+
+(defgroup ebdb-mua-gnus-scoring nil
+ "Gnus-specific scoring EBDB customizations"
+ :group 'ebdb-mua-gnus)
+(put 'ebdb-mua-gnus-scoring 'custom-loads '(ebdb-gnus))
+
+(defgroup ebdb-mua-gnus-splitting nil
+ "Gnus-specific splitting EBDB customizations"
+ :group 'ebdb-mua-gnus)
+(put 'ebdb-mua-gnus-splitting 'custom-loads '(ebdb-gnus))
+
+;;; Gnus-specific field types. All should subclass
+;;; `ebdb-field-user'.
+
+(defclass ebdb-gnus-score-field (ebdb-field-user)
+ ((score
+ :type (or null number)
+ :initarg :score
+ :initval nil))
+ :human-readable "gnus score")
+
+(cl-defmethod ebdb-read ((field (subclass ebdb-gnus-score-field)) &optional
slots obj)
+ (let ((score (string-to-number
+ (ebdb-read-string
+ "Score: " (when obj (slot-value obj 'score))))))
+ (cl-call-next-method field (plist-put slots :score score) obj)))
+
+(cl-defmethod ebdb-string ((field ebdb-gnus-score-field))
+ (slot-value field 'score))
+
+(defclass ebdb-gnus-private-field (ebdb-field-user)
+ ((group
+ :type string
+ :initarg :group))
+ :human-readable "gnus private")
+
+(cl-defmethod ebdb-read ((field (subclass ebdb-gnus-private-field)) &optional
slots obj)
+ (let ((group (ebdb-read-string "Group name: " (when obj (slot-value obj
'group)))))
+ (cl-call-next-method)))
+
+(cl-defmethod ebdb-string ((field ebdb-gnus-private-field))
+ (slot-value field 'group))
+
+;; Scoring
+
+(defcustom ebdb/gnus-score-default nil
+ "If this is set, then every mail address in the EBDB that does not have
+an associated score field will be assigned this score. A value of nil
+implies a default score of zero."
+ :group 'ebdb-mua-gnus-scoring
+ :type '(choice (const :tag "Do not assign default score" nil)
+ (integer :tag "Assign this default score" 0)))
+
+(defvar ebdb/gnus-score-default-internal nil
+ "Internal variable for detecting changes to
+`ebdb/gnus-score-default'. You should not set this variable directly -
+set `ebdb/gnus-score-default' instead.")
+
+(defvar ebdb/gnus-score-alist nil
+ "The text version of the scoring structure returned by
+ebdb/gnus-score. This is built automatically from the EBDB.")
+
+(defvar ebdb/gnus-score-rebuild-alist t
+ "Set to t to rebuild ebdb/gnus-score-alist on the next call to
+ebdb/gnus-score. This will be set automatically if you change a EBDB
+record which contains a gnus-score field.")
+
+(defun ebdb/gnus-score-invalidate-alist (record)
+ "This function is called through `ebdb-after-change-hook',
+and sets `ebdb/gnus-score-rebuild-alist' to t if the changed
+record contains a gnus-score field."
+ (if (ebdb-record-user-field record ebdb-gnus-score-field)
+ (setq ebdb/gnus-score-rebuild-alist t)))
+
+;;;###autoload
+(defun ebdb/gnus-score (group)
+ "This returns a score alist for Gnus. A score pair will be made for
+every member of the mail field in records which also have a gnus-score
+field. This allows the EBDB to serve as a supplemental global score
+file, with the advantage that it can keep up with multiple and changing
+addresses better than the traditionally static global scorefile."
+ (list (list
+ (condition-case nil
+ (read (ebdb/gnus-score-as-text group))
+ (error (setq ebdb/gnus-score-rebuild-alist t)
+ (message "Problem building EBDB score table.")
+ (ding) (sit-for 2)
+ nil)))))
+
+(defun ebdb/gnus-score-as-text (group)
+ "Returns a SCORE file format string built from the EBDB."
+ (cond ((or (cond ((/= (or ebdb/gnus-score-default 0)
+ (or ebdb/gnus-score-default-internal 0))
+ (setq ebdb/gnus-score-default-internal
+ ebdb/gnus-score-default)
+ t))
+ (not ebdb/gnus-score-alist)
+ ebdb/gnus-score-rebuild-alist)
+ (setq ebdb/gnus-score-rebuild-alist nil)
+ (setq ebdb/gnus-score-alist
+ (concat "((touched nil) (\"from\"\n"
+ (mapconcat
+ (lambda (record)
+ (let ((score (or (ebdb-record-user-field record
ebdb-gnus-score-field)
+ ebdb/gnus-score-default))
+ (mail (ebdb-record-mail record)))
+ (when (and score mail)
+ (mapconcat
+ (lambda (address)
+ (format "(\"%s\" %s)\n" (ebdb-string address)
score))
+ mail ""))))
+ ebdb-record-tracker "")
+ "))"))))
+ ebdb/gnus-score-alist)
+
+;;; from Brian Edmonds' gnus-ebdb.el
+;;;
+;;; Splitting / filing with gnus-folder
+;;;
+;;; To use this feature, you need to put this file somewhere in your
+;;; load-path and add the following lines of code to your .gnus file:
+;;;
+;;; (setq nnmail-split-methods 'ebdb/gnus-split-method)
+;;;
+;;; You should also examine the variables defvar'd below and customize
+;;; them to your taste. They're listed roughly in descending likelihood
+;;; of your wanting to change them. Once that is done, you need to add
+;;; filing information to your EBDB. There are two fields of interest:
+;;;
+;;; 1. gnus-private. This field contains the name of the group in which
+;;; mail to you from any of the addresses associated with this record
+;;; will be filed. Also, any self-copies of mail you send any of the
+;;; same addresses will be filed here.
+;;; 2. gnus-public. This field is used to keep mail from mailing lists
+;;; out of the private mailboxes. It should be added to a record for
+;;; the list submission address, and is formatted as follows:
+;;; "group regexp"
+;;; where group is where mail from the list should be filed, and
+;;; regexp is a regular expression which is checked against the
+;;; envelope sender (from the From_ header) to verify that this is
+;;; the copy which came from the list. For example, the entry for
+;;; the ding mailing list might be:
+;;; "mail.emacs.ding address@hidden"
+;;; Yes, the second part *is* a regexp, so those dots may match
+;;; something other than dots. Sue me.
+;;;
+;;; Note that you can also specify a gnus-private field for mailing list
+;;; addresses, in which case self-copies of mail you send to the list
+;;; will be filed there. Also, the field names can be changed below if
+;;; the defaults are not hip enough for you. Lastly, if you specify a
+;;; gnus-private field for your *own* EBDB record, then all self-copies
+;;; of mail you send will be filed to that group.
+;;;
+;;; This documentation should probably be expanded and moved to a
+;;; separate file, but it's late, and *I* know what I'm trying to
+;;; say. :)
+
+(defcustom ebdb/gnus-split-default-group "mail.misc"
+ "If the EBDB does not indicate any group to spool a message to, it will
+be spooled to this group. If `ebdb/gnus-split-crosspost-default' is not
+nil, and if the EBDB did not indicate a specific group for one or more
+addresses, messages will be crossposted to this group in addition to any
+group(s) which the EBDB indicated."
+ :group 'ebdb-mua-gnus-splitting
+ :type 'string)
+
+(defcustom ebdb/gnus-split-nomatch-function nil
+ "This function will be called after searching the EBDB if no place to
+file the message could be found. It should return a group name (or list
+of group names) -- `nnmail-split-fancy' as provided with Gnus is an
+excellent choice."
+ :group 'ebdb-mua-gnus-splitting
+ :type 'function)
+
+(defcustom ebdb/gnus-split-myaddr-regexp
+ (concat "^" (user-login-name) "$\\|^"
+ (user-login-name) "@\\([-a-z0-9]+\\.\\)*"
+ (or (message-make-domain) (system-name) "") "$")
+ "This regular expression should match your address as found in the
+From header of your mail."
+ :group 'ebdb-mua-gnus-splitting
+ :type 'regexp)
+
+(defcustom ebdb/gnus-split-crosspost-default nil
+ "If this variable is not nil, then if the EBDB could not identify a
+group for every mail address, messages will be filed in
+`ebdb/gnus-split-default-group' in addition to any group(s) which the EBDB
+identified."
+ :group 'ebdb-mua-gnus-splitting
+ :type 'boolean)
+
+;; The split function works by assigning one of four spooling priorities
+;; to each group that is associated with an address in the message. The
+;; priorities are assigned as follows:
+;;
+;; 0. This priority is assigned when crosspost-default is nil to To/Cc
+;; addresses which have no private group defined in the EBDB. If the
+;; user's own address has no private group defined, then it will
+;; always be given this priority.
+;; 1. This priority is assigned to To/Cc addresses which have a private
+;; group defined in the EBDB. If crosspost-default is not nil, then
+;; To/Cc addresses which have no private group will also be assigned
+;; this priority. This is also assigned to the user's own address in
+;; the From position if a private group is defined for it.
+;; 2. This priority is assigned to From addresses which have a private
+;; group defined in the EBDB, except for the user's own address as
+;; described under priorities 0 and 1.
+;; 3. This priority is assigned to To/Cc addresses which have a public
+;; group defined in the EBDB, and whose associated regular expression
+;; matches the envelope sender (found in the header From_).
+;;
+;; The split function evaluates the spool priority for each address in
+;; the headers of the message, and returns as a list all the groups
+;; associated with the addresses which share the highest calculated
+;; priority.
+
+;;;###autoload
+(defun ebdb/gnus-split-method ()
+ "This function expects to be called in a buffer which contains a mail
+message to be spooled, and the buffer should be narrowed to the message
+headers. It returns a list of groups to which the message should be
+spooled, using the addresses in the headers and information from EBDB."
+ (let ((prq (list (list 0) (list 1) (list 2) (list 3))))
+ ;; the From: header is special
+ (let* ((hdr (or (mail-fetch-field "resent-from")
+ (mail-fetch-field "from")
+ (user-login-name)))
+ (rv (ebdb/gnus-split-to-group hdr t)))
+ (setcdr (nth (cdr rv) prq) (list (car rv))))
+ ;; do the rest of the headers
+ (let ((hdr (or (concat (or (mail-fetch-field "resent-to" nil t)
+ (mail-fetch-field "to" nil t))
+ ", "
+ (mail-fetch-field "cc" nil t)
+ ", "
+ (mail-fetch-field "apparently-to" nil t))
+ "")))
+ (dolist (address (ebdb-extract-address-components hdr t))
+ (let* ((rv (ebdb/gnus-split-to-group address))
+ (pr (nth (cdr rv) prq)))
+ (unless (member-ignore-case (car rv) pr)
+ (setcdr pr (cons (car rv) (cdr pr)))))))
+ ;; find the highest non-empty queue
+ (setq prq (reverse prq))
+ (while (and prq (not (cdr (car prq)))) (setq prq (cdr prq)))
+ ;; and return...
+ (if (not (or (not (cdr (car prq)))
+ (and (equal (cdr (car prq)) (list
ebdb/gnus-split-default-group))
+ (symbolp ebdb/gnus-split-nomatch-function)
+ (fboundp ebdb/gnus-split-nomatch-function))))
+ (cdr (car prq))
+ (goto-char (point-min))
+ (funcall ebdb/gnus-split-nomatch-function))))
+
+(defun ebdb/gnus-split-to-group (address &optional source)
+ "This function is called from `ebdb/gnus-split-method' in order to
+determine the group and spooling priority for a single address."
+ (condition-case nil
+ (let* ((tmp (ebdb-extract-address-components address))
+ (mail (cadr tmp))
+ (record (car (ebdb-message-search (car tmp) mail)))
+ public private rgx)
+ (when record
+ (setq private (ebdb-record-user-field record
ebdb-gnus-private-field)
+ ;; TODO: Fix this, there's no longer a public field.
+ public (ebdb-record-user-field record
ebdb/gnus-split-public-field))
+ (if (and public (not source) (string-match "^\\([^ ]+\\) \\(.*\\)$"
public))
+ (setq rgx (substring public (match-beginning 2) (match-end 2))
+ public (substring public (match-beginning 1) (match-end
1)))
+ (setq public nil)))
+ (cond
+ ((and rgx public
+ (goto-char (point-min))
+ (re-search-forward "^From: \\([^ \n]+\\)[ \n]" nil t)
+ (string-match rgx (buffer-substring (match-beginning 1)
+ (match-end 1))))
+ (cons public 3))
+ (private
+ (cons private
+ (- 1 (if source -1 0)
+ (if (string-match ebdb/gnus-split-myaddr-regexp mail) 1
0))))
+ (t
+ (cons ebdb/gnus-split-default-group
+ (cond ((string-match ebdb/gnus-split-myaddr-regexp mail) 0)
+ (source 2)
+ (ebdb/gnus-split-crosspost-default 1)
+ (t 0))))))
+ (error (cons ebdb/gnus-split-default-group 0))))
+
+;;
+;; Imap support (Uwe Brauer)
+;;
+
+;; Why wouldn't we just use the same "private" field for imap? Why
+;; would this need to be a separate field class?
+(defclass ebdb-gnus-imap-field (ebdb-field-user)
+ ((group
+ :type string
+ :initarg :group))
+ :human-readable "gnus imap")
+
+(cl-defmethod ebdb-read ((field (subclass ebdb/gnus-imap-field)) &optional
slots obj)
+ (let ((group (ebdb-read-string "Imap group: " (when obj (slot-value obj
'group)))))
+ (cl-call-next-method
+ field
+ (plist-put slots :group group)
+ obj)))
+
+(cl-defmethod ebdb-string ((field ebdb-gnus-imap-field))
+ (slot-value field 'group))
+
+(defun ebdb/gnus-nnimap-folder-list-from-ebdb ()
+ "Return a list of \( \"From\" mail-regexp imap-folder-name\) tuples
+based on the contents of the ebdb.
+
+The folder-name is the value of the 'imap attribute of the EBDB record;
+the mail-regexp consists of all the mail addresses for the EBDB record
+concatenated with OR. Records without an 'imap attribute are ignored.
+
+Here is an example of a relevant EBDB record:
+
+Uwe Brauer
+ mail: address@hidden
+ imap: testimap
+
+This function uses `regexp-opt' to generate the mail-regexp which automatically
+`regexp-quote's its arguments. Please note: in order that this will work
+with the `nnimap-split-fancy' method you have to use macros, that is your
setting
+will look like:
+
+\(setq nnimap-split-rule 'nnimap-split-fancy
+ nnimap-split-inbox \"INBOX\"
+ nnimap-split-fancy
+ `\(| ,@\(ebdb/gnus-nnimap-folder-list-from-ebdb\)
+ ... \)\)
+
+Note that `\( is the backquote, NOT the quote '\(."
+
+ (let (;; the value of the 'imap attribute of a ebdb record
+ folder-attr
+ ;; a regexp matching all the mail addresses from a ebdb record
+ mail-regexp
+ ;; the list of (folder mail) tuples to return
+ new-elmnt-list)
+ ;; Loop over EBDB records. If an imap attribute exists for
+ ;; the record, generate a regexp matching all the mail addresses
+ ;; and add a tuple (folder mail-regexp) to the new-elmnt-list
+ (dolist (record (ebdb-records))
+ (when (setq folder-attr (ebdb-record-user-field record 'imap))
+ (setq mail-regexp (regexp-opt (mapcar (lambda (m)
+ (downcase (ebdb-string m)))
+ (ebdb-record-mail record))))
+ (unless (string= "" mail-regexp)
+ (push (list "From" mail-regexp folder-attr)
+ new-elmnt-list))))
+ new-elmnt-list))
+
+;;
+;; Insinuation
+;;
+
+(add-hook 'gnus-article-prepare-hook 'ebdb-mua-auto-update)
+
+(add-hook 'gnus-startup-hook 'ebdb-insinuate-gnus)
+
+;; It seems that `gnus-fetch-field' fetches decoded content of
+;; `gnus-visible-headers', ignoring `gnus-ignored-headers'.
+;; Here we use instead `gnus-fetch-original-field' that fetches
+;; the encoded content of `gnus-original-article-buffer'.
+;; Decoding makes this possibly a bit slower, but something like
+;; `ebdb-select-message' does not get fooled by an apparent
+;; absence of some headers.
+;; See http://permalink.gmane.org/gmane.emacs.gnus.general/78741
+
+(cl-defmethod ebdb-message-header ((header string)
+ &context (major-mode (eql
gnus-summary-mode)))
+ "Return value of HEADER for current Gnus message."
+ (set-buffer gnus-article-buffer)
+ (gnus-fetch-original-field header))
+
+;; This is all a little goofy.
+(cl-defmethod ebdb-message-header ((header string)
+ &context (major-mode (eql
gnus-article-mode)))
+ (set-buffer gnus-article-buffer)
+ (gnus-fetch-original-field header))
+
+(cl-defmethod ebdb-message-header ((header string)
+ &context (major-mode (eql gnus-tree-mode)))
+ (set-buffer gnus-article-buffer)
+ (gnus-fetch-original-field header))
+
+(cl-defmethod ebdb-mua-prepare-article (&context (major-mode (eql
gnus-summary-mode)))
+ (gnus-summary-select-article))
+
+(cl-defmethod ebdb-mua-prepare-article (&context (major-mode (eql
gnus-article-mode)))
+ (gnus-summary-select-article))
+
+(defun ebdb-insinuate-gnus ()
+ "Hook EBDB into Gnus."
+ ;; `ebdb-mua-display-sender' fails in *Article* buffers, where
+ ;; `gnus-article-read-summary-keys' provides an additional wrapper
+ ;; that restores the window configuration.
+ (define-key gnus-summary-mode-map ":" 'ebdb-mua-display-sender)
+ (define-key gnus-article-mode-map ":" 'ebdb-mua-display-sender)
+ ;; For `ebdb-mua-edit-field-sender' it is probably OK if
+ ;;`gnus-article-read-summary-keys' restores the window configuration.
+ (define-key gnus-summary-mode-map ";" 'ebdb-mua-edit-field-sender)
+ (define-key gnus-article-mode-map ";" 'ebdb-mua-edit-field-sender)
+ ;; Do we need keybindings for more commands? Suggestions welcome.
+ ;; (define-key gnus-summary-mode-map ":" 'ebdb-mua-display-records)
+ ;; (define-key gnus-summary-mode-map "'" 'ebdb-mua-display-recipients)
+ ;; (define-key gnus-summary-mode-map ";" 'ebdb-mua-edit-field-recipients)
+
+ ;; Set up user field for use in `gnus-summary-line-format'
+ ;; (1) Big solution: use whole name
+ (if ebdb-mua-summary-unify-format-letter
+ (fset (intern (concat "gnus-user-format-function-"
+ ebdb-mua-summary-unify-format-letter))
+ (lambda (header)
+ (ebdb-mua-summary-unify (mail-header-from header)))))
+
+ ;; (2) Small solution: a mark for messages whos sender is in EBDB.
+ (if ebdb-mua-summary-mark-format-letter
+ (fset (intern (concat "gnus-user-format-function-"
+ ebdb-mua-summary-mark-format-letter))
+ (lambda (header)
+ (ebdb-mua-summary-mark (mail-header-from header)))))
+
+ ;; Scoring
+; (add-hook 'ebdb-after-change-hook 'ebdb/gnus-score-invalidate-alist)
+ )
+ ;; (setq gnus-score-find-score-files-function
+ ;; (if (boundp 'gnus-score-find-score-files-function)
+ ;; (cond ((functionp gnus-score-find-score-files-function)
+ ;; (list gnus-score-find-score-files-function 'ebdb/gnus-score))
+ ;; ((listp gnus-score-find-score-files-function)
+ ;; (append gnus-score-find-score-files-function
'ebdb/gnus-score))
+ ;; (t 'ebdb/gnus-score))
+ ;; 'ebdb/gnus-score))
+
+(provide 'ebdb-gnus)
+;;; ebdb-gnus.el ends here
+;;;
diff --git a/ebdb-i18n.el b/ebdb-i18n.el
new file mode 100644
index 0000000..8f35cd1
--- /dev/null
+++ b/ebdb-i18n.el
@@ -0,0 +1,738 @@
+;;; ebdb-i18n.el --- Internationalization support for EBDB -*-
lexical-binding: t; -*-
+
+;; Copyright (C) 2016 Free Software Foundation, Inc.
+
+;; Author: Eric Abrahamsen <address@hidden>
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; This file contains extensions to EBDB, making it more
+;; internationally aware. It works by hijacking many of the common
+;; methods for field manipulation, and dispatching to new methods that
+;; allow for specialization on country codes, area codes, character
+;; scripts, etc. The new methods are generally named the same as the
+;; old methods, plus a "-i18n" suffix.
+
+;; The methods in this file are only responsible for doing the
+;; hijacking, and calling the i18n versions of the original methods --
+;; the i18n versions themselves live in other, country-specific,
+;; libraries. If no methods have specialized on the arguments in
+;; question, `cl-no-applicable-method' is raised, and the hijacker
+;; methods return control to the original methods.
+
+;;; Code:
+
+(require 'ebdb)
+;; Require all i18n libraries provided by EBDB. Third-party i18n
+;; libraries should require this library.
+(require 'ebdb-chn)
+
+(defgroup ebdb-i18n nil
+ "Options for EBDB internationalization."
+ :group 'ebdb)
+
+(defcustom ebdb-i18n-ignorable-scripts '(latin)
+ "A list of script types that should be considered \"standard\";
+ ie, no special handling will be done for them."
+ :type 'list
+ :group 'ebdb-i18n)
+
+(cl-defgeneric ebdb-read-i18n (class slots obj spec)
+ "An internationalized version of `ebdb-read'.
+
+This works the same as `ebdb-read', plus an additional argument
+SPEC. What SPEC is depends on CLASS, but might be a phone
+country code, or a country symbol, or a script symbol.
+
+This method should return a plist of slots for object creation.")
+
+(cl-defgeneric ebdb-parse-i18n (class string spec)
+ "An internationalized version of `ebdb-parse'.
+
+This works the same as `ebdb-read', plus an additional argument
+SPEC. What SPEC is depends on CLASS, but might be a phone
+country code, or a country symbol, or a script symbol.
+
+This method should return a new instance of CLASS.")
+
+(cl-defgeneric ebdb-string-i18n (field spec)
+ "An internationalized version of `ebdb-string'.")
+
+(cl-defgeneric ebdb-init-i18n (field record spec)
+ "An internationalized version of `ebdb-init'.")
+
+(cl-defgeneric ebdb-delete-i18n (field record spec unload)
+ "An internationalized version of `ebdb-delete'.")
+
+;;;###autoload
+(defun ebdb-internationalize-addresses ()
+ "Go through all the EBDB contacts and \"internationalize\"
+ address fields.
+
+Essentially this just means swapping out the string country names
+for their symbol representations.")
+
+(cl-defmethod ebdb-read :extra "i18n" ((class (subclass ebdb-field-address))
+ &optional slots obj)
+ (let ((country
+ (cdr (assoc (completing-read
+ "Country: "
+ ebdb-i18n-countries nil nil
+ (when obj (car (rassoc (ebdb-address-country obj)
+ ebdb-i18n-countries))))
+ ebdb-i18n-countries))))
+ (setq slots
+ (condition-case nil
+ (ebdb-read-i18n class
+ (plist-put slots :country country) obj country)
+ (cl-no-applicable-method
+ (plist-put slots :country country))))
+ (cl-call-next-method class slots obj)))
+
+(cl-defmethod ebdb-read :extra "i18n" ((class (subclass ebdb-field-phone))
+ &optional slots obj)
+ (let ((country
+ (if obj
+ (slot-value obj 'country-code)
+ (cdr (assoc (completing-read
+ "Country/Region: "
+ ebdb-i18n-phone-codes nil nil)
+ ebdb-i18n-phone-codes))))
+ area-code)
+ ;; Obviously this whole structure thing is just poorly
+ ;; thought-out.
+ (when (consp country)
+ (cond ((numberp (car country))
+ (setq area-code (second country)
+ country (car country)))
+ ((consp (car country))
+ (setq country (assoc
+ (string-to-number
+ (completing-read
+ "Choose: "
+ (mapcar (lambda (x)
+ (number-to-string (car x)))
+ country)))
+ country)
+ area-code (second country))))
+ (when (consp area-code)
+ (setq area-code (string-to-number
+ (completing-read
+ "Area code: "
+ (mapcar #'number-to-string area-code))))))
+ (when area-code
+ (setq slots (plist-put slots :area-code area-code)))
+ (setq slots (plist-put slots :country-code country))
+ (setq slots
+ (condition-case nil
+ (ebdb-read-i18n class slots obj country)
+ (cl-no-applicable-method
+ slots)))
+ (cl-call-next-method class slots obj)))
+
+
+;; We don't need to override the `ebdb-read' method for names. It
+;; only matters what script the name is in if the user has set
+;; `ebdb-read-name-articulate' to nil, in which case the name is
+;; passed to this `ebdb-parse' method.
+(cl-defmethod ebdb-parse :extra "i18n" ((class (subclass
ebdb-field-name-complex))
+ (string string))
+ ;; For now, only test the first character of whatever string the
+ ;; user has entered.
+ (let ((script (unless (string-empty-p string)
+ (aref char-script-table (aref string 0)))))
+ (or (and script
+ (null (memq script ebdb-i18n-ignorable-scripts))
+ (condition-case nil
+ (ebdb-parse-i18n class string script)
+ (cl-no-applicable-method
+ nil)))
+ (cl-call-next-method))))
+
+(cl-defmethod ebdb-string :extra "i18n" ((name ebdb-field-name-complex))
+ (let* ((str (cl-call-next-method name))
+ (script (aref char-script-table (aref str 0))))
+ (unless (memq script ebdb-i18n-ignorable-scripts)
+ (condition-case nil
+ (setq str (ebdb-string-i18n name script))
+ (cl-no-applicable-method nil)))
+ str))
+
+(cl-defmethod ebdb-init :extra "i18n" ((name ebdb-field-name) &optional record)
+ "Do additional initialization work for international names."
+ (let* ((res (cl-call-next-method name record))
+ (str (ebdb-string name))
+ (script (aref char-script-table (aref str 0))))
+ (unless (memq script ebdb-i18n-ignorable-scripts)
+ (condition-case nil
+ (ebdb-init-i18n name record script)
+ (cl-no-applicable-method nil)))
+ res))
+
+(cl-defmethod ebdb-delete :extra "i18n" ((name ebdb-field-name) &optional
record unload)
+ "Do additional deletion work for international names."
+ (let* ((str (ebdb-string name))
+ (script (aref char-script-table (aref str 0))))
+ (unless (memq script ebdb-i18n-ignorable-scripts)
+ (condition-case nil
+ (ebdb-delete-i18n name record script unload)
+ (cl-no-applicable-method nil))))
+ (cl-call-next-method))
+
+(defvar ebdb-i18n-countries
+ '(
+("Afghanistan" . afg)
+("Åland Islands" . ala)
+("Albania" . alb)
+("Algeria" . dza)
+("American Samoa" . asm)
+("Andorra" . and)
+("Angola" . ago)
+("Anguilla" . aia)
+("Antarctica" . ata)
+("Antigua and Barbuda" . atg)
+("Argentina" . arg)
+("Armenia" . arm)
+("Aruba" . abw)
+("Australia" . aus)
+("Austria" . aut)
+("Azerbaijan" . aze)
+("Bahamas" . bhs)
+("Bahrain" . bhr)
+("Bangladesh" . bgd)
+("Barbados" . brb)
+("Belarus" . blr)
+("Belgium" . bel)
+("Belize" . blz)
+("Benin" . ben)
+("Bermuda" . bmu)
+("Bhutan" . btn)
+("Bolivia" . bol)
+("Bonaire" . bes)
+("Sint Eustatius" . bes)
+("Saba" . bes)
+("Bosnia and Herzegovina" . bih)
+("Botswana" . bwa)
+("Bouvet Island" . bvt)
+("Brazil" . bra)
+("British Indian Ocean Territory" . iot)
+("Brunei Darussalam" . brn)
+("Bulgaria" . bgr)
+("Burkina Faso" . bfa)
+("Burundi" . bdi)
+("Cabo Verde" . cpv)
+("Cambodia" . khm)
+("Cameroon" . cmr)
+("Canada" . can)
+("Cayman Islands" . cym)
+("Central African Republic" . caf)
+("Chad" . tcd)
+("Chile" . chl)
+("China" . chn)
+("Christmas Island" . cxr)
+("Cocos (Keeling) Islands" . cck)
+("Colombia" . col)
+("Comoros" . com)
+("Congo" . cog)
+("Congo" . cod)
+("Cook Islands" . cok)
+("Costa Rica" . cri)
+("Côte d'Ivoire" . civ)
+("Croatia" . hrv)
+("Cuba" . cub)
+("Curaçao" . cuw)
+("Cyprus" . cyp)
+("Czech Republic" . cze)
+("Denmark" . dnk)
+("Djibouti" . dji)
+("Dominica" . dma)
+("Dominican Republic" . dom)
+("Ecuador" . ecu)
+("Egypt" . egy)
+("El Salvador" . slv)
+("Emacs" . emc)
+("Equatorial Guinea" . gnq)
+("Eritrea" . eri)
+("Estonia" . est)
+("Ethiopia" . eth)
+("Falkland Islands" . flk)
+("Faroe Islands" . fro)
+("Fiji" . fji)
+("Finland" . fin)
+("France" . fra)
+("French Guiana" . guf)
+("French Polynesia" . pyf)
+("French Southern Territories" . atf)
+("Gabon" . gab)
+("Gambia" . gmb)
+("Georgia" . geo)
+("Germany" . deu)
+("Ghana" . gha)
+("Gibraltar" . gib)
+("Greece" . grc)
+("Greenland" . grl)
+("Grenada" . grd)
+("Guadeloupe" . glp)
+("Guam" . gum)
+("Guatemala" . gtm)
+("Guernsey" . ggy)
+("Guinea" . gin)
+("Guinea-Bissau" . gnb)
+("Guyana" . guy)
+("Haiti" . hti)
+("Heard Island and McDonald Islands" . hmd)
+("Holy See" . vat)
+("Honduras" . hnd)
+("Hong Kong" . hkg)
+("Hungary" . hun)
+("Iceland" . isl)
+("India" . ind)
+("Indonesia" . idn)
+("Iran" . irn)
+("Iraq" . irq)
+("Ireland" . irl)
+("Isle of Man" . imn)
+("Israel" . isr)
+("Italy" . ita)
+("Jamaica" . jam)
+("Japan" . jpn)
+("Jersey" . jey)
+("Jordan" . jor)
+("Kazakhstan" . kaz)
+("Kenya" . ken)
+("Kiribati" . kir)
+("North Korea" . prk)
+("South Korea" . kor)
+("Kuwait" . kwt)
+("Kyrgyzstan" . kgz)
+("Lao People's Democratic Republic" . lao)
+("Latvia" . lva)
+("Lebanon" . lbn)
+("Lesotho" . lso)
+("Liberia" . lbr)
+("Libya" . lby)
+("Liechtenstein" . lie)
+("Lithuania" . ltu)
+("Luxembourg" . lux)
+("Macao" . mac)
+("Macedonia" . mkd)
+("Madagascar" . mdg)
+("Malawi" . mwi)
+("Malaysia" . mys)
+("Maldives" . mdv)
+("Mali" . mli)
+("Malta" . mlt)
+("Marshall Islands" . mhl)
+("Martinique" . mtq)
+("Mauritania" . mrt)
+("Mauritius" . mus)
+("Mayotte" . myt)
+("Mexico" . mex)
+("Micronesia" . fsm)
+("Moldova" . mda)
+("Monaco" . mco)
+("Mongolia" . mng)
+("Montenegro" . mne)
+("Montserrat" . msr)
+("Morocco" . mar)
+("Mozambique" . moz)
+("Myanmar" . mmr)
+("Namibia" . nam)
+("Nauru" . nru)
+("Nepal" . npl)
+("Netherlands" . nld)
+("New Caledonia" . ncl)
+("New Zealand" . nzl)
+("Nicaragua" . nic)
+("Niger" . ner)
+("Nigeria" . nga)
+("Niue" . niu)
+("Norfolk Island" . nfk)
+("Northern Mariana Islands" . mnp)
+("Norway" . nor)
+("Oman" . omn)
+("Pakistan" . pak)
+("Palau" . plw)
+("Palestine" . pse)
+("Panama" . pan)
+("Papua New Guinea" . png)
+("Paraguay" . pry)
+("Peru" . per)
+("Philippines" . phl)
+("Pitcairn" . pcn)
+("Poland" . pol)
+("Portugal" . prt)
+("Puerto Rico" . pri)
+("Qatar" . qat)
+("Réunion" . reu)
+("Romania" . rou)
+("Russian Federation" . rus)
+("Rwanda" . rwa)
+("Saint Barthélemy" . blm)
+("Saint Helena, Ascension and Tristan da Cunha" . shn)
+("Saint Kitts and Nevis" . kna)
+("Saint Lucia" . lca)
+("Saint Martin" . maf)
+("Saint Pierre and Miquelon" . spm)
+("Saint Vincent and the Grenadines" . vct)
+("Samoa" . wsm)
+("San Marino" . smr)
+("Sao Tome and Principe" . stp)
+("Saudi Arabia" . sau)
+("Senegal" . sen)
+("Serbia" . srb)
+("Seychelles" . syc)
+("Sierra Leone" . sle)
+("Singapore" . sgp)
+("Sint Maarten" . sxm)
+("Slovakia" . svk)
+("Slovenia" . svn)
+("Solomon Islands" . slb)
+("Somalia" . som)
+("South Africa" . zaf)
+("South Georgia and the South Sandwich Islands" . sgs)
+("South Sudan" . ssd)
+("Spain" . esp)
+("Sri Lanka" . lka)
+("Sudan" . sdn)
+("Suriname" . sur)
+("Svalbard and Jan Mayen" . sjm)
+("Swaziland" . swz)
+("Sweden" . swe)
+("Switzerland" . che)
+("Syrian Arab Republic" . syr)
+("Taiwan" . twn)
+("Tajikistan" . tjk)
+("Tanzania" . tza)
+("Thailand" . tha)
+("Timor-Leste" . tls)
+("Togo" . tgo)
+("Tokelau" . tkl)
+("Tonga" . ton)
+("Trinidad and Tobago" . tto)
+("Tunisia" . tun)
+("Turkey" . tur)
+("Turkmenistan" . tkm)
+("Turks and Caicos Islands" . tca)
+("Tuvalu" . tuv)
+("Uganda" . uga)
+("Ukraine" . ukr)
+("United Arab Emirates" . are)
+("United Kingdom of Great Britain and Northern Ireland" . gbr)
+("United States of America" . usa)
+("United States Minor Outlying Islands" . umi)
+("Uruguay" . ury)
+("Uzbekistan" . uzb)
+("Vanuatu" . vut)
+("Venezuela" . ven)
+("Viet Nam" . vnm)
+("Virgin Islands (British)" . vgb)
+("Virgin Islands (U.S.)" . vir)
+("Wallis and Futuna" . wlf)
+("Western Sahara" . esh)
+("Yemen" . yem)
+("Zambia" . zmb)
+("Zimbabwe" . zwe))
+ "Mapping between a string label for countries or regions, in
+English, and a three-letter symbol identifying the country, as
+per ISO 3166-1 alpha 3.")
+;; Taken from https://en.wikipedia.org/wiki/ISO_3166-1_alpha-3, on Feb
+;; 27, 2016
+
+(defvar ebdb-i18n-phone-codes
+ '(
+ ;; Need a different way of doing this.
+;("Abkhazia" . ((7 (840 940)) (995 44)))
+("Afghanistan" . 93)
+("Åland Islands" . (358 18))
+("Albania" . 355)
+("Algeria" . 213)
+("American Samoa" . (1 684))
+("Andorra" . 376)
+("Angola" . 244)
+("Anguilla" . (1 264))
+("Antigua and Barbuda" . (1 268))
+("Argentina" . 54)
+("Armenia" . 374)
+("Aruba" . 297)
+("Ascension" . 247)
+("Australia" . 61)
+("Australian External Territories" . 672)
+("Austria" . 43)
+("Azerbaijan" . 994)
+("Bahamas" . (1 242))
+("Bahrain" . 973)
+("Bangladesh" . 880)
+("Barbados" . (1 246))
+("Barbuda" . (1 268))
+("Belarus" . 375)
+("Belgium" . 32)
+("Belize" . 501)
+("Benin" . 229)
+("Bermuda" . (1 441))
+("Bhutan" . 975)
+("Bolivia" . 591)
+("Bonaire" . (599 7))
+("Bosnia and Herzegovina" . 387)
+("Botswana" . 267)
+("Brazil" . 55)
+("British Indian Ocean Territory" . 246)
+("British Virgin Islands" . (1 284))
+("Brunei Darussalam" . 673)
+("Bulgaria" . 359)
+("Burkina Faso" . 226)
+("Burundi" . 257)
+("Cambodia" . 855)
+("Cameroon" . 237)
+("Canada" . 1)
+("Cape Verde" . 238)
+("Caribbean Netherlands" . (599 (3 4 7)))
+("Cayman Islands" . (1 345))
+("Central African Republic" . 236)
+("Chad" . 235)
+("Chatham Island, New Zealand" . 64)
+("Chile" . 56)
+("China" . 86)
+("Christmas Island" . 61)
+("Cocos (Keeling) Islands" . 61)
+("Colombia" . 57)
+("Comoros" . 269)
+("Congo" . 242)
+("Congo, Democratic Republic of the (Zaire)" . 243)
+("Cook Islands" . 682)
+("Costa Rica" . 506)
+("Ivory Coast" . 225)
+("Croatia" . 385)
+("Cuba" . 53)
+("Guantanamo Bay, Cuba" . (53 99))
+("Curaçao" . (599 9))
+("Cyprus" . 357)
+("Czech Republic" . 420)
+("Denmark" . 45)
+("Diego Garcia" . 246)
+("Djibouti" . 253)
+("Dominica" . (1 767))
+("Dominican Republic" . (1 (809 829 849)))
+("East Timor" . 670)
+("Easter Island" . 56)
+("Ecuador" . 593)
+("Egypt" . 20)
+("El Salvador" . 503)
+("Ellipso (Mobile Satellite service)" . (881 (2 3)))
+("EMSAT (Mobile Satellite service)" . (882 13))
+("Equatorial Guinea" . 240)
+("Eritrea" . 291)
+("Estonia" . 372)
+("Ethiopia" . 251)
+("Falkland Islands" . 500)
+("Faroe Islands" . 298)
+("Fiji" . 679)
+("Finland" . 358)
+("France" . 33)
+("French Antilles" . 596)
+("French Guiana" . 594)
+("French Polynesia" . 689)
+("Gabon" . 241)
+("Gambia" . 220)
+("Georgia" . 995)
+("Germany" . 49)
+("Ghana" . 233)
+("Gibraltar" . 350)
+("Global Mobile Satellite System (GMSS)" . 881)
+("Globalstar (Mobile Satellite Service)" . (881 (8 9)))
+("Greece" . 30)
+("Greenland" . 299)
+("Grenada" . (1 473))
+("Guadeloupe" . 590)
+("Guam" . (1 671))
+("Guatemala" . 502)
+("Guernsey" . 44)
+("Guinea" . 224)
+("Guinea-Bissau" . 245)
+("Guyana" . 592)
+("Haiti" . 509)
+("Honduras" . 504)
+("Hong Kong" . 852)
+("Hungary" . 36)
+("Iceland" . 354)
+("ICO Global (Mobile Satellite Service)" . (881 (0 1)))
+("India" . 91)
+("Indonesia" . 62)
+("Inmarsat SNAC" . 870)
+("International Freephone Service" . 800)
+("International Shared Cost Service (ISCS)" . 808)
+("Iran" . 98)
+("Iraq" . 964)
+("Ireland" . 353)
+("Iridium (Mobile Satellite service)" . (881 (6 7)))
+("Isle of Man" . 44)
+("Israel" . 972)
+("Italy" . 39)
+("Jamaica" . (1 876))
+("Jan Mayen" . (47 79))
+("Japan" . 81)
+("Jersey" . 44)
+("Jordan" . 962)
+("Kazakhstan" . (7 (6 7)))
+("Kenya" . 254)
+("Kiribati" . 686)
+("Korea, North" . 850)
+("Korea, South" . 82)
+("Kuwait" . 965)
+("Kyrgyzstan" . 996)
+("Laos" . 856)
+("Latvia" . 371)
+("Lebanon" . 961)
+("Lesotho" . 266)
+("Liberia" . 231)
+("Libya" . 218)
+("Liechtenstein" . 423)
+("Lithuania" . 370)
+("Luxembourg" . 352)
+("Macau" . 853)
+("Macedonia" . 389)
+("Madagascar" . 261)
+("Malawi" . 265)
+("Malaysia" . 60)
+("Maldives" . 960)
+("Mali" . 223)
+("Malta" . 356)
+("Marshall Islands" . 692)
+("Martinique" . 596)
+("Mauritania" . 222)
+("Mauritius" . 230)
+("Mayotte" . 262)
+("Mexico" . 52)
+("Micronesia, Federated States of" . 691)
+("Midway Island, USA" . (1 808))
+("Moldova" . 373)
+("Monaco" . 377)
+("Mongolia" . 976)
+("Montenegro" . 382)
+("Montserrat" . (1 664))
+("Morocco" . 212)
+("Mozambique" . 258)
+("Myanmar" . 95)
+("Namibia" . 264)
+("Nauru" . 674)
+("Nepal" . 977)
+("Netherlands" . 31)
+("Nevis" . (1 869))
+("New Caledonia" . 687)
+("New Zealand" . 64)
+("Nicaragua" . 505)
+("Niger" . 227)
+("Nigeria" . 234)
+("Niue" . 683)
+("Norfolk Island" . 672)
+("Northern Cyprus" . (90 392))
+("Northern Mariana Islands" . (1 670))
+("Norway" . 47)
+("Oman" . 968)
+("Pakistan" . 92)
+("Palau" . 680)
+("Palestine, State of" . 970)
+("Panama" . 507)
+("Papua New Guinea" . 675)
+("Paraguay" . 595)
+("Peru" . 51)
+("Philippines" . 63)
+("Pitcairn Islands" . 64)
+("Poland" . 48)
+("Portugal" . 351)
+("Puerto Rico" . (1 (787 939)))
+("Qatar" . 974)
+("Réunion" . 262)
+("Romania" . 40)
+("Russia" . 7)
+("Rwanda" . 250)
+("Saba" . (599 4))
+("Saint Barthélemy" . 590)
+("Saint Helena" . 290)
+("Saint Kitts and Nevis" . (1 869))
+("Saint Lucia" . (1 758))
+("Saint Martin (France)" . 590)
+("Saint Pierre and Miquelon" . 508)
+("Saint Vincent and the Grenadines" . (1 784))
+("Samoa" . 685)
+("San Marino" . 378)
+("São Tomé and Príncipe" . 239)
+("Saudi Arabia" . 966)
+("Senegal" . 221)
+("Serbia" . 381)
+("Seychelles" . 248)
+("Sierra Leone" . 232)
+("Singapore" . 65)
+("Sint Eustatius" . (599 3))
+("Sint Maarten (Netherlands)" . (1 721))
+("Slovakia" . 421)
+("Slovenia" . 386)
+("Solomon Islands" . 677)
+("Somalia" . 252)
+("South Africa" . 27)
+("South Georgia and the South Sandwich Islands" . 500)
+("South Ossetia" . (995 34))
+("South Sudan" . 211)
+("Spain" . 34)
+("Sri Lanka" . 94)
+("Sudan" . 249)
+("Suriname" . 597)
+("Svalbard" . (47 79))
+("Swaziland" . 268)
+("Sweden" . 46)
+("Switzerland" . 41)
+("Syria" . 963)
+("Taiwan" . 886)
+("Tajikistan" . 992)
+("Tanzania" . 255)
+("Thailand" . 66)
+("Thuraya (Mobile Satellite service)" . (882 16))
+("Togo" . 228)
+("Tokelau" . 690)
+("Tonga" . 676)
+("Trinidad and Tobago" . (1 868))
+("Tristan da Cunha" . (290 8))
+("Tunisia" . 216)
+("Turkey" . 90)
+("Turkmenistan" . 993)
+("Turks and Caicos Islands" . (1 649))
+("Tuvalu" . 688)
+("Uganda" . 256)
+("Ukraine" . 380)
+("United Arab Emirates" . 971)
+("United Kingdom" . 44)
+("United States" . 1)
+("Universal Personal Telecommunications (UPT)" . 878)
+("Uruguay" . 598)
+("US Virgin Islands" . (1 340))
+("Uzbekistan" . 998)
+("Vanuatu" . 678)
+("Venezuela" . 58)
+;; What does this three-part number even mean?
+;("Vatican City State (Holy See)" . (39 06 698))
+("Vietnam" . 84)
+("Wake Island, USA" . (1 808))
+("Wallis and Futuna" . 681)
+("Yemen" . 967)
+("Zambia" . 260)
+("Zanzibar" . 255)
+("Zimbabwe" . 263))
+"Mapping of country names to country-code numbers.")
+;; Taken from https://en.wikipedia.org/wiki/Telephone_country_codes,
+;; on Jul 30, 2016
+
+(provide 'ebdb-i18n)
+;;; ebdb-i18n.el ends here
diff --git a/ebdb-ispell.el b/ebdb-ispell.el
new file mode 100644
index 0000000..5272273
--- /dev/null
+++ b/ebdb-ispell.el
@@ -0,0 +1,112 @@
+;;; ebdb-ispell.el --- Add EBDB contact names to personal dictionaries -*-
lexical-binding: t; -*-
+
+;; Copyright (C) 2016 Free Software Foundation, Inc.
+
+;; Author: Eric Abrahamsen <address@hidden>
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; Copied from bbdb-ispell.el, originally written by Ivan Kanis.
+
+;;; Code:
+
+(require 'ispell)
+(require 'ebdb)
+
+(defcustom ebdb-ispell-dictionary-list '("default")
+ "List of ispell personal dictionaries.
+Allowed elements are as in the return value of `ispell-valid-dictionary-list'."
+ :group 'ebdb-utilities-ispell
+ :type (cons 'set (mapcar (lambda (dict) `(string ,dict))
+ (ispell-valid-dictionary-list))))
+
+(defcustom ebdb-ispell-field-list '(name organization aka)
+ "List of fields of each EBDB record considered for the personal dictionary."
+ :group 'ebdb-utilities-ispell
+ :type (list 'repeat
+ (append '(choice) (mapcar (lambda (field) `(const ,field))
+ '(name organization affix aka address))
+ '((symbol :tag "xfield")))))
+
+(defcustom ebdb-ispell-min-word-length 3
+ "Words with fewer characters are ignored."
+ :group 'ebdb-utilities-ispell
+ :type 'number)
+
+(defcustom ebdb-ispell-ignore-re "[^[:alpha:]]"
+ "Words matching this regexp are ignored."
+ :group 'ebdb-utilities-ispell
+ :type 'regexp)
+
+;; Internal variable
+(defvar ebdb-ispell-word-list nil
+ "List of words extracted from the EBDB records.")
+
+;;;###autoload
+(defun ebdb-ispell-export ()
+ "Export EBDB records to ispell personal dictionaries."
+ (interactive)
+ (message "Exporting to personal dictionary...")
+ (let (ebdb-ispell-word-list)
+ ;; Collect words from EBDB records.
+ (dolist (record (ebdb-records))
+ (dolist (field ebdb-ispell-field-list)
+ (ebdb-ispell-collect-words (ebdb-record-field record field))))
+
+ ;; Update personal dictionaries
+ (dolist (dict (or ebdb-ispell-dictionary-list '("default")))
+ (ispell-change-dictionary dict)
+ ;; Initialize variables and dicts alists
+ (ispell-set-spellchecker-params)
+ (ispell-init-process)
+ ;; put in verbose mode
+ (ispell-send-string "%\n")
+ (let (new)
+ (dolist (word (delete-dups ebdb-ispell-word-list))
+ (ispell-send-string (concat "^" word "\n"))
+ (while (progn
+ (ispell-accept-output)
+ (not (string= "" (car ispell-filter)))))
+ ;; remove extra \n
+ (setq ispell-filter (cdr ispell-filter))
+ (when (and ispell-filter
+ (listp ispell-filter)
+ (not (eq (ispell-parse-output (car ispell-filter)) t)))
+ ;; ok the word doesn't exist, add it
+ (ispell-send-string (concat "*" word "\n"))
+ (setq new t)))
+ (when new
+ ;; Save dictionary:
+ ;; aspell doesn't tell us when it completed the saving.
+ ;; So we send it another word for spellchecking.
+ (ispell-send-string "#\n^hello\n")
+ (while (progn
+ (ispell-accept-output)
+ (not (string= "" (car ispell-filter)))))))))
+ (message "Exporting to personal dictionary...done"))
+
+(defun ebdb-ispell-collect-words (field)
+ "Parse EBDB FIELD and collect words in `ebdb-ispell-word-list'."
+ ;; Ignore everything in FIELD that is not a string or a sequence.
+ (cond ((stringp field)
+ (dolist (word (split-string field))
+ (if (and (>= (length word) ebdb-ispell-min-word-length)
+ (not (string-match ebdb-ispell-ignore-re word)))
+ (push word ebdb-ispell-word-list))))
+ ((sequencep field) (mapc 'ebdb-ispell-collect-words field))))
+
+(provide 'ebdb-ispell)
+;;; ebdb-ispell.el ends here
diff --git a/ebdb-message.el b/ebdb-message.el
new file mode 100644
index 0000000..cb17f61
--- /dev/null
+++ b/ebdb-message.el
@@ -0,0 +1,77 @@
+;;; ebdb-message.el --- EBDB interface to mail composition packages -*-
lexical-binding: t; -*-
+
+;; Copyright (C) 2016 Free Software Foundation, Inc.
+
+;; Author: Eric Abrahamsen <address@hidden>
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; Code for interaction with message composition and sending packages.
+
+;;; Code:
+
+
+(require 'ebdb-mua)
+(require 'message)
+(require 'sendmail)
+
+(defgroup ebdb-mua-message nil
+ "Message-specific EBDB customizations"
+ :group 'ebdb-mua)
+(put 'ebdb-mua-message 'custom-loads '(ebdb-message))
+
+;; Suggestions welcome: What are good keybindings for the following
+;; commands that do not collide with existing bindings?
+;; (define-key message-mode-map "'" 'ebdb-mua-display-recipients)
+;; (define-key message-mode-map ";" 'ebdb-mua-edit-field-recipients)
+;; (define-key message-mode-map "/" 'ebdb)
+
+(cl-defgeneric ebdb-message-header ((header string)
+ &context (major-mode (eql message-mode)))
+ (message-field-value header))
+
+(cl-defgeneric ebdb-message-header ((header string)
+ &context (major-mode (eql
notmuch-message-mode)))
+ (message-field-value header))
+
+(cl-defgeneric ebdb-message-header ((header string)
+ &context (major-mode (eql mail-mode)))
+ (message-field-value header))
+
+(defun ebdb-insinuate-message ()
+ (when ebdb-complete-mail
+ (cl-pushnew
'("^\\(Resent-\\)?\\(To\\|B?Cc\\|Reply-To\\|From\\|Mail-Followup-To\\|Mail-Copies-To\\):"
. ebdb-complete-mail)
+ message-completion-alist
+ :test #'equal)
+ (define-key mail-mode-map (kbd "TAB") 'ebdb-complete-mail)))
+
+(defun bbdb-insinuate-mail ()
+ "Hook BBDB into Mail Mode.
+Do not call this in your init file. Use `bbdb-initialize'."
+ ;; Suggestions welcome: What are good keybindings for the following
+ ;; commands that do not collide with existing bindings?
+ ;; (define-key mail-mode-map "'" 'bbdb-mua-display-recipients)
+ ;; (define-key mail-mode-map ";" 'bbdb-mua-edit-field-recipients)
+ ;; (define-key mail-mode-map "/" 'bbdb)
+ (if bbdb-complete-mail
+ (define-key mail-mode-map "\M-\t" 'bbdb-complete-mail)))
+
+(add-hook 'message-mode-hook 'ebdb-insinuate-message)
+(add-hook 'mail-setup-hook 'ebdb-insinuate-mail)
+(add-hook 'message-send-hook 'ebdb-mua-auto-update)
+(add-hook 'mail-send-hook 'ebdb-mua-auto-update)
+(provide 'ebdb-message)
+;;; ebdb-message.el ends here
diff --git a/ebdb-mhe.el b/ebdb-mhe.el
new file mode 100644
index 0000000..07d120a
--- /dev/null
+++ b/ebdb-mhe.el
@@ -0,0 +1,122 @@
+;;; ebdb-mhe.el --- EBDB interface to mh-e -*- lexical-binding: t;
-*-
+
+;; Copyright (C) 2016 Free Software Foundation, Inc.
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; EBDB interface to mh-e. This was copied from the file bbdb-mhe.el,
+;; written by Todd Kaufman with contributions from Fritz Knabe and
+;; Jack Repenning.
+
+;;; Code:
+
+(require 'ebdb-com)
+(require 'ebdb-mua)
+(require 'mh-e)
+(if (fboundp 'mh-version)
+ (require 'mh-comp)) ; For mh-e 4.x
+(require 'advice)
+
+;; A simplified `mail-fetch-field'. We could use instead (like rmail):
+;; (mail-header (intern-soft (downcase header)) (mail-header-extract))
+(defun ebdb/mh-header (header)
+ "Find and return the value of HEADER in the current buffer.
+Returns the empty string if HEADER is not in the message."
+ (let ((case-fold-search t))
+ (if mh-show-buffer (set-buffer mh-show-buffer))
+ (goto-char (point-min))
+ ;; This will be fooled if HEADER appears in the body of the message.
+ ;; Also, it fails if HEADER appears more than once.
+ (cond ((not (re-search-forward header nil t)) "")
+ ((looking-at "[\t ]*$") "")
+ (t (re-search-forward "[ \t]*\\([^ \t\n].*\\)$" nil t)
+ (let ((start (match-beginning 1)))
+ (while (progn (forward-line 1)
+ (looking-at "[ \t]")))
+ (backward-char 1)
+ (buffer-substring-no-properties start (point)))))))
+
+(cl-defmethod ebdb-message-header ((header string)
+ &context (major-mode (eql mhe-mode)))
+ (ebdb/mh-header header))
+
+(cl-defmethod ebdb-message-header ((header string)
+ &context (major-mode (eql mhe-summary-mode)))
+ (ebdb/mh-header header))
+
+(cl-defmethod ebdb-message-header ((header string)
+ &context (major-mode (eql mhe-folder-mode)))
+ (ebdb/mh-header header))
+
+(cl-defmethod ebdb-mua-prepare-article (&context (major-mode (eql mhe-mode)))
+ (mh-show))
+
+(cl-defmethod ebdb-mua-prepare-article (&context (major-mode (eql
mhe-summary-mode)))
+ (mh-show))
+
+(cl-defmethod ebdb-mua-prepare-article (&context (major-mode (eql
mhe-folder-mode)))
+ (mh-show))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Use EBDB for interactive spec of MH-E commands
+
+(defadvice mh-send (before mh-ebdb-send act)
+ (interactive
+ (list (ebdb-completing-read-mails "To: ")
+ (ebdb-completing-read-mails "Cc: ")
+ (read-string "Subject: "))))
+
+(defadvice mh-send-other-window (before mh-ebdb-send-other act)
+ (interactive
+ (list (ebdb-completing-read-mails "To: ")
+ (ebdb-completing-read-mails "Cc: ")
+ (read-string "Subject: "))))
+
+(defadvice mh-forward (before mh-ebdb-forward act)
+ (interactive
+ (list (ebdb-completing-read-mails "To: ")
+ (ebdb-completing-read-mails "Cc: ")
+ (if current-prefix-arg
+ (mh-read-seq-default "Forward" t)
+ (mh-get-msg-num t)))))
+
+(defadvice mh-redistribute (before mh-ebdb-redist act)
+ (interactive
+ (list (ebdb-completing-read-mails "Redist-To: ")
+ (ebdb-completing-read-mails "Redist-Cc: ")
+ (mh-get-msg-num t))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defun ebdb-insinuate-mh ()
+ "Call this function to hook EBDB into MH-E.
+Do not call this in your init file. Use `ebdb-initialize'."
+ (define-key mh-folder-mode-map ":" 'ebdb-mua-display-sender)
+ (define-key mh-folder-mode-map ";" 'ebdb-mua-edit-field-sender)
+ ;; Do we need keybindings for more commands? Suggestions welcome.
+ ;; (define-key mh-folder-mode-map ":" 'ebdb-mua-display-records)
+ ;; (define-key mh-folder-mode-map "'" 'ebdb-mua-display-recipients)
+ ;; (define-key mh-folder-mode-map ";" 'ebdb-mua-edit-field-recipients)
+ (when ebdb-complete-mail
+ (define-key mh-letter-mode-map "\M-;" 'ebdb-complete-mail)
+ (define-key mh-letter-mode-map "\e\t" 'ebdb-complete-mail)))
+
+(add-hook 'mh-show-hook 'ebdb-mua-auto-update)
+
+(add-hook 'mh-folder-mode-hook 'ebdb-insinuate-mh)
+
+(provide 'ebdb-mhe)
+;;; ebdb-mhe.el ends here
diff --git a/ebdb-migrate.el b/ebdb-migrate.el
new file mode 100644
index 0000000..602f777
--- /dev/null
+++ b/ebdb-migrate.el
@@ -0,0 +1,629 @@
+;;; ebdb-migrate.el --- Migration/upgrade functions for EBDB -*-
lexical-binding: t; -*-
+
+;; Copyright (C) 2016 Free Software Foundation, Inc.
+
+;; Author: Eric Abrahamsen <address@hidden>
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; This file provides functions for upgrading from earlier versions of
+;; EBDB, or from BBDB.
+
+;;; Code:
+
+(require 'ebdb)
+
+;;; Migrating the EBDB
+
+;; Unused
+(defconst ebdb-migration-features
+ '((3 . "* Date format for `creation-date' and `timestamp' has changed,
+ from \"dd mmm yy\" (ex: 25 Sep 97) to \"yyyy-mm-dd\" (ex: 1997-09-25).")
+ (4 . "* Country field added.")
+ (5 . "* More flexible street address.")
+ (6 . "* postcodes are stored as plain strings.")
+ (7 . "* Xfields is always a list. Organizations are stored as list.
+ New field `affix'."))
+ "EBDB Features that have changed in various database revisions.
+Format ((VERSION . DIFFERENCES) ... ).")
+
+;; Quiet compiler
+(defvar bbdb-file)
+
+;;; These struct functions and definitions are here only to enable
+;;; multi-step upgrades from earlier versions of the database.
+
+(defmacro ebdb-defstruct (name &rest elts)
+ "Define two functions to operate on vector NAME for each symbol ELT in ELTS.
+The function ebdb-NAME-ELT returns the element ELT in vector NAME.
+The function ebdb-NAME-set-ELT sets ELT.
+Also define a constant ebdb-NAME-length that holds the number of ELTS
+in vector NAME."
+ (declare (indent 1))
+ (let* ((count 0)
+ (sname (symbol-name name))
+ (uname (upcase sname))
+ (cname (concat "ebdb-" sname "-"))
+ body)
+ (dolist (elt elts)
+ (let* ((selt (symbol-name elt))
+ (setname (intern (concat cname "set-" selt))))
+ (push (list 'defsubst (intern (concat cname selt)) `(,name)
+ (format "For EBDB %s read element %i `%s'."
+ uname count selt)
+ ;; Use `elt' instead of `aref' so that these functions
+ ;; also work for the `ebdb-record-type' pseudo-code.
+ `(elt ,name ,count)) body)
+ (push (list 'defsubst setname `(,name value)
+ (format "For EBDB %s set element %i `%s' to VALUE. \
+Return VALUE.
+Do not call this function directly. Call instead `ebdb-record-set-field'
+which ensures the integrity of the database. Also, this makes your code
+more robust with respect to possible future changes of EBDB's innermost
+internals."
+ uname count selt)
+ `(aset ,name ,count value)) body))
+ (setq count (1+ count)))
+ (push (list 'defconst (intern (concat cname "length")) count
+ (concat "Length of EBDB `" sname "'.")) body)
+ (cons 'progn body)))
+
+;; Define structs so that the getters/setters used elsewhere in the
+;; file operate normally. These functions are used nowhere else in
+;; EBDB, and the "v" prefix has been added to prevent function name
+;; clashes.
+(ebdb-defstruct vrecord
+ firstname lastname affix aka organization phone address mail xfields cache)
+
+(ebdb-defstruct vphone
+ label area exchange suffix extension)
+
+(ebdb-defstruct vaddress
+ label streets city state postcode country)
+
+(defun ebdb-peel-the-onion (lis)
+ "Remove outer layers of parens around singleton lists.
+This is done until we get a list which is either not a singleton list
+or does not contain a list. This is a utility function used in recovering
+slightly munged old EBDB files."
+ (while (and (consp lis)
+ (null (cdr lis))
+ (listp (car lis)))
+ (setq lis (car lis)))
+ lis)
+
+(defconst ebdb-file-format 7
+ "Obsolete variable, only used in migration.")
+
+;;;###autoload
+(defun ebdb-migrate (records old-format)
+ "Migrate the EBDB from the version on disk to the current version
+\(in `ebdb-file-format')."
+ ;; Some EBDB files were corrupted by random outer layers of
+ ;; parentheses surrounding the actual correct data. We attempt to
+ ;; compensate for this.
+ (setq records (ebdb-peel-the-onion records))
+
+ ;; Add new field `affix'.
+ (if (< old-format 7)
+ (let ((temp records) record)
+ (while (setq record (car temp))
+ (setcar temp (vector (elt record 0) (elt record 1) nil
+ (elt record 2) (elt record 3) (elt record 4)
+ (elt record 5) (elt record 6) (elt record 7)
+ (elt record 8)))
+ (setq temp (cdr temp)))))
+ (mapc (ebdb-migrate-versions-lambda old-format) records)
+ records)
+
+(defconst ebdb-migration-spec
+ '((2 (ebdb-vrecord-xfields ebdb-vrecord-set-xfields
+ ebdb-migrate-change-dates))
+ (3 (ebdb-vrecord-address ebdb-vrecord-set-address
+ ebdb-migrate-add-country-field))
+ (4 (ebdb-vrecord-address ebdb-vrecord-set-address
+ ebdb-migrate-streets-to-list))
+ (5 (ebdb-vrecord-address ebdb-vrecord-set-address
+ ebdb-migrate-postcodes-to-strings))
+ (6 (ebdb-vrecord-xfields ebdb-vrecord-set-xfields
+ ebdb-migrate-xfields-to-list)
+ (ebdb-vrecord-organization ebdb-vrecord-set-organization
+ ebdb-migrate-organization-to-list)))
+ "The alist of (version . migration-spec-list).
+See `ebdb-migrate-record-lambda' for details.")
+
+(defun ebdb-migrate-record-lambda (changes)
+ "Return a function which will migrate a single record.
+CHANGES is a `migration-spec-list' containing entries of the form
+
+ (GET SET FUNCTION)
+
+where GET is the function to be used to retrieve the field to be
+modified, and SET is the function to be used to set the field to be
+modified. FUNCTION will be applied to the result of GET, and its
+results will be saved with SET."
+ (byte-compile `(lambda (record)
+ ,@(mapcar (lambda (ch)
+ `(,(cadr ch) record
+ (,(car (cddr ch))
+ (,(car ch) record))))
+ changes)
+ record)))
+
+(defun ebdb-migrate-versions-lambda (v0)
+ "Return the function to migrate from V0 to `ebdb-file-format'."
+ (let (spec)
+ (while (< v0 ebdb-file-format)
+ (setq spec (append spec (cdr (assoc v0 ebdb-migration-spec)))
+ v0 (1+ v0)))
+ (ebdb-migrate-record-lambda spec)))
+
+(defun ebdb-migrate-postcodes-to-strings (addresses)
+ "Make all postcodes plain strings.
+This uses the code that used to be in `ebdb-address-postcode'."
+ ;; apply the function to all addresses in the list and return a
+ ;; modified list of addresses
+ (mapcar (lambda (address)
+ (let ((postcode (if (stringp (ebdb-vaddress-postcode address))
+ (ebdb-vaddress-postcode address)
+ ;; if not a string, make it a string...
+ (if (consp (ebdb-vaddress-postcode address))
+ ;; if a cons cell with two strings
+ (if (and (stringp (car
(ebdb-vaddress-postcode address)))
+ (stringp (car (cdr
(ebdb-vaddress-postcode address)))))
+ ;; if the second string starts with 4
digits
+ (if (string-match "^[0-9][0-9][0-9][0-9]"
+ (car (cdr
(ebdb-vaddress-postcode address))))
+ (concat (car (ebdb-vaddress-postcode
address))
+ "-"
+ (car (cdr
(ebdb-vaddress-postcode address))))
+ ;; if ("abc" "efg")
+ (concat (car (ebdb-vaddress-postcode
address))
+ " "
+ (car (cdr
(ebdb-vaddress-postcode address)))))
+ ;; if ("SE" (123 45))
+ (if (and (stringp (nth 0
(ebdb-vaddress-postcode address)))
+ (consp (nth 1
(ebdb-vaddress-postcode address)))
+ (integerp (nth 0 (nth 1
(ebdb-vaddress-postcode address))))
+ (integerp (nth 1 (nth 1
(ebdb-vaddress-postcode address)))))
+ (format "%s-%d %d"
+ (nth 0 (ebdb-vaddress-postcode
address))
+ (nth 0 (nth 1
(ebdb-vaddress-postcode address)))
+ (nth 1 (nth 1
(ebdb-vaddress-postcode address))))
+ ;; if a cons cell with two numbers
+ (if (and (integerp (car
(ebdb-vaddress-postcode address)))
+ (integerp (car (cdr
(ebdb-vaddress-postcode address)))))
+ (format "%05d-%04d" (car
(ebdb-vaddress-postcode address))
+ (car (cdr
(ebdb-vaddress-postcode address))))
+ ;; else a cons cell with a string an a
number (possible error
+ ;; if a cons cell with a number and a
string -- note the
+ ;; order!)
+ (format "%s-%d" (car
(ebdb-vaddress-postcode address))
+ (car (cdr
(ebdb-vaddress-postcode address)))))))
+ ;; if nil or zero
+ (if (or (zerop (ebdb-vaddress-postcode
address))
+ (null (ebdb-vaddress-postcode
address)))
+ ""
+ ;; else a number, could be 3 to 5 digits
(possible error: assuming
+ ;; no leading zeroes in postcodes)
+ (format "%d" (ebdb-vaddress-postcode
address)))))))
+ (ebdb-vaddress-set-postcode address postcode))
+ address)
+ addresses))
+
+(defun ebdb-migrate-change-dates (record)
+ "Change date formats.
+Formats are changed in timestamp and creation-date fields from
+\"dd mmm yy\" to \"yyyy-mm-dd\"."
+ (unless (stringp record)
+ (mapc (lambda (rr)
+ (when (memq (car rr) '(creation-date timestamp))
+ (ebdb-migrate-change-dates-change-field rr)))
+ record)
+ record))
+
+(defun ebdb-migrate-change-dates-change-field (field)
+ "Migrate the date field (the cdr of FIELD) from \"dd mmm yy\" to
+\"yyyy-mm-dd\"."
+ (let ((date (cdr field))
+ parsed)
+ ;; Verify and extract - this is fairly hideous
+ (and (equal (setq parsed (timezone-parse-date (concat date " 00:00:00")))
+ ["0" "0" "0" "0" nil])
+ (equal (setq parsed (timezone-parse-date date))
+ ["0" "0" "0" "0" nil])
+ (cond ((string-match
+ "^\\([0-9]\\{4\\}\\)[-/]\\([ 0-9]?[0-9]\\)[-/]\\([ 0-9]?[0-9]\\)"
date)
+ (setq parsed (vector (string-to-number (match-string 1 date))
+ (string-to-number (match-string 2 date))
+ (string-to-number (match-string 3 date))))
+ ;; This should be fairly loud for GNU Emacs users
+ (ebdb-warn "EBDB is treating %s field value %s as %s %d %d"
+ (car field) (cdr field)
+ (upcase-initials
+ (downcase (car (rassoc (aref parsed 1)
+ timezone-months-assoc))))
+ (aref parsed 2) (aref parsed 0)))
+ ((string-match
+ "^\\([ 0-9]?[0-9]\\)[-/]\\([ 0-9]?[0-9]\\)[-/]\\([0-9]\\{4\\}\\)"
date)
+ (setq parsed (vector (string-to-number (match-string 3 date))
+ (string-to-number (match-string 1 date))
+ (string-to-number (match-string 2 date))))
+ ;; This should be fairly loud for GNU Emacs users
+ (ebdb-warn "EBDB is treating %s field value %s as %s %d %d"
+ (car field) (cdr field)
+ (upcase-initials
+ (downcase (car (rassoc (aref parsed 1)
+ timezone-months-assoc))))
+ (aref parsed 2) (aref parsed 0)))
+ (t ["0" "0" "0" "0" nil])))
+
+ ;; I like numbers
+ (and (stringp (aref parsed 0))
+ (aset parsed 0 (string-to-number (aref parsed 0))))
+ (and (stringp (aref parsed 1))
+ (aset parsed 1 (string-to-number (aref parsed 1))))
+ (and (stringp (aref parsed 2))
+ (aset parsed 2 (string-to-number (aref parsed 2))))
+
+ ;; Sanity check
+ (cond ((and (< 0 (aref parsed 0))
+ (< 0 (aref parsed 1)) (>= 12 (aref parsed 1))
+ (< 0 (aref parsed 2))
+ (>= (timezone-last-day-of-month (aref parsed 1)
+ (aref parsed 0))
+ (aref parsed 2)))
+ (setcdr field (format "%04d-%02d-%02d" (aref parsed 0)
+ (aref parsed 1) (aref parsed 2)))
+ field)
+ (t
+ (error "EBDB cannot parse %s header value %S for upgrade"
+ field date)))))
+
+(defun ebdb-migrate-add-country-field (addrl)
+ "Add a country field to each address in the address list."
+ (mapcar (lambda (address) (vconcat address [""])) addrl))
+
+(defun ebdb-migrate-streets-to-list (addrl)
+ "Convert the streets to a list."
+ (mapcar (lambda (address)
+ (vector (aref address 0) ; tag
+ (delq nil (delete "" ; nuke empties
+ (list (aref address 1) ; street1
+ (aref address 2) ; street2
+ (aref address 3))));street3
+ (aref address 4) ; city
+ (aref address 5) ; state
+ (aref address 6) ; postcode
+ (aref address 7))) ; country
+ addrl))
+
+(defun ebdb-migrate-xfields-to-list (xfields)
+ "Migrate XFIELDS to list."
+ (if (stringp xfields)
+ (list (cons 'notes xfields))
+ xfields))
+
+(defun ebdb-migrate-organization-to-list (organization)
+ "Migrate ORGANIZATION to list."
+ (if (stringp organization)
+ (ebdb-split 'organization organization)
+ organization))
+
+;;; These defcustoms are now obsolete, but they're here so that,
+;;; during the migration/upgrade process, we know which xfields to
+;;; handle specially, and turn into specific field types. In the case
+;;; of `bbdb/gnus-split-public-field', this should signal to us that
+;;; the record should actually be changed into a
+;;; `ebdb-record-mailing-list'. But that hasn't been implemented yet,
+;;; so...
+
+(defcustom bbdb/gnus-split-private-field 'gnus-private
+ "This variable is used to determine the xfield to reference to find the
+associated group when saving private mail for a mail address known to
+the EBDB. The value of the xfield should be the name of a mail group."
+ :group 'ebdb-mua-gnus-splitting
+ :type 'symbol)
+
+(defcustom bbdb/gnus-split-public-field 'gnus-public
+ "This variable is used to determine the xfield to reference to find the
+associated group when saving non-private mail (received from a mailing
+list) for a mail address known to the EBDB. The value of the xfield
+should be the name of a mail group, followed by a space, and a regular
+expression to match on the envelope sender to verify that this mail came
+from the list in question."
+ :group 'ebdb-mua-gnus-splitting
+ :type 'symbol)
+
+(defcustom bbdb/gnus-score-field 'gnus-score
+ "This variable contains the name of the EBDB field which should be
+checked for a score to add to the mail addresses in the same record."
+ :group 'ebdb-mua-gnus-scoring
+ :type 'symbol)
+
+;;;###autoload
+(defun ebdb-migrate-from-bbdb ()
+ "Migrate from BBDB to EBDB.
+
+This upgrade is extreme enough that we can't really use the
+existing migration mechanisms. They are still there, though, in
+case someone's going from, say, version 2 to 4 in one jump.
+
+Assume that the variable `bbdb-file' points to an existing file
+holding valid contacts in a previous BBDB format."
+ (require 'url-handlers)
+ (require 'ebdb-gnorb)
+ (require 'ebdb-gnus)
+ (with-current-buffer (find-file-noselect bbdb-file)
+ (when (and (/= (point-min) (point-max))
+ (yes-or-no-p "Upgrade from previous version of BBDB?"))
+ (let ((v-records (ebdb-migrate-parse-records))
+ (target-db (if (= (length ebdb-db-list) 1)
+ (car ebdb-db-list)
+ (ebdb-prompt-for-db)))
+ c-records duds)
+ (message "Migrating records...")
+ (dolist (r v-records)
+ (condition-case err
+ (let ((orgs (ebdb-vrecord-organization r))
+ (c-rec (ebdb-migrate-vector-to-class r))
+ org)
+ ;; Gives it a uuid
+ (ebdb-db-add-record target-db c-rec)
+ (when orgs
+ (dolist (o orgs)
+ ;; Make all the orgs into real records.
+ (unless (string= o "") ; There are many of these.
+ (setq org (or (object-assoc o 'name c-records)
+ (let ((time (current-time)))
+ (ebdb-db-add-record
+ target-db
+ (make-instance
+ 'ebdb-record-organization
+ :name (make-instance
'ebdb-field-name-simple :name o)
+ :timestamp
+ (make-instance 'ebdb-field-timestamp
:timestamp time)
+ :creation-date
+ (make-instance
'ebdb-field-creation-date :timestamp time))))))
+ ;; Create the connection between the org and the
+ ;; person.
+ (ebdb-record-add-org-role c-rec org)
+ (unless (member org c-records)
+ (push org c-records)))))
+ (push c-rec c-records))
+ (error
+ (push (list r err) duds))))
+ (when duds
+ (pop-to-buffer
+ (get-buffer-create "*EBDB Migration*")
+ '(nil . ((window-height . 10))))
+ (insert "The records below could not be migrated:\n\n")
+ (insert
+ (mapconcat
+ (lambda (r)
+ (format "%S, error: %S" (car r) (cadr r)))
+ duds "\n\n"))
+ (fit-window-to-buffer)
+ (goto-char (point-min)))
+ (dolist (r c-records)
+ (ebdb-init r))
+ (eieio-oset target-db 'dirty t)
+ (message "Migrating records... %d records migrated" (length
c-records))))))
+
+(defun ebdb-migrate-vector-to-class (v)
+ "Migrate a single vector-style BBDB record to the EIEIO class
+ style used in EBDB."
+ ;; In the vector version, vector elements were:
+
+ ;; record: firstname lastname affix aka organization phone address mail
xfields
+ ;; phone: label area exchange suffix extension
+ ;; address: label streets city state postcode country
+ (let ((f-name (aref v 0))
+ (l-name (aref v 1))
+ (affix (aref v 2))
+ (aka (aref v 3))
+ (phone (aref v 5))
+ (address (aref v 6))
+ (mail (aref v 7))
+ (xfields (aref v 8))
+ name akas phones mails addresses fields ts c-date notes lab val)
+ (setq name (make-instance ebdb-default-name-class
+ :surname l-name
+ :given-names (when f-name (split-string f-name "
" nil))
+ :affix affix))
+ (when aka
+ (dolist (a aka)
+ (push (make-instance ebdb-default-name-class
+ :surname (car (last (split-string a)))
+ :given-names (butlast (split-string a)))
+ akas)))
+ (when phone
+ (dolist (p phone)
+ (let ((label (aref p 0))
+ area extension number)
+ (if (= 2 (length p))
+ (setq number (aref p 1))
+ (setq area (ebdb-vphone-area p)
+ number (format "%d%d"
+ (ebdb-vphone-exchange p)
+ (ebdb-vphone-suffix p))
+ extension (ebdb-vphone-extension p)))
+ (push (make-instance ebdb-default-phone-class
+ :object-name label
+ :area-code area
+ :number (replace-regexp-in-string "[- ]+"
+ "" number)
+ :extension extension)
+ phones))))
+ (when address
+ (dolist (a address)
+ (let ((label (aref a 0))
+ (streets (aref a 1))
+ (city (aref a 2))
+ (state (aref a 3))
+ (postcode (aref a 4))
+ (country (aref a 5))
+ (case-fold-search t))
+ (when (and country (stringp country))
+ (dolist (c ebdb-country-list)
+ (when (and (stringp country)
+ (string-match-p country (car c)))
+ (setq country (cdr c)))))
+ (push (make-instance ebdb-default-address-class
+ :object-name label
+ :streets streets
+ :locality city
+ :region state
+ :postcode postcode
+ :country country)
+ addresses))))
+ (when mail
+ (dolist (m mail)
+ (let ((bits (ebdb-decompose-ebdb-address m)))
+ (push (make-instance ebdb-default-mail-class
+ :aka (car bits)
+ :mail (cadr bits))
+ mails)))
+ (oset (car (last mails)) priority 'primary))
+ (when xfields
+ (dolist (x xfields)
+ (setq lab (car x)
+ val (cdr x))
+ (cond
+ ((eq lab 'timestamp)
+ (setq ts (make-instance 'ebdb-field-timestamp
+ :timestamp
+ (apply #'encode-time
+ (parse-time-string val)))))
+ ((eq lab 'creation-date)
+ (setq c-date (make-instance 'ebdb-field-creation-date
+ :timestamp
+ (apply #'encode-time
+ (parse-time-string val)))))
+ ((eq lab ebdb-mail-alias-field)
+ (push (make-instance 'ebdb-field-mail-alias
+ :alias val)
+ fields))
+ ((string-match-p val url-handler-regexp)
+ (push (make-instance 'ebdb-field-url
+ :url val)
+ fields))
+ ((eq lab 'anniversary)
+ (let* ((bits (split-string val " "))
+ (date-bits (split-string (car bits) "-")))
+ (require 'calendar)
+ (push (make-instance 'ebdb-field-anniversary
+ :date (calendar-absolute-from-gregorian
+ (mapcar #'string-to-number
+ (append
+ (cdr date-bits)
+ (list (car date-bits)))))
+ :object-name (cadr bits))
+ fields)))
+ ((eq lab 'notes)
+ (setq notes (make-instance 'ebdb-field-notes
+ :notes val)))
+ ((eq lab 'messages)
+ (unless (stringp val)
+ (push (make-instance 'gnorb-ebdb-field-messages
+ :messages val)
+ fields)))
+ ((eq lab gnorb-ebdb-org-tag-field)
+ (push (make-instance 'gnorb-ebdb-field-tags
+ :tags (if (listp val)
+ val
+ (ebdb-split gnorb-ebdb-org-tag-field
val)))
+ fields))
+ ((memq lab (list bbdb/gnus-score-field
+ bbdb/gnus-split-private-field
+ 'imap))
+ (cond
+ ((eq lab bbdb/gnus-score-field)
+ (push (make-instance 'ebdb-gnus-score-field
+ :score val)
+ fields))
+ ((eq lab bbdb/gnus-split-private-field)
+ (push (make-instance 'ebdb-gnus-private-field
+ :group val)
+ fields))
+ ((eq lab 'imap)
+ (push (make-instance 'ebdb-gnus-imap-field
+ :group val)
+ fields))))
+ (t
+ (push (make-instance 'ebdb-field-user-simple
+ :object-name (symbol-name (car x))
+ :value val)
+ fields)))))
+ (make-instance ebdb-default-record-class
+ :name name
+ :aka akas
+ :phone phones
+ :address addresses
+ :mail mails
+ :timestamp ts
+ :creation-date c-date
+ :notes notes
+ :dirty t
+ :fields fields)))
+
+(defun ebdb-migrate-parse-records ()
+ "Parse an earlier (non-EIEIO) version of a BBDB database file."
+ (save-excursion
+ (save-restriction
+ (widen)
+ (goto-char (point-min))
+ ;; look backwards for file-format, and convert if necessary.
+ (let ((file-format (save-excursion
+ (if (re-search-backward
+ "^;+[ \t]*file-\\(format\\|version\\):[
\t]*\\([0-9]+\\)[ \t]*$" nil t)
+ (string-to-number (match-string 2)))))
+ migrate records)
+ (unless file-format ; current file-format, but no file-format: line.
+ (error "BBDB corrupted: no file-format line"))
+ (if (> file-format ebdb-file-format)
+ (error "BBDB version %s understands file format %s but not %s."
+ ebdb-version ebdb-file-format file-format)
+ (setq migrate (< file-format ebdb-file-format)))
+
+ (or (eobp) (looking-at "\\[")
+ (error "BBDB corrupted: no following bracket"))
+
+ ;; narrow the buffer to skip over the rubbish before the first record.
+ (narrow-to-region (point) (point-max))
+ (let ((modp (buffer-modified-p))
+ ;; Make sure those parens get cleaned up.
+ ;; This code had better stay simple!
+ (inhibit-quit t)
+ (buffer-undo-list t)
+ buffer-read-only)
+ (goto-char (point-min)) (insert "(\n")
+ (goto-char (point-max)) (insert "\n)")
+ (goto-char (point-min))
+ (unwind-protect
+ (setq records (read (current-buffer)))
+ (goto-char (point-min)) (delete-char 2)
+ (goto-char (point-max)) (delete-char -2)
+ (set-buffer-modified-p modp)))
+ (widen)
+
+ ;; Migrate if `bbdb-file' is outdated.
+ (if migrate (setq records (ebdb-migrate records file-format)))
+
+ records))))
+
+(provide 'ebdb-migrate)
+;;; ebdb-migrate.el ends here
diff --git a/ebdb-mu4e.el b/ebdb-mu4e.el
new file mode 100644
index 0000000..f15a8fd
--- /dev/null
+++ b/ebdb-mu4e.el
@@ -0,0 +1,52 @@
+;;; ebdb-mu4e.el --- EBDB interface for mu4e -*- lexical-binding: t;
-*-
+
+;; Copyright (C) 2016 Free Software Foundation, Inc.
+
+;; Author: Eric Abrahamsen <address@hidden>
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; EBDB interface to mu4e. This file was copied from bbdb-mu4e.el,
+;; originally written by David Sterratt.
+
+;;; Code:
+
+(require 'ebdb-mua)
+(require 'mu4e-view)
+
+;; Tackle `mu4e-headers-mode' later
+
+(cl-defmethod ebdb-message-header ((header string)
+ &context (major-mode (eql mu4e-view-mode)))
+ (set-buffer mu4e~view-buffer-name)
+ (message-field-value header))
+
+(defun ebdb-insinuate-mu4e ()
+ "Hook EBDB into mu4e.
+Do not call this in your init file. Use `ebdb-initialize'."
+ ;; Tackle headers later
+ ;; (define-key mu4e-headers-mode-map ":" 'ebdb-mua-display-sender)
+ ;; (define-key mu4e-headers-mode-map ";" 'ebdb-mua-edit-field-sender)
+ ;; Do we need keybindings for more commands? Suggestions welcome.
+ (define-key mu4e-view-mode-map ":" 'ebdb-mua-display-sender)
+ (define-key mu4e-view-mode-map ";" 'ebdb-mua-edit-field-sender))
+
+;; Why wasn't `ebdb-mua-auto-update' ever hooked in to mu4e?
+
+(add-hook 'mu4e-main-mode-hook 'ebdb-insinuate-mu4e)
+
+(provide 'ebdb-mu4e)
+;;; ebdb-mu4e.el ends here
diff --git a/ebdb-mua.el b/ebdb-mua.el
new file mode 100644
index 0000000..0da1d83
--- /dev/null
+++ b/ebdb-mua.el
@@ -0,0 +1,1527 @@
+;;; ebdb-mua.el --- Mail user agent interaction for EBDB -*- lexical-binding:
t; -*-
+
+;; Copyright (C) 2016 Free Software Foundation, Inc.
+
+;; Author: Eric Abrahamsen <address@hidden>
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; This library handles EBDB interaction with various other packages.
+;; The name implies integration with mail user agents, but in fact it
+;; could be used for any package that wants EBDB pop-up integration.
+;; For simplicity's sake, all these packages will be referred to as
+;; MUAs.
+
+;; Essentially, this library can make three things happen:
+
+;; 1. Return EBDB records matched by criteria provided by the MUA, and
+;; optionally display those records in a pop-up buffer.
+
+;; 2. Handle information provided by the MUA which does not exactly
+;; match the existing records. This can mean creating new records,
+;; and/or updating existing records based on new information about
+;; names or messages, or running other user-defined rules. These
+;; updates may be automatic or interactive, depending on the user's
+;; configuration.
+
+;; 3. Provide keybindings for editing or otherwise manipulating the
+;; records afterwards.
+
+;;; Code:
+
+(require 'ebdb)
+(require 'ebdb-com)
+
+(eval-and-compile
+ (autoload 'mail-decode-encoded-word-string "mail-parse"))
+
+;;; MUA interface
+
+(defvar ebdb-offer-to-create nil
+ "For communication between `ebdb-update-records' and `ebdb-query-create'.")
+
+(defvar ebdb-update-records-address nil
+ "For communication between `ebdb-update-records' and `ebdb-query-create'.
+It is a list with elements (NAME MAIL HEADER HEADER-CLASS MUA).")
+
+(defcustom ebdb-annotate-field ebdb-default-user-field
+ "Field to annotate via `ebdb-annotate-record' and friends.
+This may take the values:
+ affix The list of affixes
+ organization The list of organizations
+ aka the list of AKAs
+ mail the list of email addresses
+ all-fields Read the field to edit using a completion table
+ that includes all fields currently known to EBDB.
+
+Any other symbol is interpreted as the label of an xfield."
+ :group 'ebdb-mua
+ :type '(symbol :tag "Field to annotate"))
+
+(defcustom ebdb-mua-edit-field ebdb-default-user-field
+ "Field to edit with command `ebdb-mua-edit-field' and friends.
+This may take the values:
+ name The full name
+ affix The list of affixes
+ organization The list of organizations
+ aka the list of AKAs
+ mail the list of email addresses
+ all-fields Read the field to edit using a completion table
+ that includes all fields currently known to EBDB.
+
+Any other symbol is interpreted as the label of an xfield."
+ :group 'ebdb-mua
+ :type '(symbol :tag "Field to edit"))
+
+(defcustom ebdb-mua-auto-update-p 'existing
+ "This option governs how EBDB handles addresses found in
+ incoming mail messages. It can take one of the following
+ values:
+
+ nil Do nothing.
+ existing Find existing records matching ADDRESS.
+ update Search for existing records matching ADDRESS;
+ update name and mail field if necessary.
+ query Search for existing records matching ADDRESS;
+ query for creation of a new record if the record does not
exist.
+ create or t Search for existing records matching ADDRESS;
+ create a new record if it does not yet exist.
+ a function This functions will be called with no arguments.
+ It should return one of the above values.
+
+Note that this option only controls how EBDB acts on information
+in incoming messages; the option `ebdb-mua-pop-up' controls
+whether the records in question are actually displayed or not."
+
+ ;; Also: Used for communication between `ebdb-update-records'
+ ;; and `ebdb-query-create'.
+ :group 'ebdb-mua
+ :type '(choice (const :tag "do nothing" nil)
+ (const :tag "search for existing records" search)
+ (const :tag "update existing records" update)
+ (const :tag "query annotation of all messages" query)
+ (const :tag "annotate all messages" create)
+ (function :tag "User-defined function")))
+
+(defcustom ebdb-message-headers
+ '((sender "From" "Resent-From" "Reply-To" "Sender")
+ (recipients "Resent-To" "Resent-CC" "To" "CC" "BCC"))
+ "Alist of headers to search for sender and recipients mail addresses.
+Each element is of the form
+
+ (CLASS HEADER ...)
+
+The symbol CLASS defines a class of headers.
+The strings HEADER belong to CLASS."
+ :group 'ebdb-mua
+ :type 'list)
+
+(defcustom ebdb-message-all-addresses nil
+ "If t `ebdb-update-records' returns all mail addresses of a message.
+Otherwise this function returns only the first mail address of each message."
+ :group 'ebdb-mua
+ :type 'boolean)
+
+(defcustom ebdb-message-try-all-headers nil
+ "If t try all message headers to extract an email address from a message.
+Several EBDB commands extract either the sender or the recipients' email
+addresses from a message according to `ebdb-message-headers'. If EBDB does not
+find any email address in this subset of message headers (for example, because
+an email address is excluded because of `ebdb-user-mail-address-re')
+but `ebdb-message-try-all-headers' is t, then these commands will also consider
+the email addresses in the remaining headers."
+ :group 'ebdb-mua
+ :type 'boolean)
+
+;; TODO: Handle more headers. Why not make it possible for EBDB to
+;; ignore all messages more than five years old, for instance? Also,
+;; there was originally a distinction between ignoring a message
+;; (everything about the message), and ignoring an individual
+;; name/mail element of a message. We probably want to restore that
+;; distinction. Ie, we'll have a full complement of
+;; `ebdb-(accept|ignore)-(message|address)-alist' variables.
+
+(defcustom ebdb-accept-header-alist nil
+ "Alist describing which messages to automatically create EBDB records for.
+The format of this alist is
+ ((HEADER-TYPE . REGEXP) ...)
+
+Where HEADER-TYPE is one of the symbols 'sender, 'recipients',
+'any (meaning 'sender or 'recipients), or 'subject.
+
+For example, if
+ ((sender . \"@.*\\.maximegalon\\.edu\")
+ (subject . \"time travel\"))
+EBDB records are only created for messages sent by people at Maximegalon U.,
+or people posting about time travel.
+If t accept all messages. If nil, accept all messages.
+
+See also `ebdb-ignore-message-alist', which has the opposite effect."
+ :group 'ebdb-mua
+ :type '(repeat (cons
+ (choice (symbol :tag "Sender" sender)
+ (symbol :tag "Recipients" recipients)
+ (symbol :tag "Sender or recipients" any)
+ (symbol :tag "Subject" subject))
+ (regexp :tag "Regexp to match on header value"))))
+
+(defcustom ebdb-ignore-header-alist nil
+ "Alist describing which messages not to automatically create EBDB records
for.
+The format of this alist is
+ ((HEADER-TYPE . REGEXP) ... )
+
+Where HEADER-TYPE is one of the symbols 'sender, 'recipients',
+'any (meaning 'sender or 'recipients), or 'subject.
+
+For example, if
+ ((sender . \"mailer-daemon\")
+ (recipients . \"mailing-list-1\\\\|mailing-list-2\"))
+no EBDB records are created for messages from any mailer daemon,
+or messages sent to or CCed to either of two mailing lists.
+If t ignore all messages. If nil do not ignore any messages.
+
+See also `ebdb-accept-message-alist', which has the opposite effect."
+ :group 'ebdb-mua
+ :type '(repeat (cons
+ (choice (symbol :tag "Sender" sender)
+ (symbol :tag "Recipients" recipients)
+ (symbol :tag "Sender or recipients" any)
+ (symbol :tag "Subject" subject))
+ (regexp :tag "Regexp to match on header value"))))
+
+(defcustom ebdb-user-mail-address-re
+ (and (stringp user-mail-address)
+ (string-match "\\`\\(address@hidden)\\(@\\|\\'\\)" user-mail-address)
+ (concat "\\<" (regexp-quote (match-string 1 user-mail-address)) "\\>"))
+ "A regular expression matching your mail addresses.
+This option can be directly set to a regexp. It can also be the
+symbol 'message, in which case the value of
+`message-alternative-emails' will be used, or the symbol 'self,
+in which case the value will be constructed from the mail
+addresses of the record pointed to by `ebdb-record-self'.
+Several EBDB commands extract either the sender or the
+recipients' email addresses from a message according to
+`ebdb-message-headers'. Yet an email address will be ignored if
+it matches `ebdb-user-mail-address-re'. This way the commands
+will not operate on your own record. See also
+`ebdb-message-try-all-headers'."
+ :group 'ebdb-mua
+ :type '(choice (const :tag "Use addresses from `ebdb-record-self'" self)
+ (const :tag "Use the value of `message-alternative-emails'"
message)
+ (regexp :tag "Regexp matching your mail addresses")))
+
+;; This is currently only called in `ebdb-mua-test-headers'.
+(defun ebdb-get-user-mail-address-re ()
+ "Get or set the value of variable `ebdb-user-mail-address-re'.
+
+If it's a symbol, check if it's one of 'self or 'message, and set
+accordingly."
+ (cond ((stringp ebdb-user-mail-address-re)
+ ebdb-user-mail-address-re)
+ ((eq ebdb-user-mail-address-re 'self)
+ (let ((self-rec (ebdb-gethash ebdb-record-self 'uuid)))
+ (unless self-rec
+ (user-error "`ebdb-user-mail-address-re' set to 'self, but
`ebdb-record-self' is not set."))
+ (setq ebdb-user-mail-address-re
+ (regexp-opt (slot-value
+ (ebdb-record-cache self-rec)
+ 'mail-canon)))))
+ ((eq ebdb-user-mail-address-re 'message)
+ (setq ebdb-user-mail-address-re
+ message-alternative-emails))
+ (t ebdb-user-mail-address-re)))
+
+(defcustom ebdb-add-name 'query
+ "How to handle new names for existing EBDB records.
+This handles messages where the real name differs from the name
+in a EBDB record with the same mail address, as in \"John Smith
<address@hidden>\"
+versus \"John Q. Smith <address@hidden>\".
+Allowed values are:
+ t Automatically change the name to the new value.
+ query Query whether to use the new name.
+ nil Ignore the new name.
+ a number Number of seconds EBDB displays the name mismatch.
+ (without further action).
+ a function This is called with two args, the record and the new name.
+ It should return one of the above values.
+ a regexp If the new name matches this regexp ignore it.
+ Otherwise query to add it.
+See also `ebdb-add-aka'."
+ :group 'ebdb-mua
+ :type '(choice (const :tag "Automatically use the new name" t)
+ (const :tag "Query for name changes" query)
+ (const :tag "Ignore the new name" nil)
+ (integer :tag "Number of seconds to display name mismatch")
+ (function :tag "Function for analyzing name handling")
+ (regexp :tag "If the new name matches this regexp ignore
it.")))
+
+(defcustom ebdb-add-aka 'query
+ "How to handle alternate names for existing EBDB records.
+Allowed values are:
+ t Automatically store alternate names as AKA.
+ query Query whether to store alternate names as an AKA.
+ nil Ignore alternate names.
+ a function This is called with two args, the record and the new name.
+ It should return one of the above values.
+ a regexp If the alternate name matches this regexp ignore it.
+ Otherwise query to add it.
+See also `ebdb-add-name'."
+ :group 'ebdb-mua
+ :type '(choice (const :tag "Automatically store alternate names as AKA" t)
+ (const :tag "Query for alternate names" query)
+ (const :tag "Ignore alternate names" nil)
+ (function :tag "Function for alternate name handling")
+ (regexp :tag "If the alternate name matches this regexp
ignore it.")))
+
+(defcustom ebdb-add-mails 'query
+ "How to handle new mail addresses for existing EBDB records.
+This handles messages where the mail address differs from the mail addresses
+in a EBDB record with the same name as in \"John Q. Smith <address@hidden>\"
+versus \"John Q. Smith <address@hidden>\".
+Allowed values are:
+ t Automatically add new mail addresses to the list of mail
addresses.
+ query Query whether to add it.
+ nil Ignore new mail addresses.
+ a number Number of seconds EBDB displays the new address
+ (without further action).
+ a function This is called with two args, the record and the new mail address.
+ It should return one of the above values.
+ a regexp If the new mail address matches this regexp ignore the new
address.
+ Otherwise query to add it.
+See also `ebdb-new-mails-primary' and `ebdb-ignore-redundant-mails'."
+ :group 'ebdb-mua
+ :type '(choice (const :tag "Automatically add new mail addresses" t)
+ (const :tag "Query before adding new mail addresses" query)
+ (const :tag "Never add new mail addresses" nil)
+ (number :tag "Number of seconds to display new addresses")
+ (function :tag "Function for analyzing name handling")
+ (regexp :tag "If the new address matches this regexp ignore
it.")))
+
+(defcustom ebdb-new-mails-primary 'query
+ "Where to put new mail addresses for existing EBDB records.
+A new mail address may either become the new primary mail address,
+when it is put at the beginning of the list of mail addresses.
+Or the new mail address is added at the end of the list of mail addresses.
+Allowed values are:
+ t Make a new address automatically the primary address.
+ query Query whether to make it the primary address.
+ nil Add the new address to the end of the list.
+ a function This is called with two args, the record and the new mail address.
+ It should return one of the above values.
+ a regexp If the new mail address matches this regexp put it at the end.
+ Otherwise query to make it the primary address.
+See also `ebdb-add-mails'."
+ :group 'ebdb-mua
+ :type '(choice (const :tag "New address automatically made primary" t)
+ (const :tag "Query before making a new address primary" query)
+ (const :tag "Do not make new address primary" nil)
+ (function :tag "Function for analyzing primary handling")
+ (regexp :tag "If the new mail address matches this regexp put
it at the end.")))
+
+(defcustom ebdb-canonicalize-mail-function nil
+ "If non-nil, it should be a function of one arg: a mail address string.
+When EBDB \"notices\" a message, the corresponding mail addresses are passed
+to this function first. It acts as a kind of \"filter\" to transform
+the mail addresses before they are compared against or added to the database.
+See `ebdb-canonicalize-mail-1' for a more complete example.
+If this function returns nil, EBDB assumes that there is no mail address.
+
+See also `ebdb-ignore-redundant-mails'."
+ :group 'ebdb-mua
+ :type 'function)
+
+(defcustom ebdb-ignore-redundant-mails 'query
+ "How to handle redundant mail addresses for existing EBDB records.
+For example, \"address@hidden" is redundant w.r.t. \"address@hidden".
+This affects two things, whether a new redundant mail address is added
+to EBDB and whether an old mail address, which has become redundant
+because of a newly added mail address, is removed from EBDB.
+
+Allowed values are:
+ t Automatically ignore redundant mail addresses.
+ query Query whether to ignore them.
+ nil Do not ignore redundant mail addresses.
+ a number Number of seconds EBDB displays redundant mail addresses
+ (without further action).
+ a function This is called with two args, the record and the new mail address.
+ It should return one of the above values.
+ a regexp If the new mail address matches this regexp never ignore
+ this mail address. Otherwise query to ignore it.
+See also `ebdb-add-mails' and `ebdb-canonicalize-mail-function'."
+ :group 'ebdb-mua
+ :type '(choice (const :tag "Automatically ignore redundant mail addresses" t)
+ (const :tag "Query whether to ignore them" query)
+ (const :tag "Do not ignore redundant mail addresses" nil)
+ (number :tag "Number of seconds to display redundant
addresses")
+ (function :tag "Function for handling redundant mail
addresses")
+ (regexp :tag "If the new address matches this regexp never
ignore it.")))
+(define-obsolete-variable-alias 'ebdb-canonicalize-redundant-mails
+ 'ebdb-ignore-redundant-mails)
+
+(defcustom ebdb-message-clean-name-function 'ebdb-message-clean-name-default
+ "Function to clean up the name in the header of a message.
+It takes one argument, the name as extracted by
+`mail-extract-address-components'."
+ :group 'ebdb-mua
+ :type 'function)
+
+(defcustom ebdb-message-mail-as-name t
+ "If non-nil use mail address of message as fallback for name of new records."
+ :group 'ebdb-mua
+ :type 'boolean)
+
+(defcustom ebdb-notice-mail-hook nil
+ "Hook run each time a mail address of a record is \"noticed\" in a message.
+This means that the mail address in a message belongs to an existing EBDB
record
+or to a record EBDB has created for the mail address.
+
+Run with one argument, the record. It is up to the hook function
+to determine which MUA is used and to act appropriately.
+Hook functions can use the variable `ebdb-update-records-address'
+to determine the header and class of the mail address according
+to `ebdb-message-headers'. See `ebdb-auto-notes' for how to annotate records
+using `ebdb-update-records-address' and the headers of a mail message.
+
+If a message contains multiple mail addresses belonging to one EBDB record,
+this hook is run for each mail address. Use `ebdb-notice-record-hook'
+if you want to notice each record only once per message."
+ :group 'ebdb-mua
+ :type 'hook)
+
+(define-widget 'ebdb-alist-with-header 'group
+ "My group"
+ :match 'ebdb-alist-with-header-match
+ :value-to-internal (lambda (_widget value)
+ (if value (list (car value) (cdr value))))
+ :value-to-external (lambda (_widget value)
+ (if value (append (list (car value)) (cadr value)))))
+
+(defun ebdb-alist-with-header-match (widget value)
+ (widget-group-match widget
+ (widget-apply widget :value-to-internal value)))
+
+(defvar ebdb-auto-notes-rules-expanded nil
+ "Expanded `ebdb-auto-notes-rules'.") ; Internal variable
+
+(defcustom ebdb-auto-notes-rules nil
+ "List of rules for adding notes to records of mail addresses of messages.
+This automatically annotates the EBDB record of the sender or recipient
+of a message based on the value of a header such as the Subject header.
+This requires that `ebdb-notice-mail-hook' contains `ebdb-auto-notes'
+and that the record already exists or `ebdb-update-records-p' returns such that
+the record will be created. Messages matching
`ebdb-auto-notes-ignore-messages'
+are ignored.
+
+The elements of this list are
+
+ (FROM-TO HEADER ANNOTATE ...)
+ (HEADER ANNOTATE ...)
+
+FROM-TO is a list of headers and/or header classes as in
`ebdb-message-headers'.
+The record corresponding to a mail address of a message is considered for
+annotation if this mail address was found in a header matching FROM-TO.
+If FROM-TO is missing or t, records for each mail address are considered
+irrespective of where the mail address was found in a message.
+
+HEADER is a message header that is considered for generating the annotation.
+
+ANNOTATE may take the following values:
+
+ (REGEXP . STRING) [this is equivalent to (REGEXP notes STRING)]
+ (REGEXP FIELD STRING)
+ (REGEXP FIELD STRING REPLACE)
+
+REGEXP must match the value of HEADER for generating an annotation.
+However, if the value of HEADER also matches an element of
+`ebdb-auto-notes-ignore-headers' no annotation is generated.
+
+The annotation will be added to FIELD of the respective record.
+FIELD defaults to `ebdb-default-xfield'.
+
+STRING defines a replacement for the match of REGEXP in the value of HEADER.
+It may contain \\& or \\N specials used by `replace-match'.
+The resulting string becomes the annotation.
+If STRING is an integer N, the Nth matching subexpression is used.
+If STRING is a function, it will be called with one arg, the value of HEADER.
+The return value (which must be a string) is then used.
+
+If REPLACE is t, the resulting string replaces the old contents of FIELD.
+If it is nil, the string is appended to the contents of FIELD (unless the
+annotation is already part of the content of field).
+
+For example,
+
+ ((\"To\" (\"address@hidden" . \"VM mailing list\"))
+ (\"Subject\" (\"sprocket\" . \"mail about sprockets\")
+ (\"you bonehead\" . \"called me a bonehead\")))
+
+will cause the text \"VM mailing list\" to be added to the notes field
+of the records corresponding to anyone you get mail from via one of the VM
+mailing lists.
+
+If multiple clauses match the message, all of the corresponding strings
+will be added.
+
+See also variables `ebdb-auto-notes-ignore-messages' and
+`ebdb-auto-notes-ignore-headers'.
+
+For speed-up, the function `ebdb-auto-notes' actually use expanded rules
+stored in the internal variable `ebdb-auto-notes-rules-expanded'.
+If you change the value of `ebdb-auto-notes-rules' outside of customize,
+set `ebdb-auto-notes-rules-expanded' to nil, so that the expanded rules
+will be re-evaluated."
+ :group 'ebdb-mua
+ :set (lambda (symbol value)
+ (set-default symbol value)
+ (setq ebdb-auto-notes-rules-expanded nil))
+ :type '(repeat
+ (ebdb-alist-with-header
+ (repeat (choice
+ (const sender)
+ (const recipients)))
+ (string :tag "Header name")
+ (repeat (choice
+ (cons :tag "Value Pair"
+ (regexp :tag "Regexp to match on header value")
+ (string :tag "String for notes if regexp matches"))
+ (list :tag "Replacement list"
+ (regexp :tag "Regexp to match on header value")
+ (choice :tag "Record field"
+ (const notes :tag "xfields")
+ (const organization :tag "Organization")
+ (symbol :tag "Other"))
+ (choice :tag "Regexp match"
+ (string :tag "Replacement string")
+ (integer :tag "Subexpression match")
+ (function :tag "Callback Function"))
+ (choice :tag "Replace previous contents"
+ (const :tag "No" nil)
+ (const :tag "Yes" t))))))))
+
+(defcustom ebdb-auto-notes-ignore-messages nil
+ "List of rules for ignoring entire messages in `ebdb-auto-notes'.
+The elements may have the following values:
+ a function This function is called with one arg, the record
+ that would be annotated.
+ Ignore this message if the function returns non-nil.
+ This function may use `ebdb-update-records-address'.
+ (HEADER . REGEXP) Ignore messages where HEADER matches REGEXP.
+ For example, (\"From\" . ebdb-user-mail-address-re)
+ disables any recording of notes for mail addresses
+ found in messages coming from yourself, see
+ `ebdb-user-mail-address-re'.
+See also `ebdb-auto-notes-ignore-headers'."
+ :group 'ebdb-mua
+ :type '(repeat (cons
+ (string :tag "Header name")
+ (regexp :tag "Regexp to match on header value"))))
+
+(defcustom ebdb-auto-notes-ignore-headers nil
+ "Alist of headers and regexps to ignore in `ebdb-auto-notes'.
+Each element is of the form
+
+ (HEADER . REGEXP)
+
+For example,
+
+ (\"Organization\" . \"^Gatewayed from\\\\\|^Source only\")
+
+will exclude the phony `Organization:' headers in GNU mailing-lists
+gatewayed to gnu.* newsgroups.
+See also `ebdb-auto-notes-ignore-messages'."
+ :group 'ebdb-mua
+ :type '(repeat (cons
+ (string :tag "Header name")
+ (regexp :tag "Regexp to match on header value"))))
+
+(defcustom ebdb-mua-pop-up t
+ "If non-nil, display an auto-updated EBDB window while using a MUA.
+If 'horiz, stack the window horizontally if there is room.
+If this is nil, EBDB is updated silently.
+
+See also `ebdb-mua-pop-up-window-size' and
`ebdb-mua-horiz-pop-up-window-size'."
+ :group 'ebdb-mua
+ :type '(choice (const :tag "MUA EBDB window stacked vertically" t)
+ (const :tag "MUA EBDB window stacked horizontally" horiz)
+ (const :tag "No MUA EBDB window" nil)))
+(define-obsolete-variable-alias 'ebdb-message-pop-up 'ebdb-mua-pop-up)
+
+(defcustom ebdb-mua-pop-up-window-size ebdb-pop-up-window-size
+ "Vertical size of MUA pop-up EBDB window (vertical split).
+If it is an integer number, it is the number of lines used by EBDB.
+If it is a fraction between 0.0 and 1.0 (inclusive), it is the fraction
+of the tallest existing window that EBDB will take over.
+If it is t use `pop-to-buffer' to create the EBDB window.
+See also `ebdb-pop-up-window-size'."
+ :group 'ebdb-mua
+ :type '(choice (number :tag "EBDB window size")
+ (const :tag "Use `pop-to-buffer'" t)))
+
+(defcustom ebdb-mua-horiz-pop-up-window-size '(112 . 0.3)
+ "Horizontal size of a MUA pop-up EBDB window (horizontal split).
+It is a cons pair (TOTAL . EBDB-SIZE).
+The window that will be considered for horizontal splitting must have
+at least TOTAL columns. EBDB-SIZE is the horizontal size of the EBDB window.
+If it is an integer number, it is the number of columns used by EBDB.
+If it is a fraction between 0 and 1, it is the fraction of the
+window width that EBDB will take over."
+ :group 'ebdb-mua
+ :type '(cons (number :tag "Total number of columns")
+ (number :tag "Horizontal size of EBDB window")))
+
+
+
+(defcustom ebdb-mua-summary-unification-list
+ '(name mail message-name message-mail message-address)
+ "List of FIELDs considered by `ebdb-mua-summary-unify'.
+For the RECORD matching the address of a message, `ebdb-mua-summary-unify'
+returns the first non-empty field value matching an element FIELD from this
list.
+Each element FIELD may be a valid argument of `ebdb-record-field' for RECORD.
+In addition, this list may also include the following elements:
+ message-name The name in the address of the message
+ message-mail The mail in the address of the message
+ message-address The complete address of the message
+These provide a fallback if a message does not have a matching RECORD
+or if some FIELD of RECORD is empty."
+ :group 'ebdb-mua
+ :type '(repeat (symbol :tag "Field")))
+
+;; There are two ways to customize the mark shown for a record in an
+;; MUA's summary buffer. One is to give the record an
+;; `ebdb-field-summary-mark' field, holding the character to be
+;; displayed. The other is to implement the
+;; `ebdb-mua-make-summary-mark' method, which accepts the record as an
+;; argument, and returns a one-character string. If both are present,
+;; the per-record field wins.
+
+(defclass ebdb-field-summary-mark (ebdb-field-user)
+ ((char
+ :type character
+ :initarg :char
+ :documentation
+ "The character to display in MUA summary buffers for this
+ record."))
+ :human-readable "summary mark"
+ :documentation "Field holding the character to be displayed in MUA summary
+ buffers.")
+
+(cl-defmethod ebdb-read ((class (subclass ebdb-field-summary-mark)) &optional
slots obj)
+ (let ((char (read-char "Character: ")))
+ (cl-call-next-method class (plist-put slots :char char) obj)))
+
+(cl-defmethod ebdb-string ((field ebdb-field-summary-mark))
+ (char-to-string (slot-value field 'char)))
+
+(cl-defgeneric ebdb-mua-make-summary-mark (record)
+ "Return a single-character string to mark RECORD in an MUA
+ summary buffer.")
+
+(cl-defmethod ebdb-mua-make-summary-mark ((record ebdb-record))
+ "By default, do nothing."
+ nil)
+
+(defcustom ebdb-mua-summary-mark "+"
+ "Default mark for message addresses known to EBDB.
+If nil do not mark message addresses known to EBDB.
+See `ebdb-mua-summary-mark' and `ebdb-mua-summary-unify'.
+See also the field class `ebdb-field-summary-mark'."
+ :group 'ebdb-mua
+ :type '(choice (string :tag "Mark used")
+ (const :tag "Do not mark known posters" nil)))
+
+(defcustom ebdb-mua-summary-unify-format-letter "E"
+ "Letter required for `ebdb-mua-summary-unify' in the MUA Summary format
string.
+For Gnus, combine it with the %u specifier in `gnus-summary-line-format'
+\(see there), for example use \"%U%R%z%I%(%[%4L: %-23,23uB%]%) %s\\n\".
+For VM, combine it with the %U specifier in `vm-summary-format' (see there),
+for example, use \"%n %*%a %-17.17UB %-3.3m %2d %4l/%-5c %I\\\"%s\\\"\\n\".
+This customization of `gnus-summary-line-format' / `vm-summary-format'
+is required to use `ebdb-mua-summary-unify'.
+Currently no other MUAs support this EBDB feature."
+ :group 'ebdb-mua
+ :type 'string)
+
+(defcustom ebdb-mua-summary-mark-format-letter "e"
+ "Letter required for `ebdb-mua-summary-mark' in the MUA Summary format
string.
+For Gnus, combine it with the %u specifier in `gnus-summary-line-format'
+\(see there), for example, use \"%U%R%z%I%(%[%4L: %ue%-23,23f%]%) %s\\n\".
+For VM, combine it with the %U specifier in `vm-summary-format' (see there),
+for example, use \"%n %*%a %Ue%-17.17F %-3.3m %2d %4l/%-5c %I\\\"%s\\\"\\n\".
+This customization of `gnus-summary-line-format' / `vm-summary-format'
+is required to use `ebdb-mua-summary-mark'.
+Currently no other MUAs support this EBDB feature."
+ :group 'ebdb-mua
+ :type 'string)
+
+(defsubst ebdb-message-header-re (header regexp)
+ "Return non-nil if REGEXP matches value of HEADER."
+ (let ((val (ebdb-message-header header))
+ (case-fold-search t)) ; RW: Is this what we want?
+ (when (and val (string-match regexp val))
+ (throw done t))))
+
+(defun ebdb-mua-test-headers (header-type address-parts &optional
ignore-address)
+ "Decide if the address in ADDRESS-PARTS should be ignored or
+ acted upon. Return t if the header \"passes\".
+
+Takes into consideration the IGNORE-ADDRESS argument, as well the
+variables `ebdb-user-mail-address-re',
+`ebdb-accept-header-alist', and `ebdb-ignore-header-alist'."
+ (let ((name (car address-parts))
+ (mail (cadr address-parts)))
+ (and (null (or (and (stringp ignore-address)
+ (or (and name (string-match-p ignore-address name))
+ (and mail (string-match-p ignore-address mail))))
+ (string-match-p
+ (ebdb-get-user-mail-address-re)
+ mail)))
+ (cond ((null (or ebdb-accept-header-alist
+ ebdb-ignore-header-alist))
+ t)
+ ((and ebdb-accept-header-alist
+ (null ebdb-ignore-header-alist))
+ (ebdb-mua-check-header header-type address-parts))
+ ((and ebdb-ignore-header-alist
+ (null ebdb-accept-header-alist))
+ (ebdb-mua-check-header header-type address-parts t))
+ ((and ebdb-accept-header-alist
+ ebdb-ignore-header-alist)
+ (and (ebdb-mua-check-header header-type address-parts)
+ (ebdb-mua-check-header header-type address-parts t)))))))
+
+(defsubst ebdb-mua-check-header (header-type address-parts &optional invert)
+ (let ((rest (if invert
+ ebdb-ignore-header-alist
+ ebdb-accept-header-alist))
+ h-type)
+ (catch 'done
+ (dolist (elt rest)
+ (setq h-type (car elt))
+ (cond ((and (eq h-type 'subject)
+ (eq header-type 'subject))
+ (when (ebdb-message-header-re "Subject" (cdr elt))
+ (throw 'done (if invert nil t))))
+ ((or (eq h-type header-type)
+ (and (eq h-type 'any)
+ (memq header-type '(sender recipient))))
+ (when (string-match-p (cdr elt) (second address-parts))
+ (throw 'done (if invert nil t))))))
+ (throw 'done t))))
+
+;; How are you supposed to do the &context arglist for a defgeneric?
+;; (cl-defgeneric ebdb-message-header (header)
+;; "Get value of HEADER for the mua keyed to major-mode.")
+
+(defun ebdb-get-address-components (&optional header-class ignore-address)
+ "Process mail addresses extracted from a message.
+Return list with elements (NAME EMAIL HEADER HEADER-CLASS MUA).
+HEADER-CLASS is defined in `ebdb-message-headers'. If
+HEADER-CLASS is nil, use all classes in `ebdb-message-headers'.
+
+Returned address components are checked against the the values of
+IGNORE-ADDRESS, `ebdb-user-mail-address-re',
+`ebdb-accept-header-alist' and `ebdb-ignore-header-alist', and
+are discarded as appropriate."
+ ;; We do not use `ebdb-message-all-addresses' here because only when we
+ ;; have compared the addresses with the records in EBDB do we know which
+ ;; address(es) are relevant for us.
+ (let ((message-headers (if header-class
+ (list (assoc header-class ebdb-message-headers))
+ ebdb-message-headers))
+ address-list mail mail-list content)
+ (condition-case nil
+ (dolist (headers message-headers)
+ (dolist (header (cdr headers))
+ (when (setq content (ebdb-message-header header))
+ (dolist (address (ebdb-extract-address-components content t))
+ (setq mail (cadr address))
+ ;; Ignore addresses that should be ignored.
+ (when (and mail
+ (not (member-ignore-case mail mail-list))
+ (ebdb-mua-test-headers (car headers) address
ignore-address))
+ ;; Add each address only once. (Use MAIL-LIST for book
keeping.)
+ ;; Thus if we care about whether an address gets associated
with
+ ;; one or another header, the order of elements in
+ ;; `ebdb-message-headers' is relevant. The "most important"
+ ;; headers should be first in `ebdb-message-headers'.
+ (push mail mail-list)
+ (push (list (car address) (cadr address) header (car headers)
major-mode) address-list))))))
+ (cl-no-applicable-method
+ ;; Potentially triggered by `ebdb-message-header', which
+ ;; dispatches on major-mode.
+ (error "EBDB does not support %s" major-mode)))
+ (or (nreverse address-list)
+ (and header-class ebdb-message-try-all-headers
+ ;; Try again the remaining header classes
+ (let ((ebdb-message-headers
+ (remove (assoc header-class ebdb-message-headers)
+ ebdb-message-headers)))
+ (ebdb-get-address-components nil ignore-address))))))
+
+;;;###autoload
+(defun ebdb-update-records (address-list &optional update-p sort)
+ "Return the list of EBDB records matching ADDRESS-LIST.
+ADDRESS-LIST is a list of mail addresses. (It can be extracted from
+a mail message using `ebdb-get-address-components'.)
+UPDATE-P may take the following values:
+ existing Find existing records matching ADDRESS.
+ update Search for existing records matching ADDRESS;
+ update name and mail field if necessary.
+ query Search for existing records matching ADDRESS;
+ query for creation of a new record if the record does not
exist.
+ create or t Search for existing records matching ADDRESS;
+ create a new record if it does not yet exist.
+ nil Do nothing.
+ a function This functions will be called with no arguments.
+ It should return one of the above values.
+
+If SORT is non-nil, sort records according to `ebdb-record-lessp'.
+Otherwise, the records are ordered according to ADDRESS-LIST.
+
+Usually this function is called by the wrapper `ebdb-mua-auto-update'."
+
+ (when (functionp update-p)
+ (setq update-p (funcall update-p)))
+ (when (eq t update-p)
+ (setq update-p 'create))
+
+ (let ( ;; `ebdb-update-records-p' and `ebdb-offer-to-create' are used here
+ ;; as internal variables for communication with `ebdb-query-create'.
+ ;; This does not affect the value of the global user variable
+ ;; `ebdb-mua-auto-update-p'.
+ (ebdb-offer-to-create 'start)
+ (ebdb-update-records-p update-p)
+ address records)
+
+ (when update-p
+ (while (setq address (pop address-list))
+ (let* ((ebdb-update-records-address address)
+ hits
+ (task
+ (catch 'done
+ (setq hits
+ ;; We put the call of `ebdb-notice-mail-hook'
+ ;; into `ebdb-annotate-message' so that this hook
+ ;; runs only if the user agreed to change a record.
+ (cond ((eq ebdb-update-records-p 'existing)
+ ;; Search for records having this mail address
+ ;; but do not modify an existing record.
+ ;; This does not run `ebdb-notice-mail-hook'.
+ (ebdb-message-search (car address)
+ (cadr address)))
+ ((eq ebdb-update-records-p 'query)
+ (ebdb-annotate-message
+ address 'ebdb-query-create))
+ (t
+ (ebdb-annotate-message
+ address ebdb-update-records-p))))
+ nil)))
+ (cond ((eq task 'quit)
+ (setq address-list nil))
+ ((not (eq task 'next))
+ (dolist (hit (delq nil (nreverse hits)))
+ (cl-pushnew hit records :test #'equal))))
+ (if (and records (not ebdb-message-all-addresses))
+ (setq address-list nil))))
+ (setq records
+ (if sort (sort records 'ebdb-record-lessp)
+ ;; Make RECORDS a list ordered like ADDRESS-LIST.
+ (nreverse records))))
+
+ ;; `ebdb-message-search' might yield multiple records
+ (if (and records (not ebdb-message-all-addresses))
+ (setq records (list (car records))))
+
+ (dolist (record records)
+ (ebdb-notice record))
+
+ records))
+
+;;; This whole thing could probably be replaced by `map-y-or-n-p'
+(defun ebdb-query-create ()
+ "Interactive query used by `ebdb-update-records'.
+Return t if the record should be created or `nil' otherwise.
+Honor previous answers such as `!'."
+ (let ((task ebdb-offer-to-create))
+ ;; If we have remembered what the user typed previously,
+ ;; `ebdb-offer-to-create' holds a character, i.e., a number.
+ ;; -- Right now, we only remember "!".
+ (when (not (integerp task))
+ (let ((prompt (format "%s is not in EBDB; add? (y,!,n,s,q,?) "
+ (or (nth 0 ebdb-update-records-address)
+ (nth 1 ebdb-update-records-address))))
+ event)
+ (while (not event)
+ (setq event (read-key-sequence prompt))
+ (setq event (if (stringp event) (aref event 0))))
+ (setq task event)
+ (message ""))) ; clear the message buffer
+
+ (cond ((eq task ?y)
+ t)
+ ((eq task ?!)
+ (setq ebdb-offer-to-create task)
+ t)
+ ((or (eq task ?n)
+ (eq task ?\s))
+ (throw 'done 'next))
+ ((or (eq task ?q)
+ (eq task ?\a)) ; ?\a = C-g
+ (throw 'done 'quit))
+ ((eq task ?s)
+ (setq ebdb-update-records-p 'existing)
+ (throw 'done 'next))
+ (t ; any other key sequence
+ (save-window-excursion
+ (let* ((buffer (get-buffer-create " *EBDB Help*"))
+ (window (or (get-buffer-window buffer)
+ (split-window (get-lru-window)))))
+ (with-current-buffer buffer
+ (special-mode)
+ (let (buffer-read-only)
+ (erase-buffer)
+ (insert
+ "Your answer controls how EBDB updates/searches for
records.
+
+Type ? for this help.
+Type y to add the current record.
+Type ! to add all remaining records.
+Type n to skip the current record. (You might also type space)
+Type s to switch from annotate to search mode.
+Type q to quit updating records. No more search or annotation is done.")
+ (set-buffer-modified-p nil)
+ (goto-char (point-min)))
+ (set-window-buffer window buffer)
+ (fit-window-to-buffer window)))
+ ;; Try again!
+ (ebdb-query-create))))))
+
+
+
+(defun ebdb-annotate-message (address &optional update-p)
+ "Fill the records for message ADDRESS with as much info as possible.
+If a record for ADDRESS does not yet exist, UPDATE-P controls whether
+a new record is created for ADDRESS. UPDATE-P may take the values:
+ update or nil Update existing records, never create a new record.
+ query Query interactively whether to create a new record.
+ create or t Create a new record.
+ a function This functions will be called with no arguments.
+ It should return one of the above values.
+Return the records matching ADDRESS or nil."
+ (let* ((mail (nth 1 address)) ; possibly nil
+ (name (unless (or (equal mail (car address))
+ (null (car address)))
+ (ebdb-string (ebdb-parse 'ebdb-field-name-complex (car
address)))))
+ (records (ebdb-message-search name mail))
+ created-p new-records)
+ (if (and (not records) (functionp update-p))
+ (setq update-p (funcall update-p)))
+ (cond ((eq t update-p) (setq update-p 'create))
+ ((not update-p) (setq update-p 'update)))
+
+ ;; Create a new record if nothing else fits.
+ ;; In this way, we can fill the slots of the new record with
+ ;; the same code that updates the slots of existing records.
+ (unless (or records
+ (eq update-p 'update)
+ (not (or name mail)))
+ ;; If there is no name, try to use the mail address as name
+ (if (and ebdb-message-mail-as-name mail
+ (or (null name)
+ (string= "" name)))
+ (setq name (funcall ebdb-message-clean-name-function mail)))
+ (if (or (eq update-p 'create)
+ (and (eq update-p 'query)
+ (y-or-n-p (format "%s is not in the EBDB. Add? "
+ (or name mail)))))
+ (setq records (list (ebdb-db-add-record
+ (car ebdb-db-list)
+ (make-instance
+ (slot-value (car ebdb-db-list) 'record-class))))
+ created-p t)))
+
+ (dolist (record records)
+ (let* ((old-name (ebdb-record-name record))
+ (fullname (ebdb-divide-name (or name "")))
+ (fname (car fullname))
+ (lname (cdr fullname))
+ (mail mail) ;; possibly changed below
+ (created-p created-p)
+ (update-p update-p)
+ change-p add-mails add-name ignore-redundant)
+
+ ;; Analyze the name part of the record.
+ (cond ((or (not name)
+ ;; The following tests can differ for more complicated names
+ (ebdb-string= name old-name)
+ (and (equal fname (ebdb-record-firstname record)) ; possibly
+ (equal lname (ebdb-record-lastname record))) ; nil
+ (member-ignore-case name (ebdb-record-aka record)))) ; do
nothing
+
+ (created-p ; new record
+ (ebdb-record-change-name
+ record
+ (make-instance ebdb-default-name-class
+ :surname lname
+ :given-names (when fname (list fname)))))
+
+ ((not (setq add-name (ebdb-add-job ebdb-add-name record name))))
; do nothing
+
+ ((numberp add-name)
+ (unless ebdb-silent
+ (message "name mismatch: \"%s\" changed to \"%s\""
+ old-name name)
+ (sit-for add-name)))
+
+ ((ebdb-eval-spec add-name
+ (if old-name
+ (format "Change name \"%s\" to \"%s\"? "
+ old-name name)
+ (format "Assign name \"%s\" to address
\"%s\"? "
+ name (car (ebdb-record-mail
record)))))
+ ;; Keep old-name as AKA?
+ (when (and old-name
+ (not (member-ignore-case old-name (ebdb-record-aka
record))))
+ (if (ebdb-eval-spec (ebdb-add-job ebdb-add-aka record
old-name)
+ (format "Keep name \"%s\" as an AKA? "
old-name))
+ (ebdb-record-set-field
+ record 'aka (cons old-name (ebdb-record-aka record)))
+ (ebdb-remhash old-name record)))
+ (ebdb-record-set-field record 'name (cons fname lname))
+ (setq change-p 'name))
+
+ ;; make new name an AKA?
+ ((and old-name
+ (not (member-ignore-case name (ebdb-record-aka record)))
+ (ebdb-eval-spec (ebdb-add-job ebdb-add-aka record name)
+ (format "Make \"%s\" an alternate for
\"%s\"? "
+ name old-name)))
+ (ebdb-record-set-field
+ record 'aka (cons name (ebdb-record-aka record)))
+ (setq change-p 'name)))
+
+ ;; Is MAIL redundant compared with the mail addresses
+ ;; that are already known for RECORD?
+ (if (and mail
+ (setq ignore-redundant
+ (ebdb-add-job ebdb-ignore-redundant-mails record mail)))
+ (let ((mails (ebdb-record-mail-canon record))
+ (case-fold-search t) redundant ml re)
+ (while (setq ml (pop mails))
+ (if (and (setq re (ebdb-mail-redundant-re ml))
+ (string-match re mail))
+ (setq redundant ml mails nil)))
+ (if redundant
+ (cond ((numberp ignore-redundant)
+ (unless ebdb-silent
+ (message "%s: redundant mail `%s'"
+ (ebdb-string record) mail)
+ (sit-for ignore-redundant)))
+ ((or (eq t ignore-redundant)
+ ebdb-silent
+ (y-or-n-p (format "Ignore redundant mail %s?"
mail)))
+ (setq mail redundant))))))
+ (setq mail (make-instance ebdb-default-mail-class :mail mail))
+ ;; Analyze the mail part of the new records
+ (cond ((or (not mail) (equal (ebdb-string mail) "???")
+ (member-ignore-case (ebdb-string mail)
(ebdb-record-mail-canon record)))) ; do nothing
+
+ (created-p ; new record
+ (ebdb-record-insert-field record 'mail (list mail)))
+
+ ((not (setq add-mails (ebdb-add-job ebdb-add-mails record
mail)))) ; do nothing
+
+ ((numberp add-mails)
+ (unless ebdb-silent
+ (message "%s: new address `%s'"
+ (ebdb-string record) (ebdb-string mail))
+ (sit-for add-mails)))
+
+ ((or (eq add-mails t) ; add it automatically
+ ebdb-silent
+ (y-or-n-p (format "Add address \"%s\" to %s? " (ebdb-string
mail)
+ (ebdb-string record)))
+ (and (or (and (functionp update-p)
+ (progn (setq update-p (funcall update-p))
nil))
+ (memq update-p '(t create))
+ (and (eq update-p 'query)
+ (y-or-n-p
+ (format "Create a new record for %s? "
+ (ebdb-string record)))))
+ (progn
+ (setq record (make-instance
ebdb-default-record-class))
+ (ebdb-db-add-record (car ebdb-db-list) record)
+ (ebdb-record-change-name
+ record
+ (make-instance ebdb-default-name-class
+ :given-names (list fname)
+ :surname lname))
+ (setq created-p t))))
+
+ (let ((mails (ebdb-record-mail record)))
+ (if ignore-redundant
+ ;; Does the new address MAIL make an old address
redundant?
+ (let ((mail-re (ebdb-mail-redundant-re (ebdb-string
mail)))
+ (case-fold-search t) okay redundant)
+ (dolist (ml mails)
+ (if (string-match mail-re (ebdb-string ml)) ;
redundant mail address
+ (push ml redundant)
+ (push ml okay)))
+ (let ((form (format "redundant mail%s %s"
+ (if (< 1 (length redundant)) "s" "")
+ (ebdb-concat 'mail (nreverse
redundant))))
+ (name (ebdb-record-name record)))
+ (if redundant
+ (cond ((numberp ignore-redundant)
+ (unless ebdb-silent
+ (message "%s: %s" name form)
+ (sit-for ignore-redundant)))
+ ((or (eq t ignore-redundant)
+ ebdb-silent
+ (y-or-n-p (format "Delete %s: " form)))
+ (if (eq t ignore-redundant)
+ (message "%s: deleting %s" name form))
+ (setq mails okay)))))))
+
+ ;; then modify RECORD
+
+ ;; TODO: Reinstate the question about making this primary.
+ (ebdb-record-insert-field record 'mail mail)
+ (unless change-p (setq change-p t)))))
+
+ (cond (created-p
+ (unless ebdb-silent
+ (if (ebdb-record-name record)
+ (message "created %s's record with address \"%s\""
+ (ebdb-string record) mail)
+ (message "created record with naked address \"%s\"" mail)))
+ (ebdb-init record))
+
+ (change-p
+ (unless ebdb-silent
+ (cond ((eq change-p 'name)
+ (message "noticed \"%s\"" (ebdb-string record)))
+ ((ebdb-record-name record)
+ (message "noticed %s's address \"%s\""
+ (ebdb-string record) mail))
+ (t
+ (message "noticed naked address \"%s\"" mail))))))
+
+ ;;(run-hook-with-args 'ebdb-notice-mail-hook record)
+ ;; (ebdb-notice record) ; I think this is already happening in
+ ;; `ebdb-update-records'.
+ (push record new-records)))
+
+ (nreverse new-records)))
+
+;; I hope this (&context (major-mode t)) is the proper way to create a
+;; &context catchall.
+(cl-defmethod ebdb-mua-prepare-article (&context (major-mode t))
+ "Do whatever preparations are necessary to work on records
+ associated with the current message.
+
+Dispatches on the value of major-mode."
+ ;; Doesn't need to do anything by default.
+ t)
+
+(defun ebdb-mua-window-p ()
+ "Return lambda function matching the MUA window.
+This return value can be used as arg HORIZ-P of `ebdb-display-records'."
+ (let ((mm-alist ebdb-mua-mode-alist)
+ elt fun)
+ (while (setq elt (cdr (pop mm-alist)))
+ (if (memq major-mode elt)
+ (setq fun `(lambda (window)
+ (with-current-buffer (window-buffer window)
+ (memq major-mode ',elt)))
+ mm-alist nil)))
+ fun))
+
+;;;###autoload
+(defun ebdb-mua-update-records (&optional header-class all)
+ "Update all records associated with the message under point.
+
+This command is meant for manually updating records when
+`ebdb-mua-auto-update-p' is nil: it behaves as if that option
+were set to 'query. The rules of `ebdb-select-message' still
+apply, however."
+ (interactive)
+ ;; Temporarily copy and paste from `ebdb-mua-display-records',
+ ;; refactor later.
+ (let ((ebdb-pop-up-window-size ebdb-mua-pop-up-window-size)
+ (ebdb-message-all-addresses (or all ebdb-message-all-addresses))
+ (fmt ebdb-default-multiline-formatter)
+ records)
+ (ebdb-mua-prepare-article)
+ (setq records (ebdb-update-records
+ (ebdb-get-address-components header-class)
+ 'query t))
+ (if records (ebdb-display-records records fmt nil nil (ebdb-mua-window-p)))
+ records))
+
+;;;###autoload
+(defun ebdb-mua-display-records (&optional header-class all)
+ "Display the EBDB record(s) for the addresses in this message.
+This looks into the headers of a message according to HEADER-CLASS.
+Then for the mail addresses found the corresponding EBDB records are displayed.
+Records are not created or updated.
+
+HEADER-CLASS is defined in `ebdb-message-headers'. If it is nil,
+use all classes in `ebdb-message-headers'. If ALL is non-nil,
+bind `ebdb-message-all-addresses' to ALL."
+ (interactive)
+ (let ((ebdb-pop-up-window-size ebdb-mua-pop-up-window-size)
+ (ebdb-message-all-addresses (or all ebdb-message-all-addresses))
+ (fmt ebdb-default-multiline-formatter)
+ records)
+ (ebdb-mua-prepare-article)
+ (setq records (ebdb-update-records
+ (ebdb-get-address-components header-class)
+ 'existing t))
+ (if records (ebdb-display-records records fmt nil nil (ebdb-mua-window-p)))
+ records))
+
+;; The following commands are some frontends for `ebdb-mua-display-records',
+;; which is always doing the real work. In your init file, you can further
+;; modify or adapt these simple commands to your liking.
+
+;;;###autoload
+(defun ebdb-mua-display-sender ()
+ "Display the EBDB record(s) for the sender of this message."
+ (interactive)
+ (ebdb-mua-display-records 'sender))
+
+;;;###autoload
+(defun ebdb-mua-display-recipients ()
+ "Display the EBDB record(s) for the recipients of this message."
+ (interactive)
+ (ebdb-mua-display-records 'recipients))
+
+;;;###autoload
+(defun ebdb-mua-display-all-records ()
+ "Display the EBDB record(s) for all addresses in this message."
+ (interactive)
+ (ebdb-mua-display-records nil t))
+
+;;;###autoload
+(defun ebdb-mua-display-all-recipients ()
+ "Display EBDB records for all recipients of this message."
+ (interactive)
+ (ebdb-mua-display-records 'recipients t))
+
+;; The commands `ebdb-annotate-record' and `ebdb-mua-edit-field'
+;; have kind of similar goals, yet they use rather different strategies.
+;; `ebdb-annotate-record' is less obtrusive. It does not display
+;; the records it operates on, nor does it display the content
+;; of the field before or after adding or replacing the annotation.
+;; Hence the user needs to know what she is doing.
+;; `ebdb-mua-edit-field' is more explicit: It displays the records
+;; as well as the current content of the field that gets edited.
+
+;; In principle, this function can be used not only with MUAs.
+(defun ebdb-annotate-record (record annotation &optional field replace)
+ "In RECORD add an ANNOTATION to field FIELD.
+FIELD defaults to `ebdb-annotate-field'.
+If REPLACE is non-nil, ANNOTATION replaces the content of FIELD.
+If ANNOTATION is an empty string and REPLACE is non-nil, delete FIELD."
+ (if (memq field '(name firstname lastname phone address))
+ (error "Field `%s' illegal" field))
+ (setq annotation (ebdb-string-trim annotation))
+ (cond ((memq field '(affix organization mail aka))
+ (setq annotation (list annotation)))
+ ((not field) (setq field ebdb-annotate-field)))
+ (ebdb-record-change-field record field annotation))
+
+;; FIXME: For interactive calls of the following commands, the arg UPDATE-P
+;; should have the same meaning as for `ebdb-mua-display-records',
+;; that is, it should use `ebdb-mua-update-interactive-p'.
+;; But here the prefix arg is already used in a different way.
+;; We could possibly solve this problem if all `ebdb-mua-*' commands
+;; used another prefix arg that is consistently used only for
+;; `ebdb-mua-update-interactive-p'.
+;; Yet this prefix arg must be defined within the key space of the MUA(s).
+;; This results in lots of conflicts...
+;;
+;; Current workaround:
+;; These commands use merely the car of `ebdb-mua-update-interactive-p'.
+;; If one day someone proposes a smart solution to this problem (suggestions
+;; welcome!), this solution will hopefully include the current workaround
+;; as a subset of all its features.
+
+(defun ebdb-mua-annotate-field-interactive ()
+ "Interactive specification for `ebdb-mua-annotate-sender' and friends."
+ (let ((field (if (eq 'all-fields ebdb-annotate-field)
+ (intern (completing-read
+ "Field: "
+ (mapcar 'symbol-name
+ '(affix organization mail aka))))
+ ebdb-annotate-field)))
+ (list (read-string (format "Annotate `%s': " field))
+ field current-prefix-arg
+ (car ebdb-mua-update-interactive-p))))
+
+;;;###autoload
+(defun ebdb-mua-annotate-sender (annotation &optional field replace update-p)
+ "Add ANNOTATION to field FIELD of the EBDB record(s) of message sender(s).
+FIELD defaults to `ebdb-annotate-field'.
+If REPLACE is non-nil, ANNOTATION replaces the content of FIELD.
+UPDATE-P may take the same values as `ebdb-update-records-p'."
+ (interactive)
+ (ebdb-mua-prepare-article)
+ (dolist (record (ebdb-update-records
+ (ebdb-get-address-components 'sender)
+ update-p))
+ (ebdb-annotate-record record annotation field replace)))
+
+;;;###autoload
+(defun ebdb-mua-annotate-recipients (annotation &optional field replace
+ update-p)
+ "Add ANNOTATION to field FIELD of the EBDB records of message recipients.
+FIELD defaults to `ebdb-annotate-field'.
+If REPLACE is non-nil, ANNOTATION replaces the content of FIELD.
+UPDATE-P may take the same values as `ebdb-update-records-p'."
+ (interactive)
+ (ebdb-mua-prepare-article)
+ (dolist (record (ebdb-update-records
+ (ebdb-get-address-components 'recipients)
+ update-p))
+ (ebdb-annotate-record record annotation field replace)))
+
+;;;###autoload
+(defun ebdb-mua-edit-field (&optional field update-p header-class)
+ "Edit FIELD of the EBDB record(s) of message sender(s) or recipients.
+FIELD defaults to value of variable `ebdb-mua-edit-field'.
+UPDATE-P may take the same values as `ebdb-update-records-p'.
+HEADER-CLASS is defined in `ebdb-message-headers'. If it is nil,
+use all classes in `ebdb-message-headers'."
+ (interactive)
+ (cond ((memq field '(firstname lastname address phone))
+ (error "Field `%s' not editable this way" field))
+ ((not field)
+ (setq field ebdb-mua-edit-field)))
+ (ebdb-mua-prepare-article)
+ (let ((records (ebdb-update-records
+ (ebdb-get-address-components header-class)
+ update-p))
+ (ebdb-pop-up-window-size ebdb-mua-pop-up-window-size))
+ (when records
+ (ebdb-display-records records nil nil nil (ebdb-mua-window-p))
+ (dolist (record records)
+ (ebdb-edit-field record field)))))
+
+;;;###autoload
+(defun ebdb-mua-edit-field-sender (&optional field update-p)
+ "Edit FIELD of record corresponding to sender of this message.
+FIELD defaults to value of variable `ebdb-mua-edit-field'.
+UPDATE-P may take the same values as `ebdb-update-records-p'.
+For interactive calls, see function `ebdb-mua-update-interactive-p'."
+ (interactive)
+ (ebdb-mua-edit-field field update-p 'sender))
+
+;;;###autoload
+(defun ebdb-mua-edit-field-recipients (&optional field update-p)
+ "Edit FIELD of record corresponding to recipient of this message.
+FIELD defaults to value of variable `ebdb-mua-edit-field'.
+UPDATE-P may take the same values as `ebdb-update-records-p'."
+ (interactive)
+ (ebdb-mua-edit-field field update-p 'recipients))
+
+;; Functions for noninteractive use in MUA hooks
+
+;;;###autoload
+(defun ebdb-mua-auto-update (&optional header-class update-p)
+ "Update EBDB automatically based on incoming and outgoing messages.
+This looks into the headers of a message according to HEADER-CLASS.
+Then for the mail addresses found the corresponding EBDB records are updated.
+UPDATE-P determines whether only existing EBDB records are taken
+or whether also new records are created for these mail addresses.
+Return matching records.
+
+HEADER-CLASS is defined in `ebdb-message-headers'. If it is nil,
+use all classes in `ebdb-message-headers'. UPDATE-P may take the
+same values as `ebdb-mua-auto-update-p'. If UPDATE-P is nil,
+use `ebdb-mua-auto-update-p' (which see).
+
+If `ebdb-mua-pop-up' is non-nil, EBDB pops up the *EBDB* buffer
+along with the MUA window(s), displaying the matching records
+using `ebdb-pop-up-layout'.
+If this is nil, EBDB is updated silently.
+
+This function is intended for noninteractive use via appropriate MUA hooks.
+Call `ebdb-mua-auto-update-init' in your init file to put this function
+into the respective MUA hooks.
+See `ebdb-mua-display-records' and friends for interactive commands."
+ (let* ((ebdb-silent-internal t)
+ (ebdb-pop-up-window-size ebdb-mua-pop-up-window-size)
+ records)
+ (setq records (ebdb-update-records
+ (ebdb-get-address-components header-class)
+ (or update-p
+ ebdb-mua-auto-update-p)))
+ (if ebdb-mua-pop-up
+ (if records
+ (ebdb-display-records records ebdb-default-multiline-formatter
+ nil nil (ebdb-mua-window-p))
+ ;; If there are no records, empty the EBDB window.
+ (ebdb-undisplay-records)))
+ records))
+
+;;;###autoload
+(defun ebdb-auto-notes (record)
+ "Automatically annotate RECORD based on the headers of the current message.
+See the variables `ebdb-auto-notes-rules', `ebdb-auto-notes-ignore-messages'
+and `ebdb-auto-notes-ignore-headers'.
+For use as an element of `ebdb-notice-record-hook'."
+ ;; This code re-evaluates the annotations each time a message is viewed.
+ ;; It would be faster if we could somehow store (permanently?) that we
+ ;; have already annotated a message.
+ (let ((case-fold-search t))
+ (unless (or ebdb-read-only
+ ;; check the ignore-messages pattern
+ (let ((ignore-messages ebdb-auto-notes-ignore-messages)
+ ignore rule)
+ (while (and (not ignore) (setq rule (pop ignore-messages)))
+ (if (cond ((functionp rule)
+ ;; RULE may use `ebdb-update-records-address'
+ (funcall rule record))
+ ((symbolp rule)
+ (eq rule (nth 4 ebdb-update-records-address)))
+ ((eq 1 (safe-length rule))
+ (ebdb-message-header-re (car rule) (cdr rule)))
+ ((eq 2 (safe-length rule))
+ (and (eq (car rule) (nth 4
ebdb-update-records-address))
+ (ebdb-message-header-re (nth 1 rule) (nth
2 rule)))))
+ (setq ignore t)))
+ ignore))
+
+ ;; For speed-up expanded rules are stored in
`ebdb-auto-notes-rules-expanded'.
+ (when (and ebdb-auto-notes-rules
+ (not ebdb-auto-notes-rules-expanded))
+ (let (expanded mua from-to header)
+ (dolist (rule ebdb-auto-notes-rules)
+ ;; Which MUA do we want?
+ (if (or (stringp (car rule))
+ (stringp (nth 1 rule)))
+ (setq mua t)
+ (setq mua (if (symbolp (car rule)) (listp (car rule)) (car rule))
+ rule (cdr rule)))
+ ;; Which FROM-TO headers do we want?
+ (if (stringp (car rule))
+ (setq from-to t)
+ (setq from-to (car rule)
+ rule (cdr rule)))
+ (setq header (car rule))
+ (let (string field replace elt-e)
+ (dolist (elt (cdr rule))
+ (if (consp (setq string (cdr elt)))
+ (setq field (car string) ; (REGEXP FIELD-NAME STRING
REPLACE)
+ replace (nth 2 string) ; perhaps nil
+ string (nth 1 string))
+ ;; else it's simple (REGEXP . STRING)
+ (setq field ebdb-default-xfield
+ replace nil))
+ (push (list (car elt) field string replace) elt-e))
+ (push (append (list mua from-to header) (nreverse elt-e))
expanded)))
+ (setq ebdb-auto-notes-rules-expanded (nreverse expanded))))
+
+ (dolist (rule ebdb-auto-notes-rules-expanded)
+ (let ((mua (car rule)) (from-to (nth 1 rule)) (header (nth 2 rule))
+ hd-val string annotation)
+ (when (and (or (eq mua t)
+ (memq (nth 4 ebdb-update-records-address) mua))
+ (or (eq from-to t)
+ (member-ignore-case
+ (nth 2 ebdb-update-records-address) from-to)
+ (memq (nth 3 ebdb-update-records-address) from-to))
+ (setq hd-val (ebdb-message-header header)))
+ (dolist (elt (nthcdr 3 rule))
+ (when (and (string-match (car elt) hd-val)
+ (let ((ignore (cdr (assoc-string
+ header
+ ebdb-auto-notes-ignore-headers
t))))
+ (not (and ignore (string-match ignore hd-val)))))
+ (setq string (nth 2 elt)
+ annotation
+ (cond ((integerp string)
+ (match-string string hd-val))
+ ((stringp string)
+ (replace-match string nil nil hd-val))
+ ((functionp string)
+ (funcall string hd-val))
+ (t (error "Illegal value: %s" string))))
+ (ebdb-annotate-record record annotation
+ (nth 1 elt) (nth 3 elt))))))))))
+
+;;; Mark EBDB records in the MUA summary buffer
+
+(defun ebdb-mua-summary-unify (address)
+ "Unify mail ADDRESS displayed for a message in the MUA Summary buffer.
+Typically ADDRESS refers to the value of the From header of a message.
+If ADDRESS matches a record in EBDB display a unified name instead of ADDRESS
+in the MUA Summary buffer.
+
+Unification uses `ebdb-mua-summary-unification-list' (see there).
+The first match in this list becomes the text string displayed
+for a message in the MUA Summary buffer instead of ADDRESS.
+If variable `ebdb-mua-summary-mark' is non-nil use it to precede known
addresses.
+Return the unified mail address.
+
+Currently this works with Gnus and VM. It requires the EBDB insinuation
+of these MUAs. Also, the MUA Summary format string must use
+`ebdb-mua-summary-unify-format-letter' (see there)."
+ ;; ADDRESS is analyzed as in `ebdb-get-address-components'.
+ (let* ((data (ebdb-extract-address-components address))
+ (name (car data))
+ (mail (cadr data))
+ (record (car (ebdb-message-search name mail)))
+ (u-list ebdb-mua-summary-unification-list)
+ elt val)
+ (while (setq elt (pop u-list))
+ (setq val (cond ((eq elt 'message-name) name)
+ ((eq elt 'message-mail) mail)
+ ((eq elt 'message-address) address)
+ (record (let ((result (ebdb-record-field record elt)))
+ (if (atom result) (ebdb-string result)
+ (ebdb-string (car result)))))))
+ (if val (setq u-list nil)))
+ (format "%s%s"
+ (cond ((not ebdb-mua-summary-mark) "")
+ ((not record) " ")
+ (t
+ (or (car-safe (ebdb-record-field record
'ebdb-field-summary-mark))
+ (ebdb-mua-make-summary-mark record)
+ ebdb-mua-summary-mark)))
+ (or val name mail address "**UNKNOWN**"))))
+
+(defun ebdb-mua-summary-mark (address)
+ "In the MUA Summary buffer mark messages matching a EBDB record.
+ADDRESS typically refers to the value of the From header of a message.
+If ADDRESS matches a record in EBDB return a mark, \" \" otherwise.
+The mark itself is the value of the xfield `ebdb-mua-summary-mark-field'
+if this xfield is in the poster's record, and `ebdb-mua-summary-mark'
otherwise."
+ (if (not ebdb-mua-summary-mark)
+ "" ; for consistency
+ ;; ADDRESS is analyzed as in `ebdb-get-address-components'.
+ (let* ((data (ebdb-extract-address-components address))
+ (record (car (ebdb-message-search (car data) (cadr data)))))
+ (if record
+ (or (car-safe (ebdb-record-field record 'ebdb-field-summary-mark))
+ (ebdb-mua-make-summary-mark record)
+ ebdb-mua-summary-mark)
+ " "))))
+
+(provide 'ebdb-mua)
+;;; ebdb-mua.el ends here
diff --git a/ebdb-org.el b/ebdb-org.el
new file mode 100644
index 0000000..e1aa151
--- /dev/null
+++ b/ebdb-org.el
@@ -0,0 +1,109 @@
+;;; ebdb-org.el --- Org mode integration for EBDB -*- lexical-binding: t;
-*-
+
+;; Copyright (C) 2016 Eric Abrahamsen
+
+;; Author: Eric Abrahamsen <address@hidden>
+;; Keywords:
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; Org mode integration for EBDB. At present this just defines a link
+;; type; at some point we'll reproduce the Agenda anniversary
+;; mechanisms from org-bbdb.el.
+
+;; EBDB links can come in several varieties. A plain string is simply
+;; fed directly to `bbdb-search'. Otherwise, the string can be
+;; prefixed with a field type, to search only on those field values.
+;; The prefix is separated with a forward slash. Examples:
+
+;; 1. "ebdb:uuid/af1373d6-4ba1-46a7-aa4b-845db01bc2ab" (link to unique
+;; record)
+
+;; 2. "ebdb:mail/google.com" (all records with google.com email
+;; addresses)
+
+;; 3. "ebdb:ebdb-field-foobar/baz" (search on a particular field
+;; class)
+
+;; Valid prefixes include all the values accepted by
+;; `ebdb-record-field', as well as the names of field classes.
+
+;; When calling `org-store-link' on a contact, a "ebdb:uuid/" style
+;; link is created by default.
+
+;;; Code:
+
+(if (fboundp 'org-link-set-parameters)
+ (org-link-set-parameters "ebdb"
+ :follow 'ebdb-org-open
+ :complete (lambda ()
+ (format
+ "ebdb:uuid/%s"
+ (ebdb-record-uuid
(ebdb-completing-read-record "Record: "))))
+ :store 'ebdb-org-store-link
+ :export 'ebdb-org-export)
+ (org-add-link-type "ebdb" #'ebdb-org-open #'ebdb-org-export)
+ (add-hook 'org-store-link-functions 'ebdb-org-store-link))
+
+;; TODO: Put a custom keymap on the links (or else expand
+;; `ebdb-org-open') so that users can choose what to do with the
+;; linked record: display, email, etc.
+
+(defun ebdb-org-store-link ()
+ "Store a link to an EBDB contact."
+ (when (eq major-mode 'ebdb-mode)
+ (let* ((rec (ebdb-current-record))
+ (uuid (ebdb-record-uuid rec))
+ (name (ebdb-record-name rec))
+ (link (format "ebdb:uuid/%s" uuid)))
+ (org-store-link-props :type "ebdb" :name name
+ :link link :description name)
+ link)))
+
+(defun ebdb-org-open (link)
+ "Follow a EBDB link."
+ (let ((bits (split-string link "/" t))
+ records)
+ (if (string-match-p "^ebdb-field-" (car bits))
+ (message "Following field type links not implemented yet.")
+ (setq records
+ (pcase bits
+ (`("uuid" ,key) (list (ebdb-gethash key 'uuid)))
+ (`(,key) (ebdb-search (ebdb-records) key))
+ (`("mail" ,key) (ebdb-search (ebdb-records) nil nil key))
+ (`("phone" ,key) (ebdb-search (ebdb-records) nil nil nil nil key))
+ (`("address" ,key) (ebdb-search (ebdb-records) nil nil nil nil
nil key))
+ (_ 'unknown)))
+ (cond
+ ((eql records 'unknown) (message "Unknown field prefix: %s" (nth 1
bits)))
+ ((null records) (message "No records found"))
+ (t (ebdb-display-records records))))))
+
+(defun ebdb-org-export (path desc format)
+ "Create the export version of a EBDB link specified by PATH or DESC.
+If exporting to either HTML or LaTeX FORMAT the link will be
+italicized, in all other cases it is left unchanged."
+ (when (string= desc (format "ebdb:%s" path))
+ (setq desc path))
+ (cond
+ ((eq format 'html) (format "<i>%s</i>" desc))
+ ((eq format 'latex) (format "\\textit{%s}" desc))
+ ((eq format 'odt)
+ (format "<text:span text:style-name=\"Emphasis\">%s</text:span>" desc))
+ (t desc)))
+
+(provide 'ebdb-org)
+;;; ebdb-org.el ends here
diff --git a/ebdb-pgp.el b/ebdb-pgp.el
new file mode 100644
index 0000000..c6f6301
--- /dev/null
+++ b/ebdb-pgp.el
@@ -0,0 +1,199 @@
+;;; ebdb-pgp.el --- Interaction between EBDB and PGP -*- lexical-binding: t;
-*-
+
+;; Copyright (C) 2016 Free Software Foundation, Inc.
+
+;; Author: Eric Abrahamsen <address@hidden>
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; Interaction between EDBD and PGP encryption/signing. This file was
+;; copied from bbdb-pgp.el, originally written by Kevin Davidson and
+;; Gijs Hillenius.
+
+;;; Code:
+
+(require 'message)
+(require 'ebdb-com)
+
+(defcustom ebdb-pgp-field 'pgp-mail
+ "EBDB xfield holding the PGP action.
+If the recipient of a message has this xfield in his/her EBDB record,
+its value determines whether `ebdb-pgp' signs or encrypts the message.
+The value of this xfield should be one of the following symbols:
+ sign Sign the message
+ sign-query Query whether to sign the message
+ encrypt Encrypt the message
+ encrypt-query Query whether to encrypt the message
+If the xfield is absent use `ebdb-pgp-default'.
+See also info node `(message)security'."
+ :type '(symbol :tag "EBDB xfield")
+ :group 'ebdb-utilities-pgp)
+
+(defcustom ebdb-pgp-default nil
+ "Default action when sending a message and the recipients are not in EBDB.
+This should be one of the following symbols:
+ nil Do nothing
+ sign Sign the message
+ sign-query Query whether to sign the message
+ encrypt Encrypt the message
+ encrypt-query Query whether to encrypt the message
+See info node `(message)security'."
+ :type '(choice
+ (const :tag "Do Nothing" nil)
+ (const :tag "Encrypt" encrypt)
+ (const :tag "Query encryption" encrypt-query)
+ (const :tag "Sign" sign)
+ (const :tag "Query signing" sign-query))
+ :group 'ebdb-utilities-pgp)
+
+(defcustom ebdb-pgp-ranked-actions
+ '(encrypt-query sign-query encrypt sign)
+ "Ranked list of actions when sending a message.
+If a message has multiple recipients such that their EBDB records specify
+different actions for this message, `ebdb-pgp' will perform the action
+which appears first in `ebdb-pgp-ranked-actions'.
+This list should include the following four symbols:
+ sign Sign the message
+ sign-query Query whether to sign the message
+ encrypt Encrypt the message
+ encrypt-query Query whether to encrypt the message."
+ :type '(repeat (symbol :tag "Action"))
+ :group 'ebdb-utilities-pgp)
+
+(defcustom ebdb-pgp-headers '("To" "Cc")
+ "Message headers to look at."
+ :type '(repeat (string :tag "Message header"))
+ :group 'ebdb-utilities-pgp)
+
+(defcustom ebdb-pgp-method 'pgpmime
+ "Method for signing and encrypting messages.
+It should be one of the keys of `ebdb-pgp-method-alist'.
+The default methods include
+ pgp Add MML tags for PGP format
+ pgpauto Add MML tags for PGP-auto format
+ pgpmime Add MML tags for PGP/MIME
+ smime Add MML tags for S/MIME
+See info node `(message)security'."
+ :type '(choice
+ (const :tag "MML PGP" pgp)
+ (const :tag "MML PGP-auto" pgpauto)
+ (const :tag "MML PGP/MIME" pgpmime)
+ (const :tag "MML S/MIME" smime)
+ (symbol :tag "Custom"))
+ :group 'ebdb-utilities-pgp)
+
+(defcustom ebdb-pgp-method-alist
+ '((pgp mml-secure-message-sign-pgp
+ mml-secure-message-encrypt-pgp)
+ (pgpmime mml-secure-message-sign-pgpmime
+ mml-secure-message-encrypt-pgpmime)
+ (smime mml-secure-message-sign-smime
+ mml-secure-message-encrypt-smime)
+ (pgpauto mml-secure-message-sign-pgpauto
+ mml-secure-message-encrypt-pgpauto))
+ "Alist of methods for signing and encrypting a message with `ebdb-pgp'.
+Each method is a list (KEY SIGN ENCRYPT).
+The symbol KEY identifies the method. The function SIGN signs the message;
+the function ENCRYPT encrypts it. These functions take no arguments.
+The default methods include
+ pgp Add MML tags for PGP format
+ pgpauto Add MML tags for PGP-auto format
+ pgpmime Add MML tags for PGP/MIME
+ smime Add MML tags for S/MIME
+See info node `(message)security'."
+ :type '(repeat (list (symbol :tag "Key")
+ (symbol :tag "Sign method")
+ (symbol :tag "Encrypt method")))
+ :group 'ebdb-utilities-pgp)
+
+;;;###autoload
+(defun ebdb-read-xfield-pgp-mail (&optional init)
+ "Set `ebdb-pgp-field', requiring match with `ebdb-pgp-ranked-actions'."
+ (ebdb-read-string "PGP action: " init
+ (mapcar 'list ebdb-pgp-ranked-actions) t))
+
+;;;###autoload
+(defun ebdb-pgp ()
+ "Add PGP MML tags to a message according to the recipients' EBDB records.
+For all message recipients in `ebdb-pgp-headers', this grabs the action
+in `ebdb-pgp-field' of their EBDB records. If this proposes multiple actions,
+perform the action which appears first in `ebdb-pgp-ranked-actions'.
+If this proposes no action at all, use `ebdb-pgp-default'.
+The variable `ebdb-pgp-method' defines the method which is actually used
+for signing and encrypting.
+
+This command works with both `mail-mode' and `message-mode' to send
+signed or encrypted mail.
+
+To run this command automatically when sending a message,
+use `ebdb-initialize' with arg `pgp' to add this function
+to `message-send-hook' and `mail-send-hook'.
+Yet see info node `(message)Signing and encryption' why you
+might not want to rely for encryption on a hook function
+which runs just before the message is sent, that is, you might want
+to call the command `ebdb-pgp' manually, then call `mml-preview'."
+ (interactive)
+ (save-excursion
+ (save-restriction
+ (widen)
+ (message-narrow-to-headers)
+ (when mail-aliases
+ ;; (sendmail-sync-aliases) ; needed?
+ (expand-mail-aliases (point-min) (point-max)))
+ (let ((actions
+ (or (delq nil
+ (delete-dups
+ (mapcar
+ (lambda (record)
+ (ebdb-record-xfield-intern record ebdb-pgp-field))
+ (delete-dups
+ (apply 'nconc
+ (mapcar
+ (lambda (address)
+ (ebdb-message-search (car address)
+ (cadr address)))
+ (ebdb-extract-address-components
+ (mapconcat
+ (lambda (header)
+ (mail-fetch-field header nil t))
+ ebdb-pgp-headers ", ")
+ t)))))))
+ (and ebdb-pgp-default
+ (list ebdb-pgp-default)))))
+ (when actions
+ (widen) ; after analyzing the headers
+ (let ((ranked-actions ebdb-pgp-ranked-actions)
+ action)
+ (while ranked-actions
+ (if (memq (setq action (pop ranked-actions)) actions)
+ (cond ((or (eq action 'sign)
+ (and (eq action 'sign-query)
+ (y-or-n-p "Sign message? ")))
+ (funcall (nth 1 (assq ebdb-pgp-method
+ ebdb-pgp-method-alist)))
+ (setq ranked-actions nil))
+ ((or (eq action 'encrypt)
+ (and (eq action 'encrypt-query)
+ (y-or-n-p "Encrypt message? ")))
+ (funcall (nth 2 (assq ebdb-pgp-method
+ ebdb-pgp-method-alist)))
+ (setq ranked-actions nil)))))))))))
+
+(add-hook 'message-send-hook 'ebdb-pgp)
+(add-hook 'mail-send-hook 'ebdb-pgp)
+
+(provide 'ebdb-pgp)
+;;; ebdb-pgp.el ends here
diff --git a/ebdb-rmail.el b/ebdb-rmail.el
new file mode 100644
index 0000000..4f630cd
--- /dev/null
+++ b/ebdb-rmail.el
@@ -0,0 +1,71 @@
+;;; ebdb-rmail.el --- EBDB interface to Rmail -*- lexical-binding: t;
-*-
+
+;; Copyright (C) 2016 Free Software Foundation, Inc.
+
+;; Author: Eric Abrahamsen <address@hidden>
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; EBDB's interaction with the Rmail MUA.
+
+;;; Code:
+
+(require 'ebdb-com)
+(require 'ebdb-mua)
+(require 'rmail)
+(require 'rmailsum)
+(require 'mailheader)
+
+(defun ebdb/rmail-new-flag ()
+ "Returns t if the current message in buffer BUF is new."
+ (rmail-message-labels-p rmail-current-message ", ?\\(unseen\\),"))
+
+(defun ebdb/rmail-header (header)
+ "Pull HEADER out of Rmail header."
+ (with-current-buffer rmail-buffer
+ (if (fboundp 'rmail-get-header) ; Emacs 23
+ (rmail-get-header header)
+ (save-restriction
+ (with-no-warnings (rmail-narrow-to-non-pruned-header))
+ (mail-header (intern-soft (downcase header))
+ (mail-header-extract))))))
+
+(cl-defmethod ebdb-message-header ((header string)
+ &context (major-mode (eql rmail-mode)))
+ (ebdb/rmail-header header))
+
+(cl-defmethod ebdb-message-header ((header string)
+ &context (major-mode (eql
rmail-summary-mode)))
+ (ebdb/rmail-header header))
+
+(defun ebdb-insinuate-rmail ()
+ "Hook EBDB into RMAIL.
+Do not call this in your init file. Use `ebdb-initialize'."
+ ;; Do we need keybindings for more commands? Suggestions welcome.
+ ;; (define-key rmail-mode-map ":" 'ebdb-mua-display-records)
+ ;; (define-key rmail-mode-map "'" 'ebdb-mua-display-recipients)
+ (define-key rmail-mode-map ":" 'ebdb-mua-display-sender)
+ (define-key rmail-mode-map ";" 'ebdb-mua-edit-field-sender)
+ ;; (define-key rmail-mode-map ";" 'ebdb-mua-edit-field-recipients)
+ (define-key rmail-summary-mode-map ":" 'ebdb-mua-display-sender)
+ (define-key rmail-summary-mode-map ";" 'ebdb-mua-edit-field-sender))
+
+(add-hook 'rmail-mode-hook 'ebdb-insinuate-rmail)
+
+(add-hook 'rmail-show-message-hook 'ebdb-mua-auto-update)
+
+(provide 'ebdb-rmail)
+;;; ebdb-rmail.el ends here
diff --git a/ebdb-vcard.el b/ebdb-vcard.el
new file mode 100644
index 0000000..0eae940
--- /dev/null
+++ b/ebdb-vcard.el
@@ -0,0 +1,234 @@
+;;; ebdb-vcard.el --- Vcard export and import routine for EBDB -*-
lexical-binding: t; -*-
+
+;; Copyright (C) 2016 Free Software Foundation, Inc.
+
+;; Author: Eric Abrahamsen <address@hidden>
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; This file contains formatting and parsing functions used to export
+;; EBDB contacts to vcard format, and to create contacts from vcard
+;; files.
+
+;;; Code:
+
+(defclass ebdb-formatter-vcard (ebdb-formatter)
+ ((version-string
+ :type string
+ :allocation :class
+ :documentation "The string to insert for this formatter's
+ version."))
+ :abstract t
+ :documentation "Base formatter for VCard export.")
+
+(defclass ebdb-formatter-vcard-30 (ebdb-formatter-vcard)
+ ((version-string
+ :initform "3.0"))
+ :documentation "Formatter for VCard format 3.0.")
+
+(defclass ebdb-formatter-vcard-40 (ebdb-formatter-vcard)
+ ((version-string
+ :initform "4.0")
+ (coding-system :initform 'utf-8-emacs))
+ :documentation "Formatter for VCard format 4.0.")
+
+(defgroup ebdb-vcard nil
+ "Customization options for EBDB Vcard support."
+ :group 'ebdb)
+
+(defcustom ebdb-vcard-default-formatter
+ (make-instance 'ebdb-formatter-vcard-40
+ :object-name "VCard 4.0"
+ :combine nil
+ :collapse nil
+ :include '(ebdb-field-uuid
+ ebdb-field-timestamp
+ ebdb-field-mail
+ ebdb-field-url
+ ebdb-field-anniversary
+ ebdb-field-relation
+ ebdb-field-phone
+ ebdb-field-notes)
+ :header nil)
+ "The default formatter for vcard exportation."
+ :group 'ebdb-vcard
+ :type 'ebdb-formatter-vcard)
+
+
+(cl-defmethod ebdb-fmt-record ((f ebdb-formatter-vcard)
+ (r ebdb-record))
+ "Format a single record R in VCARD format."
+ ;; Because of the simplicity of the VCARD format, we only collect
+ ;; the fields, there's no need to sort or "process" them.
+ (let ((fields (ebdb-fmt-collect-fields f r))
+ header-fields body-fields)
+ (setq header-fields
+ (list (slot-value r 'name))
+ body-fields
+ (mapcar
+ (lambda (fld)
+ (cons (ebdb-fmt-field-label f fld 'normal r)
+ (ebdb-fmt-field f fld 'normal r)))
+ fields))
+ (concat
+ (format "BEGIN:VCARD\nVERSION:%s\n"
+ (slot-value f 'version-string))
+ (ebdb-fmt-record-header f r header-fields)
+ (ebdb-fmt-record-body f r body-fields)
+ "\nEND:VCARD\n")))
+
+(cl-defmethod ebdb-fmt-record-header ((f ebdb-formatter-vcard)
+ (r ebdb-record)
+ (fields list))
+ "Format the header of a VCARD record.
+
+VCARDs don't really have the concept of a \"header\", so this
+method is just responsible for formatting the record name."
+ (let ((name (car fields)))
+ (concat
+ (format "FN:%s\n" (ebdb-string name))
+ (format "N:%s\n"
+ (ebdb-fmt-field f name 'normal r)))))
+
+(cl-defmethod ebdb-fmt-record-body ((f ebdb-formatter-vcard)
+ (r ebdb-record)
+ (fields list))
+ (mapconcat
+ (lambda (f)
+ (format "%s:%s"
+ (car f) (cdr f)))
+ fields
+ "\n"))
+
+(cl-defmethod ebdb-fmt-record-body :around ((f ebdb-formatter-vcard-40)
+ (r ebdb-record-person)
+ (_fields list))
+ (let ((str (cl-call-next-method)))
+ (concat str "\nKIND:individual")))
+
+(cl-defmethod ebdb-fmt-record-body :around ((f ebdb-formatter-vcard-40)
+ (r ebdb-record-organization)
+ (_fields list))
+ (let ((str (cl-call-next-method)))
+ (concat str "\nKIND:org")))
+
+(cl-defmethod ebdb-fmt-field ((f ebdb-formatter-vcard)
+ (field ebdb-field)
+ _style
+ _record)
+ (ebdb-string field))
+
+(cl-defmethod ebdb-fmt-field-label ((f ebdb-formatter-vcard)
+ (field ebdb-field)
+ style
+ record)
+ (upcase (cl-call-next-method f field style record)))
+
+(cl-defmethod ebdb-fmt-field-label ((f ebdb-formatter-vcard)
+ (field ebdb-field-timestamp)
+ _style
+ _record)
+ "REV")
+
+(cl-defmethod ebdb-fmt-field-label ((f ebdb-formatter-vcard)
+ (field ebdb-field-notes)
+ _style
+ _record)
+ "NOTE")
+
+(cl-defmethod ebdb-fmt-field-label ((f ebdb-formatter-vcard)
+ (field ebdb-field-creation-date)
+ _style
+ _record)
+ "X-CREATION-DATE")
+
+(cl-defmethod ebdb-fmt-field ((f ebdb-formatter-vcard)
+ (mail ebdb-field-mail)
+ _style
+ _record)
+ (slot-value mail 'mail))
+(cl-defmethod ebdb-fmt-field ((_f ebdb-formatter-vcard)
+ (ts ebdb-field-timestamp)
+ _style
+ _record)
+ (format-time-string ":%Y%m%dT%H%M%S%z" (slot-value ts 'timestamp) t))
+
+(cl-defmethod ebdb-fmt-field ((f ebdb-formatter-vcard)
+ (name ebdb-field-name-complex)
+ _style
+ _record)
+ (with-slots (surname given-names prefix suffix) name
+ (format
+ "%s;%s;%s;%s"
+ (or surname "")
+ (if given-names (mapconcat #'identity given-names ","))
+ (or prefix "")
+ (or suffix ""))))
+
+(cl-defmethod ebdb-fmt-field-label ((f ebdb-formatter-vcard)
+ (field ebdb-field-uuid)
+ _style
+ _record)
+ "UID:urn:uuid")
+
+(cl-defmethod ebdb-fmt-field-label ((f ebdb-formatter-vcard)
+ (mail ebdb-field-mail)
+ _style
+ _record)
+ (with-slots (priority) mail
+ (format
+ "EMAIL;INTERNET%s"
+ (if (eql priority 'primary)
+ ";PREF=1"
+ ""))))
+
+(cl-defmethod ebdb-fmt-field-label ((f ebdb-formatter-vcard)
+ (phone ebdb-field-phone)
+ _style
+ _record)
+ (format "TEL;TYPE=%s" (slot-value phone 'object-name)))
+
+(cl-defmethod ebdb-fmt-field-label ((f ebdb-formatter-vcard)
+ (rel ebdb-field-relation)
+ _style
+ _record)
+ (format "RELATED;TYPE=%s" (slot-value rel 'object-name)))
+
+(cl-defmethod ebdb-fmt-field-label ((f ebdb-formatter-vcard)
+ (url ebdb-field-url)
+ _style
+ _record)
+ (format "URL;TYPE=%s" (slot-value url 'object-name)))
+
+(cl-defmethod ebdb-fmt-field ((f ebdb-formatter-vcard)
+ (rel ebdb-field-relation)
+ _style
+ _record)
+ (format "urn:uuid:%s" (slot-value rel 'rel-uuid)))
+
+(cl-defmethod ebdb-fmt-field-label ((f ebdb-formatter-vcard)
+ (ann ebdb-field-anniversary)
+ _style
+ _record)
+ (let* ((label (slot-value ann 'object-name))
+ (label-string
+ (if (string= label "birthday")
+ "BDAY"
+ (format "ANNIVERSARY;TYPE=%s" label))))
+ (format "%s;CALSCALE=%s" label-string (slot-value ann 'calendar))))
+
+(provide 'ebdb-vcard)
+;;; ebdb-vcard.el ends here
diff --git a/ebdb-vm.el b/ebdb-vm.el
new file mode 100644
index 0000000..830549a
--- /dev/null
+++ b/ebdb-vm.el
@@ -0,0 +1,363 @@
+;;; ebdb-vm.el --- EBDB interface to VM -*- lexical-binding: t;
-*-
+
+;; Copyright (C) 2016 Free Software Foundation, Inc.
+
+;; Author: Eric Abrahamsen <address@hidden>
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; EBDB's interface to VM.
+
+;;; Code:
+
+(require 'ebdb-com)
+(require 'ebdb-mua)
+(require 'vm-autoloads)
+(require 'vm)
+(require 'vm-motion)
+(require 'vm-summary)
+(require 'vm-mime)
+(require 'vm-vars)
+(require 'vm-macro)
+(require 'vm-message)
+(require 'vm-misc)
+
+(defgroup ebdb-mua-vm nil
+ "VM-specific EBDB customizations"
+ :group 'ebdb-mua)
+(put 'ebdb-mua-vm 'custom-loads '(ebdb-vm))
+
+(defun ebdb/vm-header (header)
+ (save-current-buffer
+ (vm-select-folder-buffer)
+ (vm-check-for-killed-summary)
+ (vm-error-if-folder-empty)
+ (let ((enable-local-variables t))
+ (vm-get-header-contents (car vm-message-pointer)
+ (concat header ":")))))
+
+
+;; By Alastair Burt <address@hidden>
+;; vm 5.40 and newer support a new summary format, %U<letter>, to call
+;; a user-provided function. Use "%-17.17UB" instead of "%-17.17F" to
+;; have your VM summary buffers display EBDB's idea of the sender's full
+;; name instead of the name (or lack thereof) in the message itself.
+
+;; RW: this is a VM-specific version of `ebdb-mua-summary-unify'
+;; which respects `vm-summary-uninteresting-senders'.
+
+(defun vm-summary-function-B (m)
+ "For VM message M return the EBDB name of the sender.
+Respect `vm-summary-uninteresting-senders'."
+ (if vm-summary-uninteresting-senders
+ (if (let ((case-fold-search t))
+ (string-match vm-summary-uninteresting-senders (vm-su-from m)))
+ (concat vm-summary-uninteresting-senders-arrow
+ (or (ebdb/vm-alternate-full-name (vm-su-to m))
+ (vm-decode-mime-encoded-words-in-string
+ (vm-su-to-names m))))
+ (or (ebdb/vm-alternate-full-name (vm-su-from m))
+ (vm-su-full-name m)))
+ (or (ebdb/vm-alternate-full-name (vm-su-from m))
+ (vm-decode-mime-encoded-words-in-string (vm-su-full-name m)))))
+
+(defun ebdb/vm-alternate-full-name (address)
+ (if address
+ (let* ((data (ebdb-extract-address-components address))
+ (record (car (ebdb-message-search (car data) (cadr data)))))
+ (if record
+ (or (ebdb-record-xfield record 'mail-name)
+ (ebdb-record-name record))))))
+
+
+
+;;;###autoload
+(defcustom ebdb/vm-auto-folder-headers '("From:" "To:" "CC:")
+ "The headers used by `ebdb/vm-auto-folder'.
+The order in this list is the order how matching will be performed."
+ :group 'ebdb-mua-vm
+ :type '(repeat (string :tag "header name")))
+
+;;;###autoload
+(defcustom ebdb/vm-auto-folder-field 'vm-folder
+ "The xfield which `ebdb/vm-auto-folder' searches for."
+ :group 'ebdb-mua-vm
+ :type 'symbol)
+
+;;;###autoload
+(defcustom ebdb/vm-virtual-folder-field 'vm-virtual
+ "The xfield which `ebdb/vm-virtual-folder' searches for."
+ :group 'ebdb-mua-vm
+ :type 'symbol)
+
+;;;###autoload
+(defcustom ebdb/vm-virtual-real-folders nil
+ "Real folders used for defining virtual folders.
+If nil use `vm-primary-inbox'."
+ :group 'ebdb-mua-vm
+ :type '(choice (const :tag "Use vm-primary-inbox" nil)
+ (repeat (string :tag "Real folder"))))
+
+;;;###autoload
+(defun ebdb/vm-auto-folder ()
+ "Add entries to `vm-auto-folder-alist' for the records in EBDB.
+For each record that has a `vm-folder' xfield, add an element
+\(MAIL-REGEXP . FOLDER-NAME) to `vm-auto-folder-alist'.
+The element gets added to the sublists of `vm-auto-folder-alist'
+specified in `ebdb/vm-auto-folder-headers'.
+MAIL-REGEXP matches the mail addresses of the EBDB record.
+The value of the `vm-folder' xfield becomes FOLDER-NAME.
+The `vm-folder' xfield is defined via `ebdb/vm-auto-folder-field'.
+
+Add this function to `ebdb-before-save-hook' and your .vm."
+ (interactive)
+ (let ((records ; Collect EBDB records with a vm-folder xfield.
+ (delq nil
+ (mapcar (lambda (r)
+ (if (ebdb-record-xfield r ebdb/vm-auto-folder-field)
+ r))
+ (ebdb-records))))
+ folder-list folder-name mail-regexp)
+ ;; Add (MAIL-REGEXP . FOLDER-NAME) pair to this sublist of
`vm-auto-folder-alist'
+ (dolist (header ebdb/vm-auto-folder-headers)
+ ;; create the folder-list in `vm-auto-folder-alist' if it does not exist
+ (unless (setq folder-list (assoc header vm-auto-folder-alist))
+ (push (list header) vm-auto-folder-alist)
+ (setq folder-list (assoc header vm-auto-folder-alist)))
+ (dolist (record records)
+ ;; Ignore everything past a comma
+ (setq folder-name (car (ebdb-record-xfield-split
+ record ebdb/vm-auto-folder-field))
+ ;; quote all the mail addresses for the record and join them
+ mail-regexp (regexp-opt (ebdb-record-mail record)))
+ ;; In general, the values of xfields are strings (required for
editing).
+ ;; If we could set the value of `ebdb/vm-auto-folder-field' to a
symbol,
+ ;; it could be a function that is called with arg record to calculate
+ ;; the value of folder-name.
+ ;; (if (functionp folder-name)
+ ;; (setq folder-name (funcall folder-name record)))
+ (unless (or (string= "" mail-regexp)
+ (assoc mail-regexp folder-list))
+ ;; Convert relative into absolute file names using
+ ;; `vm-folder-directory'.
+ (unless (file-name-absolute-p folder-name)
+ (setq folder-name (abbreviate-file-name
+ (expand-file-name folder-name
+ vm-folder-directory))))
+ ;; nconc modifies the list in place
+ (nconc folder-list (list (cons mail-regexp folder-name))))))))
+
+;;;###autoload
+(defun ebdb/vm-virtual-folder ()
+ "Create `vm-virtual-folder-alist' according to the records in EBDB.
+For each record that has a `vm-virtual' xfield, add or modify the
+corresponding VIRTUAL-FOLDER-NAME element of `vm-virtual-folder-alist'.
+
+ (VIRTUAL-FOLDER-NAME ((FOLDER-NAME ...)
+ (author-or-recipient MAIL-REGEXP)))
+
+VIRTUAL-FOLDER-NAME is the first element of the `vm-virtual' xfield.
+FOLDER-NAME ... are either the remaining elements of the `vm-virtual' xfield,
+or `ebdb/vm-virtual-real-folders' or `vm-primary-inbox'.
+MAIL-REGEXP matches the mail addresses of the EBDB record.
+The `vm-virtual' xfield is defined via `ebdb/vm-virtual-folder-field'.
+
+Add this function to `ebdb-before-save-hook' and your .vm."
+ (interactive)
+ (let (real-folders mail-regexp folder val tmp)
+ (dolist (record (ebdb-records))
+ (when (setq val (ebdb-record-xfield-split
+ record ebdb/vm-virtual-folder-field))
+ (setq mail-regexp (regexp-opt (ebdb-record-mail record)))
+ (unless (string= "" mail-regexp)
+ (setq folder (car val)
+ real-folders (mapcar
+ (lambda (f)
+ (if (file-name-absolute-p f) f
+ (abbreviate-file-name
+ (expand-file-name f vm-folder-directory))))
+ (or (cdr val) ebdb/vm-virtual-real-folders
+ (list vm-primary-inbox)))
+ ;; Either extend the definition of an already defined
+ ;; virtual folder or define a new virtual folder
+ tmp (or (assoc folder vm-virtual-folder-alist)
+ (car (push (list folder) vm-virtual-folder-alist)))
+ tmp (or (assoc real-folders (cdr tmp))
+ (car (setcdr tmp (cons (list real-folders)
+ (cdr tmp)))))
+ tmp (or (assoc 'author-or-recipient (cdr tmp))
+ (car (setcdr tmp (cons (list 'author-or-recipient)
+ (cdr tmp))))))
+ (cond ((not (cdr tmp))
+ (setcdr tmp (list mail-regexp)))
+ ((not (string-match (regexp-quote mail-regexp)
+ (cadr tmp)))
+ (setcdr tmp (list (concat (cadr tmp) "\\|"
mail-regexp))))))))))
+
+
+;; RW: Adding custom labels to VM messages allows one to create,
+;; for example, virtual folders. The following code creates
+;; the required labels in a rather simplistic way, checking merely
+;; whether the sender's EBDB record uses a certain mail alias.
+;; (Note that `ebdb/vm-virtual-folder' can achieve the same goal,
+;; yet this requires a second xfield that must be kept up-to-date, too.)
+;; To make auto labels yet more useful, the code could allow more
+;; sophisticated schemes, too. Are there real-world applications
+;; for this?
+
+;;; Howard Melman, contributed Jun 16 2000
+(defcustom ebdb/vm-auto-add-label-list nil
+ "List used by `ebdb/vm-auto-add-label' to automatically label VM messages.
+Its elements may be strings used both as the xfield value to check for
+and as the label to apply to the message.
+If an element is a cons pair (VALUE . LABEL), VALUE is the xfield value
+to search for and LABEL is the label to apply."
+ :group 'ebdb-mua-vm
+ :type 'list)
+
+(defcustom ebdb/vm-auto-add-label-field ebdb-mail-alias-field
+ "Xfields used by `ebdb/vm-auto-add-label' to automatically label messages.
+This is either a single EBDB xfield or a list of xfields that
+`ebdb/vm-auto-add-label' uses to check for labels to apply to a message.
+Defaults to `ebdb-mail-alias-field' which defaults to `mail-alias'."
+ :group 'ebdb-mua-vm
+ :type '(choice symbol list))
+
+(defun ebdb/vm-auto-add-label (record)
+ "Automatically add labels to VM messages.
+Add this to `ebdb-notice-record-hook' to check the messages noticed by EBDB.
+If the value of `ebdb/vm-auto-add-label-field' in the sender's EBDB record
+matches a value in `ebdb/vm-auto-add-label-list' then a VM label will be added
+to the message. Such VM labels can be used, e.g., to mark messages via
+`vm-mark-matching-messages' or to define virtual folders via
+`vm-create-virtual-folder'
+
+Typically `ebdb/vm-auto-add-label-field' and `ebdb/vm-auto-add-label-list'
+refer to mail aliases FOO used with multiple records. This adds a label FOO
+to all incoming messages matching FOO. Then VM can create a virtual folder
+for these messages. The concept of combining multiple recipients of an
+outgoing message in one mail alias thus gets extended to incoming messages
+from different senders."
+ ;; This could go into `vm-arrived-message-hook' to check messages only once.
+ (if (eq major-mode 'vm-mode)
+ (let* ((xvalues
+ ;; Inspect the relevant fields of RECORD
+ (append
+ (mapcar (lambda (field)
+ (ebdb-record-xfield-split record field))
+ (cond ((listp ebdb/vm-auto-add-label-field)
+ ebdb/vm-auto-add-label-field)
+ ((symbolp ebdb/vm-auto-add-label-field)
+ (list ebdb/vm-auto-add-label-field))
+ (t (error "Bad value for
ebdb/vm-auto-add-label-field"))))))
+ ;; Collect the relevant labels from `ebdb/vm-auto-add-label-list'
+ (labels
+ (delq nil
+ (mapcar (lambda (l)
+ (cond ((stringp l)
+ (if (member l xvalues)
+ l))
+ ((and (consp l)
+ (stringp (car l))
+ (stringp (cdr l)))
+ (if (member (car l) xvalues)
+ (cdr l)))
+ (t
+ (error "Malformed
ebdb/vm-auto-add-label-list"))))
+ ebdb/vm-auto-add-label-list))))
+ (if labels
+ (vm-add-message-labels
+ (mapconcat 'identity labels " ") 1)))))
+
+
+
+;;; If vm has set up its various modes using `define-derived-mode' we
+;;; should be able to collapse all these various methods into one that
+;;; checks `derived-mode-p'. Check how to do that with &context.
+
+(cl-defmethod ebdb-message-header ((header string)
+ &context (major-mode (eql vm-mode)))
+ (ebdb/vm-header header))
+
+(cl-defmethod ebdb-message-header ((header string)
+ &context (major-mode (eql vm-virtual-mode)))
+ (ebdb/vm-header header))
+
+(cl-defmethod ebdb-message-header ((header string)
+ &context (major-mode (eql vm-summary-mode)))
+ (ebdb/vm-header header))
+
+(cl-defmethod ebdb-message-header ((header string)
+ &context (major-mode (eql
vm-presentation-mode)))
+ (ebdb/vm-header header))
+
+(cl-defmethod ebdb-mua-prepare-article (&context (major-mode (eql vm-mode)))
+ (vm-follow-summary-cursor))
+
+(cl-defmethod ebdb-mua-prepare-article (&context (major-mode (eql
vm-virtual-mode)))
+ (vm-follow-summary-cursor))
+
+(cl-defmethod ebdb-mua-prepare-article (&context (major-mode (eql
vm-summary-mode)))
+ (vm-follow-summary-cursor))
+
+(cl-defmethod ebdb-mua-prepare-article (&context (major-mode (eql
vm-presentation-mode)))
+ (vm-follow-summary-cursor))
+
+;;;###autoload
+(defun ebdb-insinuate-vm ()
+ "Hook EBDB into VM.
+Do not call this in your init file. Use `ebdb-initialize'."
+ (define-key vm-mode-map ":" 'ebdb-mua-display-records)
+ (define-key vm-mode-map "`" 'ebdb-mua-display-sender)
+ (define-key vm-mode-map "'" 'ebdb-mua-display-recipients)
+ (define-key vm-mode-map ";" 'ebdb-mua-edit-field-sender)
+ ;; Do we need keybindings for more commands? Suggestions welcome.
+ ;; (define-key vm-mode-map "'" 'ebdb-mua-edit-field-recipients)
+ (define-key vm-mode-map "/" 'ebdb)
+ ;; `mail-mode-map' is the parent of `vm-mail-mode-map'.
+ ;; So the following is also done by `ebdb-insinuate-mail'.
+ (if (and ebdb-complete-mail (boundp 'vm-mail-mode-map))
+ (define-key vm-mail-mode-map "\M-\t" 'ebdb-complete-mail))
+
+ ;; Set up user field for use in `vm-summary-format'
+ ;; (1) Big solution: use whole name
+ (if ebdb-mua-summary-unify-format-letter
+ (fset (intern (concat "vm-summary-function-"
+ ebdb-mua-summary-unify-format-letter))
+ (lambda (m) (ebdb-mua-summary-unify
+ ;; VM does not give us the original From header.
+ ;; So we have to work backwards.
+ (let ((name (vm-decode-mime-encoded-words-in-string
+ (vm-su-interesting-full-name m)))
+ (mail (vm-su-from m)))
+ (if (string= name mail) mail
+ (format "\"%s\" <%s>" name mail)))))))
+
+ ;; (2) Small solution: a mark for messages whos sender is in EBDB.
+ (if ebdb-mua-summary-mark-format-letter
+ (fset (intern (concat "vm-summary-function-"
+ ebdb-mua-summary-mark-format-letter))
+ ;; VM does not give us the original From header.
+ ;; So we assume that the mail address is sufficient to identify
+ ;; the EBDB record of the sender.
+ (lambda (m) (ebdb-mua-summary-mark (vm-su-from m))))))
+
+(eval-after-load "vm" '(ebdb-insinuate-vm))
+
+(add-hook 'vm-select-message-hook 'ebdb-mua-auto-update)
+
+(provide 'ebdb-vm)
+;;; ebdb-vm.el ends here
diff --git a/ebdb.el b/ebdb.el
new file mode 100644
index 0000000..ee6586b
--- /dev/null
+++ b/ebdb.el
@@ -0,0 +1,4450 @@
+;;; ebdb.el --- Contact management package -*- lexical-binding: t;
-*-
+
+;; Copyright (C) 2016 Free Software Foundation, Inc.
+
+;; Version: 0.1
+;; Package-Requires: ((cl-lib "0.5") (seq "2.15"))
+
+;; Maintainer: Eric Abrahamsen <address@hidden>
+
+;; Author: Eric Abrahamsen <address@hidden>
+;; Keywords: convenience mail
+
+;; URL: https://github.com/girzel/ebdb
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; This package began as a port of the Insidious Big Brother Database
+;; (by Jamie Zawinski and Roland Winkler) using EIEIO, Emacs' newish
+;; object-orientation library. Eventually it developed to the point
+;; where a separate package seemed to make most sense. But the basic
+;; behavior of the package, and the look of the *EBDB* buffer, are
+;; still very much indebted to the original library. Some of the
+;; original files have been directly copied over and renamed -- where
+;; applicable, the names of the authors of the original libraries have
+;; been noted.
+
+;; This file contains the basic data structures and behavior for EBDB,
+;; including the class definitions for databases, records, and fields.
+
+;;; Code:
+
+(require 'timezone)
+(require 'cl-lib)
+(require 'seq)
+(require 'pcase)
+(require 'eieio)
+(require 'eieio-base)
+(require 'eieio-opt)
+
+(eval-when-compile ; pacify the compiler.
+ (autoload 'widget-group-match "wid-edit")
+ (autoload 'ebdb-migrate "ebdb-migrate")
+ (autoload 'ebdb-do-records "ebdb-com")
+ (autoload 'ebdb-append-display-p "ebdb-com")
+ (autoload 'ebdb-toggle-records-layout "ebdb-com")
+ (autoload 'ebdb-dwim-mail "ebdb-com")
+ (autoload 'ebdb-spec-prefix "ebdb-com")
+ (autoload 'ebdb-completing-read-records "ebdb-com")
+ (autoload 'mail-position-on-field "sendmail")
+ (autoload 'vm-select-folder-buffer "vm-folder")
+ (autoload 'eieio-customize-object "eieio-custom")
+ ;; cannot use autoload for variables...
+ (defvar message-mode-map) ;; message.el
+ (defvar mail-mode-map) ;; sendmail.el
+ (defvar gnus-article-buffer)) ;; gnus-art.el
+
+;; These are the most important internal variables, holding EBDB's
+;; data structures.
+
+(defvar ebdb-db-list nil
+ "The list of currently-loaded EBDB databases.")
+
+(defvar ebdb-record-tracker nil
+ "A list of all the loaded records")
+
+(defvar ebdb-seen-uuids nil
+ "A list of all previously-loaded UUIDs.")
+
+(defvar ebdb-hashtable (make-hash-table :test 'equal)
+ "Hash table for EBDB records.
+Hashes the fields first-last-name, last-first-name, organization, aka,
+and mail.")
+
+(defvar ebdb-org-hashtable (make-hash-table :size 500 :test 'equal)
+ "Hash table holding relationships between organizations and
+ member records.
+
+Keys are string UUIDs of organizations. Values are lists
+of (record-uuid . role-field). Hashtable entries are created
+and deleted by the `ebdb-init' and `ebdb-delete' methods of the
+`ebdb-field-role' field class.")
+
+;;; Internal variables
+(eval-and-compile
+ (defvar ebdb-debug t
+ "Enable debugging if non-nil during compile time.
+You really should not disable debugging. But it will speed things up."))
+
+(defconst ebdb-file-coding-system 'utf-8
+ "Coding system used for reading and writing `ebdb-file'.")
+
+(defvar ebdb-version "e"
+ "EBDB version.")
+
+(defvar ebdb-version-date "October 15, 2016"
+ "Date this version of EBDB was released.")
+
+(defvar ebdb-mail-aliases-need-rebuilt nil
+ "Non-nil if mail aliases need to be rebuilt.")
+
+(defvar ebdb-silent-internal nil
+ "Bind this to t to quiet things down - do not set it.
+See also `ebdb-silent'.")
+
+;; Custom groups
+
+(defgroup ebdb-eieio nil
+ "Options for an EIEIO version of EBDB."
+ :group 'ebdb)
+
+(defcustom ebdb-sources "~/.emacs.d/ebdb"
+ "User option specifying where EBDB contacts should be loaded
+from. It can be a single element, or a list of multiple
+elements. If an element is a string, it is treated as a
+filename, and used to create an instance of `ebdb-db-file'.
+
+Elements can also be instances of subclasses of `ebdb-db'.
+Currently, the only subclass is `ebdb-db-file', though you can
+create your own. When EBDB is loaded, the `ebdb-db-load' method
+will be called on each of class instances."
+ :group 'ebdb-eieio
+ :type 'string)
+
+(defcustom ebdb-auto-merge-records nil
+ "If t, EBDB will automatically merge multiple records with the
+same UUID.
+
+If you are using multiple databases, and intend to keep some
+records in more than one database at once, you can set this to t
+to have EBDB treat records with identical UUIDs as \"the same\"
+record, and merge them automatically when the databases are
+loaded. If it is nil, you'll be prompted to do an interactive
+merge.
+
+Merging is currently \"dumb\", ie the record with the older
+timestamp is essentially deleted and replaced by the newer.
+Future merging strategies may be smarter."
+ :group 'ebdb-eieio
+ :type 'boolean)
+
+(defcustom ebdb-default-record-class 'ebdb-record-person
+ "The default class to use for new records."
+ :group 'ebdb-eieio
+ :type 'class)
+
+(defcustom ebdb-default-name-class 'ebdb-field-name-complex
+ "The default name class to use for person records.
+
+Organization names are currently hard-coded to use
+`ebdb-field-name-simple'."
+ :group 'ebdb-eieio
+ :type 'class)
+
+(defcustom ebdb-default-mail-class 'ebdb-field-mail
+ "The default class to use for mail fields."
+ :group 'ebdb-eieio
+ :type 'class)
+
+(defcustom ebdb-default-phone-class 'ebdb-field-phone
+ "The default class to use for phone fields."
+ :group 'ebdb-eieio
+ :type 'class)
+
+(defcustom ebdb-default-address-class 'ebdb-field-address
+ "The default class to use for address fields."
+ :group 'ebdb-eieio
+ :type 'class)
+
+(defcustom ebdb-default-notes-class 'ebdb-field-notes
+ "The default class to use for notes fields."
+ :group 'ebdb-eieio
+ :type 'class)
+
+(defgroup ebdb nil
+ "The Insidious Big Brother Database."
+ :group 'news
+ :group 'mail)
+
+(defgroup ebdb-record-edit nil
+ "Variables that affect the editing of EBDB records"
+ :group 'ebdb)
+
+(defgroup ebdb-sendmail nil
+ "Variables that affect sending mail."
+ :group 'ebdb)
+
+(defgroup ebdb-utilities nil
+ "Customizations for EBDB Utilities"
+ :group 'ebdb)
+
+(defgroup ebdb-utilities-dialing nil
+ "EBDB Customizations for phone number dialing"
+ :group 'ebdb)
+
+(defgroup ebdb-utilities-print nil
+ "Customizations for printing the EBDB."
+ :group 'ebdb)
+(put 'ebdb-utilities-print 'custom-loads '(ebdb-print))
+
+(defgroup ebdb-utilities-anniv nil
+ "Customizations for EBDB Anniversaries"
+ :group 'ebdb-utilities)
+(put 'ebdb-utilities-anniv 'custom-loads '(ebdb-anniv))
+
+(defgroup ebdb-utilities-ispell nil
+ "Customizations for EBDB ispell interface"
+ :group 'ebdb-utilities)
+(put 'ebdb-utilities-ispell 'custom-loads '(ebdb-ispell))
+
+(defgroup ebdb-utilities-snarf nil
+ "Customizations for EBDB snarf"
+ :group 'ebdb-utilities)
+(put 'ebdb-utilities-snarf 'custom-loads '(ebdb-snarf))
+
+(defgroup ebdb-utilities-pgp nil
+ "Customizations for EBDB pgp"
+ :group 'ebdb-utilities)
+(put 'ebdb-utilities-pgp 'custom-loads '(ebdb-pgp))
+
+(defgroup ebdb-utilities-sc nil
+ "Customizations for using Supercite with the EBDB."
+ :group 'ebdb-utilities
+ :prefix "ebdb-sc")
+(put 'ebdb-utilities-sc 'custom-loads '(ebdb-sc))
+
+;;; Customizable variables
+(defcustom ebdb-image nil
+ "The default method for displaying record images.
+
+If a record is given a `ebdb-field-image' field, the value of
+that field specifies how or where to find the image for the
+record. This option provides a default for that value.
+
+If the field value is `name' or `fl-name', the first and last
+name of the record are used as file name. If it is `lf-name',
+the last and first name of the record are used as file name.
+
+If it is a string, that string is assumed to be a filename and
+the file is searched in the directories in `ebdb-image-path'.
+File name suffixes are appended according to
+`ebdb-image-suffixes'. See `locate-file'.
+
+If it is nil, the method `ebdb-field-image-function' will be
+called with two arguments: the image field and the record. The
+function should return either a filename, or actual image data."
+ :group 'ebdb-record-edit
+ :type '(choice (const :tag "Use built-in function" nil)
+ (const name)
+ (const fl-name)
+ (const lf-name)))
+
+(defcustom ebdb-uuid-function "uuidgen"
+ "Function used for creating a UUID for records.
+
+If a string, assume a system executable. If a symbol, assume an
+elisp function for creating UUIDs. For instance, `org-id-uuid'
+is a good candidate."
+ :group 'ebdb
+ :type '(or string symbol))
+
+(defcustom ebdb-record-self nil
+ "The UUID of the record representing the user.
+
+See the docstring of `ebdb-user-mail-address-re' for possible uses."
+ :group 'ebdb
+ :type 'string)
+
+(defcustom ebdb-country-list nil
+ "A list of country names known to EBDB.
+
+This is a list of simple strings, which do not change EBDB's
+behavior in any way. You can also require the \"ebdb-i18n\"
+library for more internationally-aware functionality, in which
+case this variable will be ignored."
+ :group 'ebdb
+ :type '(list-of string))
+
+(defcustom ebdb-auto-revert nil
+ "If t revert unchanged database without querying.
+
+If t and a database file has changed on disk, while the database
+has not been modified inside Emacs, revert the database
+automatically. If nil or the database has been changed inside
+Emacs, always query before reverting." :group 'ebdb :type
+'(choice (const :tag "Revert unchanged database without querying"
+t)
+ (const :tag "Ask before reverting database" nil)))
+
+(defcustom ebdb-before-load-hook nil
+ "Hook run before loading databases."
+ :group 'ebdb
+ :type 'hook)
+
+(defcustom ebdb-after-load-hook nil
+ "Hook run after loading databases."
+ :group 'ebdb
+ :type 'hook)
+
+(defvar ebdb-create-hook nil
+ "*Hook run each time a new EBDB record is created.
+Run with one argument, the new record. This is called before the record is
+added to the database, followed by a call of `ebdb-change-hook'.
+
+If a record has been created by analyzing a mail message, hook functions
+can use the variable `ebdb-update-records-address' to determine the header
+and class of the mail address according to `ebdb-message-headers'.")
+
+(defvar ebdb-change-hook nil
+ "*Hook run each time a EBDB record is changed.
+Run with one argument, the record. This is called before the database
+is modified. If a new ebdb record is created, `ebdb-create-hook' is called
+first, followed by a call of this hook.")
+
+(defcustom ebdb-time-format "%Y-%m-%d %T %z"
+ "The EBDB time stamp format. Used for human-readable display
+of timestamp values."
+ :group 'ebdb
+ :type 'string)
+
+(defcustom ebdb-after-change-hook nil
+ "Hook run each time a EBDB record is changed.
+Run with one argument, the record. This is called after the database
+is modified. So if you want to modify a record when it is created or changed,
+use instead `ebdb-create-hook' and / or `ebdb-change-hook'."
+ :group 'ebdb
+ :type 'hook)
+
+;; These two hooks could actually be done away with, and replaced by
+;; method overloads on `ebdb-db-load'. But users will probably be
+;; more familiar with hooks than with method overloading.
+(defcustom ebdb-before-load-db-hook nil
+ "Hook run before each database is loaded.
+Run with one argument, the database being loaded."
+ :group 'ebdb
+ :type 'hook)
+
+(defcustom ebdb-after-load-db-hook nil
+ "Hook run after each database is loaded.
+Run with one argument, the database being loaded."
+ :group 'ebdb
+ :type 'hook)
+
+(defcustom ebdb-initialize-hook nil
+ "Normal hook run after the EBDB initialization function `ebdb-initialize'."
+ :group 'ebdb
+ :type 'hook)
+
+(defcustom ebdb-mode-hook nil
+ "Normal hook run when the *EBDB* buffer is created."
+ :group 'ebdb
+ :type 'hook)
+
+(defcustom ebdb-silent nil
+ "If t, EBDB suppresses all its informational messages and queries.
+Be very very certain you want to set this to t, because it will suppress
+queries to alter record names, assign names to addresses, etc.
+Lisp Hackers: See also `ebdb-silent-internal'."
+ :group 'ebdb
+ :type '(choice (const :tag "Run silently" t)
+ (const :tag "Disable silent running" nil)))
+
+(defcustom ebdb-info-file nil
+ "Location of the ebdb info file, if it's not in the standard place."
+ :group 'ebdb
+ :type '(choice (const :tag "Standard location" nil)
+ (file :tag "Nonstandard location")))
+
+(defvar ebdb-update-unchanged-records nil
+ "If non-nil update unchanged records in the database.
+Normally calls of `ebdb-change-hook' and updating of a record are suppressed,
+if an editing command did not really change the record. Bind this to t
+if you want to call `ebdb-change-hook' and update the record unconditionally.")
+
+(defvar ebdb-street-list nil
+ "List of streets known to EBDB.")
+
+(defvar ebdb-locality-list nil
+ "List of localities (towns or cities) known to EBDB.")
+
+(defvar ebdb-region-list nil
+ "List of regions (states or provinces) known to EBDB.")
+
+(defvar ebdb-postcode-list nil
+ "List of post codes known to EBDB.")
+
+;;; Define some of our own errors. A few of these should never be
+;;; shown to the user, they're for internal flow control.
+
+;; Error parent
+(define-error 'ebdb-error "EBDB error")
+
+(define-error 'ebdb-duplicate-uuid "Duplicate EBDB UUID" 'ebdb-error)
+
+(define-error 'ebdb-unsynced-db "EBDB DB unsynced" 'ebdb-error)
+
+(define-error 'ebdb-disabled-db "EBDB DB disabled" 'ebdb-error)
+
+(define-error 'ebdb-readonly-db "EBDB DB read-only" 'ebdb-error)
+
+(define-error 'ebdb-unacceptable-field "EBDB record cannot accept field"
'ebdb-error)
+
+(define-error 'ebdb-empty "Empty value" 'ebdb-error)
+
+(define-error 'ebdb-unparseable "Unparseable value" 'ebdb-error)
+
+;;; Utility functions and macros
+
+;;;###autoload
+(defsubst ebdb-records (&optional record-class child-p)
+ "Return a list of all EBDB records; load databases if necessary.
+This function also notices if databases are out of sync.
+
+If RECORD-CLASS is given, only return records of this class or,
+if CHILD-P is non-nil, one of its subclasses."
+ (unless ebdb-db-list
+ (ebdb-load))
+ (if record-class
+ (seq-filter
+ (lambda (r)
+ (if child-p
+ (object-of-class-p r record-class)
+ (same-class-p r record-class)))
+ ebdb-record-tracker)
+ ebdb-record-tracker))
+
+(defmacro ebdb-error-retry (&rest body)
+ "Repeatedly execute BODY ignoring errors till no error occurs."
+ `(catch '--ebdb-error-retry--
+ (while t
+ (condition-case --c--
+ (throw '--ebdb-error-retry-- (progn ,@body))
+ (ebdb-unparseable
+ (ding)
+ (message "Error: %s" (nth 1 --c--))
+ (sit-for 2))))))
+
+(defmacro ebdb-with-exit (&rest body)
+ `(condition-case nil
+ ,@body
+ ((quit ebdb-empty)
+ nil)))
+
+(defmacro ebdb-loop-with-exit (&rest body)
+ "Repeat BODY, accumulating the results in a list, until the
+user either hits C-g, or enters an empty field label."
+ `(let (acc)
+ (catch '--ebdb-loop-exit--
+ (condition-case nil
+ (while t
+ (push ,@body acc))
+ ((quit ebdb-empty)
+ (throw '--ebdb-loop-exit-- acc))))))
+
+(defmacro ebdb-debug (&rest body)
+ "Excecute BODY just like `progn' with debugging capability.
+Debugging is enabled if variable `ebdb-debug' is non-nil during compile.
+You really should not disable debugging. But it will speed things up."
+ (declare (indent 0))
+ (if ebdb-debug ; compile-time switch
+ `(let ((debug-on-error t))
+ ,@body)))
+
+;;; Fields.
+
+(defclass ebdb-field ()
+ ((actions
+ :type (list-of function)
+ :allocation :class
+ :initform nil
+ :documentation
+ "A list of actions which this field can perform."))
+ :abstract t
+ :documentation "Abstract class for EBDB fields. Subclass this
+to produce real field types.")
+
+(cl-defmethod ebdb-init (_field-value &rest _args)
+ "Catch-all `ebdb-init' method for fields.
+
+This method may also get called on field values that aren't
+actually `ebdb-field' instances -- for instance, plain strings.
+In those cases, assume we don't need to do anything."
+ t)
+
+(cl-defmethod ebdb-field-readable-name ((field (subclass ebdb-field)))
+ "Return a human-readable string label for this class.
+
+Mostly used for allowing users to pick which field type they want
+to add to a record."
+ ;; Why is there no non-private access to this? The `class-option'
+ ;; function is mentioned in the EIEIO manual, but doesn't exist.
+ (eieio--class-option (find-class field) :human-readable))
+
+(cl-defmethod ebdb-field-readable-name ((field ebdb-field))
+ (ebdb-field-readable-name (eieio-object-class field)))
+
+(cl-defmethod ebdb-field-readable-name ((_field (eql string)))
+ "Value")
+
+;;; Errors
+
+;; I haven't figured this out quite yet. What I want to do is avoid
+;; raising errors for *some* methods, with *some* classes; right now
+;; all errors are suppressed. It doesn't seem very easy to specialize
+;; on methods and classes here: the GENERIC argument that's passed in
+;; to the methods below is the full struct of the generic itself.
+;; Presumably I'll have to look into that struct? Or maybe I should
+;; just write bottom-level do-nothing methods for the cases where I
+;; don't want to raise an error. I guess I'll do that for
+;; `ebdb-delete' and `ebdb-init', for the base `ebdb-field' class.
+
+;; (cl-defmethod cl-no-applicable-method (_generic &rest _args)
+;; "Don't raise errors for unimplemented methods."
+;; (message "All no-applicable-method errors are swallowed."))
+
+;; (cl-defmethod cl-no-next-method (_generic _method &rest _args)
+;; "Don't raise errors for non-existent next methods."
+;; (message "All no-next-method errors are swallowed."))
+
+;; There used to be a `destructor' method, but it's been marked
+;; obsolete as of 25.2. There may be a `delete-instance' method, but
+;; then again there may not. Handle it ourselves.
+
+(cl-defmethod ebdb-delete ((field ebdb-field) &optional _record _unload)
+ "User-level deletion routine for FIELD.
+
+Override this to do any necessary cleanup work after FIELD is
+removed."
+ (delete-instance field))
+
+(cl-defmethod ebdb-delete ((_field string) &optional _record _unload)
+ t)
+
+(cl-defmethod delete-instance ((_field ebdb-field) &rest _args)
+ t)
+
+(cl-defmethod ebdb-read ((class (subclass ebdb-field)) &optional slots _obj)
+ "Complete the read/object creation process for a field of CLASS.
+
+Earlier subclasses of `ebdb-field' will have read all the
+necessary values into SLOTS; this base method is simply
+responsible for creating the field object.
+
+The OBJ argument is used when editing existing fields: OBJ is the
+old field. By now we've sucked all the useful information out of
+it, and if this process is successful it will get deleted."
+ (apply 'make-instance class slots))
+
+;; Generics for fields. Not all field classes will implement these
+;; methods. `ebdb-action' should raise an error (to be caught and
+;; displayed at top level) when there is no applicable action method,
+;; so we don't actually define a base method. `ebdb-notice' shouldn't
+;; raise an error if it's not implemented, so we define a do-nothing
+;; base method.
+
+(cl-defmethod ebdb-action ((field ebdb-field) record &optional idx)
+ "Do an \"action\" based on one of the functions listed in FIELD's action
slot.
+
+If IDX is provided, it is an index indicating which of the action
+functions to call. Otherwise, call the car of the list."
+ (let* ((actions (slot-value field 'actions))
+ (func (when actions
+ (if idx (or (nth idx actions) (last actions)) (car actions)))))
+ (when func
+ (funcall func record field))))
+
+(cl-defmethod ebdb-notice ((_field ebdb-field) &optional _type
_message-headers _record)
+ "Ask FIELD of RECORD to react to RECORD being \"noticed\".
+
+When the user receives an email from or cc'd to RECORD, that
+record will call `ebdb-notice' on all its fields, and give them a
+chance to react somehow. TYPE is one of the symbols to, from, or
+cc, indicating which message header the record was found in.
+MESSAGE-HEADERS is a list of all the headers of the incoming
+message."
+ nil)
+
+(cl-defmethod ebdb-field-search ((field ebdb-field) (regex string))
+ (condition-case nil
+ (string-match-p regex (ebdb-string field))
+ (cl-no-applicable-method nil)))
+
+;;; The UUID field.
+
+;; This was originally just a string-value slot, but it was such a
+;; pain in the neck differentiating between strings and fields that
+;; I'm just making it a field. Who knows, it might come in handy later.
+
+(defclass ebdb-field-uuid (ebdb-field)
+ ((uuid
+ :type string
+ :initarg :uuid
+ :initform ""))
+ :human-readable "uuid")
+
+(cl-defmethod ebdb-string ((field ebdb-field-uuid))
+ (slot-value field 'uuid))
+
+;;; The name fields. One abstract base class, and two instantiable
+;;; subclasses.
+
+;; TODO: Allow the user to choose whether the aka slot uses
+;; `ebdb-field-name-simple' or `ebdb-field-name-complex'. Or maybe on
+;; a case-by-case basis?
+
+(defclass ebdb-field-name (ebdb-field)
+ nil
+ :abstract t
+ :documentation "Abstract base class for creating record
+ names.")
+
+(defclass ebdb-field-name-simple (ebdb-field-name)
+ ((name
+ :type string
+ :initarg :name
+ :initform ""))
+ :documentation "A name class for \"simple\" names: ie plain
+ strings."
+ :human-readable "name")
+
+(cl-defmethod ebdb-string ((name ebdb-field-name-simple))
+ (slot-value name 'name))
+
+(cl-defmethod ebdb-read ((class (subclass ebdb-field-name-simple))
+ &optional slots obj)
+ (let ((name (ebdb-read-string "Name: " (when obj (slot-value obj name)))))
+ (cl-call-next-method class (plist-put slots :name name) obj)))
+
+(cl-defmethod ebdb-init ((name ebdb-field-name-simple) &optional record)
+ (when record
+ (ebdb-puthash (ebdb-string name) record))
+ (cl-call-next-method))
+
+(defclass ebdb-field-name-complex (ebdb-field-name)
+ ((surname
+ :initarg :surname
+ :type (or null string)
+ :initform nil)
+ (given-names
+ :initarg :given-names
+ :type (list-of string)
+ :initform nil)
+ (prefix
+ :initarg :prefix
+ :type (or null string)
+ :initform nil)
+ (suffix
+ :initarg :suffix
+ :type (or null string)
+ :initform nil)
+ ;; What is an affix, actually?
+ (affix
+ :initarg :affix
+ :type (or null string)
+ :initform nil))
+ :documentation "A name class for \"complex\", ie structured,
+ names."
+ ;; This returns "aka" because the prompt is only used when _adding_
+ ;; another name to an existing record.
+ :human-readable "aka")
+
+(cl-defmethod ebdb-name-last ((name ebdb-field-name-complex))
+ "Return the surname of this name field."
+ (slot-value name 'surname))
+
+(cl-defmethod ebdb-name-given ((name ebdb-field-name-complex) &optional full)
+ "Return the given names of this name field.
+
+If FULL is t, return all the given names, otherwise just the
+first one."
+ (let ((given (slot-value name 'given-names)))
+ (if full
+ (mapconcat #'identity given " ")
+ (car given))))
+
+(cl-defmethod ebdb-name-lf ((name ebdb-field-name-complex) &optional full)
+ (let ((given-string (ebdb-name-given name full))
+ (prefix (slot-value name 'prefix)))
+ (concat (ebdb-name-last name)
+ (when prefix prefix)
+ (when given-string (format ", %s" given-string)))))
+
+(cl-defmethod ebdb-name-fl ((name ebdb-field-name-complex) &optional _full)
+ (with-slots (prefix surname suffix) name
+ (concat (ebdb-name-given name t)
+ " "
+ (when prefix
+ (format "%s " prefix))
+ (slot-value name 'surname)
+ (when suffix
+ (format ", %s" suffix)))))
+
+(cl-defmethod ebdb-string ((name ebdb-field-name-complex))
+ "Produce a canonical string for NAME."
+ ;; This is the crux of things, really. This is the method that
+ ;; produces the name you'll see in the *EBDB* buffer, so this is the
+ ;; bit that should be most customizable, and most flexible. This
+ ;; value also gets stored in the cache.
+ (ebdb-name-fl name))
+
+(cl-defmethod ebdb-init ((name ebdb-field-name-complex) &optional record)
+ (when record
+ (let ((lf (ebdb-name-lf name))
+ (fl (ebdb-name-fl name)))
+ (ebdb-puthash lf record)
+ (ebdb-puthash fl record)
+ (object-add-to-list (ebdb-record-cache record) 'alt-names lf)
+ (object-add-to-list (ebdb-record-cache record) 'alt-names fl)))
+ (cl-call-next-method))
+
+(cl-defmethod ebdb-delete ((name ebdb-field-name-complex) &optional record
_unload)
+ (when record
+ (let ((lf (ebdb-name-lf name))
+ (fl (ebdb-name-fl name)))
+ (ebdb-remhash lf record)
+ (ebdb-remhash fl record)
+ (object-remove-from-list (ebdb-record-cache record) 'alt-names lf)
+ (object-remove-from-list (ebdb-record-cache record) 'alt-names fl)))
+ (cl-call-next-method))
+
+(cl-defmethod ebdb-read ((class (subclass ebdb-field-name-complex)) &optional
slots obj)
+ (if ebdb-read-name-articulate
+ (let* ((surname-default (when obj (ebdb-name-last obj)))
+ (given-default (when obj (ebdb-name-given obj t)))
+ (surname (read-string "Surname: " surname-default))
+ (given-names (read-string "Given name(s): " given-default)))
+ (setq slots (plist-put slots :surname surname))
+ (setq slots (plist-put slots :given-names (split-string given-names)))
+ (cl-call-next-method class slots obj))
+ (ebdb-parse class (ebdb-read-string "Name: " (when obj (ebdb-string
obj))))))
+
+(cl-defmethod ebdb-field-search ((_field ebdb-field-name-complex) _regex)
+ "Short-circuit the plain field search for names.
+
+The record itself performs more complex searches on cached name
+values, by default the search is not handed to the name field itself."
+ nil)
+
+(cl-defmethod ebdb-parse ((_class (subclass ebdb-field-name-complex)) string)
+ (let ((bits (ebdb-divide-name string)))
+ (make-instance 'ebdb-field-name-complex
+ :given-names (when (car bits)
+ (list (car bits)))
+ :surname (cdr bits))))
+
+;;; The labeled abstract class. Can be subclassed, or used as a mixin.
+
+;; Probably there's no need to subclass from `ebdb-field'. Without
+;; this, it will be a pure mixin class. Probably we can do away with
+;; this inheritance without hurting anything.
+(defclass ebdb-field-labeled (ebdb-field eieio-named)
+ ;; The `eieio-named' superclass provides an "object-name" slot.
+ ((label-list
+ :initform nil
+ :type (or null symbol)
+ :allocation :class
+ :documentation
+ "This class-allocated slot points to a variable holding a
+ list of known string labels for objects of the subclass."))
+ :abstract t
+ :documentation "A field with a string label.")
+
+(cl-defmethod ebdb-read :around ((class (subclass ebdb-field-labeled))
&optional slots obj)
+ "Prompt for a label for a new object of class CLASS, using OBJ
+ as a default, and store the result in SLOTS.
+
+All subclasses of `ebdb-field-labeled' should have a 'label-list
+slot pointing to a var holding known labels for that class. This
+method checks that the label is known, and asks for confirmation
+if it isn't.
+
+This method also signals the 'ebdb-empty error if the user gives
+an empty string as a label, which allows interruption of the read
+process."
+ ;; This is an :around method so the field label can be prompted for
+ ;; before the value.
+ (let* ((labels (symbol-value (oref-default class label-list)))
+ (human-readable (ebdb-field-readable-name class))
+ (label (plist-get slots :object-name)))
+ (unless label
+ (setq label (ebdb-read-string
+ (if (stringp human-readable)
+ (format "%s label: " (capitalize human-readable))
+ "Label: ")
+ (and obj (slot-value obj 'object-name))
+ labels nil)
+ slots (plist-put slots :object-name label)))
+ (if (or (member label labels)
+ (yes-or-no-p (format "%s is not a known label, define it? " label)))
+ (cl-call-next-method class slots obj)
+ (signal 'ebdb-empty (list class)))))
+
+(cl-defmethod ebdb-init ((field ebdb-field-labeled) &optional _record)
+ (let ((label-var (slot-value field 'label-list)))
+ (ebdb-add-to-list label-var (slot-value field 'object-name))
+ (cl-call-next-method)))
+
+;;; User-defined fields. There are two kinds. The first is
+;;; `ebdb-field-user', which provides no information about labels or
+;;; slots, but simply gives us the right to live in the "fields" slot
+;;; of records. It must be subclassed to be useful.
+
+;;; The second is the `ebdb-field-user-simple', which subclasses
+;;; `ebdb-field-user' and `ebdb-field-labeled'. This class should
+;;; *not* be subclassed; it's the class that collects all the basic
+;;; label-plus-value fields that users might want to add. Instances
+;;; have no particular behavior, they're just key-value pairs.
+
+(defclass ebdb-field-user (ebdb-field)
+ nil
+ :abstract t
+ :documentation
+ "Fields that should be user-editable, but need more complicated
+ slot structures than the simple \"value\" provided by
+ `ebdb-field-user', can subclass this class.")
+
+(defvar ebdb-user-label-list nil
+ "List of existing labels of user fields.")
+
+(defclass ebdb-field-user-simple (ebdb-field-labeled ebdb-field-user)
+ ((label-list :initform ebdb-user-label-list)
+ (value
+ :initarg :value
+ :type (or atom list)
+ :initform ""
+ :documentation "The value of this user-defined field."))
+ :human-readable "user field")
+
+(cl-defmethod ebdb-string ((field ebdb-field-user-simple))
+ (let ((val (slot-value field 'value)))
+ (if (stringp val)
+ val
+ (ebdb-concat (intern-soft (slot-value field 'object-name)) val))))
+
+;; TODO: Maybe replicate the ability to insert a lisp sexp directly,
+;; in interactive mode?
+(cl-defmethod ebdb-read ((class (subclass ebdb-field-user-simple)) &optional
slots obj)
+ (unless (plist-get slots :value)
+ (let ((default (when obj (ebdb-string obj))))
+ (setq slots (plist-put slots :value (ebdb-read-string "Value: "
default)))))
+ (cl-call-next-method class slots obj))
+
+;;; Role fields.
+
+(defvar ebdb-role-label-list nil)
+
+(defclass ebdb-field-role (ebdb-field-labeled ebdb-field)
+ ((label-list :initform ebdb-role-label-list)
+ (record-uuid
+ :initarg :record-uuid
+ :type (or null string)
+ :initform nil)
+ (org-uuid
+ :initarg :org-uuid
+ :type (or null string)
+ :initform nil)
+ (mail
+ :initarg :mail
+ :type (or null ebdb-field-mail)
+ :initform nil)
+ (fields
+ :initarg :fields
+ :type (list-of ebdb-field)
+ :initform nil)
+ (defunct
+ :initarg :defunct
+ :type boolean
+ :initform nil
+ :documentation "If t, this role is considered defunct (ie
+ the person left their job, etc). Fields in the \"fields\"
+ slot will generally be ignored by the rest of EBDB."))
+ :documentation "This class represents a relationship between
+ the record which owns this field, and the
+ `ebdb-record-organization' pointed to by the \"organization\"
+ slot. The \"mail\" slot holds the record's organizational
+ email address. The \"fields\" slot holds whatever extra fields
+ might be relevant to the role."
+ :human-readable "role")
+
+(cl-defmethod ebdb-init ((role ebdb-field-role) &optional record)
+ (when record
+ (let* ((org-uuid (slot-value role 'org-uuid))
+ (org (seq-find ;; TODO: This is very slow.
+ (lambda (r)
+ (equal org-uuid (ebdb-record-uuid r)))
+ ebdb-record-tracker))
+ (org-string (ebdb-string (slot-value org 'name)))
+ ;; TODO: Guard against org-entry not being found.
+ (org-entry (gethash org-uuid ebdb-org-hashtable))
+ (record-uuid (ebdb-record-uuid record))
+ (role-mail (slot-value role 'mail))
+ new-org-entry exists-p)
+ ;; TODO: We shouldn't really be doing this here, because setting
+ ;; the slot value would mean the record/database should be set
+ ;; to dirty, which it isn't necessarily, at this point.
+ ;; Instead, `ebdb-read' should accept the record as an argument,
+ ;; and this should be done in that method instead.
+ (unless (slot-value role 'record-uuid)
+ (setf (slot-value role 'record-uuid) record-uuid))
+ (object-add-to-list (ebdb-record-cache record) 'organizations org-string)
+ ;; Init the role mail against the record.
+ (when (and role-mail (slot-value role-mail 'mail))
+ (ebdb-init role-mail record))
+ ;; Make sure this role is in the `ebdb-org-hashtable'.
+ (unless (and org-entry
+ (dolist (pair org-entry exists-p)
+ (if (and (string= record-uuid (car pair))
+ (string= (slot-value (cdr pair) 'object-name)
+ (slot-value role 'object-name)))
+ (setq exists-p t)
+ (push pair new-org-entry))))
+ ;; TODO: It's no longer necessary to record the record-uuid
+ ;; along with the role, as the uuid is recorded in a slot on
+ ;; the role.
+ (push (cons record-uuid role) new-org-entry))
+ (puthash org-uuid new-org-entry ebdb-org-hashtable)))
+ (when (slot-value role 'mail)
+ (ebdb-init (slot-value role 'mail) record))
+ (cl-call-next-method))
+
+(cl-defmethod ebdb-delete ((role ebdb-field-role) &optional record unload)
+ (when record
+ (let* ((org-uuid (slot-value role 'org-uuid))
+ (org-string
+ (slot-value
+ ;; `ebdb-init' can't use `ebdb-gethash' for this, because
+ ;; not all the records will be hashed during the loading
+ ;; process. We should be safe to use it here, though.
+ (ebdb-gethash org-uuid 'uuid)
+ 'name))
+ (org-entry (gethash org-uuid ebdb-org-hashtable))
+ (record-uuid (ebdb-record-uuid record))
+ record-entry new-org-entry)
+ (while (setq record-entry (pop org-entry))
+ ;; The assumption being made here is that
+ ;; record+organization+role-label combinations must be unique.
+ ;; A record can have multiple roles at an organization, but
+ ;; those roles must have different labels.
+ (unless (and (string= (car record-entry) record-uuid)
+ (string= (slot-value role 'object-name)
+ (slot-value (cdr record-entry) 'object-name)))
+ (push record-entry new-org-entry)))
+ (puthash org-uuid new-org-entry ebdb-org-hashtable)
+ (when (null (assoc-string record-uuid org-entry))
+ ;; RECORD no long has any roles at ORG.
+ (object-remove-from-list (ebdb-record-cache record) 'organizations
org-string))))
+ (when (slot-value role 'mail)
+ (ebdb-delete (slot-value role 'mail) record unload))
+ (cl-call-next-method))
+
+(cl-defmethod ebdb-read ((role (subclass ebdb-field-role)) &optional slots obj)
+ (let ((org-id (if obj (slot-value obj 'org-uuid)
+ (ebdb-record-uuid (ebdb-prompt-for-record nil
'ebdb-record-organization))))
+ (mail (ebdb-with-exit
+ (ebdb-read ebdb-default-mail-class nil
+ (when obj (slot-value obj 'mail))))))
+ (when mail
+ (setq slots (plist-put slots :mail mail)))
+ (setq slots (plist-put slots :org-uuid org-id))
+ (cl-call-next-method role slots obj)))
+
+(cl-defmethod ebdb-string ((role ebdb-field-role))
+ "Display a string for this ROLE."
+ ;; This is used in person records headers, so it just shows the
+ ;; organization name. Perhaps this could have a multi-line option
+ ;; later.
+ (ebdb-string (ebdb-gethash (slot-value role 'org-uuid) 'uuid)))
+
+;;; Mail fields.
+
+;; Instead of one field holding many mail addresses, this is one field
+;; per address.
+
+(defclass ebdb-field-mail (ebdb-field)
+ ((aka
+ :initarg :aka
+ :type (or null string)
+ :initform nil)
+ (mail
+ :initarg :mail
+ :type string
+ :initform "")
+ (priority
+ :initarg :priority
+ :type (or null symbol)
+ :initform normal
+ :custom '(choice (const :tag "Normal priority" normal)
+ (const :tag "Primary address" primary)
+ (const :tag "Defunct address" defunct))
+ :documentation
+ "The priority of this email address. The symbol 'normal means
+ normal priority, 'defunct means the address will not be
+ offered for completion, and 'primary means this address will
+ be used as the default. Only one of a record's addresses can
+ be set to 'primary.")
+ (actions :initform '(ebdb-mail)))
+ :documentation "A field representing a single email address.
+ The optional \"object-name\" slot can serve as a mail aka."
+ :human-readable "mail")
+
+(cl-defmethod ebdb-init ((mail ebdb-field-mail) &optional record)
+ (with-slots (aka mail) mail
+ (ebdb-puthash mail record)
+ (object-add-to-list (ebdb-record-cache record) 'mail-canon mail)
+ (when aka
+ (ebdb-puthash aka record)
+ (object-add-to-list (ebdb-record-cache record) 'mail-aka aka))))
+
+(cl-defmethod ebdb-delete ((mail ebdb-field-mail) &optional record _unload)
+ (with-slots (aka mail) mail
+ (when record
+ (when aka
+ (ebdb-remhash aka record)
+ (object-remove-from-list (ebdb-record-cache record) 'mail-aka aka))
+ (ebdb-remhash mail record)
+ (object-remove-from-list (ebdb-record-cache record) 'mail-canon mail)))
+ (cl-call-next-method))
+
+(cl-defmethod ebdb-string ((mail ebdb-field-mail))
+ (with-slots (aka mail) mail
+ (if aka
+ (concat aka " <" mail ">")
+ mail)))
+
+(cl-defmethod ebdb-read ((class (subclass ebdb-field-mail)) &optional slots
obj)
+ (let* ((default (when obj (ebdb-string obj)))
+ (input (ebdb-read-string "Mail address: " default))
+ (bits (ebdb-decompose-ebdb-address input))
+ (mail (nth 1 bits)))
+ ;; (unless (or ebdb-allow-duplicates
+ ;; (and obj
+ ;; (equal mail (slot-value obj 'mail))))
+ ;; (when (ebdb-gethash mail '(mail))
+ ;; (error "Address %s belongs to another record" mail)))
+ (when (car bits)
+ (setq slots (plist-put slots :aka (car bits))))
+ (setq slots (plist-put slots :mail mail))
+ (when obj
+ (setq slots (plist-put slots :priority (slot-value obj 'priority))))
+ (cl-call-next-method class slots obj)))
+
+(defun ebdb-sort-mails (mails)
+ "Sort MAILS (being instances of `ebdb-field-mail') by their
+ priority slot. Primary sorts before normal sorts before
+ defunct."
+ (sort
+ mails
+ (lambda (l r)
+ (let ((l-p (slot-value l 'priority))
+ (r-p (slot-value r 'priority)))
+ (or (and (eq l-p 'primary)
+ (memq r-p '(normal defunct)))
+ (and (eq l-p 'normal)
+ (eq r-p 'defunct)))))))
+
+;;; Address fields
+
+(defclass ebdb-field-address (ebdb-field-labeled ebdb-field)
+ ((label-list :initform ebdb-address-label-list)
+ (streets
+ :initarg :streets
+ :type (list-of string)
+ :initform nil
+ :accessor ebdb-address-streets)
+ (locality
+ :initarg :locality
+ :type string
+ :initform ""
+ :accessor ebdb-address-locality)
+ (region
+ :initarg :region
+ :type string
+ :initform ""
+ :accessor ebdb-address-region)
+ (postcode
+ :initarg :postcode
+ :type string
+ :initform ""
+ :accessor ebdb-address-postcode)
+ (country
+ :initarg :country
+ :type (or string symbol)
+ :initform ""
+ :accessor ebdb-address-country))
+ :documentation "A field representing an address."
+ :human-readable "address")
+
+(cl-defmethod ebdb-init ((address ebdb-field-address) &optional _record)
+ (with-slots (object-name streets locality region postcode country) address
+ (dolist (s streets)
+ (ebdb-add-to-list 'ebdb-street-list s))
+ (ebdb-add-to-list 'ebdb-locality-list locality)
+ (when (stringp country)
+ (ebdb-add-to-list 'ebdb-country-list country))
+ (ebdb-add-to-list 'ebdb-region-list region)
+ (ebdb-add-to-list 'ebdb-postcode-list postcode)))
+
+(cl-defmethod ebdb-read ((class (subclass ebdb-field-address)) &optional slots
obj)
+ (let ((streets
+ (if (plist-member slots :streets)
+ (plist-get slots :streets)
+ (ebdb-edit-address-street (when obj (ebdb-address-streets obj)))))
+ (locality
+ (if (plist-member slots :locality)
+ (plist-get slots :locality)
+ (ebdb-read-string "Town/City: "
+ (when obj (ebdb-address-locality obj))
ebdb-locality-list)))
+ (region
+ (if (plist-member slots :region)
+ (plist-get slots :state)
+ (ebdb-read-string "State/Province: "
+ (when obj (ebdb-address-region obj))
ebdb-locality-list)))
+ (postcode
+ (if (plist-member slots :postcode)
+ (plist-get slots :postcode)
+ (ebdb-error-retry
+ (ebdb-parse-postcode
+ (ebdb-read-string "Postcode: "
+ (when obj (ebdb-address-postcode obj))
+ ebdb-postcode-list)))))
+ (country
+ (if (plist-member slots :country)
+ (plist-get slots :country)
+ (ebdb-read-string "Country: "
+ (if obj (slot-value obj 'country)
+ ebdb-default-country)
+ ebdb-country-list))))
+
+ (cl-call-next-method
+ class
+ `(:streets ,streets
+ :locality ,locality
+ :object-name ,(plist-get slots :object-name)
+ :region ,region
+ :postcode ,postcode
+ :country ,country)
+ obj)))
+
+(defun ebdb-edit-address-street (streets)
+ "Edit list STREETS."
+ (let ((n 0) street list)
+ (condition-case nil
+ (while t
+ (setq street
+ (ebdb-read-string
+ (format "Street, line %d: " (1+ n))
+ (nth n streets) ebdb-street-list))
+ (push street list)
+ (setq n (1+ n)))
+ ((ebdb-empty quit) nil))
+ (reverse list)))
+
+;; Addresses are displayed using `ebdb-format-address', which is
+;; probably a candidate for refactoring. In the meantime, provide a
+;; stop-gap `ebdb-string' method for addresses that doesn't go through
+;; the whole formatting routine, and additionally fits on one line.
+;; This should probably get re-thought/re-worked later.
+
+(cl-defmethod ebdb-string ((address ebdb-field-address))
+ (ebdb-format-address address 2))
+
+;;; Phone fields
+
+(defclass ebdb-field-phone (ebdb-field-labeled ebdb-field)
+ ((label-list :initform ebdb-phone-label-list)
+ (country-code
+ :initarg :country-code
+ :type (or null number)
+ :initform nil)
+ (area-code
+ :initarg :area-code
+ :type (or null number)
+ :initform nil)
+ (number
+ :initarg :number
+ :type (or null string)
+ :initform nil)
+ (extension
+ :initarg :extension
+ :type (or null number)
+ :initform nil)
+ (actions
+ :initform '(ebdb-field-phone-dial)))
+ :human-readable "phone")
+
+(cl-defmethod ebdb-string ((phone ebdb-field-phone))
+ "Display the value of this phone number as a string."
+ (with-slots (country-code area-code number extension) phone
+ (let (outstring)
+ (when extension
+ (push (format "X%d" extension) outstring))
+ (when number
+ (let ((numstring (split-string number "" t)))
+ (push
+ (eval `(format ,(cl-case (length numstring)
+ (7
+ "%s%s%s-%s%s%s%s")
+ (8
+ "%s%s%s%s-%s%s%s%s")
+ (t
+ number))
+ ,@numstring))
+ outstring)))
+ (when area-code
+ (push (format "(%d) " area-code) outstring))
+ (when country-code
+ (push (format "+%d " country-code) outstring))
+ (when outstring
+ (apply #'concat outstring)))))
+
+(cl-defmethod ebdb-read ((class (subclass ebdb-field-phone)) &optional slots
obj)
+ (let* ((country
+ (or (and obj
+ (slot-value obj 'country-code))
+ (plist-get slots 'country-code)))
+ (area
+ (or (and obj
+ (slot-value obj 'area-code))
+ (plist-get slots :area-code)))
+ (prompt
+ (concat "Number"
+ (when country
+ (format " +%d" country))
+ (when area
+ (format " (%d)" area))
+ ": "))
+ (default (when obj (slot-value obj 'number)))
+ (plist
+ (ebdb-error-retry
+ (ebdb-parse class
+ (ebdb-read-string prompt default)
+ slots))))
+ (cl-call-next-method class plist obj)))
+
+(cl-defmethod ebdb-parse ((_class (subclass ebdb-field-phone))
+ (string string)
+ &optional slots)
+ "Parse a phone number from STRING and return a plist of
+integers of the form \(country-code area-code number extension\).
+
+The plist should be suitable for creating an instance of
+`ebdb-field-phone'.
+
+If plist SLOTS is present, allow values from that plist to
+override parsing."
+ ;; TODO: This `ebdb-parse' method returns a plist. Other such
+ ;; methods return an actual object. We need consistency!
+ (let ((country-regexp "\\+(?\\([0-9]\\{1,3\\}\\))?[ \t]+")
+ (area-regexp "(?\\([0-9]\\{1,4\\}\\)[-)./ \t]+")
+ (ext-regexp "[ \t]?e?[xX]t?\\.?[ \t]?\\([0-9]+\\)")
+ acc)
+ (with-temp-buffer
+ (insert (ebdb-string-trim string))
+ (goto-char (point-min))
+ (unless (plist-member slots :country-code)
+ (when (looking-at country-regexp)
+ (setq slots
+ (plist-put slots :country-code (string-to-number (match-string
1))))
+ (goto-char (match-end 0))))
+ (unless (plist-member slots :area-code)
+ (when (looking-at area-regexp)
+ ;; Bit of a hack. If we seem to have an area code, but there
+ ;; are fewer than six digits *after* the area code, assume
+ ;; it's not an area code at all, but part of the actual
+ ;; number.
+ (unless
+ (save-excursion
+ (goto-char (match-end 0))
+ (save-match-data
+ (< (abs (- (point)
+ (or (when (re-search-forward ext-regexp
(point-max) t)
+ (goto-char (match-beginning 0))
+ (point))
+ (point-max))))
+ 6)))
+ (setq slots
+ (plist-put slots :area-code (string-to-number (match-string
1))))
+ (goto-char (match-end 0)))))
+ ;; There is no full regexp for the main phone number. We just
+ ;; chomp up any and all numbers that come after the area code,
+ ;; until we hit an extension, or the end of the buffer. All
+ ;; phone slots but "number" are actually saved as numbers. The
+ ;; "number" is saved as a string, partially for ease in
+ ;; formatting, partially because if it's too long Emacs turns it
+ ;; into a float, which is a pain in the ass.
+ (while (and (< (point) (point-max))
+ (null (looking-at-p ext-regexp))
+ (looking-at "[ \t]?\\([0-9]+\\)[- .]?"))
+ (setq acc (concat acc (match-string-no-properties 1)))
+ (goto-char (match-end 0)))
+ (when (looking-at ext-regexp)
+ (setq slots
+ (plist-put slots :extension (string-to-number
+ (match-string 1))))))
+ (setq slots
+ (plist-put slots :number acc))
+ slots))
+
+;;; Notes field
+
+(defclass ebdb-field-notes (ebdb-field)
+ ((notes
+ :type string
+ :initarg :notes
+ :initform ""
+ :documentation "User notes on this contact."))
+ :human-readable "notes")
+
+(cl-defmethod ebdb-string ((notes ebdb-field-notes))
+ (slot-value notes 'notes))
+
+(cl-defmethod ebdb-read ((class (subclass ebdb-field-notes)) &optional slots
obj)
+ (let ((default (when obj (ebdb-string obj))))
+ (cl-call-next-method class
+ (plist-put slots :notes (ebdb-read-string "Notes: "
default))
+ obj)))
+
+;;; Timestamp field
+
+;; For both these fields, I'd actually prefer to store
+;; seconds-since-epoch in the actual backend, for ease of use. The
+;; human-readable date string could be output in `ebdb-string'.
+
+(defclass ebdb-field-timestamp (ebdb-field)
+ ((timestamp
+ :initarg :timestamp
+ :type list
+ :initform nil))
+ :human-readable "timestamp")
+
+(cl-defmethod ebdb-stamp-time ((field ebdb-field-timestamp))
+ (ebdb-update-timestamp-field field 'timestamp))
+
+(defun ebdb-update-timestamp-field (ts slot)
+ (setf (slot-value ts slot) (current-time)))
+
+(cl-defmethod ebdb-string ((field ebdb-field-timestamp))
+ (format-time-string ebdb-time-format (slot-value field 'timestamp) t))
+
+;;; Creation date field
+
+;; This doesn't really do anything, but who knows who might want to
+;; override it for their own nefarious purposes?
+
+(defclass ebdb-field-creation-date (ebdb-field-timestamp)
+ nil
+ :human-readable "creation date")
+
+;;; Anniversary field
+
+;; The `ebdb-notice' method could let you know when you get an email
+;; from someone and it happens to be their birthday. The
+;; `ebdb-action' method could open a calendar with point on the
+;; upcoming anniversary, etc.
+
+(defvar ebdb-anniversary-label-list '("birthday" "marriage" "death"))
+
+(defclass ebdb-field-anniversary (ebdb-field-labeled ebdb-field-user)
+ ((label-list :initform ebdb-anniversary-label-list)
+ (date
+ :initarg :date
+ :type number
+ :documentation
+ "A number representing a date, as produced by calling
+ `calendar-absolute-from-gregorian' on a gregorian date.")
+ (calendar
+ :initarg :calendar
+ :type symbol
+ :initform gregorian
+ :documentation "The calendar to which this date applies.")
+ (actions
+ :initform '(ebdb-field-anniversary-browse)))
+ :human-readable "anniversary")
+
+(cl-defmethod ebdb-read ((class (subclass ebdb-field-anniversary)) &optional
slots obj)
+ (require 'calendar)
+ ;; The only unfortunate thing here is that we can't reasonably use
+ ;; an existing date value as the default for entering a new one. Oh
+ ;; well.
+ (let ((date (calendar-absolute-from-gregorian
+ (calendar-read-date))))
+ (cl-call-next-method class (plist-put slots :date date) obj)))
+
+(cl-defmethod ebdb-string ((ann ebdb-field-anniversary))
+ (require 'calendar)
+ (calendar-date-string
+ (calendar-gregorian-from-absolute (slot-value ann 'date))
+ nil t))
+
+;;; Relationship field
+
+;; This is a bit different from the organization role field, mostly
+;; just meant for family relationships or similar things.
+
+(defvar ebdb-relation-label-list '("father" "mother" "sister" "brother"
+ "son" "daughter" "aunt" "uncle"
+ "grandmother" "grandfather" "wife"
"husband"))
+
+(defclass ebdb-field-relation (ebdb-field-labeled ebdb-field)
+ ((label-list :initform ebdb-relation-label-list)
+ (rel-uuid
+ :initarg :rel-uuid
+ :type string
+ :initform ""
+ :documentation "The UUID of the target record.")
+ (rel-label
+ :initarg :rel-label
+ :type string
+ :initform ""
+ :documentation "The label on the \"other side\" of the
+ relation, pointing at this record."))
+ :human-readable "relationship")
+
+(cl-defmethod ebdb-read ((class (subclass ebdb-field-relation)) &optional
slots obj)
+ (let* ((rec (ebdb-record-uuid (ebdb-prompt-for-record nil
ebdb-default-record-class)))
+ (rel-label (ebdb-read-string "Reverse label (for the other record): "
+ nil ebdb-relation-label-list)))
+ (setq slots (plist-put slots :rel-uuid rec))
+ (setq slots (plist-put slots :rel-label rel-label))
+ (cl-call-next-method class slots obj)))
+
+(cl-defmethod ebdb-string ((rel ebdb-field-relation))
+ (ebdb-string (ebdb-gethash (slot-value rel 'rel-uuid) 'uuid)))
+
+;; Image field
+
+(defclass ebdb-field-image (ebdb-field)
+ ((image
+ :type (or null string symbol)
+ :initarg :image))
+ :human-readable "image")
+
+(eieio-oset-default 'ebdb-field-image 'image ebdb-image)
+
+(cl-defmethod ebdb-read ((image (subclass ebdb-field-image)) &optional slots
obj)
+ (let ((existing (when obj (slot-value obj 'image)))
+ value)
+ (setq value
+ (cond
+ ((or (stringp existing)
+ (yes-or-no-p "Find image file? "))
+ (read-file-name "Image file: " ebdb-image-path existing 'confirm))
+ ((yes-or-no-p "Use name format? ")
+ (intern (completing-read "Format: " '(name fl-name lf-name) nil t
existing)))
+ (t
+ (message "Image will be found using `ebdb-field-image-function'.")
+ nil)))
+ (cl-call-next-method image (plist-put slots :image value) obj)))
+
+(cl-defmethod ebdb-string ((field ebdb-field-image))
+ (let ((image (slot-value field 'image)))
+ (format (if (stringp image) "Image file: %s" "Image format: %s") image)))
+
+;; URL field
+
+(defvar ebdb-url-label-list '("homepage")
+ "List of known URL labels.")
+
+(defclass ebdb-field-url (ebdb-field-labeled ebdb-field-user)
+ ((label-list
+ :initform ebdb-url-label-list)
+ (url
+ :type string
+ :initarg :url
+ :initform "")
+ (actions
+ :initform '(ebdb-field-url-browse)))
+ :human-readable "URL")
+
+(cl-defmethod ebdb-read ((class (subclass ebdb-field-url)) &optional slots obj)
+ (let ((url (ebdb-read-string "Url: " (when obj (slot-value obj 'url)))))
+ (cl-call-next-method class (plist-put slots :url url) obj)))
+
+(cl-defmethod ebdb-string ((field ebdb-field-url))
+ (slot-value field 'url))
+
+;;; Fields that change EBDB's behavior. Right now we've got
+;;; `ebdb-mail-name' and the hard-coded 'name-format xfield that are
+;;; meant to change a record's behavior. I'm not convinced that
+;;; that's the best way to handle that. At the very least we need
+;;; mail aliases, though.
+
+(defclass ebdb-field-mail-alias (ebdb-field-user)
+ ((alias
+ :type string
+ :initarg :alias
+ :documentation
+ "A string used as a mail alias for this record."))
+ :human-readable "mail alias")
+
+(cl-defmethod ebdb-read ((class (subclass ebdb-field-mail-alias)) &optional
slots obj)
+ (let ((alias (ebdb-read-string "Alias: " (when obj (slot-value obj
'alias)))))
+ (cl-call-next-method class (plist-put slots :alias alias) obj)))
+
+(cl-defmethod ebdb-string ((field ebdb-field-mail-alias))
+ (slot-value field 'alias))
+
+;; TODO: Write `ebdb-init' and `ebdb-delete' methods for the
+;; `ebdb-field-mail-alias' class. These methods should do the work of
+;; changing the defined mail aliases.
+
+;; Passports
+
+(defclass ebdb-field-passport (ebdb-field-user)
+ ((country
+ :type string
+ :initarg :country
+ :initform "")
+ (number
+ :type string
+ :initarg :number
+ :initform "")
+ (issue-date
+ :initarg :issue-date
+ :type (or nil number))
+ (expiration-date
+ :initarg :expiration-date
+ :type (or nil number)))
+ :human-readable "passport")
+
+(cl-defmethod ebdb-read ((class (subclass ebdb-field-passport)) &optional
slots obj)
+ (let ((country (ebdb-read-string "Country: " (when obj (slot-value obj
'country))))
+ (number (ebdb-read-string "Number: " (when obj (slot-value obj
'number))))
+ (issue-date (calendar-absolute-from-gregorian
+ (calendar-read-date)))
+ (expiration-date (calendar-absolute-from-gregorian
+ (calendar-read-date))))
+ (setq slots (plist-put slots :country country))
+ (setq slots (plist-put slots :number number))
+ (setq slots (plist-put slots :issue-date issue-date))
+ (setq slots (plist-put slots :expiration-date expiration-date))
+ (cl-call-next-method class slots obj)))
+
+(cl-defmethod ebdb-string ((field ebdb-field-passport))
+ (with-slots (country number) field
+ (format "(%s) %s" country number)))
+
+;;; Records
+
+;; The basic, abstract `ebdb-record' class should require no user
+;; interaction, and has no real user-facing fields (except for the
+;; "fields" bucket, of course). It takes care of all the fundamental
+;; setup and housekeeping automatically.
+
+(defclass ebdb-record (eieio-instance-tracker)
+ ((uuid
+ :initarg :uuid
+ :type (or null ebdb-field-uuid)
+ :initform nil)
+ (tracking-symbol
+ :initform ebdb-record-tracker)
+ (creation-date
+ :initarg :creation-date
+ :type (or null ebdb-field-creation-date)
+ :initform nil)
+ (timestamp
+ :initarg :timestamp
+ :type (or null ebdb-field-timestamp)
+ :initform nil)
+ (fields
+ :initarg :fields
+ :type (list-of ebdb-field-user)
+ :initform nil
+ :documentation "This slot contains all record fields except
+ those built-in to record subclasses.")
+ (image
+ :initarg :image
+ :type (or null ebdb-field-image)
+ :initform nil)
+ (notes
+ :initarg :notes
+ :type (or null ebdb-field-notes)
+ :initform nil
+ :documentation "User notes for this contact.")
+ (dirty
+ :initarg :dirty
+ :type boolean
+ :initform nil
+ :documentation "Does this record have changed fields?")
+ (cache
+ :initarg :cache
+ :type (or null ebdb-cache)
+ :initform nil
+ ;:accessor ebdb-record-cache
+ ))
+ :abstract t
+ :allow-nil-initform t
+ :documentation "An abstract base class for creating EBDB
+ records.")
+
+(cl-defmethod ebdb-record-uuid ((record ebdb-record))
+ (slot-value (slot-value record 'uuid) 'uuid))
+
+(cl-defmethod ebdb-read ((class (subclass ebdb-record)) &optional slots)
+ "Create a new record from the values collected into SLOTS."
+ ;; All the other `ebdb-read' methods for record subclasses "bottom
+ ;; out" here, and create a record.
+ (let ((notes (ebdb-with-exit (ebdb-read ebdb-default-notes-class))))
+ (when notes
+ (setq slots (plist-put slots :notes notes)))
+ (apply 'make-instance class slots)))
+
+(cl-defmethod ebdb-delete ((record ebdb-record) &optional db unload)
+ "Delete RECORD.
+
+This goes through a series of deletion routines, removing RECORD
+from its respective databases, un-hashing its uuid, running
+`ebdb-delete' on its fields, etc."
+ (let ((dbs (if db (list db)
+ (slot-value (ebdb-record-cache record) 'database)))
+ (uuid (ebdb-record-uuid record)))
+ ;; If DB is passed in, assume that it will be responsible for
+ ;; calling `ebdb-db-remove-record'.
+ (unless db
+ (dolist (db dbs)
+ (ebdb-db-remove-record db record)))
+ (setq ebdb-seen-uuids
+ (delete uuid ebdb-seen-uuids))
+ (dolist (field (slot-value record 'fields))
+ (ebdb-delete field record unload))
+ (ebdb-remhash uuid record)
+ (delete-instance record)))
+
+(cl-defmethod initialize-instance ((record ebdb-record) &optional slots)
+ "Add a cache to RECORD."
+ ;; This is the very first thing that happens to a record after it is
+ ;; created (whether manually or loaded).
+ (let ((cache (make-instance 'ebdb-cache)))
+ (setq slots (plist-put slots :cache cache))
+ (with-slots (timestamp creation-date) record
+ (unless creation-date
+ (setf creation-date (make-instance 'ebdb-field-creation-date))
+ (ebdb-stamp-time creation-date))
+ (unless timestamp
+ (setf timestamp (make-instance 'ebdb-field-timestamp))
+ (ebdb-stamp-time timestamp))
+ (cl-call-next-method record slots))))
+
+(cl-defmethod ebdb-init ((record ebdb-record))
+ "Initiate a record after loading a database or creating a new record.
+
+Call `ebdb-init' on all of a record's user fields."
+ (dolist (field (ebdb-record-user-fields record))
+ (ebdb-init field record))
+ (let ((uuid (ebdb-record-uuid record)))
+ (ebdb-puthash uuid record)
+ ;; I don't think there are any cases when we would be at this
+ ;; point in the code and the uuid would already be seen, but...
+ (unless (member uuid ebdb-seen-uuids)
+ (push uuid ebdb-seen-uuids)))
+ (ebdb-record-set-sortkey record))
+
+(cl-defmethod ebdb-merge ((left ebdb-record)
+ (right ebdb-record)
+ &optional _auto)
+ (with-slots (creation-date fields notes)
+ right
+ (with-slots ((lcreation-date creation-date)
+ (lfields fields)
+ (lnotes notes))
+ left
+ (let ((c-time (slot-value creation-date 'timestamp))
+ (lc-time (slot-value lcreation-date 'timestamp)))
+ ;; We're merging all values into LEFT.
+ (setf (slot-value left 'creation-date)
+ (if (or (equal lc-time c-time)
+ (time-less-p c-time lc-time))
+ creation-date
+ lcreation-date))
+ (ebdb-stamp-time left)
+ (setf (slot-value left 'fields)
+ (delete-dups
+ (append fields lfields)))
+ (when (or notes lnotes)
+ (setf (slot-value left 'notes)
+ (mapconcat #'identity (list notes lnotes) "\n\n"))))))
+ left)
+
+(cl-defmethod ebdb-stamp-time ((record ebdb-record))
+ (ebdb-stamp-time (slot-value record 'timestamp)))
+
+(cl-defmethod ebdb-record-change-field ((record ebdb-record) (old-field
ebdb-field) &optional new-field)
+ "Change the values of FIELD belonging to RECORD."
+ (let* ((fieldclass (eieio-object-class old-field))
+ (slot (car (ebdb-record-field-slot-query
+ (eieio-object-class record)
+ (cons nil fieldclass))))
+ (new-field (or new-field (ebdb-read fieldclass nil old-field))))
+ (when (or (null (equal old-field new-field))
+ ebdb-update-unchanged-records)
+ (ebdb-record-delete-field record slot old-field)
+ (ebdb-record-insert-field record slot new-field)
+ new-field)))
+
+(cl-defmethod ebdb-record-insert-field ((record ebdb-record) slot field)
+ "Add FIELD to RECORD's SLOT."
+ ;; First, the databases "actually" add the field to the record, ie
+ ;; persistence. The rest of this method is just updating the
+ ;; existing record instance with the new field.
+ (dolist (db (slot-value (ebdb-record-cache record) 'database))
+ (when field
+ (setq field (ebdb-db-add-record-field db record slot field))))
+ (when field
+ (condition-case nil
+ (object-add-to-list record slot field)
+ (invalid-slot-type
+ (setf (slot-value record slot) field)))
+ (ebdb-init field record))
+ field)
+
+(cl-defmethod ebdb-record-delete-field ((record ebdb-record) slot field)
+ "Delete FIELD from RECORD's SLOT, or set SLOT to nil, if no FIELD."
+ ;; We don't use `slot-makeunbound' because that's a huge pain in the
+ ;; ass, and why would anyone want those errors?
+ (dolist (db (slot-value (ebdb-record-cache record) 'database))
+ (ebdb-db-remove-record-field db record slot field))
+ (if (listp (slot-value record slot))
+ (object-remove-from-list record slot field)
+ (setf (slot-value record slot) nil))
+ (ebdb-delete field record))
+
+(cl-defgeneric ebdb-record-field-slot-query (record-class &optional query
alist)
+ "Ask RECORD-CLASS for information about its interactively-settable fields.
+
+If QUERY is nil, simply return ALIST, which is a full list of
+acceptable fields. Each list element is a cons of the form (SLOT
+. FIELDCLASS), meaning that RECORD-CLASS can accept fields of
+class FIELDCLASS in SLOT.
+
+If QUERY is non-nil, it should be a cons of either '(SLOT . nil),
+or '(nil . FIELDCLASS). The \"nil\" is the value to query for:
+either \"which slot can accept this field class\", or \"which
+fieldclass is appropriate for this slot\". The return value in
+either case is a cons with both slot and fieldclass filled in.")
+
+(cl-defmethod ebdb-record-field-slot-query ((class (subclass ebdb-record))
+ &optional query alist)
+ (let ((alist (append
+ '((notes . ebdb-field-notes)
+ (image . ebdb-field-image))
+ alist))
+ user-class)
+ ;; Pick up all externally-defined user fields.
+ (dolist (f (eieio-build-class-alist 'ebdb-field-user t))
+ (setq user-class (intern (car f)))
+ (unless (rassq user-class alist)
+ (push (cons 'fields user-class) alist)))
+ ;; Look, Ma, I used pcase!
+ (pcase query
+ (`(nil . ,cls)
+ (or (rassq cls alist)
+ (rassq (ebdb-class-in-list-p class (mapcar #'cdr alist))
+ alist)
+ (signal 'ebdb-unacceptable-field (list cls))))
+ (`(,slot . nil)
+ (or (assq slot alist)
+ (signal 'ebdb-unacceptable-field (list slot))))
+ (_ alist))))
+
+(cl-defgeneric ebdb-record-current-fields (record &optional f-list all)
+ "Return an alist of all RECORD's current fields.
+
+Each element of the alist is a cons of (slot-name
+. field-instance), where slot-name is a symbol, and
+field-instance is an instance of a subclass of `ebdb-field'.
+These conses are collected in F-LIST.
+
+If ALL is non-nil, really return all of RECORD's fields. If nil,
+only return fields that are suitable for user editing.")
+
+(cl-defmethod ebdb-record-current-fields ((record ebdb-record)
+ &optional f-list all)
+ "This is the \"bottom-most\" implementation of this method."
+ (with-slots (fields image timestamp creation-date uuid notes) record
+ (dolist (f fields)
+ (push `(fields . ,f) f-list))
+ (when image
+ (push `(image . ,image) f-list))
+ (when all
+ (push `(timestamp . ,timestamp) f-list)
+ (push `(creation-date . ,creation-date) f-list)
+ (push `(uuid . ,uuid) f-list))
+ (when notes
+ (push (cons 'notes notes) f-list)))
+ f-list)
+
+(cl-defmethod ebdb-notice ((_rec ebdb-record))
+ ;; Implement this later.
+ t)
+
+(cl-defmethod ebdb-record-search ((record ebdb-record)
+ (_type (eql name))
+ (regexp string))
+ (or (string-match-p regexp (or (ebdb-record-name record) ""))
+ (seq-find
+ (lambda (n)
+ (string-match-p regexp n))
+ (ebdb-record-alt-names record))
+ (ebdb-field-search (slot-value record 'name) regexp)))
+
+(cl-defmethod ebdb-record-search ((record ebdb-record)
+ (_type (eql notes))
+ (regexp string))
+ (if-let (notes (slot-value record 'notes))
+ (string-match-p regexp (ebdb-string notes))))
+
+(cl-defmethod ebdb-record-search ((record ebdb-record)
+ (_type (eql user))
+ search-clause)
+ (pcase search-clause
+ (`(* . ,(and regexp (pred stringp)))
+ ;; check all user fields
+ (catch 'found
+ (dolist (f (ebdb-record-user-fields record))
+ (when (or (string-match-p regexp (ebdb-string f))
+ (and (slot-exists-p f 'object-name)
+ (string-match-p regexp (slot-value f 'object-name))))
+ (throw 'found t)))
+ ;; so that "^$" can be used to find records that
+ ;; have no notes
+ (when (string-match-p regexp "")
+ (throw 'found t))))
+ (`((,(and field-string (pred stringp)) . ,(and class (pred symbolp))) .
,(and regexp (pred stringp))) ; check one field
+ (catch 'found
+ (if (eql class 'ebdb-field-class-simple)
+ (when (string-match-p
+ regexp (ebdb-string
+ (ebdb-record-user-field record field-string)))
+ (throw 'found t))
+ (dolist (f (ebdb-record-user-fields record))
+ ;; If it's not a `ebdb-field-class-simple', the
+ ;; "field-string" is always going to be the same. Just
+ ;; check if the regexp matches either the label, if there
+ ;; is one, or the value.
+ (when (and (object-of-class-p f class)
+ (or (and (slot-exists-p f 'object-name)
+ (string-match-p regexp (slot-value f
'object-name)))
+ (string-match-p regexp (ebdb-string f))))
+ (throw 'found t))))))
+ (_ nil)))
+
+;; TODO: rename this to `ebdb-record-name-string', it's confusing.
+(cl-defmethod ebdb-record-name ((record ebdb-record))
+ (slot-value (ebdb-record-cache record) 'name-string))
+
+(cl-defmethod ebdb-record-alt-names ((record ebdb-record))
+ (slot-value (ebdb-record-cache record) 'alt-names))
+
+(cl-defmethod ebdb-record-related ((_record ebdb-record)
+ (_field ebdb-field))
+ "Provide a base method that does nothing."
+ nil)
+
+;; The following functions are here because they need to come after
+;; `ebdb-record' has been defined.
+
+(cl-defmethod ebdb-field-image-get ((field ebdb-field-image) (record
ebdb-record))
+ "Return the image for image field FIELD.
+
+This function returns an actual image, suitable for display with
+`insert-image'."
+ (let* ((image-slot (slot-value field 'image))
+ (image
+ (cond ((stringp image-slot)
+ image-slot)
+ ((eq image-slot 'name)
+ (ebdb-string record))
+ (t
+ (ebdb-field-image-function ebdb-image record)))))
+ (when image
+ (create-image
+ (if (stringp image)
+ (if (file-name-absolute-p image)
+ image
+ (locate-file image ebdb-image-path
+ ebdb-image-suffixes))
+ image)))))
+
+(cl-defmethod ebdb-field-image-function ((_field ebdb-field-image) (_record
ebdb-record))
+ "Return image data for RECORD from image field FIELD.
+
+The return value of this function will be passed to
+`create-image', which see. It can either be an image file name,
+or actual image data."
+ ;; Unimplemented.
+ nil)
+
+(cl-defmethod ebdb-field-phone-dial ((_record ebdb-record)
+ (phone ebdb-field-phone))
+ "Make some attempt to call this PHONE number."
+ ;; This won't actually work.
+ (ebdb-dial-number (ebdb-string phone)))
+
+(cl-defmethod ebdb-field-url-browse ((_record ebdb-record)
+ (field ebdb-field-url))
+ (browse-url (slot-value field 'url)))
+
+(cl-defmethod ebdb-field-anniversary-browse ((_record ebdb-record)
+ (_field ebdb-field-anniversary))
+ (require 'calendar)
+ (message "This isn't done yet."))
+
+;;; `ebdb-record' subclasses
+
+(defclass ebdb-record-entity (ebdb-record)
+ ((mail
+ :initarg :mail
+ :type (list-of ebdb-field-mail)
+ :initform nil)
+ (phone
+ :initarg :phone
+ :type (list-of ebdb-field-phone)
+ :initform nil)
+ (address
+ :initarg :address
+ :type (list-of ebdb-field-address)
+ :initform nil))
+ :allow-nil-initform t
+ :abstract t
+ :documentation "An abstract class representing basic entities
+ that have mail, phone and address fields.")
+
+(cl-defmethod ebdb-init ((record ebdb-record-entity))
+ (dolist (phone (slot-value record 'phone))
+ (ebdb-init phone record))
+ (dolist (mail (slot-value record 'mail))
+ (ebdb-init mail record))
+ (dolist (address (slot-value record 'address))
+ (ebdb-init address record))
+ (cl-call-next-method))
+
+;; `ebdb-read' is only called for records on first creation, so we
+;; don't have to worry about existing objects.
+
+(cl-defmethod ebdb-read ((class (subclass ebdb-record-entity)) &optional slots)
+ "Prompt for the basic slot values of `ebdb-record-entity'."
+ (let ((mail (ebdb-loop-with-exit
+ (ebdb-read ebdb-default-mail-class)))
+ (phone (ebdb-loop-with-exit
+ (ebdb-read ebdb-default-phone-class)))
+ (address (ebdb-loop-with-exit
+ (ebdb-read ebdb-default-address-class))))
+ (setq slots (plist-put slots :mail mail))
+ (setq slots (plist-put slots :phone phone))
+ (setq slots (plist-put slots :address address))
+ (cl-call-next-method class slots)))
+
+(cl-defmethod ebdb-delete ((record ebdb-record-entity) &optional _db unload)
+ (dolist (mail (slot-value record 'mail))
+ (ebdb-delete mail record unload))
+ (dolist (field (ebdb-record-user-fields record))
+ (ebdb-delete field record unload))
+ ;; Maybe should also be calling `ebdb-delete' on the phone and
+ ;; address fields, just in case.
+ (cl-call-next-method))
+
+(cl-defmethod ebdb-merge ((left ebdb-record-entity)
+ (right ebdb-record-entity)
+ &optional auto)
+ (with-slots (mail phone address) right
+ (with-slots ((lmail mail) (lphone phone) (laddress address)) left
+ (setf (slot-value left 'mail) (delete-dups (append mail lmail)))
+ (setf (slot-value left 'phone) (delete-dups (append phone lphone)))
+ (setf (slot-value left 'address) (delete-dups (append address
laddress)))))
+ (cl-call-next-method left right auto))
+
+(cl-defmethod ebdb-record-field-slot-query ((class (subclass
ebdb-record-entity)) &optional query alist)
+ (cl-call-next-method
+ class
+ query
+ (append
+ `((mail . ebdb-field-mail)
+ (phone . ebdb-field-phone)
+ (address . ebdb-field-address))
+ alist)))
+
+(cl-defmethod ebdb-record-current-fields ((record ebdb-record-entity)
+ &optional f-list all)
+ (with-slots (mail phone address) record
+ (dolist (m mail)
+ (push `(mail . ,m) f-list))
+ (dolist (p phone)
+ (push `(phone . ,p) f-list))
+ (dolist (a address)
+ (push `(address . ,a) f-list)))
+ (cl-call-next-method record f-list all))
+
+(cl-defmethod ebdb-record-change-name ((record ebdb-record-entity) name)
+ (when (slot-value record 'name)
+ (ebdb-record-delete-field record 'name (slot-value record 'name)))
+ (ebdb-record-insert-field record 'name name))
+
+(cl-defmethod ebdb-record-organizations ((_record ebdb-record-entity))
+ nil)
+
+(cl-defmethod ebdb-record-insert-field :after ((record ebdb-record-entity)
+ _slot
+ (_mail ebdb-field-mail))
+ "After giving RECORD a new mail field, sort RECORD's mails by
+priority."
+ (let ((sorted (ebdb-sort-mails (slot-value record 'mail))))
+ (setf (slot-value record 'mail) sorted)))
+
+(cl-defmethod ebdb-record-primary-mail ((record ebdb-record-entity))
+ "Return the primary mail field of RECORD."
+ (let ((mails (ebdb-record-mail record t)))
+ (object-assoc 'primary 'priority mails)))
+
+(cl-defmethod ebdb-record-search ((record ebdb-record-entity)
+ (_type (eql phone))
+ (regexp string))
+ (let ((phones (ebdb-record-phone record)))
+ (if phones
+ (catch 'found
+ (dolist (ph phones)
+ (when (ebdb-field-search ph regexp)
+ (throw 'found t))))
+ (string-match-p regexp ""))))
+
+(cl-defmethod ebdb-record-search ((record ebdb-record-entity)
+ (_type (eql address))
+ (regexp string))
+ (let ((adds (ebdb-record-address record)))
+ (if adds
+ (catch 'found
+ (dolist (a adds)
+ (when (ebdb-field-search a regexp)
+ (throw 'found t))))
+ (string-match-p regexp ""))))
+
+(cl-defmethod ebdb-record-search ((record ebdb-record-entity)
+ (_type (eql mail))
+ (regexp string))
+ (let ((mails (ebdb-record-mail record t)))
+ (if mails
+ (catch 'found
+ (dolist (m mails)
+ (when (ebdb-field-search m regexp)
+ (throw 'found t))))
+ (string-match-p regexp ""))))
+
+;; TODO: There's no reason why the aka slot can't belong to
+;; `ebdb-record-entity'. In fact, what we ought to do is put both the
+;; 'name and the 'aka slots on `ebdb-record-entity', and have both
+;; slot types set to `ebdb-field-name'. Then provide a fairly simple
+;; mechanism for letting the user choose whether a name/aka should be
+;; simple or complex. Or, when creating or parsing name fields, we
+;; could always start out with the `ebdb-parse' and `ebdb-read'
+;; methods of `ebdb-field-name', which could then dispatch to the
+;; simple/complex methods depending on the initial string values. Or
+;; something like that.
+
+(defclass ebdb-record-person (ebdb-record-entity)
+ ((name
+ :initarg :name
+ :type (or null ebdb-field-name-complex)
+ :initform nil)
+ (aka
+ :initarg :aka
+ :type (list-of ebdb-field-name)
+ :initform nil
+ :accessor ebdb-record-aka)
+ (relations
+ :initarg :relations
+ :type (list-of ebdb-field-relation)
+ :initform nil)
+ (organizations
+ :initarg :organizations
+ :type (list-of ebdb-field-role)
+ :initform nil))
+ :allow-nil-initform t
+ :documentation "A record class representing a person.")
+
+(cl-defmethod ebdb-string ((record ebdb-record-person))
+ "Return a readable string label for RECORD."
+ (slot-value (ebdb-record-cache record) 'name-string))
+
+(cl-defmethod ebdb-read ((class (subclass ebdb-record-person)) &optional slots)
+ "Read the name slot for a \"person\" record."
+ (let* ((name (ebdb-read ebdb-default-name-class (plist-get slots :name))))
+ (cl-call-next-method
+ class (plist-put slots :name name))))
+
+(cl-defmethod ebdb-init ((record ebdb-record-person))
+ (let ((name (slot-value record 'name)))
+ (ebdb-init name record)
+ (setf (slot-value (ebdb-record-cache record) 'name-string) (ebdb-string
name)))
+ (dolist (aka (slot-value record 'aka))
+ (ebdb-init aka record))
+ (dolist (relation (slot-value record 'relations))
+ (ebdb-init relation record))
+ (dolist (role (slot-value record 'organizations))
+ (ebdb-init role record))
+ (cl-call-next-method))
+
+(cl-defmethod ebdb-delete ((record ebdb-record-person) &optional _db unload)
+ (ebdb-delete (slot-value record 'name) record unload)
+ (dolist (a (slot-value record 'aka))
+ (ebdb-delete a record unload))
+ (dolist (r (slot-value record 'relations))
+ (ebdb-delete r record unload))
+ (dolist (o (slot-value record 'organizations))
+ (ebdb-delete o record unload))
+ (cl-call-next-method))
+
+(cl-defmethod ebdb-merge ((left ebdb-record-person)
+ (right ebdb-record-person)
+ &optional auto)
+ "Merge person RIGHT into LEFT, and return LEFT."
+ (with-slots (name
+ aka
+ relations
+ organizations)
+ right
+ (with-slots ((lname name)
+ (laka aka)
+ (lrelations relations)
+ (lorganizations organizations))
+ left
+
+ (if auto
+ (object-add-to-list left 'aka name)
+
+ (if (yes-or-no-p (format "Make %s the primary name? " (ebdb-record-name
right)))
+ (progn
+ (ebdb-record-change-name left name)
+ (when (yes-or-no-p (format "Keep %s as an aka? "
(ebdb-record-name left)))
+ (object-add-to-list left 'aka lname)))
+ (when (yes-or-no-p (format "Keep %s as an aka? " (ebdb-record-name
right)))
+ (object-add-to-list left 'aka name))))
+
+ (setf (slot-value left 'relations)
+ (delete-dups (append relations lrelations)))
+ (setf (slot-value left 'organizations)
+ (delete-dups (append organizations lorganizations)))))
+ (cl-call-next-method left right auto))
+
+(cl-defmethod ebdb-record-field-slot-query ((class (subclass
ebdb-record-person)) &optional query alist)
+ (cl-call-next-method
+ class
+ query
+ (append
+ '((aka . ebdb-field-name-complex)
+ (relations . ebdb-field-relation)
+ (organizations . ebdb-field-role))
+ alist)))
+
+(cl-defmethod ebdb-record-firstname ((rec ebdb-record-person) &optional full)
+ (when (slot-value rec 'name)
+ (ebdb-name-given (slot-value rec 'name) full)))
+
+(cl-defmethod ebdb-record-lastname ((rec ebdb-record-person))
+ (when (slot-value rec 'name)
+ (ebdb-name-last (slot-value rec 'name))))
+
+(cl-defmethod ebdb-record-current-fields ((record ebdb-record-person)
+ &optional f-list all)
+ (with-slots (name aka relations organizations) record
+ (push `(name . ,name) f-list)
+ (dolist (a aka)
+ (push `(aka . ,a) f-list))
+ (dolist (r relations)
+ (push `(relations . ,r) f-list))
+ (dolist (o organizations)
+ (push `(organizations . ,o) f-list)))
+ (cl-call-next-method record f-list all))
+
+;; TODO: Now that both people and organizations have class-based
+;; names, there's no longer any real reason to have two
+;; implementations of this method. One implementation that accepted a
+;; `ebdb-field-name' subclass symbol would be sufficient.
+(cl-defmethod ebdb-record-change-name ((record ebdb-record-person) &optional
name)
+ (let* ((new-name (or name (ebdb-read ebdb-default-name-class nil
+ (slot-value record 'name)))))
+ (setf (slot-value (ebdb-record-cache record) 'name-string) (ebdb-string
new-name))
+ (cl-call-next-method record new-name)))
+
+(cl-defmethod ebdb-record-adopt-role-fields ((record ebdb-record-person)
&optional _prompt)
+ "Go through all of RECORDs fields and see if any of them should
+be moved to an organization role.
+
+Currently only works for mail fields."
+ (let ((roles (slot-value record 'organizations))
+ org domain)
+ (dolist (r roles)
+ (setq org (ebdb-gethash (slot-value r 'org-uuid) 'uuid))
+ (dolist (m (ebdb-record-mail record))
+ (setq domain (cadr (split-string (slot-value m 'mail) "@")))
+ (when (and domain
+ (string-match-p domain
+ (slot-value org 'domain))
+ (yes-or-no-p (format "Move mail %s to organization %s? "
+ (ebdb-string m)
+ (ebdb-string org))))
+ (setf (slot-value r 'mail) m)
+ (ebdb-record-delete-field record 'mail m))))))
+
+(cl-defmethod ebdb-record-related ((_record ebdb-record-person)
+ (field ebdb-field-relation))
+ (ebdb-gethash (slot-value field 'rel-uuid) 'uuid))
+
+(cl-defmethod ebdb-record-related ((_record ebdb-record-person)
+ (field ebdb-field-role))
+ (ebdb-gethash (slot-value field 'org-uuid) 'uuid))
+
+(cl-defmethod ebdb-record-organizations ((record ebdb-record-person))
+ "Return a list of organization string names from RECORD's cache."
+ (slot-value (ebdb-record-cache record) 'organizations))
+
+;;; This needs some more thought.
+;; (cl-defmethod ebdb-mail-set-priority ((mail ebdb-field-mail)
+;; (record ebdb-record-person)
+;; &optional priority)
+;; "Set the priority level for the MAIL address of RECORD to
+;; PRIORITY, if given, or prompt for priority."
+;; ;; How do we get the symbol choices back out of the :custom
+;; ;; declaration? Or is there a better way to keep the values in some
+;; ;; other central location?
+;; (let* ((level (or priority
+;; (intern
+;; (completing-read "Set priority to: "
+;; '(normal primary defunct) nil t
+;; (slot-value mail 'priority) ))))
+;; (new-mail (clone mail :priority level))
+;; orig-primary)
+
+;; (when (eq level 'primary)
+;; (setq
+;; ;; This is horrible
+;; orig-primary
+;; (or
+;; (dolist (m (slot-value record 'mail) orig-primary)
+;; (when (eq (slot-value m 'priority) 'primary)
+;; (setq orig-primary (cons 'rec m))))
+;; (unless orig-primary
+;; (dolist (r (slot-value record 'organizations) orig-primary)
+;; (when (eq (slot-value
+;; (slot-value r 'mail)
+;; 'priority)
+;; 'primary)
+;; (setq orig-primary (cons 'role (slot-value r 'mail)))))))))
+
+;; (when (or (null orig-primary)
+;; (yes-or-no-p (format "Switch primary address to %s? "
(ebdb-string new-mail))))
+;; (if role
+;; (let ((new-role (clone role :mail new-mail)))
+;; (ebdb-record-change-field record role new-role))
+;; (ebdb-record-change-field record mail new-mail))
+;; ;; Unset the original primary address
+;; (when orig-primary
+;; (let ((unset-mail (clone (cdr orig-primary) :priority 'normal)))
+;; (if (eq (car orig-primary) 'rec)
+;; (ebdb-record-change-field record mail unset-mail)
+;; (bbbd-record-change-field
+;; record role (clone role :mail unset-mail))))))))
+
+;;; other record subclasses.
+
+(defclass ebdb-field-domain (ebdb-field)
+ ((domain
+ :initarg :domain
+ :type string
+ :initform ""
+ :documentation))
+ :human-readable "domain"
+ :documentation "An organization's domain name. Useful for
+ automatically constructing a homepage for the organization, or
+ email addresses for member person records.")
+
+(cl-defmethod ebdb-read ((domain (subclass ebdb-field-domain)) &optional slots
obj)
+ (cl-call-next-method
+ domain
+ (plist-put slots :domain
+ (ebdb-read-string "Domain: "
+ (when obj (slot-value obj 'domain))))
+ obj))
+
+(cl-defmethod ebdb-string ((domain ebdb-field-domain))
+ (slot-value domain 'domain))
+
+(defclass ebdb-record-organization (ebdb-record-entity)
+ ((name
+ :initarg :name
+ :type ebdb-field-name-simple
+ :initform nil
+ :documentation "The name of this organization.")
+ (domain
+ :initarg :domain
+ :type (or null ebdb-field-domain)
+ :initform nil
+ :documentation "The base domain name for this organization.
+ This can be used to open the organization's, and also as a
+ default for email addresses of people with roles tied to this
+ organization."))
+ :allow-nil-initform t
+ :documentation "A record class representing an organization.")
+
+(cl-defmethod ebdb-init ((record ebdb-record-organization))
+ (let ((name (slot-value record 'name)))
+ (ebdb-init name record)
+ (setf (slot-value (ebdb-record-cache record) 'name-string)
+ (ebdb-string name))
+ (cl-call-next-method)))
+
+(cl-defmethod ebdb-delete ((org ebdb-record-organization) &optional _db unload)
+ (let* ((uuid (ebdb-record-uuid org))
+ (org-entry (gethash uuid ebdb-org-hashtable))
+ record)
+ (remhash uuid ebdb-org-hashtable)
+ (when (and org-entry
+ (null unload)
+ (yes-or-no-p (format "Delete all roles associated with %s"
+ (ebdb-string org))))
+ (dolist (r org-entry)
+ (setq record (ebdb-gethash (car r) 'uuid))
+ (ebdb-record-delete-field record 'organizations (cdr r))))
+ (cl-call-next-method)))
+
+(cl-defmethod ebdb-string ((record ebdb-record-organization))
+ "Return a string representation of RECORD."
+ (slot-value (ebdb-record-cache record) 'name-string))
+
+(cl-defmethod ebdb-read ((class (subclass ebdb-record-organization)) &optional
slots)
+ (let ((name (ebdb-read 'ebdb-field-name-simple slots
+ (plist-get slots 'name)))
+ (domain (ebdb-with-exit (ebdb-read 'ebdb-field-domain))))
+ (setq slots (plist-put slots :name name))
+ (when domain
+ (setq slots (plist-put slots :domain domain)))
+ (cl-call-next-method class slots)))
+
+(cl-defmethod ebdb-merge ((left ebdb-record-organization)
+ (right ebdb-record-organization)
+ &optional auto)
+ "Merge organization RIGHT into LEFT, and return LEFT."
+ (with-slots (name domain) right
+ (when (or auto (yes-or-no-p (format "Use name %s? " (ebdb-string name))))
+ (ebdb-record-change-name left name))
+ (when (and domain
+ (or auto (yes-or-no-p (format "Use domain %s? " domain))))
+ (setf (slot-value left 'domain) domain)))
+ (cl-call-next-method))
+
+(cl-defmethod ebdb-record-field-slot-query ((class (subclass
ebdb-record-organization))
+ &optional query alist)
+ (cl-call-next-method
+ class
+ query
+ (append
+ '((domain . ebdb-field-domain))
+ alist)))
+
+(cl-defmethod ebdb-record-current-fields ((record ebdb-record-organization)
+ &optional f-list all)
+ (with-slots (name domain) record
+ (push `(name . ,name) f-list)
+ (when domain
+ (push `(domain . ,domain) f-list)))
+ (cl-call-next-method record f-list all))
+
+(cl-defmethod ebdb-record-search ((record ebdb-record-organization)
+ (_type (eql name))
+ (regex string))
+ (string-match-p regex (ebdb-string (slot-value record 'name))))
+
+(cl-defmethod ebdb-record-insert-field :after ((org ebdb-record-organization)
+ _slot
+ (field ebdb-field-domain))
+ (let ((roles (gethash (ebdb-record-uuid org) ebdb-org-hashtable))
+ (domain (slot-value field 'domain))
+ rec)
+ (dolist (r roles)
+ (setq rec (ebdb-gethash (car r) 'uuid))
+ (dolist (m (ebdb-record-mail rec))
+ (when (and (string-match-p domain (slot-value m 'mail))
+ (yes-or-no-p (format "Move address %s of %s to %s role? "
+ (ebdb-string m)
+ (ebdb-string rec)
+ (ebdb-string org))))
+ (setf (slot-value (cdr r) 'mail) m)
+ (ebdb-record-delete-field
+ rec
+ (car (ebdb-record-field-slot-query
+ (eieio-object-class rec)
+ `(nil . ,(eieio-object-class m))))
+ m))))))
+
+(cl-defmethod ebdb-record-change-field ((_record ebdb-record-organization)
+ (old-field ebdb-field-role)
+ &optional new-field)
+ "Change the values of FIELD belonging to RECORD.
+
+This method exists to allow users to edit a role field from an
+organization record. It switches the record being edited to the
+appropriate person record."
+ (let ((record (ebdb-gethash (slot-value old-field 'record-uuid) 'uuid)))
+ (cl-call-next-method record old-field new-field)))
+
+(cl-defmethod ebdb-record-delete-field ((_record ebdb-record-organization)
+ slot
+ (field ebdb-field-role))
+ (let ((record (ebdb-gethash (slot-value field 'record-uuid) 'uuid)))
+ (cl-call-next-method record slot field)))
+
+(cl-defmethod ebdb-record-insert-field :after ((record ebdb-record-person)
+ _slot
+ (field ebdb-field-role))
+ (let* ((org-uuid (slot-value field 'org-uuid))
+ (org (seq-find
+ (lambda (r)
+ (equal org-uuid (ebdb-record-uuid r)))
+ ebdb-record-tracker))
+ (org-domain (slot-value org 'domain))
+ (role-mail (slot-value field 'mail)))
+ (when (and org-domain (not role-mail))
+ (dolist (m (ebdb-record-mail record t))
+ (when (and (string-match-p (slot-value org-domain 'domain) (ebdb-string
m))
+ (yes-or-no-p (format "Move address %s to %s role? "
+ (ebdb-string m) (ebdb-string org))))
+ (setf (slot-value field 'mail) m)
+ (ebdb-record-delete-field
+ record
+ (car (ebdb-record-field-slot-query
+ (eieio-object-class record)
+ `(nil . ,(eieio-object-class m))))
+ m))))))
+
+(cl-defmethod ebdb-record-change-name ((org ebdb-record-organization)
&optional name)
+ (let ((new-name (or name (ebdb-read 'ebdb-field-name-simple nil (slot-value
org 'name)))))
+ (setf (slot-value (ebdb-record-cache org) 'name-string) (ebdb-string
new-name))
+ (cl-call-next-method org new-name)))
+
+(cl-defmethod ebdb-record-related ((_record ebdb-record-organization)
+ (field ebdb-field-role))
+ (ebdb-gethash (slot-value field 'record-uuid) 'uuid))
+
+(defun ebdb-record-add-org-role (record org &optional mail fields)
+ "Convenience function for creating a role relationship between RECORD and
ORG.
+
+MAIL and/or FIELDS, if present, should be a list of field
+instances to add as part of the role."
+ (let ((role (make-instance 'ebdb-field-role
+ :org-uuid (ebdb-record-uuid org)
+ :record-uuid (ebdb-record-uuid record))))
+ (when fields
+ (dolist (f fields)
+ (object-add-to-list role 'fields f)))
+ (when mail
+ (setf (slot-value role 'mail) mail))
+ (ebdb-record-insert-field record 'organizations role)
+ (ebdb-init role record)))
+
+(defclass ebdb-record-mailing-list (ebdb-record eieio-named)
+ ((name
+ :type ebdb-field-name-simple
+ :initarg :name
+ :initform nil))
+ :allow-nil-initform t
+ :documentation "A record class representing a mailing list.")
+
+(cl-defmethod ebdb-read ((_class (subclass ebdb-record-mailing-list))
&optional _db _slots)
+ (error "Mailing list records haven't been implemented yet."))
+
+;;; Merging
+
+;; There should be two kinds of merging: interactive and automatic.
+;; Interactive merging is for when you actually have duplicate records
+;; for the same entity -- this is just a mistake, and should be
+;; handled interactively. Automatic merging happens when you've put a
+;; single record in multiple databases, and they've gotten out of
+;; sync. The merging process detects this by checking the 'uuid and
+;; 'timestamp
+
+(defun ebdb-check-uuid (uuid)
+ "Ensure that UUID hasn't been seen before. If it has, raise an
+error containing the record that already has that uuid."
+ (when (member uuid ebdb-seen-uuids)
+ (signal 'ebdb-duplicate-uuid
+ (list (seq-find
+ (lambda (r)
+ (equal uuid (ebdb-record-uuid r)))
+ ebdb-record-tracker)))))
+
+(defun ebdb-make-uuid (&optional prefix)
+ "Create and return a new UUID.
+
+This depends on the value of `ebdb-uuid-function'. When that
+variable is a string, assume the string refers to a system
+executable. When a symbol, assume an Elisp function."
+ (let ((prefix-string (unless (string-empty-p prefix)
+ (concat prefix "-")))
+ (uid
+ (cond
+ ((stringp ebdb-uuid-function)
+ (shell-command-to-string
+ (executable-find ebdb-uuid-function)))
+ ((functionp ebdb-uuid-function)
+ (funcall ebdb-uuid-function)))))
+ (concat prefix-string
+ (replace-regexp-in-string
+ "[\n\t ]+" ""
+ uid))))
+
+;;; The database class(es)
+
+(defclass ebdb-db (eieio-named eieio-persistent)
+ ;; Is there a need for a "remote" slot?
+ ((uuid
+ :initarg :uuid
+ :initform nil
+ :type (or null ebdb-field-uuid)
+ :documentation
+ "A unique identifier for this database.")
+ (file-header-line
+ :initform ";; EBDB file-persistent database")
+ (sync-time
+ :type (or null cons)
+ :initarg :sync-time
+ :initform nil
+ :documentation "The date/time at which this database was last synced with
its source.")
+ (records
+ :initarg :records
+ :initform nil
+ :type (list-of ebdb-record)
+ :documentation
+ "The records stored in this database.")
+ (read-only
+ :initarg :read-only
+ :initform nil
+ :type boolean
+ :custom boolean
+ :documentation
+ "Is this database read-only?")
+ (version
+ :initarg :version
+ :type string
+ :initform "0.1"
+ :documentation
+ "The version number of this database.")
+ (uuid-prefix
+ :initarg :uuid-prefix
+ :type string
+ :initform ""
+ :custom string
+ :documentation
+ "A string prefix to be added to all UUIDs generated for
+ records created in this database.")
+ (buffer-char
+ :initarg :buffer-char
+ :type string
+ :initform ""
+ :custom string
+ :documentation
+ "A single character used in the *EBDB* buffer to indicate the
+ database(s) to which a record belongs.")
+ (dirty
+ :initarg :dirty
+ :initform nil
+ :type boolean
+ :documentation
+ "Set to t when the database has unsaved data.")
+ (auto-save
+ :initarg :auto-save
+ :initform t
+ :type boolean
+ :custom boolean
+ :documentation
+ "Set to t to have this database auto save itself. Databases
+ that are disabled or read-only will not be saved.")
+ (disabled
+ :initarg :disabled
+ :initform nil
+ :type boolean
+ :custom boolean
+ :documentation
+ "Set to t to temporarily disable this database. Records will
+ not be loaded from or saved to it.")
+ (record-class
+ :initarg :record-class
+ ;; I don't think I can actually set this to `ebdb-record': the
+ ;; type needs to be a class, not an instance. Can I do that?
+ :type symbol
+ :initform nil
+ :custom symbol
+ :documentation
+ "The default EIEIO class for records in this database. Must
+ be a subclass of `ebdb-record'."))
+
+ "The base class for the EBDB database store. This class should
+not be instantiated directly, subclass it instead."
+ :allow-nil-initform t
+ :abstract t)
+
+;; I was told not to use this in Gnus, but I don't remember why. I
+;; suspect it was backward compatibility, and that's obviously already
+;; out the window.
+(oset-default 'ebdb-db record-class ebdb-default-record-class)
+
+(cl-defmethod initialize-instance ((db ebdb-db) &optional slots)
+ "Make sure DB has a uuid."
+ (unless (and (slot-boundp db 'uuid)
+ (slot-value db 'uuid))
+ (setf (slot-value db 'uuid)
+ (make-instance 'ebdb-field-uuid
+ :uuid (ebdb-make-uuid
+ (slot-value db 'uuid-prefix)))))
+ (cl-call-next-method db slots))
+
+;;; Home-made auto saving for `eieio-persistent' objects. The
+;;; `ebdb-db-save' :after method deletes the auto save file, and the
+;;; `ebdb-load' function checks for (and loads) any existing auto save
+;;; files.
+
+(defun ebdb-db-make-auto-save-file-name (filename)
+ "Make an auto save file name from FILENAME."
+ ;; What I'd really like to do, obviously, is to use the built in
+ ;; `make-auto-save-file-name'. You can't pass that function your
+ ;; own filename, though, so we'll make a (highly) watered-down
+ ;; version of that.
+ (let ((expanded (expand-file-name filename)))
+ (concat (file-name-directory expanded)
+ "#"
+ (file-name-nondirectory expanded)
+ "#")))
+
+(cl-defmethod ebdb-db-do-auto-save ((db ebdb-db))
+ (let ((auto-save-file
+ (ebdb-db-make-auto-save-file-name
+ (slot-value db 'file))))
+ (eieio-persistent-save db auto-save-file)))
+
+(defun ebdb-auto-save-databases ()
+ "Auto-save all EBDB databases.
+
+Run as a hook in the `auto-save-hook"
+ (dolist (d ebdb-db-list)
+ (with-slots (auto-save disabled read-only) d
+ (when (and auto-save
+ (null disabled)
+ (null read-only)
+ (ebdb-db-dirty d))
+ (ebdb-db-do-auto-save d)))))
+
+(add-hook 'auto-save-hook #'ebdb-auto-save-databases)
+
+;;; Database subclasses will have their own specialization of
+;;; `ebdb-db-load', which is responsible for somehow getting the
+;;; records into the DB's "records" slot. Once that's done, they
+;;; should call `cl-call-next-method' to run the methods below.
+
+(cl-defmethod ebdb-db-unsynced ((db ebdb-db))
+ "Return t if DB's persistence file has been accessed since the
+last time DB was loaded.
+
+This is the base implementation, which only checks if DB's
+persistence file has been accessed. Subclasses should combine
+this check with their own check to see if their records are
+somehow out of sync.
+
+\"Unsynced\" is different from \"dirty\". Dirty just means the
+DB has unsaved changes. Unsynced means that saving those
+changes (or re-loading the database from its source) would
+overwrite data somewhere."
+ (let ((file-access-time
+ (nth 4
+ (file-attributes
+ (expand-file-name (slot-value db 'file))))))
+ (and file-access-time
+ (time-less-p (slot-value db 'sync-time) file-access-time))))
+
+(cl-defmethod ebdb-db-dirty ((db ebdb-db))
+ "Return t if DB is marked dirty, or contains any dirty records."
+ (or (slot-value db 'dirty)
+ (ebdb-dirty-records (slot-value db 'records))))
+
+(cl-defmethod ebdb-db-load ((db ebdb-db))
+ "Complete the loading procedure for DB."
+ ;; By this point, all the DB's records are in its record slot.
+ (dolist (rec (slot-value db 'records) t)
+
+ ;; Cycle over each loaded record.
+ (condition-case err
+ (progn
+ ;; First, tell it about the database.
+ (object-add-to-list (ebdb-record-cache rec)
+ 'database db)
+
+ ;; Make sure its UUID is unique.
+ (ebdb-check-uuid (ebdb-record-uuid rec))
+
+ ;; Lastly initialize it. This has to come after
+ ;; `ebdb-check-uuid' because it adds the record's UUID to
+ ;; `ebdb-seen-uuids'.
+ (ebdb-init rec))
+
+ (ebdb-duplicate-uuid
+ ;; There's a duplicate, decide what to do about it. In the
+ ;; following, "double" refers to the already-loaded record that
+ ;; has the same uuid. We start off assuming that we will
+ ;; delete this existing "double", and replace it with the
+ ;; newly-loaded record ("rec").
+ (let* ((double (cadr err))
+ (delete-double t)
+ (equal (equal (clone rec :cache nil)
+ (clone double :cache nil)))
+ deleter keeper)
+
+ ;; If any of the double's databases are read-only, we should
+ ;; switch our assumptions about which record to delete. This
+ ;; at least gives us a fighting chance to update a writeable
+ ;; database from a read-only one, and avoid an error.
+ (dolist (d (slot-value (ebdb-record-cache double) 'database))
+ (when (slot-value d 'read-only)
+ (setq delete-double nil)))
+
+ ;; If the records are the same, it doesn't matter which we
+ ;; delete, so don't change our assumption.
+ (unless equal
+
+ ;; But if double is newer, we still need to keep it.
+ (unless (ebdb-record-compare rec double 'timestamp)
+ (setq delete-double nil)))
+
+ (setq deleter (if delete-double double rec)
+ keeper (if delete-double rec double))
+
+ ;; Merge the records, either automatically or
+ ;; interactively, depending on the value of
+ ;; `ebdb-auto-merge-records'.
+ (unless equal
+ (setq keeper (ebdb-merge keeper deleter ebdb-auto-merge-records)))
+
+ (dolist (d (slot-value (ebdb-record-cache deleter) 'database))
+ ;; Use low-level functions for this so we don't set the
+ ;; database dirty.
+ (object-remove-from-list db 'records deleter)
+ (object-add-to-list db 'records keeper)
+ (object-add-to-list (ebdb-record-cache keeper)
+ 'database d))
+ (ebdb-delete deleter)
+ ;; Double was initialized, rec wasn't. If we end up keeping
+ ;; rec, we need to initialize it.
+ (when delete-double
+ (ebdb-init keeper)))))))
+
+(cl-defmethod ebdb-db-unload ((db ebdb-db))
+ "Unload database DB.
+
+This involves going through DB's records and removing each one
+that doesn't belong to a different database."
+ (dolist (r (slot-value db 'records))
+ ;; Only disappear the record if it doesn't belong to any other
+ ;; databases.
+ (if (= 1 (length (slot-value (ebdb-record-cache r) 'database)))
+ (ebdb-delete r db t)
+ (object-remove-from-list (ebdb-record-cache r) 'database db))
+ (object-remove-from-list db 'records r)))
+
+(defun ebdb-db-reload (db)
+ (ebdb-db-unload db)
+ (ebdb-db-load db))
+
+(cl-defmethod ebdb-record-compare ((left ebdb-record)
+ (right ebdb-record)
+ (_test (eql timestamp)))
+ "Test if record LEFT is newer than record RIGHT."
+ (let ((left-time (slot-value (slot-value left 'timestamp) 'timestamp))
+ (right-time (slot-value (slot-value right 'timestamp) 'timestamp)))
+ (or (equal left-time right-time)
+ (time-less-p left-time right-time))))
+
+(cl-defmethod ebdb-db-load :after ((db ebdb-db))
+ (cl-pushnew db ebdb-db-list)
+ (setf (slot-value db 'sync-time) (current-time))
+ (run-hook-with-args 'ebdb-after-read-db-hook db))
+
+;; This is totally goofy, it's just replacing the method overloading
+;; mechanism with the hook mechanism.
+(cl-defmethod ebdb-db-load :before ((db ebdb-db))
+ (run-hook-with-args 'ebdb-before-read-db-hook db))
+
+(cl-defmethod ebdb-db-editable ((db ebdb-db) &optional noerror reload)
+ "Check that DB is in an editable state, and signal an error if
+it isn't. This method is called before most operations that
+would alter DB.
+
+With optional argument NOERROR, return nil instead of signalling
+an error. With optional argument RELOAD, reload DB if it is out
+of sync but has no local modifications."
+ (let ((err
+ (cond ((slot-value db 'read-only)
+ 'ebdb-readonly-db)
+ ((slot-value db 'disabled)
+ 'ebdb-disabled-db)
+ ((ebdb-db-unsynced db)
+ (if (and (null (ebdb-db-dirty db))
+ reload)
+ (progn
+ (ebdb-db-reload db)
+ nil)
+ 'ebdb-unsynced-db))
+ (t nil))))
+ (or (not err)
+ (if noerror
+ nil
+ (signal err (list db))))))
+
+(cl-defmethod ebdb-db-save :before ((db ebdb-db) &optional _prompt)
+ "Prepare DB to be saved."
+ (when (ebdb-db-dirty db)
+ (ebdb-db-editable db)))
+
+(cl-defmethod ebdb-db-save ((db ebdb-db) &optional _prompt)
+ "Save DB to its persistence file.
+
+This method is only responsible for saving the database
+definition to disk. Database subclasses are responsible for
+saving or otherwise persisting their records, and setting
+their :records slot to nil before calling this method with
+`cl-call-next-method'. They can either catch errors thrown by
+the persistent save, or allow them to propagate."
+ (eieio-persistent-save db))
+
+(cl-defmethod ebdb-db-save :after ((db ebdb-db) &optional _prompt)
+ "After saving DB, also delete its auto-save file, if any."
+ (let ((auto-save-file
+ (ebdb-db-make-auto-save-file-name
+ (slot-value db 'file))))
+ (setf (slot-value db 'sync-time) (current-time))
+ (when (file-exists-p auto-save-file)
+ (delete-file auto-save-file))))
+
+(cl-defmethod ebdb-db-add-record :before ((db ebdb-db) _record)
+ (ebdb-db-editable db))
+
+(cl-defmethod ebdb-db-remove-record :before ((db ebdb-db) _record)
+ (ebdb-db-editable db))
+
+(cl-defmethod ebdb-db-add-record ((db ebdb-db) record)
+ "Associate RECORD with DB."
+ ;; This function gets called when creating a new record, and also
+ ;; when "adopting" an existing record. In the first case, it
+ ;; won't have a UUID slot.
+ (unless (slot-value record 'uuid)
+ (setf (slot-value record 'uuid)
+ (make-instance
+ 'ebdb-field-uuid
+ :uuid (ebdb-make-uuid (slot-value db 'uuid-prefix)))))
+ (object-add-to-list db 'records record)
+ ;; TODO: Is there any need to sort the DB's records after insertion?
+ ;; What about sorting ebdb-record-tracker?
+ (object-add-to-list (ebdb-record-cache record)
+ 'database db)
+ record)
+
+(cl-defmethod ebdb-db-remove-record ((db ebdb-db) record)
+ "Disassociate RECORD from DB."
+ (object-remove-from-list db 'records record)
+ (object-remove-from-list (ebdb-record-cache record)
+ 'database db)
+ record)
+
+(cl-defmethod ebdb-db-add-record-field :before ((db ebdb-db) record _slot
_field)
+ (ebdb-db-editable db)
+ (ebdb-stamp-time record))
+
+(cl-defmethod ebdb-db-remove-record-field :before ((db ebdb-db) record _slot
_field)
+ (ebdb-db-editable db)
+ (ebdb-stamp-time record))
+
+(cl-defmethod ebdb-string ((db ebdb-db))
+ (format "Database: %s" (slot-value db 'file)))
+
+(defun ebdb-db-disable (db)
+ (interactive (list (ebdb-prompt-for-db)))
+ (if (ebdb-db-dirty db)
+ (message "Database %s has unsaved changes, you should save it first."
+ (ebdb-string db))
+ (setf (slot-value db 'disabled) t)
+ (setf (slot-value db 'dirty) t)
+ (ebdb-db-save db)
+ (ebdb-db-unload db)
+ (message "Database %s is disabled." (ebdb-string db))))
+
+(cl-defmethod ebdb-db-customize ((db ebdb-db))
+ (require 'eieio-custom)
+ (eieio-customize-object db))
+
+(defun ebdb-customize-database (db)
+ "Use the customization interface to edit slot values of DB."
+ (interactive (list (ebdb-prompt-for-db)))
+ (ebdb-db-customize db))
+
+(cl-defmethod eieio-done-customizing ((db ebdb-db))
+ (setf (slot-value db 'dirty) t)
+ (cl-call-next-method))
+
+;;; The cache class
+
+;; This probably bears some re-thinking. It would be nice to make it
+;; behave as a "real" cache, in the sense that all the accessors are
+;; accessors on the records themselves -- the records don't need to be
+;; aware of the cache. The (probably multiple) cache classes should
+;; be parent classes, not slots on the record (or rather, the cache
+;; slot on the record comes from the cache parent class). We ask the
+;; record for information, and the cache method intercepts the call,
+;; returns the value if it has it, and if not then asks the record for
+;; the value then stores it. Ie, a real cache. Not all the cache
+;; slots would work that way, of course -- for instance. a record has
+;; no way of knowing its databases except via the cache.
+
+(defclass ebdb-cache ()
+ ((name-string
+ :initarg :name-string
+ :type string
+ :initform nil
+ :documentation "The \"canonical\" name for the record, as
+ displayed in the *EBDB* buffer.")
+ (alt-names
+ :initarg :alt-names
+ :type (list-of string)
+ :initform nil
+ :documentation "A list of strings representing all other
+ alternate names for this record.")
+ (organizations
+ :initarg :organizations
+ :type list
+ :initform nil
+ :documentation
+ "A list of strings representing the organizations this record
+ is associated with.")
+ (mail-aka
+ :initarg :mail-aka
+ :type list
+ :initform nil)
+ (mail-canon
+ :initarg :mail-canon
+ :type list
+ :initform nil)
+ (sortkey
+ :initarg :sortkey
+ :type string
+ :initform nil)
+ (database
+ :initarg :database
+ :type (list-of ebdb-db)
+ :initform nil
+ :documentation
+ "The database(s) this record belongs to."))
+ ;; I'm not sure if a marker slot is still going to be necessary in
+ ;; this setup.
+ :allow-nil-initform t)
+
+;;; Subclasses of `ebdb-db'.
+
+;; File-based database, keeping its records in-file.
+
+(defclass ebdb-db-file (ebdb-db)
+ nil
+ :documentation "A `ebdb-db' subclass that saves records
+ directly in its persistence file.")
+
+(cl-defmethod object-print ((db ebdb-db-file) &optional strings)
+ (cl-call-next-method
+ db
+ (append strings (format " %d records" (length (slot-value db 'records))))))
+
+;; `ebdb-db-file' doesn't need a `ebdb-db-load' method. Its records
+;; are stored in its persistence file, directly in the :records slot,
+;; so simply reading the object in with `eieio-persistent-read' does
+;; all the set up we need.
+
+(cl-defmethod ebdb-db-save ((db ebdb-db-file) &optional _prompt)
+ "Mark DB and all its records as \"clean\" after saving."
+ (let ((recs (ebdb-dirty-records (slot-value db 'records))))
+ ;; Don't do anything if nothing's dirty. Later we can have a
+ ;; "force" argument.
+ (when (or recs (slot-value db 'dirty))
+ ;; These slots must be set to nil, or else we'll write ":dirty
+ ;; t" slot values to file, which would be nonsensical.
+ (setf (slot-value db 'dirty) nil)
+ (dolist (r recs)
+ (setf (slot-value r 'dirty) nil))
+ (condition-case err
+ ;; This does the actual writing to file.
+ (cl-call-next-method)
+ (error
+ (setf (slot-value db 'dirty) t)
+ (dolist (r recs)
+ (setf (slot-value r 'dirty) t))
+ (signal 'error err))))))
+
+(cl-defmethod initialize-instance ((db ebdb-db-file) &optional slots)
+ (let ((object-name (concat "File: " (plist-get slots :file))))
+ (setq slots (plist-put slots :object-name object-name))
+ (cl-call-next-method db slots)))
+
+(cl-defmethod ebdb-db-add-record ((db ebdb-db-file) record)
+ "Mark DB and RECORD as \"dirty\" until saved."
+ (setf (slot-value record 'dirty) t)
+ (setf (slot-value db 'dirty) t)
+ (cl-call-next-method))
+
+(cl-defmethod ebdb-db-remove-record ((db ebdb-db-file) _record)
+ "Mark DB as \"dirty\" until saved."
+ (setf (slot-value db 'dirty) t)
+ (cl-call-next-method))
+
+(cl-defmethod ebdb-db-add-record-field
+ ((db ebdb-db-file) record _slot field)
+ (setf (slot-value record 'dirty) t)
+ (setf (slot-value db 'dirty) t)
+ field)
+
+(cl-defmethod ebdb-db-remove-record-field
+ ((db ebdb-db-file) record _slot _field)
+ (setf (slot-value record 'dirty) t)
+ (setf (slot-value db 'dirty) t)
+ t)
+
+(cl-defmethod object-write ((record ebdb-record) &optional comment)
+ "Don't write RECORD's cache to file."
+ ;; Instead, write a clone of RECORD with the cache slot blanked out.
+ (let ((clone (clone record :cache nil)))
+ (cl-call-next-method clone comment)))
+
+(defun ebdb-clear-vars ()
+ "Set all internal EBDB vars to nil."
+ (setq ebdb-db-list nil
+ ebdb-record-tracker nil
+ ebdb-seen-uuids nil)
+ (clrhash ebdb-org-hashtable)
+ (clrhash ebdb-hashtable))
+
+;; Changing which database a record belongs to.
+
+(defun ebdb-move-record (record to-db)
+ "Move RECORD from its existing database to TO-DB."
+ (interactive
+ (list (ebdb-current-record)
+ (ebdb-prompt-for-db)))
+ ;; It's not quite right to assume that we're *only* removing the
+ ;; record from the first db in its list of dbs.
+ (let ((existing (car (slot-value (ebdb-record-cache record)
+ 'database))))
+ (if (equal existing to-db)
+ (message "Can't move record into same database")
+ (ebdb-db-add-record to-db record)
+ (ebdb-db-remove-record existing record))))
+
+(defun ebdb-copy-record (record to-db)
+ "Copy RECORD into TO-DB."
+ (interactive
+ (list (ebdb-current-record)
+ (ebdb-prompt-for-db)))
+ (ebdb-db-add-record to-db record))
+
+;;; Utility functions
+
+(defun ebdb-class-in-list-p (class list)
+ "Check if CLASS is a member of LIST.
+
+Both CLASS and the members of LIST should be class-name symbols.
+CLASS is \"in\" list if the symbol appears directly in the list,
+or if CLASS is a subclass of one of the classes in LIST. The
+function returns t in the first case, and the parent class symbol
+in the second."
+ (catch 'member
+ (progn
+ ;; First, the easy check.
+ (when (memq class list)
+ (throw 'member t))
+ (dolist (c list nil)
+ (when (child-of-class-p class c)
+ (throw 'member c))))))
+
+(defun ebdb-dirty-dbs (&optional dbs)
+ "Return all databases marked \"dirty\"."
+ (let (dirty)
+ (dolist (d (or dbs ebdb-db-list))
+ (when (ebdb-db-dirty d)
+ (push d dirty)))
+ dirty))
+
+(defun ebdb-unsynced-dbs (&optional dbs)
+ "Return any databases that are out of sync with their source."
+ (let (unsynced)
+ (dolist (d (or dbs ebdb-db-list))
+ (when (ebdb-db-unsynced d)
+ (push d unsynced)))
+ unsynced))
+
+(defun ebdb-prompt-for-record (&optional records class)
+ "Prompt for a single record, and return it.
+If RECORDS is a list of records, offer choices from that list. If
+CLASS is given, only offer choices that are an instance of that
+class, or its subclasses."
+ (let* ((recs (or records ebdb-record-tracker))
+ (pairs
+ (mapcar
+ (lambda (r)
+ ;; This is bad, doesn't take into account all the
+ ;; different strings that might be used to find a record.
+ (cons
+ (ebdb-string r)
+ (ebdb-record-uuid r)))
+ (if class
+ (seq-filter
+ (lambda (r)
+ (object-of-class-p r class))
+ recs)
+ recs)))
+ (result
+ (completing-read
+ "Choose record: "
+ pairs)))
+ (ebdb-gethash (cdr (assoc-string result pairs)) 'uuid)))
+
+(defun ebdb-prompt-for-field-type (fields)
+ "Prompt the user for a field from FIELDS.
+
+Returns a list of (\"label\" slot . field-class)."
+ ;; Fields that have labels will provide those labels as a sort of
+ ;; "second level" of choice. So our top-level choices should be:
+ ;; mail, address, phone, notes, all subclasses of ebdb-field-user,
+ ;; and then the labels in ebdb-user-label-list. With a
+ ;; non-completing string assumed to be a new label for a
+ ;; ebdb-user-field-simple.
+
+ (let* (field field-list choice)
+ (dolist (c fields)
+ ;; Find a less-ugly way of doing this.
+ (setq field (cdr c))
+ (unless (or (eq field 'ebdb-field-user-simple)
+ (eq field 'ebdb-field-creation-date)
+ (eq field 'ebdb-field-timestamp))
+ (push (list (ebdb-field-readable-name field) c) field-list)))
+ (dolist (l ebdb-user-label-list)
+ (push (list l (cons 'fields 'ebdb-field-user-simple)) field-list))
+ (setq choice
+ (completing-read
+ "Choose field type: "
+ field-list))
+ (or (assoc choice field-list)
+ (list choice (cons 'fields 'ebdb-field-user-simple)))))
+
+(defun ebdb-prompt-for-db (&optional db-list)
+ (let* ((collection (or db-list ebdb-db-list))
+ (db-string
+ (ebdb-read-string "Choose a database: "
+ nil
+ (mapcar
+ (lambda (d)
+ (slot-value d 'object-name))
+ collection)
+ t)))
+ (object-assoc db-string 'object-name collection)))
+
+(defun ebdb-dirty-records (&optional records)
+ "Return all records with unsaved changes.
+
+If RECORDS are given, only search those records."
+ (seq-filter
+ (lambda (r)
+ (slot-value r 'dirty))
+ (or records ebdb-record-tracker)))
+
+;;; Getters
+
+;; The simplest of getters/setters are defined with an :accessor tag
+;; on the class slot definition itself. Ie, `ebdb-record-user-fields'
+;; and `ebdb-record-cache'.
+
+(defun ebdb-record-cache (record)
+ (slot-value record 'cache))
+
+(defun ebdb-record-user-fields (record)
+ (slot-value record 'fields))
+
+(defun ebdb-record-user-field (record label)
+ (object-assoc (if (stringp label)
+ label
+ (symbol-name label))
+ 'object-name (ebdb-record-user-fields record)))
+
+(defun ebdb-record-address (record &optional label)
+ (let ((addresses (slot-value record 'address)))
+ (if label
+ (object-assoc label 'object-name addresses)
+ addresses)))
+
+(defun ebdb-record-phone (record &optional label)
+ (let ((phones (slot-value record 'phone)))
+ (if label
+ (object-assoc label 'object-name phones)
+ phones)))
+
+(defun ebdb-record-mail (record &optional roles label)
+ (let ((mails (slot-value record 'mail)))
+ (when (and roles (slot-exists-p record 'organizations))
+ (dolist (r (slot-value record 'organizations))
+ (when (and (slot-value r 'mail)
+ (null (slot-value r 'defunct)))
+ (push (slot-value r 'mail) mails))))
+ (if label
+ (object-assoc label 'object-name mails)
+ mails)))
+
+
+;;; Record editing
+
+(defcustom ebdb-case-fold-search (default-value 'case-fold-search)
+ "Value of `case-fold-search' used by EBDB and friends.
+This variable lets the case-sensitivity of the EBDB commands
+be different from standard commands like command `isearch-forward'."
+ :group 'ebdb-record-edit
+ :type 'boolean)
+
+;; The following two options should be obviated by ebdb-i18n.el
+;; See http://en.wikipedia.org/wiki/Postal_address
+;;
http://www.upu.int/en/activities/addressing/postal-addressing-systems-in-member-countstateries.html
+(defcustom ebdb-address-format-list
+ '(((arg) "splrc" "@address@hidden, @%l@, address@hidden@" "@%l@")
+ ((aus) "slrpc" "@address@hidden@ %r@ address@hidden@" "@%l@")
+ ((aut due esp che)
+ "splrc" "@address@hidden @%l@ (%r)@\n%c@" "@%l@")
+ ((can) "slrcp" "@address@hidden@, address@hidden@ %p@" "@%l@")
+ ((chn) "slprc" "@address@hidden@\n%p@ address@hidden@" "@%l@") ; English
format
+ ; (("China") "cprls" "@%c @address@hidden @%l@ %s@" "@%l@") ; Chinese
format
+ ((ind) "slprc" "@address@hidden@ %p@ (%r)@\n%c@" "@%l@")
+ ((usa) "slrpc" "@address@hidden@, %r@ address@hidden@" "@%l@")
+ (t ebdb-edit-address-default ebdb-format-address-default "@%l@"))
+ "List of address editing and formatting rules for EBDB.
+Each rule is a list (IDENTIFIER EDIT FORMAT FORMAT).
+The first rule for which IDENTIFIER matches an address is used for editing
+and formatting the address.
+
+IDENTIFIER may be a list of countries.
+IDENTIFIER may also be a function that is called with one arg, the address
+to be used. The rule applies if the function returns non-nil.
+See `ebdb-address-continental-p' for an example.
+If IDENTIFIER is t, this rule always applies. Usually, this should be
+the last rule that becomes a fall-back (default).
+
+EDIT may be a function that is called with one argument, the address.
+See `ebdb-edit-address-default' for an example.
+
+EDIT may also be an editting format string. It is a string containing
+the five letters s, c, p, S, and C that specify the order for editing
+the five elements of an address:
+
+s streets
+l locality
+p postcode
+r region
+c country
+
+The first FORMAT of each rule is used for multi-line layout, the second FORMAT
+is used for one-line layout.
+
+FORMAT may be a function that is called with one argument, the address.
+See `ebdb-format-address-default' for an example.
+
+FORMAT may also be a format string. It consists of formatting elements
+separated by a delimiter defined via the first (and last) character of FORMAT.
+Each formatting element may contain one of the following format specifiers:
+
+%s streets (used repeatedly for each street part)
+%l locality
+%p postcode
+%r region
+%c country
+
+A formatting element will be applied only if the corresponding part
+of the address is a non-empty string.
+
+See also `ebdb-print-address-format-list'."
+ :group 'ebdb-record-edit
+ :type '(repeat (list (choice (const :tag "Default" t)
+ (function :tag "Function")
+ (repeat (string)))
+ (choice (string)
+ (function :tag "Function"))
+ (choice (string)
+ (function :tag "Function"))
+ (choice (string)
+ (function :tag "Function")))))
+
+(defcustom ebdb-continental-postcode-regexp
+ "^\\s *[A-Z][A-Z]?\\s *-\\s *[0-9][0-9][0-9]"
+ "Regexp matching continental postcodes.
+Used by address format identifier `ebdb-address-continental-p'.
+The regexp should match postcodes of the form CH-8052, NL-2300RA,
+and SE-132 54."
+ :group 'ebdb-record-edit
+ :type 'regexp)
+
+(defcustom ebdb-default-separator '("[,;]" ", ")
+ "The default field separator. It is a list (SPLIT-RE JOIN).
+This is used for fields which do not have an entry in `ebdb-separator-alist'."
+ :group 'ebdb-record-edit
+ :type '(list regexp string))
+
+(defcustom ebdb-separator-alist
+ '((record "\n\n" "\n\n") ; used by `ebdb-copy-fields-as-kill'
+ (name-first-last "[ ,;]" " ") (name-last-first "[ ,;]" ", ")
+ (name-field ":\n" ":\n") ; used by `ebdb-copy-fields-as-kill'
+ (phone "[,;]" ", ") (address ";\n" ";\n") ; ditto
+ (organization "[,;]" ", ") (affix "[,;]" ", ") (aka "[,;]" ", ")
+ (mail "[,;]" ", ") (mail-alias "[,;]" ", ") (vm-folder "[,;]" ", ")
+ (birthday "\n" "\n") (wedding "\n" "\n") (anniversary "\n" "\n")
+ (notes "\n" "\n"))
+ "Alist of field separators.
+Each element is of the form (FIELD SPLIT-RE JOIN).
+For fields lacking an entry here `ebdb-default-separator' is used instead."
+ :group 'ebdb-record-edit
+ :type '(repeat (list symbol regexp string)))
+
+(defcustom ebdb-image-path nil
+ "List of directories to search for `ebdb-image'."
+ :group 'ebdb-record-edit
+ :type '(repeat (directory)))
+
+(defcustom ebdb-image-suffixes '(".png" ".jpg" ".gif" ".xpm")
+ "List of file name suffixes searched for `ebdb-image'."
+ :group 'ebdb-record-edit
+ :type '(repeat (string :tag "File suffix")))
+
+(defcustom ebdb-read-name-articulate nil
+ "Specify how to read record names.
+
+If nil, read full names as single strings, and parse them
+accordingly. If t, the user will be prompted separately for each
+field of the name.
+
+If this option is nil, and the user enters a single string, the
+resulting name field will be an instance of
+`ebdb-field-name-simple'. Even if this option is t, the user can
+still trigger the creation of a simple name field by entering a
+single string for the surname, and nothing else."
+ :group 'ebdb-record-edit
+ :type 'boolean)
+
+(defcustom ebdb-lastname-prefixes
+ '("von" "de" "di")
+ "List of lastname prefixes recognized in name fields.
+Used to enhance dividing name strings into firstname and lastname parts.
+Case is ignored."
+ :group 'ebdb-record-edit
+ :type '(repeat string))
+
+(defcustom ebdb-lastname-re
+ (concat "[- \t]*\\(\\(?:\\<"
+ (regexp-opt ebdb-lastname-prefixes)
+ ;; multiple last names concatenated by `-'
+ "\\>[- \t]+\\)?\\(?:\\w+[ \t]*-[ \t]*\\)*\\w+\\)\\'")
+ "Regexp matching the last name of a full name.
+Its first parenthetical subexpression becomes the last name."
+ :group 'ebdb-record-edit
+ :type 'regexp)
+
+(defcustom ebdb-lastname-suffixes
+ '("Jr" "Sr" "II" "III")
+ "List of lastname suffixes recognized in name fields.
+Used to dividing name strings into firstname and lastname parts.
+All suffixes are complemented by optional `.'. Case is ignored."
+ :group 'ebdb-record-edit
+ :type '(repeat string))
+
+(defcustom ebdb-lastname-suffix-re
+ (concat "[-,. \t/\\]+\\("
+ (regexp-opt ebdb-lastname-suffixes)
+ ;; suffices are complemented by optional `.'.
+ "\\.?\\)\\W*\\'")
+ "Regexp matching the suffix of a last name.
+Its first parenthetical subexpression becomes the suffix."
+ :group 'ebdb-record-edit
+ :type 'regexp)
+
+(defcustom ebdb-default-domain nil
+ "Default domain to append when reading a new mail address.
+If a mail address does not contain address@hidden', append
@`ebdb-default-domain' to it.
+
+The address is not altered if `ebdb-default-domain' is nil
+or if a prefix argument is given to the command `ebdb-insert-field'."
+ :group 'ebdb-record-edit
+ :type '(choice (const :tag "none" nil)
+ (string :tag "Default Domain")))
+
+(defcustom ebdb-allow-duplicates nil
+ "When non-nil EBDB allows records with duplicate names and email addresses.
+In rare cases, this may lead to confusion with EBDB's MUA interface."
+ :group 'ebdb-record-edit
+ :type 'boolean)
+
+(defcustom ebdb-default-label-list '("home" "work" "other")
+ "Default list of labels for Address and Phone fields."
+ :group 'ebdb-record-edit
+ :type '(repeat string))
+
+(defcustom ebdb-address-label-list ebdb-default-label-list
+ "List of labels for Address field."
+ :group 'ebdb-record-edit
+ :type '(repeat string))
+
+(defcustom ebdb-phone-label-list '("home" "work" "cell" "fax" "other")
+ "List of labels for Phone field."
+ :group 'ebdb-record-edit
+ :type '(repeat string))
+
+(defcustom ebdb-default-country "Emacs";; what do you mean, it's not a country?
+ "Default country to use if none is specified."
+ :group 'ebdb-record-edit
+ :type '(choice (const :tag "None" nil)
+ (string :tag "Default Country")))
+
+(defcustom ebdb-check-postcode t
+ "If non-nil, require legal postcodes when entering an address.
+The format of legal postcodes is determined by the variable
+`ebdb-legal-postcodes'."
+ :group 'ebdb-record-edit
+ :type 'boolean)
+
+(defcustom ebdb-legal-postcodes
+ '(;; empty string
+ "^$"
+ ;; Matches 1 to 6 digits.
+ "^[ \t\n]*[0-9][0-9]?[0-9]?[0-9]?[0-9]?[0-9]?[ \t\n]*$"
+ ;; Matches 5 digits and 3 or 4 digits.
+ "^[ \t\n]*\\([0-9][0-9][0-9][0-9][0-9]\\)[ \t\n]*-?[
\t\n]*\\([0-9][0-9][0-9][0-9]?\\)[ \t\n]*$"
+ ;; Match postcodes for Canada, UK, etc. (result is ("LL47" "U4B")).
+ "^[ \t\n]*\\([A-Za-z0-9]+\\)[ \t\n]+\\([A-Za-z0-9]+\\)[ \t\n]*$"
+ ;; Match postcodes for continental Europe. Examples "CH-8057"
+ ;; or "F - 83320" (result is ("CH" "8057") or ("F" "83320")).
+ ;; Support for "NL-2300RA" added at request from Carsten Dominik
+ ;; <address@hidden>
+ "^[ \t\n]*\\([A-Z]+\\)[ \t\n]*-?[ \t\n]*\\([0-9]+ ?[A-Z]*\\)[ \t\n]*$"
+ ;; Match postcodes from Sweden where the five digits are grouped 3+2
+ ;; at the request from Mats Lofdahl <address@hidden>.
+ ;; (result is ("SE" (133 36)))
+ "^[ \t\n]*\\([A-Z]+\\)[ \t\n]*-?[ \t\n]*\\([0-9]+\\)[ \t\n]+\\([0-9]+\\)[
\t\n]*$")
+ "List of regexps that match legal postcodes.
+Whether this is used at all depends on the variable `ebdb-check-postcode'."
+ :group 'ebdb-record-edit
+ :type '(repeat regexp))
+
+(defcustom ebdb-default-user-field 'notes
+ "Default field when editing EBDB records."
+ :group 'ebdb-record-edit
+ :type '(symbol :tag "Field"))
+
+
+
+(defcustom ebdb-mail-name-format 'first-last
+ "Format for names when sending mail.
+If first-last format names as \"Firstname Lastname\".
+If last-first format names as \"Lastname, Firstname\".
+If `ebdb-mail-name' returns the full name as a single string, this takes
+precedence over `ebdb-mail-name-format'. Likewise, if the mail address itself
+includes a name, this is not reformatted."
+ :group 'ebdb-sendmail
+ :type '(choice (const :tag "Firstname Lastname" first-last)
+ (const :tag "Lastname, Firstname" last-first)))
+
+(defcustom ebdb-mail-name 'mail-name
+ "Xfield holding the full name for a record when sending mail.
+This may also be a function taking one argument, a record.
+If it returns the full mail name as a single string, this is used \"as is\".
+If it returns a cons pair (FIRST . LAST) with the first and last name
+for this record, these are formatted obeying `ebdb-mail-name-format'."
+ :group 'ebdb-sendmail
+ :type '(choice (symbol :tag "xfield")
+ (function :tag "mail name function")))
+
+(defcustom ebdb-mail-alias-field 'mail-alias
+ "Xfield holding the mail alias for a record.
+Used by `ebdb-mail-aliases'. See also `ebdb-mail-alias'."
+ :group 'ebdb-sendmail
+ :type 'symbol)
+
+(defcustom ebdb-mail-alias 'first
+ "Defines which mail aliases are generated for a EBDB record.
+first: Generate one alias \"<alias>\" that expands to the first mail address
+ of a record.
+star: Generate a second alias \"<alias>*\" that expands to all mail addresses
+ of a record.
+all: Generate the aliases \"<alias>\" and \"<alias>*\" (as for 'star)
+ and aliases \"<alias>n\" for each mail address, where n is the position
+ of the mail address of a record."
+ :group 'ebdb-sendmail
+ :type '(choice (symbol :tag "Only first" first)
+ (symbol :tag "<alias>* for all mails" star)
+ (symbol :tag "All aliases" all)))
+
+(defcustom ebdb-mail-avoid-redundancy nil
+ "Mail address to use for EBDB records when sending mail.
+If non-nil do not use full name in mail address when same as mail.
+If value is mail-only never use full name."
+ :group 'ebdb-sendmail
+ :type '(choice (const :tag "Allow redundancy" nil)
+ (const :tag "Never use full name" mail-only)
+ (const :tag "Avoid redundancy" t)))
+
+(defcustom ebdb-complete-mail t
+ "If t MUA insinuation provides key binding for command `ebdb-complete-mail'."
+ :group 'ebdb-sendmail
+ :type 'boolean)
+
+(defcustom ebdb-completion-list t
+ "Controls the behaviour of `ebdb-complete-mail'.
+If a list of symbols, it specifies which fields to complete. Symbols include
+ name (= record's display name)
+ alt-names (= any other names the record has)
+ organization
+ mail (= all email addresses of each record)
+ primary (= first email address of each record)
+If t, completion is done for all of the above.
+If nil, no completion is offered."
+ ;; These symbols match the fields for which EBDB provides entries in
+ ;; `ebdb-hash-table'.
+ :group 'ebdb-sendmail
+ :type '(choice (const :tag "No Completion" nil)
+ (const :tag "Complete across all fields" t)
+ (repeat :tag "Field"
+ (choice (const name)
+ (const alt-names)
+ (const organization)
+ (const primary)
+ (const mail)))))
+
+(defcustom ebdb-complete-mail-allow-cycling nil
+ "If non-nil cycle mail addresses when calling `ebdb-complete-mail'."
+ :group 'ebdb-sendmail
+ :type 'boolean)
+
+(defcustom ebdb-complete-mail-hook nil
+ "List of functions called after a sucessful completion."
+ :group 'ebdb-sendmail
+ :type 'hook)
+
+(defcustom ebdb-mail-abbrev-expand-hook nil
+ ;; Replacement for function `mail-abbrev-expand-hook'.
+ "Function (not hook) run each time an alias is expanded.
+The function is called with two args the alias and the list
+of corresponding mail addresses."
+ :group 'ebdb-sendmail
+ :type 'function)
+
+(defcustom ebdb-completion-display-record t
+ "If non-nil `ebdb-complete-mail' displays the EBDB record after completion."
+ :group 'ebdb-sendmail
+ :type '(choice (const :tag "Update the EBDB buffer" t)
+ (const :tag "Do not update the EBDB buffer" nil)))
+
+
+;;;Dialing
+(defcustom ebdb-dial-local-prefix-alist
+ '(((if (integerp ebdb-default-area-code)
+ (format "(%03d)" ebdb-default-area-code)
+ (or ebdb-default-area-code ""))
+ . ""))
+ "Mapping to remove local prefixes from numbers.
+If this is non-nil, it should be an alist of
+\(PREFIX . REPLACEMENT) elements. The first part of a phone number
+matching the regexp returned by evaluating PREFIX will be replaced by
+the corresponding REPLACEMENT when dialing."
+ :group 'ebdb-utilities-dialing
+ :type 'sexp)
+
+(defcustom ebdb-dial-local-prefix nil
+ "Local prefix digits.
+If this is non-nil, it should be a string of digits which your phone
+system requires before making local calls (for example, if your phone system
+requires you to dial 9 before making outside calls.) In EBDB's
+opinion, you're dialing a local number if it starts with a 0 after
+processing `ebdb-dial-local-prefix-alist'."
+ :group 'ebdb-utilities-dialing
+ :type '(choice (const :tag "No digits required" nil)
+ (string :tag "Dial this first" "9")))
+
+(defcustom ebdb-dial-long-distance-prefix nil
+ "Long distance prefix digits.
+If this is non-nil, it should be a string of digits which your phone
+system requires before making a long distance call (one not in your local
+area code). For example, in some areas you must dial 1 before an area
+code. Note that this is used to replace the + sign in phone numbers
+when dialling (international dialing prefix.)"
+ :group 'ebdb-utilities-dialing
+ :type '(choice (const :tag "No digits required" nil)
+ (string :tag "Dial this first" "1")))
+
+(defcustom ebdb-dial-function nil
+ "If non-nil this should be a function used for dialing phone numbers.
+This function is used by `ebdb-dial-number'. It requires one
+argument which is a string for the number that is dialed.
+If nil then `ebdb-dial-number' uses the tel URI syntax passed to `browse-url'
+to make the call."
+ :group 'ebdb-utilities-dialing
+ :type 'function)
+
+
+
+;;; Helper functions
+
+(defun ebdb-warn (&rest args)
+ "Display a message at the bottom of the screen.
+ARGS are passed to `message'."
+ (ding t)
+ (apply 'message args))
+
+(defun ebdb-string-trim (string &optional null)
+ "Remove leading and trailing whitespace and all properties from STRING.
+If STRING is nil return an empty string unless NULL is non-nil."
+ (if (null string)
+ (unless null "")
+ (setq string (substring-no-properties (string-trim string)))
+ (unless (and null (string-empty-p string))
+ string)))
+
+(defsubst ebdb-string= (str1 str2)
+ "Return t if strings STR1 and STR2 are equal, ignoring case."
+ (and (stringp str1) (stringp str2)
+ (eq t (compare-strings str1 0 nil str2 0 nil t))))
+
+(defun ebdb-split (separator string)
+ "Split STRING into list of substrings bounded by matches for SEPARATORS.
+SEPARATOR may be a regexp. SEPARATOR may also be a symbol
+\(a field name). Then look up the value in `ebdb-separator-alist'
+or use `ebdb-default-separator'.
+Whitespace around SEPARATOR is ignored unless SEPARATOR matches
+the string \" \\t\\n\".
+Almost the inverse function of `ebdb-concat'."
+ (if (symbolp separator)
+ (setq separator (car (or (cdr (assq separator ebdb-separator-alist))
+ ebdb-default-separator))))
+ (unless (string-match separator " \t\n")
+ (setq separator (concat "[ \t\n]*" separator "[ \t\n]*")))
+ ;; `split-string' applied to an empty STRING gives nil.
+ (split-string (ebdb-string-trim string) separator t))
+
+(defun ebdb-concat (separator &rest strings)
+ "Concatenate STRINGS to a string sticking in SEPARATOR.
+STRINGS may be strings or lists of strings. Empty strings are ignored.
+SEPARATOR may be a string.
+SEPARATOR may also be a symbol (a field name). Then look up the value
+of SEPARATOR in `ebdb-separator-alist' or use `ebdb-default-separator'.
+The inverse function of `ebdb-split'."
+ (if (symbolp separator)
+ (setq separator (nth 1 (or (cdr (assq separator ebdb-separator-alist))
+ ebdb-default-separator))))
+ (mapconcat 'identity
+ (delete "" (apply 'append (mapcar (lambda (x) (if (stringp x)
+ (list x) x))
+ strings))) separator))
+
+(defun ebdb-list-strings (list)
+ "Remove all elements from LIST which are not non-empty strings."
+ (let (new-list)
+ (dolist (elt list)
+ (if (and (stringp elt) (not (string= "" elt)))
+ (push elt new-list)))
+ (nreverse new-list)))
+
+(defun ebdb-read-string (prompt &optional init collection require-match)
+ "Read a string, trimming whitespace and text properties.
+PROMPT is a string to prompt with.
+INIT appears as initial input which is useful for editing existing records.
+COLLECTION and REQUIRE-MATCH have the same meaning as in `completing-read'."
+ (ebdb-string-trim
+ (if collection
+ ;; Hack: In `minibuffer-local-completion-map' remove
+ ;; the binding of SPC to `minibuffer-complete-word'
+ ;; and of ? to `minibuffer-completion-help'.
+ (minibuffer-with-setup-hook
+ (lambda ()
+ (use-local-map
+ (let ((map (make-sparse-keymap)))
+ (set-keymap-parent map (current-local-map))
+ (define-key map " " nil)
+ (define-key map "?" nil)
+ map)))
+ (completing-read prompt collection nil require-match init))
+ (let ((string (read-string prompt init)))
+ (if (string= "" string)
+ (signal 'ebdb-empty (list prompt))
+ string)))))
+
+(defun ebdb-add-to-list (list-var element)
+ "Add ELEMENT to the value of LIST-VAR if it isn't there yet and non-nil.
+The test for presence of ELEMENT is done with `equal'.
+The return value is the new value of LIST-VAR."
+ ;; Unlike `add-to-list' this ignores ELEMENT if it is nil.
+ ;; TO DO: turn this into a faster macro so that we can abandon calls
+ ;; of add-to-list.
+ (if (or (not element)
+ (member element (symbol-value list-var)))
+ (symbol-value list-var)
+ (set list-var (cons element (symbol-value list-var)))))
+
+(defun ebdb-multiple-buffers-default ()
+ "Default function for guessing a name for new *EBDB* buffers.
+May be used as value of variable `ebdb-multiple-buffers'."
+ (save-current-buffer
+ (cond ((memq major-mode '(vm-mode vm-summary-mode vm-presentation-mode
+ vm-virtual-mode))
+ (vm-select-folder-buffer)
+ (buffer-name))
+ ((memq major-mode '(gnus-summary-mode gnus-group-mode))
+ (set-buffer gnus-article-buffer)
+ (buffer-name))
+ ((memq major-mode '(mail-mode vm-mail-mode message-mode))
+ "message composition"))))
+
+(defsubst ebdb-add-job (spec record string)
+ "Internal function: Evaluate SPEC for RECORD and STRING.
+If SPEC is a function call it with args RECORD and STRING. Return value.
+If SPEC is a regexp, return 'query unless SPEC matches STRING.
+Otherwise return SPEC.
+Used with variable `ebdb-add-name' and friends."
+ (cond ((functionp spec)
+ (funcall spec record string))
+ ((stringp spec)
+ (unless (string-match spec string) 'query)) ; be least aggressive
+ (spec)))
+
+(defsubst ebdb-eval-spec (spec prompt)
+ "Internal function: Evaluate SPEC using PROMPT.
+Return t if either SPEC equals t, or SPEC equals 'query and `ebdb-silent'
+is non-nil or `y-or-no-p' returns t using PROMPT.
+Used with return values of `ebdb-add-job'."
+ (or (eq spec t)
+ (and (eq spec 'query)
+ (or ebdb-silent (y-or-n-p prompt)))))
+
+(defun ebdb-clean-address-components (components)
+ "Clean mail address COMPONENTS.
+COMPONENTS is a list (FULL-NAME CANONICAL-ADDRESS) as returned
+by `mail-extract-address-components'.
+Pass FULL-NAME through `ebdb-message-clean-name-function'
+and CANONICAL-ADDRESS through `ebdb-canonicalize-mail-function'."
+ (list (if (car components)
+ (if ebdb-message-clean-name-function
+ (funcall ebdb-message-clean-name-function (car components))
+ (car components)))
+ (if (cadr components)
+ (if ebdb-canonicalize-mail-function
+ (funcall ebdb-canonicalize-mail-function (cadr components))
+ ;; Minimalistic clean-up
+ (ebdb-string-trim (cadr components))))))
+
+(defun ebdb-extract-address-components (address &optional all)
+ "Given an RFC-822 address ADDRESS, extract full name and canonical address.
+This function behaves like `mail-extract-address-components', but it passes
+its return value through `ebdb-clean-address-components'.
+See also `ebdb-decompose-ebdb-address'."
+ (if all
+ (mapcar 'ebdb-clean-address-components
+ (mail-extract-address-components address t))
+ (ebdb-clean-address-components (mail-extract-address-components address))))
+
+;; Inspired by `gnus-extract-address-components' from gnus-utils.
+(defun ebdb-decompose-ebdb-address (mail)
+ "Given an RFC-822 address MAIL, extract full name and canonical address.
+In general, this function behaves like the more sophisticated function
+`mail-extract-address-components'. Yet for an address `<address@hidden>'
+lacking a real name the latter function returns the name \"Joe Smith\".
+This is useful when analyzing the headers of email messages we receive
+from the outside world. Yet when analyzing the mail addresses stored
+in EBDB, this pollutes the mail-aka space. So we define here
+an intentionally much simpler function for decomposing the names
+and canonical addresses in the mail field of EBDB records."
+ (let (name address)
+ ;; First get rid of any "mailto:" in the string.
+ (setq mail (replace-regexp-in-string "mailto:" "" mail))
+ ;; Then find the address - the thing with the @ in it.
+ (cond (;; Check `<address@hidden>' first in order to handle the quite
common
+ ;; form `"address@hidden" <address@hidden>' (i.e. `@' as part of a
comment)
+ ;; correctly.
+ (string-match "<\\([^@ \t<>address@hidden@ \t<>]+\\)>" mail)
+ (setq address (match-string 1 mail)))
+ ((string-match "\\b[^@ \t<>address@hidden@ \t<>]+\\b" mail)
+ (setq address (match-string 0 mail))))
+ ;; Then check whether the `name <address>' format is used.
+ (and address
+ ;; Linear white space is not required.
+ (string-match (concat "[ \t]*<?" (regexp-quote address) ">?") mail)
+ (setq name (substring mail 0 (match-beginning 0)))
+ ;; Strip any quotes mail the name.
+ (string-match "^\".*\"$" name)
+ (setq name (substring name 1 (1- (match-end 0)))))
+ ;; If not, then check whether the `address (name)' format is used.
+ (or name
+ (and (string-match "(\\([^)]+\\))" mail)
+ (setq name (match-string 1 mail))))
+ (list (if (equal name "") nil name) (or address mail))))
+
+;;; Massage of mail addresses
+
+(defcustom ebdb-canonical-hosts
+ ;; Example
+ (regexp-opt '("cs.cmu.edu" "ri.cmu.edu"))
+ "Regexp matching the canonical part of the domain part of a mail address.
+If the domain part of a mail address matches this regexp, the domain
+is replaced by the substring that actually matched this address.
+
+Used by `ebdb-canonicalize-mail-1'. See also `ebdb-ignore-redundant-mails'."
+ :group 'ebdb-mua
+ :type '(regexp :tag "Regexp matching sites"))
+
+(defun ebdb-canonicalize-mail-1 (address)
+ "Example of `ebdb-canonicalize-mail-function'.
+However, this function is too specific to be useful for the general user.
+Take it as a source of inspiration for what can be done."
+ (setq address (ebdb-string-trim address))
+ (cond
+ ;; Rewrite mail-drop hosts.
+ ;; RW: The following is now also handled by `ebdb-ignore-redundant-mails'
+ ((string-match
+ (concat "\\`\\(address@hidden@\\).*\\.\\(" ebdb-canonical-hosts "\\)\\'")
+ address)
+ (concat (match-string 1 address) (match-string 2 address)))
+ ;;
+ ;; Here at Lucid, our workstation names sometimes get into our mail
+ ;; addresses in the form "address@hidden" (instead of simply
+ ;; "address@hidden"). This removes the workstation name.
+ ((string-match "\\`\\(address@hidden)address@hidden@\\(lucid\\.com\\)\\'"
address)
+ (concat (match-string 1 address) "@" (match-string 2 address)))
+ ;;
+ ;; Another way that our local mailer is misconfigured: sometimes addresses
+ ;; which should look like "address@hidden" end up looking like
+ ;; "user%some.outside.host" or even "address@hidden"
+ ;; instead. This rule rewrites it into the original form.
+ ((string-match
"\\`\\(address@hidden)%\\(address@hidden)\\(@lucid\\.com\\)?\\'" address)
+ (concat (match-string 1 address) "@" (match-string 2 address)))
+ ;;
+ ;; Sometimes I see addresses like "address@hidden".
+ ;; That's totally redundant, so this rewrites it as "address@hidden".
+ ((string-match "\\`\\(address@hidden)!\\(address@hidden@%]\\1\\)\\'"
address)
+ (match-string 2 address))
+ ;;
+ ;; Sometimes I see addresses like "foobar.com!user". Turn it around.
+ ((string-match "\\`\\(address@hidden@%!]+\\)!\\(address@hidden)\\'" address)
+ (concat (match-string 2 address) "@" (match-string 1 address)))
+ ;;
+ ;; The mailer at hplb.hpl.hp.com tends to puke all over addresses which
+ ;; pass through mailing lists which are maintained there: it turns normal
+ ;; addresses like "address@hidden" into "address@hidden".
+ ;; This reverses it. (I actually could have combined this rule with
+ ;; the similar lucid.com rule above, but then the regexp would have been
+ ;; more than 80 characters long...)
+ ((string-match
"\\`\\(address@hidden)%\\(address@hidden)@hplb\\.hpl\\.hp\\.com\\'"
+ address)
+ (concat (match-string 1 address) "@" (match-string 2 address)))
+ ;;
+ ;; Another local mail-configuration botch: sometimes mail shows up
+ ;; with addresses like "address@hidden", where "workstation" is a
+ ;; local machine name. That should really be "user" or "address@hidden".
+ ;; (I'm told this one is due to a bug in SunOS 4.1.1 sendmail.)
+ ((string-match "\\`\\(address@hidden)address@hidden@%!.]+\\'" address)
+ (match-string 1 address))
+ ;;
+ ;; Sometimes I see addresses like "address@hidden".
+ ;; This is silly, because I know that I can send mail to uunet directly.
+ ((string-match "address@hidden@%!]+\\'" address)
+ (concat (substring address 0 (+ (match-beginning 0) 1)) "@UUNET.UU.NET"))
+ ;;
+ ;; Otherwise, leave it as it is.
+ (t address)))
+
+(defun ebdb-message-clean-name-default (name)
+ "Default function for `ebdb-message-clean-name-function'.
+This strips garbage from the user full NAME string."
+ ;; Remove leading non-alpha chars
+ (if (string-match "\\`[^[:alpha:]]+" name)
+ (setq name (substring name (match-end 0))))
+
+ (if (string-match "^\\(address@hidden)@" name)
+ ;; The name is really a mail address and we use the part preceeding "@".
+ ;; Everything following "@" is ignored.
+ (setq name (match-string 1 name)))
+
+ ;; Replace "firstname.surname" by "firstname surname".
+ ;; Do not replace ". " with " " because that could be an initial.
+ (setq name (replace-regexp-in-string "\\.\\([^ ]\\)" " \\1" name))
+
+ ;; Replace tabs, spaces, and underscores with a single space.
+ (setq name (replace-regexp-in-string "[ \t\n_]+" " " name))
+
+ ;; Remove trailing comments separated by "(" or " [-#]"
+ ;; This does not work all the time because some of our friends in
+ ;; northern europe have brackets in their names...
+ (if (string-match "[^ \t]\\([ \t]*\\((\\| [-#]\\)\\)" name)
+ (setq name (substring name 0 (match-beginning 1))))
+
+ ;; Remove phone extensions (like "x1234" and "ext. 1234")
+ (let ((case-fold-search t))
+ (setq name (replace-regexp-in-string
+ "\\W+\\(x\\|ext\\.?\\)\\W*[-0-9]+" "" name)))
+
+ ;; Remove trailing non-alpha chars
+ (if (string-match "[^[:alpha:]]+\\'" name)
+ (setq name (substring name 0 (match-beginning 0))))
+
+ ;; Remove text properties
+ (substring-no-properties name))
+
+(defsubst ebdb-record-mail-aka (record)
+ "Record cache function: Return mail-aka for RECORD."
+ (slot-value (ebdb-record-cache record) 'mail-aka))
+
+(defsubst ebdb-record-mail-canon (record)
+ "Record cache function: Return mail-canon for RECORD."
+ (slot-value (ebdb-record-cache record) 'mail-canon))
+
+;; `ebdb-hashtable' associates with each KEY a list of matching records.
+;; KEY includes fl-name, lf-name, organizations, AKAs and email addresses.
+;; When loading the database the hash table is initialized by calling
+;; `ebdb-hash-record' for each record. This function is also called
+;; when new records are added to the database.
+
+(defun ebdb-puthash (key record)
+ "Associate RECORD with KEY in `ebdb-hashtable'.
+KEY must be a string or nil. Empty strings and nil are ignored."
+ (if (and key (not (string-empty-p key))) ; do not hash empty strings
+ (let* ((key (downcase key))
+ (records (gethash key ebdb-hashtable)))
+ (puthash key (if records (cl-pushnew record records)
+ (list record))
+ ebdb-hashtable))))
+
+(defun ebdb-gethash (key &optional predicate)
+ "Return list of records associated with KEY in
+`ebdb-hashtable'. KEY must be a string or nil. Empty strings
+and nil are ignored. PREDICATE may take the same values as
+`ebdb-completion-list'. If predicate is the single symbol uuid,
+this function returns a single record."
+ (when (and key (not (string-empty-p key)))
+ (let* ((key (downcase key))
+ (all-records (gethash key ebdb-hashtable))
+ records)
+ (if (or (not predicate) (eq t predicate))
+ all-records
+ (if (eql predicate 'uuid)
+ ;; We could conceivably do a bit of sanity checking here.
+ ;; All-records should only be a list of one.
+ (car all-records)
+ (dolist (record all-records records)
+ (if (catch 'ebdb-hash-ok
+ (ebdb-hash-p key record predicate))
+ (push record records))))))))
+
+(defun ebdb-hash-p (key record predicate)
+ "Throw `ebdb-hash-ok' non-nil if KEY matches RECORD acording to PREDICATE.
+PREDICATE may take the same values as the elements of `ebdb-completion-list'."
+ (if (and (memq 'fl-name predicate)
+ (ebdb-string= key (or (ebdb-record-name record) "")))
+ (throw 'ebdb-hash-ok 'fl-name))
+ ;; (if (and (memq 'lf-name predicate)
+ ;; (ebdb-string= key (or (ebdb-record-name-lf record) "")))
+ ;; (throw 'ebdb-hash-ok 'lf-name))
+ (if (memq 'organization predicate)
+ (mapc (lambda (organization) (if (ebdb-string= key organization)
+ (throw 'ebdb-hash-ok 'organization)))
+ (ebdb-record-organization record)))
+ (if (memq 'aka predicate)
+ (mapc (lambda (aka) (if (ebdb-string= key (ebdb-string aka))
+ (throw 'ebdb-hash-ok 'aka)))
+ (slot-value record 'aka)))
+ (if (and (memq 'primary predicate)
+ (ebdb-string= key (car (ebdb-record-mail-canon record))))
+ (throw 'ebdb-hash-ok 'primary))
+ (if (memq 'mail predicate)
+ (mapc (lambda (mail) (if (ebdb-string= key mail)
+ (throw 'ebdb-hash-ok 'mail)))
+ (ebdb-record-mail-canon record)))
+ nil)
+
+(defun ebdb-remhash (key record)
+ "Remove RECORD from list of records associated with KEY.
+KEY must be a string or nil. Empty strings and nil are ignored."
+ (if (and key (not (string-empty-p key)))
+ (let* ((key (downcase key))
+ (records (gethash key ebdb-hashtable)))
+ (when records
+ (setq records (delq record records))
+ (if records
+ (puthash key records ebdb-hashtable)
+ (remhash key ebdb-hashtable))))))
+
+(defun ebdb-hash-update (record old new)
+ "Update hash for RECORD. Remove OLD, insert NEW.
+Both OLD and NEW are lists of values."
+ (dolist (elt old)
+ (ebdb-remhash elt record))
+ (dolist (elt new)
+ (ebdb-puthash elt record)))
+
+(defun ebdb-check-name (first last &optional record)
+ "Check whether the name FIRST LAST is a valid name.
+This throws an error if the name is already used by another record
+and `ebdb-allow-duplicates' is nil. If RECORD is non-nil, FIRST and LAST
+may correspond to RECORD without raising an error."
+ ;; Are there more useful checks for names beyond checking for duplicates?
+ (unless ebdb-allow-duplicates
+ (let* ((name (ebdb-concat 'name-first-last first last))
+ (records (ebdb-gethash name '(fl-name lf-name aka))))
+ (if (or (and (not record) records)
+ (remq record records))
+ (error "%s is already in EBDB" name)))))
+
+(defun ebdb-record-sortkey (record)
+ "Record cache function: Return the sortkey for RECORD.
+Set and store it if necessary."
+ (or (slot-value (ebdb-record-cache record) 'sortkey)
+ (ebdb-record-set-sortkey record)))
+
+(cl-defmethod ebdb-record-set-sortkey ((record ebdb-record-person))
+ "Record cache function: Set and return RECORD's sortkey."
+ (setf
+ (slot-value (ebdb-record-cache record) 'sortkey)
+ (downcase (ebdb-name-lf (slot-value record 'name)))))
+
+(cl-defmethod ebdb-record-set-sortkey ((record ebdb-record-organization))
+ (setf
+ (slot-value (ebdb-record-cache record) 'sortkey)
+ (downcase (ebdb-string (slot-value record 'name)))))
+
+;; The values of xfields are normally strings. The following function
+;; comes handy if we want to treat these values as symbols.
+;; (defun ebdb-record-xfield-intern (record label)
+;; "For RECORD return interned value of xfield LABEL.
+;; Return nil if xfield LABEL does not exist."
+;; (let ((value (ebdb-record-xfield record label)))
+;; ;; If VALUE is not a string, return whatever it is.
+;; (if (stringp value) (intern value) value)))
+
+;; (defun ebdb-record-xfield-string (record label)
+;; "For RECORD return value of xfield LABEL as string.
+;; Return nil if xfield LABEL does not exist."
+;; (let ((value (ebdb-record-xfield record label)))
+;; (if (string-or-null-p value)
+;; value
+;; (let ((print-escape-newlines t))
+;; (prin1-to-string value)))))
+
+;; (defsubst ebdb-record-xfield-split (record label)
+;; "For RECORD return value of xfield LABEL split as a list.
+;; Splitting is based on `ebdb-separator-alist'."
+;; (let ((val (ebdb-record-xfield record label)))
+;; (cond ((stringp val) (ebdb-split label val))
+;; (val (error "Cannot split `%s'" val)))))
+
+(cl-defgeneric ebdb-record-field (record field)
+ "For RECORD return the value of FIELD.
+
+FIELD may be a slot-name symbol, in which case the value of that
+slot, if any, is returned. It can be a string, in which case it
+is interpreted as a label for one of RECORD's user fields. It
+can also be the symbol name of a user-field class, in which case
+all the record's instances of that class are returned. It can
+also be one of the special symbols below.
+
+ firstname Return the first name of RECORD
+ lastname Return the last name of RECORD
+ name-lf Return the full name of RECORD (last name first)
+ affix Return the list of affixes
+ aka-all Return the list of AKAs plus mail-akas.
+ mail-aka Return the list of name parts in mail addresses
+ mail-canon Return the list of canonical mail addresses.")
+
+(cl-defmethod ebdb-record-field ((record ebdb-record)
+ (field symbol))
+ (cond ((eq field 'firstname) (ebdb-record-firstname record))
+ ((eq field 'lastname) (ebdb-record-lastname record))
+ ((eq field 'affix) (slot-value (slot-value record 'name) 'affix))
+ ((eq field 'mail-canon) (ebdb-record-mail-canon record)) ; derived
(cached) field
+ ((eq field 'mail-aka) (ebdb-record-mail-aka record)) ; derived (cached)
field
+ ((eq field 'aka-all) (append (ebdb-record-aka record) ; derived field
+ (ebdb-record-mail-aka record)))
+ ;; It might be a class symbol.
+ ((class-p field)
+ (seq-filter
+ (lambda (f)
+ (object-of-class-p f field))
+ (ebdb-record-user-fields record)))
+ ;; Otherwise assume it is a valid slot name.
+ (t
+ (when (and (slot-exists-p record field)
+ (slot-boundp record field))
+ (slot-value record field)))))
+
+(cl-defmethod ebdb-record-field ((record ebdb-record)
+ (field string))
+ (let ((user-fields (ebdb-record-user-fields record)))
+ (catch 'found
+ (dolist (f user-fields)
+ (when (and (slot-exists-p f 'object-name)
+ (string= field (slot-value f 'object-name)))
+ (throw 'found f))))))
+
+(defun ebdb-merge-concat (string1 string2 &optional separator)
+ "Return the concatenation of STRING1 and STRING2.
+SEPARATOR defaults to \"\\n\"."
+ (concat string1 (or separator "\n") string2))
+
+(defun ebdb-merge-concat-remove-duplicates (string1 string2)
+ "Concatenate STRING1 and STRING2, but remove duplicate lines."
+ (let ((lines (split-string string1 "\n")))
+ (dolist (line (split-string string2 "\n"))
+ (cl-pushnew line lines))
+ (ebdb-concat "\n" lines)))
+
+(defun ebdb-merge-string-least (string1 string2)
+ "Return the string out of STRING1 and STRING2 that is `string-lessp'."
+ (if (string-lessp string1 string2)
+ string1
+ string2))
+
+(defun ebdb-merge-string-most (string1 string2)
+ "Return the string out of STRING1 and STRING2 that is not `string-lessp'."
+ (if (string-lessp string1 string2)
+ string2
+ string1))
+
+(defun ebdb-merge-lists (l1 l2 cmp)
+ "Merge two lists L1 and L2 based on comparison CMP.
+An element from L2 is added to L1 if CMP returns nil for all elements of L1.
+If L1 or L2 are not lists, they are replaced by (list L1) and (list L2)."
+ (let (merge)
+ (unless (listp l1) (setq l1 (list l1)))
+ (dolist (e2 (if (listp l2) l2 (list l2)))
+ (let ((ll1 l1) e1 fail)
+ (while (setq e1 (pop ll1))
+ (if (funcall cmp e1 e2)
+ (setq ll1 nil
+ fail t)))
+ (unless fail (push e2 merge))))
+ (append l1 (nreverse merge))))
+
+;;; Parsing other things
+
+(defun ebdb-divide-name (string)
+ "Divide STRING into a first name and a last name.
+Case is ignored. Return name as (FIRST . LAST).
+LAST is always a string (possibly empty). FIRST may be nil."
+ (let ((case-fold-search t)
+ first suffix)
+ ;; Separate a suffix.
+ (if (string-match ebdb-lastname-suffix-re string)
+ (setq suffix (concat " " (match-string 1 string))
+ string (substring string 0 (match-beginning 0))))
+ (cond ((string-match "\\`\\(.+\\),[ \t\n]*\\(.+\\)\\'" string)
+ ;; If STRING contains a comma, this probably means that STRING
+ ;; is of the form "Last, First".
+ (setq first (match-string 2 string)
+ string (match-string 1 string)))
+ ((string-match ebdb-lastname-re string)
+ (setq first (and (not (zerop (match-beginning 0)))
+ (substring string 0 (match-beginning 0)))
+ string (match-string 1 string))))
+ (cons (and first (ebdb-string-trim first))
+ (ebdb-string-trim (concat string suffix)))))
+
+(defun ebdb-parse-postcode (string)
+ "Check whether STRING is a legal postcode.
+Do this only if `ebdb-check-postcode' is non-nil."
+ (if ebdb-check-postcode
+ (let ((postcodes ebdb-legal-postcodes) re done)
+ (while (setq re (pop postcodes))
+ (if (string-match re string)
+ (setq done t postcodes nil)))
+ (if done string
+ (signal 'ebdb-unparseable (list string))))
+ string))
+
+(defsubst ebdb-record-lessp (record1 record2)
+ (string< (ebdb-record-sortkey record1)
+ (ebdb-record-sortkey record2)))
+
+
+;;; Reading and Writing the EBDB
+
+;;;###autoload
+(defun ebdb-load ()
+ "Load all databases listed in `ebdb-sources'. All the
+important work is done by the `ebdb-db-load' method."
+ (let ((sources (if (listp ebdb-sources)
+ ebdb-sources
+ (list ebdb-sources))))
+ ;; Check if we're re-loading.
+ (when (and ebdb-db-list
+ (object-assoc t 'dirty ebdb-db-list))
+ ;; Later we'll give users the option to discard unsaved data.
+ (error "Databases have unsaved data, save first."))
+ (message "Loading EBDB sources...")
+ (ebdb-clear-vars)
+ (run-hooks 'ebdb-before-load-hook)
+ (dolist (s sources)
+ (if (stringp s)
+ (if (file-exists-p s)
+ ;; Handle auto-saved databases.
+ (let ((auto-save-file (ebdb-db-make-auto-save-file-name s))
+ (orig-filename s))
+ (if (and (file-exists-p auto-save-file)
+ (yes-or-no-p (format "Recover auto-save file for %s? "
s)))
+ (progn (setq s (eieio-persistent-read auto-save-file
'ebdb-db t))
+ (setf (slot-value s 'file) orig-filename)
+ (setf (slot-value s 'dirty) t))
+ (setq s (eieio-persistent-read s 'ebdb-db t))))
+ ;; Handle new/nonexistent databases.
+ (when (yes-or-no-p (format "%s does not exist, create? " s))
+ (setq s (make-instance 'ebdb-db-file :file s :dirty t))
+ ;; Try to get it on disk first.
+ (ebdb-db-save s)))
+ (error "Source %s should be a filename." s))
+ ;; Now load it.
+ (if (child-of-class-p (eieio-object-class s) 'ebdb-db)
+ (if (null (slot-value s 'disabled))
+ (ebdb-db-load s)
+ (message "Database %s is currently disabled." s)
+ (sit-for 2))
+ (error "Object %s is not a EBDB database" s)))
+ (if (and
+ (null ebdb-record-tracker)
+ (bound-and-true-p bbdb-file)
+ (file-exists-p bbdb-file))
+ ;; We're migrating from a previous version of EBDB.
+ (ebdb-migrate-from-bbdb)
+ (message "Loading EBDB sources... done"))
+ ;; Users will expect the same ordering as `ebdb-sources'
+ (setq ebdb-db-list (nreverse ebdb-db-list))
+ (run-hooks 'ebdb-after-load-hook)
+ (length ebdb-record-tracker)))
+
+(defun ebdb-address-continental-p (address)
+ "Return non-nil if ADDRESS is a continental address.
+This is done by comparing the postcode to `ebdb-continental-postcode-regexp'.
+
+This is a possible identifying function for
+`ebdb-address-format-list' and `ebdb-print-address-format-list'."
+ (string-match ebdb-continental-postcode-regexp
+ (ebdb-address-postcode address)))
+
+;; This function can provide some guidance for writing
+;; your own address formatting function
+(defun ebdb-format-address-default (address)
+ "Return formatted ADDRESS as a string.
+This is the default format; it is used in the US, for example.
+The result looks like this:
+ label: street
+ street
+ ...
+ locality, region postcode
+ country.
+
+This function is a possible formatting function for
+`ebdb-address-format-list'."
+ (let ((country (ebdb-address-country address))
+ (streets (ebdb-address-streets address)))
+ (when (symbolp country)
+ (setq country (car (rassq country ebdb-i18n-countries))))
+ (concat (if streets
+ (concat (mapconcat 'identity streets "\n") "\n"))
+ (ebdb-concat ", " (ebdb-address-locality address)
+ (ebdb-concat " " (ebdb-address-region address)
+ (ebdb-address-postcode address)))
+ (unless (or (not country) (string= "" country))
+ (concat "\n" country)))))
+
+(defun ebdb-format-address (address layout)
+ "Format ADDRESS using LAYOUT. Return result as a string.
+The formatting rules are defined in `ebdb-address-format-list'."
+ (let ((list ebdb-address-format-list)
+ (country (ebdb-address-country address))
+ elt string)
+ (while (and (not string) (setq elt (pop list)))
+ (let ((identifier (car elt))
+ (format (nth layout elt))
+ ;; recognize case for format identifiers
+ case-fold-search str)
+ (when (or (eq t identifier) ; default
+ (and (functionp identifier)
+ (funcall identifier address))
+ (and country
+ (listp identifier)
+ ;; ignore case for countries
+ (assq country identifier)))
+ (cond ((functionp format)
+ (setq string (funcall format address)))
+ ((stringp format)
+ (setq string "")
+ (dolist (form (split-string (substring format 1 -1)
+ (substring format 0 1) t))
+ (cond ((string-match "%s" form) ; street
+ (mapc (lambda (s) (setq string (concat string
(format form s))))
+ (ebdb-address-streets address)))
+ ((string-match "%l" form) ; locality
+ (unless (or (not (setq str (ebdb-address-locality
address))) (string= "" str))
+ (setq string (concat string (format
(replace-regexp-in-string "%l" "%s" form) str)))))
+ ((string-match "%p" form) ; postcode
+ (unless (or (not (setq str (ebdb-address-postcode
address))) (string= "" str))
+ (setq string (concat string (format
(replace-regexp-in-string "%p" "%s" form) str)))))
+ ((string-match "%r" form) ; region
+ (unless (or (not (setq str (ebdb-address-region
address))) (string= "" str))
+ (setq string (concat string (format
(replace-regexp-in-string "%r" "%s" form t) str)))))
+ ((string-match "%c" form) ; country
+ (when (symbolp country)
+ (setq country (car (rassq country
ebdb-i18n-countries))))
+ (unless (or (not country) (string= "" country))
+ (setq string (concat string (format
(replace-regexp-in-string "%c" "%s" form t) country)))))
+ (t (error "Malformed address format element %s"
form)))))
+ (t (error "Malformed address format %s" format))))))
+ (unless string
+ (error "No match of `ebdb-address-format-list'"))
+ string))
+
+;; Loading and saving EBDB
+
+(defun ebdb-save (&optional prompt)
+ "Save the EBDB if it is modified.
+If PROMPT is non-nil prompt before saving."
+ (interactive (list nil))
+ ;; TODO: Reimplement ebdb-remote-file, or otherwise do something
+ ;; about that.
+ (message "Saving the EBDB...")
+ (dolist (s ebdb-db-list)
+ (ebdb-db-save s prompt))
+ (message "Saving the EBDB... done"))
+
+;;;###autoload
+(defun ebdb-version (&optional arg)
+ "Return string describing the version of EBDB.
+With prefix ARG, insert string at point."
+ (interactive (list (or (and current-prefix-arg 1) t)))
+ (let ((version-string (format "EBDB version %s (%s)"
+ ebdb-version ebdb-version-date)))
+ (cond ((numberp arg) (insert (message version-string)))
+ ((eq t arg) (message version-string))
+ (t version-string))))
+
+
+;;; Searching EBDB
+
+(defvar ebdb-search-invert nil
+ "Bind this variable to t in order to invert the result of `ebdb-search'.")
+
+(defun ebdb-search-invert-p ()
+ "Return variable `ebdb-search-invert' and set it to nil.
+To set it again, use command `ebdb-search-invert'."
+ (let ((result ebdb-search-invert))
+ (setq ebdb-search-invert nil)
+ (aset ebdb-modeline-info 2 nil)
+ (aset ebdb-modeline-info 3 nil)
+ result))
+
+;;;###autoload
+(defun ebdb-search-invert (&optional arg)
+ "Toggle inversion of the next search command.
+With prefix ARG a positive number, invert next search.
+With prefix ARG a negative number, do not invert next search."
+ (interactive "P")
+ (setq ebdb-search-invert
+ (or (and (numberp arg) (< 0 arg))
+ (and (not (numberp arg)) (not ebdb-search-invert))))
+ (aset ebdb-modeline-info 2 (if ebdb-search-invert "inv"))
+ (aset ebdb-modeline-info 3 (if ebdb-search-invert
+ (substitute-command-keys
+ "\\<ebdb-mode-map>\\[ebdb-search-invert]")))
+ (ebdb-prefix-message))
+
+(defmacro ebdb-search (records &optional name-re org-re mail-re notes-re
+ user-field-re phone-re address-re)
+ "Search RECORDS for fields matching regexps.
+Regexp NAME-RE is matched against FIRST_LAST, LAST_FIRST, and
+AKA. Regexp USER-FIELD-RE is matched against user fields.
+USER-FIELD-RE may also be a cons (LABEL . RE). Then RE is
+matched against field LABEL. If LABEL is '* then RE is matched
+against any user field.
+
+This macro only generates code for those fields actually being searched for;
+literal nils at compile-time cause no code to be generated.
+
+To reverse the search, bind variable `ebdb-search-invert' to t.
+
+See also `ebdb-message-search' for fast searches using `ebdb-hashtable'
+but not allowing for regexps."
+ (let (clauses)
+ ;; I did not protect these vars from multiple evaluation because that
+ ;; actually generates *less efficient code* in elisp, because the extra
+ ;; bindings cannot easily be optimized away without lexical scope. fmh.
+ (or (stringp name-re) (symbolp name-re) (error "name-re must be atomic"))
+ (or (stringp org-re) (symbolp org-re) (error "org-re must be atomic"))
+ (or (stringp mail-re) (symbolp mail-re) (error "mail-re must be atomic"))
+ (or (stringp user-field-re) (symbolp user-field-re) (consp user-field-re)
+ (error "user-field-re must be atomic or cons"))
+ (or (stringp phone-re) (symbolp phone-re) (error "phone-re must be
atomic"))
+ (or (stringp address-re) (symbolp address-re) (error "address-re must be
atomic"))
+ (when name-re
+ (push `(ebdb-record-search record 'name ,name-re) clauses))
+ (when org-re
+ (push `(let ((organizations (when (slot-exists-p record 'organizations)
+ (slot-value record 'organizations)))
+ org done)
+ (if organizations
+ (while (and (setq org (pop organizations)) (not done))
+ (setq done (string-match ,org-re (ebdb-string org))))
+ ;; so that "^$" can be used to find records that
+ ;; have no organization
+ (setq done (string-match ,org-re "")))
+ done)
+ clauses))
+
+ (when phone-re
+ (push `(ebdb-record-search record 'phone ,phone-re) clauses))
+ (when address-re
+ (push `(ebdb-record-search record 'address ,address-re) clauses))
+ (when mail-re
+ (push `(ebdb-record-search record 'mail ,mail-re) clauses))
+ (when notes-re
+ (push `(ebdb-record-search record 'notes ,notes-re) clauses))
+ (when user-field-re
+ (push `(ebdb-record-search record 'user ,user-field-re) clauses))
+ `(let ((case-fold-search ebdb-case-fold-search)
+ (invert (ebdb-search-invert-p))
+ matches)
+ (dolist (record ,records)
+ (unless (eq (not invert) (not (or ,@clauses)))
+ (push record matches)))
+ (nreverse matches))))
+
+(defun ebdb-search-read (&optional field)
+ "Read regexp to search FIELD values of records."
+ (read-string (format "Search records%s %smatching regexp: "
+ (if field (concat " with " field) "")
+ (if ebdb-search-invert "not " ""))))
+
+(provide 'ebdb)
+;;; ebdb.el ends here
diff --git a/ebdb.org b/ebdb.org
new file mode 100644
index 0000000..50ab540
--- /dev/null
+++ b/ebdb.org
@@ -0,0 +1,160 @@
+#+TEXINFO_CLASS: info
+#+TEXINFO_HEADER: @syncodeindex pg cp
+#+TITLE: EBDB Manual
+#+SUBTITLE: for version 1, updated 3 October, 2014
+#+TEXINFO_DIR_CATEGORY: Emacs
+#+TEXINFO_DIR_TITLE: EBDB: (ebdb)
+#+TEXINFO_DIR_DESC: Contact management package
+#+OPTIONS: *:nil num:t toc:nil
+
+* Introduction
+This manual is for EBDB version 0.1
+
+ Copyright © 2016 Free Software Foundation, Inc.
+
+ Permission is granted to copy, distribute and/or modify this
+ document under the terms of the GNU Free Documentation License,
+ Version 1.3 or any later version published by the Free Software
+ Foundation; with no Invariant Sections, with the Front-Cover Texts
+ being “A GNU Manual,” and with the Back-Cover Texts as in (a)
+ below. A copy of the license is included in the section entitled
+ “GNU Free Documentation License.”
+
+ (a) The FSF’s Back-Cover Text is: “You have the freedom to copy and
+ modify this GNU manual.”
+* The EBDB Database
+EBDB supports multiple databases, and each database definition is
+saved in a file on disk. The default database class, `ebdb-db-file',
+stores its contacts in the same file as the database itself, though
+other database classes may store contacts elsewhere.
+
+- Variable: ebdb-sources
+ User option specifying one or more databases to load. It can be a
+ single element, or a list of elements. Each element can be a
+ filename, from which a database is loaded, or it can be an instance
+ of a subclass of the `ebdb-db' class. The database at the front of
+ the list will be considered the default database.
+
+Databases have a few user-facing settings:
+
+- Option: read-only
+ If t, records can only be read from the database, not edited or
+ deleted.
+- Option: auto-save
+ Set to nil to prevent auto-saving of the database's records.
+- Option: buffer-char
+ Set to a single character that will be displayed next to records in
+ the \ast{}EBDB\ast{} buffer, indicating which database they belong
+ to.
+- Option: uuid-prefix
+ A string to be appended to the uuids of all records created in this
+ database.
+- Option: disabled
+ When t, the database will essentially be ignored -- no records will
+ be read from it.
+- Option record-class
+ The default record class to use when creating new records in this
+ database. The default is `ebdb-default-record-class'.
+
+While it's possible to edit database definitions directly in the file,
+it's safer to use the customization interface to do so from the
+\ast{}EBDB\ast{} buffer.
+
+- Command: ebdb-customize-database db
+ Use the customize interface to edit the definition of DB.
+
+Records can be moved or copied from one database to another. It's
+also possible for a single record to live in more than one database,
+though this functionality is experimental. When a record is loaded
+from more than one database, the two copies are compared using the
+"timestamp" field, and the most recently updated copy is kept.
+
+- Command: ebdb-move-record record to-db
+ More RECORD from its existing database to TO-DB.
+
+- Command: ebdb-copy-record record to-db
+ Copy RECORD into TO-DB, leaving it in its existing database(s).
+
+* MUA Interaction
+One of EBDB's most important features is the ability to create, update
+and display records based on messages received in your mail user
+agent.
+** Loading MUA code
+MUA code is activated simply by loading the relevant library. Keep in
+mind that "MUA" here means both a mail-reading client, and a
+mail-sending client. For instance, if you use the Gnus package for
+reading mail, and Message for sending it, you'll want two require
+statements:
+
+#+BEGIN_SRC elisp
+(require 'ebdb-gnus)
+(require 'ebdb-message)
+#+END_SRC
+
+There are other packages that provide other functionality: these are
+likewise activated simply by requiring the relevant library.
+** Display and updating
+When you open a message in your MUA, EBDB can react in many different
+ways: displaying records for the sender and recipients of the message;
+creating new records for unfamiliar mail addresses; and updating
+existing records with new information. EBDB also provides several
+interactive commands for editing the records associated with the
+selected message.
+
+The first and most important option governing this behavior is:
+
+- Variable: ebdb-mua-auto-update-p
+ This option determines how EBDB acts upon mail addresses found in
+ incoming messages. If nil, nothing will happen. Other options
+ include the symbols 'search (only find existing records), 'update
+ (only find existing records, and update their name and mail fields
+ as necessary), 'query (find existing records, and query about the
+ creation of new records), and 'create (automatically create new
+ records). A value of t is considered equivalent to 'create. The
+ option can also be set to a function which returns one of the above
+ symbols.
+
+
+*** Pop-up buffers
+** EBDB and MUA summary buffers
+EBDB can affect the way message senders are displayed in your MUA's
+summary buffer. It can do this in two ways: 1) by changing the way
+the contact name is displayed, and 2) by optionally displaying a
+one-character mark next to the contact's name.
+*** Sender name display
+EBDB can "unify" the name displayed for a sender that exists in the
+database. In general, an MUA will display the name part of the From:
+header in the mailbox summary buffer. EBDB can replace that display
+name with information from the database.
+
+- Variable: ebdb-message-clean-name-function
+- Variable: ebdb-message-mail-as-name
+- Variable: edb-mua-summary-unification-list
+
+- Variable: ebdb-mua-summary-unify-format-letter
+ Format letter to use for the EBDB-unified sender name in an MUA
+ summary buffer. Defaults to "E".
+
+*** Summary buffer marks
+EBDB can display a one-character mark next to the name of senders that
+are in the database -- at present this is only possible in the Gnus
+and VM MUAs. This can be done in one of three ways. From most
+general to most specific:
+
+- Variable: ebdb-mua-summary-mark
+ Set to a single-character string to use for all senders in the EBDB
+ database. Set to nil to not mark senders at all.
+- Function: ebdb-mua-make-summary-mark record
+ This generic function accepts RECORD as a single argument, and
+ returns a single-character string to be used as a mark.
+- Field class: ebdb-field-summary-mark
+ Give a record an instance of this field class to use a
+ specific mark for that record.
+
+Marks are displayed in MUA summary buffers by customizing the format
+string provided by Gnus or VM, and adding the EBDB-specific format
+code:
+
+- Variable: ebdb-mua-summary-mark-format-letter
+ Format letter to use in the summary buffer format string to mark a
+ record. Defaults to "e".
- [elpa] externals/ebdb 26ee1cb 330/350: Refactor snarfing, (continued)
- [elpa] externals/ebdb 26ee1cb 330/350: Refactor snarfing, Eric Abrahamsen, 2017/08/14
- [elpa] externals/ebdb 6cc67a7 315/350: Add instructions for writing i18n libraries to manual, Eric Abrahamsen, 2017/08/14
- [elpa] externals/ebdb c11ef0e 334/350: Rename ebdb-message-header to ebdb-mua-message-header, Eric Abrahamsen, 2017/08/14
- [elpa] externals/ebdb 7dd034d 349/350: Fix up record citation, bind a command in EBDB mode, Eric Abrahamsen, 2017/08/14
- [elpa] externals/ebdb 615ed9a 326/350: Prefix arg to article snarfing only snarfs signature, Eric Abrahamsen, 2017/08/14
- [elpa] externals/ebdb 8776051 341/350: Changes to manual and README, reflecting EBDB's move to ELPA, Eric Abrahamsen, 2017/08/14
- [elpa] externals/ebdb 80ce330 340/350: Remove libraries that will live in separate packages, Eric Abrahamsen, 2017/08/14
- [elpa] externals/ebdb bc3c712 332/350: Move "Writing Internationalization Libraries" in manual, Eric Abrahamsen, 2017/08/14
- [elpa] externals/ebdb 3210ad7 338/350: Compiler-inspired fixes version 443992, Eric Abrahamsen, 2017/08/14
- [elpa] externals/ebdb d7bc0c9 284/350: Drop the whole auto-notes thing, Eric Abrahamsen, 2017/08/14
- [elpa] externals/ebdb b25edb9 002/350: Squash "prep" branch, push to Github,
Eric Abrahamsen <=
- [elpa] externals/ebdb 4bdf47e 263/350: Get notice routine working, Eric Abrahamsen, 2017/08/14
- [elpa] externals/ebdb 9ce8e30 310/350: Check db editable before reading new record, Eric Abrahamsen, 2017/08/14
- [elpa] externals/ebdb a4d11f5 293/350: Modify ebdb-mua-yank-cc to yank from any EBDB buffer, Eric Abrahamsen, 2017/08/14
- [elpa] externals/ebdb 7caa1b4 308/350: Fix bug in reading mail alias fields, Eric Abrahamsen, 2017/08/14
- [elpa] externals/ebdb f987d46 305/350: Fix buffer modification call, Eric Abrahamsen, 2017/08/14
- [elpa] externals/ebdb c890b24 296/350: Mention mail aliases in the manual, Eric Abrahamsen, 2017/08/14
- [elpa] externals/ebdb be9464d 319/350: When merging organization records, possibly merge role fields, Eric Abrahamsen, 2017/08/14
- [elpa] externals/ebdb 969c44c 303/350: Small tweaks to README, Eric Abrahamsen, 2017/08/14
- [elpa] externals/ebdb 1df6476 322/350: Remove stray code, Eric Abrahamsen, 2017/08/14
- [elpa] externals/ebdb 8455b47 329/350: Bug in 851c0f1, signature snarfing, Eric Abrahamsen, 2017/08/14