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
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
|
;;; BBDB merge/sync framework
;;; GNU Public License to go here. This file is under GPL, thanks guys.
;;; Copyright (c) 2000 Waider
(require 'bbdb)
(require 'bbdb-com)
;;; to do:
;;; smarter phone, notes and address merging.
;;;###autoload
(defun bbdb-merge-record (new-record &optional merge-record override)
"Generic merge function.
Merges new-record into your bbdb, using DATE to check who's more
up-to-date and OVERRIDE to decide who gets precedence if two dates
match. DATE can be extracted from a notes if it's an alist with an
element marked timestamp. Set OVERRIDE to 'new to allow the new record
to stomp on existing data, 'old to preserve existing data or nil to
merge both together. If it can't find a record to merge with, it will
create a new record. If MERGE-RECORD is set, it's a record discovered
by other means that should be merged with.
Returns the Grand Unified Record."
(let* ((firstname (bbdb-record-firstname new-record))
(lastname (bbdb-record-lastname new-record))
(aka (bbdb-record-aka new-record))
(nets (bbdb-record-net new-record))
(addrs (bbdb-record-addresses new-record))
(phones (bbdb-record-phones new-record))
(company (bbdb-record-company new-record))
(notes (bbdb-record-raw-notes new-record))
(name (bbdb-string-trim (concat firstname " " lastname)))
(date (if (listp notes) (cdr (assq 'timestamp notes)) nil))
olddate)
;; for convenience
(if (stringp notes)
(setq notes (list (cons 'notes notes))))
;; See if we have a record that looks right, using an intertwingle
;; search. Could probably parameterize that.
;; bbdb-merge-search-function or some such.
(if (null merge-record)
(setq merge-record (bbdb-search-simple name nets)))
(if merge-record
(progn
;; if date is unset, set it to the existing record's date.
(setq olddate (bbdb-record-getprop merge-record 'timestamp)
date (or date olddate))
;; FIXME if date & olddate are STILL unset, set to today's date.
;; if the old record is actually newer, invert the sense of override
(if (string-lessp olddate date)
(setq override (cond ((eq 'old override) 'new)
((eq 'new override) 'old)
(t nil))))
(bbdb-record-set-firstname merge-record
(if (null override)
(bbdb-merge-strings (bbdb-record-firstname merge-record)
firstname " ")
(if (eq 'new override) firstname
(bbdb-record-firstname merge-record))))
(bbdb-record-set-lastname merge-record
(if (null override)
(bbdb-merge-strings (bbdb-record-lastname merge-record)
lastname " ")
(if (eq 'new override) lastname
(bbdb-record-lastname merge-record))))
(bbdb-record-set-company merge-record
(if (null override)
(bbdb-merge-strings (bbdb-record-company merge-record)
company " ")
(if (eq 'new override) company
(bbdb-record-company merge-record))))
(bbdb-record-set-aka
merge-record
(if (null override)
(bbdb-merge-lists!
(bbdb-record-aka merge-record)
(if (listp aka) aka (list aka)) 'string= 'downcase)
(if (eq 'new override) aka
(bbdb-record-aka merge-record))))
(bbdb-record-set-net
merge-record
(if (null override)
(bbdb-merge-lists!
(bbdb-record-net merge-record) nets 'string= 'downcase)
(if (eq 'new override) nets
(bbdb-record-net merge-record))))
(bbdb-record-set-phones
merge-record
(if (null override)
(bbdb-merge-lists!
(bbdb-record-phones merge-record) phones 'equal)
(if (eq 'new override) phones
(bbdb-record-phones merge-record))))
(bbdb-record-set-addresses
merge-record
(if (null override)
(bbdb-merge-lists!
(bbdb-record-addresses merge-record) addrs 'equal)
(if (eq 'new override) addrs
(bbdb-record-addresses merge-record))))
;; lifted from bbdb-com.el
(let ((n1 (bbdb-record-raw-notes merge-record))
(n2 notes)
tmp
(bbdb-refile-notes-default-merge-function ;; XXX
'bbdb-merge-strings))
(or (equal n1 n2)
(progn
(or (listp n1) (setq n1 (list (cons 'notes n1))))
(or (listp n2) (setq n2 (list (cons 'notes n2))))
(while n2
(if (setq tmp (assq (car (car n2)) n1))
(setcdr tmp
(funcall (or (cdr (assq (car (car n2))
bbdb-refile-notes-generate-alist))
bbdb-refile-notes-default-merge-function)
(cdr tmp) (cdr (car n2))))
(setq n1 (nconc n1 (list (car n2)))))
(setq n2 (cdr n2)))
(bbdb-record-set-raw-notes merge-record n1)))))
;; we couldn't find a record, so create one
(setq merge-record
(bbdb-create-internal name company nets addrs phones notes))
;; bite me, bbdb-create-internal
(bbdb-record-set-firstname merge-record firstname)
(bbdb-record-set-lastname merge-record lastname))
;; more general bitingness
(if (equal (bbdb-record-firstname merge-record) "")
(bbdb-record-set-firstname merge-record nil))
(if (equal (bbdb-record-lastname merge-record) "")
(bbdb-record-set-lastname merge-record nil))
;; fix up the in-memory copy.
(bbdb-change-record merge-record t)
(let ((name (bbdb-record-name merge-record))
(lastname (bbdb-record-lastname merge-record))
(company (bbdb-record-company merge-record)))
(if (> (length name) 0)
(bbdb-remhash (downcase name) merge-record))
(if (> (length lastname) 0)
(bbdb-remhash (downcase lastname) merge-record))
(if (> (length company) 0)
(bbdb-remhash (downcase company) merge-record)))
(bbdb-record-set-namecache merge-record nil)
(if (or (bbdb-record-lastname merge-record)
(bbdb-record-firstname merge-record))
(bbdb-puthash (downcase (bbdb-record-name merge-record)) merge-record))
(if (bbdb-record-company merge-record)
(bbdb-puthash (downcase (bbdb-record-company merge-record))
merge-record))
(bbdb-with-db-buffer
(if (not (memq merge-record bbdb-changed-records))
(setq bbdb-changed-records
(cons merge-record bbdb-changed-records))))
;; your record, sir.
merge-record))
;; fixme these could be a macros, I guess.
(defun bbdb-instring( s1 s2 )
;; (and case-fold-search
;; (setq s1 (downcase s1)
;; s2 (downcase s2)))
(catch 'done
(while (>= (length s1) (length s2))
(if (string= s2 (substring s1 0 (length s2)))
(throw 'done t)
(setq s1 (substring s1 1))))
(throw 'done nil)))
(defun bbdb-merge-strings (s1 s2 &optional sep)
"Merge two strings together uniquely.
If s1 doesn't contain s2, return s1+sep+s2."
(cond ((or (null s1) (string-equal s1 "")) s2)
((or (null s2) (string-equal s2 "")) s1)
(t (if (bbdb-instring s2 s1) s1
(concat s1 (or sep "") s2)))))
;;;###autoload
(defun bbdb-merge-file (&optional bbdb-new override match-fun)
"Merge a bbdb file into the in-core bbdb."
(interactive "fMerge bbdb file: ")
(or bbdb-gag-messages
bbdb-silent-running
(message "Merging %s" bbdb-new))
;; argh urgle private environment
(let* ((bbdb-live-file bbdb-file)
(bbdb-file bbdb-new)
(bbdb-live-buffer-name bbdb-buffer-name)
(bbdb-buffer-name "*BBDB-merge*")
(bbdb-buffer nil) ;; hack hack
(new-records (bbdb-records))
(bbdb-buffer nil) ;; hack hack
(bbdb-file bbdb-live-file)
(bbdb-buffer-name bbdb-live-buffer-name)
(bbdb-refile-notes-default-merge-function 'bbdb-merge-strings))
;; merge everything
(mapcar (lambda(rec)
(bbdb-merge-record rec
(and match-fun
(funcall match-fun rec))
override))
new-records))
;; hack
(setq bbdb-buffer (or (get-file-buffer bbdb-file) nil)))
(defun bbdb-add-or-update-phone ( record location phone-string )
"Add or update a phone number in the current record.
Insert into RECORD phone number for LOCATION consisting of
PHONE-STRING. Will automatically overwrite an existing phone entry for
the same location."
(let* ((phone (make-vector (if bbdb-north-american-phone-numbers-p
bbdb-phone-length
2)
nil)))
(if (= 2 (length phone))
(aset phone 1 phone-string)
(let ((newp (bbdb-parse-phone-number phone-string)))
(bbdb-phone-set-area phone (nth 0 newp))
(bbdb-phone-set-exchange phone (nth 1 newp))
(bbdb-phone-set-suffix phone (nth 2 newp))
(bbdb-phone-set-extension phone (or (nth 3 newp) 0))))
(bbdb-phone-set-location phone location)
;; "phone" now contains a suitable record
;; we need to check if this is already in the phones list
(let ((phones (bbdb-record-phones record))
phones-list)
(setq phones-list phones)
(while (car phones-list)
(if (string= (bbdb-phone-location (car phones-list))
location)
(setq phones (delete (car phones-list) phones)))
(setq phones-list (cdr phones-list)))
(bbdb-record-set-phones record
(nconc phones (list phone))))
(bbdb-change-record record nil)
;; update display if record is visible
(and (get-buffer-window bbdb-buffer-name)
(bbdb-display-records (list record)))
nil))
(provide 'bbdb-merge)
|
