Changes In Branch runcontrol Through [efa1af53d5] Excluding Merge-Ins
This is equivalent to a diff from d187e07c8b to efa1af53d5
2013-04-22
| ||
16:38 | Fixed issue with server record not reflecting actual server when have port collisions. check-in: 99ca17a0cc user: mrwellan tags: development, v1.5415 | |
01:25 | Draw test/task boxes in rows to keep compact interface check-in: df77e9f1bd user: matt tags: runcontrol | |
00:59 | Display of tests on canvas partially implemented check-in: efa1af53d5 user: matt tags: runcontrol | |
2013-04-21
| ||
01:24 | Target selector done check-in: 5a56443663 user: matt tags: runcontrol | |
2013-04-19
| ||
00:33 | Starting on dashboard run control panel check-in: b504d0edc5 user: matt tags: runcontrol | |
2013-04-17
| ||
15:28 | Converted test steps to matrix, added browsing of log check-in: d187e07c8b user: mrwellan tags: development, v1.5414 | |
08:51 | bumped version check-in: f8584f2d62 user: icfadm tags: development, v1.5413 | |
Modified common.scm from [3109b21887] to [7f9cf64fe3].
︙ | ︙ | |||
140 141 142 143 144 145 146 147 148 149 150 151 152 153 | #f #t))) string<?)) ;; '(print (string-intersperse (map cadr (hash-table-ref/default (read-config "megatest.config" \#f \#t) "disks" '"'"'("none" ""))) "\n"))' (define (common:get-disks) (hash-table-ref/default (read-config "megatest.config" #f #t) "disks" '("none" ""))) ;;====================================================================== ;; System stuff ;;====================================================================== ;; return a nice clean pathname made absolute (define (nice-path dir) | > > > > > > > > > > > > > > > > > > > > > > > > > > | 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 | #f #t))) string<?)) ;; '(print (string-intersperse (map cadr (hash-table-ref/default (read-config "megatest.config" \#f \#t) "disks" '"'"'("none" ""))) "\n"))' (define (common:get-disks) (hash-table-ref/default (read-config "megatest.config" #f #t) "disks" '("none" ""))) ;;====================================================================== ;; M I S C L I S T S ;;====================================================================== ;; items in lista are matched value and position in listb ;; return the remaining items in listb or #f ;; (define (common:list-is-sublist lista listb) (if (null? lista) listb ;; all items in listb are "remaining" (if (> (length lista)(length listb)) #f (let loop ((heda (car lista)) (tala (cdr lista)) (hedb (car listb)) (talb (cdr listb))) (if (equal? heda hedb) (if (null? tala) ;; we are done talb (loop (car tala) (cdr tala) (car talb) (cdr talb))) #f))))) ;;====================================================================== ;; System stuff ;;====================================================================== ;; return a nice clean pathname made absolute (define (nice-path dir) |
︙ | ︙ |
Modified dashboard-tests.scm from [b247a10977] to [3e5475f076].
︙ | ︙ | |||
473 474 475 476 477 478 479 | (db:test-data-get-units x) (db:test-data-get-type x) (db:test-data-get-comment x))) (open-run-close db:read-test-data #f test-id "%"))) "\n"))) (if (not (equal? currval newval)) (iup:attribute-set! test-data "VALUE" newval ))))) ;; "TITLE" newval))))) | | > > | 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 | (db:test-data-get-units x) (db:test-data-get-type x) (db:test-data-get-comment x))) (open-run-close db:read-test-data #f test-id "%"))) "\n"))) (if (not (equal? currval newval)) (iup:attribute-set! test-data "VALUE" newval ))))) ;; "TITLE" newval))))) test-data)) ;;(dashboard:run-controls) ))) (iup:attribute-set! tabs "TABTITLE0" "Steps") (iup:attribute-set! tabs "TABTITLE1" "Test Data") tabs)))) (iup:show self) (iup:callback-set! *tim* "ACTION_CB" (lambda (x) ;; Now start keeping the gui updated from the db |
︙ | ︙ |
Modified dashboard.scm from [f8c5b58774] to [3061b16302].
︙ | ︙ | |||
10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 | ;;====================================================================== (use format) (require-library iup) (import (prefix iup iup:)) (use canvas-draw) (use sqlite3 srfi-1 posix regex regex-case srfi-69) (import (prefix sqlite3 sqlite3:)) (declare (uses common)) (declare (uses margs)) (declare (uses keys)) (declare (uses items)) (declare (uses db)) (declare (uses configf)) | > > | 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 | ;;====================================================================== (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)) (declare (uses keys)) (declare (uses items)) (declare (uses db)) (declare (uses configf)) |
︙ | ︙ | |||
420 421 422 423 424 425 426 | (define (update-search x val) ;; (print "Setting search for " x " to " val) (hash-table-set! *searchpatts* x val)) (define (mark-for-update) (set! *last-db-update-time* 0) | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 | (define (update-search x val) ;; (print "Setting search for " x " to " val) (hash-table-set! *searchpatts* x val)) (define (mark-for-update) (set! *last-db-update-time* 0) (set! *delayed-update* 1)) ;;====================================================================== ;; R U N C O N T R O L ;;====================================================================== ;; target populating logic ;; ;; lb = <vector curr-label-object next-label-object> ;; field = target field name for this dropdown ;; referent-vals = selected value in the left dropdown ;; targets = list of targets to use to build the dropdown ;; ;; each node is chained: key1 -> key2 -> key3 ;; ;; must select values from only apropriate targets ;; a b c ;; a d e ;; a b f ;; a/b => c f ;; (define (dashboard:populate-target-dropdown lb referent-vals targets) ;; is the current value in the new list? choose new default if not (let* ((remvalues (map (lambda (row) (common:list-is-sublist referent-vals (vector->list row))) targets)) (values (delete-duplicates (map car (filter list? remvalues)))) (sel-valnum (iup:attribute lb "VALUE")) (sel-val (iup:attribute lb sel-valnum)) (val-num 1)) ;; first check if the current value is in the new list, otherwise replace with ;; first value from values (iup:attribute-set! lb "REMOVEITEM" "ALL") (for-each (lambda (val) ;; (iup:attribute-set! lb "APPENDITEM" val) (iup:attribute-set! lb (conc val-num) val) (if (equal? sel-val val) (iup:attribute-set! lb "VALUE" val-num)) (set! val-num (+ val-num 1))) values) (let ((val (iup:attribute lb "VALUE"))) (if val val (let ((newval (car values))) (iup:attribute-set! lb "VALUE" newval) newval))))) (define (dashboard:update-target-selector key-lbs #!key (action-proc #f)) (let* ((db-target-dat (open-run-close db:get-targets #f)) (header (vector-ref db-target-dat 0)) (db-targets (vector-ref db-target-dat 1)) (key-listboxes (if key-lbs key-lbs (make-list (length header) #f)))) (let loop ((key (car header)) (remkeys (cdr header)) (refvals '()) (indx 0) (lbs '())) (let* ((lb (let ((lb (list-ref key-listboxes indx))) (if lb lb (iup:listbox #:size "x15" #:fontsize "10" #:expand "YES" ;; #:dropdown "YES" #:editbox "YES" #:action action-proc )))) ;; loop though all the targets and build the list for this dropdown (selected-value (dashboard:populate-target-dropdown lb refvals db-targets))) (if (null? remkeys) ;; return a list of the listbox items and an iup:hbox with the labels and listboxes (let ((listboxes (append lbs (list lb)))) (list listboxes (map (lambda (htxt lb) (iup:vbox (iup:label htxt) lb)) header 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 action ;; (iup:hbox ;; ;; label Action | action selector ;; )) ;; ;; Test/items selector ;; (iup:hbox ;; ;; tests ;; ;; items ;; )) ;; ;; The command line ;; (iup:hbox ;; ;; commandline entry ;; ;; GO button ;; ) ;; ;; The command log monitor ;; (iup:tabs ;; ;; log monitor ;; ))) ;;====================================================================== ;; R U N S ;;====================================================================== (define (make-dashboard-buttons nruns ntests keynames) (let* ((nkeys (length keynames)) (runsvec (make-vector nruns)) (header (make-vector nruns)) (lftcol (make-vector ntests)) (keycol (make-vector ntests)) |
︙ | ︙ | |||
600 601 602 603 604 605 606 | (hash-table-set! *buttondat* button-key (vector 0 "100 100 100" button-key #f #f)) (vector-set! testvec testnum butn) (loop runnum (+ testnum 1) testvec (cons butn res)))))) ;; now assemble the hdrlst and bdylst and kick off the dialog (iup:show (iup:dialog #:title "Megatest dashboard" | > | | | | | | | | | > > > > > | | 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 | (hash-table-set! *buttondat* button-key (vector 0 "100 100 100" button-key #f #f)) (vector-set! testvec testnum butn) (loop runnum (+ testnum 1) testvec (cons butn res)))))) ;; now assemble the hdrlst and bdylst and kick off the dialog (iup:show (iup:dialog #:title "Megatest dashboard" (let ((tabs (iup:tabs (iup:vbox (apply iup:hbox (cons (apply iup:vbox lftlst) (list (iup:vbox ;; the header (apply iup:hbox (reverse hdrlst)) (apply iup:hbox (reverse bdylst)))))) controls) (dashboard:run-controls) ))) (iup:attribute-set! tabs "TABTITLE0" "Runs") (iup:attribute-set! tabs "TABTITLE1" "Run Control") tabs))) (vector keycol lftcol header runsvec))) (if (or (args:get-arg "-rows") (get-environment-variable "DASHBOARDROWS" )) (begin (set! *num-tests* (string->number (or (args:get-arg "-rows") (get-environment-variable "DASHBOARDROWS")))) (update-rundat "%" *num-runs* "%/%" '())) |
︙ | ︙ |
Modified db.scm from [a540e1036f] to [6e6a12b542].
︙ | ︙ | |||
504 505 506 507 508 509 510 511 512 513 514 515 516 517 | (set! res (cons (vector key keytype) res))) db "SELECT fieldname,fieldtype FROM keys ORDER BY id DESC;") (set! *db-keys* res) (debug:print-info 11 "db:get-keys END (cache miss)") res))) (define (db:get-value-by-header row header field) (debug:print-info 4 "db:get-value-by-header row: " row " header: " header " field: " field) (if (null? header) #f (let loop ((hed (car header)) (tal (cdr header)) (n 0)) (if (equal? hed field) | > | 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 | (set! res (cons (vector key keytype) res))) db "SELECT fieldname,fieldtype FROM keys ORDER BY id DESC;") (set! *db-keys* res) (debug:print-info 11 "db:get-keys END (cache miss)") res))) ;; (define (db:get-value-by-header row header field) (debug:print-info 4 "db:get-value-by-header row: " row " header: " header " field: " field) (if (null? header) #f (let loop ((hed (car header)) (tal (cdr header)) (n 0)) (if (equal? hed field) |
︙ | ︙ | |||
580 581 582 583 584 585 586 587 588 589 590 591 592 593 | (lambda (a . x) (set! res (cons (apply vector a x) res))) db qrystr ) (debug:print-info 11 "db:get-runs END qrystr: " qrystr " keypatts: " keypatts " offset: " offset " limit: " count) (vector header res))) ;; just get count of runs (define (db:get-num-runs db runpatt) (let ((numruns 0)) (debug:print-info 11 "db:get-num-runs START " runpatt) (sqlite3:for-each-row (lambda (count) | > > > > > > > > > > > > > > > > > > > > > | 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 | (lambda (a . x) (set! res (cons (apply vector a x) res))) db qrystr ) (debug:print-info 11 "db:get-runs END qrystr: " qrystr " keypatts: " keypatts " offset: " offset " limit: " count) (vector header res))) ;; Get all targets from the db ;; (define (db:get-targets db) (let* ((res '()) (keys (db:get-keys db)) (header (map key:get-fieldname keys)) (keystr (keys->keystr keys)) (qrystr (conc "SELECT " keystr " FROM runs;")) (seen (make-hash-table))) (sqlite3:for-each-row (lambda (a . x) (let ((targ (cons a x))) (if (not (hash-table-ref/default seen targ #f)) (begin (hash-table-set! seen targ #t) (set! res (cons (apply vector targ) res)))))) db qrystr) (debug:print-info 11 "db:get-targets END qrystr: " qrystr ) (vector header res))) ;; just get count of runs (define (db:get-num-runs db runpatt) (let ((numruns 0)) (debug:print-info 11 "db:get-num-runs START " runpatt) (sqlite3:for-each-row (lambda (count) |
︙ | ︙ |
Modified docs/manual/megatest_manual.txt from [db93d807cc] to [6b638a28bf].
1 2 3 4 5 6 7 | The Megatest Users Manual ========================= Matt Welland <matt@kiatoa.com> v1.0, April 2012 :doctype: book | < < < < < < < < < < < < < < < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 | 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? ~~~~~~~~~~~~~ |
︙ | ︙ |
Modified margs.scm from [282b6e3581] to [5bb81571cb].
︙ | ︙ | |||
15 16 17 18 19 20 21 | (define (args:get-arg arg . default) (if (null? default) (hash-table-ref/default args:arg-hash arg #f) (hash-table-ref/default args:arg-hash arg (car default)))) (define (args:get-arg-from ht arg . default) (if (null? default) | | | | > | 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 | (define (args:get-arg arg . default) (if (null? default) (hash-table-ref/default args:arg-hash arg #f) (hash-table-ref/default args:arg-hash arg (car default)))) (define (args:get-arg-from ht arg . default) (if (null? default) (hash-table-ref/default ht arg #f) (hash-table-ref/default ht arg (car default)))) (define (args:usage . args) (if (> (length args) 0) (apply print "ERROR: " args)) (if (string? help) (print help) (print "Usage: " (car (argv)) " ... ")) (exit 0)) ;; args: (define (args:get-args args params switches arg-hash num-needed) (let* ((numargs (length args)) (adj-num-needed (if num-needed (+ num-needed 2) #f))) (if (< numargs (if adj-num-needed adj-num-needed 2)) (if (>= num-needed 1) (args:usage "No arguments provided") '()) (let loop ((arg (cadr args)) (tail (cddr args)) (remargs '())) (cond ((member arg params) ;; args with params (if (< (length tail) 1) (args:usage "param given without argument " arg) |
︙ | ︙ |
Modified runs.scm from [f136285a97] to [0d071f8e6c].
︙ | ︙ | |||
975 976 977 978 979 980 981 | (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) | | | 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 | (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)))) |
︙ | ︙ |
Modified tests.scm from [45344ee04b] to [628e641bd0].
︙ | ︙ | |||
24 25 26 27 28 29 30 | (include "common_records.scm") (include "key_records.scm") (include "db_records.scm") (include "run_records.scm") (include "test_records.scm") | < < < < < < < < < < | 24 25 26 27 28 29 30 31 32 33 34 35 36 37 | (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) |
︙ | ︙ | |||
427 428 429 430 431 432 433 | (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) ))))) | > > > | > | > > | < > | < | | < | 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 | (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 |
︙ | ︙ | |||
528 529 530 531 532 533 534 535 536 537 538 539 540 541 | (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)) ;;====================================================================== ;; test steps ;;====================================================================== ;; teststep-set-status! used to be here | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 | (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 |
︙ | ︙ |