[bpt/emacs.git] / lisp / net / eudc-export.el

;;; eudc-export.el --- functions to export EUDC query results

;; Copyright (C) 1998, 1999, 2000 Free Software Foundation, Inc.

;; Author: Oscar Figueiredo <oscar@xemacs.org>
;; Maintainer: Oscar Figueiredo <oscar@xemacs.org>
;; Keywords: help

;; This file is part of GNU Emacs.

;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.

;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING.  If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.

;;; Commentary:

;;; Usage:
;;    See the corresponding info file

;;; Code:

(require 'eudc)

(if (not (featurep 'bbdb))
    (load-library "bbdb"))
(if (not (featurep 'bbdb-com))
    (load-library "bbdb-com"))

(defun eudc-create-bbdb-record (record &optional silent)
  "Create a BBDB record using the RECORD alist.
RECORD is an alist of (KEY . VALUE) where KEY is a directory attribute name
symbol and VALUE is the corresponding value for the record.
If SILENT is non-nil then the created BBDB record is not displayed."
  ;; This function runs in a special context where lisp symbols corresponding
  ;; to field names in record are bound to the corresponding values
  (eval 
   `(let* (,@(mapcar '(lambda (c)
			(list (car c) (if (listp (cdr c))
					  (list 'quote (cdr c))
					(cdr c))))
		     record)
	     bbdb-name
	     bbdb-company
	     bbdb-net
	     bbdb-address
	     bbdb-phones
	     bbdb-notes
	     spec
	     bbdb-record
	     value
	     (conversion-alist (symbol-value eudc-bbdb-conversion-alist)))

      ;; BBDB standard fields
      (setq bbdb-name (eudc-parse-spec (cdr (assq 'name conversion-alist)) record nil)
	    bbdb-company (eudc-parse-spec (cdr (assq 'company conversion-alist)) record nil)
	    bbdb-net (eudc-parse-spec (cdr (assq 'net conversion-alist)) record nil)
	    bbdb-notes (eudc-parse-spec (cdr (assq 'notes conversion-alist)) record nil))
      (setq spec (cdr (assq 'address conversion-alist)))
      (setq bbdb-address (delq nil (eudc-parse-spec (if (listp (car spec))
						      spec
						    (list spec))
						  record t)))
      (setq spec (cdr (assq 'phone conversion-alist)))
      (setq bbdb-phones (delq nil (eudc-parse-spec (if (listp (car spec))
						     spec
						   (list spec))
						 record t)))
      ;; BBDB custom fields
      (setq bbdb-notes (append (list (and bbdb-notes (cons 'notes bbdb-notes)))
			       (mapcar (function
					(lambda (mapping)
					  (if (and (not (memq (car mapping)
							      '(name company net address phone notes)))
						   (setq value (eudc-parse-spec (cdr mapping) record nil)))
					      (cons (car mapping) value))))
				       conversion-alist)))
      (setq bbdb-notes (delq nil bbdb-notes))
      (setq bbdb-record (bbdb-create-internal bbdb-name 
					      bbdb-company 
					      bbdb-net
					      bbdb-address
					      bbdb-phones
					      bbdb-notes))
      (or silent
	  (bbdb-display-records (list bbdb-record))))))

(defun eudc-parse-spec (spec record recurse)
  "Parse the conversion SPEC using RECORD.
If RECURSE is non-nil then SPEC may be a list of atomic specs."
  (cond 
   ((or (stringp spec)
	(symbolp spec)
	(and (listp spec)
	     (symbolp (car spec))
	     (fboundp (car spec))))
    (condition-case nil
	(eval spec)
      (void-variable nil)))
   ((and recurse
	 (listp spec))
    (mapcar '(lambda (spec-elem)
	       (eudc-parse-spec spec-elem record nil))
	    spec))
   (t
    (error "Invalid specification for `%s' in `eudc-bbdb-conversion-alist'" spec))))

(defun eudc-bbdbify-address (addr location)
  "Parse ADDR into a vector compatible with BBDB.
ADDR should be an address string of no more than four lines or a
list of lines.
The last two lines are searched for the zip code, city and state name.
LOCATION is used as the address location for bbdb."
  (let* ((addr-components (if (listp addr)
			      (reverse addr)
			    (reverse (split-string addr "\n"))))
	 (last1 (pop addr-components))
	 (last2 (pop addr-components))
	 zip city state)
    (setq addr-components (nreverse addr-components))
    ;; If not containing the zip code the last line is supposed to contain a
    ;; country name and the addres is supposed to be in european style
    (if (not (string-match "[0-9][0-9][0-9]" last1))
	(progn
	  (setq state last1)
	  (if (string-match "\\([0-9]+\\)[ \t]+\\(.*\\)" last2)
	      (setq city (match-string 2 last2)
		    zip (string-to-number (match-string 1 last2)))
	    (error "Cannot parse the address")))
      (cond
       ;; American style
       ((string-match "\\(\\w+\\)\\W*\\([A-Z][A-Z]\\)\\W*\\([0-9]+\\)" last1)
	(setq city (match-string 1 last1)
	      state (match-string 2 last1)
	      zip (string-to-number (match-string 3 last1))))
       ;; European style
       ((string-match "\\([0-9]+\\)[ \t]+\\(.*\\)" last1)
	(setq city (match-string 2 last1)
	      zip (string-to-number (match-string 1 last1))))
       (t
	(error "Cannot parse the address"))))
    (vector location 
	    (or (nth 0 addr-components) "")
	    (or (nth 1 addr-components) "")
	    (or (nth 2 addr-components) "")
	    (or city "")
	    (or state "")
	    zip)))

(defun eudc-bbdbify-phone (phone location)
  "Parse PHONE into a vector compatible with BBDB.
PHONE is either a string supposedly containing a phone number or
a list of such strings which are concatenated.
LOCATION is used as the phone location for BBDB."
  (cond 
   ((stringp phone)
    (let (phone-list)
      (condition-case err
	  (setq phone-list (bbdb-parse-phone-number phone))
	(error
	 (if (string= "phone number unparsable." (eudc-cadr err))
	     (if (not (y-or-n-p (format "BBDB claims %S to be unparsable--insert anyway? " phone)))
		 (error "Phone number unparsable")
	       (setq phone-list (list (bbdb-string-trim phone))))
	   (signal (car err) (cdr err)))))
      (if (= 3 (length phone-list))
	  (setq phone-list (append phone-list '(nil))))
      (apply 'vector location phone-list)))
   ((listp phone)
    (vector location (mapconcat 'identity phone ", ")))
   (t
    (error "Invalid phone specification"))))
      
(defun eudc-batch-export-records-to-bbdb ()
  "Insert all the records returned by a directory query into BBDB."
  (interactive)
  (goto-char (point-min))
  (let ((nbrec 0)
	record)
    (while (eudc-move-to-next-record)
      (and (overlays-at (point))
	   (setq record (overlay-get (car (overlays-at (point))) 'eudc-record))
	   (1+ nbrec)
	   (eudc-create-bbdb-record record t)))
    (message "%d records imported into BBDB" nbrec)))

;;;###autoload
(defun eudc-insert-record-at-point-into-bbdb ()
  "Insert record at point into the BBDB database.
This function can only be called from a directory query result buffer."
  (interactive)
  (let ((record (and (overlays-at (point))
		     (overlay-get (car (overlays-at (point))) 'eudc-record))))
    (if (null record)
	(error "Point is not over a record")
      (eudc-create-bbdb-record record))))

;;;###autoload
(defun eudc-try-bbdb-insert ()
  "Call `eudc-insert-record-at-point-into-bbdb' if on a record."
  (interactive)
  (and (or (featurep 'bbdb)
	   (prog1 (locate-library "bbdb") (message "")))
       (overlays-at (point))
       (overlay-get (car (overlays-at (point))) 'eudc-record)
       (eudc-insert-record-at-point-into-bbdb)))

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