Index: archive.scm ================================================================== --- archive.scm +++ archive.scm @@ -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 *default-log-port* "ERROR: the old directory " prev-test-physical-path ", still exists! Moving it to " newn) + (debug:print-error 0 *default-log-port* "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 *default-log-port* "ERROR: unable to get data for run-id=" run-id ", test-id=" test-id) + (debug:print-error 0 *default-log-port* "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 *default-log-port* "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 *default-log-port* "ERROR: No archive path in the record for run-id=" run-id " test-id=" test-id)))) + (debug:print-error 0 *default-log-port* "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 @@ -64,11 +64,11 @@ ;; ;; (define (client:setup-rpc run-id) ;; (debug:print 0 *default-log-port* "INFO: client:setup remaining-tries=" remaining-tries) ;; (if (<= remaining-tries 0) ;; (begin -;; (debug:print 0 *default-log-port* "ERROR: failed to start or connect to server for run-id " run-id) +;; (debug:print-error 0 *default-log-port* "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 *default-log-port* "client:setup host-info=" host-info ", remaining-tries=" remaining-tries) ;; (if host-info ;; (let* ((iface (car host-info)) @@ -157,11 +157,11 @@ (define (client:setup-http run-id #!key (remaining-tries 10) (failed-connects 0)) (debug:print-info 2 *default-log-port* "client:setup remaining-tries=" remaining-tries) (let* ((tdbdat (tasks:open-db))) (if (<= remaining-tries 0) (begin - (debug:print 0 *default-log-port* "ERROR: failed to start or connect to server for run-id " run-id) + (debug:print-error 0 *default-log-port* "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 *default-log-port* "client:setup server-dat=" server-dat ", remaining-tries=" remaining-tries) (if server-dat (let* ((iface (tasks:hostinfo-get-interface server-dat)) @@ -222,11 +222,11 @@ ;; (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 *default-log-port* "ERROR: Received ^C, attempting clean exit. Please be patient and wait a few seconds before hitting ^C again.") +;; (debug:print-error 0 *default-log-port* "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 *default-log-port* " Done.") ;; (exit 4)) ;; "exit on ^C timer"))) ;; (thread-start! 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 *default-log-port* "connected as client") ;; (begin -;; (debug:print 0 *default-log-port* "ERROR: Failed to connect as client") +;; (debug:print-error 0 *default-log-port* "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 *default-log-port* "ERROR: bad value for setenv, key=" key ", value=" val) + (debug:print-error 0 *default-log-port* "bad value for setenv, key=" key ", value=" val) (setenv key val)) - (debug:print 0 *default-log-port* "ERROR: bad value for setenv, key=" key ", value=" val))) + (debug:print-error 0 *default-log-port* "bad value for setenv, key=" key ", value=" val))) (define home (getenv "HOME")) (define user (getenv "USER")) ;; GLOBAL GLETCHES @@ -274,11 +274,11 @@ (handle-exceptions exn (handle-exceptions exn (begin - (debug:print 0 *default-log-port* "ERROR: received bad encoded string \"" instr "\", message: " ((condition-property-accessor 'exn 'message) exn)) + (debug:print-error 0 *default-log-port* "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)))))) @@ -417,11 +417,11 @@ (thread-join! th1)))) (define (std-signal-handler signum) ;; (signal-mask! signum) (set! *time-to-exit* #t) - (debug:print 0 *default-log-port* "ERROR: Received signal " signum " exiting promptly") + (debug:print-error 0 *default-log-port* "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) @@ -546,11 +546,11 @@ (if split tlist target) (if target (begin - (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") + (debug:print-error 0 *default-log-port* "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 @@ -651,11 +651,11 @@ (define (common:read-link-f path) (handle-exceptions exn (begin - (debug:print 0 *default-log-port* "ERROR: command \"/bin/readlink -f " path "\" failed.") + (debug:print-error 0 *default-log-port* "command \"/bin/readlink -f " path "\" failed.") path) ;; just give up (with-input-from-pipe (conc "/bin/readlink -f " path) (lambda () (read-line))))) @@ -801,11 +801,11 @@ (dbspace (cadr spacedat)) (required (caddr spacedat)) (dbdir (cadddr spacedat))) (if (not is-ok) (begin - (debug:print 0 *default-log-port* "ERROR: Insufficient space in " dbdir ", require " required ", have " dbspace ", exiting now.") + (debug:print-error 0 *default-log-port* "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) Index: common_records.scm ================================================================== --- common_records.scm +++ common_records.scm @@ -87,13 +87,29 @@ (if (debug:debug-mode n) (with-output-to-port (or e (current-error-port)) (lambda () (if *logging* (db:log-event (apply conc params)) - ;; (apply print "pid:" (current-process-id) " " params) (apply print params) ))))) + +(define (debug:print-error n e . params) + ;; normal print + (if (debug:debug-mode n) + (with-output-to-port (or e (current-error-port)) + (lambda () + (if *logging* + (db:log-event (apply conc params)) + ;; (apply print "pid:" (current-process-id) " " params) + (apply print "ERROR: " params) + )))) + ;; pass important messages to stderr + (if (and (eq? n 0)(not (eq? e (current-error-port)))) + (with-output-to-port (current-error-port) + (lambda () + (apply print "ERROR: " params) + )))) (define (debug:print-info n e . params) (if (debug:debug-mode n) (with-output-to-port (or e (current-error-port)) (lambda () 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 *default-log-port* "ERROR: problem evaluating \"" str "\" in the shell environment") + (debug:print-error 0 *default-log-port* "problem evaluating \"" str "\" in the shell environment") #f) (let ((cmdres (process:cmd-run->list (conc "echo " str)))) (if (null? cmdres) "" (caar cmdres))))) @@ -254,11 +254,11 @@ (status (cadr cmdres)) (res (car cmdres))) (debug:print-info 4 *default-log-port* "" inl "\n => " (string-intersperse res "\n")) (if (not (eq? status 0)) (begin - (debug:print 0 *default-log-port* "ERROR: problem with " inl ", return code " status + (debug:print-error 0 *default-log-port* "problem with " inl ", return code " status " output: " cmdres))) (if (> delta 2) (debug:print-info 0 *default-log-port* "for line \"" inl "\"\n command: " cmd " took " delta " seconds to run with output:\n " res) (debug:print-info 9 *default-log-port* "for line \"" inl "\"\n command: " cmd " took " delta " seconds to run with output:\n " res)) (if (null? res) @@ -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 *default-log-port* "ERROR: problem parsing " path ",\n \"" inl "\"") + (else (debug:print-error 0 *default-log-port* "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 *default-log-port* "ERROR: problem parsing line number " lnum "\"" hed "\""))))) + (debug:print-error 0 *default-log-port* "problem parsing line number " lnum "\"" hed "\""))))) (else - (debug:print 0 *default-log-port* "ERROR: Problem parsing line num " lnum " :\n " hed ))) + (debug:print-error 0 *default-log-port* "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.scm ================================================================== --- dashboard.scm +++ dashboard.scm @@ -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 *default-log-port* "ERROR: tree-path->run-id returned non-number " run-id))) + (debug:print-error 0 *default-log-port* "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 *default-log-port* "ERROR: tree-path->run-id returned non-number " run-id))) + (debug:print-error 0 *default-log-port* "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" 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 *default-log-port* "ERROR: query " stmt " failed, params: " params ", error: " ((condition-property-accessor 'exn 'message) exn)) + (debug:print-error 0 *default-log-port* " 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 *default-log-port* "ERROR: query " stmt " failed, params: " params ", error: " ((condition-property-accessor 'exn 'message) exn)) + (debug:print-error 0 *default-log-port* " 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 *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)) + (debug:print-error 0 *default-log-port* "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 *default-log-port* "ERROR: Couldn't create path to " dbdir) + (debug:print-error 0 *default-log-port* "Couldn't create path to " dbdir) (exit 1)) (if (not (directory? dbdir))(create-directory dbdir #t))) (if fname (conc dbdir "/" fname) dbdir))) @@ -218,11 +218,11 @@ (handle-exceptions exn (begin ;; (release-dot-lock dbpath) (if (> attemptnum 2) - (debug:print 0 *default-log-port* "ERROR: tried twice, cannot create/initialize db for run-id " run-id ", at path " dbpath) + (debug:print-error 0 *default-log-port* "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');" @@ -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 *default-log-port* "ERROR: " fname " appears corrupted. Making backup \"old/" fname "\"") + (debug:print-error 0 *default-log-port* "" 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 *default-log-port* "ERROR: " fnamejnl " found, moving it to old dir as " tmpjnl) + (debug:print-error 0 *default-log-port* "" 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)))) @@ -566,11 +566,11 @@ (for-each (lambda (dbdat) (let ((dbpath (db:dbdat-get-path dbdat))) (debug:print 0 *default-log-port* " dbpath: " dbpath) (if (not (db:repair-db dbdat)) (begin - (debug:print 0 *default-log-port* "ERROR: Failed to rebuild " dbpath ", exiting now.") + (debug:print-error 0 *default-log-port* "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 @@ -584,13 +584,13 @@ ;; (exit 1))) (cond ((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 *default-log-port* "ERROR: db:sync-tables called with fromdb not a database " fromdb) -3) + (debug:print-error 0 *default-log-port* "db:sync-tables called with fromdb not a database " fromdb) -3) ((not (sqlite3:database? (db:dbdat-get-db todb))) - (debug:print 0 *default-log-port* "ERROR: db:sync-tables called with todb not a database " todb) -4) + (debug:print-error 0 *default-log-port* "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)) @@ -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 *default-log-port* "ERROR: cannot open-run-close with #f anymore")) + ((not idb) (debug:print-error 0 *default-log-port* "cannot open-run-close with #f anymore")) ((procedure? idb) (idb)) - (else (debug:print 0 *default-log-port* "ERROR: cannot open-run-close with #f anymore")))) + (else (debug:print-error 0 *default-log-port* "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 *default-log-port* "open-run-close-no-exception-handling END" ) res) @@ -1729,11 +1729,11 @@ 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 *default-log-port* "ERROR: Called without all necessary keys") + (debug:print-error 0 *default-log-port* "Called without all necessary keys") #f)))) ;; replace header and keystr with a call to runs:get-std-run-fields ;; ;; keypatts: ( (KEY1 "abc%def")(KEY2 "%") ) @@ -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 *default-log-port* "ERROR: searching for runs with no pattern set for " fulkey) + (debug:print-error 0 *default-log-port* "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) "") @@ -3009,11 +3009,11 @@ (base64:base64-decode (string-substitute (regexp "_") "=" msg #t))) (lambda ()(deserialize))) (begin - (debug:print 0 *default-log-port* "ERROR: reception failed. Received " msg " but cannot translate it.") + (debug:print-error 0 *default-log-port* "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) 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 *default-log-port* "ERROR: No dumpmode specified, use -dumpmode [bash|csh|config]"))))) + (debug:print-error 0 *default-log-port* "No dumpmode specified, use -dumpmode [bash|csh|config]"))))) Index: http-transport.scm ================================================================== --- http-transport.scm +++ http-transport.scm @@ -201,11 +201,11 @@ (if (> *http-requests-in-progress* 0) (if (> etime (current-seconds)) (begin (thread-sleep! 0.05) (loop etime)) - (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")) + (debug:print-error 0 *default-log-port* "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) @@ -294,11 +294,11 @@ (debug:print-info 11 *default-log-port* "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 *default-log-port* "ERROR: error occured at server, info=" (vector-ref res 2)) + (debug:print-error 0 *default-log-port* "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 *default-log-port* " server call chain:") (pp (vector-ref res 1) (current-error-port)) (signal (vector-ref result 0)))) @@ -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 *default-log-port* "ERROR: call to http-transport:server-dat-update-last-access with non-vector!!")))) + (debug:print-error 0 *default-log-port* "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 *default-log-port* "Still waiting, last-sdat=" last-sdat) (sleep 4) (if (> (- (current-seconds) start-time) 120) ;; been waiting for two minutes (begin - (debug:print 0 *default-log-port* "ERROR: transport appears to have died, exiting server " server-id " for run " run-id) + (debug:print-error 0 *default-log-port* "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,11 +408,11 @@ (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 *default-log-port* "ERROR: error from sync code other than 'sync-failed. Attempting to gracefully shutdown the server") + (debug:print-error 0 *default-log-port* "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 *default-log-port* "SYNC: time= " sync-time ", rem-time=" rem-time) @@ -588,11 +588,11 @@ (debug:print 0 *default-log-port* " ... exiting ...") (let ((th1 (make-thread (lambda () (thread-sleep! 1)) "eat response")) (th2 (make-thread (lambda () - (debug:print 0 *default-log-port* "ERROR: Received ^C, attempting clean exit. Please be patient and wait a few seconds before hitting ^C again.") + (debug:print-error 0 *default-log-port* "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 *default-log-port* " Done.") (exit 4)) "exit on ^C timer"))) (thread-start! th2) Index: items.scm ================================================================== --- items.scm +++ items.scm @@ -48,19 +48,19 @@ (list? x)) (map (lambda (x) (debug:print 6 *default-log-port* "item-assoc->item-list x: " x) (if (< (length x) 2) (begin - (debug:print 0 *default-log-port* "ERROR: malformed items spec " (string-intersperse x " ")) + (debug:print-error 0 *default-log-port* "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 *default-log-port* "ERROR: No items specified for " name)) + (debug:print-error 0 *default-log-port* "No items specified for " name)) ilist))) itemsdat)))) (let ((debuglevel 5)) (debug:print 5 *default-log-port* "item-assoc->item-list: itemsdat => itemlst ") (if (debug:debug-mode 5) @@ -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 *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 (and have-items (null? items)) (debug:print-error 0 *default-log-port* "[items] section in testconfig but no entries defined")) + (if (and have-itable (null? itemstable))(debug:print-error 0 *default-log-port* "[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,11 +43,11 @@ (for-each (lambda (key val) (setenv key val) (if ht (hash-table-set! ht (conc ":" key) val))) keys vals) - (debug:print 0 *default-log-port* "ERROR: wrong number of values in " target ", should match " keys)) + (debug:print-error 0 *default-log-port* "wrong number of values in " target ", should match " keys)) vals) (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) ...) Index: launch.scm ================================================================== --- launch.scm +++ launch.scm @@ -278,16 +278,16 @@ (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 *default-log-port* "ERROR: Failed to resolve megatest.config, runconfigs.config and testconfig issues. Giving up now") + (debug:print-error 0 *default-log-port* "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 *default-log-port* "ERROR: ezsteps defined but ezstepslst is zero length") + (debug:print-error 0 *default-log-port* "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) @@ -371,11 +371,11 @@ (process:get-sub-pids pid)))) ;; (debug:print-info 0 *default-log-port* "not killing process " pid " as it is not alive")))) pids) (tests:test-set-status! run-id test-id "KILLED" "KILLED" (args:get-arg "-m") #f)) (begin - (debug:print 0 *default-log-port* "ERROR: Nothing to kill, pid1=" pid1 ", pid2=" pid2) + (debug:print-error 0 *default-log-port* "Nothing to kill, pid1=" pid1 ", pid2=" pid2) (tests:test-set-status! run-id test-id "KILLED" "FAILED TO KILL" (args:get-arg "-m") #f) ))) (mutex-unlock! m) ;; no point in sticking around. Exit now. (exit))) @@ -437,11 +437,11 @@ (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 *default-log-port* "ERROR: attempt to STOP process. Exiting.")) + (debug:print-error 0 *default-log-port* "attempt to STOP process. Exiting.")) (set! *time-to-exit* #t) (print "Received signal " signum ", cleaning up before exit. Please wait...") (let ((th1 (make-thread (lambda () (tests:test-force-state-status! run-id test-id "INCOMPLETE" "KILLED") (print "Killed by signal " signum ". Exiting") @@ -468,16 +468,16 @@ ((member (db:test-get-state test-info) '("INCOMPLETE" "KILLED" "UNKNOWN" "KILLREQ" "STUCK")) ;; prior run of this test didn't complete, go ahead and try to rerun (debug:print 0 *default-log-port* "INFO: test is INCOMPLETE or KILLED, treat this execute call as a rerun request") (tests:test-force-state-status! run-id test-id "REMOTEHOSTSTART" "n/a")) ;; 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 *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") + (debug:print-error 0 *default-log-port* "test state is " (db:test-get-state test-info) " and process " test-pid " is still running on host " test-host ", cannot proceed") (tests:test-force-state-status! run-id test-id "REMOTEHOSTSTART" "n/a"))) ((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 *default-log-port* "ERROR: test state is " (db:test-get-state test-info) ", cannot proceed") + (debug:print-error 0 *default-log-port* "test state is " (db:test-get-state test-info) ", cannot proceed") (exit)))) (debug:print 2 *default-log-port* "Exectuing " test-name " (id: " test-id ") on " (get-host-name)) (set! keys (rmt:get-keys)) ;; (runs:set-megatest-env-vars run-id inkeys: keys inkeyvals: keyvals) ;; these may be needed by the launching process @@ -503,11 +503,11 @@ (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 *default-log-port* "ERROR: bad variable spec, " var "=" val)))) + (debug:print-error 0 *default-log-port* "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)) @@ -539,11 +539,11 @@ (let ((var (car varval)) (val (cadr varval))) (if val (setenv var val) (begin - (debug:print 0 *default-log-port* "ERROR: required variable " var " does not have a valid value. Exiting") + (debug:print-error 0 *default-log-port* "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)) @@ -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 *default-log-port* "ERROR: you are not in a megatest area!") + (debug:print-error 0 *default-log-port* "you are not in a megatest area!") (exit 1))) (setenv "MT_RUN_AREA_HOME" *toppath*) ;; the seed read is done, now read runconfigs, cache it then read megatest.config one more time and cache it (let* ((keys (rmt:get-keys)) (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 *default-log-port* "ERROR: No " mtconfig " file found. Giving up.") + (debug:print-error 0 *default-log-port* "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 *default-log-port* "ERROR: Something went wrong when trying to create linktree dir at " linktree) + (debug:print-error 0 *default-log-port* "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 *default-log-port* "ERROR: linktree not defined in [setup] section of megatest.config") + (debug:print-error 0 *default-log-port* "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 *default-log-port* "ERROR: failed to find the top path to your Megatest area."))) + (debug:print-error 0 *default-log-port* "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 *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)) + (debug:print-error 0 *default-log-port* "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: ;; ;; - - -. @@ -893,11 +893,11 @@ (if (and (not (directory-exists? lnkbase)) (not (file-exists? lnkbase))) (handle-exceptions exn (begin - (debug:print 0 *default-log-port* "ERROR: Problem creating linktree base at " lnkbase) + (debug:print-error 0 *default-log-port* "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 *default-log-port* "Creating iterated parent " iterated-parent) (handle-exceptions exn (begin - (debug:print 0 *default-log-port* "ERROR: Failed to create directory " iterated-parent ((condition-property-accessor 'exn 'message) exn) ", exiting") + (debug:print-error 0 *default-log-port* " 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 *default-log-port* "ERROR: Failed to remove symlink " lnkpath ((condition-property-accessor 'exn 'message) exn) ", exiting") + (debug:print-error 0 *default-log-port* " 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 *default-log-port* "ERROR: Failed to create symlink " lnkpath ((condition-property-accessor 'exn 'message) exn) ", exiting") + (debug:print-error 0 *default-log-port* " 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!!! ;; @@ -974,11 +974,11 @@ (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 *default-log-port* "ERROR: Failed to create directory " test-path ((condition-property-accessor 'exn 'message) exn) ", exiting") + (debug:print-error 0 *default-log-port* " Failed to create directory " test-path ((condition-property-accessor 'exn 'message) exn) ", exiting") (exit 1)) (create-directory test-path #t)) (debug:print 2 *default-log-port* " - creating link from: " test-path "\n" " to: " lnktarget) @@ -985,11 +985,11 @@ ;; If there is already a symlink delete it and recreate it. (handle-exceptions exn (begin - (debug:print 0 *default-log-port* "ERROR: Failed to re-create link " lnktarget ((condition-property-accessor 'exn 'message) exn) ", exiting") + (debug:print-error 0 *default-log-port* " 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)) @@ -1011,11 +1011,11 @@ (if (not (eq? status 0)) (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 *default-log-port* "ERROR: Failed to create work area at " test-path " with link at " lnktarget ", remaining attempts " remtries) + (debug:print-error 0 *default-log-port* "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 Index: lock-queue.scm ================================================================== --- lock-queue.scm +++ lock-queue.scm @@ -78,11 +78,11 @@ (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 *default-log-port* "ERROR: Failed to set lock state for test with id " test-id ", error: " ((condition-property-accessor 'exn 'message) exn) ", giving up.") + (debug:print-error 0 *default-log-port* " 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))) @@ -97,11 +97,11 @@ (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 *default-log-port* "ERROR: Failed to find younger locks for test with id " test-id ", error: " ((condition-property-accessor 'exn 'message) exn) ", giving up.") + (debug:print-error 0 *default-log-port* " 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 Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -326,11 +326,11 @@ (args:get-arg "-runstep") (args:get-arg "-envcap") (args:get-arg "-envdelta") ) )) - (debug:print 0 *default-log-port* "ERROR: Unrecognised arguments: " (string-intersperse (if (list? remargs) remargs (argv)) " "))) + (debug:print-error 0 *default-log-port* "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))) @@ -407,11 +407,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 *default-log-port* "ERROR: non-existant start dir " (args:get-arg "-start-dir") " specified, exiting.") + (debug:print-error 0 *default-log-port* "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) @@ -492,12 +492,12 @@ (handle-exceptions exn (debug:print 0 *default-log-port* "WARNING: Failed to remove file " f) (delete-file f))) files)))) - (debug:print 0 *default-log-port* "ERROR: -clean-cache requires -runname.")) - (debug:print 0 *default-log-port* "ERROR: -clean-cache requires -target or -reqtarg")))) + (debug:print-error 0 *default-log-port* "-clean-cache requires -runname.")) + (debug:print-error 0 *default-log-port* "-clean-cache requires -target or -reqtarg")))) (if (args:get-arg "-env2file") (begin (save-environment-as-files (args:get-arg "-env2file")) @@ -710,11 +710,11 @@ (lambda () (env:print added removed changed))) (env:print added removed changed)) (env:close-database db) (set! *didsomething* #t)) - (debug:print 0 *default-log-port* "ERROR: Parameter to -envdelta should be new=star-end"))))) + (debug:print-error 0 *default-log-port* "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 ;;====================================================================== @@ -728,11 +728,11 @@ (string->number (args:get-arg "-run-id"))))) (if run-id (begin (server:launch run-id) (set! *didsomething* #t)) - (debug:print 0 *default-log-port* "ERROR: server requires run-id be specified with -run-id"))) + (debug:print-error 0 *default-log-port* "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 @@ -825,11 +825,11 @@ (print x)) targets)) ((json) (json-write targets)) (else - (debug:print 0 *default-log-port* "ERROR: dump output format " (args:get-arg "-dumpmode") " not supported for -list-targets"))) + (debug:print-error 0 *default-log-port* "dump output format " (args:get-arg "-dumpmode") " not supported for -list-targets"))) (set! *didsomething* #t))) ;; cache the runconfigs in $MT_LINKTREE/$MT_TARGET/$MT_RUNNAME/.runconfig ;; (define (full-runconfigs-read) @@ -885,11 +885,11 @@ ((string=? (args:get-arg "-dumpmode") "json") (json-write data)) ((string=? (args:get-arg "-dumpmode") "ini") (configf:config->ini data)) (else - (debug:print 0 *default-log-port* "ERROR: -dumpmode of " (args:get-arg "-dumpmode") " not recognised"))) + (debug:print-error 0 *default-log-port* "-dumpmode of " (args:get-arg "-dumpmode") " not recognised"))) (set! *didsomething* #t)) (pop-directory))) (if (args:get-arg "-show-config") (let ((tl (launch:setup)) @@ -909,11 +909,11 @@ ((string=? (args:get-arg "-dumpmode") "json") (json-write data)) ((string=? (args:get-arg "-dumpmode") "ini") (configf:config->ini data)) (else - (debug:print 0 *default-log-port* "ERROR: -dumpmode of " (args:get-arg "-dumpmode") " not recognised"))) + (debug:print-error 0 *default-log-port* "-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")) @@ -933,23 +933,23 @@ (define (operate-on action) (let* ((runrec (runs:runrec-make-record)) (target (common:args-get-target))) (cond ((not target) - (debug:print 0 *default-log-port* "ERROR: Missing required parameter for " action ", you must specify -target or -reqtarg") + (debug:print-error 0 *default-log-port* "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 *default-log-port* "ERROR: Missing required parameter for " action ", you must specify the run name pattern with -runname patt") + (debug:print-error 0 *default-log-port* "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 *default-log-port* "ERROR: Missing required parameter for " action ", you must specify the test pattern with -testpatt") + (debug:print-error 0 *default-log-port* "Missing required parameter for " action ", you must specify the test pattern with -testpatt") (exit 3)) (else (if (not (car *configinfo*)) (begin - (debug:print 0 *default-log-port* "ERROR: Attempted " action "on test(s) but run area config file not found") + (debug:print-error 0 *default-log-port* "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) @@ -1087,11 +1087,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 *default-log-port* "ERROR: Invalid test fields specified: " (string-intersperse invalid-tests-spec ", ")) + (debug:print-error 0 *default-log-port* "Invalid test fields specified: " (string-intersperse invalid-tests-spec ", ")) (exit))))) ;; Each run (for-each (lambda (run) @@ -1156,11 +1156,11 @@ (for-each (lambda (test) (handle-exceptions exn (begin - (debug:print 0 *default-log-port* "ERROR: Bad data in test record? " test) + (debug:print-error 0 *default-log-port* "Bad data in test record? " test) (print "exn=" (condition->list 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)) @@ -1537,11 +1537,11 @@ (target (args:get-arg "-target")) (toppath (assoc/default 'toppath cmdinfo))) (change-directory toppath) (if (not target) (begin - (debug:print 0 *default-log-port* "ERROR: -target is required.") + (debug:print-error 0 *default-log-port* "-target is required.") (exit 1))) (if (not (launch:setup)) (begin (debug:print 0 *default-log-port* "Failed to setup, giving up on -test-paths or -test-files, exiting") (exit 1))) @@ -1621,21 +1621,21 @@ (if (and run-id test-id) (begin (launch:recover-test run-id test-id) (set! *didsomething* #t)) (begin - (debug:print 0 *default-log-port* "ERROR: bad run-id or test-id, must be integers") + (debug:print-error 0 *default-log-port* "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 *default-log-port* "ERROR: MT_CMDINFO env var not set, -step must be called *inside* a megatest invoked environment!") + (debug:print-error 0 *default-log-port* "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)) @@ -1654,11 +1654,11 @@ (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 *default-log-port* "ERROR: You must specify :state and :status with every call to -step") + (debug:print-error 0 *default-log-port* "You must specify :state and :status with every call to -step") (exit 6)))))) (if (args:get-arg "-step") (begin (megatest:step @@ -1679,11 +1679,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 *default-log-port* "ERROR: MT_CMDINFO env var not set, commands -test-status, -runstep and -setlog must be called *inside* a megatest environment!") + (debug:print-error 0 *default-log-port* "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)) @@ -1722,11 +1722,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 *default-log-port* "ERROR: nothing specified to run!") + (debug:print-error 0 *default-log-port* "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")) @@ -1783,11 +1783,11 @@ res))) (if (and (args:get-arg "-test-status") (or (not state) (not status))) (begin - (debug:print 0 *default-log-port* "ERROR: You must specify :state and :status with every call to -test-status\n" help) + (debug:print-error 0 *default-log-port* "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 Index: mt.scm ================================================================== --- mt.scm +++ mt.scm @@ -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 *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) + (debug:print-error 0 *default-log-port* "bad data handed to mt:test-set-state-status-by-id, run-id=" run-id ", test-id=" test-id ", newstate=" newstate) (print-call-chain (current-error-port)) #f) (begin (cond ((and newstate newstatus newcomment) @@ -215,9 +215,9 @@ (setenv "MT_LINKTREE" old-link-tree) (unsetenv "MT_LINKTREE")) newtcfg)) (if (null? tal) (begin - (debug:print 0 *default-log-port* "ERROR: No readable testconfig found for " test-name) + (debug:print-error 0 *default-log-port* "No readable testconfig found for " test-name) #f) (loop (car tal)(cdr tal)))))))))) 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 *default-log-port* "ERROR: Couldn't create path to " dbdir) + (debug:print-error 0 *default-log-port* "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 *default-log-port* "ERROR: I was asked to open " dbfile ", but file does not exist or is not readable.") + (debug:print-error 0 *default-log-port* "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 *default-log-port* "ERROR: no main.db found at " (areadb:dbfile-path areadat 0))) + (debug:print-error 0 *default-log-port* "no main.db found at " (areadb:dbfile-path areadat 0))) areadat)) ;; given an areadat and target/runname patt fill up runs data ;; ;; ?????/ Index: nmsg-transport.scm ================================================================== --- nmsg-transport.scm +++ nmsg-transport.scm @@ -89,11 +89,11 @@ (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 *default-log-port* "ERROR: could not find an open port to start server on. Giving up") + (debug:print-error 0 *default-log-port* "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)) @@ -240,11 +240,11 @@ (if success (if (and (vector? result) (vector-ref result 0)) ;; did it fail at the server? result ;; nope, all good (begin - (debug:print 0 *default-log-port* "ERROR: error occured at server, info=" (vector-ref result 2)) + (debug:print-error 0 *default-log-port* "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 *default-log-port* " server call chain:") (pp (vector-ref result 1) (current-error-port)) (signal (vector-ref result 0)))) @@ -345,14 +345,14 @@ (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 *default-log-port* "ERROR: Received ^C, attempting clean exit. Please be patient and wait a few seconds before hitting ^C again.") + (debug:print-error 0 *default-log-port* "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 *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,11 +54,11 @@ (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 *default-log-port* "ERROR: portlogger:open-run-close failed. " proc " " params) + (debug:print-error 0 *default-log-port* "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)) Index: rmt.scm ================================================================== --- rmt.scm +++ rmt.scm @@ -159,11 +159,11 @@ (server:kind-run run-id))) ;; return the result! newres) ))) (begin - ;; (debug:print 0 *default-log-port* "ERROR: Communication failed!") + ;; (debug:print-error 0 *default-log-port* "Communication failed!") ;; (mutex-unlock! *send-receive-mutex*) ;; (exit) (rmt:open-qry-close-locally cmd run-id params) ))))) @@ -239,15 +239,15 @@ (res (vector-ref resdat 1)) (duration (- (current-milliseconds) start))) (if (not success) (if (> remretries 0) (begin - (debug:print 0 *default-log-port* "ERROR: local query failed. Trying again.") + (debug:print-error 0 *default-log-port* "local query failed. Trying again.") (thread-sleep! (/ (random 5000) 1000)) ;; some random delay (rmt:open-qry-close-locally cmd run-id params remretries: (- remretries 1))) (begin - (debug:print 0 *default-log-port* "ERROR: too many retries in rmt:open-qry-close-locally, giving up") + (debug:print-error 0 *default-log-port* "too many retries in rmt:open-qry-close-locally, giving up") #f)) (begin ;; (rmt:update-db-stats run-id cmd params duration) ;; 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 *default-log-port* "ERROR: rmt:send-receive-no-auto-client-setup failed, attempting to continue. Got " dat) +;; (debug:print-error 0 *default-log-port* "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 @@ -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 *default-log-port* "ERROR: rmt:get-tests-for-run called with bad run-id=" run-id) + (debug:print-error 0 *default-log-port* "rmt:get-tests-for-run called with bad run-id=" run-id) (print-call-chain (current-error-port)) '()))) ;; get stuff via synchash (define (rmt:synchash-get run-id proc synckey keynum params) @@ -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 *default-log-port* "ERROR: get-tests-for-run-mindata failed for run-id " hed ", testpatt " testpatt ", states " states ", status " status ", not-in " not-in)))) + (debug:print-error 0 *default-log-port* "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) Index: rpc-transport.scm ================================================================== --- rpc-transport.scm +++ rpc-transport.scm @@ -162,11 +162,11 @@ (exit 1)))))) (define (rpc-transport:client-setup run-id #!key (remtries 10)) (if *runremote* (begin - (debug:print 0 *default-log-port* "ERROR: Attempt to connect to server but already connected") + (debug:print-error 0 *default-log-port* "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,11 +205,11 @@ ;; (let ((portn (string->number port))) ;; (debug:print-info 2 *default-log-port* "Setting up to connect to host " host ":" port) ;; (handle-exceptions ;; exn ;; (begin -;; (debug:print 0 *default-log-port* "ERROR: Failed to open a connection to the server at host: " host " port: " port) +;; (debug:print-error 0 *default-log-port* "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) Index: runconfig.scm ================================================================== --- runconfig.scm +++ runconfig.scm @@ -17,11 +17,11 @@ (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 *default-log-port* "ERROR: setup-env-defaults called with no run-id or -target or -reqtarg") + (debug:print-error 0 *default-log-port* "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)) 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 *default-log-port* "ERROR: linktree not set, should be set in megatest.config in [setup] section.")) + (debug:print-error 0 *default-log-port* "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 @@ -72,11 +72,11 @@ (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 *default-log-port* "ERROR: no value for runname for id " run-id))) + (debug:print-error 0 *default-log-port* "no value for runname for id " run-id))) (setenv "MT_RUN_AREA_HOME" *toppath*) ;; if a testname and itempath are available set the remaining appropriate variables (if testname (setenv "MT_TEST_NAME" testname)) (if itempath (setenv "MT_ITEMPATH" itempath)) (if (and testname link-tree) @@ -300,11 +300,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 *default-log-port* "ERROR: test " hed " has listed itself as a waiton or waitor, please correct this!") + (debug:print-error 0 *default-log-port* "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)) @@ -381,11 +381,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 *default-log-port* "ERROR: failure in runs:run-tests-queue thread, error: " ((condition-property-accessor 'exn 'message) exn)) + ;; (debug:print-error 0 *default-log-port* "failure in runs:run-tests-queue thread, error: " ((condition-property-accessor 'exn 'message) exn)) ;; (if (> run-queue-retries 0) ;; (begin ;; (set! run-queue-retries (- run-queue-retries 1)) ;; (runs:run-tests-queue run-id runname test-records keyvals flags test-patts required-tests (any->number reglen) all-tests-registry)))) ;; (runs:run-tests-queue run-id runname test-records keyvals flags test-patts required-tests (any->number reglen) all-tests-registry))) @@ -442,11 +442,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 *default-log-port* "ERROR: runs:queue-next-hed, tal=" tal ", reg=" reg ", n=" n ", regfull=" regfull) +;; (debug:print-error 0 *default-log-port* "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 @@ -537,11 +537,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 *default-log-port* "ERROR: The proc from reading the items table did not yield a list - please report this") + (debug:print-error 0 *default-log-port* "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))) @@ -666,11 +666,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 *default-log-port* "ERROR: prereqs-not-met is not a list! " prereqs-not-met) + (debug:print-error 0 *default-log-port* "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)) @@ -724,11 +724,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 *default-log-port* "ERROR: failed to register test " (db:test-make-full-name test-name item-path))))) + (debug:print-error 0 *default-log-port* "failed to register test " (db:test-make-full-name test-name item-path))))) (if (not (eq? (hash-table-ref/default test-registry (db:test-make-full-name test-name "") #f) 'done)) (begin (rmt:register-test run-id test-name "") (if (rmt:get-test-id run-id test-name "") (hash-table-set! test-registry (db:test-make-full-name test-name "") 'done)))) @@ -1108,11 +1108,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 *default-log-port* "ERROR: test " test-name " has listed itself as a waiton, please correct this!") + (debug:print-error 0 *default-log-port* "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 @@ -1199,11 +1199,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 *default-log-port* "ERROR: Should not have a list of items in a test and the itemspath set - please report this") + (debug:print-error 0 *default-log-port* "Should not have a list of items in a test and the itemspath set - please report this") (exit 1)) ((not (null? reruns)) (let* ((newlst (tests:filter-non-runnable run-id tal test-records)) ;; i.e. not FAIL, WAIVED, INCOMPLETE, PASS, KILLED, (junked (lset-difference equal? tal newlst))) (debug:print-info 4 *default-log-port* "full drop through, if reruns is less than 100 we will force retry them, reruns=" reruns ", tal=" tal) @@ -1364,24 +1364,24 @@ (begin (debug:print-info 0 *default-log-port* "WARNING: server is overloaded, trying again in one second") (thread-sleep! 1) (loop))))) (if (not testdat) ;; should NOT happen - (debug:print 0 *default-log-port* "ERROR: failed to get test record for test-id " test-id)) + (debug:print-error 0 *default-log-port* "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 *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?") + (debug:print-error 0 *default-log-port* "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 *default-log-port* "ERROR: Failed to insert the record into the db")) + (debug:print-error 0 *default-log-port* "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)) @@ -1473,11 +1473,11 @@ ;; (debug:print 0 *default-log-port* "WARNING: Test " test-name " appears to be dead. Forcing it to state INCOMPLETE and status STUCK/DEAD") ;; (tests:test-set-status! run-id test-id "INCOMPLETE" "STUCK/DEAD" "" #f)) ;; ;; (tests:test-set-status! test-id "INCOMPLETE" "STUCK/DEAD" "" #f)) ;; (debug:print 2 *default-log-port* "NOTE: " test-name " is already running"))) (else - (debug:print 0 *default-log-port* "ERROR: Failed to launch test " full-test-name ". Unrecognised state " (test:get-state testdat)) + (debug:print-error 0 *default-log-port* "Failed to launch test " full-test-name ". Unrecognised state " (test:get-state testdat)) (case (string->symbol (test:get-state testdat)) ((COMPLETED INCOMPLETE) (hash-table-set! test-registry (db:test-make-full-name test-name test-path) 'DONOTRUN)) (else (hash-table-set! test-registry (db:test-make-full-name test-name test-path) 'DONOTRUN)))))))) @@ -1497,11 +1497,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 *default-log-port* "ERROR: There was a problem removing " real-dir " with rm -f"))))) + (debug:print-error 0 *default-log-port* "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) @@ -1542,11 +1542,11 @@ (rp-mutex (make-mutex)) (bup-mutex (make-mutex))) (debug:print-info 4 *default-log-port* "runs:operate-on => Header: " header " action: " action " new-state-status: " new-state-status) (if (> 2 (length state-status)) (begin - (debug:print 0 *default-log-port* "ERROR: the parameter to -set-state-status is a comma delimited string. E.g. COMPLETED,FAIL") + (debug:print-error 0 *default-log-port* "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) "/")) @@ -1590,11 +1590,11 @@ (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 *default-log-port* "ERROR: unrecognised sub command to -archive. Run \"megatest\" to see help") + (debug:print-error 0 *default-log-port* "unrecognised sub command to -archive. Run \"megatest\" to see help") (exit)))) "archive-bup-thread")) (thread-start! worker-thread)) (else (debug:print-info 0 *default-log-port* "action not recognised " action))) @@ -1617,11 +1617,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 *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!") + (debug:print-error 0 *default-log-port* "We have a test-id of " test-id " but no record was found. NOTE: No locking of records is done between processes, do not simultaneously remove the same run from two processes!") (if (not (null? tal)) (loop (car tal)(cdr tal)))) (let* ((item-path (db:test-get-item-path new-test-dat)) (test-name (db:test-get-testname new-test-dat)) (run-dir ;;(filedb:get-path *fdb* @@ -1745,18 +1745,18 @@ (if (symbolic-link? run-dir) (begin (debug:print-info 1 *default-log-port* "Removing symlink " run-dir) (handle-exceptions exn - (debug:print 0 *default-log-port* "ERROR: Failed to remove symlink " run-dir ((condition-property-accessor 'exn 'message) exn) ", attempting to continue") + (debug:print-error 0 *default-log-port* " 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 *default-log-port* "WARNING: refusing to remove " run-dir " as it is not empty") (handle-exceptions exn - (debug:print 0 *default-log-port* "ERROR: Failed to remove directory " run-dir ((condition-property-accessor 'exn 'message) exn) ", attempting to continue") + (debug:print-error 0 *default-log-port* " 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 *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.")) @@ -1776,14 +1776,14 @@ (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 *default-log-port* "ERROR: Missing required parameter for " switchname ", you must specify the target with -target") + (debug:print-error 0 *default-log-port* "Missing required parameter for " switchname ", you must specify the target with -target") (exit 3)) ((not runname) - (debug:print 0 *default-log-port* "ERROR: Missing required parameter for " switchname ", you must specify the run name with -runname runname") + (debug:print-error 0 *default-log-port* "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) @@ -1800,19 +1800,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 *default-log-port* "ERROR: [" (args:get-arg "-reqtarg") "] not found in " runconfigf) + (debug:print-error 0 *default-log-port* "[" (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 *default-log-port* "ERROR: Attempted to " action-desc " but run area config file not found") + (debug:print-error 0 *default-log-port* "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))) 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 *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") + (else (debug:print-error 0 *default-log-port* "unknown server type " *transport-type*)))) +;; (else (debug:print-error 0 *default-log-port* "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 *default-log-port* "ERROR: unrecognised transport type: " *transport-type*) + (debug:print-error 0 *default-log-port* "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 @@ -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 *default-log-port* "ERROR: must specify run-id when doing ping, -run-id n") + (debug:print-error 0 *default-log-port* "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: sretrieve.scm ================================================================== --- sretrieve.scm +++ sretrieve.scm @@ -135,26 +135,26 @@ (lambda (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 *default-log-port* "ERROR: invalid path for storing database: " path)))) + (debug:print-error 0 *default-log-port* "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 *default-log-port* "ERROR: Bad configuration! base-dir " base-dir " not found") + (debug:print-error 0 *default-log-port* "Bad configuration! base-dir " base-dir " not found") (exit 1))) (print datadir) (if (not (file-exists? datadir)) (begin - (debug:print 0 *default-log-port* "ERROR: Bad version (" version "), no data found at " datadir "." ) + (debug:print-error 0 *default-log-port* "Bad version (" version "), no data found at " datadir "." ) (exit 1))) (sretrieve:db-do configdat (lambda (db) @@ -187,24 +187,24 @@ (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 *default-log-port* "ERROR: Bad configuration! base-dir " base-dir " not found") + (debug:print-error 0 *default-log-port* "Bad configuration! base-dir " base-dir " not found") (exit 1))) (print datadir) (if (not (file-exists? datadir)) (begin - (debug:print 0 *default-log-port* "ERROR: File (" file "), not found at " base-dir "." ) + (debug:print-error 0 *default-log-port* "File (" file "), not found at " base-dir "." ) (exit 1))) (if (directory? datadir) (begin - (debug:print 0 *default-log-port* "ERROR: (" file ") is a dirctory!! cp cmd works only on files ." ) + (debug:print-error 0 *default-log-port* "(" 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 *default-log-port* "ERROR: Access denied to file (" file ")!! " ) + (debug:print-error 0 *default-log-port* "Access denied to file (" file ")!! " ) (exit 1))) (sretrieve:db-do configdat (lambda (db) @@ -224,20 +224,20 @@ (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 *default-log-port* "ERROR: Bad configuration! base-dir " base-dir " not found") + (debug:print-error 0 *default-log-port* "Bad configuration! base-dir " base-dir " not found") (exit 1))) (print datadir) (if (not (file-exists? datadir)) (begin - (debug:print 0 *default-log-port* "ERROR: File (" file "), not found at " base-dir "." ) + (debug:print-error 0 *default-log-port* "File (" file "), not found at " base-dir "." ) (exit 1))) (if(not (string-match (regexp allowed-sub-paths) file)) (begin - (debug:print 0 *default-log-port* "ERROR: Access denied to file (" file ")!! " ) + (debug:print-error 0 *default-log-port* "Access denied to file (" file ")!! " ) (exit 1))) (sretrieve:do-as-calling-user (lambda () ;;(change-directory datadir) @@ -256,16 +256,16 @@ (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 *default-log-port* "ERROR: Path " targ-mk " resolved outside target area " target-dir ) + (debug:print-error 0 *default-log-port* "Path " targ-mk " resolved outside target area " target-dir ) (exit 1))) (if (not (string-contains targ-path target-dir)) (begin - (debug:print 0 *default-log-port* "ERROR: You cannot update data outside " target-dir ".") + (debug:print-error 0 *default-log-port* "You cannot update data outside " target-dir ".") (exit 1))) (debug:print 0 *default-log-port* "Path " targ-mk " is valid.") )) ;; make directory in dest ;; @@ -273,11 +273,11 @@ (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 *default-log-port* "ERROR: target Directory " targ-path " already exist!!") + (debug:print-error 0 *default-log-port* "target Directory " targ-path " already exist!!") (exit 1))) (sretrieve:db-do configdat (lambda (db) (sretrieve:register-action db "mkdir" submitter targ-mk comment))) @@ -303,15 +303,15 @@ ;; (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 *default-log-port* "ERROR: target file " targ-path " already exist!!") + (debug:print-error 0 *default-log-port* "target file " targ-path " already exist!!") (exit 1))) (if (not (file-exists? targ-link )) (begin - (debug:print 0 *default-log-port* "ERROR: target file " targ-link " does not exist!!") + (debug:print-error 0 *default-log-port* "target file " targ-link " does not exist!!") (exit 1))) (sretrieve:db-do configdat (lambda (db) @@ -339,11 +339,11 @@ ;; (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 *default-log-port* "ERROR: target file " targ-path " not found, nothing to remove.") + (debug:print-error 0 *default-log-port* "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))) @@ -487,11 +487,11 @@ (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 *default-log-port* "ERROR: failed to run script " conversion-script " with params " upstream-file " " package-config) + (debug:print-error 0 *default-log-port* "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 *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 " * *") @@ -527,11 +527,11 @@ (exit 1))) (case (string->symbol action) ((get) (if (< (length args) 1) (begin - (debug:print 0 *default-log-port* "ERROR: Missing arguments; " (string-intersperse args ", ")) + (debug:print-error 0 *default-log-port* "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") @@ -542,11 +542,11 @@ (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 *default-log-port* "ERROR: Missing arguments; " (string-intersperse args ", ")) + (debug:print-error 0 *default-log-port* "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") "")) ) @@ -553,11 +553,11 @@ (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 *default-log-port* "ERROR: Missing arguments; " (string-intersperse args ", ")) + (debug:print-error 0 *default-log-port* "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") "")) ) @@ -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 *default-log-port* "ERROR: Unrecognised command. Try \"sretrieve help\""))))) + (else (debug:print-error 0 *default-log-port* "Unrecognised command. Try \"sretrieve help\""))))) (main) Index: tasks.scm ================================================================== --- tasks.scm +++ tasks.scm @@ -25,11 +25,11 @@ ;; 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 *default-log-port* "ERROR: Called tasks:wait-on-journal with path=" path " (not a string)") + (debug:print-error 0 *default-log-port* "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)) @@ -59,11 +59,11 @@ (configf:lookup *configdat* "setup" "dbdir") (conc (configf:lookup *configdat* "setup" "linktree") "/.db")))) (handle-exceptions exn (begin - (debug:print 0 *default-log-port* "ERROR: Couldn't create path to " dbdir) + (debug:print-error 0 *default-log-port* "Couldn't create path to " dbdir) (exit 1)) (if (not (directory? dbdir))(create-directory dbdir #t))) dbdir)) ;; If file exists AND @@ -286,11 +286,11 @@ 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 *default-log-port* "ERROR: no servers listed, should be at least one by now.") + #f;; (begin (debug:print-error 0 *default-log-port* "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)) @@ -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 *default-log-port* "ERROR: no record or improper record for " target "/" run-name " in tasks_queue in main.db")))) + (debug:print-error 0 *default-log-port* "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 @@ -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 *default-log-port* "ERROR: problem accessing test db " work-area ", you probably should clean and re-run this test or remove the file " + (debug:print-error 0 *default-log-port* "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 ? Index: tests.scm ================================================================== --- tests.scm +++ tests.scm @@ -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 *default-log-port* "ERROR: non-existent required test \"" test-name "\"") + (debug:print-error 0 *default-log-port* "non-existent required test \"" test-name "\"") (exit 1)))) (instr2 (if config (config-lookup config "requirements" "waitor") ""))) (debug:print-info 8 *default-log-port* "waitons string is " instr ", waitors string is " instr2) @@ -159,36 +159,36 @@ (let ((res (instr))) (debug:print-info 8 *default-log-port* "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 *default-log-port* "ERROR: something went wrong in processing waitons for test " test-name) + ;; NOTE: This is actually the case of *no* waitons! ;; (debug:print-error 0 *default-log-port* "something went wrong in processing waitons for test " test-name) "")))) (newwaitors (string-split (cond ((procedure? instr2) (let ((res (instr2))) (debug:print-info 8 *default-log-port* "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 *default-log-port* "ERROR: something went wrong in processing waitons for test " test-name) + ;; NOTE: This is actually the case of *no* waitons! ;; (debug:print-error 0 *default-log-port* "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 *default-log-port* "ERROR: test " test-name " has unrecognised waiton testname " x) + (debug:print-error 0 *default-log-port* "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 *default-log-port* "ERROR: test " test-name " has unrecognised waiton testname " x) + (debug:print-error 0 *default-log-port* "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,11 +302,11 @@ (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 *default-log-port* "ERROR: test run directory is gone, cannot propagate waiver") + (debug:print-error 0 *default-log-port* "test run directory is gone, cannot propagate waiver") #f) (begin (push-directory test-rundir) (let ((result (if (null? waivers) #f @@ -468,11 +468,11 @@ (directory? path)) ;; can get #f here under some wierd conditions. why, unknown ... (begin (debug:print 4 *default-log-port* "Found path: " path) (change-directory path)) ;; (set! outputfilename (conc path "/" outputfilename))) - (debug:print 0 *default-log-port* "ERROR: summarize-items for run-id=" run-id ", test-name=" test-name ", no such path: " path)) + (debug:print-error 0 *default-log-port* "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)) @@ -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 *default-log-port* "ERROR: bad priority value " priority ", using 0") 0))) + (if tmp tmp (begin (debug:print-error 0 *default-log-port* "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 '())) @@ -1037,21 +1037,21 @@ (debug:print-info 4 *default-log-port* "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 *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-error 0 *default-log-port* "non-existent required test \"" hed "\", grep through your testconfigs to find and remove or create the test. Discarding and continuing.") "")))) (debug:print-info 8 *default-log-port* "waitons string is " instr) (string-split (cond ((procedure? instr) (let ((res (instr))) (debug:print-info 8 *default-log-port* "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 *default-log-port* "ERROR: something went wrong in processing waitons for test " hed) + ;; NOTE: This is actually the case of *no* waitons! ;; (debug:print-error 0 *default-log-port* "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 *default-log-port* "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 *default-log-port* "ERROR: test " hed " has listed itself as a waiton, please correct this!") + (debug:print-error 0 *default-log-port* "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,11 +1163,11 @@ (debug:print-info 0 *default-log-port* "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 *default-log-port* "ERROR: tried for over a minute to update meta info and failed. Giving up") + (debug:print-error 0 *default-log-port* "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 *default-log-port* " status: " ((condition-property-accessor 'sqlite3 'status) exn)) (print-call-chain (current-error-port))))