Megatest

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

(use format)
(require-library iup)
(import (prefix iup iup:))

(use canvas-draw)
(import canvas-draw-iup)

(use sqlite3 srfi-1 posix regex regex-case srfi-69)
(import (prefix sqlite3 sqlite3:))
(use trace)

(declare (uses common))
(declare (uses margs))

			 listboxes)))
	    (loop (car remkeys)
		  (cdr remkeys)
		  (append refvals (list selected-value))
		  (+ indx 1)
		  (append lbs (list lb))))))))

;(define (dashboard:display-tests cnv x y)

(define (dashboard:run-controls)
  (let* ((targets       (make-hash-table))
	 (runconf-targs (common:get-runconfig-targets))
	 (test-records  (make-hash-table))
	 (test-names    (tests:get-valid-tests *toppath* '()))
	 (sorted-testnames #f)
	 (action        "-runtests")
	 (cmdln         "")
	 (runlogs       (make-hash-table))
	 (key-listboxes #f)
	 (update-keyvals (lambda (obj b c d)
			   ;; (print "obj: " obj ", b " b ", c " c ", d " d)
			   (dashboard:update-target-selector key-listboxes)))
	 (test-browse-xoffset 0)
	 (test-browse-yoffset 0)
	 (first-time    #t))
    (tests:get-full-data test-names test-records '())
    (set! sorted-testnames (tests:sort-by-priority-and-waiton test-records))
    
    ;; refer to *keys*, *dbkeys* for keys
    (iup:vbox
     (iup:hbox
       ;; Target and action
      (iup:frame
       #:title "Target"
      (iup:vbox
        ;; Target selectors
        (apply iup:hbox
	       (let* ((dat      (dashboard:update-target-selector key-listboxes action-proc: update-keyvals))
		      (key-lb   (car dat))
		      (combos   (cadr dat)))
		 (set! key-listboxes key-lb)
		 combos))))
      (iup:frame
       #:title "Tests and Tasks"
       (iup:vbox
	(iup:canvas #:action (make-canvas-action
			      (lambda (cnv xadj yadj)
				;; (print "cnv: " cnv " x: " x " y: " y)
				(canvas-clear! cnv)
				(canvas-font-set! cnv "Courier New, -8")
				(let-values (((sizex   sizey sizexmm sizeymm) (canvas-size cnv)))
	                           (if first-time
				       (begin
					 (set! first-time #f)
					 (set! test-browse-xoffset (- 20 (* (/ sizex 2) (* 8 xadj))))
					 (set! test-browse-yoffset (- 20 (* (/ sizey 2) (* 8 (- 1 yadj)))))))
			           (let* ((xtorig (+ test-browse-xoffset (* (/ sizex 2) (* 8 xadj)))) ;;  (- xadj 1))))
					  (ytorig (+ test-browse-yoffset (* (/ sizey 2) (* 8 (- 1 yadj))))))
				     (print "sizex: " sizex " sizey: " sizey " font: " (canvas-font cnv))
				     (for-each (lambda (testname)
						 (canvas-text! cnv (+ xtorig 5)(+ ytorig 5) testname) ;; (conc testname " (" xtorig "," ytorig ")"))
						 (canvas-rectangle! cnv xtorig (+ 60 xtorig) ytorig (+ ytorig 30))
						 (set! ytorig (+ ytorig 50)))
					       (reverse sorted-testnames))))))
		    #:size "150x200"
		    #:scrollbar "YES"
		    #:posx "0.5"
		    #:posy "0.5")))))))


(trace dashboard:populate-target-dropdown
       common:list-is-sublist)

;;       ;; key1 key2 key3 ...
;;       ;; target entry (wild cards allowed)
;;       

The Megatest Users Manual
=========================
Matt Welland <matt@kiatoa.com>
v1.0, April 2012
:doctype: book



















[preface]
Preface
=======
This book is organised as three sub-books; getting started, writing tests and reference.

Why Megatest?
~~~~~~~~~~~~~

	     (begin
	       (print "Updating " test-name " " fld " to " val)
	       (open-run-close db:testmeta-update-field db test-name fld val)))))
     '(("author" 2)("owner" 3)("description" 4)("reviewed" 5)("tags" 9)))))

;; Update test_meta for all tests
(define (runs:update-all-test_meta db)
  (let ((test-names (tests:get-valid-tests)))
    (for-each 
     (lambda (test-name)
       (let* ((test-path    (conc *toppath* "/tests/" test-name))
	      (test-configf (conc test-path "/testconfig"))
	      (testexists   (and (file-exists? test-configf)(file-read-access? test-configf)))
	      ;; read configs with tricks turned off (i.e. no system)
	      (test-conf    (if testexists (read-config test-configf #f #f)(make-hash-table))))

(include "common_records.scm")
(include "key_records.scm")
(include "db_records.scm")
(include "run_records.scm")
(include "test_records.scm")











;; tests:glob-like-match
(define (tests:glob-like-match patt str) 
  (let ((like (substring-index "%" patt)))
    (let* ((notpatt  (equal? (substring-index "~" patt) 0))
	   (newpatt  (if notpatt (substring patt 1) patt))
	   (finpatt  (if like
			(string-substitute (regexp "%") ".*" newpatt)

		(release-dot-lock outputfilename)))
	    (close-output-port oup)
	    (change-directory orig-dir)
	    ;; NB// tests:test-set-toplog! is remote internal...
	    (tests:test-set-toplog! db run-id test-name outputfilename)
	    )))))

;;======================================================================
;; Gather data from test/task specifications
;;======================================================================

(define (tests:get-valid-tests testsdir test-patts) ;;  #!key (test-names '()))
  (let ((tests (glob (conc testsdir "/tests/*")))) ;; " (string-translate patt "%" "*")))))
    (set! tests (filter (lambda (test)(file-exists? (conc test "/testconfig"))) tests))
    (delete-duplicates
     (filter (lambda (testname)

	       (tests:match test-patts testname #f))
	     (map (lambda (testp)

		    (last (string-split testp "/")))
		  tests)))))


(define (tests:get-testconfig test-name system-allowed)
  (let* ((test-path    (conc *toppath* "/tests/" test-name))
	 (test-configf (conc test-path "/testconfig"))
	 (testexists   (and (file-exists? test-configf)(file-read-access? test-configf))))
    (if testexists
	(read-config test-configf #f system-allowed environ-patt: (if system-allowed

					 (member (db:test-get-state wtdat)
						 '("INCOMPETE")))
				     (set! keep-test #f)))) ;; no point in running this one again
			     waitons))))
	 (if keep-test (set! runnables (cons testkeyname runnables)))))
     testkeynames)
    runnables))

;;======================================================================
;; refactoring this block into tests:get-full-data from line 263 of runs.scm
;;======================================================================
;; hed is the test name
;; test-records is a hash of test-name => test record
(define (tests:get-full-data test-names test-records required-tests)
  (if (not (null? test-names))
      (let loop ((hed (car test-names))
		 (tal (cdr test-names)))         ;; 'return-procs tells the config reader to prep running system but return a proc
	(debug:print-info 4 "hed=" hed " at top of loop")
	(let* ((config  (tests:get-testconfig hed 'return-procs))
	       (waitons (let ((instr (if config 
					 (config-lookup config "requirements" "waiton")
					 (begin ;; No config means this is a non-existant test
					   (debug:print 0 "ERROR: non-existent required test \"" hed "\"")
					   (if db (sqlite3:finalize! db))
					   (exit 1)))))
			  (debug:print-info 8 "waitons string is " instr)
			  (string-split (cond
					 ((procedure? instr)
					  (let ((res (instr)))
					    (debug:print-info 8 "waiton procedure results in string " res " for test " hed)
					    res))
					 ((string? instr)     instr)
					 (else 
					  ;; NOTE: This is actually the case of *no* waitons! ;; (debug:print 0 "ERROR: something went wrong in processing waitons for test " hed)
					  ""))))))
	  (debug:print-info 8 "waitons: " waitons)
	  ;; check for hed in waitons => this would be circular, remove it and issue an
	  ;; error
	  (if (member hed waitons)
	      (begin
		(debug:print 0 "ERROR: test " hed " has listed itself as a waiton, please correct this!")
		(set! waitons (filter (lambda (x)(not (equal? x hed))) waitons))))
	  
	  ;; (items   (items:get-items-from-config config)))
	  (if (not (hash-table-ref/default test-records hed #f))
	      (hash-table-set! test-records
			       hed (vector hed     ;; 0
					   config  ;; 1
					   waitons ;; 2
					   (config-lookup config "requirements" "priority")     ;; priority 3
					   (let ((items      (hash-table-ref/default config "items" #f)) ;; items 4
						 (itemstable (hash-table-ref/default config "itemstable" #f))) 
					     ;; if either items or items table is a proc return it so test running
					     ;; process can know to call items:get-items-from-config
					     ;; if either is a list and none is a proc go ahead and call get-items
					     ;; otherwise return #f - this is not an iterated test
					     (cond
					      ((procedure? items)      
					       (debug:print-info 4 "items is a procedure, will calc later")
					       items)            ;; calc later
					      ((procedure? itemstable)
					       (debug:print-info 4 "itemstable is a procedure, will calc later")
					       itemstable)       ;; calc later
					      ((filter (lambda (x)
							 (let ((val (car x)))
							   (if (procedure? val) val #f)))
						       (append (if (list? items) items '())
							       (if (list? itemstable) itemstable '())))
					       'have-procedure)
					      ((or (list? items)(list? itemstable)) ;; calc now
					       (debug:print-info 4 "items and itemstable are lists, calc now\n"
								 "    items: " items " itemstable: " itemstable)
					       (items:get-items-from-config config))
					      (else #f)))                           ;; not iterated
					   #f      ;; itemsdat 5
					   #f      ;; spare - used for item-path
					   )))
	  (for-each 
	   (lambda (waiton)
	     (if (and waiton (not (member waiton test-names)))
		 (begin
		   (set! required-tests (cons waiton required-tests))
		   (set! test-names (cons waiton test-names))))) ;; was an append, now a cons
	   waitons)
	  (let ((remtests (delete-duplicates (append waitons tal))))
	    (if (not (null? remtests))
		(loop (car remtests)(cdr remtests))))))))

;;======================================================================
;; test steps
;;======================================================================

;; teststep-set-status! used to be here