@@ -50,16 +50,16 @@ ;; (print "runsdat: " runsdat) (let* ((header (vector-ref runsdat 0)) (runslst (vector-ref runsdat 1)) (full-list (append res runslst)) (have-more (eq? (length runslst) limit))) - ;; (debug:print 0 "header: " header " runslst: " runslst " have-more: " have-more) + ;; (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))) - (debug:print-info 4 "More than " limit " runs, have " (length full-list) " runs so far.") - (debug:print-info 0 "next-batch: " next-batch) + (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 limit)) (vector header full-list))))) @@ -66,21 +66,21 @@ ;;====================================================================== ;; 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)) - (let loop ((testsdat (rmt:get-tests-for-run run-id testpatt states status 0 500 not-in sort-by sort-order qryvals)) +(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)) (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 "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) + (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) full-list new-offset limit)) full-list)))) @@ -91,11 +91,11 @@ (if last-time (< (current-seconds)(+ last-time 5)) #f)))) (if useres (let ((result (vector-ref res 1))) - (debug:print 4 "Using lazy value res: " result) + (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))) (hash-table-set! *pre-reqs-met-cache* key (vector (current-seconds) newres)) newres)))) @@ -105,11 +105,11 @@ (define (mt:discard-blocked-tests run-id failed-test tests test-records) (if (null? tests) tests (begin - (debug:print-info 1 "Discarding tests from " tests " that are waiting on " failed-test) + (debug:print-info 1 *default-log-port* "Discarding tests from " tests " that are waiting on " failed-test) (let loop ((testn (car tests)) (remt (cdr tests)) (res '())) (let* ((test-dat (hash-table-ref/default test-records testn (vector #f #f '()))) (waitons (vector-ref test-dat 2))) @@ -120,11 +120,11 @@ new-res) (loop (car remt) (cdr remt) (if (member failed-test waitons) (begin - (debug:print 0 "Discarding test " testn "(" test-dat ") due to " failed-test) + (debug:print 0 *default-log-port* "Discarding test " testn "(" test-dat ") due to " failed-test) res) (cons testn res))))))))) ;;====================================================================== ;; T R I G G E R S @@ -137,11 +137,12 @@ (db:test-rundir test-dat)) ;; ) ;; ) (test-name (db:test-testname test-dat)) (tconfig #f) (state (if newstate newstate (db:test-state test-dat))) (status (if newstatus newstatus (db:test-status test-dat)))) - (if (and test-rundir ;; #f means no dir set yet + (if (and test-name + test-rundir ;; #f means no dir set yet (file-exists? test-rundir) (directory? test-rundir)) (call-with-environment-variables (list (cons "MT_TEST_NAME" test-name) (cons "MT_TEST_RUN_DIR" test-rundir) @@ -155,11 +156,11 @@ (if cmd ;; Putting the commandline into ( )'s means no control over the shell. ;; stdout and stderr will be caught in the NBFAKE or mt_launch.log files ;; or equivalent. No need to do this. Just run it? (let ((fullcmd (conc cmd " " test-id " " test-rundir " " trigger "&"))) - (debug:print-info 0 "TRIGGERED on " trigger ", running command " fullcmd) + (debug:print-info 0 *default-log-port* "TRIGGERED on " trigger ", running command " fullcmd) (process-run fullcmd))))) (list (conc state "/" status) (conc state "/") (conc "/" status))) @@ -172,11 +173,11 @@ ;; speed up for common cases with a little logic (define (mt:test-set-state-status-by-id run-id test-id newstate newstatus newcomment) (if (not (and run-id test-id)) (begin - (debug:print 0 "ERROR: bad data handed to mt:test-set-state-status-by-id, run-id=" run-id ", test-id=" test-id ", newstate=" newstate) + (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) @@ -214,9 +215,9 @@ (setenv "MT_LINKTREE" old-link-tree) (unsetenv "MT_LINKTREE")) newtcfg)) (if (null? tal) (begin - (debug:print 0 "ERROR: No readable testconfig found for " test-name) + (debug:print-error 0 *default-log-port* "No readable testconfig found for " test-name) #f) (loop (car tal)(cdr tal))))))))))