lisp/net/eudcb-bbdb.el

   1 ;;; eudcb-bbdb.el --- Emacs Unified Directory Client - BBDB Backend
   2
   3 ;; Copyright (C) 1998-2017 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 (defun eudc-bbdb-field (field-symbol)
  46   "Convert FIELD-SYMBOL so that it is recognized by the current BBDB version.
  47 BBDB < 3 used `net'; BBDB >= 3 uses `mail'."
  48   ;; This just-in-time translation permits upgrading from BBDB 2 to
  49   ;; BBDB 3 without restarting Emacs.
  50   (if (and (eq field-symbol 'net)
  51            (eudc--using-bbdb-3-or-newer-p))
  52       'mail
  53     field-symbol))
  54
  55 (defvar eudc-bbdb-attributes-translation-alist
  56   '((name . lastname)
  57     (email . net)
  58     (phone . phones))
  59   "Alist mapping EUDC attribute names to BBDB names.")
  60
  61 (eudc-protocol-set 'eudc-query-function 'eudc-bbdb-query-internal 'bbdb)
  62 (eudc-protocol-set 'eudc-list-attributes-function nil 'bbdb)
  63 (eudc-protocol-set 'eudc-protocol-attributes-translation-alist
  64                    'eudc-bbdb-attributes-translation-alist 'bbdb)
  65 (eudc-protocol-set 'eudc-bbdb-conversion-alist nil 'bbdb)
  66 (eudc-protocol-set 'eudc-protocol-has-default-query-attributes nil 'bbdb)
  67
  68 (defun eudc-bbdb-format-query (query)
  69   "Format a EUDC query alist into a list suitable to `bbdb-search'."
  70   (let* ((firstname (cdr (assq 'firstname query)))
  71          (lastname (cdr (assq 'lastname query)))
  72          (name (or (and firstname lastname
  73                         (concat firstname " " lastname))
  74                    firstname
  75                    lastname))
  76         (company (cdr (assq 'company query)))
  77         (net (cdr (assq 'net query)))
  78         (notes (cdr (assq 'notes query)))
  79         (phone (cdr (assq 'phone query))))
  80     (list name company net notes phone)))
  81
  82
  83 (defun eudc-bbdb-filter-non-matching-record (record)
  84   "Return RECORD if it matches `eudc-bbdb-current-query', nil otherwise."
  85   (require 'bbdb)
  86   (catch 'unmatch
  87     (progn
  88       (dolist (condition eudc-bbdb-current-query)
  89         (let ((attr (car condition))
  90               (val (cdr condition))
  91               (case-fold-search t)
  92               bbdb-val)
  93           (or (and (memq attr '(firstname lastname aka company phones
  94                                 addresses net))
  95                    (progn
  96                      (setq bbdb-val
  97                            (eval (list (intern (concat "bbdb-record-"
  98                                                        (symbol-name
  99                                                         (eudc-bbdb-field
 100                                                          attr))))
 101                                        'record)))
 102                      (if (listp bbdb-val)
 103                          (if eudc-bbdb-enable-substring-matches
 104                              (eval `(or ,@(mapcar (lambda (subval)
 105                                                     (string-match val subval))
 106                                                   bbdb-val)))
 107                            (member (downcase val)
 108                                    (mapcar 'downcase bbdb-val)))
 109                        (if eudc-bbdb-enable-substring-matches
 110                            (string-match val bbdb-val)
 111                          (string-equal (downcase val) (downcase bbdb-val))))))
 112               (throw 'unmatch nil))))
 113       record)))
 114
 115 ;; External.
 116 (declare-function bbdb-phone-location   "ext:bbdb" t) ; via bbdb-defstruct
 117 (declare-function bbdb-phone-string     "ext:bbdb" (phone))
 118 (declare-function bbdb-record-phones    "ext:bbdb" t) ; via bbdb-defstruct
 119 (declare-function bbdb-address-streets  "ext:bbdb" t) ; via bbdb-defstruct
 120 (declare-function bbdb-address-city     "ext:bbdb" t) ; via bbdb-defstruct
 121 (declare-function bbdb-address-state    "ext:bbdb" t) ; via bbdb-defstruct
 122 (declare-function bbdb-address-zip      "ext:bbdb" t) ; via bbdb-defstruct
 123 (declare-function bbdb-address-location "ext:bbdb" t) ; via bbdb-defstruct
 124 (declare-function bbdb-record-addresses "ext:bbdb" t) ; via bbdb-defstruct
 125 (declare-function bbdb-records          "ext:bbdb"
 126                   (&optional dont-check-disk already-in-db-buffer))
 127
 128 (defun eudc-bbdb-extract-phones (record)
 129   (require 'bbdb)
 130   (mapcar (function
 131            (lambda (phone)
 132              (if eudc-bbdb-use-locations-as-attribute-names
 133                  (cons (intern (bbdb-phone-location phone))
 134                        (bbdb-phone-string phone))
 135                (cons 'phones (format "%s: %s"
 136                                      (bbdb-phone-location phone)
 137                                      (bbdb-phone-string phone))))))
 138           (bbdb-record-phones record)))
 139
 140 (defun eudc-bbdb-extract-addresses (record)
 141   (require 'bbdb)
 142   (let (s c val)
 143     (mapcar (lambda (address)
 144               (setq c (bbdb-address-streets address))
 145               (dotimes (n 3)
 146                 (unless (zerop (length (setq s (nth n c))))
 147                   (setq val (concat val s "\n"))))
 148               (setq c (bbdb-address-city address)
 149                     s (bbdb-address-state address))
 150               (setq val (concat val
 151                                 (if (and (> (length c) 0) (> (length s) 0))
 152                                     (concat c ", " s)
 153                                   c)
 154                                 " "
 155                                 (bbdb-address-zip address)))
 156               (if eudc-bbdb-use-locations-as-attribute-names
 157                   (cons (intern (bbdb-address-location address)) val)
 158                 (cons 'addresses (concat (bbdb-address-location address)
 159                                          "\n" val))))
 160             (bbdb-record-addresses record))))
 161
 162 (defun eudc-bbdb-format-record-as-result (record)
 163   "Format the BBDB RECORD as a EUDC query result record.
 164 The record is filtered according to `eudc-bbdb-current-return-attributes'"
 165   (require 'bbdb)
 166   (let ((attrs (or eudc-bbdb-current-return-attributes
 167                    '(firstname lastname aka company phones addresses net notes)))
 168         attr
 169         eudc-rec
 170         val)
 171     (while (prog1
 172                (setq attr (car attrs))
 173              (setq attrs (cdr attrs)))
 174       (cond
 175        ((eq attr 'phones)
 176         (setq val (eudc-bbdb-extract-phones record)))
 177        ((eq attr 'addresses)
 178         (setq val (eudc-bbdb-extract-addresses record)))
 179        ((memq attr '(firstname lastname aka company net notes))
 180         (setq val (eval
 181                    (list (intern
 182                           (concat "bbdb-record-"
 183                                   (symbol-name (eudc-bbdb-field attr))))
 184                          'record))))
 185        (t
 186         (error "Unknown BBDB attribute")))
 187       (cond
 188        ((or (not val) (equal val ""))) ; do nothing
 189        ((memq attr '(phones addresses))
 190         (setq eudc-rec (append val eudc-rec)))
 191        ((and (listp val)
 192              (= 1 (length val)))
 193         (setq eudc-rec (cons (cons attr (car val)) eudc-rec)))
 194        ((> (length val) 0)
 195         (setq eudc-rec (cons (cons attr val) eudc-rec)))
 196        (t
 197         (error "Unexpected attribute value"))))
 198     (nreverse eudc-rec)))
 199
 200
 201
 202 (defun eudc-bbdb-query-internal (query &optional return-attrs)
 203   "Query BBDB  with QUERY.
 204 QUERY is a list of cons cells (ATTR . VALUE) where ATTRs should be valid
 205 BBDB attribute names.
 206 RETURN-ATTRS is a list of attributes to return, defaulting to
 207 `eudc-default-return-attributes'."
 208   (require 'bbdb)
 209   (let ((eudc-bbdb-current-query query)
 210         (eudc-bbdb-current-return-attributes return-attrs)
 211         (query-attrs (eudc-bbdb-format-query query))
 212         bbdb-attrs
 213         (records (bbdb-records))
 214         result
 215         filtered)
 216     ;; BBDB ORs its query attributes while EUDC ANDs them, hence we need to
 217     ;; call bbdb-search iteratively on the returned records for each of the
 218     ;; requested attributes
 219     (while (and records (> (length query-attrs) 0))
 220       (setq bbdb-attrs (append bbdb-attrs (list (car query-attrs))))
 221       (if (car query-attrs)
 222           (setq records (eval `(bbdb-search ,(quote records) ,@bbdb-attrs))))
 223       (setq query-attrs (cdr query-attrs)))
 224     (mapc (function
 225            (lambda (record)
 226              (setq filtered (eudc-filter-duplicate-attributes record))
 227              ;; If there were duplicate attributes reverse the order of the
 228              ;; record so the unique attributes appear first
 229              (if (> (length filtered) 1)
 230                  (setq filtered (mapcar (function
 231                                          (lambda (rec)
 232                                            (reverse rec)))
 233                                         filtered)))
 234              (setq result (append result filtered))))
 235           (delq nil
 236                 (mapcar 'eudc-bbdb-format-record-as-result
 237                         (delq nil
 238                               (mapcar 'eudc-bbdb-filter-non-matching-record
 239                                       records)))))
 240     result))
 241
 242 ;;}}}
 243
 244 ;;{{{      High-level interfaces (interactive functions)
 245
 246 (defun eudc-bbdb-set-server (dummy)
 247   "Set the EUDC server to BBDB."
 248   (interactive)
 249   (eudc-set-server dummy 'bbdb)
 250   (message "BBDB server selected"))
 251
 252 ;;}}}
 253
 254
 255 (eudc-register-protocol 'bbdb)
 256
 257 (provide 'eudcb-bbdb)
 258
 259 ;;; eudcb-bbdb.el ends here