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 #f " message: " ((condition-property-accessor 'exn 'message) exn)) + (debug:print 0 *default-log-port* " 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,13 +115,13 @@ (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 #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 ")) + (debug:print 0 *default-log-port* "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 *default-log-port* " use [archive] minspace to specify minimum available space") + (debug:print 0 *default-log-port* " disks: " (string-intersperse (map cadr (archive:get-archive-disks)) "\n ")) (exit 1)) (debug:print-info 0 #f "Using path " archive-dir " for archiving")) ;; from the test info bin the path to the test by stem ;; @@ -151,15 +151,15 @@ partial-path-index) #f))) (cond (toplevel/children - (debug:print 0 #f "WARNING: cannot archive " test-name " with id " test-id " as it is a toplevel test with children")) + (debug:print 0 *default-log-port* "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 #f "WARNING: Cannot archive " test-name "/" item-path " as path " test-path " does not exist")) + (debug:print 0 *default-log-port* "WARNING: Cannot archive " test-name "/" item-path " as path " test-path " does not exist")) (else - (debug:print 0 #f + (debug:print 0 *default-log-port* "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 #f "Processing disk-group " disk-group) + (debug:print 0 *default-log-port* "Processing disk-group " disk-group) (let* ((test-paths (hash-table-ref disk-groups disk-group)) ;; ((string-intersperse (map cadr (rmt:get-key-val-pairs 1)) "-") (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) @@ -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 #f "ERROR: the old directory " prev-test-physical-path ", still exists! Moving it to " newn) + (debug:print 0 *default-log-port* "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 #f "ERROR: unable to get data for run-id=" run-id ", test-id=" test-id) + (debug:print 0 *default-log-port* "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 #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 #f "ERROR: No archive path in the record for run-id=" run-id " test-id=" test-id)))) + (debug:print 0 *default-log-port* "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,14 +61,14 @@ ;; ((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 #f "INFO: client:setup remaining-tries=" remaining-tries) +;; (debug:print 0 *default-log-port* "INFO: client:setup remaining-tries=" remaining-tries) ;; (if (<= remaining-tries 0) ;; (begin -;; (debug:print 0 #f "ERROR: failed to start or connect to server for run-id " run-id) +;; (debug:print 0 *default-log-port* "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 #f "client:setup host-info=" host-info ", remaining-tries=" remaining-tries) ;; (if host-info ;; (let* ((iface (car host-info)) @@ -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 #f "INFO: client:setup start-res=" start-res ", run-id=" run-id ", server-dat=" host-info) +;; (debug:print 25 *default-log-port* "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,11 +91,11 @@ ;; (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 #f "INFO: client:setup failed to connect, start-res=" start-res ", run-id=" run-id ", host-info=" host-info) +;; (debug:print 25 *default-log-port* "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 #f "client:setup server-dat=" server-dat ", remaining-tries=" remaining-tries) @@ -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 #f "INFO: client:setup start-res=" start-res ", run-id=" run-id ", server-dat=" server-dat) +;; (debug:print 25 *default-log-port* "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 #f "INFO: client:setup start-res=" start-res ", run-id=" run-id ", server-dat=" server-dat) +;; (debug:print 25 *default-log-port* "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 #f "INFO: client:setup start-res (not defined here), run-id=" run-id ", server-dat=" server-dat) +;; (debug:print 25 *default-log-port* "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 @@ -157,11 +157,11 @@ (define (client:setup-http run-id #!key (remaining-tries 10) (failed-connects 0)) (debug:print-info 2 #f "client:setup remaining-tries=" remaining-tries) (let* ((tdbdat (tasks:open-db))) (if (<= remaining-tries 0) (begin - (debug:print 0 #f "ERROR: failed to start or connect to server for run-id " run-id) + (debug:print 0 *default-log-port* "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 #f "client:setup server-dat=" server-dat ", remaining-tries=" remaining-tries) (if server-dat (let* ((iface (tasks:hostinfo-get-interface server-dat)) @@ -217,18 +217,18 @@ ;; (define (client:signal-handler signum) ;; (signal-mask! signum) ;; (set! *time-to-exit* #t) ;; (handle-exceptions ;; exn -;; (debug:print 0 #f " ... exiting ...") +;; (debug:print 0 *default-log-port* " ... 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 #f "ERROR: Received ^C, attempting clean exit. Please be patient and wait a few seconds before hitting ^C again.") +;; (debug:print 0 *default-log-port* "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 #f " Done.") +;; (debug:print 0 *default-log-port* " Done.") ;; (exit 4)) ;; "exit on ^C timer"))) ;; (thread-start! th2) ;; (thread-start! th1) ;; (thread-join! th2)))) @@ -241,8 +241,8 @@ ;; (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 #f "connected as client") ;; (begin -;; (debug:print 0 #f "ERROR: Failed to connect as client") +;; (debug:print 0 *default-log-port* "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 #f "ERROR: bad value for setenv, key=" key ", value=" val) + (debug:print 0 *default-log-port* "ERROR: bad value for setenv, key=" key ", value=" val) (setenv key val)) - (debug:print 0 #f "ERROR: bad value for setenv, key=" key ", value=" val))) + (debug:print 0 *default-log-port* "ERROR: bad value for setenv, key=" key ", value=" val))) (define home (getenv "HOME")) (define user (getenv "USER")) ;; GLOBAL GLETCHES @@ -58,10 +58,11 @@ (define *globalexitstatus* 0) ;; attempt to work around possible thread issues (define *passnum* 0) ;; when running track calls to run-tests or similar (define *write-frequency* (make-hash-table)) ;; run-id => (vector (current-seconds) 0)) (define *alt-log-file* #f) ;; used by -log (define *common:denoise* (make-hash-table)) ;; for low noise printing +(define *default-log-port* (current-error-port)) ;; DATABASE (define *dbstruct-db* #f) (define *db-stats* (make-hash-table)) ;; hash of vectors < count duration-total > (define *db-stats-mutex* (make-mutex)) @@ -169,28 +170,28 @@ (common:set-last-run-version))) (define (common:exit-on-version-changed) (if (common:version-changed?) (let ((mtconf (conc (get-environment-variable "MT_RUN_AREA_HOME") "/megatest.config"))) - (debug:print 0 #f + (debug:print 0 *default-log-port* "ERROR: Version mismatch!\n" " expected: " (common:version-signature) "\n" " 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") + (debug:print 0 *default-log-port* " 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)) + (debug:print 0 *default-log-port* "Failed to switch versions.") + (debug:print 0 *default-log-port* " 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\"") + (debug:print 0 *default-log-port* " to switch versions you can run: \"megatest -cleanup-db\"") (exit 1)))))) ;;====================================================================== ;; S P A R S E A R R A Y S ;;====================================================================== @@ -273,11 +274,11 @@ (handle-exceptions exn (handle-exceptions exn (begin - (debug:print 0 #f "ERROR: received bad encoded string \"" instr "\", message: " ((condition-property-accessor 'exn 'message) exn)) + (debug:print 0 *default-log-port* "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)))))) @@ -400,25 +401,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 #f "Attempting clean exit. Please be patient and wait a few seconds...") + (debug:print 4 *default-log-port* "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 #f " ... done") + (debug:print 4 *default-log-port* " ... 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 #f "ERROR: Received signal " signum " exiting promptly") + (debug:print 0 *default-log-port* "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) @@ -565,11 +566,11 @@ (if split tlist target) (if target (begin - (debug:print 0 #f "ERROR: Invalid target, spaces or blanks not allowed \"" target "\", target should be: " (string-intersperse keys "/") ", have " tlist " for elements") + (debug:print 0 *default-log-port* "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 @@ -670,11 +671,11 @@ (define (common:read-link-f path) (handle-exceptions exn (begin - (debug:print 0 #f "ERROR: command \"/bin/readlink -f " path "\" failed.") + (debug:print 0 *default-log-port* "ERROR: command \"/bin/readlink -f " path "\" failed.") path) ;; just give up (with-input-from-pipe (conc "/bin/readlink -f " path) (lambda () (read-line))))) @@ -820,11 +821,11 @@ (dbspace (cadr spacedat)) (required (caddr spacedat)) (dbdir (cadddr spacedat))) (if (not is-ok) (begin - (debug:print 0 #f "ERROR: Insufficient space in " dbdir ", require " required ", have " dbspace ", exiting now.") + (debug:print 0 *default-log-port* "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) @@ -834,19 +835,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 #f "WARNING: disk " disk-num " at path \"" dirpath "\" is not a directory - ignoring it.")) + (debug:print 0 *default-log-port* "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 #f "WARNING: disk " disk-num " at path \"" dirpath "\" is not writeable - ignoring it.")) + (debug:print 0 *default-log-port* "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 #f "WARNING: disk " disk-num " at path \"" dirpath "\" is not a fully qualified path - ignoring it.")) + (debug:print 0 *default-log-port* "WARNING: disk " disk-num " at path \"" dirpath "\" is not a fully qualified path - ignoring it.")) -1) (else (get-df dirpath))))) (if (> freespc bestsize) (begin 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 #f "ERROR: problem evaluating \"" str "\" in the shell environment") + (debug:print 0 *default-log-port* "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 #f "WARNING: failed to process config input \"" l "\"") - (debug:print 0 #f " message: " ((condition-property-accessor 'exn 'message) exn)) + (debug:print 0 *default-log-port* "WARNING: failed to process config input \"" l "\"") + (debug:print 0 *default-log-port* " 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 @@ -180,11 +180,11 @@ ;; 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 #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) + (debug:print 9 *default-log-port* "START: " path) (if (not (file-exists? path)) (begin (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)) @@ -200,11 +200,11 @@ (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 #f "END: " path) + (debug:print 9 *default-log-port* "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 #f "Including: " full-conf) + (debug:print 9 *default-log-port* "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) #f "INFO: include file " include-file " not found (called from " path ")") - (debug:print 2 #f " " full-conf) + (debug:print 2 *default-log-port* " " 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) @@ -254,11 +254,11 @@ (status (cadr cmdres)) (res (car cmdres))) (debug:print-info 4 #f "" inl "\n => " (string-intersperse res "\n")) (if (not (eq? status 0)) (begin - (debug:print 0 #f "ERROR: problem with " inl ", return code " status + (debug:print 0 *default-log-port* "ERROR: problem with " inl ", return code " status " output: " cmdres))) (if (> delta 2) (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) @@ -274,11 +274,11 @@ 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 #f " setting: [" curr-section-name "] " key " = #t") + (debug:print 10 *default-log-port* " 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 '())) @@ -286,11 +286,11 @@ (realval (if envar (config:eval-string-in-environment val) val))) (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 #f " setting: [" curr-section-name "] " key " = " val) + (debug:print 10 *default-log-port* " 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 #f "ERROR: problem parsing " path ",\n \"" inl "\"") + (else (debug:print 0 *default-log-port* "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)) @@ -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 #f "ERROR: problem parsing line number " lnum "\"" hed "\""))))) + (debug:print 0 *default-log-port* "ERROR: problem parsing line number " lnum "\"" hed "\""))))) (else - (debug:print 0 #f "ERROR: Problem parsing line num " lnum " :\n " hed ))) + (debug:print 0 *default-log-port* "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 @@ -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 #f "ERROR: No test data found for test " test-id ", exiting") + (debug:print 2 *default-log-port* "ERROR: No test data found for test " test-id ", exiting") (exit 1)) (let* (;; (run-id (if testdat (db:test-get-run_id testdat) #f)) (test-registry (tests:get-all)) (keydat (if testdat (rmt:get-key-val-pairs run-id) #f)) (rundat (if testdat (rmt:get-run-info run-id) #f)) @@ -522,11 +522,11 @@ (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 #f "INFO: teststeps=" (intersperse teststeps "\n ")) + ;; (debug:print 0 *default-log-port* "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)) 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 #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) + ;; (debug:print 0 *default-log-port* "(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) @@ -401,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 #f "Getting data for run " run-id " with key-vals=" key-vals) + ;; (debug:print 0 *default-log-port* "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) @@ -1227,11 +1227,11 @@ (if (d:alldat-filters-changed data) 0 last-update) *dashboard-mode*)) '()))) ;; get 'em all - (debug:print 0 #f "dboard:get-tests-dat: got " (length tdat) " test records for run " run-id) + (debug:print 0 *default-log-port* "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))) @@ -1254,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 #f "ERROR: tree-path->run-id returned non-number " run-id))) + (debug:print 0 *default-log-port* "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" @@ -1401,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 #f "ERROR: tree-path->run-id returned non-number " run-id))) + (debug:print 0 *default-log-port* "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" @@ -1645,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 #f "(d:alldat-start-run-offset data) " (d:alldat-start-run-offset data) " maxruns: " maxruns ", val: " val " oldmax: " oldmax) + (debug:print 6 *default-log-port* "(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))) @@ -1697,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 #f "(d:alldat-start-test-offset *alldat*) " (d:alldat-start-test-offset *alldat*) " val: " val " newmax: " newmax " oldmax: " oldmax) + (debug:print 6 *default-log-port* "(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" @@ -1844,11 +1844,11 @@ (define (dashboard:get-youngest-run-db-mod-time) (handle-exceptions exn (begin - (debug:print 0 #f "WARNING: error in accessing databases in get-youngest-run-db-mod-time: " ((condition-property-accessor 'exn 'message) exn)) + (debug:print 0 *default-log-port* "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")))))) @@ -1929,11 +1929,11 @@ (if (and (number? run-id) (number? test-id) (>= test-id 0)) (examine-test run-id test-id) (begin - (debug:print 3 #f "INFO: tried to open test with invalid run-id,test-id. " (args:get-arg "-test")) + (debug:print 3 *default-log-port* "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 #f "ERROR: problem accessing db " dbpath + (debug:print 2 *default-log-port* "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 #f "ERROR: query " stmt " failed, params: " params ", error: " ((condition-property-accessor 'exn 'message) exn)) + (debug:print 0 *default-log-port* "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 #f "ERROR: query " stmt " failed, params: " params ", error: " ((condition-property-accessor 'exn 'message) exn)) + (debug:print 0 *default-log-port* "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 #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)) + (debug:print 0 *default-log-port* "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 #f "ERROR: Couldn't create path to " dbdir) + (debug:print 0 *default-log-port* "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 #f "WARNING: opening db in non-writable dir " fname) + (debug:print 2 *default-log-port* "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 #f "ERROR: tried twice, cannot create/initialize db for run-id " run-id ", at path " dbpath) + (debug:print 0 *default-log-port* "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');" @@ -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 #f "WARNING: call to sync main.db to megatest.db but main not initialized") + (debug:print 3 *default-log-port* "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 #f "ERROR: " fname " appears corrupted. Making backup \"old/" fname "\"") + (debug:print 0 *default-log-port* "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 #f "ERROR: " fnamejnl " found, moving it to old dir as " tmpjnl) + (debug:print 0 *default-log-port* "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)))) @@ -502,11 +502,11 @@ (dbdir (pathname-directory dbpath)) (fname (pathname-strip-directory dbpath))) (debug:print-info 0 #f "Checking db " dbpath " for errors.") (cond ((not (file-write-access? dbdir)) - (debug:print 0 #f "WARNING: can't write to " dbdir ", can't fix " fname) + (debug:print 0 *default-log-port* "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 #f "FATAL: file " dbpath " was found corrupted, an attempt to fix has been made but you must start over.") - (debug:print 0 #f + (debug:print 0 *default-log-port* "FATAL: file " dbpath " was found corrupted, an attempt to fix has been made but you must start over.") + (debug:print 0 *default-log-port* " 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 #f "EXCEPTION: database probably overloaded or unreadable in db:sync-tables.") + (debug:print 0 *default-log-port* "EXCEPTION: database probably overloaded or unreadable in db:sync-tables.") (print-call-chain (current-error-port)) - (debug:print 0 #f " message: " ((condition-property-accessor 'exn 'message) exn)) + (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) (print "exn=" (condition->list exn)) - (debug:print 0 #f " status: " ((condition-property-accessor 'sqlite3 'status) exn)) - (debug:print 0 #f " src db: " (db:dbdat-get-path fromdb)) + (debug:print 0 *default-log-port* " status: " ((condition-property-accessor 'sqlite3 'status) exn)) + (debug:print 0 *default-log-port* " src db: " (db:dbdat-get-path fromdb)) (for-each (lambda (dbdat) (let ((dbpath (db:dbdat-get-path dbdat))) - (debug:print 0 #f " dbpath: " dbpath) + (debug:print 0 *default-log-port* " dbpath: " dbpath) (if (not (db:repair-db dbdat)) (begin - (debug:print 0 #f "ERROR: Failed to rebuild " dbpath ", exiting now.") + (debug:print 0 *default-log-port* "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 #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 fromdb) (debug:print 3 *default-log-port* "WARNING: db:sync-tables called with fromdb missing") -1) + ((not todb) (debug:print 3 *default-log-port* "WARNING: db:sync-tables called with todb missing") -2) ((not (sqlite3:database? (db:dbdat-get-db fromdb))) - (debug:print 0 #f "ERROR: db:sync-tables called with fromdb not a database " fromdb) -3) + (debug:print 0 *default-log-port* "ERROR: db:sync-tables called with fromdb not a database " fromdb) -3) ((not (sqlite3:database? (db:dbdat-get-db todb))) - (debug:print 0 #f "ERROR: db:sync-tables called with todb not a database " todb) -4) + (debug:print 0 *default-log-port* "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)) @@ -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 #f "INFO: db sync, total run time " runtime " ms")) + (if should-print (debug:print 3 *default-log-port* "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 #f (format #f " ~10a ~5a" tblname count)))))) + (if should-print (debug:print 0 *default-log-port* (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 #f "INFO: Propagating " (length testrecs) " records for run-id=" run-id " to run specific db") + (debug:print 0 *default-log-port* "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 #f "Processing run " (if (eq? run-id 0) " main.db " run-id) ", " count " of " total) + (debug:print 0 *default-log-port* "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 #f "Column last_update already added to runs table") + (debug:print 0 *default-log-port* "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 #f "Column last_update already added to " table-name " table") + (debug:print 0 *default-log-port* "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,11 +850,11 @@ (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 #f "Removing database file for deleted run " fullname) + (debug:print 0 *default-log-port* "Removing database file for deleted run " fullname) (delete-file fullname))))) dead-runs)))) ;; (db:close-all dbstruct) ;; (sqlite3:finalize! mdb) @@ -866,13 +866,13 @@ (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 #f "ERROR: cannot open-run-close with #f anymore")) + ((not idb) (debug:print 0 *default-log-port* "ERROR: cannot open-run-close with #f anymore")) ((procedure? idb) (idb)) - (else (debug:print 0 #f "ERROR: cannot open-run-close with #f anymore")))) + (else (debug:print 0 *default-log-port* "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 #f "open-run-close-no-exception-handling END" ) res) @@ -885,14 +885,14 @@ (err-status ((condition-property-accessor 'sqlite3 'status #f) exn))) (case err-status ((busy) (thread-sleep! sleep-time)) (else - (debug:print 0 #f "EXCEPTION: database probably overloaded or unreadable.") - (debug:print 0 #f " message: " ((condition-property-accessor 'exn 'message) exn)) + (debug:print 0 *default-log-port* "EXCEPTION: database probably overloaded or unreadable.") + (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) (print "exn=" (condition->list exn)) - (debug:print 0 #f " status: " ((condition-property-accessor 'sqlite3 'status) exn)) + (debug:print 0 *default-log-port* " status: " ((condition-property-accessor 'sqlite3 'status) exn)) (print-call-chain (current-error-port)) (thread-sleep! sleep-time) (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))) @@ -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 #f "WARNING: Marking test(s); " (string-intersperse (map conc all-ids) ", ") " as INCOMPLETE") + (debug:print 0 *default-log-port* "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 #f "WARNING: db clean up not fully ported to v1.60, cleanup action will be on megatest.db") + ;; (debug:print 0 *default-log-port* "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)) @@ -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 #f "WARNING: db clean up not fully ported to v1.60, cleanup action will be on megatest.db") + ;; (debug:print 0 *default-log-port* "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)) @@ -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 #f "WARNING: db clean up not fully ported to v1.60, cleanup action will be on megatest.db") + ;; (debug:print 0 *default-log-port* "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)) @@ -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 #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") + (debug:print 3 *default-log-port* "keys: " keys " allvals: " allvals " keyvals: " keyvals " key=?str is " key=?str) + (debug:print 2 *default-log-port* "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 #f "qry: " qry) + ;(debug:print 4 *default-log-port* "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 #f "ERROR: Called without all necessary keys") + (debug:print 0 *default-log-port* "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 "%") ) @@ -1789,11 +1789,11 @@ (map (lambda (dbfile) (let* ((res (string-match ".*\\/(\\d)*\\.db" dbfile))) (if res (string->number (cadr res)) (begin - (debug:print 2 #f "WARNING: Failed to process " dbfile " for run-id") + (debug:print 2 *default-log-port* "WARNING: Failed to process " dbfile " for run-id") 0)))) changed)))) ;; Get all targets from the db ;; @@ -1978,11 +1978,11 @@ (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 #f "ERROR: searching for runs with no pattern set for " fulkey) + (debug:print 0 *default-log-port* "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) "") @@ -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 #f "WARNING: call to db:get-tests-for-run with bad run-id=" run-id) + (debug:print 4 *default-log-port* "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") @@ -2348,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 #f "QRY: " qry) +;; (debug:print 0 *default-log-port* "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) @@ -2576,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 #f "INFO: migrating test records for run with id " run-id) + (debug:print 0 *default-log-port* "INFO: migrating test records for run with id " run-id) (sqlite3:with-transaction db (lambda () (for-each (lambda (rec) - ;; (debug:print 0 #f "INFO: Inserting values: " (string-intersperse (map conc (vector->list rec)) ",") "\n") + ;; (debug:print 0 *default-log-port* "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 @@ -2850,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 #f "test-id " test-id ", csvdata: " csvdata) + (debug:print 4 *default-log-port* "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) @@ -2874,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 #f "BEFORE: category: " category " variable: " variable " value: " value + (debug:print 4 *default-log-port* "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 ""))) @@ -2885,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 #f "AFTER: category: " category " variable: " variable " value: " value + (debug:print 4 *default-log-port* "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 #f "max-val: " max-val " min-val: " min-val " result: " result) + (debug:print 4 *default-log-port* "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 #f "AFTER2: category: " category " variable: " variable " value: " value + (debug:print 4 *default-log-port* "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))) @@ -2939,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 #f "db:test-get-paths-matching-keynames-target-new\n runsqry=" runsqry "\n tstsqry=" testqry) + ;; (debug:print 8 *default-log-port* "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) @@ -3009,11 +3009,11 @@ (base64:base64-decode (string-substitute (regexp "_") "=" msg #t))) (lambda ()(deserialize))) (begin - (debug:print 0 #f "ERROR: reception failed. Received " msg " but cannot translate it.") + (debug:print 0 *default-log-port* "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) @@ -3066,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 #f "Found path: " path) - (debug:print 2 #f "No such path: " path))) ;; ) + (debug:print 2 *default-log-port* "Found path: " path) + (debug:print 2 *default-log-port* "No such path: " path))) ;; ) db "SELECT rundir,final_logf FROM tests WHERE testname=? AND item_path='';" test-name) res)))) @@ -3321,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 #f "selstr: " selstr ", qrystr: " qrystr ", keyvals: " keyvals + (debug:print 4 *default-log-port* "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 #f "Got tests for run-id " run-id ", test-name " test-name + (debug:print 4 *default-log-port* "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))) @@ -3493,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 #f "WARNING: itemmap has problem \"" itemmap "\", patt: " patt ", repl: " repl) + (debug:print 0 *default-log-port* "WARNING: itemmap has problem \"" itemmap "\", patt: " patt ", repl: " repl) res)))) (if (null? tal) newr (loop (car tal)(cdr tal) newr))))))) @@ -3628,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 #f "Using " tempdir " for constructing the ods file. keyqry: " keyqry " keystr: " keysstr " with keys: " (map cadr keypatt-alist) + (debug:print 2 *default-log-port* "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 @@ -3652,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 #f "log: " log-fpath " exists: " (file-exists? log-fpath)) + (debug:print 4 *default-log-port* "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)) @@ -3670,11 +3670,11 @@ (vector->list vb)) b))))) db mainqry runspatt (map cadr keypatt-alist)) - (debug:print 2 #f "Found " (length test-ids) " records") + (debug:print 2 *default-log-port* "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)) @@ -3696,14 +3696,14 @@ (ods:list->ods tempdir (if (string-match (regexp "^[/~]+.*") outputfile) ;; full path? outputfile (begin - (debug:print 0 #f "WARNING: path given, " outputfile " is relative, prefixing with current directory") + (debug:print 0 *default-log-port* "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 #f "test-ids " test-ids ", tests-detail-changes " tests-detail-changes) +;; (debug:print 0 *default-log-port* "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 #f "node-num: " node-num ", color: " color) + (debug:print 0 *default-log-port* "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 #f "rownum:colnum=" rownum ":" colnum ", state=" status) + ;; (debug:print 2 *default-log-port* "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 #f "run-changes: " run-changes) - ;; (debug:print 2 #f "test-changes: " test-changes) + ;; (debug:print 2 *default-log-port* "run-changes: " run-changes) + ;; (debug:print 2 *default-log-port* "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 #f "test-box-info=" test-box-info) - ;; (debug:print 0 #f "test-record=" test-record) + ;; (debug:print 0 *default-log-port* "test-box-info=" test-box-info) + ;; (debug:print 0 *default-log-port* "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) 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 #f "ERROR: No dumpmode specified, use -dumpmode [bash|csh|config]"))))) + (debug:print 0 *default-log-port* "ERROR: No dumpmode specified, use -dumpmode [bash|csh|config]"))))) Index: ezsteps.scm ================================================================== --- ezsteps.scm +++ ezsteps.scm @@ -41,11 +41,11 @@ (let loop ((count 5)) (if (file-exists? test-run-dir) (push-directory test-run-dir) (if (> count 0) (begin - (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") + (debug:print 0 *default-log-port* "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 #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 @@ -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 #f "ezsteps:\n stepname: " stepname " stepinfo: " stepinfo " stepparts: " stepparts + (debug:print 4 *default-log-port* "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 #f "script: " script) + (debug:print 4 *default-log-port* "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 #f "Exit value received: " (vector-ref exit-info 2) " logpro-used: " logpro-used + (debug:print 4 *default-log-port* "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 #f "WARNING: a prior step failed, stopping at " ezstep))) + (debug:print 4 *default-log-port* "WARNING: a prior step failed, stopping at " ezstep))) ;; Once done with step/steps update the test record ;; (let* ((item-path (db:test-get-item-path testdat)) ;; (item-list->path itemdat)) (testinfo (rmt:get-testinfo-by-id run-id test-id))) ;; refresh the testdat, call it iteminfo in case need prev/curr 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 #f "Attempting to start the server ...") + (debug:print 2 *default-log-port* "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) @@ -119,15 +119,15 @@ exn (begin (print-error-message exn) (if (< portnum 64000) (begin - (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)) + (debug:print 0 *default-log-port* "WARNING: attempt to start server failed. Trying again ...") + (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) + (debug:print 0 *default-log-port* "exn=" (condition->list exn)) (portlogger:open-run-close portlogger:set-failed portnum) - (debug:print 0 #f "WARNING: failed to start on portnum: " portnum ", trying next port") + (debug:print 0 *default-log-port* "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 #f "INFO: Trying to start server on " ipaddrstr ":" portnum) + (debug:print 0 *default-log-port* "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 #f "INFO: server has been stopped")))) + (debug:print 1 *default-log-port* "INFO: server has been stopped")))) ;;====================================================================== ;; S E R V E R U T I L I T I E S ;;====================================================================== @@ -201,11 +201,11 @@ (if (> *http-requests-in-progress* 0) (if (> etime (current-seconds)) (begin (thread-sleep! 0.05) (loop etime)) - (debug:print 0 #f "ERROR: requests still in progress after 5 seconds of waiting. I'm going to pass on cleaning up http connections")) + (debug:print 0 *default-log-port* "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 #f "FATAL ERROR: http-transport:client-api-send-receive called with no server info") + (debug:print 0 *default-log-port* "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,13 +230,13 @@ ;; (begin ;; (mutex-unlock! *http-mutex*) ;; (thread-sleep! 1) ;; (handle-exceptions ;; exn -;; (debug:print 0 #f "WARNING: closing connections failed. Server at " fullurl " almost certainly dead") +;; (debug:print 0 *default-log-port* "WARNING: closing connections failed. Server at " fullurl " almost certainly dead") ;; (close-all-connections!)) -;; (debug:print 0 #f "WARNING: Failed to communicate with server, trying again, numretries left: " numretries) +;; (debug:print 0 *default-log-port* "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)) @@ -259,12 +259,12 @@ (db:string->obj (handle-exceptions exn (begin (set! success #f) - (debug:print 0 #f "WARNING: failure in with-input-from-request to " fullurl ".") - (debug:print 0 #f " message: " ((condition-property-accessor 'exn 'message) exn)) + (debug:print 0 *default-log-port* "WARNING: failure in with-input-from-request to " fullurl ".") + (debug:print 0 *default-log-port* " 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 @@ -294,14 +294,14 @@ (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 #f "ERROR: error occured at server, info=" (vector-ref res 2)) - (debug:print 0 #f " client call chain:") + (debug:print 0 *default-log-port* "ERROR: error occured at server, info=" (vector-ref res 2)) + (debug:print 0 *default-log-port* " client call chain:") (print-call-chain (current-error-port)) - (debug:print 0 #f " server call chain:") + (debug:print 0 *default-log-port* " 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 #f "ERROR: call to http-transport:server-dat-update-last-access with non-vector!!")))) + (debug:print 0 *default-log-port* "ERROR: call to http-transport:server-dat-update-last-access with non-vector!!")))) ;; ;; connect ;; (define (http-transport:client-connect iface port) @@ -379,11 +379,11 @@ (begin (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 #f "ERROR: transport appears to have died, exiting server " server-id " for run " run-id) + (debug:print 0 *default-log-port* "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 #f "ERROR: error from sync code other than 'sync-failed. Attempting to gracefully shutdown the server") + (debug:print 0 *default-log-port* "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 #f "SYNC: time= " sync-time ", rem-time=" rem-time) + (debug:print 4 *default-log-port* "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 ... @@ -458,11 +458,11 @@ ;; 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 #f "last-access=" last-access ", server-timeout=" server-timeout) + ;; (debug:print 11 *default-log-port* "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) ;; @@ -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 #f "INFO: Server for run-id " run-id " already running") + (debug:print 0 *default-log-port* "INFO: Server for run-id " run-id " already running") (exit 0))) (let loop ((server-id (tasks:server-lock-slot (db:delay-if-busy tdbdat) run-id)) (remtries 4)) (if (not server-id) (if (> remtries 0) @@ -583,18 +583,18 @@ (define (http-transport:server-signal-handler signum) (signal-mask! signum) (handle-exceptions exn - (debug:print 0 #f " ... exiting ...") + (debug:print 0 *default-log-port* " ... exiting ...") (let ((th1 (make-thread (lambda () (thread-sleep! 1)) "eat response")) (th2 (make-thread (lambda () - (debug:print 0 #f "ERROR: Received ^C, attempting clean exit. Please be patient and wait a few seconds before hitting ^C again.") + (debug:print 0 *default-log-port* "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 #f " Done.") + (debug:print 0 *default-log-port* " 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 #f "item-assoc->item-list x: " x) + (debug:print 6 *default-log-port* "item-assoc->item-list x: " x) (if (< (length x) 2) (begin - (debug:print 0 #f "ERROR: malformed items spec " (string-intersperse x " ")) + (debug:print 0 *default-log-port* "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 #f "ERROR: No items specified for " name)) + (debug:print 0 *default-log-port* "ERROR: No items specified for " name)) ilist))) itemsdat)))) (let ((debuglevel 5)) - (debug:print 5 #f "item-assoc->item-list: itemsdat => itemlst ") + (debug:print 5 *default-log-port* "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 #f "New: " new) + ;; (debug:print 0 *default-log-port* "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 #f "items: " items " itemstable: " itemstable) + (debug:print 5 *default-log-port* "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 #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 (and have-items (null? items)) (debug:print 0 *default-log-port* "ERROR: [items] section in testconfig but no entries defined")) + (if (and have-itable (null? itemstable))(debug:print 0 *default-log-port* "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 #f "ERROR: wrong number of values in " target ", should match " keys)) + (debug:print 0 *default-log-port* "ERROR: wrong number of values in " target ", should match " keys)) vals) - (debug:print 4 #f "ERROR: keys:target-set-args called with no target."))) + (debug:print 4 *default-log-port* "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 #f "ezsteps:\n stepname: " stepname " stepinfo: " stepinfo " stepparts: " stepparts + (debug:print 4 *default-log-port* "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 #f "script: " script) + (debug:print 4 *default-log-port* "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") @@ -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 #f "Exit value received: " (launch:einf-exit-code exit-info) " logpro-used: " logpro-used + (debug:print 4 *default-log-port* "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 #f "WARNING: no testconfig found for " test-name " in search path:\n " + (debug:print 0 *default-log-port* "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 #f "ERROR: Failed to resolve megatest.config, runconfigs.config and testconfig issues. Giving up now") + (debug:print 0 *default-log-port* "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 #f "ERROR: ezsteps defined but ezstepslst is zero length") + (debug:print 0 *default-log-port* "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 #f "WARNING: step " (car ezstep) " failed. Stopping"))) - (debug:print 4 #f "WARNING: a prior step failed, stopping at " ezstep))))))) + (debug:print 4 *default-log-port* "WARNING: step " (car ezstep) " failed. Stopping"))) + (debug:print 4 *default-log-port* "WARNING: a prior step failed, stopping at " ezstep))))))) (define (launch:monitor-job run-id test-id item-path fullrunscript ezsteps test-name tconfigreg exit-info m work-area runtlim misc-flags) (let* ((start-seconds (current-seconds)) (calc-minutes (lambda () (inexact->exact @@ -351,12 +351,12 @@ (lambda (pid) (handle-exceptions exn (begin (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 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))) + (debug:print 0 *default-log-port* "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)) @@ -371,11 +371,11 @@ (process:get-sub-pids pid)))) ;; (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 #f "ERROR: Nothing to kill, pid1=" pid1 ", pid2=" pid2) + (debug:print 0 *default-log-port* "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 #f "INFO: Not starting job yet - directory " top-path " not found") + (debug:print 0 *default-log-port* "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 #f "ERROR: attempt to STOP process. Exiting.")) + (debug:print 0 *default-log-port* "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 #f "Done") + (debug:print 0 *default-log-port* "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 #f "INFO: test is INCOMPLETE or KILLED, treat this execute call as a rerun request") + (debug:print 0 *default-log-port* "INFO: test is INCOMPLETE or KILLED, treat this execute call as a rerun request") (tests:test-force-state-status! run-id test-id "REMOTEHOSTSTART" "n/a")) ;; 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 #f "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 *default-log-port* "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 #f "ERROR: test state is " (db:test-get-state test-info) ", cannot proceed") + (debug:print 0 *default-log-port* "ERROR: test state is " (db:test-get-state test-info) ", cannot proceed") (exit)))) - (debug:print 2 #f "Exectuing " test-name " (id: " test-id ") on " (get-host-name)) + (debug:print 2 *default-log-port* "Exectuing " test-name " (id: " test-id ") on " (get-host-name)) (set! keys (rmt:get-keys)) ;; (runs:set-megatest-env-vars run-id inkeys: keys inkeyvals: keyvals) ;; these may be needed by the launching process ;; one of these is defunct/redundant ... (if (not (launch:setup force: #t)) (begin - (debug:print 0 #f "Failed to setup, exiting") + (debug:print 0 *default-log-port* "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 #f "ERROR: bad variable spec, " var "=" val)))) + (debug:print 0 *default-log-port* "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 #f "INFO: Not starting job yet - directory " work-area " not found") + (debug:print 0 *default-log-port* "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 #f "varpairs: " varpairs) + (debug:print 4 *default-log-port* "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 #f "Adding pre-var/val " var " = " val " to the environment") + (debug:print 1 *default-log-port* "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 #f "ERROR: required variable " var " does not have a valid value. Exiting") + (debug:print 0 *default-log-port* "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)) @@ -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 #f "Output from running " fullrunscript ", pid " (launch:einf-pid exit-info) " in work area " + (debug:print 2 *default-log-port* "Output from running " fullrunscript ", pid " (launch:einf-pid exit-info) " in work area " work-area ":\n====\n exit code " (launch:einf-exit-code exit-info) "\n" "====\n") (if (not (launch:einf-exit-status exit-info)) (exit 4))))))) (define (launch:cache-config) @@ -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 0 #f "ERROR: you are not in a megatest area!") + (debug:print 0 *default-log-port* "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 #f "ERROR: No " mtconfig " file found. Giving up.") + (debug:print 0 *default-log-port* "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 #f "ERROR: Something went wrong when trying to create linktree dir at " linktree) - (debug:print 0 #f " message: " ((condition-property-accessor 'exn 'message) exn)) + (debug:print 0 *default-log-port* "ERROR: Something went wrong when trying to create linktree dir at " linktree) + (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) (exit 1)) (create-directory linktree #t)))) (begin - (debug:print 0 #f "ERROR: linktree not defined in [setup] section of megatest.config") + (debug:print 0 *default-log-port* "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 #f "ERROR: failed to find the top path to your Megatest area."))) + (debug:print 0 *default-log-port* "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 #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)) + (debug:print 0 *default-log-port* "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 #f "INFO:\n lnkbase=" lnkbase "\n lnkpath=" lnkpath "\n toptest-path=" toptest-path "\n test-path=" test-path) + (debug:print 2 *default-log-port* "INFO:\n lnkbase=" lnkbase "\n lnkpath=" lnkpath "\n toptest-path=" toptest-path "\n test-path=" test-path) (if (not (file-exists? linktree)) (begin - (debug:print 0 #f "WARNING: linktree did not exist! Creating it now at " linktree) + (debug:print 0 *default-log-port* "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 0 #f "ERROR: Problem creating linktree base at " lnkbase) + (debug:print 0 *default-log-port* "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 @@ -912,28 +912,28 @@ (let ((iterated-parent (pathname-directory (conc lnkpath "/" item-path)))) (debug:print-info 2 #f "Creating iterated parent " iterated-parent) (handle-exceptions exn (begin - (debug:print 0 #f "ERROR: Failed to create directory " iterated-parent ((condition-property-accessor 'exn 'message) exn) ", exiting") + (debug:print 0 *default-log-port* "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 #f "ERROR: Failed to remove symlink " lnkpath ((condition-property-accessor 'exn 'message) exn) ", exiting") + (debug:print 0 *default-log-port* "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 #f "ERROR: Failed to create symlink " lnkpath ((condition-property-accessor 'exn 'message) exn) ", exiting") + (debug:print 0 *default-log-port* "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!!! ;; @@ -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 #f "Setting up sub test run area") - (debug:print 2 #f " - creating run area in " test-path) + (debug:print 2 *default-log-port* "Setting up sub test run area") + (debug:print 2 *default-log-port* " - creating run area in " test-path) (handle-exceptions exn (begin - (debug:print 0 #f "ERROR: Failed to create directory " test-path ((condition-property-accessor 'exn 'message) exn) ", exiting") + (debug:print 0 *default-log-port* "ERROR: Failed to create directory " test-path ((condition-property-accessor 'exn 'message) exn) ", exiting") (exit 1)) (create-directory test-path #t)) - (debug:print 2 #f + (debug:print 2 *default-log-port* " - 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 #f "ERROR: Failed to re-create link " lnktarget ((condition-property-accessor 'exn 'message) exn) ", exiting") + (debug:print 0 *default-log-port* "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 #f "ERROR: problem with running \"" cmd "\""))) + (debug:print 2 *default-log-port* "ERROR: problem with running \"" cmd "\""))) (list lnkpathf lnkpath )) (if (and test-src-path (> remtries 0)) (begin - (debug:print 0 #f "ERROR: Failed to create work area at " test-path " with link at " lnktarget ", remaining attempts " remtries) + (debug:print 0 *default-log-port* "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 @@ -1105,11 +1105,11 @@ (set! toptest-work-area (cadr dat)) (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 #f "WARNING: No disk work area specified - running in the test directory under tmp_run"))) + (debug:print 0 *default-log-port* "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 #f "WARNING: internal launching will not work well without \"useshell yes\" in your [jobtools] section")) + (if (not useshell)(debug:print 0 *default-log-port* "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 #f "Launching " work-area) + (debug:print 1 *default-log-port* "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 #f "fullcmd: " fullcmd) + (debug:print 4 *default-log-port* "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 #f "Launching completed, updating db") - (debug:print 2 #f "Launch results: " launch-results) + (debug:print 2 *default-log-port* "Launching completed, updating db") + (debug:print 2 *default-log-port* "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 #f "WARNING: exception on lock-queue:set-state. Trying again in 30 seconds.") - (debug:print 0 #f " message: " ((condition-property-accessor 'exn 'message) exn)) + (debug:print 0 *default-log-port* "WARNING: exception on lock-queue:set-state. Trying again in 30 seconds.") + (debug:print 0 *default-log-port* " 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 #f "ERROR: Failed to set lock state for test with id " test-id ", error: " ((condition-property-accessor 'exn 'message) exn) ", giving up.") + (debug:print 0 *default-log-port* "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 #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)) + (debug:print 0 *default-log-port* "WARNING: exception on lock-queue:any-younger. Removing lockdb and trying again in 5 seconds.") + (debug:print 0 *default-log-port* " 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 #f "ERROR: Failed to find younger locks for test with id " test-id ", error: " ((condition-property-accessor 'exn 'message) exn) ", giving up.") + (debug:print 0 *default-log-port* "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 #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)) + (debug:print 0 *default-log-port* "WARNING: failed to get queue lock. Removing lock db and returning fail") ;; Will try again in a few seconds") + (debug:print 0 *default-log-port* " 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 #f "WARNING: Failed to release queue lock. Will try again in few seconds") - (debug:print 0 #f " message: " ((condition-property-accessor 'exn 'message) exn)) + (debug:print 0 *default-log-port* "WARNING: Failed to release queue lock. Will try again in few seconds") + (debug:print 0 *default-log-port* " 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))) @@ -176,12 +176,12 @@ (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 - (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)) + (debug:print 0 *default-log-port* "WARNING: Failed to steal queue lock. Will try again in few seconds") + (debug:print 0 *default-log-port* " 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 #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)) + (debug:print 0 *default-log-port* "WARNING: Failed to find out if it is ok to skip the wait queue. Will try again in few seconds") + (debug:print 0 *default-log-port* " 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 #f "Giving up calls to lock-queue:wait-turn for test-id " test-id " at path " fname ", printing call chain") + (debug:print 0 *default-log-port* "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 #f "ERROR: Unrecognised arguments: " (string-intersperse (if (list? remargs) remargs (argv)) " "))) + (debug:print 0 *default-log-port* "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))) @@ -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 #f "ERROR: non-existant start dir " (args:get-arg "-start-dir") " specified, exiting.") + (debug:print 0 *default-log-port* "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 #f "WARNING: -itempatt has been deprecated, please use -testpatt testpatt/itempatt method, new testpatt is "newval) + (debug:print 0 *default-log-port* "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 #f "WARNING: \"-runtests\" is deprecated. Use \"-run\" with \"-testpatt\" instead")) + (debug:print 0 *default-log-port* "WARNING: \"-runtests\" is deprecated. Use \"-run\" with \"-testpatt\" instead")) (on-exit std-exit-procedure) ;;====================================================================== ;; Misc general calls @@ -488,15 +488,15 @@ (debug:print-info 0 #f "Removing cached files:\n " (string-intersperse files "\n ")) (for-each (lambda (f) (handle-exceptions exn - (debug:print 0 #f "WARNING: Failed to remove file " f) + (debug:print 0 *default-log-port* "WARNING: Failed to remove file " f) (delete-file f))) files)))) - (debug:print 0 #f "ERROR: -clean-cache requires -runname.")) - (debug:print 0 #f "ERROR: -clean-cache requires -target or -reqtarg")))) + (debug:print 0 *default-log-port* "ERROR: -clean-cache requires -runname.")) + (debug:print 0 *default-log-port* "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 #f "Bad input? data=" data) ;; some error occurred + (debug:print 0 *default-log-port* "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 #f "ERROR: Parameter to -envdelta should be new=star-end"))))) + (debug:print 0 *default-log-port* "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 #f "ERROR: server requires run-id be specified with -run-id"))) + (debug:print 0 *default-log-port* "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 @@ -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 #f "Found "(length targets) " targets") + (debug:print 1 *default-log-port* "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 #f "ERROR: dump output format " (args:get-arg "-dumpmode") " not supported for -list-targets"))) + (debug:print 0 *default-log-port* "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 #f "ERROR: -dumpmode of " (args:get-arg "-dumpmode") " not recognised"))) + (debug:print 0 *default-log-port* "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 #f "ERROR: -dumpmode of " (args:get-arg "-dumpmode") " not recognised"))) + (debug:print 0 *default-log-port* "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")) @@ -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 #f "ERROR: Missing required parameter for " action ", you must specify -target or -reqtarg") + (debug:print 0 *default-log-port* "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 #f "ERROR: Missing required parameter for " action ", you must specify the run name pattern with -runname patt") + (debug:print 0 *default-log-port* "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 #f "ERROR: Missing required parameter for " action ", you must specify the test pattern with -testpatt") + (debug:print 0 *default-log-port* "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 #f "ERROR: Attempted " action "on test(s) but run area config file not found") + (debug:print 0 *default-log-port* "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) @@ -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 #f "ERROR: Invalid test fields specified: " (string-intersperse invalid-tests-spec ", ")) + (debug:print 0 *default-log-port* "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 #f "ERROR: Bad data in test record? " test) + (debug:print 0 *default-log-port* "ERROR: Bad data in test record? " test) (print "exn=" (condition->list exn)) - (debug:print 0 #f " message: " ((condition-property-accessor 'exn 'message) exn)) + (debug:print 0 *default-log-port* " 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 #f "WARNING: meta data for run " runname " not found") + (debug:print 0 *default-log-port* "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 #f "WARNING: run " target "/" runname " appears to have no data") + (debug:print 0 *default-log-port* "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 #f "WARNING: path given, " outputfile " is relative, prefixing with current directory") + (debug:print 0 *default-log-port* "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 #f "ERROR: -target is required.") + (debug:print 0 *default-log-port* "ERROR: -target is required.") (exit 1))) (if (not (launch:setup)) (begin - (debug:print 0 #f "Failed to setup, giving up on -test-paths or -test-files, exiting") + (debug:print 0 *default-log-port* "Failed to setup, giving up on -test-paths or -test-files, exiting") (exit 1))) (let* ((keys (rmt:get-keys)) ;; 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 #f "Extract ods, outputfile: " outputfile " runspatt: " runspatt " keyvals: " keyvals) + (debug:print 2 *default-log-port* "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 #f "ERROR: bad run-id or test-id, must be integers") + (debug:print 0 *default-log-port* "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 #f "ERROR: MT_CMDINFO env var not set, -step must be called *inside* a megatest invoked environment!") + (debug:print 0 *default-log-port* "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 #f "Failed to setup, exiting") + (debug:print 0 *default-log-port* "Failed to setup, exiting") (exit 1))) (if (and state status) (let ((comment (launch:load-logpro-dat run-id test-id step))) ;; (rmt:test-set-log! run-id test-id (conc stepname ".html")))) (rmt:teststep-set-status! run-id test-id step state status (or comment msg) logfile)) (begin - (debug:print 0 #f "ERROR: You must specify :state and :status with every call to -step") + (debug:print 0 *default-log-port* "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 #f "ERROR: MT_CMDINFO env var not set, commands -test-status, -runstep and -setlog must be called *inside* a megatest environment!") + (debug:print 0 *default-log-port* "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,11 +1678,11 @@ (state (args:get-arg ":state")) (status (args:get-arg ":status")) (stepname (args:get-arg "-step"))) (if (not (launch:setup)) (begin - (debug:print 0 #f "Failed to setup, exiting") + (debug:print 0 *default-log-port* "Failed to setup, exiting") (exit 1))) (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 @@ -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 #f "ERROR: nothing specified to run!") + (debug:print 0 *default-log-port* "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")) @@ -1763,11 +1763,11 @@ res))) (if (and (args:get-arg "-test-status") (or (not state) (not status))) (begin - (debug:print 0 #f "ERROR: You must specify :state and :status with every call to -test-status\n" help) + (debug:print 0 *default-log-port* "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 #f "Failed to setup, exiting") + (debug:print 0 *default-log-port* "Failed to setup, exiting") (exit 1))) (set! keys (rmt:get-keys)) ;; db)) - (debug:print 1 #f "Keys: " (string-intersperse keys ", ")) + (debug:print 1 *default-log-port* "Keys: " (string-intersperse keys ", ")) (if (sqlite3:database? db)(sqlite3:finalize! db)) (set! *didsomething* #t))) (if (args:get-arg "-gui") (begin - (debug:print 0 #f "Look at the dashboard for now") + (debug:print 0 *default-log-port* "Look at the dashboard for now") ;; (megatest-gui) (set! *didsomething* #t))) (if (args:get-arg "-gen-megatest-area") (begin @@ -1814,30 +1814,30 @@ (if (args:get-arg "-rebuild-db") (begin (if (not (launch:setup)) (begin - (debug:print 0 #f "Failed to setup, exiting") + (debug:print 0 *default-log-port* "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 #f "Failed to setup, exiting") + (debug:print 0 *default-log-port* "Failed to setup, exiting") (exit 1))) (common:cleanup-db) (set! *didsomething* #t))) (if (args:get-arg "-mark-incompletes") (begin (if (not (launch:setup)) (begin - (debug:print 0 #f "Failed to setup, exiting") + (debug:print 0 *default-log-port* "Failed to setup, exiting") (exit 1))) (open-run-close db:find-and-mark-incomplete #f) (set! *didsomething* #t))) ;;====================================================================== @@ -1846,11 +1846,11 @@ (if (args:get-arg "-update-meta") (begin (if (not (launch:setup)) (begin - (debug:print 0 #f "Failed to setup, exiting") + (debug:print 0 *default-log-port* "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))) @@ -1914,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 #f "Failed to setup, exiting") + (debug:print 0 *default-log-port* "Failed to setup, exiting") (exit 1))) (operate-on 'run-wait) (set! *didsomething* #t))) ;; ;; ;; redo me ;; Not converted to use dbstruct yet @@ -1975,20 +1975,20 @@ ;;====================================================================== (if *runremote* (close-all-connections!)) (if (not *didsomething*) - (debug:print 0 #f help)) + (debug:print 0 *default-log-port* 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 #f "NOTE: Subprocesses with non-zero exit code detected: " *globalexitstatus*) + (debug:print 0 *default-log-port* "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,11 +50,11 @@ ;; (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 #f "header: " header " runslst: " runslst " have-more: " have-more) + ;; (debug:print 0 *default-log-port* "header: " header " runslst: " runslst " have-more: " have-more) (if have-more (let ((new-offset (+ offset limit)) (next-batch (rmt:get-runs-by-patt keys runnamepatt targpatt offset limit #f))) (debug:print-info 4 #f "More than " limit " runs, have " (length full-list) " runs so far.") (debug:print-info 0 #f "next-batch: " next-batch) @@ -91,11 +91,11 @@ (if last-time (< (current-seconds)(+ last-time 5)) #f)))) (if useres (let ((result (vector-ref res 1))) - (debug:print 4 #f "Using lazy value res: " result) + (debug:print 4 *default-log-port* "Using lazy value res: " result) result) (let ((newres (rmt:get-prereqs-not-met run-id waitons ref-item-path mode: mode itemmaps: itemmaps))) (hash-table-set! *pre-reqs-met-cache* key (vector (current-seconds) newres)) newres)))) @@ -120,11 +120,11 @@ new-res) (loop (car remt) (cdr remt) (if (member failed-test waitons) (begin - (debug:print 0 #f "Discarding test " testn "(" test-dat ") due to " failed-test) + (debug:print 0 *default-log-port* "Discarding test " testn "(" test-dat ") due to " failed-test) res) (cons testn res))))))))) ;;====================================================================== ;; T R I G G E R S @@ -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 #f "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 *default-log-port* "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 #f "ERROR: No readable testconfig found for " test-name) + (debug:print 0 *default-log-port* "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 #f "ERROR: Couldn't create path to " dbdir) + (debug:print 0 *default-log-port* "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 #f "ERROR: I was asked to open " dbfile ", but file does not exist or is not readable.") + (debug:print 0 *default-log-port* "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 #f "ERROR: no main.db found at " (areadb:dbfile-path areadat 0))) + (debug:print 0 *default-log-port* "ERROR: no main.db found at " (areadb:dbfile-path areadat 0))) areadat)) ;; given an areadat and target/runname patt fill up runs data ;; ;; ?????/ @@ -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 #f "current-matrix=" current-matrix) + ;; (debug:print 0 *default-log-port* "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)) @@ -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 #f "Adding area " hed " with index " index " to dashboard") + (debug:print 0 *default-log-port* "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)))) 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 #f "CHANGE(S): " (car changes) "...")) + (debug:print 11 *default-log-port* "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 #f "Attempting to start the server ...") + (debug:print 2 *default-log-port* "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 #f "WARNING: Failed to connect to server (self) on host " hostn ":" start-port ", trying again.") + (debug:print 0 *default-log-port* "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 #f "ERROR: could not find an open port to start server on. Giving up") + (debug:print 0 *default-log-port* "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 #f "server, received: " dat) + (debug:print 0 *default-log-port* "server, received: " dat) (let ((result (api:execute-requests dbstruct dat))) - (debug:print 0 #f "server, sending: " result) + (debug:print 0 *default-log-port* "server, sending: " result) (nn-send repsoc (db:obj->string result transport: 'nmsg))) (loop (nn-recv repsoc)))))) ;; all routes though here end in exit ... ;; @@ -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 #f "success=" success ", key=" key ", expected-key=" expected-key ", equal? " (equal? key expected-key)) + (debug:print 0 *default-log-port* "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 @@ -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 #f "ERROR: error occured at server, info=" (vector-ref result 2)) - (debug:print 0 #f " client call chain:") + (debug:print 0 *default-log-port* "ERROR: error occured at server, info=" (vector-ref result 2)) + (debug:print 0 *default-log-port* " client call chain:") (print-call-chain (current-error-port)) - (debug:print 0 #f " server call chain:") + (debug:print 0 *default-log-port* " 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")))))) @@ -339,20 +339,20 @@ ;; DO NOT USE ;; (define (nmsg-transport:client-signal-handler signum) (handle-exceptions exn - (debug:print 0 #f " ... exiting ...") + (debug:print 0 *default-log-port* " ... 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 #f "ERROR: Received ^C, attempting clean exit. Please be patient and wait a few seconds before hitting ^C again.") + (debug:print 0 *default-log-port* "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 #f " Done.") + (debug:print 0 *default-log-port* " 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 #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)) + (debug:print 0 *default-log-port* "ERROR: portlogger:open-run-close failed. " proc " " params) + (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) + (debug:print 0 *default-log-port* "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 #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)) + (debug:print 0 *default-log-port* "EXCEPTION: portlogger database probably overloaded or unreadable. If you see this message again remove /tmp/.$USER-portlogger.db") + (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) + (debug:print 0 *default-log-port* "exn=" (condition->list exn)) (print-call-chain (current-error-port)) - (debug:print 0 #f "Continuing anyway.") + (debug:print 0 *default-log-port* "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 #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)) + (debug:print 0 *default-log-port* "EXCEPTION: portlogger database probably overloaded or unreadable. If you see this message again remove /tmp/.$USER-portlogger.db") + (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) + (debug:print 0 *default-log-port* "exn=" (condition->list exn)) (print-call-chain (current-error-port)) - (debug:print 0 #f "Continuing anyway.")) + (debug:print 0 *default-log-port* "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 #f "EXCEPTION: portlogger database at " dbfname " probably overloaded or unreadable. Try removing it.") - (debug:print 0 #f " message: " ((condition-property-accessor 'exn 'message) exn)) + (debug:print 0 *default-log-port* "EXCEPTION: portlogger database at " dbfname " probably overloaded or unreadable. Try removing it.") + (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) (print "exn=" (condition->list exn)) - (debug:print 0 #f " status: " ((condition-property-accessor 'sqlite3 'status) exn)) + (debug:print 0 *default-log-port* " 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 #f " message: " ((condition-property-accessor 'exn 'message) exn)) + (debug:print 0 *default-log-port* " 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 #f + (debug:print 0 *default-log-port* (if (string? print-cmd) print-cmd "") cmdline (if params Index: rmt.scm ================================================================== --- rmt.scm +++ rmt.scm @@ -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 #f "WARNING: Communication failed, trying call to rmt:send-receive again.") + (debug:print 0 *default-log-port* "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) @@ -159,11 +159,11 @@ (server:kind-run run-id))) ;; return the result! newres) ))) (begin - ;; (debug:print 0 #f "ERROR: Communication failed!") + ;; (debug:print 0 *default-log-port* "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 #f "WARNING: stats collection failed in update-db-stats") - (debug:print 0 #f " message: " ((condition-property-accessor 'exn 'message) exn)) + (debug:print 0 *default-log-port* "WARNING: stats collection failed in update-db-stats") + (debug:print 0 *default-log-port* " 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 #f "DB Stats\n========") - (debug:print 18 #f (format #f "~40a~8a~10a~10a" "Cmd" "Count" "TotTime" "Avg")) + (debug:print 18 *default-log-port* "DB Stats\n========") + (debug:print 18 *default-log-port* (format #f "~40a~8a~10a~10a" "Cmd" "Count" "TotTime" "Avg")) (for-each (lambda (cmd) (let ((cmd-dat (hash-table-ref *db-stats* cmd))) - (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)))))) + (debug:print 18 *default-log-port* (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 #f "ERROR: local query failed. Trying again.") + (debug:print 0 *default-log-port* "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 #f "ERROR: too many retries in rmt:open-qry-close-locally, giving up") + (debug:print 0 *default-log-port* "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 #f "ERROR: rmt:send-receive-no-auto-client-setup failed, attempting to continue. Got " dat) +;; (debug:print 0 *default-log-port* "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 #f "WARNING: Bad data handed to rmt:get-test-info-by-id run-id=" run-id ", test-id=" test-id) + (debug:print 0 *default-log-port* "WARNING: Bad data handed to rmt:get-test-info-by-id run-id=" run-id ", test-id=" test-id) (print-call-chain (current-error-port)) #f))) (define (rmt:test-get-rundir-from-test-id run-id test-id) (rmt:send-receive 'test-get-rundir-from-test-id run-id (list run-id test-id))) @@ -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 #f "TEST PATH: " test-path) + (debug:print 3 *default-log-port* "TEST PATH: " test-path) (open-test-db test-path))) ;; WARNING: This currently bypasses the transaction wrapped writes system (define (rmt:test-set-state-status-by-id run-id test-id newstate newstatus newcomment) (rmt:send-receive 'test-set-state-status-by-id run-id (list run-id test-id newstate newstatus newcomment))) @@ -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 0 #f "ERROR: rmt:get-tests-for-run called with bad run-id=" run-id) + (debug:print 0 *default-log-port* "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 #f "ERROR: get-tests-for-run-mindata failed for run-id " hed ", testpatt " testpatt ", states " states ", status " status ", not-in " not-in)))) + (debug:print 0 *default-log-port* "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 #f "selstr: " selstr ", qrystr: " qrystr ", keyvals: " keyvals ", previous run ids found: " prev-run-ids) + (debug:print 4 *default-log-port* "selstr: " selstr ", qrystr: " qrystr ", keyvals: " keyvals ", previous run ids found: " prev-run-ids) (if (null? prev-run-ids) #f (let loop ((hed (car prev-run-ids)) (tal (cdr prev-run-ids))) (let ((results (rmt:get-tests-for-run hed (conc test-name "/" item-path) '() '() #f #f #f #f #f #f #f 'normal))) - (debug:print 4 #f "Got tests for run-id " run-id ", test-name " test-name ", item-path " item-path ": " results) + (debug:print 4 *default-log-port* "Got tests for run-id " run-id ", test-name " test-name ", item-path " item-path ": " results) (if (and (null? results) (not (null? tal))) (loop (car tal)(cdr tal)) (if (null? results) #f (car results)))))))))) @@ -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 #f "WARNING: Invalid " (if status "status" "state") + (debug:print 3 *default-log-port* "WARNING: Invalid " (if status "status" "state") " value \"" (if status state-in status-in) "\", update your validvalues section in megatest.config")) (rmt:send-receive 'teststep-set-status! run-id (list run-id test-id teststep-name state-in status-in comment logfile)))) (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 #f "Remote failed for " proc " " params) + (debug:print 1 *default-log-port* "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 #f "INFO: Server for run-id " run-id " already running") + (debug:print 0 *default-log-port* "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) @@ -62,11 +62,11 @@ (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 #f "Attempting to start the rpc server ...") + (debug:print 2 *default-log-port* "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 #f "Server started on " host:port) + (debug:print 0 *default-log-port* "Server started on " host:port) ;; (trace rpc:publish-procedure!) ;; (rpc:publish-procedure! 'server:login server:login) ;; (rpc:publish-procedure! 'testing (lambda () "Just testing")) @@ -162,11 +162,11 @@ (exit 1)))))) (define (rpc-transport:client-setup run-id #!key (remtries 10)) (if *runremote* (begin - (debug:print 0 #f "ERROR: Attempt to connect to server but already connected") + (debug:print 0 *default-log-port* "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)) @@ -205,12 +205,12 @@ ;; (let ((portn (string->number port))) ;; (debug:print-info 2 #f "Setting up to connect to host " host ":" port) ;; (handle-exceptions ;; exn ;; (begin -;; (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)) +;; (debug:print 0 *default-log-port* "ERROR: Failed to open a connection to the server at host: " host " port: " port) +;; (debug:print 0 *default-log-port* " 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)) 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 #f "ERROR: setup-env-defaults called with no run-id or -target or -reqtarg") + (debug:print 0 *default-log-port* "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 #f "Using key=\"" thekey "\"") + (debug:print 4 *default-log-port* "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 #f "Key settings found in runconfig.config:") + (debug:print 2 *default-log-port* "Key settings found in runconfig.config:") (for-each (lambda (fullkey) - (debug:print 2 #f (format #f "~20a ~a\n" fullkey (hash-table-ref/default whatfound fullkey 0)))) + (debug:print 2 *default-log-port* (format #f "~20a ~a\n" fullkey (hash-table-ref/default whatfound fullkey 0)))) sections) - (debug:print 2 #f "---") + (debug:print 2 *default-log-port* "---") (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 #f "WARNING: You do not have a run config file: " runconfigf)))) + (debug:print 0 *default-log-port* "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 #f "ERROR: linktree not set, should be set in megatest.config in [setup] section.")) + (debug:print 0 *default-log-port* "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 #f "setenv " key " " val) + (debug:print 2 *default-log-port* "setenv " key " " val) (safe-setenv key val))) (if (not (get-environment-variable "MT_TARGET"))(setenv "MT_TARGET" target)) (alist->env-vars (hash-table-ref/default *configdat* "env-override" '())) ;; Lets use this as an opportunity to put MT_RUNNAME in the environment (let ((runname (if inrunname inrunname (rmt:get-run-name-from-id run-id)))) (if runname (setenv "MT_RUNNAME" runname) - (debug:print 0 #f "ERROR: no value for runname for id " run-id))) + (debug:print 0 *default-log-port* "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 #f "setenv " (car item) " " (cadr item)) + (debug:print 2 *default-log-port* "setenv " (car item) " " (cadr item)) (setenv (car item) (cadr item))) itemdat)) ;; Every time can-run-more-tests is called increment the delay ;; @@ -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 #f "max-concurrent-jobs: " max-concurrent-jobs ", num-running: " num-running) + (debug:print 2 *default-log-port* "max-concurrent-jobs: " max-concurrent-jobs ", num-running: " num-running) (set! *last-num-running-tests* num-running))) (if (not (eq? 0 *globalexitstatus*)) (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 #f "WARNING: Max running jobs exceeded, current number running: " num-running + (debug:print 0 *default-log-port* "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 #f "WARNING: number of jobs " num-running-in-jobgroup + (debug:print 1 *default-log-port* "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 #f "Done") + (debug:print 0 *default-log-port* "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 #f "WARNING: You do not have a run config file: " runconfigf) + (debug:print 0 *default-log-port* "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") @@ -308,11 +308,11 @@ ;; 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 #f "ERROR: test " hed " has listed itself as a waiton or waitor, please correct this!") + (debug:print 0 *default-log-port* "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)) @@ -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 #f "ERROR: failure in runs:run-tests-queue thread, error: " ((condition-property-accessor 'exn 'message) exn)) + ;; (debug:print 0 *default-log-port* "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 #f "error in calling find-and-mark-incomplete for run-id " run-id) + (debug:print 0 *default-log-port* "error in calling find-and-mark-incomplete for run-id " run-id) (rmt:find-and-mark-incomplete run-id #f)))) ;; ovr-deadtime))) run-ids))) "runs: mark-incompletes"))) (thread-start! th1) (thread-start! th2) @@ -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 #f "ERROR: runs:queue-next-hed, tal=" tal ", reg=" reg ", n=" n ", regfull=" regfull) +;; (debug:print 0 *default-log-port* "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,11 +475,11 @@ (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 #f + (debug:print 0 *default-log-port* "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)) @@ -527,11 +527,11 @@ ;; 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 #f "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 *default-log-port* "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))) ;; @@ -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 #f "ERROR: The proc from reading the items table did not yield a list - please report this") + (debug:print 0 *default-log-port* "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 #f "WARNING: test " hed " has discarded prerequisites, removing it from the queue") + (debug:print 1 *default-log-port* "WARNING: test " hed " has discarded prerequisites, removing it from the queue") (let ((test-id (rmt:get-test-id run-id hed ""))) (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) @@ -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 #f "WARNING: FAILS or incomplete tests maybe preventing completion of this run. Watch for issues with test " hed ", continuing for now") + (debug:print 0 *default-log-port* "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,11 +682,11 @@ (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 #f "ERROR: prereqs-not-met is not a list! " prereqs-not-met) + (debug:print 0 *default-log-port* "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)) @@ -740,11 +740,11 @@ (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 #f "ERROR: failed to register test " (db:test-make-full-name test-name item-path))))) + (debug:print 0 *default-log-port* "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)))) @@ -810,11 +810,11 @@ #f)) ;; must be we have unmet prerequisites ;; (else - (debug:print 4 #f "FAILS: " fails) + (debug:print 4 *default-log-port* "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)) @@ -831,11 +831,11 @@ (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 #f "WARNING: Dropping test " test-name "/" item-path + (debug:print 1 *default-log-port* "WARNING: Dropping test " test-name "/" item-path " from the launch list as it has prerequistes that are FAIL") (let ((test-id (rmt:get-test-id run-id hed ""))) (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 #f "WARNING: test " hed " has possible RUNNING prerequisites, don't give up on it yet.")) + (debug:print 0 *default-log-port* "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 #f "WARNING: not removing test " hed " from queue although it may not be runnable due to FAILED prerequisites")) + (debug:print 1 *default-log-port* "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 #f "WARNING: test " hed " has FAILED prerequisites or other issue. Internal state " nth-try " will be overridden and we'll retry.")) + (debug:print 0 *default-log-port* "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 #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) + (debug:print 0 *default-log-port* "WARNING: test " hed " has FAILED prerequitests and we've tried at least 10 times to run it. Giving up now.")) + ;; (debug:print 0 *default-log-port* " prereqs: " prereqs-not-met) (hash-table-set! test-registry hed 'removed) (mt:test-set-state-status-by-testname run-id test-name item-path "NOT_STARTED" "TEN_STRIKES" #f) ;; I'm unclear on if this roll up is needed - it may be the root cause of the "all set to FAIL" bug. (rmt: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 #f "test-records: " test-records ", flags: " (hash-table->alist flags)) + (debug:print 5 *default-log-port* "test-records: " test-records ", flags: " (hash-table->alist flags)) ;; Do mark-and-find clean up of db before starting runing of quue ;; ;; (rmt:find-and-mark-incomplete) @@ -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 #f "max-tries-hash: " (hash-table->alist *max-tries-hash*)) + ;; (debug:print 0 *default-log-port* "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 @@ -1034,11 +1034,11 @@ (runs:queue-next-tal tal reg reglen regfull) (runs:queue-next-reg tal reg reglen regfull) reruns)))) ;; (loop (car tal)(cdr tal) reg reruns)))) - (debug:print 4 #f "TOP OF LOOP => " + (debug:print 4 *default-log-port* "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 #f "ERROR: test " test-name " has listed itself as a waiton, please correct this!") + (debug:print 0 *default-log-port* "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,11 +1083,11 @@ (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 #f "WARNING: Marking test " tfullname " as not runnable. It is waiting on tests that cannot be run. Giving up now.") + (debug:print 0 *default-log-port* "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) @@ -1107,11 +1107,11 @@ (if (and (list? items) (> (length items) 0) (and (list? (car items)) (> (length (car items)) 0)) (debug:debug-mode 1)) - (debug:print 2 #f (map (lambda (row) + (debug:print 2 *default-log-port* (map (lambda (row) (conc (string-intersperse (map (lambda (varval) (string-intersperse varval "=")) row) " ") @@ -1156,11 +1156,11 @@ ;; 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 #f "ERROR: Should not have a list of items in a test and the itemspath set - please report this") + (debug:print 0 *default-log-port* "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 #f "full drop through, if reruns is less than 100 we will force retry them, reruns=" reruns ", tal=" tal) @@ -1182,17 +1182,17 @@ ;; 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 #f "num-running=" num-running ", prev-num-running=" prev-num-running) + ;; (debug:print 0 *default-log-port* "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 #f "Got here eh! num-running=" num-running " (> num-running 0) " (> num-running 0)) + ;; (debug:print 0 *default-log-port* "Got here eh! num-running=" num-running " (> num-running 0) " (> num-running 0)) (if (> (current-seconds)(+ last-time-incomplete 900)) (begin (debug:print-info 0 #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))) @@ -1274,11 +1274,11 @@ (debug:print-info 4 #f "\nTESTNAME: " full-test-name "\n test-config: " (hash-table->alist test-conf) "\n itemdat: " itemdat ) - (debug:print 2 #f "Attempting to launch test " full-test-name) + (debug:print 2 *default-log-port* "Attempting to launch test " full-test-name) ;; (setenv "MT_TEST_NAME" test-name) ;; ;; (setenv "MT_ITEMPATH" item-path) ;; (setenv "MT_RUNNAME" runname) (runs:set-megatest-env-vars run-id inrunname: runname testname: test-name itempath: item-path) ;; these may be needed by the launching process (change-directory *toppath*) @@ -1310,11 +1310,11 @@ ;; 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 #f "WARN: Test not pre-created? test-name=" test-name ", item-path=" item-path ", run-id=" run-id) + (debug:print 2 *default-log-port* "WARN: Test not pre-created? test-name=" test-name ", item-path=" item-path ", run-id=" run-id) (rmt:register-test run-id test-name item-path) (set! test-id (rmt:get-test-id run-id test-name item-path)))) (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) @@ -1321,24 +1321,24 @@ (begin (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 #f "ERROR: failed to get test record for test-id " test-id)) + (debug:print 0 *default-log-port* "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 0 #f "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 *default-log-port* "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 #f "ERROR: Failed to insert the record into the db")) + (debug:print 0 *default-log-port* "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)) @@ -1367,15 +1367,15 @@ (set! runflag #f)) ((and (not rerun) (member (test:get-status testdat) '("FAIL" "n/a"))) (set! runflag #t)) (else (set! runflag #f))) - (debug:print 4 #f "RUNNING => runflag: " runflag " STATE: " (test:get-state testdat) " STATUS: " (test:get-status testdat)) + (debug:print 4 *default-log-port* "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 #f "NOTE: Not starting test " full-test-name " as it is state \"" (test:get-state testdat) + (debug:print 1 *default-log-port* "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 @@ -1416,25 +1416,25 @@ (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 #f "NOTE: " full-test-name " is already running or was explictly killed, use -force to launch it.") + (debug:print 1 *default-log-port* "NOTE: " full-test-name " is already running or was explictly killed, use -force to launch it.") (hash-table-set! test-registry (db:test-make-full-name test-name test-path) 'DONOTRUN)) ;; KILLED)) ((LAUNCHED REMOTEHOSTSTART RUNNING) - (debug:print 2 #f "NOTE: " test-name " is already running")) + (debug:print 2 *default-log-port* "NOTE: " test-name " is already running")) ;; (if (> (- (current-seconds)(+ (db:test-get-event_time testdat) ;; (db:test-get-run_duration testdat))) ;; (or incomplete-timeout ;; 6000)) ;; i.e. no update for more than 6000 seconds ;; (begin - ;; (debug:print 0 #f "WARNING: Test " test-name " appears to be dead. Forcing it to state INCOMPLETE and status STUCK/DEAD") + ;; (debug:print 0 *default-log-port* "WARNING: Test " test-name " appears to be dead. Forcing it to state INCOMPLETE and status STUCK/DEAD") ;; (tests:test-set-status! run-id test-id "INCOMPLETE" "STUCK/DEAD" "" #f)) ;; ;; (tests:test-set-status! test-id "INCOMPLETE" "STUCK/DEAD" "" #f)) - ;; (debug:print 2 #f "NOTE: " test-name " is already running"))) + ;; (debug:print 2 *default-log-port* "NOTE: " test-name " is already running"))) (else - (debug:print 0 #f "ERROR: Failed to launch test " full-test-name ". Unrecognised state " (test:get-state testdat)) + (debug:print 0 *default-log-port* "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 #f "ERROR: There was a problem removing " real-dir " with rm -f"))))) + (debug:print 0 *default-log-port* "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) @@ -1499,11 +1499,11 @@ (rp-mutex (make-mutex)) (bup-mutex (make-mutex))) (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 #f "ERROR: the parameter to -set-state-status is a comma delimited string. E.g. COMPLETED,FAIL") + (debug:print 0 *default-log-port* "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) "/")) @@ -1530,28 +1530,28 @@ ((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 #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"))) + ;; (debug:print 0 *default-log-port* "not attempting to kill any run launcher processes as testpatt is " testpatt)) + (debug:print 1 *default-log-port* "Removing tests for run: " runkey " " (db:get-value-by-header run header "runname"))) ((set-state-status) (if (tasks:need-server run-id)(tasks:start-and-wait-for-server tdbdat run-id 10)) - (debug:print 1 #f "Modifying state and staus for tests for run: " runkey " " (db:get-value-by-header run header "runname"))) + (debug:print 1 *default-log-port* "Modifying state and staus for tests for run: " runkey " " (db:get-value-by-header run header "runname"))) ((print-run) - (debug:print 1 #f "Printing info for run " runkey ", run=" run ", tests=" tests ", header=" header) + (debug:print 1 *default-log-port* "Printing info for run " runkey ", run=" run ", tests=" tests ", header=" header) action) ((run-wait) - (debug:print 1 #f "Waiting for run " runkey ", run=" runnamepatt " to complete")) + (debug:print 1 *default-log-port* "Waiting for run " runkey ", run=" runnamepatt " to complete")) ((archive) - (debug:print 1 #f "Archiving/restoring (" (args:get-arg "-archive") ") data for run: " runkey " " (db:get-value-by-header run header "runname")) + (debug:print 1 *default-log-port* "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 #f "ERROR: unrecognised sub command to -archive. Run \"megatest\" to see help") + (debug:print 0 *default-log-port* "ERROR: unrecognised sub command to -archive. Run \"megatest\" to see help") (exit)))) "archive-bup-thread")) (thread-start! worker-thread)) (else (debug:print-info 0 #f "action not recognised " action))) @@ -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 #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!") + (debug:print 0 *default-log-port* "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,11 +1592,11 @@ (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 #f "WARNING: skipping removal of " test-fulln " with run-id " run-id " as it has sub tests") + (debug:print 0 *default-log-port* "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)))) @@ -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 #f "WARNING: could not gracefully remove test " test-fulln ", tried to kill it to no avail. Forcing state to FAILEDKILL and continuing") + (debug:print 0 *default-log-port* "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))) @@ -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 #f "Removing run: " runkey " " (db:get-value-by-header run header "runname") " and related record") + (debug:print 1 *default-log-port* "Removing run: " runkey " " (db:get-value-by-header run header "runname") " and related record") (rmt:delete-run run-id) (rmt:delete-old-deleted-test-records) ;; (rmt:set-var "DELETED_TESTS" (current-seconds)) ;; need to figure out the path to the run dir and remove it if empty ;; (if (null? (glob (conc runpath "/*"))) ;; (begin - ;; (debug:print 1 #f "Removing run dir " runpath) + ;; (debug:print 1 *default-log-port* "Removing run dir " runpath) ;; (system (conc "rmdir -p " runpath)))) ))))) )) runs) ;; (sqlite3:finalize! (db:delay-if-busy tdbdat)) @@ -1693,32 +1693,32 @@ (file-exists? real-dir)) ;; bad heuristic but should prevent /tmp /home etc. (begin ;; let* ((realpath (resolve-pathname run-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 #f "WARNING: test dir " real-dir " appears to not exist or is not readable"))) + (debug:print 0 *default-log-port* "WARNING: test dir " real-dir " appears to not exist or is not readable"))) (if real-dir - (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"))) + (debug:print 0 *default-log-port* "WARNING: directory " real-dir " does not exist") + (debug:print 0 *default-log-port* "WARNING: no real directory corrosponding to link " run-dir ", nothing done"))) (if (symbolic-link? run-dir) (begin (debug:print-info 1 #f "Removing symlink " run-dir) (handle-exceptions exn - (debug:print 0 #f "ERROR: Failed to remove symlink " run-dir ((condition-property-accessor 'exn 'message) exn) ", attempting to continue") + (debug:print 0 *default-log-port* "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 #f "WARNING: refusing to remove " run-dir " as it is not empty") + (debug:print 0 *default-log-port* "WARNING: refusing to remove " run-dir " as it is not empty") (handle-exceptions exn - (debug:print 0 #f "ERROR: Failed to remove directory " run-dir ((condition-property-accessor 'exn 'message) exn) ", attempting to continue") + (debug:print 0 *default-log-port* "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 #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.")) + (debug:print 0 *default-log-port* "WARNING: not removing " run-dir " as it either doesn't exist or is not a symlink") + (debug:print 0 *default-log-port* "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 #f "ERROR: Missing required parameter for " switchname ", you must specify the target with -target") + (debug:print 0 *default-log-port* "ERROR: Missing required parameter for " switchname ", you must specify the target with -target") (exit 3)) ((not runname) - (debug:print 0 #f "ERROR: Missing required parameter for " switchname ", you must specify the run name with -runname runname") + (debug:print 0 *default-log-port* "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 #f "Failed to setup, exiting") + (debug:print 0 *default-log-port* "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 #f "ERROR: [" (args:get-arg "-reqtarg") "] not found in " runconfigf) + (debug:print 0 *default-log-port* "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 #f "ERROR: Attempted to " action-desc " but run area config file not found") + (debug:print 0 *default-log-port* "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))) @@ -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 #f "idx: " idx " fld: " fld " val: " val) + ;; (debug:print 5 *default-log-port* "idx: " idx " fld: " fld " val: " val) (if (and val (not (equal? (vector-ref currrecord idx) val))) (begin (print "Updating " test-name " " fld " to " val) (rmt:testmeta-update-field test-name fld val))))) '(("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 #f "runs:rollup-run, keys: " keys " -runname " runname " user: " user) + (debug:print 4 *default-log-port* "runs:rollup-run, keys: " keys " -runname " runname " user: " user) (let* ((db #f) ;; register run operates on the main db (new-run-id (rmt:register-run keyvals runname "new" "n/a" user)) (prev-tests (rmt:get-matching-previous-test-run-records new-run-id "%" "%")) (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 #f "Copying records in test_steps from test_id=" (db:test-get-id testdat) " to " (db:test-get-id new-testdat)) + (debug:print 4 *default-log-port* "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 #f "Copying records in test_data from test_id=" (db:test-get-id testdat) " to " (db:test-get-id new-testdat)) + (debug:print 4 *default-log-port* "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 #f "ERROR: unknown server type " *transport-type*)))) -;; (else (debug:print 0 #f "ERROR: No known transport set, transport=" transport ", using rpc") + (else (debug:print 0 *default-log-port* "ERROR: unknown server type " *transport-type*)))) +;; (else (debug:print 0 *default-log-port* "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 ;;====================================================================== @@ -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 #f "ERROR: unrecognised transport type: " *transport-type*) + (debug:print 0 *default-log-port* "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 #f "INFO: Starting server (" cmdln ") as none running ...") + (debug:print 0 *default-log-port* "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 @@ -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 #f "ERROR: must specify run-id when doing ping, -run-id n") + (debug:print 0 *default-log-port* "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 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 #f "ERROR: problem accessing db " dbpath + (debug:print 2 *default-log-port* "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 #f "ERROR: problem accessing db " dbpath + (debug:print 2 *default-log-port* "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 @@ -113,11 +113,11 @@ (define (sretrieve:db-do configdat proc) (let ((path (configf:lookup configdat "database" "location"))) (if (not path) (begin - (debug:print 0 #f "[database]\nlocation /some/path\n\n Is missing from the config file!") + (debug:print 0 *default-log-port* "[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")) @@ -124,37 +124,37 @@ (writeable (file-write-access? dbpath)) (dbexists (file-exists? dbpath))) (handle-exceptions exn (begin - (debug:print 2 #f "ERROR: problem accessing db " dbpath + (debug:print 2 *default-log-port* "ERROR: problem accessing db " dbpath ((condition-property-accessor 'exn 'message) exn)) (exit 1)) - ;;(debug:print 0 #f "calling proc " proc "db path " dbpath ) + ;;(debug:print 0 *default-log-port* "calling proc " proc "db path " dbpath ) (call-with-database dbpath (lambda (db) - ;;(debug:print 0 #f "calling proc " proc " on db " db) + ;;(debug:print 0 *default-log-port* "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 #f "ERROR: invalid path for storing database: " path)))) + (debug:print 0 *default-log-port* "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 #f "ERROR: Bad configuration! base-dir " base-dir " not found") + (debug:print 0 *default-log-port* "ERROR: Bad configuration! base-dir " base-dir " not found") (exit 1))) (print datadir) (if (not (file-exists? datadir)) (begin - (debug:print 0 #f "ERROR: Bad version (" version "), no data found at " datadir "." ) + (debug:print 0 *default-log-port* "ERROR: Bad version (" version "), no data found at " datadir "." ) (exit 1))) (sretrieve:db-do configdat (lambda (db) @@ -187,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 #f "ERROR: Bad configuration! base-dir " base-dir " not found") + (debug:print 0 *default-log-port* "ERROR: Bad configuration! base-dir " base-dir " not found") (exit 1))) (print datadir) (if (not (file-exists? datadir)) (begin - (debug:print 0 #f "ERROR: File (" file "), not found at " base-dir "." ) + (debug:print 0 *default-log-port* "ERROR: File (" file "), not found at " base-dir "." ) (exit 1))) (if (directory? datadir) (begin - (debug:print 0 #f "ERROR: (" file ") is a dirctory!! cp cmd works only on files ." ) + (debug:print 0 *default-log-port* "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 #f "ERROR: Access denied to file (" file ")!! " ) + (debug:print 0 *default-log-port* "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 #f "ph: "(pathname-directory datadir) "!! " ) + ;; (debug:print 0 *default-log-port* "ph: "(pathname-directory datadir) "!! " ) (change-directory (pathname-directory datadir)) - ;;(debug:print 0 #f "ph: /bin/tar" (list "chfv" "-" filename) ) + ;;(debug:print 0 *default-log-port* "ph: /bin/tar" (list "chfv" "-" filename) ) (process-execute "/bin/tar" (list "chfv" "-" filename))) )) ;; ls in file to dest, validation is done BEFORE calling this ;; @@ -224,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 #f "ERROR: Bad configuration! base-dir " base-dir " not found") + (debug:print 0 *default-log-port* "ERROR: Bad configuration! base-dir " base-dir " not found") (exit 1))) (print datadir) (if (not (file-exists? datadir)) (begin - (debug:print 0 #f "ERROR: File (" file "), not found at " base-dir "." ) + (debug:print 0 *default-log-port* "ERROR: File (" file "), not found at " base-dir "." ) (exit 1))) (if(not (string-match (regexp allowed-sub-paths) file)) (begin - (debug:print 0 #f "ERROR: Access denied to file (" file ")!! " ) + (debug:print 0 *default-log-port* "ERROR: Access denied to file (" file ")!! " ) (exit 1))) (sretrieve:do-as-calling-user (lambda () ;;(change-directory datadir) - ;; (debug:print 0 #f "/usr/bin/find" (list datadir "-ls" "|" "grep" "-E" "'"allowed-file-patt"'")) + ;; (debug:print 0 *default-log-port* "/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 #f status) + ;; (debug:print 0 *default-log-port* status) (process-execute "/bin/ls" (list "-ls" "-lrt" datadir )) )))) @@ -256,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 #f "ERROR: Path " targ-mk " resolved outside target area " target-dir ) + (debug:print 0 *default-log-port* "ERROR: Path " targ-mk " resolved outside target area " target-dir ) (exit 1))) (if (not (string-contains targ-path target-dir)) (begin - (debug:print 0 #f "ERROR: You cannot update data outside " target-dir ".") + (debug:print 0 *default-log-port* "ERROR: You cannot update data outside " target-dir ".") (exit 1))) - (debug:print 0 #f "Path " targ-mk " is valid.") + (debug:print 0 *default-log-port* "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 #f "ERROR: target Directory " targ-path " already exist!!") + (debug:print 0 *default-log-port* "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 #f " ... dir " targ-path " created")) + (debug:print 0 *default-log-port* " ... dir " targ-path " created")) "mkdir thread")) (th2 (make-thread (lambda () (let loop () (thread-sleep! 15) @@ -303,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 #f "ERROR: target file " targ-path " already exist!!") + (debug:print 0 *default-log-port* "ERROR: target file " targ-path " already exist!!") (exit 1))) (if (not (file-exists? targ-link )) (begin - (debug:print 0 #f "ERROR: target file " targ-link " does not exist!!") + (debug:print 0 *default-log-port* "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 #f " ... link " targ-path " created")) + (debug:print 0 *default-log-port* " ... link " targ-path " created")) "symlink thread")) (th2 (make-thread (lambda () (let loop () (thread-sleep! 15) @@ -339,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 #f "ERROR: target file " targ-path " not found, nothing to remove.") + (debug:print 0 *default-log-port* "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 #f " ... file " targ-path " removed")) + (debug:print 0 *default-log-port* " ... file " targ-path " removed")) "rm thread")) (th2 (make-thread (lambda () (let loop () (thread-sleep! 15) @@ -392,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 #f "running as " (current-effective-user-id)) + ;; (debug:print 0 *default-log-port* "running as " (current-effective-user-id)) (proc) (if (not (eq? eid cid)) (set! (current-effective-user-id) eid)))) (define (sretrieve:find name paths) @@ -487,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 #f "ERROR: failed to run script " conversion-script " with params " upstream-file " " package-config) + (debug:print 0 *default-log-port* "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 #f "Skipping update of " package-config " from " upstream-file)) - (debug:print 0 #f "Skipping update of " package-config " as " upstream-file " not found")) + (debug:print 0 *default-log-port* "Skipping update of " package-config " from " upstream-file)) + (debug:print 0 *default-log-port* "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 #f "Reading package config " package-config) + (debug:print 0 *default-log-port* "Reading package config " package-config) (read-config package-config #f #t)) (make-hash-table)))) (pop-directory) res))) @@ -513,60 +513,60 @@ ""))) (default-area (configf:lookup configdat "settings" "default-area"))) ;; otherwise known as the package (if (not base-dir) (begin - (debug:print 0 #f "[settings]\nbase-dir /some/path\n\n Is MISSING from the config file!") + (debug:print 0 *default-log-port* "[settings]\nbase-dir /some/path\n\n Is MISSING from the config file!") (exit))) (if (null? allowed-users) (begin - (debug:print 0 #f "[setings]\nallowed-users user1 user2 ...\n\n Is MISSING from the config file!") + (debug:print 0 *default-log-port* "[setings]\nallowed-users user1 user2 ...\n\n Is MISSING from the config file!") (exit))) (if (not (member user allowed-users)) (begin - (debug:print 0 #f "User \"" (current-user-name) "\" does not have access. Exiting") + (debug:print 0 *default-log-port* "User \"" (current-user-name) "\" does not have access. Exiting") (exit 1))) (case (string->symbol action) ((get) (if (< (length args) 1) (begin - (debug:print 0 #f "ERROR: Missing arguments; " (string-intersperse args ", ")) + (debug:print 0 *default-log-port* "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 #f "retrieving " version " of " package-type " as tar data on stdout") + (debug:print 0 *default-log-port* "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 #f "ERROR: Missing arguments; " (string-intersperse args ", ")) + (debug:print 0 *default-log-port* "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 #f "copinging " file " to current directory " ) + (debug:print 0 *default-log-port* "copinging " file " to current directory " ) (sretrieve:cp configdat user file msg))) ((ls) (if (< (length args) 1) (begin - (debug:print 0 #f "ERROR: Missing arguments; " (string-intersperse args ", ")) + (debug:print 0 *default-log-port* "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 #f "Listing files in " ) + (debug:print 0 *default-log-port* "Listing files in " ) (sretrieve:ls configdat user dir msg))) - (else (debug:print 0 #f "Unrecognised command " action))))) + (else (debug:print 0 *default-log-port* "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))) @@ -612,8 +612,8 @@ (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 #f "ERROR: Unrecognised command. Try \"sretrieve help\""))))) + (else (debug:print 0 *default-log-port* "ERROR: Unrecognised command. Try \"sretrieve help\""))))) (main) 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 #f "ERROR: Called tasks:wait-on-journal with path=" path " (not a string)") + (debug:print 0 *default-log-port* "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 #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") + (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) + (debug:print 0 *default-log-port* " exn=" (condition->list exn)) + (debug:print 0 *default-log-port* "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 #f waiting-msg)) + (debug:print 0 *default-log-port* 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 #f "ERROR: Couldn't create path to " dbdir) + (debug:print 0 *default-log-port* "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 #f " message: " ((condition-property-accessor 'exn 'message) exn)) - (debug:print 0 #f " exn=" (condition->list exn)) + (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) + (debug:print 0 *default-log-port* " exn=" (condition->list exn)) (thread-sleep! 1) (tasks:open-db numretries (- numretries 1))) (begin (print-call-chain (current-error-port)) - (debug:print 0 #f " message: " ((condition-property-accessor 'exn 'message) exn)) - (debug:print 0 #f " exn=" (condition->list exn)))) + (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) + (debug:print 0 *default-log-port* " 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 #f "ERROR: no servers listed, should be at least one by now.") + #f;; (begin (debug:print 0 *default-log-port* "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 #f "INFO: am-i-the-server got record " first) + ;; (debug:print 0 *default-log-port* "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 #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) + (debug:print 0 *default-log-port* "WARNING: tasks:get-server db access error.") + (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) + (debug:print 0 *default-log-port* " for run " run-id) (print-call-chain (current-error-port)) (if (> retries 0) (begin - (debug:print 0 #f " trying call to tasks:get-server again in 10 seconds") + (debug:print 0 *default-log-port* " 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 #f "10 tries of tasks:get-server all crashed and burned. Giving up and returning \"no server found\""))) + (debug:print 0 *default-log-port* "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: @@ -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 #f "Try starting server for run-id " run-id)) + (debug:print 0 *default-log-port* "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)))))) @@ -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 #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.")) + (debug:print 0 *default-log-port* "No run launching processes found for " target " / " run-name " with testpatt " (or testpatt "* no testpatt specified! *")) + (debug:print 0 *default-log-port* "Found " (length records) " run(s) to kill.")) (for-each (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 #f "Sending SIGINT to process " pid " on host " hostname) + (debug:print 0 *default-log-port* "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 #f "Kill of process " pid " on host " hostname " failed.") - (debug:print 0 #f " message: " ((condition-property-accessor 'exn 'message) exn)) + (debug:print 0 *default-log-port* "Kill of process " pid " on host " hostname " failed.") + (debug:print 0 *default-log-port* " 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 #f "ERROR: no record or improper record for " target "/" run-name " in tasks_queue in main.db")))) + (debug:print 0 *default-log-port* "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 @@ -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 #f "ERROR: problem accessing test db " work-area ", you probably should clean and re-run this test" + (debug:print 2 *default-log-port* "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) @@ -85,11 +85,11 @@ ;; now let's test that everything is correct (handle-exceptions exn (begin (print-call-chain (current-error-port)) - (debug:print 0 #f "ERROR: problem accessing test db " work-area ", you probably should clean and re-run this test or remove the file " + (debug:print 0 *default-log-port* "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 ? @@ -105,19 +105,19 @@ ;; 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 #f "TEST PATH: " test-path) + (debug:print 3 *default-log-port* "TEST PATH: " test-path) (open-test-db test-path))) ;; find and open the testdat.db file for an existing test (define (tdb:open-test-db-by-test-id-local dbstruct run-id test-id #!key (work-area #f)) (let* ((test-path (if work-area work-area (db:test-get-rundir-from-test-id dbstruct run-id test-id)))) - (debug:print 3 #f "TEST PATH: " test-path) + (debug:print 3 *default-log-port* "TEST PATH: " test-path) (open-test-db test-path))) ;; find and open the testdat.db file for an existing test (define (tdb:open-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 #f "db:testdb-initialize START") + (debug:print 11 *default-log-port* "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 #f "db:testdb-initialize END")) + (debug:print 11 *default-log-port* "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 #f lin) + (debug:print 4 *default-log-port* 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 #f lin) + (debug:print 4 *default-log-port* 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 #f "step=" step) + (debug:print 6 *default-log-port* "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 #f "record(before) = " record + (debug:print 6 *default-log-port* "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 #f "record[1]=" (vector-ref record 1) + (debug:print 4 *default-log-port* "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 #f "record(after) = " record + (debug:print 6 *default-log-port* "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 #f "step=" step) + (debug:print 6 *default-log-port* "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 #f "record(before) = " record + (debug:print 6 *default-log-port* "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 #f "record[1]=" (vector-ref record 1) + (debug:print 4 *default-log-port* "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 #f "record(after) = " record + (debug:print 6 *default-log-port* "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 #f "Can't update testdat.db for test " test-id " read-only or non-existant")))) + (debug:print 2 *default-log-port* "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 #f "WARNING: problem with directory " d ", dropping it from tests path")) + (debug:print 0 *default-log-port* "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 #f "res=" res) + ;; (debug:print 0 *default-log-port* "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 @@ -145,11 +145,11 @@ (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 #f "ERROR: non-existent required test \"" test-name "\"") + (debug:print 0 *default-log-port* "ERROR: non-existent required test \"" test-name "\"") (exit 1)))) (instr2 (if config (config-lookup config "requirements" "waitor") ""))) (debug:print-info 8 #f "waitons string is " instr ", waitors string is " instr2) @@ -159,36 +159,36 @@ (let ((res (instr))) (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 #f "ERROR: something went wrong in processing waitons for test " test-name) + ;; NOTE: This is actually the case of *no* waitons! ;; (debug:print 0 *default-log-port* "ERROR: something went wrong in processing waitons for test " test-name) "")))) (newwaitors (string-split (cond ((procedure? instr2) (let ((res (instr2))) (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 #f "ERROR: something went wrong in processing waitons for test " test-name) + ;; NOTE: This is actually the case of *no* waitons! ;; (debug:print 0 *default-log-port* "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 #f "ERROR: test " test-name " has unrecognised waiton testname " x) + (debug:print 0 *default-log-port* "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 #f "ERROR: test " test-name " has unrecognised waiton testname " x) + (debug:print 0 *default-log-port* "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 #f "ERROR: test run directory is gone, cannot propagate waiver") + (debug:print 0 *default-log-port* "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 #f "INFO: Applying waiver rule \"" hed "\"") + (debug:print 0 *default-log-port* "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 #f "INFO: No logpro file " fname " falling back to diff") + (debug:print 0 *default-log-port* "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 #f "INFO: No logpro file " logpro-file " found, using diff rule") + (debug:print 0 *default-log-port* "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 #f "INFO: waiver command is \"" processed-cmd "\"") + (debug:print 0 *default-log-port* "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 #f "prev-status " prev-status ", prev-state " prev-state ", prev-comment " prev-comment) + (debug:print 4 *default-log-port* "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 #f "real-status " real-status ", waived " waived ", status " status) + (debug:print 4 *default-log-port* "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 #f + (debug:print 4 *default-log-port* "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 #f "Found path: " path) + (debug:print 4 *default-log-port* "Found path: " path) (change-directory path)) ;; (set! outputfilename (conc path "/" outputfilename))) - (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) + (debug:print 0 *default-log-port* "ERROR: summarize-items for run-id=" run-id ", test-name=" test-name ", no such path: " path)) + (debug:print 4 *default-log-port* "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"))) @@ -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 #f "step=" step) + (debug:print 6 *default-log-port* "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 #f "record(before) = " record + (debug:print 6 *default-log-port* "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 #f "record[1]=" (vector-ref record 1) + (debug:print 4 *default-log-port* "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 #f "record(after) = " record + (debug:print 6 *default-log-port* "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)))) @@ -822,11 +822,11 @@ ;; 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 #f "ERROR: bad priority value " priority ", using 0") 0))) + (if tmp tmp (begin (debug:print 0 *default-log-port* "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 #f "a=" a ", b=" b ", a-waitons=" a-waitons ", b-waitons=" b-waitons) + ;; (debug:print 0 *default-log-port* "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 #f "case1") + ;; (debug:print 0 *default-log-port* "case1") #t) ((member b a-waitons) ;; is a waiting on b? - ;; (debug:print 0 #f "case2") + ;; (debug:print 0 *default-log-port* "case2") #f) ((and (not (null? a-waitons)) ;; both have waitons - do not disturb (not (null? b-waitons))) - ;; (debug:print 0 #f "case2.1") + ;; (debug:print 0 *default-log-port* "case2.1") #t) ((and (null? a-waitons) ;; no waitons for a but b has waitons (not (null? b-waitons))) - ;; (debug:print 0 #f "case3") + ;; (debug:print 0 *default-log-port* "case3") #f) ((and (not (null? a-waitons)) ;; a has waitons but b does not (null? b-waitons)) - ;; (debug:print 0 #f "case4") + ;; (debug:print 0 *default-log-port* "case4") #t) ((not (eq? a-priority b-priority)) ;; use (> a-priority b-priority)) (else - ;; (debug:print 0 #f "case5") + ;; (debug:print 0 *default-log-port* "case5") (string>? a b)))))) (sort-fn2 (lambda (a b) (> (mungepriority (tests:testqueue-get-priority (hash-table-ref test-records a))) @@ -1037,21 +1037,21 @@ (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 #f "ERROR: non-existent required test \"" hed "\", grep through your testconfigs to find and remove or create the test. Discarding and continuing.") + (debug:print 0 *default-log-port* "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 #f "waitons string is " instr) (string-split (cond ((procedure? instr) (let ((res (instr))) (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 #f "ERROR: something went wrong in processing waitons for test " hed) + ;; NOTE: This is actually the case of *no* waitons! ;; (debug:print 0 *default-log-port* "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))) @@ -1059,11 +1059,11 @@ (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 #f "ERROR: test " hed " has listed itself as a waiton, please correct this!") + (debug:print 0 *default-log-port* "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 @@ -1163,15 +1163,15 @@ (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 #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)) + (debug:print 0 *default-log-port* "ERROR: tried for over a minute to update meta info and failed. Giving up") + (debug:print 0 *default-log-port* "EXCEPTION: database probably overloaded or unreadable.") + (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) (print "exn=" (condition->list exn)) - (debug:print 0 #f " status: " ((condition-property-accessor 'sqlite3 'status) exn)) + (debug:print 0 *default-log-port* " 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) ))) ;;======================================================================