Megatest

# $(glob *.scm) did not work as I expected it to!?

PREFIX=.

FILES=$(shell ls *.scm)
HELPERS=$(addprefix $(PREFIX)/bin/,mt_laststep mt_runstep)

megatest: $(FILES)
	csc megatest.scm 

dashboard: $(FILES)
	csc dashboard.scm

$(PREFIX)/bin/megatest : megatest
	@echo Installing to PREFIX=$(PREFIX), use ^C to cancel and change
	sleep 5
	sleep 2 
	cp megatest $(PREFIX)/bin/megatest

	cp utils/mt_* $(PREFIX)/bin
	chmod a+x $(PREFIX)/bin/mt_*
$(HELPERS)  : utils/mt_*
	cp $< $@
	chmod a+x $@

# install dashboard as dboard so wrapper script can be called dashboard
$(PREFIX)/bin/dboard : dashboard $(FILES)
	cp dashboard $(PREFIX)/bin/dboard
	utils/mk_dashboard_wrapper $(PREFIX) > $(PREFIX)/bin/dashboard
	chmod a+x $(PREFIX)/bin/dashboard

install : $(PREFIX)/bin/megatest $(PREFIX)/bin/dboard
install : $(PREFIX)/bin/megatest $(PREFIX)/bin/dboard $(PREFIX)/bin/dashboard $(HELPERS)

test: tests/tests.scm
	cd tests;csi -I .. -b -n tests.scm

					(set! newcomment b))
			     #:value (db:test-get-comment testdat)
			     #:expand "YES"))
      (apply iup:hbox
	     (iup:label "STATE:" #:size "30x")
	     (let* ((btns  (map (lambda (state)
				  (let ((btn (iup:button state
							 #:expand "YES" #:size "70x"
							 #:expand "YES" #:size "50x" #:font "Courier New, -10"
							 #:action (lambda (x)
								    (db:test-set-state-status-by-id *db* test-id state #f #f)
								    (db:test-set-state! testdat state)))))
				    btn))
				(list "COMPLETED" "NOT_STARTED" "RUNNING" "REMOTEHOSTSTART" "KILLED" "KILLREQ"))))
	       (vector-set! *state-status* 0
			    (lambda (state color)
			      (for-each 
			       (lambda (btn)
				 (let* ((name     (iup:attribute btn "TITLE"))
					(newcolor (if (equal? name state) color "192 192 192")))
				   (if (not (colors-similar? newcolor (iup:attribute btn "BGCOLOR")))
				       (iup:attribute-set! btn "BGCOLOR" newcolor))))
			       btns)))
	       btns))
      (apply iup:hbox
	     (iup:label "STATUS:" #:size "30x")
	     (let* ((btns  (map (lambda (status)
				  (let ((btn (iup:button status
							 #:expand "YES" #:size "70x"
							 #:expand "YES" #:size "50x" #:font "Courier New, -10"
							 #:action (lambda (x)
								    (db:test-set-state-status-by-id *db* test-id #f status #f)
								    (db:test-set-status! testdat status)))))
				    btn))
				(list  "PASS" "WARN" "FAIL" "CHECK" "n/a" "WAIVED"))))
	       (vector-set! *state-status* 1
			    (lambda (status color)

		(test-info-panel testdat store-label widgets)
		(test-meta-panel testmeta store-meta))
	       (host-info-panel testdat store-label)
	       ;; The controls
	       (iup:frame #:title "Actions" 
			  (iup:vbox
			   (iup:hbox 
			    (iup:button "View Log"    #:action viewlog     #:size "120x")
			    (iup:button "Start Xterm" #:action xterm       #:size "120x")
			    (iup:button "Run Test"    #:action run-test    #:size "120x")
			    (iup:button "Clean Test"  #:action remove-test #:size "120x")
			    (iup:button "Close"       #:action (lambda (x)(exit)) #:size "120x"))
			    (iup:button "View Log"    #:action viewlog     #:size "80x")
			    (iup:button "Start Xterm" #:action xterm       #:size "80x")
			    (iup:button "Run Test"    #:action run-test    #:size "80x")
			    (iup:button "Clean Test"  #:action remove-test #:size "80x")
			    (iup:button "Close"       #:action (lambda (x)(exit)) #:size "80x"))
			   (apply 
			    iup:hbox
			    (list command-text-box command-launch-button))))
	       (set-fields-panel test-id testdat)
	       (iup:hbox
		(iup:frame 
		 #:title "Test Steps"
		 (let ((stepsdat ;;(iup:label "Test steps ........................................." 
			;;	   #:expand "YES" 
			;;	   #:size "200x150"
			;;	   #:alignment "ALEFT:ATOP")))
			(iup:textbox ;; #:action (lambda (obj char val)
				     ;;    	#f)
				     #:expand "YES"
				     #:multiline "YES"
				     #:font "Courier New, -10"
				     #:size "100x150")))
				     #:size "60x100")))
		   (hash-table-set! widgets "Test Steps" 
				    (lambda (testdat)
				      (let* ((currval (iup:attribute stepsdat "VALUE")) ;; "TITLE"))
					     (fmtstr  "~20a~10a~10a~12a~15a")
					     (comprsteps (db:get-steps-table db test-id))
					     (newval  (string-intersperse 
						       (append

		 #:title "Test Data"
		 (let ((test-data
			(iup:textbox  ;; #:action (lambda (obj char val)
				      ;;   	#f)
				      #:expand "YES"
				      #:multiline "YES"
				      #:font "Courier New, -10"
				      #:size "100x150")))
				      #:size "100x100")))
		   (hash-table-set! widgets "Test Data"
				    (lambda (testdat) ;; 
				      (let* ((currval (iup:attribute test-data "VALUE")) ;; "TITLE"))
					     (fmtstr  "~10a~10a~10a~10a~7a~7a~6a~a") ;; category,variable,value,expected,tol,units,comment
					     (newval  (string-intersperse 
						       (append
							(list 

(define-inline (db:test-get-first_err    vec) (printable (vector-ref vec 15))) ;; 19)))
(define-inline (db:test-get-first_warn   vec) (printable (vector-ref vec 16))) ;; 20)))

(define-inline (db:test-set-testname! vec val)(vector-set! vec 2 val))
(define-inline (db:test-set-state!    vec val)(vector-set! vec 3 val))
(define-inline (db:test-set-status!   vec val)(vector-set! vec 4 val))

(define (db-get-tests-for-run db run-id . params)
  (let ((res '())
(define (db-get-tests-for-run db run-id testpatt itempatt)
  (let ((res '()))
	(testpatt (if (or (null? params)(not (car params))) "%" (car params)))
	(itempatt (if (> (length params) 1)(cadr params) "%")))
    (sqlite3:for-each-row 
     (lambda (id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment first-err first-warn)
       (set! res (cons (vector id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment first-err first-warn) res)))
     db 
     "SELECT id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment,first_err,first_warn FROM tests WHERE run_id=? AND testname like ? AND item_path LIKE ? ORDER BY id DESC;"
     run-id
     (if testpatt testpatt "%")
     run-id testpatt (if itempatt itempatt "%"))
     (if itempatt itempatt "%"))
    res))

;; this one is a bit broken BUG FIXME
(define (db:delete-test-step-records db run-id test-name itemdat)
  (sqlite3:execute db "DELETE FROM test_steps WHERE test_id in (SELECT id FROM tests WHERE run_id=? AND testname=? AND item_path=?);" 
		   run-id test-name (item-list->path itemdat)))
;; 

	      (comment     (list-ref padded-row 6))
	      (status      (let ((s (list-ref padded-row 7)))
			     (if (and (string? s)(or (string-match (regexp "^\\s*$") s)
						     (string-match (regexp "^n/a$") s)))
				 #f
				 s)))) ;; if specified on the input then use, else calculate
	 ;; look up expected,tol,units from previous best fit test if they are all either #f or ''
	 (debug:print 4 "category: " category ", variable: " variable ", value: " value 
		      ", expected: " expected ", tol: " tol ", units: " units ", status: " status ", comment: " comment)
	 (debug:print 4 "BEFORE: category: " category " variable: " variable " value: " value 
		      ", expected: " expected " tol: " tol " units: " units " status: " status " comment: " comment)

	 (if (and (or (not expected)(equal? expected ""))
		  (or (not tol)     (equal? expected ""))
		  (or (not units)   (equal? expected "")))
	     (let-values (((new-expected new-tol new-units)(db:get-prev-tol-for-test db test-id category variable)))
	       (set! expected new-expected)
	       (set! tol      new-tol)
	       (set! units    new-units)))

	 (debug:print 4 "AFTER:  category: " category " variable: " variable " value: " value 
		      ", expected: " expected " tol: " tol " units: " units " status: " status " comment: " comment)
	 ;; calculate status if NOT specified
	 (if (and (not status)(number? expected)(number? value)) ;; need expected and value to be numbers
	     (if (number? tol) ;; if tol is a number then we do the standard comparison
		 (let ((max-val (+ expected tol))
		       (min-val (- expected tol)))
		   (set! status (if (and (>=  value min-val)(<= value max-val)) "pass" "fail")))
		 (let* ((max-val (+ expected tol))
			(min-val (- expected tol))
			(result  (and (>=  value min-val)(<= value max-val))))
		   (debug:print 4 "max-val: " max-val " min-val: " min-val " result: " result)
		   (set! status (if result "pass" "fail")))
		 (set! status ;; NB// need to assess each one (i.e. not return operator since need to act if not valid op.
		       (case (string->symbol tol) ;; tol should be >, <, >=, <=
			 ((>)  (if (>  value expected) "pass" "fail"))
			 ((<)  (if (<  value expected) "pass" "fail"))
			 ((>=) (if (>= value expected) "pass" "fail"))
			 ((<=) (if (<= value expected) "pass" "fail"))
			 (else (conc "ERROR: bad tol comparator " tol))))))
	 (debug:print 4 "AFTER2: category: " category " variable: " variable " value: " value 
		      ", expected: " expected " tol: " tol " units: " units " status: " status " comment: " comment)
	 (sqlite3:execute db "INSERT OR REPLACE INTO test_data (test_id,category,variable,value,expected,tol,units,comment,status) VALUES (?,?,?,?,?,?,?,?,?);"
	      test-id category variable value expected tol units (if comment comment "") status)))
     csvlist)))

;; get a list of test_data records matching categorypatt
(define (db:read-test-data db test-id categorypatt)
  (let ((res '()))

;;
;; Return a list of prereqs that were NOT met
;;  Tests (and all items) in waiton list must be "COMPLETED" and "PASS"
(define (db-get-prereqs-not-met db run-id waiton)
  (if (null? waiton)
      '()
      (let* ((unmet-pre-reqs '())
	     (tests           (db-get-tests-for-run db run-id))
	     (tests           (db-get-tests-for-run db run-id #f #f))
	     (result         '()))
	(for-each (lambda (waitontest-name)
		    (let ((ever-seen #f))
		      (for-each (lambda (test)
				  (if (equal? waitontest-name (db:test-get-testname test))
				      (begin
					(set! ever-seen #t)

	    (debug:print 2 "Exectuing " test-name " on " (get-host-name))
	    (change-directory testpath)
	    (setenv "MT_TEST_RUN_DIR" work-area)
	    (setenv "MT_TEST_NAME" test-name)
	    (setenv "MT_ITEM_INFO" (conc itemdat))
	    (setenv "MT_RUNNAME"   runname)
	    (setenv "MT_MEGATEST"  megatest)
	    (setenv "PATH" (conc (getenv "PATH") ":" mt-bindir-path))
	    (if mt-bindir-path (setenv "PATH" (conc (getenv "PATH") ":" mt-bindir-path)))
	    
	    (if (not (setup-for-run))
		(begin
		  (debug:print 0 "Failed to setup, exiting") 
		  (exit 1)))
	    ;; now can find our db
	    (set! db (open-db))

	      (let loop ((hed (car prev-run-ids))
			 (tal (cdr prev-run-ids)))
		(let ((results (db-get-tests-for-run db hed test-name item-path)))
		  (debug:print 4 "Got tests for run-id " run-id ", test-name " test-name ", item-path " item-path ": " results)
		  (if (and (null? results)
			   (not (null? tal)))
		      (loop (car tal)(cdr tal))
		      (if (null? results) #f
		      (car results)))))))))
			  (car results))))))))))
    
;; get the previous records for when these tests were run where all keys match but runname
;; NB// Merge this with test:get-previous-test-run-records? This one looks for all matching tests
;; can use wildcards. 
(define (test:get-matching-previous-test-run-records db run-id test-name item-path)
  (let* ((keys    (db:get-keys db))
	 (selstr  (string-intersperse (map (lambda (x)(vector-ref x 0)) keys) ","))

#!/bin/bash

prefix=$1
echo "#!/bin/bash"
if [ $LD_LIBRARY_PATH != "" ];then
  echo "export LD_LIBRARY_PATH=$LD_LIBRARY_PATH"
fi

dboard=`realpath $prefix/bin/dboard`

echo "$dboard \$*"

#!/bin/bash

if [ $MT_CMDINFO == "" ];then
  echo "ERROR: $0 should be run within a megatest test environment"
  exit
fi

# Purpose: run a step, record start and end with exit codes, if sucessful
# update test status with PASS, else update with FAIL
#
# Call like this:
# mt_laststep stepname command ....
#