| ︙ | | | ︙ | |
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
|
;; (tests:set-full-meta-info test-id run-id (calc-minutes) work-area)
(tests:set-full-meta-info #f test-id run-id (calc-minutes) work-area 10)
(let loop ((minutes (calc-minutes))
(cpu-load (alist-ref 'adj-core-load (common:get-normalized-cpu-load #f)))
(disk-free (get-df (current-directory)))
(last-sync (current-seconds)))
;; (common:telemetry-log "zombie" (conc "launch:monitor-job - top of loop encountered at "(current-seconds)" with last-sync="last-sync))
((test-get-kill-request run-id test-id)
(set! kill-reason "KILLING TEST since received kill request (KILLREQ)")
(set! kill-job? #t))
((and runtlim (> (- (current-seconds) start-seconds) runtlim))
(set! kill-reason (conc "KILLING TEST DUE TO TIME LIMIT EXCEEDED! Runtime=" (- (current-seconds) start-seconds) " seconds, limit=" runtlim))
(set! kill-job? #t))
((equal? status "DEAD")
(tests:update-central-meta-info run-id test-id new-cpu-load new-disk-free (calc-minutes) #f #f)
(rmt:set-state-status-and-roll-up-items run-id test-id 'foo "RUNNING" "n/a" "was marked dead; really still running.")
;;(set! kill-reason "KILLING TEST because it was marked as DEAD by launch:handle-zombie-tests (might indicate really overloaded server or else overzealous setup.deadtime)") ;; MARK RUNNING
(set! kill-job? #f)))
(debug:print 4 *default-log-port* "cpu: " new-cpu-load " disk: " new-disk-free " last-sync: " last-sync " do-sync: " do-sync)
(if (common:low-noise-print 600 "run zombie") ;; every five minutes is plenty
(launch:handle-zombie-tests run-id))
(when do-sync
;;(with-output-to-file (conc (getenv "MT_TEST_RUN_DIR") "/last-loadinfo.log" #:append)
;; (lambda () (pp (list (current-seconds) new-cpu-load new-disk-free (calc-minutes)))))
;; (common:telemetry-log "zombie" (conc "launch:monitor-job - dosync started at "(current-seconds)))
(tests:update-central-meta-info run-id test-id new-cpu-load new-disk-free (calc-minutes) #f #f)
;; (common:telemetry-log "zombie" (conc "launch:monitor-job - dosync finished at "(current-seconds)))
)
|
<
>
|
<
<
<
|
<
<
|
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
|
;; (tests:set-full-meta-info test-id run-id (calc-minutes) work-area)
(tests:set-full-meta-info #f test-id run-id (calc-minutes) work-area 10)
(let loop ((minutes (calc-minutes))
(cpu-load (alist-ref 'adj-core-load (common:get-normalized-cpu-load #f)))
(disk-free (get-df (current-directory)))
(last-sync (current-seconds)))
(let* ((over-time (> (current-seconds) (+ last-sync update-period)))
(new-cpu-load (let* ((load (alist-ref 'adj-core-load (common:get-normalized-cpu-load #f)))
(delta (abs (- load cpu-load))))
(if (> delta 0.1) ;; don't bother updating with small changes
load
#f)))
(new-disk-free (let* ((df (if over-time ;; only get df every 30 seconds
(get-df (current-directory))
disk-free))
(delta (abs (- df disk-free))))
(if (and (> df 0)
(> (/ delta df) 0.1)) ;; (> delta 200) ;; ignore changes under 200 Meg
df
#f)))
(do-sync (or new-cpu-load new-disk-free over-time))
(test-info (rmt:get-test-state-status-by-id run-id test-id))
(state (car test-info));; (db:test-get-state test-info))
(status (cdr test-info));; (db:test-get-status test-info))
(killreq (equal? state "KILLREQ"))
(kill-reason "no kill reason specified")
(kill-job? #f))
;; (common:telemetry-log "zombie" (conc "launch:monitor-job - decision time encountered at "(current-seconds)" with last-sync="last-sync" do-sync="do-sync" over-time="over-time" update-period="update-period))
(cond
(killreq
(set! kill-reason "KILLING TEST since received kill request (KILLREQ)")
(set! kill-job? #t))
((and runtlim (> (- (current-seconds) start-seconds) runtlim))
(set! kill-reason (conc "KILLING TEST DUE TO TIME LIMIT EXCEEDED! Runtime=" (- (current-seconds) start-seconds) " seconds, limit=" runtlim))
(set! kill-job? #t))
((equal? status "DEAD")
(tests:update-central-meta-info run-id test-id new-cpu-load new-disk-free (calc-minutes) #f #f)
(rmt:set-state-status-and-roll-up-items run-id test-id 'foo "RUNNING" "n/a" "was marked dead; really still running.")
;;(set! kill-reason "KILLING TEST because it was marked as DEAD by launch:handle-zombie-tests (might indicate really overloaded server or else overzealous setup.deadtime)") ;; MARK RUNNING
(set! kill-job? #f)))
(debug:print 4 *default-log-port* "cpu: " new-cpu-load " disk: " new-disk-free " last-sync: " last-sync " do-sync: " do-sync)
(if (common:low-noise-print 600 "run zombie") ;; every five minutes is plenty
(launch:handle-zombie-tests run-id))
(when do-sync
(tests:update-central-meta-info run-id test-id new-cpu-load new-disk-free (calc-minutes) #f #f))
(if kill-job?
(begin
(debug:print-info 0 *default-log-port* "proceeding to kill test: "kill-reason)
(mutex-lock! m)
;; NOTE: The pid can change as different steps are run. Do we need handshaking between this
;; section and the runit section? Or add a loop that tries three times with a 1/4 second
|
| ︙ | | | ︙ | |
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
|
(debug:print-error 0 *default-log-port* "Nothing to kill, pid1=" pid1 ", pid2=" pid2)
(tests:test-set-status! run-id test-id "KILLED" "FAILED TO KILL" (conc (args:get-arg "-m")" "kill-reason) #f) ;; BB ADDED kill-reason -- confirm OK with Matt
)))
(mutex-unlock! m)
;; no point in sticking around. Exit now. But run end of run before exiting?
(launch:end-of-run-check run-id)
(exit)))
(if (hash-table-ref/default misc-flags 'keep-going #f)
(begin
(thread-sleep! 3) ;; (+ 3 (random 6))) ;; add some jitter to the call home time to spread out the db accesses
(if (hash-table-ref/default misc-flags 'keep-going #f) ;; keep originals for cpu-load and disk-free unless they change more than the allowed delta
(loop (calc-minutes)
(or new-cpu-load cpu-load)
(or new-disk-free disk-free)
(if do-sync (current-seconds) last-sync)))))))
(tests:update-central-meta-info run-id test-id (get-cpu-load) (get-df (current-directory))(calc-minutes) #f #f))) ;; NOTE: Checking twice for keep-going is intentional
(define (launch:execute encoded-cmd)
(let* ((cmdinfo (common:read-encoded-string encoded-cmd))
(tconfigreg #f))
(setenv "MT_CMDINFO" encoded-cmd)
;;(bb-check-path msg: "launch:execute incoming")
(if (list? cmdinfo) ;; ((testpath /tmp/mrwellan/jazzmind/src/example_run/tests/sqlitespeed)
|
|
|
<
|
|
|
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
|
(debug:print-error 0 *default-log-port* "Nothing to kill, pid1=" pid1 ", pid2=" pid2)
(tests:test-set-status! run-id test-id "KILLED" "FAILED TO KILL" (conc (args:get-arg "-m")" "kill-reason) #f) ;; BB ADDED kill-reason -- confirm OK with Matt
)))
(mutex-unlock! m)
;; no point in sticking around. Exit now. But run end of run before exiting?
(launch:end-of-run-check run-id)
(exit)))
(if (hash-table-ref/default misc-flags 'keep-going #f) ;; keep originals for cpu-load and disk-free unless they change more than the allowed delta
(begin
(thread-sleep! 6) ;; was 3
(loop (calc-minutes)
(or new-cpu-load cpu-load)
(or new-disk-free disk-free)
(if do-sync (current-seconds) last-sync))))))
(tests:update-central-meta-info run-id test-id (get-cpu-load) (get-df (current-directory))(calc-minutes) #f #f))) ;; NOTE: Checking twice for keep-going is intentional
;; read testconfig and create .logpro and script files
;; - use #f for tconfigreg to re-read the testconfigs from disk
;;
(define (launch:extract-scripts-logpro test-dir test-name item-path tconfigreg-in)
(let* ((tconfigreg (or tconfigreg-in
(tests:get-all)))
(tconfig-fname (conc test-dir "/.testconfig"))
(tconfig-tmpfile (conc tconfig-fname ".tmp"))
(tconfig (tests:get-testconfig test-name item-path tconfigreg #t force-create: #t)) ;; 'return-procs)))
(scripts (configf:get-section tconfig "scripts"))
(logpros (configf:get-section tconfig "logpro")))
;; create .testconfig file
(configf:write-alist tconfig tconfig-tmpfile)
(file-move tconfig-tmpfile tconfig-fname #t)
(delete-file* ".final-status")
;; extract scripts from testconfig and write them to files in test run dir
(for-each
(lambda (scriptdat)
(match scriptdat
((name content)
(debug:print-info 2 *default-log-port* "Creating script "(current-directory)"/"name)
(with-output-to-file name
(lambda ()
(print content)))
(change-file-mode name (bitwise-ior perm/irwxg perm/irwxu)))
(else
(debug:print-info 0 "Invalid script definiton found in [scripts] section of testconfig. \"" scriptdat "\""))))
scripts)
;; extract logpro from testconfig and write them to files in test run dir
(for-each
(lambda (logprodat)
(match logprodat
((name content)
(debug:print-info 2 *default-log-port* "Creating logpro file "(current-directory)"/"name)
(with-output-to-file name
(lambda ()
(print content)
;; (change-file-mode name (bitwise-ior perm/irwxg perm/irwxu))
)))
(else
(debug:print-info 0 "Invalid logpro definiton found in [logpro] section of testconfig. \"" logprodat "\""))))
logpros)))
(define (launch:execute encoded-cmd)
(let* ((cmdinfo (common:read-encoded-string encoded-cmd))
(tconfigreg #f))
(setenv "MT_CMDINFO" encoded-cmd)
;;(bb-check-path msg: "launch:execute incoming")
(if (list? cmdinfo) ;; ((testpath /tmp/mrwellan/jazzmind/src/example_run/tests/sqlitespeed)
|
| ︙ | | | ︙ | |
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
|
(if (string-search tmppath " ")
(debug:print 0 *default-log-port* "WARNING: spaces in PATH are not supported."))
(if mt-bindir-path (setenv "PATH" (conc tmppath":"mt-bindir-path))))
;;(bb-check-path msg: "launch:execute post block 4")
;; (change-directory top-path)
;; Can setup as client for server mode now
;; (client:setup)
;; environment overrides are done *before* the remaining critical envars.
(alist->env-vars env-ovrd)
;;(bb-check-path msg: "launch:execute post block 41")
(runs:set-megatest-env-vars run-id inkeys: keys inkeyvals: keyvals)
;;(bb-check-path msg: "launch:execute post block 42")
(set-item-env-vars itemdat)
;;(bb-check-path msg: "launch:execute post block 43")
|
|
<
|
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
|
(if (string-search tmppath " ")
(debug:print 0 *default-log-port* "WARNING: spaces in PATH are not supported."))
(if mt-bindir-path (setenv "PATH" (conc tmppath":"mt-bindir-path))))
;;(bb-check-path msg: "launch:execute post block 4")
;; (change-directory top-path)
;; Can setup as client for server mode now
;; (client:setup)
;; environment overrides are done *before* the remaining critical envars.
(alist->env-vars env-ovrd)
;;(bb-check-path msg: "launch:execute post block 41")
(runs:set-megatest-env-vars run-id inkeys: keys inkeyvals: keyvals)
;;(bb-check-path msg: "launch:execute post block 42")
(set-item-env-vars itemdat)
;;(bb-check-path msg: "launch:execute post block 43")
|
| ︙ | | | ︙ | |
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
|
(if (args:get-arg "-xterm")
(set! fullrunscript "xterm")
(if (and fullrunscript
(common:file-exists? fullrunscript)
(not (file-execute-access? fullrunscript)))
(system (conc "chmod ug+x " fullrunscript))))
;; We are about to actually kick off the test
;; so this is a good place to remove the records for
;; any previous runs
;; (db:test-remove-steps db run-id testname itemdat)
;; now is also a good time to write the .testconfig file
(let* ((tconfig-fname (conc work-area "/.testconfig"))
(tconfig-tmpfile (conc tconfig-fname ".tmp"))
(tconfig (tests:get-testconfig test-name item-path tconfigreg #t force-create: #t)) ;; 'return-procs)))
(scripts (configf:get-section tconfig "scripts")))
;; create .testconfig file
(configf:write-alist tconfig tconfig-tmpfile)
(file-move tconfig-tmpfile tconfig-fname #t)
(delete-file* ".final-status")
;; extract scripts from testconfig and write them to files in test run dir
(for-each
(lambda (scriptdat)
(match scriptdat
((name content)
(with-output-to-file name
(lambda ()
(print content)
(change-file-mode name (bitwise-ior perm/irwxg perm/irwxu)))))
(else
(debug:print-info 0 "Invalid script definiton found in [scripts] section of testconfig. \"" scriptdat "\""))))
scripts))
;;
(let* ((m (make-mutex))
(kill-job? #f)
(exit-info (make-launch:einf pid: #t exit-status: #t exit-code: #t rollup-status: 0)) ;; pid exit-status exit-code (i.e. process was successfully run) rollup-status
(job-thread #f)
;; (keep-going #t)
(misc-flags (let ((ht (make-hash-table)))
(hash-table-set! ht 'keep-going #t)
ht))
(runit (lambda ()
(launch:manage-steps run-id test-id item-path fullrunscript ezsteps subrun test-name tconfigreg exit-info m)))
(monitorjob (lambda ()
(launch:monitor-job run-id test-id item-path fullrunscript ezsteps test-name tconfigreg exit-info m work-area runtlim misc-flags)))
(th1 (make-thread monitorjob "monitor job"))
(th2 (make-thread runit "run job"))
(tconfig (tests:get-testconfig test-name item-path tconfigreg #t))
(propagate-exit-code (configf:lookup *configdat* "setup" "propagate-exit-code"))
(propagate-status-list '("FAIL" "KILLED" "ABORT" "DEAD" "CHECK" "SKIP" "WAIVED"))
(test-status "not set")
)
(set! job-thread th2)
(thread-start! th1)
(thread-start! th2)
(thread-join! th2)
(debug:print-info 0 *default-log-port* "Megatest execute of test " test-name ", item path " item-path " complete. Notifying the db ...")
(debug:print-info 2 *default-log-port* "exit-info = " exit-info)
(hash-table-set! misc-flags 'keep-going #f)
|
>
|
|
|
|
|
|
|
|
|
>
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
>
>
>
>
|
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
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
|
(if (args:get-arg "-xterm")
(set! fullrunscript "xterm")
(if (and fullrunscript
(common:file-exists? fullrunscript)
(not (file-execute-access? fullrunscript)))
(system (conc "chmod ug+x " fullrunscript))))
(launch:extract-scripts-logpro work-area test-name item-path tconfigreg)
;;;;; ;; We are about to actually kick off the test
;;;;; ;; so this is a good place to remove the records for
;;;;; ;; any previous runs
;;;;; ;; (db:test-remove-steps db run-id testname itemdat)
;;;;; ;; now is also a good time to write the .testconfig file
;;;;; (let* ((tconfig-fname (conc work-area "/.testconfig"))
;;;;; (tconfig-tmpfile (conc tconfig-fname ".tmp"))
;;;;; (tconfig (tests:get-testconfig test-name item-path tconfigreg #t force-create: #t)) ;; 'return-procs)))
;;;;; (scripts (configf:get-section tconfig "scripts"))
;;;;; (precmd (configf:lookup tconfig )
;;;;; ;; create .testconfig file
;;;;; (configf:write-alist tconfig tconfig-tmpfile)
;;;;; (file-move tconfig-tmpfile tconfig-fname #t)
;;;;; (delete-file* ".final-status")
;;;;;
;;;;; ;; extract scripts from testconfig and write them to files in test run dir
;;;;; (for-each
;;;;; (lambda (scriptdat)
;;;;; (match scriptdat
;;;;; ((name content)
;;;;; (with-output-to-file name
;;;;; (lambda ()
;;;;; (print content)
;;;;; (change-file-mode name (bitwise-ior perm/irwxg perm/irwxu)))))
;;;;; (else
;;;;; (debug:print-info 0 "Invalid script definiton found in [scripts] section of testconfig. \"" scriptdat "\""))))
;;;;; scripts))
;;
(let* ((m (make-mutex))
(kill-job? #f)
(exit-info (make-launch:einf pid: #t exit-status: #t exit-code: #t rollup-status: 0)) ;; pid exit-status exit-code (i.e. process was successfully run) rollup-status
(job-thread #f)
;; (keep-going #t)
(misc-flags (let ((ht (make-hash-table)))
(hash-table-set! ht 'keep-going #t)
ht))
(runit (lambda ()
(launch:manage-steps run-id test-id item-path fullrunscript ezsteps subrun test-name tconfigreg exit-info m)))
(monitorjob (lambda ()
(launch:monitor-job run-id test-id item-path fullrunscript ezsteps test-name tconfigreg exit-info m work-area runtlim misc-flags)))
(th1 (make-thread monitorjob "monitor job"))
(th2 (make-thread runit "run job"))
(tconfig (tests:get-testconfig test-name item-path tconfigreg #t))
(propagate-exit-code (configf:lookup *configdat* "setup" "propagate-exit-code"))
(propagate-status-list '("FAIL" "KILLED" "ABORT" "DEAD" "CHECK" "SKIP" "WAIVED"))
(test-status "not set")
(precmd (configf:lookup tconfig "setup" "precmd"))
(postcmd (configf:lookup tconfig "setup" "postcmd")))
;; first, if set, run the precmd
(if precmd ;; (file-exists? precmd)(file-execute-access? precmd))
(system precmd)) ;; up to test author to put nbfake if desired.
(set! job-thread th2)
(thread-start! th1)
(thread-start! th2)
(thread-join! th2)
(debug:print-info 0 *default-log-port* "Megatest execute of test " test-name ", item path " item-path " complete. Notifying the db ...")
(debug:print-info 2 *default-log-port* "exit-info = " exit-info)
(hash-table-set! misc-flags 'keep-going #f)
|
| ︙ | | | ︙ | |
760
761
762
763
764
765
766
767
768
769
770
771
772
773
|
work-area ":\n====\n exit code " (launch:einf-exit-code exit-info) "\n" "====\n")
(set! test-status (db:test-get-status (rmt:get-testinfo-state-status run-id test-id)))
;; If the propagate-exit-code option has been set in the megatest config, and the test status matches the list, set the exit code to 1.
(if (and propagate-exit-code (string=? propagate-exit-code "yes") (member test-status propagate-status-list))
(begin
(debug:print 1 *default-log-port* "Setting exit status to 1 because of test status of " test-status)
(set! *globalexitstatus* 1)
)
)
|
>
>
>
|
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
|
work-area ":\n====\n exit code " (launch:einf-exit-code exit-info) "\n" "====\n")
(set! test-status (db:test-get-status (rmt:get-testinfo-state-status run-id test-id)))
;; If the propagate-exit-code option has been set in the megatest config, and the test status matches the list, set the exit code to 1.
(if postcmd
(system postcmd))
(if (and propagate-exit-code (string=? propagate-exit-code "yes") (member test-status propagate-status-list))
(begin
(debug:print 1 *default-log-port* "Setting exit status to 1 because of test status of " test-status)
(set! *globalexitstatus* 1)
)
)
|
| ︙ | | | ︙ | |