Index: dashboard-tests.scm ================================================================== --- dashboard-tests.scm +++ dashboard-tests.scm @@ -418,22 +418,22 @@ ;;====================================================================== (define (examine-test run-id test-id) ;; run-id run-key origtest) (let* ((db-path (db:dbfile-path run-id)) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/db/" run-id ".db")) (dbstruct (make-dbr:dbstruct path: (db:dbfile-path #f) ;; (configf:lookup *configdat* "setup" "linktree") local: #t)) - (testdat (db:get-test-info-by-id dbstruct run-id test-id)) + (testdat (rmt:get-test-info-by-id run-id test-id)) ;; (db:get-test-info-by-id dbstruct run-id test-id)) (db-mod-time 0) ;; (file-modification-time db-path)) (last-update 0) ;; (current-seconds)) (request-update #t)) (if (not testdat) (begin (debug:print 2 "ERROR: No test data found for test " test-id ", exiting") (exit 1)) (let* (;; (run-id (if testdat (db:test-get-run_id testdat) #f)) (test-registry (tests:get-all)) - (keydat (if testdat (db:get-key-val-pairs dbstruct run-id) #f)) - (rundat (if testdat (db:get-run-info dbstruct run-id) #f)) + (keydat (if testdat (rmt:get-key-val-pairs run-id) #f)) + (rundat (if testdat (rmt:get-run-info run-id) #f)) (runname (if testdat (db:get-value-by-header (db:get-rows rundat) (db:get-header rundat) "runname") #f)) ;; (tdb (tdb:open-test-db-by-test-id-local dbstruct run-id test-id)) ;; These next two are intentional bad values to ensure errors if they should not @@ -441,16 +441,16 @@ (logfile "/this/dir/better/not/exist") (rundir (if testdat (db:test-get-rundir testdat) logfile)) ;; (testdat-path (conc rundir "/testdat.db")) ;; this gets recalculated until found - (teststeps (if testdat (tests:get-compressed-steps dbstruct run-id test-id) '())) + (teststeps (if testdat (tests:get-compressed-steps #f run-id test-id) '())) (testfullname (if testdat (db:test-get-fullname testdat) "Gathering data ...")) (testname (if testdat (db:test-get-testname testdat) "n/a")) ;; (tests:get-testconfig testdat testname 'return-procs)) (testmeta (if testdat - (let ((tm (db:testmeta-get-record dbstruct testname))) + (let ((tm (rmt:testmeta-get-record testname))) (if tm tm (make-db:testmeta))) (make-db:testmeta))) (keystring (string-intersperse (map (lambda (keyval) @@ -512,16 +512,16 @@ (newtestdat (if need-update ;; NOTE: BUG HIDER, try to eliminate this exception handler (handle-exceptions exn (debug:print-info 0 "test db access issue in examine test for run-id " run-id ", test-id " test-id ": " ((condition-property-accessor 'exn 'message) exn)) - (db:get-test-info-by-id dbstruct run-id test-id ))))) + (rmt:get-test-info-by-id run-id test-id ))))) ;; (debug:print-info 0 "need-update= " need-update " curr-mod-time = " curr-mod-time) (cond ((and need-update newtestdat) (set! testdat newtestdat) - (set! teststeps (tests:get-compressed-steps dbstruct run-id test-id)) + (set! teststeps (tests:get-compressed-steps #f run-id test-id)) (set! logfile (conc (db:test-get-rundir testdat) "/" (db:test-get-final_logf testdat))) (set! rundir ;; (filedb:get-path *fdb* (db:test-get-rundir testdat)) ;; ) (set! testfullname (db:test-get-fullname testdat)) ;; (debug:print 0 "INFO: teststeps=" (intersperse teststeps "\n ")) @@ -757,11 +757,11 @@ (db:test-data-get-tol x) (db:test-data-get-status x) (db:test-data-get-units x) (db:test-data-get-type x) (db:test-data-get-comment x))) - (db:read-test-data dbstruct run-id test-id "%"))) + (rmt:read-test-data run-id test-id "%"))) "\n"))) (if (not (equal? currval newval)) (iup:attribute-set! test-data "VALUE" newval ))))) ;; "TITLE" newval))))) test-data)) ;;(dashboard:run-controls) Index: dashboard.scm ================================================================== --- dashboard.scm +++ dashboard.scm @@ -71,10 +71,11 @@ "-use-server" "-guimonitor" "-main" "-v" "-q" + "-use-local" ) args:arg-hash 0)) (if (args:get-arg "-h") @@ -85,11 +86,11 @@ (if (not (launch:setup-for-run)) (begin (print "Failed to find megatest.config, exiting") (exit 1))) -(define *useserver* (or (args:get-arg "-use-server") +(define *useserver* (or(not (args:get-arg "-use-local")) (configf:lookup *configdat* "dashboard" "use-server"))) (define *dbdir* (db:dbfile-path #f)) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/.db")) (define *dbstruct-local* (make-dbr:dbstruct path: *dbdir* local: #t)) @@ -960,10 +961,13 @@ #:posx "0.5" #:posy "0.5" #:button-cb (lambda (obj btn pressed x y status) (print "obj: " obj ", pressed " pressed ", status " status) (print "canvas-origin: " (canvas-origin the-cnv)) + (let-values (((xx yy)(canvas-origin the-cnv))) + (canvas-transform-set! the-cnv #f) + (print "canvas-origin: " xx " " yy " click at " x " " y)) (let ((tests-info (hash-table-ref tests-draw-state 'tests-info)) (selected-tests (hash-table-ref tests-draw-state 'selected-tests))) ;; (print "\tx\ty\tllx\tlly\turx\tury") (for-each (lambda (test-name) (let* ((rec-coords (hash-table-ref tests-info test-name)) @@ -1105,21 +1109,34 @@ (key (conc lin ":" col)) (test-id (hash-table-ref/default cell-lookup key -1)) (cmd (conc toolpath " -test " (dboard:data-get-curr-run-id *data*) "," test-id "&"))) (system cmd))))) (updater (lambda () - (let* ((runs-dat (db:get-runs-by-patt db *keys* "%" #f #f #f #f)) + (let* ((runs-dat (if *useserver* + (rmt:get-runs-by-patt *keys* "%" #f #f #f #f) + (db:get-runs-by-patt db *keys* "%" #f #f #f #f))) (runs-header (vector-ref runs-dat 0)) ;; 0 is header, 1 is list of records (run-id (dboard:data-get-curr-run-id *data*)) - (tests-dat (let ((tdat (db:get-tests-for-run db run-id - (hash-table-ref/default *searchpatts* "test-name" "%/%") - (hash-table-keys *state-ignore-hash*) ;; '() - (hash-table-keys *status-ignore-hash*) ;; '() - #f #f - *hide-not-hide* - #f #f - "id,testname,item_path,state,status"))) ;; get 'em all + (tests-dat (let ((tdat (if run-id + (if *useserver* + (rmt:get-tests-for-run run-id + (hash-table-ref/default *searchpatts* "test-name" "%/%") + (hash-table-keys *state-ignore-hash*) ;; '() + (hash-table-keys *status-ignore-hash*) ;; '() + #f #f + *hide-not-hide* + #f #f + "id,testname,item_path,state,status") ;; get 'em all + (db:get-tests-for-run db run-id + (hash-table-ref/default *searchpatts* "test-name" "%/%") + (hash-table-keys *state-ignore-hash*) ;; '() + (hash-table-keys *status-ignore-hash*) ;; '() + #f #f + *hide-not-hide* + #f #f + "id,testname,item_path,state,status")) + '()))) ;; get 'em all (sort tdat (lambda (a b) (let* ((aval (vector-ref a 2)) (bval (vector-ref b 2)) (anum (string->number aval)) (bnum (string->number bval))) Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -939,10 +939,25 @@ (if indx (if (>= indx (vector-length datavec)) #f ;; index to high, should raise an error I suppose (vector-ref datavec indx)) #f))) + +(define (to-alist dat) + (cond + ((list? dat) (map to-alist dat)) + ((vector? dat) + (map to-alist (vector->list dat))) + ((pair? dat) + (cons (to-alist (car dat)) + (to-alist (cdr dat)))) + ((hash-table? dat) + (map to-alist (hash-table->alist dat))) + (else + (if dat + dat + "")))) ;; NOTE: list-runs and list-db-targets operate on local db!!! ;; (if (or (args:get-arg "-list-runs") (args:get-arg "-list-db-targets")) @@ -957,10 +972,12 @@ ;; (runsda t (db:get-runs dbstruct runpatt #f #f '())) (runsdat (rmt:get-runs-by-patt keys (or runpatt "%") (common:args-get-target) ;; (db:get-runs-by-patt dbstruct keys (or runpatt "%") (common:args-get-target) #f #f '("id" "runname" "state" "status" "owner" "event_time" "comment"))) (runstmp (db:get-rows runsdat)) (header (db:get-header runsdat)) + ;; this is "-since" support. This looks at last mod times of .db files + ;; and collects those modified since the -since time. (runs (if (and (not (null? runstmp)) (args:get-arg "-since")) (let ((changed-ids (db:get-changed-run-ids (string->number (args:get-arg "-since"))))) (let loop ((hed (car runstmp)) (tal (cdr runstmp)) @@ -1030,11 +1047,11 @@ (string-intersperse adj-tests-spec ",") ;; db:test-record-fields #f)) '()))) (case dmode - ((json) + ((json ods) (if runs-spec (for-each (lambda (field-name) (mutils:hierhash-set! data (conc (db:get-value-by-header run header field-name)) targetstr runname "meta" field-name)) runs-spec))) @@ -1085,11 +1102,11 @@ (fullname (conc testname (if (equal? itempath "") "" (conc "(" itempath ")"))))) (case dmode - ((json) + ((json ods) (if tests-spec (for-each (lambda (field-name) (mutils:hierhash-set! data (get-value-by-fieldname test test-field-index field-name) targetstr runname "data" (conc test-id) field-name)) tests-spec))) @@ -1158,10 +1175,86 @@ (tdb:step-get-event_time step))) steps))))))))) tests))))) runs) (if (eq? dmode 'json)(json-write data)) + (let* ((metadat-fields (delete-duplicates + (append keys '( "runname" "time" "owner" "pass_count" "fail_count" "state" "status" "comment" "id")))) + (run-fields '("state" + "shortdir" + "status" + "comment" + "item_path" + "event_time" + "host" + "run_id" + "run_duration" + "attemptnum" + "testname" + "id" + "uname" + "archived" + "diskfree" + "rundir" + "cpuload" + "final_logf")) + (newdat (to-alist data)) + (allrundat (car (map cdr newdat))) ;; (car (map cdr (car (map cdr newdat))))) + (runs (append + (list "runs" ;; sheetname + metadat-fields) + (map (lambda (run) + ;; (print "run: " run) + (let* ((runname (car run)) + (rundat (cdr run)) + (metadat (let ((tmp (assoc "meta" rundat))) + (if tmp (cdr tmp) #f)))) + ;; (print "runname: " runname "\n\nrundat: " )(pp rundat)(print "\n\nmetadat: ")(pp metadat) + (if metadat + (map (lambda (field) + (let ((tmp (assoc field metadat))) + (if tmp (cdr tmp) ""))) + metadat-fields) + '()))) + allrundat))) + ;; '( ( "target" ( "runname" ( "data" ( "runid" ( "id . "37" ) ( ... )))) + (run-pages (map (lambda (targdat) + (let* ((target (car targdat)) + (runsdat (cdr targdat))) + (if runsdat + (map (lambda (rundat) + (let* ((runname (car rundat)) + (rundat (cdr rundat)) + (testsdat (let ((tmp (assoc "data" rundat))) + (if tmp (cdr tmp) #f)))) + (if testsdat + (let ((tests (map (lambda (test) + (let* ((test-id (car test)) + (test-dat (cdr test))) + (map (lambda (field) + (let ((tmp (assoc field test-dat))) + (if tmp (cdr tmp) ""))) + run-fields))) + testsdat))) + (print "Target: " target "/" runname ":") + (pp testsdat) + (cons (conc target "/" runname) + tests)) + '()))) + runsdat) + '()))) + newdat)) ;; we use newdat to get target + (sheets (apply list runs run-pages))) + ;; (print "allrundat:") + ;; (pp allrundat) + ;; (print "runs:") + ;; (pp runs) + (print "sheets: ") + (pp sheets) + (system "rm -rf /tmp/construct-ods") + (create-directory "/tmp/construct-ods" #t) + (if (eq? dmode 'ods)(ods:list->ods "/tmp/construct-ods" "blah.ods" sheets))) (set! *didsomething* #t)))) ;; Don't think I need this. Incorporated into -list-runs instead ;; ;; (if (and (args:get-arg "-since")