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 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,22 @@ (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 + " &"))) + (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 +2146,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 +2406,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 +2736,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