Megatest

(define (colors-similar? color1 color2)
  (let* ((c1    (map string->number (string-split color1)))
	 (c2    (map string->number (string-split color2)))
	 (delta (map (lambda (a b)(abs (- a b))) c1 c2)))
    (null? (filter (lambda (x)(> x 3)) delta))))

(define (compare-tests test1 test2)
  (let* ((test-name1  (db:test-get-testname  test1))
	 (item-path1  (db:test-get-item-path test1))
	 (eventtime1  (db:test-get-event_time test1))
	 (test-name2  (db:test-get-testname  test2))
	 (item-path2  (db:test-get-item-path test2))
	 (eventtime2  (db:test-get-event_time test2))
	 (same-name   (equal? test-name1 test-name2))
	 (test1-top   (equal? item-path1 ""))
	 (test2-top   (equal? item-path2 ""))
	 (test1-older (> eventtime1 eventtime2))
	 (same-time   (equal? eventtime1 eventtime2)))			 
    (if same-name
	(if same-time
	    (string>? item-path1 item-path2)
	    test1-older)
	(if same-time
	    (string>? test-name1 test-name2)
	    test1-older))))
    
;; keypatts: ( (KEY1 "abc%def")(KEY2 "%") )
(define (update-rundat runnamepatt numruns testnamepatt keypatts)
  (let* ((referenced-run-ids '())
	 (allruns     (if *useserver*
			  (rmt:get-runs runnamepatt numruns *start-run-offset* keypatts)
			  (db:get-runs *dbstruct-local* runnamepatt numruns ;; (+ numruns 1) ;; (/ numruns 2))
				      *start-run-offset* keypatts)))

			  'testname
			  'itempath)))
    ;; 
    ;; trim runs to only those that are changing often here
    ;; 
    (for-each (lambda (run)
		(let* ((run-id      (db:get-value-by-header run header "id"))
		       (tmptests    (if *useserver*
					(rmt:get-tests-for-run run-id testnamepatt states statuses
							       #f #f
							       *hide-not-hide*
							       sort-by
							       sort-order
							       'shortlist)
					(db:get-tests-for-run *dbstruct-local* run-id testnamepatt states statuses
							      #f #f
							      *hide-not-hide*
							      sort-by
							      sort-order
							      'shortlist)))
		       (tests       (if (eq? *tests-sort-reverse* 3) ;; +event_time
					(sort tmptests compare-tests)
					tmptests))
		       ;; NOTE: bubble-up also sets the global *all-item-test-names*
		       ;; (tests       (bubble-up tmptests priority: bubble-type))
		       (key-vals    (if *useserver* 
					(rmt:get-key-vals run-id)
					(db:get-key-vals *dbstruct-local* run-id))))
		  ;; NOTE: 11/01/2013 This routine is *NOT* getting called excessively.
		  ;; (debug:print 0 "Getting data for run " run-id " with key-vals=" key-vals)

	 (tests:test-set-status! run-id test-id "COMPLETED" "FAIL" (conc "Failed at step " stepname) #f)
	 )))
    logpro-used))

(define (launch:execute encoded-cmd)
  
   (let* ((cmdinfo    (common:read-encoded-string encoded-cmd))
	  (tconfigreg (tests:get-all)))
    (setenv "MT_CMDINFO" encoded-cmd)
    (if (list? cmdinfo) ;; ((testpath /tmp/mrwellan/jazzmind/src/example_run/tests/sqlitespeed)
	;; (test-name sqlitespeed) (runscript runscript.rb) (db-host localhost) (run-id 1))
	(let* ((testpath  (assoc/default 'testpath  cmdinfo))  ;; testpath is the test spec area
	       (top-path  (assoc/default 'toppath   cmdinfo))
	       (work-area (assoc/default 'work-area cmdinfo))  ;; work-area is the test run area
	       (test-name (assoc/default 'test-name cmdinfo))

   (list ;; (list "MT_TEST_RUN_DIR" work-area)
    (list "MT_RUN_AREA_HOME" *toppath*)
    (list "MT_TEST_NAME" test-name)
    ;; (list "MT_ITEM_INFO" (conc itemdat)) 
    (list "MT_RUNNAME"   runname)
    ;; (list "MT_TARGET"    mt_target)
    ))
  (let* ((tregistry       (tests:get-all))
	 (item-path       (let ((ip (item-list->path itemdat)))
			    (alist->env-vars (list (list "MT_ITEMPATH" ip)))
			    ip))
	 (tconfig         (or (tests:get-testconfig test-name tregistry #t)
			      test-conf)) ;; force re-read now that all vars are set
	 (useshell        (let ((ush (config-lookup *configdat* "jobtools"     "useshell")))
			    (if ush 

				       #f)
				     (configf:read-alist cache-file)))
			       (read-config test-configf #f system-allowed environ-patt: (if system-allowed
											     "pre-launch-env-vars"
											     #f)))
			   #f)))
    (hash-table-set! *testconfigs* test-name tcfg)
    (if (and testexists
	     cache-path
	     (not cache-exists)
	     (file-write-access? cache-path))
	(let ((tpath (conc cache-path "/.testconfig")))
	  (debug:print-info 1 "Caching testconfig for " test-name " in " tpath)
	  (configf:write-alist tcfg tpath)))
    tcfg))