Overview
Comment: | completed rollup and updated remove-runs to preserve test runs where there are still references in the db |
---|---|
Downloads: | Tarball | ZIP archive | SQL archive |
Timelines: | family | ancestors | descendants | both | trunk |
Files: | files | file ages | folders |
SHA1: |
94a65715c9b3369005a22421657e0ca7 |
User & Date: | matt on 2011-09-05 17:11:50 |
Other Links: | manifest | tags |
Context
2011-09-05
| ||
22:34 | Partial implementation of loading arbitrary test data check-in: dd5766961c user: matt tags: trunk | |
17:11 | completed rollup and updated remove-runs to preserve test runs where there are still references in the db check-in: 94a65715c9 user: matt tags: trunk | |
2011-09-03
| ||
21:07 | Merged accidental change of version in wrong branch to trunk check-in: b82c04e7f3 user: matt tags: trunk | |
Changes
Modified common.scm from [ae869b679b] to [361ea4a752].
︙ | |||
49 50 51 52 53 54 55 56 57 58 59 60 61 62 | 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 | + + + + + + + + | (if (<= n *verbosity*) (apply print params))) ;; if a value is printable (i.e. string or number) return the value ;; else return an empty string (define-inline (printable val) (if (or (number? val)(string? val)) val "")) ;; convert stuff to a number if possible (define (any->number val) (cond ((number? val) val) ((string? val) (string->number val)) ((symbol? val) (any->number (symbol->string val))) (else #f))) ;;====================================================================== ;; System stuff ;;====================================================================== (define (get-df path) (let* ((df-results (cmd-run->list (conc "df " path))) |
︙ |
Modified dashboard-tests.scm from [87658c9114] to [5627038660].
︙ | |||
353 354 355 356 357 358 359 | 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 | - + - - - - - - - - - - - - - - - - - - - - - - - - - - | (let ((stepsdat (iup:label "Test steps ........................................." #:expand "YES" #:size "200x150" #:alignment "ALEFT:ATOP"))) (hash-table-set! widgets "Test Steps" (lambda (testdat) (let* ((currval (iup:attribute stepsdat "TITLE")) (fmtstr "~25a~10a~10a~15a~20a") |
︙ | |||
417 418 419 420 421 422 423 | 391 392 393 394 395 396 397 398 | + | ;; (print "Updating " key) ((hash-table-ref widgets key) testdat)) (hash-table-keys widgets)) (update-state-status-buttons testdat) ; (iup:refresh self) (if *exit-started* (set! *exit-started* 'ok)))))))) |
Modified db.scm from [fd4588d610] to [8d79c7b2db].
︙ | |||
473 474 475 476 477 478 479 | 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 | - - - + + + + + + - - - - - + + + + + + + - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + - - - - + + + + + + + + + + | (lambda (id test-id stepname state status event-time) (set! res (cons (vector id test-id stepname state status event-time) res))) db "SELECT id,test_id,stepname,state,status,event_time FROM test_steps WHERE test_id=? ORDER BY id ASC;" ;; event_time DESC,id ASC; test-id) (reverse res))) |
︙ |
Modified megatest.scm from [1ec4b37821] to [6417d3c92b].
︙ | |||
61 62 63 64 65 66 67 | 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 | - - + + | and :runname ,-testpatt and -itempatt and -testpatt -keepgoing : continue running until no jobs are \"LAUNCHED\" or \"NOT_STARTED\" -rerun FAIL,WARN... : re-run if called on a test that previously ran (nullified if -keepgoing is also specified) -rebuild-db : bring the database schema up to date |
︙ | |||
301 302 303 304 305 306 307 | 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 | - + | ;;====================================================================== (if (args:get-arg "-rollup") (general-run-call "-rollup" "rollup tests" (lambda (db keys keynames keyvallst) (let ((n (args:get-arg "-rollup"))) |
︙ |
Modified runs.scm from [40302d30cf] to [2c155a2315].
︙ | |||
118 119 120 121 122 123 124 125 126 127 128 129 130 131 | 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 | + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + | (let ((results (db-get-tests-for-run db hed test-name item-path))) (debug:print 4 "Got tests for run-id " run-id ", test-name " test-name ", item-path " item-path ": " results) (if (and (null? results) (not (null? tal))) (loop (car tal)(cdr tal)) (car results))))))))) ;; get the previous record for when this test was run where all keys match but runname ;; NB// Merge this with test:get-previous-test-run-records (define (test:get-matching-previous-test-run-records db run-id test-name item-path) (let* ((keys (db:get-keys db)) (selstr (string-intersperse (map (lambda (x)(vector-ref x 0)) keys) ",")) (qrystr (string-intersperse (map (lambda (x)(conc (vector-ref x 0) "=?")) keys) " AND ")) (keyvals #f) (tests-hash (make-hash-table))) ;; first look up the key values from the run selected by run-id (sqlite3:for-each-row (lambda (a . b) (set! keyvals (cons a b))) db (conc "SELECT " selstr " FROM runs WHERE id=? ORDER BY event_time DESC;") run-id) (if (not keyvals) #f (let ((prev-run-ids '())) (apply sqlite3:for-each-row (lambda (id) (set! prev-run-ids (cons id prev-run-ids))) db (conc "SELECT id FROM runs WHERE " qrystr " AND id != ?;") (append keyvals (list run-id))) ;; collect all matching tests for the runs then ;; extract the most recent test and return that. (debug:print 4 "selstr: " selstr ", qrystr: " qrystr ", keyvals: " keyvals ", previous run ids found: " prev-run-ids) (if (null? prev-run-ids) #f ;; no previous runs? return #f (let loop ((hed (car prev-run-ids)) (tal (cdr prev-run-ids))) (let ((results (db-get-tests-for-run db hed test-name item-path))) (debug:print 4 "Got tests for run-id " run-id ", test-name " test-name ", item-path " item-path " results: " (intersperse results "\n")) ;; Keep only the youngest of any test/item combination (for-each (lambda (testdat) (let* ((full-testname (conc (db:test-get-testname testdat) "/" (db:test-get-item-path testdat))) (stored-test (hash-table-ref/default tests-hash full-testname #f))) (if (or (not stored-test) (and stored-test (> (db:test-get-event_time testdat)(db:test-get-event_time stored-test)))) ;; this test is younger, store it in the hash (hash-table-set! tests-hash full-testname testdat)))) results) (if (null? tal) (map cdr (hash-table->alist tests-hash)) ;; return a list of the most recent tests (loop (car tal)(cdr tal)))))))))) (define (test-set-status! db run-id test-name state status itemdat-or-path comment dat) (let* ((real-status status) (item-path (if (string? itemdat-or-path) itemdat-or-path (item-list->path itemdat-or-path))) (otherdat (if dat dat (make-hash-table))) ;; before proceeding we must find out if the previous test (where all keys matched except runname) ;; was WAIVED if this test is FAIL |
︙ | |||
680 681 682 683 684 685 686 | 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 | - + + + - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + | (rundat (runs:get-runs-by-patt db keys runnamepatt)) (header (vector-ref rundat 0)) (runs (vector-ref rundat 1))) (debug:print 1 "Header: " header) (for-each (lambda (run) (let ((runkey (string-intersperse (map (lambda (k) |
︙ | |||
792 793 794 795 796 797 798 | 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 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 | + - + + + + + + + + - - + + + + + + + - - - + + + + + + + + + + + + + + + + + + + + + + + + + + | (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)))) (runs:update-test_meta db test-name test-conf))) test-names))) ;; This could probably be refactored into one complex query ... |
Modified tests/tests.scm from [197f496658] to [d03a123d61].
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 | + + + + | (use test) ;; (require-library args) (include "../megatest.scm") (include "../common.scm") (include "../keys.scm") (include "../db.scm") (include "../configf.scm") (include "../process.scm") (include "../launch.scm") (include "../items.scm") (include "../runs.scm") (include "../runconfig.scm") (include "../megatest-version.scm") (define test-work-dir (current-directory)) (define conffile #f) (test "Read a config" #t (hash-table? (read-config "test.config" #f #f))) (test "Read a config that doesn't exist" #t (hash-table? (read-config "nada.config" #f #f))) (set! conffile (read-config "test.config" #f #f)) (test "Get available diskspace" #t (number? (get-df "./"))) |
︙ | |||
31 32 33 34 35 36 37 | 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 | - + | (define *db* #f) (test "setup for run" #t (begin (setup-for-run) (string? (getenv "MT_RUN_AREA_HOME")))) (test "open-db" #t (begin (set! *db* (open-db)) (if *db* #t #f))) |
︙ | |||
72 73 74 75 76 77 78 79 80 81 82 83 84 85 | 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 | + | '("bar" "foo" ":runname" "bob" ":sysname" "ubuntu" ":fsname" "nfs" ":datapath" "blah/foo" "nada") (list ":runname" ":state" ":status") (list "-h") args:arg-hash 0)) (test "register-run" #t (number? (register-run *db* (db-get-keys *db*)))) (define keys (db-get-keys *db*)) ;;(test "update-test-info" #t (test-update-meta-info *db* 1 "nada" (setenv "BLAHFOO" "1234") (unsetenv "NADAFOO") (test "env temp overrides" "xyz" (let ((prevvals (alist->env-vars '(("BLAHFOO" 4321)("NADAFOO" xyz)))) (result (get-environment-variable "NADAFOO"))) (alist->env-vars prevvals) |
︙ | |||
93 94 95 96 97 98 99 | 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 | + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + | (test "Items assoc" '()(item-assoc->item-list '(("a" "a b c d")("b" "c d e")("c" "")("d")))) (set! *verbosity* -1) (test "Items assoc empty items" '() (item-assoc->item-list '(("A")))) (set! *verbosity* 1) (test "Items table" "SEASON" (caadar (item-table->item-list '(("ANIMAL" "Elephant Lion")("SEASON" "Spring Winter"))))) (test "Items table empty items I" '() (item-table->item-list '(("A")))) (test "Items table empty items II" '() (item-table->item-list '(("A" "")))) ;; Test out the steps code (define test-id #f) ;; force keepgoing ; (hash-table-set! args:arg-hash "-keepgoing" #t) (hash-table-set! args:arg-hash "-itempatt" "%") (hash-table-set! args:arg-hash "-testpatt" "%") (test "Setup for a run" #t (begin (setup-for-run) #t)) (test "Remove the rollup run" #t (begin (remove-runs) #t)) (test "Run a test" #t (general-run-call "-runtests" "run a test" (lambda (db keys keynames keyvallst) (let ((test-names '("runfirst"))) (run-tests db test-names))))) (change-directory test-work-dir) (test "Add a step" #t (begin (teststep-set-status! db 1 "runfirst" "firststep" "start" 0 '() "This is a comment") (sleep 2) (teststep-set-status! db 1 "runfirst" "firststep" "end" "pass" '() "This is a different comment") (set! test-id (db:test-get-id (car (db-get-tests-for-run db 1 "runfirst" "")))) (number? test-id))) (test "Get nice table for steps" "2.0s" (begin (vector-ref (hash-table-ref (db:get-steps-table db test-id) "firststep") 4))) (hash-table-set! args:arg-hash ":runname" "rollup") (test "Remove the rollup run" #t (begin (remove-runs) #t)) (test "Rollup the run(s)" #t (begin (runs:rollup-run db keys) #t)) |