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