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
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
|
;;; -*- Mode:Emacs-Lisp -*-
;;; This file contains the migration functions for the Insidious Big
;;; Brother Database (aka BBDB), copyright (c) 1991, 1992, 1993, 1994
;;; Jamie Zawinski <jwz@netscape.com>. See the file bbdb.texinfo for
;;; documentation.
;;;
;;; The Insidious Big Brother Database 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.
;;;
;;; BBDB 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, 675 Mass Ave, Cambridge, MA 02139, USA.
;;;
(require 'bbdb)
;;; Migrating the BBDB
;; Features that have changed in the various database revs. Format:
;; ((VERSION . DIFFERENCES) ... )
(defconst bbdb-migration-features
'((3 . "* Date format for `creation-date' and `timestamp' has changed,
from \"dd mmm yy\" (ex: 25 Sep 97) to \"yyyy-mm-dd\" (ex: 1997-09-25).")
(4 . "* Country field added.")
(5 . "* More flexible street address.")
(6 . "* Zip codes are stored as plain strings.")))
;;;###autoload
(defun bbdb-migration-query (ondisk)
"Ask if the database is to be migrated.
ONDISK is the version number of the database as currently stored on
disk. Returns the version for the saved database."
(save-excursion
(let ((wc (current-window-configuration))
(buf (get-buffer-create "*BBDB Migration Info*"))
(newfeatures bbdb-migration-features)
(first t)
win update)
(set-buffer buf)
(erase-buffer)
(goto-char (point-min))
(insert (format "BBDB new data version notice:
=============================
Your BBDB data is stored in an older format (version %d). At this point,
you have the option of either upgrading or continuing to save your data
in your current format. Please note that if you elect the latter option,
any changes made to your data using features intended for the newer
versions will be lost. For your convenience, a list of file format
changes introduced after version %d is shown below:\n\n" ondisk ondisk))
(while newfeatures
(if (> (caar newfeatures) ondisk)
(insert (concat (if first (setq first nil) "\n\n")
"New features in database version "
(format "%d" (caar newfeatures))
":\n\n" (cdar newfeatures))))
(setq newfeatures (cdr newfeatures)))
(setq win (display-buffer buf))
(shrink-window-if-larger-than-buffer win)
(setq update
(y-or-n-p (concat "Upgrade BBDB to version "
(format "%d" bbdb-file-format)
"? ")))
(condition-case nil
(delete-window win)
;; The window might be the only one on its frame. Hopefully, it's
;; a dedicated window and the kill-buffer below will DTRT.
(error nil))
(kill-buffer buf)
(set-window-configuration wc)
(if update bbdb-file-format ondisk))))
;;;###autoload
(defun bbdb-migrate (records)
"Migrate the BBDB from the version on disk (the car of
`bbdb-file-format-migration') to the current version (in
`bbdb-file-format')."
(bbdb-mapc (bbdb-migrate-versions-lambda (car bbdb-file-format-migration))
records)
records)
;;;###autoload
(defun bbdb-unmigrate-record (record)
"Reverse-migrate a single record from the current version (in
`bbdb-file-format') to the version to be saved (the cdr of
`bbdb-file-format-migration')."
(funcall (bbdb-migrate-versions-lambda bbdb-file-format
(car bbdb-file-format-migration))
record)
record)
(defconst bbdb-migration-spec
'((2 (bbdb-record-raw-notes bbdb-record-set-raw-notes
bbdb-migrate-change-dates))
(3 (bbdb-record-addresses bbdb-record-set-addresses
bbdb-migrate-add-country-field))
(4 (bbdb-record-addresses bbdb-record-set-addresses
bbdb-migrate-streets-to-list))
(5 (bbdb-record-addresses bbdb-record-set-addresses
bbdb-migrate-zip-codes-to-strings)))
"The alist of (version . migration-spec-list).
See `bbdb-migrate-record-lambda' for details.")
(defconst bbdb-unmigration-spec
'((2 (bbdb-record-raw-notes bbdb-record-set-raw-notes
bbdb-unmigrate-change-dates))
(3 (bbdb-record-addresses bbdb-record-set-addresses
bbdb-unmigrate-add-country-field))
(4 (bbdb-record-addresses bbdb-record-set-addresses
bbdb-unmigrate-streets-to-list))
(5 (bbdb-record-addresses bbdb-record-set-addresses
bbdb-unmigrate-zip-codes-to-strings)))
"The alist of (version . migration-spec-list).
See `bbdb-migrate-record-lambda' for details.")
(defun bbdb-migrate-record-lambda (changes)
"Return a function which will migrate a single record.
CHANGES is a `migration-spec-list' containing entries of the form
(GET SET FUNCTION)
where GET is the function to be used to retrieve the field to be
modified, and SET is the function to be used to set the field to be
modified. FUNCTION will be applied to the result of GET, and its
results will be saved with SET."
(byte-compile `(lambda (rec)
,@(mapcar (lambda (ch)
`(,(cadr ch) rec
(,(car (cddr ch))
(,(car ch) rec))))
changes)
rec)))
(defun bbdb-migrate-versions-lambda (v0 &optional v1)
"Return the function to migrate from V0 to V1.
V1 defaults to `bbdb-file-format'."
(setq v1 (or v1 bbdb-file-format))
(let ((vv v0) spec)
(while (/= vv v1)
(setq spec (append spec (cdr (assoc vv bbdb-migration-spec)))
vv (if (< v0 v1) (1+ vv) (1- vv))))
(bbdb-migrate-record-lambda spec)))
(defun bbdb-migrate-zip-codes-to-strings (addrs)
"Make all zip codes plain strings.
This uses the code that used to be in bbdb-address-zip-string."
;; apply the function to all addresses in the list and return a
;; modified list of addresses
(mapcar (lambda (addr)
(let ((zip (if (stringp (bbdb-address-zip addr))
(bbdb-address-zip addr)
;; if not a string, make it a string...
(if (consp (bbdb-address-zip addr))
;; if a cons cell with two strings
(if (and (stringp (car (bbdb-address-zip addr)))
(stringp (car (cdr (bbdb-address-zip addr)))))
;; if the second string starts with 4 digits
(if (string-match "^[0-9][0-9][0-9][0-9]"
(car (cdr (bbdb-address-zip addr))))
(concat (car (bbdb-address-zip addr))
"-"
(car (cdr (bbdb-address-zip addr))))
;; if ("abc" "efg")
(concat (car (bbdb-address-zip addr))
" "
(car (cdr (bbdb-address-zip addr)))))
;; if ("SE" (123 45))
(if (and (stringp (nth 0 (bbdb-address-zip addr)))
(consp (nth 1 (bbdb-address-zip addr)))
(integerp (nth 0 (nth 1 (bbdb-address-zip addr))))
(integerp (nth 1 (nth 1 (bbdb-address-zip addr)))))
(format "%s-%d %d"
(nth 0 (bbdb-address-zip addr))
(nth 0 (nth 1 (bbdb-address-zip addr)))
(nth 1 (nth 1 (bbdb-address-zip addr))))
;; if a cons cell with two numbers
(if (and (integerp (car (bbdb-address-zip addr)))
(integerp (car (cdr (bbdb-address-zip addr)))))
(format "%05d-%04d" (car (bbdb-address-zip addr))
(car (cdr (bbdb-address-zip addr))))
;; else a cons cell with a string an a number (possible error
;; if a cons cell with a number and a string -- note the
;; order!)
(format "%s-%d" (car (bbdb-address-zip addr))
(car (cdr (bbdb-address-zip addr)))))))
;; if nil or zero
(if (or (eq 0 (bbdb-address-zip addr))
(null (bbdb-address-zip addr)))
""
;; else a number, could be 3 to 5 digits (possible error: assuming
;; no leading zeroes in zip codes)
(format "%d" (bbdb-address-zip addr)))))))
(bbdb-address-set-zip addr zip))
addr)
addrs))
(defun bbdb-unmigrate-zip-codes-to-strings (addrs)
"Make zip code string into zip code datastructures.
This uses the code that used to be in bbdb-parse-zip-string."
;; apply the function to all addresses in the list and return a
;; modified list of addresses
(mapcar (lambda (addr)
(let* ((string (bbdb-address-zip addr))
(zip (cond ((string-match "^[ \t\n]*$" string) 0)
;; Matches 1 to 6 digits.
((string-match "^[ \t\n]*[0-9][0-9]?[0-9]?[0-9]?[0-9]?[0-9]?[ \t\n]*$" string)
(string-to-number string))
;; Matches 5 digits and 3 or 4 digits.
((string-match "^[ \t\n]*\\([0-9][0-9][0-9][0-9][0-9]\\)[ \t\n]*-?[ \t\n]*\\([0-9][0-9][0-9][0-9]?\\)[ \t\n]*$" string)
(list (bbdb-subint string 1) (bbdb-subint string 2)))
;; Match zip codes for Canada, UK, etc. (result is ("LL47" "U4B")).
((string-match
"^[ \t\n]*\\([A-Za-z0-9]+\\)[ \t\n]+\\([A-Za-z0-9]+\\)[ \t\n]*$"
string)
(list (substring string (match-beginning 1) (match-end 1))
(substring string (match-beginning 2) (match-end 2))))
;; Match zip codes for continental Europe. Examples "CH-8057"
;; or "F - 83320" (result is ("CH" "8057") or ("F" "83320")).
;; Support for "NL-2300RA" added at request from Carsten Dominik
;; <dominik@astro.uva.nl>
((string-match
"^[ \t\n]*\\([A-Z]+\\)[ \t\n]*-?[ \t\n]*\\([0-9]+ ?[A-Z]*\\)[ \t\n]*$" string)
(list (substring string (match-beginning 1) (match-end 1))
(substring string (match-beginning 2) (match-end 2))))
;; Match zip codes from Sweden where the five digits are grouped 3+2
;; at the request from Mats Lofdahl <MLofdahl@solar.stanford.edu>.
;; (result is ("SE" (133 36)))
((string-match
"^[ \t\n]*\\([A-Z]+\\)[ \t\n]*-?[ \t\n]*\\([0-9]+\\)[ \t\n]+\\([0-9]+\\)[ \t\n]*$" string)
(list (substring string (match-beginning 1) (match-end 1))
(list (bbdb-subint string 2)
(bbdb-subint string 3)))))))
(bbdb-address-set-zip addr zip)
addr))
addrs))
(defun bbdb-migrate-change-dates (rec)
"Change date formats.
Formats are changed in timestamp and creation-date fields from
\"dd mmm yy\" to \"yyyy-mm-dd\". Assumes the notes are passed in as an
argument."
(unless (stringp rec)
(bbdb-mapc (lambda (rr)
(when (memq (car rr) '(creation-date timestamp))
(bbdb-migrate-change-dates-change-field rr)))
rec)
rec))
(defun bbdb-migrate-change-dates-change-field (field)
"Migrate the date field (the cdr of FIELD) from \"dd mmm yy\" to
\"yyyy-mm-dd\"."
(let ((date (cdr field))
parsed)
;; Verify and extract - this is fairly hideous
(and (equal (setq parsed (timezone-parse-date (concat date " 00:00:00")))
["0" "0" "0" "0" nil])
(equal (setq parsed (timezone-parse-date date))
["0" "0" "0" "0" nil])
(cond ((string-match
"^\\([0-9]\\{4\\}\\)[-/]\\([ 0-9]?[0-9]\\)[-/]\\([ 0-9]?[0-9]\\)" date)
(setq parsed (vector (string-to-number (match-string 1 date))
(string-to-number (match-string 2 date))
(string-to-number (match-string 3 date))))
;; This should be fairly loud for GNU Emacs users
(bbdb-warn "BBDB is treating %s field value %s as %s %d %d"
(car field) (cdr field)
(upcase-initials
(downcase (car (rassoc (aref parsed 1)
timezone-months-assoc))))
(aref parsed 2) (aref parsed 0)))
((string-match
"^\\([ 0-9]?[0-9]\\)[-/]\\([ 0-9]?[0-9]\\)[-/]\\([0-9]\\{4\\}\\)" date)
(setq parsed (vector (string-to-number (match-string 3 date))
(string-to-number (match-string 1 date))
(string-to-number (match-string 2 date))))
;; This should be fairly loud for GNU Emacs users
(bbdb-warn "BBDB is treating %s field value %s as %s %d %d"
(car field) (cdr field)
(upcase-initials
(downcase (car (rassoc (aref parsed 1)
timezone-months-assoc))))
(aref parsed 2) (aref parsed 0)))
(t ["0" "0" "0" "0" nil])))
;; I like numbers
(and (stringp (aref parsed 0))
(aset parsed 0 (string-to-number (aref parsed 0))))
(and (stringp (aref parsed 1))
(aset parsed 1 (string-to-number (aref parsed 1))))
(and (stringp (aref parsed 2))
(aset parsed 2 (string-to-number (aref parsed 2))))
;; Sanity check
(cond ((and (< 0 (aref parsed 0))
(< 0 (aref parsed 1)) (>= 12 (aref parsed 1))
(< 0 (aref parsed 2))
(>= (timezone-last-day-of-month (aref parsed 1)
(aref parsed 0))
(aref parsed 2)))
(setcdr field (format "%04d-%02d-%02d" (aref parsed 0)
(aref parsed 1) (aref parsed 2)))
field)
(t
(error "BBDB cannot parse %s header value %S for upgrade"
field date)))))
(defun bbdb-unmigrate-change-dates (rec)
"Change date formats.
Formats are changed in timestamp and creation-date fields from
\"yyyy-mm-dd\" to \"dd mmm yy\". Assumes the notes list is passed in
as an argument."
(unless (stringp rec)
(bbdb-mapc (lambda (rr)
(when (memq (car rr) '(creation-date timestamp))
(bbdb-unmigrate-change-dates-change-field rr)))
rec)
rec))
(defun bbdb-unmigrate-change-dates-change-field (field)
"Unmigrate the date field (the cdr of FIELD) from \"yyyy-mm-dd\" to
\"yyyy-mm-dd\"."
(cons (car field) (bbdb-time-convert (cdr field) "%e %b %y")))
(defun bbdb-migrate-add-country-field (addrl)
"Add a country field to each address in the address list."
(mapcar (lambda (addr) (vconcat addr [""])) addrl))
(defun bbdb-unmigrate-add-country-field (addrl)
"Remove the country field from each address in the address list."
;; Some version 4 zip codes will be illegal version 3 (as used in
;; 2.00.06) zip codes. This problem has not been solved.
(mapcar (lambda (addr)
(let* ((len (1- (length addr)))
(new-addr (make-vector len nil))
(ii 0))
(while (< ii len)
(aset new-addr ii (aref addr ii))
(setq ii (1+ ii)))))
addrl))
(defun bbdb-migrate-streets-to-list (addrl)
"Convert the streets to a list."
(mapcar (lambda (addr)
(vector (aref addr 0) ; tag
(delete nil (delete "" ; nuke empties
(list (aref addr 1) ; street1
(aref addr 2) ; street2
(aref addr 3))));street3
(aref addr 4) ; city
(aref addr 5) ; state
(aref addr 6) ; zip
(aref addr 7))) ; country
addrl))
(defun bbdb-unmigrate-streets-to-list (addrl)
"Convert the street list to the street[1-3] format."
;; Take all the old addresses, ie. the 5th field, and for each
;; address, render the third element (a list of streets) as three
;; vector elements (v4-style address). If there's more than 3
;; lines, everything remaining gets crammed into the third, using
;; commas to separate the bits. If there's less, fill out with nil.
(mapcar (lambda (addr)
(let ((streets (aref addr 1)))
(vector (aref addr 0) ; tag
(or (nth 0 streets) "")
(or (nth 1 streets) "")
(mapconcat 'identity (cddr streets) ", ")
(aref addr 2) ; city
(aref addr 3) ; state
(aref addr 4) ; zip
(aref addr 5)))) ; country
addrl))
;;;###autoload
(defun bbdb-migrate-rewrite-all (message-p &optional records)
"Rewrite each and every record in the bbdb file; this is necessary if we
are updating an old file format. MESSAGE-P says whether to sound off
for each record converted. If RECORDS is non-nil, its value will be
used as the list of records to update."
;; RECORDS is used by the migration mechanism. Since the migration
;; mechanism is called from within bbdb-records, if we called
;; bbdb-change-record, we'd recurse and die. We're therefore left
;; with the slightly more palatable (but still not pretty) calling
;; of bbdb-overwrite-record-internal.
(or records (setq records (bbdb-records)))
(let ((i 0))
(while records
(bbdb-overwrite-record-internal (car records) nil)
(if message-p (message "Updating %d: %s %s" (setq i (1+ i))
(bbdb-record-firstname (car records))
(bbdb-record-lastname (car records))))
(setq records (cdr records)))))
(defalias 'bbdb-dry-heaves 'bbdb-migrate-rewrite-all)
;;;###autoload
(defun bbdb-migrate-update-file-version (old new)
"Change the `file-version' string from the OLD version to the NEW
version."
(goto-char (point-min))
(if (re-search-forward (format "^;;; file-version: %d$" old) nil t)
(replace-match (format ";;; file-version: %d" new))
(error (format "Can't find file-version string in %s buffer for v%d migration"
bbdb-file new))))
(provide 'bbdb-migrate)
|
