Changes In Branch servermode Through [da3de938e3] Excluding Merge-Ins
This is equivalent to a diff from 29dd546414 to da3de938e3
2012-03-13
| ||
06:59 | Merged servermode to trunk check-in: 3e2cee87de user: matt tags: trunk | |
2012-03-04
| ||
18:06 | rpc typo fix check-in: 3892474ef6 user: matt tags: servermode | |
16:47 | Multiple small fixes made, not ready for prime time .... check-in: da3de938e3 user: matt tags: servermode | |
2012-03-01
| ||
22:49 | Run server mode as part of -run* check-in: b06b51df8d user: matt tags: servermode | |
2012-02-29
| ||
17:56 | minor improvements to server mode check-in: 29dd546414 user: mrwellan tags: trunk | |
2012-02-27
| ||
09:52 | Partial fix for -rerun check-in: 0e00d7e0c2 user: matt tags: trunk | |
Modified common.scm from [5ebf23fbcd] to [4f03816054].
︙ | ︙ | |||
31 32 33 34 35 36 37 38 39 40 41 42 43 44 | ;; global gletches (define *configinfo* #f) (define *configdat* #f) (define *toppath* #f) (define *already-seen-runconfig-info* #f) (define *waiting-queue* (make-hash-table)) (define *globalexitstatus* 0) ;; attempt to work around possible thread issues (define *passnum* 0) ;; when running track calls to run-tests or similar (define *verbosity* 1) (define *rpc:listener* #f) ;; if set up for server communication this will hold the tcp port (define *runremote* #f) ;; if set up for server communication this will hold <host port> (define (get-with-default val default) | > | 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 | ;; global gletches (define *configinfo* #f) (define *configdat* #f) (define *toppath* #f) (define *already-seen-runconfig-info* #f) (define *waiting-queue* (make-hash-table)) (define *test-meta-updated* (make-hash-table)) (define *globalexitstatus* 0) ;; attempt to work around possible thread issues (define *passnum* 0) ;; when running track calls to run-tests or similar (define *verbosity* 1) (define *rpc:listener* #f) ;; if set up for server communication this will hold the tcp port (define *runremote* #f) ;; if set up for server communication this will hold <host port> (define (get-with-default val default) |
︙ | ︙ |
Modified dashboard.scm from [56cfd810b6] to [78b39d96f4].
︙ | ︙ | |||
76 77 78 79 80 81 82 | (begin (print "Failed to find megatest.config, exiting") (exit 1))) (define *db* (open-db)) ;; HACK ALERT: this is a hack, please fix. | | | 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 | (begin (print "Failed to find megatest.config, exiting") (exit 1))) (define *db* (open-db)) ;; HACK ALERT: this is a hack, please fix. (define *read-only* (not (file-read-access? (conc *toppath* "/megatest.db")))) ;; (server:client-setup *db*) (define toplevel #f) (define dlg #f) (define max-test-num 0) (define *keys* (rdb:get-keys *db*)) ;; (define *keys* (db:get-keys *db*)) |
︙ | ︙ |
Modified db.scm from [72acdb1ad4] to [681d2d74d7].
︙ | ︙ | |||
36 37 38 39 40 41 42 | (define *incoming-mutex* (make-mutex)) (define *cache-on* #f) (define (open-db) ;; (conc *toppath* "/megatest.db") (car *configinfo*))) (let* ((dbpath (conc *toppath* "/megatest.db")) ;; fname) (dbexists (file-exists? dbpath)) (db (sqlite3:open-database dbpath)) ;; (never-give-up-open-db dbpath)) | | | 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 | (define *incoming-mutex* (make-mutex)) (define *cache-on* #f) (define (open-db) ;; (conc *toppath* "/megatest.db") (car *configinfo*))) (let* ((dbpath (conc *toppath* "/megatest.db")) ;; fname) (dbexists (file-exists? dbpath)) (db (sqlite3:open-database dbpath)) ;; (never-give-up-open-db dbpath)) (handler (make-busy-timeout 3600))) ;; 136000))) (sqlite3:set-busy-handler! db handler) (if (not dbexists) (db:initialize db)) db)) (define (db:initialize db) (let* ((configdat (car *configinfo*)) ;; tut tut, global warning... |
︙ | ︙ | |||
211 212 213 214 215 216 217 | value REAL, expected REAL, tol REAL, units TEXT, comment TEXT DEFAULT '', status TEXT DEFAULT 'n/a', CONSTRAINT test_data UNIQUE (test_id,category,variable));") | | | 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 | value REAL, expected REAL, tol REAL, units TEXT, comment TEXT DEFAULT '', status TEXT DEFAULT 'n/a', CONSTRAINT test_data UNIQUE (test_id,category,variable));") (print "WARNING: Table test_data and test_meta were recreated. Please do megatest -update-meta") (patch-db)) ((< mver 1.27) (db:set-var db "MEGATEST_VERSION" 1.27) (sqlite3:execute db "ALTER TABLE test_data ADD COLUMN type TEXT DEFAULT '';") (patch-db)) ((< mver 1.29) (db:set-var db "MEGATEST_VERSION" 1.29) |
︙ | ︙ | |||
443 444 445 446 447 448 449 | (sqlite3:for-each-row (lambda (id) (set! ids (cons id ids))) db "SELECT id FROM tests WHERE run_id=? AND testname=? AND item_path=?;" run-id test-name (item-list->path itemdat)) (for-each (lambda (id) (sqlite3:execute db "DELETE FROM test_steps WHERE test_id=?;" id) | > > | | 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 | (sqlite3:for-each-row (lambda (id) (set! ids (cons id ids))) db "SELECT id FROM tests WHERE run_id=? AND testname=? AND item_path=?;" run-id test-name (item-list->path itemdat)) (for-each (lambda (id) (sqlite3:execute db "DELETE FROM test_steps WHERE test_id=?;" id) (thread-sleep! 0.1) ;; give others access to the db (sqlite3:execute db "DELETE FROM test_data WHERE test_id=?;" id) (thread-sleep! 0.1)) ;; give others access to the db ids))) ;;"DELETE FROM test_steps WHERE test_id in (SELECT id FROM tests WHERE run_id=? AND testname=? AND item_path=?);" ;; (define (db:delete-test-records db test-id) (sqlite3:execute db "DELETE FROM test_steps WHERE test_id=?;" test-id) (sqlite3:execute db "DELETE FROM test_data WHERE test_id=?;" test-id) |
︙ | ︙ | |||
548 549 550 551 552 553 554 | (define (db:test-set-rundir! db run-id test-name item-path rundir) (sqlite3:execute db "UPDATE tests SET rundir=? WHERE run_id=? AND testname=? AND item_path=?;" rundir run-id test-name item-path)) (define (db:test-set-log! db run-id test-name item-path logf) | > | | > | 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 | (define (db:test-set-rundir! db run-id test-name item-path rundir) (sqlite3:execute db "UPDATE tests SET rundir=? WHERE run_id=? AND testname=? AND item_path=?;" rundir run-id test-name item-path)) (define (db:test-set-log! db run-id test-name item-path logf) (if (string? logf) (sqlite3:execute db "UPDATE tests SET final_logf=? WHERE run_id=? AND testname=? AND item_path=?;" logf run-id test-name item-path) (debug:print 0 "ERROR: db:test-set-log! called with non-string log file name " logf))) ;;====================================================================== ;; Misc. test related queries ;;====================================================================== (define (db:test-get-paths-matching db keynames target) (let* ((res '()) |
︙ | ︙ | |||
804 805 806 807 808 809 810 | (set! res (cons (vector id test_id category variable value expected tol units comment status type) res))) db "SELECT id,test_id,category,variable,value,expected,tol,units,comment,status,type FROM test_data WHERE test_id=? AND category LIKE ? ORDER BY category,variable;" test-id categorypatt) (reverse res))) (define (db:load-test-data db run-id test-name itemdat) (let* ((item-path (item-list->path itemdat)) | | | | | 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 | (set! res (cons (vector id test_id category variable value expected tol units comment status type) res))) db "SELECT id,test_id,category,variable,value,expected,tol,units,comment,status,type FROM test_data WHERE test_id=? AND category LIKE ? ORDER BY category,variable;" test-id categorypatt) (reverse res))) (define (db:load-test-data db run-id test-name itemdat) (let* ((item-path (item-list->path itemdat)) (testdat (rdb:get-test-info db run-id test-name item-path)) (test-id (if testdat (db:test-get-id testdat) #f))) ;; (debug:print 1 "Enter records to insert in the test_data table, seven fields, comma separated per line") (debug:print 4 "itemdat: " itemdat ", test-name: " test-name ", test-id: " test-id) (if test-id (let loop ((lin (read-line))) (if (not (eof-object? lin)) (begin (debug:print 4 lin) (rdb:csv->test-data db test-id lin) (loop (read-line)))))) ;; roll up the current results. ;; FIXME: Add the status to (rdb:test-data-rollup db test-id #f))) ;; WARNING: Do NOT call this for the parent test on an iterated test ;; Roll up test_data pass/fail results ;; look at the test_data status field, ;; if all are pass (any case) and the test status is PASS or NULL or '' then set test status to PASS. ;; if one or more are fail (any case) then set test status to PASS, non "pass" or "fail" are ignored (define (db:test-data-rollup db test-id status) |
︙ | ︙ | |||
1187 1188 1189 1190 1191 1192 1193 | run-id test-name item-path comment)) (db:test-set-comment db run-id test-name item-path comment))) (define (rdb:test-set-log! db run-id test-name item-path logf) (if *runremote* (let ((host (vector-ref *runremote* 0)) (port (vector-ref *runremote* 1))) | | < | 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 | run-id test-name item-path comment)) (db:test-set-comment db run-id test-name item-path comment))) (define (rdb:test-set-log! db run-id test-name item-path logf) (if *runremote* (let ((host (vector-ref *runremote* 0)) (port (vector-ref *runremote* 1))) ((rpc:procedure 'rdb:test-set-log! host port) run-id test-name item-path logf)) (db:test-set-log! db run-id test-name item-path logf))) (define (rdb:get-runs db runnamepatt numruns startrunoffset keypatts) (if *runremote* (let ((host (vector-ref *runremote* 0)) (port (vector-ref *runremote* 1))) ((rpc:procedure 'rdb:get-runs host port) |
︙ | ︙ | |||
1309 1310 1311 1312 1313 1314 1315 | (define (rdb:delete-test-records db test-id) (if *runremote* (let ((host (vector-ref *runremote* 0)) (port (vector-ref *runremote* 1))) ((rpc:procedure 'rdb:delete-test-records host port) test-id)) (db:delete-test-records db test-id))) | > > > > > > > | 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 | (define (rdb:delete-test-records db test-id) (if *runremote* (let ((host (vector-ref *runremote* 0)) (port (vector-ref *runremote* 1))) ((rpc:procedure 'rdb:delete-test-records host port) test-id)) (db:delete-test-records db test-id))) (define (rdb:test-data-rollup db test-id status) (if *runremote* (let ((host (vector-ref *runremote* 0)) (port (vector-ref *runremote* 1))) ((rpc:procedure 'rdb:test-data-rollup host port) test-id status)) (db:test-data-rollup db test-id status))) |
Modified launch.scm from [e033088d6b] to [55dfea2e6a].
︙ | ︙ | |||
42 43 44 45 46 47 48 | (define (steprun-good? logpro exitcode) (or (eq? exitcode 0) (and logpro (eq? exitcode 2)))) (define (launch:execute encoded-cmd) (let* ((cmdinfo (read (open-input-string (base64:base64-decode encoded-cmd))))) (setenv "MT_CMDINFO" encoded-cmd) | | > | 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 | (define (steprun-good? logpro exitcode) (or (eq? exitcode 0) (and logpro (eq? exitcode 2)))) (define (launch:execute encoded-cmd) (let* ((cmdinfo (read (open-input-string (base64:base64-decode encoded-cmd))))) (setenv "MT_CMDINFO" encoded-cmd) (if (list? cmdinfo) ;; ((testpath /tmp/mrwellan/jazzmind/src/example_run/tests/sqlitespeed) ;; (test-name sqlitespeed) (runscript runscript.rb) (db-host localhost) (run-id 1)) (let* ((testpath (assoc/default 'testpath cmdinfo)) (work-area (assoc/default 'work-area cmdinfo)) (test-name (assoc/default 'test-name cmdinfo)) (runscript (assoc/default 'runscript cmdinfo)) (ezsteps (assoc/default 'ezsteps cmdinfo)) (db-host (assoc/default 'db-host cmdinfo)) (run-id (assoc/default 'run-id cmdinfo)) |
︙ | ︙ | |||
296 297 298 299 300 301 302 | (thread-start! th2) (thread-join! th2) (mutex-lock! m) (set! db (open-db)) (if (not (args:get-arg "-server")) (server:client-setup db)) (let* ((item-path (item-list->path itemdat)) | | | 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 | (thread-start! th2) (thread-join! th2) (mutex-lock! m) (set! db (open-db)) (if (not (args:get-arg "-server")) (server:client-setup db)) (let* ((item-path (item-list->path itemdat)) (testinfo (rdb:get-test-info db run-id test-name item-path))) (if (not (equal? (db:test-get-state testinfo) "COMPLETED")) (begin (debug:print 2 "Test NOT logged as COMPLETED, (state=" (db:test-get-state testinfo) "), updating result, rollup-status is " rollup-status) (test-set-status! db run-id test-name (if kill-job? "KILLED" "COMPLETED") ;; Old logic: ;; (if (vector-ref exit-info 1) ;; look at the exit-status, #t means it at least ran |
︙ | ︙ | |||
437 438 439 440 441 442 443 | (runscript (config-lookup test-conf "setup" "runscript")) (ezsteps (> (length (hash-table-ref/default test-conf "ezsteps" '())) 0)) ;; don't send all the steps, could be big (diskspace (config-lookup test-conf "requirements" "diskspace")) (memory (config-lookup test-conf "requirements" "memory")) (hosts (config-lookup *configdat* "jobtools" "workhosts")) (remote-megatest (config-lookup *configdat* "setup" "executable")) ;; FIXME SOMEDAY: not good how this is so obtuse, this hack is to | | > > | > | 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 | (runscript (config-lookup test-conf "setup" "runscript")) (ezsteps (> (length (hash-table-ref/default test-conf "ezsteps" '())) 0)) ;; don't send all the steps, could be big (diskspace (config-lookup test-conf "requirements" "diskspace")) (memory (config-lookup test-conf "requirements" "memory")) (hosts (config-lookup *configdat* "jobtools" "workhosts")) (remote-megatest (config-lookup *configdat* "setup" "executable")) ;; FIXME SOMEDAY: not good how this is so obtuse, this hack is to ;; allow running from dashboard. Extract the path ;; from the called megatest and convert dashboard ;; or dboard to megatest (local-megatest (let* ((lm (car (argv))) (dir (pathname-directory lm)) (exe (pathname-strip-directory lm))) (conc (if dir (conc dir "/") "") (case (string->symbol exe) ((dboard) "megatest") ((dashboard) "megatest") (else exe))))) (test-sig (conc test-name ":" (item-list->path itemdat))) ;; test-path is the full path including the item-path (work-area #f) (toptest-work-area #f) ;; for iterated tests the top test contains data relevant for all (diskpath #f) (cmdparms #f) (fullcmd #f) ;; (define a (with-output-to-string (lambda ()(write x)))) (mt-bindir-path #f)) (if hosts (set! hosts (string-split hosts))) ;; set the megatest to be called on the remote host (if (not remote-megatest)(set! remote-megatest local-megatest)) ;; "megatest")) (set! mt-bindir-path (pathname-directory remote-megatest)) (if launcher (set! launcher (string-split launcher))) ;; set up the run work area for this test (set! diskpath (get-best-disk *configdat*)) (if diskpath (let ((dat (create-work-area db run-id test-path diskpath test-name itemdat))) |
︙ | ︙ | |||
495 496 497 498 499 500 501 | (set! fullcmd (append launcher (list remote-megatest test-sig "-execute" cmdparms)))) (else (if (not useshell)(debug:print 0 "WARNING: internal launching will not work well without \"useshell yes\" in your [jobtools] section")) (set! fullcmd (list remote-megatest test-sig "-execute" cmdparms (if useshell "&" ""))))) (if (args:get-arg "-xterm")(set! fullcmd (append fullcmd (list "-xterm")))) (debug:print 1 "Launching megatest for test " test-name " in " work-area" ...") (test-set-status! db run-id test-name "LAUNCHED" "n/a" itemdat #f #f) ;; (if launch-results launch-results "FAILED")) | < | | 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 | (set! fullcmd (append launcher (list remote-megatest test-sig "-execute" cmdparms)))) (else (if (not useshell)(debug:print 0 "WARNING: internal launching will not work well without \"useshell yes\" in your [jobtools] section")) (set! fullcmd (list remote-megatest test-sig "-execute" cmdparms (if useshell "&" ""))))) (if (args:get-arg "-xterm")(set! fullcmd (append fullcmd (list "-xterm")))) (debug:print 1 "Launching megatest for test " test-name " in " work-area" ...") (test-set-status! db run-id test-name "LAUNCHED" "n/a" itemdat #f #f) ;; (if launch-results launch-results "FAILED")) ;; set pre-launch-env-vars before launching, keep the vars in prevvals and put the envionment back when done (debug:print 4 "fullcmd: " fullcmd) (let* ((commonprevvals (alist->env-vars (hash-table-ref/default *configdat* "env-override" '()))) (testprevvals (alist->env-vars (hash-table-ref/default test-conf "pre-launch-env-overrides" '()))) (miscprevvals (alist->env-vars ;; consolidate this code with the code in megatest.scm for "-execute" (append (list (list "MT_TEST_NAME" test-name) (list "MT_ITEM_INFO" (conc itemdat)) (list "MT_RUNNAME" runname)) itemdat))) (launch-results (apply cmd-run-proc-each-line (if useshell (string-intersperse fullcmd " ") (car fullcmd)) print (if useshell '() (cdr fullcmd))))) ;; launcher fullcmd)));; (apply cmd-run-proc-each-line launcher print fullcmd))) ;; (cmd-run->list fullcmd)) (debug:print 2 "Launching completed, updating db") (debug:print 2 "Launch results: " launch-results) (if (not launch-results) (begin (print "ERROR: Failed to run " (string-intersperse fullcmd " ") ", exiting now") (sqlite3:finalize! db) ;; good ole "exit" seems not to work ;; (_exit 9) ;; but this hack will work! Thanks go to Alan Post of the Chicken email list |
︙ | ︙ |
Modified megatest.scm from [91d562ec2a] to [2aae15056c].
1 2 3 4 5 6 7 8 9 10 11 12 | ;; Copyright 2006-2011, Matthew Welland. ;; ;; This program is made available under the GNU GPL version 2.0 or ;; greater. See the accompanying file COPYING for details. ;; ;; This program is distributed WITHOUT ANY WARRANTY; without even the ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ;; PURPOSE. ;; (include "common.scm") ;; (include "megatest-version.scm") | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 | ;; Copyright 2006-2011, Matthew Welland. ;; ;; This program is made available under the GNU GPL version 2.0 or ;; greater. See the accompanying file COPYING for details. ;; ;; This program is distributed WITHOUT ANY WARRANTY; without even the ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ;; PURPOSE. ;; (include "common.scm") ;; (include "megatest-version.scm") (use sqlite3 srfi-1 posix regex regex-case srfi-69 base64 format readline apropos) ;; (srfi 18) extras) (import (prefix sqlite3 sqlite3:)) (import (prefix base64 base64:)) (declare (uses common)) (declare (uses megatest-version)) (declare (uses margs)) (declare (uses runs)) |
︙ | ︙ | |||
335 336 337 338 339 340 341 342 | ;; Start the server - can be done in conjunction with -runall or -runtests (one day...) ;;====================================================================== (if (and (args:get-arg "-server") (not (or (args:get-arg "-runall") (args:get-arg "-runtests")))) (let* ((toppath (setup-for-run)) (db (if toppath (open-db) #f))) (if db | > | > | 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 | ;; Start the server - can be done in conjunction with -runall or -runtests (one day...) ;;====================================================================== (if (and (args:get-arg "-server") (not (or (args:get-arg "-runall") (args:get-arg "-runtests")))) (let* ((toppath (setup-for-run)) (db (if toppath (open-db) #f))) (debug:print 0 "INFO: Starting the standalone server") (if db (let ((th2 (server:start db (args:get-arg "-server")))) (thread-join! th2)) (debug:print 0 "ERROR: Failed to setup for megatest")))) ;;====================================================================== ;; full run ;;====================================================================== ;; get lock in db for full run for this directory |
︙ | ︙ | |||
453 454 455 456 457 458 459 | (exit 1))) (set! db (open-db)) (if (not (args:get-arg "-server")) (server:client-setup db)) (let* ((itempatt (args:get-arg "-itempatt")) (keys (rdb:get-keys db)) (keynames (map key:get-fieldname keys)) | | | | 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 | (exit 1))) (set! db (open-db)) (if (not (args:get-arg "-server")) (server:client-setup db)) (let* ((itempatt (args:get-arg "-itempatt")) (keys (rdb:get-keys db)) (keynames (map key:get-fieldname keys)) (paths (rdb:test-get-paths-matching db keynames target))) (set! *didsomething* #t) (for-each (lambda (path) (print path)) paths))) ;; else do a general-run-call (general-run-call "-test-paths" "Get paths to tests" (lambda (db target runname keys keynames keyvallst) (let* ((itempatt (args:get-arg "-itempatt")) (paths (rdb:test-get-paths-matching db keynames target))) (for-each (lambda (path) (print path)) paths)))))) ;;====================================================================== ;; Archive tests ;;====================================================================== |
︙ | ︙ | |||
612 613 614 615 616 617 618 619 620 | (begin (debug:print 0 "Failed to setup, exiting") (exit 1))) (set! db (open-db)) (if (not (args:get-arg "-server")) (server:client-setup db)) (if (args:get-arg "-load-test-data") (db:load-test-data db run-id test-name itemdat)) (if (args:get-arg "-setlog") | > | | | | 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 | (begin (debug:print 0 "Failed to setup, exiting") (exit 1))) (set! db (open-db)) (if (not (args:get-arg "-server")) (server:client-setup db)) (if (args:get-arg "-load-test-data") ;; has sub commands that are rdb: (db:load-test-data db run-id test-name itemdat)) (if (args:get-arg "-setlog") (rdb:test-set-log! db run-id test-name itemdat (args:get-arg "-setlog"))) (if (args:get-arg "-set-toplog") (rdb:test-set-toplog! db run-id test-name (args:get-arg "-set-toplog"))) (if (args:get-arg "-summarize-items") (rdb:tests:summarize-items db run-id test-name #t)) ;; do force here (if (args:get-arg "-runstep") (if (null? remargs) (begin (debug:print 0 "ERROR: nothing specified to run!") (sqlite3:finalize! db) (exit 6)) (let* ((stepname (args:get-arg "-runstep")) |
︙ | ︙ | |||
662 663 664 665 666 667 668 | (oldexitstat exitstat) (cmd (string-intersperse (list "logpro" logprofile htmllogfile "<" logfile ">" (conc stepname "_logpro.log")) " "))) (debug:print 2 "INFO: running \"" cmd "\"") (change-directory startingdir) (set! exitstat (system cmd)) (set! *globalexitstatus* exitstat) ;; no necessary (change-directory testpath) | | | 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 | (oldexitstat exitstat) (cmd (string-intersperse (list "logpro" logprofile htmllogfile "<" logfile ">" (conc stepname "_logpro.log")) " "))) (debug:print 2 "INFO: running \"" cmd "\"") (change-directory startingdir) (set! exitstat (system cmd)) (set! *globalexitstatus* exitstat) ;; no necessary (change-directory testpath) (rdb:test-set-log! db run-id test-name itemdat htmllogfile))) (rdb:teststep-set-status! db run-id test-name stepname "end" exitstat itemdat (args:get-arg "-m") logfile) (sqlite3:finalize! db) (if (not (eq? exitstat 0)) (exit 254)) ;; (exit exitstat) doesn't work?!? ;; open the db ;; mark the end of the test ))) |
︙ | ︙ | |||
692 693 694 695 696 697 698 | (if (and (args:get-arg "-test-status") (or (not state) (not status))) (begin (debug:print 0 "ERROR: You must specify :state and :status with every call to -test-status\n" help) (sqlite3:finalize! db) (exit 6))) | | | 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 | (if (and (args:get-arg "-test-status") (or (not state) (not status))) (begin (debug:print 0 "ERROR: You must specify :state and :status with every call to -test-status\n" help) (sqlite3:finalize! db) (exit 6))) (rtests:test-set-status! db run-id test-name state newstatus itemdat (args:get-arg "-m") otherdata))) (sqlite3:finalize! db) (set! *didsomething* #t)))) (if (args:get-arg "-showkeys") (let ((db #f) (keys #f)) (if (not (setup-for-run)) |
︙ | ︙ |
Modified runs.scm from [25e1315b1d] to [7a34943964].
1 2 3 4 5 6 7 8 9 10 11 12 | ;; Copyright 2006-2011, Matthew Welland. ;; ;; This program is made available under the GNU GPL version 2.0 or ;; greater. See the accompanying file COPYING for details. ;; ;; This program is distributed WITHOUT ANY WARRANTY; without even the ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ;; PURPOSE. ;; strftime('%m/%d/%Y %H:%M:%S','now','localtime') | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 | ;; Copyright 2006-2011, Matthew Welland. ;; ;; This program is made available under the GNU GPL version 2.0 or ;; greater. See the accompanying file COPYING for details. ;; ;; This program is distributed WITHOUT ANY WARRANTY; without even the ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ;; PURPOSE. ;; strftime('%m/%d/%Y %H:%M:%S','now','localtime') (use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking (srfi 18)) (import (prefix sqlite3 sqlite3:)) (declare (unit runs)) (declare (uses db)) (declare (uses common)) (declare (uses items)) (declare (uses runconfig)) |
︙ | ︙ | |||
390 391 392 393 394 395 396 | (debug:print 2 "Attempting to launch test " test-name "/" item-path) (setenv "MT_TEST_NAME" test-name) ;; (setenv "MT_RUNNAME" runname) (set-megatest-env-vars db run-id) ;; these may be needed by the launching process (change-directory *toppath*) ;; Here is where the test_meta table is best updated | > > > > | | 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 | (debug:print 2 "Attempting to launch test " test-name "/" item-path) (setenv "MT_TEST_NAME" test-name) ;; (setenv "MT_RUNNAME" runname) (set-megatest-env-vars db run-id) ;; these may be needed by the launching process (change-directory *toppath*) ;; Here is where the test_meta table is best updated ;; Yes, another use of a global for caching. Need a better way? (if (not (hash-table-ref/default *test-meta-updated* test-name #f)) (begin (hash-table-set! *test-meta-updated* test-name #t) (runs:update-test_meta db test-name test-conf))) ;; (lambda (itemdat) ;;; ((ripeness "overripe") (temperature "cool") (season "summer")) (let* ((new-test-path (string-intersperse (cons test-path (map cadr itemdat)) "/")) (new-test-name (if (equal? item-path "") test-name (conc test-name "/" item-path))) ;; just need it to be unique (testdat (db:get-test-info db run-id test-name item-path))) (if (not testdat) (begin |
︙ | ︙ | |||
447 448 449 450 451 452 453 | (member (test:get-status testdat) '("FAIL" "n/a"))) (set! runflag #t)) (else (set! runflag #f))) (debug:print 6 "RUNNING => runflag: " runflag " STATE: " (test:get-state testdat) " STATUS: " (test:get-status testdat)) (if (not runflag) (if (not parent-test) (debug:print 1 "NOTE: Not starting test " new-test-name " as it is state \"" (test:get-state testdat) | | > | 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 | (member (test:get-status testdat) '("FAIL" "n/a"))) (set! runflag #t)) (else (set! runflag #f))) (debug:print 6 "RUNNING => runflag: " runflag " STATE: " (test:get-state testdat) " STATUS: " (test:get-status testdat)) (if (not runflag) (if (not parent-test) (debug:print 1 "NOTE: Not starting test " new-test-name " as it is state \"" (test:get-state testdat) "\" and status \"" (test:get-status testdat) "\", use -rerun \"" (test:get-status testdat) "\" or -force to override")) ;; NOTE: No longer be checking prerequisites here! Will never get here unless prereqs are ;; already met. (if (not (launch-test db run-id runname test-conf keyvallst test-name test-path itemdat flags)) (begin (print "ERROR: Failed to launch the test. Exiting as soon as possible") (set! *globalexitstatus* 1) ;; (process-signal (current-process-id) signal/kill)))))) |
︙ | ︙ | |||
569 570 571 572 573 574 575 | ;; Since many calls to a run require pretty much the same setup ;; this wrapper is used to reduce the replication of code (define (general-run-call switchname action-desc proc) (let ((runname (args:get-arg ":runname")) (target (if (args:get-arg "-target") (args:get-arg "-target") | | > | > > > | | 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 | ;; Since many calls to a run require pretty much the same setup ;; this wrapper is used to reduce the replication of code (define (general-run-call switchname action-desc proc) (let ((runname (args:get-arg ":runname")) (target (if (args:get-arg "-target") (args:get-arg "-target") (args:get-arg "-reqtarg"))) (th1 #f)) (cond ((not target) (debug:print 0 "ERROR: Missing required parameter for " switchname ", you must specify the target with -target") (exit 3)) ((not runname) (debug:print 0 "ERROR: Missing required parameter for " switchname ", you must specify the run name with :runname runname") (exit 3)) (else (let ((db #f) (keys #f)) (if (not (setup-for-run)) (begin (debug:print 0 "Failed to setup, exiting") (exit 1))) (set! db (open-db)) (if (args:get-arg "-server") (server:start db (args:get-arg "-server")) (if (not (or (args:get-arg "-runall") (args:get-arg "-runtests"))) (set! th1 (server:client-setup db)))) (set! keys (rdb:get-keys db)) ;; have enough to process -target or -reqtarg here (if (args:get-arg "-reqtarg") (let* ((runconfigf (conc *toppath* "/runconfigs.config")) ;; DO NOT EVALUATE ALL (runconfig (read-config runconfigf #f #f environ-patt: #f))) (if (hash-table-ref/default runconfig (args:get-arg "-reqtarg") #f) (keys:target-set-args keys (args:get-arg "-reqtarg") args:arg-hash) |
︙ | ︙ | |||
609 610 611 612 613 614 615 616 617 618 619 620 621 622 | (debug:print 0 "ERROR: Attempted to " action-desc " but run area config file not found") (exit 1)) ;; Extract out stuff needed in most or many calls ;; here then call proc (let* ((keynames (map key:get-fieldname keys)) (keyvallst (keys->vallist keys #t))) (proc db target runname keys keynames keyvallst))) (sqlite3:finalize! db) (set! *didsomething* #t)))))) ;;====================================================================== ;; Rollup runs ;;====================================================================== | > | 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 | (debug:print 0 "ERROR: Attempted to " action-desc " but run area config file not found") (exit 1)) ;; Extract out stuff needed in most or many calls ;; here then call proc (let* ((keynames (map key:get-fieldname keys)) (keyvallst (keys->vallist keys #t))) (proc db target runname keys keynames keyvallst))) (if th1 (thread-join! th1)) (sqlite3:finalize! db) (set! *didsomething* #t)))))) ;;====================================================================== ;; Rollup runs ;;====================================================================== |
︙ | ︙ |
Modified server.scm from [5c480362d7] to [626dc3a431].
︙ | ︙ | |||
80 81 82 83 84 85 86 | 'rdb:test-set-state-status-by-run-id-testname (lambda (run-id test-name item-path status state) (db:test-set-state-status-by-run-id-testname db run-id test-name item-path status state))) (rpc:publish-procedure! 'rdb:csv->test-data (lambda (test-id csvdata) | | | 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 | 'rdb:test-set-state-status-by-run-id-testname (lambda (run-id test-name item-path status state) (db:test-set-state-status-by-run-id-testname db run-id test-name item-path status state))) (rpc:publish-procedure! 'rdb:csv->test-data (lambda (test-id csvdata) (db:csv->test-data db test-id csvdata))) (rpc:publish-procedure! 'rdb:roll-up-pass-fail-counts (lambda (run-id test-name item-path status) (db:roll-up-pass-fail-counts db run-id test-name item-path status))) (rpc:publish-procedure! |
︙ | ︙ | |||
196 197 198 199 200 201 202 203 204 205 206 207 208 | (db:delete-test-records db test-id))) (rpc:publish-procedure! 'rtests:register-test (lambda (run-id test-name item-path) (tests:register-test db run-id test-name item-path))) (set! *rpc:listener* rpc:listener) (on-exit (lambda () (sqlite3:execute db "DELETE FROM metadat WHERE var='SERVER' and val=?;" host:port) (sqlite3:finalize! db))) (thread-start! th1) (thread-start! th2) | > > > > > > > > > > > > > > > > > | | 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 | (db:delete-test-records db test-id))) (rpc:publish-procedure! 'rtests:register-test (lambda (run-id test-name item-path) (tests:register-test db run-id test-name item-path))) (rpc:publish-procedure! 'rdb:test-data-rollup (lambda (test-id status) (db:test-data-rollup db test-id status))) (rpc:publish-procedure! 'rtests:test-set-status! (lambda (run-id test-name state status itemdat-or-path comment dat) (test-set-status! db run-id test-name state status itemdat-or-path comment dat))) ;;====================================================================== ;; end of publish-procedure section ;;====================================================================== (set! *rpc:listener* rpc:listener) (on-exit (lambda () (sqlite3:execute db "DELETE FROM metadat WHERE var='SERVER' and val=?;" host:port) (sqlite3:finalize! db))) (thread-start! th1) (thread-start! th2) ;; (thread-join! th2) ;; return th2 for the calling process to do a join with th2 )) ;; rpc:server))) (define (server:find-free-port-and-open port) (handle-exceptions exn (begin (print "Failed to bind to port " (rpc:default-server-port) ", trying next port") (server:find-free-port-and-open (+ port 1))) |
︙ | ︙ |
Modified tests.scm from [536da07661] to [bd1dcbf11c].
︙ | ︙ | |||
385 386 387 388 389 390 391 | (define (rtests:register-test db run-id test-name item-path) (if *runremote* (let ((host (vector-ref *runremote* 0)) (port (vector-ref *runremote* 1))) ((rpc:procedure 'rtests:register-test host port) run-id test-name item-path)) (tests:register-test db run-id test-name item-path))) | > > > > > > > | 385 386 387 388 389 390 391 392 393 394 395 396 397 398 | (define (rtests:register-test db run-id test-name item-path) (if *runremote* (let ((host (vector-ref *runremote* 0)) (port (vector-ref *runremote* 1))) ((rpc:procedure 'rtests:register-test host port) run-id test-name item-path)) (tests:register-test db run-id test-name item-path))) (define (rtests:test-set-status! db run-id test-name state status itemdat-or-path comment dat) (if *runremote* (let ((host (vector-ref *runremote* 0)) (port (vector-ref *runremote* 1))) ((rpc:procedure 'rtests:test-set-status! host port) run-id test-name state status itemdat-or-path comment dat)) (test-set-status! db run-id test-name state status itemdat-or-path comment dat))) |
Modified tests/Makefile from [393100f5ee] to [b314894f18].
1 2 3 4 5 6 7 8 9 10 | # run some tests BINPATH=$(shell realpath ../bin) MEGATEST=$(BINPATH)/megatest PATH := $(BINPATH):$(PATH) runall : cd ../;make install mkdir -p /tmp/mt_runs /tmp/mt_links $(BINPATH)/dboard -rows 15 & | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 | # run some tests BINPATH=$(shell realpath ../bin) MEGATEST=$(BINPATH)/megatest PATH := $(BINPATH):$(PATH) runall : cd ../;make install mkdir -p /tmp/mt_runs /tmp/mt_links $(BINPATH)/dboard -rows 15 & $(MEGATEST) -runall -target ubuntu/nfs/none :runname `date +w%V.%u.%H` -m "This is a comment specific to a run" -v -server - test : csi -b -I .. ../megatest.scm -- -runall -target ubuntu/afs/tmp :runname blah cd ../;make test make runall dashboard : |
︙ | ︙ |
Modified tests/megatest.config from [729204831f] to [75d2bf7273].
1 2 3 4 5 6 7 8 9 10 11 | [fields] sysname TEXT fsname TEXT datapath TEXT [setup] # exectutable /path/to/megatest max_concurrent_jobs 200 linktree /tmp/mt_links [jobtools] | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | [fields] sysname TEXT fsname TEXT datapath TEXT [setup] # exectutable /path/to/megatest max_concurrent_jobs 200 linktree /tmp/mt_links [jobtools] useshell yes # ## launcher launches jobs, the job is managed on the target host ## by megatest, comment out launcher to run local # workhosts localhost hermes launcher nbfake # launcher nodanggood ## use "xterm -e csi -- " as a launcher to examine the launch environment. |
︙ | ︙ |
Modified utils/mt_ezstep from [e004bfd05c] to [dc6e288c61].
︙ | ︙ | |||
25 26 27 28 29 30 31 | source $prev_env fi # source the environment from the previous step if it exists # if a logpro file exists then use it otherwise just run the command, nb// was using 2>&1 if [ -e ${stepname}.logpro ];then | > > > | > | | 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 | source $prev_env fi # source the environment from the previous step if it exists # if a logpro file exists then use it otherwise just run the command, nb// was using 2>&1 if [ -e ${stepname}.logpro ];then # could do: $command 2>&1| tee ${stepname}.log | logpro ${stepname}.logpro ${stepname}.html &> /dev/null logprostatus=$? # $command 2>&1| logpro ${stepname}.logpro ${stepname}.html &> ${stepname}.log # allstatus=(${PIPESTATUS[0]} ${PIPESTATUS[1]}) allstatus=(${PIPESTATUS[0]} ${PIPESTATUS[1]}) runstatus=${allstatus[0]} # logprostatus=${allstatus[1]} else $command &> ${stepname}.log runstatus=$? logprostatus=$runstatus fi # If the test exits with non-zero, we will record FAIL even if logpro |
︙ | ︙ |