Check-in [ad71efd688]
Not logged in
Overview
SHA1 Hash:ad71efd688d014165284e1baad5eadac6a455762
Date: 2012-02-24 03:21:53
User: matt
Comment:No need for the archiving branch, work not happening there anyway so merging to trunk
Timelines: family | ancestors | descendants | both | trunk
Downloads: Tarball | ZIP archive
Other Links: files | file ages | manifest
Tags And Properties
Changes

Modified Makefile from [322e8fb253d6513d] to [cd8f90dd01fd3cd8].

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 [5c4216dd3a11f4b7] to [ea2d2124424f7b1d].

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))) ................................................................................................................................................................................ 83 final_logf TEXT DEFAULT 'logs/final.log', 87 final_logf TEXT DEFAULT 'logs/final.log', 84 logdat BLOB, 88 logdat BLOB, 85 run_duration INTEGER DEFAULT 0, 89 run_duration INTEGER DEFAULT 0, 86 comment TEXT DEFAULT '', 90 comment TEXT DEFAULT '', 87 event_time TIMESTAMP, 91 event_time TIMESTAMP, 88 fail_count INTEGER DEFAULT 0, 92 fail_count INTEGER DEFAULT 0, 89 pass_count INTEGER DEFAULT 0, 93 pass_count INTEGER DEFAULT 0, > 94 archived INTEGER DEFAULT 0, -- 0=no, 1=in progress, 2=yes 90 CONSTRAINT testsconstraint UNIQUE (run_id, testname, item_p 95 CONSTRAINT testsconstraint UNIQUE (run_id, testname, item_p 91 );") 96 );") 92 (sqlite3:execute db "CREATE INDEX tests_index ON tests (run_id, testna 97 (sqlite3:execute db "CREATE INDEX tests_index ON tests (run_id, testna 93 (sqlite3:execute db "CREATE VIEW runs_tests AS SELECT * FROM runs INNE 98 (sqlite3:execute db "CREATE VIEW runs_tests AS SELECT * FROM runs INNE 94 (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_steps 99 (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_steps 95 (id INTEGER PRIMARY KEY, 100 (id INTEGER PRIMARY KEY, 96 test_id INTEGER, 101 test_id INTEGER, ................................................................................................................................................................................ 128 comment TEXT DEFAULT '', 133 comment TEXT DEFAULT '', 129 status TEXT DEFAULT 'n/a', 134 status TEXT DEFAULT 'n/a', 130 type TEXT DEFAULT '', 135 type TEXT DEFAULT '', 131 CONSTRAINT test_data_constraint UNIQUE (test_id,ca 136 CONSTRAINT test_data_constraint UNIQUE (test_id,ca 132 ;; Must do this *after* running patch db !! No more. 137 ;; Must do this *after* running patch db !! No more. 133 (db:set-var db "MEGATEST_VERSION" megatest-version) 138 (db:set-var db "MEGATEST_VERSION" megatest-version) 134 )) 139 )) > 140 (server:client-setup db) 135 db)) 141 db)) 136 142 137 ;;====================================================================== 143 ;;====================================================================== 138 ;; TODO: 144 ;; TODO: 139 ;; put deltas into an assoc list with version numbers 145 ;; put deltas into an assoc list with version numbers 140 ;; apply all from last to current 146 ;; apply all from last to current 141 ;;====================================================================== 147 ;;====================================================================== ................................................................................................................................................................................ 208 (patch-db)) 214 (patch-db)) 209 ((< mver 1.29) 215 ((< mver 1.29) 210 (db:set-var db "MEGATEST_VERSION" 1.29) 216 (db:set-var db "MEGATEST_VERSION" 1.29) 211 (sqlite3:execute db "ALTER TABLE test_steps ADD COLUMN logfile TEXT DEFAU 217 (sqlite3:execute db "ALTER TABLE test_steps ADD COLUMN logfile TEXT DEFAU 212 (sqlite3:execute db "ALTER TABLE tests ADD COLUMN shortdir TEXT DEFAULT ' 218 (sqlite3:execute db "ALTER TABLE tests ADD COLUMN shortdir TEXT DEFAULT ' 213 ((< mver 1.36) 219 ((< mver 1.36) 214 (db:set-var db "MEGATEST_VERSION" 1.36) 220 (db:set-var db "MEGATEST_VERSION" 1.36) 215 (sqlite3:execute db "ALTER TABLER test_meta ADD COLUMN jobgroup TEXT DEFA | 221 (sqlite3:execute db "ALTER TABLE test_meta ADD COLUMN jobgroup TEXT DEFAU > 222 ((< mver 1.37) > 223 (db:set-var db "MEGATEST_VERSION" 1.37) > 224 (sqlite3:execute db "ALTER TABLE tests ADD COLUMN archived INTEGER DEFAUL 216 ((< mver megatest-version) 225 ((< mver megatest-version) 217 (db:set-var db "MEGATEST_VERSION" megatest-version)))))) 226 (db:set-var db "MEGATEST_VERSION" megatest-version)))))) 218 227 219 ;;====================================================================== 228 ;;====================================================================== 220 ;; meta get and set vars 229 ;; meta get and set vars 221 ;;====================================================================== 230 ;;====================================================================== 222 231 ................................................................................................................................................................................ 410 (sqlite3:execute db "DELETE FROM tests WHERE state=? AND run_id=?;" state run- 419 (sqlite3:execute db "DELETE FROM tests WHERE state=? AND run_id=?;" state run- 411 420 412 (define (db:test-set-state-status-by-id db test-id newstate newstatus newcomment 421 (define (db:test-set-state-status-by-id db test-id newstate newstatus newcomment 413 (if newstate (sqlite3:execute db "UPDATE tests SET state=? WHERE id=?;" ne 422 (if newstate (sqlite3:execute db "UPDATE tests SET state=? WHERE id=?;" ne 414 (if newstatus (sqlite3:execute db "UPDATE tests SET status=? WHERE id=?;" ne 423 (if newstatus (sqlite3:execute db "UPDATE tests SET status=? WHERE id=?;" ne 415 (if newcomment (sqlite3:execute db "UPDATE tests SET comment=? WHERE id=?;" ne 424 (if newcomment (sqlite3:execute db "UPDATE tests SET comment=? WHERE id=?;" ne 416 425 > 426 (define (db:test-set-state-status-by-run-id-testname db run-id test-name item-pa > 427 (sqlite3:execute db "UPDATE tests SET state=?,status=?,event_time=strftime('%s > 428 state status run-id test-name item-path)) > 429 417 (define (db:get-count-tests-running db) 430 (define (db:get-count-tests-running db) 418 (let ((res 0)) 431 (let ((res 0)) 419 (sqlite3:for-each-row 432 (sqlite3:for-each-row 420 (lambda (count) 433 (lambda (count) 421 (set! res count)) 434 (set! res count)) 422 db 435 db 423 "SELECT count(id) FROM tests WHERE state = 'RUNNING' OR state = 'LAUNCHED' 436 "SELECT count(id) FROM tests WHERE state = 'RUNNING' OR state = 'LAUNCHED' ................................................................................................................................................................................ 466 (set! res (vector id run-id testname state status event-time host cpuload 479 (set! res (vector id run-id testname state status event-time host cpuload 467 db 480 db 468 "SELECT id,run_id,testname,state,status,event_time,host,cpuload,diskfree,un 481 "SELECT id,run_id,testname,state,status,event_time,host,cpuload,diskfree,un 469 test-id) 482 test-id) 470 res)) 483 res)) 471 484 472 485 473 (define (db:test-set-comment db run-id testname item-path comment) | 486 (define (db:test-set-comment db run-id test-name item-path comment) 474 (sqlite3:execute 487 (sqlite3:execute 475 db 488 db 476 "UPDATE tests SET comment=? WHERE run_id=? AND testname=? AND item_path=?;" 489 "UPDATE tests SET comment=? WHERE run_id=? AND testname=? AND item_path=?;" 477 comment run-id testname item-path)) | 490 comment run-id test-name item-path)) 478 491 479 ;; 492 ;; 480 (define (db:test-set-rundir! db run-id testname item-path rundir) | 493 (define (db:test-set-rundir! db run-id test-name item-path rundir) 481 (sqlite3:execute 494 (sqlite3:execute 482 db 495 db 483 "UPDATE tests SET rundir=? WHERE run_id=? AND testname=? AND item_path=?;" 496 "UPDATE tests SET rundir=? WHERE run_id=? AND testname=? AND item_path=?;" 484 rundir run-id testname item-path)) | 497 rundir run-id test-name item-path)) 485 498 > 499 (define (db:test-set-log! db run-id test-name item-path logf) > 500 (sqlite3:execute db "UPDATE tests SET final_logf=? WHERE run_id=? AND testname > 501 logf run-id test-name item-path)) > 502 > 503 ;;====================================================================== 486 ;; Misc. test related queries 504 ;; Misc. test related queries > 505 ;;====================================================================== > 506 487 (define (db:test-get-paths-matching db keynames target) 507 (define (db:test-get-paths-matching db keynames target) 488 (let* ((res '()) 508 (let* ((res '()) 489 (itempatt (if (args:get-arg "-itempatt")(args:get-arg "-itempatt") "% 509 (itempatt (if (args:get-arg "-itempatt")(args:get-arg "-itempatt") "% 490 (testpatt (if (args:get-arg "-testpatt")(args:get-arg "-testpatt") "% 510 (testpatt (if (args:get-arg "-testpatt")(args:get-arg "-testpatt") "% 491 (statepatt (if (args:get-arg ":state") (args:get-arg ":state") "% 511 (statepatt (if (args:get-arg ":state") (args:get-arg ":state") "% 492 (statuspatt (if (args:get-arg ":status") (args:get-arg ":status") "% 512 (statuspatt (if (args:get-arg ":status") (args:get-arg ":status") "% 493 (runname (if (args:get-arg ":runname") (args:get-arg ":runname") "% 513 (runname (if (args:get-arg ":runname") (args:get-arg ":runname") "% ................................................................................................................................................................................ 504 (debug:print 3 "qrystr: " qrystr) 524 (debug:print 3 "qrystr: " qrystr) 505 (sqlite3:for-each-row 525 (sqlite3:for-each-row 506 (lambda (p) 526 (lambda (p) 507 (set! res (cons p res))) 527 (set! res (cons p res))) 508 db 528 db 509 qrystr) 529 qrystr) 510 res)) 530 res)) > 531 > 532 (define (db:test-get-test-records-matching db keynames target) > 533 (let* ((res '()) > 534 (itempatt (if (args:get-arg "-itempatt")(args:get-arg "-itempatt") "% > 535 (testpatt (if (args:get-arg "-testpatt")(args:get-arg "-testpatt") "% > 536 (statepatt (if (args:get-arg ":state") (args:get-arg ":state") "% > 537 (statuspatt (if (args:get-arg ":status") (args:get-arg ":status") "% > 538 (runname (if (args:get-arg ":runname") (args:get-arg ":runname") "% > 539 (keystr (string-intersperse > 540 (map (lambda (key val) > 541 (conc "r." key " like '" val "'")) > 542 keynames > 543 (string-split target "/")) > 544 " AND ")) > 545 (qrystr (conc "SELECT > 546 t.id > 547 t.run_id > 548 t.testname > 549 t.host > 550 t.cpuload > 551 t.diskfree > 552 t.uname > 553 t.rundir > 554 t.shortdir > 555 t.item_path > 556 t.state > 557 t.status > 558 t.attemptnum > 559 t.final_logf > 560 t.logdat > 561 t.run_duratio > 562 t.comment > 563 t.event_time > 564 t.fail_count > 565 t.pass_count > 566 t.archived > 567 > 568 > 569 > 570 FROM tests AS t INNER JOIN runs AS r ON t.run_id=r.id WHERE " > 571 keystr " AND r.runname LIKE '" runname "' AND item_path L > 572 testpatt "' AND t.state LIKE '" statepatt "' AND t.status > 573 "'ORDER BY t.event_time ASC;"))) > 574 (debug:print 3 "qrystr: " qrystr) > 575 (sqlite3:for-each-row > 576 (lambda (p) > 577 (set! res (cons p res))) > 578 db > 579 qrystr) > 580 res)) > 581 > 582 (define (db:test-update-meta-info db run-id test-name item-path minutes cpuload > 583 (if (not item-path) > 584 (begin (debug:print 0 "WARNING: ITEMPATH not set.") > 585 (set! item-path ""))) > 586 (sqlite3:execute > 587 db > 588 "UPDATE tests SET cpuload=?,diskfree=?,run_duration=?,state='RUNNING' WHERE r > 589 cpuload > 590 diskfree > 591 minutes > 592 run-id > 593 test-name > 594 item-path)) > 595 > 596 (define (db:roll-up-pass-fail-counts db run-id test-name item-path status) > 597 (if (and (not (equal? item-path "")) > 598 (or (equal? status "PASS") > 599 (equal? status "WARN") > 600 (equal? status "FAIL") > 601 (equal? status "WAIVED") > 602 (equal? status "RUNNING"))) > 603 (begin > 604 (sqlite3:execute > 605 db > 606 "UPDATE tests > 607 SET fail_count=(SELECT count(id) FROM tests WHERE run_id=? AND test > 608 pass_count=(SELECT count(id) FROM tests WHERE run_id=? AND test > 609 WHERE run_id=? AND testname=? AND item_path='';" > 610 run-id test-name run-id test-name run-id test-name) > 611 (if (equal? status "RUNNING") ;; running takes priority over all other s > 612 (sqlite3:execute db "UPDATE tests SET state=? WHERE run_id=? AND tes > 613 (sqlite3:execute > 614 db > 615 "UPDATE tests > 616 SET state=CASE WHEN (SELECT count(id) FROM tests WHERE ru > 617 'RUNNING' > 618 ELSE 'COMPLETED' END, > 619 status=CASE WHEN fail_count > 0 THEN 'FAIL' WHEN pass_ > 620 WHERE run_id=? AND testname=? AND item_path='';" > 621 run-id test-name run-id test-name))))) 511 622 512 623 513 ;;====================================================================== 624 ;;====================================================================== 514 ;; Tests meta data 625 ;; Tests meta data 515 ;;====================================================================== 626 ;;====================================================================== 516 627 517 ;; read the record given a testname 628 ;; read the record given a testname ................................................................................................................................................................................ 790 (if (not (or parent-waiton-met item-waiton-met)) 901 (if (not (or parent-waiton-met item-waiton-met)) 791 (set! result (cons waitontest-name result))) 902 (set! result (cons waitontest-name result))) 792 ;; if the test is not found then clearly the waiton is not met... 903 ;; if the test is not found then clearly the waiton is not met... 793 (if (not ever-seen)(set! result (cons waitontest-name result))))) 904 (if (not ever-seen)(set! result (cons waitontest-name result))))) 794 waitons) 905 waitons) 795 (delete-duplicates result)))) 906 (delete-duplicates result)))) 796 907 > 908 (define (db:teststep-set-status! db run-id test-name teststep-name state-in stat > 909 (debug:print 4 "run-id: " run-id " test-name: " test-name) > 910 (let* ((state (check-valid-items "state" state-in)) > 911 (status (check-valid-items "status" status-in)) > 912 (testdat (db:get-test-info db run-id test-name item-path))) > 913 (debug:print 5 "testdat: " testdat) > 914 (if (and testdat ;; if the section exists then force specification BUG, I do > 915 (or (not state)(not status))) > 916 (debug:print 0 "WARNING: Invalid " (if status "status" "state") > 917 " value \"" (if status state-in status-in) "\", update your valid > 918 (if testdat > 919 (let ((test-id (test:get-id testdat))) > 920 ;; FIXME - this should not update the logfile unless it is specified. > 921 (sqlite3:execute db > 922 "INSERT OR REPLACE into test_steps (test_id,stepname,sta > 923 test-id teststep-name state-in status-in (if comment com > 924 #t) ;; fake out a #t - could be execute is returning something complic > 925 (debug:print 0 "ERROR: Can't update " test-name " for run " run-id " -> > 926 797 ;;====================================================================== 927 ;;====================================================================== 798 ;; Extract ods file from the db 928 ;; Extract ods file from the db 799 ;;====================================================================== 929 ;;====================================================================== 800 930 801 ;; runspatt is a comma delimited list of run patterns 931 ;; runspatt is a comma delimited list of run patterns 802 ;; keypatt-alist must contain *all* keys with an associated pattern: '( ("KEY1" 932 ;; keypatt-alist must contain *all* keys with an associated pattern: '( ("KEY1" 803 (define (db:extract-ods-file db outputfile keypatt-alist runspatt pathmod) 933 (define (db:extract-ods-file db outputfile keypatt-alist runspatt pathmod) ................................................................................................................................................................................ 914 (debug:print 0 "WARNING: path given, " outputfile " is relative, pref 1044 (debug:print 0 "WARNING: path given, " outputfile " is relative, pref 915 (conc (current-directory) "/" outputfile))) 1045 (conc (current-directory) "/" outputfile))) 916 results) 1046 results) 917 ;; brutal clean up 1047 ;; brutal clean up 918 (system "rm -rf tempdir"))) 1048 (system "rm -rf tempdir"))) 919 1049 920 ;; (db:extract-ods-file db "outputfile.ods" '(("sysname" "%")("fsname" "%")("dat 1050 ;; (db:extract-ods-file db "outputfile.ods" '(("sysname" "%")("fsname" "%")("dat > 1051 > 1052 > 1053 ;;====================================================================== > 1054 ;; REMOTE DB ACCESS VIA RPC > 1055 ;;====================================================================== > 1056 > 1057 (define (rdb:set-tests-state-status db run-id testnames currstate currstatus new > 1058 (if *runremote* > 1059 (let ((host (vector-ref *runremote* 0)) > 1060 (port (vector-ref *runremote* 1))) > 1061 ((rpc:procedure 'rdb:set-tests-state-status host port) > 1062 run-id testnames currstate currstatus newstate newstatus)) > 1063 (db:set-tests-state-status db run-id testnames currstate currstatus newsta > 1064 > 1065 (define (rdb:teststep-set-status! db run-id test-name teststep-name state-in sta > 1066 (let ((item-path (item-list->path itemdat))) > 1067 (if *runremote* > 1068 (let ((host (vector-ref *runremote* 0)) > 1069 (port (vector-ref *runremote* 1))) > 1070 ((rpc:procedure 'rdb:teststep-set-status! host port) > 1071 run-id test-name teststep-name state-in status-in item-path comment l > 1072 (db:teststep-set-status! db run-id test-name teststep-name state-in stat > 1073 > 1074 (define (rdb:test-update-meta-info db run-id test-name itemdat minutes cpuload d > 1075 (let ((item-path (item-list->path itemdat))) > 1076 (if *runremote* > 1077 (let ((host (vector-ref *runremote* 0)) > 1078 (port (vector-ref *runremote* 1))) > 1079 ((rpc:procedure 'rdb:test-update-meta-info host port) > 1080 run-id test-name item-path minutes cpuload diskfree tmpfree)) > 1081 (db:test-update-meta-info db run-id test-name item-path minutes cpuload > 1082 > 1083 (define (rdb:test-set-state-status-by-run-id-testname db run-id test-name item-p > 1084 (if *runremote* > 1085 (let ((host (vector-ref *runremote* 0)) > 1086 (port (vector-ref *runremote* 1))) > 1087 ((rpc:procedure 'rdb:test-set-state-status-by-run-id-testname host port) > 1088 run-id test-name item-path status state)) > 1089 (db:test-set-state-status-by-run-id-testname db run-id test-name item-path > 1090 > 1091 (define (rdb:csv->test-data db test-id csvdata) > 1092 (if *runremote* > 1093 (let ((host (vector-ref *runremote* 0)) > 1094 (port (vector-ref *runremote* 1))) > 1095 ((rpc:procedure 'rdb:csv->test-data host port) > 1096 test-id csvdata)) > 1097 (db:csv->test-data db test-id csvdata))) > 1098 > 1099 (define (rdb:roll-up-pass-fail-counts db run-id test-name item-path status) > 1100 (if *runremote* > 1101 (let ((host (vector-ref *runremote* 0)) > 1102 (port (vector-ref *runremote* 1))) > 1103 ((rpc:procedure 'rdb:roll-up-pass-fail-counts host port) > 1104 run-id test-name item-path status)) > 1105 (db:roll-up-pass-fail-counts db run-id test-name item-path status))) > 1106 > 1107 (define (rdb:test-set-comment db run-id test-name item-path comment) > 1108 (if *runremote* > 1109 (let ((host (vector-ref *runremote* 0)) > 1110 (port (vector-ref *runremote* 1))) > 1111 ((rpc:procedure 'rdb:test-set-comment host port) > 1112 run-id test-name item-path comment)) > 1113 (db:test-set-comment db run-id test-name item-path comment))) > 1114 > 1115 (define (rdb:test-set-log! db run-id test-name item-path logf) > 1116 (if *runremote* > 1117 (let ((host (vector-ref *runremote* 0)) > 1118 (port (vector-ref *runremote* 1))) > 1119 ((rpc:procedure 'rpc:test-set-log! host port) > 1120 run-id test-name item-path logf)) > 1121 (db:test-set-log! db run-id test-name item-path logf)))

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 [354dcb520bf7bfab] to [9cc31957ba48845b].

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 ( ................................................................................................................................................................................ 245 (let* ((db (open-db)) 245 (let* ((db (open-db)) 246 (cpuload (get-cpu-load)) 246 (cpuload (get-cpu-load)) 247 (diskfree (get-df (current-directory 247 (diskfree (get-df (current-directory 248 (tmpfree (get-df "/tmp"))) 248 (tmpfree (get-df "/tmp"))) 249 (if (not cpuload) (begin (debug:print 0 249 (if (not cpuload) (begin (debug:print 0 250 (if (not diskfree) (begin (debug:print 0 250 (if (not diskfree) (begin (debug:print 0 251 (set! kill-job? (test-get-kill-request db 251 (set! kill-job? (test-get-kill-request db 252 (test-update-meta-info db run-id test-nam | 252 (rdb:test-update-meta-info db run-id test 253 (if kill-job? 253 (if kill-job? 254 (begin 254 (begin 255 (mutex-lock! m) 255 (mutex-lock! m) 256 (let* ((pid (vector-ref exit-info 0 256 (let* ((pid (vector-ref exit-info 0 257 (if (number? pid) 257 (if (number? pid) 258 (begin 258 (begin 259 (debug:print 0 "WARNING: Re 259 (debug:print 0 "WARNING: Re

Modified megatest-version.scm from [27dcca54210e5a68] to [2c87868cc4bdbdee].

1 ;; Always use two digit decimal 1 ;; Always use two digit decimal 2 ;; 1.01, 1.02...1.10,1.11 ... 1.99,2.00.. 2 ;; 1.01, 1.02...1.10,1.11 ... 1.99,2.00.. 3 3 4 (declare (unit megatest-version)) 4 (declare (unit megatest-version)) 5 5 6 (define megatest-version 1.36) | 6 (define megatest-version 1.37) 7 7

Modified megatest.scm from [a1f994c6abd1b98e] to [89234220c0226c55].

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 ................................................................................................................................................................................ 87 -rebuild-db : bring the database schema up to date 88 -rebuild-db : bring the database schema up to date 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. > 95 -archive : archive tests, use -target, :runname, -itempatt and > 96 -server -|hostname : start the server (reduces contention on megatest.db) > 97 - to automatically figure out hostname > 98 94 Spreadsheet generation 99 Spreadsheet generation 95 -extract-ods fname.ods : extract an open document spreadsheet from the databa 100 -extract-ods fname.ods : extract an open document spreadsheet from the databa 96 -pathmod path : insert path, i.e. path/runame/itempath/logfile.html 101 -pathmod path : insert path, i.e. path/runame/itempath/logfile.html 97 will clear the field if no rundir/testname/itempath/ 102 will clear the field if no rundir/testname/itempath/ 98 if it contains forward slashes the path will be conv 103 if it contains forward slashes the path will be conv 99 to windows style 104 to windows style 100 105 ................................................................................................................................................................................ 145 ":category" 150 ":category" 146 ":variable" 151 ":variable" 147 ":value" 152 ":value" 148 ":expected" 153 ":expected" 149 ":tol" 154 ":tol" 150 ":units" 155 ":units" 151 ;; misc 156 ;; misc > 157 "-server" 152 "-extract-ods" 158 "-extract-ods" 153 "-pathmod" 159 "-pathmod" 154 "-env2file" 160 "-env2file" 155 "-setvars" 161 "-setvars" 156 "-debug" ;; for *verbosity* > 2 162 "-debug" ;; for *verbosity* > 2 157 ) 163 ) 158 (list "-h" 164 (list "-h" ................................................................................................................................................................................ 160 "-xterm" 166 "-xterm" 161 "-showkeys" 167 "-showkeys" 162 "-test-status" 168 "-test-status" 163 "-set-values" 169 "-set-values" 164 "-load-test-data" 170 "-load-test-data" 165 "-summarize-items" 171 "-summarize-items" 166 "-gui" 172 "-gui" > 173 ;; misc > 174 "-archive" 167 ;; queries 175 ;; queries 168 "-test-paths" ;; get path(s) to a test, ordered by young 176 "-test-paths" ;; get path(s) to a test, ordered by young 169 177 170 "-runall" ;; run all tests 178 "-runall" ;; run all tests 171 "-remove-runs" 179 "-remove-runs" 172 "-keepgoing" 180 "-keepgoing" 173 "-usequeue" 181 "-usequeue" 174 "-rebuild-db" 182 "-rebuild-db" 175 "-rollup" 183 "-rollup" 176 "-update-meta" 184 "-update-meta" > 185 177 "-v" ;; verbose 2, more than normal (normal is 1) 186 "-v" ;; verbose 2, more than normal (normal is 1) 178 "-q" ;; quiet 0, errors/warnings only 187 "-q" ;; quiet 0, errors/warnings only 179 ) 188 ) 180 args:arg-hash 189 args:arg-hash 181 0)) 190 0)) 182 191 183 (if (args:get-arg "-h") 192 (if (args:get-arg "-h") ................................................................................................................................................................................ 373 runname 382 runname 374 (args:get-arg "-runtests") 383 (args:get-arg "-runtests") 375 (args:get-arg "-itempatt") 384 (args:get-arg "-itempatt") 376 user 385 user 377 (make-hash-table))))) 386 (make-hash-table))))) 378 387 379 ;;====================================================================== 388 ;;====================================================================== > 389 ;; Start the server > 390 ;;====================================================================== > 391 (if (args:get-arg "-server") > 392 (let* ((toppath (setup-for-run)) > 393 (db (if toppath (open-db) #f))) > 394 (if db > 395 (server:start db (args:get-arg "-server")) > 396 (debug:print 0 "ERROR: Failed to setup for megatest")))) > 397 > 398 ;;;====================================================================== 380 ;; Rollup into a run 399 ;; Rollup into a run 381 ;;====================================================================== 400 ;;====================================================================== 382 (if (args:get-arg "-rollup") 401 (if (args:get-arg "-rollup") 383 (general-run-call 402 (general-run-call 384 "-rollup" 403 "-rollup" 385 "rollup tests" 404 "rollup tests" 386 (lambda (db keys keynames keyvallst) 405 (lambda (db keys keynames keyvallst) ................................................................................................................................................................................ 389 (keys->alist keys "na") 408 (keys->alist keys "na") 390 (args:get-arg ":runname") 409 (args:get-arg ":runname") 391 user)))) 410 user)))) 392 411 393 ;;====================================================================== 412 ;;====================================================================== 394 ;; Get paths to tests 413 ;; Get paths to tests 395 ;;====================================================================== 414 ;;====================================================================== 396 ;; run all tests are are Not COMPLETED and PASS or CHECK | 415 ;; Get test paths matching target, runname, testpatt, and itempatt 397 (if (args:get-arg "-test-paths") 416 (if (args:get-arg "-test-paths") 398 ;; if we are in a test use the MT_CMDINFO data 417 ;; if we are in a test use the MT_CMDINFO data 399 (if (getenv "MT_CMDINFO") 418 (if (getenv "MT_CMDINFO") 400 (let* ((startingdir (current-directory)) 419 (let* ((startingdir (current-directory)) 401 (cmdinfo (read (open-input-string (base64:base64-decode (getenv 420 (cmdinfo (read (open-input-string (base64:base64-decode (getenv 402 (testpath (assoc/default 'testpath cmdinfo)) 421 (testpath (assoc/default 'testpath cmdinfo)) 403 (test-name (assoc/default 'test-name cmdinfo)) 422 (test-name (assoc/default 'test-name cmdinfo)) ................................................................................................................................................................................ 414 (begin 433 (begin 415 (debug:print 0 "ERROR: -target is required.") 434 (debug:print 0 "ERROR: -target is required.") 416 (exit 1))) 435 (exit 1))) 417 (if (not (setup-for-run)) 436 (if (not (setup-for-run)) 418 (begin 437 (begin 419 (debug:print 0 "Failed to setup, giving up on -test-paths, exiti 438 (debug:print 0 "Failed to setup, giving up on -test-paths, exiti 420 (exit 1))) 439 (exit 1))) > 440 (set! db (open-db)) > 441 (let* ((itempatt (args:get-arg "-itempatt")) > 442 (keys (db-get-keys db)) > 443 (keynames (map key:get-fieldname keys)) > 444 (paths (db:test-get-paths-matching db keynames target))) > 445 (set! *didsomething* #t) > 446 (for-each (lambda (path) > 447 (print path)) > 448 paths))) > 449 ;; else do a general-run-call > 450 (general-run-call > 451 "-test-paths" > 452 "Get paths to tests" > 453 (lambda (db target runname keys keynames keyvallst) > 454 (let* ((itempatt (args:get-arg "-itempatt")) > 455 (paths (db:test-get-paths-matching db keynames target))) > 456 (for-each (lambda (path) > 457 (print path)) > 458 paths)))))) > 459 > 460 ;;====================================================================== > 461 ;; Archive tests > 462 ;;====================================================================== > 463 ;; Archive tests matching target, runname, testpatt, and itempatt > 464 (if (args:get-arg "-archive") > 465 ;; if we are in a test use the MT_CMDINFO data > 466 (if (getenv "MT_CMDINFO") > 467 (let* ((startingdir (current-directory)) > 468 (cmdinfo (read (open-input-string (base64:base64-decode (getenv > 469 (testpath (assoc/default 'testpath cmdinfo)) > 470 (test-name (assoc/default 'test-name cmdinfo)) > 471 (runscript (assoc/default 'runscript cmdinfo)) > 472 (db-host (assoc/default 'db-host cmdinfo)) > 473 (run-id (assoc/default 'run-id cmdinfo)) > 474 (itemdat (assoc/default 'itemdat cmdinfo)) > 475 (db #f) > 476 (state (args:get-arg ":state")) > 477 (status (args:get-arg ":status")) > 478 (target (args:get-arg "-target"))) > 479 (change-directory testpath) > 480 (if (not target) > 481 (begin > 482 (debug:print 0 "ERROR: -target is required.") > 483 (exit 1))) > 484 (if (not (setup-for-run)) > 485 (begin > 486 (debug:print 0 "Failed to setup, giving up on -archive, exiting" > 487 (exit 1))) 421 (set! db (open-db)) 488 (set! db (open-db)) 422 (let* ((itempatt (args:get-arg "-itempatt")) 489 (let* ((itempatt (args:get-arg "-itempatt")) 423 (keys (db-get-keys db)) 490 (keys (db-get-keys db)) 424 (keynames (map key:get-fieldname keys)) 491 (keynames (map key:get-fieldname keys)) 425 (paths (db:test-get-paths-matching db keynames target))) 492 (paths (db:test-get-paths-matching db keynames target))) 426 (set! *didsomething* #t) 493 (set! *didsomething* #t) 427 (for-each (lambda (path) 494 (for-each (lambda (path) ................................................................................................................................................................................ 487 (change-directory testpath) 554 (change-directory testpath) 488 (if (not (setup-for-run)) 555 (if (not (setup-for-run)) 489 (begin 556 (begin 490 (debug:print 0 "Failed to setup, exiting") 557 (debug:print 0 "Failed to setup, exiting") 491 (exit 1))) 558 (exit 1))) 492 (set! db (open-db)) 559 (set! db (open-db)) 493 (if (and state status) 560 (if (and state status) 494 (teststep-set-status! db run-id test-name step state status itemda | 561 (rdb:teststep-set-status! db run-id test-name step state status it 495 (begin 562 (begin 496 (debug:print 0 "ERROR: You must specify :state and :status with 563 (debug:print 0 "ERROR: You must specify :state and :status with 497 (exit 6))) 564 (exit 6))) 498 (sqlite3:finalize! db) 565 (sqlite3:finalize! db) 499 (set! *didsomething* #t)))) 566 (set! *didsomething* #t)))) 500 567 501 (if (or (args:get-arg "-setlog") ;; since setting up is so costly lets pig 568 (if (or (args:get-arg "-setlog") ;; since setting up is so costly lets pig ................................................................................................................................................................................ 550 (redir (case (string->symbol shell) 617 (redir (case (string->symbol shell) 551 ((tcsh csh ksh) ">&") 618 ((tcsh csh ksh) ">&") 552 ((zsh bash sh ash) "2>&1 >"))) 619 ((zsh bash sh ash) "2>&1 >"))) 553 (fullcmd (conc "(" (string-intersperse 620 (fullcmd (conc "(" (string-intersperse 554 (cons cmd params) " ") 621 (cons cmd params) " ") 555 ") " redir " " logfile))) 622 ") " redir " " logfile))) 556 ;; mark the start of the test 623 ;; mark the start of the test 557 (teststep-set-status! db run-id test-name stepname "start" " | 624 (rdb:teststep-set-status! db run-id test-name stepname "star 558 ;; close the db 625 ;; close the db 559 (sqlite3:finalize! db) 626 (sqlite3:finalize! db) 560 ;; run the test step 627 ;; run the test step 561 (debug:print 2 "INFO: Running \"" fullcmd "\"") 628 (debug:print 2 "INFO: Running \"" fullcmd "\"") 562 (change-directory startingdir) 629 (change-directory startingdir) 563 (set! exitstat (system fullcmd)) ;; cmd params)) 630 (set! exitstat (system fullcmd)) ;; cmd params)) 564 (set! *globalexitstatus* exitstat) 631 (set! *globalexitstatus* exitstat) ................................................................................................................................................................................ 572 (cmd (string-intersperse (list "logpro" l 639 (cmd (string-intersperse (list "logpro" l 573 (debug:print 2 "INFO: running \"" cmd "\"") 640 (debug:print 2 "INFO: running \"" cmd "\"") 574 (change-directory startingdir) 641 (change-directory startingdir) 575 (set! exitstat (system cmd)) 642 (set! exitstat (system cmd)) 576 (set! *globalexitstatus* exitstat) ;; no necessary 643 (set! *globalexitstatus* exitstat) ;; no necessary 577 (change-directory testpath) 644 (change-directory testpath) 578 (test-set-log! db run-id test-name itemdat htmllogfile 645 (test-set-log! db run-id test-name itemdat htmllogfile 579 (teststep-set-status! db run-id test-name stepname "end" exi | 646 (rdb:teststep-set-status! db run-id test-name stepname "end" 580 (sqlite3:finalize! db) 647 (sqlite3:finalize! db) 581 (if (not (eq? exitstat 0)) 648 (if (not (eq? exitstat 0)) 582 (exit 254)) ;; (exit exitstat) doesn't work?!? 649 (exit 254)) ;; (exit exitstat) doesn't work?!? 583 ;; open the db 650 ;; open the db 584 ;; mark the end of the test 651 ;; mark the end of the test 585 ))) 652 ))) 586 (if (or (args:get-arg "-test-status") 653 (if (or (args:get-arg "-test-status")

Modified runs.scm from [6ee5dc7a4131aeb6] 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 ................................................................................................................................................................................ 407 408 408 ;; (lambda (itemdat) ;;; ((ripeness "overripe") (temperature "cool") (season 409 ;; (lambda (itemdat) ;;; ((ripeness "overripe") (temperature "cool") (season 409 (let* ((new-test-path (string-intersperse (cons test-path (map cadr itemdat) 410 (let* ((new-test-path (string-intersperse (cons test-path (map cadr itemdat) 410 (new-test-name (if (equal? item-path "") test-name (conc test-name "/ 411 (new-test-name (if (equal? item-path "") test-name (conc test-name "/ 411 (testdat (db:get-test-info db run-id test-name item-path))) 412 (testdat (db:get-test-info db run-id test-name item-path))) 412 (if (not testdat) 413 (if (not testdat) 413 (begin 414 (begin > 415 ;; ensure that the path exists before registering the test > 416 (system (conc "mkdir -p " new-test-path)) 414 (register-test db run-id test-name item-path) 417 (register-test db run-id test-name item-path) 415 (set! testdat (db:get-test-info db run-id test-name item-path)))) 418 (set! testdat (db:get-test-info db run-id test-name item-path)))) 416 (change-directory test-path) 419 (change-directory test-path) 417 (case (if force ;; (args:get-arg "-force") 420 (case (if force ;; (args:get-arg "-force") 418 'NOT_STARTED 421 'NOT_STARTED 419 (if testdat 422 (if testdat 420 (string->symbol (test:get-state testdat)) 423 (string->symbol (test:get-state testdat))

Modified server.scm from [0bbf1bf4b67c22bc] to [ed22148f791920de].

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 hostinfo) > 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)) 20 (if *runremote* 32 (if *runremote* 21 (apply (eval (string->symbol (conc "remote:" procstr))) params) 33 (apply (eval (string->symbol (conc "remote:" procstr))) 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 hostn) 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-por 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)) > 42 (hostname (if (string=? "-" hostn) > 43 (get-host-name) > 44 hostn)) > 45 (ipaddrstr (if (string=? "-" hostn) > 46 (string-intersperse (map number->string (u8vector-> > 47 #f)) 30 (db:set-var db "SERVER" (conc (get-host-name) ":" (rpc:default-server-port)) | 48 (host:port (conc (if ipaddrstr ipaddrstr hostname) ":" (rpc:defaul > 49 (db:set-var db "SERVER" host:port) 31 (rpc:publish-procedure! 50 (rpc:publish-procedure! 32 'remote:run 51 'remote:run 33 (lambda (procstr . params) 52 (lambda (procstr . params) 34 (server:autoremote procstr params))) 53 (server:autoremote procstr params))) > 54 > 55 ;;====================================================================== > 56 ;; db specials here > 57 ;;====================================================================== > 58 ;; ** set-tests-state-status > 59 (rpc:publish-procedure! > 60 'rdb:set-tests-state-status > 61 (lambda (run-id testnames currstate currstatus newstate newstatus) > 62 (db:set-tests-state-status db run-id testnames currstate currstatus newst > 63 > 64 (rpc:publish-procedure! > 65 'rdb:teststep-set-status! > 66 (lambda (run-id test-name teststep-name state-in status-in item-path commen > 67 (db:teststep-set-status! db run-id test-name teststep-name state-in statu > 68 > 69 (rpc:publish-procedure! > 70 'rdb:test-update-meta-info > 71 (lambda (run-id testname item-path minutes cpuload diskfree tmpfree) > 72 (db:test-update-meta-info db run-id testname item-path minutes cpuload di > 73 > 74 (rpc:publish-procedure! > 75 'rdb:test-set-state-status-by-run-id-testname > 76 (lambda (run-id test-name item-path status state) > 77 (db:test-set-state-status-by-run-id-testname db run-id test-name item-pat > 78 > 79 (rpc:publish-procedure! > 80 'rdb:csv->test-data > 81 (lambda (test-id csvdata) > 82 (db:csv->data db test-id csvdata))) > 83 > 84 (rpc:publish-procedure! > 85 'rdb:roll-up-pass-fail-counts > 86 (lambda (run-id test-name item-path status) > 87 (db:roll-up-pass-fail-counts db run-id test-name item-path status))) > 88 > 89 (rpc:publish-procedure! > 90 'rdb:test-set-comment > 91 (lambda (run-id test-name item-path comment) > 92 (db:test-set-comment db run-id test-name item-path comment))) > 93 > 94 (rpc:publish-procedure! > 95 'rpc:test-set-log! > 96 (lambda (run-id test-name item-path logf) > 97 (db:test-set-log! db run-id test-name item-path logf))) > 98 35 (set! *rpc:listener* rpc:listener*) | 99 (set! *rpc:listener* rpc:listener) > 100 (on-exit (lambda () > 101 (sqlite3:execute db "DELETE FROM metadat WHERE var='SERVER' and v > 102 (sqlite3:finalize! db))) 36 (thread-start! rpc:server))) | 103 (thread-start! th1) > 104 (thread-join! th1))) ;; rpc:server))) 37 105 38 (define (server:find-free-port-and-open port) 106 (define (server:find-free-port-and-open port) 39 (handle-exceptions 107 (handle-exceptions 40 exn 108 exn 41 (begin 109 (begin 42 (print "Failed to bind to port " (rpc:default-server-port) ", trying next p 110 (print "Failed to bind to port " (rpc:default-server-port) ", trying next p 43 (server:find-free-port-and-open (+ port 1))) 111 (server:find-free-port-and-open (+ port 1))) ................................................................................................................................................................................ 45 (tcp-listen (rpc:default-server-port)))) 113 (tcp-listen (rpc:default-server-port)))) 46 114 47 (define (server:client-setup db) 115 (define (server:client-setup db) 48 (let* ((hostinfo (db:get-var db "SERVER")) 116 (let* ((hostinfo (db:get-var db "SERVER")) 49 (hostdat (if hostinfo (string-split hostinfo ":"))) 117 (hostdat (if hostinfo (string-split hostinfo ":"))) 50 (host (if hostinfo (car hostdat))) 118 (host (if hostinfo (car hostdat))) 51 (port (if (and hostinfo (> (length hostdat) 1))(cadr hostdat) #f))) 119 (port (if (and hostinfo (> (length hostdat) 1))(cadr hostdat) #f))) > 120 (if (and port > 121 (string->number port)) > 122 (debug:print 2 "INFO: Setting up to connect to host " host ":" port)) 52 (set! *runremote* (vector host port)))) | 123 (set! *runremote* (if port (vector host (string->number port)) #f)))) > 124

Modified tests.scm from [bf12d3e5724324b7] to [a1ec8539951555f0].

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 ................................................................................................................................................................................ 107 ;; this test is younger, store it in the hash 106 ;; this test is younger, store it in the hash 108 (hash-table-set! tests-hash full-testname testdat)))) 107 (hash-table-set! tests-hash full-testname testdat)))) 109 results) 108 results) 110 (if (null? tal) 109 (if (null? tal) 111 (map cdr (hash-table->alist tests-hash)) ;; return a list 110 (map cdr (hash-table->alist tests-hash)) ;; return a list 112 (loop (car tal)(cdr tal)))))))))) 111 (loop (car tal)(cdr tal)))))))))) 113 112 > 113 ;; 114 (define (test-set-status! db run-id test-name state status itemdat-or-path comme 114 (define (test-set-status! db run-id test-name state status itemdat-or-path comme 115 (let* ((real-status status) 115 (let* ((real-status status) 116 (item-path (if (string? itemdat-or-path) itemdat-or-path (item-list-> 116 (item-path (if (string? itemdat-or-path) itemdat-or-path (item-list-> 117 (testdat (db:get-test-info db run-id test-name item-path)) 117 (testdat (db:get-test-info db run-id test-name item-path)) 118 (test-id (if testdat (db:test-get-id testdat) #f)) 118 (test-id (if testdat (db:test-get-id testdat) #f)) 119 (otherdat (if dat dat (make-hash-table))) 119 (otherdat (if dat dat (make-hash-table))) 120 ;; 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 ................................................................................................................................................................................ 133 #f)) 133 #f)) 134 #f))) 134 #f))) 135 (if waived (set! real-status "WAIVED")) 135 (if waived (set! real-status "WAIVED")) 136 (debug:print 4 "real-status " real-status ", waived " waived ", status " sta 136 (debug:print 4 "real-status " real-status ", waived " waived ", status " sta 137 137 138 ;; update the primary record IF state AND status are defined 138 ;; update the primary record IF state AND status are defined 139 (if (and state status) 139 (if (and state status) 140 (sqlite3:execute db "UPDATE tests SET state=?,status=?,event_time=strfti < 141 state real-status run-id test-name item-path)) | 140 (rdb:test-set-state-status-by-run-id-testname db run-id test-name item-p 142 141 143 ;; if status is "AUTO" then call rollup | 142 ;; if status is "AUTO" then call rollup (note, this one modifies data in tes > 143 ;; run area, do not rpc it (yet) 144 (if (and test-id state status (equal? status "AUTO")) 144 (if (and test-id state status (equal? status "AUTO")) 145 (db:test-data-rollup db test-id status)) 145 (db:test-data-rollup db test-id status)) 146 146 147 ;; add metadata (need to do this way to avoid SQL injection issues) 147 ;; add metadata (need to do this way to avoid SQL injection issues) 148 148 149 ;; :first_err 149 ;; :first_err 150 ;; (let ((val (hash-table-ref/default otherdat ":first_err" #f))) 150 ;; (let ((val (hash-table-ref/default otherdat ":first_err" #f))) ................................................................................................................................................................................ 164 (units (hash-table-ref/default otherdat ":units" "")) 164 (units (hash-table-ref/default otherdat ":units" "")) 165 (type (hash-table-ref/default otherdat ":type" "")) 165 (type (hash-table-ref/default otherdat ":type" "")) 166 (dcomment (hash-table-ref/default otherdat ":comment" ""))) 166 (dcomment (hash-table-ref/default otherdat ":comment" ""))) 167 (debug:print 4 167 (debug:print 4 168 "category: " category ", variable: " variable ", value: " val 168 "category: " category ", variable: " variable ", value: " val 169 ", expected: " expected ", tol: " tol ", units: " units) 169 ", expected: " expected ", tol: " tol ", units: " units) 170 (if (and value expected tol) ;; all three required 170 (if (and value expected tol) ;; all three required 171 (db:csv->test-data db test-id | 171 (rdb:csv->test-data db test-id 172 (conc category "," 172 (conc category "," 173 variable "," 173 variable "," 174 value "," 174 value "," 175 expected "," 175 expected "," 176 tol "," 176 tol "," 177 units "," 177 units "," 178 dcomment ",," ;; extra comma for status 178 dcomment ",," ;; extra comma for status 179 type )))) 179 type )))) 180 180 181 ;; need to update the top test record if PASS or FAIL and this is a subtest 181 ;; need to update the top test record if PASS or FAIL and this is a subtest 182 (if (and (not (equal? item-path "")) | 182 (rdb:roll-up-pass-fail-counts db run-id test-name item-path status) 183 (or (equal? status "PASS") < 184 (equal? status "WARN") < 185 (equal? status "FAIL") < 186 (equal? status "WAIVED") < 187 (equal? status "RUNNING"))) < 188 (begin < 189 (sqlite3:execute < 190 db < 191 "UPDATE tests < 192 SET fail_count=(SELECT count(id) FROM tests WHERE run_id=? AND test < 193 pass_count=(SELECT count(id) FROM tests WHERE run_id=? AND test < 194 WHERE run_id=? AND testname=? AND item_path='';" < 195 run-id test-name run-id test-name run-id test-name) < 196 (if (equal? status "RUNNING") ;; running takes priority over all other < 197 (sqlite3:execute db "UPDATE tests SET state=? WHERE run_id=? AND t < 198 (sqlite3:execute < 199 db < 200 "UPDATE tests < 201 SET state=CASE WHEN (SELECT count(id) FROM tests WHERE ru < 202 'RUNNING' < 203 ELSE 'COMPLETED' END, < 204 status=CASE WHEN fail_count > 0 THEN 'FAIL' WHEN pass_ < 205 WHERE run_id=? AND testname=? AND item_path='';" < 206 run-id test-name run-id test-name)))) < > 183 207 (if (or (and (string? comment) 184 (if (or (and (string? comment) 208 (string-match (regexp "\\S+") comment)) 185 (string-match (regexp "\\S+") comment)) 209 waived) 186 waived) 210 (sqlite3:execute db "UPDATE tests SET comment=? WHERE run_id=? AND testn < 211 (if waived waived comment) run-id test-name item-path)) | 187 (rdb:test-set-comment db run-id test-name item-path (if waived waived c 212 )) 188 )) 213 189 214 (define (test-set-log! db run-id test-name itemdat logf) 190 (define (test-set-log! db run-id test-name itemdat logf) 215 (let ((item-path (item-list->path itemdat))) 191 (let ((item-path (item-list->path itemdat))) 216 (sqlite3:execute db "UPDATE tests SET final_logf=? WHERE run_id=? AND testna < 217 logf run-id test-name item-path))) | 192 (rdb:test-set-log! db run-id test-name item-path logf))) 218 193 219 (define (test-set-toplog! db run-id test-name logf) 194 (define (test-set-toplog! db run-id test-name logf) 220 (sqlite3:execute db "UPDATE tests SET final_logf=? WHERE run_id=? AND testname 195 (sqlite3:execute db "UPDATE tests SET final_logf=? WHERE run_id=? AND testname 221 logf run-id test-name)) 196 logf run-id test-name)) 222 197 223 (define (tests:summarize-items db run-id test-name force) 198 (define (tests:summarize-items db run-id test-name force) 224 ;; if not force then only update the record if one of these is true: 199 ;; if not force then only update the record if one of these is true: ................................................................................................................................................................................ 367 #f)))))))) 342 #f)))))))) 368 343 369 344 370 ;;====================================================================== 345 ;;====================================================================== 371 ;; test steps 346 ;; test steps 372 ;;====================================================================== 347 ;;====================================================================== 373 348 374 (define (teststep-set-status! db run-id test-name teststep-name state-in status- | 349 ;; 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 350 393 (define (test-get-kill-request db run-id test-name itemdat) 351 (define (test-get-kill-request db run-id test-name itemdat) 394 (let* ((item-path (item-list->path itemdat)) 352 (let* ((item-path (item-list->path itemdat)) 395 (testdat (db:get-test-info db run-id test-name item-path))) 353 (testdat (db:get-test-info db run-id test-name item-path))) 396 (equal? (test:get-state testdat) "KILLREQ"))) 354 (equal? (test:get-state testdat) "KILLREQ"))) 397 355 398 (define (test-set-meta-info db run-id testname itemdat) 356 (define (test-set-meta-info db run-id testname itemdat) ................................................................................................................................................................................ 408 diskfree 366 diskfree 409 uname 367 uname 410 runpath 368 runpath 411 run-id 369 run-id 412 testname 370 testname 413 item-path))) 371 item-path))) 414 372 415 (define (test-update-meta-info db run-id testname itemdat minutes cpuload diskfr < > 373 ;;====================================================================== 416 (let ((item-path (item-list->path itemdat))) | 374 ;; A R C H I V I N G 417 (if (not item-path)(begin (debug:print 0 "WARNING: ITEMPATH not set.") (se < 418 ;; (let ((testinfo (db:get-test-info db run-id testname item-path))) < > 375 ;;====================================================================== > 376 419 ;; (if (and (not (equal? (db:test-get-status testinfo) "COMPLETED")) | 377 (define (test:archive db test-id) 420 ;; (not (equal? (db:test-get-status testinfo) "KILLREQ")) | 378 #f) 421 (sqlite3:execute < 422 db < 423 "UPDATE tests SET cpuload=?,diskfree=?,run_duration=?,state='RUNNING' WHERE < 424 cpuload < 425 diskfree < 426 minutes < 427 run-id < 428 testname < 429 item-path))) < 430 379 > 380 (define (test:archive-tests db keynames target) > 381 #f)

Added tests/tests/neverrun/testconfig version [88f71844f474220c]

> 1 [setup] > 2 runscript idontexist > 3 > 4