Overview
Comment: | Fixed compilation |
---|---|
Downloads: | Tarball | ZIP archive | SQL archive |
Timelines: | family | ancestors | descendants | both | reorg-runs-code |
Files: | files | file ages | folders |
SHA1: |
ddc42ef201342fe9c87e4f4c6a5b74e4 |
User & Date: | matt on 2011-11-20 22:39:35 |
Other Links: | branch diff | manifest | tags |
Context
2011-11-20
| ||
23:13 | Incrementally putting stuff back in place for re-written runs. check-in: a1e072dbd2 user: matt tags: reorg-runs-code | |
22:39 | Fixed compilation check-in: ddc42ef201 user: matt tags: reorg-runs-code | |
22:36 | commit of re-hacked run code. completely torn to shreds and rewritten check-in: 3aeabde95d user: matt tags: reorg-runs-code | |
Changes
Modified db.scm from [c39ab57eb7] to [97aae994b9].
︙ | ︙ | |||
36 37 38 39 40 41 42 | (let* ((keys (config-get-fields configdat)) (havekeys (> (length keys) 0)) (keystr (keys->keystr keys)) (fieldstr (keys->key/field keys))) (for-each (lambda (key) (let ((keyn (vector-ref key 0))) (if (member (string-downcase keyn) | | | | | | | | | | | | | | | | 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 | (let* ((keys (config-get-fields configdat)) (havekeys (> (length keys) 0)) (keystr (keys->keystr keys)) (fieldstr (keys->key/field keys))) (for-each (lambda (key) (let ((keyn (vector-ref key 0))) (if (member (string-downcase keyn) (list "runname" "state" "status" "owner" "event_time" "comment" "fail_count" "pass_count")) (begin (print "ERROR: your key cannot be named " keyn " as this conflicts with the same named field in the runs table") (system (conc "rm -f " dbpath)) (exit 1))))) keys) ;; (sqlite3:execute db "PRAGMA synchronous = OFF;") (sqlite3:execute db "CREATE TABLE IF NOT EXISTS keys (id INTEGER PRIMARY KEY, fieldname TEXT, fieldtype TEXT, CONSTRAINT keyconstraint UNIQUE (fieldname));") (for-each (lambda (key) (sqlite3:execute db "INSERT INTO keys (fieldname,fieldtype) VALUES (?,?);" (key:get-fieldname key)(key:get-fieldtype key))) keys) (sqlite3:execute db (conc "CREATE TABLE IF NOT EXISTS runs (id INTEGER PRIMARY KEY, " fieldstr (if havekeys "," "") "runname TEXT," "state TEXT DEFAULT ''," "status TEXT DEFAULT ''," "owner TEXT DEFAULT ''," "event_time TIMESTAMP," "comment TEXT DEFAULT ''," "fail_count INTEGER DEFAULT 0," "pass_count INTEGER DEFAULT 0," "CONSTRAINT runsconstraint UNIQUE (runname" (if havekeys "," "") keystr "));")) (sqlite3:execute db (conc "CREATE INDEX runs_index ON runs (runname" (if havekeys "," "") keystr ");")) (sqlite3:execute db "CREATE TABLE IF NOT EXISTS tests (id INTEGER PRIMARY KEY, run_id INTEGER, testname TEXT, host TEXT DEFAULT 'n/a', cpuload REAL DEFAULT -1, diskfree INTEGER DEFAULT -1, uname TEXT DEFAULT 'n/a', |
︙ | ︙ | |||
172 173 174 175 176 177 178 | (patch-db)) ((< mver 1.21) (sqlite3:execute db "DROP TABLE IF EXISTS metadat;") (sqlite3:execute db "CREATE TABLE IF NOT EXISTS metadat (id INTEGER, var TEXT, val TEXT, CONSTRAINT metadat_constraint UNIQUE (var));") (db:set-var db "MEGATEST_VERSION" 1.21) ;; set before, just in case the changes are already applied (sqlite3:execute db test-meta-def) | | | | | | | | | 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 | (patch-db)) ((< mver 1.21) (sqlite3:execute db "DROP TABLE IF EXISTS metadat;") (sqlite3:execute db "CREATE TABLE IF NOT EXISTS metadat (id INTEGER, var TEXT, val TEXT, CONSTRAINT metadat_constraint UNIQUE (var));") (db:set-var db "MEGATEST_VERSION" 1.21) ;; set before, just in case the changes are already applied (sqlite3:execute db test-meta-def) ;(for-each ; (lambda (stmt) ; (sqlite3:execute db stmt)) ; (list ; "ALTER TABLE tests ADD COLUMN first_err TEXT;" ; "ALTER TABLE tests ADD COLUMN first_warn TEXT;" ; )) (patch-db)) ((< mver 1.24) (db:set-var db "MEGATEST_VERSION" 1.24) (sqlite3:execute db "DROP TABLE IF EXISTS test_data;") (sqlite3:execute db "DROP TABLE IF EXISTS test_meta;") (sqlite3:execute db test-meta-def) (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_data (id INTEGER PRIMARY KEY, |
︙ | ︙ | |||
258 259 260 261 262 263 264 | (if (null? header) #f (let loop ((hed (car header)) (tal (cdr header)) (n 0)) (if (equal? hed field) (vector-ref row n) (if (null? tal) #f (loop (car tal)(cdr tal)(+ n 1))))))) | | | 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 | (if (null? header) #f (let loop ((hed (car header)) (tal (cdr header)) (n 0)) (if (equal? hed field) (vector-ref row n) (if (null? tal) #f (loop (car tal)(cdr tal)(+ n 1))))))) ;;====================================================================== ;; R U N S ;;====================================================================== (define (runs:get-std-run-fields keys remfields) (let* ((header (append (map key:get-fieldname keys) remfields)) |
︙ | ︙ | |||
365 366 367 368 369 370 371 | ;; states and statuses are required to be lists, empty is ok (define (db-get-tests-for-run db run-id testpatt itempatt states statuses) (let ((res '()) (states-str (conc "('" (string-intersperse states "','") "')")) (statuses-str (conc "('" (string-intersperse statuses "','") "')")) ) (sqlite3:for-each-row | | | | 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 | ;; states and statuses are required to be lists, empty is ok (define (db-get-tests-for-run db run-id testpatt itempatt states statuses) (let ((res '()) (states-str (conc "('" (string-intersperse states "','") "')")) (statuses-str (conc "('" (string-intersperse statuses "','") "')")) ) (sqlite3:for-each-row (lambda (a . b) ;; id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment) (set! res (cons (apply vector a b) res))) ;; id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment) res))) db (conc "SELECT id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment " " FROM tests WHERE run_id=? AND testname like ? AND item_path LIKE ? " " AND NOT (state in " states-str " AND status IN " statuses-str ") " ;; " ORDER BY id DESC;" " ORDER BY event_time ASC;" ;; POTENTIAL ISSUE! CHECK ME! Does anyting depend on this being sorted by id? ) |
︙ | ︙ | |||
395 396 397 398 399 400 401 | ;; set tests with state currstate and status currstatus to newstate and newstatus ;; use currstate = #f and or currstatus = #f to apply to any state or status respectively ;; WARNING: SQL injection risk (define (db:set-tests-state-status db run-id testnames currstate currstatus newstate newstatus) (for-each (lambda (testname) (let ((qry (conc "UPDATE tests SET state=?,status=? WHERE " | | | | | 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 | ;; set tests with state currstate and status currstatus to newstate and newstatus ;; use currstate = #f and or currstatus = #f to apply to any state or status respectively ;; WARNING: SQL injection risk (define (db:set-tests-state-status db run-id testnames currstate currstatus newstate newstatus) (for-each (lambda (testname) (let ((qry (conc "UPDATE tests SET state=?,status=? WHERE " (if currstate (conc "state='" currstate "' AND ") "") (if currstatus (conc "status='" currstatus "' AND ") "") " run_id=? AND testname=? AND NOT (item_path='' AND testname in (SELECT DISTINCT testname FROM tests WHERE testname=? AND item_path != ''));"))) ;;(debug:print 0 "QRY: " qry) (sqlite3:execute db qry run-id newstate newstatus testname testname))) testnames)) (define (db:delete-tests-in-state db run-id state) (sqlite3:execute db "DELETE FROM tests WHERE state=? AND run_id=?;" state run-id)) |
︙ | ︙ | |||
470 471 472 473 474 475 476 | res)) (define (db:test-set-comment db run-id testname item-path comment) (sqlite3:execute db "UPDATE tests SET comment=? WHERE run_id=? AND testname=? AND item_path=?;" | | | | 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 | res)) (define (db:test-set-comment db run-id testname item-path comment) (sqlite3:execute db "UPDATE tests SET comment=? WHERE run_id=? AND testname=? AND item_path=?;" comment run-id testname item-path)) ;; (define (db:test-set-rundir! db run-id testname item-path rundir) (sqlite3:execute db "UPDATE tests SET rundir=? WHERE run_id=? AND testname=? AND item_path=?;" rundir run-id testname item-path)) ;;====================================================================== ;; Tests meta data ;;====================================================================== ;; read the record given a testname (define (db:testmeta-get-record db testname) |
︙ | ︙ | |||
534 535 536 537 538 539 540 | (debug:print 4 "BEFORE: category: " category " variable: " variable " value: " value ", expected: " expected " tol: " tol " units: " units " status: " status " comment: " comment) (if (and (or (not expected)(equal? expected "")) (or (not tol) (equal? expected "")) (or (not units) (equal? expected ""))) (let-values (((new-expected new-tol new-units)(db:get-prev-tol-for-test db test-id category variable))) | | | | | 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 | (debug:print 4 "BEFORE: category: " category " variable: " variable " value: " value ", expected: " expected " tol: " tol " units: " units " status: " status " comment: " comment) (if (and (or (not expected)(equal? expected "")) (or (not tol) (equal? expected "")) (or (not units) (equal? expected ""))) (let-values (((new-expected new-tol new-units)(db:get-prev-tol-for-test db test-id category variable))) (set! expected new-expected) (set! tol new-tol) (set! units new-units))) (debug:print 4 "AFTER: category: " category " variable: " variable " value: " value ", expected: " expected " tol: " tol " units: " units " status: " status " comment: " comment) ;; calculate status if NOT specified (if (and (not status)(number? expected)(number? value)) ;; need expected and value to be numbers (if (number? tol) ;; if tol is a number then we do the standard comparison (let* ((max-val (+ expected tol)) |
︙ | ︙ | |||
558 559 560 561 562 563 564 | ((<) (if (< value expected) "pass" "fail")) ((>=) (if (>= value expected) "pass" "fail")) ((<=) (if (<= value expected) "pass" "fail")) (else (conc "ERROR: bad tol comparator " tol)))))) (debug:print 4 "AFTER2: category: " category " variable: " variable " value: " value ", expected: " expected " tol: " tol " units: " units " status: " status " comment: " comment) (sqlite3:execute db "INSERT OR REPLACE INTO test_data (test_id,category,variable,value,expected,tol,units,comment,status) VALUES (?,?,?,?,?,?,?,?,?);" | | | 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 | ((<) (if (< value expected) "pass" "fail")) ((>=) (if (>= value expected) "pass" "fail")) ((<=) (if (<= value expected) "pass" "fail")) (else (conc "ERROR: bad tol comparator " tol)))))) (debug:print 4 "AFTER2: category: " category " variable: " variable " value: " value ", expected: " expected " tol: " tol " units: " units " status: " status " comment: " comment) (sqlite3:execute db "INSERT OR REPLACE INTO test_data (test_id,category,variable,value,expected,tol,units,comment,status) VALUES (?,?,?,?,?,?,?,?,?);" test-id category variable value expected tol units (if comment comment "") status))) csvlist))) ;; get a list of test_data records matching categorypatt (define (db:read-test-data db test-id categorypatt) (let ((res '())) (sqlite3:for-each-row (lambda (id test_id category variable value expected tol units comment status) |
︙ | ︙ | |||
586 587 588 589 590 591 592 | (if (not (eof-object? lin)) (begin (debug:print 4 lin) (db:csv->test-data db test-id lin) (loop (read-line)))))) ;; roll up the current results. (db:test-data-rollup db test-id))) | | | 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 | (if (not (eof-object? lin)) (begin (debug:print 4 lin) (db:csv->test-data db test-id lin) (loop (read-line)))))) ;; roll up the current results. (db:test-data-rollup db test-id))) ;; WARNING: Do NOT call this for the parent test on an iterated test ;; Roll up test_data pass/fail results ;; look at the test_data status field, ;; if all are pass (any case) and the test status is PASS or NULL or '' then set test status to PASS. ;; if one or more are fail (any case) then set test status to PASS, non "pass" or "fail" are ignored (define (db:test-data-rollup db test-id) (sqlite3:execute |
︙ | ︙ | |||
622 623 624 625 626 627 628 | (values #f #f #f)) ;;====================================================================== ;; S T E P S ;;====================================================================== (define (db:step-get-time-as-string vec) | | | 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 | (values #f #f #f)) ;;====================================================================== ;; S T E P S ;;====================================================================== (define (db:step-get-time-as-string vec) (seconds->time-string (db:step-get-event_time vec))) ;; db-get-test-steps-for-run (define (db:get-steps-for-test db test-id) (let ((res '())) (sqlite3:for-each-row (lambda (id test-id stepname state status event-time logfile) (set! res (cons (vector id test-id stepname state status event-time (if (string? logfile) logfile "")) res))) |
︙ | ︙ | |||
676 677 678 679 680 681 682 | ", get-status: " (db:step-get-status step)) (if (and (number? startt)(number? endt)) (seconds->hr-min-sec (- endt startt)) "-1"))) (if (> (string-length (db:step-get-logfile step)) 0) (vector-set! record 5 (db:step-get-logfile step)))) (else | | | | | 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 | ", get-status: " (db:step-get-status step)) (if (and (number? startt)(number? endt)) (seconds->hr-min-sec (- endt startt)) "-1"))) (if (> (string-length (db:step-get-logfile step)) 0) (vector-set! record 5 (db:step-get-logfile step)))) (else (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)))) |
︙ | ︙ | |||
722 723 724 725 726 727 728 | ;; all prereqs must be met: ;; if prereq test with itempath='' is COMPLETED and PASS, WARN, CHECK, or WAIVED then prereq is met ;; if prereq test with itempath=ref-item-path and COMPLETED with PASS, WARN, CHECK, or WAIVED then prereq is met (define (db:get-prereqs-not-met db run-id waiton ref-item-path) (if (null? waiton) '() (let* ((unmet-pre-reqs '()) | < > | > > > | > > | > | | | | | | | | | > > > > | > > > > | > > > | | | | 722 723 724 725 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 | ;; all prereqs must be met: ;; if prereq test with itempath='' is COMPLETED and PASS, WARN, CHECK, or WAIVED then prereq is met ;; if prereq test with itempath=ref-item-path and COMPLETED with PASS, WARN, CHECK, or WAIVED then prereq is met (define (db:get-prereqs-not-met db run-id waiton ref-item-path) (if (null? waiton) '() (let* ((unmet-pre-reqs '()) (result '())) (for-each (lambda (waitontest-name) ;; by getting the tests with matching name we are looking only at the matching test ;; and related sub items (let ((tests (db-get-tests-for-run db run-id waitontest-name #f '() '())) (ever-seen #f) (parent-waiton-met #f) (item-waiton-met #f)) (for-each (lambda (test) ;; (if (equal? waitontest-name (db:test-get-testname test)) ;; by defintion this had better be true ... (let* ((state (db:test-get-state test)) (status (db:test-get-status test)) (item-path (db:test-get-item-path test)) (is-completed (equal? state "COMPLETED")) (is-ok (member status '("PASS" "WARN" "CHECK" "WAIVED"))) (same-itempath (equal? ref-item-path item-path))) (set! ever-seen #t) (cond ;; case 1, non-item (parent test) is ((and (equal? item-path "") ;; this is the parent test is-completed is-ok) (set! waiton-met #t)) ((and same-itempath is-completed is-ok) (set! item-waiton-met #t))))) tests) (if (not (or waiton-met item-waiton-met)) (set! result (cons waitontest-name result))) ;; if the test is not found then clearly the waiton is not met... (if (not ever-seen)(set! result (cons waitontest-name result))))) waiton) (delete-duplicates result)))) ;;====================================================================== ;; Extract ods file from the db ;;====================================================================== ;; runspatt is a comma delimited list of run patterns ;; keypatt-alist must contain *all* keys with an associated pattern: '( ("KEY1" "%") .. ) |
︙ | ︙ | |||
784 785 786 787 788 789 790 | (results (list runsheader)) (testdata-header (list "Run Id" "Testname" "Item Path" "Category" "Variable" "Value" "Expected" "Tol" "Units" "Status" "Comment"))) (debug:print 2 "Using " tempdir " for constructing the ods file. keyqry: " keyqry " keystr: " keysstr " with keys: " (map cadr keypatt-alist)) ;; "Expected Value" ;; "Value Found" ;; "Tolerance" (apply sqlite3:for-each-row | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 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 | (results (list runsheader)) (testdata-header (list "Run Id" "Testname" "Item Path" "Category" "Variable" "Value" "Expected" "Tol" "Units" "Status" "Comment"))) (debug:print 2 "Using " tempdir " for constructing the ods file. keyqry: " keyqry " keystr: " keysstr " with keys: " (map cadr keypatt-alist)) ;; "Expected Value" ;; "Value Found" ;; "Tolerance" (apply sqlite3:for-each-row (lambda (test-id . b) (set! test-ids (cons test-id test-ids)) ;; test-id is now testname (set! results (append results ;; note, drop the test-id (list (if pathmod (let* ((vb (apply vector b)) (keyvals (let loop ((i 0) (res '())) (if (>= i numkeys) res (loop (+ i 1) (append res (list (vector-ref vb (+ i 2)))))))) (runname (vector-ref vb 1)) (testname (vector-ref vb (+ 2 numkeys))) (item-path (vector-ref vb (+ 3 numkeys))) (final-log (vector-ref vb (+ 7 numkeys))) (run-dir (vector-ref vb (+ 18 numkeys))) (log-fpath (conc run-dir "/" final-log))) ;; (string-intersperse keyvals "/") "/" testname "/" item-path "/" (debug:print 4 "log: " log-fpath " exists: " (file-exists? log-fpath)) (vector-set! vb (+ 7 numkeys) (if (file-exists? log-fpath) (let ((newpath (conc pathmod "/" (string-intersperse keyvals "/") "/" runname "/" testname "/" (if (string=? item-path "") "" (conc "/" item-path)) final-log))) ;; for now throw away newpath and use the log-fpath conc'd with pathmod (set! newpath (conc pathmod log-fpath)) (if windows (string-translate newpath "/" "\\") newpath)) (if (> *verbosity* 1) (conc final-log " not-found") ""))) (vector->list vb)) b))))) db (conc "SELECT t.testname,r.id,runname," keysstr ",t.testname, t.item_path,tm.description,t.state,t.status, final_logf,run_duration, strftime('%m/%d/%Y %H:%M:%S',datetime(t.event_time,'unixepoch'),'localtime'), tm.tags,r.owner,t.comment, author, tm.owner,reviewed, diskfree,uname,rundir, host,cpuload FROM tests AS t INNER JOIN runs AS r ON t.run_id=r.id INNER JOIN test_meta AS tm ON tm.testname=t.testname WHERE runname LIKE ? AND " keyqry ";") runspatt (map cadr keypatt-alist)) (set! results (list (cons "Runs" results))) ;; now, for each test, collect the test_data info and add a new sheet (for-each (lambda (test-id) (let ((test-data (list testdata-header)) (curr-test-name #f)) (sqlite3:for-each-row |
︙ | ︙ |