Index: dashboard.scm ================================================================== --- dashboard.scm +++ dashboard.scm @@ -12,10 +12,11 @@ (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) @@ -509,33 +510,72 @@ (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)) - (tests (make-hash-table)) + (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)))) + ;; (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:vbox + (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))))))) + 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 ... Index: docs/manual/megatest_manual.txt ================================================================== --- docs/manual/megatest_manual.txt +++ docs/manual/megatest_manual.txt @@ -3,27 +3,10 @@ Matt Welland v1.0, April 2012 :doctype: book -[dedication] -Dedication -========== - -Dedicated to my wife Joanna who has kindly supported my working on various projects over the years. - -Thanks ------- - -Thank you the many people I've worked over the years who have -shared their knowledge and insights with me. - -Thanks also to the creators of the various open source projects that -Megatest is built on. These include Linux, xemacs, chicken scheme, -fossil and asciidoc. Without these projects something like Megatest -would be difficult or impossible to do. - [preface] Preface ======= This book is organised as three sub-books; getting started, writing tests and reference. Index: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -977,11 +977,11 @@ (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 (get-all-legal-tests))) + (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))) Index: tests.scm ================================================================== --- tests.scm +++ tests.scm @@ -26,20 +26,10 @@ (include "key_records.scm") (include "db_records.scm") (include "run_records.scm") (include "test_records.scm") -(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))))) - ;; 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)) @@ -429,19 +419,23 @@ (change-directory orig-dir) ;; NB// tests:test-set-toplog! is remote internal... (tests:test-set-toplog! db run-id test-name outputfilename) ))))) -(define (get-all-legal-tests) - (let* ((tests (glob (conc *toppath* "/tests/*"))) - (res '())) - (debug:print-info 4 "Looking at tests " (string-intersperse tests ",")) - (for-each (lambda (testpath) - (if (file-exists? (conc testpath "/testconfig")) - (set! res (cons (last (string-split testpath "/")) res)))) - tests) - res)) +;;====================================================================== +;; 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)))) @@ -530,10 +524,90 @@ (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 ;;======================================================================