Index: configfmod.scm ================================================================== --- configfmod.scm +++ configfmod.scm @@ -35,10 +35,11 @@ chicken.pathname chicken.port chicken.pretty-print chicken.process chicken.process-context + chicken.process-context.posix chicken.sort chicken.string chicken.time chicken.eval @@ -969,10 +970,12 @@ (result #f) (start-time (current-seconds)) (cmdsym (string->symbol cmdtype)) (fullcmd (conc configf:std-imports + "(import chicken.process-context.posix)" + "(define setenv set-environment-variable)" (case cmdsym ((scheme scm) (conc "(lambda (ht)" cmd ")")) ((system) (conc "(lambda (ht)(configf:system ht \"" cmd "\"))")) ((shell sh) (conc "(lambda (ht)(string-translate (shell \"" cmd "\") \"\n\" \" \"))")) ((realpath rp)(conc "(lambda (ht)(common:nice-path \"" cmd "\"))")) Index: dbmod.scm ================================================================== --- dbmod.scm +++ dbmod.scm @@ -230,10 +230,25 @@ (let* ((db (sqlite3:open-database ":memory:")) (handler (sqlite3:make-busy-timeout 3600))) (sqlite3:set-busy-handler! db handler) (dbinit-proc db) ;; NOTE: inmem must always be initialized (db:initialize-db db) db)) + +;; for debugging we have a local mode. these routines support that mode +(define *dbcache* (make-hash-table)) + +(define (db:cache-get-dbstruct rid apath) + (let* ((dbname (db:run-id->dbname rid)) + (dbfile (db:dbname->path apath dbname))) + (or (hash-table-ref/default *dbcache* dbfile #f) + (let* ((dbstruct (db:setup dbfile))) ;; (db:open-dbdat apath dbfile db:initialize-db))) + (hash-table-set! *dbcache* dbfile dbstruct) + dbstruct)))) + +(define (db:finalize-all-cache-dbstruct) + #f) + ;; get and initalize dbstruct for a given run-id ;; ;; - uses db:initialize-db to create the schema ;; Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -182,20 +182,20 @@ (include "ods.scm") (define *usage-log-file* #f) ;; put path to file for logging usage in this var in the ~/.megatestrc file (define *usage-use-seconds* #t) ;; for Epoc seconds in usage logging change this to #t in ~/.megatestrc file - ;;====================================================================== - ;; Test commands (i.e. for use inside tests) - ;;====================================================================== - - (define (megatest:step step state status logfile msg) - (if (not (getenv "MT_CMDINFO")) - (begin +;;====================================================================== +;; 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"))) + (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)) @@ -215,18 +215,18 @@ (rmt:teststep-set-status! run-id test-id step state status (or comment msg) logfile)) (begin (debug:print-error 0 *default-log-port* "You must specify :state and :status with every call to -step") (exit 6)))))) - ;;====================================================================== - ;; full run - ;;====================================================================== - - (define (handle-run-requests target runname keys keyvals need-clean) - (if (or (args:get-arg "-kill-rerun") (args:get-arg "-rerun-clean")) ;; first set states/statuses correct - ;; For rerun-clean do we or do we not support the testpatt? - (let ((states (or (configf:lookup *configdat* "validvalues" "cleanrerun-states") +;;====================================================================== +;; 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 @@ -244,13 +244,13 @@ ;; "%" ;; (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))) + ;; 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") @@ -263,67 +263,67 @@ (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"))) + (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 + + (runs:run-tests target runname #f ;; (common:args-get-testpatt #f) ;; (or (args:get-arg "-testpatt") ;; "%") (bdat-user *bdat*) args:arg-hash run-count: rerun-cnt))) - ;; csv processing record - (define (make-refdb:csv) - (vector - (make-sparse-array) - (make-hash-table) - (make-hash-table) - 0 - 0)) - (define-inline (refdb:csv-get-svec vec) (vector-ref vec 0)) - (define-inline (refdb:csv-get-rows vec) (vector-ref vec 1)) - (define-inline (refdb:csv-get-cols vec) (vector-ref vec 2)) - (define-inline (refdb:csv-get-maxrow vec) (vector-ref vec 3)) - (define-inline (refdb:csv-get-maxcol vec) (vector-ref vec 4)) - (define-inline (refdb:csv-set-svec! vec val)(vector-set! vec 0 val)) - (define-inline (refdb:csv-set-rows! vec val)(vector-set! vec 1 val)) - (define-inline (refdb:csv-set-cols! vec val)(vector-set! vec 2 val)) - (define-inline (refdb:csv-set-maxrow! vec val)(vector-set! vec 3 val)) - (define-inline (refdb:csv-set-maxcol! vec val)(vector-set! vec 4 val)) - - (define (get-dat results sheetname) - (or (hash-table-ref/default results sheetname #f) - (let ((tmp-vec (make-refdb:csv))) +;; csv processing record +(define (make-refdb:csv) + (vector + (make-sparse-array) + (make-hash-table) + (make-hash-table) + 0 + 0)) +(define-inline (refdb:csv-get-svec vec) (vector-ref vec 0)) +(define-inline (refdb:csv-get-rows vec) (vector-ref vec 1)) +(define-inline (refdb:csv-get-cols vec) (vector-ref vec 2)) +(define-inline (refdb:csv-get-maxrow vec) (vector-ref vec 3)) +(define-inline (refdb:csv-get-maxcol vec) (vector-ref vec 4)) +(define-inline (refdb:csv-set-svec! vec val)(vector-set! vec 0 val)) +(define-inline (refdb:csv-set-rows! vec val)(vector-set! vec 1 val)) +(define-inline (refdb:csv-set-cols! vec val)(vector-set! vec 2 val)) +(define-inline (refdb:csv-set-maxrow! vec val)(vector-set! vec 3 val)) +(define-inline (refdb:csv-set-maxcol! vec val)(vector-set! vec 4 val)) + +(define (get-dat results sheetname) + (or (hash-table-ref/default results sheetname #f) + (let ((tmp-vec (make-refdb:csv))) (hash-table-set! results sheetname tmp-vec) tmp-vec))) - - ;; bracket open-output-file with code to make leading directory if it does not exist and handle exceptions - (define (open-logfile logpath-in) - (condition-case - (let* ((log-dir (or (pathname-directory logpath-in) ".")) + +;; bracket open-output-file with code to make leading directory if it does not exist and handle exceptions +(define (open-logfile logpath-in) + (condition-case + (let* ((log-dir (or (pathname-directory logpath-in) ".")) (fname (pathname-strip-directory logpath-in)) (logpath (if (> (string-length fname) 250) (let ((newlogf (conc log-dir "/" (common:get-signature fname) ".log"))) (debug:print 0 *default-log-port* "WARNING: log file " logpath-in " path too long, converted to " newlogf) newlogf) logpath-in))) - (if (not (directory-exists? log-dir)) - (system (conc "mkdir -p " log-dir))) - (open-output-file logpath)) - (exn () - (debug:print-error 0 *default-log-port* "Could not open log file for write: "logpath-in) - (define *didsomething* #t) - (exit 1)))) + (if (not (directory-exists? log-dir)) + (system (conc "mkdir -p " log-dir))) + (open-output-file logpath)) + (exn () + (debug:print-error 0 *default-log-port* "Could not open log file for write: "logpath-in) + (define *didsomething* #t) + (exit 1)))) (define (debug:setup) (let ((debugstr (or (args:get-arg "-debug") (args:get-arg "-debug-noprop") (getenv "MT_DEBUG_MODE")))) @@ -349,11 +349,11 @@ ;; 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 Index: rmtmod.scm ================================================================== --- rmtmod.scm +++ rmtmod.scm @@ -297,20 +297,27 @@ ))) ;;====================================================================== +;; FOR DEBUGGING SET TO #t +(define *localmode* #t) ;; Defaults to current area ;; (define (rmt:send-receive cmd rid params #!key (attemptnum 1)(area-dat #f)) (if (not *rmt:remote*)(set! *rmt:remote* (make-rmt:remote))) - (let* ((apath *toppath*) - (conns *rmt:remote*) - (dbname (db:run-id->dbname rid))) - (rmt:general-open-connection conns apath dbname) - (rmt:send-receive-real conns apath dbname cmd params))) + (let* ((apath *toppath*) + (conns *rmt:remote*) + (dbname (db:run-id->dbname rid))) + (if *localmode* + (let* ((dbstruct (db:cache-get-dbstruct rid apath)) + (indat `((cmd . ,cmd)(params . ,params)))) + (api:process-request dbstruct indat)) + (begin + (rmt:general-open-connection conns apath dbname) + (rmt:send-receive-real conns apath dbname cmd params))))) #;(define (rmt:send-receive-setup conn) (if (not (rmt:conn-inport conn)) (let-values (((i o) (tcp-connect (rmt:conn-ipaddr conn) (rmt:conn-port conn)))) @@ -1602,11 +1609,11 @@ (server:get-best-guess-address hostname) #f))) (if ipstr ipstr hostn))) ;; hostname))) (port (portlogger:open-run-close portlogger:find-port)) (link-tree-path (common:get-linktree)) - (tmp-area (common:get-db-tmp-area)) + ;; (tmp-area (common:get-db-tmp-area)) #;(start-file (conc tmp-area "/.server-start"))) (debug:print-info 0 *default-log-port* "portlogger recommended port: " port) (if *server-info* (begin (servdat-host-set! *server-info* ipaddrstr)