Index: common_records.scm ================================================================== --- common_records.scm +++ common_records.scm @@ -63,9 +63,9 @@ exn (begin (print-call-chain (current-error-port)) (with-output-to-port (current-error-port) (lambda () - (print ((condition-property-accessor 'exn 'message) exn)) - (print "Callback error in " procname) - (print "Full condition info:\n" (condition->list exn))))) + (debug:print 0 *default-log-port* ((condition-property-accessor 'exn 'message) exn)) + (debug:print 0 *default-log-port* "Callback error in " procname) + (debug:print 0 *default-log-port* "Full condition info:\n" (condition->list exn))))) (proc))) Index: commonmod.scm ================================================================== --- commonmod.scm +++ commonmod.scm @@ -3390,23 +3390,23 @@ ((directory? p)(hash-table-set! directories p #t)) (else (case (vector-ref rule 1) ((keep)(hash-table-set! keepers p rule)) ((remove) - (print "Removing file " p) + (debug:print 0 *default-log-port* "Removing file " p) (delete-file p)) ((compress) - (print "Compressing file " p) + (debug:print 0 *default-log-port* "Compressing file " p) (system (conc compress " " p))) (else - (print "No match for file " p)))))))) + (debug:print 0 *default-log-port* "No match for file " p)))))))) (if remove-empty (for-each (lambda (d) (if (null? (glob (conc d "/.*")(conc d "/*"))) (begin - (print "Removing empty directory " d) + (debug:print 0 *default-log-port* "Removing empty directory " d) (delete-directory d)))) (sort (hash-table-keys directories) (lambda (a b)(> (string-length a)(string-length b)))))) )) ;;====================================================================== Index: dashboard-context-menu.scm ================================================================== --- dashboard-context-menu.scm +++ dashboard-context-menu.scm @@ -361,11 +361,11 @@ (lambda () (if scheme-match (begin (handle-exceptions exn - (print "error with custom menu scheme, exn=" exn) + (debug:print 0 *default-log-port* "error with custom menu scheme, exn=" exn) (begin ;;(BB> "gonna eval it!") (eval (with-input-from-string (cadr scheme-match) read))))) (common:run-a-command command-line with-vars: #t)))))))) #f))) Index: dashboard-guimonitor.scm ================================================================== --- dashboard-guimonitor.scm +++ dashboard-guimonitor.scm @@ -83,21 +83,21 @@ (iup:hbox (iup:button "Start" #:expand "HORIZONTAL" #:action (lambda (obj) (tasks:add-from-params tdb "run" keys key-params var-params) - (print "Launch Run"))) + #;(print "Launch Run"))) (iup:button "Remove" #:expand "HORIZONTAL" #:action (lambda (obj) - (print "Remove Run") + ;; (print "Remove Run") (tasks:add-from-params tdb "remove" keys key-params var-params) )) (iup:button "Rollup" #:expand "HORIZONTAL" #:action (lambda (obj) - (print "Rollup Run") + ;; (print "Rollup Run") (tasks:add-from-params tdb "rollup" keys key-params var-params))))) (iup:frame #:title "Misc" (iup:hbox (iup:button "Quit" Index: dashboard-tests.scm ================================================================== --- dashboard-tests.scm +++ dashboard-tests.scm @@ -764,12 +764,12 @@ " -archive save-remove -testpatt " (conc testname "/" (if (equal? item-path "") "%" item-path)) ))))) (cond - ((not testdat)(begin (print "ERROR: bad test info for " test-id)(exit 1))) - ((not rundat)(begin (print "ERROR: found test info but there is a problem with the run info for " run-id)(exit 1))) + ((not testdat)(begin (debug:print 0 *default-log-port* "ERROR: bad test info for " test-id)(exit 1))) + ((not rundat)(begin (debug:print 0 *default-log-port* "ERROR: found test info but there is a problem with the run info for " run-id)(exit 1))) (else ;; (test-set-status! db run-id test-name state status itemdat) (set! self ; (iup:dialog #:close_cb (lambda (a)(exit)) ; #:expand "YES" #:title testfullname @@ -814,11 +814,11 @@ (let* ((mtrx-rc (conc lin ":" 6)) (fname (iup:attribute obj mtrx-rc)) (stepname (iup:attribute obj (conc lin ":" 1))) (comment (iup:attribute obj (conc lin ":" 7)))) (case col - ((7) (print "Comment from step "stepname": "comment)) + ((7) (debug:print 0 *default-log-port* "Comment from step "stepname": "comment)) ((8) (ezsteps:spawn-run-from testdat stepname #t)) ((9) (ezsteps:spawn-run-from testdat stepname #f)) (else (view-a-log fname)))))))) ;; (let loop ((count 0)) ;; (iup:attribute-set! steps-matrix "FITTOTEXT" (conc "L" count)) Index: dashboard.scm ================================================================== --- dashboard.scm +++ dashboard.scm @@ -191,23 +191,23 @@ (display "Checking for MT_ vars: ") (for-each (lambda (var) (display " ")(display var) (if (get-environment-variable var) (begin - (print "ERROR: environment variable " var " is set in this terminal, this will cause you problems. Exiting now.") + (debug:print 0 *default-log-port* "ERROR: environment variable " var " is set in this terminal, this will cause you problems. Exiting now.") (exit 1)))) '("MT_RUN_AREA_HOME" "MT_MEGATEST" "MT_CMDINFO" "MT_TEST_RUN_DIR" "MT_LINKTREE" "MT_TESTSUITENAME")) - (print ". Done. All ok."))) + (debug:print 0 *default-log-port* ". Done. All ok."))) (if (not (null? remargs)) (begin - (print "Unrecognised arguments: " (string-intersperse remargs " ")) + (debug:print 0 *default-log-port* "Unrecognised arguments: " (string-intersperse remargs " ")) (exit))) (if (args:get-arg "-h") (begin - (print help) + (debug:print 0 *default-log-port* help) (exit))) (if (args:get-arg "-start-dir") (if (directory-exists? (args:get-arg "-start-dir")) (let ((fullpath (common:real-path (args:get-arg "-start-dir")))) @@ -219,11 +219,11 @@ ;; TODO: Move this inside (main) ;; (if (not (launch:setup)) (begin - (print "Failed to find megatest.config, exiting") + (debug:print 0 *default-log-port* "Failed to find megatest.config, exiting") (exit 1))) ;; deal with RH 5.11 gtk lib or iup lib missing detachbox feature ;; first check for the switch ;; @@ -793,11 +793,11 @@ (hash-table-delete! (dboard:tabdat-allruns-by-id tabdat) run-id) (hash-table-set! (dboard:tabdat-allruns-by-id tabdat) run-id run-struct)) (if (or (null? tal) (> elapsed-time 2)) ;; stop loading data after 5 seconds, on the next call more data *should* be loaded since get-tests-for-run uses last update (begin - (if (> elapsed-time 2)(print "WARNING: timed out in update-testdat " elapsed-time "s")) + (if (> elapsed-time 2)(debug:print 0 *default-log-port* "WARNING: timed out in update-testdat " elapsed-time "s")) (dboard:tabdat-allruns-set! tabdat new-res) maxtests) (if (> (dboard:rundat-run-data-offset run-struct) 0) (loop run tal new-res newmaxtests) ;; not done getting data for this run (loop (car tal)(cdr tal) new-res newmaxtests))))))) @@ -1617,11 +1617,11 @@ #:expand "HORIZONTAL" #:value 1 #:action (lambda (obj tstate) (debug:catch-and-dump (lambda () - (print "tstate: " tstate) + ;; (print "tstate: " tstate) (if (eq? tstate 0) (dboard:tabdat-compact-layout-set! tabdat #f) (dboard:tabdat-compact-layout-set! tabdat #t)) (dboard:tabdat-last-filter-str-set! tabdat "") ) @@ -2054,11 +2054,11 @@ (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn) (debug:print 0 *default-log-port* "ERROR: failed call procedure " viewgen ", with; tab-num=" tab-num ", view-name=" view-name ", and views-cfgdat and megatest configdat as parameters. To debug try loading in the repl: megatest -repl") (set! success #f)) - (print "Adding tab " view-name " with proc " viewgen) + (debug:print 0 *default-log-port* "Adding tab " view-name " with proc " viewgen) ;; (iup:child-add! tabs (set! result-child ((eval (string->symbol viewgen)) commondat tabs tab-num view-name views-cfgdat *configdat*)))) ;; and finally set the updater (if success @@ -3157,11 +3157,11 @@ (filtrstr (conc targpatt "/" runpatt "/" testpatt))) ;; (print "targpatt: " targpatt " runpatt: " runpatt " testpatt: " testpatt) (if (not (equal? (dboard:tabdat-last-filter-str tabdat) filtrstr)) (let ((dwg (dboard:tabdat-drawing tabdat))) - (print "reseting drawing") + (debug:print 0 *default-log-port* "reseting drawing") (dboard:tabdat-layout-update-ok-set! tabdat #f) (vg:drawing-libs-set! dwg (make-hash-table)) (vg:drawing-insts-set! dwg (make-hash-table)) (vg:drawing-cache-set! dwg '()) (dboard:tabdat-allruns-by-id-set! tabdat (make-hash-table)) @@ -3387,11 +3387,11 @@ (vg:add-obj-to-comp cmp ;;(vg:make-rect-obj last-tval lly curr-tval last-yval ;; (- stval 2) lly (+ stval 2)(+ lly (* yval yscale)) (vg:make-line-obj curr-tval last-yval curr-tval next-yval line-color: graph-color))) - (print "ERROR: curr-tval is not > last-tval; curr-tval " curr-tval ", last-tval " last-tval)))) + (debug:print 0 *default-log-port* "ERROR: curr-tval is not > last-tval; curr-tval " curr-tval ", last-tval " last-tval)))) next) #f ;; (vector tstart minval minval) dat) )))))) ;; for each data point in the series (hash-table-keys alldat))))) @@ -3548,11 +3548,11 @@ (cons obj test-objs)))))) ;; (print "event_time: " (db:test-get-event_time testdat) " mapped event_time: " event-time) ;; (print "run-duration: " (db:test-get-run_duration testdat) " mapped run_duration: " run-duration) (if (> item-num 50) (if (eq? 0 (modulo item-num 50)) - (print "processing " run-num " of " num-runs " runs " item-num " of " num-items " of test " test-name ", " test-num " of " num-tests " tests"))) + (debug:print 0 *default-log-port* "processing " run-num " of " num-runs " runs " item-num " of " num-items " of test " test-name ", " test-num " of " num-tests " tests"))) ;; (print "test-name: " test-name " event-time: " event-time " run-duration: " run-duration) (let ((newdoneruns (cons rundat doneruns))) (if (null? tidstal) (if iterated (let* ((xtents (vg:get-extents-for-objs drawing new-test-objs)) @@ -3573,11 +3573,11 @@ (escapeloop #t) ;; (dboard:tabdat-layout-update-ok tabdat) ))))) ;; If it is an iterated test put box around it now. (if (not (null? tests-tal)) (if #f ;; (> (- (current-seconds) update-start-time) 5) - (print "drawing runs taking too long") + (debug:print 0 *default-log-port* "drawing runs taking too long") (if (dboard:tabdat-layout-update-ok tabdat) (testsloop (car tests-tal)(cdr tests-tal)(+ test-num 1)) (escapeloop #t) ;; (dboard:tabdat-layout-update-ok tabdat) ))))) ;; placeholder box @@ -3613,11 +3613,11 @@ (dboard:rundat-data-changed-set! rundat #f) (dboard:tabdat-not-done-runs-set! tabdat '()) (dboard:tabdat-done-runs-set! tabdat allruns)) (if #f ;; (> (- (current-seconds) update-start-time) 5) (begin - (print "drawing runs taking too long.... have " (length runtal) " remaining") + (debug:print 0 *default-log-port* "drawing runs taking too long.... have " (length runtal) " remaining") ;; (dboard:tabdat-done-runs-set! tabdat newdoneruns) ;; taking too long? stop here! ;; (time (vg:draw (dboard:tabdat-drawing tabdat) #t)) (dboard:tabdat-not-done-runs-set! tabdat runtal)) (begin (if (dboard:tabdat-layout-update-ok tabdat) Index: dbmod.scm ================================================================== --- dbmod.scm +++ dbmod.scm @@ -723,11 +723,11 @@ (if (<= try-num 0) #f (handle-exceptions exn (begin - (print "Attempt to safely close sqlite3 db failed. Trying again. exn=" exn) + (debug:print 0 *default-log-port* "Attempt to safely close sqlite3 db failed. Trying again. exn=" exn) (thread-sleep! 3) (sqlite3:interrupt! db) (db:safely-close-sqlite3-db db stmt-cache try-num: (- try-num 1))) (if (sqlite3:database? db) (let* ((stmts (and stmt-cache (hash-table-ref/default stmt-cache db #f)))) @@ -891,11 +891,11 @@ ;; (else ;; ((equal? fname "megatest.db") ;; this file can be regenerated if needed (handle-exceptions exn (begin - (print "Problems trying to repair the db, exn=" exn) + (debug:print 0 *default-log-port* "Problems trying to repair the db, exn=" exn) ;; (db:move-and-recreate-db dbdat) (if (> numtries 0) (db:repair-db dbdat numtries: (- numtries 1)) #f) (debug:print 0 *default-log-port* "FATAL: file " dbpath " was found corrupted, an attempt to fix has been made but you must start over.") @@ -1517,11 +1517,11 @@ (let ((keyn key)) (if (member (string-downcase keyn) (list "runname" "state" "status" "owner" "event_time" "comment" "fail_count" "pass_count" "contour")) (begin - (print "ERROR: your key cannot be named " keyn " as this conflicts with the same named field in the runs table, you must remove your megatest.db and /.db before trying again.") + (debug:print 0 *default-log-port* "ERROR: your key cannot be named " keyn " as this conflicts with the same named field in the runs table, you must remove your megatest.db and /.db before trying again.") (exit 1))))) keys) (sqlite3:with-transaction db (lambda () @@ -5032,25 +5032,26 @@ (delete-duplicates result))))) ;;====================================================================== ;; To sync individual run ;;====================================================================== + (define (db:get-run-record-ids dbstruct target run keynames test-patt) -(let ((backcons (lambda (lst item)(cons item lst)))) + (let ((backcons (lambda (lst item)(cons item lst)))) (db:with-db dbstruct #f #f (lambda (db) - (let* ((keystr (string-intersperse - (map (lambda (key val) - (conc key " like '" val "'")) - keynames - (string-split target "/")) - " AND ")) - (run-qry (conc "SELECT id FROM runs WHERE " keystr " and runname='" run"'")) - (test-qry (conc "SELECT id FROM tests WHERE run_id in (" run-qry ") and testname like '" test-patt "'"))) - (print run-qry) - (print test-qry) + (let* ((keystr (string-intersperse + (map (lambda (key val) + (conc key " like '" val "'")) + keynames + (string-split target "/")) + " AND ")) + (run-qry (conc "SELECT id FROM runs WHERE " keystr " and runname='" run"'")) + (test-qry (conc "SELECT id FROM tests WHERE run_id in (" run-qry ") and testname like '" test-patt "'"))) + ;; (print run-qry) + ;; (print test-qry) `((runs . ,(sqlite3:fold-row backcons '() db run-qry)) (tests . ,(sqlite3:fold-row backcons '() db test-qry)) (test_steps . ,(sqlite3:fold-row backcons '() db (conc "SELECT id FROM test_steps WHERE test_id in (" test-qry ")"))) (test_data . ,(sqlite3:fold-row backcons '() db (conc "SELECT id FROM test_data WHERE test_id in (" test-qry ")" ))) )))))) Index: dcommon.scm ================================================================== --- dcommon.scm +++ dcommon.scm @@ -706,11 +706,11 @@ (let* ((shell (if (get-environment-variable "SHELL") (conc "-e " (get-environment-variable "SHELL")) "")) (command (conc "cd " rundir ";mt_xterm -T \"" (string-translate testfullname "()" " ") "\" " shell "&"))) - (print "Command =" command) + (debug:print 0 *default-log-port* "Command =" command) (common:without-vars command "MT_.*")) (message-window (conc "Directory " rundir " not found")))))) (xterm) @@ -731,11 +731,11 @@ #:numcol 1 #:numlin (length key-vals) #:numcol-visible 1 #:numlin-visible (length key-vals) #:click-cb (lambda (obj lin col status) - (print "obj: " obj " lin: " lin " col: " col " status: " status))))) + (debug:print 0 *default-log-port* "obj: " obj " lin: " lin " col: " col " status: " status))))) ;; (iup:attribute-set! keys-matrix "0:0" "Run Keys") (iup:attribute-set! keys-matrix "WIDTH0" 0) (iup:attribute-set! keys-matrix "0:1" "Key Name") ;; (iup:attribute-set! keys-matrix "WIDTH1" "100") ;; fill in keys @@ -1000,14 +1000,14 @@ (iup:attribute fd "VALUE")) (iup:destroy! fd)))) ;; (lambda (obj) ;; (iup:show (iup:file-dialog)) ;; (print "File->open " obj))) - (iup:menu-item "Save" #:action (lambda (obj)(print "File->save " obj))) + (iup:menu-item "Save" #:action (lambda (obj)(debug:print 0 *default-log-port* "File->save " obj))) (iup:menu-item "Exit" #:action (lambda (obj)(exit))))) (iup:menu-item "Tools" (iup:menu - (iup:menu-item "Create new blah" #:action (lambda (obj)(print "Tools->new blah"))) + (iup:menu-item "Create new blah" #:action (lambda (obj)(debug:print 0 *default-log-port* "Tools->new blah"))) ;; (iup:menu-item "Show dialog" #:action (lambda (obj) ;; (show message-window ;; #:modal? #t ;; ;; set positon using coordinates or center, start, top, left, end, bottom, right, parent-center, current ;; ;; #:x 'mouse Index: diff-report.scm ================================================================== --- diff-report.scm +++ diff-report.scm @@ -147,11 +147,11 @@ (define (diff:target+run-name->run-id target run-name) (let* ((keys (rmt:get-keys)) (target-parts (if target (string-split target "/") (map (lambda (x) "%") keys)))) (if (not (eq? (length keys) (length keys))) (begin - (print "Error: Target ("target") item count does not match fields count target tokens="target-parts" fields="keys) + (debug:print 0 *default-log-port* "Error: Target ("target") item count does not match fields count target tokens="target-parts" fields="keys) #f) (let* ((target-map (zip keys target-parts)) (qry-res (rmt:get-runs run-name 1 0 target-map))) (if (eq? 2 (vector-length qry-res)) @@ -381,11 +381,11 @@ (s:h2 "Diffs + consistently failing tests") main-table))) ) (if html-output-file - (with-output-to-file html-output-file (lambda () (print html-body)))) + (with-output-to-file html-output-file (lambda () (debug:print 0 *default-log-port* html-body)))) (when (and email-recipients-list (> (length email-recipients-list) 0)) (sendmail (string-join email-recipients-list ",") email-subject html-body use_html: #t)) html-body)) @@ -411,16 +411,16 @@ (to-list (if (string? to-list-raw) (string-split to-list-raw ",:") #f)) ) (cond ((not src-run-id) - (print "No match for source target/runname="src-target"/"src-runname) - (print "Cannot proceed.") + (debug:print 0 *default-log-port* "No match for source target/runname="src-target"/"src-runname) + (debug:print 0 *default-log-port* "Cannot proceed.") #f) ((not dest-run-id) - (print "No match for source target/runname="dest-target"/"dest-runname) - (print "Cannot proceed.") + (debug:print 0 *default-log-port* "No match for source target/runname="dest-target"/"dest-runname) + (debug:print 0 *default-log-port* "Cannot proceed.") #f) (else (diff:deliver-diff-report src-run-id dest-run-id email-recipients-list: to-list html-output-file: html-file))))) Index: launchmod.scm ================================================================== --- launchmod.scm +++ launchmod.scm @@ -464,16 +464,16 @@ (let ((sighand (lambda (signum) ;; (signal-mask! signum) ;; to mask or not? seems to cause issues in exiting (if (eq? signum signal/stop) (debug:print-error 0 *default-log-port* "attempt to STOP process. Exiting.")) (bdat-time-to-exit-set! *bdat* #t) - (print "Received signal " signum ", cleaning up before exit (set this test to COMPLETED/ABORT) . Please wait...") + (debug:print 0 *default-log-port* "Received signal " signum ", cleaning up before exit (set this test to COMPLETED/ABORT) . Please wait...") (let ((th1 (make-thread (lambda () - (print "set test to COMPLETED/ABORT begin.") + (debug:print 0 *default-log-port* "set test to COMPLETED/ABORT begin.") (rmt:test-set-state-status run-id test-id "COMPLETED" "ABORT" "received kill signal") - (print "set test to COMPLETED/ABORT complete.") - (print "Killed by signal " signum ". Exiting") + (debug:print 0 *default-log-port* "set test to COMPLETED/ABORT complete.") + (debug:print 0 *default-log-port* "Killed by signal " signum ". Exiting") (exit 1)))) (th2 (make-thread (lambda () (thread-sleep! 20) (debug:print 0 *default-log-port* "Done") (exit 4))))) Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -934,16 +934,16 @@ (if (args:get-arg "-list-disks") (let ((toppath (launch:setup))) (print (string-intersperse - (map (lambda (x) - (string-intersperse - x - " => ")) - (common:get-disks *configdat*)) - "\n")) + (map (lambda (x) + (string-intersperse + x + " => ")) + (common:get-disks *configdat*)) + "\n")) (set! *didsomething* #t))) (if (args:get-arg "-refdb2dat") (let* ((input-db (args:get-arg "-refdb2dat")) Index: processmod.scm ================================================================== --- processmod.scm +++ processmod.scm @@ -177,11 +177,11 @@ (define (process:cmd-run-proc-each-line cmd proc . params) ;; (print "Called with cmd=" cmd ", proc=" proc ", params=" params) (handle-exceptions exn (begin - (print "ERROR: Failed to run command: " cmd " " (string-intersperse params " ")) + (debug:print 0 *default-log-port* "ERROR: Failed to run command: " cmd " " (string-intersperse params " ")) (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) (debug:print 5 *default-log-port* "exn=" (condition->list exn)) #f) (let-values (((fh fho pid) (if (null? params) (process cmd) Index: rmtmod.scm ================================================================== --- rmtmod.scm +++ rmtmod.scm @@ -710,11 +710,11 @@ (begin (debug:print-info 1 *default-log-port* "Warning: Run with id " run-id " was created after previous sync and deleted before the sync") #f) (if (handle-exceptions exn (begin (print-call-chain) - (print ((condition-property-accessor 'exn 'message) exn)) + (debug:print 0 *default-log-port* ((condition-property-accessor 'exn 'message) exn)) #f) (pgdb:insert-run dbh spec-id target run-name state status owner event-time comment fail-count pass-count area-id last-update publish-time)) @@ -762,11 +762,11 @@ (begin (debug:print-info 4 *default-log-port* "Inserting test-data with test-id: " test-id " and data-id " data-id " pgdb test id: " pgdb-test-id) (if (handle-exceptions exn (begin (print-call-chain) - (print ((condition-property-accessor 'exn 'message) exn)) + (debug:print 0 *default-log-port* ((condition-property-accessor 'exn 'message) exn)) #f) (pgdb:insert-test-data dbh pgdb-test-id category variable value expected tol units comment status type last-update)) ;(tasks:run-id->mtpg-run-id dbh cached-info run-id area-info) (begin @@ -792,28 +792,28 @@ #f)) (test-times (rmt:get-test-times runname target ))) (if (not runname) (begin - (print "Error: Missing argument -runname") + (debug:print 0 *default-log-port* "Error: Missing argument -runname") (exit))) (if (string-contains runname "%") (begin - (print "Error: Invalid runname, '%' not allowed (" runname ") ") + (debug:print 0 *default-log-port* "Error: Invalid runname, '%' not allowed (" runname ") ") (exit))) (if (not target) (begin - (print "Error: Missing argument -target") + (debug:print 0 *default-log-port* "Error: Missing argument -target") (exit))) (if (string-contains target "%") (begin - (print "Error: Invalid target, '%' not allowed (" target ") ") + (debug:print 0 *default-log-port* "Error: Invalid target, '%' not allowed (" target ") ") (exit))) (if (eq? (length test-times) 0) (begin - (print "Data not found!!") + (debug:print 0 *default-log-port* "Data not found!!") (exit))) (if (equal? (args:get-arg "-dumpmode") "json") (task:print-testtime-as-json test-times) (if (equal? (args:get-arg "-dumpmode") "csv") (task:print-testtime test-times ",") @@ -924,34 +924,34 @@ ;; get runs changed since last sync ;; (define (tasks:sync-test-data dbh cached-info area-info) ;; (let* (( (define (tasks:sync-to-postgres configdat dest) - (print "In sync") + (debug:print 0 *default-log-port* "In sync") (let* ((dbh (pgdb:open configdat dbname: dest)) (area-info (pgdb:get-area-by-path dbh *toppath*)) (cached-info (make-hash-table)) (start (current-seconds)) - (test-patt (if (args:get-arg "-testpatt") - (args:get-arg "-testpatt") - "%")) - (target (if (args:get-arg "-target") - (args:get-arg "-target") - #f)) - (run-name (if (args:get-arg "-runname") - (args:get-arg "-runname") - #f))) - (if (and target (not run-name)) - (begin - (print "Error: Provide runname") - (exit 1))) - (if (and (not target) run-name) - (begin - (print "Error: Provide target") - (exit 1))) - ;(print "123") - ;(exit 1) + (test-patt (if (args:get-arg "-testpatt") + (args:get-arg "-testpatt") + "%")) + (target (if (args:get-arg "-target") + (args:get-arg "-target") + #f)) + (run-name (if (args:get-arg "-runname") + (args:get-arg "-runname") + #f))) + (if (and target (not run-name)) + (begin + (debug:print 0 *default-log-port* "Error: Provide runname") + (exit 1))) + (if (and (not target) run-name) + (begin + (debug:print 0 *default-log-port* "Error: Provide target") + (exit 1))) + ;(print "123") + ;(exit 1) (for-each (lambda (dtype) (hash-table-set! cached-info dtype (make-hash-table))) '(runs targets tests steps data)) (hash-table-set! cached-info 'start start) ;; when done we'll set sync times to this (if area-info @@ -982,11 +982,11 @@ (tasks:sync-tests-data dbh cached-info test-ids area-info smallest-last-update-time) (debug:print-info 0 *default-log-port* "syncing test steps") (tasks:sync-test-steps dbh cached-info test-step-ids smallest-last-update-time) (debug:print-info 0 *default-log-port* "syncing test data") (tasks:sync-test-gen-data dbh cached-info test-data-ids smallest-last-update-time) - (print "----------done---------------"))) + (debug:print 0 *default-log-port* "----------done---------------"))) (let* ((smallest-time (hash-table-ref/default smallest-last-update-time "smallest-time" (current-seconds)))) (debug:print-info 0 "smallest-time :" smallest-time " last-sync-time " last-sync-time) (if (not (and target run-name)) (if (or (and smallest-time (> smallest-time last-sync-time)) (and smallest-time (eq? last-sync-time 0))) (pgdb:write-sync-time dbh area-info smallest-time))))) ;;this needs to be changed Index: runsmod.scm ================================================================== --- runsmod.scm +++ runsmod.scm @@ -253,11 +253,11 @@ (define (runs:too-soon-delay key dseconds wseconds) (let* ((last-time (hash-table-ref/default *too-soon-delays* key #f))) (if (and last-time (< (- (current-seconds) last-time) dseconds)) (begin - (debug:print-info 0 *default-log-port* "Whoa, slow down there ... "key" has been too recently seen.") + (debug:print-info 4 *default-log-port* "Whoa, slow down there ... "key" has been too recently seen.") (thread-sleep! wseconds))) (hash-table-set! *too-soon-delays* key (current-seconds)))) (define (runs:can-run-more-tests runsdat run-id jobgroup max-concurrent-jobs) @@ -395,15 +395,15 @@ ;; (if (tasks:need-server run-id)(tasks:start-and-wait-for-server tdbdat run-id 10)) (let ((sighand (lambda (signum) ;; (signal-mask! signum) ;; to mask or not? seems to cause issues in exiting (bdat-time-to-exit-set! *bdat* #t) - (print "Received signal " signum ", cleaning up before exit. Please wait...") + (debug:print 0 *default-log-port* "Received signal " signum ", cleaning up before exit. Please wait...") (let ((th1 (make-thread (lambda () ;; (let ((tdbdat (tasks:open-db))) (rmt:tasks-set-state-given-param-key task-key "killed") ;; ) - (print "Killed by signal " signum ". Exiting") + (debug:print 0 *default-log-port* "Killed by signal " signum ". Exiting") (thread-sleep! 3) (exit)))) (th2 (make-thread (lambda () (thread-sleep! 5) (debug:print 0 *default-log-port* "Done") @@ -1317,11 +1317,11 @@ (equal? status (db:test-get-status prevdat))))) (let ((fmt (runs:gendat-inc-results-fmt runs-data)) (dtime (seconds->year-work-week/day-time event-time))) (if (runs:lownoise "inc-print" 600) (begin - (print "fmt=" fmt) + ;; (print "fmt=" fmt) (format #t fmt "State" "Status" "Start Time" "Duration" "Test path"))) ;; (debug:print 0 *default-log-port* "fmt: " fmt " state: " state " status: " status " test-name: " test-name " item-path: " item-path " dtime: " dtime) ;; (debug:print 0 #f "event-time: " event-time " duration: " duration) (format #t fmt state @@ -2017,11 +2017,11 @@ (if (runs:dat-wait-for-jobs-function runsdat) ((runs:dat-wait-for-jobs-function runsdat) testdat-rec)) (if (not (launch-test test-id run-id run-info keyvals runname test-conf test-name test-path itemdat flags)) (begin - (print "ERROR: Failed to launch the test. Exiting as soon as possible") + (debug:print 0 *default-log-port* "ERROR: Failed to launch the test. Exiting as soon as possible") (set! *globalexitstatus* 1) ;; (process-signal (current-process-id) signal/kill)) ) ;; wait again here? )))))) @@ -2080,11 +2080,13 @@ res-ht)) ;; delete runs older than X (weeks, days, months years etc.) ;; delete redundant runs within a target - N is the input ;; delete redundant runs within a target IFF older than given date/time AND keep at least N -;; +;; +;; QUESTION: Should the (print ... be (debug:print ... or not? +;; (define (runs:remove-all-but-last-n-runs-per-target target-patts runpatt num-to-keep #!key (actions '(print))) (let* ((runs-ht (runs:get-hash-by-target target-patts runpatt)) (age (if (args:get-arg "-age")(common:hms-string->seconds (args:get-arg "-age")) #f)) (age-mark (if age (- (current-seconds) age) (+ (current-seconds) 86400))) (precmd (or (args:get-arg "-precmd") "")) @@ -2092,11 +2094,11 @@ ;; check the sequence of actions archive must comme before remove-runs (if (and action-chk (member (string->symbol "archive") action-chk)) (begin (debug:print-error 0 *default-log-port* "action remove-runs must come after archive") (exit 1))) - (print "Actions: " actions " age: " age) + (debug:print-info 0 *default-log-port* "Actions: " actions " age: " age) (for-each (lambda (action) (for-each (lambda (target) (let* ((runs (hash-table-ref runs-ht target)) @@ -2512,13 +2514,13 @@ ;; special case - archive get (if (equal? (args:get-arg "-archive") "get") (archive:bup-get-data "get" #f #f test-records rp-mutex bup-mutex)) (if (or (equal? (args:get-arg "-archive") "save") (equal? (args:get-arg "-archive") "save-remove")) (begin - (print "db archive started") + (debug:print 0 *default-log-port* "db archive started") (archive:megatest-db target runnamepatt) - (print "db archived"))) + (debug:print 0 *default-log-port* "db archived"))) ) #t ) ;;====================================================================== @@ -2586,24 +2588,25 @@ (rundat (mt:get-runs-by-patt keys runname target)) (header (vector-ref rundat 0)) (runs (vector-ref rundat 1))) (for-each (lambda (run) (let ((run-id (db:get-value-by-header run header "id")) - (str (if lock - "lock" - "unlock"))) + (str (if lock + "lock" + "unlock"))) (if (or lock (and unlock (or (args:get-arg "-force") - (begin - (print "Do you really wish to unlock run " run-id "?\n y/n: ") - (equal? "y" (read-line)))))) - (begin - (rmt:lock/unlock-run run-id lock unlock user) - (debug:print-info 0 *default-log-port* "Done " str " on run id " run-id)) + (begin + (print "Do you really wish to unlock run " run-id "?\n y/n: ") ;; Should this be (debug:print? + (equal? "y" (read-line)))))) + (begin + (rmt:lock/unlock-run run-id lock unlock user) + (debug:print-info 0 *default-log-port* "Done " str " on run id " run-id)) (debug:print-info 0 *default-log-port* "Skipping lock/unlock on " run-id)))) runs))) + ;;====================================================================== ;; Rollup runs ;;====================================================================== ;; Update the test_meta table for this test @@ -2783,11 +2786,11 @@ "%")) (run-times (rmt:get-run-times run-patt target-patt ))) (if (eq? (length run-times) 0) (begin - (print "Data not found!!") + (debug:print 0 *default-log-port* "Data not found!!") (exit))) (if (equal? (args:get-arg "-dumpmode") "json") (task:print-runtime-as-json run-times) (if (equal? (args:get-arg "-dumpmode") "csv") (task:print-runtime run-times ",") Index: testsmod.scm ================================================================== --- testsmod.scm +++ testsmod.scm @@ -488,11 +488,11 @@ (let ((my-start-time (current-seconds)) (lockf (conc outputfilename ".lock"))) (let loop ((have-lock (common:simple-file-lock lockf))) (if have-lock (let ((script (configf:lookup *configdat* "testrollup" test-name))) - (print "Obtained lock for " outputfilename) + (debug:print 0 *default-log-port* "Obtained lock for " outputfilename) (rmt:set-state-status-and-roll-up-items run-id test-name "" #f #f #f) (if script (system (conc script " > " outputfilename " & ")) (tests:generate-html-summary-for-iterated-test run-id test-id test-name outputfilename)) (common:simple-file-release-lock lockf) @@ -502,11 +502,11 @@ ;; didn't get the lock, check to see if current update started later than this ;; update, if so we can exit without doing any work (if (> my-start-time (handle-exceptions exn (begin - (print "failed to get mod time on " lockf ", exn=" exn) + (debug:print 0 *default-log-port* "failed to get mod time on " lockf ", exn=" exn) 0) (file-modification-time lockf))) ;; we started since current re-gen in flight, delay a little and try again (begin (debug:print-info 1 *default-log-port* "Waiting to update " outputfilename ", another test currently updating it") @@ -545,11 +545,11 @@ comment) "" "")))) (if (list? testdat) testdat (begin - (print "ERROR: failed to get records with rmt:test-get-records-for-index-file run-id=" run-id "test-name=" test-name) + (debug:print 0 *default-log-port* "ERROR: failed to get records with rmt:test-get-records-for-index-file run-id=" run-id "test-name=" test-name) '()))) (print "
") ;; Print out stats for status (set! tot 0) Index: ulex-simple/ulex.scm ================================================================== --- ulex-simple/ulex.scm +++ ulex-simple/ulex.scm @@ -114,10 +114,12 @@ (numthreads 10) (cmd-thread #f) (work-queue-thread #f) (num-threads-running 0) ) + +(define ulex-printer (make-parameter print)) ;;====================================================================== ;; serialization ;; NOTE: I've had problems with read/write and s11n serialize, deserialize ;; thus the inefficient method here @@ -154,11 +156,11 @@ (base64:base64-decode (string-substitute (regexp "_") "=" msg #t))) (lambda ()(deserialize))) (begin - (print "ULEX ERROR: cannot translate received data \""msg"\"") + ((ulex-printer) "ULEX ERROR: cannot translate received data \""msg"\"") (print-call-chain (current-error-port)) msg))) ;; crude reply for when things go awry ((write)(with-input-from-string msg (lambda ()(read)))) ((s11n)(with-input-from-string msg (lambda ()(deserialize)))) (else msg))) ;; rpc @@ -242,11 +244,11 @@ (isme (do-work udata dat)) ;; no transmission needed (else (handle-exceptions ;; TODO - MAKE THIS EXCEPTION CMD SPECIFIC? exn (begin - (print "ULEX send-receive: exn="exn) + ((ulex-printer) "ULEX send-receive: exn="exn) (message exn)) (begin ;; (mutex-lock! *send-mutex*) ;; DOESN'T SEEM TO HELP (let-values (((inp oup)(tcp-connect host port))) (let ((res (if (and inp oup) @@ -253,11 +255,11 @@ (begin (write (obj->string dat) oup) ;; (write dat oup);; (serialize dat oup) (close-output-port oup) (string->obj (read inp))) ;; (deserialize inp)) (begin - (print "ERROR: send called but no receiver has been setup. Please call setup first!") + ((ulex-printer) "ERROR: send called but no receiver has been setup. Please call setup first!") #f)))) ;; (close-output-port oup) (close-input-port inp) ;; (mutex-unlock! *send-mutex*) ;; DOESN'T SEEM TO HELP res)))))))) ;; res will always be 'ack unless return-method is direct @@ -281,11 +283,11 @@ (result (proc rem-host-port qrykey cmd params)) (end-time (current-milliseconds)) (run-time (- end-time start-time))) result)))) (else - (print "ERROR: rdat "rdat", did not match rem-host-port qrykey cmd params"))))) + ((ulex-printer) "ERROR: rdat "rdat", did not match rem-host-port qrykey cmd params"))))) ;;====================================================================== ;; misc utils ;;======================================================================