;; Copyright 2006-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/>.
;;
;; (declare (uses dbi))
(declare (uses pkts))
;; (declare (uses stml2))
;; (declare (uses cookie))
;; (declare (uses csv-xml))
;; (declare (uses hostinfo))
(declare (uses adjutant))
;; (declare (uses archivemod))
(declare (uses apimod))
;; (declare (uses autoload))
;; (declare (uses bigmod))
(declare (uses commonmod))
(declare (uses configfmod))
(declare (uses dbmod))
(declare (uses debugprint))
;; (declare (uses ducttape-lib))
;; (declare (uses ezstepsmod))
(declare (uses launchmod))
(declare (uses mtargs))
(declare (uses mtver))
;; (declare (uses mutils))
(declare (uses processmod))
(declare (uses rmtmod))
;; (declare (uses runsmod))
;; (declare (uses servermod))
;; (declare (uses testsmod))
(declare (uses dbmgrmod))
;; needed for configf scripts, scheme etc.
;; (declare (uses apimod.import))
;; (declare (uses debugprint.import))
;; (declare (uses mtargs.import))
;; (declare (uses commonmod.import))
;; (declare (uses configfmod.import))
;; (declare (uses bigmod.import))
;; (declare (uses dbmod.import))
;; (declare (uses rmtmod.import))
;; (declare (uses servermod.import))
;; (declare (uses launchmod.import))
;; (include "call-with-environment-variables/call-with-environment-variables.scm")
(module mtserve
*
(import scheme
chicken.base
;; chicken.bitwise
;; chicken.condition
;; ;; chicken.csi
;; chicken.eval
;; chicken.file
;; chicken.file.posix
;; chicken.format
;; chicken.io
;; chicken.irregex
;; chicken.pathname
;; chicken.port
;; chicken.pretty-print
;; chicken.process
chicken.process-context
;; chicken.process-context.posix
;; chicken.process.signal
;; chicken.random
;; chicken.repl
;; chicken.sort
chicken.string
;; chicken.tcp
;; chicken.time
;; chicken.time.posix
;;
;; (prefix base64 base64:)
;; (prefix sqlite3 sqlite3:)
;; (prefix sxml-modifications sxml-)
;; address-info
;; csv-abnf
;; directory-utils
;; fmt
;; format
;; http-client
;; intarweb
;; json
;; linenoise
;; matchable
;; md5
;; message-digest
;; queues
;; regex
;; regex-case
;; s11n
;; sparse-vectors
;; spiffy
;; spiffy-directory-listing
;; spiffy-request-vars
;; sql-de-lite
;; stack
;; sxml-modifications
;; sxml-serializer
;; sxml-transforms
;; system-information
;; typed-records
;; uri-common
;; z3
;;
;; srfi-1
;; srfi-4
srfi-18
;; srfi-13
;; srfi-98
;; srfi-69
;;
;; ;; local modules
;; autoload
;; adjutant
;; csv-xml
;; ;; hostinfo
;; mtver
;; mutils
;; cookie
;; csv-xml
;; ducttape-lib
(prefix mtargs args:)
;; pkts
;; stml2
;; (prefix dbi dbi:)
;;
;; apimod
;; archivemod
;; bigmod
commonmod
;; configfmod
;; dbmod
debugprint
;; ezstepsmod
launchmod
;; processmod
;; rmtmod
;; runsmod
;; servermod
;; tasksmod
;; testsmod
dbmgrmod
;;
;; ulex
)
;; ;; ulex parameters
;; (work-method 'direct)
;; (return-method 'direct)
;; ulex parameters
;; (work-method 'mailbox)
;; (return-method 'mailbox)
;; (my-with-lock common:with-simple-file-lock)
;;
;; ;; fake out readline usage of toplevel-command
;; (define (toplevel-command . a) #f)
;; (define *didsomething* #f)
;; (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 "test_records.scm")
;;
;; ;; (include "common.scm")
;; (include "db.scm")
;; ;; (include "server.scm")
;; (include "tests.scm")
;; (include "genexample.scm")
;; (include "tdb.scm")
;; (include "env.scm")
;; (include "diff-report.scm")
;; (include "ods.scm")
;;
;; 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"
;; "-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"
"-db" ;; file name for setting up a server
;; "-adjutant"
;; "-transport"
;; "-port"
;; "-extract-ods"
;; "-pathmod"
;; "-env2file"
;; "-envcap"
;; "-envdelta"
;; "-setvars"
;; "-set-state-status"
;;
;; ;; 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"
;; "-ping"
;; "-refdb2dat"
;; "-o"
;; "-log"
;; "-autolog"
;; "-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"
;;
;; ;; 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"
;; "-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 (not (null? remargs))
(debug:print-error 0 *default-log-port* "Unrecognised arguments: " (string-intersperse (if (list? remargs) remargs (argv)) " ")))
;; 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") "/.mtserverc")))
(if (common:file-exists? debugcontrolf)
(load debugcontrolf)))
;; 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"))))
(set-environment-variable! "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))))
(define (main)
(debug:setup)
(make-and-init-bigdata)
(let ((tl (launch:setup))
(dbname (args:get-arg "-db")))
(if dbname
(rmt:server-launch dbname)
(debug:print 0 *default-log-port* "Usage: mtserve -db <dbpath/file>.db"))))
#;(set! *didsomething* #t)
(thread-join!
(thread-start!
(make-thread main)))
)
;; (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
;;
;; ;;======================================================================
;; ;; Test commands (i.e. for use inside tests)
;; ;;======================================================================
;;
;; (define (megatest:step step state status logfile msg)
;; (if (not (get-environment-variable "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 (get-environment-variable "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))))))
;;
;; ;;======================================================================
;; ;; 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")
;; ;; "%")
;; (bdat-user *bdat*)
;; args:arg-hash
;; run-count: rerun-cnt)))
;;
;; ;; 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)))
;;
;; ;; bracket open-output-file with code to make leading directory if it does not exist and handle exceptions
;; (define (open-logfile logpath-in)
;; (condition-case
;; (let* ((log-dir (or (pathname-directory logpath-in) "."))
;; (fname (pathname-strip-directory logpath-in))
;; (logpath (if (> (string-length fname) 250)
;; (let ((newlogf (conc log-dir "/" (common:get-signature fname) ".log")))
;; (debug:print 0 *default-log-port* "WARNING: log file " logpath-in " path too long, converted to " newlogf)
;; newlogf)
;; logpath-in)))
;; (if (not (directory-exists? log-dir))
;; (system (conc "mkdir -p " log-dir)))
;; (open-output-file logpath))
;; (exn ()
;; (debug:print-error 0 *default-log-port* "Could not open log file for write: "logpath-in)
;; (set! *didsomething* #t)
;; (exit 1))))
;;
;; ;; 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
;; -autolog logfilebase : appends pid and host to logfilebase for 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
;;
;; 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
;;
;; 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 ))
;;
;; (define (main)
;; (make-and-init-bigdata)
;;
;; ;; 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-writable? *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))
;;
;; ;; -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"
;; "-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"
;; "-db" ;; file name for setting up a server
;; "-adjutant"
;; "-transport"
;; "-port"
;; "-extract-ods"
;; "-pathmod"
;; "-env2file"
;; "-envcap"
;; "-envdelta"
;; "-setvars"
;; "-set-state-status"
;;
;; ;; 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"
;; "-ping"
;; "-refdb2dat"
;; "-o"
;; "-log"
;; "-autolog"
;; "-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"
;;
;; ;; 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"
;; "-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"))))
;; (set-environment-variable! "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 (set-environment-variable! "MT_TARGET" targ)))
;;
;; ;; The watchdog is to keep an eye on things like db sync etc.
;; ;;
;; ;; (init-watchdog)
;;
;; ;; (define (debug:debug-mode n)
;; ;; (cond
;; ;; ((and (number? *verbosity*) ;; number number
;; ;; (number? n))
;; ;; (<= n *verbosity*))
;; ;; ((and (list? *verbosity*) ;; list number
;; ;; (number? n))
;; ;; (member n *verbosity*))
;; ;; ((and (list? *verbosity*) ;; list list
;; ;; (list? n))
;; ;; (not (null? (lset-intersection! eq? *verbosity* n))))
;; ;; ((and (number? *verbosity*)
;; ;; (list? n))
;; ;; (member *verbosity* n))))
;;
;; ;; 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
;; (args:get-arg "-autolog"))
;; (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")
;; (args:get-arg "-autolog") ;; autolog provides the basename .../logs/something- for the logfile
;; (launch:setup))) ;; run launch:setup if -server, ensure we do NOT run launch:setup if -log specified
;; (logf (or (args:get-arg "-log") ;; use -log unless we are a server, then craft a logfile name
;; (conc tl (current-process-id)"-"(get-host-name)".log")
;; (conc tl "/logs/server-" (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)))
;;
;; ;; 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) " ")))
;;
;; ;; some switches imply homehost. Exit here if not on homehost
;; ;;
;; #;(let ((homehost-required (list "-cleanup-db" "-server")))
;; (if (apply args:any-defined? homehost-required)
;; (if (not (common:on-homehost?))
;; (for-each
;; (lambda (switch)
;; (if (args:get-arg switch)
;; (begin
;; (debug:print 0 *default-log-port* "ERROR: you must be on the homehost to run with " switch
;; ", you can move homehost by removing the .homehost file but this will disrupt any runs in progress.")
;; (exit 1))))
;; homehost-required))))
;;
;; ;;======================================================================
;; ;; 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"))
;;
;; ;; (debug:print 0 *default-log-port* "on-exit disabled. Please re-enable")
;; (on-exit std-exit-procedure)
;;
;; ;;======================================================================
;; ;; Misc general calls
;; ;;======================================================================
;;
;; ;; TODO: Restore this functionality
;;
;; #; (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/" (get-environment-variable "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)))
;;
;;
;; (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
;; ))
;;
;; ;; disabled for now
;;
;; #;(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")))
;; (server-ready? (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")
;; (if (not (args:get-arg "-db"))
;; (debug:print 0 *default-log-port* "ERROR: -db required to start server")
;; (let ((tl (launch:setup))
;; (dbname (args:get-arg "-db"))) ;; transport-type (string->symbol (or (args:get-arg "-transport") "http"))))
;; (rmt:server-launch dbname)
;; (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 (or (args:get-arg "-list-servers")
;; (args:get-arg "-kill-servers"))
;; (let ((tl (launch:setup)))
;; (if tl ;; all roads from here exit
;; (let* ((servers (rmt:get-servers-info *toppath*))
;; (fmtstr "~8a~22a~20a~20a~8a\n"))
;; ;; id INTEGER PRIMARY KEY,
;; ;; host TEXT,
;; ;; port INTEGER,
;; ;; servkey TEXT,
;; ;; pid TEXT,
;; ;; ipaddr TEXT,
;; ;; apath TEXT,
;; ;; dbname TEXT,
;; ;; event_time
;; (format #t fmtstr "pid" "Interface:port" "State" "dbname" "apath")
;; (format #t fmtstr "===" "==============" "=====" "======" "=====")
;; (for-each ;; ( mod-time host port start-time pid )
;; (lambda (server)
;; (match-let
;; (((id host port servkey pid ipaddr apath dbname event_time) server))
;; (format #t
;; fmtstr
;; pid
;; (conc host":"port)
;; (if (server-ready? host port servkey) "Running" "Dead")
;; dbname ;; (seconds->hr-min-sec mod)
;; apath
;; )
;; (if (args:get-arg "-kill-servers")
;; (begin
;; (debug:print-info 0 *default-log-port* "Attempting to kill server with pid " pid " !!needs completion!!")
;; #;(server:kill server)))))
;; servers)
;; ;; (debug:print-info 1 *default-log-port* "Done with listservers")
;; (set! *didsomething* #t)
;; (exit))
;; (exit))))
;; ;; must do, would have to add checks to many/all calls below
;;
;; ;;======================================================================
;; ;; Weird special calls that need to run *after* the server has started?
;; ;;======================================================================
;;
;; (if (args:get-arg "-list-targets")
;; (if (launch:setup)
;; (let* ((rconfdat (configf:read-config (conc *toppath* "/runconfigs.config") #f #f))
;; (targets (common:get-runconfig-targets rconfdat)))
;; ;; (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*)) ;; (configf: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)
;; (bdat-time-to-exit-set! *bdat* #t)))
;;
;; (if (args:get-arg "-show-cmdinfo")
;; (if (or (args:get-arg ":value")(get-environment-variable "MT_CMDINFO"))
;; (let ((data (common:read-encoded-string (or (args:get-arg ":value")(get-environment-variable "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
;;
;; ;; TODO: restore this functionality
;;
;; ;; (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)
;; (bdat-time-to-exit-set! *bdat* #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* (;; (dbstruct (make-dbr:dbstruct path: *toppath* local: (args:get-arg "-local")))
;; (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 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" )
;; (else
;; (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)))))
;;
;; (for-each
;; (lambda (test)
;; (handle-exceptions
;; 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) "/" (pseudo-random-integer 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)
;; (bdat-time-to-exit-set! *bdat* #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)))
;;
;;
;; ;; 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 round. 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))))))
;;
;; ;;======================================================================
;; ;; 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")
;; (bdat-user *bdat*)))))
;;
;; ;;======================================================================
;; ;; 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 (get-environment-variable "MT_CMDINFO")
;; (let* ((startingdir (current-directory))
;; (cmdinfo (common:read-encoded-string (get-environment-variable "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))))))
;;
;; ;;======================================================================
;; ;; 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:get-db-tmp-area) (> (length (directory (common:get-db-tmp-area) #f)) 0))
;; (begin
;; (debug:print-info 1 *default-log-port* (common:get-db-tmp-area) " 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
;; ;;======================================================================
;;
;; ;; TODO: Reenable this functionality
;;
;; #;(if (args:get-arg "-extract-ods")
;; (general-run-call
;; "-extract-ods"
;; "Make ods spreadsheet"
;; (lambda (target runname keys keyvals)
;; (let ((dbstruct (make-dbr:dbstruct path: *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)))))))
;;
;; (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 (get-environment-variable "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 (get-environment-variable "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
;; ;; (client:setup)
;;
;; (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
;; ;;======================================================================
;;
;; ;; TODO: Restore this functionality
;;
;; #;(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 ((dbstruct (db:setup #f areapath: *toppath*)))
;; (common:cleanup-db dbstruct 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)))
;; (let ((dbstruct (db:setup #f areapath: *toppath*)))
;; (common:cleanup-db dbstruct))
;; (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)))
;; (runs:find-and-mark-incomplete-and-check-end-of-run #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 (get-environment-variable "MT_RUNSCRIPT")
;; (args:get-arg "-repl")
;; (args:get-arg "-load"))
;; (let* ((toppath (launch:setup)))
;;
;; ;; (dbstruct (if (and toppath
;; ;; #;(common:on-homehost?))
;; ;; (db:setup #f) ;; sets up main.db
;; ;; #f))) ;; make-dbr:dbstruct path: toppath local: (args:get-arg "-local")) #f)))
;; (if *toppath*
;; (cond
;; ((get-environment-variable "MT_RUNSCRIPT")
;; ;; How to run megatest scripts
;; ;;
;; ;; #!/bin/bash
;; ;;
;; ;; export MT_RUNSCRIPT=yes
;; ;; megatest << EOF
;; ;; (print "Hello world")
;; ;; (exit)
;; ;; EOF
;;
;; (repl))
;; (else
;; (begin
;; ;; (set! *db* dbstruct)
;; ;; (import extras) ;; might not be needed
;; ;; (import chicken.csi)
;; ;; (import readline)
;; #;(import apropos
;; archivemod
;; commonmod
;; configfmod
;; dbmod
;; debugprint
;; ezstepsmod
;; launchmod
;; processmod
;; rmtmod
;; runsmod
;; servermod
;; tasksmod
;; testsmod)
;;
;; (set-history-length! 300)
;; (load-history-from-file ".megatest_history")
;; (current-input-port (make-linenoise-port))
;; ;; (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)))
;;
;; ;; TODO: restore this functionality
;;
;; #;(if (args:get-arg "-import-megatest.db")
;; (begin
;; (db:multi-db-sync
;; (db:setup #f)
;; 'killservers
;; 'dejunk
;; 'adj-testids
;; 'old2new
;; ;; 'new2old
;; )
;; (set! *didsomething* #t)))
;;
;; #;(when (args:get-arg "-sync-brute-force")
;; ((server:get-bruteforce-syncer (db:setup #t) persist-until-sync: #t))
;; (set! *didsomething* #t))
;;
;; #;(if (args:get-arg "-sync-to-megatest.db")
;; (let* ((dbstruct (db:setup #f))
;; (tmpdbpth (cdr (dbr:dbstruct-tmpdb 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)
;; (print "Synced " res " records to megatest.db"))
;; (print "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)))
;;
;; (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
;; configf: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)
;; (bdat-time-to-exit-set! *bdat* #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
;; #;(let* ((watchdog (bdat-watchdog *bdat*)))
;; (if (thread? watchdog)
;; (case (thread-state watchdog)
;; ((ready running blocked sleeping terminated dead)
;; (thread-join! watchdog)))))
;;
;; (bdat-time-to-exit-set! *bdat* #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)))))
;; )
;;
;; ;; (import megatest-main commonmod)
;; ;; (import srfi-18)