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