Megatest

	$(INSTALL) $< $@
	chmod a+x $@

$(PREFIX)/bin/mt-new-to-old.sh : utils/mt-new-to-old.sh
	$(INSTALL) $< $@
	chmod a+x $@

$(PREFIX)/bin/convert-db.sh : utils/convert-db.sh
	$(INSTALL) $< $@
	chmod a+x $@

deploytarg/nbfake : utils/nbfake
	$(INSTALL) $< $@
	chmod a+x $@

deploytarg/viewscreen : utils/viewscreen
	$(INSTALL) $< $@

        fi

install : $(PREFIX)/bin/.$(ARCHSTR) $(PREFIX)/bin/.$(ARCHSTR)/mtest $(PREFIX)/bin/megatest \
          $(PREFIX)/bin/.$(ARCHSTR)/dboard $(PREFIX)/bin/dashboard $(HELPERS) $(PREFIX)/bin/nbfake \
          $(PREFIX)/bin/.$(ARCHSTR)/mtexec $(PREFIX)/bin/mtexec $(PREFIX)/bin/serialize-env \
	  $(PREFIX)/bin/nbfind $(PREFIX)/bin/mtrunner $(PREFIX)/bin/viewscreen $(PREFIX)/bin/mt_xterm \
          $(PREFIX)/bin/mt-old-to-new.sh $(PREFIX)/bin/mt-new-to-old.sh \
          $(PREFIX)/bin/convert-db.sh $(PREFIX)/bin/convert-db.sh \
	  $(PREFIX)/share/docs/megatest_manual.html $(PREFIX)/bin/remrun \
	  $(PREFIX)/share/docs/megatest_manual.html $(PREFIX)/bin/remrun $(PREFIX)/bin/mtutil \
	  $(PREFIX)/bin/tcmt $(PREFIX)/share/db/mt-pg.sql \
          $(PREFIX)/share/js/jquery-3.1.0.slim.min.js \
          $(PREFIX)/bin/.$(ARCHSTR)/lib/libpangox-1.0.so \
          $(PREFIX)/bin/.$(ARCHSTR)/lib/libpangox-1.0.so.0 \
          $(PREFIX)/bin/.$(ARCHSTR)/lib/libxcb-xlib.so.0

                     ((test-set-state-status)           (apply db:test-set-state-status dbstruct params))
                     ((test-set-top-process-pid)        (apply db:test-set-top-process-pid dbstruct params))
                     ((set-state-status-and-roll-up-items) (apply db:set-state-status-and-roll-up-items dbstruct params))
                     ((set-state-status-and-roll-up-run) (apply db:set-state-status-and-roll-up-run dbstruct params)) 
                     ((top-test-set-per-pf-counts)      (apply db:top-test-set-per-pf-counts dbstruct params))
                     ((test-set-archive-block-id)       (apply db:test-set-archive-block-id dbstruct params))

                     ((insert-test)                   (let ((run-id (alist-ref "run_id" params equal? #f)))
                                                       (db:insert-test dbstruct run-id params)))

                     ;; RUNS
                     ((register-run)                 (apply db:register-run dbstruct params))
                     ((set-tests-state-status)       (apply db:set-tests-state-status dbstruct params))
                     ((delete-run)                   (apply db:delete-run dbstruct params))
                     ((lock/unlock-run)              (apply db:lock/unlock-run dbstruct params))
                     ((update-run-event_time)        (apply db:update-run-event_time dbstruct params))
                     ((update-run-stats)             (apply db:update-run-stats dbstruct params))
                     ((set-var)                      (apply db:set-var dbstruct params))
                     ((inc-var)                      (apply db:inc-var dbstruct params))
		     ((dec-var)                      (apply db:dec-var dbstruct params))
                     ((del-var)                      (apply db:del-var dbstruct params))
		     ((add-var)                      (apply db:add-var dbstruct params))

                     ((insert-run)                   (apply db:insert-run dbstruct params))

                     ;; STEPS
                     ((teststep-set-status!)         (apply db:teststep-set-status! dbstruct params))
                     ((delete-steps-for-test!)       (apply db:delete-steps-for-test! dbstruct params))
                     
                     ;; TEST DATA
                     ((test-data-rollup)             (apply db:test-data-rollup dbstruct params))

(declare (unit common))
(declare (uses commonmod))
(import commonmod)

(include "common_records.scm")


;; (require-library margs)
(define (remove-server-files directory-path)
  (let ((files (glob (string-append directory-path "/server*"))))
;; (include "margs.scm")

    (for-each delete-file* files)))
;; (define old-exit exit)
;; 
;; (define (exit . code)
;;   (if (null? code)
;;       (old-exit)
;;       (old-exit code)))

(define (stop-the-train)
  (thread-start! (make-thread (lambda ()
				(let loop ()
				  (if (and *toppath*
					   (file-exists? (conc *toppath*"/stop-the-train")))
				      (begin
					(debug:print 0 *default-log-port* "ERROR: found file "*toppath*"/stop-the-train, exiting immediately")
                                        (remove-server-files (conc *toppath* "/logs"))
					(exit 1)))
				  (thread-sleep! 5)
				  (loop))))))

;; execute thunk, return value.  If exception thrown, trap exception, return #f, and emit nonfatal condition note to *default-log-port* .
;; arguments - thunk, message
(define (common:fail-safe thunk warning-message-on-exception)

(define *pkts-info*    (make-hash-table)) ;; store stuff like the last parent here
(define *configinfo*   #f)   ;; raw results from setup, includes toppath and table from megatest.config
(define *runconfigdat* #f)   ;; run configs data
(define *configdat*    #f)   ;; megatest.config data
(define *configstatus* #f)   ;; status of data; 'fulldata : all processing done, #f : no data yet, 'partialdata : partial read done
(define *toppath*      #f)
(define *dbdir* ".mtdb")
(define *already-seen-runconfig-info* #f)

(define *test-meta-updated* (make-hash-table))
(define *globalexitstatus*  0) ;; attempt to work around possible thread issues
(define *passnum*           0) ;; when running track calls to run-tests or similar
;; (define *alt-log-file* #f)  ;; used by -log
;; (define *common:denoise*    (make-hash-table)) ;; for low noise printing
(define *default-log-port*  (current-error-port))
(define *time-zero* (current-seconds)) ;; for the watchdog
(define *default-area-tag* "local")

;; DATABASE
;; (define *dbstruct-dbs*         #f) ;; used to cache the dbstruct in db:setup. Goal is to remove this.
;; db stats
(define *db-stats*            (make-hash-table)) ;; hash of vectors < count duration-total >
(define *db-stats-mutex*      (make-mutex))
;; db access
(define *db-last-access*      (current-seconds)) ;; last db access, used in server
;; (define *db-write-access*     #t)
;; db sync
;; (define *db-last-sync*        0)                 ;; last time the sync to megatest.db happened
;; (define *db-last-sync*        0)                 ;; last time the sync to nfs db happened
(define *db-sync-in-progress* #f)                ;; if there is a sync in progress do not try to start another
;; (define *db-multi-sync-mutex* (make-mutex))      ;; protect access to *db-sync-in-progress*, *db-last-sync*
;; task db
(define *task-db*             #f) ;; (vector db path-to-db)
(define *db-access-allowed*   #t) ;; flag to allow access
;; (define *db-access-mutex*     (make-mutex)) ;; moved to dbfile
(define *db-transaction-mutex* (make-mutex))

		     (handle-exceptions
		      exn
		      (debug:print-error 0 *default-log-port* "failed to remove " fullname ", exn=" exn)
		      (delete-file* fullname)))))
	     files)
	    (debug:print-info 0 *default-log-port* "Deleted " (length files) " files from logs, keeping " max-allowed " files."))))))

;;======================================================================
;; Force a megatest cleanup-db if version is changed and skip-version-check not specified
;; Do NOT check if not on homehost!
;;
(define (common:exit-on-version-changed)
  (if (common:on-homehost?)
      (if (common:api-changed?)
	  (let* ((mtconf (conc (get-environment-variable "MT_RUN_AREA_HOME") "/megatest.config"))
                 (dbfile  (conc (get-environment-variable "MT_RUN_AREA_HOME") "/megatest.db"))
                 (read-only (not (file-write-access? dbfile)))
                 (dbstruct (db:setup #t))) ;; (db:setup-db *dbstruct-dbs* *toppath* #f))) ;;  #t)))
	    (debug:print 0 *default-log-port*
			 "WARNING: Version mismatch!\n"
			 "   expected: " (common:version-signature) "\n"
			 "   got:      " (common:get-last-run-version))
            (cond
             ((get-environment-variable "MT_SKIP_DB_MIGRATE") #t)
             ((and (common:file-exists? mtconf) (common:file-exists? dbfile) (not read-only)
                   (eq? (current-user-id)(file-owner mtconf))) ;; safe to run -cleanup-db
              (debug:print 0 *default-log-port* "   I see you are the owner of megatest.config, attempting to cleanup and reset to new version")
              (handle-exceptions
               exn
               (begin
                 (debug:print 0 *default-log-port* "Failed to switch versions. exn=" exn)
                 (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
                 (print-call-chain (current-error-port))
                 (exit 1))
               (common:cleanup-db dbstruct)))
             ((not (common:file-exists? mtconf))
              (debug:print 0 *default-log-port* "   megatest.config does not exist in this area.  Cannot proceed with megatest version migration.")
              (exit 1))
             ((not (common:file-exists? dbfile))
              (debug:print 0 *default-log-port* "   megatest.db does not exist in this area.  Cannot proceed with megatest version migration.")
              (exit 1))
             ((not (eq? (current-user-id)(file-owner mtconf)))
              (debug:print 0 *default-log-port* "   You do not own megatest.db in this area.  Cannot proceed with megatest version migration.")
              (exit 1))
             (read-only
              (debug:print 0 *default-log-port* "   You have read-only access to this area.  Cannot proceed with megatest version migration.")
              (exit 1))
             (else
              (debug:print 0 *default-log-port* " to switch versions you can run: \"megatest -cleanup-db\"")
              (exit 1)))))))
;;======================================================================
;;      (begin
;;	(debug:print 0 *default-log-port* "ERROR: cannot migrate version unless on homehost. Exiting.")
;;	(exit 1))))

;;======================================================================
;; S P A R S E   A R R A Y S

					  (string-translate *toppath* "/" "."))
				    (conc "/tmp/" (current-process-id) ;; just in case we have an issue with the dir by own user name
					  "/megatest_localdb/"
					  tsname
					  (string-translate *toppath* "/" "."))
				    ))))
		(set! *db-cache-path* dbpath)
		;; ensure megatest area has .megatest
		(let ((dbarea (conc *toppath* "/.megatest")))
		;; ensure megatest area has dbdir
		(let ((dbarea (conc *toppath* "/" *dbdir*)))
		  (if (not (file-exists? dbarea))
		      (create-directory dbarea)))
		;; ensure tmp area has .megatest
		(let ((dbarea (conc dbpath "/.megatest")))
		;; ensure tmp area has dbdir
		(let ((dbarea (conc dbpath "/" *dbdir*)))
		  (if (not (file-exists? dbarea))
		      (create-directory dbarea)))
		dbpath))
	  #f)))

(define (common:get-area-path-signature)
  (message-digest-string (md5-primitive) *toppath*))

    (if valstr
	(val->alist valstr)
	'()))) ;; should it return empty list or #f to indicate not set?


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

(define (common:make-tmpdir-name areapath tmpadj)
  (let* ((area (pathname-file areapath))
         (dname (conc "/tmp/"(current-user-name)"/megatest_localdb/" area "/" (string-translate areapath "/" ".") tmpadj "/.mtdb")))
    (unless (directory-exists? dname)
      (create-directory dname #t))
    dname))

;; 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))
  (let ((fmod-time (handle-exceptions

                        0
                        (dboard:rundat-last-update run-dat)))
	 (last-db-time (if do-not-use-db-file-timestamps
			   0
			   (dboard:rundat-last-db-time run-dat)))
	 (db-path      (or (dboard:rundat-db-path run-dat)
			   (let* ((db-dir (common:get-db-tmp-area))
				  (db-pth (conc db-dir "/.megatest/main.db")))
				  (db-pth (conc db-dir "/" *dbdir* "/main.db")))
			     (dboard:rundat-db-path-set! run-dat db-pth)
			     db-pth)))
	 (db-mod-time  (common:lazy-sqlite-db-modification-time db-path))
	 (db-modified  (>= db-mod-time last-db-time))
	 (multi-get    (> (dboard:rundat-run-data-offset run-dat) 0))  ;; multi-get in progress
	 (tmptests     (if (or do-not-use-db-file-timestamps
			       (dboard:tabdat-filters-changed tabdat)

;;======================================================================

(stop-the-train)

(define (main)
  ;; (print "Starting dashboard main")
    
  (let* ((mtdb-path (conc *toppath* "/.megatest/main.db"))
  (let* ((mtdb-path (conc *toppath* "/" *dbdir* "/main.db"))
         (target (args:get-arg "-target"))
         (commondat       (dboard:commondat-make)))
    (if target
        (begin
          (args:remove-arg-from-ht "-target")
          (dboard:commondat-target-set! commondat target)
        )

    (if (not (common:on-homehost?))
    (begin
      (debug:print 0 *default-log-port* "WARNING: You are starting the dashboard on a machine that is not the homehost:" (common:get-homehost))
      (debug:print 0 *default-log-port* "It will be slower.")
      ))


    (if (and (common:file-exists? mtdb-path)
	     (file-write-access? mtdb-path))
	(if (not (args:get-arg "-skip-version-check"))
            (common:exit-on-version-changed)))

    (let* ()
      ;; Move this stuff to db.scm? I'm not sure that is the right thing to do...
      (cond 
       ((args:get-arg "-test") ;; run-id,test-id
	(let* ((dat     (let ((d (map string->number (string-split (args:get-arg "-test") ",")))) 
			  (if (> (length d) 1)
			      d

(define last-copy-time 0)


;; Sync to tmp only if in read-only mode.

(define (sync-db-to-tmp tabdat)
  (let* ((db-file "./.megatest/main.db"))
  (let* ((db-file (conc "./" *dbdir* "/main.db")))
    (if (and (not (file-write-access? db-file)) ( > (current-seconds) (+ last-copy-time 5)))
      (begin
        (db:multi-db-sync (db:setup #f) 'old2new)
        (set! last-copy-time (current-seconds))
      )
    )
  )

(define (db:all-db-sync dbstruct)
  (let* ((dbdat (db:open-db dbstruct #f db:initialize-main-db))
	 (data-synced       0) ;; count of changed records
    (tmp-area       (common:get-db-tmp-area))
    (dbfiles        (glob (conc tmp-area"/.megatest/*.db")))
    (dbfiles        (glob (conc tmp-area"/" *dbdir* "/*.db")))
    (sync-durations (make-hash-table))
    (no-sync-db        (db:open-no-sync-db)))
    (for-each
     (lambda (file) ;; tmp db file
       (debug:print-info 3 *default-log-port* "file: " file)
       (let* ((fname       (conc (pathname-file file) ".db")) ;; fname is tmp db file
              (wal-file (conc file "-wal"))
              (shm-file (conc file "-shm"))
	      (fulln       (conc *toppath*"/.megatest/"fname)) ;; fulln is nfs db name
	      (fulln       (conc *toppath*"/" *dbdir* "/"fname)) ;; fulln is nfs db name
              (wal-time     (if (file-exists? wal-file)             
			       (file-modification-time wal-file)
                               0))
              (shm-time     (if (file-exists? shm-file)             
			       (file-modification-time shm-file)
                               0))

    (tmp-area       (common:get-db-tmp-area))
    (old2new (member 'old2new options))
    (dejunk (member 'dejunk options))
    (killservers (member 'killservers options))
    (servers (server:get-list *toppath*))
    (src-area (if old2new *toppath* tmp-area))
    (dest-area (if old2new tmp-area *toppath*))
    (dbfiles        (if old2new (glob (conc *toppath* "/.megatest/*.db")) (glob (conc tmp-area "/.megatest/*.db"))))
    (dbfiles        (if old2new (glob (conc *toppath* "/" *dbdir* "/*.db")) (glob (conc tmp-area "/" *dbdir* "/*.db"))))
    (keys (db:get-keys dbstruct))
    (sync-durations (make-hash-table)))


    (if killservers
      (begin
       	  (for-each

    )
    (for-each
     (lambda (srcfile)
       (debug:print-info 3 *default-log-port* "file: " srcfile)
       (let* ((fname (conc (pathname-file srcfile) ".db"))
              (basename (pathname-file srcfile))
              (run-id (if (string= basename "main") #f (string->number basename)))
	      (destfile (conc dest-area "/.megatest/" fname))
              (dest-directory  (conc dest-area "/.megatest/"))
	      (destfile (conc dest-area "/" *dbdir* "/" fname))
              (dest-directory  (conc dest-area "/" *dbdir* "/"))
              (dummy (debug:print-info 2 *default-log-port* "destfile = " destfile))
              (dummy2 (debug:print-info 2 *default-log-port* "dejunk = " dejunk))
              ;; TODO: time1 and time2 need to take into account -wal and -shm files
	      (time1 (file-modification-time srcfile))
              (time2 (if (file-exists? destfile)
                         (begin
                            (debug:print-info 2 *default-log-port* "destfile " destfile " exists")

		      qry)
		    qryvals)
	     (sqlite3:execute db "UPDATE runs SET state=?,status=?,event_time=strftime('%s','now') WHERE id=? AND state='deleted';" state status res)
	     res))) 
	(begin
	  (debug:print-error 0 *default-log-port* "Called without all necessary keys")
	  #f))))

;; called with run-id=#f so will operate on main.db
;;
(define (db:insert-run dbstruct run-id target runname run-meta)
  (let* ((keys (db:get-keys dbstruct))
     	 (runs (db:simple-get-runs dbstruct runname #f #f target #f))) ;; runpatt count offset target last-update
    ;; need to insert run based on target and runname
    (let* ((targvals (string-split target "/"))
	   (keystr   (string-intersperse keys ","))
	   (key?str  (string-intersperse (make-list (length targvals) "?") ","))
	   (qrystr   (conc "INSERT INTO runs (id,runname,"keystr") VALUES (?,?,"key?str")"))
	   (get-var  (lambda (db qrystr)
		       (let* ((res #f))
			 (sqlite3:for-each-row
			  (lambda row
			    (set res (car row)))
			  db qrystr run-id runname)
			 res))))
      (if (null? runs)
        (begin
	  (db:create-initial-run-record dbstruct run-id runname target)
        )
      )
      run-id)))

(define (db:create-initial-run-record dbstruct run-id runname target)	  
  (let* ((keys     (db:get-keys dbstruct))
     	 (targvals (string-split target "/"))
	 (keystr   (string-intersperse keys ","))
	 (key?str  (string-intersperse (make-list (length targvals) "?") ",")) ;; a string with the same length as targvals, where each element is "?" and interspersed with commas.
	 (qrystr   (conc "INSERT INTO runs (id,runname,"keystr") VALUES (?,?,"key?str")")))

    (db:with-db
     dbstruct #f #t ;; run-id writable
     (lambda (dbdat db)
       (apply sqlite3:execute db qrystr run-id runname targvals)))))

(define (db:insert-test dbstruct run-id test-rec)
  (let* ((testname  (alist-ref "testname" test-rec equal?))
	 (item-path (alist-ref "item_path" test-rec equal?))
	 (id        (db:get-test-id dbstruct run-id testname item-path))
	 (fieldvals (filter (lambda (x)(not (member (car x) '("id" "last_update")))) test-rec))
	 (setqry    (conc "UPDATE tests SET "(string-intersperse
					      (map (lambda (dat)
						     (conc (car dat)"=?"))
						   fieldvals)
					      ",")" WHERE id=?;"))
	 (insqry   (conc "INSERT INTO tests ("(string-intersperse (map (lambda (x) (car x)) fieldvals) ",")
			 ") VALUES ("(string-intersperse (make-list (length fieldvals) "?") ",")");")))
    ;; (debug:print 0 *default-log-port* "id: "id"\nset: "setqry"\ninsqry: "insqry)
    (db:with-db
     dbstruct
     run-id #t
     (lambda (dbdat db)
      ;; (if id
      ;;   (apply sqlite3:execute db setqry (append (map cdr fieldvals) (list id)))
	   (apply sqlite3:execute db insqry (map cdr fieldvals))
           ))))

;; replace header and keystr with a call to runs:get-std-run-fields
;;
;; keypatts: ( (KEY1 "abc%def")(KEY2 "%") )
;; runpatts: patt1,patt2 ...
;;
(define (db:get-runs dbstruct runpatt count offset keypatts)

			     (if (number? count)
				 (conc " LIMIT " count)
				 "")
			     (if (number? offset)
				 (conc " OFFSET " offset)
				 "")))
	   )
    (debug:print-info 11 *default-log-port* "db:get-runs START qrystr: " qrystr " target: " target " offset: " offset " limit: " count)
    (debug:print-info 11 *default-log-port* "db:simple-get-runs START qrystr: " qrystr " target: " target " offset: " offset " limit: " count)
    (db:with-db dbstruct #f #f
		(lambda (dbdat db)		
		  (sqlite3:for-each-row
		   (lambda (target id runname state status owner event_time)
		     (set! res (cons (make-simple-run target id runname state status owner event_time) res)))
		     (set! res (cons (make-simple-run target id runname state status owner event_time) res))
                   )
		   db
		   qrystr
		   )))
    (debug:print-info 11 *default-log-port* "db:get-runs END qrystr: " qrystr " target: " target " offset: " offset " limit: " count)
    (debug:print-info 11 *default-log-port* "db:simple-get-runs END qrystr: " qrystr " target: " target " offset: " offset " limit: " count)
    res))

;; TODO: Switch this to use max(update_time) from each run db? Then if using a server there is no disk traffic (using inmem db)
;;
;; NOTE: This DOESN'T (necessarily) get the real run ids, but the number of the <number>.db!!






 (define (db:get-changed-run-ids since-time)
  (let* ((dbdir      (db:dbfile-path)) ;; (configf:lookup *configdat* "setup" "dbdir"))
        (alldbs     (glob (conc dbdir "/.megatest/[0-9]*.db*")))
        (alldbs     (glob (conc dbdir "/" *dbdir* "/[0-9]*.db*")))
        (changed    (filter (lambda (dbfile)
                              (> (file-modification-time dbfile) since-time))
                            alldbs)))
    (delete-duplicates
     (map (lambda (dbfile)
           (let* ((res (string-match ".*\\/(\\d\\d)\\.db*" dbfile)))
             (if res

         (changed_run_dbs (db:get-changed-run-ids since-time)) ;; gets the rundb numbers
         (all_run_ids 
          (db:with-db dbstruct #f #f 
            (lambda (dbdat db)
              (sqlite3:fold-row backcons '() db "SELECT id FROM runs"))
          )
         )
         (changed_run_ids (filter (lambda (run) (member (modulo run 100) changed_run_dbs)) all_run_ids))
         (changed_run_ids (filter (lambda (run) (member (modulo run (num-run-dbs)) changed_run_dbs)) all_run_ids))
         ;; TODO: couldn't we just use changed_run_ids for run_ids?
         (run_ids 
          (db:with-db dbstruct #f #f 
            (lambda (dbdat db)
              (sqlite3:fold-row backcons '() db "SELECT id FROM runs  WHERE last_update>=?" since-time))
          )
         )

	  #f
        ))))

;; sync for filesystem local db writes
;;
(define (db:run-lock-and-sync no-sync-db)
  (let* ((tmp-area       (common:get-db-tmp-area))
	 (dbfiles        (glob (conc tmp-area"/.megatest/*.db")))
	 (dbfiles        (glob (conc tmp-area"/" *dbdir* "/*.db")))
	 (sync-durations (make-hash-table)))
    ;; (debug:print-info 0 *default-log-port* "lock-and-sync, dbfiles: "dbfiles)
    (for-each
     (lambda (file)
       (let* ((fname (conc (pathname-file file) ".db"))
	      (fulln (conc *toppath*"/.megatest/"fname))
	      (fulln (conc *toppath*"/" *dbdir* "/"fname))
	      (time1 (if (file-exists? file)
			 (file-modification-time file)
			 (begin
			   (debug:print-info 0 *default-log-port* "Sync - I do not see file "file)
			   1)))
	      (time2 (if (file-exists? fulln)
			 (file-modification-time fulln)

	ports

	commonmod
	)

;; (import debugprint)

;; Parameters

(define num-run-dbs           (make-parameter 10))

;;======================================================================
;;  R E C O R D S
;;======================================================================

;; (define-record simple-run target id runname state status owner event_time)

;; a single Megatest area with it's multiple dbs is
;; managed in a dbstruct
;;
(defstruct dbr:dbstruct
  (areapath  #f)
  (homehost  #f)
  (tmppath   #f)
  (read-only #f)
  (subdbs (make-hash-table))
  )

;; NOTE: Need one dbr:subdb per main.db, 1.db ...
;;
(defstruct dbr:subdb
  (dbname      #f) ;; .megatest/1.db
  (mtdbfile    #f) ;; mtrah/.megatest/1.db
  (dbname      #f) ;; " *dbdir* "/1.db
  (mtdbfile    #f) ;; mtrah/" *dbdir* "/1.db
  (mtdbdat     #f) ;; only need one of these for syncing
  ;; (dbdats      (make-hash-table))  ;; id => dbdat 
  (tmpdbfile   #f) ;; /tmp/.../.megatest/1.db
  ;; (refndbfile  #f) ;; /tmp/.../.megatest/1.db_ref
  (tmpdbfile   #f) ;; /tmp/.../" *dbdir* "/1.db
  ;; (refndbfile  #f) ;; /tmp/.../" *dbdir* "/1.db_ref
  (dbstack     (make-stack)) ;; stack for tmp dbr:dbdat,
  (homehost    #f) ;; not used yet
  (on-homehost #f) ;; not used yet
  (read-only   #f)
  (last-sync   0)
  (last-write  (current-seconds))
  )                ;; goal is to converge on one struct for an area but for now it is too confusing

(define *db-sync-in-progress* #f)
(define *db-with-db-mutex*    (make-mutex))
(define *max-api-process-requests* 0)
(define *api-process-request-count* 0)
(define *db-write-access*     #t)
(define *db-last-sync*        0)                 ;; last time the sync to megatest.db happened
(define *db-multi-sync-mutex* (make-mutex))      ;; protect access to *db-sync-in-progress*, *db-last-sync*
(define *dbdir* ".mtdb")

(define (db:generic-error-printout exn . message)
  (print-call-chain (current-error-port))
  (apply dbfile:print-err message)
  (dbfile:print-err
    ", error: "     ((condition-property-accessor 'exn 'message)   exn)
    ", arguments: " ((condition-property-accessor 'exn 'arguments) exn)

(define (db:dbname->path apath dbname)
  (conc apath"/"dbname))

;; POTENTIAL BUG: this implementation could produce a db file if run-id is neither #f or a number
(define (dbfile:run-id->dbname run-id)
  (cond
   ((number? run-id) (conc ".megatest/" (modulo run-id 100) ".db"))
   ((not run-id)     (conc ".megatest/main.db"))
   ((number? run-id) (conc  *dbdir* "/" (modulo run-id (num-run-dbs)) ".db"))
   ((not run-id)     (conc  *dbdir* "/main.db"))
   (else             run-id)))

;; Make the dbstruct, setup up auxillary db's and call for main db at least once
;;
;; called in http-transport and replicated in rmt.scm for *local* access. 
;;
(define (dbfile:setup do-sync areapath tmppath)

                                 (sqlite3:set-busy-handler! db (sqlite3:make-busy-timeout 30000))
				 (if sync-mode
				     (sqlite3:execute db (conc "PRAGMA synchronous = "sync-mode";")))
				 (if journal-mode
				     (sqlite3:execute db (conc "PRAGMA journal_mode = "journal-mode";")))
				 (if (and init-proc (not db-exists))
				     (init-proc db))
				 db)))
				 db))
			     expire-time: 30)
                            (begin
			      (if (file-exists? fname )
                                  (let ((db (sqlite3:open-database fname)))
				    ;; pragmas synchronous not needed because this db is used read-only
				    ;; (sqlite3:execute db (conc "PRAGMA synchronous = "mode";")
				    (sqlite3:set-busy-handler! db (sqlite3:make-busy-timeout 30000)) ;; read-only but still need timeout
				    db )
                                  (print "file doesn't exist: " fname))))
                                  (print "cautious-open-database: file doesn't exist: " fname))))
			(exn (io-error)
			     (dbfile:print-err exn "ERROR: i/o error with " fname ". Check permissions, disk space etc. and try again.")
			     (retry))
			(exn (corrupt)
			     (dbfile:print-err exn "ERROR: database " fname " is corrupt. Repair it to proceed.")
			     (retry))
			(exn (busy)

	        (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)))
		        (set! totrecords (+ totrecords 1))
                        (thread-sleep! 2)
                      )
                    )
                 )
	         (dbr:dbdat-dbh fromdb)
	         full-sel)
              )
            )

	  (thread-sleep! 0.25)
	  (if (file-exists? fname)
	      (handle-exceptions exn
                #f 
                (with-input-from-file fname
	  	  (lambda ()
		    (equal? key-string (read-line)))))
              (begin
                (dbfile:print-err "dbfile:simple-file-lock created " fname " but it was gone 0.25 seconds later")
	      #f)
	      #f
              )
          )
       )
    )
  )
)

(define (dbfile:simple-file-lock-and-wait fname #!key (expire-time 300))
  (let ((end-time (+ expire-time (current-seconds))))

	      (if (hash-table-ref/default misc-flags 'keep-going #f)  ;; keep originals for cpu-load and disk-free unless they change more than the allowed delta
		  (loop (calc-minutes)
                        (or new-cpu-load cpu-load)
                        (or new-disk-free disk-free)
                        (if do-sync (current-seconds) last-sync)))))))
    (tests:update-central-meta-info run-id test-id (get-cpu-load) (get-df (current-directory))(calc-minutes) #f #f))) ;; NOTE: Checking twice for keep-going is intentional


;; read testconfig and create .logpro and script files
;;    - use #f for tconfigreg to re-read the testconfigs from disk
;;
(define (launch:extract-scripts-logpro  test-dir test-name item-path tconfigreg-in)
  (let* ((tconfigreg      (or tconfigreg-in
			      (tests:get-all)))
	 (tconfig-fname   (conc test-dir "/.testconfig"))
	 (tconfig-tmpfile (conc tconfig-fname ".tmp"))
	 (tconfig         (tests:get-testconfig test-name item-path tconfigreg #t force-create: #t)) ;; 'return-procs)))
	 (scripts         (configf:get-section tconfig "scripts"))
	 (logpros         (configf:get-section tconfig "logpro")))
    ;; create .testconfig file
    (configf:write-alist tconfig tconfig-tmpfile)
    (file-move tconfig-tmpfile tconfig-fname #t)
    (delete-file* ".final-status")
    
    ;; extract scripts from testconfig and write them to files in test run dir
    (for-each
     (lambda (scriptdat)
       (match scriptdat
	      ((name content)
	       (debug:print-info 2 *default-log-port* "Creating script "(current-directory)"/"name)
	       (with-output-to-file name
		 (lambda ()
		   (print content)))
	       (change-file-mode name (bitwise-ior perm/irwxg perm/irwxu)))
	      (else
	       (debug:print-info 0 "Invalid script definiton found in [scripts] section of testconfig. \"" scriptdat "\""))))
     scripts)

    ;; extract logpro from testconfig and write them to files in test run dir
    (for-each
     (lambda (logprodat)
       (match logprodat
	      ((name content)
	       (debug:print-info 2 *default-log-port* "Creating logpro file "(current-directory)"/"name)
	       (with-output-to-file name
		 (lambda ()
		   (print content)
		   ;; (change-file-mode name (bitwise-ior perm/irwxg perm/irwxu))
		   )))
	      (else
	       (debug:print-info 0 "Invalid logpro definiton found in [logpro] section of testconfig. \"" logprodat "\""))))
     logpros)))

(define (launch:execute encoded-cmd)
  (let* ((cmdinfo    (common:read-encoded-string encoded-cmd))
	 (tconfigreg #f))
    (setenv "MT_CMDINFO" encoded-cmd)
    ;;(bb-check-path msg: "launch:execute incoming")
    (if (list? cmdinfo) ;; ((testpath /tmp/mrwellan/jazzmind/src/example_run/tests/sqlitespeed)

	      (list  "MT_RUNNAME"   runname)
	      (list  "MT_MEGATEST"  megatest)
	      (list  "MT_TARGET"    target)
	      (list  "MT_LINKTREE"  (common:get-linktree)) ;; (configf:lookup *configdat* "setup" "linktree"))
	      (list  "MT_TESTSUITENAME" (common:get-testsuite-name))))
          ;;(bb-check-path msg: "launch:execute post block 3")

	  (let ((tmppath (getenv "PATH")))
	    (if (string-search tmppath " ")
		(debug:print 0 *default-log-port* "WARNING: spaces in PATH are not supported."))
	  (if mt-bindir-path (setenv "PATH" (conc "\""(getenv "PATH")":"mt-bindir-path"\"")))
	    (if mt-bindir-path (setenv "PATH" (conc tmppath":"mt-bindir-path))))
          ;;(bb-check-path msg: "launch:execute post block 4")
	  ;; (change-directory top-path)
	  ;; Can setup as client for server mode now
	  ;; (client:setup)

  
	  
	  ;; environment overrides are done *before* the remaining critical envars.
	  (alist->env-vars env-ovrd)
          ;;(bb-check-path msg: "launch:execute post block 41")
	  (runs:set-megatest-env-vars run-id inkeys: keys inkeyvals: keyvals)
          ;;(bb-check-path msg: "launch:execute post block 42")
	  (set-item-env-vars itemdat)
          ;;(bb-check-path msg: "launch:execute post block 43")

	  (if (args:get-arg "-xterm")
	      (set! fullrunscript "xterm")
	      (if (and fullrunscript 
		       (common:file-exists? fullrunscript)
		       (not (file-execute-access? fullrunscript)))
		  (system (conc "chmod ug+x " fullrunscript))))
	  (launch:extract-scripts-logpro work-area test-name item-path tconfigreg)

	  ;; We are about to actually kick off the test
	  ;; so this is a good place to remove the records for 
	  ;; any previous runs
	  ;; (db:test-remove-steps db run-id testname itemdat)
	  ;; now is also a good time to write the .testconfig file
	  (let* ((tconfig-fname   (conc work-area "/.testconfig"))
		 (tconfig-tmpfile (conc tconfig-fname ".tmp"))
		 (tconfig         (tests:get-testconfig test-name item-path tconfigreg #t force-create: #t)) ;; 'return-procs)))
		 (scripts (configf:get-section tconfig "scripts")))
	    ;; create .testconfig file
	    (configf:write-alist tconfig tconfig-tmpfile)
	    (file-move tconfig-tmpfile tconfig-fname #t)
	    (delete-file* ".final-status")

	    ;; extract scripts from testconfig and write them to files in test run dir
	    (for-each
	     (lambda (scriptdat)
	       (match scriptdat
		      ((name content)
		       (with-output-to-file name
			 (lambda ()
			   (print content)
			   (change-file-mode name (bitwise-ior perm/irwxg perm/irwxu)))))
		      (else
		       (debug:print-info 0 "Invalid script definiton found in [scripts] section of testconfig. \"" scriptdat "\""))))
	     scripts))
;;;;;	  ;; We are about to actually kick off the test
;;;;;	  ;; so this is a good place to remove the records for 
;;;;;	  ;; any previous runs
;;;;;	  ;; (db:test-remove-steps db run-id testname itemdat)
;;;;;	  ;; now is also a good time to write the .testconfig file
;;;;;	  (let* ((tconfig-fname   (conc work-area "/.testconfig"))
;;;;;		 (tconfig-tmpfile (conc tconfig-fname ".tmp"))
;;;;;		 (tconfig         (tests:get-testconfig test-name item-path tconfigreg #t force-create: #t)) ;; 'return-procs)))
;;;;;		 (scripts         (configf:get-section tconfig "scripts"))
;;;;;		 (precmd          (configf:lookup tconfig )
;;;;;	    ;; create .testconfig file
;;;;;	    (configf:write-alist tconfig tconfig-tmpfile)
;;;;;	    (file-move tconfig-tmpfile tconfig-fname #t)
;;;;;	    (delete-file* ".final-status")
;;;;;
;;;;;	    ;; extract scripts from testconfig and write them to files in test run dir
;;;;;	    (for-each
;;;;;	     (lambda (scriptdat)
;;;;;	       (match scriptdat
;;;;;		      ((name content)
;;;;;		       (with-output-to-file name
;;;;;			 (lambda ()
;;;;;			   (print content)
;;;;;			   (change-file-mode name (bitwise-ior perm/irwxg perm/irwxu)))))
;;;;;		      (else
;;;;;		       (debug:print-info 0 "Invalid script definiton found in [scripts] section of testconfig. \"" scriptdat "\""))))
;;;;;	     scripts))
	  ;;

	  (let* ((m            (make-mutex))
		 (kill-job?    #f)
		 (exit-info    (make-launch:einf pid: #t exit-status: #t exit-code: #t rollup-status: 0)) ;; pid exit-status exit-code (i.e. process was successfully run) rollup-status
		 (job-thread   #f)
		 ;; (keep-going   #t)
		 (misc-flags   (let ((ht (make-hash-table)))
				 (hash-table-set! ht 'keep-going #t)
				 ht))
		 (runit        (lambda ()
				 (launch:manage-steps run-id test-id item-path fullrunscript ezsteps subrun test-name tconfigreg exit-info m)))
		 (monitorjob   (lambda ()
				 (launch:monitor-job  run-id test-id item-path fullrunscript ezsteps test-name tconfigreg exit-info m work-area runtlim misc-flags)))
		 (th1          (make-thread monitorjob "monitor job"))
		 (th2          (make-thread runit "run job"))
                 (tconfig         (tests:get-testconfig test-name item-path tconfigreg #t))
                 (propagate-exit-code (configf:lookup *configdat* "setup" "propagate-exit-code"))
                 (propagate-status-list '("FAIL" "KILLED" "ABORT" "DEAD" "CHECK" "SKIP" "WAIVED"))
                 (test-status "not set")
                 (test-status     "not set")
                 )
		 (test-state      "not set")
		 (precmd          (configf:lookup tconfig "setup" "precmd"))
		 (postcmd         (configf:lookup tconfig "setup" "postcmd")))
	    ;; first, if set, run the precmd
	    (if precmd ;; (file-exists? precmd)(file-execute-access? precmd))
		(begin
		  ;; (save-environment-as-files "precmd-envt")
		  (system precmd))) ;; up to test author to put nbfake if desired.
	    (set! job-thread th2)
	    (thread-start! th1)
	    (thread-start! th2)
	    (thread-join! th2)
	    (debug:print-info 0 *default-log-port* "Megatest execute of test " test-name ", item path " item-path " complete. Notifying the db ...")
            (debug:print-info 2 *default-log-port* "exit-info = " exit-info)
	    (hash-table-set! misc-flags 'keep-going #f)

	      (rmt:update-run-stats run-id (rmt:get-raw-run-stats run-id))) ;; end of let*

	    (mutex-unlock! m)
            (launch:end-of-run-check run-id )
	    (debug:print 2 *default-log-port* "Output from running " fullrunscript ", pid " (launch:einf-pid exit-info) " in work area " 
			 work-area ":\n====\n exit code " (launch:einf-exit-code exit-info) "\n" "====\n")


            (set! test-status (db:test-get-status (rmt:get-testinfo-state-status run-id test-id)))
	    (let* ((testrec  (rmt:get-testinfo-state-status run-id test-id)))
              (set! test-status (db:test-get-status testrec))
	      (set! test-state  (db:test-get-state  testrec)))

            ;; If the propagate-exit-code option has been set in the megatest config, and the test status matches the list, set the exit code to 1.


            (if (and propagate-exit-code (string=? propagate-exit-code "yes") (member test-status propagate-status-list))
               (begin
                (debug:print 1 *default-log-port* "Setting exit status to 1 because of test status of " test-status) 
                (set! *globalexitstatus* 1)
               )
            )

	    (if postcmd
		(begin
		  (setenv "MT_TEST_STATE" test-state)
		  (setenv "MT_TEST_STATUS" test-status)
		  ;; (save-environment-as-files "postcmd-envt")
		  (system postcmd)))
	    (if (not (launch:einf-exit-status exit-info))
		(exit 4))))
        )))

;; Spec for End of test
;; At end of each test call, after marking self as COMPLETED do run-state-status-rollup
;; At transition to run COMPLETED/X do hooks

		       runname
		       (common:file-exists? fulldir))
		  (let ((tmpfile  (conc fulldir "/.megatest.cfg." (current-seconds)))
			(targfile (conc fulldir "/.megatest.cfg-"  megatest-version "-" megatest-fossil-hash))
			(rconfig  (conc fulldir "/.runconfig." megatest-version "-" megatest-fossil-hash)))
		    (if (common:file-exists? rconfig) ;; only cache megatest.config AFTER runconfigs has been cached
			(begin
			  (debug:print-info 0 *default-log-port* "Caching megatest.config in " tmpfile)
			  (debug:print-info 2 *default-log-port* "Caching megatest.config in " tmpfile)
                          (if (not (common:in-running-test?))
                              (configf:write-alist *configdat* tmpfile))
			  (system (conc "ln -sf " tmpfile " " targfile))))
		    )))
	    (debug:print-info 1 *default-log-port* "No linktree yet, no caching configs.")))))

;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.

;; Always use two or four digit decimal
;; 1.01, 1.02...1.10,1.11,1.1101 ... 1.99,2.00..

;; (declare (unit megatest-version))

(define megatest-version 1.7014)
(define megatest-version 1.7103)

(dbfile:db-init-proc db:initialize-main-db)

;; load the ~/.megatestrc file, put (use trace)(trace-call-sites #t)(trace function-you-want-to-trace) in this file
;;
(let ((debugcontrolf (conc (get-environment-variable "HOME") "/.megatestrc")))
  (if (common:file-exists? debugcontrolf)
    (begin
      ;; for some reason, debug:print does not work here. Had to use print.
      (with-output-to-port (current-error-port)
	(lambda ()
	  (print (conc "WARNING: loading " debugcontrolf))))
      (load debugcontrolf)))
      (load debugcontrolf)
    )
  )
)

;; usage logging, careful with this, it is not designed to deal with all real world challenges!
;;
(if (and *usage-log-file*
         (file-write-access? *usage-log-file*))
    (with-output-to-file
        *usage-log-file*

  -test-paths             : get the test paths matching target, runname, item and test
                            patterns.
  -list-disks             : list the disks available for storing runs
  -list-targets           : list the targets in runconfigs.config
  -list-db-targets        : list the target combinations used in the db
  -show-config            : dump the internal representation of the megatest.config file
  -show-runconfig         : dump the internal representation of the runconfigs.config file
  -dumpmode MODE          : dump in MODE format instead of sexpr, MODE=json,ini,sexp etc. (add -debug 0,9 to see which file contributes each line)
  -dumpmode MODE          : dump in MODE format instead of sexpr, MODE=json,ini,sexpr etc. (add -debug 0,9 to see which file contributes each line)
  -show-cmdinfo           : dump the command info for a test (run in test environment)
  -section sectionName
  -var varName            : for config and runconfig lookup value for sectionName varName
  -since N                : get list of runs changed since time N (Unix seconds)
  -fields fieldspec       : fields to include in json dump; runs:id,runame+tests:testname+steps
  -sort fieldname         : in -list-runs sort tests by this field
  -testdata-csv [categorypatt/]varpatt  : dump testdata for given category

  -load file.scm          : load and run file.scm
  -mark-incompletes       : find and mark incomplete tests
  -ping run-id|host:port  : ping server, exit with 0 if found
  -debug N|N,M,O...       : enable debug 0-N or N and M and O ...
  -debug-noprop N|M,M,O...: enable debug but do not propagate to subprocesses via MT_DEBUG
  -config fname           : override the megatest.config file with fname
  -append-config fname    : append fname to the megatest.config file
  -import-sexpr fname     : import a sexpr file (use -list-runs % -dumpmode sexpr to create)
  -regen-testfiles        : regenerate scripts and logpro files from testconfig, run in test context

  
Utilities
  -env2file fname         : write the environment to fname.csh and fname.sh
  -envcap a               : save current variables labeled as context 'a' in file envdat.db
  -envdelta a-b           : output enviroment delta from context a to context b to -o fname
                            set the output mode with -dumpmode csh, bash or ini
                            note: ini format will use calls to use curr and minimize path
  -refdb2dat refdb        : convert refdb to sexp or to format specified by s-dumpmode
  -refdb2dat refdb        : convert refdb to sexpr or to format specified by -dumpmode
                            formats: perl, ruby, sqlite3, csv (for csv the -o param
                            will substitute %s for the sheet name in generating 
                            multiple sheets)
  -o                      : output file for refdb2dat (defaults to stdout)
  -archive cmd            : archive runs specified by selectors to one of disks specified
                            in the [archive-disks] section.
                            cmd: keep-html, restore, save, save-remove, get, replicate-db (use 

			"-extract-ods"
			"-pathmod"
			"-env2file"
			"-envcap"
			"-envdelta"
			"-setvars"
			"-set-state-status"
			"-import-sexpr"

                        ;; move runs stuff here
                        "-remove-keep"           
			"-set-run-status"
			"-age"

			;; archive 

                        "-run-wait"      ;; wait on a run to complete (i.e. no RUNNING)
			"-one-pass"      ;;
			"-local"         ;; run some commands using local db access
			"-generate-html"
			"-generate-html-structure" 
			"-list-run-time"
                        "-list-test-time"
			"-regen-testfiles"
			
			;; misc queries
			"-list-disks"
			"-list-targets"
			"-list-db-targets"
			"-show-runconfig"
			"-show-config"

	       (args:get-arg "-var"))
	  (let ((val (or (configf:lookup data (args:get-arg "-section")(args:get-arg "-var"))
			 (configf:lookup data "default" (args:get-arg "-var")))))
	    (if val (print val))))
	 ((or (not (args:get-arg "-dumpmode"))
              (string=? (args:get-arg "-dumpmode") "ini"))
	  (configf:config->ini data))
	 ((string=? (args:get-arg "-dumpmode") "sexp")
	 ((string=? (args:get-arg "-dumpmode") "sexpr")
	  (pp (hash-table->alist data)))
	 ((string=? (args:get-arg "-dumpmode") "json")
	  (json-write data))
	 (else
	  (debug:print-error 0 *default-log-port* "-dumpmode of " (args:get-arg "-dumpmode") " not recognised")))
	(set! *didsomething* #t))
      (pop-directory)))

       ((and (args:get-arg "-section")
	     (args:get-arg "-var"))
	(let ((val (configf:lookup data (args:get-arg "-section")(args:get-arg "-var"))))
	  (if val (print val))))

       ;; print just a section if only -section

       ((equal? (args:get-arg "-dumpmode") "sexp")
       ((equal? (args:get-arg "-dumpmode") "sexpr")
	(pp (hash-table->alist data)))
       ((equal? (args:get-arg "-dumpmode") "json")
	(json-write data))
       ((or (not (args:get-arg "-dumpmode"))
	    (string=? (args:get-arg "-dumpmode") "ini"))
	(configf:config->ini data))
       (else

     (else
      (if (not (car *configinfo*))
	  (begin
	    (debug:print-error 0 *default-log-port* "Attempted " action "on test(s) but run area config file not found")
	    (exit 1))
	  ;; put test parameters into convenient variables
	  (begin
	    ;; check for correct version, exit with message if not correct
	    (common:exit-on-version-changed)
	    (runs:operate-on  action
			      target
			      runname
			      testpatt
			      state:  (common:args-get-state)
			      status: (common:args-get-status)
			      new-state-status: (args:get-arg "-set-state-status")

	       (tests-spec  (let ((t (alist-ref "tests" fields-spec equal?)))
			      (if (and t (null? t)) ;; all fields
				  db:test-record-fields
				  t)))
	       (adj-tests-spec (delete-duplicates (if tests-spec (cons "id" tests-spec) db:test-record-fields))) ;; '("id"))))
	       (steps-spec  (alist-ref "steps" fields-spec equal?))
	       (test-field-index (make-hash-table)))
	  (if (and (args:get-arg "-dumpmode")
		   (not (member (args:get-arg "-dumpmode") '("sexpr" "json" "ods" "list"))))
	      (begin
		(debug:print 0 *default-log-port* "ERROR: dumpmode "(args:get-arg "-dumpmode")" not recognised. Use sexpr, json, ods or list")
		(exit)))
	  (if (and tests-spec (not (null? tests-spec))) ;; do some validation and processing of the test-spec
	      (let ((invalid-tests-spec (filter (lambda (x)(not (member x db:test-record-fields))) tests-spec)))
		(if (null? invalid-tests-spec)
		    ;; generate the lookup map test-field-name => index-number
		    (let loop ((hed (car adj-tests-spec))
			       (tal (cdr adj-tests-spec))
			       (idx 0))

			;; (mutils:hierhash-set! data (db:get-value-by-header run header "status")     targetstr runname "meta" "status"     )
			;; (mutils:hierhash-set! data (db:get-value-by-header run header "state")      targetstr runname "meta" "state"      )
			;; (mutils:hierhash-set! data (conc (db:get-value-by-header run header "id"))  targetstr runname "meta" "id"         )
			;; (mutils:hierhash-set! data (db:get-value-by-header run header "event_time") targetstr runname "meta" "event_time" )
			;; (mutils:hierhash-set! data (db:get-value-by-header run header "comment")    targetstr runname "meta" "comment"    )
			;; ;; add last entry twice - seems to be a bug in hierhash?
			;; (mutils:hierhash-set! data (db:get-value-by-header run header "comment")    targetstr runname "meta" "comment"    )
		       (else
			(if (null? runs-spec)
                        ((#f list)
			 (if (null? runs-spec)
			    (print "Run: " targetstr "/" runname 
				   " status: " (db:get-value-by-header run header "state")
				   " run-id: " run-id ", number tests: " (length tests)
				   " event_time: " (db:get-value-by-header run header "event_time"))
			    (begin
			      (if (not (member "target" runs-spec))
			          ;; (display (conc "Target: " targetstr))
			          (display (conc "Run: " targetstr "/" runname " ")))
			      (for-each
			       (lambda (field-name)
				 (if (equal? field-name "target")
				     (display (conc "target: " targetstr " "))
				     (display (conc field-name ": " (db:get-value-by-header run header (conc field-name)) " "))))
			       runs-spec)
			      (newline)))))
			      (newline))))
		       (else
			(debug:print 0 *default-log-port* "ERROR: dumpmode "(args:get-arg "-dumpmode")" not recognised. Use sexpr, json, ods or list")
			))
		       
		     (for-each 
		      (lambda (test)
		      	(common:debug-handle-exceptions #f
			 exn
			 (begin
			   (debug:print-error 0 *default-log-port* "Bad data in test record? " test)

	   (let* ((db       #f)
		  ;; DO NOT run remote
		  (paths    (tests:test-get-paths-matching keys target (args:get-arg "-test-files"))))
	     (for-each (lambda (path)
			 (print path))
		       paths))))))

;;======================================================================
;; Utils for test areas
;;======================================================================

(if (args:get-arg "-regen-testfiles")
    (if (getenv "MT_TEST_RUN_DIR")
	(begin
	  (launch:setup)
	  (change-directory (getenv "MT_TEST_RUN_DIR"))
	  (let* ((testname (getenv "MT_TEST_NAME"))
		 (itempath (getenv "MT_ITEMPATH")))
	    (launch:extract-scripts-logpro (getenv "MT_TEST_RUN_DIR") testname itempath #f))
	  (set! *didsomething* #t))
	(debug:print 0 *default-log-port* "ERROR: Must run -regen-testfiles in a test environment (i.e. test xterm from dashboard)")))
		 	  
;;======================================================================
;; Archive tests
;;======================================================================
;; Archive tests matching target, runname, and testpatt
(if (equal? (args:get-arg "-archive") "replicate-db")
    (begin
          ;; check if source

       (db:setup #f)
       'killservers
       'dejunk
       'adj-testids
       'old2new
       )
      (set! *didsomething* #t)))

(if (args:get-arg "-import-sexpr")
   (begin
   (launch:setup)
   (rmt:import-sexpr (args:get-arg "-import-sexpr"))
   (set! *didsomething* #t)))

(when (args:get-arg "-sync-brute-force")
  (launch:setup)
  ((server:get-bruteforce-syncer (db:setup #t) persist-until-sync: #t))
  (set! *didsomething* #t))

(if (args:get-arg "-sync-to-megatest.db")

(declare (unit portlogger))
(declare (uses db))

;; lsof -i

(define (portlogger:open-db fname)
  (let* ((avail    (tasks:wait-on-journal fname 5 remove: #t)) ;; wait up to about 10 seconds for the journal to go away
  (let* (;; (avail    (tasks:wait-on-journal fname 5 remove: #t)) ;; wait up to about 10 seconds for the journal to go away
         (avail #t)
	 (exists   (common:file-exists? fname))
	 (db       (if avail 
		       (sqlite3:open-database fname)
		       (begin
			 (system (conc "rm -f " fname))
			 (sqlite3:open-database fname))))
	 (handler  (sqlite3:make-busy-timeout 136000))

            port INTEGER PRIMARY KEY,
            state TEXT DEFAULT 'not-used',
            fail_count INTEGER DEFAULT 0,
            update_time TIMESTAMP DEFAULT (strftime('%s','now')) );")
    db))

(define (portlogger:open-run-close proc . params)
  (let* ((fname  (conc "/tmp/." (current-user-name) "-portlogger.db"))
	 (avail  (tasks:wait-on-journal fname 10))) ;; wait up to about 10 seconds for the journal to go away
  (let* ((fname  (conc "/tmp/." (current-user-name) "-portlogger.db")))
	 ;; (avail  (tasks:wait-on-journal fname 10))) ;; wait up to about 10 seconds for the journal to go away
    (handle-exceptions
     exn
     (begin
       ;; (release-dot-lock fname)
       (debug:print-error 0 *default-log-port* "portlogger:open-run-close failed. " proc " " params)
       (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-info 13 *default-log-port* "rmt:send-receive, case  9. conninfo=" conninfo " dat=" dat " runremote = " runremote)
    (mutex-unlock! *rmt-mutex*)
    (if success ;; success only tells us that the transport was
	;; successful, have to examine the data to see if
	;; there was a detected issue at the other end
	(extras-transport-succeded *default-log-port* *rmt-mutex* attemptnum runremote res params rid cmd)
	(begin
           (debug:print-error 0 *default-log-port* " dat=" dat) 
           (debug:print-info 0 *default-log-port* "Bad return data from Megatest server: dat=" dat) 
           (extras-transport-failed *default-log-port* *rmt-mutex* attemptnum runremote cmd rid params))
	)))

(define (rmt:print-db-stats)
  (let ((fmtstr "~40a~7-d~9-d~20,2-f")) ;; "~20,2-f"
    (debug:print 18 *default-log-port* "DB Stats\n========")
    (debug:print 18 *default-log-port* (format #f "~40a~8a~10a~10a" "Cmd" "Count" "TotTime" "Avg"))

      res)) ;; All good, return res

#;(set-functions rmt:send-receive                       remote-server-url-set!
	       http-transport:close-connections	      remote-conndat-set!
	       debug:print                            debug:print-info
	       remote-ro-mode                         remote-ro-mode-set!
	       remote-ro-mode-checked-set!            remote-ro-mode-checked)


;;======================================================================
;; import an sexpr file into the db
;;======================================================================

(define (rmt:import-sexpr sexpr-file)
  (if (file-exists? sexpr-file)
      (let* ((data (with-input-from-file sexpr-file read)))
	(for-each
	 (lambda (targ-dat)
	   (rmt:import-target targ-dat)) ;; ("target" ("run1" ("data" (1 ("field" . "value") ...
	 data))
      (let* ((msg (conc "ERROR: file "sexpr-file" not found")))
	(debug:print 0 *default-log-port* msg)
	(cons #f msg))))

(define (rmt:import-target targ-dat)
  (let* ((target (car targ-dat))
	 (data   (cdr targ-dat)))
    (for-each
     (lambda (run-dat)
       (rmt:import-run target run-dat)) ;; ("runname" ("data" ("testid" ("field" . "value") ...
     data)))

(define (rmt:import-run target run-dat)
  (let* ((runname    (car run-dat))
	 (all-dat    (cdr run-dat))
	 (tests-data (alist-ref "data" all-dat equal?))
	 (run-meta   (alist-ref "meta" all-dat equal?))
         (run-id     (string->number (alist-ref "id"   run-meta equal?))))
    (rmt:insert-run run-id target runname run-meta)
    (if (list? tests-data)
      (begin
        (debug:print 0 *default-log-port* "Inserting " (length tests-data) " tests in run " runname)
        (for-each
          (lambda (test-dat)
            (let* ((test-id  (car test-dat))
	      (test-rec (cdr test-dat)))
	      (rmt:insert-test run-id test-rec)))
         tests-data)
      )
      (debug:print 0 *default-log-port* "rmt:import-run: tests-data is empty")
    )
  )
)

;; insert run if not there, return id either way
(define (rmt:insert-run run-id target runname run-meta)
  ;; look for id, return if found
  (let* ((runs (rmt:send-receive 'simple-get-runs #f
				    ;;    runpatt count offset target last-update)
				    (list runname #f    #f     target #f))))
    (if (null? runs)
       (begin
        (debug:print 0 *default-log-port* "inserting run for runname " runname " target " target)
	(rmt:send-receive 'insert-run #f (list run-id target runname run-meta))
       )
       (begin
	(simple-run-id (car runs))
       ))))


(define (rmt:insert-test run-id test-rec)
  (let* ((testname  (alist-ref "testname" test-rec equal?))
	 (item-path (alist-ref "item_path" test-rec equal?))
         (test-id (rmt:get-test-id run-id testname item-path))
         )

    (if test-id
       (debug:print 0 *default-log-port* "test "testname"/"item-path " already exists in run-id " run-id)
       (begin
         (rmt:send-receive 'insert-test run-id test-rec)
       )
    )
  )
)

    (if (not (null? required-tests))
	(debug:print-info 1 *default-log-port* "Adding \"" (string-intersperse required-tests " ") "\" to the run queue"))
    ;; NOTE: these are all parent tests, items are not expanded yet.
    (debug:print-info 4 *default-log-port* "test-records=" (hash-table->alist test-records))
    (let ((reglen (configf:lookup *configdat* "setup" "runqueue")))
      (if (> (length (hash-table-keys test-records)) 0)
	  (let* ((keep-going        #t)
	  (let* ()
		 (run-queue-retries 5)
		;; (th1        (make-thread (lambda ()
		;; 			    (handle-exceptions
		;; 				exn
		;; 				(begin
		;; 				  (print-call-chain)
		;; 				  (print " message: " ((condition-property-accessor 'exn 'message) exn)))
		;; 			      (runs:run-tests-queue run-id runname test-records keyvals flags test-patts required-tests
		;; 						    (any->number reglen) all-tests-registry)))
		;; 			  "runs:run-tests-queue"))
		 (th2        (make-thread (lambda ()			 ;; BBQ: why are we visiting ALL runs here?	    
					    ;; (rmt:find-and-mark-incomplete-all-runs))))) CAN'T INTERRUPT IT ...
					    (let ((run-ids (rmt:get-all-run-ids)))
					      (for-each (lambda (run-id)
							  (if keep-going
							      (handle-exceptions
							       exn
							       (debug:print 0 *default-log-port* "error in calling find-and-mark-incomplete for run-id " run-id ", exn=" exn)
							       (rmt:find-and-mark-incomplete run-id #f)))) ;; ovr-deadtime))) ;; could be root of https://hsdes.intel.com/appstore/article/#/220546828/main -- Title: Megatest jobs show DEAD even though they are still running (1.64/27)
							run-ids)))
					  "runs: mark-incompletes")))
	    ;; (thread-start! th1)
	    (thread-start! th2)
	    ;; (thread-join! th1)
	    ;; just do the main stuff in the main thread
	    (runs:run-tests-queue run-id runname test-records keyvals flags test-patts required-tests
								    (any->number reglen) all-tests-registry)
	    (set! keep-going #f)
	    (thread-join! th2)
	    ;; if run-count > 0 call, set -preclean and -rerun STUCK/DEAD
	    (if (> run-count 0) ;; handle reruns
		(begin
		  (if (not (hash-table-ref/default flags "-preclean" #f))
		      (hash-table-set! flags "-preclean" #t))
		  (if (not (hash-table-ref/default flags "-rerun" #f))
		      (hash-table-set! flags "-rerun" "ABORT,STUCK/DEAD,n/a,ZERO_ITEMS"))
		  ;; recursive call to self
      (runs:run-tests target runname test-patts user flags run-count: (- run-count 1)))
                  (launch:end-of-run-check run-id)))
                  (runs:run-tests target runname test-patts user flags run-count: (- run-count 1)))
                 (launch:end-of-run-check run-id)))
	  (debug:print-info 0 *default-log-port* "No tests to run")))
    (debug:print-info 4 *default-log-port* "All done by here")
    ;; TODO: try putting post hook call here
      
    ;  (debug:print-info 2 *default-log-port* " run-count " run-count)
    ;  (runs:run-post-hook run-id))
    ;  (debug:print-info 2 *default-log-port* "Not calling post hook runcount = " run-count ))   

		      (if (eq? nth-try 'removed) ;; removed is removed - drop it NOW
			  (if (null? tal)
			      #f ;; yes, really
			      (list (car tal)(cdr tal) reg reruns))
			  (begin
			    (if (runs:lownoise (conc "FAILED prerequisites or other issue" hed) 60)
				(debug:print 0 *default-log-port* "WARNING: test " hed " has FAILED prerequisites or other issue. Internal state >" nth-try "< will be overridden and we'll retry."))
			    (let* ((test-id      (rmt:get-test-id run-id testname item-path))
				   (test-info    (rmt:get-testinfo-state-status run-id test-id)) ;; we need *current* info
				   (status       (db:test-status test-info)))
			    ;; was: (mt:test-set-state-status-by-testname run-id test-name item-path "NOT_STARTED" "KEEP_TRYING" #f)
                            (mt:test-set-state-status-by-testname-unless-completed run-id test-name item-path "COMPLETED" "PREQ_FAIL" #f)
			      (if (equal? status "KEEP_TRYING")
				  (mt:test-set-state-status-by-testname-unless-completed run-id test-name item-path "COMPLETED" "PREQ_FAIL" #f)
				  (mt:test-set-state-status-by-testname run-id test-name item-path "NOT_STARTED" "KEEP_TRYING" #f)))
			    (hash-table-set! test-registry hed 'removed) ;; was 0
                            (if (not (and (null? reg) (null? tal)))
                                (runs:loop-values tal reg reglen regfull reruns)
                                #f))))
		     (else
		      (if (runs:lownoise (conc "FAILED prerequitests and we tried" hed) 60)
			  (debug:print 0 *default-log-port* "WARNING: test " hed " has FAILED prerequitests and we've tried at least 10 times to run it. Giving up now."))

    ;; Here is where the test_meta table is best updated
    ;; Yes, another use of a global for caching. Need a better way?
    ;;
    ;; There is now a single call to runs:update-all-test_meta and this 
    ;; per-test call is not needed. Given the delicacy of the move to 
    ;; v1.55 this code is being left in place for the time being.
    ;;
    (if (not (hash-table-ref/default *test-meta-updated* test-name #f))
    (if (not (hash-table-exists? *test-meta-updated* test-name))
        (begin
          (hash-table-set! *test-meta-updated* test-name #t)
          (runs:update-test_meta test-name test-conf)))
    
    ;; itemdat => ((ripeness "overripe") (temperature "cool") (season "summer"))
    (let* ((new-test-path (string-intersperse (cons test-path (map cadr itemdat)) "/"))
	   (test-id       (rmt:get-test-id run-id test-name item-path))

	 (state-status (if (string? new-state-status) (string-split new-state-status ",") '(#f #f)))
	 (rp-mutex     (make-mutex))
	 (bup-mutex    (make-mutex))
         (keep-records (args:get-arg "-keep-records")) ;; used in conjunction with -remove-runs to keep the records, TODO: consolidate this with "mode".
	 (test-records '())) ;; for tasks that we wish to operate on all tests in one fell swoop

    (let* ((write-access-actions '(remove-runs set-state-status archive run-wait kill-runs))
           (dbfile             (conc  *toppath* "/.megatest/main.db"))
           (dbfile             (conc  *toppath* "/" *dbdir* "/main.db"))
           (readonly-mode      (not (file-write-access? dbfile))))
      (when (and readonly-mode
                 (member action write-access-actions))
        (debug:print-error 0 *default-log-port* dbfile " is readonly.  Cannot proceed with action ["action"] in which write-access isrequired .")
        (exit 1)))
    
    (debug:print-info 4 *default-log-port* "runs:operate-on => Header: " header " action: " action " new-state-status: " new-state-status)

     (lambda (key)
       (let* ((idx (cadr key))
	      (fld (car  key))
	      (val (configf:lookup test-conf "test_meta" fld)))
	 ;; (debug:print 5 *default-log-port* "idx: " idx " fld: " fld " val: " val)
	 (if (and val (not (equal? (vector-ref currrecord idx) val)))
	     (begin
	       (debug:print 0 *default-log-port* "Updating " test-name " " fld " to " val)
	       (debug:print 2 *default-log-port* "Updating " test-name " " fld " to " val)
	       (rmt:testmeta-update-field test-name fld val)))))
     '(("author" 2)("owner" 3)("description" 4)("reviewed" 5)("tags" 9)("jobgroup" 10)))))

;; find tests with matching tags, tagpatt is a string "tagpatt1,tagpatt2%, ..."
;;
(define (runs:get-tests-matching-tags tagpatt)
  (let* ((tagdata (rmt:get-tests-tags))

		      (with-output-to-file start-flag (lambda () (print server-key)))
		      (thread-sleep! 0.25)
		      (set! new-server-key (with-input-from-file start-flag (lambda () (read-line))))
		      (equal? server-key new-server-key)))
	       #t
               ;; If either of the above conditions is not true, print a "Gating server start" message, wait <idle-time> + 1, then call this function recursively. 
	       (begin
		 (debug:print-info 0 *default-log-port* "Gating server start, last start: "
		 (debug:print-info 2 *default-log-port* "Gating server start, last start: "
				   (seconds->time-string fmodtime) ", time since last start: " delta ", required idletime: " idletime ", gating reason:" (if old-enough "another job started a server" "too soon to start another server"))
		 
		 (thread-sleep! ( + 1 idletime))
		 (server:wait-for-server-start-last-flag areapath)))))))


        

		(if (and tcfg cache-file) (hash-table-set! tcfg "have fulldata" #t)) ;; mark this as fully read data
		(if tcfg (hash-table-set! *testconfigs* test-full-name tcfg))
		(if (and testexists
			 cache-file
			 (file-write-access? cache-path)
			 allow-write-cache)
		    (let ((tpath (conc cache-path "/.testconfig")))
		      (debug:print-info 1 *default-log-port* "Caching testconfig for " test-name " in " tpath)
		      (debug:print-info 2 *default-log-port* "Caching testconfig for " test-name " in " tpath)
                      (if (and tcfg (not (common:in-running-test?)))
                          (configf:write-alist tcfg tpath))))
		tcfg))))))
  
;; sort tests by priority and waiton
;; Move test specific stuff to a test unit FIXME one of these days
(define (tests:sort-by-priority-and-waiton test-records)

#!/bin/bash

if [ -z "megatest.config" ]; then
    echo "The file 'megatest.config' does not exist. This must be run in a megatest area."
    exit 1
fi
if [ -d ".mtdb" ]; then
    echo "The .mtdb directory already exists. Will not do the conversion"
    exit 1
fi
if [ -d ".megatest" ]; then
    echo "Found a .megatest directory. Will convert from megatest 1.70 to 1.71/1.80 format"
    /p/foundry/env/pkgs/megatest/1.70/16/bin/megatest -list-runs % -dumpmode sexpr > data.sexpr
else 
    if [ -f "megatest.db" ]; then
        echo "Found megatest.db. Will convert from megatest 1.65 to 1.71/1.80 format"
        /p/foundry/env/pkgs/megatest/1.65/92/bin/megatest -list-runs % -dumpmode sexpr > data.sexpr
    else
        echo "Did not find .megatest or megatest.db. Cannot do the conversion"
        exit 1
    fi
fi
which megatest
megatest -import-sexpr data.sexpr