Megatest

;; 
;;     You should have received a copy of the GNU General Public License
;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.

;;======================================================================

(declare (unit genexample))
(use posix regex matchable)

(include "db_records.scm")

(define genexample:example-logpro
#<<EOF
  ;; You should have at least one expect:required. This ensures that your process ran
  ;; comment out the line below and replace "put pattern here" with a pattern that will
  ;; always be seen in your log file if the step runs successfully.
  ;;

			(if (string-match ".*\\.sh$" script)
			    (begin
			      (with-output-to-file (conc testdir "/" script)
				(lambda ()
				  (print genexample:example-script)))
			      (system (conc "chmod ug+r,a+x " (conc testdir "/" script)))))))
		    steps))))))

;; easier to work backwards than change the upstream code
;;
(define (hrs-min-sec->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 [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)))
    ))