Check-in [ebea00e4bb]
Not logged in
Overview
SHA1 Hash:ebea00e4bbe36fd26a8b37983f5f85cff8590ef7
Date: 2011-08-24 12:50:12
User: mrwellan
Comment:Merged rollup-runs branch into trunk
Timelines: family | ancestors | descendants | both | trunk
Downloads: Tarball | ZIP archive
Other Links: files | file ages | manifest
Tags And Properties
Changes

Modified configf.scm from [2d522c454ccb1e1a] to [ed3f434b69ad5f7b].

28 28 29 (define (config:assoc-safe-add alist key val) 29 (define (config:assoc-safe-add alist key val) 30 (let ((newalist (filter (lambda (x)(not (equal? key (car x)))) alist))) 30 (let ((newalist (filter (lambda (x)(not (equal? key (car x)))) alist))) 31 (append newalist (list (list key val))))) 31 (append newalist (list (list key val))))) 32 32 33 ;; read a config file, returns two level hierarchial hash-table, 33 ;; read a config file, returns two level hierarchial hash-table, 34 ;; adds to ht if given (must be #f otherwise) 34 ;; adds to ht if given (must be #f otherwise) 35 (define (read-config path . ht) | 35 (define (read-config path ht allow-system) 36 (if (not (file-exists? path)) 36 (if (not (file-exists? path)) 37 (if (null? ht)(make-hash-table) (car ht)) | 37 (if (not ht)(make-hash-table) ht) 38 (let ((inp (open-input-file path)) 38 (let ((inp (open-input-file path)) 39 (res (if (null? ht)(make-hash-table)(car ht))) | 39 (res (if (not ht)(make-hash-table) ht)) 40 (include-rx (regexp "^\\[include\\s+(.*)\\]\\s*$")) 40 (include-rx (regexp "^\\[include\\s+(.*)\\]\\s*$")) 41 (section-rx (regexp "^\\[(.*)\\]\\s*$")) 41 (section-rx (regexp "^\\[(.*)\\]\\s*$")) 42 (blank-l-rx (regexp "^\\s*$")) 42 (blank-l-rx (regexp "^\\s*$")) 43 (key-sys-pr (regexp "^(\\S+)\\s+\\[system\\s+(\\S+.*)\\]\\s*$")) 43 (key-sys-pr (regexp "^(\\S+)\\s+\\[system\\s+(\\S+.*)\\]\\s*$")) 44 (key-val-pr (regexp "^(\\S+)\\s+(.*)$")) 44 (key-val-pr (regexp "^(\\S+)\\s+(.*)$")) 45 (comment-rx (regexp "^\\s*#.*")) 45 (comment-rx (regexp "^\\s*#.*")) 46 (cont-ln-rx (regexp "^(\\s+)(\\S+.*)$"))) 46 (cont-ln-rx (regexp "^(\\s+)(\\S+.*)$"))) ................................................................................................................................................................................ 53 (close-input-port inp) 53 (close-input-port inp) 54 res) 54 res) 55 (regex-case 55 (regex-case 56 inl 56 inl 57 (comment-rx _ (loop (read-line inp) curr-section 57 (comment-rx _ (loop (read-line inp) curr-section 58 (blank-l-rx _ (loop (read-line inp) curr-section 58 (blank-l-rx _ (loop (read-line inp) curr-section 59 (include-rx ( x include-file ) (begin 59 (include-rx ( x include-file ) (begin 60 (read-config include-file res) | 60 (read-config include-file res al 61 (loop (read-line inp) curr-secti 61 (loop (read-line inp) curr-secti 62 (section-rx ( x section-name ) (loop (read-line inp) section-name 62 (section-rx ( x section-name ) (loop (read-line inp) section-name > 63 (key-sys-pr ( x key cmd ) (if allow-system 63 (key-sys-pr ( x key cmd ) (let ((alist (hash-table-ref/defau | 64 (let ((alist (hash-table-ref/d 64 (val (let* ((cmdres (cmd- | 65 (val (let* ((cmdres ( 65 (status (cadr | 66 (status ( 66 (res (car | 67 (res ( 67 (if (not (eq? statu | 68 (if (not (eq? s 68 (begin | 69 (begin 69 (debug:print | 70 (debug:pr 70 (exit 1))) | 71 (exit 1)) 71 (if (null? res) | 72 (if (null? res) 72 "" | 73 "" 73 (string-intersp | 74 (string-int 74 (hash-table-set! res curr-sectio | 75 (hash-table-set! res curr-se 75 (config:assoc-s | 76 (config:ass 76 ;; (append alis < 77 (loop (read-line inp) curr-secti | 77 (loop (read-line inp) curr-s > 78 (loop (read-line inp) curr-sec 78 (key-val-pr ( x key val ) (let ((alist (hash-table-ref/defau 79 (key-val-pr ( x key val ) (let ((alist (hash-table-ref/defau 79 (hash-table-set! res curr-sectio 80 (hash-table-set! res curr-sectio 80 (config:assoc-s 81 (config:assoc-s 81 (loop (read-line inp) curr-secti 82 (loop (read-line inp) curr-secti 82 ;; if a continued line 83 ;; if a continued line 83 (cont-ln-rx ( x whsp val ) (let ((alist (hash-table-ref/defau 84 (cont-ln-rx ( x whsp val ) (let ((alist (hash-table-ref/defau 84 (if var-flag ;; if s 85 (if var-flag ;; if s ................................................................................................................................................................................ 100 101 101 (define (find-and-read-config fname) 102 (define (find-and-read-config fname) 102 (let* ((curr-dir (current-directory)) 103 (let* ((curr-dir (current-directory)) 103 (configinfo (find-config fname)) 104 (configinfo (find-config fname)) 104 (toppath (car configinfo)) 105 (toppath (car configinfo)) 105 (configfile (cadr configinfo))) 106 (configfile (cadr configinfo))) 106 (if toppath (change-directory toppath)) 107 (if toppath (change-directory toppath)) 107 (let ((configdat (if configfile (read-config configfile) #f))) ;; (make-has | 108 (let ((configdat (if configfile (read-config configfile #f #t) #f))) ;; (ma 108 (if toppath (change-directory curr-dir)) 109 (if toppath (change-directory curr-dir)) 109 (list configdat toppath configfile fname)))) 110 (list configdat toppath configfile fname)))) 110 111 111 (define (config-lookup cfgdat section var) 112 (define (config-lookup cfgdat section var) 112 (let ((sectdat (hash-table-ref/default cfgdat section '()))) 113 (let ((sectdat (hash-table-ref/default cfgdat section '()))) 113 (if (null? sectdat) 114 (if (null? sectdat) 114 #f 115 #f ................................................................................................................................................................................ 116 (if match 117 (if match 117 (cadr match) 118 (cadr match) 118 #f)) 119 #f)) 119 ))) 120 ))) 120 121 121 (define (setup) 122 (define (setup) 122 (let* ((configf (find-config)) 123 (let* ((configf (find-config)) 123 (config (if configf (read-config configf) #f))) | 124 (config (if configf (read-config configf #f #t) #f))) 124 (if config 125 (if config 125 (setenv "RUN_AREA_HOME" (pathname-directory configf))) 126 (setenv "RUN_AREA_HOME" (pathname-directory configf))) 126 config)) 127 config)) 127 128

Modified db.scm from [04b9f6fc1e091edc] to [aed40706ae4f036d].

60 final_logf TEXT DEFAULT 'logs/final.log', 60 final_logf TEXT DEFAULT 'logs/final.log', 61 logdat BLOB, 61 logdat BLOB, 62 run_duration INTEGER DEFAULT 0, 62 run_duration INTEGER DEFAULT 0, 63 comment TEXT DEFAULT '', 63 comment TEXT DEFAULT '', 64 event_time TIMESTAMP, 64 event_time TIMESTAMP, 65 fail_count INTEGER DEFAULT 0, 65 fail_count INTEGER DEFAULT 0, 66 pass_count INTEGER DEFAULT 0, 66 pass_count INTEGER DEFAULT 0, 67 tags TEXT DEFAULT '', < 68 CONSTRAINT testsconstraint UNIQUE (run_id, testname, item_p 67 CONSTRAINT testsconstraint UNIQUE (run_id, testname, item_p 69 );") 68 );") 70 (sqlite3:execute db "CREATE INDEX tests_index ON tests (run_id, testna 69 (sqlite3:execute db "CREATE INDEX tests_index ON tests (run_id, testna 71 (sqlite3:execute db "CREATE VIEW runs_tests AS SELECT * FROM runs INNE 70 (sqlite3:execute db "CREATE VIEW runs_tests AS SELECT * FROM runs INNE 72 (sqlite3:execute db "CREATE TABLE test_steps 71 (sqlite3:execute db "CREATE TABLE test_steps 73 (id INTEGER PRIMARY KEY, 72 (id INTEGER PRIMARY KEY, 74 test_id INTEGER, 73 test_id INTEGER, ................................................................................................................................................................................ 107 (print "Adding megatest-version to metadata") 106 (print "Adding megatest-version to metadata") 108 (sqlite3:execute db (db:set-var db "MEGATEST_VERSION" megatest-version 107 (sqlite3:execute db (db:set-var db "MEGATEST_VERSION" megatest-version 109 ;; (if (< mver 1.18) 108 ;; (if (< mver 1.18) 110 ;; (begin 109 ;; (begin 111 ;; (print "Adding tags column to tests table") 110 ;; (print "Adding tags column to tests table") 112 ;; (sqlite3:execute db "ALTER TABLE tests ADD COLUMN tags TEXT D 111 ;; (sqlite3:execute db "ALTER TABLE tests ADD COLUMN tags TEXT D 113 (if (< mver 1.20) 112 (if (< mver 1.20) > 113 (begin 114 (sqlite3:execute db "CREATE TABLE test_meta (id INTEGER PRIMARY KEY, | 114 (sqlite3:execute db "CREATE TABLE test_meta (id INTEGER PRIMARY KEY, 115 testname TEXT DEFAULT '', 115 testname TEXT DEFAULT '', 116 author TEXT DEFAULT '', 116 author TEXT DEFAULT '', 117 owner TEXT DEFAULT '', 117 owner TEXT DEFAULT '', 118 description TEXT DEFAULT '', 118 description TEXT DEFAULT '', 119 reviewed TIMESTAMP, 119 reviewed TIMESTAMP, 120 iterated TEXT DEFAULT '', 120 iterated TEXT DEFAULT '', 121 avg_runtime REAL, 121 avg_runtime REAL, 122 avg_disk REAL, 122 avg_disk REAL, 123 tags TEXT DEFAULT '', 123 tags TEXT DEFAULT '', 124 CONSTRAINT test_meta_contstraint UNIQUE (id,test | 124 CONSTRAINT test_meta_contstraint UNIQUE (id,test > 125 (for-each > 126 (lambda (stmt) > 127 (sqlite3:execute db stmt)) > 128 (list > 129 "ALTER TABLE tests ADD COLUMN expected_value REAL;" ;; DO NOT Add a > 130 "ALTER TABLE tests ADD COLUMN value REAL;" > 131 "ALTER TABLE tests ADD COLUMN tol REAL;" > 132 "ALTER TABLE tests ADD COLUMN tol_perc REAL;" > 133 "ALTER TABLE tests ADD COLUMN first_err TEXT;" > 134 "ALTER TABLE tests ADD COLUMN first_warn TEXT;" > 135 )))) 125 (if (< mver megatest-version) 136 (if (< mver megatest-version) 126 (db:set-var db "MEGATEST_VERSION" megatest-version))))) 137 (db:set-var db "MEGATEST_VERSION" megatest-version))))) 127 138 128 ;;====================================================================== 139 ;;====================================================================== 129 ;; meta get and set vars 140 ;; meta get and set vars 130 ;;====================================================================== 141 ;;====================================================================== 131 142 ................................................................................................................................................................................ 197 "") 208 "") 198 (if (and (> (length count) 1) 209 (if (and (> (length count) 1) 199 (number? (cadr count))) 210 (number? (cadr count))) 200 (conc " OFFSET " (cadr count)) 211 (conc " OFFSET " (cadr count)) 201 "")) 212 "")) 202 runpatt) 213 runpatt) 203 (vector header res))) 214 (vector header res))) > 215 > 216 ;; replace header and keystr with a call to runs:get-std-run-fields > 217 ;; keypatt: '(("key1" "patt1")("key2" "patt2")...) > 218 (define (db:get-runs db keys keypatts runpatt) > 219 (let* ((res '()) > 220 (remfields (list "id" "runname" "state" "status" "owner" "event_time")) > 221 (header (append (map key:get-fieldname keys) > 222 remfields)) > 223 (keystr (conc (keys->keystr keys) "," > 224 (string-intersperse remfields ",")))) > 225 (sqlite3:for-each-row > 226 (lambda (a . x) ;; turn all the fields returned into a vector and add to th > 227 (set! res (cons (apply vector a x) res))) > 228 db > 229 (conc "SELECT " keystr " FROM runs WHERE runname LIKE ? " > 230 (map (lambda (keypatt) > 231 (conc "AND " (car keypatt) " LIKE " (cadr keypatt) " ")) > 232 keypatts) > 233 "ORDER BY event_time DESC;") > 234 runpatt) > 235 (vector header res))) 204 236 205 ;; use this one for db-get-run-info 237 ;; use this one for db-get-run-info 206 (define-inline (db:get-row vec)(vector-ref vec 1)) 238 (define-inline (db:get-row vec)(vector-ref vec 1)) 207 239 208 ;; use (get-value-by-header (db:get-header runinfo)(db:get-row runinfo)) 240 ;; use (get-value-by-header (db:get-header runinfo)(db:get-row runinfo)) 209 (define (db:get-run-info db run-id) 241 (define (db:get-run-info db run-id) 210 (let* ((res #f) 242 (let* ((res #f) ................................................................................................................................................................................ 309 ;; done with run when: 341 ;; done with run when: 310 ;; 0 tests in LAUNCHED, NOT_STARTED, REMOTEHOSTSTART, RUNNING 342 ;; 0 tests in LAUNCHED, NOT_STARTED, REMOTEHOSTSTART, RUNNING 311 (define (db:estimated-tests-remaining db run-id) 343 (define (db:estimated-tests-remaining db run-id) 312 (let ((res 0)) 344 (let ((res 0)) 313 (sqlite3:for-each-row 345 (sqlite3:for-each-row 314 (lambda (count) 346 (lambda (count) 315 (set! res count)) 347 (set! res count)) 316 db | 348 db ;; NB// KILLREQ means the jobs is still probably running 317 "SELECT count(id) FROM tests WHERE state in ('LAUNCHED','NOT_STARTED','REMO | 349 "SELECT count(id) FROM tests WHERE state in ('LAUNCHED','NOT_STARTED','REMO 318 res)) 350 res)) 319 351 320 ;; NB// Sync this with runs:get-test-info 352 ;; NB// Sync this with runs:get-test-info 321 (define (db:get-test-info db run-id testname item-path) 353 (define (db:get-test-info db run-id testname item-path) 322 (let ((res #f)) 354 (let ((res #f)) 323 (sqlite3:for-each-row 355 (sqlite3:for-each-row 324 (lambda (id run-id testname state status event-time host cpuload diskfree u 356 (lambda (id run-id testname state status event-time host cpuload diskfree u ................................................................................................................................................................................ 430 (lambda (id test-id stepname state status event-time) 462 (lambda (id test-id stepname state status event-time) 431 (set! res (cons (vector id test-id stepname state status event-time) res) 463 (set! res (cons (vector id test-id stepname state status event-time) res) 432 db 464 db 433 "SELECT id,test_id,stepname,state,status,event_time FROM test_steps WHERE t 465 "SELECT id,test_id,stepname,state,status,event_time FROM test_steps WHERE t 434 test-id) 466 test-id) 435 (reverse res))) 467 (reverse res))) 436 468 437 ;; check that *all* the prereqs are "COMPLETED" | 469 ;; ;; check that *all* the prereqs are "COMPLETED" 438 (define (db-get-prereqs-met db run-id waiton) | 470 ;; (define (db-get-prereqs-met db run-id waiton) 439 (let ((res #f) | 471 ;; (let ((res #f) 440 (not-complete 0) | 472 ;; (not-complete 0) 441 (tests (db-get-tests-for-run db run-id))) | 473 ;; (tests (db-get-tests-for-run db run-id))) 442 (for-each | 474 ;; (for-each 443 (lambda (test-name) | 475 ;; (lambda (test-name) 444 (for-each | 476 ;; (for-each 445 (lambda (test) | 477 ;; (lambda (test) 446 (if (equal? (db:test-get-testname test) test-name) | 478 ;; (if (equal? (db:test-get-testname test) test-name) 447 (begin | 479 ;; (begin 448 (set! res #t) | 480 ;; (set! res #t) 449 (if (not (equal? (db:test-get-state test) "COMPLETED")) | 481 ;; (if (not (equal? (db:test-get-state test) "COMPLETED")) 450 (set! not-complete (+ 1 not-complete)))))) | 482 ;; (set! not-complete (+ 1 not-complete)))))) 451 tests)) | 483 ;; tests)) 452 waiton) | 484 ;; waiton) 453 (and (or (null? waiton) res) | 485 ;; (and (or (null? waiton) res) 454 (eq? not-complete 0)))) | 486 ;; (eq? not-complete 0)))) 455 487 456 ;; USE: (lset-difference string=? '("a" "b" "c") '("d" "c" "e" "a")) 488 ;; USE: (lset-difference string=? '("a" "b" "c") '("d" "c" "e" "a")) 457 ;; 489 ;; 458 ;; Return a list of prereqs that were NOT met 490 ;; Return a list of prereqs that were NOT met 459 ;; Tests (and all items) in waiton list must be "COMPLETED" and "PASS" 491 ;; Tests (and all items) in waiton list must be "COMPLETED" and "PASS" 460 (define (db-get-prereqs-not-met db run-id waiton) 492 (define (db-get-prereqs-not-met db run-id waiton) 461 (if (null? waiton) 493 (if (null? waiton) ................................................................................................................................................................................ 472 (if (not (and (equal? (db:test-get-state 504 (if (not (and (equal? (db:test-get-state 473 (member (db:test-get-statu 505 (member (db:test-get-statu 474 (set! result (cons waitontest-name r 506 (set! result (cons waitontest-name r 475 tests) 507 tests) 476 (if (not ever-seen)(set! result (cons waitontest-name resu 508 (if (not ever-seen)(set! result (cons waitontest-name resu 477 waiton) 509 waiton) 478 (delete-duplicates result)))) 510 (delete-duplicates result)))) 479 ;; < 480 ;; ;; subtract from the waiton list the "COMPLETED" tests < 481 ;; ;;(completed-tests (filter (lambda (x) < 482 ;; ;; (equal? (db:test-get-state x) "COMPLETED < 483 ;; ;; tests)) < 484 ;; (completed-tests (let ((non-completed (make-hash-table))) < 485 ;; (for-each (lambda (x) < 486 ;; ;; could add check for PASS here < 487 ;; (if (not (and (equal? (db:test-get-s < 488 ;; (equal? (db:test-get-s < 489 ;; (hash-table-set! non-completed ( < 490 ;; ;; (debug:print 0 "Completed: " (db: < 491 ;; tests) < 492 ;; (filter (lambda (x) < 493 ;; (not (hash-table-ref/default non-compl < 494 ;; tests))) < 495 ;; (pre-dep-names (map db:test-get-testname completed-tests)) < 496 ;; (result (lset-difference string=? waiton pre-dep-names))) < 497 ;; (print "pre-dep-names: " pre-dep-names " waiton: " waiton " result: " re < 498 511

Modified launch.scm from [aadffc4da1b2c47b] to [f0e35ea73cd485b5].

143 (set! fullcmd (append launcher (car hosts)(list remote-megatest "-execute" 143 (set! fullcmd (append launcher (car hosts)(list remote-megatest "-execute" 144 (launcher 144 (launcher 145 (set! fullcmd (append launcher (list remote-megatest "-execute" cmdparms)) 145 (set! fullcmd (append launcher (list remote-megatest "-execute" cmdparms)) 146 (else 146 (else 147 (set! fullcmd (list remote-megatest "-execute" cmdparms)))) 147 (set! fullcmd (list remote-megatest "-execute" cmdparms)))) 148 (if (args:get-arg "-xterm")(set! fullcmd (append fullcmd (list "-xterm")))) 148 (if (args:get-arg "-xterm")(set! fullcmd (append fullcmd (list "-xterm")))) 149 (debug:print 1 "Launching megatest for test " test-name " in " work-area" .. 149 (debug:print 1 "Launching megatest for test " test-name " in " work-area" .. 150 (test-set-status! db run-id test-name "LAUNCHED" "n/a" itemdat) ;; (if launc | 150 (test-set-status! db run-id test-name "LAUNCHED" "n/a" itemdat #f #f) ;; (if 151 ;; set 151 ;; set 152 ;; set pre-launch-env-vars before launching, keep the vars in prevvals and p 152 ;; set pre-launch-env-vars before launching, keep the vars in prevvals and p 153 (let* ((commonprevvals (alist->env-vars 153 (let* ((commonprevvals (alist->env-vars 154 (hash-table-ref/default *configdat* "env-override" ' 154 (hash-table-ref/default *configdat* "env-override" ' 155 (testprevvals (alist->env-vars 155 (testprevvals (alist->env-vars 156 (hash-table-ref/default test-conf "pre-launch-env-ov 156 (hash-table-ref/default test-conf "pre-launch-env-ov 157 (miscprevvals (alist->env-vars ;; consolidate this code with the co 157 (miscprevvals (alist->env-vars ;; consolidate this code with the co

Modified megatest-version.scm from [ebeb01abfb9afbb7] to [9a855b99f9cbc339].

1 ;; Always use two digit decimal 1 ;; Always use two digit decimal 2 ;; 1.01, 1.02...1.10,1.11 ... 1.99,2.00.. 2 ;; 1.01, 1.02...1.10,1.11 ... 1.99,2.00.. 3 (define megatest-version 1.20) | 3 (define megatest-version 1.21)

Modified megatest.scm from [8f3220a6debc2edd] to [3218809c9e0ffd4b].

35 -m comment : insert a comment for this test 35 -m comment : insert a comment for this test 36 36 37 Run data 37 Run data 38 :runname : required, name for this particular test run 38 :runname : required, name for this particular test run 39 :state : required if updating step state; e.g. start, end, co 39 :state : required if updating step state; e.g. start, end, co 40 :status : required if updating step status; e.g. pass, fail, n 40 :status : required if updating step status; e.g. pass, fail, n 41 41 > 42 Values and record errors and warnings > 43 -set-values : update or set values in the megatest db > 44 :value : value measured > 45 :expected_value : value expected > 46 :tol : tolerance |value-expect| <= tol > 47 :first_err : record an error message > 48 :first_warn : record a warning message > 49 42 Queries 50 Queries 43 -list-runs patt : list runs matching pattern \"patt\", % is the wildca 51 -list-runs patt : list runs matching pattern \"patt\", % is the wildca 44 -testpatt patt : in list-runs show only these tests, % is the wildcar 52 -testpatt patt : in list-runs show only these tests, % is the wildcar 45 -itempatt patt : in list-runs show only tests with items that match p 53 -itempatt patt : in list-runs show only tests with items that match p 46 -showkeys : show the keys used in this megatest setup 54 -showkeys : show the keys used in this megatest setup 47 55 48 Misc 56 Misc ................................................................................................................................................................................ 55 \"NOT_STARTED\" 63 \"NOT_STARTED\" 56 -rerun FAIL,WARN... : re-run if called on a test that previously ran (null 64 -rerun FAIL,WARN... : re-run if called on a test that previously ran (null 57 if -keepgoing is also specified) 65 if -keepgoing is also specified) 58 -rebuild-db : bring the database schema up to date 66 -rebuild-db : bring the database schema up to date 59 -rollup N : fill run (set by :runname) with latest test(s) from 67 -rollup N : fill run (set by :runname) with latest test(s) from 60 past N days, requires keys 68 past N days, requires keys 61 -rename-run <runb> : rename run (set by :runname) to <runb>, requires key 69 -rename-run <runb> : rename run (set by :runname) to <runb>, requires key > 70 -update-meta : update the tests metadata for all tests 62 71 63 Helpers 72 Helpers 64 -runstep stepname ... : take remaining params as comand and execute as stepn 73 -runstep stepname ... : take remaining params as comand and execute as stepn 65 log will be in stepname.log. Best to put command in 74 log will be in stepname.log. Best to put command in 66 -logpro file : with -exec apply logpro file to stepname.log, create 75 -logpro file : with -exec apply logpro file to stepname.log, create 67 stepname.html and sets log to same 76 stepname.html and sets log to same 68 If using make use stepname_logpro.log as your target 77 If using make use stepname_logpro.log as your target ................................................................................................................................................................................ 92 "-runstep" 101 "-runstep" 93 "-logpro" 102 "-logpro" 94 "-m" 103 "-m" 95 "-rerun" 104 "-rerun" 96 "-days" 105 "-days" 97 "-rename-run" 106 "-rename-run" 98 "-to" 107 "-to" > 108 ;; values and messages > 109 ":first_err" > 110 ":first_warn" > 111 ":value" > 112 ":expected_value" > 113 ":tol" > 114 ;; misc 99 "-debug" ;; for *verbosity* > 2 115 "-debug" ;; for *verbosity* > 2 100 ) 116 ) 101 (list "-h" 117 (list "-h" 102 "-force" 118 "-force" 103 "-xterm" 119 "-xterm" 104 "-showkeys" 120 "-showkeys" 105 "-test-status" 121 "-test-status" > 122 "-set-values" 106 "-summarize-items" 123 "-summarize-items" 107 "-gui" 124 "-gui" 108 "-runall" ;; run all tests 125 "-runall" ;; run all tests 109 "-remove-runs" 126 "-remove-runs" 110 "-keepgoing" 127 "-keepgoing" 111 "-usequeue" 128 "-usequeue" 112 "-rebuild-db" 129 "-rebuild-db" 113 "-rollup" 130 "-rollup" > 131 "-update-meta" 114 "-v" ;; verbose 2, more than normal (normal is 1) 132 "-v" ;; verbose 2, more than normal (normal is 1) 115 "-q" ;; quiet 0, errors/warnings only 133 "-q" ;; quiet 0, errors/warnings only 116 ) 134 ) 117 args:arg-hash 135 args:arg-hash 118 0)) 136 0)) 119 137 120 (if (args:get-arg "-h") 138 (if (args:get-arg "-h") ................................................................................................................................................................................ 356 (set-run-config-vars db run-id) 374 (set-run-config-vars db run-id) 357 ;; environment overrides are done *before* the remaining critical en 375 ;; environment overrides are done *before* the remaining critical en 358 (alist->env-vars env-ovrd) 376 (alist->env-vars env-ovrd) 359 (set-megatest-env-vars db run-id) 377 (set-megatest-env-vars db run-id) 360 (set-item-env-vars itemdat) 378 (set-item-env-vars itemdat) 361 (save-environment-as-files "megatest") 379 (save-environment-as-files "megatest") 362 (test-set-meta-info db run-id test-name itemdat) 380 (test-set-meta-info db run-id test-name itemdat) 363 (test-set-status! db run-id test-name "REMOTEHOSTSTART" "n/a" itemda | 381 (test-set-status! db run-id test-name "REMOTEHOSTSTART" "n/a" itemda 364 (if (args:get-arg "-xterm") 382 (if (args:get-arg "-xterm") 365 (set! fullrunscript "xterm") 383 (set! fullrunscript "xterm") 366 (if (not (file-execute-access? fullrunscript)) 384 (if (not (file-execute-access? fullrunscript)) 367 (system (conc "chmod ug+x " fullrunscript)))) 385 (system (conc "chmod ug+x " fullrunscript)))) 368 ;; We are about to actually kick off the test 386 ;; We are about to actually kick off the test 369 ;; so this is a good place to remove the records for 387 ;; so this is a good place to remove the records for 370 ;; any previous runs 388 ;; any previous runs ................................................................................................................................................................................ 444 ;; (test-set-status! db ru 462 ;; (test-set-status! db ru 445 ;; itemdat (ar 463 ;; itemdat (ar 446 ;; (sqlite3:finalize! db) 464 ;; (sqlite3:finalize! db) 447 ;; (exit 1))))) 465 ;; (exit 1))))) 448 (begin 466 (begin 449 (debug:print 0 "WARNING: 467 (debug:print 0 "WARNING: 450 (test-set-status! db run- 468 (test-set-status! db run- 451 itemdat | 469 itemdat 452 (sqlite3:finalize! db) 470 (sqlite3:finalize! db) 453 (exit 1)))) 471 (exit 1)))) 454 ;; (thread-terminate! job-thr 472 ;; (thread-terminate! job-thr 455 (set! kill-tries (+ 1 kill-tries) 473 (set! kill-tries (+ 1 kill-tries) 456 (mutex-unlock! m))) 474 (mutex-unlock! m))) 457 ;; (handle-exceptions 475 ;; (handle-exceptions 458 ;; exn 476 ;; exn ................................................................................................................................................................................ 488 (test-set-status! db run-id test-name 506 (test-set-status! db run-id test-name 489 (if kill-job? "KILLED" "COMPLETED") 507 (if kill-job? "KILLED" "COMPLETED") 490 (if (vector-ref exit-info 1) ;; look at 508 (if (vector-ref exit-info 1) ;; look at 491 (if (and (not kill-job?) 509 (if (and (not kill-job?) 492 (eq? (vector-ref exit-info 510 (eq? (vector-ref exit-info 493 "PASS" 511 "PASS" 494 "FAIL") 512 "FAIL") 495 "FAIL") itemdat (args:get-arg "-m")) | 513 "FAIL") itemdat (args:get-arg "-m") 496 ;; for automated creation of the rollup html file this is a good 514 ;; for automated creation of the rollup html file this is a good 497 (if (not (equal? item-path "")) 515 (if (not (equal? item-path "")) 498 (tests:summarize-items db run-id test-name #f)) ;; don't forc 516 (tests:summarize-items db run-id test-name #f)) ;; don't forc 499 ) 517 ) 500 (mutex-unlock! m) 518 (mutex-unlock! m) 501 ;; (exec-results (cmd-run->list fullrunscript)) ;; (list ">" (con 519 ;; (exec-results (cmd-run->list fullrunscript)) ;; (list ">" (con 502 ;; (success exec-results)) ;; (eq? (cadr exec-results) 0))) 520 ;; (success exec-results)) ;; (eq? (cadr exec-results) 0))) ................................................................................................................................................................................ 536 (exit 6))) 554 (exit 6))) 537 (sqlite3:finalize! db) 555 (sqlite3:finalize! db) 538 (set! *didsomething* #t)))) 556 (set! *didsomething* #t)))) 539 557 540 (if (or (args:get-arg "-setlog") ;; since setting up is so costly lets pig 558 (if (or (args:get-arg "-setlog") ;; since setting up is so costly lets pig 541 (args:get-arg "-set-toplog") 559 (args:get-arg "-set-toplog") 542 (args:get-arg "-test-status") 560 (args:get-arg "-test-status") > 561 (args:get-arg "-set-values") 543 (args:get-arg "-runstep") 562 (args:get-arg "-runstep") 544 (args:get-arg "-summarize-items")) 563 (args:get-arg "-summarize-items")) 545 (if (not (getenv "MT_CMDINFO")) 564 (if (not (getenv "MT_CMDINFO")) 546 (begin 565 (begin 547 (debug:print 0 "ERROR: MT_CMDINFO env var not set, commands -test-stat 566 (debug:print 0 "ERROR: MT_CMDINFO env var not set, commands -test-stat 548 (exit 5)) 567 (exit 5)) 549 (let* ((startingdir (current-directory)) 568 (let* ((startingdir (current-directory)) ................................................................................................................................................................................ 614 (teststep-set-status! db run-id test-name stepname "end" exi 633 (teststep-set-status! db run-id test-name stepname "end" exi 615 (sqlite3:finalize! db) 634 (sqlite3:finalize! db) 616 (if (not (eq? exitstat 0)) 635 (if (not (eq? exitstat 0)) 617 (exit 254)) ;; (exit exitstat) doesn't work?!? 636 (exit 254)) ;; (exit exitstat) doesn't work?!? 618 ;; open the db 637 ;; open the db 619 ;; mark the end of the test 638 ;; mark the end of the test 620 ))) 639 ))) 621 (if (args:get-arg "-test-status") | 640 (if (or (args:get-arg "-test-status") > 641 (args:get-arg "-set-values")) 622 (let ((newstatus (cond 642 (let ((newstatus (cond 623 ((number? status) (if (equal? status 0) "P 643 ((number? status) (if (equal? status 0) "P > 644 ((and (string? status) 624 ((string->number status)(if (equal? (string->num | 645 (string->number status))(if (equal? (strin 625 (else status)))) | 646 (else status))) 626 (test-set-status! db run-id test-name state newstatus itemdat (a < 627 (if (and state status) | 647 ;; transfer relevant keys into a hash to be passed to test-s > 648 ;; could use an assoc list I guess. > 649 (otherdata (let ((res (make-hash-table))) > 650 (for-each (lambda (key) 628 (if (not (args:get-arg "-setlog")) | 651 (if (args:get-arg key) > 652 (hash-table-set! res key (args: > 653 (list ":value" ":tol" ":expected_valu > 654 res))) > 655 (if (and (args:get-arg "-test-status") > 656 (or (not state) > 657 (not status))) 629 (begin | 658 (begin 630 (debug:print 0 "ERROR: You must specify :state and :stat | 659 (debug:print 0 "ERROR: You must specify :state and :status 631 (sqlite3:finalize! db) | 660 (sqlite3:finalize! db) 632 (exit 6))))) | 661 (exit 6))) > 662 (test-set-status! db run-id test-name state newstatus itemdat (a 633 (sqlite3:finalize! db) 663 (sqlite3:finalize! db) 634 (set! *didsomething* #t)))) 664 (set! *didsomething* #t)))) 635 665 636 (if (args:get-arg "-showkeys") 666 (if (args:get-arg "-showkeys") 637 (let ((db #f) 667 (let ((db #f) 638 (keys #f)) 668 (keys #f)) 639 (if (not (setup-for-run)) 669 (if (not (setup-for-run)) ................................................................................................................................................................................ 663 (debug:print 0 "Failed to setup, exiting") 693 (debug:print 0 "Failed to setup, exiting") 664 (exit 1))) 694 (exit 1))) 665 ;; now can find our db 695 ;; now can find our db 666 (set! db (open-db)) 696 (set! db (open-db)) 667 (patch-db db) 697 (patch-db db) 668 (sqlite3:finalize! db) 698 (sqlite3:finalize! db) 669 (set! *didsomething* #t))) 699 (set! *didsomething* #t))) > 700 > 701 ;;====================================================================== > 702 ;; Update the tests meta data from the testconfig files > 703 ;; > 704 > 705 (if (args:get-arg "-update-meta") > 706 (begin > 707 (if (not (setup-for-run)) > 708 (begin > 709 (debug:print 0 "Failed to setup, exiting") > 710 (exit 1))) > 711 ;; now can find our db > 712 (set! db (open-db)) > 713 (runs:update-all-test_meta db) > 714 (sqlite3:finalize! db) > 715 (set! *didsomething* #t))) 670 716 671 (if (not *didsomething*) 717 (if (not *didsomething*) 672 (debug:print 0 help)) 718 (debug:print 0 help)) 673 719 674 (if (not (eq? *globalexitstatus* 0)) 720 (if (not (eq? *globalexitstatus* 0)) 675 (if (or (args:get-arg "-runtests")(args:get-arg "-runall")) 721 (if (or (args:get-arg "-runtests")(args:get-arg "-runall")) 676 (begin 722 (begin

Modified runconfig.scm from [1140c67c4203134a] to [4dece87b4e3289ec].

2 ;; read a config file, loading only the section pertinent 2 ;; read a config file, loading only the section pertinent 3 ;; to this run field1val/field2val/field3val ... 3 ;; to this run field1val/field2val/field3val ... 4 ;;====================================================================== 4 ;;====================================================================== 5 (define (setup-env-defaults db fname run-id . already-seen) 5 (define (setup-env-defaults db fname run-id . already-seen) 6 (let* ((keys (get-keys db)) 6 (let* ((keys (get-keys db)) 7 (keyvals (get-key-vals db run-id)) 7 (keyvals (get-key-vals db run-id)) 8 (thekey (string-intersperse (map (lambda (x)(if x x "-na-")) keyvals) 8 (thekey (string-intersperse (map (lambda (x)(if x x "-na-")) keyvals) 9 (confdat (read-config fname)) | 9 (confdat (read-config fname #f #f)) 10 (whatfound (make-hash-table)) 10 (whatfound (make-hash-table)) 11 (sections (list "default" thekey))) 11 (sections (list "default" thekey))) 12 (debug:print 4 "Using key=\"" thekey "\"") 12 (debug:print 4 "Using key=\"" thekey "\"") 13 (for-each 13 (for-each 14 (lambda (section) 14 (lambda (section) 15 (let ((section-dat (hash-table-ref/default confdat section #f))) 15 (let ((section-dat (hash-table-ref/default confdat section #f))) 16 (if section-dat 16 (if section-dat

Modified runs.scm from [a71e17f8a888b3e2] to [0a86a73c3e24ba49].

71 (lambda (a . r) 71 (lambda (a . r) 72 (set! res (cons (list->vector (cons a r)) res))) 72 (set! res (cons (list->vector (cons a r)) res))) 73 db 73 db 74 (conc "SELECT " keystr " FROM runs WHERE runname like ? " key-patt ";") 74 (conc "SELECT " keystr " FROM runs WHERE runname like ? " key-patt ";") 75 runnamepatt) 75 runnamepatt) 76 (vector header res))) 76 (vector header res))) 77 77 78 (define (register-test db run-id test-name item-path tags) | 78 (define (register-test db run-id test-name item-path) 79 (let ((item-paths (if (equal? item-path "") 79 (let ((item-paths (if (equal? item-path "") 80 (list item-path) 80 (list item-path) 81 (list item-path "")))) 81 (list item-path "")))) 82 (for-each 82 (for-each 83 (lambda (pth) 83 (lambda (pth) 84 (sqlite3:execute db "INSERT OR IGNORE INTO tests (run_id,testname,event_t | 84 (sqlite3:execute db "INSERT OR IGNORE INTO tests (run_id,testname,event_t 85 run-id 85 run-id 86 test-name 86 test-name 87 pth 87 pth 88 (conc "," (string-intersperse tags ",") ","))) | 88 ;; (conc "," (string-intersperse tags ",") ",") > 89 )) 89 item-paths ))) 90 item-paths ))) 90 91 91 ;; (define db (open-db)) 92 ;; (define db (open-db)) 92 ;; (test-set-status! db 2 "runfirst" "COMPLETED" "PASS" "summer") 93 ;; (test-set-status! db 2 "runfirst" "COMPLETED" "PASS" "summer") 93 94 94 (define (test-set-status! db run-id test-name state status itemdat-or-path . com | 95 (define (test-set-status! db run-id test-name state status itemdat-or-path comme 95 (let ((item-path (if (string? itemdat-or-path) itemdat-or-path (item-list->pat | 96 (let ((item-path (if (string? itemdat-or-path) itemdat-or-path (item-list->pat > 97 (otherdat (if dat dat (make-hash-table)))) > 98 ;; update the primary record IF state AND status are defined > 99 (if (and state status) 96 (sqlite3:execute db "UPDATE tests SET state=?,status=?,event_time=strftime(' | 100 (sqlite3:execute db "UPDATE tests SET state=?,status=?,event_time=strfti 97 state status run-id test-name item-path) | 101 state status run-id test-name item-path)) > 102 ;; add metadata (need to do this way to avoid SQL injection issues) > 103 ;; :value > 104 (let ((val (hash-table-ref/default otherdat ":value" #f))) > 105 (if val > 106 (sqlite3:execute db "UPDATE tests SET value=? WHERE run_id=? AND testn > 107 ;; :expected_value > 108 (let ((val (hash-table-ref/default otherdat ":expected_value" #f))) > 109 (if val > 110 (sqlite3:execute db "UPDATE tests SET expected_value=? WHERE run_id=? > 111 ;; :tol > 112 (let ((val (hash-table-ref/default otherdat ":tol" #f))) > 113 (if val > 114 (sqlite3:execute db "UPDATE tests SET tol=? WHERE run_id=? AND testnam > 115 ;; :first_err > 116 (let ((val (hash-table-ref/default otherdat ":first_err" #f))) > 117 (if val > 118 (sqlite3:execute db "UPDATE tests SET first_err=? WHERE run_id=? AND t > 119 ;; :first_warn > 120 (let ((val (hash-table-ref/default otherdat ":first_warn" #f))) > 121 (if val > 122 (sqlite3:execute db "UPDATE tests SET first_warn=? WHERE run_id=? AND > 123 ;; :tol_perc > 124 (let ((val (hash-table-ref/default otherdat ":tol_perc" #f))) > 125 (if val > 126 (sqlite3:execute db "UPDATE tests SET tol_perc=? WHERE run_id=? AND te > 127 98 (if (and (not (equal? item-path "")) ;; need to update the top test record i | 128 ;; need to update the top test record if PASS or FAIL and this is a subtest > 129 (if (and (not (equal? item-path "")) 99 (or (equal? status "PASS") 130 (or (equal? status "PASS") 100 (equal? status "WARN") 131 (equal? status "WARN") 101 (equal? status "FAIL"))) 132 (equal? status "FAIL"))) 102 (begin 133 (begin 103 (sqlite3:execute 134 (sqlite3:execute 104 db 135 db 105 "UPDATE tests 136 "UPDATE tests ................................................................................................................................................................................ 112 "UPDATE tests 143 "UPDATE tests 113 SET state=CASE WHEN (SELECT count(id) FROM tests WHERE run_id=? AND 144 SET state=CASE WHEN (SELECT count(id) FROM tests WHERE run_id=? AND 114 'RUNNING' 145 'RUNNING' 115 ELSE 'COMPLETED' END, 146 ELSE 'COMPLETED' END, 116 status=CASE WHEN fail_count > 0 THEN 'FAIL' WHEN pass_count > 0 147 status=CASE WHEN fail_count > 0 THEN 'FAIL' WHEN pass_count > 0 117 WHERE run_id=? AND testname=? AND item_path='';" 148 WHERE run_id=? AND testname=? AND item_path='';" 118 run-id test-name run-id test-name))) 149 run-id test-name run-id test-name))) 119 (if (and (not (null? comment)) | 150 (if (and (string? comment) 120 (car comment)) | 151 (string-match (regexp "\\S+") comment)) 121 (sqlite3:execute db "UPDATE tests SET comment=? WHERE run_id=? AND testn 152 (sqlite3:execute db "UPDATE tests SET comment=? WHERE run_id=? AND testn 122 (car comment) run-id test-name item-path)))) | 153 (car comment) run-id test-name item-path)) > 154 )) 123 155 124 (define (test-set-log! db run-id test-name itemdat logf) 156 (define (test-set-log! db run-id test-name itemdat logf) 125 (let ((item-path (item-list->path itemdat))) 157 (let ((item-path (item-list->path itemdat))) 126 (sqlite3:execute db "UPDATE tests SET final_logf=? WHERE run_id=? AND testna 158 (sqlite3:execute db "UPDATE tests SET final_logf=? WHERE run_id=? AND testna 127 logf run-id test-name item-path))) 159 logf run-id test-name item-path))) 128 160 129 (define (test-set-toplog! db run-id test-name logf) 161 (define (test-set-toplog! db run-id test-name logf) ................................................................................................................................................................................ 398 (setenv "MT_TEST_NAME" test-name) ;; 430 (setenv "MT_TEST_NAME" test-name) ;; 399 (setenv "MT_RUNNAME" (args:get-arg ":runname")) 431 (setenv "MT_RUNNAME" (args:get-arg ":runname")) 400 (set-megatest-env-vars db run-id) ;; these may be needed by the launching proc 432 (set-megatest-env-vars db run-id) ;; these may be needed by the launching proc 401 (change-directory *toppath*) 433 (change-directory *toppath*) 402 (let* ((test-path (conc *toppath* "/tests/" test-name)) 434 (let* ((test-path (conc *toppath* "/tests/" test-name)) 403 (test-configf (conc test-path "/testconfig")) 435 (test-configf (conc test-path "/testconfig")) 404 (testexists (and (file-exists? test-configf)(file-read-access? test-c 436 (testexists (and (file-exists? test-configf)(file-read-access? test-c 405 (test-conf (if testexists (read-config test-configf) (make-hash-tabl | 437 (test-conf (if testexists (read-config test-configf #f #t) (make-has 406 (waiton (let ((w (config-lookup test-conf "requirements" "waiton" 438 (waiton (let ((w (config-lookup test-conf "requirements" "waiton" 407 (if (string? w)(string-split w)'()))) 439 (if (string? w)(string-split w)'()))) 408 (tags (let ((t (config-lookup test-conf "setup" "tags"))) 440 (tags (let ((t (config-lookup test-conf "setup" "tags"))) > 441 ;; we want our tags to be separated by commas and fully > 442 ;; so that queries with "like" can tie to the commas at > 443 ;; while also allowing the end user to freely use space 409 (if (string? t)(string-split t ",") '())))) | 444 (if (string? t)(string-substitute (regexp "[,\\s]+") ", > 445 '())))) 410 (if (not testexists) 446 (if (not testexists) 411 (begin 447 (begin 412 (debug:print 0 "ERROR: Can't find config file " test-configf) 448 (debug:print 0 "ERROR: Can't find config file " test-configf) 413 (exit 2)) 449 (exit 2)) 414 ;; put top vars into convenient variables and open the db 450 ;; put top vars into convenient variables and open the db 415 (let* (;; db is always at *toppath*/db/megatest.db 451 (let* (;; db is always at *toppath*/db/megatest.db 416 (items (hash-table-ref/default test-conf "items" '())) 452 (items (hash-table-ref/default test-conf "items" '())) ................................................................................................................................................................................ 426 (begin 462 (begin 427 (print "items: ")(pp (item-assoc->item-list items)) 463 (print "items: ")(pp (item-assoc->item-list items)) 428 (print "itestable: ")(pp (item-table->item-list itemstable)))) 464 (print "itestable: ")(pp (item-table->item-list itemstable)))) 429 (if (args:get-arg "-m") 465 (if (args:get-arg "-m") 430 (db:set-comment-for-run db run-id (args:get-arg "-m"))) 466 (db:set-comment-for-run db run-id (args:get-arg "-m"))) 431 467 432 ;; Here is where the test_meta table is best updated 468 ;; Here is where the test_meta table is best updated 433 (let ((currrecord (db:testmeta-get-record db test-name))) | 469 (runs:update-test_meta db test-name test-conf) 434 (if (not currrecord) < 435 (begin < 436 (set! currrecord (make-vector 10 #f)) < 437 (db:testmeta-add-record db test-name))) < 438 (for-each < 439 (lambda (key) < 440 (let* ((idx (cadr key)) < 441 (fld (car key)) < 442 (val (config-lookup test-conf "test_meta" fld))) < 443 (if (and val (not (equal? (vector-ref currrecord idx) val))) < 444 (begin < 445 (print "Updating " test-name " " fld " to " val) < 446 (db:testmeta-update-field db test-name fld val))))) < 447 '(("author" 2)("owner" 3)("description" 4)("reviewed" 5)("tags" 9)) < 448 470 449 ;; braindead work-around for poorly specified allitems list BUG!!! FIX 471 ;; braindead work-around for poorly specified allitems list BUG!!! FIX 450 (if (null? allitems)(set! allitems '(()))) 472 (if (null? allitems)(set! allitems '(()))) 451 (let loop ((itemdat (car allitems)) 473 (let loop ((itemdat (car allitems)) 452 (tal (cdr allitems))) 474 (tal (cdr allitems))) 453 ;; (lambda (itemdat) ;;; ((ripeness "overripe") (temperature "cool") 475 ;; (lambda (itemdat) ;;; ((ripeness "overripe") (temperature "cool") 454 ;; Handle lists of items 476 ;; Handle lists of items ................................................................................................................................................................................ 465 (if (runs:can-run-more-tests db) 487 (if (runs:can-run-more-tests db) 466 (begin 488 (begin 467 (let loop2 ((ts (db:get-test-info db run-id test-name item-p 489 (let loop2 ((ts (db:get-test-info db run-id test-name item-p 468 (ct 0)) 490 (ct 0)) 469 (if (and (not ts) 491 (if (and (not ts) 470 (< ct 10)) 492 (< ct 10)) 471 (begin 493 (begin 472 (register-test db run-id test-name item-path tags) | 494 (register-test db run-id test-name item-path) 473 (db:test-set-comment db run-id test-name item-path " 495 (db:test-set-comment db run-id test-name item-path " 474 (loop2 (db:get-test-info db run-id test-name item-pa 496 (loop2 (db:get-test-info db run-id test-name item-pa 475 (+ ct 1))) 497 (+ ct 1))) 476 (if ts 498 (if ts 477 (set! testdat ts) 499 (set! testdat ts) 478 (begin 500 (begin 479 (debug:print 0 "WARNING: Couldn't register test 501 (debug:print 0 "WARNING: Couldn't register test ................................................................................................................................................................................ 679 ;; here then call proc 701 ;; here then call proc 680 (let* ((keys (db-get-keys db)) 702 (let* ((keys (db-get-keys db)) 681 (keynames (map key:get-fieldname keys)) 703 (keynames (map key:get-fieldname keys)) 682 (keyvallst (keys->vallist keys #t))) 704 (keyvallst (keys->vallist keys #t))) 683 (proc db keys keynames keyvallst))) 705 (proc db keys keynames keyvallst))) 684 (sqlite3:finalize! db) 706 (sqlite3:finalize! db) 685 (set! *didsomething* #t)))) 707 (set! *didsomething* #t)))) > 708 > 709 ;;====================================================================== > 710 ;; Rollup runs > 711 ;;====================================================================== > 712 > 713 ;; Update the test_meta table for this test > 714 (define (runs:update-test_meta db test-name test-conf) > 715 (let ((currrecord (db:testmeta-get-record db test-name))) > 716 (if (not currrecord) > 717 (begin > 718 (set! currrecord (make-vector 10 #f)) > 719 (db:testmeta-add-record db test-name))) > 720 (for-each > 721 (lambda (key) > 722 (let* ((idx (cadr key)) > 723 (fld (car key)) > 724 (val (config-lookup test-conf "test_meta" fld))) > 725 (if (and val (not (equal? (vector-ref currrecord idx) val))) > 726 (begin > 727 (print "Updating " test-name " " fld " to " val) > 728 (db:testmeta-update-field db test-name fld val))))) > 729 '(("author" 2)("owner" 3)("description" 4)("reviewed" 5)("tags" 9))))) > 730 > 731 ;; Update test_meta for all tests > 732 (define (runs:update-all-test_meta db) > 733 (let ((test-names (get-all-legal-tests))) > 734 (for-each > 735 (lambda (test-name) > 736 (let* ((test-path (conc *toppath* "/tests/" test-name)) > 737 (test-configf (conc test-path "/testconfig")) > 738 (testexists (and (file-exists? test-configf)(file-read-access? t > 739 ;; read configs with tricks turned off (i.e. no system) > 740 (test-conf (if testexists (read-config test-configf #f #f)(make > 741 (runs:update-test_meta db test-name test-conf))) > 742 test-names))) 686 743 687 (define (runs:rollup-run db keys keynames keyvallst n) 744 (define (runs:rollup-run db keys keynames keyvallst n) 688 (let* ((new-run-id (register-run db keys)) 745 (let* ((new-run-id (register-run db keys)) 689 (similar-runs (db:get-similar-runs db keys)) | 746 (similar-runs (db:get-runs db keys)) 690 (tests-n-days (db:get-tests-n-days db similar-runs))) 747 (tests-n-days (db:get-tests-n-days db similar-runs))) 691 (for-each 748 (for-each 692 (lambda (test-id) 749 (lambda (test-id) 693 (db:rollup-test db run-id test-id)) 750 (db:rollup-test db run-id test-id)) 694 tests-n-days))) 751 tests-n-days)))

Modified tests/tests.scm from [8fcf733fb42e7db6] to [197f4966586634a0].

8 (include "../process.scm") 8 (include "../process.scm") 9 (include "../launch.scm") 9 (include "../launch.scm") 10 (include "../items.scm") 10 (include "../items.scm") 11 (include "../runs.scm") 11 (include "../runs.scm") 12 (include "../megatest-version.scm") 12 (include "../megatest-version.scm") 13 13 14 (define conffile #f) 14 (define conffile #f) 15 (test "Read a config" #t (hash-table? (read-config "test.config"))) | 15 (test "Read a config" #t (hash-table? (read-config "test.config" #f #f))) 16 (test "Read a config that doesn't exist" #t (hash-table? (read-config "nada.conf | 16 (test "Read a config that doesn't exist" #t (hash-table? (read-config "nada.conf 17 17 18 (set! conffile (read-config "test.config")) | 18 (set! conffile (read-config "test.config" #f #f)) 19 (test "Get available diskspace" #t (number? (get-df "./"))) 19 (test "Get available diskspace" #t (number? (get-df "./"))) 20 (test "Get best dir" #t (let ((bestdir (get-best-disk conffile))) 20 (test "Get best dir" #t (let ((bestdir (get-best-disk conffile))) 21 (or (equal? "./" bestdir) 21 (or (equal? "./" bestdir) 22 (equal? "/tmp" bestdir)))) 22 (equal? "/tmp" bestdir)))) 23 (test "Multiline variable" 4 (length (string-split (config-lookup conffile "meta 23 (test "Multiline variable" 4 (length (string-split (config-lookup conffile "meta 24 24 25 ;; db 25 ;; db

Modified tests/tests/runfirst/main.sh from [f575e06d2a25eb06] to [b033ad6b4d30ad16].

4 # sleep 20 4 # sleep 20 5 # megatest -step wasting_time :state end :status $? 5 # megatest -step wasting_time :state end :status $? 6 6 7 touch ../I_was_here 7 touch ../I_was_here 8 8 9 $MT_MEGATEST -runstep wasting_time -logpro wasting_time.logpro "sleep 8;echo all 9 $MT_MEGATEST -runstep wasting_time -logpro wasting_time.logpro "sleep 8;echo all 10 10 11 $MT_MEGATEST -test-status :state COMPLETED :status $? -m "This is a test level c | 11 $MT_MEGATEST -test-status :state COMPLETED :status $? -m "This is a test level c

Modified tests/tests/singletest/main.sh from [c23e537bd9ea1937] to [e63ffb76fadbc087].

2 2 3 # megatest -step wasting_time :state start :status n/a -m "This is a test step c 3 # megatest -step wasting_time :state start :status n/a -m "This is a test step c 4 # sleep 20 4 # sleep 20 5 # megatest -step wasting_time :state end :status $? 5 # megatest -step wasting_time :state end :status $? 6 6 7 $MT_MEGATEST -runstep wasting_time -logpro wasting_time.logpro "sleep 5;echo all 7 $MT_MEGATEST -runstep wasting_time -logpro wasting_time.logpro "sleep 5;echo all 8 8 9 $MT_MEGATEST -test-status :state COMPLETED :status $? -m "This is a test level c | 9 $MT_MEGATEST -test-status :state COMPLETED :status $? -m "This is a test level c

Modified tests/tests/singletest2/main.sh from [c23e537bd9ea1937] to [54d3e4ef494bd371].

2 2 3 # megatest -step wasting_time :state start :status n/a -m "This is a test step c 3 # megatest -step wasting_time :state start :status n/a -m "This is a test step c 4 # sleep 20 4 # sleep 20 5 # megatest -step wasting_time :state end :status $? 5 # megatest -step wasting_time :state end :status $? 6 6 7 $MT_MEGATEST -runstep wasting_time -logpro wasting_time.logpro "sleep 5;echo all 7 $MT_MEGATEST -runstep wasting_time -logpro wasting_time.logpro "sleep 5;echo all 8 8 9 $MT_MEGATEST -test-status :state COMPLETED :status $? -m "This is a test level c | 9 $MT_MEGATEST -test-status :state COMPLETED :status $? -m "This is a test level c