Index: common.scm ================================================================== --- common.scm +++ common.scm @@ -603,22 +603,22 @@ ;; (define (common:readonly-watchdog dbstruct) (thread-sleep! 0.05) ;; delay for startup - (BB> "common:readonly-watchdog entered.") + (debug:print-info 13 *default-log-port* "common:readonly-watchdog entered.") ;; sync megatest.db to /tmp/.../megatst.db (let* ((sync-cool-off-duration 3) (golden-mtdb (dbr:dbstruct-mtdb dbstruct)) (golden-mtpath (db:dbdat-get-path golden-mtdb)) (tmp-mtdb (dbr:dbstruct-tmpdb dbstruct)) (tmp-mtpath (db:dbdat-get-path tmp-mtdb))) (debug:print-info 0 *default-log-port* "Read-only periodic sync thread started.") (let loop ((last-sync-time 0)) - (BB> "loop top tmp-mtpath="tmp-mtpath" golden-mtpath="golden-mtpath) + (debug:print-info 13 *default-log-port* "loop top tmp-mtpath="tmp-mtpath" golden-mtpath="golden-mtpath) (let* ((duration-since-last-sync (- (current-seconds) last-sync-time))) - (BB> "duration-since-last-sync="duration-since-last-sync) + (debug:print-info 13 *default-log-port* "duration-since-last-sync="duration-since-last-sync) (if (and (not *time-to-exit*) (< duration-since-last-sync sync-cool-off-duration)) (thread-sleep! (- sync-cool-off-duration duration-since-last-sync))) (if (not *time-to-exit*) (let ((golden-mtdb-mtime (file-modification-time golden-mtpath)) @@ -652,14 +652,15 @@ (sync-in-progress *db-sync-in-progress*) (should-sync (and (not *time-to-exit*) (> (- (current-seconds) *db-last-sync*) 5))) ;; sync every five seconds minimum (start-time (current-seconds)) (mt-mod-time (file-modification-time mtpath)) - (recently-synced (> (- start-time mt-mod-time) 4)) + (recently-synced (< (- start-time mt-mod-time) 4)) (will-sync (and (or need-sync should-sync) (not sync-in-progress) (not recently-synced)))) + (debug:print-info 13 *default-log-port* "WD writable-watchdog top of loop. need-sync="need-sync" sync-in-progress="sync-in-progress" should-sync="should-sync" start-time="start-time" mt-mod-time="mt-mod-time" recently-synced="recently-synced" will-sync="will-sync) ;; (if recently-synced (debug:print-info 0 *default-log-port* "Skipping sync due to recently-synced flag=" recently-synced)) ;; (debug:print-info 0 *default-log-port* "need-sync: " need-sync " sync-in-progress: " sync-in-progress " should-sync: " should-sync " will-sync: " will-sync) (if will-sync (set! *db-sync-in-progress* #t)) (mutex-unlock! *db-multi-sync-mutex*) (if will-sync @@ -685,11 +686,11 @@ ;; keep going unless time to exit ;; (if (not *time-to-exit*) (let delay-loop ((count 0)) - ;;(BB> "delay-loop top; count="count" pid="(current-process-id)" this-wd-num="this-wd-num" *time-to-exit*="*time-to-exit*) + ;;(debug:print-info 13 *default-log-port* "delay-loop top; count="count" pid="(current-process-id)" this-wd-num="this-wd-num" *time-to-exit*="*time-to-exit*) (if (and (not *time-to-exit*) (< count 4)) ;; was 11, changing to 4. (begin (thread-sleep! 1) @@ -699,28 +700,28 @@ (debug:print-info 0 *default-log-port* "Exiting watchdog timer, *time-to-exit* = " *time-to-exit*" pid="(current-process-id)" this-wd-num="this-wd-num))))))) ;; TODO: for multiple areas, we will have multiple watchdogs; and multiple threads to manage (define (common:watchdog) ;;#t) - (BB> "common:watchdog entered.") + (debug:print-info 13 *default-log-port* "common:watchdog entered.") (let ((dbstruct (db:setup))) - (BB> "after db:setup with dbstruct="dbstruct) + (debug:print-info 13 *default-log-port* "after db:setup with dbstruct="dbstruct) (cond ((dbr:dbstruct-read-only dbstruct) - (BB> "loading read-only watchdog") + (debug:print-info 13 *default-log-port* "loading read-only watchdog") (common:readonly-watchdog dbstruct)) (else - (BB> "loading writable-watchdog.") + (debug:print-info 13 *default-log-port* "loading writable-watchdog.") (common:writable-watchdog dbstruct)))) - (BB> "watchdog done.");;) + (debug:print-info 13 *default-log-port* "watchdog done.");;) ) (define (std-exit-procedure) (on-exit (lambda () 0)) - ;;(BB> "std-exit-procedure called; *time-to-exit*="*time-to-exit*) + ;;(debug:print-info 13 *default-log-port* "std-exit-procedure called; *time-to-exit*="*time-to-exit*) (let ((no-hurry (if *time-to-exit* ;; hurry up #f (begin (set! *time-to-exit* #t) #t)))) @@ -763,11 +764,11 @@ 0) (define (std-signal-handler signum) ;; (signal-mask! signum) (set! *time-to-exit* #t) - ;;(BB> "got signal "signum) + ;;(debug:print-info 13 *default-log-port* "got signal "signum) (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 Index: dashboard.scm ================================================================== --- dashboard.scm +++ dashboard.scm @@ -113,13 +113,13 @@ (exit 1))) ;; create a watch dog to move changes from lt/.db/*.db to megatest.db ;; ;;;(if (file-write-access? (conc *toppath* "/megatest.db")) -;;(BB> "Before common:watchdog spawn") +;;(debug:print-info 13 *default-log-port* "Before common:watchdog spawn") (thread-start! (make-thread common:watchdog "Watchdog thread")) -;;(BB> "After common:watchdog spawn") +;;(debug:print-info 13 *default-log-port* "After common:watchdog spawn") (if (not (args:get-arg "-use-db-cache")) (begin (debug:print-info 0 *default-log-port* "Forcing db-cache mode due to read-only access to megatest.db") (hash-table-set! args:arg-hash "-use-db-cache" #t)));;;) @@ -1700,12 +1700,12 @@ (tests-mindat (dcommon:minimize-test-data tests-dat))) ;; reduces data for display (dboard:tabdat-last-runs-update-set! tabdat (- (current-seconds) 2)) (hash-table-set! (dboard:tabdat-last-test-dat tabdat) run-id tests-dat) (hash-table-set! (dboard:tabdat-run-update-times tabdat) run-id (- (current-seconds) 10)) (when (not run) - (BB> "ERROR: NO RUN FOR RUN-ID run-id="run-id) - (BB> "runs-hash-> " (hash-table->alist runs-hash)) + (debug:print-info 13 *default-log-port* "ERROR: NO RUN FOR RUN-ID run-id="run-id) + (debug:print-info 13 *default-log-port* "runs-hash-> " (hash-table->alist runs-hash)) ) tests-mindat)) (define (dashboard:runs-summary-xor-matrix-content tabdat runs-hash #!key (hide-clean #f)) (let* ((src-run-id (dboard:tabdat-prev-run-id tabdat)) @@ -2077,11 +2077,11 @@ ;; Bummer - we dont have the global get/set api mapped in chicken ;; (let* ((modkeys (iup:global "MODKEYSTATE"))) ;; (BB> "modkeys="modkeys)) - (BB> "click-cb: obj="obj" lin="lin" col="col" status="status) + (debug:print-info 13 *default-log-port* "click-cb: obj="obj" lin="lin" col="col" status="status) ;; status is corrupted on Brandon's home machine. will have to wait until after shutdown to see if it is still broken in PDX SLES (let* ((toolpath (car (argv))) (key (conc lin ":" col)) (test-id (hash-table-ref/default cell-lookup key -1)) (run-id (dboard:tabdat-curr-run-id tabdat)) @@ -2101,25 +2101,25 @@ (item-test-path (conc test-name "/" (if (equal? item-path "") "%" item-path))) (status-chars (char-set->list (string->char-set status))) (testpanel-cmd (conc toolpath " -test " (dboard:tabdat-curr-run-id tabdat) "," test-id " &"))) - (BB> "status-chars=["status-chars"] status=["status"]") + (debug:print-info 13 *default-log-port* "status-chars=["status-chars"] status=["status"]") (cond ((member #\1 status-chars) ;; 1 is left mouse button (system testpanel-cmd)) ((member #\2 status-chars) ;; 2 is middle mouse button - (BB> "mmb- test-name="test-name" testpatt="testpatt) + (debug:print-info 13 *default-log-port* "mmb- test-name="test-name" testpatt="testpatt) (iup:show (dashboard:popup-menu run-id test-id target runname test-name testpatt item-test-path) ;; popup-menu #:x 'mouse #:y 'mouse #:modal? "NO") ) (else - (BB> "unhandled status in run-summary-click-cb. Doing right click action. (status is corrupted on Brandon's ubuntu host - bad/buggy iup install??" ) + (debug:print-info 13 *default-log-port* "unhandled status in run-summary-click-cb. Doing right click action. (status is corrupted on Brandon's ubuntu host - bad/buggy iup install??" ) (iup:show (dashboard:popup-menu run-id test-id target runname test-name testpatt item-test-path) ;; popup-menu #:x 'mouse #:y 'mouse #:modal? "NO") ) @@ -3427,11 +3427,11 @@ ;;(print "RA => calling runs-tab-updater with commondat " commondat " tab-num " tab-num) ;;(tabdat-values tabdat) ;;RA added ;; (pp (dboard:tabdat->alist tabdat)) ;; (if (dashboard:database-changed? commondat tabdat context-key: 'runs-rundat) (dashboard:do-update-rundat tabdat) - ;;(BB> "dashboard:runs-tab-updater") + ;;(debug:print-info 13 *default-log-port* "dashboard:runs-tab-updater") ;;(inspect tabdat) (let ((uidat (dboard:commondat-uidat commondat))) ;;(print "RA => Calling update-buttons with tabdat : " tabdat " uidat " uidat) (update-buttons tabdat uidat (dboard:tabdat-numruns tabdat) (dboard:tabdat-num-tests tabdat))) Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -283,11 +283,11 @@ (mtdb (db:open-megatest-db)) (mtdbpath (db:dbdat-get-path mtdb)) (mtdbexists (file-exists? mtdbpath)) (refndb (db:open-megatest-db path: dbpath name: "megatest_ref.db")) (write-access (file-write-access? mtdbpath))) - ;;(BB> "db:open-db>> mtdbpath="mtdbpath" mtdbexists="mtdbexists" and write-access="write-access) + ;;(debug:print-info 13 *default-log-port* "db:open-db>> mtdbpath="mtdbpath" mtdbexists="mtdbexists" and write-access="write-access) (if (and dbexists (not write-access)) (begin (set! *db-write-access* #f) (dbr:dbstruct-read-only-set! dbstruct #t))) (dbr:dbstruct-mtdb-set! dbstruct mtdb) @@ -298,11 +298,11 @@ ;; (mutex-unlock! *rundb-mutex*) (if #t ;;(not dbfexists) (begin (debug:print 0 *default-log-port* "filling db " (db:dbdat-get-path tmpdb) " with data from " (db:dbdat-get-path mtdb)) (db:sync-tables (db:sync-all-tables-list dbstruct) #f mtdb refndb tmpdb) - (BB> "db:sync-all-tables-list done.") + (debug:print-info 13 *default-log-port* "db:sync-all-tables-list done.") ) (debug:print 0 *default-log-port* " db, " (db:dbdat-get-path tmpdb) " already exists, not propogating data from " (db:dbdat-get-path mtdb))) ;; (db:multi-db-sync dbstruct 'old2new)) ;; migrate data from megatest.db automatically tmpdb)))) @@ -314,20 +314,20 @@ ;; (cond (*dbstruct-db* *dbstruct-db*);; TODO: when multiple areas are supported, this optimization will be a hazard (else ;;(common:on-homehost?) - (BB> "db:setup entered (first time, not cached.)") + (debug:print-info 13 *default-log-port* "db:setup entered (first time, not cached.)") (let* ((dbstruct (make-dbr:dbstruct))) (when (not *toppath*) - (BB> "in db:setup, *toppath* not set; calling launch:setup") + (debug:print-info 13 *default-log-port* "in db:setup, *toppath* not set; calling launch:setup") (launch:setup areapath: areapath)) - (BB> "Begin db:open-db") + (debug:print-info 13 *default-log-port* "Begin db:open-db") (db:open-db dbstruct areapath: areapath) - (BB> "Done db:open-db") + (debug:print-info 13 *default-log-port* "Done db:open-db") (set! *dbstruct-db* dbstruct) - ;;(BB> "new dbstruct = "(dbr:dbstruct->alist dbstruct)) + ;;(debug:print-info 13 *default-log-port* "new dbstruct = "(dbr:dbstruct->alist dbstruct)) dbstruct)))) ;; (else ;; (debug:print 0 *default-log-port* "ERROR: attempt to open database when not on homehost. Exiting. Homehost: " (common:get-homehost)) ;; (exit 1)))) @@ -341,11 +341,11 @@ (db (db:lock-create-open dbpath (lambda (db) (db:initialize-main-db db) (db:initialize-run-id-db db)))) (write-access (file-write-access? dbpath))) - (BB> "db:open-megatest-db "dbpath) + (debug:print-info 13 *default-log-port* "db:open-megatest-db "dbpath) (if (and dbexists (not write-access)) (set! *db-write-access* #f)) (cons db dbpath))) ;; sync run to disk if touched Index: launch.scm ================================================================== --- launch.scm +++ launch.scm @@ -71,11 +71,11 @@ (status (configf:lookup dat "final" "exit-status")) (msg (configf:lookup dat "final" "message"))) (if csvt ;; this if blocked stack dump caused by .dat file from logpro being 0-byte. fixed by upgrading logpro (rmt:csv->test-data run-id test-id csvt) (debug:print 0 *default-log-port* "ERROR: no csvdat exists for run-id: " run-id " test-id: " test-id " stepname: " stepname ", check that logpro version is 1.15 or newer")) - ;; (BB> "Error: run-id/test-id/stepname="run-id"/"test-id"/"stepname" => bad csvr="csvr) + ;; (debug:print-info 13 *default-log-port* "Error: run-id/test-id/stepname="run-id"/"test-id"/"stepname" => bad csvr="csvr) ;; ) (cond ((equal? status "PASS") "PASS") ;; skip the message part if status is pass (status (conc (configf:lookup dat "final" "exit-status") ": " (if msg msg "no message"))) (else #f))) Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -2017,11 +2017,11 @@ ;; Exit and clean up ;;====================================================================== (if (not *didsomething*) (debug:print 0 *default-log-port* help)) -;;(BB> "thread-join! watchdog") +;;(debug:print-info 13 *default-log-port* "thread-join! watchdog") ;; join the watchdog thread if it has been thread-start!ed (it may not have been started in the case of a server that never enters running state) ;; (symbols returned by thread-state: created ready running blocked suspended sleeping terminated dead) ;; TODO: for multiple areas, we will have multiple watchdogs; and multiple threads to manage (if (thread? *watchdog*) Index: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -1331,11 +1331,11 @@ ;; now *if* -run-wait we wait for all tests to be done ;; Now wait for any RUNNING tests to complete (if in run-wait mode) (thread-sleep! 5) ;; I think there is a race condition here. Let states/statuses settle (let wait-loop ((num-running (rmt:get-count-tests-running-for-run-id run-id)) (prev-num-running 0)) - ;; (BB> "num-running=" num-running ", prev-num-running=" prev-num-running) + ;; (debug:print-info 13 *default-log-port* "num-running=" num-running ", prev-num-running=" prev-num-running) (if (and (or (args:get-arg "-run-wait") (equal? (configf:lookup *configdat* "setup" "run-wait") "yes")) (> num-running 0)) (begin ;; Here we mark any old defunct tests as incomplete. Do this every fifteen minutes