Index: Makefile ================================================================== --- Makefile +++ Makefile @@ -1,7 +1,8 @@ PREFIX=. +CSCOPTS= SRCFILES = common.scm items.scm launch.scm \ ods.scm runconfig.scm server.scm configf.scm \ db.scm keys.scm margs.scm megatest-version.scm \ process.scm runs.scm tasks.scm tests.scm @@ -14,26 +15,26 @@ HELPERS=$(addprefix $(PREFIX)/bin/,mt_laststep mt_runstep mt_ezstep) all : megatest dboard megatest: $(OFILES) megatest.o - csc $(OFILES) megatest.o -o megatest + csc $(CSCOPTS) $(OFILES) megatest.o -o megatest dboard : $(OFILES) $(GOFILES) csc $(OFILES) $(GOFILES) -o dboard # Special dependencies for the includes -db.o launch.o runs.o dashboard-tests.o dashboard-guimonitor.o monitor.o dashboard.o megatest.o : db_records.scm -runs.o dashboard.o dashboard-tests.o : run_records.scm -keys.o db.o runs.o launch.o megatest.o : key_records.scm -tasks.o dashboard-tasks.o : task_records.scm +tests.o db.o launch.o runs.o dashboard-tests.o dashboard-guimonitor.o monitor.o dashboard.o megatest.o : db_records.scm +tests.o runs.o dashboard.o dashboard-tests.o : run_records.scm +db.o ezsteps.o keys.o launch.o megatest.o monitor.o runs-for-ref.o runs.o tests.o : key_records.scm +tests.o tasks.o dashboard-tasks.o : task_records.scm runs.o : old-runs.scm test_records.scm $(OFILES) $(GOFILES) : common_records.scm %.o : %.scm - csc -c $< + csc $(CSCOPTS) -c $< $(PREFIX)/bin/megatest : megatest @echo Installing to PREFIX=$(PREFIX) cp megatest $(PREFIX)/bin/megatest Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -720,12 +720,13 @@ ;; the new prereqs calculation, looks also at itempath if specified ;; all prereqs must be met: ;; if prereq test with itempath='' is COMPLETED and PASS, WARN, CHECK, or WAIVED then prereq is met ;; if prereq test with itempath=ref-item-path and COMPLETED with PASS, WARN, CHECK, or WAIVED then prereq is met -(define (db:get-prereqs-not-met db run-id waiton ref-item-path) - (if (null? waiton) +(define (db:get-prereqs-not-met db run-id waitons ref-item-path) + (if (or (not waitons) + (null? waitons)) '() (let* ((unmet-pre-reqs '()) (result '())) (for-each (lambda (waitontest-name) @@ -748,21 +749,21 @@ (cond ;; case 1, non-item (parent test) is ((and (equal? item-path "") ;; this is the parent test is-completed is-ok) - (set! waiton-met #t)) + (set! parent-waiton-met #t)) ((and same-itempath is-completed is-ok) (set! item-waiton-met #t))))) tests) - (if (not (or waiton-met item-waiton-met)) + (if (not (or parent-waiton-met item-waiton-met)) (set! result (cons waitontest-name result))) ;; if the test is not found then clearly the waiton is not met... (if (not ever-seen)(set! result (cons waitontest-name result))))) - waiton) + waitons) (delete-duplicates result)))) ;;====================================================================== ;; Extract ods file from the db ;;====================================================================== Index: key_records.scm ================================================================== --- key_records.scm +++ key_records.scm @@ -19,7 +19,9 @@ (string-join (map (lambda (k)(conc (key:get-fieldname k) " " (key:get-fieldtype k))) (append keys additional)) ",")) (define-inline (item-list->path itemdat) - (string-intersperse (map cadr itemdat) "/")) + (if (list? itemdat) + (string-intersperse (map cadr itemdat) "/") + "")) Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -325,14 +325,25 @@ (if (args:get-arg "-runall") (general-run-call "-runall" "run all tests" (lambda (db keys keynames keyvallst) - (let* ((test-names (get-all-legal-tests))) ;; "PROD" is ignored for now - (debug:print 1 "INFO: Attempting to start the following tests...") - (debug:print 1 " " (string-intersperse test-names ",")) - (run-tests db test-names))))) + (let* (;; (test-names (get-all-legal-tests))) ;; "PROD" is ignored for now + (runname (args:get-arg ":runname")) + (target (args:get-arg "-target"))) + (if (not target) + (begin + (debug:print 0 "ERROR: -target is a required parameter") + (exit 0))) + (runs:run-tests db + target + runname + (args:get-arg "-testpatt") + (args:get-arg "-itempatt") + user + (make-hash-table)))))) +;; (run-tests db test-names))))) ;;====================================================================== ;; Rollup into a run ;;====================================================================== (if (args:get-arg "-rollup") Index: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -190,11 +190,11 @@ (set! tests (filter (lambda (test)(file-exists? (conc test "/testconfig"))) tests)) (set! test-names (append test-names (map (lambda (testp) (last (string-split testp "/"))) tests))))) - (string-split test-patts ",")) + (if test-patts (string-split test-patts ",")(list "%"))) ;; now remove duplicates (set! test-names (delete-duplicates test-names)) (debug:print 0 "INFO: test names " test-names) @@ -217,11 +217,19 @@ (let* ((config (test:get-testconfig hed 'return-procs)) (waitons (string-split (let ((w (config-lookup config "requirements" "waiton"))) (if w w ""))))) ;; (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 config waitons (config-lookup config "requirements" "priority") #f))) + (hash-table-set! test-records + hed (vector hed ;; 0 + config ;; 1 + waitons ;; 2 + (config-lookup config "requirements" "priority") + #f ;; 4 + #f ;; 5 + #f ;; spare + ))) (for-each (lambda (waiton) (if (and waiton (not (member waiton test-names))) (begin (set! required-tests (cons waiton required-tests)) @@ -232,114 +240,121 @@ (loop (car remtests)(cdr remtests))))))) (if (not (null? required-tests)) (debug:print 1 "INFO: Adding " required-tests " to the run queue")) ;; NOTE: these are all parent tests, items are not expanded yet. - (runs:run-tests-queue test-records keyvallist))) + (runs:run-tests-queue db run-id runname test-records keyvallst flags))) -(define (runs:run-tests-queue test-records keyvallist) +(define (runs:run-tests-queue db run-id runname test-records keyvallst flags) ;; At this point the list of parent tests is expanded ;; NB// Should expand items here and then insert into the run queue. - (let ((sorted-testnames (tests:sort-by-priority-and-waiton test-records))) - (let loop (; (numtimes 0) ;; shouldn't need this - (hed (car sorted-test-names)) - (tal (cdr sorted-test-names))) - (let* ((test-record (hash-table-ref test-records hed)) - (tconfig (tests:testqueue-get-testconfig test-record)) - (waitons (tests:testqueue-get-waitons test-record)) - (priority (tests:testqueue-get-priority test-record)) - (itemdat (tests:testqueue-get-itemdat test-record)) - (items (tests:testqueue-get-items test-record)) - (item-path (item-list->path itemdat))) - (debug:print 0 "WHERE TO DO: (items:get-items-from-config config)") - (cond - ((not items) ;; when false the test is ok to be handed off to launch - (let ((have-resources (runs:can-run-more-tests db test-record)) ;; look at the test jobgroup and tot jobs running - (prereqs-not-met (db:get-prereqs-not-met db run-id waiton item-path))) - (if (and have-resources - (null? prereqs-not-met)) - ;; no loop - drop though and use the loop at the bottom - (run:test db run-id runname keyvallst test-record flags) - ;; else the run is stuck, temporarily or permanently - (let ((newtal (append tal (list hed)))) - ;; couldn't run, take a breather - (thread-sleep! 1) - (loop (car tal)(cdr tal)))))) - - ;; 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 (>= *verbosity* 1)(pp items)) - ;; (if (>= *verbosity* 5) - ;; (begin - ;; (print "items: ") (pp (item-assoc->item-list items)) - ;; (print "itemstable: ")(pp (item-table->item-list itemstable)))) - (for-each - (lambda (my-itemdat) - (let* ((new-test-record (vector-copy! test-record (make-tests:testqueue))) - (my-item-path (item-list->path my-itemdat)) - (item-matches (if item-patts ;; here we are filtering for matches with -itempatt - (let ((res #f)) ;; look through all the item-patts if defined, format is patt1,patt2,patt3 ... wildcard is % - (for-each - (lambda (patt) - (if (string-search (glob->regexp - (string-translate patt "%" "*")) - item-path) - (set! res #t))) - (string-split item-patts ",")) - res) - #t))) - (if item-matches ;; yes, we want to process this item - (begin - (tests:testqueue-set-items! new-test-record #f) - (tests:testqueue-set-itemdat! new-test-record my-itemdat) - (set! tal (cons (conc hed "/" my-item-path) tal)))))) ;; since these are itemized create new test names testname/itempath - items) - (loop (car tal)(cdr tal))) - - ;; if items is a proc then need to evaluate, get the list and loop - but only do that if - ;; resources exist to kick off the job - ((procedure? items) - (if (runs:can-run-more-tests db test-record) - (let ((items-list (items))) - - (if (list? items-list) - (begin - (tests:testqueue-set-items test-record items-list) - (loop hed tal)) - (begin - (debug:print 0 "ERROR: The proc from reading the setup did not yield a list - please report this") - (exit 1)))) - (let ((newtal (append tal (list hed)))) - ;; if can't run more tests, lets take a breather - (thread-sleep! 1) - (loop (car newtal)(cdr newtal))))) - - ;; 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))) - - ;; we get here on "drop through" - loop for next test in queue - (if (null? tal) - (debug:print 1 "INFO: All tests launched") - (loop (car tal)(cdr tal))))))) + (debug:print 5 "test-records: " test-records ", keyvallst: " keyvallst) + (let ((sorted-test-names (tests:sort-by-priority-and-waiton test-records))) + (let loop (; (numtimes 0) ;; shouldn't need this + (hed (car sorted-test-names)) + (tal (cdr sorted-test-names))) + (let* ((test-record (hash-table-ref test-records hed)) + (tconfig (tests:testqueue-get-testconfig test-record)) + (waitons (tests:testqueue-get-waitons test-record)) + (priority (tests:testqueue-get-priority test-record)) + (itemdat (tests:testqueue-get-itemdat test-record)) + (items (tests:testqueue-get-items test-record)) + (item-path (item-list->path itemdat))) + (debug:print 0 "WHERE TO DO: (items:get-items-from-config config)") + (cond + ((not items) ;; when false the test is ok to be handed off to launch + (let ((have-resources (runs:can-run-more-tests db test-record)) ;; look at the test jobgroup and tot jobs running + (prereqs-not-met (db:get-prereqs-not-met db run-id waitons item-path))) + (if (and have-resources + (null? prereqs-not-met)) + ;; no loop - drop though and use the loop at the bottom + (run:test db run-id runname keyvallst test-record flags) + ;; else the run is stuck, temporarily or permanently + (let ((newtal (append tal (list hed)))) + ;; couldn't run, take a breather + (thread-sleep! 1) + (loop (car tal)(cdr tal)))))) + + ;; 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 (>= *verbosity* 1)(pp items)) + ;; (if (>= *verbosity* 5) + ;; (begin + ;; (print "items: ") (pp (item-assoc->item-list items)) + ;; (print "itemstable: ")(pp (item-table->item-list itemstable)))) + (for-each + (lambda (my-itemdat) + (let* ((new-test-record (vector-copy! test-record (make-tests:testqueue))) + (my-item-path (item-list->path my-itemdat)) + (item-matches (if item-patts ;; here we are filtering for matches with -itempatt + (let ((res #f)) ;; look through all the item-patts if defined, format is patt1,patt2,patt3 ... wildcard is % + (for-each + (lambda (patt) + (if (string-search (glob->regexp + (string-translate patt "%" "*")) + item-path) + (set! res #t))) + (string-split item-patts ",")) + res) + #t))) + (if item-matches ;; yes, we want to process this item + (begin + (tests:testqueue-set-items! new-test-record #f) + (tests:testqueue-set-itemdat! new-test-record my-itemdat) + (set! tal (cons (conc hed "/" my-item-path) tal)))))) ;; since these are itemized create new test names testname/itempath + items) + (loop (car tal)(cdr tal))) + + ;; if items is a proc then need to evaluate, get the list and loop - but only do that if + ;; resources exist to kick off the job + ((procedure? items) + (if (runs:can-run-more-tests db test-record) + (let ((items-list (items))) + + (if (list? items-list) + (begin + (tests:testqueue-set-items test-record items-list) + (loop hed tal)) + (begin + (debug:print 0 "ERROR: The proc from reading the setup did not yield a list - please report this") + (exit 1)))) + (let ((newtal (append tal (list hed)))) + ;; if can't run more tests, lets take a breather + (thread-sleep! 1) + (loop (car newtal)(cdr newtal))))) + + ;; 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))) + + ;; we get here on "drop through" - loop for next test in queue + (if (null? tal) + (debug:print 1 "INFO: All tests launched") + (loop (car tal)(cdr tal))))))) (define (run:test db run-id runname keyvallst test-record flags) - (debug:print 1 "Launching test " test-name) ;; All these vars might be referenced by the testconfig file reader - (setenv "MT_TEST_NAME" test-name) ;; - (setenv "MT_RUNNAME" runname) - (set-megatest-env-vars db run-id) ;; these may be needed by the launching process - (change-directory *toppath*) (let* ((test-name (tests:testqueue-get-testname test-record)) (test-path (conc *toppath* "/tests/" test-name)) ;; could use test:get-testconfig here ... (test-conf (tests:testqueue-get-testconfig test-record)) (itemdat (tests:testqueue-get-itemdat test-record)) (force (hash-table-ref/default flags "-force" #f)) (rerun (hash-table-ref/default flags "-rerun" #f)) (keepgoing (hash-table-ref/default flags "-keepgoing" #f))) + (debug:print 1 "Launching test " test-name) + (debug:print 5 + "test-config: " (hash-table->alist test-conf) + "\n itemdat: " itemdat + ) + ;; setting itemdat to a list if it is #f + (if (not itemdat)(set! itemdat '())) + (setenv "MT_TEST_NAME" test-name) ;; + (setenv "MT_RUNNAME" runname) + (set-megatest-env-vars db run-id) ;; these may be needed by the launching process + (change-directory *toppath*) ;; Here is where the test_meta table is best updated (runs:update-test_meta db test-name test-conf) ;; (lambda (itemdat) ;;; ((ripeness "overripe") (temperature "cool") (season "summer")) @@ -348,11 +363,10 @@ (new-test-name (if (equal? item-path "") test-name (conc test-name "/" item-path))) ;; just need it to be unique (testdat #f) (test-info (db:get-test-info db run-id test-name item-path))) (if (not test-info)(register-test db run-id test-name item-path)) (change-directory test-path) - (debug:print 4 "run-id: " run-id " test-name: " test-name " item-path: " item-path " testdat: " (test:get-status testdat) " test-state: " (test:get-state testdat)) (case (if force ;; (args:get-arg "-force") 'NOT_STARTED (if testdat (string->symbol (test:get-state testdat)) 'failed-to-insert)) @@ -387,11 +401,11 @@ (debug:print 6 "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 \"COMPLETED\" and status \"" (test:get-status testdat) "\", use -force to override")) (let* ((get-prereqs-cmd (lambda () - (db-get-prereqs-not-met db run-id waiton))) ;; check before running .... + (db-get-prereqs-not-met db run-id waitons))) ;; check before running .... (launch-cmd (lambda () (launch-test db run-id runname test-conf keyvallst test-name test-path itemdat flags))) (testrundat (list get-prereqs-cmd launch-cmd))) (if (or force (let ((preqs-not-yet-met ((car testrundat)))) @@ -567,10 +581,11 @@ (for-each (lambda (key) (let* ((idx (cadr key)) (fld (car key)) (val (config-lookup test-conf "test_meta" fld))) + ;; (debug:print 5 "idx: " idx " fld: " fld " val: " val) (if (and val (not (equal? (vector-ref currrecord idx) val))) (begin (print "Updating " test-name " " fld " to " val) (db:testmeta-update-field db test-name fld val))))) '(("author" 2)("owner" 3)("description" 4)("reviewed" 5)("tags" 9))))) Index: tests.scm ================================================================== --- tests.scm +++ tests.scm @@ -9,10 +9,11 @@ (include "common_records.scm") (include "key_records.scm") (include "db_records.scm") (include "run_records.scm") +(include "test_records.scm") (define (register-test db run-id test-name item-path) (let ((item-paths (if (equal? item-path "") (list item-path) @@ -333,18 +334,33 @@ (hash-table-keys test-records) ;; avoid dealing with deleted tests, look at the hash table (lambda (a b) (let* ((a-record (hash-table-ref test-records a)) (b-record (hash-table-ref test-records b)) (a-waitons (tests:testqueue-get-waitons a-record)) - (b-waitons (tests:testqueue-get-waitons a-record)) - (a-priority (mungepriority (config-lookup tconf-a "requirements" "priority"))) - (b-priority (mungepriority (config-lookup tconf-b "requirements" "priority")))) + (b-waitons (tests:testqueue-get-waitons b-record)) + (a-config (tests:testqueue-get-testconfig a-record)) + (b-config (tests:testqueue-get-testconfig b-record)) + (a-raw-pri (config-lookup a-config "requirements" "priority")) + (b-raw-pri (config-lookup b-config "requirements" "priority")) + (a-priority (mungepriority a-raw-pri)) + (b-priority (mungepriority b-raw-pri))) + ;; (debug:print 5 "sort-by-priority-and-waiton, a: " a " b: " b + ;; "\n a-record: " a-record + ;; "\n b-record: " b-record + ;; "\n a-waitons: " a-waitons + ;; "\n b-waitons: " b-waitons + ;; "\n a-config: " (hash-table->alist a-config) + ;; "\n b-config: " (hash-table->alist b-config) + ;; "\n a-raw-pri: " a-raw-pri + ;; "\n b-raw-pri: " b-raw-pri + ;; "\n a-priority: " a-priority + ;; "\n b-priority: " b-priority) (tests:testqueue-set-priority! a-record a-priority) (tests:testqueue-set-priority! b-record b-priority) - (if (and a-waiton (member? (tests:testqueue-get-testname b) a-waitons)) + (if (and a-waitons (member (tests:testqueue-get-testname b-record) a-waitons)) #f ;; cannot have a which is waiting on b happening before b - (if (and b-waiton (member? (tests:testqueue-get-testname a) b-waitons)) + (if (and b-waitons (member (tests:testqueue-get-testname a-record) b-waitons)) #t ;; this is the correct order, b is waiting on a and b is before a (if (> a-priority b-priority) #t ;; if a is a higher priority than b then we are good to go #f))))))))