@@ -26,10 +26,11 @@ (define *db* #f) ;; this is only for the repl, do not use in general!!!! (include "common_records.scm") (include "key_records.scm") (include "db_records.scm") +(include "megatest-fossil-hash.scm") (define help (conc " Megatest, documentation at http://www.kiatoa.com/fossils/megatest version " megatest-version " license GPL, Copyright Matt Welland 2006-2012 @@ -111,11 +112,12 @@ Examples # Get test path, use '.' to get a single path or a specific path/file pattern megatest -test-files 'logs/*.log' -target ubuntu/n%/no% :runname w49% -testpatt test_mt% -Called as " (string-intersperse (argv) " "))) +Called as " (string-intersperse (argv) " ") " +Built from " megatest-fossil-hash )) ;; -gui : start a gui interface ;; -config fname : override the runconfig file with fname ;; process args @@ -204,14 +206,19 @@ ;;====================================================================== ;; Misc setup stuff ;;====================================================================== (set! *verbosity* (cond - ((args:get-arg "-debug")(string->number (args:get-arg "-debug"))) + ((string? (args:get-arg "-debug"))(string->number (args:get-arg "-debug"))) ((args:get-arg "-v") 2) ((args:get-arg "-q") 0) (else 1))) + +(if (not (number? *verbosity*)) + (begin + (print "ERROR: Invalid debug value " (args:get-arg "-debug")) + (exit))) ;;====================================================================== ;; Misc general calls ;;====================================================================== @@ -224,11 +231,11 @@ ;; Remove old run(s) ;;====================================================================== ;; since several actions can be specified on the command line the removal ;; is done first -(define (operate-on db action) +(define (operate-on action) (cond ((not (args:get-arg ":runname")) (debug:print 0 "ERROR: Missing required parameter for " action ", you must specify the run name pattern with :runname patt") (exit 2)) ((not (args:get-arg "-testpatt")) @@ -241,118 +248,111 @@ (if (not (car *configinfo*)) (begin (debug:print 0 "ERROR: Attempted " action "on test(s) but run area config file not found") (exit 1)) ;; put test parameters into convenient variables - (runs:operate-on db - action + (runs:operate-on action (args:get-arg ":runname") (args:get-arg "-testpatt") (args:get-arg "-itempatt") state: (args:get-arg ":state") status: (args:get-arg ":status") new-state-status: (args:get-arg "-set-state-status"))) - (sqlite3:finalize! db) (set! *didsomething* #t)))) (if (args:get-arg "-remove-runs") (general-run-call "-remove-runs" "remove runs" - (lambda (db target runname keys keynames keyvallst) - (operate-on db 'remove-runs)))) + (lambda (target runname keys keynames keyvallst) + (operate-on 'remove-runs)))) (if (args:get-arg "-set-state-status") (general-run-call "-set-state-status" "set state and status" - (lambda (db target runname keys keynames keyvallst) - (operate-on db 'set-state-status)))) + (lambda (target runname keys keynames keyvallst) + (operate-on 'set-state-status)))) ;;====================================================================== ;; Query runs ;;====================================================================== (if (args:get-arg "-list-runs") - (let* ((db (begin - (setup-for-run) - (open-db))) - (runpatt (args:get-arg "-list-runs")) - (testpatt (args:get-arg "-testpatt")) - (itempatt (args:get-arg "-itempatt")) - (runsdat (rdb:get-runs db runpatt #f #f '())) - (runs (db:get-rows runsdat)) - (header (db:get-header runsdat)) - (keys (rdb:get-keys db)) - (keynames (map key:get-fieldname keys))) - (if (not (args:get-arg "-server")) - (server:client-setup db)) - ;; Each run - (for-each - (lambda (run) - (debug:print 1 "Run: " - (string-intersperse (map (lambda (x) - (db:get-value-by-header run header x)) - keynames) "/") - "/" - (db:get-value-by-header run header "runname") - " status: " (db:get-value-by-header run header "state")) - (let ((run-id (db:get-value-by-header run header "id"))) - (let ((tests (rdb:get-tests-for-run db run-id testpatt itempatt '() '()))) - ;; Each test - (for-each - (lambda (test) - (format #t - " Test: ~25a State: ~15a Status: ~15a Runtime: ~5@as Time: ~22a Host: ~10a\n" - (conc (db:test-get-testname test) - (if (equal? (db:test-get-item-path test) "") - "" - (conc "(" (db:test-get-item-path test) ")"))) - (db:test-get-state test) - (db:test-get-status test) - (db:test-get-run_duration test) - (db:test-get-event_time test) - (db:test-get-host test)) - (if (not (or (equal? (db:test-get-status test) "PASS") - (equal? (db:test-get-status test) "WARN") - (equal? (db:test-get-state test) "NOT_STARTED"))) - (begin - (print " cpuload: " (db:test-get-cpuload test) - "\n diskfree: " (db:test-get-diskfree test) - "\n uname: " (db:test-get-uname test) - "\n rundir: " (db:test-get-rundir test) - ) - ;; Each test - (let ((steps (db:get-steps-for-test db (db:test-get-id test)))) - (for-each - (lambda (step) - (format #t - " Step: ~20a State: ~10a Status: ~10a Time ~22a\n" - (db:step-get-stepname step) - (db:step-get-state step) - (db:step-get-status step) - (db:step-get-event_time step))) - steps))))) - tests)))) - runs) - (set! *didsomething* #t) - )) + (if (setup-for-run) + (let* ((db #f) + (runpatt (args:get-arg "-list-runs")) + (testpatt (args:get-arg "-testpatt")) + (itempatt (args:get-arg "-itempatt")) + (runsdat (open-run-close db:get-runs db runpatt #f #f '())) + (runs (db:get-rows runsdat)) + (header (db:get-header runsdat)) + (keys (open-run-close db:get-keys db)) + (keynames (map key:get-fieldname keys))) + ;; Each run + (for-each + (lambda (run) + (debug:print 1 "Run: " + (string-intersperse (map (lambda (x) + (db:get-value-by-header run header x)) + keynames) "/") + "/" + (db:get-value-by-header run header "runname") + " status: " (db:get-value-by-header run header "state")) + (let ((run-id (open-run-close db:get-value-by-header run header "id"))) + (let ((tests (open-run-close db:get-tests-for-run db run-id testpatt itempatt '() '()))) + ;; Each test + (for-each + (lambda (test) + (format #t + " Test: ~25a State: ~15a Status: ~15a Runtime: ~5@as Time: ~22a Host: ~10a\n" + (conc (db:test-get-testname test) + (if (equal? (db:test-get-item-path test) "") + "" + (conc "(" (db:test-get-item-path test) ")"))) + (db:test-get-state test) + (db:test-get-status test) + (db:test-get-run_duration test) + (db:test-get-event_time test) + (db:test-get-host test)) + (if (not (or (equal? (db:test-get-status test) "PASS") + (equal? (db:test-get-status test) "WARN") + (equal? (db:test-get-state test) "NOT_STARTED"))) + (begin + (print " cpuload: " (db:test-get-cpuload test) + "\n diskfree: " (db:test-get-diskfree test) + "\n uname: " (db:test-get-uname test) + "\n rundir: " (db:test-get-rundir test) + ) + ;; Each test + (let ((steps (open-run-close db:get-steps-for-test db (db:test-get-id test)))) + (for-each + (lambda (step) + (format #t + " Step: ~20a State: ~10a Status: ~10a Time ~22a\n" + (db:step-get-stepname step) + (db:step-get-state step) + (db:step-get-status step) + (db:step-get-event_time step))) + steps))))) + tests)))) + runs) + (set! *didsomething* #t) + ))) ;;====================================================================== ;; Start the server - can be done in conjunction with -runall or -runtests (one day...) ;;====================================================================== -(if (and (args:get-arg "-server") - (not (or (args:get-arg "-runall") - (args:get-arg "-runtests")))) +(if (args:get-arg "-server") (let* ((toppath (setup-for-run)) (db (if toppath (open-db) #f))) (debug:print 0 "INFO: Starting the standalone server") (if db (let* ((host:port (db:get-var db "SERVER")) ;; this doen't support multiple servers BUG!!!! (th2 (server:start db (args:get-arg "-server"))) (th3 (make-thread (lambda () - (server:keep-running db))))) + (server:keep-running db host:port))))) (thread-start! th3) (thread-join! th3)) (debug:print 0 "ERROR: Failed to setup for megatest")))) ;;====================================================================== @@ -376,17 +376,12 @@ ;; run all tests are are Not COMPLETED and PASS or CHECK (if (args:get-arg "-runall") (general-run-call "-runall" "run all tests" - (lambda (db target runname keys keynames keyvallst) -;; (let ((flags (make-hash-table))) -;; (for-each (lambda (parm) -;; (hash-table-set! flags parm (args:get-arg parm))) -;; (list "-rerun" "-force" "-itempatt")) - (runs:run-tests db - target + (lambda (target runname keys keynames keyvallst) + (runs:run-tests target runname (args:get-arg "-runtests") user args:arg-hash)))) ;; ) @@ -409,13 +404,12 @@ (if (args:get-arg "-runtests") (general-run-call "-runtests" "run a test" - (lambda (db target runname keys keynames keyvallst) - (runs:run-tests db - target + (lambda (target runname keys keynames keyvallst) + (runs:run-tests target runname (args:get-arg "-runtests") user args:arg-hash)))) @@ -425,13 +419,12 @@ (if (args:get-arg "-rollup") (general-run-call "-rollup" "rollup tests" - (lambda (db target runname keys keynames keyvallst) - (runs:rollup-run db - keys + (lambda (target runname keys keynames keyvallst) + (runs:rollup-run keys (keys->alist keys "na") (args:get-arg ":runname") user)))) ;;====================================================================== @@ -440,12 +433,12 @@ (if (or (args:get-arg "-lock")(args:get-arg "-unlock")) (general-run-call (if (args:get-arg "-lock") "-lock" "-unlock") "lock/unlock tests" - (lambda (db target runname keys keynames keyvallst) - (runs:handle-locking db + (lambda (target runname keys keynames keyvallst) + (runs:handle-locking target keys (args:get-arg ":runname") (args:get-arg "-lock") (args:get-arg "-unlock") @@ -478,28 +471,26 @@ (exit 1))) (if (not (setup-for-run)) (begin (debug:print 0 "Failed to setup, giving up on -test-paths or -test-files, exiting") (exit 1))) - (set! db (open-db)) - (if (not (args:get-arg "-server")) - (server:client-setup db)) (let* ((itempatt (args:get-arg "-itempatt")) - (keys (rdb:get-keys db)) + (keys (open-run-close db:get-keys db)) (keynames (map key:get-fieldname keys)) - (paths (rdb:test-get-paths-matching db keynames target (args:get-arg "-test-files")))) + (paths (open-run-close db:test-get-paths-matching db keynames target (args:get-arg "-test-files")))) (set! *didsomething* #t) (for-each (lambda (path) (print path)) paths))) ;; else do a general-run-call (general-run-call "-test-files" "Get paths to test" - (lambda (db target runname keys keynames keyvallst) - (let* ((itempatt (args:get-arg "-itempatt")) - (paths (rdb:test-get-paths-matching db keynames target (args:get-arg "-test-files")))) + (lambda (target runname keys keynames keyvallst) + (let* ((db #f) + (itempatt (args:get-arg "-itempatt")) + (paths (open-run-close db:test-get-paths-matching db keynames target (args:get-arg "-test-files")))) (for-each (lambda (path) (print path)) paths)))))) ;;====================================================================== @@ -528,28 +519,26 @@ (exit 1))) (if (not (setup-for-run)) (begin (debug:print 0 "Failed to setup, giving up on -archive, exiting") (exit 1))) - (set! db (open-db)) - (if (not (args:get-arg "-server")) - (server:client-setup db)) (let* ((itempatt (args:get-arg "-itempatt")) - (keys (rdb:get-keys db)) + (keys (open-run-close db:get-keys db)) (keynames (map key:get-fieldname keys)) - (paths (db:test-get-paths-matching db keynames target))) + (paths (open-run-close db:test-get-paths-matching db keynames target))) (set! *didsomething* #t) (for-each (lambda (path) (print path)) paths))) ;; else do a general-run-call (general-run-call "-test-paths" "Get paths to tests" - (lambda (db target runname keys keynames keyvallst) - (let* ((itempatt (args:get-arg "-itempatt")) - (paths (db:test-get-paths-matching db keynames target))) + (lambda (target runname keys keynames keyvallst) + (let* ((db #f) + (itempatt (args:get-arg "-itempatt")) + (paths (open-run-close db:test-get-paths-matching db keynames target))) (for-each (lambda (path) (print path)) paths)))))) ;;====================================================================== @@ -558,17 +547,18 @@ (if (args:get-arg "-extract-ods") (general-run-call "-extract-ods" "Make ods spreadsheet" - (lambda (db target runname keys keynames keyvallst) - (let ((outputfile (args:get-arg "-extract-ods")) + (lambda (target runname keys keynames keyvallst) + (let ((db #f) + (outputfile (args:get-arg "-extract-ods")) (runspatt (args:get-arg ":runname")) (pathmod (args:get-arg "-pathmod")) (keyvalalist (keys->alist keys "%"))) (debug:print 2 "Extract ods, outputfile: " outputfile " runspatt: " runspatt " keyvalalist: " keyvalalist) - (db:extract-ods-file db outputfile keyvalalist (if runspatt runspatt "%") pathmod))))) + (open-run-close db:extract-ods-file db outputfile keyvalalist (if runspatt runspatt "%") pathmod))))) ;;====================================================================== ;; execute the test ;; - gets called on remote host ;; - receives info from the -execute param @@ -606,19 +596,16 @@ (change-directory testpath) (if (not (setup-for-run)) (begin (debug:print 0 "Failed to setup, exiting") (exit 1))) - (set! db (open-db)) - (if (not (args:get-arg "-server")) - (server:client-setup db)) (if (and state status) - (rdb:teststep-set-status! db test-id step state status itemdat (args:get-arg "-m") logfile) + (open-run-close db:teststep-set-status! db test-id step state status (args:get-arg "-m") logfile) (begin (debug:print 0 "ERROR: You must specify :state and :status with every call to -step") (exit 6))) - (sqlite3:finalize! db) + (if db (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") @@ -645,28 +632,29 @@ (change-directory testpath) (if (not (setup-for-run)) (begin (debug:print 0 "Failed to setup, exiting") (exit 1))) - (set! db (open-db)) - (if (not (args:get-arg "-server")) - (server:client-setup db)) + + ;; can setup as client for server mode now + (server:client-setup) + (if (args:get-arg "-load-test-data") ;; has sub commands that are rdb: - (db:load-test-data db test-id)) + (open-run-close db:load-test-data db test-id)) (if (args:get-arg "-setlog") (let ((logfname (args:get-arg "-setlog"))) - (rdb:test-set-log! db test-id logfname))) + (open-run-close db:test-set-log! db test-id logfname))) (if (args:get-arg "-set-toplog") - (rtests:test-set-toplog! db run-id test-name (args:get-arg "-set-toplog"))) + (open-run-close tests:test-set-toplog! db run-id test-name (args:get-arg "-set-toplog"))) (if (args:get-arg "-summarize-items") - (tests:summarize-items db run-id test-name #t)) ;; do force here + (open-run-close tests:summarize-items db run-id test-name #t)) ;; do force here (if (args:get-arg "-runstep") (if (null? remargs) (begin (debug:print 0 "ERROR: nothing specified to run!") - (sqlite3:finalize! db) + (if db (sqlite3:finalize! db)) (exit 6)) (let* ((stepname (args:get-arg "-runstep")) (logprofile (args:get-arg "-logpro")) (logfile (conc stepname ".log")) (cmd (if (null? remargs) #f (car remargs))) @@ -679,23 +667,17 @@ (else ">&"))) (fullcmd (conc "(" (string-intersperse (cons cmd params) " ") ") " redir " " logfile))) ;; mark the start of the test - (rdb:teststep-set-status! db test-id stepname "start" "n/a" itemdat (args:get-arg "-m") logfile) - ;; close the db - ;; (sqlite3:finalize! db) + (open-run-close db:teststep-set-status! db test-id stepname "start" "n/a" (args:get-arg "-m") logfile) ;; run the test step (debug:print 2 "INFO: Running \"" fullcmd "\"") (change-directory startingdir) (set! exitstat (system fullcmd)) ;; cmd params)) (set! *globalexitstatus* exitstat) (change-directory testpath) - ;; re-open the db - ;; (set! db (open-db)) - ;; (if (not (args:get-arg "-server")) - ;; (server:client-setup db)) ;; run logpro if applicable ;; (process-run "ls" (list "/foo" "2>&1" "blah.log")) (if logprofile (let* ((htmllogfile (conc stepname ".html")) (oldexitstat exitstat) (cmd (string-intersperse (list "logpro" logprofile htmllogfile "<" logfile ">" (conc stepname "_logpro.log")) " "))) @@ -702,19 +684,14 @@ (debug:print 2 "INFO: running \"" cmd "\"") (change-directory startingdir) (set! exitstat (system cmd)) (set! *globalexitstatus* exitstat) ;; no necessary (change-directory testpath) - (rdb:test-set-log! db test-id htmllogfile))) + (open-run-close db:test-set-log! db test-id htmllogfile))) (let ((msg (args:get-arg "-m"))) - (rdb:teststep-set-status! db test-id stepname "end" exitstat itemdat msg logfile)) - ;; (sqlite3:finalize! db) - ;;(if (not (eq? exitstat 0)) - ;; (exit 254)) ;; (exit exitstat) doesn't work?!? - ;; open the db - ;; mark the end of the test - ))) + (open-run-close db:teststep-set-status! db test-id stepname "end" exitstat msg logfile)) + ))) (if (or (args:get-arg "-test-status") (args:get-arg "-set-values")) (let ((newstatus (cond ((number? status) (if (equal? status 0) "PASS" "FAIL")) ((and (string? status) @@ -731,15 +708,17 @@ (if (and (args:get-arg "-test-status") (or (not state) (not status))) (begin (debug:print 0 "ERROR: You must specify :state and :status with every call to -test-status\n" help) - (sqlite3:finalize! db) + ;; (sqlite3:finalize! db) (exit 6))) - (let ((msg (args:get-arg "-m"))) - (rtests:test-set-status! db test-id state newstatus msg otherdata)))) - (sqlite3:finalize! db) + (let* ((msg (args:get-arg "-m")) + (numoth (length (hash-table-keys otherdata)))) + ;; Convert to rpc inside the tests:test-set-status! call, not here + (tests:test-set-status! test-id state newstatus msg otherdata)))) + (if db (sqlite3:finalize! db)) (set! *didsomething* #t)))) ;;====================================================================== ;; Various helper commands can go below here ;;====================================================================== @@ -749,16 +728,13 @@ (keys #f)) (if (not (setup-for-run)) (begin (debug:print 0 "Failed to setup, exiting") (exit 1))) - (set! db (open-db)) - (if (not (args:get-arg "-server")) - (server:client-setup db)) - (set! keys (rdb:get-keys db)) + (set! keys (open-run-close db:get-keys db)) (debug:print 1 "Keys: " (string-intersperse (map key:get-fieldname keys) ", ")) - (sqlite3:finalize! db) + (if db (sqlite3:finalize! db)) (set! *didsomething* #t))) (if (args:get-arg "-gui") (begin (debug:print 0 "Look at the dashboard for now") @@ -783,14 +759,11 @@ (begin (if (not (setup-for-run)) (begin (debug:print 0 "Failed to setup, exiting") (exit 1))) - ;; now can find our db - (set! db (open-db)) - (patch-db db) - (sqlite3:finalize! db) + (open-run-close patch-db #f) (set! *didsomething* #t))) ;;====================================================================== ;; Update the tests meta data from the testconfig files ;;====================================================================== @@ -800,15 +773,11 @@ (if (not (setup-for-run)) (begin (debug:print 0 "Failed to setup, exiting") (exit 1))) ;; now can find our db - (set! db (open-db)) - (if (not (args:get-arg "-server")) - (server:client-setup db)) - (runs:update-all-test_meta db) - (sqlite3:finalize! db) + (open-run-close runs:update-all-test_meta db) (set! *didsomething* #t))) ;;====================================================================== ;; Start a repl ;;====================================================================== @@ -818,11 +787,11 @@ (db (if toppath (open-db) #f))) (if db (begin (set! *db* db) (if (not (args:get-arg "-server")) - (server:client-setup db)) + (server:client-setup)) (import readline) (import apropos) (gnu-history-install-file-manager (string-append (or (get-environment-variable "HOME") ".") "/.megatest_history")) @@ -835,10 +804,12 @@ ;;====================================================================== (if (not *didsomething*) (debug:print 0 help)) +;; (if *runremote* (rpc:close-all-connections!)) + (if (not (eq? *globalexitstatus* 0)) (if (or (args:get-arg "-runtests")(args:get-arg "-runall")) (begin (debug:print 0 "NOTE: Subprocesses with non-zero exit code detected: " *globalexitstatus*) (exit 0))