Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -37,32 +37,35 @@ "state TEXT DEFAULT ''," "status TEXT DEFAULT ''," "owner TEXT DEFAULT ''," "event_time TIMESTAMP," "comment TEXT DEFAULT ''," + "fail_count INTEGER DEFAULT 0," + "pass_count INTEGER DEFAULT 0," "CONSTRAINT runsconstraint UNIQUE (runname" (if havekeys "," "") keystr "));")) (sqlite3:execute db (conc "CREATE INDEX runs_index ON runs (runname" (if havekeys "," "") keystr ");")) (sqlite3:execute db "CREATE TABLE tests (id INTEGER PRIMARY KEY, run_id INTEGER, testname TEXT, - itempath TEXT, host TEXT DEFAULT 'n/a', cpuload REAL DEFAULT -1, diskfree INTEGER DEFAULT -1, uname TEXT DEFAULT 'n/a', rundir TEXT DEFAULT 'n/a', item_path TEXT DEFAULT '', state TEXT DEFAULT 'NOT_STARTED', - status TEXT DEFAULT 'n/a', + status TEXT DEFAULT 'FAIL', attemptnum INTEGER DEFAULT 0, final_logf TEXT DEFAULT 'logs/final.log', logdat BLOB, run_duration INTEGER DEFAULT 0, comment TEXT DEFAULT '', event_time TIMESTAMP, + fail_count INTEGER DEFAULT 0, + pass_count INTEGER DEFAULT 0, CONSTRAINT testsconstraint UNIQUE (run_id, testname, item_path) );") (sqlite3:execute db "CREATE INDEX tests_index ON tests (run_id, testname);") (sqlite3:execute db "CREATE VIEW runs_tests AS SELECT * FROM runs INNER JOIN tests ON runs.id=tests.run_id;") (sqlite3:execute db "CREATE TABLE test_steps @@ -237,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 @@ -6,11 +6,11 @@ ;; This program is distributed WITHOUT ANY WARRANTY; without even the ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ;; PURPOSE. (include "common.scm") -(define megatest-version 1.04) +(define megatest-version 1.05) (define help (conc " Megatest, documentation at http://www.kiatoa.com/fossils/megatest version " megatest-version " license GPL, Copyright Matt Welland 2006-2011 @@ -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 @@ -74,25 +74,56 @@ (conc "SELECT " keystr " FROM runs WHERE runname like ? " key-patt ";") runnamepatt) (vector header res))) (define (register-test db run-id test-name item-path) - (sqlite3:execute db "INSERT OR IGNORE INTO tests (run_id,testname,event_time,item_path) VALUES (?,?,strftime('%s','now'),?);" run-id test-name item-path)) + (let ((item-paths (if (equal? item-path "") + (list item-path) + (list item-path "")))) + (for-each + (lambda (pth) + (sqlite3:execute db "INSERT OR IGNORE INTO tests (run_id,testname,event_time,item_path) VALUES (?,?,strftime('%s','now'),?);" run-id test-name pth)) + item-paths))) + +;; (define db (open-db)) +;; (test-set-status! db 2 "runfirst" "COMPLETED" "PASS" "summer") (define (test-set-status! db run-id test-name state status itemdat-or-path . comment) (let ((item-path (if (string? itemdat-or-path) itemdat-or-path (item-list->path itemdat-or-path)))) (sqlite3:execute db "UPDATE tests SET state=?,status=?,event_time=strftime('%s','now') WHERE run_id=? AND testname=? AND item_path=?;" state status run-id test-name item-path) + (if (and (not (equal? item-path "")) ;; need to update the top test record if PASS or FAIL and this is a subtest + (or (equal? status "PASS") + (equal? status "FAIL"))) + (begin + (sqlite3:execute + db + "UPDATE tests + SET fail_count=(SELECT count(id) FROM tests WHERE run_id=? AND testname=? AND item_path != '' AND status='FAIL'), + pass_count=(SELECT count(id) FROM tests WHERE run_id=? AND testname=? AND item_path != '' AND status='PASS') + WHERE run_id=? AND testname=? AND item_path='';" + run-id test-name run-id test-name run-id test-name) + (sqlite3:execute + db + "UPDATE tests + SET state='COMPLETED', + status=CASE WHEN fail_count > 0 THEN 'FAIL' WHEN pass_count > 0 AND fail_count=0 THEN 'PASS' ELSE 'UNKNOWN' END + WHERE run_id=? AND testname=? AND item_path='';" + run-id test-name))) (if (and (not (null? comment)) (car comment)) (sqlite3:execute db "UPDATE tests SET comment=? WHERE run_id=? AND testname=? AND item_path=?;" (car comment) run-id test-name item-path)))) (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