Megatest

    (begin
      (debug:print-error 0 *default-log-port* "received bad encoded string \"" instr "\", message: " ((condition-property-accessor 'exn 'message) exn))
      (print-call-chain (current-error-port))
      #f)
    (read (open-input-string (base64:base64-decode instr))))
   (read (open-input-string (z3:decode-buffer (base64:base64-decode instr))))))










































;;======================================================================
;; S T A T E S   A N D   S T A T U S E S
;;======================================================================

;; BBnote: *common:std-states* - dashboard filter control and test control state buttons defined here; used in set-fields-panel and dboard:make-controls
(define *common:std-states*   ;; for toggle buttons in dashboard
  '(

	     val-list)
	'())))

;;======================================================================
;; S Y S T E M   S T U F F
;;======================================================================























;; return a nice clean pathname made absolute
(define (common:nice-path dir)
  (let ((match (string-match "^(~[^\\/]*)(\\/.*|)$" dir)))
    (if match ;; using ~ for home?
	(common:nice-path (conc (common:read-link-f (cadr match)) "/" (caddr match)))
	(normalize-pathname (if (absolute-pathname? dir)
				dir

(declare (unit commonmod))
(declare (uses configfmod))

(module commonmod
	*
	
(import scheme chicken data-structures extras)
(import (prefix sqlite3 sqlite3:) posix typed-records srfi-18
	srfi-69 ports srfi-1 files format srfi-13 matchable
	regex-case regex)

(import configfmod)
(include "common_records.scm")

(define (db:dbdat-get-path dbdat)
  (if (pair? dbdat)
      (cdr dbdat)

(define (common:iup-color->rgb-hex instr)
  (string-intersperse 
   (map (lambda (x)
          (number->string x 16))
        (map string->number
             (string-split instr)))
   "/"))

;; dot-locking egg seems not to work, using this for now
;; if lock is older than expire-time then remove it and try again
;; to get the lock
;;
(define (common:simple-file-lock fname #!key (expire-time 300))
    (if (file-exists? fname)
	(if (> (- (current-seconds)(file-modification-time fname)) expire-time)
	    (begin
              (handle-exceptions exn #f (delete-file* fname))	
	      (common:simple-file-lock fname expire-time: expire-time))
	    #f)
	(let ((key-string (conc (get-host-name) "-" (current-process-id))))
	  (with-output-to-file fname
	    (lambda ()
	      (print key-string)))
	  (thread-sleep! 0.25)
	  (if (file-exists? fname)
	      (handle-exceptions exn
                #f 
                (with-input-from-file fname
	  	  (lambda ()
		    (equal? key-string (read-line)))))
	      #f))))

(define (common:simple-file-lock-and-wait fname #!key (expire-time 300))
  (let ((end-time (+ expire-time (current-seconds))))
    (let loop ((got-lock (common:simple-file-lock fname expire-time: expire-time)))
      (if got-lock
	  #t
	  (if (> end-time (current-seconds))
	      (begin
		(thread-sleep! 3)
		(loop (common:simple-file-lock fname expire-time: expire-time)))
	      #f)))))

(define (common:simple-file-release-lock fname)
  (handle-exceptions
      exn
      #f ;; I don't really care why this failed (at least for now)
    (delete-file* fname)))

;; lazy-safe get file mod time. on any error (file not existing etc.) return 0
;;
(define (common:lazy-modification-time fpath)
  (handle-exceptions
      exn
      0
      (file-modification-time fpath)))

;; find timestamp of newest file associated with a sqlite db file
(define (common:lazy-sqlite-db-modification-time fpath)
  (let* ((glob-list (handle-exceptions
			exn
			`(,(conc "/no/such/file, message: " ((condition-property-accessor 'exn 'message) exn)))
		      (glob (conc fpath "*"))))
         (file-list (if (eq? 0 (length glob-list))
			'("/no/such/file")
			glob-list)))
  (apply max
   (map
    common:lazy-modification-time 
    file-list))))

;; (define (debug:print . params) #f)
;; (define (debug:print-info . params) #f)
;; 
;; (define (set-functions dbgp dbgpinfo)
;;   (set! debug:print dbgp)
;;   (set! debug:print-info dbgpinfo))

)

;;
(define (configf:var-is? cfgdat section var expected-val)
  (equal? (configf:lookup cfgdat section var) expected-val))

(define configf:lookup config-lookup)
(define configf:read-file read-config)














(define (configf:section-vars cfgdat section)
  (let ((sectdat (hash-table-ref/default cfgdat section '())))
    (if (null? sectdat)
	'()
	(map car sectdat))))

(define (configf:set-section-var cfgdat section var val)

(declare (unit configfmod))
;; (declare (uses commonmod))

(module configfmod
	*
	
(import scheme chicken data-structures extras)
(import (prefix sqlite3 sqlite3:) posix typed-records srfi-18
	srfi-69 format ports srfi-1 matchable regex)
;; (import commonmod)
;; (use (prefix ulex ulex:))

(include "common_records.scm")

(define (configf:lookup cfgdat section var)
  (if (hash-table? cfgdat)
      (let ((sectdat (hash-table-ref/default cfgdat section '())))
	(if (null? sectdat)
	    #f
	    (let ((match (assoc var sectdat)))
	      (if match ;; (and match (list? match)(> (length match) 1))
		  (cadr match)
		  #f))
	    ))
      #f))

(define (configf:get-section cfgdat section)
  (hash-table-ref/default cfgdat section '()))

;; safely look up a value that is expected to be a number, return
;; a default (#f unless provided)
;;
(define (configf:lookup-number cfgdat section varname #!key (default #f))
  (let* ((val (configf:lookup cfgdat section varname))
         (res (if val
                  (string->number (string-substitute "\\s+" "" val #t))
                  #f)))
    (cond
     (res  res)
     (val  (debug:print 0 *default-log-port* "ERROR: no number found for [" section "], " varname ", got: " val))
     (else default))))


)

      (debug:print-info 13 log-port "Done db:open-db")
      ;; (set! *dbstruct-db* dbstruct)
      alldat))))

;; This routine creates the db if not already present. It is only called if the db is not already opened
;;
(define (db:open-db alldat #!key (areapath #f)(do-sync #t)) ;; TODO: actually use areapath
  (let ((toppath     (alldat-areapath alldat))
	(configdat   (alldat-mtconfig alldat))
	(log-port    (alldat-log-port alldat))
	(tmpdb-stack (alldat-dbstack  alldat))) ;; RA => Returns the first reference in alldat
    (if (stack? tmpdb-stack)
	(db:get-db tmpdb-stack) ;; get previously opened db (will create new db handle if all in the stack are already used
        (let* ((max-stale-tmp (configf:lookup-number configdat "server" "filling-db-max-stale-seconds" default: 10))
               (dbpath       (common:get-db-tmp-area alldat))      ;; path to tmp db area
               (dbexists     (file-exists? dbpath))
	       (tmpdbfname   (conc dbpath "/megatest.db"))
	       (dbfexists    (file-exists? tmpdbfname))  ;; (conc dbpath "/megatest.db")))
               (mtdbexists   (file-exists? (conc toppath "/megatest.db")))
							 
               (mtdbmodtime  (if mtdbexists (common:lazy-sqlite-db-modification-time (conc toppath "/megatest.db"))   #f))
	        		 (tmpdbmodtime (if dbfexists  (common:lazy-sqlite-db-modification-time tmpdbfname) #f)) 
               (mtdb         (db:open-megatest-db))
               (mtdbpath     (db:dbdat-get-path mtdb))
               (tmpdb        (db:open-megatest-db path: dbpath)) ;; lock-create-open dbpath db:initialize-main-db))
               (refndb       (db:open-megatest-db path: dbpath name: "megatest_ref.db"))
               (write-access (file-write-access? mtdbpath))
	       

;; db's are dbdat's
;;
;; if last-update specified ("field-name" . time-in-seconds)
;;    then sync only records where field-name >= time-in-seconds
;;    IFF field-name exists
;;
(define (db:sync-tables alldat tbls last-update fromdb todb . slave-dbs)
  (let* ((configdat (alldat-mtconfig alldat)))
    (handle-exceptions
     exn
     (begin
       (debug:print 0 *default-log-port* "EXCEPTION: database probably overloaded or unreadable in db:sync-tables.")
       (print-call-chain (current-error-port))
       (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
       (debug:print 5 *default-log-port* "exn=" (condition->list exn))
       (debug:print 0 *default-log-port* " status:  " ((condition-property-accessor 'sqlite3 'status) exn))
       (debug:print 0 *default-log-port* " src db:  " (db:dbdat-get-path fromdb))
       (for-each (lambda (dbdat)
		   (let ((dbpath (db:dbdat-get-path dbdat)))
		     (debug:print 0 *default-log-port* " dbpath:  " dbpath)
		     (if (not (db:repair-db dbdat))
			 (begin
			   (debug:print-error 0 *default-log-port* "Failed to rebuild " dbpath ", exiting now.")
			   (exit)))))
		 (cons todb slave-dbs))
       
       0)
     ;; this is the work to be done
     (cond
      ((not fromdb) (debug:print 3 *default-log-port* "WARNING: db:sync-tables called with fromdb missing")
       -1)
      ((not todb)   (debug:print 3 *default-log-port* "WARNING: db:sync-tables called with todb missing")
       -2)
      ((not (sqlite3:database? (db:dbdat-get-db fromdb)))
       (debug:print-error 0 *default-log-port* "db:sync-tables called with fromdb not a database " fromdb)
       -3)
      ((not (sqlite3:database? (db:dbdat-get-db todb)))
       (debug:print-error 0 *default-log-port* "db:sync-tables called with todb not a database " todb)
       -4)

      ((not (file-write-access? (db:dbdat-get-path todb)))
       (debug:print-error 0 *default-log-port* "db:sync-tables called with todb not a read-only database " todb)
       -5)
      ((not (null? (let ((readonly-slave-dbs
			  (filter
			   (lambda (dbdat)
			     (not (file-write-access? (db:dbdat-get-path todb))))
			   slave-dbs)))
		     (for-each
		      (lambda (bad-dbdat)
			(debug:print-error
			 0 *default-log-port* "db:sync-tables called with todb not a read-only database " bad-dbdat))
		      readonly-slave-dbs)
		     readonly-slave-dbs))) -6)
      (else
       (let ((stmts       (make-hash-table)) ;; table-field => stmt
	     (all-stmts   '())              ;; ( ( stmt1 value1 ) ( stml2 value2 ))
	     (numrecs     (make-hash-table))
	     (start-time  (current-milliseconds))
	     (tot-count   0))
	 (for-each ;; table
	  (lambda (tabledat)
	    (let* ((tablename        (car tabledat))
		   (fields           (cdr tabledat))
		   (has-last-update  (member "last_update" fields))
		   (use-last-update  (cond
				      ((and has-last-update
					    (member "last_update" fields))
				       #t) ;; if given a number, just use it for all fields
				      ((number? last-update) #f) ;; if not matched first entry then ignore last-update for this table
				      ((and (pair? last-update)
					    (member (car last-update)    ;; last-update field name
						    (map car fields))) #t)
				      (last-update
				       (debug:print 0 *default-log-port* "ERROR: parameter last-update for db:sync-tables must be a pair or a number, received: " last-update) ;; found in fields
				       #f)
				      (else
				       #f)))
		   (last-update-value (if use-last-update ;; no need to check for has-last-update - it is already accounted for
					  (if (number? last-update)
					      last-update
					      (cdr last-update))
					  #f))
		   (last-update-field (if use-last-update
					  (if (number? last-update)
					      "last_update"
					      (car last-update))
					  #f))
		   (num-fields (length fields))
		   (field->num (make-hash-table))
		   (num->field (apply vector (map car fields))) ;; BBHERE
		   (full-sel   (conc "SELECT " (string-intersperse (map car fields) ",") 
				     " FROM " tablename (if use-last-update ;; apply last-update criteria
							    (conc " WHERE " last-update-field " >= " last-update-value)
							    "")
				     ";"))
		   (full-ins   (conc "INSERT OR REPLACE INTO " tablename " ( " (string-intersperse (map car fields) ",") " ) "
				     " VALUES ( " (string-intersperse (make-list num-fields "?") ",") " );"))
		   (fromdat    '())
		   (fromdats   '())
		   (totrecords 0)
		   (batch-len  (string->number (or (configf:lookup configdat "sync" "batchsize") "100")))
		   (todat      (make-hash-table))
		   (count      0)

		   (delay-handicap  (string->number (or (configf:lookup configdat "sync" "delay-handicap") "0")))
		   )

	      ;; set up the field->num table
	      (for-each
	       (lambda (field)
		 (hash-table-set! field->num field count)
		 (set! count (+ count 1)))
	       fields)

	      ;; read the source table
	      (sqlite3:for-each-row
	       (lambda (a . b)
		 (set! fromdat (cons (apply vector a b) fromdat))
		 (if (> (length fromdat) batch-len)
		     (begin
		       (set! fromdats (cons fromdat fromdats))
		       (set! fromdat  '())
		       (set! totrecords (+ totrecords 1)))))
	       (db:dbdat-get-db fromdb)
	       full-sel)
	      
	      ;; tack on remaining records in fromdat
	      (if (not (null? fromdat))
		  (set! fromdats (cons fromdat fromdats)))

	      (if (common:low-noise-print 120 "sync-records")
		  (debug:print-info 4 *default-log-port* "found " totrecords " records to sync"))

	      ;; read the target table; BBHERE
	      (sqlite3:for-each-row
	       (lambda (a . b)
		 (hash-table-set! todat a (apply vector a b)))
	       (db:dbdat-get-db todb)
	       full-sel)

	      (when (and delay-handicap (> delay-handicap 0))
		    (debug:print-info 0 *default-log-port* "imposing synthetic sync delay of "delay-handicap" seconds since sync/delay-handicap is configured")
		    (thread-sleep! delay-handicap)
		    (debug:print-info 0 *default-log-port* "synthetic sync delay of "delay-handicap" seconds completed")
		    )
	      
	      ;; first pass implementation, just insert all changed rows
	      (for-each 
	       (lambda (targdb)
		 (let* ((db     (db:dbdat-get-db targdb))
			(stmth  (sqlite3:prepare db full-ins)))
		   (for-each
		    (lambda (fromdat-lst)
		      (sqlite3:with-transaction
		       db
		       (lambda ()
			 (for-each ;; 
			  (lambda (fromrow)
			    (let* ((a    (vector-ref fromrow 0))
				   (curr (hash-table-ref/default todat a #f))
				   (same #t))
			      (let loop ((i 0))
				(if (or (not curr)
					(not (equal? (vector-ref fromrow i)(vector-ref curr i))))
				    (set! same #f))
				(if (and same
					 (< i (- num-fields 1)))
				    (loop (+ i 1))))
			      (if (not same)
				  (begin
				    (apply sqlite3:execute stmth (vector->list fromrow))
				    (hash-table-set! numrecs tablename (+ 1 (hash-table-ref/default numrecs tablename 0)))))))
			  fromdat-lst))
		       ))
		    fromdats)
		   (sqlite3:finalize! stmth)))
	       (append (list todb) slave-dbs))))
	  tbls)
	 (let* ((runtime      (- (current-milliseconds) start-time))
		(should-print (or (debug:debug-mode 12)
				  (common:low-noise-print 120 "db sync" (> runtime 500))))) ;; low and high sync times treated as separate.
	   (if should-print (debug:print 3 *default-log-port* "INFO: db sync, total run time " runtime " ms"))
	   (for-each 
	    (lambda (dat)
	      (let ((tblname (car dat))
		    (count   (cdr dat)))
		(set! tot-count (+ tot-count count))
		(if (> count 0)
		    (if should-print (debug:print 0 *default-log-port* (format #f "    ~10a ~5a" tblname count))))))
	    (sort (hash-table->alist numrecs)(lambda (a b)(> (cdr a)(cdr b))))))
	 tot-count))))))

;; return #f to indicate the dbdat should be closed/reopened
;; else return dbdat
;;
(define (db:repair-db dbdat #!key (numtries 1))
  (let* ((dbpath   (db:dbdat-get-path        dbdat))
	 (dbdir    (pathname-directory       dbpath))

;; Open the classic megatest.db file (defaults to open in toppath)
;;
;;   NOTE: returns a dbdat not a dbstruct!
;;

;;(define (db:reopen-megatest-db

(define (db:open-megatest-db alldat #!key (path #f)(name #f))
  (let* ((dbdir        (or path (alldat-areapath alldat)))
         (dbpath       (conc  dbdir "/" (or name "megatest.db")))
	 (dbexists     (file-exists? dbpath))
	 (db           (db:lock-create-open dbpath
					    (lambda (db)
                                              (db:initialize-main-db db)
					      ;;(db:initialize-run-id-db db)
					      )))
	 (write-access (file-write-access? dbpath)))
    (debug:print-info 13 *default-log-port* "db:open-megatest-db "dbpath)

;; open an sql database inside a file lock
;; returns: db existed-prior-to-opening
;; RA => Returns a db handler; sets the lock if opened in writable mode
;;
;; (define *db-open-mutex* (make-mutex))
;;
(define (db:lock-create-open alldat fname initproc)
  (let* ((configdat    (alldat-mtconfig alldat))
	 (parent-dir   (or (pathname-directory fname)
			   (current-directory))) ;; no parent? go local
         (raw-fname    (pathname-file fname))
	 (dir-writable (file-write-access? parent-dir))
	 (file-exists  (file-exists? fname))
	 (file-write   (if file-exists
			   (file-write-access? fname)
			   dir-writable )))
    ;; (mutex-lock! *db-open-mutex*) ;; tried this mutex, not clear it helped.
    (if file-write ;; dir-writable
	(condition-case
         (let* ((lockfname   (conc fname ".lock"))
                (readyfname  (conc parent-dir "/.ready-" raw-fname))
                (readyexists (file-exists? readyfname)))
           (if (not readyexists)
               (common:simple-file-lock-and-wait lockfname))
           (let ((db      (sqlite3:open-database fname)))
             (sqlite3:set-busy-handler! db (sqlite3:make-busy-timeout 136000))
             (sqlite3:execute db "PRAGMA synchronous = 0;")
             (if (and (configf:lookup configdat "setup" "tmp_mode") (string-match "^/tmp/.*" fname))
                 (begin
                   ;;(print "DEBUG: Setting tmp_mode for " fname) 
                   (sqlite3:execute db (configf:lookup configdat "setup" "tmp_mode"))
                   )
                 )  
             (if (and (configf:lookup configdat "setup" "nfs_mode") (not (string-match "^/tmp/.*" fname)))
                 (begin
                   ;;(print "DEBUG: Setting nfs_mode for " fname)
                   (sqlite3:execute db (configf:lookup configdat "setup" "nfs_mode"))
                   )
                 )  
             (if (and (not (or (configf:lookup configdat "setup" "tmp_mode") (configf:lookup configdat "setup" "nfs_mode")))  
                      (configf:lookup configdat "setup" "use-wal")
                      (string-match "^/tmp/.*" fname)) ;; this is a file in /tmp
                 (sqlite3:execute db "PRAGMA journal_mode=WAL;")
                 (debug:print 2 *default-log-port* "Creating " fname " in NON-WAL mode."))
             (if (not file-exists)
                 (initproc db))
             (if (not readyexists)
                 (begin