0a116daff3 2012-04-02 mrwellan: ;; Copyright 2006-2012, Matthew Welland. ae6dbecf17 2011-05-02 matt: ;; ae6dbecf17 2011-05-02 matt: ;; This program is made available under the GNU GPL version 2.0 or ae6dbecf17 2011-05-02 matt: ;; greater. See the accompanying file COPYING for details. ae6dbecf17 2011-05-02 matt: ;; ae6dbecf17 2011-05-02 matt: ;; This program is distributed WITHOUT ANY WARRANTY; without even the ae6dbecf17 2011-05-02 matt: ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ae6dbecf17 2011-05-02 matt: ;; PURPOSE. ae6dbecf17 2011-05-02 matt: 3469edbbf7 2011-10-09 matt: ;; (include "common.scm") 3469edbbf7 2011-10-09 matt: ;; (include "megatest-version.scm") 3469edbbf7 2011-10-09 matt: 3e2cee87de 2012-03-13 matt: (use sqlite3 srfi-1 posix regex regex-case srfi-69 base64 format readline apropos) ;; (srfi 18) extras) e0c173490e 2011-10-09 matt: (import (prefix sqlite3 sqlite3:)) e0c173490e 2011-10-09 matt: (import (prefix base64 base64:)) e0c173490e 2011-10-09 matt: 3469edbbf7 2011-10-09 matt: (declare (uses common)) 3469edbbf7 2011-10-09 matt: (declare (uses megatest-version)) 3469edbbf7 2011-10-09 matt: (declare (uses margs)) 3469edbbf7 2011-10-09 matt: (declare (uses runs)) 3469edbbf7 2011-10-09 matt: (declare (uses launch)) ad71efd688 2012-02-24 matt: (declare (uses server)) 3e2cee87de 2012-03-13 matt: (declare (uses tests)) 3de9db9a0f 2012-04-23 matt: (declare (uses genexample)) 2c8647e6a0 2012-02-26 matt: 2c8647e6a0 2012-02-26 matt: (define *db* #f) ;; this is only for the repl, do not use in general!!!! 3469edbbf7 2011-10-09 matt: 3469edbbf7 2011-10-09 matt: (include "common_records.scm") e0c173490e 2011-10-09 matt: (include "key_records.scm") e0c173490e 2011-10-09 matt: (include "db_records.scm") ae6dbecf17 2011-05-02 matt: ae6dbecf17 2011-05-02 matt: (define help (conc " c4edfbcd13 2011-05-05 mrwellan: Megatest, documentation at http://www.kiatoa.com/fossils/megatest ae6dbecf17 2011-05-02 matt: version " megatest-version " 0a116daff3 2012-04-02 mrwellan: license GPL, Copyright Matt Welland 2006-2012 ae6dbecf17 2011-05-02 matt: ae6dbecf17 2011-05-02 matt: Usage: megatest [options] ae6dbecf17 2011-05-02 matt: -h : this help ae6dbecf17 2011-05-02 matt: ff89a30e63 2012-04-19 mrwellan: Launching and managing runs cf78fcded0 2011-05-04 matt: -runall : run all tests that are not state COMPLETED and status PASS, cf78fcded0 2011-05-04 matt: CHECK or KILLED ae6dbecf17 2011-05-02 matt: -runtests tst1,tst2 ... : run tests ff89a30e63 2012-04-19 mrwellan: -remove-runs : remove the data for a run, requires :runname, -testpatt and ff89a30e63 2012-04-19 mrwellan: -itempatt be set. Optionally use :state and :status ff89a30e63 2012-04-19 mrwellan: -set-state-status X,Y : set state to X and status to Y, requires controls per -remove-runs ff89a30e63 2012-04-19 mrwellan: -rerun FAIL,WARN... : force re-run for tests with specificed status(s) ff89a30e63 2012-04-19 mrwellan: -rollup : fill run (set by :runname) with latest test(s) from ff89a30e63 2012-04-19 mrwellan: prior runs with same keys ff89a30e63 2012-04-19 mrwellan: -lock : lock run specified by target and runname ff89a30e63 2012-04-19 mrwellan: -unlock : unlock run specified by target and runname ae6dbecf17 2011-05-02 matt: ff89a30e63 2012-04-19 mrwellan: Selectors (e.g. use for -runtests, -remove-runs, -set-state-status, -list-runs etc.) ff89a30e63 2012-04-19 mrwellan: -target key1/key2/... : run for key1, key2, etc. ff89a30e63 2012-04-19 mrwellan: -reqtarg key1/key2/... : run for key1, key2, etc. but key1/key2 must be in runconfig ff89a30e63 2012-04-19 mrwellan: -testpatt patt : % is wildcard ff89a30e63 2012-04-19 mrwellan: -itempatt patt : % is wildcard ff89a30e63 2012-04-19 mrwellan: :runname : required, name for this particular test run ff89a30e63 2012-04-19 mrwellan: :state : Applies to runs, tests or steps depending on context ff89a30e63 2012-04-19 mrwellan: :status : Applies to runs, tests or steps depending on context ff89a30e63 2012-04-19 mrwellan: ff89a30e63 2012-04-19 mrwellan: Test helpers (for use inside tests) ae6dbecf17 2011-05-02 matt: -step stepname ae6dbecf17 2011-05-02 matt: -test-status : set the state and status of a test (use :state and :status) ae6dbecf17 2011-05-02 matt: -setlog logfname : set the path/filename to the final log relative to the test ae6dbecf17 2011-05-02 matt: directory. may be used with -test-status 00761e1112 2011-05-15 matt: -set-toplog logfname : set the overall log for a suite of sub-tests 42b834da20 2011-08-02 mrwellan: -summarize-items : for an itemized test create a summary html ae6dbecf17 2011-05-02 matt: -m comment : insert a comment for this test ae6dbecf17 2011-05-02 matt: ff89a30e63 2012-04-19 mrwellan: Test data capture ff89a30e63 2012-04-19 mrwellan: -set-values : update or set values in the testdata table d406fee8c4 2011-09-12 matt: :category : set the category field (optional) d406fee8c4 2011-09-12 matt: :variable : set the variable name (optional) d406fee8c4 2011-09-12 matt: :value : value measured (required) d406fee8c4 2011-09-12 matt: :expected : value expected (required) d406fee8c4 2011-09-12 matt: :tol : |value-expect| <= tol (required, can be <, >, >=, <= or number) d406fee8c4 2011-09-12 matt: :units : name of the units for value, expected_value etc. (optional) dd5766961c 2011-09-06 matt: -load-test-data : read test specific data for storage in the test_data table dd5766961c 2011-09-06 matt: from standard in. Each line is comma delimited with four dd5766961c 2011-09-06 matt: fields category,variable,value,comment ae6dbecf17 2011-05-02 matt: ae6dbecf17 2011-05-02 matt: Queries ae6dbecf17 2011-05-02 matt: -list-runs patt : list runs matching pattern \"patt\", % is the wildcard ae6dbecf17 2011-05-02 matt: -showkeys : show the keys used in this megatest setup 5c2e1f9b03 2012-04-22 matt: -test-path targpatt : get the most recent test path(s) matching targpatt e.g. %/%... e6213e8dbb 2012-01-27 matt: returns list sorted by age ascending, see examples below ae6dbecf17 2011-05-02 matt: e38c4a9bdd 2011-05-03 matt: Misc 3bb0b5e9f9 2011-07-19 matt: -rebuild-db : bring the database schema up to date ebea00e4bb 2011-08-24 mrwellan: -update-meta : update the tests metadata for all tests 3cbc9cb854 2011-10-23 matt: -env2file fname : write the environment to fname.csh and fname.sh a9efabed17 2011-10-31 matt: -setvars VAR1=val1,VAR2=val2 : Add environment variables to a run NB// these are a9efabed17 2011-10-31 matt: overwritten by values set in config files. ad71efd688 2012-02-24 matt: -server -|hostname : start the server (reduces contention on megatest.db), use ad71efd688 2012-02-24 matt: - to automatically figure out hostname 2c8647e6a0 2012-02-26 matt: -repl : start a repl (useful for extending megatest) ad71efd688 2012-02-24 matt: 3cbc9cb854 2011-10-23 matt: Spreadsheet generation 1db4f07cc5 2012-01-11 mrwellan: -extract-ods fname.ods : extract an open document spreadsheet from the database 41350e06ff 2011-10-14 matt: -pathmod path : insert path, i.e. path/runame/itempath/logfile.html 41350e06ff 2011-10-14 matt: will clear the field if no rundir/testname/itempath/logfile 6d0ac02863 2011-10-14 mrwellan: if it contains forward slashes the path will be converted 6d0ac02863 2011-10-14 mrwellan: to windows style 3de9db9a0f 2012-04-23 matt: Getting started 3de9db9a0f 2012-04-23 matt: -gen-megatest-area : create a skeleton megatest area. You will be prompted for paths 3de9db9a0f 2012-04-23 matt: -gen-megatest-test : create a skeleton megatest test. You will be prompted for info 41350e06ff 2011-10-14 matt: e6213e8dbb 2012-01-27 matt: Examples e6213e8dbb 2012-01-27 matt: 5c2e1f9b03 2012-04-22 matt: # Get test path, the '.' is required, could use '*' or a specific path/file 5c2e1f9b03 2012-04-22 matt: megatest -test-path . -target ubuntu/n%/no% :runname w49% -testpatt test_mt% ae6dbecf17 2011-05-02 matt: ae6dbecf17 2011-05-02 matt: Called as " (string-intersperse (argv) " "))) ae6dbecf17 2011-05-02 matt: ae6dbecf17 2011-05-02 matt: ;; -gui : start a gui interface ae6dbecf17 2011-05-02 matt: ;; -config fname : override the runconfig file with fname ae6dbecf17 2011-05-02 matt: ae6dbecf17 2011-05-02 matt: ;; process args ae6dbecf17 2011-05-02 matt: (define remargs (args:get-args ae6dbecf17 2011-05-02 matt: (argv) ae6dbecf17 2011-05-02 matt: (list "-runtests" ;; run a specific test ae6dbecf17 2011-05-02 matt: "-config" ;; override the config file name ae6dbecf17 2011-05-02 matt: "-execute" ;; run the command encoded in the base64 parameter ae6dbecf17 2011-05-02 matt: "-step" ae6dbecf17 2011-05-02 matt: ":runname" c5b61052dd 2011-10-13 matt: "-target" c5b61052dd 2011-10-13 matt: "-reqtarg" ae6dbecf17 2011-05-02 matt: ":item" ae6dbecf17 2011-05-02 matt: ":runname" ae6dbecf17 2011-05-02 matt: ":state" ae6dbecf17 2011-05-02 matt: ":status" ae6dbecf17 2011-05-02 matt: "-list-runs" c4edfbcd13 2011-05-05 mrwellan: "-testpatt" c4edfbcd13 2011-05-05 mrwellan: "-itempatt" ae6dbecf17 2011-05-02 matt: "-setlog" 00761e1112 2011-05-15 matt: "-set-toplog" ae6dbecf17 2011-05-02 matt: "-runstep" ae6dbecf17 2011-05-02 matt: "-logpro" e0413b29e1 2011-05-05 matt: "-m" d73b2c1642 2011-06-27 mrwellan: "-rerun" d7ffcddcac 2011-08-11 matt: "-days" d7ffcddcac 2011-08-11 matt: "-rename-run" d7ffcddcac 2011-08-11 matt: "-to" ebea00e4bb 2011-08-24 mrwellan: ;; values and messages d406fee8c4 2011-09-12 matt: ":category" d406fee8c4 2011-09-12 matt: ":variable" ebea00e4bb 2011-08-24 mrwellan: ":value" d406fee8c4 2011-09-12 matt: ":expected" ebea00e4bb 2011-08-24 mrwellan: ":tol" b2e635cc07 2011-08-24 mrwellan: ":units" ebea00e4bb 2011-08-24 mrwellan: ;; misc ad71efd688 2012-02-24 matt: "-server" 9940aff1c0 2011-09-08 mrwellan: "-extract-ods" 41350e06ff 2011-10-14 matt: "-pathmod" 1b0a53f5b9 2011-10-09 matt: "-env2file" a9efabed17 2011-10-31 matt: "-setvars" 29cc9e826e 2012-04-12 matt: "-set-state-status" bcc1c96231 2011-07-11 mrwellan: "-debug" ;; for *verbosity* > 2 3de9db9a0f 2012-04-23 matt: "-gen-megatest-test" 3e2cee87de 2012-03-13 matt: "-override-timeout" ae6dbecf17 2011-05-02 matt: ) ae6dbecf17 2011-05-02 matt: (list "-h" ae6dbecf17 2011-05-02 matt: "-force" ae6dbecf17 2011-05-02 matt: "-xterm" ae6dbecf17 2011-05-02 matt: "-showkeys" ae6dbecf17 2011-05-02 matt: "-test-status" ebea00e4bb 2011-08-24 mrwellan: "-set-values" dd5766961c 2011-09-06 matt: "-load-test-data" 42b834da20 2011-08-02 mrwellan: "-summarize-items" ae6dbecf17 2011-05-02 matt: "-gui" ad71efd688 2012-02-24 matt: ;; misc ad71efd688 2012-02-24 matt: "-archive" 2c8647e6a0 2012-02-26 matt: "-repl" 34efa31216 2012-04-04 mrwellan: "-lock" ff89a30e63 2012-04-19 mrwellan: "-unlock" e6213e8dbb 2012-01-27 matt: ;; queries e6213e8dbb 2012-01-27 matt: "-test-paths" ;; get path(s) to a test, ordered by youngest first 5c2e1f9b03 2012-04-22 matt: "-test-path" ;; -test-paths is deprecated e6213e8dbb 2012-01-27 matt: ae6dbecf17 2011-05-02 matt: "-runall" ;; run all tests 09102f8425 2011-05-11 matt: "-remove-runs" 1ea16b0407 2011-06-28 mrwellan: "-usequeue" 3bb0b5e9f9 2011-07-19 matt: "-rebuild-db" d7ffcddcac 2011-08-11 matt: "-rollup" ebea00e4bb 2011-08-24 mrwellan: "-update-meta" 3de9db9a0f 2012-04-23 matt: "-gen-megatest-area" ad71efd688 2012-02-24 matt: bcc1c96231 2011-07-11 mrwellan: "-v" ;; verbose 2, more than normal (normal is 1) bcc1c96231 2011-07-11 mrwellan: "-q" ;; quiet 0, errors/warnings only ae6dbecf17 2011-05-02 matt: ) ae6dbecf17 2011-05-02 matt: args:arg-hash ae6dbecf17 2011-05-02 matt: 0)) ae6dbecf17 2011-05-02 matt: ae6dbecf17 2011-05-02 matt: (if (args:get-arg "-h") ae6dbecf17 2011-05-02 matt: (begin ae6dbecf17 2011-05-02 matt: (print help) ae6dbecf17 2011-05-02 matt: (exit))) ae6dbecf17 2011-05-02 matt: ae6dbecf17 2011-05-02 matt: (define *didsomething* #f) 1ea16b0407 2011-06-28 mrwellan: 1ea16b0407 2011-06-28 mrwellan: ;;====================================================================== 1ea16b0407 2011-06-28 mrwellan: ;; Misc setup stuff 1ea16b0407 2011-06-28 mrwellan: ;;====================================================================== bcc1c96231 2011-07-11 mrwellan: bcc1c96231 2011-07-11 mrwellan: (set! *verbosity* (cond bcc1c96231 2011-07-11 mrwellan: ((args:get-arg "-debug")(string->number (args:get-arg "-debug"))) bcc1c96231 2011-07-11 mrwellan: ((args:get-arg "-v") 2) bcc1c96231 2011-07-11 mrwellan: ((args:get-arg "-q") 0) bcc1c96231 2011-07-11 mrwellan: (else 1))) bcc1c96231 2011-07-11 mrwellan: bcc1c96231 2011-07-11 mrwellan: ;;====================================================================== 1b0a53f5b9 2011-10-09 matt: ;; Misc general calls 1b0a53f5b9 2011-10-09 matt: ;;====================================================================== 1b0a53f5b9 2011-10-09 matt: 1b0a53f5b9 2011-10-09 matt: (if (args:get-arg "-env2file") 1b0a53f5b9 2011-10-09 matt: (begin 1b0a53f5b9 2011-10-09 matt: (save-environment-as-files (args:get-arg "-env2file")) 1b0a53f5b9 2011-10-09 matt: (set! *didsomething* #t))) 1b0a53f5b9 2011-10-09 matt: 1b0a53f5b9 2011-10-09 matt: ;;====================================================================== 5411a1be29 2011-05-11 mrwellan: ;; Remove old run(s) 5411a1be29 2011-05-11 mrwellan: ;;====================================================================== 5411a1be29 2011-05-11 mrwellan: d73b2c1642 2011-06-27 mrwellan: ;; since several actions can be specified on the command line the removal d73b2c1642 2011-06-27 mrwellan: ;; is done first 29cc9e826e 2012-04-12 matt: (define (operate-on db action) 5411a1be29 2011-05-11 mrwellan: (cond 5411a1be29 2011-05-11 mrwellan: ((not (args:get-arg ":runname")) 29cc9e826e 2012-04-12 matt: (debug:print 0 "ERROR: Missing required parameter for " action ", you must specify the run name pattern with :runname patt") 5411a1be29 2011-05-11 mrwellan: (exit 2)) 5411a1be29 2011-05-11 mrwellan: ((not (args:get-arg "-testpatt")) 29cc9e826e 2012-04-12 matt: (debug:print 0 "ERROR: Missing required parameter for " action ", you must specify the test pattern with -testpatt") 5411a1be29 2011-05-11 mrwellan: (exit 3)) 5411a1be29 2011-05-11 mrwellan: ((not (args:get-arg "-itempatt")) 29cc9e826e 2012-04-12 matt: (print "ERROR: Missing required parameter for " action ", you must specify the items with -itempatt") 5411a1be29 2011-05-11 mrwellan: (exit 4)) 29cc9e826e 2012-04-12 matt: (else 29cc9e826e 2012-04-12 matt: (if (not (car *configinfo*)) 29cc9e826e 2012-04-12 matt: (begin 29cc9e826e 2012-04-12 matt: (debug:print 0 "ERROR: Attempted " action "on test(s) but run area config file not found") 29cc9e826e 2012-04-12 matt: (exit 1)) 29cc9e826e 2012-04-12 matt: ;; put test parameters into convenient variables 29cc9e826e 2012-04-12 matt: (runs:operate-on db 29cc9e826e 2012-04-12 matt: action 29cc9e826e 2012-04-12 matt: (args:get-arg ":runname") 29cc9e826e 2012-04-12 matt: (args:get-arg "-testpatt") 29cc9e826e 2012-04-12 matt: (args:get-arg "-itempatt") 29cc9e826e 2012-04-12 matt: state: (args:get-arg ":state") 29cc9e826e 2012-04-12 matt: status: (args:get-arg ":status") 29cc9e826e 2012-04-12 matt: new-state-status: (args:get-arg "-set-state-status"))) 29cc9e826e 2012-04-12 matt: (sqlite3:finalize! db) 29cc9e826e 2012-04-12 matt: (set! *didsomething* #t)))) 5411a1be29 2011-05-11 mrwellan: 5411a1be29 2011-05-11 mrwellan: (if (args:get-arg "-remove-runs") fe1582c208 2012-01-23 matt: (general-run-call fe1582c208 2012-01-23 matt: "-remove-runs" fe1582c208 2012-01-23 matt: "remove runs" fe1582c208 2012-01-23 matt: (lambda (db target runname keys keynames keyvallst) 29cc9e826e 2012-04-12 matt: (operate-on db 'remove-runs)))) 29cc9e826e 2012-04-12 matt: 29cc9e826e 2012-04-12 matt: (if (args:get-arg "-set-state-status") 29cc9e826e 2012-04-12 matt: (general-run-call 29cc9e826e 2012-04-12 matt: "-set-state-status" 29cc9e826e 2012-04-12 matt: "set state and status" 29cc9e826e 2012-04-12 matt: (lambda (db target runname keys keynames keyvallst) 29cc9e826e 2012-04-12 matt: (operate-on db 'set-state-status)))) ae6dbecf17 2011-05-02 matt: ae6dbecf17 2011-05-02 matt: ;;====================================================================== ae6dbecf17 2011-05-02 matt: ;; Query runs ae6dbecf17 2011-05-02 matt: ;;====================================================================== ae6dbecf17 2011-05-02 matt: ae6dbecf17 2011-05-02 matt: (if (args:get-arg "-list-runs") ae6dbecf17 2011-05-02 matt: (let* ((db (begin ae6dbecf17 2011-05-02 matt: (setup-for-run) ae6dbecf17 2011-05-02 matt: (open-db))) ae6dbecf17 2011-05-02 matt: (runpatt (args:get-arg "-list-runs")) c4edfbcd13 2011-05-05 mrwellan: (testpatt (args:get-arg "-testpatt")) c4edfbcd13 2011-05-05 mrwellan: (itempatt (args:get-arg "-itempatt")) 2c8647e6a0 2012-02-26 matt: (runsdat (rdb:get-runs db runpatt #f #f '())) ae6dbecf17 2011-05-02 matt: (runs (db:get-rows runsdat)) ae6dbecf17 2011-05-02 matt: (header (db:get-header runsdat)) 2c8647e6a0 2012-02-26 matt: (keys (rdb:get-keys db)) ae6dbecf17 2011-05-02 matt: (keynames (map key:get-fieldname keys))) 35d5a09470 2012-02-26 matt: (if (not (args:get-arg "-server")) 35d5a09470 2012-02-26 matt: (server:client-setup db)) ae6dbecf17 2011-05-02 matt: ;; Each run ae6dbecf17 2011-05-02 matt: (for-each ae6dbecf17 2011-05-02 matt: (lambda (run) 46858112fb 2012-04-19 mrwellan: (debug:print 1 "Run: " ae6dbecf17 2011-05-02 matt: (string-intersperse (map (lambda (x) d73b2c1642 2011-06-27 mrwellan: (db:get-value-by-header run header x)) ae6dbecf17 2011-05-02 matt: keynames) "/") ae6dbecf17 2011-05-02 matt: "/" 46858112fb 2012-04-19 mrwellan: (db:get-value-by-header run header "runname") 46858112fb 2012-04-19 mrwellan: " status: " (db:get-value-by-header run header "state")) d73b2c1642 2011-06-27 mrwellan: (let ((run-id (db:get-value-by-header run header "id"))) c810f51721 2012-02-26 matt: (let ((tests (rdb:get-tests-for-run db run-id testpatt itempatt '() '()))) ae6dbecf17 2011-05-02 matt: ;; Each test ae6dbecf17 2011-05-02 matt: (for-each ae6dbecf17 2011-05-02 matt: (lambda (test) ae6dbecf17 2011-05-02 matt: (format #t ae6dbecf17 2011-05-02 matt: " Test: ~25a State: ~15a Status: ~15a Runtime: ~5@as Time: ~22a Host: ~10a\n" ae6dbecf17 2011-05-02 matt: (conc (db:test-get-testname test) ae6dbecf17 2011-05-02 matt: (if (equal? (db:test-get-item-path test) "") ae6dbecf17 2011-05-02 matt: "" ae6dbecf17 2011-05-02 matt: (conc "(" (db:test-get-item-path test) ")"))) ae6dbecf17 2011-05-02 matt: (db:test-get-state test) ae6dbecf17 2011-05-02 matt: (db:test-get-status test) ae6dbecf17 2011-05-02 matt: (db:test-get-run_duration test) ae6dbecf17 2011-05-02 matt: (db:test-get-event_time test) ae6dbecf17 2011-05-02 matt: (db:test-get-host test)) ae6dbecf17 2011-05-02 matt: (if (not (or (equal? (db:test-get-status test) "PASS") 6f9cfc22a7 2011-06-06 mrwellan: (equal? (db:test-get-status test) "WARN") 6f9cfc22a7 2011-06-06 mrwellan: (equal? (db:test-get-state test) "NOT_STARTED"))) ae6dbecf17 2011-05-02 matt: (begin ae6dbecf17 2011-05-02 matt: (print " cpuload: " (db:test-get-cpuload test) ae6dbecf17 2011-05-02 matt: "\n diskfree: " (db:test-get-diskfree test) ae6dbecf17 2011-05-02 matt: "\n uname: " (db:test-get-uname test) ae6dbecf17 2011-05-02 matt: "\n rundir: " (db:test-get-rundir test) ae6dbecf17 2011-05-02 matt: ) ae6dbecf17 2011-05-02 matt: ;; Each test 2ab4dded8c 2011-09-25 matt: (let ((steps (db:get-steps-for-test db (db:test-get-id test)))) ae6dbecf17 2011-05-02 matt: (for-each ae6dbecf17 2011-05-02 matt: (lambda (step) ae6dbecf17 2011-05-02 matt: (format #t ae6dbecf17 2011-05-02 matt: " Step: ~20a State: ~10a Status: ~10a Time ~22a\n" ae6dbecf17 2011-05-02 matt: (db:step-get-stepname step) ae6dbecf17 2011-05-02 matt: (db:step-get-state step) ae6dbecf17 2011-05-02 matt: (db:step-get-status step) ae6dbecf17 2011-05-02 matt: (db:step-get-event_time step))) ae6dbecf17 2011-05-02 matt: steps))))) ae6dbecf17 2011-05-02 matt: tests)))) ae6dbecf17 2011-05-02 matt: runs) ae6dbecf17 2011-05-02 matt: (set! *didsomething* #t) ae6dbecf17 2011-05-02 matt: )) 2ab4dded8c 2011-09-25 matt: 2ab4dded8c 2011-09-25 matt: ;;====================================================================== 4299ec1adb 2012-02-27 matt: ;; Start the server - can be done in conjunction with -runall or -runtests (one day...) 4299ec1adb 2012-02-27 matt: ;;====================================================================== 4299ec1adb 2012-02-27 matt: (if (and (args:get-arg "-server") 4299ec1adb 2012-02-27 matt: (not (or (args:get-arg "-runall") 4299ec1adb 2012-02-27 matt: (args:get-arg "-runtests")))) 4299ec1adb 2012-02-27 matt: (let* ((toppath (setup-for-run)) 4299ec1adb 2012-02-27 matt: (db (if toppath (open-db) #f))) 3e2cee87de 2012-03-13 matt: (debug:print 0 "INFO: Starting the standalone server") 4299ec1adb 2012-02-27 matt: (if db 3e2cee87de 2012-03-13 matt: (let* ((host:port (db:get-var db "SERVER")) ;; this doen't support multiple servers BUG!!!! 3e2cee87de 2012-03-13 matt: (th2 (server:start db (args:get-arg "-server"))) 3e2cee87de 2012-03-13 matt: (th3 (make-thread (lambda () 3e2cee87de 2012-03-13 matt: (server:keep-running db))))) 3e2cee87de 2012-03-13 matt: (thread-start! th3) 3e2cee87de 2012-03-13 matt: (thread-join! th3)) 4299ec1adb 2012-02-27 matt: (debug:print 0 "ERROR: Failed to setup for megatest")))) 4299ec1adb 2012-02-27 matt: 4299ec1adb 2012-02-27 matt: ;;====================================================================== ae6dbecf17 2011-05-02 matt: ;; full run ae6dbecf17 2011-05-02 matt: ;;====================================================================== ae6dbecf17 2011-05-02 matt: ae6dbecf17 2011-05-02 matt: ;; get lock in db for full run for this directory ae6dbecf17 2011-05-02 matt: ;; for all tests with deps ae6dbecf17 2011-05-02 matt: ;; walk tree of tests to find head tasks ae6dbecf17 2011-05-02 matt: ;; add head tasks to task queue ae6dbecf17 2011-05-02 matt: ;; add dependant tasks to task queue ae6dbecf17 2011-05-02 matt: ;; add remaining tasks to task queue ae6dbecf17 2011-05-02 matt: ;; for each task in task queue ae6dbecf17 2011-05-02 matt: ;; if have adequate resources ae6dbecf17 2011-05-02 matt: ;; launch task ae6dbecf17 2011-05-02 matt: ;; else ae6dbecf17 2011-05-02 matt: ;; put task in deferred queue ae6dbecf17 2011-05-02 matt: ;; if still ok to run tasks ae6dbecf17 2011-05-02 matt: ;; process deferred tasks per above steps ae6dbecf17 2011-05-02 matt: ae6dbecf17 2011-05-02 matt: ;; run all tests are are Not COMPLETED and PASS or CHECK ae6dbecf17 2011-05-02 matt: (if (args:get-arg "-runall") d7ffcddcac 2011-08-11 matt: (general-run-call d7ffcddcac 2011-08-11 matt: "-runall" d7ffcddcac 2011-08-11 matt: "run all tests" 3ca3391a4e 2011-11-26 matt: (lambda (db target runname keys keynames keyvallst) 79c3028409 2012-04-10 mrwellan: ;; (let ((flags (make-hash-table))) 79c3028409 2012-04-10 mrwellan: ;; (for-each (lambda (parm) 79c3028409 2012-04-10 mrwellan: ;; (hash-table-set! flags parm (args:get-arg parm))) 79c3028409 2012-04-10 mrwellan: ;; (list "-rerun" "-force" "-itempatt")) 0e00d7e0c2 2012-02-27 matt: (runs:run-tests db 0e00d7e0c2 2012-02-27 matt: target 0e00d7e0c2 2012-02-27 matt: runname 79c3028409 2012-04-10 mrwellan: (args:get-arg "-runtests") 0e00d7e0c2 2012-02-27 matt: user 79c3028409 2012-04-10 mrwellan: args:arg-hash)))) ;; ) ae6dbecf17 2011-05-02 matt: ae6dbecf17 2011-05-02 matt: ;;====================================================================== ae6dbecf17 2011-05-02 matt: ;; run one test ae6dbecf17 2011-05-02 matt: ;;====================================================================== ae6dbecf17 2011-05-02 matt: ae6dbecf17 2011-05-02 matt: ;; 1. find the config file ae6dbecf17 2011-05-02 matt: ;; 2. change to the test directory ae6dbecf17 2011-05-02 matt: ;; 3. update the db with "test started" status, set running host ae6dbecf17 2011-05-02 matt: ;; 4. process launch the test ae6dbecf17 2011-05-02 matt: ;; - monitor the process, update stats in the db every 2^n minutes ae6dbecf17 2011-05-02 matt: ;; 5. as the test proceeds internally it calls megatest as each step is ae6dbecf17 2011-05-02 matt: ;; started and completed ae6dbecf17 2011-05-02 matt: ;; - step started, timestamp ae6dbecf17 2011-05-02 matt: ;; - step completed, exit status, timestamp ae6dbecf17 2011-05-02 matt: ;; 6. test phone home ae6dbecf17 2011-05-02 matt: ;; - if test run time > allowed run time then kill job ae6dbecf17 2011-05-02 matt: ;; - if cannot access db > allowed disconnect time then kill job ae6dbecf17 2011-05-02 matt: ae6dbecf17 2011-05-02 matt: (if (args:get-arg "-runtests") d7ffcddcac 2011-08-11 matt: (general-run-call d7ffcddcac 2011-08-11 matt: "-runtests" d7ffcddcac 2011-08-11 matt: "run a test" 3ca3391a4e 2011-11-26 matt: (lambda (db target runname keys keynames keyvallst) 3ca3391a4e 2011-11-26 matt: (runs:run-tests db 3ca3391a4e 2011-11-26 matt: target 3ca3391a4e 2011-11-26 matt: runname 3ca3391a4e 2011-11-26 matt: (args:get-arg "-runtests") 3ca3391a4e 2011-11-26 matt: user 79c3028409 2012-04-10 mrwellan: args:arg-hash)))) 3ca3391a4e 2011-11-26 matt: 3ca3391a4e 2011-11-26 matt: ;;====================================================================== 3ca3391a4e 2011-11-26 matt: ;; Rollup into a run 3ca3391a4e 2011-11-26 matt: ;;====================================================================== ff89a30e63 2012-04-19 mrwellan: 3ca3391a4e 2011-11-26 matt: (if (args:get-arg "-rollup") 3ca3391a4e 2011-11-26 matt: (general-run-call 3ca3391a4e 2011-11-26 matt: "-rollup" 3ca3391a4e 2011-11-26 matt: "rollup tests" 2c8647e6a0 2012-02-26 matt: (lambda (db target runname keys keynames keyvallst) 3ca3391a4e 2011-11-26 matt: (runs:rollup-run db 3ca3391a4e 2011-11-26 matt: keys 3ca3391a4e 2011-11-26 matt: (keys->alist keys "na") 3ca3391a4e 2011-11-26 matt: (args:get-arg ":runname") 3ca3391a4e 2011-11-26 matt: user)))) e6213e8dbb 2012-01-27 matt: e6213e8dbb 2012-01-27 matt: ;;====================================================================== ff89a30e63 2012-04-19 mrwellan: ;; Lock or unlock a run ff89a30e63 2012-04-19 mrwellan: ;;====================================================================== ff89a30e63 2012-04-19 mrwellan: ff89a30e63 2012-04-19 mrwellan: (if (or (args:get-arg "-lock")(args:get-arg "-unlock")) ff89a30e63 2012-04-19 mrwellan: (general-run-call ff89a30e63 2012-04-19 mrwellan: (if (args:get-arg "-lock") "-lock" "-unlock") ff89a30e63 2012-04-19 mrwellan: "lock/unlock tests" ff89a30e63 2012-04-19 mrwellan: (lambda (db target runname keys keynames keyvallst) ff89a30e63 2012-04-19 mrwellan: (runs:handle-locking db ff89a30e63 2012-04-19 mrwellan: target ff89a30e63 2012-04-19 mrwellan: keys ff89a30e63 2012-04-19 mrwellan: (args:get-arg ":runname") ff89a30e63 2012-04-19 mrwellan: (args:get-arg "-lock") ff89a30e63 2012-04-19 mrwellan: (args:get-arg "-unlock") ff89a30e63 2012-04-19 mrwellan: user)))) ff89a30e63 2012-04-19 mrwellan: ff89a30e63 2012-04-19 mrwellan: ;;====================================================================== 502458b88d 2012-01-28 mrwellan: ;; Get paths to tests 502458b88d 2012-01-28 mrwellan: ;;====================================================================== ad71efd688 2012-02-24 matt: ;; Get test paths matching target, runname, testpatt, and itempatt 5c2e1f9b03 2012-04-22 matt: (if (or (args:get-arg "-test-path")(args:get-arg "-test-paths")) ad71efd688 2012-02-24 matt: ;; if we are in a test use the MT_CMDINFO data ad71efd688 2012-02-24 matt: (if (getenv "MT_CMDINFO") ad71efd688 2012-02-24 matt: (let* ((startingdir (current-directory)) ad71efd688 2012-02-24 matt: (cmdinfo (read (open-input-string (base64:base64-decode (getenv "MT_CMDINFO"))))) ad71efd688 2012-02-24 matt: (testpath (assoc/default 'testpath cmdinfo)) ad71efd688 2012-02-24 matt: (test-name (assoc/default 'test-name cmdinfo)) ad71efd688 2012-02-24 matt: (runscript (assoc/default 'runscript cmdinfo)) ad71efd688 2012-02-24 matt: (db-host (assoc/default 'db-host cmdinfo)) ad71efd688 2012-02-24 matt: (run-id (assoc/default 'run-id cmdinfo)) ad71efd688 2012-02-24 matt: (itemdat (assoc/default 'itemdat cmdinfo)) ad71efd688 2012-02-24 matt: (db #f) ad71efd688 2012-02-24 matt: (state (args:get-arg ":state")) ad71efd688 2012-02-24 matt: (status (args:get-arg ":status")) ad71efd688 2012-02-24 matt: (target (args:get-arg "-target"))) ad71efd688 2012-02-24 matt: (change-directory testpath) ad71efd688 2012-02-24 matt: (if (not target) ad71efd688 2012-02-24 matt: (begin ad71efd688 2012-02-24 matt: (debug:print 0 "ERROR: -target is required.") ad71efd688 2012-02-24 matt: (exit 1))) ad71efd688 2012-02-24 matt: (if (not (setup-for-run)) ad71efd688 2012-02-24 matt: (begin 5c2e1f9b03 2012-04-22 matt: (debug:print 0 "Failed to setup, giving up on -test-path, exiting") ad71efd688 2012-02-24 matt: (exit 1))) ad71efd688 2012-02-24 matt: (set! db (open-db)) 35d5a09470 2012-02-26 matt: (if (not (args:get-arg "-server")) 35d5a09470 2012-02-26 matt: (server:client-setup db)) ad71efd688 2012-02-24 matt: (let* ((itempatt (args:get-arg "-itempatt")) 2c8647e6a0 2012-02-26 matt: (keys (rdb:get-keys db)) ad71efd688 2012-02-24 matt: (keynames (map key:get-fieldname keys)) 3e2cee87de 2012-03-13 matt: (paths (rdb:test-get-paths-matching db keynames target))) ad71efd688 2012-02-24 matt: (set! *didsomething* #t) ad71efd688 2012-02-24 matt: (for-each (lambda (path) ad71efd688 2012-02-24 matt: (print path)) ad71efd688 2012-02-24 matt: paths))) ad71efd688 2012-02-24 matt: ;; else do a general-run-call ad71efd688 2012-02-24 matt: (general-run-call 5c2e1f9b03 2012-04-22 matt: "-test-path" 5c2e1f9b03 2012-04-22 matt: "Get paths to test" ad71efd688 2012-02-24 matt: (lambda (db target runname keys keynames keyvallst) ad71efd688 2012-02-24 matt: (let* ((itempatt (args:get-arg "-itempatt")) 3e2cee87de 2012-03-13 matt: (paths (rdb:test-get-paths-matching db keynames target))) ad71efd688 2012-02-24 matt: (for-each (lambda (path) ad71efd688 2012-02-24 matt: (print path)) ad71efd688 2012-02-24 matt: paths)))))) ad71efd688 2012-02-24 matt: ad71efd688 2012-02-24 matt: ;;====================================================================== ad71efd688 2012-02-24 matt: ;; Archive tests ad71efd688 2012-02-24 matt: ;;====================================================================== ad71efd688 2012-02-24 matt: ;; Archive tests matching target, runname, testpatt, and itempatt ad71efd688 2012-02-24 matt: (if (args:get-arg "-archive") 502458b88d 2012-01-28 mrwellan: ;; if we are in a test use the MT_CMDINFO data 502458b88d 2012-01-28 mrwellan: (if (getenv "MT_CMDINFO") 502458b88d 2012-01-28 mrwellan: (let* ((startingdir (current-directory)) 502458b88d 2012-01-28 mrwellan: (cmdinfo (read (open-input-string (base64:base64-decode (getenv "MT_CMDINFO"))))) 502458b88d 2012-01-28 mrwellan: (testpath (assoc/default 'testpath cmdinfo)) 502458b88d 2012-01-28 mrwellan: (test-name (assoc/default 'test-name cmdinfo)) 502458b88d 2012-01-28 mrwellan: (runscript (assoc/default 'runscript cmdinfo)) 502458b88d 2012-01-28 mrwellan: (db-host (assoc/default 'db-host cmdinfo)) 502458b88d 2012-01-28 mrwellan: (run-id (assoc/default 'run-id cmdinfo)) 502458b88d 2012-01-28 mrwellan: (itemdat (assoc/default 'itemdat cmdinfo)) 502458b88d 2012-01-28 mrwellan: (db #f) 502458b88d 2012-01-28 mrwellan: (state (args:get-arg ":state")) 5e8a00a005 2012-01-29 matt: (status (args:get-arg ":status")) 29be07e3a4 2012-01-30 matt: (target (args:get-arg "-target"))) 502458b88d 2012-01-28 mrwellan: (change-directory testpath) 5e8a00a005 2012-01-29 matt: (if (not target) 5e8a00a005 2012-01-29 matt: (begin 5e8a00a005 2012-01-29 matt: (debug:print 0 "ERROR: -target is required.") 5e8a00a005 2012-01-29 matt: (exit 1))) 502458b88d 2012-01-28 mrwellan: (if (not (setup-for-run)) 502458b88d 2012-01-28 mrwellan: (begin ad71efd688 2012-02-24 matt: (debug:print 0 "Failed to setup, giving up on -archive, exiting") 502458b88d 2012-01-28 mrwellan: (exit 1))) 502458b88d 2012-01-28 mrwellan: (set! db (open-db)) 35d5a09470 2012-02-26 matt: (if (not (args:get-arg "-server")) 35d5a09470 2012-02-26 matt: (server:client-setup db)) 502458b88d 2012-01-28 mrwellan: (let* ((itempatt (args:get-arg "-itempatt")) 2c8647e6a0 2012-02-26 matt: (keys (rdb:get-keys db)) 5e8a00a005 2012-01-29 matt: (keynames (map key:get-fieldname keys)) 29be07e3a4 2012-01-30 matt: (paths (db:test-get-paths-matching db keynames target))) 5e8a00a005 2012-01-29 matt: (set! *didsomething* #t) 502458b88d 2012-01-28 mrwellan: (for-each (lambda (path) 502458b88d 2012-01-28 mrwellan: (print path)) 502458b88d 2012-01-28 mrwellan: paths))) 502458b88d 2012-01-28 mrwellan: ;; else do a general-run-call 502458b88d 2012-01-28 mrwellan: (general-run-call 502458b88d 2012-01-28 mrwellan: "-test-paths" 502458b88d 2012-01-28 mrwellan: "Get paths to tests" 502458b88d 2012-01-28 mrwellan: (lambda (db target runname keys keynames keyvallst) 502458b88d 2012-01-28 mrwellan: (let* ((itempatt (args:get-arg "-itempatt")) 29be07e3a4 2012-01-30 matt: (paths (db:test-get-paths-matching db keynames target))) 502458b88d 2012-01-28 mrwellan: (for-each (lambda (path) 502458b88d 2012-01-28 mrwellan: (print path)) 502458b88d 2012-01-28 mrwellan: paths)))))) 1db4f07cc5 2012-01-11 mrwellan: 1db4f07cc5 2012-01-11 mrwellan: ;;====================================================================== 3ca3391a4e 2011-11-26 matt: ;; Extract a spreadsheet from the runs database 3ca3391a4e 2011-11-26 matt: ;;====================================================================== 3ca3391a4e 2011-11-26 matt: 3ca3391a4e 2011-11-26 matt: (if (args:get-arg "-extract-ods") 3ca3391a4e 2011-11-26 matt: (general-run-call 3ca3391a4e 2011-11-26 matt: "-extract-ods" 3ca3391a4e 2011-11-26 matt: "Make ods spreadsheet" 1db4f07cc5 2012-01-11 mrwellan: (lambda (db target runname keys keynames keyvallst) 3ca3391a4e 2011-11-26 matt: (let ((outputfile (args:get-arg "-extract-ods")) 3ca3391a4e 2011-11-26 matt: (runspatt (args:get-arg ":runname")) 3ca3391a4e 2011-11-26 matt: (pathmod (args:get-arg "-pathmod")) 3ca3391a4e 2011-11-26 matt: (keyvalalist (keys->alist keys "%"))) 1db4f07cc5 2012-01-11 mrwellan: (debug:print 2 "Extract ods, outputfile: " outputfile " runspatt: " runspatt " keyvalalist: " keyvalalist) 3ca3391a4e 2011-11-26 matt: (db:extract-ods-file db outputfile keyvalalist (if runspatt runspatt "%") pathmod))))) ae6dbecf17 2011-05-02 matt: ae6dbecf17 2011-05-02 matt: ;;====================================================================== ae6dbecf17 2011-05-02 matt: ;; execute the test ae6dbecf17 2011-05-02 matt: ;; - gets called on remote host ae6dbecf17 2011-05-02 matt: ;; - receives info from the -execute param ae6dbecf17 2011-05-02 matt: ;; - passes info to steps via MT_CMDINFO env var (future is to use a dot file) ae6dbecf17 2011-05-02 matt: ;; - gathers host info and ae6dbecf17 2011-05-02 matt: ;;====================================================================== ae6dbecf17 2011-05-02 matt: ae6dbecf17 2011-05-02 matt: (if (args:get-arg "-execute") 37589f80eb 2011-10-09 matt: (begin 37589f80eb 2011-10-09 matt: (launch:execute (args:get-arg "-execute")) ae6dbecf17 2011-05-02 matt: (set! *didsomething* #t))) ff89a30e63 2012-04-19 mrwellan: ff89a30e63 2012-04-19 mrwellan: ;;====================================================================== ff89a30e63 2012-04-19 mrwellan: ;; Test commands (i.e. for use inside tests) ff89a30e63 2012-04-19 mrwellan: ;;====================================================================== b48eda5c31 2012-04-11 mrwellan: ae6dbecf17 2011-05-02 matt: (if (args:get-arg "-step") ae6dbecf17 2011-05-02 matt: (if (not (getenv "MT_CMDINFO")) ae6dbecf17 2011-05-02 matt: (begin bcc1c96231 2011-07-11 mrwellan: (debug:print 0 "ERROR: MT_CMDINFO env var not set, -step must be called *inside* a megatest invoked environment!") ae6dbecf17 2011-05-02 matt: (exit 5)) ae6dbecf17 2011-05-02 matt: (let* ((step (args:get-arg "-step")) ae6dbecf17 2011-05-02 matt: (cmdinfo (read (open-input-string (base64:base64-decode (getenv "MT_CMDINFO"))))) ae6dbecf17 2011-05-02 matt: (testpath (assoc/default 'testpath cmdinfo)) ae6dbecf17 2011-05-02 matt: (test-name (assoc/default 'test-name cmdinfo)) ae6dbecf17 2011-05-02 matt: (runscript (assoc/default 'runscript cmdinfo)) ae6dbecf17 2011-05-02 matt: (db-host (assoc/default 'db-host cmdinfo)) ae6dbecf17 2011-05-02 matt: (run-id (assoc/default 'run-id cmdinfo)) 3e2cee87de 2012-03-13 matt: (test-id (assoc/default 'test-id cmdinfo)) ae6dbecf17 2011-05-02 matt: (itemdat (assoc/default 'itemdat cmdinfo)) ae6dbecf17 2011-05-02 matt: (db #f) ae6dbecf17 2011-05-02 matt: (state (args:get-arg ":state")) 52120b2140 2011-10-20 mrwellan: (status (args:get-arg ":status")) 52120b2140 2011-10-20 mrwellan: (logfile (args:get-arg "-setlog"))) ae6dbecf17 2011-05-02 matt: (change-directory testpath) ae6dbecf17 2011-05-02 matt: (if (not (setup-for-run)) ae6dbecf17 2011-05-02 matt: (begin bcc1c96231 2011-07-11 mrwellan: (debug:print 0 "Failed to setup, exiting") ae6dbecf17 2011-05-02 matt: (exit 1))) ae6dbecf17 2011-05-02 matt: (set! db (open-db)) 35d5a09470 2012-02-26 matt: (if (not (args:get-arg "-server")) 35d5a09470 2012-02-26 matt: (server:client-setup db)) ae6dbecf17 2011-05-02 matt: (if (and state status) 3e2cee87de 2012-03-13 matt: (rdb:teststep-set-status! db test-id step state status itemdat (args:get-arg "-m") logfile) ae6dbecf17 2011-05-02 matt: (begin bcc1c96231 2011-07-11 mrwellan: (debug:print 0 "ERROR: You must specify :state and :status with every call to -step") ae6dbecf17 2011-05-02 matt: (exit 6))) ae6dbecf17 2011-05-02 matt: (sqlite3:finalize! db) ae6dbecf17 2011-05-02 matt: (set! *didsomething* #t)))) ae6dbecf17 2011-05-02 matt: ae6dbecf17 2011-05-02 matt: (if (or (args:get-arg "-setlog") ;; since setting up is so costly lets piggyback on -test-status 00761e1112 2011-05-15 matt: (args:get-arg "-set-toplog") ae6dbecf17 2011-05-02 matt: (args:get-arg "-test-status") ebea00e4bb 2011-08-24 mrwellan: (args:get-arg "-set-values") dd5766961c 2011-09-06 matt: (args:get-arg "-load-test-data") 42b834da20 2011-08-02 mrwellan: (args:get-arg "-runstep") 42b834da20 2011-08-02 mrwellan: (args:get-arg "-summarize-items")) ae6dbecf17 2011-05-02 matt: (if (not (getenv "MT_CMDINFO")) ae6dbecf17 2011-05-02 matt: (begin bcc1c96231 2011-07-11 mrwellan: (debug:print 0 "ERROR: MT_CMDINFO env var not set, commands -test-status, -runstep and -setlog must be called *inside* a megatest environment!") ae6dbecf17 2011-05-02 matt: (exit 5)) adea88835b 2011-05-06 mrwellan: (let* ((startingdir (current-directory)) adea88835b 2011-05-06 mrwellan: (cmdinfo (read (open-input-string (base64:base64-decode (getenv "MT_CMDINFO"))))) ae6dbecf17 2011-05-02 matt: (testpath (assoc/default 'testpath cmdinfo)) ae6dbecf17 2011-05-02 matt: (test-name (assoc/default 'test-name cmdinfo)) ae6dbecf17 2011-05-02 matt: (runscript (assoc/default 'runscript cmdinfo)) ae6dbecf17 2011-05-02 matt: (db-host (assoc/default 'db-host cmdinfo)) ae6dbecf17 2011-05-02 matt: (run-id (assoc/default 'run-id cmdinfo)) 3e2cee87de 2012-03-13 matt: (test-id (assoc/default 'test-id cmdinfo)) ae6dbecf17 2011-05-02 matt: (itemdat (assoc/default 'itemdat cmdinfo)) ae6dbecf17 2011-05-02 matt: (db #f) ae6dbecf17 2011-05-02 matt: (state (args:get-arg ":state")) ae6dbecf17 2011-05-02 matt: (status (args:get-arg ":status"))) ae6dbecf17 2011-05-02 matt: (change-directory testpath) ae6dbecf17 2011-05-02 matt: (if (not (setup-for-run)) ae6dbecf17 2011-05-02 matt: (begin bcc1c96231 2011-07-11 mrwellan: (debug:print 0 "Failed to setup, exiting") ae6dbecf17 2011-05-02 matt: (exit 1))) ae6dbecf17 2011-05-02 matt: (set! db (open-db)) 35d5a09470 2012-02-26 matt: (if (not (args:get-arg "-server")) 35d5a09470 2012-02-26 matt: (server:client-setup db)) dd5766961c 2011-09-06 matt: (if (args:get-arg "-load-test-data") 3e2cee87de 2012-03-13 matt: ;; has sub commands that are rdb: 3e2cee87de 2012-03-13 matt: (db:load-test-data db test-id)) ae6dbecf17 2011-05-02 matt: (if (args:get-arg "-setlog") 39b53fe321 2012-03-25 matt: (let ((logfname (args:get-arg "-setlog"))) 39b53fe321 2012-03-25 matt: (rdb:test-set-log! db test-id logfname))) 00761e1112 2011-05-15 matt: (if (args:get-arg "-set-toplog") 3e2cee87de 2012-03-13 matt: (rtests:test-set-toplog! db run-id test-name (args:get-arg "-set-toplog"))) 42b834da20 2011-08-02 mrwellan: (if (args:get-arg "-summarize-items") b48eda5c31 2012-04-11 mrwellan: (tests:summarize-items db run-id test-name #t)) ;; do force here 0add4d5d70 2011-05-06 mrwellan: (if (args:get-arg "-runstep") ae6dbecf17 2011-05-02 matt: (if (null? remargs) ae6dbecf17 2011-05-02 matt: (begin bcc1c96231 2011-07-11 mrwellan: (debug:print 0 "ERROR: nothing specified to run!") ae6dbecf17 2011-05-02 matt: (sqlite3:finalize! db) ae6dbecf17 2011-05-02 matt: (exit 6)) adea88835b 2011-05-06 mrwellan: (let* ((stepname (args:get-arg "-runstep")) adea88835b 2011-05-06 mrwellan: (logprofile (args:get-arg "-logpro")) adea88835b 2011-05-06 mrwellan: (logfile (conc stepname ".log")) ae6dbecf17 2011-05-02 matt: (cmd (if (null? remargs) #f (car remargs))) 0add4d5d70 2011-05-06 mrwellan: (params (if cmd (cdr remargs) '())) 0add4d5d70 2011-05-06 mrwellan: (exitstat #f) 0add4d5d70 2011-05-06 mrwellan: (shell (last (string-split (get-environment-variable "SHELL") "/"))) 0add4d5d70 2011-05-06 mrwellan: (redir (case (string->symbol shell) 0add4d5d70 2011-05-06 mrwellan: ((tcsh csh ksh) ">&") 3e2cee87de 2012-03-13 matt: ((zsh bash sh ash) "2>&1 >") 3e2cee87de 2012-03-13 matt: (else ">&"))) adea88835b 2011-05-06 mrwellan: (fullcmd (conc "(" (string-intersperse adea88835b 2011-05-06 mrwellan: (cons cmd params) " ") adea88835b 2011-05-06 mrwellan: ") " redir " " logfile))) ae6dbecf17 2011-05-02 matt: ;; mark the start of the test 3e2cee87de 2012-03-13 matt: (rdb:teststep-set-status! db test-id stepname "start" "n/a" itemdat (args:get-arg "-m") logfile) ae6dbecf17 2011-05-02 matt: ;; close the db 3e2cee87de 2012-03-13 matt: ;; (sqlite3:finalize! db) ae6dbecf17 2011-05-02 matt: ;; run the test step bcc1c96231 2011-07-11 mrwellan: (debug:print 2 "INFO: Running \"" fullcmd "\"") adea88835b 2011-05-06 mrwellan: (change-directory startingdir) adea88835b 2011-05-06 mrwellan: (set! exitstat (system fullcmd)) ;; cmd params)) 290c7d7cc8 2011-05-10 mrwellan: (set! *globalexitstatus* exitstat) adea88835b 2011-05-06 mrwellan: (change-directory testpath) e38c4a9bdd 2011-05-03 matt: ;; re-open the db 3e2cee87de 2012-03-13 matt: ;; (set! db (open-db)) 3e2cee87de 2012-03-13 matt: ;; (if (not (args:get-arg "-server")) 3e2cee87de 2012-03-13 matt: ;; (server:client-setup db)) 0add4d5d70 2011-05-06 mrwellan: ;; run logpro if applicable ;; (process-run "ls" (list "/foo" "2>&1" "blah.log")) adea88835b 2011-05-06 mrwellan: (if logprofile adea88835b 2011-05-06 mrwellan: (let* ((htmllogfile (conc stepname ".html")) 290c7d7cc8 2011-05-10 mrwellan: (oldexitstat exitstat) adea88835b 2011-05-06 mrwellan: (cmd (string-intersperse (list "logpro" logprofile htmllogfile "<" logfile ">" (conc stepname "_logpro.log")) " "))) bcc1c96231 2011-07-11 mrwellan: (debug:print 2 "INFO: running \"" cmd "\"") adea88835b 2011-05-06 mrwellan: (change-directory startingdir) adea88835b 2011-05-06 mrwellan: (set! exitstat (system cmd)) 290c7d7cc8 2011-05-10 mrwellan: (set! *globalexitstatus* exitstat) ;; no necessary adea88835b 2011-05-06 mrwellan: (change-directory testpath) 3e2cee87de 2012-03-13 matt: (rdb:test-set-log! db test-id htmllogfile))) 3e2cee87de 2012-03-13 matt: (let ((msg (args:get-arg "-m"))) 3e2cee87de 2012-03-13 matt: (rdb:teststep-set-status! db test-id stepname "end" exitstat itemdat msg logfile)) 3e2cee87de 2012-03-13 matt: ;; (sqlite3:finalize! db) 3e2cee87de 2012-03-13 matt: ;;(if (not (eq? exitstat 0)) 3e2cee87de 2012-03-13 matt: ;; (exit 254)) ;; (exit exitstat) doesn't work?!? 290c7d7cc8 2011-05-10 mrwellan: ;; open the db 290c7d7cc8 2011-05-10 mrwellan: ;; mark the end of the test 290c7d7cc8 2011-05-10 mrwellan: ))) ebea00e4bb 2011-08-24 mrwellan: (if (or (args:get-arg "-test-status") ebea00e4bb 2011-08-24 mrwellan: (args:get-arg "-set-values")) f412143bd2 2011-05-31 mrwellan: (let ((newstatus (cond f412143bd2 2011-05-31 mrwellan: ((number? status) (if (equal? status 0) "PASS" "FAIL")) ebea00e4bb 2011-08-24 mrwellan: ((and (string? status) ebea00e4bb 2011-08-24 mrwellan: (string->number status))(if (equal? (string->number status) 0) "PASS" "FAIL")) ebea00e4bb 2011-08-24 mrwellan: (else status))) ebea00e4bb 2011-08-24 mrwellan: ;; transfer relevant keys into a hash to be passed to test-set-status! ebea00e4bb 2011-08-24 mrwellan: ;; could use an assoc list I guess. ebea00e4bb 2011-08-24 mrwellan: (otherdata (let ((res (make-hash-table))) ebea00e4bb 2011-08-24 mrwellan: (for-each (lambda (key) ebea00e4bb 2011-08-24 mrwellan: (if (args:get-arg key) ebea00e4bb 2011-08-24 mrwellan: (hash-table-set! res key (args:get-arg key)))) d406fee8c4 2011-09-12 matt: (list ":value" ":tol" ":expected" ":first_err" ":first_warn" ":units" ":category" ":variable")) ebea00e4bb 2011-08-24 mrwellan: res))) ebea00e4bb 2011-08-24 mrwellan: (if (and (args:get-arg "-test-status") ebea00e4bb 2011-08-24 mrwellan: (or (not state) ebea00e4bb 2011-08-24 mrwellan: (not status))) ebea00e4bb 2011-08-24 mrwellan: (begin ebea00e4bb 2011-08-24 mrwellan: (debug:print 0 "ERROR: You must specify :state and :status with every call to -test-status\n" help) ebea00e4bb 2011-08-24 mrwellan: (sqlite3:finalize! db) ebea00e4bb 2011-08-24 mrwellan: (exit 6))) 3e2cee87de 2012-03-13 matt: (let ((msg (args:get-arg "-m"))) 3e2cee87de 2012-03-13 matt: (rtests:test-set-status! db test-id state newstatus msg otherdata)))) ae6dbecf17 2011-05-02 matt: (sqlite3:finalize! db) ae6dbecf17 2011-05-02 matt: (set! *didsomething* #t)))) 3e2cee87de 2012-03-13 matt: ff89a30e63 2012-04-19 mrwellan: ;;====================================================================== ff89a30e63 2012-04-19 mrwellan: ;; Various helper commands can go below here ff89a30e63 2012-04-19 mrwellan: ;;====================================================================== ff89a30e63 2012-04-19 mrwellan: ae6dbecf17 2011-05-02 matt: (if (args:get-arg "-showkeys") ae6dbecf17 2011-05-02 matt: (let ((db #f) ae6dbecf17 2011-05-02 matt: (keys #f)) ae6dbecf17 2011-05-02 matt: (if (not (setup-for-run)) ae6dbecf17 2011-05-02 matt: (begin bcc1c96231 2011-07-11 mrwellan: (debug:print 0 "Failed to setup, exiting") ae6dbecf17 2011-05-02 matt: (exit 1))) ae6dbecf17 2011-05-02 matt: (set! db (open-db)) 35d5a09470 2012-02-26 matt: (if (not (args:get-arg "-server")) 35d5a09470 2012-02-26 matt: (server:client-setup db)) 2c8647e6a0 2012-02-26 matt: (set! keys (rdb:get-keys db)) bcc1c96231 2011-07-11 mrwellan: (debug:print 1 "Keys: " (string-intersperse (map key:get-fieldname keys) ", ")) ae6dbecf17 2011-05-02 matt: (sqlite3:finalize! db) ae6dbecf17 2011-05-02 matt: (set! *didsomething* #t))) ae6dbecf17 2011-05-02 matt: ae6dbecf17 2011-05-02 matt: (if (args:get-arg "-gui") ae6dbecf17 2011-05-02 matt: (begin bcc1c96231 2011-07-11 mrwellan: (debug:print 0 "Look at the dashboard for now") ae6dbecf17 2011-05-02 matt: ;; (megatest-gui) 3de9db9a0f 2012-04-23 matt: (set! *didsomething* #t))) 3de9db9a0f 2012-04-23 matt: 3de9db9a0f 2012-04-23 matt: (if (args:get-arg "-gen-megatest-area") 3de9db9a0f 2012-04-23 matt: (begin 3de9db9a0f 2012-04-23 matt: (genexample:mk-megatest.config) 3de9db9a0f 2012-04-23 matt: (set! *didsomething* #t))) 3de9db9a0f 2012-04-23 matt: 3de9db9a0f 2012-04-23 matt: (if (args:get-arg "-gen-megatest-test") 3de9db9a0f 2012-04-23 matt: (let ((testname (args:get-arg "-gen-megatest-test"))) 3de9db9a0f 2012-04-23 matt: (genexample:mk-megatest-test testname) ff89a30e63 2012-04-19 mrwellan: (set! *didsomething* #t))) ff89a30e63 2012-04-19 mrwellan: 3bb0b5e9f9 2011-07-19 matt: ;;====================================================================== 3bb0b5e9f9 2011-07-19 matt: ;; Update the database schema on request 3bb0b5e9f9 2011-07-19 matt: ;;====================================================================== 3bb0b5e9f9 2011-07-19 matt: 3bb0b5e9f9 2011-07-19 matt: (if (args:get-arg "-rebuild-db") 3bb0b5e9f9 2011-07-19 matt: (begin 3bb0b5e9f9 2011-07-19 matt: (if (not (setup-for-run)) 3bb0b5e9f9 2011-07-19 matt: (begin 3bb0b5e9f9 2011-07-19 matt: (debug:print 0 "Failed to setup, exiting") 3bb0b5e9f9 2011-07-19 matt: (exit 1))) 3bb0b5e9f9 2011-07-19 matt: ;; now can find our db 3bb0b5e9f9 2011-07-19 matt: (set! db (open-db)) 3bb0b5e9f9 2011-07-19 matt: (patch-db db) 3bb0b5e9f9 2011-07-19 matt: (sqlite3:finalize! db) 3bb0b5e9f9 2011-07-19 matt: (set! *didsomething* #t))) ebea00e4bb 2011-08-24 mrwellan: ebea00e4bb 2011-08-24 mrwellan: ;;====================================================================== ebea00e4bb 2011-08-24 mrwellan: ;; Update the tests meta data from the testconfig files ff89a30e63 2012-04-19 mrwellan: ;;====================================================================== ebea00e4bb 2011-08-24 mrwellan: ebea00e4bb 2011-08-24 mrwellan: (if (args:get-arg "-update-meta") ebea00e4bb 2011-08-24 mrwellan: (begin ebea00e4bb 2011-08-24 mrwellan: (if (not (setup-for-run)) ebea00e4bb 2011-08-24 mrwellan: (begin ebea00e4bb 2011-08-24 mrwellan: (debug:print 0 "Failed to setup, exiting") ebea00e4bb 2011-08-24 mrwellan: (exit 1))) ebea00e4bb 2011-08-24 mrwellan: ;; now can find our db ebea00e4bb 2011-08-24 mrwellan: (set! db (open-db)) 35d5a09470 2012-02-26 matt: (if (not (args:get-arg "-server")) 35d5a09470 2012-02-26 matt: (server:client-setup db)) ebea00e4bb 2011-08-24 mrwellan: (runs:update-all-test_meta db) ebea00e4bb 2011-08-24 mrwellan: (sqlite3:finalize! db) ebea00e4bb 2011-08-24 mrwellan: (set! *didsomething* #t))) 2c8647e6a0 2012-02-26 matt: 2c8647e6a0 2012-02-26 matt: ;;====================================================================== 2c8647e6a0 2012-02-26 matt: ;; Start a repl 2c8647e6a0 2012-02-26 matt: ;;====================================================================== ff89a30e63 2012-04-19 mrwellan: 2c8647e6a0 2012-02-26 matt: (if (args:get-arg "-repl") 2c8647e6a0 2012-02-26 matt: (let* ((toppath (setup-for-run)) 2c8647e6a0 2012-02-26 matt: (db (if toppath (open-db) #f))) 2c8647e6a0 2012-02-26 matt: (if db 2c8647e6a0 2012-02-26 matt: (begin 2c8647e6a0 2012-02-26 matt: (set! *db* db) 35d5a09470 2012-02-26 matt: (if (not (args:get-arg "-server")) 35d5a09470 2012-02-26 matt: (server:client-setup db)) 2c8647e6a0 2012-02-26 matt: (import readline) 2c8647e6a0 2012-02-26 matt: (import apropos) 2c8647e6a0 2012-02-26 matt: (gnu-history-install-file-manager 2c8647e6a0 2012-02-26 matt: (string-append 2c8647e6a0 2012-02-26 matt: (or (get-environment-variable "HOME") ".") "/.megatest_history")) 2c8647e6a0 2012-02-26 matt: (current-input-port (make-gnu-readline-port "megatest> ")) 35d5a09470 2012-02-26 matt: (repl))) 35d5a09470 2012-02-26 matt: (set! *didsomething* #t))) 2c8647e6a0 2012-02-26 matt: 2c8647e6a0 2012-02-26 matt: ;;====================================================================== 2c8647e6a0 2012-02-26 matt: ;; Exit and clean up 2c8647e6a0 2012-02-26 matt: ;;====================================================================== bcc1c96231 2011-07-11 mrwellan: ae6dbecf17 2011-05-02 matt: (if (not *didsomething*) bcc1c96231 2011-07-11 mrwellan: (debug:print 0 help)) 290c7d7cc8 2011-05-10 mrwellan: 290c7d7cc8 2011-05-10 mrwellan: (if (not (eq? *globalexitstatus* 0)) d73b2c1642 2011-06-27 mrwellan: (if (or (args:get-arg "-runtests")(args:get-arg "-runall")) d73b2c1642 2011-06-27 mrwellan: (begin bcc1c96231 2011-07-11 mrwellan: (debug:print 0 "NOTE: Subprocesses with non-zero exit code detected: " *globalexitstatus*) d73b2c1642 2011-06-27 mrwellan: (exit 0)) d73b2c1642 2011-06-27 mrwellan: (case *globalexitstatus* d73b2c1642 2011-06-27 mrwellan: ((0)(exit 0)) d73b2c1642 2011-06-27 mrwellan: ((1)(exit 1)) d73b2c1642 2011-06-27 mrwellan: ((2)(exit 2)) d73b2c1642 2011-06-27 mrwellan: (else (exit 3)))))
File Annotation