Index: common.scm ================================================================== --- common.scm +++ common.scm @@ -2843,28 +2843,31 @@ #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)) - (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)))))) + (configfile (cadr configinfo))) (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)) Index: mtut.scm ================================================================== --- mtut.scm +++ mtut.scm @@ -556,19 +556,19 @@ ;; 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 @@ -580,11 +580,11 @@ (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 @@ -603,11 +603,11 @@ (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" )) @@ -740,15 +740,18 @@ ;; (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 @@ -1103,28 +1106,31 @@ ;; 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 ... ) @@ -1254,18 +1260,20 @@ (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) @@ -1281,14 +1289,17 @@ 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) Index: src/mtcommon.scm ================================================================== --- src/mtcommon.scm +++ src/mtcommon.scm @@ -31,14 +31,22 @@ 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)) @@ -116,10 +124,14 @@ (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 "??")) @@ -217,10 +229,103 @@ ;; 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) @@ -283,7 +388,82 @@ ;;;; 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)) ) Index: src/mtconfigf.scm ================================================================== --- src/mtconfigf.scm +++ src/mtconfigf.scm @@ -22,11 +22,52 @@ (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) @@ -37,13 +78,29 @@ ;; (define (dummy-function path) ;; (pathname-directory path) ;; (absolute-pathname? path) ;; (normalize-pathname path)) -(define debug:print-error print) -(define debug:print print) -(define debug:print-info print) +;;====================================================================== +;; +;; 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 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)) @@ -56,27 +113,27 @@ (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) @@ -630,29 +687,26 @@ (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)) -;; (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)))) +(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))) + (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)