lisp/net/eudcb-mab.el

   1 ;;; eudcb-mab.el --- Emacs Unified Directory Client - AddressBook backend
   2
   3 ;; Copyright (C) 2003, 2004, 2005, 2006, 2007, 2008, 2009
   4 ;;   Free Software Foundation, Inc.
   5
   6 ;; Author: John Wiegley <johnw@newartisans.com>
   7 ;; Maintainer: FSF
   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 3 of the License, or
  15 ;; (at your option) 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.  If not, see <http://www.gnu.org/licenses/>.
  24
  25 ;;; Commentary:
  26 ;;    This library provides an interface to use the Mac's AddressBook,
  27 ;;    by way of the "contacts" command-line utility which can be found
  28 ;;    by searching on the Net.
  29
  30 ;;; Code:
  31
  32 (require 'eudc)
  33 (require 'executable)
  34
  35 ;;{{{      Internal cooking
  36
  37 (defvar eudc-mab-conversion-alist nil)
  38 (defvar eudc-buffer-time nil)
  39 (defvar eudc-contacts-file
  40   "~/Library/Application Support/AddressBook/AddressBook.data")
  41
  42 (eudc-protocol-set 'eudc-query-function 'eudc-mab-query-internal 'mab)
  43 (eudc-protocol-set 'eudc-list-attributes-function nil 'mab)
  44 (eudc-protocol-set 'eudc-mab-conversion-alist nil 'mab)
  45 (eudc-protocol-set 'eudc-protocol-has-default-query-attributes nil 'mab)
  46
  47 (defun eudc-mab-query-internal (query &optional return-attrs)
  48   "Query MAB  with QUERY.
  49 QUERY is a list of cons cells (ATTR . VALUE) where ATTRs should be valid
  50 MAB attribute names.
  51 RETURN-ATTRS is a list of attributes to return, defaulting to
  52 `eudc-default-return-attributes'."
  53
  54   (let ((fmt-string "%ln:%fn:%p:%e")
  55         (mab-buffer (get-buffer-create " *mab contacts*"))
  56         (modified (nth 5 (file-attributes eudc-contacts-file)))
  57         result)
  58     (with-current-buffer mab-buffer
  59       (make-local-variable 'eudc-buffer-time)
  60       (goto-char (point-min))
  61       (when (or (eobp) (time-less-p eudc-buffer-time modified))
  62         (erase-buffer)
  63         (call-process (executable-find "contacts") nil t nil
  64                       "-H" "-l" "-f" fmt-string)
  65         (setq eudc-buffer-time modified))
  66       (goto-char (point-min))
  67       (while (not (eobp))
  68         (let* ((args (split-string (buffer-substring (point)
  69                                                      (line-end-position))
  70                                    "\\s-*:\\s-*"))
  71                (lastname (nth 0 args))
  72                (firstname (nth 1 args))
  73                (phone (nth 2 args))
  74                (mail (nth 3 args))
  75                (matched t))
  76
  77           (if (string-match "\\s-+\\'" mail)
  78               (setq mail (replace-match "" nil nil mail)))
  79
  80           (dolist (term query)
  81             (cond
  82              ((eq (car term) 'name)
  83               (unless (string-match (cdr term)
  84                                     (concat firstname " " lastname))
  85                 (setq matched nil)))
  86              ((eq (car term) 'email)
  87               (unless (string= (cdr term) mail)
  88                 (setq matched nil)))
  89              ((eq (car term) 'phone))))
  90
  91           (when matched
  92             (setq result
  93                   (cons `((firstname . ,firstname)
  94                           (lastname . ,lastname)
  95                           (name . ,(concat firstname " " lastname))
  96                           (phone . ,phone)
  97                           (email . ,mail)) result))))
  98         (forward-line)))
  99     (if (null return-attrs)
 100         result
 101       (let (eudc-result)
 102         (dolist (entry result)
 103           (let (entry-attrs abort)
 104             (dolist (attr entry)
 105               (when (memq (car attr) return-attrs)
 106                 (if (= (length (cdr attr)) 0)
 107                     (setq abort t)
 108                   (setq entry-attrs
 109                         (cons attr entry-attrs)))))
 110             (if (and entry-attrs (not abort))
 111                 (setq eudc-result
 112                       (cons entry-attrs eudc-result)))))
 113         eudc-result))))
 114
 115 ;;}}}
 116
 117 ;;{{{      High-level interfaces (interactive functions)
 118
 119 (defun eudc-mab-set-server (dummy)
 120   "Set the EUDC server to MAB."
 121   (interactive)
 122   (eudc-set-server dummy 'mab)
 123   (message "MAB server selected"))
 124
 125 ;;}}}
 126
 127
 128 (eudc-register-protocol 'mab)
 129
 130 (provide 'eudcb-mab)
 131
 132 ;; arch-tag: 4bef8e65-f109-47c7-91b9-8a6ea3ed7bb1
 133 ;;; eudcb-mab.el ends here