Index: common.scm
==================================================================
--- common.scm
+++ common.scm
@@ -97,10 +97,11 @@
(define *db-multi-sync-mutex* (make-mutex)) ;; protect access to *db-sync-in-progress*, *db-last-sync*
;; task db
(define *task-db* #f) ;; (vector db path-to-db)
(define *db-access-allowed* #t) ;; flag to allow access
(define *db-access-mutex* (make-mutex))
+(define *db-transaction-mutex* (make-mutex))
(define *db-cache-path* #f)
;; SERVER
(define *my-client-signature* #f)
(define *transport-type* 'http) ;; override with [server] transport http|rpc|nmsg
Index: db.scm
==================================================================
--- db.scm
+++ db.scm
@@ -1961,16 +1961,19 @@
;; Update run_stats for given run_id
;; input data is a list (state status count)
;;
(define (db:update-run-stats dbstruct run-id stats)
+ (mutex-lock! *db-transaction-mutex*)
(db:with-db
dbstruct
#f
#f
+
(lambda (db)
;; remove previous data
+
(let* ((stmt1 (sqlite3:prepare db "DELETE FROM run_stats WHERE run_id=? AND state=? AND status=?;"))
(stmt2 (sqlite3:prepare db "INSERT INTO run_stats (run_id,state,status,count) VALUES (?,?,?,?);"))
(res
(sqlite3:with-transaction
db
@@ -1980,10 +1983,11 @@
(sqlite3:execute stmt1 run-id (car dat)(cadr dat))
(apply sqlite3:execute stmt2 run-id dat))
stats)))))
(sqlite3:finalize! stmt1)
(sqlite3:finalize! stmt2)
+ (mutex-unlock! *db-transaction-mutex*)
res))))
(define (db:get-main-run-stats dbstruct run-id)
(db:with-db
dbstruct
@@ -3171,42 +3175,46 @@
(db:test-get-testname testdat)
test-name))
(item-path (db:test-get-item-path testdat))
(tl-testdat (db:get-test-info dbstruct run-id test-name ""))
(tl-test-id (db:test-get-id tl-testdat)))
- (sqlite3:with-transaction
- db
- (lambda ()
- (db:test-set-state-status-by-id dbstruct run-id test-id state status comment)
- (if (not (equal? item-path "")) ;; only roll up IF incoming test is an item
- (let* ((state-status-counts (db:get-all-state-status-counts-for-test db run-id test-name item-path)) ;; item-path is used to exclude current state/status of THIS test
- (running (length (filter (lambda (x)
- (member (dbr:counts-state x) *common:running-states*))
- state-status-counts)))
- (bad-not-started (length (filter (lambda (x)
- (and (equal? (dbr:counts-state x) "NOT_STARTED")
- (not (member (dbr:counts-status x)
- *common:not-started-ok-statuses*))))
- state-status-counts)))
- (all-curr-states (common:special-sort ;; worst -> best (sort of)
- (delete-duplicates
- (cons state (map dbr:counts-state state-status-counts)))
- *common:std-states* >))
- (all-curr-statuses (common:special-sort ;; worst -> best
- (delete-duplicates
- (cons status (map dbr:counts-status state-status-counts)))
- *common:std-statuses* >))
- (newstate (if (> running 0)
- "RUNNING"
- (if (> bad-not-started 0)
- "COMPLETED"
- (car all-curr-states))))
- (newstatus (if (> bad-not-started 0)
- "CHECK"
- (car all-curr-statuses))))
- ;; (print "Setting toplevel to: " newstate "/" newstatus)
- (db:test-set-state-status-by-id dbstruct run-id tl-test-id newstate newstatus #f)))))))
+ (mutex-lock! *db-transaction-mutex*)
+ (let ((tr-res
+ (sqlite3:with-transaction
+ db
+ (lambda ()
+ (db:test-set-state-status-by-id dbstruct run-id test-id state status comment)
+ (if (not (equal? item-path "")) ;; only roll up IF incoming test is an item
+ (let* ((state-status-counts (db:get-all-state-status-counts-for-test db run-id test-name item-path)) ;; item-path is used to exclude current state/status of THIS test
+ (running (length (filter (lambda (x)
+ (member (dbr:counts-state x) *common:running-states*))
+ state-status-counts)))
+ (bad-not-started (length (filter (lambda (x)
+ (and (equal? (dbr:counts-state x) "NOT_STARTED")
+ (not (member (dbr:counts-status x)
+ *common:not-started-ok-statuses*))))
+ state-status-counts)))
+ (all-curr-states (common:special-sort ;; worst -> best (sort of)
+ (delete-duplicates
+ (cons state (map dbr:counts-state state-status-counts)))
+ *common:std-states* >))
+ (all-curr-statuses (common:special-sort ;; worst -> best
+ (delete-duplicates
+ (cons status (map dbr:counts-status state-status-counts)))
+ *common:std-statuses* >))
+ (newstate (if (> running 0)
+ "RUNNING"
+ (if (> bad-not-started 0)
+ "COMPLETED"
+ (car all-curr-states))))
+ (newstatus (if (> bad-not-started 0)
+ "CHECK"
+ (car all-curr-statuses))))
+ ;; (print "Setting toplevel to: " newstate "/" newstatus)
+ (db:test-set-state-status-by-id dbstruct run-id tl-test-id newstate newstatus #f))))))
+ (mutex-unlock! *db-transaction-mutex*))
+ tr-res)))
(define db:roll-up-pass-fail-counts db:set-state-status-and-roll-up-items)
;; call with state = #f to roll up with out accounting for state/status of this item
;;
Index: launch.scm
==================================================================
--- launch.scm
+++ launch.scm
@@ -1121,12 +1121,12 @@
((dboard) "../megatest")
((mtest) "../megatest")
((dashboard) "megatest")
(else exe)))))
(launcher (common:get-launcher *configdat* test-name item-path)) ;; (config-lookup *configdat* "jobtools" "launcher"))
- (test-sig (conc (common:get-testsuite-name) ":" test-name ":" item-path)) ;; (item-list->path itemdat))) ;; test-path is the full path including the item-path
- (work-area #f)
+ (test-sig (conc (common:get-testsuite-name) ":" test-name ":" item-path)) ;; (item-list->path itemdat))) ;; test-path is the full path including the item-path
+ (work-area #f)
(toptest-work-area #f) ;; for iterated tests the top test contains data relevant for all
(diskpath #f)
(cmdparms #f)
(fullcmd #f) ;; (define a (with-output-to-string (lambda ()(write x))))
(mt-bindir-path #f)
Index: rmt.scm
==================================================================
--- rmt.scm
+++ rmt.scm
@@ -75,11 +75,11 @@
(set! *runremote* (make-remote))
(mutex-unlock! *rmt-mutex*)
(debug:print-info 12 *default-log-port* "rmt:send-receive, case 1")
(rmt:send-receive cmd rid params attemptnum: attemptnum))
;; ensure we have a homehost record
- ((not (pair? (remote-hh-dat *runremote*))) ;; have a homehost record?
+ ((not (pair? (remote-hh-dat *runremote*))) ;; not on homehost
(thread-sleep! 0.1) ;; since we shouldn't get here, delay a little
(remote-hh-dat-set! *runremote* (common:get-homehost))
(mutex-unlock! *rmt-mutex*)
(debug:print-info 12 *default-log-port* "rmt:send-receive, case 2")
(rmt:send-receive cmd rid params attemptnum: attemptnum))
@@ -141,18 +141,20 @@
;; (rmt:send-receive cmd rid params attemptnum: attemptnum)) ;) ;)
;;;;
;; if not on homehost ensure we have a connection to a live server
;; NOTE: we *have* a homehost record by now
- ((and (not (cdr (remote-hh-dat *runremote*))) ;; not on a homehost
- (not (remote-conndat *runremote*)) ;; and no connection
- (server:read-dotserver *toppath*)) ;; .server file exists
- ;; something caused the server entry in tdb to disappear, but the server is still running
- (server:remove-dotserver-file *toppath* ".*")
- (mutex-unlock! *rmt-mutex*)
- (debug:print-info 12 *default-log-port* "rmt:send-receive, case 20")
- (rmt:send-receive cmd rid params attemptnum: (add1 attemptnum)))
+
+ ;; ((and (not (cdr (remote-hh-dat *runremote*))) ;; not on a homehost
+ ;; (not (remote-conndat *runremote*)) ;; and no connection
+ ;; (server:read-dotserver *toppath*)) ;; .server file exists
+ ;; ;; something caused the server entry in tdb to disappear, but the server is still running
+ ;; (server:remove-dotserver-file *toppath* ".*")
+ ;; (mutex-unlock! *rmt-mutex*)
+ ;; (debug:print-info 12 *default-log-port* "rmt:send-receive, case 20")
+ ;; (rmt:send-receive cmd rid params attemptnum: (add1 attemptnum)))
+
((and (not (cdr (remote-hh-dat *runremote*))) ;; not on a homehost
(not (remote-conndat *runremote*))) ;; and no connection
(debug:print-info 12 *default-log-port* "rmt:send-receive, case 6 hh-dat: " (remote-hh-dat *runremote*) " conndat: " (remote-conndat *runremote*))
(mutex-unlock! *rmt-mutex*)
(tasks:start-and-wait-for-server (tasks:open-db) 0 15)
@@ -178,11 +180,11 @@
(debug:print 0 *default-log-port* "ERROR: transport " (remote-transport *runremote*) " not supported")
(exit))))
(success (if (vector? dat) (vector-ref dat 0) #f))
(res (if (vector? dat) (vector-ref dat 1) #f)))
(if (vector? conninfo)(http-transport:server-dat-update-last-access conninfo)) ;; refresh access time
- (debug:print-info 12 *default-log-port* "rmt:send-receive, case 9. conninfo=" conninfo " dat=" dat)
+ (debug:print-info 12 *default-log-port* "rmt:send-receive, case 9. conninfo=" conninfo " dat=" dat " *runremote* = "*runremote*)
(if success
(case (remote-transport *runremote*)
((http) res)
(else
(debug:print 0 *default-log-port* "ERROR: transport " (remote-transport *runremote*) " is unknown")
Index: tasks.scm
==================================================================
--- tasks.scm
+++ tasks.scm
@@ -448,14 +448,16 @@
(reverse res)))
;; no elegance here ...
;;
(define (tasks:kill-server hostname pid #!key (kill-switch ""))
+ (server:remove-dotserver-file *toppath* ".*")
(debug:print-info 0 *default-log-port* "Attempting to kill server process " pid " on host " hostname)
(setenv "TARGETHOST" hostname)
(setenv "TARGETHOST_LOGF" "server-kills.log")
(system (conc "nbfake kill "kill-switch" "pid))
+
(unsetenv "TARGETHOST_LOGF")
(unsetenv "TARGETHOST"))
;; look up a server by run-id and send it a kill, also delete the record for that server
;;
@@ -466,10 +468,11 @@
(let ((hostname (vector-ref sdat 6))
(pid (vector-ref sdat 5))
(server-id (vector-ref sdat 0)))
(tasks:server-set-state! (db:delay-if-busy tdbdat) server-id "killed")
(debug:print-info 0 *default-log-port* "Killing server " server-id " for run-id " run-id " on host " hostname " with pid " pid)
+ (server:remove-dotserver-file *toppath* ".*")
(tasks:kill-server hostname pid)
(tasks:server-delete-record (db:delay-if-busy tdbdat) server-id tag) )
(debug:print-info 0 *default-log-port* "No server found for run-id " run-id ", nothing to kill"))
;; (sqlite3:finalize! tdb)
))
Index: utils/nbfake
==================================================================
--- utils/nbfake
+++ utils/nbfake
@@ -70,7 +70,7 @@
if [[ -z "$MY_NBFAKE_HOST" ]]; then
# Run locally
sh -c "cd $CURRWD;export DISPLAY=$DISPLAY; export PATH=$PATH; nohup $* >> $MY_NBFAKE_LOG 2>&1 &"
else
# run remotely
- ssh -n -f $MY_NBFAKE_HOST "sh -c \"cd $CURRWD;export DISPLAY=$DISPLAY; export PATH=$PATH; nohup $* >> $MY_NBFAKE_LOG 2>&1 &\""
+ ssh -X -n -f $MY_NBFAKE_HOST "sh -c \"cd $CURRWD;export DISPLAY=$DISPLAY; export PATH=$PATH; nohup $* >> $MY_NBFAKE_LOG 2>&1 &\""
fi
Index: utils/plot-code.scm
==================================================================
--- utils/plot-code.scm
+++ utils/plot-code.scm
@@ -8,17 +8,19 @@
;; third param is list of files to scan
(use regex srfi-69 srfi-13)
(define targs #f)
-(define files (cddddr (argv)))
+(define files (cdr (cddddr (argv))))
(let ((targdat (cadddr (argv))))
(if (equal? targdat "-")
(set! targs files)
(set! targs (string-split targdat ","))))
+(define function-patt (car (cdr (cdddr (argv)))))
+(define function-rx (regexp function-patt))
(define filedat-defns (make-hash-table))
(define filedat-usages (make-hash-table))
(define defn-rx (regexp "^\\s*\\(define\\s+\\(([^\\s\\)]+).*"))
(define all-regexs (make-hash-table))
@@ -46,11 +48,12 @@
(if (not (eof-object? inl))
(let ((match (string-match defn-rx inl)))
(if match
(let ((fnname (cadr match)))
;; (print " " fnname)
- (set! all-fns (cons fnname all-fns))
+ (if (string-match function-rx fnname)
+ (set! all-fns (cons fnname all-fns)))
(hash-table-set!
filedat-defns
fname
(cons fnname (hash-table-ref/default filedat-defns fname '())))
))