@@ -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)))