Index: Makefile ================================================================== --- Makefile +++ Makefile @@ -56,11 +56,11 @@ tests.o tasks.o dashboard-tasks.o : task_records.scm runs.o : test_records.scm megatest.o : megatest-fossil-hash.scm # Temporary while transitioning to new routine -runs.o : run-tests-queue-classic.scm run-tests-queue-new.scm +# runs.o : run-tests-queue-classic.scm run-tests-queue-new.scm megatest-fossil-hash.scm : $(SRCFILES) megatest.scm *_records.scm echo "(define megatest-fossil-hash \"$(MTESTHASH)\")" > megatest-fossil-hash.new if ! diff -q megatest-fossil-hash.new megatest-fossil-hash.scm ; then echo copying .new to .scm;cp -f megatest-fossil-hash.new megatest-fossil-hash.scm;fi Index: TODO ================================================================== --- TODO +++ TODO @@ -1,15 +1,4 @@ -1. Run all tests -2. create run areas, copy in conf and scripts DONE -3. Add a host chooser for ssh to launch-tests -4. Run creation timestamp not happening DONE -5 . Check for test already in progress, give meaningful message DONE -6. Debug xterm creation for test generation DONE -7. Capture run info, host, load, freemem at test launch DONE -8. Rename to testalot? Nah! I like Megatest -10. Run, test and step comment field -11. At end of test scan all tests for this run, if all done - update run status to COMPLETED NOT gonna happen. It is up to the test to mark as PASS/FAIL -12. state and status lists need to be regexes -13. Test on Chicken 4. DONE -14. Try making static executable -15. Log processor script DONE + +1. Confirm that branch transaction-for-sequential-writes content was added to trunk/development +2. Add a host chooser for ssh to launch-tests +3. Try making static executable Index: common.scm ================================================================== --- common.scm +++ common.scm @@ -65,21 +65,25 @@ (define *toptest-paths* (make-hash-table)) ;; cache toptest path settings here (define *test-paths* (make-hash-table)) ;; cache test-id to test run paths here (define *test-ids* (make-hash-table)) ;; cache run-id, testname, and item-path => test-id (define *test-info* (make-hash-table)) ;; cache the test info records, update the state, status, run_duration etc. from testdat.db +(define *run-info-cache* (make-hash-table)) ;; run info is stable, no need to reget + ;; Awful. Please FIXME (define *env-vars-by-run-id* (make-hash-table)) (define *current-run-name* #f) (define (common:clear-caches) + (set! *target* (make-hash-table)) (set! *keys* (make-hash-table)) (set! *keyvals* (make-hash-table)) (set! *toptest-paths* (make-hash-table)) (set! *test-paths* (make-hash-table)) (set! *test-ids* (make-hash-table)) (set! *test-info* (make-hash-table)) + (set! *run-info-cache* (make-hash-table)) (set! *env-vars-by-run-id* (make-hash-table)) (set! *test-id-cache* (make-hash-table))) ;; Debugging stuff (define *verbosity* 1) @@ -141,10 +145,36 @@ ;; '(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 ;;====================================================================== Index: dashboard-tests.scm ================================================================== --- dashboard-tests.scm +++ dashboard-tests.scm @@ -488,11 +488,13 @@ (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))))) + 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" Index: dashboard.scm ================================================================== --- dashboard.scm +++ dashboard.scm @@ -12,13 +12,15 @@ (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)) @@ -423,12 +425,217 @@ ;; (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) - ) + (set! *delayed-update* 1)) + +;;====================================================================== +;; R U N C O N T R O L +;;====================================================================== + +;; target populating logic +;; +;; lb = +;; 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 + (if (not (null? values)) + (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 "x10" + #:fontsize "10" + #:expand "VERTICAL" + ;; #: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:draw-tests cnv xadj yadj test-draw-state sorted-testnames) + (canvas-clear! cnv) + (canvas-font-set! cnv "Courier New, -10") + (let-values (((sizex sizey sizexmm sizeymm) (canvas-size cnv)) + ((originx originy) (canvas-origin cnv))) + (if (hash-table-ref/default test-draw-state 'first-time #t) + (begin + (hash-table-set! test-draw-state 'first-time #f) + (hash-table-set! test-draw-state 'scalef 8) + ;; set these + (hash-table-set! test-draw-state 'test-browse-xoffset 20) ;; (- 0 (* (/ sizex 2) (* 8 xadj)))) + (hash-table-set! test-draw-state 'test-browse-yoffset 20))) ;; (- 0 (* (/ sizey 2) (* 8 (- 1 yadj))))))) + (let* ((scalef (hash-table-ref/default test-draw-state 'scalef 8)) + (test-browse-xoffset (hash-table-ref test-draw-state 'test-browse-xoffset)) + (test-browse-yoffset (hash-table-ref test-draw-state 'test-browse-yoffset)) + (xtorig (+ test-browse-xoffset (* (/ sizex 2) scalef (- 0.5 xadj)))) ;; (- xadj 1)))) + (ytorig (+ test-browse-yoffset (* (/ sizey 2) scalef (- yadj 0.5)))) + (boxw 90) + (boxh 25) + (gapx 20) + (gapy 30)) + (print "sizex: " sizex " sizey: " sizey " font: " (canvas-font cnv) " originx: " originx " originy: " originy " xtorig: " xtorig " ytorig: " ytorig " xadj: " xadj " yadj: " yadj) + (let loop ((hed (car (reverse sorted-testnames))) + (tal (cdr (reverse sorted-testnames))) + (llx xtorig) + (lly ytorig) + (urx (+ xtorig boxw)) + (ury (+ ytorig boxh))) + ; (print "hed " hed " llx " llx " lly " lly " urx " urx " ury " ury) + (canvas-text! cnv (+ llx 5)(+ lly 5) hed) ;; (conc testname " (" xtorig "," ytorig ")")) + (canvas-rectangle! cnv llx urx lly ury) + (if (not (null? tal)) + ;; leave a column of space to the right to list items + (let ((have-room + (if #t ;; put "auto" here where some form of auto rearanging can be done + (> (* 3 (+ boxw gapx)) (- urx xtorig)) + (< urx (- sizex boxw gapx boxw))))) ;; is there room for another column? + (loop (car tal) + (cdr tal) + (if have-room (+ llx boxw gapx) xtorig) ;; have room, + (if have-room lly (+ lly boxh gapy)) + (if have-room (+ urx boxw gapx) (+ xtorig boxw)) + (if have-room ury (+ ury boxh gapy))))))))) + +(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) + )) + (tests-draw-state (make-hash-table))) ;; use for keeping state of the test canvas + (hash-table-set! tests-draw-state 'first-time #t) + (hash-table-set! tests-draw-state 'scalef 8) + (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) + (dashboard:draw-tests cnv xadj yadj tests-draw-state sorted-testnames))) + #:size "150x150" + #:expand "YES" + #: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)) @@ -603,20 +810,26 @@ (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" - (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))) - (vector keycol lftcol header runsvec))) + (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") Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -515,10 +515,11 @@ db "SELECT fieldname FROM keys ORDER BY id DESC;") (set! *db-keys* res) 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)) @@ -643,22 +644,80 @@ 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 keys) ;; (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) (set! numruns count)) db - "SELECT COUNT(id) FROM runs WHERE runname LIKE ? AND state != 'DELETED';" runpatt) + "SELECT COUNT(id) FROM runs WHERE runname LIKE ? AND state != 'deleted';" runpatt) (debug:print-info 11 "db:get-num-runs END " runpatt) numruns)) +;; db:get-runs-by-patt +;; get runs by list of criteria +;; register a test run with the db +;; +;; Use: (db-get-value-by-header (db:get-header runinfo)(db:get-row runinfo)) +;; to extract info from the structure returned +;; +(define (db:get-runs-by-patt db keys runnamepatt targpatt) ;; test-name) + (let* ((tmp (runs:get-std-run-fields keys '("id" "runname" "state" "status" "owner" "event_time"))) + (keystr (car tmp)) + (header (cadr tmp)) + (res '()) + (key-patt "") + (runwildtype (if (substring-index "%" runnamepatt) "like" "glob")) + (qry-str #f) + (keyvals (keys:target->keyval keys targpatt))) + (for-each (lambda (keyval) + (let* ((key (car keyval)) + (patt (cadr keyval)) + (fulkey (conc ":" key)) + (wildtype (if (substring-index "%" patt) "like" "glob"))) + (if patt + (set! key-patt (conc key-patt " AND " key " " wildtype " '" patt "'")) + (begin + (debug:print 0 "ERROR: searching for runs with no pattern set for " fulkey) + (exit 6))))) + keyvals) + (set! qry-str (conc "SELECT " keystr " FROM runs WHERE runname " runwildtype " ? " key-patt ";")) + (debug:print-info 4 "runs:get-runs-by-patt qry=" qry-str " " runnamepatt) + (sqlite3:for-each-row + (lambda (a . r) + (set! res (cons (list->vector (cons a r)) res))) + db + qry-str + runnamepatt) + (vector header res))) + ;; use (get-value-by-header (db:get-header runinfo)(db:get-row runinfo)) (define (db:get-run-info db run-id) ;;(if (hash-table-ref/default *run-info-cache* run-id #f) ;; (hash-table-ref *run-info-cache* run-id) (let* ((res #f) @@ -732,11 +791,11 @@ ;; get key vals for a given run-id (define (db:get-key-vals db run-id) (let ((mykeyvals (hash-table-ref/default *keyvals* run-id #f))) (if mykeyvals mykeyvals - (let* ((keys (db:get-keys db)) + (let* ((keys (db:get-keys db)) (res '())) (debug:print-info 11 "db:get-key-vals START keys: " keys " run-id: " run-id) (for-each (lambda (key) (let ((qry (conc "SELECT " key " FROM runs WHERE id=?;"))) 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: launch.scm ================================================================== --- launch.scm +++ launch.scm @@ -667,24 +667,29 @@ (list "MT_ITEM_INFO" (conc itemdat)) (list "MT_RUNNAME" runname) (list "MT_TARGET" mt_target) ) itemdat))) - (launch-results (apply (if (equal? (configf:lookup *configdat* "setup" "launchwait") "yes") + ;; Launchwait defaults to true, must override it to turn off wait + (launchwait (if (equal? (configf:lookup *configdat* "setup" "launchwait") "no") #f #t)) + (launch-results (apply (if launchwait cmd-run-with-stderr->list process-run) (if useshell (string-intersperse fullcmd " ") (car fullcmd)) (if useshell '() (cdr fullcmd))))) - (if (list? launch-results) - (with-output-to-file "mt_launch.log" - (lambda () - (apply print launch-results)) - #:append)) + (if (not launchwait) ;; give the OS a little time to allow the process to start + (thread-sleep! 0.01)) + (with-output-to-file "mt_launch.log" + (lambda () + (if (list? launch-results) + (apply print launch-results) + (print "NOTE: launched \"" fullcmd "\"\n but did not wait for it to proceed. Add the following to megatest.config \n[setup]\nlaunchwait yes\n if you have problems with this")) + #:append)) (debug:print 2 "Launching completed, updating db") (debug:print 2 "Launch results: " launch-results) (if (not launch-results) (begin (print "ERROR: Failed to run " (string-intersperse fullcmd " ") ", exiting now") Index: margs.scm ================================================================== --- margs.scm +++ margs.scm @@ -17,12 +17,12 @@ (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))) + (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) @@ -34,11 +34,12 @@ (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")) + (args:usage "No arguments provided") + '()) (let loop ((arg (cadr args)) (tail (cddr args)) (remargs '())) (cond ((member arg params) ;; args with params Index: megatest-version.scm ================================================================== --- megatest-version.scm +++ megatest-version.scm @@ -1,7 +1,7 @@ ;; Always use two digit decimal ;; 1.01, 1.02...1.10,1.11 ... 1.99,2.00.. (declare (unit megatest-version)) -(define megatest-version 1.5504) +(define megatest-version 1.5505) Index: mt.scm ================================================================== --- mt.scm +++ mt.scm @@ -27,10 +27,27 @@ (include "test_records.scm") ;; This is the Megatest API. All generally "useful" routines will be wrapped or extended ;; here. +;;====================================================================== +;; R U N S +;;====================================================================== + +;; runs:get-runs-by-patt +;; get runs by list of criteria +;; register a test run with the db +;; +;; Use: (db-get-value-by-header (db:get-header runinfo)(db:get-row runinfo)) +;; to extract info from the structure returned +;; +(define (mt:get-runs-by-patt keys runnamepatt targpatt) + (cdb:remote-run db:get-runs-by-patt #f keys runnamepatt targpatt)) + +;;====================================================================== +;; T E S T S +;;====================================================================== (define (mt:get-tests-for-run run-id testpatt states status #!key (not-in #t) (sort-by #f)) (let loop ((testsdat (cdb:remote-run db:get-tests-for-run #f run-id testpatt states status 0 500 not-in sort-by)) (res '()) (offset 0) DELETED run-tests-queue-classic.scm Index: run-tests-queue-classic.scm ================================================================== --- run-tests-queue-classic.scm +++ /dev/null @@ -1,300 +0,0 @@ - -;; test-records is a hash table testname:item_path => vector < testname testconfig waitons priority items-info ... > -(define (runs:run-tests-queue-classic run-id runname test-records keyvals flags test-patts required-tests) - ;; At this point the list of parent tests is expanded - ;; NB// Should expand items here and then insert into the run queue. - (debug:print 5 "test-records: " test-records ", flags: " (hash-table->alist flags)) - (let ((run-info (cdb:remote-run db:get-run-info #f run-id)) - (sorted-test-names (tests:sort-by-priority-and-waiton test-records)) - (test-registry (make-hash-table)) - (registry-mutex (make-mutex)) - (num-retries 0) - (max-retries (config-lookup *configdat* "setup" "maxretries")) - (max-concurrent-jobs (let ((mcj (config-lookup *configdat* "setup" "max_concurrent_jobs"))) - (if (and mcj (string->number mcj)) - (string->number mcj) - 1)))) - (set! max-retries (if (and max-retries (string->number max-retries))(string->number max-retries) 100)) - (if (not (null? sorted-test-names)) - (let loop ((hed (car sorted-test-names)) - (tal (cdr sorted-test-names)) - (reruns '())) - (if (not (null? reruns))(debug:print-info 4 "reruns=" reruns)) - ;; (print "Top of loop, hed=" hed ", tal=" tal " ,reruns=" reruns) - (let* ((test-record (hash-table-ref test-records hed)) - (test-name (tests:testqueue-get-testname test-record)) - (tconfig (tests:testqueue-get-testconfig test-record)) - (jobgroup (config-lookup tconfig "requirements" "jobgroup")) - (testmode (let ((m (config-lookup tconfig "requirements" "mode"))) - (if m (string->symbol m) 'normal))) - (waitons (tests:testqueue-get-waitons test-record)) - (priority (tests:testqueue-get-priority test-record)) - (itemdat (tests:testqueue-get-itemdat test-record)) ;; itemdat can be a string, list or #f - (items (tests:testqueue-get-items test-record)) - (item-path (item-list->path itemdat)) - (newtal (append tal (list hed)))) - - (debug:print 6 - "test-name: " test-name - "\n hed: " hed - "\n itemdat: " itemdat - "\n items: " items - "\n item-path: " item-path - "\n waitons: " waitons - "\n num-retries: " num-retries - "\n tal: " tal - "\n reruns: " reruns) - - ;; check for hed in waitons => this would be circular, remove it and issue an - ;; error - (if (member test-name waitons) - (begin - (debug:print 0 "ERROR: test " test-name " has listed itself as a waiton, please correct this!") - (set! waiton (filter (lambda (x)(not (equal? x hed))) waitons)))) - - (cond ;; OUTER COND - ((not items) ;; when false the test is ok to be handed off to launch (but not before) - (if (and (not (tests:match test-patts (tests:testqueue-get-testname test-record) item-path required: required-tests)) - (not (null? tal))) - (loop (car newtal)(cdr newtal) reruns)) - (let* ((run-limits-info ;; (cdb:remote-run runs:can-run-more-tests #f jobgroup max-concurrent-jobs)) ;; look at the test jobgroup and tot jobs running - (open-run-close runs:can-run-more-tests #f jobgroup max-concurrent-jobs)) ;; look at the test jobgroup and tot jobs running - (have-resources (car run-limits-info)) - (num-running (list-ref run-limits-info 1)) - (num-running-in-jobgroup (list-ref run-limits-info 2)) - (max-concurrent-jobs (list-ref run-limits-info 3)) - (job-group-limit (list-ref run-limits-info 4)) - (prereqs-not-met (db:get-prereqs-not-met run-id waitons item-path mode: testmode)) - (fails (runs:calc-fails prereqs-not-met)) - (non-completed (runs:calc-not-completed prereqs-not-met))) - (debug:print-info 8 "have-resources: " have-resources " prereqs-not-met: " - (string-intersperse - (map (lambda (t) - (if (vector? t) - (conc (db:test-get-state t) "/" (db:test-get-status t)) - (conc " WARNING: t is not a vector=" t ))) - prereqs-not-met) ", ") " fails: " fails) - (debug:print-info 4 "hed=" hed "\n test-record=" test-record "\n test-name: " test-name "\n item-path: " item-path "\n test-patts: " test-patts) - - ;; Don't know at this time if the test have been launched at some time in the past - ;; i.e. is this a re-launch? - (debug:print-info 4 "run-limits-info = " run-limits-info) - (cond ;; INNER COND #1 for a launchable test - ;; Check item path against item-patts - ((not (tests:match test-patts (tests:testqueue-get-testname test-record) item-path required: required-tests)) ;; This test/itempath is not to be run - ;; else the run is stuck, temporarily or permanently - ;; but should check if it is due to lack of resources vs. prerequisites - (debug:print-info 1 "Skipping " (tests:testqueue-get-testname test-record) " " item-path " as it doesn't match " test-patts) - ;; (thread-sleep! *global-delta*) - (if (not (null? tal)) - (loop (car tal)(cdr tal) reruns))) - ;; Registry has been started for this test but has not yet completed - ;; this should be rare, the case where there are only a couple of tests and the db is slow - ;; delay a short while and continue - ;; ((eq? (hash-table-ref/default test-registry (runs:make-full-test-name test-name item-path) #f) 'start) - ;; (thread-sleep! 0.01) - ;; (loop (car newtal)(cdr newtal) reruns)) - ;; count number of 'done, if more than 100 then skip on through. - ((not (hash-table-ref/default test-registry (runs:make-full-test-name test-name item-path) #f)) ;; ) ;; too many changes required. Implement later. - (debug:print-info 4 "Pre-registering test " test-name "/" item-path " to create placeholder" ) - (let ((th (make-thread (lambda () - (mutex-lock! registry-mutex) - (hash-table-set! test-registry (runs:make-full-test-name test-name item-path) 'start) - (mutex-unlock! registry-mutex) - ;; If haven't done it before register a top level test if this is an itemized test - (if (not (eq? (hash-table-ref/default test-registry (runs:make-full-test-name test-name "") #f) 'done)) - (cdb:tests-register-test *runremote* run-id test-name "")) - (cdb:tests-register-test *runremote* run-id test-name item-path) - (mutex-lock! registry-mutex) - (hash-table-set! test-registry (runs:make-full-test-name test-name item-path) 'done) - (mutex-unlock! registry-mutex)) - (conc test-name "/" item-path)))) - (thread-start! th)) - (runs:shrink-can-run-more-tests-count) ;; DELAY TWEAKER (still needed?) - (loop (car newtal)(cdr newtal) reruns)) - ;; At this point *all* test registrations must be completed. - ((not (null? (filter (lambda (x)(eq? 'start x))(hash-table-values test-registry)))) - (debug:print-info 0 "Waiting on test registrations: " (string-intersperse - (filter (lambda (x) - (eq? (hash-table-ref/default test-registry x #f) 'start)) - (hash-table-keys test-registry)) - ", ")) - (thread-sleep! 0.1) - (loop hed tal reruns)) - ((not have-resources) ;; simply try again after waiting a second - (debug:print-info 1 "no resources to run new tests, waiting ...") - ;; Have gone back and forth on this but db starvation is an issue. - ;; wait one second before looking again to run jobs. - (thread-sleep! 1) ;; (+ 2 *global-delta*)) - ;; could have done hed tal here but doing car/cdr of newtal to rotate tests - (loop (car newtal)(cdr newtal) reruns)) - ((and have-resources - (or (null? prereqs-not-met) - (and (eq? testmode 'toplevel) - (null? non-completed)))) - (run:test run-id run-info keyvals runname test-record flags #f) - (hash-table-set! test-registry (runs:make-full-test-name test-name item-path) 'running) - (runs:shrink-can-run-more-tests-count) ;; DELAY TWEAKER (still needed?) - ;; (thread-sleep! *global-delta*) - (if (not (null? tal)) - (loop (car tal)(cdr tal) reruns))) - (else ;; must be we have unmet prerequisites - (debug:print 4 "FAILS: " fails) - ;; If one or more of the prereqs-not-met are FAIL then we can issue - ;; a message and drop hed from the items to be processed. - (if (null? fails) - (begin - ;; couldn't run, take a breather - (debug:print-info 4 "Shouldn't really get here, race condition? Unable to launch more tests at this moment, killing time ...") - ;; (thread-sleep! (+ 0.01 *global-delta*)) ;; long sleep here - no resources, may as well be patient - ;; we made new tal by sticking hed at the back of the list - (loop (car newtal)(cdr newtal) reruns)) - ;; the waiton is FAIL so no point in trying to run hed ever again - (if (not (null? tal)) - (if (vector? hed) - (begin - (debug:print 1 "WARN: Dropping test " (db:test-get-testname hed) "/" (db:test-get-item-path hed) - " from the launch list as it has prerequistes that are FAIL") - (runs:shrink-can-run-more-tests-count) ;; DELAY TWEAKER (still needed?) - ;; (thread-sleep! *global-delta*) - (hash-table-set! test-registry (runs:make-full-test-name test-name item-path) 'removed) - (loop (car tal)(cdr tal) (cons hed reruns))) - (begin - (debug:print 1 "WARN: Test not processed correctly. Could be a race condition in your test implementation? " hed) ;; " as it has prerequistes that are FAIL. (NOTE: hed is not a vector)") - (runs:shrink-can-run-more-tests-count) ;; DELAY TWEAKER (still needed?) - ;; (thread-sleep! (+ 0.01 *global-delta*)) - (loop hed tal reruns))))))))) ;; END OF INNER COND - - ;; case where an items came in as a list been processed - ((and (list? items) ;; thus we know our items are already calculated - (not itemdat)) ;; and not yet expanded into the list of things to be done - (if (and (debug:debug-mode 1) ;; (>= *verbosity* 1) - (> (length items) 0) - (> (length (car items)) 0)) - (pp items)) - (for-each - (lambda (my-itemdat) - (let* ((new-test-record (let ((newrec (make-tests:testqueue))) - (vector-copy! test-record newrec) - newrec)) - (my-item-path (item-list->path my-itemdat))) - (if (tests:match test-patts hed my-item-path required: required-tests) ;; (patt-list-match my-item-path item-patts) ;; yes, we want to process this item, NOTE: Should not need this check here! - (let ((newtestname (runs:make-full-test-name hed my-item-path))) ;; test names are unique on testname/item-path - (tests:testqueue-set-items! new-test-record #f) - (tests:testqueue-set-itemdat! new-test-record my-itemdat) - (tests:testqueue-set-item_path! new-test-record my-item-path) - (hash-table-set! test-records newtestname new-test-record) - (set! tal (cons newtestname tal)))))) ;; since these are itemized create new test names testname/itempath - items) - (if (not (null? tal)) - (begin - (debug:print-info 4 "End of items list, looping with next after short delay") - ;; (thread-sleep! (+ 0.01 *global-delta*)) - (loop (car tal)(cdr tal) reruns)))) - - ;; if items is a proc then need to run items:get-items-from-config, get the list and loop - ;; - but only do that if resources exist to kick off the job - ((or (procedure? items)(eq? items 'have-procedure)) - (let ((can-run-more ;; (cdb:remote-run runs:can-run-more-tests #f jobgroup max-concurrent-jobs))) - (open-run-close runs:can-run-more-tests #f jobgroup max-concurrent-jobs))) - (if (and (list? can-run-more) - (car can-run-more)) - (let* ((prereqs-not-met (db:get-prereqs-not-met run-id waitons item-path mode: testmode)) - (fails (runs:calc-fails prereqs-not-met)) - (non-completed (runs:calc-not-completed prereqs-not-met))) - (debug:print-info 8 "can-run-more: " can-run-more - "\n testname: " hed - "\n prereqs-not-met: " (runs:pretty-string prereqs-not-met) - "\n non-completed: " (runs:pretty-string non-completed) - "\n fails: " (runs:pretty-string fails) - "\n testmode: " testmode - "\n num-retries: " num-retries - "\n (eq? testmode 'toplevel): " (eq? testmode 'toplevel) - "\n (null? non-completed): " (null? non-completed) - "\n reruns: " reruns - "\n items: " items - "\n can-run-more: " can-run-more) - ;; (thread-sleep! (+ 0.01 *global-delta*)) - (cond ;; INNER COND #2 - ((or (null? prereqs-not-met) ;; all prereqs met, fire off the test - ;; or, if it is a 'toplevel test and all prereqs not met are COMPLETED then launch - (and (eq? testmode 'toplevel) - (null? non-completed))) - (let ((test-name (tests:testqueue-get-testname test-record))) - (setenv "MT_TEST_NAME" test-name) ;; - (setenv "MT_RUNNAME" runname) - (set-megatest-env-vars run-id inrunname: runname) ;; these may be needed by the launching process - (let ((items-list (items:get-items-from-config tconfig))) - (if (list? items-list) - (begin - (tests:testqueue-set-items! test-record items-list) - ;; (thread-sleep! *global-delta*) - (loop hed tal reruns)) - (begin - (debug:print 0 "ERROR: The proc from reading the setup did not yield a list - please report this") - (exit 1)))))) - ((null? fails) - (debug:print-info 4 "fails is null, moving on in the queue but keeping " hed " for now") - ;; only increment num-retries when there are no tests runing - (if (eq? 0 (list-ref can-run-more 1)) - (begin - ;; TRY (if (> num-retries 100) ;; first 100 retries are low time cost - ;; TRY (thread-sleep! (+ 2 *global-delta*)) - ;; TRY (thread-sleep! (+ 0.01 *global-delta*))) - (set! num-retries (+ num-retries 1)))) - (if (> num-retries max-retries) - (if (not (null? tal)) - (loop (car tal)(cdr tal) reruns)) - (loop (car newtal)(cdr newtal) reruns))) ;; an issue with prereqs not yet met? - ((and (not (null? fails))(eq? testmode 'normal)) - (debug:print-info 1 "test " hed " (mode=" testmode ") has failed prerequisite(s); " - (string-intersperse (map (lambda (t)(conc (db:test-get-testname t) ":" (db:test-get-state t)"/"(db:test-get-status t))) fails) ", ") - ", removing it from to-do list") - (if (not (null? tal)) - (begin - ;; (thread-sleep! *global-delta*) - (loop (car tal)(cdr tal)(cons hed reruns))))) - (else - (debug:print 8 "ERROR: No handler for this condition.") - ;; TRY (thread-sleep! (+ 1 *global-delta*)) - (loop (car newtal)(cdr newtal) reruns)))) ;; END OF IF CAN RUN MORE - - ;; if can't run more just loop with next possible test - (begin - (debug:print-info 4 "processing the case with a lambda for items or 'have-procedure. Moving through the queue without dropping " hed) - ;; (thread-sleep! (+ 2 *global-delta*)) - (loop (car newtal)(cdr newtal) reruns))))) ;; END OF (or (procedure? items)(eq? items 'have-procedure)) - - ;; this case should not happen, added to help catch any bugs - ((and (list? items) itemdat) - (debug:print 0 "ERROR: Should not have a list of items in a test and the itemspath set - please report this") - (exit 1)) - ((not (null? reruns)) - (let* ((newlst (tests:filter-non-runnable run-id tal test-records)) ;; i.e. not FAIL, WAIVED, INCOMPLETE, PASS, KILLED, - (junked (lset-difference equal? tal newlst))) - (debug:print-info 4 "full drop through, if reruns is less than 100 we will force retry them, reruns=" reruns ", tal=" tal) - (if (< num-retries max-retries) - (set! newlst (append reruns newlst))) - (set! num-retries (+ num-retries 1)) - ;; (thread-sleep! (+ 1 *global-delta*)) - (if (not (null? newlst)) - ;; since reruns have been tacked on to newlst create new reruns from junked - (loop (car newlst)(cdr newlst)(delete-duplicates junked))))) - ((not (null? tal)) - (debug:print-info 4 "I'm pretty sure I shouldn't get here.")) - (else - (debug:print-info 4 "Exiting loop with...\n hed=" hed "\n tal=" tal "\n reruns=" reruns)) - )))) ;; LET* ((test-record - - ;; we get here on "drop through" - loop for next test in queue - ;; FIXME!!!! THIS SHOULD NOT REQUIRE AN EXIT!!!!!!! - - (debug:print-info 1 "All tests launched") - (thread-sleep! 0.5) - ;; FIXME! This harsh exit should not be necessary.... - ;; (if (not *runremote*)(exit)) ;; - #f)) ;; return a #f as a hint that we are done - ;; Here we need to check that all the tests remaining to be run are eligible to run - ;; and are not blocked by failed - - Index: run-tests-queue-new.scm ================================================================== --- run-tests-queue-new.scm +++ run-tests-queue-new.scm @@ -1,353 +0,0 @@ - -;; test-records is a hash table testname:item_path => vector < testname testconfig waitons priority items-info ... > -(define (runs:run-tests-queue-new run-id runname test-records keyvals flags test-patts required-tests reglen-in) - ;; At this point the list of parent tests is expanded - ;; NB// Should expand items here and then insert into the run queue. - (debug:print 5 "test-records: " test-records ", flags: " (hash-table->alist flags)) - (let ((run-info (cdb:remote-run db:get-run-info #f run-id)) - (tests-info (mt:get-tests-for-run run-id #f '() '())) ;; qryvals: "id,testname,item_path")) - (sorted-test-names (tests:sort-by-priority-and-waiton test-records)) - (test-registry (make-hash-table)) - (registry-mutex (make-mutex)) - (num-retries 0) - (max-retries (config-lookup *configdat* "setup" "maxretries")) - (max-concurrent-jobs (let ((mcj (config-lookup *configdat* "setup" "max_concurrent_jobs"))) - (if (and mcj (string->number mcj)) - (string->number mcj) - 1))) ;; length of the register queue ahead - (reglen (if (number? reglen-in) reglen-in 1))) - ;; Initialize the test-registery hash with tests that already have a record - (for-each (lambda (trec) - (let ((id (db:test-get-id trec)) - (tn (db:test-get-testname trec)) - (ip (db:test-get-item-path trec)) - (st (db:test-get-state trec))) - (hash-table-set! test-registry (runs:make-full-test-name tn ip) (string->symbol st)))) - tests-info) - (set! max-retries (if (and max-retries (string->number max-retries))(string->number max-retries) 100)) - (if (not (null? sorted-test-names)) - (let loop ((hed (car sorted-test-names)) - (tal (cdr sorted-test-names)) - (reg '()) ;; registered, put these at the head of tal - (reruns '())) - (if (not (null? reruns))(debug:print-info 4 "reruns=" reruns)) - ;; (print "Top of loop, hed=" hed ", tal=" tal " ,reruns=" reruns) - (let* ((test-record (hash-table-ref test-records hed)) - (test-name (tests:testqueue-get-testname test-record)) - (tconfig (tests:testqueue-get-testconfig test-record)) - (jobgroup (config-lookup tconfig "requirements" "jobgroup")) - (testmode (let ((m (config-lookup tconfig "requirements" "mode"))) - (if m (string->symbol m) 'normal))) - (waitons (tests:testqueue-get-waitons test-record)) - (priority (tests:testqueue-get-priority test-record)) - (itemdat (tests:testqueue-get-itemdat test-record)) ;; itemdat can be a string, list or #f - (items (tests:testqueue-get-items test-record)) - (item-path (item-list->path itemdat)) - (tfullname (runs:make-full-test-name test-name item-path)) - (newtal (append tal (list hed))) - (regfull (> (length reg) reglen))) - - ;; Fast skip of tests that are already "COMPLETED" - (if (equal? (hash-table-ref/default test-registry tfullname #f) 'COMPLETED) - (begin - (debug:print-info 0 "Skipping COMPLETED test " tfullname) - (if (not (null? tal)) - (loop (car tal)(cdr tal) reg reruns)))) - ;; (if (> (length reg) 10) - ;; (begin - ;; (set! tal (cons hed tal)) - ;; (set! hed (car reg)) - ;; (set! reg (cdr reg)) - ;; (set! newtal tal))) - (debug:print 6 - "test-name: " test-name - "\n hed: " hed - "\n itemdat: " itemdat - "\n items: " items - "\n item-path: " item-path - "\n waitons: " waitons - "\n num-retries: " num-retries - "\n tal: " tal - "\n reruns: " reruns) - - ;; check for hed in waitons => this would be circular, remove it and issue an - ;; error - (if (member test-name waitons) - (begin - (debug:print 0 "ERROR: test " test-name " has listed itself as a waiton, please correct this!") - (set! waiton (filter (lambda (x)(not (equal? x hed))) waitons)))) - - (cond ;; OUTER COND - ((not items) ;; when false the test is ok to be handed off to launch (but not before) - (if (and (not (tests:match test-patts (tests:testqueue-get-testname test-record) item-path required: required-tests)) - (not (null? tal))) - (loop (car tal)(cdr tal) reg reruns)) - (let* ((run-limits-info (cdb:remote-run runs:can-run-more-tests #f jobgroup max-concurrent-jobs)) ;; look at the test jobgroup and tot jobs running - ;; (open-run-close runs:can-run-more-tests #f jobgroup max-concurrent-jobs)) ;; look at the test jobgroup and tot jobs running - (have-resources (car run-limits-info)) - (num-running (list-ref run-limits-info 1)) - (num-running-in-jobgroup (list-ref run-limits-info 2)) - (max-concurrent-jobs (list-ref run-limits-info 3)) - (job-group-limit (list-ref run-limits-info 4)) - (prereqs-not-met (mt:get-prereqs-not-met run-id waitons item-path mode: testmode)) - (fails (runs:calc-fails prereqs-not-met)) - (non-completed (runs:calc-not-completed prereqs-not-met))) - (debug:print-info 8 "have-resources: " have-resources " prereqs-not-met: " - (string-intersperse - (map (lambda (t) - (if (vector? t) - (conc (db:test-get-state t) "/" (db:test-get-status t)) - (conc " WARNING: t is not a vector=" t ))) - prereqs-not-met) ", ") " fails: " fails) - (debug:print-info 4 "hed=" hed "\n test-record=" test-record "\n test-name: " test-name "\n item-path: " item-path "\n test-patts: " test-patts) - - ;; Don't know at this time if the test have been launched at some time in the past - ;; i.e. is this a re-launch? - (debug:print-info 4 "run-limits-info = " run-limits-info) - (cond ;; INNER COND #1 for a launchable test - ;; Check item path against item-patts - ((not (tests:match test-patts (tests:testqueue-get-testname test-record) item-path required: required-tests)) ;; This test/itempath is not to be run - ;; else the run is stuck, temporarily or permanently - ;; but should check if it is due to lack of resources vs. prerequisites - (debug:print-info 1 "Skipping " (tests:testqueue-get-testname test-record) " " item-path " as it doesn't match " test-patts) - ;; (thread-sleep! *global-delta*) - (if (not (null? tal)) - (loop (runs:queue-next-hed tal reg reglen regfull) - (runs:queue-next-tal tal reg reglen regfull) - (runs:queue-next-reg tal reg reglen regfull) - reruns))) - ;; Registry has been started for this test but has not yet completed - ;; this should be rare, the case where there are only a couple of tests and the db is slow - ;; delay a short while and continue - ;; ((eq? (hash-table-ref/default test-registry (runs:make-full-test-name test-name item-path) #f) 'start) - ;; (thread-sleep! 0.01) - ;; (loop (car newtal)(cdr newtal) reruns)) - ;; count number of 'done, if more than 100 then skip on through. - ((not (hash-table-ref/default test-registry (runs:make-full-test-name test-name item-path) #f)) ;; ) ;; too many changes required. Implement later. - (debug:print-info 4 "Pre-registering test " test-name "/" item-path " to create placeholder" ) - (let ((th (make-thread (lambda () - (mutex-lock! registry-mutex) - (hash-table-set! test-registry (runs:make-full-test-name test-name item-path) 'start) - (mutex-unlock! registry-mutex) - ;; If haven't done it before register a top level test if this is an itemized test - (if (not (eq? (hash-table-ref/default test-registry (runs:make-full-test-name test-name "") #f) 'done)) - (cdb:tests-register-test *runremote* run-id test-name "")) - (cdb:tests-register-test *runremote* run-id test-name item-path) - (mutex-lock! registry-mutex) - (hash-table-set! test-registry (runs:make-full-test-name test-name item-path) 'done) - (mutex-unlock! registry-mutex)) - (conc test-name "/" item-path)))) - (thread-start! th)) - (cdb:remote-run runs:shrink-can-run-more-tests-count #f) ;; DELAY TWEAKER (still needed?) - (if (and (null? tal)(null? reg)) - (loop hed tal reg reruns) - (loop (runs:queue-next-hed tal reg reglen regfull) - (runs:queue-next-tal tal reg reglen regfull) - (let ((newl (append reg (list hed)))) - (if regfull - (cdr newl) - newl)) - reruns))) - ;; At this point hed test registration must be completed. - ((eq? (hash-table-ref/default test-registry (runs:make-full-test-name test-name item-path) #f) - 'start) - (debug:print-info 0 "Waiting on test registration(s): " (string-intersperse - (filter (lambda (x) - (eq? (hash-table-ref/default test-registry x #f) 'start)) - (hash-table-keys test-registry)) - ", ")) - (thread-sleep! 0.1) - (loop hed tal reg reruns)) - ((not have-resources) ;; simply try again after waiting a second - (debug:print-info 1 "no resources to run new tests, waiting ...") - ;; Have gone back and forth on this but db starvation is an issue. - ;; wait one second before looking again to run jobs. - (thread-sleep! 1) ;; (+ 2 *global-delta*)) - ;; could have done hed tal here but doing car/cdr of newtal to rotate tests - (loop (car newtal)(cdr newtal) reg reruns)) - ((and have-resources - (or (null? prereqs-not-met) - (and (eq? testmode 'toplevel) - (null? non-completed)))) - (run:test run-id run-info keyvals runname test-record flags #f) - (hash-table-set! test-registry (runs:make-full-test-name test-name item-path) 'running) - (cdb:remote-run runs:shrink-can-run-more-tests-count #f) ;; DELAY TWEAKER (still needed?) - ;; (thread-sleep! *global-delta*) - (if (not (null? tal)) - (loop (runs:queue-next-hed tal reg reglen regfull) - (runs:queue-next-tal tal reg reglen regfull) - (runs:queue-next-reg tal reg reglen regfull) - reruns))) - (else ;; must be we have unmet prerequisites - (debug:print 4 "FAILS: " fails) - ;; If one or more of the prereqs-not-met are FAIL then we can issue - ;; a message and drop hed from the items to be processed. - (if (null? fails) - (begin - ;; couldn't run, take a breather - (debug:print-info 4 "Shouldn't really get here, race condition? Unable to launch more tests at this moment, killing time ...") - ;; (thread-sleep! (+ 0.01 *global-delta*)) ;; long sleep here - no resources, may as well be patient - ;; we made new tal by sticking hed at the back of the list - (loop (car newtal)(cdr newtal) reg reruns)) - ;; the waiton is FAIL so no point in trying to run hed ever again - (if (not (null? tal)) - (if (vector? hed) - (begin - (debug:print 1 "WARN: Dropping test " (db:test-get-testname hed) "/" (db:test-get-item-path hed) - " from the launch list as it has prerequistes that are FAIL") - (cdb:remote-run runs:shrink-can-run-more-tests-count #f) ;; DELAY TWEAKER (still needed?) - ;; (thread-sleep! *global-delta*) - (hash-table-set! test-registry (runs:make-full-test-name test-name item-path) 'removed) - (loop (runs:queue-next-hed tal reg reglen regfull) - (runs:queue-next-tal tal reg reglen regfull) - (runs:queue-next-reg tal reg reglen regfull) - (cons hed reruns))) - (begin - (debug:print 1 "WARN: Test not processed correctly. Could be a race condition in your test implementation? " hed) ;; " as it has prerequistes that are FAIL. (NOTE: hed is not a vector)") - (cdb:remote-run runs:shrink-can-run-more-tests-count #f) ;; DELAY TWEAKER (still needed?) - ;; (thread-sleep! (+ 0.01 *global-delta*)) - (loop hed tal reg reruns))))))))) ;; END OF INNER COND - - ;; case where an items came in as a list been processed - ((and (list? items) ;; thus we know our items are already calculated - (not itemdat)) ;; and not yet expanded into the list of things to be done - (if (and (debug:debug-mode 1) ;; (>= *verbosity* 1) - (> (length items) 0) - (> (length (car items)) 0)) - (pp items)) - (for-each - (lambda (my-itemdat) - (let* ((new-test-record (let ((newrec (make-tests:testqueue))) - (vector-copy! test-record newrec) - newrec)) - (my-item-path (item-list->path my-itemdat))) - (if (tests:match test-patts hed my-item-path required: required-tests) ;; (patt-list-match my-item-path item-patts) ;; yes, we want to process this item, NOTE: Should not need this check here! - (let ((newtestname (runs:make-full-test-name hed my-item-path))) ;; test names are unique on testname/item-path - (tests:testqueue-set-items! new-test-record #f) - (tests:testqueue-set-itemdat! new-test-record my-itemdat) - (tests:testqueue-set-item_path! new-test-record my-item-path) - (hash-table-set! test-records newtestname new-test-record) - (set! tal (cons newtestname tal)))))) ;; since these are itemized create new test names testname/itempath - items) - (if (not (null? tal)) - (begin - (debug:print-info 4 "End of items list, looping with next after short delay") - ;; (thread-sleep! (+ 0.01 *global-delta*)) - (loop (runs:queue-next-hed tal reg reglen regfull) - (runs:queue-next-tal tal reg reglen regfull) - (runs:queue-next-reg tal reg reglen regfull) - reruns)))) - - ;; if items is a proc then need to run items:get-items-from-config, get the list and loop - ;; - but only do that if resources exist to kick off the job - ((or (procedure? items)(eq? items 'have-procedure)) - (let ((can-run-more (cdb:remote-run runs:can-run-more-tests #f jobgroup max-concurrent-jobs))) - (if (and (list? can-run-more) - (car can-run-more)) - (let* ((prereqs-not-met (mt:get-prereqs-not-met run-id waitons item-path mode: testmode)) - (fails (runs:calc-fails prereqs-not-met)) - (non-completed (runs:calc-not-completed prereqs-not-met))) - (debug:print-info 8 "can-run-more: " can-run-more - "\n testname: " hed - "\n prereqs-not-met: " (runs:pretty-string prereqs-not-met) - "\n non-completed: " (runs:pretty-string non-completed) - "\n fails: " (runs:pretty-string fails) - "\n testmode: " testmode - "\n num-retries: " num-retries - "\n (eq? testmode 'toplevel): " (eq? testmode 'toplevel) - "\n (null? non-completed): " (null? non-completed) - "\n reruns: " reruns - "\n items: " items - "\n can-run-more: " can-run-more) - ;; (thread-sleep! (+ 0.01 *global-delta*)) - (cond ;; INNER COND #2 - ((or (null? prereqs-not-met) ;; all prereqs met, fire off the test - ;; or, if it is a 'toplevel test and all prereqs not met are COMPLETED then launch - (and (eq? testmode 'toplevel) - (null? non-completed))) - (let ((test-name (tests:testqueue-get-testname test-record))) - (setenv "MT_TEST_NAME" test-name) ;; - (setenv "MT_RUNNAME" runname) - (set-megatest-env-vars run-id inrunname: runname) ;; these may be needed by the launching process - (let ((items-list (items:get-items-from-config tconfig))) - (if (list? items-list) - (begin - (tests:testqueue-set-items! test-record items-list) - ;; (thread-sleep! *global-delta*) - (loop hed tal reg reruns)) - (begin - (debug:print 0 "ERROR: The proc from reading the setup did not yield a list - please report this") - (exit 1)))))) - ((null? fails) - (debug:print-info 4 "fails is null, moving on in the queue but keeping " hed " for now") - ;; only increment num-retries when there are no tests runing - (if (eq? 0 (list-ref can-run-more 1)) - (begin - ;; TRY (if (> num-retries 100) ;; first 100 retries are low time cost - ;; TRY (thread-sleep! (+ 2 *global-delta*)) - ;; TRY (thread-sleep! (+ 0.01 *global-delta*))) - (set! num-retries (+ num-retries 1)))) - (if (> num-retries max-retries) - (if (not (null? tal)) - (loop (runs:queue-next-hed tal reg reglen regfull) - (runs:queue-next-tal tal reg reglen regfull) - (runs:queue-next-reg tal reg reglen regfull) - reruns)) - (loop (car newtal)(cdr newtal) reg reruns))) ;; an issue with prereqs not yet met? - ((and (not (null? fails))(eq? testmode 'normal)) - (debug:print-info 1 "test " hed " (mode=" testmode ") has failed prerequisite(s); " - (string-intersperse (map (lambda (t)(conc (db:test-get-testname t) ":" (db:test-get-state t)"/"(db:test-get-status t))) fails) ", ") - ", removing it from to-do list") - (if (not (null? tal)) - (begin - ;; (thread-sleep! *global-delta*) - (loop (runs:queue-next-hed tal reg reglen regfull) - (runs:queue-next-tal tal reg reglen regfull) - (runs:queue-next-reg tal reg reglen regfull) - (cons hed reruns))))) - (else - (debug:print 8 "ERROR: No handler for this condition.") - ;; TRY (thread-sleep! (+ 1 *global-delta*)) - (loop (car newtal)(cdr newtal) reg reruns)))) ;; END OF IF CAN RUN MORE - - ;; if can't run more just loop with next possible test - (begin - (debug:print-info 4 "processing the case with a lambda for items or 'have-procedure. Moving through the queue without dropping " hed) - ;; (thread-sleep! (+ 2 *global-delta*)) - (loop (car newtal)(cdr newtal) reg reruns))))) ;; END OF (or (procedure? items)(eq? items 'have-procedure)) - - ;; this case should not happen, added to help catch any bugs - ((and (list? items) itemdat) - (debug:print 0 "ERROR: Should not have a list of items in a test and the itemspath set - please report this") - (exit 1)) - ((not (null? reruns)) - (let* ((newlst (tests:filter-non-runnable run-id tal test-records)) ;; i.e. not FAIL, WAIVED, INCOMPLETE, PASS, KILLED, - (junked (lset-difference equal? tal newlst))) - (debug:print-info 4 "full drop through, if reruns is less than 100 we will force retry them, reruns=" reruns ", tal=" tal) - (if (< num-retries max-retries) - (set! newlst (append reruns newlst))) - (set! num-retries (+ num-retries 1)) - ;; (thread-sleep! (+ 1 *global-delta*)) - (if (not (null? newlst)) - ;; since reruns have been tacked on to newlst create new reruns from junked - (loop (car newlst)(cdr newlst) reg (delete-duplicates junked))))) - ((not (null? tal)) - (debug:print-info 4 "I'm pretty sure I shouldn't get here.")) - ((not (null? reg)) ;; could we get here with leftovers? - (debug:print-info 0 "Have leftovers!") - (loop (car reg)(cdr reg) '() reruns)) - (else - (debug:print-info 4 "Exiting loop with...\n hed=" hed "\n tal=" tal "\n reruns=" reruns)) - )))) ;; LET* ((test-record - - ;; we get here on "drop through" - loop for next test in queue - ;; FIXME!!!! THIS SHOULD NOT REQUIRE AN EXIT!!!!!!! - - (debug:print-info 1 "All tests launched") - (thread-sleep! 0.5) - ;; FIXME! This harsh exit should not be necessary.... - ;; (if (not *runremote*)(exit)) ;; - #f)) ;; return a #f as a hint that we are done -;; Here we need to check that all the tests remaining to be run are eligible to run -;; and are not blocked by failed - Index: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -26,47 +26,10 @@ (include "key_records.scm") (include "db_records.scm") (include "run_records.scm") (include "test_records.scm") -;; runs:get-runs-by-patt -;; get runs by list of criteria -;; register a test run with the db -;; -;; Use: (db-get-value-by-header (db:get-header runinfo)(db:get-row runinfo)) -;; to extract info from the structure returned -;; -(define (runs:get-runs-by-patt db keys runnamepatt targpatt) ;; test-name) - (let* ((tmp (runs:get-std-run-fields keys '("id" "runname" "state" "status" "owner" "event_time"))) - (keystr (car tmp)) - (header (cadr tmp)) - (res '()) - (key-patt "") - (runwildtype (if (substring-index "%" runnamepatt) "like" "glob")) - (qry-str #f) - (keyvals (keys:target->keyval keys targpatt))) - (for-each (lambda (keyval) - (let* ((key (car keyval)) - (patt (cadr keyval)) - (fulkey (conc ":" key)) - (wildtype (if (substring-index "%" patt) "like" "glob"))) - (if patt - (set! key-patt (conc key-patt " AND " key " " wildtype " '" patt "'")) - (begin - (debug:print 0 "ERROR: searching for runs with no pattern set for " fulkey) - (exit 6))))) - keyvals) - (set! qry-str (conc "SELECT " keystr " FROM runs WHERE runname " runwildtype " ? " key-patt ";")) - (debug:print-info 4 "runs:get-runs-by-patt qry=" qry-str " " runnamepatt) - (sqlite3:for-each-row - (lambda (a . r) - (set! res (cons (list->vector (cons a r)) res))) - db - qry-str - runnamepatt) - (vector header res))) - (define (runs:test-get-full-path test) (let* ((testname (db:test-get-testname test)) (itempath (db:test-get-item-path test))) (conc testname (if (equal? itempath "") "" (conc "(" itempath ")"))))) @@ -130,11 +93,10 @@ (setenv (car varval)(cadr varval))) (configf:get-section runconfig section))) (list "default" target)) (vector target runname testpatt keys keyvals envdat mconfig runconfig serverdat transport db toppath run-id))) - (define (set-megatest-env-vars run-id #!key (inkeys #f)(inrunname #f)(inkeyvals #f)) (let* ((target (or (args:get-arg "-reqtarg") (args:get-arg "-target") (get-environment-variable "MT_TARGET"))) (keys (if inkeys inkeys (cdb:remote-run db:get-keys #f))) @@ -170,19 +132,19 @@ ;; ;; NOTE: We run this server-side!! Do not use this global except in the runs:can-run-more-tests routine ;; (define *last-num-running-tests* 0) (define *runs:can-run-more-tests-count* 0) -(define (runs:shrink-can-run-more-tests-count db) ;; the db is just so we can use cdb:remote-run +(define (runs:shrink-can-run-more-tests-count) ;; the db is a dummy var so we can use cdb:remote-run (set! *runs:can-run-more-tests-count* 0)) ;; (/ *runs:can-run-more-tests-count* 2))) -(define (runs:can-run-more-tests db jobgroup max-concurrent-jobs) +(define (runs:can-run-more-tests jobgroup max-concurrent-jobs) (thread-sleep! (cond ((> *runs:can-run-more-tests-count* 20) 2);; obviously haven't had any work to do for a while (else 0))) - (let* ((num-running (db:get-count-tests-running db)) - (num-running-in-jobgroup (db:get-count-tests-running-in-jobgroup db jobgroup)) + (let* ((num-running (cdb:remote-run db:get-count-tests-running #f)) + (num-running-in-jobgroup (cdb:remote-run db:get-count-tests-running-in-jobgroup #f jobgroup)) (job-group-limit (config-lookup *configdat* "jobgroups" jobgroup))) (if (> (+ num-running num-running-in-jobgroup) 0) (set! *runs:can-run-more-tests-count* (+ *runs:can-run-more-tests-count* 1))) (if (not (eq? *last-num-running-tests* num-running)) (begin @@ -205,33 +167,20 @@ " in " jobgroup " exceeded, will not run " (tests:testqueue-get-testname test-record)) #t) (else #f)))) (list (not can-not-run-more) num-running num-running-in-jobgroup max-concurrent-jobs job-group-limit))))) -;;====================================================================== -;; New methodology. These routines will replace the above in time. For -;; now the code is duplicated. This stuff is initially used in the monitor -;; based code. -;;====================================================================== - - -;; This is a duplicate of run-tests (which has been deprecated). Use this one instead of run tests. -;; keyvals. -;; ;; test-names: Comma separated patterns same as test-patts but used in selection ;; of tests to run. The item portions are not respected. ;; FIXME: error out if /patt specified ;; (define (runs:run-tests target runname test-patts user flags) ;; test-names (common:clear-caches) ;; clear all caches - (let* ((db #f) - (keys (keys:config-get-fields *configdat*)) + (let* ((keys (keys:config-get-fields *configdat*)) (keyvals (keys:target->keyval keys target)) (run-id (cdb:remote-run db:register-run #f keyvals runname "new" "n/a" user)) ;; test-name))) (deferred '()) ;; delay running these since they have a waiton clause - ;; keepgoing is the defacto modality now, will add hit-n-run a bit later - ;; (keepgoing (hash-table-ref/default flags "-keepgoing" #f)) (runconfigf (conc *toppath* "/runconfigs.config")) (required-tests '()) (test-records (make-hash-table)) (all-test-names (tests:get-valid-tests *toppath* "%"))) ;; we need a list of all valid tests to check waiton names @@ -242,13 +191,11 @@ (debug:print 0 "WARNING: You do not have a run config file: " runconfigf)) ;; look up all tests matching the comma separated list of globs in ;; test-patts (using % as wildcard) - (set! test-names (tests:get-valid-tests *toppath* test-patts)) - (set! test-names (delete-duplicates test-names)) - + (set! test-names (delete-duplicates (tests:get-valid-tests *toppath* test-patts))) (debug:print-info 0 "test names " test-names) ;; on the first pass or call to run-tests set FAILS to NOT_STARTED if ;; -keepgoing is specified (if (eq? *passnum* 0) @@ -258,22 +205,22 @@ ;; on test A but test B reached the point on being registered as NOT_STARTED and test ;; A failed for some reason then on re-run using -keepgoing the run can never complete. (cdb:delete-tests-in-state *runremote* run-id "NOT_STARTED") (cdb:remote-run db:set-tests-state-status #f run-id test-names #f "FAIL" "NOT_STARTED" "FAIL"))) - ;; from here on out the db will be opened and closed on every call runs:run-tests-queue - ;; (sqlite3:finalize! db) ;; now add non-directly referenced dependencies (i.e. waiton) + ;;====================================================================== + ;; refactoring this block into tests:get-full-data + ;;====================================================================== (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 (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) (let ((newwaitons (string-split (cond ((procedure? instr) @@ -347,15 +294,418 @@ (if (not (null? required-tests)) (debug:print-info 1 "Adding " required-tests " to the run queue")) ;; NOTE: these are all parent tests, items are not expanded yet. (debug:print-info 4 "test-records=" (hash-table->alist test-records)) (let ((reglen (configf:lookup *configdat* "setup" "runqueue"))) - (if (equal? reglen "classic") - (runs:run-tests-queue-classic run-id runname test-records keyvals flags test-patts required-tests) - (runs:run-tests-queue-new run-id runname test-records keyvals flags test-patts required-tests (any->number reglen)))) + (if (> (length (hash-table-keys test-records)) 0) + (runs:run-tests-queue run-id runname test-records keyvals flags test-patts required-tests (any->number reglen)) + (debug:print-info 0 "No tests to run"))) (debug:print-info 4 "All done by here"))) + +;; loop logic. These are used in runs:run-tests-queue to make it a bit more readable. +;; +;; If reg not full and have items in tal then loop with (car tal)(cdr tal) reg reruns +;; If reg is full (i.e. length >= n +;; loop with (car reg) tal (cdr reg) reruns +;; If tal is empty +;; but have items in reg; loop with (car reg)(cdr reg) '() reruns +;; If reg is empty => all done + +(define (runs:queue-next-hed tal reg n regfull) + (if regfull + (car reg) + (if (null? tal) ;; tal is used up, pop from reg + (car reg) + (car tal)))) + +;; (cond +;; ((and regfull (null? reg)(not (null? tal))) (car tal)) +;; ((and regfull (not (null? reg))) (car reg)) +;; ((and (not regfull)(null? tal)(not (null? reg))) (car reg)) +;; ((and (not regfull)(not (null? tal))) (car tal)) +;; (else +;; (debug:print 0 "ERROR: runs:queue-next-hed, tal=" tal ", reg=" reg ", n=" n ", regfull=" regfull) +;; #f))) + +(define (runs:queue-next-tal tal reg n regfull) + (if regfull + tal + (if (null? tal) ;; must transfer from reg + (cdr reg) + (cdr tal)))) + +(define (runs:queue-next-reg tal reg n regfull) + (if regfull + (cdr reg) + (if (null? tal) ;; if tal is null and reg not full then '() as reg contents moved to tal + '() + reg))) + +(define (runs:expand-items hed tal reg reruns regfull newtal jobgroup max-concurrent-jobs run-id waitons item-path testmode test-record can-run-more items runname tconfig) + (let* ((loop-list (list hed tal reg reruns)) + (prereqs-not-met (mt:get-prereqs-not-met run-id waitons item-path mode: testmode)) + (fails (runs:calc-fails prereqs-not-met)) + (non-completed (runs:calc-not-completed prereqs-not-met))) + (debug:print-info 4 "START OF INNER COND #2 " + "\n can-run-more: " can-run-more + "\n testname: " hed + "\n prereqs-not-met: " (runs:pretty-string prereqs-not-met) + "\n non-completed: " (runs:pretty-string non-completed) + "\n fails: " (runs:pretty-string fails) + "\n testmode: " testmode + "\n (eq? testmode 'toplevel): " (eq? testmode 'toplevel) + "\n (null? non-completed): " (null? non-completed) + "\n reruns: " reruns + "\n items: " items + "\n can-run-more: " can-run-more) + (cond + ;; all prereqs met, fire off the test + ;; or, if it is a 'toplevel test and all prereqs not met are COMPLETED then launch + ((or (null? prereqs-not-met) + (and (eq? testmode 'toplevel) + (null? non-completed))) + (debug:print-info 4 "runs:expand-items: (or (null? prereqs-not-met) (and (eq? testmode 'toplevel)(null? non-completed)))") + (let ((test-name (tests:testqueue-get-testname test-record))) + (setenv "MT_TEST_NAME" test-name) ;; + (setenv "MT_RUNNAME" runname) + (set-megatest-env-vars run-id inrunname: runname) ;; these may be needed by the launching process + (let ((items-list (items:get-items-from-config tconfig))) + (if (list? items-list) + (begin + (tests:testqueue-set-items! test-record items-list) + (list hed tal reg reruns)) + (begin + (debug:print 0 "ERROR: The proc from reading the setup did not yield a list - please report this") + (exit 1)))))) + + ((null? fails) + (debug:print-info 4 "fails is null, moving on in the queue but keeping " hed " for now") + ;; num-retries code was here + ;; we use this opportunity to move contents of reg to tal + (list (car newtal)(append (cdr newtal) reg) '() reruns)) ;; an issue with prereqs not yet met? + + ((and (not (null? fails))(eq? testmode 'normal)) + (debug:print-info 1 "test " hed " (mode=" testmode ") has failed prerequisite(s); " + (string-intersperse (map (lambda (t)(conc (db:test-get-testname t) ":" (db:test-get-state t)"/"(db:test-get-status t))) fails) ", ") + ", removing it from to-do list") + (if (or (not (null? reg))(not (null? tal))) + (list (runs:queue-next-hed tal reg reglen regfull) + (runs:queue-next-tal tal reg reglen regfull) + (runs:queue-next-reg tal reg reglen regfull) + (cons hed reruns)) + #f)) ;; #f flags do not loop + + (else + (debug:print 4 "ERROR: No handler for this condition.") + (list (car newtal)(cdr newtal) reg reruns))))) + +(define (runs:process-expanded-tests hed tal reg reruns reglen regfull test-record runname test-name item-path jobgroup max-concurrent-jobs run-id waitons item-path testmode test-patts required-tests test-registry registry-mutex flags keyvals run-info) + (let* ((run-limits-info (runs:can-run-more-tests jobgroup max-concurrent-jobs)) ;; look at the test jobgroup and tot jobs running + (have-resources (car run-limits-info)) + (num-running (list-ref run-limits-info 1)) + (num-running-in-jobgroup (list-ref run-limits-info 2)) + (max-concurrent-jobs (list-ref run-limits-info 3)) + (job-group-limit (list-ref run-limits-info 4)) + (prereqs-not-met (mt:get-prereqs-not-met run-id waitons item-path mode: testmode)) + (fails (runs:calc-fails prereqs-not-met)) + (non-completed (runs:calc-not-completed prereqs-not-met)) + (loop-list (list hed tal reg reruns))) + (debug:print-info 4 "have-resources: " have-resources " prereqs-not-met: (" + (string-intersperse + (map (lambda (t) + (if (vector? t) + (conc (db:test-get-state t) "/" (db:test-get-status t)) + (conc " WARNING: t is not a vector=" t ))) + prereqs-not-met) ", ") ") fails: " fails) + + ;; Don't know at this time if the test have been launched at some time in the past + ;; i.e. is this a re-launch? + (debug:print-info 4 "run-limits-info = " run-limits-info) + + (cond + + ;; Check item path against item-patts, + ;; + ((not (tests:match test-patts (tests:testqueue-get-testname test-record) item-path required: required-tests)) ;; This test/itempath is not to be run + ;; else the run is stuck, temporarily or permanently + ;; but should check if it is due to lack of resources vs. prerequisites + (debug:print-info 1 "Skipping " (tests:testqueue-get-testname test-record) " " item-path " as it doesn't match " test-patts) + (if (or (not (null? tal))(not (null? reg))) + (list (runs:queue-next-hed tal reg reglen regfull) + (runs:queue-next-tal tal reg reglen regfull) + (runs:queue-next-reg tal reg reglen regfull) + reruns) + #f)) + + ;; Register tests + ;; + ((not (hash-table-ref/default test-registry (runs:make-full-test-name test-name item-path) #f)) + (debug:print-info 4 "Pre-registering test " test-name "/" item-path " to create placeholder" ) + (let ((th (make-thread (lambda () + (mutex-lock! registry-mutex) + (hash-table-set! test-registry (runs:make-full-test-name test-name item-path) 'start) + (mutex-unlock! registry-mutex) + ;; If haven't done it before register a top level test if this is an itemized test + (if (not (eq? (hash-table-ref/default test-registry (runs:make-full-test-name test-name "") #f) 'done)) + (cdb:tests-register-test *runremote* run-id test-name "")) + (cdb:tests-register-test *runremote* run-id test-name item-path) + (mutex-lock! registry-mutex) + (hash-table-set! test-registry (runs:make-full-test-name test-name item-path) 'done) + (mutex-unlock! registry-mutex)) + (conc test-name "/" item-path)))) + (thread-start! th)) + (runs:shrink-can-run-more-tests-count) ;; DELAY TWEAKER (still needed?) + (if (and (null? tal)(null? reg)) + (list hed tal (append reg (list hed)) reruns) + (list (runs:queue-next-hed tal reg reglen regfull) + (runs:queue-next-tal tal reg reglen regfull) + ;; NB// Here we are building reg as we register tests + ;; if regfull we must pop the front item off reg + (if regfull + (append (cdr reg) (list hed)) + (append reg (list hed))) + reruns))) + + ;; At this point hed test registration must be completed. + ;; + ((eq? (hash-table-ref/default test-registry (runs:make-full-test-name test-name item-path) #f) + 'start) + (debug:print-info 0 "Waiting on test registration(s): " + (string-intersperse + (filter (lambda (x) + (eq? (hash-table-ref/default test-registry x #f) 'start)) + (hash-table-keys test-registry)) + ", ")) + (thread-sleep! 0.1) + (list hed tal reg reruns)) + + ;; If no resources are available just kill time and loop again + ;; + ((not have-resources) ;; simply try again after waiting a second + (debug:print-info 1 "no resources to run new tests, waiting ...") + ;; Have gone back and forth on this but db starvation is an issue. + ;; wait one second before looking again to run jobs. + (thread-sleep! 1) + ;; could have done hed tal here but doing car/cdr of newtal to rotate tests + (list (car newtal)(cdr newtal) reg reruns)) + + ;; This is the final stage, everything is in place so launch the test + ;; + ((and have-resources + (or (null? prereqs-not-met) + (and (eq? testmode 'toplevel) + (null? non-completed)))) + (run:test run-id run-info keyvals runname test-record flags #f test-registry) + (hash-table-set! test-registry (runs:make-full-test-name test-name item-path) 'running) + (runs:shrink-can-run-more-tests-count) ;; DELAY TWEAKER (still needed?) + ;; (thread-sleep! *global-delta*) + (if (or (not (null? tal))(not (null? reg))) + (list (runs:queue-next-hed tal reg reglen regfull) + (runs:queue-next-tal tal reg reglen regfull) + (runs:queue-next-reg tal reg reglen regfull) + reruns) + #f)) + + ;; must be we have unmet prerequisites + ;; + (else + (debug:print 4 "FAILS: " fails) + ;; If one or more of the prereqs-not-met are FAIL then we can issue + ;; a message and drop hed from the items to be processed. + (if (null? fails) + (begin + ;; couldn't run, take a breather + (debug:print-info 4 "Shouldn't really get here, race condition? Unable to launch more tests at this moment, killing time ...") + ;; (thread-sleep! (+ 0.01 *global-delta*)) ;; long sleep here - no resources, may as well be patient + ;; we made new tal by sticking hed at the back of the list + (list (car newtal)(cdr newtal) reg reruns)) + ;; the waiton is FAIL so no point in trying to run hed ever again + (if (or (not (null? reg))(not (null? tal))) + (if (vector? hed) + (begin + (debug:print 1 "WARN: Dropping test " (db:test-get-testname hed) "/" (db:test-get-item-path hed) + " from the launch list as it has prerequistes that are FAIL") + (runs:shrink-can-run-more-tests-count) ;; DELAY TWEAKER (still needed?) + ;; (thread-sleep! *global-delta*) + (hash-table-set! test-registry (runs:make-full-test-name test-name item-path) 'removed) + (list (runs:queue-next-hed tal reg reglen regfull) + (runs:queue-next-tal tal reg reglen regfull) + (runs:queue-next-reg tal reg reglen regfull) + (cons hed reruns))) + (begin + (debug:print 1 "WARN: Test not processed correctly. Could be a race condition in your test implementation? " hed) ;; " as it has prerequistes that are FAIL. (NOTE: hed is not a vector)") + (runs:shrink-can-run-more-tests-count) ;; DELAY TWEAKER (still needed?) + (list hed tal reg reruns))))))))) + +;; test-records is a hash table testname:item_path => vector < testname testconfig waitons priority items-info ... > +(define (runs:run-tests-queue run-id runname test-records keyvals flags test-patts required-tests reglen-in) + ;; At this point the list of parent tests is expanded + ;; NB// Should expand items here and then insert into the run queue. + (debug:print 5 "test-records: " test-records ", flags: " (hash-table->alist flags)) + (let ((run-info (cdb:remote-run db:get-run-info #f run-id)) + (tests-info (mt:get-tests-for-run run-id #f '() '())) ;; qryvals: "id,testname,item_path")) + (sorted-test-names (tests:sort-by-priority-and-waiton test-records)) + (test-registry (make-hash-table)) + (registry-mutex (make-mutex)) + (num-retries 0) + (max-retries (config-lookup *configdat* "setup" "maxretries")) + (max-concurrent-jobs (let ((mcj (config-lookup *configdat* "setup" "max_concurrent_jobs"))) + (if (and mcj (string->number mcj)) + (string->number mcj) + 1))) ;; length of the register queue ahead + (reglen (if (number? reglen-in) reglen-in 1))) + + ;; Initialize the test-registery hash with tests that already have a record + ;; convert state to symbol and use that as the hash value + (for-each (lambda (trec) + (let ((id (db:test-get-id trec)) + (tn (db:test-get-testname trec)) + (ip (db:test-get-item-path trec)) + (st (db:test-get-state trec))) + (hash-table-set! test-registry (runs:make-full-test-name tn ip) (string->symbol st)))) + tests-info) + (set! max-retries (if (and max-retries (string->number max-retries))(string->number max-retries) 100)) + + (let loop ((hed (car sorted-test-names)) + (tal (cdr sorted-test-names)) + (reg '()) ;; registered, put these at the head of tal + (reruns '())) + (if (not (null? reruns))(debug:print-info 4 "reruns=" reruns)) + ;; (print "Top of loop, hed=" hed ", tal=" tal " ,reruns=" reruns) + (let* ((test-record (hash-table-ref test-records hed)) + (test-name (tests:testqueue-get-testname test-record)) + (tconfig (tests:testqueue-get-testconfig test-record)) + (jobgroup (config-lookup tconfig "requirements" "jobgroup")) + (testmode (let ((m (config-lookup tconfig "requirements" "mode"))) + (if m (string->symbol m) 'normal))) + (waitons (tests:testqueue-get-waitons test-record)) + (priority (tests:testqueue-get-priority test-record)) + (itemdat (tests:testqueue-get-itemdat test-record)) ;; itemdat can be a string, list or #f + (items (tests:testqueue-get-items test-record)) + (item-path (item-list->path itemdat)) + (tfullname (runs:make-full-test-name test-name item-path)) + (newtal (append tal (list hed))) + (regfull (>= (length reg) reglen))) + + ;; Fast skip of tests that are already "COMPLETED" + ;; + (if (equal? (hash-table-ref/default test-registry tfullname #f) 'COMPLETED) + (begin + (debug:print-info 0 "Skipping COMPLETED test " tfullname) + (if (or (not (null? tal))(not (null? reg))) + (loop (runs:queue-next-hed tal reg reglen regfull) + (runs:queue-next-tal tal reg reglen regfull) + (runs:queue-next-reg tal reg reglen regfull) + reruns)))) + ;; (loop (car tal)(cdr tal) reg reruns)))) + + (debug:print 4 "TOP OF LOOP => " + "test-name: " test-name + "\n test-record " test-record + "\n hed: " hed + "\n itemdat: " itemdat + "\n items: " items + "\n item-path: " item-path + "\n waitons: " waitons + "\n num-retries: " num-retries + "\n tal: " tal + "\n reruns: " reruns + "\n regfull: " regfull + "\n reglen: " reglen + "\n length reg: " (length reg) + "\n reg: " reg) + + ;; check for hed in waitons => this would be circular, remove it and issue an + ;; error + (if (member test-name waitons) + (begin + (debug:print 0 "ERROR: test " test-name " has listed itself as a waiton, please correct this!") + (set! waiton (filter (lambda (x)(not (equal? x hed))) waitons)))) + + (cond + + ;; items is #f then the test is ok to be handed off to launch (but not before) + ;; + ((not items) + (debug:print-info 4 "OUTER COND: (not items)") + (if (and (not (tests:match test-patts (tests:testqueue-get-testname test-record) item-path required: required-tests)) + (not (null? tal))) + (loop (car tal)(cdr tal) reg reruns)) + (let ((loop-list (runs:process-expanded-tests hed tal reg reruns reglen regfull test-record runname test-name item-path jobgroup max-concurrent-jobs run-id waitons item-path testmode test-patts required-tests test-registry registry-mutex flags keyvals run-info))) + (if loop-list (apply loop loop-list)))) + + ;; items processed into a list but not came in as a list been processed + ;; + ((and (list? items) ;; thus we know our items are already calculated + (not itemdat)) ;; and not yet expanded into the list of things to be done + (debug:print-info 4 "OUTER COND: (and (list? items)(not itemdat))") + (if (and (debug:debug-mode 1) ;; (>= *verbosity* 1) + (> (length items) 0) + (> (length (car items)) 0)) + (pp items)) + (for-each + (lambda (my-itemdat) + (let* ((new-test-record (let ((newrec (make-tests:testqueue))) + (vector-copy! test-record newrec) + newrec)) + (my-item-path (item-list->path my-itemdat))) + (if (tests:match test-patts hed my-item-path required: required-tests) ;; (patt-list-match my-item-path item-patts) ;; yes, we want to process this item, NOTE: Should not need this check here! + (let ((newtestname (runs:make-full-test-name hed my-item-path))) ;; test names are unique on testname/item-path + (tests:testqueue-set-items! new-test-record #f) + (tests:testqueue-set-itemdat! new-test-record my-itemdat) + (tests:testqueue-set-item_path! new-test-record my-item-path) + (hash-table-set! test-records newtestname new-test-record) + (set! tal (append tal (list newtestname))))))) ;; since these are itemized create new test names testname/itempath + items) + ;; At this point we have possibly added items to tal but all must be handed off to + ;; INNER COND logic. I think loop without rotating the queue + ;; (loop hed tal reg reruns)) + ;; (let ((newtal (append tal (list hed)))) ;; We should discard hed as it has been expanded into it's items? Yes, but only if this *is* an itemized test + ;; (loop (car newtal)(cdr newtal) reg reruns) + (loop (car tal)(cdr tal) reg reruns)) + + ;; if items is a proc then need to run items:get-items-from-config, get the list and loop + ;; - but only do that if resources exist to kick off the job + ;; EXPAND ITEMS + ((or (procedure? items)(eq? items 'have-procedure)) + (let ((can-run-more (runs:can-run-more-tests jobgroup max-concurrent-jobs))) + (if (and (list? can-run-more) + (car can-run-more)) + (let ((loop-list (runs:expand-items hed tal reg reruns regfull newtal jobgroup max-concurrent-jobs run-id waitons item-path testmode test-record can-run-more items runname tconfig))) + (if loop-list + (apply loop loop-list))) + ;; if can't run more just loop with next possible test + (loop (car newtal)(cdr newtal) reg reruns)))) + + ;; this case should not happen, added to help catch any bugs + ((and (list? items) itemdat) + (debug:print 0 "ERROR: Should not have a list of items in a test and the itemspath set - please report this") + (exit 1)) + ((not (null? reruns)) + (let* ((newlst (tests:filter-non-runnable run-id tal test-records)) ;; i.e. not FAIL, WAIVED, INCOMPLETE, PASS, KILLED, + (junked (lset-difference equal? tal newlst))) + (debug:print-info 4 "full drop through, if reruns is less than 100 we will force retry them, reruns=" reruns ", tal=" tal) + (if (< num-retries max-retries) + (set! newlst (append reruns newlst))) + (set! num-retries (+ num-retries 1)) + ;; (thread-sleep! (+ 1 *global-delta*)) + (if (not (null? newlst)) + ;; since reruns have been tacked on to newlst create new reruns from junked + (loop (car newlst)(cdr newlst) reg (delete-duplicates junked))))) + ((not (null? tal)) + (debug:print-info 4 "I'm pretty sure I shouldn't get here.")) + ((not (null? reg)) ;; could we get here with leftovers? + (debug:print-info 0 "Have leftovers!") + (loop (car reg)(cdr reg) '() reruns)) + (else + (debug:print-info 4 "Exiting loop with...\n hed=" hed "\n tal=" tal "\n reruns=" reruns)) + ))) ;; LET* ((test-record + + ;; we get here on "drop through". All done! + (debug:print-info 1 "All tests launched"))) + (define (runs:calc-fails prereqs-not-met) (filter (lambda (test) (and (vector? test) ;; not (string? test)) (equal? (db:test-get-state test) "COMPLETED") (not (member (db:test-get-status test) @@ -377,38 +727,12 @@ lst)) (define (runs:make-full-test-name testname itempath) (if (equal? itempath "") testname (conc testname "/" itempath))) -(define (runs:queue-next-hed tal reg n regful) - (if regful - (if (null? reg) ;; doesn't make sense, this is probably NOT the problem of the car - (car tal) - (car reg)) - (car tal))) - -(define (runs:queue-next-tal tal reg n regful) - (if regful - tal - (let ((newtal (cdr tal))) - (if (null? newtal) - reg - newtal - )))) - -(define (runs:queue-next-reg tal reg n regful) - (if regful - (cdr reg) - (if (eq? (length tal) 1) - '() - reg))) - -(include "run-tests-queue-classic.scm") -(include "run-tests-queue-new.scm") - ;; parent-test is there as a placeholder for when parent-tests can be run as a setup step -(define (run:test run-id run-info keyvals runname test-record flags parent-test) +(define (run:test run-id run-info keyvals runname test-record flags parent-test test-registry) ;; All these vars might be referenced by the testconfig file reader (let* ((test-name (tests:testqueue-get-testname test-record)) (test-waitons (tests:testqueue-get-waitons test-record)) (test-conf (tests:testqueue-get-testconfig test-record)) (itemdat (tests:testqueue-get-itemdat test-record)) @@ -415,19 +739,23 @@ (test-path (conc *toppath* "/tests/" test-name)) ;; could use tests:get-testconfig here ... (force (hash-table-ref/default flags "-force" #f)) (rerun (hash-table-ref/default flags "-rerun" #f)) (keepgoing (hash-table-ref/default flags "-keepgoing" #f)) (item-path "") - (db #f)) - (debug:print 4 - "test-config: " (hash-table->alist test-conf) - "\n itemdat: " itemdat - ) + (db #f) + (full-test-name #f)) + ;; setting itemdat to a list if it is #f (if (not itemdat)(set! itemdat '())) (set! item-path (item-list->path itemdat)) - (debug:print 2 "Attempting to launch test " test-name (if (equal? item-path "/") "/" item-path)) + (set! full-test-name (runs:make-full-test-name test-name item-path)) + (debug:print-info 4 + "\nTESTNAME: " full-test-name + "\n test-config: " (hash-table->alist test-conf) + "\n itemdat: " itemdat + ) + (debug:print 2 "Attempting to launch test " full-test-name) (setenv "MT_TEST_NAME" test-name) ;; (setenv "MT_RUNNAME" runname) (set-megatest-env-vars run-id inrunname: runname) ;; these may be needed by the launching process (change-directory *toppath*) @@ -436,13 +764,12 @@ (if (not (hash-table-ref/default *test-meta-updated* test-name #f)) (begin (hash-table-set! *test-meta-updated* test-name #t) (runs:update-test_meta test-name test-conf))) - ;; (lambda (itemdat) ;;; ((ripeness "overripe") (temperature "cool") (season "summer")) + ;; itemdat => ((ripeness "overripe") (temperature "cool") (season "summer")) (let* ((new-test-path (string-intersperse (cons test-path (map cadr itemdat)) "/")) - (new-test-name (if (equal? item-path "") test-name (conc test-name "/" item-path))) ;; just need it to be unique (test-id (cdb:remote-run db:get-test-id #f run-id test-name item-path)) (testdat (cdb:get-test-info-by-id *runremote* test-id))) (if (not testdat) (begin ;; ensure that the path exists before registering the test @@ -484,10 +811,11 @@ keepgoing) ;; Require to force re-run for COMPLETED or *anything* + PASS,WARN or CHECK (or (member (test:get-status testdat) '("PASS" "WARN" "CHECK" "SKIP")) (member (test:get-state testdat) '("COMPLETED")))) (debug:print-info 2 "running test " test-name "/" item-path " suppressed as it is " (test:get-state testdat) " and " (test:get-status testdat)) + (hash-table-set! test-registry full-test-name 'COMPLETED) (set! runflag #f)) ;; -rerun and status is one of the specifed, run it ((and rerun (let* ((rerunlst (string-split rerun ",")) (must-rerun (member (test:get-status testdat) rerunlst))) @@ -501,14 +829,14 @@ (set! runflag #f)) ((and (not rerun) (member (test:get-status testdat) '("FAIL" "n/a"))) (set! runflag #t)) (else (set! runflag #f))) - (debug:print 6 "RUNNING => runflag: " runflag " STATE: " (test:get-state testdat) " STATUS: " (test:get-status testdat)) + (debug:print 4 "RUNNING => runflag: " runflag " STATE: " (test:get-state testdat) " STATUS: " (test:get-status testdat)) (if (not runflag) (if (not parent-test) - (debug:print 1 "NOTE: Not starting test " new-test-name " as it is state \"" (test:get-state testdat) + (debug:print 1 "NOTE: Not starting test " full-test-name " as it is state \"" (test:get-state testdat) "\" and status \"" (test:get-status testdat) "\", use -rerun \"" (test:get-status testdat) "\" or -force to override")) ;; NOTE: No longer be checking prerequisites here! Will never get here unless prereqs are ;; already met. ;; This would be a great place to do the process-fork @@ -516,20 +844,20 @@ (begin (print "ERROR: Failed to launch the test. Exiting as soon as possible") (set! *globalexitstatus* 1) ;; (process-signal (current-process-id) signal/kill)))))) ((KILLED) - (debug:print 1 "NOTE: " new-test-name " is already running or was explictly killed, use -force to launch it.")) + (debug:print 1 "NOTE: " full-test-name " is already running or was explictly killed, use -force to launch it.")) ((LAUNCHED REMOTEHOSTSTART RUNNING) (if (> (- (current-seconds)(+ (db:test-get-event_time testdat) (db:test-get-run_duration testdat))) 600) ;; i.e. no update for more than 600 seconds (begin (debug:print 0 "WARNING: Test " test-name " appears to be dead. Forcing it to state INCOMPLETE and status STUCK/DEAD") (tests:test-set-status! test-id "INCOMPLETE" "STUCK/DEAD" "Test is stuck or dead" #f)) (debug:print 2 "NOTE: " test-name " is already running"))) - (else (debug:print 0 "ERROR: Failed to launch test " new-test-name ". Unrecognised state " (test:get-state testdat))))))) + (else (debug:print 0 "ERROR: Failed to launch test " full-test-name ". Unrecognised state " (test:get-state testdat))))))) ;;====================================================================== ;; END OF NEW STUFF ;;====================================================================== @@ -549,11 +877,11 @@ ;; (define (runs:operate-on action target runnamepatt testpatt #!key (state #f)(status #f)(new-state-status #f)) (common:clear-caches) ;; clear all caches (let* ((db #f) (keys (cdb:remote-run db:get-keys db)) - (rundat (cdb:remote-run runs:get-runs-by-patt db keys runnamepatt target)) + (rundat (mt:get-runs-by-patt keys runnamepatt target)) (header (vector-ref rundat 0)) (runs (vector-ref rundat 1)) (states (if state (string-split state ",") '())) (statuses (if status (string-split status ",") '())) (state-status (if (string? new-state-status) (string-split new-state-status ",") '(#f #f)))) @@ -767,11 +1095,11 @@ ;; Lock/unlock runs ;;====================================================================== (define (runs:handle-locking target keys runname lock unlock user) (let* ((db #f) - (rundat (cdb:remote-run runs:get-runs-by-patt db keys runname target)) + (rundat (mt:get-runs-by-patt keys runname target)) (header (vector-ref rundat 0)) (runs (vector-ref rundat 1))) (for-each (lambda (run) (let ((run-id (db:get-value-by-header run header "id"))) (if (or lock @@ -805,11 +1133,11 @@ (cdb:remote-run db:testmeta-update-field #f 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 @@ -1,7 +1,7 @@ ;;====================================================================== -;; Copyright 2006-2012, Matthew Welland. +;; Copyright 2006-2013, Matthew Welland. ;; ;; This program is made available under the GNU GPL version 2.0 or ;; greater. See the accompanying file COPYING for details. ;; ;; This program is distributed WITHOUT ANY WARRANTY; without even the @@ -437,19 +437,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)))) @@ -538,10 +542,95 @@ (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 "\", grep through your testconfigs to find and remove or create the test. Discarding and continuing.") + "")))) + (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) + "")))))) + (if (not config) ;; this is a non-existant test called in a waiton. + (if (null? tal) + test-records + (loop (car tal)(cdr tal))) + (begin + (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-records)))))))) ;;====================================================================== ;; test steps ;;====================================================================== Index: tests/Makefile ================================================================== --- tests/Makefile +++ tests/Makefile @@ -1,8 +1,8 @@ # run some tests -BINPATH=$(PWD)/../bin +BINPATH=$(shell readlink -m $(PWD)/../bin) MEGATEST=$(BINPATH)/megatest PATH := $(BINPATH):$(PATH) RUNNAME := $(shell date +w%V.%u.%H.%M) IPADDR := "-" # Set SERVER to "-server -" @@ -61,11 +61,11 @@ cd fullrun;sleep 0;$(MEGATEST) -runtests % -target $(TARGET) :runname $(RUNNAME)_ab -debug $(DEBUG) $(LOGGING) > ab.log 2> ab.log & cd fullrun;sleep 0;$(MEGATEST) -runtests % -target $(TARGET) :runname $(RUNNAME)_ac -debug $(DEBUG) $(LOGGING) > ac.log 2> ac.log & cd fullrun;sleep 0;$(MEGATEST) -runtests % -target $(TARGET) :runname $(RUNNAME)_ad -debug $(DEBUG) $(LOGGING) > ad.log 2> ad.log & # cd fullrun;sleep 0;$(MEGATEST) -runtests % -target $(TARGET) :runname $(RUNNAME)_ae -debug $(DEBUG) $(LOGGING) > ae.log 2> ae.log & # cd fullrun;sleep 0;$(MEGATEST) -runtests % -target $(TARGET) :runname $(RUNNAME)_af -debug $(DEBUG) $(LOGGING) > af.log 2> af.log & - cd fullrun;sleep 10;$(MEGATEST) -run-wait -target $(TARGET) :runname % -testpatt % :state RUNNING,LAUNCHED;echo ALL DONE + cd fullrun;sleep 10;$(MEGATEST) -run-wait -target $(TARGET) :runname % -testpatt % :state RUNNING,LAUNCHED,NOT_STARTED,REMOTEHOSTSTART;echo ALL DONE test6: fullprep cd fullrun;$(MEGATEST) -runtests runfirst -testpatt %/1 -reqtarg ubuntu/nfs/none :runname $(RUNNAME)_itempatt -v cd fullrun;$(MEGATEST) -runtests runfirst -testpatt %blahha% -reqtarg ubuntu/nfs/none :runname $(RUNNAME)_itempatt -debug 10 cd fullrun;$(MEGATEST) -rollup :runname newrun -target ubuntu/nfs/none -debug 10 @@ -82,10 +82,44 @@ $(MEGATEST) -runtests % -target a/d :runname c;$(MEGATEST) -list-runs %|egrep ^Run:) > test7.log 2> test7.log logpro test7.logpro test7.html < test7.log @echo @echo Run \"firefox test7.html\" to see the results. +# This one failed with v1.55 +test8a : + cd fullrun;$(MEGATEST) -runtests priority_10_waiton_1 -target ubuntu/nfs/none :runname $(RUNNAME)_waiton_single + +test8 : test8a + cd fullrun;$(MEGATEST) -runtests lineitem_fail 1 -target ubuntu/nfs/none :runname $(RUNNAME)_singletest + cd fullrun;$(MEGATEST) -runtests runfirst/fall 1 -target ubuntu/nfs/none :runname $(RUNNAME)_singleitem + cd fullrun;$(MEGATEST) -runtests test_mt_vars/2 -target ubuntu/nfs/none :runname $(RUNNAME)_singleitem_waiton + +# Some simple checks for bootstrapping and run loop logic + +test9 : minsetup test9a test9b test9c + +test9a : + @echo Run super-simple mintest e, no waitons. + cd mintest;megatest -runtests e -target $(VER) :runname `date +%H.%M.%S` -debug $(DEBUG) + +test9b : + @echo Run simple mintest d with one waiton c + cd mintest;megatest -runtests d -target $(VER) :runname `date +%H.%M.%S` -debug $(DEBUG) + +test9c : + @echo Run mintest a with full waiton chain a -> b -> c -> d -> e + cd mintest;megatest -runtests a -target $(VER) :runname `date +%H.%M.%S` -debug $(DEBUG) + + +minsetup : + cd ..;make && make install + mkdir -p mintest/{runs,links} + cd mintest;megatest -stop-server 0 + cd mintest;megatest -server - -debug $(DEBUG) > server.log 2> server.log & + sleep 3 + cd mintest;dashboard -rows 20 & + cleanprep : ../*.scm Makefile */*.config mkdir -p fullrun/tmp/mt_runs fullrun/tmp/mt_links cd ..;make;make install rm -f */logging.db touch cleanprep @@ -110,9 +144,9 @@ hardkill : kill sleep 5;killall -v mtest main.sh dboard -9 listservers : - cd fullrun;$(MEGATEST) -listservers + cd fullrun;$(MEGATEST) -list-servers runforever : while(ls); do runname=`date +%F-%R:%S`;(cd fullrun;$(MEGATEST) -runall -target ubuntu/nfs/none :runname $$runname;/home/matt/data/megatest/megatest -runall -target ubuntu/nfs/none :runname $$runname;/home/matt/data/megatest/megatest -runall -target ubuntu/nfs/none :runname $$runname);done Index: tests/fullrun/megatest.config ================================================================== --- tests/fullrun/megatest.config +++ tests/fullrun/megatest.config @@ -16,11 +16,11 @@ # launchwait yes # If set to "default" the old code is used. Otherwise defaults to 200 or uses # numeric value given. # -# runqueue 2 +runqueue 20 # It is possible (but not recommended) to override the rsync command used # to populate the test directories. For test development the following # example can be useful # ADDED tests/mintest/megatest.config Index: tests/mintest/megatest.config ================================================================== --- /dev/null +++ tests/mintest/megatest.config @@ -0,0 +1,16 @@ +[fields] +X TEXT + +[setup] +max_concurrent_jobs 50 +linktree #{getenv PWD}/linktree + +[server] +port 8090 + +[jobtools] +useshell yes +launcher nbfind + +[disks] +disk0 #{getenv PWD}/runs ADDED tests/mintest/runconfigs.config Index: tests/mintest/runconfigs.config ================================================================== --- /dev/null +++ tests/mintest/runconfigs.config @@ -0,0 +1,6 @@ +[default] +ALLTESTS see this variable + +# Your variables here are grouped by targets [SYSTEM/RELEASE] +[a] +ANOTHERVAR only defined if target is "a" ADDED tests/mintest/tests/a/testconfig Index: tests/mintest/tests/a/testconfig ================================================================== --- /dev/null +++ tests/mintest/tests/a/testconfig @@ -0,0 +1,6 @@ +# Add steps here. Format is "stepname script" +[ezsteps] +step1 echo SUCCESS + +[requirements] +waiton b ADDED tests/mintest/tests/b/testconfig Index: tests/mintest/tests/b/testconfig ================================================================== --- /dev/null +++ tests/mintest/tests/b/testconfig @@ -0,0 +1,6 @@ +# Add steps here. Format is "stepname script" +[ezsteps] +step1 echo SUCCESS + +[requirements] +waiton c ADDED tests/mintest/tests/c/testconfig Index: tests/mintest/tests/c/testconfig ================================================================== --- /dev/null +++ tests/mintest/tests/c/testconfig @@ -0,0 +1,6 @@ +# Add steps here. Format is "stepname script" +[ezsteps] +step1 echo SUCCESS + +[requirements] +waiton d ADDED tests/mintest/tests/d/testconfig Index: tests/mintest/tests/d/testconfig ================================================================== --- /dev/null +++ tests/mintest/tests/d/testconfig @@ -0,0 +1,6 @@ +# Add steps here. Format is "stepname script" +[ezsteps] +step1 echo SUCCESS + +[requirements] +waiton e ADDED tests/mintest/tests/e/testconfig Index: tests/mintest/tests/e/testconfig ================================================================== --- /dev/null +++ tests/mintest/tests/e/testconfig @@ -0,0 +1,4 @@ +# Add steps here. Format is "stepname script" +[ezsteps] +step1 echo SUCCESS + ADDED tests/mintest/tests/f/testconfig Index: tests/mintest/tests/f/testconfig ================================================================== --- /dev/null +++ tests/mintest/tests/f/testconfig @@ -0,0 +1,6 @@ +# Add steps here. Format is "stepname script" +[ezsteps] +step1 echo SUCCESS + +[requirements] +waiton b ADDED tests/mintest/tests/g/testconfig Index: tests/mintest/tests/g/testconfig ================================================================== --- /dev/null +++ tests/mintest/tests/g/testconfig @@ -0,0 +1,6 @@ +# Add steps here. Format is "stepname script" +[ezsteps] +step1 echo SUCCESS + +[requirements] +waiton b ADDED tests/mintest/tests/h/testconfig Index: tests/mintest/tests/h/testconfig ================================================================== --- /dev/null +++ tests/mintest/tests/h/testconfig @@ -0,0 +1,6 @@ +# Add steps here. Format is "stepname script" +[ezsteps] +step1 echo SUCCESS + +[requirements] +waiton b ADDED tests/mintest/tests/i/testconfig Index: tests/mintest/tests/i/testconfig ================================================================== --- /dev/null +++ tests/mintest/tests/i/testconfig @@ -0,0 +1,6 @@ +# Add steps here. Format is "stepname script" +[ezsteps] +step1 echo SUCCESS + +[requirements] +waiton b ADDED tests/mintest/tests/j/testconfig Index: tests/mintest/tests/j/testconfig ================================================================== --- /dev/null +++ tests/mintest/tests/j/testconfig @@ -0,0 +1,6 @@ +# Add steps here. Format is "stepname script" +[ezsteps] +step1 echo SUCCESS + +[requirements] +waiton b ADDED tests/mintest/tests/k/testconfig Index: tests/mintest/tests/k/testconfig ================================================================== --- /dev/null +++ tests/mintest/tests/k/testconfig @@ -0,0 +1,6 @@ +# Add steps here. Format is "stepname script" +[ezsteps] +step1 echo SUCCESS + +[requirements] +waiton b ADDED tests/mintest/tests/l/testconfig Index: tests/mintest/tests/l/testconfig ================================================================== --- /dev/null +++ tests/mintest/tests/l/testconfig @@ -0,0 +1,6 @@ +# Add steps here. Format is "stepname script" +[ezsteps] +step1 echo SUCCESS + +[requirements] +waiton b Index: tests/tests.scm ================================================================== --- tests/tests.scm +++ tests/tests.scm @@ -83,13 +83,13 @@ (test "server-register, get-best-server" #t (let ((res #f)) (open-run-close tasks:server-register tasks:open-db 1 "bob" 1234 100 'live 'http) (set! res (open-run-close tasks:get-best-server tasks:open-db)) (number? (vector-ref res 3)))) -(test "de-register server" #f (let ((res #f)) +(test "de-register server" #t (let ((res #f)) (open-run-close tasks:server-deregister tasks:open-db "bob" port: 1234) - (open-run-close tasks:get-best-server tasks:open-db))) + (vector? (open-run-close tasks:get-best-server tasks:open-db)))) (define server-pid #f) (test "launch server" #t (let ((pid (process-fork (lambda () ;; (daemon:ize) (server:launch 'http)))))