Changes In Branch runcontrol Through [6e5ba415c5] Excluding Merge-Ins
This is equivalent to a diff from ede9e7e628 to 6e5ba415c5
2013-04-29
| ||
16:53 | merged from v1.54 and development and added loop for processing 100 at a time check-in: b6a0d64bc4 user: mrwellan tags: runcontrol | |
13:41 | Merged development into runcontrol check-in: 6e5ba415c5 user: mrwellan tags: runcontrol | |
2013-04-28
| ||
23:19 | Redirected stdout to mt_launch.log in test rsync calls for fdktestqa test check-in: 2829751795 user: matt tags: dev | |
10:20 | Added server expire timeout to fdktestqa check-in: 3bdad1e79d user: matt tags: dev | |
2013-04-26
| ||
15:03 | Pulled the sites info into an external call in the fslsync example Closed-Leaf check-in: ede9e7e628 user: mrwellan tags: development | |
00:32 | Merged v1.54 back to development check-in: 6b1d02ec51 user: matt tags: development | |
2013-04-23
| ||
22:12 | Merging dev into runcontrol check-in: 7d7f76d4b1 user: matt tags: runcontrol | |
Modified common.scm from [3109b21887] to [7f9cf64fe3].
︙ | ︙ | |||
140 141 142 143 144 145 146 147 148 149 150 151 152 153 | #f #t))) string<?)) ;; '(print (string-intersperse (map cadr (hash-table-ref/default (read-config "megatest.config" \#f \#t) "disks" '"'"'("none" ""))) "\n"))' (define (common:get-disks) (hash-table-ref/default (read-config "megatest.config" #f #t) "disks" '("none" ""))) ;;====================================================================== ;; System stuff ;;====================================================================== ;; return a nice clean pathname made absolute (define (nice-path dir) | > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | #f #t))) string<?)) ;; '(print (string-intersperse (map cadr (hash-table-ref/default (read-config "megatest.config" \#f \#t) "disks" '"'"'("none" ""))) "\n"))' (define (common:get-disks) (hash-table-ref/default (read-config "megatest.config" #f #t) "disks" '("none" ""))) ;;====================================================================== ;; M I S C L I S T S ;;====================================================================== ;; items in lista are matched value and position in listb ;; return the remaining items in listb or #f ;; (define (common:list-is-sublist lista listb) (if (null? lista) listb ;; all items in listb are "remaining" (if (> (length lista)(length listb)) #f (let loop ((heda (car lista)) (tala (cdr lista)) (hedb (car listb)) (talb (cdr listb))) (if (equal? heda hedb) (if (null? tala) ;; we are done talb (loop (car tala) (cdr tala) (car talb) (cdr talb))) #f))))) ;;====================================================================== ;; System stuff ;;====================================================================== ;; return a nice clean pathname made absolute (define (nice-path dir) |
︙ | ︙ |
Modified dashboard-tests.scm from [b247a10977] to [3e5475f076].
︙ | ︙ | |||
473 474 475 476 477 478 479 | (db:test-data-get-units x) (db:test-data-get-type x) (db:test-data-get-comment x))) (open-run-close db:read-test-data #f test-id "%"))) "\n"))) (if (not (equal? currval newval)) (iup:attribute-set! test-data "VALUE" newval ))))) ;; "TITLE" newval))))) | | > > | 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 | (db:test-data-get-units x) (db:test-data-get-type x) (db:test-data-get-comment x))) (open-run-close db:read-test-data #f test-id "%"))) "\n"))) (if (not (equal? currval newval)) (iup:attribute-set! test-data "VALUE" newval ))))) ;; "TITLE" newval))))) test-data)) ;;(dashboard:run-controls) ))) (iup:attribute-set! tabs "TABTITLE0" "Steps") (iup:attribute-set! tabs "TABTITLE1" "Test Data") tabs)))) (iup:show self) (iup:callback-set! *tim* "ACTION_CB" (lambda (x) ;; Now start keeping the gui updated from the db |
︙ | ︙ |
Modified dashboard.scm from [f8c5b58774] to [7d3ee2c235].
︙ | ︙ | |||
10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 | ;;====================================================================== (use format) (require-library iup) (import (prefix iup iup:)) (use canvas-draw) (use sqlite3 srfi-1 posix regex regex-case srfi-69) (import (prefix sqlite3 sqlite3:)) (declare (uses common)) (declare (uses margs)) (declare (uses keys)) (declare (uses items)) (declare (uses db)) (declare (uses configf)) | > > | 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 | ;;====================================================================== (use format) (require-library iup) (import (prefix iup iup:)) (use canvas-draw) (import canvas-draw-iup) (use sqlite3 srfi-1 posix regex regex-case srfi-69) (import (prefix sqlite3 sqlite3:)) (use trace) (declare (uses common)) (declare (uses margs)) (declare (uses keys)) (declare (uses items)) (declare (uses db)) (declare (uses configf)) |
︙ | ︙ | |||
420 421 422 423 424 425 426 | (define (update-search x val) ;; (print "Setting search for " x " to " val) (hash-table-set! *searchpatts* x val)) (define (mark-for-update) (set! *last-db-update-time* 0) | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 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 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 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 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 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 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 | (define (update-search x val) ;; (print "Setting search for " x " to " val) (hash-table-set! *searchpatts* x val)) (define (mark-for-update) (set! *last-db-update-time* 0) (set! *delayed-update* 1)) ;;====================================================================== ;; R U N C O N T R O L ;;====================================================================== ;; target populating logic ;; ;; lb = <vector curr-label-object next-label-object> ;; field = target field name for this dropdown ;; referent-vals = selected value in the left dropdown ;; targets = list of targets to use to build the dropdown ;; ;; each node is chained: key1 -> key2 -> key3 ;; ;; must select values from only apropriate targets ;; a b c ;; a d e ;; a b f ;; a/b => c f ;; (define (dashboard:populate-target-dropdown lb referent-vals targets) ;; is the current value in the new list? choose new default if not (let* ((remvalues (map (lambda (row) (common:list-is-sublist referent-vals (vector->list row))) targets)) (values (delete-duplicates (map car (filter list? remvalues)))) (sel-valnum (iup:attribute lb "VALUE")) (sel-val (iup:attribute lb sel-valnum)) (val-num 1)) ;; first check if the current value is in the new list, otherwise replace with ;; first value from values (iup:attribute-set! lb "REMOVEITEM" "ALL") (for-each (lambda (val) ;; (iup:attribute-set! lb "APPENDITEM" val) (iup:attribute-set! lb (conc val-num) val) (if (equal? sel-val val) (iup:attribute-set! lb "VALUE" val-num)) (set! val-num (+ val-num 1))) values) (let ((val (iup:attribute lb "VALUE"))) (if val val (let ((newval (car values))) (iup:attribute-set! lb "VALUE" newval) newval))))) (define (dashboard:update-target-selector key-lbs #!key (action-proc #f)) (let* ((db-target-dat (open-run-close db:get-targets #f)) (header (vector-ref db-target-dat 0)) (db-targets (vector-ref db-target-dat 1)) (key-listboxes (if key-lbs key-lbs (make-list (length header) #f)))) (let loop ((key (car header)) (remkeys (cdr header)) (refvals '()) (indx 0) (lbs '())) (let* ((lb (let ((lb (list-ref key-listboxes indx))) (if lb lb (iup:listbox #:size "x10" #:fontsize "10" #:expand "VERTICAL" ;; #:dropdown "YES" #:editbox "YES" #:action action-proc )))) ;; loop though all the targets and build the list for this dropdown (selected-value (dashboard:populate-target-dropdown lb refvals db-targets))) (if (null? remkeys) ;; return a list of the listbox items and an iup:hbox with the labels and listboxes (let ((listboxes (append lbs (list lb)))) (list listboxes (map (lambda (htxt lb) (iup:vbox (iup:label htxt) lb)) header listboxes))) (loop (car remkeys) (cdr remkeys) (append refvals (list selected-value)) (+ indx 1) (append lbs (list lb)))))))) (define (dashboard:draw-tests cnv xadj yadj test-draw-state sorted-testnames) (canvas-clear! cnv) (canvas-font-set! cnv "Courier New, -10") (let-values (((sizex sizey sizexmm sizeymm) (canvas-size cnv)) ((originx originy) (canvas-origin cnv))) (if (hash-table-ref/default test-draw-state 'first-time #t) (begin (hash-table-set! test-draw-state 'first-time #f) (hash-table-set! test-draw-state 'scalef 8) ;; set these (hash-table-set! test-draw-state 'test-browse-xoffset 20) ;; (- 0 (* (/ sizex 2) (* 8 xadj)))) (hash-table-set! test-draw-state 'test-browse-yoffset 20))) ;; (- 0 (* (/ sizey 2) (* 8 (- 1 yadj))))))) (let* ((scalef (hash-table-ref/default test-draw-state 'scalef 8)) (test-browse-xoffset (hash-table-ref test-draw-state 'test-browse-xoffset)) (test-browse-yoffset (hash-table-ref test-draw-state 'test-browse-yoffset)) (xtorig (+ test-browse-xoffset (* (/ sizex 2) scalef (- 0.5 xadj)))) ;; (- xadj 1)))) (ytorig (+ test-browse-yoffset (* (/ sizey 2) scalef (- yadj 0.5)))) (boxw 90) (boxh 25) (gapx 20) (gapy 30)) (print "sizex: " sizex " sizey: " sizey " font: " (canvas-font cnv) " originx: " originx " originy: " originy " xtorig: " xtorig " ytorig: " ytorig " xadj: " xadj " yadj: " yadj) (let loop ((hed (car (reverse sorted-testnames))) (tal (cdr (reverse sorted-testnames))) (llx xtorig) (lly ytorig) (urx (+ xtorig boxw)) (ury (+ ytorig boxh))) ; (print "hed " hed " llx " llx " lly " lly " urx " urx " ury " ury) (canvas-text! cnv (+ llx 5)(+ lly 5) hed) ;; (conc testname " (" xtorig "," ytorig ")")) (canvas-rectangle! cnv llx urx lly ury) (if (not (null? tal)) ;; leave a column of space to the right to list items (let ((have-room (if #t ;; put "auto" here where some form of auto rearanging can be done (> (* 3 (+ boxw gapx)) (- urx xtorig)) (< urx (- sizex boxw gapx boxw))))) ;; is there room for another column? (loop (car tal) (cdr tal) (if have-room (+ llx boxw gapx) xtorig) ;; have room, (if have-room lly (+ lly boxh gapy)) (if have-room (+ urx boxw gapx) (+ xtorig boxw)) (if have-room ury (+ ury boxh gapy))))))))) (define (dashboard:run-controls) (let* ((targets (make-hash-table)) (runconf-targs (common:get-runconfig-targets)) (test-records (make-hash-table)) (test-names (tests:get-valid-tests *toppath* '())) (sorted-testnames #f) (action "-runtests") (cmdln "") (runlogs (make-hash-table)) (key-listboxes #f) (update-keyvals (lambda (obj b c d) ;; (print "obj: " obj ", b " b ", c " c ", d " d) (dashboard:update-target-selector key-listboxes) )) (tests-draw-state (make-hash-table))) ;; use for keeping state of the test canvas (hash-table-set! tests-draw-state 'first-time #t) (hash-table-set! tests-draw-state 'scalef 8) (tests:get-full-data test-names test-records '()) (set! sorted-testnames (tests:sort-by-priority-and-waiton test-records)) ;; refer to *keys*, *dbkeys* for keys (iup:vbox (iup:hbox ;; Target and action (iup:frame #:title "Target" (iup:vbox ;; Target selectors (apply iup:hbox (let* ((dat (dashboard:update-target-selector key-listboxes action-proc: update-keyvals)) (key-lb (car dat)) (combos (cadr dat))) (set! key-listboxes key-lb) combos)))) (iup:frame #:title "Tests and Tasks" (iup:vbox (iup:canvas #:action (make-canvas-action (lambda (cnv xadj yadj) ;; (print "cnv: " cnv " x: " x " y: " y) (dashboard:draw-tests cnv xadj yadj tests-draw-state sorted-testnames))) #:size "150x150" #:expand "YES" #:scrollbar "YES" #:posx "0.5" #:posy "0.5"))))))) (trace dashboard:populate-target-dropdown common:list-is-sublist) ;; ;; key1 key2 key3 ... ;; ;; target entry (wild cards allowed) ;; ;; ;; The action ;; (iup:hbox ;; ;; label Action | action selector ;; )) ;; ;; Test/items selector ;; (iup:hbox ;; ;; tests ;; ;; items ;; )) ;; ;; The command line ;; (iup:hbox ;; ;; commandline entry ;; ;; GO button ;; ) ;; ;; The command log monitor ;; (iup:tabs ;; ;; log monitor ;; ))) ;;====================================================================== ;; R U N S ;;====================================================================== (define (make-dashboard-buttons nruns ntests keynames) (let* ((nkeys (length keynames)) (runsvec (make-vector nruns)) (header (make-vector nruns)) (lftcol (make-vector ntests)) (keycol (make-vector ntests)) |
︙ | ︙ | |||
600 601 602 603 604 605 606 | (hash-table-set! *buttondat* button-key (vector 0 "100 100 100" button-key #f #f)) (vector-set! testvec testnum butn) (loop runnum (+ testnum 1) testvec (cons butn res)))))) ;; now assemble the hdrlst and bdylst and kick off the dialog (iup:show (iup:dialog #:title "Megatest dashboard" | > | | | | | | | | | > > > > > | | 806 807 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 | (hash-table-set! *buttondat* button-key (vector 0 "100 100 100" button-key #f #f)) (vector-set! testvec testnum butn) (loop runnum (+ testnum 1) testvec (cons butn res)))))) ;; now assemble the hdrlst and bdylst and kick off the dialog (iup:show (iup:dialog #:title "Megatest dashboard" (let ((tabs (iup:tabs (iup:vbox (apply iup:hbox (cons (apply iup:vbox lftlst) (list (iup:vbox ;; the header (apply iup:hbox (reverse hdrlst)) (apply iup:hbox (reverse bdylst)))))) controls) (dashboard:run-controls) ))) (iup:attribute-set! tabs "TABTITLE0" "Runs") (iup:attribute-set! tabs "TABTITLE1" "Run Control") tabs))) (vector keycol lftcol header runsvec))) (if (or (args:get-arg "-rows") (get-environment-variable "DASHBOARDROWS" )) (begin (set! *num-tests* (string->number (or (args:get-arg "-rows") (get-environment-variable "DASHBOARDROWS")))) (update-rundat "%" *num-runs* "%/%" '())) |
︙ | ︙ |
Modified db.scm from [d5deffc7e3] to [ad6a82067c].
︙ | ︙ | |||
239 240 241 242 243 244 245 | )) ;;====================================================================== ;; T E S T S P E C I F I C D B ;;====================================================================== ;; Create the sqlite db for the individual test(s) | | | | | | | | | | | | > > | | 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 | )) ;;====================================================================== ;; T E S T S P E C I F I C D B ;;====================================================================== ;; Create the sqlite db for the individual test(s) (define (open-test-db work-area) (debug:print-info 11 "open-test-db " work-area) (if (and work-area (directory? work-area) (file-read-access? work-area)) (let* ((dbpath (conc work-area "/testdat.db")) (dbexists (file-exists? dbpath)) (handler (make-busy-timeout (if (args:get-arg "-override-timeout") (string->number (args:get-arg "-override-timeout")) 136000)))) (handle-exceptions exn (begin (debug:print 0 "ERROR: problem accessing test db " work-area ", you probably should clean and re-run this test" ((condition-property-accessor 'exn 'message) exn)) #f) (set! db (sqlite3:open-database dbpath))) (sqlite3:set-busy-handler! db handler) (if (not dbexists) (begin (sqlite3:execute db "PRAGMA synchronous = FULL;") (debug:print-info 11 "Initialized test database " dbpath) (db:testdb-initialize db))) ;; (sqlite3:execute db "PRAGMA synchronous = 0;") (debug:print-info 11 "open-test-db END (sucessful)" work-area) ;; now let's test that everything is correct (handle-exceptions exn (begin (debug:print 0 "ERROR: problem accessing test db " work-area ", you probably should clean and re-run this test" ((condition-property-accessor 'exn 'message) exn)) #f) ;; Is there a cheaper single line operation that will check for existance of a table ;; and raise an exception ? (sqlite3:execute db "SELECT id FROM test_data LIMIT 1;")) db) (begin (debug:print-info 11 "open-test-db END (unsucessful)" work-area) #f))) ;; find and open the testdat.db file for an existing test (define (db:open-test-db-by-test-id db test-id #!key (work-area #f)) (let* ((test-path (if work-area work-area (cdb:remote-run db:test-get-rundir-from-test-id db test-id)))) (debug:print 3 "TEST PATH: " test-path) (open-test-db test-path))) (define (db:testdb-initialize db) (debug:print 11 "db:testdb-initialize START") (for-each (lambda (sqlcmd) |
︙ | ︙ | |||
504 505 506 507 508 509 510 511 512 513 514 515 516 517 | (set! res (cons (vector key keytype) res))) db "SELECT fieldname,fieldtype FROM keys ORDER BY id DESC;") (set! *db-keys* res) (debug:print-info 11 "db:get-keys END (cache miss)") res))) (define (db:get-value-by-header row header field) (debug:print-info 4 "db:get-value-by-header row: " row " header: " header " field: " field) (if (null? header) #f (let loop ((hed (car header)) (tal (cdr header)) (n 0)) (if (equal? hed field) | > | 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 | (set! res (cons (vector key keytype) res))) db "SELECT fieldname,fieldtype FROM keys ORDER BY id DESC;") (set! *db-keys* res) (debug:print-info 11 "db:get-keys END (cache miss)") res))) ;; (define (db:get-value-by-header row header field) (debug:print-info 4 "db:get-value-by-header row: " row " header: " header " field: " field) (if (null? header) #f (let loop ((hed (car header)) (tal (cdr header)) (n 0)) (if (equal? hed field) |
︙ | ︙ | |||
538 539 540 541 542 543 544 545 546 547 548 549 550 551 | (string-intersperse (map (lambda (patt) (let ((wildtype (if (substring-index "%" patt) "LIKE" "GLOB"))) (conc fieldname " " wildtype " '" patt "'"))) (if (null? patts) '("") patts)) comparator))) ;; replace header and keystr with a call to runs:get-std-run-fields ;; ;; keypatts: ( (KEY1 "abc%def")(KEY2 "%") ) ;; runpatts: patt1,patt2 ... ;; (define (db:get-runs db runpatt count offset keypatts) | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 | (string-intersperse (map (lambda (patt) (let ((wildtype (if (substring-index "%" patt) "LIKE" "GLOB"))) (conc fieldname " " wildtype " '" patt "'"))) (if (null? patts) '("") patts)) comparator))) ;; register a test run with the db (define (db:register-run db keys keyvallst runname state status user) (debug:print 3 "runs:register-run, keys: " keys " keyvallst: " keyvallst " runname: " runname " state: " state " status: " status " user: " user) (let* ((keystr (keys->keystr keys)) (comma (if (> (length keys) 0) "," "")) (andstr (if (> (length keys) 0) " AND " "")) (valslots (keys->valslots keys)) ;; ?,?,? ... (keyvals (map cadr keyvallst)) (allvals (append (list runname state status user) keyvals)) (qryvals (append (list runname) keyvals)) (key=?str (string-intersperse (map (lambda (k)(conc (key:get-fieldname k) "=?")) keys) " AND "))) (debug:print 3 "keys: " keys " allvals: " allvals " keyvals: " keyvals) (debug:print 2 "NOTE: using target " (string-intersperse keyvals "/") " for this run") (if (and runname (null? (filter (lambda (x)(not x)) keyvals))) ;; there must be a better way to "apply and" (let ((res #f)) (apply sqlite3:execute db (conc "INSERT OR IGNORE INTO runs (runname,state,status,owner,event_time" comma keystr ") VALUES (?,?,?,?,strftime('%s','now')" comma valslots ");") allvals) (apply sqlite3:for-each-row (lambda (id) (set! res id)) db (let ((qry (conc "SELECT id FROM runs WHERE (runname=? " andstr key=?str ");"))) ;(debug:print 4 "qry: " qry) qry) qryvals) (sqlite3:execute db "UPDATE runs SET state=?,status=? WHERE id=?;" state status res) res) (begin (debug:print 0 "ERROR: Called without all necessary keys") #f)))) ;; replace header and keystr with a call to runs:get-std-run-fields ;; ;; keypatts: ( (KEY1 "abc%def")(KEY2 "%") ) ;; runpatts: patt1,patt2 ... ;; (define (db:get-runs db runpatt count offset keypatts) |
︙ | ︙ | |||
580 581 582 583 584 585 586 587 588 589 590 591 592 593 | (lambda (a . x) (set! res (cons (apply vector a x) res))) db qrystr ) (debug:print-info 11 "db:get-runs END qrystr: " qrystr " keypatts: " keypatts " offset: " offset " limit: " count) (vector header res))) ;; just get count of runs (define (db:get-num-runs db runpatt) (let ((numruns 0)) (debug:print-info 11 "db:get-num-runs START " runpatt) (sqlite3:for-each-row (lambda (count) | > > > > > > > > > > > > > > > > > > > > > | 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 | (lambda (a . x) (set! res (cons (apply vector a x) res))) db qrystr ) (debug:print-info 11 "db:get-runs END qrystr: " qrystr " keypatts: " keypatts " offset: " offset " limit: " count) (vector header res))) ;; Get all targets from the db ;; (define (db:get-targets db) (let* ((res '()) (keys (db:get-keys db)) (header (map key:get-fieldname keys)) (keystr (keys->keystr keys)) (qrystr (conc "SELECT " keystr " FROM runs;")) (seen (make-hash-table))) (sqlite3:for-each-row (lambda (a . x) (let ((targ (cons a x))) (if (not (hash-table-ref/default seen targ #f)) (begin (hash-table-set! seen targ #t) (set! res (cons (apply vector targ) res)))))) db qrystr) (debug:print-info 11 "db:get-targets END qrystr: " qrystr ) (vector header res))) ;; just get count of runs (define (db:get-num-runs db runpatt) (let ((numruns 0)) (debug:print-info 11 "db:get-num-runs START " runpatt) (sqlite3:for-each-row (lambda (count) |
︙ | ︙ | |||
699 700 701 702 703 704 705 | (hash-table-set! *target* run-id thekey) thekey)))) ;;====================================================================== ;; T E S T S ;;====================================================================== | < < < < < < < < < < < < < < < | 756 757 758 759 760 761 762 763 764 765 766 767 768 769 | (hash-table-set! *target* run-id thekey) thekey)))) ;;====================================================================== ;; T E S T S ;;====================================================================== ;; states and statuses are lists, turn them into ("PASS","FAIL"...) and use NOT IN ;; i.e. these lists define what to NOT show. ;; states and statuses are required to be lists, empty is ok ;; not-in #t = above behaviour, #f = must match (define (db:get-tests-for-run db run-id testpatt states statuses #!key (not-in #t) (sort-by #f) ;; 'rundir 'event_time |
︙ | ︙ | |||
822 823 824 825 826 827 828 | db qry ) (debug:print-info 11 "db:get-tests-for-run START run-ids=" run-ids ", testpatt=" testpatt ", states=" states ", statuses=" statuses ", not-in=" not-in ", sort-by=" sort-by) res)) ;; this one is a bit broken BUG FIXME | | | | 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 | db qry ) (debug:print-info 11 "db:get-tests-for-run START run-ids=" run-ids ", testpatt=" testpatt ", states=" states ", statuses=" statuses ", not-in=" not-in ", sort-by=" sort-by) res)) ;; this one is a bit broken BUG FIXME (define (db:delete-test-step-records db test-id #!key (work-area #f)) ;; Breaking it into two queries for better file access interleaving (let* ((tdb (db:open-test-db-by-test-id db test-id work-area: work-area))) ;; test db's can go away - must check every time (if tdb (begin (sqlite3:execute tdb "DELETE FROM test_steps;") (sqlite3:execute tdb "DELETE FROM test_data;") (sqlite3:finalize! tdb))))) |
︙ | ︙ | |||
872 873 874 875 876 877 878 879 880 881 882 883 884 885 | ;;(debug:print 0 "QRY: " qry) (sqlite3:execute db qry run-id newstate newstatus testname testname))) testnames)) (define (cdb:delete-tests-in-state serverdat run-id state) (cdb:client-call serverdat 'delete-tests-in-state #t *default-numtries* run-id state)) ;; speed up for common cases with a little logic (define (db:test-set-state-status-by-id db test-id newstate newstatus newcomment) (cond ((and newstate newstatus newcomment) (sqlite3:exectute db "UPDATE tests SET state=?,status=?,comment=? WHERE id=?;" newstate newstatus test-id)) ((and newstate newstatus) (sqlite3:execute db "UPDATE tests SET state=?,status=? WHERE id=?;" newstate newstatus test-id)) | > > > > > > > > > | 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 | ;;(debug:print 0 "QRY: " qry) (sqlite3:execute db qry run-id newstate newstatus testname testname))) testnames)) (define (cdb:delete-tests-in-state serverdat run-id state) (cdb:client-call serverdat 'delete-tests-in-state #t *default-numtries* run-id state)) (define (cdb:tests-update-cpuload-diskfree serverdat test-id cpuload diskfree) (cdb:client-call serverdat 'update-cpuload-diskfree #t *default-numtries* cpuload diskfree test-id)) (define (cdb:tests-update-run-duration serverdat test-id minutes) (cdb:client-call serverdat 'update-run-duration #t *default-numtries* minutes test-id)) (define (cdb:tests-update-uname-host serverdat test-id uname hostname) (cdb:client-call serverdat 'update-uname-host #t *default-numtries* test-id uname hostname)) ;; speed up for common cases with a little logic (define (db:test-set-state-status-by-id db test-id newstate newstatus newcomment) (cond ((and newstate newstatus newcomment) (sqlite3:exectute db "UPDATE tests SET state=?,status=?,comment=? WHERE id=?;" newstate newstatus test-id)) ((and newstate newstatus) (sqlite3:execute db "UPDATE tests SET state=?,status=? WHERE id=?;" newstate newstatus test-id)) |
︙ | ︙ | |||
952 953 954 955 956 957 958 | run-id testname item-path) res)) (define db:get-test-id db:get-test-id-not-cached) ;; given a test-info record, patch in the latest data from the testdat.db file ;; found in the test run directory | > > > | | | 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 | run-id testname item-path) res)) (define db:get-test-id db:get-test-id-not-cached) ;; given a test-info record, patch in the latest data from the testdat.db file ;; found in the test run directory ;; ;; NOT USED ;; (define (db:patch-tdb-data-into-test-info db test-id res #!key (work-area #f)) (let ((tdb (db:open-test-db-by-test-id db test-id work-area: work-area))) ;; get state and status from megatest.db in real time ;; other fields that perhaps should be updated: ;; fail_count ;; pass_count ;; final_logf (sqlite3:for-each-row (lambda (state status final_logf) |
︙ | ︙ | |||
1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 | (debug:print-info 11 "Sent " zdat ", received " rawdat) (set! tmp (db:string->obj rawdat)) (vector-ref tmp 2)))) ((zmq) (handle-exceptions exn (begin (thread-sleep! 5) (if (> numretries 0)(apply cdb:client-call serverdat qtype immediate (- numretries 1) params))) (let* ((push-socket (vector-ref serverdat 0)) (sub-socket (vector-ref serverdat 1)) (client-sig (client:get-signature)) (query-sig (message-digest-string (md5-primitive) (conc qtype immediate params))) (zdat (db:obj->string (vector client-sig qtype immediate query-sig params (current-seconds)))) ;; (with-output-to-string (lambda ()(serialize params)))) | > | 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 | (debug:print-info 11 "Sent " zdat ", received " rawdat) (set! tmp (db:string->obj rawdat)) (vector-ref tmp 2)))) ((zmq) (handle-exceptions exn (begin (debug:print-info 0 "cdb:client-call timeout or error. Trying again in 5 seconds") (thread-sleep! 5) (if (> numretries 0)(apply cdb:client-call serverdat qtype immediate (- numretries 1) params))) (let* ((push-socket (vector-ref serverdat 0)) (sub-socket (vector-ref serverdat 1)) (client-sig (client:get-signature)) (query-sig (message-digest-string (md5-primitive) (conc qtype immediate params))) (zdat (db:obj->string (vector client-sig qtype immediate query-sig params (current-seconds)))) ;; (with-output-to-string (lambda ()(serialize params)))) |
︙ | ︙ | |||
1215 1216 1217 1218 1219 1220 1221 | ;; this should match (client:get-signature) ;; we will need to process "all" messages here some day (receive-message* sub-socket) ;; now get the actual message (let ((myres (db:string->obj (receive-message* sub-socket)))) (if (equal? query-sig (vector-ref myres 1)) (set! res (vector-ref myres 2)) | | | | | | | | | | | | | | | | | | > | | 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 | ;; this should match (client:get-signature) ;; we will need to process "all" messages here some day (receive-message* sub-socket) ;; now get the actual message (let ((myres (db:string->obj (receive-message* sub-socket)))) (if (equal? query-sig (vector-ref myres 1)) (set! res (vector-ref myres 2)) (loop))))))) ;; (timeout (lambda () ;; (let loop ((n numretries)) ;; (thread-sleep! 15) ;; (if (not res) ;; (if (> numretries 0) ;; (begin ;; (debug:print 2 "WARNING: no reply to query " params ", trying resend") ;; (debug:print-info 11 "re-sending message") ;; (send-message push-socket zdat) ;; (debug:print-info 11 "message re-sent") ;; (loop (- n 1))) ;; ;; (apply cdb:client-call *runremote* qtype immediate (- numretries 1) params)) ;; (begin ;; (debug:print 0 "ERROR: cdb:client-call timed out " params ", exiting.") ;; (exit 5)))))))) (debug:print-info 11 "Starting threads") (let ((th1 (make-thread send-receive "send receive")) ;; (th2 (make-thread timeout "timeout")) ) (thread-start! th1) ;; (thread-start! th2) (thread-join! th1) (debug:print-info 11 "cdb:client-call returning res=" res) res)))))) (define (cdb:set-verbosity serverdat val) (cdb:client-call serverdat 'set-verbosity #f *default-numtries* val)) |
︙ | ︙ | |||
1264 1265 1266 1267 1268 1269 1270 | (define (cdb:test-rollup-test_data-pass-fail serverdat test-id) (cdb:client-call serverdat 'test_data-pf-rollup #t *default-numtries* test-id test-id test-id test-id)) (define (cdb:pass-fail-counts serverdat test-id fail-count pass-count) (cdb:client-call serverdat 'pass-fail-counts #t *default-numtries* fail-count pass-count test-id)) (define (cdb:tests-register-test serverdat run-id test-name item-path) | < < < | | 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 | (define (cdb:test-rollup-test_data-pass-fail serverdat test-id) (cdb:client-call serverdat 'test_data-pf-rollup #t *default-numtries* test-id test-id test-id test-id)) (define (cdb:pass-fail-counts serverdat test-id fail-count pass-count) (cdb:client-call serverdat 'pass-fail-counts #t *default-numtries* fail-count pass-count test-id)) (define (cdb:tests-register-test serverdat run-id test-name item-path) (cdb:client-call serverdat 'register-test #t *default-numtries* run-id test-name item-path)) (define (cdb:flush-queue serverdat) (cdb:client-call serverdat 'flush #f *default-numtries*)) (define (cdb:kill-server serverdat) (cdb:client-call serverdat 'killserver #t *default-numtries*)) |
︙ | ︙ | |||
1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 | (debug:print 2 "Found path: " path) (debug:print 2 "No such path: " path))) db "SELECT rundir,final_logf FROM tests WHERE run_id=? AND testname=? AND item_path='';" run-id test-name) res)) (define db:queries (list '(register-test "INSERT OR IGNORE INTO tests (run_id,testname,event_time,item_path,state,status) VALUES (?,?,strftime('%s','now'),?,'NOT_STARTED','n/a');") '(state-status "UPDATE tests SET state=?,status=? WHERE id=?;") '(state-status-msg "UPDATE tests SET state=?,status=?,comment=? WHERE id=?;") '(pass-fail-counts "UPDATE tests SET fail_count=?,pass_count=? WHERE id=?;") ;; test_data-pf-rollup is used to set a tests PASS/FAIL based on the pass/fail info from the steps '(test_data-pf-rollup "UPDATE tests SET status=CASE WHEN (SELECT fail_count FROM tests WHERE id=?) > 0 THEN 'FAIL' WHEN (SELECT pass_count FROM tests WHERE id=?) > 0 AND (SELECT status FROM tests WHERE id=?) NOT IN ('WARN','FAIL') THEN 'PASS' ELSE status END WHERE id=?;") '(test-set-log "UPDATE tests SET final_logf=? WHERE id=?;") '(test-set-rundir-by-test-id "UPDATE tests SET rundir=? WHERE id=?") '(test-set-rundir "UPDATE tests SET rundir=? WHERE run_id=? AND testname=? AND item_path=?;") '(delete-tests-in-state "DELETE FROM tests WHERE state=? AND run_id=?;") '(tests:test-set-toplog "UPDATE tests SET final_logf=? WHERE run_id=? AND testname=? AND item_path='';") )) ;; do not run these as part of the transaction (define db:special-queries '(rollup-tests-pass-fail db:roll-up-pass-fail-counts login immediate | > > > > > > > | 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 | (debug:print 2 "Found path: " path) (debug:print 2 "No such path: " path))) db "SELECT rundir,final_logf FROM tests WHERE run_id=? AND testname=? AND item_path='';" run-id test-name) res)) ;;====================================================================== ;; A G R E G A T E D T R A N S A C T I O N D B W R I T E S ;;====================================================================== (define db:queries (list '(register-test "INSERT OR IGNORE INTO tests (run_id,testname,event_time,item_path,state,status) VALUES (?,?,strftime('%s','now'),?,'NOT_STARTED','n/a');") '(state-status "UPDATE tests SET state=?,status=? WHERE id=?;") '(state-status-msg "UPDATE tests SET state=?,status=?,comment=? WHERE id=?;") '(pass-fail-counts "UPDATE tests SET fail_count=?,pass_count=? WHERE id=?;") ;; test_data-pf-rollup is used to set a tests PASS/FAIL based on the pass/fail info from the steps '(test_data-pf-rollup "UPDATE tests SET status=CASE WHEN (SELECT fail_count FROM tests WHERE id=?) > 0 THEN 'FAIL' WHEN (SELECT pass_count FROM tests WHERE id=?) > 0 AND (SELECT status FROM tests WHERE id=?) NOT IN ('WARN','FAIL') THEN 'PASS' ELSE status END WHERE id=?;") '(test-set-log "UPDATE tests SET final_logf=? WHERE id=?;") '(test-set-rundir-by-test-id "UPDATE tests SET rundir=? WHERE id=?") '(test-set-rundir "UPDATE tests SET rundir=? WHERE run_id=? AND testname=? AND item_path=?;") '(delete-tests-in-state "DELETE FROM tests WHERE state=? AND run_id=?;") '(tests:test-set-toplog "UPDATE tests SET final_logf=? WHERE run_id=? AND testname=? AND item_path='';") '(update-cpuload-diskfree "UPDATE tests SET cpuload=?,diskfree=? WHERE id=?;") '(update-run-duration "UPDATE tests SET run_duration=? WHERE id=?;") '(update-uname-host "UPDATE tests SET uname=?,host=? WHERE id=?;") )) ;; do not run these as part of the transaction (define db:special-queries '(rollup-tests-pass-fail db:roll-up-pass-fail-counts login immediate |
︙ | ︙ | |||
1591 1592 1593 1594 1595 1596 1597 | (define (db:testmeta-update-field db testname field value) (sqlite3:execute db (conc "UPDATE test_meta SET " field "=? WHERE testname=?;") value testname)) ;;====================================================================== ;; T E S T D A T A ;;====================================================================== | | | | 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 | (define (db:testmeta-update-field db testname field value) (sqlite3:execute db (conc "UPDATE test_meta SET " field "=? WHERE testname=?;") value testname)) ;;====================================================================== ;; T E S T D A T A ;;====================================================================== (define (db:csv->test-data db test-id csvdata #!key (work-area #f)) (debug:print 4 "test-id " test-id ", csvdata: " csvdata) (let ((tdb (db:open-test-db-by-test-id db test-id work-area: work-area))) (if tdb (let ((csvlist (csv->list (make-csv-reader (open-input-string csvdata) '((strip-leading-whitespace? #t) (strip-trailing-whitespace? #t)) )))) ;; (csv->list csvdata))) (for-each (lambda (csvrow) |
︙ | ︙ | |||
1647 1648 1649 1650 1651 1652 1653 | ((<) (if (< value expected) "pass" "fail")) ((>=) (if (>= value expected) "pass" "fail")) ((<=) (if (<= value expected) "pass" "fail")) (else (conc "ERROR: bad tol comparator " tol)))))) (debug:print 4 "AFTER2: category: " category " variable: " variable " value: " value ", expected: " expected " tol: " tol " units: " units " status: " status " comment: " comment) (sqlite3:execute tdb "INSERT OR REPLACE INTO test_data (test_id,category,variable,value,expected,tol,units,comment,status,type) VALUES (?,?,?,?,?,?,?,?,?,?);" | | > | < | | | | | | | | 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 1721 1722 1723 1724 1725 1726 1727 1728 1729 1730 1731 1732 1733 1734 1735 1736 1737 1738 1739 1740 1741 1742 1743 1744 1745 1746 1747 1748 1749 1750 1751 1752 1753 1754 1755 1756 1757 | ((<) (if (< value expected) "pass" "fail")) ((>=) (if (>= value expected) "pass" "fail")) ((<=) (if (<= value expected) "pass" "fail")) (else (conc "ERROR: bad tol comparator " tol)))))) (debug:print 4 "AFTER2: category: " category " variable: " variable " value: " value ", expected: " expected " tol: " tol " units: " units " status: " status " comment: " comment) (sqlite3:execute tdb "INSERT OR REPLACE INTO test_data (test_id,category,variable,value,expected,tol,units,comment,status,type) VALUES (?,?,?,?,?,?,?,?,?,?);" test-id category variable value expected tol units (if comment comment "") status type))) csvlist) (sqlite3:finalize! tdb))))) ;; get a list of test_data records matching categorypatt (define (db:read-test-data db test-id categorypatt #!key (work-area #f)) (let ((tdb (db:open-test-db-by-test-id db test-id work-area: work-area))) (if tdb (let ((res '())) (sqlite3:for-each-row (lambda (id test_id category variable value expected tol units comment status type) (set! res (cons (vector id test_id category variable value expected tol units comment status type) res))) tdb "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) (sqlite3:finalize! tdb) (reverse res)) '()))) ;; NOTE: Run this local with #f for db !!! (define (db:load-test-data db test-id #!key (work-area #f)) (let loop ((lin (read-line))) (if (not (eof-object? lin)) (begin (debug:print 4 lin) (db:csv->test-data db test-id lin work-area: work-area) (loop (read-line))))) ;; roll up the current results. ;; FIXME: Add the status to (db:test-data-rollup db test-id #f work-area: work-area)) ;; 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 #!key (work-area #f)) (let ((tdb (db:open-test-db-by-test-id db test-id work-area: work-area)) (fail-count 0) (pass-count 0)) (if tdb (begin (sqlite3:for-each-row (lambda (fcount pcount) (set! fail-count fcount) |
︙ | ︙ | |||
1736 1737 1738 1739 1740 1741 1742 | ;; S T E P S ;;====================================================================== (define (db:step-get-time-as-string vec) (seconds->time-string (db:step-get-event_time vec))) ;; db-get-test-steps-for-run | | | | | | 1796 1797 1798 1799 1800 1801 1802 1803 1804 1805 1806 1807 1808 1809 1810 1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 1822 1823 1824 1825 1826 1827 1828 | ;; S T E P S ;;====================================================================== (define (db:step-get-time-as-string vec) (seconds->time-string (db:step-get-event_time vec))) ;; db-get-test-steps-for-run (define (db:get-steps-for-test db test-id #!key (work-area #f)) (let* ((tdb (db:open-test-db-by-test-id db test-id work-area: work-area)) (res '())) (if tdb (begin (sqlite3:for-each-row (lambda (id test-id stepname state status event-time logfile) (set! res (cons (vector id test-id stepname state status event-time (if (string? logfile) logfile "")) res))) tdb "SELECT id,test_id,stepname,state,status,event_time,logfile FROM test_steps WHERE test_id=? ORDER BY id ASC;" ;; event_time DESC,id ASC; test-id) (sqlite3:finalize! tdb) (reverse res)) '()))) ;; get a pretty table to summarize steps ;; (define (db:get-steps-table db test-id #!key (work-area #f)) (let ((steps (db:get-steps-for-test db test-id work-area: work-area))) ;; organise the steps for better readability (let ((res (make-hash-table))) (for-each (lambda (step) (debug:print 6 "step=" step) (let ((record (hash-table-ref/default res |
︙ | ︙ | |||
1813 1814 1815 1816 1817 1818 1819 | ((eq? (db:step-get-event_time a)(db:step-get-event_time b)) (< (db:step-get-id a) (db:step-get-id b))) (else #f))))) res))) ;; get a pretty table to summarize steps ;; | | | | 1873 1874 1875 1876 1877 1878 1879 1880 1881 1882 1883 1884 1885 1886 1887 1888 | ((eq? (db:step-get-event_time a)(db:step-get-event_time b)) (< (db:step-get-id a) (db:step-get-id b))) (else #f))))) res))) ;; get a pretty table to summarize steps ;; (define (db:get-steps-table-list db test-id #!key (work-area #f)) (let ((steps (db:get-steps-for-test db test-id work-area: work-area))) ;; organise the steps for better readability (let ((res (make-hash-table))) (for-each (lambda (step) (debug:print 6 "step=" step) (let ((record (hash-table-ref/default res |
︙ | ︙ | |||
1955 1956 1957 1958 1959 1960 1961 | ;; if the test is not found then clearly the waiton is not met... ;; (if (not ever-seen)(set! result (cons waitontest-name result))))) (if (not ever-seen) (set! result (append (if (null? tests)(list waitontest-name) tests) result))))) waitons) (delete-duplicates result)))) | | | | 2015 2016 2017 2018 2019 2020 2021 2022 2023 2024 2025 2026 2027 2028 2029 2030 2031 2032 | ;; if the test is not found then clearly the waiton is not met... ;; (if (not ever-seen)(set! result (cons waitontest-name result))))) (if (not ever-seen) (set! result (append (if (null? tests)(list waitontest-name) tests) result))))) waitons) (delete-duplicates result)))) (define (db:teststep-set-status! db test-id teststep-name state-in status-in comment logfile #!key (work-area #f)) (debug:print 4 "test-id: " test-id " teststep-name: " teststep-name) ;; db:open-test-db-by-test-id does cdb:remote-run (let* ((tdb (db:open-test-db-by-test-id db test-id work-area: work-area)) (state (items:check-valid-items "state" state-in)) (status (items:check-valid-items "status" status-in))) (if (or (not state)(not status)) (debug:print 3 "WARNING: Invalid " (if status "status" "state") " value \"" (if status state-in status-in) "\", update your validvalues section in megatest.config")) (if tdb (begin |
︙ | ︙ |
Modified docs/manual/megatest_manual.txt from [db93d807cc] to [6b638a28bf].
1 2 3 4 5 6 7 | The Megatest Users Manual ========================= Matt Welland <matt@kiatoa.com> v1.0, April 2012 :doctype: book | < < < < < < < < < < < < < < < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 | The Megatest Users Manual ========================= Matt Welland <matt@kiatoa.com> v1.0, April 2012 :doctype: book [preface] Preface ======= This book is organised as three sub-books; getting started, writing tests and reference. Why Megatest? ~~~~~~~~~~~~~ |
︙ | ︙ |
Modified http-transport.scm from [d020b4da1f] to [b400e69336].
︙ | ︙ | |||
200 201 202 203 204 205 206 | (define (http-transport:client-connect iface port) (let* ((login-res #f) (serverdat (list iface port))) (set! login-res (client:login serverdat)) (if (and (not (null? login-res)) (car login-res)) (begin | | | 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 | (define (http-transport:client-connect iface port) (let* ((login-res #f) (serverdat (list iface port))) (set! login-res (client:login serverdat)) (if (and (not (null? login-res)) (car login-res)) (begin (debug:print-info 2 "Logged in and connected to " iface ":" port) (set! *runremote* serverdat) serverdat) (begin (debug:print-info 0 "Failed to login or connect to " iface ":" port) (set! *runremote* #f) (set! *transport-type* 'fs) #f)))) |
︙ | ︙ |
Modified launch.scm from [72a27c3b60] to [d2d20103be].
︙ | ︙ | |||
51 52 53 54 55 56 57 | '()))) (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)) | | | | 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 | '()))) (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)) ;; testpath is the test spec area (top-path (assoc/default 'toppath cmdinfo)) (work-area (assoc/default 'work-area cmdinfo)) ;; work-area is the test run area (test-name (assoc/default 'test-name cmdinfo)) (runscript (assoc/default 'runscript cmdinfo)) (ezsteps (assoc/default 'ezsteps cmdinfo)) ;; (runremote (assoc/default 'runremote cmdinfo)) (transport (assoc/default 'transport cmdinfo)) (serverinf (assoc/default 'serverinf cmdinfo)) (port (assoc/default 'port cmdinfo)) |
︙ | ︙ | |||
131 132 133 134 135 136 137 | (open-run-close set-run-config-vars #f run-id keys keyvals) ;; environment overrides are done *before* the remaining critical envars. (alist->env-vars env-ovrd) (set-megatest-env-vars run-id) (set-item-env-vars itemdat) (save-environment-as-files "megatest") ;; open-run-close not needed for test-set-meta-info | | | 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 | (open-run-close set-run-config-vars #f run-id keys keyvals) ;; environment overrides are done *before* the remaining critical envars. (alist->env-vars env-ovrd) (set-megatest-env-vars run-id) (set-item-env-vars itemdat) (save-environment-as-files "megatest") ;; open-run-close not needed for test-set-meta-info (tests:set-meta-info #f test-id run-id test-name itemdat 0 work-area) (tests:test-set-status! test-id "REMOTEHOSTSTART" "n/a" (args:get-arg "-m") #f) (if (args:get-arg "-xterm") (set! fullrunscript "xterm") (if (and fullrunscript (not (file-execute-access? fullrunscript))) (system (conc "chmod ug+x " fullrunscript)))) ;; We are about to actually kick off the test ;; so this is a good place to remove the records for |
︙ | ︙ | |||
206 207 208 209 210 211 212 | ;; (set! script (conc script "source " prev-env)))) ;; call the command using mt_ezstep (set! script (conc "mt_ezstep " stepname " " (if prevstep prevstep "-") " " stepcmd)) (debug:print 4 "script: " script) ;; DO NOT remote | | | | 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 | ;; (set! script (conc script "source " prev-env)))) ;; call the command using mt_ezstep (set! script (conc "mt_ezstep " stepname " " (if prevstep prevstep "-") " " stepcmd)) (debug:print 4 "script: " script) ;; DO NOT remote (db:teststep-set-status! #f test-id stepname "start" "-" #f #f work-area: work-area) ;; now launch (let ((pid (process-run script))) (let processloop ((i 0)) (let-values (((pid-val exit-status exit-code)(process-wait pid #t))) (mutex-lock! m) (vector-set! exit-info 0 pid) (vector-set! exit-info 1 exit-status) (vector-set! exit-info 2 exit-code) (mutex-unlock! m) (if (eq? pid-val 0) (begin (thread-sleep! 2) (processloop (+ i 1)))) )) (let ((exinfo (vector-ref exit-info 2)) (logfna (if logpro-used (conc stepname ".html") ""))) ;; testing if procedures called in a remote call cause problems (ans: no or so I suspect) (db:teststep-set-status! #f test-id stepname "end" exinfo #f logfna work-area: work-area)) (if logpro-used (cdb:test-set-log! *runremote* test-id (conc stepname ".html"))) ;; set the test final status (let* ((this-step-status (cond ((and (eq? (vector-ref exit-info 2) 2) logpro-used) 'warn) ((eq? (vector-ref exit-info 2) 0) 'pass) (else 'fail))) |
︙ | ︙ | |||
274 275 276 277 278 279 280 | (current-seconds) start-seconds))))) (kill-tries 0)) (let loop ((minutes (calc-minutes))) (begin (set! kill-job? (test-get-kill-request test-id)) ;; run-id test-name itemdat)) ;; open-run-close not needed for test-set-meta-info | | | 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 | (current-seconds) start-seconds))))) (kill-tries 0)) (let loop ((minutes (calc-minutes))) (begin (set! kill-job? (test-get-kill-request test-id)) ;; run-id test-name itemdat)) ;; open-run-close not needed for test-set-meta-info (tests:set-meta-info #f test-id run-id test-name itemdat minutes work-area) (if kill-job? (begin (mutex-lock! m) (let* ((pid (vector-ref exit-info 0))) (if (number? pid) (begin (debug:print 0 "WARNING: Request received to kill job (attempt # " kill-tries ")") |
︙ | ︙ | |||
535 536 537 538 539 540 541 | ;; (system (conc "ln -sf " test-path " " testlink))) (if (directory? test-path) (begin (let* ((ovrcmd (let ((cmd (config-lookup *configdat* "setup" "testcopycmd"))) (if cmd ;; substitute the TEST_SRC_PATH and TEST_TARG_PATH (string-substitute "TEST_TARG_PATH" test-path | | | > | 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 | ;; (system (conc "ln -sf " test-path " " testlink))) (if (directory? test-path) (begin (let* ((ovrcmd (let ((cmd (config-lookup *configdat* "setup" "testcopycmd"))) (if cmd ;; substitute the TEST_SRC_PATH and TEST_TARG_PATH (string-substitute "TEST_TARG_PATH" test-path (string-substitute "TEST_SRC_PATH" test-src-path cmd #t) #t) #f))) (cmd (if ovrcmd ovrcmd (conc "rsync -av" (if (debug:debug-mode 1) "" "q") " " test-src-path "/ " test-path "/" " >> " test-path "/mt_launch.log >>2 " test-path "/mt_launch.log"))) (status (system cmd))) (if (not (eq? status 0)) (debug:print 2 "ERROR: problem with running \"" cmd "\""))) (list lnkpathf lnkpath )) (list #f #f)))) ;; 1. look though disks list for disk with most space |
︙ | ︙ | |||
666 667 668 669 670 671 672 | (append (list (list "MT_TEST_RUN_DIR" work-area) (list "MT_TEST_NAME" test-name) (list "MT_ITEM_INFO" (conc itemdat)) (list "MT_RUNNAME" runname) (list "MT_TARGET" mt_target) ) itemdat))) | > | > < | > | | | > | | | | | | | | | | 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 | (append (list (list "MT_TEST_RUN_DIR" work-area) (list "MT_TEST_NAME" test-name) (list "MT_ITEM_INFO" (conc itemdat)) (list "MT_RUNNAME" runname) (list "MT_TARGET" mt_target) ) itemdat))) (launch-results (apply (if (equal? (configf:lookup *configdat* "setup" "launchwait") "yes") cmd-run-with-stderr->list process-run) (if useshell (string-intersperse fullcmd " ") (car fullcmd)) (if useshell '() (cdr fullcmd))))) (if (list? launch-results) (with-output-to-file "mt_launch.log" (lambda () (apply print launch-results)) #:append)) (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 ;; NB// Is this still needed? Should be safe to go back to "exit" now? (process-signal (current-process-id) signal/kill) )) (alist->env-vars miscprevvals) (alist->env-vars testprevvals) (alist->env-vars commonprevvals) launch-results)) (change-directory *toppath*)) |
Modified margs.scm from [282b6e3581] to [5bb81571cb].
︙ | ︙ | |||
15 16 17 18 19 20 21 | (define (args:get-arg arg . default) (if (null? default) (hash-table-ref/default args:arg-hash arg #f) (hash-table-ref/default args:arg-hash arg (car default)))) (define (args:get-arg-from ht arg . default) (if (null? default) | | | | > | 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 | (define (args:get-arg arg . default) (if (null? default) (hash-table-ref/default args:arg-hash arg #f) (hash-table-ref/default args:arg-hash arg (car default)))) (define (args:get-arg-from ht arg . default) (if (null? default) (hash-table-ref/default ht arg #f) (hash-table-ref/default ht arg (car default)))) (define (args:usage . args) (if (> (length args) 0) (apply print "ERROR: " args)) (if (string? help) (print help) (print "Usage: " (car (argv)) " ... ")) (exit 0)) ;; args: (define (args:get-args args params switches arg-hash num-needed) (let* ((numargs (length args)) (adj-num-needed (if num-needed (+ num-needed 2) #f))) (if (< numargs (if adj-num-needed adj-num-needed 2)) (if (>= num-needed 1) (args:usage "No arguments provided") '()) (let loop ((arg (cadr args)) (tail (cddr args)) (remargs '())) (cond ((member arg params) ;; args with params (if (< (length tail) 1) (args:usage "param given without argument " arg) |
︙ | ︙ |
Modified megatest.scm from [cde7121482] to [df389d567a].
︙ | ︙ | |||
32 33 34 35 36 37 38 | (include "common_records.scm") (include "key_records.scm") (include "db_records.scm") (include "megatest-fossil-hash.scm") ;; (use trace dot-locking) ;; (trace | > > > > > > | | > | 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 | (include "common_records.scm") (include "key_records.scm") (include "db_records.scm") (include "megatest-fossil-hash.scm") ;; (use trace dot-locking) ;; (trace ;; db:teststep-set-status! ;; db:open-test-db-by-test-id ;; db:test-get-rundir-from-test-id ;; cdb:tests-register-test ;; cdb:tests-update-uname-host ;; cdb:tests-update-run-duration ;; ;; cdb:client-call ;; ;; cdb:remote-run ;; ) ;; cdb:test-set-status-state ;; change-directory ;; db:process-queue-item ;; db:test-get-logfile-info ;; db:teststep-set-status! ;; nice-path ;; obtain-dot-lock |
︙ | ︙ | |||
117 118 119 120 121 122 123 124 125 126 127 128 129 130 | patterns. -list-disks : list the disks available for storing runs -list-targets : list the targets in runconfigs.config -list-db-targets : list the target combinations used in the db -show-config : dump the internal representation of the megatest.config file -show-runconfig : dump the internal representation of the runconfigs.config file -dumpmode json : dump in json format instead of sexpr Misc -rebuild-db : bring the database schema up to date -update-meta : update the tests metadata for all tests -env2file fname : write the environment to fname.csh and fname.sh -setvars VAR1=val1,VAR2=val2 : Add environment variables to a run NB// these are overwritten by values set in config files. | > | 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 | patterns. -list-disks : list the disks available for storing runs -list-targets : list the targets in runconfigs.config -list-db-targets : list the target combinations used in the db -show-config : dump the internal representation of the megatest.config file -show-runconfig : dump the internal representation of the runconfigs.config file -dumpmode json : dump in json format instead of sexpr -show-cmdinfo : dump the command info for a test (run in test environment) Misc -rebuild-db : bring the database schema up to date -update-meta : update the tests metadata for all tests -env2file fname : write the environment to fname.csh and fname.sh -setvars VAR1=val1,VAR2=val2 : Add environment variables to a run NB// these are overwritten by values set in config files. |
︙ | ︙ | |||
229 230 231 232 233 234 235 236 237 238 239 240 241 242 | "-list-servers" ;; mist queries "-list-disks" "-list-targets" "-list-db-targets" "-show-runconfig" "-show-config" ;; queries "-test-paths" ;; get path(s) to a test, ordered by youngest first "-runall" ;; run all tests "-remove-runs" "-rebuild-db" "-rollup" | > | 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 | "-list-servers" ;; mist queries "-list-disks" "-list-targets" "-list-db-targets" "-show-runconfig" "-show-config" "-show-cmdinfo" ;; queries "-test-paths" ;; get path(s) to a test, ordered by youngest first "-runall" ;; run all tests "-remove-runs" "-rebuild-db" "-rollup" |
︙ | ︙ | |||
429 430 431 432 433 434 435 436 437 438 439 440 441 442 | ((not (args:get-arg "-dumpmode")) (pp (hash-table->alist data))) ((string=? (args:get-arg "-dumpmode") "json") (json-write data)) (else (debug:print 0 "ERROR: -dumpmode of " (args:get-arg "-dumpmode") " not recognised"))) (set! *didsomething* #t))) ;;====================================================================== ;; Remove old run(s) ;;====================================================================== ;; since several actions can be specified on the command line the removal ;; is done first | > > > > > > > | 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 | ((not (args:get-arg "-dumpmode")) (pp (hash-table->alist data))) ((string=? (args:get-arg "-dumpmode") "json") (json-write data)) (else (debug:print 0 "ERROR: -dumpmode of " (args:get-arg "-dumpmode") " not recognised"))) (set! *didsomething* #t))) (if (args:get-arg "-show-cmdinfo") (let ((data (read (open-input-string (base64:base64-decode (getenv "MT_CMDINFO")))))) (if (equal? (args:get-arg "-dumpmode") "json") (json-write data) (pp data)) (set! *didsomething* #t))) ;;====================================================================== ;; Remove old run(s) ;;====================================================================== ;; since several actions can be specified on the command line the removal ;; is done first |
︙ | ︙ | |||
795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 | (testpath (assoc/default 'testpath cmdinfo)) (test-name (assoc/default 'test-name cmdinfo)) (runscript (assoc/default 'runscript cmdinfo)) (db-host (assoc/default 'db-host cmdinfo)) (run-id (assoc/default 'run-id cmdinfo)) (test-id (assoc/default 'test-id cmdinfo)) (itemdat (assoc/default 'itemdat cmdinfo)) (db #f)) (change-directory testpath) ;; (set! *runremote* runremote) (set! *transport-type* (string->symbol transport)) (if (not (setup-for-run)) (begin (debug:print 0 "Failed to setup, exiting") (exit 1))) (if (and state status) | > | | | > | 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 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 | (testpath (assoc/default 'testpath cmdinfo)) (test-name (assoc/default 'test-name cmdinfo)) (runscript (assoc/default 'runscript cmdinfo)) (db-host (assoc/default 'db-host cmdinfo)) (run-id (assoc/default 'run-id cmdinfo)) (test-id (assoc/default 'test-id cmdinfo)) (itemdat (assoc/default 'itemdat cmdinfo)) (work-area (assoc/default 'work-area cmdinfo)) (db #f)) (change-directory testpath) ;; (set! *runremote* runremote) (set! *transport-type* (string->symbol transport)) (if (not (setup-for-run)) (begin (debug:print 0 "Failed to setup, exiting") (exit 1))) (if (and state status) ;; DO NOT remote run, makes calls to the testdat.db test db. (db:teststep-set-status! db test-id step state status msg logfile work-area: work-area) (begin (debug:print 0 "ERROR: You must specify :state and :status with every call to -step") (exit 6)))))) (if (args:get-arg "-step") (begin (megatest:step (args:get-arg "-step") (args:get-arg ":state") (args:get-arg ":status") (args:get-arg "-setlog") (args:get-arg "-m")) ;; (if db (sqlite3:finalize! db)) (set! *didsomething* #t))) (if (or (and (args:get-arg "-setlog") ;; since setting up is so costly lets piggyback on -test-status (not (args:get-arg "-step"))) ;; -setlog may have been processed already in the "-step" previous (args:get-arg "-set-toplog") (args:get-arg "-test-status") (args:get-arg "-set-values") (args:get-arg "-load-test-data") (args:get-arg "-runstep") (args:get-arg "-summarize-items")) (if (not (getenv "MT_CMDINFO")) |
︙ | ︙ | |||
843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 | (testpath (assoc/default 'testpath cmdinfo)) (test-name (assoc/default 'test-name cmdinfo)) (runscript (assoc/default 'runscript cmdinfo)) (db-host (assoc/default 'db-host cmdinfo)) (run-id (assoc/default 'run-id cmdinfo)) (test-id (assoc/default 'test-id cmdinfo)) (itemdat (assoc/default 'itemdat cmdinfo)) (db #f) ;; (open-db)) (state (args:get-arg ":state")) (status (args:get-arg ":status"))) (change-directory testpath) ;; (set! *runremote* runremote) (set! *transport-type* (string->symbol transport)) (if (not (setup-for-run)) (begin (debug:print 0 "Failed to setup, exiting") (exit 1))) ;; can setup as client for server mode now ;; (client:setup) (if (args:get-arg "-load-test-data") ;; has sub commands that are rdb: ;; DO NOT put this one into either cdb:remote-run or open-run-close | > | | 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 | (testpath (assoc/default 'testpath cmdinfo)) (test-name (assoc/default 'test-name cmdinfo)) (runscript (assoc/default 'runscript cmdinfo)) (db-host (assoc/default 'db-host cmdinfo)) (run-id (assoc/default 'run-id cmdinfo)) (test-id (assoc/default 'test-id cmdinfo)) (itemdat (assoc/default 'itemdat cmdinfo)) (work-area (assoc/default 'work-area cmdinfo)) (db #f) ;; (open-db)) (state (args:get-arg ":state")) (status (args:get-arg ":status"))) (change-directory testpath) ;; (set! *runremote* runremote) (set! *transport-type* (string->symbol transport)) (if (not (setup-for-run)) (begin (debug:print 0 "Failed to setup, exiting") (exit 1))) ;; can setup as client for server mode now ;; (client:setup) (if (args:get-arg "-load-test-data") ;; has sub commands that are rdb: ;; DO NOT put this one into either cdb:remote-run or open-run-close (db:load-test-data db test-id work-area: work-area)) (if (args:get-arg "-setlog") (let ((logfname (args:get-arg "-setlog"))) (cdb:test-set-log! *runremote* test-id logfname))) (if (args:get-arg "-set-toplog") ;; DO NOT run remote (tests:test-set-toplog! db run-id test-name (args:get-arg "-set-toplog"))) (if (args:get-arg "-summarize-items") |
︙ | ︙ | |||
892 893 894 895 896 897 898 | ((zsh bash sh ash) "2>&1 >") (else ">&"))) (fullcmd (conc "(" (string-intersperse (cons cmd params) " ") ") " redir " " logfile))) ;; mark the start of the test ;; DO NOT run remote | | | | 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 | ((zsh bash sh ash) "2>&1 >") (else ">&"))) (fullcmd (conc "(" (string-intersperse (cons cmd params) " ") ") " redir " " logfile))) ;; mark the start of the test ;; DO NOT run remote (db:teststep-set-status! db test-id stepname "start" "n/a" (args:get-arg "-m") logfile work-area: work-area) ;; run the test step (debug:print-info 2 "Running \"" fullcmd "\"") (change-directory startingdir) (set! exitstat (system fullcmd)) ;; cmd params)) (set! *globalexitstatus* exitstat) (change-directory testpath) ;; run logpro if applicable ;; (process-run "ls" (list "/foo" "2>&1" "blah.log")) (if logprofile (let* ((htmllogfile (conc stepname ".html")) (oldexitstat exitstat) (cmd (string-intersperse (list "logpro" logprofile htmllogfile "<" logfile ">" (conc stepname "_logpro.log")) " "))) (debug:print-info 2 "running \"" cmd "\"") (change-directory startingdir) (set! exitstat (system cmd)) (set! *globalexitstatus* exitstat) ;; no necessary (change-directory testpath) (cdb:test-set-log! *runremote* test-id htmllogfile))) (let ((msg (args:get-arg "-m"))) ;; DO NOT run remote (db:teststep-set-status! db test-id stepname "end" exitstat msg logfile work-area: work-area)) ))) (if (or (args:get-arg "-test-status") (args:get-arg "-set-values")) (let ((newstatus (cond ((number? status) (if (equal? status 0) "PASS" "FAIL")) ((and (string? status) (string->number status))(if (equal? (string->number status) 0) "PASS" "FAIL")) |
︙ | ︙ | |||
939 940 941 942 943 944 945 | (begin (debug:print 0 "ERROR: You must specify :state and :status with every call to -test-status\n" help) ;; (sqlite3:finalize! db) (exit 6))) (let* ((msg (args:get-arg "-m")) (numoth (length (hash-table-keys otherdata)))) ;; Convert to rpc inside the tests:test-set-status! call, not here | | | 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 | (begin (debug:print 0 "ERROR: You must specify :state and :status with every call to -test-status\n" help) ;; (sqlite3:finalize! db) (exit 6))) (let* ((msg (args:get-arg "-m")) (numoth (length (hash-table-keys otherdata)))) ;; Convert to rpc inside the tests:test-set-status! call, not here (tests:test-set-status! test-id state newstatus msg otherdata work-area: work-area)))) (if db (sqlite3:finalize! db)) (set! *didsomething* #t)))) ;;====================================================================== ;; Various helper commands can go below here ;;====================================================================== |
︙ | ︙ |
Modified runs.scm from [f136285a97] to [523e5fa433].
︙ | ︙ | |||
169 170 171 172 173 174 175 | ;;====================================================================== ;; New methodology. These routines will replace the above in time. For ;; now the code is duplicated. This stuff is initially used in the monitor ;; based code. ;;====================================================================== | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | | 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 | ;;====================================================================== ;; New methodology. These routines will replace the above in time. For ;; now the code is duplicated. This stuff is initially used in the monitor ;; based code. ;;====================================================================== ;; This is a duplicate of run-tests (which has been deprecated). Use this one instead of run tests. ;; keyvals. ;; ;; test-names: Comma separated patterns same as test-patts but used in selection ;; of tests to run. The item portions are not respected. ;; FIXME: error out if /patt specified ;; (define (runs:run-tests target runname test-names test-patts user flags) (common:clear-caches) ;; clear all caches (let* ((db #f) (keys (cdb:remote-run db:get-keys #f)) (keyvallst (keys:target->keyval keys target)) (run-id (cdb:remote-run db:register-run #f keys keyvallst runname "new" "n/a" user)) ;; test-name))) (keyvals (if run-id (cdb:remote-run db:get-key-vals #f run-id) #f)) (deferred '()) ;; delay running these since they have a waiton clause ;; keepgoing is the defacto modality now, will add hit-n-run a bit later ;; (keepgoing (hash-table-ref/default flags "-keepgoing" #f)) (runconfigf (conc *toppath* "/runconfigs.config")) (required-tests '()) (test-records (make-hash-table))) |
︙ | ︙ | |||
249 250 251 252 253 254 255 | ;; A failed for some reason then on re-run using -keepgoing the run can never complete. (cdb:delete-tests-in-state *runremote* run-id "NOT_STARTED") (cdb:remote-run db:set-tests-state-status #f run-id test-names #f "FAIL" "NOT_STARTED" "FAIL"))) ;; from here on out the db will be opened and closed on every call runs:run-tests-queue ;; (sqlite3:finalize! db) ;; now add non-directly referenced dependencies (i.e. waiton) | < < < < < < < < < < < < < < < < < < < < < < < < < < < < | | < > | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 | ;; A failed for some reason then on re-run using -keepgoing the run can never complete. (cdb:delete-tests-in-state *runremote* run-id "NOT_STARTED") (cdb:remote-run db:set-tests-state-status #f run-id test-names #f "FAIL" "NOT_STARTED" "FAIL"))) ;; from here on out the db will be opened and closed on every call runs:run-tests-queue ;; (sqlite3:finalize! db) ;; now add non-directly referenced dependencies (i.e. waiton) ;;====================================================================== ;; refactoring this block into tests:get-full-data ;;====================================================================== (tests:get-full-data test-names test-records required-tests) (if (not (null? required-tests)) (debug:print-info 1 "Adding " required-tests " to the run queue")) ;; NOTE: these are all parent tests, items are not expanded yet. (debug:print-info 4 "test-records=" (hash-table->alist test-records)) (runs:run-tests-queue run-id runname test-records keyvallst flags test-patts) (debug:print-info 4 "All done by here"))) |
︙ | ︙ | |||
362 363 364 365 366 367 368 369 370 371 372 373 374 375 | ;; test-records is a hash table testname:item_path => vector < testname testconfig waitons priority items-info ... > (define (runs:run-tests-queue run-id runname test-records keyvallst flags test-patts) ;; At this point the list of parent tests is expanded ;; NB// Should expand items here and then insert into the run queue. (debug:print 5 "test-records: " test-records ", keyvallst: " keyvallst " flags: " (hash-table->alist flags)) (let ((sorted-test-names (tests:sort-by-priority-and-waiton test-records)) (test-registery (make-hash-table)) (num-retries 0) (max-retries (config-lookup *configdat* "setup" "maxretries"))) (set! max-retries (if (and max-retries (string->number max-retries))(string->number max-retries) 100)) (if (not (null? sorted-test-names)) (let loop ((hed (car sorted-test-names)) (tal (cdr sorted-test-names)) (reruns '())) | > | 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 | ;; test-records is a hash table testname:item_path => vector < testname testconfig waitons priority items-info ... > (define (runs:run-tests-queue run-id runname test-records keyvallst flags test-patts) ;; At this point the list of parent tests is expanded ;; NB// Should expand items here and then insert into the run queue. (debug:print 5 "test-records: " test-records ", keyvallst: " keyvallst " flags: " (hash-table->alist flags)) (let ((sorted-test-names (tests:sort-by-priority-and-waiton test-records)) (test-registery (make-hash-table)) (registery-mutex (make-mutex)) (num-retries 0) (max-retries (config-lookup *configdat* "setup" "maxretries"))) (set! max-retries (if (and max-retries (string->number max-retries))(string->number max-retries) 100)) (if (not (null? sorted-test-names)) (let loop ((hed (car sorted-test-names)) (tal (cdr sorted-test-names)) (reruns '())) |
︙ | ︙ | |||
403 404 405 406 407 408 409 | (if (member test-name waitons) (begin (debug:print 0 "ERROR: test " test-name " has listed itself as a waiton, please correct this!") (set! waiton (filter (lambda (x)(not (equal? x hed))) waitons)))) (cond ;; OUTER COND ((not items) ;; when false the test is ok to be handed off to launch (but not before) | | | | 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 | (if (member test-name waitons) (begin (debug:print 0 "ERROR: test " test-name " has listed itself as a waiton, please correct this!") (set! waiton (filter (lambda (x)(not (equal? x hed))) waitons)))) (cond ;; OUTER COND ((not items) ;; when false the test is ok to be handed off to launch (but not before) (let* ((run-limits-info (runs:can-run-more-tests test-record)) ;; look at the test jobgroup and tot jobs running (have-resources (car run-limits-info)) (num-running (list-ref run-limits-info 1)) (num-running-in-jobgroup (list-ref run-limits-info 2)) (max-concurrent-jobs (list-ref run-limits-info 3)) (job-group-limit (list-ref run-limits-info 4)) (prereqs-not-met (cdb:remote-run db:get-prereqs-not-met #f run-id waitons item-path mode: testmode)) (fails (runs:calc-fails prereqs-not-met)) (non-completed (runs:calc-not-completed prereqs-not-met))) (debug:print-info 8 "have-resources: " have-resources " prereqs-not-met: " (string-intersperse (map (lambda (t) (if (vector? t) (conc (db:test-get-state t) "/" (db:test-get-status t)) |
︙ | ︙ | |||
433 434 435 436 437 438 439 | ((not (tests:match test-patts (tests:testqueue-get-testname test-record) item-path)) ;; This test/itempath is not to be run ;; else the run is stuck, temporarily or permanently ;; but should check if it is due to lack of resources vs. prerequisites (debug:print-info 1 "Skipping " (tests:testqueue-get-testname test-record) " " item-path " as it doesn't match " test-patts) ;; (thread-sleep! *global-delta*) (if (not (null? tal)) (loop (car tal)(cdr tal) reruns))) | > > > > | > > > | < > > > > > > > | > > | > > > | | > > > > > > > > > > > | > | > | | | | > | | | 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 | ((not (tests:match test-patts (tests:testqueue-get-testname test-record) item-path)) ;; This test/itempath is not to be run ;; else the run is stuck, temporarily or permanently ;; but should check if it is due to lack of resources vs. prerequisites (debug:print-info 1 "Skipping " (tests:testqueue-get-testname test-record) " " item-path " as it doesn't match " test-patts) ;; (thread-sleep! *global-delta*) (if (not (null? tal)) (loop (car tal)(cdr tal) reruns))) ;; Registery has been started for this test but has not yet completed ;; this should be rare, the case where there are only a couple of tests and the db is slow ;; delay a short while and continue ;; ((eq? (hash-table-ref/default test-registery (runs:make-full-test-name test-name item-path) #f) 'start) ;; (thread-sleep! 0.01) ;; (loop (car newtal)(cdr newtal) reruns)) ;; count number of 'done, if more than 100 then skip on through. (;; (and (< (length (filter (lambda (x)(eq? x 'done))(hash-table-values test-registery))) 100) ;; why get more than 200 ahead? (not (hash-table-ref/default test-registery (runs:make-full-test-name test-name item-path) #f)) ;; ) ;; too many changes required. Implement later. (debug:print-info 4 "Pre-registering test " test-name "/" item-path " to create placeholder" ) ;; NEED TO THREADIFY THIS (let ((th (make-thread (lambda () (mutex-lock! registery-mutex) (hash-table-set! test-registery (runs:make-full-test-name test-name item-path) 'start) (mutex-unlock! registery-mutex) ;; If haven't done it before register a top level test if this is an itemized test (if (not (eq? (hash-table-ref/default test-registery (runs:make-full-test-name test-name "") #f) 'done)) (cdb:tests-register-test *runremote* run-id test-name "")) (cdb:tests-register-test *runremote* run-id test-name item-path) (mutex-lock! registery-mutex) (hash-table-set! test-registery (runs:make-full-test-name test-name item-path) 'done) (mutex-unlock! registery-mutex)) (conc test-name "/" item-path)))) (thread-start! th)) (thread-sleep! *global-delta*) (runs:shrink-can-run-more-tests-delay) ;; DELAY TWEAKER (still needed?) (loop (car newtal)(cdr newtal) reruns)) ;; At this point *all* test registrations must be completed. ((not (null? (filter (lambda (x)(eq? 'start x))(hash-table-values test-registery)))) (debug:print-info 0 "Waiting on test registrations: " (string-intersperse (filter (lambda (x) (eq? (hash-table-ref/default test-registery x #f) 'start)) (hash-table-keys test-registery)) ", ")) (thread-sleep! 0.1) (loop hed tal reruns)) ((not have-resources) ;; simply try again after waiting a second (debug:print-info 1 "no resources to run new tests, waiting ...") ;; Have gone back and forth on this but db starvation is an issue. ;; wait one second before looking again to run jobs. (thread-sleep! 1) ;; (+ 2 *global-delta*)) ;; could have done hed tal here but doing car/cdr of newtal to rotate tests (loop (car newtal)(cdr newtal) reruns)) ((and have-resources (or (null? prereqs-not-met) (and (eq? testmode 'toplevel) (null? non-completed)))) (run:test run-id runname keyvallst test-record flags #f) (hash-table-set! test-registery (runs:make-full-test-name test-name item-path) 'running) (runs:shrink-can-run-more-tests-delay) ;; DELAY TWEAKER (still needed?) ;; (thread-sleep! *global-delta*) (if (not (null? tal)) (loop (car tal)(cdr tal) reruns))) (else ;; must be we have unmet prerequisites (debug:print 4 "FAILS: " fails) ;; If one or more of the prereqs-not-met are FAIL then we can issue ;; a message and drop hed from the items to be processed. (if (null? fails) (begin ;; couldn't run, take a breather (debug:print-info 4 "Shouldn't really get here, race condition? Unable to launch more tests at this moment, killing time ...") ;; (thread-sleep! (+ 0.01 *global-delta*)) ;; long sleep here - no resources, may as well be patient ;; we made new tal by sticking hed at the back of the list (loop (car newtal)(cdr newtal) reruns)) ;; the waiton is FAIL so no point in trying to run hed ever again (if (not (null? tal)) (if (vector? hed) (begin (debug:print 1 "WARN: Dropping test " (db:test-get-testname hed) "/" (db:test-get-item-path hed) " from the launch list as it has prerequistes that are FAIL") (runs:shrink-can-run-more-tests-delay) ;; DELAY TWEAKER (still needed?) ;; (thread-sleep! *global-delta*) (hash-table-set! test-registery (runs:make-full-test-name test-name item-path) 'removed) (loop (car tal)(cdr tal) (cons hed reruns))) (begin (debug:print 1 "WARN: Test not processed correctly. Could be a race condition in your test implementation? " hed) ;; " as it has prerequistes that are FAIL. (NOTE: hed is not a vector)") (runs:shrink-can-run-more-tests-delay) ;; DELAY TWEAKER (still needed?) ;; (thread-sleep! (+ 0.01 *global-delta*)) (loop hed tal reruns))))))))) ;; END OF INNER COND ;; case where an items came in as a list been processed ((and (list? items) ;; thus we know our items are already calculated (not itemdat)) ;; and not yet expanded into the list of things to be done (if (and (debug:debug-mode 1) ;; (>= *verbosity* 1) |
︙ | ︙ | |||
665 666 667 668 669 670 671 | ;; ;; NB// for the above line. I want the test to be registered long before this routine gets called! ;; (set! test-id (open-run-close db:get-test-id db run-id test-name item-path)) (if (not test-id) (begin (debug:print 2 "WARN: Test not pre-created? test-name=" test-name ", item-path=" item-path ", run-id=" run-id) | | | 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 | ;; ;; NB// for the above line. I want the test to be registered long before this routine gets called! ;; (set! test-id (open-run-close db:get-test-id db run-id test-name item-path)) (if (not test-id) (begin (debug:print 2 "WARN: Test not pre-created? test-name=" test-name ", item-path=" item-path ", run-id=" run-id) (cdb:tests-register-test *runremote* run-id test-name item-path) (set! test-id (open-run-close db:get-test-id db run-id test-name item-path)))) (debug:print-info 4 "test-id=" test-id ", run-id=" run-id ", test-name=" test-name ", item-path=\"" item-path "\"") (set! testdat (cdb:get-test-info-by-id *runremote* test-id)))) (set! test-id (db:test-get-id testdat)) (change-directory test-path) (case (if force ;; (args:get-arg "-force") 'NOT_STARTED |
︙ | ︙ | |||
717 718 719 720 721 722 723 724 725 726 727 728 729 730 | (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 #f 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)))))) ((KILLED) (debug:print 1 "NOTE: " new-test-name " is already running or was explictly killed, use -force to launch it.")) | > | 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 | (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. ;; This would be a great place to do the process-fork (if (not (launch-test #f 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)))))) ((KILLED) (debug:print 1 "NOTE: " new-test-name " is already running or was explictly killed, use -force to launch it.")) |
︙ | ︙ | |||
956 957 958 959 960 961 962 | runs))) ;;====================================================================== ;; Rollup runs ;;====================================================================== ;; Update the test_meta table for this test (define (runs:update-test_meta db test-name test-conf) | | | | | | | 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 | runs))) ;;====================================================================== ;; Rollup runs ;;====================================================================== ;; Update the test_meta table for this test (define (runs:update-test_meta db test-name test-conf) (let ((currrecord (cdb:remote-run db:testmeta-get-record db test-name))) (if (not currrecord) (begin (set! currrecord (make-vector 10 #f)) (cdb:remote-run db:testmeta-add-record db test-name))) (for-each (lambda (key) (let* ((idx (cadr key)) (fld (car key)) (val (config-lookup test-conf "test_meta" fld))) ;; (debug:print 5 "idx: " idx " fld: " fld " val: " val) (if (and val (not (equal? (vector-ref currrecord idx) val))) (begin (print "Updating " test-name " " fld " to " val) (cdb:remote-run db:testmeta-update-field db test-name fld val))))) '(("author" 2)("owner" 3)("description" 4)("reviewed" 5)("tags" 9))))) ;; Update test_meta for all tests (define (runs:update-all-test_meta db) (let ((test-names (tests:get-valid-tests))) (for-each (lambda (test-name) (let* ((test-path (conc *toppath* "/tests/" test-name)) (test-configf (conc test-path "/testconfig")) (testexists (and (file-exists? test-configf)(file-read-access? test-configf))) ;; read configs with tricks turned off (i.e. no system) (test-conf (if testexists (read-config test-configf #f #f)(make-hash-table)))) ;; use the open-run-close instead of passing in db (runs:update-test_meta #f test-name test-conf))) test-names))) ;; This could probably be refactored into one complex query ... (define (runs:rollup-run keys keyvallst runname user) ;; was target, now keyvallst (debug:print 4 "runs:rollup-run, keys: " keys " keyvallst: " keyvallst " :runname " runname " user: " user) (let* ((db #f) ;; (keyvalllst (keys:target->keyval keys target)) (new-run-id (cdb:remote-run db:register-run #f keys keyvallst runname "new" "n/a" user)) (prev-tests (open-run-close test:get-matching-previous-test-run-records db new-run-id "%" "%")) (curr-tests (open-run-close db:get-tests-for-run db new-run-id "%/%" '() '())) (curr-tests-hash (make-hash-table))) (open-run-close db:update-run-event_time db new-run-id) ;; index the already saved tests by testname and itemdat in curr-tests-hash (for-each (lambda (testdat) |
︙ | ︙ |
Modified tests.scm from [45344ee04b] to [f0213e3c02].
︙ | ︙ | |||
24 25 26 27 28 29 30 | (include "common_records.scm") (include "key_records.scm") (include "db_records.scm") (include "run_records.scm") (include "test_records.scm") | < < < < < < < < < < | 24 25 26 27 28 29 30 31 32 33 34 35 36 37 | (include "common_records.scm") (include "key_records.scm") (include "db_records.scm") (include "run_records.scm") (include "test_records.scm") ;; tests:glob-like-match (define (tests:glob-like-match patt str) (let ((like (substring-index "%" patt))) (let* ((notpatt (equal? (substring-index "~" patt) 0)) (newpatt (if notpatt (substring patt 1) patt)) (finpatt (if like (string-substitute (regexp "%") ".*" newpatt) |
︙ | ︙ | |||
242 243 244 245 246 247 248 | (loop (car tal)(cdr tal))) #f)))))) (pop-directory) result))) ;; Do not rpc this one, do the underlying calls!!! | | | 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 | (loop (car tal)(cdr tal))) #f)))))) (pop-directory) result))) ;; Do not rpc this one, do the underlying calls!!! (define (tests:test-set-status! test-id state status comment dat #!key (work-area #f)) (debug:print-info 4 "tests:test-set-status! test-id=" test-id ", state=" state ", status=" status ", dat=" dat) (let* ((db #f) (real-status status) (otherdat (if dat dat (make-hash-table))) (testdat (cdb:get-test-info-by-id *runremote* test-id)) (run-id (db:test-get-run_id testdat)) (test-name (db:test-get-testname testdat)) |
︙ | ︙ | |||
288 289 290 291 292 293 294 | ;; update the primary record IF state AND status are defined (if (and state status) (cdb:test-set-status-state *runremote* test-id real-status state (if waived waived comment))) ;; if status is "AUTO" then call rollup (note, this one modifies data in test ;; run area, it does remote calls under the hood. (if (and test-id state status (equal? status "AUTO")) | | | 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 | ;; update the primary record IF state AND status are defined (if (and state status) (cdb:test-set-status-state *runremote* test-id real-status state (if waived waived comment))) ;; if status is "AUTO" then call rollup (note, this one modifies data in test ;; run area, it does remote calls under the hood. (if (and test-id state status (equal? status "AUTO")) (db:test-data-rollup #f test-id status work-area: work-area)) ;; add metadata (need to do this way to avoid SQL injection issues) ;; :first_err ;; (let ((val (hash-table-ref/default otherdat ":first_err" #f))) ;; (if val ;; (sqlite3:execute db "UPDATE tests SET first_err=? WHERE run_id=? AND testname=? AND item_path=?;" val run-id test-name item-path))) |
︙ | ︙ | |||
322 323 324 325 326 327 328 | variable "," value "," expected "," tol "," units "," dcomment ",," ;; extra comma for status type ))) | > | | 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 | variable "," value "," expected "," tol "," units "," dcomment ",," ;; extra comma for status type ))) ;; This was run remote, don't think that makes sense. (db:csv->test-data #f test-id dat)))) ;; need to update the top test record if PASS or FAIL and this is a subtest (if (not (equal? item-path "")) (cdb:roll-up-pass-fail-counts *runremote* run-id test-name item-path status)) (if (or (and (string? comment) |
︙ | ︙ | |||
427 428 429 430 431 432 433 | (release-dot-lock outputfilename))) (close-output-port oup) (change-directory orig-dir) ;; NB// tests:test-set-toplog! is remote internal... (tests:test-set-toplog! db run-id test-name outputfilename) ))))) | > > > | > | > > | < > | < | | < | 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 | (release-dot-lock outputfilename))) (close-output-port oup) (change-directory orig-dir) ;; NB// tests:test-set-toplog! is remote internal... (tests:test-set-toplog! db run-id test-name outputfilename) ))))) ;;====================================================================== ;; Gather data from test/task specifications ;;====================================================================== (define (tests:get-valid-tests testsdir test-patts) ;; #!key (test-names '())) (let ((tests (glob (conc testsdir "/tests/*")))) ;; " (string-translate patt "%" "*"))))) (set! tests (filter (lambda (test)(file-exists? (conc test "/testconfig"))) tests)) (delete-duplicates (filter (lambda (testname) (tests:match test-patts testname #f)) (map (lambda (testp) (last (string-split testp "/"))) tests))))) (define (tests:get-testconfig test-name system-allowed) (let* ((test-path (conc *toppath* "/tests/" test-name)) (test-configf (conc test-path "/testconfig")) (testexists (and (file-exists? test-configf)(file-read-access? test-configf)))) (if testexists (read-config test-configf #f system-allowed environ-patt: (if system-allowed |
︙ | ︙ | |||
528 529 530 531 532 533 534 535 536 537 538 539 540 541 | (member (db:test-get-state wtdat) '("INCOMPETE"))) (set! keep-test #f)))) ;; no point in running this one again waitons)))) (if keep-test (set! runnables (cons testkeyname runnables))))) testkeynames) runnables)) ;;====================================================================== ;; test steps ;;====================================================================== ;; teststep-set-status! used to be here | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 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 610 611 612 613 614 615 616 617 618 619 620 621 | (member (db:test-get-state wtdat) '("INCOMPETE"))) (set! keep-test #f)))) ;; no point in running this one again waitons)))) (if keep-test (set! runnables (cons testkeyname runnables))))) testkeynames) runnables)) ;;====================================================================== ;; refactoring this block into tests:get-full-data from line 263 of runs.scm ;;====================================================================== ;; hed is the test name ;; test-records is a hash of test-name => test record (define (tests:get-full-data test-names test-records required-tests) (if (not (null? test-names)) (let loop ((hed (car test-names)) (tal (cdr test-names))) ;; 'return-procs tells the config reader to prep running system but return a proc (debug:print-info 4 "hed=" hed " at top of loop") (let* ((config (tests:get-testconfig hed 'return-procs)) (waitons (let ((instr (if config (config-lookup config "requirements" "waiton") (begin ;; No config means this is a non-existant test (debug:print 0 "ERROR: non-existent required test \"" hed "\", grep through your testconfigs to find and remove or create the test. Discarding and continuing.") "")))) (debug:print-info 8 "waitons string is " instr) (string-split (cond ((procedure? instr) (let ((res (instr))) (debug:print-info 8 "waiton procedure results in string " res " for test " hed) res)) ((string? instr) instr) (else ;; NOTE: This is actually the case of *no* waitons! ;; (debug:print 0 "ERROR: something went wrong in processing waitons for test " hed) "")))))) (if (not config) ;; this is a non-existant test called in a waiton. (if (null? tal) test-records (loop (car tal)(cdr tal))) (begin (debug:print-info 8 "waitons: " waitons) ;; check for hed in waitons => this would be circular, remove it and issue an ;; error (if (member hed waitons) (begin (debug:print 0 "ERROR: test " hed " has listed itself as a waiton, please correct this!") (set! waitons (filter (lambda (x)(not (equal? x hed))) waitons)))) ;; (items (items:get-items-from-config config))) (if (not (hash-table-ref/default test-records hed #f)) (hash-table-set! test-records hed (vector hed ;; 0 config ;; 1 waitons ;; 2 (config-lookup config "requirements" "priority") ;; priority 3 (let ((items (hash-table-ref/default config "items" #f)) ;; items 4 (itemstable (hash-table-ref/default config "itemstable" #f))) ;; if either items or items table is a proc return it so test running ;; process can know to call items:get-items-from-config ;; if either is a list and none is a proc go ahead and call get-items ;; otherwise return #f - this is not an iterated test (cond ((procedure? items) (debug:print-info 4 "items is a procedure, will calc later") items) ;; calc later ((procedure? itemstable) (debug:print-info 4 "itemstable is a procedure, will calc later") itemstable) ;; calc later ((filter (lambda (x) (let ((val (car x))) (if (procedure? val) val #f))) (append (if (list? items) items '()) (if (list? itemstable) itemstable '()))) 'have-procedure) ((or (list? items)(list? itemstable)) ;; calc now (debug:print-info 4 "items and itemstable are lists, calc now\n" " items: " items " itemstable: " itemstable) (items:get-items-from-config config)) (else #f))) ;; not iterated #f ;; itemsdat 5 #f ;; spare - used for item-path ))) (for-each (lambda (waiton) (if (and waiton (not (member waiton test-names))) (begin (set! required-tests (cons waiton required-tests)) (set! test-names (cons waiton test-names))))) ;; was an append, now a cons waitons) (let ((remtests (delete-duplicates (append waitons tal)))) (if (not (null? remtests)) (loop (car remtests)(cdr remtests)) test-records)))))))) ;;====================================================================== ;; test steps ;;====================================================================== ;; teststep-set-status! used to be here |
︙ | ︙ | |||
551 552 553 554 555 556 557 | (lambda (count) (set! res count)) tdb "SELECT count(id) FROM test_rundat;") res)) 0) | | > > > > | | | | > > | | > | < > | > | | | | > | 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 | (lambda (count) (set! res count)) tdb "SELECT count(id) FROM test_rundat;") res)) 0) (define (tests:update-central-meta-info test-id cpuload diskfree minutes num-records uname hostname) ;; This is a good candidate for threading the requests to enable ;; transactionized write at the server (cdb:tests-update-cpuload-diskfree *runremote* test-id cpuload diskfree) ;; (let ((db (open-db))) ;; (sqlite3:execute db "UPDATE tests SET cpuload=?,diskfree=? WHERE id=?;" ;; cpuload ;; diskfree ;; test-id) (if minutes (cdb:tests-update-run-duration *runremote* test-id minutes)) ;; (sqlite3:execute db "UPDATE tests SET run_duration=? WHERE id=?;" minutes test-id)) (if (eq? num-records 0) (cdb:tests-update-uname-host *runremote* test-id uname hostname)) ;;(sqlite3:execute db "UPDATE tests SET uname=?,host=? WHERE id=?;" uname hostname test-id)) ;;(sqlite3:finalize! db)) ) (define (tests:set-meta-info db test-id run-id testname itemdat minutes work-area) ;; DOES cdb:remote-run under the hood! (let* ((tdb (db:open-test-db-by-test-id db test-id work-area: work-area)) (num-records (test:tdb-get-rundat-count tdb)) (cpuload (get-cpu-load)) (diskfree (get-df (current-directory)))) (if (eq? (modulo num-records 10) 0) ;; every ten records update central (let ((uname (get-uname "-srvpio")) (hostname (get-host-name))) (tests:update-central-meta-info test-id cpuload diskfree minutes num-records uname hostname))) (sqlite3:execute tdb "INSERT INTO test_rundat (update_time,cpuload,diskfree,run_duration) VALUES (strftime('%s','now'),?,?,?);" cpuload diskfree minutes) (sqlite3:finalize! tdb))) ;;====================================================================== ;; A R C H I V I N G ;;====================================================================== (define (test:archive db test-id) #f) (define (test:archive-tests db keynames target) #f) |
Modified tests/Makefile from [60f7cab260] to [11459f8d0e].
︙ | ︙ | |||
42 43 44 45 46 47 48 | cd fullrun;megatest -runtests %/,%/winter -target ubuntu/nfs/none :runname $(RUNNAME)_03 -debug $(DEBUG) sleep 40;cd fullrun;megatest -target ubuntu/nfs/none :runname $(RUNNAME) -set-state-status COMPLETED,FORCED :state COMPLETED :status PASS -testpatt ez_p%s,runfirst/ -debug $(DEBUG) $(LOGGING) test3 : fullprep cd fullrun;$(MEGATEST) -runtests runfirst -reqtarg ubuntu/nfs/none :runname $(RUNNAME)_b -debug 10 | | > | | > | | 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 | cd fullrun;megatest -runtests %/,%/winter -target ubuntu/nfs/none :runname $(RUNNAME)_03 -debug $(DEBUG) sleep 40;cd fullrun;megatest -target ubuntu/nfs/none :runname $(RUNNAME) -set-state-status COMPLETED,FORCED :state COMPLETED :status PASS -testpatt ez_p%s,runfirst/ -debug $(DEBUG) $(LOGGING) test3 : fullprep cd fullrun;$(MEGATEST) -runtests runfirst -reqtarg ubuntu/nfs/none :runname $(RUNNAME)_b -debug 10 test4 : cleanprep @echo "WARNING: No longer running fullprep, test converage may be lessened" cd fullrun;time $(MEGATEST) -debug $(DEBUG) -runtests % -reqtarg ubuntu/nfs/none :runname $(RUNNAME)_b -m "This is a comment specific to a run" -v $(LOGGING) # NOTE: Only one instance can be a server test5 : cleanprep @echo "WARNING: No longer running fullprep, test converage may be lessened" cd fullrun;sleep 0;$(MEGATEST) -runtests % -target $(TARGET) :runname $(RUNNAME)_aa -debug $(DEBUG) $(LOGGING) > aa.log 2> aa.log & cd fullrun;sleep 0;$(MEGATEST) -runtests % -target $(TARGET) :runname $(RUNNAME)_ab -debug $(DEBUG) $(LOGGING) > ab.log 2> ab.log & cd fullrun;sleep 0;$(MEGATEST) -runtests % -target $(TARGET) :runname $(RUNNAME)_ac -debug $(DEBUG) $(LOGGING) > ac.log 2> ac.log & cd fullrun;sleep 0;$(MEGATEST) -runtests % -target $(TARGET) :runname $(RUNNAME)_ad -debug $(DEBUG) $(LOGGING) > ad.log 2> ad.log & # cd fullrun;sleep 0;$(MEGATEST) -runtests % -target $(TARGET) :runname $(RUNNAME)_ae -debug $(DEBUG) $(LOGGING) > ae.log 2> ae.log & # cd fullrun;sleep 0;$(MEGATEST) -runtests % -target $(TARGET) :runname $(RUNNAME)_af -debug $(DEBUG) $(LOGGING) > af.log 2> af.log & test6: fullprep cd fullrun;$(MEGATEST) -runtests runfirst -testpatt %/1 -reqtarg ubuntu/nfs/none :runname $(RUNNAME)_itempatt -v cd fullrun;$(MEGATEST) -runtests runfirst -testpatt %blahha% -reqtarg ubuntu/nfs/none :runname $(RUNNAME)_itempatt -debug 10 cd fullrun;$(MEGATEST) -rollup :runname newrun -target ubuntu/nfs/none -debug 10 cleanprep : ../*.scm Makefile */*.config mkdir -p fullrun/tmp/mt_runs fullrun/tmp/mt_links cd ..;make;make install rm -f */logging.db touch cleanprep fullprep : cleanprep cd fullrun;$(MEGATEST) -remove-runs :runname $(RUNNAME)% -target %/%/% -testpatt %/% cd fullrun;$(BINPATH)/dashboard -rows 15 & |
︙ | ︙ |
Modified tests/fdktestqa/testqa/megatest.config from [c04381f809] to [5cdeb94e1e].
1 | [setup] | | > > | 1 2 3 4 5 6 7 | [setup] testcopycmd cp --remove-destination -rlv TEST_SRC_PATH/. TEST_TARG_PATH/. >> TEST_TARG_PATH/mt_launch.log 2>> TEST_TARG_PATH/mt_launch.log [include ../fdk.config] [server] timeout 0.01 |
Added tests/fdktestqa/testqa/runsuite.sh version [5c9574fe6e].
> > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 | #!/bin/bash (cd ../../..;make && make install) || exit 1 export PATH=$PWD/../../../bin:$PATH for i in a b c d e f;do # g h i j k l m n o p q r s t u v w x y z;do megatest -runtests % -target a/b :runname $i & done echo "" > num-running.log while true; do foo=`megatest -list-runs % | grep RUNNING | wc -l` echo "Num running at `date` $foo" echo "$foo at `date`" >> num-running.log # to make the test go at a reasonable clip only gather this info ever minute sleep 1m done |
Modified tests/fdktestqa/testqa/tests/bigrun/step1.sh from [8c4fcc7255] to [38294e0788].
1 | #!/bin/sh | > | > > > > | 1 2 3 4 5 6 7 8 | #!/bin/sh if [ $NUMBER -lt 200 ];then sleep $NUMBER else sleep 200 fi exit 0 |
Modified tests/fdktestqa/testqa/tests/bigrun/testconfig from [25b4432948] to [54bef43c00].
1 2 3 4 5 6 7 8 9 10 11 | # Add additional steps here. Format is "stepname script" [ezsteps] step1 step1.sh # Test requirements are specified here [requirements] # waiton setup priority 0 # Iteration for your tests are controlled by the items section [items] | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | # Add additional steps here. Format is "stepname script" [ezsteps] step1 step1.sh # Test requirements are specified here [requirements] # waiton setup priority 0 # Iteration for your tests are controlled by the items section [items] NUMBER #{scheme (string-intersperse (map number->string (sort (let loop ((a 0)(res '()))(if (< a 150)(loop (+ a 1)(cons a res)) res)) >)) " ")} # test_meta is a section for storing additional data on your test [test_meta] author matt owner matt description An example test tags tagone,tagtwo |
︙ | ︙ |
Modified tests/fdktestqa/testqa/tests/bigrun2/testconfig from [e796f325ee] to [4f3289f0a3].
1 2 3 4 5 6 7 8 9 10 11 12 13 | # Add additional steps here. Format is "stepname script" [ezsteps] step1 step1.sh # Test requirements are specified here [requirements] waiton bigrun priority 0 mode itemmatch # Iteration for your tests are controlled by the items section [items] | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 | # Add additional steps here. Format is "stepname script" [ezsteps] step1 step1.sh # Test requirements are specified here [requirements] waiton bigrun priority 0 mode itemmatch # Iteration for your tests are controlled by the items section [items] NUMBER #{scheme (string-intersperse (map number->string (sort (let loop ((a 0)(res '()))(if (< a 150)(loop (+ a 1)(cons a res)) res)) >)) " ")} # test_meta is a section for storing additional data on your test [test_meta] author matt owner matt description An example test tags tagone,tagtwo |
︙ | ︙ |
Modified tests/fullrun/config/mt_include_1.config from [4d0b8a5d7e] to [8ae9c17ecf].
1 2 | [setup] # exectutable /path/to/megatest | | | 1 2 3 4 5 6 7 8 9 10 | [setup] # exectutable /path/to/megatest max_concurrent_jobs 150 linktree #{getenv MT_RUN_AREA_HOME}/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 |
︙ | ︙ |
Modified tests/fullrun/megatest.config from [d25787fc32] to [d10fbb7cf0].
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 | [fields] sysname TEXT fsname TEXT datapath TEXT # refareas can be searched to find previous runs # the path points to where megatest.db exists [refareas] area1 /tmp/oldarea/megatest [include config/mt_include_1.config] [setup] # It is possible (but not recommended) to override the rsync command used # to populate the test directories. For test development the following # example can be useful # | > > > > | | 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 | [fields] sysname TEXT fsname TEXT datapath TEXT # refareas can be searched to find previous runs # the path points to where megatest.db exists [refareas] area1 /tmp/oldarea/megatest [include config/mt_include_1.config] [setup] # Set launchwait to yes to use the old launch run code that waits for the launch process to return before # proceeding. # launchwait yes # It is possible (but not recommended) to override the rsync command used # to populate the test directories. For test development the following # example can be useful # testcopycmd cp --remove-destination -rsv TEST_SRC_PATH/. TEST_TARG_PATH/. >> TEST_TARG_PATH/mt_launch.log 2>> TEST_TARG_PATH/mt_launch.log # or for hard links # testcopycmd cp --remove-destination -rlv TEST_SRC_PATH/. TEST_TARG_PATH/. # FULL or 2, NORMAL or 1, OFF or 0 synchronous OFF |
︙ | ︙ |