Overview
Comment: | Rollup runs, clean up tests |
---|---|
Downloads: | Tarball | ZIP archive | SQL archive |
Timelines: | family | ancestors | descendants | both | rollup-runs |
Files: | files | file ages | folders |
SHA1: |
3e4d4b90274334b3bd2d20a7a1073759 |
User & Date: | mrwellan on 2011-08-10 21:57:40 |
Other Links: | branch diff | manifest | tags |
Context
2011-08-11
| ||
00:53 | Added test_meta data populating check-in: 5cecd7e1d4 user: matt tags: rollup-runs | |
2011-08-10
| ||
21:57 | Rollup runs, clean up tests check-in: 3e4d4b9027 user: mrwellan tags: rollup-runs | |
2011-08-08
| ||
23:24 | Minor refactoring of run code. check-in: f8f7968767 user: mrwellan tags: rollup-runs | |
Changes
Modified Makefile from [6bee1e6a16] to [6c62140a06].
︙ | ︙ | |||
12 13 14 15 16 17 18 | cp megatest $(PREFIX)/bin/megatest $(PREFIX)/bin/dashboard : dashboard cp dashboard $(PREFIX)/bin/dashboard install : $(PREFIX)/bin/megatest $(PREFIX)/bin/dashboard | | | 12 13 14 15 16 17 18 19 20 21 | cp megatest $(PREFIX)/bin/megatest $(PREFIX)/bin/dashboard : dashboard cp dashboard $(PREFIX)/bin/dashboard install : $(PREFIX)/bin/megatest $(PREFIX)/bin/dashboard test: tests/tests.scm cd tests;csi -I .. -b -n tests.scm |
Modified configf.scm from [50f8f33c26] to [9fba368c47].
︙ | ︙ | |||
23 24 25 26 27 28 29 | (list path fullpath configname) (let ((remcwd (take dir (- (length dir) 1)))) (if (null? remcwd) (list #f #f #f) ;; #f #f) (loop remcwd)))))))) (define (config:assoc-safe-add alist key val) | | | | > | > > | | | | | > > > > > > > > > > | > > > | > > | 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 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 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 | (list path fullpath configname) (let ((remcwd (take dir (- (length dir) 1)))) (if (null? remcwd) (list #f #f #f) ;; #f #f) (loop remcwd)))))))) (define (config:assoc-safe-add alist key val) (let ((newalist (filter (lambda (x)(not (equal? key (car x)))) alist))) (append newalist (list (list key val))))) ;; read a config file, returns two level hierarchial hash-table, ;; adds to ht if given (must be #f otherwise) (define (read-config path . ht) (if (not (file-exists? path)) (if (null? ht)(make-hash-table) (car ht)) (let ((inp (open-input-file path)) (res (if (null? ht)(make-hash-table)(car ht))) (include-rx (regexp "^\\[include\\s+(.*)\\]\\s*$")) (section-rx (regexp "^\\[(.*)\\]\\s*$")) (blank-l-rx (regexp "^\\s*$")) (key-sys-pr (regexp "^(\\S+)\\s+\\[system\\s+(\\S+.*)\\]\\s*$")) (key-val-pr (regexp "^(\\S+)\\s+(.*)$")) (comment-rx (regexp "^\\s*#.*")) (cont-ln-rx (regexp "^(\\s+)(\\S+.*)$"))) (let loop ((inl (read-line inp)) (curr-section-name "default") (var-flag #f);; turn on for key-var-pr and cont-ln-rx, turn off elsewhere (lead #f)) (if (eof-object? inl) (begin (close-input-port inp) res) (regex-case inl (comment-rx _ (loop (read-line inp) curr-section-name #f #f)) (blank-l-rx _ (loop (read-line inp) curr-section-name #f #f)) (include-rx ( x include-file ) (begin (read-config include-file res) (loop (read-line inp) curr-section-name #f #f))) (section-rx ( x section-name ) (loop (read-line inp) section-name #f #f)) (key-sys-pr ( x key cmd ) (let ((alist (hash-table-ref/default res curr-section-name '())) (val (let* ((cmdres (cmd-run->list cmd)) (status (cadr cmdres)) (res (car cmdres))) (if (not (eq? status 0)) (begin (debug:print 0 "ERROR: problem with " inl ", return code " status) (exit 1))) (if (null? res) "" (string-intersperse res " "))))) (hash-table-set! res curr-section-name (config:assoc-safe-add alist key val)) ;; (append alist (list (list key val)))) (loop (read-line inp) curr-section-name #f #f))) (key-val-pr ( x key val ) (let ((alist (hash-table-ref/default res curr-section-name '()))) (hash-table-set! res curr-section-name (config:assoc-safe-add alist key val)) (loop (read-line inp) curr-section-name key #f))) ;; if a continued line (cont-ln-rx ( x whsp val ) (let ((alist (hash-table-ref/default res curr-section-name '()))) (if var-flag ;; if set to a string then we have a continued var (let ((newval (conc (config-lookup res curr-section-name var-flag) "\n" ;; trim lead from the incoming whsp to support some indenting. (if lead (string-substitute (regexp lead) "" whsp) "") val))) (print "val: " val "\nnewval: \"" newval "\"\nvarflag: " var-flag) (hash-table-set! res curr-section-name (config:assoc-safe-add alist var-flag newval)) (loop (read-line inp) curr-section-name var-flag (if lead lead whsp))) (loop (read-line inp) curr-section-name #f #f)))) (else (debug:print 0 "ERROR: problem parsing " path ",\n \"" inl "\"") (set! var-flag #f) (loop (read-line inp) curr-section-name)))))))) (define (find-and-read-config fname) (let* ((curr-dir (current-directory)) (configinfo (find-config fname)) (toppath (car configinfo)) (configfile (cadr configinfo))) |
︙ | ︙ |
Modified db.scm from [6e2b657ab8] to [b3bfe37375].
︙ | ︙ | |||
77 78 79 80 81 82 83 | status TEXT DEFAULT 'n/a',event_time TIMESTAMP, comment TEXT DEFAULT '', CONSTRAINT test_steps_constraint UNIQUE (test_id,stepname,state));") (sqlite3:execute db "CREATE TABLE extradat (id INTEGER PRIMARY KEY, run_id INTEGER, key TEXT, val TEXT);") (sqlite3:execute db "CREATE TABLE metadat (id INTEGER PRIMARY KEY, var TEXT, val TEXT, CONSTRAINT metadat_constraint UNIQUE (id,var));") (db:set-var db "MEGATEST_VERSION" megatest-version) | | > > > > > > > > > > > > | | 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 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 | status TEXT DEFAULT 'n/a',event_time TIMESTAMP, comment TEXT DEFAULT '', CONSTRAINT test_steps_constraint UNIQUE (test_id,stepname,state));") (sqlite3:execute db "CREATE TABLE extradat (id INTEGER PRIMARY KEY, run_id INTEGER, key TEXT, val TEXT);") (sqlite3:execute db "CREATE TABLE metadat (id INTEGER PRIMARY KEY, var TEXT, val TEXT, CONSTRAINT metadat_constraint UNIQUE (id,var));") (db:set-var db "MEGATEST_VERSION" megatest-version) (sqlite3:execute db "CREATE TABLE access_log (id INTEGER PRIMARY KEY, user TEXT, accessed TIMESTAMP, args TEXT);") (sqlite3:execute db "CREATE TABLE test_meta (id INTEGER PRIMARY KEY, testname TEXT DEFAULT '', author TEXT DEFAULT '', owner TEXT DEFAULT '', description TEXT DEFAULT '', reviewed TIMESTAMP, iterated TEXT DEFAULT '', avg_runtime REAL, avg_disk REAL, CONSTRAINT test_meta_contstraint UNIQUE (id,testname));") )) db)) ;;====================================================================== ;; TODO: ;; put deltas into an assoc list with version numbers ;; apply all from last to current ;;====================================================================== (define (patch-db db) (handle-exceptions exn (begin (print "Exception: " exn) (print "ERROR: Possible out of date schema, attempting to add table metadata...") (sqlite3:execute db "CREATE TABLE metadat (id INTEGER PRIMARY KEY, var TEXT, val TEXT, CONSTRAINT metadat_constraint UNIQUE (id,var));") (sqlite3:execute db "ALTER TABLE tests ADD COLUMN tags TEXT DEFAULT '';") (db:set-var db "MEGATEST_VERSION" 1.17) ) (let ((mver (db:get-var db "MEGATEST_VERSION"))) (if (not mver) (begin (print "Adding megatest-version to metadata") (sqlite3:execute db (db:set-var db "MEGATEST_VERSION" megatest-version)))) (if (< mver 1.18) (begin (print "Adding tags column to tests table") (sqlite3:execute db "ALTER TABLE tests ADD COLUMN tags TEXT DEFAULT '';"))) |
︙ | ︙ |
Modified megatest.scm from [8ae7c5dabf] to [8f3220a6de].
︙ | ︙ | |||
300 301 302 303 304 305 306 | ;; started and completed ;; - step started, timestamp ;; - step completed, exit status, timestamp ;; 6. test phone home ;; - if test run time > allowed run time then kill job ;; - if cannot access db > allowed disconnect time then kill job | | < < < < | 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 | ;; started and completed ;; - step started, timestamp ;; - step completed, exit status, timestamp ;; 6. test phone home ;; - if test run time > allowed run time then kill job ;; - if cannot access db > allowed disconnect time then kill job (if (args:get-arg "-runtests") (general-run-call "-runtests" "run a test" (lambda (db keys keynames keyvallst) (let ((test-names (string-split (args:get-arg "-runtests") ","))) (run-tests db test-names))))) ;;====================================================================== ;; execute the test ;; - gets called on remote host ;; - receives info from the -execute param ;; - passes info to steps via MT_CMDINFO env var (future is to use a dot file) ;; - gathers host info and ;;====================================================================== |
︙ | ︙ |
Modified runs.scm from [b9d0916f14] to [4f776d58bd].
︙ | ︙ | |||
424 425 426 427 428 429 430 431 432 433 434 435 436 437 | (if (>= *verbosity* 1)(pp allitems)) (if (>= *verbosity* 5) (begin (print "items: ")(pp (item-assoc->item-list items)) (print "itestable: ")(pp (item-table->item-list itemstable)))) (if (args:get-arg "-m") (db:set-comment-for-run db run-id (args:get-arg "-m"))) ;; braindead work-around for poorly specified allitems list BUG!!! FIXME (if (null? allitems)(set! allitems '(()))) (let loop ((itemdat (car allitems)) (tal (cdr allitems))) ;; (lambda (itemdat) ;;; ((ripeness "overripe") (temperature "cool") (season "summer")) ;; Handle lists of items (let* ((item-path (item-list->path itemdat)) ;; (string-intersperse (map cadr itemdat) "/")) | > > > > > > | 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 | (if (>= *verbosity* 1)(pp allitems)) (if (>= *verbosity* 5) (begin (print "items: ")(pp (item-assoc->item-list items)) (print "itestable: ")(pp (item-table->item-list itemstable)))) (if (args:get-arg "-m") (db:set-comment-for-run db run-id (args:get-arg "-m"))) ;; Here is where the test_meta table is best updated (for-each (lambda (key) (let ((val (config-lookup *configdat* "test_meta" key))) ;; braindead work-around for poorly specified allitems list BUG!!! FIXME (if (null? allitems)(set! allitems '(()))) (let loop ((itemdat (car allitems)) (tal (cdr allitems))) ;; (lambda (itemdat) ;;; ((ripeness "overripe") (temperature "cool") (season "summer")) ;; Handle lists of items (let* ((item-path (item-list->path itemdat)) ;; (string-intersperse (map cadr itemdat) "/")) |
︙ | ︙ |
Modified tests/test.config from [50c4aca439] to [5ec648d029].
︙ | ︙ | |||
15 16 17 18 19 20 21 | [include a file that doesn't exist] blah nada # now inlcude a file tha tdoes exist [include megatest.config] | > > > > > > > > > > | 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 | [include a file that doesn't exist] blah nada # now inlcude a file tha tdoes exist [include megatest.config] [metadata] description This is a multiline description. The leading whitespace is discarded irrespective of amount of indenting. This line is indented more. author matt lastreview never |
Modified tests/tests.scm from [51a14a8524] to [8fcf733fb4].
︙ | ︙ | |||
16 17 18 19 20 21 22 23 24 25 26 27 28 29 | (test "Read a config that doesn't exist" #t (hash-table? (read-config "nada.config"))) (set! conffile (read-config "test.config")) (test "Get available diskspace" #t (number? (get-df "./"))) (test "Get best dir" #t (let ((bestdir (get-best-disk conffile))) (or (equal? "./" bestdir) (equal? "/tmp" bestdir)))) ;; db (define row (vector "a" "b" "c" "blah")) (define header (list "col1" "col2" "col3" "col4")) (test "Get row by header" "blah" (db:get-value-by-header row header "col4")) ;; (define *toppath* "tests") | > | 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 | (test "Read a config that doesn't exist" #t (hash-table? (read-config "nada.config"))) (set! conffile (read-config "test.config")) (test "Get available diskspace" #t (number? (get-df "./"))) (test "Get best dir" #t (let ((bestdir (get-best-disk conffile))) (or (equal? "./" bestdir) (equal? "/tmp" bestdir)))) (test "Multiline variable" 4 (length (string-split (config-lookup conffile "metadata" "description") "\n"))) ;; db (define row (vector "a" "b" "c" "blah")) (define header (list "col1" "col2" "col3" "col4")) (test "Get row by header" "blah" (db:get-value-by-header row header "col4")) ;; (define *toppath* "tests") |
︙ | ︙ | |||
58 59 60 61 62 63 64 | (and (file-exists? "nada.sh") (file-exists? "nada.csh")))) (test "get all legal tests" (list "runfirst" "runwithfirst" "singletest" "singletest2" "sqlitespeed") (sort (get-all-legal-tests) string<=?)) (test "register-test, test info" "NOT_STARTED" (begin | | | 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 | (and (file-exists? "nada.sh") (file-exists? "nada.csh")))) (test "get all legal tests" (list "runfirst" "runwithfirst" "singletest" "singletest2" "sqlitespeed") (sort (get-all-legal-tests) string<=?)) (test "register-test, test info" "NOT_STARTED" (begin (register-test *db* 1 "nada" "" '("tag1" "tag2" "tag3")) (test:get-state (db:get-test-info *db* 1 "nada" "")))) (test "get-keys" "sysname" (key:get-fieldname (car (sort (db-get-keys *db*)(lambda (a b)(string>=? (vector-ref a 0)(vector-ref b 0))))))) (define remargs (args:get-args '("bar" "foo" ":runname" "bob" ":sysname" "ubuntu" ":fsname" "nfs" ":datapath" "blah/foo" "nada") (list ":runname" ":state" ":status") |
︙ | ︙ |
Modified tests/tests/runfirst/testconfig from [9a8e30b98e] to [f0b52bc3c6].
︙ | ︙ | |||
10 11 12 13 14 15 16 | [items] SEASON summer winter fall spring [itemstable] BLOCK a b TOCK 1 2 | > > > > > > > > | 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 | [items] SEASON summer winter fall spring [itemstable] BLOCK a b TOCK 1 2 [test_meta] author matt owner bob description This test must be run before the other tests tags first,single reviewed 1/1/1965 |