Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -1961,11 +1961,11 @@ ;; 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*) + ;; (mutex-lock! *db-transaction-mutex*) (db:with-db dbstruct #f #f @@ -1983,11 +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*) + ;; (mutex-unlock! *db-transaction-mutex*) res)))) (define (db:get-main-run-stats dbstruct run-id) (db:with-db dbstruct @@ -2487,11 +2487,12 @@ run-id #t (lambda (db) (let ((test-id (db:get-test-id dbstruct run-id testname ""))) (sqlite3:execute db qry newstate newstatus run-id testname) - (if test-id (mt:process-triggers run-id test-id newstate newstatus))) + (if test-id (mt:process-triggers dbstruct run-id test-id newstate newstatus)) + ) )))) testnames)) ;; speed up for common cases with a little logic ;; NB// Ultimately this will be deprecated in deference to mt:test-set-state-status-by-id @@ -2511,11 +2512,11 @@ (else (if newstate (sqlite3:execute db "UPDATE tests SET state=? WHERE id=?;" newstate test-id)) (if newstatus (sqlite3:execute db "UPDATE tests SET status=? WHERE id=?;" newstatus test-id)) (if newcomment (sqlite3:execute db "UPDATE tests SET comment=? WHERE id=?;" newcomment ;; (sdb:qry 'getid newcomment) test-id)))) - (mt:process-triggers run-id test-id newstate newstatus)))) + (mt:process-triggers dbstruct run-id test-id newstate newstatus)))) ;; NEW BEHAVIOR: Count tests running in all runs! ;; (define (db:get-count-tests-running dbstruct run-id) (db:with-db @@ -3155,11 +3156,11 @@ ;; (db:general-call dbdat 'state-status (list state status test-id))) (db:set-state-status-and-roll-up-items dbstruct run-id test-id #f state status msg) ;; process the test_data table (if (and test-id state status (equal? status "AUTO")) (db:test-data-rollup dbstruct run-id test-id status)) - (mt:process-triggers run-id test-id state status))) + (mt:process-triggers dbstruct run-id test-id state status))) ;; state is the priority rollup of all states ;; status is the priority rollup of all completed statesfu ;; ;; if test-name is an integer work off that instead of test-name test-path @@ -3175,11 +3176,11 @@ (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))) - (mutex-lock! *db-transaction-mutex*) + ;; (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) @@ -3209,11 +3210,12 @@ (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*)) + ;;(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: mt.scm ================================================================== --- mt.scm +++ mt.scm @@ -128,12 +128,12 @@ ;;====================================================================== ;; T R I G G E R S ;;====================================================================== -(define (mt:process-triggers run-id test-id newstate newstatus) - (let* ((test-dat (rmt:get-test-info-by-id run-id test-id))) +(define (mt:process-triggers dbstruct run-id test-id newstate newstatus) + (let* ((test-dat (db:get-test-info-by-id dbstruct run-id test-id))) (if test-dat (let* ((test-rundir ;; (rmt:sdb-qry 'getstr ;; (filedb:get-path *fdb* (db:test-get-rundir test-dat)) ;; ) ;; ) (test-name (db:test-get-testname test-dat)) (tconfig #f) @@ -187,17 +187,17 @@ ;; (else ;; (if newstate (rmt:general-call 'set-test-state run-id newstate test-id)) ;; (if newstatus (rmt:general-call 'set-test-status run-id newstatus test-id)) ;; (if newcomment (rmt:general-call 'set-test-comment run-id newcomment test-id)))) (rmt:roll-up-pass-fail-counts run-id test-id #f newstate newstatus newcomment) - (mt:process-triggers run-id test-id newstate newstatus) + ;; (mt:process-triggers run-id test-id newstate newstatus) #t))) (define (mt:test-set-state-status-by-testname run-id test-name item-path new-state new-status new-comment) (let ((test-id (rmt:get-test-id run-id test-name item-path))) (rmt:roll-up-pass-fail-counts run-id test-name item-path new-state new-status new-comment) - (mt:process-triggers run-id test-id new-state new-status) + ;; (mt:process-triggers run-id test-id new-state new-status) #t)) ;;(mt:test-set-state-status-by-id run-id test-id new-state new-status new-comment))) (define (mt:lazy-read-test-config test-name) (let ((tconf (hash-table-ref/default *testconfigs* test-name #f))) Index: tests.scm ================================================================== --- tests.scm +++ tests.scm @@ -352,13 +352,13 @@ #f)))))) (pop-directory) result))))) (define (tests:test-force-state-status! run-id test-id state status) - (rmt:test-set-status-state run-id test-id status state #f) + (rmt:test-set-status-state run-id test-id status state #f)) ;; (rmt:roll-up-pass-fail-counts run-id test-name item - (mt:process-triggers run-id test-id state status)) + ;; (mt:process-triggers run-id test-id state status)) ;; Do not rpc this one, do the underlying calls!!! (define (tests:test-set-status! run-id test-id state status comment dat #!key (work-area #f)) (let* ((real-status status) (otherdat (if dat dat (make-hash-table))) Index: utils/plot-code.scm ================================================================== --- utils/plot-code.scm +++ utils/plot-code.scm @@ -34,10 +34,11 @@ (lambda () (apply print data)))) (print-err "Making graph for files: " (string-intersperse targs ", ")) (print-err "Looking at files: " (string-intersperse files ", ")) +(print-err "Function regex: " function-patt) ;; Gather the functions ;; (for-each (lambda (fname) @@ -49,16 +50,17 @@ (let ((match (string-match defn-rx inl))) (if match (let ((fnname (cadr match))) ;; (print " " fnname) (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 '()))) - )) + (begin + (set! all-fns (cons fnname all-fns))) + (hash-table-set! + filedat-defns + fname + (cons fnname (hash-table-ref/default filedat-defns fname '()))) + ))) (loop (read-line)))))))) files) ;; fill up the regex hash (print-err "Make the huge regex hash")