@@ -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)))
+ ))