ae6dbecf17 2011-05-02 matt: ;; Copyright 2006-2011, 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: ae6dbecf17 2011-05-02 matt: (include "common.scm") 3bb0b5e9f9 2011-07-19 matt: (include "megatest-version.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 " ae6dbecf17 2011-05-02 matt: license GPL, Copyright Matt Welland 2006-2011 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: ae6dbecf17 2011-05-02 matt: Process and test running 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 ae6dbecf17 2011-05-02 matt: ae6dbecf17 2011-05-02 matt: Run status updates (these require that you are in a test directory cf78fcded0 2011-05-04 matt: and you have sourced the \"megatest.csh\" or ae6dbecf17 2011-05-02 matt: \"megatest.sh\" file.) 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 ae6dbecf17 2011-05-02 matt: -m comment : insert a comment for this test ae6dbecf17 2011-05-02 matt: cf78fcded0 2011-05-04 matt: Run data ae6dbecf17 2011-05-02 matt: :runname : required, name for this particular test run ae6dbecf17 2011-05-02 matt: :state : required if updating step state; e.g. start, end, completed ae6dbecf17 2011-05-02 matt: :status : required if updating step status; e.g. pass, fail, n/a 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 c4edfbcd13 2011-05-05 mrwellan: -testpatt patt : in list-runs show only these tests, % is the wildcard c4edfbcd13 2011-05-05 mrwellan: -itempatt patt : in list-runs show only tests with items that match patt ae6dbecf17 2011-05-02 matt: -showkeys : show the keys used in this megatest setup ae6dbecf17 2011-05-02 matt: e38c4a9bdd 2011-05-03 matt: Misc ae6dbecf17 2011-05-02 matt: -force : override some checks ae6dbecf17 2011-05-02 matt: -xterm : start an xterm instead of launching the test d73b2c1642 2011-06-27 mrwellan: -remove-runs : remove the data for a run, requires all fields be specified d73b2c1642 2011-06-27 mrwellan: and :runname ,-testpatt and -itempatt 09102f8425 2011-05-11 matt: and -testpatt c075ebd51b 2011-06-16 mrwellan: -keepgoing : continue running until no jobs are \"LAUNCHED\" or c075ebd51b 2011-06-16 mrwellan: \"NOT_STARTED\" d73b2c1642 2011-06-27 mrwellan: -rerun FAIL,WARN... : re-run if called on a test that previously ran (nullified d73b2c1642 2011-06-27 mrwellan: if -keepgoing is also specified) 3bb0b5e9f9 2011-07-19 matt: -rebuild-db : bring the database schema up to date ae6dbecf17 2011-05-02 matt: ae6dbecf17 2011-05-02 matt: Helpers 09102f8425 2011-05-11 matt: -runstep stepname ... : take remaining params as comand and execute as stepname 09102f8425 2011-05-11 matt: log will be in stepname.log. Best to put command in quotes ae6dbecf17 2011-05-02 matt: -logpro file : with -exec apply logpro file to stepname.log, creates ae6dbecf17 2011-05-02 matt: stepname.html and sets log to same 0add4d5d70 2011-05-06 mrwellan: If using make use stepname_logpro.log as your target 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" 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" bcc1c96231 2011-07-11 mrwellan: "-debug" ;; for *verbosity* > 2 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" ae6dbecf17 2011-05-02 matt: "-gui" ae6dbecf17 2011-05-02 matt: "-runall" ;; run all tests 09102f8425 2011-05-11 matt: "-remove-runs" c075ebd51b 2011-06-16 mrwellan: "-keepgoing" 1ea16b0407 2011-06-28 mrwellan: "-usequeue" 3bb0b5e9f9 2011-07-19 matt: "-rebuild-db" 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: (include "keys.scm") ae6dbecf17 2011-05-02 matt: (include "items.scm") ae6dbecf17 2011-05-02 matt: (include "db.scm") ae6dbecf17 2011-05-02 matt: (include "configf.scm") ae6dbecf17 2011-05-02 matt: (include "process.scm") ae6dbecf17 2011-05-02 matt: (include "launch.scm") ae6dbecf17 2011-05-02 matt: (include "runs.scm") 6654e3905e 2011-07-19 matt: (include "runconfig.scm") 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))) 5411a1be29 2011-05-11 mrwellan: 5411a1be29 2011-05-11 mrwellan: ;;====================================================================== 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 5411a1be29 2011-05-11 mrwellan: (define (remove-runs) 5411a1be29 2011-05-11 mrwellan: (cond 5411a1be29 2011-05-11 mrwellan: ((not (args:get-arg ":runname")) bcc1c96231 2011-07-11 mrwellan: (debug:print 0 "ERROR: Missing required parameter for -remove-runs, 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")) bcc1c96231 2011-07-11 mrwellan: (debug:print 0 "ERROR: Missing required parameter for -remove-runs, 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")) 5411a1be29 2011-05-11 mrwellan: (print "ERROR: Missing required parameter for -remove-runs, you must specify the items with -itempatt") 5411a1be29 2011-05-11 mrwellan: (exit 4)) 5411a1be29 2011-05-11 mrwellan: ((let ((db #f)) 5411a1be29 2011-05-11 mrwellan: (if (not (setup-for-run)) 5411a1be29 2011-05-11 mrwellan: (begin bcc1c96231 2011-07-11 mrwellan: (debug:print 0 print "Failed to setup, exiting") 5411a1be29 2011-05-11 mrwellan: (exit 1))) 5411a1be29 2011-05-11 mrwellan: (set! db (open-db)) 5411a1be29 2011-05-11 mrwellan: (if (not (car *configinfo*)) 5411a1be29 2011-05-11 mrwellan: (begin bcc1c96231 2011-07-11 mrwellan: (debug:print 0 "ERROR: Attempted to remove test(s) but run area config file not found") 5411a1be29 2011-05-11 mrwellan: (exit 1)) 5411a1be29 2011-05-11 mrwellan: ;; put test parameters into convenient variables 5411a1be29 2011-05-11 mrwellan: (runs:remove-runs db 5411a1be29 2011-05-11 mrwellan: (args:get-arg ":runname") 5411a1be29 2011-05-11 mrwellan: (args:get-arg "-testpatt") 5411a1be29 2011-05-11 mrwellan: (args:get-arg "-itempatt"))) 5411a1be29 2011-05-11 mrwellan: (sqlite3:finalize! db) 5411a1be29 2011-05-11 mrwellan: (set! *didsomething* #t))))) 5411a1be29 2011-05-11 mrwellan: 5411a1be29 2011-05-11 mrwellan: (if (args:get-arg "-remove-runs") 5411a1be29 2011-05-11 mrwellan: (remove-runs)) 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")) ae6dbecf17 2011-05-02 matt: (runsdat (db-get-runs db runpatt)) ae6dbecf17 2011-05-02 matt: (runs (db:get-rows runsdat)) ae6dbecf17 2011-05-02 matt: (header (db:get-header runsdat)) ae6dbecf17 2011-05-02 matt: (keys (db-get-keys db)) ae6dbecf17 2011-05-02 matt: (keynames (map key:get-fieldname keys))) ae6dbecf17 2011-05-02 matt: ;; Each run ae6dbecf17 2011-05-02 matt: (for-each ae6dbecf17 2011-05-02 matt: (lambda (run) bcc1c96231 2011-07-11 mrwellan: (debug:print 2 "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: "/" d73b2c1642 2011-06-27 mrwellan: (db:get-value-by-header run header "runname")) d73b2c1642 2011-06-27 mrwellan: (let ((run-id (db:get-value-by-header run header "id"))) c4edfbcd13 2011-05-05 mrwellan: (let ((tests (db-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 ae6dbecf17 2011-05-02 matt: (let ((steps (db-get-test-steps-for-run 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: )) ae6dbecf17 2011-05-02 matt: ae6dbecf17 2011-05-02 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") ae6dbecf17 2011-05-02 matt: (if (not (args:get-arg ":runname")) ae6dbecf17 2011-05-02 matt: (begin bcc1c96231 2011-07-11 mrwellan: (debug:print 0 "ERROR: Missing required parameter for -runtests, you must specify the run name with :runname runname") ae6dbecf17 2011-05-02 matt: (exit 2)) ae6dbecf17 2011-05-02 matt: (let* ((db (if (setup-for-run) ae6dbecf17 2011-05-02 matt: (open-db) 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: (if (not (car *configinfo*)) ae6dbecf17 2011-05-02 matt: (begin bcc1c96231 2011-07-11 mrwellan: (debug:print 0 "ERROR: Attempted to run a test but run area config file not found") ae6dbecf17 2011-05-02 matt: (exit 1)) ae6dbecf17 2011-05-02 matt: ;; put test parameters into convenient variables ae6dbecf17 2011-05-02 matt: (let* ((test-names (get-all-legal-tests))) ;; "PROD" is ignored for now bcc1c96231 2011-07-11 mrwellan: (debug:print 1 "INFO: Attempting to start the following tests...") bcc1c96231 2011-07-11 mrwellan: (debug:print 1 " " (string-intersperse test-names ",")) ae6dbecf17 2011-05-02 matt: (run-tests db test-names))) c075ebd51b 2011-06-16 mrwellan: ;; (run-waiting-tests db) 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: ;;====================================================================== 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: (define (runtests) ae6dbecf17 2011-05-02 matt: (if (not (args:get-arg ":runname")) ae6dbecf17 2011-05-02 matt: (begin bcc1c96231 2011-07-11 mrwellan: (debug:print 0 "ERROR: Missing required parameter for -runtests, you must specify the run name with :runname runname") ae6dbecf17 2011-05-02 matt: (exit 2)) ae6dbecf17 2011-05-02 matt: (let ((db #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)) ae6dbecf17 2011-05-02 matt: (if (not (car *configinfo*)) ae6dbecf17 2011-05-02 matt: (begin bcc1c96231 2011-07-11 mrwellan: (debug:print 0 "ERROR: Attempted to run a test but run area config file not found") ae6dbecf17 2011-05-02 matt: (exit 1)) ae6dbecf17 2011-05-02 matt: ;; put test parameters into convenient variables ae6dbecf17 2011-05-02 matt: (let* ((test-names (string-split (args:get-arg "-runtests") ","))) ae6dbecf17 2011-05-02 matt: (run-tests db test-names))) ae6dbecf17 2011-05-02 matt: ;; run-waiting-tests db) ae6dbecf17 2011-05-02 matt: (sqlite3:finalize! db) c075ebd51b 2011-06-16 mrwellan: ;; (run-waiting-tests #f) ae6dbecf17 2011-05-02 matt: (set! *didsomething* #t)))) ae6dbecf17 2011-05-02 matt: ae6dbecf17 2011-05-02 matt: (if (args:get-arg "-runtests") ae6dbecf17 2011-05-02 matt: (runtests)) 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") ae6dbecf17 2011-05-02 matt: (let* ((cmdinfo (read (open-input-string (base64:base64-decode (args:get-arg "-execute")))))) ae6dbecf17 2011-05-02 matt: (setenv "MT_CMDINFO" (args:get-arg "-execute")) ae6dbecf17 2011-05-02 matt: (if (list? cmdinfo) ;; ((testpath /tmp/mrwellan/jazzmind/src/example_run/tests/sqlitespeed) (test-name sqlitespeed) (runscript runscript.rb) (db-host localhost) (run-id 1)) ae6dbecf17 2011-05-02 matt: (let* ((testpath (assoc/default 'testpath cmdinfo)) ae6dbecf17 2011-05-02 matt: (work-area (assoc/default 'work-area 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)) ae6dbecf17 2011-05-02 matt: (itemdat (assoc/default 'itemdat cmdinfo)) 5c3fd5b583 2011-05-25 mrwellan: (env-ovrd (assoc/default 'env-ovrd cmdinfo)) 89a6bb7363 2011-05-08 matt: (runname (assoc/default 'runname cmdinfo)) 00761e1112 2011-05-15 matt: (megatest (assoc/default 'megatest cmdinfo)) e38c4a9bdd 2011-05-03 matt: (mt-bindir-path (assoc/default 'mt-bindir-path cmdinfo)) ae6dbecf17 2011-05-02 matt: (fullrunscript (conc testpath "/" runscript)) ae6dbecf17 2011-05-02 matt: (db #f)) bcc1c96231 2011-07-11 mrwellan: (debug:print 2 "Exectuing " test-name " on " (get-host-name)) ae6dbecf17 2011-05-02 matt: (change-directory testpath) c5d5ee467e 2011-05-09 mrwellan: (setenv "MT_TEST_RUN_DIR" work-area) 89a6bb7363 2011-05-08 matt: (setenv "MT_TEST_NAME" test-name) 89a6bb7363 2011-05-08 matt: (setenv "MT_ITEM_INFO" (conc itemdat)) 89a6bb7363 2011-05-08 matt: (setenv "MT_RUNNAME" runname) 00761e1112 2011-05-15 matt: (setenv "MT_MEGATEST" megatest) e38c4a9bdd 2011-05-03 matt: (setenv "PATH" (conc (getenv "PATH") ":" mt-bindir-path)) 00761e1112 2011-05-15 matt: 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: ;; now can find our db ae6dbecf17 2011-05-02 matt: (set! db (open-db)) ae6dbecf17 2011-05-02 matt: (change-directory work-area) 6654e3905e 2011-07-19 matt: (set-run-config-vars db run-id) 5c3fd5b583 2011-05-25 mrwellan: ;; environment overrides are done *before* the remaining critical envars. 5c3fd5b583 2011-05-25 mrwellan: (alist->env-vars env-ovrd) ae6dbecf17 2011-05-02 matt: (set-megatest-env-vars db run-id) ae6dbecf17 2011-05-02 matt: (set-item-env-vars itemdat) ae6dbecf17 2011-05-02 matt: (save-environment-as-files "megatest") ae6dbecf17 2011-05-02 matt: (test-set-meta-info db run-id test-name itemdat) ae6dbecf17 2011-05-02 matt: (test-set-status! db run-id test-name "REMOTEHOSTSTART" "n/a" itemdat (args:get-arg "-m")) ae6dbecf17 2011-05-02 matt: (if (args:get-arg "-xterm") ae6dbecf17 2011-05-02 matt: (set! fullrunscript "xterm") ae6dbecf17 2011-05-02 matt: (if (not (file-execute-access? fullrunscript)) ae6dbecf17 2011-05-02 matt: (system (conc "chmod ug+x " fullrunscript)))) ae6dbecf17 2011-05-02 matt: ;; We are about to actually kick off the test ae6dbecf17 2011-05-02 matt: ;; so this is a good place to remove the records for ae6dbecf17 2011-05-02 matt: ;; any previous runs ae6dbecf17 2011-05-02 matt: ;; (db:test-remove-steps db run-id testname itemdat) ae6dbecf17 2011-05-02 matt: ae6dbecf17 2011-05-02 matt: ;; from here on out we will open and close the db ae6dbecf17 2011-05-02 matt: ;; on every access to reduce the probablitiy of ae6dbecf17 2011-05-02 matt: ;; contention or stuck access on nfs. ae6dbecf17 2011-05-02 matt: (sqlite3:finalize! db) ae6dbecf17 2011-05-02 matt: ae6dbecf17 2011-05-02 matt: (let* ((m (make-mutex)) ae6dbecf17 2011-05-02 matt: (kill-job? #f) ae6dbecf17 2011-05-02 matt: (exit-info (make-vector 3)) 5cefaba81b 2011-06-16 mrwellan: (job-thread #f) ae6dbecf17 2011-05-02 matt: (runit (lambda () 5cefaba81b 2011-06-16 mrwellan: ;; (let-values 5cefaba81b 2011-06-16 mrwellan: ;; (((pid exit-status exit-code) 5cefaba81b 2011-06-16 mrwellan: ;; (run-n-wait fullrunscript))) 5cefaba81b 2011-06-16 mrwellan: (let ((pid (process-run fullrunscript))) 5cefaba81b 2011-06-16 mrwellan: (let loop ((i 0)) 5cefaba81b 2011-06-16 mrwellan: (let-values 5cefaba81b 2011-06-16 mrwellan: (((pid-val exit-status exit-code) (process-wait pid #t))) 5cefaba81b 2011-06-16 mrwellan: (mutex-lock! m) 5cefaba81b 2011-06-16 mrwellan: (vector-set! exit-info 0 pid) 5cefaba81b 2011-06-16 mrwellan: (vector-set! exit-info 1 exit-status) 5cefaba81b 2011-06-16 mrwellan: (vector-set! exit-info 2 exit-code) 5cefaba81b 2011-06-16 mrwellan: (mutex-unlock! m) 5cefaba81b 2011-06-16 mrwellan: (if (eq? pid-val 0) 5cefaba81b 2011-06-16 mrwellan: (begin 5cefaba81b 2011-06-16 mrwellan: (thread-sleep! 2) 5cefaba81b 2011-06-16 mrwellan: (loop (+ i 1))) 5cefaba81b 2011-06-16 mrwellan: )))))) ae6dbecf17 2011-05-02 matt: (monitorjob (lambda () ae6dbecf17 2011-05-02 matt: (let* ((start-seconds (current-seconds)) ae6dbecf17 2011-05-02 matt: (calc-minutes (lambda () ae6dbecf17 2011-05-02 matt: (inexact->exact ae6dbecf17 2011-05-02 matt: (round ae6dbecf17 2011-05-02 matt: (- ae6dbecf17 2011-05-02 matt: (current-seconds) 5cefaba81b 2011-06-16 mrwellan: start-seconds))))) 5cefaba81b 2011-06-16 mrwellan: (kill-tries 0)) ae6dbecf17 2011-05-02 matt: (let loop ((minutes (calc-minutes))) ae6dbecf17 2011-05-02 matt: (let ((db (open-db))) ae6dbecf17 2011-05-02 matt: (set! kill-job? (test-get-kill-request db run-id test-name itemdat)) ae6dbecf17 2011-05-02 matt: (test-update-meta-info db run-id test-name itemdat minutes) c075ebd51b 2011-06-16 mrwellan: (if kill-job? c075ebd51b 2011-06-16 mrwellan: (begin 5cefaba81b 2011-06-16 mrwellan: (mutex-lock! m) 5cefaba81b 2011-06-16 mrwellan: (let* ((pid (vector-ref exit-info 0))) 5cefaba81b 2011-06-16 mrwellan: (if (number? pid) 5cefaba81b 2011-06-16 mrwellan: (begin bcc1c96231 2011-07-11 mrwellan: (debug:print 0 "WARNING: Request received to kill job (attempt # " kill-tries ")") 5cefaba81b 2011-06-16 mrwellan: ;;(cond 5cefaba81b 2011-06-16 mrwellan: ;;((> kill-tries 0) ; 2) 5cefaba81b 2011-06-16 mrwellan: (let ((processes (cmd-run->list (conc "pgrep -l -P " pid)))) 5cefaba81b 2011-06-16 mrwellan: (for-each 5cefaba81b 2011-06-16 mrwellan: (lambda (p) 5cefaba81b 2011-06-16 mrwellan: (let* ((parts (string-split p)) 5cefaba81b 2011-06-16 mrwellan: (p-id (if (> (length parts) 0) 5cefaba81b 2011-06-16 mrwellan: (string->number (car parts)) 5cefaba81b 2011-06-16 mrwellan: #f))) 5cefaba81b 2011-06-16 mrwellan: (if p-id 5cefaba81b 2011-06-16 mrwellan: (begin bcc1c96231 2011-07-11 mrwellan: (debug:print 0 "Killing " (cadr parts) "; kill -9 " p-id) 5cefaba81b 2011-06-16 mrwellan: (system (conc "kill -9 " p-id)))))) 5cefaba81b 2011-06-16 mrwellan: (car processes)) 5cefaba81b 2011-06-16 mrwellan: (system (conc "kill -9 " pid)))) 5cefaba81b 2011-06-16 mrwellan: ;;(let* ((ppid (process-group-id pid)) 5cefaba81b 2011-06-16 mrwellan: ;; (kcmd (conc "pkill -9 -g " ppid))) 5cefaba81b 2011-06-16 mrwellan: ;; ;; (process-signal pid signal/term) 5cefaba81b 2011-06-16 mrwellan: ;; ;; (process-signal pid signal/kill) bcc1c96231 2011-07-11 mrwellan: ;; (debug:print 0 "Attempting to kill pid " pid " and children in process group " ppid " with command:\n " kcmd) bcc1c96231 2011-07-11 mrwellan: ;; (debug:print 0 "Children:") 5cefaba81b 2011-06-16 mrwellan: ;; (system (conc "pgrep -g -l " ppid)) 5cefaba81b 2011-06-16 mrwellan: ;; (system kcmd) 5cefaba81b 2011-06-16 mrwellan: ;; (sleep 1) ;; give it a rest 5cefaba81b 2011-06-16 mrwellan: ;; (test-set-status! db run-id test-name "KILLED" "FAIL" 5cefaba81b 2011-06-16 mrwellan: ;; itemdat (args:get-arg "-m")) 5cefaba81b 2011-06-16 mrwellan: ;; (sqlite3:finalize! db) 5cefaba81b 2011-06-16 mrwellan: ;; (exit 1))))) 5cefaba81b 2011-06-16 mrwellan: (begin bcc1c96231 2011-07-11 mrwellan: (debug:print 0 "WARNING: Request received to kill job but problem with process, attempting to kill manager process") 5cefaba81b 2011-06-16 mrwellan: (test-set-status! db run-id test-name "KILLED" "FAIL" 5cefaba81b 2011-06-16 mrwellan: itemdat (args:get-arg "-m")) 5cefaba81b 2011-06-16 mrwellan: (sqlite3:finalize! db) 5cefaba81b 2011-06-16 mrwellan: (exit 1)))) 5cefaba81b 2011-06-16 mrwellan: ;; (thread-terminate! job-thread))) 5cefaba81b 2011-06-16 mrwellan: (set! kill-tries (+ 1 kill-tries)) 5cefaba81b 2011-06-16 mrwellan: (mutex-unlock! m))) 5cefaba81b 2011-06-16 mrwellan: ;; (handle-exceptions 5cefaba81b 2011-06-16 mrwellan: ;; exn 5cefaba81b 2011-06-16 mrwellan: ;; (begin bcc1c96231 2011-07-11 mrwellan: ;; (debug:print 0 "ERROR: Problem killing process " (vector-ref exit-info 0)) 5cefaba81b 2011-06-16 mrwellan: ;; (abort exn)) 5cefaba81b 2011-06-16 mrwellan: ;; (let* ((pid (vector-ref exit-info 0)) 5cefaba81b 2011-06-16 mrwellan: ;; ;; (pgid (process-group-id pid)) 5cefaba81b 2011-06-16 mrwellan: ;; ;; (cmd (conc "pkill -9 -P " pgid)) 5cefaba81b 2011-06-16 mrwellan: ;; ) bcc1c96231 2011-07-11 mrwellan: ;; ;; (debug:print 0 "Running \"" cmd "\"") 5cefaba81b 2011-06-16 mrwellan: ;; ;; (system cmd) bcc1c96231 2011-07-11 mrwellan: ;; (debug:print 0 "Running \"kill -9 " pid "\"") 5cefaba81b 2011-06-16 mrwellan: ;; (system (conc "kill -9 " pid)) 5cefaba81b 2011-06-16 mrwellan: ;; ;; (process-signal (vector-ref exit-info 0) signal/kill) 5cefaba81b 2011-06-16 mrwellan: ;; )))) ae6dbecf17 2011-05-02 matt: (sqlite3:finalize! db) ae6dbecf17 2011-05-02 matt: (thread-sleep! (+ 8 (random 4))) ;; add some jitter to the call home time to spread out the db accesses ae6dbecf17 2011-05-02 matt: (loop (calc-minutes))))))) ae6dbecf17 2011-05-02 matt: (th1 (make-thread monitorjob)) ae6dbecf17 2011-05-02 matt: (th2 (make-thread runit))) 5cefaba81b 2011-06-16 mrwellan: (set! job-thread th2) ae6dbecf17 2011-05-02 matt: (thread-start! th1) ae6dbecf17 2011-05-02 matt: (thread-start! th2) ae6dbecf17 2011-05-02 matt: (thread-join! th2) ae6dbecf17 2011-05-02 matt: (mutex-lock! m) ae6dbecf17 2011-05-02 matt: (set! db (open-db)) 772558f8b5 2011-05-06 mrwellan: (let* ((testinfo (db:get-test-info db run-id test-name (item-list->path itemdat)))) ae6dbecf17 2011-05-02 matt: (if (not (equal? (db:test-get-state testinfo) "COMPLETED")) ae6dbecf17 2011-05-02 matt: (begin bcc1c96231 2011-07-11 mrwellan: (debug:print 2 "Test NOT logged as COMPLETED, (state=" (db:test-get-state testinfo) "), updating result") ae6dbecf17 2011-05-02 matt: (test-set-status! db run-id test-name ae6dbecf17 2011-05-02 matt: (if kill-job? "KILLED" "COMPLETED") ae6dbecf17 2011-05-02 matt: (if (vector-ref exit-info 1) ;; look at the exit-status d73b2c1642 2011-06-27 mrwellan: (if (and (not kill-job?) d73b2c1642 2011-06-27 mrwellan: (eq? (vector-ref exit-info 2) 0)) ae6dbecf17 2011-05-02 matt: "PASS" ae6dbecf17 2011-05-02 matt: "FAIL") ae6dbecf17 2011-05-02 matt: "FAIL") itemdat (args:get-arg "-m"))))) ae6dbecf17 2011-05-02 matt: (mutex-unlock! m) ae6dbecf17 2011-05-02 matt: ;; (exec-results (cmd-run->list fullrunscript)) ;; (list ">" (conc test-name "-run.log")))) ae6dbecf17 2011-05-02 matt: ;; (success exec-results)) ;; (eq? (cadr exec-results) 0))) bcc1c96231 2011-07-11 mrwellan: (debug:print 2 "Output from running " fullrunscript ", pid " (vector-ref exit-info 0) " in work area " ae6dbecf17 2011-05-02 matt: work-area ":\n====\n exit code " (vector-ref exit-info 2) "\n" "====\n") ae6dbecf17 2011-05-02 matt: (sqlite3:finalize! db) ae6dbecf17 2011-05-02 matt: (if (not (vector-ref exit-info 1)) ae6dbecf17 2011-05-02 matt: (exit 4))))) ae6dbecf17 2011-05-02 matt: (set! *didsomething* #t))) ae6dbecf17 2011-05-02 matt: 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)) 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)) ae6dbecf17 2011-05-02 matt: (if (and state status) 1146144d5b 2011-05-05 matt: (teststep-set-status! db run-id test-name step state status itemdat (args:get-arg "-m")) 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") ae6dbecf17 2011-05-02 matt: (args:get-arg "-runstep")) 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)) 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)) ae6dbecf17 2011-05-02 matt: (if (args:get-arg "-setlog") ae6dbecf17 2011-05-02 matt: (test-set-log! db run-id test-name itemdat (args:get-arg "-setlog"))) 00761e1112 2011-05-15 matt: (if (args:get-arg "-set-toplog") 00761e1112 2011-05-15 matt: (test-set-toplog! db run-id test-name (args:get-arg "-set-toplog"))) 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) ">&") 6696dc330f 2011-05-07 matt: ((zsh bash sh ash) "2>&1 >"))) 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 c075ebd51b 2011-06-16 mrwellan: (teststep-set-status! db run-id test-name stepname "start" "n/a" itemdat (args:get-arg "-m")) ae6dbecf17 2011-05-02 matt: ;; close the db ae6dbecf17 2011-05-02 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 e38c4a9bdd 2011-05-03 matt: (set! db (open-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) 89a6bb7363 2011-05-08 matt: (test-set-log! db run-id test-name itemdat htmllogfile))) 290c7d7cc8 2011-05-10 mrwellan: (teststep-set-status! db run-id test-name stepname "end" exitstat itemdat (args:get-arg "-m")) e38c4a9bdd 2011-05-03 matt: (sqlite3:finalize! db) 290c7d7cc8 2011-05-10 mrwellan: (if (not (eq? exitstat 0)) 290c7d7cc8 2011-05-10 mrwellan: (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: ))) f412143bd2 2011-05-31 mrwellan: (if (args:get-arg "-test-status") f412143bd2 2011-05-31 mrwellan: (let ((newstatus (cond f412143bd2 2011-05-31 mrwellan: ((number? status) (if (equal? status 0) "PASS" "FAIL")) f412143bd2 2011-05-31 mrwellan: ((string->number status)(if (equal? (string->number status) 0) "PASS" "FAIL")) f412143bd2 2011-05-31 mrwellan: (else status)))) f412143bd2 2011-05-31 mrwellan: (test-set-status! db run-id test-name state newstatus itemdat (args:get-arg "-m"))) f412143bd2 2011-05-31 mrwellan: (if (and state status) f412143bd2 2011-05-31 mrwellan: (if (not (args:get-arg "-setlog")) f412143bd2 2011-05-31 mrwellan: (begin bcc1c96231 2011-07-11 mrwellan: (debug:print 0 "ERROR: You must specify :state and :status with every call to -test-status\n" help) f412143bd2 2011-05-31 mrwellan: (sqlite3:finalize! db) f412143bd2 2011-05-31 mrwellan: (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 (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)) ae6dbecf17 2011-05-02 matt: (set! keys (db-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) 3bb0b5e9f9 2011-07-19 matt: (set! *didsomething* #t))) 3bb0b5e9f9 2011-07-19 matt: 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) bcc1c96231 2011-07-11 mrwellan: (set! *didsomething* #t))) 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