Megatest

		    (debug:print 0 *default-log-port* "INFO: Found host: " new-best " load: " load " last-used: " delta " seconds ago, with job-rate: " job-rate)
		    (host-last-used-set! rec curr-time)
		    new-best)
		  (if (null? tal) #f (loop (car tal)(cdr tal) best-host)))))))))

(define (common:wait-for-cpuload maxload-in numcpus-in waitdelay #!key (count 1000) (msg #f)(remote-host #f)(force-maxload #f))
  (let* ((loadavg (common:get-cpu-load remote-host))
	 (numcpus (if (<= 1 numcpus-in) ;; not possible to have zero.  If we get 1, it's possible that we got the previous default, and we should check again
		      (common:get-num-cpus remote-host)
		      numcpus-in))
	 (maxload (if force-maxload
		      maxload-in
		      (max maxload-in 0.5))) ;; so maxload must be greater than 0.5 for now BUG - FIXME?
	 (first   (car loadavg))
	 (next    (cadr loadavg))

           (if (not readyexists)
               (common:simple-file-lock-and-wait lockfname))
           (let ((db      (sqlite3:open-database fname)))
             (sqlite3:set-busy-handler! db (make-busy-timeout 136000))
             (sqlite3:execute db "PRAGMA synchronous = 0;")
             (if (not file-exists)
                 (begin
                   (if (and (configf:lookup *configdat* "setup" "tmp_mode") (string-match "^/tmp/.*" fname))
                      (begin
                       (print "DEBUG: Setting tmp_mode for " fname) 
                       (sqlite3:execute db (configf:lookup *configdat* "setup" "tmp_mode"))
                      )
                   )  
                   (if (and (configf:lookup *configdat* "setup" "nfs_mode") (not (string-match "^/tmp/.*" fname)))
                       (begin
                        (print "DEBUG: Setting nfs_mode for " fname)
                        (sqlite3:execute db (configf:lookup *configdat* "setup" "nfs_mode"))
                       )
                   )  
                   (if (and (not (or (configf:lookup *configdat* "setup" "tmp_mode") (configf:lookup *configdat* "setup" "nfs_mode")))  
                            (configf:lookup *configdat* "setup" "use-wal")
                            (string-match "^/tmp/.*" fname)) ;; this is a file in /tmp
                       (sqlite3:execute db "PRAGMA journal_mode=WAL;")
                       (debug:print 2 *default-log-port* "Creating " fname " in NON-WAL mode."))
                   (initproc db)))
             (if (not readyexists)
                 (begin
                   (common:simple-file-release-lock lockfname)

         (exn (corrupt)   (debug:print 0 *default-log-port* "ERROR: database " fname " is corrupt. Repair it to proceed."))
         (exn (busy)      (debug:print 0 *default-log-port* "ERROR: database " fname " is locked. Try copying to another location, remove original and copy back."))
         (exn (permission)(debug:print 0 *default-log-port* "ERROR: database " fname " has some permissions problem."))
         (exn () (debug:print 0 *default-log-port* "ERROR: Unknown error with database " fname " message: " ((condition-property-accessor 'exn 'message) exn))))
	)))











































;; This routine creates the db if not already present. It is only called if the db is not already opened
;;
(define (db:open-db dbstruct #!key (areapath #f)(do-sync #t)) ;; TODO: actually use areapath
  (let ((tmpdb-stack (dbr:dbstruct-dbstack dbstruct))) ;; RA => Returns the first reference in dbstruct
    (if (stack? tmpdb-stack)
	(db:get-db tmpdb-stack) ;; get previously opened db (will create new db handle if all in the stack are already used
        (let* ((max-stale-tmp (configf:lookup-number *configdat* "server" "filling-db-max-stale-seconds" default: 10))

(use gl glut 3viewer typed-records matchable)

(define red    '#f32(1 0 0 1))   ;;      
(define blue   '#f32(0 0 1 1))	  ;;	  
(define green  '#f32(0 1 0 1))	  ;;	  
(define yellow '#f32(1 1 0 1))	  ;;	  
(define white  '#f32(1 1 1 1))	  ;;	  
(define orange '#f32(1 0.5 0 1)) ;; 	  
(define black  '#f32(0 0 0 1)) ;;	 

(define colors
  `((1 . ,red    ) ;;  red    
    (2 . ,blue   ) ;;	 blue   
    (3 . ,green  ) ;;	 green  
    (4 . ,yellow ) ;;	 yellow 
    (5 . ,white  ) ;;	 white  
    (6 . ,orange ) ;; 	 orange 
    (7 . ,black  ) ;;	 black
    ))

;; retrive color
(define (rc c)
  (alist-ref c colors))

(defstruct cspec
  (x 0)
  (y 0)
  (z 0)
  (n (rc 1))   ;; north
  (s (rc 1))   ;; south
  (e (rc 1))   ;; east
  (w (rc 1))   ;; west
  (t (rc 1))   ;; top
  (b (rc 1)))  ;; bottom

(define a 0)

(define (spin id)
  (set! a (modulo (+ a 1) 360)))

(define (colorize id col)
  (gl:Materialfv 
   gl:FRONT_AND_BACK gl:AMBIENT_AND_DIFFUSE
   (if (object-highlighted? id)
       '#f32(1 1 0 1)
       col)))

(define (make-cuber cspec)
  (lambda (id)
    (gl:Translatef (cspec-x cspec)(cspec-y cspec)(cspec-z cspec))
    (draw-side id (cspec-w cspec)) ;; west side
    (gl:Translatef 0 1 0)
    (gl:Rotatef 90 1 0 0)
    (draw-side id (cspec-e cspec)) ;; east side
    (gl:Translatef 0 0 1)
    (gl:Rotatef 90 0 1 0)
    (draw-side id (cspec-n cspec)) ;; east side
    (gl:Translatef 0 0 1)
    (gl:Rotatef 90 0 1 0)
    (draw-side id (cspec-s cspec)) ;; east side
    (gl:Translatef 0 0 1)
    (gl:Rotatef 90 0 1 0)
    (draw-side id (cspec-t cspec)) ;; east side
    (gl:Translatef 0 1 0)
    (gl:Rotatef 90 1 0 0)
    (draw-side id (cspec-b cspec)) ;; east side
       ))
    
(define (draw-side id color)
  (colorize id color) ;; '#f32(1 0 0 1))
  (gl:Begin gl:POLYGON)
  (gl:Vertex2f 0 0) 
  (gl:Vertex2f 0 1) 
  (gl:Vertex2f 1 1) 
  (gl:Vertex2f 1 0) 
  (gl:End) 
  )

(define data
  (map (lambda (inl)
	 (map string->number (string-split inl)))
       (with-input-from-file "data.txt"
	 read-lines)))

(print "data: " data)

(use trace)

;; (add-object draw-cube animate: spin select: (lambda _ (print "oink!")))
;; (add-object draw-polygon animate: spin select: (lambda _ (print "oink!")))
(gl:Clear gl:COLOR_BUFFER_BIT)
(for-each
 (lambda (dat)
   ;; (let ((c1 (make-cspec e: red w: blue n: green s: yellow t: white b: orange)))
   (match dat
     ((x y z n s e w t b)
      (let ((c1 (make-cspec x: x y: y z: z n: (rc n) s: (rc s) e: (rc e) w: (rc w) t: (rc t) b: (rc b))))
	(pp (cspec->alist c1))
	(add-object (make-cuber c1) select: (lambda _ (print "oink!")))))
     (else (print "bad object " dat))))
 data)
(gl:Flush)      
(start-viewer)

0 0 0 1 2 3 4 5 6
0 0 1 1 2 3 4 5 6
0 0 2 1 2 3 4 5 6
0 1 0 1 2 3 4 5 6
0 1 1 1 2 3 4 5 6
0 1 2 1 2 3 4 5 6
0 2 0 1 2 3 4 5 6
0 2 1 1 2 3 4 5 6
0 2 2 1 2 3 4 5 6
1 0 0 1 2 3 4 5 6
1 0 1 1 2 3 4 5 6
1 0 2 1 2 3 4 5 6
1 1 0 1 2 3 4 5 6
1 1 1 1 2 3 4 5 6
1 1 2 1 2 3 4 5 6
1 2 0 1 2 3 4 5 6
1 2 1 1 2 3 4 5 6
1 2 2 1 2 3 4 5 6
2 0 0 1 2 3 4 5 6
2 0 1 1 2 3 4 5 6
2 0 2 1 2 3 4 5 6
2 1 0 1 2 3 4 5 6
2 1 1 1 2 3 4 5 6
2 1 2 1 2 3 4 5 6
2 2 0 1 2 3 4 5 6
2 2 1 1 2 3 4 5 6
2 2 2 1 2 3 4 5 6

;;     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.6529)

	;;  (if newstate   (rmt:general-call 'set-test-state   run-id newstate   test-id))
	;;  (if newstatus  (rmt:general-call 'set-test-status  run-id newstatus  test-id))
	;;  (if newcomment (rmt:general-call 'set-test-comment run-id newcomment test-id))))
	(rmt:set-state-status-and-roll-up-items run-id test-id #f newstate newstatus newcomment)
	;; (mt:process-triggers run-id test-id newstate newstatus)
	#t)))


(define (mt:test-set-state-status-by-id-unless-completed run-id test-id newstate newstatus newcomment)
  (let* ((test-vec   (rmt:get-testinfo-state-status run-id test-id))
         (state     (vector-ref test-vec 3)))
    (if (equal? state "COMPLETED")
        #t
        (rmt:set-state-status-and-roll-up-items run-id test-id #f newstate newstatus newcomment))))

  
(define (mt:test-set-state-status-by-testname run-id test-name item-path new-state new-status new-comment)
  ;(let ((test-id (rmt:get-test-id run-id test-name item-path)))
  (rmt:set-state-status-and-roll-up-items run-id test-name item-path new-state new-status new-comment)
  ;; (mt:process-triggers run-id test-id new-state new-status)
  #t);)
	;;(mt:test-set-state-status-by-id run-id test-id new-state new-status new-comment)))

(define (mt:test-set-state-status-by-testname-unless-completed run-id test-name item-path new-state new-status new-comment)
  (let ((test-id (rmt:get-test-id run-id test-name item-path)))
    (mt:test-set-state-status-by-id-unless-completed run-id test-id new-state new-status new-comment)))
    
(define (mt:lazy-read-test-config test-name)
  (let ((tconf (hash-table-ref/default *testconfigs* test-name #f)))
    (if tconf
	tconf
	(let ((test-dirs (tests:get-tests-search-path *configdat*)))
	  (let loop ((hed (car test-dirs))
		     (tal (cdr test-dirs)))

                             ;;        (if (args:get-arg "-target") 
                             ;;             (if (string= (args:get-arg "-target") runkey) (area-allowed? area "area-needs-to-be-run" runkey contour #f) #f) 
                             ;;             (area-allowed? area "area-needs-to-be-run" runkey contour #f))))
			    ;;(print "Area Allowed: " (area-allowed? area "area-needs-to-be-run" runkey contour #f))
;Add code to check whether area is valid
			     (if 
                   ;; This code checks whether the target has been passed in via argument, and only runs the specified target
                   (and (< packets-generated (or (string->number (if (configf:lookup mtconf "setup" "max_packets_per_run") (configf:lookup mtconf "setup" "max_packets_per_run") "10000" )) 10000))  
                        (if (args:get-arg "-target") 
                            (if (string= (args:get-arg "-target") runkey) (area-allowed? area "area-needs-to-be-run" runkey contour #f) #f) 
                                (area-allowed? area "area-needs-to-be-run" runkey contour #f)))
       
			     (let* ((script (car cmd))
				(params (cdr cmd))
				(cmd    (conc script " " contour " " area " " runkey " " std-runname " " action " " params))
				(res    (handle-exceptions
					    exn
					    #f

	 ;; (for-each
	 ;;  (lambda (key)
	 ;;    (if (not (member key *legal-params*))
	 ;; 	(hash-table-delete! adjargs key))) ;; we need to delete any params intended for mtutil
	 ;;  (hash-table-keys adjargs))
	 (let-values (((uuid pkt)
		       (command-line->pkt *action* adjargs #f area-path: area-path new-ss: new-ss)))
           (print "run log @ " (conc (current-directory) "/" uuid "-" *action* ".log"))
	   (write-pkt pktsdir uuid pkt))))
      ((dispatch import rungen process)
       (let* ((mtconfdat (simple-setup (args:get-arg "-start-dir")))
	      (mtconf    (car mtconfdat))
	      (toppath   (configf:lookup mtconf "scratchdat" "toppath")))
	 (case (string->symbol *action*)
	   ((process)  (begin

      (debug:print-info 4 *default-log-port* "cond branch - "  "ei-5")
      (debug:print-info 1 *default-log-port* "test "  hed " (mode=" testmode ") has failed prerequisite(s); "
			(string-intersperse (map (lambda (t)(conc (db:test-get-testname t) ":" (db:test-get-state t)"/"(db:test-get-status t))) fails) ", ")
			", removing it from to-do list")
      (let ((test-id (rmt:get-test-id run-id hed "")))
	(if test-id
	    (if (not (null? prereq-fails))
		(mt:test-set-state-status-by-id-unless-completed run-id test-id "COMPLETED" "PREQ_DISCARDED" "Failed to run due to prior failed prerequisites")
		(mt:test-set-state-status-by-id-unless-completed run-id test-id "COMPLETED" "PREQ_FAIL"      "Failed to run due to failed prerequisites"))))
      ;; (debug:print 4 *default-log-port*"BB> set PREQ_FAIL on "hed)
      ;; (mt:test-set-state-status-by-id run-id test-id "NOT_STARTED" "PREQ_FAIL"      "Failed to run due to failed prerequisites")))) ;; BB: this works, btu equivalent for itemwait mode does not work.
      (if (or (not (null? reg))(not (null? tal)))
	  (begin
	    (hash-table-set! test-registry hed 'CANNOTRUN)
            (runs:loop-values tal reg reglen regfull (cons hed reruns))
            )

	    (if  (runs:lownoise "Waiting for more work to do..." 60)
		 (debug:print-info 0 *default-log-port* "Waiting for more work to do..."))
	    (thread-sleep! 1)
	    (list (car newtal)(cdr newtal) reg reruns))
	  ;; the waiton is FAIL so no point in trying to run hed ever again
	  (begin
            (let ((my-test-id (rmt:get-test-id run-id test-name item-path)))
              (mt:test-set-state-status-by-id-unless-completed run-id my-test-id "COMPLETED" "PREQ_FAIL" "Failed to run due to failed prerequisites2"))


            
            (if (or (not (null? reg))(not (null? tal)))
                (if (vector? hed)
		  (begin
		    (debug:print 1 *default-log-port* "WARNING: Dropping test " test-name "/" item-path
				 " from the launch list as it has prerequistes that are FAIL")
		    (let ((test-id (rmt:get-test-id run-id hed "")))
		      (if test-id (mt:test-set-state-status-by-id-unless-completed run-id test-id "COMPLETED" "PREQ_FAIL" "Failed to run due to failed prerequisites")))
		    (runs:shrink-can-run-more-tests-count runsdat) ;; DELAY TWEAKER (still needed?)
		    ;; (thread-sleep! *global-delta*)
		    ;; This next is for the items

                    (if (not (null? fails))
                        ;;(mt:test-set-state-status-by-testname run-id test-name item-path "NOT_STARTED" "PREQ_FAIL" #f)
                        (rmt:set-state-status-and-roll-up-items run-id test-name item-path "NOT_STARTED" "PREQ_FAIL" #f) 

			  (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."))
			    ;; 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)
			    (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."))

(define (subrun:launch-cmd test-run-dir)
  (if (subrun:subrun-removed? test-run-dir)
      (subrun:unset-subrun-removed test-run-dir))      

  (let* ((log-prefix "run")
         (switches (subrun:selector+log-switches test-run-dir log-prefix))
         (run-wait #t)
         (cmd      (conc "megatest -rerun-clean "switches" "
                         (if run-wait "-run-wait " ""))))
    cmd))


(define (subrun:sanitize-path inpath)
  (let* ((insane-pattern (irregex "[^[a-zA-Z0-9_\\-]")))
    (regex#string-substitute insane-pattern "_" inpath #t)))