Index: Makefile ================================================================== --- Makefile +++ Makefile @@ -104,13 +104,13 @@ $(PREFIX)/bin/loadrunner : utils/loadrunner $(INSTALL) $< $@ chmod a+x $@ -$(PREFIX)/bin/refdb : refdb - $(INSTALL) $< $@ - chmod a+x $@ +# $(PREFIX)/bin/refdb : refdb +# $(INSTALL) $< $@ +# chmod a+x $@ deploytarg/nbfake : utils/nbfake $(INSTALL) $< $@ chmod a+x $@ @@ -125,11 +125,11 @@ chmod a+x $(PREFIX)/bin/dashboard $(INSTALL) dboard $(PREFIX)/bin/.$(ARCHSTR)/dboard install : $(PREFIX)/bin/.$(ARCHSTR) $(PREFIX)/bin/.$(ARCHSTR)/mtest $(PREFIX)/bin/megatest \ $(PREFIX)/bin/.$(ARCHSTR)/dboard $(PREFIX)/bin/dashboard $(HELPERS) $(PREFIX)/bin/nbfake \ - $(PREFIX)/bin/nbfind $(PREFIX)/bin/loadrunner $(PREFIX)/bin/refdb $(PREFIX)/bin/mt_xterm \ + $(PREFIX)/bin/nbfind $(PREFIX)/bin/loadrunner $(PREFIX)/bin/mt_xterm \ $(PREFIX)/bin/newdashboard $(PREFIX)/bin/.$(ARCHSTR) : mkdir -p $(PREFIX)/bin/.$(ARCHSTR) Index: api.scm ================================================================== --- api.scm +++ api.scm @@ -44,10 +44,11 @@ get-all-run-ids get-prev-run-ids get-run-ids-matching-target get-runs-by-patt get-steps-data + get-steps-for-test login testmeta-get-record have-incompletes? synchash-get )) @@ -210,10 +211,11 @@ ((get-runs-by-patt) (apply db:get-runs-by-patt dbstruct params)) ((get-run-name-from-id) (apply db:get-run-name-from-id dbstruct params)) ;; STEPS ((get-steps-data) (apply db:get-steps-data dbstruct params)) + ((get-steps-for-test) (apply db:get-steps-for-test dbstruct params)) ;; MISC ((have-incompletes?) (apply db:have-incompletes? dbstruct params)) ((login) (apply db:login dbstruct params)) ((general-call) (let ((stmtname (car params)) Index: db_records.scm ================================================================== --- db_records.scm +++ db_records.scm @@ -89,10 +89,14 @@ ;; (define-inline (db:test-get-pass_count vec) (vector-ref vec 15)) ;; (define-inline (db:test-get-fail_count vec) (vector-ref vec 16)) (define-inline (db:test-get-fullname vec) (conc (db:test-get-testname vec) "/" (db:test-get-item-path vec))) +;; replace runs:make-full-test-name with this routine +(define (db:test-make-full-name testname itempath) + (if (equal? itempath "") testname (conc testname "/" itempath))) + (define-inline (db:test-get-first_err vec) (printable (vector-ref vec 15))) (define-inline (db:test-get-first_warn vec) (printable (vector-ref vec 16))) (define-inline (db:test-set-cpuload! vec val)(vector-set! vec 7 val)) (define-inline (db:test-set-diskfree! vec val)(vector-set! vec 8 val)) @@ -198,10 +202,12 @@ (define-inline (tdb:steps-table-get-stepname vec) (vector-ref vec 0)) (define-inline (tdb:steps-table-get-start vec) (vector-ref vec 1)) (define-inline (tdb:steps-table-get-end vec) (vector-ref vec 2)) (define-inline (tdb:steps-table-get-status vec) (vector-ref vec 3)) (define-inline (tdb:steps-table-get-runtime vec) (vector-ref vec 4)) +(define-inline (tdb:steps-table-get-log-file vec) (vector-ref vec 5)) + (define-inline (tdb:step-stable-set-stepname! vec val)(vector-set! vec 0 val)) (define-inline (tdb:step-stable-set-start! vec val)(vector-set! vec 1 val)) (define-inline (tdb:step-stable-set-end! vec val)(vector-set! vec 2 val)) (define-inline (tdb:step-stable-set-status! vec val)(vector-set! vec 3 val)) (define-inline (tdb:step-stable-set-runtime! vec val)(vector-set! vec 4 val)) Index: dcommon.scm ================================================================== --- dcommon.scm +++ dcommon.scm @@ -710,12 +710,16 @@ ((eq? (tdb:step-get-event_time a)(tdb:step-get-event_time b)) (< (tdb:step-get-id a) (tdb:step-get-id b))) (else #f))))) res)) +;; temporarily passing in dbstruct to support direct access (i.e. bypassing servers) +;; (define (dcommon:get-compressed-steps dbstruct run-id test-id) - (let* ((steps-data (db:get-steps-for-test dbstruct run-id test-id)) + (let* ((steps-data (if dbstruct + (db:get-steps-for-test dbstruct run-id test-id) + (rmt:get-steps-for-test run-id test-id))) (comprsteps (dcommon:process-steps-table steps-data))) ;; (open-run-close db:get-steps-table #f test-id work-area: work-area))) (map (lambda (x) ;; take advantage of the \n on time->string (vector (vector-ref x 0) Index: rmt.scm ================================================================== --- rmt.scm +++ rmt.scm @@ -604,12 +604,12 @@ ;; 2. Open the testdat.db file and do the query ;; If not given the work area ;; 1. Do a remote call to get the test path ;; 2. Continue as above ;; -(define (rmt:get-steps-for-test run-id test-id) - (rmt:send-receive 'get-steps-data run-id (list test-id))) +;;(define (rmt:get-steps-for-test run-id test-id) +;; (rmt:send-receive 'get-steps-data run-id (list test-id))) (define (rmt:teststep-set-status! run-id test-id teststep-name state-in status-in comment logfile) (let* ((state (items:check-valid-items "state" state-in)) (status (items:check-valid-items "status" status-in))) (if (or (not state)(not status)) @@ -616,11 +616,11 @@ (debug:print 3 "WARNING: Invalid " (if status "status" "state") " value \"" (if status state-in status-in) "\", update your validvalues section in megatest.config")) (rmt:send-receive 'teststep-set-status! run-id (list run-id test-id teststep-name state-in status-in comment logfile)))) (define (rmt:get-steps-for-test run-id test-id) - (rmt:send-receive 'get-steps-for-test run-id (list test-id))) + (rmt:send-receive 'get-steps-for-test run-id (list run-id test-id))) ;;====================================================================== ;; T E S T D A T A ;;====================================================================== Index: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -481,13 +481,13 @@ (cond ;; all prereqs met, fire off the test ;; or, if it is a 'toplevel test and all prereqs not met are COMPLETED then launch ((and (not (member 'toplevel testmode)) - (member (hash-table-ref/default test-registry (runs:make-full-test-name hed item-path) 'n/a) + (member (hash-table-ref/default test-registry (db:test-make-full-name hed item-path) 'n/a) '(DONOTRUN removed CANNOTRUN))) ;; *common:cant-run-states-sym*) ;; '(COMPLETED KILLED WAIVED UNKNOWN INCOMPLETE)) ;; try to catch repeat processing of COMPLETED tests here - (debug:print-info 1 "Test " hed " set to \"" (hash-table-ref test-registry (runs:make-full-test-name hed item-path)) "\". Removing it from the queue") + (debug:print-info 1 "Test " hed " set to \"" (hash-table-ref test-registry (db:test-make-full-name hed item-path)) "\". Removing it from the queue") (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) @@ -686,26 +686,26 @@ reruns) #f)) ;; Register tests ;; - ((not (hash-table-ref/default test-registry (runs:make-full-test-name test-name item-path) #f)) + ((not (hash-table-ref/default test-registry (db:test-make-full-name test-name item-path) #f)) (debug:print-info 4 "Pre-registering test " test-name "/" item-path " to create placeholder" ) ;; always do firm registration now in v1.60 and greater ;; (eq? *transport-type* 'fs) ;; no point in parallel registration if use fs (let register-loop ((numtries 15)) (rmt:general-call 'register-test run-id run-id test-name item-path) (thread-sleep! 0.5) (if (rmt:get-test-id run-id test-name item-path) - (hash-table-set! test-registry (runs:make-full-test-name test-name item-path) 'done) + (hash-table-set! test-registry (db:test-make-full-name test-name item-path) 'done) (if (> numtries 0) (register-loop (- numtries 1)) - (debug:print 0 "ERROR: failed to register test " (runs:make-full-test-name test-name item-path))))) - (if (not (eq? (hash-table-ref/default test-registry (runs:make-full-test-name test-name "") #f) 'done)) + (debug:print 0 "ERROR: failed to register test " (db:test-make-full-name test-name item-path))))) + (if (not (eq? (hash-table-ref/default test-registry (db:test-make-full-name test-name "") #f) 'done)) (begin (rmt:general-call 'register-test run-id run-id test-name "") (if (rmt:get-test-id run-id test-name "") - (hash-table-set! test-registry (runs:make-full-test-name test-name "") 'done)))) + (hash-table-set! test-registry (db:test-make-full-name test-name "") 'done)))) (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) @@ -716,11 +716,11 @@ (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) + ((eq? (hash-table-ref/default test-registry (db:test-make-full-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)) @@ -744,20 +744,20 @@ ;; ((and have-resources (or (null? prereqs-not-met) (and (eq? testmode 'toplevel) (null? non-completed)))) - ;; (hash-table-delete! *max-tries-hash* (runs:make-full-test-name test-name item-path)) + ;; (hash-table-delete! *max-tries-hash* (db:test-make-full-name test-name item-path)) ;; we are going to reset all the counters for test retries by setting a new hash table ;; this means they will increment only when nothing can be run (set! *max-tries-hash* (make-hash-table)) ;; well, first lets see if cpu load throttling is enabled. If so wait around until the ;; average cpu load is under the threshold before continuing (if (configf:lookup *configdat* "jobtools" "maxload") ;; only gate if maxload is specified (common:wait-for-cpuload maxload numcpus waitdelay)) (run:test run-id run-info keyvals runname test-record flags #f test-registry all-tests-registry) - (hash-table-set! test-registry (runs:make-full-test-name test-name item-path) 'running) + (hash-table-set! test-registry (db:test-make-full-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) @@ -794,11 +794,11 @@ (if test-id (mt:test-set-state-status-by-id run-id test-id "NOT_STARTED" "PREQ_FAIL" "Failed to run due to failed prerequisites"))) (runs:shrink-can-run-more-tests-count) ;; DELAY TWEAKER (still needed?) ;; (thread-sleep! *global-delta*) ;; This next is for the items (mt:test-set-state-status-by-testname run-id test-name item-path "NOT_STARTED" "BLOCKED" #f) - (hash-table-set! test-registry (runs:make-full-test-name test-name item-path) 'removed) + (hash-table-set! test-registry (db:test-make-full-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) reruns ;; WAS: (cons hed reruns) ;; but that makes no sense? )) @@ -917,11 +917,11 @@ (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))) (if (not (equal? st "DELETED")) - (hash-table-set! test-registry (runs:make-full-test-name tn ip) (string->symbol st))))) + (hash-table-set! test-registry (db:test-make-full-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)) @@ -950,11 +950,11 @@ (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)) + (tfullname (db:test-make-full-name test-name item-path)) (newtal (append tal (list hed))) (regfull (>= (length reg) reglen)) (num-running (rmt:get-count-tests-running-for-run-id run-id))) ;; every couple minutes verify the server is there for this run @@ -969,14 +969,14 @@ (hash-table-set! *max-tries-hash* tfullname (+ (hash-table-ref/default *max-tries-hash* tfullname 0) 1))) ;; (debug:print 0 "max-tries-hash: " (hash-table->alist *max-tries-hash*)) ;; Ensure all top level tests get registered. This way they show up as "NOT_STARTED" on the dashboard ;; and it is clear they *should* have run but did not. - (if (not (hash-table-ref/default test-registry (runs:make-full-test-name test-name "") #f)) + (if (not (hash-table-ref/default test-registry (db:test-make-full-name test-name "") #f)) (begin (rmt:general-call 'register-test run-id run-id test-name "") - (hash-table-set! test-registry (runs:make-full-test-name test-name "") 'done))) + (hash-table-set! test-registry (db:test-make-full-name test-name "") 'done))) ;; Fast skip of tests that are already "COMPLETED" - NO! Cannot do that as the items may not have been expanded yet :( ;; (if (member (hash-table-ref/default test-registry tfullname #f) '(DONOTRUN removed)) ;; *common:cant-run-states-sym*) ;; '(COMPLETED KILLED WAIVED UNKNOWN INCOMPLETE)) @@ -1065,11 +1065,11 @@ (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 + (let ((newtestname (db:test-make-full-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 @@ -1191,13 +1191,10 @@ (if (not (vector? t)) (conc t) (conc (db:test-get-testname t) ":" (db:test-get-state t) "/" (db:test-get-status t)))) lst)) -(define (runs:make-full-test-name testname itempath) - (if (equal? itempath "") testname (conc testname "/" itempath))) - ;; 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 test-registry all-tests-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)) @@ -1213,11 +1210,11 @@ (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)) - (set! full-test-name (runs:make-full-test-name test-name item-path)) + (set! full-test-name (db:test-make-full-name test-name item-path)) (debug:print-info 4 "\nTESTNAME: " full-test-name "\n test-config: " (hash-table->alist test-conf) "\n itemdat: " itemdat ) @@ -1349,11 +1346,11 @@ (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: " full-test-name " is already running or was explictly killed, use -force to launch it.") - (hash-table-set! test-registry (runs:make-full-test-name test-name test-path) 'DONOTRUN)) ;; KILLED)) + (hash-table-set! test-registry (db:test-make-full-name test-name test-path) 'DONOTRUN)) ;; KILLED)) ((LAUNCHED REMOTEHOSTSTART RUNNING) (debug:print 2 "NOTE: " test-name " is already running")) ;; (if (> (- (current-seconds)(+ (db:test-get-event_time testdat) ;; (db:test-get-run_duration testdat))) ;; (or incomplete-timeout @@ -1365,13 +1362,13 @@ ;; (debug:print 2 "NOTE: " test-name " is already running"))) (else (debug:print 0 "ERROR: Failed to launch test " full-test-name ". Unrecognised state " (test:get-state testdat)) (case (string->symbol (test:get-state testdat)) ((COMPLETED INCOMPLETE) - (hash-table-set! test-registry (runs:make-full-test-name test-name test-path) 'DONOTRUN)) + (hash-table-set! test-registry (db:test-make-full-name test-name test-path) 'DONOTRUN)) (else - (hash-table-set! test-registry (runs:make-full-test-name test-name test-path) 'DONOTRUN)))))))) + (hash-table-set! test-registry (db:test-make-full-name test-name test-path) 'DONOTRUN)))))))) ;;====================================================================== ;; END OF NEW STUFF ;;====================================================================== Index: tests.scm ================================================================== --- tests.scm +++ tests.scm @@ -20,10 +20,11 @@ (declare (unit tests)) (declare (uses lock-queue)) (declare (uses db)) (declare (uses tdb)) (declare (uses common)) +(declare (uses dcommon)) ;; needed for the steps processing (declare (uses items)) (declare (uses runconfig)) ;; (declare (uses sdb)) (include "common_records.scm") @@ -343,11 +344,12 @@ (logf (vector-ref testrecord 5)) (comment (vector-ref testrecord 6))) (hash-table-set! counts status (+ 1 (hash-table-ref/default counts status 0))) (hash-table-set! statecounts state (+ 1 (hash-table-ref/default statecounts state 0))) (set! outtxt (conc outtxt "" - " " itempath "" + ;; " " itempath "" + " " itempath "" "" state "" "" status "" "" (if (equal? comment "") " " @@ -395,26 +397,53 @@ ;; summarize test (define (tests:summarize-test run-id test-id) (let* ((test-dat (rmt:get-test-info-by-id run-id test-id)) (steps-dat (rmt:get-steps-for-test run-id test-id)) (test-name (db:test-get-testname test-dat)) - (oup (open-output-file "test-summary.html"))) + (item-path (db:test-get-item-path test-dat)) + (full-name (db:test-make-full-name test-name item-path)) + (oup (open-output-file (conc (db:test-get-rundir test-dat) "/test-summary.html"))) + (status (db:test-get-status test-dat)) + (color (common:get-color-from-status status)) + (logf (db:test-get-final_logf test-dat)) + (steps-dat (dcommon:get-compressed-steps #f run-id test-id))) + ;; (dcommon:get-compressed-steps #f 1 30045) + ;; (#("wasting_time" "23:36:13" "23:36:21" "0" "8.0s" "wasting_time.log")) + (s:output-new oup (s:html - (s:title "Summary: " test-name) + (s:title "Summary for " full-name) (s:body - (s:h2 "Summary for " test-name) - (s:table - (s:tr (s:td "id") (s:td (db:test-get-id test-dat))) - (s:tr (s:td "run-id") (s:td (db:test-get-run_id test-dat))) - (s:tr (s:td "testname") (s:td (db:test-get-testname test-dat))) - (s:tr (s:td "state") (s:td (db:test-get-state test-dat))) - (s:tr (s:td "status") (s:td (db:test-get-status test-dat))) + (s:h2 "Summary for " full-name) + (s:table 'cellspacing "0" 'border "1" + (s:tr (s:td "run id") (s:td (db:test-get-run_id test-dat)) + (s:td "test id") (s:td (db:test-get-id test-dat))) + (s:tr (s:td "testname") (s:td test-name) + (s:td "itempath") (s:td item-path)) + (s:tr (s:td "state") (s:td (db:test-get-state test-dat)) + (s:td "status") (s:td (s:a 'href logf (s:font 'color color status)))) (s:tr (s:td "TestDate") (s:td (seconds->work-week/day-time - (db:test-get-event_time test-dat))))) - ))) + (db:test-get-event_time test-dat))) + (s:td "Duration") (s:td (seconds->hr-min-sec (db:test-get-run_duration test-dat))))) + (s:h3 "Log files") + (s:table + 'cellspacing "0" 'border "1" + (s:tr (s:td "Final log")(s:td (s:a 'href logf logf)))) + (s:table + 'cellspacing "0" 'border "1" + (s:tr (s:td "Step Name")(s:td "Start")(s:td "End")(s:td "Status")(s:td "Duration")(s:td "Log File")) + (map (lambda (step-dat) + (s:tr (s:td (tdb:steps-table-get-stepname step-dat)) + (s:td (tdb:steps-table-get-start step-dat)) + (s:td (tdb:steps-table-get-end step-dat)) + (s:td (tdb:steps-table-get-status step-dat)) + (s:td (tdb:steps-table-get-runtime step-dat)) + (s:td (let ((step-log (tdb:steps-table-get-log-file step-dat))) + (s:a 'href step-log step-log))))) + steps-dat)) + ))) (close-output-port oup))) ;; MUST BE CALLED local! ;;