Index: common.scm ================================================================== --- common.scm +++ common.scm @@ -183,10 +183,34 @@ (define *launch-setup-mutex* (make-mutex)) ;; need to be able to call launch:setup often so mutex it and re-call the real deal only if *toppath* not set (define *homehost-mutex* (make-mutex)) ;; Miscellaneous (define *triggers-mutex* (make-mutex)) ;; block overlapping processing of triggers + +(use posix-extras pathname-expand files) + +(define ##sys#expand-home-path pathname-expand) ;; plugs a hole in posix-extras in recent chicken versions +(define (realpath x) (resolve-pathname (pathname-expand (or x "/dev/null")) )) + +(define (common:get-this-exe-fullpath #!key (argv (argv))) + (let* ((this-script + (cond + ((and (> (length argv) 2) + (string-match "^(.*/csi|csi)$" (car argv)) + (string-match "^-(s|ss|sx|script)$" (cadr argv))) + (caddr argv)) + (else (car argv)))) + (fullpath (realpath this-script))) + fullpath)) +(define *common:this-exe-fullpath* (common:get-this-exe-fullpath)) +(define *common:this-exe-dir* (pathname-directory *common:this-exe-fullpath*)) +(define *common:this-exe-name* (pathname-strip-directory *common:this-exe-fullpath*)) + + + + + (defstruct remote (hh-dat (common:get-homehost)) ;; homehost record ( addr . hhflag ) (server-url (if *toppath* (server:check-if-running *toppath*))) ;; (server:check-if-running *toppath*) #f)) (last-server-check 0) ;; last time we checked to see if the server was alive @@ -1001,16 +1025,18 @@ (begin (if message (debug:print-info 0 *default-log-port* message)) #f) (thunk) )) -(define (common:file-exists? path-string) +(define (common:file-exists? path-string #!key (silent #f)) ;; this avoids stack dumps in the case where ;;;; TODO: catch permission denied exceptions and emit appropriate warnings, eg: system error while trying to access file: "/nfs/pdx/disks/icf_env_disk001/bjbarcla/gwa/issues/mtdev/randy-slow/reproduce/q... (common:false-on-exception (lambda () (file-exists? path-string)) - message: (conc "Unable to access path: " path-string) + message: (if (not silent) + (conc "Unable to access path: " path-string) + #f) )) (define (common:directory-exists? path-string) ;;;; TODO: catch permission denied exceptions and emit appropriate warnings, eg: system error while trying to access file: "/nfs/pdx/disks/icf_env_disk001/bjbarcla/gwa/issues/mtdev/randy-slow/reproduce/q... (common:false-on-exception (lambda () (directory-exists? path-string)) Index: dashboard-tests.scm ================================================================== --- dashboard-tests.scm +++ dashboard-tests.scm @@ -246,11 +246,11 @@ ;; if there is a submegatest create a button to launch dashboard in that area ;; (define (submegatest-panel dbstruct keydat testdat runname testconfig) (let* ((test-run-dir (db:test-get-rundir testdat)) (subarea (subrun:get-runarea test-run-dir)) - (area-exists (and subarea (common:file-exists? subarea)))) + (area-exists (and subarea (common:file-exists? subarea silent: #t)))) (if subarea (iup:frame #:title "Megatest Run Info" ; #:expand "YES" (iup:button "Launch Dashboard" Index: dashboard.scm ================================================================== --- dashboard.scm +++ dashboard.scm @@ -14,11 +14,11 @@ (require-library iup) (import (prefix iup iup:)) (use canvas-draw) (import canvas-draw-iup) - +(use ducttape-lib) (use sqlite3 srfi-1 posix regex regex-case srfi-69 typed-records sparse-vectors) ;; defstruct (import (prefix sqlite3 sqlite3:)) (declare (uses common)) (declare (uses margs)) @@ -325,10 +325,25 @@ (lambda (alist-entry) (member (car alist-entry) '(allruns-by-id allruns))) ;; FIELDS OF INTEREST (dboard:tabdat->alist tabdat-item))))) + +(define (dboard:launch-testpanel run-id test-id) + (let* (;; (cfg-sh (conc *common:this-exe-dir* "/cfg.sh")) + ;; (cmd (conc + ;; (if (common:file-exists? cfg-sh) + ;; (conc "source "cfg-sh" && ") + ;; "") + ;; *common:this-exe-fullpath* + ;; " -test " run-id "," test-id + ;; " &")) + (cmd (conc *common:this-exe-dir*"/../dashboard " + "-test " run-id "," test-id + " &"))) + (system cmd))) + (define (dboard:tabdat-target-string vec) (let ((targ (dboard:tabdat-target vec))) (if (list? targ)(string-intersperse targ "/") "no-target-specified"))) (define (dboard:tabdat-test-patts-use vec) @@ -2134,15 +2149,15 @@ (item-path (db:test-get-item-path (rmt:get-test-info-by-id run-id test-id))) (item-test-path (conc test-name "/" (if (equal? item-path "") "%" item-path))) (status-chars (char-set->list (string->char-set status))) - (testpanel-cmd (conc toolpath " -test " (dboard:tabdat-curr-run-id tabdat) "," test-id " &"))) + (run-id (dboard:tabdat-curr-run-id tabdat))) (debug:print-info 13 *default-log-port* "status-chars=["status-chars"] status=["status"]") (cond ((member #\1 status-chars) ;; 1 is left mouse button - (system testpanel-cmd)) + (dboard:launch-testpanel run-id test-id)) ((member #\2 status-chars) ;; 2 is middle mouse button (debug:print-info 13 *default-log-port* "mmb- test-name="test-name" testpatt="testpatt) (iup:show (dashboard:popup-menu run-id test-id target runname test-name testpatt item-test-path test-info) ;; popup-menu @@ -2394,15 +2409,11 @@ (iup:menu (iup:menu-item "Test Control Panel" #:action (lambda (obj) - (let* ((toolpath (car (argv))) - (testpanel-cmd - (conc toolpath " -test " run-id "," test-id " &"))) - (system testpanel-cmd) - ))) + (launch-testpanel run-id test-id))) (iup:menu-item (conc "View Log " item-test-path) #:action (lambda (obj) @@ -2728,14 +2739,12 @@ )) (if (eq? pressed 0) (let* ((toolpath (car (argv))) (buttndat (hash-table-ref (dboard:tabdat-buttondat runs-dat) button-key)) (test-id (db:test-get-id (vector-ref buttndat 3))) - (run-id (db:test-get-run_id (vector-ref buttndat 3))) - (cmd (conc toolpath " -test " run-id "," test-id "&"))) - (system cmd))) - ))))) + (run-id (db:test-get-run_id (vector-ref buttndat 3)))) + (dboard:launch-testpanel run-id test-id)))))))) (hash-table-set! (dboard:tabdat-buttondat runs-dat) button-key (vector 0 "100 100 100" button-key #f #f)) (vector-set! testvec testnum butn) (loop runnum (+ testnum 1) testvec (cons butn res)))))) ;; now assemble the hdrlst and bdylst and kick off the dialog (iup:show Index: ducttape/ducttape-lib.scm ================================================================== --- ducttape/ducttape-lib.scm +++ ducttape/ducttape-lib.scm @@ -16,11 +16,13 @@ iputs re-match? ; launch-repl keyword-skim skim-cmdline-opts-noarg-by-regex - skim-cmdline-opts-withargs-by-regex + skim-cmdline-opts-withargs-by-regex + get-cli-arg + get-cli-switch concat-lists ducttape-process-command-line ducttape-append-logfile ducttape-activate-logfile isys @@ -42,24 +44,52 @@ isodate->wwdate wwdate->seconds wwdate->isodate current-wwdate current-isodate - + *this-exe-dir* + *this-exe-name* + *this-exe-fullpath* ) (import scheme chicken extras ports data-structures ) (use posix regex ansi-escape-sequences test srfi-1 irregex slice srfi-13 rfc3339) ;;scsh-process ;; dropping scsh-process, it was clobbering posix's process and process* (use directory-utils uuid-lib filepath srfi-19 ) ; linenoise - + + ;; plugs a hole in posix-extras in latter chicken versions + (use posix-extras pathname-expand files) + (define ##sys#expand-home-path pathname-expand) + (define (realpath x) (resolve-pathname (pathname-expand (or x "/dev/null")) )) + (include "mimetypes.scm") ; provides ext->mimetype (include "workweekdate.scm") (define ducttape-lib-version 1.00) (define (toplevel-command sym proc) (lambda () #f)) + +;;;; define some handy globals + ;; resolve fullpath to this script or binary. + (define (__get-this-script-fullpath #!key (argv (argv))) + (let* ((this-script + (cond + ((and (> (length argv) 2) + (string-match "^(.*/csi|csi)$" (car argv)) + (string-match "^-(s|ss|sx|script)$" (cadr argv))) + (caddr argv)) + (else (car argv)))) + (fullpath (realpath this-script))) + fullpath)) + + (define *this-exe-fullpath* (__get-this-script-fullpath)) + (define *this-exe-dir* (pathname-directory *this-exe-fullpath*)) + (define *this-exe-name* (pathname-strip-directory *this-exe-fullpath*)) + + ;;;; utility procedures + + ;; begin credit: megatest's process.scm (define (port->list fh ) (if (eof-object? fh) #f (let loop ((curr (read-line fh)) (result '())) @@ -637,10 +667,26 @@ (loop (list (cadr args-remaining)) (cddr args-remaining) args-to-return) (loop (cons (cadr args-remaining) kwval) (cddr args-remaining) args-to-return)) (loop (cadr args-remaining) (cddr args-remaining) args-to-return))) (else (loop kwval (cdr args-remaining) (cons (car args-remaining) args-to-return)))))) + + (define (get-cli-arg arg #!key (default #f) (is-list #f)) + (let* ((temp (skim-cmdline-opts-withargs-by-regex arg))) + (if (> (length temp) 0) + (if is-list + temp + (car temp)) + default))) + + (define (get-cli-switch arg) + (let ((temp (skim-cmdline-opts-noarg-by-regex arg))) + (if (> (length temp) 0) + (car temp) + #f))) + + ;; get command line switches (have a subsequent arg; eg. [-foo bar]) ;; assumes these are switches without arguments ;; will return list of arguments to matches Index: launch.scm ================================================================== --- launch.scm +++ launch.scm @@ -1496,22 +1496,26 @@ itemdat))) (testprevvals (alist->env-vars (hash-table-ref/default tconfig "pre-launch-env-overrides" '()))) ;; Launchwait defaults to true, must override it to turn off wait (launchwait (if (equal? (configf:lookup *configdat* "setup" "launchwait") "no") #f #t)) - (launch-results (apply (if launchwait ;; BB: TODO: refactor this to examine return code of launcher, if nonzero, set state to launch failed. - process:cmd-run-with-stderr->list + (launch-results-prev (apply (if launchwait ;; BB: TODO: refactor this to examine return code of launcher, if nonzero, set state to launch failed. + process:cmd-run-with-stderr-and-exitcode->list process-run) (if useshell (let ((cmdstr (string-intersperse fullcmd " "))) (if launchwait cmdstr (conc cmdstr " >> mt_launch.log 2>&1 &"))) (car fullcmd)) (if useshell '() - (cdr fullcmd))))) + (cdr fullcmd)))) + (success (if launchwait (equal? 0 (cadr launch-results-prev)) #t)) + (launch-results (if launchwait (car launch-results-prev) launch-results-prev))) + (if (not success) + (tests:test-set-status! run-id test-id "COMPLETED" "DEAD" "launcher failed; exited non-zero; check mt_launch.log" #f)) ;; (if launch-results launch-results "FAILED")) (mutex-unlock! *launch-setup-mutex*) ;; yes, really should mutex all the way to here. Need to put this entire process into a fork. ;; (rmt:no-sync-del! lock-key) ;; release the lock for starting this test (if (not launchwait) ;; give the OS a little time to allow the process to start (thread-sleep! 0.01)) (with-output-to-file "mt_launch.log" Index: process.scm ================================================================== --- process.scm +++ process.scm @@ -44,10 +44,36 @@ (begin (close-input-port fh) (close-input-port fhe) (close-output-port fho) result))))) ;; ) + +(define (process:cmd-run-with-stderr-and-exitcode->list cmd . params) + ;; (print "Called with cmd=" cmd ", proc=" proc ", params=" params) +;; (handle-exceptions +;; exn +;; (begin +;; (print "ERROR: Failed to run command: " cmd " " (string-intersperse params " ")) +;; (print " " ((condition-property-accessor 'exn 'message) exn)) +;; #f) + (let-values (((fh fho pid fhe) (if (null? params) + (process* cmd) + (process* cmd params)))) + (let loop ((curr (read-line fh)) + (result '())) + (let ((errstr (process:conservative-read fhe))) + (if (not (string=? errstr "")) + (set! result (append result (list errstr))))) + (if (not (eof-object? curr)) + (loop (read-line fh) + (append result (list curr))) + (begin + ;(close-input-port fh) + ;(close-input-port fhe) + ;(close-output-port fho) + (let-values (((anotherpid normalexit? exitstatus) (process-wait pid))) + (list result (if normalexit? exitstatus -1)))))))) (define (process:cmd-run-proc-each-line cmd proc . params) ;; (print "Called with cmd=" cmd ", proc=" proc ", params=" params) (handle-exceptions exn