Index: configf.scm
==================================================================
--- configf.scm
+++ configf.scm
@@ -57,10 +57,11 @@
;;======================================================================
;; Make the regexp's needed globally available
;;======================================================================
(define configf:include-rx (regexp "^\\[include\\s+(.*)\\]\\s*$"))
+(define configf:script-rx (regexp "^\\[scriptinc\\s+(.*)\\]\\s*$")) ;; include output from a script
(define configf:section-rx (regexp "^\\[(.*)\\]\\s*$"))
(define configf:blank-l-rx (regexp "^\\s*$"))
(define configf:key-sys-pr (regexp "^(\\S+)\\s+\\[system\\s+(\\S+.*)\\]\\s*$"))
(define configf:key-val-pr (regexp "^(\\S+)(\\s+(.*)|())$"))
(define configf:key-no-val (regexp "^(\\S+)(\\s*)$"))
@@ -68,11 +69,11 @@
(define configf:cont-ln-rx (regexp "^(\\s+)(\\S+.*)$"))
(define configf:settings (regexp "^\\[configf:settings\\s+(\\S+)\\s+(\\S+)]\\s*$"))
;; read a line and process any #{ ... } constructs
-(define configf:var-expand-regex (regexp "^(.*)#\\{(scheme|system|shell|getenv|get|runconfigs-get|rget)\\s+([^\\}\\{]*)\\}(.*)"))
+(define configf:var-expand-regex (regexp "^(.*)#\\{(scheme|system|shell|getenv|get|runconfigs-get|rget|scm|sh|rp|gv|g|mtrah)\\s+([^\\}\\{]*)\\}(.*)"))
(define (configf:process-line l ht allow-system #!key (linenum #f))
(let loop ((res l))
(if (string? res)
(let ((matchdat (string-search configf:var-expand-regex res)))
@@ -83,36 +84,42 @@
(poststr (list-ref matchdat 4))
(result #f)
(start-time (current-seconds))
(cmdsym (string->symbol cmdtype))
(fullcmd (case cmdsym
- ((scheme)(conc "(lambda (ht)" cmd ")"))
- ((system)(conc "(lambda (ht)(system \"" cmd "\"))"))
- ((shell) (conc "(lambda (ht)(shell \"" cmd "\"))"))
- ((getenv)(conc "(lambda (ht)(get-environment-variable \"" cmd "\"))"))
- ((get)
+ ((scheme scm) (conc "(lambda (ht)" cmd ")"))
+ ((system) (conc "(lambda (ht)(system \"" cmd "\"))"))
+ ((shell sh) (conc "(lambda (ht)(string-translate (shell \"" cmd "\") \"\n\" \" \"))"))
+ ((realpath rp)(conc "(lambda (ht)(common:nice-path \"" cmd "\"))"))
+ ((getenv gv) (conc "(lambda (ht)(get-environment-variable \"" cmd "\"))"))
+ ((mtrah) (conc "(lambda (ht)"
+ " (let ((extra \"" cmd "\"))"
+ " (conc (or *toppath* (get-environment-variable \"MT_RUN_AREA_HOME\"))"
+ " (if (string-null? extra) \"\" \"/\")"
+ " extra)))"))
+ ((get g)
(let* ((parts (string-split cmd))
(sect (car parts))
(var (cadr parts)))
(conc "(lambda (ht)(config-lookup ht \"" sect "\" \"" var "\"))")))
- ((runconfigs-get) (conc "(lambda (ht)(runconfigs-get ht \"" cmd "\"))"))
- ((rget) (conc "(lambda (ht)(runconfigs-get ht \"" cmd "\"))"))
+ ((runconfigs-get rget) (conc "(lambda (ht)(runconfigs-get ht \"" cmd "\"))"))
+ ;; ((rget) (conc "(lambda (ht)(runconfigs-get ht \"" cmd "\"))"))
(else "(lambda (ht)(print \"ERROR\") \"ERROR\")"))))
;; (print "fullcmd=" fullcmd)
(handle-exceptions
exn
(begin
(debug:print 0 *default-log-port* "WARNING: failed to process config input \"" l "\"")
(debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
;; (print "exn=" (condition->list exn))
- (set! result (conc "#{( " cmdtype ") " cmd"}")))
+ (set! result (conc "#{( " cmdtype ") " cmd "}, full expansion: " fullcmd)))
(if (or allow-system
- (not (member cmdtype '("system" "shell"))))
+ (not (member cmdtype '("system" "shell" "sh"))))
(with-input-from-string fullcmd
(lambda ()
(set! result ((eval (read)) ht))))
- (set! result (conc "#{(" cmdtype ") " cmd "}"))))
+ (set! result (conc "#{(" cmdtype ") " cmd "}"))))
(case cmdsym
((system shell scheme)
(let ((delta (- (current-seconds) start-time)))
(if (> delta 2)
(debug:print-info 0 *default-log-port* "for line \"" l "\"\n command: " cmd " took " delta " seconds to run with output:\n " result)
@@ -182,16 +189,19 @@
;; post-section-procs alist of section-pattern => proc, where: (proc section-name next-section-name ht curr-path)
;;
(define (read-config path ht allow-system #!key (environ-patt #f)(curr-section #f)(sections #f)(settings (make-hash-table))(keep-filenames #f)(post-section-procs '()))
(debug:print-info 5 *default-log-port* "read-config " path " allow-system " allow-system " environ-patt " environ-patt " curr-section: " curr-section " sections: " sections " pwd: " (current-directory))
(debug:print 9 *default-log-port* "START: " path)
- (if (not (file-exists? path))
+ (if (and (not (port? path))
+ (not (file-exists? path))) ;; for case where we are handed a port
(begin
(debug:print-info 1 *default-log-port* "read-config - file not found " path " current path: " (current-directory))
;; WARNING: This is a risky change but really, we should not return an empty hash table if no file read?
#f) ;; (if (not ht)(make-hash-table) ht))
- (let ((inp (open-input-file path))
+ (let ((inp (if (string? path)
+ (open-input-file path)
+ path)) ;; we can be handed a port
(res (if (not ht)(make-hash-table) ht))
(metapath (if (or (debug:debug-mode 9)
keep-filenames)
path #f)))
(let loop ((inl (configf:read-line inp res (calc-allow-system allow-system curr-section sections) settings)) ;; (read-line inp))
@@ -199,11 +209,12 @@
(var-flag #f);; turn on for key-var-pr and cont-ln-rx, turn off elsewhere
(lead #f))
(debug:print-info 8 *default-log-port* "curr-section-name: " curr-section-name " var-flag: " var-flag "\n inl: \"" inl "\"")
(if (eof-object? inl)
(begin
- (close-input-port inp)
+ (if (string? path) ;; we received a path, not a port, thus we are responsible for closing it.
+ (close-input-port inp))
(hash-table-delete! res "") ;; we are using "" as a dumping ground and must remove it before returning the ht
(debug:print 9 *default-log-port* "END: " path)
res)
(regex-case
inl
@@ -229,10 +240,26 @@
(loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f))
(begin
(debug:print '(2 9) #f "INFO: include file " include-file " not found (called from " path ")")
(debug:print 2 *default-log-port* " " full-conf)
(loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f)))))
+ (configf:script-rx ( x include-script );; handle-exceptions
+ ;; exn
+ ;; (begin
+ ;; (debug:print '(0 2 9) #f "INFO: include from script " include-script " failed.")
+ ;; (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f))
+ (if (and (file-exists? include-script)(file-execute-access? include-script))
+ (let* ((new-inp-port (open-input-pipe include-script)))
+ (debug:print '(2 9) *default-log-port* "Including from script output: " include-script)
+ ;; (print "We got here, calling read-config next. Port is: " new-inp-port)
+ (read-config new-inp-port res allow-system environ-patt: environ-patt curr-section: curr-section-name sections: sections settings: settings keep-filenames: keep-filenames)
+ (close-input-port new-inp-port)
+ (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f))
+ (begin
+ (debug:print 0 *default-log-port* "Script not found or not exectutable: " include-script)
+ (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f)))
+ ) ;; )
(configf:section-rx ( x section-name ) (begin
;; call post-section-procs
(for-each
(lambda (dat)
(let ((patt (car dat))
Index: db.scm
==================================================================
--- db.scm
+++ db.scm
@@ -739,11 +739,11 @@
;; Add db direct
;;
(define (db:dispatch-query access-mode rmt-cmd db-cmd . params)
(if (eq? access-mode 'cached)
- (print "not doing cached calls right now"))
+ (debug:print 2 *default-log-port* "not doing cached calls right now"))
;; (apply db:call-with-cached-db db-cmd params)
(apply rmt-cmd params))
;;)
;; return the target db handle so it can be used
@@ -3055,23 +3055,26 @@
(set! row-ids (cons rid row-ids)))
runsqry)
(sqlite3:finalize! runsqry)
row-ids))
+;; finds latest matching all patts for given run-id
+;;
(define (db:test-get-paths-matching-keynames-target-new dbstruct run-id keynames target res testpatt statepatt statuspatt runname)
(let* ((testqry (tests:match->sqlqry testpatt))
- (tstsqry (conc "SELECT rundir FROM tests WHERE " testqry " AND state LIKE '" statepatt "' AND status LIKE '" statuspatt "' ORDER BY event_time ASC;")))
+ (tstsqry (conc "SELECT rundir FROM tests WHERE run_id=? AND " testqry " AND state LIKE '" statepatt "' AND status LIKE '" statuspatt "' ORDER BY event_time ASC;")))
(db:with-db
dbstruct
run-id
#f
(lambda (db)
(sqlite3:for-each-row
(lambda (p)
(set! res (cons p res)))
db
- tstsqry)
+ tstsqry
+ run-id)
res))))
(define (db:test-toplevel-num-items dbstruct run-id testname)
(db:with-db
dbstruct
Index: docs/manual/megatest_manual.html
==================================================================
--- docs/manual/megatest_manual.html
+++ docs/manual/megatest_manual.html
@@ -1,10 +1,10 @@
-
+
The Megatest Users Manual