ebdb-migrate.el

;;; ebdb-migrate.el --- Migration/upgrade functions for EBDB  -*- lexical-binding: t; -*-

;; Copyright (C) 2016-2024  Free Software Foundation, Inc.

;; Author: Eric Abrahamsen <eric@ericabrahamsen.net>

;; This program 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 3 of the License, or
;; (at your option) any later version.

;; This program 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 this program.  If not, see <http://www.gnu.org/licenses/>.

;;; Commentary:

;; This file provides functions for upgrading from earlier versions of
;; EBDB, or from BBDB.

;;; Code:

(require 'ebdb)
(require 'cl-lib)
(require 'subr-x)
(autoload 'calendar-absolute-from-gregorian "calendar")
(autoload 'calendar-gregorian-from-absolute "calendar")
(autoload 'org-time-string-to-absolute "org")
(declare-function make-gnorb-ebdb-link "ext:gnorb-ebdb")
(declare-function org-contacts-db "ext:org-contacts")
(defvar url-handler-regexp)
(defvar bbdb-time-stamp-format)
;;; Migrating the EBDB

;; For org-contacts

(defvar org-contacts-email-property)
(defvar org-contacts-alias-property)
(defvar org-contacts-tel-property)
(defvar org-contacts-address-property)
(defvar org-contacts-birthday-property)
(defvar org-contacts-note-property)
(defvar org-contacts-icon-property)
(defvar org-contacts-nickname-property)

;; Unused
(defconst ebdb-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 . "* postcodes are stored as plain strings.")
    (7 . "* Xfields is always a list.  Organizations are stored as list.
  New field `affix'."))
  "EBDB Features that have changed in various database revisions.
Format ((VERSION . DIFFERENCES) ... ).")

;; Quiet compiler
(defvar bbdb-file)

;; Define structs so that the getters/setters used elsewhere in the
;; file operate normally.  These functions are used nowhere else in
;; EBDB, and the "v" prefix has been added to prevent function name
;; clashes.
(cl-defstruct (ebdb-vrecord
               (:type vector)
               (:constructor nil))
 firstname lastname affix aka organization phone address mail xfields
 uuid creation-date timestamp cache)

(cl-defstruct (ebdb-vphone
               (:type vector)
               (:constructor nil))
  label area exchange suffix extension)

(cl-defstruct (ebdb-vaddress
               (:type vector)
               (:constructor nil))
  label streets city state postcode country)

(defun ebdb-peel-the-onion (lis)
  "Remove outer layers of parens around singleton lists.
This is done until we get a list which is either not a singleton list
or does not contain a list.  This is a utility function used in recovering
slightly munged old EBDB files."
  (while (and (consp lis)
	      (null (cdr lis))
	      (listp (car lis)))
    (setq lis (car lis)))
  lis)

(defconst ebdb-file-format 9
  "Obsolete variable, only used in migration.")

;;;###autoload
(defun ebdb-migrate (records old-format)
  "Migrate the EBDB from the version on disk to the current version
\(in `ebdb-file-format')."
  ;; Some EBDB files were corrupted by random outer layers of
  ;; parentheses surrounding the actual correct data.  We attempt to
  ;; compensate for this.
  (setq records (ebdb-peel-the-onion records))

  ;; Add new field `affix'.
  (if (< old-format 7)
      (let ((temp records) record)
        (while (setq record (car temp))
          (setcar temp (vector (elt record 0) (elt record 1) nil
                               (elt record 2) (elt record 3) (elt record 4)
                               (elt record 5) (elt record 6) (elt record 7)
                               (elt record 8)))
          (setq temp (cdr temp)))))
  (if (< old-format 9)
      (let (new-records)
        (dolist (record records)
          (let ((uuid (or (cdr (assq 'uuid (elt record 8)))
                          (ebdb-make-uuid)))
                (creation-date (or (cdr (assq 'creation-date (elt record 8)))
                                   (format-time-string bbdb-time-stamp-format nil t)))
                (timestamp (or (cdr (assq 'timestamp (elt record 8)))
                               (format-time-string bbdb-time-stamp-format nil t))))
            (push (vector (elt record 0) (elt record 1) (elt record 2)
                          (elt record 3) (elt record 4) (elt record 5)
                          (elt record 6) (elt record 7)
                          (let ((xfields (elt record 8)))
                            (dolist (elt '(uuid creation-date timestamp))
                              (setq xfields (assq-delete-all elt xfields)))
                            xfields)
                          uuid creation-date timestamp
                          (elt record 9))
                  new-records)))
        (setq records (nreverse new-records))))
  (mapc (ebdb-migrate-versions-lambda old-format) records)
  records)

(defconst ebdb-migration-spec
  '((2 (ebdb-vrecord-xfields ebdb-migrate-change-dates))
    (3 (ebdb-vrecord-address ebdb-migrate-add-country-field))
    (4 (ebdb-vrecord-address ebdb-migrate-streets-to-list))
    (5 (ebdb-vrecord-address ebdb-migrate-postcodes-to-strings))
    (6 (ebdb-vrecord-xfields ebdb-migrate-xfields-to-list)
       (ebdb-vrecord-organization ebdb-migrate-organization-to-list))
    (7 (bbdb-record-xfields bbdb-migrate-xfields-to-list)
       (bbdb-record-organization bbdb-migrate-organization-to-list)))
  "The alist of (version . migration-spec-list).
See `ebdb-migrate-record-lambda' for details.")

(defun ebdb-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 (record)
                   ,@(mapcar (lambda (ch)
                               `(cl-callf ,(cadr ch)
                                    (,(car ch) record)))
                             changes)
                   record)))

(defun ebdb-migrate-versions-lambda (v0)
  "Return the function to migrate from V0 to `ebdb-file-format'."
  (let (spec)
    (while (< v0 ebdb-file-format)
      (setq spec (append spec (cdr (assoc v0 ebdb-migration-spec)))
            v0 (1+ v0)))
    (ebdb-migrate-record-lambda spec)))

(defun ebdb-migrate-postcodes-to-strings (addresses)
  "Make all postcodes plain strings.
This uses the code that used to be in `ebdb-address-postcode'."
  ;; apply the function to all addresses in the list and return a
  ;; modified list of addresses
  (mapcar (lambda (address)
            (let ((postcode (if (stringp (ebdb-vaddress-postcode address))
                                (ebdb-vaddress-postcode address)
                              ;; if not a string, make it a string...
                              (if (consp (ebdb-vaddress-postcode address))
                                  ;; if a cons cell with two strings
                                  (if (and (stringp (car (ebdb-vaddress-postcode address)))
                                           (stringp (car (cdr (ebdb-vaddress-postcode address)))))
                                      ;; if the second string starts with 4 digits
                                      (if (string-match "^[0-9][0-9][0-9][0-9]"
                                                        (car (cdr (ebdb-vaddress-postcode address))))
                                          (concat (car (ebdb-vaddress-postcode address))
                                                  "-"
                                                  (car (cdr (ebdb-vaddress-postcode address))))
                                        ;; if ("abc" "efg")
                                        (concat (car (ebdb-vaddress-postcode address))
                                                " "
                                                (car (cdr (ebdb-vaddress-postcode address)))))
                                    ;; if ("SE" (123 45))
                                    (if (and (stringp (nth 0 (ebdb-vaddress-postcode address)))
                                             (consp (nth 1 (ebdb-vaddress-postcode address)))
                                             (integerp (nth 0 (nth 1 (ebdb-vaddress-postcode address))))
                                             (integerp (nth 1 (nth 1 (ebdb-vaddress-postcode address)))))
                                        (format "%s-%d %d"
                                                (nth 0 (ebdb-vaddress-postcode address))
                                                (nth 0 (nth 1 (ebdb-vaddress-postcode address)))
                                                (nth 1 (nth 1 (ebdb-vaddress-postcode address))))
                                      ;; if a cons cell with two numbers
                                      (if (and (integerp (car (ebdb-vaddress-postcode address)))
                                               (integerp (car (cdr (ebdb-vaddress-postcode address)))))
                                          (format "%05d-%04d" (car (ebdb-vaddress-postcode address))
                                                  (car (cdr (ebdb-vaddress-postcode address))))
                                        ;; 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 (ebdb-vaddress-postcode address))
                                                (car (cdr (ebdb-vaddress-postcode address)))))))
                                ;; if nil or zero
                                (if (or (zerop (ebdb-vaddress-postcode address))
                                        (null (ebdb-vaddress-postcode address)))
                                    ""
                                  ;; else a number, could be 3 to 5 digits (possible error: assuming
                                  ;; no leading zeroes in postcodes)
                                  (format "%d" (ebdb-vaddress-postcode address)))))))
              (setf (ebdb-vaddress-postcode address) postcode))
            address)
          addresses))

(defun ebdb-migrate-change-dates (record)
  "Change date formats.
Formats are changed in timestamp and creation-date fields from
\"dd mmm yy\" to \"yyyy-mm-dd\"."
  (unless (stringp record)
    (mapc (lambda (rr)
                 (when (memq (car rr) '(creation-date timestamp))
                   (ebdb-migrate-change-dates-change-field rr)))
               record)
    record))

(defun ebdb-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
        (message "EBDB 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
        (message "EBDB 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 "EBDB cannot parse %s header value %S for upgrade"
          field date)))))

(defun ebdb-migrate-add-country-field (addrl)
  "Add a country field to each address in the address list."
  (mapcar (lambda (address) (vconcat address [""])) addrl))

(defun ebdb-migrate-streets-to-list (addrl)
  "Convert the streets to a list."
  (mapcar (lambda (address)
            (vector (aref address 0) ; tag
                    (delq nil (delete "" ; nuke empties
                                      (list (aref address 1) ; street1
                                            (aref address 2) ; street2
                                            (aref address 3))));street3
                    (aref address 4) ; city
                    (aref address 5) ; state
                    (aref address 6) ; postcode
                    (aref address 7))) ; country
          addrl))

(defun ebdb-migrate-xfields-to-list (xfields)
  "Migrate XFIELDS to list."
  (if (stringp xfields)
      (list (cons 'notes xfields))
    xfields))

(defun ebdb-migrate-organization-to-list (organization)
  "Migrate ORGANIZATION to list."
  (if (stringp organization)
      (ebdb-split 'organization organization)
    organization))

;; These defcustoms are now obsolete, but they're here so that,
;; during the migration/upgrade process, we know which xfields to
;; handle specially, and turn into specific field types.  In the case
;; of `bbdb/gnus-split-public-field', this should signal to us that
;; the record should actually be changed into a
;; `ebdb-record-mailing-list'.  But that hasn't been implemented yet,
;; so...

(defcustom bbdb/gnus-split-private-field 'gnus-private
  "This variable is used to determine the xfield to reference to find the
associated group when saving private mail for a mail address known to
the EBDB.  The value of the xfield should be the name of a mail group."
  :group 'ebdb-mua-gnus-splitting
  :type  'symbol)

(defcustom bbdb/gnus-split-public-field 'gnus-public
  "This variable is used to determine the xfield to reference to find the
associated group when saving non-private mail (received from a mailing
list) for a mail address known to the EBDB.  The value of the xfield
should be the name of a mail group, followed by a space, and a regular
expression to match on the envelope sender to verify that this mail came
from the list in question."
  :group 'ebdb-mua-gnus-splitting
  :type  'symbol)

(defcustom bbdb/vm-auto-folder-field 'vm-folder
  "The name of the VM-specific xfield for mail splitting."
  :group 'ebdb-mua-vm
  :type 'symbol)

(defcustom bbdb/gnus-score-field 'gnus-score
  "This variable contains the name of the EBDB field which should be
checked for a score to add to the mail addresses in the same record."
  :group 'ebdb-mua-gnus-scoring
  :type 'symbol)

(defcustom gnorb-ebdb-org-tag-field 'org-tags
  "The name (as a symbol) of the field to use for org tags."
  :group 'gnorb-ebdb
  :type 'symbol)

;;;###autoload
(defun ebdb-migrate-from-bbdb (&optional file)
  "Migrate from BBDB to EBDB.
This upgrade is extreme enough that we can't really use the
existing migration mechanisms.  They are still there, though, in
case someone's going from, say, version 2 to 4 in one jump.

Migrate from FILE, if non-nil.  Otherwise, assume that the
variable `bbdb-file' points to an existing file holding valid
contacts in a previous BBDB format.  If that variable isn't set
use (locate-user-emacs-file \"bbdb\" \".bbdb\"), which is how
BBDB sets the default of that option."
  (interactive)
  (require 'url-handlers)
  (require 'ebdb-org)
  (require 'ebdb-gnus)
  (with-current-buffer (find-file-noselect
			(or file
			    (and (bound-and-true-p bbdb-file)
				 bbdb-file)
			    (locate-user-emacs-file "bbdb" ".bbdb")))
    (when (and (/= (point-min) (point-max))
	       (yes-or-no-p "Migrate records from BBDB? "))
      (let ((v-records (ebdb-migrate-parse-records))
	    (target-db (ebdb-prompt-for-db nil t))
	    (total 0)
	    c-records duds)
	(message "Migrating records from BBDB...")
	(dolist (r v-records)
	  (condition-case-unless-debug err
	      (let ((orgs (ebdb-vrecord-organization r))
		    (c-rec (ebdb-migrate-vector-to-class r))
		    org)
		;; Gives it a uuid if it doesn't already have one.
		(ebdb-db-add-record target-db c-rec)
		(when orgs
		  (dolist (o orgs)
		    ;; Make all the orgs into real records.
		    (unless (string-blank-p o) ; There are many of these.
		      (setq org (or (seq-find
				     (lambda (r)
				       (and (ebdb-record-organization-p r)
					    (string= o (ebdb-record-name-string r))))
				     c-records)
				    (let ((time (current-time)))
				      (ebdb-db-add-record
				       target-db
				       (make-instance
					'ebdb-record-organization
					:name (make-instance 'ebdb-field-name-simple :name o)
					:timestamp
					(make-instance 'ebdb-field-timestamp :timestamp time)
					:creation-date
					(make-instance 'ebdb-field-creation-date :timestamp time))))))
		      ;; Create the connection between the org and the
		      ;; person.
		      (ebdb-record-add-org-role c-rec org)
		      (unless (member org c-records)
			(push org c-records)))))
		(push c-rec c-records)
		(message "Migrating records from BBDB... %d" (cl-incf total)))
	    (error
	     (push (list r err) duds))))
	(when duds
	  (pop-to-buffer
	   (get-buffer-create "*EBDB Migration Errors*")
	   '(nil . ((window-height . 10))))
	  (insert "The records below could not be migrated:\n\n")
	  (insert
	   (mapconcat
	    (lambda (r)
	      (format "%S\nerror: %S" (car r) (cadr r)))
	    duds "\n\n"))
	  (fit-window-to-buffer)
	  (goto-char (point-min)))
	(dolist (r c-records)
	  (ebdb-init-record r))
	(setf (slot-value target-db 'dirty) t)
	(message "Migrating records from BBDB... %d records migrated"
		 (length c-records))))))

(defun ebdb-migrate-vector-to-class (v)
  "Migrate a single vector-style BBDB record V to EBDB style EIEIO object."
  ;; In the vector version, vector elements were:

  ;; record: firstname lastname affix aka organization phone address mail xfields
  ;; phone: label area exchange suffix extension
  ;; address: label streets city state postcode country
  (let ((f-name (aref v 0))
	(l-name (aref v 1))
	(affix (aref v 2))
	(aka (aref v 3))
	(phone (aref v 5))
	(address (aref v 6))
	(mail (aref v 7))
	(xfields (aref v 8))
	(uuid (aref v 9))
	(c-date (aref v 10))
	(ts (aref v 11))
	name akas phones mails addresses fields notes lab val
	instance)
    (setq name (if (child-of-class-p ebdb-default-record-class
				     'ebdb-record-person)
		   (make-instance
		    ebdb-default-name-class
		    :surname l-name
		    :given-names (when f-name (split-string f-name " " nil))
		    :affix (if (stringp affix)
			       affix
			     (mapconcat #'identity affix " ")))
		 (make-instance 'ebdb-field-name-simple
				:name (if f-name
					  (concat f-name " " l-name)
					l-name))))
    (when aka
      (dolist (a aka)
	(push (make-instance ebdb-default-name-class
			     :surname (car (last (split-string a)))
			     :given-names (butlast (split-string a)))
	      akas)))
    (when uuid
      (setq uuid
	    (make-instance 'ebdb-field-uuid :uuid uuid)))
    (when phone
      (dolist (p phone)
	(let ((label (aref p 0))
	      instance comment)
	  (setq instance
		(if (= 2 (length p))
		    ;; BBDB let users put arbitrary strings in after
		    ;; the phone number, when the number itself was a
		    ;; plain string.  Pull that out and put it in the
		    ;; `comment' slot.
		    (let ((p-string (aref p 1)))
		      (if (null (string-match "\\([^[:digit:]]+\\)\\'" p-string))
			  (ebdb-parse ebdb-default-phone-class p-string)
			(setq comment (string-trim (match-string 1 p-string)))
			(ebdb-parse ebdb-default-phone-class
				    (substring p-string 0 (match-beginning 1)))))
		  (make-instance ebdb-default-phone-class
				 :area-code (ebdb-vphone-area p)
				 :number (replace-regexp-in-string
					  "[- ]+"
					  "" (format "%d%d"
						     (ebdb-vphone-exchange p)
						     (ebdb-vphone-suffix p)))
				 :extension (ebdb-vphone-extension p))))
	  (when comment
	    (setf (slot-value instance 'comment) comment))
	  (setf (slot-value instance 'label) label)
	  (when (and (null (slot-value instance 'country-code))
		     ebdb-default-phone-country)
	    (setf (slot-value instance 'country-code)
		  ebdb-default-phone-country))
	  (push instance phones))))
    (when address
      (dolist (a address)
	(let ((label (aref a 0))
	      (streets (aref a 1))
	      (city (aref a 2))
	      (state (aref a 3))
	      (postcode (aref a 4))
	      (country (aref a 5))
	      (case-fold-search t))
	  (push (make-instance ebdb-default-address-class
			       :label label
			       :streets streets
			       :locality city
			       :region state
			       :postcode postcode
			       :country country)
		addresses))))
    (when mail
      (dolist (m mail)
	(let ((bits (ebdb-decompose-ebdb-address m)))
	  (when (cadr bits)
	    (push (make-instance ebdb-default-mail-class
				 :aka (car bits)
				 :mail (cadr bits))
		  mails))))
      (when mails
	(setf (slot-value (car (last mails)) 'priority) 'primary)))
    (when ts
      (setq ts (make-instance 'ebdb-field-timestamp
			      :timestamp
			      (apply #'encode-time
				     (mapcar
				      (lambda (el)
					(if (null el)
					    0
					  el))
				      (parse-time-string ts))))))
    (when c-date
      (setq c-date (make-instance 'ebdb-field-creation-date
				  :timestamp
				  (apply #'encode-time
					 (mapcar
					  (lambda (el)
					    (if (null el)
						0
					      el))
					  (parse-time-string c-date))))))
    (when xfields
      (dolist (x xfields)
	(setq lab (car x)
	      val (cdr x))
	(cond
	 ((eq lab 'mail-alias)
	  (when mails
	    (push (make-instance 'ebdb-field-mail-alias
				 :alias val
				 :address (car-safe mails))
		  fields)))
	 ((and (stringp val)
	       (string-match-p url-handler-regexp val))
	  (push (make-instance 'ebdb-field-url
			       :url val)
		fields))
	 ((eq lab 'anniversary)
	  (let* ((bits (split-string val " "))
		 (date-bits (split-string (car bits) "-")))
	    (push (make-instance 'ebdb-field-anniversary
				 :date (list
					(string-to-number (nth 1 date-bits))
					(string-to-number (nth 2 date-bits))
					(string-to-number (car date-bits)))
				 :label (cadr bits))
		  fields)))
	 ((eq lab 'notes)
	  (setq notes (make-instance 'ebdb-field-notes
				     :notes val)))
	 ((eq lab 'messages)
	  (unless (stringp val)
	    (require 'ebdb-gnorb)
	    (setq val
		  (mapcar
		   (lambda (s)
		     (make-gnorb-ebdb-link
		      :subject (aref s 1)
		      :date (aref s 2)
		      :group (aref s 3)
		      :id (aref s 4)))
		   val))
	    (push (make-instance 'gnorb-ebdb-field-messages
				 :messages val)
		  fields)))
	 ((eq lab gnorb-ebdb-org-tag-field)
	  (push (make-instance 'ebdb-org-field-tags
			       :tags (if (listp val)
					 val
				       (split-string val ";" t " ")))
		fields))
	 ((eq lab bbdb/gnus-score-field)
	  (push (make-instance 'ebdb-gnus-score-field
			       :score val)
		fields))
	 ((memq lab (list 'imap bbdb/gnus-split-private-field
			  bbdb/vm-auto-folder-field))
	  (push (make-instance 'ebdb-field-mail-folder
			       :folder val)
		fields))
	 (t
	  (push (make-instance 'ebdb-field-user-simple
			       :label (symbol-name (car x))
			       :value val)
		fields)))))
    (setq instance
	  (make-instance ebdb-default-record-class
			 :name name
			 :uuid uuid
			 :phone phones
			 :address addresses
			 :mail mails
			 :timestamp ts
			 :creation-date c-date
			 :notes notes
			 :dirty t
			 :fields fields))
    (when akas
      (condition-case nil
	  (setf (slot-value instance 'aka) akas)
	(invalid-slot-type nil)))
    instance))

(defun ebdb-migrate-parse-records ()
  "Parse an earlier (non-EIEIO) version of a BBDB database file."
  (save-excursion
    (save-restriction
      (widen)
      (goto-char (point-min))
      ;; look backwards for file-format, and convert if necessary.
      (let ((file-format
	     (if (re-search-forward
		  "^;+[ \t]*file-\\(format\\|version\\):[ \t]*\\([0-9]+\\)[ \t]*$" nil t)
		 (string-to-number (match-string 2))))
            migrate records)
        (unless file-format ; current file-format, but no file-format: line.
          (error "BBDB corrupted: no file-format line"))
        (if (> file-format ebdb-file-format)
            (error "EBDB understands file format %s but not %s."
                   ebdb-file-format file-format)
          (setq migrate (< file-format ebdb-file-format)))
	(unless (re-search-forward "^\\[" nil t)
	  (error "Unreadabe BBDB file: no contacts found"))
	(goto-char (line-beginning-position))
        ;; narrow the buffer to skip over the rubbish before the first record.
        (narrow-to-region (point) (point-max))
        (let ((modp (buffer-modified-p))
              ;; Make sure those parens get cleaned up.
              ;; This code had better stay simple!
              (inhibit-quit t)
              (buffer-undo-list t)
              buffer-read-only)
          (goto-char (point-min)) (insert "(\n")
          (goto-char (point-max)) (insert "\n)")
          (goto-char (point-min))
          (unwind-protect
              (setq records (read (current-buffer)))
            (goto-char (point-min)) (delete-char 2)
            (goto-char (point-max)) (delete-char -2)
            (set-buffer-modified-p modp)))
        (widen)

        ;; Migrate if `bbdb-file' is outdated.
        (if migrate (setq records (ebdb-migrate records file-format)))

	records))))

(defvar ebdb-migrate-org-simple-correspondences
  '((org-contacts-email-property . ebdb-default-mail-class)
    (org-contacts-tel-property . ebdb-default-phone-class)
    (org-contacts-note-property . ebdb-default-notes-class)
    ;; NICKNAME is specifically meant for erc nicks, not normal
    ;; nicknames.
;    (org-contacts-nickname-property . ebdb-field-name-simple)
    (org-contacts-alias-property . ebdb-default-name-class))
  "The simplest property-to-field correspondences.
This variable only holds correspondences for fields that require
no processing beyond calling `ebdb-parse' on the string values.")

;;;###autoload
(defun ebdb-migrate-from-org-contacts ()
  "Migrate contacts from the org-contacts format."
  (interactive)
  (require 'org-contacts)
  (unless ebdb-sources
    (error "First set `ebdb-sources' to the location of your EBDB database."))

  (let ((db (ebdb-prompt-for-db nil t))
	;; Postpone evaluation of the symbols until run time.
	(prop-fields
	 (mapcar
	  (pcase-lambda (`(,prop . ,class))
	    (cons (symbol-value prop)
		  (if (class-p class) class (symbol-value class))))
	  ebdb-migrate-org-simple-correspondences))
	(count 0)
	(dud-fields '())
	record records)

    (message "Migrating records from org-contacts... %d records" count)

    (pcase-dolist (`(,name ,_ ,fields) (org-contacts-db))
      (setq record (make-instance ebdb-default-record-class))
      (ebdb-record-change-name record name)
      (pcase-dolist (`(,field-label . ,value) fields)
	(condition-case nil
	    (let ((f (if (assoc-string field-label prop-fields)
			 (ebdb-parse (cdr (assoc-string field-label prop-fields))
				     value)
		       (pcase field-label
			 ((pred (equal org-contacts-address-property))
			  (signal 'ebdb-unparseable (list value)))
			 ((pred (equal org-contacts-birthday-property))
			  (make-instance 'ebdb-field-anniversary
					 :date  (calendar-gregorian-from-absolute
						 (org-time-string-to-absolute
						  value))
					 :label "birthday"))))))
	      (when f
		(ebdb-record-insert-field record f)))
	  (ebdb-unparseable
	   (push (cons field-label value)
		 (alist-get name dud-fields '() nil #'equal)))))
      (push record records)
      (message "Migrating records from org-contacts... %d records"
	       (cl-incf count)))

    (dolist (r records)
      (ebdb-db-add-record db r))

    (message "Migrating records from org-contacts... %d records"
	     (length records))

    (ebdb-display-records records)

    (when dud-fields
      (pop-to-buffer (get-buffer-create "*EBDB Migration Errors*")
		     '(display-buffer-pop-up-window . ((width . 50))))
      (goto-char (point-min))
      (pcase-dolist (`(,name . ,fields) dud-fields)
	(insert (format "* [[ebdb:uuid/%s][%s]]\n"
			(ebdb-record-uuid (car (ebdb-gethash name '(fl-name))))
			name))
	(pcase-dolist (`(,field-label . ,value) fields)
	  (insert (format "%s: %s\n" field-label value)))
	(insert "\n"))
      (goto-char (point-min))
      (org-mode)
      (message "Some field values could not be parsed"))))

(provide 'ebdb-migrate)
;;; ebdb-migrate.el ends here