Index: common.scm ================================================================== --- common.scm +++ common.scm @@ -1704,10 +1704,21 @@ path) ;; just give up (with-input-from-pipe (conc "/bin/readlink -f " path) (lambda () (read-line))))) + +(define (common:get-intercept onemin fivemin) + (let* ((load-change (- onemin fivemin)) + (tchange (- 300 60))) + (max (+ onemin (* 60 (/ load-change tchange)))0)) +) + +(define (common:get-delay load-in numcpus) + (max (/ (expt 5 (* 4 (/ load-in numcpus))) 10) 0) +) + (define (get-cpu-load #!key (remote-host #f)) (car (common:get-cpu-load remote-host))) ;; (let* ((load-res (process:cmd-run->list "uptime")) ;; (load-rx (regexp "load average:\\s+(\\d+)")) Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -1760,35 +1760,22 @@ (if (and (null? incompleted) (null? oldlaunched) (null? toplevels)) #f #t))))) - -;; given a launch delay (minimum time from last launch) return amount of time to wait -;; -;; (define (db:launch-delay-left dbstruct run-id launch-delay) - - (define (db:get-status-from-final-status-file run-dir) - (let ( - (infile (conc run-dir "/.final-status"))) - - ;; first verify we are able to write the output file - (if (not (file-read-access? infile)) - (begin - (debug:print 0 *default-log-port* "ERROR: cannot read " infile) + (let ((infile (conc run-dir "/.final-status"))) + ;; first verify we are able to write the output file + (if (not (file-read-access? infile)) + (begin + (debug:print 0 *default-log-port* "ERROR: cannot read " infile) (debug:print 0 *default-log-port* "ERROR: run-dir is " run-dir) #f ) - (with-input-from-file infile read-lines) - ) - ) -) - - - + (with-input-from-file infile read-lines) + ))) ;; select end_time-now from ;; (select testname,item_path,event_time+run_duration as ;; end_time,strftime('%s','now') as now from tests where state in ;; ('RUNNING','REMOTEHOSTSTART','LAUNCHED')); @@ -3231,11 +3218,11 @@ ;; ;; (define (db:get-running-stats dbstruct run-id) (define (db:get-count-tests-running-for-run-id dbstruct run-id fastmode) (let* ((qry (if fastmode "SELECT count(id) FROM tests WHERE state in ('RUNNING','LAUNCHED','REMOTEHOSTSTART') AND run_id=? LIMIT 1;" - "SELECT count(id) FROM tests WHERE state in ('RUNNING','LAUNCHED','REMOTEHOSTSTART') AND run_id=?;"))) + "SELECT count(id) FROM tests WHERE state in ('RUNNING','LAUNCHED','REMOTEHOSTSTART') AND run_id=?;"))) (db:with-db dbstruct run-id #f (lambda (db) @@ -3249,14 +3236,14 @@ (db:with-db dbstruct run-id #f (lambda (db) - (sqlite3:first-result - db - "SELECT count(id) FROM tests WHERE state in ('RUNNING','LAUNCHED','REMOTEHOSTSTART') AND run_id=? AND NOT (uname = 'n/a' AND item_path = '') AND testname=?;" run-id testname)))) - + (let* ((stmt "SELECT count(id) FROM tests WHERE state in ('RUNNING','LAUNCHED','REMOTEHOSTSTART') AND run_id=? AND NOT (uname = 'n/a' AND item_path = '') AND testname=?;") + (stmth (db:get-cache-stmth dbstruct db stmt))) + (sqlite3:first-result + stmth run-id testname))))) (define (db:get-not-completed-cnt dbstruct run-id) (db:with-db dbstruct run-id @@ -4093,10 +4080,13 @@ run-id ))))) test-count-recs)) ;; BBnote: db:get-all-state-status-counts-for-test returns dbr:counts object aggregating state and status of items of a given test, *not including rollup state/status* +;; +;; NOTE: This is called within a transaction +;; (define (db:get-all-state-status-counts-for-test dbstruct run-id test-name item-path item-state-in item-status-in) (let* ((test-info (db:get-test-info dbstruct run-id test-name item-path)) (item-state (or item-state-in (db:test-get-state test-info))) (item-status (or item-status-in (db:test-get-status test-info))) (other-items-count-recs (db:with-db Index: dcommon.scm ================================================================== --- dcommon.scm +++ dcommon.scm @@ -637,11 +637,11 @@ (iup:attribute-set! stats-matrix "CLEARVALUE" "CONTENTS") (iup:attribute-set! stats-matrix "NUMCOL" max-col ) (iup:attribute-set! stats-matrix "NUMLIN" (if (< max-row max-visible) max-visible max-row)) ;; min of 20 (iup:attribute-set! stats-matrix "NUMCOL_VISIBLE" max-col-vis) (iup:attribute-set! stats-matrix "NUMLIN_VISIBLE" (if (> max-row max-visible) max-visible max-row)) - (print "row-indices: " row-indices " col-indices: " col-indices) + ;;(print "row-indices: " row-indices " col-indices: " col-indices) ;; Row labels (for-each (lambda (ind) (let* ((name (car ind)) (num (cadr ind)) (key (conc num ":0"))) Index: genexample.scm ================================================================== --- genexample.scm +++ genexample.scm @@ -17,11 +17,13 @@ ;; along with Megatest. If not, see . ;;====================================================================== (declare (unit genexample)) -(use posix regex) +(use posix regex matchable) + +(include "db_records.scm") (define genexample:example-logpro #<seconds str) + (let* ((parts (string-split str)) + (res 0)) + (for-each + (lambda (part) + (set! res + (+ res + (match (string-match "(\\d+)([a-z])" part) + ((_ val units)(* (string->number val)(case (string->symbol units) + ((s) 1) + ((m) 60) + ((h) 3600)))) + (else 0))))) + parts) + res)) + +;; generate a skeleton Megatest area from a current area with runs +;; +;; specify target, runname etc to use specific runs for the template +;; +(define (genexample:extract-skeleton-area dest-path) + (let* ((target (args:get-arg "-target")) + (runname (args:get-arg "-runname")) + (obtuse (make-hash-table)) + (obtusef (args:get-arg "-obfuscate")) + (letters (string-split-fields "\\S" "abcdefghijklmnopqrstuvwxyz")) + (maxletter (- (length letters) 1)) + (lastlet 0) + (lastnum 1) + (obfuscate (lambda (instr) + (or (hash-table-ref/default obtuse instr #f) + (if obtusef + (let* ((letter (list-ref letters lastlet)) + (val (conc letter lastnum))) + (if (>= lastlet maxletter) + (begin + (set! lastlet 0) + (set! lastnum (+ lastnum 1))) + (set! lastlet (+ lastlet 1))) + (hash-table-set! obtuse instr val) + val) + instr))))) + (if (not (and target runname)) + (debug:print 0 *default-log-port* "WARNING: For best results please specifiy -target and -runname for a good run to use as a template.")) + (if (not (and (file-exists? "megatest.config") + (file-exists? "megatest.db"))) + (begin + (debug:print 0 *default-log-port* "ERROR: this command must be run at the top level of a megatest area where runs have been completed") + (exit))) + + ;; first create the dest path and needed subdirectories + (if (not (file-exists? dest-path)) + (begin + (create-directory dest-path) + (create-directory (conc dest-path "/tests"))) + (if (file-exists? (conc dest-path "/megatest.config")) + (begin + (debug:print 0 *default-log-port* "ERROR: destination path already has megatest.config, stopping now.") + (exit)))) + + ;; dump the config files from this area to the dest area + (if (args:get-arg "-obfuscate") + (debug:print 0 *default-log-port* "WARNING: obfuscation is NOT done on megatest.config and runconfigs.config. Please edit those files to remove any sensitive information!")) + (system (conc "megatest -show-config > " dest-path "/megatest.config")) + (system (conc "megatest -show-runconfig > " dest-path "/runconfigs.config")) + + ;; create stepsinfo and items refdbs, some stuff has to be done due to refdb not initing area + ;; + ;; sheet row col value + ;; stepsinfo testname itempath stepname steptime + ;; miscinfo "itemsinfo" testname itempath "x" + ;; + (for-each + (lambda (rdbname) + (if (not (file-exists? (conc dest-path "/" rdbname))) + (begin + (create-directory (conc dest-path "/" rdbname "/sxml") #t) + (with-output-to-file (conc dest-path "/" rdbname "/sheet-names.cfg") + (lambda ()(print)))))) + '("stepsinfo" "miscinfo")) + + (let* ((runs (rmt:simple-get-runs (or runname "%") #f #f (or target "%"))) + (tests (make-hash-table)) ;; just tests + (fullt (make-hash-table)) ;; all test/items + (testreg (make-hash-table)) ;; for the testconfigs + (stepsrdb (conc dest-path "/stepsinfo")) + (miscrdb (conc dest-path "/miscinfo"))) + (if (> (length runs) 1) + (debug:print-info 0 *default-log-port* "More than one run matches, first found data will be used.")) + ;; get all testnames + (for-each + (lambda (run-id) + (let* ((tests-data (rmt:get-tests-for-run run-id "%" '() '() #f #f #f #f #f #f #f #f))) + (for-each + (lambda (testdat) + (let* ((test-id (db:test-get-id testdat)) + (testname (db:test-get-testname testdat)) + (item-path (db:test-get-item-path testdat)) + (tlevel (db:test-get-is-toplevel testdat)) + (tfullname (db:test-get-fullname testdat)) + ;; now get steps info + (test-steps (tests:get-compressed-steps run-id test-id)) + (testconfig (tests:get-testconfig testname item-path testreg #f))) + + + (if (not (hash-table-exists? fullt tfullname)) + ;; do the work for this test if not previously done + (let* ((new-test-dir (conc dest-path "/tests/" (obfuscate testname))) + (tconfigf (conc new-test-dir "/testconfig"))) + (print "Analyzing and extracting info for " tfullname " as " (obfuscate testname)) + (print " toplevel: " (if tlevel "yes" "no")) + (hash-table-set! fullt tfullname #t) ;; track that this one has been seen + (if (not (directory-exists? new-test-dir)) + (create-directory new-test-dir #t)) + + ;; create the testconfig IIF we are a toplevel or an item AND the testconfig has not been previously created + (if (and (or (not tlevel) + (not (equal? item-path ""))) + (not (file-exists? tconfigf))) + (with-output-to-file tconfigf + (lambda () + ;; first the ezsteps + (print "[ezsteps]") + (for-each + (lambda (teststep) + (let* ((step-name (vector-ref teststep 0))) + (print (obfuscate step-name) + " sleep $(refdb lookup #{getenv MT_RUN_AREA_HOME}/stepsinfo " + (obfuscate testname) " $MT_ITEMPATH " + (obfuscate step-name) ")"))) + test-steps) + + ;; now the requirements section + (if testconfig + (begin + (print "\n[requirements]") + (for-each + (lambda (entry) + (let* ((key (car entry)) + (val (cadr entry))) + (case (string->symbol key) + ((waiton) (print "waiton " (obfuscate val))) + (else (print key " " val))))) + (configf:get-section testconfig "requirements"))) + #;(print "WARNING: No testconfig data for " testname ", " item-path)) + + (print "\n[items]") + (print "THE_ITEM [system refdb getrow #{getenv MT_RUN_AREA_HOME}/miscinfo itemsinfo " (obfuscate testname)" | awk '{print $1}']") + ))) + + ;; fill the stepsrdb + (for-each + (lambda (teststep) + (let* ((step-name (vector-ref teststep 0)) + (step-duration (hrs-min-sec->seconds (vector-ref teststep 4)))) + + (system (conc "refdb set " stepsrdb " " (obfuscate testname) + " '" (if (equal? item-path "") + "no-item-path" + (obfuscate item-path)) + "' " (obfuscate step-name) " " step-duration)))) + test-steps) + + ;; miscinfo "itemsinfo" testname itempath "x" + (if (not (equal? item-path "")) + (system (conc "refdb set " miscrdb " itemsinfo " (obfuscate testname) " " (obfuscate item-path) " x"))) + + )))) + tests-data))) + (map (lambda (runrec)(simple-run-id runrec)) runs))) + )) Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -232,15 +232,13 @@ -dest to set destination), -include path1,path2... to get or save specific files -generate-html : create a simple html dashboard for browsing your runs -generate-html-structure : create a top level html veiw to list targets/runs and a Run view within each run directory. -list-run-time : list time requered to complete runs. It supports following switches -run-patt -target-patt -dumpmode - -list-test-time : list time requered to complete each test in a run. It following following arguments + -list-test-time : list time requered to complete each test in a run. It following following arguments -runname -target -dumpmode - - - + -extract-skeleton targd : extract a skeleton area based on the current area. Use median step run times. Diff report -diff-rep : generate diff report (must include -src-target, -src-runname, -target, -runname and either -diff-email or -diff-html) -src-target @@ -371,10 +369,13 @@ "-diff-email" "-sync-to" "-pgsync" "-kill-wait" ;; wait this long before removing test (default is 10 sec) "-diff-html" + + ;; wizards, area capture, setup new ... + "-extract-skeleton" ) (list "-h" "-help" "--help" "-manual" "-version" "-force" @@ -446,10 +447,11 @@ "-v" ;; verbose 2, more than normal (normal is 1) "-q" ;; quiet 0, errors/warnings only "-diff-rep" + "-obfuscate" ;; junk placeholder ;; "-:p" ) args:arg-hash @@ -2433,17 +2435,24 @@ (let* ((toppath (launch:setup))) (if (tests:create-html-tree #f) (debug:print-info 0 *default-log-port* "HTML output created in " toppath "/lt/page0.html") (debug:print 0 *default-log-port* "Failed to create HTML output in " toppath "/lt/runs-index.html")) (set! *didsomething* #t))) + (if (args:get-arg "-generate-html-structure") (let* ((toppath (launch:setup))) ;(if (tests:create-html-tree #f) (if (tests:create-html-summary #f) (debug:print-info 0 *default-log-port* "HTML output created in " toppath "/lt/targets.html") (debug:print 0 *default-log-port* "Failed to create HTML output in " toppath "/lt/runs-index.html")) (set! *didsomething* #t))) + +(if (args:get-arg "-extract-skeleton") + (let* ((toppath (launch:setup))) + (genexample:extract-skeleton-area (args:get-arg "-extract-skeleton")) + (set! *didsomething* #t))) + ;;====================================================================== ;; Exit and clean up ;;====================================================================== (if (not *didsomething*) Index: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -102,12 +102,12 @@ (runs:dat-last-fuel-check-set! rdat (current-seconds)))))) ;; Fourth try, do accounting through time ;; (define (runs:parallel-runners-mgmt rdat) - (let ((time-to-check 10) ;; 28 - (time-to-wait 30) + (let ((time-to-check (configf:lookup-number *configdat* "runners" "time-to-check" default: 10)) ;; 28 + (time-to-wait (configf:lookup-number *configdat* "runners" "time-to-wait" default: 30)) (now-time (current-seconds))) (if (> (- now-time (runs:dat-last-fuel-check rdat)) time-to-check) ;; time to check (runs:wait-on-softlock rdat "runners")))) ;; To test parallel-runners management start a repl: @@ -2043,11 +2043,11 @@ (debug:print-info 1 *default-log-port* "SKIPPING Test " full-test-name " due to " skip-test)) ;; ;; Here the test is handed off to launch.scm for launch-test to complete the launch process ;; (if (not (launch-test test-id run-id run-info keyvals runname test-conf test-name test-path itemdat flags)) - (begin + (begin (print "ERROR: Failed to launch the test. Exiting as soon as possible") (set! *globalexitstatus* 1) ;; (process-signal (current-process-id) signal/kill)))))))) ((KILLED) (debug:print 1 *default-log-port* "NOTE: " full-test-name " is already running or was explictly killed, use -force to launch it.")