Megatest

           (handle-exceptions
           exn
           #t ;; just ignore it, it might have died in the meantime so joining it will throw an exception
           (thread-join! thread))
           )))
   (hash-table-keys *common:thread-punchlist*)))

;; Use this when switching to mtconfigf module in find-and-read-config
;;
(define (common:set-fields curr-section next-section ht path)
  (let ((field-names (if ht (common:get-fields ht) '()))
	(target      (or (getenv "MT_TARGET")(args:get-arg "-reqtarg")(args:get-arg "-target"))))
    (debug:print-info 9 *default-log-port* "set-fields with field-names=" field-names " target=" target " curr-section=" curr-section " next-section=" next-section " path=" path " ht=" ht)
    (if (not (null? field-names))(keys:target-set-args field-names target #f))))

;; moved to common.scm as it is very megatest specific

;; pathenvvar will set the named var to the path of the config
(define (common:find-and-read-config fname #!key (environ-patt #f)(given-toppath #f)(pathenvvar #f))
(define (common:find-and-read-config fname #!key (environ-patt #f)(given-toppath #f)(pathenvvar #f)(set-fields common:set-fields))
  (let* ((curr-dir   (current-directory))
         (configinfo (find-config fname toppath: given-toppath))
	 (toppath    (car configinfo))
	 (configfile (cadr configinfo))
	 (configfile (cadr configinfo)))
	 (set-fields (lambda (curr-section next-section ht path)
		       (let ((field-names (if ht (common:get-fields ht) '()))
			     (target      (or (getenv "MT_TARGET")(args:get-arg "-reqtarg")(args:get-arg "-target"))))
			 (debug:print-info 9 *default-log-port* "set-fields with field-names=" field-names " target=" target " curr-section=" curr-section " next-section=" next-section " path=" path " ht=" ht)
			 (if (not (null? field-names))(keys:target-set-args field-names target #f))))))
    (if toppath (change-directory toppath)) 
    (if (and toppath pathenvvar)(setenv pathenvvar toppath))
    (let ((configdat  (if configfile 
			  (read-config configfile #f #t environ-patt: environ-patt post-section-procs: (list (cons "^fields$" set-fields)) #f))))
			  (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))))

;;;; return list (path fullpath configname)
(define (common:find-config configname #!key (toppath #f))
  (if toppath
      (let ((cfname (conc toppath "/" configname)))

;; collect, translate, collate and assemble a pkt from the command-line
;;
;; sched => force the run start time to be recorded as sched Unix
;; epoch. This aligns times properly for triggers in some cases.
;;
;;  extra-dat format is ( 'x xval 'y yval .... )
;;
(define (command-line->pkt action args-alist sched-in #!key (extra-dat '())(area-path #f)(new-ss #f))
   (let* ((sched     (cond
(define (command-line->pkt action args-alist sched-in #!key (extra-dat '())(area-path #f)(new-ss #f)(log-port (current-error-port)))
  (let* ((sched     (cond
		     ((vector? sched-in)(local-time->seconds sched-in)) ;; we recieved a time
		     ((number? sched-in) sched-in)
		     (else     (current-seconds))))
   (user  (if (and args-alist (hash-table? args-alist))
              (hash-table-ref/default args-alist "-override-user" (current-user-name))
						  (current-user-name)))
                    
	 (user  (if (and args-alist (hash-table? args-alist))
		    (hash-table-ref/default args-alist "-override-user" (current-user-name))
		    (current-user-name)))
	 
	 (args-data (if args-alist
			(if (hash-table? args-alist) ;; seriously?
			    (hash-table->alist args-alist)
			    args-alist)
			(hash-table->alist args:arg-hash))) ;; if no args-alist then we assume this is a call driven directly by commandline
	 (alldat    (apply append
			   (list 'A action
				 'U user
				 'D sched)
			   (if area-path
			       (list 'S area-path) ;; the area-path is mapped to the start-dir
			       '())
                           (if (list? extra-dat)
			       extra-dat
			       (begin
				 (debug:print 0 *default-log-port* "ERROR: command-line->pkt received bad extra-dat " extra-dat)
				 (debug-print 0 log-port "ERROR: command-line->pkt received bad extra-dat " extra-dat)
				 '()))
			   (map (lambda (x)
				  (let* ((param (car x))
					 (value (cdr x))
					 (pmeta (assoc param *arg-keys*))    ;; translate the card key to a megatest switch or parameter
					 (smeta (assoc param *switch-keys*)) ;; first lookup the key in arg-keys or switch-keys
					 (meta  (if (or pmeta smeta)

    ;(exit)
    (add-z-card
     (apply construct-sdat alldat))))

(define (simple-setup start-dir-in)
  (let* ((start-dir (or start-dir-in "."))
	 (mtconfig  (or (args:get-arg "-config") "megatest.config"))
	 (mtconfdat (find-and-read-config        ;; NB// sets MT_RUN_AREA_HOME as side effect
	 (mtconfdat (configf:find-and-read-config        ;; NB// sets MT_RUN_AREA_HOME as side effect
		     mtconfig
		     ;; environ-patt: "env-override"
		     given-toppath: start-dir
		     ;; pathenvvar: "MT_RUN_AREA_HOME"
		     ))
	 (mtconf    (if mtconfdat (car mtconfdat) #f)))
    ;; we set some dynamic data in a section called "scratchdata"

	  (print pkt))))))

;; (use trace)(trace create-run-pkt)

;; collect all needed data and create run pkts for contours with changed inputs
;;
(define (generate-run-pkts mtconf toppath)
  (let ((std-runname (conc "sched"  (time->string (seconds->local-time (current-seconds)) "%M%H%d"))))
  (let ((std-runname   (conc "sched"  (time->string (seconds->local-time (current-seconds)) "%M%H%d")))
	(pktsdir-str   (configf:lookup mtconf "scratchdat" "toppath"))
	(setup-pdbpath (configf:lookup mtconf "setup"  "pdbpath")))
    (common:with-queue-db
     mtconf
     pktsdir-str
     setup-pdbpath
     (lambda (pktsdirs pktsdir pdb)
       (let* ((rgconfdat (find-and-read-config (conc toppath "/runconfigs.config")))
       (let* ((rgconfdat (configf:find-and-read-config (conc toppath "/runconfigs.config")))
	      (rgconf    (car rgconfdat))
	      (all-areas (map car (configf:get-section mtconf "areas")))
	      (contours  (configf:get-section mtconf "contours"))
	      (torun     (make-hash-table)) ;; target => ( ... info ... )
	      (rgentargs (hash-table-keys rgconf))) ;; these are the targets registered for automatically triggering

	 (print "rgentargs: " rgentargs)

	  (print pkt)))
      (print "ERROR: cannot process commands without a pkts directory")))

;; collect all needed data and create run pkts for contours with changed inputs
;;
(define (dispatch-commands mtconf toppath)
  ;; we are expecting a directory "logs", check and create it, create the log in /tmp if not able to create logs dir
  (let ((logdir
  (let* ((logdir
	 (if (if (not (directory? "logs"))
		 (handle-exceptions
		     exn
		     #f
		   (create-directory "logs")
		   #t)
		 #t)
	     "logs"
	     "/tmp"))
	(cpuload (alist-ref 'adj-proc-load (common:get-normalized-cpu-load #f)))
	(cpuload (alist-ref 'adj-proc-load (common:get-normalized-cpu-load logdir #f)))
	(maxload (string->number (or (configf:lookup mtconf "setup" "maxload")
				     (configf:lookup mtconf "jobtools" "maxload") ;; respect value used by Megatest calls
				     "1.1"))))
				     "1.1")))
	(pktsdir-str   (configf:lookup mtconf "scratchdat" "toppath"))
	(setup-pdbpath (configf:lookup mtconf "setup"  "pdbpath")))
    (common:with-queue-db
     mtconf
     pktsdir-str
     setup-pdbpath
     (lambda (pktsdirs pktsdir pdb)
       (let* ((rgconfdat (find-and-read-config (conc toppath "/runconfigs.config")))
       (let* ((rgconfdat (configf:find-and-read-config (conc toppath "/runconfigs.config")))
	      (rgconf    (car rgconfdat))
	      (areas     (configf:get-section mtconf "areas"))
	      (contours  (configf:get-section mtconf "contours"))
	      (pkts      (find-pkts pdb '(cmd) '()))
	      (torun     (make-hash-table)) ;; target => ( ... info ... )
	      (rgentargs (hash-table-keys rgconf))) ;; these are the targets registered for automatically triggering
	 (for-each

	 ;;  (hash-table-keys adjargs))
	 (let-values (((uuid pkt)
		       (command-line->pkt *action* adjargs #f area-path: area-path new-ss: new-ss)))
	   (write-pkt pktsdir uuid pkt))))
      ((dispatch import rungen process)
       (let* ((mtconfdat (simple-setup (args:get-arg "-start-dir")))
	      (mtconf    (car mtconfdat))
	      (toppath   (configf:lookup mtconf "scratchdat" "toppath")))
	      (toppath   (configf:lookup mtconf "scratchdat" "toppath"))
	      (pktsdir-str   (or (configf:lookup mtconf "scratchdat" "toppath")(configf:lookup mtconf "setup" "pktsdir")))
	      (setup-pdbpath (configf:lookup mtconf "setup"  "pdbpath")))
	 (case (string->symbol *action*)
	   ((process)  (begin
			 (common:load-pkts-to-db mtconf)
			 (common:load-pkts-to-db pktsdir-str setup-pdbpath)
			 (generate-run-pkts mtconf toppath)
			 (common:load-pkts-to-db mtconf)
			 (common:load-pkts-to-db pktsdir-str setup-pdbpath)
			 (dispatch-commands mtconf toppath)))
	   ((import)   (common:load-pkts-to-db mtconf)) ;; import pkts
	   ((import)   (common:load-pkts-to-db pktsdir-str setup-pdbpath)) ;; import pkts
	   ((rungen)   (generate-run-pkts mtconf toppath))
	   ((dispatch) (dispatch-commands mtconf toppath)))))
      ;; misc
      ((show)
       (if (> (length remargs) 0)
	   (let* ((mtconfdat (simple-setup (args:get-arg "-start-dir")))
		  (mtconf    (car mtconfdat))
		  (sect-dat (configf:get-section mtconf (car remargs))))
	     (if sect-dat
		 (for-each
		  (lambda (entry)
		    (if (> (length entry) 1)
			(print (car entry) "   " (cadr entry))
			(print (car entry))))
		  sect-dat)
		 (print "No section \"" (car remargs) "\" found")))
	   (print "ERROR: list requires section parameter; areas, setup or contours")))
      ((gendot)
       (let* ((mtconfdat (simple-setup (args:get-arg "-start-dir")))
	      (mtconf    (car mtconfdat)))
	 (common:load-pkts-to-db mtconf use-lt: #t) ;; need to NOT do this by default ...
	      (mtconf    (car mtconfdat))
	      (pktsdir-str   (configf:lookup mtconf "scratchdat" "toppath"))
	      (setup-pdbpath (configf:lookup mtconf "setup"  "pdbpath")))
	 (common:load-pkts-to-db pktsdir-str setup-pdbpath use-lt: #t) ;; need to NOT do this by default ...
	 (common:with-queue-db
	  mtconf
	  pktsdir-str
	  setup-pdbpath
	  (lambda (pktsdirs pktsdir conn)
	    ;;                       pktspec display-fields 
	    (make-report "out.dot" conn
			 '((cmd      . ((parent . P)
					(user   . M)
					(target . t)))
			   (runstart . ((parent . P)

         print-error
         print-info
         log-event
         debug-setup
         debug-mode
         check-verbosity
         calc-verbosity
	 ;; pkts stuff
	 load-pkts-to-db	 
	 get-pkt-alists
	 with-queue-db
	 ;; unix stuff
	 get-cached-info
	 write-cached-info
	 get-normalized-cpu-load
         )

(import scheme chicken data-structures extras posix ports)
(use (prefix sql-de-lite sql:) posix typed-records format srfi-1 srfi-69)
(use (prefix sql-de-lite sql:) posix typed-records format srfi-1 srfi-69 pkts regex (prefix dbi dbi:) regex-case)

(defstruct ctrldat
  (port      (current-error-port))
  (verbosity 1)
  (vcache    (make-hash-table))
  (logging   #f) ;; keep the flag and the db handle separate to enable overriding
  (logdb     #f) ;; might need to make this a stack of handles for threaded access

      (with-output-to-port (or e (current-error-port))
	(lambda ()
	  (if (ctrldat-logging *log*)
	      (log-event (apply conc params))
	      (apply print params)
	      )))))

;; more betterer implementation above?
;; (define (print-info n e . params)
;;   (apply debug-print n e "INFO: " params))

;; ;; Brandon's debug printer shortcut (indulge me :)
;; (define *BB-process-starttime* (current-milliseconds))
;; (define (BB> . in-args)
;;   (let* ((stack (get-call-chain))
;;          (location "??"))
;;     (for-each
;;      (lambda (frame)

	      )))))

;; if a value is printable (i.e. string or number) return the value
;; else return an empty string
(define-inline (printable val)
  (if (or (number? val)(string? val)) val ""))

;;======================================================================
;; Unix stuff
;;======================================================================

;; get values from cached info from dropping file in logs dir
;;  e.g. key is host and dtype is normalized-load
;;
(define (get-cached-info logdir key dtype #!key (age 5)(log-port (current-error-port)))
  (let* ((fullpath (conc logdir "/" key "-" dtype ".log")))
    (if (and (file-exists? fullpath)
	     (file-read-access? fullpath))
	(handle-exceptions
	 exn
	 #f
	 (debug-print 2 log-port "reading file " fullpath)
	 (let ((real-age (- (current-seconds)(file-change-time fullpath)))) 
	   (if (< real-age age)
	       (with-input-from-file fullpath read)
	       (begin
		 (debug-print 2 log-port "file " fullpath " is too old (" real-age" seconds)to trust, skipping reading it")
		 #f))))
	(begin
	  (debug-print 2 log-port "not reading file " fullpath)
	  #f))))

(define (write-cached-info logdir key dtype dat)
  (let* ((fullpath (conc logdir "/" key "-" dtype ".log")))
    (handle-exceptions
     exn
     #f
     (with-output-to-file fullpath (lambda ()(pp dat))))))


;; get normalized cpu load by reading from /proc/loadavg and /proc/cpuinfo return all three values and the number of real cpus and the number of threads
;; returns alist '((adj-cpu-load . normalized-proc-load) ... etc.
;;  keys: adj-proc-load, adj-core-load, 1m-load, 5m-load, 15m-load
;;
(define (get-normalized-cpu-load logdir remote-host)
  (let ((actual-host (or remote-host (get-host-name)))) ;; #f is localhost
    (or (get-cached-info logdir actual-host "normalized-load")
	(let ((data (if remote-host
			(with-input-from-pipe 
			    (conc "ssh " remote-host " cat /proc/loadavg;cat /proc/cpuinfo;echo end")
			  read-lines)
			(append 
			 (with-input-from-file "/proc/loadavg" 
			   read-lines)
			 (with-input-from-file "/proc/cpuinfo"
			   read-lines)
			 (list "end"))))
	      (load-rx  (regexp "^([\\d\\.]+)\\s+([\\d\\.]+)\\s+([\\d\\.]+)\\s+.*$"))
	      (proc-rx  (regexp "^processor\\s+:\\s+(\\d+)\\s*$"))
	      (core-rx  (regexp "^core id\\s+:\\s+(\\d+)\\s*$"))
	      (phys-rx  (regexp "^physical id\\s+:\\s+(\\d+)\\s*$"))
	      (max-num  (lambda (p n)(max (string->number p) n))))
	  ;; (print "data=" data)
	  (if (null? data) ;; something went wrong
	      #f
	      (let loop ((hed      (car data))
			 (tal      (cdr data))
			 (loads    #f)
			 (proc-num 0)  ;; processor includes threads
			 (phys-num 0)  ;; physical chip on motherboard
			 (core-num 0)) ;; core
		;; (print hed ", " loads ", " proc-num ", " phys-num ", " core-num)
		(if (null? tal) ;; have all our data, calculate normalized load and return result
		    (let* ((act-proc (+ proc-num 1))
			   (act-phys (+ phys-num 1))
			   (act-core (+ core-num 1))
			   (adj-proc-load (/ (car loads) act-proc))
			   (adj-core-load (/ (car loads) act-core))
			   (result
			    (append (list (cons 'adj-proc-load adj-proc-load)
					  (cons 'adj-core-load adj-core-load))
				    (list (cons '1m-load (car loads))
					  (cons '5m-load (cadr loads))
					  (cons '15m-load (caddr loads)))
				    (list (cons 'proc act-proc)
					  (cons 'core act-core)
					  (cons 'phys act-phys)))))
		      (write-cached-info logdir actual-host "normalized-load" result)
		      result)
		  (regex-case
		   hed
		   (load-rx  ( x l1 l5 l15 ) (loop (car tal)(cdr tal)(map string->number (list l1 l5 l15)) proc-num phys-num core-num))
		   (proc-rx  ( x p         ) (loop (car tal)(cdr tal) loads           (max-num p proc-num) phys-num core-num))
		   (phys-rx  ( x p         ) (loop (car tal)(cdr tal) loads           proc-num (max-num p phys-num) core-num))
		   (core-rx  ( x c         ) (loop (car tal)(cdr tal) loads           proc-num phys-num (max-num c core-num)))
		   (else 
		    (begin
		      ;; (print "NO MATCH: " hed)
		      (loop (car tal)(cdr tal) loads proc-num phys-num core-num)))))))))))

;;======================================================================
;; L O G G I N G    D B 
;;======================================================================

(define (open-logging-db toppath)
  (let* ((dbpath    (conc (if toppath (conc toppath "/") "") "logging.db")) ;; fname)
	 (dbexists  (file-exists? dbpath))

(define (file-exists? path-string)
  ;; this avoids stack dumps. NOTE: The issues that triggered this approach might have been fixed TODO: test and remove if possible
  ;;;; TODO: catch permission denied exceptions and emit appropriate warnings, eg:  system error while trying to access file: "/nfs/pdx/disks/icf_env_disk001/bjbarcla/gwa/issues/mtdev/randy-slow/reproduce/q...
  (handle-exceptions
   exn
   #f
   (old-file-exists? path-string)))

;;======================================================================
;; pkts stuff
;;======================================================================
)

(define (load-pkts-to-db pktsdir-str setup-pdbpath #!key (use-lt #f)(log-port (current-error-port)))
  (with-queue-db
     pktsdir-str
     setup-pdbpath
     (lambda (pktsdirs pktsdir pdb)
       (for-each
	(lambda (pktsdir) ;; look at all
	  (cond
	   ((not (file-exists? pktsdir))
	    (debug-print 0 log-port "ERROR: packets directory " pktsdir " does not exist."))
	   ((not (directory? pktsdir))
	    (debug-print 0 log-port "ERROR: packets directory path " pktsdir " is not a directory."))
	   ((not (file-read-access? pktsdir))
	    (debug-print 0 log-port "ERROR: packets directory path " pktsdir " is not readable."))
	   (else
	    (print-info 0 log-port "Loading packets found in " pktsdir)
	    (let ((pkts (glob (conc pktsdir "/*.pkt"))))
	      (for-each
	       (lambda (pkt)
		 (let* ((uuid    (cadr (string-match ".*/([0-9a-f]+).pkt" pkt)))
			(exists  (lookup-by-uuid pdb uuid #f)))
		   (if (not exists)
		       (let* ((pktdat (string-intersperse
				       (with-input-from-file pkt read-lines)
				       "\n"))
			      (apkt   (pkt->alist pktdat))
			      (ptype  (alist-ref 'T apkt)))
			 (add-to-queue pdb pktdat uuid (or ptype 'cmd) #f 0)
			 (debug-print 4 log-port "Added " uuid " of type " ptype " to queue"))
		       (debug-print 4 log-port "pkt: " uuid " exists, skipping...")
		       )))
	       pkts)))))
	pktsdirs))
     use-lt: use-lt))
  
(define (get-pkt-alists pkts)
  (map (lambda (x)
	 (alist-ref 'apkt x)) ;; 'pkta pulls out the alist from the read pkt
       pkts))

(define (with-queue-db pktsdir-str setup-pdbpath proc #!key (use-lt #f)(toppath-in #f)(log-port (current-error-port)))
  (let* ((pktsdirs (get-pkts-dirs use-lt pktsdir-str))
	 (pktsdir  (if pktsdirs (car pktsdirs) #f))
	 (toppath  toppath-in) ;; (or (configf:lookup mtconf "scratchdat" "toppath") toppath-in))
	 (pdbpath  (or setup-pdbpath pktsdir))) ;; (configf:lookup mtconf "setup"  "pdbpath")
    (cond
     ((not (and  pktsdir toppath pdbpath))
      (debug-print 0 log-port "ERROR: settings are missing in your megatest.config for area management.")
      (debug-print 0 log-port "  you need to have pktsdir in the [setup] section."))
     ((not (file-exists? pktsdir))
      (debug-print 0 log-port "ERROR: pkts directory not found " pktsdir))
     ((not (equal? (file-owner pktsdir)(current-effective-user-id)))
      (debug-print 0 log-port "ERROR: directory " pktsdir " is not owned by " (current-effective-user-name)))
     (else
	(let* ((pdb  (open-queue-db pdbpath "pkts.db"
				    schema: '("CREATE TABLE groups (id INTEGER PRIMARY KEY,groupname TEXT, CONSTRAINT group_constraint UNIQUE (groupname));"))))
	  (proc pktsdirs pktsdir pdb)
	  (dbi:close pdb))))))

;; (configf:lookup mtconf "setup"  "pktsdirs")
(define (get-pkts-dirs use-lt #!key (top-path #f)(pktsdirs #f))
  (let* ((pktsdirs-str (or pktsdirs
			   (and use-lt
				(conc (or top-path
					  (current-directory))
				      "/lt/.pkts"))))
	 (pktsdirs  (if pktsdirs-str
			(string-split pktsdirs-str " ")
			#f)))
    pktsdirs))

)

;; NOTE: This is the configf module, long term it will replace configf.scm.

(declare (unit mtconfigf))

(module mtconfigf
        (

	 set-debug-printers
	 lazy-convert
	 assoc-safe-add
	 section-var-set!
	 safe-file-exists?
	 read-link-f
	 nice-path
	 eval-string-in-environment
	 safe-setenv
	 with-env-vars
	 cmd-run->list
	 port->list
	 configf:system
	 process-line
	 shell
	 configf:read-line
	 cfgdat->env-alist
	 calc-allow-system
	 apply-wildcards
	 val->alist
	 section->val-alist
	 read-config
	 find-config
	 find-and-read-config
	 lookup
	 var-is?
	 lookup-number
	 section-vars
	 get-section
	 set-section-var
	 compress-multi-lines
	 expand-multi-lines
	 file->list
	 write-config
	 read-refdb
	 map-all-hier-alist
	 config->alist
	 alist->config
	 read-alist
	 write-alist
	 config->ini
	 set-verbosity
         )

(import scheme chicken data-structures extras ports files)
(use posix typed-records srfi-18)
(use regex regex-case srfi-69 srfi-1 directory-utils extras srfi-13)
(import posix)

;; very wierd, the reference to pathname-directory here fixes a reference to possibly unbound identifier problem
;;
;; (define (dummy-function path)
;;   (pathname-directory path)
;;   (absolute-pathname? path)
;;   (normalize-pathname path))

;;======================================================================
;;
;; CONVERGE THIS WITH mtcommon.scm debug-print stuff
;;
;;======================================================================
(define *verbosity* 4)

(define (set-verbosity v)(set! *verbosity* v))

(define (tmp-debug-print n e . params)
  (if (cond
       ((list? n)(< (apply min n) *verbosity*))
       ((number? n) (< n *verbosity*))
       (else #f))
      (with-output-to-port (or e (current-error-port))
	(lambda ()(apply print params)))))
(define debug:print-error print)
(define debug:print       print)
(define debug:print-info  print)
(define debug:print-error tmp-debug-print)
(define debug:print       tmp-debug-print)
(define debug:print-info  tmp-debug-print)
(define *default-log-port* (current-error-port))

(define (set-debug-printers normal-fn info-fn error-fn default-port)
  (if error-fn  (set! debug:print-error error-fn))
  (if info-fn   (set! debug:print-info  info-fn))
  (if normal-fn (set! debug:print       normal-fn))
  (if default-port (set! *default-log-port* default-port)))
  
;; if it looks like a number -> convert it to a number, else return it
;;
(define (lazy-convert inval)
  (let* ((as-num (if (string? inval)(string->number inval) #f)))
    (or as-num inval)))

;; Moved to common
;;
;;;; return list (path fullpath configname)
;;(define (find-config configname #!key (toppath #f))
;;  (if toppath
;;      (let ((cfname (conc toppath "/" configname)))
;;	(if (common:file-exists? cfname)
;;	    (list toppath cfname configname)
;;	    (list #f      #f     #f)))
;;      (let* ((cwd (string-split (current-directory) "/")))
;;	(let loop ((dir cwd))
;;	  (let* ((path     (conc "/" (string-intersperse dir "/")))
;;		 (fullpath (conc path "/" configname)))
;;	    (if (common:file-exists? fullpath)
;;		(list path fullpath configname)
;;		(let ((remcwd (take dir (- (length dir) 1))))
;;		  (if (null? remcwd)
;;		      (list #f #f #f) ;;  #f #f) 
;;		  (loop remcwd)))))))))
;; return list (path fullpath configname)
(define (find-config configname #!key (toppath #f))
  (if toppath
      (let ((cfname (conc toppath "/" configname)))
	(if (safe-file-exists? cfname)
	    (list toppath cfname configname)
	    (list #f      #f     #f)))
      (let* ((cwd (string-split (current-directory) "/")))
	(let loop ((dir cwd))
	  (let* ((path     (conc "/" (string-intersperse dir "/")))
		 (fullpath (conc path "/" configname)))
	    (if (safe-file-exists? fullpath)
		(list path fullpath configname)
		(let ((remcwd (take dir (- (length dir) 1))))
		  (if (null? remcwd)
		      (list #f #f #f) ;;  #f #f) 
		  (loop remcwd)))))))))

(define (assoc-safe-add alist key val #!key (metadata #f))
  (let ((newalist (filter (lambda (x)(not (equal? key (car x)))) alist)))
    (append newalist (list (if metadata
			       (list key val metadata)
			       (list key val))))))

                                         (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
        )))

;; moved to common.scm as it is very megatest specific
;; look at common:set-fields for an example of how to use the set-fields proc
;; pathenvvar will set the named var to the path of the config
;;
;; ;; pathenvvar will set the named var to the path of the config
;; (define (find-and-read-config fname #!key (environ-patt #f)(given-toppath #f)(pathenvvar #f))
;;   (let* ((curr-dir   (current-directory))
;;          (configinfo (find-config fname toppath: given-toppath))
;; 	 (toppath    (car configinfo))
;; 	 (configfile (cadr configinfo))
(define (find-and-read-config fname #!key (environ-patt #f)(given-toppath #f)(pathenvvar #f)(set-fields #f))
  (let* ((curr-dir   (current-directory))
         (configinfo (find-config fname toppath: given-toppath))
	 (toppath    (car configinfo))
	 (configfile (cadr configinfo)))
;; 	 (set-fields (lambda (curr-section next-section ht path)
;; 		       (let ((field-names (if ht (common:get-fields ht) '()))
;; 			     (target      (or (getenv "MT_TARGET")(args:get-arg "-reqtarg")(args:get-arg "-target"))))
;; 			 (debug:print-info 9 *default-log-port* "set-fields with field-names=" field-names " target=" target " curr-section=" curr-section " next-section=" next-section " path=" path " ht=" ht)
;; 			 (if (not (null? field-names))(keys:target-set-args field-names target #f))))))
;;     (if toppath (change-directory toppath)) 
;;     (if (and toppath pathenvvar)(setenv pathenvvar toppath))
;;     (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))))
    (if toppath (change-directory toppath)) 
    (if (and toppath pathenvvar)(setenv pathenvvar toppath))
    (let ((configdat  (if configfile 
			  (read-config configfile #f #t environ-patt: environ-patt
				       post-section-procs: (if set-fields (list (cons "^fields$" set-fields)) '())
				       #f))))
      (if toppath (change-directory curr-dir))
      (list configdat toppath configfile fname))))

(define (lookup cfgdat section var)
  (if (hash-table? cfgdat)
      (let ((sectdat (hash-table-ref/default cfgdat section '())))
	(if (null? sectdat)
	    #f
	    (let ((match (assoc var sectdat)))