Changes In Branch rollup Through [bf70f7cd40] Excluding Merge-Ins
This is equivalent to a diff from b82c04e7f3 to bf70f7cd40
2011-09-05
| ||
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 | |
16:22 | Reworked remove runs to only delete directories no longer referenced in the database check-in: 2961a06589 user: matt tags: rollup (unpublished) | |
2011-09-04
| ||
20:12 | Added rollup. check-in: bf70f7cd40 user: matt tags: rollup (unpublished) | |
2011-09-03
| ||
21:07 | Merged accidental change of version in wrong branch to trunk check-in: b82c04e7f3 user: matt tags: trunk | |
2011-09-01
| ||
11:33 | Bumped version to 1.22. Closed-Leaf check-in: a1198a099f user: mrwellan tags: v1.22, waiver-propagation | |
2011-08-30
| ||
22:59 | Merged WAIVER propagation into trunk and bumped version check-in: 39d81114d3 user: matt tags: trunk | |
Modified common.scm from [ae869b679b] to [361ea4a752].
︙ | ︙ | |||
49 50 51 52 53 54 55 56 57 58 59 60 61 62 | (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 "")) ;;====================================================================== ;; System stuff ;;====================================================================== (define (get-df path) (let* ((df-results (cmd-run->list (conc "df " path))) | > > > > > > > > | 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 | (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") | | < < < < < < < < < < < < < < < < < < < < < < < < < < | 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") (comprsteps (db:get-steps-table db test-id)) (newval (string-intersperse (append (list (format #f fmtstr "Stepname" "Start" "End" "Status" "Time") (format #f fmtstr "========" "=====" "======" "======" "==========")) (map (lambda (x) ;; take advantage of the \n on time->string |
︙ | ︙ | |||
417 418 419 420 421 422 423 | ;; (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)))))))) | > | 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 | (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))) | | > | > > | < < | | > > > > | < > > > > > > > > > | > > > > > | > > > > > | | | < > > > | > > > | > | | 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))) ;; get a pretty table to summarize steps ;; (define (db:get-steps-table db test-id) (let ((steps (db:get-steps-for-test db test-id))) ;; 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 (db:step-get-stepname step) ;; stepname start end status (vector (db:step-get-stepname step) "" "" "" "")))) (debug:print 6 "record(before) = " record "\nid: " (db:step-get-id step) "\nstepname: " (db:step-get-stepname step) "\nstate: " (db:step-get-state step) "\nstatus: " (db:step-get-status step) "\ntime: " (db:step-get-event_time step)) (case (string->symbol (db:step-get-state step)) ((start)(vector-set! record 1 (db:step-get-event_time step)) (vector-set! record 3 (if (equal? (vector-ref record 3) "") (db:step-get-status step)))) ((end) (vector-set! record 2 (any->number (db:step-get-event_time step))) (vector-set! record 3 (db:step-get-status step)) (vector-set! record 4 (let ((startt (any->number (vector-ref record 1))) (endt (any->number (vector-ref record 2)))) (debug:print 4 "record[1]=" (vector-ref record 1) ", startt=" startt ", endt=" endt ", get-status: " (db:step-get-status step)) (if (and (number? startt)(number? endt)) (seconds->hr-min-sec (- endt startt)) "-1")))) (else (vector-set! record 1 (db:step-get-event_time step))) (vector-set! record 2 (db:step-get-state step)) (vector-set! record 3 (db:step-get-status step)) (vector-set! record 4 (db:step-get-event_time step))) (hash-table-set! res (db:step-get-stepname step) record) (debug:print 6 "record(after) = " record "\nid: " (db:step-get-id step) "\nstepname: " (db:step-get-stepname step) "\nstate: " (db:step-get-state step) "\nstatus: " (db:step-get-status step) "\ntime: " (db:step-get-event_time step)))) (sort steps (lambda (a b)(< (db:step-get-event_time a)(db:step-get-event_time b))))) res))) ;; USE: (lset-difference string=? '("a" "b" "c") '("d" "c" "e" "a")) ;; ;; Return a list of prereqs that were NOT met ;; Tests (and all items) in waiton list must be "COMPLETED" and "PASS" (define (db-get-prereqs-not-met db run-id waiton) (if (null? waiton) |
︙ | ︙ |
Modified megatest.scm from [1ec4b37821] to [6417d3c92b].
︙ | ︙ | |||
61 62 63 64 65 66 67 | 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 | | | | 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 -rollup : fill run (set by :runname) with latest test(s) from prior runs with same keys -rename-run <runb> : rename run (set by :runname) to <runb>, requires keys -update-meta : update the tests metadata for all tests Helpers -runstep stepname ... : take remaining params as comand and execute as stepname log will be in stepname.log. Best to put command in quotes -logpro file : with -exec apply logpro file to stepname.log, creates |
︙ | ︙ | |||
301 302 303 304 305 306 307 | ;;====================================================================== (if (args:get-arg "-rollup") (general-run-call "-rollup" "rollup tests" (lambda (db keys keynames keyvallst) (let ((n (args:get-arg "-rollup"))) | | | 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"))) (runs:rollup-run db keys))))) ;;====================================================================== ;; run one test ;;====================================================================== ;; 1. find the config file ;; 2. change to the test directory |
︙ | ︙ |
Modified runs.scm from [40302d30cf] to [f3e89435b8].
︙ | ︙ | |||
118 119 120 121 122 123 124 125 126 127 128 129 130 131 | (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))))))))) (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 | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | (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)) ;; 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))) ;; for each run starting with the most recent look to see if there is a matching test ;; if found then return that matching test record (debug:print 4 "selstr: " selstr ", qrystr: " qrystr ", keyvals: " keyvals ", previous run ids found: " prev-run-ids) (if (null? prev-run-ids) #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) (if (and (null? results) (not (null? tal))) (loop (car tal)(cdr tal)) results)))))))) (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 |
︙ | ︙ | |||
792 793 794 795 796 797 798 | (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))) | > | > > > > > > > | > > | > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | 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 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 | (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 ... (define (runs:rollup-run db keys) (let* ((new-run-id (register-run db keys)) (prev-tests (test:get-matching-previous-test-run-records db new-run-id "%" "%")) (curr-tests (db-get-tests-for-run db new-run-id "%" "%")) (curr-tests-hash (make-hash-table))) ;; index the already saved tests by testname and itempath in curr-tests-hash (for-each (lambda (testdat) (let* ((testname (db:test-get-testname testdat)) (item-path (db:test-get-item-path testdat)) (full-name (conc testname "/" item-path))) (hash-table-set! curr-tests-hash full-name testdat))) curr-tests) ;; now for each test record found, if it is more recent than that which is stored in ;; the db then: ;; 1. update the db with all data from the newer record ;; 2. update the lookup table (for-each (lambda (testdat) (let* ((testname (db:test-get-testname testdat)) (item-path (db:test-get-item-path testdat)) (full-name (conc testname "/" item-path)) (prev-test-dat (hash-table-ref/default curr-tests-hash full-name #f))) ;; if testdat is more recent than prev-test-dat or if there is no prev-test-dat ;; then update the database and the hash table with this new record (if (or (not prev-test-dat) (> (db:test-get-event_time testdat) (db:test-get-event_time prev-test-dat))) (let ((test-steps (db:get-steps-for-test db (db:test-get-id testdat))) (new-test-record #f)) ;; replace these with insert ... select (apply sqlite3:execute db (conc "INSERT OR REPLACE INTO tests (run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment,value,expected_value,tol,units,first_err,first_warn) " "VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?);") new-run-id (cddr (vector->list testdat))) (set! new-testdat (car (db-get-tests-for-run db new-run-id testname item-path))) (hash-table-set! curr-tests-hash full-name new-testdat) ;; this could be confusing, which record should go into the lookup table? ;; Now duplicate the test steps (debug:print 4 "Copying records in test_steps from test_id=" (db:test-get-id testdat) " to " (db:test-get-id new-testdat)) (sqlite3:execute db (conc "INSERT OR REPLACE INTO test_steps (test_id,stepname,state,status,event_time,comment) " "SELECT " (db:test-get-id new-testdat) ",stepname,state,status,event_time,comment FROM test_steps WHERE test_id=?;") (db:test-get-id testdat)) )))) prev-tests))) |
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 | (use test) ;; (require-library args) (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 "../megatest-version.scm") (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 "./"))) | > > > > | 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 | (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))) | | | 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))) ;; quit wasting time, I'm changing *db* to db (define db *db*) (test "get cpu load" #t (number? (get-cpu-load))) (test "get uname" #t (string? (get-uname))) (test "get validvalues as list" (list "start" "end" "completed") (string-split (config-lookup *configdat* "validvalues" "state"))) |
︙ | ︙ | |||
72 73 74 75 76 77 78 79 80 81 82 83 84 85 | '("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*)))) ;;(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) | > | 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 | (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" "")))) | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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)) |