Check-in [b077e2bbcd]
Not logged in
Overview
SHA1 Hash:b077e2bbcd891acd09509ac461d90e17fd65f9c6
Date: 2012-04-12 16:14:02
User: mrwellan
Comment:Added helpful (hopefully) output on system and shell from config processing and launch processes
Timelines: family | ancestors | descendants | both | trunk
Downloads: Tarball | ZIP archive
Other Links: files | file ages | manifest
Tags And Properties
Changes

Modified configf.scm from [aeb220e9e6167319] to [f3836ab5761565ea].

89 89 90 ;; Run a shell command and return the output as a string 90 ;; Run a shell command and return the output as a string 91 (define (shell cmd) 91 (define (shell cmd) 92 (let* ((output (cmd-run->list cmd)) 92 (let* ((output (cmd-run->list cmd)) 93 (res (car output)) 93 (res (car output)) 94 (status (cadr output))) 94 (status (cadr output))) 95 (if (equal? status 0) 95 (if (equal? status 0) 96 (string-intersperse | 96 (let ((outres (string-intersperse 97 res | 97 res 98 "\n") | 98 "\n"))) > 99 (debug:print 4 "INFO: shell result:\n" outres) > 100 outres) 99 (begin 101 (begin 100 (with-output-to-port (current-error-port) 102 (with-output-to-port (current-error-port) 101 (print "ERROR: " cmd " returned bad exit code " status)) 103 (print "ERROR: " cmd " returned bad exit code " status)) 102 "")))) 104 "")))) 103 105 104 ;; Lookup a value in runconfigs based on -reqtarg or -target 106 ;; Lookup a value in runconfigs based on -reqtarg or -target 105 (define (runconfigs-get config var) 107 (define (runconfigs-get config var) ................................................................................................................................................................................ 147 (configf:section-rx ( x section-name ) (loop (configf:read-line i 149 (configf:section-rx ( x section-name ) (loop (configf:read-line i 148 (configf:key-sys-pr ( x key cmd ) (if allow-system 150 (configf:key-sys-pr ( x key cmd ) (if allow-system 149 (let ((alist (hash-tab 151 (let ((alist (hash-tab 150 (val-proc (lambd 152 (val-proc (lambd 151 (let 153 (let 152 154 153 155 > 156 (d 154 (i 157 (i 155 158 156 | 159 > 160 157 161 158 (i 162 (i 159 163 160 164 161 (hash-table-set! res 165 (hash-table-set! res 162 (co 166 (co 163 167

Modified launch.scm from [c99403d780c1549e] to [f72ebdf466261267].

534 (cmdparms #f) 534 (cmdparms #f) 535 (fullcmd #f) ;; (define a (with-output-to-string (lambda ()(write x) 535 (fullcmd #f) ;; (define a (with-output-to-string (lambda ()(write x) 536 (mt-bindir-path #f) 536 (mt-bindir-path #f) 537 (item-path (item-list->path itemdat)) 537 (item-path (item-list->path itemdat)) 538 (testinfo (rdb:get-test-info db run-id test-name item-path)) 538 (testinfo (rdb:get-test-info db run-id test-name item-path)) 539 (test-id (db:test-get-id testinfo)) 539 (test-id (db:test-get-id testinfo)) 540 (debug-param (if (args:get-arg "-debug")(list "-debug" (args:get-arg "- 540 (debug-param (if (args:get-arg "-debug")(list "-debug" (args:get-arg "- 541 (if hosts (set! hosts (string-split hosts))) | 541 (if hosts (set! hosts (string-split hosts))) 542 ;; set the megatest to be called on the remote host 542 ;; set the megatest to be called on the remote host 543 (if (not remote-megatest)(set! remote-megatest local-megatest)) ;; "megatest 543 (if (not remote-megatest)(set! remote-megatest local-megatest)) ;; "megatest 544 (set! mt-bindir-path (pathname-directory remote-megatest)) 544 (set! mt-bindir-path (pathname-directory remote-megatest)) 545 (if launcher (set! launcher (string-split launcher))) 545 (if launcher (set! launcher (string-split launcher))) 546 ;; set up the run work area for this test 546 ;; set up the run work area for this test 547 (set! diskpath (get-best-disk *configdat*)) 547 (set! diskpath (get-best-disk *configdat*)) 548 (if diskpath 548 (if diskpath ................................................................................................................................................................................ 551 (set! toptest-work-area (cadr dat)) 551 (set! toptest-work-area (cadr dat)) 552 (debug:print 2 "INFO: Using work area " work-area)) 552 (debug:print 2 "INFO: Using work area " work-area)) 553 (begin 553 (begin 554 (set! work-area (conc test-path "/tmp_run")) 554 (set! work-area (conc test-path "/tmp_run")) 555 (create-directory work-area #t) 555 (create-directory work-area #t) 556 (debug:print 0 "WARNING: No disk work area specified - running in the 556 (debug:print 0 "WARNING: No disk work area specified - running in the 557 (set! cmdparms (base64:base64-encode (with-output-to-string 557 (set! cmdparms (base64:base64-encode (with-output-to-string 558 (lambda () ;; (list 'hosts hosts) | 558 (lambda () ;; (list 'hosts hosts) 559 (write (list (list 'testpath test-path) | 559 (write (list (list 'testpath test- 560 (list 'work-area work-area) | 560 (list 'work-area work- 561 (list 'test-name test-name) | 561 (list 'test-name test- 562 (list 'runscript runscript) | 562 (list 'runscript runsc 563 (list 'run-id run-id ) | 563 (list 'run-id run-i 564 (list 'test-id test-id ) | 564 (list 'test-id test- 565 (list 'itemdat itemdat ) | 565 (list 'itemdat itemd 566 (list 'megatest remote-megat | 566 (list 'megatest remot 567 (list 'ezsteps ezsteps) | 567 (list 'ezsteps ezste 568 (list 'env-ovrd (hash-table- | 568 (list 'env-ovrd (hash 569 (list 'set-vars (if params ( | 569 (list 'set-vars (if p 570 (list 'runname runname) | 570 (list 'runname runna 571 (list 'mt-bindir-path mt-bind | 571 (list 'mt-bindir-path 572 ;; clean out step records from previous run if they exist 572 ;; clean out step records from previous run if they exist 573 (db:delete-test-step-records db run-id test-name itemdat) 573 (db:delete-test-step-records db run-id test-name itemdat) 574 (change-directory work-area) ;; so that log files from the launch process do 574 (change-directory work-area) ;; so that log files from the launch process do 575 (cond 575 (cond 576 ((and launcher hosts) ;; must be using ssh hostname 576 ((and launcher hosts) ;; must be using ssh hostname 577 (set! fullcmd (append launcher (car hosts)(list remote-megatest test-sig " 577 (set! fullcmd (append launcher (car hosts)(list remote-megatest test-sig " 578 ;; (set! fullcmd (append launcher (car hosts)(list remote-megatest test-si | 578 ;; (set! fullcmd (append launcher (car hosts)(list remote-megatest test-sig 579 (launcher 579 (launcher 580 (set! fullcmd (append launcher (list remote-megatest test-sig "-execute" c 580 (set! fullcmd (append launcher (list remote-megatest test-sig "-execute" c 581 ;; (set! fullcmd (append launcher (list remote-megatest test-sig "-execute | 581 ;; (set! fullcmd (append launcher (list remote-megatest test-sig "-execute" 582 (else 582 (else 583 (if (not useshell)(debug:print 0 "WARNING: internal launching will not wor 583 (if (not useshell)(debug:print 0 "WARNING: internal launching will not wor 584 (set! fullcmd (append (list remote-megatest test-sig "-execute" cmdparms) 584 (set! fullcmd (append (list remote-megatest test-sig "-execute" cmdparms) 585 ;; (set! fullcmd (list remote-megatest test-sig "-execute" cmdparms (if us | 585 ;; (set! fullcmd (list remote-megatest test-sig "-execute" cmdparms (if uses 586 (if (args:get-arg "-xterm")(set! fullcmd (append fullcmd (list "-xterm")))) 586 (if (args:get-arg "-xterm")(set! fullcmd (append fullcmd (list "-xterm")))) 587 (debug:print 1 "Launching megatest for test " test-name " in " work-area" .. 587 (debug:print 1 "Launching megatest for test " test-name " in " work-area" .. 588 (test-set-status! db test-id "LAUNCHED" "n/a" #f #f) ;; (if launch-results l 588 (test-set-status! db test-id "LAUNCHED" "n/a" #f #f) ;; (if launch-results l 589 ;; set pre-launch-env-vars before launching, keep the vars in prevvals and p 589 ;; set pre-launch-env-vars before launching, keep the vars in prevvals and p 590 (debug:print 4 "fullcmd: " fullcmd) 590 (debug:print 4 "fullcmd: " fullcmd) 591 (let* ((commonprevvals (alist->env-vars 591 (let* ((commonprevvals (alist->env-vars 592 (hash-table-ref/default *configdat* "env-override" ' 592 (hash-table-ref/default *configdat* "env-override" '