;; Copyright 2006-2014, Matthew Welland.
;; 
;;  This program is made available under the GNU GPL version 2.0 or
;;  greater. See the accompanying file COPYING for details.
;; 
;;  This program is distributed WITHOUT ANY WARRANTY; without even the
;;  implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
;;  PURPOSE.


(module refdb
	(
	 ;; routines for accessing refdb files (useful to user)
	 read-dat ;; produces the dat format ( ("row" "col" "val") ...)
	 lookup
	 get-rowcol-names
	 datf->alist   ;; read dat into alist (does not respect record order)
	 refdb->alist
	 dat->alist                  ;; convert dat to alist
	 alist-remove-blank-entries  ;; remove bogus entries "" ("" . "")
	 alist3->sqlite3db           ;; convert a refdb to sqlite3
	 get-row-or-column           ;; get row-value or col-value pairs
	 set-sheet-var
	 write-dat
	 mod-value
	 add-sheet
	 list-sheets
	 
	 ;; gnumeric routines
	 refdb:read-gnumeric-xml
	 sheet->refdb
	 refdb-export
	 read-gnumeric-file
	 import-gnumeric-file

	 ;; sxml utils
	 sxml->file
	 file->sxml
	 find-section
	 remove-section
	 extract-refdb
	 dat->cells
	 refdb->sxml

	 ;; misc
	 refdb-version
	 list-sections
	 string->safe-filename

	 replace-sheet-name-index
	 hash-table-reverse-lookup
	 get-value-type
	 dat-lookup
	 dat->list-of-lists
	 list-of-lists->csv
	 conf-get-record
	 common:sparse-list-generate-index
	 edit-refdb
	 create-new-db
	 make-sheet-meta-if-needed
	 megatest->refdb
         
	 )

(import scheme chicken extras)

(use data-structures)
(use srfi-1)
(use files)
(use srfi-13)
(use ssax)
(use sxml-serializer)
(use sxml-modifications)
(use regex)
(use srfi-69)
(use regex-case)
(use posix)
(use json)
(use csv)
(use srfi-18)
;; (use sql-de-lite)
(use sqlite3)

(define refdb-version 1.05)

;;======================================================================
;; M I S C
;;======================================================================

(define (file->list path)
  (with-input-from-file path
    (lambda ()
      (let loop ((instr (read-line))
		 (res   '()))
	(if (eof-object? instr)
	    (reverse res)
	    (loop (read-line)
		  (cons instr res)))))))

;;======================================================================
;; G N U M E R I C
;;======================================================================

;; Read a non-compressed gnumeric file
(define (refdb:read-gnumeric-xml fname)
  (with-input-from-file fname
    (lambda ()
      (ssax:xml->sxml (current-input-port) '()))))


(define (find-section dat section #!key (depth 0))
  (let loop ((hed   (car dat))
	     (tal   (cdr dat)))   
    (if (list? hed)
	(let ((res (find-section hed section depth: (+ depth 1))))
	  (if res 
	      res
	      (if (null? tal)
		  #f
		  (loop (car tal)(cdr tal)))))
	(if (eq? hed section)
	    tal
	    (if (null? tal)
		#f
		(loop (car tal)(cdr tal)))))))

(define (remove-section dat section)
  (if (null? dat)
      '()
      (let loop ((hed (car dat))
		 (tal (cdr dat))
		 (res '()))
	(let ((newres (if (and (list? hed)
			       (not (null? hed))
			       (equal? (car hed) section))
			  res
			  (cons hed res))))
	  (if (null? tal)
	      (reverse newres)
	      (loop (car tal)(cdr tal) newres))))))

(define (list-sections dat)
  (filter (lambda (x)(and x))
	  (map (lambda (section)
		 (if (and (list? section)
			  (not (null? section)))
		     (car section)
		     #f))
	       dat)))

(define (string->safe-filename str)
  (string-substitute (regexp " ") "_" str #t))

(define (sheet->refdb dat targdir #!key (rec #f)) ;; records: 'col or 'row
  (let* ((comment-rx  (regexp "^#CMNT\\d+\\s*"))
	 (blank-rx    (regexp "^#BLNK\\d+\\s*"))
	 (record  (if rec rec (conf-get-record targdir)))
    (sheet-name  (car (find-section dat 'http://www.gnumeric.org/v10.dtd:Name)))
	 ;; (safe-name   (string->safe-filename sheet-name))
	 (cells       (find-section dat 'http://www.gnumeric.org/v10.dtd:Cells))
	 (remaining   (remove-section (remove-section dat 'http://www.gnumeric.org/v10.dtd:Name)
				      'http://www.gnumeric.org/v10.dtd:Cells))
	 (rownums     (make-hash-table))  ;; num -> name
	 (colnums     (make-hash-table))  ;; num -> name
	 (cols        (make-hash-table))  ;; name -> ( (name val) ... )
	 (col0title   ""))
    (for-each (lambda (cell)
		(let ((rownum  (string->number (car (find-section cell (if (eq? record 'col) 'Row 'Col)))))
		      (colnum  (string->number (car (find-section cell (if (eq? record 'col) 'Col 'Row)))))
		      (valtype (let ((res (find-section cell 'ValueType)))
				 (if res (car res) #f)))
		      (value   (let ((res (cdr (filter (lambda (x)(not (list? x))) cell))))
				 (if (null? res) "" (car res)))))
		  ;; If colnum is 0 Then this is a row name, if rownum is 0 then this is a col name
		  (cond
		   ((and (not (eq? 0 rownum))
			 (eq? 0 colnum)) ;; a blank in column zero is handled with the special name "row-N"
		    (hash-table-set! rownums rownum (if (equal? value "")
							(conc "row-" rownum)
							value)))
		   ((and (not (eq? 0 colnum))
			 (eq? 0 rownum))
		    (hash-table-set! colnums colnum (if (equal? value "")
							(conc "col-" colnum)
							value)))
		   ((and (eq? 0 rownum)
			 (eq? 0 colnum))
		    (set! col0title value))
		   (else
		    (let ((colname (hash-table-ref/default colnums colnum (conc "col-" colnum)))
			  (rowname (hash-table-ref/default rownums rownum (conc "row-" rownum))))
		      (hash-table-set! cols colname (cons (list rowname value) 
							  (hash-table-ref/default cols colname '()))))))))
	      cells)
    (let ((ref-colnums (map (lambda (c)
			      (list (cdr c)(car c)))
			    (hash-table->alist colnums))))
      (with-output-to-file (conc targdir "/" sheet-name ".dat")
	(lambda ()
	  (if (not (string-null? col0title))(print "[" col0title "]"))
	  (for-each (lambda (colname)
		      (print "[" colname "]")
		      (for-each (lambda (row)
				  (let ((key (car row))
					(val (cadr row)))
				    (if (string-search comment-rx key)
					(print val)
					(if (string-search blank-rx key)
					    (print)
					    (if (string-search " " key)
						(print "\"" key "\" " val)
						(print key " " val))))))
				(reverse (hash-table-ref cols colname)))
		      ;; (print)
		      )
		    (sort (hash-table-keys cols)(lambda (a b)
						  (let ((colnum-a (assoc a ref-colnums))
							(colnum-b (assoc b ref-colnums)))
						    (if (and colnum-a colnum-b)
							(< (cadr colnum-a)(cadr colnum-b))
							(if (and (string? a)
								 (string? b))
							    (string< a b))))))))))
    (with-output-to-file (conc targdir "/sxml/" sheet-name ".sxml")
      (lambda ()
	(pretty-print-width 10)
	(pp remaining)))
    sheet-name))

(define (sxml->file dat fname)
  (with-output-to-file fname
    (lambda ()
      ;; (print (sxml-serializer#serialize-sxml dat))
      (pretty-print-width 10)
      (pp dat))))

(define (file->sxml fname)
  (let ((res (read-file fname read)))
    (if (null? res)
	(begin
	  (print "ERROR: file " fname " is malformed for read")
	  #f)
	(car res))))

(define (replace-sheet-name-index indat sheets)
  (let* ((rem-dat  (remove-section indat 'http://www.gnumeric.org/v10.dtd:SheetNameIndex))
	 (one-sht  (find-section rem-dat 'http://www.gnumeric.org/v10.dtd:SheetName)) ;; for the future if I ever decide to do this "right"
	 (mk-entry (lambda (sheet-name)
		     (append '(http://www.gnumeric.org/v10.dtd:SheetName
			       (@ (http://www.gnumeric.org/v10.dtd:Rows "65536")
				  (http://www.gnumeric.org/v10.dtd:Cols "256")))
			     (list sheet-name))))
	 (new-indx-values (map mk-entry sheets)))
    (append rem-dat (list (cons 'http://www.gnumeric.org/v10.dtd:SheetNameIndex
				new-indx-values)))))
    
    
;; Write an sxml gnumeric workbook to a refdb directory structure.
;;
(define (extract-refdb dat targdir #!key (rec #f)) ;; record 'col or 'row
  (create-directory (conc targdir "/sxml") #t)
  (let* ((record  (if rec rec (conf-get-record targdir)))
	 (wrkbk       (find-section   dat   'http://www.gnumeric.org/v10.dtd:Workbook))
	 (wrk-rem     (remove-section dat   'http://www.gnumeric.org/v10.dtd:Workbook))
	 (sheets      (find-section   wrkbk 'http://www.gnumeric.org/v10.dtd:Sheets))
	 (sht-rem     (remove-section wrkbk 'http://www.gnumeric.org/v10.dtd:Sheets))
	 (sheet-names (map (lambda (sheet)
			     (sheet->refdb sheet targdir record: record))
			   sheets)))
    (sxml->file wrk-rem (conc targdir "/sxml/_workbook.sxml"))
    (sxml->file sht-rem (conc targdir "/sxml/_sheets.sxml"))
    (with-output-to-file (conc targdir "/sheet-names.cfg")
      (lambda ()
	(map print sheet-names)))))

(define (read-gnumeric-file fname)
  (if (not (string-match (regexp ".*.gnumeric$") fname))
      (begin
	(print "ERROR: Attempt to import gnumeric file with extention other than .gnumeric")
	(exit))
      (let ((tmpf (create-temporary-file (pathname-strip-directory fname))))
	(system (conc " gunzip > " tmpf " < " fname))
	(let ((res (refdb:read-gnumeric-xml tmpf)))
	  (delete-file tmpf)
	  res))))

(define (import-gnumeric-file fname targdir #!key (rec #f)) ;; record 'col or 'row
  (let ((record  (if rec rec (conf-get-record targdir))))
    (extract-refdb (read-gnumeric-file fname) targdir record: record)))

;; Write a gnumeric compressed xml spreadsheet from a refdb directory structure.
;;
(define (refdb-export dbdir fname #!key (rec #f)) ;; record 'col or 'row
  (let* ((record  (if rec rec (conf-get-record dbdir)))
	 (sxml-dat (refdb->sxml dbdir record: record))
	 (tmpf     (create-temporary-file (pathname-strip-directory fname)))
	 (tmpgzf   (conc tmpf ".gz")))
    (with-output-to-file tmpf
      (lambda ()
	(print (sxml-serializer#serialize-sxml sxml-dat ns-prefixes: (list (cons 'gnm "http://www.gnumeric.org/v10.dtd"))))))
    (system (conc "gzip " tmpf))
    (file-copy tmpgzf fname #t)
    (delete-file tmpgzf)))

(define (hash-table-reverse-lookup ht val)
  (hash-table-fold ht (lambda (k v res)(if (equal? v val) k res)) #f))

(define (transpose-dat dat)
  (map (lambda (el)(list (cadr el)(car el)(caddr el)))
       dat))

(define (create-empty-dat fname)
  (if (file-write-access? (pathname-directory fname))
      (begin
	(with-output-to-file fname
	  (lambda ()
	    (print "[Refdb data file]\nfield value ...")))
	#t)
      #f))

;; converge this with the ini-file egg and the Megatest config reader. 
;;
(define (read-dat fname #!key (rec #f)(dest 'dat)(dont-read-conf #f)) ;; record: 'col or 'row, dest: 'dat or 'alist
  (if (not (file-exists? fname))
      (let ((record     (if dont-read-conf
			    rec
			    (if rec rec (conf-get-record (pathname-directory fname))))))
	(if (create-empty-dat fname)
	    (read-dat fname record: record dont-read-conf: dont-read-conf)
	    '(("" "" "")))	)
      (let ((section-rx  (regexp "^\\[(.*)\\]\\s*$"))
	    (comment-rx  (regexp "^#.*"))          ;; This means a cell name cannot start with #
	    (quoted-cell-rx (regexp "^\"([^\"]*)\" (.*)$"))
	    (cell-rx     (regexp "^(\\S+) (.*)$")) ;; One space only for the cellname content separator 
	    (blank-rx    (regexp "^\\s*$"))
	    (continue-rx (regexp ".*\\\\$"))
	    (var-no-val-rx (regexp "^(\\S+)\\s*$"))
	    (inp         (open-input-file fname))
	    (cmnt-indx   (make-hash-table))
	    (blnk-indx   (make-hash-table))
	    (first-section "") ;; used for zeroth title
	    (record     (if dont-read-conf
			    rec
			    (if rec rec (conf-get-record (pathname-directory fname))))))
	(let loop ((inl     (read-line inp))
		   (section ".............")
		   (res     '()))
	  (if (eof-object? inl)
	      (begin
		(close-input-port inp)
		(let ((newres (cons (list first-section first-section first-section)
				    (reverse res))))
		  (if (eq? record 'col)
		      newres
		      (transpose-dat newres))))
	      (regex-case
	       inl 
	       (continue-rx _         (loop (conc inl (read-line inp)) section res))
	       (comment-rx _          (let ((curr-indx (+ 1 (hash-table-ref/default cmnt-indx section 0))))
					(hash-table-set! cmnt-indx section curr-indx)
					(loop (read-line inp)
					      section 
					      (cons (list (conc "#CMNT" curr-indx) section inl) res))))
	       (blank-rx   _          (let ((curr-indx (+ 1 (hash-table-ref/default blnk-indx section 0))))
					(hash-table-set! blnk-indx section curr-indx)
					(loop (read-line inp)
					      section
					      (cons (list (conc "#BLNK" curr-indx) section " ") res))))
	       (section-rx (x sname)  (begin
					(if (not first-section)
					    (set! first-section sname))
					(loop (read-line inp) 
					      sname 
					      res)))
	       (quoted-cell-rx (x k v)(loop (read-line inp)
					    section
					    (cons (list k section v) res)))
	       (cell-rx   (x k v)     (loop (read-line inp)
					    section
					    (cons (list k section v) res)))
	       (var-no-val-rx (x k)   (loop (read-line inp)
					    section
					    (cons (list k section "") res)))
	       (else                  (begin
					(print "ERROR: Unrecognised line in input file " fname ", ignoring it")
					(loop (read-line inp) section res)))))))))

;; use a hash table with a list (x y) for the index and a hash table for the 
;; row name to number and col name to number
;;
(define (dat->list-of-lists dat)
  (let* ((sparse-array (make-hash-table))
	 (row-keys     (make-hash-table))
	 (col-keys     (make-hash-table))
	 (nam-row      (make-hash-table))
	 (nam-col      (make-hash-table))
	 (max-row      0)
	 (max-col      0))
    (let loop ((hed (car dat))
	       (tal (cdr dat)))
      (let* ((rown (car hed))
	     (coln (cadr hed))
	     (val  (caddr hed))
	     (rnum (or (hash-table-ref/default row-keys rown #f)
		       (let ((oldmax max-row))
			 (set! max-row (+ max-row 1))
			 (hash-table-set! row-keys rown oldmax)
			 oldmax)))
	     (cnum (or (hash-table-ref/default col-keys coln #f)
		       (let ((oldmax max-col))
			 (set! max-col (+ max-col 1))
			 (hash-table-set! col-keys coln oldmax)
			 oldmax)))
	     (realval (cond ;; didn't work
		       ((and (eq? rnum 0)(eq? cnum 0)) (if (not (string-null? coln))
							   coln
							   (if (not (string-null? rown))
							       rown
							       "")))
		       ((eq? rnum 0) coln)
		       ((eq? cnum 0) rown)
		       (else val))))
	(if (not (hash-table-ref/default nam-row rnum #f))(hash-table-set! nam-row rnum rown))
	(if (not (hash-table-ref/default nam-col cnum #f))(hash-table-set! nam-col cnum coln))
	;; (print "rnum: " rnum " cnum: " cnum " val: " val " realval: " realval)
	(hash-table-set! sparse-array (cons rnum cnum) realval)
	(if (not (null? tal))
	    (loop (car tal)(cdr tal))
	    (hash-table->alist sparse-array))))
    (let loop ((r 0)
	       (c 0)
	       (res '())
	       (row '()))
      (let* ((val  (hash-table-ref/default sparse-array (cons r c)
					   (cond ;; didn't work
					    ((and (eq? r 0)(eq? c 0)) "")
					    ((eq? r 0) (hash-table-ref/default nam-col c ""))
					    ((eq? c 0) (hash-table-ref/default nam-row r ""))
					    (else ""))))
	     (newr (cons val row)))
	(if (>= c (- max-col 1))
	    (loop (+ r 1) 0 (cons (reverse newr )res) '())
	    (if (> r max-row)
		(reverse (cons newr res))
		(loop r (+ c 1) res newr)))))))
	
(define (list-of-lists->csv data)
  (let-values (((fmt-cell fmt-record fmt-csv) (make-format ",")))
      (fmt-csv (map list->csv-record data))))

(define (write-dat fname dat #!key (rec #f))
  (let* ((record  (if rec rec (conf-get-record (pathname-directory fname))))
	 (mdat    (if (eq? record 'row)
		      (transpose-dat dat)
		      dat))
	 (sdat (sort mdat (lambda (a b)(string>? (cadr a)(cadr b)))))) ;; sort by column
    (with-output-to-file fname
      (lambda ()
	(if (null? dat)
	    (print "")
	    (let loop ((hed (car dat))
		       (tal (cdr dat))
		       (sec #f))
	      (let* ((row    (car hed))
		     (col    (cadr hed))
		     (val    (caddr hed))
		     (newsec (not (eq? col sec))))
		(if newsec (print "[" col "]"))
		(if (not (and (equal? row "")(equal? val "")))
		    (print row " " val))
		(if (not (null? tal))
		    (loop (car tal)(cdr tal)(if newsec col sec))))))))))
			       
(define (dat-lookup dat section var)
  (let ((res (assoc section (map cdr (filter (lambda (x)(equal? (car x) var)) dat)))))
    (if res
	(cadr res)
	#f)))

(define (mod-value dat section var val)
  (if (null? dat)
      (list (list section var val))
      (let loop ((hed (car dat))
		 (tal (cdr dat))
		 (res '())
		 (mod #f))
	(let ((new (if (and (equal? (car hed) section)
			    (equal? (cadr hed)  var))
		       (list section var val)
		       #f)))
	  (if (null? tal)
	      (if mod
		  (reverse (cons (if new new hed) res))
		  (reverse (cons (list section var val)(cons (if new new hed) res)))) ;; not found, tack it on
	      (loop (car tal)(cdr tal)(cons (if new new hed) res)(if new #t mod)))))))

;; Gnumeric spreadsheet values
;;
(define (get-value-type val expressions)
  (cond 
   ((not val)            '(ValueType "60"))
   ((string->number val) '(ValueType "40"))
   ((equal? val "")      '(ValueType "60"))
   ((equal? (substring val 0 1) "=")
    (let ((exid (hash-table-ref/default expressions val #f)))
      (if exid 
	  (list 'ExprID exid)
	  (let* ((values  (hash-table-keys expressions)) ;; note, values are the id numbers
		 (new-max (+ 1 (if (null? values) 0 (apply max values)))))
	    (hash-table-set! expressions val new-max)
	    (list 'ExprID new-max)))))
   (else '(ValueType "60"))))

;; convert a dat alist to sxml cells ready for conversion to gnumeric xml
;;
(define (dat->cells dat)
  (let* ((indx     (common:sparse-list-generate-index (cdr dat)))
	 (row-indx (car indx))
	 (col-indx (cadr indx))
	 (rowdat   (map (lambda (row)(list (car row) "    " (car row))) row-indx))
	 (coldat   (map (lambda (col)(list "    " (car col) (car col))) col-indx))
	 (exprs    (make-hash-table)))
    (list (cons 'http://www.gnumeric.org/v10.dtd:Cells 
		(map (lambda (item)
		       (let* ((row-name (car item))
			      (col-name (cadr item))
			      (row-num  (let ((i (assoc row-name row-indx)))
					  (if i (cadr i) 0))) ;; 0 for the title row/col
			      (col-num  (let ((i (assoc col-name col-indx)))
					  (if i (cadr i) 0)))
			      (value    (caddr item))
			      (val-type (get-value-type value exprs)))
			 (list 'http://www.gnumeric.org/v10.dtd:Cell
			       (list '@ val-type (list 'Row (conc row-num)) (list 'Col (conc col-num)))
			       value)))
		     (append rowdat coldat dat))))))

;; convert an entire refdb to sxml ready for conversion to gnumeric xml
;;
(define (refdb->sxml dbdir #!key (rec #f)) ;; record 'col or 'row
  (let* ((record    (if rec rec (conf-get-record dbdir)))
	 (sht-names (read-file (conc dbdir "/sheet-names.cfg")  read-line))
	 (wrk-rem   (file->sxml (conc dbdir "/sxml/_workbook.sxml")))
	 (sht-rem   (file->sxml (conc dbdir "/sxml/_sheets.sxml")))
	 (sheets    (fold (lambda (sheetname res)
			    (let* ((sheetdat (read-dat (conc dbdir "/" sheetname ".dat") record: record))
				   (cells    (dat->cells sheetdat))
				   (meta-fname (conc dbdir "/sxml/" sheetname ".sxml"))
				   (sht-meta (begin
					       (make-sheet-meta-if-needed meta-fname)
					       (file->sxml meta-fname))))
			      (cons (cons (car sht-meta) 
					  (append (cons (list 'http://www.gnumeric.org/v10.dtd:Name sheetname)
							(cdr sht-meta))
						  cells))
				    res)))
			  '()
			 (reverse  sht-names))))
    (append wrk-rem (list (append
			   (cons 'http://www.gnumeric.org/v10.dtd:Workbook
				 sht-rem)
			   (list (cons 'http://www.gnumeric.org/v10.dtd:Sheets sheets)))))))

;; (define (

;; 
;; optional apply proc to rownum colnum value
;; 
;; NB// If a change is made to this routine please look also at applying
;;      it to the code in Megatest (http://www.kiatoa.com/fossils/megatest)
;;      in the file common.scm
;;
(define (common:sparse-list-generate-index data #!key (proc #f))
  (if (null? data)
      (list '() '())
      (let loop ((hed (car data))
		 (tal (cdr data))
		 (rownames '())
		 (colnames '())
		 (rownum   0)
		 (colnum   0))
	(let* ((rowkey          (car   hed))
	       (colkey          (cadr  hed))
	       (value           (caddr hed))
	       (existing-rowdat (assoc rowkey rownames))
	       (existing-coldat (assoc colkey colnames))
	       (curr-rownum     (if existing-rowdat rownum (+ rownum 1)))
	       (curr-colnum     (if existing-coldat colnum (+ colnum 1)))
	       (new-rownames    (if existing-rowdat rownames (cons (list rowkey curr-rownum) rownames)))
	       (new-colnames    (if existing-coldat colnames (cons (list colkey curr-colnum) colnames))))
	  ;; (debug:print-info 0 "Processing record: " hed )
	  (if proc (proc curr-rownum curr-colnum rowkey colkey value))
	  (if (null? tal)
	      (list new-rownames new-colnames)
	      (loop (car tal)
		    (cdr tal)
		    new-rownames
		    new-colnames
		    (if (> curr-rownum rownum) curr-rownum rownum)
		    (if (> curr-colnum colnum) curr-colnum colnum)
		    ))))))

(define (list-sheets path)
  ;; (cond
  ;;  ((and path (not sheet)(not row)(not col))
  (if (file-exists? path)
      (read-file (conc path "/sheet-names.cfg") read-line)
      '()))

(define (add-sheet path sheetname)
  (let ((sheets (list-sheets path)))
    (with-output-to-file (conc path "/sheet-names.cfg")
      (lambda ()
	(for-each
	 (lambda (sheet)
	   (print sheet))
	 sheets)
	(print sheetname)))))

;; ((and path sheet (not row)(not col))

;;======================================================================
;; H I G H   L E V E L   C O M M A N D S
;;======================================================================

(define (lookup path sheet row col #!key (rec #f));; record 'col or 'row
  (let ((fname (conc path "/" sheet ".dat"))
	(record  (if rec rec (conf-get-record path))))
    (if (file-exists? fname)
	(let ((dat (read-dat fname record: record)))
	  (if (null? dat)
	      #f
	      (let loop ((hed (car dat))
			 (tal (cdr dat)))
		(if (and (equal? row (car hed))
			 (equal? col (cadr hed)))
		    (caddr hed)
		    (if (null? tal)
			#f
			(loop (car tal)(cdr tal)))))))
	#f)))

;; call with proc = car to get row names
;; call with proc = cadr to get col names
(define (get-rowcol-names path sheet proc #!key (rec #f))
  (let ((fname (conc path "/" sheet ".dat"))
	(cmnt-rx (regexp "^#CMNT\\d+\\s*"))
	(blnk-rx (regexp "^#BLNK\\d+\\s*"))
	(record  (if rec rec (conf-get-record path))))
    (if (file-exists? fname)
	(let ((dat (read-dat fname record: record)))
	  (if (null? dat)
	      '()
	      (let loop ((hed (car dat))
			 (tal (cdr dat))
			 (res '()))
		(let* ((row-name (proc hed))
		       (newres (if (and (not (member row-name res))
					(not (string-search cmnt-rx row-name))
					(not (string-search blnk-rx row-name)))
				   (cons row-name res)
				   res)))
		  (if (null? tal)
		      (reverse newres)
		      (loop (car tal)(cdr tal) newres))))))
	'())))

;; get row val pairs for a column
;;
(define (get-row-or-column path sheet name #!key (rec #f)(get-type 'row))
  (let ((fname (conc path "/" sheet ".dat"))
	(cmnt-rx (regexp "^#CMNT\\d+\\s*"))
	(blnk-rx (regexp "^#BLNK\\d+\\s*"))
	(record  (if rec rec (conf-get-record path))))
    (if (file-exists? fname)
	(let ((dat (read-dat fname record: record)))
	  (if (null? dat)
	      '()
	      (let loop ((hed (car dat))
			 (tal (cdr dat))
			 (res '()))
		(let* ((row-name (car hed))
		       (col-name (cadr hed))
		       (val      (caddr hed))
		       (newres   (if (eq? get-type 'col)
				     ;; get a row
				     (if (and (equal? col-name name)
					      (not (string-search cmnt-rx row-name))
					      (not (string-search blnk-rx row-name)))
					 (cons (cons row-name val) res)
					 res)
				     ;; get a column
				     (if (and (equal? row-name name)
					      (not (string-search cmnt-rx row-name))
					      (not (string-search blnk-rx row-name)))
					 (cons (cons col-name val) res)
					 res))))
		  (if (null? tal)
		      (reverse newres)
		      (loop (car tal)(cdr tal) newres))))))
	'())))

;; set a value
;;
(define (set-sheet-var dbpath sheet row col val #!key (rec #f))
  (let ((fname (conc dbpath "/" sheet ".dat"))
	;; (cmnt-rx (regexp "^#CMNT\\d+\\s*"))
	;; (blnk-rx (regexp "^#BLNK\\d+\\s*"))
	(record  (if rec rec (conf-get-record dbpath))))
    (if (file-exists? fname)
	(let ((dat (read-dat fname record: record)))
	  (write-dat fname (mod-value dat row col val)))
	(begin
	  (add-sheet dbpath sheet)
	  (write-dat fname (list (list row col val)))
	  (make-sheet-meta-if-needed (conc (pathname-directory fname) "/sxml/" sheet ".sxml"))
	  (let ((sheet-names (list-sheets dbpath)))
	    (sxml->file (replace-sheet-name-index sheets-meta sheet-names) (conc dbpath "/sxml/_sheets.sxml"))
	    )))))

(define (edit-refdb path)
  ;; TEMPORARY, REMOVE IN 2014
  (if (not (file-exists? path)) ;; Create new 
      (begin
	(print "\nINFO: Creating new txtdb at " path "\n")
	(create-new-db path)))
  (if (not (file-exists? (conc path "/sxml/_sheets.sxml")))
      (begin
	(print "ERROR: You appear to have the old file structure for txtdb. Please do the following and try again.")
	(print)
	(print "mv " path "/sxml/sheets.sxml " path "/sxml/_sheets.sxml")
	(print "mv " path "/sxml/workbook.sxml " path "/sxml/_workbook.sxml")
	(print)
	(print "Don't forget to remove the old files from your revision control system and add the new.")
	(exit)))
  (let* ((dbname  (pathname-strip-directory path))
	 (tmpf    (conc (create-temporary-file dbname) ".gnumeric"))
	 (record  (conf-get-record path)))
    (if (file-exists? (conc path "/sheet-names.cfg"))
	(refdb-export path tmpf record: record))
    (let* ((pid (process-run "gnumeric" (list tmpf))))
      (let loop ((last-mod-time (current-seconds)))
	(let-values (((pid-code exit-status exit-signal)(process-wait pid #t)))
           (if (eq? pid-code 0) ;; still going
	       (if (file-exists? tmpf)
		   (let ((mod-time (file-modification-time tmpf)))
		     (if (> mod-time last-mod-time)
			 (begin
			   (print "saved data to " path)
			   (import-gnumeric-file tmpf path record: record)))
		     (thread-sleep! 0.5)
		     (loop mod-time))
		   (begin
		     (thread-sleep! 0.5)
		     (loop last-mod-time))))))
      ;; all done
      (print "all done, writing new data to " path)
      (import-gnumeric-file tmpf path record: record)
      (print "data written, exiting refdb edit."))))

;; (define (get-col-names path sheet)
;;   (let ((fname (conc path "/" sheet ".dat")))
;;     (if (file-exists? fname)
;; 	(let ((dat (read-dat fname)))
;; 	  (if (null? dat)
;; 	      #f
;; 	      (map cadr dat))))))

;;======================================================================
;; S E T T I N G S
;;======================================================================

;; read the settings.cfg file and extract the record type
;;   'row  - i.e. rows are records
;;   'col  - i.e. cols are records
;;
(define (conf-get-record path) ;;  #!key (dont-read-conf #f))
  (let ((confdat (if (file-exists? (conc path "/settings.cfg"))
		     (read-dat (conc path "/settings.cfg") rec: 'col dont-read-conf: #t) ;; dont-read-conf)
		     '())))
    (if (equal? (dat-lookup confdat "setup" "record") "row")
	'row
	'col)))

;;======================================================================
;;  C R E A T E   N E W   D B S
;;======================================================================

(include "metadat.scm")

;; Creates a new db at path with one sheet
(define (create-new-db path)
  (extract-refdb minimal-sxml path))

;;======================================================================
;; M E G A T E S T   S U P P O R T
;;======================================================================

;; Construct a temporary refdb area from the files in a Megatest area
;; 
;; .refdb
;;      megatest.dat    (from megatest.config)
;;      runconfigs.dat  (from runconfigs.config)
;;      tests_test1.dat (from tests/test1/testconfig)
;; etc.
;;

;; takes path to meta file - not the dat file
;;
(define (make-sheet-meta-if-needed fname)
  (if (not (file-exists? fname))
      (sxml->file sheet-meta fname)))

(define (megatest->refdb)
  (if (not (file-exists? "megatest.config")) ;; must be at top of Megatest area
      (begin
	(print "ERROR: Must be at top of Megatest area to edit")
	(exit)))
  (create-directory ".refdb/sxml" #t)
  (if (not (file-exists? ".refdb/sxml/_workbook.sxml"))
      (sxml->file workbook-meta  ".refdb/sxml/_workbook.sxml"))
  (file-copy "megatest.config" ".refdb/megatest.dat" #t)
  (make-sheet-meta-if-needed ".refdb/sxml/megatest.sxml")
  (file-copy "runconfigs.config" ".refdb/runconfigs.dat" #t)
  (make-sheet-meta-if-needed ".refdb/sxml/runconfigs.sxml")
  (let ((testnames '()))
    (for-each (lambda (tdir)
		(let* ((testname (pathname-strip-directory tdir))
		       (tconfig  (conc tdir "/testconfig"))
		       (metafile (conc ".refdb/sxml/" testname ".sxml")))
		  (if (file-exists? tconfig)
		      (begin
			(set! testnames (append testnames (list testname)))
			(file-copy tconfig (conc ".refdb/" testname ".dat") #t)
			(make-sheet-meta-if-needed metafile)))))
	      (glob "tests/*"))
    (let ((sheet-names (append (list "megatest" "runconfigs") testnames)))
      (if (not (file-exists? ".refdb/sxml/_sheets.sxml"))
	  (sxml->file (replace-sheet-name-index sheets-meta sheet-names) ".refdb/sxml/_sheets.sxml"))
      (with-output-to-file ".refdb/sheet-names.cfg"
	(lambda ()
	  (map print sheet-names))))))
  
;;======================================================================
;; Simplified interface and exporters
;;======================================================================

;;======================================================================
;; alist
;;======================================================================

(define (datf->alist path sheet-name #!key (rec #f))
  (let ((dat-file (conc path "/" sheet-name ".dat"))
	(record   (if rec rec (conf-get-record path))))
    (with-input-from-file dat-file
      (lambda ()
	(let loop ((instr        (read-line))
		   (section-name #f)
		   (section-dat  '())
		   (data         '()))
	  (if (eof-object? instr)
	      (reverse (cons (cons section-name section-dat) data))
	      (regex-case
	       instr
	       ((regexp "^\\[(.*)\\]\\s*$") ( na sname ) ;; [section-name]
		(loop (read-line)
		      sname
		      '()
		      (if section-name
			  (cons (cons section-name (reverse section-dat)) data)
			  data)))
	       ((regexp "^(\\S+)\\s+(.*)$")( na var val )
		(loop (read-line)
		      section-name
		      (cons (cons var val) section-dat)
		      data))
	       (else
		(loop (read-line)
		      section-name
		      section-dat
		      data)))))))))

(define (refdb->alist path #!key (rec #f))
  (let* ((sheet-index (conc path "/sheet-names.cfg"))
	 (record  (if rec rec (conf-get-record path)))
	 (sheets (if (file-exists? sheet-index)
		     (file->list sheet-index)
		     '())))
    (if (null? sheets)
	'()
	(let loop ((hed  (car sheets))
		   (tal  (cdr sheets))
		   (data '()))
	  (let* ((dat     (alist-remove-blank-entries
			   (dat->alist
			    (read-dat (conc path "/" hed ".dat") record: record))));; (datf->alist path hed))
		 (newdata (cons (cons hed dat) data)))
	    (if (null? tal)
		(reverse newdata)
		(loop (car tal)
		      (cdr tal)
		      newdata)))))))

;; give dat of format: (("r1" "c1" "v1") ("r2" "c1" "v2") ... )
;; return:             (("c1" ("r1" . "v1)("r2" . "v2"))("c2"  ...)
(define (dat->alist dat)
  (if (null? dat)
      '()
      (let loop ((hed    (car dat))
		 (tal    (cdr dat))
		 (coln   #f)
		 (coldat '())
		 (res    '()))
	(let* ((r         (car hed))
	       (c         (cadr hed))
	       (v         (caddr hed))
	       (newcol    (not (equal? coln c)))
	       (newcoldat (if newcol
			      (cons c (list (cons r v)))
			      (append coldat (list (cons r v)))))
	       (newres    (if newcol
			      (if (null? coldat)
				  res
				  (append res (list coldat)))
			      res)))
	  (if (null? tal)
	      (append res (list newcoldat))
	      (loop (car tal)
		    (cdr tal)
		    (if newcol c coln)
		    newcoldat
		    newres))))))

(define (alist-remove-blank-entries alst)
  (filter (lambda (x)
	    (not (equal? (car x) "")))
	  alst))

;;     
;; refdb sheet -> section -> var -> val
;;  sqlite3db:
;;      table1 (sheet)
;;         var1 var2 var3 ...
;;         val1 val2 val3 ...
;;
(define (alist3->sqlite3db dat dbfile)
  (if (file-exists? dbfile)(system (conc "rm -f " dbfile)))
  (let ((seen-sheets (make-hash-table))
	(db          (open-database dbfile))
	(seen-tables (make-hash-table)))
    (execute db "PRAGMA synchronous = 0;")
    (for-each
     (lambda (sheet)
       (let ((sheet-name   (car sheet)) ;; maps to table
	     (sheet-dat    (cdr sheet))
	     (seen-fields  (make-hash-table))
	     (seen-rowkeys (make-hash-table)))
	 (if (not (hash-table-ref/default seen-tables sheet-name #f))
	     (let ((sql (conc "CREATE TABLE IF NOT EXISTS '" sheet-name "' (rowkey TEXT PRIMARY KEY);")))
	       ;; (print "sql=" sql)
	       (execute db sql)
	       (hash-table-set! seen-tables sheet-name #t)))
	 ;; (print "processing sheet-dat=" sheet-dat " for sheet name=" sheet-name)
	 (for-each
	  (lambda (column)
	    (let ((column-name  (car column)) ;; maps to field
		  (column-data  (cdr column)))
	      (if (not (hash-table-ref/default seen-fields column-name #f))
		  (let ((sql  (conc "ALTER TABLE '" sheet-name "' ADD COLUMN '" column-name "' TEXT;")))
		    ;; (print "sql=" sql)
		    (execute db sql)
		    (hash-table-set! seen-fields column-name #t)))
	      (for-each
	       (lambda (varval)
		 (let ((var (car varval))  ;; maps to rowkey
		       (val (cdr varval)))
		   ;; (print "seen rowkeys=" (hash-table-keys seen-rowkeys))
		   (if (not (hash-table-ref/default seen-rowkeys var #f))
		       (let ((sql (conc "INSERT INTO '" sheet-name "' (rowkey,'" column-name "') VALUES (?,?);")))
			 ;; (print "sql=" sql " " var " " val)
			 (execute db sql var val)
			 (hash-table-set! seen-rowkeys var #t))
		       (let ((sql (conc "UPDATE '" sheet-name "' SET '" column-name "'=? WHERE rowkey=?;")))
			 ;; (print "sql=" sql " " val " " var)
			 (execute db sql val var)))
		   ;; (print "sheet=" sheet-name " column=" column-name " " var "=" val)))
		   ))
	       column-data)))
	  sheet-dat)))
     dat)
    (finalize! db)))

)