Megatest

				     #:expand "HORIZONTAL"
				     #:action (lambda (obj)
						(tasks:add-from-params tdb "run" keys key-params var-params)
						(print "Launch Run")))
			 (iup:button "Remove" 
				     #:expand "HORIZONTAL"
				     #:action (lambda (obj)
						(print "Remove Run")
						(tasks:add-from-params tdb "remove" keys key-params var-params)
						))
			 (iup:button "Rollup" 
				     #:expand "HORIZONTAL"
				     #:action (lambda (obj)
						(print "Rollup Run")
						(tasks:add-from-params tdb "rollup" keys key-params var-params)))))
		       (iup:frame 
			#:title "Misc"
			(iup:hbox
			 (iup:button "Quit" 
				     #:expand "HORIZONTAL"
				     #:action (lambda (obj)
						(sqlite3:finalize! db)

    (set! topdialog (iup:dialog 
		     #:close_cb (lambda (a)(exit))
		     #:title "Run Controls"
		     (iup:vbox
		      (iup:hbox keyentries othervars)
		      controls
		      (let ((tabtop (iup:tabs 

				     (iup:vbox 
				       (let* ((tb (iup:textbox #:expand "HORIZONTAL"))
					      (bt (iup:button "Remove tasks by id"
							      #:action (lambda (obj)
									 (let ((val (iup:attribute tb "VALUE")))
									   (tasks:remove-queue-entries tdb val)))))
					      (lb (iup:label "(comma separated)")))
					 (iup:hbox bt tb lb))
				       actions)
				     monitors
				     )))
			(iup:attribute-set! tabtop "TABTITLE0" "Actions")
			(iup:attribute-set! tabtop "TABTITLE1" "Monitors")
			tabtop)
		      )))
		      ; (iup:frame
		      ;  #:title "Monitors"
		      ;  monitors)
		      ; (iup:frame
		      ;  #:title "Actions"

	 (numtarg  (length targlist))
	 (targtweaked (if (> numkeys numtarg)
			  (append targlist (make-list (- numkeys numtarg) ""))
			  targlist)))
    (map (lambda (key targ)
	   (list (vector-ref key 0) targ))
	 keys targtweaked)))


;;======================================================================
;; key <=> args routines
;;======================================================================

;; Using the keys pulled from the database (initially set from the megatest.config file)
;; look for the equivalent value on the command line and add it to a list, or #f if not found.
;; default => (val1 val2 val3 ...)
;; withkey => (:key1 val1 :key2 val2 :key3 val3 ...)
(define (keys->vallist keys . withkey) ;; ORDERING IS VERY IMPORTANT, KEEP PROPER ORDER HERE!
  (let* ((keynames   (map key:get-fieldname keys))
	 (argkeys    (map (lambda (k)(conc ":" k)) keynames))
	 (withkey    (not (null? withkey)))
	 (newremargs (args:get-args 
		      (cons "blah" remargs) ;; the cons blah works around a bug in args [args assumes ("calling-prog-name" .... ) ]
		      argkeys 
		      '()
		      args:arg-hash 
		      0)))
    ;;(debug:print 0 "remargs: " remargs " newremargs: " newremargs)
    (apply append (map (lambda (x)
			 (let ((val (args:get-arg x)))
			   ;; (debug:print 0 "x: " x " val: " val)
			   (if (not val)
			       (begin
				 (if (not (hash-table-ref/default keys:warning-suppress-hash x #f))

	(hosts      (config-lookup *configdat* "jobtools"     "workhosts"))
	(remote-megatest (config-lookup *configdat* "setup" "executable"))
	;; FIXME SOMEDAY: not good how this is so obtuse, this hack is to 
	;;                allow running from dashboard 
	(local-megatest  (let* ((lm  (car (argv)))
				(dir (pathname-directory lm))
				(exe (pathname-strip-directory lm)))
			   (conc (if dir (conc dir "/") "")
				 (case (string->symbol exe)
				   ((dboard) "megatest")
				   ((dashboard) "megatest")
				   (else exe)))))
	(test-sig   (conc "=" test-name ":" (item-list->path itemdat) "=")) ;; test-path is the full path including the item-path
	(work-area  #f)
	(toptest-work-area #f) ;; for iterated tests the top test contains data relevant for all

;; Rollup into a run
;;======================================================================
(if (args:get-arg "-rollup")
    (general-run-call 
     "-rollup" 
     "rollup tests" 
     (lambda (db keys keynames keyvallst)
       (runs:rollup-run db
			keys
			(keys->alist keys "na")
			(args:get-arg ":runname") 
			user))))

;;======================================================================
;; Extract a spreadsheet from the runs database
;;======================================================================

(if (args:get-arg "-extract-ods")
    (general-run-call

;; New methodology. These routines will replace the above in time. For
;; now the code is duplicated. This stuff is initially used in the monitor
;; based code.
;;======================================================================

;; register a test run with the db
(define (runs:register-run db keys keyvallst runname state status user)
  (debug:print 3 "runs:register-run, keys: " keys " keyvallst: " keyvallst " runname: " runname " state: " state " status: " status " user: " user)
  (let* ((keystr    (keys->keystr keys))
	 (comma     (if (> (length keys) 0) "," ""))
	 (andstr    (if (> (length keys) 0) " AND " ""))
	 (valslots  (keys->valslots keys)) ;; ?,?,? ...
	 (keyvals   (map cadr keyvallst))
	 (allvals   (append (list runname state status user) keyvals))
	 (qryvals   (append (list runname) keyvals))

       (let* ((test-path    (conc *toppath* "/tests/" test-name))
	      (test-configf (conc test-path "/testconfig"))
	      (testexists   (and (file-exists? test-configf)(file-read-access? test-configf)))
	      ;; read configs with tricks turned off (i.e. no system)
	      (test-conf    (if testexists (read-config test-configf #f #f)(make-hash-table))))
	 (runs:update-test_meta db test-name test-conf)))
     test-names)))

;; 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      (db-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 itempath in curr-tests-hash
    (for-each
     (lambda (testdat)

		  (tasks:monitors-update tdb)
		  (loop (+ count 1)(+ (current-seconds) 240)))
		(loop (+ count 1) next-touch)))))))
      
(define (tasks:process-queue db tdb)
  (let* ((task   (tasks:snag-a-task tdb))
	 (action (if task (tasks:task-get-action task) #f)))
    (if action (print "tasks:process-queue task: " task))
    (if action
	(case (string->symbol action)
	  ((run)       (tasks:start-run   db tdb task))
	  ((remove)    (tasks:remove-runs db tdb task))
	  ((lock)      (tasks:lock-runs   db tdb task))
	  ;; ((monitor)   (tasks:start-monitor db task))
	  ((rollup)    (tasks:rollup-runs db tdb task))

		   (get-host-name)))

(define (tasks:set-state tdb task-id state)
  (sqlite3:execute tdb "UPDATE tasks_queue SET state=? WHERE id=?;" 
		   state 
		   task-id))

;;======================================================================
;; The routines to process tasks
;;======================================================================

;; NOTE: It might be good to add one more layer of checking to ensure
;;       that no task gets run in parallel.

(define (tasks:start-run db tdb task)
  (let ((flags (make-hash-table)))
    (hash-table-set! flags "-rerun" "NOT_STARTED")
    (print "Starting run " task)
    ;; sillyness, just call the damn routine with the task vector and be done with it. FIXME SOMEDAY
    (runs:run-tests db
		    (tasks:task-get-target task)
		    (tasks:task-get-name   task)
		    (tasks:task-get-test   task)
		    (tasks:task-get-item   task)
		    (tasks:task-get-owner  task)
		    flags)
    (tasks:set-state tdb (tasks:task-get-id task) "waiting")))

(define (tasks:rollup-runs db tdb task)
  (let* ((flags (make-hash-table))
	 (keys  (db:get-keys db))
	 (keyvallst (keys:target->keyval keys (tasks:task-get-target task))))
    ;; (hash-table-set! flags "-rerun" "NOT_STARTED")
    (print "Starting rollup " task)
    ;; sillyness, just call the damn routine with the task vector and be done with it. FIXME SOMEDAY
    (runs:rollup-run db
		     keys 
		     keyvallst
		     (tasks:task-get-name  task)
		     (tasks:task-get-owner  task))
    (tasks:set-state tdb (tasks:task-get-id task) "waiting")))