Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -60,10 +60,11 @@ -rerun FAIL,WARN... : force re-run for tests with specificed status(s) -rollup : (currently disabled) fill run (set by :runname) with latest test(s) from prior runs with same keys -lock : lock run specified by target and runname -unlock : unlock run specified by target and runname + -run-wait : wait on run specified by target and runname Selectors (e.g. use for -runtests, -remove-runs, -set-state-status, -list-runs etc.) -target key1/key2/... : run for key1, key2, etc. -reqtarg key1/key2/... : run for key1, key2, etc. but key1/key2 must be in runconfig -testpatt patt1/patt2,patt3/... : % is wildcard @@ -116,11 +117,12 @@ -server -|hostname : start the server (reduces contention on megatest.db), use - to automatically figure out hostname -transport http|fs : use http or direct access for transport (default is http) -daemonize : fork into background and disconnect from stdin/out -list-servers : list the servers - -stop-server id : stop server specified by id (see output of -list-servers) + -stop-server id : stop server specified by id (see output of -list-servers), use + 0 to kill all -repl : start a repl (useful for extending megatest) -load file.scm : load and run file.scm Spreadsheet generation -extract-ods fname.ods : extract an open document spreadsheet from the database @@ -211,11 +213,13 @@ "-archive" "-repl" "-lock" "-unlock" "-list-servers" - ;; mist queries + "-run-wait" ;; wait on a run to complete (i.e. no RUNNING) + + ;; misc queries "-list-disks" "-list-targets" "-list-db-targets" "-show-runconfig" "-show-config" @@ -373,11 +377,12 @@ (open-run-close tasks:server-deregister tasks:open-db hostname pullport: pullport pid: pid action: 'delete)) (if (> last-update 20) ;; Mark as dead if not updated in last 20 seconds (open-run-close tasks:server-deregister tasks:open-db hostname pullport: pullport pid: pid))) (format #t fmtstr id mt-ver pid hostname interface pullport pubport last-update (if status "alive" "dead") transport) - (if (equal? id sid) + (if (or (equal? id sid) + (equal? sid 0)) ;; kill all/any (begin (debug:print-info 0 "Attempting to stop server with pid " pid) (tasks:kill-server status hostname pullport pid transport))))) servers) (debug:print-info 1 "Done with listservers") @@ -1016,48 +1021,20 @@ ;; keep this one local (open-run-close patch-db #f) (set! *didsomething* #t))) ;;====================================================================== -;; Update the tests meta data from the testconfig files +;; Wait on a run to complete ;;====================================================================== -(if (args:get-arg "-update-meta") +(if (args:get-arg "-run-wait") (begin (if (not (setup-for-run)) (begin (debug:print 0 "Failed to setup, exiting") (exit 1))) - ;; now can find our db - ;; keep this one local - (open-run-close runs:update-all-test_meta db) - (set! *didsomething* #t))) - -;;====================================================================== -;; Start a repl -;;====================================================================== - -(if (or (args:get-arg "-repl") - (args:get-arg "-load")) - (let* ((toppath (setup-for-run)) - (db (if toppath (open-db) #f))) - (if db - (begin - (set! *db* db) - (set! *client-non-blocking-mode* #t) - ;; (client:setup) - ;; (client:launch) - (import readline) - (import apropos) - (gnu-history-install-file-manager - (string-append - (or (get-environment-variable "HOME") ".") "/.megatest_history")) - (current-input-port (make-gnu-readline-port "megatest> ")) - (if (args:get-arg "-repl") - (repl) - (load (args:get-arg "-load")))) - (exit)) + (operate-on 'run-wait) (set! *didsomething* #t))) ;;====================================================================== ;; Exit and clean up ;;====================================================================== Index: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -564,20 +564,22 @@ (exit))) (for-each (lambda (run) (let ((runkey (string-intersperse (map (lambda (k) (db:get-value-by-header run header k)) keys) "/")) - (dirs-to-remove (make-hash-table))) + (dirs-to-remove (make-hash-table)) + (proc-get-tests (lambda (run-id) + (cdb:remote-run db:get-tests-for-run db run-id + testpatt states statuses + not-in: #f + sort-by: (case action + ((remove-runs) 'rundir) + (else 'event_time)))))) (let* ((run-id (db:get-value-by-header run header "id")) (run-state (db:get-value-by-header run header "state")) (tests (if (not (equal? run-state "locked")) - (cdb:remote-run db:get-tests-for-run db run-id - testpatt states statuses - not-in: #f - sort-by: (case action - ((remove-runs) 'rundir) - (else 'event_time))) + (proc-get-tests run-id) '())) (lasttpath "/does/not/exist/I/hope")) (debug:print-info 4 "runs:operate-on run=" run ", header=" header) (if (not (null? tests)) (begin @@ -587,10 +589,12 @@ ((set-state-status) (debug:print 1 "Modifying state and staus for tests for run: " runkey " " (db:get-value-by-header run header "runname"))) ((print-run) (debug:print 1 "Printing info for run " runkey ", run=" run ", tests=" tests ", header=" header) action) + ((run-wait) + (debug:print 1 "Waiting for run " runkey ", run=" runnamepatt " to complete")) (else (debug:print-info 0 "action not recognised " action))) (let ((sorted-tests (sort tests (lambda (a b)(let ((dira (db:test-get-rundir a)) (dirb (db:test-get-rundir b))) (if (and (string? dira)(string? dirb)) @@ -667,11 +671,18 @@ )) (if (not (null? tal)) (loop (car tal)(cdr tal)))))) ((set-state-status) (debug:print-info 2 "new state " (car state-status) ", new status " (cadr state-status)) - (cdb:remote-run db:test-set-state-status-by-id db (db:test-get-id test) (car state-status)(cadr state-status) #f))))) + (cdb:remote-run db:test-set-state-status-by-id db (db:test-get-id test) (car state-status)(cadr state-status) #f)) + ((run-wait) + (debug:print-info 2 "still waiting, " (length tests) " tests still running") + (thread-sleep! 10) + (let ((new-tests (proc-get-tests run-id))) + (if (null? new-tests) + (debug:print-info 1 "Run completed according to zero tests matching provided criteria.") + (loop (car new-tests)(cdr new-tests)))))))) ))) ;; remove the run if zero tests remain (if (eq? action 'remove-runs) (let ((remtests (cdb:remote-run db:get-tests-for-run db (db:get-value-by-header run header "id") #f '("DELETED") '("n/a") not-in: #t))) (if (null? remtests) ;; no more tests remaining Index: tests/Makefile ================================================================== --- tests/Makefile +++ tests/Makefile @@ -66,12 +66,14 @@ cd fullrun;$(MEGATEST) -rollup :runname newrun -target ubuntu/nfs/none -debug 10 test7: @echo Only a/c testname c should remain. If there is a run a/b/c then there is a cache issue. (cd simplerun;$(MEGATEST) -remove-runs -target %/% :runname % -testpatt %; \ - $(MEGATEST) -runtests % -target a/b :runname c; \ - $(MEGATEST) -runtests % -target a/c :runname c; \ + $(MEGATEST) -runtests % -target a/b :runname c ; \ + $(MEGATEST) -runtests % -target a/c :runname c ; \ + $(MEGATEST) -run-wait -target a/c :runname c :state RUNNING ; \ + $(MEGATEST) -run-wait -target a/b :runname c :state RUNNING ; \ $(MEGATEST) -remove-runs -target a/b :runname c -testpatt % ; \ $(MEGATEST) -runtests % -target a/d :runname c;$(MEGATEST) -list-runs %|egrep ^Run:) > test7.log 2> test7.log logpro test7.logpro test7.html < test7.log @echo @echo Run \"firefox test7.html\" to see the results.