1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
|
;;; eudc-export.el --- functions to export EUDC query results -*- lexical-binding: t; -*-
;; Copyright (C) 1998-2021 Free Software Foundation, Inc.
;; Author: Oscar Figueiredo <oscar@cpe.fr>
;; Pavel Janík <Pavel@Janik.cz>
;; Maintainer: Thomas Fitzsimmons <fitzsim@fitzsim.org>
;; Keywords: comm
;; Package: eudc
;; 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 3 of the License, 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. If not, see <https://www.gnu.org/licenses/>.
;;; Commentary:
;;; Usage:
;; See the corresponding info file
;;; Code:
(require 'eudc)
;; NOERROR is so we can compile it.
(require 'bbdb nil t)
(require 'bbdb-com nil t)
(require 'cl-lib)
(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."
(require 'bbdb)
(declare-function bbdb-create-internal "bbdb-com" (&rest spec))
(declare-function bbdb-display-records "bbdb"
(records &optional layout append))
;; This function runs in a special context where lisp symbols corresponding
;; to field names in record are bound to the corresponding values
(cl-progv (mapcar #'car record) (mapcar #'cdr record)
(let* (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 (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
(apply #'bbdb-create-internal
`(,bbdb-name
,@(when (eudc--using-bbdb-3-or-newer-p)
'(nil
nil))
,bbdb-company
,bbdb-net
,@(if (eudc--using-bbdb-3-or-newer-p)
(list bbdb-phones
bbdb-address)
(list 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 t)
(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 address 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)))
;; External.
(declare-function bbdb-parse-phone-number "ext:bbdb-com"
(string &optional number-type))
(declare-function bbdb-parse-phone "ext:bbdb-com" (string &optional style))
(declare-function bbdb-string-trim "ext:bbdb" (string))
(defun eudc-bbdbify-company (&rest organizations)
"Return ORGANIZATIONS as a list compatible with BBDB."
organizations)
(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."
(require 'bbdb)
(cond
((stringp phone)
(let (phone-list)
(condition-case err
(setq phone-list (if (eudc--using-bbdb-3-or-newer-p)
(bbdb-parse-phone phone)
(bbdb-parse-phone-number phone)))
(error
(if (string= "phone number unparsable." (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)
(require 'bbdb)
(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)
(require 'bbdb)
(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)
(require 'bbdb)
(and (overlays-at (point))
(overlay-get (car (overlays-at (point))) 'eudc-record)
(eudc-insert-record-at-point-into-bbdb)))
;;; eudc-export.el ends here
|
