diff options
Diffstat (limited to 'lisp/bbdb-migrate.el')
| -rw-r--r-- | lisp/bbdb-migrate.el | 413 |
1 files changed, 0 insertions, 413 deletions
diff --git a/lisp/bbdb-migrate.el b/lisp/bbdb-migrate.el deleted file mode 100644 index 92c2504..0000000 --- a/lisp/bbdb-migrate.el +++ /dev/null @@ -1,413 +0,0 @@ -;;; -*- 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) |