Index: common.scm
==================================================================
--- common.scm
+++ common.scm
@@ -43,14 +43,18 @@
(define home (getenv "HOME"))
(define user (getenv "USER"))
;; GLOBAL GLETCHES
(define *db-keys* #f)
-(define *configinfo* #f)
-(define *configdat* #f)
-(define *toppath* #f)
+
+(define *configinfo* #f) ;; raw results from setup, includes toppath and table from megatest.config
+(define *runconfigdat* #f) ;; run configs data
+(define *configdat* #f) ;; megatest.config data
+(define *configstatus* #f) ;; status of data; 'fulldata : all processing done, #f : no data yet, 'partialdata : partial read done
+(define *toppath* #f)
(define *already-seen-runconfig-info* #f)
+
(define *waiting-queue* (make-hash-table))
(define *test-meta-updated* (make-hash-table))
(define *globalexitstatus* 0) ;; attempt to work around possible thread issues
(define *passnum* 0) ;; when running track calls to run-tests or similar
(define *write-frequency* (make-hash-table)) ;; run-id => (vector (current-seconds) 0))
@@ -447,36 +451,42 @@
rtestpatt)
args-testpatt)))
(if rtestpatt (debug:print-info 0 "TESTPATT from runconfigs: " rtestpatt))
testpatt))
+(define (common:get-linktree)
+ (or (getenv "MT_LINKTREE")
+ (if *configdat*
+ (configf:lookup *configdat* "setup" "linktree"))))
+
(define (common:args-get-runname)
- (or (args:get-arg "-runname")
- (args:get-arg ":runname")
- (getenv "MT_RUNNAME")))
+ (let ((res (or (args:get-arg "-runname")
+ (args:get-arg ":runname")
+ (getenv "MT_RUNNAME"))))
+ ;; (if res (set-environment-variable "MT_RUNNAME" res)) ;; not sure if this is a good idea. side effect and all ...
+ res))
(define (common:args-get-target #!key (split #f))
- (let* ((keys (keys:config-get-fields *configdat*))
+ (let* ((keys (if *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
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,17 @@
""
(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-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 +282,16 @@
(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)))
+ (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) 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 +301,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.scm
==================================================================
--- dashboard.scm
+++ dashboard.scm
@@ -81,11 +81,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)))
(define *useserver* (cond
@@ -113,11 +113,10 @@
(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)) ;; <run-id color text test run-key>
(define *alltestnamelst* '())
(define *searchpatts* (make-hash-table))
(define *num-runs* 8)
@@ -306,14 +305,10 @@
(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)
(set! result (cons dstruct result))))))
runs)
(set! *header* header)
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
ADDED fsl-rebase.scm
Index: fsl-rebase.scm
==================================================================
--- /dev/null
+++ fsl-rebase.scm
@@ -0,0 +1,37 @@
+;; given branch and baseline commit generate list of commands to cherry pick commits
+;;
+;;
+;; Usage: fsl-rebase basecommit branch
+;;
+
+(use regex posix)
+
+(let* ((basecommit (cadr (argv)))
+ (branch (caddr (argv)))
+ (cmd (conc "fossil timeline after " basecommit " -n 1000000 -W 0"))
+ (theregex (conc ;; "^[^\\]]+"
+ "\\[([a-z0-9]+)\\]\\s+"
+ "(.*)"
+ "\\s+\\(.*tags:\\s+" branch
+ ;; ".*\\)"
+ )))
+ (print "basecommit: " basecommit ", branch: " branch ", theregex: " theregex ", cmd: \"" cmd "\"")
+ (with-input-from-pipe
+ cmd
+ (lambda ()
+ (let loop ((inl (read-line))
+ (res '()))
+ (if (not (eof-object? inl))
+ (let ((have-match (string-search theregex inl)))
+ (if have-match
+ (loop (read-line)
+ (cons (conc "fossil merge --cherrypick " (cadr have-match)
+ "\nfossil commit -m \"Cherry pick from " (cadr have-match)
+ ": " (caddr have-match) "\"")
+ res))
+ (loop (read-line) res)))
+ (map print res))))))
+
+;; (print "match: " inl "\n $1: " (cadr have-match) " $2: " (caddr have-match))
+;; (print "no match: " theregex " " inl))
+;; (loop (read-line))))))))
Index: launch.scm
==================================================================
--- launch.scm
+++ launch.scm
@@ -269,15 +269,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 +290,11 @@
(debug:print 2 "Exectuing " test-name " (id: " test-id ") on " (get-host-name))
(set! keys (rmt:get-keys))
;; (runs:set-megatest-env-vars run-id inkeys: keys inkeyvals: keyvals) ;; these may be needed by the launching process
;; one of these is defunct/redundant ...
- (if (not (launch:setup-for-run force: #t))
+ (if (not (launch:setup force: #t))
(begin
(debug:print 0 "Failed to setup, exiting")
;; (sqlite3:finalize! db)
;; (sqlite3:finalize! tdb)
(exit 1)))
@@ -437,22 +443,18 @@
(hash-table-ref/default testconfig "ezsteps" '())
#f)))
(if testconfig
(hash-table-set! *testconfigs* test-name testconfig) ;; cached for lazy reads later ...
(begin
- ;; got here but there are race condiitions - re-do all setup and try one more time
- (if (launch:setup-for-run)
- (begin
- (launch:cache-config)
- (set! testconfig (full-runconfigs-read))) ;; redunantly redundant, but does it resolve the race?
+ (launch:setup)
(debug:print 0 "WARNING: no testconfig found for " test-name " in search path:\n "
- (string-intersperse (tests:get-tests-search-path *configdat*) "\n ")))))
+ (string-intersperse (tests:get-tests-search-path *configdat*) "\n "))))
;; after all that, still no testconfig? Time to abort
(if (not testconfig)
(begin
(debug:print 0 "ERROR: Failed to resolve megatest.config, runconfigs.config and testconfig issues. Giving up now")
- (exit 1)))s
+ (exit 1)))
(if (not (file-exists? ".ezsteps"))(create-directory ".ezsteps"))
;; if ezsteps was defined then we are sure to have at least one step but check anyway
(if (not (> (length ezstepslst) 0))
(debug:print 0 "ERROR: ezsteps defined but ezstepslst is zero length")
(let loop ((ezstep (car ezstepslst))
@@ -595,13 +597,47 @@
(mutex-unlock! m)
(debug:print 2 "Output from running " fullrunscript ", pid " (launch:einf-pid exit-info) " in work area "
work-area ":\n====\n exit code " (launch:einf-exit-code exit-info) "\n" "====\n")
(if (not (launch:einf-exit-status exit-info))
(exit 4)))))))
+
+(define (launch:cache-config)
+ ;; if we have a linktree and -runtests and -target and the directory exists dump the config
+ ;; to megatest-(current-seconds).cfg and symlink it to megatest.cfg
+ (if (and *configdat*
+ (or (args:get-arg "-run")
+ (args:get-arg "-runtests")
+ (args:get-arg "-execute")))
+ (let* ((linktree (get-environment-variable "MT_LINKTREE"))
+ (target (common:args-get-target))
+ (runname (or (args:get-arg "-runname")
+ (args:get-arg ":runname")
+ (getenv "MT_RUNNAME")))
+ (fulldir (conc linktree "/"
+ target "/"
+ runname)))
+ (debug:print-info 0 "Have -runtests with target=" target ", runname=" runname ", fulldir=" fulldir ", testpatt=" (or (args:get-arg "-testpatt") "%"))
+ (if (and linktree (file-exists? linktree)) ;; can't proceed without linktree
+ (begin
+ (if (not (file-exists? fulldir))
+ (create-directory fulldir #t)) ;; need to protect with exception handler
+ (if (and target
+ runname
+ (file-exists? fulldir))
+ (let ((tmpfile (conc fulldir "/.megatest.cfg." (current-seconds)))
+ (targfile (conc fulldir "/.megatest.cfg-" megatest-version "-" megatest-fossil-hash))
+ (rconfig (conc fulldir "/.runconfig." megatest-version "-" megatest-fossil-hash)))
+ (if (file-exists? rconfig) ;; only cache megatest.config AFTER runconfigs has been cached
+ (begin
+ (debug:print-info 0 "Caching megatest.config in " fulldir "/.megatest.cfg")
+ (configf:write-alist *configdat* tmpfile)
+ (system (conc "ln -sf " tmpfile " " targfile))))
+ )))))))
;; set up the very basics needed for doing anything here.
-(define (launch:setup-for-run #!key (force #f))
+;;
+(define (launch:setup-old #!key (force #f))
;; would set values for KEYS in the environment here for better support of env-override but
;; have chicken/egg scenario. need to read megatest.config then read it again. Going to
;; pass on that idea for now
;; special case
(if (or force (not (hash-table? *configdat*))) ;; no need to re-open on every call
@@ -665,61 +701,134 @@
(debug:print 0 "ERROR: failed to find the top path to your Megatest area.")
(exit 1)))
)))
*toppath*)
-(define (launch:cache-config)
- ;; if we have a linktree and -runtests and -target and the directory exists dump the config
- ;; to megatest-(current-seconds).cfg and symlink it to megatest.cfg
- (if (and *configdat*
- (or (args:get-arg "-run")
- (args:get-arg "-runtests")
- (args:get-arg "-execute")))
- (let* ((linktree (get-environment-variable "MT_LINKTREE"))
- (target (common:args-get-target))
- (runname (or (args:get-arg "-runname")
- (args:get-arg ":runname")
- (getenv "MT_RUNNAME")))
- (fulldir (conc linktree "/"
- target "/"
- runname)))
- (debug:print-info 0 "Have -runtests with target=" target ", runname=" runname ", fulldir=" fulldir ", testpatt=" (or (args:get-arg "-testpatt") "%"))
- (if (file-exists? linktree) ;; can't proceed without linktree
- (begin
- (if (not (file-exists? fulldir))
- (create-directory fulldir #t)) ;; need to protect with exception handler
- (if (and target
- runname
- (file-exists? fulldir))
- (let ((tmpfile (conc fulldir "/.megatest.cfg." (current-seconds)))
- (targfile (conc fulldir "/.megatest.cfg-" megatest-version "-" megatest-fossil-hash))
- (rconfig (conc fulldir "/.runconfig." megatest-version "-" megatest-fossil-hash)))
- (if (file-exists? rconfig) ;; only cache megatest.config AFTER runconfigs has been cached
- (begin
- (debug:print-info 0 "Caching megatest.config in " fulldir "/.megatest.cfg")
- (configf:write-alist *configdat* tmpfile)
- (system (conc "ln -sf " tmpfile " " targfile))))
- )))))))
-
;; gather available information, if legit read configs in this order:
;;
;; if have cache;
;; read it a return it
;; else
;; megatest.config (do not cache)
;; runconfigs.config (cache if all vars avail)
;; megatest.config (cache if all vars avail)
+;; returns:
+;; *toppath*
+;; side effects:
+;; sets; *configdat* (megatest.config info)
+;; *runconfigdat* (runconfigs.config info)
+;; *configstatus* (status of the read data)
;;
-(define (launch:setup #!key (force #f))
- (let* ((runname (common:args-get-runname))
+(define (launch:setup-new #!key (force #f))
+ (let* ((toppath (or *toppath* (getenv "MT_RUN_AREA_HOME"))) ;; preserve toppath
+ (runname (common:args-get-runname))
(target (common:args-get-target))
- (linktree (or (getenv "MT_LINKTREE")
- (if *configdat* (configf:lookup *configdat* "setup" "linktree") #f)))
+ (linktree (common:get-linktree))
+ (sections (if target (list "default" target) #f)) ;; for runconfigs
+ (mtconfig (or (args:get-arg "-config") "megatest.config")) ;; allow overriding megatest.config
(rundir (if (and runname target linktree)(conc linktree "/" target "/" runname) #f))
(mtcachef (and rundir (conc rundir "/" ".megatest.cfg-" megatest-version "-" megatest-fossil-hash)))
- (rccachef (and rundir (conc rundir "/" ".runconfigs.cfg-" megatest-version "-" megatest-fossil-hash))))
- #f))
+ (rccachef (and rundir (conc rundir "/" ".runconfigs.cfg-" megatest-version "-" megatest-fossil-hash)))
+ (cancreate (and rundir (file-exists? rundir)(file-write-access? rundir))))
+ ;; (print "runname: " runname " target: " target " mtcachef: " mtcachef " rccachef: " rccachef)
+ (set! *toppath* toppath) ;; This is needed when we are running as a test using CMDINFO as a datasource
+ (cond
+ ;; data was read and cached and available in *configstatus*, toppath has already been set
+ ((eq? *configstatus* 'fulldata)
+ *toppath*)
+ ;; if mtcachef exists just read it, however we need to assume toppath is available in $MT_RUN_AREA_HOME
+ ((and mtcachef (file-exists? mtcachef) (get-environment-variable "MT_RUN_AREA_HOME"))
+ (set! *configdat* (configf:read-alist mtcachef))
+ (set! *runconfigdat* (configf:read-alist rccachef))
+ (set! *configinfo* (list *configdat* (get-environment-variable "MT_RUN_AREA_HOME")))
+ (set! *configstatus* 'fulldata)
+ (set! *toppath* (get-environment-variable "MT_RUN_AREA_HOME"))
+ *toppath*)
+ ;; we have all the info needed to fully process runconfigs and megatest.config
+ (mtcachef
+ (let* ((first-pass (find-and-read-config ;; NB// sets MT_RUN_AREA_HOME as side effect
+ mtconfig
+ environ-patt: "env-override"
+ given-toppath: toppath
+ pathenvvar: "MT_RUN_AREA_HOME"))
+ (first-rundat (read-config (conc toppath "/runconfigs.config") *runconfigdat* #t
+ sections: sections)))
+ (set! *runconfigdat* first-rundat)
+ (if first-pass ;;
+ (begin
+ (set! *configdat* (car first-pass))
+ (set! *configinfo* first-pass)
+ (set! *toppath* (or toppath (cadr first-pass))) ;; use the gathered data unless already have it
+ (set! toppath *toppath*)
+ (setenv "MT_RUN_AREA_HOME" *toppath*)
+ ;; the seed read is done, now read runconfigs, cache it then read megatest.config one more time and cache it
+ (let* ((keys (rmt:get-keys))
+ (key-vals (keys:target->keyval keys target))
+ (linktree (or (getenv "MT_LINKTREE")
+ (if *configdat* (configf:lookup *configdat* "setup" "linktree") #f)))
+ (second-pass (find-and-read-config
+ mtconfig
+ environ-patt: "env-override"
+ given-toppath: toppath
+ pathenvvar: "MT_RUN_AREA_HOME"))
+ (runconfigdat (begin ;; this read of the runconfigs will see any adjustments made by re-reading megatest.config
+ (for-each (lambda (kt)
+ (setenv (car kt) (cadr kt)))
+ key-vals)
+ (read-config (conc toppath "/runconfigs.config") *runconfigdat* #t
+ sections: sections))))
+ (if cancreate (configf:write-alist runconfigdat rccachef))
+ (set! *runconfigdat* runconfigdat)
+ (if cancreate (configf:write-alist *configdat* mtcachef))
+ (if cancreate (set! *configstatus* 'fulldata))))
+ ;; no configs found? should not happen but let's try to recover gracefully, return an empty hash-table
+ (set! *configdat* (make-hash-table))
+ )))
+ ;; else read what you can and set the flag accordingly
+ (else
+ (let* ((cfgdat (find-and-read-config
+ (or (args:get-arg "-config") "megatest.config")
+ environ-patt: "env-override"
+ given-toppath: (get-environment-variable "MT_RUN_AREA_HOME")
+ pathenvvar: "MT_RUN_AREA_HOME")))
+ (if cfgdat
+ (let* ((toppath (or (get-environment-variable "MT_RUN_AREA_HOME")(cadr cfgdat)))
+ (rdat (read-config (conc toppath
+ "/runconfigs.config") *runconfigdat* #t sections: sections)))
+ (set! *configinfo* cfgdat)
+ (set! *configdat* (car cfgdat))
+ (set! *runconfigdat* rdat)
+ (set! *toppath* toppath)
+ (set! *configstatus* 'partial))
+ (begin
+ (debug:print 0 "ERROR: No " mtconfig " file found. Giving up.")
+ (exit 2))))))
+ ;; additional house keeping
+ (let* ((linktree (or (getenv "MT_LINKTREE")
+ (if *configdat* (configf:lookup *configdat* "setup" "linktree") #f))))
+ (if linktree
+ (if (not (file-exists? linktree))
+ (begin
+ (handle-exceptions
+ exn
+ (begin
+ (debug:print 0 "ERROR: Something went wrong when trying to create linktree dir at " linktree)
+ (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn))
+ (exit 1))
+ (create-directory linktree #t))))
+ (begin
+ (debug:print 0 "ERROR: linktree not defined in [setup] section of megatest.config")
+ ;; (exit 1)
+ )))
+ (if (and *toppath*
+ (directory-exists? *toppath*))
+ (setenv "MT_RUN_AREA_HOME" *toppath*)
+ (begin
+ (debug:print 0 "ERROR: failed to find the top path to your Megatest area.")))
+ *toppath*))
+
+(define launch:setup launch:setup-new)
(define (get-best-disk confdat testconfig)
(let* ((disks (or (and testconfig (hash-table-ref/default testconfig "disks" #f))
(hash-table-ref/default confdat "disks" #f)))
(minspace (let ((m (configf:lookup confdat "setup" "minspace")))
Index: megatest.scm
==================================================================
--- megatest.scm
+++ megatest.scm
@@ -468,11 +468,11 @@
(begin
(save-environment-as-files (args:get-arg "-env2file"))
(set! *didsomething* #t)))
(if (args:get-arg "-list-disks")
- (let ((toppath (launch:setup-for-run)))
+ (let ((toppath (launch:setup)))
(print
(string-intersperse
(map (lambda (x)
(string-intersperse
x
@@ -720,11 +720,11 @@
(if (args:get-arg "-server")
;; Server? Start up here.
;;
- (let ((tl (launch:setup-for-run))
+ (let ((tl (launch:setup))
(run-id (and (args:get-arg "-run-id")
(string->number (args:get-arg "-run-id")))))
(if run-id
(begin
(server:launch run-id)
@@ -740,11 +740,11 @@
'("-list-servers"
"-stop-server"
"-show-cmdinfo"
"-list-runs"
"-ping")))
- (if (launch:setup-for-run)
+ (if (launch:setup)
(let ((run-id (and (args:get-arg "-run-id")
(string->number (args:get-arg "-run-id")))))
;; (set! *fdb* (filedb:open-db (conc *toppath* "/db/paths.db")))
;; if not list or kill then start a client (if appropriate)
(if (or (args-defined? "-h" "-version" "-gen-megatest-area" "-gen-megatest-test")
@@ -760,11 +760,11 @@
;; MAY STILL NEED THIS
;; (set! *megatest-db* (make-dbr:dbstruct path: *toppath* local: #t))))))))))
(if (or (args:get-arg "-list-servers")
(args:get-arg "-stop-server"))
- (let ((tl (launch:setup-for-run)))
+ (let ((tl (launch:setup)))
(if tl
(let* ((tdbdat (tasks:open-db))
(servers (tasks:get-all-servers (db:delay-if-busy tdbdat)))
(fmtstr "~5a~12a~8a~20a~24a~10a~10a~10a~10a\n")
(servers-to-kill '())
@@ -830,10 +830,17 @@
(set! *didsomething* #t)))
;; cache the runconfigs in $MT_LINKTREE/$MT_TARGET/$MT_RUNNAME/.runconfig
;;
(define (full-runconfigs-read)
+;; in the envprocessing branch the below code replaces the further below code
+;; (if (eq? *configstatus* 'fulldata)
+;; *runconfigdat*
+;; (begin
+;; (launch:setup)
+;; *runconfigdat*)))
+
(let* ((rundir (if (and (getenv "MT_LINKTREE")(getenv "MT_TARGET")(getenv "MT_RUNNAME"))
(conc (getenv "MT_LINKTREE") "/" (getenv "MT_TARGET") "/" (getenv "MT_RUNNAME"))
#f))
(cfgf (if rundir (conc rundir "/.runconfig." megatest-version "-" megatest-fossil-hash) #f)))
(if (and cfgf
@@ -855,16 +862,16 @@
(directory-exists? rundir)
(file-write-access? rundir))
(begin
(configf:write-alist data cfgf)
;; force re-read of megatest.config - this resolves circular references between megatest.config
- (launch:setup-for-run force: #t)
+ (launch:setup force: #t)
(launch:cache-config))) ;; we can safely cache megatest.config since we have a valid runconfig
data))))
(if (args:get-arg "-show-runconfig")
- (let ((tl (launch:setup-for-run)))
+ (let ((tl (launch:setup)))
(push-directory *toppath*)
(let ((data (full-runconfigs-read)))
;; keep this one local
(cond
((and (args:get-arg "-section")
@@ -882,11 +889,11 @@
(debug:print 0 "ERROR: -dumpmode of " (args:get-arg "-dumpmode") " not recognised")))
(set! *didsomething* #t))
(pop-directory)))
(if (args:get-arg "-show-config")
- (let ((tl (launch:setup-for-run))
+ (let ((tl (launch:setup))
(data *configdat*)) ;; (read-config "megatest.config" #f #t)))
(push-directory *toppath*)
;; keep this one local
(cond
((and (args:get-arg "-section")
@@ -1019,11 +1026,11 @@
;;
;; IDEA: megatest list -runname blah% ...
;;
(if (or (args:get-arg "-list-runs")
(args:get-arg "-list-db-targets"))
- (if (launch:setup-for-run)
+ (if (launch:setup)
(let* (;; (dbstruct (make-dbr:dbstruct path: *toppath* local: (args:get-arg "-local")))
(runpatt (args:get-arg "-list-runs"))
(testpatt (common:args-get-testpatt #f))
;; (if (args:get-arg "-testpatt")
;; (args:get-arg "-testpatt")
@@ -1350,11 +1357,11 @@
(set! *didsomething* #t))))
;; Don't think I need this. Incorporated into -list-runs instead
;;
;; (if (and (args:get-arg "-since")
-;; (launch:setup-for-run))
+;; (launch:setup))
;; (let* ((since-time (string->number (args:get-arg "-since")))
;; (run-ids (db:get-changed-run-ids since-time)))
;; ;; (rmt:get-tests-for-runs-mindata run-ids testpatt states status not-in)
;; (print (sort run-ids <))
;; (set! *didsomething* #t)))
@@ -1508,11 +1515,11 @@
(change-directory toppath)
(if (not target)
(begin
(debug:print 0 "ERROR: -target is required.")
(exit 1)))
- (if (not (launch:setup-for-run))
+ (if (not (launch:setup))
(begin
(debug:print 0 "Failed to setup, giving up on -test-paths or -test-files, exiting")
(exit 1)))
(let* ((keys (rmt:get-keys))
;; db:test-get-paths must not be run remote
@@ -1614,11 +1621,11 @@
(test-id (assoc/default 'test-id cmdinfo))
(itemdat (assoc/default 'itemdat cmdinfo))
(work-area (assoc/default 'work-area cmdinfo))
(db #f))
(change-directory testpath)
- (if (not (launch:setup-for-run))
+ (if (not (launch:setup))
(begin
(debug:print 0 "Failed to setup, exiting")
(exit 1)))
(if (and state status)
(rmt:teststep-set-status! run-id test-id step state status msg logfile)
@@ -1662,11 +1669,11 @@
(itemdat (assoc/default 'itemdat cmdinfo))
(work-area (assoc/default 'work-area cmdinfo))
(db #f) ;; (open-db))
(state (args:get-arg ":state"))
(status (args:get-arg ":status")))
- (if (not (launch:setup-for-run))
+ (if (not (launch:setup))
(begin
(debug:print 0 "Failed to setup, exiting")
(exit 1)))
(if (args:get-arg "-runstep")(debug:print-info 1 "Running -runstep, first change to directory " work-area))
@@ -1767,11 +1774,11 @@
(if (or (args:get-arg "-showkeys")
(args:get-arg "-show-keys"))
(let ((db #f)
(keys #f))
- (if (not (launch:setup-for-run))
+ (if (not (launch:setup))
(begin
(debug:print 0 "Failed to setup, exiting")
(exit 1)))
(set! keys (rmt:get-keys)) ;; db))
(debug:print 1 "Keys: " (string-intersperse keys ", "))
@@ -1798,21 +1805,21 @@
;; Update the database schema, clean up the db
;;======================================================================
(if (args:get-arg "-rebuild-db")
(begin
- (if (not (launch:setup-for-run))
+ (if (not (launch:setup))
(begin
(debug:print 0 "Failed to setup, exiting")
(exit 1)))
;; keep this one local
(open-run-close patch-db #f)
(set! *didsomething* #t)))
(if (args:get-arg "-cleanup-db")
(begin
- (if (not (launch:setup-for-run))
+ (if (not (launch:setup))
(begin
(debug:print 0 "Failed to setup, exiting")
(exit 1)))
;; keep this one local
;; (open-run-close db:clean-up #f)
@@ -1827,11 +1834,11 @@
)
(set! *didsomething* #t)))
(if (args:get-arg "-mark-incompletes")
(begin
- (if (not (launch:setup-for-run))
+ (if (not (launch:setup))
(begin
(debug:print 0 "Failed to setup, exiting") b
(exit 1)))
(open-run-close db:find-and-mark-incomplete #f)
(set! *didsomething* #t)))
@@ -1840,11 +1847,11 @@
;; Update the tests meta data from the testconfig files
;;======================================================================
(if (args:get-arg "-update-meta")
(begin
- (if (not (launch:setup-for-run))
+ (if (not (launch:setup))
(begin
(debug:print 0 "Failed to setup, exiting")
(exit 1)))
;; now can find our db
;; keep this one local
@@ -1857,11 +1864,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)
@@ -1888,11 +1895,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)))
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))
@@ -1780,11 +1780,11 @@
(debug:print 0 "ERROR: Missing required parameter for " switchname ", you must specify the run name with -runname runname")
(exit 3))
(else
(let (;; (db #f)
(keys #f))
- (if (launch:setup-for-run)
+ (if (launch:setup)
(begin
(full-runconfigs-read) ;; cache the run config
(launch:cache-config)) ;; do not cache here - need to be sure runconfigs is processed
(begin
(debug:print 0 "Failed to setup, exiting")
Index: server.scm
==================================================================
--- server.scm
+++ server.scm
@@ -207,11 +207,11 @@
(let ((tdbdat (tasks:open-db)))
(let* ((host-port (let ((slst (string-split host:port ":")))
(if (eq? (length slst) 2)
(list (car slst)(string->number (cadr slst)))
#f)))
- (toppath (launch:setup-for-run))
+ (toppath (launch:setup))
(server-db-dat (if (not host-port)(tasks:get-server (db:delay-if-busy tdbdat) run-id) #f)))
(if (not run-id)
(begin
(debug:print 0 "ERROR: must specify run-id when doing ping, -run-id n")
(print "ERROR: No run-id")