Comment: | wip |
---|---|
Downloads: | Tarball | ZIP archive | SQL archive |
Timelines: | family | ancestors | descendants | both | v1.6584-ck5 |
Files: | files | file ages | folders |
SHA1: |
b2430732e090c38f35fd6ba87096beed |
User & Date: | matt on 2021-04-14 21:42:43 |
Other Links: | branch diff | manifest | tags |
2021-04-14
| ||
21:59 | wip check-in: 3e47d0a515 user: matt tags: v1.6584-ck5 | |
21:42 | wip check-in: b2430732e0 user: matt tags: v1.6584-ck5 | |
00:07 | wip check-in: 73ba59bf9c user: matt tags: v1.6584-ck5 | |
Modified Makefile from [0cf36bc26d] to [4ce39b8bf7].
︙ | ︙ | |||
28 29 30 31 32 33 34 | cookie.scm mutils.scm mtargs.scm apimod.scm \ configfmod.scm commonmod.scm dbmod.scm rmtmod.scm \ debugprint.scm mtver.scm csv-xml.scm servermod.scm \ hostinfo.scm adjutant.scm processmod.scm testsmod.scm \ itemsmod.scm keysmod.scm mtmod.scm rmtmod.scm \ tasksmod.scm pgdb.scm launchmod.o runsmod.scm \ http-transportmod.scm portloggermod.scm clientmod.scm \ | | | 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 | cookie.scm mutils.scm mtargs.scm apimod.scm \ configfmod.scm commonmod.scm dbmod.scm rmtmod.scm \ debugprint.scm mtver.scm csv-xml.scm servermod.scm \ hostinfo.scm adjutant.scm processmod.scm testsmod.scm \ itemsmod.scm keysmod.scm mtmod.scm rmtmod.scm \ tasksmod.scm pgdb.scm launchmod.o runsmod.scm \ http-transportmod.scm portloggermod.scm clientmod.scm \ archivemod.scm ezstepsmod.o subrunmod.scm GUISRCF = dashboard-context-menu.scm dashboard-tests.scm \ dashboard-guimonitor.scm gutils.scm dcommon.scm tree.scm \ vg.scm OFILES = $(SRCFILES:%.scm=%.o) GOFILES = $(GUISRCF:%.scm=%.o) |
︙ | ︙ | |||
60 61 62 63 64 65 66 67 | mofiles/dbmod.o mofiles/rmtmod.o : mofiles/commonmod.o mofiles/servermod.o : mofiles/commonmod.o mofiles/apimod.o : mofiles/servermod.o mofiles/apimod.o : mofiles/tasksmod.o mofiles/archivemod.o : mofiles/launchmod.o mofiles/clientmod.o : mofiles/servermod.o | > < > | > > | | | | | 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 | mofiles/dbmod.o mofiles/rmtmod.o : mofiles/commonmod.o mofiles/servermod.o : mofiles/commonmod.o mofiles/apimod.o : mofiles/servermod.o mofiles/apimod.o : mofiles/tasksmod.o mofiles/archivemod.o : mofiles/launchmod.o mofiles/archivemod.o : mofiles/servermod.o mofiles/clientmod.o : mofiles/servermod.o mofiles/commonmod.o : mofiles/configfmod.o mofiles/commonmod.o : mofiles/debugprint.o mofiles/commonmod.o : mofiles/hostinfo.o mofiles/commonmod.o : mofiles/itemsmod.o mofiles/commonmod.o : mofiles/keysmod.o mofiles/commonmod.o : mofiles/mtargs.o mofiles/commonmod.o : mofiles/mtver.o mofiles/commonmod.o : mofiles/processmod.o mofiles/configfmod.o : mofiles/keysmod.o mofiles/dbmod.o : mofiles/csv-xml.o mofiles/keysmod.o mofiles/mtmod.o mofiles/ezstepsmod.o : mofiles/rmtmod.o mofiles/ezstepsmod.o : mofiles/subrunmod.o mofiles/http-transportmod.o : mofiles/dbmod.o mofiles/portloggermod.o mofiles/launchmod.o : mofiles/ezstepsmod.o mofiles/launchmod.o : mofiles/rmtmod.o mofiles/servermod.o mofiles/mtmod.o : mofiles/debugprint.o # mofiles/mtmod.o : mofiles/rmtmod.o mofiles/portlogger.o : mofiles/tasksmod.o mofiles/rmtmod.o : mofiles/apimod.o mofiles/rmtmod.o : mofiles/itemsmod.o mofiles/clientmod.o mofiles/runsmod.o : mofiles/rmtmod.o mofiles/archivemod.o mofiles/servermod.o : mofiles/http-transportmod.o mofiles/tasksmod.o : mofiles/pgdb.o mofiles/dbmod.o mofiles/testsmod.o : mofiles/itemsmod.o mofiles/rmtmod.o mofiles/tasksmod.o |
︙ | ︙ | |||
411 412 413 414 415 416 417 | targets: @grep : Makefile | perl -ne '/^([A-Za-z0-9_-]+):/ && print "$$1\n"' unit : cd tests;make unit | | > > > > > > | 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 | targets: @grep : Makefile | perl -ne '/^([A-Za-z0-9_-]+):/ && print "$$1\n"' unit : cd tests;make unit DEPSFILES=*mod.scm # (MSRCFILES) # shell ls *.scm adjutant.scm cgisetup/models/pgdb.scm|sort -u|egrep -v '.import.|debugprint|mtargs|sretrieve|sauth|sharedat|tcmt') deps.pdf : $(DEPSFILES) gendeps deps.inc $(DEPSFILES) dot deps.dot -Tpdf -o deps.pdf showdepfiles : @echo $(DEPSFILES) |
Modified archivemod.scm from [bac40198c7] to [f8a6de6075].
︙ | ︙ | |||
27 28 29 30 31 32 33 34 35 36 37 38 39 40 | ;; (declare (uses csv-xml)) ;; (declare (uses keysmod)) (declare (uses mtmod)) (declare (uses dbmod)) (declare (uses rmtmod)) (declare (uses launchmod)) (declare (uses processmod)) (module archivemod * (import scheme (prefix sqlite3 sqlite3:) chicken.base | > | 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 | ;; (declare (uses csv-xml)) ;; (declare (uses keysmod)) (declare (uses mtmod)) (declare (uses dbmod)) (declare (uses rmtmod)) (declare (uses launchmod)) (declare (uses processmod)) (declare (uses servermod)) (module archivemod * (import scheme (prefix sqlite3 sqlite3:) chicken.base |
︙ | ︙ | |||
77 78 79 80 81 82 83 84 85 86 87 88 89 90 | ;; keysmod mtmod mtver dbmod rmtmod launchmod processmod ) ;; strftime('%m/%d/%Y %H:%M:%S','now','localtime') ;; ;; (use (prefix sqlite3 sqlite3:) srfi-1 posix regex regex-case srfi-69 format md5 message-digest srfi-18) ;; | > | 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 | ;; keysmod mtmod mtver dbmod rmtmod launchmod processmod servermod ) ;; strftime('%m/%d/%Y %H:%M:%S','now','localtime') ;; ;; (use (prefix sqlite3 sqlite3:) srfi-1 posix regex regex-case srfi-69 format md5 message-digest srfi-18) ;; |
︙ | ︙ |
Name change from mockup-cached-writes.scm to attic/mockup-cached-writes.scm.
whitespace changes only
Name change from portlogger-example.scm to attic/portlogger-example.scm.
whitespace changes only
Name change from show-uncalled-procedures.scm to attic/show-uncalled-procedures.scm.
whitespace changes only
Modified ezstepsmod.scm from [9dd7e8ebd1] to [6bc412a811].
︙ | ︙ | |||
51 52 53 54 55 56 57 58 59 60 61 62 63 64 | chicken.sort chicken.string chicken.time chicken.time.posix (prefix base64 base64:) csv-xml directory-utils matchable regex s11n srfi-1 srfi-13 srfi-18 | > | 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 | chicken.sort chicken.string chicken.time chicken.time.posix (prefix base64 base64:) csv-xml csv-abnf directory-utils matchable regex s11n srfi-1 srfi-13 srfi-18 |
︙ | ︙ |
Modified launchmod.scm from [e02c4b9b76] to [cd179d448d].
︙ | ︙ | |||
30 31 32 33 34 35 36 37 38 39 40 41 42 43 | (declare (uses mtmod)) (declare (uses mtver)) (declare (uses processmod)) (declare (uses rmtmod)) (declare (uses servermod)) (declare (uses testsmod)) (declare (uses ezstepsmod)) (module launchmod * (import scheme (prefix sqlite3 sqlite3:) chicken.base | > > | 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 | (declare (uses mtmod)) (declare (uses mtver)) (declare (uses processmod)) (declare (uses rmtmod)) (declare (uses servermod)) (declare (uses testsmod)) (declare (uses ezstepsmod)) (declare (uses subrunmod)) ;; (declare (uses servermod)) (module launchmod * (import scheme (prefix sqlite3 sqlite3:) chicken.base |
︙ | ︙ | |||
53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 | chicken.process-context chicken.process-context.posix chicken.process.signal chicken.sort chicken.string chicken.time chicken.time.posix (prefix base64 base64:) csv-xml directory-utils matchable regex s11n srfi-1 srfi-13 srfi-18 srfi-69 stack system-information typed-records z3 sxml-serializer sxml-modifications (prefix sxml-modifications sxml-) sxml-transforms | > < < < | | | | | | | | | | | | | > > > | 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 | chicken.process-context chicken.process-context.posix chicken.process.signal chicken.sort chicken.string chicken.time chicken.time.posix chicken.bitwise (prefix base64 base64:) csv-xml directory-utils matchable regex s11n srfi-1 srfi-13 srfi-18 srfi-69 stack system-information typed-records z3 sxml-serializer sxml-modifications (prefix sxml-modifications sxml-) sxml-transforms (prefix mtargs args:) commonmod configfmod dbmod debugprint keysmod mtmod mtver processmod rmtmod servermod testsmod ezstepsmod subrunmod ;; (import servermod) ) (include "db_records.scm") (include "key_records.scm") ;;====================================================================== ;; ezsteps ;;====================================================================== |
︙ | ︙ |
Modified mt.scm from [53dc19790d] to [4764783860].
︙ | ︙ | |||
11 12 13 14 15 16 17 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see <http://www.gnu.org/licenses/>. ;; | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 11 12 13 14 15 16 17 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see <http://www.gnu.org/licenses/>. ;; |
Modified mtmod.scm from [cbfcb5b3d1] to [df18d8fd34].
︙ | ︙ | |||
17 18 19 20 21 22 23 24 25 26 27 28 29 30 | ;; along with Megatest. If not, see <http://www.gnu.org/licenses/>. ;;====================================================================== (declare (unit mtmod)) ;; (declare (uses mtargs)) (declare (uses debugprint)) (module mtmod * (import scheme chicken.base | > > > | 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 | ;; along with Megatest. If not, see <http://www.gnu.org/licenses/>. ;;====================================================================== (declare (unit mtmod)) ;; (declare (uses mtargs)) (declare (uses debugprint)) (declare (uses commonmod)) (declare (uses dbmod)) ;; (declare (uses rmtmod)) (module mtmod * (import scheme chicken.base |
︙ | ︙ | |||
39 40 41 42 43 44 45 46 47 48 49 50 51 52 | chicken.sort chicken.string chicken.time debugprint ;; mtargs ;; pkts (prefix base64 base64:) (prefix dbi dbi:) (prefix sqlite3 sqlite3:) (srfi 18) directory-utils format | > > > | 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 | chicken.sort chicken.string chicken.time debugprint ;; mtargs ;; pkts commonmod dbmod ;; rmtmod (prefix base64 base64:) (prefix dbi dbi:) (prefix sqlite3 sqlite3:) (srfi 18) directory-utils format |
︙ | ︙ | |||
61 62 63 64 65 66 67 68 | srfi-69 stack typed-records z3 ) | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 | srfi-69 stack typed-records z3 ) ;; (use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking (srfi 18) posix-extras directory-utils call-with-environment-variables) ;; (import (prefix sqlite3 sqlite3:)) ;; ;; (declare (unit mt)) ;; (declare (uses db)) ;; (declare (uses common)) ;; (declare (uses items)) ;; (declare (uses runconfig)) ;; (declare (uses tests)) ;; (declare (uses server)) ;; (declare (uses runs)) ;; (declare (uses rmt)) ;; ;; (declare (uses filedb)) ;; ;; (include "common_records.scm") ;; (include "key_records.scm") (include "db_records.scm") ;; (include "run_records.scm") ;; (include "test_records.scm") ;; This is the Megatest API. All generally "useful" routines will be wrapped or extended ;; here. (define (mt:get-run-stats dbstruct run-id) ;; Get run stats from local access, move this ... but where? (db:get-run-stats dbstruct run-id)) (define (mt:discard-blocked-tests run-id failed-test tests test-records) (if (null? tests) tests (begin (debug:print-info 1 *default-log-port* "Discarding tests from " tests " that are waiting on " failed-test) (let loop ((testn (car tests)) (remt (cdr tests)) (res '())) (let* ((test-dat (hash-table-ref/default test-records testn (vector #f #f '()))) (waitons (vector-ref test-dat 2))) ;; (print "mt:discard-blocked-tests run-id: " run-id " failed-test: " failed-test " testn: " testn " with waitons: " waitons) (if (null? remt) (let ((new-res (reverse res))) ;; (print " new-res: " new-res) new-res) (loop (car remt) (cdr remt) (if (member failed-test waitons) (begin (debug:print 0 *default-log-port* "Discarding test " testn "(" test-dat ") due to " failed-test) res) (cons testn res))))))))) ) |
Modified rmtmod.scm from [10fee1373e] to [625e964a73].
︙ | ︙ | |||
1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 | ;; (mt:process-triggers run-id test-id new-state new-status) #t);) ;;(mt:test-set-state-status-by-id run-id test-id new-state new-status new-comment))) (define (mt:test-set-state-status-by-testname-unless-completed run-id test-name item-path new-state new-status new-comment) (let ((test-id (rmt:get-test-id run-id test-name item-path))) (mt:test-set-state-status-by-id-unless-completed run-id test-id new-state new-status new-comment))) ) | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 1539 1540 1541 1542 1543 1544 1545 1546 1547 1548 1549 1550 1551 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 1572 1573 1574 1575 1576 1577 1578 1579 1580 1581 1582 | ;; (mt:process-triggers run-id test-id new-state new-status) #t);) ;;(mt:test-set-state-status-by-id run-id test-id new-state new-status new-comment))) (define (mt:test-set-state-status-by-testname-unless-completed run-id test-name item-path new-state new-status new-comment) (let ((test-id (rmt:get-test-id run-id test-name item-path))) (mt:test-set-state-status-by-id-unless-completed run-id test-id new-state new-status new-comment))) ;;====================================================================== ;; R U N S ;;====================================================================== ;; runs:get-runs-by-patt ;; get runs by list of criteria ;; register a test run with the db ;; ;; Use: (db-get-value-by-header (db:get-header runinfo)(db:get-rows runinfo)) ;; to extract info from the structure returned ;; (define (mt:get-runs-by-patt keys runnamepatt targpatt) (let loop ((runsdat (rmt:get-runs-by-patt keys runnamepatt targpatt 0 500 #f 0)) (res '()) (offset 0) (limit 500)) ;; (print "runsdat: " runsdat) (let* ((header (vector-ref runsdat 0)) (runslst (vector-ref runsdat 1)) (full-list (append res runslst)) (have-more (eq? (length runslst) limit))) ;; (debug:print 0 *default-log-port* "header: " header " runslst: " runslst " have-more: " have-more) (if have-more (let ((new-offset (+ offset limit)) (next-batch (rmt:get-runs-by-patt keys runnamepatt targpatt offset limit #f 0))) (debug:print-info 4 *default-log-port* "More than " limit " runs, have " (length full-list) " runs so far.") (debug:print-info 0 *default-log-port* "next-batch: " next-batch) (loop next-batch full-list new-offset limit)) (vector header full-list))))) ;;====================================================================== ;; T E S T S ;;====================================================================== (define (mt:get-tests-for-run run-id testpatt states status #!key (not-in #t) (sort-by 'event_time) (sort-order "ASC") (qryvals #f)(last-update #f)) (let loop ((testsdat (rmt:get-tests-for-run run-id testpatt states status 0 500 not-in sort-by sort-order qryvals last-update 'normal)) (res '()) (offset 0) (limit 500)) (let* ((full-list (append res testsdat)) (have-more (eq? (length testsdat) limit))) (if have-more (let ((new-offset (+ offset limit))) (debug:print-info 4 *default-log-port* "More than " limit " tests, have " (length full-list) " tests so far.") (loop (rmt:get-tests-for-run run-id testpatt states status new-offset limit not-in sort-by sort-order qryvals last-update 'normal) full-list new-offset limit)) full-list)))) (define (mt:lazy-get-prereqs-not-met run-id waitons ref-item-path #!key (mode '(normal))(itemmaps #f) ) (let* ((key (list run-id waitons ref-item-path mode)) (res (hash-table-ref/default *pre-reqs-met-cache* key #f)) (useres (let ((last-time (if (vector? res) (vector-ref res 0) #f))) (if last-time (< (current-seconds)(+ last-time 5)) #f)))) (if useres (let ((result (vector-ref res 1))) (debug:print 4 *default-log-port* "Using lazy value res: " result) result) (let ((newres (rmt:get-prereqs-not-met run-id waitons ref-item-path mode: mode itemmaps: itemmaps))) (hash-table-set! *pre-reqs-met-cache* key (vector (current-seconds) newres)) newres)))) ) |
Modified runsmod.scm from [4971de8f4a] to [a2d1c728ab].
︙ | ︙ | |||
29 30 31 32 33 34 35 36 37 38 39 40 41 42 | (declare (uses mtmod)) (declare (uses processmod)) (declare (uses dbmod)) (declare (uses rmtmod)) (declare (uses testsmod)) (declare (uses tasksmod)) (declare (uses archivemod)) (module runsmod * (import scheme (prefix sqlite3 sqlite3:) chicken.base | > > | 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 | (declare (uses mtmod)) (declare (uses processmod)) (declare (uses dbmod)) (declare (uses rmtmod)) (declare (uses testsmod)) (declare (uses tasksmod)) (declare (uses archivemod)) (declare (uses launchmod)) (declare (uses subrunmod)) (module runsmod * (import scheme (prefix sqlite3 sqlite3:) chicken.base |
︙ | ︙ | |||
83 84 85 86 87 88 89 90 91 92 93 94 95 96 | mtver processmod dbmod rmtmod testsmod tasksmod archivemod ) (include "db_records.scm") ;; use this struct to facilitate refactoring ;; | > > | 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 | mtver processmod dbmod rmtmod testsmod tasksmod archivemod launchmod subrunmod ) (include "db_records.scm") ;; use this struct to facilitate refactoring ;; |
︙ | ︙ |
Modified subrun.scm from [e0be46add8] to [df6b4acf37].
︙ | ︙ | |||
12 13 14 15 16 17 18 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see <http://www.gnu.org/licenses/>. | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 12 13 14 15 16 17 18 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see <http://www.gnu.org/licenses/>. |
Added subrunmod.scm version [08d82931ae].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 | ;;====================================================================== ;; Copyright 2017, Matthew Welland. ;; ;; This file is part of Megatest. ;; ;; Megatest is free software: you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation, either version 3 of the License, or ;; (at your option) any later version. ;; ;; Megatest is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see <http://www.gnu.org/licenses/>. ;;====================================================================== (declare (unit subrunmod)) (declare (uses debugprint)) (declare (uses commonmod)) (declare (uses configfmod)) (declare (uses mtargs)) (declare (uses mtver)) (declare (uses csv-xml)) (declare (uses keysmod)) (declare (uses mtmod)) (declare (uses rmtmod)) (declare (uses testsmod)) (declare (uses dbmod)) (module subrunmod * (import scheme (prefix sqlite3 sqlite3:) chicken.base chicken.condition chicken.file chicken.file.posix chicken.format chicken.io chicken.pathname chicken.port chicken.pretty-print chicken.process chicken.process-context chicken.process-context.posix chicken.sort chicken.string chicken.time chicken.time.posix chicken.irregex (prefix base64 base64:) csv-xml csv-abnf directory-utils matchable regex s11n srfi-1 srfi-13 srfi-18 srfi-69 stack typed-records z3 (prefix mtargs args:) commonmod configfmod debugprint ;; keysmod mtmod mtver rmtmod testsmod dbmod ) ;; strftime('%m/%d/%Y %H:%M:%S','now','localtime') ;; (use (prefix sqlite3 sqlite3:) srfi-1 posix regex regex-case srfi-69 (srfi 18) ;; posix-extras directory-utils pathname-expand typed-records format ;; call-with-environment-variables) ;; (declare (unit subrun)) ;; ;;(declare (uses runs)) ;; (declare (uses db)) ;; (declare (uses common)) ;; ;;(declare (uses items)) ;; ;;(declare (uses runconfig)) ;; ;;(declare (uses tests)) ;; ;;(declare (uses server)) ;; (declare (uses mt)) ;; ;;(declare (uses archive)) ;; ;; (declare (uses filedb)) ;; ;; ;(include "common_records.scm") ;; ;;(include "key_records.scm") ;; (include "db_records.scm") ;; provides db:test-get-id ;; ;;(include "run_records.scm") ;; ;;(include "test_records.scm") (define (subrun:subrun-test-initialized? test-run-dir) (if (and (common:file-exists? (conc test-run-dir "/subrun-area") ) (common:file-exists? (conc test-run-dir "/testconfig.subrun") )) #t #f)) (define (subrun:launch-dashboard test-run-dir) (if (subrun:subrun-test-initialized? test-run-dir) (let* ((subarea (subrun:get-runarea test-run-dir))) (if (and subarea (common:file-exists? subarea)) (system (conc "cd " subarea ";env -i PATH=$PATH DISPLAY=$DISPLAY HOME=$HOME USER=$USER dashboard &")))))) (define (subrun:subrun-removed? test-run-dir) (if (subrun:subrun-test-initialized? test-run-dir) (let ((flagfile (conc test-run-dir "/subrun.removed"))) (if (common:file-exists? flagfile) #t #f)) #t)) (define (subrun:set-subrun-removed test-run-dir) (let ((flagfile (conc test-run-dir "/subrun.removed"))) (if (and (subrun:subrun-test-initialized? test-run-dir) (not (common:file-exists? flagfile))) (with-output-to-file flagfile (lambda () (print (current-seconds))))))) (define (subrun:unset-subrun-removed test-run-dir) (let ((flagfile (conc test-run-dir "/subrun.removed"))) (if (and (subrun:subrun-test-initialized? test-run-dir) (common:file-exists? flagfile)) (delete-file flagfile)))) (define (subrun:testconfig-defines-subrun? testconfig) (configf:lookup testconfig "subrun" "runwait")) ;; we use runwait as the flag that a subrun is requested (define (subrun:initialize-toprun-test testconfig test-run-dir) (let ((ra (configf:lookup testconfig "subrun" "run-area")) (logpro (configf:lookup testconfig "subrun" "logpro")) (symlink-target (conc test-run-dir "/subrun-area")) ) (if (not ra) ;; when runarea is not set we default to *toppath*. However (let ((fallback-run-area (or *toppath* (conc test-run-dir "/subrun")))) ;; we need to force the setting in the testconfig so it will ;; be preserved in the testconfig.subrun file (configf:set-section-var testconfig "subrun" "run-area" fallback-run-area) (set! ra fallback-run-area))) (configf:set-section-var testconfig "logpro" "subrun" logpro) ;; append the logpro rules to the logpro section as stepname subrun (if (common:file-exists? symlink-target) (delete-file symlink-target)) (create-symbolic-link ra symlink-target) (configf:write-alist testconfig "testconfig.subrun"))) (define (subrun:set-state-status test-run-dir state status new-state-status) (if (and (not (subrun:subrun-removed? test-run-dir)) (subrun:subrun-test-initialized? test-run-dir)) (let* ((action-switches-str (conc "-set-state-status "new-state-status (if state (conc " -state "state) "") (if status (conc " -status "status) ""))) (log-prefix (subrun:sanitize-path (conc "set-state-status="new-state-status (if state (conc ":state="state) "") (if status (conc "+status="status) "")))) (submt-result (subrun:exec-sub-megatest test-run-dir action-switches-str log-prefix))) submt-result))) (define (subrun:remove-subrun test-run-dir keep-records ) (if (and (not (subrun:subrun-removed? test-run-dir)) (subrun:subrun-test-initialized? test-run-dir)) (let* ((action-switches-str (conc "-remove-runs" (if keep-records "-keep-records " "") )) (remove-result (subrun:exec-sub-megatest test-run-dir action-switches-str "remove"))) (if remove-result (begin (subrun:set-subrun-removed test-run-dir) #t) #f)) #t)) (define (subrun:kill-subrun test-run-dir ) (if (and (not (subrun:subrun-removed? test-run-dir)) (subrun:subrun-test-initialized? test-run-dir)) (let* ((action-switches-str (conc "-kill-runs" )) (kill-result (subrun:exec-sub-megatest test-run-dir action-switches-str "kill"))) kill-result) #t)) (define (subrun:launch-cmd test-run-dir #!optional (sub-cmd "-run")) ;; BUG: "-run" should be changed to "-rerun-clean" but current doesn't work (if (subrun:subrun-removed? test-run-dir) (subrun:unset-subrun-removed test-run-dir)) (let* ((log-prefix "run") (switches (subrun:selector+log-switches test-run-dir log-prefix)) (run-wait #t) (cmd (conc "megatest " sub-cmd " " switches" " (if run-wait "-run-wait " "")))) cmd)) (define (subrun:sanitize-path inpath) (let* ((insane-pattern (irregex "[^[a-zA-Z0-9_\\-]"))) (regex#string-substitute insane-pattern "_" inpath #t))) (define (subrun:get-runarea test-run-dir) (if (subrun:subrun-test-initialized? test-run-dir) (let* ((info-alist (subrun:selector+log-alist test-run-dir "foo")) (run-area (if (list? info-alist) (alist-ref "-start-dir" info-alist equal? #f) #f))) run-area) #f)) (define (subrun:selector+log-alist test-run-dir log-prefix) (let* ((switch-def-alist (common:get-param-mapping flavor: 'config)) (subrunfile (conc test-run-dir "/testconfig.subrun" )) (subrundata (with-input-from-file subrunfile read)) (subrunconfig (configf:alist->config subrundata)) (run-area (configf:lookup subrunconfig "subrun" "run-area")) (defvals `(("start-dir" . ,(or run-area ;; default values if not specified in subrun section of tconf (get-environment-variable "MT_RUN_AREA_HOME") "/no/rundir/found")) ("run-name" . ,(or (get-environment-variable "MT_RUNNAME") "NO-RUNNAME")) ("target" . ,(or (get-environment-variable "MT_TARGET") "NO-TARGET")))) (switch-alist-pre (filter-map (lambda (item) (let* ((config-key (car item)) (switch (cdr item)) (defval (alist-ref config-key defvals equal? #f)) (val (or (configf:lookup subrunconfig "subrun" config-key) defval))) (if val (cons switch val) #f))) switch-def-alist)) ;; testpatt may be modified if all three of mode-patt, tag-expr, and testpatt are null (mode-patt (alist-ref "-modepatt" switch-alist-pre equal? #f)) (tag-expr (alist-ref "-tagexpr" switch-alist-pre equal? #f)) (testpatt (alist-ref "-testpatt" switch-alist-pre equal? (if (not (or mode-patt tag-expr)) "%" #f))) ;; testpatt is % if not ;; otherwise specified ;; define compact-stem for logfile (target (alist-ref "-target" switch-alist-pre equal? #f)) ;; want data-structures alist-ref, not alist-lib alist-ref (runname (alist-ref "-runname" switch-alist-pre equal? #f)) (compact-stem (subrun:sanitize-path (conc target "-" runname "-" (or testpatt mode-patt tag-expr "NO-TESTPATT")))) (logfile (conc test-run-dir "/" (if log-prefix (conc (subrun:sanitize-path log-prefix) "-") "") compact-stem ".log")) ;; swap out testpatt with modified test-patt and add -log (switch-alist (cons (cons "-log" logfile) (map (lambda (item) (if (equal? (car item) "-testpatt") (cons "-testpatt" testpatt) item)) switch-alist-pre)))) switch-alist)) ;; note - get precmd from subrun section ;; apply to submegatest commands (define (subrun:get-log-path test-run-dir log-prefix) (let* ((alist (subrun:selector+log-alist test-run-dir log-prefix)) (res (alist-ref "-log" alist equal? #f))) res)) (define (subrun:selector+log-switches test-run-dir log-prefix) (let* ((switch-alist (subrun:selector+log-alist test-run-dir log-prefix)) (res (string-intersperse (apply append (map (lambda (x) (list (car x) (cdr x))) switch-alist)) " "))) res)) (define (subrun:exec-sub-megatest test-run-dir action-switches-str log-prefix) (let* ((selector-switches (subrun:selector+log-switches test-run-dir log-prefix)) (cmd (conc "megatest " selector-switches " " action-switches-str )) (pid #f) (proc (lambda () (debug:print-info 0 *default-log-port* "Running sub megatest command: "cmd) ;;(set! pid (process-run "/usr/bin/xterm" (list )))))) (set! pid (process-run "/bin/bash" (list "-c" cmd)))))) (call-with-environment-variables (list (cons "PATH" (conc (get-environment-variable "PATH") ":."))) (lambda () (common:without-vars proc "^MT_.*"))) (let processloop ((i 0)) (let-values (((pid-val exit-status exit-code)(process-wait pid #t))) (if (eq? pid-val 0) (begin (thread-sleep! 2) (processloop (+ i 1))) (begin (debug:print-info 0 *default-log-port* "sub megatest " action-switches-str " completed with exit code " exit-code) (if (eq? 0 exit-code) (begin #t) (begin #f)))))))) ;; (subrun:exec-sub-megatest "/nfs/pdx/disks/icf_env_disk001/bjbarcla/gwa/issues/mtdev/165/megatest/ext-tests/tests/subrun-usecases/toparea/links/SYSTEM_val/RELEASE_val/go/toptest" "-foo" "foo") ) |