Overview
Comment: | Various fixes in config handling |
---|---|
Downloads: | Tarball | ZIP archive | SQL archive |
Timelines: | family | ancestors | descendants | both | v1.6584-nanomsg |
Files: | files | file ages | folders |
SHA1: |
2749ac0d131230c1f55e6c68f767fb32 |
User & Date: | matt on 2021-11-25 20:41:03 |
Other Links: | branch diff | manifest | tags |
Context
2021-11-26
| ||
19:30 | wip check-in: 099e36e67a user: matt tags: v1.6584-nanomsg | |
2021-11-25
| ||
20:41 | Various fixes in config handling check-in: 2749ac0d13 user: matt tags: v1.6584-nanomsg | |
18:25 | Simplerun now passes check-in: c8d4b40864 user: matt tags: v1.6584-nanomsg | |
Changes
Modified configfmod.scm from [be968f04c6] to [fa96749dc9].
︙ | ︙ | |||
44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 | configf:section-var-set! configf:section-vars configf:set-section-var configf:var-is? configf:write-alist configf:write-config find-config nice-path process:cmd-run->list runconfig:read runconfigs-get safe-setenv setenv configf:eval-string-in-environment ) (import scheme chicken.base chicken.condition chicken.file chicken.io chicken.pathname chicken.port chicken.pretty-print | > > > | 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 | configf:section-var-set! configf:section-vars configf:set-section-var configf:var-is? configf:write-alist configf:write-config find-config getenv mytarget nice-path process:cmd-run->list runconfig:read runconfigs-get safe-setenv setenv configf:eval-string-in-environment ) (import scheme big-chicken ;; more of a reminder than anything ... chicken.base chicken.condition chicken.file chicken.io chicken.pathname chicken.port chicken.pretty-print |
︙ | ︙ | |||
99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 | z3 ) (define getenv get-environment-variable) (define setenv set-environment-variable!) (define unsetenv unset-environment-variable!) ;;====================================================================== ;; move debug stuff to separate module then put these back where they belong ;;====================================================================== ;;====================================================================== ;; lookup routines - replicated from configf ;;====================================================================== (define (configf:lookup cfgdat section var) (if (hash-table? cfgdat) (let ((sectdat (hash-table-ref/default cfgdat section '()))) (if (null? sectdat) #f | > > > > > > > | | | | 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 | z3 ) (define getenv get-environment-variable) (define setenv set-environment-variable!) (define unsetenv unset-environment-variable!) ;;====================================================================== ;; parameters ;;====================================================================== ;; while targets are Megatest specific they are a useful concept (define mytarget (make-parameter #f)) ;;====================================================================== ;; move debug stuff to separate module then put these back where they belong ;;====================================================================== ;;====================================================================== ;; lookup routines - replicated from configf ;;====================================================================== (define (configf:lookup cfgdat section var) (if (hash-table? cfgdat) (let ((sectdat (hash-table-ref/default cfgdat section '()))) (if (null? sectdat) #f (let ((res (assoc var sectdat))) (if res ;; (and match (list? match)(> (length match) 1)) (cadr res) #f)) )) #f)) (define (configf: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 |
︙ | ︙ | |||
702 703 704 705 706 707 708 | delta-env-alist)))) (let ((rv (thunk))) (for-each (lambda (x) (x)) restore-thunks) ;; restore env to original state rv))) ;; return a nice clean pathname made absolute (define (common:nice-path dir) | | | | | 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 | delta-env-alist)))) (let ((rv (thunk))) (for-each (lambda (x) (x)) restore-thunks) ;; restore env to original state rv))) ;; return a nice clean pathname made absolute (define (common:nice-path dir) (let ((res (string-match "^(~[^\\/]*)(\\/.*|)$" dir))) (if res ;; using ~ for home? (common:nice-path (conc (common:read-link-f (cadr res)) "/" (caddr res))) (normalize-pathname (if (absolute-pathname? dir) dir (conc (current-directory) "/" dir)))))) ;; make "nice-path" available in config files and the repl (define nice-path common:nice-path) |
︙ | ︙ | |||
739 740 741 742 743 744 745 | (tal (cdr fdat)) (cur "") (led #f) (res '())) ;; ALL WHITESPACE LEADING LINES ARE TACKED ON!! ;; 1. remove led whitespace ;; 2. tack on to hed with "\n" | | | | | | 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 | (tal (cdr fdat)) (cur "") (led #f) (res '())) ;; ALL WHITESPACE LEADING LINES ARE TACKED ON!! ;; 1. remove led whitespace ;; 2. tack on to hed with "\n" (let ((res (string-match configf:cont-ln-rx hed))) (if res ;; blast! have to deal with a multiline (let* ((lead (cadr res)) (lval (caddr res)) (newl (conc cur "\n" lval))) (if (not led)(set! led lead)) (if (null? tal) (set! fdat (append fdat (list newl))) (loop (car tal)(cdr tal) newl led res))) ;; NB// not tacking newl onto res (let ((newres (if led (append res (list cur hed)) |
︙ | ︙ | |||
981 982 983 984 985 986 987 | (configf:read-config fname ht #t environ-patt: environ-patt sections: (if target (list "default" target) #f)))) ;;====================================================================== ;; Config file handling ;;====================================================================== ;; convert to param? | | > | < < | | | 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 | (configf:read-config fname ht #t environ-patt: environ-patt sections: (if target (list "default" target) #f)))) ;;====================================================================== ;; Config file handling ;;====================================================================== ;; convert to param? (define configf:std-imports "(import big-chicken configfmod commonmod rmtmod)") (define (configf:process-one matchdat l ht allow-system env-to-use linenum) (let* ((prestr (list-ref matchdat 1)) (cmdtype (list-ref matchdat 2)) ;; eval, system, shell, getenv (cmd (list-ref matchdat 3)) (quotedcmd (conc "\""cmd"\"")) (poststr (list-ref matchdat 4)) (result #f) (start-time (current-seconds)) (cmdsym (string->symbol cmdtype)) (fullcmd (if (member cmdsym '(scheme scm)) `(eval-needed ,(conc "(lambda (ht)" configf:std-imports cmd ")")) (case cmdsym ((system) `(noeval-needed ,(conc (configf:system ht quotedcmd)))) ((shell sh) `(noeval-needed ,(conc (string-translate (shell quotedcmd) "\n" " ")))) ((realpath rp)`(noeval-needed ,(conc (common:nice-path quotedcmd)))) ((getenv gv) `(noeval-needed ,(conc (get-environment-variable cmd)))) ;; ((mtrah) (conc (or *toppath* (get-environment-variable \"MT_RUN_AREA_HOME\")))) ((get g) (match (string-split cmd) ((sect var) `(noeval-needed ,(configf:lookup ht sect var))) (else (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 "\"))")) (else `(#f ,(conc "cmd: " cmd " not recognised"))))))) (match fullcmd |
︙ | ︙ | |||
1033 1034 1035 1036 1037 1038 1039 | (lambda () (set! result (if env-to-use ((eval (read) env-to-use) ht) ((eval (read)) ht) )))) (set! result (conc "#{(" cmdtype ") " cmd "}"))))) (('noeval-needed newres)(set! result newres)) | | | | 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 | (lambda () (set! result (if env-to-use ((eval (read) env-to-use) ht) ((eval (read)) ht) )))) (set! result (conc "#{(" cmdtype ") " cmd "}"))))) (('noeval-needed newres)(set! result newres)) (else ;; (#f errres) (debug:print 0 *default-log-port* "WARNING: failed to process config input \""l"\", fullcmd="fullcmd"."))) ;; we process as a result (let ((delta (- (current-seconds) start-time))) (debug:print-info (if (> delta 2) 0 9) *default-log-port* "for line \"" l "\"\n command: " cmd " took " delta " seconds to run with output:\n " result)) (conc prestr result poststr))) (define (configf:process-line l ht allow-system env-to-use #!key (linenum #f)) (let loop ((res l)) |
︙ | ︙ | |||
1116 1117 1118 1119 1120 1121 1122 | (loop (conc prestr result poststr))) res)) res))) ;;====================================================================== ;; Lookup a value in runconfigs based on -reqtarg or -target ;; | | | | 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 | (loop (conc prestr result poststr))) res)) res))) ;;====================================================================== ;; Lookup a value in runconfigs based on -reqtarg or -target ;; (define (runconfigs-get config var) (let ((targ (mytarget) #;(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)))) ;; pathenvvar will set the named var to the path of the config |
︙ | ︙ |
Modified rmtmod.scm from [70b915874b] to [db7ecb31bf].
︙ | ︙ | |||
310 311 312 313 314 315 316 | (if (not *rmt:remote*)(set! *rmt:remote* (make-rmt:remote))) (let* ((apath *toppath*) (conns *rmt:remote*) (dbname (db:run-id->dbname rid))) (if *localmode* (let* ((dbdat (dbr:dbstruct-get-dbdat *dbstruct* dbname)) (indat `((cmd . ,cmd)(params . ,params)))) | | > > | 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 | (if (not *rmt:remote*)(set! *rmt:remote* (make-rmt:remote))) (let* ((apath *toppath*) (conns *rmt:remote*) (dbname (db:run-id->dbname rid))) (if *localmode* (let* ((dbdat (dbr:dbstruct-get-dbdat *dbstruct* dbname)) (indat `((cmd . ,cmd)(params . ,params)))) (api:process-request *dbstruct* indat) ;; (api:process-request dbdat indat) ) (begin (rmt:general-open-connection conns apath dbname) (rmt:send-receive-real conns apath dbname cmd params))))) #;(define (rmt:send-receive-setup conn) (if (not (rmt:conn-inport conn)) (let-values (((i o) (tcp-connect (rmt:conn-ipaddr conn) |
︙ | ︙ |