;;======================================================================
;; 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 <http://www.gnu.org/licenses/>.
;;======================================================================
;;======================================================================
;; 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 <age> : 120d,3h,20m to apply only to runs older than the
specified age. NB// M=month, m=minute
-actions <action>[,...] : 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 <key> 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 <patt> -target-patt <patt> -dumpmode <csv,json,plain-text>
-list-test-time : list time requered to complete each test in a run. It following following arguments
-runname <patt> -target <patt> -dumpmode <csv,json,plain-text>
-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 <target>
-src-runname <target>
-diff-email <emails> : comma separated list of email addresses to send diff report
-diff-html <rep.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-<name> => num or col-<name> => 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 <target name>")
(exit 1))
((not runname-patt)
(debug:print-error 0 *default-log-port* "Missing runname, must specify runname for -kill-rerun with -runname <run name>")
(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 <target name>")
(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 <runname name>")
(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 <run-id>.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 <archive path>")
(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
)