Index: configfmod.scm ================================================================== --- configfmod.scm +++ configfmod.scm @@ -397,12 +397,12 @@ (open-input-file path) path)) ;; we can be handed a port (res (let ((ht-in (if (not ht) (make-hash-table) ht))) - (if (not (configf:lookup ht-in "" "toppath")) - (configf:set-section-var ht-in "" "toppath" (pathname-directory path))) + (if (not (configf:lookup ht-in "toppath" "toppath")) + (configf:set-section-var ht-in "toppath" "toppath" (pathname-directory path))) ht-in)) (metapath (if (or (debug:debug-mode 9) keep-filenames) path #f)) (process-wildcards (lambda (res curr-section-name) @@ -414,11 +414,10 @@ (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 env-to-use)) ;; (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. @@ -427,10 +426,12 @@ (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 @@ -1014,11 +1015,12 @@ (hash-table->alist data))) (define (runconfig:read fname target environ-patt) (let ((ht (make-hash-table))) (if target (hash-table-set! ht target '())) - (configf:read-config fname ht #t environ-patt: environ-patt sections: (if target (list "default" target) #f)))) + (configf:set-section-var ht "toppath" "toppath" (getenv "PWD")) + (configf:read-config fname ht #t environ-patt: environ-patt sections: (if target (list "toppath" "default" target) #f)))) ;;====================================================================== ;; Config file handling ;;====================================================================== @@ -1037,19 +1039,19 @@ (fullcmd (if (member cmdsym '(scheme scm)) `(eval-needed ,(conc "(lambda (ht)" configf:std-imports - "(set! *toppath* \""(configf:lookup ht "" "toppath")"\")" + "(set! *toppath* \""(configf:lookup ht "toppath" "toppath")"\")" cmd ")")) (case cmdsym ((system) `(noeval-needed ,(conc (configf:system ht cmd)))) ;; ((shell sh) `(noeval-needed ,(conc (string-translate (shell quotedcmd) "\n" " ")))) ((shell sh) `(noeval-needed ,(conc (string-translate (shell cmd) "\n" " ")))) ((realpath rp)`(noeval-needed ,(conc (common:nice-path quotedcmd)))) ((getenv gv) `(noeval-needed ,(conc (get-environment-variable cmd)))) - ((mtrah) `(noeval-needed ,(configf:lookup ht "" "toppath"))) + ((mtrah) `(noeval-needed ,(configf:lookup ht "toppath" "toppath"))) ((get g) (match (string-split cmd) ((sect var) `(noeval-needed ,(configf:lookup ht sect var))) (else @@ -1056,11 +1058,11 @@ (debug:print-error 0 *default-log-port* "#{get ...} used with only one parameter, \"" cmd "\", two needed.") '(bad-param ,(conc "#{get ...} used with only one parameter, \"" cmd "\", two needed."))))) ;;((runconfigs-get rget) `(noeval-needed ,(runconfigs-get ht quotedcmd))) ;; (conc "(lambda (ht)(runconfigs-get ht \"" cmd "\"))")) ((runconfigs-get rget) `(noeval-needed ,(runconfigs-get ht cmd))) ;; (conc "(lambda (ht)(runconfigs-get ht \"" cmd "\"))")) (else `(#f ,(conc "cmd: " cmd " not recognised"))))))) - (match + (match fullcmd (('eval-needed newres) (if (or allow-system (not (member cmdtype '("system" "shell" "sh")))) (begin @@ -1070,11 +1072,11 @@ (set! result (handle-exceptions exn (begin (debug:print 0 *default-log-port* "WARNING: failed to process config input \"" l "\", eval-needed, newres="newres", exn="(condition->list exn)) - (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) + (debug:print 0 *default-log-port* " message1: " ((condition-property-accessor 'exn 'message) exn)) (set! result (conc "#{( " cmdtype ") " cmd "}, full expansion: " newres))) (if env-to-use ((eval (read) env-to-use) ht) ((eval (read)) ht) )))))) @@ -1135,11 +1137,11 @@ ;; (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)) + (debug:print 0 *default-log-port* " message2: " ((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 Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -195,10 +195,12 @@ (include "diff-report.scm") (include "ods.scm") (define *usage-log-file* #f) ;; put path to file for logging usage in this var in the ~/.megatestrc file (define *usage-use-seconds* #t) ;; for Epoc seconds in usage logging change this to #t in ~/.megatestrc file + +(set! *toppath* (get-environment-variable "PWD")) ;;====================================================================== ;; Test commands (i.e. for use inside tests) ;;====================================================================== @@ -282,11 +284,11 @@ (let* ((config-reruns (let ((x (configf:lookup *configdat* "setup" "reruns"))) (if x (string->number x) #f))) (rerun-cnt (if config-reruns config-reruns 1))) - + (debug:print 0 *default-log-port* "handle-run-requests *toppath* = " *toppath*) (runs:run-tests target runname #f ;; (common:args-get-testpatt #f) ;; (or (args:get-arg "-testpatt") ;; "%") @@ -758,15 +760,20 @@ ;; (if (args:get-arg "-start-dir") (if (common:file-exists? (args:get-arg "-start-dir")) (let ((fullpath (common:real-path (args:get-arg "-start-dir")))) (set-environment-variable! "PWD" fullpath) - (change-directory fullpath)) + (change-directory fullpath) + (set! *toppath* fullpath)) (begin (debug:print-error 0 *default-log-port* "non-existant start dir " (args:get-arg "-start-dir") " specified, exiting.") (exit 1)))) + + (set! *toppath* (get-environment-variable "PWD")) + + ;; immediately set MT_TARGET if -reqtarg or -target are available ;; (let ((targ (or (args:get-arg "-reqtarg")(args:get-arg "-target")))) (if targ (begin Index: runsmod.scm ================================================================== --- runsmod.scm +++ runsmod.scm @@ -378,11 +378,11 @@ (allowed-tests #f) (runconf #f)) ;; check if readonly (when readonly-mode - (debug:print-error 0 *default-log-port* "megatest.db is readonly. Cannot proceed.") + (debug:print-error 0 *default-log-port* *toppath* ".db/main.db is readonly. Cannot proceed.") (exit 1)) ;; per user request. If less than 100Meg space on dbdir partition, bail out with error ;; this will reduce issues in database corruption (common:check-db-dir-and-exit-if-insufficient)