Changes In Branch test-specific-db Through [b95aecf28b] Excluding Merge-Ins
This is equivalent to a diff from e6642c0f2d to b95aecf28b
2012-10-07
| ||
12:14 | merged to trunk while sitting next to a creek in Prescott wilderness check-in: 30895dfd86 user: user tags: trunk, test4-clean | |
2012-09-19
| ||
12:25 | Migrated steps to test specific db file check-in: 7861874745 user: mrwellan tags: test-specific-db | |
2012-09-18
| ||
17:31 | Partially broken implementation of steps data move to testrundat check-in: b95aecf28b user: mrwellan tags: test-specific-db | |
17:31 | Partially broken implementation of steps data move to testrundat check-in: baf93f49cf user: mrwellan tags: test-specific-db | |
2012-09-14
| ||
14:18 | Brought up to date with latest from trunk check-in: 191987e384 user: mrwellan tags: test-specific-db | |
14:17 | Merged in fix for symlink crash check-in: e6642c0f2d user: mrwellan tags: trunk | |
14:16 | Merged in v1.4403 changes to trunk check-in: e0a7e24c94 user: mrwellan tags: trunk | |
13:43 | Added check for symbolic link to creation logic check-in: 3c167a3ae4 user: mrwellan tags: v1.44 | |
Modified common.scm from [7138a29341] to [9ce875d3de].
︙ | ︙ | |||
26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 | (define getenv get-environment-variable) (define home (getenv "HOME")) (define user (getenv "USER")) ;; global gletches (define *configinfo* #f) (define *configdat* #f) (define *toppath* #f) (define *already-seen-runconfig-info* #f) (define *waiting-queue* (make-hash-table)) (define *test-meta-updated* (make-hash-table)) (define *globalexitstatus* 0) ;; attempt to work around possible thread issues (define *passnum* 0) ;; when running track calls to run-tests or similar (define *verbosity* 1) (define *rpc:listener* #f) ;; if set up for server communication this will hold the tcp port (define *runremote* #f) ;; if set up for server communication this will hold <host port> (define *last-db-access* 0) ;; update when db is accessed via server | > | > > > | 26 27 28 29 30 31 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 | (define getenv get-environment-variable) (define home (getenv "HOME")) (define user (getenv "USER")) ;; global gletches (define *db-keys* #f) (define *configinfo* #f) (define *configdat* #f) (define *toppath* #f) (define *already-seen-runconfig-info* #f) (define *waiting-queue* (make-hash-table)) (define *test-meta-updated* (make-hash-table)) (define *globalexitstatus* 0) ;; attempt to work around possible thread issues (define *passnum* 0) ;; when running track calls to run-tests or similar (define *verbosity* 1) (define *rpc:listener* #f) ;; if set up for server communication this will hold the tcp port (define *runremote* #f) ;; if set up for server communication this will hold <host port> (define *last-db-access* 0) ;; update when db is accessed via server (define *target* (make-hash-table)) ;; cache the target here; target is keyval1/keyval2/.../keyvalN (define *keys* (make-hash-table)) ;; cache the keys here (define *keyvals* (make-hash-table)) (define *toptest-paths* (make-hash-table)) ;; cache toptest path settings here (define *test-paths* (make-hash-table)) ;; cache test-id to test run paths here (define *run-info-cache* (make-hash-table)) ;; run info is stable, no need to reget (define (get-with-default val default) (let ((val (args:get-arg val))) (if val val default))) (define (assoc/default key lst . default) |
︙ | ︙ |
Modified db.scm from [c61472a5e1] to [0c68fc0a7e].
︙ | ︙ | |||
153 154 155 156 157 158 159 160 161 162 163 164 165 166 | status TEXT DEFAULT 'n/a', type TEXT DEFAULT '', CONSTRAINT test_data_constraint UNIQUE (test_id,category,variable));") ;; Must do this *after* running patch db !! No more. (db:set-var db "MEGATEST_VERSION" megatest-version) )) ;;====================================================================== ;; TODO: ;; put deltas into an assoc list with version numbers ;; apply all from last to current ;;====================================================================== (define (patch-db db) (handle-exceptions | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 | status TEXT DEFAULT 'n/a', type TEXT DEFAULT '', CONSTRAINT test_data_constraint UNIQUE (test_id,category,variable));") ;; Must do this *after* running patch db !! No more. (db:set-var db "MEGATEST_VERSION" megatest-version) )) ;; Create the sqlite db for the individual test(s) (define (open-test-db testpath) (let* ((dbpath (conc testpath "/testdat.db")) (dbexists (file-exists? dbpath)) (db (sqlite3:open-database dbpath)) ;; (never-give-up-open-db dbpath)) (handler (make-busy-timeout (if (args:get-arg "-override-timeout") (string->number (args:get-arg "-override-timeout")) 36000)))) (debug:print 4 "INFO: test dbpath=" dbpath) (sqlite3:set-busy-handler! db handler) (if (not dbexists) (begin (sqlite3:execute db "PRAGMA synchronous = FULL;") (debug:print 0 "Initialized test database " dbpath) (db:testdb-initialize db))) (sqlite3:execute db "PRAGMA synchronous = 0;") db)) ;; find and open the testdat.db file for an existing test (define (db:open-test-db-by-test-id db test-id) (let* ((test-path (db:test-get-rundir db test-id))) (open-test-db test-path))) (define (db:testdb-initialize db) (for-each (lambda (sqlcmd) (sqlite3:execute db sqlcmd)) (list "CREATE TABLE IF NOT EXISTS test_rundat ( id INTEGER PRIMARY KEY, update_time TIMESTAMP, cpuload INTEGER DEFAULT -1, diskfree INTEGER DEFAULT -1, diskusage INTGER DEFAULT -1);" "CREATE TABLE IF NOT EXISTS test_data ( id INTEGER PRIMARY KEY, test_id INTEGER, category TEXT DEFAULT '', variable TEXT, value REAL, expected REAL, tol REAL, units TEXT, comment TEXT DEFAULT '', status TEXT DEFAULT 'n/a', type TEXT DEFAULT '', CONSTRAINT test_data_constraint UNIQUE (test_id,category,variable));" "CREATE TABLE IF NOT EXISTS test_steps ( id INTEGER PRIMARY KEY, test_id INTEGER, stepname TEXT, state TEXT DEFAULT 'NOT_STARTED', status TEXT DEFAULT 'n/a', event_time TIMESTAMP, comment TEXT DEFAULT '', logfile TEXT DEFAULT '', CONSTRAINT test_steps_constraint UNIQUE (test_id,stepname,state));" ;; test_meta can be used for handing commands to the test ;; e.g. KILLREQ ;; the ackstate is set to 1 once the command has been completed "CREATE TABLE IF NOT EXISTS test_meta ( id INTEGER PRIMARY KEY, var TEXT, val TEXT, ackstate INTEGER DEFAULT 0, CONSTRAINT metadat_constraint UNIQUE (var));"))) ;;====================================================================== ;; TODO: ;; put deltas into an assoc list with version numbers ;; apply all from last to current ;;====================================================================== (define (patch-db db) (handle-exceptions |
︙ | ︙ | |||
260 261 262 263 264 265 266 | (define (db:set-var db var val) (sqlite3:execute db "INSERT OR REPLACE INTO metadat (var,val) VALUES (?,?);" var val)) ;; use a global for some primitive caching, it is just silly to re-read the db ;; over and over again for the keys since they never change | < < | 326 327 328 329 330 331 332 333 334 335 336 337 338 339 | (define (db:set-var db var val) (sqlite3:execute db "INSERT OR REPLACE INTO metadat (var,val) VALUES (?,?);" var val)) ;; use a global for some primitive caching, it is just silly to re-read the db ;; over and over again for the keys since they never change (define (db:get-keys db) (if *db-keys* *db-keys* (let ((res '())) (sqlite3:for-each-row (lambda (key keytype) (set! res (cons (vector key keytype) res))) db |
︙ | ︙ | |||
422 423 424 425 426 427 428 | (set! res (cons (list (key:get-fieldname key) key-val) res))) db qry run-id))) keys) (reverse res))) ;; get key vals for a given run-id (define (db:get-key-vals db run-id) | > > > | | | | | | | | | | | | | > > > | | | | | | | 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 | (set! res (cons (list (key:get-fieldname key) key-val) res))) db qry run-id))) keys) (reverse res))) ;; get key vals for a given run-id (define (db:get-key-vals db run-id) (let ((mykeyvals (hash-table-ref/default *keyvals* run-id #f))) (if mykeyvals mykeyvals (let* ((keys (get-keys db)) (res '())) (debug:print 6 "keys: " keys " run-id: " run-id) (for-each (lambda (key) (let ((qry (conc "SELECT " (key:get-fieldname key) " FROM runs WHERE id=?;"))) ;; (debug:print 0 "qry: " qry) (sqlite3:for-each-row (lambda (key-val) (set! res (cons key-val res))) db qry run-id))) keys) (let ((final-res (reverse res))) (hash-table-set! *keyvals* run-id final-res) final-res))))) ;; The target is keyval1/keyval2..., cached in *target* as it is used often (define (db:get-target db run-id) (let ((mytarg (hash-table-ref/default *target* run-id #f))) (if mytarg mytarg (let* ((keyvals (db:get-key-vals db run-id)) ;; (rdb:get-key-vals db run-id)) (thekey (string-intersperse (map (lambda (x)(if x x "-na-")) keyvals) "/"))) (hash-table-set! *target* run-id thekey) thekey)))) ;;====================================================================== ;; T E S T S ;;====================================================================== ;; states and statuses are lists, turn them into ("PASS","FAIL"...) and use NOT IN ;; i.e. these lists define what to NOT show. |
︙ | ︙ | |||
489 490 491 492 493 494 495 | run-id ;; (if testpatt testpatt "%") ;; (if itempatt itempatt "%")) ) res)) ;; this one is a bit broken BUG FIXME | | | < < < < < < | < | < | < | | 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 | run-id ;; (if testpatt testpatt "%") ;; (if itempatt itempatt "%")) ) res)) ;; this one is a bit broken BUG FIXME (define (db:delete-test-step-records db test-id) ;; Breaking it into two queries for better file access interleaving (let* ((tdb (db:open-test-db-by-test-id db test-id))) (sqlite3:execute tdb "DELETE FROM test_steps;") (sqlite3:execute tdb "DELETE FROM test_data;") (sqlite3:finalize! tdb))) ;; (define (db:delete-test-records db test-id) (sqlite3:execute db "DELETE FROM test_steps WHERE test_id=?;" test-id) (sqlite3:execute db "DELETE FROM test_data WHERE test_id=?;" test-id) (sqlite3:execute db "DELETE FROM tests WHERE id=?;" test-id)) ;; set tests with state currstate and status currstatus to newstate and newstatus |
︙ | ︙ | |||
609 610 611 612 613 614 615 616 617 618 619 620 621 622 | ;; (define (db:test-set-rundir! db run-id test-name item-path rundir) (sqlite3:execute db "UPDATE tests SET rundir=? WHERE run_id=? AND testname=? AND item_path=?;" rundir run-id test-name item-path)) (define (db:test-set-log! db test-id logf) (if (string? logf) (sqlite3:execute db "UPDATE tests SET final_logf=? WHERE id=?;" logf test-id) (debug:print 0 "ERROR: db:test-set-log! called with non-string log file name " logf))) ;;====================================================================== | > > > > > > > > > > > > > > > | 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 | ;; (define (db:test-set-rundir! db run-id test-name item-path rundir) (sqlite3:execute db "UPDATE tests SET rundir=? WHERE run_id=? AND testname=? AND item_path=?;" rundir run-id test-name item-path)) ;; (define (db:test-get-rundir db test-id) (let ((res (hash-table-ref/default *test-paths* test-id #f))) (if res res (begin (sqlite3:for-each-row (lambda (tpath) (set! res tpath)) db "SELECT rundir FROM tests WHERE id=?;" test-id) (hash-table-set! *test-paths* test-id res) res)))) (define (db:test-set-log! db test-id logf) (if (string? logf) (sqlite3:execute db "UPDATE tests SET final_logf=? WHERE id=?;" logf test-id) (debug:print 0 "ERROR: db:test-set-log! called with non-string log file name " logf))) ;;====================================================================== |
︙ | ︙ | |||
723 724 725 726 727 728 729 | qrystr) res)) ;;====================================================================== ;; QUEUE UP META, TEST STATUS AND STEPS ;;====================================================================== | | | | | | | | | | | | | | | | | | | | > | | | | | | | | | | | | | | | | | | | | | | | | 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 | qrystr) res)) ;;====================================================================== ;; QUEUE UP META, TEST STATUS AND STEPS ;;====================================================================== ;; (define (db:updater db) ;; (let loop ((start-time (current-time))) ;; (thread-sleep! 0.5) ;; move save time around to minimize regular collisions? ;; (db:write-cached-data db) ;; (loop start-time))) ;; ;; (define (db:test-update-meta-info db test-id minutes cpuload diskfree tmpfree) ;; (mutex-lock! *incoming-mutex*) ;; (set! *incoming-data* (cons (vector 'meta-info ;; (current-seconds) ;; (list cpuload ;; diskfree ;; minutes ;; test-id)) ;; run-id test-name item-path minutes cpuload diskfree tmpfree) ;; *incoming-data*)) ;; (mutex-unlock! *incoming-mutex*) ;; (if *cache-on* ;; (debug:print 6 "INFO: *cache-on* is " *cache-on* ", skipping cache write as part of test-update-meta-info") ;; (db:write-cached-data db))) ;; ;; ==> (define (db:write-cached-data db) ;; ==> (let ((meta-stmt (sqlite3:prepare db "UPDATE tests SET cpuload=?,diskfree=?,run_duration=?,state='RUNNING' WHERE id=? AND state NOT IN ('COMPLETED','KILLREQ','KILLED');")) ;; ==> (step-stmt (sqlite3:prepare db "INSERT OR REPLACE into test_steps (test_id,stepname,state,status,event_time,comment,logfile) VALUES(?,?,?,?,?,?,?);")) ;; strftime('%s','now')#f) ;; ==> (data (sort *incoming-data* (lambda (a b)(< (vector-ref a 1)(vector-ref b 1)))))) ;; ==> (if (> (length data) 0) ;; ==> (debug:print 4 "Writing cached data " data)) ;; ==> (mutex-lock! *incoming-mutex*) ;; ==> (sqlite3:with-transaction ;; ==> db ;; ==> (lambda () ;; ==> (for-each (lambda (entry) ;; ==> (case (vector-ref entry 0) ;; ==> ((meta-info) ;; ==> (apply sqlite3:execute meta-stmt (vector-ref entry 2))) ;; ==> ((step-status) ;; ==> (apply sqlite3:execute step-stmt (vector-ref entry 2))) ;; ==> (else ;; ==> (debug:print 0 "ERROR: Queued entry not recognised " entry)))) ;; ==> data))) ;; ==> (sqlite3:finalize! meta-stmt) ;; sqlite is the bottleneck, clear the statements asap? ;; ==> (sqlite3:finalize! step-stmt) ;; ==> (set! *incoming-data* '()) ;; ==> (mutex-unlock! *incoming-mutex*))) (define (db:roll-up-pass-fail-counts db run-id test-name item-path status) (if (and (not (equal? item-path "")) (or (equal? status "PASS") (equal? status "WARN") (equal? status "FAIL") (equal? status "WAIVED") |
︙ | ︙ | |||
942 943 944 945 946 947 948 | ;;====================================================================== (define (db:step-get-time-as-string vec) (seconds->time-string (db:step-get-event_time vec))) ;; db-get-test-steps-for-run (define (db:get-steps-for-test db test-id) | > | | > | 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 | ;;====================================================================== (define (db:step-get-time-as-string vec) (seconds->time-string (db:step-get-event_time vec))) ;; db-get-test-steps-for-run (define (db:get-steps-for-test db test-id) (let* ((tdb (db:open-test-db-by-test-id db test-id)) (res '())) (sqlite3:for-each-row (lambda (id test-id stepname state status event-time logfile) (set! res (cons (vector id test-id stepname state status event-time (if (string? logfile) logfile "")) res))) tdb "SELECT id,test_id,stepname,state,status,event_time,logfile FROM test_steps WHERE test_id=? ORDER BY id ASC;" ;; event_time DESC,id ASC; test-id) (sqlite3:finalize! tdb) (reverse res))) ;; get a pretty table to summarize steps ;; (define (db:get-steps-table db test-id) (let ((steps (db:get-steps-for-test db test-id))) ;; organise the steps for better readability |
︙ | ︙ | |||
1065 1066 1067 1068 1069 1070 1071 | (if (not ever-seen) (set! result (append (if (null? tests)(list waitontest-name) tests) result))))) waitons) (delete-duplicates result)))) (define (db:teststep-set-status! db test-id teststep-name state-in status-in item-path comment logfile) (debug:print 4 "test-id: " test-id " teststep-name: " teststep-name) | > | | < | < > | < < < | | 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 | (if (not ever-seen) (set! result (append (if (null? tests)(list waitontest-name) tests) result))))) waitons) (delete-duplicates result)))) (define (db:teststep-set-status! db test-id teststep-name state-in status-in item-path comment logfile) (debug:print 4 "test-id: " test-id " teststep-name: " teststep-name) (let* ((tdb (db:open-test-db-by-test-id db test-id)) (state (check-valid-items "state" state-in)) (status (check-valid-items "status" status-in))) (if (or (not state)(not status)) (debug:print 0 "WARNING: Invalid " (if status "status" "state") " value \"" (if status state-in status-in) "\", update your validvalues section in megatest.config")) (sqlite3:execute tdb "INSERT OR REPLACE into test_steps (test_id,stepname,state,status,event_time,comment,logfile) VALUES(?,?,?,?,?,?,?);" test-id teststep-name state-in status-in (current-seconds) (if comment comment "") (if logfile logfile ""))) #t) ;;====================================================================== ;; Extract ods file from the db ;;====================================================================== ;; runspatt is a comma delimited list of run patterns ;; keypatt-alist must contain *all* keys with an associated pattern: '( ("KEY1" "%") .. ) |
︙ | ︙ |
Added docs/plan.txt version [b6f3c7c220].
> > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 | Move test specific db to test dir ================================= . Create teststats.db . Redirect test run stats to teststats.db . Redirect test steps data to teststats.db . Redirect test_data to teststats.db . Direct dboard to get stats from teststats.db . Redirect kill requests to teststats.db . Kill requests need to kill all processes in the tree . Roll up overall stats to megatest.db every five minutes or when test done . Add any necessary tests |
Modified launch.scm from [228baa4ee9] to [90fc495cd2].
︙ | ︙ | |||
62 63 64 65 66 67 68 69 70 71 72 73 74 75 | (env-ovrd (assoc/default 'env-ovrd cmdinfo)) (set-vars (assoc/default 'set-vars cmdinfo)) ;; pre-overrides from -setvar (runname (assoc/default 'runname cmdinfo)) (megatest (assoc/default 'megatest cmdinfo)) (mt-bindir-path (assoc/default 'mt-bindir-path cmdinfo)) (fullrunscript (if runscript (conc testpath "/" runscript) #f)) (db #f) (rollup-status 0)) (debug:print 2 "Exectuing " test-name " (id: " test-id ") on " (get-host-name)) ;; apply pre-overrides before other variables. The pre-override vars must not ;; clobbers things from the official sources such as megatest.config and runconfigs.config (if (string? set-vars) (let ((varpairs (string-split set-vars ","))) | > | 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 | (env-ovrd (assoc/default 'env-ovrd cmdinfo)) (set-vars (assoc/default 'set-vars cmdinfo)) ;; pre-overrides from -setvar (runname (assoc/default 'runname cmdinfo)) (megatest (assoc/default 'megatest cmdinfo)) (mt-bindir-path (assoc/default 'mt-bindir-path cmdinfo)) (fullrunscript (if runscript (conc testpath "/" runscript) #f)) (db #f) (tdb #f) (rollup-status 0)) (debug:print 2 "Exectuing " test-name " (id: " test-id ") on " (get-host-name)) ;; apply pre-overrides before other variables. The pre-override vars must not ;; clobbers things from the official sources such as megatest.config and runconfigs.config (if (string? set-vars) (let ((varpairs (string-split set-vars ","))) |
︙ | ︙ | |||
89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 | (setenv "MT_MEGATEST" megatest) (setenv "MT_TARGET" target) (if mt-bindir-path (setenv "PATH" (conc (getenv "PATH") ":" mt-bindir-path))) (change-directory top-path) (if (not (setup-for-run)) (begin (debug:print 0 "Failed to setup, exiting") (exit 1))) (change-directory *toppath*) ;; now can find our db (set! db (open-db)) (if (not (args:get-arg "-server")) (server:client-setup db)) ;; (set! *cache-on* #t) (set-megatest-env-vars db run-id) ;; these may be needed by the launching process (change-directory work-area) (set-run-config-vars db run-id) ;; environment overrides are done *before* the remaining critical envars. (alist->env-vars env-ovrd) (set-megatest-env-vars db run-id) (set-item-env-vars itemdat) (save-environment-as-files "megatest") | > > > > > > > > > > | < < < < < | 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 | (setenv "MT_MEGATEST" megatest) (setenv "MT_TARGET" target) (if mt-bindir-path (setenv "PATH" (conc (getenv "PATH") ":" mt-bindir-path))) (change-directory top-path) (if (not (setup-for-run)) (begin (debug:print 0 "Failed to setup, exiting") ;; (sqlite3:finalize! db) ;; (sqlite3:finalize! tdb) (exit 1))) (change-directory *toppath*) ;; now can find our db (set! db (open-db)) (if (not (args:get-arg "-server")) (server:client-setup db)) ;; (set! *cache-on* #t) (set-megatest-env-vars db run-id) ;; these may be needed by the launching process (change-directory work-area) ;; Open up the test specific database (set! tdb (open-test-db work-area)) (on-exit (lambda () (debug:print 0 "Finalizing both tdb and db!!!") (sqlite3:finalize! tdb) (sqlite3:finalize! db))) (set-run-config-vars db run-id) ;; environment overrides are done *before* the remaining critical envars. (alist->env-vars env-ovrd) (set-megatest-env-vars db run-id) (set-item-env-vars itemdat) (save-environment-as-files "megatest") (test-set-meta-info db tdb run-id test-name itemdat) (test-set-status! db test-id "REMOTEHOSTSTART" "n/a" (args:get-arg "-m") #f) (if (args:get-arg "-xterm") (set! fullrunscript "xterm") (if (and fullrunscript (not (file-execute-access? fullrunscript))) (system (conc "chmod ug+x " fullrunscript)))) ;; We are about to actually kick off the test ;; so this is a good place to remove the records for ;; any previous runs ;; (db:test-remove-steps db run-id testname itemdat) (let* ((m (make-mutex)) (kill-job? #f) (exit-info (vector #t #t #t)) (job-thread #f) (runit (lambda () ;; (let-values ;; (((pid exit-status exit-code) |
︙ | ︙ | |||
252 253 254 255 256 257 258 | (inexact->exact (round (- (current-seconds) start-seconds))))) (kill-tries 0)) (let loop ((minutes (calc-minutes))) | | | | | > | | | | > | | 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 | (inexact->exact (round (- (current-seconds) start-seconds))))) (kill-tries 0)) (let loop ((minutes (calc-minutes))) ;; (let* (;; (db (open-db)) ;; (cpuload (get-cpu-load)) ;; (diskfree (get-df (current-directory))) ;; (tmpfree (get-df "/tmp"))) (begin ;; (if (not (args:get-arg "-server")) ;; (server:client-setup db)) ;; (if (not cpuload) (begin (debug:print 0 "WARNING: CPULOAD not found.") (set! cpuload "n/a"))) ;; (if (not diskfree) (begin (debug:print 0 "WARNING: DISKFREE not found.") (set! diskfree "n/a"))) (set! kill-job? (test-get-kill-request db run-id test-name itemdat)) (test-set-meta-info db tdb run-id test-name itemdat minutes: minutes) ;; (rdb:test-update-meta-info db test-id minutes cpuload diskfree tmpfree) (if kill-job? (begin (mutex-lock! m) (let* ((pid (vector-ref exit-info 0))) (if (number? pid) (begin (debug:print 0 "WARNING: Request received to kill job (attempt # " kill-tries ")") |
︙ | ︙ | |||
287 288 289 290 291 292 293 294 295 296 | (car processes)) (system (conc "kill -9 " pid)))) (begin (debug:print 0 "WARNING: Request received to kill job but problem with process, attempting to kill manager process") (test-set-status! db test-id "KILLED" "FAIL" (args:get-arg "-m") #f) (sqlite3:finalize! db) (exit 1)))) (set! kill-tries (+ 1 kill-tries)) (mutex-unlock! m))) | > | | | | | 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 | (car processes)) (system (conc "kill -9 " pid)))) (begin (debug:print 0 "WARNING: Request received to kill job but problem with process, attempting to kill manager process") (test-set-status! db test-id "KILLED" "FAIL" (args:get-arg "-m") #f) (sqlite3:finalize! db) (sqlite3:finalize! tdb) (exit 1)))) (set! kill-tries (+ 1 kill-tries)) (mutex-unlock! m))) ;; (sqlite3:finalize! db) (thread-sleep! (+ 10 (random 10))) ;; add some jitter to the call home time to spread out the db accesses (loop (calc-minutes))))))) (th1 (make-thread monitorjob)) (th2 (make-thread runit))) (set! job-thread th2) (thread-start! th1) (thread-start! th2) (thread-join! th2) (mutex-lock! m) ;; (set! db (open-db)) ;; (if (not (args:get-arg "-server")) ;; (server:client-setup db)) (let* ((item-path (item-list->path itemdat)) (testinfo (rdb:get-test-info db run-id test-name item-path))) (if (not (equal? (db:test-get-state testinfo) "COMPLETED")) (begin (debug:print 2 "Test NOT logged as COMPLETED, (state=" (db:test-get-state testinfo) "), updating result, rollup-status is " rollup-status) (test-set-status! db test-id (if kill-job? "KILLED" "COMPLETED") |
︙ | ︙ | |||
339 340 341 342 343 344 345 346 347 348 349 350 351 352 | ) (mutex-unlock! m) ;; (exec-results (cmd-run->list fullrunscript)) ;; (list ">" (conc test-name "-run.log")))) ;; (success exec-results)) ;; (eq? (cadr exec-results) 0))) (debug:print 2 "Output from running " fullrunscript ", pid " (vector-ref exit-info 0) " in work area " work-area ":\n====\n exit code " (vector-ref exit-info 2) "\n" "====\n") (sqlite3:finalize! db) (if (not (vector-ref exit-info 1)) (exit 4))))))) ;; set up the very basics needed for doing anything here. (define (setup-for-run) ;; would set values for KEYS in the environment here for better support of env-override but ;; have chicken/egg scenario. need to read megatest.config then read it again. Going to | > | 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 | ) (mutex-unlock! m) ;; (exec-results (cmd-run->list fullrunscript)) ;; (list ">" (conc test-name "-run.log")))) ;; (success exec-results)) ;; (eq? (cadr exec-results) 0))) (debug:print 2 "Output from running " fullrunscript ", pid " (vector-ref exit-info 0) " in work area " work-area ":\n====\n exit code " (vector-ref exit-info 2) "\n" "====\n") (sqlite3:finalize! db) (sqlite3:finalize! tdb) (if (not (vector-ref exit-info 1)) (exit 4))))))) ;; set up the very basics needed for doing anything here. (define (setup-for-run) ;; would set values for KEYS in the environment here for better support of env-override but ;; have chicken/egg scenario. need to read megatest.config then read it again. Going to |
︙ | ︙ | |||
585 586 587 588 589 590 591 | (list 'ezsteps ezsteps) (list 'target mt_target) (list 'env-ovrd (hash-table-ref/default *configdat* "env-override" '())) (list 'set-vars (if params (hash-table-ref/default params "-setvars" #f))) (list 'runname runname) (list 'mt-bindir-path mt-bindir-path))))))) ;; (string-intersperse keyvallst " ")))) ;; clean out step records from previous run if they exist | | | 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 | (list 'ezsteps ezsteps) (list 'target mt_target) (list 'env-ovrd (hash-table-ref/default *configdat* "env-override" '())) (list 'set-vars (if params (hash-table-ref/default params "-setvars" #f))) (list 'runname runname) (list 'mt-bindir-path mt-bindir-path))))))) ;; (string-intersperse keyvallst " ")))) ;; clean out step records from previous run if they exist (db:delete-test-step-records db test-id) (change-directory work-area) ;; so that log files from the launch process don't clutter the test dir (cond ((and launcher hosts) ;; must be using ssh hostname (set! fullcmd (append launcher (car hosts)(list remote-megatest test-sig "-execute" cmdparms) debug-param))) ;; (set! fullcmd (append launcher (car hosts)(list remote-megatest test-sig "-execute" cmdparms)))) (launcher (set! fullcmd (append launcher (list remote-megatest test-sig "-execute" cmdparms) debug-param))) |
︙ | ︙ |
Modified runs.scm from [25e65a825b] to [ec5f4d2861].
︙ | ︙ | |||
309 310 311 312 313 314 315 | (filter (lambda (t) (or (not (vector? t)) (not (equal? "COMPLETED" (db:test-get-state t))))) prereqs-not-met))) (pretty-string (lambda (lst) (map (lambda (t) | | | | 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 | (filter (lambda (t) (or (not (vector? t)) (not (equal? "COMPLETED" (db:test-get-state t))))) prereqs-not-met))) (pretty-string (lambda (lst) (map (lambda (t) (if (not (vector? t)) (conc t) (conc (db:test-get-testname t) ":" (db:test-get-state t) "/" (db:test-get-status t)))) lst)))) (debug:print 6 "itemdat: " itemdat "\n items: " items "\n item-path: " item-path "\n waitons: " waitons) |
︙ | ︙ | |||
335 336 337 338 339 340 341 | (let* ((have-resources (runs:can-run-more-tests db test-record)) ;; look at the test jobgroup and tot jobs running (prereqs-not-met (db:get-prereqs-not-met db run-id waitons item-path mode: testmode)) (fails (calc-fails prereqs-not-met)) (non-completed (calc-not-completed prereqs-not-met))) (debug:print 8 "INFO: have-resources: " have-resources " prereqs-not-met: " (string-intersperse (map (lambda (t) | > > | | 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 | (let* ((have-resources (runs:can-run-more-tests db test-record)) ;; look at the test jobgroup and tot jobs running (prereqs-not-met (db:get-prereqs-not-met db run-id waitons item-path mode: testmode)) (fails (calc-fails prereqs-not-met)) (non-completed (calc-not-completed prereqs-not-met))) (debug:print 8 "INFO: have-resources: " have-resources " prereqs-not-met: " (string-intersperse (map (lambda (t) (if (not (vector? t)) (conc " WARNING: t is not a vector=" t ) (conc (db:test-get-state t) "/" (db:test-get-status t)))) prereqs-not-met) ", ") " fails: " fails) ;; Don't know at this time if the test have been launched at some time in the past ;; i.e. is this a re-launch? (cond ((and have-resources (or (null? prereqs-not-met) (and (eq? testmode 'toplevel) |
︙ | ︙ |
Modified tests.scm from [ce4320f87b] to [e990011da7].
︙ | ︙ | |||
399 400 401 402 403 404 405 | ;; teststep-set-status! used to be here (define (test-get-kill-request db run-id test-name itemdat) (let* ((item-path (item-list->path itemdat)) (testdat (db:get-test-info db run-id test-name item-path))) (equal? (test:get-state testdat) "KILLREQ"))) | > > > > > > > > > | > | | < | < > > | < | | < | | | > > > > > > > > > > | 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 | ;; teststep-set-status! used to be here (define (test-get-kill-request db run-id test-name itemdat) (let* ((item-path (item-list->path itemdat)) (testdat (db:get-test-info db run-id test-name item-path))) (equal? (test:get-state testdat) "KILLREQ"))) (define (test:tdb-get-rundat-count tdb) (let ((res 0)) (sqlite3:for-each-row (lambda (count) (set! res count)) tdb "SELECT count(id) FROM test_rundat;") res)) (define (test-set-meta-info db tdb run-id testname itemdat #!key (minutes #f)) (let* ((num-records (test:tdb-get-rundat-count tdb)) (item-path (item-list->path itemdat)) (cpuload (get-cpu-load)) (diskfree (get-df (current-directory)))) (if (eq? (modulo num-records 10) 0) ;; every ten records update central (begin (sqlite3:execute db "UPDATE tests SET cpuload=?,diskfree=? WHERE run_id=? AND testname=? AND item_path=?;" cpuload diskfree run-id testname item-path) (if (eq? num-records 0) (begin (sqlite3:execute db "UPDATE tests SET uname=?,host=? WHERE run_id=? AND testname=? AND item_path=?;" (get-uname "-srvpio") (get-host-name) run-id testname item-path) (if minutes (sqlite3:execute db "UPDATE tests SET minutes=? WHERE run_id=? AND testname=? AND item_path=?;" minutes run-id testname item-path)))))) (sqlite3:execute tdb "INSERT INTO test_rundat (cpuload,diskfree) VALUES (?,?);" cpuload diskfree))) ;;====================================================================== ;; A R C H I V I N G ;;====================================================================== (define (test:archive db test-id) #f) |
︙ | ︙ |