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: dashboard-transport-mode.scm
==================================================================
--- dashboard-transport-mode.scm
+++ dashboard-transport-mode.scm
@@ -3,20 +3,22 @@
;;
;; sync-method: 'original, 'attach or 'none
;; cache-method: 'tmp or 'none
;; rmt:transport-mode: 'http, 'tcp, 'nfs
;;
+;; 'auto
+;; read-only query and no servers started - mrah/
+;;
;; NOTE: NOT ALL COMBINATIONS WORK
;;
;;======================================================================
;; uncomment this block to test without tcp or cachedb
-;; (dbfile:sync-method 'none)
-;; (dbfile:cache-method 'none)
-;; (rmt:transport-mode 'nfs)
+(dbfile:sync-method 'none)
+(dbfile:cache-method 'none)
+(rmt:transport-mode 'nfs)
;; uncomment this block to test with tcp and cachedb
-(dbfile:sync-method 'none) ;; original was causing crash on start.
-(dbfile:cache-method 'none)
-(rmt:transport-mode 'tcp)
-;; (rmt:transport-mode 'nfs)
+;; (dbfile:sync-method 'none) ;; original was causing crash on start.
+;; (dbfile:cache-method 'none)
+;; (rmt:transport-mode 'tcp)
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,11 +38,11 @@
(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))
@@ -60,21 +60,21 @@
(declare (uses apimod))
(declare (uses apimod.import))
(declare (uses rmtmod))
(declare (uses rmtmod.import))
(declare (uses tasksmod))
-(declare (uses tasksmod.import))
+;; (declare (uses tasksmod.import))
(declare (uses testsmod))
-(declare (uses testsmod.import))
+;; (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))
@@ -1026,10 +1029,11 @@
(if dbfname
(tt:start-server tl #f dbfname api:tcp-dispatch-request-make-handler keys)
(begin
(debug:print 0 *default-log-port* "ERROR: transport mode is tcp - -db is required.")
(exit 1)))))
+ ((nfs)(debug:print 0 *default-log-port* "WARNING: server start called in nfs mode '"(rmt:transport-mode)))
(else (debug:print 0 *default-log-port* "ERROR: rmt:transport-mode value not recognised "(rmt:transport-mode))))
(set! *didsomething* #t)))
;; The adjutant is a bit different, it does NOT run (launch:setup) as it is not necessarily tied to
;; a specific Megatest area. Detail are being hashed out and this may change.
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
Index: rmtmod.scm
==================================================================
--- rmtmod.scm
+++ rmtmod.scm
@@ -950,11 +950,10 @@
#f)))
#f))) ;; not true strickly speaking, might be runremote was not yet initialized.
(define (make-and-init-remote areapath)
(case (rmt:transport-mode)
- ((http)(make-remote))
((tcp) (tt:make-remote areapath))
(else #f)))
;; how to make area-dat
(define (rmt:set-ttdat areapath ttdat)
Index: runsmod.scm
==================================================================
--- runsmod.scm
+++ runsmod.scm
@@ -1188,13 +1188,15 @@
(if (and (not (rmt:on-homehost?))
maxload) ;; only gate if maxload is specified, NOTE: maxload is normalized, i.e. load=1 means all cpus fully utilized
(common:wait-for-normalized-load maxload "Waiting for load to drop before starting more tests" #f))
;; jobtools maxhomehostload is intended to prevent overloading on the homehost which can cause database corruption issues
- (if maxhomehostload
- (common:wait-for-homehost-load maxhomehostload
- (conc "Waiting for homehost load to drop below normalized value of " maxhomehostload))))))
+ ;; (if maxhomehostload
+ ;; (common:wait-for-homehost-load
+ ;; maxhomehostload
+ ;; (conc "Waiting for homehost load to drop below normalized value of " maxhomehostload)))
+ )))
(if (and (not (null? prereqs-not-met))
(runs:lownoise (conc "waiting on tests " prereqs-not-met hed) 60))
Index: servermod.scm
==================================================================
--- servermod.scm
+++ servermod.scm
@@ -272,29 +272,29 @@
;; or another host?
;;
;; returns #t => ok to start another server
;; #f => not ok to start another server
;;
-(define (server:minimal-check areapath)
- (server:clean-up-old areapath)
- (let* ((srvdir (server:get-servinfo-dir areapath)) ;; (conc areapath"/.servinfo"))
- (servrs (glob (conc srvdir"/*")))
- (thishostip (server:get-best-guess-address (get-host-name)))
- (thisservrs (glob (conc srvdir"/"thishostip":*")))
- (homehostinf (server:choose-server areapath 'homehost))
- (havehome (car homehostinf))
- (wearehome (cdr homehostinf)))
- (debug:print-info 0 *default-log-port* thishostip", have homehost: "havehome", we are homehost: "wearehome
- ", numservers: "(length thisservrs))
- (cond
- ((not havehome) #t) ;; no homehost yet, go for it
- ((and havehome wearehome (< (length thisservrs) 20)) #t) ;; we are home and less than 20 servers, ok to start another
- ((and havehome (not wearehome)) #f) ;; we are not the home host
- ((and havehome wearehome (>= (length thisservrs) 20)) #f) ;; have enough running
- (else
- (debug:print 0 *default-log-port* "WARNING: Unrecognised scenario, servrs="servrs", thishostip="thishostip", thisservrs="thisservrs)
- #t))))
+;; (define (server:minimal-check areapath)
+;; (server:clean-up-old areapath)
+;; (let* ((srvdir (server:get-servinfo-dir areapath)) ;; (conc areapath"/.servinfo"))
+;; (servrs (glob (conc srvdir"/*")))
+;; (thishostip (server:get-best-guess-address (get-host-name)))
+;; (thisservrs (glob (conc srvdir"/"thishostip":*")))
+;; (homehostinf (server:choose-server areapath 'homehost))
+;; (havehome (car homehostinf))
+;; (wearehome (cdr homehostinf)))
+;; (debug:print-info 0 *default-log-port* thishostip", have homehost: "havehome", we are homehost: "wearehome
+;; ", numservers: "(length thisservrs))
+;; (cond
+;; ((not havehome) #t) ;; no homehost yet, go for it
+;; ((and havehome wearehome (< (length thisservrs) 20)) #t) ;; we are home and less than 20 servers, ok to start another
+;; ((and havehome (not wearehome)) #f) ;; we are not the home host
+;; ((and havehome wearehome (>= (length thisservrs) 20)) #f) ;; have enough running
+;; (else
+;; (debug:print 0 *default-log-port* "WARNING: Unrecognised scenario, servrs="servrs", thishostip="thishostip", thisservrs="thisservrs)
+;; #t))))
(define server-last-start 0)
@@ -303,87 +303,87 @@
;;
;; mode:
;; best - get best server (random of newest five)
;; home - get home host based on oldest server
;; info - print info
-(define (server:choose-server areapath #!optional (mode 'best))
- ;; age is current-starttime
- ;; find oldest alive
- ;; 1. sort by age ascending and ping until good
- ;; find alive rand from youngest
- ;; 1. sort by age descending
- ;; 2. take five
- ;; 3. check alive, discard if not and repeat
- ;; first we clean up old server files
- (assert (eq? (rmt:transport-mode) 'http) "FATAL: server:run called with rmt:transport-mode="(rmt:transport-mode))
- (server:clean-up-old areapath)
- (let* ((since-last (- (current-seconds) server-last-start))
- (server-start-delay 10))
- (if ( < (- (current-seconds) server-last-start) 10 )
- (begin
- (debug:print 2 *default-log-port* "server:choose-server: seconds since last server start: " (- (current-seconds) server-last-start))
- (debug:print 2 *default-log-port* "server:choose-server: last server start less than " server-start-delay " seconds ago. Sleeping " server-start-delay " seconds")
- (thread-sleep! server-start-delay)
- )
- (debug:print 2 *default-log-port* "server:choose-server: seconds since last server start: " (- (current-seconds) server-last-start))
- )
- )
- (let* ((serversdat (server:get-servers-info areapath))
- (servkeys (hash-table-keys serversdat))
- (by-time-asc (if (not (null? servkeys)) ;; NOTE: Oldest is last
- (sort servkeys ;; list of "host:port"
- (lambda (a b)
- (>= (list-ref (hash-table-ref serversdat a) 2)
- (list-ref (hash-table-ref serversdat b) 2))))
- '())))
- (debug:print 2 *default-log-port* "server:choose-server: serversdat: " serversdat)
- (debug:print 2 *default-log-port* "server:choose-server: servkeys: " servkeys)
- (if (not (null? by-time-asc))
- (let* ((oldest (last by-time-asc))
- (oldest-dat (hash-table-ref serversdat oldest))
- (host (list-ref oldest-dat 0))
- (all-valid (filter (lambda (x)
- (equal? host (list-ref (hash-table-ref serversdat x) 0)))
- by-time-asc))
- (best-ten (lambda ()
- (if (> (length all-valid) 11)
- (take (drop-right all-valid 1) 10) ;; remove the oldest from consideration so it can age out
- (if (> (length all-valid) 8)
- (drop-right all-valid 1)
- all-valid))))
- (names->dats (lambda (names)
- (map (lambda (x)
- (hash-table-ref serversdat x))
- names)))
- (am-home? (lambda ()
- (let* ((currhost (get-host-name))
- (bestadrs (server:get-best-guess-address currhost)))
- (or (equal? host currhost)
- (equal? host bestadrs))))))
- (case mode
- ((info)
- (debug:print 0 *default-log-port* "oldest: "oldest-dat", selected host: "host", all-valid: "all-valid)
- (debug:print 0 *default-log-port* "youngest: "(hash-table-ref serversdat (car all-valid))))
- ((home) host)
- ((homehost) (cons host (am-home?))) ;; shut up old code
- ((home?) (am-home?))
- ((best-ten)(names->dats (best-ten)))
- ((all-valid)(names->dats all-valid))
- ((best) (let* ((best-ten (best-ten))
- (len (length best-ten)))
- (hash-table-ref serversdat (list-ref best-ten (random len)))))
- ((count)(length all-valid))
- (else
- (debug:print 0 *default-log-port* "ERROR: invalid command "mode)
- #f)))
- (begin
- (server:run areapath)
- (set! server-last-start (current-seconds))
- ;; (thread-sleep! 3)
- (case mode
- ((homehost) (cons #f #f))
- (else #f))))))
+;; (define (server:choose-server areapath #!optional (mode 'best))
+;; ;; age is current-starttime
+;; ;; find oldest alive
+;; ;; 1. sort by age ascending and ping until good
+;; ;; find alive rand from youngest
+;; ;; 1. sort by age descending
+;; ;; 2. take five
+;; ;; 3. check alive, discard if not and repeat
+;; ;; first we clean up old server files
+;; (assert (eq? (rmt:transport-mode) 'http) "FATAL: server:run called with rmt:transport-mode="(rmt:transport-mode))
+;; (server:clean-up-old areapath)
+;; (let* ((since-last (- (current-seconds) server-last-start))
+;; (server-start-delay 10))
+;; (if ( < (- (current-seconds) server-last-start) 10 )
+;; (begin
+;; (debug:print 2 *default-log-port* "server:choose-server: seconds since last server start: " (- (current-seconds) server-last-start))
+;; (debug:print 2 *default-log-port* "server:choose-server: last server start less than " server-start-delay " seconds ago. Sleeping " server-start-delay " seconds")
+;; (thread-sleep! server-start-delay)
+;; )
+;; (debug:print 2 *default-log-port* "server:choose-server: seconds since last server start: " (- (current-seconds) server-last-start))
+;; )
+;; )
+;; (let* ((serversdat (server:get-servers-info areapath))
+;; (servkeys (hash-table-keys serversdat))
+;; (by-time-asc (if (not (null? servkeys)) ;; NOTE: Oldest is last
+;; (sort servkeys ;; list of "host:port"
+;; (lambda (a b)
+;; (>= (list-ref (hash-table-ref serversdat a) 2)
+;; (list-ref (hash-table-ref serversdat b) 2))))
+;; '())))
+;; (debug:print 2 *default-log-port* "server:choose-server: serversdat: " serversdat)
+;; (debug:print 2 *default-log-port* "server:choose-server: servkeys: " servkeys)
+;; (if (not (null? by-time-asc))
+;; (let* ((oldest (last by-time-asc))
+;; (oldest-dat (hash-table-ref serversdat oldest))
+;; (host (list-ref oldest-dat 0))
+;; (all-valid (filter (lambda (x)
+;; (equal? host (list-ref (hash-table-ref serversdat x) 0)))
+;; by-time-asc))
+;; (best-ten (lambda ()
+;; (if (> (length all-valid) 11)
+;; (take (drop-right all-valid 1) 10) ;; remove the oldest from consideration so it can age out
+;; (if (> (length all-valid) 8)
+;; (drop-right all-valid 1)
+;; all-valid))))
+;; (names->dats (lambda (names)
+;; (map (lambda (x)
+;; (hash-table-ref serversdat x))
+;; names)))
+;; (am-home? (lambda ()
+;; (let* ((currhost (get-host-name))
+;; (bestadrs (server:get-best-guess-address currhost)))
+;; (or (equal? host currhost)
+;; (equal? host bestadrs))))))
+;; (case mode
+;; ((info)
+;; (debug:print 0 *default-log-port* "oldest: "oldest-dat", selected host: "host", all-valid: "all-valid)
+;; (debug:print 0 *default-log-port* "youngest: "(hash-table-ref serversdat (car all-valid))))
+;; ((home) host)
+;; ((homehost) (cons host (am-home?))) ;; shut up old code
+;; ((home?) (am-home?))
+;; ((best-ten)(names->dats (best-ten)))
+;; ((all-valid)(names->dats all-valid))
+;; ((best) (let* ((best-ten (best-ten))
+;; (len (length best-ten)))
+;; (hash-table-ref serversdat (list-ref best-ten (random len)))))
+;; ((count)(length all-valid))
+;; (else
+;; (debug:print 0 *default-log-port* "ERROR: invalid command "mode)
+;; #f)))
+;; (begin
+;; (server:run areapath)
+;; (set! server-last-start (current-seconds))
+;; ;; (thread-sleep! 3)
+;; (case mode
+;; ((homehost) (cons #f #f))
+;; (else #f))))))
(define (server:get-servinfo-dir areapath)
(let* ((spath (conc areapath"/.servinfo")))
(if (not (file-exists? spath))
(create-directory spath #t))
@@ -451,11 +451,11 @@
;; transport to be used
;; http - use http-transport
;; http-read-cached - use http-transport for writes but in-mem cached for reads
(rmode 'http)
- (hh-dat (let ((res (or (server:choose-server *toppath* 'homehost)
+ (hh-dat (let ((res (or ;; (server:choose-server *toppath* 'homehost)
(cons #f #f))))
(assert (pair? res)(conc "FATAL: hh-dat should be a pair, got "res))
res))
(server-url #f) ;; (server:check-if-running *toppath*) #f))
(server-id #f)
Index: tasksmod.scm
==================================================================
--- tasksmod.scm
+++ tasksmod.scm
@@ -1220,27 +1220,27 @@
;;======================================================================
;; (begin
;; (debug:print 0 *default-log-port* "ERROR: cannot migrate version unless on homehost. Exiting.")
;; (exit 1))))
-(define (common:wait-for-homehost-load maxnormload msg)
- (let loop ((start-time (current-seconds))) ;; we saw some instances of this being called before *toppath* was set. This might be an early setup race. This delay should help but it is impossible to test...
- (if (not *toppath*)
- (begin
- (debug:print 0 *default-log-port* "ERROR: common:wait-for-homehost-load called before *toppath* set.")
- (thread-sleep! 30)
- (if (< (- (current-seconds) start-time) 300)
- (loop start-time)))))
- (case (rmt:transport-mode)
- ((http)
- (let* ((hh-dat (if (rmt:on-homehost?) ;; if we are on the homehost then pass in #f so the calls are local.
- #f
- (server:choose-server *toppath* 'homehost)))
- (hh (if hh-dat (car hh-dat) #f)))
- (common:wait-for-normalized-load maxnormload msg hh)))
- (else
- (common:wait-for-normalized-load maxnormload msg (get-host-name)))))
+;; (define (common:wait-for-homehost-load maxnormload msg)
+;; (let loop ((start-time (current-seconds))) ;; we saw some instances of this being called before *toppath* was set. This might be an early setup race. This delay should help but it is impossible to test...
+;; (if (not *toppath*)
+;; (begin
+;; (debug:print 0 *default-log-port* "ERROR: common:wait-for-homehost-load called before *toppath* set.")
+;; (thread-sleep! 30)
+;; (if (< (- (current-seconds) start-time) 300)
+;; (loop start-time)))))
+;; (case (rmt:transport-mode)
+;; ((http)
+;; (let* ((hh-dat (if (rmt:on-homehost?) ;; if we are on the homehost then pass in #f so the calls are local.
+;; #f
+;; (server:choose-server *toppath* 'homehost)))
+;; (hh (if hh-dat (car hh-dat) #f)))
+;; (common:wait-for-normalized-load maxnormload msg hh)))
+;; (else
+;; (common:wait-for-normalized-load maxnormload msg (get-host-name)))))
(define (configf:write-alist cdat fname)
(if (not (common:faux-lock fname))
(debug:print 0 *default-log-port* "INFO: Could not get lock on " fname))
Index: transport-mode.scm
==================================================================
--- transport-mode.scm
+++ transport-mode.scm
@@ -8,15 +8,15 @@
;; NOTE: NOT ALL COMBINATIONS WORK
;;
;;======================================================================
;; uncomment this block to test without tcp
-;; (dbfile:sync-method 'none)
-;; (dbfile:cache-method 'none)
-;; (rmt:transport-mode 'nfs)
+(dbfile:sync-method 'none)
+(dbfile:cache-method 'none)
+(rmt:transport-mode 'nfs)
;; uncomment this block to test with tcp
-(dbfile:sync-method 'attach) ;; attach) ;; original
-(dbfile:cache-method 'tmp)
-(rmt:transport-mode 'tcp)
+;; (dbfile:sync-method 'attach) ;; attach) ;; original
+;; (dbfile:cache-method 'tmp)
+;; (rmt:transport-mode 'tcp)