1 ;;; eudcb-bbdb.el --- Emacs Unified Directory Client - BBDB Backend -*- coding: utf-8 -*-
3 ;; Copyright (C) 1998-2015 Free Software Foundation, Inc.
5 ;; Author: Oscar Figueiredo <oscar@cpe.fr>
6 ;; Pavel Janík <Pavel@Janik.cz>
7 ;; Maintainer: Thomas Fitzsimmons <fitzsim@fitzsim.org>
11 ;; This file is part of GNU Emacs.
13 ;; GNU Emacs is free software: you can redistribute it and/or modify
14 ;; it under the terms of the GNU General Public License as published by
15 ;; the Free Software Foundation, either version 3 of the License, or
16 ;; (at your option) any later version.
18 ;; GNU Emacs is distributed in the hope that it will be useful,
19 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
20 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
21 ;; GNU General Public License for more details.
23 ;; You should have received a copy of the GNU General Public License
24 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
27 ;; This library provides an interface to use BBDB as a backend of
28 ;; the Emacs Unified Directory Client.
34 ;; Make it loadable on systems without bbdb.
36 (require 'bbdb-com nil t
)
38 ;;{{{ Internal cooking
40 ;; I don't like this but mapcar does not accept a parameter to the function and
41 ;; I don't want to use mapcar*
42 (defvar eudc-bbdb-current-query nil
)
43 (defvar eudc-bbdb-current-return-attributes nil
)
47 (defun eudc-bbdb-field (field-symbol)
48 "Convert FIELD-SYMBOL so that it is recognized by the current BBDB version.
49 BBDB < 3 used `net'; BBDB >= 3 uses `mail'."
50 ;; This just-in-time translation permits upgrading from BBDB 2 to
51 ;; BBDB 3 without restarting Emacs.
52 (if (and (eq field-symbol
'net
)
54 ;; MELPA versions of BBDB may have a bad package version,
55 ;; but they're all version 3 or later.
56 (equal bbdb-version
"@PACKAGE_VERSION@")
57 ;; Development versions of BBDB can have the format "X.YZ
58 ;; devo". Split the string just in case.
59 (version<= "3" (car (split-string bbdb-version
)))))
63 (defvar eudc-bbdb-attributes-translation-alist
67 "Alist mapping EUDC attribute names to BBDB names.")
69 (eudc-protocol-set 'eudc-query-function
'eudc-bbdb-query-internal
'bbdb
)
70 (eudc-protocol-set 'eudc-list-attributes-function nil
'bbdb
)
71 (eudc-protocol-set 'eudc-protocol-attributes-translation-alist
72 'eudc-bbdb-attributes-translation-alist
'bbdb
)
73 (eudc-protocol-set 'eudc-bbdb-conversion-alist nil
'bbdb
)
74 (eudc-protocol-set 'eudc-protocol-has-default-query-attributes nil
'bbdb
)
76 (defun eudc-bbdb-format-query (query)
77 "Format a EUDC query alist into a list suitable to `bbdb-search'."
78 (let* ((firstname (cdr (assq 'firstname query
)))
79 (lastname (cdr (assq 'lastname query
)))
80 (name (or (and firstname lastname
81 (concat firstname
" " lastname
))
84 (company (cdr (assq 'company query
)))
85 (net (cdr (assq 'net query
)))
86 (notes (cdr (assq 'notes query
)))
87 (phone (cdr (assq 'phone query
))))
88 (list name company net notes phone
)))
91 (defun eudc-bbdb-filter-non-matching-record (record)
92 "Return RECORD if it matches `eudc-bbdb-current-query', nil otherwise."
96 (dolist (condition eudc-bbdb-current-query
)
97 (let ((attr (car condition
))
101 (or (and (memq attr
'(firstname lastname aka company phones
105 (eval (list (intern (concat "bbdb-record-"
111 (if eudc-bbdb-enable-substring-matches
112 (eval `(or ,@(mapcar (lambda (subval)
113 (string-match val subval
))
115 (member (downcase val
)
116 (mapcar 'downcase bbdb-val
)))
117 (if eudc-bbdb-enable-substring-matches
118 (string-match val bbdb-val
)
119 (string-equal (downcase val
) (downcase bbdb-val
))))))
120 (throw 'unmatch nil
))))
124 (declare-function bbdb-phone-location
"ext:bbdb" t
) ; via bbdb-defstruct
125 (declare-function bbdb-phone-string
"ext:bbdb" (phone))
126 (declare-function bbdb-record-phones
"ext:bbdb" t
) ; via bbdb-defstruct
127 (declare-function bbdb-address-streets
"ext:bbdb" t
) ; via bbdb-defstruct
128 (declare-function bbdb-address-city
"ext:bbdb" t
) ; via bbdb-defstruct
129 (declare-function bbdb-address-state
"ext:bbdb" t
) ; via bbdb-defstruct
130 (declare-function bbdb-address-zip
"ext:bbdb" t
) ; via bbdb-defstruct
131 (declare-function bbdb-address-location
"ext:bbdb" t
) ; via bbdb-defstruct
132 (declare-function bbdb-record-addresses
"ext:bbdb" t
) ; via bbdb-defstruct
133 (declare-function bbdb-records
"ext:bbdb"
134 (&optional dont-check-disk already-in-db-buffer
))
136 (defun eudc-bbdb-extract-phones (record)
140 (if eudc-bbdb-use-locations-as-attribute-names
141 (cons (intern (bbdb-phone-location phone
))
142 (bbdb-phone-string phone
))
143 (cons 'phones
(format "%s: %s"
144 (bbdb-phone-location phone
)
145 (bbdb-phone-string phone
))))))
146 (bbdb-record-phones record
)))
148 (defun eudc-bbdb-extract-addresses (record)
151 (mapcar (lambda (address)
152 (setq c
(bbdb-address-streets address
))
154 (unless (zerop (length (setq s
(nth n c
))))
155 (setq val
(concat val s
"\n"))))
156 (setq c
(bbdb-address-city address
)
157 s
(bbdb-address-state address
))
158 (setq val
(concat val
159 (if (and (> (length c
) 0) (> (length s
) 0))
163 (bbdb-address-zip address
)))
164 (if eudc-bbdb-use-locations-as-attribute-names
165 (cons (intern (bbdb-address-location address
)) val
)
166 (cons 'addresses
(concat (bbdb-address-location address
)
168 (bbdb-record-addresses record
))))
170 (defun eudc-bbdb-format-record-as-result (record)
171 "Format the BBDB RECORD as a EUDC query result record.
172 The record is filtered according to `eudc-bbdb-current-return-attributes'"
174 (let ((attrs (or eudc-bbdb-current-return-attributes
175 '(firstname lastname aka company phones addresses net notes
)))
180 (setq attr
(car attrs
))
181 (setq attrs
(cdr attrs
)))
184 (setq val
(eudc-bbdb-extract-phones record
)))
185 ((eq attr
'addresses
)
186 (setq val
(eudc-bbdb-extract-addresses record
)))
187 ((memq attr
'(firstname lastname aka company net notes
))
190 (concat "bbdb-record-"
191 (symbol-name (eudc-bbdb-field attr
))))
194 (error "Unknown BBDB attribute")))
196 ((or (not val
) (equal val
""))) ; do nothing
197 ((memq attr
'(phones addresses
))
198 (setq eudc-rec
(append val eudc-rec
)))
201 (setq eudc-rec
(cons (cons attr
(car val
)) eudc-rec
)))
203 (setq eudc-rec
(cons (cons attr val
) eudc-rec
)))
205 (error "Unexpected attribute value"))))
206 (nreverse eudc-rec
)))
210 (defun eudc-bbdb-query-internal (query &optional return-attrs
)
211 "Query BBDB with QUERY.
212 QUERY is a list of cons cells (ATTR . VALUE) where ATTRs should be valid
213 BBDB attribute names.
214 RETURN-ATTRS is a list of attributes to return, defaulting to
215 `eudc-default-return-attributes'."
217 (let ((eudc-bbdb-current-query query
)
218 (eudc-bbdb-current-return-attributes return-attrs
)
219 (query-attrs (eudc-bbdb-format-query query
))
221 (records (bbdb-records))
224 ;; BBDB ORs its query attributes while EUDC ANDs them, hence we need to
225 ;; call bbdb-search iteratively on the returned records for each of the
226 ;; requested attributes
227 (while (and records
(> (length query-attrs
) 0))
228 (setq bbdb-attrs
(append bbdb-attrs
(list (car query-attrs
))))
229 (if (car query-attrs
)
230 (setq records
(eval `(bbdb-search ,(quote records
) ,@bbdb-attrs
))))
231 (setq query-attrs
(cdr query-attrs
)))
234 (setq filtered
(eudc-filter-duplicate-attributes record
))
235 ;; If there were duplicate attributes reverse the order of the
236 ;; record so the unique attributes appear first
237 (if (> (length filtered
) 1)
238 (setq filtered
(mapcar (function
242 (setq result
(append result filtered
))))
244 (mapcar 'eudc-bbdb-format-record-as-result
246 (mapcar 'eudc-bbdb-filter-non-matching-record
252 ;;{{{ High-level interfaces (interactive functions)
254 (defun eudc-bbdb-set-server (dummy)
255 "Set the EUDC server to BBDB."
257 (eudc-set-server dummy
'bbdb
)
258 (message "BBDB server selected"))
263 (eudc-register-protocol 'bbdb
)
265 (provide 'eudcb-bbdb
)
267 ;;; eudcb-bbdb.el ends here