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
|
;;; 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))
(company (bbdb-record-company merge-record)))
(if (> (length name) 0)
(bbdb-remhash (downcase name) 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 this could be a macro, I guess.
(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 (string-match 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
(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*")
(new-records (bbdb-records))
(bbdb-buffer nil) ;; hack hack
(bbdb-file bbdb-live-file)
(bbdb-buffer-name bbdb-live-buffer-name)
(live-records (bbdb-records))
(bbdb-refile-notes-default-merge-function 'bbdb-merge-strings))
;; merge everything
(mapcar (function (lambda(rec)
(bbdb-merge-record rec
(if match-fun
(funcall match-fun r)
nil)
override))) new-records))
;; hack
(setq bbdb-buffer (or (get-file-buffer bbdb-file) nil)))
(provide 'bbdb-merge)
|
