Comment: | Merged dev into refactor-api. Note that this branch has some remaining issues due to not all calls migrated to api. some remaining calls are broken |
---|---|
Downloads: | Tarball | ZIP archive | SQL archive |
Timelines: | family | ancestors | descendants | both | refactor-api |
Files: | files | file ages | folders |
SHA1: |
1f8d02d299331ebbd6a526aa6708e3b4 |
User & Date: | matt on 2013-08-17 16:51:49 |
Original Comment: | Merged dev into refactor-api but this merge appears to have broken something |
Other Links: | branch diff | manifest | tags |
2013-10-19
| ||
10:36 | Merged refactor-api into refactor-db check-in: 45b4ad07c1 user: matt tags: refactor-db | |
2013-08-17
| ||
16:51 | Merged dev into refactor-api. Note that this branch has some remaining issues due to not all calls migrated to api. some remaining calls are broken Closed-Leaf check-in: 1f8d02d299 user: matt tags: refactor-api | |
16:36 | Merged work done to v1.55 to dev check-in: 7a867d557f user: matt tags: dev | |
2013-08-06
| ||
23:55 | Brought recent changes back into the api refactor branch so work can continue on new api check-in: 4692ce2dad user: matt tags: refactor-api | |
Modified Makefile from [4f76357eec] to [431aa13af1].
1 2 3 4 5 6 7 8 9 10 | # make install CSCOPTS='-accumulate-profile -profile-name $(PWD)/profile-ww$(shell date +%V.%u)' PREFIX=$(PWD) CSCOPTS= INSTALL=install SRCFILES = common.scm items.scm launch.scm \ ods.scm runconfig.scm server.scm configf.scm \ db.scm keys.scm margs.scm megatest-version.scm \ process.scm runs.scm tasks.scm tests.scm genexample.scm \ fs-transport.scm http-transport.scm \ client.scm gutils.scm synchash.scm daemon.scm mt.scm dcommon.scm \ | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | # make install CSCOPTS='-accumulate-profile -profile-name $(PWD)/profile-ww$(shell date +%V.%u)' PREFIX=$(PWD) CSCOPTS= INSTALL=install SRCFILES = common.scm items.scm launch.scm \ ods.scm runconfig.scm server.scm configf.scm \ db.scm keys.scm margs.scm megatest-version.scm \ process.scm runs.scm tasks.scm tests.scm genexample.scm \ fs-transport.scm http-transport.scm \ client.scm gutils.scm synchash.scm daemon.scm mt.scm dcommon.scm \ tree.scm rmt.scm api.scm tdb.scm \ ezsteps.scm lock-queue.scm GUISRCF = dashboard-tests.scm dashboard-guimonitor.scm OFILES = $(SRCFILES:%.scm=%.o) GOFILES = $(GUISRCF:%.scm=%.o) ADTLSCR=mt_laststep mt_runstep mt_ezstep |
︙ | ︙ |
Modified dashboard-tests.scm from [77639fe07b] to [a2d2a6daf3].
︙ | ︙ | |||
385 386 387 388 389 390 391 | (db-path (conc *toppath* "/megatest.db")) (db-mod-time 0) ;; (file-modification-time db-path)) (last-update 0) ;; (current-seconds)) (request-update #t) (db #f)) (if (not testdat) (begin | | | 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 | (db-path (conc *toppath* "/megatest.db")) (db-mod-time 0) ;; (file-modification-time db-path)) (last-update 0) ;; (current-seconds)) (request-update #t) (db #f)) (if (not testdat) (begin (debug:print 2 "ERROR: No test data found for test " test-id ", exiting") (exit 1)) (let* ((run-id (if testdat (db:test-get-run_id testdat) #f)) (keydat (if testdat (rmt:get-key-val-pairs run-id) #f)) (rundat (if testdat (rmt:get-run-info run-id) #f)) (runname (if testdat (db:get-value-by-header (db:get-row rundat) (db:get-header rundat) "runname") #f)) |
︙ | ︙ |
Modified db.scm from [9048766a2d] to [af72ef9ec3].
︙ | ︙ | |||
358 359 360 361 362 363 364 | (begin (sqlite3:execute db "CREATE TABLE IF NOT EXISTS log (id INTEGER PRIMARY KEY,event_time TIMESTAMP DEFAULT (strftime('%s','now')),logline TEXT,pwd TEXT,cmdline TEXT,pid INTEGER);") (sqlite3:execute db (conc "PRAGMA synchronous = 0;")))) db)) (define (db:log-local-event . loglst) (let ((logline (apply conc loglst))) | | | | | 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 | (begin (sqlite3:execute db "CREATE TABLE IF NOT EXISTS log (id INTEGER PRIMARY KEY,event_time TIMESTAMP DEFAULT (strftime('%s','now')),logline TEXT,pwd TEXT,cmdline TEXT,pid INTEGER);") (sqlite3:execute db (conc "PRAGMA synchronous = 0;")))) db)) (define (db:log-local-event . loglst) (let ((logline (apply conc loglst))) ;; (pwd (current-directory)) ;; (cmdline (string-intersperse (argv) " ")) ;; (pid (current-process-id))) (db:log-event logline))) (define (db:log-event logline) (let ((db (open-logging-db))) (sqlite3:execute db "INSERT INTO log (logline,pwd,cmdline,pid) VALUES (?,?,?,?);" logline (current-directory) |
︙ | ︙ | |||
501 502 503 504 505 506 507 | (debug:print-info 0 "Records count after clean: " tot)) count-stmt))) (map sqlite3:finalize! statements) (sqlite3:finalize! count-stmt) (sqlite3:execute db "VACUUM;"))) ;; (define (db:report-junk-records db) | | | 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 | (debug:print-info 0 "Records count after clean: " tot)) count-stmt))) (map sqlite3:finalize! statements) (sqlite3:finalize! count-stmt) (sqlite3:execute db "VACUUM;"))) ;; (define (db:report-junk-records db) ;;====================================================================== ;; meta get and set vars ;;====================================================================== ;; returns number if string->number is successful, string otherwise ;; also updates *global-delta* |
︙ | ︙ | |||
636 637 638 639 640 641 642 | (debug:print 3 "keys: " keys " allvals: " allvals " keyvals: " keyvals " key=?str is " key=?str) (debug:print 2 "NOTE: using target " (string-intersperse (map cadr keyvals) "/") " for this run") (if (and runname (null? (filter (lambda (x)(not x)) keyvals))) ;; there must be a better way to "apply and" (let ((res #f)) (apply sqlite3:execute db (conc "INSERT OR IGNORE INTO runs (runname,state,status,owner,event_time" comma keystr ") VALUES (?,?,?,?,strftime('%s','now')" comma valslots ");") allvals) (apply sqlite3:for-each-row | | | | | | | | | 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 | (debug:print 3 "keys: " keys " allvals: " allvals " keyvals: " keyvals " key=?str is " key=?str) (debug:print 2 "NOTE: using target " (string-intersperse (map cadr keyvals) "/") " for this run") (if (and runname (null? (filter (lambda (x)(not x)) keyvals))) ;; there must be a better way to "apply and" (let ((res #f)) (apply sqlite3:execute db (conc "INSERT OR IGNORE INTO runs (runname,state,status,owner,event_time" comma keystr ") VALUES (?,?,?,?,strftime('%s','now')" comma valslots ");") allvals) (apply sqlite3:for-each-row (lambda (id) (set! res id)) db (let ((qry (conc "SELECT id FROM runs WHERE (runname=? " andstr key=?str ");"))) ;(debug:print 4 "qry: " qry) qry) qryvals) (sqlite3:execute db "UPDATE runs SET state=?,status=?,event_time=strftime('%s','now') WHERE id=?;" state status res) res) (begin (debug:print 0 "ERROR: Called without all necessary keys") #f)))) |
︙ | ︙ | |||
738 739 740 741 742 743 744 | (sqlite3:for-each-row (lambda (runname state count) (let* ((stateparts (string-split state "|")) (newstate (conc (car stateparts) "\n" (cadr stateparts)))) (hash-table-set! totals newstate (+ (hash-table-ref/default totals newstate 0) count)) (set! res (cons (list runname newstate count) res)))) db | | | 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 | (sqlite3:for-each-row (lambda (runname state count) (let* ((stateparts (string-split state "|")) (newstate (conc (car stateparts) "\n" (cadr stateparts)))) (hash-table-set! totals newstate (+ (hash-table-ref/default totals newstate 0) count)) (set! res (cons (list runname newstate count) res)))) db "SELECT runname,t.state||'|'||t.status AS s,count(t.id) FROM runs AS r INNER JOIN tests AS t ON r.id=t.run_id GROUP BY s,runname ORDER BY r.event_time,s DESC;" ) ;; (set! res (reverse res)) (for-each (lambda (state) (set! res (cons (list "Totals" state (hash-table-ref totals state)) res))) (sort (hash-table-keys totals) string>=)) res)) ;; db:get-runs-by-patt |
︙ | ︙ | |||
789 790 791 792 793 794 795 | runnamepatt) (vector header res))) ;; use (get-value-by-header (db:get-header runinfo)(db:get-row runinfo)) (define (db:get-run-info db run-id) ;;(if (hash-table-ref/default *run-info-cache* run-id #f) ;; (hash-table-ref *run-info-cache* run-id) | | | | | | | | | | | | | | | | | | | 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 | runnamepatt) (vector header res))) ;; use (get-value-by-header (db:get-header runinfo)(db:get-row runinfo)) (define (db:get-run-info db run-id) ;;(if (hash-table-ref/default *run-info-cache* run-id #f) ;; (hash-table-ref *run-info-cache* run-id) (let* ((res #f) (keys (db:get-keys db)) (remfields (list "id" "runname" "state" "status" "owner" "event_time")) (header (append keys remfields)) (keystr (conc (keys->keystr keys) "," (string-intersperse remfields ",")))) (debug:print-info 11 "db:get-run-info run-id: " run-id " header: " header " keystr: " keystr) (sqlite3:for-each-row (lambda (a . x) (set! res (apply vector a x))) db (conc "SELECT " keystr " FROM runs WHERE id=? AND state != 'deleted';") run-id) (debug:print-info 11 "db:get-run-info run-id: " run-id " header: " header " keystr: " keystr) (let ((finalres (vector header res))) ;; (hash-table-set! *run-info-cache* run-id finalres) finalres))) (define (db:set-comment-for-run db run-id comment) (debug:print-info 11 "db:set-comment-for-run START run-id: " run-id " comment: " comment) (sqlite3:execute db "UPDATE runs SET comment=? WHERE id=?;" comment run-id) (debug:print-info 11 "db:set-comment-for-run END run-id: " run-id " comment: " comment)) ;; does not (obviously!) removed dependent data. But why not!!? |
︙ | ︙ | |||
865 866 867 868 869 870 871 | db qry run-id))) keys) (debug:print-info 11 "db:get-key-val-pairs END keys: " keys " run-id: " run-id) (reverse res))) ;; get key vals for a given run-id (define (db:get-key-vals db run-id) | | | | | | | | | | | | | | | | | | 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 | db qry run-id))) keys) (debug:print-info 11 "db:get-key-val-pairs END keys: " keys " run-id: " run-id) (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 (db:get-keys db)) (res '())) (debug:print-info 11 "db:get-key-vals START keys: " keys " run-id: " run-id) (for-each (lambda (key) (let ((qry (conc "SELECT " 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) (debug:print-info 11 "db:get-key-vals END keys: " keys " run-id: " run-id) (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)) (thekey (string-intersperse (map (lambda (x)(if x x "-na-")) keyvals) "/"))) (hash-table-set! *target* run-id thekey) thekey)))) ;;====================================================================== ;; T E S T S ;;====================================================================== |
︙ | ︙ | |||
928 929 930 931 932 933 934 | (conc " status " (if not-in " NOT IN ('" " IN ('") (string-intersperse statuses "','") "')"))) (states-statuses-qry | | | | | | | | | | | 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 | (conc " status " (if not-in " NOT IN ('" " IN ('") (string-intersperse statuses "','") "')"))) (states-statuses-qry (cond ((and states-qry statuses-qry) (conc " AND ( " states-qry " AND " statuses-qry " ) ")) (states-qry (conc " AND " states-qry)) (statuses-qry (conc " AND " statuses-qry)) (else ""))) (tests-match-qry (tests:match->sqlqry testpatt)) (qry (conc "SELECT " qryvals " FROM tests WHERE run_id=? AND state != 'DELETED' " states-statuses-qry (if tests-match-qry (conc " AND (" tests-match-qry ") ") "") (case sort-by ((rundir) " ORDER BY length(rundir) DESC ") ((event_time) " ORDER BY event_time ASC ") (else (if (string? sort-by) (conc " ORDER BY " sort-by) ""))) (if limit (conc " LIMIT " limit) "") (if offset (conc " OFFSET " offset) "") ";" ))) (debug:print-info 8 "db:get-tests-for-run qry=" qry) (sqlite3:for-each-row (lambda (a . b) ;; id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment) (set! res (cons (apply vector a b) res))) ;; id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment) res))) db qry run-id |
︙ | ︙ | |||
975 976 977 978 979 980 981 | ;; ;; states and statuses are lists, turn them into ("PASS","FAIL"...) and use NOT IN ;; i.e. these lists define what to NOT show. ;; states and statuses are required to be lists, empty is ok ;; not-in #t = above behaviour, #f = must match ;; run-ids is a list of run-ids or a single number or #f for all runs (define (db:get-tests-for-runs db run-ids testpatt states statuses | | | | | 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 | ;; ;; states and statuses are lists, turn them into ("PASS","FAIL"...) and use NOT IN ;; i.e. these lists define what to NOT show. ;; states and statuses are required to be lists, empty is ok ;; not-in #t = above behaviour, #f = must match ;; run-ids is a list of run-ids or a single number or #f for all runs (define (db:get-tests-for-runs db run-ids testpatt states statuses #!key (not-in #t) (sort-by #f) (qryvals "id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment")) ;; 'rundir 'event_time (debug:print-info 11 "db:get-tests-for-run START run-ids=" run-ids ", testpatt=" testpatt ", states=" states ", statuses=" statuses ", not-in=" not-in ", sort-by=" sort-by) (let* ((res '()) ;; if states or statuses are null then assume match all when not-in is false (states-qry (if (null? states) #f (conc " state " (if not-in "NOT" "") |
︙ | ︙ | |||
1010 1011 1012 1013 1014 1015 1016 | (if states-qry (conc " AND " states-qry) "") (if statuses-qry (conc " AND " statuses-qry) "") (if tests-match-qry (conc " AND (" tests-match-qry ") ") "") (case sort-by ((rundir) " ORDER BY length(rundir) DESC;") ((event_time) " ORDER BY event_time ASC;") (else ";")) | | | 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 | (if states-qry (conc " AND " states-qry) "") (if statuses-qry (conc " AND " statuses-qry) "") (if tests-match-qry (conc " AND (" tests-match-qry ") ") "") (case sort-by ((rundir) " ORDER BY length(rundir) DESC;") ((event_time) " ORDER BY event_time ASC;") (else ";")) ))) (debug:print-info 8 "db:get-tests-for-run qry=" qry) (sqlite3:for-each-row (lambda (a . b) ;; id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment) (set! res (cons (apply vector a b) res))) ;; id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment) res))) db qry ) |
︙ | ︙ | |||
1103 1104 1105 1106 1107 1108 1109 | (define (cdb:tests-update-cpuload-diskfree serverdat test-id cpuload diskfree) (cdb:client-call serverdat 'update-cpuload-diskfree #t *default-numtries* cpuload diskfree test-id)) (define (cdb:tests-update-run-duration serverdat test-id minutes) (cdb:client-call serverdat 'update-run-duration #t *default-numtries* minutes test-id)) (define (cdb:tests-update-uname-host serverdat test-id uname hostname) | | > > > > > | < > > | | | | 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 | (define (cdb:tests-update-cpuload-diskfree serverdat test-id cpuload diskfree) (cdb:client-call serverdat 'update-cpuload-diskfree #t *default-numtries* cpuload diskfree test-id)) (define (cdb:tests-update-run-duration serverdat test-id minutes) (cdb:client-call serverdat 'update-run-duration #t *default-numtries* minutes test-id)) (define (cdb:tests-update-uname-host serverdat test-id uname hostname) (cdb:client-call serverdat 'update-uname-host #t *default-numtries* uname hostname test-id)) (define (db:process-triggers test-id newstate newstatus) #t) ;; 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 db test-id newstate newstatus newcomment) (cond ((and newstate newstatus newcomment) (sqlite3:execute db "UPDATE tests SET state=?,status=?,comment=? WHERE id=?;" newstate newstatus newcomment test-id)) ((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 test-id)))) (db:process-triggers test-id newstate newstatus) #t) ;; retrun something to keep the remote calls happy ;; Never used ;; (define (db:test-set-state-status-by-run-id-testname db run-id test-name item-path status state) ;; (sqlite3:execute db "UPDATE tests SET state=?,status=?,event_time=strftime('%s','now') WHERE run_id=? AND testname=? AND item_path=?;" ;; state status run-id test-name item-path)) (define (db:get-count-tests-running db) (let ((res 0)) (sqlite3:for-each-row (lambda (count) (set! res count)) db |
︙ | ︙ | |||
1279 1280 1281 1282 1283 1284 1285 | res))) (define (db:get-test-info db run-id testname item-path) (db:get-test-info-by-id db (db:get-test-id db run-id testname item-path))) (define (db:test-set-comment db test-id comment) (sqlite3:execute | | | 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 | res))) (define (db:get-test-info db run-id testname item-path) (db:get-test-info-by-id db (db:get-test-id db run-id testname item-path))) (define (db:test-set-comment db test-id comment) (sqlite3:execute db "UPDATE tests SET comment=? WHERE id=?;" comment test-id)) (define (cdb:test-set-rundir! serverdat run-id test-name item-path rundir) (cdb:client-call serverdat 'test-set-rundir #t *default-numtries* rundir run-id test-name item-path)) (define (cdb:test-set-rundir-by-test-id serverdat test-id rundir) |
︙ | ︙ | |||
1313 1314 1315 1316 1317 1318 1319 | ;; MUST BE CALLED local! (define (db:test-get-paths-matching db keynames target fnamepatt #!key (res '())) ;; BUG: Move the values derived from args to parameters and push to megatest.scm (let* ((testpatt (if (args:get-arg "-testpatt")(args:get-arg "-testpatt") "%")) (statepatt (if (args:get-arg ":state") (args:get-arg ":state") "%")) (statuspatt (if (args:get-arg ":status") (args:get-arg ":status") "%")) (runname (if (args:get-arg ":runname") (args:get-arg ":runname") "%")) | | | 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 | ;; MUST BE CALLED local! (define (db:test-get-paths-matching db keynames target fnamepatt #!key (res '())) ;; BUG: Move the values derived from args to parameters and push to megatest.scm (let* ((testpatt (if (args:get-arg "-testpatt")(args:get-arg "-testpatt") "%")) (statepatt (if (args:get-arg ":state") (args:get-arg ":state") "%")) (statuspatt (if (args:get-arg ":status") (args:get-arg ":status") "%")) (runname (if (args:get-arg ":runname") (args:get-arg ":runname") "%")) (paths-from-db (cdb:remote-run db:test-get-paths-matching-keynames-target-new db keynames target res testpatt: testpatt statepatt: statepatt statuspatt: statuspatt runname: runname))) (if fnamepatt (apply append (map (lambda (p) |
︙ | ︙ | |||
1344 1345 1346 1347 1348 1349 1350 | (string-split target "/")) " AND ")) (testqry (tests:match->sqlqry testpatt)) (qrystr (conc "SELECT t.rundir FROM tests AS t INNER JOIN runs AS r ON t.run_id=r.id WHERE " keystr " AND r.runname LIKE '" runname "' AND " testqry " AND t.state LIKE '" statepatt "' AND t.status LIKE '" statuspatt "' ORDER BY t.event_time ASC;"))) | < > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 | (string-split target "/")) " AND ")) (testqry (tests:match->sqlqry testpatt)) (qrystr (conc "SELECT t.rundir FROM tests AS t INNER JOIN runs AS r ON t.run_id=r.id WHERE " keystr " AND r.runname LIKE '" runname "' AND " testqry " AND t.state LIKE '" statepatt "' AND t.status LIKE '" statuspatt "' ORDER BY t.event_time ASC;"))) (sqlite3:for-each-row (lambda (p) (set! res (cons p res))) db qrystr) res)) (define (db:test-get-paths-matching-keynames-target-new db keynames target res #!key (testpatt "%") (statepatt "%") (statuspatt "%") (runname "%")) (let* ((row-ids '()) (keystr (string-intersperse (map (lambda (key val) (conc key " like '" val "'")) keynames (string-split target "/")) " AND ")) (testqry (tests:match->sqlqry testpatt)) (runsqry (sqlite3:prepare db (conc "SELECT id FROM runs WHERE " keystr " AND runname LIKE '" runname "';"))) (tstsqry (sqlite3:prepare db (conc "SELECT rundir FROM tests WHERE run_id=? AND " testqry " AND state LIKE '" statepatt "' AND status LIKE '" statuspatt "' ORDER BY event_time ASC;")))) (sqlite3:for-each-row (lambda (rid) (set! row-ids (cons rid row-ids))) runsqry) (for-each (lambda (rid) (sqlite3:for-each-row (lambda (p) (set! res (cons p res))) tstsqry rid)) row-ids) (sqlite3:finalize! tstsqry) (sqlite3:finalize! runsqry) res)) ;; look through tests from matching runs for a file (define (db:test-get-first-path-matching db keynames target fname) ;; [refpaths] is the section where references to other megatest databases are stored (let ((mt-paths (configf:get-section "refpaths")) (res (db:test-get-paths-matching db keynames target fname))) (let loop ((pathdat (if (null? paths) #f (car mt-paths))) |
︙ | ︙ | |||
1390 1391 1392 1393 1394 1395 1396 | (base64:base64-encode (with-output-to-string (lambda ()(serialize obj)))) #t)) ((zmq)(with-output-to-string (lambda ()(serialize obj)))) (else obj))) (define (db:string->obj msg) (case *transport-type* | | | | | | | | | | | | | | 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 | (base64:base64-encode (with-output-to-string (lambda ()(serialize obj)))) #t)) ((zmq)(with-output-to-string (lambda ()(serialize obj)))) (else obj))) (define (db:string->obj msg) (case *transport-type* ((fs) msg) ((http) (if (string? msg) (with-input-from-string (base64:base64-decode (string-substitute (regexp "_") "=" msg #t)) (lambda ()(deserialize))) (vector #f #f #f))) ;; crude reply for when things go awry ((zmq)(with-input-from-string msg (lambda ()(deserialize)))) (else msg))) (define (cdb:use-non-blocking-mode proc) (set! *client-non-blocking-mode* #t) (let ((res (proc))) (set! *client-non-blocking-mode* #f) res)) ;; params = 'target cached remparams ;; ;; make-vector-record cdb packet client-sig qtype immediate query-sig params qtime ;; ;; cdb:client-call is the unified interface to all the transports. It dispatches the ;; query to a server routine (e.g. server:client-send-recieve) that ;; transports the data to the server where it is passed to db:process-queue-item |
︙ | ︙ | |||
1467 1468 1469 1470 1471 1472 1473 | ;; we will need to process "all" messages here some day (receive-message* sub-socket) ;; now get the actual message (let ((myres (db:string->obj (receive-message* sub-socket)))) (if (equal? query-sig (vector-ref myres 1)) (set! res (vector-ref myres 2)) (loop))))))) | | | | | | | | | | | | | | | | | > > > > > > > > > > > > > | 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 1539 1540 1541 1542 1543 1544 1545 1546 1547 1548 1549 1550 1551 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 1572 1573 1574 1575 1576 1577 1578 1579 1580 1581 1582 1583 1584 | ;; we will need to process "all" messages here some day (receive-message* sub-socket) ;; now get the actual message (let ((myres (db:string->obj (receive-message* sub-socket)))) (if (equal? query-sig (vector-ref myres 1)) (set! res (vector-ref myres 2)) (loop))))))) ;; (timeout (lambda () ;; (let loop ((n numretries)) ;; (thread-sleep! 15) ;; (if (not res) ;; (if (> numretries 0) ;; (begin ;; (debug:print 2 "WARNING: no reply to query " params ", trying resend") ;; (debug:print-info 11 "re-sending message") ;; (send-message push-socket zdat) ;; (debug:print-info 11 "message re-sent") ;; (loop (- n 1))) ;; ;; (apply cdb:client-call *runremote* qtype immediate (- numretries 1) params)) ;; (begin ;; (debug:print 0 "ERROR: cdb:client-call timed out " params ", exiting.") ;; (exit 5)))))))) (debug:print-info 11 "Starting threads") (let ((th1 (make-thread send-receive "send receive")) ;; (th2 (make-thread timeout "timeout")) ) (thread-start! th1) ;; (thread-start! th2) (thread-join! th1) (debug:print-info 11 "cdb:client-call returning res=" res) res)))))) (define (cdb:set-verbosity serverdat val) (cdb:client-call serverdat 'set-verbosity #f *default-numtries* val)) (define (cdb:login serverdat keyval signature) (cdb:client-call serverdat 'login #t *default-numtries* keyval megatest-version signature)) (define (cdb:logout serverdat keyval signature) (cdb:client-call serverdat 'logout #t *default-numtries* keyval signature)) (define (cdb:num-clients serverdat) (cdb:client-call serverdat 'numclients #t *default-numtries*)) ;; I think this would be more efficient if executed on client side FIXME??? (define (cdb:test-set-status-state serverdat test-id status state msg) (if (member state '("LAUNCHED" "REMOTEHOSTSTART")) (cdb:client-call serverdat 'set-test-start-time #t *default-numtries* test-id)) (if msg (cdb:client-call serverdat 'state-status-msg #t *default-numtries* state status msg test-id) (cdb:client-call serverdat 'state-status #t *default-numtries* state status test-id))) ;; run-id test-name item-path minutes cpuload diskfree tmpfree) ;; Set the test event_time to current time. Call this when setting a test to LAUNCHED or REMOTEHOSTSTART ;; (define (cdb:set-test-start-time! serverdat test-id) ;; (cdb:client-call serverdat 'set-test-start-time #t *default-numtries* test-id)) (define (cdb:test-rollup-test_data-pass-fail serverdat test-id) (cdb:client-call serverdat 'test_data-pf-rollup #t *default-numtries* test-id test-id test-id test-id)) (define (cdb:pass-fail-counts serverdat test-id fail-count pass-count) (cdb:client-call serverdat 'pass-fail-counts #t *default-numtries* fail-count pass-count test-id)) (define (cdb:tests-register-test serverdat run-id test-name item-path) (cdb:client-call serverdat 'register-test #t *default-numtries* run-id test-name item-path)) ;; more transactioned calls, these for roll-up-pass-fail stuff (define (cdb:update-pass-fail-counts serverdat run-id test-name) (cdb:client-call serverdat 'update-fail-pass-counts #t *default-numtries* run-id test-name run-id test-name run-id test-name)) (define (cdb:top-test-set-running serverdat run-id test-name) (cdb:client-call serverdat 'top-test-set-running #t *default-numtries* run-id test-name)) (define (cdb:top-test-set-per-pf-counts serverdat run-id test-name) (cdb:client-call serverdat 'top-test-set-per-pf-counts #t *default-numtries* run-id test-name run-id test-name run-id test-name)) ;;= (define (cdb:flush-queue serverdat) (cdb:client-call serverdat 'flush #f *default-numtries*)) (define (cdb:kill-server serverdat pid) (cdb:client-call serverdat 'killserver #t *default-numtries* pid)) |
︙ | ︙ | |||
1563 1564 1565 1566 1567 1568 1569 1570 | ;;====================================================================== ;; A G R E G A T E D T R A N S A C T I O N D B W R I T E S ;;====================================================================== (define db:queries (list '(register-test "INSERT OR IGNORE INTO tests (run_id,testname,event_time,item_path,state,status) VALUES (?,?,strftime('%s','now'),?,'NOT_STARTED','n/a');") '(state-status "UPDATE tests SET state=?,status=? WHERE id=?;") | > > > < > > > > > > > > > > > > > > > > > > > > > > > > > | | | | | 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 | ;;====================================================================== ;; A G R E G A T E D T R A N S A C T I O N D B W R I T E S ;;====================================================================== (define db:queries (list '(register-test "INSERT OR IGNORE INTO tests (run_id,testname,event_time,item_path,state,status) VALUES (?,?,strftime('%s','now'),?,'NOT_STARTED','n/a');") ;; Test state and status '(set-test-state "UPDATE tests SET state=? WHERE id=?;") '(set-test-status "UPDATE tests SET state=? WHERE id=?;") '(state-status "UPDATE tests SET state=?,status=? WHERE id=?;") '(state-status-msg "UPDATE tests SET state=?,status=?,comment=? WHERE id=?;") ;; Test comment '(set-test-comment "UPDATE tests SET comment=? WHERE id=?;") '(set-test-start-time "UPDATE tests SET event_time=strftime('%s','now') WHERE id=?;") '(pass-fail-counts "UPDATE tests SET fail_count=?,pass_count=? WHERE id=?;") ;; test_data-pf-rollup is used to set a tests PASS/FAIL based on the pass/fail info from the steps '(test_data-pf-rollup "UPDATE tests SET status=CASE WHEN (SELECT fail_count FROM tests WHERE id=?) > 0 THEN 'FAIL' WHEN (SELECT pass_count FROM tests WHERE id=?) > 0 AND (SELECT status FROM tests WHERE id=?) NOT IN ('WARN','FAIL') THEN 'PASS' ELSE status END WHERE id=?;") '(test-set-log "UPDATE tests SET final_logf=? WHERE id=?;") '(test-set-rundir-by-test-id "UPDATE tests SET rundir=? WHERE id=?") '(test-set-rundir "UPDATE tests SET rundir=? WHERE run_id=? AND testname=? AND item_path=?;") '(delete-tests-in-state "DELETE FROM tests WHERE state=? AND run_id=?;") '(tests:test-set-toplog "UPDATE tests SET final_logf=? WHERE run_id=? AND testname=? AND item_path='';") '(update-cpuload-diskfree "UPDATE tests SET cpuload=?,diskfree=? WHERE id=?;") '(update-run-duration "UPDATE tests SET run_duration=? WHERE id=?;") '(update-uname-host "UPDATE tests SET uname=?,host=? WHERE id=?;") '(update-test-state "UPDATE tests SET state=? WHERE state=? AND run_id=? AND testname=? AND NOT (item_path='' AND testname IN (SELECT DISTINCT testname FROM tests WHERE testname=? AND item_path != ''));") '(update-test-status "UPDATE tests SET status=? WHERE status like ? AND run_id=? AND testname=? AND NOT (item_path='' AND testname IN (SELECT DISTINCT testname FROM tests WHERE testname=? AND item_path != ''));") ;; stuff for roll-up-pass-fail-counts '(update-fail-pass-counts "UPDATE tests SET fail_count=(SELECT count(id) FROM tests WHERE run_id=? AND testname=? AND item_path != '' AND status IN ('FAIL','CHECK')), pass_count=(SELECT count(id) FROM tests WHERE run_id=? AND testname=? AND item_path != '' AND status IN ('PASS','WARN','WAIVED')) WHERE run_id=? AND testname=? AND item_path='';") '(top-test-set-running "UPDATE tests SET state='RUNNING' WHERE run_id=? AND testname=? AND item_path='';") '(top-test-set-per-pf-counts "UPDATE tests SET state=CASE WHEN (SELECT count(id) FROM tests WHERE run_id=? AND testname=? AND item_path != '' AND state in ('RUNNING','NOT_STARTED')) > 0 THEN 'RUNNING' ELSE 'COMPLETED' END, status=CASE WHEN fail_count > 0 THEN 'FAIL' WHEN pass_count > 0 AND fail_count=0 THEN 'PASS' WHEN (SELECT count(id) FROM tests WHERE run_id=? AND testname=? AND item_path != '' AND status = 'SKIP') > 0 THEN 'SKIP' ELSE 'UNKNOWN' END WHERE run_id=? AND testname=? AND item_path='';") )) ;; do not run these as part of the transaction (define db:special-queries '(rollup-tests-pass-fail ;; db:roll-up-pass-fail-counts ;; WHY NOT!? login immediate flush sync set-verbosity killserver )) ;; not used, intended to indicate to run in calling process |
︙ | ︙ | |||
1615 1616 1617 1618 1619 1620 1621 | (set! *server:last-write-flush* (current-milliseconds)) (set! *incoming-writes* '()) (mutex-unlock! *incoming-mutex*) (if (> (length data) 0) ;; Process if we have data (begin (debug:print-info 7 "Writing cached data " data) | | | 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 1702 1703 1704 | (set! *server:last-write-flush* (current-milliseconds)) (set! *incoming-writes* '()) (mutex-unlock! *incoming-mutex*) (if (> (length data) 0) ;; Process if we have data (begin (debug:print-info 7 "Writing cached data " data) ;; Prepare the needed sql statements ;; (for-each (lambda (request-item) (let ((stmt-key (vector-ref request-item 0)) (query (vector-ref request-item 1))) (hash-table-set! queries stmt-key (sqlite3:prepare db query)))) data) |
︙ | ︙ | |||
1707 1708 1709 1710 1711 1712 1713 | (< (current-seconds) timeout)) (begin (thread-sleep! 0.01) (loop)))) (set! *number-of-writes* (+ *number-of-writes* 1)) (set! *writes-total-delay* (+ *writes-total-delay* (- (current-milliseconds) start-time))) got-it)) | | | 1782 1783 1784 1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 1795 1796 | (< (current-seconds) timeout)) (begin (thread-sleep! 0.01) (loop)))) (set! *number-of-writes* (+ *number-of-writes* 1)) (set! *writes-total-delay* (+ *writes-total-delay* (- (current-milliseconds) start-time))) got-it)) (define (db:process-queue-item db item) (let* ((stmt-key (cdb:packet-get-qtype item)) (qry-sig (cdb:packet-get-query-sig item)) (return-address (cdb:packet-get-client-sig item)) (params (cdb:packet-get-params item)) (query (let ((q (alist-ref stmt-key db:queries))) (if q (car q) #f)))) |
︙ | ︙ | |||
1797 1798 1799 1800 1801 1802 1803 | (lambda (id itempath state status run_duration logf comment) (set! res (cons (vector id itempath state status run_duration logf comment) res))) db "SELECT id,item_path,state,status,run_duration,final_logf,comment FROM tests WHERE run_id=? AND testname=? AND item_path != '';" run-id test-name) res)) | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 1872 1873 1874 1875 1876 1877 1878 1879 1880 1881 1882 1883 1884 1885 | (lambda (id itempath state status run_duration logf comment) (set! res (cons (vector id itempath state status run_duration logf comment) res))) db "SELECT id,item_path,state,status,run_duration,final_logf,comment FROM tests WHERE run_id=? AND testname=? AND item_path != '';" run-id test-name) res)) ;;====================================================================== ;; Tests meta data ;;====================================================================== ;; read the record given a testname (define (db:testmeta-get-record db testname) (let ((res #f)) |
︙ | ︙ | |||
1971 1972 1973 1974 1975 1976 1977 | ;; (thread-sleep! 1) ;; play nice with the queue by ensuring the rollup is at least 10ms later than the set ;; if the test is not FAIL then set status based on the fail and pass counts. (cdb:test-rollup-test_data-pass-fail *runremote* test-id) ;; (sqlite3:execute ;; db ;;; NOTE: Should this be WARN,FAIL? A WARN is not a FAIL????? BUG FIXME ;; "UPDATE tests | | | | | | | | | 2007 2008 2009 2010 2011 2012 2013 2014 2015 2016 2017 2018 2019 2020 2021 2022 2023 2024 2025 2026 2027 | ;; (thread-sleep! 1) ;; play nice with the queue by ensuring the rollup is at least 10ms later than the set ;; if the test is not FAIL then set status based on the fail and pass counts. (cdb:test-rollup-test_data-pass-fail *runremote* test-id) ;; (sqlite3:execute ;; db ;;; NOTE: Should this be WARN,FAIL? A WARN is not a FAIL????? BUG FIXME ;; "UPDATE tests ;; SET status=CASE WHEN (SELECT fail_count FROM tests WHERE id=?) > 0 ;; THEN 'FAIL' ;; WHEN (SELECT pass_count FROM tests WHERE id=?) > 0 AND ;; (SELECT status FROM tests WHERE id=?) NOT IN ('WARN','FAIL') ;; THEN 'PASS' ;; ELSE status ;; END WHERE id=?;" ;; test-id test-id test-id test-id) )))) (define (db:get-prev-tol-for-test db test-id category variable) ;; Finish me? (values #f #f #f)) |
︙ | ︙ | |||
2116 2117 2118 2119 2120 2121 2122 | (if (and (equal? item-path "") (or is-completed is-running));; this is the parent, set it to run if completed or running (set! parent-waiton-met #t))) ;; normal checking of parent items, any parent or parent item not ok blocks running ((and is-completed (or is-ok (eq? mode 'toplevel)) ;; toplevel does not block on FAIL | | | | | 2152 2153 2154 2155 2156 2157 2158 2159 2160 2161 2162 2163 2164 2165 2166 2167 2168 2169 2170 | (if (and (equal? item-path "") (or is-completed is-running));; this is the parent, set it to run if completed or running (set! parent-waiton-met #t))) ;; normal checking of parent items, any parent or parent item not ok blocks running ((and is-completed (or is-ok (eq? mode 'toplevel)) ;; toplevel does not block on FAIL (and is-ok (eq? mode 'itemmatch))) ;; itemmatch blocks on not ok (set! item-waiton-met #t))))) tests) ;; both requirements, parent and item-waiton must be met to NOT add item to ;; prereq's not met list (if (not (or parent-waiton-met item-waiton-met)) (set! result (append (if (null? tests) (list waitontest-name) tests) result))) ;; if the test is not found then clearly the waiton is not met... ;; (if (not ever-seen)(set! result (cons waitontest-name result))))) (if (not ever-seen) (set! result (append (if (null? tests)(list waitontest-name) tests) result))))) waitons) |
︙ | ︙ |
Added docs/manual/howto.txt version [ad8e0484e1].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 | How To Do Things ================ Tricks ------ This section is a compendium of a various useful tricks for debugging, configuring and generally getting the most out of Megatest. Debugging Tricks ---------------- Examining The Environment ~~~~~~~~~~~~~~~~~~~~~~~~~ During Config File Processing ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ Organising Your Tests and Tasks ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ /nfs/ch/disks/ch_unienv_disk005/qa_mrwellan/interim/src/megatest/tests/fdktestqa/testqa ---------------------------- [tests-paths] 1 #{get misc parent}/simplerun/tests ---------------------------- ------------------- [setup] ------------------- The runscript method is a brute force way to run scripts where the user is responsible for setting STATE and STATUS ------------------- runscript main.csh ------------------- ww30.2 cellname/LVS/cellname.LAYOUT_ERRORS Error: text open ww31.3 cellname/LVS/cellname.LAYOUT_ERRORS Error: text open |
Modified docs/manual/megatest_manual.txt from [32284f0199] to [20ce759875].
︙ | ︙ | |||
44 45 46 47 48 49 50 51 52 53 54 55 56 57 | which can launch jobs on local and remote Linux hosts. Currently megatest uses the network filesystem to call home to your master sqlite3 database. include::../plan.txt[] include::getting_started.txt[] include::writing_tests.txt[] include::reference.txt[] [appendix] Example Appendix ================ One or more optional appendixes go here at section level zero. | > | 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 | which can launch jobs on local and remote Linux hosts. Currently megatest uses the network filesystem to call home to your master sqlite3 database. include::../plan.txt[] include::getting_started.txt[] include::writing_tests.txt[] include::howto.txt[] include::reference.txt[] [appendix] Example Appendix ================ One or more optional appendixes go here at section level zero. |
︙ | ︙ |
Modified ezsteps.scm from [ad9d3c507a] to [56b532d0f1].
︙ | ︙ | |||
163 164 165 166 167 168 169 | new-status (args:get-arg "-m") #f) ;; need to update the top test record if PASS or FAIL and this is a subtest (if (not (equal? item-path "")) (cdb:roll-up-pass-fail-counts *runremote* run-id test-name item-path new-status)))) ;; for automated creation of the rollup html file this is a good place... (if (not (equal? item-path "")) | | | 163 164 165 166 167 168 169 170 171 172 173 | new-status (args:get-arg "-m") #f) ;; need to update the top test record if PASS or FAIL and this is a subtest (if (not (equal? item-path "")) (cdb:roll-up-pass-fail-counts *runremote* run-id test-name item-path new-status)))) ;; for automated creation of the rollup html file this is a good place... (if (not (equal? item-path "")) (tests:summarize-items #f run-id test-id test-name #f)) ;; don't force - just update if no ))) (pop-directory) rollup-status)) |
Modified http-transport.scm from [e77ae27b79] to [ee9b75177b].
︙ | ︙ | |||
351 352 353 354 355 356 357 | (mutex-lock! *http-mutex*) (set! res (with-input-from-request ;; was dat fullurl (list (cons 'key "thekey") (cons 'cmd cmd) (cons 'params params)) read-string)) | > | | 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 | (mutex-lock! *http-mutex*) (set! res (with-input-from-request ;; was dat fullurl (list (cons 'key "thekey") (cons 'cmd cmd) (cons 'params params)) read-string)) ;; Shouldn't this be a call to the managed call-all-connections stuff above? (close-all-connections!) (mutex-unlock! *http-mutex*) )) ;; (if cleanup ;; ;; mutex already set ;; (begin ;; (set! res dat) ;; (http-transport:dec-requests-count-and-close-all-connections)) |
︙ | ︙ |
Modified launch.scm from [825fd61cf1] to [9f87d3c019].
1 |
| | | 1 2 3 4 5 6 7 8 9 | ;; Copyright 2006-2013, Matthew Welland. ;; ;; This program is made available under the GNU GPL version 2.0 or ;; greater. See the accompanying file COPYING for details. ;; ;; This program is distributed WITHOUT ANY WARRANTY; without even the ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ;; PURPOSE. |
︙ | ︙ | |||
133 134 135 136 137 138 139 | (set-run-config-vars run-id keyvals target) ;; (db:get-target db run-id)) ;; environment overrides are done *before* the remaining critical envars. (alist->env-vars env-ovrd) (set-megatest-env-vars run-id) (set-item-env-vars itemdat) (save-environment-as-files "megatest") ;; open-run-close not needed for test-set-meta-info | | > | | 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 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 | (set-run-config-vars run-id keyvals target) ;; (db:get-target db run-id)) ;; environment overrides are done *before* the remaining critical envars. (alist->env-vars env-ovrd) (set-megatest-env-vars run-id) (set-item-env-vars itemdat) (save-environment-as-files "megatest") ;; open-run-close not needed for test-set-meta-info (tests:set-full-meta-info #f test-id run-id 0 work-area) (tests:test-set-status! test-id "REMOTEHOSTSTART" "n/a" (args:get-arg "-m") #f) ;; (cdb:set-test-start-time! *runremote* test-id) (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) (keep-going #t) (runit (lambda () ;; (let-values ;; (((pid exit-status exit-code) ;; (run-n-wait fullrunscript))) (tests:test-set-status! test-id "RUNNING" "n/a" #f #f) ;; if there is a runscript do it first (if fullrunscript (let ((pid (process-run fullrunscript))) (let loop ((i 0)) (let-values (((pid-val exit-status exit-code) (process-wait pid #t))) (mutex-lock! m) (vector-set! exit-info 0 pid) (vector-set! exit-info 1 exit-status) (vector-set! exit-info 2 exit-code) (set! rollup-status exit-code) (mutex-unlock! m) (if (eq? pid-val 0) (begin (thread-sleep! 1) (loop (+ i 1))) ))))) ;; then, if runscript ran ok (or did not get called) ;; do all the ezsteps (if any) (if ezsteps (let* ((testconfig (read-config (conc work-area "/testconfig") #f #t environ-patt: "pre-launch-env-vars")) ;; FIXME??? is allow-system ok here? (ezstepslst (hash-table-ref/default testconfig "ezsteps" '()))) |
︙ | ︙ | |||
221 222 223 224 225 226 227 | (mutex-lock! m) (vector-set! exit-info 0 pid) (vector-set! exit-info 1 exit-status) (vector-set! exit-info 2 exit-code) (mutex-unlock! m) (if (eq? pid-val 0) (begin | | | 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 | (mutex-lock! m) (vector-set! exit-info 0 pid) (vector-set! exit-info 1 exit-status) (vector-set! exit-info 2 exit-code) (mutex-unlock! m) (if (eq? pid-val 0) (begin (thread-sleep! 1) (processloop (+ i 1)))) )) (let ((exinfo (vector-ref exit-info 2)) (logfna (if logpro-used (conc stepname ".html") ""))) ;; testing if procedures called in a remote call cause problems (ans: no or so I suspect) (db:teststep-set-status! #f test-id stepname "end" exinfo #f logfna work-area: work-area)) (if logpro-used |
︙ | ︙ | |||
273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 | (calc-minutes (lambda () (inexact->exact (round (- (current-seconds) start-seconds))))) (kill-tries 0)) (let loop ((minutes (calc-minutes))) (begin (set! kill-job? (or (test-get-kill-request test-id) ;; run-id test-name itemdat)) (and runtlim (let* ((run-seconds (- (current-seconds) start-seconds)) (time-exceeded (> run-seconds runtlim))) (if time-exceeded (begin (debug:print-info 0 "KILLING TEST DUE TO TIME LIMIT EXCEEDED! Runtime=" run-seconds " seconds, limit=" runtlim) #t) #f))))) ;; open-run-close not needed for test-set-meta-info | > | > > > | 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 | (calc-minutes (lambda () (inexact->exact (round (- (current-seconds) start-seconds))))) (kill-tries 0)) (tests:set-full-meta-info #f test-id run-id (calc-minutes) work-area) (let loop ((minutes (calc-minutes))) (begin (set! kill-job? (or (test-get-kill-request test-id) ;; run-id test-name itemdat)) (and runtlim (let* ((run-seconds (- (current-seconds) start-seconds)) (time-exceeded (> run-seconds runtlim))) (if time-exceeded (begin (debug:print-info 0 "KILLING TEST DUE TO TIME LIMIT EXCEEDED! Runtime=" run-seconds " seconds, limit=" runtlim) #t) #f))))) ;; open-run-close not needed for test-set-meta-info (tests:set-partial-meta-info #f test-id run-id minutes work-area) (if kill-job? (begin (mutex-lock! m) ;; NOTE: The pid can change as different steps are run. Do we need handshaking between this ;; section and the runit section? Or add a loop that tries three times with a 1/4 second ;; between tries? (let* ((pid (vector-ref exit-info 0))) (if (number? pid) (process-signal pid signal/kill) ;; (begin ;; (debug:print 0 "WARNING: Request received to kill job (attempt # " kill-tries ")") ;; (let ((processes (cmd-run->list (conc "pgrep -l -P " pid)))) ;; (for-each |
︙ | ︙ | |||
315 316 317 318 319 320 321 | (tests:test-set-status! test-id "KILLED" "FAIL" (args:get-arg "-m") #f) (sqlite3:finalize! tdb) (exit 1)))) (set! kill-tries (+ 1 kill-tries)) (mutex-unlock! m))) ;; (sqlite3:finalize! db) | > > | > | | | > > > | | | > | > > | < | < < < < < | 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 | (tests:test-set-status! test-id "KILLED" "FAIL" (args:get-arg "-m") #f) (sqlite3:finalize! tdb) (exit 1)))) (set! kill-tries (+ 1 kill-tries)) (mutex-unlock! m))) ;; (sqlite3:finalize! db) (if keep-going (begin (thread-sleep! (+ 10 (random 10))) ;; add some jitter to the call home time to spread out the db accesses (if keep-going (loop (calc-minutes)))))))))) ;; NOTE: Checking twice for keep-going is intentional (th1 (make-thread monitorjob "monitor job")) (th2 (make-thread runit "run job"))) (set! job-thread th2) (thread-start! th1) (thread-start! th2) (thread-join! th2) (set! keep-going #f) (thread-sleep! 1) (thread-terminate! th1) ;; Not sure if this is a good idea (thread-sleep! 0.1) ;; give thread th1 a chance to be done TODO: Verify this is needed. At 0.1 I was getting fail to stop, increased to total of 1.1 sec. (mutex-lock! m) (let* ((item-path (item-list->path itemdat)) (testinfo (cdb:get-test-info-by-id *runremote* test-id))) ;; )) ;; run-id test-name item-path))) ;; Am I completed? (if (equal? (db:test-get-state testinfo) "RUNNING") ;; (not (equal? (db:test-get-state testinfo) "COMPLETED")) (let ((new-state (if kill-job? "KILLED" "COMPLETED") ;; (if (eq? (vector-ref exit-info 2) 0) ;; exited with "good" status ;; "COMPLETED" ;; (db:test-get-state testinfo))) ;; else preseve the state as set within the test ) (new-status (cond ((not (vector-ref exit-info 1)) "FAIL") ;; job failed to run ((eq? rollup-status 0) ;; if the current status is AUTO then defer to the calculated value (i.e. leave this AUTO) (if (equal? (db:test-get-status testinfo) "AUTO") "AUTO" "PASS")) ((eq? rollup-status 1) "FAIL") ((eq? rollup-status 2) ;; if the current status is AUTO the defer to the calculated value but qualify (i.e. make this AUTO-WARN) (if (equal? (db:test-get-status testinfo) "AUTO") "AUTO-WARN" "WARN")) (else "FAIL")))) ;; (db:test-get-status testinfo))) (debug:print-info 1 "Test exited in state=" (db:test-get-state testinfo) ", setting state/status based on exit code of " (vector-ref exit-info 1) " and rollup-status of " rollup-status) (tests:test-set-status! test-id new-state new-status (args:get-arg "-m") #f) ;; need to update the top test record if PASS or FAIL and this is a subtest ;; NO NEED TO CALL roll-up-pass-fail-counts HERE, THIS IS DONE IN roll-up-pass-fail-counts called by tests:test-set-status! ;; (if (not (equal? item-path "")) ;; (begin ;; (thread-sleep! 0.1) ;; give other processes an opportunity to access the db as rollup is lower priority ;; (cdb:roll-up-pass-fail-counts *runremote* run-id test-name item-path new-status))) )) ;; for automated creation of the rollup html file this is a good place... (if (not (equal? item-path "")) (tests:summarize-items #f run-id test-id test-name #f))) ;; don't force - just update if no (mutex-unlock! m) (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") (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 |
︙ | ︙ |
Added lock-queue.scm version [343ec1ffa5].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 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 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 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 | ;; Copyright 2006-2013, Matthew Welland. ;; ;; This program is made available under the GNU GPL version 2.0 or ;; greater. See the accompanying file COPYING for details. ;; ;; This program is distributed WITHOUT ANY WARRANTY; without even the ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ;; PURPOSE. ;;====================================================================== ;; launch a task - this runs on the originating host, tests themselves ;; ;;====================================================================== (use sqlite3 srfi-18) (import (prefix sqlite3 sqlite3:)) (declare (unit lock-queue)) (declare (uses common)) ;;====================================================================== ;; attempt to prevent overlapping updates of rollup files by queueing ;; update requests in an sqlite db ;;====================================================================== (define (lock-queue:open-db fname) (let* ((actualfname (conc fname ".lockdb")) (dbexists (file-exists? actualfname)) (db (sqlite3:open-database actualfname)) (handler (make-busy-timeout 3600))) (if dbexists db (begin (sqlite3:execute db "CREATE TABLE IF NOT EXISTS queue ( id INTEGER PRIMARY KEY, test_id INTEGER, start_time INTEGER, state TEXT, CONSTRAINT queue_constraint UNIQUE (test_id));") (sqlite3:execute db "CREATE TABLE IF NOT EXISTS runlocks ( id INTEGER PRIMARY KEY, test_id INTEGER, run_lock TEXT, CONSTRAINT runlock_constraint UNIQUE (run_lock));"))) (sqlite3:set-busy-handler! db handler) db)) (define (lock-queue:set-state db test-id newstate) (sqlite3:execute db "UPDATE queue SET state=? WHERE test_id=?;" newstate test-id)) (define (lock-queue:any-younger? db mystart test-id) (let ((res #f)) (sqlite3:for-each-row (lambda (tid) ;; Actually this should not be needed as mystart cannot be simultaneously less than and test-id same as (if (not (equal? tid test-id)) (set! res tid))) db "SELECT test_id FROM queue WHERE start_time > ?;" mystart) res)) (define (lock-queue:get-lock db test-id) (let ((res #f) (lckqry (sqlite3:prepare db "SELECT test_id,run_lock FROM runlocks WHERE run_lock='locked';")) (mklckqry (sqlite3:prepare db "INSERT INTO runlocks (test_id,run_lock) VALUES (?,'locked');"))) (let ((result (handle-exceptions exn #f (sqlite3:with-transaction db (lambda () (sqlite3:for-each-row (lambda (tid lockstate) (set! res (list tid lockstate))) lckqry) (if res (if (equal? (car res) test-id) #t ;; already have the lock #f) (begin (sqlite3:execute mklckqry test-id) ;; if no error handled then return #t for got the lock #t))))))) (sqlite3:finalize! lckqry) (sqlite3:finalize! mklckqry) result))) (define (lock-queue:release-lock fname test-id) (let ((db (lock-queue:open-db fname))) (sqlite3:execute db "DELETE FROM runlocks WHERE test_id=?;" test-id) (sqlite3:finalize! db))) (define (lock-queue:steal-lock db test-id) (sqlite3:execute db "DELETE FROM runlocks WHERE run_lock='locked';") (lock-queue:get-lock db test-it)) ;; returns #f if ok to skip the task ;; returns #t if ok to proceed with task ;; otherwise waits ;; (define (lock-queue:wait-turn fname test-id) (let ((db (lock-queue:open-db fname)) (mystart (current-seconds))) (sqlite3:execute db "INSERT OR REPLACE INTO queue (test_id,start_time,state) VALUES (?,?,'waiting');" test-id mystart) (thread-sleep! 1) ;; give other tests a chance to register (let ((result (let loop ((younger-waiting (lock-queue:any-younger? db mystart test-id))) (if younger-waiting (begin ;; no need for us to wait. mark in the lock queue db as skipping (lock-queue:set-state db test-id "skipping") #f) ;; let the calling process know that nothing needs to be done (if (lock-queue:get-lock db test-id) #t (if (> (- (current-seconds) mystart) 36000) ;; waited too long, steal the lock (lock-queue:steal-lock db test-id) (begin (thread-sleep! 1) (loop (lock-queue:any-younger? db mystart test-id))))))))) (sqlite3:finalize! db) result))) ;; (use trace) ;; (trace lock-queue:get-lock lock-queue:release-lock lock-queue:wait-turn lock-queue:any-younger? lock-queue:set-state) |
Modified megatest.scm from [6a2f2b93a6] to [210d0a1c02].
︙ | ︙ | |||
936 937 938 939 940 941 942 | (let ((logfname (args:get-arg "-setlog"))) (cdb:test-set-log! *runremote* test-id logfname))) (if (args:get-arg "-set-toplog") ;; DO NOT run remote (tests:test-set-toplog! db run-id test-name (args:get-arg "-set-toplog"))) (if (args:get-arg "-summarize-items") ;; DO NOT run remote | | | 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 | (let ((logfname (args:get-arg "-setlog"))) (cdb:test-set-log! *runremote* test-id logfname))) (if (args:get-arg "-set-toplog") ;; DO NOT run remote (tests:test-set-toplog! db run-id test-name (args:get-arg "-set-toplog"))) (if (args:get-arg "-summarize-items") ;; DO NOT run remote (tests:summarize-items db run-id test-id test-name #t)) ;; do force here (if (args:get-arg "-runstep") (if (null? remargs) (begin (debug:print 0 "ERROR: nothing specified to run!") (if db (sqlite3:finalize! db)) (exit 6)) (let* ((stepname (args:get-arg "-runstep")) |
︙ | ︙ |
Modified mt.scm from [31d9a09536] to [c659fc340c].
︙ | ︙ | |||
85 86 87 88 89 90 91 | (define (mt:get-prereqs-not-met run-id waitons ref-item-path #!key (mode 'normal)) (db:get-prereqs-not-met run-id waitons ref-item-path mode: mode)) (define (mt:get-run-stats) (cdb:remote-run db:get-run-stats #f)) ;;====================================================================== | | > > > > > > > > > > > > > > > > > > > > > > > | 85 86 87 88 89 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 | (define (mt:get-prereqs-not-met run-id waitons ref-item-path #!key (mode 'normal)) (db:get-prereqs-not-met run-id waitons ref-item-path mode: mode)) (define (mt:get-run-stats) (cdb:remote-run db:get-run-stats #f)) ;;====================================================================== ;; S T A T E A N D S T A T U S F O R T E S T S ;;====================================================================== (define (mt:roll-up-pass-fail-counts run-id test-name item-path status) (if (and (not (equal? item-path "")) (member status '("PASS" "WARN" "FAIL" "WAIVED" "RUNNING" "CHECK" "SKIP"))) (begin (cdb:update-pass-fail-counts *runremote* run-id test-name) (if (equal? status "RUNNING") (cdb:top-test-set-running *runremote* run-id test-name) (cdb:top-test-set-per-pf-counts *runremote* run-id test-name)) #f) #f)) ;; speed up for common cases with a little logic (define (mt:test-set-state-status-by-id test-id newstate newstatus newcomment) (cond ((and newstate newstatus newcomment) (cdb:client-call *runremote* 'state-status-msg #t *default-numtries* newstate newstatus newcomment test-id)) ((and newstate newstatus) (cdb:client-call serverdat 'state-status #t *default-numtries* newstate newstatus test-id)) (else (if newstate (cdb:client-call *runremote* 'set-test-state #t *default-numtries* newstate test-id)) (if newstatus (cdb:client-call *runremote* 'set-test-status #t *default-numtries* newstatus test-id)) (if newcomment (cdb:client-call *runremote* 'set-test-comment #t *default-numtries* newcomment test-id)))) (db:process-triggers test-id newstate newstatus)) |
Modified runs.scm from [a6403613e5] to [8c7a71404f].
︙ | ︙ | |||
789 790 791 792 793 794 795 | (runs:update-test_meta test-name test-conf))) ;; itemdat => ((ripeness "overripe") (temperature "cool") (season "summer")) (let* ((new-test-path (string-intersperse (cons test-path (map cadr itemdat)) "/")) (test-id (cdb:remote-run db:get-test-id #f run-id test-name item-path)) (testdat (cdb:get-test-info-by-id *runremote* test-id))) (if (not testdat) | | | > > > > > | 789 790 791 792 793 794 795 796 797 798 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 | (runs:update-test_meta test-name test-conf))) ;; itemdat => ((ripeness "overripe") (temperature "cool") (season "summer")) (let* ((new-test-path (string-intersperse (cons test-path (map cadr itemdat)) "/")) (test-id (cdb:remote-run db:get-test-id #f run-id test-name item-path)) (testdat (cdb:get-test-info-by-id *runremote* test-id))) (if (not testdat) (let loop () ;; ensure that the path exists before registering the test ;; NOPE: Cannot! Don't know yet which disk area will be assigned.... ;; (system (conc "mkdir -p " new-test-path)) ;; ;; (open-run-close tests:register-test db run-id test-name item-path) ;; ;; NB// for the above line. I want the test to be registered long before this routine gets called! ;; (set! test-id (cdb:remote-run db:get-test-id #f run-id test-name item-path)) (if (not test-id) (begin (debug:print 2 "WARN: Test not pre-created? test-name=" test-name ", item-path=" item-path ", run-id=" run-id) (cdb:tests-register-test *runremote* run-id test-name item-path) (set! test-id (cdb:remote-run db:get-test-id #f run-id test-name item-path)))) (debug:print-info 4 "test-id=" test-id ", run-id=" run-id ", test-name=" test-name ", item-path=\"" item-path "\"") (set! testdat (cdb:get-test-info-by-id *runremote* test-id)) (if (not testdat) (begin (debug:print-info 0 "WARNING: server is overloaded, trying again in one second") (thread-sleep! 1) (loop))))) (if (not testdat) ;; should NOT happen (debug:print 0 "ERROR: failed to get test record for test-id " test-id)) (set! test-id (db:test-get-id testdat)) (if (file-exists? test-path) (change-directory test-path) (begin (debug:print "ERROR: test run path not created before attempting to run the test. Perhaps you are running -remove-runs at the same time?") |
︙ | ︙ | |||
879 880 881 882 883 884 885 | (set! skip-test "Skipping due to previous tests running")))) ((and skip-check (configf:lookup test-conf "skip" "fileexists")) (if (file-exists? (configf:lookup test-conf "skip" "fileexists")) (set! skip-test (conc "Skipping due to existance of file " (configf:lookup test-conf "skip" "fileexists")))))) (if skip-test (begin | | | 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 | (set! skip-test "Skipping due to previous tests running")))) ((and skip-check (configf:lookup test-conf "skip" "fileexists")) (if (file-exists? (configf:lookup test-conf "skip" "fileexists")) (set! skip-test (conc "Skipping due to existance of file " (configf:lookup test-conf "skip" "fileexists")))))) (if skip-test (begin (mt:test-set-state-status-by-id test-id "COMPLETED" "SKIP" skip-test) (debug:print-info 1 "SKIPPING Test " full-test-name " due to " skip-test)) (if (not (launch-test test-id run-id run-info keyvals runname test-conf test-name test-path itemdat flags)) (begin (print "ERROR: Failed to launch the test. Exiting as soon as possible") (set! *globalexitstatus* 1) ;; (process-signal (current-process-id) signal/kill)))))))) ((KILLED) |
︙ | ︙ | |||
1022 1023 1024 1025 1026 1027 1028 | (hash-table-set! test-retry-time test-fulln (current-seconds)))) (if (> (- (current-seconds)(hash-table-ref test-retry-time test-fulln)) allow-run-time) ;; This test is not in a correct state for cleaning up. Let's try some graceful shutdown steps first ;; Set the test to "KILLREQ" and wait five seconds then try again. Repeat up to five times then give ;; up and blow it away. (begin (debug:print 0 "WARNING: could not gracefully remove test " test-fulln ", tried to kill it to no avail. Forcing state to FAILEDKILL and continuing") | | | | | 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 | (hash-table-set! test-retry-time test-fulln (current-seconds)))) (if (> (- (current-seconds)(hash-table-ref test-retry-time test-fulln)) allow-run-time) ;; This test is not in a correct state for cleaning up. Let's try some graceful shutdown steps first ;; Set the test to "KILLREQ" and wait five seconds then try again. Repeat up to five times then give ;; up and blow it away. (begin (debug:print 0 "WARNING: could not gracefully remove test " test-fulln ", tried to kill it to no avail. Forcing state to FAILEDKILL and continuing") (mt:test-set-state-status-by-id (db:test-get-id test) "FAILEDKILL" "n/a" #f) (thread-sleep! 1)) (begin (mt:test-set-state-status-by-id (db:test-get-id test) "KILLREQ" "n/a" #f) (thread-sleep! 1))) ;; NOTE: This is suboptimal as the testdata will be used later and the state/status may have changed ... (if (null? tal) (loop new-test-dat tal) (loop (car tal)(append tal (list new-test-dat))))) (begin (mt:test-set-state-status-by-id (db:test-get-id test) "REMOVING" "LOCKED" #f) (debug:print-info 1 "Attempting to remove " (if real-dir (conc " dir " real-dir " and ") "") " link " run-dir) (if (and real-dir (> (string-length real-dir) 5) (file-exists? real-dir)) ;; bad heuristic but should prevent /tmp /home etc. (begin ;; let* ((realpath (resolve-pathname run-dir))) (debug:print-info 1 "Recursively removing " real-dir) (if (file-exists? real-dir) |
︙ | ︙ | |||
1069 1070 1071 1072 1073 1074 1075 | )) ;; Only delete the records *after* removing the directory. If things fail we have a record (cdb:remote-run db:delete-test-records db #f (db:test-get-id test)) (if (not (null? tal)) (loop (car tal)(cdr tal)))))) ((set-state-status) (debug:print-info 2 "new state " (car state-status) ", new status " (cadr state-status)) | | | 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 | )) ;; Only delete the records *after* removing the directory. If things fail we have a record (cdb:remote-run db:delete-test-records db #f (db:test-get-id test)) (if (not (null? tal)) (loop (car tal)(cdr tal)))))) ((set-state-status) (debug:print-info 2 "new state " (car state-status) ", new status " (cadr state-status)) (mt:test-set-state-status-by-id (db:test-get-id test) (car state-status)(cadr state-status) #f) (if (not (null? tal)) (loop (car tal)(cdr tal)))) ((run-wait) (debug:print-info 2 "still waiting, " (length tests) " tests still running") (thread-sleep! 10) (let ((new-tests (proc-get-tests run-id))) (if (null? new-tests) |
︙ | ︙ |
Modified tests.scm from [3fc8cabe45] to [2146eaed6a].
︙ | ︙ | |||
13 14 15 16 17 18 19 20 21 22 23 24 25 26 | ;; Tests ;;====================================================================== (use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking tcp directory-utils) (import (prefix sqlite3 sqlite3:)) (declare (unit tests)) (declare (uses db)) (declare (uses common)) (declare (uses items)) (declare (uses runconfig)) (include "common_records.scm") (include "key_records.scm") | > | 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 | ;; Tests ;;====================================================================== (use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking tcp directory-utils) (import (prefix sqlite3 sqlite3:)) (declare (unit tests)) (declare (uses lock-queue)) (declare (uses db)) (declare (uses common)) (declare (uses items)) (declare (uses runconfig)) (include "common_records.scm") (include "key_records.scm") |
︙ | ︙ | |||
363 364 365 366 367 368 369 | type ))) ;; This was run remote, don't think that makes sense. (db:csv->test-data #f test-id dat)))) ;; need to update the top test record if PASS or FAIL and this is a subtest (if (not (equal? item-path "")) | | | | | > | 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 | type ))) ;; This was run remote, don't think that makes sense. (db:csv->test-data #f test-id dat)))) ;; need to update the top test record if PASS or FAIL and this is a subtest (if (not (equal? item-path "")) (mt:roll-up-pass-fail-counts run-id test-name item-path status)) (if (or (and (string? comment) (string-match (regexp "\\S+") comment)) waived) (let ((cmt (if waived waived comment))) (cdb:remote-run db:test-set-comment #f test-id cmt))) )) (define (tests:test-set-toplog! db run-id test-name logf) (cdb:client-call *runremote* 'tests:test-set-toplog #t 2 logf run-id test-name)) (define (tests:summarize-items db run-id test-id test-name force) ;; if not force then only update the record if one of these is true: ;; 1. logf is "log/final.log ;; 2. logf is same as outputfilename (let* ((outputfilename (conc "megatest-rollup-" test-name ".html")) (orig-dir (current-directory)) (logf-info (cdb:remote-run db:test-get-logfile-info #f run-id test-name)) (logf (if logf-info (cadr logf-info) #f)) (path (if logf-info (car logf-info) #f))) ;; This query finds the path and changes the directory to it for the test (if (directory? path) (begin (debug:print 4 "Found path: " path) (change-directory path)) ;; (set! outputfilename (conc path "/" outputfilename))) (print "No such path: " path)) (debug:print 4 "summarize-items with logf " logf ", outputfilename " outputfilename " and force " force) (if (or (equal? logf "logs/final.log") (equal? logf outputfilename) force) (begin (if ;; (not (obtain-dot-lock outputfilename 1 5 7)) ;; retry every second for 20 seconds, call it dead after 30 seconds and steal the lock (not (lock-queue:wait-turn outputfilename test-id)) (print "Not updating " outputfilename " as another test item has signed up for the job") (begin (print "Obtained lock for " outputfilename) (let ((oup (open-output-file outputfilename)) (counts (make-hash-table)) (statecounts (make-hash-table)) (outtxt "") (tot 0) |
︙ | ︙ | |||
459 460 461 462 463 464 465 466 467 468 469 470 471 472 | (print "</td></td></tr></table>") (print "<table cellspacing=\"0\" border=\"1\">" "<tr><td>Item</td><td>State</td><td>Status</td><td>Comment</td>" outtxt "</table></body></html>") (release-dot-lock outputfilename))) (close-output-port oup) (change-directory orig-dir) ;; NB// tests:test-set-toplog! is remote internal... (tests:test-set-toplog! db run-id test-name outputfilename) ))))))) ;;====================================================================== ;; Gather data from test/task specifications | > | 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 | (print "</td></td></tr></table>") (print "<table cellspacing=\"0\" border=\"1\">" "<tr><td>Item</td><td>State</td><td>Status</td><td>Comment</td>" outtxt "</table></body></html>") (release-dot-lock outputfilename))) (close-output-port oup) (lock-queue:release-lock outputfilename test-id) (change-directory orig-dir) ;; NB// tests:test-set-toplog! is remote internal... (tests:test-set-toplog! db run-id test-name outputfilename) ))))))) ;;====================================================================== ;; Gather data from test/task specifications |
︙ | ︙ | |||
677 678 679 680 681 682 683 | (lambda (count) (set! res count)) tdb "SELECT count(id) FROM test_rundat;") res)) 0) | | < < < < < | | < | | < < | < | < | | < | | > | > > > > > > > > > > > | | 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 | (lambda (count) (set! res count)) tdb "SELECT count(id) FROM test_rundat;") res)) 0) (define (tests:update-central-meta-info test-id cpuload diskfree minutes uname hostname) ;; This is a good candidate for threading the requests to enable ;; transactionized write at the server (cdb:tests-update-cpuload-diskfree *runremote* test-id cpuload diskfree) (if minutes (cdb:tests-update-run-duration *runremote* test-id minutes)) (if (and uname hostname) (cdb:tests-update-uname-host *runremote* test-id uname hostname))) (define (tests:set-full-meta-info db test-id run-id minutes work-area) ;; DOES cdb:remote-run under the hood! (let* ((num-records 0) ;; (test:tdb-get-rundat-count tdb)) (cpuload (get-cpu-load)) (diskfree (get-df (current-directory))) (uname (get-uname "-srvpio")) (hostname (get-host-name))) (tests:update-testdat-meta-info db test-id work-area cpuload diskfree minutes) (tests:update-central-meta-info test-id cpuload diskfree minutes uname hostname))) (define (tests:set-partial-meta-info db test-id run-id minutes work-area) ;; DOES cdb:remote-run under the hood! (let* ((cpuload (get-cpu-load)) (diskfree (get-df (current-directory)))) (tests:update-testdat-meta-info db test-id work-area cpuload diskfree minutes) ;; Update central with uname and hostname = #f (tests:update-central-meta-info test-id cpuload diskfree minutes #f #f))) (define (tests:update-testdat-meta-info db test-id work-area cpuload diskfree minutes) (let ((tdb (db:open-test-db-by-test-id db test-id work-area: work-area))) (sqlite3:execute tdb "INSERT INTO test_rundat (update_time,cpuload,diskfree,run_duration) VALUES (strftime('%s','now'),?,?,?);" cpuload diskfree minutes) (sqlite3:finalize! tdb))) ;;====================================================================== ;; A R C H I V I N G ;;====================================================================== (define (test:archive db test-id) #f) (define (test:archive-tests db keynames target) #f) |
Modified tests/Makefile from [602052bbdd] to [801e8f7cee].
︙ | ︙ | |||
126 127 128 129 130 131 132 133 134 135 136 137 138 139 | (cd fullrun;$(MEGATEST) -runtests priority_10_waiton_1 -target $$targ :runname $(RUNNAME) &); done for sys in ubuntu suse redhat debian;do \ for fs in afs nfs zfs; do \ for dpath in none tmp; do \ (cd fullrun;$(MEGATEST) -runtests priority_10_waiton_1 -target $$sys/$$fs/$$dpath :runname $(RUNNAME) &);\ done;done;done minsetup : cd ..;make && make install mkdir -p mintest/runs mintest/links cd mintest;megatest -stop-server 0 cd mintest;megatest -server - -debug $(DEBUG) > server.log 2> server.log & sleep 3 cd mintest;dashboard -rows 20 & | > > > | 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 | (cd fullrun;$(MEGATEST) -runtests priority_10_waiton_1 -target $$targ :runname $(RUNNAME) &); done for sys in ubuntu suse redhat debian;do \ for fs in afs nfs zfs; do \ for dpath in none tmp; do \ (cd fullrun;$(MEGATEST) -runtests priority_10_waiton_1 -target $$sys/$$fs/$$dpath :runname $(RUNNAME) &);\ done;done;done test11 : cd fullrun;time (for a in 1 2 3 4 5 6 7 8 9 10 1 2 3 4 5 6 7 8 9 10 1 2 3 4 5 6 7 8 9 10 1 2 3 4 5 6 7 8 9 10 ;do (megatest -test-paths -target %/%/% > /dev/null ) & done; wait; ) minsetup : cd ..;make && make install mkdir -p mintest/runs mintest/links cd mintest;megatest -stop-server 0 cd mintest;megatest -server - -debug $(DEBUG) > server.log 2> server.log & sleep 3 cd mintest;dashboard -rows 20 & |
︙ | ︙ |
Modified tests/fdktestqa/fdk.config from [d8147016d6] to [c701336661].
1 2 3 4 5 6 | [fields] SYSTEM TEXT RELEASE TEXT [setup] # Adjust max_concurrent_jobs to limit how much you load your machines | | | 1 2 3 4 5 6 7 8 9 10 11 12 | [fields] SYSTEM TEXT RELEASE TEXT [setup] # Adjust max_concurrent_jobs to limit how much you load your machines max_concurrent_jobs 150 # This is your link path, you can move it but it is generally better to keep it stable linktree #{shell readlink -f #{getenv PWD}/../simplelinks} [include testqa/configs/megatest.abc.config] |
Modified tests/fdktestqa/testqa/Makefile from [b85c936a02] to [0b9ed605a6].
︙ | ︙ | |||
12 13 14 15 16 17 18 | ($(MEGATEST) -runtests % -target a/b :runname $tn & ) ; \ done bigrun : $(MEGATEST) -runtests bigrun -target a/bigrun :runname a bigrun2 : | | | 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 | ($(MEGATEST) -runtests % -target a/b :runname $tn & ) ; \ done bigrun : $(MEGATEST) -runtests bigrun -target a/bigrun :runname a bigrun2 : $(MEGATEST) -runtests bigrun2 -target a/bigrun2 :runname a -transport http dashboard : $(DASHBOARD) -rows 20 & compile : (cd ../../..;make && make install) |
︙ | ︙ |
Modified tests/fdktestqa/testqa/megatest.config from [b118157a0d] to [cfe5ca96f4].
1 2 | [setup] testcopycmd cp --remove-destination -rlv TEST_SRC_PATH/. TEST_TARG_PATH/. >> TEST_TARG_PATH/mt_launch.log 2>> TEST_TARG_PATH/mt_launch.log | | > > | | 1 2 3 4 5 6 7 8 9 10 | [setup] testcopycmd cp --remove-destination -rlv TEST_SRC_PATH/. TEST_TARG_PATH/. >> TEST_TARG_PATH/mt_launch.log 2>> TEST_TARG_PATH/mt_launch.log runqueue 20 transport http launchwait no [include ../fdk.config] [server] port 9080 |
Modified tests/fullrun/megatest.config from [4419360fc2] to [7450f4e4e1].
︙ | ︙ | |||
14 15 16 17 18 19 20 | home #{shell readlink -f $MT_RUN_AREA_HOME} parent #{shell readlink -f $MT_RUN_AREA_HOME/..} [tests-paths] 1 #{get misc parent}/simplerun/tests [setup] | | < | | 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 | home #{shell readlink -f $MT_RUN_AREA_HOME} parent #{shell readlink -f $MT_RUN_AREA_HOME/..} [tests-paths] 1 #{get misc parent}/simplerun/tests [setup] # Set launchwait to no to use the more agressive code that does not wait for the launch to complete before proceeding launchwait no # Use http instead of direct filesystem access transport http # If set to "default" the old code is used. Otherwise defaults to 200 or uses # numeric value given. |
︙ | ︙ |