Overview
Comment: | Closer - and further away than ever. |
---|---|
Downloads: | Tarball | ZIP archive | SQL archive |
Timelines: | family | ancestors | descendants | both | v1.65-wip |
Files: | files | file ages | folders |
SHA1: |
f6d852ea5423899a904625e7ffb4afbd |
User & Date: | matt on 2019-10-04 00:50:12 |
Other Links: | branch diff | manifest | tags |
Context
2019-10-09
| ||
23:15 | Trimmed use of some globals. Removed use of mutex - nb// bit risky, unsure if there are consequences check-in: 1d3928260a user: mrwellan tags: v1.65-wip | |
2019-10-04
| ||
00:50 | Closer - and further away than ever. check-in: f6d852ea54 user: matt tags: v1.65-wip | |
2019-10-03
| ||
00:02 | Removed some of the member:print debug stuff check-in: 9b6c3193e6 user: matt tags: v1.65-wip | |
Changes
Modified common.scm from [91c6910f87] to [b059fdcd91].
︙ | ︙ | |||
268 269 270 271 272 273 274 | ((abort) "ABORT") ((skip) "SKIP") (else "FAIL"))) (define (common:logpro-exit-code->test-status exit-code) (status-sym->string (common:logpro-exit-code->status-sym exit-code))) | < < < < < < < < < < < < < | 268 269 270 271 272 273 274 275 276 277 278 279 280 281 | ((abort) "ABORT") ((skip) "SKIP") (else "FAIL"))) (define (common:logpro-exit-code->test-status exit-code) (status-sym->string (common:logpro-exit-code->status-sym exit-code))) ;; launching and hosts (defstruct host (reachable #f) (last-update 0) (last-used 0) (last-cpuload 1)) |
︙ | ︙ |
Modified common_records.scm from [72d272b34e] to [8ea3eb84a5].
︙ | ︙ | |||
15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 | ;; ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see <http://www.gnu.org/licenses/>. ;; ;;====================================================================== ;; (use trace) (include "altdb.scm") ;; Some of these routines use: ;; ;; http://www.cs.toronto.edu/~gfb/scheme/simple-macros.html ;; ;; Syntax for defining macros in a simple style similar to function definiton, ;; when there is a single pattern for the argument list and there are no keywords. | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 | ;; ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see <http://www.gnu.org/licenses/>. ;; ;;====================================================================== ;; (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 ;; ;; Syntax for defining macros in a simple style similar to function definiton, ;; when there is a single pattern for the argument list and there are no keywords. |
︙ | ︙ | |||
78 79 80 81 82 83 84 | (mutex-unlock! mtx) res)) ;; 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. ;; | | | | | 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 | (mutex-unlock! mtx) res)) ;; 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 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) (vstr (let ((debugvals (filter number? (map string->number (string-split vstr ","))))) (cond ((> (length debugvals) 1) debugvals) ((> (length debugvals) 0)(car debugvals)) (else 1)))) (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 (define (debug:check-verbosity verbosity vstr) (if (not (or (number? verbosity) |
︙ | ︙ | |||
119 120 121 122 123 124 125 | ((and (list? *verbosity*) ;; list list (list? n)) (not (null? (lset-intersection! eq? *verbosity* n)))) ((and (number? *verbosity*) (list? n)) (member *verbosity* n)))) | | | | | | | | | 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 | ((and (list? *verbosity*) ;; list list (list? n)) (not (null? (lset-intersection! eq? *verbosity* n)))) ((and (number? *verbosity*) (list? n)) (member *verbosity* n)))) (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 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* (exec-fn 'db:log-event (apply conc params)) (apply print params) ))))) ;; Brandon's debug printer shortcut (indulge me :) (define *BB-process-starttime* (current-milliseconds)) (define (BB> . in-args) (let* ((stack (get-call-chain)) |
︙ | ︙ | |||
216 217 218 219 220 221 222 | (define (debug:print-error n e . params) ;; normal print (if (debug:debug-mode n) (with-output-to-port (if (port? e) e (current-error-port)) (lambda () (if *logging* | | | | 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 | (define (debug:print-error n e . params) ;; normal print (if (debug:debug-mode n) (with-output-to-port (if (port? e) e (current-error-port)) (lambda () (if *logging* (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)))) (with-output-to-port (current-error-port) (lambda () (apply print "ERROR: " params) )))) (define (debug:print-info n e . params) (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)))) (exec-fn 'db:log-event res)) ;; (apply print "pid:" (current-process-id) " " "INFO: (" n ") " params) ;; res) (apply print "INFO: (" n ") " params) ;; res) ))))) ;; if a value is printable (i.e. string or number) return the value ;; else return an empty string (define-inline (printable val) (if (or (number? val)(string? val)) val "")) |
Modified dashboard.scm from [2679042d5f] to [df9da433e4].
︙ | ︙ | |||
509 510 511 512 513 514 515 | (if t-sort (cadr t-sort) 3))) (define (get-curr-sort) (vector-ref *tests-sort-options* *tests-sort-reverse*)) | | | 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 | (if t-sort (cadr t-sort) 3))) (define (get-curr-sort) (vector-ref *tests-sort-options* *tests-sort-reverse*)) (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)) (define-inline (dboard:uidat-get-header vec)(vector-ref vec 2)) (define-inline (dboard:uidat-get-runsvec vec)(vector-ref vec 3)) |
︙ | ︙ |
Modified db.scm from [5cbdd1ef19] to [15fede171d].
︙ | ︙ | |||
36 37 38 39 40 41 42 43 44 45 46 47 48 49 | (declare (uses client)) (declare (uses mt)) (include "common_records.scm") (include "db_records.scm") (include "key_records.scm") (include "run_records.scm") (define *rundb-mutex* (make-mutex)) ;; prevent problems opening/closing rundb's (define *number-of-writes* 0) (define *number-non-write-queries* 0) ;;====================================================================== ;; R E C O R D S | > > > > | 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 | (declare (uses client)) (declare (uses mt)) (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) ;;====================================================================== ;; R E C O R D S |
︙ | ︙ | |||
4748 4749 4750 4751 4752 4753 4754 | results) ;; brutal clean up (stack-push! (dbr:dbstruct-dbstack dbstruct) dbdat) (system "rm -rf tempdir"))) ;; (db:extract-ods-file db "outputfile.ods" '(("sysname" "%")("fsname" "%")("datapath" "%")) "%") | | > > | 4752 4753 4754 4755 4756 4757 4758 4759 4760 4761 | results) ;; brutal clean up (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) |
Modified megatest.scm from [86d6f690da] to [27452e8ba5].
︙ | ︙ | |||
606 607 608 609 610 611 612 | (exit 1)))) homehost-required)))) ;;====================================================================== ;; Misc setup stuff ;;====================================================================== | | | 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 | (exit 1)))) homehost-required)))) ;;====================================================================== ;; Misc setup stuff ;;====================================================================== (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)) (if (args:get-arg "-itempatt") |
︙ | ︙ |
Modified rmt.scm from [e244c9b139] to [c91853a277].
︙ | ︙ | |||
23 24 25 26 27 28 29 30 31 32 33 34 35 36 | (declare (unit rmt)) (declare (uses api)) (declare (uses http-transport)) (include "common_records.scm") (declare (uses rmtmod)) (import rmtmod) ;; ;; THESE ARE ALL CALLED ON THE CLIENT SIDE!!! ;; ;; generate entries for ~/.megatestrc with the following ;; | > > > | 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 | (declare (unit rmt)) (declare (uses api)) (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!!! ;; ;; generate entries for ~/.megatestrc with the following ;; |
︙ | ︙ | |||
863 864 865 866 867 868 869 | (set-functions rmt:send-receive remote-server-url-set! 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 | | | 866 867 868 869 870 871 872 873 874 | (set-functions rmt:send-receive remote-server-url-set! 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 #f #f api:execute-requests api:read-only-queries) |
Modified rmtmod.scm from [34866aceda] to [5d21778e4d].
︙ | ︙ | |||
21 22 23 24 25 26 27 | (declare (unit rmtmod)) (declare (uses commonmod)) (module rmtmod * (import scheme chicken data-structures extras) | | > > < < < < < < < < < < < | 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 | (declare (unit rmtmod)) (declare (uses commonmod)) (module rmtmod * (import scheme chicken data-structures extras) (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 (api:execute-requests . params) #f) (define (set-functions send-receive rsus close-connections rcs dbgp dbgpinfo dbgperr ro-mode ro-mode-set |
︙ | ︙ | |||
61 62 63 64 65 66 67 | (set! http-transport:close-connections close-connections) (set! remote-conndat-set! rcs) ;; print stuff (set! debug:print dbgp) (set! debug:print-info dbgpinfo) (set! debug:print-error dbgperr) ;; | < < < < < < | | | 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 | (set! http-transport:close-connections close-connections) (set! remote-conndat-set! rcs) ;; print stuff (set! debug:print dbgp) (set! debug:print-info dbgpinfo) (set! debug:print-error dbgperr) ;; ;; db stuff for local db access (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 (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.. exn ;; This is an attempt to detect that situation and recover gracefully (begin |
︙ | ︙ | |||
190 191 192 193 194 195 196 | (define (rmtmod:send-receive-ulex ulex:conn cmd rid params attemptnum area-dat) #f) (use trace)(trace-call-sites #t) | | | 175 176 177 178 179 180 181 182 183 184 | (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) ) |