Overview
| SHA1 Hash: | 331e7c90b2a4c20175faea173020685aaeca4b3e |
|---|---|
| Date: | 2012-02-23 21:42:21 |
| User: | matt |
| Comment: | Merged in rpc stuff, fixed few bugs |
| Timelines: | family | ancestors | descendants | both | archiving |
| Diffs: | root of this branch |
| Downloads: | Tarball | ZIP archive |
| Other Links: | files | file ages | manifest |
Tags And Properties
- branch=archiving inherited from [263965f514]
- sym-archiving inherited from [263965f514]
Changes
Modified Makefile from [2f05184f326d6a6a] to [cd8f90dd01fd3cd8].
24 24 25 # Special dependencies for the includes 25 # Special dependencies for the includes 26 tests.o db.o launch.o runs.o dashboard-tests.o dashboard-guimonitor.o dashboard- 26 tests.o db.o launch.o runs.o dashboard-tests.o dashboard-guimonitor.o dashboard- 27 tests.o runs.o dashboard.o dashboard-tests.o dashboard-main.o : run_records.scm 27 tests.o runs.o dashboard.o dashboard-tests.o dashboard-main.o : run_records.scm 28 db.o ezsteps.o keys.o launch.o megatest.o monitor.o runs-for-ref.o runs.o tests. 28 db.o ezsteps.o keys.o launch.o megatest.o monitor.o runs-for-ref.o runs.o tests. 29 tests.o tasks.o dashboard-tasks.o : task_records.scm 29 tests.o tasks.o dashboard-tasks.o : task_records.scm 30 runs.o : test_records.scm 30 runs.o : test_records.scm 31 < 32 31 33 $(OFILES) $(GOFILES) : common_records.scm 32 $(OFILES) $(GOFILES) : common_records.scm 34 33 35 %.o : %.scm 34 %.o : %.scm 36 csc $(CSCOPTS) -c $< 35 csc $(CSCOPTS) -c $< 37 36 38 $(PREFIX)/bin/megatest : megatest 37 $(PREFIX)/bin/megatest : megatest
Modified common.scm from [afba6d90ad8d5e81] to [5ebf23fbcda8e053].
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 *globalexitstatus* 0) ;; attempt to work around possible thread issues 38 (define *globalexitstatus* 0) ;; attempt to work around possible thread issues 39 (define *passnum* 0) ;; when running track calls to run-tests or similar 39 (define *passnum* 0) ;; when running track calls to run-tests or similar 40 (define *verbosity* 1) 40 (define *verbosity* 1) 41 (define *rpc:listener* #f) ;; if set up for server communication this will hold 41 (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 42 43 43 (define (get-with-default val default) 44 (define (get-with-default val default) 44 (let ((val (args:get-arg val))) 45 (let ((val (args:get-arg val))) 45 (if val val default))) 46 (if val val default))) 46 47 47 (define (assoc/default key lst . default) 48 (define (assoc/default key lst . default) 48 (let ((res (assoc key lst))) 49 (let ((res (assoc key lst)))
Modified db.scm from [353182e7641d7a52] to [05d3c682d2f276a1].
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 11 12 ;;====================================================================== 12 ;;====================================================================== 13 ;; Database access 13 ;; Database access 14 ;;====================================================================== 14 ;;====================================================================== > 15 > 16 (require-extension (srfi 18) extras tcp rpc) > 17 (import (prefix rpc rpc:)) 15 18 16 (use sqlite3 srfi-1 posix regex regex-case srfi-69 csv-xml) 19 (use sqlite3 srfi-1 posix regex regex-case srfi-69 csv-xml) 17 (import (prefix sqlite3 sqlite3:)) 20 (import (prefix sqlite3 sqlite3:)) 18 21 19 (declare (unit db)) 22 (declare (unit db)) 20 (declare (uses common)) 23 (declare (uses common)) 21 (declare (uses keys)) 24 (declare (uses keys)) 22 (declare (uses ods)) 25 (declare (uses ods)) 23 26 24 (include "common_records.scm") 27 (include "common_records.scm") 25 (include "db_records.scm") 28 (include "db_records.scm") 26 (include "key_records.scm") 29 (include "key_records.scm") > 30 (include "run_records.scm") 27 31 28 (define (open-db) ;; (conc *toppath* "/megatest.db") (car *configinfo*))) 32 (define (open-db) ;; (conc *toppath* "/megatest.db") (car *configinfo*))) 29 (let* ((dbpath (conc *toppath* "/megatest.db")) ;; fname) 33 (let* ((dbpath (conc *toppath* "/megatest.db")) ;; fname) 30 (configdat (car *configinfo*)) 34 (configdat (car *configinfo*)) 31 (dbexists (file-exists? dbpath)) 35 (dbexists (file-exists? dbpath)) 32 (db (sqlite3:open-database dbpath)) ;; (never-give-up-open-db db 36 (db (sqlite3:open-database dbpath)) ;; (never-give-up-open-db db 33 (handler (make-busy-timeout 36000))) 37 (handler (make-busy-timeout 36000))) ................................................................................................................................................................................ 129 comment TEXT DEFAULT '', 133 comment TEXT DEFAULT '', 130 status TEXT DEFAULT 'n/a', 134 status TEXT DEFAULT 'n/a', 131 type TEXT DEFAULT '', 135 type TEXT DEFAULT '', 132 CONSTRAINT test_data_constraint UNIQUE (test_id,ca 136 CONSTRAINT test_data_constraint UNIQUE (test_id,ca 133 ;; Must do this *after* running patch db !! No more. 137 ;; Must do this *after* running patch db !! No more. 134 (db:set-var db "MEGATEST_VERSION" megatest-version) 138 (db:set-var db "MEGATEST_VERSION" megatest-version) 135 )) 139 )) > 140 (server:client-setup db) 136 db)) 141 db)) 137 142 138 ;;====================================================================== 143 ;;====================================================================== 139 ;; TODO: 144 ;; TODO: 140 ;; put deltas into an assoc list with version numbers 145 ;; put deltas into an assoc list with version numbers 141 ;; apply all from last to current 146 ;; apply all from last to current 142 ;;====================================================================== 147 ;;====================================================================== ................................................................................................................................................................................ 405 (let ((qry (conc "UPDATE tests SET state=?,status=? WHERE " 410 (let ((qry (conc "UPDATE tests SET state=?,status=? WHERE " 406 (if currstate (conc "state='" currstate "' AND " 411 (if currstate (conc "state='" currstate "' AND " 407 (if currstatus (conc "status='" currstatus "' AND 412 (if currstatus (conc "status='" currstatus "' AND 408 " run_id=? AND testname=? AND NOT (item_path='' A 413 " run_id=? AND testname=? AND NOT (item_path='' A 409 ;;(debug:print 0 "QRY: " qry) 414 ;;(debug:print 0 "QRY: " qry) 410 (sqlite3:execute db qry run-id newstate newstatus testname testn 415 (sqlite3:execute db qry run-id newstate newstatus testname testn 411 testnames)) 416 testnames)) > 417 > 418 (define (db:teststep-set-status! db run-id test-name teststep-name state-in stat > 419 (debug:print 4 "run-id: " run-id " test-name: " test-name) > 420 (let* ((state (check-valid-items "state" state-in)) > 421 (status (check-valid-items "status" status-in)) > 422 (testdat (db:get-test-info db run-id test-name item-path))) > 423 (debug:print 5 "testdat: " testdat) > 424 (if (and testdat ;; if the section exists then force specification BUG, I do > 425 (or (not state)(not status))) > 426 (debug:print 0 "WARNING: Invalid " (if status "status" "state") > 427 " value \"" (if status state-in status-in) "\", update your valid > 428 (if testdat > 429 (let ((test-id (test:get-id testdat))) > 430 ;; FIXME - this should not update the logfile unless it is specified. > 431 (sqlite3:execute db > 432 "INSERT OR REPLACE into test_steps (test_id,stepname,sta > 433 test-id teststep-name state-in status-in (if comment com > 434 #t) ;; fake out a #t - could be execute is returning something complic > 435 (debug:print 0 "ERROR: Can't update " test-name " for run " run-id " -> > 436 412 437 413 (define (db:delete-tests-in-state db run-id state) 438 (define (db:delete-tests-in-state db run-id state) 414 (sqlite3:execute db "DELETE FROM tests WHERE state=? AND run_id=?;" state run- 439 (sqlite3:execute db "DELETE FROM tests WHERE state=? AND run_id=?;" state run- 415 440 416 (define (db:test-set-state-status-by-id db test-id newstate newstatus newcomment 441 (define (db:test-set-state-status-by-id db test-id newstate newstatus newcomment 417 (if newstate (sqlite3:execute db "UPDATE tests SET state=? WHERE id=?;" ne 442 (if newstate (sqlite3:execute db "UPDATE tests SET state=? WHERE id=?;" ne 418 (if newstatus (sqlite3:execute db "UPDATE tests SET status=? WHERE id=?;" ne 443 (if newstatus (sqlite3:execute db "UPDATE tests SET status=? WHERE id=?;" ne ................................................................................................................................................................................ 971 (debug:print 0 "WARNING: path given, " outputfile " is relative, pref 996 (debug:print 0 "WARNING: path given, " outputfile " is relative, pref 972 (conc (current-directory) "/" outputfile))) 997 (conc (current-directory) "/" outputfile))) 973 results) 998 results) 974 ;; brutal clean up 999 ;; brutal clean up 975 (system "rm -rf tempdir"))) 1000 (system "rm -rf tempdir"))) 976 1001 977 ;; (db:extract-ods-file db "outputfile.ods" '(("sysname" "%")("fsname" "%")("dat 1002 ;; (db:extract-ods-file db "outputfile.ods" '(("sysname" "%")("fsname" "%")("dat > 1003 > 1004 > 1005 ;;====================================================================== > 1006 ;; REMOTE DB ACCESS VIA RPC > 1007 ;;====================================================================== > 1008 > 1009 ;; (define (rdb:get-var db var) > 1010 ;; (define (rdb:set-var db var val) > 1011 ;; (define (rdb-get-keys db) > 1012 ;; (define (rdb:get-value-by-header row header field) > 1013 ;; (define (rruns:get-std-run-fields keys remfields) > 1014 ;; (define (rdb:get-runs db runpatt count offset keypatts) > 1015 ;; (define (rdb:get-num-runs db runpatt) > 1016 ;; (define (rdb:get-run-info db run-id) > 1017 ;; (define (rdb:set-comment-for-run db run-id comment) > 1018 ;; (define (rdb:delete-run db run-id) > 1019 ;; (define (rdb:update-run-event_time db run-id) > 1020 ;; (define (rdb-get-tests-for-run db run-id testpatt itempatt states statuses) > 1021 ;; (define (rdb:delete-test-step-records db run-id test-name itemdat) > 1022 ;; (define (rdb:delete-test-records db test-id) > 1023 > 1024 (define (rdb:set-tests-state-status db run-id testnames currstate currstatus new > 1025 (if *runremote* > 1026 (let ((host (vector-ref *runremote* 0)) > 1027 (port (vector-ref *runremote* 1))) > 1028 ((rpc:procedure 'rdb:set-tests-state-status host port) > 1029 run-id testnames currstate currstatus newstate newstatus)) > 1030 (db:set-tests-state-status db run-id testnames currstate currstatus newsta > 1031 > 1032 (define (rdb:teststep-set-status! db run-id test-name teststep-name state-in sta > 1033 (print "teststep-set-status!:" run-id test-name teststep-name state-in status > 1034 (let ((item-path (item-list->path itemdat))) > 1035 (if *runremote* > 1036 (let ((host (vector-ref *runremote* 0)) > 1037 (port (vector-ref *runremote* 1))) > 1038 ((rpc:procedure 'rdb:teststep-set-status! host port) > 1039 run-id test-name teststep-name state-in status-in item-path comment l > 1040 (db:teststep-set-status! db run-id test-name teststep-name state-in st > 1041 > 1042 > 1043 ;; (define (rdb:delete-tests-in-state db run-id state) > 1044 ;; (define (rdb:test-set-state-status-by-id db test-id newstate newstatus newcom > 1045 ;; (define (rdb:get-count-tests-running db) > 1046 ;; (define (rdb:get-count-tests-running-in-jobgroup db jobgroup) > 1047 ;; (define (rdb:estimated-tests-remaining db run-id) > 1048 ;; (define (rdb:get-test-info db run-id testname item-path) > 1049 ;; (define (rdb:get-test-data-by-id db test-id) > 1050 ;; (define (rdb:test-set-comment db run-id testname item-path comment) > 1051 ;; (define (rdb:test-set-rundir! db run-id testname item-path rundir) > 1052 ;; (define (rdb:test-get-paths-matching db keynames target) > 1053 ;; (define (rdb:test-get-test-records-matching db keynames target) > 1054 ;; (define (rdb:testmeta-get-record db testname) > 1055 ;; (define (rdb:testmeta-add-record db testname) > 1056 ;; (define (rdb:testmeta-update-field db testname field value) > 1057 ;; (define (rdb:csv->test-data db test-id csvdata) > 1058 ;; (define (rdb:read-test-data db test-id categorypatt) > 1059 ;; (define (rdb:load-test-data db run-id test-name itemdat) > 1060 ;; (define (rdb:test-data-rollup db test-id status) > 1061 ;; (define (rdb:get-prev-tol-for-test db test-id category variable) > 1062 ;; (define (rdb:step-get-time-as-string vec) > 1063 ;; (define (rdb:get-steps-for-test db test-id) > 1064 ;; (define (rdb:get-steps-table db test-id) > 1065 ;; (define (rdb-get-prereqs-not-met db run-id waiton) > 1066 ;; (define (rdb:get-prereqs-not-met db run-id waitons ref-item-path) > 1067 ;; (define (rdb:extract-ods-file db outputfile keypatt-alist runspatt pathmod)
Modified items.scm from [d370c880ec95b9d4] to [63e566656e64095d].
14 ;; (season "summer winter fall spring"))) 14 ;; (season "summer winter fall spring"))) 15 15 16 (declare (unit items)) 16 (declare (unit items)) 17 (declare (uses common)) 17 (declare (uses common)) 18 18 19 (include "common_records.scm") 19 (include "common_records.scm") 20 20 21 ;; Mostly worked = puts out all combinations? | 21 ;; Puts out all combinations 22 (define (process-itemlist-try1 curritemkey itemlist) | 22 (define (process-itemlist hierdepth curritemkey itemlist) > 23 (let ((res '())) > 24 (if (not hierdepth) > 25 (set! hierdepth (length itemlist))) 23 (let loop ((hed (car itemlist)) | 26 (let loop ((hed (car itemlist)) 24 (tal (cdr itemlist))) | 27 (tal (cdr itemlist))) 25 (if (null? tal) | 28 (if (null? tal) 26 (for-each (lambda (item) < 27 (debug:print 6 "curritemkey: " (append curritemkey (list ite < 28 (cadr hed)) < 29 (begin < 30 (for-each (lambda (item) 29 (for-each (lambda (item) > 30 (if (> (length curritemkey) (- hierdepth 2)) 31 (process-itemlist (append curritemkey (list item)) tal)) | 31 (set! res (append res (list (append curritemkey (list 32 (cadr hed)) 32 (cadr hed)) > 33 (begin > 34 (for-each (lambda (item) > 35 (set! res (append res (process-itemlist hierdepth (appen > 36 (cadr hed)) 33 (loop (car tal)(cdr tal)))))) | 37 (loop (car tal)(cdr tal))))) > 38 res)) 34 39 35 ;; Mostly worked = puts out all combinations? | 40 ;; Puts out all combinations 36 (define (process-itemlist hierdepth curritemkey itemlist) 41 (define (process-itemlist hierdepth curritemkey itemlist) 37 (let ((res '())) 42 (let ((res '())) 38 (if (not hierdepth) 43 (if (not hierdepth) 39 (set! hierdepth (length itemlist))) 44 (set! hierdepth (length itemlist))) 40 (let loop ((hed (car itemlist)) 45 (let loop ((hed (car itemlist)) 41 (tal (cdr itemlist))) 46 (tal (cdr itemlist))) 42 (if (null? tal) 47 (if (null? tal)
Modified launch.scm from [3d741a045bcae29c] to [39a68fda61b17084].
177 ;; (set! script (conc s 177 ;; (set! script (conc s 178 178 179 ;; call the command using mt_ 179 ;; call the command using mt_ 180 (set! script (conc "mt_ezstep 180 (set! script (conc "mt_ezstep 181 181 182 (debug:print 4 "script: " scr 182 (debug:print 4 "script: " scr 183 183 184 (teststep-set-status! db run- | 184 (rdb:teststep-set-status! db 185 ;; now launch 185 ;; now launch 186 (let ((pid (process-run scrip 186 (let ((pid (process-run scrip 187 (let processloop ((i 0)) 187 (let processloop ((i 0)) 188 (let-values (((pid-val ex 188 (let-values (((pid-val ex 189 (mutex-lock! 189 (mutex-lock! 190 (vector-set! 190 (vector-set! 191 (vector-set! 191 (vector-set! ................................................................................................................................................................................ 192 (vector-set! 192 (vector-set! 193 (mutex-unlock 193 (mutex-unlock 194 (if (eq? pid- 194 (if (eq? pid- 195 (begin 195 (begin 196 (thread 196 (thread 197 (proces 197 (proces 198 )) 198 )) 199 (teststep-set-status! db ru | 199 (rdb:teststep-set-status! d 200 (if logpro-used 200 (if logpro-used 201 (test-set-log! db run-i 201 (test-set-log! db run-i 202 ;; set the test final statu 202 ;; set the test final statu 203 (let* ((this-step-status (c 203 (let* ((this-step-status (c 204 ( 204 ( 205 ( 205 ( 206 ( 206 (
Modified megatest.scm from [65f72e6e78e66e16] to [020b44b20d8374e3].
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 23 23 (include "common_records.scm") 24 (include "common_records.scm") 24 (include "key_records.scm") 25 (include "key_records.scm") 25 (include "db_records.scm") 26 (include "db_records.scm") 26 27 27 (define help (conc " 28 (define help (conc " 28 Megatest, documentation at http://www.kiatoa.com/fossils/megatest 29 Megatest, documentation at http://www.kiatoa.com/fossils/megatest ................................................................................................................................................................................ 88 -rollup : fill run (set by :runname) with latest test(s) from 89 -rollup : fill run (set by :runname) with latest test(s) from 89 prior runs with same keys 90 prior runs with same keys 90 -update-meta : update the tests metadata for all tests 91 -update-meta : update the tests metadata for all tests 91 -env2file fname : write the environment to fname.csh and fname.sh 92 -env2file fname : write the environment to fname.csh and fname.sh 92 -setvars VAR1=val1,VAR2=val2 : Add environment variables to a run NB// these a 93 -setvars VAR1=val1,VAR2=val2 : Add environment variables to a run NB// these a 93 overwritten by values set in config files. 94 overwritten by values set in config files. 94 -archive : archive tests, use -target, :runname, -itempatt and 95 -archive : archive tests, use -target, :runname, -itempatt and > 96 -server : start the server (reduces contention on megatest.db) 95 97 96 Spreadsheet generation 98 Spreadsheet generation 97 -extract-ods fname.ods : extract an open document spreadsheet from the databa 99 -extract-ods fname.ods : extract an open document spreadsheet from the databa 98 -pathmod path : insert path, i.e. path/runame/itempath/logfile.html 100 -pathmod path : insert path, i.e. path/runame/itempath/logfile.html 99 will clear the field if no rundir/testname/itempath/ 101 will clear the field if no rundir/testname/itempath/ 100 if it contains forward slashes the path will be conv 102 if it contains forward slashes the path will be conv 101 to windows style 103 to windows style ................................................................................................................................................................................ 174 "-runall" ;; run all tests 176 "-runall" ;; run all tests 175 "-remove-runs" 177 "-remove-runs" 176 "-keepgoing" 178 "-keepgoing" 177 "-usequeue" 179 "-usequeue" 178 "-rebuild-db" 180 "-rebuild-db" 179 "-rollup" 181 "-rollup" 180 "-update-meta" 182 "-update-meta" > 183 "-server" > 184 181 "-v" ;; verbose 2, more than normal (normal is 1) 185 "-v" ;; verbose 2, more than normal (normal is 1) 182 "-q" ;; quiet 0, errors/warnings only 186 "-q" ;; quiet 0, errors/warnings only 183 ) 187 ) 184 args:arg-hash 188 args:arg-hash 185 0)) 189 0)) 186 190 187 (if (args:get-arg "-h") 191 (if (args:get-arg "-h") ................................................................................................................................................................................ 377 runname 381 runname 378 (args:get-arg "-runtests") 382 (args:get-arg "-runtests") 379 (args:get-arg "-itempatt") 383 (args:get-arg "-itempatt") 380 user 384 user 381 (make-hash-table))))) 385 (make-hash-table))))) 382 386 383 ;;====================================================================== 387 ;;====================================================================== > 388 ;; Start the server > 389 ;;====================================================================== > 390 (if (args:get-arg "-server") > 391 (let* ((toppath (setup-for-run)) > 392 (db (if toppath (open-db) #f))) > 393 (if db > 394 (server:start db) > 395 (debug:print 0 "ERROR: Failed to setup for megatest")))) > 396 > 397 ;;;====================================================================== 384 ;; Rollup into a run 398 ;; Rollup into a run 385 ;;====================================================================== 399 ;;====================================================================== 386 (if (args:get-arg "-rollup") 400 (if (args:get-arg "-rollup") 387 (general-run-call 401 (general-run-call 388 "-rollup" 402 "-rollup" 389 "rollup tests" 403 "rollup tests" 390 (lambda (db keys keynames keyvallst) 404 (lambda (db keys keynames keyvallst) ................................................................................................................................................................................ 539 (change-directory testpath) 553 (change-directory testpath) 540 (if (not (setup-for-run)) 554 (if (not (setup-for-run)) 541 (begin 555 (begin 542 (debug:print 0 "Failed to setup, exiting") 556 (debug:print 0 "Failed to setup, exiting") 543 (exit 1))) 557 (exit 1))) 544 (set! db (open-db)) 558 (set! db (open-db)) 545 (if (and state status) 559 (if (and state status) 546 (teststep-set-status! db run-id test-name step state status itemda | 560 (rdb:teststep-set-status! db run-id test-name step state status it 547 (begin 561 (begin 548 (debug:print 0 "ERROR: You must specify :state and :status with 562 (debug:print 0 "ERROR: You must specify :state and :status with 549 (exit 6))) 563 (exit 6))) 550 (sqlite3:finalize! db) 564 (sqlite3:finalize! db) 551 (set! *didsomething* #t)))) 565 (set! *didsomething* #t)))) 552 566 553 (if (or (args:get-arg "-setlog") ;; since setting up is so costly lets pig 567 (if (or (args:get-arg "-setlog") ;; since setting up is so costly lets pig ................................................................................................................................................................................ 602 (redir (case (string->symbol shell) 616 (redir (case (string->symbol shell) 603 ((tcsh csh ksh) ">&") 617 ((tcsh csh ksh) ">&") 604 ((zsh bash sh ash) "2>&1 >"))) 618 ((zsh bash sh ash) "2>&1 >"))) 605 (fullcmd (conc "(" (string-intersperse 619 (fullcmd (conc "(" (string-intersperse 606 (cons cmd params) " ") 620 (cons cmd params) " ") 607 ") " redir " " logfile))) 621 ") " redir " " logfile))) 608 ;; mark the start of the test 622 ;; mark the start of the test 609 (teststep-set-status! db run-id test-name stepname "start" " | 623 (rdb:teststep-set-status! db run-id test-name stepname "star 610 ;; close the db 624 ;; close the db 611 (sqlite3:finalize! db) 625 (sqlite3:finalize! db) 612 ;; run the test step 626 ;; run the test step 613 (debug:print 2 "INFO: Running \"" fullcmd "\"") 627 (debug:print 2 "INFO: Running \"" fullcmd "\"") 614 (change-directory startingdir) 628 (change-directory startingdir) 615 (set! exitstat (system fullcmd)) ;; cmd params)) 629 (set! exitstat (system fullcmd)) ;; cmd params)) 616 (set! *globalexitstatus* exitstat) 630 (set! *globalexitstatus* exitstat) ................................................................................................................................................................................ 624 (cmd (string-intersperse (list "logpro" l 638 (cmd (string-intersperse (list "logpro" l 625 (debug:print 2 "INFO: running \"" cmd "\"") 639 (debug:print 2 "INFO: running \"" cmd "\"") 626 (change-directory startingdir) 640 (change-directory startingdir) 627 (set! exitstat (system cmd)) 641 (set! exitstat (system cmd)) 628 (set! *globalexitstatus* exitstat) ;; no necessary 642 (set! *globalexitstatus* exitstat) ;; no necessary 629 (change-directory testpath) 643 (change-directory testpath) 630 (test-set-log! db run-id test-name itemdat htmllogfile 644 (test-set-log! db run-id test-name itemdat htmllogfile 631 (teststep-set-status! db run-id test-name stepname "end" exi | 645 (rdb:teststep-set-status! db run-id test-name stepname "end" 632 (sqlite3:finalize! db) 646 (sqlite3:finalize! db) 633 (if (not (eq? exitstat 0)) 647 (if (not (eq? exitstat 0)) 634 (exit 254)) ;; (exit exitstat) doesn't work?!? 648 (exit 254)) ;; (exit exitstat) doesn't work?!? 635 ;; open the db 649 ;; open the db 636 ;; mark the end of the test 650 ;; mark the end of the test 637 ))) 651 ))) 638 (if (or (args:get-arg "-test-status") 652 (if (or (args:get-arg "-test-status")
Modified runs.scm from [4295c234826d1ae4] to [8d5b51c35f7388dd].
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)) 21 (declare (uses tests)) 21 (declare (uses tests)) > 22 (declare (uses server)) 22 23 23 (include "common_records.scm") 24 (include "common_records.scm") 24 (include "key_records.scm") 25 (include "key_records.scm") 25 (include "db_records.scm") 26 (include "db_records.scm") 26 (include "run_records.scm") 27 (include "run_records.scm") 27 (include "test_records.scm") 28 (include "test_records.scm") 28 29 ................................................................................................................................................................................ 208 (if (eq? *passnum* 0) 209 (if (eq? *passnum* 0) 209 (begin 210 (begin 210 ;; have to delete test records where NOT_STARTED since they can cause 211 ;; have to delete test records where NOT_STARTED since they can cause 211 ;; get stuck due to becoming inaccessible from a failed test. I.e. if 212 ;; get stuck due to becoming inaccessible from a failed test. I.e. if 212 ;; on test A but test B reached the point on being registered as NOT_S 213 ;; on test A but test B reached the point on being registered as NOT_S 213 ;; A failed for some reason then on re-run using -keepgoing the run ca 214 ;; A failed for some reason then on re-run using -keepgoing the run ca 214 (db:delete-tests-in-state db run-id "NOT_STARTED") 215 (db:delete-tests-in-state db run-id "NOT_STARTED") 215 (db:set-tests-state-status db run-id test-names #f "FAIL" "NOT_STARTED | 216 (rdb:set-tests-state-status db run-id test-names #f "FAIL" "NOT_STARTE 216 217 217 ;; now add non-directly referenced dependencies (i.e. waiton) 218 ;; now add non-directly referenced dependencies (i.e. waiton) 218 (if (not (null? test-names)) 219 (if (not (null? test-names)) 219 (let loop ((hed (car test-names)) 220 (let loop ((hed (car test-names)) 220 (tal (cdr test-names))) ;; 'return-procs tells the co 221 (tal (cdr test-names))) ;; 'return-procs tells the co 221 (let* ((config (test:get-testconfig hed 'return-procs)) 222 (let* ((config (test:get-testconfig hed 'return-procs)) 222 (waitons (string-split (let ((w (config-lookup config "requirem 223 (waitons (string-split (let ((w (config-lookup config "requirem
Modified server.scm from [0bbf1bf4b67c22bc] to [13820d7ecc3212ad].
4 ;; This program is made available under the GNU GPL version 2.0 or 4 ;; This program is made available under the GNU GPL version 2.0 or 5 ;; greater. See the accompanying file COPYING for details. 5 ;; greater. See the accompanying file COPYING for details. 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 (require-extension (srfi 18) extras tcp rpc) > 12 (import (prefix rpc rpc:)) > 13 > 14 (use sqlite3 srfi-1 posix regex regex-case srfi-69) > 15 (import (prefix sqlite3 sqlite3:)) > 16 11 (declare (unit server)) 17 (declare (unit server)) 12 18 > 19 (declare (uses common)) > 20 (declare (uses db)) > 21 > 22 (include "common_records.scm") > 23 (include "db_records.scm") > 24 13 ;; procstr is the name of the procedure to be called as a string 25 ;; procstr is the name of the procedure to be called as a string 14 (define (server:autoremote procstr params) 26 (define (server:autoremote procstr params) 15 (handle-exceptions 27 (handle-exceptions 16 exn 28 exn 17 (begin 29 (begin 18 (debug:print 1 "Remote failed for " proc " " params) 30 (debug:print 1 "Remote failed for " proc " " params) 19 (apply (eval (string->symbol proc)) params)) 31 (apply (eval (string->symbol proc)) params)) ................................................................................................................................................................................ 22 (eval (string->symbol procstr) params)))) 34 (eval (string->symbol procstr) params)))) 23 35 24 (define (server:start db) 36 (define (server:start db) 25 (debug:print 0 "Attempting to start the server ...") 37 (debug:print 0 "Attempting to start the server ...") 26 (let* ((rpc:listener (server:find-free-port-and-open (rpc:default-server-port) 38 (let* ((rpc:listener (server:find-free-port-and-open (rpc:default-server-port) 27 (th1 (make-thread 39 (th1 (make-thread 28 (cute (rpc:make-server rpc:listener) "rpc:server") 40 (cute (rpc:make-server rpc:listener) "rpc:server") 29 'rpc:server))) | 41 'rpc:server)) 30 (db:set-var db "SERVER" (conc (get-host-name) ":" (rpc:default-server-port)) | 42 (host:port (conc (get-host-name) ":" (rpc:default-server-port)))) > 43 (db:set-var db "SERVER" host:port) 31 (rpc:publish-procedure! 44 (rpc:publish-procedure! 32 'remote:run 45 'remote:run 33 (lambda (procstr . params) 46 (lambda (procstr . params) 34 (server:autoremote procstr params))) 47 (server:autoremote procstr params))) > 48 > 49 ;;====================================================================== > 50 ;; db specials here > 51 ;;====================================================================== > 52 ;; ** set-tests-state-status > 53 (rpc:publish-procedure! > 54 'rdb:set-tests-state-status > 55 (lambda (run-id testnames currstate currstatus newstate newstatus) > 56 ;; (debug:print 2 "rdb:set-tests-state-status newstate: " newstate " news > 57 (db:set-tests-state-status db run-id testnames currstate currstatus newst > 58 > 59 (rpc:publish-procedure! > 60 'rdb:teststep-set-status! > 61 (lambda (run-id test-name teststep-name state-in status-in item-path commen > 62 ;; (debug:print 2 "rdb:teststep-state-set-status! test-name: " test-name > 63 (db:teststep-set-status! db run-id test-name teststep-name state-in statu > 64 35 (set! *rpc:listener* rpc:listener*) | 65 (set! *rpc:listener* rpc:listener) > 66 (on-exit (lambda () > 67 (sqlite3:execute db "DELETE FROM metadat WHERE var='SERVER' and v > 68 (sqlite3:finalize! db))) 36 (thread-start! rpc:server))) | 69 (thread-start! th1) > 70 (thread-join! th1))) ;; rpc:server))) 37 71 38 (define (server:find-free-port-and-open port) 72 (define (server:find-free-port-and-open port) 39 (handle-exceptions 73 (handle-exceptions 40 exn 74 exn 41 (begin 75 (begin 42 (print "Failed to bind to port " (rpc:default-server-port) ", trying next p 76 (print "Failed to bind to port " (rpc:default-server-port) ", trying next p 43 (server:find-free-port-and-open (+ port 1))) 77 (server:find-free-port-and-open (+ port 1))) ................................................................................................................................................................................ 45 (tcp-listen (rpc:default-server-port)))) 79 (tcp-listen (rpc:default-server-port)))) 46 80 47 (define (server:client-setup db) 81 (define (server:client-setup db) 48 (let* ((hostinfo (db:get-var db "SERVER")) 82 (let* ((hostinfo (db:get-var db "SERVER")) 49 (hostdat (if hostinfo (string-split hostinfo ":"))) 83 (hostdat (if hostinfo (string-split hostinfo ":"))) 50 (host (if hostinfo (car hostdat))) 84 (host (if hostinfo (car hostdat))) 51 (port (if (and hostinfo (> (length hostdat) 1))(cadr hostdat) #f))) 85 (port (if (and hostinfo (> (length hostdat) 1))(cadr hostdat) #f))) > 86 (if (and port > 87 (string->number port)) > 88 (debug:print 2 "INFO: Setting up to connect to host " host ":" port)) 52 (set! *runremote* (vector host port)))) | 89 (set! *runremote* (if port (vector host (string->number port)) #f)))) > 90
Modified tests.scm from [1a89bc4432adb3e4] to [fab9cd8fcddce0b6].
9 9 10 (include "common_records.scm") 10 (include "common_records.scm") 11 (include "key_records.scm") 11 (include "key_records.scm") 12 (include "db_records.scm") 12 (include "db_records.scm") 13 (include "run_records.scm") 13 (include "run_records.scm") 14 (include "test_records.scm") 14 (include "test_records.scm") 15 15 16 < 17 (define (register-test db run-id test-name item-path) 16 (define (register-test db run-id test-name item-path) 18 (let ((item-paths (if (equal? item-path "") 17 (let ((item-paths (if (equal? item-path "") 19 (list item-path) 18 (list item-path) 20 (list item-path "")))) 19 (list item-path "")))) 21 (for-each 20 (for-each 22 (lambda (pth) 21 (lambda (pth) 23 (sqlite3:execute db "INSERT OR IGNORE INTO tests (run_id,testname,event_t 22 (sqlite3:execute db "INSERT OR IGNORE INTO tests (run_id,testname,event_t ................................................................................................................................................................................ 367 #f)))))))) 366 #f)))))))) 368 367 369 368 370 ;;====================================================================== 369 ;;====================================================================== 371 ;; test steps 370 ;; test steps 372 ;;====================================================================== 371 ;;====================================================================== 373 372 374 (define (teststep-set-status! db run-id test-name teststep-name state-in status- | 373 ;; teststep-set-status! used to be here 375 (debug:print 4 "run-id: " run-id " test-name: " test-name) < 376 (let* ((state (check-valid-items "state" state-in)) < 377 (status (check-valid-items "status" status-in)) < 378 (item-path (item-list->path itemdat)) < 379 (testdat (db:get-test-info db run-id test-name item-path))) < 380 (debug:print 5 "testdat: " testdat) < 381 (if (and testdat ;; if the section exists then force specification BUG, I do < 382 (or (not state)(not status))) < 383 (debug:print 0 "WARNING: Invalid " (if status "status" "state") < 384 " value \"" (if status state-in status-in) "\", update your valid < 385 (if testdat < 386 (let ((test-id (test:get-id testdat))) < 387 ;; FIXME - this should not update the logfile unless it is specified. < 388 (sqlite3:execute db < 389 "INSERT OR REPLACE into test_steps (test_id,stepname,sta < 390 test-id teststep-name state-in status-in (if comment com < 391 (debug:print 0 "ERROR: Can't update " test-name " for run " run-id " -> < 392 374 393 (define (test-get-kill-request db run-id test-name itemdat) 375 (define (test-get-kill-request db run-id test-name itemdat) 394 (let* ((item-path (item-list->path itemdat)) 376 (let* ((item-path (item-list->path itemdat)) 395 (testdat (db:get-test-info db run-id test-name item-path))) 377 (testdat (db:get-test-info db run-id test-name item-path))) 396 (equal? (test:get-state testdat) "KILLREQ"))) 378 (equal? (test:get-state testdat) "KILLREQ"))) 397 379 398 (define (test-set-meta-info db run-id testname itemdat) 380 (define (test-set-meta-info db run-id testname itemdat)