Overview
Comment: | Added support for using the shell when launching a command (vs. directly kicking off the process) |
---|---|
Downloads: | Tarball | ZIP archive | SQL archive |
Timelines: | family | ancestors | descendants | both | trunk |
Files: | files | file ages | folders |
SHA1: |
dc5aae878ad18fc63872a3ae037f60f4 |
User & Date: | mrwellan on 2011-08-04 09:56:27 |
Other Links: | manifest | tags |
Context
2011-08-06
| ||
23:42 | Added debugging statements, regenerated docs check-in: 6b1fa57fcf user: matt tags: trunk | |
2011-08-04
| ||
09:56 | Added support for using the shell when launching a command (vs. directly kicking off the process) check-in: dc5aae878a user: mrwellan tags: trunk | |
2011-08-03
| ||
13:28 | Couple more tweaks to html output of the items rollup check-in: b2ba4571a3 user: mrwellan tags: trunk | |
Changes
Modified launch.scm from [e7a7004ae8] to [aadffc4da1].
︙ | ︙ | |||
91 92 93 94 95 96 97 | ;; 3. create link from run dir to megatest runs area ;; 4. remotely run the test on allocated host ;; - could be ssh to host from hosts table (update regularly with load) ;; - could be netbatch ;; (launch-test db (cadr status) test-conf)) (define (launch-test db run-id test-conf keyvallst test-name test-path itemdat) (change-directory *toppath*) | > | | 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 | ;; 3. create link from run dir to megatest runs area ;; 4. remotely run the test on allocated host ;; - could be ssh to host from hosts table (update regularly with load) ;; - could be netbatch ;; (launch-test db (cadr status) test-conf)) (define (launch-test db run-id test-conf keyvallst test-name test-path itemdat) (change-directory *toppath*) (let ((useshell (config-lookup *configdat* "jobtools" "useshell")) (launcher (config-lookup *configdat* "jobtools" "launcher")) (runscript (config-lookup test-conf "setup" "runscript")) (diskspace (config-lookup test-conf "requirements" "diskspace")) (memory (config-lookup test-conf "requirements" "memory")) (hosts (config-lookup *configdat* "jobtools" "workhosts")) (remote-megatest (config-lookup *configdat* "setup" "executable")) (local-megatest (car (argv))) ;; (item-path (item-list->path itemdat)) test-path is the full path including the item-path |
︙ | ︙ | |||
155 156 157 158 159 160 161 | (hash-table-ref/default test-conf "pre-launch-env-overrides" '()))) (miscprevvals (alist->env-vars ;; consolidate this code with the code in megatest.scm for "-execute" (append (list (list "MT_TEST_NAME" test-name) (list "MT_ITEM_INFO" (conc itemdat)) (list "MT_RUNNAME" (args:get-arg ":runname"))) itemdat))) (launch-results (apply cmd-run-proc-each-line | > > | > > | > | 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 | (hash-table-ref/default test-conf "pre-launch-env-overrides" '()))) (miscprevvals (alist->env-vars ;; consolidate this code with the code in megatest.scm for "-execute" (append (list (list "MT_TEST_NAME" test-name) (list "MT_ITEM_INFO" (conc itemdat)) (list "MT_RUNNAME" (args:get-arg ":runname"))) itemdat))) (launch-results (apply cmd-run-proc-each-line (if useshell (string-intersperse fullcmd " ") (car fullcmd)) print (if useshell '() (cdr fullcmd))))) ;; launcher fullcmd)));; (apply cmd-run-proc-each-line launcher print fullcmd))) ;; (cmd-run->list fullcmd)) (debug:print 2 "Launching completed, updating db") (debug:print 4 "Launch results: " launch-results) (if (not launch-results) (begin (print "ERROR: Failed to run " (string-intersperse fullcmd " ") ", exiting now") (sqlite3:finalize! db) ;; good ole "exit" seems not to work ;; (_exit 9) ;; but this hack will work! Thanks go to Alan Post of the Chicken email list ;; NB// Is this still needed? Should be safe to go back to "exit" now? (process-signal (current-process-id) signal/kill) )) (alist->env-vars miscprevvals) (alist->env-vars testprevvals) (alist->env-vars commonprevvals) launch-results))) |
Modified process.scm from [a67e367861] to [83cec585a3].
︙ | ︙ | |||
10 11 12 13 14 15 16 17 18 19 20 21 | ;;====================================================================== ;;====================================================================== ;; Process convience utils ;;====================================================================== (define (cmd-run-proc-each-line cmd proc . params) (handle-exceptions exn (begin (print "ERROR: Failed to run command: " cmd " " (string-intersperse params " ")) #f) | > | > > | 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 | ;;====================================================================== ;;====================================================================== ;; Process convience utils ;;====================================================================== (define (cmd-run-proc-each-line cmd proc . params) ;; (print "Called with cmd=" cmd ", proc=" proc ", params=" params) (handle-exceptions exn (begin (print "ERROR: Failed to run command: " cmd " " (string-intersperse params " ")) #f) (let-values (((fh fho pid) (if (null? params) (process cmd) (process cmd params)))) (let loop ((curr (read-line fh)) (result '())) (if (not (eof-object? curr)) (loop (read-line fh) (append result (list (proc curr)))) (begin (close-input-port fh) |
︙ | ︙ |