Index: common.scm ================================================================== --- common.scm +++ common.scm @@ -212,10 +212,43 @@ (if res (cadr res)(if (null? default) #f (car default))))) (define (common:get-testsuite-name) (or (configf:lookup *configdat* "setup" "testsuite" ) (pathname-file *toppath*))) + +;;====================================================================== +;; E X I T H A N D L I N G +;;====================================================================== + +(define (std-exit-procedure) + (debug:print-info 0 "starting exit process, finalizing databases.") + (rmt:print-db-stats) + (let ((run-ids (hash-table-keys *db-local-sync*))) + (if (not (null? run-ids)) + (db:multi-db-sync run-ids 'new2old))) + (if *dbstruct-db* (db:close-all *dbstruct-db*)) + (if (and *megatest-db* + (sqlite3:database? *megatest-db*)) + (begin + (sqlite3:interrupt! *megatest-db*) + (sqlite3:finalize! *megatest-db* #t) + (set! *megatest-db* #f))) + (if *task-db* (let ((db (cdr *task-db*))) + (if (sqlite3:database? db) + (begin + (sqlite3:interrupt! db) + (sqlite3:finalize! db #t) + (vector-set! *task-db* 0 #f)))))) + +(define (std-signal-handler signum) + (signal-mask! signum) + (debug:print 0 "ERROR: Received signal " signum " exiting promptly") + ;; (std-exit-procedure) ;; shouldn't need this since we are exiting and it will be called anyway + (exit)) + +(set-signal-handler! signal/int std-signal-handler) +(set-signal-handler! signal/term std-signal-handler) ;;====================================================================== ;; Misc utils ;;====================================================================== Index: dashboard.scm ================================================================== --- dashboard.scm +++ dashboard.scm @@ -1519,12 +1519,11 @@ ((args:get-arg "-run") (let ((runid (string->number (args:get-arg "-run")))) (if runid (begin (lambda (x) - (on-exit (lambda () - (if *dbstruct-local* (db:close-all *dbstruct-local*)))) + (on-exit std-exit-procedure) (examine-run *dbstruct-local* runid))) (begin (print "ERROR: runid is not a number " (args:get-arg "-run")) (exit 1))))) ((args:get-arg "-test") ;; run-id,test-id Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -178,16 +178,17 @@ (debug:print 0 "ERROR: no such db in non-writable dir " fname) (sqlite3:open-database fname)))))) ;; This routine creates the db. It is only called if the db is not already opened ;; -(define (db:open-rundb dbstruct run-id #!key (attemptnum 0)) ;; (conc *toppath* "/megatest.db") (car *configinfo*))) +(define (db:open-rundb dbstruct run-id #!key (attemptnum 0)(do-not-open #f)) ;; (conc *toppath* "/megatest.db") (car *configinfo*))) (let* ((local (dbr:dbstruct-get-local dbstruct)) (rdb (if local (dbr:dbstruct-get-localdb dbstruct run-id) (dbr:dbstruct-get-inmem dbstruct)))) ;; (dbr:dbstruct-get-runrec dbstruct run-id 'inmem))) - (if rdb + (if (or rdb + do-not-open) rdb (let* ((dbpath (db:dbfile-path run-id)) ;; (conc toppath "/db/" run-id ".db")) (dbexists (file-exists? dbpath)) (inmem (if local #f (db:open-inmem-db))) (refdb (if local #f (db:open-inmem-db))) @@ -319,43 +320,67 @@ (let ((num-synced (db:sync-tables db:sync-tests-only inmem refdb rundb olddb))) (dbr:dbstruct-set-stime! dbstruct (current-milliseconds)) num-synced) 0))))) +(define (db:close-main dbstruct) + (let ((maindb (dbr:dbstruct-get-main dbstruct))) + (if maindb + (begin + (sqlite3:finalize! (db:dbdat-get-db maindb)) + (dbr:dbstruct-set-main! dbstruct #f))))) + +(define (db:close-run-db dbstruct run-id) + (let ((rdb (db:open-rundb dbstruct run-id do-not-open: #t))) + (if (and rdb + (sqlite3:database? rdb)) + (begin + (sqlite3:finalize! rdb) + (dbr:dbstruct-set-localdb! dbstruct run-id #f) + (dbr:dbstruct-set-inmem! dbstruct #f))))) + ;; close all opened run-id dbs (define (db:close-all dbstruct) ;; finalize main.db (db:sync-touched dbstruct 0 force-sync: #t) ;;(common:db-block-further-queries) ;; (mutex-lock! *db-sync-mutex*) ;; with this perhaps it isn't necessary to use the block-further-queries mechanism? - (sqlite3:finalize! (db:dbdat-get-db (db:get-db dbstruct #f))) - (let* ((local (dbr:dbstruct-get-local dbstruct)) - (rundb (db:dbdat-get-db (dbr:dbstruct-get-rundb dbstruct)))) - (if local - (for-each - (lambda (dbdat) - (let ((db (db:dbdat-get-db dbdat))) - (if (sqlite3:database? db) - (begin - (sqlite3:interrupt! db) - (sqlite3:finalize! db #t))))) - ;; TODO: Come back to this and rework to delete from hashtable when finalized - (hash-table-values (dbr:dbstruct-get-locdbs dbstruct)))) - (thread-sleep! 3) - (if (and rundb - (sqlite3:database? rundb)) - (handle-exceptions - exn - (begin - (debug:print 0 "WARNING: database files may not have been closed correctly. Consider running -cleanup-db") - (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) - (debug:print 0 " db: " rundb) - (print-call-chain (current-error-port)) - #f) - (sqlite3:interrupt! rundb) - (sqlite3:finalize! rundb #t)))) - ;; (mutex-unlock! *db-sync-mutex*) + + (db:close-main dbstruct) + + (let ((locdbs (dbr:dbstruct-get-locdbs dbstruct))) + (if (hash-table? locdbs) + (for-each (lambda (run-id) + (db:close-run-db dbstruct run-id)) + (hash-table-keys locdbs)))) + + ;; (let* ((local (dbr:dbstruct-get-local dbstruct)) + ;; (rundb (db:dbdat-get-db (dbr:dbstruct-get-rundb dbstruct)))) + ;; (if local + ;; (for-each + ;; (lambda (dbdat) + ;; (let ((db (db:dbdat-get-db dbdat))) + ;; (if (sqlite3:database? db) + ;; (begin + ;; (sqlite3:interrupt! db) + ;; (sqlite3:finalize! db #t))))) + ;; ;; TODO: Come back to this and rework to delete from hashtable when finalized + ;; (hash-table-values (dbr:dbstruct-get-locdbs dbstruct)))) + ;; (thread-sleep! 3) + ;; (if (and rundb + ;; (sqlite3:database? rundb)) + ;; (handle-exceptions + ;; exn + ;; (begin + ;; (debug:print 0 "WARNING: database files may not have been closed correctly. Consider running -cleanup-db") + ;; (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) + ;; (debug:print 0 " db: " rundb) + ;; (print-call-chain (current-error-port)) + ;; #f) + ;; (sqlite3:interrupt! rundb) + ;; (sqlite3:finalize! rundb #t)))) + ;; ;; (mutex-unlock! *db-sync-mutex*) ) (define (db:open-inmem-db) (let* ((db (sqlite3:open-database ":memory:")) (handler (make-busy-timeout 3600))) Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -320,33 +320,10 @@ (loop))))) "Watchdog thread")) (thread-start! *watchdog*) -(define (std-exit-procedure) - (rmt:print-db-stats) - (let ((run-ids (hash-table-keys *db-local-sync*))) - (if (not (null? run-ids)) - (db:multi-db-sync run-ids 'new2old))) - ;; (if *dbstruct-db* (db:close-all *dbstruct-db*)) - ;; (if *megatest-db* (begin - ;; (sqlite3:interrupt! *megatest-db*) - ;; (sqlite3:finalize! *megatest-db* #t))) - ;; (if *task-db* (let ((db (vector-ref *task-db* 0))) - ;; (sqlite3:interrupt! db) - ;; (sqlite3:finalize! db #t)))) - ) - -(define (std-signal-handler signum) - (signal-mask! signum) - (debug:print 0 "ERROR: Received signal " signum " exiting promptly") - (std-exit-procedure) - (exit)) - -(set-signal-handler! signal/int std-signal-handler) -(set-signal-handler! signal/term std-signal-handler) - (if (args:get-arg "-log") (let ((oup (open-output-file (args:get-arg "-log")))) (debug:print-info 0 "Sending log output to " (args:get-arg "-log")) (current-error-port oup) (current-output-port oup))) @@ -411,11 +388,11 @@ (let ((newval (conc (args:get-arg "-testpatt") "/" (args:get-arg "-itempatt")))) (debug:print 0 "WARNING: -itempatt has been deprecated, please use -testpatt testpatt/itempatt method, new testpatt is "newval) (hash-table-set! args:arg-hash "-testpatt" newval) (hash-table-delete! args:arg-hash "-itempatt"))) -;; (on-exit std-exit-procedure) +(on-exit std-exit-procedure) ;;====================================================================== ;; Misc general calls ;;====================================================================== Index: tasks.scm ================================================================== --- tasks.scm +++ tasks.scm @@ -354,11 +354,11 @@ (let loop ((server-dat (tasks:get-server (db:delay-if-busy tdbdat) run-id)) (delay-time 0)) (if (and (not server-dat) (< delay-time delay-max-tries)) (begin - (if (common:low-noise-print 60 run-id)(debug:print 0 "Try starting server for run-id " run-id)) + (if (common:low-noise-print 60 "tasks:start-and-wait-for-server" run-id)(debug:print 0 "Try starting server for run-id " run-id)) (server:kind-run run-id) (thread-sleep! (min delay-time 5)) (loop (tasks:get-server (db:delay-if-busy tdbdat) run-id)(+ delay-time 1)))))) (define (tasks:get-all-servers mdb)