(define (deblank! port)
   (let deblank ((c (peek-char port)))
      (cond ((eof-object? c) c)
	    ((char-whitespace? c)
	     (read-char port)
	     (deblank (peek-char port)))
	    (else c)
	    )))

(define (read-n-chars n port)
   (let ((s (make-string n)))
      (let get ((i 0) (c (read-char port)))
	 (cond ((eof-object? c) c)
	       ((< i n)
		(string-set! s i c)
		(get (+ i 1) (read-char port)))
	       (else s)
	       ))))


(define-record-type BBDB-record
   (raw-make-BBDB-record firstname
			 lastname
			 aka
			 company
			 phones
			 addresses
			 net
			 raw-notes
			 cache
			 )
   BBDB-record?
   (firstname BBDB-firstname BBDB-firstname!)
   (lastname BBDB-lastname BBDB-lastname!)
   (aka BBDB-aka BBDB-aka!)
   (company BBDB-company BBDB-company!)
   (phones BBDB-phones BBDB-phones!)
   (addresses BBDB-addresses BBDB-addresses!)
   (net BBDB-net BBDB-net!)
   (raw-notes BBDB-raw-notes BBDB-raw-notes!)
   (cache BBDB-cache BBDB-cache!)
   )

(define-record-type BBDB-address
   (raw-make-BBDB-address location
			  streets
			  city
			  state
			  zip
			  country)
   BBDB-address?
   (location bbdb-address-location)
   (streets bbdb-address-streets)
   (city bbdb-address-city)
   (state bbdb-address-state)
   (zip bbdb-address-zip)
   (country bbdb-address-country)
   )

(define *bbdb-record-number* 0)

(define (read-string-or-nil port abort)
   (let ((s (read port)))
      (cond ((string? s) s)
	    ((eq? s 'nil) '())
	    (else
	     (abort "not a string at BBDB record " *bbdb-record-number*))
	    )))

(define (read-strings port abort)
   (let ((ss (read port)))
      (if (eq? ss 'nil)
	  ss
	  (let check-strings ((check ss))
	     (cond ((null? check) ss)
		   ((pair? check)
		    (if (string? (car check))
			(check-strings (cdr check))
			(abort "not a list of strings at BBDB record " *bbdb-record-number*)))
		   (else
		    (abort "not a list at BBDB record " *bbdb-record-number*))
		   )))))


(define (read-firstname port abort) (read-string-or-nil port abort))
(define (read-lastname port abort) (read-string-or-nil port abort))
(define (read-company port abort) (read-string-or-nil port abort))

(define (read-aka port abort) (read-strings port abort))
(define (read-net port abort) (read-strings port abort))

(define (read-cache port abort)
   (let ((nil (read port)))
      (if (eq? nil 'nil)
	  '()
	  (abort "invalid cache in BBDB record " *bbdb-record-number*)
	  )))

(define (if-valid-phone phone k-got-phone abort)
   (let ((phone-length (length phone)))
      ; two valid phone specs in BBDB version 6
      (cond ((< phone-length 2)
	     (abort "invalid phone specification at BBDB record " *bbdb-record-number*))
	    
	    ((and (= phone-length 2)
		  (string? (car phone))
		  (string? (cadr phone)))
	     (k-got-phone (vector (car phone) (cadr phone))))
	    
	    (else
	     (let ((phone (reverse phone)))
		(let check ((numbers (cdr phone)))
		   (cond ((null? numbers) (k-got-phone (list->vector phone)))
			 ((number? (car numbers)) (check (cdr numbers)))
			 (else
			  (abort "invalid number in phone specification at BBDB record "
				 *bbdb-record-number*))
			 ))))
	    )))

(define (if-valid-address address k-got-address abort)
   (if (= (length address) 6)
       (apply (lambda (location streets city state zip country)
		 (if (and (string? location)
			  (string? city)
			  (string? state)
			  (string? country)
			  (string? zip)
			  (or (eq? streets 'nil)
			      (and (pair? streets)
				   (let check-streets ((streets streets))
				      (or (null? streets)
					  (and (string? (car streets))
					       (check-streets (cdr streets))))
				      ))))
		     (k-got-address (raw-make-BBDB-address location
							   (if (eq? streets 'nil) '() streets)
							   city
							   state
							   zip
							   country))
		     (abort "invalid address component at BBDB record " *bbdb-record-number* ": "
			    (list location streets city state zip country))
		     ))
	      address)
       (abort "invalid address at BBDB record " *bbdb-record-number*)
       ))


(define (read-elisp-array-object-in-list object-name if-valid port
					 k-got-object k-got-close
					 abort)
   (deblank! port)
   (let ((c0 (read-char port)))
      (cond ((char=? #\[ c0)
	     (let get-components ((object '()))
		(deblank! port)
		(let ((c1 (peek-char port)))
		   (if (char=? #\] c1)
		       (begin
			  (read-char port)
			  (if-valid (reverse object) k-got-object abort))
		       (let ((component (read port)))
			  (if (eof-object? component)
			      (abort "invalid " object-name " component at BBDB record " *bbdb-record-number*)
			      (get-components (cons component object))
			      ))))))
	    
	    ((char=? #\) c0) (k-got-close))

	    (else
	     (abort "invalid " object-name " at BBDB record " *bbdb-record-number*))
	    )))


(define (read-phone port k-got-phone k-got-close abort)
   (read-elisp-array-object-in-list "phone" if-valid-phone
				    port
				    (lambda (phone) (display `(read-phone ,phone)) (newline) (k-got-phone phone))
				    k-got-close
				    abort))

(define (read-address port k-got-address k-got-close abort)
   (read-elisp-array-object-in-list "address" if-valid-address
				    port
				    (lambda (address) (display `(read-address ,address)) (newline) (k-got-address address))
				    k-got-close
				    abort))
   

(define (read-custom-list objects-name read-object port abort)
   (deblank! port)
   (let ((c0 (read-char port)))
      (cond ((char=? #\( c0)
	     (let get-objects ((objects '()))
		(read-object port
		 (lambda (object) (get-objects (cons object objects)))
		 (lambda ()
		    (if (null? objects)
			(abort "no " objects-name " at BBDB record " *bbdb-record-number*)
			(begin
			   (display `(read ,objects-name)) (newline)
			   (reverse objects))
			))
		 abort)))
	    
	    ((and (char-ci=? #\n c0)
		  (char-ci=? #\i (read-char port))
		  (char-ci=? #\l (read-char port)))
	     '())
		     
	    (else
	     (abort "not a list of " objects-name " at BBDB record " *bbdb-record-number*))
	    )))

(define (read-phones port abort)
   (read-custom-list "phones" read-phone port abort))

(define (read-addresses port abort)
   (read-custom-list "addresses" read-address port abort))


(define (read-notes port abort)
   ; string or alist
   ; string -> ((notes . string))
   (deblank! port)
   (let ((notes (read port)))
      (cond ((string? notes) `((notes . ,notes)))
	    ((pair? notes)
	     (let check ((assocs notes))
		(if (null? assocs)
		    notes
		    (let ((assoc (car assocs))
			  (unchecked (cdr assocs)))
		       (cond ((and (not (null? unchecked))
				   (not (pair? unchecked)))
			      (abort "invalid notes a-list at BBDB record " *bbdb-record-number*))
			     
			     ((or (not (pair? assoc))
				  (and (not (symbol? (car assoc)))
				       (not (string? (cdr assoc)))))
			      (abort "invalid association in notes at BBDB record " *bbdb-record-number* ": " assoc))

			     (else
			      (check unchecked))
			     )))))
	    (else
	     (abort "invalid notes field in BBDB record " *bbdb-record-number* ": " notes))
	    )))

(define (read-bbdb-record port k-success k-eof k-failure)
   (deblank! port)
   (let ((result
	  (call/cc
	   (lambda (k-abort) 
	      (let ((abort (lambda args (k-abort (cons 'abort args))))
		    (c0 (read-char port)))
		 (cond ((char=? #\[ c0)
			(let* ((firstname (read-firstname port abort))
			       (lastname (read-lastname port abort))
			       (aka (read-aka port abort))
			       (company (read-company port abort))
			       (phones (read-phones port abort))
			       (addresses (read-addresses port abort))
			       (net (read-net port abort))
			       (raw-notes (read-notes port abort))
			       (cache (read-cache port abort))
			       )
			   (deblank! port)
			   (let ((c1 (read-char port)))
			      (if (char=? #\] c1)
				  (cons 'success
					(raw-make-BBDB-record firstname lastname aka
							      company
							      phones
							      net
							      addresses
							      raw-notes
							      cache))
				  (abort "unterminated BBDB record number " *bbdb-record-number*)
				  ))))
		       ((eof-object? c0) '(eof))
		       (else
			(abort "invalid BBDB record after" *bbdb-record-number*))
		       ))))))

      (case (car result)
	 ((success)
	  (set! *bbdb-record-number* (+ *bbdb-record-number* 1))
	  (k-success (cdr result)))

	 ((eof) (k-eof))
	 
	 ((abort) (k-failure (cdr result)))
	 
	 (else
	  (k-failure `("bogus internal return code: " ,(car result))))
	 )))

(define (read-bbdb-signature port k-success k-failure)
   (let* ((comment0 (read-n-chars 3 port))
	  (tag0 (read port))
	  (version (read port))
	  (comment1 (begin
		       (deblank! port)
		       (read-n-chars 3 port)))
	  (tag1 (read port))
	  (user-fields (read port)))
      (if (and (string=? ";;;" comment0)
	       (eq? tag0 'file-version:)
	       (= version 6)
	       (string=? ";;;" comment1)
	       (eq? tag1 'user-fields:)
	       (list? user-fields))
	  (k-success port)
	  (k-failure `("invalid BBDB signature: " ,tag0 ,version ,tag1 ,user-fields))
	  )))


(define (k-read-bbdb filename k-success k-failure)
   (let ((port (open-input-file filename)))
      (if (input-port? port)
	  (read-BBDB-signature port
	   (lambda (port)
	      (let get-records ((db '()))
		 (read-bbdb-record port
		  (lambda (record) (get-records (cons record db)))
		  (lambda () (k-success (list->vector (reverse db))))
		  (lambda (error-message) (k-failure error-message))
		  )))
	   k-failure)
	  
	  (k-failure `("could not open BBDB file " ,filename " for input"))
	  )))

(define (read-bbdb filename)
   (k-read-bbdb filename
		(lambda (bbdb) bbdb)
		(lambda (error-message)
		   (for-each display error-message)
		   (newline)
		   #f)))