@@ -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 "%") #f)) + (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))) + ))