Overview
Comment: | Made mt:process-triggers run exclusively on the server side |
---|---|
Downloads: | Tarball | ZIP archive | SQL archive |
Timelines: | family | ancestors | descendants | both | v1.63-stackdumpfix |
Files: | files | file ages | folders |
SHA1: |
bcaec592852774ae2fca6a61ca6bb0d8 |
User & Date: | matt on 2017-01-06 22:37:18 |
Other Links: | branch diff | manifest | tags |
Context
2017-01-07
| ||
17:07 | Changed some calls using status-state order to state-status to be consistent and easier to read. check-in: bf1dd4b5fc user: matt tags: v1.63-stackdumpfix | |
2017-01-06
| ||
22:37 | Made mt:process-triggers run exclusively on the server side check-in: bcaec59285 user: matt tags: v1.63-stackdumpfix | |
21:54 | utils/plot-code.scm check-in: 064872f8bc user: matt tags: v1.63-stackdumpfix | |
Changes
Modified db.scm from [b31dceb2af] to [aa5dac4609].
︙ | ︙ | |||
1959 1960 1961 1962 1963 1964 1965 | "SELECT state,status,count(id) AS count FROM tests WHERE run_id=? AND NOT(uname='n/a' AND item_path='') GROUP BY state,status;;" run-id)))) ;; Update run_stats for given run_id ;; input data is a list (state status count) ;; (define (db:update-run-stats dbstruct run-id stats) | | | 1959 1960 1961 1962 1963 1964 1965 1966 1967 1968 1969 1970 1971 1972 1973 | "SELECT state,status,count(id) AS count FROM tests WHERE run_id=? AND NOT(uname='n/a' AND item_path='') GROUP BY state,status;;" run-id)))) ;; 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 |
︙ | ︙ | |||
1981 1982 1983 1984 1985 1986 1987 | (for-each (lambda (dat) (sqlite3:execute stmt1 run-id (car dat)(cadr dat)) (apply sqlite3:execute stmt2 run-id dat)) stats))))) (sqlite3:finalize! stmt1) (sqlite3:finalize! stmt2) | | | 1981 1982 1983 1984 1985 1986 1987 1988 1989 1990 1991 1992 1993 1994 1995 | (for-each (lambda (dat) (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 #f ;; this data comes from main #f |
︙ | ︙ | |||
2485 2486 2487 2488 2489 2490 2491 | (db:with-db dbstruct 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) | | > | 2485 2486 2487 2488 2489 2490 2491 2492 2493 2494 2495 2496 2497 2498 2499 2500 | (db:with-db dbstruct 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 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 ;; (define (db:test-set-state-status-by-id dbstruct run-id test-id newstate newstatus newcomment) |
︙ | ︙ | |||
2509 2510 2511 2512 2513 2514 2515 | ((and newstate newstatus) (sqlite3:execute db "UPDATE tests SET state=?,status=? WHERE id=?;" newstate newstatus test-id)) (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)))) | | | 2510 2511 2512 2513 2514 2515 2516 2517 2518 2519 2520 2521 2522 2523 2524 | ((and newstate newstatus) (sqlite3:execute db "UPDATE tests SET state=?,status=? WHERE id=?;" newstate newstatus test-id)) (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 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 dbstruct run-id |
︙ | ︙ | |||
3153 3154 3155 3156 3157 3158 3159 | ;; (if msg ;; (db:general-call dbdat 'state-status-msg (list state status msg test-id)) ;; (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)) | | | | 3154 3155 3156 3157 3158 3159 3160 3161 3162 3163 3164 3165 3166 3167 3168 3169 3170 3171 3172 3173 3174 3175 3176 3177 3178 3179 3180 3181 3182 3183 3184 3185 3186 3187 3188 | ;; (if msg ;; (db:general-call dbdat 'state-status-msg (list state status msg test-id)) ;; (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 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 ;; (define (db:set-state-status-and-roll-up-items dbstruct run-id test-name item-path state status comment) ;; establish info on incoming test followed by info on top level test (let* ((db (db:dbdat-get-db (dbr:dbstruct-tmpdb dbstruct))) (testdat (if (number? test-name) (db:get-test-info-by-id dbstruct run-id test-name) ;; test-name is actually a test-id (db:get-test-info dbstruct run-id test-name item-path))) (test-id (db:test-get-id testdat)) (test-name (if (number? test-name) (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*) (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 |
︙ | ︙ | |||
3207 3208 3209 3210 3211 3212 3213 | "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)))))) | | > | 3208 3209 3210 3211 3212 3213 3214 3215 3216 3217 3218 3219 3220 3221 3222 3223 | "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 ;; ;; (define (db:roll-up-pass-fail-counts dbstruct run-id test-name item-path state status) |
︙ | ︙ |
Modified mt.scm from [1d20117cfc] to [8b3b9cbacc].
︙ | ︙ | |||
126 127 128 129 130 131 132 | res) (cons testn res))))))))) ;;====================================================================== ;; T R I G G E R S ;;====================================================================== | | | | 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 | res) (cons testn res))))))))) ;;====================================================================== ;; T R I G G E R S ;;====================================================================== (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) (state (if newstate newstate (db:test-get-state test-dat))) (status (if newstatus newstatus (db:test-get-status test-dat)))) |
︙ | ︙ | |||
185 186 187 188 189 190 191 | ;; ((and newstate newstatus) ;; (rmt:general-call 'state-status run-id newstate newstatus test-id)) ;; (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) | | | | 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 | ;; ((and newstate newstatus) ;; (rmt:general-call 'state-status run-id newstate newstatus test-id)) ;; (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) #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) #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))) (if tconf tconf |
︙ | ︙ |
Modified tests.scm from [99a08e573f] to [585eeaa784].
︙ | ︙ | |||
350 351 352 353 354 355 356 | #t (loop (car tal)(cdr tal))) #f)))))) (pop-directory) result))))) (define (tests:test-force-state-status! run-id test-id state status) | | | | 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 | #t (loop (car tal)(cdr tal))) #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:roll-up-pass-fail-counts run-id test-name item ;; (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))) (testdat (rmt:get-test-info-by-id run-id test-id)) (test-name (db:test-get-testname testdat)) |
︙ | ︙ |
Modified utils/plot-code.scm from [903f29a75e] to [34a7dae9ed].
︙ | ︙ | |||
32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 | (define (print-err . data) (with-output-to-port (current-error-port) (lambda () (apply print data)))) (print-err "Making graph for files: " (string-intersperse targs ", ")) (print-err "Looking at files: " (string-intersperse files ", ")) ;; Gather the functions ;; (for-each (lambda (fname) (print-err "Processing file " fname) (with-input-from-file fname (lambda () (let loop ((inl (read-line))) (if (not (eof-object? inl)) (let ((match (string-match defn-rx inl))) (if match (let ((fnname (cadr match))) ;; (print " " fnname) (if (string-match function-rx fnname) | > > | | | | | | | 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 | (define (print-err . data) (with-output-to-port (current-error-port) (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) (print-err "Processing file " fname) (with-input-from-file fname (lambda () (let loop ((inl (read-line))) (if (not (eof-object? inl)) (let ((match (string-match defn-rx inl))) (if match (let ((fnname (cadr match))) ;; (print " " fnname) (if (string-match function-rx fnname) (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") (for-each (lambda (fnname) |
︙ | ︙ |