cgit.sxemacs.org Git - packages/blob - xemacs-packages/bbdb/lisp/bbdb-migrate.el

   1 ;;; -*- Mode:Emacs-Lisp -*-
   2
   3 ;;; This file contains the migration functions for the Insidious Big
   4 ;;; Brother Database (aka BBDB), copyright (c) 1991, 1992, 1993, 1994
   5 ;;; Jamie Zawinski <jwz@netscape.com>.  See the file bbdb.texinfo for
   6 ;;; documentation.
   7 ;;;
   8 ;;; The Insidious Big Brother Database is free software; you can redistribute
   9 ;;; it and/or modify it under the terms of the GNU General Public License as
  10 ;;; published by the Free Software Foundation; either version 2, or (at your
  11 ;;; option) any later version.
  12 ;;;
  13 ;;; BBDB is distributed in the hope that it will be useful, but WITHOUT ANY
  14 ;;; WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
  15 ;;; FOR A PARTICULAR PURPOSE.  See the GNU General Public License for more
  16 ;;; details.
  17 ;;;
  18 ;;; You should have received a copy of the GNU General Public License
  19 ;;; along with GNU Emacs; see the file COPYING.  If not, write to
  20 ;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  21 ;;;
  22
  23 ;;
  24 ;; $Id: bbdb-migrate.el,v 1.9 2007-02-23 20:24:08 fenk Exp $
  25 ;;
  26
  27 (require 'bbdb)
  28
  29 ;;; Migrating the BBDB
  30
  31 ;; Features that have changed in the various database revs.  Format:
  32 ;;    ((VERSION . DIFFERENCES) ... )
  33 (defconst bbdb-migration-features
  34   '((3 . "* Date format for `creation-date' and `timestamp' has changed,
  35   from \"dd mmm yy\" (ex: 25 Sep 97) to \"yyyy-mm-dd\" (ex: 1997-09-25).")
  36     (4 . "* Country field added.")
  37     (5 . "* More flexible street address.")
  38     (6 . "* Zip codes are stored as plain strings.")))
  39
  40 ;;;###autoload
  41 (defun bbdb-migration-query (ondisk)
  42   "Ask if the database is to be migrated.
  43 ONDISK is the version number of the database as currently stored on
  44 disk.  Returns the version for the saved database."
  45   (save-excursion
  46     (let ((wc (current-window-configuration))
  47       (buf (get-buffer-create "*BBDB Migration Info*"))
  48       (newfeatures bbdb-migration-features)
  49       (first t)
  50       win update)
  51       (set-buffer buf)
  52       (erase-buffer)
  53       (goto-char (point-min))
  54       (insert-string (format "BBDB new data version notice:
  55 =============================
  56
  57 Your BBDB data is stored in an older format (version %d).  At this point,
  58 you have the option of either upgrading or continuing to save your data
  59 in your current format.  Please note that if you elect the latter option,
  60 any changes made to your data using features intended for the newer
  61 versions will be lost.  For your convenience, a list of file format
  62 changes introduced after version %d is shown below:\n\n" ondisk ondisk))
  63       (while newfeatures
  64     (if (> (caar newfeatures) ondisk)
  65       (insert-string (concat (if first (setq first nil) "\n\n")
  66                  "New features in database version "
  67                  (format "%d" (caar newfeatures))
  68                  ":\n\n" (cdar newfeatures))))
  69     (setq newfeatures (cdr newfeatures)))
  70       (setq win (display-buffer buf))
  71       (shrink-window-if-larger-than-buffer win)
  72       (setq update
  73         (y-or-n-p (concat "Upgrade BBDB to version "
  74                   (format "%d" bbdb-file-format)
  75                   "? ")))
  76       (condition-case nil
  77           (delete-window win)
  78         ;; The window might be the only one on its frame.  Hopefully, it's
  79         ;; a dedicated window and the kill-buffer below will DTRT.
  80         (error nil))
  81       (kill-buffer buf)
  82       (set-window-configuration wc)
  83       (if update bbdb-file-format ondisk))))
  84
  85 ;;;###autoload
  86 (defun bbdb-migrate (records)
  87   "Migrate the BBDB from the version on disk (the car of
  88 `bbdb-file-format-migration') to the current version (in
  89 `bbdb-file-format')."
  90   (bbdb-mapc (bbdb-migrate-versions-lambda (car bbdb-file-format-migration))
  91          records)
  92   records)
  93
  94 ;;;###autoload
  95 (defun bbdb-unmigrate-record (record)
  96   "Reverse-migrate a single record from the current version (in
  97 `bbdb-file-format') to the version to be saved (the cdr of
  98 `bbdb-file-format-migration')."
  99   (funcall (bbdb-migrate-versions-lambda bbdb-file-format
 100                                          (car bbdb-file-format-migration))
 101            record)
 102   record)
 103
 104 (defconst bbdb-migration-spec
 105   '((2 (bbdb-record-raw-notes bbdb-record-set-raw-notes
 106         bbdb-migrate-change-dates))
 107     (3 (bbdb-record-addresses bbdb-record-set-addresses
 108         bbdb-migrate-add-country-field))
 109     (4 (bbdb-record-addresses bbdb-record-set-addresses
 110         bbdb-migrate-streets-to-list))
 111     (5 (bbdb-record-addresses bbdb-record-set-addresses
 112         bbdb-migrate-zip-codes-to-strings)))
 113   "The alist of (version . migration-spec-list).
 114 See `bbdb-migrate-record-lambda' for details.")
 115
 116 (defconst bbdb-unmigration-spec
 117   '((2 (bbdb-record-raw-notes bbdb-record-set-raw-notes
 118         bbdb-unmigrate-change-dates))
 119     (3 (bbdb-record-addresses bbdb-record-set-addresses
 120         bbdb-unmigrate-add-country-field))
 121     (4 (bbdb-record-addresses bbdb-record-set-addresses
 122         bbdb-unmigrate-streets-to-list))
 123     (5 (bbdb-record-addresses bbdb-record-set-addresses
 124         bbdb-unmigrate-zip-codes-to-strings)))
 125   "The alist of (version . migration-spec-list).
 126 See `bbdb-migrate-record-lambda' for details.")
 127
 128 (defun bbdb-migrate-record-lambda (changes)
 129   "Return a function which will migrate a single record.
 130 CHANGES is a `migration-spec-list' containing entries of the form
 131
 132         (GET SET FUNCTION)
 133
 134 where GET is the function to be used to retrieve the field to be
 135 modified, and SET is the function to be used to set the field to be
 136 modified.  FUNCTION will be applied to the result of GET, and its
 137 results will be saved with SET."
 138   (byte-compile `(lambda (rec)
 139                   ,@(mapcar (lambda (ch)
 140                               `(,(cadr ch) rec
 141                                 (,(car (cddr ch))
 142                                  (,(car ch) rec))))
 143                             changes)
 144                   rec)))
 145
 146 (defun bbdb-migrate-versions-lambda (v0 &optional v1)
 147   "Return the function to migrate from V0 to V1.
 148 V1 defaults to `bbdb-file-format'."
 149   (setq v1 (or v1 bbdb-file-format))
 150   (let ((vv v0) spec)
 151     (while (/= vv v1)
 152       (setq spec (append spec (cdr (assoc vv bbdb-migration-spec)))
 153             vv (if (< v0 v1) (1+ vv) (1- vv))))
 154     (bbdb-migrate-record-lambda spec)))
 155
 156 (defun bbdb-migrate-zip-codes-to-strings (addrs)
 157   "Make all zip codes plain strings.
 158 This uses the code that used to be in bbdb-address-zip-string."
 159   ;; apply the function to all addresses in the list and return a
 160   ;; modified list of addresses
 161   (mapcar (lambda (addr)
 162             (let ((zip (if (stringp (bbdb-address-zip addr))
 163                            (bbdb-address-zip addr)
 164                          ;; if not a string, make it a string...
 165                          (if (consp (bbdb-address-zip addr))
 166                              ;; if a cons cell with two strings
 167                              (if (and (stringp (car (bbdb-address-zip addr)))
 168                                       (stringp (car (cdr (bbdb-address-zip addr)))))
 169                                  ;; if the second string starts with 4 digits
 170                                  (if (string-match "^[0-9][0-9][0-9][0-9]"
 171                                                    (car (cdr (bbdb-address-zip addr))))
 172                                      (concat (car (bbdb-address-zip addr))
 173                                              "-"
 174                                              (car (cdr (bbdb-address-zip addr))))
 175                                    ;; if ("abc" "efg")
 176                                    (concat (car (bbdb-address-zip addr))
 177                                            " "
 178                                            (car (cdr (bbdb-address-zip addr)))))
 179                                ;; if ("SE" (123 45))
 180                                (if (and (stringp (nth 0 (bbdb-address-zip addr)))
 181                                         (consp (nth 1 (bbdb-address-zip addr)))
 182                                         (integerp (nth 0 (nth 1 (bbdb-address-zip addr))))
 183                                         (integerp (nth 1 (nth 1 (bbdb-address-zip addr)))))
 184                                    (format "%s-%d %d"
 185                                            (nth 0 (bbdb-address-zip addr))
 186                                            (nth 0 (nth 1 (bbdb-address-zip addr)))
 187                                            (nth 1 (nth 1 (bbdb-address-zip addr))))
 188                                  ;; if a cons cell with two numbers
 189                                  (if (and (integerp (car (bbdb-address-zip addr)))
 190                                           (integerp (car (cdr (bbdb-address-zip addr)))))
 191                                      (format "%05d-%04d" (car (bbdb-address-zip addr))
 192                                              (car (cdr (bbdb-address-zip addr))))
 193                                    ;; else a cons cell with a string an a number (possible error
 194                                    ;; if a cons cell with a number and a string -- note the
 195                                    ;; order!)
 196                                    (format "%s-%d" (car (bbdb-address-zip addr))
 197                                            (car (cdr (bbdb-address-zip addr)))))))
 198                            ;; if nil or zero
 199                            (if (or (eq 0 (bbdb-address-zip addr))
 200                                    (null (bbdb-address-zip addr)))
 201                                ""
 202                              ;; else a number, could be 3 to 5 digits (possible error: assuming
 203                              ;; no leading zeroes in zip codes)
 204                              (format "%d" (bbdb-address-zip addr)))))))
 205               (bbdb-address-set-zip addr zip))
 206             addr)
 207           addrs))
 208
 209 (defun bbdb-unmigrate-zip-codes-to-strings (addrs)
 210   "Make zip code string into zip code datastructures.
 211 This uses the code that used to be in bbdb-parse-zip-string."
 212   ;; apply the function to all addresses in the list and return a
 213   ;; modified list of addresses
 214   (mapcar (lambda (addr)
 215             (let* ((string (bbdb-address-zip addr))
 216                   (zip (cond ((string-match "^[ \t\n]*$" string) 0)
 217                              ;; Matches 1 to 6 digits.
 218                              ((string-match "^[ \t\n]*[0-9][0-9]?[0-9]?[0-9]?[0-9]?[0-9]?[ \t\n]*$" string)
 219                               (string-to-number string))
 220                              ;; Matches 5 digits and 3 or 4 digits.
 221                              ((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)
 222                               (list (bbdb-subint string 1) (bbdb-subint string 2)))
 223                              ;; Match zip codes for Canada, UK, etc. (result is ("LL47" "U4B")).
 224                              ((string-match
 225                                "^[ \t\n]*\\([A-Za-z0-9]+\\)[ \t\n]+\\([A-Za-z0-9]+\\)[ \t\n]*$"
 226                                string)
 227                               (list (substring string (match-beginning 1) (match-end 1))
 228                                     (substring string (match-beginning 2) (match-end 2))))
 229                              ;; Match zip codes for continental Europe.  Examples "CH-8057"
 230                              ;; or "F - 83320" (result is ("CH" "8057") or ("F" "83320")).
 231                              ;; Support for "NL-2300RA" added at request from Carsten Dominik
 232                              ;; <dominik@astro.uva.nl>
 233                              ((string-match
 234                                "^[ \t\n]*\\([A-Z]+\\)[ \t\n]*-?[ \t\n]*\\([0-9]+ ?[A-Z]*\\)[ \t\n]*$" string)
 235                               (list (substring string (match-beginning 1) (match-end 1))
 236                                     (substring string (match-beginning 2) (match-end 2))))
 237                              ;; Match zip codes from Sweden where the five digits are grouped 3+2
 238                              ;; at the request from Mats Lofdahl <MLofdahl@solar.stanford.edu>.
 239                              ;; (result is ("SE" (133 36)))
 240                              ((string-match
 241                                "^[ \t\n]*\\([A-Z]+\\)[ \t\n]*-?[ \t\n]*\\([0-9]+\\)[ \t\n]+\\([0-9]+\\)[ \t\n]*$" string)
 242                               (list (substring string (match-beginning 1) (match-end 1))
 243                                     (list (bbdb-subint string 2)
 244                                           (bbdb-subint string 3)))))))
 245               (bbdb-address-set-zip addr zip)
 246               addr))
 247           addrs))
 248
 249 (defun bbdb-migrate-change-dates (rec)
 250   "Change date formats.
 251 Formats are changed in timestamp and creation-date fields from
 252 \"dd mmm yy\" to \"yyyy-mm-dd\".  Assumes the notes are passed in as an
 253 argument."
 254   (unless (stringp rec)
 255     (bbdb-mapc (lambda (rr)
 256                  (when (memq (car rr) '(creation-date timestamp))
 257                    (bbdb-migrate-change-dates-change-field rr)))
 258                rec)
 259     rec))
 260
 261 (defun bbdb-migrate-change-dates-change-field (field)
 262   "Migrate the date field (the cdr of FIELD) from \"dd mmm yy\" to
 263 \"yyyy-mm-dd\"."
 264   (let ((date (cdr field))
 265     parsed)
 266     ;; Verify and extract - this is fairly hideous
 267     (and (equal (setq parsed (timezone-parse-date (concat date " 00:00:00")))
 268         ["0" "0" "0" "0" nil])
 269      (equal (setq parsed (timezone-parse-date date))
 270         ["0" "0" "0" "0" nil])
 271      (cond ((string-match
 272          "^\\([0-9]\\{4\\}\\)[-/]\\([ 0-9]?[0-9]\\)[-/]\\([ 0-9]?[0-9]\\)" date)
 273         (setq parsed (vector (string-to-number (match-string 1 date))
 274                      (string-to-number (match-string 2 date))
 275                      (string-to-number (match-string 3 date))))
 276         ;; This should be fairly loud for GNU Emacs users
 277         (bbdb-warn "BBDB is treating %s field value %s as %s %d %d"
 278                (car field) (cdr field)
 279                (upcase-initials
 280                 (downcase (car (rassoc (aref parsed 1)
 281                            timezone-months-assoc))))
 282                (aref parsed 2) (aref parsed 0)))
 283            ((string-match
 284          "^\\([ 0-9]?[0-9]\\)[-/]\\([ 0-9]?[0-9]\\)[-/]\\([0-9]\\{4\\}\\)" date)
 285         (setq parsed (vector (string-to-number (match-string 3 date))
 286                      (string-to-number (match-string 1 date))
 287                      (string-to-number (match-string 2 date))))
 288         ;; This should be fairly loud for GNU Emacs users
 289         (bbdb-warn "BBDB is treating %s field value %s as %s %d %d"
 290                (car field) (cdr field)
 291                (upcase-initials
 292                 (downcase (car (rassoc (aref parsed 1)
 293                            timezone-months-assoc))))
 294                (aref parsed 2) (aref parsed 0)))
 295            (t ["0" "0" "0" "0" nil])))
 296
 297     ;; I like numbers
 298     (and (stringp (aref parsed 0))
 299      (aset parsed 0 (string-to-number (aref parsed 0))))
 300     (and (stringp (aref parsed 1))
 301      (aset parsed 1 (string-to-number (aref parsed 1))))
 302     (and (stringp (aref parsed 2))
 303      (aset parsed 2 (string-to-number (aref parsed 2))))
 304
 305     ;; Sanity check
 306     (cond ((and (< 0 (aref parsed 0))
 307         (< 0 (aref parsed 1)) (>= 12 (aref parsed 1))
 308         (< 0 (aref parsed 2))
 309         (>= (timezone-last-day-of-month (aref parsed 1)
 310                         (aref parsed 0))
 311             (aref parsed 2)))
 312        (setcdr field (format "%04d-%02d-%02d" (aref parsed 0)
 313                  (aref parsed 1) (aref parsed 2)))
 314        field)
 315       (t
 316        (error "BBDB cannot parse %s header value %S for upgrade"
 317           field date)))))
 318
 319 (defun bbdb-unmigrate-change-dates (rec)
 320   "Change date formats.
 321 Formats are changed in timestamp and creation-date fields from
 322 \"yyyy-mm-dd\" to \"dd mmm yy\".  Assumes the notes list is passed in
 323 as an argument."
 324   (unless (stringp rec)
 325     (bbdb-mapc (lambda (rr)
 326                  (when (memq (car rr) '(creation-date timestamp))
 327                    (bbdb-unmigrate-change-dates-change-field rr)))
 328                rec)
 329     rec))
 330
 331 (defun bbdb-unmigrate-change-dates-change-field (field)
 332   "Unmigrate the date field (the cdr of FIELD) from \"yyyy-mm-dd\" to
 333 \"yyyy-mm-dd\"."
 334   (cons (car field) (bbdb-time-convert (cdr field) "%e %b %y")))
 335
 336 (defun bbdb-migrate-add-country-field (addrl)
 337   "Add a country field to each address in the address list."
 338   (mapcar (lambda (addr) (vconcat addr [""])) addrl))
 339
 340 (defun bbdb-unmigrate-add-country-field (addrl)
 341   "Remove the country field from each address in the address list."
 342   ;; Some version 4 zip codes will be illegal version 3 (as used in
 343   ;; 2.00.06) zip codes.  This problem has not been solved.
 344   (mapcar (lambda (addr)
 345             (let* ((len (1- (length addr)))
 346                    (new-addr (make-vector len nil))
 347                    (ii 0))
 348               (while (< ii len)
 349                 (aset new-addr ii (aref addr ii))
 350                 (setq ii (1+ ii)))))
 351           addrl))
 352
 353 (defun bbdb-migrate-streets-to-list (addrl)
 354   "Convert the streets to a list."
 355   (mapcar (lambda (addr)
 356             (vector (aref addr 0) ; tag
 357                     (delete nil (delete "" ; nuke empties
 358                                         (list (aref addr 1) ; street1
 359                                               (aref addr 2) ; street2
 360                                               (aref addr 3))));street3
 361                     (aref addr 4) ; city
 362                     (aref addr 5) ; state
 363                     (aref addr 6) ; zip
 364                     (aref addr 7))) ; country
 365           addrl))
 366
 367 (defun bbdb-unmigrate-streets-to-list (addrl)
 368   "Convert the street list to the street[1-3] format."
 369   ;; Take all the old addresses, ie. the 5th field, and for each
 370   ;; address, render the third element (a list of streets) as three
 371   ;; vector elements (v4-style address). If there's more than 3
 372   ;; lines, everything remaining gets crammed into the third, using
 373   ;; commas to separate the bits. If there's less, fill out with nil.
 374   (mapcar (lambda (addr)
 375             (let ((streets (aref addr 1)))
 376               (vector (aref addr 0) ; tag
 377                       (or (nth 0 streets) "")
 378                       (or (nth 1 streets) "")
 379                       (mapconcat 'identity (cddr streets) ", ")
 380                       (aref addr 2) ; city
 381                       (aref addr 3) ; state
 382                       (aref addr 4) ; zip
 383                       (aref addr 5)))) ; country
 384           addrl))
 385
 386 ;;;###autoload
 387 (defun bbdb-migrate-rewrite-all (message-p &optional records)
 388   "Rewrite each and every record in the bbdb file; this is necessary if we
 389 are updating an old file format.  MESSAGE-P says whether to sound off
 390 for each record converted.  If RECORDS is non-nil, its value will be
 391 used as the list of records to update."
 392   ;; RECORDS is used by the migration mechanism.  Since the migration
 393   ;; mechanism is called from within bbdb-records, if we called
 394   ;; bbdb-change-record, we'd recurse and die.  We're therefore left
 395   ;; with the slightly more palatable (but still not pretty) calling
 396   ;; of bbdb-overwrite-record-internal.
 397   (or records (setq records (bbdb-records)))
 398   (let ((i 0))
 399     (while records
 400       (bbdb-overwrite-record-internal (car records) nil)
 401       (if message-p (message "Updating %d: %s %s" (setq i (1+ i))
 402                  (bbdb-record-firstname (car records))
 403                  (bbdb-record-lastname  (car records))))
 404       (setq records (cdr records)))))
 405 (defalias 'bbdb-dry-heaves 'bbdb-migrate-rewrite-all)
 406
 407 ;;;###autoload
 408 (defun bbdb-migrate-update-file-version (old new)
 409   "Change the `file-version' string from the OLD version to the NEW
 410 version."
 411   (goto-char (point-min))
 412   (if (re-search-forward (format "^;;; file-version: %d$" old) nil t)
 413       (replace-match (format ";;; file-version: %d" new))
 414     (error (format "Can't find file-version string in %s buffer for v%d migration"
 415            bbdb-file new))))
 416
 417 (provide 'bbdb-migrate)