[emacs] update 4 drones
[~bandali/configs] / lisp / bbdb / bbdb-migrate.el
1 ;;; bbdb-migrate.el --- migration functions for BBDB -*- lexical-binding: t -*-
2
3 ;; Copyright (C) 2010-2017 Free Software Foundation, Inc.
4
5 ;; This file is part of the Insidious Big Brother Database (aka BBDB),
6
7 ;; BBDB is free software: you can redistribute it and/or modify
8 ;; it under the terms of the GNU General Public License as published by
9 ;; the Free Software Foundation, either version 3 of the License, or
10 ;; (at your option) any later version.
11
12 ;; BBDB is distributed in the hope that it will be useful,
13 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
14 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 ;; GNU General Public License for more details.
16
17 ;; You should have received a copy of the GNU General Public License
18 ;; along with BBDB. If not, see <http://www.gnu.org/licenses/>.
19
20 ;;; Commentary:
21 ;;; This file contains the migration functions for BBDB.
22 ;;; See the BBDB info manual for documentation.
23
24 ;; Changes in `bbdb-file-format':
25 ;; 3 Date format for `creation-date' and `timestamp' changed
26 ;; from "dd mmm yy" (ex: 25 Sep 97) to "yyyy-mm-dd" (ex: 1997-09-25).
27 ;; 4 Country field added.
28 ;; 5 Streets are lists.
29 ;; 6 Postcodes are plain strings.
30 ;; 7 New field `affix'. Organizations are a list.
31 ;; Xfields is always a list.
32 ;; (8 Skipped format in "official BBDB": Some BBDB users introduced
33 ;; an xfield uuid in their format 8. To bring them back, we jump
34 ;; straight from 7 to 9.)
35 ;; 9 New field uuid. Make `creation-date' and `timestamp' immutable fields.
36
37
38 ;;; Code:
39
40 (require 'bbdb)
41
42 ;;; Migrating the BBDB
43
44 (defvar bbdb-migrate-uuid-xfield 'uuid
45 "Xfield holding a uuid in file format 8.")
46
47 ;;;###autoload
48 (defun bbdb-migrate (records old)
49 "Migrate RECORDS from format OLD to `bbdb-file-format'."
50 ;; Some BBDB files were corrupted by random outer layers of
51 ;; parentheses surrounding the actual correct data. We attempt to
52 ;; compensate for this.
53 (while (and (consp records)
54 (listp (car records))
55 (null (cdr records)))
56 (setq records (car records)))
57
58 ;; `bbdb-migrate-lambda' uses the usual functions to access and set
59 ;; the fields of a record. So if a new record format changes
60 ;; the set of fields, we need to make these changes first.
61
62 ;; Format 7: Add new field `affix'.
63 (if (< old 7)
64 (let (new-records)
65 (dolist (record records)
66 (push (vector (elt record 0) (elt record 1) nil
67 (elt record 2) (elt record 3) (elt record 4)
68 (elt record 5) (elt record 6) (elt record 7)
69 (elt record 8))
70 new-records))
71 (setq records (nreverse new-records))))
72
73 ;; Format 9: New field `uuid'.
74 ;; Make `creation-date' and `timestamp' immutable fields.
75 (if (< old 9)
76 (let (new-records)
77 (dolist (record records)
78 (let ((uuid (or (cdr (assq bbdb-migrate-uuid-xfield (elt record 8)))
79 (bbdb-uuid)))
80 (creation-date (or (cdr (assq 'creation-date (elt record 8)))
81 (format-time-string bbdb-time-stamp-format nil t)))
82 (timestamp (or (cdr (assq 'timestamp (elt record 8)))
83 (format-time-string bbdb-time-stamp-format nil t))))
84 (push (vector (elt record 0) (elt record 1) (elt record 2)
85 (elt record 3) (elt record 4) (elt record 5)
86 (elt record 6) (elt record 7)
87 (let ((xfields (elt record 8)))
88 (dolist (elt '(uuid creation-date timestamp))
89 (setq xfields (assq-delete-all elt xfields)))
90 xfields)
91 uuid creation-date timestamp
92 (elt record 9))
93 new-records)))
94 (setq records (nreverse new-records))))
95
96 (mapc (bbdb-migrate-lambda old) records)
97 records)
98
99 (defconst bbdb-migrate-alist
100 '((3 (bbdb-record-xfields bbdb-record-set-xfields
101 bbdb-migrate-dates))
102 (4 (bbdb-record-address bbdb-record-set-address
103 bbdb-migrate-add-country))
104 (5 (bbdb-record-address bbdb-record-set-address
105 bbdb-migrate-streets-to-list))
106 (6 (bbdb-record-address bbdb-record-set-address
107 bbdb-migrate-postcode-to-string))
108 (7 (bbdb-record-xfields bbdb-record-set-xfields
109 bbdb-migrate-xfields-to-list)
110 (bbdb-record-organization bbdb-record-set-organization
111 bbdb-migrate-organization-to-list)))
112 ;; Formats 8 and 9: do nothing
113 "Alist (VERSION . CHANGES).
114 CHANGES is a list with elements (GET SET FUNCTION) that expands
115 to action (SET record (FUNCTION (GET record))).")
116
117 (defun bbdb-migrate-lambda (old)
118 "Return the function to migrate from OLD to `bbdb-file-format'.
119 The manipulations are defined by `bbdb-migrate-alist'."
120 (let (spec)
121 (while (<= old bbdb-file-format)
122 (setq spec (append spec (cdr (assoc old bbdb-migrate-alist)))
123 old (1+ old)))
124 `(lambda (record)
125 ,@(mapcar (lambda (change)
126 ;; (SET record (FUNCTION (GET record)))
127 `(,(nth 1 change) record ; SET
128 (,(nth 2 change) ; FUNCTION
129 (,(nth 0 change) record)))) ; GET
130 spec)
131 record)))
132
133 (defun bbdb-migrate-postcode-to-string (addresses)
134 "Make all postcodes plain strings.
135 This uses the code that used to be in `bbdb-address-postcode'."
136 ;; apply the function to all addresses in the list and return a
137 ;; modified list of addresses
138 (mapcar (lambda (address)
139 (let ((postcode (bbdb-address-postcode address)))
140 (bbdb-address-set-postcode
141 address
142 (cond ((stringp postcode)
143 postcode)
144 ;; nil or zero
145 ((or (zerop postcode)
146 (null postcode))
147 "")
148 ;; a number
149 ((numberp postcode)
150 (format "%d" postcode))
151 ;; list with two strings
152 ((and (stringp (nth 0 postcode))
153 (stringp (nth 1 postcode)))
154 ;; the second string starts with 4 digits
155 (if (string-match "^[0-9][0-9][0-9][0-9]"
156 (nth 1 postcode))
157 (format "%s-%s" (nth 0 postcode) (nth 1 postcode))
158 ;; ("abc" "efg")
159 (format "%s %s" (nth 0 postcode) (nth 1 postcode))))
160 ;; list with two numbers
161 ((and (integerp (nth 0 postcode))
162 (integerp (nth 1 postcode)))
163 (format "%05d-%04d" (nth 0 postcode) (nth 1 postcode)))
164 ;; list with a string and a number
165 ((and (stringp (nth 0 postcode))
166 (integerp (nth 1 postcode)))
167 (format "%s-%d" (nth 0 postcode) (nth 1 postcode)))
168 ;; ("SE" (123 45))
169 ((and (stringp (nth 0 postcode))
170 (integerp (nth 0 (nth 1 postcode)))
171 (integerp (nth 1 (nth 1 postcode))))
172 (format "%s-%d %d" (nth 0 postcode) (nth 0 (nth 1 postcode))
173 (nth 1 (nth 1 postcode))))
174 ;; last possibility
175 (t (format "%s" postcode)))))
176 address)
177 addresses))
178
179 (defun bbdb-migrate-dates (xfields)
180 "Change date formats.
181 Formats are changed in timestamp and creation-date fields from
182 \"dd mmm yy\" to \"yyyy-mm-dd\"."
183 (unless (stringp xfields)
184 (mapc (lambda (xfield)
185 (when (memq (car xfield) '(creation-date timestamp))
186 (bbdb-migrate-date xfield)))
187 xfields)
188 xfields))
189
190 (defun bbdb-migrate-date (field)
191 "Convert date field FIELD from \"dd mmm yy\" to \"yyyy-mm-dd\"."
192 (let* ((date (cdr field))
193 (parsed (timezone-parse-date (concat date " 00:00:00"))))
194 ;; If `timezone-parse-date' cannot make sense of its arg DATE
195 ;; it returns ["0" "0" "0" "0" nil].
196 (if (equal parsed ["0" "0" "0" "0" nil])
197 (setq parsed (timezone-parse-date date)))
198 (when (equal parsed ["0" "0" "0" "0" nil])
199 (cond ((string-match
200 "^\\([0-9]\\{4\\}\\)[-/]\\([ 0-9]?[0-9]\\)[-/]\\([ 0-9]?[0-9]\\)" date)
201 (setq parsed (vector (match-string 1 date) (match-string 2 date)
202 (match-string 3 date))))
203 ((string-match
204 "^\\([ 0-9]?[0-9]\\)[-/]\\([ 0-9]?[0-9]\\)[-/]\\([0-9]\\{4\\}\\)" date)
205 (setq parsed (vector (match-string 3 date) (match-string 1 date)
206 (match-string 2 date))))))
207
208 ;; We need numbers for the following sanity check
209 (dotimes (i 3)
210 (if (stringp (aref parsed i))
211 (aset parsed i (string-to-number (aref parsed i)))))
212
213 ;; Sanity check
214 (if (and (< 0 (aref parsed 0))
215 (< 0 (aref parsed 1)) (< (aref parsed 1) 13)
216 (< 0 (aref parsed 2))
217 (<= (aref parsed 2)
218 (timezone-last-day-of-month (aref parsed 1) (aref parsed 0))))
219 (setcdr field (format "%04d-%02d-%02d" (aref parsed 0)
220 (aref parsed 1) (aref parsed 2)))
221 (error "BBDB cannot parse %s header value %S for upgrade"
222 field date))))
223
224 (defun bbdb-migrate-add-country (addrl)
225 "Add a country field to each address in the address list."
226 (mapcar (lambda (address) (vconcat address [bbdb-default-country])) addrl))
227
228 (defun bbdb-migrate-streets-to-list (addrl)
229 "Convert the streets to a list."
230 (mapcar (lambda (address)
231 (vector (aref address 0) ; key
232 (delq nil (delete "" ; nuke empties
233 (list (aref address 1) ; street1
234 (aref address 2) ; street2
235 (aref address 3))));street3
236 (aref address 4) ; city
237 (aref address 5) ; state
238 (aref address 6) ; postcode
239 (aref address 7))) ; country
240 addrl))
241
242 (defun bbdb-migrate-xfields-to-list (xfields)
243 "Migrate XFIELDS to list."
244 (if (stringp xfields)
245 `((notes . ,xfields))
246 xfields))
247
248 (defun bbdb-migrate-organization-to-list (organization)
249 "Migrate ORGANIZATION to list."
250 (if (stringp organization)
251 (bbdb-split 'organization organization)
252 organization))
253
254 ;;;###autoload
255 (defun bbdb-undocumented-variables (&optional name-space message)
256 "Return list of undocumented variables in NAME-SPACE.
257 NAME-SPACE defaults to \"bbdb-\". Use a prefix arg to specify NAME-SPACE
258 interactively. If MESSAGE is non-nil (as in interactive calls) display
259 the list in the message area.
260
261 This command may come handy to identify BBDB variables in your init file
262 that are not used anymore by the current version of BBDB. Yet this fails
263 for outdated BBDB variables that are set via your personal `custom-file'."
264 (interactive (list (if current-prefix-arg
265 (read-string "Name space: ")) t))
266 (let ((re (concat "\\`" (or name-space "bbdb-"))) list)
267 (mapatoms (lambda (vv)
268 (if (and (boundp vv)
269 (string-match re (symbol-name vv))
270 (not (get vv 'variable-documentation))
271 (not (get vv 'byte-obsolete-variable)))
272 (push vv list))))
273 (if message
274 (if list
275 (apply 'message (concat "Undocumented variables: "
276 (mapconcat (lambda (_m) "%s") list " ")) list)
277 (message "No undocumented variables `%s...'" name-space)))
278 list))
279
280 (provide 'bbdb-migrate)
281
282 ;;; bbdb-migrate.el ends here