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 @@ -709,11 +719,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 +736,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 +749,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,11 +861,11 @@ ;; (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 'dotscale 10.5) (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))))))) @@ -799,11 +903,11 @@ ;; (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 +972,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")) @@ -1089,32 +1193,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 +1402,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 +1446,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 +1469,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 +1543,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 +1598,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 +1636,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 +1691,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 +1750,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 +1773,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 +1840,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 +1893,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 @@ -728,11 +728,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 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 ) ADDED fsl-rebase.scm Index: fsl-rebase.scm ================================================================== --- /dev/null +++ fsl-rebase.scm @@ -0,0 +1,37 @@ +;; given branch and baseline commit generate list of commands to cherry pick commits +;; +;; +;; Usage: fsl-rebase basecommit branch +;; + +(use regex posix) + +(let* ((basecommit (cadr (argv))) + (branch (caddr (argv))) + (cmd (conc "fossil timeline after " basecommit " -n 1000000 -W 0")) + (theregex (conc ;; "^[^\\]]+" + "\\[([a-z0-9]+)\\]\\s+" + "(.*)" + "\\s+\\(.*tags:\\s+" branch + ;; ".*\\)" + ))) + (print "basecommit: " basecommit ", branch: " branch ", theregex: " theregex ", cmd: \"" cmd "\"") + (with-input-from-pipe + cmd + (lambda () + (let loop ((inl (read-line)) + (res '())) + (if (not (eof-object? inl)) + (let ((have-match (string-search theregex inl))) + (if have-match + (loop (read-line) + (cons (conc "fossil merge --cherrypick " (cadr have-match) + "\nfossil commit -m \"Cherry pick from " (cadr have-match) + ": " (caddr have-match) "\"") + res)) + (loop (read-line) res))) + (map print res)))))) + +;; (print "match: " inl "\n $1: " (cadr have-match) " $2: " (caddr have-match)) +;; (print "no match: " theregex " " inl)) +;; (loop (read-line)))))))) Index: launch.scm ================================================================== --- launch.scm +++ launch.scm @@ -138,15 +138,16 @@ (if logpro-used (rmt:test-set-log! run-id test-id (conc stepname ".html"))) ;; set the test final status (let* ((process-exit-status (launch:einf-exit-code exit-info)) ;; (vector-ref exit-info 2)) (this-step-status (cond - ((and (eq? process-exit-status 2) logpro-used) 'warn) ;; logpro 2 = warnings - ((and (eq? process-exit-status 3) logpro-used) 'check) ;; logpro 3 = check - ((and (eq? process-exit-status 4) logpro-used) 'waived) ;; logpro 4 = abort - ((and (eq? process-exit-status 5) logpro-used) 'abort) ;; logpro 4 = abort - ((eq? process-exit-status 0) 'pass) ;; logpro 0 = pass + ((and (eq? process-exit-status 2) logpro-used) 'warn) ;; logpro 2 = warnings + ((and (eq? process-exit-status 3) logpro-used) 'check) ;; logpro 3 = check + ((and (eq? process-exit-status 4) logpro-used) 'waived) ;; logpro 4 = waived + ((and (eq? process-exit-status 5) logpro-used) 'abort) ;; logpro 5 = abort + ((and (eq? process-exit-status 6) logpro-used) 'skip) ;; logpro 6 = skip + ((eq? process-exit-status 0) 'pass) ;; logpro 0 = pass (else 'fail))) (overall-status (cond ((eq? (launch:einf-rollup-status exit-info) 2) 'warn) ;; rollup-status (vector-ref exit-info 3) ((eq? (launch:einf-rollup-status exit-info) 0) 'pass) ;; (vector-ref exit-info 3) (else 'fail))) @@ -158,12 +159,11 @@ (else 'fail))) (next-state ;; "RUNNING") ;; WHY WAS THIS CHANGED TO NOT USE (null? tal) ?? (cond ((null? tal) ;; more to run? "COMPLETED") - (else "RUNNING"))) - ) + (else "RUNNING")))) (debug:print 4 "Exit value received: " (launch:einf-exit-code exit-info) " logpro-used: " logpro-used " this-step-status: " this-step-status " overall-status: " overall-status " next-status: " next-status " rollup-status: " (launch:einf-rollup-status exit-info)) ;; (vector-ref exit-info 3)) (case next-status ((warn) @@ -176,16 +176,28 @@ (launch:einf-rollup-status-set! exit-info 3) ;; (vector-set! exit-info 3 3) ;; rollup-status ;; NB// test-set-status! does rdb calls under the hood (tests:test-set-status! run-id test-id next-state "CHECK" (if (eq? this-step-status 'check) "Logpro check found" #f) #f)) + ((waived) + (launch:einf-rollup-status-set! exit-info 4) ;; (vector-set! exit-info 3 3) ;; rollup-status + ;; NB// test-set-status! does rdb calls under the hood + (tests:test-set-status! run-id test-id next-state "WAIVED" + (if (eq? this-step-status 'check) "Logpro waived found" #f) + #f)) ((abort) - (launch:einf-rollup-status-set! exit-info 4) ;; (vector-set! exit-info 3 4) ;; rollup-status + (launch:einf-rollup-status-set! exit-info 5) ;; (vector-set! exit-info 3 4) ;; rollup-status ;; NB// test-set-status! does rdb calls under the hood (tests:test-set-status! run-id test-id next-state "ABORT" (if (eq? this-step-status 'abort) "Logpro abort found" #f) #f)) + ((skip) + (launch:einf-rollup-status-set! exit-info 6) ;; (vector-set! exit-info 3 4) ;; rollup-status + ;; NB// test-set-status! does rdb calls under the hood + (tests:test-set-status! run-id test-id next-state "SKIP" + (if (eq? this-step-status 'skip) "Logpro skip found" #f) + #f)) ((pass) (tests:test-set-status! run-id test-id next-state "PASS" #f #f)) (else ;; 'fail (launch:einf-rollup-status-set! exit-info 1) ;; (vector-set! exit-info 3 1) ;; force fail, this used to be next-state but that doesn't make sense. should always be "COMPLETED" (tests:test-set-status! run-id test-id "COMPLETED" "FAIL" (conc "Failed at step " stepname) #f) @@ -269,15 +281,21 @@ ;; (set-signal-handler! signal/int (lambda () ;; Do not run the test if it is REMOVING, RUNNING, KILLREQ or REMOTEHOSTSTART, ;; Mark the test as REMOTEHOSTSTART *IMMEDIATELY* ;; - (let ((test-info (rmt:get-testinfo-state-status run-id test-id))) + (let* ((test-info (rmt:get-test-info-by-id run-id test-id)) + (test-host (db:test-get-host test-info)) + (test-pid (db:test-get-process_id test-info))) (cond ((member (db:test-get-state test-info) '("INCOMPLETE" "KILLED" "UNKNOWN" "KILLREQ" "STUCK")) ;; prior run of this test didn't complete, go ahead and try to rerun (debug:print 0 "INFO: test is INCOMPLETE or KILLED, treat this execute call as a rerun request") (tests:test-force-state-status! run-id test-id "REMOTEHOSTSTART" "n/a")) ;; prime it for running + ((member (db:test-get-state test-info) '("RUNNING" "REMOTEHOSTSTART")) + (if (process:alive-on-host? test-host test-pid) + (debug:print 0 "ERROR: test state is " (db:test-get-state test-info) " and process " test-pid " is still running on host " test-host ", cannot proceed") + (tests:test-force-state-status! run-id test-id "REMOTEHOSTSTART" "n/a"))) ((not (member (db:test-get-state test-info) '("REMOVING" "REMOTEHOSTSTART" "RUNNING" "KILLREQ"))) (tests:test-force-state-status! run-id test-id "REMOTEHOSTSTART" "n/a")) (else ;; (member (db:test-get-state test-info) '("REMOVING" "REMOTEHOSTSTART" "RUNNING" "KILLREQ")) (debug:print 0 "ERROR: test state is " (db:test-get-state test-info) ", cannot proceed") (exit)))) @@ -284,11 +302,11 @@ (debug:print 2 "Exectuing " test-name " (id: " test-id ") on " (get-host-name)) (set! keys (rmt:get-keys)) ;; (runs:set-megatest-env-vars run-id inkeys: keys inkeyvals: keyvals) ;; these may be needed by the launching process ;; one of these is defunct/redundant ... - (if (not (launch:setup-for-run force: #t)) + (if (not (launch:setup force: #t)) (begin (debug:print 0 "Failed to setup, exiting") ;; (sqlite3:finalize! db) ;; (sqlite3:finalize! tdb) (exit 1))) @@ -437,22 +455,18 @@ (hash-table-ref/default testconfig "ezsteps" '()) #f))) (if testconfig (hash-table-set! *testconfigs* test-name testconfig) ;; cached for lazy reads later ... (begin - ;; got here but there are race condiitions - re-do all setup and try one more time - (if (launch:setup-for-run) - (begin - (launch:cache-config) - (set! testconfig (full-runconfigs-read))) ;; redunantly redundant, but does it resolve the race? + (launch:setup) (debug:print 0 "WARNING: no testconfig found for " test-name " in search path:\n " - (string-intersperse (tests:get-tests-search-path *configdat*) "\n "))))) + (string-intersperse (tests:get-tests-search-path *configdat*) "\n ")))) ;; after all that, still no testconfig? Time to abort (if (not testconfig) (begin (debug:print 0 "ERROR: Failed to resolve megatest.config, runconfigs.config and testconfig issues. Giving up now") - (exit 1)))s + (exit 1))) (if (not (file-exists? ".ezsteps"))(create-directory ".ezsteps")) ;; if ezsteps was defined then we are sure to have at least one step but check anyway (if (not (> (length ezstepslst) 0)) (debug:print 0 "ERROR: ezsteps defined but ezstepslst is zero length") (let loop ((ezstep (car ezstepslst)) @@ -459,13 +473,14 @@ (tal (cdr ezstepslst)) (prevstep #f)) ;; check exit-info (vector-ref exit-info 1) (if (launch:einf-exit-status exit-info) ;; (vector-ref exit-info 1) (let ((logpro-used (launch:runstep ezstep run-id test-id exit-info m tal testconfig))) - (if (and (steprun-good? logpro-used (launch:einf-exit-code exit-info)) - (not (null? tal))) - (loop (car tal) (cdr tal) stepname))) + (if (steprun-good? logpro-used (launch:einf-exit-code exit-info)) + (if (not (null? tal)) + (loop (car tal) (cdr tal) stepname)) + (debug:print 4 "WARNING: step " (car ezstep) " failed. Stopping"))) (debug:print 4 "WARNING: a prior step failed, stopping at " ezstep)))))))) (monitorjob (lambda () (let* ((start-seconds (current-seconds)) (calc-minutes (lambda () (inexact->exact @@ -575,10 +590,14 @@ (if (equal? (db:test-get-status testinfo) "AUTO") "AUTO" "PASS")) ((eq? (launch:einf-rollup-status exit-info) 1) "FAIL") ;; (vector-ref exit-info 3) ((eq? (launch:einf-rollup-status exit-info) 2) ;; (vector-ref exit-info 3) ;; if the current status is AUTO the defer to the calculated value but qualify (i.e. make this AUTO-WARN) (if (equal? (db:test-get-status testinfo) "AUTO") "AUTO-WARN" "WARN")) + ((eq? (launch:einf-rollup-status exit-info) 3) "CHECK") + ((eq? (launch:einf-rollup-status exit-info) 4) "WAIVED") + ((eq? (launch:einf-rollup-status exit-info) 5) "ABORT") + ((eq? (launch:einf-rollup-status exit-info) 6) "SKIP") (else "FAIL")))) ;; (db:test-get-status testinfo))) (debug:print-info 1 "Test exited in state=" (db:test-get-state testinfo) ", setting state/status based on exit code of " (launch:einf-exit-status exit-info) " and rollup-status of " (launch:einf-rollup-status exit-info)) (tests:test-set-status! run-id test-id new-state @@ -595,13 +614,47 @@ (mutex-unlock! m) (debug:print 2 "Output from running " fullrunscript ", pid " (launch:einf-pid exit-info) " in work area " work-area ":\n====\n exit code " (launch:einf-exit-code exit-info) "\n" "====\n") (if (not (launch:einf-exit-status exit-info)) (exit 4))))))) + +(define (launch:cache-config) + ;; if we have a linktree and -runtests and -target and the directory exists dump the config + ;; to megatest-(current-seconds).cfg and symlink it to megatest.cfg + (if (and *configdat* + (or (args:get-arg "-run") + (args:get-arg "-runtests") + (args:get-arg "-execute"))) + (let* ((linktree (get-environment-variable "MT_LINKTREE")) + (target (common:args-get-target)) + (runname (or (args:get-arg "-runname") + (args:get-arg ":runname") + (getenv "MT_RUNNAME"))) + (fulldir (conc linktree "/" + target "/" + runname))) + (debug:print-info 0 "Have -runtests with target=" target ", runname=" runname ", fulldir=" fulldir ", testpatt=" (or (args:get-arg "-testpatt") "%")) + (if (and linktree (file-exists? linktree)) ;; can't proceed without linktree + (begin + (if (not (file-exists? fulldir)) + (create-directory fulldir #t)) ;; need to protect with exception handler + (if (and target + runname + (file-exists? fulldir)) + (let ((tmpfile (conc fulldir "/.megatest.cfg." (current-seconds))) + (targfile (conc fulldir "/.megatest.cfg-" megatest-version "-" megatest-fossil-hash)) + (rconfig (conc fulldir "/.runconfig." megatest-version "-" megatest-fossil-hash))) + (if (file-exists? rconfig) ;; only cache megatest.config AFTER runconfigs has been cached + (begin + (debug:print-info 0 "Caching megatest.config in " fulldir "/.megatest.cfg") + (configf:write-alist *configdat* tmpfile) + (system (conc "ln -sf " tmpfile " " targfile)))) + ))))))) ;; set up the very basics needed for doing anything here. -(define (launch:setup-for-run #!key (force #f)) +;; +(define (launch:setup-old #!key (force #f)) ;; would set values for KEYS in the environment here for better support of env-override but ;; have chicken/egg scenario. need to read megatest.config then read it again. Going to ;; pass on that idea for now ;; special case (if (or force (not (hash-table? *configdat*))) ;; no need to re-open on every call @@ -665,61 +718,137 @@ (debug:print 0 "ERROR: failed to find the top path to your Megatest area.") (exit 1))) ))) *toppath*) -(define (launch:cache-config) - ;; if we have a linktree and -runtests and -target and the directory exists dump the config - ;; to megatest-(current-seconds).cfg and symlink it to megatest.cfg - (if (and *configdat* - (or (args:get-arg "-run") - (args:get-arg "-runtests") - (args:get-arg "-execute"))) - (let* ((linktree (get-environment-variable "MT_LINKTREE")) - (target (common:args-get-target)) - (runname (or (args:get-arg "-runname") - (args:get-arg ":runname") - (getenv "MT_RUNNAME"))) - (fulldir (conc linktree "/" - target "/" - runname))) - (debug:print-info 0 "Have -runtests with target=" target ", runname=" runname ", fulldir=" fulldir ", testpatt=" (or (args:get-arg "-testpatt") "%")) - (if (file-exists? linktree) ;; can't proceed without linktree - (begin - (if (not (file-exists? fulldir)) - (create-directory fulldir #t)) ;; need to protect with exception handler - (if (and target - runname - (file-exists? fulldir)) - (let ((tmpfile (conc fulldir "/.megatest.cfg." (current-seconds))) - (targfile (conc fulldir "/.megatest.cfg-" megatest-version "-" megatest-fossil-hash)) - (rconfig (conc fulldir "/.runconfig." megatest-version "-" megatest-fossil-hash))) - (if (file-exists? rconfig) ;; only cache megatest.config AFTER runconfigs has been cached - (begin - (debug:print-info 0 "Caching megatest.config in " fulldir "/.megatest.cfg") - (configf:write-alist *configdat* tmpfile) - (system (conc "ln -sf " tmpfile " " targfile)))) - ))))))) - ;; gather available information, if legit read configs in this order: ;; ;; if have cache; ;; read it a return it ;; else ;; megatest.config (do not cache) ;; runconfigs.config (cache if all vars avail) ;; megatest.config (cache if all vars avail) +;; returns: +;; *toppath* +;; side effects: +;; sets; *configdat* (megatest.config info) +;; *runconfigdat* (runconfigs.config info) +;; *configstatus* (status of the read data) ;; -(define (launch:setup #!key (force #f)) - (let* ((runname (common:args-get-runname)) +(define (launch:setup-new #!key (force #f)) + (let* ((toppath (or *toppath* (getenv "MT_RUN_AREA_HOME"))) ;; preserve toppath + (runname (common:args-get-runname)) (target (common:args-get-target)) - (linktree (or (getenv "MT_LINKTREE") - (if *configdat* (configf:lookup *configdat* "setup" "linktree") #f))) + (linktree (common:get-linktree)) + (sections (if target (list "default" target) #f)) ;; for runconfigs + (mtconfig (or (args:get-arg "-config") "megatest.config")) ;; allow overriding megatest.config (rundir (if (and runname target linktree)(conc linktree "/" target "/" runname) #f)) (mtcachef (and rundir (conc rundir "/" ".megatest.cfg-" megatest-version "-" megatest-fossil-hash))) - (rccachef (and rundir (conc rundir "/" ".runconfigs.cfg-" megatest-version "-" megatest-fossil-hash)))) - #f)) + (rccachef (and rundir (conc rundir "/" ".runconfigs.cfg-" megatest-version "-" megatest-fossil-hash))) + (cancreate (and rundir (file-exists? rundir)(file-write-access? rundir)))) + ;; (print "runname: " runname " target: " target " mtcachef: " mtcachef " rccachef: " rccachef) + (set! *toppath* toppath) ;; This is needed when we are running as a test using CMDINFO as a datasource + (cond + ;; data was read and cached and available in *configstatus*, toppath has already been set + ((eq? *configstatus* 'fulldata) + *toppath*) + ;; if mtcachef exists just read it, however we need to assume toppath is available in $MT_RUN_AREA_HOME + ((and mtcachef (file-exists? mtcachef) (get-environment-variable "MT_RUN_AREA_HOME")) + (set! *configdat* (configf:read-alist mtcachef)) + (set! *runconfigdat* (configf:read-alist rccachef)) + (set! *configinfo* (list *configdat* (get-environment-variable "MT_RUN_AREA_HOME"))) + (set! *configstatus* 'fulldata) + (set! *toppath* (get-environment-variable "MT_RUN_AREA_HOME")) + *toppath*) + ;; we have all the info needed to fully process runconfigs and megatest.config + (mtcachef + (let* ((first-pass (find-and-read-config ;; NB// sets MT_RUN_AREA_HOME as side effect + mtconfig + environ-patt: "env-override" + given-toppath: toppath + pathenvvar: "MT_RUN_AREA_HOME")) + (first-rundat (let ((toppath (if toppath + toppath + (car first-pass)))) + (read-config (conc toppath "/runconfigs.config") *runconfigdat* #t + sections: sections)))) + (set! *runconfigdat* first-rundat) + (if first-pass ;; + (begin + (set! *configdat* (car first-pass)) + (set! *configinfo* first-pass) + (set! *toppath* (or toppath (cadr first-pass))) ;; use the gathered data unless already have it + (set! toppath *toppath*) + (setenv "MT_RUN_AREA_HOME" *toppath*) + ;; the seed read is done, now read runconfigs, cache it then read megatest.config one more time and cache it + (let* ((keys (rmt:get-keys)) + (key-vals (keys:target->keyval keys target)) + (linktree (or (getenv "MT_LINKTREE") + (if *configdat* (configf:lookup *configdat* "setup" "linktree") #f))) + (second-pass (find-and-read-config + mtconfig + environ-patt: "env-override" + given-toppath: toppath + pathenvvar: "MT_RUN_AREA_HOME")) + (runconfigdat (begin ;; this read of the runconfigs will see any adjustments made by re-reading megatest.config + (for-each (lambda (kt) + (setenv (car kt) (cadr kt))) + key-vals) + (read-config (conc toppath "/runconfigs.config") *runconfigdat* #t + sections: sections)))) + (if cancreate (configf:write-alist runconfigdat rccachef)) + (set! *runconfigdat* runconfigdat) + (if cancreate (configf:write-alist *configdat* mtcachef)) + (if cancreate (set! *configstatus* 'fulldata)))) + ;; no configs found? should not happen but let's try to recover gracefully, return an empty hash-table + (set! *configdat* (make-hash-table)) + ))) + ;; else read what you can and set the flag accordingly + (else + (let* ((cfgdat (find-and-read-config + (or (args:get-arg "-config") "megatest.config") + environ-patt: "env-override" + given-toppath: (get-environment-variable "MT_RUN_AREA_HOME") + pathenvvar: "MT_RUN_AREA_HOME"))) + (if cfgdat + (let* ((toppath (or (get-environment-variable "MT_RUN_AREA_HOME")(cadr cfgdat))) + (rdat (read-config (conc toppath + "/runconfigs.config") *runconfigdat* #t sections: sections))) + (set! *configinfo* cfgdat) + (set! *configdat* (car cfgdat)) + (set! *runconfigdat* rdat) + (set! *toppath* toppath) + (set! *configstatus* 'partial)) + (begin + (debug:print 0 "ERROR: No " mtconfig " file found. Giving up.") + (exit 2)))))) + ;; additional house keeping + (let* ((linktree (or (getenv "MT_LINKTREE") + (if *configdat* (configf:lookup *configdat* "setup" "linktree") #f)))) + (if linktree + (if (not (file-exists? linktree)) + (begin + (handle-exceptions + exn + (begin + (debug:print 0 "ERROR: Something went wrong when trying to create linktree dir at " linktree) + (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) + (exit 1)) + (create-directory linktree #t)))) + (begin + (debug:print 0 "ERROR: linktree not defined in [setup] section of megatest.config") + ;; (exit 1) + ))) + (if (and *toppath* + (directory-exists? *toppath*)) + (setenv "MT_RUN_AREA_HOME" *toppath*) + (begin + (debug:print 0 "ERROR: failed to find the top path to your Megatest area."))) + *toppath*)) + +(define launch:setup launch:setup-new) (define (get-best-disk confdat testconfig) (let* ((disks (or (and testconfig (hash-table-ref/default testconfig "disks" #f)) (hash-table-ref/default confdat "disks" #f))) (minspace (let ((m (configf:lookup confdat "setup" "minspace"))) Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -468,11 +468,11 @@ (begin (save-environment-as-files (args:get-arg "-env2file")) (set! *didsomething* #t))) (if (args:get-arg "-list-disks") - (let ((toppath (launch:setup-for-run))) + (let ((toppath (launch:setup))) (print (string-intersperse (map (lambda (x) (string-intersperse x @@ -720,11 +720,11 @@ (if (args:get-arg "-server") ;; Server? Start up here. ;; - (let ((tl (launch:setup-for-run)) + (let ((tl (launch:setup)) (run-id (and (args:get-arg "-run-id") (string->number (args:get-arg "-run-id"))))) (if run-id (begin (server:launch run-id) @@ -740,11 +740,11 @@ '("-list-servers" "-stop-server" "-show-cmdinfo" "-list-runs" "-ping"))) - (if (launch:setup-for-run) + (if (launch:setup) (let ((run-id (and (args:get-arg "-run-id") (string->number (args:get-arg "-run-id"))))) ;; (set! *fdb* (filedb:open-db (conc *toppath* "/db/paths.db"))) ;; if not list or kill then start a client (if appropriate) (if (or (args-defined? "-h" "-version" "-gen-megatest-area" "-gen-megatest-test") @@ -760,11 +760,11 @@ ;; MAY STILL NEED THIS ;; (set! *megatest-db* (make-dbr:dbstruct path: *toppath* local: #t)))))))))) (if (or (args:get-arg "-list-servers") (args:get-arg "-stop-server")) - (let ((tl (launch:setup-for-run))) + (let ((tl (launch:setup))) (if tl (let* ((tdbdat (tasks:open-db)) (servers (tasks:get-all-servers (db:delay-if-busy tdbdat))) (fmtstr "~5a~12a~8a~20a~24a~10a~10a~10a~10a\n") (servers-to-kill '()) @@ -830,10 +830,17 @@ (set! *didsomething* #t))) ;; cache the runconfigs in $MT_LINKTREE/$MT_TARGET/$MT_RUNNAME/.runconfig ;; (define (full-runconfigs-read) +;; in the envprocessing branch the below code replaces the further below code +;; (if (eq? *configstatus* 'fulldata) +;; *runconfigdat* +;; (begin +;; (launch:setup) +;; *runconfigdat*))) + (let* ((rundir (if (and (getenv "MT_LINKTREE")(getenv "MT_TARGET")(getenv "MT_RUNNAME")) (conc (getenv "MT_LINKTREE") "/" (getenv "MT_TARGET") "/" (getenv "MT_RUNNAME")) #f)) (cfgf (if rundir (conc rundir "/.runconfig." megatest-version "-" megatest-fossil-hash) #f))) (if (and cfgf @@ -855,16 +862,16 @@ (directory-exists? rundir) (file-write-access? rundir)) (begin (configf:write-alist data cfgf) ;; force re-read of megatest.config - this resolves circular references between megatest.config - (launch:setup-for-run force: #t) + (launch:setup force: #t) (launch:cache-config))) ;; we can safely cache megatest.config since we have a valid runconfig data)))) (if (args:get-arg "-show-runconfig") - (let ((tl (launch:setup-for-run))) + (let ((tl (launch:setup))) (push-directory *toppath*) (let ((data (full-runconfigs-read))) ;; keep this one local (cond ((and (args:get-arg "-section") @@ -882,11 +889,11 @@ (debug:print 0 "ERROR: -dumpmode of " (args:get-arg "-dumpmode") " not recognised"))) (set! *didsomething* #t)) (pop-directory))) (if (args:get-arg "-show-config") - (let ((tl (launch:setup-for-run)) + (let ((tl (launch:setup)) (data *configdat*)) ;; (read-config "megatest.config" #f #t))) (push-directory *toppath*) ;; keep this one local (cond ((and (args:get-arg "-section") @@ -1019,11 +1026,11 @@ ;; ;; IDEA: megatest list -runname blah% ... ;; (if (or (args:get-arg "-list-runs") (args:get-arg "-list-db-targets")) - (if (launch:setup-for-run) + (if (launch:setup) (let* (;; (dbstruct (make-dbr:dbstruct path: *toppath* local: (args:get-arg "-local"))) (runpatt (args:get-arg "-list-runs")) (testpatt (common:args-get-testpatt #f)) ;; (if (args:get-arg "-testpatt") ;; (args:get-arg "-testpatt") @@ -1350,11 +1357,11 @@ (set! *didsomething* #t)))) ;; Don't think I need this. Incorporated into -list-runs instead ;; ;; (if (and (args:get-arg "-since") -;; (launch:setup-for-run)) +;; (launch:setup)) ;; (let* ((since-time (string->number (args:get-arg "-since"))) ;; (run-ids (db:get-changed-run-ids since-time))) ;; ;; (rmt:get-tests-for-runs-mindata run-ids testpatt states status not-in) ;; (print (sort run-ids <)) ;; (set! *didsomething* #t))) @@ -1508,11 +1515,11 @@ (change-directory toppath) (if (not target) (begin (debug:print 0 "ERROR: -target is required.") (exit 1))) - (if (not (launch:setup-for-run)) + (if (not (launch:setup)) (begin (debug:print 0 "Failed to setup, giving up on -test-paths or -test-files, exiting") (exit 1))) (let* ((keys (rmt:get-keys)) ;; db:test-get-paths must not be run remote @@ -1614,11 +1621,11 @@ (test-id (assoc/default 'test-id cmdinfo)) (itemdat (assoc/default 'itemdat cmdinfo)) (work-area (assoc/default 'work-area cmdinfo)) (db #f)) (change-directory testpath) - (if (not (launch:setup-for-run)) + (if (not (launch:setup)) (begin (debug:print 0 "Failed to setup, exiting") (exit 1))) (if (and state status) (rmt:teststep-set-status! run-id test-id step state status msg logfile) @@ -1662,11 +1669,11 @@ (itemdat (assoc/default 'itemdat cmdinfo)) (work-area (assoc/default 'work-area cmdinfo)) (db #f) ;; (open-db)) (state (args:get-arg ":state")) (status (args:get-arg ":status"))) - (if (not (launch:setup-for-run)) + (if (not (launch:setup)) (begin (debug:print 0 "Failed to setup, exiting") (exit 1))) (if (args:get-arg "-runstep")(debug:print-info 1 "Running -runstep, first change to directory " work-area)) @@ -1767,11 +1774,11 @@ (if (or (args:get-arg "-showkeys") (args:get-arg "-show-keys")) (let ((db #f) (keys #f)) - (if (not (launch:setup-for-run)) + (if (not (launch:setup)) (begin (debug:print 0 "Failed to setup, exiting") (exit 1))) (set! keys (rmt:get-keys)) ;; db)) (debug:print 1 "Keys: " (string-intersperse keys ", ")) @@ -1798,21 +1805,21 @@ ;; Update the database schema, clean up the db ;;====================================================================== (if (args:get-arg "-rebuild-db") (begin - (if (not (launch:setup-for-run)) + (if (not (launch:setup)) (begin (debug:print 0 "Failed to setup, exiting") (exit 1))) ;; keep this one local (open-run-close patch-db #f) (set! *didsomething* #t))) (if (args:get-arg "-cleanup-db") (begin - (if (not (launch:setup-for-run)) + (if (not (launch:setup)) (begin (debug:print 0 "Failed to setup, exiting") (exit 1))) ;; keep this one local ;; (open-run-close db:clean-up #f) @@ -1827,11 +1834,11 @@ ) (set! *didsomething* #t))) (if (args:get-arg "-mark-incompletes") (begin - (if (not (launch:setup-for-run)) + (if (not (launch:setup)) (begin (debug:print 0 "Failed to setup, exiting") b (exit 1))) (open-run-close db:find-and-mark-incomplete #f) (set! *didsomething* #t))) @@ -1840,11 +1847,11 @@ ;; Update the tests meta data from the testconfig files ;;====================================================================== (if (args:get-arg "-update-meta") (begin - (if (not (launch:setup-for-run)) + (if (not (launch:setup)) (begin (debug:print 0 "Failed to setup, exiting") (exit 1))) ;; now can find our db ;; keep this one local @@ -1855,44 +1862,59 @@ ;; Start a repl ;;====================================================================== ;; fakeout readline -(if (or (args:get-arg "-repl") +(if (or (getenv "MT_RUNSCRIPT") + (args:get-arg "-repl") (args:get-arg "-load")) - (let* ((toppath (launch:setup-for-run)) + (let* ((toppath (launch:setup)) (dbstruct (if toppath (make-dbr:dbstruct path: toppath local: (args:get-arg "-local")) #f))) (if dbstruct - (begin - (set! *db* dbstruct) - (set! *client-non-blocking-mode* #t) - (import extras) ;; might not be needed - ;; (import csi) - (import readline) - (import apropos) - ;; (import (prefix sqlite3 sqlite3:)) ;; doesn't work ... - (include "readline-fix.scm") - (gnu-history-install-file-manager - (string-append - (or (get-environment-variable "HOME") ".") "/.megatest_history")) - (current-input-port (make-gnu-readline-port "megatest> ")) - (if (args:get-arg "-repl") - (repl) - (load (args:get-arg "-load"))) - (db:close-all dbstruct)) - (exit)) - (set! *didsomething* #t))) + (cond + ((getenv "MT_RUNSCRIPT") + ;; How to run megatest scripts + ;; + ;; #!/bin/bash + ;; + ;; export MT_RUNSCRIPT=yes + ;; megatest << EOF + ;; (print "Hello world") + ;; (exit) + ;; EOF + + (repl)) + (else + (begin + (set! *db* dbstruct) + (set! *client-non-blocking-mode* #t) + (import extras) ;; might not be needed + ;; (import csi) + (import readline) + (import apropos) + ;; (import (prefix sqlite3 sqlite3:)) ;; doesn't work ... + (include "readline-fix.scm") + (gnu-history-install-file-manager + (string-append + (or (get-environment-variable "HOME") ".") "/.megatest_history")) + (current-input-port (make-gnu-readline-port "megatest> ")) + (if (args:get-arg "-repl") + (repl) + (load (args:get-arg "-load"))) + (db:close-all dbstruct)) + (exit))) + (set! *didsomething* #t)))) ;;====================================================================== ;; Wait on a run to complete ;;====================================================================== (if (and (args:get-arg "-run-wait") (not (or (args:get-arg "-run") (args:get-arg "-runtests")))) ;; run-wait is built into runtests now (begin - (if (not (launch:setup-for-run)) + (if (not (launch:setup)) (begin (debug:print 0 "Failed to setup, exiting") (exit 1))) (operate-on 'run-wait) (set! *didsomething* #t))) Index: newdashboard.scm ================================================================== --- newdashboard.scm +++ newdashboard.scm @@ -67,11 +67,11 @@ (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))) ;; (if (args:get-arg "-host") Index: process.scm ================================================================== --- process.scm +++ process.scm @@ -147,11 +147,27 @@ ;; possibly pid is a process not a child, look in /proc to see if it is running still (file-exists? (conc "/proc/" pid)) (let-values (((rpid exit-type exit-signal)(process-wait pid #t))) (and (number? rpid) (equal? rpid pid))))) - + +(define (process:alive-on-host? host pid) + (let ((cmd (conc "ssh " host " ps -o pid= -p " pid))) + (handle-exceptions + exn + #f ;; anything goes wrong - assume the process in NOT running. + (with-input-from-pipe + cmd + (lambda () + (let loop ((inl (read-line))) + (if (eof-object? inl) + #f + (let* ((clean-str (string-substitute "^[^\\d]*([0-9]+)[^\\d]*$" "\\1" inl)) + (innum (string->number clean-str))) + (and innum + (eq? pid innum)))))))))) + (define (process:get-sub-pids pid) (with-input-from-pipe (conc "pstree -A -p " pid) ;; | tr 'a-z\\-+`()\\.' ' ' " pid) (lambda () (let loop ((inl (read-line)) Index: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -40,11 +40,11 @@ ;; NOT YET UTILIZED ;; (define (runs:create-run-record) (let* ((mconfig (if *configdat* *configdat* - (if (launch:setup-for-run) + (if (launch:setup) *configdat* (begin (debug:print 0 "ERROR: Called setup in a non-megatest area, exiting") (exit 1))))) (runrec (runs:runrec-make-record)) @@ -73,18 +73,25 @@ (set! envdat (append envdat (list (list "MT_RUN_AREA_HOME" toppath) (list "MT_RUNNAME" runname) (list "MT_TARGET" target)))) - ;; Now can read the runconfigs file + + ;; Now can read the runconfigs file -- can replace this with call to launch:setup? + ;; + ;; This block should be ok to remove - just keep the set of runconfig ;; - (set! runconfig (read-config (conc *toppath* "/runconfigs.config") #f #t sections: (list "default" target))) - (if (not (hash-table-ref/default runconfig (args:get-arg "-reqtarg") #f)) + (if (not (eq? *configstatus* 'fulldata)) (begin - (debug:print 0 "ERROR: [" (args:get-arg "-reqtarg") "] not found in " runconfigf) - (if db (sqlite3:finalize! db)) - (exit 1))) + (debug:print 0 "Processing runconfigs.config again...") + (set! runconfig (read-config (conc *toppath* "/runconfigs.config") #f #t sections: (list "default" target))) + (if (not (hash-table-ref/default runconfig (args:get-arg "-reqtarg") #f)) + (begin + (debug:print 0 "ERROR: [" (args:get-arg "-reqtarg") "] not found in " runconfigf) + (if db (sqlite3:finalize! db)) + (exit 1)))) + (set! runconfig *runconfigdat*)) ;; Now have runconfigs data loaded, set environment vars ;; Only now can we calculate the testpatt (set! testpatt (common:args-get-testpatt runconfig)) @@ -226,11 +233,11 @@ ;; test-names: Comma separated patterns same as test-patts but used in selection ;; of tests to run. The item portions are not respected. ;; FIXME: error out if /patt specified ;; -(define (runs:run-tests target runname test-patts user flags #!key (run-count 3)) ;; test-names +(define (runs:run-tests target runname test-patts user flags #!key (run-count 1)) ;; test-names (let* ((keys (keys:config-get-fields *configdat*)) (keyvals (keys:target->keyval keys target)) (run-id (rmt:register-run keyvals runname "new" "n/a" user)) ;; test-name))) (deferred '()) ;; delay running these since they have a waiton clause (runconfigf (conc *toppath* "/runconfigs.config")) @@ -1780,11 +1787,11 @@ (debug:print 0 "ERROR: Missing required parameter for " switchname ", you must specify the run name with -runname runname") (exit 3)) (else (let (;; (db #f) (keys #f)) - (if (launch:setup-for-run) + (if (launch:setup) (begin (full-runconfigs-read) ;; cache the run config (launch:cache-config)) ;; do not cache here - need to be sure runconfigs is processed (begin (debug:print 0 "Failed to setup, exiting") Index: server.scm ================================================================== --- server.scm +++ server.scm @@ -207,11 +207,11 @@ (let ((tdbdat (tasks:open-db))) (let* ((host-port (let ((slst (string-split host:port ":"))) (if (eq? (length slst) 2) (list (car slst)(string->number (cadr slst))) #f))) - (toppath (launch:setup-for-run)) + (toppath (launch:setup)) (server-db-dat (if (not host-port)(tasks:get-server (db:delay-if-busy tdbdat) run-id) #f))) (if (not run-id) (begin (debug:print 0 "ERROR: must specify run-id when doing ping, -run-id n") (print "ERROR: No run-id") Index: tests.scm ================================================================== --- tests.scm +++ tests.scm @@ -735,45 +735,56 @@ (getenv "MT_TEST_NAME") "/" (if (or (getenv "MT_ITEMPATH") (not (string=? "" (getenv "MT_ITEMPATH")))) (conc "/" (getenv "MT_ITEMPATH")))))) +;; if .testconfig exists in test directory read and return it +;; else if have cached copy in *testconfigs* return it IFF there is a section "have fulldata" +;; else read the testconfig file +;; if have path to test directory save the config as .testconfig and return it +;; (define (tests:get-testconfig test-name test-registry system-allowed #!key (force-create #f)) - (let* ((treg (or test-registry - (tests:get-all))) - (test-path (hash-table-ref/default - treg test-name - (conc *toppath* "/tests/" test-name))) - (test-configf (conc test-path "/testconfig")) - (testexists (and (file-exists? test-configf)(file-read-access? test-configf))) - (cache-path (tests:get-test-path-from-environment)) - (cache-exists (and cache-path + (let* ((cache-path (tests:get-test-path-from-environment)) + (cache-file (and cache-path (conc cache-path "/.testconfig"))) + (cache-exists (and cache-file (not force-create) ;; if force-create then pretend there is no cache to read - (file-exists? (conc cache-path "/.testconfig")))) - (cache-file (conc cache-path "/.testconfig")) - (tcfg (if testexists - (or (and (not force-create) - cache-exists - (handle-exceptions - exn - (begin - (debug:print 0 "WARNING: Failed to read " cache-file) - (make-hash-table)) ;; better to return a hash and keep going - I think - (configf:read-alist cache-file))) - (read-config test-configf #f system-allowed environ-patt: (if system-allowed - "pre-launch-env-vars" - #f))) - #f))) - (hash-table-set! *testconfigs* test-name tcfg) - (if (and testexists - cache-path - (not cache-exists) - (file-write-access? cache-path)) - (let ((tpath (conc cache-path "/.testconfig"))) - (debug:print-info 1 "Caching testconfig for " test-name " in " tpath) - (configf:write-alist tcfg tpath))) - tcfg)) + (file-exists? cache-file))) + (cached-dat (if (and (not force-create) + cache-exists) + (handle-exceptions + exn + #f ;; any issues, just give up with the cached version and re-read + (configf:read-alist cache-file)) + #f))) + (if cached-dat + cached-dat + (let ((dat (hash-table-ref/default *testconfigs* test-name #f))) + (if (and dat ;; have a locally cached version + (hash-table-ref/default dat "have fulldata" #f)) ;; marked as good data? + dat + ;; no cached data available + (let* ((treg (or test-registry + (tests:get-all))) + (test-path (or (hash-table-ref/default treg test-name #f) + (conc *toppath* "/tests/" test-name))) + (test-configf (conc test-path "/testconfig")) + (testexists (and (file-exists? test-configf)(file-read-access? test-configf))) + (tcfg (if testexists + (read-config test-configf #f system-allowed + environ-patt: (if system-allowed + "pre-launch-env-vars" + #f)) + #f))) + (if cache-file (hash-table-set! tcfg "have fulldata" #t)) ;; mark this as fully read data + (if tcfg (hash-table-set! *testconfigs* test-name tcfg)) + (if (and testexists + cache-file + (file-write-access? cache-path)) + (let ((tpath (conc cache-path "/.testconfig"))) + (debug:print-info 1 "Caching testconfig for " test-name " in " tpath) + (configf:write-alist tcfg tpath))) + tcfg)))))) ;; sort tests by priority and waiton ;; Move test specific stuff to a test unit FIXME one of these days (define (tests:sort-by-priority-and-waiton test-records) (let* ((mungepriority (lambda (priority) @@ -849,10 +860,11 @@ (let-values (((fd temp-path) (file-mkstemp (conc "/tmp/" (current-user-name) ".XXXXXX")))) (let ((all-testnames (hash-table-keys test-records)) (temp-port (open-output-file* fd))) ;; (format temp-port "This file is ~A.~%" temp-path) (format temp-port "digraph tests {\n") + (format temp-port " size=4,8\n") ;; (format temp-port " splines=none\n") (for-each (lambda (testname) (let* ((testrec (hash-table-ref test-records testname)) (waitons (or (tests:testqueue-get-waitons testrec) '()))) @@ -880,11 +892,13 @@ (let ((all-testnames (hash-table-keys test-records))) (if (null? all-testnames) '() (let loop ((hed (car all-testnames)) (tal (cdr all-testnames)) - (res (list "digraph tests {"))) + (res (list "digraph tests {" + " size=\"11,11\";" + " ratio=0.9;"))) (let* ((testrec (hash-table-ref test-records hed)) (waitons (or (tests:testqueue-get-waitons testrec) '())) (newres (append res (if (null? waitons) (list (conc " \"" hed "\";")) Index: tests/fullrun/configs/mt_include_2.config ================================================================== --- tests/fullrun/configs/mt_include_2.config +++ tests/fullrun/configs/mt_include_2.config @@ -1,2 +1,2 @@ [disks] -disk0 #{getenv MT_RUN_AREA_HOME}/tmp/mt_runs +disk0 #{scheme (create-directory "#{getenv MT_RUN_AREA_HOME}/tmp/mt_runs" #t)} Index: tests/fullrun/megatest.config ================================================================== --- tests/fullrun/megatest.config +++ tests/fullrun/megatest.config @@ -94,13 +94,10 @@ # (nb// this is in addition to NOT_STARTED which is automatically re-run) # allow-auto-rerun INCOMPLETE ZERO_ITEMS # could add: STUCK STUCK/DEAD UNKNOWN KILLED KILLREQ PREQ_DISCARD -# Try this -reruns 0 - [validvalues] state start end 0 1 - 2 status pass fail n/a 0 1 running - 2 # These are set before all tests, override them Index: tests/fullrun/runconfigs.config ================================================================== --- tests/fullrun/runconfigs.config +++ tests/fullrun/runconfigs.config @@ -1,7 +1,9 @@ [default] SOMEVAR This should show up in SOMEVAR3 +VARNOVAL +VARNOVAL_WITHSPACE # target based getting of config file, look at afs.config and nfs.config [include #{getenv fsname}.config] [include #{getenv MT_RUN_AREA_HOME}/common_runconfigs.config] Index: tests/fullrun/tests/all_toplevel/testconfig ================================================================== --- tests/fullrun/tests/all_toplevel/testconfig +++ tests/fullrun/tests/all_toplevel/testconfig @@ -1,7 +1,12 @@ [ezsteps] calcresults megatest -list-runs $MT_RUNNAME -target $MT_TARGET +check_triggers cat $MT_RUN_AREA_HOME/triggers_$MT_RUN_NAME.dat + +[logpro] +check_triggers ;; + (expect:error in "LogFileBody" = 0 "No errors" #/error/i) [requirements] waiton #{getenv ALL_TOPLEVEL_TESTS} # This is a "toplevel" test, it does not require waitons to be non-FAIL to run Index: tests/fullrun/tests/exit_0/testconfig ================================================================== --- tests/fullrun/tests/exit_0/testconfig +++ tests/fullrun/tests/exit_0/testconfig @@ -8,8 +8,10 @@ tags first,single reviewed 09/10/2011, by Matt [triggers] -NOT_STARTED/ xterm -e bash -s -- -RUNNING/ xterm -e bash -s -- +# NOT_STARTED/ xterm -e bash -s -- +NOT_STARTED/ echo "trigger: exit_0, NOT_STARTED/" > $MT_RUN_AREA_HOME/triggers_$MT_RUN_NAME.dat +RUNNING/ echo "trigger: exit_0, RUNNING/" >> $MT_RUN_AREA_HOME/triggers_$MT_RUN_NAME.dat + Index: tests/fullrun/tests/ez_fail_quick/testconfig ================================================================== --- tests/fullrun/tests/ez_fail_quick/testconfig +++ tests/fullrun/tests/ez_fail_quick/testconfig @@ -5,11 +5,11 @@ # should fail on next step lookitnada ls /nada [triggers] # run like this: cmd test-id test-rundir trigger -COMPLETED/FAIL xterm;echo +COMPLETED/FAIL echo "trigger: ez_fail_quick, COMPLETED/FAIL" >> $MT_RUN_AREA_HOME/triggers_$MT_RUN_NAME.dat [test_meta] author matt owner bob description This test runs a single ezstep which fails immediately. Index: tests/fullrun/tests/priority_1/testconfig ================================================================== --- tests/fullrun/tests/priority_1/testconfig +++ tests/fullrun/tests/priority_1/testconfig @@ -12,6 +12,6 @@ tags first,single reviewed 09/10/2011, by Matt [triggers] -COMPLETED/ echo $MT_TEST_NAME > $MT_RUN_AREA_HOME/foo +COMPLETED/ echo "trigger: priority_1, COMPLETED/" >> $MT_RUN_AREA_HOME/triggers_$MT_RUN_NAME.dat Index: tests/fullrun/tests/test_mt_vars/testconfig ================================================================== --- tests/fullrun/tests/test_mt_vars/testconfig +++ tests/fullrun/tests/test_mt_vars/testconfig @@ -22,17 +22,35 @@ test-path test-path-file.sh # verify that vars with $ signs get expanded varwithdollar eval_vars.sh +emptyvars bash -c 'if [[ $VARNOVAL == "" ]];then echo HAVE_VARNOVAL;else echo "ERROR: VARNOVAL not found";fi' +emptyvar_withspace bash -c 'if [[ $VARNOVAL_WITHSPACE == "" ]];then echo HAVE_VARNOVAL_WITHSPACE;else echo "ERROR: VARNOVAL_WITHSPACE not found";fi' +emptyvar_megatest.sh egrep VARNO megatest.sh + [requirements] waiton runfirst priority 0 [items] NUMNUM [system cat $MT_RUN_AREA_HOME/tmp/$USER/$sysname/$fsname/$datapath/$MT_RUNNAME/$PREDICTABLE] +[logpro] +emptyvars ;; + (expect:error in "LogFileBody" = 0 "VARNOVAL not found" #/ERROR: VARNOVAL not found/) + (expect:required in "LogFileBody" = 1 "HAVE_VARNOVAL" #/HAVE_VARNOVAL/) + +emptyvar_withspace ;; + (expect:error in "LogFileBody" = 0 "VARNOVAL_WITHSPACE not found" #/ERROR: VARNOVAL_WITHSPACE not found/) + (expect:required in "LogFileBody" = 1 "HAVE_VARNOVAL_WITHSPACE" #/HAVE_VARNOVAL_WITHSPACE/) + +emptyvar_megatest.sh ;; + (expect:error in "LogFileBody" = 0 "No errors expected" #/ERR/i) + (expect:required in "LogFileBody" = 1 "VARNOVAL_WITHSPACE" #/VARNOVAL_WITHSPACE/) + (expect:required in "LogFileBody" = 1 "VARNOVAL" #/VARNOVAL/) + [test_meta] author matt owner bob description This test runs a single ezstep which is expected to pass, no logpro file.