Index: db.scm
==================================================================
--- db.scm
+++ db.scm
@@ -766,15 +766,13 @@
;; b. If test dir gone, delete the test record
;; 2. Look at run records
;; a. If have tests that are not deleted, set state='unknown'
;; b. ....
;;
-(define (db:clean-up dbstruct)
-
- (debug:print 0 "ERROR: db clean up not ported yet")
-
- (let* ((db (db:get-db dbstruct #f))
+(define (db:clean-up db)
+ (debug:print 0 "WARNING: db clean up not ported to v1.60, cleanup action will be on megatest.db")
+ (let* (;; (db (db:get-db dbstruct #f))
(count-stmt (sqlite3:prepare db "SELECT (SELECT count(id) FROM tests)+(SELECT count(id) FROM runs);"))
(statements
(map (lambda (stmt)
(sqlite3:prepare db stmt))
(list
@@ -799,11 +797,11 @@
(sqlite3:for-each-row (lambda (tot)
(debug:print-info 0 "Records count after clean: " tot))
count-stmt)))
(map sqlite3:finalize! statements)
(sqlite3:finalize! count-stmt)
- (db:find-and-mark-incomplete db)
+ ;; (db:find-and-mark-incomplete db)
(sqlite3:execute db "VACUUM;")))
;;======================================================================
;; M E T A G E T A N D S E T V A R S
;;======================================================================
@@ -1634,15 +1632,18 @@
(lambda (db)
(let* ((qmarks (string-intersperse (make-list (length db:test-record-fields) "?") ","))
(qrystr (conc "INSERT OR REPLACE INTO tests (" db:test-record-qry-selector ") VALUES (" qmarks ");"))
(qry (sqlite3:prepare db qrystr)))
(debug:print 0 "INFO: migrating test records for run with id " run-id)
- (for-each
- (lambda (rec)
- ;; (debug:print 0 "INFO: Inserting values: " (string-intersperse (map conc (vector->list rec)) ",") "\n")
- (apply sqlite3:execute qry (vector->list rec)))
- testrecs)
+ (sqlite3:with-transaction
+ db
+ (lambda ()
+ (for-each
+ (lambda (rec)
+ ;; (debug:print 0 "INFO: Inserting values: " (string-intersperse (map conc (vector->list rec)) ",") "\n")
+ (apply sqlite3:execute qry (vector->list rec)))
+ testrecs)))
(sqlite3:finalize! qry)))))
;; map a test-id into the proper range
;;
(define (db:adj-test-id mtdb min-test-id test-id)
Index: megatest.scm
==================================================================
--- megatest.scm
+++ megatest.scm
@@ -1293,11 +1293,25 @@
(if (args:get-arg "-import-megatest.db")
(let* ((toppath (launch:setup-for-run))
(dbstruct (if toppath (make-dbr:dbstruct path: toppath) #f))
(mtdb (if toppath (db:open-megatest-db)))
- (run-ids (if toppath (db:get-all-run-ids mtdb))))
+ (run-ids (if toppath (db:get-all-run-ids mtdb)))
+ (mdb (tasks:open-db))
+ (servers (tasks:get-all-servers mdb)))
+
+ ;; kill servers
+ (for-each
+ (lambda (server)
+ (tasks:server-delete-record mdb (vector-ref server 0) "dbmigration")
+ (tasks:kill-server (vector-ref server 2)(vector-ref server 1)))
+ servers)
+ (sqlite3:finalize! mdb)
+
+ ;; clear out junk records
+ ;;
+ (db:clean-up mtdb)
;; adjust test-ids to fit into proper range
;;
(db:prep-megatest.db-for-migration mtdb)
Index: tasks.scm
==================================================================
--- tasks.scm
+++ tasks.scm
@@ -295,48 +295,50 @@
(define (tasks:get-all-servers mdb)
(let ((res '()))
(sqlite3:for-each-row
(lambda (id pid hostname interface port pubport start-time priority state mt-version last-update transport run-id)
- ;; 0 1 2 3 4 5 6 7 8 9 10 11 12
+ ;; 0 1 2 3 4 5 6 7 8 9 10 11 12
(set! res (cons (vector id pid hostname interface port pubport start-time priority state mt-version last-update transport run-id) res)))
mdb
"SELECT id,pid,hostname,interface,port,pubport,start_time,priority,state,mt_version,strftime('%s','now')-heartbeat AS last_update,transport,run_id FROM servers WHERE state NOT LIKE 'defunct%' ORDER BY start_time DESC;")
res))
-(define (tasks:kill-server status hostname port pid)
- (debug:print-info 1 "Removing defunct server record for " hostname ":" port)
- (if port
- (open-run-close tasks:server-deregister tasks:open-db hostname port: port)
- (open-run-close tasks:server-deregister tasks:open-db hostname pid: pid))
- (if status ;; #t means alive
- (begin
- (if (equal? hostname (get-host-name))
- (handle-exceptions
- exn
- (debug:print-info 0 "server may or may not be dead, check for megatest -server running as pid " pid "\n"
- " EXCEPTION: " ((condition-property-accessor 'exn 'message) exn))
- (debug:print 1 "Sending signal/term to " pid " on " hostname)
- (process-signal pid signal/term)
- (thread-sleep! 5) ;; give it five seconds to die peacefully then do a brutal kill
- ;;(process-signal pid signal/kill)
- ) ;; local machine, send sig term
- (begin
- ;;(debug:print-info 1 "Stopping remote servers not yet supported."))))
- (debug:print-info 1 "Telling alive server on " hostname ":" port " to commit servercide")
- (let ((serverdat (list hostname port)))
- (hash-table-set! *runremote* run-id (http-transport:client-connect hostname port))
- (cdb:kill-server serverdat pid))))) ;; remote machine, try telling server to commit suicide
- (begin
- (if status
- (if (equal? hostname (get-host-name))
- (begin
- (debug:print-info 1 "Sending signal/term to " pid " on " hostname)
- (process-signal pid signal/term) ;; local machine, send sig term
- (thread-sleep! 5) ;; give it five seconds to die peacefully then do a brutal kill
- (process-signal pid signal/kill))
- (debug:print 0 "WARNING: Can't kill frozen server on remote host " hostname))))))
+;; no elegance here ...
+;;
+(define (tasks:kill-server hostname pid)
+ (debug:print-info 0 "Attempting to kill server process " pid " on host " hostname)
+ (setenv "TARGETHOST" hostname)
+ (system (conc "nbfake kill " pid)))
+
+;; (if status ;; #t means alive
+;; (begin
+;; (if (equal? hostname (get-host-name))
+;; (handle-exceptions
+;; exn
+;; (debug:print-info 0 "server may or may not be dead, check for megatest -server running as pid " pid "\n"
+;; " EXCEPTION: " ((condition-property-accessor 'exn 'message) exn))
+;; (debug:print 1 "Sending signal/term to " pid " on " hostname)
+;; (process-signal pid signal/term)
+;; (thread-sleep! 5) ;; give it five seconds to die peacefully then do a brutal kill
+;; ;;(process-signal pid signal/kill)
+;; ) ;; local machine, send sig term
+;; (begin
+;; ;;(debug:print-info 1 "Stopping remote servers not yet supported."))))
+;; (debug:print-info 1 "Telling alive server on " hostname ":" port " to commit servercide")
+;; (let ((serverdat (list hostname port)))
+;; (hash-table-set! *runremote* run-id (http-transport:client-connect hostname port))
+;; (cdb:kill-server serverdat pid))))) ;; remote machine, try telling server to commit suicide
+;; (begin
+;; (if status
+;; (if (equal? hostname (get-host-name))
+;; (begin
+;; (debug:print-info 1 "Sending signal/term to " pid " on " hostname)
+;; (process-signal pid signal/term) ;; local machine, send sig term
+;; (thread-sleep! 5) ;; give it five seconds to die peacefully then do a brutal kill
+;; (process-signal pid signal/kill))
+;; (debug:print 0 "WARNING: Can't kill frozen server on remote host " hostname))))))
;;======================================================================
;; Tasks and Task monitors
;;======================================================================