1;;; eudcb-bbdb.el --- Emacs Unified Directory Client - BBDB Backend
2
3;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004,
4;;   2005, 2006, 2007 Free Software Foundation, Inc.
5
6;; Author: Oscar Figueiredo <oscar@cpe.fr>
7;; Maintainer: Pavel Jan�k <Pavel@Janik.cz>
8;; Keywords: comm
9
10;; This file is part of GNU Emacs.
11
12;; GNU Emacs is free software; you can redistribute it and/or modify
13;; it under the terms of the GNU General Public License as published by
14;; the Free Software Foundation; either version 2, or (at your option)
15;; any later version.
16
17;; GNU Emacs is distributed in the hope that it will be useful,
18;; but WITHOUT ANY WARRANTY; without even the implied warranty of
19;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
20;; GNU General Public License for more details.
21
22;; You should have received a copy of the GNU General Public License
23;; along with GNU Emacs; see the file COPYING.  If not, write to the
24;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
25;; Boston, MA 02110-1301, USA.
26
27;;; Commentary:
28;;    This library provides an interface to use BBDB as a backend of
29;;    the Emacs Unified Directory Client.
30
31;;; Code:
32
33(require 'eudc)
34(if (not (featurep 'bbdb))
35    (load-library "bbdb"))
36(if (not (featurep 'bbdb-com))
37    (load-library "bbdb-com"))
38
39;;{{{      Internal cooking
40
41;; I don't like this but mapcar does not accept a parameter to the function and
42;; I don't want to use mapcar*
43(defvar eudc-bbdb-current-query nil)
44(defvar eudc-bbdb-current-return-attributes nil)
45
46(defvar eudc-bbdb-attributes-translation-alist
47  '((name . lastname)
48    (email . net)
49    (phone . phones))
50  "Alist mapping EUDC attribute names to BBDB names.")
51
52(eudc-protocol-set 'eudc-query-function 'eudc-bbdb-query-internal 'bbdb)
53(eudc-protocol-set 'eudc-list-attributes-function nil 'bbdb)
54(eudc-protocol-set 'eudc-protocol-attributes-translation-alist
55		   'eudc-bbdb-attributes-translation-alist 'bbdb)
56(eudc-protocol-set 'eudc-bbdb-conversion-alist nil 'bbdb)
57(eudc-protocol-set 'eudc-protocol-has-default-query-attributes nil 'bbdb)
58
59(defun eudc-bbdb-format-query (query)
60  "Format a EUDC query alist into a list suitable to `bbdb-search'."
61  (let* ((firstname (cdr (assq 'firstname query)))
62	 (lastname (cdr (assq 'lastname query)))
63	 (name (or (and firstname lastname
64			(concat firstname " " lastname))
65		   firstname
66		   lastname))
67	(company (cdr (assq 'company query)))
68	(net (cdr (assq 'net query)))
69	(notes (cdr (assq 'notes query)))
70	(phone (cdr (assq 'phone query))))
71    (list name company net notes phone)))
72
73
74(defun eudc-bbdb-filter-non-matching-record (record)
75  "Return RECORD if it matches `eudc-bbdb-current-query', nil otherwise."
76  (catch 'unmatch
77    (progn
78      (mapcar
79       (function
80	(lambda (condition)
81	  (let ((attr (car condition))
82		(val (cdr condition))
83		(case-fold-search t)
84		bbdb-val)
85	    (or (and (memq attr '(firstname lastname aka company phones addresses net))
86		     (progn
87		       (setq bbdb-val
88			     (eval (list (intern (concat "bbdb-record-"
89							 (symbol-name attr)))
90					 'record)))
91		       (if (listp bbdb-val)
92			   (if eudc-bbdb-enable-substring-matches
93			       (eval `(or ,@(mapcar '(lambda (subval)
94						       (string-match val
95								     subval))
96						  bbdb-val)))
97			     (member (downcase val)
98				     (mapcar 'downcase bbdb-val)))
99			 (if eudc-bbdb-enable-substring-matches
100			     (string-match val bbdb-val)
101			   (string-equal (downcase val) (downcase bbdb-val))))))
102		(throw 'unmatch nil)))))
103       eudc-bbdb-current-query)
104      record)))
105
106(defun eudc-bbdb-extract-phones (record)
107  (mapcar (function
108	   (lambda (phone)
109	     (if eudc-bbdb-use-locations-as-attribute-names
110		 (cons (intern (bbdb-phone-location phone))
111		       (bbdb-phone-string phone))
112	       (cons 'phones (format "%s: %s"
113				     (bbdb-phone-location phone)
114				     (bbdb-phone-string phone))))))
115	  (bbdb-record-phones record)))
116
117(defun eudc-bbdb-extract-addresses (record)
118  (let (s c val)
119    (mapcar (function
120	     (lambda (address)
121	       (setq val (concat (unless (= 0 (length (setq s (bbdb-address-street1 address))))
122				   (concat s "\n"))
123				 (unless (= 0 (length (setq s (bbdb-address-street2 address))))
124				   (concat s "\n"))
125				 (unless (= 0 (length (setq s (bbdb-address-street3 address))))
126				   (concat s "\n"))
127				 (progn
128				   (setq c (bbdb-address-city address))
129				   (setq s (bbdb-address-state address))
130				   (if (and (> (length c) 0) (> (length s) 0))
131				       (concat c ", " s " ")
132				     (concat c " ")))
133				 (bbdb-address-zip-string address)))
134	       (if eudc-bbdb-use-locations-as-attribute-names
135		   (cons (intern (bbdb-address-location address)) val)
136		 (cons 'addresses (concat (bbdb-address-location address) "\n" val)))))
137	    (bbdb-record-addresses record))))
138
139(defun eudc-bbdb-format-record-as-result (record)
140  "Format the BBDB RECORD as a EUDC query result record.
141The record is filtered according to `eudc-bbdb-current-return-attributes'"
142  (let ((attrs (or eudc-bbdb-current-return-attributes
143		   '(firstname lastname aka company phones addresses net notes)))
144	attr
145	eudc-rec
146	val)
147    (while (prog1
148	       (setq attr (car attrs))
149	     (setq attrs (cdr attrs)))
150      (cond
151       ((eq attr 'phones)
152	(setq val (eudc-bbdb-extract-phones record)))
153       ((eq attr 'addresses)
154	(setq val (eudc-bbdb-extract-addresses record)))
155       ((memq attr '(firstname lastname aka company net notes))
156	(setq val (eval
157		   (list (intern
158			  (concat "bbdb-record-"
159				  (symbol-name attr)))
160			 'record))))
161       (t
162	(setq val "Unknown BBDB attribute")))
163      (if val
164	(cond
165	 ((memq attr '(phones addresses))
166	  (setq eudc-rec (append val eudc-rec)))
167	 ((and (listp val)
168	  (= 1 (length val)))
169	  (setq eudc-rec (cons (cons attr (car val)) eudc-rec)))
170	 ((> (length val) 0)
171	  (setq eudc-rec (cons (cons attr val) eudc-rec)))
172	 (t
173	  (error "Unexpected attribute value")))))
174    (nreverse eudc-rec)))
175
176
177
178(defun eudc-bbdb-query-internal (query &optional return-attrs)
179  "Query BBDB  with QUERY.
180QUERY is a list of cons cells (ATTR . VALUE) where ATTRs should be valid
181BBDB attribute names.
182RETURN-ATTRS is a list of attributes to return, defaulting to
183`eudc-default-return-attributes'."
184
185  (let ((eudc-bbdb-current-query query)
186	(eudc-bbdb-current-return-attributes return-attrs)
187	(query-attrs (eudc-bbdb-format-query query))
188	bbdb-attrs
189	(records (bbdb-records))
190	result
191	filtered)
192    ;; BBDB ORs its query attributes while EUDC ANDs them, hence we need to
193    ;; call bbdb-search iteratively on the returned records for each of the
194    ;; requested attributes
195    (while (and records (> (length query-attrs) 0))
196      (setq bbdb-attrs (append bbdb-attrs (list (car query-attrs))))
197      (if (car query-attrs)
198	  (setq records (eval `(bbdb-search ,(quote records) ,@bbdb-attrs))))
199      (setq query-attrs (cdr query-attrs)))
200    (mapcar (function
201	     (lambda (record)
202	       (setq filtered (eudc-filter-duplicate-attributes record))
203	       ;; If there were duplicate attributes reverse the order of the
204	       ;; record so the unique attributes appear first
205	       (if (> (length filtered) 1)
206		   (setq filtered (mapcar (function
207					   (lambda (rec)
208					     (reverse rec)))
209					  filtered)))
210	       (setq result (append result filtered))))
211	    (delq nil
212		  (mapcar 'eudc-bbdb-format-record-as-result
213			  (delq nil
214				(mapcar 'eudc-bbdb-filter-non-matching-record
215					records)))))
216    result))
217
218;;}}}
219
220;;{{{      High-level interfaces (interactive functions)
221
222(defun eudc-bbdb-set-server (dummy)
223  "Set the EUDC server to BBDB."
224  (interactive)
225  (eudc-set-server dummy 'bbdb)
226  (message "BBDB server selected"))
227
228;;}}}
229
230
231(eudc-register-protocol 'bbdb)
232
233(provide 'eudcb-bbdb)
234
235;;; arch-tag: 38276208-75de-4dbc-ba6f-8db684c32e0a
236;;; eudcb-bbdb.el ends here
237