Index: megatest-version.scm ================================================================== --- megatest-version.scm +++ megatest-version.scm @@ -1,7 +1,7 @@ ;; Always use two or four digit decimal ;; 1.01, 1.02...1.10,1.11,1,1101 ... 1.99,2.00.. (declare (unit megatest-version)) -(define megatest-version 1.6008) +(define megatest-version 1.6009) Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -18,10 +18,11 @@ (use sparse-vectors) (import (prefix sqlite3 sqlite3:)) (import (prefix base64 base64:)) (import (prefix rpc rpc:)) +(require-library mutils) ;; (use zmq) (declare (uses common)) (declare (uses megatest-version)) @@ -891,11 +892,14 @@ #f #f)) ;; (cdb:remote-run db:get-runs #f runpatt #f #f '())) (runs (db:get-rows runsdat)) (header (db:get-header runsdat)) (db-targets (args:get-arg "-list-db-targets")) - (seen (make-hash-table))) + (seen (make-hash-table)) + (dmode (let ((d (args:get-arg "-dumpmode"))) + (if d (string->symbol d) #f))) + (data (make-hash-table))) ;; Each run (for-each (lambda (run) (let ((targetstr (string-intersperse (map (lambda (x) (db:get-value-by-header run header x)) @@ -903,59 +907,75 @@ (if db-targets (if (not (hash-table-ref/default seen targetstr #f)) (begin (hash-table-set! seen targetstr #t) ;; (print "[" targetstr "]")))) - (print targetstr)))) - (if (not db-targets) - (let* ((run-id (db:get-value-by-header run header "id")) + (if (not dmode)(print targetstr)))) + (let* ((run-id (db:get-value-by-header run header "id")) + (runname (db:get-value-by-header run header "runname")) (tests (db:get-tests-for-run dbstruct run-id testpatt '() '() #f #f #f 'testname 'asc #f))) - (print "Run: " targetstr "/" (db:get-value-by-header run header "runname") - " status: " (db:get-value-by-header run header "state") - " run-id: " run-id ", number tests: " (length tests)) + (case dmode + ((json) + (mutils:hierhash-set! data targetstr runname "meta" "status" (db:get-value-by-header run header "status")) + (mutils:hierhash-set! data targetstr runname "meta" "state" (db:get-value-by-header run header "state")) + (mutils:hierhash-set! data targetstr runname "meta" "id" (conc (db:get-value-by-header run header "id")))) + (else + (print "Run: " targetstr "/" runname + " status: " (db:get-value-by-header run header "state") + " run-id: " run-id ", number tests: " (length tests)))) (for-each (lambda (test) - (handle-exceptions + (handle-exceptions exn (debug:print 0 "ERROR: Bad data in test record? " test) - (format #t - " Test: ~25a State: ~15a Status: ~15a Runtime: ~5@as Time: ~22a Host: ~10a\n" - (conc (db:test-get-testname test) - (if (equal? (db:test-get-item-path test) "") - "" - (conc "(" (db:test-get-item-path test) ")"))) - (db:test-get-state test) - (db:test-get-status test) - (db:test-get-run_duration test) - (db:test-get-event_time test) - (db:test-get-host test))) - (if (not (or (equal? (db:test-get-status test) "PASS") - (equal? (db:test-get-status test) "WARN") - (equal? (db:test-get-state test) "NOT_STARTED"))) - (begin - (print " cpuload: " (db:test-get-cpuload test) - "\n diskfree: " (db:test-get-diskfree test) - "\n uname: " ;; (sdb:qry 'getstr - (db:test-get-uname test) ;; ) - "\n rundir: " ;; (sdb:qry 'getstr ;; (filedb:get-path *fdb* - (db:test-get-rundir test) ;; ) - ) - ;; Each test - ;; DO NOT remote run - (let ((steps (db:get-steps-for-test dbstruct run-id (db:test-get-id test)))) - (for-each - (lambda (step) - (format #t - " Step: ~20a State: ~10a Status: ~10a Time ~22a\n" - (tdb:step-get-stepname step) - (tdb:step-get-state step) - (tdb:step-get-status step) - (tdb:step-get-event_time step))) - steps))))) + (let ((test-id (db:test-get-id test)) + (fullname (conc (db:test-get-testname test) + (if (equal? (db:test-get-item-path test) "") + "" + (conc "(" (db:test-get-item-path test) ")")))) + (tstate (db:test-get-state test)) + (tstatus (db:test-get-status test))) + (case dmode + ((json) + (mutils:hierhash-set! data targetstr runname "data" (conc test-id) "tname" fullname) + (mutils:hierhash-set! data targetstr runname "data" (conc test-id) "state" tstate) + (mutils:hierhash-set! data targetstr runname "data" (conc test-id) "status" tstatus)) + (else + (format #t + " Test: ~25a State: ~15a Status: ~15a Runtime: ~5@as Time: ~22a Host: ~10a\n" + fullname + tstate + tstatus + (db:test-get-run_duration test) + (db:test-get-event_time test) + (db:test-get-host test)) + (if (not (or (equal? (db:test-get-status test) "PASS") + (equal? (db:test-get-status test) "WARN") + (equal? (db:test-get-state test) "NOT_STARTED"))) + (begin + (print " cpuload: " (db:test-get-cpuload test) + "\n diskfree: " (db:test-get-diskfree test) + "\n uname: " (db:test-get-uname test) + "\n rundir: " (db:test-get-rundir test) + "\n rundir: " ;; (sdb:qry 'getstr ;; (filedb:get-path *fdb* + (db:test-get-rundir test) ;; ) + ) + ;; Each test + ;; DO NOT remote run + (let ((steps (db:get-steps-for-test dbstruct run-id (db:test-get-id test)))) + (for-each + (lambda (step) + (format #t + " Step: ~20a State: ~10a Status: ~10a Time ~22a\n" + (tdb:step-get-stepname step) + (tdb:step-get-state step) + (tdb:step-get-status step) + (tdb:step-get-event_time step))) + steps))))))))) tests))))) - runs) - ;; (db:close-all dbstruct) + runs) + (if (eq? dmode 'json)(json-write data)) (set! *didsomething* #t)))) ;;====================================================================== ;; full run ;;======================================================================