Index: Makefile ================================================================== --- Makefile +++ Makefile @@ -228,15 +228,17 @@ # base64 dot-locking \ # csv-xml z3 # "(define (toplevel-command . a) #f)" +# if egrep 'version.*3.0' $(shell dirname $(shell dirname $(shell which csi)))/lib/chicken/7/readline.setup-info;then \ + readline-fix.scm : - if egrep 'version.*3.0' $(shell dirname $(shell dirname $(shell which csi)))/lib/chicken/7/readline.setup-info;then \ - echo "(use-legacy-bindings)" > readline-fix.scm; \ + if [[ $(shell chicken-status | grep readline | awk '{print $4}' | cut -d. -f1) -gt 3 ]];then \ + echo "(define *use-new-readline* #f)" > readline-fix.scm; \ else \ - echo "" > readline-fix.scm;\ + echo "(define *use-new-readline* #t)" > readline-fix.scm;\ fi altdb.scm : echo ";; optional alternate db setup" > altdb.scm echo "(define *available-db* (make-hash-table))" >> altdb.scm Index: api.scm ================================================================== --- api.scm +++ api.scm @@ -107,11 +107,11 @@ (define (api:execute-requests dbstruct dat) (handle-exceptions exn (let ((call-chain (get-call-chain))) (print-call-chain (current-error-port)) - (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) + (debug:print 0 #f " message: " ((condition-property-accessor 'exn 'message) exn)) (vector #f (vector exn call-chain dat))) ;; return some stuff for debug if an exception happens (if (not (vector? dat)) ;; it is an error to not receive a vector (vector #f #f "remote must be called with a vector") (vector ;; return a vector + the returned data structure #t Index: archive.scm ================================================================== --- archive.scm +++ archive.scm @@ -115,15 +115,15 @@ (compress (or (configf:lookup *configdat* "archive" "compress") "9")) (linktree (configf:lookup *configdat* "setup" "linktree"))) (if (not archive-dir) ;; no archive disk found, this is fatal (begin - (debug:print 0 "FATAL: No archive disks found. Please add disks with at least " min-space " MB space to the [archive-disks] section of megatest.config") - (debug:print 0 " use [archive] minspace to specify minimum available space") - (debug:print 0 " disks: " (string-intersperse (map cadr (archive:get-archive-disks)) "\n ")) + (debug:print 0 #f "FATAL: No archive disks found. Please add disks with at least " min-space " MB space to the [archive-disks] section of megatest.config") + (debug:print 0 #f " use [archive] minspace to specify minimum available space") + (debug:print 0 #f " disks: " (string-intersperse (map cadr (archive:get-archive-disks)) "\n ")) (exit 1)) - (debug:print-info 0 "Using path " archive-dir " for archiving")) + (debug:print-info 0 #f "Using path " archive-dir " for archiving")) ;; from the test info bin the path to the test by stem ;; (for-each (lambda (test-dat) @@ -151,15 +151,15 @@ partial-path-index) #f))) (cond (toplevel/children - (debug:print 0 "WARNING: cannot archive " test-name " with id " test-id " as it is a toplevel test with children")) + (debug:print 0 #f "WARNING: cannot archive " test-name " with id " test-id " as it is a toplevel test with children")) ((not (file-exists? test-path)) - (debug:print 0 "WARNING: Cannot archive " test-name "/" item-path " as path " test-path " does not exist")) + (debug:print 0 #f "WARNING: Cannot archive " test-name "/" item-path " as path " test-path " does not exist")) (else - (debug:print 0 + (debug:print 0 #f "From test-dat=" test-dat " derived the following:\n" "test-partial-path = " test-partial-path "\n" "test-path = " test-path "\n" "test-physical-path = " test-physical-path "\n" "partial-path-index = " partial-path-index "\n" @@ -169,11 +169,11 @@ test-path)))) tests) ;; for each disk-group (for-each (lambda (disk-group) - (debug:print 0 "Processing disk-group " disk-group) + (debug:print 0 #f "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)) "-") (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) @@ -185,19 +185,19 @@ (if (not (file-exists? archive-dir)) (create-directory archive-dir #t)) (if (not (file-exists? (conc archive-dir "/HEAD"))) (begin ;; replace this with jobrunner stuff enventually - (debug:print-info 0 "Init bup in " archive-dir) + (debug:print-info 0 #f "Init bup in " archive-dir) ;; (mutex-lock! bup-mutex) (run-n-wait bup-exe params: bup-init-params print-cmd: print-prefix) ;; (mutex-unlock! bup-mutex) )) - (debug:print-info 0 "Indexing data to be archived") + (debug:print-info 0 #f "Indexing data to be archived") ;; (mutex-lock! bup-mutex) (run-n-wait bup-exe params: bup-index-params print-cmd: print-prefix) - (debug:print-info 0 "Archiving data with bup") + (debug:print-info 0 #f "Archiving data with bup") (run-n-wait bup-exe params: bup-save-params print-cmd: print-prefix) ;; (mutex-unlock! bup-mutex) (for-each (lambda (test-dat) (let ((test-id (db:test-get-id test-dat)) @@ -254,11 +254,11 @@ prev-test-physical-path (file-exists? prev-test-physical-path)) ;; what to do? abort or clean up or link it in? (let* ((base (pathname-directory prev-test-physical-path)) (dirn (pathname-file prev-test-physical-path)) (newn (conc base "/." dirn))) - (debug:print 0 "ERROR: the old directory " prev-test-physical-path ", still exists! Moving it to " newn) + (debug:print 0 #f "ERROR: the old directory " prev-test-physical-path ", still exists! Moving it to " newn) (rename-file prev-test-physical-path newn))) (if (and archive-path ;; no point in proceeding if there is no actual archive (not toplevel/children)) (begin @@ -276,17 +276,17 @@ ;; DO BUP RESTORE (let* ((new-test-dat (rmt:get-test-info-by-id run-id test-id)) (new-test-path (if (vector? new-test-dat ) (db:test-get-rundir new-test-dat) (begin - (debug:print 0 "ERROR: unable to get data for run-id=" run-id ", test-id=" test-id) + (debug:print 0 #f "ERROR: unable to get data for run-id=" run-id ", test-id=" test-id) (exit 1)))) ;; new-test-path won't work - must use best-disk instead? Nope, new-test-path but tack on /.. (bup-restore-params (list "-d" archive-path "restore" "-C" (conc new-test-path "/..") archive-internal-path))) - (debug:print-info 0 "Restoring archived data to " new-test-physical-path " from archive in " archive-path " ... " archive-internal-path) + (debug:print-info 0 #f "Restoring archived data to " new-test-physical-path " from archive in " archive-path " ... " archive-internal-path) ;; (mutex-lock! bup-mutex) (run-n-wait bup-exe params: bup-restore-params print-cmd: #f) ;; (mutex-unlock! bup-mutex) (mt:test-set-state-status-by-id run-id test-id "COMPLETED" #f #f))) - (debug:print 0 "ERROR: No archive path in the record for run-id=" run-id " test-id=" test-id)))) + (debug:print 0 #f "ERROR: No archive path in the record for run-id=" run-id " test-id=" test-id)))) (filter vector? tests)))) Index: client.scm ================================================================== --- client.scm +++ client.scm @@ -61,17 +61,17 @@ ;; ((rpc) (rpc:login-no-auto-client-setup server-info run-id)) ;; ((http) (rmt:login-no-auto-client-setup server-info run-id)) ;; (else (rpc:login-no-auto-client-setup server-info run-id)))) ;; ;; (define (client:setup-rpc run-id) -;; (debug:print 0 "INFO: client:setup remaining-tries=" remaining-tries) +;; (debug:print 0 #f "INFO: client:setup remaining-tries=" remaining-tries) ;; (if (<= remaining-tries 0) ;; (begin -;; (debug:print 0 "ERROR: failed to start or connect to server for run-id " run-id) +;; (debug:print 0 #f "ERROR: failed to start or connect to server for run-id " run-id) ;; (exit 1)) ;; (let ((host-info (hash-table-ref/default *runremote* run-id #f))) -;; (debug:print-info 0 "client:setup host-info=" host-info ", remaining-tries=" remaining-tries) +;; (debug:print-info 0 #f "client:setup host-info=" host-info ", remaining-tries=" remaining-tries) ;; (if host-info ;; (let* ((iface (car host-info)) ;; (port (cadr host-info)) ;; (start-res (client:connect iface port)) ;; ;; (ping-res (server:ping-server run-id iface port)) @@ -80,11 +80,11 @@ ;; (begin ;; (hash-table-set! *runremote* run-id start-res) ;; start-res) ;; return the server info ;; (if (member remaining-tries '(3 4 6)) ;; (begin ;; login failed -;; (debug:print 25 "INFO: client:setup start-res=" start-res ", run-id=" run-id ", server-dat=" host-info) +;; (debug:print 25 #f "INFO: client:setup start-res=" start-res ", run-id=" run-id ", server-dat=" host-info) ;; (hash-table-delete! *runremote* run-id) ;; (open-run-close tasks:server-force-clean-run-record ;; tasks:open-db ;; run-id ;; (car host-info) @@ -91,16 +91,16 @@ ;; (cadr host-info) ;; " client:setup (host-info=#t)") ;; (thread-sleep! 5) ;; (client:setup run-id remaining-tries: 10)) ;; (- remaining-tries 1))) ;; (begin -;; (debug:print 25 "INFO: client:setup failed to connect, start-res=" start-res ", run-id=" run-id ", host-info=" host-info) +;; (debug:print 25 #f "INFO: client:setup failed to connect, start-res=" start-res ", run-id=" run-id ", host-info=" host-info) ;; (thread-sleep! 5) ;; (client:setup run-id remaining-tries: (- remaining-tries 1)))))) ;; ;; YUK: rename server-dat here ;; (let* ((server-dat (open-run-close tasks:get-server tasks:open-db run-id))) -;; (debug:print-info 0 "client:setup server-dat=" server-dat ", remaining-tries=" remaining-tries) +;; (debug:print-info 0 #f "client:setup server-dat=" server-dat ", remaining-tries=" remaining-tries) ;; (if server-dat ;; (let* ((iface (tasks:hostinfo-get-interface server-dat)) ;; (port (tasks:hostinfo-get-port server-dat)) ;; (start-res (http-transport:client-connect iface port)) ;; ;; (ping-res (server:ping-server run-id iface port)) @@ -109,11 +109,11 @@ ;; (begin ;; (hash-table-set! *runremote* run-id start-res) ;; start-res) ;; (if (member remaining-tries '(2 5)) ;; (begin ;; login failed -;; (debug:print 25 "INFO: client:setup start-res=" start-res ", run-id=" run-id ", server-dat=" server-dat) +;; (debug:print 25 #f "INFO: client:setup start-res=" start-res ", run-id=" run-id ", server-dat=" server-dat) ;; (hash-table-delete! *runremote* run-id) ;; (open-run-close tasks:server-force-clean-run-record ;; tasks:open-db ;; run-id ;; (tasks:hostinfo-get-interface server-dat) @@ -122,21 +122,21 @@ ;; (thread-sleep! 2) ;; (server:try-running run-id) ;; (thread-sleep! 10) ;; give server a little time to start up ;; (client:setup run-id remaining-tries: 10)) ;; (- remaining-tries 1))) ;; (begin -;; (debug:print 25 "INFO: client:setup start-res=" start-res ", run-id=" run-id ", server-dat=" server-dat) +;; (debug:print 25 #f "INFO: client:setup start-res=" start-res ", run-id=" run-id ", server-dat=" server-dat) ;; (thread-sleep! 5) ;; (client:setup run-id remaining-tries: (- remaining-tries 1)))))) ;; (begin ;; no server registered ;; (if (eq? remaining-tries 2) ;; (begin ;; ;; (open-run-close tasks:server-clean-out-old-records-for-run-id tasks:open-db run-id " client:setup (server-dat=#f)") ;; (client:setup run-id remaining-tries: 10)) ;; (begin ;; (thread-sleep! 2) -;; (debug:print 25 "INFO: client:setup start-res (not defined here), run-id=" run-id ", server-dat=" server-dat) +;; (debug:print 25 #f "INFO: client:setup start-res (not defined here), run-id=" run-id ", server-dat=" server-dat) ;; (if (< (open-run-close tasks:num-in-available-state tasks:open-db run-id) 3) ;; (begin ;; ;; (open-run-close tasks:server-clean-out-old-records-for-run-id tasks:open-db run-id " client:setup (server-dat=#f)") ;; (server:try-running run-id))) ;; (thread-sleep! 10) ;; give server a little time to start up @@ -153,18 +153,18 @@ ;; client:setup ;; ;; lookup_server, need to remove *runremote* stuff ;; (define (client:setup-http run-id #!key (remaining-tries 10) (failed-connects 0)) - (debug:print-info 2 "client:setup remaining-tries=" remaining-tries) + (debug:print-info 2 #f "client:setup remaining-tries=" remaining-tries) (let* ((tdbdat (tasks:open-db))) (if (<= remaining-tries 0) (begin - (debug:print 0 "ERROR: failed to start or connect to server for run-id " run-id) + (debug:print 0 #f "ERROR: failed to start or connect to server for run-id " run-id) (exit 1)) (let* ((server-dat (tasks:get-server (db:delay-if-busy tdbdat) run-id))) - (debug:print-info 4 "client:setup server-dat=" server-dat ", remaining-tries=" remaining-tries) + (debug:print-info 4 #f "client:setup server-dat=" server-dat ", remaining-tries=" remaining-tries) (if server-dat (let* ((iface (tasks:hostinfo-get-interface server-dat)) (hostname (tasks:hostinfo-get-hostname server-dat)) (port (tasks:hostinfo-get-port server-dat)) (start-res (case *transport-type* @@ -178,14 +178,14 @@ #f)))))) (if (and start-res ping-res) (begin (hash-table-set! *runremote* run-id start-res) - (debug:print-info 2 "connected to " (http-transport:server-dat-make-url start-res)) + (debug:print-info 2 #f "connected to " (http-transport:server-dat-make-url start-res)) start-res) (begin ;; login failed but have a server record, clean out the record and try again - (debug:print-info 0 "client:setup, login failed, will attempt to start server ... start-res=" start-res ", run-id=" run-id ", server-dat=" server-dat) + (debug:print-info 0 #f "client:setup, login failed, will attempt to start server ... start-res=" start-res ", run-id=" run-id ", server-dat=" server-dat) (case *transport-type* ((http)(http-transport:close-connections run-id))) (hash-table-delete! *runremote* run-id) (tasks:kill-server-run-id run-id) (tasks:server-force-clean-run-record (db:delay-if-busy tdbdat) @@ -200,11 +200,11 @@ (thread-sleep! 5) ;; give server a little time to start up (client:setup run-id remaining-tries: (- remaining-tries 1)) ))) (begin ;; no server registered (let ((num-available (tasks:num-in-available-state (db:dbdat-get-db tdbdat) run-id))) - (debug:print-info 0 "client:setup, no server registered, remaining-tries=" remaining-tries " num-available=" num-available) + (debug:print-info 0 #f "client:setup, no server registered, remaining-tries=" remaining-tries " num-available=" num-available) (if (< num-available 2) (server:try-running run-id)) (thread-sleep! (+ 5 (random (- 20 remaining-tries)))) ;; give server a little time to start up, randomize a little to avoid start storms. (client:setup run-id remaining-tries: (- remaining-tries 1))))))))) @@ -217,18 +217,18 @@ ;; (define (client:signal-handler signum) ;; (signal-mask! signum) ;; (set! *time-to-exit* #t) ;; (handle-exceptions ;; exn -;; (debug:print " ... exiting ...") +;; (debug:print 0 #f " ... exiting ...") ;; (let ((th1 (make-thread (lambda () ;; "") ;; do nothing for now (was flush out last call if applicable) ;; "eat response")) ;; (th2 (make-thread (lambda () -;; (debug:print 0 "ERROR: Received ^C, attempting clean exit. Please be patient and wait a few seconds before hitting ^C again.") +;; (debug:print 0 #f "ERROR: Received ^C, attempting clean exit. Please be patient and wait a few seconds before hitting ^C again.") ;; (thread-sleep! 1) ;; give the flush one second to do it's stuff -;; (debug:print 0 " Done.") +;; (debug:print 0 #f " Done.") ;; (exit 4)) ;; "exit on ^C timer"))) ;; (thread-start! th2) ;; (thread-start! th1) ;; (thread-join! th2)))) @@ -239,10 +239,10 @@ ;; ;; ;; (define (client:launch run-id) ;; (set-signal-handler! signal/int client:signal-handler) ;; (set-signal-handler! signal/term client:signal-handler) ;; (if (client:setup run-id) -;; (debug:print-info 2 "connected as client") +;; (debug:print-info 2 #f "connected as client") ;; (begin -;; (debug:print 0 "ERROR: Failed to connect as client") +;; (debug:print 0 #f "ERROR: Failed to connect as client") ;; (exit)))) ;; Index: common.scm ================================================================== --- common.scm +++ common.scm @@ -34,13 +34,13 @@ (define getenv get-environment-variable) (define (safe-setenv key val) (if (and (string? val)(string? key)) (handle-exceptions exn - (debug:print 0 "ERROR: bad value for setenv, key=" key ", value=" val) + (debug:print 0 #f "ERROR: bad value for setenv, key=" key ", value=" val) (setenv key val)) - (debug:print 0 "ERROR: bad value for setenv, key=" key ", value=" val))) + (debug:print 0 #f "ERROR: bad value for setenv, key=" key ", value=" val))) (define home (getenv "HOME")) (define user (getenv "USER")) ;; GLOBAL GLETCHES @@ -152,28 +152,46 @@ (define (common:version-changed?) (not (equal? (common:get-last-run-version) (common:version-signature)))) +;; Move me elsewhere ... +;; +(define (common:cleanup-db) + (db:multi-db-sync + #f ;; do all run-ids + ;; 'new2old + 'killservers + 'dejunk + ;; 'adj-testids + ;; 'old2new + 'new2old) + (if (common:version-changed?) + (common:set-last-run-version))) + (define (common:exit-on-version-changed) (if (common:version-changed?) - (begin - (debug:print 0 + (let ((mtconf (conc (get-environment-variable "MT_RUN_AREA_HOME") "/megatest.config"))) + (debug:print 0 #f "ERROR: Version mismatch!\n" " expected: " (common:version-signature) "\n" - " got: " (common:get-last-run-version) "\n" - " to switch versions you can run: \"megatest -cleanup-db\"") - ;; megatest -cleanup-db IS NOT correcting the dbver. Let's force it for now. - ;; Matt: please review this! - (db:multi-db-sync - #f - 'killservers - 'dejunk - 'new2old) - (rmt:set-var "MEGATEST_VERSION" (common:version-signature)) - - (exit 1)))) + " got: " (common:get-last-run-version)) + (if (and (file-exists? mtconf) + (eq? (current-user-id)(file-owner mtconf))) ;; safe to run -cleanup-db + (begin + (debug:print 0 #f " I see you are the owner of megatest.config, attempting to cleanup and reset to new version") + (handle-exceptions + exn + (begin + (debug:print 0 #f "Failed to switch versions.") + (debug:print 0 #f " message: " ((condition-property-accessor 'exn 'message) exn)) + (print-call-chain (current-error-port)) + (exit 1)) + (common:cleanup-db))) + (begin + (debug:print 0 #f " to switch versions you can run: \"megatest -cleanup-db\"") + (exit 1)))))) ;;====================================================================== ;; S P A R S E A R R A Y S ;;====================================================================== @@ -255,11 +273,11 @@ (handle-exceptions exn (handle-exceptions exn (begin - (debug:print 0 "ERROR: received bad encoded string \"" instr "\", message: " ((condition-property-accessor 'exn 'message) exn)) + (debug:print 0 #f "ERROR: received bad encoded string \"" instr "\", message: " ((condition-property-accessor 'exn 'message) exn)) (print-call-chain (current-error-port)) #f) (read (open-input-string (base64:base64-decode instr)))) (read (open-input-string (z3:decode-buffer (base64:base64-decode instr)))))) @@ -357,11 +375,11 @@ (let ((no-hurry (if *time-to-exit* ;; hurry up #f (begin (set! *time-to-exit* #t) #t)))) - (debug:print-info 4 "starting exit process, finalizing databases.") + (debug:print-info 4 #f "starting exit process, finalizing databases.") (if (and no-hurry (debug:debug-mode 18)) (rmt:print-db-stats)) (let ((th1 (make-thread (lambda () ;; thread for cleaning up, give it five seconds (let ((run-ids (hash-table-keys *db-local-sync*))) (if (and (not (null? run-ids)) @@ -382,25 +400,25 @@ (begin (sqlite3:interrupt! db) (sqlite3:finalize! db #t) (vector-set! *task-db* 0 #f)))))) "Cleanup db exit thread")) (th2 (make-thread (lambda () - (debug:print 4 "Attempting clean exit. Please be patient and wait a few seconds...") + (debug:print 4 #f "Attempting clean exit. Please be patient and wait a few seconds...") (if no-hurry (thread-sleep! 5) ;; give the clean up few seconds to do it's stuff (thread-sleep! 2)) - (debug:print 4 " ... done") + (debug:print 4 #f " ... done") ) "clean exit"))) (thread-start! th1) (thread-start! th2) (thread-join! th1)))) (define (std-signal-handler signum) ;; (signal-mask! signum) (set! *time-to-exit* #t) - (debug:print 0 "ERROR: Received signal " signum " exiting promptly") + (debug:print 0 #f "ERROR: Received signal " signum " exiting promptly") ;; (std-exit-procedure) ;; shouldn't need this since we are exiting and it will be called anyway (exit)) (set-signal-handler! signal/int std-signal-handler) ;; ^C (set-signal-handler! signal/term std-signal-handler) @@ -452,17 +470,17 @@ (define (any->number-if-possible val) (let ((num (any->number val))) (if num num val))) (define (patt-list-match item patts) - (debug:print-info 8 "patt-list-match item=" item " patts=" patts) + (debug:print-info 8 #f "patt-list-match item=" item " patts=" patts) (if (and item patts) ;; here we are filtering for matches with item patterns (let ((res #f)) ;; look through all the item-patts if defined, format is patt1,patt2,patt3 ... wildcard is % (for-each (lambda (patt) (let ((modpatt (string-substitute "%" ".*" patt #t))) - (debug:print-info 10 "patt " patt " modpatt " modpatt) + (debug:print-info 10 #f "patt " patt " modpatt " modpatt) (if (string-match (regexp modpatt) item) (set! res #t)))) (string-split patts ",")) res) #t)) @@ -513,11 +531,11 @@ (args:get-arg "-runtests") "%")) (testpatt (or (and (equal? args-testpatt "%") rtestpatt) args-testpatt))) - (if rtestpatt (debug:print-info 0 "TESTPATT from runconfigs: " rtestpatt)) + (if rtestpatt (debug:print-info 0 #f "TESTPATT from runconfigs: " rtestpatt)) testpatt)) (define (common:get-linktree) (or (getenv "MT_LINKTREE") (if *configdat* @@ -547,11 +565,11 @@ (if split tlist target) (if target (begin - (debug:print 0 "ERROR: Invalid target, spaces or blanks not allowed \"" target "\", target should be: " (string-intersperse keys "/") ", have " tlist " for elements") + (debug:print 0 #f "ERROR: Invalid target, spaces or blanks not allowed \"" target "\", target should be: " (string-intersperse keys "/") ", have " tlist " for elements") #f) #f)))) ;;====================================================================== ;; M I S C L I S T S @@ -620,11 +638,11 @@ (existing-coldat (assoc colkey colnames)) (curr-rownum (if existing-rowdat rownum (+ rownum 1))) (curr-colnum (if existing-coldat colnum (+ colnum 1))) (new-rownames (if existing-rowdat rownames (cons (list rowkey curr-rownum) rownames))) (new-colnames (if existing-coldat colnames (cons (list colkey curr-colnum) colnames)))) - ;; (debug:print-info 0 "Processing record: " hed ) + ;; (debug:print-info 0 #f "Processing record: " hed ) (if proc (proc curr-rownum curr-colnum rowkey colkey value)) (if (null? tal) (list new-rownames new-colnames) (loop (car tal) (cdr tal) @@ -652,11 +670,11 @@ (define (common:read-link-f path) (handle-exceptions exn (begin - (debug:print 0 "ERROR: command \"/bin/readlink -f " path "\" failed.") + (debug:print 0 #f "ERROR: command \"/bin/readlink -f " path "\" failed.") path) ;; just give up (with-input-from-pipe (conc "/bin/readlink -f " path) (lambda () (read-line))))) @@ -688,16 +706,16 @@ (adjload (* maxload numcpus)) (loadjmp (- first next))) (cond ((and (> first adjload) (> count 0)) - (debug:print-info 0 "waiting " waitdelay " seconds due to load " first " exceeding max of " adjload (if msg msg "")) + (debug:print-info 0 #f "waiting " waitdelay " seconds due to load " first " exceeding max of " adjload (if msg msg "")) (thread-sleep! waitdelay) (common:wait-for-cpuload maxload numcpus waitdelay count: (- count 1))) ((and (> loadjmp numcpus) (> count 0)) - (debug:print-info 0 "waiting " waitdelay " seconds due to load jump " loadjmp " > numcpus " numcpus (if msg msg "")) + (debug:print-info 0 #f "waiting " waitdelay " seconds due to load jump " loadjmp " > numcpus " numcpus (if msg msg "")) (thread-sleep! waitdelay) (common:wait-for-cpuload maxload numcpus waitdelay count: (- count 1)))))) (define (common:get-num-cpus) (with-input-from-file "/proc/cpuinfo" @@ -802,11 +820,11 @@ (dbspace (cadr spacedat)) (required (caddr spacedat)) (dbdir (cadddr spacedat))) (if (not is-ok) (begin - (debug:print 0 "ERROR: Insufficient space in " dbdir ", require " required ", have " dbspace ", exiting now.") + (debug:print 0 #f "ERROR: Insufficient space in " dbdir ", require " required ", have " dbspace ", exiting now.") (exit 1))))) ;; paths is list of lists ((name path) ... ) ;; (define (common:get-disk-with-most-free-space disks minsize) @@ -816,19 +834,19 @@ (lambda (disk-num) (let* ((dirpath (cadr (assoc disk-num disks))) (freespc (cond ((not (directory? dirpath)) (if (common:low-noise-print 300 "disks not a dir " disk-num) - (debug:print 0 "WARNING: disk " disk-num " at path \"" dirpath "\" is not a directory - ignoring it.")) + (debug:print 0 #f "WARNING: disk " disk-num " at path \"" dirpath "\" is not a directory - ignoring it.")) -1) ((not (file-write-access? dirpath)) (if (common:low-noise-print 300 "disks not writeable " disk-num) - (debug:print 0 "WARNING: disk " disk-num " at path \"" dirpath "\" is not writeable - ignoring it.")) + (debug:print 0 #f "WARNING: disk " disk-num " at path \"" dirpath "\" is not writeable - ignoring it.")) -1) ((not (eq? (string-ref dirpath 0) #\/)) (if (common:low-noise-print 300 "disks not a proper path " disk-num) - (debug:print 0 "WARNING: disk " disk-num " at path \"" dirpath "\" is not a fully qualified path - ignoring it.")) + (debug:print 0 #f "WARNING: disk " disk-num " at path \"" dirpath "\" is not a fully qualified path - ignoring it.")) -1) (else (get-df dirpath))))) (if (> freespc bestsize) (begin @@ -1212,20 +1230,20 @@ (tal (cdr launchers))) (let ((patt (car hed)) (host-type (cadr hed))) (if (tests:match patt testname itempath) (begin - (debug:print-info 2 "Have flexi-launcher match for " testname "/" itempath " = " host-type) + (debug:print-info 2 #f "Have flexi-launcher match for " testname "/" itempath " = " host-type) (let ((launcher (configf:lookup configdat "host-types" host-type))) (if launcher launcher (begin - (debug:print-info 0 "WARNING: no launcher found for host-type " host-type) + (debug:print-info 0 #f "WARNING: no launcher found for host-type " host-type) (if (null? tal) fallback-launcher (loop (car tal)(cdr tal))))))) ;; no match, try again (if (null? tal) fallback-launcher (loop (car tal)(cdr tal)))))))) fallback-launcher))) Index: common_records.scm ================================================================== --- common_records.scm +++ common_records.scm @@ -81,24 +81,23 @@ (not (getenv "MT_DEBUG_MODE"))) (setenv "MT_DEBUG_MODE" (if (list? *verbosity*) (string-intersperse (map conc *verbosity*) ",") (conc *verbosity*)))))) - -(define (debug:print n . params) +(define (debug:print n e . params) (if (debug:debug-mode n) - (with-output-to-port (current-error-port) + (with-output-to-port (or e (current-error-port)) (lambda () (if *logging* (db:log-event (apply conc params)) ;; (apply print "pid:" (current-process-id) " " params) (apply print params) ))))) -(define (debug:print-info n . params) +(define (debug:print-info n e . params) (if (debug:debug-mode n) - (with-output-to-port (current-error-port) + (with-output-to-port (or e (current-error-port)) (lambda () (if *logging* (let ((res (format#format #f "INFO: (~a) ~a" n (apply conc params)))) (db:log-event res)) ;; (apply print "pid:" (current-process-id) " " "INFO: (" n ") " params) ;; res) Index: configf.scm ================================================================== --- configf.scm +++ configf.scm @@ -45,11 +45,11 @@ (define (config:eval-string-in-environment str) (handle-exceptions exn (begin - (debug:print 0 "ERROR: problem evaluating \"" str "\" in the shell environment") + (debug:print 0 #f "ERROR: problem evaluating \"" str "\" in the shell environment") #f) (let ((cmdres (process:cmd-run->list (conc "echo " str)))) (if (null? cmdres) "" (caar cmdres))))) @@ -98,12 +98,12 @@ (else "(lambda (ht)(print \"ERROR\") \"ERROR\")")))) ;; (print "fullcmd=" fullcmd) (handle-exceptions exn (begin - (debug:print 0 "WARNING: failed to process config input \"" l "\"") - (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) + (debug:print 0 #f "WARNING: failed to process config input \"" l "\"") + (debug:print 0 #f " message: " ((condition-property-accessor 'exn 'message) exn)) ;; (print "exn=" (condition->list exn)) (set! result (conc "#{( " cmdtype ") " cmd"}"))) (if (or allow-system (not (member cmdtype '("system" "shell")))) (with-input-from-string fullcmd @@ -112,12 +112,12 @@ (set! result (conc "#{(" cmdtype ") " cmd "}")))) (case cmdsym ((system shell scheme) (let ((delta (- (current-seconds) start-time))) (if (> delta 2) - (debug:print-info 0 "for line \"" l "\"\n command: " cmd " took " delta " seconds to run with output:\n " result) - (debug:print-info 9 "for line \"" l "\"\n command: " cmd " took " delta " seconds to run with output:\n " result))))) + (debug:print-info 0 #f "for line \"" l "\"\n command: " cmd " took " delta " seconds to run with output:\n " result) + (debug:print-info 9 #f "for line \"" l "\"\n command: " cmd " took " delta " seconds to run with output:\n " result))))) (loop (conc prestr result poststr))) res)) res))) ;; Run a shell command and return the output as a string @@ -127,11 +127,11 @@ (status (cadr output))) (if (equal? status 0) (let ((outres (string-intersperse res "\n"))) - (debug:print-info 4 "shell result:\n" outres) + (debug:print-info 4 #f "shell result:\n" outres) outres) (begin (with-output-to-port (current-error-port) (lambda () (print "ERROR: " cmd " returned bad exit code " status))) @@ -179,15 +179,15 @@ ;; in the environment on the fly ;; sections: #f => get all, else list of sections to gather ;; post-section-procs alist of section-pattern => proc, where: (proc section-name next-section-name ht curr-path) ;; (define (read-config path ht allow-system #!key (environ-patt #f)(curr-section #f)(sections #f)(settings (make-hash-table))(keep-filenames #f)(post-section-procs '())) - (debug:print-info 5 "read-config " path " allow-system " allow-system " environ-patt " environ-patt " curr-section: " curr-section " sections: " sections " pwd: " (current-directory)) - (debug:print 9 "START: " path) + (debug:print-info 5 #f "read-config " path " allow-system " allow-system " environ-patt " environ-patt " curr-section: " curr-section " sections: " sections " pwd: " (current-directory)) + (debug:print 9 #f "START: " path) (if (not (file-exists? path)) (begin - (debug:print-info 1 "read-config - file not found " path " current path: " (current-directory)) + (debug:print-info 1 #f "read-config - file not found " path " current path: " (current-directory)) ;; WARNING: This is a risky change but really, we should not return an empty hash table if no file read? #f) ;; (if (not ht)(make-hash-table) ht)) (let ((inp (open-input-file path)) (res (if (not ht)(make-hash-table) ht)) (metapath (if (or (debug:debug-mode 9) @@ -195,16 +195,16 @@ path #f))) (let loop ((inl (configf:read-line inp res (calc-allow-system allow-system curr-section sections) settings)) ;; (read-line inp)) (curr-section-name (if curr-section curr-section "default")) (var-flag #f);; turn on for key-var-pr and cont-ln-rx, turn off elsewhere (lead #f)) - (debug:print-info 8 "curr-section-name: " curr-section-name " var-flag: " var-flag "\n inl: \"" inl "\"") + (debug:print-info 8 #f "curr-section-name: " curr-section-name " var-flag: " var-flag "\n inl: \"" inl "\"") (if (eof-object? inl) (begin (close-input-port inp) (hash-table-delete! res "") ;; we are using "" as a dumping ground and must remove it before returning the ht - (debug:print 9 "END: " path) + (debug:print 9 #f "END: " path) res) (regex-case inl (configf:comment-rx _ (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f)) (configf:blank-l-rx _ (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f)) @@ -220,17 +220,17 @@ ".") "/" include-file))))) (if (file-exists? full-conf) (begin ;; (push-directory conf-dir) - (debug:print 9 "Including: " full-conf) + (debug:print 9 #f "Including: " full-conf) (read-config full-conf res allow-system environ-patt: environ-patt curr-section: curr-section-name sections: sections settings: settings keep-filenames: keep-filenames) ;; (pop-directory) (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f)) (begin - (debug:print '(2 9) "INFO: include file " include-file " not found (called from " path ")") - (debug:print 2 " " full-conf) + (debug:print '(2 9) #f "INFO: include file " include-file " not found (called from " path ")") + (debug:print 2 #f " " full-conf) (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f))))) (configf:section-rx ( x section-name ) (begin ;; call post-section-procs (for-each (lambda (dat) @@ -251,18 +251,18 @@ (let* ((start-time (current-seconds)) (cmdres (process:cmd-run->list cmd)) (delta (- (current-seconds) start-time)) (status (cadr cmdres)) (res (car cmdres))) - (debug:print-info 4 "" inl "\n => " (string-intersperse res "\n")) + (debug:print-info 4 #f "" inl "\n => " (string-intersperse res "\n")) (if (not (eq? status 0)) (begin - (debug:print 0 "ERROR: problem with " inl ", return code " status + (debug:print 0 #f "ERROR: problem with " inl ", return code " status " output: " cmdres))) (if (> delta 2) - (debug:print-info 0 "for line \"" inl "\"\n command: " cmd " took " delta " seconds to run with output:\n " res) - (debug:print-info 9 "for line \"" inl "\"\n command: " cmd " took " delta " seconds to run with output:\n " res)) + (debug:print-info 0 #f "for line \"" inl "\"\n command: " cmd " took " delta " seconds to run with output:\n " res) + (debug:print-info 9 #f "for line \"" inl "\"\n command: " cmd " took " delta " seconds to run with output:\n " res)) (if (null? res) "" (string-intersperse res " ")))))) (hash-table-set! res curr-section-name (config:assoc-safe-add alist @@ -274,23 +274,23 @@ metadata: metapath)) (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f)) (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f))) (configf:key-no-val ( x key val) (let* ((alist (hash-table-ref/default res curr-section-name '())) (fval (or (if (string? val) val #f) ""))) ;; fval should be either "" or " " (one or more spaces) - (debug:print 10 " setting: [" curr-section-name "] " key " = #t") + (debug:print 10 #f " setting: [" curr-section-name "] " key " = #t") (safe-setenv key fval) (hash-table-set! res curr-section-name (config:assoc-safe-add alist key fval metadata: metapath)) (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name key #f))) (configf:key-val-pr ( x key unk1 val unk2 ) (let* ((alist (hash-table-ref/default res curr-section-name '())) (envar (and environ-patt (string-search (regexp environ-patt) curr-section-name))) (realval (if envar (config:eval-string-in-environment val) val))) - (debug:print-info 6 "read-config env setting, envar: " envar " realval: " realval " val: " val " key: " key " curr-section-name: " curr-section-name) + (debug:print-info 6 #f "read-config env setting, envar: " envar " realval: " realval " val: " val " key: " key " curr-section-name: " curr-section-name) (if envar (safe-setenv key realval)) - (debug:print 10 " setting: [" curr-section-name "] " key " = " val) + (debug:print 10 #f " setting: [" curr-section-name "] " key " = " val) (hash-table-set! res curr-section-name (config:assoc-safe-add alist key realval metadata: metapath)) (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name key #f))) ;; if a continued line (configf:cont-ln-rx ( x whsp val ) (let ((alist (hash-table-ref/default res curr-section-name '()))) @@ -305,11 +305,11 @@ ;; (print "val: " val "\nnewval: \"" newval "\"\nvarflag: " var-flag) (hash-table-set! res curr-section-name (config:assoc-safe-add alist var-flag newval metadata: metapath)) (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name var-flag (if lead lead whsp))) (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f)))) - (else (debug:print 0 "ERROR: problem parsing " path ",\n \"" inl "\"") + (else (debug:print 0 #f "ERROR: problem parsing " path ",\n \"" inl "\"") (set! var-flag #f) (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f)))))))) ;; pathenvvar will set the named var to the path of the config (define (find-and-read-config fname #!key (environ-patt #f)(given-toppath #f)(pathenvvar #f)) @@ -318,11 +318,11 @@ (toppath (car configinfo)) (configfile (cadr configinfo)) (set-fields (lambda (curr-section next-section ht path) (let ((field-names (if ht (keys:config-get-fields ht) '())) (target (or (getenv "MT_TARGET")(args:get-arg "-reqtarg")(args:get-arg "-target")))) - (debug:print-info 9 "set-fields with field-names=" field-names " target=" target " curr-section=" curr-section " next-section=" next-section " path=" path " ht=" ht) + (debug:print-info 9 #f "set-fields with field-names=" field-names " target=" target " curr-section=" curr-section " next-section=" next-section " path=" path " ht=" ht) (if (not (null? field-names))(keys:target-set-args field-names target #f)))))) (if toppath (change-directory toppath)) (if (and toppath pathenvvar)(setenv pathenvvar toppath)) (let ((configdat (if configfile (read-config configfile #f #t environ-patt: environ-patt post-section-procs: (list (cons "^fields$" set-fields)) #f)))) @@ -467,13 +467,13 @@ (set! new #f)) ((not (equal? newval val)) (hash-table-set! sechash key newval) (set! new (conc key " " newval))) (else - (debug:print 0 "ERROR: problem parsing line number " lnum "\"" hed "\""))))) + (debug:print 0 #f "ERROR: problem parsing line number " lnum "\"" hed "\""))))) (else - (debug:print 0 "ERROR: Problem parsing line num " lnum " :\n " hed ))) + (debug:print 0 #f "ERROR: Problem parsing line num " lnum " :\n " hed ))) (if (not (null? tal)) (loop (car tal)(cdr tal)(if new (append res (list new)) res)(+ lnum 1))) ;; drop to here when done processing, res contains modified list of lines (set! fdat res))) Index: dashboard-tests.scm ================================================================== --- dashboard-tests.scm +++ dashboard-tests.scm @@ -235,11 +235,11 @@ ;; if there is a submegatest create a button to launch dashboard in that area ;; (define (submegatest-panel dbstruct keydat testdat runname testconfig) (let* ((subarea (configf:lookup testconfig "setup" "submegatest")) (area-exists (and subarea (file-exists? subarea)))) - ;; (debug:print-info 0 "Megatest subarea=" subarea ", area-exists=" area-exists) + ;; (debug:print-info 0 #f "Megatest subarea=" subarea ", area-exists=" area-exists) (if subarea (iup:frame #:title "Megatest Run Info" ; #:expand "YES" (iup:button "Launch Dashboard" @@ -424,11 +424,11 @@ (db-mod-time 0) ;; (file-modification-time db-path)) (last-update 0) ;; (current-seconds)) (request-update #t)) (if (not testdat) (begin - (debug:print 2 "ERROR: No test data found for test " test-id ", exiting") + (debug:print 2 #f "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)) @@ -511,22 +511,22 @@ request-update)) (newtestdat (if need-update ;; NOTE: BUG HIDER, try to eliminate this exception handler (handle-exceptions exn - (debug:print-info 0 "test db access issue in examine test for run-id " run-id ", test-id " test-id ": " ((condition-property-accessor 'exn 'message) exn)) + (debug:print-info 0 #f "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 ))))) - ;; (debug:print-info 0 "need-update= " need-update " curr-mod-time = " curr-mod-time) + ;; (debug:print-info 0 #f "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! 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 "INFO: teststeps=" (intersperse teststeps "\n ")) + ;; (debug:print 0 #f "INFO: teststeps=" (intersperse teststeps "\n ")) ;; I don't see why this was implemented this way. Please comment it ... ;; (if (eq? curr-mod-time db-mod-time) ;; do only once if same ;; (set! db-mod-time (+ curr-mod-time 1)) ;; (set! db-mod-time curr-mod-time)) @@ -579,11 +579,11 @@ (command-proc (lambda (command-text-box) (let* ((cmd (iup:attribute command-text-box "VALUE")) (fullcmd (conc (dtests:get-pre-command) cmd (dtests:get-post-command)))) - (debug:print-info 02 "Running command: " fullcmd) + (debug:print-info 02 #f "Running command: " fullcmd) (common:without-vars fullcmd "MT_.*")))) (command-text-box (iup:textbox #:expand "HORIZONTAL" #:font "Courier New, -10" #:action (lambda (obj cnum val) @@ -596,11 +596,11 @@ ;; (lambda (x) ;; (let* ((cmd (iup:attribute command-text-box "VALUE")) ;; (fullcmd (conc (dtests:get-pre-command) ;; cmd ;; (dtests:get-post-command)))) - ;; (debug:print-info 02 "Running command: " fullcmd) + ;; (debug:print-info 02 #f "Running command: " fullcmd) ;; (common:without-vars fullcmd "MT_.*"))))) (kill-jobs (lambda (x) (iup:attribute-set! command-text-box "VALUE" (conc "megatest -target " keystring " -runname " runname Index: dashboard.scm ================================================================== --- dashboard.scm +++ dashboard.scm @@ -374,11 +374,11 @@ (eq? (db:test-get-id a)(db:test-get-id b))))))) (if (eq? *tests-sort-reverse* 3) ;; +event_time (sort newdat dboard:compare-tests) newdat)))) (vector-set! prev-dat 3 (- (current-seconds) 2)) ;; go back two seconds in time to ensure all changes are captured. - ;; (debug:print 0 "(dboard:get-tests-for-run-duplicate: filters-changed=" (d:alldat-filters-changed data) " last-update=" last-update " got " (length tmptests) " test records for run " run-id) + ;; (debug:print 0 #f "(dboard:get-tests-for-run-duplicate: filters-changed=" (d:alldat-filters-changed data) " last-update=" last-update " got " (length tmptests) " test records for run " run-id) tests)) ;; create a virtual table of all the tests ;; keypatts: ( (KEY1 "abc%def")(KEY2 "%") ) (define (update-rundat data runnamepatt numruns testnamepatt keypatts) @@ -388,12 +388,11 @@ (db:get-runs (d:alldat-dblocal data) runnamepatt numruns ;; (+ numruns 1) ;; (/ numruns 2)) (d:alldat-start-run-offset data) keypatts))) (header (db:get-header allruns)) (runs (db:get-rows allruns)) (result '()) - (maxtests 0) -) + (maxtests 0)) ;; ;; trim runs to only those that are changing often here ;; (for-each (lambda (run) (let* ((run-id (db:get-value-by-header run header "id")) @@ -402,11 +401,11 @@ (db:get-key-vals (d:alldat-dblocal data) run-id))) (tests (dboard:get-tests-for-run-duplicate data run-id run testnamepatt key-vals))) ;; NOTE: bubble-up also sets the global (d:alldat-item-test-names data) ;; (tests (bubble-up tmptests priority: bubble-type)) ;; NOTE: 11/01/2013 This routine is *NOT* getting called excessively. - ;; (debug:print 0 "Getting data for run " run-id " with key-vals=" key-vals) + ;; (debug:print 0 #f "Getting data for run " run-id " with key-vals=" key-vals) ;; Not sure this is needed? (if (not (null? tests)) (begin (set! referenced-run-ids (cons run-id referenced-run-ids)) (if (> (length tests) maxtests) @@ -418,11 +417,11 @@ (set! result (cons dstruct result)))))))) runs) (d:alldat-header-set! data header) (d:alldat-allruns-set! data result) - (debug:print-info 6 "(d:alldat-allruns data) has " (length (d:alldat-allruns data)) " runs") + (debug:print-info 6 #f "(d:alldat-allruns data) has " (length (d:alldat-allruns data)) " runs") maxtests)) (define *collapsed* (make-hash-table)) ; (define *row-lookup* (make-hash-table)) ;; testname => (rownum lableobj) @@ -1228,11 +1227,11 @@ (if (d:alldat-filters-changed data) 0 last-update) *dashboard-mode*)) '()))) ;; get 'em all - (debug:print 0 "dboard:get-tests-dat: got " (length tdat) " test records for run " run-id) + (debug:print 0 #f "dboard:get-tests-dat: got " (length tdat) " test records for run " run-id) (sort tdat (lambda (a b) (let* ((aval (vector-ref a 2)) (bval (vector-ref b 2)) (anum (string->number aval)) (bnum (string->number bval))) @@ -1255,11 +1254,11 @@ (run-id (tree-path->run-id ddata (cdr run-path)))) (if (number? run-id) (begin (d:data-curr-run-id-set! ddata run-id) (dashboard:update-run-summary-tab)) - (debug:print 0 "ERROR: tree-path->run-id returned non-number " run-id))) + (debug:print 0 #f "ERROR: tree-path->run-id returned non-number " run-id))) ;; (print "path: " (tree:node->path obj id) " run-id: " run-id) ))) (cell-lookup (make-hash-table)) (run-matrix (iup:matrix #:expand "YES" @@ -1402,11 +1401,11 @@ (run-id (tree-path->run-id ddata (cdr run-path)))) (if (number? run-id) (begin (d:data-curr-run-id-set! ddata run-id) (dashboard:update-new-view-tab)) - (debug:print 0 "ERROR: tree-path->run-id returned non-number " run-id))) + (debug:print 0 #f "ERROR: tree-path->run-id returned non-number " run-id))) ;; (print "path: " (tree:node->path obj id) " run-id: " run-id) ))) (cell-lookup (make-hash-table)) (run-matrix (iup:matrix #:expand "YES" @@ -1604,11 +1603,11 @@ (iup:attribute-set! show "BGCOLOR" nonsel-color) (mark-for-update)))) (set! show (iup:button "Show" #:expand "YES" #:action (lambda (obj) - (d:alldat-hide-not-hide-set! data (not (d:alldat-hide-not-hide data))) + (d:alldat-hide-not-hide-set! data #f) ;; (not (d:alldat-hide-not-hide data))) (iup:attribute-set! show "BGCOLOR" sel-color) (iup:attribute-set! hide "BGCOLOR" nonsel-color) (mark-for-update)))) (iup:attribute-set! hide "BGCOLOR" sel-color) (iup:attribute-set! show "BGCOLOR" nonsel-color) @@ -1646,11 +1645,11 @@ (let ((val (inexact->exact (round (/ (string->number (iup:attribute obj "VALUE")) 10)))) (oldmax (string->number (iup:attribute obj "MAX"))) (maxruns (d:alldat-tot-runs data))) (d:alldat-start-run-offset-set! data val) (mark-for-update) - (debug:print 6 "(d:alldat-start-run-offset data) " (d:alldat-start-run-offset data) " maxruns: " maxruns ", val: " val " oldmax: " oldmax) + (debug:print 6 #f "(d:alldat-start-run-offset data) " (d:alldat-start-run-offset data) " maxruns: " maxruns ", val: " val " oldmax: " oldmax) (iup:attribute-set! obj "MAX" (* maxruns 10)))) #:expand "HORIZONTAL" #:max (* 10 (length (d:alldat-allruns data))) #:min 0 #:step 0.01))) @@ -1698,11 +1697,11 @@ (let ((val (string->number (iup:attribute obj "VALUE"))) (oldmax (string->number (iup:attribute obj "MAX"))) (newmax (* 10 (length *alltestnamelst*)))) (d:alldat-please-update-set! data #t) (d:alldat-start-test-offset-set! *alldat* (inexact->exact (round (/ val 10)))) - (debug:print 6 "(d:alldat-start-test-offset *alldat*) " (d:alldat-start-test-offset *alldat*) " val: " val " newmax: " newmax " oldmax: " oldmax) + (debug:print 6 #f "(d:alldat-start-test-offset *alldat*) " (d:alldat-start-test-offset *alldat*) " val: " val " newmax: " newmax " oldmax: " oldmax) (if (< val 10) (iup:attribute-set! obj "MAX" newmax)) )) #:expand "VERTICAL" #:orientation "VERTICAL" @@ -1845,11 +1844,11 @@ (define (dashboard:get-youngest-run-db-mod-time) (handle-exceptions exn (begin - (debug:print 0 "WARNING: error in accessing databases in get-youngest-run-db-mod-time: " ((condition-property-accessor 'exn 'message) exn)) + (debug:print 0 #f "WARNING: error in accessing databases in get-youngest-run-db-mod-time: " ((condition-property-accessor 'exn 'message) exn)) (current-seconds)) ;; something went wrong - just print an error and return current-seconds (apply max (map (lambda (filen) (file-modification-time filen)) (glob (conc (d:alldat-dbdir *alldat*) "/*.db")))))) @@ -1930,11 +1929,11 @@ (if (and (number? run-id) (number? test-id) (>= test-id 0)) (examine-test run-id test-id) (begin - (debug:print 3 "INFO: tried to open test with invalid run-id,test-id. " (args:get-arg "-test")) + (debug:print 3 #f "INFO: tried to open test with invalid run-id,test-id. " (args:get-arg "-test")) (exit 1))))) ((args:get-arg "-guimonitor") (gui-monitor (d:alldat-dblocal data))) (else (set! uidat (make-dashboard-buttons data ;; (d:alldat-dblocal data) Index: datashare.scm ================================================================== --- datashare.scm +++ datashare.scm @@ -231,11 +231,11 @@ (dbexists (file-exists? dbpath)) (handler (make-busy-timeout 136000))) (handle-exceptions exn (begin - (debug:print 2 "ERROR: problem accessing db " dbpath + (debug:print 2 #f "ERROR: problem accessing db " dbpath ((condition-property-accessor 'exn 'message) exn)) (exit)) (set! db (sqlite3:open-database dbpath))) (if *db-write-access* (sqlite3:set-busy-handler! db handler)) (if (not dbexists) Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -40,11 +40,11 @@ (define (db:general-sqlite-error-dump exn stmt run-id params) (let ((err-status ((condition-property-accessor 'sqlite3 'status #f) exn))) ;; check for (exn sqlite3) ((condition-property-accessor 'exn 'message) exn) (print "err-status: " err-status) - (debug:print 0 "ERROR: query " stmt " failed, params: " params ", error: " ((condition-property-accessor 'exn 'message) exn)) + (debug:print 0 #f "ERROR: query " stmt " failed, params: " params ", error: " ((condition-property-accessor 'exn 'message) exn)) (print-call-chain (current-error-port)))) ;; convert to -inline (define (db:first-result-default db stmt default . params) (handle-exceptions @@ -52,11 +52,11 @@ (let ((err-status ((condition-property-accessor 'sqlite3 'status #f) exn))) ;; check for (exn sqlite3) ((condition-property-accessor 'exn 'message) exn) (if (eq? err-status 'done) default (begin - (debug:print 0 "ERROR: query " stmt " failed, params: " params ", error: " ((condition-property-accessor 'exn 'message) exn)) + (debug:print 0 #f "ERROR: query " stmt " failed, params: " params ", error: " ((condition-property-accessor 'exn 'message) exn)) (print-call-chain (current-error-port)) default))) (apply sqlite3:first-result db stmt params))) ;; Get/open a database @@ -111,11 +111,11 @@ (db (db:dbdat-get-db dbdat))) (db:delay-if-busy dbdat) (handle-exceptions exn (begin - (debug:print 0 "ERROR: sqlite3 issue in db:with-db, dbstruct=" dbstruct ", run-id=" run-id ", proc=" proc ", params=" params " error: " ((condition-property-accessor 'exn 'message) exn)) + (debug:print 0 #f "ERROR: sqlite3 issue in db:with-db, dbstruct=" dbstruct ", run-id=" run-id ", proc=" proc ", params=" params " error: " ((condition-property-accessor 'exn 'message) exn)) (print-call-chain (current-error-port))) (let ((res (apply proc db params))) (if (vector? dbstruct)(db:done-with dbstruct run-id r/w)) res)))) @@ -152,11 +152,11 @@ (if (eq? run-id 0) "main.db" (conc run-id ".db")) #f))) (handle-exceptions exn (begin - (debug:print 0 "ERROR: Couldn't create path to " dbdir) + (debug:print 0 #f "ERROR: Couldn't create path to " dbdir) (exit 1)) (if (not (directory? dbdir))(create-directory dbdir #t))) (if fname (conc dbdir "/" fname) dbdir))) @@ -192,11 +192,11 @@ (db:set-sync db) ;; (sqlite3:execute db "PRAGMA synchronous = 0;") (if (not file-exists)(initproc db)) ;; (release-dot-lock fname) db) (begin - (debug:print 2 "WARNING: opening db in non-writable dir " fname) + (debug:print 2 #f "WARNING: opening db in non-writable dir " fname) (sqlite3:open-database fname))))) ;; ) ;; This routine creates the db. It is only called if the db is not already opened ;; (define (db:open-rundb dbstruct run-id #!key (attemptnum 0)(do-not-open #f)) ;; (conc *toppath* "/megatest.db") (car *configinfo*))) @@ -218,11 +218,11 @@ (handle-exceptions exn (begin ;; (release-dot-lock dbpath) (if (> attemptnum 2) - (debug:print 0 "ERROR: tried twice, cannot create/initialize db for run-id " run-id ", at path " dbpath) + (debug:print 0 #f "ERROR: tried twice, cannot create/initialize db for run-id " run-id ", at path " dbpath) (db:open-rundb dbstruct run-id attemptnum (+ attemptnum 1)))) (db:initialize-run-id-db db) (sqlite3:execute db "INSERT OR IGNORE INTO tests (id,run_id,testname,event_time,item_path,state,status) VALUES (?,?,'bogustest',strftime('%s','now'),'nowherepath','DELETED','n/a');" @@ -319,11 +319,11 @@ (maindb (dbr:dbstruct-get-main dbstruct)) (refdb (dbr:dbstruct-get-refdb dbstruct)) (olddb (dbr:dbstruct-get-olddb dbstruct)) ;; (runid (dbr:dbstruct-get-run-id dbstruct)) ) - (debug:print-info 4 "Syncing for run-id: " run-id) + (debug:print-info 4 #f "Syncing for run-id: " run-id) ;; (mutex-lock! *http-mutex*) (if (eq? run-id 0) ;; runid equal to 0 is main.db (if maindb (if (or (not (number? mtime)) @@ -339,11 +339,11 @@ 0)) (begin ;; this can occur when using local access (i.e. not in a server) ;; need a flag to turn it off. ;; - (debug:print 3 "WARNING: call to sync main.db to megatest.db but main not initialized") + (debug:print 3 #f "WARNING: call to sync main.db to megatest.db but main not initialized") 0)) ;; any other runid is a run (if (or (not (number? mtime)) (not (number? stime)) (> mtime stime) @@ -481,16 +481,16 @@ (dbdir (pathname-directory dbpath)) (fname (pathname-strip-directory dbpath)) (fnamejnl (conc fname "-journal")) (tmpname (conc fname "." (current-process-id))) (tmpjnl (conc fnamejnl "." (current-process-id)))) - (debug:print 0 "ERROR: " fname " appears corrupted. Making backup \"old/" fname "\"") + (debug:print 0 #f "ERROR: " fname " appears corrupted. Making backup \"old/" fname "\"") (system (conc "cd " dbdir ";mkdir -p old;cat " fname " > old/" tmpname)) (system (conc "rm -f " dbpath)) (if (file-exists? fnamejnl) (begin - (debug:print 0 "ERROR: " fnamejnl " found, moving it to old dir as " tmpjnl) + (debug:print 0 #f "ERROR: " fnamejnl " found, moving it to old dir as " tmpjnl) (system (conc "cd " dbdir ";mkdir -p old;cat " fnamejnl " > old/" tmpjnl)) (system (conc "rm -f " dbdir "/" fnamejnl)))) ;; attempt to recreate database (system (conc "cd " dbdir ";sqlite3 old/" tmpname " .dump | sqlite3 " fname)))) @@ -499,14 +499,14 @@ ;; (define (db:repair-db dbdat #!key (numtries 1)) (let* ((dbpath (db:dbdat-get-path dbdat)) (dbdir (pathname-directory dbpath)) (fname (pathname-strip-directory dbpath))) - (debug:print-info 0 "Checking db " dbpath " for errors.") + (debug:print-info 0 #f "Checking db " dbpath " for errors.") (cond ((not (file-write-access? dbdir)) - (debug:print 0 "WARNING: can't write to " dbdir ", can't fix " fname) + (debug:print 0 #f "WARNING: can't write to " dbdir ", can't fix " fname) #f) ;; handle special cases, megatest.db and monitor.db ;; ;; NOPE: apply this same approach to all db files @@ -517,12 +517,12 @@ (begin ;; (db:move-and-recreate-db dbdat) (if (> numtries 0) (db:repair-db dbdat numtries: (- numtries 1)) #f) - (debug:print 0 "FATAL: file " dbpath " was found corrupted, an attempt to fix has been made but you must start over.") - (debug:print 0 + (debug:print 0 #f "FATAL: file " dbpath " was found corrupted, an attempt to fix has been made but you must start over.") + (debug:print 0 #f " check the following:\n" " 1. full directories, look in ~/ /tmp and " dbdir "\n" " 2. write access to " dbdir "\n\n" " if the automatic recovery failed you may be able to recover data by doing \"" (if (member fname '("megatest.db" "monitor.db")) @@ -555,22 +555,22 @@ (mutex-lock! *db-sync-mutex*) (handle-exceptions exn (begin (mutex-unlock! *db-sync-mutex*) - (debug:print 0 "EXCEPTION: database probably overloaded or unreadable in db:sync-tables.") + (debug:print 0 #f "EXCEPTION: database probably overloaded or unreadable in db:sync-tables.") (print-call-chain (current-error-port)) - (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) + (debug:print 0 #f " message: " ((condition-property-accessor 'exn 'message) exn)) (print "exn=" (condition->list exn)) - (debug:print 0 " status: " ((condition-property-accessor 'sqlite3 'status) exn)) - (debug:print 0 " src db: " (db:dbdat-get-path fromdb)) + (debug:print 0 #f " status: " ((condition-property-accessor 'sqlite3 'status) exn)) + (debug:print 0 #f " src db: " (db:dbdat-get-path fromdb)) (for-each (lambda (dbdat) (let ((dbpath (db:dbdat-get-path dbdat))) - (debug:print 0 " dbpath: " dbpath) + (debug:print 0 #f " dbpath: " dbpath) (if (not (db:repair-db dbdat)) (begin - (debug:print 0 "ERROR: Failed to rebuild " dbpath ", exiting now.") + (debug:print 0 #f "ERROR: Failed to rebuild " dbpath ", exiting now.") (exit))))) (cons todb slave-dbs)) 0) ;; (if *server-run* ;; we are inside a server, throw a sync-failed error @@ -581,16 +581,16 @@ ;; (set! *time-to-exit* #t) ;; let watch dog know that it is time to die. ;; (tasks:server-set-state! (db:delay-if-busy tdbdat) server-id "shutting-down") ;; (portlogger:open-run-close portlogger:set-port port "released") ;; (exit 1))) (cond - ((not fromdb) (debug:print 3 "WARNING: db:sync-tables called with fromdb missing") -1) - ((not todb) (debug:print 3 "WARNING: db:sync-tables called with todb missing") -2) + ((not fromdb) (debug:print 3 #f "WARNING: db:sync-tables called with fromdb missing") -1) + ((not todb) (debug:print 3 #f "WARNING: db:sync-tables called with todb missing") -2) ((not (sqlite3:database? (db:dbdat-get-db fromdb))) - (debug:print 0 "ERROR: db:sync-tables called with fromdb not a database " fromdb) -3) + (debug:print 0 #f "ERROR: db:sync-tables called with fromdb not a database " fromdb) -3) ((not (sqlite3:database? (db:dbdat-get-db todb))) - (debug:print 0 "ERROR: db:sync-tables called with todb not a database " todb) -4) + (debug:print 0 #f "ERROR: db:sync-tables called with todb not a database " todb) -4) (else (let ((stmts (make-hash-table)) ;; table-field => stmt (all-stmts '()) ;; ( ( stmt1 value1 ) ( stml2 value2 )) (numrecs (make-hash-table)) (start-time (current-milliseconds)) @@ -635,11 +635,11 @@ ;; tack on remaining records in fromdat (if (not (null? fromdat)) (set! fromdats (cons fromdat fromdats))) (if (common:low-noise-print 120 "sync-records") - (debug:print-info 4 "found " totrecords " records to sync")) + (debug:print-info 4 #f "found " totrecords " records to sync")) ;; read the target table (sqlite3:for-each-row (lambda (a . b) (hash-table-set! todat a (apply vector a b))) @@ -679,18 +679,18 @@ (sqlite3:finalize! stmth))) (append (list todb) slave-dbs)))) tbls) (let* ((runtime (- (current-milliseconds) start-time)) (should-print (common:low-noise-print 120 "db sync" (> runtime 500)))) ;; low and high sync times treated as separate. - (if should-print (debug:print 3 "INFO: db sync, total run time " runtime " ms")) + (if should-print (debug:print 3 #f "INFO: db sync, total run time " runtime " ms")) (for-each (lambda (dat) (let ((tblname (car dat)) (count (cdr dat))) (set! tot-count (+ tot-count count)) (if (> count 0) - (if should-print (debug:print 0 (format #f " ~10a ~5a" tblname count)))))) + (if should-print (debug:print 0 #f (format #f " ~10a ~5a" tblname count)))))) (sort (hash-table->alist numrecs)(lambda (a b)(> (cdr a)(cdr b)))))) tot-count))) (mutex-unlock! *db-sync-mutex*))) ;; options: @@ -747,11 +747,11 @@ (for-each (lambda (run-id) (db:delay-if-busy mtdb) (let ((testrecs (db:get-all-tests-info-by-run-id mtdb run-id)) (dbstruct (if toppath (make-dbr:dbstruct path: toppath local: #t) #f))) - (debug:print 0 "INFO: Propagating " (length testrecs) " records for run-id=" run-id " to run specific db") + (debug:print 0 #f "INFO: Propagating " (length testrecs) " records for run-id=" run-id " to run specific db") (db:replace-test-records dbstruct run-id testrecs) (sqlite3:finalize! (db:dbdat-get-db (dbr:dbstruct-get-rundb dbstruct))))) run-ids))) ;; now ensure all newdb data are synced to megatest.db @@ -764,11 +764,11 @@ (count 1) (total (length all-run-ids)) (dead-runs '())) (for-each (lambda (run-id) - (debug:print 0 "Processing run " (if (eq? run-id 0) " main.db " run-id) ", " count " of " total) + (debug:print 0 #f "Processing run " (if (eq? run-id 0) " main.db " run-id) ", " count " of " total) (set! count (+ count 1)) (let* ((fromdb (if toppath (make-dbr:dbstruct path: toppath local: #t) #f)) (frundb (db:dbdat-get-db (db:get-db fromdb run-id)))) ;; (db:delay-if-busy frundb) ;; (db:delay-if-busy mtdb) @@ -783,11 +783,11 @@ ;; remove all these some time after september 2016 (added in v1.6031 ;; (handle-exceptions exn (if (string-match ".*duplicate.*" ((condition-property-accessor 'exn 'message) exn)) - (debug:print 0 "Column last_update already added to runs table") + (debug:print 0 #f "Column last_update already added to runs table") (db:general-sqlite-error-dump exn "alter table runs ..." run-id "none")) (sqlite3:execute maindb "ALTER TABLE runs ADD COLUMN last_update INTEGER DEFAULT 0")) ;; these schema changes don't need exception handling @@ -825,11 +825,11 @@ (for-each (lambda (table-name) (handle-exceptions exn (if (string-match ".*duplicate.*" ((condition-property-accessor 'exn 'message) exn)) - (debug:print 0 "Column last_update already added to " table-name " table") + (debug:print 0 #f "Column last_update already added to " table-name " table") (db:general-sqlite-error-dump exn "alter table " table-name " ..." #f "none")) (sqlite3:execute frundb (conc "ALTER TABLE " table-name " ADD COLUMN last_update INTEGER DEFAULT 0"))) (sqlite3:execute @@ -850,33 +850,33 @@ (let ((dbdir (tasks:get-task-db-path))) (for-each (lambda (run-id) (let ((fullname (conc dbdir "/" run-id ".db"))) (if (file-exists? fullname) (begin - (debug:print 0 "Removing database file for deleted run " fullname) + (debug:print 0 #f "Removing database file for deleted run " fullname) (delete-file fullname))))) dead-runs)))) ;; (db:close-all dbstruct) ;; (sqlite3:finalize! mdb) )) ;; keeping it around for debugging purposes only (define (open-run-close-no-exception-handling proc idb . params) - (debug:print-info 11 "open-run-close-no-exception-handling START given a db=" (if idb "yes " "no ") ", params=" params) + (debug:print-info 11 #f "open-run-close-no-exception-handling START given a db=" (if idb "yes " "no ") ", params=" params) (if (or *db-write-access* (not (member proc *db:all-write-procs*))) (let* ((db (cond ((pair? idb) (db:dbdat-get-db idb)) ((sqlite3:database? idb) idb) - ((not idb) (debug:print 0 "ERROR: cannot open-run-close with #f anymore")) + ((not idb) (debug:print 0 #f "ERROR: cannot open-run-close with #f anymore")) ((procedure? idb) (idb)) - (else (debug:print 0 "ERROR: cannot open-run-close with #f anymore")))) + (else (debug:print 0 #f "ERROR: cannot open-run-close with #f anymore")))) (res #f)) (set! res (apply proc db params)) (if (not idb)(sqlite3:finalize! dbstruct)) - (debug:print-info 11 "open-run-close-no-exception-handling END" ) + (debug:print-info 11 #f "open-run-close-no-exception-handling END" ) res) #f)) (define (open-run-close-exception-handling proc idb . params) (handle-exceptions @@ -885,17 +885,17 @@ (err-status ((condition-property-accessor 'sqlite3 'status #f) exn))) (case err-status ((busy) (thread-sleep! sleep-time)) (else - (debug:print 0 "EXCEPTION: database probably overloaded or unreadable.") - (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) + (debug:print 0 #f "EXCEPTION: database probably overloaded or unreadable.") + (debug:print 0 #f " message: " ((condition-property-accessor 'exn 'message) exn)) (print "exn=" (condition->list exn)) - (debug:print 0 " status: " ((condition-property-accessor 'sqlite3 'status) exn)) + (debug:print 0 #f " status: " ((condition-property-accessor 'sqlite3 'status) exn)) (print-call-chain (current-error-port)) (thread-sleep! sleep-time) - (debug:print-info 0 "trying db call one more time....this may never recover, if necessary kill process " (current-process-id) " on host " (get-host-name) " to clean up"))) + (debug:print-info 0 #f "trying db call one more time....this may never recover, if necessary kill process " (current-process-id) " on host " (get-host-name) " to clean up"))) (apply open-run-close-exception-handling proc idb params)) (apply open-run-close-no-exception-handling proc idb params))) ;; (define open-run-close (define open-run-close open-run-close-exception-handling) @@ -1016,11 +1016,11 @@ CONSTRAINT metadat_constraint UNIQUE (var));") (sqlite3:execute db "CREATE TABLE IF NOT EXISTS access_log (id INTEGER PRIMARY KEY, user TEXT, accessed TIMESTAMP, args TEXT);") ;; Must do this *after* running patch db !! No more. ;; cannot use db:set-var since it will deadlock, hardwire the code here (sqlite3:execute db "INSERT OR REPLACE INTO metadat (var,val) VALUES (?,?);" "MEGATEST_VERSION" (common:version-signature)) - (debug:print-info 11 "db:initialize END"))))) + (debug:print-info 11 #f "db:initialize END"))))) ;;====================================================================== ;; R U N S P E C I F I C D B ;;====================================================================== @@ -1308,11 +1308,11 @@ (if (and (equal? uname "n/a") (equal? item-path "")) ;; this is a toplevel test ;; what to do with toplevel? call rollup? (begin (set! toplevels (cons (list test-id run-dir uname testname item-path run-id) toplevels)) - (debug:print-info 0 "Found old toplevel test in RUNNING state, test-id=" test-id)) + (debug:print-info 0 #f "Found old toplevel test in RUNNING state, test-id=" test-id)) (set! incompleted (cons (list test-id run-dir uname testname item-path run-id) incompleted)))) db "SELECT id,rundir,uname,testname,item_path FROM tests WHERE run_id=? AND (strftime('%s','now') - event_time) > (run_duration + ?) AND state IN ('RUNNING','REMOTEHOSTSTART');" run-id deadtime) @@ -1328,11 +1328,11 @@ (set! oldlaunched (cons (list test-id run-dir uname testname item-path run-id) oldlaunched)))) db "SELECT id,rundir,uname,testname,item_path FROM tests WHERE run_id=? AND (strftime('%s','now') - event_time) > 86400 AND state IN ('LAUNCHED');" run-id) - (debug:print-info 18 "Found " (length oldlaunched) " old LAUNCHED items, " (length toplevels) " old LAUNCHED toplevel tests and " (length incompleted) " tests marked RUNNING but apparently dead.") + (debug:print-info 18 #f "Found " (length oldlaunched) " old LAUNCHED items, " (length toplevels) " old LAUNCHED toplevel tests and " (length incompleted) " tests marked RUNNING but apparently dead.") (if (and (null? incompleted) (null? oldlaunched) (null? toplevels)) #f #t))) @@ -1367,11 +1367,11 @@ (if (and (equal? uname "n/a") (equal? item-path "")) ;; this is a toplevel test ;; what to do with toplevel? call rollup? (begin (set! toplevels (cons (list test-id run-dir uname testname item-path run-id) toplevels)) - (debug:print-info 0 "Found old toplevel test in RUNNING state, test-id=" test-id)) + (debug:print-info 0 #f "Found old toplevel test in RUNNING state, test-id=" test-id)) (set! incompleted (cons (list test-id run-dir uname testname item-path run-id) incompleted)))) db "SELECT id,rundir,uname,testname,item_path FROM tests WHERE run_id=? AND (strftime('%s','now') - event_time) > (run_duration + ?) AND state IN ('RUNNING','REMOTEHOSTSTART');" run-id deadtime) @@ -1387,11 +1387,11 @@ (set! oldlaunched (cons (list test-id run-dir uname testname item-path run-id) oldlaunched)))) db "SELECT id,rundir,uname,testname,item_path FROM tests WHERE run_id=? AND (strftime('%s','now') - event_time) > 86400 AND state IN ('LAUNCHED');" run-id) - (debug:print-info 18 "Found " (length oldlaunched) " old LAUNCHED items, " (length toplevels) " old LAUNCHED toplevel tests and " (length incompleted) " tests marked RUNNING but apparently dead.") + (debug:print-info 18 #f "Found " (length oldlaunched) " old LAUNCHED items, " (length toplevels) " old LAUNCHED toplevel tests and " (length incompleted) " tests marked RUNNING but apparently dead.") ;; These are defunct tests, do not do all the overhead of set-state-status. Force them to INCOMPLETE. ;; (db:delay-if-busy dbdat) (let* (;; (min-incompleted (filter (lambda (x) @@ -1403,11 +1403,11 @@ ;; incompleted)) (min-incompleted-ids (map car incompleted)) ;; do 'em all (all-ids (append min-incompleted-ids (map car oldlaunched)))) (if (> (length all-ids) 0) (begin - (debug:print 0 "WARNING: Marking test(s); " (string-intersperse (map conc all-ids) ", ") " as INCOMPLETE") + (debug:print 0 #f "WARNING: Marking test(s); " (string-intersperse (map conc all-ids) ", ") " as INCOMPLETE") (sqlite3:execute db (conc "UPDATE tests SET state='INCOMPLETE' WHERE id IN (" (string-intersperse (map conc all-ids) ",") ");"))))) @@ -1436,11 +1436,11 @@ ;; 2. Look at run records ;; a. If have tests that are not deleted, set state='unknown' ;; b. .... ;; (define (db:clean-up dbdat) - ;; (debug:print 0 "WARNING: db clean up not fully ported to v1.60, cleanup action will be on megatest.db") + ;; (debug:print 0 #f "WARNING: db clean up not fully ported to v1.60, cleanup action will be on megatest.db") (let* ((db (db:dbdat-get-db dbdat)) (count-stmt (sqlite3:prepare db "SELECT (SELECT count(id) FROM tests)+(SELECT count(id) FROM runs);")) (statements (map (lambda (stmt) (sqlite3:prepare db stmt)) @@ -1459,15 +1459,15 @@ (db:delay-if-busy dbdat) (sqlite3:with-transaction db (lambda () (sqlite3:for-each-row (lambda (tot) - (debug:print-info 0 "Records count before clean: " tot)) + (debug:print-info 0 #f "Records count before clean: " tot)) count-stmt) (map sqlite3:execute statements) (sqlite3:for-each-row (lambda (tot) - (debug:print-info 0 "Records count after clean: " tot)) + (debug:print-info 0 #f "Records count after clean: " tot)) count-stmt))) (map sqlite3:finalize! statements) (sqlite3:finalize! count-stmt) ;; (db:find-and-mark-incomplete db) (db:delay-if-busy dbdat) @@ -1483,11 +1483,11 @@ ;; 2. Look at run records ;; a. If have tests that are not deleted, set state='unknown' ;; b. .... ;; (define (db:clean-up-rundb dbdat) - ;; (debug:print 0 "WARNING: db clean up not fully ported to v1.60, cleanup action will be on megatest.db") + ;; (debug:print 0 #f "WARNING: db clean up not fully ported to v1.60, cleanup action will be on megatest.db") (let* ((db (db:dbdat-get-db dbdat)) (count-stmt (sqlite3:prepare db "SELECT (SELECT count(id) FROM tests);")) (statements (map (lambda (stmt) (sqlite3:prepare db stmt)) @@ -1500,15 +1500,15 @@ (db:delay-if-busy dbdat) (sqlite3:with-transaction db (lambda () (sqlite3:for-each-row (lambda (tot) - (debug:print-info 0 "Records count before clean: " tot)) + (debug:print-info 0 #f "Records count before clean: " tot)) count-stmt) (map sqlite3:execute statements) (sqlite3:for-each-row (lambda (tot) - (debug:print-info 0 "Records count after clean: " tot)) + (debug:print-info 0 #f "Records count after clean: " tot)) count-stmt))) (map sqlite3:finalize! statements) (sqlite3:finalize! count-stmt) ;; (db:find-and-mark-incomplete db) (db:delay-if-busy dbdat) @@ -1524,11 +1524,11 @@ ;; 2. Look at run records ;; a. If have tests that are not deleted, set state='unknown' ;; b. .... ;; (define (db:clean-up-maindb dbdat) - ;; (debug:print 0 "WARNING: db clean up not fully ported to v1.60, cleanup action will be on megatest.db") + ;; (debug:print 0 #f "WARNING: db clean up not fully ported to v1.60, cleanup action will be on megatest.db") (let* ((db (db:dbdat-get-db dbdat)) (count-stmt (sqlite3:prepare db "SELECT (SELECT count(id) FROM runs);")) (statements (map (lambda (stmt) (sqlite3:prepare db stmt)) @@ -1547,15 +1547,15 @@ (db:delay-if-busy dbdat) (sqlite3:with-transaction db (lambda () (sqlite3:for-each-row (lambda (tot) - (debug:print-info 0 "Records count before clean: " tot)) + (debug:print-info 0 #f "Records count before clean: " tot)) count-stmt) (map sqlite3:execute statements) (sqlite3:for-each-row (lambda (tot) - (debug:print-info 0 "Records count after clean: " tot)) + (debug:print-info 0 #f "Records count after clean: " tot)) count-stmt))) (map sqlite3:finalize! statements) (sqlite3:finalize! count-stmt) ;; (db:find-and-mark-incomplete db) (db:delay-if-busy dbdat) @@ -1591,11 +1591,11 @@ ;; (set! *global-delta* (/ (+ *global-delta* (* (- (current-milliseconds) start-ms) ;; (if throttle throttle 0.01))) ;; 2)) ;; (if (> (abs (- *last-global-delta-printed* *global-delta*)) 0.08) ;; don't print all the time, only if it changes a bit ;; (begin -;; (debug:print-info 4 "launch throttle factor=" *global-delta*) +;; (debug:print-info 4 #f "launch throttle factor=" *global-delta*) ;; (set! *last-global-delta-printed* *global-delta*))) (define (db:set-var dbstruct var val) (let* ((dbdat (db:get-db dbstruct #f)) (db (db:dbdat-get-db dbdat))) @@ -1709,12 +1709,12 @@ (andstr (if (> (length keys) 0) " AND " "")) (valslots (keys->valslots keys)) ;; ?,?,? ... (allvals (append (list runname state status user) (map cadr keyvals))) (qryvals (append (list runname) (map cadr keyvals))) (key=?str (string-intersperse (map (lambda (k)(conc k "=?")) keys) " AND "))) - (debug:print 3 "keys: " keys " allvals: " allvals " keyvals: " keyvals " key=?str is " key=?str) - (debug:print 2 "NOTE: using target " (string-intersperse (map cadr keyvals) "/") " for this run") + (debug:print 3 #f "keys: " keys " allvals: " allvals " keyvals: " keyvals " key=?str is " key=?str) + (debug:print 2 #f "NOTE: using target " (string-intersperse (map cadr keyvals) "/") " for this run") (if (and runname (null? (filter (lambda (x)(not x)) keyvals))) ;; there must be a better way to "apply and" (let ((res #f)) (db:delay-if-busy dbdat) (apply sqlite3:execute db (conc "INSERT OR IGNORE INTO runs (runname,state,status,owner,event_time" comma keystr ") VALUES (?,?,?,?,strftime('%s','now')" comma valslots ");") allvals) @@ -1722,18 +1722,18 @@ (apply sqlite3:for-each-row (lambda (id) (set! res id)) db (let ((qry (conc "SELECT id FROM runs WHERE (runname=? " andstr key=?str ");"))) - ;(debug:print 4 "qry: " qry) + ;(debug:print 4 #f "qry: " qry) qry) qryvals) (db:delay-if-busy dbdat) (sqlite3:execute db "UPDATE runs SET state=?,status=?,event_time=strftime('%s','now') WHERE id=? AND state='deleted';" state status res) res) (begin - (debug:print 0 "ERROR: Called without all necessary keys") + (debug:print 0 #f "ERROR: Called without all necessary keys") #f)))) ;; replace header and keystr with a call to runs:get-std-run-fields ;; ;; keypatts: ( (KEY1 "abc%def")(KEY2 "%") ) @@ -1763,20 +1763,20 @@ (conc " LIMIT " count) "") (if (number? offset) (conc " OFFSET " offset) "")))) - (debug:print-info 11 "db:get-runs START qrystr: " qrystr " keypatts: " keypatts " offset: " offset " limit: " count) + (debug:print-info 11 #f "db:get-runs START qrystr: " qrystr " keypatts: " keypatts " offset: " offset " limit: " count) (db:with-db dbstruct #f #f (lambda (db) (sqlite3:for-each-row (lambda (a . x) (set! res (cons (apply vector a x) res))) db qrystr ))) - (debug:print-info 11 "db:get-runs END qrystr: " qrystr " keypatts: " keypatts " offset: " offset " limit: " count) + (debug:print-info 11 #f "db:get-runs END qrystr: " qrystr " keypatts: " keypatts " offset: " offset " limit: " count) (vector header res))) ;; TODO: Switch this to use max(update_time) from each run db? Then if using a server there is no disk traffic (using inmem db) ;; (define (db:get-changed-run-ids since-time) @@ -1789,11 +1789,11 @@ (map (lambda (dbfile) (let* ((res (string-match ".*\\/(\\d)*\\.db" dbfile))) (if res (string->number (cadr res)) (begin - (debug:print 2 "WARNING: Failed to process " dbfile " for run-id") + (debug:print 2 #f "WARNING: Failed to process " dbfile " for run-id") 0)))) changed)))) ;; Get all targets from the db ;; @@ -1816,11 +1816,11 @@ (begin (hash-table-set! seen targ #t) (set! res (cons (apply vector targ) res)))))) db qrystr) - (debug:print-info 11 "db:get-targets END qrystr: " qrystr ) + (debug:print-info 11 #f "db:get-targets END qrystr: " qrystr ) (vector header res))))) ;; just get count of runs (define (db:get-num-runs dbstruct runpatt) (db:with-db @@ -1827,17 +1827,17 @@ dbstruct #f #f (lambda (db) (let ((numruns 0)) - (debug:print-info 11 "db:get-num-runs START " runpatt) + (debug:print-info 11 #f "db:get-num-runs START " runpatt) (sqlite3:for-each-row (lambda (count) (set! numruns count)) db "SELECT COUNT(id) FROM runs WHERE runname LIKE ? AND state != 'deleted';" runpatt) - (debug:print-info 11 "db:get-num-runs END " runpatt) + (debug:print-info 11 #f "db:get-num-runs END " runpatt) numruns)))) ;; (sqlite3#fold-row proc3670 init3671 db-or-stmt3672 . params3673)> ;; (define (db:get-raw-run-stats dbstruct run-id) @@ -1978,18 +1978,18 @@ (fulkey (conc ":" key)) (wildtype (if (substring-index "%" patt) "like" "glob"))) (if patt (set! key-patt (conc key-patt " AND " key " " wildtype " '" patt "'")) (begin - (debug:print 0 "ERROR: searching for runs with no pattern set for " fulkey) + (debug:print 0 #f "ERROR: searching for runs with no pattern set for " fulkey) (exit 6))))) keyvals) (set! qry-str (conc "SELECT " keystr " FROM runs WHERE state != 'deleted' AND runname " runwildtype " ? " key-patt " ORDER BY event_time " (if limit (conc " LIMIT " limit) "") (if offset (conc " OFFSET " offset) "") ";")) - (debug:print-info 4 "runs:get-runs-by-patt qry=" qry-str " " runnamepatt) + (debug:print-info 4 #f "runs:get-runs-by-patt qry=" qry-str " " runnamepatt) (db:with-db dbstruct #f #f ;; reads db, does not write to it. (lambda (db) (sqlite3:for-each-row (lambda (a . r) (set! res (cons (list->vector (cons a r)) res))) @@ -2008,19 +2008,19 @@ (keys (db:get-keys dbstruct)) (remfields (list "id" "runname" "state" "status" "owner" "event_time")) (header (append keys remfields)) (keystr (conc (keys->keystr keys) "," (string-intersperse remfields ",")))) - (debug:print-info 11 "db:get-run-info run-id: " run-id " header: " header " keystr: " keystr) + (debug:print-info 11 #f "db:get-run-info run-id: " run-id " header: " header " keystr: " keystr) (db:delay-if-busy dbdat) (sqlite3:for-each-row (lambda (a . x) (set! res (apply vector a x))) db (conc "SELECT " keystr " FROM runs WHERE id=? AND state != 'deleted';") run-id) - (debug:print-info 11 "db:get-run-info run-id: " run-id " header: " header " keystr: " keystr) + (debug:print-info 11 #f "db:get-run-info run-id: " run-id " header: " header " keystr: " keystr) (let ((finalres (vector header res))) ;; (hash-table-set! *run-info-cache* run-id finalres) finalres))) (define (db:set-comment-for-run dbstruct run-id comment) @@ -2065,11 +2065,11 @@ "unlocked" "locked")))) ;; semi-failsafe (sqlite3:execute db "UPDATE runs SET state=? WHERE id=?;" newlockval run-id) (sqlite3:execute db "INSERT INTO access_log (user,accessed,args) VALUES(?,strftime('%s','now'),?);" user (conc newlockval " " run-id)) - (debug:print-info 1 "" newlockval " run number " run-id))))) + (debug:print-info 1 #f "" newlockval " run number " run-id))))) (define (db:set-run-status dbstruct run-id status msg) (let* ((dbdat (db:get-db dbstruct #f)) (db (db:dbdat-get-db dbdat))) (db:delay-if-busy dbdat) @@ -2168,11 +2168,11 @@ ;; 'dashboard - use state = 'COMPLETED' AND status in ( statuses ) OR state in ( states ) ;; (define (db:get-tests-for-run dbstruct run-id testpatt states statuses offset limit not-in sort-by sort-order qryvals last-update mode) (if (not (number? run-id)) (begin ;; no need to treat this as an error by default - (debug:print 4 "WARNING: call to db:get-tests-for-run with bad run-id=" run-id) + (debug:print 4 #f "WARNING: call to db:get-tests-for-run with bad run-id=" run-id) ;; (print-call-chain (current-error-port)) '()) (let* ((qryvalstr (case qryvals ((shortlist) "id,run_id,testname,item_path,state,status") ((#f) db:test-record-qry-selector) ;; "id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment") @@ -2197,20 +2197,33 @@ (if not-in " NOT IN ('" " IN ('") ) (string-intersperse statuses "','") "')"))) + (interim-qry (conc " AND " (if not-in "NOT " "") "( state='COMPLETED' " (if statuses-qry (conc " AND " statuses-qry " ) ") " ) ") + (if states-qry + (conc (if not-in " AND " " OR ") states-qry ) ;; " ) ") + ""))) (states-statuses-qry (cond ((and states-qry statuses-qry) (case mode - ((dashboard)(conc " AND " (if not-in "NOT " "") "( ( state='COMPLETED' AND " statuses-qry " ) OR " states-qry " ) ")) + ((dashboard) + (if not-in + (conc " AND (state='COMPLETED' AND status NOT IN ('" (string-intersperse statuses "','") "')) " + " OR (state != 'COMPLETED' AND state NOT IN ('" (string-intersperse states "','") "')) ") + (conc " AND (state='COMPLETED' AND status IN ('" (string-intersperse statuses "','") "')) " + " OR (state NOT IN ('COMPLETED','DELETED') AND state IN ('" (string-intersperse states "','") "')) "))) (else (conc " AND ( " states-qry " AND " statuses-qry " ) ")))) (states-qry - (conc " AND " states-qry)) + (case mode + ((dashboard) (conc " AND " (if not-in "NOT " "") " state IN ('" (string-intersperse states "','") "') ")) ;; interim-qry) + (else (conc " AND " states-qry)))) (statuses-qry - (conc " AND " statuses-qry)) + (case mode + ((dashboard) (conc " AND " (if not-in "NOT " "") " status IN ('" (string-intersperse statuses "','") "') ")) ;; interim-qry) + (else (conc " AND " statuses-qry)))) (else ""))) (tests-match-qry (tests:match->sqlqry testpatt)) (qry (conc "SELECT " qryvalstr " FROM tests WHERE run_id=? " (if last-update " " " AND state != 'DELETED' ") ;; if using last-update we want deleted tests? @@ -2228,11 +2241,11 @@ (if sort-order sort-order " ") (if limit (conc " LIMIT " limit) " ") (if offset (conc " OFFSET " offset) " ") ";" ))) - (debug:print-info 8 "db:get-tests-for-run run-id=" run-id ", qry=" qry) + (debug:print-info 8 #f "db:get-tests-for-run run-id=" run-id ", qry=" qry) (db:with-db dbstruct run-id #f (lambda (db) (sqlite3:for-each-row (lambda (a . b) ;; id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment) (set! res (cons (apply vector a b) res))) ;; id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment) res))) @@ -2260,11 +2273,11 @@ (define (db:get-tests-for-run-state-status dbstruct run-id testpatt) (let* ((res '()) (tests-match-qry (tests:match->sqlqry testpatt)) (qry (conc "SELECT id,testname,item_path,state,status FROM tests WHERE run_id=? " (if tests-match-qry (conc " AND (" tests-match-qry ") ") "")))) - (debug:print-info 8 "db:get-tests-for-run qry=" qry) + (debug:print-info 8 #f "db:get-tests-for-run qry=" qry) (db:with-db dbstruct run-id #f (lambda (db) (sqlite3:for-each-row (lambda (id testname item-path state status) ;; id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment @@ -2287,17 +2300,10 @@ test-id))) res)) ;; get a useful subset of the tests data (used in dashboard ;; use db:mintest-get-{id ,run_id,testname ...} -;; -(define (db:get-tests-for-runs-mindata dbstruct run-ids testpatt states statuses not-in) - (debug:print 0 "ERROR: BROKN!") - ;; (db:get-tests-for-runs dbstruct run-ids testpatt states statuses not-in: not-in qryvals: "id,run_id,testname,state,status,event_time,item_path")) -) - -;; get a useful subset of the tests data (used in dashboard ;; (define (db:get-tests-for-run-mindata dbstruct run-id testpatt states statuses not-in) (db:get-tests-for-run dbstruct run-id testpatt states statuses #f #f not-in #f #f "id,run_id,testname,state,status,event_time,item_path" #f)) ;; do not use. @@ -2342,11 +2348,11 @@ ;; set tests with state currstate and status currstatus to newstate and newstatus ;; use currstate = #f and or currstatus = #f to apply to any state or status respectively ;; WARNING: SQL injection risk. NB// See new but not yet used "faster" version below ;; ;; AND NOT (item_path='' AND testname in (SELECT DISTINCT testname FROM tests WHERE testname=? AND item_path != ''));"))) -;; (debug:print 0 "QRY: " qry) +;; (debug:print 0 #f "QRY: " qry) ;; (db:delay-if-busy) ;; ;; NB// This call only operates on toplevel tests. Consider replacing it with more general call ;; (define (db:set-tests-state-status dbstruct run-id testnames currstate currstatus newstate newstatus) @@ -2570,17 +2576,17 @@ (db:with-db dbstruct run-id #t (lambda (db) (let* ((qmarks (string-intersperse (make-list (length db:test-record-fields) "?") ",")) (qrystr (conc "INSERT OR REPLACE INTO tests (" db:test-record-qry-selector ") VALUES (" qmarks ");")) (qry (sqlite3:prepare db qrystr))) - (debug:print 0 "INFO: migrating test records for run with id " run-id) + (debug:print 0 #f "INFO: migrating test records for run with id " run-id) (sqlite3:with-transaction db (lambda () (for-each (lambda (rec) - ;; (debug:print 0 "INFO: Inserting values: " (string-intersperse (map conc (vector->list rec)) ",") "\n") + ;; (debug:print 0 #f "INFO: Inserting values: " (string-intersperse (map conc (vector->list rec)) ",") "\n") (apply sqlite3:execute qry (vector->list rec))) testrecs))) (sqlite3:finalize! qry))))) ;; map a test-id into the proper range @@ -2598,17 +2604,17 @@ new-id) ;; if test-id-found then need to try again (if test-id-found (loop (+ new-id 1)) (begin - (debug:print-info 0 "New test id " new-id " selected for test with id " test-id) + (debug:print-info 0 #f "New test id " new-id " selected for test with id " test-id) (sqlite3:execute mtdb "UPDATE tests SET id=? WHERE id=?;" new-id test-id))))))) ;; move test ids into the 30k * run_id range ;; (define (db:prep-megatest.db-adj-test-ids mtdb run-id testrecs) - (debug:print-info 0 "Adjusting test ids in megatest.db for run " run-id) + (debug:print-info 0 #f "Adjusting test ids in megatest.db for run " run-id) (let ((min-test-id (* run-id 30000))) (for-each (lambda (testrec) (let* ((test-id (vector-ref testrec (db:field->number "id" db:test-record-fields)))) (db:adj-test-id (db:dbdat-get-db mtdb) min-test-id test-id))) @@ -2844,11 +2850,11 @@ ;; foo,bra, 1.2, pass, silly stuff ;; faz,bar, 10, 8mA, , ,"this is a comment" ;; EOF (define (db:csv->test-data dbstruct run-id test-id csvdata) - (debug:print 4 "test-id " test-id ", csvdata: " csvdata) + (debug:print 4 #f "test-id " test-id ", csvdata: " csvdata) (let* ((dbdat (db:get-db dbstruct run-id)) (db (db:dbdat-get-db dbdat)) (csvlist (csv->list (make-csv-reader (open-input-string csvdata) '((strip-leading-whitespace? #t) @@ -2868,11 +2874,11 @@ (string-match (regexp "^n/a$") s))) #f s))) ;; if specified on the input then use, else calculate (type (list-ref padded-row 8))) ;; look up expected,tol,units from previous best fit test if they are all either #f or '' - (debug:print 4 "BEFORE: category: " category " variable: " variable " value: " value + (debug:print 4 #f "BEFORE: category: " category " variable: " variable " value: " value ", expected: " expected " tol: " tol " units: " units " status: " status " comment: " comment " type: " type) (if (and (or (not expected)(equal? expected "")) (or (not tol) (equal? expected "")) (or (not units) (equal? expected ""))) @@ -2879,28 +2885,28 @@ (let-values (((new-expected new-tol new-units)(tdb:get-prev-tol-for-test #f test-id category variable))) (set! expected new-expected) (set! tol new-tol) (set! units new-units))) - (debug:print 4 "AFTER: category: " category " variable: " variable " value: " value + (debug:print 4 #f "AFTER: category: " category " variable: " variable " value: " value ", expected: " expected " tol: " tol " units: " units " status: " status " comment: " comment) ;; calculate status if NOT specified (if (and (not status)(number? expected)(number? value)) ;; need expected and value to be numbers (if (number? tol) ;; if tol is a number then we do the standard comparison (let* ((max-val (+ expected tol)) (min-val (- expected tol)) (result (and (>= value min-val)(<= value max-val)))) - (debug:print 4 "max-val: " max-val " min-val: " min-val " result: " result) + (debug:print 4 #f "max-val: " max-val " min-val: " min-val " result: " result) (set! status (if result "pass" "fail"))) (set! status ;; NB// need to assess each one (i.e. not return operator since need to act if not valid op. (case (string->symbol tol) ;; tol should be >, <, >=, <= ((>) (if (> value expected) "pass" "fail")) ((<) (if (< value expected) "pass" "fail")) ((>=) (if (>= value expected) "pass" "fail")) ((<=) (if (<= value expected) "pass" "fail")) (else (conc "ERROR: bad tol comparator " tol)))))) - (debug:print 4 "AFTER2: category: " category " variable: " variable " value: " value + (debug:print 4 #f "AFTER2: category: " category " variable: " variable " value: " value ", expected: " expected " tol: " tol " units: " units " status: " status " comment: " comment) (db:delay-if-busy dbdat) (sqlite3:execute db "INSERT OR REPLACE INTO test_data (test_id,category,variable,value,expected,tol,units,comment,status,type) VALUES (?,?,?,?,?,?,?,?,?,?);" test-id category variable value expected tol units (if comment comment "") status type))) csvlist))) @@ -2933,11 +2939,11 @@ keynames (string-split target "/")) " AND ")) ;; (testqry (tests:match->sqlqry testpatt)) (runsqry (sqlite3:prepare db (conc "SELECT id FROM runs WHERE " keystr " AND runname LIKE '" runname "';")))) - ;; (debug:print 8 "db:test-get-paths-matching-keynames-target-new\n runsqry=" runsqry "\n tstsqry=" testqry) + ;; (debug:print 8 #f "db:test-get-paths-matching-keynames-target-new\n runsqry=" runsqry "\n tstsqry=" testqry) (sqlite3:for-each-row (lambda (rid) (set! row-ids (cons rid row-ids))) runsqry) (sqlite3:finalize! runsqry) @@ -3003,11 +3009,11 @@ (base64:base64-decode (string-substitute (regexp "_") "=" msg #t))) (lambda ()(deserialize))) (begin - (debug:print 0 "ERROR: reception failed. Received " msg " but cannot translate it.") + (debug:print 0 #f "ERROR: reception failed. Received " msg " but cannot translate it.") msg))) ;; crude reply for when things go awry ((zmq nmsg)(with-input-from-string msg (lambda ()(deserialize)))) (else msg))) (define (db:test-set-status-state dbstruct run-id test-id status state msg) @@ -3060,12 +3066,12 @@ ;; (let ((path (sdb:qry 'getstr path-id)) ;; (final_logf (sdb:qry 'getstr final_logf-id))) (set! logf final_logf) (set! res (list path final_logf)) (if (directory? path) - (debug:print 2 "Found path: " path) - (debug:print 2 "No such path: " path))) ;; ) + (debug:print 2 #f "Found path: " path) + (debug:print 2 #f "No such path: " path))) ;; ) db "SELECT rundir,final_logf FROM tests WHERE testname=? AND item_path='';" test-name) res)))) @@ -3315,17 +3321,17 @@ (set! prev-run-ids (cons id prev-run-ids))) db (conc "SELECT id FROM runs WHERE " qrystr " AND id != ?;") (append keyvals (list run-id))) ;; collect all matching tests for the runs then ;; extract the most recent test and return that. - (debug:print 4 "selstr: " selstr ", qrystr: " qrystr ", keyvals: " keyvals + (debug:print 4 #f "selstr: " selstr ", qrystr: " qrystr ", keyvals: " keyvals ", previous run ids found: " prev-run-ids) (if (null? prev-run-ids) '() ;; no previous runs? return null (let loop ((hed (car prev-run-ids)) (tal (cdr prev-run-ids))) (let ((results (db:get-tests-for-run dbstruct hed (conc test-name "/" item-path) '() '() #f #f #f #f #f #f #f 'normal))) - (debug:print 4 "Got tests for run-id " run-id ", test-name " test-name + (debug:print 4 #f "Got tests for run-id " run-id ", test-name " test-name ", item-path " item-path " results: " (intersperse results "\n")) ;; Keep only the youngest of any test/item combination (for-each (lambda (testdat) (let* ((full-testname (conc (db:test-get-testname testdat) "/" (db:test-get-item-path testdat))) @@ -3348,11 +3354,11 @@ (db (db:dbdat-get-db dbdat)) ;; we'll return this so (db:delay--if-busy can be called inline (dbfj (conc dbpath "-journal"))) (if (handle-exceptions exn (begin - (debug:print-info 0 "WARNING: failed to test for existance of " dbfj) + (debug:print-info 0 #f "WARNING: failed to test for existance of " dbfj) (thread-sleep! 1) (db:delay-if-busy count (- count 1))) (file-exists? dbfj)) (case count ((6) @@ -3372,11 +3378,11 @@ (db:delay-if-busy count: 1)) ((1) (thread-sleep! 6.4) (db:delay-if-busy count: 0)) (else - (debug:print-info 0 "delaying db access due to high database load.") + (debug:print-info 0 #f "delaying db access due to high database load.") (thread-sleep! 12.8)))) db) "bogus result from db:delay-if-busy"))) (define (db:test-get-records-for-index-file dbstruct run-id test-name) @@ -3449,24 +3455,24 @@ ;; patha and pathb must be strings or this will fail ;; ;; path-b is waiting on path-a ;; (define (db:compare-itempaths test-b-name path-a path-b itemmaps ) - (debug:print-info 6 "ITEMMAPS: " itemmaps) + (debug:print-info 6 #f "ITEMMAPS: " itemmaps) (let* ((itemmap (tests:lookup-itemmap itemmaps test-b-name))) (if itemmap (let ((path-b-mapped (db:multi-pattern-apply path-b itemmap))) - (debug:print-info 6 "ITEMMAP is " itemmap ", path: " path-b ", mapped path: " path-b-mapped) + (debug:print-info 6 #f "ITEMMAP is " itemmap ", path: " path-b ", mapped path: " path-b-mapped) (equal? path-a path-b-mapped)) (equal? path-b path-a)))) ;; A routine to convert test/itempath using a itemmap ;; NOTE: to process only an itempath (i.e. no prepended testname) ;; just call db:multi-pattern-apply ;; (define (db:convert-test-itempath path-in itemmap) - (debug:print-info 6 "ITEMMAP is " itemmap) + (debug:print-info 6 #f "ITEMMAP is " itemmap) (let* ((path-parts (string-split path-in "/")) (test-name (if (null? path-parts) "" (car path-parts))) (item-path (string-intersperse (if (null? path-parts) '() (cdr path-parts)) "/"))) (conc test-name "/" (db:multi-pattern-apply item-path itemmap)))) @@ -3487,11 +3493,11 @@ (patt (car parts)) (repl (if (> (length parts) 1)(cadr parts) "")) (newr (if (and patt repl) (string-substitute patt repl res) (begin - (debug:print 0 "WARNING: itemmap has problem \"" itemmap "\", patt: " patt ", repl: " repl) + (debug:print 0 #f "WARNING: itemmap has problem \"" itemmap "\", patt: " patt ", repl: " repl) res)))) (if (null? tal) newr (loop (car tal)(cdr tal) newr))))))) @@ -3622,11 +3628,11 @@ tm.owner,reviewed, diskfree,uname,rundir, host,cpuload FROM tests AS t JOIN runs AS r ON t.run_id=r.id JOIN test_meta AS tm ON tm.testname=t.testname WHERE runname LIKE ? AND " keyqry ";"))) - (debug:print 2 "Using " tempdir " for constructing the ods file. keyqry: " keyqry " keystr: " keysstr " with keys: " (map cadr keypatt-alist) + (debug:print 2 #f "Using " tempdir " for constructing the ods file. keyqry: " keyqry " keystr: " keysstr " with keys: " (map cadr keypatt-alist) "\n mainqry: " mainqry) ;; "Expected Value" ;; "Value Found" ;; "Tolerance" (apply sqlite3:for-each-row @@ -3646,11 +3652,11 @@ (testname (vector-ref vb (+ 2 numkeys))) (item-path (vector-ref vb (+ 3 numkeys))) (final-log (vector-ref vb (+ 7 numkeys))) (run-dir (vector-ref vb (+ 18 numkeys))) (log-fpath (conc run-dir "/" final-log))) ;; (string-intersperse keyvals "/") "/" testname "/" item-path "/" - (debug:print 4 "log: " log-fpath " exists: " (file-exists? log-fpath)) + (debug:print 4 #f "log: " log-fpath " exists: " (file-exists? log-fpath)) (vector-set! vb (+ 7 numkeys) (if (file-exists? log-fpath) (let ((newpath (conc pathmod "/" (string-intersperse keyvals "/") "/" runname "/" testname "/" (if (string=? item-path "") "" (conc "/" item-path)) @@ -3664,11 +3670,11 @@ (vector->list vb)) b))))) db mainqry runspatt (map cadr keypatt-alist)) - (debug:print 2 "Found " (length test-ids) " records") + (debug:print 2 #f "Found " (length test-ids) " records") (set! results (list (cons "Runs" results))) ;; now, for each test, collect the test_data info and add a new sheet (for-each (lambda (test-id) (let ((test-data (list testdata-header)) @@ -3690,14 +3696,14 @@ (ods:list->ods tempdir (if (string-match (regexp "^[/~]+.*") outputfile) ;; full path? outputfile (begin - (debug:print 0 "WARNING: path given, " outputfile " is relative, prefixing with current directory") + (debug:print 0 #f "WARNING: path given, " outputfile " is relative, prefixing with current directory") (conc (current-directory) "/" outputfile))) results) ;; brutal clean up (system "rm -rf tempdir"))) ;; (db:extract-ods-file db "outputfile.ods" '(("sysname" "%")("fsname" "%")("datapath" "%")) "%") Index: dcommon.scm ================================================================== --- dcommon.scm +++ dcommon.scm @@ -186,11 +186,11 @@ )) (runid-to-col (hash-table-ref *cachedata* "runid-to-col")) (testname-to-row (hash-table-ref *cachedata* "testname-to-row")) (colnum 1) (rownum 0)) ;; rownum = 0 is the header -;; (debug:print 0 "test-ids " test-ids ", tests-detail-changes " tests-detail-changes) +;; (debug:print 0 #f "test-ids " test-ids ", tests-detail-changes " tests-detail-changes) ;; tests related stuff ;; (all-testnames (delete-duplicates (map db:test-get-testname test-changes)))) ;; Given a run-id and testname/item_path calculate a cell R:C @@ -262,11 +262,11 @@ (tree:add-node (dboard:data-get-tests-tree *data*) "Runs" test-path userdata: (conc "test-id: " test-id)) (let ((node-num (tree:find-node tb (cons "Runs" test-path))) (color (car (gutils:get-color-for-state-status state status)))) - (debug:print 0 "node-num: " node-num ", color: " color) + (debug:print 0 #f "node-num: " node-num ", color: " color) (iup:attribute-set! tb (conc "COLOR" node-num) color)) (hash-table-set! (dboard:data-get-path-test-ids *data*) test-path test-id) (if (not rownum) (let ((rownums (hash-table-values testname-to-row))) (set! rownum (if (null? rownums) @@ -276,11 +276,11 @@ ;; create the label (iup:attribute-set! (dboard:data-get-runs-matrix *data*) (conc rownum ":" 0) dispname) )) ;; set the cell text and color - ;; (debug:print 2 "rownum:colnum=" rownum ":" colnum ", state=" status) + ;; (debug:print 2 #f "rownum:colnum=" rownum ":" colnum ", state=" status) (iup:attribute-set! (dboard:data-get-runs-matrix *data*) (conc rownum ":" colnum) (if (member state '("ARCHIVED" "COMPLETED")) status state)) @@ -293,12 +293,12 @@ (let ((updater (hash-table-ref/default (dboard:data-get-updaters *data*) window-id #f))) (if updater (updater (hash-table-ref/default data get-details-sig #f)))) (iup:attribute-set! (dboard:data-get-runs-matrix *data*) "REDRAW" "ALL") - ;; (debug:print 2 "run-changes: " run-changes) - ;; (debug:print 2 "test-changes: " test-changes) + ;; (debug:print 2 #f "run-changes: " run-changes) + ;; (debug:print 2 #f "test-changes: " test-changes) (list run-changes all-test-changes))) ;;====================================================================== ;; TESTS DATA ;;====================================================================== @@ -685,12 +685,12 @@ (lambda (waiton) (let* ((waiton-box-info (hash-table-ref/default tests-hash waiton #f)) (waiton-center (dcommon:get-box-center (or waiton-box-info test-box-info)))) (dcommon:draw-arrow cnv test-box-center waiton-center))) waitons) - ;; (debug:print 0 "test-box-info=" test-box-info) - ;; (debug:print 0 "test-record=" test-record) + ;; (debug:print 0 #f "test-box-info=" test-box-info) + ;; (debug:print 0 #f "test-record=" test-record) )) (define (dcommon:estimate-scale sizex sizey originx originy nodes) ;; (print "sizex: " sizex " sizey: " sizey " originx: " originx " originy: " originy " nodes: " nodes) (let* ((maxx 1) @@ -902,20 +902,20 @@ (begin ;; we are going to speculatively clear rows until we find a row that is already cleared (let loop ((rownum (+ max-row 1)) (colnum 0) (deleted #f)) - ;; (debug:print-info 0 "cleaning " rownum ":" colnum) + ;; (debug:print-info 0 #f "cleaning " rownum ":" colnum) (let* ((next-row (if (eq? colnum max-col) (+ rownum 1) rownum)) (next-col (if (eq? colnum max-col) 1 (+ colnum 1))) (mtrx-rc (conc rownum ":" colnum)) (curr-val (iup:attribute steps-matrix mtrx-rc))) - ;; (debug:print-info 0 "cleaning " rownum ":" colnum " currval= " curr-val) + ;; (debug:print-info 0 #f "cleaning " rownum ":" colnum " currval= " curr-val) (if (and (string? curr-val) (not (equal? curr-val ""))) (begin (iup:attribute-set! steps-matrix mtrx-rc "") (loop next-row next-col #t)) (if (eq? colnum max-col) ;; not done, didn't get a full blank row (if deleted (loop next-row next-col #f)) ;; exit on this not met (loop next-row next-col deleted))))) (iup:attribute-set! steps-matrix "REDRAW" "ALL"))))) Index: env.scm ================================================================== --- env.scm +++ env.scm @@ -206,6 +206,6 @@ (begin (print "# Changed vars") (map (lambda (dat)(print (car dat) " " (cdr dat))) (hash-table->alist changed))))) (else - (debug:print 0 "ERROR: No dumpmode specified, use -dumpmode [bash|csh|config]"))))) + (debug:print 0 #f "ERROR: No dumpmode specified, use -dumpmode [bash|csh|config]"))))) Index: ezsteps.scm ================================================================== --- ezsteps.scm +++ ezsteps.scm @@ -41,14 +41,14 @@ (let loop ((count 5)) (if (file-exists? test-run-dir) (push-directory test-run-dir) (if (> count 0) (begin - (debug:print 0 "WARNING: ezsteps attempting to run but test run directory " test-run-dir " is not there. Waiting and trying again " count " more times") + (debug:print 0 #f "WARNING: ezsteps attempting to run but test run directory " test-run-dir " is not there. Waiting and trying again " count " more times") (sleep 3) (loop (- count 1)))))) - (debug:print-info 0 "Running in directory " test-run-dir) + (debug:print-info 0 #f "Running in directory " test-run-dir) (if (not (file-exists? ".ezsteps"))(create-directory ".ezsteps")) ;; if ezsteps was defined then we are sure to have at least one step but check anyway (if (not (> (length ezstepslst) 0)) (message-window "ERROR: You can only re-run steps defined via ezsteps") (begin @@ -72,19 +72,19 @@ (if (equal? stepname start-step-name) (set! runflag #t) ;; and continue (if (not (null? tal)) (loop (car tal)(cdr tal) stepname #f)))) - (debug:print 4 "ezsteps:\n stepname: " stepname " stepinfo: " stepinfo " stepparts: " stepparts + (debug:print 4 #f "ezsteps:\n stepname: " stepname " stepinfo: " stepinfo " stepparts: " stepparts " stepparms: " stepparms " stepcmd: " stepcmd) (if (file-exists? (conc stepname ".logpro"))(set! logpro-used #t)) ;; call the command using mt_ezstep (set! script (conc "mt_ezstep " stepname " " (if prevstep prevstep "-") " " stepcmd)) - (debug:print 4 "script: " script) + (debug:print 4 #f "script: " script) (rmt:teststep-set-status! 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))) @@ -115,11 +115,11 @@ (next-status (cond ((eq? overall-status 'pass) this-step-status) ((eq? overall-status 'warn) (if (eq? this-step-status 'fail) 'fail 'warn)) (else 'fail)))) - (debug:print 4 "Exit value received: " (vector-ref exit-info 2) " logpro-used: " logpro-used + (debug:print 4 #f "Exit value received: " (vector-ref exit-info 2) " logpro-used: " logpro-used " this-step-status: " this-step-status " overall-status: " overall-status " next-status: " next-status " rollup-status: " rollup-status) (case next-status ((warn) (set! rollup-status 2) @@ -135,11 +135,11 @@ )))) (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)))) - (debug:print 4 "WARNING: a prior step failed, stopping at " ezstep))) + (debug:print 4 #f "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 @@ -157,11 +157,11 @@ ((eq? rollup-status 1) "FAIL") ((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 "Test NOT logged as COMPLETED, (state=" (db:test-get-state testinfo) "), updating result, rollup-status is " rollup-status) + (debug:print-info 2 #f "Test NOT logged as COMPLETED, (state=" (db:test-get-state testinfo) "), updating result, rollup-status is " rollup-status) (tests:test-set-status! 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 Index: fs-transport.scm ================================================================== --- fs-transport.scm +++ fs-transport.scm @@ -37,8 +37,8 @@ ;; (define (fs:process-queue-item packet) (if (not *megatest-db*) ;; we will require that (setup-for-run) has already been called (set! *megatest-db* (open-db))) - (debug:print-info 11 "fs:process-queue-item called with packet=" packet) + (debug:print-info 11 #f "fs:process-queue-item called with packet=" packet) (db:process-queue-item *megatest-db* packet)) Index: http-transport.scm ================================================================== --- http-transport.scm +++ http-transport.scm @@ -48,11 +48,11 @@ ;; (define *db:process-queue-mutex* (make-mutex)) (define (http-transport:run hostn run-id server-id) - (debug:print 2 "Attempting to start the server ...") + (debug:print 2 #f "Attempting to start the server ...") (let* ((db #f) ;; (open-db)) ;; we don't want the server to be opening and closing the db unnecesarily (hostname (get-host-name)) (ipaddrstr (let ((ipstr (if (string=? "-" hostn) ;; (string-intersperse (map number->string (u8vector->list (hostname->ip hostname))) ".") (server:get-best-guess-address hostname) @@ -59,11 +59,11 @@ #f))) (if ipstr ipstr hostn))) ;; hostname))) (start-port (portlogger:open-run-close portlogger:find-port)) (link-tree-path (configf:lookup *configdat* "setup" "linktree"))) ;; (set! db *inmemdb*) - (debug:print-info 0 "portlogger recommended port: " start-port) + (debug:print-info 0 #f "portlogger recommended port: " start-port) (root-path (if link-tree-path link-tree-path (current-directory))) ;; WARNING: SECURITY HOLE. FIX ASAP! (handle-directory spiffy-directory-listing) (handle-exception (lambda (exn chain) @@ -112,22 +112,22 @@ ;; This is recursively run by http-transport:run until sucessful ;; (define (http-transport:try-start-server run-id ipaddrstr portnum server-id) (let ((config-hostname (configf:lookup *configdat* "server" "hostname")) (tdbdat (tasks:open-db))) - (debug:print-info 0 "http-transport:try-start-server run-id=" run-id " ipaddrsstr=" ipaddrstr " portnum=" portnum " server-id=" server-id " config-hostname=" config-hostname) + (debug:print-info 0 #f "http-transport:try-start-server run-id=" run-id " ipaddrsstr=" ipaddrstr " portnum=" portnum " server-id=" server-id " config-hostname=" config-hostname) (handle-exceptions exn (begin (print-error-message exn) (if (< portnum 64000) (begin - (debug:print 0 "WARNING: attempt to start server failed. Trying again ...") - (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) - (debug:print 0 "exn=" (condition->list exn)) + (debug:print 0 #f "WARNING: attempt to start server failed. Trying again ...") + (debug:print 0 #f " message: " ((condition-property-accessor 'exn 'message) exn)) + (debug:print 0 #f "exn=" (condition->list exn)) (portlogger:open-run-close portlogger:set-failed portnum) - (debug:print 0 "WARNING: failed to start on portnum: " portnum ", trying next port") + (debug:print 0 #f "WARNING: failed to start on portnum: " portnum ", trying next port") (thread-sleep! 0.1) ;; get_next_port goes here (http-transport:try-start-server run-id ipaddrstr @@ -140,11 +140,11 @@ (set! *server-info* (list ipaddrstr portnum)) (tasks:server-set-interface-port (db:delay-if-busy tdbdat) server-id ipaddrstr portnum) - (debug:print 0 "INFO: Trying to start server on " ipaddrstr ":" portnum) + (debug:print 0 #f "INFO: Trying to start server on " ipaddrstr ":" portnum) ;; This starts the spiffy server ;; NEED WAY TO SET IP TO #f TO BIND ALL ;; (start-server bind-address: ipaddrstr port: portnum) (if config-hostname ;; this is a hint to bind directly (start-server port: portnum bind-address: (if (equal? config-hostname "-") @@ -151,11 +151,11 @@ ipaddrstr config-hostname)) (start-server port: portnum)) ;; (portlogger:open-run-close portlogger:set-port portnum "released") (tasks:server-force-clean-run-record (db:delay-if-busy tdbdat) run-id ipaddrstr portnum " http-transport:try-start-server") - (debug:print 1 "INFO: server has been stopped")))) + (debug:print 1 #f "INFO: server has been stopped")))) ;;====================================================================== ;; S E R V E R U T I L I T I E S ;;====================================================================== @@ -183,11 +183,11 @@ (mutex-lock! *http-mutex*) (set! *http-requests-in-progress* (+ 1 *http-requests-in-progress*)) ;; Use this opportunity to slow things down iff there are too many requests in flight (if (> *http-requests-in-progress* 5) (begin - (debug:print-info 0 "Whoa there buddy, ease up...") + (debug:print-info 0 #f "Whoa there buddy, ease up...") (thread-sleep! 1))) (mutex-unlock! *http-mutex*)) (define (http-transport:dec-requests-count proc) (mutex-lock! *http-mutex*) @@ -201,11 +201,11 @@ (if (> *http-requests-in-progress* 0) (if (> etime (current-seconds)) (begin (thread-sleep! 0.05) (loop etime)) - (debug:print 0 "ERROR: requests still in progress after 5 seconds of waiting. I'm going to pass on cleaning up http connections")) + (debug:print 0 #f "ERROR: requests still in progress after 5 seconds of waiting. I'm going to pass on cleaning up http connections")) (close-all-connections!))) (set! *http-connections-next-cleanup* (+ (current-seconds) 10)) (mutex-unlock! *http-mutex*)) (define (http-transport:inc-requests-and-prep-to-close-all-connections) @@ -216,11 +216,11 @@ ;; (define (http-transport:client-api-send-receive run-id serverdat cmd params #!key (numretries 3)) (let* ((fullurl (if (vector? serverdat) (http-transport:server-dat-get-api-req serverdat) (begin - (debug:print 0 "FATAL ERROR: http-transport:client-api-send-receive called with no server info") + (debug:print 0 #f "FATAL ERROR: http-transport:client-api-send-receive called with no server info") (exit 1)))) (res #f) (success #t) (sparams (db:obj->string params transport: 'http))) ;; (condition-case @@ -230,20 +230,20 @@ ;; (begin ;; (mutex-unlock! *http-mutex*) ;; (thread-sleep! 1) ;; (handle-exceptions ;; exn -;; (debug:print 0 "WARNING: closing connections failed. Server at " fullurl " almost certainly dead") +;; (debug:print 0 #f "WARNING: closing connections failed. Server at " fullurl " almost certainly dead") ;; (close-all-connections!)) -;; (debug:print 0 "WARNING: Failed to communicate with server, trying again, numretries left: " numretries) +;; (debug:print 0 #f "WARNING: Failed to communicate with server, trying again, numretries left: " numretries) ;; (http-transport:client-api-send-receive run-id serverdat cmd sparams numretries: (- numretries 1))) ;; (begin ;; (mutex-unlock! *http-mutex*) ;; (tasks:kill-server-run-id run-id) ;; #f)) ;; (begin - (debug:print-info 11 "fullurl=" fullurl ", cmd=" cmd ", params=" params ", run-id=" run-id "\n") + (debug:print-info 11 #f "fullurl=" fullurl ", cmd=" cmd ", params=" params ", run-id=" run-id "\n") ;; set up the http-client here (max-retry-attempts 1) ;; consider all requests indempotent (retry-request? (lambda (request) #f)) @@ -259,12 +259,12 @@ (db:string->obj (handle-exceptions exn (begin (set! success #f) - (debug:print 0 "WARNING: failure in with-input-from-request to " fullurl ".") - (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) + (debug:print 0 #f "WARNING: failure in with-input-from-request to " fullurl ".") + (debug:print 0 #f " message: " ((condition-property-accessor 'exn 'message) exn)) (hash-table-delete! *runremote* run-id) ;; Killing associated server to allow clean retry.") ;; (tasks:kill-server-run-id run-id) ;; better to kill the server in the logic that called this routine? (mutex-unlock! *http-mutex*) ;;; (signal (make-composite-condition @@ -289,19 +289,19 @@ (th2 (make-thread time-out "time out"))) (thread-start! th1) (thread-start! th2) (thread-join! th1) (thread-terminate! th2) - (debug:print-info 11 "got res=" res) + (debug:print-info 11 #f "got res=" res) (if (vector? res) (if (vector-ref res 0) res (begin ;; note: this code also called in nmsg-transport - consider consolidating it - (debug:print 0 "ERROR: error occured at server, info=" (vector-ref res 2)) - (debug:print 0 " client call chain:") + (debug:print 0 #f "ERROR: error occured at server, info=" (vector-ref res 2)) + (debug:print 0 #f " client call chain:") (print-call-chain (current-error-port)) - (debug:print 0 " server call chain:") + (debug:print 0 #f " server call chain:") (pp (vector-ref res 1) (current-error-port)) (signal (vector-ref result 0)))) (signal (make-composite-condition (make-property-condition 'timeout @@ -339,11 +339,11 @@ (define (http-transport:server-dat-update-last-access vec) (if (vector? vec) (vector-set! vec 5 (current-seconds)) (begin (print-call-chain (current-error-port)) - (debug:print 0 "ERROR: call to http-transport:server-dat-update-last-access with non-vector!!")))) + (debug:print 0 #f "ERROR: call to http-transport:server-dat-update-last-access with non-vector!!")))) ;; ;; connect ;; (define (http-transport:client-connect iface port) @@ -358,32 +358,32 @@ ;; (define (http-transport:keep-running server-id run-id) ;; if none running or if > 20 seconds since ;; server last used then start shutdown ;; This thread waits for the server to come alive - (debug:print-info 0 "Starting the sync-back, keep alive thread in server for run-id=" run-id) + (debug:print-info 0 #f "Starting the sync-back, keep alive thread in server for run-id=" run-id) (let* ((tdbdat (tasks:open-db)) (server-start-time (current-seconds)) (server-info (let loop ((start-time (current-seconds)) (changed #t) (last-sdat "not this")) (let ((sdat #f)) (thread-sleep! 0.01) - (debug:print-info 0 "Waiting for server alive signature") + (debug:print-info 0 #f "Waiting for server alive signature") (mutex-lock! *heartbeat-mutex*) (set! sdat *server-info*) (mutex-unlock! *heartbeat-mutex*) (if (and sdat (not changed) (> (- (current-seconds) start-time) 2)) sdat (begin - (debug:print-info 0 "Still waiting, last-sdat=" last-sdat) + (debug:print-info 0 #f "Still waiting, last-sdat=" last-sdat) (sleep 4) (if (> (- (current-seconds) start-time) 120) ;; been waiting for two minutes (begin - (debug:print 0 "ERROR: transport appears to have died, exiting server " server-id " for run " run-id) + (debug:print 0 #f "ERROR: transport appears to have died, exiting server " server-id " for run " run-id) (tasks:server-delete-record (db:delay-if-busy tdbdat) server-id "failed to start, never received server alive signature") (exit)) (loop start-time (equal? sdat last-sdat) sdat))))))) @@ -408,16 +408,16 @@ (http-transport:server-shutdown server-id port)) (else ;; (> bad-sync-count 0) ;; we've had a fail or two, delay and loop (thread-sleep! 5) (loop count server-state (+ bad-sync-count 1))))) ((exn) - (debug:print 0 "ERROR: error from sync code other than 'sync-failed. Attempting to gracefully shutdown the server") + (debug:print 0 #f "ERROR: error from sync code other than 'sync-failed. Attempting to gracefully shutdown the server") (tasks:server-delete-record (db:delay-if-busy tdbdat) server-id " http-transport:keep-running crashed") (exit))) (set! sync-time (- (current-milliseconds) start-time)) (set! rem-time (quotient (- 4000 sync-time) 1000)) - (debug:print 4 "SYNC: time= " sync-time ", rem-time=" rem-time) + (debug:print 4 #f "SYNC: time= " sync-time ", rem-time=" rem-time) (if (and (<= rem-time 4) (> rem-time 0)) (thread-sleep! rem-time) (thread-sleep! 4))) ;; fallback for if the math is changed ... @@ -449,20 +449,20 @@ (mutex-unlock! *heartbeat-mutex*) (if (or (not (equal? sdat (list iface port))) (not server-id)) (begin - (debug:print-info 0 "interface changed, refreshing iface and port info") + (debug:print-info 0 #f "interface changed, refreshing iface and port info") (set! iface (car sdat)) (set! port (cadr sdat)))) ;; Transfer *last-db-access* to last-access to use in checking that we are still alive (mutex-lock! *heartbeat-mutex*) (set! last-access *last-db-access*) (mutex-unlock! *heartbeat-mutex*) - ;; (debug:print 11 "last-access=" last-access ", server-timeout=" server-timeout) + ;; (debug:print 11 #f "last-access=" last-access ", server-timeout=" server-timeout) ;; ;; no_traffic, no running tests, if server 0, no running servers ;; ;; (let ((wait-on-running (configf:lookup *configdat* "server" b"wait-on-running"))) ;; wait on running tasks (if not true then exit on time out) ;; @@ -469,17 +469,17 @@ (let* ((hrs-since-start (/ (- (current-seconds) server-start-time) 3600)) (adjusted-timeout (if (> hrs-since-start 1) (- server-timeout (inexact->exact (round (* hrs-since-start 60)))) ;; subtract 60 seconds per hour server-timeout))) (if (common:low-noise-print 120 "server timeout") - (debug:print-info 0 "Adjusted server timeout: " adjusted-timeout)) + (debug:print-info 0 #f "Adjusted server timeout: " adjusted-timeout)) (if (and *server-run* (> (+ last-access server-timeout) (current-seconds))) (begin (if (common:low-noise-print 120 "server continuing") - (debug:print-info 0 "Server continuing, seconds since last db access: " (- (current-seconds) last-access))) + (debug:print-info 0 #f "Server continuing, seconds since last db access: " (- (current-seconds) last-access))) ;; ;; Consider implementing some smarts here to re-insert the record or kill self is ;; the db indicates so ;; ;; (if (tasks:server-am-i-the-server? tdb run-id) @@ -488,36 +488,36 @@ (loop 0 server-state bad-sync-count)) (http-transport:server-shutdown server-id port)))))) (define (http-transport:server-shutdown server-id port) (let ((tdbdat (tasks:open-db))) - (debug:print-info 0 "Starting to shutdown the server.") + (debug:print-info 0 #f "Starting to shutdown the server.") ;; need to delete only *my* server entry (future use) (set! *time-to-exit* #t) (if *inmemdb* (db:sync-touched *inmemdb* *run-id* force-sync: #t)) ;; ;; start_shutdown ;; (tasks:server-set-state! (db:delay-if-busy tdbdat) server-id "shutting-down") (portlogger:open-run-close portlogger:set-port port "released") (thread-sleep! 5) - (debug:print-info 0 "Max cached queries was " *max-cache-size*) - (debug:print-info 0 "Number of cached writes " *number-of-writes*) - (debug:print-info 0 "Average cached write time " + (debug:print-info 0 #f "Max cached queries was " *max-cache-size*) + (debug:print-info 0 #f "Number of cached writes " *number-of-writes*) + (debug:print-info 0 #f "Average cached write time " (if (eq? *number-of-writes* 0) "n/a (no writes)" (/ *writes-total-delay* *number-of-writes*)) " ms") - (debug:print-info 0 "Number non-cached queries " *number-non-write-queries*) - (debug:print-info 0 "Average non-cached time " + (debug:print-info 0 #f "Number non-cached queries " *number-non-write-queries*) + (debug:print-info 0 #f "Average non-cached time " (if (eq? *number-non-write-queries* 0) "n/a (no queries)" (/ *total-non-write-delay* *number-non-write-queries*)) " ms") - (debug:print-info 0 "Server shutdown complete. Exiting") + (debug:print-info 0 #f "Server shutdown complete. Exiting") (tasks:server-delete-record (db:delay-if-busy tdbdat) server-id " http-transport:keep-running complete") (exit))) ;; all routes though here end in exit ... ;; @@ -533,11 +533,11 @@ (begin (current-error-port *alt-log-file*) (current-output-port *alt-log-file*))))) (if (server:check-if-running run-id) (begin - (debug:print 0 "INFO: Server for run-id " run-id " already running") + (debug:print 0 #f "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)) (if (not server-id) (if (> remtries 0) @@ -545,23 +545,23 @@ (thread-sleep! 2) (loop (tasks:server-lock-slot (db:delay-if-busy tdbdat) run-id) (- remtries 1))) (begin ;; since we didn't get the server lock we are going to clean up and bail out - (debug:print-info 2 "INFO: server pid=" (current-process-id) ", hostname=" (get-host-name) " not starting due to other candidates ahead in start queue") + (debug:print-info 2 #f "INFO: server pid=" (current-process-id) ", hostname=" (get-host-name) " not starting due to other candidates ahead in start queue") (tasks:server-delete-records-for-this-pid (db:delay-if-busy tdbdat) " http-transport:launch") )) (let* ((th2 (make-thread (lambda () - (debug:print-info 0 "Server run thread started") + (debug:print-info 0 #f "Server run thread started") (http-transport:run (if (args:get-arg "-server") (args:get-arg "-server") "-") run-id server-id)) "Server run")) (th3 (make-thread (lambda () - (debug:print-info 0 "Server monitor thread started") + (debug:print-info 0 #f "Server monitor thread started") (http-transport:keep-running server-id run-id)) "Keep running"))) (thread-start! th2) (thread-sleep! 0.25) ;; give the server time to settle before starting the keep-running monitor. (thread-start! th3) @@ -583,18 +583,18 @@ (define (http-transport:server-signal-handler signum) (signal-mask! signum) (handle-exceptions exn - (debug:print " ... exiting ...") + (debug:print 0 #f " ... exiting ...") (let ((th1 (make-thread (lambda () (thread-sleep! 1)) "eat response")) (th2 (make-thread (lambda () - (debug:print 0 "ERROR: Received ^C, attempting clean exit. Please be patient and wait a few seconds before hitting ^C again.") + (debug:print 0 #f "ERROR: Received ^C, attempting clean exit. Please be patient and wait a few seconds before hitting ^C again.") (thread-sleep! 3) ;; give the flush three seconds to do it's stuff - (debug:print 0 " Done.") + (debug:print 0 #f " Done.") (exit 4)) "exit on ^C timer"))) (thread-start! th2) (thread-start! th1) (thread-join! th2)))) Index: items.scm ================================================================== --- items.scm +++ items.scm @@ -45,26 +45,26 @@ (define (item-assoc->item-list itemsdat) (if (and itemsdat (not (null? itemsdat))) (let ((itemlst (filter (lambda (x) (list? x)) (map (lambda (x) - (debug:print 6 "item-assoc->item-list x: " x) + (debug:print 6 #f "item-assoc->item-list x: " x) (if (< (length x) 2) (begin - (debug:print 0 "ERROR: malformed items spec " (string-intersperse x " ")) + (debug:print 0 #f "ERROR: malformed items spec " (string-intersperse x " ")) (list (car x)'())) (let* ((name (car x)) (items (cadr x)) (ilist (list name (if (string? items) (string-split items) '())))) (if (null? ilist) - (debug:print 0 "ERROR: No items specified for " name)) + (debug:print 0 #f "ERROR: No items specified for " name)) ilist))) itemsdat)))) (let ((debuglevel 5)) - (debug:print 5 "item-assoc->item-list: itemsdat => itemlst ") + (debug:print 5 #f "item-assoc->item-list: itemsdat => itemlst ") (if (debug:debug-mode 5) (begin (pp itemsdat) (print " => ") (pp itemlst)))) @@ -93,11 +93,11 @@ (rowdat (cadr row))) (set! item (append item (list (if (< indx (length rowdat)) (let ((new (list rowname (list-ref rowdat indx)))) - ;; (debug:print 0 "New: " new) + ;; (debug:print 0 #f "New: " new) (set! elflag #t) new ) ;; i.e. had at least on legit value to use (list rowname "-"))))))) newlst) @@ -121,11 +121,11 @@ (define (items:get-items-from-config tconfig) (let* ((have-items (hash-table-ref/default tconfig "items" #f)) (have-itable (hash-table-ref/default tconfig "itemstable" #f)) (items (hash-table-ref/default tconfig "items" '())) (itemstable (hash-table-ref/default tconfig "itemstable" '()))) - (debug:print 5 "items: " items " itemstable: " itemstable) + (debug:print 5 #f "items: " items " itemstable: " itemstable) (set! items (map (lambda (item) (if (procedure? (cadr item)) (list (car item)((cadr item))) ;; evaluate the proc item)) items)) @@ -132,16 +132,16 @@ (set! itemstable (map (lambda (item) (if (procedure? (cadr item)) (list (car item)((cadr item))) ;; evaluate the proc item)) itemstable)) - (if (and have-items (null? items)) (debug:print 0 "ERROR: [items] section in testconfig but no entries defined")) - (if (and have-itable (null? itemstable))(debug:print 0 "ERROR: [itemstable] section in testconfig but no entries defined")) + (if (and have-items (null? items)) (debug:print 0 #f "ERROR: [items] section in testconfig but no entries defined")) + (if (and have-itable (null? itemstable))(debug:print 0 #f "ERROR: [itemstable] section in testconfig but no entries defined")) (if (or (not (null? items))(not (null? itemstable))) (append (item-assoc->item-list items) (item-table->item-list itemstable)) '(())))) ;; (pp (item-assoc->item-list itemdat)) Index: keys.scm ================================================================== --- keys.scm +++ keys.scm @@ -43,13 +43,13 @@ (for-each (lambda (key val) (setenv key val) (if ht (hash-table-set! ht (conc ":" key) val))) keys vals) - (debug:print 0 "ERROR: wrong number of values in " target ", should match " keys)) + (debug:print 0 #f "ERROR: wrong number of values in " target ", should match " keys)) vals) - (debug:print 4 "ERROR: keys:target-set-args called with no target."))) + (debug:print 4 #f "ERROR: keys:target-set-args called with no target."))) ;; given the keys (a list of vectors or a list of keys) and a target return a keyval list ;; keyval list ( (key1 val1) (key2 val2) ...) (define (keys:target->keyval keys target) (let* ((targlist (string-split target "/")) Index: launch.scm ================================================================== --- launch.scm +++ launch.scm @@ -99,11 +99,11 @@ ";;") (print tconfig-logpro))) (set! logpro-used #t))) ;; NB// can safely assume we are in test-area directory - (debug:print 4 "ezsteps:\n stepname: " stepname " stepinfo: " stepinfo " stepparts: " stepparts + (debug:print 4 #f "ezsteps:\n stepname: " stepname " stepinfo: " stepinfo " stepparts: " stepparts " stepparms: " stepparms " stepcmd: " stepcmd) ;; ;; first source the previous environment ;; (let ((prev-env (conc ".ezsteps/" prevstep (if (string-search (regexp "csh") ;; (get-environment-variable "SHELL")) ".csh" ".sh")))) @@ -111,11 +111,11 @@ ;; (set! script (conc script "source " prev-env)))) ;; call the command using mt_ezstep ;; (set! script (conc "mt_ezstep " stepname " " (if prevstep prevstep "x") " " stepcmd)) - (debug:print 4 "script: " script) + (debug:print 4 #f "script: " script) (rmt:teststep-set-status! 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") @@ -132,11 +132,11 @@ (if (eq? pid-val 0) (begin (thread-sleep! 2) (processloop (+ i 1)))) ))))) - (debug:print-info 0 "step " stepname " completed with exit code " (launch:einf-exit-code exit-info)) ;; (vector-ref exit-info 2)) + (debug:print-info 0 #f "step " stepname " completed with exit code " (launch:einf-exit-code exit-info)) ;; (vector-ref exit-info 2)) ;; now run logpro if needed (if logpro-used (let ((pid (process-run (conc "logpro " logpro-file " " (conc stepname ".html") " < " stepname ".log")))) (let processloop ((i 0)) (let-values (((pid-val exit-status exit-code)(process-wait pid #t))) @@ -148,11 +148,11 @@ (mutex-unlock! m) (if (eq? pid-val 0) (begin (thread-sleep! 2) (processloop (+ i 1))))) - (debug:print-info 0 "logpro for step " stepname " exited with code " (launch:einf-exit-code exit-info))))) ;; (vector-ref exit-info 2))))) + (debug:print-info 0 #f "logpro for step " stepname " exited with code " (launch:einf-exit-code exit-info))))) ;; (vector-ref exit-info 2))))) (let ((exinfo (launch:einf-exit-code exit-info)) ;; (vector-ref exit-info 2)) (logfna (if logpro-used (conc stepname ".html") "")) (comment #f)) (if logpro-used @@ -185,11 +185,11 @@ (next-state ;; "RUNNING") ;; WHY WAS THIS CHANGED TO NOT USE (null? tal) ?? (cond ((null? tal) ;; more to run? "COMPLETED") (else "RUNNING")))) - (debug:print 4 "Exit value received: " (launch:einf-exit-code exit-info) " logpro-used: " logpro-used + (debug:print 4 #f "Exit value received: " (launch:einf-exit-code exit-info) " logpro-used: " logpro-used " this-step-status: " this-step-status " overall-status: " overall-status " 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 @@ -273,21 +273,21 @@ #f))) (if testconfig (hash-table-set! *testconfigs* test-name testconfig) ;; cached for lazy reads later ... (begin (launch:setup) - (debug:print 0 "WARNING: no testconfig found for " test-name " in search path:\n " + (debug:print 0 #f "WARNING: no testconfig found for " test-name " in search path:\n " (string-intersperse (tests:get-tests-search-path *configdat*) "\n ")))) ;; after all that, still no testconfig? Time to abort (if (not testconfig) (begin - (debug:print 0 "ERROR: Failed to resolve megatest.config, runconfigs.config and testconfig issues. Giving up now") + (debug:print 0 #f "ERROR: Failed to resolve megatest.config, runconfigs.config and testconfig issues. Giving up now") (exit 1))) (if (not (file-exists? ".ezsteps"))(create-directory ".ezsteps")) ;; if ezsteps was defined then we are sure to have at least one step but check anyway (if (not (> (length ezstepslst) 0)) - (debug:print 0 "ERROR: ezsteps defined but ezstepslst is zero length") + (debug:print 0 #f "ERROR: ezsteps defined but ezstepslst is zero length") (let loop ((ezstep (car ezstepslst)) (tal (cdr ezstepslst)) (prevstep #f)) ;; check exit-info (vector-ref exit-info 1) (if (launch:einf-exit-status exit-info) ;; (vector-ref exit-info 1) @@ -297,12 +297,12 @@ (if (and logpro-used (file-exists? (conc stepname ".dat"))) (launch:load-logpro-dat run-id test-id stepname)) (if (steprun-good? logpro-used (launch:einf-exit-code exit-info)) (if (not (null? tal)) (loop (car tal) (cdr tal) stepname)) - (debug:print 4 "WARNING: step " (car ezstep) " failed. Stopping"))) - (debug:print 4 "WARNING: a prior step failed, stopping at " ezstep))))))) + (debug:print 4 #f "WARNING: step " (car ezstep) " failed. Stopping"))) + (debug:print 4 #f "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) (let* ((start-seconds (current-seconds)) (calc-minutes (lambda () (inexact->exact @@ -330,11 +330,11 @@ (set! kill-job? (or (test-get-kill-request 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 "KILLING TEST DUE TO TIME LIMIT EXCEEDED! Runtime=" run-seconds " seconds, limit=" runtlim) + (debug:print-info 0 #f "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) (if kill-job? (begin @@ -350,14 +350,14 @@ (for-each (lambda (pid) (handle-exceptions exn (begin - (debug:print-info 0 "Unable to kill process with pid " pid ", possibly already killed.") - (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn))) - (debug:print 0 "WARNING: Request received to kill job " pid) ;; " (attempt # " kill-tries ")") - (debug:print-info 0 "Signal mask=" (signal-mask)) + (debug:print-info 0 #f "Unable to kill process with pid " pid ", possibly already killed.") + (debug:print 0 #f " message: " ((condition-property-accessor 'exn 'message) exn))) + (debug:print 0 #f "WARNING: Request received to kill job " pid) ;; " (attempt # " kill-tries ")") + (debug:print-info 0 #f "Signal mask=" (signal-mask)) ;; (if (process:alive? pid) ;; (begin (map (lambda (pid-num) (process-signal pid-num signal/term)) (process:get-sub-pids pid)) @@ -367,15 +367,15 @@ (handle-exceptions exn #f (process-signal pid-num signal/kill))) (process:get-sub-pids pid)))) - ;; (debug:print-info 0 "not killing process " pid " as it is not alive")))) + ;; (debug:print-info 0 #f "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)) (begin - (debug:print 0 "ERROR: Nothing to kill, pid1=" pid1 ", pid2=" pid2) + (debug:print 0 #f "ERROR: Nothing to kill, pid1=" pid1 ", pid2=" pid2) (tests:test-set-status! run-id test-id "KILLED" "FAILED TO KILL" (args:get-arg "-m") #f) ))) (mutex-unlock! m) ;; no point in sticking around. Exit now. (exit))) @@ -430,28 +430,28 @@ (let loop ((count 0)) (if (or (file-exists? top-path) (> count 10)) (change-directory top-path) (begin - (debug:print 0 "INFO: Not starting job yet - directory " top-path " not found") + (debug:print 0 #f "INFO: Not starting job yet - directory " top-path " not found") (thread-sleep! 10) (loop (+ count 1))))) (let ((sighand (lambda (signum) ;; (signal-mask! signum) ;; to mask or not? seems to cause issues in exiting (if (eq? signum signal/stop) - (debug:print 0 "ERROR: attempt to STOP process. Exiting.")) + (debug:print 0 #f "ERROR: 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 () (tests:test-force-state-status! run-id test-id "INCOMPLETE" "KILLED") (print "Killed by signal " signum ". Exiting") (thread-sleep! 1) (exit 1)))) (th2 (make-thread (lambda () (thread-sleep! 2) - (debug:print 0 "Done") + (debug:print 0 #f "Done") (exit 4))))) (thread-start! th2) (thread-start! th1) (thread-join! th2))))) (set-signal-handler! signal/int sighand) @@ -464,29 +464,29 @@ (let* ((test-info (rmt:get-test-info-by-id 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 "INFO: test is INCOMPLETE or KILLED, treat this execute call as a rerun request") + (debug:print 0 #f "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")) ;; prime it for running ((member (db:test-get-state test-info) '("RUNNING" "REMOTEHOSTSTART")) (if (process:alive-on-host? test-host test-pid) - (debug:print 0 "ERROR: test state is " (db:test-get-state test-info) " and process " test-pid " is still running on host " test-host ", cannot proceed") + (debug:print 0 #f "ERROR: 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"))) ((not (member (db:test-get-state test-info) '("REMOVING" "REMOTEHOSTSTART" "RUNNING" "KILLREQ"))) (tests:test-force-state-status! run-id test-id "REMOTEHOSTSTART" "n/a")) (else ;; (member (db:test-get-state test-info) '("REMOVING" "REMOTEHOSTSTART" "RUNNING" "KILLREQ")) - (debug:print 0 "ERROR: test state is " (db:test-get-state test-info) ", cannot proceed") + (debug:print 0 #f "ERROR: test state is " (db:test-get-state test-info) ", cannot proceed") (exit)))) - (debug:print 2 "Exectuing " test-name " (id: " test-id ") on " (get-host-name)) + (debug:print 2 #f "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 ;; one of these is defunct/redundant ... (if (not (launch:setup force: #t)) (begin - (debug:print 0 "Failed to setup, exiting") + (debug:print 0 #f "Failed to setup, exiting") ;; (sqlite3:finalize! db) ;; (sqlite3:finalize! tdb) (exit 1))) (change-directory *toppath*) @@ -503,47 +503,47 @@ (let ((var (car varval)) (val (cadr varval))) (if (and (string? var)(string? val)) (begin (setenv var (config:eval-string-in-environment val))) ;; val) - (debug:print 0 "ERROR: bad variable spec, " var "=" val)))) + (debug:print 0 #f "ERROR: bad variable spec, " var "=" val)))) (configf:get-section rconfig section))) (list "default" target))) ;; 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? work-area) (> count 10)) (change-directory work-area) (begin - (debug:print 0 "INFO: Not starting job yet - directory " work-area " not found") + (debug:print 0 #f "INFO: Not starting job yet - directory " work-area " not found") (thread-sleep! 10) (loop (+ count 1))))) ;; (change-directory work-area) (set! keyvals (keys:target->keyval keys target)) ;; apply pre-overrides before other variables. The pre-override vars must not ;; clobbers things from the official sources such as megatest.config and runconfigs.config (if (string? set-vars) (let ((varpairs (string-split set-vars ","))) - (debug:print 4 "varpairs: " varpairs) + (debug:print 4 #f "varpairs: " varpairs) (map (lambda (varpair) (let ((varval (string-split varpair "="))) (if (eq? (length varval) 2) (let ((var (car varval)) (val (cadr varval))) - (debug:print 1 "Adding pre-var/val " var " = " val " to the environment") + (debug:print 1 #f "Adding pre-var/val " var " = " val " to the environment") (setenv var val))))) varpairs))) (for-each (lambda (varval) (let ((var (car varval)) (val (cadr varval))) (if val (setenv var val) (begin - (debug:print 0 "ERROR: required variable " var " does not have a valid value. Exiting") + (debug:print 0 #f "ERROR: required variable " var " does not have a valid value. Exiting") (exit))))) (list (list "MT_TEST_RUN_DIR" work-area) (list "MT_TEST_NAME" test-name) (list "MT_ITEM_INFO" (conc itemdat)) @@ -600,11 +600,11 @@ (th2 (make-thread runit "run job"))) (set! job-thread th2) (thread-start! th1) (thread-start! th2) (thread-join! th2) - (debug:print-info 0 "Megatest exectute of test " test-name ", item path " item-path " complete. Notifying the db ...") + (debug:print-info 0 #f "Megatest exectute of test " test-name ", item path " item-path " complete. Notifying the db ...") (hash-table-set! misc-flags 'keep-going #f) (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)) @@ -628,11 +628,11 @@ ((eq? (launch:einf-rollup-status exit-info) 3) "CHECK") ((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 "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)) + (debug:print-info 1 #f "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 test-id new-state new-status (args:get-arg "-m") #f) @@ -643,11 +643,11 @@ (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))) (mutex-unlock! m) - (debug:print 2 "Output from running " fullrunscript ", pid " (launch:einf-pid exit-info) " in work area " + (debug:print 2 #f "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))))))) (define (launch:cache-config) @@ -665,11 +665,11 @@ (fulldir (conc linktree "/" target "/" runname))) (if (and linktree (file-exists? linktree)) ;; can't proceed without linktree (begin - (debug:print-info 0 "Have -run with target=" target ", runname=" runname ", fulldir=" fulldir ", testpatt=" (or (args:get-arg "-testpatt") "%")) + (debug:print-info 0 #f "Have -run with target=" target ", runname=" runname ", fulldir=" fulldir ", testpatt=" (or (args:get-arg "-testpatt") "%")) (if (not (file-exists? fulldir)) (create-directory fulldir #t)) ;; need to protect with exception handler (if (and target runname (file-exists? fulldir)) @@ -676,15 +676,15 @@ (let ((tmpfile (conc fulldir "/.megatest.cfg." (current-seconds))) (targfile (conc fulldir "/.megatest.cfg-" megatest-version "-" megatest-fossil-hash)) (rconfig (conc fulldir "/.runconfig." megatest-version "-" megatest-fossil-hash))) (if (file-exists? rconfig) ;; only cache megatest.config AFTER runconfigs has been cached (begin - (debug:print-info 0 "Caching megatest.config in " tmpfile) + (debug:print-info 0 #f "Caching megatest.config in " tmpfile) (configf:write-alist *configdat* tmpfile) (system (conc "ln -sf " tmpfile " " targfile)))) ))) - (debug:print-info 1 "No linktree yet, no caching configs."))))) + (debug:print-info 1 #f "No linktree yet, no caching configs."))))) ;; gather available information, if legit read configs in this order: ;; ;; if have cache; @@ -749,11 +749,11 @@ (set! *configinfo* first-pass) (set! *toppath* (or toppath (cadr first-pass))) ;; use the gathered data unless already have it (set! toppath *toppath*) (if (not *toppath*) (begin - (debug:print "ERROR: you are not in a megatest area!") + (debug:print 0 #f "ERROR: 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)) (key-vals (keys:target->keyval keys target)) @@ -792,11 +792,11 @@ (set! *configdat* (car cfgdat)) (set! *runconfigdat* rdat) (set! *toppath* toppath) (set! *configstatus* 'partial)) (begin - (debug:print 0 "ERROR: No " mtconfig " file found. Giving up.") + (debug:print 0 #f "ERROR: No " mtconfig " file found. Giving up.") (exit 2)))))) ;; additional house keeping (let* ((linktree (or (getenv "MT_LINKTREE") (if *configdat* (configf:lookup *configdat* "setup" "linktree") #f)))) (if linktree @@ -803,23 +803,23 @@ (if (not (file-exists? linktree)) (begin (handle-exceptions exn (begin - (debug:print 0 "ERROR: Something went wrong when trying to create linktree dir at " linktree) - (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) + (debug:print 0 #f "ERROR: Something went wrong when trying to create linktree dir at " linktree) + (debug:print 0 #f " message: " ((condition-property-accessor 'exn 'message) exn)) (exit 1)) (create-directory linktree #t)))) (begin - (debug:print 0 "ERROR: linktree not defined in [setup] section of megatest.config") + (debug:print 0 #f "ERROR: linktree not defined in [setup] section of megatest.config") ;; (exit 1) ))) (if (and *toppath* (directory-exists? *toppath*)) (setenv "MT_RUN_AREA_HOME" *toppath*) (begin - (debug:print 0 "ERROR: failed to find the top path to your Megatest area."))) + (debug:print 0 #f "ERROR: failed to find the top path to your Megatest area."))) *toppath*)) (define launch:setup launch:setup-new) (define (get-best-disk confdat testconfig) @@ -831,11 +831,11 @@ (let ((res (common:get-disk-with-most-free-space disks minspace))) ;; min size of 1000, seems tad dumb (if res (cdr res) (begin (if (common:low-noise-print 20 "No valid disks or no disk with enough space") - (debug:print 0 "ERROR: No valid disks found in megatest.config. Please add some to your [disks] section and ensure the directory exists and has enough space!\n You can change minspace in the [setup] section of megatest.config. Current setting is: " minspace)) + (debug:print 0 #f "ERROR: No valid disks found in megatest.config. Please add some to your [disks] section and ensure the directory exists and has enough space!\n You can change minspace in the [setup] section of megatest.config. Current setting is: " minspace)) (exit 1))))))) ;; Desired directory structure: ;; ;; - - -. @@ -882,22 +882,22 @@ ;; 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) - (debug:print 2 "INFO:\n lnkbase=" lnkbase "\n lnkpath=" lnkpath "\n toptest-path=" toptest-path "\n test-path=" test-path) + (debug:print 2 #f "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 "WARNING: linktree did not exist! Creating it now at " linktree) + (debug:print 0 #f "WARNING: linktree did not exist! Creating it now at " linktree) (create-directory linktree #t))) ;; (system (conc "mkdir -p " linktree)))) ;; create the directory for the tests dir links, this is needed no matter what... (if (and (not (directory-exists? lnkbase)) (not (file-exists? lnkbase))) (handle-exceptions exn (begin - (debug:print "ERROR: Problem creating linktree base at " lnkbase) + (debug:print 0 #f "ERROR: Problem creating linktree base at " lnkbase) (print-error-message exn (current-error-port))) (create-directory lnkbase #t))) ;; update the toptest record with its location rundir, cache the path ;; This wass highly inefficient, one db write for every subtest, potentially @@ -908,32 +908,32 @@ ;; if the test is iterated it is necessary to create the parent path ;; to the iteration. use pathname-directory to trim the path by one ;; level (if (not not-iterated) ;; i.e. iterated (let ((iterated-parent (pathname-directory (conc lnkpath "/" item-path)))) - (debug:print-info 2 "Creating iterated parent " iterated-parent) + (debug:print-info 2 #f "Creating iterated parent " iterated-parent) (handle-exceptions exn (begin - (debug:print 0 "ERROR: Failed to create directory " iterated-parent ((condition-property-accessor 'exn 'message) exn) ", exiting") + (debug:print 0 #f "ERROR: Failed to create directory " iterated-parent ((condition-property-accessor 'exn 'message) exn) ", exiting") (exit 1)) (create-directory iterated-parent #t)))) (if (symbolic-link? lnkpath) (handle-exceptions exn (begin - (debug:print 0 "ERROR: Failed to remove symlink " lnkpath ((condition-property-accessor 'exn 'message) exn) ", exiting") + (debug:print 0 #f "ERROR: Failed to remove symlink " lnkpath ((condition-property-accessor 'exn 'message) exn) ", exiting") (exit 1)) (delete-file lnkpath))) (if (not (or (file-exists? lnkpath) (symbolic-link? lnkpath))) (handle-exceptions exn (begin - (debug:print 0 "ERROR: Failed to create symlink " lnkpath ((condition-property-accessor 'exn 'message) exn) ", exiting") + (debug:print 0 #f "ERROR: Failed to create symlink " lnkpath ((condition-property-accessor 'exn 'message) exn) ", exiting") (exit 1)) (create-symbolic-link toptest-path lnkpath))) ;; NB - This was not working right - some top tests are not getting the path set!!! ;; @@ -958,11 +958,11 @@ testname "") ;; (rmt:general-call '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 "Creating " toptest-path " and link " lnkpath) + (debug:print-info 2 #f "Creating " toptest-path " and link " lnkpath) (handle-exceptions exn #f ;; don't care to catch and deal with errors here for now. (create-directory toptest-path #t)) (hash-table-set! *toptest-paths* testname toptest-path))))) @@ -969,27 +969,27 @@ ;; The toptest path has been created, the link to the test in the linktree has ;; been created. Now, if this is an iterated test the real test dir must be created (if (not not-iterated) ;; this is an iterated test (begin ;; (let ((lnktarget (conc lnkpath "/" item-path))) - (debug:print 2 "Setting up sub test run area") - (debug:print 2 " - creating run area in " test-path) + (debug:print 2 #f "Setting up sub test run area") + (debug:print 2 #f " - creating run area in " test-path) (handle-exceptions exn (begin - (debug:print 0 "ERROR: Failed to create directory " test-path ((condition-property-accessor 'exn 'message) exn) ", exiting") + (debug:print 0 #f "ERROR: Failed to create directory " test-path ((condition-property-accessor 'exn 'message) exn) ", exiting") (exit 1)) (create-directory test-path #t)) - (debug:print 2 + (debug:print 2 #f " - creating link from: " test-path "\n" " to: " lnktarget) ;; If there is already a symlink delete it and recreate it. (handle-exceptions exn (begin - (debug:print 0 "ERROR: Failed to re-create link " lnktarget ((condition-property-accessor 'exn 'message) exn) ", exiting") + (debug:print 0 #f "ERROR: Failed to re-create link " lnktarget ((condition-property-accessor 'exn 'message) exn) ", exiting") (exit)) (if (symbolic-link? lnktarget) (delete-file lnktarget)) (if (not (file-exists? lnktarget)) (create-symbolic-link test-path lnktarget))))) (if (not (directory? test-path)) @@ -1007,15 +1007,15 @@ ovrcmd (conc "rsync -av" (if (debug:debug-mode 1) "" "q") " " test-src-path "/ " test-path "/" " >> " test-path "/mt_launch.log 2>> " test-path "/mt_launch.log"))) (status (system cmd))) (if (not (eq? status 0)) - (debug:print 2 "ERROR: problem with running \"" cmd "\""))) + (debug:print 2 #f "ERROR: problem with running \"" cmd "\""))) (list lnkpathf lnkpath )) (if (and test-src-path (> remtries 0)) (begin - (debug:print 0 "ERROR: Failed to create work area at " test-path " with link at " lnktarget ", remaining attempts " remtries) + (debug:print 0 #f "ERROR: Failed to create work area at " test-path " with link at " lnktarget ", remaining attempts " remtries) ;; (create-work-area run-id run-info keyvals test-id test-src-path disk-path testname itemdat remtries: (- remtries 1))) (list #f #f))))) ;; 1. look though disks list for disk with most space @@ -1089,11 +1089,11 @@ (if launcher (set! launcher (string-split launcher))) ;; 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 "attempting to preclean directory " (db:test-get-rundir testinfo) " for test " test-name "/" item-path) + (debug:print-info 0 #f "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 ;; prevent overlapping actions - set to LAUNCHED as early as possible ;; (tests:test-set-status! run-id test-id "LAUNCHED" "n/a" #f #f) ;; (if launch-results launch-results "FAILED")) @@ -1101,15 +1101,15 @@ (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)) (set! toptest-work-area (cadr dat)) - (debug:print-info 2 "Using work area " work-area)) + (debug:print-info 2 #f "Using work area " work-area)) (begin (set! work-area (conc test-path "/tmp_run")) (create-directory work-area #t) - (debug:print 0 "WARNING: No disk work area specified - running in the test directory under tmp_run"))) + (debug:print 0 #f "WARNING: No disk work area specified - running in the test directory under tmp_run"))) (set! cmdparms (base64:base64-encode (z3:encode-buffer (with-output-to-string (lambda () ;; (list 'hosts hosts) (write (list (list 'testpath test-path) @@ -1143,17 +1143,17 @@ ;; (set! fullcmd (append launcher (car hosts)(list remote-megatest test-sig "-execute" cmdparms)))) (launcher (set! fullcmd (append launcher (list remote-megatest "-m" test-sig "-execute" cmdparms) debug-param))) ;; (set! fullcmd (append launcher (list remote-megatest test-sig "-execute" cmdparms)))) (else - (if (not useshell)(debug:print 0 "WARNING: internal launching will not work well without \"useshell yes\" in your [jobtools] section")) + (if (not useshell)(debug:print 0 #f "WARNING: internal launching will not work well without \"useshell yes\" in your [jobtools] section")) (set! fullcmd (append (list remote-megatest "-m" test-sig "-execute" cmdparms) debug-param (list (if useshell "&" "")))))) ;; (set! fullcmd (list remote-megatest test-sig "-execute" cmdparms (if useshell "&" ""))))) (if (args:get-arg "-xterm")(set! fullcmd (append fullcmd (list "-xterm")))) - (debug:print 1 "Launching " work-area) + (debug:print 1 #f "Launching " work-area) ;; set pre-launch-env-vars before launching, keep the vars in prevvals and put the envionment back when done - (debug:print 4 "fullcmd: " fullcmd) + (debug:print 4 #f "fullcmd: " fullcmd) (let* ((commonprevvals (alist->env-vars (hash-table-ref/default *configdat* "env-override" '()))) (testprevvals (alist->env-vars (hash-table-ref/default tconfig "pre-launch-env-overrides" '()))) (miscprevvals (alist->env-vars ;; consolidate this code with the code in megatest.scm for "-execute" @@ -1186,12 +1186,12 @@ (print "LAUNCHCMD: " (string-intersperse fullcmd " ")) (if (list? launch-results) (apply print launch-results) (print "NOTE: launched \"" fullcmd "\"\n but did not wait for it to proceed. Add the following to megatest.config \n[setup]\nlaunchwait yes\n if you have problems with this")) #:append)) - (debug:print 2 "Launching completed, updating db") - (debug:print 2 "Launch results: " launch-results) + (debug:print 2 #f "Launching completed, updating db") + (debug:print 2 #f "Launch results: " launch-results) (if (not launch-results) (begin (print "ERROR: Failed to run " (string-intersperse fullcmd " ") ", exiting now") ;; (sqlite3:finalize! db) ;; good ole "exit" seems not to work Index: lock-queue.scm ================================================================== --- lock-queue.scm +++ lock-queue.scm @@ -73,16 +73,16 @@ (tasks:wait-on-journal (lock-queue:db-dat-get-path dbdat) 1200) (handle-exceptions exn (if (> remtries 0) (begin - (debug:print 0 "WARNING: exception on lock-queue:set-state. Trying again in 30 seconds.") - (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) + (debug:print 0 #f "WARNING: exception on lock-queue:set-state. Trying again in 30 seconds.") + (debug:print 0 #f " message: " ((condition-property-accessor 'exn 'message) exn)) (thread-sleep! 30) (lock-queue:set-state dbdat test-id newstate remtries: (- remtries 1))) (begin - (debug:print 0 "ERROR: Failed to set lock state for test with id " test-id ", error: " ((condition-property-accessor 'exn 'message) exn) ", giving up.") + (debug:print 0 #f "ERROR: Failed to set lock state for test with id " test-id ", error: " ((condition-property-accessor 'exn 'message) exn) ", giving up.") #f)) (sqlite3:execute (lock-queue:db-dat-get-db dbdat) "UPDATE queue SET state=? WHERE test_id=?;" newstate test-id))) @@ -91,17 +91,17 @@ ;; (tasks:wait-on-journal (lock-queue:db-dat-get-path dbdat) 1200) (handle-exceptions exn (if (> remtries 0) (begin - (debug:print 0 "WARNING: exception on lock-queue:any-younger. Removing lockdb and trying again in 5 seconds.") - (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) + (debug:print 0 #f "WARNING: exception on lock-queue:any-younger. Removing lockdb and trying again in 5 seconds.") + (debug:print 0 #f " message: " ((condition-property-accessor 'exn 'message) exn)) (thread-sleep! 5) (lock-queue:delete-lock-db dbdat) (lock-queue:any-younger? dbdat mystart test-id remtries: (- remtries 1))) (begin - (debug:print 0 "ERROR: Failed to find younger locks for test with id " test-id ", error: " ((condition-property-accessor 'exn 'message) exn) ", giving up.") + (debug:print 0 #f "ERROR: Failed to find younger locks for test with id " test-id ", error: " ((condition-property-accessor 'exn 'message) exn) ", giving up.") #f)) (let ((res #f)) (sqlite3:for-each-row (lambda (tid) ;; Actually this should not be needed as mystart cannot be simultaneously less than and test-id same as @@ -119,12 +119,12 @@ (mklckqry (sqlite3:prepare db "INSERT INTO runlocks (test_id,run_lock) VALUES (?,'locked');"))) (let ((result (handle-exceptions exn (begin - (debug:print 0 "WARNING: failed to get queue lock. Removing lock db and returning fail") ;; Will try again in a few seconds") - (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) + (debug:print 0 #f "WARNING: failed to get queue lock. Removing lock db and returning fail") ;; Will try again in a few seconds") + (debug:print 0 #f " message: " ((condition-property-accessor 'exn 'message) exn)) (thread-sleep! 10) ;; (if (> count 0) ;; #f ;; (lock-queue:get-lock dbdat test-id count: (- count 1)) - give up on retries ;; (begin ;; never recovered, remote the lock file and return #f, no lock obtained (lock-queue:delete-lock-db dbdat) @@ -151,12 +151,12 @@ (let* ((dbdat (lock-queue:open-db fname))) (tasks:wait-on-journal (lock-queue:db-dat-get-path dbdat) 1200 "lock-queue:release-lock; waiting on journal") (handle-exceptions exn (begin - (debug:print 0 "WARNING: Failed to release queue lock. Will try again in few seconds") - (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) + (debug:print 0 #f "WARNING: Failed to release queue lock. Will try again in few seconds") + (debug:print 0 #f " message: " ((condition-property-accessor 'exn 'message) exn)) (thread-sleep! (/ count 10)) (if (> count 0) (begin (sqlite3:finalize! (lock-queue:db-dat-get-db dbdat)) (lock-queue:release-lock fname test-id count: (- count 1))) @@ -171,17 +171,17 @@ #f)))) (sqlite3:execute (lock-queue:db-dat-get-db dbdat) "DELETE FROM runlocks WHERE test_id=?;" test-id) (sqlite3:finalize! (lock-queue:db-dat-get-db dbdat))))) (define (lock-queue:steal-lock dbdat test-id #!key (count 10)) - (debug:print-info 0 "Attempting to steal lock at " (lock-queue:db-dat-get-path dbdat)) + (debug:print-info 0 #f "Attempting to steal lock at " (lock-queue:db-dat-get-path dbdat)) (tasks:wait-on-journal (lock-queue:db-dat-get-path dbdat) 1200 "lock-queue:steal-lock; waiting on journal") (handle-exceptions exn (begin - (tadebug:print 0 "WARNING: Failed to steal queue lock. Will try again in few seconds") - (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) + (debug:print 0 #f "WARNING: Failed to steal queue lock. Will try again in few seconds") + (debug:print 0 #f " message: " ((condition-property-accessor 'exn 'message) exn)) (thread-sleep! 10) (if (> count 0) (lock-queue:steal-lock dbdat test-id count: (- count 1)) #f)) (sqlite3:execute (lock-queue:db-dat-get-db dbdat) "DELETE FROM runlocks WHERE run_lock='locked';")) @@ -197,20 +197,20 @@ (db (lock-queue:db-dat-get-db dbdat))) ;; (tasks:wait-on-journal (lock-queue:db-dat-get-path dbdat) 1200 waiting-msg: "lock-queue:wait-turn; waiting on journal file") (handle-exceptions exn (begin - (debug:print 0 "WARNING: Failed to find out if it is ok to skip the wait queue. Will try again in few seconds") - (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) + (debug:print 0 #f "WARNING: Failed to find out if it is ok to skip the wait queue. Will try again in few seconds") + (debug:print 0 #f " message: " ((condition-property-accessor 'exn 'message) exn)) (print-call-chain (current-error-port)) (thread-sleep! 10) (if (> count 0) (begin (sqlite3:finalize! db) (lock-queue:wait-turn fname test-id count: (- count 1))) (begin - (debug:print 0 "Giving up calls to lock-queue:wait-turn for test-id " test-id " at path " fname ", printing call chain") + (debug:print 0 #f "Giving up calls to lock-queue:wait-turn for test-id " test-id " at path " fname ", printing call chain") (print-call-chain (current-error-port)) #f))) ;; wait 10 seconds and then check to see if someone is already updating the html (thread-sleep! 10) (if (not (lock-queue:any-younger? dbdat mystart test-id)) ;; no processing in flight, must try to start processing Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -324,11 +324,11 @@ (args:get-arg "-runstep") (args:get-arg "-envcap") (args:get-arg "-envdelta") ) )) - (debug:print 0 "ERROR: Unrecognised arguments: " (string-intersperse (if (list? remargs) remargs (argv)) " "))) + (debug:print 0 #f "ERROR: Unrecognised arguments: " (string-intersperse (if (list? remargs) remargs (argv)) " "))) ;; immediately set MT_TARGET if -reqtarg or -target are available ;; (let ((targ (or (args:get-arg "-reqtarg")(args:get-arg "-target")))) (if targ (setenv "MT_TARGET" targ))) @@ -356,25 +356,25 @@ (hash-table-ref/default *db-local-sync* run-id #f)) ;; (if (> (- start-time last-write) 5) ;; every five seconds (begin ;; let ((sync-time (- (current-seconds) start-time))) (db:multi-db-sync (list run-id) 'new2old) (let ((sync-time (- (current-seconds) start-time))) - (debug:print-info 3 "Sync of newdb to olddb for run-id " run-id " completed in " sync-time " seconds") + (debug:print-info 3 #f "Sync of newdb to olddb for run-id " run-id " completed in " sync-time " seconds") (if (common:low-noise-print 30 "sync new to old") - (debug:print-info 0 "Sync of newdb to olddb for run-id " run-id " completed in " sync-time " seconds"))) + (debug:print-info 0 #f "Sync of newdb to olddb for run-id " run-id " completed in " sync-time " seconds"))) ;; (if (> sync-time 10) ;; took more than ten seconds, start a server for this run ;; (begin - ;; (debug:print-info 0 "Sync is taking a long time, start up a server to assist for run " run-id) + ;; (debug:print-info 0 #f "Sync is taking a long time, start up a server to assist for run " run-id) ;; (server:kind-run run-id))))) (hash-table-delete! *db-local-sync* run-id))) (mutex-unlock! *db-multi-sync-mutex*)) (hash-table-keys *db-local-sync*)) (if (and debug-mode (> (- start-time last-time) 60)) (begin (set! last-time start-time) - (debug:print-info 4 "timestamp -> " (seconds->time-string (current-seconds)) ", time since start -> " (seconds->hr-min-sec (- (current-seconds) *time-zero*)))))) + (debug:print-info 4 #f "timestamp -> " (seconds->time-string (current-seconds)) ", time since start -> " (seconds->hr-min-sec (- (current-seconds) *time-zero*)))))) ;; keep going unless time to exit ;; (if (not *time-to-exit*) (let delay-loop ((count 0)) @@ -383,19 +383,19 @@ (begin (thread-sleep! 1) (delay-loop (+ count 1)))) (loop))) (if (common:low-noise-print 30) - (debug:print-info 0 "Exiting watchdog timer, *time-to-exit* = " *time-to-exit*))))) + (debug:print-info 0 #f "Exiting watchdog timer, *time-to-exit* = " *time-to-exit*))))) "Watchdog thread"))) (thread-start! *watchdog*) (if (args:get-arg "-log") (let ((oup (open-output-file (args:get-arg "-log")))) - (debug:print-info 0 "Sending log output to " (args:get-arg "-log")) + (debug:print-info 0 #f "Sending log output to " (args:get-arg "-log")) (current-error-port oup) (current-output-port oup))) (if (or (args:get-arg "-h") (args:get-arg "-help") @@ -406,11 +406,11 @@ (if (args:get-arg "-start-dir") (if (file-exists? (args:get-arg "-start-dir")) (change-directory (args:get-arg "-start-dir")) (begin - (debug:print 0 "ERROR: non-existant start dir " (args:get-arg "-start-dir") " specified, exiting.") + (debug:print 0 #f "ERROR: non-existant start dir " (args:get-arg "-start-dir") " specified, exiting.") (exit 1)))) (if (args:get-arg "-version") (begin (print (common:version-signature)) ;; (print megatest-version) @@ -453,16 +453,16 @@ (if (debug:debug-mode 3) ;; we are obviously debugging (set! open-run-close open-run-close-no-exception-handling)) (if (args:get-arg "-itempatt") (let ((newval (conc (args:get-arg "-testpatt") "/" (args:get-arg "-itempatt")))) - (debug:print 0 "WARNING: -itempatt has been deprecated, please use -testpatt testpatt/itempatt method, new testpatt is "newval) + (debug:print 0 #f "WARNING: -itempatt has been deprecated, please use -testpatt testpatt/itempatt method, new testpatt is "newval) (hash-table-set! args:arg-hash "-testpatt" newval) (hash-table-delete! args:arg-hash "-itempatt"))) (if (args:get-arg "-runtests") - (debug:print 0 "WARNING: \"-runtests\" is deprecated. Use \"-run\" with \"-testpatt\" instead")) + (debug:print 0 #f "WARNING: \"-runtests\" is deprecated. Use \"-run\" with \"-testpatt\" instead")) (on-exit std-exit-procedure) ;;====================================================================== ;; Misc general calls @@ -481,22 +481,22 @@ (files (if (file-exists? runtop) (append (glob (conc runtop "/.megatest*")) (glob (conc runtop "/.runconfig*"))) '()))) (if (null? files) - (debug:print-info 0 "No cached megatest or runconfigs files found. None removed.") + (debug:print-info 0 #f "No cached megatest or runconfigs files found. None removed.") (begin - (debug:print-info 0 "Removing cached files:\n " (string-intersperse files "\n ")) + (debug:print-info 0 #f "Removing cached files:\n " (string-intersperse files "\n ")) (for-each (lambda (f) (handle-exceptions exn - (debug:print 0 "WARNING: Failed to remove file " f) + (debug:print 0 #f "WARNING: Failed to remove file " f) (delete-file f))) files)))) - (debug:print 0 "ERROR: -clean-cache requires -runname.")) - (debug:print 0 "ERROR: -clean-cache requires -target or -reqtarg")))) + (debug:print 0 #f "ERROR: -clean-cache requires -runname.")) + (debug:print 0 #f "ERROR: -clean-cache requires -target or -reqtarg")))) (if (args:get-arg "-env2file") (begin (save-environment-as-files (args:get-arg "-env2file")) @@ -549,11 +549,11 @@ (current-output-port))) (res-data (configf:read-refdb input-db)) (data (car res-data)) (msg (cadr res-data))) (if (not data) - (debug:print 0 "Bad input? data=" data) ;; some error occurred + (debug:print 0 #f "Bad input? data=" data) ;; some error occurred (with-output-to-port out-port (lambda () (case (string->symbol out-fmt) ((scheme)(pp data)) ((perl) @@ -709,11 +709,11 @@ (lambda () (env:print added removed changed))) (env:print added removed changed)) (env:close-database db) (set! *didsomething* #t)) - (debug:print 0 "ERROR: Parameter to -envdelta should be new=star-end"))))) + (debug:print 0 #f "ERROR: Parameter to -envdelta should be new=star-end"))))) ;;====================================================================== ;; Start the server - can be done in conjunction with -runall or -runtests (one day...) ;; we start the server if not running else start the client thread ;;====================================================================== @@ -727,11 +727,11 @@ (string->number (args:get-arg "-run-id"))))) (if run-id (begin (server:launch run-id) (set! *didsomething* #t)) - (debug:print 0 "ERROR: server requires run-id be specified with -run-id"))) + (debug:print 0 #f "ERROR: server requires run-id be specified with -run-id"))) ;; Not a server? This section will decide how to communicate ;; ;; Setup client for all expect listed here (if (null? (lset-intersection @@ -747,11 +747,11 @@ (string->number (args:get-arg "-run-id"))))) ;; (set! *fdb* (filedb:open-db (conc *toppath* "/db/paths.db"))) ;; if not list or kill then start a client (if appropriate) (if (or (args-defined? "-h" "-version" "-gen-megatest-area" "-gen-megatest-test") (eq? (length (hash-table-keys args:arg-hash)) 0)) - (debug:print-info 1 "Server connection not needed") + (debug:print-info 1 #f "Server connection not needed") (begin ;; (if run-id ;; (client:launch run-id) ;; (client:launch 0) ;; without run-id we'll start a server for "0" #t @@ -800,14 +800,14 @@ (format #t fmtstr id mt-ver pid hostname (conc interface ":" pullport) pubport last-update (if status "alive" "dead") transport) (if (or (equal? id sid) (equal? sid 0)) ;; kill all/any (begin - (debug:print-info 0 "Attempting to stop server with pid " pid) + (debug:print-info 0 #f "Attempting to stop server with pid " pid) (tasks:kill-server status hostname pullport pid transport))))) servers) - (debug:print-info 1 "Done with listservers") + (debug:print-info 1 #f "Done with listservers") (set! *didsomething* #t) (exit)) ;; must do, would have to add checks to many/all calls below (exit)))) ;;====================================================================== @@ -814,21 +814,21 @@ ;; Weird special calls that need to run *after* the server has started? ;;====================================================================== (if (args:get-arg "-list-targets") (let ((targets (common:get-runconfig-targets))) - (debug:print 1 "Found "(length targets) " targets") + (debug:print 1 #f "Found "(length targets) " targets") (case (string->symbol (or (args:get-arg "-dumpmode") "alist")) ((alist) (for-each (lambda (x) ;; (print "[" x "]")) (print x)) targets)) ((json) (json-write targets)) (else - (debug:print 0 "ERROR: dump output format " (args:get-arg "-dumpmode") " not supported for -list-targets"))) + (debug:print 0 #f "ERROR: 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) @@ -884,11 +884,11 @@ ((string=? (args:get-arg "-dumpmode") "json") (json-write data)) ((string=? (args:get-arg "-dumpmode") "ini") (configf:config->ini data)) (else - (debug:print 0 "ERROR: -dumpmode of " (args:get-arg "-dumpmode") " not recognised"))) + (debug:print 0 #f "ERROR: -dumpmode of " (args:get-arg "-dumpmode") " not recognised"))) (set! *didsomething* #t)) (pop-directory))) (if (args:get-arg "-show-config") (let ((tl (launch:setup)) @@ -908,11 +908,11 @@ ((string=? (args:get-arg "-dumpmode") "json") (json-write data)) ((string=? (args:get-arg "-dumpmode") "ini") (configf:config->ini data)) (else - (debug:print 0 "ERROR: -dumpmode of " (args:get-arg "-dumpmode") " not recognised"))) + (debug:print 0 #f "ERROR: -dumpmode of " (args:get-arg "-dumpmode") " not recognised"))) (set! *didsomething* #t) (pop-directory))) (if (args:get-arg "-show-cmdinfo") (if (or (args:get-arg ":value")(getenv "MT_CMDINFO")) @@ -919,11 +919,11 @@ (let ((data (common:read-encoded-string (or (args:get-arg ":value")(getenv "MT_CMDINFO"))))) (if (equal? (args:get-arg "-dumpmode") "json") (json-write data) (pp data)) (set! *didsomething* #t)) - (debug:print-info 0 "environment variable MT_CMDINFO is not set"))) + (debug:print-info 0 #f "environment variable MT_CMDINFO is not set"))) ;;====================================================================== ;; Remove old run(s) ;;====================================================================== @@ -932,23 +932,23 @@ (define (operate-on action) (let* ((runrec (runs:runrec-make-record)) (target (common:args-get-target))) (cond ((not target) - (debug:print 0 "ERROR: Missing required parameter for " action ", you must specify -target or -reqtarg") + (debug:print 0 #f "ERROR: Missing required parameter for " action ", you must specify -target or -reqtarg") (exit 1)) ((not (or (args:get-arg ":runname") (args:get-arg "-runname"))) - (debug:print 0 "ERROR: Missing required parameter for " action ", you must specify the run name pattern with -runname patt") + (debug:print 0 #f "ERROR: Missing required parameter for " action ", you must specify the run name pattern with -runname patt") (exit 2)) ((not (args:get-arg "-testpatt")) - (debug:print 0 "ERROR: Missing required parameter for " action ", you must specify the test pattern with -testpatt") + (debug:print 0 #f "ERROR: Missing required parameter for " action ", you must specify the test pattern with -testpatt") (exit 3)) (else (if (not (car *configinfo*)) (begin - (debug:print 0 "ERROR: Attempted " action "on test(s) but run area config file not found") + (debug:print 0 #f "ERROR: Attempted " action "on test(s) but run area config file not found") (exit 1)) ;; put test parameters into convenient variables (begin ;; check for correct version, exit with message if not correct (common:exit-on-version-changed) @@ -986,11 +986,11 @@ #f #f #f)) (header (vector-ref runsdat 0)) (rows (vector-ref runsdat 1))) (if (null? rows) (begin - (debug:print-info 0 "No matching run found.") + (debug:print-info 0 #f "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")) @@ -1086,11 +1086,11 @@ (tal (cdr adj-tests-spec)) (idx 0)) (hash-table-set! test-field-index hed idx) (if (not (null? tal))(loop (car tal)(cdr tal)(+ idx 1)))) (begin - (debug:print 0 "ERROR: Invalid test fields specified: " (string-intersperse invalid-tests-spec ", ")) + (debug:print 0 #f "ERROR: Invalid test fields specified: " (string-intersperse invalid-tests-spec ", ")) (exit))))) ;; Each run (for-each (lambda (run) @@ -1155,13 +1155,13 @@ (for-each (lambda (test) (handle-exceptions exn (begin - (debug:print 0 "ERROR: Bad data in test record? " test) + (debug:print 0 #f "ERROR: Bad data in test record? " test) (print "exn=" (condition->list exn)) - (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) + (debug:print 0 #f " message: " ((condition-property-accessor 'exn 'message) exn)) (print-call-chain (current-error-port))) (let* ((test-id (if (member "id" tests-spec)(get-value-by-fieldname test test-field-index "id" ) #f)) ;; (db:test-get-id test)) (testname (if (member "testname" tests-spec)(get-value-by-fieldname test test-field-index "testname" ) #f)) ;; (db:test-get-testname test)) (itempath (if (member "item_path" tests-spec)(get-value-by-fieldname test test-field-index "item_path" ) #f)) ;; (db:test-get-item-path test)) (comment (if (member "comment" tests-spec)(get-value-by-fieldname test test-field-index "comment" ) #f)) ;; (db:test-get-comment test)) @@ -1301,11 +1301,11 @@ (map (lambda (field) (let ((tmp (assoc field metadat))) (if tmp (cdr tmp) ""))) metadat-fields) (begin - (debug:print 0 "WARNING: meta data for run " runname " not found") + (debug:print 0 #f "WARNING: meta data for run " runname " not found") '())))) allrundat))) ;; '( ( "target" ( "runname" ( "data" ( "runid" ( "id . "37" ) ( ... )))) (run-pages (map (lambda (targdat) (let* ((target (car targdat)) @@ -1330,11 +1330,11 @@ (cons (conc target "/" runname) (cons (list (conc target "/" runname)) (cons '() (cons run-fields tests))))) (begin - (debug:print 0 "WARNING: run " target "/" runname " appears to have no data") + (debug:print 0 #f "WARNING: run " target "/" runname " appears to have no data") ;; (pp rundat) '())))) runsdat) '()))) newdat)) ;; we use newdat to get target @@ -1351,11 +1351,11 @@ (let* ((tempdir (conc "/tmp/" (current-user-name) "/" (random 10000) "_" (current-process-id))) (outputfile (or (args:get-arg "-o") "out.ods")) (ouf (if (string-match (regexp "^[/~]+.*") outputfile) ;; full path? outputfile (begin - (debug:print 0 "WARNING: path given, " outputfile " is relative, prefixing with current directory") + (debug:print 0 #f "WARNING: path given, " outputfile " is relative, prefixing with current directory") (conc (current-directory) "/" outputfile))))) (create-directory tempdir #t) (ods:list->ods tempdir ouf sheets)))) ;; (system (conc "rm -rf " tempdir)) (set! *didsomething* #t)))) @@ -1517,15 +1517,15 @@ (target (args:get-arg "-target")) (toppath (assoc/default 'toppath cmdinfo))) (change-directory toppath) (if (not target) (begin - (debug:print 0 "ERROR: -target is required.") + (debug:print 0 #f "ERROR: -target is required.") (exit 1))) (if (not (launch:setup)) (begin - (debug:print 0 "Failed to setup, giving up on -test-paths or -test-files, exiting") + (debug:print 0 #f "Failed to setup, giving up on -test-paths or -test-files, exiting") (exit 1))) (let* ((keys (rmt:get-keys)) ;; db:test-get-paths must not be run remote (paths (tests:test-get-paths-matching keys target (args:get-arg "-test-files")))) (set! *didsomething* #t) @@ -1568,11 +1568,11 @@ (let ((dbstruct (make-dbr:dbstruct path: *toppath* local: #t)) (outputfile (args:get-arg "-extract-ods")) (runspatt (or (args:get-arg "-runname")(args:get-arg ":runname"))) (pathmod (args:get-arg "-pathmod"))) ;; (keyvalalist (keys->alist keys "%"))) - (debug:print 2 "Extract ods, outputfile: " outputfile " runspatt: " runspatt " keyvals: " keyvals) + (debug:print 2 #f "Extract ods, outputfile: " outputfile " runspatt: " runspatt " keyvals: " keyvals) (db:extract-ods-file dbstruct outputfile keyvals (if runspatt runspatt "%") pathmod) (db:close-all dbstruct) (set! *didsomething* #t))))) ;;====================================================================== @@ -1601,21 +1601,21 @@ (if (and run-id test-id) (begin (launch:recover-test run-id test-id) (set! *didsomething* #t)) (begin - (debug:print 0 "ERROR: bad run-id or test-id, must be integers") + (debug:print 0 #f "ERROR: bad run-id or test-id, must be integers") (exit 1))))))) ;;====================================================================== ;; Test commands (i.e. for use inside tests) ;;====================================================================== (define (megatest:step step state status logfile msg) (if (not (getenv "MT_CMDINFO")) (begin - (debug:print 0 "ERROR: MT_CMDINFO env var not set, -step must be called *inside* a megatest invoked environment!") + (debug:print 0 #f "ERROR: MT_CMDINFO env var not set, -step must be called *inside* a megatest invoked environment!") (exit 5)) (let* ((cmdinfo (common:read-encoded-string (getenv "MT_CMDINFO"))) (transport (assoc/default 'transport cmdinfo)) (testpath (assoc/default 'testpath cmdinfo)) (test-name (assoc/default 'test-name cmdinfo)) @@ -1627,18 +1627,18 @@ (work-area (assoc/default 'work-area cmdinfo)) (db #f)) (change-directory testpath) (if (not (launch:setup)) (begin - (debug:print 0 "Failed to setup, exiting") + (debug:print 0 #f "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)) (begin - (debug:print 0 "ERROR: You must specify :state and :status with every call to -step") + (debug:print 0 #f "ERROR: You must specify :state and :status with every call to -step") (exit 6)))))) (if (args:get-arg "-step") (begin (megatest:step @@ -1659,11 +1659,11 @@ (args:get-arg "-load-test-data") (args:get-arg "-runstep") (args:get-arg "-summarize-items")) (if (not (getenv "MT_CMDINFO")) (begin - (debug:print 0 "ERROR: MT_CMDINFO env var not set, commands -test-status, -runstep and -setlog must be called *inside* a megatest environment!") + (debug:print 0 #f "ERROR: MT_CMDINFO env var not set, commands -test-status, -runstep and -setlog must be called *inside* a megatest environment!") (exit 5)) (let* ((startingdir (current-directory)) (cmdinfo (common:read-encoded-string (getenv "MT_CMDINFO"))) (transport (assoc/default 'transport cmdinfo)) (testpath (assoc/default 'testpath cmdinfo)) @@ -1678,14 +1678,14 @@ (state (args:get-arg ":state")) (status (args:get-arg ":status")) (stepname (args:get-arg "-step"))) (if (not (launch:setup)) (begin - (debug:print 0 "Failed to setup, exiting") + (debug:print 0 #f "Failed to setup, exiting") (exit 1))) - (if (args:get-arg "-runstep")(debug:print-info 1 "Running -runstep, first change to directory " work-area)) + (if (args:get-arg "-runstep")(debug:print-info 1 #f "Running -runstep, first change to directory " work-area)) (change-directory work-area) ;; can setup as client for server mode now ;; (client:setup) (if (args:get-arg "-load-test-data") @@ -1702,11 +1702,11 @@ ;; 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) (begin - (debug:print 0 "ERROR: nothing specified to run!") + (debug:print 0 #f "ERROR: nothing specified to run!") (if db (sqlite3:finalize! db)) (exit 6)) (let* ((stepname (args:get-arg "-runstep")) (logprofile (args:get-arg "-logpro")) (logfile (conc stepname ".log")) @@ -1725,21 +1725,21 @@ (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) ;; run the test step - (debug:print-info 2 "Running \"" fullcmd "\" in directory \"" startingdir) + (debug:print-info 2 #f "Running \"" fullcmd "\" in directory \"" startingdir) (change-directory startingdir) (set! exitstat (system fullcmd)) (set! *globalexitstatus* exitstat) ;; (change-directory testpath) ;; run logpro if applicable ;; (process-run "ls" (list "/foo" "2>&1" "blah.log")) (if logprofile (let* ((htmllogfile (conc stepname ".html")) (oldexitstat exitstat) (cmd (string-intersperse (list "logpro" logprofile htmllogfile "<" logfile ">" (conc stepname "_logpro.log")) " "))) - (debug:print-info 2 "running \"" cmd "\"") + (debug:print-info 2 #f "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))) @@ -1763,11 +1763,11 @@ res))) (if (and (args:get-arg "-test-status") (or (not state) (not status))) (begin - (debug:print 0 "ERROR: You must specify :state and :status with every call to -test-status\n" help) + (debug:print 0 #f "ERROR: You must specify :state and :status with every call to -test-status\n" help) (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 @@ -1783,20 +1783,20 @@ (args:get-arg "-show-keys")) (let ((db #f) (keys #f)) (if (not (launch:setup)) (begin - (debug:print 0 "Failed to setup, exiting") + (debug:print 0 #f "Failed to setup, exiting") (exit 1))) (set! keys (rmt:get-keys)) ;; db)) - (debug:print 1 "Keys: " (string-intersperse keys ", ")) + (debug:print 1 #f "Keys: " (string-intersperse keys ", ")) (if (sqlite3:database? db)(sqlite3:finalize! db)) (set! *didsomething* #t))) (if (args:get-arg "-gui") (begin - (debug:print 0 "Look at the dashboard for now") + (debug:print 0 #f "Look at the dashboard for now") ;; (megatest-gui) (set! *didsomething* #t))) (if (args:get-arg "-gen-megatest-area") (begin @@ -1814,42 +1814,30 @@ (if (args:get-arg "-rebuild-db") (begin (if (not (launch:setup)) (begin - (debug:print 0 "Failed to setup, exiting") + (debug:print 0 #f "Failed to setup, exiting") (exit 1))) ;; keep this one local (open-run-close patch-db #f) (set! *didsomething* #t))) (if (args:get-arg "-cleanup-db") (begin (if (not (launch:setup)) (begin - (debug:print 0 "Failed to setup, exiting") + (debug:print 0 #f "Failed to setup, exiting") (exit 1))) - ;; keep this one local - ;; (open-run-close db:clean-up #f) - (db:multi-db-sync - #f ;; do all run-ids - ;; 'new2old - 'killservers - 'dejunk - ;; 'adj-testids - ;; 'old2new - 'new2old - ) - (if (common:version-changed?) - (common:set-last-run-version)) + (common:cleanup-db) (set! *didsomething* #t))) (if (args:get-arg "-mark-incompletes") (begin (if (not (launch:setup)) (begin - (debug:print 0 "Failed to setup, exiting") + (debug:print 0 #f "Failed to setup, exiting") (exit 1))) (open-run-close db:find-and-mark-incomplete #f) (set! *didsomething* #t))) ;;====================================================================== @@ -1858,11 +1846,11 @@ (if (args:get-arg "-update-meta") (begin (if (not (launch:setup)) (begin - (debug:print 0 "Failed to setup, exiting") + (debug:print 0 #f "Failed to setup, exiting") (exit 1))) ;; now can find our db ;; keep this one local (open-run-close runs:update-all-test_meta #f) (set! *didsomething* #t))) @@ -1900,14 +1888,19 @@ ;; (import csi) (import readline) (import apropos) ;; (import (prefix sqlite3 sqlite3:)) ;; doesn't work ... (include "readline-fix.scm") - (gnu-history-install-file-manager - (string-append - (or (get-environment-variable "HOME") ".") "/.megatest_history")) - (current-input-port (make-gnu-readline-port "megatest> ")) + (if *use-new-readline* + (begin + (install-history-file (get-environment-variable "HOME") ".megatest_history") ;; [homedir] [filename] [nlines]) + (current-input-port (make-readline-port "megatest> "))) + (begin + (gnu-history-install-file-manager + (string-append + (or (get-environment-variable "HOME") ".") "/.megatest_history")) + (current-input-port (make-gnu-readline-port "megatest> ")))) (if (args:get-arg "-repl") (repl) (load (args:get-arg "-load"))) (db:close-all dbstruct)) (exit))) @@ -1921,11 +1914,11 @@ (not (or (args:get-arg "-run") (args:get-arg "-runtests")))) ;; run-wait is built into runtests now (begin (if (not (launch:setup)) (begin - (debug:print 0 "Failed to setup, exiting") + (debug:print 0 #f "Failed to setup, exiting") (exit 1))) (operate-on 'run-wait) (set! *didsomething* #t))) ;; ;; ;; redo me ;; Not converted to use dbstruct yet @@ -1934,24 +1927,24 @@ ;; ;; ;; redo me (let* ((toppath (setup-for-run)) ;; ;; ;; redo me (dbstruct (if toppath (make-dbr:dbstruct path: toppath local: #t)))) ;; ;; ;; redo me (for-each ;; ;; ;; redo me (lambda (field) ;; ;; ;; redo me (let ((dat '())) -;; ;; ;; redo me (debug:print-info 0 "Getting data for field " field) +;; ;; ;; redo me (debug:print-info 0 #f "Getting data for field " field) ;; ;; ;; redo me (sqlite3:for-each-row ;; ;; ;; redo me (lambda (id val) ;; ;; ;; redo me (set! dat (cons (list id val) dat))) ;; ;; ;; redo me (db:get-db db run-id) ;; ;; ;; redo me (conc "SELECT id," field " FROM tests;")) -;; ;; ;; redo me (debug:print-info 0 "found " (length dat) " items for field " field) +;; ;; ;; redo me (debug:print-info 0 #f "found " (length dat) " items for field " field) ;; ;; ;; redo me (let ((qry (sqlite3:prepare db (conc "UPDATE tests SET " field "=? WHERE id=?;")))) ;; ;; ;; redo me (for-each ;; ;; ;; redo me (lambda (item) ;; ;; ;; redo me (let ((newval ;; (sdb:qry 'getid ;; ;; ;; redo me (cadr item))) ;; ) ;; ;; ;; redo me (if (not (equal? newval (cadr item))) -;; ;; ;; redo me (debug:print-info 0 "Converting " (cadr item) " to " newval " for test #" (car item))) +;; ;; ;; redo me (debug:print-info 0 #f "Converting " (cadr item) " to " newval " for test #" (car item))) ;; ;; ;; redo me (sqlite3:execute qry newval (car item)))) ;; ;; ;; redo me dat) ;; ;; ;; redo me (sqlite3:finalize! qry)))) ;; ;; ;; redo me (db:close-all dbstruct) ;; ;; ;; redo me (list "uname" "rundir" "final_logf" "comment")) @@ -1982,20 +1975,20 @@ ;;====================================================================== (if *runremote* (close-all-connections!)) (if (not *didsomething*) - (debug:print 0 help)) + (debug:print 0 #f help)) (set! *time-to-exit* #t) (thread-join! *watchdog*) (if (not (eq? *globalexitstatus* 0)) (if (or (args:get-arg "-run")(args:get-arg "-runtests")(args:get-arg "-runall")) (begin - (debug:print 0 "NOTE: Subprocesses with non-zero exit code detected: " *globalexitstatus*) + (debug:print 0 #f "NOTE: Subprocesses with non-zero exit code detected: " *globalexitstatus*) (exit 0)) (case *globalexitstatus* ((0)(exit 0)) ((1)(exit 1)) ((2)(exit 2)) (else (exit 3))))) Index: mt.scm ================================================================== --- mt.scm +++ mt.scm @@ -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 #f "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 #f "More than " limit " runs, have " (length full-list) " runs so far.") + (debug:print-info 0 #f "next-batch: " next-batch) (loop next-batch full-list new-offset limit)) (vector header full-list))))) @@ -75,11 +75,11 @@ (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.") + (debug:print-info 4 #f "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 #f "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 #f "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 #f "Discarding test " testn "(" test-dat ") due to " failed-test) res) (cons testn res))))))))) ;;====================================================================== ;; T R I G G E R S @@ -156,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 #f "TRIGGERED on " trigger ", running command " fullcmd) (process-run fullcmd))))) (list (conc state "/" status) (conc state "/") (conc "/" status))) @@ -173,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 0 #f "ERROR: 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) @@ -215,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 0 #f "ERROR: No readable testconfig found for " test-name) #f) (loop (car tal)(cdr tal)))))))))) Index: multi-dboard.scm ================================================================== --- multi-dboard.scm +++ multi-dboard.scm @@ -212,11 +212,11 @@ (else (conc run-id ".db"))) #f))) (handle-exceptions exn (begin - (debug:print 0 "ERROR: Couldn't create path to " dbdir) + (debug:print 0 #f "ERROR: Couldn't create path to " dbdir) (exit 1)) (if (not (directory? dbdir))(create-directory dbdir #t))) (if fname (conc dbdir "/" fname) dbdir))) @@ -240,11 +240,11 @@ db ;; merely return the already opened db (let* ((dbfile (areadb:dbfile-path areadat run-id)) ;; not already opened, so open it (db (if (file-exists? dbfile) (open-database dbfile) (begin - (debug:print 0 "ERROR: I was asked to open " dbfile ", but file does not exist or is not readable.") + (debug:print 0 #f "ERROR: I was asked to open " dbfile ", but file does not exist or is not readable.") #f)))) (case run-id ((-1)(areadat-monitordb-set! areadat db)) ((0) (areadat-maindb-set! areadat db)) (else (rundat-db-set! rundat db))) @@ -263,11 +263,11 @@ (print row) (hash-table-set! runs id dat)))) (sql maindb (conc "SELECT id," (string-intersperse keys "||'/'||") ",runname,state,status,event_time FROM runs WHERE state != 'deleted';"))) - (debug:print 0 "ERROR: no main.db found at " (areadb:dbfile-path areadat 0))) + (debug:print 0 #f "ERROR: no main.db found at " (areadb:dbfile-path areadat 0))) areadat)) ;; given an areadat and target/runname patt fill up runs data ;; ;; ?????/ @@ -323,15 +323,15 @@ (current-matrix (if (null? tab-ids) #f (tab-matrix current-tab))) (seen-nodes (make-hash-table)) (path-changed (if current-tab (equal? current-path (tab-view-path current-tab)) #t))) - ;; (debug:print-info 0 "Current path: " current-path) + ;; (debug:print-info 0 #f "Current path: " current-path) ;; now for each area in the window gather the data (if path-changed (begin - (debug:print-info 0 "clearing matrix - path changed") + (debug:print-info 0 #f "clearing matrix - path changed") (dboard:clear-matrix current-tab))) (for-each (lambda (area-name) ;; (print "Processing for area-name " area-name) (let* ((area-dat (hash-table-ref areas area-name)) @@ -485,11 +485,11 @@ (used-rows (hash-table-values rows)) (touched (make-hash-table)) ;; (vector row col) ==> true, touched cell (view-type (dboard:get-view-type keys current-path)) (changed #f) (state-statuses (list "PASS" "FAIL" "WARN" "CHECK" "SKIP" "RUNNING" "LAUNCHED"))) - ;; (debug:print 0 "current-matrix=" current-matrix) + ;; (debug:print 0 #f "current-matrix=" current-matrix) (case view-type ((areas) ;; find row for this area, if not found, create new entry (let* ((curr-rownum (hash-table-ref/default rows area-name #f)) (next-rownum (+ (apply max (cons 0 used-rows)) 1)) (rownum (or curr-rownum next-rownum)) @@ -503,11 +503,11 @@ (if (not (equal? (iup:attribute current-matrix (conc "0:" count)) hed)) (iup:attribute-set! current-matrix (conc "0:" count) hed)) (iup:attribute-set! current-matrix (conc rownum ":" count) "0") (if (not (null? tal)) (loop (car tal)(cdr tal)(+ count 1)))) - (debug:print-info 0 "view-type=" view-type ", rownum=" rownum ", curr-rownum=" curr-rownum ", next-rownum=" next-rownum ", coord=" coord ", area-name=" area-name) + (debug:print-info 0 #f "view-type=" view-type ", rownum=" rownum ", curr-rownum=" curr-rownum ", next-rownum=" next-rownum ", coord=" coord ", area-name=" area-name) (iup:attribute-set! current-matrix coord area-name) (set! changed #t)))))) (if changed (iup:attribute-set! current-matrix "REDRAW" "ALL")))) @@ -573,11 +573,11 @@ (if (not (null? area-names)) (let loop ((index 0) (hed (car area-names)) (tal (cdr area-names))) ;; (hash-table-set! tabs index hed) - (debug:print 0 "Adding area " hed " with index " index " to dashboard") + (debug:print 0 #f "Adding area " hed " with index " index " to dashboard") (iup:attribute-set! tabtop (conc "TABTITLE" index) hed) (if (not (null? tal)) (loop (+ index 1)(car tal)(cdr tal))))) tabtop)))) @@ -730,21 +730,21 @@ toppath: (or (get-environment-variable "MT_RUN_AREA_HOME")(current-directory)))) (curr-mtcfg (if (and curr-mtcfgdat (not (null? curr-mtcfgdat)))(cadr curr-mtcfgdat) #f)) (curr-mtpath (if curr-mtcfg (car curr-mtcfgdat) #f))) (if curr-mtpath (begin - (debug:print-info 0 "Creating config file " fname) + (debug:print-info 0 #f "Creating config file " fname) (if (not (file-exists? dirname)) (create-directory dirname #t)) (with-output-to-file fname (lambda () (let ((aname (pathname-strip-directory curr-mtpath))) (print "[" aname "]") (print "path " curr-mtpath)))) #t) (begin - (debug:print-info 0 "Need to create a config but no megatest.config found: " curr-mtcfgdat) + (debug:print-info 0 #f "Need to create a config but no megatest.config found: " curr-mtcfgdat) #f)))) ;; ) (define (dboard:read-mtconf apath) (let* ((mtconffile (conc apath "/megatest.config"))) Index: newdashboard.scm ================================================================== --- newdashboard.scm +++ newdashboard.scm @@ -625,11 +625,11 @@ (if (< nextmintime (current-milliseconds)) (let* ((starttime (current-milliseconds)) (changes (dcommon:run-update keys data runname keypatts testpatt states statuses 'full my-window-id)) (endtime (current-milliseconds))) (set! nextmintime (+ endtime (* 2 (- endtime starttime)))) - (debug:print 11 "CHANGE(S): " (car changes) "...")) - (debug:print-info 11 "Server overloaded")))))) + (debug:print 11 #f "CHANGE(S): " (car changes) "...")) + (debug:print-info 11 #f "Server overloaded")))))) (dboard:data-set-updaters! *data* (make-hash-table)) (newdashboard *dbstruct-local*) (iup:main-loop) Index: nmsg-transport.scm ================================================================== --- nmsg-transport.scm +++ nmsg-transport.scm @@ -62,11 +62,11 @@ ;;====================================================================== ;; S E R V E R ;;====================================================================== (define (nmsg-transport:run dbstruct hostn run-id server-id #!key (retrynum 1000)) - (debug:print 2 "Attempting to start the server ...") + (debug:print 2 #f "Attempting to start the server ...") (let* ((start-port (portlogger:open-run-close portlogger:find-port)) (server-thread (make-thread (lambda () (nmsg-transport:try-start-server dbstruct run-id start-port server-id)) "server thread")) (tdbdat (tasks:open-db))) @@ -84,26 +84,26 @@ (lambda ()(nmsg-transport:keep-running server-id run-id)) "keep running")) (thread-join! server-thread)) (if (> retrynum 0) (begin - (debug:print 0 "WARNING: Failed to connect to server (self) on host " hostn ":" start-port ", trying again.") + (debug:print 0 #f "WARNING: Failed to connect to server (self) on host " hostn ":" start-port ", trying again.") (tasks:server-delete-record (db:delay-if-busy tdbdat) server-id "failed to start, never received server alive signature") (portlogger:open-run-close portlogger:set-failed start-port) (nmsg-transport:run dbstruct hostn run-id server-id)) (begin - (debug:print 0 "ERROR: could not find an open port to start server on. Giving up") + (debug:print 0 #f "ERROR: could not find an open port to start server on. Giving up") (exit 1)))))) (define (nmsg-transport:try-start-server dbstruct run-id portnum server-id) (let ((repsoc (nn-socket 'rep))) (nn-bind repsoc (conc "tcp://*:" portnum)) (let loop ((msg-in (nn-recv repsoc))) (let* ((dat (db:string->obj msg-in transport: 'nmsg))) - (debug:print 0 "server, received: " dat) + (debug:print 0 #f "server, received: " dat) (let ((result (api:execute-requests dbstruct dat))) - (debug:print 0 "server, sending: " result) + (debug:print 0 #f "server, sending: " result) (nn-send repsoc (db:obj->string result transport: 'nmsg))) (loop (nn-recv repsoc)))))) ;; all routes though here end in exit ... ;; @@ -122,11 +122,11 @@ ;; (begin ;; (current-error-port *alt-log-file*) ;; (current-output-port *alt-log-file*))))) (if (server:check-if-running run-id) (begin - (debug:print-info 0 "Server for run-id " run-id " already running") + (debug:print-info 0 #f "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)) (if (not server-id) (if (> remtries 0) @@ -134,15 +134,15 @@ (thread-sleep! 2) (if (not (server:check-if-running run-id)) (loop (tasks:server-lock-slot (db:delay-if-busy tdbdat) run-id) (- remtries 1)) (begin - (debug:print-info 0 "Another server took the slot, exiting") + (debug:print-info 0 #f "Another server took the slot, exiting") (exit 0)))) (begin ;; since we didn't get the server lock we are going to clean up and bail out - (debug:print-info 2 "INFO: server pid=" (current-process-id) ", hostname=" (get-host-name) " not starting due to other candidates ahead in start queue") + (debug:print-info 2 #f "INFO: server pid=" (current-process-id) ", hostname=" (get-host-name) " not starting due to other candidates ahead in start queue") (tasks:server-delete-records-for-this-pid (db:delay-if-busy tdbdat) " http-transport:launch") )) ;; locked in a server id, try to start up (nmsg-transport:run dbstruct hostn run-id server-id)) (set! *didsomething* #t) @@ -184,11 +184,11 @@ (nmsg-transport:client-api-send-receive-raw req dat timeout: timeout) ((timeout)(set! success #f) #f))) (key (if success (vector-ref result 1) #f))) - (debug:print 0 "success=" success ", key=" key ", expected-key=" expected-key ", equal? " (equal? key expected-key)) + (debug:print 0 #f "success=" success ", key=" key ", expected-key=" expected-key ", equal? " (equal? key expected-key)) (if (and success (or (not expected-key) ;; just getting a reply is good enough then (equal? key expected-key))) (if return-socket req @@ -218,11 +218,11 @@ "send-recv")) (timeout (make-thread (lambda () (let loop ((count 0)) (thread-sleep! 1) - (debug:print-info 1 "send-receive-raw, still waiting after " count " seconds...") + (debug:print-info 1 #f "send-receive-raw, still waiting after " count " seconds...") (if (and keepwaiting (< count timeout)) ;; yes, this is very aproximate (loop (+ count 1)))) (if keepwaiting (begin (print "timeout waiting for ping") @@ -240,14 +240,14 @@ (if success (if (and (vector? result) (vector-ref result 0)) ;; did it fail at the server? result ;; nope, all good (begin - (debug:print 0 "ERROR: error occured at server, info=" (vector-ref result 2)) - (debug:print 0 " client call chain:") + (debug:print 0 #f "ERROR: error occured at server, info=" (vector-ref result 2)) + (debug:print 0 #f " client call chain:") (print-call-chain (current-error-port)) - (debug:print 0 " server call chain:") + (debug:print 0 #f " server call chain:") (pp (vector-ref result 1) (current-error-port)) (signal (vector-ref result 0)))) (signal (make-composite-condition (make-property-condition 'timeout 'message "nmsg-transport:client-api-send-receive-raw timed out talking to server")))))) @@ -263,11 +263,11 @@ (mutex-lock! *heartbeat-mutex*) (set! sdat *server-info*) (mutex-unlock! *heartbeat-mutex*) (if sdat (begin - (debug:print-info 0 "keep-running got sdat=" sdat) + (debug:print-info 0 #f "keep-running got sdat=" sdat) sdat) (begin (thread-sleep! 0.5) (loop)))))) (iface (car server-info)) @@ -297,18 +297,18 @@ (db:sync-touched *inmemdb* run-id force-sync: #t) (if (and *server-run* (> (+ last-access server-timeout) (current-seconds))) (begin - (debug:print-info 0 "Server continuing, seconds since last db access: " (- (current-seconds) last-access)) + (debug:print-info 0 #f "Server continuing, seconds since last db access: " (- (current-seconds) last-access)) (loop 0)) (begin - (debug:print-info 0 "Starting to shutdown the server.") + (debug:print-info 0 #f "Starting to shutdown the server.") (set! *time-to-exit* #t) (db:sync-touched *inmemdb* run-id force-sync: #t) (tasks:server-delete-record (db:delay-if-busy tdbdat) server-id " http-transport:keep-running") - (debug:print-info 0 "Server shutdown complete. Exiting") + (debug:print-info 0 #f "Server shutdown complete. Exiting") (exit) )))))) ;;====================================================================== ;; C L I E N T S @@ -339,20 +339,20 @@ ;; DO NOT USE ;; (define (nmsg-transport:client-signal-handler signum) (handle-exceptions exn - (debug:print " ... exiting ...") + (debug:print 0 #f " ... exiting ...") (let ((th1 (make-thread (lambda () (if (not *received-response*) (receive-message* *runremote*))) ;; flush out last call if applicable "eat response")) (th2 (make-thread (lambda () - (debug:print 0 "ERROR: Received ^C, attempting clean exit. Please be patient and wait a few seconds before hitting ^C again.") + (debug:print 0 #f "ERROR: Received ^C, attempting clean exit. Please be patient and wait a few seconds before hitting ^C again.") (thread-sleep! 3) ;; give the flush three seconds to do it's stuff - (debug:print 0 " Done.") + (debug:print 0 #f " Done.") (exit 4)) "exit on ^C timer"))) (thread-start! th2) (thread-start! th1) (thread-join! th2)))) Index: portlogger.scm ================================================================== --- portlogger.scm +++ portlogger.scm @@ -54,13 +54,13 @@ (avail (tasks:wait-on-journal fname 10))) ;; wait up to about 10 seconds for the journal to go away (handle-exceptions exn (begin ;; (release-dot-lock fname) - (debug:print 0 "ERROR: portlogger:open-run-close failed. " proc " " params) - (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) - (debug:print 0 "exn=" (condition->list exn)) + (debug:print 0 #f "ERROR: portlogger:open-run-close failed. " proc " " params) + (debug:print 0 #f " message: " ((condition-property-accessor 'exn 'message) exn)) + (debug:print 0 #f "exn=" (condition->list exn)) (if (file-exists? fname)(delete-file fname)) ;; brutally get rid of it (print-call-chain (current-error-port))) (let* (;; (lock (obtain-dot-lock fname 2 9 10)) (db (portlogger:open-db fname)) (res (apply proc db params))) @@ -101,15 +101,15 @@ (define (portlogger:get-prev-used-port db) (handle-exceptions exn (begin - (debug:print 0 "EXCEPTION: portlogger database probably overloaded or unreadable. If you see this message again remove /tmp/.$USER-portlogger.db") - (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) - (debug:print 0 "exn=" (condition->list exn)) + (debug:print 0 #f "EXCEPTION: portlogger database probably overloaded or unreadable. If you see this message again remove /tmp/.$USER-portlogger.db") + (debug:print 0 #f " message: " ((condition-property-accessor 'exn 'message) exn)) + (debug:print 0 #f "exn=" (condition->list exn)) (print-call-chain (current-error-port)) - (debug:print 0 "Continuing anyway.") + (debug:print 0 #f "Continuing anyway.") #f) (sqlite3:fold-row (lambda (var curr) (or curr var curr)) #f @@ -126,15 +126,15 @@ (+ lowport ;; top of registered ports is 49152 but lets use ports in the registered range (random (- 64000 lowport)))))) (handle-exceptions exn (begin - (debug:print 0 "EXCEPTION: portlogger database probably overloaded or unreadable. If you see this message again remove /tmp/.$USER-portlogger.db") - (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) - (debug:print 0 "exn=" (condition->list exn)) + (debug:print 0 #f "EXCEPTION: portlogger database probably overloaded or unreadable. If you see this message again remove /tmp/.$USER-portlogger.db") + (debug:print 0 #f " message: " ((condition-property-accessor 'exn 'message) exn)) + (debug:print 0 #f "exn=" (condition->list exn)) (print-call-chain (current-error-port)) - (debug:print 0 "Continuing anyway.")) + (debug:print 0 #f "Continuing anyway.")) (portlogger:take-port db portnum)) portnum)) ;; set port to "released", "failed" etc. ;; @@ -156,14 +156,14 @@ (numargs (length args)) (result (handle-exceptions exn (begin - (debug:print 0 "EXCEPTION: portlogger database at " dbfname " probably overloaded or unreadable. Try removing it.") - (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) + (debug:print 0 #f "EXCEPTION: portlogger database at " dbfname " probably overloaded or unreadable. Try removing it.") + (debug:print 0 #f " message: " ((condition-property-accessor 'exn 'message) exn)) (print "exn=" (condition->list exn)) - (debug:print 0 " status: " ((condition-property-accessor 'sqlite3 'status) exn)) + (debug:print 0 #f " status: " ((condition-property-accessor 'sqlite3 'status) exn)) (print-call-chain (current-error-port)) #f) (case (string->symbol (car args)) ;; commands with two or more params ((take)(portlogger:take-port db (string->number (cadr args)))) ((find)(portlogger:find-port db)) Index: process.scm ================================================================== --- process.scm +++ process.scm @@ -52,11 +52,11 @@ ;; (print "Called with cmd=" cmd ", proc=" proc ", params=" params) (handle-exceptions exn (begin (print "ERROR: Failed to run command: " cmd " " (string-intersperse params " ")) - (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) + (debug:print 0 #f " message: " ((condition-property-accessor 'exn 'message) exn)) (print "exn=" (condition->list exn)) #f) (let-values (((fh fho pid) (if (null? params) (process cmd) (process cmd params)))) @@ -104,11 +104,11 @@ ;; here is an example line where the shell is sh or bash ;; "find / -print 2&>1 > findall.log" (define (run-n-wait cmdline #!key (params #f)(print-cmd #f)) (if print-cmd - (debug:print 0 + (debug:print 0 #f (if (string? print-cmd) print-cmd "") cmdline (if params Index: rmt.scm ================================================================== --- rmt.scm +++ rmt.scm @@ -53,11 +53,11 @@ (max (- (current-seconds) start) 1)))) (vector-set! record 1 count) (if (and (> count 10) (> queries-per-second 10)) (begin - (debug:print-info 1 "db write rate too high, starting a server, count=" count " start=" start " run-id=" run-id " queries-per-second=" queries-per-second) + (debug:print-info 1 #f "db write rate too high, starting a server, count=" count " start=" start " run-id=" run-id " queries-per-second=" queries-per-second) #t) #f)))) ;; 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 @@ -81,11 +81,11 @@ (lambda (run-id) (let ((connection (hash-table-ref/default *runremote* run-id #f))) (if (and (vector? connection) (< (http-transport:server-dat-get-last-access connection) expire-time)) (begin - (debug:print-info 0 "Discarding connection to server for run-id " run-id ", too long between accesses") + (debug:print-info 0 #f "Discarding connection to server for run-id " run-id ", too long between accesses") ;; SHOULD CLOSE THE CONNECTION HERE (case *transport-type* ((nmsg)(nn-close (http-transport:server-dat-get-socket (hash-table-ref *runremote* run-id))))) (hash-table-delete! *runremote* run-id))))) @@ -114,11 +114,11 @@ ;; (mutex-unlock! *send-receive-mutex*) (case *transport-type* ((http) res) ;; (db:string->obj res)) ((nmsg) res))) ;; (vector-ref res 1))) (begin ;; let ((new-connection-info (client:setup run-id))) - (debug:print 0 "WARNING: Communication failed, trying call to rmt:send-receive again.") + (debug:print 0 #f "WARNING: Communication failed, trying call to rmt:send-receive again.") ;; (case *transport-type* ;; ((nmsg)(nn-close (http-transport:server-dat-get-socket connection-info)))) (hash-table-delete! *runremote* run-id) ;; don't keep using the same connection ;; NOTE: killing server causes this process to block forever. No idea why. Dec 2. ;; (if (eq? (modulo attemptnum 5) 0) @@ -153,17 +153,17 @@ "300"))) (newres (rmt:open-qry-close-locally cmd run-id params))) (let ((delta (- (current-milliseconds) start-time))) (if (> delta max-query) (begin - (debug:print-info 0 "Starting server as query time " delta " is over the limit of " max-query) + (debug:print-info 0 #f "Starting server as query time " delta " is over the limit of " max-query) (server:kind-run run-id))) ;; return the result! newres) ))) (begin - ;; (debug:print 0 "ERROR: Communication failed!") + ;; (debug:print 0 #f "ERROR: Communication failed!") ;; (mutex-unlock! *send-receive-mutex*) ;; (exit) (rmt:open-qry-close-locally cmd run-id params) ))))) @@ -170,12 +170,12 @@ (define (rmt:update-db-stats run-id rawcmd params duration) (mutex-lock! *db-stats-mutex*) (handle-exceptions exn (begin - (debug:print 0 "WARNING: stats collection failed in update-db-stats") - (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) + (debug:print 0 #f "WARNING: stats collection failed in update-db-stats") + (debug:print 0 #f " message: " ((condition-property-accessor 'exn 'message) exn)) (print "exn=" (condition->list exn)) #f) ;; if this fails we don't care, it is just stats (let* ((cmd (conc "run-id=" run-id " " (if (eq? rawcmd 'general-call) (car params) rawcmd))) (stat-vec (hash-table-ref/default *db-stats* cmd #f))) (if (not (vector? stat-vec)) @@ -187,15 +187,15 @@ (mutex-unlock! *db-stats-mutex*)) (define (rmt:print-db-stats) (let ((fmtstr "~40a~7-d~9-d~20,2-f")) ;; "~20,2-f" - (debug:print 18 "DB Stats\n========") - (debug:print 18 (format #f "~40a~8a~10a~10a" "Cmd" "Count" "TotTime" "Avg")) + (debug:print 18 #f "DB Stats\n========") + (debug:print 18 #f (format #f "~40a~8a~10a~10a" "Cmd" "Count" "TotTime" "Avg")) (for-each (lambda (cmd) (let ((cmd-dat (hash-table-ref *db-stats* cmd))) - (debug:print 18 (format #f fmtstr cmd (vector-ref cmd-dat 0) (vector-ref cmd-dat 1) (/ (vector-ref cmd-dat 1)(vector-ref cmd-dat 0)))))) + (debug:print 18 #f (format #f fmtstr cmd (vector-ref cmd-dat 0) (vector-ref cmd-dat 1) (/ (vector-ref cmd-dat 1)(vector-ref cmd-dat 0)))))) (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))))))) @@ -239,15 +239,15 @@ (res (vector-ref resdat 1)) (duration (- (current-milliseconds) start))) (if (not success) (if (> remretries 0) (begin - (debug:print 0 "ERROR: local query failed. Trying again.") + (debug:print 0 #f "ERROR: 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))) (begin - (debug:print 0 "ERROR: too many retries in rmt:open-qry-close-locally, giving up") + (debug:print 0 #f "ERROR: too many retries in rmt:open-qry-close-locally, giving up") #f)) (begin ;; (rmt:update-db-stats run-id cmd params duration) ;; mark this run as dirty if this was a write (if (not (member cmd api:read-only-queries)) @@ -270,11 +270,11 @@ (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))) ;; (db:string->obj (vector-ref dat 1)) ;; (begin -;; (debug:print 0 "ERROR: rmt:send-receive-no-auto-client-setup failed, attempting to continue. Got " dat) +;; (debug:print 0 #f "ERROR: rmt:send-receive-no-auto-client-setup failed, attempting to continue. Got " dat) ;; dat)))) ;; Wrap json library for strings (why the ports crap in the first place?) (define (rmt:dat->json-str dat) (with-output-to-string @@ -365,11 +365,11 @@ (define (rmt:get-test-info-by-id 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)) (begin - (debug:print 0 "WARNING: Bad data handed to rmt:get-test-info-by-id run-id=" run-id ", test-id=" test-id) + (debug:print 0 #f "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))) @@ -376,11 +376,11 @@ (define (rmt:open-test-db-by-test-id 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)))) - (debug:print 3 "TEST PATH: " test-path) + (debug:print 3 #f "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))) @@ -390,11 +390,11 @@ (define (rmt:get-tests-for-run 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)) (begin - (debug:print "ERROR: rmt:get-tests-for-run called with bad run-id=" run-id) + (debug:print 0 #f "ERROR: 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) @@ -421,11 +421,11 @@ (if (list? res) (begin (mutex-lock! multi-run-mutex) (set! result (append result res)) (mutex-unlock! multi-run-mutex)) - (debug:print 0 "ERROR: get-tests-for-run-mindata failed for run-id " hed ", testpatt " testpatt ", states " states ", status " status ", not-in " not-in)))) + (debug:print 0 #f "ERROR: get-tests-for-run-mindata failed for run-id " hed ", testpatt " testpatt ", states " states ", status " status ", not-in " not-in)))) (conc "multi-run-thread for run-id " hed))) (newthreads (cons newthread threads))) (thread-start! newthread) (thread-sleep! 0.05) ;; give that thread some time to start (if (null? tal) @@ -615,16 +615,16 @@ (if (not keyvals) #f (let ((prev-run-ids (rmt:get-prev-run-ids 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 "selstr: " selstr ", qrystr: " qrystr ", keyvals: " keyvals ", previous run ids found: " prev-run-ids) + (debug:print 4 #f "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) '() '() #f #f #f #f #f #f #f 'normal))) - (debug:print 4 "Got tests for run-id " run-id ", test-name " test-name ", item-path " item-path ": " results) + (debug:print 4 #f "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)))))))))) @@ -647,11 +647,11 @@ (define (rmt:teststep-set-status! 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 "WARNING: Invalid " (if status "status" "state") + (debug:print 3 #f "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)))) (define (rmt:get-steps-for-test run-id test-id) (rmt:send-receive 'get-steps-for-test run-id (list run-id test-id))) Index: rpc-transport.scm ================================================================== --- rpc-transport.scm +++ rpc-transport.scm @@ -27,11 +27,11 @@ ;; procstr is the name of the procedure to be called as a string (define (rpc-transport:autoremote procstr params) (handle-exceptions exn (begin - (debug:print 1 "Remote failed for " proc " " params) + (debug:print 1 #f "Remote failed for " proc " " params) (apply (eval (string->symbol procstr)) params)) ;; (if *runremote* ;; (apply (eval (string->symbol (conc "remote:" procstr))) params) (apply (eval (string->symbol procstr)) params))) @@ -43,11 +43,11 @@ (set! *run-id* run-id) (if (args:get-arg "-daemonize") (daemon:ize)) (if (server:check-if-running run-id) (begin - (debug:print 0 "INFO: Server for run-id " run-id " already running") + (debug:print 0 #f "INFO: Server for run-id " run-id " already running") (exit 0))) (let loop ((server-id (open-run-close tasks:server-lock-slot tasks:open-db run-id)) (remtries 4)) (if (not server-id) (if (> remtries 0) @@ -55,18 +55,18 @@ (thread-sleep! 2) (loop (open-run-close tasks:server-lock-slot tasks:open-db run-id) (- remtries 1))) (begin ;; since we didn't get the server lock we are going to clean up and bail out - (debug:print-info 2 "INFO: server pid=" (current-process-id) ", hostname=" (get-host-name) " not starting due to other candidates ahead in start queue") + (debug:print-info 2 #f "INFO: server pid=" (current-process-id) ", hostname=" (get-host-name) " not starting due to other candidates ahead in start queue") (open-run-close tasks:server-delete-records-for-this-pid tasks:open-db " rpc-transport:launch"))) (begin (rpc-transport:run (if (args:get-arg "-server")(args:get-arg "-server") "-") run-id server-id) (exit))))) (define (rpc-transport:run hostn run-id server-id) - (debug:print 2 "Attempting to start the rpc server ...") + (debug:print 2 #f "Attempting to start the rpc server ...") ;; (trace rpc:publish-procedure!) (rpc:publish-procedure! 'server:login server:login) (rpc:publish-procedure! 'testing (lambda () "Just testing")) @@ -99,11 +99,11 @@ (set! db *inmemdb*) (open-run-close tasks:server-set-interface-port tasks:open-db server-id ipaddrstr portnum) - (debug:print 0 "Server started on " host:port) + (debug:print 0 #f "Server started on " host:port) ;; (trace rpc:publish-procedure!) ;; (rpc:publish-procedure! 'server:login server:login) ;; (rpc:publish-procedure! 'testing (lambda () "Just testing")) @@ -123,18 +123,18 @@ (thread-sleep! 5) ;; no need to do this very often (let ((numrunning -1)) ;; (db:get-count-tests-running db))) (if (or (> numrunning 0) (> (+ *last-db-access* 60)(current-seconds))) (begin - (debug:print-info 0 "Server continuing, tests running: " numrunning ", seconds since last db access: " (- (current-seconds) *last-db-access*)) + (debug:print-info 0 #f "Server continuing, tests running: " numrunning ", seconds since last db access: " (- (current-seconds) *last-db-access*)) (loop (+ 1 count))) (begin - (debug:print-info 0 "Starting to shutdown the server side") + (debug:print-info 0 #f "Starting to shutdown the server side") (open-run-close tasks:server-delete-record tasks:open-db server-id " rpc-transport:try-start-server stop") (thread-sleep! 10) - (debug:print-info 0 "Max cached queries was " *max-cache-size*) - (debug:print-info 0 "Server shutdown complete. Exiting") + (debug:print-info 0 #f "Max cached queries was " *max-cache-size*) + (debug:print-info 0 #f "Server shutdown complete. Exiting") )))))) (define (rpc-transport:find-free-port-and-open port) (handle-exceptions exn @@ -162,11 +162,11 @@ (exit 1)))))) (define (rpc-transport:client-setup run-id #!key (remtries 10)) (if *runremote* (begin - (debug:print 0 "ERROR: Attempt to connect to server but already connected") + (debug:print 0 #f "ERROR: Attempt to connect to server but already connected") #f) (let* ((host-info (hash-table-ref/default *runremote* run-id #f))) ;; (open-run-close db:get-var #f "SERVER")) (if host-info (let ((iface (car host-info)) (port (cadr host-info)) @@ -178,11 +178,11 @@ (begin (server:try-running run-id) (thread-sleep! 2) (rpc-transport:client-setup run-id (- remtries 1))))) (let* ((server-db-info (open-run-close tasks:get-server tasks:open-db run-id))) - (debug:print-info 0 "client:setup server-dat=" server-dat ", remaining-tries=" remaining-tries) + (debug:print-info 0 #f "client:setup server-dat=" server-dat ", remaining-tries=" remaining-tries) (if server-db-info (let* ((iface (tasks:hostinfo-get-interface server-db-info)) (port (tasks:hostinfo-get-port server-db-info)) (server-dat (list iface port #f #f #f)) (ping-res ((rpc:procedure 'server:login host port) *toppath*))) @@ -201,26 +201,26 @@ ;; ;; (port (if (and hostinfo (> (length hostdat) 1))(cadr hostdat) #f))) ;; (if (and port ;; (string->number port)) ;; (let ((portn (string->number port))) -;; (debug:print-info 2 "Setting up to connect to host " host ":" port) +;; (debug:print-info 2 #f "Setting up to connect to host " host ":" port) ;; (handle-exceptions ;; exn ;; (begin -;; (debug:print 0 "ERROR: Failed to open a connection to the server at host: " host " port: " port) -;; (debug:print 0 " EXCEPTION: " ((condition-property-accessor 'exn 'message) exn)) +;; (debug:print 0 #f "ERROR: Failed to open a connection to the server at host: " host " port: " port) +;; (debug:print 0 #f " EXCEPTION: " ((condition-property-accessor 'exn 'message) exn)) ;; ;; (open-run-close ;; ;; (lambda (db . param) ;; ;; (sqlite3:execute db "DELETE FROM metadat WHERE var='SERVER'")) ;; ;; #f) ;; (set! *runremote* #f)) ;; (if (and (not (args:get-arg "-server")) ;; no point in the server using the server using the server ;; ((rpc:procedure 'server:login host portn) *toppath*)) ;; (begin -;; (debug:print-info 2 "Logged in and connected to " host ":" port) +;; (debug:print-info 2 #f "Logged in and connected to " host ":" port) ;; (set! *runremote* (vector host portn))) ;; (begin -;; (debug:print-info 2 "Failed to login or connect to " host ":" port) +;; (debug:print-info 2 #f "Failed to login or connect to " host ":" port) ;; (set! *runremote* #f))))) -;; (debug:print-info 2 "no server available"))))) +;; (debug:print-info 2 #f "no server available"))))) Index: runconfig.scm ================================================================== --- runconfig.scm +++ runconfig.scm @@ -17,20 +17,20 @@ (thekey (if keyvals (string-intersperse (map (lambda (x)(if x x "-na-")) (map cadr keyvals)) "/") (or (common:args-get-target) (get-environment-variable "MT_TARGET") (begin - (debug:print 0 "ERROR: setup-env-defaults called with no run-id or -target or -reqtarg") + (debug:print 0 #f "ERROR: setup-env-defaults called with no run-id or -target or -reqtarg") "nothing matches this I hope")))) ;; Why was system disallowed in the reading of the runconfigs file? ;; NOTE: Should be setting env vars based on (target|default) (confdat (read-config fname #f #t environ-patt: environ-patt sections: (list "default" thekey))) (whatfound (make-hash-table)) (finaldat (make-hash-table)) (sections (list "default" thekey))) (if (not *target*)(set! *target* thekey)) ;; may save a db access or two but repeats db:get-target code - (debug:print 4 "Using key=\"" thekey "\"") + (debug:print 4 #f "Using key=\"" thekey "\"") (if change-env (for-each ;; NB// This can be simplified with new content of keyvals having all that is needed. (lambda (keyval) (safe-setenv (car keyval)(cadr keyval))) @@ -51,15 +51,15 @@ (hash-table-set! finaldat envvar val))) (map car section-dat))))) sections) (if already-seen (begin - (debug:print 2 "Key settings found in runconfig.config:") + (debug:print 2 #f "Key settings found in runconfig.config:") (for-each (lambda (fullkey) - (debug:print 2 (format #f "~20a ~a\n" fullkey (hash-table-ref/default whatfound fullkey 0)))) + (debug:print 2 #f (format #f "~20a ~a\n" fullkey (hash-table-ref/default whatfound fullkey 0)))) sections) - (debug:print 2 "---") + (debug:print 2 #f "---") (set! *already-seen-runconfig-info* #t))) ;; finaldat ;; was returning this "finaldat" which would be good but conflicts with other uses confdat )) @@ -74,7 +74,7 @@ (setup-env-defaults runconfigf run-id #t keyvals environ-patt: (conc "(default" (if targ (conc "|" targ ")") ")"))) - (debug:print 0 "WARNING: You do not have a run config file: " runconfigf)))) + (debug:print 0 #f "WARNING: You do not have a run config file: " runconfigf)))) Index: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -51,11 +51,11 @@ (if itempath (setenv "MT_ITEMPATH" itempath)) ;; get the info from the db and put it in the cache (if link-tree (setenv "MT_LINKTREE" link-tree) - (debug:print 0 "ERROR: linktree not set, should be set in megatest.config in [setup] section.")) + (debug:print 0 #f "ERROR: linktree not set, should be set in megatest.config in [setup] section.")) (if (not vals) (let ((ht (make-hash-table))) (hash-table-set! *env-vars-by-run-id* run-id ht) (set! vals ht) (for-each @@ -64,19 +64,19 @@ keyvals))) ;; from the cached data set the vars (hash-table-for-each vals (lambda (key val) - (debug:print 2 "setenv " key " " val) + (debug:print 2 #f "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)))) (if runname (setenv "MT_RUNNAME" runname) - (debug:print 0 "ERROR: no value for runname for id " run-id))) + (debug:print 0 #f "ERROR: 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 (if testname (setenv "MT_TEST_NAME" testname)) (if itempath (setenv "MT_ITEMPATH" itempath)) (if (and testname link-tree) @@ -90,11 +90,11 @@ "")))) )) (define (set-item-env-vars itemdat) (for-each (lambda (item) - (debug:print 2 "setenv " (car item) " " (cadr item)) + (debug:print 2 #f "setenv " (car item) " " (cadr item)) (setenv (car item) (cadr item))) itemdat)) ;; Every time can-run-more-tests is called increment the delay ;; @@ -128,11 +128,11 @@ (define (runs:can-run-more-tests run-id jobgroup max-concurrent-jobs) (thread-sleep! (cond ((> *runs:can-run-more-tests-count* 20) (if (runs:lownoise "waiting on tasks" 60) - (debug:print-info 2 "waiting for tasks to complete, sleeping briefly ...")) + (debug:print-info 2 #f "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)) (job-group-limit (let ((jobg-count (config-lookup *configdat* "jobgroups" jobgroup))) @@ -141,28 +141,28 @@ jobg-count)))) (if (> (+ num-running num-running-in-jobgroup) 0) (set! *runs:can-run-more-tests-count* (+ *runs:can-run-more-tests-count* 1))) (if (not (eq? *last-num-running-tests* num-running)) (begin - (debug:print 2 "max-concurrent-jobs: " max-concurrent-jobs ", num-running: " num-running) + (debug:print 2 #f "max-concurrent-jobs: " max-concurrent-jobs ", num-running: " num-running) (set! *last-num-running-tests* num-running))) (if (not (eq? 0 *globalexitstatus*)) (list #f num-running num-running-in-jobgroup max-concurrent-jobs job-group-limit) (let ((can-not-run-more (cond ;; if max-concurrent-jobs is set and the number running is greater ;; than it than cannot run more jobs ((and max-concurrent-jobs (>= num-running max-concurrent-jobs)) (if (runs:lownoise "mcj msg" 60) - (debug:print 0 "WARNING: Max running jobs exceeded, current number running: " num-running + (debug:print 0 #f "WARNING: Max running jobs exceeded, current number running: " num-running ", max_concurrent_jobs: " max-concurrent-jobs)) #t) ;; if job-group-limit is set and number of jobs in the group is greater ;; than the limit then cannot run more jobs of this kind ((and job-group-limit (>= num-running-in-jobgroup job-group-limit)) (if (runs:lownoise (conc "maxjobgroup " jobgroup) 60) - (debug:print 1 "WARNING: number of jobs " num-running-in-jobgroup + (debug:print 1 #f "WARNING: number of jobs " num-running-in-jobgroup " in jobgroup \"" jobgroup "\" exceeds limit of " job-group-limit)) #t) (else #f)))) ;; ;; lets use the debugger eh? ;; (debugger-start start: 15) @@ -217,11 +217,11 @@ (print "Killed by signal " signum ". Exiting") (thread-sleep! 3) (exit)))) (th2 (make-thread (lambda () (thread-sleep! 5) - (debug:print 0 "Done") + (debug:print 0 #f "Done") (exit 4))))) (thread-start! th2) (thread-start! th1) (thread-join! th2))))) (set-signal-handler! signal/int sighand) @@ -229,11 +229,11 @@ (runs:set-megatest-env-vars 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 "WARNING: You do not have a run config file: " runconfigf) + (debug:print 0 #f "WARNING: You do not have a run config file: " runconfigf) #f))) ;; 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") @@ -260,14 +260,14 @@ ;; look up all tests matching the comma separated list of globs in ;; test-patts (using % as wildcard) ;; (set! test-names (delete-duplicates (tests:get-valid-tests *toppath* test-patts))) - (debug:print-info 0 "tests search path: " (string-intersperse (tests:get-tests-search-path *configdat*) " ")) - (debug:print-info 0 "all tests: " (string-intersperse (sort all-test-names string<) " ")) - (debug:print-info 0 "test names: " (string-intersperse (sort test-names string<) " ")) - (debug:print-info 0 "required tests: " (string-intersperse (sort required-tests string<) " ")) + (debug:print-info 0 #f "tests search path: " (string-intersperse (tests:get-tests-search-path *configdat*) " ")) + (debug:print-info 0 #f "all tests: " (string-intersperse (sort all-test-names string<) " ")) + (debug:print-info 0 #f "test names: " (string-intersperse (sort test-names string<) " ")) + (debug:print-info 0 #f "required tests: " (string-intersperse (sort required-tests string<) " ")) ;; on the first pass or call to run-tests set FAILS to NOT_STARTED if ;; -keepgoing is specified (if (eq? *passnum* 0) (begin @@ -302,17 +302,17 @@ (let loop ((hed (car test-names)) ;; NOTE: This is the main loop that iterates over the test-names (tal (cdr test-names))) ;; 'return-procs tells the config reader to prep running system but return a proc (change-directory *toppath*) ;; PLEASE OPTIMIZE ME!!! I think this should be a no-op but there are several places where change-directories could be happening. (setenv "MT_TEST_NAME" hed) ;; (let*-values (((waitons waitors config)(tests:get-waitons hed all-tests-registry))) - (debug:print-info 8 "waitons: " waitons) + (debug:print-info 8 #f "waitons: " waitons) ;; check for hed in waitons => this would be circular, remove it and issue an ;; error (if (or (member hed waitons) (member hed waitors)) (begin - (debug:print 0 "ERROR: test " hed " has listed itself as a waiton or waitor, please correct this!") + (debug:print 0 #f "ERROR: test " hed " has listed itself as a waiton or waitor, please correct this!") (set! waitons (filter (lambda (x)(not (equal? x hed))) waitons)) (set! waitors (filter (lambda (x)(not (equal? x hed))) waitors)))) ;; (items (items:get-items-from-config config))) (if (not (hash-table-ref/default test-records hed #f)) @@ -334,11 +334,11 @@ (waiton-itemized (and waiton-tconfig (or (hash-table-ref/default waiton-tconfig "items" #f) (hash-table-ref/default waiton-tconfig "itemstable" #f)))) (itemmaps (tests:get-itemmaps config)) ;; (configf:lookup config "requirements" "itemmap")) (new-test-patts (tests:extend-test-patts test-patts hed waiton itemmaps))) - (debug:print-info 0 "Test " waiton " has " (if waiton-record "a" "no") " waiton-record and" (if waiton-itemized " " " no ") "items") + (debug:print-info 0 #f "Test " waiton " has " (if waiton-record "a" "no") " waiton-record and" (if waiton-itemized " " " no ") "items") ;; need to account for test-patt here, if I am test "a", selected with a test-patt of "hed/b%" ;; and we are waiting on "waiton" we need to add "waiton/,waiton/b%" to test-patt ;; is this satisfied by merely appending "/" to the waiton name added to the list? ;; ;; This approach causes all of the items in an upstream test to be run @@ -351,19 +351,19 @@ (if waiton-tconfig (begin (set! test-names (cons waiton test-names)) ;; need to process this one, only add once the waiton tconfig read (if waiton-itemized (begin - (debug:print-info 0 "New test patts: " new-test-patts ", prev test patts: " test-patts) + (debug:print-info 0 #f "New test patts: " new-test-patts ", prev test patts: " test-patts) (set! required-tests (cons (conc waiton "/") required-tests)) (set! test-patts new-test-patts)) (begin - (debug:print-info 0 "Adding non-itemized test " waiton " to required-tests") + (debug:print-info 0 #f "Adding non-itemized test " waiton " to required-tests") (set! required-tests (cons waiton required-tests)) (set! test-patts new-test-patts)))) (begin - (debug:print-info 0 "No testconfig info yet for " waiton ", setting up to re-process it") + (debug:print-info 0 #f "No testconfig info yet for " waiton ", setting up to re-process it") (set! tal (append (cons waiton tal)(list hed))))) ;; (cons (conc waiton "/") required-tests)) ;; NOPE: didn't work. required needs to be plain test names. Try tacking on to test-patts ;; - doesn't work ;; (set! test-patts (conc test-patts "," waiton "/")) @@ -372,17 +372,17 @@ ))) (delete-duplicates (append waitons waitors))) (let ((remtests (delete-duplicates (append waitons tal)))) (if (not (null? remtests)) (begin - ;; (debug:print-info 0 "Preprocessing continues for " (string-intersperse remtests ", ")) + ;; (debug:print-info 0 #f "Preprocessing continues for " (string-intersperse remtests ", ")) (loop (car remtests)(cdr remtests)))))))) (if (not (null? required-tests)) - (debug:print-info 1 "Adding \"" (string-intersperse required-tests " ") "\" to the run queue")) + (debug:print-info 1 #f "Adding \"" (string-intersperse required-tests " ") "\" to the run queue")) ;; NOTE: these are all parent tests, items are not expanded yet. - (debug:print-info 4 "test-records=" (hash-table->alist test-records)) + (debug:print-info 4 #f "test-records=" (hash-table->alist test-records)) (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 () @@ -389,11 +389,11 @@ (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 0 "ERROR: failure in runs:run-tests-queue thread, error: " ((condition-property-accessor 'exn 'message) exn)) + ;; (debug:print 0 #f "ERROR: 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))) @@ -403,11 +403,11 @@ (let ((run-ids (rmt:get-all-run-ids))) (for-each (lambda (run-id) (if keep-going (handle-exceptions exn - (debug:print 0 "error in calling find-and-mark-incomplete for run-id " run-id) + (debug:print 0 #f "error in calling find-and-mark-incomplete for run-id " run-id) (rmt:find-and-mark-incomplete run-id #f)))) ;; ovr-deadtime))) run-ids))) "runs: mark-incompletes"))) (thread-start! th1) (thread-start! th2) @@ -421,12 +421,12 @@ (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))))) - (debug:print-info 0 "No tests to run"))) - (debug:print-info 4 "All done by here") + (debug:print-info 0 #f "No tests to run"))) + (debug:print-info 4 #f "All done by here") (rmt:tasks-set-state-given-param-key task-key "done") ;; (sqlite3:finalize! tasks-db) )) @@ -450,11 +450,11 @@ ;; ((and regfull (null? reg)(not (null? tal))) (car tal)) ;; ((and regfull (not (null? reg))) (car reg)) ;; ((and (not regfull)(null? tal)(not (null? reg))) (car reg)) ;; ((and (not regfull)(not (null? tal))) (car tal)) ;; (else -;; (debug:print 0 "ERROR: runs:queue-next-hed, tal=" tal ", reg=" reg ", n=" n ", regfull=" regfull) +;; (debug:print 0 #f "ERROR: runs:queue-next-hed, tal=" tal ", reg=" reg ", n=" n ", regfull=" regfull) ;; #f))) (define (runs:queue-next-tal tal reg n regfull) (if regfull tal @@ -475,20 +475,20 @@ (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))) (if (list? res) res (begin - (debug:print 0 + (debug:print 0 #f "ERROR: rmt:get-prereqs-not-met returned non-list!\n" " res=" res " run-id=" run-id " waitons=" waitons " hed=" hed " item-path=" item-path " testmode=" testmode " itemmaps=" itemmaps) '())))) ;; (prereqs-not-met (mt:lazy-get-prereqs-not-met run-id waitons item-path mode: testmode itemmap: itemmap)) (fails (runs:calc-fails prereqs-not-met)) (prereq-fails (runs:calc-prereq-fail prereqs-not-met)) (non-completed (runs:calc-not-completed prereqs-not-met)) (runnables (runs:calc-runnable prereqs-not-met))) - (debug:print-info 4 "START OF INNER COND #2 " + (debug:print-info 4 #f "START OF INNER COND #2 " "\n can-run-more: " can-run-more "\n testname: " hed "\n prereqs-not-met: " (runs:pretty-string prereqs-not-met) "\n non-completed: " (runs:pretty-string non-completed) "\n prereq-fails: " (runs:pretty-string prereq-fails) @@ -513,34 +513,34 @@ ;; or, if it is a 'toplevel test and all prereqs not met are COMPLETED then launch ((and (not (member 'toplevel testmode)) (member (hash-table-ref/default test-registry (db:test-make-full-name hed item-path) 'n/a) '(DONOTRUN removed CANNOTRUN))) ;; *common:cant-run-states-sym*) ;; '(COMPLETED KILLED WAIVED UNKNOWN INCOMPLETE)) ;; try to catch repeat processing of COMPLETED tests here - (debug:print-info 1 "Test " hed " set to \"" (hash-table-ref test-registry (db:test-make-full-name hed item-path)) "\". Removing it from the queue") + (debug:print-info 1 #f "Test " hed " set to \"" (hash-table-ref test-registry (db:test-make-full-name hed item-path)) "\". Removing it from the queue") (if (or (not (null? tal)) (not (null? reg))) (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) (begin - (debug:print-info 0 "Nothing left in the queue!") + (debug:print-info 0 #f "Nothing left in the queue!") ;; If get here twice then we know we've tried to expand all items ;; since there must be a logic issue with the handling of loops in the ;; items expand phase we will brute force an exit here. (if (> runs:nothing-left-in-queue-count 2) (begin - (debug:print 0 "WARNING: this condition is triggered when there were no items to expand and nothing to run. Please check your run for completeness") + (debug:print 0 #f "WARNING: this condition is triggered when there were no items to expand and nothing to run. Please check your run for completeness") (exit 0)) (set! runs:nothing-left-in-queue-count (+ runs:nothing-left-in-queue-count 1))) #f))) ;; ((or (null? prereqs-not-met) (and (member 'toplevel testmode) (null? non-completed))) - (debug:print-info 4 "runs:expand-items: (or (null? prereqs-not-met) (and (member 'toplevel testmode)(null? non-completed)))") + (debug:print-info 4 #f "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 (let ((items-list (items:get-items-from-config tconfig))) @@ -553,11 +553,11 @@ (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)) (begin - (debug:print 0 "ERROR: The proc from reading the items table did not yield a list - please report this") + (debug:print 0 #f "ERROR: The proc from reading the items table did not yield a list - please report this") (exit 1)))))) ((and (null? fails) (null? prereq-fails) (not (null? non-completed))) @@ -584,11 +584,11 @@ (if (and give-up (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 "WARNING: test " hed " has discarded prerequisites, removing it from the queue") + (debug:print 1 #f "WARNING: test " hed " has discarded prerequisites, removing it from the queue") (let ((test-id (rmt:get-test-id 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) @@ -604,18 +604,18 @@ (null? prereq-fails) (null? non-completed)) (if (runs:can-keep-running? hed 20) (begin (runs:inc-cant-run-tests hed) - (debug:print-info 1 "no fails in prerequisites for " hed " but also none running, keeping " hed " for now. Try count: " (hash-table-ref/default *seen-cant-run-tests* hed 0)) + (debug:print-info 1 #f "no fails in prerequisites for " hed " but also none running, keeping " hed " for now. Try count: " (hash-table-ref/default *seen-cant-run-tests* hed 0)) ;; getting here likely means the system is way overloaded, kill a full minute before continuing (thread-sleep! 60) ;; 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 "no fails in prerequisites for " hed " but nothing seen running in a while, dropping test " hed " from the run queue") + (debug:print-info 1 #f "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 ""))) (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) @@ -623,11 +623,11 @@ ((and (or (not (null? fails)) (not (null? prereq-fails))) (member 'normal testmode)) - (debug:print-info 1 "test " hed " (mode=" testmode ") has failed prerequisite(s); " + (debug:print-info 1 #f "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 ""))) (if test-id (if (not (null? prereq-fails)) @@ -646,11 +646,11 @@ (if (or (not (null? reg))(not (null? tal))) (list (car newtal)(append (cdr newtal) reg) '() reruns) #f)) ((null? runnables) #f) ;; if we get here and non-completed is null the it's all over. (else - (debug:print 0 "WARNING: FAILS or incomplete tests maybe preventing completion of this run. Watch for issues with test " hed ", continuing for now") + (debug:print 0 #f "WARNING: FAILS or incomplete tests maybe preventing completion of this run. Watch for issues with test " hed ", continuing for now") ;; (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) (list (car newtal)(cdr newtal) reg reruns))))) @@ -682,21 +682,21 @@ (prereqs-not-met (rmt:get-prereqs-not-met 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 0 "ERROR: prereqs-not-met is not a list! " prereqs-not-met) + (debug:print 0 #f "ERROR: prereqs-not-met is not a list! " prereqs-not-met) '()))) (non-completed (filter (lambda (x) ;; remove hed from not completed list, duh, of course it is not completed! (not (equal? x hed))) (runs:calc-not-completed prereqs-not-met))) (loop-list (list hed tal reg reruns)) ;; configure the load runner (numcpus (common:get-num-cpus)) (maxload (string->number (or (configf:lookup *configdat* "jobtools" "maxload") "3"))) (waitdelay (string->number (or (configf:lookup *configdat* "jobtools" "waitdelay") "60")))) - (debug:print-info 4 "have-resources: " have-resources " prereqs-not-met: (" + (debug:print-info 4 #f "have-resources: " have-resources " prereqs-not-met: (" (string-intersperse (map (lambda (t) (if (vector? t) (conc (db:test-get-state t) "/" (db:test-get-status t)) (conc " WARNING: t is not a vector=" t ))) @@ -706,24 +706,24 @@ (if (and (not (null? prereqs-not-met)) (runs:lownoise (conc "waiting on tests " prereqs-not-met hed) 60)) - (debug:print-info 2 "waiting on tests; " (string-intersperse (runs:mixed-list-testname-and-testrec->list-of-strings prereqs-not-met) ", "))) + (debug:print-info 2 #f "waiting on tests; " (string-intersperse (runs:mixed-list-testname-and-testrec->list-of-strings prereqs-not-met) ", "))) ;; Don't know at this time if the test have been launched at some time in the past ;; i.e. is this a re-launch? - (debug:print-info 4 "run-limits-info = " run-limits-info) + (debug:print-info 4 #f "run-limits-info = " run-limits-info) (cond ;; Check item path against item-patts, ;; ((not (tests:match test-patts (tests:testqueue-get-testname test-record) item-path required: required-tests)) ;; This test/itempath is not to be run ;; else the run is stuck, temporarily or permanently ;; but should check if it is due to lack of resources vs. prerequisites - (debug:print-info 1 "Skipping " (tests:testqueue-get-testname test-record) " " item-path " as it doesn't match " test-patts) + (debug:print-info 1 #f "Skipping " (tests:testqueue-get-testname test-record) " " item-path " as it doesn't match " test-patts) (if (or (not (null? tal))(not (null? reg))) (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) @@ -730,21 +730,21 @@ #f)) ;; Register tests ;; ((not (hash-table-ref/default test-registry (db:test-make-full-name test-name item-path) #f)) - (debug:print-info 4 "Pre-registering test " test-name "/" item-path " to create placeholder" ) + (debug:print-info 4 #f "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) (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 0 "ERROR: failed to register test " (db:test-make-full-name test-name item-path))))) + (debug:print 0 #f "ERROR: 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 "") (hash-table-set! test-registry (db:test-make-full-name test-name "") 'done)))) @@ -762,11 +762,11 @@ ;; At this point hed test registration must be completed. ;; ((eq? (hash-table-ref/default test-registry (db:test-make-full-name test-name item-path) #f) 'start) - (debug:print-info 0 "Waiting on test registration(s): " + (debug:print-info 0 #f "Waiting on test registration(s): " (string-intersperse (filter (lambda (x) (eq? (hash-table-ref/default test-registry x #f) 'start)) (hash-table-keys test-registry)) ", ")) @@ -775,11 +775,11 @@ ;; If no resources are available just kill time and loop again ;; ((not have-resources) ;; simply try again after waiting a second (if (runs:lownoise "no resources" 60) - (debug:print-info 1 "no resources to run new tests, waiting ...")) + (debug:print-info 1 #f "no resources to run new tests, waiting ...")) ;; Have gone back and forth on this but db starvation is an issue. ;; wait one second before looking again to run jobs. (thread-sleep! 1) ;; could have done hed tal here but doing car/cdr of newtal to rotate tests (list (car newtal)(cdr newtal) reg reruns)) @@ -810,32 +810,32 @@ #f)) ;; must be we have unmet prerequisites ;; (else - (debug:print 4 "FAILS: " fails) + (debug:print 4 #f "FAILS: " fails) ;; If one or more of the prereqs-not-met are FAIL then we can issue ;; a message and drop hed from the items to be processed. ;; (runs:mixed-list-testname-and-testrec->list-of-strings prereqs-not-met) (if (and (not (null? prereqs-not-met)) (runs:lownoise (conc "waiting on tests " prereqs-not-met hed) 60)) - (debug:print-info 1 "waiting on tests; " (string-intersperse + (debug:print-info 1 #f "waiting on tests; " (string-intersperse (runs:mixed-list-testname-and-testrec->list-of-strings prereqs-not-met) ", "))) (if (or (null? fails) (member 'toplevel testmode)) (begin ;; couldn't run, take a breather (if (runs:lownoise "Waiting for more work to do..." 60) - (debug:print-info 0 "Waiting for more work to do...")) + (debug:print-info 0 #f "Waiting for more work to do...")) (thread-sleep! 1) (list (car newtal)(cdr newtal) reg reruns)) ;; the waiton is FAIL so no point in trying to run hed ever again (if (or (not (null? reg))(not (null? tal))) (if (vector? hed) (begin - (debug:print 1 "WARNING: Dropping test " test-name "/" item-path + (debug:print 1 #f "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 ""))) (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) ;; DELAY TWEAKER (still needed?) ;; (thread-sleep! *global-delta*) @@ -849,11 +849,11 @@ )) (let ((nth-try (hash-table-ref/default test-registry hed 0))) (cond ((member "RUNNING" (map db:test-get-state prereqs-not-met)) (if (runs:lownoise (conc "possible RUNNING prerequistes " hed) 60) - (debug:print 0 "WARNING: test " hed " has possible RUNNING prerequisites, don't give up on it yet.")) + (debug:print 0 #f "WARNING: test " hed " has possible RUNNING prerequisites, don't give up on it yet.")) (thread-sleep! 4) (list (runs:queue-next-hed newtal reg reglen regfull) (runs:queue-next-tal newtal reg reglen regfull) (runs:queue-next-reg newtal reg reglen regfull) reruns)) @@ -862,11 +862,11 @@ (< nth-try 10))) (hash-table-set! test-registry hed (if (number? nth-try) (+ nth-try 1) 0)) (if (runs:lownoise (conc "not removing test " hed) 60) - (debug:print 1 "WARNING: not removing test " hed " from queue although it may not be runnable due to FAILED prerequisites")) + (debug:print 1 #f "WARNING: not removing test " hed " from queue although it may not be runnable due to FAILED prerequisites")) ;; may not have processed correctly. Could be a race condition in your test implementation? Dropping test " hed) ;; " as it has prerequistes that are FAIL. (NOTE: hed is not a vector)") (runs:shrink-can-run-more-tests-count) ;; DELAY TWEAKER (still needed?) ;; (list hed tal reg reruns) ;; (list (car newtal)(cdr newtal) reg reruns) ;; (hash-table-set! test-registry hed 'removed) @@ -879,21 +879,21 @@ (if (null? tal) #f ;; yes, really (list (car tal)(cdr tal) reg reruns)) (begin (if (runs:lownoise (conc "FAILED prerequisites or other issue" hed) 60) - (debug:print 0 "WARNING: test " hed " has FAILED prerequisites or other issue. Internal state " nth-try " will be overridden and we'll retry.")) + (debug:print 0 #f "WARNING: test " hed " has FAILED prerequisites or other issue. Internal state " nth-try " will be overridden and we'll retry.")) (mt:test-set-state-status-by-testname run-id test-name item-path "NOT_STARTED" "KEEP_TRYING" #f) (hash-table-set! test-registry hed 0) (list (runs:queue-next-hed newtal reg reglen regfull) (runs:queue-next-tal newtal reg reglen regfull) (runs:queue-next-reg newtal reg reglen regfull) reruns)))) (else (if (runs:lownoise (conc "FAILED prerequitests and we tried" hed) 60) - (debug:print 0 "WARNING: test " hed " has FAILED prerequitests and we've tried at least 10 times to run it. Giving up now.")) - ;; (debug:print 0 " prereqs: " prereqs-not-met) + (debug:print 0 #f "WARNING: test " hed " has FAILED prerequitests and we've tried at least 10 times to run it. Giving up now.")) + ;; (debug:print 0 #f " 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:roll-up-pass-fail-counts run-id test-name item-path #f "FAIL") ;; treat as FAIL (list (if (null? tal)(car newtal)(car tal)) @@ -933,11 +933,11 @@ ;; 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) ;; 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 "test-records: " test-records ", flags: " (hash-table->alist flags)) + (debug:print 5 #f "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) @@ -972,11 +972,11 @@ (let loop ((hed (car sorted-test-names)) (tal (cdr sorted-test-names)) (reg '()) ;; registered, put these at the head of tal (reruns '())) - (if (not (null? reruns))(debug:print-info 4 "reruns=" reruns)) + (if (not (null? reruns))(debug:print-info 4 #f "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)) @@ -1011,11 +1011,11 @@ (if (> num-running 0) (set! last-time-some-running (current-seconds))) (if (> (current-seconds)(+ last-time-some-running (or (configf:lookup *configdat* "setup" "give-up-waiting") 36000))) (hash-table-set! *max-tries-hash* tfullname (+ (hash-table-ref/default *max-tries-hash* tfullname 0) 1))) - ;; (debug:print 0 "max-tries-hash: " (hash-table->alist *max-tries-hash*)) + ;; (debug:print 0 #f "max-tries-hash: " (hash-table->alist *max-tries-hash*)) ;; 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 @@ -1026,19 +1026,19 @@ ;; (if (member (hash-table-ref/default test-registry tfullname #f) '(DONOTRUN removed)) ;; *common:cant-run-states-sym*) ;; '(COMPLETED KILLED WAIVED UNKNOWN INCOMPLETE)) (begin (if (runs:lownoise (conc "been marked do not run " tfullname) 60) - (debug:print-info 0 "Skipping test " tfullname " as it has been marked do not run due to being completed or not runnable")) + (debug:print-info 0 #f "Skipping test " tfullname " as it has been marked do not run due to being completed or not runnable")) (if (or (not (null? tal))(not (null? reg))) (loop (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)))) ;; (loop (car tal)(cdr tal) reg reruns)))) - (debug:print 4 "TOP OF LOOP => " + (debug:print 4 #f "TOP OF LOOP => " "test-name: " test-name "\n test-record " test-record "\n hed: " hed "\n itemdat: " itemdat "\n items: " items @@ -1065,11 +1065,11 @@ ;; check for hed in waitons => this would be circular, remove it and issue an ;; error (if (member test-name waitons) (begin - (debug:print 0 "ERROR: test " test-name " has listed itself as a waiton, please correct this!") + (debug:print 0 #f "ERROR: test " test-name " has listed itself as a waiton, please correct this!") (set! waiton (filter (lambda (x)(not (equal? x hed))) waitons)))) (cond ;; We want to catch tests that have waitons that are NOT in the queue and discard them IFF @@ -1083,17 +1083,17 @@ (if (and (not (member waiton tal)) ;; this waiton is not in the list to be tried to run (not (member waiton reruns))) 1 #f)) waitons))))) ;; could do this more elegantly with a marker.... - (debug:print 0 "WARNING: Marking test " tfullname " as not runnable. It is waiting on tests that cannot be run. Giving up now.") + (debug:print 0 #f "WARNING: Marking test " tfullname " as not runnable. It is waiting on tests that cannot be run. Giving up now.") (hash-table-set! test-registry tfullname 'removed)) ;; items is #f then the test is ok to be handed off to launch (but not before) ;; ((not items) - (debug:print-info 4 "OUTER COND: (not items)") + (debug:print-info 4 #f "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)) (let ((loop-list (runs:process-expanded-tests 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))) (if loop-list (apply loop loop-list)))) @@ -1100,18 +1100,18 @@ ;; 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 (not itemdat)) ;; and not yet expanded into the list of things to be done - (debug:print-info 4 "OUTER COND: (and (list? items)(not itemdat))") + (debug:print-info 4 #f "OUTER COND: (and (list? items)(not itemdat))") ;; Must determine if the items list is valid. Discard the test if it is not. (if (and (list? items) (> (length items) 0) (and (list? (car items)) (> (length (car items)) 0)) (debug:debug-mode 1)) - (debug:print 2 (map (lambda (row) + (debug:print 2 #f (map (lambda (row) (conc (string-intersperse (map (lambda (varval) (string-intersperse varval "=")) row) " ") @@ -1130,11 +1130,11 @@ (tests:testqueue-set-item_path! new-test-record my-item-path) (hash-table-set! test-records newtestname new-test-record) (set! tal (append tal (list newtestname))))))) ;; since these are itemized create new test names testname/itempath items) - ;; (debug:print-info 0 "Test " (tests:testqueue-get-testname test-record) " is itemized but has no items") + ;; (debug:print-info 0 #f "Test " (tests:testqueue-get-testname test-record) " is itemized but has no items") ;; At this point we have possibly added items to tal but all must be handed off to ;; INNER COND logic. I think loop without rotating the queue ;; (loop hed tal reg reruns)) ;; (let ((newtal (append tal (list hed)))) ;; We should discard hed as it has been expanded into it's items? Yes, but only if this *is* an itemized test @@ -1156,56 +1156,56 @@ ;; if can't run more just loop with next possible test (loop (car newtal)(cdr newtal) reg reruns)))) ;; this case should not happen, added to help catch any bugs ((and (list? items) itemdat) - (debug:print 0 "ERROR: Should not have a list of items in a test and the itemspath set - please report this") + (debug:print 0 #f "ERROR: 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, (junked (lset-difference equal? tal newlst))) - (debug:print-info 4 "full drop through, if reruns is less than 100 we will force retry them, reruns=" reruns ", tal=" tal) + (debug:print-info 4 #f "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)) ;; (thread-sleep! (+ 1 *global-delta*)) (if (not (null? newlst)) ;; since reruns have been tacked on to newlst create new reruns from junked (loop (car newlst)(cdr newlst) reg (delete-duplicates junked))))) ((not (null? tal)) - (debug:print-info 4 "I'm pretty sure I shouldn't get here.")) + (debug:print-info 4 #f "I'm pretty sure I shouldn't get here.")) ((not (null? reg)) ;; could we get here with leftovers? - (debug:print-info 0 "Have leftovers!") + (debug:print-info 0 #f "Have leftovers!") (loop (car reg)(cdr reg) '() reruns)) (else - (debug:print-info 4 "Exiting loop with...\n hed=" hed "\n tal=" tal "\n reruns=" reruns)) + (debug:print-info 4 #f "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)) (prev-num-running 0)) - ;; (debug:print 0 "num-running=" num-running ", prev-num-running=" prev-num-running) + ;; (debug:print 0 #f "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)) (begin ;; Here we mark any old defunct tests as incomplete. Do this every fifteen minutes - ;; (debug:print 0 "Got here eh! num-running=" num-running " (> num-running 0) " (> num-running 0)) + ;; (debug:print 0 #f "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 "Marking stuck tests as INCOMPLETE while waiting for run " run-id ". Running as pid " (current-process-id) " on " (get-host-name)) + (debug:print-info 0 #f "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))) (if (not (eq? num-running prev-num-running)) - (debug:print-info 0 "run-wait specified, waiting on " num-running " tests in RUNNING, REMOTEHOSTSTART or LAUNCHED state at " (time->string (seconds->local-time (current-seconds))))) + (debug:print-info 0 #f "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)))) ;; LET* ((test-record ;; we get here on "drop through". All done! - (debug:print-info 1 "All tests launched"))) + (debug:print-info 1 #f "All tests launched"))) (define (runs:calc-fails prereqs-not-met) (filter (lambda (test) (and (vector? test) ;; not (string? test)) (member (db:test-get-state test) '("INCOMPLETE" "COMPLETED")) @@ -1269,16 +1269,16 @@ ;; setting itemdat to a list if it is #f (if (not itemdat)(set! itemdat '())) (set! item-path (item-list->path itemdat)) (set! full-test-name (db:test-make-full-name test-name item-path)) - (debug:print-info 4 + (debug:print-info 4 #f "\nTESTNAME: " full-test-name "\n test-config: " (hash-table->alist test-conf) "\n itemdat: " itemdat ) - (debug:print 2 "Attempting to launch test " full-test-name) + (debug:print 2 #f "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 (change-directory *toppath*) @@ -1310,35 +1310,35 @@ ;; 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) (begin - (debug:print 2 "WARN: Test not pre-created? test-name=" test-name ", item-path=" item-path ", run-id=" run-id) + (debug:print 2 #f "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)))) - (debug:print-info 4 "test-id=" test-id ", run-id=" run-id ", test-name=" test-name ", item-path=\"" item-path "\"") + (debug:print-info 4 #f "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)) (if (not testdat) (begin - (debug:print-info 0 "WARNING: server is overloaded, trying again in one second") + (debug:print-info 0 #f "WARNING: server is overloaded, trying again in one second") (thread-sleep! 1) (loop))))) (if (not testdat) ;; should NOT happen - (debug:print 0 "ERROR: failed to get test record for test-id " test-id)) + (debug:print 0 #f "ERROR: failed to get test record for test-id " test-id)) (set! test-id (db:test-get-id testdat)) (if (file-exists? test-path) (change-directory test-path) (begin - (debug:print "ERROR: test run path not created before attempting to run the test. Perhaps you are running -remove-runs at the same time?") + (debug:print 0 #f "ERROR: test run path not created before attempting to run the test. Perhaps you are running -remove-runs at the same time?") (change-directory *toppath*))) (case (if force ;; (args:get-arg "-force") 'NOT_STARTED (if testdat (string->symbol (test:get-state testdat)) 'failed-to-insert)) ((failed-to-insert) - (debug:print 0 "ERROR: Failed to insert the record into the db")) + (debug:print 0 #f "ERROR: Failed to insert the record into the db")) ((NOT_STARTED COMPLETED DELETED INCOMPLETE) (let ((runflag #f)) (cond ;; -force, run no matter what (force (set! runflag #t)) @@ -1348,34 +1348,34 @@ ((and (or (not rerun) keepgoing) ;; Require to force re-run for COMPLETED or *anything* + PASS,WARN or CHECK (or (member (test:get-status testdat) '("PASS" "WARN" "CHECK" "SKIP" "WAIVED")) (member (test:get-state testdat) '("COMPLETED")))) - (debug:print-info 2 "running test " test-name "/" item-path " suppressed as it is " (test:get-state testdat) " and " (test:get-status testdat)) + (debug:print-info 2 #f "running test " test-name "/" item-path " suppressed as it is " (test:get-state testdat) " and " (test:get-status testdat)) (hash-table-set! test-registry full-test-name 'DONOTRUN) ;; COMPLETED) (set! runflag #f)) ;; -rerun and status is one of the specifed, run it ((and rerun (let* ((rerunlst (string-split rerun ",")) (must-rerun (member (test:get-status testdat) rerunlst))) - (debug:print-info 3 "-rerun list: " rerun ", test-status: " (test:get-status testdat)", must-rerun: " must-rerun) + (debug:print-info 3 #f "-rerun list: " rerun ", test-status: " (test:get-status testdat)", must-rerun: " must-rerun) must-rerun)) - (debug:print-info 2 "Rerun forced for test " test-name "/" item-path) + (debug:print-info 2 #f "Rerun forced for test " test-name "/" item-path) (set! runflag #t)) ;; -keepgoing, do not rerun FAIL ((and keepgoing (member (test:get-status testdat) '("FAIL"))) (set! runflag #f)) ((and (not rerun) (member (test:get-status testdat) '("FAIL" "n/a"))) (set! runflag #t)) (else (set! runflag #f))) - (debug:print 4 "RUNNING => runflag: " runflag " STATE: " (test:get-state testdat) " STATUS: " (test:get-status testdat)) + (debug:print 4 #f "RUNNING => runflag: " runflag " STATE: " (test:get-state testdat) " STATUS: " (test:get-status testdat)) (if (not runflag) (if (not parent-test) (if (runs:lownoise (conc "not starting test" full-test-name) 60) - (debug:print 1 "NOTE: Not starting test " full-test-name " as it is state \"" (test:get-state testdat) + (debug:print 1 #f "NOTE: Not starting test " full-test-name " as it is state \"" (test:get-state testdat) "\" and status \"" (test:get-status testdat) "\", use -rerun \"" (test:get-status testdat) "\" or -force to override"))) ;; NOTE: No longer be checking prerequisites here! Will never get here unless prereqs are ;; already met. ;; This would be a great place to do the process-fork @@ -1409,32 +1409,32 @@ (set! skip-test (conc "Skipping due to previous test run less than " (configf:lookup test-conf "skip" "rundelay") " ago")))))) (if skip-test (begin (mt:test-set-state-status-by-id run-id test-id "COMPLETED" "SKIP" skip-test) - (debug:print-info 1 "SKIPPING Test " full-test-name " due to " skip-test)) + (debug:print-info 1 #f "SKIPPING Test " full-test-name " due to " skip-test)) (if (not (launch-test test-id run-id run-info keyvals runname test-conf test-name test-path itemdat flags)) (begin (print "ERROR: Failed to launch the test. Exiting as soon as possible") (set! *globalexitstatus* 1) ;; (process-signal (current-process-id) signal/kill)))))))) ((KILLED) - (debug:print 1 "NOTE: " full-test-name " is already running or was explictly killed, use -force to launch it.") + (debug:print 1 #f "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 "NOTE: " test-name " is already running")) + (debug:print 2 #f "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 "WARNING: Test " test-name " appears to be dead. Forcing it to state INCOMPLETE and status STUCK/DEAD") + ;; (debug:print 0 #f "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 "NOTE: " test-name " is already running"))) + ;; (debug:print 2 #f "NOTE: " test-name " is already running"))) (else - (debug:print 0 "ERROR: Failed to launch test " full-test-name ". Unrecognised state " (test:get-state testdat)) + (debug:print 0 #f "ERROR: 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)) (else (hash-table-set! test-registry (db:test-make-full-name test-name test-path) 'DONOTRUN)))))))) @@ -1454,11 +1454,11 @@ (if (> (system (conc "rm -rf " real-dir)) 0) (begin ;; FAILED, possibly due to permissions, do chmod a+rwx then try one more time (system (conc "chmod -R a+rwx " real-dir)) (if (> (system (conc "rm -rf " real-dir)) 0) - (debug:print 0 "ERROR: There was a problem removing " real-dir " with rm -f"))))) + (debug:print 0 #f "ERROR: There was a problem removing " real-dir " with rm -f"))))) (define (runs:safe-delete-test-dir real-dir) ;; first delete all sub-directories (directory-fold (lambda (f x) @@ -1496,14 +1496,14 @@ (states (if state (string-split state ",") '())) (statuses (if status (string-split status ",") '())) (state-status (if (string? new-state-status) (string-split new-state-status ",") '(#f #f))) (rp-mutex (make-mutex)) (bup-mutex (make-mutex))) - (debug:print-info 4 "runs:operate-on => Header: " header " action: " action " new-state-status: " new-state-status) + (debug:print-info 4 #f "runs:operate-on => Header: " header " action: " action " new-state-status: " new-state-status) (if (> 2 (length state-status)) (begin - (debug:print 0 "ERROR: the parameter to -set-state-status is a comma delimited string. E.g. COMPLETED,FAIL") + (debug:print 0 #f "ERROR: the parameter to -set-state-status is a comma delimited string. E.g. COMPLETED,FAIL") (exit))) (for-each (lambda (run) (let ((runkey (string-intersperse (map (lambda (k) (db:get-value-by-header run header k)) keys) "/")) @@ -1521,42 +1521,42 @@ (tests (if (not (equal? run-state "locked")) (proc-get-tests run-id) '())) (lasttpath "/does/not/exist/I/hope") (worker-thread #f)) - (debug:print-info 4 "runs:operate-on run=" run ", header=" header) + (debug:print-info 4 #f "runs:operate-on run=" run ", header=" header) (if (not (null? tests)) (begin (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) - ;; (debug:print 0 "not attempting to kill any run launcher processes as testpatt is " testpatt)) - (debug:print 1 "Removing tests for run: " runkey " " (db:get-value-by-header run header "runname"))) + ;; (debug:print 0 #f "not attempting to kill any run launcher processes as testpatt is " testpatt)) + (debug:print 1 #f "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)) - (debug:print 1 "Modifying state and staus for tests for run: " runkey " " (db:get-value-by-header run header "runname"))) + (debug:print 1 #f "Modifying state and staus for tests for run: " runkey " " (db:get-value-by-header run header "runname"))) ((print-run) - (debug:print 1 "Printing info for run " runkey ", run=" run ", tests=" tests ", header=" header) + (debug:print 1 #f "Printing info for run " runkey ", run=" run ", tests=" tests ", header=" header) action) ((run-wait) - (debug:print 1 "Waiting for run " runkey ", run=" runnamepatt " to complete")) + (debug:print 1 #f "Waiting for run " runkey ", run=" runnamepatt " to complete")) ((archive) - (debug:print 1 "Archiving/restoring (" (args:get-arg "-archive") ") data for run: " runkey " " (db:get-value-by-header run header "runname")) + (debug:print 1 #f "Archiving/restoring (" (args:get-arg "-archive") ") data for run: " runkey " " (db:get-value-by-header run header "runname")) (set! worker-thread (make-thread (lambda () (case (string->symbol (args:get-arg "-archive")) ((save save-remove keep-html)(archive:run-bup (args:get-arg "-archive") run-id run-name tests rp-mutex bup-mutex)) ((restore)(archive:bup-restore (args:get-arg "-archive") run-id run-name tests rp-mutex bup-mutex)) (else - (debug:print 0 "ERROR: unrecognised sub command to -archive. Run \"megatest\" to see help") + (debug:print 0 #f "ERROR: unrecognised sub command to -archive. Run \"megatest\" to see help") (exit)))) "archive-bup-thread")) (thread-start! worker-thread)) (else - (debug:print-info 0 "action not recognised " action))) + (debug:print-info 0 #f "action not recognised " action))) ;; actions that operate on one test at a time can be handled below ;; (let ((sorted-tests (filter vector? @@ -1574,11 +1574,11 @@ (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))) (if (not new-test-dat) (begin - (debug:print 0 "ERROR: 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!") + (debug:print 0 #f "ERROR: 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* @@ -1592,19 +1592,19 @@ (case action ((remove-runs) ;; if the test is a toplevel-with-children issue an error and do not remove (if toplevel-with-children (begin - (debug:print 0 "WARNING: skipping removal of " test-fulln " with run-id " run-id " as it has sub tests") + (debug:print 0 #f "WARNING: skipping removal of " test-fulln " with run-id " run-id " as it has sub tests") (hash-table-set! toplevel-retries test-fulln (+ (hash-table-ref/default toplevel-retries test-fulln 0) 1)) (if (> (hash-table-ref toplevel-retries test-fulln) 3) (if (not (null? tal)) (loop (car tal)(cdr tal))) ;; no else clause - drop it if no more in queue and > 3 tries (let ((newtal (append tal (list test)))) (loop (car newtal)(cdr newtal))))) ;; loop with test still in queue (begin - (debug:print-info 0 "test: " test-name " itest-state: " test-state) + (debug:print-info 0 #f "test: " test-name " itest-state: " test-state) (if (member test-state (list "RUNNING" "LAUNCHED" "REMOTEHOSTSTART" "KILLREQ")) (begin (if (not (hash-table-ref/default test-retry-time test-fulln #f)) (begin ;; want to set to REMOVING BUT CANNOT do it here? @@ -1612,11 +1612,11 @@ (if (> (- (current-seconds)(hash-table-ref test-retry-time test-fulln)) allow-run-time) ;; This test is not in a correct state for cleaning up. Let's try some graceful shutdown steps first ;; Set the test to "KILLREQ" and wait five seconds then try again. Repeat up to five times then give ;; up and blow it away. (begin - (debug:print 0 "WARNING: could not gracefully remove test " test-fulln ", tried to kill it to no avail. Forcing state to FAILEDKILL and continuing") + (debug:print 0 #f "WARNING: could not gracefully remove test " test-fulln ", tried to kill it to no avail. Forcing state to FAILEDKILL and continuing") (mt:test-set-state-status-by-id run-id (db:test-get-id test) "FAILEDKILL" "n/a" #f) (thread-sleep! 1)) (begin (mt:test-set-state-status-by-id run-id (db:test-get-id test) "KILLREQ" "n/a" #f) (thread-sleep! 1))) @@ -1628,28 +1628,28 @@ (runs:remove-test-directory 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))) ((set-state-status) - (debug:print-info 2 "new state " (car state-status) ", new status " (cadr state-status)) + (debug:print-info 2 #f "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)))) ((run-wait) - (debug:print-info 2 "still waiting, " (length tests) " tests still running") + (debug:print-info 2 #f "still waiting, " (length tests) " tests still running") (thread-sleep! 10) (let ((new-tests (proc-get-tests run-id))) (if (null? new-tests) - (debug:print-info 1 "Run completed according to zero tests matching provided criteria.") + (debug:print-info 1 #f "Run completed according to zero tests matching provided criteria.") (loop (car new-tests)(cdr new-tests))))) ((archive) (if (and run-dir (not toplevel-with-children)) (let ((ddir (conc run-dir "/"))) (case (string->symbol (args:get-arg "-archive")) ((save save-remove keep-html) (if (file-exists? ddir) - (debug:print-info 0 "Estimating disk space usage for " test-fulln ": " (common:get-disk-space-used ddir))))))) + (debug:print-info 0 #f "Estimating disk space usage for " test-fulln ": " (common:get-disk-space-used ddir))))))) (if (not (null? tal)) (loop (car tal)(cdr tal)))) ))) ) (if worker-thread (thread-join! worker-thread)))))) @@ -1659,18 +1659,18 @@ (if (null? remtests) ;; no more tests remaining (let* ((dparts (string-split lasttpath "/")) (runpath (conc "/" (string-intersperse (take dparts (- (length dparts) 1)) "/")))) - (debug:print 1 "Removing run: " runkey " " (db:get-value-by-header run header "runname") " and related record") + (debug:print 1 #f "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)) ;; need to figure out the path to the run dir and remove it if empty ;; (if (null? (glob (conc runpath "/*"))) ;; (begin - ;; (debug:print 1 "Removing run dir " runpath) + ;; (debug:print 1 #f "Removing run dir " runpath) ;; (system (conc "rmdir -p " runpath)))) ))))) )) runs) ;; (sqlite3:finalize! (db:delay-if-busy tdbdat)) @@ -1685,40 +1685,40 @@ #f))) (case mode ((remove-data-only)(mt:test-set-state-status-by-id (db:test-get-run_id test)(db:test-get-id test) "CLEANING" "LOCKED" #f)) ((remove-all) (mt:test-set-state-status-by-id (db:test-get-run_id test)(db:test-get-id test) "REMOVING" "LOCKED" #f)) ((archive-remove) (mt:test-set-state-status-by-id (db:test-get-run_id test)(db:test-get-id test) "ARCHIVE_REMOVING" #f #f))) - (debug:print-info 1 "Attempting to remove " (if real-dir (conc " dir " real-dir " and ") "") " link " run-dir) + (debug:print-info 1 #f "Attempting to remove " (if real-dir (conc " dir " real-dir " and ") "") " link " run-dir) (if (and real-dir (> (string-length real-dir) 5) (file-exists? real-dir)) ;; bad heuristic but should prevent /tmp /home etc. (begin ;; let* ((realpath (resolve-pathname run-dir))) - (debug:print-info 1 "Recursively removing " real-dir) + (debug:print-info 1 #f "Recursively removing " real-dir) (if (file-exists? real-dir) (runs:safe-delete-test-dir real-dir) - (debug:print 0 "WARNING: test dir " real-dir " appears to not exist or is not readable"))) + (debug:print 0 #f "WARNING: test dir " real-dir " appears to not exist or is not readable"))) (if real-dir - (debug:print 0 "WARNING: directory " real-dir " does not exist") - (debug:print 0 "WARNING: no real directory corrosponding to link " run-dir ", nothing done"))) + (debug:print 0 #f "WARNING: directory " real-dir " does not exist") + (debug:print 0 #f "WARNING: no real directory corrosponding to link " run-dir ", nothing done"))) (if (symbolic-link? run-dir) (begin - (debug:print-info 1 "Removing symlink " run-dir) + (debug:print-info 1 #f "Removing symlink " run-dir) (handle-exceptions exn - (debug:print 0 "ERROR: Failed to remove symlink " run-dir ((condition-property-accessor 'exn 'message) exn) ", attempting to continue") + (debug:print 0 #f "ERROR: Failed to remove symlink " run-dir ((condition-property-accessor 'exn 'message) exn) ", attempting to continue") (delete-file run-dir))) (if (directory? run-dir) (if (> (directory-fold (lambda (f x)(+ 1 x)) 0 run-dir) 0) - (debug:print 0 "WARNING: refusing to remove " run-dir " as it is not empty") + (debug:print 0 #f "WARNING: refusing to remove " run-dir " as it is not empty") (handle-exceptions exn - (debug:print 0 "ERROR: Failed to remove directory " run-dir ((condition-property-accessor 'exn 'message) exn) ", attempting to continue") + (debug:print 0 #f "ERROR: Failed to remove directory " run-dir ((condition-property-accessor 'exn 'message) exn) ", attempting to continue") (delete-directory run-dir))) (if (and run-dir (not (member run-dir (list "n/a" "/tmp/badname")))) - (debug:print 0 "WARNING: not removing " run-dir " as it either doesn't exist or is not a symlink") - (debug:print 0 "NOTE: the run dir for this test is undefined. Test may have already been deleted.")) + (debug:print 0 #f "WARNING: not removing " run-dir " as it either doesn't exist or is not a symlink") + (debug:print 0 #f "NOTE: the run dir for this test is undefined. Test may have already been deleted.")) )) ;; 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)) @@ -1733,24 +1733,24 @@ (define (general-run-call switchname action-desc proc) (let ((runname (or (args:get-arg "-runname")(args:get-arg ":runname"))) (target (common:args-get-target))) (cond ((not target) - (debug:print 0 "ERROR: Missing required parameter for " switchname ", you must specify the target with -target") + (debug:print 0 #f "ERROR: Missing required parameter for " switchname ", you must specify the target with -target") (exit 3)) ((not runname) - (debug:print 0 "ERROR: Missing required parameter for " switchname ", you must specify the run name with -runname runname") + (debug:print 0 #f "ERROR: Missing required parameter for " switchname ", you must specify the run name with -runname runname") (exit 3)) (else (let (;; (db #f) (keys #f)) (if (launch:setup) (begin (full-runconfigs-read) ;; cache the run config (launch:cache-config)) ;; do not cache here - need to be sure runconfigs is processed (begin - (debug:print 0 "Failed to setup, exiting") + (debug:print 0 #f "Failed to setup, exiting") (exit 1))) (set! keys (keys:config-get-fields *configdat*)) ;; have enough to process -target or -reqtarg here (if (args:get-arg "-reqtarg") (let* ((runconfigf (conc *toppath* "/runconfigs.config")) ;; DO NOT EVALUATE ALL @@ -1757,19 +1757,19 @@ (runconfig (read-config runconfigf #f #t environ-patt: #f))) (if (hash-table-ref/default runconfig (args:get-arg "-reqtarg") #f) (keys:target-set-args keys (args:get-arg "-reqtarg") args:arg-hash) (begin - (debug:print 0 "ERROR: [" (args:get-arg "-reqtarg") "] not found in " runconfigf) + (debug:print 0 #f "ERROR: [" (args:get-arg "-reqtarg") "] not found in " runconfigf) ;; (if db (sqlite3:finalize! db)) (exit 1) ))) (if (args:get-arg "-target") (keys:target-set-args keys (args:get-arg "-target" args:arg-hash) args:arg-hash))) (if (not (car *configinfo*)) (begin - (debug:print 0 "ERROR: Attempted to " action-desc " but run area config file not found") + (debug:print 0 #f "ERROR: Attempted to " action-desc " but run area config file not found") (exit 1)) ;; Extract out stuff needed in most or many calls ;; here then call proc (let* ((keyvals (keys:target->keyval keys target))) (proc target runname keys keyvals))) @@ -1791,11 +1791,11 @@ (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) - (debug:print-info 0 "Skipping lock/unlock on " run-id)))) + (debug:print-info 0 #f "Skipping lock/unlock on " run-id)))) runs))) ;;====================================================================== ;; Rollup runs ;;====================================================================== @@ -1809,11 +1809,11 @@ (for-each (lambda (key) (let* ((idx (cadr key)) (fld (car key)) (val (config-lookup test-conf "test_meta" fld))) - ;; (debug:print 5 "idx: " idx " fld: " fld " val: " val) + ;; (debug:print 5 #f "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))))) '(("author" 2)("owner" 3)("description" 4)("reviewed" 5)("tags" 9)("jobgroup" 10))))) @@ -1829,11 +1829,11 @@ ;; This could probably be refactored into one complex query ... ;; NOT PORTED - DO NOT USE YET ;; (define (runs:rollup-run keys runname user keyvals) - (debug:print 4 "runs:rollup-run, keys: " keys " -runname " runname " user: " user) + (debug:print 4 #f "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 "%" "%")) (curr-tests (mt:get-tests-for-run new-run-id "%/%" '() '())) @@ -1865,24 +1865,24 @@ "VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?);") new-run-id (cddr (vector->list testdat))) (set! new-testdat (car (mt:get-tests-for-run new-run-id (conc testname "/" item-path) '() '()))) (hash-table-set! curr-tests-hash full-name new-testdat) ;; this could be confusing, which record should go into the lookup table? ;; Now duplicate the test steps - (debug:print 4 "Copying records in test_steps from test_id=" (db:test-get-id testdat) " to " (db:test-get-id new-testdat)) + (debug:print 4 #f "Copying records in test_steps from test_id=" (db:test-get-id testdat) " to " (db:test-get-id new-testdat)) (cdb:remote-run ;; to be replaced, note: this routine is not used currently (lambda () (sqlite3:execute db (conc "INSERT OR REPLACE INTO test_steps (test_id,stepname,state,status,event_time,comment) " "SELECT " (db:test-get-id new-testdat) ",stepname,state,status,event_time,comment FROM test_steps WHERE test_id=?;") (db:test-get-id testdat)) ;; Now duplicate the test data - (debug:print 4 "Copying records in test_data from test_id=" (db:test-get-id testdat) " to " (db:test-get-id new-testdat)) + (debug:print 4 #f "Copying records in test_data from test_id=" (db:test-get-id testdat) " to " (db:test-get-id new-testdat)) (sqlite3:execute db (conc "INSERT OR REPLACE INTO test_data (test_id,category,variable,value,expected,tol,units,comment) " "SELECT " (db:test-get-id new-testdat) ",category,variable,value,expected,tol,units,comment FROM test_data WHERE test_id=?;") (db:test-get-id testdat)))) )) prev-tests))) Index: server.scm ================================================================== --- server.scm +++ server.scm @@ -52,12 +52,12 @@ (define (server:launch run-id) (case *transport-type* ((http)(http-transport:launch run-id)) ((nmsg)(nmsg-transport:launch run-id)) ((rpc) (rpc-transport:launch run-id)) - (else (debug:print 0 "ERROR: unknown server type " *transport-type*)))) -;; (else (debug:print 0 "ERROR: No known transport set, transport=" transport ", using rpc") + (else (debug:print 0 #f "ERROR: unknown server type " *transport-type*)))) +;; (else (debug:print 0 #f "ERROR: No known transport set, transport=" transport ", using rpc") ;; (rpc-transport:launch run-id))))) ;;====================================================================== ;; S E R V E R U T I L I T I E S ;;====================================================================== @@ -83,11 +83,11 @@ ;; When using zmq this would send the message back (two step process) ;; with spiffy or rpc this simply returns the return data to be returned ;; (define (server:reply return-addr query-sig success/fail result) - (debug:print-info 11 "server:reply return-addr=" return-addr ", result=" result) + (debug:print-info 11 #f "server:reply return-addr=" return-addr ", result=" result) ;; (send-message pubsock target send-more: #t) ;; (send-message pubsock (case (server:get-transport) ((rpc) (db:obj->string (vector success/fail query-sig result))) ((http) (db:obj->string (vector success/fail query-sig result))) @@ -95,11 +95,11 @@ (let ((pub-socket (vector-ref *runremote* 1))) (send-message pub-socket return-addr send-more: #t) (send-message pub-socket (db:obj->string (vector success/fail query-sig result))))) ((fs) result) (else - (debug:print 0 "ERROR: unrecognised transport type: " *transport-type*) + (debug:print 0 #f "ERROR: unrecognised transport type: " *transport-type*) result))) ;; Given a run id start a server process ### NOTE ### > file 2>&1 ;; if the run-id is zero and the target-host is set ;; try running on that host @@ -113,11 +113,11 @@ (cmdln (conc (common:get-megatest-exe) " -server " (or target-host "-") " -run-id " run-id (if (equal? (configf:lookup *configdat* "server" "daemonize") "yes") (conc " -daemonize -log " logfile) "") " -m testsuite:" testsuite))) ;; (conc " >> " logfile " 2>&1 &"))))) - (debug:print 0 "INFO: Starting server (" cmdln ") as none running ...") + (debug:print 0 #f "INFO: Starting server (" cmdln ") as none running ...") (push-directory *toppath*) (if (not (directory-exists? "logs"))(create-directory "logs")) ;; Rotate logs, logic: ;; if > 500k and older than 1 week, remove previous compressed log and compress this log (directory-fold @@ -125,13 +125,13 @@ (if (and (string-match "^.*.log" file) (> (file-size (conc "logs/" file)) 200000)) (let ((gzfile (conc "logs/" file ".gz"))) (if (file-exists? gzfile) (begin - (debug:print-info 0 "removing " gzfile) + (debug:print-info 0 #f "removing " gzfile) (delete-file gzfile))) - (debug:print-info 0 "compressing " file) + (debug:print-info 0 #f "compressing " file) (system (conc "gzip logs/" file))))) '() "logs") ;; host.domain.tld match host? @@ -139,11 +139,11 @@ ;; look at target host, is it host.domain.tld or ip address and does it ;; match current ip or hostname (not (string-match (conc "("curr-host "|" curr-host"\\..*)") target-host)) (not (equal? curr-ip target-host))) (begin - (debug:print-info 0 "Starting server on " target-host ", logfile is " logfile) + (debug:print-info 0 #f "Starting server on " target-host ", logfile is " logfile) (setenv "TARGETHOST" target-host))) (setenv "TARGETHOST_LOGF" logfile) (common:wait-for-normalized-load 4 " delaying server start due to load") ;; do not try starting servers on an already overloaded machine, just wait forever (system (conc "nbfake " cmdln)) (unsetenv "TARGETHOST_LOGF") @@ -193,11 +193,11 @@ timeout: 2))))) ;; if the server didn't respond we must remove the record (if res #t (begin - (debug:print-info 0 "server at " server " not responding, removing record") + (debug:print-info 0 #f "server at " server " not responding, removing record") (tasks:server-force-clean-running-records-for-run-id (db:delay-if-busy tdbdat) run-id " server:check-if-running") res))) #f)))) @@ -211,11 +211,11 @@ #f))) (toppath (launch:setup)) (server-db-dat (if (not host-port)(tasks:get-server (db:delay-if-busy tdbdat) run-id) #f))) (if (not run-id) (begin - (debug:print 0 "ERROR: must specify run-id when doing ping, -run-id n") + (debug:print 0 #f "ERROR: must specify run-id when doing ping, -run-id n") (print "ERROR: No run-id") (exit 1)) (if (and (not host-port) (not server-db-dat)) (begin @@ -252,14 +252,14 @@ (define (server:login toppath) (lambda (toppath) (set! *last-db-access* (current-seconds)) (if (equal? *toppath* toppath) (begin - ;; (debug:print-info 2 "login successful") + ;; (debug:print-info 2 #f "login successful") #t) (begin - ;; (debug:print-info 2 "login failed") + ;; (debug:print-info 2 #f "login failed") #f)))) (define (server:get-timeout) (let ((tmo (configf:lookup *configdat* "server" "timeout"))) (if (and (string? tmo) Index: sharedat.scm ================================================================== --- sharedat.scm +++ sharedat.scm @@ -115,11 +115,11 @@ (writeable (file-write-access? dbpath)) (dbexists (file-exists? dbpath))) (handle-exceptions exn (begin - (debug:print 2 "ERROR: problem accessing db " dbpath + (debug:print 2 #f "ERROR: problem accessing db " dbpath ((condition-property-accessor 'exn 'message) exn)) (exit 1)) (call-with-database dbpath (lambda (db) Index: spublish.scm ================================================================== --- spublish.scm +++ spublish.scm @@ -115,11 +115,11 @@ (writeable (file-write-access? dbpath)) (dbexists (file-exists? dbpath))) (handle-exceptions exn (begin - (debug:print 2 "ERROR: problem accessing db " dbpath + (debug:print 2 #f "ERROR: problem accessing db " dbpath ((condition-property-accessor 'exn 'message) exn)) (exit 1)) (call-with-database dbpath (lambda (db) Index: sretrieve.scm ================================================================== --- sretrieve.scm +++ sretrieve.scm @@ -56,10 +56,11 @@ ls : list contents of target area get : retrieve data for release -m \"message\" : why retrieved? cp : copy file to current directory log : get listing of recent downloads + shell : start a shell-like interface Part of the Megatest tool suite. Learn more at http://www.kiatoa.com/fossils/megatest Version: " megatest-fossil-hash)) ;; " @@ -112,11 +113,11 @@ (define (sretrieve:db-do configdat proc) (let ((path (configf:lookup configdat "database" "location"))) (if (not path) (begin - (debug:print 0 "[database]\nlocation /some/path\n\n Is missing from the config file!") + (debug:print 0 #f "[database]\nlocation /some/path\n\n Is missing from the config file!") (exit 1))) (if (and path (directory? path) (file-read-access? path)) (let* ((dbpath (conc path "/" *exe-name* ".db")) @@ -123,37 +124,37 @@ (writeable (file-write-access? dbpath)) (dbexists (file-exists? dbpath))) (handle-exceptions exn (begin - (debug:print 2 "ERROR: problem accessing db " dbpath + (debug:print 2 #f "ERROR: problem accessing db " dbpath ((condition-property-accessor 'exn 'message) exn)) (exit 1)) - ;;(debug:print 0 "calling proc " proc "db path " dbpath ) + ;;(debug:print 0 #f "calling proc " proc "db path " dbpath ) (call-with-database dbpath (lambda (db) - ;;(debug:print 0 "calling proc " proc " on db " db) + ;;(debug:print 0 #f "calling proc " proc " on db " db) (set-busy-handler! db (busy-timeout 10000)) ;; 10 sec timeout (if (not dbexists)(sretrieve:initialize-db db)) (proc db))))) - (debug:print 0 "ERROR: invalid path for storing database: " path)))) + (debug:print 0 #f "ERROR: invalid path for storing database: " path)))) ;; copy in directory to dest, validation is done BEFORE calling this ;; (define (sretrieve:get configdat retriever version comment) (let* ((base-dir (configf:lookup configdat "settings" "base-dir")) (datadir (conc base-dir "/" version))) (if (or (not base-dir) (not (file-exists? base-dir))) (begin - (debug:print 0 "ERROR: Bad configuration! base-dir " base-dir " not found") + (debug:print 0 #f "ERROR: Bad configuration! base-dir " base-dir " not found") (exit 1))) (print datadir) (if (not (file-exists? datadir)) (begin - (debug:print 0 "ERROR: Bad version (" version "), no data found at " datadir "." ) + (debug:print 0 #f "ERROR: Bad version (" version "), no data found at " datadir "." ) (exit 1))) (sretrieve:db-do configdat (lambda (db) @@ -186,34 +187,34 @@ (datadir (conc base-dir "/" file)) (filename (conc(pathname-file datadir) "." (pathname-extension datadir)))) (if (or (not base-dir) (not (file-exists? base-dir))) (begin - (debug:print 0 "ERROR: Bad configuration! base-dir " base-dir " not found") + (debug:print 0 #f "ERROR: Bad configuration! base-dir " base-dir " not found") (exit 1))) (print datadir) (if (not (file-exists? datadir)) (begin - (debug:print 0 "ERROR: File (" file "), not found at " base-dir "." ) + (debug:print 0 #f "ERROR: File (" file "), not found at " base-dir "." ) (exit 1))) (if (directory? datadir) (begin - (debug:print 0 "ERROR: (" file ") is a dirctory!! cp cmd works only on files ." ) + (debug:print 0 #f "ERROR: (" file ") is a dirctory!! cp cmd works only on files ." ) (exit 1))) (if(not (string-match (regexp allowed-sub-paths) file)) (begin - (debug:print 0 "ERROR: Access denied to file (" file ")!! " ) + (debug:print 0 #f "ERROR: Access denied to file (" file ")!! " ) (exit 1))) (sretrieve:db-do configdat (lambda (db) (sretrieve:register-action db "cp" retriever datadir comment))) (sretrieve:do-as-calling-user - ;; (debug:print 0 "ph: "(pathname-directory datadir) "!! " ) + ;; (debug:print 0 #f "ph: "(pathname-directory datadir) "!! " ) (change-directory (pathname-directory datadir)) - ;;(debug:print 0 "ph: /bin/tar" (list "chfv" "-" filename) ) + ;;(debug:print 0 #f "ph: /bin/tar" (list "chfv" "-" filename) ) (process-execute "/bin/tar" (list "chfv" "-" filename))) )) ;; ls in file to dest, validation is done BEFORE calling this ;; @@ -223,28 +224,28 @@ (datadir (conc base-dir "/" file)) (filename (conc(pathname-file datadir) "." (pathname-extension datadir)))) (if (or (not base-dir) (not (file-exists? base-dir))) (begin - (debug:print 0 "ERROR: Bad configuration! base-dir " base-dir " not found") + (debug:print 0 #f "ERROR: Bad configuration! base-dir " base-dir " not found") (exit 1))) (print datadir) (if (not (file-exists? datadir)) (begin - (debug:print 0 "ERROR: File (" file "), not found at " base-dir "." ) + (debug:print 0 #f "ERROR: File (" file "), not found at " base-dir "." ) (exit 1))) (if(not (string-match (regexp allowed-sub-paths) file)) (begin - (debug:print 0 "ERROR: Access denied to file (" file ")!! " ) + (debug:print 0 #f "ERROR: Access denied to file (" file ")!! " ) (exit 1))) (sretrieve:do-as-calling-user (lambda () ;;(change-directory datadir) - ;; (debug:print 0 "/usr/bin/find" (list datadir "-ls" "|" "grep" "-E" "'"allowed-file-patt"'")) + ;; (debug:print 0 #f "/usr/bin/find" (list datadir "-ls" "|" "grep" "-E" "'"allowed-file-patt"'")) ;; (status (with-input-from-pipe "find " datadir " -ls | grep -E '" allowed-file-patt "'" (lambda () (read-line)))) - ;; (debug:print 0 status) + ;; (debug:print 0 #f status) (process-execute "/bin/ls" (list "-ls" "-lrt" datadir )) )))) @@ -255,37 +256,37 @@ (define (sretrieve:validate target-dir targ-mk) (let* ((normal-path (normalize-pathname targ-mk)) (targ-path (conc target-dir "/" normal-path))) (if (string-contains normal-path "..") (begin - (debug:print 0 "ERROR: Path " targ-mk " resolved outside target area " target-dir ) + (debug:print 0 #f "ERROR: Path " targ-mk " resolved outside target area " target-dir ) (exit 1))) (if (not (string-contains targ-path target-dir)) (begin - (debug:print 0 "ERROR: You cannot update data outside " target-dir ".") + (debug:print 0 #f "ERROR: You cannot update data outside " target-dir ".") (exit 1))) - (debug:print 0 "Path " targ-mk " is valid.") + (debug:print 0 #f "Path " targ-mk " is valid.") )) ;; make directory in dest ;; (define (sretrieve:mkdir configdat submitter target-dir targ-mk comment) (let ((targ-path (conc target-dir "/" targ-mk))) (if (file-exists? targ-path) (begin - (debug:print 0 "ERROR: target Directory " targ-path " already exist!!") + (debug:print 0 #f "ERROR: target Directory " targ-path " already exist!!") (exit 1))) (sretrieve:db-do configdat (lambda (db) (sretrieve:register-action db "mkdir" submitter targ-mk comment))) (let* ((th1 (make-thread (lambda () (create-directory targ-path #t) - (debug:print 0 " ... dir " targ-path " created")) + (debug:print 0 #f " ... dir " targ-path " created")) "mkdir thread")) (th2 (make-thread (lambda () (let loop () (thread-sleep! 15) @@ -302,25 +303,25 @@ ;; (define (sretrieve:ln configdat submitter target-dir targ-link link-name comment) (let ((targ-path (conc target-dir "/" link-name))) (if (file-exists? targ-path) (begin - (debug:print 0 "ERROR: target file " targ-path " already exist!!") + (debug:print 0 #f "ERROR: target file " targ-path " already exist!!") (exit 1))) (if (not (file-exists? targ-link )) (begin - (debug:print 0 "ERROR: target file " targ-link " does not exist!!") + (debug:print 0 #f "ERROR: target file " targ-link " does not exist!!") (exit 1))) (sretrieve:db-do configdat (lambda (db) (sretrieve:register-action db "ln" submitter link-name comment))) (let* ((th1 (make-thread (lambda () (create-symbolic-link targ-link targ-path ) - (debug:print 0 " ... link " targ-path " created")) + (debug:print 0 #f " ... link " targ-path " created")) "symlink thread")) (th2 (make-thread (lambda () (let loop () (thread-sleep! 15) @@ -338,20 +339,20 @@ ;; (define (sretrieve:rm configdat submitter target-dir targ-file comment) (let ((targ-path (conc target-dir "/" targ-file))) (if (not (file-exists? targ-path)) (begin - (debug:print 0 "ERROR: target file " targ-path " not found, nothing to remove.") + (debug:print 0 #f "ERROR: target file " targ-path " not found, nothing to remove.") (exit 1))) (sretrieve:db-do configdat (lambda (db) (sretrieve:register-action db "rm" submitter targ-file comment))) (let* ((th1 (make-thread (lambda () (delete-file targ-path) - (debug:print 0 " ... file " targ-path " removed")) + (debug:print 0 #f " ... file " targ-path " removed")) "rm thread")) (th2 (make-thread (lambda () (let loop () (thread-sleep! 15) @@ -391,11 +392,11 @@ (define (sretrieve:do-as-calling-user proc) (let ((eid (current-effective-user-id)) (cid (current-user-id))) (if (not (eq? eid cid)) ;; running suid (set! (current-effective-user-id) cid)) - ;; (debug:print 0 "running as " (current-effective-user-id)) + ;; (debug:print 0 #f "running as " (current-effective-user-id)) (proc) (if (not (eq? eid cid)) (set! (current-effective-user-id) eid)))) (define (sretrieve:find name paths) @@ -411,10 +412,55 @@ (define (sretrieve:stderr-print . args) (with-output-to-port (current-error-port) (lambda () (apply print args)))) + +;;====================================================================== +;; SHELL +;;====================================================================== + +(define (toplevel-command . args) #f) +(define (sretrieve:shell) + (use readline) + (let* ((path '()) + (prompt "> ") + (top-areas '("mrwellan" "pjhatwal" "bjbarcla" "ritikaag" "jmoon18")) + (iport (make-readline-port prompt))) + (install-history-file) ;; [homedir] [filename] [nlines]) + (with-input-from-port iport + (lambda () + (let loop ((inl (read-line))) + (if (not (or (eof-object? inl) + (equal? inl "exit"))) + (let* ((parts (string-split inl)) + (cmd (if (null? parts) #f (car parts)))) + (if (not cmd) + (loop (read-line)) + (case (string->symbol cmd) + ((cd) + (if (> (length parts) 1) ;; have a parameter + (set! path (append path (string-split (cadr parts)))) ;; not correct for relative paths + (set! path '()))) + ((ls) + (let* ((thepath (if (> (length parts) 1) ;; have a parameter + (cdr parts) + path)) + (plen (length thepath))) + (cond + ((null? thepath) + (print (string-intersperse top-areas " "))) + ((and (< plen 2) + (member (car thepath) top-areas)) + (system (conc "ls /p/fdk/gwa/" (car thepath)))) + (else ;; have a long path + ;; check for access rights here + (system (conc "ls /p/fdk/gwa/" (string-intersperse thepath "/"))))))) + (else + (print "Got command: " inl)))) + (loop (read-line))))))))) + ;;====================================================================== ;; MAIN ;;====================================================================== @@ -441,20 +487,20 @@ (if (file-exists? upstream-file) (if (or (not (file-exists? package-config)) ;; if not created call the updater, otherwise call only if upstream newer (> (file-modification-time upstream-file)(file-modification-time package-config))) (handle-exceptions exn - (debug:print 0 "ERROR: failed to run script " conversion-script " with params " upstream-file " " package-config) + (debug:print 0 #f "ERROR: failed to run script " conversion-script " with params " upstream-file " " package-config) (let ((pid (process-run conversion-script (list upstream-file package-config)))) (process-wait pid))) - (debug:print 0 "Skipping update of " package-config " from " upstream-file)) - (debug:print 0 "Skipping update of " package-config " as " upstream-file " not found")) + (debug:print 0 #f "Skipping update of " package-config " from " upstream-file)) + (debug:print 0 #f "Skipping update of " package-config " as " upstream-file " not found")) ;; (ini:property-separator-patt " * *") ;; (ini:property-separator #\space) (let ((res (if (file-exists? package-config) (begin - (debug:print 0 "Reading package config " package-config) + (debug:print 0 #f "Reading package config " package-config) (read-config package-config #f #t)) (make-hash-table)))) (pop-directory) res))) @@ -467,60 +513,60 @@ ""))) (default-area (configf:lookup configdat "settings" "default-area"))) ;; otherwise known as the package (if (not base-dir) (begin - (debug:print 0 "[settings]\nbase-dir /some/path\n\n Is MISSING from the config file!") + (debug:print 0 #f "[settings]\nbase-dir /some/path\n\n Is MISSING from the config file!") (exit))) (if (null? allowed-users) (begin - (debug:print 0 "[setings]\nallowed-users user1 user2 ...\n\n Is MISSING from the config file!") + (debug:print 0 #f "[setings]\nallowed-users user1 user2 ...\n\n Is MISSING from the config file!") (exit))) (if (not (member user allowed-users)) (begin - (debug:print 0 "User \"" (current-user-name) "\" does not have access. Exiting") + (debug:print 0 #f "User \"" (current-user-name) "\" does not have access. Exiting") (exit 1))) (case (string->symbol action) ((get) (if (< (length args) 1) (begin - (debug:print 0 "ERROR: Missing arguments; " (string-intersperse args ", ")) + (debug:print 0 #f "ERROR: Missing arguments; " (string-intersperse args ", ")) (exit 1))) (let* ((remargs (args:get-args args '("-m" "-i" "-package") '() args:arg-hash 0)) (version (car args)) (msg (or (args:get-arg "-m") "")) (package-type (or (args:get-arg "-package") default-area)) (exe-dir (configf:lookup configdat "exe-info" "exe-dir"))) ;; (relconfig (sretrieve:load-packages configdat exe-dir package-type))) - (debug:print 0 "retrieving " version " of " package-type " as tar data on stdout") + (debug:print 0 #f "retrieving " version " of " package-type " as tar data on stdout") (sretrieve:get configdat user version msg))) ((cp) (if (< (length args) 1) (begin - (debug:print 0 "ERROR: Missing arguments; " (string-intersperse args ", ")) + (debug:print 0 #f "ERROR: Missing arguments; " (string-intersperse args ", ")) (exit 1))) (let* ((remargs (args:get-args args '("-m" "-i" "-package") '() args:arg-hash 0)) (file (car args)) (msg (or (args:get-arg "-m") "")) ) - (debug:print 0 "copinging " file " to current directory " ) + (debug:print 0 #f "copinging " file " to current directory " ) (sretrieve:cp configdat user file msg))) ((ls) (if (< (length args) 1) (begin - (debug:print 0 "ERROR: Missing arguments; " (string-intersperse args ", ")) + (debug:print 0 #f "ERROR: Missing arguments; " (string-intersperse args ", ")) (exit 1))) (let* ((remargs (args:get-args args '("-m" "-i" "-package") '() args:arg-hash 0)) (dir (car args)) (msg (or (args:get-arg "-m") "")) ) - (debug:print 0 "Listing files in " ) + (debug:print 0 #f "Listing files in " ) (sretrieve:ls configdat user dir msg))) - (else (debug:print 0 "Unrecognised command " action))))) + (else (debug:print 0 #f "Unrecognised command " action))))) ;; ease debugging by loading ~/.dashboardrc - REMOVE FROM PRODUCTION! ;; (let ((debugcontrolf (conc (get-environment-variable "HOME") "/.sretrieverc"))) ;; (if (file-exists? debugcontrolf) ;; (load debugcontrolf))) @@ -558,14 +604,16 @@ (print "Logs : ") (query (for-each-row (lambda (row) (apply print (intersperse row " | ")))) (sql db "SELECT * FROM actions"))))) + ((shell) + (sretrieve:shell)) (else (print "ERROR: Unrecognised command. Try \"sretrieve help\"")))) ;; multi-word commands ((null? rema)(print sretrieve:help)) ((>= (length rema) 2) (apply sretrieve:process-action configdat (car rema)(cdr rema))) - (else (debug:print 0 "ERROR: Unrecognised command. Try \"sretrieve help\""))))) + (else (debug:print 0 #f "ERROR: Unrecognised command. Try \"sretrieve help\""))))) (main) Index: synchash.scm ================================================================== --- synchash.scm +++ synchash.scm @@ -71,11 +71,11 @@ (hash-table-set! synchash synckey myhash))) (for-each (lambda (item) (let ((id (car item)) (dat (cadr item))) - ;; (debug:print-info 2 "Processing item: " item) + ;; (debug:print-info 2 #f "Processing item: " item) (hash-table-set! myhash id dat))) newdat) (for-each (lambda (id) (hash-table-delete! myhash id)) @@ -85,11 +85,11 @@ (list newdat removs))) ;; synchash)) (define *synchashes* (make-hash-table)) (define (synchash:server-get dbstruct run-id proc synckey keynum params) - ;; (debug:print-info 2 "synckey: " synckey ", keynum: " keynum ", params: " params) + ;; (debug:print-info 2 #f "synckey: " synckey ", keynum: " keynum ", params: " params) (let* ((dbdat (db:get-db dbstruct run-id)) (db (db:dbdat-get-db dbdat)) (synchash (hash-table-ref/default *synchashes* synckey #f)) (newdat (apply (case proc ((db:get-runs) db:get-runs) @@ -103,22 +103,22 @@ (make-indexed (lambda (x) (list (vector-ref x keynum) x)))) ;; Now process newdat based on the query type (set! postdat (case proc ((db:get-runs) - ;; (debug:print-info 2 "Get runs call") + ;; (debug:print-info 2 #f "Get runs call") (let ((header (vector-ref newdat 0)) (data (vector-ref newdat 1))) - ;; (debug:print-info 2 "header: " header ", data: " data) + ;; (debug:print-info 2 #f "header: " header ", data: " data) (cons (list "header" header) ;; add the header keyed by the word "header" (map make-indexed data)))) ;; add each element keyed by the keynum'th val (else - ;; (debug:print-info 2 "Non-get runs call") + ;; (debug:print-info 2 #f "Non-get runs call") (map make-indexed newdat)))) - ;; (debug:print-info 2 "postdat: " postdat) + ;; (debug:print-info 2 #f "postdat: " postdat) ;; (if (not indb)(sqlite3:finalize! db)) (if (not synchash) (begin (set! synchash (make-hash-table)) (hash-table-set! *synchashes* synckey synchash))) (synchash:get-delta postdat synchash))) Index: tasks.scm ================================================================== --- tasks.scm +++ tasks.scm @@ -25,27 +25,27 @@ ;; wait up to aprox n seconds for a journal to go away ;; (define (tasks:wait-on-journal path n #!key (remove #f)(waiting-msg #f)) (if (not (string? path)) - (debug:print 0 "ERROR: Called tasks:wait-on-journal with path=" path " (not a string)") + (debug:print 0 #f "ERROR: Called tasks:wait-on-journal with path=" path " (not a string)") (let ((fullpath (conc path "-journal"))) (handle-exceptions exn (begin (print-call-chain (current-error-port)) - (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) - (debug:print 0 " exn=" (condition->list exn)) - (debug:print 0 "tasks:wait-on-journal failed. Continuing on, you can ignore this call-chain") + (debug:print 0 #f " message: " ((condition-property-accessor 'exn 'message) exn)) + (debug:print 0 #f " exn=" (condition->list exn)) + (debug:print 0 #f "tasks:wait-on-journal failed. Continuing on, you can ignore this call-chain") #t) ;; if stuff goes wrong just allow it to move on (let loop ((journal-exists (file-exists? fullpath)) (count n)) ;; wait ten times ... (if journal-exists (begin (if (and waiting-msg (eq? (modulo n 30) 0)) - (debug:print 0 waiting-msg)) + (debug:print 0 #f waiting-msg)) (if (> count 0) (begin (thread-sleep! 1) (loop (file-exists? fullpath) (- count 1))) @@ -59,11 +59,11 @@ (configf:lookup *configdat* "setup" "dbdir") (conc (configf:lookup *configdat* "setup" "linktree") "/.db")))) (handle-exceptions exn (begin - (debug:print 0 "ERROR: Couldn't create path to " dbdir) + (debug:print 0 #f "ERROR: Couldn't create path to " dbdir) (exit 1)) (if (not (directory? dbdir))(create-directory dbdir #t))) dbdir)) ;; If file exists AND @@ -81,18 +81,18 @@ (handle-exceptions exn (if (> numretries 0) (begin (print-call-chain (current-error-port)) - (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) - (debug:print 0 " exn=" (condition->list exn)) + (debug:print 0 #f " message: " ((condition-property-accessor 'exn 'message) exn)) + (debug:print 0 #f " exn=" (condition->list exn)) (thread-sleep! 1) (tasks:open-db numretries (- numretries 1))) (begin (print-call-chain (current-error-port)) - (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) - (debug:print 0 " exn=" (condition->list exn)))) + (debug:print 0 #f " message: " ((condition-property-accessor 'exn 'message) exn)) + (debug:print 0 #f " exn=" (condition->list exn)))) (let* ((dbpath (tasks:get-task-db-path)) (dbfile (conc dbpath "/monitor.db")) (avail (tasks:wait-on-journal dbpath 10)) ;; wait up to about 10 seconds for the journal to go away (exists (file-exists? dbpath)) (write-access (file-write-access? dbpath)) @@ -286,21 +286,21 @@ port)))))) (define (tasks:server-am-i-the-server? mdb run-id) (let* ((all (tasks:server-get-servers-vying-for-run-id mdb run-id)) (first (if (null? all) - #f;; (begin (debug:print 0 "ERROR: no servers listed, should be at least one by now.") + #f;; (begin (debug:print 0 #f "ERROR: no servers listed, should be at least one by now.") ;; (sqlite3:finalize! mdb) ;; (exit 1)) (car (db:get-rows all))))) (if first (let* ((header (db:get-header all)) (id (db:get-value-by-header first header "id")) (hostname (db:get-value-by-header first header "hostname")) (pid (db:get-value-by-header first header "pid")) (priority (db:get-value-by-header first header "priority"))) - ;; (debug:print 0 "INFO: am-i-the-server got record " first) + ;; (debug:print 0 #f "INFO: am-i-the-server got record " first) ;; for now a basic check. add tiebreaking by priority later (if (and (equal? hostname (get-host-name)) (equal? pid (current-process-id))) id #f)) @@ -326,20 +326,20 @@ (best #f)) (handle-exceptions exn (begin (print-call-chain (current-error-port)) - (debug:print 0 "WARNING: tasks:get-server db access error.") - (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) - (debug:print 0 " for run " run-id) + (debug:print 0 #f "WARNING: tasks:get-server db access error.") + (debug:print 0 #f " message: " ((condition-property-accessor 'exn 'message) exn)) + (debug:print 0 #f " for run " run-id) (print-call-chain (current-error-port)) (if (> retries 0) (begin - (debug:print 0 " trying call to tasks:get-server again in 10 seconds") + (debug:print 0 #f " trying call to tasks:get-server again in 10 seconds") (thread-sleep! 10) (tasks:get-server mdb run-id retries: (- retries 0))) - (debug:print 0 "10 tries of tasks:get-server all crashed and burned. Giving up and returning \"no server found\""))) + (debug:print 0 #f "10 tries of tasks:get-server all crashed and burned. Giving up and returning \"no server found\""))) (sqlite3:for-each-row (lambda (id interface port pubport transport pid hostname) (set! res (vector id interface port pubport transport pid hostname))) mdb ;; removed: @@ -373,15 +373,15 @@ ;; (maxqry (cdr (rmt:get-max-query-average run-id))) ;; (threshold (string->number (or (configf:lookup *configdat* "server" "server-query-threshold") "10")))) ;; (cond ;; (forced ;; (if (common:low-noise-print 60 run-id "server required is set") -;; (debug:print-info 0 "Server required is set, starting server for run-id " run-id ".")) +;; (debug:print-info 0 #f "Server required is set, starting server for run-id " run-id ".")) ;; #t) ;; ((> maxqry threshold) ;; (if (common:low-noise-print 60 run-id "Max query time execeeded") -;; (debug:print-info 0 "Max avg query time of " maxqry "ms exceeds limit of " threshold "ms, server needed for run-id " run-id ".")) +;; (debug:print-info 0 #f "Max avg query time of " maxqry "ms exceeds limit of " threshold "ms, server needed for run-id " run-id ".")) ;; #t) ;; (else ;; #f)))) ;; try to start a server and wait for it to be available @@ -392,11 +392,11 @@ (delay-time 0)) (if (and (not server-dat) (< delay-time delay-max-tries)) (begin (if (common:low-noise-print 60 "tasks:start-and-wait-for-server" run-id) - (debug:print 0 "Try starting server for run-id " run-id)) + (debug:print 0 #f "Try starting server for run-id " run-id)) (thread-sleep! (/ (random 2000) 1000)) (server:kind-run run-id) (thread-sleep! (min delay-time 1)) (loop (tasks:get-server (db:delay-if-busy tdbdat) run-id)(+ delay-time 1)))))) @@ -424,11 +424,11 @@ (reverse res))) ;; no elegance here ... ;; (define (tasks:kill-server hostname pid) - (debug:print-info 0 "Attempting to kill server process " pid " on host " hostname) + (debug:print-info 0 #f "Attempting to kill server process " pid " on host " hostname) (setenv "TARGETHOST" hostname) (setenv "TARGETHOST_LOGF" "server-kills.log") (system (conc "nbfake kill " pid)) (unsetenv "TARGETHOST_LOGF") (unsetenv "TARGETHOST")) @@ -441,14 +441,14 @@ (if sdat (let ((hostname (vector-ref sdat 6)) (pid (vector-ref sdat 5)) (server-id (vector-ref sdat 0))) (tasks:server-set-state! (db:delay-if-busy tdbdat) server-id "killed") - (debug:print-info 0 "Killing server " server-id " for run-id " run-id " on host " hostname " with pid " pid) + (debug:print-info 0 #f "Killing server " server-id " for run-id " run-id " on host " hostname " with pid " pid) (tasks:kill-server hostname pid) (tasks:server-delete-record (db:delay-if-busy tdbdat) server-id tag) ) - (debug:print-info 0 "No server found for run-id " run-id ", nothing to kill")) + (debug:print-info 0 #f "No server found for run-id " run-id ", nothing to kill")) ;; (sqlite3:finalize! tdb) )) ;;====================================================================== ;; M O N I T O R S @@ -519,11 +519,11 @@ res)) ;; (define (tasks:start-monitor db mdb) (if (> (tasks:get-num-alive-monitors mdb) 2) ;; have two running, no need for more - (debug:print-info 1 "Not starting monitor, already have more than two running") + (debug:print-info 1 #f "Not starting monitor, already have more than two running") (let* ((megatestdb (conc *toppath* "/megatest.db")) (monitordbf (conc (db:dbfile-path #f) "/monitor.db")) (last-db-update 0)) ;; (file-modification-time megatestdb))) (task:register-monitor mdb) (let loop ((count 0) @@ -747,28 +747,28 @@ ;; (define (tasks:kill-runner target run-name testpatt) (let ((records (rmt:tasks-find-task-queue-records 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 "No run launching processes found for " target " / " run-name " with testpatt " (or testpatt "* no testpatt specified! *")) - (debug:print 0 "Found " (length records) " run(s) to kill.")) + (debug:print 0 #f "No run launching processes found for " target " / " run-name " with testpatt " (or testpatt "* no testpatt specified! *")) + (debug:print 0 #f "Found " (length records) " run(s) to kill.")) (for-each (lambda (record) (let* ((param-key (list-ref record 8)) (match-dat (string-search hostpid-rx param-key))) (if match-dat (let ((hostname (cadr match-dat)) (pid (string->number (caddr match-dat)))) - (debug:print 0 "Sending SIGINT to process " pid " on host " hostname) + (debug:print 0 #f "Sending SIGINT to process " pid " on host " hostname) (if (equal? (get-host-name) hostname) (if (process:alive? pid) (begin (handle-exceptions exn (begin - (debug:print 0 "Kill of process " pid " on host " hostname " failed.") - (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) + (debug:print 0 #f "Kill of process " pid " on host " hostname " failed.") + (debug:print 0 #f " message: " ((condition-property-accessor 'exn 'message) exn)) #t) (process-signal pid signal/int) (thread-sleep! 5) (if (process:alive? pid) (process-signal pid signal/kill))))) @@ -778,11 +778,11 @@ (setenv "TARGETHOST_LOGF" "server-kills.log") (system (conc "nbfake kill " pid)) (if old-targethost (setenv "TARGETHOST" old-targethost)) (unsetenv "TARGETHOST") (unsetenv "TARGETHOST_LOGF")))) - (debug:print 0 "ERROR: no record or improper record for " target "/" run-name " in tasks_queue in main.db")))) + (debug:print 0 #f "ERROR: no record or improper record for " target "/" run-name " in tasks_queue in main.db")))) records))) ;; (define (tasks:start-run dbstruct mdb task) ;; (let ((flags (make-hash-table))) ;; (hash-table-set! flags "-rerun" "NOT_STARTED") Index: tdb.scm ================================================================== --- tdb.scm +++ tdb.scm @@ -45,11 +45,11 @@ ;; ;; Moved these tables into .db ;; THIS CODE TO BE REMOVED ;; (define (open-test-db work-area) - (debug:print-info 11 "open-test-db " work-area) + (debug:print-info 11 #f "open-test-db " work-area) (if (and work-area (directory? work-area) (file-read-access? work-area)) (let* ((dbpath (conc work-area "/testdat.db")) (dbexists (file-exists? dbpath)) @@ -56,11 +56,11 @@ (work-area-writeable (file-write-access? work-area)) (db (handle-exceptions ;; open the db if area writeable or db pre-existing. open in-mem otherwise. if exception, open in-mem exn (begin (print-call-chain (current-error-port)) - (debug:print 2 "ERROR: problem accessing test db " work-area ", you probably should clean and re-run this test" + (debug:print 2 #f "ERROR: problem accessing test db " work-area ", you probably should clean and re-run this test" ((condition-property-accessor 'exn 'message) exn)) (set! dbexists #f) ;; must force re-creation of tables, more tom-foolery (sqlite3:open-database ":memory:")) ;; open an in-memory db to allow readonly access (if (or work-area-writeable dbexists) @@ -76,48 +76,48 @@ *db-write-access*) (sqlite3:set-busy-handler! db handler)) (if (not dbexists) (begin (db:set-sync db) ;; (sqlite3:execute db "PRAGMA synchronous = FULL;") - (debug:print-info 11 "Initialized test database " dbpath) + (debug:print-info 11 #f "Initialized test database " dbpath) (tdb:testdb-initialize db))) ;; (sqlite3:execute db "PRAGMA synchronous = 0;") - (debug:print-info 11 "open-test-db END (sucessful)" work-area) + (debug:print-info 11 #f "open-test-db END (sucessful)" work-area) ;; now let's test that everything is correct (handle-exceptions exn (begin (print-call-chain (current-error-port)) - (debug:print 0 "ERROR: problem accessing test db " work-area ", you probably should clean and re-run this test or remove the file " + (debug:print 0 #f "ERROR: problem accessing test db " work-area ", you probably should clean and re-run this test or remove the file " dbpath ".\n " ((condition-property-accessor 'exn 'message) exn)) #f) ;; Is there a cheaper single line operation that will check for existance of a table ;; and raise an exception ? (sqlite3:execute db "SELECT id FROM test_data LIMIT 1;")) db) ;; no work-area or not readable - create a placeholder to fake rest of world out (let ((baddb (sqlite3:open-database ":memory:"))) - (debug:print-info 11 "open-test-db END (unsucessful)" work-area) + (debug:print-info 11 #f "open-test-db END (unsucessful)" work-area) ;; 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)) (let* ((test-path (if work-area work-area (rmt:test-get-rundir-from-test-id test-id)))) - (debug:print 3 "TEST PATH: " test-path) + (debug:print 3 #f "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)) (let* ((test-path (if work-area work-area (db:test-get-rundir-from-test-id dbstruct run-id test-id)))) - (debug:print 3 "TEST PATH: " test-path) + (debug:print 3 #f "TEST PATH: " test-path) (open-test-db test-path))) ;; find and open the testdat.db file for an existing test (define (tdb:open-run-close-db-by-test-id-local dbstruct run-id test-id work-area proc . params) (let* ((test-path (if work-area @@ -125,11 +125,11 @@ (db:test-get-rundir-from-test-id dbstruct run-id test-id))) (tdb (open-test-db test-path))) (apply proc tdb params))) (define (tdb:testdb-initialize db) - (debug:print 11 "db:testdb-initialize START") + (debug:print 11 #f "db:testdb-initialize START") (sqlite3:with-transaction db (lambda () (for-each (lambda (sqlcmd) @@ -171,11 +171,11 @@ id INTEGER PRIMARY KEY, var TEXT, val TEXT, ackstate INTEGER DEFAULT 0, CONSTRAINT metadat_constraint UNIQUE (var));")))) - (debug:print 11 "db:testdb-initialize END")) + (debug:print 11 #f "db:testdb-initialize END")) ;; This routine moved to db:read-test-data ;; (define (tdb:read-test-data tdb test-id categorypatt) (let ((res '())) @@ -208,11 +208,11 @@ ;; NOTE: Run this local with #f for db !!! (define (tdb:load-test-data run-id test-id) (let loop ((lin (read-line))) (if (not (eof-object? lin)) (begin - (debug:print 4 lin) + (debug:print 4 #f lin) (rmt:csv->test-data 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)) @@ -220,11 +220,11 @@ ;; NOTE: Run this local with #f for db !!! (define (tdb:load-logpro-data run-id test-id) (let loop ((lin (read-line))) (if (not (eof-object? lin)) (begin - (debug:print 4 lin) + (debug:print 4 #f lin) (rmt:csv->test-data 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)) @@ -246,17 +246,17 @@ ;; (define (tdb:get-steps-table steps);; organise the steps for better readability (let ((res (make-hash-table))) (for-each (lambda (step) - (debug:print 6 "step=" step) + (debug:print 6 #f "step=" step) (let ((record (hash-table-ref/default res (tdb:step-get-stepname step) ;; stepname start end status Duration Logfile (vector (tdb:step-get-stepname step) "" "" "" "" "")))) - (debug:print 6 "record(before) = " record + (debug:print 6 #f "record(before) = " record "\nid: " (tdb:step-get-id step) "\nstepname: " (tdb:step-get-stepname step) "\nstate: " (tdb:step-get-state step) "\nstatus: " (tdb:step-get-status step) "\ntime: " (tdb:step-get-event_time step)) @@ -270,11 +270,11 @@ ((end) (vector-set! record 2 (any->number (tdb:step-get-event_time step))) (vector-set! record 3 (tdb:step-get-status step)) (vector-set! record 4 (let ((startt (any->number (vector-ref record 1))) (endt (any->number (vector-ref record 2)))) - (debug:print 4 "record[1]=" (vector-ref record 1) + (debug:print 4 #f "record[1]=" (vector-ref record 1) ", startt=" startt ", endt=" endt ", get-status: " (tdb:step-get-status step)) (if (and (number? startt)(number? endt)) (seconds->hr-min-sec (- endt startt)) "-1"))) (if (> (string-length (tdb:step-get-logfile step)) @@ -283,11 +283,11 @@ (else (vector-set! record 2 (tdb:step-get-state step)) (vector-set! record 3 (tdb:step-get-status step)) (vector-set! record 4 (tdb:step-get-event_time step)))) (hash-table-set! res (tdb:step-get-stepname step) record) - (debug:print 6 "record(after) = " record + (debug:print 6 #f "record(after) = " record "\nid: " (tdb:step-get-id step) "\nstepname: " (tdb:step-get-stepname step) "\nstate: " (tdb:step-get-state step) "\nstatus: " (tdb:step-get-status step) "\ntime: " (tdb:step-get-event_time step)))) @@ -307,17 +307,17 @@ (define (tdb:get-steps-table-list steps) ;; organise the steps for better readability (let ((res (make-hash-table))) (for-each (lambda (step) - (debug:print 6 "step=" step) + (debug:print 6 #f "step=" step) (let ((record (hash-table-ref/default res (tdb:step-get-stepname step) ;; stepname start end status (vector (tdb:step-get-stepname step) "" "" "" "" "")))) - (debug:print 6 "record(before) = " record + (debug:print 6 #f "record(before) = " record "\nid: " (tdb:step-get-id step) "\nstepname: " (tdb:step-get-stepname step) "\nstate: " (tdb:step-get-state step) "\nstatus: " (tdb:step-get-status step) "\ntime: " (tdb:step-get-event_time step)) @@ -331,11 +331,11 @@ ((end) (vector-set! record 2 (any->number (tdb:step-get-event_time step))) (vector-set! record 3 (tdb:step-get-status step)) (vector-set! record 4 (let ((startt (any->number (vector-ref record 1))) (endt (any->number (vector-ref record 2)))) - (debug:print 4 "record[1]=" (vector-ref record 1) + (debug:print 4 #f "record[1]=" (vector-ref record 1) ", startt=" startt ", endt=" endt ", get-status: " (tdb:step-get-status step)) (if (and (number? startt)(number? endt)) (seconds->hr-min-sec (- endt startt)) "-1"))) (if (> (string-length (tdb:step-get-logfile step)) @@ -344,11 +344,11 @@ (else (vector-set! record 2 (tdb:step-get-state step)) (vector-set! record 3 (tdb:step-get-status step)) (vector-set! record 4 (tdb:step-get-event_time step)))) (hash-table-set! res (tdb:step-get-stepname step) record) - (debug:print 6 "record(after) = " record + (debug:print 6 #f "record(after) = " record "\nid: " (tdb:step-get-id step) "\nstepname: " (tdb:step-get-stepname step) "\nstate: " (tdb:step-get-state step) "\nstatus: " (tdb:step-get-status step) "\ntime: " (tdb:step-get-event_time step)))) @@ -395,7 +395,7 @@ (if (sqlite3:database? tdb) (begin (sqlite3:execute tdb "INSERT INTO test_rundat (update_time,cpuload,diskfree,run_duration) VALUES (strftime('%s','now'),?,?,?);" cpuload diskfree minutes) (sqlite3:finalize! tdb)) - (debug:print 2 "Can't update testdat.db for test " test-id " read-only or non-existant")))) + (debug:print 2 #f "Can't update testdat.db for test " test-id " read-only or non-existant")))) Index: tests.scm ================================================================== --- tests.scm +++ tests.scm @@ -47,11 +47,11 @@ (filter (lambda (d) (if (directory-exists? d) d (begin (if (common:low-noise-print 60 "tests:get-tests-search-path" d) - (debug:print 0 "WARNING: problem with directory " d ", dropping it from tests path")) + (debug:print 0 #f "WARNING: problem with directory " d ", dropping it from tests path")) #f))) (append paths (list (conc *toppath* "/tests")))))) (define (tests:get-valid-tests test-registry tests-paths) (if (null? tests-paths) @@ -101,11 +101,11 @@ (tests:match (car itemmap) testname #f)) itemmaps))) (if (null? best-matches) #f (let ((res (car best-matches))) - ;; (debug:print 0 "res=" res) + ;; (debug:print 0 #f "res=" res) (cond ((string? res) res) ;;; FIX THE ROOT CAUSE HERE .... ((null? res) #f) ((string? (cdr res)) (cdr res)) ;; it is a pair ((string? (cadr res))(cadr res)) ;; it is a list @@ -120,23 +120,23 @@ ;; process can know to call items:get-items-from-config ;; if either is a list and none is a proc go ahead and call get-items ;; otherwise return #f - this is not an iterated test (cond ((procedure? items) - (debug:print-info 4 "items is a procedure, will calc later") + (debug:print-info 4 #f "items is a procedure, will calc later") items) ;; calc later ((procedure? itemstable) - (debug:print-info 4 "itemstable is a procedure, will calc later") + (debug:print-info 4 #f "itemstable is a procedure, will calc later") itemstable) ;; calc later ((filter (lambda (x) (let ((val (car x))) (if (procedure? val) val #f))) (append (if (list? items) items '()) (if (list? itemstable) itemstable '()))) 'have-procedure) ((or (list? items)(list? itemstable)) ;; calc now - (debug:print-info 4 "items and itemstable are lists, calc now\n" + (debug:print-info 4 #f "items and itemstable are lists, calc now\n" " items: " items " itemstable: " itemstable) (items:get-items-from-config tconfig)) (else #f)))) ;; not iterated @@ -145,50 +145,50 @@ (define (tests:get-waitons test-name all-tests-registry) (let* ((config (tests:get-testconfig test-name all-tests-registry 'return-procs))) (let ((instr (if config (config-lookup config "requirements" "waiton") (begin ;; No config means this is a non-existant test - (debug:print 0 "ERROR: non-existent required test \"" test-name "\"") + (debug:print 0 #f "ERROR: non-existent required test \"" test-name "\"") (exit 1)))) (instr2 (if config (config-lookup config "requirements" "waitor") ""))) - (debug:print-info 8 "waitons string is " instr ", waitors string is " instr2) + (debug:print-info 8 #f "waitons string is " instr ", waitors string is " instr2) (let ((newwaitons (string-split (cond ((procedure? instr) ;; here (let ((res (instr))) - (debug:print-info 8 "waiton procedure results in string " res " for test " test-name) + (debug:print-info 8 #f "waiton procedure results in string " res " for test " test-name) res)) ((string? instr) instr) (else - ;; NOTE: This is actually the case of *no* waitons! ;; (debug:print 0 "ERROR: something went wrong in processing waitons for test " test-name) + ;; NOTE: This is actually the case of *no* waitons! ;; (debug:print 0 #f "ERROR: something went wrong in processing waitons for test " test-name) "")))) (newwaitors (string-split (cond ((procedure? instr2) (let ((res (instr2))) - (debug:print-info 8 "waitor procedure results in string " res " for test " test-name) + (debug:print-info 8 #f "waitor procedure results in string " res " for test " test-name) res)) ((string? instr2) instr2) (else - ;; NOTE: This is actually the case of *no* waitons! ;; (debug:print 0 "ERROR: something went wrong in processing waitons for test " test-name) + ;; NOTE: This is actually the case of *no* waitons! ;; (debug:print 0 #f "ERROR: something went wrong in processing waitons for test " test-name) ""))))) (values ;; the waitons (filter (lambda (x) (if (hash-table-ref/default all-tests-registry x #f) #t (begin - (debug:print 0 "ERROR: test " test-name " has unrecognised waiton testname " x) + (debug:print 0 #f "ERROR: test " test-name " has unrecognised waiton testname " x) #f))) newwaitons) (filter (lambda (x) (if (hash-table-ref/default all-tests-registry x #f) #t (begin - (debug:print 0 "ERROR: test " test-name " has unrecognised waiton testname " x) + (debug:print 0 #f "ERROR: test " test-name " has unrecognised waiton testname " x) #f))) newwaitors) config))))) ;; given waiting-test that is waiting on waiton-test extend test-patt appropriately @@ -302,29 +302,29 @@ (waiver-rx (regexp "^(\\S+)\\s+(.*)$")) (diff-rule "diff %file1% %file2%") (logpro-rule "diff %file1% %file2% | logpro %waivername%.logpro %waivername%.html")) (if (not (file-exists? test-rundir)) (begin - (debug:print 0 "ERROR: test run directory is gone, cannot propagate waiver") + (debug:print 0 #f "ERROR: test run directory is gone, cannot propagate waiver") #f) (begin (push-directory test-rundir) (let ((result (if (null? waivers) #f (let loop ((hed (car waivers)) (tal (cdr waivers))) - (debug:print 0 "INFO: Applying waiver rule \"" hed "\"") + (debug:print 0 #f "INFO: Applying waiver rule \"" hed "\"") (let* ((waiver (configf:lookup testconfig "waivers" hed)) (wparts (if waiver (string-match waiver-rx waiver) #f)) (waiver-rule (if wparts (cadr wparts) #f)) (waiver-glob (if wparts (caddr wparts) #f)) (logpro-file (if waiver (let ((fname (conc hed ".logpro"))) (if (file-exists? fname) fname (begin - (debug:print 0 "INFO: No logpro file " fname " falling back to diff") + (debug:print 0 #f "INFO: No logpro file " fname " falling back to diff") #f))) #f)) ;; if rule by name of waiver-rule is found in testconfig - use it ;; else if waivername.logpro exists use logpro-rule ;; else default to diff-rule @@ -332,21 +332,21 @@ (if rule rule (if logpro-file logpro-rule (begin - (debug:print 0 "INFO: No logpro file " logpro-file " found, using diff rule") + (debug:print 0 #f "INFO: No logpro file " logpro-file " found, using diff rule") diff-rule))))) ;; (string-substitute "%file1%" "foofoo.txt" "This is %file1% and so is this %file1%." #t) (processed-cmd (string-substitute "%file1%" (conc test-rundir "/" waiver-glob) (string-substitute "%file2%" (conc prev-rundir "/" waiver-glob) (string-substitute "%waivername%" hed rule-string #t) #t) #t)) (res #f)) - (debug:print 0 "INFO: waiver command is \"" processed-cmd "\"") + (debug:print 0 #f "INFO: waiver command is \"" processed-cmd "\"") (if (eq? (system processed-cmd) 0) (if (null? tal) #t (loop (car tal)(cdr tal))) #f)))))) @@ -377,11 +377,11 @@ (waived (if prev-test (if prev-test ;; true if we found a previous test in this run series (let ((prev-status (db:test-get-status prev-test)) (prev-state (db:test-get-state prev-test)) (prev-comment (db:test-get-comment prev-test))) - (debug:print 4 "prev-status " prev-status ", prev-state " prev-state ", prev-comment " prev-comment) + (debug:print 4 #f "prev-status " prev-status ", prev-state " prev-state ", prev-comment " prev-comment) (if (and (equal? prev-state "COMPLETED") (equal? prev-status "WAIVED")) (if comment comment prev-comment) ;; waived is either the comment or #f @@ -390,11 +390,11 @@ #f))) (if (and waived (tests:check-waiver-eligibility testdat prev-test)) (set! real-status "WAIVED")) - (debug:print 4 "real-status " real-status ", waived " waived ", status " status) + (debug:print 4 #f "real-status " real-status ", waived " waived ", status " status) ;; update the primary record IF state AND status are defined (if (and state status) (begin (rmt:test-set-status-state run-id test-id real-status state (if waived waived comment)) @@ -423,11 +423,11 @@ (expected (hash-table-ref/default otherdat ":expected" #f)) (tol (hash-table-ref/default otherdat ":tol" #f)) (units (hash-table-ref/default otherdat ":units" "")) (type (hash-table-ref/default otherdat ":type" "")) (dcomment (hash-table-ref/default otherdat ":comment" ""))) - (debug:print 4 + (debug:print 4 #f "category: " category ", variable: " variable ", value: " value ", expected: " expected ", tol: " tol ", units: " units) (if (and value expected tol) ;; all three required (let ((dat (conc category "," variable "," @@ -465,15 +465,15 @@ (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 ... (begin - (debug:print 4 "Found path: " path) + (debug:print 4 #f "Found path: " path) (change-directory path)) ;; (set! outputfilename (conc path "/" outputfilename))) - (debug:print 0 "ERROR: summarize-items for run-id=" run-id ", test-name=" test-name ", no such path: " path)) - (debug:print 4 "summarize-items with logf " logf ", outputfilename " outputfilename " and force " force) + (debug:print 0 #f "ERROR: summarize-items for run-id=" run-id ", test-name=" test-name ", no such path: " path)) + (debug:print 4 #f "summarize-items with logf " logf ", outputfilename " outputfilename " and force " force) (if (or (equal? logf "logs/final.log") (equal? logf outputfilename) force) (let ((my-start-time (current-seconds)) (lockf (conc outputfilename ".lock"))) @@ -494,11 +494,11 @@ ;; 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 "Waiting to update " outputfilename ", another test currently updating it") + (debug:print-info 1 #f "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) (let ((counts (make-hash-table)) @@ -579,17 +579,17 @@ ;; (let ((steps (db:get-steps-for-test db test-id work-area: work-area))) ;; organise the steps for better readability (let ((res (make-hash-table))) (for-each (lambda (step) - (debug:print 6 "step=" step) + (debug:print 6 #f "step=" step) (let ((record (hash-table-ref/default res (tdb:step-get-stepname step) ;; stepname start end status Duration Logfile Comment (vector (tdb:step-get-stepname step) "" "" "" "" "" "")))) - (debug:print 6 "record(before) = " record + (debug:print 6 #f "record(before) = " record "\nid: " (tdb:step-get-id step) "\nstepname: " (tdb:step-get-stepname step) "\nstate: " (tdb:step-get-state step) "\nstatus: " (tdb:step-get-status step) "\ntime: " (tdb:step-get-event_time step)) @@ -603,11 +603,11 @@ ((end) (vector-set! record 2 (any->number (tdb:step-get-event_time step))) (vector-set! record 3 (tdb:step-get-status step)) (vector-set! record 4 (let ((startt (any->number (vector-ref record 1))) (endt (any->number (vector-ref record 2)))) - (debug:print 4 "record[1]=" (vector-ref record 1) + (debug:print 4 #f "record[1]=" (vector-ref record 1) ", startt=" startt ", endt=" endt ", get-status: " (tdb:step-get-status step)) (if (and (number? startt)(number? endt)) (seconds->hr-min-sec (- endt startt)) "-1"))) (if (> (string-length (tdb:step-get-logfile step)) @@ -620,11 +620,11 @@ (vector-set! record 2 (tdb:step-get-state step)) (vector-set! record 3 (tdb:step-get-status step)) (vector-set! record 4 (tdb:step-get-event_time step)) (vector-set! record 6 (tdb:step-get-comment step)))) (hash-table-set! res (tdb:step-get-stepname step) record) - (debug:print 6 "record(after) = " record + (debug:print 6 #f "record(after) = " record "\nid: " (tdb:step-get-id step) "\nstepname: " (tdb:step-get-stepname step) "\nstate: " (tdb:step-get-state step) "\nstatus: " (tdb:step-get-status step) "\ntime: " (tdb:step-get-event_time step)))) @@ -812,21 +812,21 @@ (if tcfg (hash-table-set! *testconfigs* test-name tcfg)) (if (and testexists cache-file (file-write-access? cache-path)) (let ((tpath (conc cache-path "/.testconfig"))) - (debug:print-info 1 "Caching testconfig for " test-name " in " tpath) + (debug:print-info 1 #f "Caching testconfig for " test-name " in " tpath) (configf:write-alist tcfg tpath))) tcfg)))))) ;; sort tests by priority and waiton ;; Move test specific stuff to a test unit FIXME one of these days (define (tests:sort-by-priority-and-waiton test-records) (let* ((mungepriority (lambda (priority) (if priority (let ((tmp (any->number priority))) - (if tmp tmp (begin (debug:print 0 "ERROR: bad priority value " priority ", using 0") 0))) + (if tmp tmp (begin (debug:print 0 #f "ERROR: bad priority value " priority ", using 0") 0))) 0))) (all-tests (hash-table-keys test-records)) (all-waited-on (let loop ((hed (car all-tests)) (tal (cdr all-tests)) (res '())) @@ -847,35 +847,35 @@ (b-raw-pri (config-lookup b-config "requirements" "priority")) (a-priority (mungepriority a-raw-pri)) (b-priority (mungepriority b-raw-pri))) (tests:testqueue-set-priority! a-record a-priority) (tests:testqueue-set-priority! b-record b-priority) - ;; (debug:print 0 "a=" a ", b=" b ", a-waitons=" a-waitons ", b-waitons=" b-waitons) + ;; (debug:print 0 #f "a=" a ", b=" b ", a-waitons=" a-waitons ", b-waitons=" b-waitons) (cond ;; is ((member a b-waitons) ;; is b waiting on a? - ;; (debug:print 0 "case1") + ;; (debug:print 0 #f "case1") #t) ((member b a-waitons) ;; is a waiting on b? - ;; (debug:print 0 "case2") + ;; (debug:print 0 #f "case2") #f) ((and (not (null? a-waitons)) ;; both have waitons - do not disturb (not (null? b-waitons))) - ;; (debug:print 0 "case2.1") + ;; (debug:print 0 #f "case2.1") #t) ((and (null? a-waitons) ;; no waitons for a but b has waitons (not (null? b-waitons))) - ;; (debug:print 0 "case3") + ;; (debug:print 0 #f "case3") #f) ((and (not (null? a-waitons)) ;; a has waitons but b does not (null? b-waitons)) - ;; (debug:print 0 "case4") + ;; (debug:print 0 #f "case4") #t) ((not (eq? a-priority b-priority)) ;; use (> a-priority b-priority)) (else - ;; (debug:print 0 "case5") + ;; (debug:print 0 #f "case5") (string>? a b)))))) (sort-fn2 (lambda (a b) (> (mungepriority (tests:testqueue-get-priority (hash-table-ref test-records a))) @@ -1032,38 +1032,38 @@ ;; test-records is a hash of test-name => test record (define (tests:get-full-data test-names test-records required-tests all-tests-registry) (if (not (null? test-names)) (let loop ((hed (car test-names)) (tal (cdr test-names))) ;; 'return-procs tells the config reader to prep running system but return a proc - (debug:print-info 4 "hed=" hed " at top of loop") + (debug:print-info 4 #f "hed=" hed " at top of loop") (let* ((config (tests:get-testconfig hed all-tests-registry 'return-procs)) (waitons (let ((instr (if config (config-lookup config "requirements" "waiton") (begin ;; No config means this is a non-existant test - (debug:print 0 "ERROR: non-existent required test \"" hed "\", grep through your testconfigs to find and remove or create the test. Discarding and continuing.") + (debug:print 0 #f "ERROR: non-existent required test \"" hed "\", grep through your testconfigs to find and remove or create the test. Discarding and continuing.") "")))) - (debug:print-info 8 "waitons string is " instr) + (debug:print-info 8 #f "waitons string is " instr) (string-split (cond ((procedure? instr) (let ((res (instr))) - (debug:print-info 8 "waiton procedure results in string " res " for test " hed) + (debug:print-info 8 #f "waiton procedure results in string " res " for test " hed) res)) ((string? instr) instr) (else - ;; NOTE: This is actually the case of *no* waitons! ;; (debug:print 0 "ERROR: something went wrong in processing waitons for test " hed) + ;; NOTE: This is actually the case of *no* waitons! ;; (debug:print 0 #f "ERROR: something went wrong in processing waitons for test " hed) "")))))) (if (not config) ;; this is a non-existant test called in a waiton. (if (null? tal) test-records (loop (car tal)(cdr tal))) (begin - (debug:print-info 8 "waitons: " waitons) + (debug:print-info 8 #f "waitons: " waitons) ;; check for hed in waitons => this would be circular, remove it and issue an ;; error (if (member hed waitons) (begin - (debug:print 0 "ERROR: test " hed " has listed itself as a waiton, please correct this!") + (debug:print 0 #f "ERROR: test " hed " has listed itself as a waiton, please correct this!") (set! waitons (filter (lambda (x)(not (equal? x hed))) waitons)))) ;; (items (items:get-items-from-config config))) (if (not (hash-table-ref/default test-records hed #f)) (hash-table-set! test-records @@ -1077,23 +1077,23 @@ ;; process can know to call items:get-items-from-config ;; if either is a list and none is a proc go ahead and call get-items ;; otherwise return #f - this is not an iterated test (cond ((procedure? items) - (debug:print-info 4 "items is a procedure, will calc later") + (debug:print-info 4 #f "items is a procedure, will calc later") items) ;; calc later ((procedure? itemstable) - (debug:print-info 4 "itemstable is a procedure, will calc later") + (debug:print-info 4 #f "itemstable is a procedure, will calc later") itemstable) ;; calc later ((filter (lambda (x) (let ((val (car x))) (if (procedure? val) val #f))) (append (if (list? items) items '()) (if (list? itemstable) itemstable '()))) 'have-procedure) ((or (list? items)(list? itemstable)) ;; calc now - (debug:print-info 4 "items and itemstable are lists, calc now\n" + (debug:print-info 4 #f "items and itemstable are lists, calc now\n" " items: " items " itemstable: " itemstable) (items:get-items-from-config config)) (else #f))) ;; not iterated #f ;; itemsdat 5 #f ;; spare - used for item-path @@ -1158,20 +1158,20 @@ (handle-exceptions exn (if (> remtries 0) (begin (print-call-chain (current-error-port)) - (debug:print-info 0 "WARNING: failed to set meta info. Will try " remtries " more times") + (debug:print-info 0 #f "WARNING: failed to set meta info. Will try " remtries " more times") (set! remtries (- remtries 1)) (thread-sleep! 10) (tests:set-full-meta-info db test-id run-id minutes work-area (- remtries 1))) (let ((err-status ((condition-property-accessor 'sqlite3 'status #f) exn))) - (debug:print 0 "ERROR: tried for over a minute to update meta info and failed. Giving up") - (debug:print 0 "EXCEPTION: database probably overloaded or unreadable.") - (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) + (debug:print 0 #f "ERROR: tried for over a minute to update meta info and failed. Giving up") + (debug:print 0 #f "EXCEPTION: database probably overloaded or unreadable.") + (debug:print 0 #f " message: " ((condition-property-accessor 'exn 'message) exn)) (print "exn=" (condition->list exn)) - (debug:print 0 " status: " ((condition-property-accessor 'sqlite3 'status) exn)) + (debug:print 0 #f " status: " ((condition-property-accessor 'sqlite3 'status) exn)) (print-call-chain (current-error-port)))) (tests:update-testdat-meta-info db test-id work-area cpuload diskfree minutes) ))) ;;====================================================================== Index: tests/unittests/basicserver.scm ================================================================== --- tests/unittests/basicserver.scm +++ tests/unittests/basicserver.scm @@ -7,11 +7,11 @@ ;; ./rununittest.sh server 1;(cd simplerun;megatest -stop-server 0) (delete-file* "logs/1.log") (define run-id 1) -(test "setup for run" #t (begin (launch:setup-for-run) +(test "setup for run" #t (begin (launch:setup) (string? (getenv "MT_RUN_AREA_HOME")))) ;; NON Server tests go here (test #f #f (db:dbdat-get-path *db*)) @@ -179,11 +179,11 @@ ;; ;; (test "launch server" #t (let ((pid (process-fork (lambda () ;; ;; ;; (daemon:ize) ;; ;; (server:launch 'http))))) ;; ;; (set! server-pid pid) ;; ;; (number? pid))) -;; (system "../../bin/megatest -server - -debug 22 > server.log 2> server.log &") +;; (system "../../bin/megatest -server - -debugbcom 22 > server.log 2> server.log &") ;; ;; (let loop ((n 10)) ;; (thread-sleep! 1) ;; need to wait for server to start. ;; (let ((res (open-run-close tasks:get-best-server tasks:open-db))) ;; (print "tasks:get-best-server returned " res) Index: tests/unittests/tests.scm ================================================================== --- tests/unittests/tests.scm +++ tests/unittests/tests.scm @@ -1,13 +1,80 @@ -;;====================================================================== -;; itemwait, itemmatch - -(db:compare-itempaths ref-item-path item-path itemmap) - -;; prereqs-not-met - -(rmt:get-prereqs-not-met run-id waitons item-path mode: testmode itemmap: itemmap)) - - (fails (runs:calc-fails prereqs-not-met)) - (prereq-fails (runs:calc-prereq-fail prereqs-not-met)) - (non-completed (runs:calc-not-completed prereqs-not-met)) - (runnables (runs:calc-runnable prereqs-not-met))) +;; ;;====================================================================== +;; ;; itemwait, itemmatch +;; +;; (db:compare-itempaths ref-item-path item-path itemmap) +;; +;; ;; prereqs-not-met +;; +;; (rmt:get-prereqs-not-met run-id waitons item-path mode: testmode itemmap: itemmap)) +;; +;; (fails (runs:calc-fails prereqs-not-met)) +;; (prereq-fails (runs:calc-prereq-fail prereqs-not-met)) +;; (non-completed (runs:calc-not-completed prereqs-not-met)) +;; (runnables (runs:calc-runnable prereqs-not-met))) +;; +;; +;; + +(define user (current-user-name)) +(define runname "mytestrun") +(define keys (rmt:get-keys)) +(define runinfo #f) +(define keyvals '(("SYSTEM" "abc")("RELEASE" "def"))) +(define header (list "SYSTEM" "RELEASE" "id" "runname" "state" "status" "owner" "event_time")) +(define run-id 1) + +;; Create a run +(test #f 1 (rmt:register-run keyvals runname "new" "n/a" user)) +(test #f #t (rmt:general-call 'register-test run-id run-id "test-one" "")) +(test #f #t (rmt:general-call 'register-test run-id run-id "test-two" "")) +(test #f #t (rmt:general-call 'register-test run-id run-id "test-three" "")) +(test #f #t (rmt:general-call 'register-test run-id run-id "test-four" "")) + +(rmt:test-set-state-status-by-id run-id (rmt:get-test-id run-id "test-one" "") "COMPLETED" "FAIL" "") +(rmt:test-set-state-status-by-id run-id (rmt:get-test-id run-id "test-two" "") "COMPLETED" "PASS" "") +(rmt:test-set-state-status-by-id run-id (rmt:get-test-id run-id "test-three" "") "RUNNING" "n/a" "") +(rmt:test-set-state-status-by-id run-id (rmt:get-test-id run-id "test-four" "") "COMPLETED" "WARN" "") + +(print "MODE=not in") +(test #f '() + (filter + (lambda (y) + (equal? y "FAIL")) ;; any FAIL in the output list? + (map + (lambda (x)(vector-ref x 4)) + (rmt:get-tests-for-run run-id "%/%" '() '("FAIL") #f #f #t 'event_time "DESC" 'shortlist 0 'dashboard)))) + +(print "MODE=in") +(test #f '("FAIL") + (map + (lambda (x)(vector-ref x 4)) + (rmt:get-tests-for-run run-id "%/%" '() '("FAIL") #f #f #f 'event_time "DESC" 'shortlist 0 'dashboard))) +(set! *verbosity* 1) + +(print "MODE=in, state in RUNNING") +;; (set! *verbosity* 8) +(test #f '("RUNNING") + (map + (lambda (x)(vector-ref x 3)) + (rmt:get-tests-for-run run-id "%/%" '("RUNNING") '() #f #f #f 'event_time "DESC" 'shortlist 0 'dashboard))) +(set! *verbosity* 1) + +(print "MODE=in, state in RUNNING and status IN WARN") +;; (set! *verbosity* 8) +(test #f '(("RUNNING" . "n/a") ("COMPLETED" . "WARN")) + (map + (lambda (x) + (cons (vector-ref x 3)(vector-ref x 4))) + (rmt:get-tests-for-run run-id "%/%" '("RUNNING") '("WARN") #f #f #f 'event_time "DESC" 'shortlist 0 'dashboard))) +(set! *verbosity* 1) + +(print "MODE=not in, state in RUNNING and status IN WARN") +(set! *verbosity* 8) +(test #f '(("RUNNING" . "n/a") ("COMPLETED" . "WARN")) + (map + (lambda (x) + (cons (vector-ref x 3)(vector-ref x 4))) + (rmt:get-tests-for-run run-id "%/%" '("RUNNING") '("WARN") #f #f #t 'event_time "DESC" 'shortlist 0 'dashboard))) +(set! *verbosity* 1) + +(exit)