Megatest

	       btns))))))


;;======================================================================
;;
;;======================================================================
(define (examine-test db test-id) ;; run-id run-key origtest)
  (let* ((testdat       (db:get-test-data-by-id db test-id)))
    (if (not testdat)
	(begin
	  (debug:print 0 "ERROR: No test data found for test " test-id ", exiting")
	  (exit 1))
	(let* ((run-id        (if testdat (db:test-get-run_id testdat) #f))
	       (keydat        (if testdat (rdb:get-key-val-pairs db run-id) #f))
	       (rundat        (if testdat (rdb:get-run-info db run-id) #f))
	       (runname       (if testdat (db:get-value-by-header (db:get-row rundat)
								  (db:get-header rundat)
								  "runname") #f))
					;(teststeps     (if testdat (db:get-steps-for-test db test-id) #f))
	       (logfile       "/this/dir/better/not/exist")
	       (rundir        logfile)
	       (testfullname  (if testdat (db:test-get-fullname testdat) "Gathering data ..."))
	       (testname      (if testdat (db:test-get-testname testdat) "n/a"))
	       (testmeta      (if testdat 
				  (let ((tm (rdb:testmeta-get-record db testname)))
				    (if tm tm (make-db:testmeta)))
				  (make-db:testmeta)))

	       (keystring  (string-intersperse 
			    (map (lambda (keyval)
				   ;; (conc ":" (car keyval) " " (cadr keyval)))
				   (cadr keyval))
				 keydat)
			    "/"))
	       (item-path  (db:test-get-item-path testdat))
	       (viewlog    (lambda (x)
			     (if (file-exists? logfile)
					;(system (conc "firefox " logfile "&"))
				 (iup:send-url logfile)
				 (message-window (conc "File " logfile " not found")))))
	       (xterm      (lambda (x)
			     (if (directory-exists? rundir)
				 (let ((shell (if (get-environment-variable "SHELL") 
						  (conc "-e " (get-environment-variable "SHELL"))
						  "")))
				   (system (conc "cd " rundir 
						 ";xterm -T \"" (string-translate testfullname "()" "  ") "\" " shell "&")))
				 (message-window  (conc "Directory " rundir " not found")))))
	       (refreshdat (lambda ()
			     (let ((newtestdat (rdb:get-test-data-by-id db test-id)))
			       (if newtestdat 
				   (begin
					;(mutex-lock! mx1)
				     (set! testdat newtestdat)
				     (set! teststeps    (rdb:get-steps-for-test db test-id))
				     (set! logfile      (conc (db:test-get-rundir testdat) "/" (db:test-get-final_logf testdat)))
				     (set! rundir       (db:test-get-rundir testdat))
				     (set! testfullname (db:test-get-fullname testdat))
					;(mutex-unlock! mx1)
				     )
				   (begin
				     (db:test-set-testname! testdat "DEAD OR DELETED TEST"))))))
	       (widgets      (make-hash-table))
	       (meta-widgets (make-hash-table))
	       (self         #f)
	       (store-label  (lambda (name lbl cmd)
			       (hash-table-set! widgets name 
						(lambda (testdat)
						  (let ((newval (cmd testdat))
							(oldval (iup:attribute lbl "TITLE")))
						    (if (not (equal? newval oldval))
							(begin
					;(mutex-lock! mx1)
							  (iup:attribute-set! lbl "TITLE" newval)
					;(mutex-unlock! mx1)
							  )))))
			       lbl))
	       (store-meta  (lambda (name lbl cmd)
			      (hash-table-set! meta-widgets name 
					       (lambda (testmeta)
						 (let ((newval (cmd testmeta))
						       (oldval (iup:attribute lbl "TITLE")))
						   (if (not (equal? newval oldval))
						       (begin
					;(mutex-lock! mx1)
							 (iup:attribute-set! lbl "TITLE" newval)
					;(mutex-unlock! mx1)
							 )))))
			      lbl))
	       (store-button store-label)
	       (command-text-box (iup:textbox #:expand "HORIZONTAL" #:font "Courier New, -10"))
	       (command-launch-button (iup:button "Execute!" #:action (lambda (x)
									(let ((cmd (iup:attribute command-text-box "VALUE")))
									  (system (conc cmd "  &"))))))
	       (run-test  (lambda (x)
			    (iup:attribute-set! 
			     command-text-box "VALUE"
			     (conc "megatest -runtests " testname " -target " keystring " :runname " runname 
				   " -itempatt " (if (equal? item-path "")
						     "%" 
						     item-path)
				   "" ))))
	       (remove-test (lambda (x)
			      (iup:attribute-set!
			       command-text-box "VALUE"
			       (conc "megatest -remove-runs -target " keystring " :runname " runname " -testpatt " testname " -itempatt "
				     (if (equal? item-path "")
					 "%"
					 item-path)
				     " -v ")))))
	  (cond
	   ((not testdat)(begin (print "ERROR: bad test info for " test-id)(exit 1)))
	   ((not rundat)(begin (print "ERROR: found test info but there is a problem with the run info for " run-id)(exit 1)))
	   (else
	    ;;  (test-set-status! db run-id test-name state status itemdat)
	    (set! self ; 
		  (iup:dialog #:close_cb (lambda (a)(exit)) ; #:expand "YES"
			      #:title testfullname
			      (iup:vbox ; #:expand "YES"
			       ;; The run and test info
			       (iup:hbox  ; #:expand "YES"
				(run-info-panel keydat testdat runname)
				(test-info-panel testdat store-label widgets)
				(test-meta-panel testmeta store-meta))
			       (host-info-panel testdat store-label)
			       ;; The controls
			       (iup:frame #:title "Actions" 
					  (iup:vbox
					   (iup:hbox 
					    (iup:button "View Log"    #:action viewlog     #:size "80x")
					    (iup:button "Start Xterm" #:action xterm       #:size "80x")
					    (iup:button "Run Test"    #:action run-test    #:size "80x")
					    (iup:button "Clean Test"  #:action remove-test #:size "80x")
					    (iup:button "Close"       #:action (lambda (x)(exit)) #:size "80x"))
					   (apply 
					    iup:hbox
					    (list command-text-box command-launch-button))))
			       (set-fields-panel test-id testdat)
			       (iup:hbox
				(iup:frame 
				 #:title "Test Steps"
				 (let ((stepsdat ;;(iup:label "Test steps ........................................." 
					;;	   #:expand "YES" 
					;;	   #:size "200x150"
					;;	   #:alignment "ALEFT:ATOP")))
					(iup:textbox ;; #:action (lambda (obj char val)
					 ;;    	#f)
					 #:expand "YES"
					 #:multiline "YES"
					 #:font "Courier New, -10"
					 #:size "60x100")))
				   (hash-table-set! widgets "Test Steps" 
						    (lambda (testdat)
						      (let* ((currval (iup:attribute stepsdat "VALUE")) ;; "TITLE"))
							     (fmtstr  "~20a~10a~10a~12a~15a~20a")
							     (comprsteps (rdb:get-steps-table db test-id))
							     (newval  (string-intersperse 
								       (append
									(list 
									 (format #f fmtstr "Stepname" "Start" "End" "Status" "Time" "Logfile")
									 (format #f fmtstr "========" "=====" "===" "======" "====" "======="))
									(map (lambda (x)
									       ;; take advantage of the \n on time->string
									       (format #f fmtstr
										       (vector-ref x 0)
										       (let ((s (vector-ref x 1)))
											 (if (number? s)(seconds->time-string s) s))
										       (let ((s (vector-ref x 2)))
											 (if (number? s)(seconds->time-string s) s))
										       (vector-ref x 3)    ;; status
										       (vector-ref x 4)
										       (vector-ref x 5)))  ;; time delta
									     (sort (hash-table-values comprsteps)
										   (lambda (a b)
										     (let ((time-a (vector-ref a 1))
											   (time-b (vector-ref b 1)))
										       (if (and (number? time-a)(number? time-b))
											   (< time-a time-b)
											   #t))))))
								       "\n")))
							(if (not (equal? currval newval))
							    (iup:attribute-set! stepsdat "VALUE" newval ))))) ;; "TITLE" newval)))))
				   stepsdat))
				;; populate the Test Data panel
				(iup:frame
				 #:title "Test Data"
				 (let ((test-data
					(iup:textbox  ;; #:action (lambda (obj char val)
					 ;;   	#f)
					 #:expand "YES"
					 #:multiline "YES"
					 #:font "Courier New, -10"
					 #:size "100x100")))
				   (hash-table-set! widgets "Test Data"
						    (lambda (testdat) ;; 
						      (let* ((currval (iup:attribute test-data "VALUE")) ;; "TITLE"))
							     (fmtstr  "~10a~10a~10a~10a~7a~7a~6a~6a~a") ;; category,variable,value,expected,tol,units,type,comment
							     (newval  (string-intersperse 
								       (append
									(list 
									 (format #f fmtstr "Category" "Variable" "Value" "Expected" "Tol" "Status" "Units" "Type" "Comment")
									 (format #f fmtstr "========" "========" "=====" "========" "===" "======" "=====" "====" "======="))
									(map (lambda (x)
									       (format #f fmtstr
										       (db:test-data-get-category x)
										       (db:test-data-get-variable x)
										       (db:test-data-get-value    x)
										       (db:test-data-get-expected x)
										       (db:test-data-get-tol      x)
										       (db:test-data-get-status   x)
										       (db:test-data-get-units    x)
										       (db:test-data-get-type     x)
										       (db:test-data-get-comment  x)))
									     (db:read-test-data db test-id "%")))
								       "\n")))
							(if (not (equal? currval newval))
							    (iup:attribute-set! test-data "VALUE" newval ))))) ;; "TITLE" newval)))))
				   test-data)))
			       )))
	    (iup:show self)
	    (iup:callback-set! *tim* "ACTION_CB"
			       (lambda (x)
				 ;; Now start keeping the gui updated from the db
				 (refreshdat) ;; update from the db here
					;(thread-suspend! other-thread)
				 ;; update the gui elements here
				 (for-each 
				  (lambda (key)
				    ;; (print "Updating " key)
				    ((hash-table-ref widgets key) testdat))
				  (hash-table-keys widgets))
				 (update-state-status-buttons testdat)
					; (iup:refresh self)
				 (if *exit-started*
				     (set! *exit-started* 'ok))))))))))

      (db:get-test-data-by-id db test-id)))

(define (rdb:get-run-info db run-id)
  (if *runremote*
      (let ((host (vector-ref *runremote* 0))
	    (port (vector-ref *runremote* 1)))
	((rpc:procedure 'rdb:get-run-info host port) run-id))
      (db:get-run-info db run-id)))

(define (rdb:get-steps-for-test db test-id)
  (if *runremote*
      (let ((host (vector-ref *runremote* 0))
	    (port (vector-ref *runremote* 1)))
	((rpc:procedure 'rdb:get-steps-for-test host port) test-id))
      (db:get-steps-for-test db test-id)))

(define (rdb:get-steps-table db test-id)
  (if *runremote*
      (let ((host (vector-ref *runremote* 0))
	    (port (vector-ref *runremote* 1)))
	((rpc:procedure 'rdb:get-steps-table host port) test-id))
      (db:get-steps-table db test-id)))

(define (rdb:read-test-data db test-id categorypatt)
  (if *runremote*
      (let ((host (vector-ref *runremote* 0))
	    (port (vector-ref *runremote* 1)))
	((rpc:procedure 'rdb:read-test-data host port) test-id categorypatt))
      (db:read-test-data db test-id categorypatt)))

(define (rdb:get-test-info db run-id testname item-path)
  (if *runremote*
      (let ((host (vector-ref *runremote* 0))
	    (port (vector-ref *runremote* 1)))
	((rpc:procedure 'rdb:get-test-info host port) run-id testname item-path))
      (db:get-test-info db run-id testname item-path)))

(define (rdb:delete-test-records db test-id)
  (if *runremote*
      (let ((host (vector-ref *runremote* 0))
	    (port (vector-ref *runremote* 1)))
	((rpc:procedure 'rdb:delete-test-records host port) test-id))
      (db:delete-test-records db test-id)))

	 (debug:print 2 "Run: "
		(string-intersperse (map (lambda (x)
					   (db:get-value-by-header run header x))
					 keynames) "/")
		"/"
		(db:get-value-by-header run header "runname"))
	 (let ((run-id (db:get-value-by-header run header "id")))
	   (let ((tests (rdb:get-tests-for-run db run-id testpatt itempatt '() '())))
	     ;; Each test
	     (for-each 
	      (lambda (test)
		(format #t
			"  Test: ~25a State: ~15a Status: ~15a Runtime: ~5@as Time: ~22a Host: ~10a\n"
			(conc (db:test-get-testname test)
			      (if (equal? (db:test-get-item-path test) "")

    (debug:print 1 "Header: " header)
    (for-each
     (lambda (run)
       (let ((runkey (string-intersperse (map (lambda (k)
						(db:get-value-by-header run header (vector-ref k 0))) keys) "/"))
	     (dirs-to-remove (make-hash-table)))
	 (let* ((run-id (db:get-value-by-header run header "id") )
		(tests  (rdb:get-tests-for-run db (db:get-value-by-header run header "id") testpatt itempatt '() '()))
		(lasttpath "/does/not/exist/I/hope"))

	   (if (not (null? tests))
	       (begin
		 (debug:print 1 "Removing tests for run: " runkey " " (db:get-value-by-header run header "runname"))
		 (for-each
		  (lambda (test)

			  (debug:print 2 "Removing directory with zero db references: " dir-to-remove)
			  (system (conc "rm -rf " dir-to-remove))
			  (hash-table-delete! dirs-to-remove dir-to-remove))
			(debug:print 2 "Skipping removal of " dir-to-remove " for now as it still has references in the database")))))
	    (sort (hash-table-keys dirs-to-remove) (lambda (a b)(> (string-length a)(string-length b)))))

	   ;; remove the run if zero tests remain
	   (let ((remtests (rdb:get-tests-for-run db (db:get-value-by-header run header "id") #f #f '() '())))
	     (if (null? remtests) ;; no more tests remaining
		 (let* ((dparts  (string-split lasttpath "/"))
			(runpath (conc "/" (string-intersperse 
					    (take dparts (- (length dparts) 1))
					    "/"))))
		   (debug:print 1 "Removing run: " runkey " " (db:get-value-by-header run header "runname"))
		   (db:delete-run db run-id)

      (let ((db   #f)
	    (keys #f))
	(if (not (setup-for-run))
	    (begin 
	      (debug:print 0 "Failed to setup, exiting")
	      (exit 1)))
	(set! db   (open-db))
	(set! keys (rdb:get-keys db))
	;; have enough to process -target or -reqtarg here
	(if (args:get-arg "-reqtarg")
	    (let* ((runconfigf (conc  *toppath* "/runconfigs.config")) ;; DO NOT EVALUATE ALL 
		   (runconfig  (read-config runconfigf #f #f environ-patt: #f))) 
	      (if (hash-table-ref/default runconfig (args:get-arg "-reqtarg") #f)
		  (keys:target-set-args keys (args:get-arg "-reqtarg") args:arg-hash)
		  (begin

;; This could probably be refactored into one complex query ...
(define (runs:rollup-run db keys keyvallst runname user) ;; was target, now keyvallst
  (debug:print 4 "runs:rollup-run, keys: " keys " keyvallst: " keyvallst " :runname " runname " user: " user)
  (let* (; (keyvalllst      (keys:target->keyval keys target))
	 (new-run-id      (runs:register-run db keys keyvallst runname "new" "n/a" user))
	 (prev-tests      (test:get-matching-previous-test-run-records db new-run-id "%" "%"))
	 (curr-tests      (rdb:get-tests-for-run db new-run-id "%" "%" '() '()))
	 (curr-tests-hash (make-hash-table)))
    (db:update-run-event_time db new-run-id)
    ;; index the already saved tests by testname and itemdat in curr-tests-hash
    (for-each
     (lambda (testdat)
       (let* ((testname  (db:test-get-testname testdat))
	      (item-path (db:test-get-item-path testdat))

	      (new-test-record #f))
	 ;; replace these with insert ... select
	 (apply sqlite3:execute 
		db 
		(conc "INSERT OR REPLACE INTO tests (run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment) "
		      "VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?);")
		new-run-id (cddr (vector->list testdat)))
	 (set! new-testdat (car (rdb:get-tests-for-run db new-run-id testname item-path '() '())))
	 (hash-table-set! curr-tests-hash full-name new-testdat) ;; this could be confusing, which record should go into the lookup table?
	 ;; Now duplicate the test steps
	 (debug:print 4 "Copying records in test_steps from test_id=" (db:test-get-id testdat) " to " (db:test-get-id new-testdat))
	 (sqlite3:execute 
	  db 
	  (conc "INSERT OR REPLACE INTO test_steps (test_id,stepname,state,status,event_time,comment) "
		"SELECT " (db:test-get-id new-testdat) ",stepname,state,status,event_time,comment FROM test_steps WHERE test_id=?;")

       (db:read-test-data db test-id categorypatt)))

    (rpc:publish-procedure!
     'rdb:get-test-info
     (lambda (run-id testname item-path)
       (db:get-test-info db  run-id testname item-path)))

    (rpc:publish-procedure!
     'rdb:delete-test-records
     (lambda (test-id)
       (db:delete-test-records db test-id)))

    (set! *rpc:listener* rpc:listener)
    (on-exit (lambda ()
	       (sqlite3:execute db "DELETE FROM metadat WHERE var='SERVER' and val=?;" host:port)
	       (sqlite3:finalize! db)))
    (thread-start! th1)
    (thread-join! th1))) ;; rpc:server)))

		 (conc "SELECT id FROM runs WHERE " qrystr " AND id != ?;") (append keyvals (list run-id)))
	  ;; for each run starting with the most recent look to see if there is a matching test
	  ;; if found then return that matching test record
	  (debug:print 4 "selstr: " selstr ", qrystr: " qrystr ", keyvals: " keyvals ", previous run ids found: " prev-run-ids)
	  (if (null? prev-run-ids) #f
	      (let loop ((hed (car prev-run-ids))
			 (tal (cdr prev-run-ids)))
		(let ((results (rdb:get-tests-for-run db hed test-name item-path '() '())))
		  (debug:print 4 "Got tests for run-id " run-id ", test-name " test-name ", item-path " item-path ": " results)
		  (if (and (null? results)
			   (not (null? tal)))
		      (loop (car tal)(cdr tal))
		      (if (null? results) #f
			  (car results))))))))))
    

	  ;; collect all matching tests for the runs then
	  ;; extract the most recent test and return that.
	  (debug:print 4 "selstr: " selstr ", qrystr: " qrystr ", keyvals: " keyvals 
		       ", previous run ids found: " prev-run-ids)
	  (if (null? prev-run-ids) '()  ;; no previous runs? return null
	      (let loop ((hed (car prev-run-ids))
			 (tal (cdr prev-run-ids)))
		(let ((results (rdb:get-tests-for-run db hed test-name item-path '() '())))
		  (debug:print 4 "Got tests for run-id " run-id ", test-name " test-name 
			       ", item-path " item-path " results: " (intersperse results "\n"))
		  ;; Keep only the youngest of any test/item combination
		  (for-each 
		   (lambda (testdat)
		     (let* ((full-testname (conc (db:test-get-testname testdat) "/" (db:test-get-item-path testdat)))
			    (stored-test   (hash-table-ref/default tests-hash full-testname #f)))