@@ -86,10 +86,11 @@ "-set-toplog" "-runstep" "-logpro" "-m" "-rerun" + "-debug" ;; for *verbosity* > 2 ) (list "-h" "-force" "-xterm" "-showkeys" @@ -97,10 +98,12 @@ "-gui" "-runall" ;; run all tests "-remove-runs" "-keepgoing" "-usequeue" + "-v" ;; verbose 2, more than normal (normal is 1) + "-q" ;; quiet 0, errors/warnings only ) args:arg-hash 0)) (if (args:get-arg "-h") @@ -121,36 +124,42 @@ ;;====================================================================== ;; Misc setup stuff ;;====================================================================== +(define *verbosity* (cond + ((args:get-arg "-debug")(string->number (args:get-arg "-debug"))) + ((args:get-arg "-v") 2) + ((args:get-arg "-q") 0) + (else 1))) + ;;====================================================================== ;; Remove old run(s) ;;====================================================================== ;; since several actions can be specified on the command line the removal ;; is done first (define (remove-runs) (cond ((not (args:get-arg ":runname")) - (print "ERROR: Missing required parameter for -remove-runs, you must specify the run name pattern with :runname patt") + (debug:print 0 "ERROR: Missing required parameter for -remove-runs, you must specify the run name pattern with :runname patt") (exit 2)) ((not (args:get-arg "-testpatt")) - (print "ERROR: Missing required parameter for -remove-runs, you must specify the test pattern with -testpatt") + (debug:print 0 "ERROR: Missing required parameter for -remove-runs, you must specify the test pattern with -testpatt") (exit 3)) ((not (args:get-arg "-itempatt")) (print "ERROR: Missing required parameter for -remove-runs, you must specify the items with -itempatt") (exit 4)) ((let ((db #f)) (if (not (setup-for-run)) (begin - (print "Failed to setup, exiting") + (debug:print 0 print "Failed to setup, exiting") (exit 1))) (set! db (open-db)) (if (not (car *configinfo*)) (begin - (print "ERROR: Attempted to remove test(s) but run area config file not found") + (debug:print 0 "ERROR: Attempted to remove test(s) but run area config file not found") (exit 1)) ;; put test parameters into convenient variables (runs:remove-runs db (args:get-arg ":runname") (args:get-arg "-testpatt") @@ -178,11 +187,11 @@ (keys (db-get-keys db)) (keynames (map key:get-fieldname keys))) ;; Each run (for-each (lambda (run) - (print "Run: " + (debug:print 2 "Run: " (string-intersperse (map (lambda (x) (db:get-value-by-header run header x)) keynames) "/") "/" (db:get-value-by-header run header "runname")) @@ -219,14 +228,10 @@ " Step: ~20a State: ~10a Status: ~10a Time ~22a\n" (db:step-get-stepname step) (db:step-get-state step) (db:step-get-status step) (db:step-get-event_time step))) - ;; (print " Step: " (db:step-get-stepname step) - ;; " " (db:step-get-state step) - ;; " " (db:step-get-status step) - ;; " " (db:step-get-event_time step))) steps))))) tests)))) runs) (set! *didsomething* #t) )) @@ -251,25 +256,25 @@ ;; run all tests are are Not COMPLETED and PASS or CHECK (if (args:get-arg "-runall") (if (not (args:get-arg ":runname")) (begin - (print "ERROR: Missing required parameter for -runtests, you must specify the run name with :runname runname") + (debug:print 0 "ERROR: Missing required parameter for -runtests, you must specify the run name with :runname runname") (exit 2)) (let* ((db (if (setup-for-run) (open-db) (begin - (print "Failed to setup, exiting") + (debug:print 0 "Failed to setup, exiting") (exit 1))))) (if (not (car *configinfo*)) (begin - (print "ERROR: Attempted to run a test but run area config file not found") + (debug:print 0 "ERROR: Attempted to run a test but run area config file not found") (exit 1)) ;; put test parameters into convenient variables (let* ((test-names (get-all-legal-tests))) ;; "PROD" is ignored for now - (print "INFO: Attempting to start the following tests...") - (print " " (string-intersperse test-names ",")) + (debug:print 1 "INFO: Attempting to start the following tests...") + (debug:print 1 " " (string-intersperse test-names ",")) (run-tests db test-names))) ;; (run-waiting-tests db) (sqlite3:finalize! db) (set! *didsomething* #t)))) @@ -291,21 +296,21 @@ ;; - if cannot access db > allowed disconnect time then kill job (define (runtests) (if (not (args:get-arg ":runname")) (begin - (print "ERROR: Missing required parameter for -runtests, you must specify the run name with :runname runname") + (debug:print 0 "ERROR: Missing required parameter for -runtests, you must specify the run name with :runname runname") (exit 2)) (let ((db #f)) (if (not (setup-for-run)) (begin - (print "Failed to setup, exiting") + (debug:print 0 "Failed to setup, exiting") (exit 1))) (set! db (open-db)) (if (not (car *configinfo*)) (begin - (print "ERROR: Attempted to run a test but run area config file not found") + (debug:print 0 "ERROR: Attempted to run a test but run area config file not found") (exit 1)) ;; put test parameters into convenient variables (let* ((test-names (string-split (args:get-arg "-runtests") ","))) (run-tests db test-names))) ;; run-waiting-tests db) @@ -339,11 +344,11 @@ (runname (assoc/default 'runname cmdinfo)) (megatest (assoc/default 'megatest cmdinfo)) (mt-bindir-path (assoc/default 'mt-bindir-path cmdinfo)) (fullrunscript (conc testpath "/" runscript)) (db #f)) - (print "Exectuing " test-name " on " (get-host-name)) + (debug:print 2 "Exectuing " test-name " on " (get-host-name)) (change-directory testpath) (setenv "MT_TEST_RUN_DIR" work-area) (setenv "MT_TEST_NAME" test-name) (setenv "MT_ITEM_INFO" (conc itemdat)) (setenv "MT_RUNNAME" runname) @@ -350,19 +355,19 @@ (setenv "MT_MEGATEST" megatest) (setenv "PATH" (conc (getenv "PATH") ":" mt-bindir-path)) (if (not (setup-for-run)) (begin - (print "Failed to setup, exiting") + (debug:print 0 "Failed to setup, exiting") (exit 1))) ;; now can find our db (set! db (open-db)) (change-directory work-area) (let ((runconfigf (conc *toppath* "/runconfigs.config"))) (if (file-exists? runconfigf) (setup-env-defaults db runconfigf run-id) - (print "WARNING: You do not have a run config file: " runconfigf))) + (debug:print 0 "WARNING: You do not have a run config file: " runconfigf))) ;; environment overrides are done *before* the remaining critical envars. (alist->env-vars env-ovrd) (set-megatest-env-vars db run-id) (set-item-env-vars itemdat) (save-environment-as-files "megatest") @@ -421,11 +426,11 @@ (begin (mutex-lock! m) (let* ((pid (vector-ref exit-info 0))) (if (number? pid) (begin - (print "WARNING: Request received to kill job (attempt # " kill-tries ")") + (debug:print 0 "WARNING: Request received to kill job (attempt # " kill-tries ")") ;;(cond ;;((> kill-tries 0) ; 2) (let ((processes (cmd-run->list (conc "pgrep -l -P " pid)))) (for-each (lambda (p) @@ -433,29 +438,29 @@ (p-id (if (> (length parts) 0) (string->number (car parts)) #f))) (if p-id (begin - (print "Killing " (cadr parts) "; kill -9 " p-id) + (debug:print 0 "Killing " (cadr parts) "; kill -9 " p-id) (system (conc "kill -9 " p-id)))))) (car processes)) (system (conc "kill -9 " pid)))) ;;(let* ((ppid (process-group-id pid)) ;; (kcmd (conc "pkill -9 -g " ppid))) ;; ;; (process-signal pid signal/term) ;; ;; (process-signal pid signal/kill) - ;; (print "Attempting to kill pid " pid " and children in process group " ppid " with command:\n " kcmd) - ;; (print "Children:") + ;; (debug:print 0 "Attempting to kill pid " pid " and children in process group " ppid " with command:\n " kcmd) + ;; (debug:print 0 "Children:") ;; (system (conc "pgrep -g -l " ppid)) ;; (system kcmd) ;; (sleep 1) ;; give it a rest ;; (test-set-status! db run-id test-name "KILLED" "FAIL" ;; itemdat (args:get-arg "-m")) ;; (sqlite3:finalize! db) ;; (exit 1))))) (begin - (print "WARNING: Request received to kill job but problem with process, attempting to kill manager process") + (debug:print 0 "WARNING: Request received to kill job but problem with process, attempting to kill manager process") (test-set-status! db run-id test-name "KILLED" "FAIL" itemdat (args:get-arg "-m")) (sqlite3:finalize! db) (exit 1)))) ;; (thread-terminate! job-thread))) @@ -462,19 +467,19 @@ (set! kill-tries (+ 1 kill-tries)) (mutex-unlock! m))) ;; (handle-exceptions ;; exn ;; (begin - ;; (print "ERROR: Problem killing process " (vector-ref exit-info 0)) + ;; (debug:print 0 "ERROR: Problem killing process " (vector-ref exit-info 0)) ;; (abort exn)) ;; (let* ((pid (vector-ref exit-info 0)) ;; ;; (pgid (process-group-id pid)) ;; ;; (cmd (conc "pkill -9 -P " pgid)) ;; ) - ;; ;; (print "Running \"" cmd "\"") + ;; ;; (debug:print 0 "Running \"" cmd "\"") ;; ;; (system cmd) - ;; (print "Running \"kill -9 " pid "\"") + ;; (debug:print 0 "Running \"kill -9 " pid "\"") ;; (system (conc "kill -9 " pid)) ;; ;; (process-signal (vector-ref exit-info 0) signal/kill) ;; )))) (sqlite3:finalize! db) (thread-sleep! (+ 8 (random 4))) ;; add some jitter to the call home time to spread out the db accesses @@ -488,11 +493,11 @@ (mutex-lock! m) (set! db (open-db)) (let* ((testinfo (db:get-test-info db run-id test-name (item-list->path itemdat)))) (if (not (equal? (db:test-get-state testinfo) "COMPLETED")) (begin - (print "Test NOT logged as COMPLETED, (state=" (db:test-get-state testinfo) "), updating result") + (debug:print 2 "Test NOT logged as COMPLETED, (state=" (db:test-get-state testinfo) "), updating result") (test-set-status! db run-id test-name (if kill-job? "KILLED" "COMPLETED") (if (vector-ref exit-info 1) ;; look at the exit-status (if (and (not kill-job?) (eq? (vector-ref exit-info 2) 0)) @@ -500,21 +505,21 @@ "FAIL") "FAIL") itemdat (args:get-arg "-m"))))) (mutex-unlock! m) ;; (exec-results (cmd-run->list fullrunscript)) ;; (list ">" (conc test-name "-run.log")))) ;; (success exec-results)) ;; (eq? (cadr exec-results) 0))) - (print "Output from running " fullrunscript ", pid " (vector-ref exit-info 0) " in work area " + (debug:print 2 "Output from running " fullrunscript ", pid " (vector-ref exit-info 0) " in work area " work-area ":\n====\n exit code " (vector-ref exit-info 2) "\n" "====\n") (sqlite3:finalize! db) (if (not (vector-ref exit-info 1)) (exit 4))))) (set! *didsomething* #t))) (if (args:get-arg "-step") (if (not (getenv "MT_CMDINFO")) (begin - (print "ERROR: MT_CMDINFO env var not set, -step must be called *inside* a megatest invoked environment!") + (debug:print 0 "ERROR: MT_CMDINFO env var not set, -step must be called *inside* a megatest invoked environment!") (exit 5)) (let* ((step (args:get-arg "-step")) (cmdinfo (read (open-input-string (base64:base64-decode (getenv "MT_CMDINFO"))))) (testpath (assoc/default 'testpath cmdinfo)) (test-name (assoc/default 'test-name cmdinfo)) @@ -526,17 +531,17 @@ (state (args:get-arg ":state")) (status (args:get-arg ":status"))) (change-directory testpath) (if (not (setup-for-run)) (begin - (print "Failed to setup, exiting") + (debug:print 0 "Failed to setup, exiting") (exit 1))) (set! db (open-db)) (if (and state status) (teststep-set-status! db run-id test-name step state status itemdat (args:get-arg "-m")) (begin - (print "ERROR: You must specify :state and :status with every call to -step") + (debug:print 0 "ERROR: You must specify :state and :status with every call to -step") (exit 6))) (sqlite3:finalize! db) (set! *didsomething* #t)))) (if (or (args:get-arg "-setlog") ;; since setting up is so costly lets piggyback on -test-status @@ -543,11 +548,11 @@ (args:get-arg "-set-toplog") (args:get-arg "-test-status") (args:get-arg "-runstep")) (if (not (getenv "MT_CMDINFO")) (begin - (print "ERROR: MT_CMDINFO env var not set, commands -test-status, -runstep and -setlog must be called *inside* a megatest environment!") + (debug:print 0 "ERROR: MT_CMDINFO env var not set, commands -test-status, -runstep and -setlog must be called *inside* a megatest environment!") (exit 5)) (let* ((startingdir (current-directory)) (cmdinfo (read (open-input-string (base64:base64-decode (getenv "MT_CMDINFO"))))) (testpath (assoc/default 'testpath cmdinfo)) (test-name (assoc/default 'test-name cmdinfo)) @@ -559,21 +564,21 @@ (state (args:get-arg ":state")) (status (args:get-arg ":status"))) (change-directory testpath) (if (not (setup-for-run)) (begin - (print "Failed to setup, exiting") + (debug:print 0 "Failed to setup, exiting") (exit 1))) (set! db (open-db)) (if (args:get-arg "-setlog") (test-set-log! db run-id test-name itemdat (args:get-arg "-setlog"))) (if (args:get-arg "-set-toplog") (test-set-toplog! db run-id test-name (args:get-arg "-set-toplog"))) (if (args:get-arg "-runstep") (if (null? remargs) (begin - (print "ERROR: nothing specified to run!") + (debug:print 0 "ERROR: nothing specified to run!") (sqlite3:finalize! db) (exit 6)) (let* ((stepname (args:get-arg "-runstep")) (logprofile (args:get-arg "-logpro")) (logfile (conc stepname ".log")) @@ -590,11 +595,11 @@ ;; mark the start of the test (teststep-set-status! db run-id test-name stepname "start" "n/a" itemdat (args:get-arg "-m")) ;; close the db (sqlite3:finalize! db) ;; run the test step - (print "INFO: Running \"" fullcmd "\"") + (debug:print 2 "INFO: Running \"" fullcmd "\"") (change-directory startingdir) (set! exitstat (system fullcmd)) ;; cmd params)) (set! *globalexitstatus* exitstat) (change-directory testpath) ;; re-open the db @@ -602,11 +607,11 @@ ;; run logpro if applicable ;; (process-run "ls" (list "/foo" "2>&1" "blah.log")) (if logprofile (let* ((htmllogfile (conc stepname ".html")) (oldexitstat exitstat) (cmd (string-intersperse (list "logpro" logprofile htmllogfile "<" logfile ">" (conc stepname "_logpro.log")) " "))) - (print "INFO: running \"" cmd "\"") + (debug:print 2 "INFO: running \"" cmd "\"") (change-directory startingdir) (set! exitstat (system cmd)) (set! *globalexitstatus* exitstat) ;; no necessary (change-directory testpath) (test-set-log! db run-id test-name itemdat htmllogfile))) @@ -624,11 +629,11 @@ (else status)))) (test-set-status! db run-id test-name state newstatus itemdat (args:get-arg "-m"))) (if (and state status) (if (not (args:get-arg "-setlog")) (begin - (print "ERROR: You must specify :state and :status with every call to -test-status\n" help) + (debug:print 0 "ERROR: You must specify :state and :status with every call to -test-status\n" help) (sqlite3:finalize! db) (exit 6))))) (sqlite3:finalize! db) (set! *didsomething* #t)))) @@ -635,32 +640,32 @@ (if (args:get-arg "-showkeys") (let ((db #f) (keys #f)) (if (not (setup-for-run)) (begin - (print "Failed to setup, exiting") + (debug:print 0 "Failed to setup, exiting") (exit 1))) (set! db (open-db)) (set! keys (db-get-keys db)) - (print "Keys: " (string-intersperse (map key:get-fieldname keys) ", ")) + (debug:print 1 "Keys: " (string-intersperse (map key:get-fieldname keys) ", ")) (sqlite3:finalize! db) (set! *didsomething* #t))) (if (args:get-arg "-gui") (begin - (print "Look at the dashboard for now") + (debug:print 0 "Look at the dashboard for now") ;; (megatest-gui) (set! *didsomething* #t))) (if (not *didsomething*) - (print help)) + (debug:print 0 help)) (if (not (eq? *globalexitstatus* 0)) (if (or (args:get-arg "-runtests")(args:get-arg "-runall")) (begin - (print "NOTE: Subprocesses with non-zero exit code detected: " *globalexitstatus*) + (debug:print 0 "NOTE: Subprocesses with non-zero exit code detected: " *globalexitstatus*) (exit 0)) (case *globalexitstatus* ((0)(exit 0)) ((1)(exit 1)) ((2)(exit 2)) (else (exit 3)))))