Check-in [3e2cee87de]
Not logged in
Overview
SHA1 Hash:3e2cee87dee369d63c4aadca09ed4ea5852996a6
Date: 2012-03-13 06:59:26
User: matt
Comment:Merged servermode to trunk
Timelines: family | ancestors | descendants | both | trunk
Downloads: Tarball | ZIP archive
Other Links: files | file ages | manifest
Tags And Properties
Changes

Modified common.scm from [5ebf23fbcda8e053] to [28e4357992a744da].

31 31 32 ;; global gletches 32 ;; global gletches 33 (define *configinfo* #f) 33 (define *configinfo* #f) 34 (define *configdat* #f) 34 (define *configdat* #f) 35 (define *toppath* #f) 35 (define *toppath* #f) 36 (define *already-seen-runconfig-info* #f) 36 (define *already-seen-runconfig-info* #f) 37 (define *waiting-queue* (make-hash-table)) 37 (define *waiting-queue* (make-hash-table)) > 38 (define *test-meta-updated* (make-hash-table)) 38 (define *globalexitstatus* 0) ;; attempt to work around possible thread issues 39 (define *globalexitstatus* 0) ;; attempt to work around possible thread issues 39 (define *passnum* 0) ;; when running track calls to run-tests or similar 40 (define *passnum* 0) ;; when running track calls to run-tests or similar 40 (define *verbosity* 1) 41 (define *verbosity* 1) 41 (define *rpc:listener* #f) ;; if set up for server communication this will hold 42 (define *rpc:listener* #f) ;; if set up for server communication this will hold 42 (define *runremote* #f) ;; if set up for server communication this will hold 43 (define *runremote* #f) ;; if set up for server communication this will hold > 44 (define *last-db-access* 0) ;; update when db is accessed via server 43 45 44 (define (get-with-default val default) 46 (define (get-with-default val default) 45 (let ((val (args:get-arg val))) 47 (let ((val (args:get-arg val))) 46 (if val val default))) 48 (if val val default))) 47 49 48 (define (assoc/default key lst . default) 50 (define (assoc/default key lst . default) 49 (let ((res (assoc key lst))) 51 (let ((res (assoc key lst)))

Modified dashboard.scm from [56cfd810b6a1c9e2] to [78b39d96f4f5940f].

76 (begin 76 (begin 77 (print "Failed to find megatest.config, exiting") 77 (print "Failed to find megatest.config, exiting") 78 (exit 1))) 78 (exit 1))) 79 79 80 (define *db* (open-db)) 80 (define *db* (open-db)) 81 81 82 ;; HACK ALERT: this is a hack, please fix. 82 ;; HACK ALERT: this is a hack, please fix. 83 (define *read-only* (file-read-access? (conc *toppath* "/megatest.db"))) | 83 (define *read-only* (not (file-read-access? (conc *toppath* "/megatest.db")))) 84 ;; (server:client-setup *db*) 84 ;; (server:client-setup *db*) 85 85 86 (define toplevel #f) 86 (define toplevel #f) 87 (define dlg #f) 87 (define dlg #f) 88 (define max-test-num 0) 88 (define max-test-num 0) 89 (define *keys* (rdb:get-keys *db*)) 89 (define *keys* (rdb:get-keys *db*)) 90 ;; (define *keys* (db:get-keys *db*)) 90 ;; (define *keys* (db:get-keys *db*))

Modified db.scm from [72acdb1ad4467de9] to [48ed807e565b67b3].

36 (define *incoming-mutex* (make-mutex)) 36 (define *incoming-mutex* (make-mutex)) 37 (define *cache-on* #f) 37 (define *cache-on* #f) 38 38 39 (define (open-db) ;; (conc *toppath* "/megatest.db") (car *configinfo*))) 39 (define (open-db) ;; (conc *toppath* "/megatest.db") (car *configinfo*))) 40 (let* ((dbpath (conc *toppath* "/megatest.db")) ;; fname) 40 (let* ((dbpath (conc *toppath* "/megatest.db")) ;; fname) 41 (dbexists (file-exists? dbpath)) 41 (dbexists (file-exists? dbpath)) 42 (db (sqlite3:open-database dbpath)) ;; (never-give-up-open-db db 42 (db (sqlite3:open-database dbpath)) ;; (never-give-up-open-db db 43 (handler (make-busy-timeout 36000))) | 43 (handler (make-busy-timeout (if (args:get-arg "-override-timeout") > 44 (string->number (args:get-arg "-overr > 45 36000)))) ;; 136000))) 44 (sqlite3:set-busy-handler! db handler) 46 (sqlite3:set-busy-handler! db handler) 45 (if (not dbexists) 47 (if (not dbexists) 46 (db:initialize db)) 48 (db:initialize db)) 47 db)) 49 db)) 48 50 49 (define (db:initialize db) 51 (define (db:initialize db) 50 (let* ((configdat (car *configinfo*)) ;; tut tut, global warning... 52 (let* ((configdat (car *configinfo*)) ;; tut tut, global warning... ................................................................................................................................................................................ 211 value REAL, 213 value REAL, 212 expected REAL, 214 expected REAL, 213 tol REAL, 215 tol REAL, 214 units TEXT, 216 units TEXT, 215 comment TEXT DEFAULT '', 217 comment TEXT DEFAULT '', 216 status TEXT DEFAULT 'n/a', 218 status TEXT DEFAULT 'n/a', 217 CONSTRAINT test_data UNIQUE (test_id,category,vari 219 CONSTRAINT test_data UNIQUE (test_id,category,vari 218 (print "WARNING: Table test_data and test_meta where recreated. Please do | 220 (print "WARNING: Table test_data and test_meta were recreated. Please do 219 (patch-db)) 221 (patch-db)) 220 ((< mver 1.27) 222 ((< mver 1.27) 221 (db:set-var db "MEGATEST_VERSION" 1.27) 223 (db:set-var db "MEGATEST_VERSION" 1.27) 222 (sqlite3:execute db "ALTER TABLE test_data ADD COLUMN type TEXT DEFAULT ' 224 (sqlite3:execute db "ALTER TABLE test_data ADD COLUMN type TEXT DEFAULT ' 223 (patch-db)) 225 (patch-db)) 224 ((< mver 1.29) 226 ((< mver 1.29) 225 (db:set-var db "MEGATEST_VERSION" 1.29) 227 (db:set-var db "MEGATEST_VERSION" 1.29) ................................................................................................................................................................................ 443 (sqlite3:for-each-row (lambda (id) 445 (sqlite3:for-each-row (lambda (id) 444 (set! ids (cons id ids))) 446 (set! ids (cons id ids))) 445 db 447 db 446 "SELECT id FROM tests WHERE run_id=? AND testname=? AN 448 "SELECT id FROM tests WHERE run_id=? AND testname=? AN 447 run-id test-name (item-list->path itemdat)) 449 run-id test-name (item-list->path itemdat)) 448 (for-each (lambda (id) 450 (for-each (lambda (id) 449 (sqlite3:execute db "DELETE FROM test_steps WHERE test_id=?;" id 451 (sqlite3:execute db "DELETE FROM test_steps WHERE test_id=?;" id > 452 (thread-sleep! 0.1) ;; give others access to the db > 453 (sqlite3:execute db "DELETE FROM test_data WHERE test_id=?;" id) 450 (thread-sleep! 0.1)) ;; give others access to the db | 454 (thread-sleep! 0.1)) ;; give others access to the db 451 ids))) 455 ids))) 452 ;;"DELETE FROM test_steps WHERE test_id in (SELECT id FROM tests WHERE run_id=? 456 ;;"DELETE FROM test_steps WHERE test_id in (SELECT id FROM tests WHERE run_id=? 453 457 454 ;; 458 ;; 455 (define (db:delete-test-records db test-id) 459 (define (db:delete-test-records db test-id) 456 (sqlite3:execute db "DELETE FROM test_steps WHERE test_id=?;" test-id) 460 (sqlite3:execute db "DELETE FROM test_steps WHERE test_id=?;" test-id) 457 (sqlite3:execute db "DELETE FROM test_data WHERE test_id=?;" test-id) 461 (sqlite3:execute db "DELETE FROM test_data WHERE test_id=?;" test-id) ................................................................................................................................................................................ 534 (set! res (vector id run-id testname state status event-time host cpuload 538 (set! res (vector id run-id testname state status event-time host cpuload 535 db 539 db 536 "SELECT id,run_id,testname,state,status,event_time,host,cpuload,diskfree,un 540 "SELECT id,run_id,testname,state,status,event_time,host,cpuload,diskfree,un 537 test-id) 541 test-id) 538 res)) 542 res)) 539 543 540 544 541 (define (db:test-set-comment db run-id test-name item-path comment) | 545 (define (db:test-set-comment db test-id comment) 542 (sqlite3:execute 546 (sqlite3:execute 543 db 547 db 544 "UPDATE tests SET comment=? WHERE run_id=? AND testname=? AND item_path=?;" | 548 "UPDATE tests SET comment=? WHERE id=?;" 545 comment run-id test-name item-path)) | 549 comment test-id)) 546 550 547 ;; 551 ;; 548 (define (db:test-set-rundir! db run-id test-name item-path rundir) 552 (define (db:test-set-rundir! db run-id test-name item-path rundir) 549 (sqlite3:execute 553 (sqlite3:execute 550 db 554 db 551 "UPDATE tests SET rundir=? WHERE run_id=? AND testname=? AND item_path=?;" 555 "UPDATE tests SET rundir=? WHERE run_id=? AND testname=? AND item_path=?;" 552 rundir run-id test-name item-path)) 556 rundir run-id test-name item-path)) 553 557 554 (define (db:test-set-log! db run-id test-name item-path logf) | 558 (define (db:test-set-log! db test-id logf) > 559 (if (string? logf) 555 (sqlite3:execute db "UPDATE tests SET final_logf=? WHERE run_id=? AND testname | 560 (sqlite3:execute db "UPDATE tests SET final_logf=? WHERE id=?;" 556 logf run-id test-name item-path)) < > 561 logf test-id) > 562 (debug:print 0 "ERROR: db:test-set-log! called with non-string log file na 557 563 558 ;;====================================================================== 564 ;;====================================================================== 559 ;; Misc. test related queries 565 ;; Misc. test related queries 560 ;;====================================================================== 566 ;;====================================================================== 561 567 562 (define (db:test-get-paths-matching db keynames target) 568 (define (db:test-get-paths-matching db keynames target) 563 (let* ((res '()) 569 (let* ((res '()) ................................................................................................................................................................................ 676 ((meta-info) 682 ((meta-info) 677 (apply sqlite3:execute meta-stmt (vector-ref entry 2))) 683 (apply sqlite3:execute meta-stmt (vector-ref entry 2))) 678 ((step-status) 684 ((step-status) 679 (apply sqlite3:execute step-stmt (vector-ref entry 2))) 685 (apply sqlite3:execute step-stmt (vector-ref entry 2))) 680 (else 686 (else 681 (debug:print 0 "ERROR: Queued entry not recognised " entry 687 (debug:print 0 "ERROR: Queued entry not recognised " entry 682 data))) 688 data))) > 689 (sqlite3:finalize! meta-stmt) ;; sqlite is the bottleneck, clear the stateme > 690 (sqlite3:finalize! step-stmt) 683 (set! *incoming-data* '()) 691 (set! *incoming-data* '()) 684 (mutex-unlock! *incoming-mutex*) | 692 (mutex-unlock! *incoming-mutex*))) 685 (sqlite3:finalize! meta-stmt) < 686 (sqlite3:finalize! step-stmt))) < 687 693 688 (define (db:roll-up-pass-fail-counts db run-id test-name item-path status) 694 (define (db:roll-up-pass-fail-counts db run-id test-name item-path status) 689 (if (and (not (equal? item-path "")) 695 (if (and (not (equal? item-path "")) 690 (or (equal? status "PASS") 696 (or (equal? status "PASS") 691 (equal? status "WARN") 697 (equal? status "WARN") 692 (equal? status "FAIL") 698 (equal? status "FAIL") 693 (equal? status "WAIVED") 699 (equal? status "WAIVED") ................................................................................................................................................................................ 696 (sqlite3:execute 702 (sqlite3:execute 697 db 703 db 698 "UPDATE tests 704 "UPDATE tests 699 SET fail_count=(SELECT count(id) FROM tests WHERE run_id=? AND test 705 SET fail_count=(SELECT count(id) FROM tests WHERE run_id=? AND test 700 pass_count=(SELECT count(id) FROM tests WHERE run_id=? AND test 706 pass_count=(SELECT count(id) FROM tests WHERE run_id=? AND test 701 WHERE run_id=? AND testname=? AND item_path='';" 707 WHERE run_id=? AND testname=? AND item_path='';" 702 run-id test-name run-id test-name run-id test-name) 708 run-id test-name run-id test-name run-id test-name) > 709 (thread-sleep! 0.1) ;; give other processes a chance here 703 (if (equal? status "RUNNING") ;; running takes priority over all other s 710 (if (equal? status "RUNNING") ;; running takes priority over all other s 704 (sqlite3:execute db "UPDATE tests SET state=? WHERE run_id=? AND tes 711 (sqlite3:execute db "UPDATE tests SET state=? WHERE run_id=? AND tes 705 (sqlite3:execute 712 (sqlite3:execute 706 db 713 db 707 "UPDATE tests 714 "UPDATE tests 708 SET state=CASE WHEN (SELECT count(id) FROM tests WHERE ru 715 SET state=CASE WHEN (SELECT count(id) FROM tests WHERE ru 709 'RUNNING' 716 'RUNNING' 710 ELSE 'COMPLETED' END, 717 ELSE 'COMPLETED' END, 711 status=CASE WHEN fail_count > 0 THEN 'FAIL' WHEN pass_ 718 status=CASE WHEN fail_count > 0 THEN 'FAIL' WHEN pass_ 712 WHERE run_id=? AND testname=? AND item_path='';" 719 WHERE run_id=? AND testname=? AND item_path='';" 713 run-id test-name run-id test-name))))) | 720 run-id test-name run-id test-name)) > 721 #f) > 722 #f)) 714 723 715 724 716 ;;====================================================================== 725 ;;====================================================================== 717 ;; Tests meta data 726 ;; Tests meta data 718 ;;====================================================================== 727 ;;====================================================================== 719 728 720 ;; read the record given a testname 729 ;; read the record given a testname ................................................................................................................................................................................ 802 (sqlite3:for-each-row 811 (sqlite3:for-each-row 803 (lambda (id test_id category variable value expected tol units comment stat 812 (lambda (id test_id category variable value expected tol units comment stat 804 (set! res (cons (vector id test_id category variable value expected tol u 813 (set! res (cons (vector id test_id category variable value expected tol u 805 db 814 db 806 "SELECT id,test_id,category,variable,value,expected,tol,units,comment,statu 815 "SELECT id,test_id,category,variable,value,expected,tol,units,comment,statu 807 (reverse res))) 816 (reverse res))) 808 817 809 (define (db:load-test-data db run-id test-name itemdat) | 818 (define (db:load-test-data db test-id) 810 (let* ((item-path (item-list->path itemdat)) < 811 (testdat (db:get-test-info db run-id test-name item-path)) < 812 (test-id (if testdat (db:test-get-id testdat) #f))) < 813 ;; (debug:print 1 "Enter records to insert in the test_data table, seven fie < 814 (debug:print 4 "itemdat: " itemdat ", test-name: " test-name ", test-id: " t < 815 (if test-id < 816 (let loop ((lin (read-line))) | 819 (let loop ((lin (read-line))) 817 (if (not (eof-object? lin)) | 820 (if (not (eof-object? lin)) 818 (begin | 821 (begin 819 (debug:print 4 lin) | 822 (debug:print 4 lin) 820 (db:csv->test-data db test-id lin) | 823 (rdb:csv->test-data db test-id lin) 821 (loop (read-line)))))) | 824 (loop (read-line))))) 822 ;; roll up the current results. | 825 ;; roll up the current results. 823 ;; FIXME: Add the status to | 826 ;; FIXME: Add the status to 824 (db:test-data-rollup db test-id #f))) | 827 (rdb:test-data-rollup db test-id #f)) 825 828 826 ;; WARNING: Do NOT call this for the parent test on an iterated test 829 ;; WARNING: Do NOT call this for the parent test on an iterated test 827 ;; Roll up test_data pass/fail results 830 ;; Roll up test_data pass/fail results 828 ;; look at the test_data status field, 831 ;; look at the test_data status field, 829 ;; if all are pass (any case) and the test status is PASS or NULL or '' then 832 ;; if all are pass (any case) and the test status is PASS or NULL or '' then 830 ;; if one or more are fail (any case) then set test status to PASS, non "pass 833 ;; if one or more are fail (any case) then set test status to PASS, non "pass 831 (define (db:test-data-rollup db test-id status) 834 (define (db:test-data-rollup db test-id status) ................................................................................................................................................................................ 972 (if (not (or parent-waiton-met item-waiton-met)) 975 (if (not (or parent-waiton-met item-waiton-met)) 973 (set! result (cons waitontest-name result))) 976 (set! result (cons waitontest-name result))) 974 ;; if the test is not found then clearly the waiton is not met... 977 ;; if the test is not found then clearly the waiton is not met... 975 (if (not ever-seen)(set! result (cons waitontest-name result))))) 978 (if (not ever-seen)(set! result (cons waitontest-name result))))) 976 waitons) 979 waitons) 977 (delete-duplicates result)))) 980 (delete-duplicates result)))) 978 981 979 (define (db:teststep-set-status! db run-id test-name teststep-name state-in stat | 982 (define (db:teststep-set-status! db test-id teststep-name state-in status-in ite 980 (debug:print 4 "run-id: " run-id " test-name: " test-name) | 983 (debug:print 4 "test-id: " test-id " teststep-name: " teststep-name) 981 (let* ((state (check-valid-items "state" state-in)) 984 (let* ((state (check-valid-items "state" state-in)) 982 (status (check-valid-items "status" status-in)) | 985 (status (check-valid-items "status" status-in))) 983 (testdat (db:get-test-info db run-id test-name item-path))) < 984 (debug:print 5 "testdat: " testdat) < 985 (if (and testdat ;; if the section exists then force specification BUG, I do < 986 (or (not state)(not status))) | 986 (if (or (not state)(not status)) 987 (debug:print 0 "WARNING: Invalid " (if status "status" "state") 987 (debug:print 0 "WARNING: Invalid " (if status "status" "state") 988 " value \"" (if status state-in status-in) "\", update your valid | 988 " value \"" (if status state-in status-in) "\", update your 989 (if testdat < 990 (let ((test-id (test:get-id testdat))) < 991 (mutex-lock! *incoming-mutex*) | 989 (mutex-lock! *incoming-mutex*) 992 (set! *incoming-data* (cons (vector 'step-status | 990 (set! *incoming-data* (cons (vector 'step-status 993 (current-seconds) | 991 (current-seconds) 994 ;; FIXME - this should not update | 992 ;; FIXME - this should not update the lo 995 (list test-id teststep-name state- | 993 (list test-id teststep-name state-in sta 996 *incoming-data*)) | 994 *incoming-data*)) 997 (mutex-unlock! *incoming-mutex*) | 995 (mutex-unlock! *incoming-mutex*) 998 (if (not *cache-on*)(db:write-cached-data db)) | 996 (if (not *cache-on*)(db:write-cached-data db)) 999 #t) | 997 #t)) 1000 (debug:print 0 "ERROR: Can't update " test-name " for run " run-id " -> < 1001 998 1002 ;;====================================================================== 999 ;;====================================================================== 1003 ;; Extract ods file from the db 1000 ;; Extract ods file from the db 1004 ;;====================================================================== 1001 ;;====================================================================== 1005 1002 1006 ;; runspatt is a comma delimited list of run patterns 1003 ;; runspatt is a comma delimited list of run patterns 1007 ;; keypatt-alist must contain *all* keys with an associated pattern: '( ("KEY1" 1004 ;; keypatt-alist must contain *all* keys with an associated pattern: '( ("KEY1" ................................................................................................................................................................................ 1133 (if *runremote* 1130 (if *runremote* 1134 (let ((host (vector-ref *runremote* 0)) 1131 (let ((host (vector-ref *runremote* 0)) 1135 (port (vector-ref *runremote* 1))) 1132 (port (vector-ref *runremote* 1))) 1136 ((rpc:procedure 'rdb:set-tests-state-status host port) 1133 ((rpc:procedure 'rdb:set-tests-state-status host port) 1137 run-id testnames currstate currstatus newstate newstatus)) 1134 run-id testnames currstate currstatus newstate newstatus)) 1138 (db:set-tests-state-status db run-id testnames currstate currstatus newsta 1135 (db:set-tests-state-status db run-id testnames currstate currstatus newsta 1139 1136 1140 (define (rdb:teststep-set-status! db run-id test-name teststep-name state-in sta | 1137 (define (rdb:teststep-set-status! db test-id teststep-name state-in status-in it 1141 (let ((item-path (item-list->path itemdat))) 1138 (let ((item-path (item-list->path itemdat))) 1142 (if *runremote* 1139 (if *runremote* 1143 (let ((host (vector-ref *runremote* 0)) 1140 (let ((host (vector-ref *runremote* 0)) 1144 (port (vector-ref *runremote* 1))) 1141 (port (vector-ref *runremote* 1))) 1145 ((rpc:procedure 'rdb:teststep-set-status! host port) 1142 ((rpc:procedure 'rdb:teststep-set-status! host port) 1146 run-id test-name teststep-name state-in status-in item-path comment l | 1143 test-id teststep-name state-in status-in item-path comment logfile)) 1147 (db:teststep-set-status! db run-id test-name teststep-name state-in stat | 1144 (db:teststep-set-status! db test-id teststep-name state-in status-in ite 1148 1145 1149 (define (rdb:test-update-meta-info db run-id test-name itemdat minutes cpuload d 1146 (define (rdb:test-update-meta-info db run-id test-name itemdat minutes cpuload d 1150 (let ((item-path (item-list->path itemdat))) 1147 (let ((item-path (item-list->path itemdat))) 1151 (if *runremote* 1148 (if *runremote* 1152 (let ((host (vector-ref *runremote* 0)) 1149 (let ((host (vector-ref *runremote* 0)) 1153 (port (vector-ref *runremote* 1))) 1150 (port (vector-ref *runremote* 1))) 1154 ((rpc:procedure 'rdb:test-update-meta-info host port) 1151 ((rpc:procedure 'rdb:test-update-meta-info host port) ................................................................................................................................................................................ 1175 (if *runremote* 1172 (if *runremote* 1176 (let ((host (vector-ref *runremote* 0)) 1173 (let ((host (vector-ref *runremote* 0)) 1177 (port (vector-ref *runremote* 1))) 1174 (port (vector-ref *runremote* 1))) 1178 ((rpc:procedure 'rdb:roll-up-pass-fail-counts host port) 1175 ((rpc:procedure 'rdb:roll-up-pass-fail-counts host port) 1179 run-id test-name item-path status)) 1176 run-id test-name item-path status)) 1180 (db:roll-up-pass-fail-counts db run-id test-name item-path status))) 1177 (db:roll-up-pass-fail-counts db run-id test-name item-path status))) 1181 1178 1182 (define (rdb:test-set-comment db run-id test-name item-path comment) | 1179 (define (rdb:test-set-comment db test-id comment) 1183 (if *runremote* 1180 (if *runremote* 1184 (let ((host (vector-ref *runremote* 0)) 1181 (let ((host (vector-ref *runremote* 0)) 1185 (port (vector-ref *runremote* 1))) 1182 (port (vector-ref *runremote* 1))) 1186 ((rpc:procedure 'rdb:test-set-comment host port) 1183 ((rpc:procedure 'rdb:test-set-comment host port) 1187 run-id test-name item-path comment)) | 1184 test-id comment)) 1188 (db:test-set-comment db run-id test-name item-path comment))) | 1185 (db:test-set-comment db test-id comment))) 1189 1186 1190 (define (rdb:test-set-log! db run-id test-name item-path logf) | 1187 (define (rdb:test-set-log! db test-id logf) 1191 (if *runremote* 1188 (if *runremote* 1192 (let ((host (vector-ref *runremote* 0)) 1189 (let ((host (vector-ref *runremote* 0)) 1193 (port (vector-ref *runremote* 1))) 1190 (port (vector-ref *runremote* 1))) 1194 ((rpc:procedure 'rdb:test-set-log! host port) | 1191 ((rpc:procedure 'rdb:test-set-log! host port) test-id logf)) 1195 run-id test-name item-path logf)) < 1196 (db:test-set-log! db run-id test-name item-path logf))) | 1192 (db:test-set-log! db test-id logf))) 1197 1193 1198 (define (rdb:get-runs db runnamepatt numruns startrunoffset keypatts) 1194 (define (rdb:get-runs db runnamepatt numruns startrunoffset keypatts) 1199 (if *runremote* 1195 (if *runremote* 1200 (let ((host (vector-ref *runremote* 0)) 1196 (let ((host (vector-ref *runremote* 0)) 1201 (port (vector-ref *runremote* 1))) 1197 (port (vector-ref *runremote* 1))) 1202 ((rpc:procedure 'rdb:get-runs host port) 1198 ((rpc:procedure 'rdb:get-runs host port) 1203 runnamepatt numruns startrunoffset keypatts)) 1199 runnamepatt numruns startrunoffset keypatts)) ................................................................................................................................................................................ 1309 1305 1310 (define (rdb:delete-test-records db test-id) 1306 (define (rdb:delete-test-records db test-id) 1311 (if *runremote* 1307 (if *runremote* 1312 (let ((host (vector-ref *runremote* 0)) 1308 (let ((host (vector-ref *runremote* 0)) 1313 (port (vector-ref *runremote* 1))) 1309 (port (vector-ref *runremote* 1))) 1314 ((rpc:procedure 'rdb:delete-test-records host port) test-id)) 1310 ((rpc:procedure 'rdb:delete-test-records host port) test-id)) 1315 (db:delete-test-records db test-id))) 1311 (db:delete-test-records db test-id))) > 1312 > 1313 (define (rdb:test-data-rollup db test-id status) > 1314 (if *runremote* > 1315 (let ((host (vector-ref *runremote* 0)) > 1316 (port (vector-ref *runremote* 1))) > 1317 ((rpc:procedure 'rdb:test-data-rollup host port) test-id status)) > 1318 (db:test-data-rollup db test-id status)))

Modified launch.scm from [e033088d6b399baf] to [587849e94b49d432].

42 (define (steprun-good? logpro exitcode) 42 (define (steprun-good? logpro exitcode) 43 (or (eq? exitcode 0) 43 (or (eq? exitcode 0) 44 (and logpro (eq? exitcode 2)))) 44 (and logpro (eq? exitcode 2)))) 45 45 46 (define (launch:execute encoded-cmd) 46 (define (launch:execute encoded-cmd) 47 (let* ((cmdinfo (read (open-input-string (base64:base64-decode encoded-cmd)) 47 (let* ((cmdinfo (read (open-input-string (base64:base64-decode encoded-cmd)) 48 (setenv "MT_CMDINFO" encoded-cmd) 48 (setenv "MT_CMDINFO" encoded-cmd) 49 (if (list? cmdinfo) ;; ((testpath /tmp/mrwellan/jazzmind/src/example_run/tes | 49 (if (list? cmdinfo) ;; ((testpath /tmp/mrwellan/jazzmind/src/example_run/tes > 50 ;; (test-name sqlitespeed) (runscript runscript.rb) (db- 50 (let* ((testpath (assoc/default 'testpath cmdinfo)) 51 (let* ((testpath (assoc/default 'testpath cmdinfo)) 51 (work-area (assoc/default 'work-area cmdinfo)) 52 (work-area (assoc/default 'work-area cmdinfo)) 52 (test-name (assoc/default 'test-name cmdinfo)) 53 (test-name (assoc/default 'test-name cmdinfo)) 53 (runscript (assoc/default 'runscript cmdinfo)) 54 (runscript (assoc/default 'runscript cmdinfo)) 54 (ezsteps (assoc/default 'ezsteps cmdinfo)) 55 (ezsteps (assoc/default 'ezsteps cmdinfo)) 55 (db-host (assoc/default 'db-host cmdinfo)) 56 (db-host (assoc/default 'db-host cmdinfo)) 56 (run-id (assoc/default 'run-id cmdinfo)) 57 (run-id (assoc/default 'run-id cmdinfo)) > 58 (test-id (assoc/default 'test-id cmdinfo)) 57 (itemdat (assoc/default 'itemdat cmdinfo)) 59 (itemdat (assoc/default 'itemdat cmdinfo)) 58 (env-ovrd (assoc/default 'env-ovrd cmdinfo)) 60 (env-ovrd (assoc/default 'env-ovrd cmdinfo)) 59 (set-vars (assoc/default 'set-vars cmdinfo)) ;; pre-overrides f 61 (set-vars (assoc/default 'set-vars cmdinfo)) ;; pre-overrides f 60 (runname (assoc/default 'runname cmdinfo)) 62 (runname (assoc/default 'runname cmdinfo)) 61 (megatest (assoc/default 'megatest cmdinfo)) 63 (megatest (assoc/default 'megatest cmdinfo)) 62 (mt-bindir-path (assoc/default 'mt-bindir-path cmdinfo)) 64 (mt-bindir-path (assoc/default 'mt-bindir-path cmdinfo)) 63 (fullrunscript (if runscript (conc testpath "/" runscript) #f)) 65 (fullrunscript (if runscript (conc testpath "/" runscript) #f)) ................................................................................................................................................................................ 100 (set-run-config-vars db run-id) 102 (set-run-config-vars db run-id) 101 ;; environment overrides are done *before* the remaining critical enva 103 ;; environment overrides are done *before* the remaining critical enva 102 (alist->env-vars env-ovrd) 104 (alist->env-vars env-ovrd) 103 (set-megatest-env-vars db run-id) 105 (set-megatest-env-vars db run-id) 104 (set-item-env-vars itemdat) 106 (set-item-env-vars itemdat) 105 (save-environment-as-files "megatest") 107 (save-environment-as-files "megatest") 106 (test-set-meta-info db run-id test-name itemdat) 108 (test-set-meta-info db run-id test-name itemdat) 107 (test-set-status! db run-id test-name "REMOTEHOSTSTART" "n/a" itemdat | 109 (test-set-status! db test-id "REMOTEHOSTSTART" "n/a" (args:get-arg "-m 108 (if (args:get-arg "-xterm") 110 (if (args:get-arg "-xterm") 109 (set! fullrunscript "xterm") 111 (set! fullrunscript "xterm") 110 (if (and fullrunscript (not (file-execute-access? fullrunscript))) 112 (if (and fullrunscript (not (file-execute-access? fullrunscript))) 111 (system (conc "chmod ug+x " fullrunscript)))) 113 (system (conc "chmod ug+x " fullrunscript)))) 112 ;; We are about to actually kick off the test 114 ;; We are about to actually kick off the test 113 ;; so this is a good place to remove the records for 115 ;; so this is a good place to remove the records for 114 ;; any previous runs 116 ;; any previous runs ................................................................................................................................................................................ 182 ;; (set! script (conc s 184 ;; (set! script (conc s 183 185 184 ;; call the command using mt_ 186 ;; call the command using mt_ 185 (set! script (conc "mt_ezstep 187 (set! script (conc "mt_ezstep 186 188 187 (debug:print 4 "script: " scr 189 (debug:print 4 "script: " scr 188 190 189 (rdb:teststep-set-status! db | 191 (rdb:teststep-set-status! db 190 ;; now launch 192 ;; now launch 191 (let ((pid (process-run scrip 193 (let ((pid (process-run scrip 192 (let processloop ((i 0)) 194 (let processloop ((i 0)) 193 (let-values (((pid-val ex 195 (let-values (((pid-val ex 194 (mutex-lock! 196 (mutex-lock! 195 (vector-set! 197 (vector-set! 196 (vector-set! 198 (vector-set! ................................................................................................................................................................................ 197 (vector-set! 199 (vector-set! 198 (mutex-unlock 200 (mutex-unlock 199 (if (eq? pid- 201 (if (eq? pid- 200 (begin 202 (begin 201 (thread 203 (thread 202 (proces 204 (proces 203 )) 205 )) > 206 (let ((exinfo (vector-ref e 204 (rdb:teststep-set-status! d | 207 (logfna (if logpro-us > 208 ;; testing if procedures > 209 (rdb:teststep-set-status 205 (if logpro-used 210 (if logpro-used 206 (test-set-log! db run-i | 211 (rdb:test-set-log! db t 207 ;; set the test final statu 212 ;; set the test final statu 208 (let* ((this-step-status (c 213 (let* ((this-step-status (c 209 ( 214 ( 210 ( 215 ( 211 ( 216 ( 212 (overall-status (c 217 (overall-status (c 213 ( 218 ( ................................................................................................................................................................................ 221 (debug:print 4 "Exit valu 226 (debug:print 4 "Exit valu 222 " this-step- 227 " this-step- 223 " next-statu 228 " next-statu 224 (case next-status 229 (case next-status 225 ((warn) 230 ((warn) 226 (set! rollup-status 2) 231 (set! rollup-status 2) 227 ;; NB// test-set-statu 232 ;; NB// test-set-statu 228 (test-set-status! db r | 233 (test-set-status! db t 229 (if 234 (if 230 #f)) 235 #f)) 231 ((pass) 236 ((pass) 232 (test-set-status! db r | 237 (test-set-status! db t 233 (else ;; 'fail 238 (else ;; 'fail 234 (set! rollup-status 1) 239 (set! rollup-status 1) 235 (test-set-status! db r | 240 (test-set-status! db t 236 )))) 241 )))) 237 (if (and (steprun-good? logpr 242 (if (and (steprun-good? logpr 238 (not (null? tal))) 243 (not (null? tal))) 239 (loop (car tal) (cdr tal) 244 (loop (car tal) (cdr tal) 240 (debug:print 4 "WARNING: a prior st 245 (debug:print 4 "WARNING: a prior st 241 (monitorjob (lambda () 246 (monitorjob (lambda () 242 (let* ((start-seconds (current-seconds)) 247 (let* ((start-seconds (current-seconds)) ................................................................................................................................................................................ 276 (begin 281 (begin 277 (debug:print 0 282 (debug:print 0 278 (system (conc 283 (system (conc 279 (car processes)) 284 (car processes)) 280 (system (conc "kill -9 " 285 (system (conc "kill -9 " 281 (begin 286 (begin 282 (debug:print 0 "WARNING: Re 287 (debug:print 0 "WARNING: Re 283 (test-set-status! db run-id | 288 (test-set-status! db test-i 284 itemdat ( | 289 (args:get 285 (sqlite3:finalize! db) 290 (sqlite3:finalize! db) 286 (exit 1)))) 291 (exit 1)))) 287 (set! kill-tries (+ 1 kill-tries)) 292 (set! kill-tries (+ 1 kill-tries)) 288 (mutex-unlock! m))) 293 (mutex-unlock! m))) 289 (sqlite3:finalize! db) 294 (sqlite3:finalize! db) 290 (thread-sleep! (+ 10 (random 10))) ;; add 295 (thread-sleep! (+ 10 (random 10))) ;; add 291 (loop (calc-minutes))))))) 296 (loop (calc-minutes))))))) ................................................................................................................................................................................ 296 (thread-start! th2) 301 (thread-start! th2) 297 (thread-join! th2) 302 (thread-join! th2) 298 (mutex-lock! m) 303 (mutex-lock! m) 299 (set! db (open-db)) 304 (set! db (open-db)) 300 (if (not (args:get-arg "-server")) 305 (if (not (args:get-arg "-server")) 301 (server:client-setup db)) 306 (server:client-setup db)) 302 (let* ((item-path (item-list->path itemdat)) 307 (let* ((item-path (item-list->path itemdat)) 303 (testinfo (db:get-test-info db run-id test-name item-path))) | 308 (testinfo (rdb:get-test-info db run-id test-name item-path)) 304 (if (not (equal? (db:test-get-state testinfo) "COMPLETED")) 309 (if (not (equal? (db:test-get-state testinfo) "COMPLETED")) 305 (begin 310 (begin 306 (debug:print 2 "Test NOT logged as COMPLETED, (state=" (db:t 311 (debug:print 2 "Test NOT logged as COMPLETED, (state=" (db:t 307 (test-set-status! db run-id test-name | 312 (test-set-status! db test-id 308 (if kill-job? "KILLED" "COMPLETED") 313 (if kill-job? "KILLED" "COMPLETED") 309 ;; Old logic: 314 ;; Old logic: 310 ;; (if (vector-ref exit-info 1) ;; look at 315 ;; (if (vector-ref exit-info 1) ;; look at 311 ;; (if (and (not kill-job?) 316 ;; (if (and (not kill-job?) 312 ;; (eq? (vector-ref exit-info 2) 0 317 ;; (eq? (vector-ref exit-info 2) 0 313 ;; "PASS" 318 ;; "PASS" 314 ;; "FAIL") 319 ;; "FAIL") ................................................................................................................................................................................ 320 ;; if the current status is AUTO the def 325 ;; if the current status is AUTO the def 321 (if (equal? (db:test-get-status testinfo 326 (if (equal? (db:test-get-status testinfo 322 ((eq? rollup-status 1) "FAIL") 327 ((eq? rollup-status 1) "FAIL") 323 ((eq? rollup-status 2) 328 ((eq? rollup-status 2) 324 ;; if the current status is AUTO the def 329 ;; if the current status is AUTO the def 325 (if (equal? (db:test-get-status testinfo 330 (if (equal? (db:test-get-status testinfo 326 (else "FAIL")) 331 (else "FAIL")) 327 itemdat (args:get-arg "-m") #f))) | 332 (args:get-arg "-m") #f))) 328 ;; for automated creation of the rollup html file this is a good p 333 ;; for automated creation of the rollup html file this is a good p 329 (if (not (equal? item-path "")) 334 (if (not (equal? item-path "")) 330 (tests:summarize-items db run-id test-name #f)) ;; don't force 335 (tests:summarize-items db run-id test-name #f)) ;; don't force 331 ) 336 ) 332 (mutex-unlock! m) 337 (mutex-unlock! m) 333 ;; (exec-results (cmd-run->list fullrunscript)) ;; (list ">" (conc 338 ;; (exec-results (cmd-run->list fullrunscript)) ;; (list ">" (conc 334 ;; (success exec-results)) ;; (eq? (cadr exec-results) 0))) 339 ;; (success exec-results)) ;; (eq? (cadr exec-results) 0))) ................................................................................................................................................................................ 428 ;; 3. create link from run dir to megatest runs area 433 ;; 3. create link from run dir to megatest runs area 429 ;; 4. remotely run the test on allocated host 434 ;; 4. remotely run the test on allocated host 430 ;; - could be ssh to host from hosts table (update regularly with load) 435 ;; - could be ssh to host from hosts table (update regularly with load) 431 ;; - could be netbatch 436 ;; - could be netbatch 432 ;; (launch-test db (cadr status) test-conf)) 437 ;; (launch-test db (cadr status) test-conf)) 433 (define (launch-test db run-id runname test-conf keyvallst test-name test-path i 438 (define (launch-test db run-id runname test-conf keyvallst test-name test-path i 434 (change-directory *toppath*) 439 (change-directory *toppath*) 435 (let ((useshell (config-lookup *configdat* "jobtools" "useshell")) | 440 (let* ((useshell (config-lookup *configdat* "jobtools" "useshell")) 436 (launcher (config-lookup *configdat* "jobtools" "launcher")) 441 (launcher (config-lookup *configdat* "jobtools" "launcher")) 437 (runscript (config-lookup test-conf "setup" "runscript")) 442 (runscript (config-lookup test-conf "setup" "runscript")) 438 (ezsteps (> (length (hash-table-ref/default test-conf "ezsteps" '())) 443 (ezsteps (> (length (hash-table-ref/default test-conf "ezsteps" '())) 439 (diskspace (config-lookup test-conf "requirements" "diskspace")) 444 (diskspace (config-lookup test-conf "requirements" "diskspace")) 440 (memory (config-lookup test-conf "requirements" "memory")) 445 (memory (config-lookup test-conf "requirements" "memory")) 441 (hosts (config-lookup *configdat* "jobtools" "workhosts")) 446 (hosts (config-lookup *configdat* "jobtools" "workhosts")) 442 (remote-megatest (config-lookup *configdat* "setup" "executable")) 447 (remote-megatest (config-lookup *configdat* "setup" "executable")) 443 ;; FIXME SOMEDAY: not good how this is so obtuse, this hack is to 448 ;; FIXME SOMEDAY: not good how this is so obtuse, this hack is to 444 ;; allow running from dashboard | 449 ;; allow running from dashboard. Extract the path > 450 ;; from the called megatest and convert dashboard > 451 ;; or dboard to megatest 445 (local-megatest (let* ((lm (car (argv))) 452 (local-megatest (let* ((lm (car (argv))) 446 (dir (pathname-directory lm)) 453 (dir (pathname-directory lm)) 447 (exe (pathname-strip-directory lm))) 454 (exe (pathname-strip-directory lm))) 448 (conc (if dir (conc dir "/") "") 455 (conc (if dir (conc dir "/") "") 449 (case (string->symbol exe) 456 (case (string->symbol exe) 450 ((dboard) "megatest") 457 ((dboard) "megatest") 451 ((dashboard) "megatest") 458 ((dashboard) "megatest") 452 (else exe))))) 459 (else exe))))) 453 (test-sig (conc "=" test-name ":" (item-list->path itemdat) "=")) ;; t | 460 (test-sig (conc test-name ":" (item-list->path itemdat))) ;; test-path 454 (work-area #f) 461 (work-area #f) 455 (toptest-work-area #f) ;; for iterated tests the top test contains data 462 (toptest-work-area #f) ;; for iterated tests the top test contains data 456 (diskpath #f) 463 (diskpath #f) 457 (cmdparms #f) 464 (cmdparms #f) 458 (fullcmd #f) ;; (define a (with-output-to-string (lambda ()(write x)) 465 (fullcmd #f) ;; (define a (with-output-to-string (lambda ()(write x)) 459 (mt-bindir-path #f)) | 466 (mt-bindir-path #f) > 467 (item-path (item-list->path itemdat)) > 468 (testinfo (rdb:get-test-info db run-id test-name item-path)) > 469 (test-id (db:test-get-id testinfo))) 460 (if hosts (set! hosts (string-split hosts))) | 470 (if hosts (set! hosts (string-split hosts))) > 471 ;; set the megatest to be called on the remote host 461 (if (not remote-megatest)(set! remote-megatest local-megatest)) ;; "megatest 472 (if (not remote-megatest)(set! remote-megatest local-megatest)) ;; "megatest 462 (set! mt-bindir-path (pathname-directory remote-megatest)) 473 (set! mt-bindir-path (pathname-directory remote-megatest)) 463 (if launcher (set! launcher (string-split launcher))) 474 (if launcher (set! launcher (string-split launcher))) 464 ;; set up the run work area for this test 475 ;; set up the run work area for this test 465 (set! diskpath (get-best-disk *configdat*)) 476 (set! diskpath (get-best-disk *configdat*)) 466 (if diskpath 477 (if diskpath 467 (let ((dat (create-work-area db run-id test-path diskpath test-name ite 478 (let ((dat (create-work-area db run-id test-path diskpath test-name ite ................................................................................................................................................................................ 474 (set! cmdparms (base64:base64-encode (with-output-to-string 485 (set! cmdparms (base64:base64-encode (with-output-to-string 475 (lambda () ;; (list 'hosts hosts) 486 (lambda () ;; (list 'hosts hosts) 476 (write (list (list 'testpath test-path) 487 (write (list (list 'testpath test-path) 477 (list 'work-area work-area) 488 (list 'work-area work-area) 478 (list 'test-name test-name) 489 (list 'test-name test-name) 479 (list 'runscript runscript) 490 (list 'runscript runscript) 480 (list 'run-id run-id ) 491 (list 'run-id run-id ) > 492 (list 'test-id test-id ) 481 (list 'itemdat itemdat ) 493 (list 'itemdat itemdat ) 482 (list 'megatest remote-megat 494 (list 'megatest remote-megat 483 (list 'ezsteps ezsteps) 495 (list 'ezsteps ezsteps) 484 (list 'env-ovrd (hash-table- 496 (list 'env-ovrd (hash-table- 485 (list 'set-vars (if params ( 497 (list 'set-vars (if params ( 486 (list 'runname runname) 498 (list 'runname runname) 487 (list 'mt-bindir-path mt-bind 499 (list 'mt-bindir-path mt-bind ................................................................................................................................................................................ 494 (launcher 506 (launcher 495 (set! fullcmd (append launcher (list remote-megatest test-sig "-execute" c 507 (set! fullcmd (append launcher (list remote-megatest test-sig "-execute" c 496 (else 508 (else 497 (if (not useshell)(debug:print 0 "WARNING: internal launching will not wor 509 (if (not useshell)(debug:print 0 "WARNING: internal launching will not wor 498 (set! fullcmd (list remote-megatest test-sig "-execute" cmdparms (if usesh 510 (set! fullcmd (list remote-megatest test-sig "-execute" cmdparms (if usesh 499 (if (args:get-arg "-xterm")(set! fullcmd (append fullcmd (list "-xterm")))) 511 (if (args:get-arg "-xterm")(set! fullcmd (append fullcmd (list "-xterm")))) 500 (debug:print 1 "Launching megatest for test " test-name " in " work-area" .. 512 (debug:print 1 "Launching megatest for test " test-name " in " work-area" .. 501 (test-set-status! db run-id test-name "LAUNCHED" "n/a" itemdat #f #f) ;; (if | 513 (test-set-status! db test-id "LAUNCHED" "n/a" #f #f) ;; (if launch-results l 502 ;; set < 503 ;; set pre-launch-env-vars before launching, keep the vars in prevvals and p 514 ;; set pre-launch-env-vars before launching, keep the vars in prevvals and p 504 (debug:print 4 "fullcmd: " fullcmd) 515 (debug:print 4 "fullcmd: " fullcmd) 505 (let* ((commonprevvals (alist->env-vars 516 (let* ((commonprevvals (alist->env-vars 506 (hash-table-ref/default *configdat* "env-override" ' 517 (hash-table-ref/default *configdat* "env-override" ' 507 (testprevvals (alist->env-vars 518 (testprevvals (alist->env-vars 508 (hash-table-ref/default test-conf "pre-launch-env-ov 519 (hash-table-ref/default test-conf "pre-launch-env-ov 509 (miscprevvals (alist->env-vars ;; consolidate this code with the co 520 (miscprevvals (alist->env-vars ;; consolidate this code with the co ................................................................................................................................................................................ 516 (string-intersperse fullcmd " ") 527 (string-intersperse fullcmd " ") 517 (car fullcmd)) 528 (car fullcmd)) 518 print 529 print 519 (if useshell 530 (if useshell 520 '() 531 '() 521 (cdr fullcmd))))) ;; launcher fullcmd))); 532 (cdr fullcmd))))) ;; launcher fullcmd))); 522 (debug:print 2 "Launching completed, updating db") 533 (debug:print 2 "Launching completed, updating db") 523 (debug:print 4 "Launch results: " launch-results) | 534 (debug:print 2 "Launch results: " launch-results) 524 (if (not launch-results) 535 (if (not launch-results) 525 (begin 536 (begin 526 (print "ERROR: Failed to run " (string-intersperse fullcmd " ") ", e 537 (print "ERROR: Failed to run " (string-intersperse fullcmd " ") ", e 527 (sqlite3:finalize! db) 538 (sqlite3:finalize! db) 528 ;; good ole "exit" seems not to work 539 ;; good ole "exit" seems not to work 529 ;; (_exit 9) 540 ;; (_exit 9) 530 ;; but this hack will work! Thanks go to Alan Post of the Chicken em 541 ;; but this hack will work! Thanks go to Alan Post of the Chicken em

Modified megatest.scm from [91d562ec2adc6950] to [58ffc597e072ad12].

6 ;; This program is distributed WITHOUT ANY WARRANTY; without even the 6 ;; This program is distributed WITHOUT ANY WARRANTY; without even the 7 ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR 7 ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR 8 ;; PURPOSE. 8 ;; PURPOSE. 9 9 10 ;; (include "common.scm") 10 ;; (include "common.scm") 11 ;; (include "megatest-version.scm") 11 ;; (include "megatest-version.scm") 12 12 13 (use sqlite3 srfi-1 posix regex regex-case srfi-69 base64 format readline apropo | 13 (use sqlite3 srfi-1 posix regex regex-case srfi-69 base64 format readline apropo 14 (import (prefix sqlite3 sqlite3:)) 14 (import (prefix sqlite3 sqlite3:)) 15 (import (prefix base64 base64:)) 15 (import (prefix base64 base64:)) 16 16 17 (declare (uses common)) 17 (declare (uses common)) 18 (declare (uses megatest-version)) 18 (declare (uses megatest-version)) 19 (declare (uses margs)) 19 (declare (uses margs)) 20 (declare (uses runs)) 20 (declare (uses runs)) 21 (declare (uses launch)) 21 (declare (uses launch)) 22 (declare (uses server)) 22 (declare (uses server)) > 23 (declare (uses tests)) 23 24 24 (define *db* #f) ;; this is only for the repl, do not use in general!!!! 25 (define *db* #f) ;; this is only for the repl, do not use in general!!!! 25 26 26 (include "common_records.scm") 27 (include "common_records.scm") 27 (include "key_records.scm") 28 (include "key_records.scm") 28 (include "db_records.scm") 29 (include "db_records.scm") 29 30 ................................................................................................................................................................................ 159 ;; misc 160 ;; misc 160 "-server" 161 "-server" 161 "-extract-ods" 162 "-extract-ods" 162 "-pathmod" 163 "-pathmod" 163 "-env2file" 164 "-env2file" 164 "-setvars" 165 "-setvars" 165 "-debug" ;; for *verbosity* > 2 166 "-debug" ;; for *verbosity* > 2 > 167 "-override-timeout" 166 ) 168 ) 167 (list "-h" 169 (list "-h" 168 "-force" 170 "-force" 169 "-xterm" 171 "-xterm" 170 "-showkeys" 172 "-showkeys" 171 "-test-status" 173 "-test-status" 172 "-set-values" 174 "-set-values" ................................................................................................................................................................................ 335 ;; Start the server - can be done in conjunction with -runall or -runtests (one 337 ;; Start the server - can be done in conjunction with -runall or -runtests (one 336 ;;====================================================================== 338 ;;====================================================================== 337 (if (and (args:get-arg "-server") 339 (if (and (args:get-arg "-server") 338 (not (or (args:get-arg "-runall") 340 (not (or (args:get-arg "-runall") 339 (args:get-arg "-runtests")))) 341 (args:get-arg "-runtests")))) 340 (let* ((toppath (setup-for-run)) 342 (let* ((toppath (setup-for-run)) 341 (db (if toppath (open-db) #f))) 343 (db (if toppath (open-db) #f))) > 344 (debug:print 0 "INFO: Starting the standalone server") 342 (if db 345 (if db > 346 (let* ((host:port (db:get-var db "SERVER")) ;; this doen't support mul 343 (server:start db (args:get-arg "-server")) | 347 (th2 (server:start db (args:get-arg "-server"))) > 348 (th3 (make-thread (lambda () > 349 (server:keep-running db))))) > 350 (thread-start! th3) > 351 (thread-join! th3)) 344 (debug:print 0 "ERROR: Failed to setup for megatest")))) 352 (debug:print 0 "ERROR: Failed to setup for megatest")))) 345 353 346 ;;====================================================================== 354 ;;====================================================================== 347 ;; full run 355 ;; full run 348 ;;====================================================================== 356 ;;====================================================================== 349 357 350 ;; get lock in db for full run for this directory 358 ;; get lock in db for full run for this directory ................................................................................................................................................................................ 453 (exit 1))) 461 (exit 1))) 454 (set! db (open-db)) 462 (set! db (open-db)) 455 (if (not (args:get-arg "-server")) 463 (if (not (args:get-arg "-server")) 456 (server:client-setup db)) 464 (server:client-setup db)) 457 (let* ((itempatt (args:get-arg "-itempatt")) 465 (let* ((itempatt (args:get-arg "-itempatt")) 458 (keys (rdb:get-keys db)) 466 (keys (rdb:get-keys db)) 459 (keynames (map key:get-fieldname keys)) 467 (keynames (map key:get-fieldname keys)) 460 (paths (db:test-get-paths-matching db keynames target))) | 468 (paths (rdb:test-get-paths-matching db keynames target))) 461 (set! *didsomething* #t) 469 (set! *didsomething* #t) 462 (for-each (lambda (path) 470 (for-each (lambda (path) 463 (print path)) 471 (print path)) 464 paths))) 472 paths))) 465 ;; else do a general-run-call 473 ;; else do a general-run-call 466 (general-run-call 474 (general-run-call 467 "-test-paths" 475 "-test-paths" 468 "Get paths to tests" 476 "Get paths to tests" 469 (lambda (db target runname keys keynames keyvallst) 477 (lambda (db target runname keys keynames keyvallst) 470 (let* ((itempatt (args:get-arg "-itempatt")) 478 (let* ((itempatt (args:get-arg "-itempatt")) 471 (paths (db:test-get-paths-matching db keynames target))) | 479 (paths (rdb:test-get-paths-matching db keynames target))) 472 (for-each (lambda (path) 480 (for-each (lambda (path) 473 (print path)) 481 (print path)) 474 paths)))))) 482 paths)))))) 475 483 476 ;;====================================================================== 484 ;;====================================================================== 477 ;; Archive tests 485 ;; Archive tests 478 ;;====================================================================== 486 ;;====================================================================== ................................................................................................................................................................................ 560 (let* ((step (args:get-arg "-step")) 568 (let* ((step (args:get-arg "-step")) 561 (cmdinfo (read (open-input-string (base64:base64-decode (getenv 569 (cmdinfo (read (open-input-string (base64:base64-decode (getenv 562 (testpath (assoc/default 'testpath cmdinfo)) 570 (testpath (assoc/default 'testpath cmdinfo)) 563 (test-name (assoc/default 'test-name cmdinfo)) 571 (test-name (assoc/default 'test-name cmdinfo)) 564 (runscript (assoc/default 'runscript cmdinfo)) 572 (runscript (assoc/default 'runscript cmdinfo)) 565 (db-host (assoc/default 'db-host cmdinfo)) 573 (db-host (assoc/default 'db-host cmdinfo)) 566 (run-id (assoc/default 'run-id cmdinfo)) 574 (run-id (assoc/default 'run-id cmdinfo)) > 575 (test-id (assoc/default 'test-id cmdinfo)) 567 (itemdat (assoc/default 'itemdat cmdinfo)) 576 (itemdat (assoc/default 'itemdat cmdinfo)) 568 (db #f) 577 (db #f) 569 (state (args:get-arg ":state")) 578 (state (args:get-arg ":state")) 570 (status (args:get-arg ":status")) 579 (status (args:get-arg ":status")) 571 (logfile (args:get-arg "-setlog"))) 580 (logfile (args:get-arg "-setlog"))) 572 (change-directory testpath) 581 (change-directory testpath) 573 (if (not (setup-for-run)) 582 (if (not (setup-for-run)) ................................................................................................................................................................................ 574 (begin 583 (begin 575 (debug:print 0 "Failed to setup, exiting") 584 (debug:print 0 "Failed to setup, exiting") 576 (exit 1))) 585 (exit 1))) 577 (set! db (open-db)) 586 (set! db (open-db)) 578 (if (not (args:get-arg "-server")) 587 (if (not (args:get-arg "-server")) 579 (server:client-setup db)) 588 (server:client-setup db)) 580 (if (and state status) 589 (if (and state status) 581 (rdb:teststep-set-status! db run-id test-name step state status it | 590 (rdb:teststep-set-status! db test-id step state status itemdat (ar 582 (begin 591 (begin 583 (debug:print 0 "ERROR: You must specify :state and :status with 592 (debug:print 0 "ERROR: You must specify :state and :status with 584 (exit 6))) 593 (exit 6))) 585 (sqlite3:finalize! db) 594 (sqlite3:finalize! db) 586 (set! *didsomething* #t)))) 595 (set! *didsomething* #t)))) 587 596 588 (if (or (args:get-arg "-setlog") ;; since setting up is so costly lets pig 597 (if (or (args:get-arg "-setlog") ;; since setting up is so costly lets pig ................................................................................................................................................................................ 599 (let* ((startingdir (current-directory)) 608 (let* ((startingdir (current-directory)) 600 (cmdinfo (read (open-input-string (base64:base64-decode (getenv 609 (cmdinfo (read (open-input-string (base64:base64-decode (getenv 601 (testpath (assoc/default 'testpath cmdinfo)) 610 (testpath (assoc/default 'testpath cmdinfo)) 602 (test-name (assoc/default 'test-name cmdinfo)) 611 (test-name (assoc/default 'test-name cmdinfo)) 603 (runscript (assoc/default 'runscript cmdinfo)) 612 (runscript (assoc/default 'runscript cmdinfo)) 604 (db-host (assoc/default 'db-host cmdinfo)) 613 (db-host (assoc/default 'db-host cmdinfo)) 605 (run-id (assoc/default 'run-id cmdinfo)) 614 (run-id (assoc/default 'run-id cmdinfo)) > 615 (test-id (assoc/default 'test-id cmdinfo)) 606 (itemdat (assoc/default 'itemdat cmdinfo)) 616 (itemdat (assoc/default 'itemdat cmdinfo)) 607 (db #f) 617 (db #f) 608 (state (args:get-arg ":state")) 618 (state (args:get-arg ":state")) 609 (status (args:get-arg ":status"))) 619 (status (args:get-arg ":status"))) 610 (change-directory testpath) 620 (change-directory testpath) 611 (if (not (setup-for-run)) 621 (if (not (setup-for-run)) 612 (begin 622 (begin 613 (debug:print 0 "Failed to setup, exiting") 623 (debug:print 0 "Failed to setup, exiting") 614 (exit 1))) 624 (exit 1))) 615 (set! db (open-db)) 625 (set! db (open-db)) 616 (if (not (args:get-arg "-server")) 626 (if (not (args:get-arg "-server")) 617 (server:client-setup db)) 627 (server:client-setup db)) 618 (if (args:get-arg "-load-test-data") 628 (if (args:get-arg "-load-test-data") > 629 ;; has sub commands that are rdb: 619 (db:load-test-data db run-id test-name itemdat)) | 630 (db:load-test-data db test-id)) 620 (if (args:get-arg "-setlog") 631 (if (args:get-arg "-setlog") 621 (test-set-log! db run-id test-name itemdat (args:get-arg "-setlog" | 632 (rtests:test-set-log! db test-id (args:get-arg "-setlog"))) 622 (if (args:get-arg "-set-toplog") 633 (if (args:get-arg "-set-toplog") 623 (test-set-toplog! db run-id test-name (args:get-arg "-set-toplog") | 634 (rtests:test-set-toplog! db run-id test-name (args:get-arg "-set-t 624 (if (args:get-arg "-summarize-items") 635 (if (args:get-arg "-summarize-items") 625 (tests:summarize-items db run-id test-name #t)) ;; do force here | 636 (rdb:tests:summarize-items db run-id test-name #t)) ;; do force he 626 (if (args:get-arg "-runstep") 637 (if (args:get-arg "-runstep") 627 (if (null? remargs) 638 (if (null? remargs) 628 (begin 639 (begin 629 (debug:print 0 "ERROR: nothing specified to run!") 640 (debug:print 0 "ERROR: nothing specified to run!") 630 (sqlite3:finalize! db) 641 (sqlite3:finalize! db) 631 (exit 6)) 642 (exit 6)) 632 (let* ((stepname (args:get-arg "-runstep")) 643 (let* ((stepname (args:get-arg "-runstep")) ................................................................................................................................................................................ 634 (logfile (conc stepname ".log")) 645 (logfile (conc stepname ".log")) 635 (cmd (if (null? remargs) #f (car remargs))) 646 (cmd (if (null? remargs) #f (car remargs))) 636 (params (if cmd (cdr remargs) '())) 647 (params (if cmd (cdr remargs) '())) 637 (exitstat #f) 648 (exitstat #f) 638 (shell (last (string-split (get-environment-variab 649 (shell (last (string-split (get-environment-variab 639 (redir (case (string->symbol shell) 650 (redir (case (string->symbol shell) 640 ((tcsh csh ksh) ">&") 651 ((tcsh csh ksh) ">&") 641 ((zsh bash sh ash) "2>&1 >"))) | 652 ((zsh bash sh ash) "2>&1 >") > 653 (else ">&"))) 642 (fullcmd (conc "(" (string-intersperse 654 (fullcmd (conc "(" (string-intersperse 643 (cons cmd params) " ") 655 (cons cmd params) " ") 644 ") " redir " " logfile))) 656 ") " redir " " logfile))) 645 ;; mark the start of the test 657 ;; mark the start of the test 646 (rdb:teststep-set-status! db run-id test-name stepname "star | 658 (rdb:teststep-set-status! db test-id stepname "start" "n/a" 647 ;; close the db 659 ;; close the db 648 (sqlite3:finalize! db) | 660 ;; (sqlite3:finalize! db) 649 ;; run the test step 661 ;; run the test step 650 (debug:print 2 "INFO: Running \"" fullcmd "\"") 662 (debug:print 2 "INFO: Running \"" fullcmd "\"") 651 (change-directory startingdir) 663 (change-directory startingdir) 652 (set! exitstat (system fullcmd)) ;; cmd params)) 664 (set! exitstat (system fullcmd)) ;; cmd params)) 653 (set! *globalexitstatus* exitstat) 665 (set! *globalexitstatus* exitstat) 654 (change-directory testpath) 666 (change-directory testpath) 655 ;; re-open the db 667 ;; re-open the db 656 (set! db (open-db)) | 668 ;; (set! db (open-db)) 657 (if (not (args:get-arg "-server")) | 669 ;; (if (not (args:get-arg "-server")) 658 (server:client-setup db)) | 670 ;; (server:client-setup db)) 659 ;; run logpro if applicable ;; (process-run "ls" (list "/foo 671 ;; run logpro if applicable ;; (process-run "ls" (list "/foo 660 (if logprofile 672 (if logprofile 661 (let* ((htmllogfile (conc stepname ".html")) 673 (let* ((htmllogfile (conc stepname ".html")) 662 (oldexitstat exitstat) 674 (oldexitstat exitstat) 663 (cmd (string-intersperse (list "logpro" l 675 (cmd (string-intersperse (list "logpro" l 664 (debug:print 2 "INFO: running \"" cmd "\"") 676 (debug:print 2 "INFO: running \"" cmd "\"") 665 (change-directory startingdir) 677 (change-directory startingdir) 666 (set! exitstat (system cmd)) 678 (set! exitstat (system cmd)) 667 (set! *globalexitstatus* exitstat) ;; no necessary 679 (set! *globalexitstatus* exitstat) ;; no necessary 668 (change-directory testpath) 680 (change-directory testpath) 669 (test-set-log! db run-id test-name itemdat htmllogfile | 681 (rdb:test-set-log! db test-id htmllogfile))) > 682 (let ((msg (args:get-arg "-m"))) 670 (rdb:teststep-set-status! db run-id test-name stepname "end" | 683 (rdb:teststep-set-status! db test-id stepname "end" exitst 671 (sqlite3:finalize! db) | 684 ;; (sqlite3:finalize! db) 672 (if (not (eq? exitstat 0)) | 685 ;;(if (not (eq? exitstat 0)) 673 (exit 254)) ;; (exit exitstat) doesn't work?!? | 686 ;; (exit 254)) ;; (exit exitstat) doesn't work?!? 674 ;; open the db 687 ;; open the db 675 ;; mark the end of the test 688 ;; mark the end of the test 676 ))) 689 ))) 677 (if (or (args:get-arg "-test-status") 690 (if (or (args:get-arg "-test-status") 678 (args:get-arg "-set-values")) 691 (args:get-arg "-set-values")) 679 (let ((newstatus (cond 692 (let ((newstatus (cond 680 ((number? status) (if (equal? status 0) "P 693 ((number? status) (if (equal? status 0) "P ................................................................................................................................................................................ 692 (if (and (args:get-arg "-test-status") 705 (if (and (args:get-arg "-test-status") 693 (or (not state) 706 (or (not state) 694 (not status))) 707 (not status))) 695 (begin 708 (begin 696 (debug:print 0 "ERROR: You must specify :state and :status 709 (debug:print 0 "ERROR: You must specify :state and :status 697 (sqlite3:finalize! db) 710 (sqlite3:finalize! db) 698 (exit 6))) 711 (exit 6))) 699 (test-set-status! db run-id test-name state newstatus itemdat (a | 712 (let ((msg (args:get-arg "-m"))) > 713 (rtests:test-set-status! db test-id state newstatus msg otherd 700 (sqlite3:finalize! db) 714 (sqlite3:finalize! db) 701 (set! *didsomething* #t)))) 715 (set! *didsomething* #t)))) 702 716 703 (if (args:get-arg "-showkeys") 717 (if (args:get-arg "-showkeys") 704 (let ((db #f) 718 (let ((db #f) 705 (keys #f)) 719 (keys #f)) 706 (if (not (setup-for-run)) 720 (if (not (setup-for-run))

Modified runs.scm from [25e1315b1dabc15b] to [c9cc30bbd7dfff43].

6 ;; 6 ;; 7 ;; This program is distributed WITHOUT ANY WARRANTY; without even the 7 ;; This program is distributed WITHOUT ANY WARRANTY; without even the 8 ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR 8 ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR 9 ;; PURPOSE. 9 ;; PURPOSE. 10 10 11 ;; strftime('%m/%d/%Y %H:%M:%S','now','localtime') 11 ;; strftime('%m/%d/%Y %H:%M:%S','now','localtime') 12 12 13 (use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking) | 13 (use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking (srfi 18)) 14 (import (prefix sqlite3 sqlite3:)) 14 (import (prefix sqlite3 sqlite3:)) 15 15 16 (declare (unit runs)) 16 (declare (unit runs)) 17 (declare (uses db)) 17 (declare (uses db)) 18 (declare (uses common)) 18 (declare (uses common)) 19 (declare (uses items)) 19 (declare (uses items)) 20 (declare (uses runconfig)) 20 (declare (uses runconfig)) ................................................................................................................................................................................ 257 (if (not (null? remtests)) 257 (if (not (null? remtests)) 258 (loop (car remtests)(cdr remtests))))))) 258 (loop (car remtests)(cdr remtests))))))) 259 259 260 (if (not (null? required-tests)) 260 (if (not (null? required-tests)) 261 (debug:print 1 "INFO: Adding " required-tests " to the run queue")) 261 (debug:print 1 "INFO: Adding " required-tests " to the run queue")) 262 ;; NOTE: these are all parent tests, items are not expanded yet. 262 ;; NOTE: these are all parent tests, items are not expanded yet. 263 (runs:run-tests-queue db run-id runname test-records keyvallst flags) 263 (runs:run-tests-queue db run-id runname test-records keyvallst flags) > 264 (if *rpc:listener* (server:keep-running db)) 264 (debug:print 4 "INFO: All done by here"))) 265 (debug:print 4 "INFO: All done by here"))) 265 266 266 (define (runs:run-tests-queue db run-id runname test-records keyvallst flags) 267 (define (runs:run-tests-queue db run-id runname test-records keyvallst flags) 267 ;; At this point the list of parent tests is expanded 268 ;; At this point the list of parent tests is expanded 268 ;; NB// Should expand items here and then insert into the run queue. 269 ;; NB// Should expand items here and then insert into the run queue. 269 (debug:print 5 "test-records: " test-records ", keyvallst: " keyvallst) 270 (debug:print 5 "test-records: " test-records ", keyvallst: " keyvallst) 270 (let ((sorted-test-names (tests:sort-by-priority-and-waiton test-records)) 271 (let ((sorted-test-names (tests:sort-by-priority-and-waiton test-records)) ................................................................................................................................................................................ 360 (debug:print 0 "ERROR: Should not have a list of items in a test and t 361 (debug:print 0 "ERROR: Should not have a list of items in a test and t 361 (exit 1)))) 362 (exit 1)))) 362 363 363 ;; we get here on "drop through" - loop for next test in queue 364 ;; we get here on "drop through" - loop for next test in queue 364 (if (null? tal) 365 (if (null? tal) 365 (begin 366 (begin 366 ;; FIXME!!!! THIS SHOULD NOT REQUIRE AN EXIT!!!!!!! 367 ;; FIXME!!!! THIS SHOULD NOT REQUIRE AN EXIT!!!!!!! 367 (debug:print 1 "INFO: All tests launched, exiting") | 368 (debug:print 1 "INFO: All tests launched") 368 (exit 0)) | 369 ;; (exit 0) > 370 ) 369 (loop (car tal)(cdr tal)))))) 371 (loop (car tal)(cdr tal)))))) 370 372 371 ;; parent-test is there as a placeholder for when parent-tests can be run as a s 373 ;; parent-test is there as a placeholder for when parent-tests can be run as a s 372 (define (run:test db run-id runname keyvallst test-record flags parent-test) 374 (define (run:test db run-id runname keyvallst test-record flags parent-test) 373 ;; All these vars might be referenced by the testconfig file reader 375 ;; All these vars might be referenced by the testconfig file reader 374 (let* ((test-name (tests:testqueue-get-testname test-record)) 376 (let* ((test-name (tests:testqueue-get-testname test-record)) 375 (test-waitons (tests:testqueue-get-waitons test-record)) 377 (test-waitons (tests:testqueue-get-waitons test-record)) ................................................................................................................................................................................ 390 (debug:print 2 "Attempting to launch test " test-name "/" item-path) 392 (debug:print 2 "Attempting to launch test " test-name "/" item-path) 391 (setenv "MT_TEST_NAME" test-name) ;; 393 (setenv "MT_TEST_NAME" test-name) ;; 392 (setenv "MT_RUNNAME" runname) 394 (setenv "MT_RUNNAME" runname) 393 (set-megatest-env-vars db run-id) ;; these may be needed by the launching pr 395 (set-megatest-env-vars db run-id) ;; these may be needed by the launching pr 394 (change-directory *toppath*) 396 (change-directory *toppath*) 395 397 396 ;; Here is where the test_meta table is best updated 398 ;; Here is where the test_meta table is best updated > 399 ;; Yes, another use of a global for caching. Need a better way? > 400 (if (not (hash-table-ref/default *test-meta-updated* test-name #f)) > 401 (begin > 402 (hash-table-set! *test-meta-updated* test-name #t) 397 (runs:update-test_meta db test-name test-conf) | 403 (runs:update-test_meta db test-name test-conf))) 398 404 399 ;; (lambda (itemdat) ;;; ((ripeness "overripe") (temperature "cool") (season 405 ;; (lambda (itemdat) ;;; ((ripeness "overripe") (temperature "cool") (season 400 (let* ((new-test-path (string-intersperse (cons test-path (map cadr itemdat) 406 (let* ((new-test-path (string-intersperse (cons test-path (map cadr itemdat) 401 (new-test-name (if (equal? item-path "") test-name (conc test-name "/ 407 (new-test-name (if (equal? item-path "") test-name (conc test-name "/ 402 (testdat (db:get-test-info db run-id test-name item-path))) | 408 (testdat (db:get-test-info db run-id test-name item-path)) > 409 (test-id #f)) 403 (if (not testdat) 410 (if (not testdat) 404 (begin 411 (begin 405 ;; ensure that the path exists before registering the test 412 ;; ensure that the path exists before registering the test 406 ;; NOPE: Cannot! Don't know yet which disk area will be assigned.... 413 ;; NOPE: Cannot! Don't know yet which disk area will be assigned.... 407 ;; (system (conc "mkdir -p " new-test-path)) 414 ;; (system (conc "mkdir -p " new-test-path)) 408 (rtests:register-test db run-id test-name item-path) 415 (rtests:register-test db run-id test-name item-path) 409 (set! testdat (db:get-test-info db run-id test-name item-path)))) 416 (set! testdat (db:get-test-info db run-id test-name item-path)))) > 417 (set! test-id (db:test-get-id testdat)) 410 (change-directory test-path) 418 (change-directory test-path) 411 (case (if force ;; (args:get-arg "-force") 419 (case (if force ;; (args:get-arg "-force") 412 'NOT_STARTED 420 'NOT_STARTED 413 (if testdat 421 (if testdat 414 (string->symbol (test:get-state testdat)) 422 (string->symbol (test:get-state testdat)) 415 'failed-to-insert)) 423 'failed-to-insert)) 416 ((failed-to-insert) 424 ((failed-to-insert) ................................................................................................................................................................................ 447 (member (test:get-status testdat) '("FAIL" "n/a"))) 455 (member (test:get-status testdat) '("FAIL" "n/a"))) 448 (set! runflag #t)) 456 (set! runflag #t)) 449 (else (set! runflag #f))) 457 (else (set! runflag #f))) 450 (debug:print 6 "RUNNING => runflag: " runflag " STATE: " (test:get-st 458 (debug:print 6 "RUNNING => runflag: " runflag " STATE: " (test:get-st 451 (if (not runflag) 459 (if (not runflag) 452 (if (not parent-test) 460 (if (not parent-test) 453 (debug:print 1 "NOTE: Not starting test " new-test-name " as 461 (debug:print 1 "NOTE: Not starting test " new-test-name " as 454 "\" and status \"" (test:get-status testdat) "\" | 462 "\" and status \"" (test:get-status testdat) "\" > 463 "\" or -force to override")) 455 ;; NOTE: No longer be checking prerequisites here! Will never get 464 ;; NOTE: No longer be checking prerequisites here! Will never get 456 ;; already met. 465 ;; already met. 457 (if (not (launch-test db run-id runname test-conf keyvallst test- 466 (if (not (launch-test db run-id runname test-conf keyvallst test- 458 (begin 467 (begin 459 (print "ERROR: Failed to launch the test. Exiting as soon a 468 (print "ERROR: Failed to launch the test. Exiting as soon a 460 (set! *globalexitstatus* 1) ;; 469 (set! *globalexitstatus* 1) ;; 461 (process-signal (current-process-id) signal/kill)))))) 470 (process-signal (current-process-id) signal/kill)))))) ................................................................................................................................................................................ 463 (debug:print 1 "NOTE: " new-test-name " is already running or was expli 472 (debug:print 1 "NOTE: " new-test-name " is already running or was expli 464 ((LAUNCHED REMOTEHOSTSTART RUNNING) 473 ((LAUNCHED REMOTEHOSTSTART RUNNING) 465 (if (> (- (current-seconds)(+ (db:test-get-event_time testdat) 474 (if (> (- (current-seconds)(+ (db:test-get-event_time testdat) 466 (db:test-get-run_duration testdat))) 475 (db:test-get-run_duration testdat))) 467 600) ;; i.e. no update for more than 600 seconds 476 600) ;; i.e. no update for more than 600 seconds 468 (begin 477 (begin 469 (debug:print 0 "WARNING: Test " test-name " appears to be dead. F 478 (debug:print 0 "WARNING: Test " test-name " appears to be dead. F 470 (test-set-status! db run-id test-name "INCOMPLETE" "STUCK/DEAD" i | 479 (test-set-status! db test-id "INCOMPLETE" "STUCK/DEAD" "Test is s 471 (debug:print 2 "NOTE: " test-name " is already running"))) 480 (debug:print 2 "NOTE: " test-name " is already running"))) 472 (else (debug:print 0 "ERROR: Failed to launch test " new-test-name 481 (else (debug:print 0 "ERROR: Failed to launch test " new-test-name 473 482 474 ;;====================================================================== 483 ;;====================================================================== 475 ;; END OF NEW STUFF 484 ;; END OF NEW STUFF 476 ;;====================================================================== 485 ;;====================================================================== 477 486 ................................................................................................................................................................................ 569 578 570 ;; Since many calls to a run require pretty much the same setup 579 ;; Since many calls to a run require pretty much the same setup 571 ;; this wrapper is used to reduce the replication of code 580 ;; this wrapper is used to reduce the replication of code 572 (define (general-run-call switchname action-desc proc) 581 (define (general-run-call switchname action-desc proc) 573 (let ((runname (args:get-arg ":runname")) 582 (let ((runname (args:get-arg ":runname")) 574 (target (if (args:get-arg "-target") 583 (target (if (args:get-arg "-target") 575 (args:get-arg "-target") 584 (args:get-arg "-target") 576 (args:get-arg "-reqtarg")))) | 585 (args:get-arg "-reqtarg"))) > 586 (th1 #f)) 577 (cond 587 (cond 578 ((not target) 588 ((not target) 579 (debug:print 0 "ERROR: Missing required parameter for " switchname ", you 589 (debug:print 0 "ERROR: Missing required parameter for " switchname ", you 580 (exit 3)) 590 (exit 3)) 581 ((not runname) 591 ((not runname) 582 (debug:print 0 "ERROR: Missing required parameter for " switchname ", you 592 (debug:print 0 "ERROR: Missing required parameter for " switchname ", you 583 (exit 3)) 593 (exit 3)) ................................................................................................................................................................................ 585 (let ((db #f) 595 (let ((db #f) 586 (keys #f)) 596 (keys #f)) 587 (if (not (setup-for-run)) 597 (if (not (setup-for-run)) 588 (begin 598 (begin 589 (debug:print 0 "Failed to setup, exiting") 599 (debug:print 0 "Failed to setup, exiting") 590 (exit 1))) 600 (exit 1))) 591 (set! db (open-db)) 601 (set! db (open-db)) 592 (if (not (args:get-arg "-server")) | 602 (if (args:get-arg "-server") > 603 (server:start db (args:get-arg "-server")) > 604 (if (not (or (args:get-arg "-runall") > 605 (args:get-arg "-runtests"))) 593 (server:client-setup db)) | 606 (server:client-setup db))) 594 (set! keys (rdb:get-keys db)) 607 (set! keys (rdb:get-keys db)) 595 ;; have enough to process -target or -reqtarg here 608 ;; have enough to process -target or -reqtarg here 596 (if (args:get-arg "-reqtarg") 609 (if (args:get-arg "-reqtarg") 597 (let* ((runconfigf (conc *toppath* "/runconfigs.config")) ;; DO NOT 610 (let* ((runconfigf (conc *toppath* "/runconfigs.config")) ;; DO NOT 598 (runconfig (read-config runconfigf #f #f environ-patt: #f))) 611 (runconfig (read-config runconfigf #f #f environ-patt: #f))) 599 (if (hash-table-ref/default runconfig (args:get-arg "-reqtarg") #f 612 (if (hash-table-ref/default runconfig (args:get-arg "-reqtarg") #f 600 (keys:target-set-args keys (args:get-arg "-reqtarg") args:arg- 613 (keys:target-set-args keys (args:get-arg "-reqtarg") args:arg- ................................................................................................................................................................................ 609 (debug:print 0 "ERROR: Attempted to " action-desc " but run area c 622 (debug:print 0 "ERROR: Attempted to " action-desc " but run area c 610 (exit 1)) 623 (exit 1)) 611 ;; Extract out stuff needed in most or many calls 624 ;; Extract out stuff needed in most or many calls 612 ;; here then call proc 625 ;; here then call proc 613 (let* ((keynames (map key:get-fieldname keys)) 626 (let* ((keynames (map key:get-fieldname keys)) 614 (keyvallst (keys->vallist keys #t))) 627 (keyvallst (keys->vallist keys #t))) 615 (proc db target runname keys keynames keyvallst))) 628 (proc db target runname keys keynames keyvallst))) > 629 (if th1 (thread-join! th1)) 616 (sqlite3:finalize! db) 630 (sqlite3:finalize! db) 617 (set! *didsomething* #t)))))) 631 (set! *didsomething* #t)))))) 618 632 619 ;;====================================================================== 633 ;;====================================================================== 620 ;; Rollup runs 634 ;; Rollup runs 621 ;;====================================================================== 635 ;;====================================================================== 622 636

Modified server.scm from [5c480362d7bd1851] to [0c84f97116aeb7cb].

60 ;;====================================================================== 60 ;;====================================================================== 61 ;; db specials here 61 ;; db specials here 62 ;;====================================================================== 62 ;;====================================================================== 63 ;; ** set-tests-state-status 63 ;; ** set-tests-state-status 64 (rpc:publish-procedure! 64 (rpc:publish-procedure! 65 'rdb:set-tests-state-status 65 'rdb:set-tests-state-status 66 (lambda (run-id testnames currstate currstatus newstate newstatus) 66 (lambda (run-id testnames currstate currstatus newstate newstatus) > 67 (set! *last-db-access* (current-seconds)) 67 (db:set-tests-state-status db run-id testnames currstate currstatus newst 68 (db:set-tests-state-status db run-id testnames currstate currstatus newst 68 69 69 (rpc:publish-procedure! 70 (rpc:publish-procedure! 70 'rdb:teststep-set-status! 71 'rdb:teststep-set-status! 71 (lambda (run-id test-name teststep-name state-in status-in item-path commen | 72 (lambda (test-id teststep-name state-in status-in item-path comment logfile > 73 (set! *last-db-access* (current-seconds)) 72 (db:teststep-set-status! db run-id test-name teststep-name state-in statu | 74 (db:teststep-set-status! db test-id teststep-name state-in status-in item 73 75 74 (rpc:publish-procedure! 76 (rpc:publish-procedure! 75 'rdb:test-update-meta-info 77 'rdb:test-update-meta-info 76 (lambda (run-id testname item-path minutes cpuload diskfree tmpfree) 78 (lambda (run-id testname item-path minutes cpuload diskfree tmpfree) > 79 (set! *last-db-access* (current-seconds)) 77 (db:test-update-meta-info db run-id testname item-path minutes cpuload di 80 (db:test-update-meta-info db run-id testname item-path minutes cpuload di 78 81 79 (rpc:publish-procedure! 82 (rpc:publish-procedure! 80 'rdb:test-set-state-status-by-run-id-testname 83 'rdb:test-set-state-status-by-run-id-testname 81 (lambda (run-id test-name item-path status state) 84 (lambda (run-id test-name item-path status state) > 85 (set! *last-db-access* (current-seconds)) 82 (db:test-set-state-status-by-run-id-testname db run-id test-name item-pat 86 (db:test-set-state-status-by-run-id-testname db run-id test-name item-pat 83 87 84 (rpc:publish-procedure! 88 (rpc:publish-procedure! 85 'rdb:csv->test-data 89 'rdb:csv->test-data 86 (lambda (test-id csvdata) 90 (lambda (test-id csvdata) > 91 (set! *last-db-access* (current-seconds)) 87 (db:csv->data db test-id csvdata))) | 92 (db:csv->test-data db test-id csvdata))) 88 93 89 (rpc:publish-procedure! 94 (rpc:publish-procedure! 90 'rdb:roll-up-pass-fail-counts 95 'rdb:roll-up-pass-fail-counts 91 (lambda (run-id test-name item-path status) 96 (lambda (run-id test-name item-path status) > 97 (set! *last-db-access* (current-seconds)) 92 (db:roll-up-pass-fail-counts db run-id test-name item-path status))) 98 (db:roll-up-pass-fail-counts db run-id test-name item-path status))) 93 99 94 (rpc:publish-procedure! 100 (rpc:publish-procedure! 95 'rdb:test-set-comment 101 'rdb:test-set-comment 96 (lambda (run-id test-name item-path comment) 102 (lambda (run-id test-name item-path comment) > 103 (set! *last-db-access* (current-seconds)) 97 (db:test-set-comment db run-id test-name item-path comment))) 104 (db:test-set-comment db run-id test-name item-path comment))) 98 105 99 (rpc:publish-procedure! 106 (rpc:publish-procedure! 100 'rdb:test-set-log! 107 'rdb:test-set-log! 101 (lambda (run-id test-name item-path logf) | 108 (lambda (test-id logf) > 109 (set! *last-db-access* (current-seconds)) 102 (db:test-set-log! db run-id test-name item-path logf))) | 110 (db:test-set-log! db test-id logf))) 103 111 104 (rpc:publish-procedure! 112 (rpc:publish-procedure! 105 'rpc:get-test-data-by-id | 113 'rdb:get-test-data-by-id 106 (lambda (test-id) 114 (lambda (test-id) > 115 (set! *last-db-access* (current-seconds)) 107 (db:get-test-data-by-id db test-id))) 116 (db:get-test-data-by-id db test-id))) 108 117 109 (rpc:publish-procedure! 118 (rpc:publish-procedure! 110 'serve:get-toppath 119 'serve:get-toppath 111 (lambda () 120 (lambda () > 121 (set! *last-db-access* (current-seconds)) 112 *toppath*)) 122 *toppath*)) 113 123 114 (rpc:publish-procedure! 124 (rpc:publish-procedure! 115 'serve:login 125 'serve:login 116 (lambda (toppath) 126 (lambda (toppath) > 127 (set! *last-db-access* (current-seconds)) 117 (if (equal? *toppath* toppath) 128 (if (equal? *toppath* toppath) 118 (begin 129 (begin 119 (debug:print 2 "INFO: login successful") 130 (debug:print 2 "INFO: login successful") 120 #t) 131 #t) 121 #f))) 132 #f))) 122 133 123 (rpc:publish-procedure! 134 (rpc:publish-procedure! 124 'rdb:get-runs 135 'rdb:get-runs 125 (lambda (runnamepatt numruns startrunoffset keypatts) 136 (lambda (runnamepatt numruns startrunoffset keypatts) > 137 (set! *last-db-access* (current-seconds)) 126 (db:get-runs db runnamepatt numruns startrunoffset keypatts))) 138 (db:get-runs db runnamepatt numruns startrunoffset keypatts))) 127 139 128 (rpc:publish-procedure! 140 (rpc:publish-procedure! 129 'rdb:get-tests-for-run 141 'rdb:get-tests-for-run 130 (lambda (run-id testpatt itempatt states statuses) 142 (lambda (run-id testpatt itempatt states statuses) > 143 (set! *last-db-access* (current-seconds)) 131 (db:get-tests-for-run db run-id testpatt itempatt states statuses))) 144 (db:get-tests-for-run db run-id testpatt itempatt states statuses))) 132 145 133 (rpc:publish-procedure! 146 (rpc:publish-procedure! 134 'rdb:get-keys 147 'rdb:get-keys 135 (lambda () 148 (lambda () > 149 (set! *last-db-access* (current-seconds)) 136 (db:get-keys db))) 150 (db:get-keys db))) 137 151 138 (rpc:publish-procedure! 152 (rpc:publish-procedure! 139 'rdb:get-num-runs 153 'rdb:get-num-runs 140 (lambda (runpatt) 154 (lambda (runpatt) > 155 (set! *last-db-access* (current-seconds)) 141 (db:get-num-runs db runpatt))) 156 (db:get-num-runs db runpatt))) 142 157 143 (rpc:publish-procedure! 158 (rpc:publish-procedure! 144 'rdb:test-set-state-status-by-id 159 'rdb:test-set-state-status-by-id 145 (lambda (test-id newstate newstatus newcomment) 160 (lambda (test-id newstate newstatus newcomment) > 161 (set! *last-db-access* (current-seconds)) 146 (db:test-set-state-status-by-id db test-id newstate newstatus newcomment) 162 (db:test-set-state-status-by-id db test-id newstate newstatus newcomment) 147 163 148 (rpc:publish-procedure! 164 (rpc:publish-procedure! 149 'rdb:get-key-val-pairs 165 'rdb:get-key-val-pairs 150 (lambda (run-id) 166 (lambda (run-id) > 167 (set! *last-db-access* (current-seconds)) 151 (db:get-key-val-pairs db run-id))) 168 (db:get-key-val-pairs db run-id))) 152 169 153 (rpc:publish-procedure! 170 (rpc:publish-procedure! 154 'rdb:get-key-vals 171 'rdb:get-key-vals 155 (lambda (run-id) 172 (lambda (run-id) > 173 (set! *last-db-access* (current-seconds)) 156 (db:get-key-vals db run-id))) 174 (db:get-key-vals db run-id))) 157 175 158 (rpc:publish-procedure! 176 (rpc:publish-procedure! 159 'rdb:testmeta-get-record 177 'rdb:testmeta-get-record 160 (lambda (run-id) 178 (lambda (run-id) > 179 (set! *last-db-access* (current-seconds)) 161 (db:testmeta-get-record db run-id))) 180 (db:testmeta-get-record db run-id))) 162 181 163 (rpc:publish-procedure! 182 (rpc:publish-procedure! 164 'rdb:get-test-data-by-id 183 'rdb:get-test-data-by-id 165 (lambda (test-id) 184 (lambda (test-id) > 185 (set! *last-db-access* (current-seconds)) 166 (db:get-test-data-by-id db test-id))) 186 (db:get-test-data-by-id db test-id))) 167 187 168 (rpc:publish-procedure! 188 (rpc:publish-procedure! 169 'rdb:get-run-info 189 'rdb:get-run-info 170 (lambda (run-id) 190 (lambda (run-id) > 191 (set! *last-db-access* (current-seconds)) 171 (db:get-run-info db run-id))) 192 (db:get-run-info db run-id))) 172 193 173 (rpc:publish-procedure! 194 (rpc:publish-procedure! 174 'rdb:get-steps-for-test 195 'rdb:get-steps-for-test 175 (lambda (test-id) 196 (lambda (test-id) > 197 (set! *last-db-access* (current-seconds)) 176 (db:get-steps-for-test db test-id))) 198 (db:get-steps-for-test db test-id))) 177 199 178 (rpc:publish-procedure! 200 (rpc:publish-procedure! 179 'rdb:get-steps-table 201 'rdb:get-steps-table 180 (lambda (test-id) 202 (lambda (test-id) > 203 (set! *last-db-access* (current-seconds)) 181 (db:get-steps-table db test-id))) 204 (db:get-steps-table db test-id))) 182 205 183 (rpc:publish-procedure! 206 (rpc:publish-procedure! 184 'rdb:read-test-data 207 'rdb:read-test-data 185 (lambda (test-id categorypatt) 208 (lambda (test-id categorypatt) > 209 (set! *last-db-access* (current-seconds)) 186 (db:read-test-data db test-id categorypatt))) 210 (db:read-test-data db test-id categorypatt))) 187 211 188 (rpc:publish-procedure! 212 (rpc:publish-procedure! 189 'rdb:get-test-info 213 'rdb:get-test-info 190 (lambda (run-id testname item-path) 214 (lambda (run-id testname item-path) > 215 (set! *last-db-access* (current-seconds)) 191 (db:get-test-info db run-id testname item-path))) 216 (db:get-test-info db run-id testname item-path))) 192 217 193 (rpc:publish-procedure! 218 (rpc:publish-procedure! 194 'rdb:delete-test-records 219 'rdb:delete-test-records 195 (lambda (test-id) 220 (lambda (test-id) > 221 (set! *last-db-access* (current-seconds)) 196 (db:delete-test-records db test-id))) 222 (db:delete-test-records db test-id))) 197 223 198 (rpc:publish-procedure! 224 (rpc:publish-procedure! 199 'rtests:register-test 225 'rtests:register-test 200 (lambda (run-id test-name item-path) 226 (lambda (run-id test-name item-path) > 227 (set! *last-db-access* (current-seconds)) 201 (tests:register-test db run-id test-name item-path))) 228 (tests:register-test db run-id test-name item-path))) 202 229 > 230 (rpc:publish-procedure! > 231 'rdb:test-data-rollup > 232 (lambda (test-id status) > 233 (set! *last-db-access* (current-seconds)) > 234 (db:test-data-rollup db test-id status))) > 235 > 236 (rpc:publish-procedure! > 237 'rtests:test-set-status! > 238 (lambda (test-id state status comment dat) > 239 (set! *last-db-access* (current-seconds)) > 240 (test-set-status! db test-id state status comment dat))) > 241 > 242 (rpc:publish-procedure! > 243 'rtests:test-set-toplog! > 244 (lambda (run-id test-name logf) > 245 (set! *last-db-access* (current-seconds)) > 246 (test-set-toplog! db run-id test-name logf))) > 247 > 248 ;;====================================================================== > 249 ;; end of publish-procedure section > 250 ;;====================================================================== > 251 203 (set! *rpc:listener* rpc:listener) 252 (set! *rpc:listener* rpc:listener) 204 (on-exit (lambda () 253 (on-exit (lambda () 205 (sqlite3:execute db "DELETE FROM metadat WHERE var='SERVER' and v 254 (sqlite3:execute db "DELETE FROM metadat WHERE var='SERVER' and v 206 (sqlite3:finalize! db))) 255 (sqlite3:finalize! db))) 207 (thread-start! th1) 256 (thread-start! th1) 208 (thread-start! th2) 257 (thread-start! th2) > 258 ;; (thread-join! th2) > 259 ;; return th2 for the calling process to do a join with > 260 th2 209 (thread-join! th2))) ;; rpc:server))) | 261 )) ;; rpc:server))) > 262 > 263 (define (server:keep-running db) > 264 ;; if none running or if > 20 seconds since > 265 ;; server last used then start shutdown > 266 (let loop ((count 0)) > 267 (thread-sleep! 20) ;; no need to do this very often > 268 (let ((numrunning (db:get-count-tests-running db))) > 269 (if (or (not (> numrunning 0)) > 270 (> *last-db-access* (+ (current-seconds) 20))) > 271 (begin > 272 (debug:print 0 "INFO: Starting to shutdown the server side") > 273 (sqlite3:execute db "DELETE FROM metadat WHERE var='SERVER'"); ;; A > 274 ;; host:port) ;; need to delete only *my* server entry > 275 (thread-sleep! 10) > 276 (debug:print 0 "INFO: Server shutdown complete. Exiting") > 277 (exit)))) > 278 (loop (+ 1 count)))) 210 279 211 (define (server:find-free-port-and-open port) 280 (define (server:find-free-port-and-open port) 212 (handle-exceptions 281 (handle-exceptions 213 exn 282 exn 214 (begin 283 (begin 215 (print "Failed to bind to port " (rpc:default-server-port) ", trying next p 284 (print "Failed to bind to port " (rpc:default-server-port) ", trying next p 216 (server:find-free-port-and-open (+ port 1))) 285 (server:find-free-port-and-open (+ port 1))) 217 (rpc:default-server-port port) 286 (rpc:default-server-port port) 218 (tcp-listen (rpc:default-server-port)))) 287 (tcp-listen (rpc:default-server-port)))) 219 288 220 (define (server:client-setup db) 289 (define (server:client-setup db) 221 (if *runremote* 290 (if *runremote* > 291 (begin 222 (debug:print 0 "ERROR: Attempt to connect to server but already connected" | 292 (debug:print 0 "ERROR: Attempt to connect to server but already connecte > 293 #f) 223 (let* ((hostinfo (db:get-var db "SERVER")) 294 (let* ((hostinfo (db:get-var db "SERVER")) 224 (hostdat (if hostinfo (string-split hostinfo ":"))) 295 (hostdat (if hostinfo (string-split hostinfo ":"))) 225 (host (if hostinfo (car hostdat))) 296 (host (if hostinfo (car hostdat))) 226 (port (if (and hostinfo (> (length hostdat) 1))(cadr hostdat) # 297 (port (if (and hostinfo (> (length hostdat) 1))(cadr hostdat) # 227 (if (and port 298 (if (and port 228 (string->number port)) 299 (string->number port)) 229 (let ((portn (string->number port))) 300 (let ((portn (string->number port)))

Modified tests.scm from [536da0766162b5d1] to [18d52e02c6056e6f].

49 (conc "SELECT id FROM runs WHERE " qrystr " AND id != ?;") (app 49 (conc "SELECT id FROM runs WHERE " qrystr " AND id != ?;") (app 50 ;; for each run starting with the most recent look to see if there is 50 ;; for each run starting with the most recent look to see if there is 51 ;; if found then return that matching test record 51 ;; if found then return that matching test record 52 (debug:print 4 "selstr: " selstr ", qrystr: " qrystr ", keyvals: " key 52 (debug:print 4 "selstr: " selstr ", qrystr: " qrystr ", keyvals: " key 53 (if (null? prev-run-ids) #f 53 (if (null? prev-run-ids) #f 54 (let loop ((hed (car prev-run-ids)) 54 (let loop ((hed (car prev-run-ids)) 55 (tal (cdr prev-run-ids))) 55 (tal (cdr prev-run-ids))) 56 (let ((results (rdb:get-tests-for-run db hed test-name item-path | 56 (let ((results (db:get-tests-for-run db hed test-name item-path 57 (debug:print 4 "Got tests for run-id " run-id ", test-name " t 57 (debug:print 4 "Got tests for run-id " run-id ", test-name " t 58 (if (and (null? results) 58 (if (and (null? results) 59 (not (null? tal))) 59 (not (null? tal))) 60 (loop (car tal)(cdr tal)) 60 (loop (car tal)(cdr tal)) 61 (if (null? results) #f 61 (if (null? results) #f 62 (car results)))))))))) 62 (car results)))))))))) 63 63 ................................................................................................................................................................................ 106 (hash-table-set! tests-hash full-testname testdat)))) 106 (hash-table-set! tests-hash full-testname testdat)))) 107 results) 107 results) 108 (if (null? tal) 108 (if (null? tal) 109 (map cdr (hash-table->alist tests-hash)) ;; return a list 109 (map cdr (hash-table->alist tests-hash)) ;; return a list 110 (loop (car tal)(cdr tal)))))))))) 110 (loop (car tal)(cdr tal)))))))))) 111 111 112 ;; 112 ;; 113 (define (test-set-status! db run-id test-name state status itemdat-or-path comme | 113 (define (test-set-status! db test-id state status comment dat) 114 (let* ((real-status status) 114 (let* ((real-status status) 115 (item-path (if (string? itemdat-or-path) itemdat-or-path (item-list-> < 116 (testdat (db:get-test-info db run-id test-name item-path)) < 117 (test-id (if testdat (db:test-get-id testdat) #f)) < 118 (otherdat (if dat dat (make-hash-table))) 115 (otherdat (if dat dat (make-hash-table))) > 116 (testdat (db:get-test-data-by-id db test-id)) > 117 (run-id (db:test-get-run_id testdat)) > 118 (test-name (db:test-get-testname testdat)) > 119 (item-path (db:test-get-item-path testdat)) 119 ;; before proceeding we must find out if the previous test (where all k 120 ;; before proceeding we must find out if the previous test (where all k 120 ;; was WAIVED if this test is FAIL 121 ;; was WAIVED if this test is FAIL 121 (waived (if (equal? status "FAIL") 122 (waived (if (equal? status "FAIL") 122 (let ((prev-test (test:get-previous-test-run-record db ru 123 (let ((prev-test (test:get-previous-test-run-record db ru 123 (if prev-test ;; true if we found a previous test in th 124 (if prev-test ;; true if we found a previous test in th 124 (let ((prev-status (db:test-get-status prev-test) 125 (let ((prev-status (db:test-get-status prev-test) 125 (prev-state (db:test-get-state prev-test) 126 (prev-state (db:test-get-state prev-test) ................................................................................................................................................................................ 163 (units (hash-table-ref/default otherdat ":units" "")) 164 (units (hash-table-ref/default otherdat ":units" "")) 164 (type (hash-table-ref/default otherdat ":type" "")) 165 (type (hash-table-ref/default otherdat ":type" "")) 165 (dcomment (hash-table-ref/default otherdat ":comment" ""))) 166 (dcomment (hash-table-ref/default otherdat ":comment" ""))) 166 (debug:print 4 167 (debug:print 4 167 "category: " category ", variable: " variable ", value: " val 168 "category: " category ", variable: " variable ", value: " val 168 ", expected: " expected ", tol: " tol ", units: " units) 169 ", expected: " expected ", tol: " tol ", units: " units) 169 (if (and value expected tol) ;; all three required 170 (if (and value expected tol) ;; all three required 170 (rdb:csv->test-data db test-id < 171 (conc category "," | 171 (let ((dat (conc category "," 172 variable "," | 172 variable "," 173 value "," | 173 value "," 174 expected "," | 174 expected "," 175 tol "," | 175 tol "," 176 units "," | 176 units "," 177 dcomment ",," ;; extra comma for status | 177 dcomment ",," ;; extra comma for status 178 type )))) | 178 type ))) > 179 (rdb:csv->test-data db test-id > 180 dat)))) 179 181 180 ;; need to update the top test record if PASS or FAIL and this is a subtest 182 ;; need to update the top test record if PASS or FAIL and this is a subtest 181 (rdb:roll-up-pass-fail-counts db run-id test-name item-path status) 183 (rdb:roll-up-pass-fail-counts db run-id test-name item-path status) 182 184 183 (if (or (and (string? comment) 185 (if (or (and (string? comment) 184 (string-match (regexp "\\S+") comment)) 186 (string-match (regexp "\\S+") comment)) 185 waived) 187 waived) 186 (rdb:test-set-comment db run-id test-name item-path (if waived waived c | 188 (let ((cmt (if waived waived comment))) > 189 (rdb:test-set-comment db test-id cmt))) 187 )) 190 )) 188 191 189 (define (test-set-log! db run-id test-name itemdat logf) < 190 (let ((item-path (item-list->path itemdat))) < 191 (rdb:test-set-log! db run-id test-name item-path logf))) < 192 < 193 (define (test-set-toplog! db run-id test-name logf) 192 (define (test-set-toplog! db run-id test-name logf) 194 (sqlite3:execute db "UPDATE tests SET final_logf=? WHERE run_id=? AND testname 193 (sqlite3:execute db "UPDATE tests SET final_logf=? WHERE run_id=? AND testname 195 logf run-id test-name)) 194 logf run-id test-name)) 196 195 197 (define (tests:summarize-items db run-id test-name force) 196 (define (tests:summarize-items db run-id test-name force) 198 ;; if not force then only update the record if one of these is true: 197 ;; if not force then only update the record if one of these is true: 199 ;; 1. logf is "log/final.log 198 ;; 1. logf is "log/final.log ................................................................................................................................................................................ 385 384 386 (define (rtests:register-test db run-id test-name item-path) 385 (define (rtests:register-test db run-id test-name item-path) 387 (if *runremote* 386 (if *runremote* 388 (let ((host (vector-ref *runremote* 0)) 387 (let ((host (vector-ref *runremote* 0)) 389 (port (vector-ref *runremote* 1))) 388 (port (vector-ref *runremote* 1))) 390 ((rpc:procedure 'rtests:register-test host port) run-id test-name item-p 389 ((rpc:procedure 'rtests:register-test host port) run-id test-name item-p 391 (tests:register-test db run-id test-name item-path))) 390 (tests:register-test db run-id test-name item-path))) > 391 > 392 (define (rtests:test-set-status! db test-id state status comment dat) > 393 (if *runremote* > 394 (let ((host (vector-ref *runremote* 0)) > 395 (port (vector-ref *runremote* 1))) > 396 ((rpc:procedure 'rtests:test-set-status! host port) test-id state status > 397 (test-set-status! db test-id state status comment dat))) > 398 > 399 (define (rtests:test-set-toplog! db run-id test-name logf) > 400 (if *runremote* > 401 (let ((host (vector-ref *runremote* 0)) > 402 (port (vector-ref *runremote* 1))) > 403 ((rpc:procedure 'rtests:test-set-toplog! host port) run-id test-name log > 404 (test-set-toplog! db run-id test-name logf))) > 405 > 406

Modified tests/Makefile from [393100f5ee44673a] to [7122e406414be480].

1 # run some tests 1 # run some tests 2 2 3 BINPATH=$(shell realpath ../bin) 3 BINPATH=$(shell realpath ../bin) 4 MEGATEST=$(BINPATH)/megatest 4 MEGATEST=$(BINPATH)/megatest 5 PATH := $(BINPATH):$(PATH) 5 PATH := $(BINPATH):$(PATH) > 6 RUNNAME := $(shell date +w%V.%u.%H) > 7 IPADDR :="-" > 8 > 9 runall : test1 test2 > 10 > 11 test1 : cleanprep > 12 $(MEGATEST) -runtests ez_pass -target ubuntu/nfs/none :runname $(RUNNAME > 13 > 14 test2 : cleanprep > 15 $(MEGATEST) -runtests runfirst -target ubuntu/nfs/none :runname $(RUNNAM > 16 > 17 test3 : cleanprep > 18 $(MEGATEST) -runall -target ubuntu/nfs/none :runname $(RUNNAME)_b -m "Th 6 19 7 runall : | 20 cleanprep : ../*.scm 8 cd ../;make install | 21 sqlite3 megatest.db "delete from metadat where var='SERVER';" 9 mkdir -p /tmp/mt_runs /tmp/mt_links 22 mkdir -p /tmp/mt_runs /tmp/mt_links > 23 cd ..;make > 24 @sleep 1 > 25 @if ps -def |awk '{print $8}'|grep megatest; then \ > 26 echo WARNING: These tests will kill megatest and dashboard!; \ > 27 sleep 3; \ > 28 killall -9 dboard || true; \ > 29 killall -9 megatest || true; \ > 30 fi > 31 cd ../;make install > 32 $(MEGATEST) -remove-runs :runname $(RUNNAME)% -target %/%/% -testpatt % 10 $(BINPATH)/dboard -rows 15 & 33 $(BINPATH)/dboard -rows 15 & 11 $(MEGATEST) -runall -target ubuntu/nfs/none :runname `date +w%V.%u.%H` - | 34 touch cleanprep 12 35 13 test : 36 test : 14 csi -b -I .. ../megatest.scm -- -runall -target ubuntu/afs/tmp :runname 37 csi -b -I .. ../megatest.scm -- -runall -target ubuntu/afs/tmp :runname 15 cd ../;make test 38 cd ../;make test 16 make runall 39 make runall 17 40 18 dashboard : 41 dashboard : 19 cd ../;make install 42 cd ../;make install 20 $(BINPATH)/dboard & 43 $(BINPATH)/dboard & 21 44 22 remove : 45 remove : 23 (cd ../;make);$(MEGATEST) -remove-runs :runname $(RUN) -testpatt % -ite 46 (cd ../;make);$(MEGATEST) -remove-runs :runname $(RUN) -testpatt % -ite 24 47 > 48 clean : > 49 rm cleanprep > 50 25 runforever : 51 runforever : 26 while(ls); do runname=`date +%F-%R:%S`;$(MEGATEST) -runall -target ubunt 52 while(ls); do runname=`date +%F-%R:%S`;$(MEGATEST) -runall -target ubunt

Modified tests/megatest.config from [729204831fabda5a] to [75d2bf7273d2314a].

5 5 6 [setup] 6 [setup] 7 # exectutable /path/to/megatest 7 # exectutable /path/to/megatest 8 max_concurrent_jobs 200 8 max_concurrent_jobs 200 9 linktree /tmp/mt_links 9 linktree /tmp/mt_links 10 10 11 [jobtools] 11 [jobtools] 12 # useshell yes | 12 useshell yes 13 # ## launcher launches jobs, the job is managed on the target host 13 # ## launcher launches jobs, the job is managed on the target host 14 ## by megatest, comment out launcher to run local 14 ## by megatest, comment out launcher to run local 15 # workhosts localhost hermes 15 # workhosts localhost hermes 16 launcher nbfake 16 launcher nbfake 17 # launcher nodanggood 17 # launcher nodanggood 18 18 19 ## use "xterm -e csi -- " as a launcher to examine the launch environment. 19 ## use "xterm -e csi -- " as a launcher to examine the launch environment.

Modified utils/mt_ezstep from [e004bfd05cb198b4] to [dc6e288c61060e14].

25 source $prev_env 25 source $prev_env 26 fi 26 fi 27 27 28 # source the environment from the previous step if it exists 28 # source the environment from the previous step if it exists 29 29 30 # if a logpro file exists then use it otherwise just run the command, nb// was u 30 # if a logpro file exists then use it otherwise just run the command, nb// was u 31 if [ -e ${stepname}.logpro ];then 31 if [ -e ${stepname}.logpro ];then > 32 # could do: > 33 $command 2>&1| tee ${stepname}.log | logpro ${stepname}.logpro ${stepname}.ht > 34 logprostatus=$? 32 $command 2>&1| logpro ${stepname}.logpro ${stepname}.html &> ${stepname}.log | 35 # $command 2>&1| logpro ${stepname}.logpro ${stepname}.html &> ${stepname}.lo > 36 # allstatus=(${PIPESTATUS[0]} ${PIPESTATUS[1]}) 33 allstatus=(${PIPESTATUS[0]} ${PIPESTATUS[1]}) 37 allstatus=(${PIPESTATUS[0]} ${PIPESTATUS[1]}) 34 runstatus=${allstatus[0]} 38 runstatus=${allstatus[0]} 35 logprostatus=${allstatus[1]} | 39 # logprostatus=${allstatus[1]} 36 else 40 else 37 $command &> ${stepname}.log 41 $command &> ${stepname}.log 38 runstatus=$? 42 runstatus=$? 39 logprostatus=$runstatus 43 logprostatus=$runstatus 40 fi 44 fi 41 45 42 # If the test exits with non-zero, we will record FAIL even if logpro 46 # If the test exits with non-zero, we will record FAIL even if logpro