Overview
| Comment: | Added child reaper based on post to #chicken by andyjpg, it seems to work well |
|---|---|
| Downloads: | Tarball | ZIP archive | SQL archive |
| Timelines: | family | ancestors | descendants | both | v1.55 |
| Files: | files | file ages | folders |
| SHA1: |
2886acdd2f593802d86f8b10dd6a296e |
| User & Date: | matt on 2013-09-11 23:36:14 |
| Other Links: | branch diff | manifest | tags |
Context
|
2013-09-12
| ||
| 23:38 | Added exec to nbfake. Changed test4 to do launchwait. Added forced registration of top level tests as not having them is a path to possible escape on silent failure check-in: fd20d22153 user: matt tags: v1.55 | |
|
2013-09-11
| ||
| 23:36 | Added child reaper based on post to #chicken by andyjpg, it seems to work well check-in: 2886acdd2f user: matt tags: v1.55 | |
|
2013-09-10
| ||
| 17:27 | Misc fixes check-in: e5b733b81c user: mrwellan tags: v1.55 | |
Changes
Modified NOTES from [ef843a82ce] to [973eb2f3d1].
1 2 3 4 5 6 7 | 1. All run control access to db is direct. 2. All test machines must have megatest available 3. Tests may or may not have file system access to the originating run area. rsync is used to pull the test area to the home host if and only if the originating area can not be seen via file system. NO LONGER TRUE. Rsync is used but file system must be visible. 4. All db access is done via the home host. NOT IMPLEMENTED YET. | > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | # FROM andyjpg on #chicken (let ((original-exit (exit-handler))) (exit-handler (lambda (#!optional (exit-code 0)) (printf "Preparing to exit...\n" exit-code) (for-each (lambda (pid) (printf "Sending signal/term to ~A\n" pid) (process-signal pid signal/term)) (children)) (original-exit exit-code)))) 1. All run control access to db is direct. 2. All test machines must have megatest available 3. Tests may or may not have file system access to the originating run area. rsync is used to pull the test area to the home host if and only if the originating area can not be seen via file system. NO LONGER TRUE. Rsync is used but file system must be visible. 4. All db access is done via the home host. NOT IMPLEMENTED YET. |
| ︙ | ︙ |
Modified megatest.scm from [73e9da4e68] to [ab8143b2ea].
| ︙ | ︙ | |||
31 32 33 34 35 36 37 38 39 40 41 42 43 44 |
(define *db* #f) ;; this is only for the repl, do not use in general!!!!
(include "common_records.scm")
(include "key_records.scm")
(include "db_records.scm")
(include "run_records.scm")
(include "megatest-fossil-hash.scm")
(let ((debugcontrolf (conc (get-environment-variable "HOME") "/.megatestrc")))
(if (file-exists? debugcontrolf)
(load debugcontrolf)))
(define help (conc "
| > > > > > > > > > > > > > > > > > > | 31 32 33 34 35 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 |
(define *db* #f) ;; this is only for the repl, do not use in general!!!!
(include "common_records.scm")
(include "key_records.scm")
(include "db_records.scm")
(include "run_records.scm")
(include "megatest-fossil-hash.scm")
;; Overall exit handling setup immediately
;;
(let ((original-exit (exit-handler)))
(exit-handler (lambda (#!optional (exit-code 0))
(printf "Preparing to exit with exit code ~A ...\n" exit-code)
(children
(lambda (pid)
(handle-exceptions
exn
#t
(let-values (((pid-val exit-status exit-code) (process-wait pid #t)))
(if (or (eq? pid-val pid)
(eq? pid-val 0))
(begin
(printf "Sending signal/term to ~A\n" pid)
(process-signal pid signal/term)))))))
(original-exit exit-code))))
(let ((debugcontrolf (conc (get-environment-variable "HOME") "/.megatestrc")))
(if (file-exists? debugcontrolf)
(load debugcontrolf)))
(define help (conc "
|
| ︙ | ︙ |
Modified process.scm from [444a7f5a5f] to [8a2775d2d2].
| ︙ | ︙ | |||
107 108 109 110 111 112 113 |
(let-values (((pid-val exit-status exit-code) (process-wait pid #t)))
(if (eq? pid-val 0)
(begin
(thread-sleep! 2)
(loop (+ i 1)))
(values pid-val exit-status exit-code))))))
| > > > > > > > > > > > > > > > > | 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 |
(let-values (((pid-val exit-status exit-code) (process-wait pid #t)))
(if (eq? pid-val 0)
(begin
(thread-sleep! 2)
(loop (+ i 1)))
(values pid-val exit-status exit-code))))))
;;======================================================================
;; MISC PROCESS RELATED STUFF
;;======================================================================
(define (children proc)
(with-input-from-pipe
(conc "ps h --ppid " (current-process-id) " -o pid")
(lambda ()
(let loop ((inl (read-line))
(res '()))
(if (eof-object? inl)
(reverse res)
(let ((pid (string->number inl)))
(if proc (proc pid))
(loop (read-line) (cons pid res))))))))
|