138
139
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
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
|
(configf:section-vars *configdat* "env-override"))))
;; set up needed environment variables given a run-id and optionally a target, itempath etc.
;;
(define (runs:set-megatest-env-vars run-id #!key (inkeys #f)(inrunname #f)(inkeyvals #f)(intarget #f)(testname #f)(itempath #f))
;;(bb-check-path msg: "runs:set-megatest-env-vars entry")
(let* ((target (or intarget
(common:args-get-target)
(get-environment-variable "MT_TARGET")))
(keys (if inkeys inkeys (rmt:get-keys)))
(keyvals (if inkeyvals inkeyvals (keys:target->keyval keys target)))
(vals (hash-table-ref/default *env-vars-by-run-id* run-id #f))
(link-tree (common:get-linktree))) ;; (configf:lookup *configdat* "setup" "linktree")))
(if testname (setenv "MT_TEST_NAME" testname))
(if itempath (setenv "MT_ITEMPATH" itempath))
;; get the info from the db and put it in the cache
(if link-tree
(setenv "MT_LINKTREE" link-tree)
(debug:print-error 0 *default-log-port* "linktree not set, should be set in megatest.config in [setup] section."))
(if (not vals)
(let ((ht (make-hash-table)))
(hash-table-set! *env-vars-by-run-id* run-id ht)
(set! vals ht)
(for-each
(lambda (key)
(hash-table-set! vals (car key) (cadr key)))
keyvals)))
;; from the cached data set the vars
(hash-table-for-each
vals
(lambda (key val)
(debug:print 2 *default-log-port* "setenv " key " " val)
(safe-setenv key val)))
;;(bb-check-path msg: "runs:set-megatest-env-vars block 1")
;;(BB> "*env-vars-by-run-id*/runid("run-id" vals="(hash-table->alist vals))
(if (not (get-environment-variable "MT_TARGET"))(setenv "MT_TARGET" target))
;; we had a case where there was an exception generated by the hash-table-ref
;; due to *configdat* being #f Adding a handle and exit
(let fatal-loop ((count 0))
(handle-exceptions
exn
(let ((call-chain (get-call-chain))
(msg ((condition-property-accessor 'exn 'message) exn)))
(if (< count 5)
(begin ;; this call is colliding, do some crude stuff to fix it.
(debug:print 0 *default-log-port* "ERROR: *configdat* was inaccessible! This should never happen. Retry #" count)
(launch:setup force-reread: #t)
(fatal-loop (+ count 1)))
(begin
(debug:print 0 *default-log-port* "FATAL: *configdat* was inaccessible! This should never happen. Retried " count " times. Message: " msg)
(debug:print 0 *default-log-port* "Call chain:")
(with-output-to-port *default-log-port*
(lambda ()
(print "*configdat* is >>"*configdat*"<<")
(pp *configdat*)
(pp call-chain)))
(exit 1))))
;;(bb-check-path msg: "runs:set-megatest-env-vars block 1.5")
(when (or (not *configdat*) (not (hash-table? *configdat*)))
(debug:print 0 *default-log-port* "WARNING: *configdat* was inaccessible! This should never happen. Brute force reread.")
;;(BB> "ERROR: *configdat* was inaccessible! This should never happen. Brute force reread.")
(thread-sleep! 2) ;; assuming nfs lag.
(launch:setup force-reread: #t))
(alist->env-vars (hash-table-ref/default *configdat* "env-override" '())))) ;;;; environment is tainted HERE in this let block.
;;(bb-check-path msg: "runs:set-megatest-env-vars block 2")
;; Lets use this as an opportunity to put MT_RUNNAME in the environment
(let ((runname (if inrunname inrunname (rmt:get-run-name-from-id run-id))))
(if runname
(setenv "MT_RUNNAME" runname)
(debug:print-error 0 *default-log-port* "no value for runname for id " run-id)))
(setenv "MT_RUN_AREA_HOME" *toppath*)
;; if a testname and itempath are available set the remaining appropriate variables
(if testname (setenv "MT_TEST_NAME" testname))
(if itempath (setenv "MT_ITEMPATH" itempath))
;;(bb-check-path msg: "runs:set-megatest-env-vars block 3")
(if (and testname link-tree)
(setenv "MT_TEST_RUN_DIR" (conc (getenv "MT_LINKTREE") "/"
(getenv "MT_TARGET") "/"
(getenv "MT_RUNNAME") "/"
(getenv "MT_TEST_NAME")
(if (and itempath
(not (equal? itempath "")))
(conc "/" itempath)
""))))))
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
|
138
139
140
141
142
143
144
145
146
147
148
149
150
151
|
(configf:section-vars *configdat* "env-override"))))
(define (runs:can-run-more-tests runsdat run-id jobgroup max-concurrent-jobs)
;; Take advantage of a good place to exit if running the one-pass methodology
(if (and (> (runs:dat-can-run-more-tests-count runsdat) 20)
(args:get-arg "-one-pass"))
(exit 0))
|
2688
2689
2690
2691
2692
2693
2694
2695
2696
|
(delete-file f)))
files))))
(debug:print-error 0 *default-log-port* "-clean-cache requires -runname."))
(debug:print-error 0 *default-log-port* "-clean-cache requires -target or -reqtarg")))
)
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
2601
2602
2603
2604
2605
2606
2607
2608
2609
2610
2611
2612
2613
2614
2615
2616
2617
2618
2619
2620
2621
2622
2623
2624
2625
2626
2627
2628
2629
2630
2631
2632
2633
2634
2635
2636
2637
2638
2639
2640
2641
2642
2643
2644
2645
2646
2647
2648
2649
2650
2651
2652
2653
2654
|
(delete-file f)))
files))))
(debug:print-error 0 *default-log-port* "-clean-cache requires -runname."))
(debug:print-error 0 *default-log-port* "-clean-cache requires -target or -reqtarg")))
;; Spec for End of test
;; At end of each test call, after marking self as COMPLETED do run-state-status-rollup
;; At transition to run COMPLETED/X do hooks
;; Definition: test_dead if event_time + duration + 1 minute? < current_time AND
;; we can prove the process is not alive (ssh host pstree -A pid)
;; if dead safe to mark the test as killed in the db
;; State/status table
;; new
;; 100% COMPLETED/ (PASS,FAIL,ABORT etc.) ==> COMPLETED / X where X is same as itemized rollup
;; > 3 RUNNING with not test_dead do nothing (run should already be RUNNING/ na
;; > 0 RUNNING and test_dead then send KILLREQ ==> COMPLETED
;; 0 RUNNING ==> this is actually the first condition, should not get here
(define (launch:end-of-run-check run-id )
(let* ((not-completed-cnt (rmt:get-not-completed-cnt run-id))
(running-cnt (rmt:get-count-tests-running-for-run-id run-id))
(all-test-launched (rmt:get-var (conc "lunch-complete-" run-id)))
(current-state (rmt:get-run-state run-id))
(current-status (rmt:get-run-status run-id)))
;;get-vars run-id to query metadata table to check if all completed. if all-test-launched = yes then only not-completed-cnt = 0 means everyting is completed if no entry found in the table do nothing
(debug:print 0 *default-log-port* "rollup run state/status")
(rmt:set-state-status-and-roll-up-run run-id current-state current-status)
(cond
((and all-test-launched (eq? not-completed-cnt 0) (equal? all-test-launched "yes" ))
(debug:print 0 *default-log-port* "look for post hook.")
(runs:run-post-hook run-id))
((> running-cnt 3)
(debug:print 0 *default-log-port* "There are " running-cnt " tests running." ))
((> running-cnt 0)
(debug:print 0 *default-log-port* "running cnt > 0 but <= 3 kill-running-tests-if-dead" )
(let ((kill-cnt (launch:kill-tests-if-dead run-id)))
(if (and all-test-launched (equal? all-test-launched "yes") (eq? kill-cnt running-cnt))
(launch:end-of-run-check run-id)))) ;;todo
(else (debug:print 0 *default-log-port* "Should it get here?? May be everything is not launched yet. Running test cnt:" running-cnt " Not completed test cnt:" not-completed-cnt)
(let* ((not-completed-tests (rmt:get-tests-for-run run-id "%" `("NOT_STARTED" "RUNNING" "LAUNCHED" "REMOTEHOSTSTART") `() #f #f #f #f #f #f #f #f)))
(if (> (length not-completed-tests) 0)
(let loop ((running-test (car not-completed-tests))
(tal (cdr not-completed-tests)))
(let* ((test-name (vector-ref running-test 2))
(item-path (vector-ref running-test 11)))
(debug:print 0 *default-log-port* "test " test-name "/" item-path " not completed")
(if (not (null? tal))
(loop (car tal) (cdr tal)))))))))))
)
|