code.delx.au - gnu-emacs/blob - lisp/net/eudcb-bbdb.el

   1 ;;; eudcb-bbdb.el --- Emacs Unified Directory Client - BBDB Backend
   2
   3 ;; Copyright (C) 1998-2015 Free Software Foundation, Inc.
   4
   5 ;; Author: Oscar Figueiredo <oscar@cpe.fr>
   6 ;;         Pavel Janík <Pavel@Janik.cz>
   7 ;; Maintainer: Thomas Fitzsimmons <fitzsim@fitzsim.org>
   8 ;; Keywords: comm
   9 ;; Package: eudc
  10
  11 ;; This file is part of GNU Emacs.
  12
  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.
  17
  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.
  22
  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/>.
  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
  34 ;; Make it loadable on systems without bbdb.
  35 (require 'bbdb nil t)
  36 (require 'bbdb-com nil t)
  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 bbdb-version)
  46
  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)
  53            (or
  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)))))
  60       'mail
  61     field-symbol))
  62
  63 (defvar eudc-bbdb-attributes-translation-alist
  64   '((name . lastname)
  65     (email . net)
  66     (phone . phones))
  67   "Alist mapping EUDC attribute names to BBDB names.")
  68
  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)
  75
  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))
  82                    firstname
  83                    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)))
  89
  90
  91 (defun eudc-bbdb-filter-non-matching-record (record)
  92   "Return RECORD if it matches `eudc-bbdb-current-query', nil otherwise."
  93   (require 'bbdb)
  94   (catch 'unmatch
  95     (progn
  96       (dolist (condition eudc-bbdb-current-query)
  97         (let ((attr (car condition))
  98               (val (cdr condition))
  99               (case-fold-search t)
 100               bbdb-val)
 101           (or (and (memq attr '(firstname lastname aka company phones
 102                                 addresses net))
 103                    (progn
 104                      (setq bbdb-val
 105                            (eval (list (intern (concat "bbdb-record-"
 106                                                        (symbol-name
 107                                                         (eudc-bbdb-field
 108                                                          attr))))
 109                                        'record)))
 110                      (if (listp bbdb-val)
 111                          (if eudc-bbdb-enable-substring-matches
 112                              (eval `(or ,@(mapcar (lambda (subval)
 113                                                     (string-match val subval))
 114                                                   bbdb-val)))
 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))))
 121       record)))
 122
 123 ;; External.
 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))
 135
 136 (defun eudc-bbdb-extract-phones (record)
 137   (require 'bbdb)
 138   (mapcar (function
 139            (lambda (phone)
 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)))
 147
 148 (defun eudc-bbdb-extract-addresses (record)
 149   (require 'bbdb)
 150   (let (s c val)
 151     (mapcar (lambda (address)
 152               (setq c (bbdb-address-streets address))
 153               (dotimes (n 3)
 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))
 160                                     (concat c ", " s)
 161                                   c)
 162                                 " "
 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)
 167                                          "\n" val))))
 168             (bbdb-record-addresses record))))
 169
 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'"
 173   (require 'bbdb)
 174   (let ((attrs (or eudc-bbdb-current-return-attributes
 175                    '(firstname lastname aka company phones addresses net notes)))
 176         attr
 177         eudc-rec
 178         val)
 179     (while (prog1
 180                (setq attr (car attrs))
 181              (setq attrs (cdr attrs)))
 182       (cond
 183        ((eq attr 'phones)
 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))
 188         (setq val (eval
 189                    (list (intern
 190                           (concat "bbdb-record-"
 191                                   (symbol-name (eudc-bbdb-field attr))))
 192                          'record))))
 193        (t
 194         (error "Unknown BBDB attribute")))
 195       (cond
 196        ((or (not val) (equal val ""))) ; do nothing
 197        ((memq attr '(phones addresses))
 198         (setq eudc-rec (append val eudc-rec)))
 199        ((and (listp val)
 200              (= 1 (length val)))
 201         (setq eudc-rec (cons (cons attr (car val)) eudc-rec)))
 202        ((> (length val) 0)
 203         (setq eudc-rec (cons (cons attr val) eudc-rec)))
 204        (t
 205         (error "Unexpected attribute value"))))
 206     (nreverse eudc-rec)))
 207
 208
 209
 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'."
 216   (require 'bbdb)
 217   (let ((eudc-bbdb-current-query query)
 218         (eudc-bbdb-current-return-attributes return-attrs)
 219         (query-attrs (eudc-bbdb-format-query query))
 220         bbdb-attrs
 221         (records (bbdb-records))
 222         result
 223         filtered)
 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)))
 232     (mapc (function
 233            (lambda (record)
 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
 239                                          (lambda (rec)
 240                                            (reverse rec)))
 241                                         filtered)))
 242              (setq result (append result filtered))))
 243           (delq nil
 244                 (mapcar 'eudc-bbdb-format-record-as-result
 245                         (delq nil
 246                               (mapcar 'eudc-bbdb-filter-non-matching-record
 247                                       records)))))
 248     result))
 249
 250 ;;}}}
 251
 252 ;;{{{      High-level interfaces (interactive functions)
 253
 254 (defun eudc-bbdb-set-server (dummy)
 255   "Set the EUDC server to BBDB."
 256   (interactive)
 257   (eudc-set-server dummy 'bbdb)
 258   (message "BBDB server selected"))
 259
 260 ;;}}}
 261
 262
 263 (eudc-register-protocol 'bbdb)
 264
 265 (provide 'eudcb-bbdb)
 266
 267 ;;; eudcb-bbdb.el ends here