Overview
Comment: | Merged gui monitor, job launching stuff all into a single gui |
---|---|
Downloads: | Tarball | ZIP archive | SQL archive |
Timelines: | family | ancestors | descendants | both | new-gui |
Files: | files | file ages | folders |
SHA1: |
ff53dae2a1088301031403583159a421 |
User & Date: | mrwellan on 2012-12-17 13:06:41 |
Other Links: | branch diff | manifest | tags |
Context
2012-12-19
| ||
16:53 | yada check-in: c997a36b7c user: mrwellan tags: remote-run-capability | |
2012-12-17
| ||
13:06 | Merged gui monitor, job launching stuff all into a single gui Closed-Leaf check-in: ff53dae2a1 user: mrwellan tags: new-gui | |
09:32 | Moved tabs around in main gui. Changed configf.scm to not process #{} when not in allow-system mode check-in: 866c36fc2f user: mrwellan tags: trunk | |
Changes
Modified configf.scm from [7db68c2c56] to [fa6c390f67].
︙ | ︙ | |||
111 112 113 114 115 116 117 | ;; Lookup a value in runconfigs based on -reqtarg or -target (define (runconfigs-get config var) (let ((targ (or (args:get-arg "-reqtarg")(args:get-arg "-target")))) (if targ (config-lookup config targ var) #f))) | | | | | | | | | | | | 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 | ;; Lookup a value in runconfigs based on -reqtarg or -target (define (runconfigs-get config var) (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-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 ;; 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)(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-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) (begin (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-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-expand environ-patt: environ-patt curr-section: curr-section-name sections: sections) (change-directory curr-dir) (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)) (configf:key-sys-pr ( x key cmd ) (if allow-system (let ((alist (hash-table-ref/default res curr-section-name '())) |
︙ | ︙ | |||
180 181 182 183 184 185 186 | (hash-table-set! res curr-section-name (config:assoc-safe-add alist key (case allow-system ((return-procs) val-proc) ((return-string) cmd) (else (val-proc))))) | | | | | | | | 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 | (hash-table-set! res curr-section-name (config:assoc-safe-add alist key (case allow-system ((return-procs) val-proc) ((return-string) cmd) (else (val-proc))))) (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))) (debug:print-info 6 "read-config env setting, envar: " envar " realval: " realval " val: " val " key: " key " curr-section-name: " curr-section-name) (if envar (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-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" ;; trim lead from the incoming whsp to support some indenting. (if lead (string-substitute (regexp lead) "" whsp) "") 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-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-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)) (toppath (car configinfo)) (configfile (cadr configinfo))) |
︙ | ︙ |
Modified dashboard-guimonitor.scm from [74e70b90f3] to [04b2273746].
︙ | ︙ | |||
29 30 31 32 33 34 35 36 37 38 39 40 41 42 | (declare (uses tasks)) (include "common_records.scm") (include "db_records.scm") (include "run_records.scm") (include "task_records.scm") (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 #:title "Keys" (apply | > | 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 | (declare (uses tasks)) (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 #:title "Keys" (apply |
︙ | ︙ | |||
124 125 126 127 128 129 130 | ;; (tasks:process-queue db tdb monitordbpath) (tasks:monitors-update tdb) (tasks:reset-stuck-tasks tdb) (set! monitorsdat (tasks:get-monitors tdb)) (set! next-touch (+ (current-seconds) 10)) ))))) (topdialog #f)) | | | 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 | ;; (tasks:process-queue db tdb monitordbpath) (tasks:monitors-update tdb) (tasks:reset-stuck-tasks tdb) (set! monitorsdat (tasks:get-monitors tdb)) (set! next-touch (+ (current-seconds) 10)) ))))) (topdialog #f)) (set! topdialog (iup:vbox ;; iup:dialog #:close_cb (lambda (a)(exit)) #:title "Run Controls" (iup:vbox (iup:hbox keyentries othervars) controls (let ((tabtop (iup:tabs (iup:vbox |
︙ | ︙ | |||
153 154 155 156 157 158 159 | ; (iup:frame ; #:title "Monitors" ; monitors) ; (iup:frame ; #:title "Actions" ; actions)))) | | | > | 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 | ; (iup:frame ; #:title "Monitors" ; monitors) ; (iup:frame ; #:title "Actions" ; actions)))) ;; (iup:show topdialog) (iup:callback-set! *tim* "ACTION_CB" (lambda (x) (refreshdat) (if *exit-started* (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))) (iup:attribute-set! tabtop "TABTITLE0" "Setup") (iup:attribute-set! tabtop "TABTITLE1" "Collateral") |
︙ | ︙ |
Modified dashboard-main.scm from [7f5cc3138c] to [5522f9984b].
︙ | ︙ | |||
19 20 21 22 23 24 25 26 27 28 29 30 31 32 | (use canvas-draw) (use sqlite3 srfi-1 posix regex regex-case srfi-69) (import (prefix sqlite3 sqlite3:)) (declare (unit dashboard-main)) (declare (uses common)) (declare (uses keys)) (declare (uses db)) (declare (uses tasks)) (include "common_records.scm") (include "db_records.scm") | > | 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 | (use canvas-draw) (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)) (include "common_records.scm") (include "db_records.scm") |
︙ | ︙ | |||
51 52 53 54 55 56 57 | ;; ;; #:y 'mouse ;; ) )))) (define (mtest) (let* ((curr-row-num 0) | | | 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 | ;; ;; #:y 'mouse ;; ) )))) (define (mtest) (let* ((curr-row-num 0) (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 #:numcol-visible 1 #:numlin-visible 5 |
︙ | ︙ | |||
204 205 206 207 208 209 210 | (iup:hbox (iup:frame #:title "Tests browser"))) (define (runs) (iup:hbox (iup:frame #:title "Runs browser"))) | | > | | 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 | (iup:hbox (iup:frame #:title "Tests browser"))) (define (runs) (iup:hbox (iup:frame #:title "Runs browser"))) (define (main-panel db) (iup:dialog #:title "Menu Test" #:menu (main-menu) (let ((tabtop (iup:tabs (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))) |
Modified dashboard.scm from [5a6e0cab75] to [dd23c90b5f].
︙ | ︙ | |||
649 650 651 652 653 654 655 | (examine-test testid) (begin (print "ERROR: testid is not a number " (args:get-arg "-test")) (exit 1))))) ((args:get-arg "-guimonitor") (gui-monitor *db*)) ((args:get-arg "-main") | | | 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 | (examine-test testid) (begin (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 *db*))) (else (set! uidat (make-dashboard-buttons *num-runs* *num-tests* *dbkeys*)) (iup:callback-set! *tim* "ACTION_CB" (lambda (x) (run-update x))))) ;(print x))))) |
︙ | ︙ |
Modified items.scm from [225b8827e5] to [f7c63548ba].
︙ | ︙ | |||
118 119 120 121 122 123 124 | (if elflag (begin (set! res (append res (list item))) (loop (+ indx 1) '() #f))) res))) | | | | > > > | 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 | (if elflag (begin (set! res (append res (list item))) (loop (+ indx 1) '() #f))) res))) ;; 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 (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" '())) (itemstable (hash-table-ref/default tconfig "itemstable" '()))) (debug:print 5 "items: " items " itemstable: " itemstable) |
︙ | ︙ |
Modified tests/simplerun/megatest.config from [3fbc57ac34] to [b40d286eaf].
1 2 3 4 5 6 7 8 9 10 11 12 13 | [fields] SYSTEM TEXT RELEASE TEXT [setup] # Adjust max_concurrent_jobs to limit how much you load your machines max_concurrent_jobs 50 # 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] | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 | [fields] SYSTEM TEXT RELEASE TEXT [setup] # Adjust max_concurrent_jobs to limit how much you load your machines max_concurrent_jobs 50 # 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 0 # Job tools are more advanced ways to control how your jobs are launched [jobtools] useshell yes launcher nbfind # You can override environment variables for all your tests here |
︙ | ︙ |
Modified tests/tests.scm from [052cb1980d] to [68f35a9489].
︙ | ︙ | |||
152 153 154 155 156 157 158 | (list "start" "end" "completed")) (for-each (lambda (item) (test (conc "get valid items (" item ")") item (items:check-valid-items "status" item))) (list "pass" "fail" "n/a")) | | > > > | 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 | (list "start" "end" "completed")) (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 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")))) (test #f #t (cdb:client-call *runremote* 'immediate #t 1 (lambda ()(display "Got here eh!?") #t))) |
︙ | ︙ |