Index: dashboard-tests.scm ================================================================== --- dashboard-tests.scm +++ dashboard-tests.scm @@ -10,48 +10,114 @@ ;;====================================================================== ;;====================================================================== ;; ;;====================================================================== -(define (examine-test db test-id) ;; run-id run-key origtest) - (let* ((testdat (db:get-test-data-by-id db test-id)) - (run-id (if testdat (db:test-get-run_id testdat) #f)) - (rundat (if testdat (db:get-run-info db run-id))) - (teststeps (if testdat (db:get-steps-for-test db test-id)))) +(define (examine-test db test-id other-thread) ;; run-id run-key origtest) + (let* ((testdat (db:get-test-data-by-id db test-id)) + (run-id (if testdat (db:test-get-run_id testdat) #f)) + (keydat (if testdat (keys:get-key-val-pairs db run-id) #f)) + (rundat (if testdat (db:get-run-info db run-id) #f)) + (runname (if testdat (db:get-value-by-header (db:get-row rundat) + (db:get-header rundat) + "runname") #f)) + (teststeps (if testdat (db:get-steps-for-test db test-id) #f)) + (logfile "/this/dir/better/not/exist") + (rundir logfile) + (testfullname (if testdat (db:test-get-fullname testdat) "Gathering data ...")) + (viewlog (lambda (x) + (if (file-exists? logfile) + (system (conc "firefox " logfile "&")) + (message-window (conc "File " logfile " not found"))))) + (xterm (lambda (x) + (if (directory-exists? rundir) + (let ((shell (if (get-environment-variable "SHELL") + (conc "-e " (get-environment-variable "SHELL")) + ""))) + (system (conc "cd " rundir + ";xterm -T \"" (string-translate testfullname "()" " ") "\" " shell "&"))) + (message-window (conc "Directory " rundir " not found"))))) + (refreshdat (lambda () + (set! testdat (db:get-test-data-by-id db test-id)) + (set! teststeps (db:get-steps-for-test db test-id)) + (set! logfile (conc (db:test-get-rundir testdat) "/" (db:test-get-final_logf testdat))) + (set! rundir (db:test-get-rundir testdat)) + (set! testfullname (db:test-get-fullname testdat)))) + (widgets (make-hash-table)) + (self #f) + (store-label (lambda (name lbl cmd) + (hash-table-set! widgets name (lambda () + (iup:attribute-set! lbl "TITLE" (cmd)))) + lbl)) + (store-button (lambda (name btn cmd) + (hash-table-set! widgets name (lambda (cmd) + (iup:attribute-set! btn "TITLE" (cmd)))) + btn)) + ) (cond ((not testdat)(begin (print "ERROR: bad test info for " test-id)(exit 1))) ((not rundat)(begin (print "ERROR: found test info but there is a problem with the run info for " run-id)(exit 1))) (else - (let* ((widgets (make-hash-table)) ;; put the widgets to update in this hashtable - (logfile (conc (db:test-get-rundir testdat) "/" (db:test-get-final_logf testdat))) - (viewlog (lambda (x) - (if (file-exists? logfile) - (system (conc "firefox " logfile "&")) - (message-window (conc "File " logfile " not found"))))) - (xterm (lambda (x) - (if (directory-exists? rundir) - (let ((shell (if (get-environment-variable "SHELL") - (conc "-e " (get-environment-variable "SHELL")) - ""))) - (system (conc "cd " rundir - ";xterm -T \"" (string-translate testfullname "()" " ") "\" " shell "&"))) - (message-window (conc "Directory " rundir " not found"))))) - (self #f)) - - (hash-table-set! widgets "testdat" testdat) - (hash-table-set! widgets "rundat" rundat) - - ;; (test-set-status! db run-id test-name state status itemdat) - (set! self - (iup:dialog - #:title "testfullname" - (iup:hbox ;; Need a full height box for all the test steps - (iup:vbox - (iup:hbox - (iup:frame (iup:label "BLAH (was run-key)"))))))) - (iup:show self) - ))))) + ;; (test-set-status! db run-id test-name state status itemdat) + (set! self + (iup:dialog + #:title testfullname + (iup:hbox #:expand "BOTH" ;; Need a full height box for all the test steps + (iup:vbox #:expand "BOTH" + (iup:hbox #:expand "BOTH" + (iup:frame #:title "Run Info" #:expand "VERTICAL" + (iup:hbox #:expand "BOTH" + (apply iup:vbox #:expand "BOTH" + (append (map (lambda (keyval) + (iup:label (conc (car keyval) " ") #:expand "HORIZONTAL")) + keydat) + (list (iup:label "runname ")))) + (apply iup:vbox + (append (map (lambda (keyval) + (iup:label (cadr keyval) #:expand "HORIZONTAL")) + keydat) + (list (iup:label runname)))))) + (iup:frame #:title "Test Info" #:expand "VERTICAL" + (iup:hbox #:expand "BOTH" + (apply iup:vbox #:expand "BOTH" + (map (lambda (val) + (iup:label val #:expand "HORIZONTAL")) + (list "Testname: " + "Item path: " + "Current state: " + "Current status: " + "Test comment: "))) + (apply iup:vbox #:expand "BOTH" + (list + (iup:label (db:test-get-testname testdat) #:expand "BOTH") + (iup:label (db:test-get-item-path testdat) #:expand "BOTH") + (store-label "teststate" + (iup:label "TestState" #:expand "BOTH") + (lambda () + (db:test-get-state testdat))) + (store-label "teststatus" + (iup:label "TestStatus" #:expand "BOTH") + (lambda () + (db:test-get-status testdat))) + (store-label "testcomment" + (iup:label "TestComment" #:expand "BOTH") + (lambda () + (db:test-get-comment testdat)))))))))))) + (iup:show self) + ;; Now start keeping the gui updated from the db + (let loop ((i 0)) + (thread-sleep! 0.1) + (refreshdat) ;; update from the db here + (thread-suspend! other-thread) + ;; update the gui elements here + (for-each + (lambda (key) + (print "Updating " key) + ((hash-table-ref widgets key))) + (hash-table-keys widgets)) + (thread-resume! other-thread) + (loop i)))))) ;; ;; (iup:frame (iup:label (conc "TESTNAME:\n" testfullname) #:expand "YES"))) ;; (iup:frame #:title "Actions" #:expand "YES" ;; (iup:hbox ;; the actions box Index: dashboard.scm ================================================================== --- dashboard.scm +++ dashboard.scm @@ -118,11 +118,11 @@ (header (db:get-header allruns)) (runs (db:get-rows allruns)) (result '()) (maxtests 0)) (for-each (lambda (run) - (let* ((run-id (db-get-value-by-header run header "id")) + (let* ((run-id (db:get-value-by-header run header "id")) (tests (db-get-tests-for-run *db* run-id testnamepatt itemnamepatt)) (key-vals (get-key-vals *db* run-id))) (if (> (length tests) maxtests) (set! maxtests (length tests))) (set! result (cons (vector run tests key-vals) result)))) @@ -402,11 +402,11 @@ (update-buttons uidat *num-runs* *num-tests*) (update-rundat (hash-table-ref/default *searchpatts* "runname" "%") *num-runs* (hash-table-ref/default *searchpatts* "test-name" "%") (hash-table-ref/default *searchpatts* "item-name" "%")) (thread-resume! other-thread) - (loop (+ i 1)))) + (loop i))) (define *job* #f) (cond ((args:get-arg "-run") @@ -417,11 +417,11 @@ (print "ERROR: runid is not a number " (args:get-arg "-run")) (exit 1))))) ((args:get-arg "-test") (let ((testid (string->number (args:get-arg "-test")))) (if testid - (set! *job* (lambda (thr)(examine-test *db* testid))) + (set! *job* (lambda (thr)(examine-test *db* testid thr))) (begin (print "ERROR: testid is not a number " (args:get-arg "-test")) (exit 1))))) (else (set! uidat (make-dashboard-buttons *num-runs* *num-tests* dbkeys)) Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -100,11 +100,11 @@ (define-inline (db:get-header vec)(vector-ref vec 0)) (define-inline (db:get-rows vec)(vector-ref vec 1)) -(define (db-get-value-by-header row header field) +(define (db:get-value-by-header row header field) (if (null? header) #f (let loop ((hed (car header)) (tal (cdr header)) (n 0)) (if (equal? hed field) @@ -191,10 +191,12 @@ (define-inline (db:test-get-rundir vec) (vector-ref vec 10)) (define-inline (db:test-get-item-path vec) (vector-ref vec 11)) (define-inline (db:test-get-run_duration vec) (vector-ref vec 12)) (define-inline (db:test-get-final_logf vec) (vector-ref vec 13)) (define-inline (db:test-get-comment vec) (vector-ref vec 14)) +(define-inline (db:test-get-fullname vec) + (conc (db:test-get-testname vec) "/" (db:test-get-item-path vec))) (define (db-get-tests-for-run db run-id . params) (let ((res '()) (testpatt (if (or (null? params)(not (car params))) "%" (car params))) (itempatt (if (> (length params) 1)(cadr params) "%"))) Index: keys.scm ================================================================== --- keys.scm +++ keys.scm @@ -35,10 +35,27 @@ ;; (print "qry: " qry) (sqlite3:for-each-row (lambda (key-val) (set! res (cons key-val res))) db qry run-id))) + keys) + (reverse res))) + +;; get key val pairs for a given run-id +;; ( (FIELDNAME1 keyval1) (FIELDNAME2 keyval2) ... ) +(define (keys:get-key-val-pairs db run-id) + (let* ((keys (get-keys db)) + (res '())) + ;; (print "keys: " keys " run-id: " run-id) + (for-each + (lambda (key) + (let ((qry (conc "SELECT " (key:get-fieldname key) " FROM runs WHERE id=?;"))) + ;; (print "qry: " qry) + (sqlite3:for-each-row + (lambda (key-val) + (set! res (cons (list (key:get-fieldname key) key-val) res))) + db qry run-id))) keys) (reverse res))) (define (keys->keystr keys) ;; => key1,key2,key3,additiona1, ... (string-intersperse (map key:get-fieldname keys) ",")) Index: launch.scm ================================================================== --- launch.scm +++ launch.scm @@ -72,11 +72,11 @@ (define (create-work-area db run-id test-path disk-path testname itemdat) (let* ((run-info (db:get-run-info db run-id)) (item-path (let ((ip (item-list->path itemdat))) (if (equal? ip "") "" (conc "/" ip)))) - (runname (db-get-value-by-header (db:get-row run-info) + (runname (db:get-value-by-header (db:get-row run-info) (db:get-header run-info) "runname")) (key-vals (get-key-vals db run-id)) (key-str (string-intersperse key-vals "/")) (dfullp (conc disk-path "/" key-str "/" runname "/" testname Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -175,15 +175,15 @@ ;; Each run (for-each (lambda (run) (print "Run: " (string-intersperse (map (lambda (x) - (db-get-value-by-header run header x)) + (db:get-value-by-header run header x)) keynames) "/") "/" - (db-get-value-by-header run header "runname")) - (let ((run-id (db-get-value-by-header run header "id"))) + (db:get-value-by-header run header "runname")) + (let ((run-id (db:get-value-by-header run header "id"))) (let ((tests (db-get-tests-for-run db run-id testpatt itempatt))) ;; Each test (for-each (lambda (test) (format #t Index: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -467,17 +467,17 @@ (runs (vector-ref rundat 1))) (print "Header: " header) (for-each (lambda (run) (let ((runkey (string-intersperse (map (lambda (k) - (db-get-value-by-header run header (vector-ref k 0))) keys) "/"))) - (let* ((run-id (db-get-value-by-header run header "id") ) - (tests (db-get-tests-for-run db (db-get-value-by-header run header "id") testpatt itempatt)) + (db:get-value-by-header run header (vector-ref k 0))) keys) "/"))) + (let* ((run-id (db:get-value-by-header run header "id") ) + (tests (db-get-tests-for-run db (db:get-value-by-header run header "id") testpatt itempatt)) (lasttpath "/does/not/exist/I/hope")) (if (not (null? tests)) (begin - (print "Removing tests for run: " runkey " " (db-get-value-by-header run header "runname")) + (print "Removing tests for run: " runkey " " (db:get-value-by-header run header "runname")) (for-each (lambda (test) (print " " (db:test-get-testname test) " id: " (db:test-get-id test) " " (db:test-get-item-path test)) (db:delete-test-records db (db:test-get-id test)) (if (> (string-length (db:test-get-rundir test)) 5) ;; bad heuristic but should prevent /tmp /home etc. @@ -488,17 +488,17 @@ (let ((cmd (conc "rmdir -p " (get-dir-up-one fullpath)))) (print cmd) (system cmd)) ))) tests))) - (let ((remtests (db-get-tests-for-run db (db-get-value-by-header run header "id")))) + (let ((remtests (db-get-tests-for-run db (db:get-value-by-header run header "id")))) (if (null? remtests) ;; no more tests remaining (let* ((dparts (string-split lasttpath "/")) (runpath (conc "/" (string-intersperse (take dparts (- (length dparts) 1)) "/")))) - (print "Removing run: " runkey " " (db-get-value-by-header run header "runname")) + (print "Removing run: " runkey " " (db:get-value-by-header run header "runname")) (db:delete-run db run-id) ;; need to figure out the path to the run dir and remove it if empty ;; (if (null? (glob (conc runpath "/*"))) ;; (begin ;; (print "Removing run dir " runpath)