Index: common.scm ================================================================== --- common.scm +++ common.scm @@ -270,23 +270,10 @@ (else "FAIL"))) (define (common:logpro-exit-code->test-status exit-code) (status-sym->string (common:logpro-exit-code->status-sym exit-code))) -(defstruct remote - (hh-dat (common:get-homehost)) ;; homehost record ( addr . hhflag ) - (server-url (if *toppath* (server:check-if-running *toppath*))) ;; (server:check-if-running *toppath*) #f)) - (last-server-check 0) ;; last time we checked to see if the server was alive - (conndat #f) - (transport *transport-type*) - (server-timeout (server:expiration-timeout)) - (force-server #f) - (ro-mode #f) - (ro-mode-checked #f) ;; flag that indicates we have checked for ro-mode - (ulex:conn #f) ;; ulex db conn is not exactly a db connector, more like a network connector - ) - ;; launching and hosts (defstruct host (reachable #f) (last-update 0) (last-used 0) Index: common_records.scm ================================================================== --- common_records.scm +++ common_records.scm @@ -17,12 +17,45 @@ ;; along with Megatest. If not, see . ;; ;;====================================================================== ;; (use trace) +(use typed-records) + +;; globals - modules that include this need these here +(define *verbosity-cache* (make-hash-table)) +(define *verbosity* 0) +(define *default-log-port* (current-error-port)) +(define *logging* #f) +(define *functions* (make-hash-table)) ;; symbol => fn +(define *toppath* #f) +(define *transport-type* 'http) + +(define (exec-fn fn . params) + (if (hash-table-exists? *functions* fn) + (apply (hash-table-ref *functions* fn) params) + #f)) + +(define (set-fn fn-name fn) + (hash-table-set! *functions* fn-name fn)) (include "altdb.scm") + + +(defstruct remote + (hh-dat (exec-fn 'common:get-homehost)) ;; homehost record ( addr . hhflag ) + (server-url (if *toppath* (exec-fn 'server:check-if-running *toppath*))) ;; (server:check-if-running *toppath*) #f)) + (last-server-check 0) ;; last time we checked to see if the server was alive + (conndat #f) + (transport *transport-type*) + (server-timeout (exec-fn 'server:expiration-timeout)) + (force-server #f) + (ro-mode #f) + (ro-mode-checked #f) ;; flag that indicates we have checked for ro-mode + (ulex:conn #f) ;; ulex db conn is not exactly a db connector, more like a network connector + ) + ;; Some of these routines use: ;; ;; http://www.cs.toronto.edu/~gfb/scheme/simple-macros.html ;; @@ -80,11 +113,11 @@ ;; this was cached based on results from profiling but it turned out the profiling ;; somehow went wrong - perhaps too many processes writing to it. Leaving the caching ;; in for now but can probably take it out later. ;; -(define (debug:calc-verbosity vstr) +(define (debug:calc-verbosity vstr verbose quiet) ;; verbose and quiet are #f or enabled (or (hash-table-ref/default *verbosity-cache* vstr #f) (let ((res (cond ((number? vstr) vstr) ((not (string? vstr)) 1) ;; ((string-match "^\\s*$" vstr) 1) @@ -91,12 +124,12 @@ (vstr (let ((debugvals (filter number? (map string->number (string-split vstr ","))))) (cond ((> (length debugvals) 1) debugvals) ((> (length debugvals) 0)(car debugvals)) (else 1)))) - ((args:get-arg "-v") 2) - ((args:get-arg "-q") 0) + (verbose 2) ;; ((args:get-arg "-v") 2) + (quiet 0) ;; ((args:get-arg "-q") 0) (else 1)))) (hash-table-set! *verbosity-cache* vstr res) res))) ;; check verbosity, #t is ok @@ -121,29 +154,29 @@ (not (null? (lset-intersection! eq? *verbosity* n)))) ((and (number? *verbosity*) (list? n)) (member *verbosity* n)))) -(define (debug:setup) - (let ((debugstr (or (args:get-arg "-debug") - (getenv "MT_DEBUG_MODE")))) - (set! *verbosity* (debug:calc-verbosity debugstr)) +(define (debug:setup dmode verbose quiet) + (let ((debugstr (or dmode ;; (args:get-arg "-debug") + (get-environment-variable "MT_DEBUG_MODE")))) + (set! *verbosity* (debug:calc-verbosity debugstr verbose quiet)) (debug:check-verbosity *verbosity* debugstr) ;; if we were handed a bad verbosity rule then we will override it with 1 and continue (if (not *verbosity*)(set! *verbosity* 1)) - (if (or (args:get-arg "-debug") - (not (getenv "MT_DEBUG_MODE"))) + (if (or dmode ;; (args:get-arg "-debug") + (not (get-environment-variable "MT_DEBUG_MODE"))) (setenv "MT_DEBUG_MODE" (if (list? *verbosity*) (string-intersperse (map conc *verbosity*) ",") (conc *verbosity*)))))) (define (debug:print n e . params) (if (debug:debug-mode n) (with-output-to-port (or e (current-error-port)) (lambda () (if *logging* - (db:log-event (apply conc params)) + (exec-fn 'db:log-event (apply conc params)) (apply print params) ))))) ;; Brandon's debug printer shortcut (indulge me :) (define *BB-process-starttime* (current-milliseconds)) @@ -218,11 +251,11 @@ ;; normal print (if (debug:debug-mode n) (with-output-to-port (if (port? e) e (current-error-port)) (lambda () (if *logging* - (db:log-event (apply conc params)) + (exec-fn 'db:log-event (apply conc params)) ;; (apply print "pid:" (current-process-id) " " params) (apply print "ERROR: " params) )))) ;; pass important messages to stderr (if (and (eq? n 0)(not (eq? e (current-error-port)))) @@ -235,11 +268,11 @@ (if (debug:debug-mode n) (with-output-to-port (if (port? e) e (current-error-port)) (lambda () (if *logging* (let ((res (format#format #f "INFO: (~a) ~a" n (apply conc params)))) - (db:log-event res)) + (exec-fn 'db:log-event res)) ;; (apply print "pid:" (current-process-id) " " "INFO: (" n ") " params) ;; res) (apply print "INFO: (" n ") " params) ;; res) ))))) Index: dashboard.scm ================================================================== --- dashboard.scm +++ dashboard.scm @@ -511,11 +511,11 @@ 3))) (define (get-curr-sort) (vector-ref *tests-sort-options* *tests-sort-reverse*)) -(debug:setup) +(debug:setup (args:get-arg "-debug")(args:get-arg "-v")(args:get-arg "-q")) ;; (define uidat #f) (define-inline (dboard:uidat-get-keycol vec)(vector-ref vec 0)) (define-inline (dboard:uidat-get-lftcol vec)(vector-ref vec 1)) Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -38,10 +38,14 @@ (include "common_records.scm") (include "db_records.scm") (include "key_records.scm") (include "run_records.scm") + +(declare (uses rmtmod)) +(import rmtmod) + (define *rundb-mutex* (make-mutex)) ;; prevent problems opening/closing rundb's (define *number-of-writes* 0) (define *number-non-write-queries* 0) @@ -4750,6 +4754,8 @@ (stack-push! (dbr:dbstruct-dbstack dbstruct) dbdat) (system "rm -rf tempdir"))) ;; (db:extract-ods-file db "outputfile.ods" '(("sysname" "%")("fsname" "%")("datapath" "%")) "%") - +;; tiresome setup for rmtmod (and other mods) goes here +(set-fn 'db:dbfile-path common:get-db-tmp-area) +(set-fn 'db:setup db:setup) Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -608,11 +608,11 @@ ;;====================================================================== ;; Misc setup stuff ;;====================================================================== -(debug:setup) +(debug:setup (args:get-arg "-debug")(args:get-arg "-v")(args:get-arg "-q")) (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)) Index: rmt.scm ================================================================== --- rmt.scm +++ rmt.scm @@ -25,10 +25,13 @@ (declare (uses http-transport)) (include "common_records.scm") (declare (uses rmtmod)) (import rmtmod) +(set-fn 'server:expiration-timeout server:expiration-timeout) +(set-fn 'common:get-homehost common:get-homehost) +(set-fn 'server:check-if-running server:check-if-running) ;; ;; THESE ARE ALL CALLED ON THE CLIENT SIDE!!! ;; @@ -865,7 +868,7 @@ http-transport:close-connections remote-conndat-set! debug:print debug:print-info debug:print-error remote-ro-mode remote-ro-mode-set! remote-ro-mode-checked-set! remote-ro-mode-checked - db:dbfile-path db:setup + #f #f api:execute-requests api:read-only-queries) Index: rmtmod.scm ================================================================== --- rmtmod.scm +++ rmtmod.scm @@ -23,29 +23,20 @@ (module rmtmod * (import scheme chicken data-structures extras) -(import (prefix sqlite3 sqlite3:) posix typed-records srfi-18) +(import (prefix sqlite3 sqlite3:) posix typed-records srfi-18 srfi-69 format ports srfi-1) (import commonmod) (use (prefix ulex ulex:)) + +(include "common_records.scm") ;; Hack to make these functions visible to the refactored code, goal is to eliminate these over time. (define (rmt:send-receive . params) #f) (define (http-transport:close-connections . params) #f) ;; from remote defstruct in common.scm -(define (remote-conndat-set! . params) #f) -(define (remote-server-url-set! . params) #f) -(define (remote-ro-mode . params) #f) -(define (remote-ro-mode-set! . params) #f) -(define (remote-ro-mode-checked-set! . params) #f) -(define (remote-ro-mode-checked . params) #f) -(define (debug:print . params) #f) -(define (debug:print-info . params) #f) -(define (debug:print-error . params) #f) -(define (db:dbfile-path . params) #f) -(define (db:setup . params) #f) (define (api:execute-requests . params) #f) (define (set-functions send-receive rsus close-connections rcs dbgp dbgpinfo @@ -63,24 +54,18 @@ ;; print stuff (set! debug:print dbgp) (set! debug:print-info dbgpinfo) (set! debug:print-error dbgperr) ;; - (set! remote-ro-mode ro-mode) - (set! remote-ro-mode-set! ro-mode-set) - (set! remote-ro-mode-checked-set! ro-mode-checked-set) - (set! remote-ro-mode-checked ro-mode-checked) ;; db stuff for local db access - (set! db:dbfile-path dbfile-path) - (set! db:setup dbsetup) (set! apt:execute-requests exec-req) ) (define (rmt:open-qry-close-locally log-port multi-sync-mutex cmd run-id params #!key (ro-queries '())(remretries 5)) (let* ((qry-is-write (not (member cmd ro-queries))) - (db-file-path (db:dbfile-path)) ;; 0)) - (dbstruct-local (db:setup #t)) ;; make-dbr:dbstruct path: dbdir local: #t))) + (db-file-path (exec-fn 'db:dbfile-path)) ;; 0)) + (dbstruct-local (exec-fn 'db:setup #t)) ;; make-dbr:dbstruct path: dbdir local: #t))) (read-only (not (file-write-access? db-file-path))) (start (current-milliseconds)) (resdat (if (not (and read-only qry-is-write)) (let ((v (api:execute-requests dbstruct-local (vector (symbol->string cmd) params)))) (handle-exceptions ;; there has been a long history of receiving strange errors from values returned by the client when things go wrong.. @@ -192,8 +177,8 @@ (define (rmtmod:send-receive-ulex ulex:conn cmd rid params attemptnum area-dat) #f) (use trace)(trace-call-sites #t) -(trace member rmtmod:calc-ro-mode rmt:open-qry-close-locally) +;; (trace member rmtmod:calc-ro-mode rmt:open-qry-close-locally) )