1;;; eudc-export.el --- functions to export EUDC query results
2
3;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004,
4;;   2005, 2006, 2007 Free Software Foundation, Inc.
5
6;; Author: Oscar Figueiredo <oscar@cpe.fr>
7;; Maintainer: Pavel Jan�k <Pavel@Janik.cz>
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 2, or (at your option)
15;; 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; see the file COPYING.  If not, write to the
24;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
25;; Boston, MA 02110-1301, USA.
26
27;;; Commentary:
28
29;;; Usage:
30;;    See the corresponding info file
31
32;;; Code:
33
34(require 'eudc)
35
36(if (not (featurep 'bbdb))
37    (load-library "bbdb"))
38(if (not (featurep 'bbdb-com))
39    (load-library "bbdb-com"))
40
41(defun eudc-create-bbdb-record (record &optional silent)
42  "Create a BBDB record using the RECORD alist.
43RECORD is an alist of (KEY . VALUE) where KEY is a directory attribute name
44symbol and VALUE is the corresponding value for the record.
45If SILENT is non-nil then the created BBDB record is not displayed."
46  ;; This function runs in a special context where lisp symbols corresponding
47  ;; to field names in record are bound to the corresponding values
48  (eval
49   `(let* (,@(mapcar '(lambda (c)
50			(list (car c) (if (listp (cdr c))
51					  (list 'quote (cdr c))
52					(cdr c))))
53		     record)
54	     bbdb-name
55	     bbdb-company
56	     bbdb-net
57	     bbdb-address
58	     bbdb-phones
59	     bbdb-notes
60	     spec
61	     bbdb-record
62	     value
63	     (conversion-alist (symbol-value eudc-bbdb-conversion-alist)))
64
65      ;; BBDB standard fields
66      (setq bbdb-name (eudc-parse-spec (cdr (assq 'name conversion-alist)) record nil)
67	    bbdb-company (eudc-parse-spec (cdr (assq 'company conversion-alist)) record nil)
68	    bbdb-net (eudc-parse-spec (cdr (assq 'net conversion-alist)) record nil)
69	    bbdb-notes (eudc-parse-spec (cdr (assq 'notes conversion-alist)) record nil))
70      (setq spec (cdr (assq 'address conversion-alist)))
71      (setq bbdb-address (delq nil (eudc-parse-spec (if (listp (car spec))
72						      spec
73						    (list spec))
74						  record t)))
75      (setq spec (cdr (assq 'phone conversion-alist)))
76      (setq bbdb-phones (delq nil (eudc-parse-spec (if (listp (car spec))
77						     spec
78						   (list spec))
79						 record t)))
80      ;; BBDB custom fields
81      (setq bbdb-notes (append (list (and bbdb-notes (cons 'notes bbdb-notes)))
82			       (mapcar (function
83					(lambda (mapping)
84					  (if (and (not (memq (car mapping)
85							      '(name company net address phone notes)))
86						   (setq value (eudc-parse-spec (cdr mapping) record nil)))
87					      (cons (car mapping) value))))
88				       conversion-alist)))
89      (setq bbdb-notes (delq nil bbdb-notes))
90      (setq bbdb-record (bbdb-create-internal bbdb-name
91					      bbdb-company
92					      bbdb-net
93					      bbdb-address
94					      bbdb-phones
95					      bbdb-notes))
96      (or silent
97	  (bbdb-display-records (list bbdb-record))))))
98
99(defun eudc-parse-spec (spec record recurse)
100  "Parse the conversion SPEC using RECORD.
101If RECURSE is non-nil then SPEC may be a list of atomic specs."
102  (cond
103   ((or (stringp spec)
104	(symbolp spec)
105	(and (listp spec)
106	     (symbolp (car spec))
107	     (fboundp (car spec))))
108    (condition-case nil
109	(eval spec)
110      (void-variable nil)))
111   ((and recurse
112	 (listp spec))
113    (mapcar '(lambda (spec-elem)
114	       (eudc-parse-spec spec-elem record nil))
115	    spec))
116   (t
117    (error "Invalid specification for `%s' in `eudc-bbdb-conversion-alist'" spec))))
118
119(defun eudc-bbdbify-address (addr location)
120  "Parse ADDR into a vector compatible with BBDB.
121ADDR should be an address string of no more than four lines or a
122list of lines.
123The last two lines are searched for the zip code, city and state name.
124LOCATION is used as the address location for bbdb."
125  (let* ((addr-components (if (listp addr)
126			      (reverse addr)
127			    (reverse (split-string addr "\n"))))
128	 (last1 (pop addr-components))
129	 (last2 (pop addr-components))
130	 zip city state)
131    (setq addr-components (nreverse addr-components))
132    ;; If not containing the zip code the last line is supposed to contain a
133    ;; country name and the addres is supposed to be in european style
134    (if (not (string-match "[0-9][0-9][0-9]" last1))
135	(progn
136	  (setq state last1)
137	  (if (string-match "\\([0-9]+\\)[ \t]+\\(.*\\)" last2)
138	      (setq city (match-string 2 last2)
139		    zip (string-to-number (match-string 1 last2)))
140	    (error "Cannot parse the address")))
141      (cond
142       ;; American style
143       ((string-match "\\(\\w+\\)\\W*\\([A-Z][A-Z]\\)\\W*\\([0-9]+\\)" last1)
144	(setq city (match-string 1 last1)
145	      state (match-string 2 last1)
146	      zip (string-to-number (match-string 3 last1))))
147       ;; European style
148       ((string-match "\\([0-9]+\\)[ \t]+\\(.*\\)" last1)
149	(setq city (match-string 2 last1)
150	      zip (string-to-number (match-string 1 last1))))
151       (t
152	(error "Cannot parse the address"))))
153    (vector location
154	    (or (nth 0 addr-components) "")
155	    (or (nth 1 addr-components) "")
156	    (or (nth 2 addr-components) "")
157	    (or city "")
158	    (or state "")
159	    zip)))
160
161(defun eudc-bbdbify-phone (phone location)
162  "Parse PHONE into a vector compatible with BBDB.
163PHONE is either a string supposedly containing a phone number or
164a list of such strings which are concatenated.
165LOCATION is used as the phone location for BBDB."
166  (cond
167   ((stringp phone)
168    (let (phone-list)
169      (condition-case err
170	  (setq phone-list (bbdb-parse-phone-number phone))
171	(error
172	 (if (string= "phone number unparsable." (eudc-cadr err))
173	     (if (not (y-or-n-p (format "BBDB claims %S to be unparsable--insert anyway? " phone)))
174		 (error "Phone number unparsable")
175	       (setq phone-list (list (bbdb-string-trim phone))))
176	   (signal (car err) (cdr err)))))
177      (if (= 3 (length phone-list))
178	  (setq phone-list (append phone-list '(nil))))
179      (apply 'vector location phone-list)))
180   ((listp phone)
181    (vector location (mapconcat 'identity phone ", ")))
182   (t
183    (error "Invalid phone specification"))))
184
185(defun eudc-batch-export-records-to-bbdb ()
186  "Insert all the records returned by a directory query into BBDB."
187  (interactive)
188  (goto-char (point-min))
189  (let ((nbrec 0)
190	record)
191    (while (eudc-move-to-next-record)
192      (and (overlays-at (point))
193	   (setq record (overlay-get (car (overlays-at (point))) 'eudc-record))
194	   (1+ nbrec)
195	   (eudc-create-bbdb-record record t)))
196    (message "%d records imported into BBDB" nbrec)))
197
198;;;###autoload
199(defun eudc-insert-record-at-point-into-bbdb ()
200  "Insert record at point into the BBDB database.
201This function can only be called from a directory query result buffer."
202  (interactive)
203  (let ((record (and (overlays-at (point))
204		     (overlay-get (car (overlays-at (point))) 'eudc-record))))
205    (if (null record)
206	(error "Point is not over a record")
207      (eudc-create-bbdb-record record))))
208
209;;;###autoload
210(defun eudc-try-bbdb-insert ()
211  "Call `eudc-insert-record-at-point-into-bbdb' if on a record."
212  (interactive)
213  (and (or (featurep 'bbdb)
214	   (prog1 (locate-library "bbdb") (message "")))
215       (overlays-at (point))
216       (overlay-get (car (overlays-at (point))) 'eudc-record)
217       (eudc-insert-record-at-point-into-bbdb)))
218
219;;; arch-tag: 8cbda7dc-3163-47e6-921c-6ec5083df2d7
220;;; eudc-export.el ends here
221