Megatest

;;======================================================================
;; Copyright 2006-2012, Matthew Welland.
;; 
;; This file is part of Megatest.
;; 
;;     Megatest is free software: you can redistribute it and/or modify
;;     it under the terms of the GNU General Public License as published by
;;     the Free Software Foundation, either version 3 of the License, or
;;     (at your option) any later version.
;; 
;;     Megatest is distributed in the hope that it will be useful,
;;     but WITHOUT ANY WARRANTY; without even the implied warranty of
;;     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;     GNU General Public License for more details.
;; 
;;     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 (not (directory? path))
	(begin
	  (print "The path " path " does not exist or is not a directory. Attempting to create it now")
	  (create-directory path #t)))

    ;; First check that the directory is empty!
    (if (and (common:file-exists? path)
	     (not (null? (glob (conc path "/*")))))
	(begin
	  (print "WARNING: directory " path " is not empty, are you sure you want to continue?")
	  (display "Enter y/n: ")
	  (if (equal? "y" (read-line))
	      (print "Using directory " path " for your Megatest area.")
	      (begin

	(print "[fields]")
	(map (lambda (k)(print k " TEXT")) keys)
	(print "")
	(print "[setup]")
	(print "# Adjust max_concurrent_jobs to limit how much you load your machines")
	(print "max_concurrent_jobs 50\n")
	(print "# This is your link path. Avoid moving it once set.")
	(print "linktree " lntree) ;; (common:real-path lntree))
	(print "\n# Job tools are more advanced ways to control how your jobs are launched")
	(print "[jobtools]\nuseshell yes\nlauncher nbfake\nmaxload 1.5\n")
	(print "# You can override environment variables for all your tests here")
	(print "[env-override]\nEXAMPLE_VAR example value\n")
	(print "# As you run more tests you may need to add additional disks, the names are arbitrary but must be unique")
	(print "[disks]\ndisk0 " firstd))) ;; (common:real-path firstd))))
    
    (print
     "==================

I'm now creating a runconfigs.config file for you with a default section.
You can use this file to set variables for your tests based on the \"target\" (the combination
of keys).

	(print "# Override settings in ../runconfigs.config for user " (current-user-name) " here.")))
    
    ;; Now create a test and logpro file
    (print
     "==================

You now have the basic common files for your megatest setup. Next run
\"megatest -create-test <testname>\" to create a test.

Thank you for using Megatest. 

You can edit your config files and create tests in the " path " directory

")))

	(description #f)
	(steps    '())
	(scripts  '())
	(items    '())
	(rel-path #f))

    (cond
     ((common:file-exists? "megatest.config")         (set! rel-path "./"))
     ((common:file-exists? "../megatest.config")      (set! rel-path "../"))
     ((common:file-exists? "../../megatest.config")   (set! rel-path "../../"))
     ((common:file-exists? "../../../megatest.config")(set! rel-path "../../../"))) ;; good enough dang it.

    ;; Don't gather data or continue if a) megatest.config can't be found or b) testconfig already exists
    (if (not rel-path)
	(begin
	  (print "ERROR: I could not find megatest.config, please run -create-test in the top dir of your megatest area")
	  (exit 1)))

    (if (common:file-exists? (conc rel-path "tests/" testname "/testconfig"))
	(begin
	  (print "WARNING: You already have a testconfig in " rel-path "tests/" testname ", do you want to clobber your files?")
	  (display "Enter y/n: ")
	  (if (not (equal? "y" (read-line)))
	      (begin
		(print "INFO: user abort of creation of test " testname)
		(exit 1)))))

			(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"))
	 )
    (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
    (system (conc "megatest -show-config > " dest-path "/megatest.config"))
    (system (conc "megatest -show-runconfig > " dest-path "/runconfigs.config"))

    ;; create a refdb, some stuff has to be done due to refdb not initing area
    ;;   sheet   row       col      value
    ;;   test    itempath  stepname steptime
    (if (not (file-exists? (conc dest-path "/stepsinfo")))
	(begin
	  (create-directory (conc dest-path "/stepsinfo/sxml") #t)
	  (with-output-to-file (conc dest-path "/stepsinfo/sheet-names.cfg") (lambda ()(print)))))

    ;; rmt:get-tests-for-run
    ;; rmt:get-tests-for-run-mindata run-id testpatt states status not-in
    ;; rmt:simple-get-runs
    ;; (define-record simple-run target id runname state status owner event_time)
    (let* ((runs   (rmt:simple-get-runs (or runname "%") #f #f (or target "%")))
	   (tests  (make-hash-table))
	   (refdb  (conc dest-path "/stepsinfo")))
      (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-mindata run-id "%" '() '() #f)))
	   (for-each
	    (lambda (testdat)
	      (let* ((test-id      (db:mintest-get-id testdat))
		     (testname     (db:mintest-get-testname testdat))
		     (item-path    (db:mintest-get-item_path testdat))
		     ;; now get steps info
		     (test-steps   (tests:get-compressed-steps run-id test-id)))
		(if (not (hash-table-exists? tests testname))
		    (begin
		      (print "\n" testname)
		      (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 " refdb " " testname " '" (if (equal? item-path "")
										  "no-item-path"
										  item-path)
					 "' " step-name " " step-duration))
			   ))
		       test-steps))
		    (else (debug:print-info 0 *default-log-port* "Skipping already seen test " testname)))))
	    tests-data)))
       (map (lambda (runrec)(simple-run-id runrec)) runs)))
    ))