1;;; eudcb-mab.el --- Emacs Unified Directory Client - AddressBook backend
2
3;; Copyright (C) 2003, 2004, 2005, 2006, 2007 Free Software Foundation, Inc.
4
5;; Author: John Wiegley <johnw@newartisans.com>
6;; Maintainer: FSF
7;; Keywords: comm
8
9;; This file is part of GNU Emacs.
10
11;; This program is free software; you can redistribute it and/or
12;; modify it under the terms of the GNU General Public License as
13;; published by the Free Software Foundation; either version 2, or (at
14;; your option) any later version.
15
16;; This program is distributed in the hope that it will be useful, but
17;; WITHOUT ANY WARRANTY; without even the implied warranty of
18;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
19;; 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., 51 Franklin Street, Fifth Floor,
24;; Boston, MA 02110-1301, USA.
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.
50QUERY is a list of cons cells (ATTR . VALUE) where ATTRs should be valid
51MAB attribute names.
52RETURN-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
135