Index: Makefile ================================================================== --- Makefile +++ Makefile @@ -5,22 +5,22 @@ SRCFILES = common.scm items.scm launch.scm \ ods.scm runconfig.scm server.scm configf.scm \ db.scm keys.scm margs.scm megatest-version.scm \ process.scm runs.scm tasks.scm tests.scm genexample.scm \ http-transport.scm nmsg-transport.scm filedb.scm \ - client.scm gutils.scm synchash.scm daemon.scm mt.scm dcommon.scm \ - tree.scm ezsteps.scm lock-queue.scm sdb.scm \ + client.scm synchash.scm daemon.scm mt.scm \ + ezsteps.scm lock-queue.scm sdb.scm \ rmt.scm api.scm tdb.scm rpc-transport.scm \ - portlogger.scm archive.scm env.scm vg.scm + portlogger.scm archive.scm env.scm # Eggs to install (straightforward ones) EGGS=matchable readline apropos base64 regex-literals format regex-case test coops trace csv \ dot-locking posix-utils posix-extras directory-utils hostinfo tcp-server rpc csv-xml fmt \ json md5 awful http-client spiffy uri-common intarweb spiffy-request-vars \ spiffy-directory-listing ssax sxml-serializer sxml-modifications iup canvas-draw sqlite3 -GUISRCF = dashboard-tests.scm dashboard-guimonitor.scm +GUISRCF = dashboard-tests.scm dashboard-guimonitor.scm gutils.scm dcommon.scm tree.scm vg.scm OFILES = $(SRCFILES:%.scm=%.o) GOFILES = $(GUISRCF:%.scm=%.o) ADTLSCR=mt_laststep mt_runstep mt_ezstep @@ -76,27 +76,27 @@ $(OFILES) $(GOFILES) : common_records.scm %.o : %.scm csc $(CSCOPTS) -c $< -$(PREFIX)/bin/.$(ARCHSTR)/mtest : mtest +$(PREFIX)/bin/.$(ARCHSTR)/mtest : mtest utils/mk_wrapper @echo Installing to PREFIX=$(PREFIX) $(INSTALL) mtest $(PREFIX)/bin/.$(ARCHSTR)/mtest utils/mk_wrapper $(PREFIX) mtest $(PREFIX)/bin/megatest chmod a+x $(PREFIX)/bin/megatest $(PREFIX)/bin/.$(ARCHSTR)/ndboard : ndboard $(INSTALL) ndboard $(PREFIX)/bin/.$(ARCHSTR)/ndboard -$(PREFIX)/bin/newdashboard : $(PREFIX)/bin/.$(ARCHSTR)/ndboard +$(PREFIX)/bin/newdashboard : $(PREFIX)/bin/.$(ARCHSTR)/ndboard utils/mk_wrapper utils/mk_wrapper $(PREFIX) ndboard $(PREFIX)/bin/newdashboard chmod a+x $(PREFIX)/bin/newdashboard $(PREFIX)/bin/.$(ARCHSTR)/mdboard : multi-dboard $(INSTALL) multi-dboard $(PREFIX)/bin/.$(ARCHSTR)/mdboard -$(PREFIX)/bin/mdboard : $(PREFIX)/bin/.$(ARCHSTR)/mdboard +$(PREFIX)/bin/mdboard : $(PREFIX)/bin/.$(ARCHSTR)/mdboard utils/mk_wrapper utils/mk_wrapper $(PREFIX) mdboard $(PREFIX)/bin/mdboard chmod a+x $(PREFIX)/bin/mdboard # $(HELPERS) : utils/% # $(INSTALL) $< $@ @@ -142,11 +142,11 @@ $(INSTALL) $< $@ chmod a+x $@ # install dashboard as dboard so wrapper script can be called dashboard -$(PREFIX)/bin/.$(ARCHSTR)/dboard : dboard $(FILES) +$(PREFIX)/bin/.$(ARCHSTR)/dboard : dboard $(FILES) utils/mk_wrapper utils/mk_wrapper $(PREFIX) dboard $(PREFIX)/bin/dashboard chmod a+x $(PREFIX)/bin/dashboard $(INSTALL) dboard $(PREFIX)/bin/.$(ARCHSTR)/dboard install : $(PREFIX)/bin/.$(ARCHSTR) $(PREFIX)/bin/.$(ARCHSTR)/mtest $(PREFIX)/bin/megatest \ 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? @@ -998,11 +1013,11 @@ ;; given span of seconds tstart to tend ;; find start time to mark and mark delta ;; (define (common:find-start-mark-and-mark-delta tstart tend) - (let* ((deltat (- tend tstart)) + (let* ((deltat (- (max tend (+ tend 10)) tstart)) ;; can't handle runs of less than 4 seconds. Pad it to 10 seconds ... (result #f) (min 60) (hr (* 60 60)) (day (* 24 hr)) (yr (* 365 day)) ;; year @@ -1295,5 +1310,22 @@ (if (null? tal) fallback-launcher (loop (car tal)(cdr tal)))))))) fallback-launcher))) +;;====================================================================== +;; D A S H B O A R D U S E R V I E W S +;;====================================================================== + +;; first read ~/views.config if it exists, then read $MTRAH/views.config if it exists +;; +(define (common:load-views-config) + (let* ((view-cfgdat (make-hash-table)) + (home-cfgfile (conc (get-environment-variable "HOME") "/.mtviews.config")) + (mthome-cfgfile (conc *toppath* "/.mtviews.config"))) + (if (file-exists? mthome-cfgfile) + (read-config mthome-cfgfile view-cfgdat #t)) + ;; we load the home dir file AFTER the MTRAH file so the user can clobber settings when running the dashboard in read-only areas + (if (file-exists? home-cfgfile) + (read-config home-cfgfile view-cfgdat #t)) + view-cfgdat)) + 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 @@ -8,10 +8,11 @@ ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ;; PURPOSE. ;;====================================================================== (use format) + (require-library iup) (import (prefix iup iup:)) (use canvas-draw) (import canvas-draw-iup) @@ -99,19 +100,20 @@ (exit 1))) ;; data common to all tabs goes here ;; (defstruct dboard:commondat - curr-tab-num + ((curr-tab-num 0) : number) please-update tabdats update-mutex 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) @@ -120,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 '()))) @@ -166,14 +173,18 @@ ((allruns-by-id (make-hash-table)) : hash-table) ;; hash of run-id -> dboard:rundat records ((done-runs '()) : list) ;; list of runs already drawn ((not-done-runs '()) : list) ;; list of runs not yet drawn (header #f) ;; header for decoding the run records (keys #f) ;; keys for this run (i.e. target components) - ((numruns (string->number (or (args:get-arg "-cols") "8"))) : number) ;; + ((numruns (string->number (or (args:get-arg "-cols") "10"))) : number) ;; ((tot-runs 0) : number) ((last-data-update 0) : number) ;; last time the data in allruns was updated + ((last-runs-update 0) : number) ;; last time we pulled the runs info to update the tree (runs-mutex (make-mutex)) ;; use to prevent parallel access to draw objects + ((run-update-times (make-hash-table)) : hash-table) ;; update times indexed by run-id + ((last-test-dat (make-hash-table)) : hash-table) ;; cache last tests dat by run-id + ((run-db-paths (make-hash-table)) : hash-table) ;; cache the paths to the run db files ;; Runs view ((buttondat (make-hash-table)) : hash-table) ;; ((item-test-names '()) : list) ;; list of itemized tests ((run-keys (make-hash-table)) : hash-table) @@ -206,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) ;; @@ -238,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))) @@ -296,24 +317,23 @@ tests-drawn ;; list of id's already drawn on screen tests-notdrawn ;; list of id's NOT already drawn rowsused ;; hash of lists covering what areas used - replace with quadtree hierdat ;; put hierarchial sorted list here tests ;; hash of id => testdat - tests-by-name ;; hash of testfullname => testdat + ((tests-by-name (make-hash-table)) : hash-table) ;; hash of testfullname => testdat key-vals - ((last-update 0) : fixnum) ;; last query to db got records from before last-update - data-changed + ((last-update 0) : fixnum) ;; last query to db got records from before last-update + ((data-changed #f) : boolean) + ((run-data-offset 0) : number) ;; get only 100 items per call, set back to zero when received less that 100 items + (db-path #f) ) -(define (dboard:rundat-make-init #!key (run #f)(key-vals #f)(tests #f)(last-update -100));; -100 is before time began +(define (dboard:rundat-make-init #!key (run #f)(key-vals #f)(tests #f));; -100 is before time began (make-dboard:rundat run: run tests: (or tests (make-hash-table)) - tests-by-name: (make-hash-table) key-vals: key-vals - last-update: last-update - data-changed: #t )) (define (dboard:rundat-copy-tests-to-by-name rundat) (let ((src-ht (dboard:rundat-tests rundat)) (trg-ht (dboard:rundat-tests-by-name rundat))) @@ -468,54 +488,97 @@ ;; 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* ((states (hash-table-keys (dboard:tabdat-state-ignore-hash tabdat))) + (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 'itempath)) ;; note: the rundat is normally created in "update-rundat". - (run-dat (let ((rec (hash-table-ref/default (dboard:tabdat-allruns-by-id tabdat) run-id #f))) - (if rec - rec - (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)))) + (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)) - (tmptests (rmt:get-tests-for-run run-id testnamepatt states statuses ;; run-id testpatt states statuses - #f #f ;; offset limit - (dboard:tabdat-hide-not-hide tabdat) ;; no-in - sort-by ;; sort-by - sort-order ;; sort-order - #f ;; 'shortlist ;; qrytype - (if (dboard:tabdat-filters-changed tabdat) - 0 - last-update) ;; last-update - *dashboard-mode*)) ;; use dashboard mode + (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 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 + #f ;; 'shortlist ;; qrytype + (if (dboard:tabdat-filters-changed tabdat) + 0 + last-update) ;; last-update + *dashboard-mode*) ;; use dashboard mode + '())) (use-new (dboard:tabdat-hide-not-hide tabdat)) (tests-ht (if (dboard:tabdat-filters-changed tabdat) (let ((ht (make-hash-table))) (dboard:rundat-tests-set! run-dat ht) ht) (dboard:rundat-tests run-dat))) (start-time (current-seconds))) + + ;; to limit the amount of data transferred each cycle use limit of num-to-get and offset + (dboard:rundat-run-data-offset-set! + run-dat + (if (< (length tmptests) num-to-get) + 0 + (let ((newval (+ num-to-get (dboard:rundat-run-data-offset run-dat)))) + ;; (print "Incremental get, offset=" (dboard:rundat-run-data-offset run-dat) " retrieved: " (length tmptests) " newval: " newval) + newval))) + (for-each (lambda (tdat) (let ((test-id (db:test-get-id tdat)) (state (db:test-get-state tdat))) (dboard:rundat-data-changed-set! run-dat #t) (if (equal? state "DELETED") (hash-table-delete! tests-ht test-id) (hash-table-set! tests-ht test-id tdat)))) tmptests) - (dboard:rundat-last-update-set! run-dat (- (current-seconds) 2)) ;; go back two seconds in time to ensure all changes are captured. + + ;; 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)) + ;; (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)) ;; tmptests - new tests data ;; prev-tests - old tests data @@ -538,20 +601,26 @@ ;; ;; create a virtual table of all the tests ;; keypatts: ( (KEY1 "abc%def")(KEY2 "%") ) ;; (define (update-rundat tabdat runnamepatt numruns testnamepatt keypatts) - (let* ((allruns (rmt:get-runs runnamepatt numruns (dboard:tabdat-start-run-offset tabdat) keypatts)) + (let* ((keys (rmt:get-keys)) + (last-runs-update (dboard:tabdat-last-runs-update tabdat)) + (allruns (rmt:get-runs runnamepatt numruns (dboard:tabdat-start-run-offset tabdat) keypatts)) + ;;(allruns-tree (rmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f)) + (allruns-tree (rmt:get-runs-by-patt keys "%" #f #f #f #f last-runs-update));;'("id" "runname") (header (db:get-header allruns)) - (runs (db:get-rows allruns)) + (runs (db:get-rows allruns)) ;; RA => Filtered as per runpatt selected + (runs-tree (db:get-rows allruns-tree)) ;; RA => Returns complete list of runs (start-time (current-seconds)) (runs-hash (let ((ht (make-hash-table))) (for-each (lambda (run) (hash-table-set! ht (db:get-value-by-header run header "id") run)) - runs) ;; (vector-ref runs-dat 1)) + runs-tree) ;; (vector-ref runs-dat 1)) ht)) (tb (dboard:tabdat-runs-tree tabdat))) + (dboard:tabdat-last-runs-update-set! tabdat (- (current-seconds) 2)) (dboard:tabdat-header-set! tabdat header) ;; ;; trim runs to only those that are changing often here ;; (if (null? runs) @@ -572,22 +641,23 @@ ;; GET RID OF dboard:get-tests-dat - it is superceded by dboard:get-tests-for-run-duplicate ;; dboard:get-tests-for-run-duplicate - returns a hash table ;; (dboard:get-tests-dat tabdat run-id last-update)) (all-test-ids (hash-table-keys tests-ht)) (num-tests (length all-test-ids))) + ;; (print "run-struct: " run-struct) ;; NOTE: bubble-up also sets the global (dboard:tabdat-item-test-names tabdat) ;; (tests (bubble-up tmptests priority: bubble-type)) ;; NOTE: 11/01/2013 This routine is *NOT* getting called excessively. ;; (debug:print 0 *default-log-port* "Getting data for run " run-id " with key-vals=" key-vals) ;; Not sure this is needed? (let* ((newmaxtests (max num-tests maxtests)) (last-update (- (current-seconds) 10)) - (run-struct (dboard:rundat-make-init - run: run - tests: tests-ht - key-vals: key-vals - last-update: last-update)) + (run-struct (or run-struct + (dboard:rundat-make-init + run: run + tests: tests-ht + key-vals: key-vals))) (new-res (if (null? all-test-ids) res (cons run-struct res))) (elapsed-time (- (current-seconds) start-time))) (if (null? all-test-ids) (hash-table-delete! (dboard:tabdat-allruns-by-id tabdat) run-id) (hash-table-set! (dboard:tabdat-allruns-by-id tabdat) run-id run-struct)) @@ -595,13 +665,18 @@ (> elapsed-time 2)) ;; stop loading data after 5 seconds, on the next call more data *should* be loaded since get-tests-for-run uses last update (begin (if (> elapsed-time 2)(print "WARNING: timed out in update-testdat " elapsed-time "s")) (dboard:tabdat-allruns-set! tabdat new-res) maxtests) - (loop (car tal)(cdr tal) new-res newmaxtests)))))) + (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)) @@ -751,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 @@ -853,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))) @@ -887,11 +962,11 @@ (hash-table-set! (dboard:tabdat-searchpatts tabdat) x val) (dboard:tabdat-filters-changed-set! tabdat #t) (set-bg-on-filter commondat tabdat)) (define (mark-for-update tabdat) - (dboard:tabdat-filters-changed-set! tabdat #t) + ;; (dboard:tabdat-filters-changed-set! tabdat #t) (dboard:tabdat-last-db-update-set! tabdat 0)) ;;====================================================================== ;; R U N C O N T R O L ;;====================================================================== @@ -1103,10 +1178,34 @@ ;; ((dboard:tabdat-updater-for-runs tabdat))) (if (or (not (equal? curr-runname (dboard:tabdat-run-name tabdat))) (equal? (dboard:tabdat-run-name tabdat) "")) (dboard:tabdat-run-name-set! tabdat curr-runname)) (dashboard:update-run-command tabdat))) + +;; used by run-controls +;; +(define (dashboard:update-tree-selector tabdat #!key (action-proc #f)) + (let* ((tb (dboard:tabdat-runs-tree tabdat)) + (runconf-targs (common:get-runconfig-targets)) + (db-target-dat (rmt:get-targets)) + (header (vector-ref db-target-dat 0)) + (db-targets (vector-ref db-target-dat 1)) + (munge-target (lambda (x) ;; create a target vector from a string. Pad with na if needed. + (take (append (string-split x "/") + (make-list (length header) "na")) + (length header)))) + (all-targets (append (list (munge-target (string-intersperse + (map (lambda (x) "%") header) + "/"))) + (map vector->list db-targets) + (map munge-target + runconf-targs) + ))) + (for-each + (lambda (target) + (tree:add-node tb "Runs" target)) ;; (append key-vals (list run-name)) + all-targets))) (define (dashboard:run-controls commondat tabdat #!key (tab-num #f)) (let* ((targets (make-hash-table)) (test-records (make-hash-table)) (all-tests-registry (tests:get-all)) ;; (tests:get-valid-tests *toppath* '())) @@ -1124,59 +1223,73 @@ ;; (hash-table-set! tests-draw-state 'scalef 1) (tests:get-full-data test-names test-records '() all-tests-registry) (set! sorted-testnames (tests:sort-by-priority-and-waiton test-records)) ;; refer to (dboard:tabdat-keys tabdat), (dboard:tabdat-dbkeys tabdat) for keys - (iup:vbox - (dcommon:command-execution-control tabdat) - (iup:split - #:orientation "VERTICAL" ;; "HORIZONTAL" - #:value 200 -;; -;; (iup:split -;; #:value 300 - - ;; Target, testpatt, state and status input boxes - ;; - (iup:vbox - ;; Command to run, placed over the top of the canvas - (dcommon:command-action-selector commondat tabdat tab-num: tab-num) - (dcommon:command-runname-selector commondat tabdat tab-num: tab-num) - (dcommon:command-testname-selector commondat tabdat update-keyvals)) ;; key-listboxes)) - - (dcommon:command-tests-tasks-canvas tabdat test-records sorted-testnames tests-draw-state)) - + (let* ((result + (iup:vbox + (dcommon:command-execution-control tabdat) + (iup:split + #:orientation "VERTICAL" ;; "HORIZONTAL" + #:value 200 + ;; + ;; (iup:split + ;; #:value 300 + + ;; Target, testpatt, state and status input boxes + ;; + (iup:vbox + ;; Command to run, placed over the top of the canvas + (dcommon:command-action-selector commondat tabdat tab-num: tab-num) + (dboard:runs-tree-browser commondat tabdat) + (dcommon:command-runname-selector commondat tabdat tab-num: tab-num) + (dcommon:command-testname-selector commondat tabdat update-keyvals)) + ;; key-listboxes)) + (dcommon:command-tests-tasks-canvas tabdat test-records sorted-testnames tests-draw-state)))) + (tb (dboard:tabdat-runs-tree tabdat))) + (dboard:commondat-add-updater + commondat + (lambda () + (dashboard:update-tree-selector tabdat)) + tab-num: tab-num) + result))) + ;;(iup:frame ;; #:title "Logs" ;; To be replaced with tabs ;; (let ((logs-tb (iup:textbox #:expand "YES" ;; #: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-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 @@ -1197,10 +1310,13 @@ (if (> (- now-time last-data-update) 5) (if (not (dboard:tabdat-running-layout tabdat)) (begin (dashboard:run-times-tab-run-data-updater commondat tabdat tab-num) (dboard:tabdat-last-data-update-set! tabdat now-time) + ;; this is threadified to return control to the gui for a redraw. + ;; it relies on the running-layout flag to prevent overlapping + ;; calls. (thread-start! (make-thread (lambda () (dboard:tabdat-running-layout-set! tabdat #t) (dashboard:run-times-tab-layout-updater commondat tabdat tab-num) (dboard:tabdat-running-layout-set! tabdat #f)) @@ -1256,11 +1372,11 @@ (let ((drawing (dboard:tabdat-drawing tabdat)) (old-xadj (dboard:tabdat-xadj tabdat)) (old-yadj (dboard:tabdat-yadj tabdat))) (if (not (and (eq? xadj old-xadj)(eq? yadj old-yadj))) (begin - (print "xadj: " xadj " yadj: " yadj "changed: "(eq? xadj old-xadj) " " (eq? yadj old-yadj)) + ;; (print "xadj: " xadj " yadj: " yadj "changed: "(eq? xadj old-xadj) " " (eq? yadj old-yadj)) (dboard:tabdat-view-changed-set! tabdat #t) (dboard:tabdat-xadj-set! tabdat (* -2000 (- xadj 0.5))) (dboard:tabdat-yadj-set! tabdat (* 2000 (- yadj 0.5))) )))) "iup:canvas action"))) @@ -1268,11 +1384,11 @@ (debug:catch-and-dump (lambda () (let* ((drawing (dboard:tabdat-drawing tabdat)) (scalex (vg:drawing-scalex drawing))) (dboard:tabdat-view-changed-set! tabdat #t) - (print "step: " step " x: " x " y: " y " dir: " dir " scalex: " scalex) + ;; (print "step: " step " x: " x " y: " y " dir: " dir " scalex: " scalex) (vg:drawing-scalex-set! drawing (+ scalex (if (> step 0) (* scalex 0.02) (* scalex -0.02)))))) @@ -1290,11 +1406,11 @@ (if (not (null? path)) (hash-table-ref/default (dboard:tabdat-path-run-ids tabdat) path #f) #f)) (define (dboard:get-tests-dat tabdat run-id last-update) - (let ((tdat (if run-id (rmt:get-tests-for-run run-id + (let* ((tdat (if run-id (rmt:get-tests-for-run run-id (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "test-name" "%/%") (hash-table-keys (dboard:tabdat-state-ignore-hash tabdat)) ;; '() (hash-table-keys (dboard:tabdat-status-ignore-hash tabdat)) ;; '() #f #f ;; offset limit (dboard:tabdat-hide-not-hide tabdat) ;; not-in @@ -1329,11 +1445,13 @@ (record-b (hash-table-ref runs-hash b)) (time-a (db:get-value-by-header record-a runs-header "event_time")) (time-b (db:get-value-by-header record-b runs-header "event_time"))) (< time-a time-b))))) (changed #f) - (runs-dat (rmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f))) + (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))) + (dboard:tabdat-last-runs-update-set! tabdat (- (current-seconds) 2)) (for-each (lambda (run-id) (let* ((run-record (hash-table-ref/default runs-hash run-id #f)) (key-vals (map (lambda (key)(db:get-value-by-header run-record runs-header key)) (dboard:tabdat-keys tabdat))) (run-name (db:get-value-by-header run-record runs-header "runname")) @@ -1351,103 +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* ((runs-dat (rmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f)) + +(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)) - (last-update 0) ;; fix me - have to create and store a rundat record for this - (tests-dat (dboard:get-tests-dat tabdat run-id last-update)) - (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) - (runs-hash (let ((ht (make-hash-table))) + (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))) - (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") - (iup:attribute-set! run-matrix "NUMCOL" max-col ) - (iup:attribute-set! run-matrix "NUMLIN" (if (< max-row max-visible) max-visible max-row)))) ;; min of 20 - - ;; 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) - (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-debug-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"))))) + 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* ((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 ;;====================================================================== ;; @@ -1481,259 +1678,285 @@ ;; #:title "Disks Areas" (dcommon:section-matrix rawconfig "disks" "Disk area" "Path")))) (iup:frame #:title "Run statistics" (dcommon:run-stats commondat tabdat tab-num: tab-num))))) + +;;====================================================================== +;; H A N D L E U S E R C O N T R I B U T E D V I E W S +;;====================================================================== + +(define (dboard:add-external-tab commondat view-name views-cfgdat tabs tab-num) + (let* ((success #t) ;; at any stage of the process set this flag to #f to skip downstream steps. Intention here is to recover gracefully if user provided tabs fail to load. + (source (configf:lookup views-cfgdat view-name "source")) + (viewgen (configf:lookup views-cfgdat view-name "viewgen")) + (updater (configf:lookup views-cfgdat view-name "updater")) + (result-child #f)) + (if (and (file-exists? source) + (file-read-access? source)) + (handle-exceptions + exn + (begin + (print-call-chain) + (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) + (debug:print 0 *default-log-port* "ERROR: failed to load " source ", try loading in the repl: megatest -repl") + (set! success #f)) + (load source)) + (begin + (debug:print 0 *default-log-port* "ERROR: cannot find file to load: \"" source "\" for user view " view-name))) + ;; now run the user supplied definition for the tab view + (if success + (handle-exceptions + exn + (begin + (print-call-chain) + (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) + (debug:print 0 *default-log-port* "ERROR: failed call procedure " viewgen + ", with; tab-num=" tab-num ", view-name=" view-name + ", and views-cfgdat and megatest configdat as parameters. To debug try loading in the repl: megatest -repl") + (set! success #f)) + (print "Adding tab " view-name " with proc " viewgen) + ;; (iup:child-add! tabs + (set! result-child + ((eval (string->symbol viewgen)) commondat tabs tab-num view-name views-cfgdat *configdat*)))) + ;; and finally set the updater + (if success + (dboard:commondat-add-updater commondat + (lambda () + (handle-exceptions + exn + (begin + (print-call-chain) + (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) + (debug:print 0 *default-log-port* "ERROR: failed call procedure \"" updater + "\", with; tabnum=" tabnum ", view-name=" view-name + ", and views-cfgdat and megatest configdat as parameters. To debug try loading in the repl: megatest -repl") + (set! success #f)) + (debug:print 4 *default-log-port* "Running updater for tab " view-name " with proc " updater " and tab-num: " tab-num) + ((eval (string->symbol updater)) commondat tabs tab-num view-name views-cfgdat *configdat*))) + tab-num: tab-num)) + (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 -;; (define dashboard:update-run-summary-tab #f) -;; (define dashboard:update-new-view-tab #f) - ;; This is the Run Summary tab ;; -(define (dashboard:one-run commondat tabdat #!key (tab-num #f)) - (let* ((tb (iup:treebox +(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" #:addexpanded "NO" #:selection-cb (lambda (obj id state) - ;; (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-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) - )) + (debug:catch-and-dump + (lambda () + ;; (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 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 (lambda () - (if (dashboard:database-changed? commondat tabdat) - (dashboard:one-run-updater commondat tabdat tb cell-lookup run-matrix))))) - (dboard:commondat-add-updater commondat one-run-updater tab-num: tab-num) + (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:runs-summary-updater commondat tabdat tb cell-lookup run-matrix))) + "dashboard:runs-summary-updater") + ) + (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:split - tb - run-matrix))) -;; (iup:vbox -;; (let* ((cnv-obj (iup:canvas -;; ;; #:size "500x400" -;; #:expand "YES" -;; #:scrollbar "YES" -;; #:posx "0.5" -;; #:posy "0.5" -;; #:action (make-canvas-action -;; (lambda (c xadj yadj) -;; (debug:catch-and-dump -;; (lambda () -;; (if (not (dboard:tabdat-cnv tabdat)) -;; (dboard:tabdat-cnv-set! tabdat c)) -;; (let ((drawing (dboard:tabdat-drawing tabdat)) -;; (old-xadj (dboard:tabdat-xadj tabdat)) -;; (old-yadj (dboard:tabdat-yadj tabdat))) -;; (if (not (and (eq? xadj old-xadj)(eq? yadj old-yadj))) -;; (begin -;; (print "xadj: " xadj " yadj: " yadj "changed: "(eq? xadj old-xadj) " " (eq? yadj old-yadj)) -;; (dboard:tabdat-view-changed-set! tabdat #t) -;; (dboard:tabdat-xadj-set! tabdat (* -500 (- xadj 0.5))) -;; (dboard:tabdat-yadj-set! tabdat (* 500 (- yadj 0.5))) -;; )))) -;; "iup:canvas action dashboard:one-run"))) -;; #:wheel-cb (lambda (obj step x y dir) ;; dir is 4 for up and 5 for down. I think. -;; (debug:catch-and-dump -;; (lambda () -;; (let* ((drawing (dboard:tabdat-drawing tabdat)) -;; (scalex (vg:drawing-scalex drawing))) -;; (dboard:tabdat-view-changed-set! tabdat #t) -;; (print "step: " step " x: " x " y: " y " dir: " dir " scalex: " scalex) -;; (vg:drawing-scalex-set! drawing -;; (+ scalex -;; (if (> step 0) -;; (* scalex 0.02) -;; (* scalex -0.02)))))) -;; "dashboard:one-run wheel-cb")) -;; ))) -;; cnv-obj)))) - - -;; This is the New View tab -;; -;; (define (dashboard:new-view db commondat tabdat #!key (tab-num #f)) -;; (let* ((tb (iup:treebox -;; #:value 0 -;; #:name "Runs" -;; #:expand "YES" -;; #:addexpanded "NO" -;; #:selection-cb -;; (lambda (obj id state) -;; ;; (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-curr-run-id-set! tabdat run-id) -;; ;; (dashboard:update-new-view-tab) -;; (dboard:tabdat-layout-update-ok-set! tabdat #f) -;; ) -;; (debug:print-error 0 *default-log-port* "tree-path->run-id returned non-number " run-id))) -;; ;; (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))))) -;; (new-view-updater (lambda () -;; (if (dashboard:database-changed? commondat tabdat) -;; (let* ((runs-dat (rmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f)) -;; (runs-header (vector-ref runs-dat 0)) ;; 0 is header, 1 is list of records -;; (run-id (dboard:tabdat-curr-run-id tabdat)) -;; (last-update 0) ;; fix me -;; (tests-dat (dboard:get-tests-dat tabdat run-id last-update)) -;; (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) -;; (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)) -;; (run-ids (sort (filter number? (hash-table-keys runs-hash)) -;; (lambda (a b) -;; (let* ((record-a (hash-table-ref runs-hash a)) -;; (record-b (hash-table-ref runs-hash b)) -;; (time-a (db:get-value-by-header record-a runs-header "event_time")) -;; (time-b (db:get-value-by-header record-b runs-header "event_time"))) -;; (< time-a time-b)))))) -;; ;; (iup:attribute-set! tb "VALUE" "0") -;; ;; (iup:attribute-set! tb "NAME" "Runs") -;; ;; Update the runs tree -;; (for-each (lambda (run-id) -;; (let* ((run-record (hash-table-ref/default runs-hash run-id #f)) -;; (key-vals (map (lambda (key)(db:get-value-by-header run-record runs-header key)) -;; (dboard:tabdat-keys tabdat))) -;; (run-name (db:get-value-by-header run-record runs-header "runname")) -;; (col-name (conc (string-intersperse key-vals "\n") "\n" run-name)) -;; (run-path (append key-vals (list run-name))) -;; (existing (tree:find-node tb run-path))) -;; (if (not (hash-table-ref/default (dboard:tabdat-path-run-ids tabdat) run-path #f)) -;; (begin -;; (hash-table-set! (dboard:tabdat-run-keys tabdat) run-id run-path) -;; ;; (iup:attribute-set! (dboard:tabdat-runs-matrix tabdat) -;; ;; (conc rownum ":" colnum) col-name) -;; ;; (hash-table-set! runid-to-col run-id (list colnum run-record)) -;; ;; Here we update the tests treebox and tree keys -;; (tree:add-node tb "Runs" run-path ;; (append key-vals (list run-name)) -;; 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) -;; (iup:attribute-set! run-matrix "CLEARVALUE" "ALL") ;; NOTE: Was CONTENTS -;; (iup:attribute-set! run-matrix "CLEARATTRIB" "CONTENTS") -;; (iup:attribute-set! run-matrix "RESIZEMATRIX" "YES") -;; (iup:attribute-set! run-matrix "NUMCOL" max-col ) -;; (iup:attribute-set! run-matrix "NUMLIN" (if (< max-row max-visible) max-visible max-row)) ;; min of 20 -;; ;; (iup:attribute-set! run-matrix "NUMCOL_VISIBLE" max-col) -;; ;; (iup:attribute-set! run-matrix "NUMLIN_VISIBLE" (if (> max-row max-visible) max-visible 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) -;; -;; -;; ;; Cell contents -;; (for-each (lambda (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) -;; (iup:attribute-set! run-matrix "FITTOTEXT" (conc "C" num)))))) -;; col-indices) -;; (if changed (iup:attribute-set! run-matrix "REDRAW" "ALL"))))))) -;; (dboard:commondat-add-updater commondat new-view-updater tab-num: tab-num) -;; (dboard:tabdat-runs-tree-set! tabdat tb) -;; (iup:split -;; tb -;; run-matrix))) + (iup:vbox + (iup:split + #:value 200 + tb + run-matrix) + (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 @@ -1764,12 +1987,11 @@ (hash-table-delete! *collapsed* tname)) (hash-table-keys *collapsed*)) (iup:attribute-set! obj "TITLE" "Collapse")))) (mark-for-update tabdat)) "make-controls collapse button")) - #:expand "NO" #:size "40x15")) - ) + #:expand "NO" #:size "40x15"))) (iup:vbox ;; (iup:button "Sort -t" #:action (lambda (obj) ;; (next-sort-option) ;; (iup:attribute-set! obj "TITLE" (vector-ref (vector-ref *tests-sort-options* *tests-sort-reverse*) 0)) ;; (mark-for-update tabdat))) @@ -1785,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" @@ -1812,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 @@ -1854,27 +2088,69 @@ (dboard:tabdat-start-run-offset-set! tabdat val) (mark-for-update tabdat) (debug:print 6 *default-log-port* "(dboard:tabdat-start-run-offset tabdat) " (dboard:tabdat-start-run-offset tabdat) " maxruns: " maxruns ", val: " val " oldmax: " oldmax) (iup:attribute-set! obj "MAX" (* maxruns 10)))) #:expand "HORIZONTAL" - #:max (* 10 (length (dboard:tabdat-allruns tabdat))) + #: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) +(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) + ;; (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") @@ -1893,41 +2169,50 @@ #: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 " test-name) + (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 " test-name + " -testpatt " item-test-path " -preclean -clean-cache")))) (iup:menu-item - (conc "Kill " test-name) + (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 " test-name + " -testpatt " item-test-path " -state RUNNING,REMOTEHOSTSTART,LAUNCHED")))) (iup:menu-item - (conc "Clean " test-name) + (conc "Clean "item-test-path) #:action (lambda (obj) (common:run-a-command (conc "megatest -remove-runs -target " target " -runname " runname - " -testpatt " test-name)))) + " -testpatt " item-test-path)))) (iup:menu-item "Start xterm" #:action (lambda (obj) (dcommon:examine-xterm run-id test-id))) @@ -1952,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)) @@ -1963,21 +2248,21 @@ (nkeys (length keynames)) (runsvec (make-vector nruns)) (header (make-vector nruns)) (lftcol (make-vector ntests)) (keycol (make-vector ntests)) - (controls '()) + (controls (dboard:make-controls commondat runs-dat)) ;; '()) (lftlst '()) (hdrlst '()) (bdylst '()) (result '()) (i 0) (btn-height (dboard:tabdat-runs-btn-height runs-dat)) (btn-fontsz (dboard:tabdat-runs-btn-fontsz runs-dat)) (cell-width (dboard:tabdat-runs-cell-width runs-dat))) ;; controls (along bottom) - (set! controls (dboard:make-controls commondat runs-dat)) + ;; (set! controls (dboard:make-controls commondat runs-dat)) ;; create the left most column for the run key names and the test names (set! lftlst (list (iup:hbox (iup:label) ;; (iup:valuator) (apply iup:vbox @@ -2017,11 +2302,11 @@ #:flat "YES" #:alignment "ALEFT" ; #:image img1 ; #:impress img2 #:size (conc cell-width btn-height) - #:expand "NO" ;; "HORIZONTAL" + #:expand "HORIZONTAL" #:fontsize btn-fontsz #:action (lambda (obj) (mark-for-update runs-dat) (toggle-hide testnum (dboard:commondat-uidat commondat)))))) ;; (iup:attribute obj "TITLE")))) (vector-set! lftcol testnum labl) @@ -2077,12 +2362,16 @@ (if tlast (let ((tpatt (tasks:task-get-testpatt tlast))) (if (member tpatt '("0" 0)) ;; known bad historical value - remove in 2017 "%" tpatt)) - "%")))) - (iup:show (dashboard:popup-menu buttndat run-id test-id target runname test-name testpatt) ;; popup-menu + "%"))) + (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 run-id test-id target runname test-name testpatt item-test-path) ;; popup-menu #:x 'mouse #:y 'mouse #:modal? "NO") ;; (print "got here") )) @@ -2105,57 +2394,92 @@ (let* ((runs-view (iup:vbox (iup:split #:orientation "VERTICAL" ;; "HORIZONTAL" #:value 150 (dboard:runs-tree-browser commondat runs-dat) - (apply iup:hbox - (cons (apply iup:vbox lftlst) - (list - (iup:vbox - ;; the header - (apply iup:hbox (reverse hdrlst)) - (apply iup:hbox (reverse bdylst))))))) + (iup:split + ;; left most block, including row names + (apply iup:vbox lftlst) + ;; right hand block, including cells + (iup:vbox + ;; the header + (apply iup:hbox (reverse hdrlst)) + (apply iup:hbox (reverse bdylst))))) controls )) + (views-cfgdat (common:load-views-config)) + (additional-tabnames '()) + (tab-start-num 5) ;; DON'T FORGET TO UPDATE THIS WHEN CHANGING THE STANDARD TABS BELOW ;; (data (dboard:tabdat-init (make-d:data))) - (tabs (iup:tabs - #:tabchangepos-cb (lambda (obj curr prev) - (debug:catch-and-dump - (lambda () - (let* ((tab-num (dboard:commondat-curr-tab-num commondat)) - (tabdat (dboard:common-get-tabdat commondat tab-num: tab-num))) - (dboard:tabdat-layout-update-ok-set! tabdat #f)) - (dboard:commondat-curr-tab-num-set! commondat curr) - (let* ((tab-num (dboard:commondat-curr-tab-num commondat)) - (tabdat (dboard:common-get-tabdat commondat tab-num: tab-num))) - (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: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 ;; process views-dat + (let ((tab-num tab-start-num) + (result '())) + (for-each + (lambda (view-name) + (debug:print 0 *default-log-port* "Adding view " view-name) + (let* ((cfgtype (configf:lookup views-cfgdat view-name "type"))) ;; what type of view? + (if (not (string? cfgtype)) + (debug:print-info 0 *default-log-port* "WARNING: view \"" view-name + "\" is missing needed sections. Please consult the documenation and update ~/.mtviews.config or " *toppath* "/.mtviews.config") + (case (string->symbol cfgtype) + ;; user supplied source for a tab + ;; + ((external) + (let ((tab-content (dboard:add-external-tab commondat view-name views-cfgdat #f tab-num))) ;; was tabs + (set! additional-tabnames (cons (cons tab-num view-name) additional-tabnames)) + (set! tab-num (+ tab-num 1)) + (set! result (append result (list tab-content))))))))) + (sort (hash-table-keys views-cfgdat) (lambda (a b) + (let ((order-a (or (any->number (configf:lookup views-cfgdat a "order")) 999)) + (order-b (or (any->number (configf:lookup views-cfgdat b "order")) 999))) + (> order-a order-b))))) + result)) + (tabs (apply iup:tabs + #:tabchangepos-cb (lambda (obj curr prev) + (debug:catch-and-dump + (lambda () + (let* ((tab-num (dboard:commondat-curr-tab-num commondat)) + (tabdat (dboard:common-get-tabdat commondat tab-num: tab-num))) + (dboard:tabdat-layout-update-ok-set! tabdat #f)) + (dboard:commondat-curr-tab-num-set! commondat curr) + (let* ((tab-num (dboard:commondat-curr-tab-num commondat)) + (tabdat (dboard:common-get-tabdat commondat tab-num: tab-num))) + (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: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))) (iup:attribute-set! tabs "TABTITLE0" "Summary") (iup:attribute-set! tabs "TABTITLE1" "Runs") (iup:attribute-set! tabs "TABTITLE2" "Run Summary") (iup:attribute-set! tabs "TABTITLE3" "Run Control") (iup:attribute-set! tabs "TABTITLE4" "Run Times") ;; (iup:attribute-set! tabs "TABTITLE3" "New View") ;; (iup:attribute-set! tabs "TABTITLE4" "Run Control") + + ;; set the tab names for user added tabs + (for-each + (lambda (tab-info) + (iup:attribute-set! tabs (conc "TABTITLE" (car tab-info)) (cdr tab-info))) + additional-tabnames) + (iup:attribute-set! tabs "BGCOLOR" "190 190 190") ;; make the iup tabs object available (for changing color for example) (dboard:commondat-hide-not-hide-tabs-set! commondat tabs) ;; now set up the tabdat lookup (dboard:common-set-tabdat! commondat 0 stats-dat) (dboard:common-set-tabdat! commondat 1 runs-dat) (dboard:common-set-tabdat! commondat 2 onerun-dat) (dboard:common-set-tabdat! commondat 3 runcontrols-dat) (dboard:common-set-tabdat! commondat 4 runtimes-dat) + (iup:vbox tabs ;; controls )))) (vector keycol lftcol header runsvec))) @@ -2171,14 +2495,14 @@ (iup:attribute-set! *tim* "TIME" 300) (iup:attribute-set! *tim* "RUN" "YES") (define *last-recalc-ended-time* 0) -(define (dashboard:been-changed) +(define (dashboard:been-changed tabdat) (> (file-modification-time (dboard:tabdat-dbfpath tabdat)) (dboard:tabdat-last-db-update tabdat))) -(define (dashboard:set-db-update-time) +(define (dashboard:set-db-update-time tabdat) (dboard:tabdat-last-db-update-set! tabdat (file-modification-time (dboard:tabdat-dbfpath tabdat)))) (define (dashboard:recalc modtime please-update-buttons last-db-update-time) (or please-update-buttons (and (> (current-milliseconds)(+ *last-recalc-ended-time* 150)) @@ -2225,12 +2549,12 @@ ;; point inside line ;; (define-inline (dashboard:px-between px lx1 lx2) (and (< lx1 px)(> lx2 px))) -(define (dashboard:summary-tab-updater commondat tab-num) - (if dashboard:update-summary-tab (dashboard:update-summary-tab))) +;;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))) @@ -2324,11 +2648,12 @@ (db:test-get-event_time (hash-table-ref testsdat (car b)))))))))) ;; run times tab data updater ;; (define (dashboard:run-times-tab-run-data-updater commondat tabdat tab-num) - (let* ((runs-dat (rmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f)) + (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-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)) @@ -2342,10 +2667,11 @@ (< time-a time-b))))) (tb (dboard:tabdat-runs-tree tabdat)) (num-runs (length (hash-table-keys runs-hash))) (update-start-time (current-seconds)) (inc-mode #f)) + (dboard:tabdat-last-runs-update-set! tabdat (- (current-seconds) 2)) ;; fill in the tree (if (and tb (not inc-mode)) (for-each (lambda (run-id) @@ -2364,11 +2690,11 @@ 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)) - (print "Updating rundat") + ;; (print "Updating rundat") (if (dboard:tabdat-keys tabdat) ;; have keys yet? (let* ((num-keys (length (dboard:tabdat-keys tabdat))) (targpatt (map (lambda (k v) (list k v)) (dboard:tabdat-keys tabdat) @@ -2380,11 +2706,11 @@ (runpatt (if (dboard:tabdat-target tabdat) (last (dboard:tabdat-target tabdat)) "%")) (testpatt (or (dboard:tabdat-test-patts tabdat) "%")) (filtrstr (conc targpatt "/" runpatt "/" testpatt))) - (print "targpatt: " targpatt " runpatt: " runpatt " testpatt: " testpatt) + ;; (print "targpatt: " targpatt " runpatt: " runpatt " testpatt: " testpatt) (if (not (equal? (dboard:tabdat-last-filter-str tabdat) filtrstr)) (let ((dwg (dboard:tabdat-drawing tabdat))) (print "reseting drawing") (dboard:tabdat-layout-update-ok-set! tabdat #f) @@ -2396,11 +2722,11 @@ (dboard:tabdat-max-row-set! tabdat 0) (dboard:tabdat-last-filter-str-set! tabdat filtrstr))) (update-rundat tabdat runpatt ;; (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "runname" "%") - 10 ;; (dboard:tabdat-numruns tabdat) + (dboard:tabdat-numruns tabdat) testpatt ;; (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "test-name" "%/%") ;; (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "item-name" "%") targpatt @@ -2538,11 +2864,12 @@ (let* ((maxval (apply max vals)) (minval (min 0 (apply min vals))) (yoff (- minval lly)) ;; minval)) (deltaval (- maxval minval)) (yscale (/ delta-y (if (zero? deltaval) 1 deltaval))) - (yfunc (lambda (y)(+ lly (* yscale (- y minval)))))) ;; (lambda (y)(* (+ y yoff) yscale)))) + (yfunc (lambda (y)(+ lly (* yscale (- y minval))))) ;; (lambda (y)(* (+ y yoff) yscale)))) + (graph-color (vg:generate-color))) ;; (print (car cf) "; maxval: " maxval " minval: " minval " deltaval: " deltaval " yscale: " yscale) (vg:add-obj-to-comp cmp (vg:make-text-obj (- llx 10)(yfunc maxval) (conc maxval))) (vg:add-obj-to-comp @@ -2549,28 +2876,28 @@ cmp (vg:make-text-obj (- llx 10)(yfunc minval) (conc minval))) (fold (lambda (next prev) ;; #(time ? val) #(time ? val) (if prev - (let* ((yval (vector-ref prev 2)) - (yval-next (vector-ref next 2)) - (last-tval (tfn (vector-ref prev 0))) - (last-yval (yfunc yval)) ;; (+ lly (* yscale (vector-ref prev 2)))) - (next-yval (yfunc yval-next)) - (curr-tval (tfn (vector-ref next 0)))) + (let* ((yval (vector-ref prev 2)) + (yval-next (vector-ref next 2)) + (last-tval (tfn (vector-ref prev 0))) + (last-yval (yfunc yval)) ;; (+ lly (* yscale (vector-ref prev 2)))) + (next-yval (yfunc yval-next)) + (curr-tval (tfn (vector-ref next 0)))) (if (>= curr-tval last-tval) (begin (vg:add-obj-to-comp cmp ;;(vg:make-rect-obj last-tval lly curr-tval last-yval ;; (- stval 2) lly (+ stval 2)(+ lly (* yval yscale)) (vg:make-line-obj last-tval last-yval curr-tval last-yval - line-color: stdcolor)) + line-color: graph-color)) (vg:add-obj-to-comp cmp ;;(vg:make-rect-obj last-tval lly curr-tval last-yval ;; (- stval 2) lly (+ stval 2)(+ lly (* yval yscale)) (vg:make-line-obj curr-tval last-yval curr-tval next-yval - line-color: stdcolor))) + line-color: graph-color))) (print "ERROR: curr-tval is not > last-tval; curr-tval " curr-tval ", last-tval " last-tval)))) next) ;; for init create vector tstart,0 #f ;; (vector tstart minval minval) dat) @@ -2656,11 +2983,12 @@ (testsdat (hash-table-values tests-ht)) (runcomp (vg:comp-new));; new component for this run (rows-used (make-hash-table)) ;; keep track of what parts of the rows are used here row1 = (obj1 obj2 ...) ;; (row-height 4) (run-start (dboard:min-max < (map db:test-get-event_time testsdat))) - (run-end (dboard:min-max > (map (lambda (t)(+ (db:test-get-event_time t)(db:test-get-run_duration t))) testsdat))) + (run-end (let ((re (dboard:min-max > (map (lambda (t)(+ (db:test-get-event_time t)(db:test-get-run_duration t))) testsdat)))) + (max re (+ 1 run-start)))) ;; use run-start+1 if run-start == run-end so delta is not zero (timeoffset (- run-start)) ;; (+ fixed-originx canvas-margin) run-start)) (run-duration (- run-end run-start)) (timescale (/ (- sizex (* 2 canvas-margin)) (if (> run-duration 0) run-duration @@ -2814,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) @@ -2863,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))) @@ -2924,14 +3332,15 @@ 1)))) (let ((th1 (make-thread (lambda () (thread-sleep! 1) (dboard:common-run-curr-updaters commondat 0) ;; force update of summary tab - (dboard:commondat-please-update-set! commondat #t) + ;; (dboard:commondat-please-update-set! commondat #t) ;; MRW: ww36.3 - why was please update set true here? Removing it for now. ;; (dashboard:run-update commondat) ) "update buttons once")) (th2 (make-thread iup:main-loop "Main loop"))) - (thread-start! th1) + ;; (thread-start! th1) (thread-start! th2) (thread-join! th2)))) (main) + 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 ;; @@ -1962,11 +1990,11 @@ ;; register a test run with the db ;; ;; Use: (db:get-value-by-header (db:get-header runinfo)(db:get-rows runinfo)) ;; to extract info from the structure returned ;; -(define (db:get-runs-by-patt dbstruct keys runnamepatt targpatt offset limit fields) ;; test-name) +(define (db:get-runs-by-patt dbstruct keys runnamepatt targpatt offset limit fields last-update) ;; test-name) (let* ((tmp (runs:get-std-run-fields keys (or fields '("id" "runname" "state" "status" "owner" "event_time")))) (keystr (car tmp)) (header (cadr tmp)) (res '()) (key-patt "") @@ -1982,11 +2010,15 @@ (set! key-patt (conc key-patt " AND " key " " wildtype " '" patt "'")) (begin (debug:print-error 0 *default-log-port* "searching for runs with no pattern set for " fulkey) (exit 6))))) keyvals) - (set! qry-str (conc "SELECT " keystr " FROM runs WHERE state != 'deleted' AND runname " runwildtype " ? " key-patt " ORDER BY event_time " + (set! qry-str (conc "SELECT " keystr " FROM runs WHERE state != 'deleted' AND runname " runwildtype " ? " key-patt + (if last-update + (conc " AND last_update >= " last-update " ") + " ") + " ORDER BY event_time " (if limit (conc " LIMIT " limit) "") (if offset (conc " OFFSET " offset) "") ";")) (debug:print-info 4 *default-log-port* "runs:get-runs-by-patt qry=" qry-str " " runnamepatt) (db:with-db dbstruct #f #f ;; reads db, does not write to it. @@ -3345,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 .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"))) @@ -3381,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)) @@ -275,33 +275,141 @@ (tal (cdr tests-dat)) (res '())) (let* ((test-id (db:test-get-id hed)) ;; look at the tests-dat spec for locations (test-name (db:test-get-testname hed)) (item-path (db:test-get-item-path hed)) - (state (db:test-get-status hed)) + (state (db:test-get-state hed)) (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 @@ -940,11 +1048,11 @@ (dashboard:update-run-command tabdat)))) "command-runname-selector lb action")))) (refresh-runs-list (lambda () (if (dashboard:database-changed? commondat tabdat) (let* ((target (dboard:tabdat-target-string tabdat)) - (runs-for-targ (rmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" target #f #f #f)) + (runs-for-targ (rmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" target #f #f #f 0)) (runs-header (vector-ref runs-for-targ 0)) (runs-dat (vector-ref runs-for-targ 1)) (run-names (cons default-run-name (map (lambda (x) (db:get-value-by-header x runs-header "runname")) 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)) 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.6103) +(define megatest-version 1.6201) Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -36,11 +36,11 @@ (declare (uses client)) (declare (uses tests)) (declare (uses genexample)) (declare (uses daemon)) (declare (uses db)) -(declare (uses dcommon)) +;; (declare (uses dcommon)) (declare (uses tdb)) (declare (uses mt)) (declare (uses api)) (declare (uses tasks)) ;; only used for debugging. @@ -1041,11 +1041,11 @@ ;; (args:get-arg "-testpatt") ;; "%")) (keys (rmt:get-keys)) ;; (db:get-keys dbstruct)) ;; (runsda t (db:get-runs dbstruct runpatt #f #f '())) (runsdat (rmt:get-runs-by-patt keys (or runpatt "%") (common:args-get-target) ;; (db:get-runs-by-patt dbstruct keys (or runpatt "%") (common:args-get-target) - #f #f '("id" "runname" "state" "status" "owner" "event_time" "comment"))) + #f #f '("id" "runname" "state" "status" "owner" "event_time" "comment") 0)) (runstmp (db:get-rows runsdat)) (header (db:get-header runsdat)) ;; this is "-since" support. This looks at last mod times of .db files ;; and collects those modified since the -since time. (runs (if (and (not (null? runstmp)) @@ -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,11 @@ (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> "))) (begin Index: mt.scm ================================================================== --- mt.scm +++ mt.scm @@ -41,11 +41,11 @@ ;; ;; Use: (db-get-value-by-header (db:get-header runinfo)(db:get-rows runinfo)) ;; to extract info from the structure returned ;; (define (mt:get-runs-by-patt keys runnamepatt targpatt) - (let loop ((runsdat (rmt:get-runs-by-patt keys runnamepatt targpatt 0 500 #f)) + (let loop ((runsdat (rmt:get-runs-by-patt keys runnamepatt targpatt 0 500 #f 0)) (res '()) (offset 0) (limit 500)) ;; (print "runsdat: " runsdat) (let* ((header (vector-ref runsdat 0)) @@ -53,11 +53,11 @@ (full-list (append res runslst)) (have-more (eq? (length runslst) limit))) ;; (debug:print 0 *default-log-port* "header: " header " runslst: " runslst " have-more: " have-more) (if have-more (let ((new-offset (+ offset limit)) - (next-batch (rmt:get-runs-by-patt keys runnamepatt targpatt offset limit #f))) + (next-batch (rmt:get-runs-by-patt keys runnamepatt targpatt offset limit #f 0))) (debug:print-info 4 *default-log-port* "More than " limit " runs, have " (length full-list) " runs so far.") (debug:print-info 0 *default-log-port* "next-batch: " next-batch) (loop next-batch full-list new-offset 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 @@ -576,12 +579,12 @@ (rmt:send-receive 'set-run-status #f (list run-id run-status msg))) (define (rmt:update-run-event_time run-id) (rmt:send-receive 'update-run-event_time #f (list run-id))) -(define (rmt:get-runs-by-patt keys runnamepatt targpatt offset limit fields) ;; fields of #f uses default - (rmt:send-receive 'get-runs-by-patt #f (list keys runnamepatt targpatt offset limit fields))) +(define (rmt:get-runs-by-patt keys runnamepatt targpatt offset limit fields last-runs-update) ;; fields of #f uses default + (rmt:send-receive 'get-runs-by-patt #f (list keys runnamepatt targpatt offset limit fields last-runs-update))) (define (rmt:find-and-mark-incomplete run-id ovr-deadtime) (if (rmt:send-receive 'have-incompletes? run-id (list run-id ovr-deadtime)) (rmt:send-receive 'mark-incomplete run-id (list run-id ovr-deadtime)))) Index: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -943,10 +943,11 @@ (runs:queue-next-tal newtal reg reglen regfull) (runs:queue-next-reg newtal reg reglen regfull) reruns))))))))) ;; scan a list of tests looking to see if any are potentially runnable +;; (define (runs:runable-tests tests) (filter (lambda (t) (if (not (vector? t)) t (let ((state (db:test-get-state t)) Index: utils/installall.sh ================================================================== --- utils/installall.sh +++ utils/installall.sh @@ -12,10 +12,11 @@ # 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 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 @@ -55,21 +56,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 +81,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 - +cd $BUILDHOME # IUP versions if [[ x$USEOLDIUP == "x" ]];then - CDVER=5.7 - IUPVER=3.8 - IMVER=3.8 + CDVER=5.10 + IUPVER=3.17 + IMVER=3.11 else - CDVER=5.7 - IUPVER=3.8 - IMVER=3.8 + 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/Linux26g4_64/* $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")' Index: utils/mk_wrapper ================================================================== --- utils/mk_wrapper +++ utils/mk_wrapper @@ -24,8 +24,29 @@ # if [ "$LD_LIBRARY_PATH" != "" ];then # echo "source $prefix/bin/.\$(lsb_release -sr)/cfg.sh" >> $target # fi # echo "exec $prefix/bin/.\$(lsb_release -sr)/$cmd \"\$@\"" >> $target echo "#!/bin/bash" > $target + +if [[ $cmd =~ dboard ]]; then + cat >> $target <<'EOF' + +# check that $DISPLAY is set +if [[ -z $DISPLAY ]]; then + echo 'ERROR: $DISPLAY environment variable is not set; megatest dashboard requires X display address to be set in $DISPLAY.' + exit 1 +fi + +# check that $DISPLAY is proper +if [[ -x $(which xdpyinfo 2>/dev/null) ]]; then + if ! xdpyinfo -display "$DISPLAY" &>/dev/null; then + echo 'ERROR: megatest dashboard cannot open display "'$DISPLAY'". Please check $DISPLAY environment variable.' + exit 1 + fi +fi +EOF + +fi + echo "lsbr=\$(lsb_release -sr)" >> $target echo "if [[ -e \$lsbr ]];then source \$lsbr;fi" >> $target echo "exec $prefix/bin/.\$lsbr/$cmd \"\$@\"" >> $target Index: vg.scm ================================================================== --- vg.scm +++ vg.scm @@ -367,10 +367,16 @@ (bitwise-ior (arithmetic-shift a 24) (arithmetic-shift r 16) (arithmetic-shift g 8) b)) + +(define (vg:generate-color) + (vg:rgb->number (random 255) + (random 255) + (random 255))) + ;;(vg:rgb->number 0 0 0)) (define (vg:iup-color->number iup-color) (apply vg:rgb->number (map string->number (string-split iup-color)))) ;;======================================================================