Index: Makefile
==================================================================
--- Makefile
+++ Makefile
@@ -43,11 +43,11 @@
tcp-transportmod.scm rmtmod.scm portlogger.scm apimod.scm \
configfmod.scm processmod.scm servermod.scm megatestmod.scm \
stml2.scm fsmod.scm cpumod.scm mtmod.scm odsmod.scm \
pkts.scm testsmod.scm pgdb.scm cookie.scm launchmod.scm \
subrunmod.scm runsmod.scm tasksmod.scm archivemod.scm \
- ezstepsmod.scm
+ ezstepsmod.scm mtbody.scm envmod.scm
transport-mode.scm : transport-mode.scm.template
cp transport-mode.scm.template transport-mode.scm
dashboard-transport-mode.scm : dashboard-transport-mode.scm.template
@@ -56,10 +56,11 @@
mtest : transport-mode.scm
dboard : dashboard-transport-mode.scm
# dbmod.import.o is just a hack here
+mofiles/mtbody.o : mofiles/launchmod.o readline-fix.scm mofiles/envmod.o
process.o : mofiles/processmod.o
mofiles/configfmod.o : mofiles/processmod.o
mofiles/processmod.o : mofiles/commonmod.o
mofiles/servermod.o : mofiles/commonmod.o
mofiles/rmtmod.o : mofiles/mtmod.o mofiles/apimod.o
Index: api.scm
==================================================================
--- api.scm
+++ api.scm
@@ -40,90 +40,5 @@
matchable
s11n
typed-records)
-;; QUEUE METHOD
-
-(define (api:tcp-dispatch-request-make-handler-new dbstruct) ;; cmd run-id params)
- (api:tcp-dispatch-request-make-handler-core dbstruct api:dispatch-request))
-
-
-;; indat is (cmd run-id params meta)
-;;
-;; WARNING: Do not print anything in the lambda of this function as it
-;; reads/writes to current in/out port
-;;
-(define (api:tcp-dispatch-request-make-handler-old dbstruct) ;; cmd run-id params)
- (assert *toppath* "FATAL: api:tcp-dispatch-request-make-handler called but *toppath* not set.")
- (if (not *server-signature*)
- (set! *server-signature* (tt:mk-signature *toppath*)))
- (lambda (indat)
- (api:register-thread (current-thread))
- (let* ((result
- (let* ((numthreads (api:get-count-threads-alive))
- (delay-wait (if (> numthreads 10)
- (- numthreads 10)
- 0))
- (normal-proc (lambda (cmd run-id params)
- (case cmd
- ((ping) *server-signature*)
- (else
- (api:dispatch-request dbstruct cmd run-id params))))))
- (set! *api-process-request-count* numthreads)
- (set! *db-last-access* (current-seconds))
-;; (if (not (eq? numthreads numthreads))
-;; (begin
-;; (api:remove-dead-or-terminated)
-;; (let ((threads-now (api:get-count-threads-alive)))
-;; (debug:print 0 *default-log-port* "WARNING: numthreads="numthreads", numthreads="numthreads", remaining="threads-now)
-;; (set! numthreads threads-now))))
- (match indat
- ((cmd run-id params meta)
- (let* ((start-t (current-milliseconds))
- (db-ok (let* ((dbfname (dbmod:run-id->dbfname run-id))
- (ok (equal? dbfname (dbr:dbstruct-dbfname dbstruct))))
- (case cmd
- ((ping) #t) ;; we are fine
- (else
- (assert ok "FATAL: database file and run-id not aligned.")))))
- (ttdat *server-info*)
- (server-state (tt-state ttdat))
- (maxthreads 20) ;; make this a parameter?
- (status (cond
- ((and (> numthreads maxthreads)
- (> (random 100) 70)) ;; allow a 30% probability to go through so we can figure out what is going wrong in main.db server.
- 'busy)
- ;; ((> numthreads 5) 'loaded) ;; this gets transmitted to the client which calls tt:backoff-incr to slow stuff down.
- (else 'ok)))
- (errmsg (case status
- ((busy) (conc "Server overloaded, "numthreads" threads in flight"))
- ((loaded) (conc "Server loaded, "numthreads" threads in flight"))
- (else #f)))
- (result (case status
- ((busy)
- (if (eq? cmd 'ping)
- (normal-proc cmd run-id params)
- ;; numthreads must be greater than 5 for busy
- (* 0.1 (- numthreads maxthreads)) ;; was 15 - return a number for the remote to delay
- )) ;; (- numthreads 29)) ;; call back in as many seconds
- ((loaded)
- (normal-proc cmd run-id params))
- (else
- (normal-proc cmd run-id params))))
- (meta (case cmd
- ((ping) `((sstate . ,server-state)))
- (else `((wait . ,delay-wait)))))
- (payload (list status errmsg result meta)))
- ;; (cmd run-id params meta)
- (db:add-stats cmd run-id params (- (current-milliseconds) start-t))
- payload))
- (else
- (assert #f "FATAL: failed to deserialize indat "indat))))))
- ;; (set! *api-process-request-count* (- *api-process-request-count* 1))
- ;; (serialize payload)
-
- (api:unregister-thread (current-thread))
- result)))
-
-(define api:tcp-dispatch-request-make-handler api:tcp-dispatch-request-make-handler-new) ;; choose -old or -new
-
Index: apimod.scm
==================================================================
--- apimod.scm
+++ apimod.scm
@@ -26,10 +26,17 @@
(declare (uses tcp-transportmod))
(declare (uses megatestmod))
(module apimod
(
+ *server-signature*
+ api:tcp-dispatch-request-make-handler-core
+ api:register-thread
+ api:unregister-thread
+ api:get-count-threads-alive
+ api:print-db-stats
+ api:queue-processor
api:dispatch-request
)
(import scheme chicken data-structures extras)
(import (prefix sqlite3 sqlite3:) posix matchable typed-records srfi-1 srfi-18 srfi-69 )
Index: commonmod.scm
==================================================================
--- commonmod.scm
+++ commonmod.scm
@@ -51,10 +51,13 @@
(import stml2
)
(module commonmod
(
+ make-sparse-array
+ sparse-array-set!
+ sparse-array-ref
keys->valslots
item-list->path
common:human-time
number-of-processes-running
get-normalized-cpu-load
Index: configfmod.scm
==================================================================
--- configfmod.scm
+++ configfmod.scm
@@ -26,10 +26,12 @@
(use regex regex-case)
(module configfmod
(
+ configf:map-all-hier-alist
+ configf:read-refdb
lookup
configf:lookup
get-section
configf:get-section
configf:lookup-number
Index: dbmod.scm
==================================================================
--- dbmod.scm
+++ dbmod.scm
@@ -43,10 +43,11 @@
db:roll-up-rules
db:get-all-state-status-counts-for-test
db:test-set-state-status-db
db:general-call
+ db:cache-for-read-only
db:convert-test-itempath
db:test-data-rollup
db:keep-trying-until-true
db:get-test-info-by-id
Index: env.scm
==================================================================
--- env.scm
+++ env.scm
@@ -21,238 +21,239 @@
(declare (unit env))
(declare (uses debugprint))
(declare (uses mtargs))
-(import (prefix mtargs args:)
- debugprint)
-
-(use sql-de-lite) ;; srfi-1 posix regex regex-case srfi-69 srfi-18 call-with-environment-variables)
-
-(define (env:open-db fname)
- (let* ((db-exists (common:file-exists? fname))
- (db (open-database fname)))
- (if (not db-exists)
- (begin
- (exec (sql db "CREATE TABLE envvars (
- id INTEGER PRIMARY KEY,
- context TEXT NOT NULL,
- var TEXT NOT NULL,
- val TEXT NOT NULL,
- CONSTRAINT envvars_constraint UNIQUE (context,var))"))))
- (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)(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))
- (for-each
- (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)))
- (if vardat
- (hash-table->alist vardat)
- (get-environment-variables))))))
-
-;; 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 result 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 result var) val))
- val)))))
- (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: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=?)")
- contextb contexta)
- 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)))))))
-
-;; given a before and an after envvar calculate a new merged path
-;;
-(define (env:merge-path-envvar separator patha pathb)
- (let* ((patha-parts (string-split patha separator))
- (pathb-parts (string-split pathb separator))
- (common-parts (lset-intersection equal? patha-parts pathb-parts))
- (final (delete-duplicates ;; env:blind-merge
- (append pathb-parts common-parts patha-parts))))
-;; (print "BEFORE: " (string-intersperse patha-parts "\n "))
-;; (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)
- (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)
- 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:inc-path path)
- (print "PATH "
- (conc "#{scheme (env:min-path \"" path "\" \"#{getenv PATH}\")}")))
-;; (conc
-;; "#{scheme (string-intersperse "
-;; "(delete-duplicates "
-;; "(append (string-split \"" path "\" \":\") "
-;; "(string-split \"#{getenv PATH}\" \":\")))"
-;; " \":\")}")))
-
-(define (env:min-path path1 path2)
- (string-intersperse
- (delete-duplicates
- (append
- (string-split path1 ":")
- (string-split path2 ":")))
- ":"))
-
-;; inc path will set a PATH that is incrementally modified when read - config mode only
-;;
-(define (env:print added removed changed #!key (inc-path #t))
- (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)
- (let ((var (car dat))
- (val (cdr dat)))
- (if (and inc-path
- (equal? var "PATH"))
- (env:inc-path val)
- (print var " " val))))
- (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)
- (let ((var (car dat))
- (val (cdr dat)))
- (if (and inc-path
- (equal? var "PATH"))
- (env:inc-path val)
- (print var " " val))))
- (hash-table->alist changed)))))
- (else
- (debug:print-error 0 *default-log-port* "No dumpmode specified, use -dumpmode [bash|csh|config]")))))
+;; (import (prefix mtargs args:)
+;; debugprint)
+;;
+;; (use sql-de-lite) ;; srfi-1 posix regex regex-case srfi-69 srfi-18 call-with-environment-variables)
+;;
+;; (define (env:open-db fname)
+;; (let* ((db-exists (common:file-exists? fname))
+;; (db (open-database fname)))
+;; (if (not db-exists)
+;; (begin
+;; (exec (sql db "CREATE TABLE envvars (
+;; id INTEGER PRIMARY KEY,
+;; context TEXT NOT NULL,
+;; var TEXT NOT NULL,
+;; val TEXT NOT NULL,
+;; CONSTRAINT envvars_constraint UNIQUE (context,var))"))))
+;; (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)(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))
+;; (for-each
+;; (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)))
+;; (if vardat
+;; (hash-table->alist vardat)
+;; (get-environment-variables))))))
+;;
+;; ;; 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 result 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 result var) val))
+;; val)))))
+;; (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: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=?)")
+;; contextb contexta)
+;; 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)))))))
+;;
+;; ;; given a before and an after envvar calculate a new merged path
+;; ;;
+;; (define (env:merge-path-envvar separator patha pathb)
+;; (let* ((patha-parts (string-split patha separator))
+;; (pathb-parts (string-split pathb separator))
+;; (common-parts (lset-intersection equal? patha-parts pathb-parts))
+;; (final (delete-duplicates ;; env:blind-merge
+;; (append pathb-parts common-parts patha-parts))))
+;; ;; (print "BEFORE: " (string-intersperse patha-parts "\n "))
+;; ;; (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)
+;; (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)
+;; 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:inc-path path)
+;; (print "PATH "
+;; (conc "#{scheme (env:min-path \"" path "\" \"#{getenv PATH}\")}")))
+;; ;; (conc
+;; ;; "#{scheme (string-intersperse "
+;; ;; "(delete-duplicates "
+;; ;; "(append (string-split \"" path "\" \":\") "
+;; ;; "(string-split \"#{getenv PATH}\" \":\")))"
+;; ;; " \":\")}")))
+;;
+;; (define (env:min-path path1 path2)
+;; (string-intersperse
+;; (delete-duplicates
+;; (append
+;; (string-split path1 ":")
+;; (string-split path2 ":")))
+;; ":"))
+;;
+;; ;; inc path will set a PATH that is incrementally modified when read - config mode only
+;; ;;
+;; (define (env:print added removed changed #!key (inc-path #t))
+;; (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)
+;; (let ((var (car dat))
+;; (val (cdr dat)))
+;; (if (and inc-path
+;; (equal? var "PATH"))
+;; (env:inc-path val)
+;; (print var " " val))))
+;; (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)
+;; (let ((var (car dat))
+;; (val (cdr dat)))
+;; (if (and inc-path
+;; (equal? var "PATH"))
+;; (env:inc-path val)
+;; (print var " " val))))
+;; (hash-table->alist changed)))))
+;; (else
+;; (debug:print-error 0 *default-log-port* "No dumpmode specified, use -dumpmode [bash|csh|config]")))))
+;;
ADDED envmod.scm
Index: envmod.scm
==================================================================
--- /dev/null
+++ envmod.scm
@@ -0,0 +1,275 @@
+;;======================================================================
+;; Copyright 2006-2013, Matthew Welland.
+;;
+;; This file is part of Megatest.
+;;
+;; Megatest is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+;;
+;; Megatest is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with Megatest. If not, see .
+
+;;======================================================================
+
+(use sql-de-lite)
+
+(declare (unit envmod))
+
+(declare (uses debugprint))
+(declare (uses mtargs))
+(declare (uses commonmod))
+
+(module envmod
+ *
+
+(import scheme
+ chicken
+
+ posix
+ srfi-1
+ data-structures
+ srfi-69)
+
+(import (prefix mtargs args:)
+ debugprint
+ commonmod)
+
+(import sql-de-lite) ;; srfi-1 posix regex regex-case srfi-69 srfi-18 call-with-environment-variables)
+
+(define (env:open-db fname)
+ (let* ((db-exists (common:file-exists? fname))
+ (db (open-database fname)))
+ (if (not db-exists)
+ (begin
+ (exec (sql db "CREATE TABLE envvars (
+ id INTEGER PRIMARY KEY,
+ context TEXT NOT NULL,
+ var TEXT NOT NULL,
+ val TEXT NOT NULL,
+ CONSTRAINT envvars_constraint UNIQUE (context,var))"))))
+ (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)(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))
+ (for-each
+ (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)))
+ (if vardat
+ (hash-table->alist vardat)
+ (get-environment-variables))))))
+
+;; 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 result 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 result var) val))
+ val)))))
+ (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: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=?)")
+ contextb contexta)
+ 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)))))))
+
+;; given a before and an after envvar calculate a new merged path
+;;
+(define (env:merge-path-envvar separator patha pathb)
+ (let* ((patha-parts (string-split patha separator))
+ (pathb-parts (string-split pathb separator))
+ (common-parts (lset-intersection equal? patha-parts pathb-parts))
+ (final (delete-duplicates ;; env:blind-merge
+ (append pathb-parts common-parts patha-parts))))
+;; (print "BEFORE: " (string-intersperse patha-parts "\n "))
+;; (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)
+ (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)
+ 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:inc-path path)
+ (print "PATH "
+ (conc "#{scheme (env:min-path \"" path "\" \"#{getenv PATH}\")}")))
+;; (conc
+;; "#{scheme (string-intersperse "
+;; "(delete-duplicates "
+;; "(append (string-split \"" path "\" \":\") "
+;; "(string-split \"#{getenv PATH}\" \":\")))"
+;; " \":\")}")))
+
+(define (env:min-path path1 path2)
+ (string-intersperse
+ (delete-duplicates
+ (append
+ (string-split path1 ":")
+ (string-split path2 ":")))
+ ":"))
+
+;; inc path will set a PATH that is incrementally modified when read - config mode only
+;;
+(define (env:print added removed changed #!key (inc-path #t))
+ (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)
+ (let ((var (car dat))
+ (val (cdr dat)))
+ (if (and inc-path
+ (equal? var "PATH"))
+ (env:inc-path val)
+ (print var " " val))))
+ (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)
+ (let ((var (car dat))
+ (val (cdr dat)))
+ (if (and inc-path
+ (equal? var "PATH"))
+ (env:inc-path val)
+ (print var " " val))))
+ (hash-table->alist changed)))))
+ (else
+ (debug:print-error 0 *default-log-port* "No dumpmode specified, use -dumpmode [bash|csh|config]")))))
+
+)
Index: megatest.scm
==================================================================
--- megatest.scm
+++ megatest.scm
@@ -84,2745 +84,10 @@
(declare (uses diff-report))
(declare (uses runs))
(declare (uses launch))
(declare (uses server))
(declare (uses genexample))
-
-;; (include "debugmode.scm")
-
-;; (declare (uses daemon))
-
-;; (declare (uses dcommon))
-
-;; (declare (uses debugprint))
-;; (declare (uses debugprint.import))
-
-;; (declare (uses ftail))
-;; (import ftail)
-
-(import (prefix mtargs args:)
- debugprint
- dbmod
- commonmod
- processmod
- configfmod
- dbfile
- portlogger
- tcp-transportmod
- rmtmod
- apimod
- stml2
- mtmod
- megatestmod
- servermod
- tasksmod
- runsmod
- rmtmod
- launchmod
- fsmod
- )
-
-(define *db* #f) ;; this is only for the repl, do not use in general!!!!
-
-;; (include "common_records.scm")
-;; (include "key_records.scm")
-;; (include "db_records.scm")
-(include "run_records.scm")
-(include "megatest-fossil-hash.scm")
-
-(use (prefix sqlite3 sqlite3:) srfi-1 posix regex regex-case srfi-69 (prefix base64 base64:))
-(use readline apropos json http-client directory-utils typed-records)
-(use http-client srfi-18 extras format tcp-server tcp)
-
-;; Added for csv stuff - will be removed
-;;
-(use sparse-vectors)
-
-(require-library mutils)
-
-;; remove when configf fully modularized
-(read-config-set! configf:read-file)
-
-(define *usage-log-file* #f) ;; put path to file for logging usage in this var in the ~/.megatestrc file
-(define *usage-use-seconds* #t) ;; for Epoc seconds in usage logging change this to #t in ~/.megatestrc file
-
-;; set some parameters here - these need to be put in something that can be loaded from other
-;; executables such as dashboard and mtutil
-;;
-(include "transport-mode.scm")
-(dbfile:db-init-proc db:initialize-main-db)
-(debug:enable-timestamp #t)
-
-
-(set! rmtmod:send-receive rmt:send-receive)
- ;;(lambda params (apply rmt:send-receive params))) ;; make send-receive available to rmtmod via parameter
-
-
-;; load the ~/.megatestrc file, put (use trace)(trace-call-sites #t)(trace function-you-want-to-trace) in this file
-;;
-(let ((debugcontrolf (conc (get-environment-variable "HOME") "/.megatestrc")))
- (if (common:file-exists? debugcontrolf)
- (load debugcontrolf)))
-
-;; usage logging, careful with this, it is not designed to deal with all real world challenges!
-;;
-(if (and *usage-log-file*
- (file-write-access? *usage-log-file*))
- (with-output-to-file
- *usage-log-file*
- (lambda ()
- (print (if *usage-use-seconds*
- (current-seconds)
- (time->string
- (seconds->local-time (current-seconds))
- "%Yww%V.%w %H:%M:%S"))
- " "
- (current-user-name) " "
- (current-directory) " "
- "\"" (string-intersperse (argv) " ") "\""))
- #:append))
-
-;; Disabled help items
-;; -rollup : (currently disabled) fill run (set by :runname) with latest test(s)
-;; from prior runs with same keys
-;; -daemonize : fork into background and disconnect from stdin/out
-
-(define help (conc "
-Megatest, documentation at http://www.kiatoa.com/fossils/megatest
- version " megatest-version "
- license GPL, Copyright Matt Welland 2006-2017
-
-Usage: megatest [options]
- -h : this help
- -manual : show the Megatest user manual
- -version : print megatest version (currently " megatest-version ")
-
-Launching and managing runs
- -run : run all tests or as specified by -testpatt
- -remove-runs : remove the data for a run, requires -runname and -testpatt
- Optionally use :state and :status, use -keep-records to remove only
- the run data. Use -kill-wait to override the 10 second
- per test wait after kill delay (e.g. -kill-wait 0).
- -kill-runs : kill existing run(s) (all incomplete tests killed)
- -kill-rerun : kill an existing run (all incomplete tests killed and run is rerun)
- -set-state-status X,Y : set state to X and status to Y, requires controls per -remove-runs
- -rerun FAIL,WARN... : force re-run for tests with specificed status(s)
- -rerun-clean : set all tests not COMPLETED+PASS,WARN,WAIVED to NOT_STARTED,n/a
- and then run the specified testpatt with -preclean
- -rerun-all : set all tests to NOT_STARTED,n/a and run with -preclean
- -lock : lock run specified by target and runname
- -unlock : unlock run specified by target and runname
- -set-run-status status : sets status for run to status, requires -target and -runname
- -get-run-status : gets status for run specified by target and runname
- -run-wait : wait on run specified by target and runname
- -preclean : remove the existing test directory before running the test
- -clean-cache : remove the cached megatest.config and runconfigs.config files
- -no-cache : do not use the cached config files.
- -one-pass : launch as many tests as you can but do not wait for more to be ready
- -remove-keep N : remove all but N most recent runs per target; use '-actions, -age, -precmd'
- -age : 120d,3h,20m to apply only to runs older than the
- specified age. NB// M=month, m=minute
- -actions [,...] : actions to take; print,remove-runs,archive,kill-runs
- -precmd : insert a wrapper command in front of the commands run
-
-Selectors (e.g. use for -runtests, -remove-runs, -set-state-status, -list-runs etc.)
- -target key1/key2/... : run for key1, key2, etc.
- -reqtarg key1/key2/... : run for key1, key2, etc. but key1/key2 must be in runconfigs
- -testpatt patt1/patt2,patt3/... : % is wildcard
- -runname : required, name for this particular test run
- -state : Applies to runs, tests or steps depending on context
- -status : Applies to runs, tests or steps depending on context
- -modepatt key : load testpatt from in runconfigs instead of default TESTPATT if -testpatt and -tagexpr are not specified
- -tagexpr tag1,tag2%,.. : select tests with tags matching expression
-
-
-Test helpers (for use inside tests)
- -step stepname
- -test-status : set the state and status of a test (use :state and :status)
- -setlog logfname : set the path/filename to the final log relative to the test
- directory. may be used with -test-status
- -set-toplog logfname : set the overall log for a suite of sub-tests
- -summarize-items : for an itemized test create a summary html
- -m comment : insert a comment for this test
-
-Test data capture
- -set-values : update or set values in the testdata table
- :category : set the category field (optional)
- :variable : set the variable name (optional)
- :value : value measured (required)
- :expected : value expected (required)
- :tol : |value-expect| <= tol (required, can be <, >, >=, <= or number)
- :units : name of the units for value, expected_value etc. (optional)
- -load-test-data : read test specific data for storage in the test_data table
- from standard in. Each line is comma delimited with four
- fields category,variable,value,comment
-
-Queries
- -list-runs patt : list runs matching pattern \"patt\", % is the wildcard
- -show-keys : show the keys used in this megatest setup
- -test-files targpatt : get the most recent test path/file matching targpatt e.g. %/% or '*.log'
- returns list sorted by age ascending, see examples below
- -test-paths : get the test paths matching target, runname, item and test
- patterns.
- -list-disks : list the disks available for storing runs
- -list-targets : list the targets in runconfigs.config
- -list-db-targets : list the target combinations used in the db
- -show-config : dump the internal representation of the megatest.config file
- -show-runconfig : dump the internal representation of the runconfigs.config file
- -dumpmode MODE : dump in MODE format instead of sexpr, MODE=json,ini,sexp etc. (add -debug 0,9 to see which file contributes each line)
- -show-cmdinfo : dump the command info for a test (run in test environment)
- -section sectionName
- -var varName : for config and runconfig lookup value for sectionName varName
- -since N : get list of runs changed since time N (Unix seconds)
- -fields fieldspec : fields to include in json dump; runs:id,runame+tests:testname+steps
- -sort fieldname : in -list-runs sort tests by this field
- -testdata-csv [categorypatt/]varpatt : dump testdata for given category
-
-Misc
- -start-dir path : switch to this directory before running megatest
- -contour cname : add a level of hierarcy to the linktree and run paths
- -area-tag tagname : add a tag to an area while syncing to pgdb
- -run-tag tagname : add a tag to a run while syncing to pgdb
- -rebuild-db : bring the database schema up to date
- -cleanup-db : remove any orphan records, vacuum the db
- -import-megatest.db : push data from megatest.db to cache db files in /tmp/$USER
- -sync-to-megatest.db : pull data from cache files in /tmp/$USER to megatest.db
- -sync-to dest : sync to new postgresql central style database
- -update-meta : update the tests metadata for all tests
- -setvars VAR1=val1,VAR2=val2 : Add environment variables to a run NB// these are
- overwritten by values set in config files.
- -server -|hostname : start the server (reduces contention on megatest.db), use
- - to automatically figure out hostname
- -adjutant C,M : start the server/adjutant with allocated cores C and Mem M (Gig),
- use 0,0 to auto use full machine
- -transport http|rpc : use http or rpc for transport (default is http)
- -log logfile : send stdout and stderr to logfile
- -list-servers : list the servers
- -kill-servers : kill all servers
- -repl : start a repl (useful for extending megatest)
- -load file.scm : load and run file.scm
- -mark-incompletes : find and mark incomplete tests
- -ping run-id|host:port : ping server, exit with 0 if found
- -debug N|N,M,O... : enable debug 0-N or N and M and O ...
- -debug-noprop N|M,M,O...: enable debug but do not propagate to subprocesses via MT_DEBUG
- -config fname : override the megatest.config file with fname
- -append-config fname : append fname to the megatest.config file
- -import-sexpr fname : import a sexpr file (use -list-runs % -dumpmode sexpr to create)
- -remove-dbs all : remove Megatest DBs before importing sexpr. (Use only with -import-sexpr)
- -regen-testfiles : regenerate scripts and logpro files from testconfig, run in test context
-
-Utilities
- -env2file fname : write the environment to fname.csh and fname.sh
- -envcap a : save current variables labeled as context 'a' in file envdat.db
- -envdelta a-b : output enviroment delta from context a to context b to -o fname
- set the output mode with -dumpmode csh, bash or ini
- note: ini format will use calls to use curr and minimize path
- -refdb2dat refdb : convert refdb to sexp or to format specified by s-dumpmode
- formats: perl, ruby, sqlite3, csv (for csv the -o param
- will substitute %s for the sheet name in generating
- multiple sheets)
- -o : output file for refdb2dat (defaults to stdout)
- -archive cmd : archive runs specified by selectors to one of disks specified
- in the [archive-disks] section.
- cmd: keep-html, restore, save, save-remove, get, replicate-db (use
- -dest to set destination), -include path1,path2... to get or save specific files
- -generate-html : create a simple html dashboard for browsing your runs
- -generate-html-structure : create a top level html veiw to list targets/runs and a Run view within each run directory.
- -list-run-time : list time requered to complete runs. It supports following switches
- -run-patt -target-patt -dumpmode
- -list-test-time : list time requered to complete each test in a run. It following following arguments
- -runname -target -dumpmode
- -syscheck : do some very basic checks; write access and space in tmp, home, runs, links and
- is $DISPLAY valid
- -list-waivers : dump waivers for specified target, runname, testpatt to stdout
- -db2db : sync db to db, use -from, -to for dbs, -period and -timeout for continuous sync
-
-Diff report
- -diff-rep : generate diff report (must include -src-target, -src-runname, -target, -runname
- and either -diff-email or -diff-html)
- -src-target
- -src-runname
- -diff-email : comma separated list of email addresses to send diff report
- -diff-html : path to html file to generate
-
-Spreadsheet generation
- -extract-ods fname.ods : extract an open document spreadsheet from the database
- -pathmod path : insert path, i.e. path/runame/itempath/logfile.html
- will clear the field if no rundir/testname/itempath/logfile
- if it contains forward slashes the path will be converted
- to windows style
-Getting started
- -create-megatest-area : create a skeleton megatest area. You will be prompted for paths
- -create-test testname : create a skeleton megatest test. You will be prompted for info
-
-Examples
-
-# Get test path, use '.' to get a single path or a specific path/file pattern
-megatest -test-files 'logs/*.log' -target ubuntu/n%/no% -runname w49% -testpatt test_mt%
-
-Called as " (string-intersperse (argv) " ") "
-Version " megatest-version ", built from " megatest-fossil-hash ))
-
-;; -gui : start a gui interface
-;; -config fname : override the runconfigs file with fname
-
-;; process args
-(define remargs (args:get-args
- (argv)
- (list "-runtests" ;; run a specific test
- "-config" ;; override the config file name
- "-append-config"
- "-execute" ;; run the command encoded in the base64 parameter
- "-step"
- "-target"
- "-reqtarg"
- ":runname"
- "-runname"
- ":state"
- "-state"
- ":status"
- "-status"
- "-list-runs"
- "-testdata-csv"
- "-testpatt"
- ;; "--modepatt"
- "-modepatt"
- "-tagexpr"
- "-itempatt"
- "-setlog"
- "-set-toplog"
- "-runstep"
- "-logpro"
- "-m"
- "-rerun"
-
- "-days"
- "-rename-run"
- "-from"
- "-to"
- "-dest"
- "-source"
- "-time-stamp"
- ;; values and messages
- ":category"
- ":variable"
- ":value"
- ":expected"
- ":tol"
- ":units"
-
- ;; misc
- "-start-dir"
- "-run-patt"
- "-target-patt"
- "-contour"
- "-area-tag"
- "-area"
- "-run-tag"
- "-server"
- "-adjutant"
- "-transport"
- "-port"
- "-extract-ods"
- "-pathmod"
- "-env2file"
- "-envcap"
- "-envdelta"
- "-setvars"
- "-set-state-status"
- "-import-sexpr"
- "-remove-dbs" ;; to be used only with -import-sexpr to remove megatest dbs first.
- "-period" ;; sync period in seconds
- "-timeout" ;; exit sync if timeout in seconds exceeded since last change
-
- ;; move runs stuff here
- "-remove-keep"
- "-set-run-status"
- "-age"
-
- ;; archive
- "-archive"
- "-actions"
- "-precmd"
- "-include"
- "-exclude-rx"
- "-exclude-rx-from"
-
- "-debug" ;; for *verbosity* > 2
- "-debug-noprop"
- "-create-test"
- "-override-timeout"
- "-test-files" ;; -test-paths is for listing all
- "-load" ;; load and exectute a scheme file
- "-section"
- "-var"
- "-dumpmode"
- "-run-id"
- "-db"
- "-ping"
- "-refdb2dat"
- "-o"
- "-log"
- "-sync-log"
- "-since"
- "-fields"
- "-recover-test" ;; run-id,test-id - used internally to recover a test stuck in RUNNING state
- "-sort"
- "-target-db"
- "-source-db"
- "-prefix-target"
-
- "-src-target"
- "-src-runname"
- "-diff-email"
- "-sync-to"
- "-pgsync"
- "-kill-wait" ;; wait this long before removing test (default is 10 sec)
- "-diff-html"
-
- ;; wizards, area capture, setup new ...
- "-extract-skeleton"
- )
- (list "-h" "-help" "--help"
- "-manual"
- "-version"
- "-force"
- "-xterm"
- "-showkeys"
- "-show-keys"
- "-test-status"
- "-set-values"
- "-load-test-data"
- "-summarize-items"
- "-gui"
- "-daemonize"
- "-preclean"
- "-rerun-clean"
- "-rerun-all"
- "-clean-cache"
- "-no-cache"
- "-cache-db"
- "-cp-eventtime-to-publishtime"
- "-use-db-cache"
- "-prepend-contour"
-
-
- ;; misc
- "-repl"
- "-lock"
- "-unlock"
- "-list-servers"
- "-kill-servers"
- "-run-wait" ;; wait on a run to complete (i.e. no RUNNING)
- "-one-pass" ;;
- "-local" ;; run some commands using local db access
- "-generate-html"
- "-generate-html-structure"
- "-list-run-time"
- "-list-test-time"
- "-regen-testfiles"
-
- ;; misc queries
- "-list-disks"
- "-list-targets"
- "-list-db-targets"
- "-show-runconfig"
- "-show-config"
- "-show-cmdinfo"
- "-get-run-status"
- "-list-waivers"
-
- ;; queries
- "-test-paths" ;; get path(s) to a test, ordered by youngest first
-
- "-runall" ;; run all tests, respects -testpatt, defaults to %
- "-run" ;; alias for -runall
- "-remove-runs"
- "-kill-runs"
- "-kill-rerun"
- "-keep-records" ;; use with -remove-runs to remove only the run data
- "-rebuild-db"
- "-cleanup-db"
- "-rollup"
- "-update-meta"
- "-create-megatest-area"
- "-mark-incompletes"
-
- "-convert-to-norm"
- "-convert-to-old"
- "-import-megatest.db"
- "-sync-to-megatest.db"
- "-db2db"
- "-sync-brute-force"
- "-logging"
- "-v" ;; verbose 2, more than normal (normal is 1)
- "-q" ;; quiet 0, errors/warnings only
-
- "-diff-rep"
-
- "-syscheck"
- "-obfuscate"
- ;; junk placeholder
- ;; "-:p"
-
- )
- args:arg-hash
- 0))
-
-;; Add args that use remargs here
-;;
-(if (and (not (null? remargs))
- (not (or
- (args:get-arg "-runstep")
- (args:get-arg "-envcap")
- (args:get-arg "-envdelta")
- )
- ))
- (debug:print-error 0 *default-log-port* "Unrecognised arguments: " (string-intersperse (if (list? remargs) remargs (argv)) " ")))
-
-;; before doing anything else change to the start-dir if provided
-;;
-(if (args:get-arg "-start-dir")
- (if (common:file-exists? (args:get-arg "-start-dir"))
- (let ((fullpath (common:real-path (args:get-arg "-start-dir"))))
- (setenv "PWD" fullpath)
- (change-directory fullpath))
- (begin
- (debug:print-error 0 *default-log-port* "non-existant start dir " (args:get-arg "-start-dir") " specified, exiting.")
- (exit 1))))
-
-;; immediately set MT_TARGET if -reqtarg or -target are available
-;;
-(let ((targ (or (args:get-arg "-reqtarg")(args:get-arg "-target"))))
- (if targ (setenv "MT_TARGET" targ)))
-
-;; set the purpose field in procinf
-
-(procinf-purpose-set! *procinf* (get-purpose args:arg-hash))
-(procinf-mtversion-set! *procinf* megatest-version)
-
-;; The watchdog is to keep an eye on things like db sync etc.
-;;
-
-;; TODO: for multiple areas, we will have multiple watchdogs; and multiple threads to manage
-;;(define *watchdog* (make-thread
-;; (lambda ()
-;; (handle-exceptions
-;; exn
-;; (begin
-;; (print-call-chain)
-;; (print " message: " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn))
-;; (common:watchdog)))
-;; "Watchdog thread"))
-
-;;(if (not (args:get-arg "-server"))
-;; (thread-start! *watchdog*)) ;; if starting a server; wait till we get to running state before kicking off watchdog
-(let* ((no-watchdog-args
- '("-list-runs"
- "-testdata-csv"
- "-list-servers"
- "-server"
- "-adjutant"
- "-list-disks"
- "-list-targets"
- "-show-runconfig"
- ;;"-list-db-targets"
- "-show-runconfig"
- "-show-config"
- "-show-cmdinfo"
- "-cleanup-db"
- ))
- (no-watchdog-argvals (list '("-archive" . "replicate-db")))
- (start-watchdog-specail-arg-val (let loop ((hed (car no-watchdog-argvals))
- (tail (cdr no-watchdog-argvals)))
- ;; (print "hed" hed " arg " (args:get-arg (car hed)) " val:" (cdr hed) " eql" (equal? (args:get-arg (car hed)) (cdr hed)))
- (if (equal? (args:get-arg (car hed)) (cdr hed))
- #f
- (if (null? tail)
- #t
- (loop (car tail) (cdr tail))))))
- (no-watchdog-args-vals (filter (lambda (x) x)
- (map args:get-arg no-watchdog-args)))
- (start-watchdog (and (null? no-watchdog-args-vals) start-watchdog-specail-arg-val)))
- ;(print "no-watchdog-args="no-watchdog-args "no-watchdog-args-vals="no-watchdog-args-vals " start-watchdog-specail-arg-val:" start-watchdog-specail-arg-val " start-watchdog:" start-watchdog)
-;; (if start-watchdog
-;; (thread-start! *watchdog*))
- #t
-)
-
-;; stop the train watchdog
-(stop-the-train)
-
-;; bracket open-output-file with code to make leading directory if it does not exist and handle exceptions
-(define (open-logfile logpath-in)
- (condition-case
- (let* ((log-dir (or (pathname-directory logpath-in) "."))
- (fname (pathname-strip-directory logpath-in))
- (logpath (if (> (string-length fname) 250)
- (let ((newlogf (conc log-dir "/" (common:get-signature fname) ".log")))
- (debug:print 0 *default-log-port* "WARNING: log file " logpath-in " path too long, converted to " newlogf)
- newlogf)
- logpath-in)))
- (if (not (directory-exists? log-dir))
- (system (conc "mkdir -p " log-dir)))
- (open-output-file logpath))
- (exn ()
- (debug:print-error 0 *default-log-port* "Could not open log file for write: "logpath)
- (define *didsomething* #t)
- (exit 1))))
-
-;; this segment will run launch:setup only if -log is not set. This is fairly safe as servers are not
-;; manually started and thus should never be started in a non-megatest area. Thus no need to handle situation
-;; where (launch:setup) returns #f?
-;;
-(if (or (args:get-arg "-log")#;(args:get-arg "-server")) ;; redirect the log always when a server
- (handle-exceptions
- exn
- (begin
- (print "ERROR: Failed to switch to log output. " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn))
- (let* ((tl (or (args:get-arg "-log")(launch:setup))) ;; run launch:setup if -server, ensure we do NOT run launch:setup if -log specified
- (dbname (args:get-arg "-db")) ;; for the server logfile name
- (logf (or (args:get-arg "-log") ;; use -log unless we are a server, then craft a logfile name
- (conc tl "/logs/server-"(or dbname "unk")"-"(current-process-id) "-" (get-host-name) ".log")))
- (oup (open-logfile logf)))
- (if (not (args:get-arg "-log"))
- (hash-table-set! args:arg-hash "-log" logf)) ;; fake out future queries of -log
- (debug:print-info 0 *default-log-port* "Sending log output to " logf)
- (set! *default-log-port* oup))))
-
-(if (or (args:get-arg "-h")
- (args:get-arg "-help")
- (args:get-arg "--help"))
- (begin
- (print help)
- (exit)))
-
-(if (args:get-arg "-manual")
- (let* ((htmlviewercmd (or (configf:lookup *configdat* "setup" "htmlviewercmd")
- (common:which '("firefox" "arora"))))
- (install-home (common:get-install-area))
- (manual-html (conc install-home "/share/docs/megatest_manual.html")))
- (if (and install-home
- (common:file-exists? manual-html))
- (system (conc "(" htmlviewercmd " " manual-html " ) &"))
- (system (conc "(" htmlviewercmd " http://www.kiatoa.com/cgi-bin/fossils/megatest/doc/tip/docs/manual/megatest_manual.html ) &")))
- (exit)))
-
-(if (args:get-arg "-version")
- (begin
- (print (common:version-signature)) ;; (print megatest-version)
- (exit)))
-
-(define *didsomething* #f)
-
-;; Overall exit handling setup immediately
-;;
-(if (or (args:get-arg "-process-reap"))
- ;; (args:get-arg "-runtests")
- ;; (args:get-arg "-execute")
- ;; (args:get-arg "-remove-runs")
- ;; (args:get-arg "-runstep"))
- (let ((original-exit (exit-handler)))
- (exit-handler (lambda (#!optional (exit-code 0))
- (printf "Preparing to exit with exit code ~A ...\n" exit-code)
- (for-each
-
- (lambda (pid)
- (handle-exceptions
- exn
- (begin
- (printf "process reap failed. exn=~A\n" exn)
- #t)
- (let-values (((pid-val exit-status exit-code) (process-wait pid #t)))
- (if (or (eq? pid-val pid)
- (eq? pid-val 0))
- (begin
- (printf "Sending signal/term to ~A\n" pid)
- (process-signal pid signal/term))))))
- (process:children #f))
- (original-exit exit-code)))))
-
-;; for some switches always print the command to stderr
-;;
-(if (args:any-defined? "-run" "-runall" "-remove-runs" "-set-state-status" "-kill-runs" "-kill-rerun")
- (debug:print 0 *default-log-port* (string-intersperse (argv) " ")))
-
-
-;;======================================================================
-;; Misc setup stuff
-;;======================================================================
-
-(debug:setup)
-
-(if (args:get-arg "-logging")(set! *logging* #t))
-
-;;(if (debug:debug-mode 3) ;; we are obviously debugging
-;; (set! open-run-close open-run-close-no-exception-handling))
-
-(if (args:get-arg "-itempatt")
- (let ((newval (conc (args:get-arg "-testpatt") "/" (args:get-arg "-itempatt"))))
- (debug:print 0 *default-log-port* "WARNING: -itempatt has been deprecated, please use -testpatt testpatt/itempatt method, new testpatt is "newval)
- (hash-table-set! args:arg-hash "-testpatt" newval)
- (hash-table-delete! args:arg-hash "-itempatt")))
-
-(if (args:get-arg "-runtests")
- (debug:print 0 *default-log-port* "WARNING: \"-runtests\" is deprecated. Use \"-run\" with \"-testpatt\" instead"))
-
-(on-exit std-exit-procedure)
-
-;;======================================================================
-;; Misc general calls
-;;======================================================================
-
-(if (and (args:get-arg "-cache-db")
- (args:get-arg "-source-db"))
- (let* ((temp-dir (or (args:get-arg "-target-db") (create-directory (conc "/tmp/" (getenv "USER") "/" (string-translate (current-directory) "/" "_")))))
- (target-db (conc temp-dir "/cached.db"))
- (source-db (args:get-arg "-source-db")))
- (db:cache-for-read-only source-db target-db)
- (set! *didsomething* #t)))
-
-;; handle a clean-cache request as early as possible
-;;
-(if (args:get-arg "-clean-cache")
- (let ((toppath (launch:setup)))
- (set! *didsomething* #t) ;; suppress the help output.
- (runs:clean-cache (common:args-get-target)
- (args:get-arg "-runname")
- toppath)))
-
-(if (args:get-arg "-env2file")
- (begin
- (save-environment-as-files (args:get-arg "-env2file"))
- (set! *didsomething* #t)))
-
-(if (args:get-arg "-list-disks")
- (let ((toppath (launch:setup)))
- (print (string-intersperse
- (map (lambda (x)
- (string-intersperse
- x
- " => "))
- (common:get-disks *configdat*))
- "\n"))
- (set! *didsomething* #t)))
-
-;; csv processing record
-(define (make-refdb:csv)
- (vector
- (make-sparse-array)
- (make-hash-table)
- (make-hash-table)
- 0
- 0))
-(define-inline (refdb:csv-get-svec vec) (vector-ref vec 0))
-(define-inline (refdb:csv-get-rows vec) (vector-ref vec 1))
-(define-inline (refdb:csv-get-cols vec) (vector-ref vec 2))
-(define-inline (refdb:csv-get-maxrow vec) (vector-ref vec 3))
-(define-inline (refdb:csv-get-maxcol vec) (vector-ref vec 4))
-(define-inline (refdb:csv-set-svec! vec val)(vector-set! vec 0 val))
-(define-inline (refdb:csv-set-rows! vec val)(vector-set! vec 1 val))
-(define-inline (refdb:csv-set-cols! vec val)(vector-set! vec 2 val))
-(define-inline (refdb:csv-set-maxrow! vec val)(vector-set! vec 3 val))
-(define-inline (refdb:csv-set-maxcol! vec val)(vector-set! vec 4 val))
-
-(define (get-dat results sheetname)
- (or (hash-table-ref/default results sheetname #f)
- (let ((tmp-vec (make-refdb:csv)))
- (hash-table-set! results sheetname tmp-vec)
- tmp-vec)))
-
-(if (args:get-arg "-refdb2dat")
- (let* ((input-db (args:get-arg "-refdb2dat"))
- (out-file (args:get-arg "-o"))
- (out-fmt (or (args:get-arg "-dumpmode") "scheme"))
- (out-port (if (and out-file
- (not (member out-fmt '("sqlite3" "csv"))))
- (open-output-file out-file)
- (current-output-port)))
- (res-data (configf:read-refdb input-db))
- (data (car res-data))
- (msg (cadr res-data)))
- (if (not data)
- (debug:print 0 *default-log-port* "Bad input? data=" data) ;; some error occurred
- (with-output-to-port out-port
- (lambda ()
- (case (string->symbol out-fmt)
- ((scheme)(pp data))
- ((perl)
- ;; (print "%hash = (")
- ;; key1 => 'value1',
- ;; key2 => 'value2',
- ;; key3 => 'value3',
- ;; );
- (configf:map-all-hier-alist
- data
- (lambda (sheetname sectionname varname val)
- (print "$data{\"" sheetname "\"}{\"" sectionname "\"}{\"" varname "\"} = \"" val "\";"))))
- ((python ruby)
- (print "data={}")
- (configf:map-all-hier-alist
- data
- (lambda (sheetname sectionname varname val)
- (print "data[\"" sheetname "\"][\"" sectionname "\"][\"" varname "\"] = \"" val "\""))
- initproc1:
- (lambda (sheetname)
- (print "data[\"" sheetname "\"] = {}"))
- initproc2:
- (lambda (sheetname sectionname)
- (print "data[\"" sheetname "\"][\"" sectionname "\"] = {}"))))
- ((csv)
- (let* ((results (make-hash-table)) ;; (make-sparse-array)))
- (row-cols (make-hash-table))) ;; hash of hashes where section => ht { row- => num or col- => num
- ;; (print "data=")
- ;; (pp data)
- (configf:map-all-hier-alist
- data
- (lambda (sheetname sectionname varname val)
- ;; (print "sheetname: " sheetname ", sectionname: " sectionname ", varname: " varname ", val: " val)
- (let* ((dat (get-dat results sheetname))
- (vec (refdb:csv-get-svec dat))
- (rownames (refdb:csv-get-rows dat))
- (colnames (refdb:csv-get-cols dat))
- (currrown (hash-table-ref/default rownames varname #f))
- (currcoln (hash-table-ref/default colnames sectionname #f))
- (rown (or currrown
- (let* ((lastn (refdb:csv-get-maxrow dat))
- (newrown (+ lastn 1)))
- (refdb:csv-set-maxrow! dat newrown)
- newrown)))
- (coln (or currcoln
- (let* ((lastn (refdb:csv-get-maxcol dat))
- (newcoln (+ lastn 1)))
- (refdb:csv-set-maxcol! dat newcoln)
- newcoln))))
- (if (not (sparse-array-ref vec 0 coln)) ;; (eq? rown 0)
- (begin
- (sparse-array-set! vec 0 coln sectionname)
- ;; (print "sparse-array-ref " 0 "," coln "=" (sparse-array-ref vec 0 coln))
- ))
- (if (not (sparse-array-ref vec rown 0)) ;; (eq? coln 0)
- (begin
- (sparse-array-set! vec rown 0 varname)
- ;; (print "sparse-array-ref " rown "," 0 "=" (sparse-array-ref vec rown 0))
- ))
- (if (not currrown)(hash-table-set! rownames varname rown))
- (if (not currcoln)(hash-table-set! colnames sectionname coln))
- ;; (print "dat=" dat ", rown=" rown ", coln=" coln)
- (sparse-array-set! vec rown coln val)
- ;; (print "sparse-array-ref " rown "," coln "=" (sparse-array-ref vec rown coln))
- )))
- (for-each
- (lambda (sheetname)
- (let* ((sheetdat (get-dat results sheetname))
- (svec (refdb:csv-get-svec sheetdat))
- (maxrow (refdb:csv-get-maxrow sheetdat))
- (maxcol (refdb:csv-get-maxcol sheetdat))
- (fname (if out-file
- (string-substitute "%s" sheetname out-file) ;; "/foo/bar/%s.csv")
- (conc sheetname ".csv"))))
- (with-output-to-file fname
- (lambda ()
- ;; (print "Sheetname: " sheetname)
- (let loop ((row 0)
- (col 0)
- (curr-row '())
- (result '()))
- (let* ((val (sparse-array-ref svec row col))
- (disp-val (if val
- (conc "\"" val "\"")
- "")))
- (if (> col 0)(display ","))
- (display disp-val)
- (cond
- ((> row maxrow)(display "\n") result)
- ((>= col maxcol)
- (display "\n")
- (loop (+ row 1) 0 '() (append result (list curr-row))))
- (else
- (loop row (+ col 1) (append curr-row (list val)) result)))))))))
- (hash-table-keys results))))
- ((sqlite3)
- (let* ((db-file (or out-file (pathname-file input-db)))
- (db-exists (common:file-exists? db-file))
- (db (sqlite3:open-database db-file)))
- (if (not db-exists)(sqlite3:execute db "CREATE TABLE data (sheet,section,var,val);"))
- (configf:map-all-hier-alist
- data
- (lambda (sheetname sectionname varname val)
- (sqlite3:execute db
- "INSERT OR REPLACE INTO data (sheet,section,var,val) VALUES (?,?,?,?);"
- sheetname sectionname varname val)))
- (sqlite3:finalize! db)))
- (else
- (pp data))))))
- (if out-file (close-output-port out-port))
- (exit) ;; yes, bending the rules here - need to exit since this is a utility
- ))
-
-(if (args:get-arg "-ping")
- (let* ((server-id (string->number (args:get-arg "-ping"))) ;; extract run-id (i.e. no ":"
- (host:port (args:get-arg "-ping")))
- (debug:print 0 *default-log-port* "NOT YET REIMPLEMENTED FOR TCP/INMEM") ;; bug
- (exit)))
- ;; (server:ping (or server-id host:port) #f do-exit: #t)))
-
-;;======================================================================
-;; 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-error 0 *default-log-port* "Parameter to -envdelta should be new=start-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
-;;======================================================================
-
-;; Server? Start up here.
-;;
-(if (args:get-arg "-server")
- (let* (;; (run-id (args:get-arg "-run-id"))
- (dbfname (args:get-arg "-db"))
- (tl (launch:setup))
- (keys (keys:config-get-fields *configdat*)))
- (case (rmt:transport-mode)
- ((tcp)
- (let* ((timeout (server:expiration-timeout)))
- (debug:print 0 *default-log-port* "INFO: megatest -server starting on " (get-host-name) " for " dbfname " using tcp method with timeout of "timeout)
- (tt-server-timeout-param timeout)
- (api:queue-processor)
- (thread-start! (make-thread api:print-db-stats "print-db-stats"))
- (if dbfname
- (tt:start-server tl #f dbfname api:tcp-dispatch-request-make-handler keys)
- (begin
- (debug:print 0 *default-log-port* "ERROR: transport mode is tcp - -db is required.")
- (exit 1)))))
- ((nfs)(debug:print 0 *default-log-port* "WARNING: server start called in nfs mode '"(rmt:transport-mode)))
- (else (debug:print 0 *default-log-port* "ERROR: rmt:transport-mode value not recognised "(rmt:transport-mode))))
- (set! *didsomething* #t)))
-
-;; The adjutant is a bit different, it does NOT run (launch:setup) as it is not necessarily tied to
-;; a specific Megatest area. Detail are being hashed out and this may change.
-;;
-(if (args:get-arg "-adjutant")
- (begin
- (adjutant-run)
- (set! *didsomething* #t)))
-
-(if (args:get-arg "-list-servers")
- (let* ((tl (launch:setup)) ;; need this to initialize *toppath*
- (servdir (tt:get-servinfo-dir *toppath*))
- (servfiles (glob (conc servdir "/*:*.db")))
- (fmtstr "~10a~22a~10a~25a~25a~8a\n")
- (dbfiles (append (glob (conc *toppath* "/.mtdb/main.db")) (glob (conc *toppath* "/.mtdb/?.db"))(glob (conc *toppath* "/.mtdb/??.db"))))
- (ttdat (make-tt areapath: *toppath*))
- )
- (format #t fmtstr "DB" "host:port" "PID" "age" "last mod" "state")
- (for-each
- (lambda (dbfile)
- (let* (
- (dbfname (conc (pathname-file dbfile) ".db"))
- (sfiles (tt:find-server *toppath* dbfname))
- )
- (for-each
- (lambda (sfile)
- (let (
- (sinfos (tt:get-server-info-sorted ttdat dbfname))
- )
- (for-each
- (lambda (sinfo)
- (let* (
- (db (list-ref sinfo 5))
- (pid (list-ref sinfo 4))
- (host (list-ref sinfo 0))
- (port (list-ref sinfo 1))
- (server-id (list-ref sinfo 3))
- (age (seconds->hr-min-sec (- (current-seconds) (list-ref sinfo 2))))
- (last-mod (seconds->string (list-ref sinfo 2)))
- (status (system (conc "ssh " host " ps " pid " > /dev/null")))
- (state (if (> status 0)
- "dead"
- (tt:ping host port server-id 0)
- ))
- )
- (format #t fmtstr db (conc host ":" port) pid age last-mod state)
- )
- )
- sinfos
- )
- )
- )
- sfiles
- )
- )
- )
- dbfiles
- )
- (set! *didsomething* #t)
- (exit)
- )
-)
-
-
-
-
-(if (args:get-arg "-kill-servers")
-
- (let* ((tl (launch:setup)) ;; need this to initialize *toppath*
- (servdir (tt:get-servinfo-dir *toppath*))
- (servfiles (glob (conc servdir "/*:*.db")))
- (fmtstr "~10a~22a~10a~25a~25a~8a\n")
- (dbfiles (if (file-exists? (conc *toppath* "/.mtdb/main.db")) (append (glob (conc *toppath* "/.mtdb/main.db")) (glob (conc *toppath* "/.mtdb/?.db"))(glob (conc *toppath* "/.mtdb/??.db"))) '()))
- (ttdat (make-tt areapath: *toppath*))
- )
- (format #t fmtstr "DB" "host:port" "PID" "age" "last mod" "state")
- (for-each
- (lambda (dbfile)
- (let* (
- (dbfname (conc (pathname-file dbfile) ".db"))
- (sfiles (tt:find-server *toppath* dbfname))
- )
- (for-each
- (lambda (sfile)
- (let (
- (sinfos (tt:get-server-info-sorted ttdat dbfname))
- )
- (for-each
- (lambda (sinfo)
- (let* (
- (db (list-ref sinfo 5))
- (pid (list-ref sinfo 4))
- (host (list-ref sinfo 0))
- (port (list-ref sinfo 1))
- (server-id (list-ref sinfo 3))
- (age (seconds->hr-min-sec (- (current-seconds) (list-ref sinfo 2))))
- (last-mod (seconds->string (list-ref sinfo 2)))
- (killed (system (conc "ssh " host " kill " pid " > /dev/null")))
- (dummy2 (sleep 1))
- (state (if (> (system (conc "ssh " host " ps " pid " > /dev/null")) 0) "dead" "alive"))
- )
- (format #t fmtstr db (conc host ":" port) pid age last-mod state)
- (system (conc "rm " sfile))
- )
- )
- sinfos
- )
- )
- )
- sfiles
- )
- )
- )
- dbfiles
- )
- ;; remove this db, because otherwise metadata contains records for old servers, and this causes a problem with db:no-sync-get-lock-with-id.
- (if (file-exists? (conc *toppath* "/.mtdb/no-sync.db"))
- (delete-file (conc *toppath* "/.mtdb/no-sync.db"))
- )
- (set! *didsomething* #t)
- (exit)
- )
-)
-
-;;======================================================================
-;; Weird special calls that need to run *after* the server has started?
-;;======================================================================
-
-(if (args:get-arg "-list-targets")
- (if (launch:setup)
- (let ((targets (common:get-runconfig-targets)))
- ;; (debug:print 1 *default-log-port* "Found "(length targets) " targets")
- (case (string->symbol (or (args:get-arg "-dumpmode") "alist"))
- ((alist)
- (for-each (lambda (x)
- ;; (print "[" x "]"))
- (print x))
- targets))
- ((json)
- (json-write targets))
- (else
- (debug:print-error 0 *default-log-port* "dump output format " (args:get-arg "-dumpmode") " not supported for -list-targets")))
- (set! *didsomething* #t))))
-
-(if (args:get-arg "-show-runconfig")
- (let ((tl (launch:setup)))
- (push-directory *toppath*)
- (let ((data (full-runconfigs-read)))
- ;; keep this one local
- (cond
- ((and (args:get-arg "-section")
- (args:get-arg "-var"))
- (let ((val (or (configf:lookup data (args:get-arg "-section")(args:get-arg "-var"))
- (configf:lookup data "default" (args:get-arg "-var")))))
- (if val (print val))))
- ((or (not (args:get-arg "-dumpmode"))
- (string=? (args:get-arg "-dumpmode") "ini"))
- (configf:config->ini data))
- ((string=? (args:get-arg "-dumpmode") "sexp")
- (pp (hash-table->alist data)))
- ((string=? (args:get-arg "-dumpmode") "json")
- (json-write data))
- (else
- (debug:print-error 0 *default-log-port* "-dumpmode of " (args:get-arg "-dumpmode") " not recognised")))
- (set! *didsomething* #t))
- (pop-directory)))
-
-(if (args:get-arg "-show-config")
- (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")
- (args:get-arg "-var"))
- (let ((val (configf:lookup data (args:get-arg "-section")(args:get-arg "-var"))))
- (if val (print val))))
-
- ;; print just a section if only -section
-
- ((equal? (args:get-arg "-dumpmode") "sexp")
- (pp (hash-table->alist data)))
- ((equal? (args:get-arg "-dumpmode") "json")
- (json-write data))
- ((or (not (args:get-arg "-dumpmode"))
- (string=? (args:get-arg "-dumpmode") "ini"))
- (configf:config->ini data))
- (else
- (debug:print-error 0 *default-log-port* "-dumpmode of " (args:get-arg "-dumpmode") " not recognised")))
- (set! *didsomething* #t)
- (pop-directory)
- (set! *time-to-exit* #t)))
-
-(if (args:get-arg "-show-cmdinfo")
- (if (or (args:get-arg ":value")(getenv "MT_CMDINFO"))
- (let ((data (common:read-encoded-string (or (args:get-arg ":value")(getenv "MT_CMDINFO")))))
- (if (equal? (args:get-arg "-dumpmode") "json")
- (json-write data)
- (pp data))
- (set! *didsomething* #t))
- (debug:print-info 0 *default-log-port* "environment variable MT_CMDINFO is not set")))
-
-;;======================================================================
-;; Remove old run(s)
-;;======================================================================
-
-;; since several actions can be specified on the command line the removal
-;; is done first
-(define (operate-on action #!key (mode #f)(target-in #f)(runname-in #f)(keys-in #f)(keyvals-in #f)) ;; #f is "use default"
- (let* ((runrec (runs:runrec-make-record))
- (target (or target-in (common:args-get-target))) ;; eventually get rid of the call to common:args-get-target
- (runname (or runname-in
- (args:get-arg "-runname"))) ;; eventually get rid of the get-arg calls
- (testpatt (or (args:get-arg "-testpatt")
- (and (eq? action 'archive) ;; if it is an archive command fallback to MT_TEST_NAME and MT_ITEMPATH
- (common:get-full-test-name))
- (and (eq? action 'kill-runs)
- "%/%") ;; I'm just guessing that this is correct :(
- (common:args-get-testpatt #f) ;; (args:get-arg "-testpatt")))
- ))) ;;
- (cond
- ((not target)
- (debug:print-error 0 *default-log-port* "Missing required parameter for "
- action ", you must specify -target or -reqtarg")
- (exit 1))
- ((not runname)
- (debug:print-error 0 *default-log-port* "Missing required parameter for "
- action ", you must specify the run name pattern with -runname patt")
- (exit 2))
- ((not testpatt)
- (debug:print-error 0 *default-log-port* "Missing required parameter for "
- action ", you must specify the test pattern with -testpatt")
- (exit 3))
- (else
- (if (not (car *configinfo*))
- (begin
- (debug:print-error 0 *default-log-port* "Attempted " action "on test(s) but run area config file not found")
- (exit 1))
- ;; put test parameters into convenient variables
- (begin
- ;; check for correct version, exit with message if not correct
- (common:exit-on-version-changed)
- (runs:operate-on action
- target
- runname
- testpatt
- state: (common:args-get-state)
- status: (common:args-get-status)
- new-state-status: (args:get-arg "-set-state-status")
- mode: mode)))
- (set! *didsomething* #t)))))
-
-(if (args:get-arg "-kill-runs")
- (general-run-call
- "-kill-runs"
- "kill runs"
- (lambda (target runname keys keyvals)
- (operate-on 'kill-runs mode: #f)
- )))
-
-(if (args:get-arg "-kill-rerun")
- (let* ((target-patt (common:args-get-target))
- (runname-patt (args:get-arg "-runname")))
- (cond ((not target-patt)
- (debug:print-error 0 *default-log-port* "Missing target, must specify target for -kill-rerun with -target ")
- (exit 1))
- ((not runname-patt)
- (debug:print-error 0 *default-log-port* "Missing runname, must specify runname for -kill-rerun with -runname ")
- (exit 1))
- ((string-search "[ ,%]" target-patt)
- (debug:print-error 0 *default-log-port* "Invalid target ["target-patt"], must specify exact target (no wildcards) for -kill-rerun with -target ")
- (exit 1))
- ((string-search "[ ,%]" runname-patt)
- (debug:print-error 0 *default-log-port* "Invalid runname ["runname-patt"], must specify exact runname (no wildcards) for -kill-rerun with -runname ")
- (exit 1))
- (else
- (general-run-call
- "-kill-runs"
- "kill runs"
- (lambda (target runname keys keyvals)
- (operate-on 'kill-runs mode: #f)
- ))
-
- (thread-sleep! 15))
- ;; fall thru and let "-run" loop fire
- )))
-
-
-(if (args:get-arg "-remove-runs")
- (general-run-call
- "-remove-runs"
- "remove runs"
- (lambda (target runname keys keyvals)
- (operate-on 'remove-runs mode: (if (args:get-arg "-keep-records")
- 'remove-data-only
- 'remove-all)))))
-
-(if (args:get-arg "-remove-keep")
- (general-run-call
- "-remove-keep"
- "remove keep"
- (lambda (target runname keys keyvals)
- (let ((actions (map string->symbol
- (string-split
- (or (args:get-arg "-actions")
- "print")
- ",")))) ;; default to printing the output
- (runs:remove-all-but-last-n-runs-per-target target runname
- (string->number (args:get-arg "-remove-keep"))
- actions: actions)))))
-
-(if (args:get-arg "-set-state-status")
- (general-run-call
- "-set-state-status"
- "set state and status"
- (lambda (target runname keys keyvals)
- (operate-on 'set-state-status))))
-
-(if (or (args:get-arg "-set-run-status")
- (args:get-arg "-get-run-status"))
- (general-run-call
- "-set-run-status"
- "set run status"
- (lambda (target runname keys keyvals)
- (let* ((runsdat (rmt:get-runs-by-patt keys runname
- (common:args-get-target)
- #f #f #f #f))
- (header (vector-ref runsdat 0))
- (rows (vector-ref runsdat 1)))
- (if (null? rows)
- (begin
- (debug:print-info 0 *default-log-port* "No matching run found.")
- (exit 1))
- (let* ((row (car (vector-ref runsdat 1)))
- (run-id (db:get-value-by-header row header "id")))
- (if (args:get-arg "-set-run-status")
- (rmt:set-run-status run-id (args:get-arg "-set-run-status") msg: (args:get-arg "-m"))
- (print (rmt:get-run-status run-id))
- )))))))
-
-;;======================================================================
-;; Query runs
-;;======================================================================
-
-;; -fields runs:id,target,runname,comment+tests:id,testname,item_path+steps
-;;
-;; csi> (extract-fields-constraints "runs:id,target,runname,comment+tests:id,testname,item_path+steps")
-;; => (("runs" "id" "target" "runname" "comment") ("tests" "id" "testname" "item_path") ("steps"))
-;;
-;; NOTE: remember that the cdr will be the list you expect (cdr ("runs" "id" "target" "runname" "comment")) => ("id" "target" "runname" "comment")
-;; and so alist-ref will yield what you expect
-;;
-(define (extract-fields-constraints fields-spec)
- (map (lambda (table-spec) ;; runs:id,target,runname
- (let ((dat (string-split table-spec ":"))) ;; ("runs" "id,target,runname")
- (if (> (length dat) 1)
- (cons (car dat)(string-split (cadr dat) ",")) ;; "id,target,runname"
- dat)))
- (string-split fields-spec "+")))
-
-(define (get-value-by-fieldname datavec test-field-index fieldname)
- (let ((indx (hash-table-ref/default test-field-index fieldname #f)))
- (if indx
- (if (>= indx (vector-length datavec))
- #f ;; index too high, should raise an error I suppose
- (vector-ref datavec indx))
- #f)))
-
-
-
-
-
-(when (args:get-arg "-testdata-csv")
- (if (launch:setup)
- (let* ((keys (rmt:get-keys)) ;; (db:get-keys dbstruct))
- (runpatt (or (args:get-arg "-runname") "%"))
- (testpatt (common:args-get-testpatt #f))
- (datapatt (args:get-arg "-testdata-csv"))
- (match-data (string-match "^([^/]+)/(.*)" (args:get-arg "-testdata-csv")))
- (categorypatt (if match-data (list-ref match-data 1) "%"))
- (setvarpatt (if match-data
- (list-ref match-data 2)
- (args:get-arg "-testdata-csv")))
- (runsdat (rmt:get-runs-by-patt keys (or runpatt "%")
- (common:args-get-target) #f #f '("id" "runname" "state" "status" "owner" "event_time" "comment") 0))
- (header (db:get-header runsdat))
- (access-mode (db:get-access-mode))
- (testpatt (common:args-get-testpatt #f))
- (fields-spec (if (args:get-arg "-fields")
- (extract-fields-constraints (args:get-arg "-fields"))
- (list (cons "runs" (append keys (list "id" "runname" "state" "status" "owner" "event_time" "comment" "fail_count" "pass_count")))
- (cons "tests" db:test-record-fields) ;; "id" "testname" "test_path")
- (list "steps" "id" "stepname"))))
- (tests-spec (let ((t (alist-ref "tests" fields-spec equal?)))
- (if (and t (null? t)) ;; all fields
- db:test-record-fields
- t)))
- (adj-tests-spec (delete-duplicates (if tests-spec (cons "id" tests-spec) db:test-record-fields)))
- (test-field-index (make-hash-table))
- (runs (db:get-rows runsdat))
- )
- (if (and tests-spec (not (null? tests-spec))) ;; do some validation and processing of the test-spec
- (let ((invalid-tests-spec (filter (lambda (x)(not (member x db:test-record-fields))) tests-spec)))
- (if (null? invalid-tests-spec)
- ;; generate the lookup map test-field-name => index-number
- (let loop ((hed (car adj-tests-spec))
- (tal (cdr adj-tests-spec))
- (idx 0))
- (hash-table-set! test-field-index hed idx)
- (if (not (null? tal))(loop (car tal)(cdr tal)(+ idx 1))))
- (begin
- (debug:print-error 0 *default-log-port* "Invalid test fields specified: " (string-intersperse invalid-tests-spec ", "))
- (exit)))))
- (let* ((table-header (string-split "target,run,test,itempath,category,var,value,comment" ","))
- (table-rows
- (apply append (map
- (lambda (run)
- (let* ((target (string-intersperse (map (lambda (x)
- (db:get-value-by-header run header x))
- keys) "/"))
- (statuses (string-split (or (args:get-arg "-status") "") ","))
- (run-id (db:get-value-by-header run header "id"))
- (runname (db:get-value-by-header run header "runname"))
- (states (string-split (or (args:get-arg "-state") "") ","))
- (tests (if tests-spec
- (rmt:get-tests-for-run run-id testpatt states statuses #f #f #f 'testname 'asc ;; (db:get-tests-for-run dbstruct run-id testpatt '() '() #f #f #f 'testname 'asc
- ;; use qryvals if test-spec provided
- (if tests-spec
- (string-intersperse adj-tests-spec ",")
- ;; db:test-record-fields
- #f)
- #f
- 'normal)
- '())))
- (apply append
- (map
- (lambda (test)
- (let* (
- (test-id (if (member "id" tests-spec)(get-value-by-fieldname test test-field-index "id" ) #f)) ;; (db:test-get-id test))
- (testname (if (member "testname" tests-spec)(get-value-by-fieldname test test-field-index "testname" ) #f)) ;; (db:test-get-testname test))
- (itempath (if (member "item_path" tests-spec)(get-value-by-fieldname test test-field-index "item_path" ) #f)) ;; (db:test-get-item-path test))
- (fullname (conc testname
- (if (equal? itempath "")
- ""
- (conc "/" itempath ))))
- (testdat-raw (map vector->list (rmt:read-test-data-varpatt run-id test-id categorypatt setvarpatt)))
- (testdat (filter
- (lambda (x)
- (not (equal? "logpro"
- (list-ref x 10))))
- testdat-raw)))
- (map
- (lambda (item)
- (receive (id test_id category
- variable value expected
- tol units comment status type)
- (apply values item)
- (list target runname testname itempath category variable value comment)))
- testdat)))
- tests))))
- runs))))
- (print (string-join table-header ","))
- (for-each (lambda(table-row)
- (print (string-join (map ->string table-row) ",")))
-
-
- table-rows))))
- (set! *didsomething* #t)
- (set! *time-to-exit* #t))
-
-
-
-;; NOTE: list-runs and list-db-targets operate on local db!!!
-;;
-;; IDEA: megatest list -runname blah% ...
-;;
-(if (or (args:get-arg "-list-runs")
- (args:get-arg "-list-db-targets"))
- (if (launch:setup)
- (let* ((runpatt (args:get-arg "-list-runs"))
- (access-mode (db:get-access-mode))
- (testpatt (common:args-get-testpatt #f))
- ;; (if (args:get-arg "-testpatt")
- ;; (args:get-arg "-testpatt")
- ;; "%"))
- (keys (rmt:get-keys)) ;; (db:get-keys dbstruct))
- ;; (runsdat (db:get-runs dbstruct runpatt #f #f '()))
- ;; (runsdat (rmt:get-runs-by-patt keys (or runpatt "%") (common:args-get-target) ;; (db:get-runs-by-patt dbstruct keys (or runpatt "%") (common:args-get-target)
- ;; #f #f '("id" "runname" "state" "status" "owner" "event_time" "comment") 0))
- (runsdat (rmt:get-runs-by-patt keys (or runpatt "%")
- (common:args-get-target) #f #f '("id" "runname" "state" "status" "owner" "event_time" "comment") 0))
- (runstmp (db:get-rows runsdat))
- (header (db:get-header runsdat))
- ;; this is "-since" support. This looks at last mod times of .db files
- ;; and collects those modified since the -since time.
- (runs runstmp)
- ;; (if (and (not (null? runstmp))
- ;; (args:get-arg "-since"))
- ;; (let ((changed-ids (db:get-changed-run-ids (string->number (args:get-arg "-since")))))
- ;; (let loop ((hed (car runstmp))
- ;; (tal (cdr runstmp))
- ;; (res '()))
- ;; (let ((new-res (if (member (db:get-value-by-header hed header "id") changed-ids)
- ;; (cons hed res)
- ;; res)))
- ;; (if (null? tal)
- ;; (reverse new-res)
- ;; (loop (car tal)(cdr tal) new-res)))))
- ;; runstmp))
- (db-targets (args:get-arg "-list-db-targets"))
- (seen (make-hash-table))
- (dmode (let ((d (args:get-arg "-dumpmode"))) ;; json, sexpr
- (if d (string->symbol d) #f)))
- (data (make-hash-table))
- (fields-spec (if (args:get-arg "-fields")
- (extract-fields-constraints (args:get-arg "-fields"))
- (list (cons "runs" (append keys (list "id" "runname" "state" "status" "owner" "event_time" "comment" "fail_count" "pass_count")))
- (cons "tests" db:test-record-fields) ;; "id" "testname" "test_path")
- (list "steps" "id" "stepname"))))
- (runs-spec (let ((r (alist-ref "runs" fields-spec equal?))) ;; the check is now unnecessary
- (if (and r (not (null? r))) r (list "id" ))))
- (tests-spec (let ((t (alist-ref "tests" fields-spec equal?)))
- (if (and t (null? t)) ;; all fields
- db:test-record-fields
- t)))
- (adj-tests-spec (delete-duplicates (if tests-spec (cons "id" tests-spec) db:test-record-fields))) ;; '("id"))))
- (steps-spec (alist-ref "steps" fields-spec equal?))
- (test-field-index (make-hash-table)))
- (if (and (args:get-arg "-dumpmode")
- (not (member (args:get-arg "-dumpmode") '("sexpr" "json" "ods" "list"))))
- (begin
- (debug:print 0 *default-log-port* "ERROR: dumpmode "(args:get-arg "-dumpmode")" not recognised. Use sexpr, json, ods or list")
- (exit)))
- (if (and tests-spec (not (null? tests-spec))) ;; do some validation and processing of the test-spec
- (let ((invalid-tests-spec (filter (lambda (x)(not (member x db:test-record-fields))) tests-spec)))
- (if (null? invalid-tests-spec)
- ;; generate the lookup map test-field-name => index-number
- (let loop ((hed (car adj-tests-spec))
- (tal (cdr adj-tests-spec))
- (idx 0))
- (hash-table-set! test-field-index hed idx)
- (if (not (null? tal))(loop (car tal)(cdr tal)(+ idx 1))))
- (begin
- (debug:print-error 0 *default-log-port* "Invalid test fields specified: " (string-intersperse invalid-tests-spec ", "))
- (exit)))))
- ;; Each run
- (for-each
- (lambda (run)
- (let ((targetstr (string-intersperse (map (lambda (x)
- (db:get-value-by-header run header x))
- keys) "/")))
- (if db-targets
- (if (not (hash-table-ref/default seen targetstr #f))
- (begin
- (hash-table-set! seen targetstr #t)
- ;; (print "[" targetstr "]"))))
- (if (not dmode)
- (print targetstr)
- (hash-table-set! data "targets" (cons targetstr (hash-table-ref/default data "targets" '())))
- )))
- (let* ((run-id (db:get-value-by-header run header "id"))
- (runname (db:get-value-by-header run header "runname"))
- (states (string-split (or (args:get-arg "-state") "") ","))
- (statuses (string-split (or (args:get-arg "-status") "") ","))
- (tests (if tests-spec
- (rmt:get-tests-for-run run-id testpatt states statuses #f #f #f 'testname 'asc ;; (db:get-tests-for-run dbstruct run-id testpatt '() '() #f #f #f 'testname 'asc
- ;; use qryvals if test-spec provided
- (if tests-spec
- (string-intersperse adj-tests-spec ",")
- ;; db:test-record-fields
- #f)
- #f
- 'normal)
- '())))
- (case dmode
- ((json ods sexpr)
- (if runs-spec
- (for-each
- (lambda (field-name)
- (mutils:hierhash-set! data (conc (db:get-value-by-header run header field-name)) targetstr runname "meta" field-name))
- runs-spec)))
- ;; (mutils:hierhash-set! data (db:get-value-by-header run header "status") targetstr runname "meta" "status" )
- ;; (mutils:hierhash-set! data (db:get-value-by-header run header "state") targetstr runname "meta" "state" )
- ;; (mutils:hierhash-set! data (conc (db:get-value-by-header run header "id")) targetstr runname "meta" "id" )
- ;; (mutils:hierhash-set! data (db:get-value-by-header run header "event_time") targetstr runname "meta" "event_time" )
- ;; (mutils:hierhash-set! data (db:get-value-by-header run header "comment") targetstr runname "meta" "comment" )
- ;; ;; add last entry twice - seems to be a bug in hierhash?
- ;; (mutils:hierhash-set! data (db:get-value-by-header run header "comment") targetstr runname "meta" "comment" )
- ((#f list)
- (if (null? runs-spec)
- (print "Run: " targetstr "/" runname
- " status: " (db:get-value-by-header run header "state")
- " run-id: " run-id ", number tests: " (length tests)
- " event_time: " (db:get-value-by-header run header "event_time"))
- (begin
- (if (not (member "target" runs-spec))
- ;; (display (conc "Target: " targetstr))
- (display (conc "Run: " targetstr "/" runname " ")))
- (for-each
- (lambda (field-name)
- (if (equal? field-name "target")
- (display (conc "target: " targetstr " "))
- (display (conc field-name ": " (db:get-value-by-header run header (conc field-name)) " "))))
- runs-spec)
- (newline))))
- (else
- (debug:print 0 *default-log-port* "ERROR: dumpmode "(args:get-arg "-dumpmode")" not recognised. Use sexpr, json, ods or list")
- ))
-
- (for-each
- (lambda (test)
- (common:debug-handle-exceptions #f
- exn
- (begin
- (debug:print-error 0 *default-log-port* "Bad data in test record? " test)
- (debug:print-error 5 *default-log-port* "exn=" (condition->list exn))
- (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
- (print-call-chain (current-error-port)))
- (let* ((test-id (if (member "id" tests-spec)(get-value-by-fieldname test test-field-index "id" ) #f)) ;; (db:test-get-id test))
- (testname (if (member "testname" tests-spec)(get-value-by-fieldname test test-field-index "testname" ) #f)) ;; (db:test-get-testname test))
- (itempath (if (member "item_path" tests-spec)(get-value-by-fieldname test test-field-index "item_path" ) #f)) ;; (db:test-get-item-path test))
- (comment (if (member "comment" tests-spec)(get-value-by-fieldname test test-field-index "comment" ) #f)) ;; (db:test-get-comment test))
- (tstate (if (member "state" tests-spec)(get-value-by-fieldname test test-field-index "state" ) #f)) ;; (db:test-get-state test))
- (tstatus (if (member "status" tests-spec)(get-value-by-fieldname test test-field-index "status" ) #f)) ;; (db:test-get-status test))
- (event-time (if (member "event_time" tests-spec)(get-value-by-fieldname test test-field-index "event_time" ) #f)) ;; (db:test-get-event_time test))
- (rundir (if (member "rundir" tests-spec)(get-value-by-fieldname test test-field-index "rundir" ) #f)) ;; (db:test-get-rundir test))
- (final_logf (if (member "final_logf" tests-spec)(get-value-by-fieldname test test-field-index "final_logf" ) #f)) ;; (db:test-get-final_logf test))
- (run_duration (if (member "run_duration" tests-spec)(get-value-by-fieldname test test-field-index "run_duration") #f)) ;; (db:test-get-run_duration test))
- (fullname (conc testname
- (if (equal? itempath "")
- ""
- (conc "(" itempath ")")))))
- (case dmode
- ((json ods sexpr)
- (if tests-spec
- (for-each
- (lambda (field-name)
- (mutils:hierhash-set! data (get-value-by-fieldname test test-field-index field-name) targetstr runname "data" (conc test-id) field-name))
- tests-spec)))
- ;; ;; (mutils:hierhash-set! data fullname targetstr runname "data" (conc test-id) "tname" )
- ;; (mutils:hierhash-set! data testname targetstr runname "data" (conc test-id) "testname" )
- ;; (mutils:hierhash-set! data itempath targetstr runname "data" (conc test-id) "itempath" )
- ;; (mutils:hierhash-set! data comment targetstr runname "data" (conc test-id) "comment" )
- ;; (mutils:hierhash-set! data tstate targetstr runname "data" (conc test-id) "state" )
- ;; (mutils:hierhash-set! data tstatus targetstr runname "data" (conc test-id) "status" )
- ;; (mutils:hierhash-set! data rundir targetstr runname "data" (conc test-id) "rundir" )
- ;; (mutils:hierhash-set! data final_logf targetstr runname "data" (conc test-id) "final_logf")
- ;; (mutils:hierhash-set! data run_duration targetstr runname "data" (conc test-id) "run_duration")
- ;; (mutils:hierhash-set! data event-time targetstr runname "data" (conc test-id) "event_time")
- ;; ;; add last entry twice - seems to be a bug in hierhash?
- ;; (mutils:hierhash-set! data event-time targetstr runname "data" (conc test-id) "event_time")
- ;; )
- (else
- (if (and tstate tstatus event-time)
- (format #t
- " Test: ~25a State: ~15a Status: ~15a Runtime: ~5@as Time: ~22a Host: ~10a\n"
- (if fullname fullname "")
- (if tstate tstate "")
- (if tstatus tstatus "")
- (get-value-by-fieldname test test-field-index "run_duration");;(if test (db:test-get-run_duration test) "")
- (if event-time event-time "")
- (get-value-by-fieldname test test-field-index "host")) ;;(if test (db:test-get-host test)) "")
- (print " Test: " fullname
- (if tstate (conc " State: " tstate) "")
- (if tstatus (conc " Status: " tstatus) "")
- (if (get-value-by-fieldname test test-field-index "run_duration")
- (conc " Runtime: " (get-value-by-fieldname test test-field-index "run_duration"))
- "")
- (if event-time (conc " Time: " event-time) "")
- (if (get-value-by-fieldname test test-field-index "host")
- (conc " Host: " (get-value-by-fieldname test test-field-index "host"))
- "")))
- (if (not (or (equal? (get-value-by-fieldname test test-field-index "status") "PASS")
- (equal? (get-value-by-fieldname test test-field-index "status") "WARN")
- (equal? (get-value-by-fieldname test test-field-index "state") "NOT_STARTED")))
- (begin
- (print (if (get-value-by-fieldname test test-field-index "cpuload")
- (conc " cpuload: " (get-value-by-fieldname test test-field-index "cpuload"))
- "") ;; (db:test-get-cpuload test)
- (if (get-value-by-fieldname test test-field-index "diskfree")
- (conc "\n diskfree: " (get-value-by-fieldname test test-field-index "diskfree")) ;; (db:test-get-diskfree test)
- "")
- (if (get-value-by-fieldname test test-field-index "uname")
- (conc "\n uname: " (get-value-by-fieldname test test-field-index "uname")) ;; (db:test-get-uname test)
- "")
- (if (get-value-by-fieldname test test-field-index "rundir")
- (conc "\n rundir: " (get-value-by-fieldname test test-field-index "rundir")) ;; (db:test-get-rundir test)
- "")
-;; "\n rundir: " (get-value-by-fieldname test test-field-index "") ;; (sdb:qry 'getstr ;; (filedb:get-path *fdb*
-;; (db:test-get-rundir test) ;; )
- )
- ;; Each test
- ;; DO NOT remote run
- (let ((steps (rmt:get-steps-for-test run-id (db:test-get-id test)))) ;; (db:get-steps-for-test dbstruct run-id (db:test-get-id test))))
- (for-each
- (lambda (step)
- (format #t
- " Step: ~20a State: ~10a Status: ~10a Time ~22a\n"
- (tdb:step-get-stepname step)
- (tdb:step-get-state step)
- (tdb:step-get-status step)
- (tdb:step-get-event_time step)))
- steps)))))))))
- (if (args:get-arg "-sort")
- (sort tests
- (lambda (a-test b-test)
- (let* ((key (args:get-arg "-sort"))
- (first (get-value-by-fieldname a-test test-field-index key))
- (second (get-value-by-fieldname b-test test-field-index key)))
- ((cond
- ((and (number? first)(number? second)) <)
- ((and (string? first)(string? second)) string<=?)
- (else equal?))
- first second))))
- tests))))))
- runs)
- (case dmode
- ((json) (json-write data))
- ((sexpr) (pp (common:to-alist data))))
- (let* ((metadat-fields (delete-duplicates
- (append keys '( "runname" "time" "owner" "pass_count" "fail_count" "state" "status" "comment" "id"))))
- (run-fields '(
- "testname"
- "item_path"
- "state"
- "status"
- "comment"
- "event_time"
- "host"
- "run_id"
- "run_duration"
- "attemptnum"
- "id"
- "archived"
- "diskfree"
- "cpuload"
- "final_logf"
- "shortdir"
- "rundir"
- "uname"
- )
- )
- (newdat (common:to-alist data))
- (allrundat (if (null? newdat)
- '()
- (car (map cdr newdat)))) ;; (car (map cdr (car (map cdr newdat)))))
- (runs (append
- (list "runs" ;; sheetname
- metadat-fields)
- (map (lambda (run)
- ;; (print "run: " run)
- (let* ((runname (car run))
- (rundat (cdr run))
- (metadat (let ((tmp (assoc "meta" rundat)))
- (if tmp (cdr tmp) #f))))
- ;; (print "runname: " runname "\n\nrundat: " )(pp rundat)(print "\n\nmetadat: ")(pp metadat)
- (if metadat
- (map (lambda (field)
- (let ((tmp (assoc field metadat)))
- (if tmp (cdr tmp) "")))
- metadat-fields)
- (begin
- (debug:print 0 *default-log-port* "WARNING: meta data for run " runname " not found")
- '()))))
- allrundat)))
- ;; '( ( "target" ( "runname" ( "data" ( "runid" ( "id . "37" ) ( ... ))))
- (run-pages (map (lambda (targdat)
- (let* ((target (car targdat))
- (runsdat (cdr targdat)))
- (if runsdat
- (map (lambda (rundat)
- (let* ((runname (car rundat))
- (rundat (cdr rundat))
- (testsdat (let ((tmp (assoc "data" rundat)))
- (if tmp (cdr tmp) #f))))
- (if testsdat
- (let ((tests (map (lambda (test)
- (let* ((test-id (car test))
- (test-dat (cdr test)))
- (map (lambda (field)
- (let ((tmp (assoc field test-dat)))
- (if tmp (cdr tmp) "")))
- run-fields)))
- testsdat)))
- ;; (print "Target: " target "/" runname " tests:")
- ;; (pp tests)
- (cons (conc target "/" runname)
- (cons (list (conc target "/" runname))
- (cons '()
- (cons run-fields tests)))))
- (begin
- (debug:print 4 *default-log-port* "WARNING: run " target "/" runname " appears to have no data")
- ;; (pp rundat)
- '()))))
- runsdat)
- '())))
- newdat)) ;; we use newdat to get target
- (sheets (filter (lambda (x)
- (not (null? x)))
- (cons runs (map car run-pages)))))
- ;; (print "allrundat:")
- ;; (pp allrundat)
- ;; (print "runs:")
- ;; (pp runs)
- ;(print "sheets: ")
- ;; (pp sheets)
- (if (eq? dmode 'ods)
- (let* ((tempdir (conc "/tmp/" (current-user-name) "/" (random 10000) "_" (current-process-id)))
- (outputfile (or (args:get-arg "-o") "out.ods"))
- (ouf (if (string-match (regexp "^[/~]+.*") outputfile) ;; full path?
- outputfile
- (begin
- (debug:print 0 *default-log-port* "WARNING: path given, " outputfile " is relative, prefixing with current directory")
- (conc (current-directory) "/" outputfile)))))
- (create-directory tempdir #t)
- (ods:list->ods tempdir ouf sheets))))
- ;; (system (conc "rm -rf " tempdir))
- (set! *didsomething* #t)
- (set! *time-to-exit* #t)
- ) ;; end if true branch (end of a let)
- ) ;; end if
- ) ;; end if -list-runs
-
-;; list-waivers
-(if (and (args:get-arg "-list-waivers")
- (launch:setup))
- (let* ((runpatt (or (args:get-arg "-runname") "%"))
- (testpatt (common:args-get-testpatt #f))
- (keys (rmt:get-keys))
- (runsdat (rmt:get-runs-by-patt
- keys runpatt
- (common:args-get-target) #f #f
- '("id" "runname" "state" "status" "owner" "event_time" "comment") 0))
- (runs (db:get-rows runsdat))
- (header (db:get-header runsdat))
- (results (make-hash-table)) ;; [target] ( (testname/itempath . "comment") ... )
- (addtest (lambda (target testname itempath comment)
- (hash-table-set! results target (cons (cons (conc testname "/" itempath) comment)
- (hash-table-ref/default results target '())))))
- (last-target #f))
- (for-each
- (lambda (run)
- (let* ((run-id (db:get-value-by-header run header "id"))
- (target (rmt:get-target run-id))
- (runname (db:get-value-by-header run header "runname"))
- (tests (rmt:get-tests-for-run
- run-id testpatt '("COMPLETED") '("WAIVED") #f #f #f 'testname 'asc ;; use qryvals if test-spec provided
- #f #f #f)))
- (if (not (equal? target last-target))
- (print "[" target "]"))
- (set! last-target target)
- (print "# " runname)
- (for-each
- (lambda (testdat)
- (let* ((testfullname (conc (db:test-get-testname testdat)
- (if (equal? "" (db:test-get-item-path testdat))
- ""
- (conc "/" (db:test-get-item-path testdat)))
- )))
- (print testfullname " " (db:test-get-comment testdat))))
- tests)))
- runs)
- (set! *didsomething* #t)))
-
-;;======================================================================
-;; full run
-;;======================================================================
-
-(define (handle-run-requests target runname keys keyvals need-clean)
- (if (or (args:get-arg "-kill-rerun") (args:get-arg "-rerun-clean")) ;; first set states/statuses correct
- ;; For rerun-clean do we or do we not support the testpatt?
- (let ((states (or (configf:lookup *configdat* "validvalues" "cleanrerun-states")
- "KILLREQ,KILLED,UNKNOWN,INCOMPLETE,STUCK,NOT_STARTED"))
- (statuses (or (configf:lookup *configdat* "validvalues" "cleanrerun-statuses")
- "FAIL,INCOMPLETE,ABORT,CHECK,DEAD,PREQ_FAIL,PREQ_DISCARDED")))
- (hash-table-set! args:arg-hash "-preclean" #t)
- (runs:operate-on 'set-state-status
- target
- (common:args-get-runname) ;; (or (args:get-arg "-runname")(args:get-arg ":runname"))
- ;; "%" ;; (common:args-get-testpatt #f) ;; (args:get-arg "-testpatt")
- (common:args-get-testpatt #f) ;; (args:get-arg "-testpatt")
- state: states
- ;; status: statuses
- new-state-status: "NOT_STARTED,n/a")
- (runs:clean-cache target runname *toppath*)
- (runs:operate-on 'set-state-status
- target
- (common:args-get-runname) ;; (or (args:get-arg "-runname")(args:get-arg ":runname"))
- ;; "%" ;; (common:args-get-testpatt #f) ;; (args:get-arg "-testpatt")
- (common:args-get-testpatt #f) ;; (args:get-arg "-testpatt")
- ;; state: states
- status: statuses
- new-state-status: "NOT_STARTED,n/a")))
- ;; RERUN ALL
- (if (args:get-arg "-rerun-all") ;; first set states/statuses correct
- (let* ((rconfig (full-runconfigs-read)))
- (hash-table-set! args:arg-hash "-preclean" #t)
- (runs:operate-on 'set-state-status
- target
- (common:args-get-runname) ;; (or (args:get-arg "-runname")(args:get-arg ":runname"))
- (common:args-get-testpatt rconfig) ;; (args:get-arg "-testpatt")
- state: #f
- ;; status: statuses
- new-state-status: "NOT_STARTED,n/a")
- (runs:clean-cache target runname *toppath*)
- (runs:operate-on 'set-state-status
- target
- (common:args-get-runname) ;; (or (args:get-arg "-runname")(args:get-arg ":runname"))
- (common:args-get-testpatt rconfig) ;; (args:get-arg "-testpatt")
- ;; state: states
- status: #f
- new-state-status: "NOT_STARTED,n/a")))
- (let* ((config-reruns (let ((x (configf:lookup *configdat* "setup" "reruns")))
- (if x (string->number x) #f)))
- (rerun-cnt (if config-reruns
- config-reruns
- 1)))
-
- (runs:run-tests target
- runname
- #f ;; (common:args-get-testpatt #f)
- ;; (or (args:get-arg "-testpatt")
- ;; "%")
- user
- args:arg-hash
- run-count: rerun-cnt)))
-
-;; get lock in db for full run for this directory
-;; for all tests with deps
-;; walk tree of tests to find head tasks
-;; add head tasks to task queue
-;; add dependant tasks to task queue
-;; add remaining tasks to task queue
-;; for each task in task queue
-;; if have adequate resources
-;; launch task
-;; else
-;; put task in deferred queue
-;; if still ok to run tasks
-;; process deferred tasks per above steps
-
-;; run all tests are are Not COMPLETED and PASS or CHECK
-(if (or (args:get-arg "-runall")
- (args:get-arg "-run")
- (args:get-arg "-rerun-clean")
- (args:get-arg "-rerun-all")
- (args:get-arg "-runtests")
- (args:get-arg "-kill-rerun"))
- (let ((need-clean (or (args:get-arg "-rerun-clean")
- (args:get-arg "-rerun-all")))
- (orig-cmdline (string-intersperse (argv) " ")))
- (general-run-call
- "-runall"
- "run all tests"
- (lambda (target runname keys keyvals)
- (if (or (string-search "%" target)
- (string-search "%" runname)) ;; we are being asked to re-run multiple runs
- (let* ((run-specs (rmt:simple-get-runs runname #f #f target #f))) ;; list of simple-run records
- (debug:print-info 0 *default-log-port* "Pattern supplied for target or runname with "
- (length run-specs) " matches found. Running each in turn.")
- (if (null? run-specs)
- (debug:print 0 *default-log-port* "WARNING: No runs match target " target " and runname " runname))
- (for-each (lambda (spec)
- (let* ((precmd (if (args:get-arg "-precmd")(conc (args:get-arg "-precmd") " ") ""))
- (newcmdline (conc
- precmd
- (string-substitute
- (conc "target " target)
- (conc "target " (simple-run-target spec))
- (string-substitute
- (conc "runname " runname)
- (conc "runname " (simple-run-runname spec))
- orig-cmdline)))))
- (debug:print 0 *default-log-port* "ORIG: " orig-cmdline)
- (debug:print 0 *default-log-port* "NEW: " newcmdline)
- (system newcmdline)))
- run-specs))
- (handle-run-requests target runname keys keyvals need-clean))))
- (set! *didsomething* #t)))
-
-;;======================================================================
-;; run one test
-;;======================================================================
-
-;; 1. find the config file
-;; 2. change to the test directory
-;; 3. update the db with "test started" status, set running host
-;; 4. process launch the test
-;; - monitor the process, update stats in the db every 2^n minutes
-;; 5. as the test proceeds internally it calls megatest as each step is
-;; started and completed
-;; - step started, timestamp
-;; - step completed, exit status, timestamp
-;; 6. test phone home
-;; - if test run time > allowed run time then kill job
-;; - if cannot access db > allowed disconnect time then kill job
-
-;; == duplicated == (if (or (args:get-arg "-run")(args:get-arg "-runtests"))
-;; == duplicated == (general-run-call
-;; == duplicated == "-runtests"
-;; == duplicated == "run a test"
-;; == duplicated == (lambda (target runname keys keyvals)
-;; == duplicated == ;;
-;; == duplicated == ;; May or may not implement it this way ...
-;; == duplicated == ;;
-;; == duplicated == ;; Insert this run into the tasks queue
-;; == duplicated == ;; (open-run-close tasks:add tasks:open-db
-;; == duplicated == ;; "runtests"
-;; == duplicated == ;; user
-;; == duplicated == ;; target
-;; == duplicated == ;; runname
-;; == duplicated == ;; (args:get-arg "-runtests")
-;; == duplicated == ;; #f))))
-;; == duplicated == (runs:run-tests target
-;; == duplicated == runname
-;; == duplicated == (common:args-get-testpatt #f) ;; (args:get-arg "-runtests")
-;; == duplicated == user
-;; == duplicated == args:arg-hash))))
-
-;;======================================================================
-;; Rollup into a run
-;;======================================================================
-
-(if (args:get-arg "-rollup")
- (general-run-call
- "-rollup"
- "rollup tests"
- (lambda (target runname keys keyvals)
- (runs:rollup-run keys
- keyvals
- (or (args:get-arg "-runname")(args:get-arg ":runname") )
- user))))
-
-;;======================================================================
-;; Lock or unlock a run
-;;======================================================================
-
-(if (or (args:get-arg "-lock")(args:get-arg "-unlock"))
- (general-run-call
- (if (args:get-arg "-lock") "-lock" "-unlock")
- "lock/unlock tests"
- (lambda (target runname keys keyvals)
- (runs:handle-locking
- target
- keys
- (or (args:get-arg "-runname")(args:get-arg ":runname") )
- (args:get-arg "-lock")
- (args:get-arg "-unlock")
- user))))
-
-;;======================================================================
-;; Get paths to tests
-;;======================================================================
-;; Get test paths matching target, runname, and testpatt
-(if (or (args:get-arg "-test-files")(args:get-arg "-test-paths"))
- ;; if we are in a test use the MT_CMDINFO data
- (if (getenv "MT_CMDINFO")
- (let* ((startingdir (current-directory))
- (cmdinfo (common:read-encoded-string (getenv "MT_CMDINFO")))
- (transport (assoc/default 'transport cmdinfo))
- (testpath (assoc/default 'testpath cmdinfo))
- (test-name (assoc/default 'test-name cmdinfo))
- (runscript (assoc/default 'runscript cmdinfo))
- (db-host (assoc/default 'db-host cmdinfo))
- (run-id (assoc/default 'run-id cmdinfo))
- (itemdat (assoc/default 'itemdat cmdinfo))
- (state (args:get-arg ":state"))
- (status (args:get-arg ":status"))
- ;;(target (args:get-arg "-target"))
- (target (common:args-get-target))
- (toppath (assoc/default 'toppath cmdinfo)))
- (change-directory toppath)
- (if (not target)
- (begin
- (debug:print-error 0 *default-log-port* "-target is required.")
- (exit 1)))
- (if (not (launch:setup))
- (begin
- (debug:print 0 *default-log-port* "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
- (paths (tests:test-get-paths-matching keys target (args:get-arg "-test-files"))))
- (set! *didsomething* #t)
- (for-each (lambda (path)
- (if (common:file-exists? path)
- (print path)))
- paths)))
- ;; else do a general-run-call
- (general-run-call
- "-test-files"
- "Get paths to test"
- (lambda (target runname keys keyvals)
- (let* ((db #f)
- ;; DO NOT run remote
- (paths (tests:test-get-paths-matching keys target (args:get-arg "-test-files"))))
- (for-each (lambda (path)
- (print path))
- paths))))))
-
-;;======================================================================
-;; Utils for test areas
-;;======================================================================
-
-(if (args:get-arg "-regen-testfiles")
- (if (getenv "MT_TEST_RUN_DIR")
- (begin
- (launch:setup)
- (change-directory (getenv "MT_TEST_RUN_DIR"))
- (let* ((testname (getenv "MT_TEST_NAME"))
- (itempath (getenv "MT_ITEMPATH")))
- (launch:extract-scripts-logpro (getenv "MT_TEST_RUN_DIR") testname itempath #f))
- (set! *didsomething* #t))
- (debug:print 0 *default-log-port* "ERROR: Must run -regen-testfiles in a test environment (i.e. test xterm from dashboard)")))
-
-;;======================================================================
-;; Archive tests
-;;======================================================================
-;; Archive tests matching target, runname, and testpatt
-(if (equal? (args:get-arg "-archive") "replicate-db")
- (begin
- ;; check if source
- ;; check if megatest.db exist
- (launch:setup)
- (if (not (args:get-arg "-source"))
- (begin
- (debug:print-info 1 *default-log-port* "Missing required argument -source ")
- (exit 1)))
- (if (common:file-exists? (conc *toppath* "/megatest.db"))
- (begin
- (debug:print-info 1 *default-log-port* "File " (conc *toppath* "/megatest.db") " already exists. Please remove it before trying to replicate db")
- (exit 1)))
- (if (and (common:make-tmpdir-name *toppath* "") (> (length (directory (common:make-tmpdir-name *toppath* "") #f)) 0))
- (begin
- (debug:print-info 1 *default-log-port* (common:make-tmpdir-name *toppath* "") " not empty. Please remove it before trying to replicate db")
- (exit 1)))
- ;; check if timestamp
- (let* ((source (args:get-arg "-source"))
- (src (if (not (equal? (substring source 0 1) "/"))
- (conc (current-directory) "/" source)
- source))
- (ts (if (args:get-arg "-time-stamp") (args:get-arg "-time-stamp") "latest")))
- (if (common:directory-exists? src)
- (begin
- (archive:restore-db src ts)
- (set! *didsomething* #t))
- (begin
- (debug:print-error 1 *default-log-port* "Path " source " not found")
- (exit 1))))))
- ;; else do a general-run-call
- (if (and (args:get-arg "-archive") (not (equal? (args:get-arg "-archive") "replicate-db")))
- (begin
- ;; for the archive get we need to preserve the starting dir as part of the target path
- (if (and (args:get-arg "-dest")
- (not (equal? (substring (args:get-arg "-dest") 0 1) "/")))
- (let ((newpath (conc (current-directory) "/" (args:get-arg "-dest"))))
- (debug:print-info 1 *default-log-port* "Preserving original path to destination, was " (args:get-arg "-dest") ", now " newpath)
- (hash-table-set! args:arg-hash "-dest" newpath)))
- (general-run-call
- "-archive"
- "Archive"
- (lambda (target runname keys keyvals)
- (operate-on 'archive target-in: target runname-in: runname )))))
-
-;;======================================================================
-;; Extract a spreadsheet from the runs database
-;;======================================================================
-
-(if (args:get-arg "-extract-ods")
- (general-run-call
- "-extract-ods"
- "Make ods spreadsheet"
- (lambda (target runname keys keyvals)
- (let ((dbstruct (make-dbr:dbstruct areapath: *toppath* local: #t))
- (outputfile (args:get-arg "-extract-ods"))
- (runspatt (or (args:get-arg "-runname")(args:get-arg ":runname")))
- (pathmod (args:get-arg "-pathmod")))
- ;; (keyvalalist (keys->alist keys "%")))
- (debug:print 2 *default-log-port* "Extract ods, outputfile: " outputfile " runspatt: " runspatt " keyvals: " keyvals)
- (db:extract-ods-file dbstruct outputfile keyvals (if runspatt runspatt "%") pathmod)
- (db:close-all dbstruct)
- (set! *didsomething* #t)))))
-
-;;======================================================================
-;; execute the test
-;; - gets called on remote host
-;; - receives info from the -execute param
-;; - passes info to steps via MT_CMDINFO env var (future is to use a dot file)
-;; - gathers host info and
-;;======================================================================
-
-(if (args:get-arg "-execute")
- (begin
- (launch:execute (args:get-arg "-execute"))
- (set! *didsomething* #t)))
-
-;;======================================================================
-;; recover from a test where the managing mtest was killed but the underlying
-;; process might still be salvageable
-;;======================================================================
-
-(if (args:get-arg "-recover-test")
- (let* ((params (string-split (args:get-arg "-recover-test") ",")))
- (if (> (length params) 1) ;; run-id and test-id
- (let ((run-id (string->number (car params)))
- (test-id (string->number (cadr params))))
- (if (and run-id test-id)
- (begin
- (launch:recover-test run-id test-id)
- (set! *didsomething* #t))
- (begin
- (debug:print-error 0 *default-log-port* "bad run-id or test-id, must be integers")
- (exit 1)))))))
-
-;;======================================================================
-;; Test commands (i.e. for use inside tests)
-;;======================================================================
-
-(define (megatest:step step state status logfile msg)
- (if (not (getenv "MT_CMDINFO"))
- (begin
- (debug:print-error 0 *default-log-port* "MT_CMDINFO env var not set, -step must be called *inside* a megatest invoked environment!")
- (exit 5))
- (let* ((cmdinfo (common:read-encoded-string (getenv "MT_CMDINFO")))
- (transport (assoc/default 'transport cmdinfo))
- (testpath (assoc/default 'testpath cmdinfo))
- (test-name (assoc/default 'test-name cmdinfo))
- (runscript (assoc/default 'runscript cmdinfo))
- (db-host (assoc/default 'db-host cmdinfo))
- (run-id (assoc/default 'run-id cmdinfo))
- (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))
- (begin
- (debug:print 0 *default-log-port* "Failed to setup, exiting")
- (exit 1)))
- (if (and state status)
- (let ((comment (launch:load-logpro-dat run-id test-id step)))
- ;; (rmt:test-set-log! run-id test-id (conc stepname ".html"))))
- (rmt:teststep-set-status! run-id test-id step state status (or comment msg) logfile))
- (begin
- (debug:print-error 0 *default-log-port* "You must specify :state and :status with every call to -step")
- (exit 6))))))
-
-(if (args:get-arg "-step")
- (begin
- (thread-sleep! 1.5)
- (megatest:step
- (args:get-arg "-step")
- (or (args:get-arg "-state")(args:get-arg ":state"))
- (or (args:get-arg "-status")(args:get-arg ":status"))
- (args:get-arg "-setlog")
- (args:get-arg "-m"))
- ;; (if db (sqlite3:finalize! db))
- (set! *didsomething* #t)
- (thread-sleep! 1.5)))
-
-(if (or (args:get-arg "-setlog") ;; since setting up is so costly lets piggyback on -test-status
- ;; (not (args:get-arg "-step"))) ;; -setlog may have been processed already in the "-step" previous
- ;; NEW POLICY - -setlog sets test overall log on every call.
- (args:get-arg "-set-toplog")
- (args:get-arg "-test-status")
- (args:get-arg "-set-values")
- (args:get-arg "-load-test-data")
- (args:get-arg "-runstep")
- (args:get-arg "-summarize-items"))
- (if (not (getenv "MT_CMDINFO"))
- (begin
- (debug:print-error 0 *default-log-port* "MT_CMDINFO env var not set, commands -test-status, -runstep and -setlog must be called *inside* a megatest environment!")
- (exit 5))
- (let* ((startingdir (current-directory))
- (cmdinfo (common:read-encoded-string (getenv "MT_CMDINFO")))
- (transport (assoc/default 'transport cmdinfo))
- (testpath (assoc/default 'testpath cmdinfo))
- (test-name (assoc/default 'test-name cmdinfo))
- (runscript (assoc/default 'runscript cmdinfo))
- (db-host (assoc/default 'db-host cmdinfo))
- (run-id (assoc/default 'run-id cmdinfo))
- (test-id (assoc/default 'test-id cmdinfo))
- (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"))
- (stepname (args:get-arg "-step")))
- (if (not (launch:setup))
- (begin
- (debug:print 0 *default-log-port* "Failed to setup, exiting")
- (exit 1)))
-
- (if (args:get-arg "-runstep")(debug:print-info 1 *default-log-port* "Running -runstep, first change to directory " work-area))
- (change-directory work-area)
- ;; can setup as client for server mode now
-
- (if (args:get-arg "-load-test-data")
- ;; has sub commands that are rdb:
- ;; DO NOT put this one into either rmt: or open-run-close
- (tdb:load-test-data run-id test-id))
- (if (args:get-arg "-setlog")
- (let ((logfname (args:get-arg "-setlog")))
- (rmt:test-set-log! run-id test-id logfname)))
- (if (args:get-arg "-set-toplog")
- ;; DO NOT run remote
- (tests:test-set-toplog! run-id test-name (args:get-arg "-set-toplog")))
- (if (args:get-arg "-summarize-items")
- ;; DO NOT run remote
- (tests:summarize-items run-id test-id test-name #t)) ;; do force here
- (if (args:get-arg "-runstep")
- (if (null? remargs)
- (begin
- (debug:print-error 0 *default-log-port* "nothing specified to run!")
- (if db (sqlite3:finalize! db))
- (exit 6))
- (let* ((stepname (args:get-arg "-runstep"))
- (logprofile (args:get-arg "-logpro"))
- (logfile (conc stepname ".log"))
- (cmd (if (null? remargs) #f (car remargs)))
- (params (if cmd (cdr remargs) '()))
- (exitstat #f)
- (shell (let ((sh (get-environment-variable "SHELL") ))
- (if sh
- (last (string-split sh "/"))
- "bash")))
- (redir (case (string->symbol shell)
- ((tcsh csh ksh) ">&")
- ((zsh bash sh ash) "2>&1 >")
- (else ">&")))
- (fullcmd (conc "(" (string-intersperse
- (cons cmd params) " ")
- ") " redir " " logfile)))
- ;; mark the start of the test
- (rmt:teststep-set-status! run-id test-id stepname "start" "n/a" (args:get-arg "-m") logfile)
- ;; run the test step
- (debug:print-info 2 *default-log-port* "Running \"" fullcmd "\" in directory \"" startingdir)
- (change-directory startingdir)
- (set! exitstat (system fullcmd))
- (set! *globalexitstatus* exitstat)
- ;; (change-directory testpath)
- ;; run logpro if applicable ;; (process-run "ls" (list "/foo" "2>&1" "blah.log"))
- (if logprofile
- (let* ((htmllogfile (conc stepname ".html"))
- (oldexitstat exitstat)
- (cmd (string-intersperse (list "logpro" logprofile htmllogfile "<" logfile ">" (conc stepname "_logpro.log")) " ")))
- (debug:print-info 2 *default-log-port* "running \"" cmd "\"")
- (change-directory startingdir)
- (set! exitstat (system cmd))
- (set! *globalexitstatus* exitstat) ;; no necessary
- (change-directory testpath)
- (rmt:test-set-log! run-id test-id htmllogfile)))
- (let ((msg (args:get-arg "-m")))
- (rmt:teststep-set-status! run-id test-id stepname "end" exitstat msg logfile))
- )))
- (if (or (args:get-arg "-test-status")
- (args:get-arg "-set-values"))
- (let ((newstatus (cond
- ((number? status) (if (equal? status 0) "PASS" "FAIL"))
- ((and (string? status)
- (string->number status))(if (equal? (string->number status) 0) "PASS" "FAIL"))
- (else status)))
- ;; transfer relevant keys into a hash to be passed to test-set-status!
- ;; could use an assoc list I guess.
- (otherdata (let ((res (make-hash-table)))
- (for-each (lambda (key)
- (if (args:get-arg key)
- (hash-table-set! res key (args:get-arg key))))
- (list ":value" ":tol" ":expected" ":first_err" ":first_warn" ":units" ":category" ":variable"))
- res)))
- (if (and (args:get-arg "-test-status")
- (or (not state)
- (not status)))
- (begin
- (debug:print-error 0 *default-log-port* "You must specify :state and :status with every call to -test-status\n" help)
- (if (sqlite3:database? db)(sqlite3:finalize! db))
- (exit 6)))
- (let* ((msg (args:get-arg "-m"))
- (numoth (length (hash-table-keys otherdata))))
- ;; Convert to rpc inside the tests:test-set-status! call, not here
- (tests:test-set-status! run-id test-id state newstatus msg otherdata work-area: work-area))))
- (if (sqlite3:database? db)(sqlite3:finalize! db))
- (set! *didsomething* #t))))
-
-;;======================================================================
-;; Various helper commands can go below here
-;;======================================================================
-
-(if (or (args:get-arg "-showkeys")
- (args:get-arg "-show-keys"))
- (let ((db #f)
- (keys #f))
- (if (not (launch:setup))
- (begin
- (debug:print 0 *default-log-port* "Failed to setup, exiting")
- (exit 1)))
- (set! keys (rmt:get-keys)) ;; db))
- (debug:print 1 *default-log-port* "Keys: " (string-intersperse keys ", "))
- (if (sqlite3:database? db)(sqlite3:finalize! db))
- (set! *didsomething* #t)))
-
-(if (args:get-arg "-gui")
- (begin
- (debug:print 0 *default-log-port* "Look at the dashboard for now")
- ;; (megatest-gui)
- (set! *didsomething* #t)))
-
-(if (args:get-arg "-create-megatest-area")
- (begin
- (genexample:mk-megatest.config)
- (set! *didsomething* #t)))
-
-(if (args:get-arg "-create-test")
- (let ((testname (args:get-arg "-create-test")))
- (genexample:mk-megatest-test testname)
- (set! *didsomething* #t)))
-
-;;======================================================================
-;; Update the database schema, clean up the db
-;;======================================================================
-
-(if (args:get-arg "-rebuild-db")
- (begin
- (if (not (launch:setup))
- (begin
- (debug:print 0 *default-log-port* "Failed to setup, exiting")
- (exit 1)))
- ;; keep this one local
- ;; (open-run-close patch-db #f)
- (let ((dbstructs (db:setup)))
- (common:cleanup-db dbstructs full: #t))
- (set! *didsomething* #t)))
-
-(if (args:get-arg "-cleanup-db")
- (begin
- (if (not (launch:setup))
- (begin
- (debug:print 0 *default-log-port* "Failed to setup, exiting")
- (exit 1)))
-
-;; (if (not (server:choose-server *toppath* 'home?))
-;; (begin
-;; (debug:print 0 *default-log-port* "Servers are not running on this host or no servers alive. Cannot run cleanup-db")
-;; (exit 1)))
-
- (let ((dbstructs (db:setup)))
- (common:cleanup-db dbstructs))
- (set! *didsomething* #t)))
-
-(if (args:get-arg "-mark-incompletes")
- (begin
- (if (not (launch:setup))
- (begin
- (debug:print 0 *default-log-port* "Failed to setup, exiting")
- (exit 1)))
- (open-run-close db:find-and-mark-incomplete #f)
- (set! *didsomething* #t)))
-
-;;======================================================================
-;; Update the tests meta data from the testconfig files
-;;======================================================================
-
-(if (args:get-arg "-update-meta")
- (begin
- (if (not (launch:setup))
- (begin
- (debug:print 0 *default-log-port* "Failed to setup, exiting")
- (exit 1)))
- (runs:update-all-test_meta #f)
- (set! *didsomething* #t)))
-
-;;======================================================================
-;; Start a repl
-;;======================================================================
-
-;; fakeout readline
-(include "readline-fix.scm")
-
-
-(when (args:get-arg "-diff-rep")
- (when (and
- (not (args:get-arg "-diff-html"))
- (not (args:get-arg "-diff-email")))
- (debug:print 0 *default-log-port* "Must specify -diff-html or -diff-email with -diff-rep")
- (set! *didsomething* 1)
- (exit 1))
-
- (let* ((toppath (launch:setup)))
- (do-diff-report
- (args:get-arg "-src-target")
- (args:get-arg "-src-runname")
- (args:get-arg "-target")
- (args:get-arg "-runname")
- (args:get-arg "-diff-html")
- (args:get-arg "-diff-email"))
- (set! *didsomething* #t)
- (exit 0)))
-
-(if (or (getenv "MT_RUNSCRIPT")
- (args:get-arg "-repl")
- (args:get-arg "-load"))
- (let* ((toppath (launch:setup))
- (dbstructs (if (and toppath
- ;; NOTE: server:choose-server is starting a server
- ;; either add equivalent for tcp mode or ????
- #;(server:choose-server toppath 'home?))
- (db:setup)
- #f))) ;; make-dbr:dbstruct path: toppath local: (args:get-arg "-local")) #f)))
- (if *toppath*
- (cond
- ((getenv "MT_RUNSCRIPT")
- ;; How to run megatest scripts
- ;;
- ;; #!/bin/bash
- ;;
- ;; export MT_RUNSCRIPT=yes
- ;; megatest << EOF
- ;; (print "Hello world")
- ;; (exit)
- ;; EOF
-
- (repl))
- (else
- (begin
- (set! *db* dbstructs)
- (import extras) ;; might not be needed
- ;; (import csi)
- (import readline)
- (import apropos)
- (import dbfile)
- ;; (import (prefix sqlite3 sqlite3:)) ;; doesn't work ...
-
- (if *use-new-readline*
- (begin
- (install-history-file (get-environment-variable "HOME") ".megatest_history") ;; [homedir] [filename] [nlines])
- (current-input-port (make-readline-port "megatest> ")))
- (begin
- (gnu-history-install-file-manager
- (string-append
- (or (get-environment-variable "HOME") ".") "/.megatest_history"))
- (current-input-port (make-gnu-readline-port "megatest> "))))
- (if (args:get-arg "-repl")
- (repl)
- (load (args:get-arg "-load")))
- ;; (db:close-all dbstruct) <= taken care of by on-exit call
- )
- (exit)))
- (set! *didsomething* #t))))
-
-;;======================================================================
-;; Wait on a run to complete
-;;======================================================================
-
-(if (and (args:get-arg "-run-wait")
- (not (or (args:get-arg "-run")
- (args:get-arg "-runtests")))) ;; run-wait is built into runtests now
- (begin
- (if (not (launch:setup))
- (begin
- (debug:print 0 *default-log-port* "Failed to setup, exiting")
- (exit 1)))
- (operate-on 'run-wait)
- (set! *didsomething* #t)))
-
-;; ;; ;; redo me ;; Not converted to use dbstruct yet
-;; ;; ;; redo me ;;
-;; ;; ;; redo me (if (args:get-arg "-convert-to-norm")
-;; ;; ;; redo me (let* ((toppath (setup-for-run))
-;; ;; ;; redo me (dbstruct (if toppath (make-dbr:dbstruct path: toppath local: #t))))
-;; ;; ;; redo me (for-each
-;; ;; ;; redo me (lambda (field)
-;; ;; ;; redo me (let ((dat '()))
-;; ;; ;; redo me (debug:print-info 0 *default-log-port* "Getting data for field " field)
-;; ;; ;; redo me (sqlite3:for-each-row
-;; ;; ;; redo me (lambda (id val)
-;; ;; ;; redo me (set! dat (cons (list id val) dat)))
-;; ;; ;; redo me (db:get-db db run-id)
-;; ;; ;; redo me (conc "SELECT id," field " FROM tests;"))
-;; ;; ;; redo me (debug:print-info 0 *default-log-port* "found " (length dat) " items for field " field)
-;; ;; ;; redo me (let ((qry (sqlite3:prepare db (conc "UPDATE tests SET " field "=? WHERE id=?;"))))
-;; ;; ;; redo me (for-each
-;; ;; ;; redo me (lambda (item)
-;; ;; ;; redo me (let ((newval ;; (sdb:qry 'getid
-;; ;; ;; redo me (cadr item))) ;; )
-;; ;; ;; redo me (if (not (equal? newval (cadr item)))
-;; ;; ;; redo me (debug:print-info 0 *default-log-port* "Converting " (cadr item) " to " newval " for test #" (car item)))
-;; ;; ;; redo me (sqlite3:execute qry newval (car item))))
-;; ;; ;; redo me dat)
-;; ;; ;; redo me (sqlite3:finalize! qry))))
-;; ;; ;; redo me (db:close-all dbstruct)
-;; ;; ;; redo me (list "uname" "rundir" "final_logf" "comment"))
-;; ;; ;; redo me (set! *didsomething* #t)))
-
-(if (args:get-arg "-import-megatest.db")
- (begin
- (launch:setup)
- (db:multi-db-sync
- (db:setup)
- 'killservers
- 'dejunk
- 'adj-testids
- 'old2new
- )
- (set! *didsomething* #t)))
-
-(if (args:get-arg "-import-sexpr")
- (let*(
- (toppath (launch:setup))
- (tmppath (common:make-tmpdir-name toppath "")))
- (if (file-exists? (conc toppath "/.mtdb"))
- (if (args:get-arg "-remove-dbs")
- (let* ((dbfiles (conc toppath "/.mtdb/* " tmppath "/*")))
- (debug:print 0 *default-log-port* "Removing db files: " dbfiles)
- (system (conc "rm -rvf " dbfiles))
- )
- (begin
- (debug:print 0 *default-log-port* "ERROR: Cannot import sexpr with an existing DB present.")
- (debug:print 0 *default-log-port* "Add '-remove-dbs all' to remove the current Megatest DBs.")
- (set! *didsomething* #t)
- (exit)
- )
- )
- (debug:print 0 *default-log-port* "Did not find " (conc toppath "/.mtdb"))
- )
- (db:setup)
- (rmt:import-sexpr (args:get-arg "-import-sexpr"))
- (set! *didsomething* #t)))
-
-(if (args:get-arg "-sync-to-megatest.db")
- (let* ((duh (launch:setup))
- (dbstruct (db:setup))
- (tmpdbpth (dbr:dbstruct-tmppath dbstruct))
- (lockfile (conc tmpdbpth ".lock"))
- (locked (common:simple-file-lock lockfile))
- (res (if locked
- (db:multi-db-sync
- dbstruct
- 'new2old)
- #f)))
- (if res
- (begin
- (common:simple-file-release-lock lockfile)
- (debug:print 0 *default-log-port* "Synced " res " records to megatest.db"))
- (debug:print 0 *default-log-port* "Skipping sync, there is a sync in progress."))
- (set! *didsomething* #t)))
-
-(if (args:get-arg "-sync-to")
- (let ((toppath (launch:setup)))
- (tasks:sync-to-postgres *configdat* (args:get-arg "-sync-to"))
- (set! *didsomething* #t)))
-
-
-;; use with -from and -to
-;;
-(if (args:get-arg "-db2db")
- (let* ((duh (launch:setup))
- (src-db (args:get-arg "-from"))
- (dest-db (args:get-arg "-to"))
- ;; (sync-period (args:get-arg-number "-period"))
- ;; (sync-timeout (args:get-arg-number "-timeout"))
- (sync-period-in (args:get-arg "-period"))
- (sync-timeout-in (args:get-arg "-timeout"))
- (sync-period (if sync-period-in (string->number sync-period-in) #f))
- (sync-timeout (if sync-timeout-in (string->number sync-timeout-in) #f))
- (lockfile (conc dest-db".sync-lock"))
- (keys (db:get-keys #f))
- (thesync (lambda (last-update)
- (debug:print-info 0 *default-log-port* "Attempting to sync data from "src-db" to "dest-db"...")
- (debug:print-info 0 *default-log-port* "PID = " (current-process-id))
- (if (not (file-exists? dest-db))
- (begin
- (debug:print 0 *default-log-port* "Using copy to create "dest-db" from "src-db)
- (file-copy src-db dest-db)
- 1)
- (let ((res (dbmod:db-to-db-sync src-db dest-db last-update (dbfile:db-init-proc) keys)))
- (if res
- (debug:print-info 2 *default-log-port* "Synced " res " records from "src-db" to "dest-db)
- (debug:print-info 0 *default-log-port* "No sync due to permissions or other issue."))
- res))))
- (start-time (current-seconds))
- (synclock-mod-time (if (file-exists? lockfile)
- (handle-exceptions
- exn
- #f
- (file-modification-time synclock-file))
- #f))
- (age (if synclock-mod-time (- (current-seconds) synclock-mod-time) 1000))
- )
- (if (and src-db dest-db)
- (if (file-exists? src-db)
- (if (and (file-exists? lockfile) (< age 20))
- (debug:print 0 *default-log-port* "Lock "lockfile" exists, skipping sync...")
- (begin
- (if (file-exists? lockfile)
- (begin
- (debug:print 0 *default-log-port* "Deleting old lock file " lockfile)
- (delete-file lockfile)
- )
- )
- (dbfile:with-simple-file-lock
- lockfile
- (lambda ()
- (let loop ((last-changed (current-seconds))
- (last-update 0))
- (let* ((changes (handle-exceptions
- exn
- (begin
- (debug:print 0 *default-log-port* "Exception in sync: "(condition->list exn))
- (delete-file lockfile)
- (exit))
- (thesync last-update)))
- (now-time (current-seconds)))
- (if (and sync-period sync-timeout) ;;
- (if (and (< (- now-time start-time) 600) ;; hard limit on how long we run for
- (> sync-timeout (- now-time last-changed)))
- (begin
- (if sync-period (thread-sleep! sync-period))
- (loop (if (> changes 0) now-time last-changed) now-time))))))))
- (debug:print 0 *default-log-port* "Releasing lock file " lockfile)
- )
- )
- (debug:print 0 *default-log-port* "No sync due to unreadble or non-existant source file"src-db))
- (debug:print 0 *default-log-port* "Usage for -db2db; -to and -from must be specified"))
- (set! *didsomething* #t)))
-
-(if (args:get-arg "-list-test-time")
- (let* ((toppath (launch:setup)))
- (task:get-test-times)
- (set! *didsomething* #t)))
-
-(if (args:get-arg "-list-run-time")
- (let* ((toppath (launch:setup)))
- (task:get-run-times)
- (set! *didsomething* #t)))
-
-(if (args:get-arg "-generate-html")
- (let* ((toppath (launch:setup)))
- (if (tests:create-html-tree #f)
- (debug:print-info 0 *default-log-port* "HTML output created in " toppath "/lt/page0.html")
- (debug:print 0 *default-log-port* "Failed to create HTML output in " toppath "/lt/runs-index.html"))
- (set! *didsomething* #t)))
-
-(if (args:get-arg "-generate-html-structure")
- (let* ((toppath (launch:setup)))
- ;(if (tests:create-html-tree #f)
- (if (tests:create-html-summary #f)
- (debug:print-info 0 *default-log-port* "HTML output created in " toppath "/lt/targets.html")
- (debug:print 0 *default-log-port* "Failed to create HTML output in " toppath "/lt/runs-index.html"))
- (set! *didsomething* #t)))
-
-(if (args:get-arg "-syscheck")
- (begin
- (mutils:syscheck common:raw-get-remote-host-load
- server:get-best-guess-address
- read-config)
- (set! *didsomething* #t)))
-
-(if (args:get-arg "-extract-skeleton")
- (let* ((toppath (launch:setup)))
- (genexample:extract-skeleton-area (args:get-arg "-extract-skeleton"))
- (set! *didsomething* #t)))
-
-;;======================================================================
-;; Exit and clean up
-;;======================================================================
-
-(if (not *didsomething*)
- (debug:print 0 *default-log-port* help)
- (set! *time-to-exit* #t)
- )
-;;(debug:print-info 13 *default-log-port* "thread-join! watchdog")
-
-;; join the watchdog thread if it has been thread-start!ed (it may not have been started in the case of a server that never enters running state)
-;; (symbols returned by thread-state: created ready running blocked suspended sleeping terminated dead)
-;; TODO: for multiple areas, we will have multiple watchdogs; and multiple threads to manage
-;;(if (thread? *watchdog*)
-;; (case (thread-state *watchdog*)
-;; ((ready running blocked sleeping terminated dead)
-;; (thread-join! *watchdog*))))
-
-(set! *time-to-exit* #t)
-
-(if (not (eq? *globalexitstatus* 0))
- (if (or (args:get-arg "-run")(args:get-arg "-runtests")(args:get-arg "-runall"))
- (begin
- (debug:print 0 *default-log-port* "NOTE: Subprocesses with non-zero exit code detected: " *globalexitstatus*)
- (exit 0))
- (case *globalexitstatus*
- ((0)(exit 0))
- ((1)(exit 1))
- ((2)(exit 2))
- (else (exit 3)))))
+(declare (uses mtbody))
+
+(import mtbody)
+
+(main)
Index: megatestmod.scm
==================================================================
--- megatestmod.scm
+++ megatestmod.scm
@@ -39,29 +39,30 @@
(use srfi-69)
(module megatestmod
(
- db:set-tests-state-status
- db:set-state-status-and-roll-up-items
- common:get-install-area
- tests:get-all
- common:use-cache?
-
- mt:lazy-read-test-config
- common:get-full-test-name
- tests:extend-test-patts
- tests:get-itemmaps
- tests:get-items
- tests:get-global-waitons
- tests:get-tests-search-path
- tests:filter-test-names
- common:args-get-testpatt
- tests:filter-test-names-not-matched
- common:args-get-runname
- common:load-views-config
- )
+ common:get-disks
+ db:set-tests-state-status
+ db:set-state-status-and-roll-up-items
+ common:get-install-area
+ tests:get-all
+ common:use-cache?
+
+ mt:lazy-read-test-config
+ common:get-full-test-name
+ tests:extend-test-patts
+ tests:get-itemmaps
+ tests:get-items
+ tests:get-global-waitons
+ tests:get-tests-search-path
+ tests:filter-test-names
+ common:args-get-testpatt
+ tests:filter-test-names-not-matched
+ common:args-get-runname
+ common:load-views-config
+ )
(import scheme)
(cond-expand
(chicken-4
ADDED mtbody.scm
Index: mtbody.scm
==================================================================
--- /dev/null
+++ mtbody.scm
@@ -0,0 +1,2940 @@
+;;======================================================================
+;; Copyright 2017, Matthew Welland.
+;;
+;; This file is part of Megatest.
+;;
+;; Megatest is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+;;
+;; Megatest is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with Megatest. If not, see .
+
+;;======================================================================
+
+;;======================================================================
+;; All the crud that was in megatest.scm
+;;======================================================================
+
+(declare (unit mtbody))
+(declare (uses debugprint))
+(declare (uses mtargs))
+(declare (uses commonmod))
+(declare (uses configfmod))
+(declare (uses dbmod))
+(declare (uses dbfile))
+(declare (uses envmod))
+(declare (uses apimod))
+
+(use srfi-69)
+
+(module mtbody
+ *
+
+(import scheme)
+(cond-expand
+ (chicken-4
+
+ (import chicken
+ ports
+ (prefix base64 base64:)
+
+ (prefix sqlite3 sqlite3:)
+ data-structures
+ directory-utils
+ extras
+ files
+ matchable
+ md5
+ message-digest
+ pathname-expand
+ posix
+ posix-extras
+ regex
+ regex-case
+ sparse-vectors
+ srfi-1
+ srfi-18
+ srfi-69
+ typed-records
+ z3
+
+ debugprint
+ commonmod
+ configfmod
+ ;; tcp-transportmod
+ (prefix mtargs args:)
+ )
+ (use srfi-69))
+ (chicken-5
+ (import (prefix sqlite3 sqlite3:)
+ ;; data-structures
+ ;; extras
+ ;; files
+ ;; posix
+ ;; posix-extras
+ chicken.base
+ chicken.condition
+ chicken.file
+ chicken.file.posix
+ chicken.io
+ chicken.pathname
+ chicken.port
+ chicken.process
+ chicken.process-context
+ chicken.process-context.posix
+ chicken.sort
+ chicken.string
+ chicken.time
+ chicken.time.posix
+
+ matchable
+ md5
+ message-digest
+ pathname-expand
+ regex
+ regex-case
+ srfi-1
+ srfi-18
+ srfi-69
+ typed-records
+ system-information
+
+ debugprint
+ )))
+
+;; imports common to chk5 and ck4
+(import srfi-13)
+
+(import (prefix mtargs args:)
+ debugprint
+ dbmod
+ commonmod
+ processmod
+ configfmod
+ dbfile
+ dbmod
+ portlogger
+ tcp-transportmod
+ rmtmod
+ apimod
+ stml2
+ mtmod
+ megatestmod
+ servermod
+ tasksmod
+ runsmod
+ rmtmod
+ launchmod
+ fsmod
+ envmod
+ apimod
+ )
+
+(define *db* #f) ;; this is only for the repl, do not use in general!!!!
+
+;; (include "common_records.scm")
+;; (include "key_records.scm")
+;; (include "db_records.scm")
+(include "run_records.scm")
+(include "megatest-fossil-hash.scm")
+
+(use (prefix sqlite3 sqlite3:) srfi-1 posix regex regex-case srfi-69 (prefix base64 base64:))
+(use readline apropos json http-client directory-utils typed-records)
+(use http-client srfi-18 extras format tcp-server tcp)
+
+;; Added for csv stuff - will be removed
+;;
+(use sparse-vectors)
+
+(require-library mutils)
+
+;;======================================================================
+;; api handler stuff
+;;======================================================================
+
+;; QUEUE METHOD
+
+(define (api:tcp-dispatch-request-make-handler-new dbstruct) ;; cmd run-id params)
+ (api:tcp-dispatch-request-make-handler-core dbstruct api:dispatch-request))
+
+
+;; indat is (cmd run-id params meta)
+;;
+;; WARNING: Do not print anything in the lambda of this function as it
+;; reads/writes to current in/out port
+;;
+(define (api:tcp-dispatch-request-make-handler-old dbstruct) ;; cmd run-id params)
+ (assert *toppath* "FATAL: api:tcp-dispatch-request-make-handler called but *toppath* not set.")
+ (if (not *server-signature*)
+ (set! *server-signature* (tt:mk-signature *toppath*)))
+ (lambda (indat)
+ (api:register-thread (current-thread))
+ (let* ((result
+ (let* ((numthreads (api:get-count-threads-alive))
+ (delay-wait (if (> numthreads 10)
+ (- numthreads 10)
+ 0))
+ (normal-proc (lambda (cmd run-id params)
+ (case cmd
+ ((ping) *server-signature*)
+ (else
+ (api:dispatch-request dbstruct cmd run-id params))))))
+ (set! *api-process-request-count* numthreads)
+ (set! *db-last-access* (current-seconds))
+;; (if (not (eq? numthreads numthreads))
+;; (begin
+;; (api:remove-dead-or-terminated)
+;; (let ((threads-now (api:get-count-threads-alive)))
+;; (debug:print 0 *default-log-port* "WARNING: numthreads="numthreads", numthreads="numthreads", remaining="threads-now)
+;; (set! numthreads threads-now))))
+ (match indat
+ ((cmd run-id params meta)
+ (let* ((start-t (current-milliseconds))
+ (db-ok (let* ((dbfname (dbmod:run-id->dbfname run-id))
+ (ok (equal? dbfname (dbr:dbstruct-dbfname dbstruct))))
+ (case cmd
+ ((ping) #t) ;; we are fine
+ (else
+ (assert ok "FATAL: database file and run-id not aligned.")))))
+ (ttdat *server-info*)
+ (server-state (tt-state ttdat))
+ (maxthreads 20) ;; make this a parameter?
+ (status (cond
+ ((and (> numthreads maxthreads)
+ (> (random 100) 70)) ;; allow a 30% probability to go through so we can figure out what is going wrong in main.db server.
+ 'busy)
+ ;; ((> numthreads 5) 'loaded) ;; this gets transmitted to the client which calls tt:backoff-incr to slow stuff down.
+ (else 'ok)))
+ (errmsg (case status
+ ((busy) (conc "Server overloaded, "numthreads" threads in flight"))
+ ((loaded) (conc "Server loaded, "numthreads" threads in flight"))
+ (else #f)))
+ (result (case status
+ ((busy)
+ (if (eq? cmd 'ping)
+ (normal-proc cmd run-id params)
+ ;; numthreads must be greater than 5 for busy
+ (* 0.1 (- numthreads maxthreads)) ;; was 15 - return a number for the remote to delay
+ )) ;; (- numthreads 29)) ;; call back in as many seconds
+ ((loaded)
+ (normal-proc cmd run-id params))
+ (else
+ (normal-proc cmd run-id params))))
+ (meta (case cmd
+ ((ping) `((sstate . ,server-state)))
+ (else `((wait . ,delay-wait)))))
+ (payload (list status errmsg result meta)))
+ ;; (cmd run-id params meta)
+ (db:add-stats cmd run-id params (- (current-milliseconds) start-t))
+ payload))
+ (else
+ (assert #f "FATAL: failed to deserialize indat "indat))))))
+ ;; (set! *api-process-request-count* (- *api-process-request-count* 1))
+ ;; (serialize payload)
+
+ (api:unregister-thread (current-thread))
+ result)))
+
+(define api:tcp-dispatch-request-make-handler api:tcp-dispatch-request-make-handler-new) ;; choose -old or -new
+
+;; end api stuff
+
+;; bracket open-output-file with code to make leading directory if it does not exist and handle exceptions
+(define (open-logfile logpath-in)
+ (let ((lpath #f))
+ (condition-case
+ (let* ((log-dir (or (pathname-directory logpath-in) "."))
+ (fname (pathname-strip-directory logpath-in))
+ (logpath (if (> (string-length fname) 250)
+ (let ((newlogf (conc log-dir "/" (common:get-signature fname) ".log")))
+ (debug:print 0 *default-log-port* "WARNING: log file " logpath-in " path too long, converted to " newlogf)
+ newlogf)
+ logpath-in)))
+ (set! lpath logpath) ;; just for printing if error
+ (if (not (directory-exists? log-dir))
+ (system (conc "mkdir -p " log-dir)))
+ (open-output-file logpath))
+ (exn ()
+ (debug:print-error 0 *default-log-port* "Could not open log file for write: "lpath)
+ (define *didsomething* #t)
+ (exit 1)))))
+
+(define (main)
+ ;; remove when configf fully modularized
+ (read-config-set! configf:read-file)
+
+ (define *usage-log-file* #f) ;; put path to file for logging usage in this var in the ~/.megatestrc file
+ (define *usage-use-seconds* #t) ;; for Epoc seconds in usage logging change this to #t in ~/.megatestrc file
+
+ ;; set some parameters here - these need to be put in something that can be loaded from other
+ ;; executables such as dashboard and mtutil
+ ;;
+ (include "transport-mode.scm")
+ (dbfile:db-init-proc db:initialize-main-db)
+ (debug:enable-timestamp #t)
+
+
+ (set! rmtmod:send-receive rmt:send-receive)
+ ;;(lambda params (apply rmt:send-receive params))) ;; make send-receive available to rmtmod via parameter
+
+
+ ;; load the ~/.megatestrc file, put (use trace)(trace-call-sites #t)(trace function-you-want-to-trace) in this file
+ ;;
+ (let ((debugcontrolf (conc (get-environment-variable "HOME") "/.megatestrc")))
+ (if (common:file-exists? debugcontrolf)
+ (load debugcontrolf)))
+
+ ;; usage logging, careful with this, it is not designed to deal with all real world challenges!
+ ;;
+ (if (and *usage-log-file*
+ (file-write-access? *usage-log-file*))
+ (with-output-to-file
+ *usage-log-file*
+ (lambda ()
+ (print (if *usage-use-seconds*
+ (current-seconds)
+ (time->string
+ (seconds->local-time (current-seconds))
+ "%Yww%V.%w %H:%M:%S"))
+ " "
+ (current-user-name) " "
+ (current-directory) " "
+ "\"" (string-intersperse (argv) " ") "\""))
+ #:append))
+
+ ;; Disabled help items
+ ;; -rollup : (currently disabled) fill run (set by :runname) with latest test(s)
+ ;; from prior runs with same keys
+ ;; -daemonize : fork into background and disconnect from stdin/out
+
+ (define help (conc "
+Megatest, documentation at http://www.kiatoa.com/fossils/megatest
+ version " megatest-version "
+ license GPL, Copyright Matt Welland 2006-2017
+
+Usage: megatest [options]
+ -h : this help
+ -manual : show the Megatest user manual
+ -version : print megatest version (currently " megatest-version ")
+
+Launching and managing runs
+ -run : run all tests or as specified by -testpatt
+ -remove-runs : remove the data for a run, requires -runname and -testpatt
+ Optionally use :state and :status, use -keep-records to remove only
+ the run data. Use -kill-wait to override the 10 second
+ per test wait after kill delay (e.g. -kill-wait 0).
+ -kill-runs : kill existing run(s) (all incomplete tests killed)
+ -kill-rerun : kill an existing run (all incomplete tests killed and run is rerun)
+ -set-state-status X,Y : set state to X and status to Y, requires controls per -remove-runs
+ -rerun FAIL,WARN... : force re-run for tests with specificed status(s)
+ -rerun-clean : set all tests not COMPLETED+PASS,WARN,WAIVED to NOT_STARTED,n/a
+ and then run the specified testpatt with -preclean
+ -rerun-all : set all tests to NOT_STARTED,n/a and run with -preclean
+ -lock : lock run specified by target and runname
+ -unlock : unlock run specified by target and runname
+ -set-run-status status : sets status for run to status, requires -target and -runname
+ -get-run-status : gets status for run specified by target and runname
+ -run-wait : wait on run specified by target and runname
+ -preclean : remove the existing test directory before running the test
+ -clean-cache : remove the cached megatest.config and runconfigs.config files
+ -no-cache : do not use the cached config files.
+ -one-pass : launch as many tests as you can but do not wait for more to be ready
+ -remove-keep N : remove all but N most recent runs per target; use '-actions, -age, -precmd'
+ -age : 120d,3h,20m to apply only to runs older than the
+ specified age. NB// M=month, m=minute
+ -actions [,...] : actions to take; print,remove-runs,archive,kill-runs
+ -precmd : insert a wrapper command in front of the commands run
+
+Selectors (e.g. use for -runtests, -remove-runs, -set-state-status, -list-runs etc.)
+ -target key1/key2/... : run for key1, key2, etc.
+ -reqtarg key1/key2/... : run for key1, key2, etc. but key1/key2 must be in runconfigs
+ -testpatt patt1/patt2,patt3/... : % is wildcard
+ -runname : required, name for this particular test run
+ -state : Applies to runs, tests or steps depending on context
+ -status : Applies to runs, tests or steps depending on context
+ -modepatt key : load testpatt from in runconfigs instead of default TESTPATT if -testpatt and -tagexpr are not specified
+ -tagexpr tag1,tag2%,.. : select tests with tags matching expression
+
+
+Test helpers (for use inside tests)
+ -step stepname
+ -test-status : set the state and status of a test (use :state and :status)
+ -setlog logfname : set the path/filename to the final log relative to the test
+ directory. may be used with -test-status
+ -set-toplog logfname : set the overall log for a suite of sub-tests
+ -summarize-items : for an itemized test create a summary html
+ -m comment : insert a comment for this test
+
+Test data capture
+ -set-values : update or set values in the testdata table
+ :category : set the category field (optional)
+ :variable : set the variable name (optional)
+ :value : value measured (required)
+ :expected : value expected (required)
+ :tol : |value-expect| <= tol (required, can be <, >, >=, <= or number)
+ :units : name of the units for value, expected_value etc. (optional)
+ -load-test-data : read test specific data for storage in the test_data table
+ from standard in. Each line is comma delimited with four
+ fields category,variable,value,comment
+
+Queries
+ -list-runs patt : list runs matching pattern \"patt\", % is the wildcard
+ -show-keys : show the keys used in this megatest setup
+ -test-files targpatt : get the most recent test path/file matching targpatt e.g. %/% or '*.log'
+ returns list sorted by age ascending, see examples below
+ -test-paths : get the test paths matching target, runname, item and test
+ patterns.
+ -list-disks : list the disks available for storing runs
+ -list-targets : list the targets in runconfigs.config
+ -list-db-targets : list the target combinations used in the db
+ -show-config : dump the internal representation of the megatest.config file
+ -show-runconfig : dump the internal representation of the runconfigs.config file
+ -dumpmode MODE : dump in MODE format instead of sexpr, MODE=json,ini,sexp etc. (add -debug 0,9 to see which file contributes each line)
+ -show-cmdinfo : dump the command info for a test (run in test environment)
+ -section sectionName
+ -var varName : for config and runconfig lookup value for sectionName varName
+ -since N : get list of runs changed since time N (Unix seconds)
+ -fields fieldspec : fields to include in json dump; runs:id,runame+tests:testname+steps
+ -sort fieldname : in -list-runs sort tests by this field
+ -testdata-csv [categorypatt/]varpatt : dump testdata for given category
+
+Misc
+ -start-dir path : switch to this directory before running megatest
+ -contour cname : add a level of hierarcy to the linktree and run paths
+ -area-tag tagname : add a tag to an area while syncing to pgdb
+ -run-tag tagname : add a tag to a run while syncing to pgdb
+ -rebuild-db : bring the database schema up to date
+ -cleanup-db : remove any orphan records, vacuum the db
+ -import-megatest.db : push data from megatest.db to cache db files in /tmp/$USER
+ -sync-to-megatest.db : pull data from cache files in /tmp/$USER to megatest.db
+ -sync-to dest : sync to new postgresql central style database
+ -update-meta : update the tests metadata for all tests
+ -setvars VAR1=val1,VAR2=val2 : Add environment variables to a run NB// these are
+ overwritten by values set in config files.
+ -server -|hostname : start the server (reduces contention on megatest.db), use
+ - to automatically figure out hostname
+ -adjutant C,M : start the server/adjutant with allocated cores C and Mem M (Gig),
+ use 0,0 to auto use full machine
+ -transport http|rpc : use http or rpc for transport (default is http)
+ -log logfile : send stdout and stderr to logfile
+ -list-servers : list the servers
+ -kill-servers : kill all servers
+ -repl : start a repl (useful for extending megatest)
+ -load file.scm : load and run file.scm
+ -mark-incompletes : find and mark incomplete tests
+ -ping run-id|host:port : ping server, exit with 0 if found
+ -debug N|N,M,O... : enable debug 0-N or N and M and O ...
+ -debug-noprop N|M,M,O...: enable debug but do not propagate to subprocesses via MT_DEBUG
+ -config fname : override the megatest.config file with fname
+ -append-config fname : append fname to the megatest.config file
+ -import-sexpr fname : import a sexpr file (use -list-runs % -dumpmode sexpr to create)
+ -remove-dbs all : remove Megatest DBs before importing sexpr. (Use only with -import-sexpr)
+ -regen-testfiles : regenerate scripts and logpro files from testconfig, run in test context
+
+Utilities
+ -env2file fname : write the environment to fname.csh and fname.sh
+ -envcap a : save current variables labeled as context 'a' in file envdat.db
+ -envdelta a-b : output enviroment delta from context a to context b to -o fname
+ set the output mode with -dumpmode csh, bash or ini
+ note: ini format will use calls to use curr and minimize path
+ -refdb2dat refdb : convert refdb to sexp or to format specified by s-dumpmode
+ formats: perl, ruby, sqlite3, csv (for csv the -o param
+ will substitute %s for the sheet name in generating
+ multiple sheets)
+ -o : output file for refdb2dat (defaults to stdout)
+ -archive cmd : archive runs specified by selectors to one of disks specified
+ in the [archive-disks] section.
+ cmd: keep-html, restore, save, save-remove, get, replicate-db (use
+ -dest to set destination), -include path1,path2... to get or save specific files
+ -generate-html : create a simple html dashboard for browsing your runs
+ -generate-html-structure : create a top level html veiw to list targets/runs and a Run view within each run directory.
+ -list-run-time : list time requered to complete runs. It supports following switches
+ -run-patt -target-patt -dumpmode
+ -list-test-time : list time requered to complete each test in a run. It following following arguments
+ -runname -target -dumpmode
+ -syscheck : do some very basic checks; write access and space in tmp, home, runs, links and
+ is $DISPLAY valid
+ -list-waivers : dump waivers for specified target, runname, testpatt to stdout
+ -db2db : sync db to db, use -from, -to for dbs, -period and -timeout for continuous sync
+
+Diff report
+ -diff-rep : generate diff report (must include -src-target, -src-runname, -target, -runname
+ and either -diff-email or -diff-html)
+ -src-target
+ -src-runname
+ -diff-email : comma separated list of email addresses to send diff report
+ -diff-html : path to html file to generate
+
+Spreadsheet generation
+ -extract-ods fname.ods : extract an open document spreadsheet from the database
+ -pathmod path : insert path, i.e. path/runame/itempath/logfile.html
+ will clear the field if no rundir/testname/itempath/logfile
+ if it contains forward slashes the path will be converted
+ to windows style
+Getting started
+ -create-megatest-area : create a skeleton megatest area. You will be prompted for paths
+ -create-test testname : create a skeleton megatest test. You will be prompted for info
+
+Examples
+
+# Get test path, use '.' to get a single path or a specific path/file pattern
+megatest -test-files 'logs/*.log' -target ubuntu/n%/no% -runname w49% -testpatt test_mt%
+
+Called as " (string-intersperse (argv) " ") "
+Version " megatest-version ", built from " megatest-fossil-hash ))
+
+ ;; -gui : start a gui interface
+ ;; -config fname : override the runconfigs file with fname
+
+ ;; process args
+ (define remargs (args:get-args
+ (argv)
+ (list "-runtests" ;; run a specific test
+ "-config" ;; override the config file name
+ "-append-config"
+ "-execute" ;; run the command encoded in the base64 parameter
+ "-step"
+ "-target"
+ "-reqtarg"
+ ":runname"
+ "-runname"
+ ":state"
+ "-state"
+ ":status"
+ "-status"
+ "-list-runs"
+ "-testdata-csv"
+ "-testpatt"
+ ;; "--modepatt"
+ "-modepatt"
+ "-tagexpr"
+ "-itempatt"
+ "-setlog"
+ "-set-toplog"
+ "-runstep"
+ "-logpro"
+ "-m"
+ "-rerun"
+
+ "-days"
+ "-rename-run"
+ "-from"
+ "-to"
+ "-dest"
+ "-source"
+ "-time-stamp"
+ ;; values and messages
+ ":category"
+ ":variable"
+ ":value"
+ ":expected"
+ ":tol"
+ ":units"
+
+ ;; misc
+ "-start-dir"
+ "-run-patt"
+ "-target-patt"
+ "-contour"
+ "-area-tag"
+ "-area"
+ "-run-tag"
+ "-server"
+ "-adjutant"
+ "-transport"
+ "-port"
+ "-extract-ods"
+ "-pathmod"
+ "-env2file"
+ "-envcap"
+ "-envdelta"
+ "-setvars"
+ "-set-state-status"
+ "-import-sexpr"
+ "-remove-dbs" ;; to be used only with -import-sexpr to remove megatest dbs first.
+ "-period" ;; sync period in seconds
+ "-timeout" ;; exit sync if timeout in seconds exceeded since last change
+
+ ;; move runs stuff here
+ "-remove-keep"
+ "-set-run-status"
+ "-age"
+
+ ;; archive
+ "-archive"
+ "-actions"
+ "-precmd"
+ "-include"
+ "-exclude-rx"
+ "-exclude-rx-from"
+
+ "-debug" ;; for *verbosity* > 2
+ "-debug-noprop"
+ "-create-test"
+ "-override-timeout"
+ "-test-files" ;; -test-paths is for listing all
+ "-load" ;; load and exectute a scheme file
+ "-section"
+ "-var"
+ "-dumpmode"
+ "-run-id"
+ "-db"
+ "-ping"
+ "-refdb2dat"
+ "-o"
+ "-log"
+ "-sync-log"
+ "-since"
+ "-fields"
+ "-recover-test" ;; run-id,test-id - used internally to recover a test stuck in RUNNING state
+ "-sort"
+ "-target-db"
+ "-source-db"
+ "-prefix-target"
+
+ "-src-target"
+ "-src-runname"
+ "-diff-email"
+ "-sync-to"
+ "-pgsync"
+ "-kill-wait" ;; wait this long before removing test (default is 10 sec)
+ "-diff-html"
+
+ ;; wizards, area capture, setup new ...
+ "-extract-skeleton"
+ )
+ (list "-h" "-help" "--help"
+ "-manual"
+ "-version"
+ "-force"
+ "-xterm"
+ "-showkeys"
+ "-show-keys"
+ "-test-status"
+ "-set-values"
+ "-load-test-data"
+ "-summarize-items"
+ "-gui"
+ "-daemonize"
+ "-preclean"
+ "-rerun-clean"
+ "-rerun-all"
+ "-clean-cache"
+ "-no-cache"
+ "-cache-db"
+ "-cp-eventtime-to-publishtime"
+ "-use-db-cache"
+ "-prepend-contour"
+
+
+ ;; misc
+ "-repl"
+ "-lock"
+ "-unlock"
+ "-list-servers"
+ "-kill-servers"
+ "-run-wait" ;; wait on a run to complete (i.e. no RUNNING)
+ "-one-pass" ;;
+ "-local" ;; run some commands using local db access
+ "-generate-html"
+ "-generate-html-structure"
+ "-list-run-time"
+ "-list-test-time"
+ "-regen-testfiles"
+
+ ;; misc queries
+ "-list-disks"
+ "-list-targets"
+ "-list-db-targets"
+ "-show-runconfig"
+ "-show-config"
+ "-show-cmdinfo"
+ "-get-run-status"
+ "-list-waivers"
+
+ ;; queries
+ "-test-paths" ;; get path(s) to a test, ordered by youngest first
+
+ "-runall" ;; run all tests, respects -testpatt, defaults to %
+ "-run" ;; alias for -runall
+ "-remove-runs"
+ "-kill-runs"
+ "-kill-rerun"
+ "-keep-records" ;; use with -remove-runs to remove only the run data
+ "-rebuild-db"
+ "-cleanup-db"
+ "-rollup"
+ "-update-meta"
+ "-create-megatest-area"
+ "-mark-incompletes"
+
+ "-convert-to-norm"
+ "-convert-to-old"
+ "-import-megatest.db"
+ "-sync-to-megatest.db"
+ "-db2db"
+ "-sync-brute-force"
+ "-logging"
+ "-v" ;; verbose 2, more than normal (normal is 1)
+ "-q" ;; quiet 0, errors/warnings only
+
+ "-diff-rep"
+
+ "-syscheck"
+ "-obfuscate"
+ ;; junk placeholder
+ ;; "-:p"
+
+ )
+ args:arg-hash
+ 0))
+
+ ;; Add args that use remargs here
+ ;;
+ (if (and (not (null? remargs))
+ (not (or
+ (args:get-arg "-runstep")
+ (args:get-arg "-envcap")
+ (args:get-arg "-envdelta")
+ )
+ ))
+ (debug:print-error 0 *default-log-port* "Unrecognised arguments: " (string-intersperse (if (list? remargs) remargs (argv)) " ")))
+
+ ;; before doing anything else change to the start-dir if provided
+ ;;
+ (if (args:get-arg "-start-dir")
+ (if (common:file-exists? (args:get-arg "-start-dir"))
+ (let ((fullpath (common:real-path (args:get-arg "-start-dir"))))
+ (setenv "PWD" fullpath)
+ (change-directory fullpath))
+ (begin
+ (debug:print-error 0 *default-log-port* "non-existant start dir " (args:get-arg "-start-dir") " specified, exiting.")
+ (exit 1))))
+
+ ;; immediately set MT_TARGET if -reqtarg or -target are available
+ ;;
+ (let ((targ (or (args:get-arg "-reqtarg")(args:get-arg "-target"))))
+ (if targ (setenv "MT_TARGET" targ)))
+
+ ;; set the purpose field in procinf
+
+ (procinf-purpose-set! *procinf* (get-purpose args:arg-hash))
+ (procinf-mtversion-set! *procinf* megatest-version)
+
+ ;; The watchdog is to keep an eye on things like db sync etc.
+ ;;
+
+ ;; TODO: for multiple areas, we will have multiple watchdogs; and multiple threads to manage
+ ;;(define *watchdog* (make-thread
+ ;; (lambda ()
+ ;; (handle-exceptions
+ ;; exn
+ ;; (begin
+ ;; (print-call-chain)
+ ;; (print " message: " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn))
+ ;; (common:watchdog)))
+ ;; "Watchdog thread"))
+
+ ;;(if (not (args:get-arg "-server"))
+ ;; (thread-start! *watchdog*)) ;; if starting a server; wait till we get to running state before kicking off watchdog
+ (let* ((no-watchdog-args
+ '("-list-runs"
+ "-testdata-csv"
+ "-list-servers"
+ "-server"
+ "-adjutant"
+ "-list-disks"
+ "-list-targets"
+ "-show-runconfig"
+ ;;"-list-db-targets"
+ "-show-runconfig"
+ "-show-config"
+ "-show-cmdinfo"
+ "-cleanup-db"
+ ))
+ (no-watchdog-argvals (list '("-archive" . "replicate-db")))
+ (start-watchdog-specail-arg-val (let loop ((hed (car no-watchdog-argvals))
+ (tail (cdr no-watchdog-argvals)))
+ ;; (print "hed" hed " arg " (args:get-arg (car hed)) " val:" (cdr hed) " eql" (equal? (args:get-arg (car hed)) (cdr hed)))
+ (if (equal? (args:get-arg (car hed)) (cdr hed))
+ #f
+ (if (null? tail)
+ #t
+ (loop (car tail) (cdr tail))))))
+ (no-watchdog-args-vals (filter (lambda (x) x)
+ (map args:get-arg no-watchdog-args)))
+ (start-watchdog (and (null? no-watchdog-args-vals) start-watchdog-specail-arg-val)))
+ ;(print "no-watchdog-args="no-watchdog-args "no-watchdog-args-vals="no-watchdog-args-vals " start-watchdog-specail-arg-val:" start-watchdog-specail-arg-val " start-watchdog:" start-watchdog)
+ ;; (if start-watchdog
+ ;; (thread-start! *watchdog*))
+ #t
+ )
+
+ ;; stop the train watchdog
+ (stop-the-train)
+
+ ;; this segment will run launch:setup only if -log is not set. This is fairly safe as servers are not
+ ;; manually started and thus should never be started in a non-megatest area. Thus no need to handle situation
+ ;; where (launch:setup) returns #f?
+ ;;
+ (if (or (args:get-arg "-log")#;(args:get-arg "-server")) ;; redirect the log always when a server
+ (handle-exceptions
+ exn
+ (begin
+ (print "ERROR: Failed to switch to log output. " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn))
+ (let* ((tl (or (args:get-arg "-log")(launch:setup))) ;; run launch:setup if -server, ensure we do NOT run launch:setup if -log specified
+ (dbname (args:get-arg "-db")) ;; for the server logfile name
+ (logf (or (args:get-arg "-log") ;; use -log unless we are a server, then craft a logfile name
+ (conc tl "/logs/server-"(or dbname "unk")"-"(current-process-id) "-" (get-host-name) ".log")))
+ (oup (open-logfile logf)))
+ (if (not (args:get-arg "-log"))
+ (hash-table-set! args:arg-hash "-log" logf)) ;; fake out future queries of -log
+ (debug:print-info 0 *default-log-port* "Sending log output to " logf)
+ (set! *default-log-port* oup))))
+
+ (if (or (args:get-arg "-h")
+ (args:get-arg "-help")
+ (args:get-arg "--help"))
+ (begin
+ (print help)
+ (exit)))
+
+ (if (args:get-arg "-manual")
+ (let* ((htmlviewercmd (or (configf:lookup *configdat* "setup" "htmlviewercmd")
+ (common:which '("firefox" "arora"))))
+ (install-home (common:get-install-area))
+ (manual-html (conc install-home "/share/docs/megatest_manual.html")))
+ (if (and install-home
+ (common:file-exists? manual-html))
+ (system (conc "(" htmlviewercmd " " manual-html " ) &"))
+ (system (conc "(" htmlviewercmd " http://www.kiatoa.com/cgi-bin/fossils/megatest/doc/tip/docs/manual/megatest_manual.html ) &")))
+ (exit)))
+
+ (if (args:get-arg "-version")
+ (begin
+ (print (common:version-signature)) ;; (print megatest-version)
+ (exit)))
+
+ (define *didsomething* #f)
+
+ ;; Overall exit handling setup immediately
+ ;;
+ (if (or (args:get-arg "-process-reap"))
+ ;; (args:get-arg "-runtests")
+ ;; (args:get-arg "-execute")
+ ;; (args:get-arg "-remove-runs")
+ ;; (args:get-arg "-runstep"))
+ (let ((original-exit (exit-handler)))
+ (exit-handler (lambda (#!optional (exit-code 0))
+ (printf "Preparing to exit with exit code ~A ...\n" exit-code)
+ (for-each
+
+ (lambda (pid)
+ (handle-exceptions
+ exn
+ (begin
+ (printf "process reap failed. exn=~A\n" exn)
+ #t)
+ (let-values (((pid-val exit-status exit-code) (process-wait pid #t)))
+ (if (or (eq? pid-val pid)
+ (eq? pid-val 0))
+ (begin
+ (printf "Sending signal/term to ~A\n" pid)
+ (process-signal pid signal/term))))))
+ (process:children #f))
+ (original-exit exit-code)))))
+
+ ;; for some switches always print the command to stderr
+ ;;
+ (if (args:any-defined? "-run" "-runall" "-remove-runs" "-set-state-status" "-kill-runs" "-kill-rerun")
+ (debug:print 0 *default-log-port* (string-intersperse (argv) " ")))
+
+
+ ;;======================================================================
+ ;; Misc setup stuff
+ ;;======================================================================
+
+ (debug:setup)
+
+ (if (args:get-arg "-logging")(set! *logging* #t))
+
+ ;;(if (debug:debug-mode 3) ;; we are obviously debugging
+ ;; (set! open-run-close open-run-close-no-exception-handling))
+
+ (if (args:get-arg "-itempatt")
+ (let ((newval (conc (args:get-arg "-testpatt") "/" (args:get-arg "-itempatt"))))
+ (debug:print 0 *default-log-port* "WARNING: -itempatt has been deprecated, please use -testpatt testpatt/itempatt method, new testpatt is "newval)
+ (hash-table-set! args:arg-hash "-testpatt" newval)
+ (hash-table-delete! args:arg-hash "-itempatt")))
+
+ (if (args:get-arg "-runtests")
+ (debug:print 0 *default-log-port* "WARNING: \"-runtests\" is deprecated. Use \"-run\" with \"-testpatt\" instead"))
+
+ (on-exit std-exit-procedure)
+
+ ;;======================================================================
+ ;; Misc general calls
+ ;;======================================================================
+
+ (if (and (args:get-arg "-cache-db")
+ (args:get-arg "-source-db"))
+ (let* ((temp-dir (or (args:get-arg "-target-db") (create-directory (conc "/tmp/" (getenv "USER") "/" (string-translate (current-directory) "/" "_")))))
+ (target-db (conc temp-dir "/cached.db"))
+ (source-db (args:get-arg "-source-db")))
+ (db:cache-for-read-only source-db target-db)
+ (set! *didsomething* #t)))
+
+ ;; handle a clean-cache request as early as possible
+ ;;
+ (if (args:get-arg "-clean-cache")
+ (let ((toppath (launch:setup)))
+ (set! *didsomething* #t) ;; suppress the help output.
+ (runs:clean-cache (common:args-get-target)
+ (args:get-arg "-runname")
+ toppath)))
+
+ (if (args:get-arg "-env2file")
+ (begin
+ (save-environment-as-files (args:get-arg "-env2file"))
+ (set! *didsomething* #t)))
+
+ (if (args:get-arg "-list-disks")
+ (let ((toppath (launch:setup)))
+ (print (string-intersperse
+ (map (lambda (x)
+ (string-intersperse
+ x
+ " => "))
+ (common:get-disks *configdat*))
+ "\n"))
+ (set! *didsomething* #t)))
+
+ ;; csv processing record
+ (define (make-refdb:csv)
+ (vector
+ (make-sparse-array)
+ (make-hash-table)
+ (make-hash-table)
+ 0
+ 0))
+ (define-inline (refdb:csv-get-svec vec) (vector-ref vec 0))
+ (define-inline (refdb:csv-get-rows vec) (vector-ref vec 1))
+ (define-inline (refdb:csv-get-cols vec) (vector-ref vec 2))
+ (define-inline (refdb:csv-get-maxrow vec) (vector-ref vec 3))
+ (define-inline (refdb:csv-get-maxcol vec) (vector-ref vec 4))
+ (define-inline (refdb:csv-set-svec! vec val)(vector-set! vec 0 val))
+ (define-inline (refdb:csv-set-rows! vec val)(vector-set! vec 1 val))
+ (define-inline (refdb:csv-set-cols! vec val)(vector-set! vec 2 val))
+ (define-inline (refdb:csv-set-maxrow! vec val)(vector-set! vec 3 val))
+ (define-inline (refdb:csv-set-maxcol! vec val)(vector-set! vec 4 val))
+
+ (define (get-dat results sheetname)
+ (or (hash-table-ref/default results sheetname #f)
+ (let ((tmp-vec (make-refdb:csv)))
+ (hash-table-set! results sheetname tmp-vec)
+ tmp-vec)))
+
+ (if (args:get-arg "-refdb2dat")
+ (let* ((input-db (args:get-arg "-refdb2dat"))
+ (out-file (args:get-arg "-o"))
+ (out-fmt (or (args:get-arg "-dumpmode") "scheme"))
+ (out-port (if (and out-file
+ (not (member out-fmt '("sqlite3" "csv"))))
+ (open-output-file out-file)
+ (current-output-port)))
+ (res-data (configf:read-refdb input-db))
+ (data (car res-data))
+ (msg (cadr res-data)))
+ (if (not data)
+ (debug:print 0 *default-log-port* "Bad input? data=" data) ;; some error occurred
+ (with-output-to-port out-port
+ (lambda ()
+ (case (string->symbol out-fmt)
+ ((scheme)(pp data))
+ ((perl)
+ ;; (print "%hash = (")
+ ;; key1 => 'value1',
+ ;; key2 => 'value2',
+ ;; key3 => 'value3',
+ ;; );
+ (configf:map-all-hier-alist
+ data
+ (lambda (sheetname sectionname varname val)
+ (print "$data{\"" sheetname "\"}{\"" sectionname "\"}{\"" varname "\"} = \"" val "\";"))))
+ ((python ruby)
+ (print "data={}")
+ (configf:map-all-hier-alist
+ data
+ (lambda (sheetname sectionname varname val)
+ (print "data[\"" sheetname "\"][\"" sectionname "\"][\"" varname "\"] = \"" val "\""))
+ initproc1:
+ (lambda (sheetname)
+ (print "data[\"" sheetname "\"] = {}"))
+ initproc2:
+ (lambda (sheetname sectionname)
+ (print "data[\"" sheetname "\"][\"" sectionname "\"] = {}"))))
+ ((csv)
+ (let* ((results (make-hash-table)) ;; (make-sparse-array)))
+ (row-cols (make-hash-table))) ;; hash of hashes where section => ht { row- => num or col- => num
+ ;; (print "data=")
+ ;; (pp data)
+ (configf:map-all-hier-alist
+ data
+ (lambda (sheetname sectionname varname val)
+ ;; (print "sheetname: " sheetname ", sectionname: " sectionname ", varname: " varname ", val: " val)
+ (let* ((dat (get-dat results sheetname))
+ (vec (refdb:csv-get-svec dat))
+ (rownames (refdb:csv-get-rows dat))
+ (colnames (refdb:csv-get-cols dat))
+ (currrown (hash-table-ref/default rownames varname #f))
+ (currcoln (hash-table-ref/default colnames sectionname #f))
+ (rown (or currrown
+ (let* ((lastn (refdb:csv-get-maxrow dat))
+ (newrown (+ lastn 1)))
+ (refdb:csv-set-maxrow! dat newrown)
+ newrown)))
+ (coln (or currcoln
+ (let* ((lastn (refdb:csv-get-maxcol dat))
+ (newcoln (+ lastn 1)))
+ (refdb:csv-set-maxcol! dat newcoln)
+ newcoln))))
+ (if (not (sparse-array-ref vec 0 coln)) ;; (eq? rown 0)
+ (begin
+ (sparse-array-set! vec 0 coln sectionname)
+ ;; (print "sparse-array-ref " 0 "," coln "=" (sparse-array-ref vec 0 coln))
+ ))
+ (if (not (sparse-array-ref vec rown 0)) ;; (eq? coln 0)
+ (begin
+ (sparse-array-set! vec rown 0 varname)
+ ;; (print "sparse-array-ref " rown "," 0 "=" (sparse-array-ref vec rown 0))
+ ))
+ (if (not currrown)(hash-table-set! rownames varname rown))
+ (if (not currcoln)(hash-table-set! colnames sectionname coln))
+ ;; (print "dat=" dat ", rown=" rown ", coln=" coln)
+ (sparse-array-set! vec rown coln val)
+ ;; (print "sparse-array-ref " rown "," coln "=" (sparse-array-ref vec rown coln))
+ )))
+ (for-each
+ (lambda (sheetname)
+ (let* ((sheetdat (get-dat results sheetname))
+ (svec (refdb:csv-get-svec sheetdat))
+ (maxrow (refdb:csv-get-maxrow sheetdat))
+ (maxcol (refdb:csv-get-maxcol sheetdat))
+ (fname (if out-file
+ (string-substitute "%s" sheetname out-file) ;; "/foo/bar/%s.csv")
+ (conc sheetname ".csv"))))
+ (with-output-to-file fname
+ (lambda ()
+ ;; (print "Sheetname: " sheetname)
+ (let loop ((row 0)
+ (col 0)
+ (curr-row '())
+ (result '()))
+ (let* ((val (sparse-array-ref svec row col))
+ (disp-val (if val
+ (conc "\"" val "\"")
+ "")))
+ (if (> col 0)(display ","))
+ (display disp-val)
+ (cond
+ ((> row maxrow)(display "\n") result)
+ ((>= col maxcol)
+ (display "\n")
+ (loop (+ row 1) 0 '() (append result (list curr-row))))
+ (else
+ (loop row (+ col 1) (append curr-row (list val)) result)))))))))
+ (hash-table-keys results))))
+ ((sqlite3)
+ (let* ((db-file (or out-file (pathname-file input-db)))
+ (db-exists (common:file-exists? db-file))
+ (db (sqlite3:open-database db-file)))
+ (if (not db-exists)(sqlite3:execute db "CREATE TABLE data (sheet,section,var,val);"))
+ (configf:map-all-hier-alist
+ data
+ (lambda (sheetname sectionname varname val)
+ (sqlite3:execute db
+ "INSERT OR REPLACE INTO data (sheet,section,var,val) VALUES (?,?,?,?);"
+ sheetname sectionname varname val)))
+ (sqlite3:finalize! db)))
+ (else
+ (pp data))))))
+ (if out-file (close-output-port out-port))
+ (exit) ;; yes, bending the rules here - need to exit since this is a utility
+ ))
+
+ (if (args:get-arg "-ping")
+ (let* ((server-id (string->number (args:get-arg "-ping"))) ;; extract run-id (i.e. no ":"
+ (host:port (args:get-arg "-ping")))
+ (debug:print 0 *default-log-port* "NOT YET REIMPLEMENTED FOR TCP/INMEM") ;; bug
+ (exit)))
+ ;; (server:ping (or server-id host:port) #f do-exit: #t)))
+
+ ;;======================================================================
+ ;; 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-error 0 *default-log-port* "Parameter to -envdelta should be new=start-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
+ ;;======================================================================
+
+ ;; Server? Start up here.
+ ;;
+ (if (args:get-arg "-server")
+ (let* (;; (run-id (args:get-arg "-run-id"))
+ (dbfname (args:get-arg "-db"))
+ (tl (launch:setup))
+ (keys (keys:config-get-fields *configdat*)))
+ (case (rmt:transport-mode)
+ ((tcp)
+ (let* ((timeout (server:expiration-timeout)))
+ (debug:print 0 *default-log-port* "INFO: megatest -server starting on " (get-host-name) " for " dbfname " using tcp method with timeout of "timeout)
+ (tt-server-timeout-param timeout)
+ (api:queue-processor)
+ (thread-start! (make-thread api:print-db-stats "print-db-stats"))
+ (if dbfname
+ (tt:start-server tl #f dbfname api:tcp-dispatch-request-make-handler keys)
+ (begin
+ (debug:print 0 *default-log-port* "ERROR: transport mode is tcp - -db is required.")
+ (exit 1)))))
+ ((nfs)(debug:print 0 *default-log-port* "WARNING: server start called in nfs mode '"(rmt:transport-mode)))
+ (else (debug:print 0 *default-log-port* "ERROR: rmt:transport-mode value not recognised "(rmt:transport-mode))))
+ (set! *didsomething* #t)))
+
+ ;; The adjutant is a bit different, it does NOT run (launch:setup) as it is not necessarily tied to
+ ;; a specific Megatest area. Detail are being hashed out and this may change.
+ ;;
+ (if (args:get-arg "-adjutant")
+ (begin
+ ;; (adjutant-run)
+ (set! *didsomething* #t)))
+
+ (if (args:get-arg "-list-servers")
+ (let* ((tl (launch:setup)) ;; need this to initialize *toppath*
+ (servdir (tt:get-servinfo-dir *toppath*))
+ (servfiles (glob (conc servdir "/*:*.db")))
+ (fmtstr "~10a~22a~10a~25a~25a~8a\n")
+ (dbfiles (append (glob (conc *toppath* "/.mtdb/main.db")) (glob (conc *toppath* "/.mtdb/?.db"))(glob (conc *toppath* "/.mtdb/??.db"))))
+ (ttdat (make-tt areapath: *toppath*))
+ )
+ (format #t fmtstr "DB" "host:port" "PID" "age" "last mod" "state")
+ (for-each
+ (lambda (dbfile)
+ (let* (
+ (dbfname (conc (pathname-file dbfile) ".db"))
+ (sfiles (tt:find-server *toppath* dbfname))
+ )
+ (for-each
+ (lambda (sfile)
+ (let (
+ (sinfos (tt:get-server-info-sorted ttdat dbfname))
+ )
+ (for-each
+ (lambda (sinfo)
+ (let* (
+ (db (list-ref sinfo 5))
+ (pid (list-ref sinfo 4))
+ (host (list-ref sinfo 0))
+ (port (list-ref sinfo 1))
+ (server-id (list-ref sinfo 3))
+ (age (seconds->hr-min-sec (- (current-seconds) (list-ref sinfo 2))))
+ (last-mod (seconds->string (list-ref sinfo 2)))
+ (status (system (conc "ssh " host " ps " pid " > /dev/null")))
+ (state (if (> status 0)
+ "dead"
+ (tt:ping host port server-id 0)
+ ))
+ )
+ (format #t fmtstr db (conc host ":" port) pid age last-mod state)
+ )
+ )
+ sinfos
+ )
+ )
+ )
+ sfiles
+ )
+ )
+ )
+ dbfiles
+ )
+ (set! *didsomething* #t)
+ (exit)
+ )
+ )
+
+
+
+
+ (if (args:get-arg "-kill-servers")
+
+ (let* ((tl (launch:setup)) ;; need this to initialize *toppath*
+ (servdir (tt:get-servinfo-dir *toppath*))
+ (servfiles (glob (conc servdir "/*:*.db")))
+ (fmtstr "~10a~22a~10a~25a~25a~8a\n")
+ (dbfiles (if (file-exists? (conc *toppath* "/.mtdb/main.db")) (append (glob (conc *toppath* "/.mtdb/main.db")) (glob (conc *toppath* "/.mtdb/?.db"))(glob (conc *toppath* "/.mtdb/??.db"))) '()))
+ (ttdat (make-tt areapath: *toppath*))
+ )
+ (format #t fmtstr "DB" "host:port" "PID" "age" "last mod" "state")
+ (for-each
+ (lambda (dbfile)
+ (let* (
+ (dbfname (conc (pathname-file dbfile) ".db"))
+ (sfiles (tt:find-server *toppath* dbfname))
+ )
+ (for-each
+ (lambda (sfile)
+ (let (
+ (sinfos (tt:get-server-info-sorted ttdat dbfname))
+ )
+ (for-each
+ (lambda (sinfo)
+ (let* (
+ (db (list-ref sinfo 5))
+ (pid (list-ref sinfo 4))
+ (host (list-ref sinfo 0))
+ (port (list-ref sinfo 1))
+ (server-id (list-ref sinfo 3))
+ (age (seconds->hr-min-sec (- (current-seconds) (list-ref sinfo 2))))
+ (last-mod (seconds->string (list-ref sinfo 2)))
+ (killed (system (conc "ssh " host " kill " pid " > /dev/null")))
+ (dummy2 (sleep 1))
+ (state (if (> (system (conc "ssh " host " ps " pid " > /dev/null")) 0) "dead" "alive"))
+ )
+ (format #t fmtstr db (conc host ":" port) pid age last-mod state)
+ (system (conc "rm " sfile))
+ )
+ )
+ sinfos
+ )
+ )
+ )
+ sfiles
+ )
+ )
+ )
+ dbfiles
+ )
+ ;; remove this db, because otherwise metadata contains records for old servers, and this causes a problem with db:no-sync-get-lock-with-id.
+ (if (file-exists? (conc *toppath* "/.mtdb/no-sync.db"))
+ (delete-file (conc *toppath* "/.mtdb/no-sync.db"))
+ )
+ (set! *didsomething* #t)
+ (exit)
+ )
+ )
+
+ ;;======================================================================
+ ;; Weird special calls that need to run *after* the server has started?
+ ;;======================================================================
+
+ (if (args:get-arg "-list-targets")
+ (if (launch:setup)
+ (let ((targets (common:get-runconfig-targets)))
+ ;; (debug:print 1 *default-log-port* "Found "(length targets) " targets")
+ (case (string->symbol (or (args:get-arg "-dumpmode") "alist"))
+ ((alist)
+ (for-each (lambda (x)
+ ;; (print "[" x "]"))
+ (print x))
+ targets))
+ ((json)
+ (json-write targets))
+ (else
+ (debug:print-error 0 *default-log-port* "dump output format " (args:get-arg "-dumpmode") " not supported for -list-targets")))
+ (set! *didsomething* #t))))
+
+ (if (args:get-arg "-show-runconfig")
+ (let ((tl (launch:setup)))
+ (push-directory *toppath*)
+ (let ((data (full-runconfigs-read)))
+ ;; keep this one local
+ (cond
+ ((and (args:get-arg "-section")
+ (args:get-arg "-var"))
+ (let ((val (or (configf:lookup data (args:get-arg "-section")(args:get-arg "-var"))
+ (configf:lookup data "default" (args:get-arg "-var")))))
+ (if val (print val))))
+ ((or (not (args:get-arg "-dumpmode"))
+ (string=? (args:get-arg "-dumpmode") "ini"))
+ (configf:config->ini data))
+ ((string=? (args:get-arg "-dumpmode") "sexp")
+ (pp (hash-table->alist data)))
+ ((string=? (args:get-arg "-dumpmode") "json")
+ (json-write data))
+ (else
+ (debug:print-error 0 *default-log-port* "-dumpmode of " (args:get-arg "-dumpmode") " not recognised")))
+ (set! *didsomething* #t))
+ (pop-directory)))
+
+ (if (args:get-arg "-show-config")
+ (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")
+ (args:get-arg "-var"))
+ (let ((val (configf:lookup data (args:get-arg "-section")(args:get-arg "-var"))))
+ (if val (print val))))
+
+ ;; print just a section if only -section
+
+ ((equal? (args:get-arg "-dumpmode") "sexp")
+ (pp (hash-table->alist data)))
+ ((equal? (args:get-arg "-dumpmode") "json")
+ (json-write data))
+ ((or (not (args:get-arg "-dumpmode"))
+ (string=? (args:get-arg "-dumpmode") "ini"))
+ (configf:config->ini data))
+ (else
+ (debug:print-error 0 *default-log-port* "-dumpmode of " (args:get-arg "-dumpmode") " not recognised")))
+ (set! *didsomething* #t)
+ (pop-directory)
+ (set! *time-to-exit* #t)))
+
+ (if (args:get-arg "-show-cmdinfo")
+ (if (or (args:get-arg ":value")(getenv "MT_CMDINFO"))
+ (let ((data (common:read-encoded-string (or (args:get-arg ":value")(getenv "MT_CMDINFO")))))
+ (if (equal? (args:get-arg "-dumpmode") "json")
+ (json-write data)
+ (pp data))
+ (set! *didsomething* #t))
+ (debug:print-info 0 *default-log-port* "environment variable MT_CMDINFO is not set")))
+
+ ;;======================================================================
+ ;; Remove old run(s)
+ ;;======================================================================
+
+ ;; since several actions can be specified on the command line the removal
+ ;; is done first
+ (define (operate-on action #!key (mode #f)(target-in #f)(runname-in #f)(keys-in #f)(keyvals-in #f)) ;; #f is "use default"
+ (let* ((runrec (runs:runrec-make-record))
+ (target (or target-in (common:args-get-target))) ;; eventually get rid of the call to common:args-get-target
+ (runname (or runname-in
+ (args:get-arg "-runname"))) ;; eventually get rid of the get-arg calls
+ (testpatt (or (args:get-arg "-testpatt")
+ (and (eq? action 'archive) ;; if it is an archive command fallback to MT_TEST_NAME and MT_ITEMPATH
+ (common:get-full-test-name))
+ (and (eq? action 'kill-runs)
+ "%/%") ;; I'm just guessing that this is correct :(
+ (common:args-get-testpatt #f) ;; (args:get-arg "-testpatt")))
+ ))) ;;
+ (cond
+ ((not target)
+ (debug:print-error 0 *default-log-port* "Missing required parameter for "
+ action ", you must specify -target or -reqtarg")
+ (exit 1))
+ ((not runname)
+ (debug:print-error 0 *default-log-port* "Missing required parameter for "
+ action ", you must specify the run name pattern with -runname patt")
+ (exit 2))
+ ((not testpatt)
+ (debug:print-error 0 *default-log-port* "Missing required parameter for "
+ action ", you must specify the test pattern with -testpatt")
+ (exit 3))
+ (else
+ (if (not (car *configinfo*))
+ (begin
+ (debug:print-error 0 *default-log-port* "Attempted " action "on test(s) but run area config file not found")
+ (exit 1))
+ ;; put test parameters into convenient variables
+ (begin
+ ;; check for correct version, exit with message if not correct
+ (common:exit-on-version-changed)
+ (runs:operate-on action
+ target
+ runname
+ testpatt
+ state: (common:args-get-state)
+ status: (common:args-get-status)
+ new-state-status: (args:get-arg "-set-state-status")
+ mode: mode)))
+ (set! *didsomething* #t)))))
+
+ (if (args:get-arg "-kill-runs")
+ (general-run-call
+ "-kill-runs"
+ "kill runs"
+ (lambda (target runname keys keyvals)
+ (operate-on 'kill-runs mode: #f)
+ )))
+
+ (if (args:get-arg "-kill-rerun")
+ (let* ((target-patt (common:args-get-target))
+ (runname-patt (args:get-arg "-runname")))
+ (cond ((not target-patt)
+ (debug:print-error 0 *default-log-port* "Missing target, must specify target for -kill-rerun with -target ")
+ (exit 1))
+ ((not runname-patt)
+ (debug:print-error 0 *default-log-port* "Missing runname, must specify runname for -kill-rerun with -runname ")
+ (exit 1))
+ ((string-search "[ ,%]" target-patt)
+ (debug:print-error 0 *default-log-port* "Invalid target ["target-patt"], must specify exact target (no wildcards) for -kill-rerun with -target ")
+ (exit 1))
+ ((string-search "[ ,%]" runname-patt)
+ (debug:print-error 0 *default-log-port* "Invalid runname ["runname-patt"], must specify exact runname (no wildcards) for -kill-rerun with -runname ")
+ (exit 1))
+ (else
+ (general-run-call
+ "-kill-runs"
+ "kill runs"
+ (lambda (target runname keys keyvals)
+ (operate-on 'kill-runs mode: #f)
+ ))
+
+ (thread-sleep! 15))
+ ;; fall thru and let "-run" loop fire
+ )))
+
+
+ (if (args:get-arg "-remove-runs")
+ (general-run-call
+ "-remove-runs"
+ "remove runs"
+ (lambda (target runname keys keyvals)
+ (operate-on 'remove-runs mode: (if (args:get-arg "-keep-records")
+ 'remove-data-only
+ 'remove-all)))))
+
+ (if (args:get-arg "-remove-keep")
+ (general-run-call
+ "-remove-keep"
+ "remove keep"
+ (lambda (target runname keys keyvals)
+ (let ((actions (map string->symbol
+ (string-split
+ (or (args:get-arg "-actions")
+ "print")
+ ",")))) ;; default to printing the output
+ (runs:remove-all-but-last-n-runs-per-target target runname
+ (string->number (args:get-arg "-remove-keep"))
+ actions: actions)))))
+
+ (if (args:get-arg "-set-state-status")
+ (general-run-call
+ "-set-state-status"
+ "set state and status"
+ (lambda (target runname keys keyvals)
+ (operate-on 'set-state-status))))
+
+ (if (or (args:get-arg "-set-run-status")
+ (args:get-arg "-get-run-status"))
+ (general-run-call
+ "-set-run-status"
+ "set run status"
+ (lambda (target runname keys keyvals)
+ (let* ((runsdat (rmt:get-runs-by-patt keys runname
+ (common:args-get-target)
+ #f #f #f #f))
+ (header (vector-ref runsdat 0))
+ (rows (vector-ref runsdat 1)))
+ (if (null? rows)
+ (begin
+ (debug:print-info 0 *default-log-port* "No matching run found.")
+ (exit 1))
+ (let* ((row (car (vector-ref runsdat 1)))
+ (run-id (db:get-value-by-header row header "id")))
+ (if (args:get-arg "-set-run-status")
+ (rmt:set-run-status run-id (args:get-arg "-set-run-status") msg: (args:get-arg "-m"))
+ (print (rmt:get-run-status run-id))
+ )))))))
+
+ ;;======================================================================
+ ;; Query runs
+ ;;======================================================================
+
+ ;; -fields runs:id,target,runname,comment+tests:id,testname,item_path+steps
+ ;;
+ ;; csi> (extract-fields-constraints "runs:id,target,runname,comment+tests:id,testname,item_path+steps")
+ ;; => (("runs" "id" "target" "runname" "comment") ("tests" "id" "testname" "item_path") ("steps"))
+ ;;
+ ;; NOTE: remember that the cdr will be the list you expect (cdr ("runs" "id" "target" "runname" "comment")) => ("id" "target" "runname" "comment")
+ ;; and so alist-ref will yield what you expect
+ ;;
+ (define (extract-fields-constraints fields-spec)
+ (map (lambda (table-spec) ;; runs:id,target,runname
+ (let ((dat (string-split table-spec ":"))) ;; ("runs" "id,target,runname")
+ (if (> (length dat) 1)
+ (cons (car dat)(string-split (cadr dat) ",")) ;; "id,target,runname"
+ dat)))
+ (string-split fields-spec "+")))
+
+ (define (get-value-by-fieldname datavec test-field-index fieldname)
+ (let ((indx (hash-table-ref/default test-field-index fieldname #f)))
+ (if indx
+ (if (>= indx (vector-length datavec))
+ #f ;; index too high, should raise an error I suppose
+ (vector-ref datavec indx))
+ #f)))
+
+
+
+
+
+ (when (args:get-arg "-testdata-csv")
+ (if (launch:setup)
+ (let* ((keys (rmt:get-keys)) ;; (db:get-keys dbstruct))
+ (runpatt (or (args:get-arg "-runname") "%"))
+ (testpatt (common:args-get-testpatt #f))
+ (datapatt (args:get-arg "-testdata-csv"))
+ (match-data (string-match "^([^/]+)/(.*)" (args:get-arg "-testdata-csv")))
+ (categorypatt (if match-data (list-ref match-data 1) "%"))
+ (setvarpatt (if match-data
+ (list-ref match-data 2)
+ (args:get-arg "-testdata-csv")))
+ (runsdat (rmt:get-runs-by-patt keys (or runpatt "%")
+ (common:args-get-target) #f #f '("id" "runname" "state" "status" "owner" "event_time" "comment") 0))
+ (header (db:get-header runsdat))
+ (access-mode (db:get-access-mode))
+ (testpatt (common:args-get-testpatt #f))
+ (fields-spec (if (args:get-arg "-fields")
+ (extract-fields-constraints (args:get-arg "-fields"))
+ (list (cons "runs" (append keys (list "id" "runname" "state" "status" "owner" "event_time" "comment" "fail_count" "pass_count")))
+ (cons "tests" db:test-record-fields) ;; "id" "testname" "test_path")
+ (list "steps" "id" "stepname"))))
+ (tests-spec (let ((t (alist-ref "tests" fields-spec equal?)))
+ (if (and t (null? t)) ;; all fields
+ db:test-record-fields
+ t)))
+ (adj-tests-spec (delete-duplicates (if tests-spec (cons "id" tests-spec) db:test-record-fields)))
+ (test-field-index (make-hash-table))
+ (runs (db:get-rows runsdat))
+ )
+ (if (and tests-spec (not (null? tests-spec))) ;; do some validation and processing of the test-spec
+ (let ((invalid-tests-spec (filter (lambda (x)(not (member x db:test-record-fields))) tests-spec)))
+ (if (null? invalid-tests-spec)
+ ;; generate the lookup map test-field-name => index-number
+ (let loop ((hed (car adj-tests-spec))
+ (tal (cdr adj-tests-spec))
+ (idx 0))
+ (hash-table-set! test-field-index hed idx)
+ (if (not (null? tal))(loop (car tal)(cdr tal)(+ idx 1))))
+ (begin
+ (debug:print-error 0 *default-log-port* "Invalid test fields specified: " (string-intersperse invalid-tests-spec ", "))
+ (exit)))))
+ (let* ((table-header (string-split "target,run,test,itempath,category,var,value,comment" ","))
+ (table-rows
+ (apply append (map
+ (lambda (run)
+ (let* ((target (string-intersperse (map (lambda (x)
+ (db:get-value-by-header run header x))
+ keys) "/"))
+ (statuses (string-split (or (args:get-arg "-status") "") ","))
+ (run-id (db:get-value-by-header run header "id"))
+ (runname (db:get-value-by-header run header "runname"))
+ (states (string-split (or (args:get-arg "-state") "") ","))
+ (tests (if tests-spec
+ (rmt:get-tests-for-run run-id testpatt states statuses #f #f #f 'testname 'asc ;; (db:get-tests-for-run dbstruct run-id testpatt '() '() #f #f #f 'testname 'asc
+ ;; use qryvals if test-spec provided
+ (if tests-spec
+ (string-intersperse adj-tests-spec ",")
+ ;; db:test-record-fields
+ #f)
+ #f
+ 'normal)
+ '())))
+ (apply append
+ (map
+ (lambda (test)
+ (let* (
+ (test-id (if (member "id" tests-spec)(get-value-by-fieldname test test-field-index "id" ) #f)) ;; (db:test-get-id test))
+ (testname (if (member "testname" tests-spec)(get-value-by-fieldname test test-field-index "testname" ) #f)) ;; (db:test-get-testname test))
+ (itempath (if (member "item_path" tests-spec)(get-value-by-fieldname test test-field-index "item_path" ) #f)) ;; (db:test-get-item-path test))
+ (fullname (conc testname
+ (if (equal? itempath "")
+ ""
+ (conc "/" itempath ))))
+ (testdat-raw (map vector->list (rmt:read-test-data-varpatt run-id test-id categorypatt setvarpatt)))
+ (testdat (filter
+ (lambda (x)
+ (not (equal? "logpro"
+ (list-ref x 10))))
+ testdat-raw)))
+ (map
+ (lambda (item)
+ (receive (id test_id category
+ variable value expected
+ tol units comment status type)
+ (apply values item)
+ (list target runname testname itempath category variable value comment)))
+ testdat)))
+ tests))))
+ runs))))
+ (print (string-join table-header ","))
+ (for-each (lambda(table-row)
+ (print (string-join (map ->string table-row) ",")))
+
+
+ table-rows))))
+ (set! *didsomething* #t)
+ (set! *time-to-exit* #t))
+
+
+
+ ;; NOTE: list-runs and list-db-targets operate on local db!!!
+ ;;
+ ;; IDEA: megatest list -runname blah% ...
+ ;;
+ (if (or (args:get-arg "-list-runs")
+ (args:get-arg "-list-db-targets"))
+ (if (launch:setup)
+ (let* ((runpatt (args:get-arg "-list-runs"))
+ (access-mode (db:get-access-mode))
+ (testpatt (common:args-get-testpatt #f))
+ ;; (if (args:get-arg "-testpatt")
+ ;; (args:get-arg "-testpatt")
+ ;; "%"))
+ (keys (rmt:get-keys)) ;; (db:get-keys dbstruct))
+ ;; (runsdat (db:get-runs dbstruct runpatt #f #f '()))
+ ;; (runsdat (rmt:get-runs-by-patt keys (or runpatt "%") (common:args-get-target) ;; (db:get-runs-by-patt dbstruct keys (or runpatt "%") (common:args-get-target)
+ ;; #f #f '("id" "runname" "state" "status" "owner" "event_time" "comment") 0))
+ (runsdat (rmt:get-runs-by-patt keys (or runpatt "%")
+ (common:args-get-target) #f #f '("id" "runname" "state" "status" "owner" "event_time" "comment") 0))
+ (runstmp (db:get-rows runsdat))
+ (header (db:get-header runsdat))
+ ;; this is "-since" support. This looks at last mod times of .db files
+ ;; and collects those modified since the -since time.
+ (runs runstmp)
+ ;; (if (and (not (null? runstmp))
+ ;; (args:get-arg "-since"))
+ ;; (let ((changed-ids (db:get-changed-run-ids (string->number (args:get-arg "-since")))))
+ ;; (let loop ((hed (car runstmp))
+ ;; (tal (cdr runstmp))
+ ;; (res '()))
+ ;; (let ((new-res (if (member (db:get-value-by-header hed header "id") changed-ids)
+ ;; (cons hed res)
+ ;; res)))
+ ;; (if (null? tal)
+ ;; (reverse new-res)
+ ;; (loop (car tal)(cdr tal) new-res)))))
+ ;; runstmp))
+ (db-targets (args:get-arg "-list-db-targets"))
+ (seen (make-hash-table))
+ (dmode (let ((d (args:get-arg "-dumpmode"))) ;; json, sexpr
+ (if d (string->symbol d) #f)))
+ (data (make-hash-table))
+ (fields-spec (if (args:get-arg "-fields")
+ (extract-fields-constraints (args:get-arg "-fields"))
+ (list (cons "runs" (append keys (list "id" "runname" "state" "status" "owner" "event_time" "comment" "fail_count" "pass_count")))
+ (cons "tests" db:test-record-fields) ;; "id" "testname" "test_path")
+ (list "steps" "id" "stepname"))))
+ (runs-spec (let ((r (alist-ref "runs" fields-spec equal?))) ;; the check is now unnecessary
+ (if (and r (not (null? r))) r (list "id" ))))
+ (tests-spec (let ((t (alist-ref "tests" fields-spec equal?)))
+ (if (and t (null? t)) ;; all fields
+ db:test-record-fields
+ t)))
+ (adj-tests-spec (delete-duplicates (if tests-spec (cons "id" tests-spec) db:test-record-fields))) ;; '("id"))))
+ (steps-spec (alist-ref "steps" fields-spec equal?))
+ (test-field-index (make-hash-table)))
+ (if (and (args:get-arg "-dumpmode")
+ (not (member (args:get-arg "-dumpmode") '("sexpr" "json" "ods" "list"))))
+ (begin
+ (debug:print 0 *default-log-port* "ERROR: dumpmode "(args:get-arg "-dumpmode")" not recognised. Use sexpr, json, ods or list")
+ (exit)))
+ (if (and tests-spec (not (null? tests-spec))) ;; do some validation and processing of the test-spec
+ (let ((invalid-tests-spec (filter (lambda (x)(not (member x db:test-record-fields))) tests-spec)))
+ (if (null? invalid-tests-spec)
+ ;; generate the lookup map test-field-name => index-number
+ (let loop ((hed (car adj-tests-spec))
+ (tal (cdr adj-tests-spec))
+ (idx 0))
+ (hash-table-set! test-field-index hed idx)
+ (if (not (null? tal))(loop (car tal)(cdr tal)(+ idx 1))))
+ (begin
+ (debug:print-error 0 *default-log-port* "Invalid test fields specified: " (string-intersperse invalid-tests-spec ", "))
+ (exit)))))
+ ;; Each run
+ (for-each
+ (lambda (run)
+ (let ((targetstr (string-intersperse (map (lambda (x)
+ (db:get-value-by-header run header x))
+ keys) "/")))
+ (if db-targets
+ (if (not (hash-table-ref/default seen targetstr #f))
+ (begin
+ (hash-table-set! seen targetstr #t)
+ ;; (print "[" targetstr "]"))))
+ (if (not dmode)
+ (print targetstr)
+ (hash-table-set! data "targets" (cons targetstr (hash-table-ref/default data "targets" '())))
+ )))
+ (let* ((run-id (db:get-value-by-header run header "id"))
+ (runname (db:get-value-by-header run header "runname"))
+ (states (string-split (or (args:get-arg "-state") "") ","))
+ (statuses (string-split (or (args:get-arg "-status") "") ","))
+ (tests (if tests-spec
+ (rmt:get-tests-for-run run-id testpatt states statuses #f #f #f 'testname 'asc ;; (db:get-tests-for-run dbstruct run-id testpatt '() '() #f #f #f 'testname 'asc
+ ;; use qryvals if test-spec provided
+ (if tests-spec
+ (string-intersperse adj-tests-spec ",")
+ ;; db:test-record-fields
+ #f)
+ #f
+ 'normal)
+ '())))
+ (case dmode
+ ((json ods sexpr)
+ (if runs-spec
+ (for-each
+ (lambda (field-name)
+ (mutils:hierhash-set! data (conc (db:get-value-by-header run header field-name)) targetstr runname "meta" field-name))
+ runs-spec)))
+ ;; (mutils:hierhash-set! data (db:get-value-by-header run header "status") targetstr runname "meta" "status" )
+ ;; (mutils:hierhash-set! data (db:get-value-by-header run header "state") targetstr runname "meta" "state" )
+ ;; (mutils:hierhash-set! data (conc (db:get-value-by-header run header "id")) targetstr runname "meta" "id" )
+ ;; (mutils:hierhash-set! data (db:get-value-by-header run header "event_time") targetstr runname "meta" "event_time" )
+ ;; (mutils:hierhash-set! data (db:get-value-by-header run header "comment") targetstr runname "meta" "comment" )
+ ;; ;; add last entry twice - seems to be a bug in hierhash?
+ ;; (mutils:hierhash-set! data (db:get-value-by-header run header "comment") targetstr runname "meta" "comment" )
+ ((#f list)
+ (if (null? runs-spec)
+ (print "Run: " targetstr "/" runname
+ " status: " (db:get-value-by-header run header "state")
+ " run-id: " run-id ", number tests: " (length tests)
+ " event_time: " (db:get-value-by-header run header "event_time"))
+ (begin
+ (if (not (member "target" runs-spec))
+ ;; (display (conc "Target: " targetstr))
+ (display (conc "Run: " targetstr "/" runname " ")))
+ (for-each
+ (lambda (field-name)
+ (if (equal? field-name "target")
+ (display (conc "target: " targetstr " "))
+ (display (conc field-name ": " (db:get-value-by-header run header (conc field-name)) " "))))
+ runs-spec)
+ (newline))))
+ (else
+ (debug:print 0 *default-log-port* "ERROR: dumpmode "(args:get-arg "-dumpmode")" not recognised. Use sexpr, json, ods or list")
+ ))
+
+ (for-each
+ (lambda (test)
+ (common:debug-handle-exceptions #f
+ exn
+ (begin
+ (debug:print-error 0 *default-log-port* "Bad data in test record? " test)
+ (debug:print-error 5 *default-log-port* "exn=" (condition->list exn))
+ (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
+ (print-call-chain (current-error-port)))
+ (let* ((test-id (if (member "id" tests-spec)(get-value-by-fieldname test test-field-index "id" ) #f)) ;; (db:test-get-id test))
+ (testname (if (member "testname" tests-spec)(get-value-by-fieldname test test-field-index "testname" ) #f)) ;; (db:test-get-testname test))
+ (itempath (if (member "item_path" tests-spec)(get-value-by-fieldname test test-field-index "item_path" ) #f)) ;; (db:test-get-item-path test))
+ (comment (if (member "comment" tests-spec)(get-value-by-fieldname test test-field-index "comment" ) #f)) ;; (db:test-get-comment test))
+ (tstate (if (member "state" tests-spec)(get-value-by-fieldname test test-field-index "state" ) #f)) ;; (db:test-get-state test))
+ (tstatus (if (member "status" tests-spec)(get-value-by-fieldname test test-field-index "status" ) #f)) ;; (db:test-get-status test))
+ (event-time (if (member "event_time" tests-spec)(get-value-by-fieldname test test-field-index "event_time" ) #f)) ;; (db:test-get-event_time test))
+ (rundir (if (member "rundir" tests-spec)(get-value-by-fieldname test test-field-index "rundir" ) #f)) ;; (db:test-get-rundir test))
+ (final_logf (if (member "final_logf" tests-spec)(get-value-by-fieldname test test-field-index "final_logf" ) #f)) ;; (db:test-get-final_logf test))
+ (run_duration (if (member "run_duration" tests-spec)(get-value-by-fieldname test test-field-index "run_duration") #f)) ;; (db:test-get-run_duration test))
+ (fullname (conc testname
+ (if (equal? itempath "")
+ ""
+ (conc "(" itempath ")")))))
+ (case dmode
+ ((json ods sexpr)
+ (if tests-spec
+ (for-each
+ (lambda (field-name)
+ (mutils:hierhash-set! data (get-value-by-fieldname test test-field-index field-name) targetstr runname "data" (conc test-id) field-name))
+ tests-spec)))
+ ;; ;; (mutils:hierhash-set! data fullname targetstr runname "data" (conc test-id) "tname" )
+ ;; (mutils:hierhash-set! data testname targetstr runname "data" (conc test-id) "testname" )
+ ;; (mutils:hierhash-set! data itempath targetstr runname "data" (conc test-id) "itempath" )
+ ;; (mutils:hierhash-set! data comment targetstr runname "data" (conc test-id) "comment" )
+ ;; (mutils:hierhash-set! data tstate targetstr runname "data" (conc test-id) "state" )
+ ;; (mutils:hierhash-set! data tstatus targetstr runname "data" (conc test-id) "status" )
+ ;; (mutils:hierhash-set! data rundir targetstr runname "data" (conc test-id) "rundir" )
+ ;; (mutils:hierhash-set! data final_logf targetstr runname "data" (conc test-id) "final_logf")
+ ;; (mutils:hierhash-set! data run_duration targetstr runname "data" (conc test-id) "run_duration")
+ ;; (mutils:hierhash-set! data event-time targetstr runname "data" (conc test-id) "event_time")
+ ;; ;; add last entry twice - seems to be a bug in hierhash?
+ ;; (mutils:hierhash-set! data event-time targetstr runname "data" (conc test-id) "event_time")
+ ;; )
+ (else
+ (if (and tstate tstatus event-time)
+ (format #t
+ " Test: ~25a State: ~15a Status: ~15a Runtime: ~5@as Time: ~22a Host: ~10a\n"
+ (if fullname fullname "")
+ (if tstate tstate "")
+ (if tstatus tstatus "")
+ (get-value-by-fieldname test test-field-index "run_duration");;(if test (db:test-get-run_duration test) "")
+ (if event-time event-time "")
+ (get-value-by-fieldname test test-field-index "host")) ;;(if test (db:test-get-host test)) "")
+ (print " Test: " fullname
+ (if tstate (conc " State: " tstate) "")
+ (if tstatus (conc " Status: " tstatus) "")
+ (if (get-value-by-fieldname test test-field-index "run_duration")
+ (conc " Runtime: " (get-value-by-fieldname test test-field-index "run_duration"))
+ "")
+ (if event-time (conc " Time: " event-time) "")
+ (if (get-value-by-fieldname test test-field-index "host")
+ (conc " Host: " (get-value-by-fieldname test test-field-index "host"))
+ "")))
+ (if (not (or (equal? (get-value-by-fieldname test test-field-index "status") "PASS")
+ (equal? (get-value-by-fieldname test test-field-index "status") "WARN")
+ (equal? (get-value-by-fieldname test test-field-index "state") "NOT_STARTED")))
+ (begin
+ (print (if (get-value-by-fieldname test test-field-index "cpuload")
+ (conc " cpuload: " (get-value-by-fieldname test test-field-index "cpuload"))
+ "") ;; (db:test-get-cpuload test)
+ (if (get-value-by-fieldname test test-field-index "diskfree")
+ (conc "\n diskfree: " (get-value-by-fieldname test test-field-index "diskfree")) ;; (db:test-get-diskfree test)
+ "")
+ (if (get-value-by-fieldname test test-field-index "uname")
+ (conc "\n uname: " (get-value-by-fieldname test test-field-index "uname")) ;; (db:test-get-uname test)
+ "")
+ (if (get-value-by-fieldname test test-field-index "rundir")
+ (conc "\n rundir: " (get-value-by-fieldname test test-field-index "rundir")) ;; (db:test-get-rundir test)
+ "")
+ ;; "\n rundir: " (get-value-by-fieldname test test-field-index "") ;; (sdb:qry 'getstr ;; (filedb:get-path *fdb*
+ ;; (db:test-get-rundir test) ;; )
+ )
+ ;; Each test
+ ;; DO NOT remote run
+ (let ((steps (rmt:get-steps-for-test run-id (db:test-get-id test)))) ;; (db:get-steps-for-test dbstruct run-id (db:test-get-id test))))
+ (for-each
+ (lambda (step)
+ (format #t
+ " Step: ~20a State: ~10a Status: ~10a Time ~22a\n"
+ (tdb:step-get-stepname step)
+ (tdb:step-get-state step)
+ (tdb:step-get-status step)
+ (tdb:step-get-event_time step)))
+ steps)))))))))
+ (if (args:get-arg "-sort")
+ (sort tests
+ (lambda (a-test b-test)
+ (let* ((key (args:get-arg "-sort"))
+ (first (get-value-by-fieldname a-test test-field-index key))
+ (second (get-value-by-fieldname b-test test-field-index key)))
+ ((cond
+ ((and (number? first)(number? second)) <)
+ ((and (string? first)(string? second)) string<=?)
+ (else equal?))
+ first second))))
+ tests))))))
+ runs)
+ (case dmode
+ ((json) (json-write data))
+ ((sexpr) (pp (common:to-alist data))))
+ (let* ((metadat-fields (delete-duplicates
+ (append keys '( "runname" "time" "owner" "pass_count" "fail_count" "state" "status" "comment" "id"))))
+ (run-fields '(
+ "testname"
+ "item_path"
+ "state"
+ "status"
+ "comment"
+ "event_time"
+ "host"
+ "run_id"
+ "run_duration"
+ "attemptnum"
+ "id"
+ "archived"
+ "diskfree"
+ "cpuload"
+ "final_logf"
+ "shortdir"
+ "rundir"
+ "uname"
+ )
+ )
+ (newdat (common:to-alist data))
+ (allrundat (if (null? newdat)
+ '()
+ (car (map cdr newdat)))) ;; (car (map cdr (car (map cdr newdat)))))
+ (runs (append
+ (list "runs" ;; sheetname
+ metadat-fields)
+ (map (lambda (run)
+ ;; (print "run: " run)
+ (let* ((runname (car run))
+ (rundat (cdr run))
+ (metadat (let ((tmp (assoc "meta" rundat)))
+ (if tmp (cdr tmp) #f))))
+ ;; (print "runname: " runname "\n\nrundat: " )(pp rundat)(print "\n\nmetadat: ")(pp metadat)
+ (if metadat
+ (map (lambda (field)
+ (let ((tmp (assoc field metadat)))
+ (if tmp (cdr tmp) "")))
+ metadat-fields)
+ (begin
+ (debug:print 0 *default-log-port* "WARNING: meta data for run " runname " not found")
+ '()))))
+ allrundat)))
+ ;; '( ( "target" ( "runname" ( "data" ( "runid" ( "id . "37" ) ( ... ))))
+ (run-pages (map (lambda (targdat)
+ (let* ((target (car targdat))
+ (runsdat (cdr targdat)))
+ (if runsdat
+ (map (lambda (rundat)
+ (let* ((runname (car rundat))
+ (rundat (cdr rundat))
+ (testsdat (let ((tmp (assoc "data" rundat)))
+ (if tmp (cdr tmp) #f))))
+ (if testsdat
+ (let ((tests (map (lambda (test)
+ (let* ((test-id (car test))
+ (test-dat (cdr test)))
+ (map (lambda (field)
+ (let ((tmp (assoc field test-dat)))
+ (if tmp (cdr tmp) "")))
+ run-fields)))
+ testsdat)))
+ ;; (print "Target: " target "/" runname " tests:")
+ ;; (pp tests)
+ (cons (conc target "/" runname)
+ (cons (list (conc target "/" runname))
+ (cons '()
+ (cons run-fields tests)))))
+ (begin
+ (debug:print 4 *default-log-port* "WARNING: run " target "/" runname " appears to have no data")
+ ;; (pp rundat)
+ '()))))
+ runsdat)
+ '())))
+ newdat)) ;; we use newdat to get target
+ (sheets (filter (lambda (x)
+ (not (null? x)))
+ (cons runs (map car run-pages)))))
+ ;; (print "allrundat:")
+ ;; (pp allrundat)
+ ;; (print "runs:")
+ ;; (pp runs)
+ ;(print "sheets: ")
+ ;; (pp sheets)
+ (if (eq? dmode 'ods)
+ (let* ((tempdir (conc "/tmp/" (current-user-name) "/" (random 10000) "_" (current-process-id)))
+ (outputfile (or (args:get-arg "-o") "out.ods"))
+ (ouf (if (string-match (regexp "^[/~]+.*") outputfile) ;; full path?
+ outputfile
+ (begin
+ (debug:print 0 *default-log-port* "WARNING: path given, " outputfile " is relative, prefixing with current directory")
+ (conc (current-directory) "/" outputfile)))))
+ (create-directory tempdir #t)
+ (ods:list->ods tempdir ouf sheets))))
+ ;; (system (conc "rm -rf " tempdir))
+ (set! *didsomething* #t)
+ (set! *time-to-exit* #t)
+ ) ;; end if true branch (end of a let)
+ ) ;; end if
+ ) ;; end if -list-runs
+
+ ;; list-waivers
+ (if (and (args:get-arg "-list-waivers")
+ (launch:setup))
+ (let* ((runpatt (or (args:get-arg "-runname") "%"))
+ (testpatt (common:args-get-testpatt #f))
+ (keys (rmt:get-keys))
+ (runsdat (rmt:get-runs-by-patt
+ keys runpatt
+ (common:args-get-target) #f #f
+ '("id" "runname" "state" "status" "owner" "event_time" "comment") 0))
+ (runs (db:get-rows runsdat))
+ (header (db:get-header runsdat))
+ (results (make-hash-table)) ;; [target] ( (testname/itempath . "comment") ... )
+ (addtest (lambda (target testname itempath comment)
+ (hash-table-set! results target (cons (cons (conc testname "/" itempath) comment)
+ (hash-table-ref/default results target '())))))
+ (last-target #f))
+ (for-each
+ (lambda (run)
+ (let* ((run-id (db:get-value-by-header run header "id"))
+ (target (rmt:get-target run-id))
+ (runname (db:get-value-by-header run header "runname"))
+ (tests (rmt:get-tests-for-run
+ run-id testpatt '("COMPLETED") '("WAIVED") #f #f #f 'testname 'asc ;; use qryvals if test-spec provided
+ #f #f #f)))
+ (if (not (equal? target last-target))
+ (print "[" target "]"))
+ (set! last-target target)
+ (print "# " runname)
+ (for-each
+ (lambda (testdat)
+ (let* ((testfullname (conc (db:test-get-testname testdat)
+ (if (equal? "" (db:test-get-item-path testdat))
+ ""
+ (conc "/" (db:test-get-item-path testdat)))
+ )))
+ (print testfullname " " (db:test-get-comment testdat))))
+ tests)))
+ runs)
+ (set! *didsomething* #t)))
+
+ ;;======================================================================
+ ;; full run
+ ;;======================================================================
+
+ (define (handle-run-requests target runname keys keyvals need-clean)
+ (if (or (args:get-arg "-kill-rerun") (args:get-arg "-rerun-clean")) ;; first set states/statuses correct
+ ;; For rerun-clean do we or do we not support the testpatt?
+ (let ((states (or (configf:lookup *configdat* "validvalues" "cleanrerun-states")
+ "KILLREQ,KILLED,UNKNOWN,INCOMPLETE,STUCK,NOT_STARTED"))
+ (statuses (or (configf:lookup *configdat* "validvalues" "cleanrerun-statuses")
+ "FAIL,INCOMPLETE,ABORT,CHECK,DEAD,PREQ_FAIL,PREQ_DISCARDED")))
+ (hash-table-set! args:arg-hash "-preclean" #t)
+ (runs:operate-on 'set-state-status
+ target
+ (common:args-get-runname) ;; (or (args:get-arg "-runname")(args:get-arg ":runname"))
+ ;; "%" ;; (common:args-get-testpatt #f) ;; (args:get-arg "-testpatt")
+ (common:args-get-testpatt #f) ;; (args:get-arg "-testpatt")
+ state: states
+ ;; status: statuses
+ new-state-status: "NOT_STARTED,n/a")
+ (runs:clean-cache target runname *toppath*)
+ (runs:operate-on 'set-state-status
+ target
+ (common:args-get-runname) ;; (or (args:get-arg "-runname")(args:get-arg ":runname"))
+ ;; "%" ;; (common:args-get-testpatt #f) ;; (args:get-arg "-testpatt")
+ (common:args-get-testpatt #f) ;; (args:get-arg "-testpatt")
+ ;; state: states
+ status: statuses
+ new-state-status: "NOT_STARTED,n/a")))
+ ;; RERUN ALL
+ (if (args:get-arg "-rerun-all") ;; first set states/statuses correct
+ (let* ((rconfig (full-runconfigs-read)))
+ (hash-table-set! args:arg-hash "-preclean" #t)
+ (runs:operate-on 'set-state-status
+ target
+ (common:args-get-runname) ;; (or (args:get-arg "-runname")(args:get-arg ":runname"))
+ (common:args-get-testpatt rconfig) ;; (args:get-arg "-testpatt")
+ state: #f
+ ;; status: statuses
+ new-state-status: "NOT_STARTED,n/a")
+ (runs:clean-cache target runname *toppath*)
+ (runs:operate-on 'set-state-status
+ target
+ (common:args-get-runname) ;; (or (args:get-arg "-runname")(args:get-arg ":runname"))
+ (common:args-get-testpatt rconfig) ;; (args:get-arg "-testpatt")
+ ;; state: states
+ status: #f
+ new-state-status: "NOT_STARTED,n/a")))
+ (let* ((config-reruns (let ((x (configf:lookup *configdat* "setup" "reruns")))
+ (if x (string->number x) #f)))
+ (rerun-cnt (if config-reruns
+ config-reruns
+ 1)))
+
+ (runs:run-tests target
+ runname
+ #f ;; (common:args-get-testpatt #f)
+ ;; (or (args:get-arg "-testpatt")
+ ;; "%")
+ user
+ args:arg-hash
+ run-count: rerun-cnt)))
+
+ ;; get lock in db for full run for this directory
+ ;; for all tests with deps
+ ;; walk tree of tests to find head tasks
+ ;; add head tasks to task queue
+ ;; add dependant tasks to task queue
+ ;; add remaining tasks to task queue
+ ;; for each task in task queue
+ ;; if have adequate resources
+ ;; launch task
+ ;; else
+ ;; put task in deferred queue
+ ;; if still ok to run tasks
+ ;; process deferred tasks per above steps
+
+ ;; run all tests are are Not COMPLETED and PASS or CHECK
+ (if (or (args:get-arg "-runall")
+ (args:get-arg "-run")
+ (args:get-arg "-rerun-clean")
+ (args:get-arg "-rerun-all")
+ (args:get-arg "-runtests")
+ (args:get-arg "-kill-rerun"))
+ (let ((need-clean (or (args:get-arg "-rerun-clean")
+ (args:get-arg "-rerun-all")))
+ (orig-cmdline (string-intersperse (argv) " ")))
+ (general-run-call
+ "-runall"
+ "run all tests"
+ (lambda (target runname keys keyvals)
+ (if (or (string-search "%" target)
+ (string-search "%" runname)) ;; we are being asked to re-run multiple runs
+ (let* ((run-specs (rmt:simple-get-runs runname #f #f target #f))) ;; list of simple-run records
+ (debug:print-info 0 *default-log-port* "Pattern supplied for target or runname with "
+ (length run-specs) " matches found. Running each in turn.")
+ (if (null? run-specs)
+ (debug:print 0 *default-log-port* "WARNING: No runs match target " target " and runname " runname))
+ (for-each (lambda (spec)
+ (let* ((precmd (if (args:get-arg "-precmd")(conc (args:get-arg "-precmd") " ") ""))
+ (newcmdline (conc
+ precmd
+ (string-substitute
+ (conc "target " target)
+ (conc "target " (simple-run-target spec))
+ (string-substitute
+ (conc "runname " runname)
+ (conc "runname " (simple-run-runname spec))
+ orig-cmdline)))))
+ (debug:print 0 *default-log-port* "ORIG: " orig-cmdline)
+ (debug:print 0 *default-log-port* "NEW: " newcmdline)
+ (system newcmdline)))
+ run-specs))
+ (handle-run-requests target runname keys keyvals need-clean))))
+ (set! *didsomething* #t)))
+
+ ;;======================================================================
+ ;; run one test
+ ;;======================================================================
+
+ ;; 1. find the config file
+ ;; 2. change to the test directory
+ ;; 3. update the db with "test started" status, set running host
+ ;; 4. process launch the test
+ ;; - monitor the process, update stats in the db every 2^n minutes
+ ;; 5. as the test proceeds internally it calls megatest as each step is
+ ;; started and completed
+ ;; - step started, timestamp
+ ;; - step completed, exit status, timestamp
+ ;; 6. test phone home
+ ;; - if test run time > allowed run time then kill job
+ ;; - if cannot access db > allowed disconnect time then kill job
+
+ ;; == duplicated == (if (or (args:get-arg "-run")(args:get-arg "-runtests"))
+ ;; == duplicated == (general-run-call
+ ;; == duplicated == "-runtests"
+ ;; == duplicated == "run a test"
+ ;; == duplicated == (lambda (target runname keys keyvals)
+ ;; == duplicated == ;;
+ ;; == duplicated == ;; May or may not implement it this way ...
+ ;; == duplicated == ;;
+ ;; == duplicated == ;; Insert this run into the tasks queue
+ ;; == duplicated == ;; (open-run-close tasks:add tasks:open-db
+ ;; == duplicated == ;; "runtests"
+ ;; == duplicated == ;; user
+ ;; == duplicated == ;; target
+ ;; == duplicated == ;; runname
+ ;; == duplicated == ;; (args:get-arg "-runtests")
+ ;; == duplicated == ;; #f))))
+ ;; == duplicated == (runs:run-tests target
+ ;; == duplicated == runname
+ ;; == duplicated == (common:args-get-testpatt #f) ;; (args:get-arg "-runtests")
+ ;; == duplicated == user
+ ;; == duplicated == args:arg-hash))))
+
+ ;;======================================================================
+ ;; Rollup into a run
+ ;;======================================================================
+
+ (if (args:get-arg "-rollup")
+ (general-run-call
+ "-rollup"
+ "rollup tests"
+ (lambda (target runname keys keyvals)
+ (runs:rollup-run keys
+ keyvals
+ (or (args:get-arg "-runname")(args:get-arg ":runname") )
+ user))))
+
+ ;;======================================================================
+ ;; Lock or unlock a run
+ ;;======================================================================
+
+ (if (or (args:get-arg "-lock")(args:get-arg "-unlock"))
+ (general-run-call
+ (if (args:get-arg "-lock") "-lock" "-unlock")
+ "lock/unlock tests"
+ (lambda (target runname keys keyvals)
+ (runs:handle-locking
+ target
+ keys
+ (or (args:get-arg "-runname")(args:get-arg ":runname") )
+ (args:get-arg "-lock")
+ (args:get-arg "-unlock")
+ user))))
+
+ ;;======================================================================
+ ;; Get paths to tests
+ ;;======================================================================
+ ;; Get test paths matching target, runname, and testpatt
+ (if (or (args:get-arg "-test-files")(args:get-arg "-test-paths"))
+ ;; if we are in a test use the MT_CMDINFO data
+ (if (getenv "MT_CMDINFO")
+ (let* ((startingdir (current-directory))
+ (cmdinfo (common:read-encoded-string (getenv "MT_CMDINFO")))
+ (transport (assoc/default 'transport cmdinfo))
+ (testpath (assoc/default 'testpath cmdinfo))
+ (test-name (assoc/default 'test-name cmdinfo))
+ (runscript (assoc/default 'runscript cmdinfo))
+ (db-host (assoc/default 'db-host cmdinfo))
+ (run-id (assoc/default 'run-id cmdinfo))
+ (itemdat (assoc/default 'itemdat cmdinfo))
+ (state (args:get-arg ":state"))
+ (status (args:get-arg ":status"))
+ ;;(target (args:get-arg "-target"))
+ (target (common:args-get-target))
+ (toppath (assoc/default 'toppath cmdinfo)))
+ (change-directory toppath)
+ (if (not target)
+ (begin
+ (debug:print-error 0 *default-log-port* "-target is required.")
+ (exit 1)))
+ (if (not (launch:setup))
+ (begin
+ (debug:print 0 *default-log-port* "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
+ (paths (tests:test-get-paths-matching keys target (args:get-arg "-test-files"))))
+ (set! *didsomething* #t)
+ (for-each (lambda (path)
+ (if (common:file-exists? path)
+ (print path)))
+ paths)))
+ ;; else do a general-run-call
+ (general-run-call
+ "-test-files"
+ "Get paths to test"
+ (lambda (target runname keys keyvals)
+ (let* ((db #f)
+ ;; DO NOT run remote
+ (paths (tests:test-get-paths-matching keys target (args:get-arg "-test-files"))))
+ (for-each (lambda (path)
+ (print path))
+ paths))))))
+
+ ;;======================================================================
+ ;; Utils for test areas
+ ;;======================================================================
+
+ (if (args:get-arg "-regen-testfiles")
+ (if (getenv "MT_TEST_RUN_DIR")
+ (begin
+ (launch:setup)
+ (change-directory (getenv "MT_TEST_RUN_DIR"))
+ (let* ((testname (getenv "MT_TEST_NAME"))
+ (itempath (getenv "MT_ITEMPATH")))
+ (launch:extract-scripts-logpro (getenv "MT_TEST_RUN_DIR") testname itempath #f))
+ (set! *didsomething* #t))
+ (debug:print 0 *default-log-port* "ERROR: Must run -regen-testfiles in a test environment (i.e. test xterm from dashboard)")))
+
+ ;;======================================================================
+ ;; Archive tests
+ ;;======================================================================
+ ;; Archive tests matching target, runname, and testpatt
+ (if (equal? (args:get-arg "-archive") "replicate-db")
+ (begin
+ ;; check if source
+ ;; check if megatest.db exist
+ (launch:setup)
+ (if (not (args:get-arg "-source"))
+ (begin
+ (debug:print-info 1 *default-log-port* "Missing required argument -source ")
+ (exit 1)))
+ (if (common:file-exists? (conc *toppath* "/megatest.db"))
+ (begin
+ (debug:print-info 1 *default-log-port* "File " (conc *toppath* "/megatest.db") " already exists. Please remove it before trying to replicate db")
+ (exit 1)))
+ (if (and (common:make-tmpdir-name *toppath* "") (> (length (directory (common:make-tmpdir-name *toppath* "") #f)) 0))
+ (begin
+ (debug:print-info 1 *default-log-port* (common:make-tmpdir-name *toppath* "") " not empty. Please remove it before trying to replicate db")
+ (exit 1)))
+ ;; check if timestamp
+ (let* ((source (args:get-arg "-source"))
+ (src (if (not (equal? (substring source 0 1) "/"))
+ (conc (current-directory) "/" source)
+ source))
+ (ts (if (args:get-arg "-time-stamp") (args:get-arg "-time-stamp") "latest")))
+ (if (common:directory-exists? src)
+ (begin
+ (archive:restore-db src ts)
+ (set! *didsomething* #t))
+ (begin
+ (debug:print-error 1 *default-log-port* "Path " source " not found")
+ (exit 1))))))
+ ;; else do a general-run-call
+ (if (and (args:get-arg "-archive") (not (equal? (args:get-arg "-archive") "replicate-db")))
+ (begin
+ ;; for the archive get we need to preserve the starting dir as part of the target path
+ (if (and (args:get-arg "-dest")
+ (not (equal? (substring (args:get-arg "-dest") 0 1) "/")))
+ (let ((newpath (conc (current-directory) "/" (args:get-arg "-dest"))))
+ (debug:print-info 1 *default-log-port* "Preserving original path to destination, was " (args:get-arg "-dest") ", now " newpath)
+ (hash-table-set! args:arg-hash "-dest" newpath)))
+ (general-run-call
+ "-archive"
+ "Archive"
+ (lambda (target runname keys keyvals)
+ (operate-on 'archive target-in: target runname-in: runname )))))
+
+ ;;======================================================================
+ ;; Extract a spreadsheet from the runs database
+ ;;======================================================================
+
+ (if (args:get-arg "-extract-ods")
+ (general-run-call
+ "-extract-ods"
+ "Make ods spreadsheet"
+ (lambda (target runname keys keyvals)
+ (let ((dbstruct (make-dbr:dbstruct areapath: *toppath* local: #t))
+ (outputfile (args:get-arg "-extract-ods"))
+ (runspatt (or (args:get-arg "-runname")(args:get-arg ":runname")))
+ (pathmod (args:get-arg "-pathmod")))
+ ;; (keyvalalist (keys->alist keys "%")))
+ (debug:print 2 *default-log-port* "Extract ods, outputfile: " outputfile " runspatt: " runspatt " keyvals: " keyvals)
+ (db:extract-ods-file dbstruct outputfile keyvals (if runspatt runspatt "%") pathmod)
+ (db:close-all dbstruct)
+ (set! *didsomething* #t)))))
+
+ ;;======================================================================
+ ;; execute the test
+ ;; - gets called on remote host
+ ;; - receives info from the -execute param
+ ;; - passes info to steps via MT_CMDINFO env var (future is to use a dot file)
+ ;; - gathers host info and
+ ;;======================================================================
+
+ (if (args:get-arg "-execute")
+ (begin
+ (launch:execute (args:get-arg "-execute"))
+ (set! *didsomething* #t)))
+
+ ;;======================================================================
+ ;; recover from a test where the managing mtest was killed but the underlying
+ ;; process might still be salvageable
+ ;;======================================================================
+
+ (if (args:get-arg "-recover-test")
+ (let* ((params (string-split (args:get-arg "-recover-test") ",")))
+ (if (> (length params) 1) ;; run-id and test-id
+ (let ((run-id (string->number (car params)))
+ (test-id (string->number (cadr params))))
+ (if (and run-id test-id)
+ (begin
+ (launch:recover-test run-id test-id)
+ (set! *didsomething* #t))
+ (begin
+ (debug:print-error 0 *default-log-port* "bad run-id or test-id, must be integers")
+ (exit 1)))))))
+
+ ;;======================================================================
+ ;; Test commands (i.e. for use inside tests)
+ ;;======================================================================
+
+ (define (megatest:step step state status logfile msg)
+ (if (not (getenv "MT_CMDINFO"))
+ (begin
+ (debug:print-error 0 *default-log-port* "MT_CMDINFO env var not set, -step must be called *inside* a megatest invoked environment!")
+ (exit 5))
+ (let* ((cmdinfo (common:read-encoded-string (getenv "MT_CMDINFO")))
+ (transport (assoc/default 'transport cmdinfo))
+ (testpath (assoc/default 'testpath cmdinfo))
+ (test-name (assoc/default 'test-name cmdinfo))
+ (runscript (assoc/default 'runscript cmdinfo))
+ (db-host (assoc/default 'db-host cmdinfo))
+ (run-id (assoc/default 'run-id cmdinfo))
+ (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))
+ (begin
+ (debug:print 0 *default-log-port* "Failed to setup, exiting")
+ (exit 1)))
+ (if (and state status)
+ (let ((comment (launch:load-logpro-dat run-id test-id step)))
+ ;; (rmt:test-set-log! run-id test-id (conc stepname ".html"))))
+ (rmt:teststep-set-status! run-id test-id step state status (or comment msg) logfile))
+ (begin
+ (debug:print-error 0 *default-log-port* "You must specify :state and :status with every call to -step")
+ (exit 6))))))
+
+ (if (args:get-arg "-step")
+ (begin
+ (thread-sleep! 1.5)
+ (megatest:step
+ (args:get-arg "-step")
+ (or (args:get-arg "-state")(args:get-arg ":state"))
+ (or (args:get-arg "-status")(args:get-arg ":status"))
+ (args:get-arg "-setlog")
+ (args:get-arg "-m"))
+ ;; (if db (sqlite3:finalize! db))
+ (set! *didsomething* #t)
+ (thread-sleep! 1.5)))
+
+ (if (or (args:get-arg "-setlog") ;; since setting up is so costly lets piggyback on -test-status
+ ;; (not (args:get-arg "-step"))) ;; -setlog may have been processed already in the "-step" previous
+ ;; NEW POLICY - -setlog sets test overall log on every call.
+ (args:get-arg "-set-toplog")
+ (args:get-arg "-test-status")
+ (args:get-arg "-set-values")
+ (args:get-arg "-load-test-data")
+ (args:get-arg "-runstep")
+ (args:get-arg "-summarize-items"))
+ (if (not (getenv "MT_CMDINFO"))
+ (begin
+ (debug:print-error 0 *default-log-port* "MT_CMDINFO env var not set, commands -test-status, -runstep and -setlog must be called *inside* a megatest environment!")
+ (exit 5))
+ (let* ((startingdir (current-directory))
+ (cmdinfo (common:read-encoded-string (getenv "MT_CMDINFO")))
+ (transport (assoc/default 'transport cmdinfo))
+ (testpath (assoc/default 'testpath cmdinfo))
+ (test-name (assoc/default 'test-name cmdinfo))
+ (runscript (assoc/default 'runscript cmdinfo))
+ (db-host (assoc/default 'db-host cmdinfo))
+ (run-id (assoc/default 'run-id cmdinfo))
+ (test-id (assoc/default 'test-id cmdinfo))
+ (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"))
+ (stepname (args:get-arg "-step")))
+ (if (not (launch:setup))
+ (begin
+ (debug:print 0 *default-log-port* "Failed to setup, exiting")
+ (exit 1)))
+
+ (if (args:get-arg "-runstep")(debug:print-info 1 *default-log-port* "Running -runstep, first change to directory " work-area))
+ (change-directory work-area)
+ ;; can setup as client for server mode now
+
+ (if (args:get-arg "-load-test-data")
+ ;; has sub commands that are rdb:
+ ;; DO NOT put this one into either rmt: or open-run-close
+ (tdb:load-test-data run-id test-id))
+ (if (args:get-arg "-setlog")
+ (let ((logfname (args:get-arg "-setlog")))
+ (rmt:test-set-log! run-id test-id logfname)))
+ (if (args:get-arg "-set-toplog")
+ ;; DO NOT run remote
+ (tests:test-set-toplog! run-id test-name (args:get-arg "-set-toplog")))
+ (if (args:get-arg "-summarize-items")
+ ;; DO NOT run remote
+ (tests:summarize-items run-id test-id test-name #t)) ;; do force here
+ (if (args:get-arg "-runstep")
+ (if (null? remargs)
+ (begin
+ (debug:print-error 0 *default-log-port* "nothing specified to run!")
+ (if db (sqlite3:finalize! db))
+ (exit 6))
+ (let* ((stepname (args:get-arg "-runstep"))
+ (logprofile (args:get-arg "-logpro"))
+ (logfile (conc stepname ".log"))
+ (cmd (if (null? remargs) #f (car remargs)))
+ (params (if cmd (cdr remargs) '()))
+ (exitstat #f)
+ (shell (let ((sh (get-environment-variable "SHELL") ))
+ (if sh
+ (last (string-split sh "/"))
+ "bash")))
+ (redir (case (string->symbol shell)
+ ((tcsh csh ksh) ">&")
+ ((zsh bash sh ash) "2>&1 >")
+ (else ">&")))
+ (fullcmd (conc "(" (string-intersperse
+ (cons cmd params) " ")
+ ") " redir " " logfile)))
+ ;; mark the start of the test
+ (rmt:teststep-set-status! run-id test-id stepname "start" "n/a" (args:get-arg "-m") logfile)
+ ;; run the test step
+ (debug:print-info 2 *default-log-port* "Running \"" fullcmd "\" in directory \"" startingdir)
+ (change-directory startingdir)
+ (set! exitstat (system fullcmd))
+ (set! *globalexitstatus* exitstat)
+ ;; (change-directory testpath)
+ ;; run logpro if applicable ;; (process-run "ls" (list "/foo" "2>&1" "blah.log"))
+ (if logprofile
+ (let* ((htmllogfile (conc stepname ".html"))
+ (oldexitstat exitstat)
+ (cmd (string-intersperse (list "logpro" logprofile htmllogfile "<" logfile ">" (conc stepname "_logpro.log")) " ")))
+ (debug:print-info 2 *default-log-port* "running \"" cmd "\"")
+ (change-directory startingdir)
+ (set! exitstat (system cmd))
+ (set! *globalexitstatus* exitstat) ;; no necessary
+ (change-directory testpath)
+ (rmt:test-set-log! run-id test-id htmllogfile)))
+ (let ((msg (args:get-arg "-m")))
+ (rmt:teststep-set-status! run-id test-id stepname "end" exitstat msg logfile))
+ )))
+ (if (or (args:get-arg "-test-status")
+ (args:get-arg "-set-values"))
+ (let ((newstatus (cond
+ ((number? status) (if (equal? status 0) "PASS" "FAIL"))
+ ((and (string? status)
+ (string->number status))(if (equal? (string->number status) 0) "PASS" "FAIL"))
+ (else status)))
+ ;; transfer relevant keys into a hash to be passed to test-set-status!
+ ;; could use an assoc list I guess.
+ (otherdata (let ((res (make-hash-table)))
+ (for-each (lambda (key)
+ (if (args:get-arg key)
+ (hash-table-set! res key (args:get-arg key))))
+ (list ":value" ":tol" ":expected" ":first_err" ":first_warn" ":units" ":category" ":variable"))
+ res)))
+ (if (and (args:get-arg "-test-status")
+ (or (not state)
+ (not status)))
+ (begin
+ (debug:print-error 0 *default-log-port* "You must specify :state and :status with every call to -test-status\n" help)
+ (if (sqlite3:database? db)(sqlite3:finalize! db))
+ (exit 6)))
+ (let* ((msg (args:get-arg "-m"))
+ (numoth (length (hash-table-keys otherdata))))
+ ;; Convert to rpc inside the tests:test-set-status! call, not here
+ (tests:test-set-status! run-id test-id state newstatus msg otherdata work-area: work-area))))
+ (if (sqlite3:database? db)(sqlite3:finalize! db))
+ (set! *didsomething* #t))))
+
+ ;;======================================================================
+ ;; Various helper commands can go below here
+ ;;======================================================================
+
+ (if (or (args:get-arg "-showkeys")
+ (args:get-arg "-show-keys"))
+ (let ((db #f)
+ (keys #f))
+ (if (not (launch:setup))
+ (begin
+ (debug:print 0 *default-log-port* "Failed to setup, exiting")
+ (exit 1)))
+ (set! keys (rmt:get-keys)) ;; db))
+ (debug:print 1 *default-log-port* "Keys: " (string-intersperse keys ", "))
+ (if (sqlite3:database? db)(sqlite3:finalize! db))
+ (set! *didsomething* #t)))
+
+ (if (args:get-arg "-gui")
+ (begin
+ (debug:print 0 *default-log-port* "Look at the dashboard for now")
+ ;; (megatest-gui)
+ (set! *didsomething* #t)))
+
+ (if (args:get-arg "-create-megatest-area")
+ (begin
+ (genexample:mk-megatest.config)
+ (set! *didsomething* #t)))
+
+ (if (args:get-arg "-create-test")
+ (let ((testname (args:get-arg "-create-test")))
+ (genexample:mk-megatest-test testname)
+ (set! *didsomething* #t)))
+
+ ;;======================================================================
+ ;; Update the database schema, clean up the db
+ ;;======================================================================
+
+ (if (args:get-arg "-rebuild-db")
+ (begin
+ (if (not (launch:setup))
+ (begin
+ (debug:print 0 *default-log-port* "Failed to setup, exiting")
+ (exit 1)))
+ ;; keep this one local
+ ;; (open-run-close patch-db #f)
+ (let ((dbstructs (db:setup)))
+ (common:cleanup-db dbstructs full: #t))
+ (set! *didsomething* #t)))
+
+ (if (args:get-arg "-cleanup-db")
+ (begin
+ (if (not (launch:setup))
+ (begin
+ (debug:print 0 *default-log-port* "Failed to setup, exiting")
+ (exit 1)))
+
+ ;; (if (not (server:choose-server *toppath* 'home?))
+ ;; (begin
+ ;; (debug:print 0 *default-log-port* "Servers are not running on this host or no servers alive. Cannot run cleanup-db")
+ ;; (exit 1)))
+
+ (let ((dbstructs (db:setup)))
+ (common:cleanup-db dbstructs))
+ (set! *didsomething* #t)))
+
+ (if (args:get-arg "-mark-incompletes")
+ (begin
+ (if (not (launch:setup))
+ (begin
+ (debug:print 0 *default-log-port* "Failed to setup, exiting")
+ (exit 1)))
+ (open-run-close db:find-and-mark-incomplete #f)
+ (set! *didsomething* #t)))
+
+ ;;======================================================================
+ ;; Update the tests meta data from the testconfig files
+ ;;======================================================================
+
+ (if (args:get-arg "-update-meta")
+ (begin
+ (if (not (launch:setup))
+ (begin
+ (debug:print 0 *default-log-port* "Failed to setup, exiting")
+ (exit 1)))
+ (runs:update-all-test_meta #f)
+ (set! *didsomething* #t)))
+
+ ;;======================================================================
+ ;; Start a repl
+ ;;======================================================================
+
+ ;; fakeout readline
+ (include "readline-fix.scm")
+
+
+ (when (args:get-arg "-diff-rep")
+ (when (and
+ (not (args:get-arg "-diff-html"))
+ (not (args:get-arg "-diff-email")))
+ (debug:print 0 *default-log-port* "Must specify -diff-html or -diff-email with -diff-rep")
+ (set! *didsomething* 1)
+ (exit 1))
+
+ (let* ((toppath (launch:setup)))
+ (do-diff-report
+ (args:get-arg "-src-target")
+ (args:get-arg "-src-runname")
+ (args:get-arg "-target")
+ (args:get-arg "-runname")
+ (args:get-arg "-diff-html")
+ (args:get-arg "-diff-email"))
+ (set! *didsomething* #t)
+ (exit 0)))
+
+ (if (or (getenv "MT_RUNSCRIPT")
+ (args:get-arg "-repl")
+ (args:get-arg "-load"))
+ (let* ((toppath (launch:setup))
+ (dbstructs (if (and toppath
+ ;; NOTE: server:choose-server is starting a server
+ ;; either add equivalent for tcp mode or ????
+ #;(server:choose-server toppath 'home?))
+ (db:setup)
+ #f))) ;; make-dbr:dbstruct path: toppath local: (args:get-arg "-local")) #f)))
+ (if *toppath*
+ (cond
+ ((getenv "MT_RUNSCRIPT")
+ ;; How to run megatest scripts
+ ;;
+ ;; #!/bin/bash
+ ;;
+ ;; export MT_RUNSCRIPT=yes
+ ;; megatest << EOF
+ ;; (print "Hello world")
+ ;; (exit)
+ ;; EOF
+
+ (repl))
+ (else
+ (begin
+ (set! *db* dbstructs)
+ (import extras) ;; might not be needed
+ ;; (import csi)
+ (import readline)
+ (import apropos)
+ (import dbfile)
+ ;; (import (prefix sqlite3 sqlite3:)) ;; doesn't work ...
+
+ (if *use-new-readline*
+ (begin
+ (install-history-file (get-environment-variable "HOME") ".megatest_history") ;; [homedir] [filename] [nlines])
+ (current-input-port (make-readline-port "megatest> ")))
+ (begin
+ (gnu-history-install-file-manager
+ (string-append
+ (or (get-environment-variable "HOME") ".") "/.megatest_history"))
+ (current-input-port (make-gnu-readline-port "megatest> "))))
+ (if (args:get-arg "-repl")
+ (repl)
+ (load (args:get-arg "-load")))
+ ;; (db:close-all dbstruct) <= taken care of by on-exit call
+ )
+ (exit)))
+ (set! *didsomething* #t))))
+
+ ;;======================================================================
+ ;; Wait on a run to complete
+ ;;======================================================================
+
+ (if (and (args:get-arg "-run-wait")
+ (not (or (args:get-arg "-run")
+ (args:get-arg "-runtests")))) ;; run-wait is built into runtests now
+ (begin
+ (if (not (launch:setup))
+ (begin
+ (debug:print 0 *default-log-port* "Failed to setup, exiting")
+ (exit 1)))
+ (operate-on 'run-wait)
+ (set! *didsomething* #t)))
+
+ ;; ;; ;; redo me ;; Not converted to use dbstruct yet
+ ;; ;; ;; redo me ;;
+ ;; ;; ;; redo me (if (args:get-arg "-convert-to-norm")
+ ;; ;; ;; redo me (let* ((toppath (setup-for-run))
+ ;; ;; ;; redo me (dbstruct (if toppath (make-dbr:dbstruct path: toppath local: #t))))
+ ;; ;; ;; redo me (for-each
+ ;; ;; ;; redo me (lambda (field)
+ ;; ;; ;; redo me (let ((dat '()))
+ ;; ;; ;; redo me (debug:print-info 0 *default-log-port* "Getting data for field " field)
+ ;; ;; ;; redo me (sqlite3:for-each-row
+ ;; ;; ;; redo me (lambda (id val)
+ ;; ;; ;; redo me (set! dat (cons (list id val) dat)))
+ ;; ;; ;; redo me (db:get-db db run-id)
+ ;; ;; ;; redo me (conc "SELECT id," field " FROM tests;"))
+ ;; ;; ;; redo me (debug:print-info 0 *default-log-port* "found " (length dat) " items for field " field)
+ ;; ;; ;; redo me (let ((qry (sqlite3:prepare db (conc "UPDATE tests SET " field "=? WHERE id=?;"))))
+ ;; ;; ;; redo me (for-each
+ ;; ;; ;; redo me (lambda (item)
+ ;; ;; ;; redo me (let ((newval ;; (sdb:qry 'getid
+ ;; ;; ;; redo me (cadr item))) ;; )
+ ;; ;; ;; redo me (if (not (equal? newval (cadr item)))
+ ;; ;; ;; redo me (debug:print-info 0 *default-log-port* "Converting " (cadr item) " to " newval " for test #" (car item)))
+ ;; ;; ;; redo me (sqlite3:execute qry newval (car item))))
+ ;; ;; ;; redo me dat)
+ ;; ;; ;; redo me (sqlite3:finalize! qry))))
+ ;; ;; ;; redo me (db:close-all dbstruct)
+ ;; ;; ;; redo me (list "uname" "rundir" "final_logf" "comment"))
+ ;; ;; ;; redo me (set! *didsomething* #t)))
+
+ (if (args:get-arg "-import-megatest.db")
+ (begin
+ (launch:setup)
+ (db:multi-db-sync
+ (db:setup)
+ 'killservers
+ 'dejunk
+ 'adj-testids
+ 'old2new
+ )
+ (set! *didsomething* #t)))
+
+ (if (args:get-arg "-import-sexpr")
+ (let*(
+ (toppath (launch:setup))
+ (tmppath (common:make-tmpdir-name toppath "")))
+ (if (file-exists? (conc toppath "/.mtdb"))
+ (if (args:get-arg "-remove-dbs")
+ (let* ((dbfiles (conc toppath "/.mtdb/* " tmppath "/*")))
+ (debug:print 0 *default-log-port* "Removing db files: " dbfiles)
+ (system (conc "rm -rvf " dbfiles))
+ )
+ (begin
+ (debug:print 0 *default-log-port* "ERROR: Cannot import sexpr with an existing DB present.")
+ (debug:print 0 *default-log-port* "Add '-remove-dbs all' to remove the current Megatest DBs.")
+ (set! *didsomething* #t)
+ (exit)
+ )
+ )
+ (debug:print 0 *default-log-port* "Did not find " (conc toppath "/.mtdb"))
+ )
+ (db:setup)
+ (rmt:import-sexpr (args:get-arg "-import-sexpr"))
+ (set! *didsomething* #t)))
+
+ (if (args:get-arg "-sync-to-megatest.db")
+ (let* ((duh (launch:setup))
+ (dbstruct (db:setup))
+ (tmpdbpth (dbr:dbstruct-tmppath dbstruct))
+ (lockfile (conc tmpdbpth ".lock"))
+ (locked (common:simple-file-lock lockfile))
+ (res (if locked
+ (db:multi-db-sync
+ dbstruct
+ 'new2old)
+ #f)))
+ (if res
+ (begin
+ (common:simple-file-release-lock lockfile)
+ (debug:print 0 *default-log-port* "Synced " res " records to megatest.db"))
+ (debug:print 0 *default-log-port* "Skipping sync, there is a sync in progress."))
+ (set! *didsomething* #t)))
+
+ (if (args:get-arg "-sync-to")
+ (let ((toppath (launch:setup)))
+ (tasks:sync-to-postgres *configdat* (args:get-arg "-sync-to"))
+ (set! *didsomething* #t)))
+
+
+ ;; use with -from and -to
+ ;;
+ (if (args:get-arg "-db2db")
+ (let* ((duh (launch:setup))
+ (src-db (args:get-arg "-from"))
+ (dest-db (args:get-arg "-to"))
+ ;; (sync-period (args:get-arg-number "-period"))
+ ;; (sync-timeout (args:get-arg-number "-timeout"))
+ (sync-period-in (args:get-arg "-period"))
+ (sync-timeout-in (args:get-arg "-timeout"))
+ (sync-period (if sync-period-in (string->number sync-period-in) #f))
+ (sync-timeout (if sync-timeout-in (string->number sync-timeout-in) #f))
+ (lockfile (conc dest-db".sync-lock"))
+ (keys (db:get-keys #f))
+ (thesync (lambda (last-update)
+ (debug:print-info 0 *default-log-port* "Attempting to sync data from "src-db" to "dest-db"...")
+ (debug:print-info 0 *default-log-port* "PID = " (current-process-id))
+ (if (not (file-exists? dest-db))
+ (begin
+ (debug:print 0 *default-log-port* "Using copy to create "dest-db" from "src-db)
+ (file-copy src-db dest-db)
+ 1)
+ (let ((res (dbmod:db-to-db-sync src-db dest-db last-update (dbfile:db-init-proc) keys)))
+ (if res
+ (debug:print-info 2 *default-log-port* "Synced " res " records from "src-db" to "dest-db)
+ (debug:print-info 0 *default-log-port* "No sync due to permissions or other issue."))
+ res))))
+ (start-time (current-seconds))
+ (synclock-mod-time (if (file-exists? lockfile)
+ (handle-exceptions
+ exn
+ #f
+ (file-modification-time synclock-file))
+ #f))
+ (age (if synclock-mod-time (- (current-seconds) synclock-mod-time) 1000))
+ )
+ (if (and src-db dest-db)
+ (if (file-exists? src-db)
+ (if (and (file-exists? lockfile) (< age 20))
+ (debug:print 0 *default-log-port* "Lock "lockfile" exists, skipping sync...")
+ (begin
+ (if (file-exists? lockfile)
+ (begin
+ (debug:print 0 *default-log-port* "Deleting old lock file " lockfile)
+ (delete-file lockfile)
+ )
+ )
+ (dbfile:with-simple-file-lock
+ lockfile
+ (lambda ()
+ (let loop ((last-changed (current-seconds))
+ (last-update 0))
+ (let* ((changes (handle-exceptions
+ exn
+ (begin
+ (debug:print 0 *default-log-port* "Exception in sync: "(condition->list exn))
+ (delete-file lockfile)
+ (exit))
+ (thesync last-update)))
+ (now-time (current-seconds)))
+ (if (and sync-period sync-timeout) ;;
+ (if (and (< (- now-time start-time) 600) ;; hard limit on how long we run for
+ (> sync-timeout (- now-time last-changed)))
+ (begin
+ (if sync-period (thread-sleep! sync-period))
+ (loop (if (> changes 0) now-time last-changed) now-time))))))))
+ (debug:print 0 *default-log-port* "Releasing lock file " lockfile)
+ )
+ )
+ (debug:print 0 *default-log-port* "No sync due to unreadble or non-existant source file"src-db))
+ (debug:print 0 *default-log-port* "Usage for -db2db; -to and -from must be specified"))
+ (set! *didsomething* #t)))
+
+ (if (args:get-arg "-list-test-time")
+ (let* ((toppath (launch:setup)))
+ (task:get-test-times)
+ (set! *didsomething* #t)))
+
+ (if (args:get-arg "-list-run-time")
+ (let* ((toppath (launch:setup)))
+ (task:get-run-times)
+ (set! *didsomething* #t)))
+
+ (if (args:get-arg "-generate-html")
+ (let* ((toppath (launch:setup)))
+ (if (tests:create-html-tree #f)
+ (debug:print-info 0 *default-log-port* "HTML output created in " toppath "/lt/page0.html")
+ (debug:print 0 *default-log-port* "Failed to create HTML output in " toppath "/lt/runs-index.html"))
+ (set! *didsomething* #t)))
+
+ (if (args:get-arg "-generate-html-structure")
+ (let* ((toppath (launch:setup)))
+ ;(if (tests:create-html-tree #f)
+ (if (tests:create-html-summary #f)
+ (debug:print-info 0 *default-log-port* "HTML output created in " toppath "/lt/targets.html")
+ (debug:print 0 *default-log-port* "Failed to create HTML output in " toppath "/lt/runs-index.html"))
+ (set! *didsomething* #t)))
+
+ (if (args:get-arg "-syscheck")
+ (begin
+ (mutils:syscheck common:raw-get-remote-host-load
+ server:get-best-guess-address
+ read-config)
+ (set! *didsomething* #t)))
+
+ (if (args:get-arg "-extract-skeleton")
+ (let* ((toppath (launch:setup)))
+ (genexample:extract-skeleton-area (args:get-arg "-extract-skeleton"))
+ (set! *didsomething* #t)))
+
+ ;;======================================================================
+ ;; Exit and clean up
+ ;;======================================================================
+
+ (if (not *didsomething*)
+ (debug:print 0 *default-log-port* help)
+ (set! *time-to-exit* #t)
+ )
+ ;;(debug:print-info 13 *default-log-port* "thread-join! watchdog")
+
+ ;; join the watchdog thread if it has been thread-start!ed (it may not have been started in the case of a server that never enters running state)
+ ;; (symbols returned by thread-state: created ready running blocked suspended sleeping terminated dead)
+ ;; TODO: for multiple areas, we will have multiple watchdogs; and multiple threads to manage
+ ;;(if (thread? *watchdog*)
+ ;; (case (thread-state *watchdog*)
+ ;; ((ready running blocked sleeping terminated dead)
+ ;; (thread-join! *watchdog*))))
+
+ (set! *time-to-exit* #t)
+
+ (if (not (eq? *globalexitstatus* 0))
+ (if (or (args:get-arg "-run")(args:get-arg "-runtests")(args:get-arg "-runall"))
+ (begin
+ (debug:print 0 *default-log-port* "NOTE: Subprocesses with non-zero exit code detected: " *globalexitstatus*)
+ (exit 0))
+ (case *globalexitstatus*
+ ((0)(exit 0))
+ ((1)(exit 1))
+ ((2)(exit 2))
+ (else (exit 3)))))
+ ) ;; main
+)
Index: processmod.scm
==================================================================
--- processmod.scm
+++ processmod.scm
@@ -24,10 +24,12 @@
(use srfi-69)
(module processmod
(
+ process:children
+
process:cmd-run->list
process:alive?
run-n-wait
process:cmd-run-with-stderr-and-exitcode->list
Index: runsmod.scm
==================================================================
--- runsmod.scm
+++ runsmod.scm
@@ -45,10 +45,11 @@
(use srfi-69)
(module runsmod
(
+ runs:clean-cache
rmt:find-and-mark-incomplete
launch:setup
launch:end-of-run-check
launch:test-copy
Index: servermod.scm
==================================================================
--- servermod.scm
+++ servermod.scm
@@ -27,11 +27,11 @@
(module servermod
(
remote-hh-dat
server:mk-signature
common:wait-for-normalized-load
-
+ server:expiration-timeout
)
(import scheme
chicken)
Index: tcp-transportmod.scm
==================================================================
--- tcp-transportmod.scm
+++ tcp-transportmod.scm
@@ -28,10 +28,14 @@
(use address-info tcp)
(module tcp-transportmod
(
+ make-tt
+ tt:start-server
+ tt:get-servinfo-dir
+ tt-server-timeout-param
tt:mk-signature
tt-state
tt:server-process-run
tt:make-remote
tt-ro-mode-checked-set!