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