Index: common.scm
==================================================================
--- common.scm
+++ common.scm
@@ -143,21 +143,26 @@
(define (common:version-signature)
(conc megatest-version "-" (substring megatest-fossil-hash 0 4)))
;; from metadat lookup MEGATEST_VERSION
;;
-(define (common:get-last-run-version)
+(define (common:get-last-run-version) ;; RADT => How does this work in send-receive function??; assume it is the value saved in some DB
(rmt:get-var "MEGATEST_VERSION"))
+(define (common:get-last-run-version-number)
+ (string->number
+ (substring (common:get-last-run-version) 0 6)))
+
(define (common:set-last-run-version)
(rmt:set-var "MEGATEST_VERSION" (common:version-signature)))
(define (common:version-changed?)
(not (equal? (common:get-last-run-version)
(common:version-signature))))
;; Move me elsewhere ...
+;; RADT => Why do we meed the version check here, this is called only if version misma
;;
(define (common:cleanup-db)
(db:multi-db-sync
#f ;; do all run-ids
;; 'new2old
@@ -167,15 +172,17 @@
;; 'old2new
'new2old)
(if (common:version-changed?)
(common:set-last-run-version)))
+;; Force a megatest cleanup-db if version is changed and skip-version-check not specified
+;;
(define (common:exit-on-version-changed)
(if (common:version-changed?)
(let ((mtconf (conc (get-environment-variable "MT_RUN_AREA_HOME") "/megatest.config")))
(debug:print 0 *default-log-port*
- "ERROR: Version mismatch!\n"
+ "WARNING: Version mismatch!\n"
" expected: " (common:version-signature) "\n"
" got: " (common:get-last-run-version))
(if (and (file-exists? mtconf)
(eq? (current-user-id)(file-owner mtconf))) ;; safe to run -cleanup-db
(begin
@@ -634,10 +641,18 @@
))))))
;;======================================================================
;; S Y S T E M S T U F F
;;======================================================================
+
+;; lazy-safe get file mod time. on any error (file not existing etc.) return 0
+;;
+(define (common:lazy-modification-time fpath)
+ (handle-exceptions
+ exn
+ 0
+ (file-modification-time fpath)))
;; return a nice clean pathname made absolute
(define (common:nice-path dir)
(let ((match (string-match "^(~[^\\/]*)(\\/.*|)$" dir)))
(if match ;; using ~ for home?
Index: common_records.scm
==================================================================
--- common_records.scm
+++ common_records.scm
@@ -103,10 +103,24 @@
(lambda ()
(if *logging*
(db:log-event (apply conc params))
(apply print params)
)))))
+
+;; Brandon's debug printer shortcut (indulge me :)
+(define (BB> . in-args)
+ (let* ((stack (get-call-chain))
+ (location #f))
+ (for-each
+ (lambda (frame)
+ (let* ((this-loc (vector-ref frame 0))
+ (this-func (cadr (string-split this-loc " "))))
+ (if (equal? this-func "BB>")
+ (set! location this-loc))))
+ stack)
+ (let ((dp-args (append (list 0 *default-log-port* location" " ) in-args)))
+ (apply debug:print dp-args))))
(define (debug:print-error n e . params)
;; normal print
(if (debug:debug-mode n)
(with-output-to-port (or e (current-error-port))
Index: dashboard-tests.scm
==================================================================
--- dashboard-tests.scm
+++ dashboard-tests.scm
@@ -414,11 +414,11 @@
;;======================================================================
;;
;;======================================================================
-(define (examine-test run-id test-id) ;; run-id run-key origtest)
+(define (dashboard-tests: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 (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))
Index: dashboard.scm
==================================================================
--- dashboard.scm
+++ dashboard.scm
@@ -109,10 +109,11 @@
updaters
updating
uidat ;; needs to move to tabdat at some time
hide-not-hide-tabs
)
+
(define (dboard:commondat-make)
(make-dboard:commondat
curr-tab-num: 0
tabdats: (make-hash-table)
@@ -121,37 +122,42 @@
updaters: (make-hash-table)
updating: #f
hide-not-hide-tabs: #f
))
+;; RA => returns the tabdat stored at hashkey passed in commondat-tabdats table (e.g. 0 gives summary)
+;;
(define (dboard:common-get-tabdat commondat #!key (tab-num #f))
(hash-table-ref/default
(dboard:commondat-tabdats commondat)
- (or tab-num (dboard:commondat-curr-tab-num commondat))
+ (or tab-num (dboard:commondat-curr-tab-num commondat)) ;; tab-num value is curr-tab-num value in passed commondat
#f))
+;; RA => sets the tabdat passed to the hashkey at commondat:tabdats hash table
+;;
(define (dboard:common-set-tabdat! commondat tabnum tabdat)
(hash-table-set!
(dboard:commondat-tabdats commondat)
tabnum
tabdat))
-;; gets and calls updater based on curr-tab-num
+;; gets and calls updater list based on curr-tab-num
(define (dboard:common-run-curr-updaters commondat #!key (tab-num #f))
(if (dboard:common-get-tabdat commondat tab-num: tab-num) ;; only update if there is a tabdat
(let* ((tnum (or tab-num (dboard:commondat-curr-tab-num commondat)))
(updaters (hash-table-ref/default (dboard:commondat-updaters commondat)
tnum
'())))
(debug:print 4 *default-log-port* "Found these updaters: " updaters " for tab-num: " tnum)
- (for-each
+ (for-each ;; perform the function calls for the complete updaters list
(lambda (updater)
;; (debug:print 3 *default-log-port* "Running " updater)
(updater))
updaters))))
;; if tab-num passed in then use it, otherwise look in commondat at curr-tab-num
+;; adds the updater passed in the updaters list at that hashkey
;;
(define (dboard:commondat-add-updater commondat updater #!key (tab-num #f))
(let* ((tnum (or tab-num
(dboard:commondat-curr-tab-num commondat)))
(curr-updaters (hash-table-ref/default (dboard:commondat-updaters commondat) tnum '())))
@@ -211,12 +217,13 @@
states ;; states for -state s1,s2 ...
statuses ;; statuses for -status s1,s2 ...
;; Selector variables
curr-run-id ;; current row to display in Run summary view
+ prev-run-id ;; previous runid selected before current runid was selected (used in xor-two-runs runs summary mode
curr-test-ids ;; used only in dcommon:run-update which is used in newdashboard
- ((filters-changed #f) : boolean) ;; to to indicate that the user changed filters for this tab
+ ((filters-changed #t) : boolean) ;; to to indicate that the user changed filters for this tab
((last-filter-str "") : string) ;; conc the target runname and testpatt for a signature of changed filters
((hide-empty-runs #f) : boolean)
((hide-not-hide #t) : boolean) ;; toggle for hide/not hide empty runs
(hide-not-hide-button #f)
((searchpatts (make-hash-table)) : hash-table) ;;
@@ -243,10 +250,19 @@
;; tab data
((view-changed #t) : boolean)
((xadj 0) : number) ;; x slider number (if using canvas)
((yadj 0) : number) ;; y slider number (if using canvas)
+ ;; runs-summary tab state
+ ((runs-summary-modes '((one-run . "Show One Run") (xor-two-runs . "XOR Two Runs") (xor-two-runs-hide-clean . "XOR; Hide Clean")) ) : list)
+ ((runs-summary-mode-buttons '()) : list)
+ ((runs-summary-mode 'one-run) : symbol)
+ ((runs-summary-mode-change-callbacks '()) : list)
+ (runs-summary-source-runname-label #f)
+ (runs-summary-dest-runname-label #f)
+ ;; runs summary view
+
tests-tree ;; used in newdashboard
)
(define (dboard:tabdat-target-string vec)
(let ((targ (dboard:tabdat-target vec)))
@@ -472,13 +488,21 @@
;; gets all the tests for run-id that match testnamepatt and key-vals, merges them
;;
;; NOTE: Yes, this is used
;;
(define (dboard:get-tests-for-run-duplicate tabdat run-id run testnamepatt key-vals)
- (let* ((num-to-get 100)
+ (let* ((num-to-get
+ (let ((num-tests-from-config (configf:lookup *configdat* "setup" "num-tests-to-get")))
+ (if num-tests-from-config
+ (begin
+ (BB> "override num-tests 100 -> "num-tests-from-config)
+ (string->number num-tests-from-config))
+ 100)))
(states (hash-table-keys (dboard:tabdat-state-ignore-hash tabdat)))
(statuses (hash-table-keys (dboard:tabdat-status-ignore-hash tabdat)))
+ (do-not-use-db-file-timestamps (configf:lookup *configdat* "setup" "do-not-use-db-file-timestamps")) ;; this still hosts runs-summary-tab
+ (do-not-use-query-timestamps (configf:lookup *configdat* "setup" "do-not-use-query-timestamps")) ;; this no longer troubles runs-summary-tab
(sort-info (get-curr-sort))
(sort-by (vector-ref sort-info 1))
(sort-order (vector-ref sort-info 2))
(bubble-type (if (member sort-order '(testname))
'testname
@@ -487,19 +511,25 @@
(run-dat (or (hash-table-ref/default (dboard:tabdat-allruns-by-id tabdat) run-id #f)
(let ((rd (dboard:rundat-make-init run: run key-vals: key-vals)))
(hash-table-set! (dboard:tabdat-allruns-by-id tabdat) run-id rd)
rd)))
;; (prev-tests (dboard:rundat-tests prev-dat)) ;; (vector-ref prev-dat 1))
- (last-update (dboard:rundat-last-update run-dat)) ;; (vector-ref prev-dat 3))
+ (last-update
+ (if do-not-use-query-timestamps
+ 0
+ (dboard:rundat-last-update run-dat)
+ ;;(hash-table-ref/default (dboard:tabdat-run-update-times tabdat) run-id 0)
+ ))
+
(db-path (or (dboard:rundat-db-path run-dat)
(let* ((db-dir (tasks:get-task-db-path))
(db-pth (conc db-dir "/" run-id ".db")))
(dboard:rundat-db-path-set! run-dat db-pth)
db-pth)))
- (tmptests (if (or (configf:lookup *configdat* "setup" "do-not-use-db-file-timestamps")
- (>= (file-modification-time db-path) last-update))
- (rmt:get-tests-for-run run-id testnamepatt states statuses ;; run-id testpatt states statuses
+ (tmptests (if (or do-not-use-db-file-timestamps
+ (>= (common:lazy-modification-time db-path) last-update))
+ (rmt:get-tests-for-run run-id testnamepatt states statuses ;; run-id testpatt states statuses
(dboard:rundat-run-data-offset run-dat)
num-to-get
(dboard:tabdat-hide-not-hide tabdat) ;; no-in
sort-by ;; sort-by
sort-order ;; sort-order
@@ -539,11 +569,14 @@
;; set last-update to 0 if still getting data incrementally
(if (> (dboard:rundat-run-data-offset run-dat) 0)
(begin
;; (print "run-data-offset: " (dboard:rundat-run-data-offset run-dat) ", setting last-update to 0")
- (dboard:rundat-last-update-set! run-dat 0))
+ ;; (dboard:rundat-last-update-set! run-dat 0)
+ (dboard:rundat-last-update-set! run-dat 0))
+ ;; (hash-table-set! (dboard:tabdat-run-update-times tabdat) run-id (- start-time 3))
+
(dboard:rundat-last-update-set! run-dat (- (current-seconds) 2))) ;; go back two seconds in time to ensure all changes are captured.
;; (debug:print-info 0 *default-log-port* "tests-ht: " (hash-table-keys tests-ht))
tests-ht))
@@ -637,10 +670,13 @@
(if (> (dboard:rundat-run-data-offset run-struct) 0)
(loop run tal new-res newmaxtests) ;; not done getting data for this run
(loop (car tal)(cdr tal) new-res newmaxtests)))))))
(dboard:tabdat-filters-changed-set! tabdat #f)
(dboard:update-tree tabdat runs-hash header tb)))
+
+
+
(define *collapsed* (make-hash-table))
(define (toggle-hide lnum uidat) ; fulltestname)
(let* ((btn (vector-ref (dboard:uidat-get-lftcol uidat) lnum))
@@ -790,11 +826,10 @@
(lftcol (dboard:uidat-get-lftcol uidat))
(tableheader (dboard:uidat-get-header uidat))
(table (dboard:uidat-get-runsvec uidat))
(coln 0)
(all-test-names (make-hash-table)))
-
;; create a concise list of test names
;;
(for-each
(lambda (rundat)
(if rundat
@@ -892,10 +927,11 @@
(curr-title (vector-ref buttondat 2))) ;; (iup:attribute button "TITLE")))
(if (not (equal? curr-color color))
(iup:attribute-set! button "BGCOLOR" color))
(if (not (equal? curr-title buttontxt))
(iup:attribute-set! button "TITLE" buttontxt))
+ ;;(print "RA => testdat " testdat " teststate " teststate " teststatus " teststatus " buttondat " buttondat " curr-color " curr-color " curr-title " curr-title "buttontxt" buttontxt " title " curr-title )
(vector-set! buttondat 0 run-id)
(vector-set! buttondat 1 color)
(vector-set! buttondat 2 buttontxt)
(vector-set! buttondat 3 testdat)
(vector-set! buttondat 4 run-key)))
@@ -1223,32 +1259,37 @@
;; #:multiline "YES")))
;; (dboard:tabdat-logs-textbox-set! tabdat logs-tb)
;; logs-tb))
(define (dboard:runs-tree-browser commondat tabdat)
- (let* ((tb (iup:treebox
- #:value 0
- #:name "Runs"
- #:expand "YES"
- #:addexpanded "NO"
- #:selection-cb
- (lambda (obj id state)
- (debug:catch-and-dump
- (lambda ()
- (let* ((run-path (tree:node->path obj id))
- (run-id (tree-path->run-id tabdat (cdr run-path))))
- ;; (dboard:tabdat-view-changed-set! tabdat #t) ;; ?? done below when run-id is a number
- (dboard:tabdat-target-set! tabdat (cdr run-path)) ;; (print "run-path: " run-path)
- (dboard:tabdat-layout-update-ok-set! tabdat #f)
- (if (number? run-id)
- (begin
- (dboard:tabdat-curr-run-id-set! tabdat run-id)
- (dboard:tabdat-view-changed-set! tabdat #t))
- (debug:print-error 5 *default-log-port* "tree-path->run-id returned non-number " run-id))))
- "treebox"))
- ;; (print "path: " (tree:node->path obj id) " run-id: " run-id)
- )))
+ (let* ((tb
+ (iup:treebox
+ #:value 0
+ #:name "Runs"
+ #:expand "YES"
+ #:addexpanded "NO"
+ #:selection-cb
+ (lambda (obj id state)
+ (debug:catch-and-dump
+ (lambda ()
+ (let* ((run-path (tree:node->path obj id))
+ (run-id (tree-path->run-id tabdat (cdr run-path))))
+ ;; (dboard:tabdat-view-changed-set! tabdat #t) ;; ?? done below when run-id is a number
+ (dboard:tabdat-target-set! tabdat (cdr run-path)) ;; (print "run-path: " run-path)
+ (dboard:tabdat-layout-update-ok-set! tabdat #f)
+ (if (number? run-id)
+ (begin
+ ;; capture last two in tabdat.
+ (dboard:tabdat-prev-run-id-set!
+ tabdat
+ (dboard:tabdat-curr-run-id tabdat))
+ (dboard:tabdat-curr-run-id-set! tabdat run-id)
+ (dboard:tabdat-view-changed-set! tabdat #t))
+ (debug:print-error 5 *default-log-port* "tree-path->run-id returned non-number " run-id))))
+ "treebox"))
+ ;; (print "path: " (tree:node->path obj id) " run-id: " run-id)
+ )))
(dboard:tabdat-runs-tree-set! tabdat tb)
tb))
;;======================================================================
;; R U N C O N T R O L S
@@ -1428,129 +1469,182 @@
userdata: (conc "run-id: " run-id))
(hash-table-set! (dboard:tabdat-path-run-ids tabdat) run-path run-id)
;; (set! colnum (+ colnum 1))
))))
run-ids)))
-
-(define (dashboard:one-run-updater commondat tabdat tb cell-lookup run-matrix)
- (let* ((last-runs-update (dboard:tabdat-last-runs-update tabdat))
+
+(define (dashboard:tests-ht->tests-dat tests-ht)
+ (reverse
+ (sort
+ (hash-table-values tests-ht)
+ (lambda (a b)
+ (let ((a-test-name (db:test-get-testname a))
+ (a-item-path (db:test-get-item-path a))
+ (b-test-name (db:test-get-testname b))
+ (b-item-path (db:test-get-item-path b)))
+ (cond
+ ((< 0 (string-compare3 a-test-name b-test-name)) #t)
+ ((> 0 (string-compare3 a-test-name b-test-name)) #f)
+ ((< 0 (string-compare3 a-item-path b-item-path)) #t)
+ (else #f)))))))
+
+
+(define (dashboard:run-id->tests-mindat run-id tabdat runs-hash)
+ (let* ((run (hash-table-ref/default runs-hash run-id #f))
+ (key-vals (rmt:get-key-vals run-id))
+ (testnamepatt (or (dboard:tabdat-test-patts tabdat) "%/%"))
+ (tests-ht (dboard:get-tests-for-run-duplicate tabdat run-id run testnamepatt key-vals))
+ (tests-dat (dashboard:tests-ht->tests-dat tests-ht))
+ (tests-mindat (dcommon:minimize-test-data tests-dat))) ;; reduces data for display
+ (dboard:tabdat-last-runs-update-set! tabdat (- (current-seconds) 2))
+ (hash-table-set! (dboard:tabdat-last-test-dat tabdat) run-id tests-dat)
+ (hash-table-set! (dboard:tabdat-run-update-times tabdat) run-id (- (current-seconds) 10))
+ (when (not run)
+ (BB> "ERROR: NO RUN FOR RUN-ID run-id="run-id)
+ (BB> "runs-hash-> " (hash-table->alist runs-hash))
+ )
+ tests-mindat))
+
+(define (dashboard:runs-summary-xor-matrix-content tabdat runs-hash #!key (hide-clean #f))
+ (let* ((src-run-id (dboard:tabdat-prev-run-id tabdat))
+ (dest-run-id (dboard:tabdat-curr-run-id tabdat)))
+ (if (and src-run-id dest-run-id)
+ (dcommon:xor-tests-mindat
+ (dashboard:run-id->tests-mindat src-run-id tabdat runs-hash)
+ (dashboard:run-id->tests-mindat dest-run-id tabdat runs-hash)
+ hide-clean: hide-clean)
+ #f)))
+
+
+(define (dashboard:get-runs-hash tabdat)
+ (let* ((last-runs-update 0);;(dboard:tabdat-last-runs-update tabdat))
(runs-dat (rmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f last-runs-update))
(runs-header (vector-ref runs-dat 0)) ;; 0 is header, 1 is list of records
+ (runs (vector-ref runs-dat 1))
(run-id (dboard:tabdat-curr-run-id tabdat))
(runs-hash (let ((ht (make-hash-table)))
(for-each (lambda (run)
(hash-table-set! ht (db:get-value-by-header run runs-header "id") run))
- (vector-ref runs-dat 1))
- ht)))
+ runs) ht)))
+ runs-hash))
+
+
+(define (dashboard:runs-summary-updater commondat tabdat tb cell-lookup run-matrix)
+ (dashboard:do-update-rundat tabdat)
+ (dboard:runs-summary-control-panel-updater tabdat)
+ (let* ((last-runs-update (dboard:tabdat-last-runs-update tabdat))
+ (runs-dat (rmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f last-runs-update))
+ (runs-header (vector-ref runs-dat 0)) ;; 0 is header, 1 is list of records
+ (runs (vector-ref runs-dat 1))
+ (run-id (dboard:tabdat-curr-run-id tabdat))
+ (runs-hash (dashboard:get-runs-hash tabdat))
+ ;; (runs-hash (let ((ht (make-hash-table)))
+ ;; (for-each (lambda (run)
+ ;; (hash-table-set! ht (db:get-value-by-header run runs-header "id") run))
+ ;; runs)
+ ;; ht))
+ )
(dboard:update-tree tabdat runs-hash runs-header tb)
(if run-id
- (let* (
-
- (last-update (hash-table-ref/default (dboard:tabdat-run-update-times tabdat) run-id 0))
- (db-path (or (hash-table-ref/default (dboard:tabdat-run-db-paths tabdat) run-id #f)
- (let* ((db-dir (tasks:get-task-db-path))
- (db-pth (conc db-dir "/" run-id ".db")))
- (hash-table-set! (dboard:tabdat-run-db-paths tabdat) run-id db-pth)
- db-pth)))
- (tests-dat (if (or (not run-id)
- (configf:lookup *configdat* "setup" "do-not-use-db-file-timestamps")
- (not (hash-table-exists? (dboard:tabdat-last-test-dat tabdat) run-id))
- (>= (file-modification-time db-path) last-update))
- (dboard:get-tests-dat tabdat run-id last-update)
- (hash-table-ref (dboard:tabdat-last-test-dat tabdat) run-id)))
- (tests-mindat (dcommon:minimize-test-data tests-dat))
- (indices (common:sparse-list-generate-index tests-mindat)) ;; proc: set-cell))
- (row-indices (cadr indices))
- (col-indices (car indices))
- (max-row (if (null? row-indices) 1 (common:max (map cadr row-indices))))
- (max-col (if (null? col-indices) 1 (common:max (map cadr col-indices))))
- (max-visible (max (- (dboard:tabdat-num-tests tabdat) 15) 3)) ;; (dboard:tabdat-num-tests tabdat) is proportional to the size of the window
- (numrows 1)
- (numcols 1)
- (changed #f)
- )
- (dboard:tabdat-last-runs-update-set! tabdat (- (current-seconds) 2))
- (hash-table-set! (dboard:tabdat-last-test-dat tabdat) run-id tests-dat)
- (hash-table-set! (dboard:tabdat-run-update-times tabdat) run-id (- (current-seconds) 10))
- (dboard:tabdat-filters-changed-set! tabdat #f)
- (let loop ((pass-num 0)
- (changed #f))
- ;; Update the runs tree
- (dboard:update-tree tabdat runs-hash runs-header tb)
-
- (if (eq? pass-num 1)
- (begin ;; big reset
- (iup:attribute-set! run-matrix "CLEARVALUE" "ALL") ;; NOTE: Was CONTENTS
- (iup:attribute-set! run-matrix "CLEARATTRIB" "CONTENTS")
- (iup:attribute-set! run-matrix "RESIZEMATRIX" "YES")))
-
- (if (> max-col (string->number (iup:attribute run-matrix "NUMCOL")))
- (iup:attribute-set! run-matrix "NUMCOL" max-col ))
-
- (let ((effective-max-row (if (< max-row max-visible) max-visible max-row)))
- (if (> effective-max-row (string->number (iup:attribute run-matrix "NUMLIN")))
- (iup:attribute-set! run-matrix "NUMLIN" effective-max-row )))
-
- ;; Row labels
- (for-each (lambda (ind)
- (let* ((name (car ind))
- (num (cadr ind))
- (key (conc num ":0")))
- (if (not (equal? (iup:attribute run-matrix key) name))
- (begin
- (set! changed #t)
- (iup:attribute-set! run-matrix key name)))))
- row-indices)
- ;; (print "row-indices: " row-indices " col-indices: " col-indices)
- (if (and (eq? pass-num 0) changed)
- (loop 1 #t)) ;; force second pass
-
- ;; Cell contents
- (for-each (lambda (entry)
- ;; (print "entry: " entry)
- (let* ((row-name (cadr entry))
- (col-name (car entry))
- (valuedat (caddr entry))
- (test-id (list-ref valuedat 0))
- (test-name row-name) ;; (list-ref valuedat 1))
- (item-path col-name) ;; (list-ref valuedat 2))
- (state (list-ref valuedat 1))
- (status (list-ref valuedat 2))
- (value (gutils:get-color-for-state-status state status))
- (row-num (cadr (assoc row-name row-indices)))
- (col-num (cadr (assoc col-name col-indices)))
- (key (conc row-num ":" col-num)))
- (hash-table-set! cell-lookup key test-id)
- (if (not (equal? (iup:attribute run-matrix key) (cadr value)))
- (begin
- (set! changed #t)
- (iup:attribute-set! run-matrix key (cadr value))
- (iup:attribute-set! run-matrix (conc "BGCOLOR" key) (car value))))))
- tests-mindat)
-
- ;; Col labels - do after setting Cell contents so they are accounted for in the size calc.
-
- (for-each (lambda (ind)
- (let* ((name (car ind))
- (num (cadr ind))
- (key (conc "0:" num)))
- (if (not (equal? (iup:attribute run-matrix key) name))
- (begin
- (set! changed #t)
- (iup:attribute-set! run-matrix key name)
- (if (<= num max-col)
- (iup:attribute-set! run-matrix "FITTOTEXT" (conc "C" num)))))))
- col-indices)
-
- (if (and (eq? pass-num 0) changed)
- (loop 1 #t)) ;; force second pass due to column labels changing
-
- ;; (debug:print 0 *default-log-port* "one-run-updater, changed: " changed " pass-num: " pass-num)
- ;; (print "one-run-updater, changed: " changed " pass-num: " pass-num)
- (if changed (iup:attribute-set! run-matrix "REDRAW" "ALL"))))))
-
- )
+ (let* ((matrix-content
+ (case (dboard:tabdat-runs-summary-mode tabdat)
+ ((one-run) (dashboard:run-id->tests-mindat run-id tabdat runs-hash))
+ ((xor-two-runs) (dashboard:runs-summary-xor-matrix-content tabdat runs-hash))
+ ((xor-two-runs-hide-clean) (dashboard:runs-summary-xor-matrix-content tabdat runs-hash hide-clean: #t))
+ (else (dashboard:run-id->tests-mindat run-id tabdat runs-hash)))))
+ (when matrix-content
+ (let* ((indices (common:sparse-list-generate-index matrix-content)) ;; proc: set-cell))
+ (row-indices (cadr indices))
+ (col-indices (car indices))
+ (max-row (if (null? row-indices) 1 (common:max (map cadr row-indices))))
+ (max-col (if (null? col-indices) 1 (common:max (map cadr col-indices))))
+ (max-visible (max (- (dboard:tabdat-num-tests tabdat) 15) 3)) ;; (dboard:tabdat-num-tests tabdat) is proportional to the size of the window
+ (numrows 1)
+ (numcols 1)
+ (changed #f)
+ )
+
+
+
+
+
+ (dboard:tabdat-filters-changed-set! tabdat #f)
+ (let loop ((pass-num 0)
+ (changed #f))
+ ;; Update the runs tree
+ (dboard:update-tree tabdat runs-hash runs-header tb)
+
+ (if (eq? pass-num 1)
+ (begin ;; big reset
+ (iup:attribute-set! run-matrix "CLEARVALUE" "ALL") ;; NOTE: Was CONTENTS
+ (iup:attribute-set! run-matrix "CLEARATTRIB" "CONTENTS")
+ (iup:attribute-set! run-matrix "RESIZEMATRIX" "YES")))
+
+ (if (> max-col (string->number (iup:attribute run-matrix "NUMCOL")))
+ (iup:attribute-set! run-matrix "NUMCOL" max-col ))
+
+ (let ((effective-max-row (if (< max-row max-visible) max-visible max-row)))
+ (if (> effective-max-row (string->number (iup:attribute run-matrix "NUMLIN")))
+ (iup:attribute-set! run-matrix "NUMLIN" effective-max-row )))
+
+ ;; Row labels
+ (for-each (lambda (ind)
+ (let* ((name (car ind))
+ (num (cadr ind))
+ (key (conc num ":0")))
+ (if (not (equal? (iup:attribute run-matrix key) name))
+ (begin
+ (set! changed #t)
+ (iup:attribute-set! run-matrix key name)))))
+ row-indices)
+ ;; (print "row-indices: " row-indices " col-indices: " col-indices)
+ (if (and (eq? pass-num 0) changed)
+ (loop 1 #t)) ;; force second pass
+
+ ;; Cell contents
+ (for-each (lambda (entry)
+ ;; (print "entry: " entry)
+ (let* ((row-name (cadr entry))
+ (col-name (car entry))
+ (valuedat (caddr entry))
+ (test-id (list-ref valuedat 0))
+ (test-name row-name) ;; (list-ref valuedat 1))
+ (item-path col-name) ;; (list-ref valuedat 2))
+ (state (list-ref valuedat 1))
+ (status (list-ref valuedat 2))
+ (value (gutils:get-color-for-state-status state status))
+ (row-num (cadr (assoc row-name row-indices)))
+ (col-num (cadr (assoc col-name col-indices)))
+ (key (conc row-num ":" col-num)))
+ (hash-table-set! cell-lookup key test-id)
+ (if (not (equal? (iup:attribute run-matrix key) (cadr value)))
+ (begin
+ (set! changed #t)
+ (iup:attribute-set! run-matrix key (cadr value))
+ (iup:attribute-set! run-matrix (conc "BGCOLOR" key) (car value))))))
+ matrix-content)
+
+ ;; Col labels - do after setting Cell contents so they are accounted for in the size calc.
+
+ (for-each (lambda (ind)
+ (let* ((name (car ind))
+ (num (cadr ind))
+ (key (conc "0:" num)))
+ (if (not (equal? (iup:attribute run-matrix key) name))
+ (begin
+ (set! changed #t)
+ (iup:attribute-set! run-matrix key name)
+ (if (<= num max-col)
+ (iup:attribute-set! run-matrix "FITTOTEXT" (conc "C" num)))))))
+ col-indices)
+
+ (if (and (eq? pass-num 0) changed)
+ (loop 1 #t)) ;; force second pass due to column labels changing
+
+ ;; (debug:print 0 *default-log-port* "runs-summary-updater, changed: " changed " pass-num: " pass-num)
+ ;; (print "runs-summary-updater, changed: " changed " pass-num: " pass-num)
+ (if changed (iup:attribute-set! run-matrix "REDRAW" "ALL")))))))))
;;======================================================================
;; S U M M A R Y
;;======================================================================
;;
@@ -1643,20 +1737,103 @@
(if success
(begin
;; (iup:attribute-set! tabs (conc "TABTITLE" tab-num) view-name)
(dboard:common-set-tabdat! commondat tab-num (dboard:tabdat-make-data))))
result-child))
+
+
+
+(define (dboard:runs-summary-buttons-updater tabdat)
+ (let loop ((buttons-left (dboard:tabdat-runs-summary-mode-buttons tabdat))
+ (modes-left (dboard:tabdat-runs-summary-modes tabdat)))
+ (if (or (null? buttons-left) (null? modes-left))
+ #t
+ (let* ((this-button (car buttons-left))
+ (mode-item (car modes-left))
+ (this-mode (car mode-item))
+ (sel-color "180 100 100")
+ (nonsel-color "170 170 170")
+ (current-mode (dboard:tabdat-runs-summary-mode tabdat)))
+ (if (eq? this-mode current-mode)
+ (iup:attribute-set! this-button "BGCOLOR" sel-color)
+ (iup:attribute-set! this-button "BGCOLOR" nonsel-color))
+ (loop (cdr buttons-left) (cdr modes-left))))))
+
+(define (dboard:runs-summary-xor-labels-updater tabdat)
+ (let ((source-runname-label (dboard:tabdat-runs-summary-source-runname-label tabdat))
+ (dest-runname-label (dboard:tabdat-runs-summary-dest-runname-label tabdat))
+ (mode (dboard:tabdat-runs-summary-mode tabdat)))
+ (when (and source-runname-label dest-runname-label)
+ (case mode
+ ((xor-two-runs xor-two-runs-hide-clean)
+ (let* ((curr-run-id (dboard:tabdat-curr-run-id tabdat))
+ (prev-run-id (dboard:tabdat-prev-run-id tabdat))
+ (curr-runname (if curr-run-id
+ (rmt:get-run-name-from-id curr-run-id)
+ "None"))
+ (prev-runname (if prev-run-id
+ (rmt:get-run-name-from-id prev-run-id)
+ "None")))
+ (iup:attribute-set! source-runname-label "TITLE" (conc " SRC: "prev-runname" "))
+ (iup:attribute-set! dest-runname-label "TITLE" (conc "DEST: "curr-runname" "))))
+ (else
+ (iup:attribute-set! source-runname-label "TITLE" "")
+ (iup:attribute-set! dest-runname-label "TITLE" ""))))))
+
+(define (dboard:runs-summary-control-panel-updater tabdat)
+ (dboard:runs-summary-xor-labels-updater tabdat)
+ (dboard:runs-summary-buttons-updater tabdat))
+
+
+;; setup buttons and callbacks to switch between modes in runs summary tab
+;;
+(define (dashboard:runs-summary-control-panel tabdat)
+ (let* ((summary-buttons ;; build buttons
+ (map
+ (lambda (mode-item)
+ (let* ((this-mode (car mode-item))
+ (this-mode-label (cdr mode-item)))
+ (iup:button this-mode-label
+ #:action
+ (lambda (obj)
+ (debug:catch-and-dump
+ (lambda ()
+ (dboard:tabdat-runs-summary-mode-set! tabdat this-mode)
+ (dboard:runs-summary-control-panel-updater tabdat))
+ "runs summary control panel updater")))))
+ (dboard:tabdat-runs-summary-modes tabdat)))
+ (summary-buttons-hbox (apply iup:hbox summary-buttons))
+ (xor-runname-labels-hbox
+ (iup:hbox
+ (let ((temp-label
+ (iup:label "" #:size "125x15" #:fontsize "10" )))
+ (dboard:tabdat-runs-summary-source-runname-label-set! tabdat temp-label)
+ temp-label
+ )
+ (let ((temp-label
+ (iup:label "" #:size "125x15" #:fontsize "10")))
+ (dboard:tabdat-runs-summary-dest-runname-label-set! tabdat temp-label)
+ temp-label))))
+ (dboard:tabdat-runs-summary-mode-buttons-set! tabdat summary-buttons)
+
+ ;; maybe wrap in a frame
+ (let ((res (iup:vbox summary-buttons-hbox xor-runname-labels-hbox )))
+ (dboard:runs-summary-control-panel-updater tabdat)
+ res
+ )))
+
+
;;======================================================================
;; R U N
;;======================================================================
;;
;; display and manage a single run at a time
;; This is the Run Summary tab
;;
-(define (dashboard:one-run commondat tabdat #!key (tab-num #f))
+(define (dashboard:runs-summary commondat tabdat #!key (tab-num #f))
(let* ((update-mutex (dboard:commondat-update-mutex commondat))
(tb (iup:treebox
#:value 0
#:name "Runs"
#:expand "YES"
@@ -1668,60 +1845,118 @@
;; (print "obj: " obj ", id: " id ", state: " state)
(let* ((run-path (tree:node->path obj id))
(run-id (tree-path->run-id tabdat (cdr run-path))))
(if (number? run-id)
(begin
+ (dboard:tabdat-prev-run-id-set!
+ tabdat
+ (dboard:tabdat-curr-run-id tabdat))
+
(dboard:tabdat-curr-run-id-set! tabdat run-id)
(dboard:tabdat-layout-update-ok-set! tabdat #f)
;; (dashboard:update-run-summary-tab)
)
;; (debug:print-error 0 *default-log-port* "tree-path->run-id returned non-number " run-id)
)))
- "selection-cb in one-run")
+ "selection-cb in runs-summary")
;; (print "path: " (tree:node->path obj id) " run-id: " run-id)
)))
(cell-lookup (make-hash-table))
(run-matrix (iup:matrix
#:expand "YES"
#:click-cb
+
(lambda (obj lin col status)
- (let* ((toolpath (car (argv)))
- (key (conc lin ":" col))
- (test-id (hash-table-ref/default cell-lookup key -1))
- (cmd (conc toolpath " -test " (dboard:tabdat-curr-run-id tabdat) "," test-id "&")))
- (system cmd)))))
- (one-run-updater
+ (debug:catch-and-dump
+ (lambda ()
+
+ ;; Bummer - we dont have the global get/set api mapped in chicken
+ ;; (let* ((modkeys (iup:global "MODKEYSTATE")))
+ ;; (BB> "modkeys="modkeys))
+
+ (BB> "click-cb: obj="obj" lin="lin" col="col" status="status)
+ ;; status is corrupted on Brandon's home machine. will have to wait until after shutdown to see if it is still broken in PDX SLES
+ (let* ((toolpath (car (argv)))
+ (key (conc lin ":" col))
+ (test-id (hash-table-ref/default cell-lookup key -1))
+ (run-id (dboard:tabdat-curr-run-id tabdat))
+ (run-info (rmt:get-run-info run-id))
+ (target (rmt:get-target run-id))
+ (runname (db:get-value-by-header (db:get-rows run-info)
+ (db:get-header run-info) "runname"))
+ (test-name (db:test-get-testname (rmt:get-test-info-by-id run-id test-id)))
+ (testpatt (let ((tlast (rmt:tasks-get-last target runname)))
+ (if tlast
+ (let ((tpatt (tasks:task-get-testpatt tlast)))
+ (if (member tpatt '("0" 0)) ;; known bad historical value - remove in 2017
+ "%"
+ tpatt))
+ "%")))
+ (item-path (db:test-get-item-path (rmt:get-test-info-by-id run-id test-id)))
+ (item-test-path (conc test-name "/" (if (equal? item-path "")
+ "%"
+ item-path)))
+ (status-chars (char-set->list (string->char-set status)))
+ (testpanel-cmd (conc toolpath " -test " (dboard:tabdat-curr-run-id tabdat) "," test-id " &")))
+ (BB> "status-chars=["status-chars"] status=["status"]")
+ (cond
+ ((member #\1 status-chars) ;; 1 is left mouse button
+ (system testpanel-cmd))
+
+ ((member #\2 status-chars) ;; 2 is middle mouse button
+
+ (BB> "mmb- test-name="test-name" testpatt="testpatt)
+ (iup:show (dashboard:popup-menu run-id test-id target runname test-name testpatt item-test-path) ;; popup-menu
+ #:x 'mouse
+ #:y 'mouse
+ #:modal? "NO")
+ )
+ (else
+ (BB> "unhandled status in run-summary-click-cb. Doing right click action. (status is corrupted on Brandon's ubuntu host - bad/buggy iup install??" )
+ (iup:show (dashboard:popup-menu run-id test-id target runname test-name testpatt item-test-path) ;; popup-menu
+ #:x 'mouse
+ #:y 'mouse
+ #:modal? "NO")
+ )
+ )
+
+ )) "runs-summary-click-callback"))))
+ (runs-summary-updater
(lambda ()
(mutex-lock! update-mutex)
(if (or (dashboard:database-changed? commondat tabdat)
(dboard:tabdat-view-changed tabdat))
(debug:catch-and-dump
(lambda () ;; check that run-matrix is initialized before calling the updater
(if run-matrix
- (dashboard:one-run-updater commondat tabdat tb cell-lookup run-matrix)))
- "dashboard:one-run-updater")
+ (dashboard:runs-summary-updater commondat tabdat tb cell-lookup run-matrix)))
+ "dashboard:runs-summary-updater")
)
- (mutex-unlock! update-mutex))))
- (dboard:commondat-add-updater commondat one-run-updater tab-num: tab-num)
+ (mutex-unlock! update-mutex)))
+ (runs-summary-control-panel (dashboard:runs-summary-control-panel tabdat))
+ )
+ (dboard:commondat-add-updater commondat runs-summary-updater tab-num: tab-num)
(dboard:tabdat-runs-tree-set! tabdat tb)
(iup:vbox
(iup:split
+ #:value 200
tb
run-matrix)
- (dboard:make-controls commondat tabdat))))
+ (dboard:make-controls commondat tabdat extra-widget: runs-summary-control-panel))))
;;======================================================================
;; R U N S
;;======================================================================
-(define (dboard:make-controls commondat tabdat)
+(define (dboard:make-controls commondat tabdat #!key (extra-widget #f) )
(let ((btn-fontsz (dboard:tabdat-runs-btn-fontsz tabdat)))
(iup:hbox
(iup:vbox
(iup:frame
#:title "filter test and items"
- (iup:hbox
+ (iup:vbox
+ (iup:hbox
(iup:vbox
(iup:textbox #:size "120x15" #:fontsize "10" #:value "%"
#:expand "NO"
#:action (lambda (obj unk val)
(debug:catch-and-dump
@@ -1772,10 +2007,11 @@
#:dropdown "YES"
#:action (lambda (obj val index lbstate)
(set! *tests-sort-reverse* index)
(mark-for-update tabdat))))
(default-cmd (car (list-ref *tests-sort-type-index* *tests-sort-reverse*))))
+
(iuplistbox-fill-list sort-lb cmds-list selected-item: default-cmd)
(set! hide-empty (iup:button "HideEmpty"
;; #:expand HORIZONTAL"
#:expand "NO" #:size "80x15"
@@ -1799,14 +2035,25 @@
(iup:attribute-set! hide "BGCOLOR" nonsel-color)
(mark-for-update tabdat))))
(iup:attribute-set! hide "BGCOLOR" sel-color)
(iup:attribute-set! show "BGCOLOR" nonsel-color)
;; (dboard:tabdat-hide-not-hide-button-set! tabdat hideit) ;; never used, can eliminate ...
- (iup:vbox
- (iup:hbox hide show)
- hide-empty sort-lb)))
- )))
+ (iup:vbox
+ (iup:hbox hide show)
+ sort-lb)))
+ )
+
+ ;; insert extra widget here
+ (if extra-widget
+ extra-widget
+ (iup:hbox)) ;; empty widget
+
+
+
+
+ )))
+
(iup:frame
#:title "state/status filter"
(iup:vbox
(apply
iup:hbox
@@ -1844,24 +2091,66 @@
(iup:attribute-set! obj "MAX" (* maxruns 10))))
#:expand "HORIZONTAL"
#:max (* 10 (max (hash-table-size (dboard:tabdat-allruns-by-id tabdat)) 10))
#:min 0
#:step 0.01)))
- ;(iup:button "inc rows" #:action (lambda (obj)(dboard:tabdat-num-tests-set! tabdat (+ (dboard:tabdat-num-tests tabdat) 1))))
+ ;;(iup:button "inc rows" #:action (lambda (obj)(dboard:tabdat-num-tests-set! tabdat (+ (dboard:tabdat-num-tests tabdat) 1))))
;(iup:button "dec rows" #:action (lambda (obj)(dboard:tabdat-num-tests-set! tabdat (if (> (dboard:tabdat-num-tests tabdat) 0)(- (dboard:tabdat-num-tests tabdat) 1) 0))))
)))
-(define (dashboard:popup-menu buttndat run-id test-id target runname test-name testpatt item-test-path)
+(define (dashboard:popup-menu run-id test-id target runname test-name testpatt item-test-path)
(iup:menu
+ (iup:menu-item
+ "Test Control Panel"
+ #:action
+ (lambda (obj)
+ (let* ((toolpath (car (argv)))
+ (testpanel-cmd
+ (conc toolpath " -test " run-id "," test-id " &")))
+ (system testpanel-cmd)
+ )))
+
+ (iup:menu-item
+ (conc "View Log (not yet implemented) " item-test-path)
+ )
+
+ (iup:menu-item
+ (conc "Rerun " item-test-path)
+ #:action
+ (lambda (obj)
+ (common:run-a-command
+ (conc "megatest -set-state-status NOT_STARTED,n/a -run -target " target
+ " -runname " runname
+ " -testpatt " item-test-path
+ " -preclean -clean-cache"))))
+
+ (iup:menu-item
+ "Start xterm"
+ #:action
+ (lambda (obj)
+ (dcommon:examine-xterm run-id test-id)))
+
+ (iup:menu-item
+ (conc "Kill " item-test-path)
+ #:action
+ (lambda (obj)
+ ;; (rmt:test-set-state-status-by-id run-id test-id "KILLREQ" #f #f)
+ (common:run-a-command
+ (conc "megatest -set-state-status KILLREQ,n/a -target " target
+ " -runname " runname
+ " -testpatt " item-test-path
+ " -state RUNNING,REMOTEHOSTSTART,LAUNCHED"))))
+
+
(iup:menu-item
"Run"
(iup:menu
(iup:menu-item
(conc "Rerun " testpatt)
#:action
(lambda (obj)
- ;; (print "buttndat: " buttndat " run-id: " run-id " test-id: " test-id " target: " target " runname: " runname " test-name: " test-name " testpatt: " testpatt "item-path : " item-path)
+ ;; (print " run-id: " run-id " test-id: " test-id " target: " target " runname: " runname " test-name: " test-name " testpatt: " testpatt "item-path : " item-path)
(common:run-a-command
(conc "megatest -run -target " target
" -runname " runname
" -testpatt " testpatt
" -preclean -clean-cache")
@@ -1880,11 +2169,20 @@
#:action
(lambda (obj)
(common:run-a-command
(conc "megatest -remove-runs -target " target
" -runname " runname
- " -testpatt % "))))))
+ " -testpatt % "))))
+ (iup:menu-item ;; RADT => itemize this run lists before merging with v1.61
+ "Kill Complete Run"
+ #:action
+ (lambda (obj)
+ (common:run-a-command
+ (conc "megatest -set-state-status KILLREQ,n/a -target " target
+ " -runname " runname
+ " -testpatt % "
+ " -state RUNNING,REMOTEHOSTSTART,LAUNCHED"))))))
(iup:menu-item
"Test"
(iup:menu
(iup:menu-item
(conc "Rerun " item-test-path)
@@ -1939,11 +2237,11 @@
))))
(define (make-dashboard-buttons commondat) ;; runs-sum-dat new-view-dat)
(let* ((stats-dat (dboard:tabdat-make-data))
(runs-dat (dboard:tabdat-make-data))
- (onerun-dat (dboard:tabdat-make-data))
+ (onerun-dat (dboard:tabdat-make-data)) ;; name for run-summary structure
(runcontrols-dat (dboard:tabdat-make-data))
(runtimes-dat (dboard:tabdat-make-data))
(nruns (dboard:tabdat-numruns runs-dat))
(ntests (dboard:tabdat-num-tests runs-dat))
(keynames (dboard:tabdat-dbkeys runs-dat))
@@ -2069,11 +2367,11 @@
"%")))
(item-path (db:test-get-item-path (rmt:get-test-info-by-id run-id test-id)))
(item-test-path (conc test-name "/" (if (equal? item-path "")
"%"
item-path))))
- (iup:show (dashboard:popup-menu buttndat run-id test-id target runname test-name testpatt item-test-path) ;; popup-menu
+ (iup:show (dashboard:popup-menu run-id test-id target runname test-name testpatt item-test-path) ;; popup-menu
#:x 'mouse
#:y 'mouse
#:modal? "NO")
;; (print "got here")
))
@@ -2148,11 +2446,11 @@
(dboard:commondat-please-update-set! commondat #t)
(dboard:tabdat-layout-update-ok-set! tabdat #t)))
"tabchangepos"))
(dashboard:summary commondat stats-dat tab-num: 0)
runs-view
- (dashboard:one-run commondat onerun-dat tab-num: 2)
+ (dashboard:runs-summary commondat onerun-dat tab-num: 2)
;; (dashboard:new-view db data new-view-dat tab-num: 3)
(dashboard:run-controls commondat runcontrols-dat tab-num: 3)
(dashboard:run-times commondat runtimes-dat tab-num: 4)
additional-views)))
;; (set! (iup:callback tabs tabchange-cb:) (lambda (a b c)(print "SWITCHED TO TAB: " a " " b " " c)))
@@ -2251,10 +2549,12 @@
;; point inside line
;;
(define-inline (dashboard:px-between px lx1 lx2)
(and (< lx1 px)(> lx2 px)))
+;;Not reference anywhere
+;;
;; can a bar be placed in row "rownum" covering x1 to x2 without overlapping with existing
;; bars? Use num-rows to check that a block will fit from rownum to (+ rownum num-rows)
;;
(define (dashboard:row-collision rowhash rownum x1 x2 #!key (num-rows #f))
(let ((lastrow (if num-rows (+ rownum num-rows) rownum)))
@@ -2842,37 +3142,112 @@
(runloop (car runtal)(cdr runtal) (+ run-num 1) newdoneruns)
(escapeloop #t) ;; (dboard:tabdat-layout-update-ok tabdat)
))))))))) ;; new-run-start-row
)))
(debug:print 2 *default-log-port* "no tabdat for run-times-tab-updater"))))
+
+(define (tabdat-values tabdat)
+ (let ((allruns (dboard:tabdat-allruns tabdat))
+ (allruns-by-id (dboard:tabdat-allruns-by-id tabdat))
+ (done-runs (dboard:tabdat-done-runs tabdat))
+ (not-done-runs (dboard:tabdat-not-done-runs tabdat))
+ (header (dboard:tabdat-header tabdat))
+ (keys (dboard:tabdat-keys tabdat))
+ (numruns (dboard:tabdat-numruns tabdat))
+ (tot-runs (dboard:tabdat-tot-runs tabdat))
+ (last-data-update (dboard:tabdat-last-data-update tabdat))
+ (runs-mutex (dboard:tabdat-runs-mutex tabdat))
+ (run-update-times (dboard:tabdat-run-update-times tabdat))
+ (last-test-dat (dboard:tabdat-last-test-dat tabdat))
+ (run-db-paths (dboard:tabdat-run-db-paths tabdat))
+ (buttondat (dboard:tabdat-buttondat tabdat))
+ (item-test-names (dboard:tabdat-item-test-names tabdat))
+ (run-keys (dboard:tabdat-run-keys tabdat))
+ (start-run-offset (dboard:tabdat-start-run-offset tabdat))
+ (start-test-offset (dboard:tabdat-start-test-offset tabdat))
+ (runs-btn-height (dboard:tabdat-runs-btn-height tabdat))
+ (all-test-names (dboard:tabdat-all-test-names tabdat))
+ (cnv (dboard:tabdat-cnv tabdat))
+ (command (dboard:tabdat-command tabdat))
+ (run-name (dboard:tabdat-run-name tabdat))
+ (states (dboard:tabdat-states tabdat))
+ (statuses (dboard:tabdat-statuses tabdat))
+ (curr-run-id (dboard:tabdat-curr-run-id tabdat))
+ (curr-test-ids (dboard:tabdat-curr-test-ids tabdat))
+ (state-ignore-hash (dboard:tabdat-state-ignore-hash tabdat))
+ (test-patts (dboard:tabdat-test-patts tabdat))
+ (target (dboard:tabdat-target tabdat))
+ (dbdir (dboard:tabdat-dbdir tabdat))
+ (monitor-db-path (dboard:tabdat-monitor-db-path tabdat))
+ (path-run-ids (dboard:tabdat-path-run-ids tabdat)))
+ (print "allruns is : " allruns)
+ (print "allruns-by-id is : " allruns-by-id)
+ (print "done-runs is : " done-runs)
+ (print "not-done-runs is : " not-done-runs)
+ (print "header is : " header )
+ (print "keys is : " keys)
+ (print "numruns is : " numruns)
+ (print "tot-runs is : " tot-runs)
+ (print "last-data-update is : " last-data-update)
+ (print "runs-mutex is : " runs-mutex)
+ (print "run-update-times is : " run-update-times)
+ (print "last-test-dat is : " last-test-dat)
+ (print "run-db-paths is : " run-db-paths)
+ (print "buttondat is : " buttondat)
+ (print "item-test-names is : " item-test-names)
+ (print "run-keys is : " run-keys)
+ (print "start-run-offset is : " start-run-offset)
+ (print "start-test-offset is : " start-test-offset)
+ (print "runs-btn-height is : " runs-btn-height)
+ (print "all-test-names is : " all-test-names)
+ (print "cnv is : " cnv)
+ (print "command is : " command)
+ (print "run-name is : " run-name)
+ (print "states is : " states)
+ (print "statuses is : " statuses)
+ (print "curr-run-id is : " curr-run-id)
+ (print "curr-test-ids is : " curr-test-ids)
+ (print "state-ignore-hash is : " state-ignore-hash)
+ (print "test-patts is : " test-patts)
+ (print "target is : " target)
+ (print "dbdir is : " dbdir)
+ (print "monitor-db-path is : " monitor-db-path)
+ (print "path-run-ids is : " path-run-ids)))
+
+(define (dashboard:do-update-rundat tabdat)
+ (update-rundat
+ tabdat
+ (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "runname" "%")
+ (dboard:tabdat-numruns tabdat)
+ (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "test-name" "%/%")
+ ;; (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "item-name" "%")
+ (let* ((dbkeys (dboard:tabdat-dbkeys tabdat)))
+ ;; (print "dbkeys: " dbkeys)
+ (let ((fres (if (dboard:tabdat-target tabdat)
+ (let ((ptparts (append (dboard:tabdat-target tabdat)(make-list (length dbkeys) "%"))))
+ (map (lambda (k v)(list k v)) dbkeys ptparts))
+ (let ((res '()))
+ ;; (print "target: " (dboard:tabdat-target tabdat))
+ (for-each (lambda (key)
+ (if (not (equal? key "runname"))
+ (let ((val (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) key #f)))
+ (if val (set! res (cons (list key val) res))))))
+ dbkeys)
+ res))))
+ ;; (debug:print 0 *default-log-port* "fres: " fres)
+ fres))))
(define (dashboard:runs-tab-updater commondat tab-num)
(debug:catch-and-dump
(lambda ()
(let* ((tabdat (dboard:common-get-tabdat commondat tab-num: tab-num))
(dbkeys (dboard:tabdat-dbkeys tabdat)))
- (update-rundat tabdat
- (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "runname" "%")
- (dboard:tabdat-numruns tabdat)
- (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "test-name" "%/%")
- ;; (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "item-name" "%")
- (let* ((dbkeys (dboard:tabdat-dbkeys tabdat)))
- ;; (print "dbkeys: " dbkeys)
- (let ((fres (if (dboard:tabdat-target tabdat)
- (let ((ptparts (append (dboard:tabdat-target tabdat)(make-list (length dbkeys) "%"))))
- (map (lambda (k v)(list k v)) dbkeys ptparts))
- (let ((res '()))
- ;; (print "target: " (dboard:tabdat-target tabdat))
- (for-each (lambda (key)
- (if (not (equal? key "runname"))
- (let ((val (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) key #f)))
- (if val (set! res (cons (list key val) res))))))
- dbkeys)
- res))))
- ;; (debug:print 0 *default-log-port* "fres: " fres)
- fres)))
+ ;;(print "RA => calling runs-tab-updater with commondat " commondat " tab-num " tab-num)
+ ;;(tabdat-values tabdat) ;;RA added
+ (dashboard:do-update-rundat tabdat)
(let ((uidat (dboard:commondat-uidat commondat)))
+ ;;(print "RA => Calling update-buttons with tabdat : " tabdat " uidat " uidat)
(update-buttons tabdat uidat (dboard:tabdat-numruns tabdat) (dboard:tabdat-num-tests tabdat)))
))
"dashboard:runs-tab-updater"))
;; ((2)
@@ -2891,25 +3266,30 @@
(let ((debugcontrolf (conc (get-environment-variable "HOME") "/.dashboardrc")))
(if (file-exists? debugcontrolf)
(load debugcontrolf)))
(define (main)
- (if (not (args:get-arg "-skip-version-check"))(common:exit-on-version-changed))
+ (if (not (args:get-arg "-skip-version-check"))
+ (let ((th1 (make-thread common:exit-on-version-changed)))
+ (thread-start! th1)
+ (if (> megatest-version (common:get-last-run-version-number))
+ (debug:print-info 0 *default-log-port* "Version bump detected, blocking until db sync complete")
+ (thread-join! th1))))
(let* ((commondat (dboard:commondat-make)))
;; Move this stuff to db.scm? I'm not sure that is the right thing to do...
(cond
((args:get-arg "-test") ;; run-id,test-id
- (let* ((dat (let ((d (map string->number (string-split (args:get-arg "-test") ","))))
+ (let* ((dat (let ((d (map string->number (string-split (args:get-arg "-test") ",")))) ;; RADT couldn't find string->number, though it works
(if (> (length d) 1)
d
(list #f #f))))
(run-id (car dat))
(test-id (cadr dat)))
(if (and (number? run-id)
(number? test-id)
(>= test-id 0))
- (examine-test run-id test-id)
+ (dashboard-tests:examine-test run-id test-id)
(begin
(debug:print 3 *default-log-port* "INFO: tried to open test with invalid run-id,test-id. " (args:get-arg "-test"))
(exit 1)))))
;; ((args:get-arg "-guimonitor")
;; (gui-monitor (dboard:tabdat-dblocal tabdat)))
Index: db.scm
==================================================================
--- db.scm
+++ db.scm
@@ -1,7 +1,7 @@
;;======================================================================
-;; Copyright 2006-2013, Matthew Welland.
+;; Copyright 2006-2016, Matthew Welland.
;;
;; This program is made available under the GNU GPL version 2.0 or
;; greater. See the accompanying file COPYING for details.
;;
;; This program is distributed WITHOUT ANY WARRANTY; without even the
@@ -11,14 +11,16 @@
;;======================================================================
;; Database access
;;======================================================================
-(require-extension (srfi 18) extras tcp)
-(use sqlite3 srfi-1 posix regex regex-case srfi-69 csv-xml s11n md5 message-digest base64 format dot-locking z3)
+;; dbstruct vector containing all the relevant dbs like main.db, megatest.db, run.db etc
+
+(require-extension (srfi 18) extras tcp) ;; RADT => use of require-extension?
+(use sqlite3 srfi-1 posix regex regex-case srfi-69 csv-xml s11n md5 message-digest base64 format dot-locking z3 typed-records)
(import (prefix sqlite3 sqlite3:))
-(import (prefix base64 base64:))
+(import (prefix base64 base64:)) ;; RADT => prefix??
(declare (unit db))
(declare (uses common))
(declare (uses keys))
(declare (uses ods))
@@ -31,23 +33,43 @@
(include "run_records.scm")
(define *rundb-mutex* (make-mutex)) ;; prevent problems opening/closing rundb's
(define *number-of-writes* 0)
(define *number-non-write-queries* 0)
+
+;;======================================================================
+;; R E C O R D S
+;;======================================================================
+
+(defstruct dbr:dbstruct
+ main
+ strdb
+ ((path #f) : string)
+ ((local #f) : boolean)
+ rundb
+ inmem
+ mtime
+ rtime
+ stime
+ inuse
+ refdb
+ ((locdbs (make-hash-table)) : hash-table)
+ olddb)
;;======================================================================
;; SQLITE3 HELPERS
;;======================================================================
(define (db:general-sqlite-error-dump exn stmt . params)
- (let ((err-status ((condition-property-accessor 'sqlite3 'status #f) exn)))
+ (let ((err-status ((condition-property-accessor 'sqlite3 'status #f) exn))) ;; RADT ... how does this work?
;; check for (exn sqlite3) ((condition-property-accessor 'exn 'message) exn)
(print "err-status: " err-status)
(debug:print-error 0 *default-log-port* " query " stmt " failed, params: " params ", error: " ((condition-property-accessor 'exn 'message) exn))
(print-call-chain (current-error-port))))
;; convert to -inline
+;;
(define (db:first-result-default db stmt default . params)
(handle-exceptions
exn
(let ((err-status ((condition-property-accessor 'sqlite3 'status #f) exn)))
;; check for (exn sqlite3) ((condition-property-accessor 'exn 'message) exn)
@@ -64,11 +86,11 @@
;; if #f => get main db
;; if db already open - return inmem
;; if db not open, open inmem, rundb and sync then return inmem
;; inuse gets set automatically for rundb's
;;
-(define (db:get-db dbstruct run-id)
+(define (db:get-db dbstruct run-id)
(if (sqlite3:database? dbstruct) ;; pass sqlite3 databases on through
dbstruct
(begin
(let ((dbdat (if (or (not run-id)
(eq? run-id 0))
@@ -75,10 +97,12 @@
(db:open-main dbstruct)
(db:open-rundb dbstruct run-id)
)))
dbdat))))
+;; legacy handling of structure for managing db's. Refactor this into dbr:?
+;;
(define (db:dbdat-get-db dbdat)
(if (pair? dbdat)
(car dbdat)
dbdat))
@@ -88,30 +112,30 @@
#f))
;; mod-read:
;; 'mod modified data
;; 'read read data
+;; Locks the mutex and depending on 'mod or 'read passed, sets the last timestamp in dbstruct
;;
(define (db:done-with dbstruct run-id mod-read)
(if (not (sqlite3:database? dbstruct))
(begin
(mutex-lock! *rundb-mutex*)
(if (eq? mod-read 'mod)
- (dbr:dbstruct-set-mtime! dbstruct (current-milliseconds))
- (dbr:dbstruct-set-rtime! dbstruct (current-milliseconds)))
- (dbr:dbstruct-set-inuse! dbstruct #f)
+ (dbr:dbstruct-mtime-set! dbstruct (current-milliseconds))
+ (dbr:dbstruct-rtime-set! dbstruct (current-milliseconds)))
+ (dbr:dbstruct-inuse-set! dbstruct #f)
(mutex-unlock! *rundb-mutex*))))
;; (db:with-db dbstruct run-id sqlite3:exec "select blah from blaz;")
;; r/w is a flag to indicate if the db is modified by this query #t = yes, #f = no
;;
(define (db:with-db dbstruct run-id r/w proc . params)
- (let* ((dbdat (if (vector? dbstruct)
+ (let* ((dbdat (if (dbr:dbstruct? dbstruct)
(db:get-db dbstruct run-id)
dbstruct)) ;; cheat, allow for passing in a dbdat
(db (db:dbdat-get-db dbdat)))
- (db:delay-if-busy dbdat)
(handle-exceptions
exn
(begin
(debug:print-error 0 *default-log-port* "sqlite3 issue in db:with-db, dbstruct=" dbstruct ", run-id=" run-id ", proc=" proc ", params=" params " error: " ((condition-property-accessor 'exn 'message) exn))
(print-call-chain (current-error-port)))
@@ -143,10 +167,12 @@
;; (let ((fdb (db:get-filedb dbstruct)))
;; (filedb:get-path db id)))
;; NB// #f => return dbdir only
;; (was planned to be; zeroth db with name=main.db)
+;;
+;; If run-id is #f return to create and retrieve the path where the db will live.
;;
(define (db:dbfile-path run-id)
(let* ((dbdir (db:get-dbdir))
(fname (if run-id
(if (eq? run-id 0) "main.db" (conc run-id ".db"))
@@ -159,21 +185,23 @@
(if (not (directory? dbdir))(create-directory dbdir #t)))
(if fname
(conc dbdir "/" fname)
dbdir)))
+;; Returns the database location as specified in config file
+;;
(define (db:get-dbdir)
(or (configf:lookup *configdat* "setup" "dbdir")
(conc (configf:lookup *configdat* "setup" "linktree") "/.db")))
(define (db:set-sync db)
(let ((syncprag (configf:lookup *configdat* "setup" "sychronous")))
- (sqlite3:execute db (conc "PRAGMA synchronous = " (or syncprag 1) ";"))))
+ (sqlite3:execute db (conc "PRAGMA synchronous = " (or syncprag 1) ";"))))
;; open an sql database inside a file lock
-;;
;; returns: db existed-prior-to-opening
+;; RA => Returns a db handler; sets the lock if opened in writable mode
;;
(define (db:lock-create-open fname initproc)
;; (if (file-exists? fname)
;; (let ((db (sqlite3:open-database fname)))
;; (sqlite3:set-busy-handler! db (make-busy-timeout 136000))
@@ -198,14 +226,14 @@
(sqlite3:open-database fname))))) ;; )
;; This routine creates the db. It is only called if the db is not already opened
;;
(define (db:open-rundb dbstruct run-id #!key (attemptnum 0)(do-not-open #f)) ;; (conc *toppath* "/megatest.db") (car *configinfo*)))
- (let* ((local (dbr:dbstruct-get-local dbstruct))
+ (let* ((local (dbr:dbstruct-local dbstruct))
(rdb (if local
- (dbr:dbstruct-get-localdb dbstruct run-id)
- (dbr:dbstruct-get-inmem dbstruct)))) ;; (dbr:dbstruct-get-runrec dbstruct run-id 'inmem)))
+ (dbr:dbstruct-localdb dbstruct run-id)
+ (dbr:dbstruct-inmem dbstruct)))) ;; (dbr:dbstruct-runrec dbstruct run-id 'inmem)))
(if (or rdb
do-not-open)
rdb
(begin
(mutex-lock! *rundb-mutex*)
@@ -240,36 +268,36 @@
(write-access (file-write-access? dbpath))
;; (handler (make-busy-timeout 136000))
)
(if (and dbexists (not write-access))
(set! *db-write-access* #f)) ;; only unset so other db's also can use this control
- (dbr:dbstruct-set-rundb! dbstruct (cons db dbpath))
- (dbr:dbstruct-set-inuse! dbstruct #t)
- (dbr:dbstruct-set-olddb! dbstruct olddb)
- ;; (dbr:dbstruct-set-run-id! dbstruct run-id)
+ (dbr:dbstruct-rundb-set! dbstruct (cons db dbpath))
+ (dbr:dbstruct-inuse-set! dbstruct #t)
+ (dbr:dbstruct-olddb-set! dbstruct olddb)
+ ;; (dbr:dbstruct-run-id-set! dbstruct run-id)
(mutex-unlock! *rundb-mutex*)
(if local
(begin
- (dbr:dbstruct-set-localdb! dbstruct run-id db) ;; (dbr:dbstruct-set-inmem! dbstruct db) ;; direct access ...
+ (dbr:dbstruct-localdb-set! dbstruct run-id db) ;; (dbr:dbstruct-inmem-set! dbstruct db) ;; direct access ...
db)
(begin
- (dbr:dbstruct-set-inmem! dbstruct inmem)
+ (dbr:dbstruct-inmem-set! dbstruct inmem)
;; dec 14, 2014 - keep deleted records available. hunch is that they are needed for id placeholders
;; (sqlite3:execute db "DELETE FROM tests WHERE state='DELETED';") ;; they just slow us down in this context
(db:sync-tables db:sync-tests-only db inmem)
(db:delay-if-busy refdb) ;; dbpath: (db:dbdat-get-path refdb)) ;; What does delaying here achieve?
- (dbr:dbstruct-set-refdb! dbstruct refdb)
+ (dbr:dbstruct-refdb-set! dbstruct refdb)
(db:sync-tables db:sync-tests-only inmem refdb) ;; use inmem as the reference, don't read again from db
;; sync once more to deal with delays?
;; (db:sync-tables db:sync-tests-only db inmem)
;; (db:sync-tables db:sync-tests-only inmem refdb)
inmem)))))))
-;; This routine creates the db. It is only called if the db is not already ls opened
+;; This routine creates the db if not already present. It is only called if the db is not already ls opened
;;
-(define (db:open-main dbstruct) ;; (conc *toppath* "/megatest.db") (car *configinfo*)))
- (let ((mdb (dbr:dbstruct-get-main dbstruct)))
+(define (db:open-main dbstruct) ;; (conc *toppath* "/megatest.db") (car *configinfo*)))
+ (let ((mdb (dbr:dbstruct-main dbstruct))) ;; RA => Returns the first reference in dbstruct
(if mdb
mdb
(begin
(mutex-lock! *rundb-mutex*)
(let* ((dbpath (db:dbfile-path 0))
@@ -278,12 +306,12 @@
(olddb (db:open-megatest-db))
(write-access (file-write-access? dbpath))
(dbdat (cons db dbpath)))
(if (and dbexists (not write-access))
(set! *db-write-access* #f))
- (dbr:dbstruct-set-main! dbstruct dbdat)
- (dbr:dbstruct-set-olddb! dbstruct olddb) ;; olddb is already a (cons db path)
+ (dbr:dbstruct-main-set! dbstruct dbdat)
+ (dbr:dbstruct-olddb-set! dbstruct olddb) ;; olddb is already a (cons db path)
(mutex-unlock! *rundb-mutex*)
(if (and (not dbexists)
*db-write-access*) ;; did not have a prior db and do have write access
(db:multi-db-sync #f 'old2new)) ;; migrate data from megatest.db automatically
dbdat)))))
@@ -310,18 +338,18 @@
(cons db dbpath)))
;; sync run to disk if touched
;;
(define (db:sync-touched dbstruct run-id #!key (force-sync #f))
- (let ((mtime (dbr:dbstruct-get-mtime dbstruct))
- (stime (dbr:dbstruct-get-stime dbstruct))
- (rundb (dbr:dbstruct-get-rundb dbstruct))
- (inmem (dbr:dbstruct-get-inmem dbstruct))
- (maindb (dbr:dbstruct-get-main dbstruct))
- (refdb (dbr:dbstruct-get-refdb dbstruct))
- (olddb (dbr:dbstruct-get-olddb dbstruct))
- ;; (runid (dbr:dbstruct-get-run-id dbstruct))
+ (let ((mtime (dbr:dbstruct-mtime dbstruct))
+ (stime (dbr:dbstruct-stime dbstruct))
+ (rundb (dbr:dbstruct-rundb dbstruct))
+ (inmem (dbr:dbstruct-inmem dbstruct))
+ (maindb (dbr:dbstruct-main dbstruct))
+ (refdb (dbr:dbstruct-refdb dbstruct))
+ (olddb (dbr:dbstruct-olddb dbstruct))
+ ;; (runid (dbr:dbstruct-run-id dbstruct))
)
(debug:print-info 4 *default-log-port* "Syncing for run-id: " run-id)
;; (mutex-lock! *http-mutex*)
(if (eq? run-id 0)
;; runid equal to 0 is main.db
@@ -332,11 +360,11 @@
force-sync)
(begin
(db:delay-if-busy maindb)
(db:delay-if-busy olddb)
(let ((num-synced (db:sync-tables (db:sync-main-list maindb) maindb olddb)))
- (dbr:dbstruct-set-stime! dbstruct (current-milliseconds))
+ (dbr:dbstruct-stime-set! dbstruct (current-milliseconds))
num-synced)
0))
(begin
;; this can occur when using local access (i.e. not in a server)
;; need a flag to turn it off.
@@ -349,33 +377,33 @@
(> mtime stime)
force-sync)
(begin
(db:delay-if-busy rundb)
(db:delay-if-busy olddb)
- (dbr:dbstruct-set-stime! dbstruct (current-milliseconds))
+ (dbr:dbstruct-stime-set! dbstruct (current-milliseconds))
(let ((num-synced (db:sync-tables db:sync-tests-only inmem refdb rundb olddb)))
;; (mutex-unlock! *http-mutex*)
num-synced)
(begin
;; (mutex-unlock! *http-mutex*)
0))))))
(define (db:close-main dbstruct)
- (let ((maindb (dbr:dbstruct-get-main dbstruct)))
+ (let ((maindb (dbr:dbstruct-main dbstruct)))
(if maindb
(begin
(sqlite3:finalize! (db:dbdat-get-db maindb))
- (dbr:dbstruct-set-main! dbstruct #f)))))
+ (dbr:dbstruct-main-set! dbstruct #f)))))
(define (db:close-run-db dbstruct run-id)
(let ((rdb (db:open-rundb dbstruct run-id do-not-open: #t)))
(if (and rdb
(sqlite3:database? rdb))
(begin
(sqlite3:finalize! rdb)
- (dbr:dbstruct-set-localdb! dbstruct run-id #f)
- (dbr:dbstruct-set-inmem! dbstruct #f)))))
+ (dbr:dbstruct-localdb-set! dbstruct run-id #f)
+ (dbr:dbstruct-inmem-set! dbstruct #f)))))
;; close all opened run-id dbs
(define (db:close-all dbstruct)
;; finalize main.db
(db:sync-touched dbstruct 0 force-sync: #t)
@@ -382,11 +410,11 @@
;;(common:db-block-further-queries)
;; (mutex-lock! *db-sync-mutex*) ;; with this perhaps it isn't necessary to use the block-further-queries mechanism?
(db:close-main dbstruct)
- (let ((locdbs (dbr:dbstruct-get-locdbs dbstruct)))
+ (let ((locdbs (dbr:dbstruct-locdbs dbstruct)))
(if (hash-table? locdbs)
(for-each (lambda (run-id)
(db:close-run-db dbstruct run-id))
(hash-table-keys locdbs)))))
@@ -749,11 +777,11 @@
(db:delay-if-busy mtdb)
(let ((testrecs (db:get-all-tests-info-by-run-id mtdb run-id))
(dbstruct (if toppath (make-dbr:dbstruct path: toppath local: #t) #f)))
(debug:print 0 *default-log-port* "INFO: Propagating " (length testrecs) " records for run-id=" run-id " to run specific db")
(db:replace-test-records dbstruct run-id testrecs)
- (sqlite3:finalize! (db:dbdat-get-db (dbr:dbstruct-get-rundb dbstruct)))))
+ (sqlite3:finalize! (db:dbdat-get-db (dbr:dbstruct-rundb dbstruct)))))
run-ids)))
;; now ensure all newdb data are synced to megatest.db
;; do not use the run-ids list passed in to the function
;;
@@ -3349,12 +3377,15 @@
results)
(if (null? tal)
(map cdr (hash-table->alist tests-hash)) ;; return a list of the most recent tests
(loop (car tal)(cdr tal))))))))))
+;; Function recursively checks if <db>.journal exists; if yes means db busy; call itself after delayed interval
+;; return the sqlite3 db handle if possible
+;;
(define (db:delay-if-busy dbdat #!key (count 6))
- (if (not (configf:lookup *configdat* "server" "delay-on-busy"))
+ (if (not (configf:lookup *configdat* "server" "delay-on-busy")) ;;RADT => two conditions in a if block?? also understand what config looked up
(and dbdat (db:dbdat-get-db dbdat))
(if dbdat
(let* ((dbpath (db:dbdat-get-path dbdat))
(db (db:dbdat-get-db dbdat)) ;; we'll return this so (db:delay--if-busy can be called inline
(dbfj (conc dbpath "-journal")))
@@ -3385,11 +3416,11 @@
(thread-sleep! 6.4)
(db:delay-if-busy count: 0))
(else
(debug:print-info 0 *default-log-port* "delaying db access due to high database load.")
(thread-sleep! 12.8))))
- db)
+ db) ;; RADT => why does it need to return db, not #t
"bogus result from db:delay-if-busy")))
(define (db:test-get-records-for-index-file dbstruct run-id test-name)
(let ((res '()))
(db:with-db
Index: db_records.scm
==================================================================
--- db_records.scm
+++ db_records.scm
@@ -13,59 +13,61 @@
;;
;;
;; Accessors for a dbstruct
;;
-(define-inline (dbr:dbstruct-get-main vec) (vector-ref vec 0)) ;; ( db path )
-(define-inline (dbr:dbstruct-get-strdb vec) (vector-ref vec 1)) ;; ( db path )
-(define-inline (dbr:dbstruct-get-path vec) (vector-ref vec 2))
-(define-inline (dbr:dbstruct-get-local vec) (vector-ref vec 3))
-(define-inline (dbr:dbstruct-get-rundb vec) (vector-ref vec 4)) ;; ( db path )
-(define-inline (dbr:dbstruct-get-inmem vec) (vector-ref vec 5)) ;; ( db #f )
-(define-inline (dbr:dbstruct-get-mtime vec) (vector-ref vec 6))
-(define-inline (dbr:dbstruct-get-rtime vec) (vector-ref vec 7))
-(define-inline (dbr:dbstruct-get-stime vec) (vector-ref vec 8))
-(define-inline (dbr:dbstruct-get-inuse vec) (vector-ref vec 9))
-(define-inline (dbr:dbstruct-get-refdb vec) (vector-ref vec 10)) ;; ( db path )
-(define-inline (dbr:dbstruct-get-locdbs vec) (vector-ref vec 11))
-(define-inline (dbr:dbstruct-get-olddb vec) (vector-ref vec 12)) ;; ( db path )
-;; (define-inline (dbr:dbstruct-get-main-path vec) (vector-ref vec 13))
-;; (define-inline (dbr:dbstruct-get-rundb-path vec) (vector-ref vec 14))
-;; (define-inline (dbr:dbstruct-get-run-id vec) (vector-ref vec 13))
-
-(define-inline (dbr:dbstruct-set-main! vec val)(vector-set! vec 0 val))
-(define-inline (dbr:dbstruct-set-strdb! vec val)(vector-set! vec 1 val))
-(define-inline (dbr:dbstruct-set-path! vec val)(vector-set! vec 2 val))
-(define-inline (dbr:dbstruct-set-local! vec val)(vector-set! vec 3 val))
-(define-inline (dbr:dbstruct-set-rundb! vec val)(vector-set! vec 4 val))
-(define-inline (dbr:dbstruct-set-inmem! vec val)(vector-set! vec 5 val))
-(define-inline (dbr:dbstruct-set-mtime! vec val)(vector-set! vec 6 val))
-(define-inline (dbr:dbstruct-set-rtime! vec val)(vector-set! vec 7 val))
-(define-inline (dbr:dbstruct-set-stime! vec val)(vector-set! vec 8 val))
-(define-inline (dbr:dbstruct-set-inuse! vec val)(vector-set! vec 9 val))
-(define-inline (dbr:dbstruct-set-refdb! vec val)(vector-set! vec 10 val))
-(define-inline (dbr:dbstruct-set-locdbs! vec val)(vector-set! vec 11 val))
-(define-inline (dbr:dbstruct-set-olddb! vec val)(vector-set! vec 12 val))
-(define-inline (dbr:dbstruct-set-main-path! vec val)(vector-set! vec 13 val))
-(define-inline (dbr:dbstruct-set-rundb-path! vec val)(vector-set! vec 14 val))
-
-; (define-inline (dbr:dbstruct-set-run-id! vec val)(vector-set! vec 13 val))
+;; (define-inline (dbr:dbstruct-main vec) (vector-ref vec 0)) ;; ( db path )
+;; (define-inline (dbr:dbstruct-strdb vec) (vector-ref vec 1)) ;; ( db path )
+;; (define-inline (dbr:dbstruct-path vec) (vector-ref vec 2))
+;; (define-inline (dbr:dbstruct-local vec) (vector-ref vec 3))
+;; (define-inline (dbr:dbstruct-rundb vec) (vector-ref vec 4)) ;; ( db path )
+;; (define-inline (dbr:dbstruct-inmem vec) (vector-ref vec 5)) ;; ( db #f )
+;; (define-inline (dbr:dbstruct-mtime vec) (vector-ref vec 6))
+;; (define-inline (dbr:dbstruct-rtime vec) (vector-ref vec 7))
+;; (define-inline (dbr:dbstruct-stime vec) (vector-ref vec 8))
+;; (define-inline (dbr:dbstruct-inuse vec) (vector-ref vec 9))
+;; (define-inline (dbr:dbstruct-refdb vec) (vector-ref vec 10)) ;; ( db path )
+;; (define-inline (dbr:dbstruct-locdbs vec) (vector-ref vec 11))
+;; (define-inline (dbr:dbstruct-olddb vec) (vector-ref vec 12)) ;; ( db path )
+;; ;; (define-inline (dbr:dbstruct-main-path vec) (vector-ref vec 13))
+;; ;; (define-inline (dbr:dbstruct-rundb-path vec) (vector-ref vec 14))
+;; ;; (define-inline (dbr:dbstruct-run-id vec) (vector-ref vec 13))
+;;
+;; (define-inline (dbr:dbstruct-main-set! vec val)(vector-set! vec 0 val))
+;; (define-inline (dbr:dbstruct-strdb-set! vec val)(vector-set! vec 1 val))
+;; (define-inline (dbr:dbstruct-path-set! vec val)(vector-set! vec 2 val))
+;; (define-inline (dbr:dbstruct-local-set! vec val)(vector-set! vec 3 val))
+;; (define-inline (dbr:dbstruct-rundb-set! vec val)(vector-set! vec 4 val))
+;; (define-inline (dbr:dbstruct-inmem-set! vec val)(vector-set! vec 5 val))
+;; (define-inline (dbr:dbstruct-mtime-set! vec val)(vector-set! vec 6 val))
+;; (define-inline (dbr:dbstruct-rtime-set! vec val)(vector-set! vec 7 val))
+;; (define-inline (dbr:dbstruct-stime-set! vec val)(vector-set! vec 8 val))
+;; (define-inline (dbr:dbstruct-inuse-set! vec val)(vector-set! vec 9 val))
+;; (define-inline (dbr:dbstruct-refdb-set! vec val)(vector-set! vec 10 val))
+;; (define-inline (dbr:dbstruct-locdbs-set! vec val)(vector-set! vec 11 val))
+;; (define-inline (dbr:dbstruct-olddb-set! vec val)(vector-set! vec 12 val))
+;; (define-inline (dbr:dbstruct-main-path-set! vec val)(vector-set! vec 13 val))
+;; (define-inline (dbr:dbstruct-rundb-path-set! vec val)(vector-set! vec 14 val))
+;;
+; (define-inline (dbr:dbstruct-run-id-set! vec val)(vector-set! vec 13 val))
;; constructor for dbstruct
;;
-(define (make-dbr:dbstruct #!key (path #f)(local #f))
- (let ((v (make-vector 15 #f)))
- (dbr:dbstruct-set-path! v path)
- (dbr:dbstruct-set-local! v local)
- (dbr:dbstruct-set-locdbs! v (make-hash-table))
- v))
-
-(define (dbr:dbstruct-get-localdb v run-id)
- (hash-table-ref/default (dbr:dbstruct-get-locdbs v) run-id #f))
-
-(define (dbr:dbstruct-set-localdb! v run-id db)
- (hash-table-set! (dbr:dbstruct-get-locdbs v) run-id db))
+;; (define (make-dbr:dbstruct #!key (path #f)(local #f))
+;; (let ((v (make-vector 15 #f)))
+;; (dbr:dbstruct-path-set! v path)
+;; (dbr:dbstruct-local-set! v local)
+;; (dbr:dbstruct-locdbs-set! v (make-hash-table))
+;; v))
+
+;; Returns the database for a particular run-id fron the dbstruct:localdbs
+;;
+(define (dbr:dbstruct-localdb v run-id)
+ (hash-table-ref/default (dbr:dbstruct-locdbs v) run-id #f))
+
+(define (dbr:dbstruct-localdb-set! v run-id db)
+ (hash-table-set! (dbr:dbstruct-locdbs v) run-id db))
(define (make-db:test)(make-vector 20))
(define-inline (db:test-get-id vec) (vector-ref vec 0))
(define-inline (db:test-get-run_id vec) (vector-ref vec 1))
@@ -94,11 +96,11 @@
;; 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-get-first_warn vec) (printable (vector-ref vec 16))) ;; RADT => reference 16 is repeated
(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))
(define-inline (db:test-set-testname! vec val)(vector-set! vec 2 val))
(define-inline (db:test-set-state! vec val)(vector-set! vec 3 val))
@@ -113,10 +115,11 @@
(define (db:test-get-is-toplevel vec)
(and (equal? (db:test-get-item-path vec) "") ;; test is not an item
(equal? (db:test-get-uname vec) "n/a"))) ;; test has never been run
;; make-vector-record "" db mintest id run_id testname state status event_time item_path
+;; RADT => purpose of mintest??
;;
(define (make-db:mintest)(make-vector 7))
(define-inline (db:mintest-get-id vec) (vector-ref vec 0))
(define-inline (db:mintest-get-run_id vec) (vector-ref vec 1))
(define-inline (db:mintest-get-testname vec) (vector-ref vec 2))
Index: dcommon.scm
==================================================================
--- dcommon.scm
+++ dcommon.scm
@@ -12,11 +12,11 @@
(use format)
(require-library iup)
(import (prefix iup iup:))
(use canvas-draw)
(import canvas-draw-iup)
-(use regex defstruct)
+(use regex typed-records)
(declare (unit dcommon))
(declare (uses megatest-version))
(declare (uses gutils))
@@ -281,27 +281,135 @@
(status (db:test-get-status hed))
(newitem (list test-name item-path (list test-id state status))))
(if (null? tal)
(reverse (cons newitem res))
(loop (car tal)(cdr tal)(cons newitem res)))))))
+
+(define (dcommon:tests-mindat->hash tests-mindat)
+ (let* ((res (make-hash-table)))
+ (for-each
+ (lambda (item)
+ (let* ((test-name+item-path (cons (list-ref item 0) (list-ref item 1)))
+ (value (list-ref item 2)))
+ (hash-table-set! res test-name+item-path value)))
+ tests-mindat)
+ res))
+
+;; return 1 if status1 is better
+;; return 0 if status1 and 2 are equally good
+;; return -1 if status2 is better
+(define (dcommon:status-compare3 status1 status2)
+ (let*
+ ((status-goodness-ranking (list "PASS" "WARN" "WAIVED" "SKIP" "FAIL" "ABORT" #f))
+ (mem1 (member status1 status-goodness-ranking))
+ (mem2 (member status2 status-goodness-ranking))
+ )
+ (cond
+ ((and (not mem1) (not mem2)) 0)
+ ((not mem1) -1)
+ ((not mem2) 1)
+ ((= (length mem1) (length mem2)) 0)
+ ((> (length mem1) (length mem2)) 1)
+ (else -1))))
+
+(define (dcommon:xor-tests-mindat src-tests-mindat dest-tests-mindat #!key (hide-clean #f))
+ (let* ((src-hash (dcommon:tests-mindat->hash src-tests-mindat))
+ (dest-hash (dcommon:tests-mindat->hash dest-tests-mindat))
+ (all-keys
+ (reverse (sort
+ (delete-duplicates
+ (append (hash-table-keys src-hash) (hash-table-keys dest-hash)))
+
+ (lambda (a b)
+ (cond
+ ((< 0 (string-compare3 (car a) (car b))) #t)
+ ((> 0 (string-compare3 (car a) (car b))) #f)
+ ((< 0 (string-compare3 (cdr a) (cdr b))) #t)
+ (else #f)))
+
+ ))))
+ (let ((res
+ (map ;; TODO: rename xor to delta globally in dcommon and dashboard
+ (lambda (key)
+ (let* ((test-name (car key))
+ (item-path (cdr key))
+
+ (dest-value (hash-table-ref/default dest-hash key #f)) ;; (list test-id state status)
+ (dest-test-id (if dest-value (list-ref dest-value 0) #f))
+ (dest-state (if dest-value (list-ref dest-value 1) #f))
+ (dest-status (if dest-value (list-ref dest-value 2) #f))
+
+ (src-value (hash-table-ref/default src-hash key #f)) ;; (list test-id state status)
+ (src-test-id (if src-value (list-ref src-value 0) #f))
+ (src-state (if src-value (list-ref src-value 1) #f))
+ (src-status (if src-value (list-ref src-value 2) #f))
+
+ (incomplete-statuses '("DELETED" "INCOMPLETE" "STUCK/DEAD" "N/A")) ;; if any of these statuses apply, treat test as incomplete
+
+ (dest-complete
+ (and dest-value dest-state dest-status
+ (equal? dest-state "COMPLETED")
+ (not (member dest-status incomplete-statuses))))
+ (src-complete
+ (and src-value src-state src-status
+ (equal? src-state "COMPLETED")
+ (not (member src-status incomplete-statuses))))
+ (status-compare-result (dcommon:status-compare3 src-status dest-status))
+ (xor-new-item
+ (cond
+ ;; complete, for this case means: state=compelte AND status not in ( deleted uncomplete stuck/dead n/a )
+ ;; neither complete -> bad
+
+ ;; src !complete, dest complete -> better
+ ((and (not dest-complete) (not src-complete))
+ (list dest-test-id "BOTH-BAD" "BOTH-INCOMPLETE"))
+ ((not dest-complete)
+ (list src-test-id "DIFF-MISSING" "DEST-INCOMPLETE"))
+ ((not src-complete)
+ (list dest-test-id "DIFF-NEW" "SRC-INCOMPLETE"))
+ ((and
+ (equal? src-state dest-state)
+ (equal? src-status dest-status))
+ (list dest-test-id (conc "CLEAN") (conc "CLEAN-" dest-status) ))
+ ;; better or worse: pass > warn > waived > skip > fail > abort
+ ;; pass > warn > waived > skip > fail > abort
+
+ ((= 1 status-compare-result) ;; src is better, dest is worse
+ (list dest-test-id "DIRTY-WORSE" (conc src-status "->" dest-status)))
+ (else
+ (list dest-test-id "DIRTY-BETTER" (conc src-status "->" dest-status)))
+ )))
+ (list test-name item-path xor-new-item)))
+ all-keys)))
+
+ (if hide-clean
+ (filter
+ (lambda (item)
+ ;;(print item)
+ (not
+ (equal?
+ "CLEAN"
+ (list-ref (list-ref item 2) 1))))
+ res)
+ res))))
(define (dcommon:examine-xterm run-id test-id)
(let* ((testdat (rmt:get-test-info-by-id run-id test-id)))
(if (not testdat)
- (begin
- (debug:print 2 "ERROR: No test data found for test " test-id ", exiting")
- (exit 1))
+ (begin
+ (debug:print 2 "ERROR: No test data found for test " test-id ", exiting")
+ (exit 1))
(let*
((rundir (if testdat
- (db:test-get-rundir testdat)
- logfile))
+ (db:test-get-rundir testdat)
+ logfile))
(testfullname (if testdat (db:test-get-fullname testdat) "Gathering data ..."))
(xterm (lambda ()
(if (directory-exists? rundir)
(let* ((shell (if (get-environment-variable "SHELL")
- (conc "-e " (get-environment-variable "SHELL"))
- ""))
+ (conc "-e " (get-environment-variable "SHELL"))
+ ""))
(command (conc "cd " rundir
";mt_xterm -T \"" (string-translate testfullname "()" " ") "\" " shell "&")))
(print "Command =" command)
(common:without-vars
command
@@ -315,21 +423,21 @@
;;======================================================================
;; Table of keys
(define (dcommon:keys-matrix rawconfig)
(let* ((curr-row-num 1)
- (key-vals (configf:section-vars rawconfig "fields"))
- (keys-matrix (iup:matrix
- #:alignment1 "ALEFT"
- #:expand "YES" ;; "HORIZONTAL" ;; "VERTICAL"
- ;; #:scrollbar "YES"
- #:numcol 1
- #:numlin (length key-vals)
- #:numcol-visible 1
- #:numlin-visible (length key-vals)
- #:click-cb (lambda (obj lin col status)
- (print "obj: " obj " lin: " lin " col: " col " status: " status)))))
+ (key-vals (configf:section-vars rawconfig "fields"))
+ (keys-matrix (iup:matrix
+ #:alignment1 "ALEFT"
+ #:expand "YES" ;; "HORIZONTAL" ;; "VERTICAL"
+ ;; #:scrollbar "YES"
+ #:numcol 1
+ #:numlin (length key-vals)
+ #:numcol-visible 1
+ #:numlin-visible (length key-vals)
+ #:click-cb (lambda (obj lin col status)
+ (print "obj: " obj " lin: " lin " col: " col " status: " status)))))
;; (iup:attribute-set! keys-matrix "0:0" "Run Keys")
(iup:attribute-set! keys-matrix "WIDTH0" 0)
(iup:attribute-set! keys-matrix "0:1" "Key Name")
;; (iup:attribute-set! keys-matrix "WIDTH1" "100")
;; fill in keys
@@ -344,18 +452,18 @@
keys-matrix))
;; Section to table
(define (dcommon:section-matrix rawconfig sectionname varcolname valcolname #!key (title #f))
(let* ((curr-row-num 1)
- (key-vals (configf:section-vars rawconfig sectionname))
- (section-matrix (iup:matrix
- #:alignment1 "ALEFT"
- #:expand "YES" ;; "HORIZONTAL"
- #:numcol 1
- #:numlin (length key-vals)
- #:numcol-visible 1
- #:numlin-visible (min 10 (length key-vals))
+ (key-vals (configf:section-vars rawconfig sectionname))
+ (section-matrix (iup:matrix
+ #:alignment1 "ALEFT"
+ #:expand "YES" ;; "HORIZONTAL"
+ #:numcol 1
+ #:numlin (length key-vals)
+ #:numcol-visible 1
+ #:numlin-visible (min 10 (length key-vals))
#:scrollbar "YES")))
(iup:attribute-set! section-matrix "0:0" varcolname)
(iup:attribute-set! section-matrix "0:1" valcolname)
(iup:attribute-set! section-matrix "WIDTH1" "200")
;; fill in keys
Index: gutils.scm
==================================================================
--- gutils.scm
+++ gutils.scm
@@ -48,7 +48,17 @@
((REMOTEHOSTSTART) (list "50 130 195" state))
((RUNNING) (list "9 131 232" state))
((KILLREQ) (list "39 82 206" state))
((KILLED) (list "234 101 17" state))
((NOT_STARTED) (list "240 240 240" state))
+ ;; for xor mode below
+ ;;
+ ((CLEAN)
+ (case (string->symbol status)
+ ((CLEAN-FAIL CLEAN-CHECK CLEAN-ABORT) (list "200 130 13" status)) ;; orange requested for these
+ (else (list "60 235 63" status))))
+ ((DIRTY-BETTER) (list "160 255 153" status))
+ ((DIRTY-WORSE) (list "165 42 42" status))
+ ((BOTH-BAD) (list "180 33 49" status))
+
(else (list "192 192 192" state))))
Index: launch.scm
==================================================================
--- launch.scm
+++ launch.scm
@@ -12,11 +12,11 @@
;; launch a task - this runs on the originating host, tests themselves
;;
;;======================================================================
(use regex regex-case base64 sqlite3 srfi-18 directory-utils posix-extras z3 call-with-environment-variables csv)
-(use defstruct pathname-expand)
+(use typed-records pathname-expand)
(import (prefix base64 base64:))
(import (prefix sqlite3 sqlite3:))
(declare (unit launch))
@@ -68,11 +68,14 @@
(csvr (db:logpro-dat->csv dat stepname))
(csvt (let-values (( (fmt-cell fmt-record fmt-csv) (make-format ",")))
(fmt-csv (map list->csv-record csvr))))
(status (configf:lookup dat "final" "exit-status"))
(msg (configf:lookup dat "final" "message")))
- (rmt:csv->test-data run-id test-id csvt)
+ ;;(if csvt ;; this if blocked stack dump caused by .dat file from logpro being 0-byte. fixed by upgrading logpro
+ (rmt:csv->test-data run-id test-id csvt)
+ ;; (BB> "Error: run-id/test-id/stepname="run-id"/"test-id"/"stepname" => bad csvr="csvr)
+ ;; )
(cond
((equal? status "PASS") "PASS") ;; skip the message part if status is pass
(status (conc (configf:lookup dat "final" "exit-status") ": " (if msg msg "no message")))
(else #f)))
#f)))
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.6105)
+(define megatest-version 1.6201)
Index: megatest.scm
==================================================================
--- megatest.scm
+++ megatest.scm
@@ -1879,10 +1879,11 @@
;;======================================================================
;; Start a repl
;;======================================================================
;; fakeout readline
+(include "readline-fix.scm")
(if (or (getenv "MT_RUNSCRIPT")
(args:get-arg "-repl")
(args:get-arg "-load"))
(let* ((toppath (launch:setup))
@@ -1908,11 +1909,10 @@
(import extras) ;; might not be needed
;; (import csi)
(import readline)
(import apropos)
;; (import (prefix sqlite3 sqlite3:)) ;; doesn't work ...
- (include "readline-fix.scm")
(if *use-new-readline*
(begin
(install-history-file (get-environment-variable "HOME") ".megatest_history") ;; [homedir] [filename] [nlines])
(current-input-port (make-readline-port "megatest> ")))
Index: rmt.scm
==================================================================
--- rmt.scm
+++ rmt.scm
@@ -7,11 +7,11 @@
;; This program is distributed WITHOUT ANY WARRANTY; without even the
;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
;; PURPOSE.
;;======================================================================
-(use json format)
+(use json format) ;; RADT => purpose of json format??
(declare (unit rmt))
(declare (uses api))
(declare (uses tdb))
(declare (uses http-transport))
@@ -71,10 +71,13 @@
(if (tasks:server-running-or-starting? (db:delay-if-busy (tasks:open-db)) run-id)
(client:setup run-id)
#f))))
(define *send-receive-mutex* (make-mutex)) ;; should have separate mutex per run-id
+
+;; RA => e.g. usage (rmt:send-receive 'get-var #f (list varname))
+;;
(define (rmt:send-receive cmd rid params #!key (attemptnum 1)) ;; start attemptnum at 1 so the modulo below works as expected
;; clean out old connections
;; (mutex-lock! *db-multi-sync-mutex*)
(let ((expire-time (- (current-seconds) (server:get-timeout) 10))) ;; don't forget the 10 second margin
(for-each
Index: tdb.scm
==================================================================
--- tdb.scm
+++ tdb.scm
@@ -209,11 +209,13 @@
(define (tdb:load-test-data run-id test-id)
(let loop ((lin (read-line)))
(if (not (eof-object? lin))
(begin
(debug:print 4 *default-log-port* lin)
- (rmt:csv->test-data run-id test-id lin)
+ ;;(when lin ;; this when blocked stack dump caused by .dat file from logpro being 0-byte. fixed by upgrading logpro
+ (rmt:csv->test-data run-id test-id lin)
+ ;;)
(loop (read-line)))))
;; roll up the current results.
;; FIXME: Add the status too
(rmt:test-data-rollup run-id test-id #f))
@@ -221,11 +223,13 @@
(define (tdb:load-logpro-data run-id test-id)
(let loop ((lin (read-line)))
(if (not (eof-object? lin))
(begin
(debug:print 4 *default-log-port* lin)
- (rmt:csv->test-data run-id test-id lin)
+ ;;(when lin ;; this when blocked stack dump caused by .dat file from logpro being 0-byte. fixed by upgrading logpro
+ (rmt:csv->test-data run-id test-id lin)
+ ;;)
(loop (read-line)))))
;; roll up the current results.
;; FIXME: Add the status too
(rmt:test-data-rollup run-id test-id #f))
Index: utils/installall.sh
==================================================================
--- utils/installall.sh
+++ utils/installall.sh
@@ -12,20 +12,56 @@
# PURPOSE.
echo You may need to do the following first:
echo sudo apt-get install libreadline-dev
echo sudo apt-get install libwebkitgtk-dev
+echo sudo apt-get install libpangox-1.0-0 zlib1g-dev libfreetype6-dev cmake
echo sudo apt-get install libssl-dev
echo sudo apt-get install libmotif3 -OR- set KTYPE=26g4
-echo KTYPE can be 26, 26g4, or 32
-echo
-echo KTYPE=$KTYPE
+echo
+echo Set OPTION to std, currently OPTION=$OPTION
+echo
echo You are using PREFIX=$PREFIX
echo You are using proxy="$proxy"
echo
echo "Set additional_libpath to help find gtk or other libraries, don't forget a leading :"
+SYSTEM_TYPE=$(lsb_release -irs |tr ' ' '_' |tr '\n' '-')$(uname -i)-$OPTION
+
+# Set up variables
+#
+case $SYSTEM_TYPE in
+Ubuntu-16.04-x86_64-std)
+ KTYPE=32
+ CDVER=5.10
+ IUPVER=3.17
+ IMVER=3.11
+ ;;
+Ubuntu-16.04-i686-std)
+ KTYPE=32
+ CDVER=5.10
+ IUPVER=3.17
+ IMVER=3.11
+ ;;
+SUSE_LINUX_11-x86_64-std)
+ KTYPE=26g4
+ CDVER=5.10
+ IUPVER=3.17
+ IMVER=3.11
+ ;;
+CentOS_5.11-x86_64-std)
+ KTYPE=24g3
+ CDVER=5.4.1
+ IUPVER=3.5
+ IMVER=3.6.3
+ ;;
+esac
+
+echo KTYPE=$KTYPE
+echo CDVER=$CDVER
+echo IUPVER=$IUPVER
+echo IMVER=$IMVER
# NOTES:
#
# Centos with security setup may need to do commands such as following as root:
#
# NB// fix the paths first
@@ -55,21 +91,21 @@
export PROX="-proxy $proxy"
fi
if [[ $KTYPE == "" ]]; then
echo 'Using KTYPE=26'
- export KTYPE=26
+ export KTYPE=26g4
else
echo Using KTYPE=$KTYPE
fi
# Put all the downloaded tar files in tgz
mkdir -p tgz
# http://code.call-cc.org/releases/4.8.0/chicken-4.8.0.5.tar.gz
-export CHICKEN_VERSION=4.8.0.5
-export CHICKEN_BASEVER=4.8.0
+export CHICKEN_VERSION=4.11.0
+export CHICKEN_BASEVER=4.11.0
chicken_targz=chicken-${CHICKEN_VERSION}.tar.gz
if ! [[ -e tgz/$chicken_targz ]]; then
wget http://code.call-cc.org/releases/${CHICKEN_BASEVER}/${chicken_targz}
mv $chicken_targz tgz
fi
@@ -80,167 +116,210 @@
if [[ $PREFIX == "" ]]; then
PREFIX=$PWD/inst
fi
export PATH=$PREFIX/bin:$PATH
-export LIBPATH=$PREFIX/lib$ADDITIONAL_LIBPATH
+export LIBPATH=$PREFIX/lib:$PREFIX/lib64:$ADDITIONAL_LIBPATH
export LD_LIBRARY_PATH=$LIBPATH
export CHICKEN_INSTALL=$PREFIX/bin/chicken-install
-echo "export PATH=$PREFIX/bin:\$PATH" > setup-chicken4x.sh
-echo "export LD_LIBRARY_PATH=$LD_LIBRARY_PATH" >> setup-chicken4x.sh
+mkdir -p $PREFIX
+echo "export PATH=$PREFIX/bin:\$PATH" > $PREFIX/setup-chicken4x.sh
+echo "export LD_LIBRARY_PATH=$LD_LIBRARY_PATH:\$LD_LIBRARY_PATH" >> $PREFIX/setup-chicken4x.sh
+echo "setenv PATH $PREFIX/bin:\$PATH" > $PREFIX/setup-chicken4x.csh
+echo "setenv LD_LIBRARY_PATH $LD_LIBRARY_PATH:\$LD_LIBRARY_PATH" >> $PREFIX/setup-chicken4x.csh
echo PATH=$PATH
echo LD_LIBRARY_PATH=$LD_LIBRARY_PATH
if ! [[ -e $PREFIX/bin/csi ]]; then
- tar xfvz tgz/$chicken_targz
+ tar xfz tgz/$chicken_targz
cd chicken-${CHICKEN_VERSION}
# make PLATFORM=linux PREFIX=$PREFIX spotless
make PLATFORM=linux PREFIX=$PREFIX
make PLATFORM=linux PREFIX=$PREFIX install
cd $BUILDHOME
fi
+cd $BUILDHOME
+#wget --no-check-certificate https://github.com/nanomsg/nanomsg/archive/1.0.0.tar.gz
+#mv 1.0.0 1.0.0.tar.gz
+if ! [[ -e $PREFIX/lib64/libnanomsg.so.1.0.0 ]]; then
+ wget --no-check-certificate https://github.com/nanomsg/nanomsg/archive/1.0.0.tar.gz
+ mv 1.0.0 1.0.0.tar.gz
+ tar xf 1.0.0.tar.gz
+ cd nanomsg-1.0.0
+ ./configure --prefix=$PREFIX
+ make
+ make install
+fi
+cd $BUILDHOME
+
+export SQLITE3_VERSION=3090200
+if ! [[ -e $PREFIX/bin/sqlite3 ]]; then
+ echo Install sqlite3
+ sqlite3_tgz=sqlite-autoconf-$SQLITE3_VERSION.tar.gz
+ if ! [[ -e tgz/$sqlite3_tgz ]]; then
+ wget http://www.sqlite.org/2015/$sqlite3_tgz
+ mv $sqlite3_tgz tgz
+ fi
+
+ if ! [[ -e $PREFIX/bin/sqlite3 ]] ; then
+ if [[ -e tgz/sqlite-autoconf-$SQLITE3_VERSION.tar.gz ]]; then
+ tar xfz tgz/sqlite-autoconf-$SQLITE3_VERSION.tar.gz
+ (cd sqlite-autoconf-$SQLITE3_VERSION;./configure --prefix=$PREFIX;make;make install)
+ fi
+ fi
+fi
+cd $BUILDHOME
# Some eggs are quoted since they are reserved to Bash
# for f in matchable readline apropos base64 regex-literals format "regex-case" "test" coops trace csv dot-locking posix-utils posix-extras directory-utils hostinfo tcp rpc csv-xml fmt json md5; do
# $CHICKEN_INSTALL $PROX -keep-installed matchable readline apropos base64 regex-literals format "regex-case" "test" coops trace csv dot-locking posix-utils posix-extras directory-utils hostinfo tcp rpc csv-xml fmt json md5 awful http-client spiffy uri-common intarweb http-client spiffy-request-vars md5 message-digest http-client spiffy-directory-listing
-$CHICKEN_INSTALL $PROX -keep-installed matchable readline apropos base64 regex-literals format "regex-case" "test" coops trace csv dot-locking posix-utils posix-extras directory-utils hostinfo tcp rpc csv-xml fmt json md5 awful http-client spiffy uri-common intarweb http-client spiffy-request-vars s md5 message-digest piffy-directory-listing ssax sxml-serializer sxml-modifications logpro
-# if ! [[ -e $PREFIX/lib/chicken/6/$f.so ]];then
-# $CHICKEN_INSTALL $PROX $f
-# # $CHICKEN_INSTALL -deploy -prefix $DEPLOYTARG $PROX $f
-# else
-# echo Skipping install of egg $f as it is already installed
-# fi
-# done
-
-cd $BUILDHOME
-
-for a in `ls */*.meta|cut -f1 -d/` ; do
- echo $a
- (cd $a;$CHICKEN_INSTALL)
+for egg in matchable readline apropos base64 regex-literals format "regex-case" "test" \
+ coops trace csv dot-locking posix-utils posix-extras directory-utils hostinfo \
+ tcp rpc csv-xml fmt json md5 awful http-client spiffy uri-common intarweb http-client \
+ spiffy-request-vars s md5 message-digest spiffy-directory-listing ssax sxml-serializer \
+ sxml-modifications logpro z3 call-with-environment-variables \
+ pathname-expand typed-records simple-exceptions numbers crypt parley srfi-42
+do
+ echo "Installing $egg"
+ $CHICKEN_INSTALL $PROX -keep-installed $egg
+ #$CHICKEN_INSTALL $PROX $egg
+ if [ $? -ne 0 ]; then
+ echo "$egg failed to install"
+ exit 1
+ fi
+done
+for egg in "sqlite3" sql-de-lite nanomsg
+do
+ echo "Installing $egg"
+ CSC_OPTIONS="-I$PREFIX/include -L$PREFIX/lib -L$PREFIX/lib64" $CHICKEN_INSTALL $PROX -keep-installed $egg
+ #CSC_OPTIONS="-I$PREFIX/include -L$PREFIX/lib -L$PREFIX/lib64" $CHICKEN_INSTALL $PROX $egg
+ if [ $? -ne 0 ]; then
+ echo "$egg failed to install"
+ exit 1
+ fi
done
-export LIBPATH=$PREFIX/lib$ADDITIONAL_LIBPATH
-export LD_LIBRARY_PATH=$LIBPATH
-
-export SQLITE3_VERSION=3071401
-echo Install sqlite3
-sqlite3_tgz=sqlite-autoconf-$SQLITE3_VERSION.tar.gz
-if ! [[ -e tgz/$sqlite3_tgz ]]; then
- wget http://www.sqlite.org/$sqlite3_tgz
- mv $sqlite3_tgz tgz
-fi
-
-if ! [[ -e $PREFIX/bin/sqlite3 ]] ; then
- if [[ -e tgz/sqlite-autoconf-$SQLITE3_VERSION.tar.gz ]]; then
- tar xfz tgz/sqlite-autoconf-$SQLITE3_VERSION.tar.gz
- (cd sqlite-autoconf-$SQLITE3_VERSION;./configure --prefix=$PREFIX;make;make install)
- # CSC_OPTIONS="-I$PREFIX/include -L$PREFIX/lib" $CHICKEN_INSTALL -prefix $DEPLOYTARG -deploy $PROX sqlite3
- CSC_OPTIONS="-I$PREFIX/include -L$PREFIX/lib" $CHICKEN_INSTALL $PROX sqlite3
- fi
-fi
-
# $CHICKEN_INSTALL $PROX sqlite3
-
-# IUP versions
-if [[ x$USEOLDIUP == "x" ]];then
- CDVER=5.7
- IUPVER=3.8
- IMVER=3.8
-else
- CDVER=5.7
- IUPVER=3.8
- IMVER=3.8
-fi
+cd $BUILDHOME
+# # IUP versions
+# if [[ x$USEOLDIUP == "x" ]];then
+# CDVER=5.10
+# IUPVER=3.17
+# IMVER=3.11
+# else
+# CDVER=5.10
+# IUPVER=3.17
+# IMVER=3.11
+# fi
+# if [[ x$KTYPE == "x24g3" ]];then
+# CDVER=5.4.1
+# IUPVER=3.5
+# IMVER=3.6.3
+# fi
if [[ `uname -a | grep x86_64` == "" ]]; then
export ARCHSIZE=''
else
export ARCHSIZE=64_
fi
# export files="cd-5.4.1_Linux${KTYPE}_lib.tar.gz im-3.6.3_Linux${KTYPE}_lib.tar.gz iup-3.5_Linux${KTYPE}_lib.tar.gz"
if [[ x$USEOLDIUP == "x" ]];then
- export files="cd-${CDVER}_Linux${KTYPE}_${ARCHSIZE}lib.tar.gz im-${IMVER}_Linux${KTYPE}_${ARCHSIZE}lib.tar.gz iup-${IUPVER}_Linux${KTYPE}_${ARCHSIZE}lib.tar.gz"
+ export files="cd/cd-${CDVER}_Linux${KTYPE}_${ARCHSIZE}lib.tar.gz im/im-${IMVER}_Linux${KTYPE}_${ARCHSIZE}lib.tar.gz iup/iup-${IUPVER}_Linux${KTYPE}_${ARCHSIZE}lib.tar.gz"
else
echo WARNING: Using old IUP libraries
- export files="cd-5.4.1_Linux${KTYPE}_${ARCHSIZE}lib.tar.gz im-3.6.3_Linux${KTYPE}_${ARCHSIZE}lib.tar.gz iup-3.5_Linux${KTYPE}_${ARCHSIZE}lib.tar.gz"
+ export files="cd/cd-5.4.1_Linux${KTYPE}_${ARCHSIZE}lib.tar.gz im/im-3.6.3_Linux${KTYPE}_${ARCHSIZE}lib.tar.gz iup/iup-3.5_Linux${KTYPE}_${ARCHSIZE}lib.tar.gz"
fi
+echo $files
mkdir -p $PREFIX/iuplib
+mkdir -p iup/
for a in `echo $files` ; do
if ! [[ -e tgz/$a ]] ; then
- wget http://www.kiatoa.com/matt/iup/$a
- mv $a tgz/$a
+ echo wget -c -O tgz/$a http://www.kiatoa.com/matt/chicken-build/$a
+ wget -c http://www.kiatoa.com/matt/chicken-build/$a
+ mv `echo $a | cut -d'/' -f2` tgz/
fi
echo Untarring tgz/$a into $BUILDHOME/lib
- (cd $PREFIX/lib;tar xfvz $BUILDHOME/tgz/$a;mv include/* ../include)
+ tar -xzf tgz/`echo $a | cut -d'/' -f2` -C iup/
+ #(cd $PREFIX/lib;tar xfvz $BUILDHOME/tgz/$a;mv include/* ../include)
# (cd $DEPLOYTARG;tar xfvz $BUILDHOME/$a)
done
-
+cp iup/include/* $PREFIX/include/
+cp iup/*.so $PREFIX/lib/
+cp iup/*.a $PREFIX/lib/
+cp iup/ftgl/lib/*/* $PREFIX/lib/
+cd $BUILDHOME
# ffcall obtained from:
# cvs -z3 -d:pserver:anonymous@cvs.savannah.gnu.org:/sources/libffcall co ffcall
-
-if ! [[ -e tgz/ffcall.tar.gz ]] ; then
- wget http://www.kiatoa.com/matt/iup/ffcall.tar.gz
- mv ffcall.tar.gz tgz
+#exit
+if ! [[ -e $PREFIX/include/callback.h ]] ; then
+ #fossil clone http://www.kiatoa.com/fossils/ffcall ffcall.fossil
+ wget -c -O ffcall.tar.gz 'http://www.kiatoa.com/fossils/ffcall/tarball?name=ffcall&uuid=trunk'
+ tar -xzf ffcall.tar.gz
+ #mkdir -p ffcall
+ cd ffcall
+ #fossil open ../ffcall.fossil
+ ./configure --prefix=$PREFIX --enable-shared
+ make CC="gcc -fPIC"
+ make install
+fi
+cd $BUILDHOME
+#wget -c -O opensrc.tar.gz 'http://www.kiatoa.com/fossils/opensrc/tarball?name=opensrc&uuid=trunk'
+# Not working due to login problems.
+if ! [[ -e $PREFIX/bin/hs ]] ; then
+ #fossil clone http://www.kiatoa.com/fossils/opensrc opensrc.fossil
+ #mkdir -p opensrc
+ wget -c -O opensrc.tar.gz 'http://www.kiatoa.com/fossils/opensrc/tarball?name=opensrc&uuid=trunk'
+ tar -xzf opensrc.tar.gz
+ cd opensrc
+ #fossil open ../opensrc.fossil
+ cd histstore
+ $PREFIX/bin/csc histstore.scm -o hs
+ cp -f hs $PREFIX/bin/hs
+ cd ../mutils
+ $PREFIX/bin/chicken-install
+ cd ../dbi
+ $PREFIX/bin/chicken-install
+ cd ../margs
+ $PREFIX/bin/chicken-install
fi
-
-tar xfvz tgz/ffcall.tar.gz
-
-cd ffcall
-./configure --prefix=$PREFIX --enable-shared
-make
-make install
-
+cd $BUILDHOME
+
+if ! [[ -e $PREFIX/bin/stmlrun ]] ; then
+ #fossil clone http://www.kiatoa.com/fossils/stml stml.fossil
+ wget -c -O stml.tar.gz 'http://www.kiatoa.com/fossils/stml/tarball?name=stml&uuid=trunk'
+ tar -xzf stml.tar.gz
+ cd stml
+ #fossil open ../stml.fossil
+ cp install.cfg.template install.cfg
+ echo "TARGDIR=$PREFIX/bin" > install.cfg
+ echo "LOGDIR=/tmp/stmlrun" >> install.cfg
+ echo "SQLITE3=$PREFIX/bin/sqlite3" >> install.cfg
+ cp requirements.scm.template requirements.scm
+ which csc
+ make clean
+ CSCOPTS="-C -fPIC" make
+fi
cd $BUILDHOME
export CSCLIBS=`echo $LD_LIBRARY_PATH | sed 's/:/ -L/g'`
-CSC_OPTIONS="-I$PREFIX/include -L$CSCLIBS" $CHICKEN_INSTALL $PROX -D no-library-checks -feature disable-iup-web iup
+IUPEGGVER='iup'
+if [[ $IUPVER == "3.5" ]]; then
+ IUPEGGVER='iup:1.2.1'
+fi
+
+#CSC_OPTIONS="-I$PREFIX/include -L$CSCLIBS" $CHICKEN_INSTALL $PROX -D no-library-checks -feature disable-iup-web iup
+CSC_OPTIONS="-I$PREFIX/include -L$PREFIX/lib" $CHICKEN_INSTALL $PROX -D no-library-checks -feature disable-iup-web $IUPEGGVER
+
# CSC_OPTIONS="-I$PREFIX/include -L$CSCLIBS" $CHICKEN_INSTALL $PROX -D no-library-checks -feature disable-iup-web -deploy -prefix $DEPLOYTARG iup
# iup:1.0.2
-CSC_OPTIONS="-I$PREFIX/include -L$CSCLIBS" $CHICKEN_INSTALL $PROX -D no-library-checks canvas-draw
+CSC_OPTIONS="-I$PREFIX/include -L$PREFIX/lib" $CHICKEN_INSTALL $PROX -D no-library-checks canvas-draw
# CSC_OPTIONS="-I$PREFIX/include -L$CSCLIBS" $CHICKEN_INSTALL $PROX -D no-library-checks -deploy -prefix $DEPLOYTARG canvas-draw
-# NB// Removed bunch of zmq compiling tricks. Look at older versions of this file if you need to recreate...
-
cd $BUILDHOME
-# git clone https://bitbucket.org/DerGuteMoritz/zmq/commits/branch/3.2 zmq-3.2
-# cd zmq-3.2
-# chicken-install
-#
-# cd $BUILDHOME
-
-## WEBKIT=WebKit-r131972
-## if ! [[ -e ${WEBKIT}.tar.bz2 ]] ; then
-## # http://builds.nightly.webkit.org/files/trunk/src/WebKit-r131972.tar.bz2
-## wget http://builds.nightly.webkit.org/files/trunk/src/${WEBKIT}.tar.bz2
-## fi
-##
-## if [[ x$only_it_worked == $I_wish ]] ;then
-## if [[ -e ${WEBKIT}.tar.bz2 ]] ; then
-## tar xfj ${WEBKIT}.tar.bz2
-## cd $WEBKIT
-## ./autogen.sh
-## ./configure --prefix=$PREFIX
-## make
-## make install
-## fi
-## fi
-##
-## cd $BUILHOME
-
-# export CD_REL=d704525ebe1c6d08
-# if ! [[ -e Canvas_Draw-$CD_REL.zip ]]; then
-# wget http://www.kiatoa.com/matt/iup/Canvas_Draw-$CD_REL.zip
-# fi
-#
-# unzip -o Canvas_Draw-$CD_REL.zip
-#
-# cd "Canvas Draw-$CD_REL/chicken"
-# CSC_OPTIONS="-I$PREFIX/include -L$LIBPATH" $CHICKEN_INSTALL $PROX -D no-library-checks
-
echo You may need to add $LD_LIBRARY_PATH to your LD_LIBRARY_PATH variable, a setup-chicken4x.sh
echo file can be found in the current directory which should work for setting up to run chicken4x
echo Testing iup
$PREFIX/bin/csi -b -eval '(use iup)(print "Success")'