git.shemshak.org - ~bandali/configs/blob - 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