Index: api.scm ================================================================== --- api.scm +++ api.scm @@ -279,18 +279,18 @@ ;; (define (api:process-request dbstruct $) ;; the $ is the request vars proc (set! *api-process-request-count* (+ *api-process-request-count* 1)) (let* ((cmd ($ 'cmd)) (paramsj ($ 'params)) - (params (db:string->obj paramsj transport: 'http)) ;; (rmt:json-str->dat paramsj)) + (params (db:string->obj paramsj transport: 'http)) ;; (rmt:json-str->dat area-dat paramsj)) (resdat (api:execute-requests dbstruct (vector cmd params))) ;; #( flag result ) (res (vector-ref resdat 1))) (if (> *api-process-request-count* *max-api-process-requests*) (set! *max-api-process-requests* *api-process-request-count*)) (set! *api-process-request-count* (- *api-process-request-count* 1)) ;; This can be here but needs controls to ensure it doesn't run more than every 4 seconds - ;; (rmt:dat->json-str + ;; (rmt:dat->json-str area-dat ;; (if (or (string? res) ;; (list? res) ;; (number? res) ;; (boolean? res)) ;; res Index: archive.scm ================================================================== --- archive.scm +++ archive.scm @@ -57,15 +57,15 @@ '()))) ;; look for the best candidate archive area, else create new ;; area ;; -(define (archive:get-archive testname itempath dused) +(define (archive:get-archive area-dat testname itempath dused) ;; look up in archive_allocations if there is a pre-used archive ;; with adequate diskspace ;; - (let* ((existing-blocks (rmt:archive-get-allocations testname itempath dused)) + (let* ((existing-blocks (rmt:archive-get-allocations area-dat testname itempath dused)) (candidate-disks (map (lambda (block) (list (vector-ref block 1) ;; archive-area-name (vector-ref block 2))) ;; disk-path existing-blocks))) @@ -72,25 +72,25 @@ (or (common:get-disk-with-most-free-space candidate-disks dused) (archive:allocate-new-archive-block #f #f #f)))) ;; BROKEN. testname itempath)))) ;; allocate a new archive area ;; -(define (archive:allocate-new-archive-block run-area-home testsuite-name dneeded) +(define (archive:allocate-new-archive-block area-dat run-area-home testsuite-name dneeded) (let* ((adisks (archive:get-archive-disks)) (best-disk (common:get-disk-with-most-free-space adisks dneeded))) (if best-disk (let* ((bdisk-name (car best-disk)) (bdisk-path (cdr best-disk)) (area-key (substring (message-digest-string (md5-primitive) run-area-home) 0 5)) - (bdisk-id (rmt:archive-register-disk bdisk-name bdisk-path (get-df bdisk-path))) + (bdisk-id (rmt:archive-register-disk area-dat bdisk-name bdisk-path (get-df bdisk-path))) (archive-name (let ((sec (current-seconds))) (conc (time->string (seconds->local-time sec) "%Y") "_q" (seconds->quarter sec) "/" testsuite-name "_" area-key))) (archive-path (conc bdisk-path "/" archive-name)) - (block-id (rmt:archive-register-block-name bdisk-id archive-path))) - ;; (allocation-id (rmt:archive-allocate-testsuite/area-to-block block-id testsuite-name area-key))) + (block-id (rmt:archive-register-block-name area-dat bdisk-id archive-path))) + ;; (allocation-id (rmt:archive-allocate-testsuite/area-to-block area-dat block-id testsuite-name area-key))) (if block-id ;; (and block-id allocation-id) (cons block-id archive-path) #f)) #f))) @@ -99,11 +99,11 @@ ;; 1. create the bup dir if not exists ;; 2. start the du of each directory ;; 3. gen index ;; 4. save ;; -(define (archive:run-bup archive-command run-id run-name tests rp-mutex bup-mutex) +(define (archive:run-bup area-dat archive-command run-id run-name tests rp-mutex bup-mutex) ;; move the getting of archive space down into the below block so that a single run can ;; allocate as needed should a disk fill up ;; (let* ((min-space (string->number (or (configf:lookup *configdat* "archive" "minspace") "1000"))) (archive-info (archive:allocate-new-archive-block *toppath* (common:get-testsuite-name) min-space)) @@ -129,14 +129,14 @@ (lambda (test-dat) (let* ((item-path (db:test-get-item-path test-dat)) (test-name (db:test-get-testname test-dat)) (test-id (db:test-get-id test-dat)) (run-id (db:test-get-run_id test-dat)) - (target (string-intersperse (map cadr (rmt:get-key-val-pairs run-id)) "/")) + (target (string-intersperse (map cadr (rmt:get-key-val-pairs area-dat run-id)) "/")) (toplevel/children (and (db:test-get-is-toplevel test-dat) - (> (rmt:test-toplevel-num-items run-id test-name) 0))) + (> (rmt:test-toplevel-num-items area-dat run-id test-name) 0))) (test-partial-path (conc target "/" run-name "/" (db:test-make-full-name test-name item-path))) ;; note the trailing slash to get the dir inspite of it being a link (test-path (conc linktree "/" test-partial-path)) (mutex-lock! rp-mutex) (test-physical-path (if (file-exists? test-path) @@ -171,11 +171,11 @@ ;; for each disk-group (for-each (lambda (disk-group) (debug:print 0 *default-log-port* "Processing disk-group " disk-group) (let* ((test-paths (hash-table-ref disk-groups disk-group)) - ;; ((string-intersperse (map cadr (rmt:get-key-val-pairs 1)) "-") + ;; ((string-intersperse (map cadr (rmt:get-key-val-pairs area-dat 1)) "-") (bup-init-params (list "-d" archive-dir "init")) (bup-index-params (append (list "-d" archive-dir "index") test-paths)) (bup-save-params (append (list "-d" archive-dir "save" ;; (conc "--strip-path=" linktree) (conc "-" compress) ;; or (conc "--compress=" compress) "-n" (conc (common:get-testsuite-name) "-" run-id) @@ -200,18 +200,18 @@ ;; (mutex-unlock! bup-mutex) (for-each (lambda (test-dat) (let ((test-id (db:test-get-id test-dat)) (run-id (db:test-get-run_id test-dat))) - (rmt:test-set-archive-block-id run-id test-id archive-id) + (rmt:test-set-archive-block-id area-dat run-id test-id archive-id) (if (member archive-command '("save-remove")) - (runs:remove-test-directory test-dat 'archive-remove)))) + (runs:remove-test-directory area-dat test-dat 'archive-remove)))) (hash-table-ref test-groups disk-group)))) (hash-table-keys disk-groups)) #t)) -(define (archive:bup-restore archive-command run-id run-name tests rp-mutex bup-mutex) ;; move the getting of archive space down into the below block so that a single run can +(define (archive:bup-restore area-dat archive-command run-id run-name tests rp-mutex bup-mutex) ;; move the getting of archive space down into the below block so that a single run can ;; allocate as needed should a disk fill up ;; (let* ((bup-exe (or (configf:lookup *configdat* "archive" "bup") "bup")) (linktree (configf:lookup *configdat* "setup" "linktree"))) @@ -223,15 +223,15 @@ (let* ((best-disk (get-best-disk *configdat* #f)) ;; BUG: get the testconfig and use it here. Otherwise data pulled out of archive could end up on the wrong kind of disk. (item-path (db:test-get-item-path test-dat)) (test-name (db:test-get-testname test-dat)) (test-id (db:test-get-id test-dat)) (run-id (db:test-get-run_id test-dat)) - (keyvals (rmt:get-key-val-pairs run-id)) + (keyvals (rmt:get-key-val-pairs area-dat run-id)) (target (string-intersperse (map cadr keyvals) "/")) (toplevel/children (and (db:test-get-is-toplevel test-dat) - (> (rmt:test-toplevel-num-items run-id test-name) 0))) + (> (rmt:test-toplevel-num-items area-dat run-id test-name) 0))) (test-partial-path (conc target "/" run-name "/" (db:test-make-full-name test-name item-path))) ;; note the trailing slash to get the dir inspite of it being a link (test-path (conc linktree "/" test-partial-path)) ;; if the old path was not deleted then prev-test-physical-path will end up pointing to a real directory (mutex-lock! rp-mutex) @@ -240,11 +240,11 @@ (common:real-path test-path) #f)) (mutex-unlock! rp-mutex) (new-test-physical-path (conc best-disk "/" test-partial-path)) (archive-block-id (db:test-get-archived test-dat)) - (archive-block-info (rmt:test-get-archive-block-info archive-block-id)) + (archive-block-info (rmt:test-get-archive-block-info area-dat archive-block-id)) (archive-path (if (vector? archive-block-info) (vector-ref archive-block-info 2) ;; look in db.scm for test-get-archive-block-info for the vector record info #f)) ;; no archive found? (archive-internal-path (conc (common:get-testsuite-name) "-" run-id "/latest/" test-partial-path))) @@ -272,11 +272,11 @@ ;; 3. Construct the paths etc. for the following command: ;; ;; bup -d /tmp/matt/adisk1/2015_q1/fullrun_e1a40/ restore -C /tmp/seeme fullrun-30/latest/ubuntu/nfs/none/w02.1.20.54_b/ ;; DO BUP RESTORE - (let* ((new-test-dat (rmt:get-test-info-by-id run-id test-id)) + (let* ((new-test-dat (rmt:get-test-info-by-id area-dat run-id test-id)) (new-test-path (if (vector? new-test-dat ) (db:test-get-rundir new-test-dat) (begin (debug:print-error 0 *default-log-port* "unable to get data for run-id=" run-id ", test-id=" test-id) (exit 1)))) Index: client.scm ================================================================== --- client.scm +++ client.scm @@ -67,13 +67,13 @@ ;; client:setup ;; ;; lookup_server, need to remove *runremote* stuff ;; -(define (client:setup-http areapath #!key (remaining-tries 100) (failed-connects 0)) +(define (client:setup-http area-dat areapath #!key (remaining-tries 100) (failed-connects 0)) (debug:print-info 2 *default-log-port* "client:setup remaining-tries=" remaining-tries) - (server:start-and-wait areapath) + (server:start-and-wait area-dat areapath) (if (<= remaining-tries 0) (begin (debug:print-error 0 *default-log-port* "failed to start or connect to server") (exit 1)) ;; @@ -89,11 +89,11 @@ (if (not *runremote*)(set! *runremote* (make-remote))) (if (and host port) (let* ((start-res (case *transport-type* ((http)(http-transport:client-connect host port)))) (ping-res (case *transport-type* - ((http)(rmt:login-no-auto-client-setup start-res))))) + ((http)(rmt:login-no-auto-client-setup area-dat start-res))))) (if (and start-res ping-res) (begin (remote-conndat-set! *runremote* start-res) ;; (hash-table-set! *runremote* run-id start-res) (debug:print-info 2 *default-log-port* "connected to " (http-transport:server-dat-make-url start-res)) @@ -108,8 +108,8 @@ ))) (begin ;; no server registered (server:kind-run areapath) (debug:print-info 0 *default-log-port* "client:setup, no server registered, remaining-tries=" remaining-tries) (thread-sleep! 1) ;; (+ 5 (random (- 20 remaining-tries)))) ;; give server a little time to start up, randomize a little to avoid start storms. - (server:start-and-wait areapath) + (server:start-and-wait area-dat areapath) (client:setup-http areapath remaining-tries: (- remaining-tries 1))))))))) Index: common.scm ================================================================== --- common.scm +++ common.scm @@ -141,11 +141,11 @@ (define *launch-setup-mutex* (make-mutex)) ;; need to be able to call launch:setup often so mutex it and re-call the real deal only if *toppath* not set (define *homehost-mutex* (make-mutex)) (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)) + (server-url #f) (last-server-check 0) ;; last time we checked to see if the server was alive (conndat #f) (transport *transport-type*) (server-timeout (or (server:get-timeout) 100))) ;; default to 100 seconds @@ -202,19 +202,19 @@ (define (common:version-signature) (conc megatest-version "-" (substring megatest-fossil-hash 0 4))) ;; from metadat lookup MEGATEST_VERSION ;; -(define (common:get-last-run-version) ;; RADT => How does this work in send-receive function??; assume it is the value saved in some DB - (rmt:get-var "MEGATEST_VERSION")) +(define (common:get-last-run-version area-dat) ;; RADT => How does this work in send-receive function??; assume it is the value saved in some DB + (rmt:get-var area-dat "MEGATEST_VERSION")) (define (common:get-last-run-version-number) (string->number (substring (common:get-last-run-version) 0 6))) -(define (common:set-last-run-version) - (rmt:set-var "MEGATEST_VERSION" (common:version-signature))) +(define (common:set-last-run-version area-dat) + (rmt:set-var area-dat "MEGATEST_VERSION" (common:version-signature))) (define (common:version-changed?) (not (equal? (common:get-last-run-version) (common:version-signature)))) @@ -650,21 +650,21 @@ (delay-loop (+ count 1)))) (if (not *time-to-exit*) (loop)))) (if (common:low-noise-print 30) (debug:print-info 0 *default-log-port* "Exiting watchdog timer, *time-to-exit* = " *time-to-exit*" pid="(current-process-id)" this-wd-num="this-wd-num))))))) -(define (std-exit-procedure) +(define (std-exit-procedure area-dat) (on-exit (lambda () 0)) ;;(BB> "std-exit-procedure called; *time-to-exit*="*time-to-exit*) (let ((no-hurry (if *time-to-exit* ;; hurry up #f (begin (set! *time-to-exit* #t) #t)))) (debug:print-info 4 *default-log-port* "starting exit process, finalizing databases.") (if (and no-hurry (debug:debug-mode 18)) - (rmt:print-db-stats)) + (rmt:print-db-stats area-dat)) (let ((th1 (make-thread (lambda () ;; thread for cleaning up, give it five seconds (if *dbstruct-db* (db:close-all *dbstruct-db*)) ;; one second allocated (if *task-db* (let ((db (cdr *task-db*))) (if (sqlite3:database? db) @@ -834,13 +834,13 @@ (or (args:get-arg "-state")(args:get-arg ":state"))) (define (common:args-get-status) (or (args:get-arg "-status")(args:get-arg ":status"))) -(define (common:args-get-testpatt rconf) +(define (common:args-get-testpatt area-dat rconf) (let* ((tagexpr (args:get-arg "-tagexpr")) - (tags-testpatt (if tagexpr (string-join (runs:get-tests-matching-tags tagexpr) ",") #f)) + (tags-testpatt (if tagexpr (string-join (runs:get-tests-matching-tags area-dat tagexpr) ",") #f)) (testpatt-key (if (args:get-arg "--modepatt") (args:get-arg "--modepatt") "TESTPATT")) (args-testpatt (or (args:get-arg "-testpatt") (args:get-arg "-runtests") "%")) (rtestpatt (if rconf (runconfigs-get rconf testpatt-key) #f))) (cond (tags-testpatt @@ -1230,12 +1230,12 @@ ;; ideally put all this info into the db, no need to preserve it across moving homehost ;; ;; return list of ;; ( reachable? cpuload update-time ) -(define (common:get-host-info hostname) - (let* ((loadinfo (rmt:get-latest-host-load hostname)) +(define (common:get-host-info hostname area-dat) + (let* ((loadinfo (rmt:get-latest-host-load area-dat hostname)) (load (car loadinfo)) (load-sample-time (cdr loadinfo)) (load-sample-age (- (current-seconds) load-sample-time)) (loadinfo-timeout-seconds 20) (host-last-update-timeout-seconds 10) Index: dashboard-tests.scm ================================================================== --- dashboard-tests.scm +++ dashboard-tests.scm @@ -156,13 +156,13 @@ ;;====================================================================== ;; Run info panel ;;====================================================================== -(define (run-info-panel db keydat testdat runname) +(define (run-info-panel db area-dat keydat testdat runname) (let* ((run-id (db:test-get-run_id testdat)) - (rundat (rmt:get-run-info run-id)) + (rundat (rmt:get-run-info area-dat run-id)) (header (db:get-header rundat)) (event_time (db:get-value-by-header (db:get-rows rundat) (db:get-header rundat) "event_time"))) (iup:frame @@ -261,24 +261,24 @@ (define *dashboard-comment-share-slot* #f) ;;====================================================================== ;; Set fields ;;====================================================================== -(define (set-fields-panel dbstruct run-id test-id testdat #!key (db #f)) +(define (set-fields-panel area-dat run-id test-id testdat #!key (db #f)) (let ((newcomment #f) (newstatus #f) (newstate #f) (wtxtbox #f)) (iup:frame #:title "Set fields" (iup:vbox (iup:hbox (iup:label "Comment:") (let ((txtbox (iup:textbox #:action (lambda (val a b) - ;; (rmt:test-set-state-status-by-id run-id test-id #f #f b) - (rmt:test-set-state-status run-id test-id #f #f b) + ;; (rmt:test-set-state-status-by-id area-dat run-id test-id #f #f b) + (rmt:test-set-state-status area-dat run-id test-id #f #f b) ;; IDEA: Just set a variable with the proc to call? - ;; (rmt:test-set-state-status-by-id run-id test-id #f #f b) + ;; (rmt:test-set-state-status-by-id area-dat run-id test-id #f #f b) (set! newcomment b)) #:value (db:test-get-comment testdat) #:expand "HORIZONTAL"))) (set! wtxtbox txtbox) txtbox)) @@ -287,12 +287,12 @@ (iup:label "STATE:" #:size "30x") (let* ((btns (map (lambda (state) (let ((btn (iup:button state #:expand "HORIZONTAL" #:size "50x" #:font "Courier New, -10" #:action (lambda (x) - ;; (rmt:test-set-state-status-by-id run-id test-id state #f #f) - (rmt:set-state-status-and-roll-up-items run-id test-id #f state #f #f) ;; test-name passed in as test-id is respected + ;; (rmt:test-set-state-status-by-id area-dat run-id test-id state #f #f) + (rmt:set-state-status-and-roll-up-items area-dat run-id test-id #f state #f #f) ;; test-name passed in as test-id is respected (db:test-set-state! testdat state))))) btn)) (map cadr *common:std-states*)))) ;; (list "COMPLETED" "NOT_STARTED" "RUNNING" "REMOTEHOSTSTART" "LAUNCHED" "KILLED" "KILLREQ")))) (vector-set! *state-status* 0 (lambda (state color) @@ -321,12 +321,12 @@ (iup:attribute-set! wtxtbox "VALUE" c) (if (not *dashboard-comment-share-slot*) (set! *dashboard-comment-share-slot* wtxtbox))) )))) (begin - ;; (rmt:test-set-state-status-by-id run-id test-id #f status #f) - (rmt:set-state-status-and-roll-up-items run-id test-id #f #f status #f) ;; test-name passed in as test-id is respected + ;; (rmt:test-set-state-status-by-id area-dat run-id test-id #f status #f) + (rmt:set-state-status-and-roll-up-items area-dat run-id test-id #f #f status #f) ;; test-name passed in as test-id is respected (db:test-set-status! testdat status)))))))) btn)) (map cadr *common:std-statuses*)))) ;; (list "PASS" "WARN" "FAIL" "CHECK" "n/a" "WAIVED" "SKIP")))) (vector-set! *state-status* 1 (lambda (status color) @@ -371,11 +371,11 @@ ;; #:expand "HORIZONTAL" ;; #:action (lambda (obj) ;; (print "Refresh test data " stepname)) ))) -(define (dashboard-tests:waiver run-id testdat ovrdval cmtcmd) +(define (dashboard-tests:waiver area-dat run-id testdat ovrdval cmtcmd) (let* ((wpatt (configf:lookup *configdat* "setup" "waivercommentpatt")) (wregx (if (string? wpatt)(regexp wpatt) #f)) (wmesg (iup:label (if wpatt (conc "Comment must match pattern " wpatt) ""))) (comnt (iup:textbox #:action (lambda (val a b) (if wpatt @@ -403,12 +403,12 @@ (let ((comment (iup:attribute comnt "VALUE")) (test-id (db:test-get-id testdat))) (if (or (not wpatt) (string-match wregx comment)) (begin - ;; (rmt:test-set-state-status-by-id run-id test-id #f "WAIVED" comment) - (rmt:test-set-state-status-by run-id test-id #f "WAIVED" comment) + ;; (rmt:test-set-state-status-by-id area-dat run-id test-id #f "WAIVED" comment) + (rmt:test-set-state-status-by area-dat run-id test-id #f "WAIVED" comment) (db:test-set-status! testdat "WAIVED") (cmtcmd comment) (iup:destroy! dlog)))))) (iup:button "Cancel" #:expand "HORIZONTAL" @@ -418,43 +418,42 @@ ;;====================================================================== ;; ;;====================================================================== -(define (dashboard-tests:examine-test run-id test-id) ;; run-id run-key origtest) +(define (dashboard-tests:examine-test area-dat run-id test-id) ;; run-id run-key origtest) (let* ((db-path (db:dbfile-path)) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/db/" run-id ".db")) (dbstruct #f) ;; NOT ACTUALLY USED (db:setup)) ;; (make-dbr:dbstruct path: (db:dbfile-path #f) ;; (configf:lookup *configdat* "setup" "linktree") ;; local: #t)) - (testdat (rmt:get-test-info-by-id run-id test-id)) ;; (db:get-test-info-by-id dbstruct run-id test-id)) + (testdat (rmt:get-test-info-by-id area-dat run-id test-id)) ;; (db:get-test-info-by-id dbstruct run-id test-id)) (db-mod-time 0) ;; (file-modification-time db-path)) (last-update 0) ;; (current-seconds)) (request-update #t)) (if (not testdat) (begin (debug:print 2 *default-log-port* "ERROR: No test data found for test " test-id ", exiting") (exit 1)) (let* (;; (run-id (if testdat (db:test-get-run_id testdat) #f)) (test-registry (tests:get-all)) - (keydat (if testdat (rmt:get-key-val-pairs run-id) #f)) - (rundat (if testdat (rmt:get-run-info run-id) #f)) + (keydat (if testdat (rmt:get-key-val-pairs area-dat run-id) #f)) + (rundat (if testdat (rmt:get-run-info area-dat run-id) #f)) (runname (if testdat (db:get-value-by-header (db:get-rows rundat) (db:get-header rundat) "runname") #f)) - ;; (tdb (tdb:open-test-db-by-test-id-local dbstruct run-id test-id)) ;; These next two are intentional bad values to ensure errors if they should not ;; get filled in properly. (logfile "/this/dir/better/not/exist") (rundir (if testdat (db:test-get-rundir testdat) logfile)) ;; (testdat-path (conc rundir "/testdat.db")) ;; this gets recalculated until found - (teststeps (if testdat (tests:get-compressed-steps run-id test-id) '())) + (teststeps (if testdat (tests:get-compressed-steps area-dat run-id test-id) '())) (testfullname (if testdat (db:test-get-fullname testdat) "Gathering data ...")) (testname (if testdat (db:test-get-testname testdat) "n/a")) ;; (tests:get-testconfig testdat testname 'return-procs)) (testmeta (if testdat - (let ((tm (rmt:testmeta-get-record testname))) + (let ((tm (rmt:testmeta-get-record area-dat testname))) (if tm tm (make-db:testmeta))) (make-db:testmeta))) (keystring (string-intersperse (map (lambda (keyval) @@ -472,11 +471,11 @@ #f ;; do nothing, just keep on trucking .... (setup-env-defaults runconfigf run-id (make-hash-table) keydat environ-patt: keystring)) (make-hash-table)))) (testconfig (begin ;; (runs:set-megatest-env-vars run-id inrunname: runname testname: test-name itempath: item-path) - (runs:set-megatest-env-vars run-id inkeyvals: keydat inrunname: runname intarget: keystring testname: testname itempath: item-path) ;; these may be needed by the launching process + (runs:set-megatest-env-vars area-dat run-id inkeyvals: keydat inrunname: runname intarget: keystring testname: testname itempath: item-path) ;; these may be needed by the launching process (handle-exceptions exn (tests:get-testconfig (db:test-get-testname testdat) (db:test-get-item-path testdat) test-registry #f) (tests:get-testconfig (db:test-get-testname testdat) test-registry #t)))) (viewlog (lambda (x) @@ -516,16 +515,16 @@ (newtestdat (if need-update ;; NOTE: BUG HIDER, try to eliminate this exception handler (handle-exceptions exn (debug:print-info 0 *default-log-port* "test db access issue in examine test for run-id " run-id ", test-id " test-id ": " ((condition-property-accessor 'exn 'message) exn)) - (rmt:get-test-info-by-id run-id test-id ))))) + (rmt:get-test-info-by-id area-dat run-id test-id ))))) ;; (print "INFO: need-update= " need-update " curr-mod-time = " curr-mod-time) (cond ((and need-update newtestdat) (set! testdat newtestdat) - (set! teststeps (tests:get-compressed-steps run-id test-id)) + (set! teststeps (tests:get-compressed-steps area-dat run-id test-id)) (set! logfile (conc (db:test-get-rundir testdat) "/" (db:test-get-final_logf testdat))) (set! rundir ;; (filedb:get-path *fdb* (db:test-get-rundir testdat)) ;; ) (set! testfullname (db:test-get-fullname testdat)) ;; (debug:print 0 *default-log-port* "INFO: teststeps=" (intersperse teststeps "\n ")) @@ -758,11 +757,11 @@ (db:test-data-get-tol x) (db:test-data-get-status x) (db:test-data-get-units x) (db:test-data-get-type x) (db:test-data-get-comment x))) - (rmt:read-test-data run-id test-id "%"))) + (rmt:read-test-data area-dat run-id test-id "%"))) "\n"))) (if (not (equal? currval newval)) (iup:attribute-set! test-data "VALUE" newval ))))) ;; "TITLE" newval))))) test-data)) ;;(dashboard:run-controls) Index: dashboard.scm ================================================================== --- dashboard.scm +++ dashboard.scm @@ -130,10 +130,11 @@ update-mutex updaters updating uidat ;; needs to move to tabdat at some time hide-not-hide-tabs + (area-dat (make-remote)) ) (define (dboard:commondat-make) (make-dboard:commondat curr-tab-num: 0 @@ -322,21 +323,21 @@ (let ((dat (make-dboard:tabdat))) (dboard:setup-tabdat dat) (dboard:setup-num-rows dat) dat)) -(define (dboard:setup-tabdat tabdat) +(define (dboard:setup-tabdat tabdat area-dat) (dboard:tabdat-dbdir-set! tabdat (db:dbfile-path)) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/.db")) (dboard:tabdat-dbfpath-set! tabdat (db:dbfile-path)) (dboard:tabdat-monitor-db-path-set! tabdat (conc (dboard:tabdat-dbdir tabdat) "/monitor.db")) ;; HACK ALERT: this is a hack, please fix. (dboard:tabdat-ro-set! tabdat (not (file-read-access? (dboard:tabdat-dbfpath tabdat)))) (dboard:tabdat-keys-set! tabdat (db:dispatch-query (db:get-access-mode) rmt:get-keys db:get-keys)) (dboard:tabdat-dbkeys-set! tabdat (append (dboard:tabdat-keys tabdat) (list "runname"))) - (dboard:tabdat-tot-runs-set! tabdat (rmt:get-num-runs "%")) + (dboard:tabdat-tot-runs-set! tabdat (rmt:get-num-runs area-dat "%")) ) ;; RADT => Matrix defstruct addition (defstruct dboard:graph-dat ((id #f) : string) @@ -630,19 +631,21 @@ ;; this calls dboard:get-tests-for-run-duplicate for each run ;; ;; create a virtual table of all the tests ;; keypatts: ( (KEY1 "abc%def")(KEY2 "%") ) ;; -(define (update-rundat tabdat runnamepatt numruns testnamepatt keypatts) +(define (update-rundat tabdat area-dat runnamepatt numruns testnamepatt keypatts) (let* ((access-mode (dboard:tabdat-access-mode tabdat)) - (keys (db:dispatch-query access-mode rmt:get-keys db:get-keys)) + (keys ;; (db:dispatch-query access-mode rmt:get-keys db:get-keys)) + (rmt:get-keys area-dat)) (last-runs-update (- (dboard:tabdat-last-runs-update tabdat) 2)) - (allruns (db:dispatch-query access-mode rmt:get-runs db:get-runs - runnamepatt numruns (dboard:tabdat-start-run-offset tabdat) keypatts)) - ;;(allruns-tree (rmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f)) - (allruns-tree (db:dispatch-query access-mode rmt:get-runs-by-patt db:get-runs-by-patt - keys "%" #f #f #f #f last-runs-update));;'("id" "runname") + (allruns (rmt:get-runs area-dat runnamepatt numruns (dboard:tabdat-start-run-offset tabdat) keypatts)) + ;; (db:dispatch-query access-mode rmt:get-runs db:get-runs + ;; runnamepatt numruns (dboard:tabdat-start-run-offset tabdat) keypatts)) + (allruns-tree (rmt:get-runs-by-patt area-dat keys "%" #f #f #f #f)) + ;; (allruns-tree (db:dispatch-query access-mode rmt:get-runs-by-patt db:get-runs-by-patt + ;; keys "%" #f #f #f #f last-runs-update));;'("id" "runname") (header (db:get-header allruns)) (runs (db:get-rows allruns)) ;; RA => Filtered as per runpatt selected (runs-tree (db:get-rows allruns-tree)) ;; RA => Returns complete list of runs (start-time (current-seconds)) (runs-hash (let ((ht (make-hash-table))) @@ -669,11 +672,11 @@ (res '()) (maxtests 0)) (let* ((run-id (db:get-value-by-header run header "id")) (run-struct (hash-table-ref/default (dboard:tabdat-allruns-by-id tabdat) run-id #f)) (last-update (if run-struct (dboard:rundat-last-update run-struct) 0)) - (key-vals (rmt:get-key-vals run-id)) + (key-vals (rmt:get-key-vals area-dat run-id)) (tests-ht (dboard:get-tests-for-run-duplicate tabdat run-id run testnamepatt key-vals)) ;; GET RID OF dboard:get-tests-dat - it is superceded by dboard:get-tests-for-run-duplicate ;; dboard:get-tests-for-run-duplicate - returns a hash table ;; (dboard:get-tests-dat tabdat run-id last-update)) (all-test-ids (hash-table-keys tests-ht)) @@ -711,19 +714,19 @@ ;; this calls dboard:get-tests-for-run-duplicate for each run ;; ;; create a virtual table of all the tests ;; keypatts: ( (KEY1 "abc%def")(KEY2 "%") ) ;; -(define (dboard:update-rundat tabdat runnamepatt numruns testnamepatt keypatts) +(define (dboard:update-rundat tabdat area-dat runnamepatt numruns testnamepatt keypatts) (let* ((access-mode (dboard:tabdat-access-mode tabdat)) (keys (dboard:tabdat-keys tabdat)) ;; (db:dispatch-query access-mode rmt:get-keys db:get-keys))) (last-runs-update (- (dboard:tabdat-last-runs-update tabdat) 2)) (allruns (db:dispatch-query access-mode rmt:get-runs db:get-runs runnamepatt numruns (dboard:tabdat-start-run-offset tabdat) keypatts)) - ;;(allruns-tree (rmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f)) - (allruns-tree (db:dispatch-query access-mode rmt:get-runs-by-patt db:get-runs-by-patt - keys "%" #f #f #f #f 0)) ;; last-runs-update));;'("id" "runname") + (allruns-tree (rmt:get-runs-by-patt area-dat keys "%" #f #f #f #f)) + ;; (allruns-tree (db:dispatch-query access-mode rmt:get-runs-by-patt db:get-runs-by-patt + ;; keys "%" #f #f #f #f 0)) ;; last-runs-update));;'("id" "runname") (header (db:get-header allruns)) (runs (db:get-rows allruns)) ;; RA => Filtered as per runpatt selected (runs-tree (db:get-rows allruns-tree)) ;; RA => Returns complete list of runs (start-time (current-seconds)) (runs-hash (let ((ht (make-hash-table))) @@ -748,11 +751,11 @@ (res '()) (maxtests 0)) (let* ((run-id (db:get-value-by-header run header "id")) (run-struct (hash-table-ref/default (dboard:tabdat-allruns-by-id tabdat) run-id #f)) ;; (last-update (if run-struct (dboard:rundat-last-update run-struct) 0)) - (key-vals (rmt:get-key-vals run-id)) + (key-vals (rmt:get-key-vals area-dat run-id)) (tests-ht (dboard:get-tests-for-run-duplicate tabdat run-id run testnamepatt key-vals)) ;; GET RID OF dboard:get-tests-dat - it is superceded by dboard:get-tests-for-run-duplicate ;; dboard:get-tests-for-run-duplicate - returns a hash table ;; (dboard:get-tests-dat tabdat run-id last-update)) (all-test-ids (hash-table-keys tests-ht)) @@ -1131,11 +1134,11 @@ newval)))))) (define (dashboard:update-target-selector tabdat #!key (action-proc #f)) (let* ((runconf-targs (common:get-runconfig-targets)) (key-lbs (dboard:tabdat-key-listboxes tabdat)) - (db-target-dat (rmt:get-targets)) + (db-target-dat (rmt:get-targets area-dat)) (header (vector-ref db-target-dat 0)) (db-targets (vector-ref db-target-dat 1)) (munge-target (lambda (x) ;; create a target vector from a string. Pad with na if needed. (list->vector (take (append (string-split x "/") @@ -1304,11 +1307,11 @@ ;; used by run-controls ;; (define (dashboard:update-tree-selector tabdat #!key (action-proc #f)) (let* ((tb (dboard:tabdat-runs-tree tabdat)) (runconf-targs (common:get-runconfig-targets)) - (db-target-dat (rmt:get-targets)) + (db-target-dat (rmt:get-targets area-dat)) (runs-tree-ht (dboard:tabdat-runs-tree-ht tabdat)) (header (vector-ref db-target-dat 0)) (db-targets (vector-ref db-target-dat 1)) (munge-target (lambda (x) ;; create a target vector from a string. Pad with na if needed. (take (append (string-split x "/") @@ -1634,11 +1637,11 @@ (let ((res (assoc name lst))) (if (and res (> (length res) 1)) (cadr res) #f))) -(define (dboard:update-tree tabdat runs-hash runs-header tb) +(define (dboard:update-tree tabdat area-dat runs-hash runs-header tb) (let* ((access-mode (dboard:tabdat-access-mode tabdat)) (run-ids (sort (filter number? (hash-table-keys runs-hash)) (lambda (a b) (let* ((record-a (hash-table-ref runs-hash a)) (record-b (hash-table-ref runs-hash b)) @@ -1645,12 +1648,13 @@ (time-a (db:get-value-by-header record-a runs-header "event_time")) (time-b (db:get-value-by-header record-b runs-header "event_time"))) (< time-a time-b))))) (changed #f) (last-runs-update (dboard:tabdat-last-runs-update tabdat)) - (runs-dat (db:dispatch-query access-mode rmt:get-runs-by-patt db:get-runs-by-patt - (dboard:tabdat-keys tabdat) "%" #f #f #f #f last-runs-update))) + (runs-dat (rmt:get-runs-by-patt area-dat (dboard:tabdat-keys tabdat) "%" #f #f #f #f last-runs-update))) + ;; (db:dispatch-query access-mode rmt:get-runs-by-patt db:get-runs-by-patt + ;; (dboard:tabdat-keys tabdat) "%" #f #f #f #f last-runs-update))) (dboard:tabdat-last-runs-update-set! tabdat (- (current-seconds) 2)) (for-each (lambda (run-id) (let* ((run-record (hash-table-ref/default runs-hash run-id #f)) (key-vals (map (lambda (key)(db:get-value-by-header run-record runs-header key)) (dboard:tabdat-keys tabdat))) @@ -1689,11 +1693,11 @@ (else #f))))))) (define (dashboard:run-id->tests-mindat run-id tabdat runs-hash) (let* ((run (hash-table-ref/default runs-hash run-id #f)) - (key-vals (rmt:get-key-vals run-id)) + (key-vals (rmt:get-key-vals area-dat run-id)) (testnamepatt (or (dboard:tabdat-test-patts tabdat) "%/%")) (tests-ht (dboard:get-tests-for-run-duplicate tabdat run-id run testnamepatt key-vals)) (tests-dat (dashboard:tests-ht->tests-dat tests-ht)) (tests-mindat (dcommon:minimize-test-data tests-dat))) ;; reduces data for display (dboard:tabdat-last-runs-update-set! tabdat (- (current-seconds) 2)) @@ -1714,15 +1718,16 @@ (dashboard:run-id->tests-mindat dest-run-id tabdat runs-hash) hide-clean: hide-clean) #f))) -(define (dashboard:get-runs-hash tabdat) +(define (dashboard:get-runs-hash tabdat area-dat) (let* ((access-mode (dboard:tabdat-access-mode tabdat)) (last-runs-update 0);;(dboard:tabdat-last-runs-update tabdat)) - (runs-dat (db:dispatch-query access-mode rmt:get-runs-by-patt db:get-runs-by-patt - (dboard:tabdat-keys tabdat) "%" #f #f #f #f last-runs-update)) + (runs-dat (rmt:get-runs-by-patt area-dat (dboard:tabdat-keys tabdat) "%" #f #f #f #f last-runs-update)) + ;; (db:dispatch-query access-mode rmt:get-runs-by-patt db:get-runs-by-patt + ;; (dboard:tabdat-keys tabdat) "%" #f #f #f #f last-runs-update)) (runs-header (vector-ref runs-dat 0)) ;; 0 is header, 1 is list of records (runs (vector-ref runs-dat 1)) (run-id (dboard:tabdat-curr-run-id tabdat)) (runs-hash (let ((ht (make-hash-table))) (for-each (lambda (run) @@ -1733,14 +1738,14 @@ (define (dashboard:runs-summary-updater commondat tabdat tb cell-lookup run-matrix) ;; (if (dashboard:database-changed? commondat tabdat context-key: 'runs-summary-rundat) (dashboard:do-update-rundat tabdat) ;; ) (dboard:runs-summary-control-panel-updater tabdat) - (let* ((last-runs-update (dboard:tabdat-last-runs-update tabdat)) - (runs-dat (db:dispatch-query (dboard:tabdat-access-mode tabdat) - rmt:get-runs-by-patt db:get-runs-by-patt - (dboard:tabdat-keys tabdat) "%" #f #f #f #f last-runs-update)) + (let* ((area-dat (dboard:commondat-area-dat commondat)) + (last-runs-update (dboard:tabdat-last-runs-update tabdat)) + (runs-dat ;; (db:dispatch-query (dboard:tabdat-access-mode tabdat) + (rmt:get-runs-by-patt area-dat (dboard:tabdat-keys tabdat) "%" #f #f #f #f last-runs-update)) (runs-header (vector-ref runs-dat 0)) ;; 0 is header, 1 is list of records (runs (vector-ref runs-dat 1)) (run-id (dboard:tabdat-curr-run-id tabdat)) (runs-hash (dashboard:get-runs-hash tabdat)) ;; (runs-hash (let ((ht (make-hash-table))) @@ -1960,24 +1965,24 @@ (if (eq? this-mode current-mode) (iup:attribute-set! this-button "BGCOLOR" sel-color) (iup:attribute-set! this-button "BGCOLOR" nonsel-color)) (loop (cdr buttons-left) (cdr modes-left)))))) -(define (dboard:runs-summary-xor-labels-updater tabdat) +(define (dboard:runs-summary-xor-labels-updater tabdat area-dat) (let ((source-runname-label (dboard:tabdat-runs-summary-source-runname-label tabdat)) (dest-runname-label (dboard:tabdat-runs-summary-dest-runname-label tabdat)) (mode (dboard:tabdat-runs-summary-mode tabdat))) (when (and source-runname-label dest-runname-label) (case mode ((xor-two-runs xor-two-runs-hide-clean) (let* ((curr-run-id (dboard:tabdat-curr-run-id tabdat)) (prev-run-id (dboard:tabdat-prev-run-id tabdat)) (curr-runname (if curr-run-id - (rmt:get-run-name-from-id curr-run-id) + (rmt:get-run-name-from-id area-dat curr-run-id) "None")) (prev-runname (if prev-run-id - (rmt:get-run-name-from-id prev-run-id) + (rmt:get-run-name-from-id area-dat prev-run-id) "None"))) (iup:attribute-set! source-runname-label "TITLE" (conc " SRC: "prev-runname" ")) (iup:attribute-set! dest-runname-label "TITLE" (conc "DEST: "curr-runname" ")))) (else (iup:attribute-set! source-runname-label "TITLE" "") @@ -2035,10 +2040,11 @@ ;; This is the Run Summary tab ;; (define (dashboard:runs-summary commondat tabdat #!key (tab-num #f)) (let* ((update-mutex (dboard:commondat-update-mutex commondat)) + (area-dat (dboard:commondat-area-dat commondat)) (tb (iup:treebox #:value 0 #:name "Runs" #:expand "YES" #:addexpanded "NO" @@ -2081,23 +2087,23 @@ ;; status is corrupted on Brandon's home machine. will have to wait until after shutdown to see if it is still broken in PDX SLES (let* ((toolpath (car (argv))) (key (conc lin ":" col)) (test-id (hash-table-ref/default cell-lookup key -1)) (run-id (dboard:tabdat-curr-run-id tabdat)) - (run-info (rmt:get-run-info run-id)) - (target (rmt:get-target run-id)) + (run-info (rmt:get-run-info area-dat run-id)) + (target (rmt:get-target area-dat run-id)) (runname (db:get-value-by-header (db:get-rows run-info) (db:get-header run-info) "runname")) - (test-name (db:test-get-testname (rmt:get-test-info-by-id run-id test-id))) - (testpatt (let ((tlast (rmt:tasks-get-last target runname))) + (test-name (db:test-get-testname (rmt:get-test-info-by-id area-dat run-id test-id))) + (testpatt (let ((tlast (rmt:tasks-get-last area-dat target runname))) (if tlast (let ((tpatt (tasks:task-get-testpatt tlast))) (if (member tpatt '("0" 0)) ;; known bad historical value - remove in 2017 "%" tpatt)) "%"))) - (item-path (db:test-get-item-path (rmt:get-test-info-by-id run-id test-id))) + (item-path (db:test-get-item-path (rmt:get-test-info-by-id area-dat run-id test-id))) (item-test-path (conc test-name "/" (if (equal? item-path "") "%" item-path))) (status-chars (char-set->list (string->char-set status))) (testpanel-cmd (conc toolpath " -test " (dboard:tabdat-curr-run-id tabdat) "," test-id " &"))) @@ -2334,11 +2340,11 @@ (iup:menu-item (conc "Kill " item-test-path) #:action (lambda (obj) - ;; (rmt:test-set-state-status-by-id run-id test-id "KILLREQ" #f #f) + ;; (rmt:test-set-state-status-by-id area-dat run-id test-id "KILLREQ" #f #f) (common:run-a-command (conc "megatest -set-state-status KILLREQ,n/a -target " target " -runname " runname " -testpatt " item-test-path " -state RUNNING,REMOTEHOSTSTART,LAUNCHED")))) @@ -2398,11 +2404,11 @@ " -preclean -clean-cache")))) (iup:menu-item (conc "Kill " item-test-path) #:action (lambda (obj) - ;; (rmt:test-set-state-status-by-id run-id test-id "KILLREQ" #f #f) + ;; (rmt:test-set-state-status-by-id area-dat run-id test-id "KILLREQ" #f #f) (common:run-a-command (conc "megatest -set-state-status KILLREQ,n/a -target " target " -runname " runname " -testpatt " item-test-path " -state RUNNING,REMOTEHOSTSTART,LAUNCHED")))) @@ -2459,11 +2465,12 @@ (bdylst '()) (result '()) (i 0) (btn-height (dboard:tabdat-runs-btn-height runs-dat)) (btn-fontsz (dboard:tabdat-runs-btn-fontsz runs-dat)) - (cell-width (dboard:tabdat-runs-cell-width runs-dat))) + (cell-width (dboard:tabdat-runs-cell-width runs-dat)) + (area-dat (dboard:commondat-area-dat commondat))) ;; controls (along bottom) ;; (set! controls (dboard:make-controls commondat runs-dat)) ;; create the left most column for the run key names and the test names (set! lftlst (list (iup:hbox @@ -2554,23 +2561,23 @@ (if (eq? pressed 1) (let* ((toolpath (car (argv))) (buttndat (hash-table-ref (dboard:tabdat-buttondat runs-dat) button-key)) (test-id (db:test-get-id (vector-ref buttndat 3))) (run-id (db:test-get-run_id (vector-ref buttndat 3))) - (run-info (rmt:get-run-info run-id)) - (target (rmt:get-target run-id)) + (run-info (rmt:get-run-info area-dat run-id)) + (target (rmt:get-target area-dat run-id)) (runname (db:get-value-by-header (db:get-rows run-info) (db:get-header run-info) "runname")) - (test-name (db:test-get-testname (rmt:get-test-info-by-id run-id test-id))) - (testpatt (let ((tlast (rmt:tasks-get-last target runname))) + (test-name (db:test-get-testname (rmt:get-test-info-by-id area-dat run-id test-id))) + (testpatt (let ((tlast (rmt:tasks-get-last area-dat target runname))) (if tlast (let ((tpatt (tasks:task-get-testpatt tlast))) (if (member tpatt '("0" 0)) ;; known bad historical value - remove in 2017 "%" tpatt)) "%"))) - (item-path (db:test-get-item-path (rmt:get-test-info-by-id run-id test-id))) + (item-path (db:test-get-item-path (rmt:get-test-info-by-id area-dat run-id test-id))) (item-test-path (conc test-name "/" (if (equal? item-path "") "%" item-path)))) (iup:show (dashboard:popup-menu run-id test-id target runname test-name testpatt item-test-path) ;; popup-menu #:x 'mouse @@ -2851,14 +2858,14 @@ ;; run times tab data updater ;; (define (dashboard:run-times-tab-run-data-updater commondat tabdat tab-num) (let* ((access-mode (dboard:tabdat-access-mode tabdat)) + (area-dat (dboard:commondat-area-dat commondat)) (last-runs-update (dboard:tabdat-last-runs-update tabdat)) - (runs-dat (db:dispatch-query access-mode - rmt:get-runs-by-patt db:get-runs-by-patt - (dboard:tabdat-keys tabdat) "%" #f #f #f #f last-runs-update)) + (runs-dat ;; (db:dispatch-query access-mode + (rmt:get-runs-by-patt area-dat (dboard:tabdat-keys tabdat) "%" #f #f #f #f last-runs-update)) (runs-header (vector-ref runs-dat 0)) ;; 0 is header, 1 is list of records (runs-hash (let ((ht (make-hash-table))) (for-each (lambda (run) (hash-table-set! ht (db:get-value-by-header run runs-header "id") run)) (vector-ref runs-dat 1)) Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -2276,13 +2276,13 @@ thekey)) ;; Get run-ids for runs with same target but different runnames and NOT run-id ;; (define (db:get-prev-run-ids dbstruct run-id) - (let* ((keyvals (rmt:get-key-val-pairs run-id)) + (let* ((keyvals (db:get-key-val-pairs dbstruct run-id)) (kvalues (map cadr keyvals)) - (keys (rmt:get-keys)) + (keys (db:get-keys dbstruct)) (qrystr (string-intersperse (map (lambda (x)(conc x "=?")) keys) " AND "))) (let ((prev-run-ids '())) (if (null? keyvals) '() (begin Index: dcommon.scm ================================================================== --- dcommon.scm +++ dcommon.scm @@ -85,11 +85,11 @@ ;; 3. Add extraction of filters to synchash calls ;; ;; NOTE: Used in newdashboard ;; ;; Mode is 'full or 'incremental for full refresh or incremental refresh -(define (dcommon:run-update keys data runname keypatts testpatt states statuses mode window-id) +(define (dcommon:run-update area-dat keys data runname keypatts testpatt states statuses mode window-id) (let* (;; count and offset => #f so not used ;; the synchash calls modify the "data" hash (changed #f) (get-runs-sig (conc (client:get-signature) " get-runs")) (get-tests-sig (conc (client:get-signature) " get-tests")) @@ -96,23 +96,23 @@ (get-details-sig (conc (client:get-signature) " get-test-details")) ;; test-ids to get and display are indexed on window-id in curr-test-ids hash (test-ids (hash-table-values (dboard:tabdat-curr-test-ids data))) ;; run-id is #f in next line to send the query to server 0 - (run-changes (synchash:client-get 'db:get-runs get-runs-sig (length keypatts) data #f runname #f #f keypatts)) + (run-changes (synchash:client-get area-dat 'db:get-runs get-runs-sig (length keypatts) data #f runname #f #f keypatts)) (tests-detail-changes (if (not (null? test-ids)) - (synchash:client-get 'db:get-test-info-by-ids get-details-sig 0 data #f test-ids) + (synchash:client-get area-dat 'db:get-test-info-by-ids get-details-sig 0 data #f test-ids) '())) ;; Now can calculate the run-ids (run-hash (hash-table-ref/default data get-runs-sig #f)) (run-ids (if run-hash (filter number? (hash-table-keys run-hash)) '())) (all-test-changes (let ((res (make-hash-table))) (for-each (lambda (run-id) (if (> run-id 0) - (hash-table-set! res run-id (synchash:client-get 'db:get-tests-for-run-mindata get-tests-sig 0 data run-id 1 testpatt states statuses #f)))) + (hash-table-set! res run-id (synchash:client-get area-dat 'db:get-tests-for-run-mindata get-tests-sig 0 data run-id 1 testpatt states statuses #f)))) run-ids) res)) (runs-hash (hash-table-ref/default data get-runs-sig #f)) (header (hash-table-ref/default runs-hash "header" #f)) (run-ids (sort (filter number? (hash-table-keys runs-hash)) @@ -426,12 +426,12 @@ "CLEAN" (list-ref (list-ref item 2) 1)))) res) res)))) -(define (dcommon:examine-xterm run-id test-id) - (let* ((testdat (rmt:get-test-info-by-id run-id test-id))) +(define (dcommon:examine-xterm area-dat run-id test-id) + (let* ((testdat (rmt:get-test-info-by-id area-dat run-id test-id))) (if (not testdat) (begin (debug:print 2 "ERROR: No test data found for test " test-id ", exiting") (exit 1)) (let* @@ -539,16 +539,16 @@ (iup:attribute-set! general-matrix "2:0" "Version") (iup:attribute-set! general-matrix "2:1" (conc megatest-version "-" (substring megatest-fossil-hash 0 4))) general-matrix)) -(define (dcommon:run-stats commondat tabdat #!key (tab-num #f)) +(define (dcommon:run-stats area-dat commondat tabdat #!key (tab-num #f)) (let* ((stats-matrix (iup:matrix expand: "YES")) (changed #f) (stats-updater (lambda () (if (dashboard:database-changed? commondat tabdat context-key: 'run-stats) - (let* ((run-stats (rmt:get-run-stats)) + (let* ((run-stats (rmt:get-run-stats area-dat)) (indices (common:sparse-list-generate-index run-stats)) ;; proc: set-cell)) (row-indices (car indices)) (col-indices (cadr indices)) (max-row (if (null? row-indices) 1 (common:max (map cadr row-indices)))) (max-col (if (null? col-indices) 1 @@ -1092,11 +1092,11 @@ (dashboard:update-run-command tabdat)))) "command-runname-selector lb action")))) (refresh-runs-list (lambda () (if (dashboard:database-changed? commondat tabdat context-key: 'runname-selector-runs-list) (let* (;; (target (dboard:tabdat-target-string tabdat)) - (runs-for-targ (rmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f 0)) + (runs-for-targ (rmt:get-runs-by-patt area-dat (dboard:tabdat-keys tabdat) "%" #f #f #f #f 0)) (runs-header (vector-ref runs-for-targ 0)) (runs-dat (vector-ref runs-for-targ 1)) (run-names (cons default-run-name (map (lambda (x) (db:get-value-by-header x runs-header "runname")) Index: diff-report.scm ================================================================== --- diff-report.scm +++ diff-report.scm @@ -116,36 +116,36 @@ "CLEAN" (list-ref (list-ref item 2) 1)))) res) res)))) -(define (diff:run-name->run-id run-name) +(define (diff:run-name->run-id area-dat run-name) (if (number? run-name) run-name - (let* ((qry-res (rmt:get-runs run-name 1 0 '()))) + (let* ((qry-res (rmt:get-runs area-dat run-name 1 0 '()))) (if (eq? 2 (vector-length qry-res)) (vector-ref (car (vector-ref qry-res 1)) 1) #f)))) -(define (diff:target+run-name->run-id target run-name) - (let* ((keys (rmt:get-keys)) +(define (diff:target+run-name->run-id area-dat target run-name) + (let* ((keys (rmt:get-keys area-dat)) (target-parts (if target (string-split target "/") (map (lambda (x) "%") keys)))) (if (not (eq? (length keys) (length keys))) (begin (print "Error: Target ("target") item count does not match fields count target tokens="target-parts" fields="keys) #f) (let* ((target-map (zip keys target-parts)) - (qry-res (rmt:get-runs run-name 1 0 target-map))) + (qry-res (rmt:get-runs area-dat run-name 1 0 target-map))) (if (eq? 2 (vector-length qry-res)) (let ((first-ent (vector-ref qry-res 1))) (if (> (length first-ent) 0) (vector-ref (car first-ent) 1) #f)) #f))))) -(define (diff:run-id->tests-mindat run-id #!key (testpatt "%/%")) +(define (diff:run-id->tests-mindat area-dat run-id #!key (testpatt "%/%")) (let* ((states '()) (statuses '()) (offset #f) (limit #f) (not-in #t) @@ -168,11 +168,11 @@ (item-path (vector-ref row 2)) (state (vector-ref row 3)) (status (vector-ref row 4))) (list test-name item-path (list id state status)))) - (rmt:get-tests-for-run run-id + (rmt:get-tests-for-run area-dat run-id testpatt states statuses offset limit not-in sort-by sort-order qryvals last-update @@ -260,13 +260,13 @@ |_| |_|\\___|\\__, |\\__,_|\\__\\___||___/\\__| |____/|_|_| |_| |___/ ") -(define (diff:run-id->target+run-name+starttime run-id) - (let* ((target (rmt:get-target run-id)) - (runinfo (rmt:get-run-info run-id)) ; vector of header (list) and result (vector) +(define (diff:run-id->target+run-name+starttime area-dat run-id) + (let* ((target (rmt:get-target area-dat run-id)) + (runinfo (rmt:get-run-info area-dat run-id)) ; vector of header (list) and result (vector) (info-hash (alist->hash-table (map (lambda (x) (cons (car x) (cadr x))) ; make it a useful hash (zip (vector-ref runinfo 0) (vector->list (vector-ref runinfo 1)))))) (run-name (hash-table-ref/default info-hash "runname" "N/A")) (start-time (hash-table-ref/default info-hash "event_time" 0))) Index: ezsteps.scm ================================================================== --- ezsteps.scm +++ ezsteps.scm @@ -24,11 +24,11 @@ (include "common_records.scm") (include "key_records.scm") (include "db_records.scm") (include "run_records.scm") -(define (ezsteps:run-from testdat start-step-name run-one) +(define (ezsteps:run-from area-dat testdat start-step-name run-one) (let* ((test-run-dir ;; (filedb:get-path *fdb* (db:test-get-rundir testdat)) ;; ) (testconfig (read-config (conc test-run-dir "/testconfig") #f #t environ-patt: "pre-launch-env-vars")) (ezstepslst (hash-table-ref/default testconfig "ezsteps" '())) (run-mutex (make-mutex)) @@ -81,11 +81,11 @@ ;; call the command using mt_ezstep (set! script (conc "mt_ezstep " stepname " " (if prevstep prevstep "-") " " stepcmd)) (debug:print 4 *default-log-port* "script: " script) - (rmt:teststep-set-status! run-id test-id stepname "start" "-" #f #f) + (rmt:teststep-set-status! area-dat run-id test-id stepname "start" "-" #f #f) ;; now launch (let ((pid (process-run script))) (let processloop ((i 0)) (let-values (((pid-val exit-status exit-code)(process-wait pid #t))) (mutex-lock! run-mutex) @@ -98,13 +98,13 @@ (thread-sleep! 1) (processloop (+ i 1)))) )) (let ((exinfo (vector-ref exit-info 2)) (logfna (if logpro-used (conc stepname ".html") ""))) - (rmt:teststep-set-status! run-id test-id stepname "end" exinfo #f logfna)) + (rmt:teststep-set-status! area-dat run-id test-id stepname "end" exinfo #f logfna)) (if logpro-used - (rmt:test-set-log! test-id (conc stepname ".html"))) + (rmt:test-set-log! area-dat test-id (conc stepname ".html"))) ;; set the test final status (let* ((this-step-status (cond ((and (eq? (vector-ref exit-info 2) 2) logpro-used) 'warn) ((eq? (vector-ref exit-info 2) 0) 'pass) (else 'fail))) @@ -122,18 +122,18 @@ " next-status: " next-status " rollup-status: " rollup-status) (case next-status ((warn) (set! rollup-status 2) ;; NB// test-set-status! does rdb calls under the hood - (tests:test-set-status! test-id "RUNNING" "WARN" + (tests:test-set-status! area-dat test-id "RUNNING" "WARN" (if (eq? this-step-status 'warn) "Logpro warning found" #f) #f)) ((pass) - (tests:test-set-status! test-id "RUNNING" "PASS" #f #f)) + (tests:test-set-status! area-dat test-id "RUNNING" "PASS" #f #f)) (else ;; 'fail (set! rollup-status 1) ;; force fail - (tests:test-set-status! test-id "RUNNING" "FAIL" (conc "Failed at step " stepname) #f) + (tests:test-set-status! area-dat test-id "RUNNING" "FAIL" (conc "Failed at step " stepname) #f) )))) (if (and (steprun-good? logpro-used (vector-ref exit-info 2)) (not (null? tal))) (if (not run-one) ;; if we got here we completed the step, if run-one is true, stop (loop (car tal) (cdr tal) stepname runflag)))) @@ -140,11 +140,11 @@ (debug:print 4 *default-log-port* "WARNING: a prior step failed, stopping at " ezstep))) ;; Once done with step/steps update the test record ;; (let* ((item-path (db:test-get-item-path testdat)) ;; (item-list->path itemdat)) - (testinfo (rmt:get-testinfo-by-id run-id test-id))) ;; refresh the testdat, call it iteminfo in case need prev/curr + (testinfo (rmt:get-testinfo-by-id area-dat run-id test-id))) ;; refresh the testdat, call it iteminfo in case need prev/curr ;; Am I completed? (if (equal? (db:test-get-state testinfo) "RUNNING") ;; (not (equal? (db:test-get-state testinfo) "COMPLETED")) (let ((new-state (if kill-job "KILLED" "COMPLETED") ;; (if (eq? (vector-ref exit-info 2) 0) ;; exited with "good" status ;; "COMPLETED" ;; (db:test-get-state testinfo))) ;; else preseve the state as set within the test @@ -158,18 +158,18 @@ ((eq? rollup-status 2) ;; if the current status is AUTO the defer to the calculated value but qualify (i.e. make this AUTO-WARN) (if (equal? (db:test-get-status testinfo) "AUTO") "AUTO-WARN" "WARN")) (else "FAIL")))) ;; (db:test-get-status testinfo))) (debug:print-info 2 *default-log-port* "Test NOT logged as COMPLETED, (state=" (db:test-get-state testinfo) "), updating result, rollup-status is " rollup-status) - (tests:test-set-status! test-id + (tests:test-set-status! area-dat test-id new-state new-status (args:get-arg "-m") #f) ;; need to update the top test record if PASS or FAIL and this is a subtest (if (not (equal? item-path "")) (cdb:set-state-status-and-roll-up-items *runremote* run-id test-name item-path new-status)))) ;; for automated creation of the rollup html file this is a good place... (if (not (equal? item-path "")) - (tests:summarize-items #f run-id test-id test-name #f)) ;; don't force - just update if no + (tests:summarize-items area-dat #f run-id test-id test-name #f)) ;; don't force - just update if no ))) (pop-directory) rollup-status)) Index: launch.scm ================================================================== --- launch.scm +++ launch.scm @@ -59,31 +59,31 @@ (defstruct launch:einf (pid #t)(exit-status #t)(exit-code #t)(rollup-status 0)) ;; return (conc status ": " comment) from the final section so that ;; the comment can be set in the step record in launch.scm ;; -(define (launch:load-logpro-dat run-id test-id stepname) +(define (launch:load-logpro-dat area-dat run-id test-id stepname) (let ((cname (conc stepname ".dat"))) (if (file-exists? cname) (let* ((dat (read-config cname #f #f)) (csvr (db:logpro-dat->csv dat stepname)) (csvt (let-values (((fmt-cell fmt-record fmt-csv) (make-format ","))) (fmt-csv (map list->csv-record csvr)))) (status (configf:lookup dat "final" "exit-status")) (msg (configf:lookup dat "final" "message"))) (if csvt ;; this if blocked stack dump caused by .dat file from logpro being 0-byte. fixed by upgrading logpro - (rmt:csv->test-data run-id test-id csvt) + (rmt:csv->test-data area-dat run-id test-id csvt) (debug:print 0 *default-log-port* "ERROR: no csvdat exists for run-id: " run-id " test-id: " test-id " stepname: " stepname ", check that logpro version is 1.15 or newer")) ;; (BB> "Error: run-id/test-id/stepname="run-id"/"test-id"/"stepname" => bad csvr="csvr) ;; ) (cond ((equal? status "PASS") "PASS") ;; skip the message part if status is pass (status (conc (configf:lookup dat "final" "exit-status") ": " (if msg msg "no message"))) (else #f))) #f))) -(define (launch:runstep ezstep run-id test-id exit-info m tal testconfig) +(define (launch:runstep area-dat ezstep run-id test-id exit-info m tal testconfig) (let* ((stepname (car ezstep)) ;; do stuff to run the step (stepinfo (cadr ezstep)) (stepparts (string-match (regexp "^(\\{([^\\}]*)\\}\\s*|)(.*)$") stepinfo)) (stepparms (list-ref stepparts 2)) ;; for future use, {VAR=1,2,3}, run step for each (stepcmd (list-ref stepparts 3)) @@ -116,11 +116,11 @@ ;; call the command using mt_ezstep ;; (set! script (conc "mt_ezstep " stepname " " (if prevstep prevstep "x") " " stepcmd)) (debug:print 4 *default-log-port* "script: " script) - (rmt:teststep-set-status! run-id test-id stepname "start" "-" #f #f) + (rmt:teststep-set-status! area-dat run-id test-id stepname "start" "-" #f #f) ;; now launch the actual process (call-with-environment-variables (list (cons "PATH" (conc (get-environment-variable "PATH") ":."))) (lambda () ;; (process-run "/bin/bash" "-c" "exec ls -l /tmp/foobar > /tmp/delme-more.log 2>&1") (let* ((cmd (conc stepcmd " > " stepname ".log 2>&1")) ;; >outfile 2>&1 @@ -135,11 +135,11 @@ (print) (print stepname " : " stepname ".log") (print)) #:append) - (rmt:test-set-top-process-pid run-id test-id pid) + (rmt:test-set-top-process-pid area-dat run-id test-id pid) (let processloop ((i 0)) (let-values (((pid-val exit-status exit-code)(process-wait pid #t))) (mutex-lock! m) (launch:einf-pid-set! exit-info pid) ;; (vector-set! exit-info 0 pid) (launch:einf-exit-status-set! exit-info exit-status) ;; (vector-set! exit-info 1 exit-status) @@ -174,12 +174,12 @@ (if logpro-used (let ((datfile (conc stepname ".dat"))) ;; load the .dat file into the test_data table if it exists (if (file-exists? datfile) (set! comment (launch:load-logpro-dat run-id test-id stepname))) - (rmt:test-set-log! run-id test-id (conc stepname ".html")))) - (rmt:teststep-set-status! run-id test-id stepname "end" exinfo comment logfna)) + (rmt:test-set-log! area-dat run-id test-id (conc stepname ".html")))) + (rmt:teststep-set-status! area-dat run-id test-id stepname "end" exinfo comment logfna)) ;; set the test final status (let* ((process-exit-status (launch:einf-exit-code exit-info)) ;; (vector-ref exit-info 2)) (this-step-status (cond ((and (eq? process-exit-status 2) logpro-used) 'warn) ;; logpro 2 = warnings ((and (eq? process-exit-status 3) logpro-used) 'check) ;; logpro 3 = check @@ -208,46 +208,46 @@ " next-status: " next-status " rollup-status: " (launch:einf-rollup-status exit-info)) ;; (vector-ref exit-info 3)) (case next-status ((warn) (launch:einf-rollup-status-set! exit-info 2) ;; (vector-set! exit-info 3 2) ;; rollup-status ;; NB// test-set-status! does rdb calls under the hood - (tests:test-set-status! run-id test-id next-state "WARN" + (tests:test-set-status! area-dat run-id test-id next-state "WARN" (if (eq? this-step-status 'warn) "Logpro warning found" #f) #f)) ((check) (launch:einf-rollup-status-set! exit-info 3) ;; (vector-set! exit-info 3 3) ;; rollup-status ;; NB// test-set-status! does rdb calls under the hood - (tests:test-set-status! run-id test-id next-state "CHECK" + (tests:test-set-status! area-dat run-id test-id next-state "CHECK" (if (eq? this-step-status 'check) "Logpro check found" #f) #f)) ((waived) (launch:einf-rollup-status-set! exit-info 4) ;; (vector-set! exit-info 3 3) ;; rollup-status ;; NB// test-set-status! does rdb calls under the hood - (tests:test-set-status! run-id test-id next-state "WAIVED" + (tests:test-set-status! area-dat run-id test-id next-state "WAIVED" (if (eq? this-step-status 'check) "Logpro waived found" #f) #f)) ((abort) (launch:einf-rollup-status-set! exit-info 5) ;; (vector-set! exit-info 3 4) ;; rollup-status ;; NB// test-set-status! does rdb calls under the hood - (tests:test-set-status! run-id test-id next-state "ABORT" + (tests:test-set-status! area-dat run-id test-id next-state "ABORT" (if (eq? this-step-status 'abort) "Logpro abort found" #f) #f)) ((skip) (launch:einf-rollup-status-set! exit-info 6) ;; (vector-set! exit-info 3 4) ;; rollup-status ;; NB// test-set-status! does rdb calls under the hood - (tests:test-set-status! run-id test-id next-state "SKIP" + (tests:test-set-status! area-dat run-id test-id next-state "SKIP" (if (eq? this-step-status 'skip) "Logpro skip found" #f) #f)) ((pass) - (tests:test-set-status! run-id test-id next-state "PASS" #f #f)) + (tests:test-set-status! area-dat run-id test-id next-state "PASS" #f #f)) (else ;; 'fail (launch:einf-rollup-status-set! exit-info 1) ;; (vector-set! exit-info 3 1) ;; force fail, this used to be next-state but that doesn't make sense. should always be "COMPLETED" - (tests:test-set-status! run-id test-id "COMPLETED" "FAIL" (conc "Failed at step " stepname) #f) + (tests:test-set-status! area-dat run-id test-id "COMPLETED" "FAIL" (conc "Failed at step " stepname) #f) ))) logpro-used)) -(define (launch:manage-steps run-id test-id item-path fullrunscript ezsteps test-name tconfigreg exit-info m) +(define (launch:manage-steps area-dat run-id test-id item-path fullrunscript ezsteps test-name tconfigreg exit-info m) ;; (let-values ;; (((pid exit-status exit-code) ;; (run-n-wait fullrunscript))) ;; (tests:test-set-status! test-id "RUNNING" "n/a" #f #f) ;; Since we should have a clean slate at this time there is no need to do @@ -254,17 +254,17 @@ ;; any of the other stuff that tests:test-set-status! does. Let's just ;; force RUNNING/n/a ;; (thread-sleep! 0.3) ;; (tests:test-force-state-status! run-id test-id "RUNNING" "n/a") - (rmt:set-state-status-and-roll-up-items run-id test-name item-path "RUNNING" #f #f) + (rmt:set-state-status-and-roll-up-items area-dat run-id test-name item-path "RUNNING" #f #f) ;; (thread-sleep! 0.3) ;; NFS slowness has caused grief here ;; if there is a runscript do it first (if fullrunscript (let ((pid (process-run fullrunscript))) - (rmt:test-set-top-process-pid run-id test-id pid) + (rmt:test-set-top-process-pid area-dat run-id test-id pid) (let loop ((i 0)) (let-values (((pid-val exit-status exit-code) (process-wait pid #t))) (mutex-lock! m) (launch:einf-pid-set! exit-info pid) ;; (vector-set! exit-info 0 pid) @@ -316,11 +316,11 @@ (if (not (null? tal)) (loop (car tal) (cdr tal) stepname)) (debug:print 4 *default-log-port* "WARNING: step " (car ezstep) " failed. Stopping"))) (debug:print 4 *default-log-port* "WARNING: a prior step failed, stopping at " ezstep))))))) -(define (launch:monitor-job run-id test-id item-path fullrunscript ezsteps test-name tconfigreg exit-info m work-area runtlim misc-flags) +(define (launch:monitor-job area-dat run-id test-id item-path fullrunscript ezsteps test-name tconfigreg exit-info m work-area runtlim misc-flags) (let* ((start-seconds (current-seconds)) (calc-minutes (lambda () (inexact->exact (round (- @@ -327,11 +327,11 @@ (current-seconds) start-seconds))))) (kill-tries 0)) ;; (tests:set-full-meta-info #f test-id run-id (calc-minutes) work-area) ;; (tests:set-full-meta-info test-id run-id (calc-minutes) work-area) - (tests:set-full-meta-info #f test-id run-id (calc-minutes) work-area 10) + (tests:set-full-meta-info #f area-dat test-id run-id (calc-minutes) work-area 10) (let loop ((minutes (calc-minutes)) (cpu-load (alist-ref 'adj-core-load (common:get-normalized-cpu-load #f))) (disk-free (get-df (current-directory)))) (let ((new-cpu-load (let* ((load (alist-ref 'adj-core-load (common:get-normalized-cpu-load #f))) (delta (abs (- load cpu-load)))) @@ -341,27 +341,27 @@ (new-disk-free (let* ((df (get-df (current-directory))) (delta (abs (- df disk-free)))) (if (> delta 200) ;; ignore changes under 200 Meg df #f)))) - (set! kill-job? (or (test-get-kill-request run-id test-id) ;; run-id test-name itemdat)) + (set! kill-job? (or (test-get-kill-request area-dat run-id test-id) ;; run-id test-name itemdat)) (and runtlim (let* ((run-seconds (- (current-seconds) start-seconds)) (time-exceeded (> run-seconds runtlim))) (if time-exceeded (begin (debug:print-info 0 *default-log-port* "KILLING TEST DUE TO TIME LIMIT EXCEEDED! Runtime=" run-seconds " seconds, limit=" runtlim) #t) #f))))) - (tests:update-central-meta-info run-id test-id new-cpu-load new-disk-free (calc-minutes) #f #f) + (tests:update-central-meta-info area-dat run-id test-id new-cpu-load new-disk-free (calc-minutes) #f #f) (if kill-job? (begin (mutex-lock! m) ;; NOTE: The pid can change as different steps are run. Do we need handshaking between this ;; section and the runit section? Or add a loop that tries three times with a 1/4 second ;; between tries? (let* ((pid1 (launch:einf-pid exit-info)) ;; (vector-ref exit-info 0)) - (pid2 (rmt:test-get-top-process-pid run-id test-id)) + (pid2 (rmt:test-get-top-process-pid area-dat run-id test-id)) (pids (delete-duplicates (filter number? (list pid1 pid2))))) (if (not (null? pids)) (begin (for-each (lambda (pid) @@ -385,24 +385,24 @@ #f (process-signal pid-num signal/kill))) (process:get-sub-pids pid)))) ;; (debug:print-info 0 *default-log-port* "not killing process " pid " as it is not alive")))) pids) - (tests:test-set-status! run-id test-id "KILLED" "KILLED" (args:get-arg "-m") #f)) + (tests:test-set-status! area-dat run-id test-id "KILLED" "KILLED" (args:get-arg "-m") #f)) (begin (debug:print-error 0 *default-log-port* "Nothing to kill, pid1=" pid1 ", pid2=" pid2) - (tests:test-set-status! run-id test-id "KILLED" "FAILED TO KILL" (args:get-arg "-m") #f) + (tests:test-set-status! area-dat run-id test-id "KILLED" "FAILED TO KILL" (args:get-arg "-m") #f) ))) (mutex-unlock! m) ;; no point in sticking around. Exit now. (exit))) (if (hash-table-ref/default misc-flags 'keep-going #f) (begin (thread-sleep! 3) ;; (+ 3 (random 6))) ;; add some jitter to the call home time to spread out the db accesses (if (hash-table-ref/default misc-flags 'keep-going #f) ;; keep originals for cpu-load and disk-free unless they change more than the allowed delta (loop (calc-minutes) (or new-cpu-load cpu-load) (or new-disk-free disk-free))))))) - (tests:update-central-meta-info run-id test-id (get-cpu-load) (get-df (current-directory))(calc-minutes) #f #f))) ;; NOTE: Checking twice for keep-going is intentional + (tests:update-central-meta-info area-dat run-id test-id (get-cpu-load) (get-df (current-directory))(calc-minutes) #f #f))) ;; NOTE: Checking twice for keep-going is intentional (define (launch:execute encoded-cmd) (let* ((cmdinfo (common:read-encoded-string encoded-cmd)) (tconfigreg #f)) (setenv "MT_CMDINFO" encoded-cmd) @@ -438,11 +438,11 @@ (let ((fulln (conc testpath "/" runscript))) (if (and (file-exists? fulln) (file-execute-access? fulln)) fulln runscript))))) ;; assume it is on the path - ) ;; (rollup-status 0) + (area-dat (make-remote))) ;; (rollup-status 0) ;; NFS might not have propagated the directory meta data to the run host - give it time if needed (let loop ((count 0)) (if (or (file-exists? top-path) (> count 10)) @@ -458,11 +458,11 @@ (if (eq? signum signal/stop) (debug:print-error 0 *default-log-port* "attempt to STOP process. Exiting.")) (set! *time-to-exit* #t) (print "Received signal " signum ", cleaning up before exit. Please wait...") (let ((th1 (make-thread (lambda () - (rmt:test-set-state-status run-id test-id "INCOMPLETE" "KILLED" #f) + (rmt:test-set-state-status area-dat run-id test-id "INCOMPLETE" "KILLED" #f) (print "Killed by signal " signum ". Exiting") (thread-sleep! 1) (exit 1)))) (th2 (make-thread (lambda () (thread-sleep! 2) @@ -476,36 +476,35 @@ ) ;; (set-signal-handler! signal/stop sighand) ;; Do not run the test if it is REMOVING, RUNNING, KILLREQ or REMOTEHOSTSTART, ;; Mark the test as REMOTEHOSTSTART *IMMEDIATELY* ;; - (let* ((test-info (rmt:get-test-info-by-id run-id test-id)) + (let* ((test-info (rmt:get-test-info-by-id area-dat run-id test-id)) (test-host (db:test-get-host test-info)) (test-pid (db:test-get-process_id test-info))) (cond ((member (db:test-get-state test-info) '("INCOMPLETE" "KILLED" "UNKNOWN" "KILLREQ" "STUCK")) ;; prior run of this test didn't complete, go ahead and try to rerun (debug:print 0 *default-log-port* "INFO: test is INCOMPLETE or KILLED, treat this execute call as a rerun request") ;; (tests:test-force-state-status! run-id test-id "REMOTEHOSTSTART" "n/a") - (rmt:test-set-state-status run-id test-id "REMOTEHOSTSTART" "n/a" #f) + (rmt:test-set-state-status area-dat run-id test-id "REMOTEHOSTSTART" "n/a" #f) ) ;; prime it for running ((member (db:test-get-state test-info) '("RUNNING" "REMOTEHOSTSTART")) (if (process:alive-on-host? test-host test-pid) (debug:print-error 0 *default-log-port* "test state is " (db:test-get-state test-info) " and process " test-pid " is still running on host " test-host ", cannot proceed") ;; (tests:test-force-state-status! run-id test-id "REMOTEHOSTSTART" "n/a") - (rmt:test-set-state-status run-id test-id "REMOTEHOSTSTART" "n/a" #f) + (rmt:test-set-state-status area-dat run-id test-id "REMOTEHOSTSTART" "n/a" #f) )) ((not (member (db:test-get-state test-info) '("REMOVING" "REMOTEHOSTSTART" "RUNNING" "KILLREQ"))) ;; (tests:test-force-state-status! run-id test-id "REMOTEHOSTSTART" "n/a") - (rmt:test-set-state-status run-id test-id "REMOTEHOSTSTART" "n/a" #f) + (rmt:test-set-state-status area-dat run-id test-id "REMOTEHOSTSTART" "n/a" #f) ) (else ;; (member (db:test-get-state test-info) '("REMOVING" "REMOTEHOSTSTART" "RUNNING" "KILLREQ")) (debug:print-error 0 *default-log-port* "test state is " (db:test-get-state test-info) ", cannot proceed") (exit)))) (debug:print 2 *default-log-port* "Exectuing " test-name " (id: " test-id ") on " (get-host-name)) - (set! keys (rmt:get-keys)) - ;; (runs:set-megatest-env-vars run-id inkeys: keys inkeyvals: keyvals) ;; these may be needed by the launching process + (set! keys (rmt:get-keys area-dat)) ;; one of these is defunct/redundant ... (if (not (launch:setup force: #t)) (begin (debug:print 0 *default-log-port* "Failed to setup, exiting") ;; (sqlite3:finalize! db) @@ -583,17 +582,17 @@ ;; (client:setup) ;; environment overrides are done *before* the remaining critical envars. (alist->env-vars env-ovrd) - (runs:set-megatest-env-vars run-id inkeys: keys inkeyvals: keyvals) + (runs:set-megatest-env-vars area-dat run-id inkeys: keys inkeyvals: keyvals) (set-item-env-vars itemdat) (save-environment-as-files "megatest") ;; open-run-close not needed for test-set-meta-info ;; (tests:set-full-meta-info #f test-id run-id 0 work-area) ;; (tests:set-full-meta-info test-id run-id 0 work-area) - (tests:set-full-meta-info #f test-id run-id 0 work-area 10) + (tests:set-full-meta-info #f area-dat test-id run-id 0 work-area 10) ;; (thread-sleep! 0.3) ;; NFS slowness has caused grief here (if (args:get-arg "-xterm") (set! fullrunscript "xterm") @@ -630,11 +629,11 @@ (thread-join! th1) (thread-sleep! 1) ;; givbe thread th1 a chance to be done TODO: Verify this is needed. At 0.1 I was getting fail to stop, increased to total of 1.1 sec. (mutex-lock! m) (let* ((item-path (item-list->path itemdat)) ;; only state and status needed - use lazy routine - (testinfo (rmt:get-testinfo-state-status run-id test-id))) + (testinfo (rmt:get-testinfo-state-status area-dat run-id test-id))) ;; Am I completed? (if (member (db:test-get-state testinfo) '("REMOTEHOSTSTART" "RUNNING")) ;; NOTE: It should *not* be REMOTEHOSTSTART but for reasons I don't yet understand it sometimes gets stuck in that state ;; (not (equal? (db:test-get-state testinfo) "COMPLETED")) (let ((new-state (if kill-job? "KILLED" "COMPLETED") ;; (if (eq? (vector-ref exit-info 2) 0) ;; exited with "good" status ;; "COMPLETED" ;; (db:test-get-state testinfo))) ;; else preseve the state as set within the test @@ -652,23 +651,23 @@ ((eq? (launch:einf-rollup-status exit-info) 4) "WAIVED") ((eq? (launch:einf-rollup-status exit-info) 5) "ABORT") ((eq? (launch:einf-rollup-status exit-info) 6) "SKIP") (else "FAIL")))) ;; (db:test-get-status testinfo))) (debug:print-info 1 *default-log-port* "Test exited in state=" (db:test-get-state testinfo) ", setting state/status based on exit code of " (launch:einf-exit-status exit-info) " and rollup-status of " (launch:einf-rollup-status exit-info)) - (tests:test-set-status! run-id + (tests:test-set-status! area-dat run-id test-id new-state new-status (args:get-arg "-m") #f) ;; need to update the top test record if PASS or FAIL and this is a subtest ;; NO NEED TO CALL set-state-status-and-roll-up-items HERE, THIS IS DONE IN set-state-status-and-roll-up-items called by tests:test-set-status! )) ;; for automated creation of the rollup html file this is a good place... (if (not (equal? item-path "")) - (tests:summarize-items run-id test-id test-name #f)) - (tests:summarize-test run-id test-id) ;; don't force - just update if no - (rmt:update-run-stats run-id (rmt:get-raw-run-stats run-id))) + (tests:summarize-items area-dat run-id test-id test-name #f)) + (tests:summarize-test area-dat run-id test-id) ;; don't force - just update if no + (rmt:update-run-stats area-dat run-id (rmt:get-raw-run-stats area-dat run-id))) (mutex-unlock! m) (debug:print 2 *default-log-port* "Output from running " fullrunscript ", pid " (launch:einf-pid exit-info) " in work area " work-area ":\n====\n exit code " (launch:einf-exit-code exit-info) "\n" "====\n") (if (not (launch:einf-exit-status exit-info)) (exit 4))))))) @@ -733,11 +732,11 @@ *toppath*) (let ((res (launch:setup-body force: force))) (mutex-unlock! *launch-setup-mutex*) res))) -(define (launch:setup-body #!key (force #f)) +(define (launch:setup-body area-dat #!key (force #f)) (let* ((toppath (or *toppath* (getenv "MT_RUN_AREA_HOME"))) ;; preserve toppath (runname (common:args-get-runname)) (target (common:args-get-target)) (linktree (common:get-linktree)) (sections (if target (list "default" target) #f)) ;; for runconfigs @@ -793,11 +792,11 @@ (begin (debug:print-error 0 *default-log-port* "you are not in a megatest area!") (exit 1))) (setenv "MT_RUN_AREA_HOME" *toppath*) ;; the seed read is done, now read runconfigs, cache it then read megatest.config one more time and cache it - (let* ((keys (rmt:get-keys)) + (let* ((keys (rmt:get-keys area-dat)) (key-vals (keys:target->keyval keys target)) (linktree (or (getenv "MT_LINKTREE") (if *configdat* (configf:lookup *configdat* "setup" "linktree") #f))) (second-pass (find-and-read-config mtconfig @@ -931,11 +930,11 @@ (lnkpathf (conc lnkpath (if not-iterated "" "/") item-path)) (lnktarget (conc lnkpath "/" item-path))) ;; Update the rundir path in the test record for all, rundir=physical, shortdir=logical ;; rundir shortdir - (rmt:general-call 'test-set-rundir-shortdir run-id lnkpathf test-path testname item-path run-id) + (rmt:general-call area-dat 'test-set-rundir-shortdir run-id lnkpathf test-path testname item-path run-id) (debug:print 2 *default-log-port* "INFO:\n lnkbase=" lnkbase "\n lnkpath=" lnkpath "\n toptest-path=" toptest-path "\n test-path=" test-path) (if (not (file-exists? linktree)) (begin (debug:print 0 *default-log-port* "WARNING: linktree did not exist! Creating it now at " linktree) @@ -991,25 +990,25 @@ ;; Do the setting of this record after the paths are created so that the shortdir can ;; be set to the real directory location. This is safer for future clean up if the link ;; tree is damaged or lost. ;; (if (not (hash-table-ref/default *toptest-paths* testname #f)) - (let* ((testinfo (rmt:get-test-info-by-id run-id test-id)) ;; run-id testname item-path)) + (let* ((testinfo (rmt:get-test-info-by-id area-dat run-id test-id)) ;; run-id testname item-path)) (curr-test-path (if testinfo ;; (filedb:get-path *fdb* ;; (db:get-path dbstruct - ;; (rmt:sdb-qry 'getstr + ;; (rmt:sdb-qry area-dat 'getstr (db:test-get-rundir testinfo) ;; ) ;; ) #f))) (hash-table-set! *toptest-paths* testname curr-test-path) ;; NB// Was this for the test or for the parent in an iterated test? - (rmt:general-call 'test-set-rundir-shortdir run-id lnkpath + (rmt:general-call area-dat 'test-set-rundir-shortdir run-id lnkpath (if (file-exists? lnkpath) ;; (resolve-pathname lnkpath) (common:nice-path lnkpath) lnkpath) testname "" run-id) - ;; (rmt:general-call 'test-set-rundir run-id lnkpath testname "") ;; toptest-path) + ;; (rmt:general-call area-dat 'test-set-rundir run-id lnkpath testname "") ;; toptest-path) (if (or (not curr-test-path) (not (directory-exists? toptest-path))) (begin (debug:print-info 2 *default-log-port* "Creating " toptest-path " and link " lnkpath) (handle-exceptions @@ -1135,11 +1134,11 @@ (toptest-work-area #f) ;; for iterated tests the top test contains data relevant for all (diskpath #f) (cmdparms #f) (fullcmd #f) ;; (define a (with-output-to-string (lambda ()(write x)))) (mt-bindir-path #f) - (testinfo (rmt:get-test-info-by-id run-id test-id)) + (testinfo (rmt:get-test-info-by-id area-dat run-id test-id)) (mt_target (string-intersperse (map cadr keyvals) "/")) (debug-param (append (if (args:get-arg "-debug") (list "-debug" (args:get-arg "-debug")) '()) (if (args:get-arg "-logging")(list "-logging") '())))) ;; (if hosts (set! hosts (string-split hosts))) ;; set the megatest to be called on the remote host @@ -1149,17 +1148,17 @@ ;; set up the run work area for this test (if (and (args:get-arg "-preclean") ;; user has requested to preclean for this run (not (member (db:test-get-rundir testinfo)(list "n/a" "/tmp/badname")))) ;; n/a is a placeholder and thus not a read dir (begin (debug:print-info 0 *default-log-port* "attempting to preclean directory " (db:test-get-rundir testinfo) " for test " test-name "/" item-path) - (runs:remove-test-directory testinfo 'remove-data-only))) ;; remove data only, do not perturb the record + (runs:remove-test-directory area-dat testinfo 'remove-data-only))) ;; remove data only, do not perturb the record ;; prevent overlapping actions - set to LAUNCHED as early as possible ;; ;; the following call handles waiver propogation. cannot yet condense into roll-up-pass-fail - (tests:test-set-status! run-id test-id "LAUNCHED" "n/a" #f #f) ;; (if launch-results launch-results "FAILED")) - (rmt:set-state-status-and-roll-up-items run-id test-name item-path #f "LAUNCHED" #f) + (tests:test-set-status! area-dat run-id test-id "LAUNCHED" "n/a" #f #f) ;; (if launch-results launch-results "FAILED")) + (rmt:set-state-status-and-roll-up-items area-dat run-id test-name item-path #f "LAUNCHED" #f) ;; (pp (hash-table->alist tconfig)) (set! diskpath (get-best-disk *configdat* tconfig)) (if diskpath (let ((dat (create-work-area run-id run-info keyvals test-id test-path diskpath test-name itemdat))) (set! work-area (car dat)) @@ -1192,11 +1191,11 @@ (list 'set-vars (if params (hash-table-ref/default params "-setvars" #f))) (list 'runname runname) (list 'mt-bindir-path mt-bindir-path)))))))) ;; clean out step records from previous run if they exist - ;; (rmt:delete-test-step-records run-id test-id) + ;; (rmt:delete-test-step-records area-dat run-id test-id) ;; if the dir does not exist we may have a itempath where individual variables are a path, launch anyway (if (file-exists? work-area) (change-directory work-area)) ;; so that log files from the launch process don't clutter the test dir (cond ;; ((and launcher hosts) ;; must be using ssh hostname @@ -1269,21 +1268,21 @@ launch-results)) (change-directory *toppath*))) ;; recover a test where the top controlling mtest may have died ;; -(define (launch:recover-test run-id test-id) +(define (launch:recover-test area-dat run-id test-id) ;; this function is called on the test run host via ssh ;; ;; 1. look at the process from pid ;; - is it owned by calling user ;; - it it's run directory correct for the test ;; - is there a controlling mtest (maybe stuck) ;; 2. if recovery is needed watch pid ;; - when it exits take the exit code and do the needful ;; - (let* ((pid (rmt:test-get-top-process-id run-id test-id)) + (let* ((pid (rmt:test-get-top-process-id area-dat run-id test-id)) (psres (with-input-from-pipe (conc "ps -F -u " (current-user-name) " | grep -E '" pid " ' | grep -v 'grep -E " pid "'") (lambda () (read-line)))) (rundir (if (string? psres) ;; real process owned by user Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -683,12 +683,13 @@ (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"))) - (server:ping (or server-id host:port) do-exit: #t))) + (host:port (args:get-arg "-ping")) + (area-dat (make-remote))) + (server:ping area-dat (or server-id host:port) do-exit: #t))) ;;====================================================================== ;; Capture, save and manipulate environments ;;====================================================================== @@ -814,11 +815,11 @@ (debug:print-error 0 *default-log-port* "dump output format " (args:get-arg "-dumpmode") " not supported for -list-targets"))) (set! *didsomething* #t)))) ;; cache the runconfigs in $MT_LINKTREE/$MT_TARGET/$MT_RUNNAME/.runconfig ;; -(define (full-runconfigs-read) +(define (full-runconfigs-read area-dat) ;; in the envprocessing branch the below code replaces the further below code ;; (if (eq? *configstatus* 'fulldata) ;; *runconfigdat* ;; (begin ;; (launch:setup) @@ -830,11 +831,11 @@ (cfgf (if rundir (conc rundir "/.runconfig." megatest-version "-" megatest-fossil-hash) #f))) (if (and cfgf (file-exists? cfgf) (file-write-access? cfgf)) (configf:read-alist cfgf) - (let* ((keys (rmt:get-keys)) + (let* ((keys (rmt:get-keys area-dat)) (target (common:args-get-target)) (key-vals (if target (keys:target->keyval keys target) #f)) (sections (if target (list "default" target) #f)) (data (begin (setenv "MT_RUN_AREA_HOME" *toppath*) @@ -912,11 +913,11 @@ ;; Remove old run(s) ;;====================================================================== ;; since several actions can be specified on the command line the removal ;; is done first -(define (operate-on action) +(define (operate-on area-dat action) (let* ((runrec (runs:runrec-make-record)) (target (common:args-get-target))) (cond ((not target) (debug:print-error 0 *default-log-port* "Missing required parameter for " action ", you must specify -target or -reqtarg") @@ -935,11 +936,11 @@ (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 + (runs:operate-on area-dat action target (common:args-get-runname) ;; (or (args:get-arg "-runname")(args:get-arg ":runname")) (common:args-get-testpatt #f) ;; (args:get-arg "-testpatt") state: (common:args-get-state) status: (common:args-get-status) @@ -948,27 +949,27 @@ (if (args:get-arg "-remove-runs") (general-run-call "-remove-runs" "remove runs" - (lambda (target runname keys keyvals) - (operate-on 'remove-runs)))) + (lambda (area-dat target runname keys keyvals) + (operate-on area-dat 'remove-runs)))) (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)))) + (lambda (area-dat target runname keys keyvals) + (operate-on area-dat '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 + (lambda (area-dat target runname keys keyvals) + (let* ((runsdat (rmt:get-runs-by-patt area-dat keys runname (common:args-get-target) #f #f #f #f)) (header (vector-ref runsdat 0)) (rows (vector-ref runsdat 1))) (if (null? rows) @@ -976,12 +977,12 @@ (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)) + (rmt:set-run-status area-dat run-id (args:get-arg "-set-run-status") msg: (args:get-arg "-m")) + (print (rmt:get-run-status area-dat run-id)) ))))))) ;;====================================================================== ;; Query runs ;;====================================================================== @@ -1019,18 +1020,19 @@ (if (launch:setup) (let* (;; (dbstruct (make-dbr:dbstruct path: *toppath* local: (args:get-arg "-local"))) (runpatt (args:get-arg "-list-runs")) (access-mode (db:get-access-mode)) (testpatt (common:args-get-testpatt #f)) + (area-dat (make-remote)) ;; (if (args:get-arg "-testpatt") ;; (args:get-arg "-testpatt") ;; "%")) - (keys (rmt:get-keys)) ;; (db:get-keys dbstruct)) + (keys (rmt:get-keys area-dat)) ;; (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) + ;; (runsdat (rmt:get-runs-by-patt area-dat 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 "%") + (runsdat (rmt:get-runs-by-patt area-dat 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. @@ -1353,11 +1355,11 @@ ;; ;; (if (and (args:get-arg "-since") ;; (launch:setup)) ;; (let* ((since-time (string->number (args:get-arg "-since"))) ;; (run-ids (db:get-changed-run-ids since-time))) -;; ;; (rmt:get-tests-for-runs-mindata run-ids testpatt states status not-in) +;; ;; (rmt:get-tests-for-runs-mindata area-dat run-ids testpatt states status not-in) ;; (print (sort run-ids <)) ;; (set! *didsomething* #t))) ;;====================================================================== @@ -1385,25 +1387,25 @@ (args:get-arg "-rerun-all") (args:get-arg "-runtests")) (general-run-call "-runall" "run all tests" - (lambda (target runname keys keyvals) + (lambda (area-dat target runname keys keyvals) (if (args:get-arg "-rerun-clean") ;; first set states/statuses correct (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"))) (hash-table-set! args:arg-hash "-preclean" #t) - (runs:operate-on 'set-state-status + (runs:operate-on area-dat '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") state: states ;; status: statuses new-state-status: "NOT_STARTED,n/a") - (runs:operate-on 'set-state-status + (runs:operate-on area-dat '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") ;; state: states status: statuses @@ -1410,25 +1412,25 @@ new-state-status: "NOT_STARTED,n/a"))) ;; RERUN ALL (if (args:get-arg "-rerun-all") ;; first set states/statuses correct (begin (hash-table-set! args:arg-hash "-preclean" #t) - (runs:operate-on 'set-state-status + (runs:operate-on area-dat '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") state: #f ;; status: statuses new-state-status: "NOT_STARTED,n/a") - (runs:operate-on 'set-state-status + (runs:operate-on area-dat '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") ;; state: states status: #f new-state-status: "NOT_STARTED,n/a"))) - (runs:run-tests target + (runs:run-tests area-dat target runname #f ;; (common:args-get-testpatt #f) ;; (or (args:get-arg "-testpatt") ;; "%") user @@ -1449,42 +1451,20 @@ ;; - 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 + (lambda (area-dat target runname keys keyvals) + (runs:rollup-run area-dat keys keyvals (or (args:get-arg "-runname")(args:get-arg ":runname") ) user)))) ;;====================================================================== @@ -1493,12 +1473,13 @@ (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 + (lambda (area-dat target runname keys keyvals) + (runs:handle-locking + area-dat target keys (or (args:get-arg "-runname")(args:get-arg ":runname") ) (args:get-arg "-lock") (args:get-arg "-unlock") @@ -1521,23 +1502,24 @@ (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")) - (toppath (assoc/default 'toppath cmdinfo))) + (toppath (assoc/default 'toppath cmdinfo)) + (area-dat (make-remote))) (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)) + (let* ((keys (rmt:get-keys area-dat)) ;; db:test-get-paths must not be run remote - (paths (tests:test-get-paths-matching keys target (args:get-arg "-test-files")))) + (paths (tests:test-get-paths-matching area-dat keys target (args:get-arg "-test-files")))) (set! *didsomething* #t) (for-each (lambda (path) (if (file-exists? path) (print path))) paths))) @@ -1546,11 +1528,11 @@ "-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")))) + (paths (tests:test-get-paths-matching area-dat keys target (args:get-arg "-test-files")))) (for-each (lambda (path) (print path)) paths)))))) ;;====================================================================== @@ -1560,12 +1542,12 @@ (if (args:get-arg "-archive") ;; else do a general-run-call (general-run-call "-archive" "Archive" - (lambda (target runname keys keyvals) - (operate-on 'archive)))) + (lambda (area-dat target runname keys keyvals) + (operate-on area-dat 'archive)))) ;;====================================================================== ;; Extract a spreadsheet from the runs database ;;====================================================================== @@ -1632,20 +1614,21 @@ (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)) + (db #f) + (area-dat (make-remote))) (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)) + ;; (rmt:test-set-log! area-dat run-id test-id (conc stepname ".html")))) + (rmt:teststep-set-status! area-dat 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") @@ -1684,11 +1667,12 @@ (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"))) + (stepname (args:get-arg "-step")) + (area-dat (make-remote))) (if (not (launch:setup)) (begin (debug:print 0 *default-log-port* "Failed to setup, exiting") (exit 1))) @@ -1698,17 +1682,17 @@ ;; (client:setup) (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)) + (tdb:load-test-data area-dat run-id test-id)) (if (args:get-arg "-setlog") (let ((logfname (args:get-arg "-setlog"))) - (rmt:test-set-log! run-id test-id logfname))) + (rmt:test-set-log! area-dat 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"))) + (tests:test-set-toplog! area-dat 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) @@ -1732,11 +1716,11 @@ (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) + (rmt:teststep-set-status! area-dat 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) @@ -1749,13 +1733,13 @@ (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))) + (rmt:test-set-log! area-dat run-id test-id htmllogfile))) (let ((msg (args:get-arg "-m"))) - (rmt:teststep-set-status! run-id test-id stepname "end" exitstat msg logfile)) + (rmt:teststep-set-status! area-dat 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")) @@ -1778,27 +1762,28 @@ (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)))) + (tests:test-set-status! area-dat 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)) + (let ((db #f) + (keys #f) + (area-dat (make-remote))) (if (not (launch:setup)) (begin (debug:print 0 *default-log-port* "Failed to setup, exiting") (exit 1))) - (set! keys (rmt:get-keys)) ;; db)) + (set! keys (rmt:get-keys area-dat)) ;; 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") @@ -1943,16 +1928,16 @@ ;;====================================================================== (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 + (let ((area-dat (make-remote))) (if (not (launch:setup)) (begin (debug:print 0 *default-log-port* "Failed to setup, exiting") (exit 1))) - (operate-on 'run-wait) + (operate-on area-dat 'run-wait) (set! *didsomething* #t))) ;; ;; ;; redo me ;; Not converted to use dbstruct yet ;; ;; ;; redo me ;; ;; ;; ;; redo me (if (args:get-arg "-convert-to-norm") @@ -2001,12 +1986,13 @@ 'new2old ) (set! *didsomething* #t))) (if (args:get-arg "-generate-html") - (let* ((toppath (launch:setup))) - (if (tests:create-html-tree #f) + (let* ((toppath (launch:setup)) + (area-dat (make-remote))) + (if (tests:create-html-tree area-dat #f) (debug:print-info 0 *default-log-port* "HTML output created in " toppath "/lt/page#.html") (debug:print 0 *default-log-port* "Failed to create HTML output in " toppath "/lt/runs-index.html")) (set! *didsomething* #t))) ;;====================================================================== Index: mt.scm ================================================================== --- mt.scm +++ mt.scm @@ -40,12 +40,12 @@ ;; register a test run with the db ;; ;; Use: (db-get-value-by-header (db:get-header runinfo)(db:get-rows runinfo)) ;; to extract info from the structure returned ;; -(define (mt:get-runs-by-patt keys runnamepatt targpatt) - (let loop ((runsdat (rmt:get-runs-by-patt keys runnamepatt targpatt 0 500 #f 0)) +(define (mt:get-runs-by-patt area-dat keys runnamepatt targpatt) + (let loop ((runsdat (rmt:get-runs-by-patt area-dat keys runnamepatt targpatt 0 500 #f 0)) (res '()) (offset 0) (limit 500)) ;; (print "runsdat: " runsdat) (let* ((header (vector-ref runsdat 0)) @@ -53,11 +53,11 @@ (full-list (append res runslst)) (have-more (eq? (length runslst) limit))) ;; (debug:print 0 *default-log-port* "header: " header " runslst: " runslst " have-more: " have-more) (if have-more (let ((new-offset (+ offset limit)) - (next-batch (rmt:get-runs-by-patt keys runnamepatt targpatt offset limit #f 0))) + (next-batch (rmt:get-runs-by-patt area-dat keys runnamepatt targpatt offset limit #f 0))) (debug:print-info 4 *default-log-port* "More than " limit " runs, have " (length full-list) " runs so far.") (debug:print-info 0 *default-log-port* "next-batch: " next-batch) (loop next-batch full-list new-offset @@ -66,27 +66,27 @@ ;;====================================================================== ;; T E S T S ;;====================================================================== -(define (mt:get-tests-for-run run-id testpatt states status #!key (not-in #t) (sort-by 'event_time) (sort-order "ASC") (qryvals #f)(last-update #f)) - (let loop ((testsdat (rmt:get-tests-for-run run-id testpatt states status 0 500 not-in sort-by sort-order qryvals last-update 'normal)) +(define (mt:get-tests-for-run area-dat run-id testpatt states status #!key (not-in #t) (sort-by 'event_time) (sort-order "ASC") (qryvals #f)(last-update #f)) + (let loop ((testsdat (rmt:get-tests-for-run area-dat run-id testpatt states status 0 500 not-in sort-by sort-order qryvals last-update 'normal)) (res '()) (offset 0) (limit 500)) (let* ((full-list (append res testsdat)) (have-more (eq? (length testsdat) limit))) (if have-more (let ((new-offset (+ offset limit))) (debug:print-info 4 *default-log-port* "More than " limit " tests, have " (length full-list) " tests so far.") - (loop (rmt:get-tests-for-run run-id testpatt states status new-offset limit not-in sort-by sort-order qryvals last-update 'normal) + (loop (rmt:get-tests-for-run area-dat run-id testpatt states status new-offset limit not-in sort-by sort-order qryvals last-update 'normal) full-list new-offset limit)) full-list)))) -(define (mt:lazy-get-prereqs-not-met run-id waitons ref-item-path #!key (mode '(normal))(itemmaps #f) ) +(define (mt:lazy-get-prereqs-not-met area-dat run-id waitons ref-item-path #!key (mode '(normal))(itemmaps #f) ) (let* ((key (list run-id waitons ref-item-path mode)) (res (hash-table-ref/default *pre-reqs-met-cache* key #f)) (useres (let ((last-time (if (vector? res) (vector-ref res 0) #f))) (if last-time (< (current-seconds)(+ last-time 5)) @@ -93,11 +93,11 @@ #f)))) (if useres (let ((result (vector-ref res 1))) (debug:print 4 *default-log-port* "Using lazy value res: " result) result) - (let ((newres (rmt:get-prereqs-not-met run-id waitons ref-item-path mode: mode itemmaps: itemmaps))) + (let ((newres (rmt:get-prereqs-not-met area-dat run-id waitons ref-item-path mode: mode itemmaps: itemmaps))) (hash-table-set! *pre-reqs-met-cache* key (vector (current-seconds) newres)) newres)))) (define (mt:get-run-stats dbstruct run-id) ;; Get run stats from local access, move this ... but where? @@ -131,11 +131,11 @@ ;;====================================================================== (define (mt:process-triggers dbstruct run-id test-id newstate newstatus) (let* ((test-dat (db:get-test-info-by-id dbstruct run-id test-id))) (if test-dat - (let* ((test-rundir ;; (rmt:sdb-qry 'getstr ;; (filedb:get-path *fdb* + (let* ((test-rundir ;; (rmt:sdb-qry area-dat 'getstr ;; (filedb:get-path *fdb* (db:test-get-rundir test-dat)) ;; ) ;; ) (test-name (db:test-get-testname test-dat)) (tconfig #f) (state (if newstate newstate (db:test-get-state test-dat))) (status (if newstatus newstatus (db:test-get-status test-dat)))) @@ -170,33 +170,33 @@ ;;====================================================================== ;; S T A T E A N D S T A T U S F O R T E S T S ;;====================================================================== ;; speed up for common cases with a little logic -(define (mt:test-set-state-status-by-id run-id test-id newstate newstatus newcomment) +(define (mt:test-set-state-status-by-id area-dat run-id test-id newstate newstatus newcomment) (if (not (and run-id test-id)) (begin (debug:print-error 0 *default-log-port* "bad data handed to mt:test-set-state-status-by-id, run-id=" run-id ", test-id=" test-id ", newstate=" newstate) (print-call-chain (current-error-port)) #f) (begin ;; cond ;; ((and newstate newstatus newcomment) - ;; (rmt:general-call 'state-status-msg run-id newstate newstatus newcomment test-id)) + ;; (rmt:general-call area-dat 'state-status-msg run-id newstate newstatus newcomment test-id)) ;; ((and newstate newstatus) - ;; (rmt:general-call 'state-status run-id newstate newstatus test-id)) + ;; (rmt:general-call area-dat 'state-status run-id newstate newstatus test-id)) ;; (else - ;; (if newstate (rmt:general-call 'set-test-state run-id newstate test-id)) - ;; (if newstatus (rmt:general-call 'set-test-status run-id newstatus test-id)) - ;; (if newcomment (rmt:general-call 'set-test-comment run-id newcomment test-id)))) - (rmt:set-state-status-and-roll-up-items run-id test-id #f newstate newstatus newcomment) + ;; (if newstate (rmt:general-call area-dat 'set-test-state run-id newstate test-id)) + ;; (if newstatus (rmt:general-call area-dat 'set-test-status run-id newstatus test-id)) + ;; (if newcomment (rmt:general-call area-dat 'set-test-comment run-id newcomment test-id)))) + (rmt:set-state-status-and-roll-up-items area-dat run-id test-id #f newstate newstatus newcomment) ;; (mt:process-triggers run-id test-id newstate newstatus) #t))) -(define (mt:test-set-state-status-by-testname run-id test-name item-path new-state new-status new-comment) - (let ((test-id (rmt:get-test-id run-id test-name item-path))) - (rmt:set-state-status-and-roll-up-items run-id test-name item-path new-state new-status new-comment) +(define (mt:test-set-state-status-by-testname area-dat run-id test-name item-path new-state new-status new-comment) + (let ((test-id (rmt:get-test-id area-dat run-id test-name item-path))) + (rmt:set-state-status-and-roll-up-items area-dat run-id test-name item-path new-state new-status new-comment) ;; (mt:process-triggers run-id test-id new-state new-status) #t)) ;;(mt:test-set-state-status-by-id run-id test-id new-state new-status new-comment))) (define (mt:lazy-read-test-config test-name) Index: rmt.scm ================================================================== --- rmt.scm +++ rmt.scm @@ -31,29 +31,29 @@ ;;====================================================================== ;; if a server is either running or in the process of starting call client:setup ;; else return #f to let the calling proc know that there is no server available ;; -(define (rmt:get-connection-info areapath) ;; TODO: push areapath down. - (let ((cinfo (remote-conndat *runremote*)) +(define (rmt:get-connection-info area-dat areapath) ;; TODO: push areapath down. + (let ((cinfo (remote-conndat area-dat)) (run-id 0)) (if cinfo cinfo - (if (server:check-if-running areapath) + (if (server:check-if-running area-dat areapath) (client:setup areapath) #f)))) (define *send-receive-mutex* (make-mutex)) ;; should have separate mutex per run-id -;; RA => e.g. usage (rmt:send-receive 'get-var #f (list varname)) +;; RA => e.g. usage (rmt:send-receive area-dat 'get-var #f (list varname)) ;; -(define (rmt:send-receive cmd rid params #!key (attemptnum 1)) ;; start attemptnum at 1 so the modulo below works as expected +(define (rmt:send-receive area-dat cmd rid params #!key (attemptnum 1)) ;; start attemptnum at 1 so the modulo below works as expected ;; do all the prep locked under the rmt-mutex (mutex-lock! *rmt-mutex*) - ;; 1. check if server is started IFF cmd is a write OR if we are not on the homehost, store in *runremote* + ;; 1. check if server is started IFF cmd is a write OR if we are not on the homehost, store in area-dat ;; 2. check the age of the connections. refresh the connection if it is older than timeout-20 seconds. ;; 3. do the query, if on homehost use local access ;; (let* ((start-time (current-seconds))) ;; snapshot time so all use cases get same value (cond @@ -60,120 +60,121 @@ ;; give up if more than 15 attempts ((> attemptnum 15) (debug:print 0 *default-log-port* "ERROR: 15 tries to start/connect to server. Giving up.") (exit 1)) ;; reset the connection if it has been unused too long - ((and *runremote* - (remote-conndat *runremote*) - (let ((expire-time (+ (- start-time (remote-server-timeout *runremote*))(random 30)))) ;; add 30 seconds of noise so that not all running tests expire at the same time causing a storm of server starts - (< (http-transport:server-dat-get-last-access (remote-conndat *runremote*)) expire-time))) + ((and area-dat + (remote-conndat area-dat) + (let ((expire-time (+ (- start-time (remote-server-timeout area-dat))(random 30)))) ;; add 30 seconds of noise so that not all running tests expire at the same time causing a storm of server starts + (< (http-transport:server-dat-get-last-access (remote-conndat area-dat)) expire-time))) (debug:print-info 12 *default-log-port* "rmt:send-receive, case 8") - (remote-conndat-set! *runremote* #f) + (remote-conndat-set! area-dat #f) (mutex-unlock! *rmt-mutex*) - (rmt:send-receive cmd rid params attemptnum: attemptnum)) + (rmt:send-receive area-dat cmd rid params attemptnum: attemptnum)) ;; ensure we have a record for our connection for given area - ((not *runremote*) - (set! *runremote* (make-remote)) + ((not area-dat) + (print "ERROR!!!!!!! SHOULD NEVER GET HERE NOW.") + (set! area-dat (make-remote)) (mutex-unlock! *rmt-mutex*) (debug:print-info 12 *default-log-port* "rmt:send-receive, case 1") - (rmt:send-receive cmd rid params attemptnum: attemptnum)) + (rmt:send-receive area-dat cmd rid params attemptnum: attemptnum)) ;; ensure we have a homehost record - ((not (pair? (remote-hh-dat *runremote*))) ;; not on homehost + ((not (pair? (remote-hh-dat area-dat))) ;; not on homehost (thread-sleep! 0.1) ;; since we shouldn't get here, delay a little - (remote-hh-dat-set! *runremote* (common:get-homehost)) + (remote-hh-dat-set! area-dat (common:get-homehost)) (mutex-unlock! *rmt-mutex*) (debug:print-info 12 *default-log-port* "rmt:send-receive, case 2") - (rmt:send-receive cmd rid params attemptnum: attemptnum)) + (rmt:send-receive area-dat cmd rid params attemptnum: attemptnum)) ;; on homehost and this is a read - ((and (cdr (remote-hh-dat *runremote*)) ;; on homehost + ((and (cdr (remote-hh-dat area-dat)) ;; on homehost (member cmd api:read-only-queries)) ;; this is a read (mutex-unlock! *rmt-mutex*) (debug:print-info 12 *default-log-port* "rmt:send-receive, case 3") - (rmt:open-qry-close-locally cmd 0 params)) + (rmt:open-qry-close-locally area-dat cmd 0 params)) ;; on homehost and this is a write, we already have a server, but server has died - ((and (cdr (remote-hh-dat *runremote*)) ;; on homehost + ((and (cdr (remote-hh-dat area-dat)) ;; on homehost (not (member cmd api:read-only-queries)) ;; this is a write - (remote-server-url *runremote*) ;; have a server - (not (server:check-if-running *toppath*))) ;; server has died. - (set! *runremote* (make-remote)) + (remote-server-url area-dat) ;; have a server + (not (server:check-if-running area-dat *toppath*))) ;; server has died. + (remote-server-url-set! area-dat #f) (mutex-unlock! *rmt-mutex*) (debug:print-info 12 *default-log-port* "rmt:send-receive, case 4.1") - (rmt:send-receive cmd rid params attemptnum: attemptnum)) + (rmt:send-receive area-dat cmd rid params attemptnum: attemptnum)) ;; on homehost and this is a write, we already have a server - ((and (cdr (remote-hh-dat *runremote*)) ;; on homehost + ((and (cdr (remote-hh-dat area-dat)) ;; on homehost (not (member cmd api:read-only-queries)) ;; this is a write - (remote-server-url *runremote*)) ;; have a server + (remote-server-url area-dat)) ;; have a server (mutex-unlock! *rmt-mutex*) (debug:print-info 12 *default-log-port* "rmt:send-receive, case 4") - (rmt:open-qry-close-locally cmd 0 params)) + (rmt:open-qry-close-locally area-dat cmd 0 params)) ;; on homehost, no server contact made and this is a write, passively start a server - ((and (cdr (remote-hh-dat *runremote*)) ; new - (not (remote-server-url *runremote*)) + ((and (cdr (remote-hh-dat area-dat)) ; new + (not (remote-server-url area-dat)) (not (member cmd api:read-only-queries))) (debug:print-info 12 *default-log-port* "rmt:send-receive, case 5") - (let ((server-url (server:check-if-running *toppath*))) ;; (server:read-dotserver->url *toppath*))) ;; (server:check-if-running *toppath*))) ;; Do NOT want to run server:check-if-running - very expensive to do for every write call + (let ((server-url (server:check-if-running area-dat *toppath*))) ;; (server:read-dotserver->url *toppath*))) ;; (server:check-if-running *toppath*))) ;; Do NOT want to run server:check-if-running - very expensive to do for every write call (if server-url - (remote-server-url-set! *runremote* server-url) ;; the string can be consumed by the client setup if needed + (remote-server-url-set! area-dat server-url) ;; the string can be consumed by the client setup if needed (server:kind-run *toppath*))) (mutex-unlock! *rmt-mutex*) (debug:print-info 12 *default-log-port* "rmt:send-receive, case 5.1") - (rmt:open-qry-close-locally cmd 0 params)) + (rmt:open-qry-close-locally area-dat cmd 0 params)) - ((and (not (cdr (remote-hh-dat *runremote*))) ;; not on a homehost - (not (remote-conndat *runremote*))) ;; and no connection - (debug:print-info 12 *default-log-port* "rmt:send-receive, case 6 hh-dat: " (remote-hh-dat *runremote*) " conndat: " (remote-conndat *runremote*)) + ((and (not (cdr (remote-hh-dat area-dat))) ;; not on a homehost + (not (remote-conndat area-dat))) ;; and no connection + (debug:print-info 12 *default-log-port* "rmt:send-receive, case 6 hh-dat: " (remote-hh-dat area-dat) " conndat: " (remote-conndat area-dat)) (mutex-unlock! *rmt-mutex*) - (server:start-and-wait *toppath*) - (remote-conndat-set! *runremote* (rmt:get-connection-info *toppath*)) ;; calls client:setup which calls client:setup-http - (rmt:send-receive cmd rid params attemptnum: attemptnum)) ;; TODO: add back-off timeout as + (server:start-and-wait area-dat *toppath*) + (remote-conndat-set! area-dat (rmt:get-connection-info area-dat *toppath*)) ;; calls client:setup which calls client:setup-http + (rmt:send-receive area-dat cmd rid params attemptnum: attemptnum)) ;; TODO: add back-off timeout as ;; all set up if get this far, dispatch the query - ((cdr (remote-hh-dat *runremote*)) ;; we are on homehost + ((cdr (remote-hh-dat area-dat)) ;; we are on homehost (mutex-unlock! *rmt-mutex*) (debug:print-info 12 *default-log-port* "rmt:send-receive, case 7") - (rmt:open-qry-close-locally cmd (if rid rid 0) params)) + (rmt:open-qry-close-locally area-dat cmd (if rid rid 0) params)) ;; not on homehost, do server query (else (mutex-unlock! *rmt-mutex*) (debug:print-info 12 *default-log-port* "rmt:send-receive, case 9") (mutex-lock! *rmt-mutex*) - (let* ((conninfo (remote-conndat *runremote*)) - (dat (case (remote-transport *runremote*) + (let* ((conninfo (remote-conndat area-dat)) + (dat (case (remote-transport area-dat) ((http) (condition-case ;; handling here has caused a lot of problems. However it is needed to deal with attemtped communication to servers that have gone away (http-transport:client-api-send-receive 0 conninfo cmd params) ((commfail)(vector #f "communications fail")) ((exn)(vector #f "other fail" (print-call-chain))))) (else - (debug:print 0 *default-log-port* "ERROR: transport " (remote-transport *runremote*) " not supported") + (debug:print 0 *default-log-port* "ERROR: transport " (remote-transport area-dat) " not supported") (exit)))) (success (if (vector? dat) (vector-ref dat 0) #f)) (res (if (vector? dat) (vector-ref dat 1) #f))) (if (vector? conninfo)(http-transport:server-dat-update-last-access conninfo)) ;; refresh access time ;; (mutex-unlock! *rmt-mutex*) - (debug:print-info 12 *default-log-port* "rmt:send-receive, case 9. conninfo=" conninfo " dat=" dat " *runremote* = "*runremote*) + (debug:print-info 12 *default-log-port* "rmt:send-receive, case 9. conninfo=" conninfo " dat=" dat " area-dat = "area-dat) (if success - (case (remote-transport *runremote*) + (case (remote-transport area-dat) ((http) (mutex-unlock! *rmt-mutex*) res) (else - (debug:print 0 *default-log-port* "ERROR: transport " (remote-transport *runremote*) " is unknown") + (debug:print 0 *default-log-port* "ERROR: transport " (remote-transport area-dat) " is unknown") (mutex-unlock! *rmt-mutex*) (exit 1))) (begin (debug:print 0 *default-log-port* "WARNING: communication failed. Trying again, try num: " attemptnum) - (remote-conndat-set! *runremote* #f) - (remote-server-url-set! *runremote* #f) + (remote-conndat-set! area-dat #f) + (remote-server-url-set! area-dat #f) (debug:print-info 12 *default-log-port* "rmt:send-receive, case 9.1") (mutex-unlock! *rmt-mutex*) - (server:start-and-wait *toppath*) - (rmt:send-receive cmd rid params attemptnum: (+ attemptnum 1))))))))) + (server:start-and-wait area-dat *toppath*) + (rmt:send-receive area-dat cmd rid params attemptnum: (+ attemptnum 1))))))))) -;; (define (rmt:update-db-stats run-id rawcmd params duration) +;; (define (rmt:update-db-stats area-dat run-id rawcmd params duration) ;; (mutex-lock! *db-stats-mutex*) ;; (handle-exceptions ;; exn ;; (begin ;; (debug:print 0 *default-log-port* "WARNING: stats collection failed in update-db-stats") @@ -188,11 +189,11 @@ ;; (set! stat-vec newvec))) ;; (vector-set! stat-vec 0 (+ (vector-ref stat-vec 0) 1)) ;; (vector-set! stat-vec 1 (+ (vector-ref stat-vec 1) duration)))) ;; (mutex-unlock! *db-stats-mutex*)) -(define (rmt:print-db-stats) +(define (rmt:print-db-stats area-dat) (let ((fmtstr "~40a~7-d~9-d~20,2-f")) ;; "~20,2-f" (debug:print 18 *default-log-port* "DB Stats\n========") (debug:print 18 *default-log-port* (format #f "~40a~8a~10a~10a" "Cmd" "Count" "TotTime" "Avg")) (for-each (lambda (cmd) (let ((cmd-dat (hash-table-ref *db-stats* cmd))) @@ -200,11 +201,11 @@ (sort (hash-table-keys *db-stats*) (lambda (a b) (> (vector-ref (hash-table-ref *db-stats* a) 0) (vector-ref (hash-table-ref *db-stats* b) 0))))))) -(define (rmt:get-max-query-average run-id) +(define (rmt:get-max-query-average area-dat run-id) (mutex-lock! *db-stats-mutex*) (let* ((runkey (conc "run-id=" run-id " ")) (cmds (filter (lambda (x) (substring-index runkey x)) (hash-table-keys *db-stats*))) @@ -225,11 +226,11 @@ (cons 'none 0)) (loop (car tal)(cdr tal) newmax-cmd currmax))))))) (mutex-unlock! *db-stats-mutex*) res)) -(define (rmt:open-qry-close-locally cmd run-id params #!key (remretries 5)) +(define (rmt:open-qry-close-locally area-dat cmd run-id params #!key (remretries 5)) (let* ((qry-is-write (not (member cmd api:read-only-queries))) (db-file-path (db:dbfile-path)) ;; 0)) (dbstruct-local (db:setup)) ;; make-dbr:dbstruct path: dbdir local: #t))) (read-only (not (file-write-access? db-file-path))) (start (current-milliseconds)) @@ -244,25 +245,25 @@ (if (not success) (if (> remretries 0) (begin (debug:print-error 0 *default-log-port* "local query failed. Trying again.") (thread-sleep! (/ (random 5000) 1000)) ;; some random delay - (rmt:open-qry-close-locally cmd run-id params remretries: (- remretries 1))) + (rmt:open-qry-close-locally area-dat cmd run-id params remretries: (- remretries 1))) (begin (debug:print-error 0 *default-log-port* "too many retries in rmt:open-qry-close-locally, giving up") #f)) (begin - ;; (rmt:update-db-stats run-id cmd params duration) + ;; (rmt:update-db-stats area-dat run-id cmd params duration) ;; mark this run as dirty if this was a write, the watchdog is responsible for syncing it (if qry-is-write (let ((start-time (current-seconds))) (mutex-lock! *db-multi-sync-mutex*) (set! *db-last-access* start-time) ;; THIS IS PROBABLY USELESS? (we are on a client) (mutex-unlock! *db-multi-sync-mutex*))))) res)) -(define (rmt:send-receive-no-auto-client-setup connection-info cmd run-id params) +(define (rmt:send-receive-no-auto-client-setup area-dat connection-info cmd run-id params) (let* ((run-id (if run-id run-id 0)) (res (handle-exceptions exn #f (http-transport:client-api-send-receive run-id connection-info cmd params)))) @@ -269,16 +270,16 @@ (if (and res (vector-ref res 0)) (vector-ref res 1) ;;; YES!! THIS IS CORRECT!! CHANGE IT HERE, THEN CHANGE rmt:send-receive ALSO!!! #f))) ;; ;; Wrap json library for strings (why the ports crap in the first place?) -;; (define (rmt:dat->json-str dat) +;; (define (rmt:dat->json-str area-dat dat) ;; (with-output-to-string ;; (lambda () ;; (json-write dat)))) ;; -;; (define (rmt:json-str->dat json-str) +;; (define (rmt:json-str->dat area-dat json-str) ;; (with-input-from-string json-str ;; (lambda () ;; (json-read)))) ;;====================================================================== @@ -289,151 +290,151 @@ ;;====================================================================== ;; S E R V E R ;;====================================================================== -(define (rmt:kill-server run-id) - (rmt:send-receive 'kill-server run-id (list run-id))) +(define (rmt:kill-server area-dat run-id) + (rmt:send-receive area-dat 'kill-server run-id (list run-id))) -(define (rmt:start-server run-id) - (rmt:send-receive 'start-server 0 (list run-id))) +(define (rmt:start-server area-dat run-id) + (rmt:send-receive area-dat 'start-server 0 (list run-id))) ;;====================================================================== ;; M I S C ;;====================================================================== -(define (rmt:login run-id) - (rmt:send-receive 'login run-id (list *toppath* megatest-version *my-client-signature*))) +(define (rmt:login area-dat run-id) + (rmt:send-receive area-dat 'login run-id (list *toppath* megatest-version *my-client-signature*))) ;; This login does no retries under the hood - it acts a bit like a ping. ;; Deprecated for nmsg-transport. ;; -(define (rmt:login-no-auto-client-setup connection-info) +(define (rmt:login-no-auto-client-setup area-dat connection-info) (case *transport-type* ;; run-id of 0 is just a placeholder - ((http)(rmt:send-receive-no-auto-client-setup connection-info 'login 0 (list *toppath* megatest-version *my-client-signature*))) + ((http)(rmt:send-receive-no-auto-client-setup area-dat connection-info 'login 0 (list *toppath* megatest-version *my-client-signature*))) ;;((nmsg)(nmsg-transport:client-api-send-receive run-id connection-info 'login (list *toppath* megatest-version run-id *my-client-signature*))) )) ;; hand off a call to one of the db:queries statements ;; added run-id to make looking up the correct db possible ;; -(define (rmt:general-call stmtname run-id . params) - (rmt:send-receive 'general-call run-id (append (list stmtname run-id) params))) +(define (rmt:general-call area-dat stmtname run-id . params) + (rmt:send-receive area-dat 'general-call run-id (append (list stmtname run-id) params))) ;; given a hostname, return a pair of cpu load and update time representing latest intelligence from tests running on that host -(define (rmt:get-latest-host-load hostname) - (rmt:send-receive 'get-latest-host-load 0 (list hostname))) +(define (rmt:get-latest-host-load area-dat hostname) + (rmt:send-receive area-dat 'get-latest-host-load 0 (list hostname))) -;; (define (rmt:sync-inmem->db run-id) -;; (rmt:send-receive 'sync-inmem->db run-id '())) +;; (define (rmt:sync-inmem->db area-dat run-id) +;; (rmt:send-receive area-dat 'sync-inmem->db run-id '())) -(define (rmt:sdb-qry qry val run-id) +(define (rmt:sdb-qry area-dat qry val run-id) ;; add caching if qry is 'getid or 'getstr - (rmt:send-receive 'sdb-qry run-id (list qry val))) + (rmt:send-receive area-dat 'sdb-qry run-id (list qry val))) ;; NOT COMPLETED -(define (rmt:runtests user run-id testpatt params) - (rmt:send-receive 'runtests run-id testpatt)) +(define (rmt:runtests area-dat user run-id testpatt params) + (rmt:send-receive area-dat 'runtests run-id testpatt)) ;;====================================================================== ;; T E S T M E T A ;;====================================================================== -(define (rmt:get-tests-tags) - (rmt:send-receive 'get-tests-tags #f '())) +(define (rmt:get-tests-tags area-dat) + (rmt:send-receive area-dat 'get-tests-tags #f '())) ;;====================================================================== ;; K E Y S ;;====================================================================== ;; These require run-id because the values come from the run! ;; -(define (rmt:get-key-val-pairs run-id) - (rmt:send-receive 'get-key-val-pairs run-id (list run-id))) +(define (rmt:get-key-val-pairs area-dat run-id) + (rmt:send-receive area-dat 'get-key-val-pairs run-id (list run-id))) -(define (rmt:get-keys) +(define (rmt:get-keys area-dat) (if *db-keys* *db-keys* - (let ((res (rmt:send-receive 'get-keys #f '()))) + (let ((res (rmt:send-receive area-dat 'get-keys #f '()))) (set! *db-keys* res) res))) -(define (rmt:get-keys-write) ;; dummy query to force server start - (let ((res (rmt:send-receive 'get-keys-write #f '()))) +(define (rmt:get-keys-write area-dat) ;; dummy query to force server start + (let ((res (rmt:send-receive area-dat 'get-keys-write #f '()))) (set! *db-keys* res) res)) ;; we don't reuse run-id's (except possibly *after* a db cleanup) so it is safe ;; to cache the resuls in a hash ;; -(define (rmt:get-key-vals run-id) +(define (rmt:get-key-vals area-dat run-id) (or (hash-table-ref/default *keyvals* run-id #f) - (let ((res (rmt:send-receive 'get-key-vals #f (list run-id)))) + (let ((res (rmt:send-receive area-dat 'get-key-vals #f (list run-id)))) (hash-table-set! *keyvals* run-id res) res))) -(define (rmt:get-targets) - (rmt:send-receive 'get-targets #f '())) +(define (rmt:get-targets area-dat) + (rmt:send-receive area-dat 'get-targets #f '())) -(define (rmt:get-target run-id) - (rmt:send-receive 'get-target run-id (list run-id))) +(define (rmt:get-target area-dat run-id) + (rmt:send-receive area-dat 'get-target run-id (list run-id))) ;;====================================================================== ;; T E S T S ;;====================================================================== ;; Just some syntatic sugar -(define (rmt:register-test run-id test-name item-path) - (rmt:general-call 'register-test run-id run-id test-name item-path)) +(define (rmt:register-test area-dat run-id test-name item-path) + (rmt:general-call area-dat 'register-test run-id run-id test-name item-path)) -(define (rmt:get-test-id run-id testname item-path) - (rmt:send-receive 'get-test-id run-id (list run-id testname item-path))) +(define (rmt:get-test-id area-dat run-id testname item-path) + (rmt:send-receive area-dat 'get-test-id run-id (list run-id testname item-path))) -(define (rmt:get-test-info-by-id run-id test-id) +(define (rmt:get-test-info-by-id area-dat run-id test-id) (if (and (number? run-id)(number? test-id)) - (rmt:send-receive 'get-test-info-by-id run-id (list run-id test-id)) + (rmt:send-receive area-dat 'get-test-info-by-id run-id (list run-id test-id)) (begin (debug:print 0 *default-log-port* "WARNING: Bad data handed to rmt:get-test-info-by-id run-id=" run-id ", test-id=" test-id) (print-call-chain (current-error-port)) #f))) -(define (rmt:test-get-rundir-from-test-id run-id test-id) - (rmt:send-receive 'test-get-rundir-from-test-id run-id (list run-id test-id))) +(define (rmt:test-get-rundir-from-test-id area-dat run-id test-id) + (rmt:send-receive area-dat 'test-get-rundir-from-test-id run-id (list run-id test-id))) -(define (rmt:open-test-db-by-test-id run-id test-id #!key (work-area #f)) +(define (rmt:open-test-db-by-test-id area-dat run-id test-id #!key (work-area #f)) (let* ((test-path (if (string? work-area) work-area - (rmt:test-get-rundir-from-test-id run-id test-id)))) + (rmt:test-get-rundir-from-test-id area-dat run-id test-id)))) (debug:print 3 *default-log-port* "TEST PATH: " test-path) (open-test-db test-path))) ;; WARNING: This currently bypasses the transaction wrapped writes system -(define (rmt:test-set-state-status-by-id run-id test-id newstate newstatus newcomment) - (rmt:send-receive 'test-set-state-status-by-id run-id (list run-id test-id newstate newstatus newcomment))) +(define (rmt:test-set-state-status-by-id area-dat run-id test-id newstate newstatus newcomment) + (rmt:send-receive area-dat 'test-set-state-status-by-id run-id (list run-id test-id newstate newstatus newcomment))) -(define (rmt:set-tests-state-status run-id testnames currstate currstatus newstate newstatus) - (rmt:send-receive 'set-tests-state-status run-id (list run-id testnames currstate currstatus newstate newstatus))) +(define (rmt:set-tests-state-status area-dat run-id testnames currstate currstatus newstate newstatus) + (rmt:send-receive area-dat 'set-tests-state-status run-id (list run-id testnames currstate currstatus newstate newstatus))) -(define (rmt:get-tests-for-run run-id testpatt states statuses offset limit not-in sort-by sort-order qryvals last-update mode) +(define (rmt:get-tests-for-run area-dat run-id testpatt states statuses offset limit not-in sort-by sort-order qryvals last-update mode) (if (number? run-id) - (rmt:send-receive 'get-tests-for-run run-id (list run-id testpatt states statuses offset limit not-in sort-by sort-order qryvals last-update mode)) + (rmt:send-receive area-dat 'get-tests-for-run run-id (list run-id testpatt states statuses offset limit not-in sort-by sort-order qryvals last-update mode)) (begin (debug:print-error 0 *default-log-port* "rmt:get-tests-for-run called with bad run-id=" run-id) (print-call-chain (current-error-port)) '()))) ;; get stuff via synchash -(define (rmt:synchash-get run-id proc synckey keynum params) - (rmt:send-receive 'synchash-get run-id (list run-id proc synckey keynum params))) +(define (rmt:synchash-get area-dat run-id proc synckey keynum params) + (rmt:send-receive area-dat 'synchash-get run-id (list run-id proc synckey keynum params))) ;; IDEA: Threadify these - they spend a lot of time waiting ... ;; -(define (rmt:get-tests-for-runs-mindata run-ids testpatt states status not-in) +(define (rmt:get-tests-for-runs-mindata area-dat run-ids testpatt states status not-in) (let ((multi-run-mutex (make-mutex)) (run-id-list (if run-ids run-ids - (rmt:get-all-run-ids))) + (rmt:get-all-run-ids area-dat))) (result '())) (if (null? run-id-list) '() (let loop ((hed (car run-id-list)) (tal (cdr run-id-list)) @@ -440,11 +441,11 @@ (threads '())) (if (> (length threads) 5) (loop hed tal (filter (lambda (th)(not (member (thread-state th) '(terminated dead)))) threads)) (let* ((newthread (make-thread (lambda () - (let ((res (rmt:send-receive 'get-tests-for-run-mindata hed (list hed testpatt states status not-in)))) + (let ((res (rmt:send-receive area-dat 'get-tests-for-run-mindata hed (list hed testpatt states status not-in)))) (if (list? res) (begin (mutex-lock! multi-run-mutex) (set! result (append result res)) (mutex-unlock! multi-run-mutex)) @@ -458,208 +459,208 @@ (loop (car tal)(cdr tal) newthreads)))))) result)) ;; ;; IDEA: Threadify these - they spend a lot of time waiting ... ;; ;; -;; (define (rmt:get-tests-for-runs-mindata run-ids testpatt states status not-in) +;; (define (rmt:get-tests-for-runs-mindata area-dat run-ids testpatt states status not-in) ;; (let ((run-id-list (if run-ids ;; run-ids -;; (rmt:get-all-run-ids)))) +;; (rmt:get-all-run-ids area-dat)))) ;; (apply append (map (lambda (run-id) -;; (rmt:send-receive 'get-tests-for-run-mindata run-id (list run-ids testpatt states status not-in))) +;; (rmt:send-receive area-dat 'get-tests-for-run-mindata run-id (list run-ids testpatt states status not-in))) ;; run-id-list)))) -(define (rmt:delete-test-records run-id test-id) - (rmt:send-receive 'delete-test-records run-id (list run-id test-id))) +(define (rmt:delete-test-records area-dat run-id test-id) + (rmt:send-receive area-dat 'delete-test-records run-id (list run-id test-id))) ;; This is not needed as test steps are deleted on test delete call ;; -;; (define (rmt:delete-test-step-records run-id test-id) -;; (rmt:send-receive 'delete-test-step-records run-id (list run-id test-id))) - -(define (rmt:test-set-state-status run-id test-id state status msg) - (rmt:send-receive 'test-set-state-status run-id (list run-id test-id state status msg))) - -(define (rmt:test-toplevel-num-items run-id test-name) - (rmt:send-receive 'test-toplevel-num-items run-id (list run-id test-name))) - -;; (define (rmt:get-previous-test-run-record run-id test-name item-path) -;; (rmt:send-receive 'get-previous-test-run-record run-id (list run-id test-name item-path))) - -(define (rmt:get-matching-previous-test-run-records run-id test-name item-path) - (rmt:send-receive 'get-matching-previous-test-run-records run-id (list run-id test-name item-path))) - -(define (rmt:test-get-logfile-info run-id test-name) - (rmt:send-receive 'test-get-logfile-info run-id (list run-id test-name))) - -(define (rmt:test-get-records-for-index-file run-id test-name) - (rmt:send-receive 'test-get-records-for-index-file run-id (list run-id test-name))) - -(define (rmt:get-testinfo-state-status run-id test-id) - (rmt:send-receive 'get-testinfo-state-status run-id (list run-id test-id))) - -(define (rmt:test-set-log! run-id test-id logf) - (if (string? logf)(rmt:general-call 'test-set-log run-id logf test-id))) - -(define (rmt:test-set-top-process-pid run-id test-id pid) - (rmt:send-receive 'test-set-top-process-pid run-id (list run-id test-id pid))) - -(define (rmt:test-get-top-process-pid run-id test-id) - (rmt:send-receive 'test-get-top-process-pid run-id (list run-id test-id))) - -(define (rmt:get-run-ids-matching-target keynames target res runname testpatt statepatt statuspatt) - (rmt:send-receive 'get-run-ids-matching-target #f (list keynames target res runname testpatt statepatt statuspatt))) +;; (define (rmt:delete-test-step-records area-dat run-id test-id) +;; (rmt:send-receive area-dat 'delete-test-step-records run-id (list run-id test-id))) + +(define (rmt:test-set-state-status area-dat run-id test-id state status msg) + (rmt:send-receive area-dat 'test-set-state-status run-id (list run-id test-id state status msg))) + +(define (rmt:test-toplevel-num-items area-dat run-id test-name) + (rmt:send-receive area-dat 'test-toplevel-num-items run-id (list run-id test-name))) + +;; (define (rmt:get-previous-test-run-record area-dat run-id test-name item-path) +;; (rmt:send-receive area-dat 'get-previous-test-run-record run-id (list run-id test-name item-path))) + +(define (rmt:get-matching-previous-test-run-records area-dat run-id test-name item-path) + (rmt:send-receive area-dat 'get-matching-previous-test-run-records run-id (list run-id test-name item-path))) + +(define (rmt:test-get-logfile-info area-dat run-id test-name) + (rmt:send-receive area-dat 'test-get-logfile-info run-id (list run-id test-name))) + +(define (rmt:test-get-records-for-index-file area-dat run-id test-name) + (rmt:send-receive area-dat 'test-get-records-for-index-file run-id (list run-id test-name))) + +(define (rmt:get-testinfo-state-status area-dat run-id test-id) + (rmt:send-receive area-dat 'get-testinfo-state-status run-id (list run-id test-id))) + +(define (rmt:test-set-log! area-dat run-id test-id logf) + (if (string? logf)(rmt:general-call area-dat 'test-set-log run-id logf test-id))) + +(define (rmt:test-set-top-process-pid area-dat run-id test-id pid) + (rmt:send-receive area-dat 'test-set-top-process-pid run-id (list run-id test-id pid))) + +(define (rmt:test-get-top-process-pid area-dat run-id test-id) + (rmt:send-receive area-dat 'test-get-top-process-pid run-id (list run-id test-id))) + +(define (rmt:get-run-ids-matching-target area-dat keynames target res runname testpatt statepatt statuspatt) + (rmt:send-receive area-dat 'get-run-ids-matching-target #f (list keynames target res runname testpatt statepatt statuspatt))) ;; NOTE: This will open and access ALL run databases. ;; -(define (rmt:test-get-paths-matching-keynames-target-new keynames target res testpatt statepatt statuspatt runname) - (let ((run-ids (rmt:get-run-ids-matching-target keynames target res runname testpatt statepatt statuspatt))) +(define (rmt:test-get-paths-matching-keynames-target-new area-dat keynames target res testpatt statepatt statuspatt runname) + (let ((run-ids (rmt:get-run-ids-matching-target area-dat keynames target res runname testpatt statepatt statuspatt))) (apply append (map (lambda (run-id) - (rmt:send-receive 'test-get-paths-matching-keynames-target-new run-id (list run-id keynames target res testpatt statepatt statuspatt runname))) + (rmt:send-receive area-dat 'test-get-paths-matching-keynames-target-new run-id (list run-id keynames target res testpatt statepatt statuspatt runname))) run-ids)))) -;; (define (rmt:get-run-ids-matching keynames target res) -;; (rmt:send-receive #f 'get-run-ids-matching (list keynames target res))) - -(define (rmt:get-prereqs-not-met run-id waitons ref-test-name ref-item-path #!key (mode '(normal))(itemmaps #f)) - (rmt:send-receive 'get-prereqs-not-met run-id (list run-id waitons ref-test-name ref-item-path mode itemmaps))) - -(define (rmt:get-count-tests-running-for-run-id run-id) - (rmt:send-receive 'get-count-tests-running-for-run-id run-id (list run-id))) +;; (define (rmt:get-run-ids-matching area-dat keynames target res) +;; (rmt:send-receive area-dat #f 'get-run-ids-matching (list keynames target res))) + +(define (rmt:get-prereqs-not-met area-dat run-id waitons ref-test-name ref-item-path #!key (mode '(normal))(itemmaps #f)) + (rmt:send-receive area-dat 'get-prereqs-not-met run-id (list run-id waitons ref-test-name ref-item-path mode itemmaps))) + +(define (rmt:get-count-tests-running-for-run-id area-dat run-id) + (rmt:send-receive area-dat 'get-count-tests-running-for-run-id run-id (list run-id))) ;; Statistical queries -(define (rmt:get-count-tests-running run-id) - (rmt:send-receive 'get-count-tests-running run-id (list run-id))) - -(define (rmt:get-count-tests-running-for-testname run-id testname) - (rmt:send-receive 'get-count-tests-running-for-testname run-id (list run-id testname))) - -(define (rmt:get-count-tests-running-in-jobgroup run-id jobgroup) - (rmt:send-receive 'get-count-tests-running-in-jobgroup run-id (list run-id jobgroup))) +(define (rmt:get-count-tests-running area-dat run-id) + (rmt:send-receive area-dat 'get-count-tests-running run-id (list run-id))) + +(define (rmt:get-count-tests-running-for-testname area-dat run-id testname) + (rmt:send-receive area-dat 'get-count-tests-running-for-testname run-id (list run-id testname))) + +(define (rmt:get-count-tests-running-in-jobgroup area-dat run-id jobgroup) + (rmt:send-receive area-dat 'get-count-tests-running-in-jobgroup run-id (list run-id jobgroup))) ;; state and status are extra hints not usually used in the calculation ;; -(define (rmt:set-state-status-and-roll-up-items run-id test-name item-path state status comment) - (rmt:send-receive 'set-state-status-and-roll-up-items run-id (list run-id test-name item-path state status comment))) - -(define (rmt:update-pass-fail-counts run-id test-name) - (rmt:general-call 'update-pass-fail-counts run-id test-name test-name test-name)) - -(define (rmt:top-test-set-per-pf-counts run-id test-name) - (rmt:send-receive 'top-test-set-per-pf-counts run-id (list run-id test-name))) - -(define (rmt:get-raw-run-stats run-id) - (rmt:send-receive 'get-raw-run-stats run-id (list run-id))) +(define (rmt:set-state-status-and-roll-up-items area-dat run-id test-name item-path state status comment) + (rmt:send-receive area-dat 'set-state-status-and-roll-up-items run-id (list run-id test-name item-path state status comment))) + +(define (rmt:update-pass-fail-counts area-dat run-id test-name) + (rmt:general-call area-dat 'update-pass-fail-counts run-id test-name test-name test-name)) + +(define (rmt:top-test-set-per-pf-counts area-dat run-id test-name) + (rmt:send-receive area-dat 'top-test-set-per-pf-counts run-id (list run-id test-name))) + +(define (rmt:get-raw-run-stats area-dat run-id) + (rmt:send-receive area-dat 'get-raw-run-stats run-id (list run-id))) ;;====================================================================== ;; R U N S ;;====================================================================== -(define (rmt:get-run-info run-id) - (rmt:send-receive 'get-run-info run-id (list run-id))) +(define (rmt:get-run-info area-dat run-id) + (rmt:send-receive area-dat 'get-run-info run-id (list run-id))) -(define (rmt:get-num-runs runpatt) - (rmt:send-receive 'get-num-runs #f (list runpatt))) +(define (rmt:get-num-runs area-dat runpatt) + (rmt:send-receive area-dat 'get-num-runs #f (list runpatt))) ;; Use the special run-id == #f scenario here since there is no run yet -(define (rmt:register-run keyvals runname state status user) - (rmt:send-receive 'register-run #f (list keyvals runname state status user))) - -(define (rmt:get-run-name-from-id run-id) - (rmt:send-receive 'get-run-name-from-id run-id (list run-id))) - -(define (rmt:delete-run run-id) - (rmt:send-receive 'delete-run run-id (list run-id))) - -(define (rmt:update-run-stats run-id stats) - (rmt:send-receive 'update-run-stats #f (list run-id stats))) - -(define (rmt:delete-old-deleted-test-records) - (rmt:send-receive 'delete-old-deleted-test-records #f '())) - -(define (rmt:get-runs runpatt count offset keypatts) - (rmt:send-receive 'get-runs #f (list runpatt count offset keypatts))) - -(define (rmt:get-all-run-ids) - (rmt:send-receive 'get-all-run-ids #f '())) - -(define (rmt:get-prev-run-ids run-id) - (rmt:send-receive 'get-prev-run-ids #f (list run-id))) - -(define (rmt:lock/unlock-run run-id lock unlock user) - (rmt:send-receive 'lock/unlock-run #f (list run-id lock unlock user))) +(define (rmt:register-run area-dat keyvals runname state status user) + (rmt:send-receive area-dat 'register-run #f (list keyvals runname state status user))) + +(define (rmt:get-run-name-from-id area-dat run-id) + (rmt:send-receive area-dat 'get-run-name-from-id run-id (list run-id))) + +(define (rmt:delete-run area-dat run-id) + (rmt:send-receive area-dat 'delete-run run-id (list run-id))) + +(define (rmt:update-run-stats area-dat run-id stats) + (rmt:send-receive area-dat 'update-run-stats #f (list run-id stats))) + +(define (rmt:delete-old-deleted-test-records area-dat) + (rmt:send-receive area-dat 'delete-old-deleted-test-records #f '())) + +(define (rmt:get-runs area-dat runpatt count offset keypatts) + (rmt:send-receive area-dat 'get-runs #f (list runpatt count offset keypatts))) + +(define (rmt:get-all-run-ids area-dat) + (rmt:send-receive area-dat 'get-all-run-ids #f '())) + +(define (rmt:get-prev-run-ids area-dat run-id) + (rmt:send-receive area-dat 'get-prev-run-ids #f (list run-id))) + +(define (rmt:lock/unlock-run area-dat run-id lock unlock user) + (rmt:send-receive area-dat 'lock/unlock-run #f (list run-id lock unlock user))) ;; set/get status -(define (rmt:get-run-status run-id) - (rmt:send-receive 'get-run-status #f (list run-id))) - -(define (rmt:set-run-status run-id run-status #!key (msg #f)) - (rmt:send-receive 'set-run-status #f (list run-id run-status msg))) - -(define (rmt:update-run-event_time run-id) - (rmt:send-receive 'update-run-event_time #f (list run-id))) - -(define (rmt:get-runs-by-patt keys runnamepatt targpatt offset limit fields last-runs-update) ;; fields of #f uses default - (rmt:send-receive 'get-runs-by-patt #f (list keys runnamepatt targpatt offset limit fields last-runs-update))) - -(define (rmt:find-and-mark-incomplete run-id ovr-deadtime) - ;; (if (rmt:send-receive 'have-incompletes? run-id (list run-id ovr-deadtime)) - (rmt:send-receive 'mark-incomplete run-id (list run-id ovr-deadtime))) ;; ) - -(define (rmt:get-main-run-stats run-id) - (rmt:send-receive 'get-main-run-stats #f (list run-id))) - -(define (rmt:get-var varname) - (rmt:send-receive 'get-var #f (list varname))) - -(define (rmt:set-var varname value) - (rmt:send-receive 'set-var #f (list varname value))) +(define (rmt:get-run-status area-dat run-id) + (rmt:send-receive area-dat 'get-run-status #f (list run-id))) + +(define (rmt:set-run-status area-dat run-id run-status #!key (msg #f)) + (rmt:send-receive area-dat 'set-run-status #f (list run-id run-status msg))) + +(define (rmt:update-run-event_time area-dat run-id) + (rmt:send-receive area-dat 'update-run-event_time #f (list run-id))) + +(define (rmt:get-runs-by-patt area-dat keys runnamepatt targpatt offset limit fields last-runs-update) ;; fields of #f uses default + (rmt:send-receive area-dat 'get-runs-by-patt #f (list keys runnamepatt targpatt offset limit fields last-runs-update))) + +(define (rmt:find-and-mark-incomplete area-dat run-id ovr-deadtime) + ;; (if (rmt:send-receive area-dat 'have-incompletes? run-id (list run-id ovr-deadtime)) + (rmt:send-receive area-dat 'mark-incomplete run-id (list run-id ovr-deadtime))) ;; ) + +(define (rmt:get-main-run-stats area-dat run-id) + (rmt:send-receive area-dat 'get-main-run-stats #f (list run-id))) + +(define (rmt:get-var area-dat varname) + (rmt:send-receive area-dat 'get-var #f (list varname))) + +(define (rmt:set-var area-dat varname value) + (rmt:send-receive area-dat 'set-var #f (list varname value))) ;;====================================================================== ;; M U L T I R U N Q U E R I E S ;;====================================================================== ;; Need to move this to multi-run section and make associated changes -(define (rmt:find-and-mark-incomplete-all-runs #!key (ovr-deadtime #f)) - (let ((run-ids (rmt:get-all-run-ids))) +(define (rmt:find-and-mark-incomplete-all-runs area-dat #!key (ovr-deadtime #f)) + (let ((run-ids (rmt:get-all-run-ids area-dat))) (for-each (lambda (run-id) - (rmt:find-and-mark-incomplete run-id ovr-deadtime)) + (rmt:find-and-mark-incomplete area-dat run-id ovr-deadtime)) run-ids))) ;; get the previous record for when this test was run where all keys match but runname ;; returns #f if no such test found, returns a single test record if found ;; ;; Run this at the client end since we have to connect to multiple run-id dbs ;; -(define (rmt:get-previous-test-run-record run-id test-name item-path) - (let* ((keyvals (rmt:get-key-val-pairs run-id)) - (keys (rmt:get-keys)) +(define (rmt:get-previous-test-run-record area-dat run-id test-name item-path) + (let* ((keyvals (rmt:get-key-val-pairs area-dat run-id)) + (keys (rmt:get-keys area-dat)) (selstr (string-intersperse keys ",")) (qrystr (string-intersperse (map (lambda (x)(conc x "=?")) keys) " AND "))) (if (not keyvals) #f - (let ((prev-run-ids (rmt:get-prev-run-ids run-id))) + (let ((prev-run-ids (rmt:get-prev-run-ids area-dat run-id))) ;; for each run starting with the most recent look to see if there is a matching test ;; if found then return that matching test record (debug:print 4 *default-log-port* "selstr: " selstr ", qrystr: " qrystr ", keyvals: " keyvals ", previous run ids found: " prev-run-ids) (if (null? prev-run-ids) #f (let loop ((hed (car prev-run-ids)) (tal (cdr prev-run-ids))) - (let ((results (rmt:get-tests-for-run hed (conc test-name "/" item-path) '() '() ;; run-id testpatt states statuses + (let ((results (rmt:get-tests-for-run area-dat hed (conc test-name "/" item-path) '() '() ;; run-id testpatt states statuses #f #f #f ;; offset limit not-in hide/not-hide #f #f #f #f 'normal))) ;; sort-by sort-order qryvals last-update mode (debug:print 4 *default-log-port* "Got tests for run-id " run-id ", test-name " test-name ", item-path " item-path ": " results) (if (and (null? results) (not (null? tal))) (loop (car tal)(cdr tal)) (if (null? results) #f (car results)))))))))) -(define (rmt:get-run-stats) - (rmt:send-receive 'get-run-stats #f '())) +(define (rmt:get-run-stats area-dat) + (rmt:send-receive area-dat 'get-run-stats #f '())) ;;====================================================================== ;; S T E P S ;;====================================================================== @@ -670,82 +671,82 @@ ;; 2. Open the testdat.db file and do the query ;; If not given the work area ;; 1. Do a remote call to get the test path ;; 2. Continue as above ;; -;;(define (rmt:get-steps-for-test run-id test-id) -;; (rmt:send-receive 'get-steps-data run-id (list test-id))) +;;(define (rmt:get-steps-for-test area-dat run-id test-id) +;; (rmt:send-receive area-dat 'get-steps-data run-id (list test-id))) -(define (rmt:teststep-set-status! run-id test-id teststep-name state-in status-in comment logfile) +(define (rmt:teststep-set-status! area-dat run-id test-id teststep-name state-in status-in comment logfile) (let* ((state (items:check-valid-items "state" state-in)) (status (items:check-valid-items "status" status-in))) (if (or (not state)(not status)) (debug:print 3 *default-log-port* "WARNING: Invalid " (if status "status" "state") " value \"" (if status state-in status-in) "\", update your validvalues section in megatest.config")) - (rmt:send-receive 'teststep-set-status! run-id (list run-id test-id teststep-name state-in status-in comment logfile)))) + (rmt:send-receive area-dat 'teststep-set-status! run-id (list run-id test-id teststep-name state-in status-in comment logfile)))) -(define (rmt:get-steps-for-test run-id test-id) - (rmt:send-receive 'get-steps-for-test run-id (list run-id test-id))) +(define (rmt:get-steps-for-test area-dat run-id test-id) + (rmt:send-receive area-dat 'get-steps-for-test run-id (list run-id test-id))) ;;====================================================================== ;; T E S T D A T A ;;====================================================================== -(define (rmt:read-test-data run-id test-id categorypatt #!key (work-area #f)) - (rmt:send-receive 'read-test-data run-id (list run-id test-id categorypatt))) -;; (let ((tdb (rmt:open-test-db-by-test-id run-id test-id work-area: work-area))) +(define (rmt:read-test-data area-dat run-id test-id categorypatt #!key (work-area #f)) + (rmt:send-receive area-dat 'read-test-data run-id (list run-id test-id categorypatt))) +;; (let ((tdb (rmt:open-test-db-by-test-id area-dat run-id test-id work-area: work-area))) ;; (if tdb ;; (tdb:read-test-data tdb test-id categorypatt) ;; '()))) -(define (rmt:testmeta-add-record testname) - (rmt:send-receive 'testmeta-add-record #f (list testname))) - -(define (rmt:testmeta-get-record testname) - (rmt:send-receive 'testmeta-get-record #f (list testname))) - -(define (rmt:testmeta-update-field test-name fld val) - (rmt:send-receive 'testmeta-update-field #f (list test-name fld val))) - -(define (rmt:test-data-rollup run-id test-id status) - (rmt:send-receive 'test-data-rollup run-id (list run-id test-id status))) - -(define (rmt:csv->test-data run-id test-id csvdata) - (rmt:send-receive 'csv->test-data run-id (list run-id test-id csvdata))) +(define (rmt:testmeta-add-record area-dat testname) + (rmt:send-receive area-dat 'testmeta-add-record #f (list testname))) + +(define (rmt:testmeta-get-record area-dat testname) + (rmt:send-receive area-dat 'testmeta-get-record #f (list testname))) + +(define (rmt:testmeta-update-field area-dat test-name fld val) + (rmt:send-receive area-dat 'testmeta-update-field #f (list test-name fld val))) + +(define (rmt:test-data-rollup area-dat run-id test-id status) + (rmt:send-receive area-dat 'test-data-rollup run-id (list run-id test-id status))) + +(define (rmt:csv->test-data area-dat run-id test-id csvdata) + (rmt:send-receive area-dat 'csv->test-data run-id (list run-id test-id csvdata))) ;;====================================================================== ;; T A S K S ;;====================================================================== -(define (rmt:tasks-find-task-queue-records target run-name test-patt state-patt action-patt) - (rmt:send-receive 'find-task-queue-records #f (list target run-name test-patt state-patt action-patt))) - -(define (rmt:tasks-add action owner target runname testpatt params) - (rmt:send-receive 'tasks-add #f (list action owner target runname testpatt params))) - -(define (rmt:tasks-set-state-given-param-key param-key new-state) - (rmt:send-receive 'tasks-set-state-given-param-key #f (list param-key new-state))) - -(define (rmt:tasks-get-last target runname) - (rmt:send-receive 'tasks-get-last #f (list target runname))) +(define (rmt:tasks-find-task-queue-records area-dat target run-name test-patt state-patt action-patt) + (rmt:send-receive area-dat 'find-task-queue-records #f (list target run-name test-patt state-patt action-patt))) + +(define (rmt:tasks-add area-dat action owner target runname testpatt params) + (rmt:send-receive area-dat 'tasks-add #f (list action owner target runname testpatt params))) + +(define (rmt:tasks-set-state-given-param-key area-dat param-key new-state) + (rmt:send-receive area-dat 'tasks-set-state-given-param-key #f (list param-key new-state))) + +(define (rmt:tasks-get-last area-dat target runname) + (rmt:send-receive area-dat 'tasks-get-last #f (list target runname))) ;;====================================================================== ;; A R C H I V E S ;;====================================================================== -(define (rmt:archive-get-allocations testname itempath dneeded) - (rmt:send-receive 'archive-get-allocations #f (list testname itempath dneeded))) - -(define (rmt:archive-register-block-name bdisk-id archive-path) - (rmt:send-receive 'archive-register-block-name #f (list bdisk-id archive-path))) - -(define (rmt:archive-allocate-testsuite/area-to-block block-id testsuite-name areakey) - (rmt:send-receive 'archive-allocate-test-to-block #f (list block-id testsuite-name areakey))) - -(define (rmt:archive-register-disk bdisk-name bdisk-path df) - (rmt:send-receive 'archive-register-disk #f (list bdisk-name bdisk-path df))) - -(define (rmt:test-set-archive-block-id run-id test-id archive-block-id) - (rmt:send-receive 'test-set-archive-block-id run-id (list run-id test-id archive-block-id))) - -(define (rmt:test-get-archive-block-info archive-block-id) - (rmt:send-receive 'test-get-archive-block-info #f (list archive-block-id))) +(define (rmt:archive-get-allocations area-dat testname itempath dneeded) + (rmt:send-receive area-dat 'archive-get-allocations #f (list testname itempath dneeded))) + +(define (rmt:archive-register-block-name area-dat bdisk-id archive-path) + (rmt:send-receive area-dat 'archive-register-block-name #f (list bdisk-id archive-path))) + +(define (rmt:archive-allocate-testsuite/area-to-block area-dat block-id testsuite-name areakey) + (rmt:send-receive area-dat 'archive-allocate-test-to-block #f (list block-id testsuite-name areakey))) + +(define (rmt:archive-register-disk area-dat bdisk-name bdisk-path df) + (rmt:send-receive area-dat 'archive-register-disk #f (list bdisk-name bdisk-path df))) + +(define (rmt:test-set-archive-block-id area-dat run-id test-id archive-block-id) + (rmt:send-receive area-dat 'test-set-archive-block-id run-id (list run-id test-id archive-block-id))) + +(define (rmt:test-get-archive-block-info area-dat archive-block-id) + (rmt:send-receive area-dat 'test-get-archive-block-info #f (list archive-block-id))) Index: rpc-transport.scm ================================================================== --- rpc-transport.scm +++ rpc-transport.scm @@ -37,17 +37,17 @@ ;; all routes though here end in exit ... ;; ;; start_server? ;; -(define (rpc-transport:launch run-id) +(define (rpc-transport:launch area-dat run-id) (let* ((tdbdat (tasks:open-db))) (BB> "rpc-transport:launch fired for run-id="run-id) (set! *run-id* run-id) (if (args:get-arg "-daemonize") (daemon:ize)) - (if (server:check-if-running run-id) + (if (server:check-if-running area-dat run-id) (begin (debug:print 0 *default-log-port* "INFO: Server for run-id " run-id " already running") (exit 0))) (let loop ((server-id (tasks:server-lock-slot (db:delay-if-busy tdbdat) run-id)) (remtries 4)) Index: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -49,15 +49,15 @@ test-name item-path jobgroup waitons testmode newtal itemmaps prereqs-not-met) ;; set up needed environment variables given a run-id and optionally a target, itempath etc. ;; -(define (runs:set-megatest-env-vars run-id #!key (inkeys #f)(inrunname #f)(inkeyvals #f)(intarget #f)(testname #f)(itempath #f)) +(define (runs:set-megatest-env-vars area-dat run-id #!key (inkeys #f)(inrunname #f)(inkeyvals #f)(intarget #f)(testname #f)(itempath #f)) (let* ((target (or intarget (common:args-get-target) (get-environment-variable "MT_TARGET"))) - (keys (if inkeys inkeys (rmt:get-keys))) + (keys (if inkeys inkeys (rmt:get-keys area-dat))) (keyvals (if inkeyvals inkeyvals (keys:target->keyval keys target))) (vals (hash-table-ref/default *env-vars-by-run-id* run-id #f)) (link-tree (configf:lookup *configdat* "setup" "linktree"))) (if testname (setenv "MT_TEST_NAME" testname)) (if itempath (setenv "MT_ITEMPATH" itempath)) @@ -81,11 +81,11 @@ (debug:print 2 *default-log-port* "setenv " key " " val) (safe-setenv key val))) (if (not (get-environment-variable "MT_TARGET"))(setenv "MT_TARGET" target)) (alist->env-vars (hash-table-ref/default *configdat* "env-override" '())) ;; Lets use this as an opportunity to put MT_RUNNAME in the environment - (let ((runname (if inrunname inrunname (rmt:get-run-name-from-id run-id)))) + (let ((runname (if inrunname inrunname (rmt:get-run-name-from-id area-dat run-id)))) (if runname (setenv "MT_RUNNAME" runname) (debug:print-error 0 *default-log-port* "no value for runname for id " run-id))) (setenv "MT_RUN_AREA_HOME" *toppath*) ;; if a testname and itempath are available set the remaining appropriate variables @@ -110,21 +110,18 @@ ;; Every time can-run-more-tests is called increment the delay ;; ;; NOTE: We run this server-side!! Do not use this global except in the runs:can-run-more-tests routine ;; (define *last-num-running-tests* 0) -;; (define *runs:can-run-more-tests-count* 0) (define (runs:shrink-can-run-more-tests-count runsdat) (runs:dat-can-run-more-tests-count-set! runsdat 0)) (define (runs:inc-can-run-more-tests-count runsdat) (runs:dat-can-run-more-tests-count-set! runsdat (+ (runs:dat-can-run-more-tests-count runsdat) 1))) -;; (set! *runs:can-run-more-tests-count* 0)) ;; (/ *runs:can-run-more-tests-count* 2))) - ;; Temporary globals. Move these into the logic or into common ;; (define *seen-cant-run-tests* (make-hash-table)) ;; use to track tests that we suspect cannot be run (define (runs:inc-cant-run-tests testname) (hash-table-set! *seen-cant-run-tests* testname @@ -148,28 +145,28 @@ (begin (hash-table-set! *runs:denoise* key currtime) #t) #f))) -(define (runs:can-run-more-tests runsdat run-id jobgroup max-concurrent-jobs) +(define (runs:can-run-more-tests area-dat runsdat run-id jobgroup max-concurrent-jobs) ;; Take advantage of a good place to exit if running the one-pass methodology (if (and (> (runs:dat-can-run-more-tests-count runsdat) 20) (args:get-arg "-one-pass")) (exit 0)) (thread-sleep! (cond ((> (runs:dat-can-run-more-tests-count runsdat) 20) (if (runs:lownoise "waiting on tasks" 60)(debug:print-info 2 *default-log-port* "waiting for tasks to complete, sleeping briefly ...")) 2);; obviously haven't had any work to do for a while (else 0))) - (let* ((num-running (rmt:get-count-tests-running run-id)) - (num-running-in-jobgroup (rmt:get-count-tests-running-in-jobgroup run-id jobgroup)) + (let* ((num-running (rmt:get-count-tests-running area-dat run-id)) + (num-running-in-jobgroup (rmt:get-count-tests-running-in-jobgroup area-dat run-id jobgroup)) (job-group-limit (let ((jobg-count (config-lookup *configdat* "jobgroups" jobgroup))) (if (string? jobg-count) (string->number jobg-count) jobg-count)))) (if (> (+ num-running num-running-in-jobgroup) 0) - (runs:inc-can-run-more-tests-count runsdat)) ;; (set! *runs:can-run-more-tests-count* (+ *runs:can-run-more-tests-count* 1))) + (runs:inc-can-run-more-tests-count runsdat)) (if (not (eq? *last-num-running-tests* num-running)) (begin (debug:print 2 *default-log-port* "max-concurrent-jobs: " max-concurrent-jobs ", num-running: " num-running) (set! *last-num-running-tests* num-running))) (if (not (eq? 0 *globalexitstatus*)) @@ -196,14 +193,14 @@ ;; test-names: Comma separated patterns same as test-patts but used in selection ;; of tests to run. The item portions are not respected. ;; FIXME: error out if /patt specified ;; -(define (runs:run-tests target runname test-patts user flags #!key (run-count 1)) ;; test-names +(define (runs:run-tests area-dat target runname test-patts user flags #!key (run-count 1)) ;; test-names (let* ((keys (keys:config-get-fields *configdat*)) (keyvals (keys:target->keyval keys target)) - (run-id (rmt:register-run keyvals runname "new" "n/a" user)) ;; test-name))) + (run-id (rmt:register-run area-dat keyvals runname "new" "n/a" user)) ;; test-name))) ;; (deferred '()) ;; delay running these since they have a waiton clause (runconfigf (conc *toppath* "/runconfigs.config")) (test-records (make-hash-table)) ;; need to process runconfigs before generating these lists (all-tests-registry #f) ;; (tests:get-all)) ;; (tests:get-valid-tests (make-hash-table) test-search-path)) ;; all valid tests to check waiton names @@ -230,11 +227,11 @@ ;; (signal-mask! signum) ;; to mask or not? seems to cause issues in exiting (set! *time-to-exit* #t) (print "Received signal " signum ", cleaning up before exit. Please wait...") (let ((th1 (make-thread (lambda () (let ((tdbdat (tasks:open-db))) - (rmt:tasks-set-state-given-param-key task-key "killed")) + (rmt:tasks-set-state-given-param-key area-dat task-key "killed")) (print "Killed by signal " signum ". Exiting") (thread-sleep! 3) (exit)))) (th2 (make-thread (lambda () (thread-sleep! 5) @@ -244,11 +241,11 @@ (thread-start! th1) (thread-join! th2))))) (set-signal-handler! signal/int sighand) (set-signal-handler! signal/term sighand)) - (runs:set-megatest-env-vars run-id inkeys: keys inrunname: runname) ;; these may be needed by the launching process + (runs:set-megatest-env-vars area-dat run-id inkeys: keys inrunname: runname) ;; these may be needed by the launching process (set! runconf (if (file-exists? runconfigf) (setup-env-defaults runconfigf run-id *already-seen-runconfig-info* keyvals target) (begin (debug:print 0 *default-log-port* "WARNING: You do not have a run config file: " runconfigf) #f))) @@ -255,12 +252,12 @@ (if (not test-patts) ;; first time in - adjust testpatt (set! test-patts (common:args-get-testpatt runconf))) ;; register this run in monitor.db - (rmt:tasks-add "run-tests" user target runname test-patts task-key) ;; params) - (rmt:tasks-set-state-given-param-key task-key "running") + (rmt:tasks-add area-dat "run-tests" user target runname test-patts task-key) ;; params) + (rmt:tasks-set-state-given-param-key area-dat task-key "running") ;; Now generate all the tests lists (set! all-tests-registry (tests:get-all)) ;; hash of testname => path-to-test (set! all-test-names (hash-table-keys all-tests-registry)) (set! test-names (tests:filter-test-names all-test-names test-patts)) @@ -296,20 +293,20 @@ ;; have to delete test records where NOT_STARTED since they can cause -keepgoing to ;; get stuck due to becoming inaccessible from a failed test. I.e. if test B depends ;; on test A but test B reached the point on being registered as NOT_STARTED and test ;; A failed for some reason then on re-run using -keepgoing the run can never complete. ;; - ;; (rmt:general-call 'delete-tests-in-state run-id "NOT_STARTED") + ;; (rmt:general-call area-dat 'delete-tests-in-state run-id "NOT_STARTED") ;; Now convert anything in allow-auto-rerun to NOT_STARTED ;; (for-each (lambda (state) - (rmt:set-tests-state-status run-id test-names state #f "NOT_STARTED" state)) + (rmt:set-tests-state-status area-dat run-id test-names state #f "NOT_STARTED" state)) (string-split (or (configf:lookup *configdat* "setup" "allow-auto-rerun") ""))))) ;; Ensure all tests are registered in the test_meta table - (runs:update-all-test_meta #f) + (runs:update-all-test_meta area-dat) ;; now add non-directly referenced dependencies (i.e. waiton) ;;====================================================================== ;; refactoring this block into tests:get-full-data ;; @@ -403,31 +400,21 @@ (let ((reglen (configf:lookup *configdat* "setup" "runqueue"))) (if (> (length (hash-table-keys test-records)) 0) (let* ((keep-going #t) (run-queue-retries 5) (th1 (make-thread (lambda () - (runs:run-tests-queue run-id runname test-records keyvals flags test-patts required-tests (any->number reglen) all-tests-registry)) - ;; (handle-exceptions - ;; exn - ;; (begin - ;; (print-call-chain (current-error-port)) - ;; (debug:print-error 0 *default-log-port* "failure in runs:run-tests-queue thread, error: " ((condition-property-accessor 'exn 'message) exn)) - ;; (if (> run-queue-retries 0) - ;; (begin - ;; (set! run-queue-retries (- run-queue-retries 1)) - ;; (runs:run-tests-queue run-id runname test-records keyvals flags test-patts required-tests (any->number reglen) all-tests-registry)))) - ;; (runs:run-tests-queue run-id runname test-records keyvals flags test-patts required-tests (any->number reglen) all-tests-registry))) + (runs:run-tests-queue area-dat run-id runname test-records keyvals flags test-patts required-tests (any->number reglen) all-tests-registry)) "runs:run-tests-queue")) (th2 (make-thread (lambda () - ;; (rmt:find-and-mark-incomplete-all-runs))))) CAN'T INTERRUPT IT ... - (let ((run-ids (rmt:get-all-run-ids))) + ;; (rmt:find-and-mark-incomplete-all-runs area-dat))))) CAN'T INTERRUPT IT ... + (let ((run-ids (rmt:get-all-run-ids area-dat))) (for-each (lambda (run-id) (if keep-going (handle-exceptions exn (debug:print 0 *default-log-port* "error in calling find-and-mark-incomplete for run-id " run-id) - (rmt:find-and-mark-incomplete run-id #f)))) ;; ovr-deadtime))) + (rmt:find-and-mark-incomplete area-dat run-id #f)))) ;; ovr-deadtime))) run-ids))) "runs: mark-incompletes"))) (thread-start! th1) (thread-start! th2) (thread-join! th1) @@ -439,14 +426,14 @@ (if (not (hash-table-ref/default flags "-preclean" #f)) (hash-table-set! flags "-preclean" #t)) (if (not (hash-table-ref/default flags "-rerun" #f)) (hash-table-set! flags "-rerun" "STUCK/DEAD,n/a,ZERO_ITEMS")) ;; recursive call to self - (runs:run-tests target runname test-patts user flags run-count: (- run-count 1))))) + (runs:run-tests area-dat target runname test-patts user flags run-count: (- run-count 1))))) (debug:print-info 0 *default-log-port* "No tests to run"))) (debug:print-info 4 *default-log-port* "All done by here") - (rmt:tasks-set-state-given-param-key task-key "done") + (rmt:tasks-set-state-given-param-key area-dat task-key "done") ;; (sqlite3:finalize! tasks-db) )) ;; loop logic. These are used in runs:run-tests-queue to make it a bit more readable. @@ -479,13 +466,13 @@ '() reg))) (define runs:nothing-left-in-queue-count 0) -(define (runs:expand-items hed tal reg reruns regfull newtal jobgroup max-concurrent-jobs run-id waitons item-path testmode test-record can-run-more items runname tconfig reglen test-registry test-records itemmaps) +(define (runs:expand-items area-dat hed tal reg reruns regfull newtal jobgroup max-concurrent-jobs run-id waitons item-path testmode test-record can-run-more items runname tconfig reglen test-registry test-records itemmaps) (let* ((loop-list (list hed tal reg reruns)) - (prereqs-not-met (let ((res (rmt:get-prereqs-not-met run-id waitons hed item-path mode: testmode itemmaps: itemmaps))) + (prereqs-not-met (let ((res (rmt:get-prereqs-not-met area-dat run-id waitons hed item-path mode: testmode itemmaps: itemmaps))) (if (list? res) res (begin (debug:print 0 *default-log-port* "ERROR: rmt:get-prereqs-not-met returned non-list!\n" @@ -542,17 +529,17 @@ (null? non-completed))) (debug:print-info 4 *default-log-port* "runs:expand-items: (or (null? prereqs-not-met) (and (member 'toplevel testmode)(null? non-completed)))") (let ((test-name (tests:testqueue-get-testname test-record))) (setenv "MT_TEST_NAME" test-name) ;; (setenv "MT_RUNNAME" runname) - (runs:set-megatest-env-vars run-id inrunname: runname) ;; these may be needed by the launching process + (runs:set-megatest-env-vars area-dat run-id inrunname: runname) ;; these may be needed by the launching process (let ((items-list (items:get-items-from-config tconfig))) (if (list? items-list) (begin (if (null? items-list) - (let ((test-id (rmt:get-test-id run-id test-name "")) - (num-items (rmt:test-toplevel-num-items run-id test-name))) + (let ((test-id (rmt:get-test-id area-dat run-id test-name "")) + (num-items (rmt:test-toplevel-num-items area-dat run-id test-name))) (if (and test-id (not (> num-items 0))) (mt:test-set-state-status-by-id run-id test-id "NOT_STARTED" "ZERO_ITEMS" "Failed to run due to failed prerequisites")))) (tests:testqueue-set-items! test-record items-list) (list hed tal reg reruns)) @@ -588,11 +575,11 @@ (not (and (null? tal)(null? reg)))) (let ((trimmed-tal (mt:discard-blocked-tests run-id hed tal test-records)) (trimmed-reg (mt:discard-blocked-tests run-id hed reg test-records))) (debug:print 1 *default-log-port* "WARNING: test " hed " has discarded prerequisites, removing it from the queue") - (let ((test-id (rmt:get-test-id run-id hed ""))) + (let ((test-id (rmt:get-test-id area-dat run-id hed ""))) (if test-id (mt:test-set-state-status-by-id run-id test-id "NOT_STARTED" "PREQ_DISCARDED" "Failed to run due to discarded prerequisites"))) (if (and (null? trimmed-tal) (null? trimmed-reg)) #f @@ -614,11 +601,11 @@ ;; num-retries code was here ;; we use this opportunity to move contents of reg to tal (list (car newtal)(append (cdr newtal) reg) '() reruns)) ;; an issue with prereqs not yet met? (begin (debug:print-info 1 *default-log-port* "no fails in prerequisites for " hed " but nothing seen running in a while, dropping test " hed " from the run queue") - (let ((test-id (rmt:get-test-id run-id hed ""))) + (let ((test-id (rmt:get-test-id area-dat run-id hed ""))) (if test-id (mt:test-set-state-status-by-id run-id test-id "NOT_STARTED" "TIMED_OUT" "Nothing seen running in a while."))) (list (runs:queue-next-hed tal reg reglen regfull) (runs:queue-next-tal tal reg reglen regfull) (runs:queue-next-reg tal reg reglen regfull) reruns)))) @@ -628,11 +615,11 @@ (not (null? prereq-fails))) (member 'normal testmode)) (debug:print-info 1 *default-log-port* "test " hed " (mode=" testmode ") has failed prerequisite(s); " (string-intersperse (map (lambda (t)(conc (db:test-get-testname t) ":" (db:test-get-state t)"/"(db:test-get-status t))) fails) ", ") ", removing it from to-do list") - (let ((test-id (rmt:get-test-id run-id hed ""))) + (let ((test-id (rmt:get-test-id area-dat run-id hed ""))) (if test-id (if (not (null? prereq-fails)) (mt:test-set-state-status-by-id run-id test-id "NOT_STARTED" "PREQ_DISCARDED" "Failed to run due to prior failed prerequisites") (mt:test-set-state-status-by-id run-id test-id "NOT_STARTED" "PREQ_FAIL" "Failed to run due to failed prerequisites")))) (if (or (not (null? reg))(not (null? tal))) @@ -674,11 +661,11 @@ (conc t)))) inlst))) ;; hed tal reg reruns reglen regfull test-record runname test-name item-path jobgroup max-concurrent-jobs run-id waitons item-path testmode test-patts required-tests test-registry registry-mutex flags keyvals run-info newtal all-tests-registry itemmaps) -(define (runs:process-expanded-tests runsdat testdat) +(define (runs:process-expanded-tests area-dat runsdat testdat) ;; unroll the contents of runsdat and testdat (due to ongoing refactoring). (let* ((hed (runs:testdat-hed testdat)) (tal (runs:testdat-tal testdat)) (reg (runs:testdat-reg testdat)) (reruns (runs:testdat-reruns testdat)) @@ -705,17 +692,16 @@ (flags (runs:dat-flags runsdat)) (keyvals (runs:dat-keyvals runsdat)) (run-info (runs:dat-run-info runsdat)) (all-tests-registry (runs:dat-all-tests-registry runsdat)) (run-limits-info (runs:dat-can-run-more-tests runsdat)) - ;; (runs:can-run-more-tests run-id jobgroup max-concurrent-jobs)) ;; look at the test jobgroup and tot jobs running (have-resources (car run-limits-info)) (num-running (list-ref run-limits-info 1)) (num-running-in-jobgroup(list-ref run-limits-info 2)) (max-concurrent-jobs (list-ref run-limits-info 3)) (job-group-limit (list-ref run-limits-info 4)) - ;; (prereqs-not-met (rmt:get-prereqs-not-met run-id waitons hed item-path mode: testmode itemmaps: itemmaps)) + ;; (prereqs-not-met (rmt:get-prereqs-not-met area-dat run-id waitons hed item-path mode: testmode itemmaps: itemmaps)) ;; (prereqs-not-met (mt:lazy-get-prereqs-not-met run-id waitons item-path mode: testmode itemmap: itemmap)) (fails (if (list? prereqs-not-met) (runs:calc-fails prereqs-not-met) (begin (debug:print-error 0 *default-log-port* "prereqs-not-met is not a list! " prereqs-not-met) @@ -767,22 +753,22 @@ ;; ((not (hash-table-ref/default test-registry (db:test-make-full-name test-name item-path) #f)) (debug:print-info 4 *default-log-port* "Pre-registering test " test-name "/" item-path " to create placeholder" ) ;; always do firm registration now in v1.60 and greater ;; (eq? *transport-type* 'fs) ;; no point in parallel registration if use fs (let register-loop ((numtries 15)) - (rmt:register-test run-id test-name item-path) - (if (rmt:get-test-id run-id test-name item-path) + (rmt:register-test area-dat run-id test-name item-path) + (if (rmt:get-test-id area-dat run-id test-name item-path) (hash-table-set! test-registry (db:test-make-full-name test-name item-path) 'done) (if (> numtries 0) (begin (thread-sleep! 0.5) (register-loop (- numtries 1))) (debug:print-error 0 *default-log-port* "failed to register test " (db:test-make-full-name test-name item-path))))) (if (not (eq? (hash-table-ref/default test-registry (db:test-make-full-name test-name "") #f) 'done)) (begin - (rmt:register-test run-id test-name "") - (if (rmt:get-test-id run-id test-name "") + (rmt:register-test area-dat run-id test-name "") + (if (rmt:get-test-id area-dat run-id test-name "") (hash-table-set! test-registry (db:test-make-full-name test-name "") 'done)))) (runs:shrink-can-run-more-tests-count runsdat) ;; DELAY TWEAKER (still needed?) (if (and (null? tal)(null? reg)) (list hed tal (append reg (list hed)) reruns) (list (runs:queue-next-hed tal reg reglen regfull) @@ -830,12 +816,12 @@ (set! *max-tries-hash* (make-hash-table)) ;; well, first lets see if cpu load throttling is enabled. If so wait around until the ;; average cpu load is under the threshold before continuing (if (configf:lookup *configdat* "jobtools" "maxload") ;; only gate if maxload is specified (common:wait-for-cpuload maxload numcpus waitdelay)) - (run:test run-id run-info keyvals runname test-record flags #f test-registry all-tests-registry) - (runs:incremental-print-results run-id) + (run:test area-dat run-id run-info keyvals runname test-record flags #f test-registry all-tests-registry) + (runs:incremental-print-results area-dat run-id) (hash-table-set! test-registry (db:test-make-full-name test-name item-path) 'running) (runs:shrink-can-run-more-tests-count runsdat) ;; DELAY TWEAKER (still needed?) ;; (thread-sleep! *global-delta*) (if (or (not (null? tal))(not (null? reg))) (list (runs:queue-next-hed tal reg reglen regfull) @@ -868,11 +854,11 @@ (if (or (not (null? reg))(not (null? tal))) (if (vector? hed) (begin (debug:print 1 *default-log-port* "WARNING: Dropping test " test-name "/" item-path " from the launch list as it has prerequistes that are FAIL") - (let ((test-id (rmt:get-test-id run-id hed ""))) + (let ((test-id (rmt:get-test-id area-dat run-id hed ""))) (if test-id (mt:test-set-state-status-by-id run-id test-id "NOT_STARTED" "PREQ_FAIL" "Failed to run due to failed prerequisites"))) (runs:shrink-can-run-more-tests-count runsdat) ;; DELAY TWEAKER (still needed?) ;; (thread-sleep! *global-delta*) ;; This next is for the items (mt:test-set-state-status-by-testname run-id test-name item-path "NOT_STARTED" "BLOCKED" #f) @@ -928,11 +914,11 @@ (debug:print 0 *default-log-port* "WARNING: test " hed " has FAILED prerequitests and we've tried at least 10 times to run it. Giving up now.")) ;; (debug:print 0 *default-log-port* " prereqs: " prereqs-not-met) (hash-table-set! test-registry hed 'removed) (mt:test-set-state-status-by-testname run-id test-name item-path "NOT_STARTED" "TEN_STRIKES" #f) ;; I'm unclear on if this roll up is needed - it may be the root cause of the "all set to FAIL" bug. - (rmt:set-state-status-and-roll-up-items run-id test-name item-path #f "FAIL" #f) ;; treat as FAIL + (rmt:set-state-status-and-roll-up-items area-dat run-id test-name item-path #f "FAIL" #f) ;; treat as FAIL (list (if (null? tal)(car newtal)(car tal)) tal reg reruns))))) ;; can't drop this - maybe running? Just keep trying @@ -975,19 +961,19 @@ runname: #f target: #f ) ) -(define (runs:incremental-print-results run-id) +(define (runs:incremental-print-results area-dat run-id) (let ((curr-sec (current-seconds))) (if (> (- curr-sec (runs:gendat-inc-results-last-update *runs:general-data*)) 5) ;; at least five seconds since last update - (let* ((run-dat (or (runs:gendat-run-info *runs:general-data*)(rmt:get-run-info run-id))) + (let* ((run-dat (or (runs:gendat-run-info *runs:general-data*)(rmt:get-run-info area-dat run-id))) (runname (or (runs:gendat-runname *runs:general-data*) (db:get-value-by-header (db:get-rows run-dat) (db:get-header run-dat) "runname"))) - (target (or (runs:gendat-target *runs:general-data*)(rmt:get-target run-id))) - (testsdat (rmt:get-tests-for-run run-id "%" '() '() ;; run-id testpatt states statuses + (target (or (runs:gendat-target *runs:general-data*)(rmt:get-target area-dat run-id))) + (testsdat (rmt:get-tests-for-run area-dat run-id "%" '() '() ;; run-id testpatt states statuses #f #f ;; offset limit #f ;; not-in #f ;; sort-by #f ;; sort-order #f ;; get full data (not 'shortlist) @@ -1034,20 +1020,20 @@ ;; when the min is > max-allowed and none running then force exit ;; (define *max-tries-hash* (make-hash-table)) ;; test-records is a hash table testname:item_path => vector < testname testconfig waitons priority items-info ... > -(define (runs:run-tests-queue run-id runname test-records keyvals flags test-patts required-tests reglen-in all-tests-registry) +(define (runs:run-tests-queue area-dat run-id runname test-records keyvals flags test-patts required-tests reglen-in all-tests-registry) ;; At this point the list of parent tests is expanded ;; NB// Should expand items here and then insert into the run queue. (debug:print 5 *default-log-port* "test-records: " test-records ", flags: " (hash-table->alist flags)) ;; Do mark-and-find clean up of db before starting runing of quue ;; - ;; (rmt:find-and-mark-incomplete) + ;; (rmt:find-and-mark-incomplete area-dat) - (let* ((run-info (rmt:get-run-info run-id)) + (let* ((run-info (rmt:get-run-info area-dat run-id)) (tests-info (mt:get-tests-for-run run-id #f '() '())) ;; qryvals: "id,testname,item_path")) (sorted-test-names (tests:sort-by-priority-and-waiton test-records)) (test-registry (make-hash-table)) (registry-mutex (make-mutex)) (num-retries 0) @@ -1084,12 +1070,11 @@ keyvals: keyvals run-info: run-info ;; newtal: newtal all-tests-registry: all-tests-registry ;; itemmaps: itemmaps - ;; prereqs-not-met: (rmt:get-prereqs-not-met run-id waitons hed item-path mode: testmode itemmaps: itemmaps) - ;; can-run-more-tests: (runs:can-run-more-tests run-id jobgroup max-concurrent-jobs) ;; look at the test jobgroup and tot jobs running + ;; prereqs-not-met: (rmt:get-prereqs-not-met area-dat run-id waitons hed item-path mode: testmode itemmaps: itemmaps) ))) ;; Initialize the test-registery hash with tests that already have a record ;; convert state to symbol and use that as the hash value (for-each (lambda (trec) @@ -1105,21 +1090,21 @@ (let loop ((hed (car sorted-test-names)) (tal (cdr sorted-test-names)) (reg '()) ;; registered, put these at the head of tal (reruns '())) - (runs:incremental-print-results run-id) + (runs:incremental-print-results area-dat run-id) (if (not (null? reruns))(debug:print-info 4 *default-log-port* "reruns=" reruns)) ;; Here we mark any old defunct tests as incomplete. Do this every fifteen minutes ;; moving this to a parallel thread and just run it once. ;; (if (> (current-seconds)(+ last-time-incomplete 900)) (begin (set! last-time-incomplete (current-seconds)) - ;; (rmt:find-and-mark-incomplete-all-runs) + ;; (rmt:find-and-mark-incomplete-all-runs area-dat) )) ;; (print "Top of loop, hed=" hed ", tal=" tal " ,reruns=" reruns) (let* ((test-record (hash-table-ref test-records hed)) (test-name (tests:testqueue-get-testname test-record)) @@ -1134,11 +1119,11 @@ (items (tests:testqueue-get-items test-record)) (item-path (item-list->path itemdat)) (tfullname (db:test-make-full-name test-name item-path)) (newtal (append tal (list hed))) (regfull (>= (length reg) reglen)) - (num-running (rmt:get-count-tests-running-for-run-id run-id)) + (num-running (rmt:get-count-tests-running-for-run-id area-dat run-id)) (testdat (make-runs:testdat hed: hed tal: tal reg: reg reruns: reruns @@ -1167,11 +1152,11 @@ ;; Ensure all top level tests get registered. This way they show up as "NOT_STARTED" on the dashboard ;; and it is clear they *should* have run but did not. (if (not (hash-table-ref/default test-registry (db:test-make-full-name test-name "") #f)) (begin - (rmt:register-test run-id test-name "") + (rmt:register-test area-dat run-id test-name "") (hash-table-set! test-registry (db:test-make-full-name test-name "") 'done))) ;; Fast skip of tests that are already "COMPLETED" - NO! Cannot do that as the items may not have been expanded yet :( ;; (if (member (hash-table-ref/default test-registry tfullname #f) @@ -1184,11 +1169,11 @@ (runs:queue-next-tal tal reg reglen regfull) (runs:queue-next-reg tal reg reglen regfull) reruns)))) ;; (loop (car tal)(cdr tal) reg reruns)))) - (runs:incremental-print-results run-id) + (runs:incremental-print-results area-dat run-id) (debug:print 4 *default-log-port* "TOP OF LOOP => " "test-name: " test-name "\n test-record " test-record "\n hed: " hed "\n itemdat: " itemdat @@ -1233,13 +1218,13 @@ ((not items) (debug:print-info 4 *default-log-port* "OUTER COND: (not items)") (if (and (not (tests:match test-patts (tests:testqueue-get-testname test-record) item-path required: required-tests)) (not (null? tal))) (loop (car tal)(cdr tal) reg reruns)) - (runs:testdat-prereqs-not-met-set! testdat (rmt:get-prereqs-not-met run-id waitons hed item-path mode: testmode itemmaps: itemmaps)) - (runs:dat-can-run-more-tests-set! runsdat (runs:can-run-more-tests runsdat run-id jobgroup max-concurrent-jobs)) ;; look at the test jobgroup and tot jobs running - (let ((loop-list (runs:process-expanded-tests runsdat testdat))) + (runs:testdat-prereqs-not-met-set! testdat (rmt:get-prereqs-not-met area-dat run-id waitons hed item-path mode: testmode itemmaps: itemmaps)) + (runs:dat-can-run-more-tests-set! runsdat (runs:can-run-more-tests area-dat runsdat run-id jobgroup max-concurrent-jobs)) ;; look at the test jobgroup and tot jobs running + (let ((loop-list (runs:process-expanded-tests area-dat runsdat testdat))) (if loop-list (apply loop loop-list)))) ;; items processed into a list but not came in as a list been processed ;; ((and (list? items) ;; thus we know our items are already calculated @@ -1287,14 +1272,14 @@ ;; if items is a proc then need to run items:get-items-from-config, get the list and loop ;; - but only do that if resources exist to kick off the job ;; EXPAND ITEMS ((or (procedure? items)(eq? items 'have-procedure)) - (let ((can-run-more (runs:can-run-more-tests runsdat run-id jobgroup max-concurrent-jobs))) + (let ((can-run-more (runs:can-run-more-tests area-dat runsdat run-id jobgroup max-concurrent-jobs))) (if (and (list? can-run-more) (car can-run-more)) - (let ((loop-list (runs:expand-items hed tal reg reruns regfull newtal jobgroup max-concurrent-jobs run-id waitons item-path testmode test-record can-run-more items runname tconfig reglen test-registry test-records itemmaps))) + (let ((loop-list (runs:expand-items area-dat hed tal reg reruns regfull newtal jobgroup max-concurrent-jobs run-id waitons item-path testmode test-record can-run-more items runname tconfig reglen test-registry test-records itemmaps))) (if loop-list (apply loop loop-list))) ;; if can't run more just loop with next possible test (loop (car newtal)(cdr newtal) reg reruns)))) @@ -1301,11 +1286,11 @@ ;; this case should not happen, added to help catch any bugs ((and (list? items) itemdat) (debug:print-error 0 *default-log-port* "Should not have a list of items in a test and the itemspath set - please report this") (exit 1)) ((not (null? reruns)) - (let* ((newlst (tests:filter-non-runnable run-id tal test-records)) ;; i.e. not FAIL, WAIVED, INCOMPLETE, PASS, KILLED, + (let* ((newlst (tests:filter-non-runnable area-dat run-id tal test-records)) ;; i.e. not FAIL, WAIVED, INCOMPLETE, PASS, KILLED, (junked (lset-difference equal? tal newlst))) (debug:print-info 4 *default-log-port* "full drop through, if reruns is less than 100 we will force retry them, reruns=" reruns ", tal=" tal) (if (< num-retries max-retries) (set! newlst (append reruns newlst))) (set! num-retries (+ num-retries 1)) @@ -1322,11 +1307,11 @@ (debug:print-info 4 *default-log-port* "Exiting loop with...\n hed=" hed "\n tal=" tal "\n reruns=" reruns)) ))) ;; now *if* -run-wait we wait for all tests to be done ;; Now wait for any RUNNING tests to complete (if in run-wait mode) (thread-sleep! 5) ;; I think there is a race condition here. Let states/statuses settle - (let wait-loop ((num-running (rmt:get-count-tests-running-for-run-id run-id)) + (let wait-loop ((num-running (rmt:get-count-tests-running-for-run-id area-dat run-id)) (prev-num-running 0)) ;; (BB> "num-running=" num-running ", prev-num-running=" prev-num-running) (if (and (or (args:get-arg "-run-wait") (equal? (configf:lookup *configdat* "setup" "run-wait") "yes")) (> num-running 0)) @@ -1335,16 +1320,16 @@ ;; (debug:print 0 *default-log-port* "Got here eh! num-running=" num-running " (> num-running 0) " (> num-running 0)) (if (> (current-seconds)(+ last-time-incomplete 900)) (begin (debug:print-info 0 *default-log-port* "Marking stuck tests as INCOMPLETE while waiting for run " run-id ". Running as pid " (current-process-id) " on " (get-host-name)) (set! last-time-incomplete (current-seconds)) - (rmt:find-and-mark-incomplete run-id #f))) + (rmt:find-and-mark-incomplete area-dat run-id #f))) (if (not (eq? num-running prev-num-running)) (debug:print-info 0 *default-log-port* "run-wait specified, waiting on " num-running " tests in RUNNING, REMOTEHOSTSTART or LAUNCHED state at " (time->string (seconds->local-time (current-seconds))))) (thread-sleep! 5) - ;; (wait-loop (rmt:get-count-tests-running-for-run-id run-id) num-running)))) - (wait-loop (rmt:get-count-tests-running-for-run-id run-id) num-running)))) + ;; (wait-loop (rmt:get-count-tests-running-for-run-id area-dat run-id) num-running)))) + (wait-loop (rmt:get-count-tests-running-for-run-id area-dat run-id) num-running)))) ;; LET* ((test-record ;; we get here on "drop through". All done! (debug:print-info 1 *default-log-port* "All tests launched"))) (define (runs:calc-fails prereqs-not-met) @@ -1393,11 +1378,11 @@ (conc (db:test-get-testname t) ":" (db:test-get-state t) "/" (db:test-get-status t)))) lst)) ;; parent-test is there as a placeholder for when parent-tests can be run as a setup step ;; -(define (run:test run-id run-info keyvals runname test-record flags parent-test test-registry all-tests-registry) +(define (run:test area-dat run-id run-info keyvals runname test-record flags parent-test test-registry all-tests-registry) ;; All these vars might be referenced by the testconfig file reader (let* ((test-name (tests:testqueue-get-testname test-record)) (test-waitons (tests:testqueue-get-waitons test-record)) (test-conf (tests:testqueue-get-testconfig test-record)) (itemdat (tests:testqueue-get-itemdat test-record)) @@ -1421,11 +1406,11 @@ ) (debug:print 2 *default-log-port* "Attempting to launch test " full-test-name) ;; (setenv "MT_TEST_NAME" test-name) ;; ;; (setenv "MT_ITEMPATH" item-path) ;; (setenv "MT_RUNNAME" runname) - (runs:set-megatest-env-vars run-id inrunname: runname testname: test-name itempath: item-path) ;; these may be needed by the launching process + (runs:set-megatest-env-vars area-dat run-id inrunname: runname testname: test-name itempath: item-path) ;; these may be needed by the launching process (change-directory *toppath*) ;; Here is where the test_meta table is best updated ;; Yes, another use of a global for caching. Need a better way? ;; @@ -1434,16 +1419,16 @@ ;; v1.55 this code is being left in place for the time being. ;; (if (not (hash-table-ref/default *test-meta-updated* test-name #f)) (begin (hash-table-set! *test-meta-updated* test-name #t) - (runs:update-test_meta test-name test-conf))) + (runs:update-test_meta area-dat test-name test-conf))) ;; itemdat => ((ripeness "overripe") (temperature "cool") (season "summer")) (let* ((new-test-path (string-intersperse (cons test-path (map cadr itemdat)) "/")) - (test-id (rmt:get-test-id run-id test-name item-path)) - (testdat (if test-id (rmt:get-test-info-by-id run-id test-id) #f))) + (test-id (rmt:get-test-id area-dat run-id test-name item-path)) + (testdat (if test-id (rmt:get-test-info-by-id area-dat run-id test-id) #f))) (if (not testdat) (let loop () ;; ensure that the path exists before registering the test ;; NOPE: Cannot! Don't know yet which disk area will be assigned.... ;; (system (conc "mkdir -p " new-test-path)) @@ -1450,18 +1435,18 @@ ;; ;; (open-run-close tests:register-test db run-id test-name item-path) ;; ;; NB// for the above line. I want the test to be registered long before this routine gets called! ;; - (if (not test-id)(set! test-id (rmt:get-test-id run-id test-name item-path))) + (if (not test-id)(set! test-id (rmt:get-test-id area-dat run-id test-name item-path))) (if (not test-id) (begin (debug:print 2 *default-log-port* "WARN: Test not pre-created? test-name=" test-name ", item-path=" item-path ", run-id=" run-id) - (rmt:register-test run-id test-name item-path) - (set! test-id (rmt:get-test-id run-id test-name item-path)))) + (rmt:register-test area-dat run-id test-name item-path) + (set! test-id (rmt:get-test-id area-dat run-id test-name item-path)))) (debug:print-info 4 *default-log-port* "test-id=" test-id ", run-id=" run-id ", test-name=" test-name ", item-path=\"" item-path "\"") - (set! testdat (rmt:get-test-info-by-id run-id test-id)) + (set! testdat (rmt:get-test-info-by-id area-dat run-id test-id)) (if (not testdat) (begin (debug:print-info 0 *default-log-port* "WARNING: server is overloaded, trying again in one second") (thread-sleep! 1) (loop))))) @@ -1529,11 +1514,11 @@ ;; Have to check for skip conditions. This one skips if there are same-named tests ;; currently running ((and skip-check (configf:lookup test-conf "skip" "prevrunning")) ;; run-ids = #f means *all* runs - (let ((running-tests (rmt:get-tests-for-runs-mindata #f full-test-name '("RUNNING" "REMOTEHOSTSTART" "LAUNCHED") '() #f))) + (let ((running-tests (rmt:get-tests-for-runs-mindata area-dat #f full-test-name '("RUNNING" "REMOTEHOSTSTART" "LAUNCHED") '() #f))) (if (not (null? running-tests)) ;; have to skip (set! skip-test "Skipping due to previous tests running")))) ((and skip-check (configf:lookup test-conf "skip" "fileexists")) (if (file-exists? (configf:lookup test-conf "skip" "fileexists")) @@ -1541,12 +1526,12 @@ ((and skip-check (configf:lookup test-conf "skip" "rundelay")) ;; run-ids = #f means *all* runs (let* ((numseconds (common:hms-string->seconds (configf:lookup test-conf "skip" "rundelay"))) - (running-tests (rmt:get-tests-for-runs-mindata #f full-test-name '("RUNNING" "REMOTEHOSTSTART" "LAUNCHED") '() #f)) - (completed-tests (rmt:get-tests-for-runs-mindata #f full-test-name '("COMPLETED" "INCOMPLETE") '("PASS" "FAIL" "ABORT") #f)) ;; ironically INCOMPLETE is same as COMPLETED in this contex + (running-tests (rmt:get-tests-for-runs-mindata area-dat #f full-test-name '("RUNNING" "REMOTEHOSTSTART" "LAUNCHED") '() #f)) + (completed-tests (rmt:get-tests-for-runs-mindata area-dat #f full-test-name '("COMPLETED" "INCOMPLETE") '("PASS" "FAIL" "ABORT") #f)) ;; ironically INCOMPLETE is same as COMPLETED in this contex (last-run-times (map db:mintest-get-event_time completed-tests)) (time-since-last (- (current-seconds) (if (null? last-run-times) 0 (common:max last-run-times))))) (if (or (not (null? running-tests)) ;; have to skip if test is running (> numseconds time-since-last)) (set! skip-test (conc "Skipping due to previous test run less than " (configf:lookup test-conf "skip" "rundelay") " ago")))))) @@ -1563,19 +1548,10 @@ ((KILLED) (debug:print 1 *default-log-port* "NOTE: " full-test-name " is already running or was explictly killed, use -force to launch it.") (hash-table-set! test-registry (db:test-make-full-name test-name test-path) 'DONOTRUN)) ;; KILLED)) ((LAUNCHED REMOTEHOSTSTART RUNNING) (debug:print 2 *default-log-port* "NOTE: " test-name " is already running")) - ;; (if (> (- (current-seconds)(+ (db:test-get-event_time testdat) - ;; (db:test-get-run_duration testdat))) - ;; (or incomplete-timeout - ;; 6000)) ;; i.e. no update for more than 6000 seconds - ;; (begin - ;; (debug:print 0 *default-log-port* "WARNING: Test " test-name " appears to be dead. Forcing it to state INCOMPLETE and status STUCK/DEAD") - ;; (tests:test-set-status! run-id test-id "INCOMPLETE" "STUCK/DEAD" "" #f)) - ;; ;; (tests:test-set-status! test-id "INCOMPLETE" "STUCK/DEAD" "" #f)) - ;; (debug:print 2 *default-log-port* "NOTE: " test-name " is already running"))) (else (debug:print-error 0 *default-log-port* "Failed to launch test " full-test-name ". Unrecognised state " (test:get-state testdat)) (case (string->symbol (test:get-state testdat)) ((COMPLETED INCOMPLETE) (hash-table-set! test-registry (db:test-make-full-name test-name test-path) 'DONOTRUN)) @@ -1626,15 +1602,15 @@ ;; 'remove-runs ;; 'set-state-status ;; ;; NB// should pass in keys? ;; -(define (runs:operate-on action target runnamepatt testpatt #!key (state #f)(status #f)(new-state-status #f)(mode 'remove-all)(options '())) +(define (runs:operate-on area-dat action target runnamepatt testpatt #!key (state #f)(status #f)(new-state-status #f)(mode 'remove-all)(options '())) (common:clear-caches) ;; clear all caches (let* ((db #f) (tdbdat (tasks:open-db)) - (keys (rmt:get-keys)) + (keys (rmt:get-keys area-dat)) (rundat (mt:get-runs-by-patt keys runnamepatt target)) (header (vector-ref rundat 0)) (runs (vector-ref rundat 1)) (states (if state (string-split state ",") '())) (statuses (if status (string-split status ",") '())) @@ -1672,11 +1648,11 @@ (case action ((remove-runs) ;; (if (tasks:need-server run-id)(tasks:start-and-wait-for-server tdbdat run-id 10)) ;; seek and kill in flight -runtests with % as testpatt here ;; (if (equal? testpatt "%") - (tasks:kill-runner target run-name testpatt) + (tasks:kill-runner area-dat target run-name testpatt) ;; (debug:print 0 *default-log-port* "not attempting to kill any run launcher processes as testpatt is " testpatt)) (debug:print 1 *default-log-port* "Removing tests for run: " runkey " " (db:get-value-by-header run header "runname"))) ((set-state-status) (if (tasks:need-server run-id)(tasks:start-and-wait-for-server tdbdat run-id 10)) @@ -1702,13 +1678,13 @@ ;; actions that operate on one test at a time can be handled below ;; (let ((sorted-tests (filter vector? - (sort tests (lambda (a b)(let ((dira ;; (rmt:sdb-qry 'getstr + (sort tests (lambda (a b)(let ((dira ;; (rmt:sdb-qry area-dat 'getstr (db:test-get-rundir a)) ;; ) ;; (filedb:get-path *fdb* (db:test-get-rundir a))) - (dirb ;; (rmt:sdb-qry 'getstr + (dirb ;; (rmt:sdb-qry area-dat 'getstr (db:test-get-rundir b))) ;; ) ;; ((filedb:get-path *fdb* (db:test-get-rundir b)))) (if (and (string? dira)(string? dirb)) (> (string-length dira)(string-length dirb)) #f)))))) (toplevel-retries (make-hash-table)) ;; try three times to loop through and remove top level tests @@ -1715,26 +1691,26 @@ (test-retry-time (make-hash-table)) (allow-run-time 10)) ;; seconds to allow for killing tests before just brutally killing 'em (let loop ((test (car sorted-tests)) (tal (cdr sorted-tests))) (let* ((test-id (db:test-get-id test)) - (new-test-dat (rmt:get-test-info-by-id run-id test-id))) + (new-test-dat (rmt:get-test-info-by-id area-dat run-id test-id))) (if (not new-test-dat) (begin (debug:print-error 0 *default-log-port* "We have a test-id of " test-id " but no record was found. NOTE: No locking of records is done between processes, do not simultaneously remove the same run from two processes!") (if (not (null? tal)) (loop (car tal)(cdr tal)))) (let* ((item-path (db:test-get-item-path new-test-dat)) (test-name (db:test-get-testname new-test-dat)) (run-dir ;;(filedb:get-path *fdb* - ;; (rmt:sdb-qry 'getid + ;; (rmt:sdb-qry area-dat 'getid (db:test-get-rundir new-test-dat)) ;; ) ;; run dir is from the link tree (test-state (db:test-get-state new-test-dat)) (test-fulln (db:test-get-fullname new-test-dat)) (uname (db:test-get-uname new-test-dat)) (toplevel-with-children (and (db:test-get-is-toplevel test) - (> (rmt:test-toplevel-num-items run-id test-name) 0)))) + (> (rmt:test-toplevel-num-items area-dat run-id test-name) 0)))) (case action ((remove-runs) ;; if the test is a toplevel-with-children issue an error and do not remove (if toplevel-with-children (begin @@ -1767,14 +1743,14 @@ ;; NOTE: This is suboptimal as the testdata will be used later and the state/status may have changed ... (if (null? tal) (loop new-test-dat tal) (loop (car tal)(append tal (list new-test-dat))))) (begin - (runs:remove-test-directory new-test-dat mode) ;; 'remove-all) + (runs:remove-test-directory area-dat new-test-dat mode) ;; 'remove-all) (if (not (null? tal)) (loop (car tal)(cdr tal))))))) - (rmt:update-run-stats run-id (rmt:get-raw-run-stats run-id))) + (rmt:update-run-stats area-dat run-id (rmt:get-raw-run-stats area-dat run-id))) ((set-state-status) (debug:print-info 2 *default-log-port* "new state " (car state-status) ", new status " (cadr state-status)) (mt:test-set-state-status-by-id run-id (db:test-get-id test) (car state-status)(cadr state-status) #f) (if (not (null? tal)) (loop (car tal)(cdr tal)))) @@ -1804,13 +1780,13 @@ (let* ((dparts (string-split lasttpath "/")) (runpath (conc "/" (string-intersperse (take dparts (- (length dparts) 1)) "/")))) (debug:print 1 *default-log-port* "Removing run: " runkey " " (db:get-value-by-header run header "runname") " and related record") - (rmt:delete-run run-id) - (rmt:delete-old-deleted-test-records) - ;; (rmt:set-var "DELETED_TESTS" (current-seconds)) + (rmt:delete-run area-dat run-id) + (rmt:delete-old-deleted-test-records area-dat) + ;; (rmt:set-var area-dat "DELETED_TESTS" (current-seconds)) ;; need to figure out the path to the run dir and remove it if empty ;; (if (null? (glob (conc runpath "/*"))) ;; (begin ;; (debug:print 1 *default-log-port* "Removing run dir " runpath) ;; (system (conc "rmdir -p " runpath)))) @@ -1819,11 +1795,11 @@ runs) ;; (sqlite3:finalize! (db:delay-if-busy tdbdat)) ) #t) -(define (runs:remove-test-directory test mode) ;; remove-data-only) +(define (runs:remove-test-directory area-dat test mode) ;; remove-data-only) (let* ((run-dir (db:test-get-rundir test)) ;; run dir is from the link tree (real-dir (if (file-exists? run-dir) ;; (resolve-pathname run-dir) (common:nice-path run-dir) #f))) @@ -1864,11 +1840,11 @@ )) ;; Only delete the records *after* removing the directory. If things fail we have a record (case mode ((remove-data-only)(mt:test-set-state-status-by-id (db:test-get-run_id test)(db:test-get-id test) "NOT_STARTED" "n/a" #f)) ((archive-remove) (mt:test-set-state-status-by-id (db:test-get-run_id test)(db:test-get-id test) "ARCHIVED" #f #f)) - (else (rmt:delete-test-records (db:test-get-run_id test) (db:test-get-id test)))))) + (else (rmt:delete-test-records area-dat (db:test-get-run_id test) (db:test-get-id test)))))) ;;====================================================================== ;; Routines for manipulating runs ;;====================================================================== @@ -1922,11 +1898,11 @@ ;;====================================================================== ;; Lock/unlock runs ;;====================================================================== -(define (runs:handle-locking target keys runname lock unlock user) +(define (runs:handle-locking area-dat target keys runname lock unlock user) (let* ((db #f) (rundat (mt:get-runs-by-patt keys runname target)) (header (vector-ref rundat 0)) (runs (vector-ref rundat 1))) (for-each (lambda (run) @@ -1934,40 +1910,40 @@ (if (or lock (and unlock (begin (print "Do you really wish to unlock run " run-id "?\n y/n: ") (equal? "y" (read-line))))) - (rmt:lock/unlock-run run-id lock unlock user) + (rmt:lock/unlock-run area-dat run-id lock unlock user) (debug:print-info 0 *default-log-port* "Skipping lock/unlock on " run-id)))) runs))) ;;====================================================================== ;; Rollup runs ;;====================================================================== ;; Update the test_meta table for this test -(define (runs:update-test_meta test-name test-conf) - (let ((currrecord (rmt:testmeta-get-record test-name))) +(define (runs:update-test_meta area-dat test-name test-conf) + (let ((currrecord (rmt:testmeta-get-record area-dat test-name))) (if (not currrecord) (begin (set! currrecord (make-vector 11 #f)) - (rmt:testmeta-add-record test-name))) + (rmt:testmeta-add-record area-dat test-name))) (for-each (lambda (key) (let* ((idx (cadr key)) (fld (car key)) (val (config-lookup test-conf "test_meta" fld))) ;; (debug:print 5 *default-log-port* "idx: " idx " fld: " fld " val: " val) (if (and val (not (equal? (vector-ref currrecord idx) val))) (begin (print "Updating " test-name " " fld " to " val) - (rmt:testmeta-update-field test-name fld val))))) + (rmt:testmeta-update-field area-dat test-name fld val))))) '(("author" 2)("owner" 3)("description" 4)("reviewed" 5)("tags" 9)("jobgroup" 10))))) ;; find tests with matching tags, tagpatt is a string "tagpatt1,tagpatt2%, ..." ;; -(define (runs:get-tests-matching-tags tagpatt) - (let* ((tagdata (rmt:get-tests-tags)) +(define (runs:get-tests-matching-tags area-dat tagpatt) + (let* ((tagdata (rmt:get-tests-tags area-dat)) (res '())) ;; list of tests that match one or more tags (for-each (lambda (tag) (if (patt-list-match tag tagpatt) (set! res (append (hash-table-ref tagdata tag))))) @@ -1974,30 +1950,30 @@ (hash-table-keys tagdata)) res)) ;; Update test_meta for all tests -(define (runs:update-all-test_meta db) +(define (runs:update-all-test_meta area-dat) (let ((test-names (tests:get-all))) ;; (tests:get-valid-tests))) (for-each (lambda (test-name) (let* ((test-conf (mt:lazy-read-test-config test-name))) - (if test-conf (runs:update-test_meta test-name test-conf)))) + (if test-conf (runs:update-test_meta area-dat test-name test-conf)))) (hash-table-keys test-names)))) ;; This could probably be refactored into one complex query ... ;; NOT PORTED - DO NOT USE YET ;; -(define (runs:rollup-run keys runname user keyvals) +(define (runs:rollup-run area-dat keys runname user keyvals) (debug:print 4 *default-log-port* "runs:rollup-run, keys: " keys " -runname " runname " user: " user) (let* ((db #f) ;; register run operates on the main db - (new-run-id (rmt:register-run keyvals runname "new" "n/a" user)) - (prev-tests (rmt:get-matching-previous-test-run-records new-run-id "%" "%")) + (new-run-id (rmt:register-run area-dat keyvals runname "new" "n/a" user)) + (prev-tests (rmt:get-matching-previous-test-run-records area-dat new-run-id "%" "%")) (curr-tests (mt:get-tests-for-run new-run-id "%/%" '() '())) (curr-tests-hash (make-hash-table))) - (rmt:update-run-event_time new-run-id) + (rmt:update-run-event_time area-dat new-run-id) ;; index the already saved tests by testname and itemdat in curr-tests-hash (for-each (lambda (testdat) (let* ((testname (db:test-get-testname testdat)) (item-path (db:test-get-item-path testdat)) @@ -2011,11 +1987,11 @@ (lambda (testdat) (let* ((testname (db:test-get-testname testdat)) (item-path (db:test-get-item-path testdat)) (full-name (conc testname "/" item-path)) (prev-test-dat (hash-table-ref/default curr-tests-hash full-name #f)) - (test-steps (rmt:get-steps-for-test (db:test-get-id testdat))) + (test-steps (rmt:get-steps-for-test area-dat (db:test-get-id testdat))) (new-test-record #f)) ;; replace these with insert ... select (apply sqlite3:execute db (conc "INSERT OR REPLACE INTO tests (run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment) " Index: server.scm ================================================================== --- server.scm +++ server.scm @@ -98,12 +98,10 @@ ;; try running on that host ;; incidental: rotate logs in logs/ dir. ;; (define (server:run areapath) ;; areapath is *toppath* for a given testsuite area (let* ((curr-host (get-host-name)) - ;; (attempt-in-progress (server:start-attempted? areapath)) - ;; (dot-server-url (server:check-if-running areapath)) (curr-ip (server:get-best-guess-address curr-host)) (curr-pid (current-process-id)) (homehost (common:get-homehost)) ;; configf:lookup *configdat* "server" "homehost" )) (target-host (car homehost)) (testsuite (common:get-testsuite-name)) @@ -267,21 +265,21 @@ (random 5)))) ;; add a small random number just in case a lot of jobs hit the work hosts simultaneously (if (> (- (current-seconds) when-run) run-delay) (server:run areapath)) (hash-table-set! *server-kind-run* areapath (list (+ call-num 1)(current-seconds))))) -(define (server:start-and-wait areapath #!key (timeout 60)) +(define (server:start-and-wait area-dat areapath #!key (timeout 60)) (let ((give-up-time (+ (current-seconds) timeout))) - (let loop ((server-url (server:check-if-running areapath))) + (let loop ((server-url (server:check-if-running area-dat areapath))) (if (or server-url (> (current-seconds) give-up-time)) ;; server-url will be #f if no server available. server-url (let ((num-ok (length (server:get-best (server:get-list areapath))))) (if (< num-ok 1) ;; if there are no decent candidates for servers then try starting a new one (server:kind-run areapath)) (thread-sleep! 5) - (loop (server:check-if-running areapath))))))) + (loop (server:check-if-running area-dat areapath))))))) (define server:try-running server:run) ;; there is no more per-run servers ;; REMOVE ME. BUG. (define (server:dotserver-age-seconds areapath) (let ((server-file (conc areapath "/.server"))) @@ -292,29 +290,29 @@ (- (current-seconds) (file-modification-time server-file)))))) ;; no longer care if multiple servers are started by accident. older servers will drop off in time. ;; -(define (server:check-if-running areapath) +(define (server:check-if-running area-dat areapath) (let* ((servers (server:get-best (server:get-list areapath)))) (if (null? servers) #f (let loop ((hed (car servers)) (tal (cdr servers))) - (let ((res (server:check-server hed))) + (let ((res (server:check-server area-dat hed))) (if res res (if (null? tal) #f (loop (car tal)(cdr tal))))))))) ;; ping the given server ;; -(define (server:check-server server-record) +(define (server:check-server area-dat server-record) (let* ((server-url (server:record->url server-record)) (res (case *transport-type* - ((http)(server:ping server-url)) + ((http)(server:ping area-dat server-url)) ;; ((nmsg)(nmsg-transport:ping (tasks:hostinfo-get-interface server) ))) (if res server-url #f))) @@ -327,38 +325,30 @@ ;; called in megatest.scm, host-port is string hostname:port ;; ;; NOTE: This is NOT called directly from clients as not all transports support a client running ;; in the same process as the server. ;; -(define (server:ping host-port-in #!key (do-exit #f)) +(define (server:ping area-dat host-port-in #!key (do-exit #f)) (let ((host:port (if (not host-port-in) ;; use read-dotserver to find - #f ;; (server:check-if-running *toppath*) - ;; (if (number? host-port-in) ;; we were handed a server-id - ;; (let ((srec (tasks:get-server-by-id (db:delay-if-busy (tasks:open-db)) host-port-in))) - ;; ;; (print "srec: " srec " host-port-in: " host-port-in) - ;; (if srec - ;; (conc (vector-ref srec 3) ":" (vector-ref srec 4)) - ;; (conc "no such server-id " host-port-in))) + #f host-port-in))) ;; ) (let* ((host-port (if host:port (let ((slst (string-split host:port ":"))) (if (eq? (length slst) 2) (list (car slst)(string->number (cadr slst))) #f)) #f))) -;; (toppath (launch:setup))) - ;; (print "host-port=" host-port) (if (not host-port) (begin (if host-port-in (debug:print 0 *default-log-port* "ERROR: bad host:port")) (if do-exit (exit 1)) #f) (let* ((iface (car host-port)) (port (cadr host-port)) (server-dat (http-transport:client-connect iface port)) - (login-res (rmt:login-no-auto-client-setup server-dat))) + (login-res (rmt:login-no-auto-client-setup area-dat server-dat))) (if (and (list? login-res) (car login-res)) (begin ;; (print "LOGIN_OK") (if do-exit (exit 0)) Index: synchash.scm ================================================================== --- synchash.scm +++ synchash.scm @@ -58,12 +58,12 @@ ;; (list indat '()) ;; just for debugging )) ;; keynum => the field to use as the unique key (usually 0 but can be other field) ;; -(define (synchash:client-get proc synckey keynum synchash run-id . params) - (let* ((data (rmt:synchash-get run-id proc synckey keynum params)) +(define (synchash:client-get area-dat proc synckey keynum synchash run-id . params) + (let* ((data (rmt:synchash-get area-dat run-id proc synckey keynum params)) (newdat (car data)) (removs (cadr data)) (myhash (hash-table-ref/default synchash synckey #f))) (if (not myhash) (begin Index: tasks.scm ================================================================== --- tasks.scm +++ tasks.scm @@ -507,12 +507,12 @@ ;; kill any runner processes (i.e. processes handling -runtests) that match target/runname ;; ;; do a remote call to get the task queue info but do the killing as self here. ;; -(define (tasks:kill-runner target run-name testpatt) - (let ((records (rmt:tasks-find-task-queue-records target run-name testpatt "running" "run-tests")) +(define (tasks:kill-runner area-dat target run-name testpatt) + (let ((records (rmt:tasks-find-task-queue-records area-dat target run-name testpatt "running" "run-tests")) (hostpid-rx (regexp "\\s+(\\w+)\\s+(\\d+)$"))) ;; host pid is at end of param string (if (null? records) (debug:print 0 *default-log-port* "No run launching processes found for " target " / " run-name " with testpatt " (or testpatt "* no testpatt specified! *")) (debug:print 0 *default-log-port* "Found " (length records) " run(s) to kill.")) (for-each Index: tdb.scm ================================================================== --- tdb.scm +++ tdb.scm @@ -101,14 +101,14 @@ ;; provide an in-mem db (this is dangerous!) (tdb:testdb-initialize baddb) baddb))) ;; find and open the testdat.db file for an existing test -(define (tdb:open-test-db-by-test-id test-id #!key (work-area #f)) +(define (tdb:open-test-db-by-test-id area-dat test-id #!key (work-area #f)) (let* ((test-path (if work-area work-area - (rmt:test-get-rundir-from-test-id test-id)))) + (rmt:test-get-rundir-from-test-id area-dat test-id)))) (debug:print 3 *default-log-port* "TEST PATH: " test-path) (open-test-db test-path))) ;; find and open the testdat.db file for an existing test (define (tdb:open-test-db-by-test-id-local dbstruct run-id test-id #!key (work-area #f)) @@ -204,36 +204,36 @@ ;; (sqlite3:finalize! tdb) ;; (reverse res)) ;; '()))) ;; NOTE: Run this local with #f for db !!! -(define (tdb:load-test-data run-id test-id) +(define (tdb:load-test-data area-dat run-id test-id) (let loop ((lin (read-line))) (if (not (eof-object? lin)) (begin (debug:print 4 *default-log-port* lin) ;;(when lin ;; this when blocked stack dump caused by .dat file from logpro being 0-byte. fixed by upgrading logpro - (rmt:csv->test-data run-id test-id lin) + (rmt:csv->test-data area-dat run-id test-id lin) ;;) (loop (read-line))))) ;; roll up the current results. ;; FIXME: Add the status too - (rmt:test-data-rollup run-id test-id #f)) + (rmt:test-data-rollup area-dat run-id test-id #f)) ;; NOTE: Run this local with #f for db !!! -(define (tdb:load-logpro-data run-id test-id) +(define (tdb:load-logpro-data area-dat run-id test-id) (let loop ((lin (read-line))) (if (not (eof-object? lin)) (begin (debug:print 4 *default-log-port* lin) ;;(when lin ;; this when blocked stack dump caused by .dat file from logpro being 0-byte. fixed by upgrading logpro - (rmt:csv->test-data run-id test-id lin) + (rmt:csv->test-data area-dat run-id test-id lin) ;;) (loop (read-line))))) ;; roll up the current results. ;; FIXME: Add the status too - (rmt:test-data-rollup run-id test-id #f)) + (rmt:test-data-rollup area-dat run-id test-id #f)) (define (tdb:get-prev-tol-for-test tdb test-id category variable) ;; Finish me? (values #f #f #f)) @@ -391,15 +391,16 @@ (stringtest-data run-id test-id + (rmt:csv->test-data area-dat run-id test-id dat)))) ;; need to update the top test record if PASS or FAIL and this is a subtest ;;;;;; (if (not (equal? item-path "")) - ;;;;;; (rmt:set-state-status-and-roll-up-items run-id test-name item-path state status #f) ;;;;;) + ;;;;;; (rmt:set-state-status-and-roll-up-items area-dat run-id test-name item-path state status #f) ;;;;;) (if (or (and (string? comment) (string-match (regexp "\\S+") comment)) waived) (let ((cmt (if waived waived comment))) - (rmt:general-call 'set-test-comment run-id cmt test-id))))) + (rmt:general-call area-dat 'set-test-comment run-id cmt test-id))))) -(define (tests:test-set-toplog! run-id test-name logf) - (rmt:general-call 'tests:test-set-toplog run-id logf run-id test-name)) +(define (tests:test-set-toplog! area-dat run-id test-name logf) + (rmt:general-call area-dat 'tests:test-set-toplog run-id logf run-id test-name)) -(define (tests:summarize-items run-id test-id test-name force) +(define (tests:summarize-items area-dat run-id test-id test-name force) ;; if not force then only update the record if one of these is true: ;; 1. logf is "log/final.log ;; 2. logf is same as outputfilename (let* ((outputfilename (conc "megatest-rollup-" test-name ".html")) (orig-dir (current-directory)) - (logf-info (rmt:test-get-logfile-info run-id test-name)) + (logf-info (rmt:test-get-logfile-info area-dat run-id test-name)) (logf (if logf-info (cadr logf-info) #f)) (path (if logf-info (car logf-info) #f))) ;; This query finds the path and changes the directory to it for the test (if (and (string? path) (directory? path)) ;; can get #f here under some wierd conditions. why, unknown ... @@ -476,33 +476,33 @@ (lockf (conc outputfilename ".lock"))) (let loop ((have-lock (common:simple-file-lock lockf))) (if have-lock (let ((script (configf:lookup *configdat* "testrollup" test-name))) (print "Obtained lock for " outputfilename) - (rmt:set-state-status-and-roll-up-items run-id test-name "" #f #f #f) + (rmt:set-state-status-and-roll-up-items area-dat run-id test-name "" #f #f #f) (if script (system (conc script " > " outputfilename " & ")) - (tests:generate-html-summary-for-iterated-test run-id test-id test-name outputfilename)) + (tests:generate-html-summary-for-iterated-test area-dat run-id test-id test-name outputfilename)) (common:simple-file-release-lock lockf) (change-directory orig-dir) ;; NB// tests:test-set-toplog! is remote internal... - (tests:test-set-toplog! run-id test-name outputfilename)) + (tests:test-set-toplog! area-dat run-id test-name outputfilename)) ;; didn't get the lock, check to see if current update started later than this ;; update, if so we can exit without doing any work (if (> my-start-time (file-modification-time lockf)) ;; we started since current re-gen in flight, delay a little and try again (begin (debug:print-info 1 *default-log-port* "Waiting to update " outputfilename ", another test currently updating it") (thread-sleep! (+ 5 (random 5))) ;; delay between 5 and 10 seconds (loop (common:simple-file-lock lockf)))))))))) -(define (tests:generate-html-summary-for-iterated-test run-id test-id test-name outputfilename) +(define (tests:generate-html-summary-for-iterated-test area-dat run-id test-id test-name outputfilename) (let ((counts (make-hash-table)) (statecounts (make-hash-table)) (outtxt "") (tot 0) - (testdat (rmt:test-get-records-for-index-file run-id test-name))) + (testdat (rmt:test-get-records-for-index-file area-dat run-id test-name))) (with-output-to-file outputfilename (lambda () (set! outtxt (conc outtxt "Summary: " test-name "

Summary for " test-name "

")) (for-each @@ -555,11 +555,11 @@ (print "" "" outtxt "
ItemStateStatusComment
") ;; (release-dot-lock outputfilename) - ;;(rmt:update-run-stats + ;;(rmt:update-run-stats area-dat ;; run-id ;; (hash-table-map ;; state-status-counts ;; (lambda (key val) ;; (append key (list val))))) @@ -666,17 +666,17 @@ (define (tests:run-record->test-path run numkeys) (append (take (vector->list run) numkeys) (list (vector-ref run (+ 1 numkeys))))) -(define (tests:get-rest-data runs header numkeys) +(define (tests:get-rest-data area-dat runs header numkeys) (let ((resh (make-hash-table))) (for-each (lambda (run) (let* ((run-id (db:get-value-by-header run header "id")) (run-dir (tests:run-record->test-path run numkeys)) - (test-data (rmt:get-tests-for-run + (test-data (rmt:get-tests-for-run area-dat run-id "%" ;; testnamepatt '() ;; states '() ;; statuses #f ;; offset @@ -703,30 +703,30 @@ runs) resh)) ;; (tests:create-html-tree "test-index.html") ;; -(define (tests:create-html-tree outf) +(define (tests:create-html-tree area-dat outf) (let* ((lockfile (conc outf ".lock")) (runs-to-process '()) (linktree (common:get-linktree)) (area-name (common:get-testsuite-name)) - (keys (rmt:get-keys)) + (keys (rmt:get-keys area-dat)) (numkeys (length keys)) - (total-runs (rmt:get-num-runs "%")) + (total-runs (rmt:get-num-runs area-dat "%")) (pg-size 10) ) (if (common:simple-file-lock lockfile) (begin (print total-runs) (let loop ((page 0)) (let* ((oup (open-output-file (or outf (conc linktree "/page" page ".html")))) (start (* page pg-size)) - (runsdat (rmt:get-runs "%" pg-size start (map (lambda (x)(list x "%")) keys))) + (runsdat (rmt:get-runs area-dat "%" pg-size start (map (lambda (x)(list x "%")) keys))) (header (vector-ref runsdat 0)) (runs (vector-ref runsdat 1)) (ctr 0) - (test-runs-hash (tests:get-rest-data runs header numkeys)) + (test-runs-hash (tests:get-rest-data area-dat runs header numkeys)) (test-list (hash-table-keys test-runs-hash)) (get-prev-links (lambda (page linktree ) (let* ((link (if (not (eq? page 0)) (s:a "<<prev" 'href (conc linktree "/page" (- page 1) ".html")) (s:a "" 'href (conc linktree "/page" page ".html"))))) @@ -798,20 +798,20 @@ -(define (tests:create-html-tree-old outf) +(define (tests:create-html-tree-old area-dat outf) (let* ((lockfile (conc outf ".lock")) (runs-to-process '())) (if (common:simple-file-lock lockfile) (let* ((linktree (common:get-linktree)) (oup (open-output-file (or outf (conc linktree "/runs-index.html")))) (area-name (common:get-testsuite-name)) - (keys (rmt:get-keys)) + (keys (rmt:get-keys area-dat)) (numkeys (length keys)) - (runsdat (rmt:get-runs "%" #f #f (map (lambda (x)(list x "%")) keys))) + (runsdat (rmt:get-runs area-dat "%" #f #f (map (lambda (x)(list x "%")) keys))) (header (vector-ref runsdat 0)) (runs (vector-ref runsdat 1)) (runtreedat (map (lambda (x) (tests:run-record->test-path x numkeys)) runs)) @@ -846,11 +846,11 @@ (for-each (lambda (run) (let* ((test-subpath (tests:run-record->test-path run numkeys)) (run-id (db:get-value-by-header run header "id")) (run-dir (tests:run-record->test-path run numkeys)) - (test-dats (rmt:get-tests-for-run + (test-dats (rmt:get-tests-for-run area-dat run-id "%/" ;; testnamepatt '() ;; states '() ;; statuses #f ;; offset @@ -905,13 +905,13 @@ std-file)) (run-name (car (reverse p)))) (if (and (not (file-exists? full-targ)) (directory? full-targ) (file-write-access? full-targ)) - (tests:summarize-test + (tests:summarize-test area-dat run-id - (rmt:get-test-id run-id test-name item-path))) + (rmt:get-test-id area-dat run-id test-name item-path))) (if (file-exists? full-targ) (s:a run-name 'href html-file) (begin (debug:print 0 *default-log-port* "ERROR: can't access " full-targ) (conc "No summary for " run-name))))) @@ -994,12 +994,12 @@ (else #f))))) res)) ;; ;; -(define (tests:get-compressed-steps run-id test-id) - (let* ((steps-data (rmt:get-steps-for-test run-id test-id)) +(define (tests:get-compressed-steps area-dat run-id test-id) + (let* ((steps-data (rmt:get-steps-for-test area-dat run-id test-id)) (comprsteps (tests:process-steps-table steps-data))) ;; (open-run-close db:get-steps-table #f test-id work-area: work-area))) (map (lambda (x) ;; take advantage of the \n on time->string (vector (vector-ref x 0) @@ -1025,21 +1025,21 @@ (stringlist exn))