Index: configf.scm ================================================================== --- configf.scm +++ configf.scm @@ -113,13 +113,13 @@ (let ((targ (or (args:get-arg "-reqtarg")(args:get-arg "-target")))) (if targ (config-lookup config targ var) #f))) -(define-inline (configf:read-line p ht allow-processing) - (if (and allow-processing - (not (eq? allow-processing 'return-string))) +(define-inline (configf:read-line p ht allow-expand) + (if (and allow-expand + (not (eq? allow-expand 'return-string))) (configf:process-line (read-line p) ht) (read-line p))) ;; read a config file, returns hash table of alists @@ -126,19 +126,19 @@ ;; read a config file, returns hash table of alists ;; adds to ht if given (must be #f otherwise) ;; envion-patt is a regex spec that identifies sections that will be eval'd ;; in the environment on the fly ;; sections: #f => get all, else list of sections to gather -(define (read-config path ht allow-system #!key (environ-patt #f)(curr-section #f)(sections #f)) +(define (read-config path ht allow-system #!key (environ-patt #f)(curr-section #f)(sections #f)(allow-expand #t)) (debug:print-info 4 "read-config " path " allow-system " allow-system " environ-patt " environ-patt " curr-section: " curr-section " sections: " sections) (if (not (file-exists? path)) (begin (debug:print-info 4 "read-config - file not found " path " current path: " (current-directory)) (if (not ht)(make-hash-table) ht)) (let ((inp (open-input-file path)) (res (if (not ht)(make-hash-table) ht))) - (let loop ((inl (configf:read-line inp res allow-system)) ;; (read-line inp)) + (let loop ((inl (configf:read-line inp res allow-expand)) ;; (read-line inp)) (curr-section-name (if curr-section curr-section "default")) (var-flag #f);; turn on for key-var-pr and cont-ln-rx, turn off elsewhere (lead #f)) (debug:print-info 8 "curr-section-name: " curr-section-name " var-flag: " var-flag "\n inl: \"" inl "\"") (if (eof-object? inl) @@ -146,19 +146,19 @@ (close-input-port inp) (hash-table-delete! res "") ;; we are using "" as a dumping ground and must remove it before returning the ht res) (regex-case inl - (configf:comment-rx _ (loop (configf:read-line inp res allow-system) curr-section-name #f #f)) - (configf:blank-l-rx _ (loop (configf:read-line inp res allow-system) curr-section-name #f #f)) + (configf:comment-rx _ (loop (configf:read-line inp res allow-expand) curr-section-name #f #f)) + (configf:blank-l-rx _ (loop (configf:read-line inp res allow-expand) curr-section-name #f #f)) (configf:include-rx ( x include-file ) (let ((curr-dir (current-directory)) (conf-dir (pathname-directory path))) (if conf-dir (change-directory conf-dir)) - (read-config include-file res allow-system environ-patt: environ-patt curr-section: curr-section-name sections: sections) + (read-config include-file res allow-expand environ-patt: environ-patt curr-section: curr-section-name sections: sections) (change-directory curr-dir) - (loop (configf:read-line inp res allow-system) curr-section-name #f #f))) - (configf:section-rx ( x section-name ) (loop (configf:read-line inp res allow-system) + (loop (configf:read-line inp res allow-expand) curr-section-name #f #f))) + (configf:section-rx ( x section-name ) (loop (configf:read-line inp res allow-expand) ;; if we have the sections list then force all settings into "" and delete it later? (if (or (not sections) (member section-name sections)) section-name "") ;; stick everything into "" #f #f)) @@ -182,12 +182,12 @@ key (case allow-system ((return-procs) val-proc) ((return-string) cmd) (else (val-proc))))) - (loop (configf:read-line inp res allow-system) curr-section-name #f #f)) - (loop (configf:read-line inp res allow-system) curr-section-name #f #f))) + (loop (configf:read-line inp res allow-expand) curr-section-name #f #f)) + (loop (configf:read-line inp res allow-expand) curr-section-name #f #f))) (configf:key-val-pr ( x key unk1 val unk2 ) (let* ((alist (hash-table-ref/default res curr-section-name '())) (envar (and environ-patt (string-search (regexp environ-patt) curr-section-name))) (realval (if envar (config:eval-string-in-environment val) val))) @@ -196,11 +196,11 @@ (begin ;; (debug:print-info 4 "read-config key=" key ", val=" val ", realval=" realval) (setenv key realval))) (hash-table-set! res curr-section-name (config:assoc-safe-add alist key realval)) - (loop (configf:read-line inp res allow-system) curr-section-name key #f))) + (loop (configf:read-line inp res allow-expand) curr-section-name key #f))) ;; if a continued line (configf:cont-ln-rx ( x whsp val ) (let ((alist (hash-table-ref/default res curr-section-name '()))) (if var-flag ;; if set to a string then we have a continued var (let ((newval (conc (config-lookup res curr-section-name var-flag) "\n" @@ -210,15 +210,15 @@ "") val))) ;; (print "val: " val "\nnewval: \"" newval "\"\nvarflag: " var-flag) (hash-table-set! res curr-section-name (config:assoc-safe-add alist var-flag newval)) - (loop (configf:read-line inp res allow-system) curr-section-name var-flag (if lead lead whsp))) - (loop (configf:read-line inp res allow-system) curr-section-name #f #f)))) + (loop (configf:read-line inp res allow-expand) curr-section-name var-flag (if lead lead whsp))) + (loop (configf:read-line inp res allow-expand) curr-section-name #f #f)))) (else (debug:print 0 "ERROR: problem parsing " path ",\n \"" inl "\"") (set! var-flag #f) - (loop (configf:read-line inp res allow-system) curr-section-name #f #f)))))))) + (loop (configf:read-line inp res allow-expand) curr-section-name #f #f)))))))) ;; pathenvvar will set the named var to the path of the config (define (find-and-read-config fname #!key (environ-patt #f)(given-toppath #f)(pathenvvar #f)) (let* ((curr-dir (current-directory)) (configinfo (find-config fname toppath: given-toppath)) Index: dashboard-guimonitor.scm ================================================================== --- dashboard-guimonitor.scm +++ dashboard-guimonitor.scm @@ -31,10 +31,11 @@ (include "common_records.scm") (include "db_records.scm") (include "run_records.scm") (include "task_records.scm") +;; tdb is the tasks database (monitor.db) (define (control-panel db tdb keys) (let* ((var-params (make-hash-table)) ;; register all the widgets here for querying on run, rollup, remove? (key-params (make-hash-table)) (monitordat '()) ;; list of monitor records (keyentries (iup:frame @@ -126,11 +127,11 @@ (tasks:reset-stuck-tasks tdb) (set! monitorsdat (tasks:get-monitors tdb)) (set! next-touch (+ (current-seconds) 10)) ))))) (topdialog #f)) - (set! topdialog (iup:dialog + (set! topdialog (iup:vbox ;; iup:dialog #:close_cb (lambda (a)(exit)) #:title "Run Controls" (iup:vbox (iup:hbox keyentries othervars) controls @@ -155,16 +156,17 @@ ; monitors) ; (iup:frame ; #:title "Actions" ; actions)))) - (iup:show topdialog) + ;; (iup:show topdialog) (iup:callback-set! *tim* "ACTION_CB" (lambda (x) (refreshdat) (if *exit-started* - (set! *exit-started* 'ok)))))) + (set! *exit-started* 'ok)))) + topdialog)) (define (main-window setuptab fsltab collateraltab toolstab) (iup:show (iup:dialog #:title "FSL Power Window" #:size "290x190" ; #:expand "YES" (let ((tabtop (iup:tabs setuptab collateraltab fsltab toolstab))) Index: dashboard-main.scm ================================================================== --- dashboard-main.scm +++ dashboard-main.scm @@ -21,10 +21,11 @@ (use sqlite3 srfi-1 posix regex regex-case srfi-69) (import (prefix sqlite3 sqlite3:)) (declare (unit dashboard-main)) +(declare (uses dashboard-guimonitor)) (declare (uses common)) (declare (uses keys)) (declare (uses db)) (declare (uses tasks)) @@ -53,11 +54,11 @@ )))) (define (mtest) (let* ((curr-row-num 0) - (rawconfig (read-config (conc *toppath* "/megatest.config") #f 'return-string)) + (rawconfig (read-config (conc *toppath* "/megatest.config") #f 'return-string allow-expand: #f)) (keys-matrix (iup:matrix #:expand "VERTICAL" ;; #:scrollbar "YES" #:numcol 1 #:numlin 20 @@ -206,20 +207,21 @@ (define (runs) (iup:hbox (iup:frame #:title "Runs browser"))) -(define (main-panel) +(define (main-panel db) (iup:dialog #:title "Menu Test" #:menu (main-menu) (let ((tabtop (iup:tabs - (runs) + (gui-monitor db) ;; (control-panel db tdb) + ;; (runs) (mtest) (rconfig) (tests) ))) (iup:attribute-set! tabtop "TABTITLE0" "Runs") (iup:attribute-set! tabtop "TABTITLE3" "Tests") (iup:attribute-set! tabtop "TABTITLE1" "megatest.config") (iup:attribute-set! tabtop "TABTITLE2" "runconfigs.config") tabtop))) Index: dashboard.scm ================================================================== --- dashboard.scm +++ dashboard.scm @@ -651,11 +651,11 @@ (print "ERROR: testid is not a number " (args:get-arg "-test")) (exit 1))))) ((args:get-arg "-guimonitor") (gui-monitor *db*)) ((args:get-arg "-main") - (iup:show (main-panel))) + (iup:show (main-panel *db*))) (else (set! uidat (make-dashboard-buttons *num-runs* *num-tests* *dbkeys*)) (iup:callback-set! *tim* "ACTION_CB" (lambda (x) Index: items.scm ================================================================== --- items.scm +++ items.scm @@ -120,18 +120,21 @@ (set! res (append res (list item))) (loop (+ indx 1) '() #f))) res))) - ;; Nope, not now, return null as of 6/6/2011 +;; Nope, not now, return null as of 6/6/2011 (define (items:check-valid-items class item) (let ((valid-values (let ((s (config-lookup *configdat* "validvalues" class))) (if s (string-split s) #f)))) (if valid-values - (if (member item valid-values) - item #f) + (if (member (conc item) valid-values) + item + (begin + (debug:print-info 1 item " not found in " valid-values) + #f)) item))) (define (items:get-items-from-config tconfig) (let* (;; db is always at *toppath*/db/megatest.db (items (hash-table-ref/default tconfig "items" '())) Index: tests/simplerun/megatest.config ================================================================== --- tests/simplerun/megatest.config +++ tests/simplerun/megatest.config @@ -9,11 +9,11 @@ # This is your link path, you can move it but it is generally better to keep it stable linktree #{shell realpath #{getenv PWD}/../simplelinks} # Valid values for state and status for steps, NB// It is not recommended you use this [validvalues] -state start end completed +state start end completed 0 # Job tools are more advanced ways to control how your jobs are launched [jobtools] useshell yes launcher nbfind Index: tests/tests.scm ================================================================== --- tests/tests.scm +++ tests/tests.scm @@ -154,11 +154,14 @@ (for-each (lambda (item) (test (conc "get valid items (" item ")") item (items:check-valid-items "status" item))) (list "pass" "fail" "n/a")) -(test #f #f (items:check-valid-items "state" "blahfool")) +(test #f #f (items:check-valid-items "state" "blahfool")) +(test #f 0 (items:check-valid-items "state" 0)) +(test #f "0" (items:check-valid-items "state" "0")) +(test #f "foo" (items:check-valid-items "nada" "foo")) (test "write env files" "nada.csh" (begin (save-environment-as-files "nada") (and (file-exists? "nada.sh") (file-exists? "nada.csh"))))