Overview
Comment: | Partial edits for refactor of db, committing prior to trying to merge in the api branch |
---|---|
Downloads: | Tarball | ZIP archive | SQL archive |
Timelines: | family | ancestors | descendants | both | refactor-db |
Files: | files | file ages | folders |
SHA1: |
5a1b924a675282a91c42892921f9c1f1 |
User & Date: | matt on 2013-10-19 10:24:38 |
Other Links: | branch diff | manifest | tags |
Context
2013-10-19
| ||
10:36 | Merged refactor-api into refactor-db check-in: 45b4ad07c1 user: matt tags: refactor-db | |
10:24 | Partial edits for refactor of db, committing prior to trying to merge in the api branch check-in: 5a1b924a67 user: matt tags: refactor-db | |
2013-10-18
| ||
00:20 | Ported tests.scm to dbstruct check-in: a3f5835386 user: matt tags: refactor-db | |
Changes
Modified common.scm from [50a5d9c6c7] to [236bfdcd02].
︙ | ︙ | |||
95 96 97 98 99 100 101 | (set! *test-id-cache* (make-hash-table))) ;;====================================================================== ;; S T A T E S A N D S T A T U S E S ;;====================================================================== (define *common:std-states* | > > > | > > > > > > > > > > > > | | 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 124 125 126 127 | (set! *test-id-cache* (make-hash-table))) ;;====================================================================== ;; S T A T E S A N D S T A T U S E S ;;====================================================================== (define *common:std-states* '((0 "COMPLETED") (1 "NOT_STARTED") (2 "RUNNING") (3 "REMOTEHOSTSTART") (4 "LAUNCHED") (5 "KILLED") (6 "KILLREQ") (7 "STUCK"))) (define *common:std-statuses* '((0 "PASS") (1 "WARN") (2 "FAIL") (3 "CHECK") (4 "n/a") (5 "WAIVED") (6 "SKIP") (7 "DELETED") (8 "STUCK/DEAD"))) ;; These are stopping conditions that prevent a test from being run (define *common:cant-run-states-sym* '(COMPLETED KILLED WAIVED UNKNOWN INCOMPLETE)) ;;====================================================================== ;; D E B U G G I N G S T U F F |
︙ | ︙ |
Modified mt.scm from [bd0f14c7cf] to [1d4bcb987f].
︙ | ︙ | |||
36 37 38 39 40 41 42 | ;; runs:get-runs-by-patt ;; get runs by list of criteria ;; register a test run with the db ;; ;; Use: (db-get-value-by-header (db:get-header runinfo)(db:get-row runinfo)) ;; to extract info from the structure returned ;; | | | | | 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 | ;; runs:get-runs-by-patt ;; get runs by list of criteria ;; register a test run with the db ;; ;; Use: (db-get-value-by-header (db:get-header runinfo)(db:get-row runinfo)) ;; to extract info from the structure returned ;; (define (mt:get-runs-by-patt dbstruct keys runnamepatt targpatt) (let loop ((runsdat (db:get-runs-by-patt dbstruct keys runnamepatt targpatt 0 500)) (res '()) (offset 0) (limit 500)) ;; (print "runsdat: " runsdat) (let* ((header (vector-ref runsdat 0)) (runslst (vector-ref runsdat 1)) (full-list (append res runslst)) (have-more (eq? (length runslst) limit))) ;; (debug:print 0 "header: " header " runslst: " runslst " have-more: " have-more) (if have-more (let ((new-offset (+ offset limit)) (next-batch (db:get-runs-by-patt dbstruct keys runnamepatt targpatt offset limit))) (debug:print-info 4 "More than " limit " runs, have " (length full-list) " runs so far.") (debug:print-info 0 "next-batch: " next-batch) (loop next-batch full-list new-offset limit)) (vector header full-list))))) |
︙ | ︙ | |||
81 82 83 84 85 86 87 | new-offset limit)) full-list)))) (define (mt:get-prereqs-not-met run-id waitons ref-item-path #!key (mode 'normal)) (db:get-prereqs-not-met run-id waitons ref-item-path mode: mode)) | | | | 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 | new-offset limit)) full-list)))) (define (mt:get-prereqs-not-met run-id waitons ref-item-path #!key (mode 'normal)) (db:get-prereqs-not-met run-id waitons ref-item-path mode: mode)) (define (mt:get-run-stats dbstruct run-id) (db:get-run-stats dbstruct run-id)) (define (mt:discard-blocked-tests run-id failed-test tests test-records) (if (null? tests) tests (begin (debug:print-info 1 "Discarding tests from " tests " that are waiting on " failed-test) (let loop ((testn (car tests)) |
︙ | ︙ | |||
140 141 142 143 144 145 146 | (conc state "/") (conc "/" status))))))) ;;====================================================================== ;; S T A T E A N D S T A T U S F O R T E S T S ;;====================================================================== | | | | | | | | | | | | | | | | | | | 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 | (conc state "/") (conc "/" status))))))) ;;====================================================================== ;; S T A T E A N D S T A T U S F O R T E S T S ;;====================================================================== (define (mt:roll-up-pass-fail-counts dbstruct run-id test-name item-path status) (if (and (not (equal? item-path "")) (member status '("PASS" "WARN" "FAIL" "WAIVED" "RUNNING" "CHECK" "SKIP"))) (begin (db:update-pass-fail-counts dbstruct run-id test-name) (if (equal? status "RUNNING") (db:top-test-set-running dbstruct run-id test-name) (db:top-test-set-per-pf-counts dbstruct run-id test-name)) #f) #f)) ;; ;; speed up for common cases with a little logic ;; (define (mt:test-set-state-status-by-id dbstruct run-id test-id newstate newstatus newcomment) ;; (cond ;; ((and newstate newstatus newcomment) ;; (sqlite3: 'state-status-msg #t *default-numtries* newstate newstatus newcomment test-id)) ;; ((and newstate newstatus) ;; (cdb:client-call *runremote* 'state-status #t *default-numtries* newstate newstatus test-id)) ;; (else ;; (if newstate (cdb:client-call *runremote* 'set-test-state #t *default-numtries* newstate test-id)) ;; (if newstatus (cdb:client-call *runremote* 'set-test-status #t *default-numtries* newstatus test-id)) ;; (if newcomment (cdb:client-call *runremote* 'set-test-comment #t *default-numtries* newcomment test-id)))) ;; (mt:process-triggers test-id newstate newstatus) ;; #t) (define (mt:lazy-get-test-info-by-id test-id) (let* ((tdat (hash-table-ref/default *test-info* test-id #f))) (if (and tdat (< (current-seconds)(+ (vector-ref tdat 0) 10))) (vector-ref tdat 1) ;; no need to update *test-info* as that is done in cdb:get-test-info-by-id |
︙ | ︙ |
Modified newdashboard.scm from [1f8bd891c4] to [4e9877b3af].
︙ | ︙ | |||
566 567 568 569 570 571 572 | (iup:attribute-set! tabtop "TABTITLE2" "Run Control") (iup:attribute-set! tabtop "TABTITLE3" "megatest.config") (iup:attribute-set! tabtop "TABTITLE4" "runconfigs.config") tabtop))) (define *current-window-id* 0) | | | | 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 | (iup:attribute-set! tabtop "TABTITLE2" "Run Control") (iup:attribute-set! tabtop "TABTITLE3" "megatest.config") (iup:attribute-set! tabtop "TABTITLE4" "runconfigs.config") tabtop))) (define *current-window-id* 0) (define (newdashboard dbstruct) (let* ((data (make-hash-table)) (keys (db:get-keys dbstruct)) (runname "%") (testpatt "%") (keypatts (map (lambda (k)(list k "%")) keys)) (states '()) (statuses '()) (nextmintime (current-milliseconds)) (my-window-id *current-window-id*)) |
︙ | ︙ |
Modified synchash.scm from [68c033427e] to [a110b60074].
︙ | ︙ | |||
53 54 55 56 57 58 59 | (set! deleted (cons id deleted)) (hash-table-delete! synchash id)))) orig-keys) (list changed deleted) ;; (list indat '()) ;; just for debugging )) | | | | | | 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 | (set! deleted (cons id deleted)) (hash-table-delete! synchash id)))) orig-keys) (list changed deleted) ;; (list indat '()) ;; just for debugging )) ;; (c?db:remote-run db:get-keys #f) ;; (c?db:remote-run db:get-num-runs #f "%") ;; (c?db:remote-run db:get-runs #f runnamepatt numruns *start-run-offset* keypatts) ;; ;; keynum => the field to use as the unique key (usually 0 but can be other field) ;; (define (synchash:client-get proc synckey keynum synchash . params) (let* ((data (apply cdb:remote-run synchash:server-get #f proc synckey keynum params)) (newdat (car data)) (removs (cadr data)) (myhash (hash-table-ref/default synchash synckey #f))) |
︙ | ︙ |
Modified tests.scm from [f1da5de029] to [fb86a2abb4].
︙ | ︙ | |||
24 25 26 27 28 29 30 31 32 33 34 35 36 37 | (declare (uses runconfig)) (include "common_records.scm") (include "key_records.scm") (include "db_records.scm") (include "run_records.scm") (include "test_records.scm") ;; Call this one to do all the work and get a standardized list of tests (define (tests:get-all) (let* ((test-search-path (cons (conc *toppath* "/tests") ;; the default (tests:get-tests-search-path *configdat*)))) (tests:get-valid-tests (make-hash-table) test-search-path))) | > | 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 | (declare (uses runconfig)) (include "common_records.scm") (include "key_records.scm") (include "db_records.scm") (include "run_records.scm") (include "test_records.scm") ;; Call this one to do all the work and get a standardized list of tests (define (tests:get-all) (let* ((test-search-path (cons (conc *toppath* "/tests") ;; the default (tests:get-tests-search-path *configdat*)))) (tests:get-valid-tests (make-hash-table) test-search-path))) |
︙ | ︙ | |||
704 705 706 707 708 709 710 | (db:tests-update-run-duration dbstruct run-id test-id minutes)) (if (and uname hostname) (db:tests-update-uname-host dbstruct run-id test-id uname hostname))) ;; OPTIMIZE THESE!!! They are redundant!! (define (tests:set-full-meta-info dbstruct test-id run-id minutes work-area) | < < | 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 | (db:tests-update-run-duration dbstruct run-id test-id minutes)) (if (and uname hostname) (db:tests-update-uname-host dbstruct run-id test-id uname hostname))) ;; OPTIMIZE THESE!!! They are redundant!! (define (tests:set-full-meta-info dbstruct test-id run-id minutes work-area) (let* ((num-records 0) ;; (test:tdb-get-rundat-count tdb)) (cpuload (get-cpu-load)) (diskfree (get-df (current-directory))) (uname (get-uname "-srvpio")) (hostname (get-host-name))) ;; (tests:update-testdat-meta-info dbstruct run-id test-id work-area cpuload diskfree minutes) (tests:update-central-meta-info dbstruct run-id test-id cpuload diskfree minutes uname hostname))) (define (tests:set-partial-meta-info dbstruct test-id run-id minutes work-area) (let* ((cpuload (get-cpu-load)) (diskfree (get-df (current-directory)))) (tests:update-testdat-meta-info db test-id work-area cpuload diskfree minutes) ;; Update central with uname and hostname = #f (tests:update-central-meta-info test-id cpuload diskfree minutes #f #f))) (define (tests:update-testdat-meta-info dbstruct run-id test-id work-area cpuload diskfree minutes) |
︙ | ︙ |