Index: Makefile
==================================================================
--- Makefile
+++ Makefile
@@ -202,11 +202,11 @@
# Special dependencies for the includes
$(MOFILE) $(MOIMPFILES) : megatest-fossil-hash.scm
mofiles/commonmod.o : mofiles/debugprint.o megatest-fossil-hash.scm
common.o : mofiles/commonmod.o
-mofiles/configfmod.o : mofiles/commonmod.o
+mofiles/configfmod.o : mofiles/commonmod.o configf-guts.scm
# mofiles/dbmod.o : mofiles/configfmod.o
# commonmod.o dashboard.o megatest.o tcmt.o apimod.o : megatest-fossil-hash.scm
Index: commonmod.scm
==================================================================
--- commonmod.scm
+++ commonmod.scm
@@ -2735,7 +2735,9 @@
(define (common:get-fields cfgdat)
(let ((fields (hash-table-ref/default cfgdat "fields" '())))
(map car fields)))
(define keys:config-get-fields common:get-fields)
+
+
)
ADDED configf-guts.scm
Index: configf-guts.scm
==================================================================
--- /dev/null
+++ configf-guts.scm
@@ -0,0 +1,427 @@
+;;======================================================================
+;; Copyright 2006-2012, Matthew Welland.
+;;
+;; This file is part of Megatest.
+;;
+;; Megatest is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+;;
+;; Megatest is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with Megatest. If not, see .
+
+;;======================================================================
+
+;;======================================================================
+;; Config file handling
+;;======================================================================
+
+;; (use regex regex-case matchable) ;; directory-utils)
+;; (declare (unit configf))
+;; (declare (uses process))
+;; (declare (uses env))
+;; (declare (uses keys))
+;; (declare (uses debugprint))
+;; (declare (uses mtargs))
+;; (declare (uses mtargs.import))
+;; (declare (uses common))
+;; (declare (uses commonmod))
+;; (declare (uses commonmod.import))
+;; (declare (uses processmod))
+;; (declare (uses processmod.import))
+;; (declare (uses configfmod))
+;; (declare (uses configfmod.import))
+;; (declare (uses dbfile))
+;; (declare (uses dbfile.import))
+;; (declare (uses dbmod))
+;; (declare (uses dbmod.import))
+;; (declare (uses mtmod))
+;; (declare (uses mtmod.import))
+;; (declare (uses megatestmod))
+;; (declare (uses megatestmod.import))
+;;
+;; (import commonmod
+;; configfmod
+;; processmod
+;; (prefix mtargs args:)
+;; debugprint
+;; mtmod
+;; )
+;;
+;; (include "common_records.scm")
+
+(define configf:imports "(import commonmod configfmod processmod (prefix mtargs args:))")
+
+
+(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)))
+ (if matchdat
+ (let* ((prestr (list-ref matchdat 1))
+ (cmdtype (list-ref matchdat 2)) ;; eval, system, shell, getenv
+ (cmd (list-ref matchdat 3))
+ (poststr (list-ref matchdat 4))
+ (result #f)
+ (start-time (current-seconds))
+ (cmdsym (string->symbol cmdtype))
+ (fullcmd (case cmdsym
+ ((scheme scm) (conc "(lambda (ht)(begin " configf:imports cmd "))"))
+ ((system) (conc "(lambda (ht)(configf:system ht \"" 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)
+ (match (string-split cmd)
+ ((sect var)(conc "(lambda (ht)(configf:lookup ht \"" sect "\" \"" var "\"))"))
+ (else
+ (debug:print-error 0 *default-log-port* "#{get ...} used with only one parameter, \"" cmd "\", two needed.")
+ "(lambda (ht) #f)")))
+ ((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 "\", exn=" exn)
+ (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
+ ;; (print "exn=" (condition->list exn))
+ (set! result (conc "#{( " cmdtype ") " cmd "}, full expansion: " fullcmd)))
+ (if (or allow-system
+ (not (member cmdtype '("system" "shell" "sh"))))
+ (with-input-from-string fullcmd
+ (lambda ()
+ (set! result ((eval (read)) ht))))
+ (set! result (conc "#{(" cmdtype ") " cmd "}"))))
+ (case cmdsym
+ ((system shell scheme)
+ (let ((delta (- (current-seconds) start-time)))
+ (if (> delta 2)
+ (debug:print-info 2 *default-log-port* "for line \"" l "\"\n command: " cmd " took " delta " seconds to run with output:\n " result)
+ (debug:print-info 9 *default-log-port* "for line \"" l "\"\n command: " cmd " took " delta " seconds to run with output:\n " result)))))
+ (loop (conc prestr result poststr)))
+ res))
+ res)))
+
+;; this was inline but I'm pretty sure that is a hold over from when it was *very* simple ...
+;;
+(define (configf:read-line p ht allow-processing settings)
+ (let loop ((inl (read-line p)))
+ (let ((cont-line (and (string? inl)
+ (not (string-null? inl))
+ (equal? "\\" (string-take-right inl 1)))))
+ (if cont-line ;; last character is \
+ (let ((nextl (read-line p)))
+ (if (not (eof-object? nextl))
+ (loop (string-append (if cont-line
+ (string-take inl (- (string-length inl) 1))
+ inl)
+ nextl))))
+ (let ((res (case allow-processing ;; if (and allow-processing
+ ;; (not (eq? allow-processing 'return-string)))
+ ((#t #f)
+ (configf:process-line inl ht allow-processing))
+ ((return-string)
+ inl)
+ (else
+ (configf:process-line inl ht allow-processing)))))
+ (if (and (string? res) ;; must set to "no" to force NOT trimming trailing spaces
+ (not (equal? (hash-table-ref/default settings "trim-trailing-spaces" "yes") "no")))
+ (string-substitute "\\s+$" "" res)
+ res))))))
+
+;; 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)
+;; allow-system:
+;; #f - do not evaluate [system
+;; #t - immediately evaluate [system and store result as string
+;; 'return-procs -- return a proc taking ht as an argument that may be evaulated at some future time
+;; 'return-string -- return a string representing a proc taking ht as an argument that may be evaulated at some future time
+;; 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
+;; post-section-procs alist of section-pattern => proc, where: (proc section-name next-section-name ht curr-path)
+;; apply-wildcards: #t/#f - apply vars from targets with % wildcards to all matching sections
+;;
+(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 '()) (apply-wildcards #t) )
+ (debug:print 9 *default-log-port* "START: " path)
+;; (if *configdat*
+;; (common:save-pkt `((action . read-config)
+;; (f . ,(cond ((string? path) path)
+;; ((port? path) "port")
+;; (else (conc path))))
+;; (T . configf))
+;; *configdat* #t add-only: #t))
+ (if (and (not (port? path))
+ (not (common: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 (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))
+ (process-wildcards (lambda (res curr-section-name)
+ (if (and apply-wildcards
+ (or (string-contains curr-section-name "%") ;; wildcard
+ (string-match "/.*/" curr-section-name))) ;; regex
+ (begin
+ (configf:apply-wildcards res curr-section-name)
+ (hash-table-delete! res curr-section-name)))))) ;; NOTE: if the section is a wild card it will be REMOVED from res
+ (let loop ((inl (configf:read-line inp res (calc-allow-system allow-system curr-section sections) settings)) ;; (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 *default-log-port* "curr-section-name: " curr-section-name " var-flag: " var-flag "\n inl: \"" inl "\"")
+ (if (eof-object? inl)
+ (begin
+ ;; process last section for wildcards
+ (process-wildcards res curr-section-name)
+ (if (string? path) ;; we received a path, not a port, thus we are responsible for closing it.
+ (close-input-port inp))
+ (if (list? sections) ;; delete all sections except given when sections is provided
+ (for-each
+ (lambda (section)
+ (if (not (member section sections))
+ (hash-table-delete! res section))) ;; we are using "" as a dumping ground and must remove it before returning the ht
+ (hash-table-keys res)))
+ (debug:print 9 *default-log-port* "END: " path)
+ res
+ ) ;; retval
+ (regex-case
+ inl
+ (configf:comment-rx _ (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings)
+ curr-section-name #f #f))
+
+ (configf:blank-l-rx _ (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings)
+ curr-section-name #f #f))
+ (configf:settings ( x setting val )
+ (begin
+ (hash-table-set! settings setting val)
+ (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings)
+ curr-section-name #f #f)))
+
+ (configf:include-rx ( x include-file )
+ (let* ((curr-conf-dir (pathname-directory path))
+ (full-conf (if (and (absolute-pathname? include-file) (file-exists? include-file))
+ include-file
+ (common:nice-path
+ (conc (if curr-conf-dir
+ curr-conf-dir
+ ".")
+ "/" include-file)))))
+ (let ((all-matches (sort (handle-exceptions exn
+ (begin
+ (debug:print '(2 9) *default-log-port* "glob of " full-conf " gave no match. , exn=" exn)
+ (list))
+ (glob full-conf)) string<=?)))
+ (if (null? all-matches)
+ (begin
+ (debug:print '(2 9) #f "INFO: include file(s) matching " include-file " not found (called from " path ")")
+ (debug:print 2 *default-log-port* " " full-conf))
+ (for-each
+ (lambda (fpath)
+ ;; (push-directory conf-dir)
+ (debug:print 9 *default-log-port* "Including: " full-conf)
+ (read-config fpath res allow-system environ-patt: environ-patt
+ curr-section: curr-section-name sections: sections settings: settings
+ keep-filenames: keep-filenames))
+ all-matches))
+ (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 params);; 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 (common:file-exists? include-script)(file-execute-access? include-script))
+ (let* ((local-allow-system (calc-allow-system allow-system curr-section-name sections))
+ (env-delta (configf:cfgdat->env-alist curr-section-name res local-allow-system))
+ (new-inp-port
+ (common:with-env-vars
+ env-delta
+ (lambda ()
+ (open-input-pipe (conc include-script " " params))))))
+ (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))
+ (proc (cdr dat)))
+ (if (string-match patt curr-section-name)
+ (proc curr-section-name section-name res path))))
+ post-section-procs)
+ ;; after gathering the vars for a section and if apply-wildcards is true and if there is a wildcard in the section name process wildcards
+ ;; NOTE: we are processing the curr-section-name, NOT section-name.
+ (process-wildcards res curr-section-name)
+ (if (not (hash-table-ref/default res section-name #f))(hash-table-set! res section-name '())) ;; ensure that mere mention of a section is not lost
+ (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings)
+ ;; 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 "". NOPE: We need new strategy. Put stuff in correct sections and then delete all sections later.
+ section-name
+ #f #f)))
+ (configf:key-sys-pr ( x key cmd )
+ (if (calc-allow-system allow-system curr-section-name sections)
+ (let ((alist (hash-table-ref/default res curr-section-name '()))
+ (val-proc (lambda ()
+ (let* ((start-time (current-seconds))
+ (local-allow-system (calc-allow-system allow-system curr-section-name sections))
+ (env-delta (configf:cfgdat->env-alist curr-section-name res local-allow-system))
+ (cmdres (process:cmd-run->list cmd delta-env-alist-or-hash-table: env-delta)) ;; BB: here is where [system is exec'd. needs to have env from other vars!
+ (delta (- (current-seconds) start-time))
+ (status (cadr cmdres))
+ (res (car cmdres)))
+ (debug:print-info 4 *default-log-port* "" inl "\n => " (string-intersperse res "\n"))
+ (if (not (eq? status 0))
+ (begin
+ (debug:print-error 0 *default-log-port* "problem with " inl ", return code " status
+ " output: " cmdres)))
+ (if (> delta 2)
+ (debug:print-info 0 *default-log-port* "for line \"" inl "\"\n command: " cmd " took " delta " seconds to run with output:\n " res)
+ (debug:print-info 9 *default-log-port* "for line \"" inl "\"\n command: " cmd " took " delta " seconds to run with output:\n " res))
+ (if (null? res)
+ ""
+ (string-intersperse res " "))))))
+ (hash-table-set! res curr-section-name
+ (configf:assoc-safe-add alist
+ key
+ (case (calc-allow-system allow-system curr-section-name sections)
+ ((return-procs) val-proc)
+ ((return-string) cmd)
+ (else (val-proc)))
+ metadata: metapath))
+ (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f))
+ (loop (configf:read-line inp res
+ (calc-allow-system allow-system curr-section-name sections)
+ settings)
+ curr-section-name #f #f)))
+
+ (configf:key-no-val ( x key val)
+ (let* ((alist (hash-table-ref/default res curr-section-name '()))
+ (fval (or (if (string? val) val #f) ""))) ;; fval should be either "" or " " (one or more spaces)
+ (debug:print 10 *default-log-port* " setting: [" curr-section-name "] " key " = #t")
+ (safe-setenv key fval)
+ (hash-table-set! res curr-section-name
+ (configf:assoc-safe-add alist key fval metadata: metapath))
+ (loop (configf:read-line inp res
+ (calc-allow-system allow-system curr-section-name sections)
+ settings)
+ curr-section-name key #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) ;; does the section match the envionpatt?
+ (and (not (string-null? key))
+ (not (equal? "!" (substring key 0 1)))) ;; ! as leading character is a signature to NOT export to the environment
+ ;; (string-match "^.*:.*:.*$" key) ;; ;; something:something:something reserved for triggers in runconfigs
+ ))
+ (realval (if envar
+ (configf:eval-string-in-environment val)
+ val)))
+ (debug:print-info 6 *default-log-port* "read-config env setting, envar: " envar " realval: " realval " val: " val " key: " key " curr-section-name: " curr-section-name)
+ (if envar (safe-setenv key realval))
+ (debug:print 10 *default-log-port* " setting: [" curr-section-name "] " key " = " val)
+ (hash-table-set! res curr-section-name
+ (configf:assoc-safe-add alist key realval metadata: metapath))
+ (loop (configf:read-line inp res
+ (calc-allow-system allow-system curr-section-name sections) settings)
+ 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
+ (configf: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
+ (configf:assoc-safe-add alist var-flag newval metadata: metapath))
+ (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name var-flag (if lead lead whsp)))
+ (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f))))
+ (else (debug:print-error 0 *default-log-port* "problem parsing " path ",\n \"" inl "\"")
+ (set! var-flag #f)
+ (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f))))
+ ) ;; end loop
+ )))
+
+(define (setup)
+ (let* ((configf (find-config "megatest.config"))
+ (config (if configf (read-config configf #f #t) #f)))
+ (if config
+ (setenv "RUN_AREA_HOME" (pathname-directory configf)))
+ config))
+
+;;======================================================================
+;; refdb
+;;======================================================================
+
+;; reads a refdb into an assoc array of assoc arrays
+;; returns (list dat msg)
+(define (configf:read-refdb refdb-path)
+ (let ((sheets-file (conc refdb-path "/sheet-names.cfg")))
+ (if (not (common:file-exists? sheets-file))
+ (list #f (conc "ERROR: no refdb found at " refdb-path))
+ (if (not (file-read-access? sheets-file))
+ (list #f (conc "ERROR: refdb file not readable at " refdb-path))
+ (let* ((sheets (with-input-from-file sheets-file
+ (lambda ()
+ (let loop ((inl (read-line))
+ (res '()))
+ (if (eof-object? inl)
+ (reverse res)
+ (loop (read-line)(cons inl res)))))))
+ (data '()))
+ (for-each
+ (lambda (sheet-name)
+ (let* ((dat-path (conc refdb-path "/" sheet-name ".dat"))
+ (ref-dat (configf:read-file dat-path #f #t))
+ (ref-assoc (map (lambda (key)
+ (list key (hash-table-ref ref-dat key)))
+ (hash-table-keys ref-dat))))
+ ;; (hash-table->alist ref-dat)))
+ ;; (set! data (append data (list (list sheet-name ref-assoc))))))
+ (set! data (cons (list sheet-name ref-assoc) data))))
+ sheets)
+ (list data "NO ERRORS"))))))
+
+;; redefines
+(define config-lookup configf:lookup)
+(define configf:read-file read-config)
+
Index: configf.scm
==================================================================
--- configf.scm
+++ configf.scm
@@ -41,386 +41,12 @@
(declare (uses dbfile.import))
(declare (uses dbmod))
(declare (uses dbmod.import))
(declare (uses mtmod))
(declare (uses mtmod.import))
-
-(import commonmod
- configfmod
- processmod
- (prefix mtargs args:)
- debugprint
- mtmod
- )
-
-(include "common_records.scm")
-
-(define configf:imports "(import commonmod configfmod processmod (prefix mtargs args:))")
-
-
-(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)))
- (if matchdat
- (let* ((prestr (list-ref matchdat 1))
- (cmdtype (list-ref matchdat 2)) ;; eval, system, shell, getenv
- (cmd (list-ref matchdat 3))
- (poststr (list-ref matchdat 4))
- (result #f)
- (start-time (current-seconds))
- (cmdsym (string->symbol cmdtype))
- (fullcmd (case cmdsym
- ((scheme scm) (conc "(lambda (ht)(begin " configf:imports cmd "))"))
- ((system) (conc "(lambda (ht)(configf:system ht \"" 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)
- (match (string-split cmd)
- ((sect var)(conc "(lambda (ht)(configf:lookup ht \"" sect "\" \"" var "\"))"))
- (else
- (debug:print-error 0 *default-log-port* "#{get ...} used with only one parameter, \"" cmd "\", two needed.")
- "(lambda (ht) #f)")))
- ((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 "\", exn=" exn)
- (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
- ;; (print "exn=" (condition->list exn))
- (set! result (conc "#{( " cmdtype ") " cmd "}, full expansion: " fullcmd)))
- (if (or allow-system
- (not (member cmdtype '("system" "shell" "sh"))))
- (with-input-from-string fullcmd
- (lambda ()
- (set! result ((eval (read)) ht))))
- (set! result (conc "#{(" cmdtype ") " cmd "}"))))
- (case cmdsym
- ((system shell scheme)
- (let ((delta (- (current-seconds) start-time)))
- (if (> delta 2)
- (debug:print-info 2 *default-log-port* "for line \"" l "\"\n command: " cmd " took " delta " seconds to run with output:\n " result)
- (debug:print-info 9 *default-log-port* "for line \"" l "\"\n command: " cmd " took " delta " seconds to run with output:\n " result)))))
- (loop (conc prestr result poststr)))
- res))
- res)))
-
-;; this was inline but I'm pretty sure that is a hold over from when it was *very* simple ...
-;;
-(define (configf:read-line p ht allow-processing settings)
- (let loop ((inl (read-line p)))
- (let ((cont-line (and (string? inl)
- (not (string-null? inl))
- (equal? "\\" (string-take-right inl 1)))))
- (if cont-line ;; last character is \
- (let ((nextl (read-line p)))
- (if (not (eof-object? nextl))
- (loop (string-append (if cont-line
- (string-take inl (- (string-length inl) 1))
- inl)
- nextl))))
- (let ((res (case allow-processing ;; if (and allow-processing
- ;; (not (eq? allow-processing 'return-string)))
- ((#t #f)
- (configf:process-line inl ht allow-processing))
- ((return-string)
- inl)
- (else
- (configf:process-line inl ht allow-processing)))))
- (if (and (string? res) ;; must set to "no" to force NOT trimming trailing spaces
- (not (equal? (hash-table-ref/default settings "trim-trailing-spaces" "yes") "no")))
- (string-substitute "\\s+$" "" res)
- res))))))
-
-;; 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)
-;; allow-system:
-;; #f - do not evaluate [system
-;; #t - immediately evaluate [system and store result as string
-;; 'return-procs -- return a proc taking ht as an argument that may be evaulated at some future time
-;; 'return-string -- return a string representing a proc taking ht as an argument that may be evaulated at some future time
-;; 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
-;; post-section-procs alist of section-pattern => proc, where: (proc section-name next-section-name ht curr-path)
-;; apply-wildcards: #t/#f - apply vars from targets with % wildcards to all matching sections
-;;
-(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 '()) (apply-wildcards #t) )
- (debug:print 9 *default-log-port* "START: " path)
-;; (if *configdat*
-;; (common:save-pkt `((action . read-config)
-;; (f . ,(cond ((string? path) path)
-;; ((port? path) "port")
-;; (else (conc path))))
-;; (T . configf))
-;; *configdat* #t add-only: #t))
- (if (and (not (port? path))
- (not (common: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 (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))
- (process-wildcards (lambda (res curr-section-name)
- (if (and apply-wildcards
- (or (string-contains curr-section-name "%") ;; wildcard
- (string-match "/.*/" curr-section-name))) ;; regex
- (begin
- (configf:apply-wildcards res curr-section-name)
- (hash-table-delete! res curr-section-name)))))) ;; NOTE: if the section is a wild card it will be REMOVED from res
- (let loop ((inl (configf:read-line inp res (calc-allow-system allow-system curr-section sections) settings)) ;; (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 *default-log-port* "curr-section-name: " curr-section-name " var-flag: " var-flag "\n inl: \"" inl "\"")
- (if (eof-object? inl)
- (begin
- ;; process last section for wildcards
- (process-wildcards res curr-section-name)
- (if (string? path) ;; we received a path, not a port, thus we are responsible for closing it.
- (close-input-port inp))
- (if (list? sections) ;; delete all sections except given when sections is provided
- (for-each
- (lambda (section)
- (if (not (member section sections))
- (hash-table-delete! res section))) ;; we are using "" as a dumping ground and must remove it before returning the ht
- (hash-table-keys res)))
- (debug:print 9 *default-log-port* "END: " path)
- res
- ) ;; retval
- (regex-case
- inl
- (configf:comment-rx _ (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings)
- curr-section-name #f #f))
-
- (configf:blank-l-rx _ (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings)
- curr-section-name #f #f))
- (configf:settings ( x setting val )
- (begin
- (hash-table-set! settings setting val)
- (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings)
- curr-section-name #f #f)))
-
- (configf:include-rx ( x include-file )
- (let* ((curr-conf-dir (pathname-directory path))
- (full-conf (if (and (absolute-pathname? include-file) (file-exists? include-file))
- include-file
- (common:nice-path
- (conc (if curr-conf-dir
- curr-conf-dir
- ".")
- "/" include-file)))))
- (let ((all-matches (sort (handle-exceptions exn
- (begin
- (debug:print '(2 9) *default-log-port* "glob of " full-conf " gave no match. , exn=" exn)
- (list))
- (glob full-conf)) string<=?)))
- (if (null? all-matches)
- (begin
- (debug:print '(2 9) #f "INFO: include file(s) matching " include-file " not found (called from " path ")")
- (debug:print 2 *default-log-port* " " full-conf))
- (for-each
- (lambda (fpath)
- ;; (push-directory conf-dir)
- (debug:print 9 *default-log-port* "Including: " full-conf)
- (read-config fpath res allow-system environ-patt: environ-patt
- curr-section: curr-section-name sections: sections settings: settings
- keep-filenames: keep-filenames))
- all-matches))
- (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 params);; 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 (common:file-exists? include-script)(file-execute-access? include-script))
- (let* ((local-allow-system (calc-allow-system allow-system curr-section-name sections))
- (env-delta (configf:cfgdat->env-alist curr-section-name res local-allow-system))
- (new-inp-port
- (common:with-env-vars
- env-delta
- (lambda ()
- (open-input-pipe (conc include-script " " params))))))
- (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))
- (proc (cdr dat)))
- (if (string-match patt curr-section-name)
- (proc curr-section-name section-name res path))))
- post-section-procs)
- ;; after gathering the vars for a section and if apply-wildcards is true and if there is a wildcard in the section name process wildcards
- ;; NOTE: we are processing the curr-section-name, NOT section-name.
- (process-wildcards res curr-section-name)
- (if (not (hash-table-ref/default res section-name #f))(hash-table-set! res section-name '())) ;; ensure that mere mention of a section is not lost
- (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings)
- ;; 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 "". NOPE: We need new strategy. Put stuff in correct sections and then delete all sections later.
- section-name
- #f #f)))
- (configf:key-sys-pr ( x key cmd )
- (if (calc-allow-system allow-system curr-section-name sections)
- (let ((alist (hash-table-ref/default res curr-section-name '()))
- (val-proc (lambda ()
- (let* ((start-time (current-seconds))
- (local-allow-system (calc-allow-system allow-system curr-section-name sections))
- (env-delta (configf:cfgdat->env-alist curr-section-name res local-allow-system))
- (cmdres (process:cmd-run->list cmd delta-env-alist-or-hash-table: env-delta)) ;; BB: here is where [system is exec'd. needs to have env from other vars!
- (delta (- (current-seconds) start-time))
- (status (cadr cmdres))
- (res (car cmdres)))
- (debug:print-info 4 *default-log-port* "" inl "\n => " (string-intersperse res "\n"))
- (if (not (eq? status 0))
- (begin
- (debug:print-error 0 *default-log-port* "problem with " inl ", return code " status
- " output: " cmdres)))
- (if (> delta 2)
- (debug:print-info 0 *default-log-port* "for line \"" inl "\"\n command: " cmd " took " delta " seconds to run with output:\n " res)
- (debug:print-info 9 *default-log-port* "for line \"" inl "\"\n command: " cmd " took " delta " seconds to run with output:\n " res))
- (if (null? res)
- ""
- (string-intersperse res " "))))))
- (hash-table-set! res curr-section-name
- (configf:assoc-safe-add alist
- key
- (case (calc-allow-system allow-system curr-section-name sections)
- ((return-procs) val-proc)
- ((return-string) cmd)
- (else (val-proc)))
- metadata: metapath))
- (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f))
- (loop (configf:read-line inp res
- (calc-allow-system allow-system curr-section-name sections)
- settings)
- curr-section-name #f #f)))
-
- (configf:key-no-val ( x key val)
- (let* ((alist (hash-table-ref/default res curr-section-name '()))
- (fval (or (if (string? val) val #f) ""))) ;; fval should be either "" or " " (one or more spaces)
- (debug:print 10 *default-log-port* " setting: [" curr-section-name "] " key " = #t")
- (safe-setenv key fval)
- (hash-table-set! res curr-section-name
- (configf:assoc-safe-add alist key fval metadata: metapath))
- (loop (configf:read-line inp res
- (calc-allow-system allow-system curr-section-name sections)
- settings)
- curr-section-name key #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) ;; does the section match the envionpatt?
- (and (not (string-null? key))
- (not (equal? "!" (substring key 0 1)))) ;; ! as leading character is a signature to NOT export to the environment
- ;; (string-match "^.*:.*:.*$" key) ;; ;; something:something:something reserved for triggers in runconfigs
- ))
- (realval (if envar
- (configf:eval-string-in-environment val)
- val)))
- (debug:print-info 6 *default-log-port* "read-config env setting, envar: " envar " realval: " realval " val: " val " key: " key " curr-section-name: " curr-section-name)
- (if envar (safe-setenv key realval))
- (debug:print 10 *default-log-port* " setting: [" curr-section-name "] " key " = " val)
- (hash-table-set! res curr-section-name
- (configf:assoc-safe-add alist key realval metadata: metapath))
- (loop (configf:read-line inp res
- (calc-allow-system allow-system curr-section-name sections) settings)
- 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
- (configf: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
- (configf:assoc-safe-add alist var-flag newval metadata: metapath))
- (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name var-flag (if lead lead whsp)))
- (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f))))
- (else (debug:print-error 0 *default-log-port* "problem parsing " path ",\n \"" inl "\"")
- (set! var-flag #f)
- (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f))))
- ) ;; end loop
- )))
-
-(define (setup)
- (let* ((configf (find-config "megatest.config"))
- (config (if configf (read-config configf #f #t) #f)))
- (if config
- (setenv "RUN_AREA_HOME" (pathname-directory configf)))
- config))
-
-;;======================================================================
-;; refdb
-;;======================================================================
-
-;; reads a refdb into an assoc array of assoc arrays
-;; returns (list dat msg)
-(define (configf:read-refdb refdb-path)
- (let ((sheets-file (conc refdb-path "/sheet-names.cfg")))
- (if (not (common:file-exists? sheets-file))
- (list #f (conc "ERROR: no refdb found at " refdb-path))
- (if (not (file-read-access? sheets-file))
- (list #f (conc "ERROR: refdb file not readable at " refdb-path))
- (let* ((sheets (with-input-from-file sheets-file
- (lambda ()
- (let loop ((inl (read-line))
- (res '()))
- (if (eof-object? inl)
- (reverse res)
- (loop (read-line)(cons inl res)))))))
- (data '()))
- (for-each
- (lambda (sheet-name)
- (let* ((dat-path (conc refdb-path "/" sheet-name ".dat"))
- (ref-dat (configf:read-file dat-path #f #t))
- (ref-assoc (map (lambda (key)
- (list key (hash-table-ref ref-dat key)))
- (hash-table-keys ref-dat))))
- ;; (hash-table->alist ref-dat)))
- ;; (set! data (append data (list (list sheet-name ref-assoc))))))
- (set! data (cons (list sheet-name ref-assoc) data))))
- sheets)
- (list data "NO ERRORS"))))))
-
-;; redefines
-(define config-lookup configf:lookup)
-(define configf:read-file read-config)
-(define shell configfmod#shell)
-
+(declare (uses megatestmod))
+(declare (uses megatestmod.import))
+
+;; (include "configf-guts.scm")
+
+;; (define shell configfmod#shell)
+;; (print (runconfigs-get *configdat* "testing"))
Index: configfmod.scm
==================================================================
--- configfmod.scm
+++ configfmod.scm
@@ -473,8 +473,47 @@
(let ((configdat (if configfile
(read-config configfile #f #t environ-patt: environ-patt post-section-procs: (list (cons "^fields$" set-fields)) #f))))
(if toppath (change-directory curr-dir))
(list configdat toppath configfile fname))))
+
+;;======================================================================
+;; Lookup a value in runconfigs based on -reqtarg or -target
+;;
+(define (runconfigs-get config var)
+ (let ((targ (common:args-get-target))) ;; (or (args:get-arg "-reqtarg")(args:get-arg "-target")(getenv "MT_TARGET"))))
+ (if targ
+ (or (configf:lookup config targ var)
+ (configf:lookup config "default" var))
+ (configf:lookup config "default" var))))
+
+(define (common:args-get-target #!key (split #f)(exit-if-bad #f))
+ (let* ((keys (if (hash-table? *configdat*) (common:get-fields *configdat*) '()))
+ (numkeys (length keys))
+ (target (or (args:get-arg "-reqtarg")
+ (args:get-arg "-target")
+ (getenv "MT_TARGET")))
+ (tlist (if target (string-split target "/" #t) '()))
+ (valid (if target
+ (or (null? keys) ;; probably don't know our keys yet
+ (and (not (null? tlist))
+ (eq? numkeys (length tlist))
+ (null? (filter string-null? tlist))))
+ #f)))
+ (if valid
+ (if split
+ tlist
+ target)
+ (if target
+ (begin
+ (debug:print-error 0 *default-log-port* "Invalid target, spaces or blanks not allowed \"" target "\", target should be: " (string-intersperse keys "/") ", have " tlist " for elements")
+ (if exit-if-bad (exit 1))
+ #f)
+ #f))))
+
+
+
+
+(include "configf-guts.scm")
)
Index: configure
==================================================================
--- configure
+++ configure
@@ -15,87 +15,91 @@
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with Megatest. If not, see .
-# Configure the build
-
-if [[ "$1"x == "x" ]];then
- PREFIX=$PWD
-else
- PREFIX=$1
-fi
-
-
-#======================================================================
-# Configure stuff needed for eggs
-#======================================================================
-
-function configure_dependencies () {
-
- #======================================================================
- # libnanomsg
- #======================================================================
-
- if [[ ! $(ls /usr/lib/*/libnanomsg*) ]];then
- echo "libnanomsg build needed."
- echo "BUILD_NANOMSG=yes" >> makefile.inc
- fi
-
- #======================================================================
- # postgresql libraries
- #======================================================================
-
- if [[ ! $(ls /usr/lib/*/libpq.*) ]];then
- echo "Postgresql build needed."
- echo "BUILD_POSTGRES=yes" >> makefile.inc
- fi
-
- if [[ ! $(ls /usr/lib/*/libsqlite3.*) ]];then
- echo "Sqlite3 build needed."
- echo "BUILD_SQLITE3=yes" >> makefile.inc
- fi
-
-}
-
-#======================================================================
-# Initialize makefile.inc
-#======================================================================
-
-echo "" > makefile.inc
-
-#======================================================================
-# Do we need Chicken?
-#======================================================================
-
-if [[ -e /usr/bin/sw_vers ]]; then
- ARCHSTR=$(/usr/bin/sw_vers -productVersion)
-else
- ARCHSTR=$(lsb_release -sr)
-fi
-
-echo "CHICKEN_PREFIX=$PREFIX/.$ARCHSTR" >> makefile.inc
-CHICKEN_PREFIX=$PREFIX/bin/.$ARCHSTR
-
-if [[ ! $(type csi) ]];then
- echo "Chicken build needed."
- echo "BUILD_CHICKEN=yes" >> makefile.inc
- configure_dependencies
- echo "include chicken.makefile" >> makefile.inc
-else
- echo "CSIPATH=$(which csi)" >> makefile.inc
- CSIPATH=$(which csi)
- echo "CKPATH=$(dirname $(dirname $CSIPATH))" >> makefile.inc
-fi
-
-# Make setup scripts
-echo "#!/bin/bash" > setup.sh
-echo "export PATH=$CHICKEN_PREFIX/bin:\$PATH" >> setup.sh
-echo "export LD_LIBRARY_PATH=$CHICKEN_PREFIX/lib" >> setup.sh
-echo 'exec "$@"' >> setup.sh
-chmod a+x setup.sh
-
-echo "setenv PATH $CHICKEN_PREFIX/bin:\$PATH" > setup.csh
-echo "setenv LD_LIBRARY_PATH $CHICKEN_PREFIX/lib" >> setup.csh
-
-echo "All done creating makefile.inc, feel free to edit it!"
-echo "run \"setup.sh bash\" or source setup.csh to get PATH and LD_LIBRARY_PATH adjusted"
+
+
+
+# # Configure the build
+#
+# if [[ "$1"x == "x" ]];then
+# PREFIX=$PWD
+# else
+# PREFIX=$1
+# fi
+#
+#
+# #======================================================================
+# # Configure stuff needed for eggs
+# #======================================================================
+#
+# function configure_dependencies () {
+#
+# #======================================================================
+# # libnanomsg
+# #======================================================================
+#
+# if [[ ! $(ls /usr/lib/*/libnanomsg*) ]];then
+# echo "libnanomsg build needed."
+# echo "BUILD_NANOMSG=yes" >> makefile.inc
+# fi
+#
+# #======================================================================
+# # postgresql libraries
+# #======================================================================
+#
+# if [[ ! $(ls /usr/lib/*/libpq.*) ]];then
+# echo "Postgresql build needed."
+# echo "BUILD_POSTGRES=yes" >> makefile.inc
+# fi
+#
+# if [[ ! $(ls /usr/lib/*/libsqlite3.*) ]];then
+# echo "Sqlite3 build needed."
+# echo "BUILD_SQLITE3=yes" >> makefile.inc
+# fi
+#
+# }
+#
+# #======================================================================
+# # Initialize makefile.inc
+# #======================================================================
+#
+# echo "" > makefile.inc
+#
+# #======================================================================
+# # Do we need Chicken?
+# #======================================================================
+#
+# if [[ -e /usr/bin/sw_vers ]]; then
+# ARCHSTR=$(/usr/bin/sw_vers -productVersion)
+# else
+# ARCHSTR=$(lsb_release -sr)
+# fi
+#
+# echo "CHICKEN_PREFIX=$PREFIX/.$ARCHSTR" >> makefile.inc
+# CHICKEN_PREFIX=$PREFIX/bin/.$ARCHSTR
+#
+# if [[ ! $(type csi) ]];then
+# echo "Chicken build needed."
+# echo "BUILD_CHICKEN=yes" >> makefile.inc
+# configure_dependencies
+# echo "include chicken.makefile" >> makefile.inc
+# else
+# echo "CSIPATH=$(which csi)" >> makefile.inc
+# CSIPATH=$(which csi)
+# echo "CKPATH=$(dirname $(dirname $CSIPATH))" >> makefile.inc
+# fi
+#
+# # Make setup scripts
+# echo "#!/bin/bash" > setup.sh
+# echo "export PATH=$CHICKEN_PREFIX/bin:\$PATH" >> setup.sh
+# echo "export LD_LIBRARY_PATH=$CHICKEN_PREFIX/lib" >> setup.sh
+# echo 'exec "$@"' >> setup.sh
+# chmod a+x setup.sh
+#
+# echo "setenv PATH $CHICKEN_PREFIX/bin:\$PATH" > setup.csh
+# echo "setenv LD_LIBRARY_PATH $CHICKEN_PREFIX/lib" >> setup.csh
+#
+# echo "All done creating makefile.inc, feel free to edit it!"
+# echo "run \"setup.sh bash\" or source setup.csh to get PATH and LD_LIBRARY_PATH adjusted"
+#
Index: megatest.scm
==================================================================
--- megatest.scm
+++ megatest.scm
@@ -24,11 +24,11 @@
(declare (uses common))
;; (declare (uses megatest-version))
;; (declare (uses margs))
(declare (uses mtargs))
-(declare (uses mtargs.import))
+;; (declare (uses mtargs.import))
(declare (uses debugprint))
(declare (uses debugprint.import))
(declare (uses cookie))
(declare (uses cookie.import))
(declare (uses stml2))
@@ -38,43 +38,43 @@
(declare (uses processmod))
(declare (uses processmod.import))
(declare (uses configfmod))
(declare (uses configfmod.import))
(declare (uses pgdb))
-(declare (uses pgdb.import))
+;; (declare (uses pgdb.import))
(declare (uses mtmod))
(declare (uses mtmod.import))
(declare (uses servermod))
(declare (uses servermod.import))
(declare (uses dbfile))
(declare (uses dbfile.import))
(declare (uses dbmod))
(declare (uses dbmod.import))
(declare (uses portlogger))
-(declare (uses portlogger.import))
+;; (declare (uses portlogger.import))
(declare (uses tcp-transportmod))
-(declare (uses tcp-transportmod.import))
+;; (declare (uses tcp-transportmod.import))
(declare (uses fsmod))
(declare (uses fsmod.import))
(declare (uses megatestmod))
(declare (uses megatestmod.import))
(declare (uses apimod))
-(declare (uses apimod.import))
+;; (declare (uses apimod.import))
(declare (uses rmtmod))
-(declare (uses rmtmod.import))
+;; (declare (uses rmtmod.import))
(declare (uses tasksmod))
-(declare (uses tasksmod.import))
+;; (declare (uses tasksmod.import))
(declare (uses testsmod))
;; (declare (uses testsmod.import))
(declare (uses subrunmod))
-(declare (uses subrunmod.import))
+;; (declare (uses subrunmod.import))
(declare (uses archivemod))
-(declare (uses archivemod.import))
+;; (declare (uses archivemod.import))
(declare (uses runsmod))
;; (declare (uses runsmod.import))
(declare (uses cpumod))
-(declare (uses cpumod.import))
+;; (declare (uses cpumod.import))
(declare (uses runsmod))
(declare (uses ezstepsmod))
(declare (uses launchmod))
(declare (uses tdb))
@@ -84,10 +84,13 @@
(declare (uses diff-report))
(declare (uses runs))
(declare (uses launch))
(declare (uses server))
(declare (uses genexample))
+
+;; (include "debugmode.scm")
+
;; (declare (uses daemon))
;; (declare (uses dcommon))
;; (declare (uses debugprint))
Index: megatestmod.scm
==================================================================
--- megatestmod.scm
+++ megatestmod.scm
@@ -197,34 +197,10 @@
(args:get-arg ":runname")
(getenv "MT_RUNNAME"))))
;; (if res (set-environment-variable "MT_RUNNAME" res)) ;; not sure if this is a good idea. side effect and all ...
res))
-(define (common:args-get-target #!key (split #f)(exit-if-bad #f))
- (let* ((keys (if (hash-table? *configdat*) (common:get-fields *configdat*) '()))
- (numkeys (length keys))
- (target (or (args:get-arg "-reqtarg")
- (args:get-arg "-target")
- (getenv "MT_TARGET")))
- (tlist (if target (string-split target "/" #t) '()))
- (valid (if target
- (or (null? keys) ;; probably don't know our keys yet
- (and (not (null? tlist))
- (eq? numkeys (length tlist))
- (null? (filter string-null? tlist))))
- #f)))
- (if valid
- (if split
- tlist
- target)
- (if target
- (begin
- (debug:print-error 0 *default-log-port* "Invalid target, spaces or blanks not allowed \"" target "\", target should be: " (string-intersperse keys "/") ", have " tlist " for elements")
- (if exit-if-bad (exit 1))
- #f)
- #f))))
-
;;======================================================================
;; looking only (at least for now) at the MT_ variables craft the full testname
;;
(define (common:get-full-test-name)
(if (getenv "MT_TEST_NAME")
@@ -420,20 +396,10 @@
(with-output-to-file
(conc pktsdir "/" uuid ".pkt")
(lambda ()
(print pkt)))))))))
-;;======================================================================
-;; Lookup a value in runconfigs based on -reqtarg or -target
-;;
-(define (runconfigs-get config var)
- (let ((targ (common:args-get-target))) ;; (or (args:get-arg "-reqtarg")(args:get-arg "-target")(getenv "MT_TARGET"))))
- (if targ
- (or (configf:lookup config targ var)
- (configf:lookup config "default" var))
- (configf:lookup config "default" var))))
-
;;======================================================================
;; R U N S
;;======================================================================
;; set tests with state currstate and status currstatus to newstate and newstatus