Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -240,11 +240,20 @@ (sqlite3:execute db "UPDATE tests SET comment=? WHERE run_id=? AND testname=? AND item_path=?;" comment run-id testname item-path)) +;; +(define (db:test-set-rundir! db run-id testname item-path rundir) + (sqlite3:execute + db + "UPDATE tests SET rundir=? WHERE run_id=? AND testname=? AND item_path=?;" + rundir run-id testname item-path)) + +;;====================================================================== ;; Steps +;;====================================================================== ;; Run steps ;; make-vector-record "Run steps" db step id test_id stepname step_complete step_pass event_time (define (make-db:step)(make-vector 6)) (define-inline (db:step-get-id vec) (vector-ref vec 0)) (define-inline (db:step-get-test_id vec) (vector-ref vec 1)) Index: launch.scm ================================================================== --- launch.scm +++ launch.scm @@ -79,13 +79,18 @@ "runname")) (key-vals (get-key-vals db run-id)) (key-str (string-intersperse key-vals "/")) (dfullp (conc disk-path "/" key-str "/" runname "/" testname item-path)) + (toptest-path (conc disk-path "/" key-str "/" runname "/" testname)) (runsdir (config-lookup *configdat* "setup" "runsdir")) (lnkpath (conc (if runsdir runsdir (conc *toppath* "/runs")) "/" key-str "/" runname item-path))) + ;; since this is an iterated test this is as good a place as any to + ;; update the toptest record with its location rundir + (if (not (equal? item-path "")) + (db:test-set-rundir! db run-id testname "" toptest-path)) (print "Setting up test run area") (print " - creating run area in " dfullp) (system (conc "mkdir -p " dfullp)) (print " - creating link from " dfullp "/" testname " to " lnkpath) (system (conc "mkdir -p " lnkpath)) @@ -93,12 +98,12 @@ (system (conc "rm -f " lnkpath "/" testname))) (system (conc "ln -sf " dfullp " " lnkpath "/" testname)) (if (directory? dfullp) (begin (system (conc "rsync -av " test-path "/ " dfullp "/")) - dfullp) - #f))) + (list dfullp toptest-path)) + (list #f #f)))) ;; 1. look though disks list for disk with most space ;; 2. create run dir on disk, path name is meaningful ;; 3. create link from run dir to megatest runs area ;; 4. remotely run the test on allocated host @@ -113,10 +118,11 @@ (hosts (config-lookup *configdat* "jobtools" "workhosts")) (remote-megatest (config-lookup *configdat* "setup" "executable")) (local-megatest (car (argv))) ;; (item-path (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 (diskpath #f) (cmdparms #f) (fullcmd #f) ;; (define a (with-output-to-string (lambda ()(write x)))) (mt-bindir-path #f)) (if hosts (set! hosts (string-split hosts))) @@ -124,11 +130,13 @@ (set! mt-bindir-path (pathname-directory remote-megatest)) (if launcher (set! launcher (string-split launcher))) ;; set up the run work area for this test (set! diskpath (get-best-disk *configdat*)) (if diskpath - (set! work-area (create-work-area db run-id test-path diskpath test-name itemdat)) + (let ((dat (create-work-area db run-id test-path diskpath test-name itemdat))) + (set! work-area (car dat)) + (set! toptest-work-area (cadr dat))) (begin (set! work-area test-path) (print "WARNING: No disk work area specified - running in the test directory"))) (set! cmdparms (base64:base64-encode (with-output-to-string (lambda () ;; (list 'hosts hosts) @@ -135,11 +143,12 @@ (write (list (list 'testpath test-path) (list 'work-area work-area) (list 'test-name test-name) (list 'runscript runscript) (list 'run-id run-id ) - (list 'itemdat itemdat) + (list 'itemdat itemdat ) + (list 'megatest remote-megatest) (list 'runname (args:get-arg ":runname")) (list 'mt-bindir-path mt-bindir-path))))))) ;; (string-intersperse keyvallst " ")))) (change-directory work-area) ;; so that log files from the launch process don't clutter the test dir (cond ((and launcher hosts) ;; must be using ssh hostname Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -28,10 +28,11 @@ \"megatest.sh\" file.) -step stepname -test-status : set the state and status of a test (use :state and :status) -setlog logfname : set the path/filename to the final log relative to the test directory. may be used with -test-status + -set-toplog logfname : set the overall log for a suite of sub-tests -m comment : insert a comment for this test Run data :runname : required, name for this particular test run :state : required if updating step state; e.g. start, end, completed @@ -76,10 +77,11 @@ ":status" "-list-runs" "-testpatt" "-itempatt" "-setlog" + "-set-toplog" "-runstep" "-logpro" "-m" ) (list "-h" @@ -318,20 +320,23 @@ (runscript (assoc/default 'runscript cmdinfo)) (db-host (assoc/default 'db-host cmdinfo)) (run-id (assoc/default 'run-id cmdinfo)) (itemdat (assoc/default 'itemdat cmdinfo)) (runname (assoc/default 'runname cmdinfo)) + (megatest (assoc/default 'megatest cmdinfo)) (mt-bindir-path (assoc/default 'mt-bindir-path cmdinfo)) (fullrunscript (conc testpath "/" runscript)) (db #f)) (print "Exectuing " test-name " on " (get-host-name)) (change-directory testpath) (setenv "MT_TEST_RUN_DIR" work-area) (setenv "MT_TEST_NAME" test-name) (setenv "MT_ITEM_INFO" (conc itemdat)) (setenv "MT_RUNNAME" runname) + (setenv "MT_MEGATEST" megatest) (setenv "PATH" (conc (getenv "PATH") ":" mt-bindir-path)) + (if (not (setup-for-run)) (begin (print "Failed to setup, exiting") (exit 1))) ;; now can find our db @@ -445,10 +450,11 @@ (exit 6))) (sqlite3:finalize! db) (set! *didsomething* #t)))) (if (or (args:get-arg "-setlog") ;; since setting up is so costly lets piggyback on -test-status + (args:get-arg "-set-toplog") (args:get-arg "-test-status") (args:get-arg "-runstep")) (if (not (getenv "MT_CMDINFO")) (begin (print "ERROR: MT_CMDINFO env var not set, commands -test-status, -runstep and -setlog must be called *inside* a megatest environment!") @@ -470,10 +476,12 @@ (print "Failed to setup, exiting") (exit 1))) (set! db (open-db)) (if (args:get-arg "-setlog") (test-set-log! db run-id test-name itemdat (args:get-arg "-setlog"))) + (if (args:get-arg "-set-toplog") + (test-set-toplog! db run-id test-name (args:get-arg "-set-toplog"))) (if (args:get-arg "-test-status") (test-set-status! db run-id test-name state status itemdat (args:get-arg "-m")) (if (and state status) (if (not (args:get-arg "-setlog")) (begin Index: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -116,10 +116,14 @@ (define (test-set-log! db run-id test-name itemdat logf) (let ((item-path (item-list->path itemdat))) (sqlite3:execute db "UPDATE tests SET final_logf=? WHERE run_id=? AND testname=? AND item_path=?;" logf run-id test-name item-path))) + +(define (test-set-toplog! db run-id test-name logf) + (sqlite3:execute db "UPDATE tests SET final_logf=? WHERE run_id=? AND testname=? AND item_path='';" + logf run-id test-name)) ;; ;; TODO: Converge this with db:get-test-info ;; (define (runs:get-test-info db run-id test-name item-path) ;; (let ((res #f)) ;; (vector #f #f #f #f #f #f))) ;; (sqlite3:for-each-row Index: tests/tests/runfirst/main.sh ================================================================== --- tests/tests/runfirst/main.sh +++ tests/tests/runfirst/main.sh @@ -2,8 +2,8 @@ # megatest -step wasting_time :state start :status n/a -m "This is a test step comment" # sleep 20 # megatest -step wasting_time :state end :status $? -megatest -runstep wasting_time -logpro wasting_time.logpro "sleep 20;echo all done eh?" -m "This is a test step comment" +$MT_MEGATEST -runstep wasting_time -logpro wasting_time.logpro "sleep 20;echo all done eh?" -m "This is a test step comment" -megatest -test-status :state COMPLETED :status PASS -m "This is a test level comment" +$MT_MEGATEST -test-status :state COMPLETED :status PASS -m "This is a test level comment" -set-toplog the_top_log.html