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,35 +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"))) + (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 *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 @@ -708,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)) @@ -720,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)) @@ -733,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) (import (prefix sqlite3 sqlite3:)) (declare (uses common)) (declare (uses margs)) (declare (uses keys)) @@ -81,59 +81,62 @@ (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 + dbdir dblocal dbfpath + keys dbkeys header + allruns useserver ro + allruns-by-id buttondat searchpatts + numruns tot-runs + last-db-update + please-update ) + +(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)) + +(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* "%")) +(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*) "%"))) ;; 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* '()) @@ -239,16 +242,17 @@ test1-older) (if same-time (string>? test-name1 test-name2) test1-older)))) +;; 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* + (allruns (if (d:alldat-useserver *alldat*) (rmt:get-runs runnamepatt numruns *start-run-offset* keypatts) - (db:get-runs *dbstruct-local* runnamepatt numruns ;; (+ numruns 1) ;; (/ numruns 2)) + (db:get-runs (d:alldat-dblocal *alldat*) runnamepatt numruns ;; (+ numruns 1) ;; (/ numruns 2)) *start-run-offset* keypatts))) (header (db:get-header allruns)) (runs (db:get-rows allruns)) (result '()) (maxtests 0) @@ -263,26 +267,26 @@ ;; ;; 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* 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* sort-by sort-order 'shortlist @@ -305,21 +309,17 @@ (if (> (length tests) maxtests) (set! maxtests (length tests))) (if (or (not *hide-empty-runs*) ;; 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) @@ -460,13 +460,13 @@ (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* '()) @@ -493,17 +493,17 @@ (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) @@ -518,11 +518,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) @@ -563,12 +563,12 @@ (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*))))) + (not (equal? (hash-table-ref (d:alldat-searchpatts *alldat*) key) "%"))) + (hash-table-keys (d:alldat-searchpatts *alldat*)))))) (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" (if (or search-changed state-changed @@ -576,15 +576,15 @@ "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) + (d:alldat-last-db-update-set! *alldat* 0) (set! *delayed-update* 1)) ;;====================================================================== ;; R U N C O N T R O L ;;====================================================================== @@ -631,13 +631,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 @@ -798,11 +798,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 @@ -867,13 +867,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")) @@ -1125,27 +1125,27 @@ (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 "&"))) (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))) + (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 (dboard:data-get-curr-run-id *data*)) (tests-dat (let ((tdat (if run-id - (if *useserver* + (if (d:alldat-useserver *alldat*) (rmt:get-tests-for-run run-id - (hash-table-ref/default *searchpatts* "test-name" "%/%") + (hash-table-ref/default (d:alldat-searchpatts *alldat*) "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-ref/default (d:alldat-searchpatts *alldat*) "test-name" "%/%") (hash-table-keys *state-ignore-hash*) ;; '() (hash-table-keys *status-ignore-hash*) ;; '() #f #f *hide-not-hide* #f #f @@ -1186,11 +1186,11 @@ ;; (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)) @@ -1326,11 +1326,11 @@ (mark-for-update))))) (set! *hide-not-hide-button* hideit) 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"))) @@ -1370,17 +1370,17 @@ (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*)) + (maxruns (d:alldat-tot-runs *alldat*))) (set! *start-run-offset* val) (mark-for-update) (debug:print 6 "*start-run-offset* " *start-run-offset* " 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)))) ) @@ -1408,11 +1408,11 @@ (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) + (d:alldat-please-update-set! *alldat* #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) (if (< val 10) (iup:attribute-set! obj "MAX" newmax)) )) @@ -1467,17 +1467,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 @@ -1492,11 +1492,11 @@ (apply iup:hbox (reverse hdrlst)) (apply iup:hbox (reverse bdylst)))))) controls)) (tabs (iup:tabs #:tabchangepos-cb (lambda (obj curr prev) - (set! *please-update-buttons* #t) + (d:alldat-please-update-set! *alldat* #t) (set! *current-tab-number* curr)) (dashboard:summary db) runs-view (dashboard:one-run db) (dashboard:run-controls) @@ -1514,36 +1514,36 @@ (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))) + (update-rundat "%" (d:alldat-numruns *alldat*) "%/%" '())) + (set! *num-tests* (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) @@ -1553,19 +1553,19 @@ (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*))) + (recalc (dashboard:recalc modtime (d:alldat-please-update *alldat*) (d:alldat-last-db-update *alldat*)))) (if (and (eq? *current-tab-number* 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) @@ -1574,29 +1574,29 @@ (begin (case *current-tab-number* ((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*) *num-tests*)) ((2) (dashboard:update-run-summary-tab)) (else (let ((updater (hash-table-ref/default *updaters* *current-tab-number* #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-update* run-update-time) (set! *last-recalc-ended-time* (current-milliseconds)))))) ;;====================================================================== ;; The heavy lifting starts here ;;====================================================================== @@ -1611,11 +1611,11 @@ (let ((runid (string->number (args:get-arg "-run")))) (if runid (begin (lambda (x) (on-exit std-exit-procedure) - (examine-run *dbstruct-local* runid))) + (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") ",")))) @@ -1630,13 +1630,13 @@ (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*)) + (gui-monitor (d:alldat-dblocal *alldat*))) (else - (set! uidat (make-dashboard-buttons *dbstruct-local* *num-runs* *num-tests* *dbkeys*)) + (set! uidat (make-dashboard-buttons (d:alldat-dblocal *alldat*) (d:alldat-numruns *alldat*) *num-tests* (d:alldat-dbkeys *alldat*))) (iup:callback-set! *tim* "ACTION_CB" (lambda (x) (let ((update-is-running #f)) (mutex-lock! *update-mutex*) @@ -1652,11 +1652,11 @@ (mutex-unlock! *update-mutex*)))) 1)))) (let ((th1 (make-thread (lambda () (thread-sleep! 1) - (set! *please-update-buttons* #t) + (d:alldat-please-update-set! *alldat* #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* @@ -1671,6 +1671,6 @@ (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*) +;; (iup:main-loop)(db:close-all (d:alldat-dblocal *alldat*)) 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: docs/manual/Makefile ================================================================== --- docs/manual/Makefile +++ docs/manual/Makefile @@ -1,8 +1,8 @@ ASCPATH = $(shell which asciidoc) -EXEPATH = $(shell realpath $(ASCPATH)) +EXEPATH = $(shell readlink -f $(ASCPATH)) BINPATH = $(shell dirname $(EXEPATH)) DISPATH = $(shell dirname $(BINPATH)) # broad_goals.csv needed_features.csv : tables/*.dat # ./refdb2csv tables Index: docs/manual/megatest_manual.html ================================================================== --- docs/manual/megatest_manual.html +++ docs/manual/megatest_manual.html @@ -1177,17 +1177,15 @@

Requirements section

-
-

Header

+
Header
[requirements]
-

Wait on Other Tests

# A normal waiton waits for the prior tests to be COMPLETED
@@ -1218,10 +1216,25 @@
 

 
[requirements]
 mode itemmatch
+
+
+

Overriding Enviroment Variables

+

Override variables before starting the test. Can include files (perhaps generated by megatest -envdelta or similar).

+
+
+
[pre-launch-env-vars]
+VAR1 value1
+
+# Get some generated settings
+[include ../generated-vars.config]
+
+# Use this trick to unset variables
+#{scheme (unsetenv "FOOBAR")}
+

Itemmap Handling

For cases were the dependent test has a similar but not identical itempath to the downstream test an itemmap can allow for itemmatch @@ -1291,11 +1304,11 @@ 

[requirements]
 waiton A B
 
 [itemmap]
 A (\d+)/aa aa/\1
-B (\d+)/bb bb/\1
+B (\d+)/bb
Testconfig for Test D
[requirements]
@@ -1317,18 +1330,19 @@
 

 
[requirements]
 # With a toplevel test you may wish to generate your list
 # of tests to run dynamically
 #
-# waiton #{shell get-valid-tests-to-run.sh}

+waiton #{shell get-valid-tests-to-run.sh}

Run time limit

-
runtimelim 1h 2m 3s  # this will automatically kill the test if it runs for more than 1h 2m and 3s
+
[requirements]
+runtimelim 1h 2m 3s  # this will automatically kill the test if it runs for more than 1h 2m and 3s

Skip

A test with a skip section will conditional skip running.

@@ -1485,10 +1499,53 @@ # <testsuite>/<creationdate> # Within the archive the data is structured like this: # <target>/<runname>/<test>/ archive0 /mfs/myarchive-data/adisk1
+ + +
+

Handling Environment Variables

+
+

It is often necessary to capture and or manipulate environment +variables. Megatest has some facilities built in to help.

+
+

Capture variables

+
+
Commands
+
+
# capture the current enviroment into a db called envdat.db under
+# the context "before"
+megatest -envcap before
+
+# capture the current environment into a db called startup.db with
+# context "after"
+megatest -envcap after startup.db
+
+# write the diff from before to after
+megatest -envdelta before-after -dumpmode bash
+
+

Dump modes include bash, csh and config. You can include config data +into megatest.config or runconfigs.config.

+
+
Example of generating and using config data
+
+
megatest -envcap original
+# do some stuff here
+megatest -envcap munged
+megatest -envdelta original-munged -dumpmode ini -o modified.config
+
+

Then in runconfigs.config

+
+
Example of using modified.config in a testconfig
+
+
cat testconfig
+
+[pre-launch-env-vars]
+[include modified.config]
+
+

Programming API

@@ -1656,11 +1713,10 @@
Index: docs/manual/reference.txt ================================================================== --- docs/manual/reference.txt +++ docs/manual/reference.txt @@ -89,13 +89,11 @@ ------------------- Requirements section ~~~~~~~~~~~~~~~~~~~~ -Header -^^^^^^ - +.Header ------------------- [requirements] ------------------- Wait on Other Tests @@ -132,10 +130,26 @@ ------------------- [requirements] mode itemmatch ------------------- + +Overriding Enviroment Variables +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Override variables before starting the test. Can include files (perhaps generated by megatest -envdelta or similar). + +-------------------- +[pre-launch-env-vars] +VAR1 value1 + +# Get some generated settings +[include ../generated-vars.config] + +# Use this trick to unset variables +#{scheme (unsetenv "FOOBAR")} +-------------------- Itemmap Handling ~~~~~~~~~~~~~~~~ For cases were the dependent test has a similar but not identical @@ -186,11 +200,12 @@ [requirements] waiton A B [itemmap] A (\d+)/aa aa/\1 -B (\d+)/bb -------------------- +B (\d+)/bb +---------------------- .Testconfig for Test D ---------------------- [requirements] waiton C @@ -384,10 +399,54 @@ # / # Within the archive the data is structured like this: # /// archive0 /mfs/myarchive-data/adisk1 -------------- + +Handling Environment Variables +------------------------------ + +It is often necessary to capture and or manipulate environment +variables. Megatest has some facilities built in to help. + +Capture variables +~~~~~~~~~~~~~~~~~ + +.Commands +------------------------------ +# capture the current enviroment into a db called envdat.db under +# the context "before" +megatest -envcap before + +# capture the current environment into a db called startup.db with +# context "after" +megatest -envcap after startup.db + +# write the diff from before to after +megatest -envdelta before-after -dumpmode bash +------------------------------ + +Dump modes include bash, csh and config. You can include config data +into megatest.config or runconfigs.config. + +.Example of generating and using config data +------------------------------ +megatest -envcap original +# do some stuff here +megatest -envcap munged +megatest -envdelta original-munged -dumpmode ini -o modified.config +------------------------------ + +Then in runconfigs.config + +.Example of using modified.config in a testconfig +------------------------------ +cat testconfig + +[pre-launch-env-vars] +[include modified.config] +------------------------------ Programming API --------------- These routines can be called from the megatest repl. Index: docs/manual/server.png ================================================================== --- docs/manual/server.png +++ docs/manual/server.png cannot compute difference between binary files Index: env.scm ================================================================== --- env.scm +++ env.scm @@ -27,11 +27,11 @@ (set-busy-handler! db (busy-timeout 10000)) db)) ;; save vars in given context, this is NOT incremental by default ;; -(define (env:save-env-vars db context #!key (incremental #f)) +(define (env:save-env-vars db context #!key (incremental #f)(vardat #f)) (with-transaction db (lambda () ;; first clear out any vars for this context (if (not incremental)(exec (sql db "DELETE FROM envvars WHERE context=?") context)) @@ -39,40 +39,83 @@ (lambda (varval) (let ((var (car varval)) (val (cdr varval))) (if incremental (exec (sql db "DELETE FROM envvars WHERE context=? AND var=?") context var)) (exec (sql db "INSERT INTO envvars (context,var,val) VALUES (?,?,?)") context var val))) - (get-environment-variables))))) + (if vardat + (hash-table->alist vardat) + (get-environment-variables)))))) -;; apply contexts to current environment +;; merge contexts in the order given ;; - each context is applied in the given order ;; - variables in the paths list are split on the separator and the components ;; merged using simple delta addition +;; returns a hash of the merged vars +;; +(define (env:merge-contexts db basecontext contexts paths) + (let ((result (make-hash-table))) + (for-each + (lambda (context) + (query + (for-each-row + (lambda (row) + (let ((var (car row)) + (val (cadr row))) + (hash-table-set! result var + (if (and (hash-table-ref/default results var #f) + (assoc var paths)) ;; this var is a path and there is a previous path + (let ((sep (cadr (assoc var paths)))) + (env:merge-path-envvar sep (hash-table-ref results var) valb)) + valb))))) + (sql db "SELECT var,val FROM envvars WHERE context=?") + context)) + contexts) + result)) + +;; get list of removed variables between two contexts +;; +(define (env:get-removed db contexta contextb) + (let ((result (make-hash-table))) + (query + (for-each-row + (lambda (row) + (let ((var (car row)) + (val (cadr row))) + (hash-table-set! result var val)))) + (sql db "SELECT var,val FROM envvars WHERE context=? AND var NOT IN (SELECT var FROM envvars WHERE context=?)") + contexta contextb) + result)) + +;; get list of variables added to contextb from contexta +;; +(define (env:get-added db contexta contextb) + (let ((result (make-hash-table))) + (query + (for-each-row + (lambda (row) + (let ((var (car row)) + (val (cadr row))) + (hash-table-set! result var val)))) + (sql db "SELECT var,val FROM envvars WHERE context=? AND var NOT IN (SELECT var FROM envvars WHERE context=?)") + contextb contexta) + result)) + +;; get list of variables in both contexta and contexb that have been changed ;; -(define (env:apply-contexts db basecontext contexts paths outputf formats) - - (for-each - (lambda (context) - (query - (for-each-row - (lambda (row) - (let ((var (car row)) - (vala (cadr row)) - (valb (caddr row))) - ;;(print "var: " var " vala: " vala " valb" valb " paths: " paths) - (if (assoc var paths) ;; this var is a PATH - (let ((current (get-environment-variable var))) ;; use this NOT vala - ;;(pp paths) - ;;(pp var) - (env:process-path-envvar var (cadr (assoc var paths)) current valb)) - (begin - (setenv var valb)))))) - (sql db "SELECT b.var,a.val,b.val FROM envvars AS a JOIN envvars AS b ON a.var=b.var WHERE a.context=? AND b.context=? AND a.val != b.val") - ;;(sql db "SELECT b.var,a.val,b.val FROM envvars AS a JOIN envvars AS b ON a.var=b.var WHERE a.context=? AND b.context=?") - basecontext context)) - contexts)) - +(define (env:get-changed db contexta contextb) + (let ((result (make-hash-table))) + (query + (for-each-row + (lambda (row) + (let ((var (car row)) + (val (cadr row))) + (hash-table-set! result var val)))) + (sql db "SELECT var,val FROM envvars AS a WHERE context=? AND val != (SELECT val FROM envvars WHERE var=a.var AND context=?)") + contexta contextb) + result)) + +;; (define (env:blind-merge l1 l2) (if (null? l1) l2 (if (null? l2) l1 (cons (car l1) (cons (car l2) (env:blind-merge (cdr l1) (cdr l2))))))) @@ -88,13 +131,10 @@ ;; (print "AFTER: " (string-intersperse pathb-parts "\n ")) ;; (print "COMMON: " (string-intersperse common-parts "\n ")) (string-intersperse final separator))) (define (env:process-path-envvar varname separator patha pathb) - (begin - (print "Process-path-envvar: " varname) - ) (let ((newpath (env:merge-path-envvar separator patha pathb))) (setenv varname newpath))) (define (env:have-context db context) (> (query fetch-value (sql db "SELECT count(id) FROM envvars WHERE context=?") context) @@ -101,5 +141,71 @@ 0)) ;; this is so the calling block does not need to import sql-de-lite (define (env:close-database db) (close-database db)) + +(define (env:lazy-hash-table->alist indat) + (if (hash-table? indat) + (let ((dat (hash-table->alist indat))) + (if (null? dat) + #f + dat)) + #f)) + +(define (env:print added removed changed) + (let ((a (env:lazy-hash-table->alist added)) + (r (env:lazy-hash-table->alist removed)) + (c (env:lazy-hash-table->alist changed))) + (case (if (args:get-arg "-dumpmode") + (string->symbol (args:get-arg "-dumpmode")) + 'bash) + ((bash) + (if a + (begin + (print "# Added vars") + (map (lambda (dat)(print "export " (car dat) "=" (cdr dat))) + (hash-table->alist added)))) + (if r + (begin + (print "# Removed vars") + (map (lambda (dat)(print "unset " (car dat))) + (hash-table->alist removed)))) + (if c + (begin + (print "# Changed vars") + (map (lambda (dat)(print "export " (car dat) "=" (cdr dat))) + (hash-table->alist changed))))) + ((csh) + (if a + (begin + (print "# Added vars") + (map (lambda (dat)(print "setenv " (car dat) " " (cdr dat))) + (hash-table->alist added)))) + (if r + (begin + (print "# Removed vars") + (map (lambda (dat)(print "unsetenv " (car dat))) + (hash-table->alist removed)))) + (if c + (begin + (print "# Changed vars") + (map (lambda (dat)(print "setenv " (car dat) " " (cdr dat))) + (hash-table->alist changed))))) + ((config ini) + (if a + (begin + (print "# Added vars") + (map (lambda (dat)(print (car dat) " " (cdr dat))) + (hash-table->alist added)))) + (if r + (begin + (print "# Removed vars") + (map (lambda (dat)(print "#{scheme (unsetenv \"" (car dat) "\")}")) + (hash-table->alist removed)))) + (if c + (begin + (print "# Changed vars") + (map (lambda (dat)(print (car dat) " " (cdr dat))) + (hash-table->alist changed))))) + (else + (debug:print 0 "ERROR: No dumpmode specified, use -dumpmode [bash|csh|config]"))))) 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))) @@ -176,16 +177,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) @@ -245,11 +258,11 @@ (loop (+ count 1))))) (let ((sighand (lambda (signum) ;; (signal-mask! signum) ;; to mask or not? seems to cause issues in exiting (if (eq? signum signal/stop) - (debug:print 0 "ERROR: attempt to STOP process. Exiting.")) + (debug:print 0 "ERROR: attempt to STOP process. Exiting.")) (set! *time-to-exit* #t) (print "Received signal " signum ", cleaning up before exit. Please wait...") (let ((th1 (make-thread (lambda () (tests:test-force-state-status! run-id test-id "INCOMPLETE" "KILLED") (print "Killed by signal " signum ". Exiting") @@ -269,15 +282,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 +303,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))) @@ -295,11 +314,11 @@ (change-directory *toppath*) ;; NOTE: Current order is to process runconfigs *before* setting the MT_ vars. This ;; seems non-ideal but could well break stuff ;; BUG? BUG? BUG? - + (let ((rconfig (full-runconfigs-read))) ;; (read-config (conc *toppath* "/runconfigs.config") #f #t sections: (list "default" target)))) ;; (setup-env-defaults (conc *toppath* "/runconfigs.config") run-id (make-hash-table) keyvals target) ;; (set-run-config-vars run-id keyvals target) ;; (db:get-target db run-id)) ;; Now have runconfigs data loaded, set environment vars (for-each (lambda (section) @@ -431,12 +450,24 @@ (if ezsteps (let* ((testconfig ;; (read-config (conc work-area "/testconfig") #f #t environ-patt: "pre-launch-env-vars")) ;; FIXME??? is allow-system ok here? ;; NOTE: it is tempting to turn off force-create of testconfig but dynamic ;; ezstep names need a full re-eval here. (tests:get-testconfig test-name tconfigreg #t force-create: #t)) ;; 'return-procs))) - (ezstepslst (hash-table-ref/default testconfig "ezsteps" '()))) - (hash-table-set! *testconfigs* test-name testconfig) ;; cached for lazy reads later ... + (ezstepslst (if (hash-table? testconfig) + (hash-table-ref/default testconfig "ezsteps" '()) + #f))) + (if testconfig + (hash-table-set! *testconfigs* test-name testconfig) ;; cached for lazy reads later ... + (begin + (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 ")))) + ;; 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))) (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)) @@ -443,13 +474,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 @@ -559,10 +591,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 @@ -580,106 +616,135 @@ (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))))))) -;; set up the very basics needed for doing anything here. -(define (launch:setup-for-run #!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 - (begin - (set! *configinfo* (or (if (get-environment-variable "MT_CMDINFO") ;; we are inside a test - do not reprocess configs - (let ((alistconfig (conc (get-environment-variable "MT_LINKTREE") "/" - (get-environment-variable "MT_TARGET") "/" - (get-environment-variable "MT_RUNNAME") "/" - ".megatest.cfg-" megatest-version "-" megatest-fossil-hash))) - (if (file-exists? alistconfig) - (list (configf:read-alist alistconfig) - (get-environment-variable "MT_RUN_AREA_HOME")) - #f)) - #f) ;; no config cached - give up - (let ((runname (or (args:get-arg "-runname")(args:get-arg ":runname")))) - (if runname (setenv "MT_RUNNAME" runname)) - (find-and-read-config - (if (args:get-arg "-config")(args:get-arg "-config") "megatest.config") - environ-patt: "env-override" - given-toppath: (get-environment-variable "MT_RUN_AREA_HOME") - pathenvvar: "MT_RUN_AREA_HOME")))) - (set! *configdat* (if (car *configinfo*)(car *configinfo*) #f)) - (set! *toppath* (if (car *configinfo*)(cadr *configinfo*) #f)) - (let* ((tmptransport (configf:lookup *configdat* "server" "transport")) - (transport (if tmptransport (string->symbol tmptransport) 'http))) - (if (member transport '(http rpc nmsg)) - (set! *transport-type* transport) - (begin - (debug:print 0 "ERROR: Unrecognised transport " transport) - (exit)))) - (let ((linktree (configf:lookup *configdat* "setup" "linktree"))) ;; link tree is critical - (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 linktree - (let ((dbdir (conc linktree "/.db"))) - (handle-exceptions - exn - (begin - (debug:print 0 "ERROR: failed to create the " dbdir " area for your database files") - (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn))) - (if (not (directory-exists? dbdir))(create-directory dbdir))) - (setenv "MT_LINKTREE" linktree)) - (begin - (debug:print 0 "ERROR: linktree is required in your megatest.config [setup] section") - (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.") - (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"))) - (let* ((linktree (get-environment-variable "MT_LINKTREE")) - (target (common:args-get-target)) - (runname (or (args:get-arg "-runname") - (args:get-arg ":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))) - (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* ((toppath (or *toppath* (getenv "MT_RUN_AREA_HOME"))) ;; preserve toppath + (runname (common:args-get-runname)) + (target (common:args-get-target)) + (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))) + (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 (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 @@ -233,10 +233,11 @@ "-port" "-extract-ods" "-pathmod" "-env2file" "-envcap" + "-envdelta" "-setvars" "-set-state-status" "-set-run-status" "-debug" ;; for *verbosity* > 2 "-gen-megatest-test" @@ -312,14 +313,18 @@ "-q" ;; quiet 0, errors/warnings only ) args:arg-hash 0)) +;; Add args that use remargs here +;; (if (and (not (null? remargs)) (not (or - (args:get-arg "-runstep")) - ;; add more args that use remargs here + (args:get-arg "-runstep") + (args:get-arg "-envcap") + (args:get-arg "-envdelta") + ) )) (debug:print 0 "ERROR: Unrecognised arguments: " (string-intersperse (if (list? remargs) remargs (argv)) " "))) ;; immediately set MT_TARGET if -reqtarg or -target are available ;; @@ -463,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 @@ -662,10 +667,53 @@ ;; (print ((rpc:procedure 'testing (car host-port)(cadr host-port)))) ;; (case (server:get-transport) ;; ((http)(http:ping run-id host-port)) ;; ((rpc) (rpc:procedure 'server:login (car host-port)(cadr host-port));; *toppath*)) ;; (rpc-transport:ping run-id (car host-port)(cadr host-port))) ;; (else (debug:print 0 "ERROR: No transport set")(exit))))) + +;;====================================================================== +;; Capture, save and manipulate environments +;;====================================================================== + +;; NOTE: Keep these above the section where the server or client code is setup + +(let ((envcap (args:get-arg "-envcap"))) + (if envcap + (let* ((db (env:open-db (if (null? remargs) "envdat.db" (car remargs))))) + (env:save-env-vars db envcap) + (env:close-database db) + (set! *didsomething* #t)))) + +;; delta "language" will eventually be res=a+b-c but for now it is just res=a-b +;; +(let ((envdelta (args:get-arg "-envdelta"))) + (if envdelta + (let ((match (string-split envdelta "-")));; (string-match "([a-z0-9_]+)=([a-z0-9_\\-,]+)" envdelta))) + (if (not (null? match)) + (let* ((db (env:open-db (if (null? remargs) "envdat.db" (car remargs)))) + ;; (resctx (cadr match)) + ;; (equn (caddr match)) + (parts match) ;; (string-split equn "-")) + (minuend (car parts)) + (subtraend (cadr parts)) + (added (env:get-added db minuend subtraend)) + (removed (env:get-removed db minuend subtraend)) + (changed (env:get-changed db minuend subtraend))) + ;; (pp (hash-table->alist added)) + ;; (pp (hash-table->alist removed)) + ;; (pp (hash-table->alist changed)) + (if (args:get-arg "-o") + (with-output-to-file + (args:get-arg "-o") + (lambda () + (env:print added removed changed))) + (env:print added removed changed)) + (env:close-database db) + (set! *didsomething* #t)) + (debug:print 0 "ERROR: Parameter to -envdelta should be new=star-end"))))) + + ;;====================================================================== ;; Start the server - can be done in conjunction with -runall or -runtests (one day...) ;; we start the server if not running else start the client thread ;;====================================================================== @@ -672,51 +720,51 @@ (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) (set! *didsomething* #t)) - (debug:print 0 "ERROR: server requires run-id be specified with -run-id")))) + (debug:print 0 "ERROR: server requires run-id be specified with -run-id"))) ;; Not a server? This section will decide how to communicate ;; ;; Setup client for all expect listed here - ;; (if (null? (lset-intersection - ;; equal? - ;; (hash-table-keys args:arg-hash) - ;; '("-list-servers" - ;; "-stop-server" - ;; "-show-cmdinfo" - ;; "-list-runs" - ;; "-ping"))) - ;; (if (launch:setup-for-run) - ;; (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") - ;; (eq? (length (hash-table-keys args:arg-hash)) 0)) - ;; (debug:print-info 1 "Server connection not needed") - ;; (begin - ;; ;; (if run-id - ;; ;; (client:launch run-id) - ;; ;; (client:launch 0) ;; without run-id we'll start a server for "0" - ;; #t - ;; )))))) + (if (null? (lset-intersection + equal? + (hash-table-keys args:arg-hash) + '("-list-servers" + "-stop-server" + "-show-cmdinfo" + "-list-runs" + "-ping"))) + (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") + (eq? (length (hash-table-keys args:arg-hash)) 0)) + (debug:print-info 1 "Server connection not needed") + (begin + ;; (if run-id + ;; (client:launch run-id) + ;; (client:launch 0) ;; without run-id we'll start a server for "0" + #t + )))))) ;; 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 '()) @@ -779,27 +827,50 @@ (json-write targets)) (else (debug:print 0 "ERROR: dump output format " (args:get-arg "-dumpmode") " not supported for -list-targets"))) (set! *didsomething* #t))) +;; get the runconfigs +;; (define (full-runconfigs-read) - (let* ((keys (rmt:get-keys)) - (target (common:args-get-target)) - (key-vals (if target (keys:target->keyval keys target) #f)) - (sections (if target (list "default" target) #f)) - (data (begin - (setenv "MT_RUN_AREA_HOME" *toppath*) - (if key-vals - (for-each (lambda (kt) - (setenv (car kt) (cadr kt))) - key-vals)) - (read-config (conc *toppath* "/runconfigs.config") #f #t sections: sections)))) - data)) - + (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 +;; (file-exists? cfgf) +;; (file-write-access? cfgf)) +;; (configf:read-alist cfgf) +;; (let* ((keys (rmt:get-keys)) +;; (target (common:args-get-target)) +;; (key-vals (if target (keys:target->keyval keys target) #f)) +;; (sections (if target (list "default" target) #f)) +;; (data (begin +;; (setenv "MT_RUN_AREA_HOME" *toppath*) +;; (if key-vals +;; (for-each (lambda (kt) +;; (setenv (car kt) (cadr kt))) +;; key-vals)) +;; (read-config (conc *toppath* "/runconfigs.config") #f #t sections: sections)))) +;; (if (and rundir ;; have all needed variabless +;; (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 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") @@ -817,11 +888,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") @@ -954,11 +1025,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") @@ -1285,11 +1356,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))) @@ -1443,11 +1514,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 @@ -1549,11 +1620,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) @@ -1597,11 +1668,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)) @@ -1702,11 +1773,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 ", ")) @@ -1733,21 +1804,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) @@ -1762,11 +1833,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))) @@ -1775,11 +1846,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 @@ -1792,11 +1863,11 @@ ;; fakeout readline (if (or (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) @@ -1823,11 +1894,11 @@ (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))) @@ -1879,28 +1950,10 @@ #f ;; do all run-ids 'new2old ) (set! *didsomething* #t))) -;;====================================================================== -;; Capture, save and manipulate environments -;;====================================================================== - -(let ((envcap (args:get-arg "-envcap"))) - (if envcap - (if (substring-index "=" envcap) - (let* ((parts (string-split envcap "=")) - (fname (car parts)) - (context (cadr parts)) - (db (env:open-db fname))) - (env:save-env-vars db context) - (env:close-database db) - (set! *didsomething* #t)) - (begin - (debug:print 0 "ERROR: Parameter to -envcap should be =. E.G. envdat=original, got: " envcap) - (set! *didsomething* #t))))) - ;;====================================================================== ;; Exit and clean up ;;====================================================================== (if *runremote* (close-all-connections!)) 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,12 +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) - (launch:cache-config) + (if (not (launch:setup)) (begin (debug:print 0 "Failed to setup, exiting") (exit 1))) (set! keys (keys:config-get-fields *configdat*)) ;; have enough to process -target or -reqtarg here 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) 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/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.