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