Index: common.scm ================================================================== --- common.scm +++ common.scm @@ -52,26 +52,26 @@ ;; CONTEXTS (defstruct cxt (taskdb #f) (cmutex (make-mutex))) -(define *contexts* (make-hash-table)) -(define *context-mutex* (make-mutex)) - -;; safe method for accessing a context given a toppath -;; -(define (common:with-cxt toppath proc) - (mutex-lock! *context-mutex*) - (let ((cxt (hash-table-ref/default *contexts* toppath #f))) - (if (not cxt) - (set! cxt (let ((x (make-cxt)))(hash-table-set! *contexts* toppath x) x))) - (let ((cxt-mutex (cxt-mutex cxt))) - (mutex-unlock! *context-mutex*) - (mutex-lock! cxt-mutex) - (let ((res (proc cxt))) - (mutex-unlock! cxt-mutex) - res)))) +;; (define *contexts* (make-hash-table)) +;; (define *context-mutex* (make-mutex)) + +;; ;; safe method for accessing a context given a toppath +;; ;; +;; (define (common:with-cxt toppath proc) +;; (mutex-lock! *context-mutex*) +;; (let ((cxt (hash-table-ref/default *contexts* toppath #f))) +;; (if (not cxt) +;; (set! cxt (let ((x (make-cxt)))(hash-table-set! *contexts* toppath x) x))) +;; (let ((cxt-mutex (cxt-mutex cxt))) +;; (mutex-unlock! *context-mutex*) +;; (mutex-lock! cxt-mutex) +;; (let ((res (proc cxt))) +;; (mutex-unlock! cxt-mutex) +;; res)))) ;; A hash table that can be accessed by #{scheme ...} calls in ;; config files. Allows communicating between confgs ;; (define *user-hash-data* (make-hash-table)) @@ -86,11 +86,11 @@ (define *already-seen-runconfig-info* #f) (define *test-meta-updated* (make-hash-table)) (define *globalexitstatus* 0) ;; attempt to work around possible thread issues (define *passnum* 0) ;; when running track calls to run-tests or similar -(define *alt-log-file* #f) ;; used by -log +;; (define *alt-log-file* #f) ;; used by -log (define *common:denoise* (make-hash-table)) ;; for low noise printing (define *default-log-port* (current-error-port)) (define *time-zero* (current-seconds)) ;; for the watchdog ;; DATABASE @@ -116,20 +116,20 @@ ;; SERVER (define *my-client-signature* #f) (define *transport-type* 'http) ;; override with [server] transport http|rpc|nmsg (define *runremote* #f) ;; if set up for server communication this will hold -(define *max-cache-size* 0) +;; (define *max-cache-size* 0) (define *logged-in-clients* (make-hash-table)) -(define *server-id* #f) -(define *server-info* #f) +;; (define *server-id* #f) +(define *server-info* #f) ;; good candidate for easily convert to non-global (define *time-to-exit* #f) (define *server-run* #t) (define *run-id* #f) (define *server-kind-run* (make-hash-table)) (define *home-host* #f) -(define *total-non-write-delay* 0) +;; (define *total-non-write-delay* 0) (define *heartbeat-mutex* (make-mutex)) (define *api-process-request-count* 0) (define *max-api-process-requests* 0) ;; client Index: http-transport.scm ================================================================== --- http-transport.scm +++ http-transport.scm @@ -476,17 +476,17 @@ ;; all routes though here end in exit ... ;; ;; start_server? ;; (define (http-transport:launch) - (if (args:get-arg "-daemonize") - (begin - (daemon:ize) - (if *alt-log-file* ;; we should re-connect to this port, I think daemon:ize disrupts it - (begin - (current-error-port *alt-log-file*) - (current-output-port *alt-log-file*))))) + ;; (if (args:get-arg "-daemonize") + ;; (begin + ;; (daemon:ize) + ;; (if *alt-log-file* ;; we should re-connect to this port, I think daemon:ize disrupts it + ;; (begin + ;; (current-error-port *alt-log-file*) + ;; (current-output-port *alt-log-file*))))) (let* ((th2 (make-thread (lambda () (debug:print-info 0 *default-log-port* "Server run thread started") (http-transport:run (if (args:get-arg "-server") (args:get-arg "-server") @@ -541,22 +541,22 @@ (define (http-transport:stats-table) (mutex-lock! *heartbeat-mutex*) (let ((res (conc "" - "" + ;; "" "" "" "" - "" "" "
Max cached queries " *max-cache-size* "
Max cached queries " *max-cache-size* "
Number of cached writes " *number-of-writes* "
Average cached write time " (if (eq? *number-of-writes* 0) "n/a (no writes)" (/ *writes-total-delay* *number-of-writes*)) " ms
Number non-cached queries " *number-non-write-queries* "
Average non-cached time " (if (eq? *number-non-write-queries* 0) - "n/a (no queries)" - (/ *total-non-write-delay* - *number-non-write-queries*)) + ;; "
Average non-cached time " (if (eq? *number-non-write-queries* 0) + ;; "n/a (no queries)" + ;; (/ *total-non-write-delay* + ;; *number-non-write-queries*)) " ms
Last access" (seconds->time-string *db-last-access*) "
"))) (mutex-unlock! *heartbeat-mutex*) res)) Index: launch.scm ================================================================== --- launch.scm +++ launch.scm @@ -792,15 +792,15 @@ (sections (if target (list "default" target) #f)) ;; for runconfigs (mtconfig (or (args:get-arg "-config") "megatest.config")) ;; allow overriding megatest.config (rundir (if (and runname target linktree)(conc linktree (if contour (conc "/" contour) "") "/" target "/" runname) #f)) (mtcachef (and rundir (conc rundir "/" ".megatest.cfg-" megatest-version "-" megatest-fossil-hash))) (rccachef (and rundir (conc rundir "/" ".runconfigs.cfg-" megatest-version "-" megatest-fossil-hash))) - (cancreate (and rundir (file-exists? rundir)(file-write-access? rundir))) - (cxt (hash-table-ref/default *contexts* toppath #f))) + (cancreate (and rundir (file-exists? rundir)(file-write-access? rundir)))) + ;; (cxt (hash-table-ref/default *contexts* toppath #f))) ;; create our cxt for this area if it doesn't already exist - (if (not cxt)(hash-table-set! *contexts* toppath (make-cxt))) + ;; (if (not cxt)(hash-table-set! *contexts* toppath (make-cxt))) ;; (print "runname: " runname " target: " target " mtcachef: " mtcachef " rccachef: " rccachef) (set! *toppath* toppath) ;; This is needed when we are running as a test using CMDINFO as a datasource (cond ;; data was read and cached and available in *configstatus*, toppath has already been set Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -60,10 +60,11 @@ (load debugcontrolf))) ;; 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-2015 @@ -154,11 +155,10 @@ -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 -transport http|rpc : use http or rpc for transport (default is http) - -daemonize : fork into background and disconnect from stdin/out -log logfile : send stdout and stderr to logfile -list-servers : list the servers -stop-server id : stop server specified by id (see output of -list-servers), use 0 to kill all -repl : start a repl (useful for extending megatest) @@ -427,18 +427,23 @@ (define *didsomething* #t) (exit 1)))) (if (or (args:get-arg "-log")(args:get-arg "-server")) ;; redirect the log always when a server - (let* ((tl (or (args:get-arg "-log")(launch:setup))) ;; run launch:setup if -server - (logf (or (args:get-arg "-log") ;; use -log unless we are a server, then craft a logfile name - (conc tl "/logs/server-" (current-process-id) "-" (get-host-name) ".log"))) - (oup (open-logfile logf))) - (if (not (args:get-arg "-log")) - (hash-table-set! args:arg-hash "-log" logf)) ;; fake out future queries of -log - (debug:print-info 0 *default-log-port* "Sending log output to " logf) - (set! *default-log-port* oup))) + (handle-exceptions + exn + (begin + (print "ERROR: Failed to switch to log output. " ((conition-property-accessor 'exn 'message) exn)) + ) + (let* ((tl (or (args:get-arg "-log")(launch:setup))) ;; run launch:setup if -server + (logf (or (args:get-arg "-log") ;; use -log unless we are a server, then craft a logfile name + (conc tl "/logs/server-" (current-process-id) "-" (get-host-name) ".log"))) + (oup (open-logfile logf))) + (if (not (args:get-arg "-log")) + (hash-table-set! args:arg-hash "-log" logf)) ;; fake out future queries of -log + (debug:print-info 0 *default-log-port* "Sending log output to " logf) + (set! *default-log-port* oup)))) (if (or (args:get-arg "-h") (args:get-arg "-help") (args:get-arg "--help")) (begin