Index: api.scm ================================================================== --- api.scm +++ api.scm @@ -144,10 +144,11 @@ ((set-tests-state-status) (apply db:set-tests-state-status dbstruct params)) ((delete-run) (apply db:delete-run dbstruct params)) ((lock/unlock-run) (apply db:lock/unlock-run dbstruct params)) ((update-run-event_time) (apply db:update-run-event_time dbstruct params)) ((update-run-stats) (apply db:update-run-stats dbstruct params)) + ((set-var) (apply db:set-var dbstruct params)) ;; STEPS ((teststep-set-status!) (apply db:teststep-set-status! dbstruct params)) ;; TEST DATA @@ -219,10 +220,11 @@ ((get-prev-run-ids) (apply db:get-prev-run-ids dbstruct params)) ((get-run-ids-matching-target) (apply db:get-run-ids-matching-target dbstruct params)) ((get-runs-by-patt) (apply db:get-runs-by-patt dbstruct params)) ((get-run-name-from-id) (apply db:get-run-name-from-id dbstruct params)) ((get-main-run-stats) (apply db:get-main-run-stats dbstruct params)) + ((get-var) (apply db:get-var dbstruct params)) ;; STEPS ((get-steps-data) (apply db:get-steps-data dbstruct params)) ((get-steps-for-test) (apply db:get-steps-for-test dbstruct params)) Index: common.scm ================================================================== --- common.scm +++ common.scm @@ -43,14 +43,18 @@ (define home (getenv "HOME")) (define user (getenv "USER")) ;; GLOBAL GLETCHES (define *db-keys* #f) -(define *configinfo* #f) -(define *configdat* #f) -(define *toppath* #f) + +(define *configinfo* #f) ;; raw results from setup, includes toppath and table from megatest.config +(define *runconfigdat* #f) ;; run configs data +(define *configdat* #f) ;; megatest.config data +(define *configstatus* #f) ;; status of data; 'fulldata : all processing done, #f : no data yet, 'partialdata : partial read done +(define *toppath* #f) (define *already-seen-runconfig-info* #f) + (define *waiting-queue* (make-hash-table)) (define *test-meta-updated* (make-hash-table)) (define *globalexitstatus* 0) ;; attempt to work around possible thread issues (define *passnum* 0) ;; when running track calls to run-tests or similar (define *write-frequency* (make-hash-table)) ;; run-id => (vector (current-seconds) 0)) @@ -447,36 +451,42 @@ rtestpatt) args-testpatt))) (if rtestpatt (debug:print-info 0 "TESTPATT from runconfigs: " rtestpatt)) testpatt)) +(define (common:get-linktree) + (or (getenv "MT_LINKTREE") + (if *configdat* + (configf:lookup *configdat* "setup" "linktree")))) + (define (common:args-get-runname) - (or (args:get-arg "-runname") - (args:get-arg ":runname") - (getenv "MT_RUNNAME"))) + (let ((res (or (args:get-arg "-runname") + (args:get-arg ":runname") + (getenv "MT_RUNNAME")))) + ;; (if res (set-environment-variable "MT_RUNNAME" res)) ;; not sure if this is a good idea. side effect and all ... + res)) (define (common:args-get-target #!key (split #f)) - (let* ((keys (keys:config-get-fields *configdat*)) + (let* ((keys (if (hash-table? *configdat*) (keys:config-get-fields *configdat*) '())) (numkeys (length keys)) - (target (if (args:get-arg "-reqtarg") - (args:get-arg "-reqtarg") - (if (args:get-arg "-target") - (args:get-arg "-target") - (getenv "MT_TARGET")))) + (target (or (args:get-arg "-reqtarg") + (args:get-arg "-target") + (getenv "MT_TARGET"))) (tlist (if target (string-split target "/" #t) '())) (valid (if target - (and (not (null? tlist)) - (eq? numkeys (length tlist)) - (null? (filter string-null? tlist))) + (or (null? keys) ;; probably don't know our keys yet + (and (not (null? tlist)) + (eq? numkeys (length tlist)) + (null? (filter string-null? tlist)))) #f))) (if valid (if split tlist target) (if target (begin - (debug:print 0 "ERROR: Invalid target, spaces or blanks not allowed \"" target "\", target should be: " (string-intersperse keys "/")) + (debug:print 0 "ERROR: Invalid target, spaces or blanks not allowed \"" target "\", target should be: " (string-intersperse keys "/") ", have " tlist " for elements") #f) #f)))) ;;====================================================================== ;; M I S C L I S T S @@ -657,11 +667,24 @@ ;;====================================================================== (define (common:get-disk-space-used fpath) (with-input-from-pipe (conc "/usr/bin/du -s " fpath) read)) +;; given path get free space, allows override in [setup] +;; with free-space-script /path/to/some/script.sh +;; (define (get-df path) + (if (configf:lookup *configdat* "setup" "free-space-script") + (with-input-from-pipe + (configf:lookup *configdat* "setup" "free-space-script") + (lambda () + (let ((res (read-line))) + (if (string? res) + (string->number res))))) + (get-unix-df path))) + +(define (get-unix-df path) (let* ((df-results (process:cmd-run->list (conc "df " path))) (space-rx (regexp "([0-9]+)\\s+([0-9]+)%")) (freespc #f)) ;; (write df-results) (for-each (lambda (l) @@ -670,10 +693,39 @@ (let ((newval (string->number (cadr match)))) (if (number? newval) (set! freespc newval)))))) (car df-results)) freespc)) + +;; check space in dbdir +;; returns: ok/not dbspace required-space +;; +(define (common:check-db-dir-space) + (let* ((dbdir (db:get-dbdir)) + (dbspace (if (directory? dbdir) + (get-df dbdir) + 0)) + (required (string->number + (or (configf:lookup *configdat* "setup" "dbdir-space-required") + "100000")))) + (list (> dbspace required) + dbspace + required + dbdir))) + +;; check available space in dbdir, exit if insufficient +;; +(define (common:check-db-dir-and-exit-if-insufficient) + (let* ((spacedat (common:check-db-dir-space)) + (is-ok (car spacedat)) + (dbspace (cadr spacedat)) + (required (caddr spacedat)) + (dbdir (cadddr spacedat))) + (if (not is-ok) + (begin + (debug:print 0 "ERROR: Insufficient space in " dbdir ", require " required ", have " dbspace ", exiting now.") + (exit 1))))) ;; paths is list of lists ((name path) ... ) ;; (define (common:get-disk-with-most-free-space disks minsize) (let ((best #f) @@ -709,11 +761,16 @@ ;; E N V I R O N M E N T V A R S ;;====================================================================== (define (save-environment-as-files fname #!key (ignorevars (list "USER" "HOME" "DISPLAY" "LS_COLORS" "XKEYSYMDB" "EDITOR" "MAKEFLAGS" "MAKEF" "MAKEOVERRIDES"))) (let ((envvars (get-environment-variables)) - (whitesp (regexp "[^a-zA-Z0-9_\\-:,.\\/%$]"))) + (whitesp (regexp "[^a-zA-Z0-9_\\-:,.\\/%$]")) + (mungeval (lambda (val) + (cond + ((eq? val #t) "") ;; convert #t to empty string + ((eq? val #f) #f) ;; convert #f to itself (still thinking about this one + (else val))))) (with-output-to-file (conc fname ".csh") (lambda () (for-each (lambda (keyval) (let* ((key (car keyval)) (val (cdr keyval)) @@ -721,11 +778,11 @@ "\"" ""))) (print (if (member key ignorevars) "# setenv " "setenv ") - key " " delim val delim))) + key " " delim (mungeval val) delim))) envvars))) (with-output-to-file (conc fname ".sh") (lambda () (for-each (lambda (keyval) (let* ((key (car keyval)) @@ -734,11 +791,11 @@ "\"" ""))) (print (if (member key ignorevars) "# export " "export ") - key "=" delim val delim))) + key "=" delim (mungeval val) delim))) envvars))))) ;; set some env vars from an alist, return an alist with original values ;; (("VAR" "value") ...) (define (alist->env-vars lst) Index: configf.scm ================================================================== --- configf.scm +++ configf.scm @@ -99,10 +99,12 @@ ;; (print "fullcmd=" fullcmd) (handle-exceptions exn (begin (debug:print 0 "WARNING: failed to process config input \"" l "\"") + (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) + ;; (print "exn=" (condition->list exn)) (set! result (conc "#{( " cmdtype ") " cmd"}"))) (if (or allow-system (not (member cmdtype '("system" "shell")))) (with-input-from-string fullcmd (lambda () @@ -159,11 +161,18 @@ (configf:process-line inl ht allow-processing))))) (if (and (string? res) (not (equal? (hash-table-ref/default settings "trim-trailing-spaces" "no") "no"))) (string-substitute "\\s+$" "" res) res)))))) - + +(define (calc-allow-system allow-system section sections) + (if sections + (and (or (equal? "default" section) + (member section sections)) + allow-system) ;; account for sections and return allow-system as it might be a symbol such as return-strings + allow-system)) + ;; read a config file, returns hash table of alists ;; read a config file, returns hash table of alists ;; adds to ht if given (must be #f otherwise) ;; envion-patt is a regex spec that identifies sections that will be eval'd @@ -182,11 +191,11 @@ (let ((inp (open-input-file path)) (res (if (not ht)(make-hash-table) ht)) (metapath (if (or (debug:debug-mode 9) keep-filenames) path #f))) - (let loop ((inl (configf:read-line inp res allow-system settings)) ;; (read-line inp)) + (let loop ((inl (configf:read-line inp res (calc-allow-system allow-system curr-section sections) settings)) ;; (read-line inp)) (curr-section-name (if curr-section curr-section "default")) (var-flag #f);; turn on for key-var-pr and cont-ln-rx, turn off elsewhere (lead #f)) (debug:print-info 8 "curr-section-name: " curr-section-name " var-flag: " var-flag "\n inl: \"" inl "\"") (if (eof-object? inl) @@ -195,15 +204,15 @@ (hash-table-delete! res "") ;; we are using "" as a dumping ground and must remove it before returning the ht (debug:print 9 "END: " path) res) (regex-case inl - (configf:comment-rx _ (loop (configf:read-line inp res allow-system settings) curr-section-name #f #f)) - (configf:blank-l-rx _ (loop (configf:read-line inp res allow-system settings) curr-section-name #f #f)) + (configf:comment-rx _ (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f)) + (configf:blank-l-rx _ (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f)) (configf:settings ( x setting val ) (begin (hash-table-set! settings setting val) - (loop (configf:read-line inp res allow-system settings) curr-section-name #f #f))) + (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f))) (configf:include-rx ( x include-file ) (let* ((curr-conf-dir (pathname-directory path)) (full-conf (if (absolute-pathname? include-file) include-file (nice-path (conc (if curr-conf-dir @@ -214,31 +223,31 @@ (begin ;; (push-directory conf-dir) (debug:print 9 "Including: " full-conf) (read-config full-conf res allow-system environ-patt: environ-patt curr-section: curr-section-name sections: sections settings: settings keep-filenames: keep-filenames) ;; (pop-directory) - (loop (configf:read-line inp res allow-system settings) curr-section-name #f #f)) + (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f)) (begin (debug:print '(2 9) "INFO: include file " include-file " not found (called from " path ")") (debug:print 2 " " full-conf) - (loop (configf:read-line inp res allow-system settings) curr-section-name #f #f))))) + (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f))))) (configf:section-rx ( x section-name ) (begin ;; call post-section-procs (for-each (lambda (dat) (let ((patt (car dat)) (proc (cdr dat))) (if (string-match patt curr-section-name) (proc curr-section-name section-name res path)))) post-section-procs) - (loop (configf:read-line inp res allow-system settings) + (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) ;; if we have the sections list then force all settings into "" and delete it later? (if (or (not sections) (member section-name sections)) section-name "") ;; stick everything into "" #f #f))) - (configf:key-sys-pr ( x key cmd ) (if allow-system + (configf:key-sys-pr ( x key cmd ) (if (calc-allow-system allow-system curr-section-name sections) (let ((alist (hash-table-ref/default res curr-section-name '())) (val-proc (lambda () (let* ((start-time (current-seconds)) (cmdres (process:cmd-run->list cmd)) (delta (- (current-seconds) start-time)) @@ -256,17 +265,24 @@ "" (string-intersperse res " ")))))) (hash-table-set! res curr-section-name (config:assoc-safe-add alist key - (case allow-system + (case (calc-allow-system allow-system curr-section-name sections) ((return-procs) val-proc) ((return-string) cmd) (else (val-proc))) metadata: metapath)) - (loop (configf:read-line inp res allow-system settings) curr-section-name #f #f)) - (loop (configf:read-line inp res allow-system settings) curr-section-name #f #f))) + (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f)) + (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f))) + (configf:key-no-val ( x key val) (let* ((alist (hash-table-ref/default res curr-section-name '())) + (fval (or (if (string? val) val #f) ""))) ;; fval should be either "" or " " (one or more spaces) + (debug:print 10 " setting: [" curr-section-name "] " key " = #t") + (safe-setenv key fval) + (hash-table-set! res curr-section-name + (config:assoc-safe-add alist key fval metadata: metapath)) + (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name key #f))) (configf:key-val-pr ( x key unk1 val unk2 ) (let* ((alist (hash-table-ref/default res curr-section-name '())) (envar (and environ-patt (string-search (regexp environ-patt) curr-section-name))) (realval (if envar (config:eval-string-in-environment val) val))) @@ -273,16 +289,11 @@ (debug:print-info 6 "read-config env setting, envar: " envar " realval: " realval " val: " val " key: " key " curr-section-name: " curr-section-name) (if envar (safe-setenv key realval)) (debug:print 10 " setting: [" curr-section-name "] " key " = " val) (hash-table-set! res curr-section-name (config:assoc-safe-add alist key realval metadata: metapath)) - (loop (configf:read-line inp res allow-system settings) curr-section-name key #f))) - (configf:key-no-val ( x key val) (let* ((alist (hash-table-ref/default res curr-section-name '()))) - (debug:print 10 " setting: [" curr-section-name "] " key " = #t") - (hash-table-set! res curr-section-name - (config:assoc-safe-add alist key #t metadata: metapath)) - (loop (configf:read-line inp res allow-system settings) curr-section-name key #f))) + (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name key #f))) ;; if a continued line (configf:cont-ln-rx ( x whsp val ) (let ((alist (hash-table-ref/default res curr-section-name '()))) (if var-flag ;; if set to a string then we have a continued var (let ((newval (conc (config-lookup res curr-section-name var-flag) "\n" @@ -292,15 +303,15 @@ "") val))) ;; (print "val: " val "\nnewval: \"" newval "\"\nvarflag: " var-flag) (hash-table-set! res curr-section-name (config:assoc-safe-add alist var-flag newval metadata: metapath)) - (loop (configf:read-line inp res allow-system settings) curr-section-name var-flag (if lead lead whsp))) - (loop (configf:read-line inp res allow-system settings) curr-section-name #f #f)))) + (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name var-flag (if lead lead whsp))) + (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f)))) (else (debug:print 0 "ERROR: problem parsing " path ",\n \"" inl "\"") (set! var-flag #f) - (loop (configf:read-line inp res allow-system settings) curr-section-name #f #f)))))))) + (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f)))))))) ;; pathenvvar will set the named var to the path of the config (define (find-and-read-config fname #!key (environ-patt #f)(given-toppath #f)(pathenvvar #f)) (let* ((curr-dir (current-directory)) (configinfo (find-config fname toppath: given-toppath)) Index: dashboard-tests.scm ================================================================== --- dashboard-tests.scm +++ dashboard-tests.scm @@ -235,11 +235,11 @@ ;; if there is a submegatest create a button to launch dashboard in that area ;; (define (submegatest-panel dbstruct keydat testdat runname testconfig) (let* ((subarea (configf:lookup testconfig "setup" "submegatest")) (area-exists (and subarea (file-exists? subarea)))) - (debug:print-info 0 "Megatest subarea=" subarea ", area-exists=" area-exists) + ;; (debug:print-info 0 "Megatest subarea=" subarea ", area-exists=" area-exists) (if subarea (iup:frame #:title "Megatest Run Info" ; #:expand "YES" (iup:button "Launch Dashboard" Index: dashboard.scm ================================================================== --- dashboard.scm +++ dashboard.scm @@ -14,11 +14,11 @@ (import (prefix iup iup:)) (use canvas-draw) (import canvas-draw-iup) -(use sqlite3 srfi-1 posix regex regex-case srfi-69) +(use sqlite3 srfi-1 posix regex regex-case srfi-69 defstruct sparse-vectors) (import (prefix sqlite3 sqlite3:)) (declare (uses common)) (declare (uses margs)) (declare (uses keys)) @@ -81,72 +81,189 @@ (if (args:get-arg "-h") (begin (print help) (exit))) -(if (not (launch:setup-for-run)) +(if (not (launch:setup)) (begin (print "Failed to find megatest.config, exiting") (exit 1))) -(define *useserver* (cond - ((args:get-arg "-use-local") #f) - ((configf:lookup *configdat* "dashboard" "use-server") - (let ((ans (config:lookup *configdat* "dashboard" "use-server"))) - (if (equal? ans "yes") #t #f))) - (else #t))) - -(define *dbdir* (db:dbfile-path #f)) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/.db")) -(define *dbstruct-local* (make-dbr:dbstruct path: *dbdir* - local: #t)) -(define *db-file-path* (db:dbfile-path 0)) +;; create a stuct for all the miscellaneous state +;; +(defstruct d:alldat + allruns + allruns-by-id + buttondat + curr-tab-num + dbdir + dbfpath + dbkeys + dblocal + header + hide-empty-runs + hide-not-hide ;; toggle for hide/not hide + hide-not-hide-button + hide-not-hide-tabs + item-test-names + keys + last-db-update + num-tests + numruns + please-update + ro + searchpatts + start-run-offset + start-test-offset + state-ignore-hash + status-ignore-hash + tot-runs + update-mutex + updaters + updating + useserver + ) + +(define *alldat* (make-d:alldat + header: #f + allruns: '() + allruns-by-id: (make-hash-table) + buttondat: (make-hash-table) + searchpatts: (make-hash-table) + numruns: 16 + last-db-update: 0 + please-update: #t + updating: #f + update-mutex: (make-mutex) + item-test-names: '() + num-tests: 15 + start-run-offset: 0 + start-test-offset: 0 + status-ignore-hash: (make-hash-table) + state-ignore-hash: (make-hash-table) + hide-empty-runs: #f + hide-not-hide: #t + hide-not-hide-button: #f + hide-not-hide-tabs: #f + curr-tab-num: 0 + updaters: (make-hash-table) + )) + +;; simple two dimentional sparse array +;; +(define (make-sparse-array) + (let ((a (make-sparse-vector))) + (sparse-vector-set! a 0 (make-sparse-vector)) + a)) + +(define (sparse-array? a) + (and (sparse-vector? a) + (sparse-vector? (sparse-vector-ref a 0)))) + +(define (sparse-array-ref a x y) + (let ((row (sparse-vector-ref a x))) + (if row + (sparse-vector-ref row y) + #f))) + +(define (sparse-array-set! a x y val) + (let ((row (sparse-vector-ref a x))) + (if row + (sparse-vector-set! row y val) + (let ((new-row (make-sparse-vector))) + (sparse-vector-set! a x new-row) + (sparse-vector-set! new-row y val))))) + +;; data for runs, tests etc +;; +(defstruct d:rundat + ;; new system + runs-index ;; target/runname => colnum + tests-index ;; testname/itempath => rownum + matrix-dat ;; vector of vectors rows/cols + ) + +(define (d:rundat-make-init) + (make-d:rundat + runs-index: (make-hash-table) + tests-index: (make-hash-table) + matrix-dat: (make-sparse-array))) + +(defstruct d:testdat + id ;; testid + state ;; test state + status ;; test status + ) + +(define (d:rundat-get-col-num dat target runname force-set) + (let* ((runs-index (d:rundat-runs-index dat)) + (col-name (conc target "/" runname)) + (res (hash-table-ref/default runs-index col-name #f))) + (if res + res + (if force-set + (let ((max-col-num (+ 1 (apply max -1 (hash-table-values runs-index))))) + (hash-table-set! runs-index col-name max-col-num) + max-col-num))))) + +(define (d:rundat-get-row-num dat testname itempath force-set) + (let* ((tests-index (d:rundat-runs-index dat)) + (row-name (conc testname "/" itempath)) + (res (hash-table-ref/default runs-index row-name #f))) + (if res + res + (if force-set + (let ((max-row-num (+ 1 (apply max -1 (hash-table-values tests-index))))) + (hash-table-set! runs-index row-name max-row-num) + max-row-num))))) + +;; default is to NOT set the cell if the column and row names are not pre-existing +;; +(define (d:rundat-set-test-cell dat target runname testname itempath test-id state status #!key (force-set #f)) + (let* ((col-num (d:rundat-get-col-num dat target runname force-set)) + (row-num (d:rundat-get-row-num dat testname itempath force-set))) + (if (and row-num col-num) + (let ((tdat (d:testdat + id: test-id + state: state + status: status))) + (sparse-array-set! (d:rundat-matrix-dat dat) col-num row-num tdat) + tdat) + #f))) + + + + + +(d:alldat-useserver-set! *alldat* (cond + ((args:get-arg "-use-local") #f) + ((configf:lookup *configdat* "dashboard" "use-server") + (let ((ans (config:lookup *configdat* "dashboard" "use-server"))) + (if (equal? ans "yes") #t #f))) + (else #t))) + +(d:alldat-dbdir-set! *alldat* (db:dbfile-path #f)) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/.db")) +(d:alldat-dblocal-set! *alldat* (make-dbr:dbstruct path: (d:alldat-dbdir *alldat*) + local: #t)) +(d:alldat-dbfpath-set! *alldat* (db:dbfile-path 0)) ;; HACK ALERT: this is a hack, please fix. -(define *read-only* (not (file-read-access? *db-file-path*))) - -(define toplevel #f) -(define dlg #f) -(define max-test-num 0) -(define *keys* (if *useserver* - (rmt:get-keys) - (db:get-keys *dbstruct-local*))) - -(define *dbkeys* (append *keys* (list "runname"))) - -(define *header* #f) -(define *allruns* '()) -(define *allruns-by-id* (make-hash-table)) ;; -(define *runchangerate* (make-hash-table)) - -(define *buttondat* (make-hash-table)) ;; -(define *alltestnamelst* '()) -(define *searchpatts* (make-hash-table)) -(define *num-runs* 8) -(define *tot-run-count* (if *useserver* - (rmt:get-num-runs "%") - (db:get-num-runs *dbstruct-local* "%"))) - -;; (define *tot-run-count* (db:get-num-runs *dbstruct-local* "%")) - -;; Update management -;; -(define *last-update* (current-seconds)) -(define *last-db-update-time* 0) -(define *please-update-buttons* #t) -(define *delayed-update* 0) -(define *update-is-running* #f) -(define *update-mutex* (make-mutex)) - -(define *all-item-test-names* '()) -(define *num-tests* 15) -(define *start-run-offset* 0) -(define *start-test-offset* 0) -(define *examine-test-dat* (make-hash-table)) +(d:alldat-ro-set! *alldat* (not (file-read-access? (d:alldat-dbfpath *alldat*)))) + +(d:alldat-keys-set! *alldat* (if (d:alldat-useserver *alldat*) + (rmt:get-keys) + (db:get-keys (d:alldat-dblocal *alldat*)))) +(d:alldat-dbkeys-set! *alldat* (append (d:alldat-keys *alldat*) (list "runname"))) +(d:alldat-tot-runs-set! *alldat* (if (d:alldat-useserver *alldat*) + (rmt:get-num-runs "%") + (db:get-num-runs (d:alldat-dblocal *alldat*) "%"))) +;; (define *exit-started* #f) -(define *status-ignore-hash* (make-hash-table)) -(define *state-ignore-hash* (make-hash-table)) +;; *updaters* (make-hash-table)) +;; sorting global data (would apply to many testsuites so leave it global for now) +;; (define *tests-sort-options* (vector (vector "Sort +a" 'testname "ASC") (vector "Sort -a" 'testname "DESC") (vector "Sort +t" 'event_time "ASC") (vector "Sort -t" 'event_time "DESC") (vector "Sort +s" 'statestatus "ASC") @@ -174,18 +291,10 @@ 3))) (define (get-curr-sort) (vector-ref *tests-sort-options* *tests-sort-reverse*)) -(define *hide-empty-runs* #f) -(define *hide-not-hide* #t) ;; toggle for hide/not hide -(define *hide-not-hide-button* #f) -(define *hide-not-hide-tabs* #f) - -(define *current-tab-number* 0) -(define *updaters* (make-hash-table)) - (debug:setup) (define uidat #f) (define-inline (dboard:uidat-get-keycol vec)(vector-ref vec 0)) @@ -243,20 +352,20 @@ ;; create a virtual table of all the tests ;; keypatts: ( (KEY1 "abc%def")(KEY2 "%") ) (define (update-rundat runnamepatt numruns testnamepatt keypatts) (let* ((referenced-run-ids '()) - (allruns (if *useserver* - (rmt:get-runs runnamepatt numruns *start-run-offset* keypatts) - (db:get-runs *dbstruct-local* runnamepatt numruns ;; (+ numruns 1) ;; (/ numruns 2)) - *start-run-offset* keypatts))) + (allruns (if (d:alldat-useserver *alldat*) + (rmt:get-runs runnamepatt numruns (d:alldat-start-run-offset *alldat*) keypatts) + (db:get-runs (d:alldat-dblocal *alldat*) runnamepatt numruns ;; (+ numruns 1) ;; (/ numruns 2)) + (d:alldat-start-run-offset *alldat*) keypatts))) (header (db:get-header allruns)) (runs (db:get-rows allruns)) (result '()) (maxtests 0) - (states (hash-table-keys *state-ignore-hash*)) - (statuses (hash-table-keys *status-ignore-hash*)) + (states (hash-table-keys (d:alldat-state-ignore-hash *alldat*))) + (statuses (hash-table-keys (d:alldat-status-ignore-hash *alldat*))) (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 @@ -264,28 +373,28 @@ ;; ;; trim runs to only those that are changing often here ;; (for-each (lambda (run) (let* ((run-id (db:get-value-by-header run header "id")) - (key-vals (if *useserver* + (key-vals (if (d:alldat-useserver *alldat*) (rmt:get-key-vals run-id) - (db:get-key-vals *dbstruct-local* run-id))) - (prev-dat (let ((rec (hash-table-ref/default *allruns-by-id* run-id #f))) + (db:get-key-vals (d:alldat-dblocal *alldat*) run-id))) + (prev-dat (let ((rec (hash-table-ref/default (d:alldat-allruns-by-id *alldat*) run-id #f))) (if rec rec (vector run '() key-vals -100)))) ;; -100 is before time began (prev-tests (vector-ref prev-dat 1)) (last-update (vector-ref prev-dat 3)) - (tmptests (if *useserver* + (tmptests (if (d:alldat-useserver *alldat*) (rmt:get-tests-for-run run-id testnamepatt states statuses #f #f - *hide-not-hide* + (d:alldat-hide-not-hide *alldat*) sort-by sort-order 'shortlist last-update) - (db:get-tests-for-run *dbstruct-local* run-id testnamepatt states statuses + (db:get-tests-for-run (d:alldat-dblocal *alldat*) run-id testnamepatt states statuses #f #f - *hide-not-hide* + (d:alldat-hide-not-hide *alldat*) sort-by sort-order 'shortlist last-update))) (tests (let ((newdat (filter @@ -295,32 +404,28 @@ (lambda (a b) (eq? (db:test-get-id a)(db:test-get-id b))))))) (if (eq? *tests-sort-reverse* 3) ;; +event_time (sort newdat compare-tests) newdat)))) - ;; NOTE: bubble-up also sets the global *all-item-test-names* + ;; NOTE: bubble-up also sets the global (d:alldat-item-test-names *alldat*) ;; (tests (bubble-up tmptests priority: bubble-type)) ;; NOTE: 11/01/2013 This routine is *NOT* getting called excessively. ;; (debug:print 0 "Getting data for run " run-id " with key-vals=" key-vals) ;; Not sure this is needed? (set! referenced-run-ids (cons run-id referenced-run-ids)) (if (> (length tests) maxtests) (set! maxtests (length tests))) - (if (or (not *hide-empty-runs*) ;; this reduces the data burden when set + (if (or (not (d:alldat-hide-empty-runs *alldat*)) ;; this reduces the data burden when set (not (null? tests))) (let ((dstruct (vector run tests key-vals (- (current-seconds) 10)))) - ;; - ;; compare the tests with the tests in *allruns-by-id* same run-id - ;; if different then increment value in *runchangerate* - ;; - (hash-table-set! *allruns-by-id* run-id dstruct) + (hash-table-set! (d:alldat-allruns-by-id *alldat*) run-id dstruct) (set! result (cons dstruct result)))))) runs) - (set! *header* header) - (set! *allruns* result) - (debug:print-info 6 "*allruns* has " (length *allruns*) " runs") + (d:alldat-header-set! *alldat* header) + (d:alldat-allruns-set! *alldat* result) + (debug:print-info 6 "(d:alldat-allruns *alldat*) has " (length (d:alldat-allruns *alldat*)) " runs") maxtests)) (define *collapsed* (make-hash-table)) ; (define *row-lookup* (make-hash-table)) ;; testname => (rownum lableobj) @@ -444,30 +549,30 @@ (hash-table-set! tests tname (cons testdat (hash-table-ref/default tests tname '()))) ;; This is item, append it (hash-table-set! tests tname (append (hash-table-ref/default tests tname '())(list testdat)))))) test-dats) ;; Set all tests with items - (set! *all-item-test-names* (append (if (null? tnames) - '() - (filter (lambda (tname) - (let ((tlst (hash-table-ref tests tname))) - (and (list tlst) - (> (length tlst) 1)))) - tnames)) - *all-item-test-names*)) + (d:alldat-item-test-names-set! *alldat* (append (if (null? tnames) + '() + (filter (lambda (tname) + (let ((tlst (hash-table-ref tests tname))) + (and (list tlst) + (> (length tlst) 1)))) + tnames)) + (d:alldat-item-test-names *alldat*))) (let loop ((hed (car tnames)) (tal (cdr tnames)) (res '())) (let ((newres (append res (hash-table-ref tests hed)))) (if (null? tal) newres (loop (car tal)(cdr tal) newres)))))))) (define (update-buttons uidat numruns numtests) - (let* ((runs (if (> (length *allruns*) numruns) - (take-right *allruns* numruns) - (pad-list *allruns* numruns))) + (let* ((runs (if (> (length (d:alldat-allruns *alldat*)) numruns) + (take-right (d:alldat-allruns *alldat*) numruns) + (pad-list (d:alldat-allruns *alldat*) numruns))) (lftcol (dboard:uidat-get-lftcol uidat)) (tableheader (dboard:uidat-get-header uidat)) (table (dboard:uidat-get-runsvec uidat)) (coln 0)) (set! *alltestnamelst* '()) @@ -475,36 +580,36 @@ (for-each (lambda (rundat) (if (vector? rundat) (let* ((testdat (vector-ref rundat 1)) (testnames (map test:test-get-fullname testdat))) - (if (not (and *hide-empty-runs* + (if (not (and (d:alldat-hide-empty-runs *alldat*) (null? testnames))) (for-each (lambda (testname) (if (not (member testname *alltestnamelst*)) (begin (set! *alltestnamelst* (append *alltestnamelst* (list testname)))))) testnames))))) runs) (set! *alltestnamelst* (collapse-rows *alltestnamelst*)) ;;; argh. please clean up this sillyness - (set! *alltestnamelst* (let ((xl (if (> (length *alltestnamelst*) *start-test-offset*) - (drop *alltestnamelst* *start-test-offset*) + (set! *alltestnamelst* (let ((xl (if (> (length *alltestnamelst*) (d:alldat-start-test-offset *alldat*)) + (drop *alltestnamelst* (d:alldat-start-test-offset *alldat*)) '()))) - (append xl (make-list (- *num-tests* (length xl)) "")))) + (append xl (make-list (- (d:alldat-num-tests *alldat*) (length xl)) "")))) (update-labels uidat) (for-each (lambda (rundat) (if (not rundat) ;; handle padded runs ;; ;; id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration - (set! rundat (vector (make-vector 20 #f) '() (map (lambda (x) "") *keys*))));; 3))) + (set! rundat (vector (make-vector 20 #f) '() (map (lambda (x) "") (d:alldat-keys *alldat*)))));; 3))) (let* ((run (vector-ref rundat 0)) (testsdat (vector-ref rundat 1)) (key-val-dat (vector-ref rundat 2)) - (run-id (db:get-value-by-header run *header* "id")) + (run-id (db:get-value-by-header run (d:alldat-header *alldat*) "id")) (key-vals (append key-val-dat - (list (let ((x (db:get-value-by-header run *header* "runname"))) + (list (let ((x (db:get-value-by-header run (d:alldat-header *alldat*) "runname"))) (if x x ""))))) (run-key (string-intersperse key-vals "\n"))) ;; fill in the run header key values (let ((rown 0) @@ -519,11 +624,11 @@ ;; For this run now fill in the buttons for each test (let ((rown 0) (columndat (vector-ref table coln))) (for-each (lambda (testname) - (let ((buttondat (hash-table-ref/default *buttondat* (mkstr coln rown) #f))) + (let ((buttondat (hash-table-ref/default (d:alldat-buttondat *alldat*) (mkstr coln rown) #f))) (if buttondat (let* ((test (let ((matching (filter (lambda (x)(equal? (test:test-get-fullname x) testname)) testsdat))) (if (null? matching) @@ -564,29 +669,28 @@ (define (mkstr . x) (string-intersperse (map conc x) ",")) (define (set-bg-on-filter) (let ((search-changed (not (null? (filter (lambda (key) - (not (equal? (hash-table-ref *searchpatts* key) "%"))) - (hash-table-keys *searchpatts*))))) - (state-changed (not (null? (hash-table-keys *state-ignore-hash*)))) - (status-changed (not (null? (hash-table-keys *status-ignore-hash*))))) - (iup:attribute-set! *hide-not-hide-tabs* "BGCOLOR" + (not (equal? (hash-table-ref (d:alldat-searchpatts *alldat*) key) "%"))) + (hash-table-keys (d:alldat-searchpatts *alldat*)))))) + (state-changed (not (null? (hash-table-keys (d:alldat-state-ignore-hash *alldat*))))) + (status-changed (not (null? (hash-table-keys (d:alldat-status-ignore-hash *alldat*)))))) + (iup:attribute-set! (d:alldat-hide-not-hide-tabs *alldat*) "BGCOLOR" (if (or search-changed state-changed status-changed) "190 180 190" "190 190 190" )))) (define (update-search x val) - (hash-table-set! *searchpatts* x val) + (hash-table-set! (d:alldat-searchpatts *alldat*) x val) (set-bg-on-filter)) (define (mark-for-update) - (set! *last-db-update-time* 0) - (set! *delayed-update* 1)) + (d:alldat-last-db-update-set! *alldat* 0)) ;;====================================================================== ;; R U N C O N T R O L ;;====================================================================== @@ -632,13 +736,13 @@ (iup:attribute-set! lb "VALUE" newval) newval)))))) (define (dashboard:update-target-selector key-lbs #!key (action-proc #f)) (let* ((runconf-targs (common:get-runconfig-targets)) - (db-target-dat (if *useserver* + (db-target-dat (if (d:alldat-useserver *alldat*) (rmt:get-targets) - (db:get-targets *dbstruct-local*))) + (db:get-targets (d:alldat-dblocal *alldat*)))) (header (vector-ref db-target-dat 0)) (db-targets (vector-ref db-target-dat 1)) (all-targets (append db-targets (map (lambda (x) (list->vector @@ -757,16 +861,13 @@ ;; (canvas-origin-set! cnv 0 (- (/ sizey 2))) (if (hash-table-ref/default tests-draw-state 'first-time #t) (begin (hash-table-set! tests-draw-state 'first-time #f) (hash-table-set! tests-draw-state 'scalef 1) - (hash-table-set! tests-draw-state 'dotscale 60) (hash-table-set! tests-draw-state 'tests-info (make-hash-table)) (hash-table-set! tests-draw-state 'selected-tests (make-hash-table)) ;; set these - (hash-table-set! tests-draw-state 'test-browse-xoffset 20) ;; (- 0 (* (/ sizex 2) (* 8 xadj)))) - (hash-table-set! tests-draw-state 'test-browse-yoffset 20) ;; (- 0 (* (/ sizey 2) (* 8 (- 1 yadj))))))) (dcommon:initial-draw-tests cnv xadj yadj sizex sizey sizexmm sizeymm originx originy tests-draw-state sorted-testnames test-records)) (dcommon:redraw-tests cnv xadj yadj sizex sizey sizexmm sizeymm originx originy tests-draw-state sorted-testnames test-records)) )) ;;====================================================================== @@ -795,15 +896,14 @@ (dashboard:update-run-command)))) (tests-draw-state (make-hash-table)) ;; use for keeping state of the test canvas (test-patterns-textbox #f)) (hash-table-set! tests-draw-state 'first-time #t) ;; (hash-table-set! tests-draw-state 'scalef 1) - ;; (hash-table-set! tests-draw-state 'dotscale 60) (tests:get-full-data test-names test-records '() all-tests-registry) (set! sorted-testnames (tests:sort-by-priority-and-waiton test-records)) - ;; refer to *keys*, *dbkeys* for keys + ;; refer to (d:alldat-keys *alldat*), (d:alldat-dbkeys *alldat*) for keys (iup:vbox ;; The command line display/exectution control (iup:frame #:title "Command to be exectuted" (iup:hbox @@ -868,13 +968,13 @@ (iup:attribute-set! tb "VALUE" val) (dboard:data-set-run-name! *data* val) (dashboard:update-run-command)))) (refresh-runs-list (lambda () (let* ((target (dboard:data-get-target-string *data*)) - (runs-for-targ (if *useserver* - (rmt:get-runs-by-patt *keys* "%" target #f #f #f) - (db:get-runs-by-patt *dbstruct-local* *keys* "%" target #f #f #f))) + (runs-for-targ (if (d:alldat-useserver *alldat*) + (rmt:get-runs-by-patt (d:alldat-keys *alldat*) "%" target #f #f #f) + (db:get-runs-by-patt (d:alldat-dblocal *alldat*) (d:alldat-keys *alldat*) "%" target #f #f #f))) (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")) @@ -953,70 +1053,64 @@ (set! the-cnv cnv) )) ;; Following doesn't work #:wheel-cb (lambda (obj step x y dir) ;; dir is 4 for up and 5 for down. I think. (let ((scalef (hash-table-ref tests-draw-state 'scalef))) - ;; (debug:print 0 "step=" step ", dir=" dir ", scalef=" scalef ", x=" x ", y=" y) - ;; (let (;; (xadj last-xadj) - ;; (yadj (+ last-yadj (if (> step 0) - ;; -0.01 - ;; 0.01)))) (hash-table-set! tests-draw-state 'scalef (+ scalef (if (> step 0) - 0.01 - -0.01))) - - ;; (print "step: " step " x: " x " y: " y " dir: \"" dir "\"") - ;; (print "the-cnv: " the-cnv " obj: " obj " xadj: " xadj " yadj: " yadj " dir: " dir) + (* scalef 0.01) + (* scalef -0.01)))) (if the-cnv (dashboard:draw-tests the-cnv last-xadj last-yadj tests-draw-state sorted-testnames test-records)) - ;; (set! last-xadj xadj) - ;; (set! last-yadj yadj) )) ;; #:size "50x50" #:expand "YES" #:scrollbar "YES" #:posx "0.5" #:posy "0.5" #:button-cb (lambda (obj btn pressed x y status) - (print "obj: " obj ", pressed " pressed ", status " status) - (print "canvas-origin: " (canvas-origin the-cnv)) - (let-values (((xx yy)(canvas-origin the-cnv))) - (canvas-transform-set! the-cnv #f) - (print "canvas-origin: " xx " " yy " click at " x " " y)) - (let ((tests-info (hash-table-ref tests-draw-state 'tests-info)) - (selected-tests (hash-table-ref tests-draw-state 'selected-tests))) + ;; (print "obj: " obj ", pressed " pressed ", status " status) + ; (print "canvas-origin: " (canvas-origin the-cnv)) + ;; (let-values (((xx yy)(canvas-origin the-cnv))) + ;; (canvas-transform-set! the-cnv #f) + ;; (print "canvas-origin: " xx " " yy " click at " x " " y)) + (let* ((tests-info (hash-table-ref tests-draw-state 'tests-info)) + (selected-tests (hash-table-ref tests-draw-state 'selected-tests)) + (scalef (hash-table-ref tests-draw-state 'scalef)) + (sizey (hash-table-ref tests-draw-state 'sizey)) + (xoffset (dcommon:get-xoffset tests-draw-state #f #f)) + (yoffset (dcommon:get-yoffset tests-draw-state #f #f)) + (new-y (- sizey y))) + ;; (print "xoffset=" xoffset ", yoffset=" yoffset) ;; (print "\tx\ty\tllx\tlly\turx\tury") (for-each (lambda (test-name) (let* ((rec-coords (hash-table-ref tests-info test-name)) - (llx (list-ref rec-coords 0)) - (urx (list-ref rec-coords 1)) - (lly (list-ref rec-coords 2)) - (ury (list-ref rec-coords 3))) - ;; (print "\t" x "\t" y "\t" llx "\t" lly "\t" urx "\t" ury "\t" test-name " ") + (llx (dcommon:x->canvas (list-ref rec-coords 0) scalef xoffset)) + (lly (dcommon:y->canvas (list-ref rec-coords 1) scalef yoffset)) + (urx (dcommon:x->canvas (list-ref rec-coords 2) scalef xoffset)) + (ury (dcommon:y->canvas (list-ref rec-coords 3) scalef yoffset))) + ;; (if (eq? pressed 1) + ;; (print "\tx=" x "\ty=" y "\tnew-y=" new-y "\tllx=" llx "\tlly=" lly "\turx=" urx "\tury=" ury "\t" test-name " ")) (if (and (eq? pressed 1) - (> x llx) - (> y lly) - (< x urx) - (< y ury)) + (>= x llx) + (>= new-y lly) + (<= x urx) + (<= new-y ury)) (let ((patterns (string-split (iup:attribute test-patterns-textbox "VALUE")))) (let* ((selected (not (member test-name patterns))) (newpatt-list (if selected (cons test-name patterns) (delete test-name patterns))) (newpatt (string-intersperse newpatt-list "\n"))) - ;; (if cnv-obj - ;; (dashboard:draw-tests cnv-obj 0 0 tests-draw-state sorted-testnames)) (iup:attribute-set! obj "REDRAW" "ALL") (hash-table-set! selected-tests test-name selected) (iup:attribute-set! test-patterns-textbox "VALUE" newpatt) (dboard:data-set-test-patts! *data* (dboard:lines->test-patt newpatt)) (dashboard:update-run-command) (if updater (updater last-xadj last-yadj))))))) (hash-table-keys tests-info))))))) canvas-obj))) - ;; (print "obj: " obj " btn: " btn " pressed: " pressed " x: " x " y: " y " status: " status)) (iup:frame #:title "Logs" ;; To be replaced with tabs (let ((logs-tb (iup:textbox #:expand "YES" #:multiline "YES"))) @@ -1089,32 +1183,207 @@ ;; R U N ;;====================================================================== ;; ;; display and manage a single run at a time -(define (tree-path->run-id path) +(define (tree-path->run-id data path) (if (not (null? path)) - (hash-table-ref/default (dboard:data-get-path-run-ids *data*) path #f) + (hash-table-ref/default (d:data-path-run-ids data) path #f) #f)) (define dashboard:update-run-summary-tab #f) -;; (define (tests window-id) -(define (dashboard:one-run db) +;; This is the Run Summary tab +;; +(define (dashboard:one-run db data) + (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 data (cdr run-path)))) + (if (number? run-id) + (begin + (d:data-curr-run-id-set! data run-id) + (dashboard:update-run-summary-tab)) + (debug:print 0 "ERROR: 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 " (d:data-curr-run-id data) "," test-id "&"))) + (system cmd))))) + (updater (lambda () + (let* ((runs-dat (if (d:alldat-useserver *alldat*) + (rmt:get-runs-by-patt (d:alldat-keys *alldat*) "%" #f #f #f #f) + (db:get-runs-by-patt db (d:alldat-keys *alldat*) "%" #f #f #f #f))) + (runs-header (vector-ref runs-dat 0)) ;; 0 is header, 1 is list of records + (run-id (d:data-curr-run-id data)) + (last-update 0) ;; fix me + (tests-dat (let ((tdat (if run-id + (if (d:alldat-useserver *alldat*) + (rmt:get-tests-for-run run-id + (hash-table-ref/default (d:alldat-searchpatts *alldat*) "test-name" "%/%") + (hash-table-keys (d:alldat-state-ignore-hash *alldat*)) ;; '() + (hash-table-keys (d:alldat-status-ignore-hash *alldat*)) ;; '() + #f #f + (d:alldat-hide-not-hide *alldat*) + #f #f + "id,testname,item_path,state,status" + last-update) ;; get 'em all + (db:get-tests-for-run db run-id + (hash-table-ref/default (d:alldat-searchpatts *alldat*) "test-name" "%/%") + (hash-table-keys (d:alldat-state-ignore-hash *alldat*)) ;; '() + (hash-table-keys (d:alldat-status-ignore-hash *alldat*)) ;; '() + #f #f + (d:alldat-hide-not-hide *alldat*) + #f #f + "id,testname,item_path,state,status" + last-update)) + '()))) ;; get 'em all + (sort tdat (lambda (a b) + (let* ((aval (vector-ref a 2)) + (bval (vector-ref b 2)) + (anum (string->number aval)) + (bnum (string->number bval))) + (if (and anum bnum) + (< anum bnum) + (string<= aval bval))))))) + (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 (- (d:alldat-num-tests *alldat*) 15) 3)) ;; (d:alldat-num-tests *alldat*) 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)) + (d:alldat-keys *alldat*))) + (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 (d:data-path-run-ids data) run-path #f)) + (begin + (hash-table-set! (d:data-run-keys data) run-id run-path) + ;; (iup:attribute-set! (dboard:data-get-runs-matrix *data*) + ;; (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! (d:data-path-run-ids data) 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")))))) + + (set! dashboard:update-run-summary-tab updater) + (d:data-runs-tree-set! data tb) + (iup:split + tb + run-matrix))) + +;; This is the New View tab +;; +(define (dashboard:new-view db data) (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 (cdr run-path)))) + (run-id (tree-path->run-id data (cdr run-path)))) (if (number? run-id) (begin - (dboard:data-set-curr-run-id! *data* run-id) + (d:data-curr-run-id-set! data run-id) (dashboard:update-run-summary-tab)) (debug:print 0 "ERROR: 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)) @@ -1123,36 +1392,39 @@ #: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:data-get-curr-run-id *data*) "," test-id "&"))) + (cmd (conc toolpath " -test " (d:data-curr-run-id data) "," test-id "&"))) (system cmd))))) (updater (lambda () - (let* ((runs-dat (if *useserver* - (rmt:get-runs-by-patt *keys* "%" #f #f #f #f) - (db:get-runs-by-patt db *keys* "%" #f #f #f #f))) - (runs-header (vector-ref runs-dat 0)) ;; 0 is header, 1 is list of records - (run-id (dboard:data-get-curr-run-id *data*)) - (tests-dat (let ((tdat (if run-id - (if *useserver* - (rmt:get-tests-for-run run-id - (hash-table-ref/default *searchpatts* "test-name" "%/%") - (hash-table-keys *state-ignore-hash*) ;; '() - (hash-table-keys *status-ignore-hash*) ;; '() - #f #f - *hide-not-hide* - #f #f - "id,testname,item_path,state,status") ;; get 'em all - (db:get-tests-for-run db run-id - (hash-table-ref/default *searchpatts* "test-name" "%/%") - (hash-table-keys *state-ignore-hash*) ;; '() - (hash-table-keys *status-ignore-hash*) ;; '() - #f #f - *hide-not-hide* - #f #f - "id,testname,item_path,state,status")) + (let* ((runs-dat (if (d:alldat-useserver *alldat*) + (rmt:get-runs-by-patt (d:alldat-keys *alldat*) "%" #f #f #f #f) + (db:get-runs-by-patt db (d:alldat-keys *alldat*) "%" #f #f #f #f))) + (runs-header (vector-ref runs-dat 0)) ;; 0 is header, 1 is list of records + (run-id (d:data-curr-run-id data)) + (last-update 0) ;; fix me + (tests-dat (let ((tdat (if run-id + (if (d:alldat-useserver *alldat*) + (rmt:get-tests-for-run run-id + (hash-table-ref/default (d:alldat-searchpatts *alldat*) "test-name" "%/%") + (hash-table-keys (d:alldat-state-ignore-hash *alldat*)) ;; '() + (hash-table-keys (d:alldat-status-ignore-hash *alldat*)) ;; '() + #f #f + (d:alldat-hide-not-hide *alldat*) + #f #f + "id,testname,item_path,state,status" + last-update) ;; get 'em all + (db:get-tests-for-run db run-id + (hash-table-ref/default (d:alldat-searchpatts *alldat*) "test-name" "%/%") + (hash-table-keys (d:alldat-state-ignore-hash *alldat*)) ;; '() + (hash-table-keys (d:alldat-status-ignore-hash *alldat*)) ;; '() + #f #f + (d:alldat-hide-not-hide *alldat*) + #f #f + "id,testname,item_path,state,status" + last-update)) '()))) ;; get 'em all (sort tdat (lambda (a b) (let* ((aval (vector-ref a 2)) (bval (vector-ref b 2)) (anum (string->number aval)) @@ -1164,11 +1436,11 @@ (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 (- *num-tests* 15) 3)) ;; *num-tests* is proportional to the size of the window + (max-visible (max (- (d:alldat-num-tests *alldat*) 15) 3)) ;; (d:alldat-num-tests *alldat*) 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) @@ -1187,25 +1459,25 @@ ;; (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)) - *keys*)) + (d:alldat-keys *alldat*))) (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:data-get-path-run-ids *data*) run-path #f)) + (if (not (hash-table-ref/default (d:data-path-run-ids data) run-path #f)) (begin - (hash-table-set! (dboard:data-get-run-keys *data*) run-id run-path) + (hash-table-set! (d:data-run-keys data) run-id run-path) ;; (iup:attribute-set! (dboard:data-get-runs-matrix *data*) ;; (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:data-get-path-run-ids *data*) run-path run-id) + (hash-table-set! (d:data-path-run-ids data) 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") @@ -1261,20 +1533,20 @@ (iup:attribute-set! run-matrix "FITTOTEXT" (conc "C" num)))))) col-indices) (if changed (iup:attribute-set! run-matrix "REDRAW" "ALL")))))) (set! dashboard:update-run-summary-tab updater) - (dboard:data-set-runs-tree! *data* tb) + (d:data-runs-tree-set! data tb) (iup:split tb run-matrix))) ;;====================================================================== ;; R U N S ;;====================================================================== -(define (make-dashboard-buttons db nruns ntests keynames) +(define (make-dashboard-buttons db nruns ntests keynames runs-sum-dat new-view-dat) (let* ((nkeys (length keynames)) (runsvec (make-vector nruns)) (header (make-vector nruns)) (lftcol (make-vector ntests)) (keycol (make-vector ntests)) @@ -1316,32 +1588,32 @@ ;; (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))) (iup:button "HideEmpty" #:action (lambda (obj) - (set! *hide-empty-runs* (not *hide-empty-runs*)) - (iup:attribute-set! obj "TITLE" (if *hide-empty-runs* "+HideE" "-HideE")) + (d:alldat-hide-empty-runs-set! *alldat* (not (d:alldat-hide-empty-runs *alldat*))) + (iup:attribute-set! obj "TITLE" (if (d:alldat-hide-empty-runs *alldat*) "+HideE" "-HideE")) (mark-for-update))) (let ((hideit (iup:button "HideTests" #:action (lambda (obj) - (set! *hide-not-hide* (not *hide-not-hide*)) - (iup:attribute-set! obj "TITLE" (if *hide-not-hide* "HideTests" "NotHide")) + (d:alldat-hide-not-hide-set! *alldat* (not (d:alldat-hide-not-hide *alldat*))) + (iup:attribute-set! obj "TITLE" (if (d:alldat-hide-not-hide *alldat*) "HideTests" "NotHide")) (mark-for-update))))) - (set! *hide-not-hide-button* hideit) + (d:alldat-hide-not-hide-button-set! *alldat* hideit) ;; never used, can eliminate ... hideit)) (iup:hbox (iup:button "Quit" #:action (lambda (obj) - ;; (if *dbstruct-local* (db:close-all *dbstruct-local*)) + ;; (if (d:alldat-dblocal *alldat*) (db:close-all (d:alldat-dblocal *alldat*))) (exit))) (iup:button "Refresh" #:action (lambda (obj) (mark-for-update))) (iup:button "Collapse" #:action (lambda (obj) (let ((myname (iup:attribute obj "TITLE"))) (if (equal? myname "Collapse") (begin (for-each (lambda (tname) (hash-table-set! *collapsed* tname #t)) - *all-item-test-names*) + (d:alldat-item-test-names *alldat*)) (iup:attribute-set! obj "TITLE" "Expand")) (begin (for-each (lambda (tname) (hash-table-delete! *collapsed* tname)) (hash-table-keys *collapsed*)) @@ -1354,38 +1626,38 @@ iup:hbox (map (lambda (status) (iup:toggle status #:action (lambda (obj val) (mark-for-update) (if (eq? val 1) - (hash-table-set! *status-ignore-hash* status #t) - (hash-table-delete! *status-ignore-hash* status)) + (hash-table-set! (d:alldat-status-ignore-hash *alldat*) status #t) + (hash-table-delete! (d:alldat-status-ignore-hash *alldat*) status)) (set-bg-on-filter)))) (map cadr *common:std-statuses*))) ;; '("PASS" "FAIL" "WARN" "CHECK" "WAIVED" "STUCK/DEAD" "n/a" "SKIP"))) (apply iup:hbox (map (lambda (state) (iup:toggle state #:action (lambda (obj val) (mark-for-update) (if (eq? val 1) - (hash-table-set! *state-ignore-hash* state #t) - (hash-table-delete! *state-ignore-hash* state)) + (hash-table-set! (d:alldat-state-ignore-hash *alldat*) state #t) + (hash-table-delete! (d:alldat-state-ignore-hash *alldat*) state)) (set-bg-on-filter)))) (map cadr *common:std-states*))) ;; '("RUNNING" "COMPLETED" "INCOMPLETE" "LAUNCHED" "NOT_STARTED" "KILLED" "DELETED"))) (iup:valuator #:valuechanged_cb (lambda (obj) (let ((val (inexact->exact (round (/ (string->number (iup:attribute obj "VALUE")) 10)))) (oldmax (string->number (iup:attribute obj "MAX"))) - (maxruns *tot-run-count*)) - (set! *start-run-offset* val) + (maxruns (d:alldat-tot-runs *alldat*))) + (d:alldat-start-run-offset-set! *alldat* val) (mark-for-update) - (debug:print 6 "*start-run-offset* " *start-run-offset* " maxruns: " maxruns ", val: " val " oldmax: " oldmax) + (debug:print 6 "(d:alldat-start-run-offset *alldat*) " (d:alldat-start-run-offset *alldat*) " maxruns: " maxruns ", val: " val " oldmax: " oldmax) (iup:attribute-set! obj "MAX" (* maxruns 10)))) #:expand "HORIZONTAL" - #:max (* 10 (length *allruns*)) + #:max (* 10 (length (d:alldat-allruns *alldat*))) #:min 0 #:step 0.01))) - ;(iup:button "inc rows" #:action (lambda (obj)(set! *num-tests* (+ *num-tests* 1)))) - ;(iup:button "dec rows" #:action (lambda (obj)(set! *num-tests* (if (> *num-tests* 0)(- *num-tests* 1) 0)))) + ;(iup:button "inc rows" #:action (lambda (obj)(d:alldat-num-tests-set! *alldat* (+ (d:alldat-num-tests *alldat*) 1)))) + ;(iup:button "dec rows" #:action (lambda (obj)(d:alldat-num-tests-set! *alldat* (if (> (d:alldat-num-tests *alldat*) 0)(- (d:alldat-num-tests *alldat*) 1) 0)))) ) ) ;; create the left most column for the run key names and the test names (set! lftlst (list (iup:hbox @@ -1409,13 +1681,13 @@ (set! lftlst (append lftlst (list (iup:hbox #:expand "HORIZONTAL" (iup:valuator #:valuechanged_cb (lambda (obj) (let ((val (string->number (iup:attribute obj "VALUE"))) (oldmax (string->number (iup:attribute obj "MAX"))) (newmax (* 10 (length *alltestnamelst*)))) - (set! *please-update-buttons* #t) - (set! *start-test-offset* (inexact->exact (round (/ val 10)))) - (debug:print 6 "*start-test-offset* " *start-test-offset* " val: " val " newmax: " newmax " oldmax: " oldmax) + (d:alldat-please-update-set! *alldat* #t) + (d:alldat-start-test-offset-set! *alldat* (inexact->exact (round (/ val 10)))) + (debug:print 6 "(d:alldat-start-test-offset *alldat*) " (d:alldat-start-test-offset *alldat*) " val: " val " newmax: " newmax " oldmax: " oldmax) (if (< val 10) (iup:attribute-set! obj "MAX" newmax)) )) #:expand "VERTICAL" #:orientation "VERTICAL" @@ -1468,17 +1740,17 @@ #:size "60x15" #:expand "HORIZONTAL" #:fontsize "10" #:action (lambda (x) (let* ((toolpath (car (argv))) - (buttndat (hash-table-ref *buttondat* button-key)) + (buttndat (hash-table-ref (d:alldat-buttondat *alldat*) button-key)) (test-id (db:test-get-id (vector-ref buttndat 3))) (run-id (db:test-get-run_id (vector-ref buttndat 3))) (cmd (conc toolpath " -test " run-id "," test-id "&"))) ;(print "Launching " cmd) (system cmd)))))) - (hash-table-set! *buttondat* button-key (vector 0 "100 100 100" button-key #f #f)) + (hash-table-set! (d:alldat-buttondat *alldat*) button-key (vector 0 "100 100 100" button-key #f #f)) (vector-set! testvec testnum butn) (loop runnum (+ testnum 1) testvec (cons butn res)))))) ;; now assemble the hdrlst and bdylst and kick off the dialog (iup:show (iup:dialog @@ -1491,60 +1763,64 @@ (iup:vbox ;; the header (apply iup:hbox (reverse hdrlst)) (apply iup:hbox (reverse bdylst)))))) controls)) + (data (d:data-init (make-d:data))) (tabs (iup:tabs #:tabchangepos-cb (lambda (obj curr prev) - (set! *please-update-buttons* #t) - (set! *current-tab-number* curr)) + (d:alldat-please-update-set! *alldat* #t) + (d:alldat-curr-tab-num-set! *alldat* curr)) (dashboard:summary db) runs-view - (dashboard:one-run db) + (dashboard:one-run db runs-sum-dat) + (dashboard:new-view db new-view-dat) (dashboard:run-controls) ))) ;; (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 "TABTITLE3" "New View") + (iup:attribute-set! tabs "TABTITLE4" "Run Control") (iup:attribute-set! tabs "BGCOLOR" "190 190 190") - (set! *hide-not-hide-tabs* tabs) + (d:alldat-hide-not-hide-tabs-set! *alldat* tabs) tabs))) (vector keycol lftcol header runsvec))) (if (or (args:get-arg "-rows") (get-environment-variable "DASHBOARDROWS" )) (begin - (set! *num-tests* (string->number (or (args:get-arg "-rows") - (get-environment-variable "DASHBOARDROWS")))) - (update-rundat "%" *num-runs* "%/%" '())) - (set! *num-tests* (min (max (update-rundat "%" *num-runs* "%/%" '()) 8) 20))) + (d:alldat-num-tests-set! *alldat* (string->number + (or (args:get-arg "-rows") + (get-environment-variable "DASHBOARDROWS")))) + (update-rundat "%" (d:alldat-numruns *alldat*) "%/%" '())) + (d:alldat-num-tests-set! *alldat* (min (max (update-rundat "%" (d:alldat-numruns *alldat*) "%/%" '()) 8) 20))) (define *tim* (iup:timer)) (define *ord* #f) (iup:attribute-set! *tim* "TIME" 300) (iup:attribute-set! *tim* "RUN" "YES") ;; Move this stuff to db.scm? I'm not sure that is the right thing to do... ;; -(define *last-db-update-time* (file-modification-time *db-file-path*)) ;; (conc *toppath* "/db/main.db"))) +(d:alldat-last-db-update-set! *alldat* (file-modification-time (d:alldat-dbfpath *alldat*))) ;; (conc *toppath* "/db/main.db"))) (define *last-recalc-ended-time* 0) (define (dashboard:been-changed) - (> (file-modification-time *db-file-path*) *last-db-update-time*)) + (> (file-modification-time (d:alldat-dbfpath *alldat*)) (d:alldat-last-db-update *alldat*))) (define (dashboard:set-db-update-time) - (set! *last-db-update-time* (file-modification-time *db-file-path*))) + (d:alldat-last-db-update-set! *alldat* (file-modification-time (d:alldat-dbfpath *alldat*)))) (define (dashboard:recalc modtime please-update-buttons last-db-update-time) (or please-update-buttons (and (> (current-milliseconds)(+ *last-recalc-ended-time* 150)) (> modtime last-db-update-time) (> (current-seconds)(+ last-db-update-time 1))))) -(define *monitor-db-path* (conc *dbdir* "/monitor.db")) +(define *monitor-db-path* (conc (d:alldat-dbdir *alldat*) "/monitor.db")) (define *last-monitor-update-time* 0) ;; Force creation of the db in case it isn't already there. (tasks:open-db) @@ -1554,50 +1830,52 @@ (begin (debug:print 0 "WARNING: error in accessing databases in get-youngest-run-db-mod-time: " ((condition-property-accessor 'exn 'message) exn)) (current-seconds)) ;; something went wrong - just print an error and return current-seconds (apply max (map (lambda (filen) (file-modification-time filen)) - (glob (conc *dbdir* "/*.db")))))) + (glob (conc (d:alldat-dbdir *alldat*) "/*.db")))))) (define (dashboard:run-update x) - (let* ((modtime (dashboard:get-youngest-run-db-mod-time)) ;; (file-modification-time *db-file-path*)) + (let* ((modtime (dashboard:get-youngest-run-db-mod-time)) ;; (file-modification-time (d:alldat-dbfpath *alldat*))) (monitor-modtime (if (file-exists? *monitor-db-path*) (file-modification-time *monitor-db-path*) -1)) (run-update-time (current-seconds)) - (recalc (dashboard:recalc modtime *please-update-buttons* *last-db-update-time*))) - (if (and (eq? *current-tab-number* 0) + (recalc (dashboard:recalc modtime (d:alldat-please-update *alldat*) (d:alldat-last-db-update *alldat*)))) + (if (and (eq? (d:alldat-curr-tab-num *alldat*) 0) (or (> monitor-modtime *last-monitor-update-time*) (> (- run-update-time *last-monitor-update-time*) 5))) ;; update every 1/2 minute just in case (begin (set! *last-monitor-update-time* run-update-time) ;; monitor-modtime) (if dashboard:update-servers-table (dashboard:update-servers-table)))) (if recalc (begin - (case *current-tab-number* + (case (d:alldat-curr-tab-num *alldat*) ((0) (if dashboard:update-summary-tab (dashboard:update-summary-tab))) ((1) ;; The runs table is active - (update-rundat (hash-table-ref/default *searchpatts* "runname" "%") *num-runs* - (hash-table-ref/default *searchpatts* "test-name" "%/%") - ;; (hash-table-ref/default *searchpatts* "item-name" "%") + (update-rundat (hash-table-ref/default (d:alldat-searchpatts *alldat*) "runname" "%") (d:alldat-numruns *alldat*) + (hash-table-ref/default (d:alldat-searchpatts *alldat*) "test-name" "%/%") + ;; (hash-table-ref/default (d:alldat-searchpatts *alldat*) "item-name" "%") (let ((res '())) (for-each (lambda (key) (if (not (equal? key "runname")) - (let ((val (hash-table-ref/default *searchpatts* key #f))) + (let ((val (hash-table-ref/default (d:alldat-searchpatts *alldat*) key #f))) (if val (set! res (cons (list key val) res)))))) - *dbkeys*) + (d:alldat-dbkeys *alldat*)) res)) - (update-buttons uidat *num-runs* *num-tests*)) + (update-buttons uidat (d:alldat-numruns *alldat*) (d:alldat-num-tests *alldat*))) ((2) + (dashboard:update-run-summary-tab)) + ((3) (dashboard:update-run-summary-tab)) (else - (let ((updater (hash-table-ref/default *updaters* *current-tab-number* #f))) + (let ((updater (hash-table-ref/default (d:alldat-updaters *alldat*) + (d:alldat-curr-tab-num *alldat*) #f))) (if updater (updater))))) - (set! *please-update-buttons* #f) - (set! *last-db-update-time* modtime) - (set! *last-update* run-update-time) + (d:alldat-please-update-set! *alldat* #f) + (d:alldat-last-db-update-set! *alldat* modtime) (set! *last-recalc-ended-time* (current-milliseconds)))))) ;;====================================================================== ;; The heavy lifting starts here ;;====================================================================== @@ -1605,73 +1883,68 @@ ;; ease debugging by loading ~/.dashboardrc (let ((debugcontrolf (conc (get-environment-variable "HOME") "/.dashboardrc"))) (if (file-exists? debugcontrolf) (load debugcontrolf))) -(cond - ((args:get-arg "-run") - (let ((runid (string->number (args:get-arg "-run")))) - (if runid - (begin - (lambda (x) - (on-exit std-exit-procedure) - (examine-run *dbstruct-local* runid))) - (begin - (print "ERROR: runid is not a number " (args:get-arg "-run")) - (exit 1))))) - ((args:get-arg "-test") ;; run-id,test-id - (let* ((dat (let ((d (map string->number (string-split (args:get-arg "-test") ",")))) - (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) - (begin - (debug:print 3 "INFO: tried to open test with invalid run-id,test-id. " (args:get-arg "-test")) - (exit 1))))) - ((args:get-arg "-guimonitor") - (gui-monitor *dbstruct-local*)) - (else - (set! uidat (make-dashboard-buttons *dbstruct-local* *num-runs* *num-tests* *dbkeys*)) - (iup:callback-set! *tim* - "ACTION_CB" - (lambda (x) - (let ((update-is-running #f)) - (mutex-lock! *update-mutex*) - (set! update-is-running *update-is-running*) - (if (not update-is-running) - (set! *update-is-running* #t)) - (mutex-unlock! *update-mutex*) - (if (not update-is-running) - (begin - (dashboard:run-update x) - (mutex-lock! *update-mutex*) - (set! *update-is-running* #f) - (mutex-unlock! *update-mutex*)))) - 1)))) - -(let ((th1 (make-thread (lambda () - (thread-sleep! 1) - (set! *please-update-buttons* #t) - (dashboard:run-update 1)) "update buttons once")) - ;; need to wait for first *update-is-running* #t - ;; (let loop () - ;; (mutex-lock! *update-mutex*) - ;; (if *update-is-running* - ;; (begin - ;; (set! *please-update-buttons* #t) - ;; (mark-for-update) - ;; (print "Did redraw trigger")) "First update after startup") - ;; (mutex-unlock! *update-mutex*) - ;; (thread-sleep! 1) - ;; (if (not *please-update-buttons*) - ;; (loop)))))) - (th2 (make-thread iup:main-loop "Main loop"))) - (thread-start! th1) - (thread-start! th2) - (thread-join! th2)) - -;; (iup:main-loop)(db:close-all *dbstruct-local*) +(define (main) + (let ((runs-sum-dat (d:data-init (make-d:data))) ;; data for run-summary tab + (new-view-dat (d:data-init (make-d:data)))) + (cond + ((args:get-arg "-run") + (let ((runid (string->number (args:get-arg "-run")))) + (if runid + (begin + (lambda (x) + (on-exit std-exit-procedure) + (examine-run (d:alldat-dblocal *alldat*) runid))) + (begin + (print "ERROR: runid is not a number " (args:get-arg "-run")) + (exit 1))))) + ((args:get-arg "-test") ;; run-id,test-id + (let* ((dat (let ((d (map string->number (string-split (args:get-arg "-test") ",")))) + (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) + (begin + (debug:print 3 "INFO: tried to open test with invalid run-id,test-id. " (args:get-arg "-test")) + (exit 1))))) + ((args:get-arg "-guimonitor") + (gui-monitor (d:alldat-dblocal *alldat*))) + (else + (set! uidat (make-dashboard-buttons (d:alldat-dblocal *alldat*) + (d:alldat-numruns *alldat*) + (d:alldat-num-tests *alldat*) + (d:alldat-dbkeys *alldat*) + runs-sum-dat new-view-dat)) + (iup:callback-set! *tim* + "ACTION_CB" + (lambda (x) + (let ((update-is-running #f)) + (mutex-lock! (d:alldat-update-mutex *alldat*)) + (set! update-is-running (d:alldat-updating *alldat*)) + (if (not update-is-running) + (d:alldat-updating-set! *alldat* #t)) + (mutex-unlock! (d:alldat-update-mutex *alldat*)) + (if (not update-is-running) + (begin + (dashboard:run-update x) + (mutex-lock! (d:alldat-update-mutex *alldat*)) + (d:alldat-updating-set! *alldat* #f) + (mutex-unlock! (d:alldat-update-mutex *alldat*))))) + 1)))) + + (let ((th1 (make-thread (lambda () + (thread-sleep! 1) + (d:alldat-please-update-set! *alldat* #t) + (dashboard:run-update 1)) "update buttons once")) + (th2 (make-thread iup:main-loop "Main loop"))) + (thread-start! th1) + (thread-start! th2) + (thread-join! th2)))) + +(main) Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -145,12 +145,11 @@ ;; NB// #f => return dbdir only ;; (was planned to be; zeroth db with name=main.db) ;; (define (db:dbfile-path run-id) - (let* ((dbdir (or (configf:lookup *configdat* "setup" "dbdir") - (conc (configf:lookup *configdat* "setup" "linktree") "/.db"))) + (let* ((dbdir (db:get-dbdir)) (fname (if run-id (if (eq? run-id 0) "main.db" (conc run-id ".db")) #f))) (handle-exceptions exn @@ -159,10 +158,14 @@ (exit 1)) (if (not (directory? dbdir))(create-directory dbdir #t))) (if fname (conc dbdir "/" fname) dbdir))) + +(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) ";")))) @@ -728,11 +731,11 @@ ;; 'closeall - close all opened dbs ;; ;; run-ids: '(1 2 3 ...) or #f (for all) ;; (define (db:multi-db-sync run-ids . options) - (let* ((toppath (launch:setup-for-run)) + (let* ((toppath (launch:setup)) (dbstruct (if toppath (make-dbr:dbstruct path: toppath) #f)) (mtdb (if toppath (db:open-megatest-db))) (allow-cleanup (if run-ids #f #t)) (run-ids (if run-ids run-ids @@ -1583,17 +1586,14 @@ ;; also updates *global-delta* ;; ;; Operates on megatestdb ;; (define (db:get-var dbstruct var) - (let* ((start-ms (current-milliseconds)) - (throttle (let ((t (config-lookup *configdat* "setup" "throttle"))) - (if t (string->number t) t))) - (res #f) + (let* ((res #f) (dbdat (db:get-db dbstruct #f)) (db (db:dbdat-get-db dbdat))) - (db:delay-if-busy dbdat) + ;; (db:delay-if-busy dbdat) (sqlite3:for-each-row (lambda (val) (set! res val)) db "SELECT val FROM metadat WHERE var=?;" var) @@ -1600,23 +1600,22 @@ ;; convert to number if can (if (string? res) (let ((valnum (string->number res))) (if valnum (set! res valnum)))) ;; scale by 10, average with current value. - (set! *global-delta* (/ (+ *global-delta* (* (- (current-milliseconds) start-ms) - (if throttle throttle 0.01))) - 2)) - (if (> (abs (- *last-global-delta-printed* *global-delta*)) 0.08) ;; don't print all the time, only if it changes a bit - (begin - (debug:print-info 4 "launch throttle factor=" *global-delta*) - (set! *last-global-delta-printed* *global-delta*))) +;; (set! *global-delta* (/ (+ *global-delta* (* (- (current-milliseconds) start-ms) +;; (if throttle throttle 0.01))) +;; 2)) +;; (if (> (abs (- *last-global-delta-printed* *global-delta*)) 0.08) ;; don't print all the time, only if it changes a bit +;; (begin +;; (debug:print-info 4 "launch throttle factor=" *global-delta*) +;; (set! *last-global-delta-printed* *global-delta*))) res)) (define (db:set-var dbstruct var val) - (let ((dbdat (db:get-db dbstruct #f)) - (db (db:dbdat-get-db dbdat))) - (db:delay-if-busy dbdat) + (let* ((dbdat (db:get-db dbstruct #f)) + (db (db:dbdat-get-db dbdat))) (sqlite3:execute db "INSERT OR REPLACE INTO metadat (var,val) VALUES (?,?);" var val))) (define (db:del-var dbstruct var) ;; (db:delay-if-busy) (db:with-db dbstruct #f #t Index: dcommon.scm ================================================================== --- dcommon.scm +++ dcommon.scm @@ -11,11 +11,11 @@ (use format) (require-library iup) (import (prefix iup iup:)) (use canvas-draw) -(use regex) +(use regex defstruct) (declare (unit dcommon)) (declare (uses megatest-version)) (declare (uses gutils)) @@ -63,10 +63,15 @@ (define (dboard:data-get-target-string vec) (let ((targ (dboard:data-get-target vec))) (if (list? targ)(string-intersperse targ "/") "no-target-specified"))) (define (dboard:data-get-run-name vec) (vector-ref vec 19)) (define (dboard:data-get-runs-listbox vec) (vector-ref vec 20)) + +(defstruct d:data runs tests runs-matrix tests-tree run-keys + curr-test-ids updaters path-run-ids curr-run-id runs-tree test-patts + states statuses logs-textbox command command-tb target run-name + runs-listbox) (define (dboard:data-set-runs! vec val)(vector-set! vec 0 val)) (define (dboard:data-set-tests! vec val)(vector-set! vec 1 val)) (define (dboard:data-set-runs-matrix! vec val)(vector-set! vec 2 val)) (define (dboard:data-set-tests-tree! vec val)(vector-set! vec 3 val)) @@ -98,10 +103,16 @@ ;; Look up test-ids by (key1 key2 ... testname [itempath]) (dboard:data-set-path-test-ids! *data* (make-hash-table)) ;; Look up run-ids by ?? (dboard:data-set-path-run-ids! *data* (make-hash-table)) + +(define (d:data-init dat) + (d:data-run-keys-set! dat (make-hash-table)) + (d:data-curr-test-ids-set! dat (make-hash-table)) + (d:data-path-run-ids-set! dat (make-hash-table)) + dat) ;;====================================================================== ;; D O T F I L E ;;====================================================================== @@ -407,11 +418,11 @@ (row-indices (car indices)) (col-indices (cadr indices)) (max-row (if (null? row-indices) 1 (apply max (map cadr row-indices)))) (max-col (if (null? col-indices) 1 (apply max (map cadr col-indices)))) - (max-visible (max (- *num-tests* 15) 3)) + (max-visible (max (- (d:alldat-num-tests *alldat*) 15) 3)) (max-col-vis (if (> max-col 10) 10 max-col)) (numrows 1) (numcols 1)) (iup:attribute-set! stats-matrix "CLEARVALUE" "CONTENTS") (iup:attribute-set! stats-matrix "NUMCOL" max-col ) @@ -579,16 +590,16 @@ ;;====================================================================== ;; CANVAS STUFF FOR TESTS ;;====================================================================== -(define (dcommon:draw-test cnv scalef x y w h name selected) - (let* ((llx (* scalef x)) - (lly (* scalef y)) - (urx (* scalef (+ x w))) - (ury (* scalef (+ y h)))) - (canvas-text! cnv (+ llx 5)(+ lly 5) name) ;; (conc testname " (" xtorig "," ytorig ")")) +(define (dcommon:draw-test cnv xoffset yoffset scalef x y w h name selected) + (let* ((llx (dcommon:x->canvas x scalef xoffset)) + (lly (dcommon:y->canvas y scalef yoffset)) + (urx (dcommon:x->canvas (+ x w) scalef xoffset)) + (ury (dcommon:y->canvas (+ y h) scalef yoffset))) + (canvas-text! cnv (+ llx 5)(+ lly 5) name) (canvas-rectangle! cnv llx urx lly ury) (if selected (canvas-box! cnv llx (+ llx 5) lly (+ lly 5))))) (define (dcommon:draw-arrow cnv test-box-center waiton-center) (let* ((test-box-center-x (vector-ref test-box-center 0)) @@ -630,33 +641,41 @@ ) (canvas-mark! cnv new-waiton-x new-waiton-y))) (define (dcommon:get-box-center box) (let* ((llx (list-ref box 0)) - (lly (list-ref box 4)) - (boxw (list-ref box 5)) - (boxh (list-ref box 6))) + (lly (list-ref box 1)) + (boxw (list-ref box 4)) + (boxh (list-ref box 5))) (vector (+ llx (/ boxw 2)) (+ lly (/ boxh 2))))) (define-inline (num->int num) (inexact->exact (round num))) -(define (dcommon:draw-edges cnv scalef edges) +(define (dcommon:draw-edges cnv xoffset yoffset scalef edges) (for-each (lambda (e) (let loop ((x1 (car e)) (y1 (cadr e)) (x2 #f) (y2 #f) (tal (cddr e))) (if (and x1 y1 x2 y2) - (canvas-line! cnv x1 y1 x2 y2)) ;; (num->int x1)(num->int y1)(num->int x2)(num->int y2))) + (canvas-line! + cnv + (num->int (dcommon:x->canvas x1 scalef xoffset)) + (num->int (dcommon:y->canvas y1 scalef yoffset)) + (num->int (dcommon:x->canvas x2 scalef xoffset)) + (num->int (dcommon:y->canvas y2 scalef yoffset)))) ;; (num->int x1)(num->int y1)(num->int x2)(num->int y2))) (if (< (length tal) 2) - (canvas-mark! cnv x1 y1) ;; (num->int x1)(num->int y1)) + (canvas-mark! cnv + (num->int (dcommon:x->canvas x1 scalef xoffset)) + (num->int (dcommon:y->canvas y1 scalef yoffset))) ;; (num->int x1)(num->int y1)) (loop (car tal)(cadr tal) x1 y1 (cddr tal))))) - (map (lambda (e)(map (lambda (x)(num->int (* x scalef))) e)) edges))) + ;; (map (lambda (e)(map (lambda (x)(num->int (* x scalef))) e)) edges))) + edges)) (define (dcommon:draw-arrows cnv testname tests-hash test-records) (let* ((test-box-info (hash-table-ref tests-hash testname)) (test-box-center (dcommon:get-box-center test-box-info)) @@ -670,81 +689,146 @@ waitons) ;; (debug:print 0 "test-box-info=" test-box-info) ;; (debug:print 0 "test-record=" test-record) )) +(define (dcommon:estimate-scale sizex sizey originx originy nodes) + ;; (print "sizex: " sizex " sizey: " sizey " originx: " originx " originy: " originy " nodes: " nodes) + (let* ((maxx 1) + (maxy 1)) + (for-each + (lambda (node) + (if (equal? (car node) "node") + (let ((x (string->number (list-ref node 2))) + (y (string->number (list-ref node 3)))) + (if (and x (> x maxx))(set! maxx x)) + (if (and y (> y maxy))(set! maxy y))))) + nodes) + (let ((scalex (/ sizex maxx)) + (scaley (/ sizey maxy))) + ;; (print "maxx: " maxx " maxy: " maxy " scalex: " scalex " scaley: " scaley) + (min scalex scaley)))) + +(define (dcommon:get-xoffset tests-draw-state sizex-in xadj-in) + (let ((xadj (or xadj-in (hash-table-ref/default tests-draw-state 'xadj 0))) + (sizex (or sizex-in (hash-table-ref/default tests-draw-state 'sizex 500)))) + (hash-table-set! tests-draw-state 'xadj xadj) ;; for use in de-scaling when handling mouse clicks + (hash-table-set! tests-draw-state 'sizex sizex) + (* (/ sizex 2) (- 0.5 xadj)))) + +(define (dcommon:get-yoffset tests-draw-state sizey-in yadj-in) + (let ((yadj (or yadj-in (hash-table-ref/default tests-draw-state 'yadj 0))) + (sizey (or sizey-in (hash-table-ref/default tests-draw-state 'sizey 500)))) + (hash-table-set! tests-draw-state 'yadj yadj) ;; for use in de-scaling when handling mouse clicks + (hash-table-set! tests-draw-state 'sizey sizey) + (* (/ sizey 2) (- yadj 0.5)))) + +(define (dcommon:x->canvas x scalef xoffset) + (+ xoffset (* x scalef))) + +(define (dcommon:y->canvas y scalef yoffset) + (+ yoffset (* y scalef))) + +;; sizex, sizey - canvas size +;; originx, originy - canvas origin +;; (define (dcommon:initial-draw-tests cnv xadj yadj sizex sizey sizexmm sizeymm originx originy tests-draw-state sorted-testnames test-records) (let* ((dot-data ;; (map cdr (filter ;; (lambda (x)(equal? "node" (car x))) - (map string-split (tests:lazy-dot test-records "plain"))) ;; (tests:easy-dot test-records "plain"))) - (scalef (hash-table-ref tests-draw-state 'scalef)) - (dotscale (hash-table-ref tests-draw-state 'dotscale)) - (test-browse-xoffset (hash-table-ref tests-draw-state 'test-browse-xoffset)) - (test-browse-yoffset (hash-table-ref tests-draw-state 'test-browse-yoffset)) - (xtorig (+ test-browse-xoffset (* (/ sizex 2) 1 (- 0.5 xadj)))) ;; (- xadj 1)))) - (ytorig (+ test-browse-yoffset (* (/ sizey 2) 1 (- yadj 0.5)))) - (boxw 10) - (tests-hash (hash-table-ref tests-draw-state 'tests-info)) - (selected-tests (hash-table-ref tests-draw-state 'selected-tests ))) - ;; (print "dot-data=" dot-data) - (hash-table-set! tests-draw-state 'xtorig xtorig) - (hash-table-set! tests-draw-state 'ytorig ytorig) + (map string-split (tests:lazy-dot test-records "plain" sizex sizey))) ;; (tests:easy-dot test-records "plain"))) + (xoffset (dcommon:get-xoffset tests-draw-state sizex xadj)) + (yoffset (dcommon:get-yoffset tests-draw-state sizey yadj)) + (no-dot (configf:lookup *configdat* "setup" "nodot")) + (boxh 15) + (boxw 10) + (margin 5) + (tests-info (hash-table-ref tests-draw-state 'tests-info)) + (selected-tests (hash-table-ref tests-draw-state 'selected-tests )) + (scalef (if no-dot + 1 + (dcommon:estimate-scale sizex sizey originx originy dot-data))) + (sorted-testnames (if no-dot + (sort sorted-testnames string>=?) + sorted-testnames)) + (curr-x 0) ;; NB// NOT screen units + (curr-y (/ (- sizey boxh margin) scalef)) ;; used when no-dot + (scaled-sizex (/ sizex scalef))) + + (hash-table-set! tests-draw-state 'scalef scalef) + (let ((longest-str (if (null? sorted-testnames) " " (car (sort sorted-testnames (lambda (a b)(>= (string-length a)(string-length b)))))))) (let-values (((x-max y-max) (canvas-text-size cnv longest-str))) (if (> x-max boxw)(set! boxw (+ 10 x-max))))) ;; (print "sizex: " sizex " sizey: " sizey " font: " (canvas-font cnv) " originx: " originx " originy: " originy " xtorig: " xtorig " ytorig: " ytorig " xadj: " xadj " yadj: " yadj) (if (not (null? sorted-testnames)) (let loop ((hed (car (reverse sorted-testnames))) (tal (cdr (reverse sorted-testnames)))) - (let* ((nodedat (let ((tmpres (filter (lambda (x) - (if (and (not (null? x)) - (equal? (car x) "node")) - (equal? hed (cadr x)) - #f)) - dot-data))) - (if (null? tmpres) - ;; llx lly boxw boxh - (list "0" "1" "1" (conc (length tal)) "2" "0.5") ;; return some junk - (car tmpres)))) - (edgedat (let ((edges (filter (lambda (x) ;; filter for edge - (if (and (not (null? x)) - (equal? (car x) "edge")) - (equal? hed (cadr x)) - #f)) - dot-data))) - (map (lambda (inlst) - (dcommon:process-polyline - (map (lambda (instr) - (* dotscale (string->number instr))) ;; convert to number and scale - (let ((il (cddddr inlst))) - (take il (- (length il) 2)))) - (lambda (x y) - (list (+ x xtorig) - (+ y ytorig))) - #f #f)) ;; process polyline - edges))) - (llx (* (string->number (list-ref nodedat 2)) dotscale)) - (lly (* (string->number (list-ref nodedat 3)) dotscale)) - (boxw (* (string->number (list-ref nodedat 4)) dotscale)) - (boxh (* (string->number (list-ref nodedat 5)) dotscale)) + (let* ((nodedat (if no-dot + #f + (let ((tmpres (filter (lambda (x) + (if (and (not (null? x)) + (equal? (car x) "node")) + (equal? hed (cadr x)) + #f)) + dot-data))) + (if (null? tmpres) + ;; llx lly boxw boxh + (list "0" "1" "1" (conc (length tal)) "2" "0.5") ;; return some placeholder junk if no dat found + (car tmpres))))) + (edgedat (if no-dot + '() + (let ((edges (filter (lambda (x) ;; filter for edge + (if (and (not (null? x)) + (equal? (car x) "edge")) + (equal? hed (cadr x)) + #f)) + dot-data))) + (map (lambda (inlst) + (dcommon:process-polyline + (map (lambda (instr) + (string->number instr)) ;; convert to number and scale + (let ((il (cddddr inlst))) + (take il (- (length il) 2)))) + (lambda (x y) + (list (+ x 0) ;; xtorig) + (+ y 0))) ;; ytorig))) + #f #f)) ;; process polyline + edges)))) + (llx (if no-dot + curr-x + (string->number (list-ref nodedat 2)))) + (lly (if no-dot + curr-y + (string->number (list-ref nodedat 3)))) + (boxw (if no-dot + boxw + (string->number (list-ref nodedat 4)))) + (boxh (if no-dot + boxh + (string->number (list-ref nodedat 5)))) (urx (+ llx boxw)) (ury (+ lly boxh))) + + ;; if we are in no-dot mode then increment curr-x and curr-y as needed + (if no-dot + (begin + (cond + ((< curr-x (- scaled-sizex boxw boxw margin)) + (set! curr-x (+ curr-x boxw margin))) + ((> curr-x (- scaled-sizex boxw boxw margin)) + (set! curr-x 0) + (set! curr-y (- curr-y (+ boxh margin))))))) ; (print "hed " hed " llx " llx " lly " lly " urx " urx " ury " ury) - (dcommon:draw-test cnv scalef llx lly boxw boxh hed (hash-table-ref/default selected-tests hed #f)) - ;; (dcommon:draw-arrows cnv testname tests-hash test-records)) - (dcommon:draw-edges cnv scalef edgedat) + (dcommon:draw-test cnv xoffset yoffset scalef llx lly boxw boxh hed (hash-table-ref/default selected-tests hed #f)) + ;; (dcommon:draw-arrows cnv testname tests-info test-records)) + (dcommon:draw-edges cnv xoffset yoffset scalef edgedat) ;; data used by mouse click calc. keep the wacky order for now. - (hash-table-set! tests-hash hed (list llx urx (- sizey ury)(- sizey lly) lly boxw boxh edgedat)) - ;; (list llx lly boxw boxh)) ;; NB// Swap ury and lly + (hash-table-set! tests-info hed (list llx lly urx ury boxw boxh edgedat)) (if (not (null? tal)) (loop (car tal) (cdr tal)))))) - ;; (for-each - ;; (lambda (testname) - ;; (dcommon:draw-arrows cnv testname tests-hash test-records)) - ;; sorted-testnames)) )) ;; per-point-proc required, remainder optional ;; (define (dcommon:process-polyline line per-point-proc per-segment-proc last-segment-proc) @@ -764,48 +848,36 @@ (append res (per-point-proc x1 y1))) (loop (car tal)(cadr tal) x1 y1 (cddr tal) (append res (per-point-proc x1 y1))))))) (define (dcommon:redraw-tests cnv xadj yadj sizex sizey sizexmm sizeymm originx originy tests-draw-state sorted-testnames test-records) (let* ((scalef (hash-table-ref tests-draw-state 'scalef)) - (test-browse-xoffset (hash-table-ref tests-draw-state 'test-browse-xoffset)) - (test-browse-yoffset (hash-table-ref tests-draw-state 'test-browse-yoffset)) - (xtorig (+ test-browse-xoffset (* (/ sizex 2) (- xadj 0.5)))) ;; (- xadj 1)))) - (ytorig (+ test-browse-yoffset (* (/ sizey 2) (- 0.5 yadj)))) - (xdelta (- (hash-table-ref tests-draw-state 'xtorig) xtorig)) - (ydelta (- (hash-table-ref tests-draw-state 'ytorig) ytorig)) - (tests-hash (hash-table-ref tests-draw-state 'tests-info)) + (xoffset (dcommon:get-xoffset tests-draw-state sizex xadj)) + (yoffset (dcommon:get-yoffset tests-draw-state sizey yadj)) + (tests-info (hash-table-ref tests-draw-state 'tests-info)) (selected-tests (hash-table-ref tests-draw-state 'selected-tests ))) - (hash-table-set! tests-draw-state 'xtorig xtorig) - (hash-table-set! tests-draw-state 'ytorig ytorig) (if (not (null? sorted-testnames)) (let loop ((hed (car (reverse sorted-testnames))) (tal (cdr (reverse sorted-testnames)))) - (let* ((tvals (hash-table-ref tests-hash hed)) - (llx (+ xdelta (list-ref tvals 0))) - (lly (+ ydelta (list-ref tvals 4))) - (boxw (list-ref tvals 5)) - (boxh (list-ref tvals 6)) + (let* ((tvals (hash-table-ref tests-info hed)) + (llx (list-ref tvals 0)) + (lly (list-ref tvals 1)) + (boxw (list-ref tvals 4)) + (boxh (list-ref tvals 5)) (edges (map (lambda (pline) (dcommon:process-polyline pline (lambda (x1 y1) - (list (+ x1 xdelta) - (+ y1 ydelta))) + (list x1 y1)) #f #f)) - (list-ref tvals 7))) + (list-ref tvals 6))) (urx (+ llx boxw)) (ury (+ lly boxh))) - (dcommon:draw-test cnv scalef llx lly boxw boxh hed (hash-table-ref/default selected-tests hed #f)) - (dcommon:draw-edges cnv scalef edges) - (hash-table-set! tests-hash hed (list llx urx (- sizey ury)(- sizey lly) lly boxw boxh edges)) + (dcommon:draw-test cnv xoffset yoffset scalef llx lly boxw boxh hed (hash-table-ref/default selected-tests hed #f)) + (dcommon:draw-edges cnv xoffset yoffset scalef edges) (if (not (null? tal)) ;; leave a column of space to the right to list items (loop (car tal) (cdr tal)))))))) - ;; (for-each - ;; (lambda (testname) - ;; (dcommon:draw-edges cnv scalef edges)) ;; (dcommon:draw-arrows cnv testname tests-hash test-records)) - ;; sorted-testnames))) ;;====================================================================== ;; S T E P S ;;====================================================================== Index: docs/manual/megatest_manual.html ================================================================== --- docs/manual/megatest_manual.html +++ docs/manual/megatest_manual.html @@ -1,10 +1,10 @@ - + The Megatest Users Manual