Megatest

;; extract index number given a header/data structure
(define (db:get-index-by-header header field)
  (list-index (lambda (x)(equal? x field)) header))

;; look up values in a header/data structure
(define (db:get-value-by-header row header field)
  (let ((len (vector-length row)))
    (if (or (null? header) (not row))
	#f
	(let loop ((hed (car header))
		   (tal (cdr header))
		   (n   0))
	  (if (equal? hed field)
	      (handle-exceptions
	       exn
	       (begin
		 (debug:print 0 *default-log-port* "WARNING: attempt to read non-existant field, row="
			      row " header=" header " field=" field ", exn=" exn)
		 #f)
	       (if (>= n len)
		   #f
		   (vector-ref row n)))
	      (if (null? tal) #f (loop (car tal)(cdr tal)(+ n 1))))))))

;; Accessors for the header/data structure
;; get rows and header from 
(define (db:get-header vec)(vector-ref vec 0))
(define (db:get-rows   vec)(vector-ref vec 1))

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

         (if (and test-id state status (equal? status "AUTO")) 
             (db:test-data-rollup dbstruct run-id test-id status))
	 (if new-state-eh ;; moved from db:test-set-state-status
	      (mt:process-triggers dbstruct run-id test-id new-state-eh new-status-eh))
         tr-res)))))

(define (db:roll-up-rules state-status-counts state status)
  (if (null? state-status-counts)
      '(#f #f)
      (let* ((running     (length (filter (lambda (x)
					    (member (dbr:counts-state x) *common:running-states*))
					  state-status-counts)))
	     (bad-not-started      (length (filter (lambda (x)
						     (and (equal? (dbr:counts-state x) "NOT_STARTED") 
							  (not (member (dbr:counts-status x)  *common:not-started-ok-statuses*))))
						   state-status-counts)))
	     (all-curr-states      (common:special-sort  ;; worst -> best (sort of)
				    (delete-duplicates
				     (if (and state (not (member state *common:dont-roll-up-states*)))
					 (cons state (map dbr:counts-state state-status-counts))
					 (map dbr:counts-state state-status-counts)))
				    *common:std-states* >))
	     (all-curr-statuses    (common:special-sort  ;; worst -> best
				    (delete-duplicates
				     (if (and state status (not (member state *common:dont-roll-up-states*)))
					 (cons status (map dbr:counts-status state-status-counts))
					 (map dbr:counts-status state-status-counts)))
				    *common:std-statuses* >))
	     (non-completes        (filter (lambda (x)
					     (not (member x (cons "COMPLETED" *common:dont-roll-up-states*))))
					   all-curr-states))
	     (preq-fails        (filter (lambda (x)
					  (equal? x "PREQ_FAIL"))
					all-curr-statuses))
	     (num-non-completes (length non-completes))
	     (newstate          (cond
				 ((> running 0)           "RUNNING")            ;; anything running, call the situation running
				 ((> (length preq-fails) 0) "NOT_STARTED")
				 ((> bad-not-started 0)   "COMPLETED")          ;; we have an ugly situation, it is completed in the sense we cannot do more.
				 ((> num-non-completes 0) (car non-completes))  ;;  (remove (lambda (x)(equal? "COMPLETED" x)) all-curr-states))) ;; only rollup DELETED if all DELETED
				 (else                    (car all-curr-states))))
	     (newstatus         (cond
				 ((> (length preq-fails) 0)  "PREQ_FAIL")
				 ((or (> bad-not-started 0)
				      (and (equal? newstate "NOT_STARTED")
					   (> num-non-completes 0)))
				  "STARTED")
				 (else (car all-curr-statuses)))))
	(debug:print-info 2 *default-log-port*
			  "\n--> probe db:set-state-status-and-roll-up-items: "
			  "\n--> state-status-counts: "(map dbr:counts->alist state-status-counts)
			  "\n--> running:             "running
			  "\n--> bad-not-started:     "bad-not-started
			  "\n--> non-non-completes:   "num-non-completes
			  "\n--> non-completes:       "non-completes
			  "\n--> all-curr-states:     "all-curr-states
			  "\n--> all-curr-statuses:     "all-curr-statuses
			  "\n--> newstate              "newstate
			  "\n--> newstatus            "newstatus
			  "\n\n")
	
	;; NB// Pass the db so it is part of the transaction
	(list newstate newstatus))))

(define (db:set-state-status-and-roll-up-run dbstruct run-id curr-state curr-status)
    (mutex-lock! *db-transaction-mutex*)
    (db:with-db
     dbstruct run-id #f
     (lambda (dbdat db)
       (let ((tr-res

(define (dbfile:brute-force-salvage-db fname)
  (let* ((backupfname (conc fname"-"(current-process-id)".bak"))
	 (cmd (conc "cp "fname" "backupfname";mv "fname" "(conc fname ".delme;")
		    "cp "backupfname" "fname)))
    (dbfile:print-err "WARNING: attempting recovery of file "fname" by running commands:\n"
		      "  "cmd)
    (system cmd)))

;; opens and returns handle and nothing else
;;
(define (dbfile:raw-open-no-sync-db dbpath)



  (if (not (file-exists? dbpath))
      (create-directory dbpath #t))
  (let* ((dbname    (conc dbpath "/no-sync.db"))
	 (db-exists (file-exists? dbname))
	 (init-proc (lambda (db)
		      (if (not db-exists)
			  (begin
			    (sqlite3:execute db "CREATE TABLE IF NOT EXISTS no_sync_metadat (var TEXT,val TEXT, CONSTRAINT no_sync_metadat_constraint UNIQUE (var));"))
			  )))
	 (on-tmp      (equal? (car (string-split dbpath "/")) "tmp"))
	 (db        (if on-tmp
			(dbfile:cautious-open-database dbname init-proc 0 "WAL")
			(dbfile:cautious-open-database dbname init-proc 0 #f)
			;; (sqlite3:open-database dbname)
			)))
    (if on-tmp	      ;; done in cautious-open-database
	(begin
	  (sqlite3:execute db "PRAGMA synchronous = 0;")
	  (sqlite3:set-busy-handler! db (sqlite3:make-busy-timeout 136000))))
    db))

(define (dbfile:with-no-sync-db dbpath proc)
  (let* ((db  (dbfile:raw-open-no-sync-db dbpath))
	 (res (proc db)))
    (sqlite3:finalize! db)
    res))

(define (dbfile:open-no-sync-db dbpath)
  (if *no-sync-db*
      *no-sync-db*
      (let* ((db (dbfile:raw-open-no-sync-db dbpath)))
	(set! *no-sync-db* db)
	db)))

(define (db:no-sync-set db var val)
  (sqlite3:execute db "INSERT OR REPLACE INTO no_sync_metadat (var,val) VALUES (?,?);" var val))

(define (db:no-sync-del! db var)
  (sqlite3:execute db "DELETE FROM no_sync_metadat WHERE var=?;" var))

     (conc "SELECT name FROM pragma_table_info('"tablename"') as tblInfo;"))
    has-last))

;; tbls is ( ("tablename" ( "field1" [#f|proc1] ) ( "field2" [#f|proc2] ) .... ) )
;;
;; direction = fromdest, todest
;; mode = 'full, 'incr
;;
;; Idea: youngest in dest is last_update time
;;
(define (dbmod:attach-sync tables dbh destdbfile direction #!key
			   (mode 'full)
			   (no-update '("keys")) ;; do
			   )
  (debug:print 0 *default-log-port* "Doing sync "direction" "destdbfile)
  (if (not (sqlite3:auto-committing? dbh))

    ))

(define (tt:keep-running ttdat dbfname dbstruct)
  ;; verfiy conn for ready
  ;; listener socket has been started by this stage
  ;; wait for a port before creating the registration file
  ;;
  (let* ((db-locked-in #f)
	 (areapath     (tt-areapath ttdat))
	 (nosyncdbpath (conc areapath"/.megatest"))
	 (cleanup (lambda ()
		    (if (tt-cleanup-proc ttdat)
			((tt-cleanup-proc ttdat)))
		    (dbfile:with-no-sync-db nosyncdbpath
					    (lambda (db)
					      (db:no-sync-del! db dbfname))))))
    (let loop ((count 0))
      (if (> count 240)
	  (begin
	    (debug:print 0 *default-log-port* "FATAL: Could not start a tcp server, giving up.")
	    (exit 1))
	  (if (not (tt-port ttdat)) ;; no connection yet
	      (begin

    (let loop ()
      (let* ((servers (tt:get-server-info-sorted ttdat dbfname))
	     (ok      (cond
		       ((null? servers) #f) ;; not ok
		       ((equal? (list-ref (car servers) 6) ;; compare the servinfofile
				(tt-servinf-file ttdat))
			(debug:print-info 0 *default-log-port* "Keep running, I'm the top server.")
			(if db-locked-in
			    #t
			    (let* ((lockinfo  (dbfile:with-no-sync-db nosyncdbpath
								      (lambda (db)
									(db:no-sync-get-lock db dbfname))))
				   (success   (car lockinfo)))
			      success)))
		       (else
			(debug:print-info 0 *default-log-port* "I'm not the lead server: "servers)
			(let* ((leadsrv (car servers)))
			  (match leadsrv
			    ((host port startseconds server-id pid dbfname servinfofile)
			     (if (tt:ping host port server-id)
				 #f ;; not the server, but all good, want to exit