Overview
Comment: | Implemented (but not tested) triggers |
---|---|
Downloads: | Tarball | ZIP archive | SQL archive |
Timelines: | family | ancestors | descendants | both | v1.55 |
Files: | files | file ages | folders |
SHA1: |
8fbf618bd9cce4172cbf1b72764284fa |
User & Date: | matt on 2013-08-18 00:35:39 |
Other Links: | branch diff | manifest | tags |
Context
2013-08-18
| ||
01:17 | Tweaks for triggers check-in: 61acf99e82 user: matt tags: v1.55 | |
00:35 | Implemented (but not tested) triggers check-in: 8fbf618bd9 user: matt tags: v1.55 | |
2013-08-17
| ||
17:07 | Missed a runremote check-in: cff566396e user: matt tags: v1.55 | |
Changes
Modified common.scm from [0004ed06a1] to [5237757a15].
︙ | ︙ | |||
69 70 71 72 73 74 75 76 77 78 79 80 81 82 | (define *run-info-cache* (make-hash-table)) ;; run info is stable, no need to reget ;; Awful. Please FIXME (define *env-vars-by-run-id* (make-hash-table)) (define *current-run-name* #f) (define (common:clear-caches) (set! *target* (make-hash-table)) (set! *keys* (make-hash-table)) (set! *keyvals* (make-hash-table)) (set! *toptest-paths* (make-hash-table)) (set! *test-paths* (make-hash-table)) (set! *test-ids* (make-hash-table)) | > > > > | 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 | (define *run-info-cache* (make-hash-table)) ;; run info is stable, no need to reget ;; Awful. Please FIXME (define *env-vars-by-run-id* (make-hash-table)) (define *current-run-name* #f) ;; Testconfig and runconfig caches. (define *testconfigs* (make-hash-table)) ;; test-id => testconfig (define *runconfigs* (make-hash-table)) ;; target => runconfig (define (common:clear-caches) (set! *target* (make-hash-table)) (set! *keys* (make-hash-table)) (set! *keyvals* (make-hash-table)) (set! *toptest-paths* (make-hash-table)) (set! *test-paths* (make-hash-table)) (set! *test-ids* (make-hash-table)) |
︙ | ︙ |
Modified configf.scm from [40fcc5a96b] to [a206263cb1].
︙ | ︙ | |||
139 140 141 142 143 144 145 | ;; in the environment on the fly ;; sections: #f => get all, else list of sections to gather (define (read-config path ht allow-system #!key (environ-patt #f)(curr-section #f)(sections #f)) (debug:print-info 5 "read-config " path " allow-system " allow-system " environ-patt " environ-patt " curr-section: " curr-section " sections: " sections " pwd: " (current-directory)) (if (not (file-exists? path)) (begin (debug:print-info 1 "read-config - file not found " path " current path: " (current-directory)) | > | | 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 | ;; in the environment on the fly ;; sections: #f => get all, else list of sections to gather (define (read-config path ht allow-system #!key (environ-patt #f)(curr-section #f)(sections #f)) (debug:print-info 5 "read-config " path " allow-system " allow-system " environ-patt " environ-patt " curr-section: " curr-section " sections: " sections " pwd: " (current-directory)) (if (not (file-exists? path)) (begin (debug:print-info 1 "read-config - file not found " path " current path: " (current-directory)) ;; WARNING: This is a risky change but really, we should not return an empty hash table if no file read? #f) ;; (if (not ht)(make-hash-table) ht)) (let ((inp (open-input-file path)) (res (if (not ht)(make-hash-table) ht))) (let loop ((inl (configf:read-line inp res allow-system)) ;; (read-line inp)) (curr-section-name (if curr-section curr-section "default")) (var-flag #f);; turn on for key-var-pr and cont-ln-rx, turn off elsewhere (lead #f)) (debug:print-info 8 "curr-section-name: " curr-section-name " var-flag: " var-flag "\n inl: \"" inl "\"") |
︙ | ︙ |
Modified db.scm from [0eb6a7e788] to [15ceac39e1].
︙ | ︙ | |||
1105 1106 1107 1108 1109 1110 1111 | (define (cdb:tests-update-run-duration serverdat test-id minutes) (cdb:client-call serverdat 'update-run-duration #t *default-numtries* minutes test-id)) (define (cdb:tests-update-uname-host serverdat test-id uname hostname) (cdb:client-call serverdat 'update-uname-host #t *default-numtries* uname hostname test-id)) | < < < | | 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 | (define (cdb:tests-update-run-duration serverdat test-id minutes) (cdb:client-call serverdat 'update-run-duration #t *default-numtries* minutes test-id)) (define (cdb:tests-update-uname-host serverdat test-id uname hostname) (cdb:client-call serverdat 'update-uname-host #t *default-numtries* uname hostname test-id)) ;; speed up for common cases with a little logic ;; NB// Ultimately this will be deprecated in deference to mt:test-set-state-status-by-id ;; (define (db:test-set-state-status-by-id db test-id newstate newstatus newcomment) (cond ((and newstate newstatus newcomment) (sqlite3:execute db "UPDATE tests SET state=?,status=?,comment=? WHERE id=?;" newstate newstatus newcomment test-id)) ((and newstate newstatus) (sqlite3:execute db "UPDATE tests SET state=?,status=? WHERE id=?;" newstate newstatus test-id)) (else (if newstate (sqlite3:execute db "UPDATE tests SET state=? WHERE id=?;" newstate test-id)) (if newstatus (sqlite3:execute db "UPDATE tests SET status=? WHERE id=?;" newstatus test-id)) (if newcomment (sqlite3:execute db "UPDATE tests SET comment=? WHERE id=?;" newcomment test-id)))) (mt:process-triggers test-id newstate newstatus)) ;; Never used ;; (define (db:test-set-state-status-by-run-id-testname db run-id test-name item-path status state) ;; (sqlite3:execute db "UPDATE tests SET state=?,status=?,event_time=strftime('%s','now') WHERE run_id=? AND testname=? AND item_path=?;" ;; state status run-id test-name item-path)) (define (db:get-count-tests-running db) |
︙ | ︙ | |||
1584 1585 1586 1587 1588 1589 1590 | (define (cdb:roll-up-pass-fail-counts serverdat run-id test-name item-path status) (cdb:client-call serverdat 'immediate #f *default-numtries* open-run-close db:roll-up-pass-fail-counts #f run-id test-name item-path status)) (define (cdb:get-test-info serverdat run-id test-name item-path) (cdb:client-call serverdat 'immediate #f *default-numtries* open-run-close db:get-test-info #f run-id test-name item-path)) (define (cdb:get-test-info-by-id serverdat test-id) | | > > | 1581 1582 1583 1584 1585 1586 1587 1588 1589 1590 1591 1592 1593 1594 1595 1596 1597 | (define (cdb:roll-up-pass-fail-counts serverdat run-id test-name item-path status) (cdb:client-call serverdat 'immediate #f *default-numtries* open-run-close db:roll-up-pass-fail-counts #f run-id test-name item-path status)) (define (cdb:get-test-info serverdat run-id test-name item-path) (cdb:client-call serverdat 'immediate #f *default-numtries* open-run-close db:get-test-info #f run-id test-name item-path)) (define (cdb:get-test-info-by-id serverdat test-id) (let ((test-dat (cdb:client-call serverdat 'immediate #f *default-numtries* open-run-close db:get-test-info-by-id #f test-id))) (hash-table-set! *test-info* test-id test-dat) ;; cached for use where up-to-date info is not needed test-dat)) ;; db should be db open proc or #f (define (cdb:remote-run proc db . params) (apply cdb:client-call *runremote* 'immediate #f *default-numtries* open-run-close proc #f params)) (define (db:test-get-logfile-info db run-id test-name) (let ((res #f)) |
︙ | ︙ |
Modified launch.scm from [54776b43d1] to [7a5983c4e5].
︙ | ︙ | |||
176 177 178 179 180 181 182 183 184 185 186 187 188 189 | (loop (+ i 1))) ))))) ;; then, if runscript ran ok (or did not get called) ;; do all the ezsteps (if any) (if ezsteps (let* ((testconfig (read-config (conc work-area "/testconfig") #f #t environ-patt: "pre-launch-env-vars")) ;; FIXME??? is allow-system ok here? (ezstepslst (hash-table-ref/default testconfig "ezsteps" '()))) (if (not (file-exists? ".ezsteps"))(create-directory ".ezsteps")) ;; if ezsteps was defined then we are sure to have at least one step but check anyway (if (not (> (length ezstepslst) 0)) (debug:print 0 "ERROR: ezsteps defined but ezstepslst is zero length") (let loop ((ezstep (car ezstepslst)) (tal (cdr ezstepslst)) (prevstep #f)) | > | 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 | (loop (+ i 1))) ))))) ;; then, if runscript ran ok (or did not get called) ;; do all the ezsteps (if any) (if ezsteps (let* ((testconfig (read-config (conc work-area "/testconfig") #f #t environ-patt: "pre-launch-env-vars")) ;; FIXME??? is allow-system ok here? (ezstepslst (hash-table-ref/default testconfig "ezsteps" '()))) (hash-table-set! *testconfigs* test-id testconfig) ;; cached for lazy reads later ... (if (not (file-exists? ".ezsteps"))(create-directory ".ezsteps")) ;; if ezsteps was defined then we are sure to have at least one step but check anyway (if (not (> (length ezstepslst) 0)) (debug:print 0 "ERROR: ezsteps defined but ezstepslst is zero length") (let loop ((ezstep (car ezstepslst)) (tal (cdr ezstepslst)) (prevstep #f)) |
︙ | ︙ |
Modified mt.scm from [8d32b77738] to [d3f560c691].
︙ | ︙ | |||
83 84 85 86 87 88 89 90 91 92 93 94 95 96 | 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) (cdb:remote-run db:get-run-stats #f)) ;;====================================================================== ;; 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 run-id test-name item-path status) (if (and (not (equal? item-path "")) | > > > > > > > > > > > > > > > > > > > > > > > | 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 | 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) (cdb:remote-run db:get-run-stats #f)) ;;====================================================================== ;; T R I G G E R S ;;====================================================================== (define (mt:process-triggers test-id newstate newstatus) (let* ((test-dat (mt:lazy-get-test-info-by-id test-id)) (test-rundir (db:test-get-rundir test-dat)) (tconfig #f)) (if (and (file-exists? test-rundir) (directory? test-rundir)) (begin (push-directory test-rundir) (set! tconfig (mt:lazy-read-test-config test-dat)) (pop-directory) (for-each (lambda (trigger) (let ((cmd (configf:lookup tconfig "triggers" trigger))) (if cmd (system (conc cmd " " test-id " " test-rundir " " trigger " 2&>1 " test-rundir "/last-trigger.log"))))) (list (conc newstate "/" newstatus) (conc newstate "/") (conc "/" newstatus))))))) ;;====================================================================== ;; 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 run-id test-name item-path status) (if (and (not (equal? item-path "")) |
︙ | ︙ | |||
110 111 112 113 114 115 116 | (cdb:client-call *runremote* '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)))) | | > > > > > > > > > > > > > > > > > > > | 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 | (cdb:client-call *runremote* '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 tdat tdat ;; no need to update *test-info* as that is done in cdb:get-test-info-by-id (cdb:get-test-info-by-id *runremote* test-id)))) (define (mt:lazy-read-test-config test-dat) (let* ((test-id (db:test-get-id test-dat)) (test-rundir (db:test-get-rundir test-dat)) (tconfig (hash-table-ref/default *testconfigs* test-id #f))) (if tconfig tconfig (let ((newtcfg (read-config (conc test-rundir "/testconfig") #f #f))) ;; NOTE: Does NOT run [system ...] (hash-table-set! *testconfigs* test-id newtcfg) newtcfg)))) |
Modified runs.scm from [8c7a71404f] to [e0d9d07905].
︙ | ︙ | |||
1003 1004 1005 1006 1007 1008 1009 | (> (string-length dira)(string-length dirb)) #f))))) (test-retry-time (make-hash-table)) (allow-run-time 10)) ;; seconds to allow for killing tests before just brutally killing 'em (let loop ((test (car sorted-tests)) (tal (cdr sorted-tests))) (let* ((test-id (db:test-get-id test)) | | > > > > > | | 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 | (> (string-length dira)(string-length dirb)) #f))))) (test-retry-time (make-hash-table)) (allow-run-time 10)) ;; seconds to allow for killing tests before just brutally killing 'em (let loop ((test (car sorted-tests)) (tal (cdr sorted-tests))) (let* ((test-id (db:test-get-id test)) (new-test-dat (cdb:get-test-info-by-id *runremote* test-id))) (if (not new-test-dat) (begin (debug:print 0 "ERROR: We have a test-id of " test-id " but no record was found. NOTE: No locking of records is done between processes, do not simultaneously remove the same run from two processes!") (if (not (null? tal)) (loop (car tal)(cdr tal)))) (let* ((item-path (db:test-get-item-path new-test-dat)) (test-name (db:test-get-testname new-test-dat)) (run-dir (db:test-get-rundir new-test-dat)) ;; run dir is from the link tree (real-dir (if (file-exists? run-dir) (resolve-pathname run-dir) #f)) (test-state (db:test-get-state new-test-dat)) (test-fulln (db:test-get-fullname new-test-dat))) |
︙ | ︙ | |||
1084 1085 1086 1087 1088 1089 1090 | ((run-wait) (debug:print-info 2 "still waiting, " (length tests) " tests still running") (thread-sleep! 10) (let ((new-tests (proc-get-tests run-id))) (if (null? new-tests) (debug:print-info 1 "Run completed according to zero tests matching provided criteria.") (loop (car new-tests)(cdr new-tests)))))))) | | | 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 | ((run-wait) (debug:print-info 2 "still waiting, " (length tests) " tests still running") (thread-sleep! 10) (let ((new-tests (proc-get-tests run-id))) (if (null? new-tests) (debug:print-info 1 "Run completed according to zero tests matching provided criteria.") (loop (car new-tests)(cdr new-tests)))))))) ))))) ;; remove the run if zero tests remain (if (eq? action 'remove-runs) (let ((remtests (mt:get-tests-for-run (db:get-value-by-header run header "id") #f '("DELETED") '("n/a") not-in: #t))) (if (null? remtests) ;; no more tests remaining (let* ((dparts (string-split lasttpath "/")) (runpath (conc "/" (string-intersperse (take dparts (- (length dparts) 1)) |
︙ | ︙ |
tests/installall/config/megatest.config.dat became a symlink with target [736a5da885].
whitespace changes only
tests/installall/config/runconfigs.config.dat became a symlink with target [3b8f260acb].
whitespace changes only