new environment-variable API
The `current-environment-variables' parameter determines the current mutable "environment variable set". If that set is the initial one for a Racket process, then using the set corresponds to working with OS environment variables. Otherwise, it's really just a hash table that is packaged up as OS environment variables if a subprocess is created. The new environment-variable interface works in terms of bytes, instead of assuming that environment variable names and values fit in a string encoding. The string-based `getenv' and `putenv' are still available as convenience wrappers. The checking on environment-variable names for those wrappers is a little tighter, preventing any attempt to use a name that contains "=".
This commit is contained in:
Matthew Flatt
parent
de9b77ad6d
commit
3d1b0bd381
|
|
@ -185,6 +185,42 @@
|
|||
|
||||
;; -------------------------------------------------------------------------
|
||||
|
||||
(define (string-no-nuls? s)
|
||||
(and (string? s)
|
||||
(not (regexp-match? #rx"\0" s))))
|
||||
|
||||
(define (bytes-environment-variable-name? s)
|
||||
(and (bytes? s)
|
||||
(if (eq? 'windows (system-type))
|
||||
(regexp-match? #rx#"^[^\0=]+$" s)
|
||||
(regexp-match? #rx#"^[^\0=]*$" s))))
|
||||
|
||||
(define (string-environment-variable-name? s)
|
||||
(and (string? s)
|
||||
(bytes-environment-variable-name?
|
||||
(string->bytes/locale s (char->integer #\?)))))
|
||||
|
||||
(define (getenv s)
|
||||
(unless (string-environment-variable-name? s)
|
||||
(raise-argument-error 'getenv "string-environment-variable-name?" s))
|
||||
(let ([v (environment-variables-get (string->bytes/locale s (char->integer #\?)))])
|
||||
(and v
|
||||
(bytes->string/locale v #\?))))
|
||||
|
||||
(define (putenv s t)
|
||||
(unless (string-no-nuls? s)
|
||||
(raise-argument-error 'putenv "string-environment-variable-name?" 0 s t))
|
||||
(unless (string-no-nuls? t)
|
||||
(raise-argument-error 'putenv "string-no-nuls?" 1 s t))
|
||||
(and
|
||||
(environment-variables-set! (string->bytes/locale s (char->integer #\?))
|
||||
(string->bytes/locale t (char->integer #\?))
|
||||
(current-environment-variables)
|
||||
(lambda () #f))
|
||||
#t))
|
||||
|
||||
;; -------------------------------------------------------------------------
|
||||
|
||||
(#%provide define-syntax-rule
|
||||
rationalize
|
||||
path-string? path-replace-suffix path-add-suffix
|
||||
|
|
@ -196,4 +232,7 @@
|
|||
collection-path collection-file-path load/use-compiled
|
||||
guard-evt channel-get channel-try-get channel-put
|
||||
port? displayln
|
||||
find-library-collection-paths))
|
||||
find-library-collection-paths
|
||||
bytes-environment-variable-name?
|
||||
string-environment-variable-name?
|
||||
getenv putenv))
|
||||
|
|
|
|||
119
collects/scribblings/reference/envvars.scrbl
Normal file
119
collects/scribblings/reference/envvars.scrbl
Normal file
|
|
@ -0,0 +1,119 @@
|
|||
#lang scribble/doc
|
||||
@(require "mz.rkt")
|
||||
|
||||
@title[#:tag "envvars"]{Environment Variables}
|
||||
|
||||
A @deftech{environment variable set} encapsulates a partial mapping
|
||||
from byte strings to bytes strings. A Racket process's initial
|
||||
@tech{environment variable set} is connected to the operating system's
|
||||
environment variables: accesses or changes to the set read or change
|
||||
operating-system environment variables for the Racket process.
|
||||
|
||||
The current @tech{environment variable set}, which is determined by
|
||||
the @racket[current-environment-variables] parameter, is propagated to
|
||||
a @tech{subprocess} when the @tech{subprocess} is created.
|
||||
|
||||
|
||||
@defproc[(environment-variables? [v any/c]) boolean?]{
|
||||
|
||||
Returns @racket[#t] if @racket[v] is an @tech{environment variable
|
||||
set}, @racket[#f] otherwise.}
|
||||
|
||||
|
||||
@defparam[current-environment-variables env environment-variables?]{
|
||||
|
||||
A @tech{parameter} that determines the @tech{environment variable set}
|
||||
that is propagated to a @tech{subprocess} and that is used as the
|
||||
default set for functions such as @racket[environment-variables-get] or
|
||||
@racket[getenv].}
|
||||
|
||||
|
||||
@defproc[(bytes-environment-variable-name? [v any/c]) boolean?]{
|
||||
|
||||
Returns @racket[#t] if @racket[v] is a byte string and if it is valid
|
||||
for an environment variable name. An environment variable name must
|
||||
contain no bytes the with value @racket[0] or @racket[61], where
|
||||
@racket[61] is @racket[(char->integer #\=)]. On Windows, an
|
||||
environment variable name also must have a non-zero length.}
|
||||
|
||||
|
||||
@defproc[(environment-variables-get [name bytes-environment-variable-name?]
|
||||
[env environment-variables?
|
||||
(current-environment-variables)])
|
||||
(or/c #f (and/c bytes-no-nul? immutable?))]{
|
||||
|
||||
Returns the mapping for @racket[name] in @racket[env], returning
|
||||
@racket[#f] if @racket[name] has no mapping.
|
||||
|
||||
Normally, @racket[name] should be a byte-string encoding of a string
|
||||
using the default encoding of the current @tech{locale}. On Windows,
|
||||
@racket[name] is coerced to a UTF-8 encoding if @racket[env] is the
|
||||
initial @tech{environment variable set} of the Racket process.}
|
||||
|
||||
|
||||
@defproc[(environment-variables-set! [name bytes-environment-variable-name?]
|
||||
[maybe-bstr (or/c bytes-no-nul? #f)]
|
||||
[env environment-variables?
|
||||
(current-environment-variables)]
|
||||
[fail (-> any)
|
||||
(lambda ()
|
||||
(raise (make-exn:fail ....)))])
|
||||
any]{
|
||||
|
||||
Changes the mapping for @racket[name] in @racket[env] to
|
||||
@racket[maybe-bstr]. If @racket[maybe-bstr] is @racket[#f] and
|
||||
@racket[env] is the initial @tech{environment variable set} of the
|
||||
Racket process, then the operating system environment-variable mapping
|
||||
for @racket[name] is removed.
|
||||
|
||||
Normally, @racket[name] and @racket[maybe-bstr] should be a
|
||||
byte-string encoding of a string using the default encoding of the
|
||||
current @tech{locale}. On Windows, @racket[name] and
|
||||
@racket[maybe-bstr] are coerced to a UTF-8 encoding if @racket[env] is
|
||||
the initial @tech{environment variable set} of the Racket process.
|
||||
|
||||
On success, the result of @racket[environment-variables-set!] is
|
||||
@|void-const|. If @racket[env] is the initial @tech{environment
|
||||
variable set} of the Racket process, then attempting to adjust the
|
||||
operating system environment-variable mapping might fail for some reason,
|
||||
in which case @racket[fail] is called in tail position with respect to the
|
||||
@racket[environment-variables-set!]. The default @racket[fail] raises
|
||||
an exception.}
|
||||
|
||||
|
||||
@defproc[(environment-variables-keys [env environment-variables?])
|
||||
(listof (and/c bytes-environment-variable-name? immutable?))]{
|
||||
|
||||
Returns a list of byte strings that corresponds to names mapped by
|
||||
@racket[env].}
|
||||
|
||||
|
||||
@defproc[(environment-variables-copy [env environment-variables?])
|
||||
environment-variables?]{
|
||||
|
||||
Returns an @tech{environment variable set} that is initialized with
|
||||
the same mappings as @racket[env].}
|
||||
|
||||
|
||||
@deftogether[(
|
||||
@defproc[(getenv [name string-environment-variable-name?])
|
||||
(or/c string-no-nuls? #f)]
|
||||
@defproc[(putenv [name string-environment-variable-name?]
|
||||
[value string-no-nuls?]) boolean?]
|
||||
)]{
|
||||
|
||||
Convenience wrappers for @racket[environment-variables-get] and
|
||||
@racket[environment-variables-set!] that convert between strings and
|
||||
byte strings using the current @tech{locale}'s default encoding (using
|
||||
@racket[#\?] as the replacement character for encoding errors) and
|
||||
always using the current @tech{environment variable set} from
|
||||
@racket[current-environment-variables]. The @racket[putenv] function
|
||||
returns @racket[#t] for success and @racket[#f] for failure.}
|
||||
|
||||
|
||||
@defproc[(string-environment-variable-name? [v any/c]) boolean?]{
|
||||
|
||||
Returns @racket[#t] if @racket[v] is a string and if its encoding
|
||||
using the current @tech{locale}'s encoding is valid for an environment
|
||||
variable name according to @racket[bytes-environment-variable-name?].}
|
||||
|
||||
|
|
@ -11,5 +11,6 @@
|
|||
@include-section["subprocess.scrbl"]
|
||||
@include-section["logging.scrbl"]
|
||||
@include-section["time.scrbl"]
|
||||
@include-section["envvars.scrbl"]
|
||||
@include-section["runtime.scrbl"]
|
||||
@include-section["cmdline.scrbl"]
|
||||
|
|
|
|||
|
|
@ -3,21 +3,6 @@
|
|||
|
||||
@title[#:tag "runtime"]{Environment and Runtime Information}
|
||||
|
||||
@defproc[(getenv [name string?]) (or/c string? #f)]{
|
||||
|
||||
Gets the value of an operating system environment variable. The
|
||||
@racket[name] argument cannot contain a null character; if an
|
||||
environment variable named by @racket[name] exists, its value is
|
||||
returned (as a string); otherwise, @racket[#f] is returned.}
|
||||
|
||||
@defproc[(putenv [name string?] [value string?]) boolean?]{
|
||||
|
||||
Sets the value of an operating system environment variable. The
|
||||
@racket[name] and @racket[value] arguments are strings that cannot
|
||||
contain a null character; the environment variable named by
|
||||
@racket[name] is set to @racket[value]. The return value is
|
||||
@racket[#t] if the assignment succeeds, @racket[#f] otherwise.}
|
||||
|
||||
@defproc[(system-type [mode (or/c 'os 'word 'gc 'link 'so-suffix 'so-mode 'machine)
|
||||
'os])
|
||||
(or/c symbol? string? bytes? exact-positive-integer?)]{
|
||||
|
|
|
|||
|
|
@ -24,8 +24,10 @@
|
|||
(or/c (and/c input-port? file-stream-port?) #f))])]{
|
||||
|
||||
Creates a new process in the underlying operating system to execute
|
||||
@racket[command] asynchronously. See also @racket[system] and
|
||||
@racket[process] from @racketmodname[racket/system].
|
||||
@racket[command] asynchronously, providing the new process with
|
||||
environment variables @racket[current-environment-variables]. See also
|
||||
@racket[system] and @racket[process] from
|
||||
@racketmodname[racket/system].
|
||||
|
||||
The @racket[command] argument is a path to a program executable, and
|
||||
the @racket[arg]s are command-line arguments for the program. See
|
||||
|
|
|
|||
|
|
@ -1258,6 +1258,23 @@
|
|||
(arity-test printf 1 -1)
|
||||
(arity-test fprintf 2 -1)
|
||||
|
||||
(test #t environment-variables? (current-environment-variables))
|
||||
(test #f environment-variables? 10)
|
||||
(test #t environment-variables? (environment-variables-copy (current-environment-variables)))
|
||||
(test #t list? (environment-variables-keys (current-environment-variables)))
|
||||
(test #t andmap bytes? (environment-variables-keys (current-environment-variables)))
|
||||
(test #t =
|
||||
(length (environment-variables-keys (current-environment-variables)))
|
||||
(length (environment-variables-keys (environment-variables-copy (current-environment-variables)))))
|
||||
(test #f bytes-environment-variable-name? #"x=")
|
||||
(test #f bytes-environment-variable-name? #"x\0")
|
||||
(test (not (eq? 'windows (system-type))) bytes-environment-variable-name? #"")
|
||||
|
||||
(test #f string-environment-variable-name? "x=")
|
||||
(test #f string-environment-variable-name? "x\0")
|
||||
(test (not (eq? 'windows (system-type))) string-environment-variable-name? "")
|
||||
|
||||
(define (env-var-tests)
|
||||
(define success-1? (putenv "APPLE" "AnApple"))
|
||||
(define success-2? (putenv "BANANA" "AnotherApple"))
|
||||
(err/rt-test (getenv 7))
|
||||
|
|
@ -1273,6 +1290,26 @@
|
|||
(test "AnotherApple" getenv "BANANA")
|
||||
(test #f getenv "AnUndefinedEnvironmentVariable")
|
||||
|
||||
(test #"AnApple" environment-variables-get #"APPLE")
|
||||
(err/rt-test (environment-variables-get #"=AP=PLE="))
|
||||
(test (void) environment-variables-set! #"APPLE" #"=x=")
|
||||
(test #"=x=" environment-variables-get #"APPLE")
|
||||
(test #"AnotherApple" environment-variables-get #"BANANA")
|
||||
(test (void) environment-variables-set! #"BANANA" #f)
|
||||
(test #f environment-variables-get #"BANANA")
|
||||
(test #f getenv "BANANA")
|
||||
|
||||
(test #"APPLE" car (member #"APPLE" (environment-variables-keys
|
||||
(current-environment-variables))))
|
||||
(test #f member #"BANANA" (environment-variables-keys
|
||||
(current-environment-variables))))
|
||||
|
||||
(parameterize ([current-environment-variables
|
||||
(environment-variables-copy
|
||||
(current-environment-variables))])
|
||||
(env-var-tests))
|
||||
(env-var-tests)
|
||||
|
||||
(arity-test getenv 1 1)
|
||||
(arity-test putenv 2 2)
|
||||
|
||||
|
|
|
|||
|
|
@ -460,6 +460,20 @@
|
|||
(parameterize ([current-input-port (open-input-string "")])
|
||||
(test 3 system/exit-code "exit 3")))
|
||||
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Environment variables:
|
||||
|
||||
(let ([out (open-output-bytes)])
|
||||
(parameterize ([current-input-port (open-input-string "Hi\n")]
|
||||
[current-output-port out]
|
||||
[current-environment-variables
|
||||
(environment-variables-copy
|
||||
(current-environment-variables))])
|
||||
(environment-variables-set! #"Hola" #"hi, there")
|
||||
(system* self "-e" "(getenv \"Hola\")"))
|
||||
(test "\"hi, there\"\n" get-output-string out))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(for ([f (list tmpfile tmpfile2)] #:when (file-exists? f)) (delete-file f))
|
||||
|
|
|
|||
|
|
@ -1,3 +1,9 @@
|
|||
Version 5.3.4.2
|
||||
Added current-environment-variables, environment-variables-get,
|
||||
environment-variables-set!, environment-variables-keys,
|
||||
environment-variables-copy, bytes-environment-variables-name?,
|
||||
string-environment-variables-name?, and environment-variables?
|
||||
|
||||
Version 5.3.4.1
|
||||
Changed JIT to support ARM
|
||||
|
||||
|
|
|
|||
|
|
@ -104,7 +104,7 @@
|
|||
["libpangocairo-1.0-0.dll" 94625]
|
||||
["libpangowin32-1.0-0.dll" 143647]
|
||||
["libpangoft2-1.0-0.dll" 679322]]
|
||||
(if (getenv "PLT_WIN_GTK")
|
||||
(if (environment-variables-get #"PLT_WIN_GTK")
|
||||
'(["libatk-1.0-0.dll" 153763]
|
||||
["libgtk-win32-2.0-0.dll" 4740156]
|
||||
["libgdk-win32-2.0-0.dll" 827670]
|
||||
|
|
@ -195,7 +195,7 @@
|
|||
(define-values (path-size/show)
|
||||
(lambda (path)
|
||||
(let-values ([(sz) (path-size path)])
|
||||
(if (getenv "PLT_SHOW_PATH_SIZES")
|
||||
(if (environment-variables-get #"PLT_SHOW_PATH_SIZES")
|
||||
(printf "~s ~s\n" path sz)
|
||||
(void))
|
||||
sz)))
|
||||
|
|
|
|||
|
|
@ -1365,6 +1365,7 @@ enum {
|
|||
MZCONFIG_LOAD_EXTENSION_HANDLER,
|
||||
|
||||
MZCONFIG_CURRENT_DIRECTORY,
|
||||
MZCONFIG_CURRENT_ENV_VARS,
|
||||
|
||||
MZCONFIG_RANDOM_STATE,
|
||||
|
||||
|
|
|
|||
File diff suppressed because it is too large
Load Diff
|
|
@ -9011,7 +9011,8 @@ static char *cmdline_protect(char *s)
|
|||
|
||||
static intptr_t mz_spawnv(char *command, const char * const *argv,
|
||||
int exact_cmdline, intptr_t sin, intptr_t sout, intptr_t serr, int *pid,
|
||||
int new_process_group)
|
||||
int new_process_group,
|
||||
void *env)
|
||||
{
|
||||
int i, l, len = 0;
|
||||
intptr_t cr_flag;
|
||||
|
|
@ -9056,10 +9057,11 @@ static intptr_t mz_spawnv(char *command, const char * const *argv,
|
|||
cr_flag = 0;
|
||||
if (new_process_group)
|
||||
cr_flag |= CREATE_NEW_PROCESS_GROUP;
|
||||
cr_flag |= CREATE_UNICODE_ENVIRONMENT;
|
||||
|
||||
if (CreateProcessW(WIDE_PATH_COPY(command), WIDE_PATH_COPY(cmdline),
|
||||
NULL, NULL, 1 /*inherit*/,
|
||||
cr_flag, NULL, NULL,
|
||||
cr_flag, env, NULL,
|
||||
&startup, &info)) {
|
||||
CloseHandle(info.hThread);
|
||||
*pid = info.dwProcessId;
|
||||
|
|
@ -9129,6 +9131,8 @@ static Scheme_Object *subprocess(int c, Scheme_Object *args[])
|
|||
System_Child *sc;
|
||||
# endif
|
||||
int fork_errno = 0;
|
||||
char *env;
|
||||
int need_free;
|
||||
#else
|
||||
void *sc = 0;
|
||||
#endif
|
||||
|
|
@ -9351,7 +9355,10 @@ static Scheme_Object *subprocess(int c, Scheme_Object *args[])
|
|||
fflush(stderr);
|
||||
|
||||
{
|
||||
Scheme_Object *tcd;
|
||||
Scheme_Object *tcd, *envvar;
|
||||
Scheme_Config *config;
|
||||
char *env;
|
||||
int need_free;
|
||||
|
||||
if (!exact_cmdline) {
|
||||
/* protect spaces, etc. in the arguments: */
|
||||
|
|
@ -9362,20 +9369,29 @@ static Scheme_Object *subprocess(int c, Scheme_Object *args[])
|
|||
}
|
||||
}
|
||||
|
||||
config = scheme_current_config();
|
||||
|
||||
/* Set real CWD before spawn: */
|
||||
tcd = scheme_get_param(scheme_current_config(), MZCONFIG_CURRENT_DIRECTORY);
|
||||
tcd = scheme_get_param(config, MZCONFIG_CURRENT_DIRECTORY);
|
||||
scheme_os_setcwd(SCHEME_BYTE_STR_VAL(tcd), 0);
|
||||
|
||||
envvar = scheme_get_param(config, MZCONFIG_CURRENT_ENV_VARS);
|
||||
|
||||
env = scheme_environment_variables_to_block(envvar, &need_free);
|
||||
|
||||
spawn_status = mz_spawnv(command, (const char * const *)argv,
|
||||
exact_cmdline,
|
||||
to_subprocess[0],
|
||||
from_subprocess[1],
|
||||
err_subprocess[1],
|
||||
&pid,
|
||||
new_process_group);
|
||||
new_process_group,
|
||||
env);
|
||||
|
||||
if (spawn_status != -1)
|
||||
sc = (void *)spawn_status;
|
||||
|
||||
if (need_free) free(env);
|
||||
}
|
||||
|
||||
#else
|
||||
|
|
@ -9539,10 +9555,17 @@ static Scheme_Object *subprocess(int c, Scheme_Object *args[])
|
|||
#endif
|
||||
}
|
||||
|
||||
/* Set real CWD */
|
||||
/* Set real CWD and get envrionment variables */
|
||||
{
|
||||
Scheme_Object *dir;
|
||||
dir = scheme_get_param(scheme_current_config(), MZCONFIG_CURRENT_DIRECTORY);
|
||||
Scheme_Object *dir, *envvar;
|
||||
Scheme_Config *config;
|
||||
|
||||
config = scheme_current_config();
|
||||
|
||||
envvar = scheme_get_param(config, MZCONFIG_CURRENT_ENV_VARS);
|
||||
env = scheme_environment_variables_to_block(envvar, &need_free);
|
||||
|
||||
dir = scheme_get_param(config, MZCONFIG_CURRENT_DIRECTORY);
|
||||
if (!scheme_os_setcwd(SCHEME_PATH_VAL(dir), 1)) {
|
||||
scheme_console_printf("racket: chdir failed to: %s\n", SCHEME_BYTE_STR_VAL(dir));
|
||||
_exit(1);
|
||||
|
|
@ -9564,10 +9587,13 @@ static Scheme_Object *subprocess(int c, Scheme_Object *args[])
|
|||
#endif
|
||||
END_XFORM_SKIP;
|
||||
|
||||
err = MSC_IZE(execv)(command, argv);
|
||||
err = MSC_IZE(execve)(command, argv, (char **)env);
|
||||
if (err)
|
||||
err = errno;
|
||||
|
||||
if (need_free)
|
||||
free(env);
|
||||
|
||||
/* If we get here it failed; give up */
|
||||
|
||||
/* using scheme_signal_error will leave us in the forked process,
|
||||
|
|
|
|||
|
|
@ -14,7 +14,7 @@
|
|||
|
||||
#define USE_COMPILED_STARTUP 1
|
||||
|
||||
#define EXPECTED_PRIM_COUNT 1088
|
||||
#define EXPECTED_PRIM_COUNT 1092
|
||||
#define EXPECTED_UNSAFE_COUNT 100
|
||||
#define EXPECTED_FLFXNUM_COUNT 69
|
||||
#define EXPECTED_EXTFL_COUNT 45
|
||||
|
|
|
|||
|
|
@ -4000,6 +4000,10 @@ void scheme_unused_intptr(intptr_t);
|
|||
|
||||
intptr_t scheme_check_overflow(intptr_t n, intptr_t m, intptr_t a);
|
||||
|
||||
Scheme_Object *scheme_make_environment_variables(Scheme_Hash_Table *ht);
|
||||
# define SCHEME_ENVVARS_TABLE(ev) ((Scheme_Hash_Table *)SCHEME_PTR_VAL(ev))
|
||||
void *scheme_environment_variables_to_block(Scheme_Object *env, int *_need_free);
|
||||
|
||||
/*========================================================================*/
|
||||
/* places */
|
||||
/*========================================================================*/
|
||||
|
|
|
|||
|
|
@ -13,12 +13,12 @@
|
|||
consistently.)
|
||||
*/
|
||||
|
||||
#define MZSCHEME_VERSION "5.3.4.1"
|
||||
#define MZSCHEME_VERSION "5.3.4.2"
|
||||
|
||||
#define MZSCHEME_VERSION_X 5
|
||||
#define MZSCHEME_VERSION_Y 3
|
||||
#define MZSCHEME_VERSION_Z 4
|
||||
#define MZSCHEME_VERSION_W 1
|
||||
#define MZSCHEME_VERSION_W 2
|
||||
|
||||
#define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y)
|
||||
#define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W)
|
||||
|
|
|
|||
|
|
@ -261,13 +261,14 @@
|
|||
"(if(and(relative-path? program)"
|
||||
"(let-values(((base name dir?)(split-path program)))"
|
||||
"(eq? base 'relative)))"
|
||||
" (let ((paths-str (getenv \"PATH\"))"
|
||||
" (let ((paths-str (environment-variables-get #\"PATH\"))"
|
||||
"(win-add(lambda(s)(if(eq?(system-type) 'windows) "
|
||||
" (cons (bytes->path #\".\") s) "
|
||||
" s))))"
|
||||
"(let loop((paths(win-add "
|
||||
"(if paths-str"
|
||||
"(path-list-string->path-list paths-str null)"
|
||||
"(path-list-string->path-list(bytes->string/locale paths-str #\\?)"
|
||||
" null)"
|
||||
" null))))"
|
||||
"(if(null? paths)"
|
||||
" #f"
|
||||
|
|
@ -634,7 +635,10 @@
|
|||
"(cons-if(lambda(f r)(if f(cons f r) r))))"
|
||||
"(path-list-string->path-list"
|
||||
"(if user-too?"
|
||||
" (or (getenv \"PLTCOLLECTS\") \"\")"
|
||||
" (let ((c (environment-variables-get #\"PLTCOLLECTS\")))"
|
||||
"(if c"
|
||||
"(bytes->string/locale c #\\?)"
|
||||
" \"\"))"
|
||||
" \"\")"
|
||||
"(cons-if"
|
||||
"(and user-too?"
|
||||
|
|
|
|||
|
|
@ -316,13 +316,14 @@
|
|||
(if (and (relative-path? program)
|
||||
(let-values ([(base name dir?) (split-path program)])
|
||||
(eq? base 'relative)))
|
||||
(let ([paths-str (getenv "PATH")]
|
||||
(let ([paths-str (environment-variables-get #"PATH")]
|
||||
[win-add (lambda (s) (if (eq? (system-type) 'windows)
|
||||
(cons (bytes->path #".") s)
|
||||
s))])
|
||||
(let loop ([paths (win-add
|
||||
(if paths-str
|
||||
(path-list-string->path-list paths-str null)
|
||||
(path-list-string->path-list (bytes->string/locale paths-str #\?)
|
||||
null)
|
||||
null))])
|
||||
(if (null? paths)
|
||||
#f
|
||||
|
|
@ -730,7 +731,10 @@
|
|||
[cons-if (lambda (f r) (if f (cons f r) r))])
|
||||
(path-list-string->path-list
|
||||
(if user-too?
|
||||
(or (getenv "PLTCOLLECTS") "")
|
||||
(let ([c (environment-variables-get #"PLTCOLLECTS")])
|
||||
(if c
|
||||
(bytes->string/locale c #\?)
|
||||
""))
|
||||
"")
|
||||
(cons-if
|
||||
(and user-too?
|
||||
|
|
|
|||
|
|
@ -301,8 +301,12 @@ static Scheme_Object *sch_printf(int argc, Scheme_Object *argv[]);
|
|||
static Scheme_Object *sch_eprintf(int argc, Scheme_Object *argv[]);
|
||||
static Scheme_Object *sch_fprintf(int argc, Scheme_Object *argv[]);
|
||||
static Scheme_Object *banner(int argc, Scheme_Object *argv[]);
|
||||
static Scheme_Object *env_p(int argc, Scheme_Object *argv[]);
|
||||
static Scheme_Object *sch_getenv(int argc, Scheme_Object *argv[]);
|
||||
static Scheme_Object *sch_getenv_names(int argc, Scheme_Object *argv[]);
|
||||
static Scheme_Object *sch_putenv(int argc, Scheme_Object *argv[]);
|
||||
static Scheme_Object *env_copy(int argc, Scheme_Object *argv[]);
|
||||
static Scheme_Object *current_environment_variables(int argc, Scheme_Object *argv[]);
|
||||
static Scheme_Object *system_type(int argc, Scheme_Object *argv[]);
|
||||
static Scheme_Object *system_library_subpath(int argc, Scheme_Object *argv[]);
|
||||
static Scheme_Object *cmdline_args(int argc, Scheme_Object *argv[]);
|
||||
|
|
@ -849,15 +853,42 @@ scheme_init_string (Scheme_Env *env)
|
|||
0, 0),
|
||||
env);
|
||||
|
||||
scheme_add_global_constant("getenv",
|
||||
/* Environment variables */
|
||||
|
||||
scheme_add_global_constant("environment-variables?",
|
||||
scheme_make_folding_prim(env_p,
|
||||
"environment-variables?",
|
||||
1, 1, 1),
|
||||
env);
|
||||
|
||||
scheme_add_global_constant("current-environment-variables",
|
||||
scheme_register_parameter(current_environment_variables,
|
||||
"current-environment-variables",
|
||||
MZCONFIG_CURRENT_ENV_VARS),
|
||||
env);
|
||||
|
||||
scheme_add_global_constant("environment-variables-get",
|
||||
scheme_make_immed_prim(sch_getenv,
|
||||
"getenv",
|
||||
"environment-variables-get",
|
||||
1, 2),
|
||||
env);
|
||||
|
||||
scheme_add_global_constant("environment-variables-set!",
|
||||
scheme_make_prim_w_arity(sch_putenv,
|
||||
"environment-variables-set!",
|
||||
2, 4),
|
||||
env);
|
||||
|
||||
scheme_add_global_constant("environment-variables-keys",
|
||||
scheme_make_immed_prim(sch_getenv_names,
|
||||
"environment-variables-keys",
|
||||
1, 1),
|
||||
env);
|
||||
scheme_add_global_constant("putenv",
|
||||
scheme_make_immed_prim(sch_putenv,
|
||||
"putenv",
|
||||
2, 2),
|
||||
|
||||
scheme_add_global_constant("environment-variables-copy",
|
||||
scheme_make_immed_prim(env_copy,
|
||||
"environment-variables-copy",
|
||||
1, 1),
|
||||
env);
|
||||
|
||||
/* Don't make these folding, since they're platform-specific: */
|
||||
|
|
@ -2052,6 +2083,46 @@ int scheme_any_string_has_null(Scheme_Object *o)
|
|||
/* Environment Variables */
|
||||
/***********************************************************************/
|
||||
|
||||
#ifdef OS_X
|
||||
# include <crt_externs.h>
|
||||
# define GET_ENVIRON_ARRAY *_NSGetEnviron()
|
||||
#endif
|
||||
|
||||
#if !defined(DOS_FILE_SYSTEM) && !defined(GET_ENVIRON_ARRAY)
|
||||
extern char **environ;
|
||||
# define GET_ENVIRON_ARRAY environ
|
||||
#endif
|
||||
|
||||
Scheme_Object *scheme_make_environment_variables(Scheme_Hash_Table *ht)
|
||||
{
|
||||
Scheme_Object *ev;
|
||||
|
||||
ev = scheme_alloc_small_object();
|
||||
ev->type = scheme_environment_variables_type;
|
||||
SCHEME_PTR_VAL(ev) = (Scheme_Object *)ht;
|
||||
|
||||
return ev;
|
||||
}
|
||||
|
||||
static Scheme_Object *env_p(int argc, Scheme_Object *argv[])
|
||||
{
|
||||
return (SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_environment_variables_type)
|
||||
? scheme_true
|
||||
: scheme_false);
|
||||
}
|
||||
|
||||
static Scheme_Object *current_environment_variables(int argc, Scheme_Object *argv[])
|
||||
{
|
||||
Scheme_Object *v;
|
||||
|
||||
v = scheme_param_config("current-environment-variables",
|
||||
scheme_make_integer(MZCONFIG_CURRENT_ENV_VARS),
|
||||
argc, argv,
|
||||
-1, env_p, "environment-variables?", 0);
|
||||
|
||||
return v;
|
||||
}
|
||||
|
||||
#if defined(MZ_USE_PLACES) && defined(MZ_PRECISE_GC)
|
||||
static char* clone_str_with_gc(const char* buffer) {
|
||||
int length;
|
||||
|
|
@ -2070,51 +2141,28 @@ static void create_putenv_str_table_if_needed() {
|
|||
}
|
||||
|
||||
#ifndef DOS_FILE_SYSTEM
|
||||
static void putenv_str_table_put_name(Scheme_Object *name, Scheme_Object *value) {
|
||||
static void putenv_str_table_put_name(const char *name, char *value) {
|
||||
#if defined(MZ_USE_PLACES) && defined(MZ_PRECISE_GC)
|
||||
void *original_gc;
|
||||
Scheme_Object *name_copy;
|
||||
const char *name_copy;
|
||||
original_gc = GC_switch_to_master_gc();
|
||||
scheme_start_atomic();
|
||||
|
||||
name_copy = (Scheme_Object *) clone_str_with_gc((const char *) name);
|
||||
name_copy = clone_str_with_gc(name);
|
||||
create_putenv_str_table_if_needed();
|
||||
scheme_hash_set(putenv_str_table, name_copy, value);
|
||||
scheme_hash_set(putenv_str_table, (Scheme_Object *)name_copy, (Scheme_Object *)value);
|
||||
|
||||
scheme_end_atomic_no_swap();
|
||||
GC_switch_back_from_master(original_gc);
|
||||
#else
|
||||
create_putenv_str_table_if_needed();
|
||||
scheme_hash_set(putenv_str_table, name, value);
|
||||
scheme_hash_set(putenv_str_table, (Scheme_Object *)name, (Scheme_Object *)value);
|
||||
#endif
|
||||
}
|
||||
#endif
|
||||
|
||||
#ifndef GETENV_FUNCTION
|
||||
static void putenv_str_table_put_name_value(Scheme_Object *name, Scheme_Object *value) {
|
||||
#if defined(MZ_USE_PLACES) && defined(MZ_PRECISE_GC)
|
||||
void *original_gc;
|
||||
Scheme_Object *name_copy;
|
||||
Scheme_Object *value_copy;
|
||||
original_gc = GC_switch_to_master_gc();
|
||||
scheme_start_atomic();
|
||||
|
||||
name_copy = (Scheme_Object *) clone_str_with_gc((const char *) name);
|
||||
value_copy = (Scheme_Object *) clone_str_with_gc((const char *) value);
|
||||
create_putenv_str_table_if_needed();
|
||||
scheme_hash_set(putenv_str_table, name_copy, value_copy);
|
||||
|
||||
scheme_end_atomic_no_swap();
|
||||
GC_switch_back_from_master(original_gc);
|
||||
#else
|
||||
create_putenv_str_table_if_needed();
|
||||
scheme_hash_set(putenv_str_table, name, value);
|
||||
#endif
|
||||
}
|
||||
#endif
|
||||
|
||||
#if !defined(GETENV_FUNCTION) || defined(MZ_PRECISE_GC)
|
||||
static Scheme_Object *putenv_str_table_get(Scheme_Object *name) {
|
||||
#if defined(MZ_PRECISE_GC)
|
||||
static Scheme_Object *putenv_str_table_get(const char *name) {
|
||||
#if defined(MZ_USE_PLACES) && defined(MZ_PRECISE_GC)
|
||||
void *original_gc;
|
||||
Scheme_Object *value;
|
||||
|
|
@ -2122,14 +2170,14 @@ static Scheme_Object *putenv_str_table_get(Scheme_Object *name) {
|
|||
scheme_start_atomic();
|
||||
|
||||
create_putenv_str_table_if_needed();
|
||||
value = scheme_hash_get(putenv_str_table, name);
|
||||
value = scheme_hash_get(putenv_str_table, (Scheme_Object *)name);
|
||||
|
||||
scheme_end_atomic_no_swap();
|
||||
GC_switch_back_from_master(original_gc);
|
||||
return value;
|
||||
#else
|
||||
create_putenv_str_table_if_needed();
|
||||
return scheme_hash_get(putenv_str_table, name);
|
||||
return scheme_hash_get(putenv_str_table, (Scheme_Object *)name);
|
||||
#endif
|
||||
}
|
||||
#endif
|
||||
|
|
@ -2140,40 +2188,6 @@ static int sch_bool_getenv(const char* name);
|
|||
void
|
||||
scheme_init_getenv(void)
|
||||
{
|
||||
#ifndef GETENV_FUNCTION
|
||||
FILE *f = fopen("Environment", "r");
|
||||
if (f) {
|
||||
Scheme_Object *p = scheme_make_file_input_port(f);
|
||||
mz_jmp_buf *savebuf, newbuf;
|
||||
savebuf = scheme_current_thread->error_buf;
|
||||
scheme_current_thread->error_buf = &newbuf;
|
||||
if (!scheme_setjmp(newbuf)) {
|
||||
while (1) {
|
||||
Scheme_Object *v = scheme_read(p);
|
||||
if (SCHEME_EOFP(v))
|
||||
break;
|
||||
|
||||
if (SCHEME_PAIRP(v) && SCHEME_PAIRP(SCHEME_CDR(v))
|
||||
&& SCHEME_NULLP(SCHEME_CDR(SCHEME_CDR(v)))) {
|
||||
Scheme_Object *key = SCHEME_CAR(v);
|
||||
Scheme_Object *val = SCHEME_CADR(v);
|
||||
if (SCHEME_STRINGP(key) && SCHEME_STRINGP(val)) {
|
||||
Scheme_Object *a[2];
|
||||
a[0] = key;
|
||||
a[1] = val;
|
||||
sch_putenv(2, a);
|
||||
v = NULL;
|
||||
}
|
||||
}
|
||||
|
||||
if (v)
|
||||
scheme_signal_error("bad environment specification: %V", v);
|
||||
}
|
||||
}
|
||||
scheme_current_thread->error_buf = savebuf;
|
||||
scheme_close_input_port(p);
|
||||
}
|
||||
#endif
|
||||
if (sch_bool_getenv("PLTNOMZJIT")) {
|
||||
scheme_set_startup_use_jit(0);
|
||||
}
|
||||
|
|
@ -2183,61 +2197,82 @@ scheme_init_getenv(void)
|
|||
# include <windows.h>
|
||||
static char *dos_win_getenv(const char *name) {
|
||||
int value_size;
|
||||
value_size = GetEnvironmentVariable(name, NULL, 0);
|
||||
value_size = GetEnvironmentVariableW(WIDE_PATH(name), NULL, 0);
|
||||
if (value_size) {
|
||||
char *value;
|
||||
wchar_t *value;
|
||||
int got;
|
||||
value = scheme_malloc_atomic(value_size);
|
||||
got = GetEnvironmentVariable(name, value, value_size);
|
||||
value = scheme_malloc_atomic(sizeof(wchar_t) * value_size);
|
||||
got = GetEnvironmentVariableW(WIDE_PATH(name), value, value_size);
|
||||
if (got < value_size)
|
||||
value[got] = 0;
|
||||
return value;
|
||||
return NARROW_PATH(value);
|
||||
}
|
||||
return NULL;
|
||||
}
|
||||
#endif
|
||||
|
||||
static int sch_bool_getenv(const char* name) {
|
||||
static int sch_bool_getenv(const char* name)
|
||||
{
|
||||
int rc = 0;
|
||||
#ifdef GETENV_FUNCTION
|
||||
|
||||
#ifdef DOS_FILE_SYSTEM
|
||||
if (GetEnvironmentVariable(name, NULL, 0)) rc = 1;
|
||||
#else
|
||||
if (getenv(name)) rc = 1;
|
||||
#endif
|
||||
#else
|
||||
if (putenv_str_table_get(name)) rc = 1;
|
||||
#endif
|
||||
|
||||
return rc;
|
||||
}
|
||||
|
||||
int byte_string_ok_name(Scheme_Object *o)
|
||||
{
|
||||
const char *s = SCHEME_BYTE_STR_VAL(o);
|
||||
int i = SCHEME_BYTE_STRTAG_VAL(o);
|
||||
#ifdef DOS_FILE_SYSTEM
|
||||
if (!i) return 0;
|
||||
#endif
|
||||
while (i--) {
|
||||
if (!s[i] || s[i] == '=')
|
||||
return 0;
|
||||
}
|
||||
return 1;
|
||||
}
|
||||
|
||||
static Scheme_Object *sch_getenv(int argc, Scheme_Object *argv[])
|
||||
{
|
||||
char *name;
|
||||
char *value;
|
||||
Scheme_Object *bs;
|
||||
Scheme_Object *bs, *ev, *val;
|
||||
Scheme_Hash_Table *ht;
|
||||
|
||||
if (!SCHEME_CHAR_STRINGP(argv[0]) || scheme_any_string_has_null(argv[0]))
|
||||
scheme_wrong_contract("getenv", CHAR_STRING_W_NO_NULLS, 0, argc, argv);
|
||||
bs = argv[0];
|
||||
if (!SCHEME_BYTE_STRINGP(bs)
|
||||
|| !byte_string_ok_name(bs))
|
||||
scheme_wrong_contract("environment-variables-get", "bytes-environment-variable-name?", 0, argc, argv);
|
||||
if ((argc > 1)
|
||||
&& !SAME_TYPE(SCHEME_TYPE(argv[1]), scheme_environment_variables_type))
|
||||
scheme_wrong_contract("environment-variables-get", "environment-variables?", 1, argc, argv);
|
||||
|
||||
bs = scheme_char_string_to_byte_string_locale(argv[0]);
|
||||
if (argc > 1)
|
||||
ev = argv[1];
|
||||
else
|
||||
ev = scheme_get_param(scheme_current_config(), MZCONFIG_CURRENT_ENV_VARS);
|
||||
ht = SCHEME_ENVVARS_TABLE(ev);
|
||||
|
||||
if (!ht) {
|
||||
name = SCHEME_BYTE_STR_VAL(bs);
|
||||
|
||||
#ifdef GETENV_FUNCTION
|
||||
#ifdef DOS_FILE_SYSTEM
|
||||
value = dos_win_getenv(name);
|
||||
#else
|
||||
value = getenv(name);
|
||||
#endif
|
||||
#else
|
||||
{
|
||||
Scheme_Object *hash_value;
|
||||
hash_value = putenv_str_table_get(name);
|
||||
return hash_value ? hash_value : scheme_false;
|
||||
}
|
||||
#endif
|
||||
|
||||
return value ? scheme_make_locale_string(value) : scheme_false;
|
||||
return value ? scheme_make_byte_string(value) : scheme_false;
|
||||
} else {
|
||||
val = scheme_hash_get_atomic(ht, bs);
|
||||
return val ? val : scheme_false;
|
||||
}
|
||||
}
|
||||
|
||||
#ifndef DOS_FILE_SYSTEM
|
||||
|
|
@ -2246,21 +2281,26 @@ static int sch_unix_putenv(const char *var, const char *val, const intptr_t varl
|
|||
intptr_t total_length;
|
||||
total_length = varlen + vallen + 2;
|
||||
|
||||
if (val) {
|
||||
#ifdef MZ_PRECISE_GC
|
||||
/* Can't put moveable string into array. */
|
||||
buffer = malloc(total_length);
|
||||
#else
|
||||
buffer = (char *)scheme_malloc_atomic(total_length);
|
||||
#endif
|
||||
|
||||
memcpy(buffer, var, varlen);
|
||||
buffer[varlen] = '=';
|
||||
memcpy(buffer + varlen + 1, val, vallen + 1);
|
||||
} else {
|
||||
buffer = NULL;
|
||||
}
|
||||
|
||||
#ifdef MZ_PRECISE_GC
|
||||
{
|
||||
/* Free old, if in table: */
|
||||
char *oldbuffer;
|
||||
oldbuffer = (char *)putenv_str_table_get((Scheme_Object *)var);
|
||||
oldbuffer = (char *)putenv_str_table_get(var);
|
||||
if (oldbuffer)
|
||||
free(oldbuffer);
|
||||
}
|
||||
|
|
@ -2268,40 +2308,270 @@ static int sch_unix_putenv(const char *var, const char *val, const intptr_t varl
|
|||
|
||||
/* if precise the buffer needs to be remembered so it can be freed */
|
||||
/* if not precise the buffer needs to be rooted so it doesn't get collected prematurely */
|
||||
putenv_str_table_put_name((Scheme_Object *)var, (Scheme_Object *)buffer);
|
||||
putenv_str_table_put_name(var, buffer);
|
||||
|
||||
if (buffer)
|
||||
return putenv(buffer);
|
||||
else
|
||||
return unsetenv(var);
|
||||
}
|
||||
#endif
|
||||
|
||||
static Scheme_Object *sch_putenv(int argc, Scheme_Object *argv[])
|
||||
{
|
||||
Scheme_Object *varbs;
|
||||
Scheme_Object *valbs;
|
||||
Scheme_Object *varbs, *valbs, *ev;
|
||||
Scheme_Hash_Table *ht;
|
||||
char *var;
|
||||
char *val;
|
||||
int rc = 0;
|
||||
int rc = 0, errid = 0;
|
||||
|
||||
if (!SCHEME_CHAR_STRINGP(argv[0]) || scheme_any_string_has_null(argv[0]))
|
||||
scheme_wrong_contract("putenv", CHAR_STRING_W_NO_NULLS, 0, argc, argv);
|
||||
if (!SCHEME_CHAR_STRINGP(argv[1]) || scheme_any_string_has_null(argv[1]))
|
||||
scheme_wrong_contract("putenv", CHAR_STRING_W_NO_NULLS, 1, argc, argv);
|
||||
varbs = argv[0];
|
||||
if (!SCHEME_BYTE_STRINGP(varbs)
|
||||
|| !byte_string_ok_name(varbs))
|
||||
scheme_wrong_contract("environment-variables-set!", "bytes-environment-variable-name?", 0, argc, argv);
|
||||
valbs = argv[1];
|
||||
if (!SCHEME_FALSEP(valbs)
|
||||
&& (!SCHEME_BYTE_STRINGP(valbs)
|
||||
|| scheme_byte_string_has_null(valbs)))
|
||||
scheme_wrong_contract("environment-variables-set!", "(or/c bytes-no-nuls? #f)", 1, argc, argv);
|
||||
if ((argc > 2)
|
||||
&& !SAME_TYPE(SCHEME_TYPE(argv[2]), scheme_environment_variables_type))
|
||||
scheme_wrong_contract("environment-variables-set!", "environment-variables?", 1, argc, argv);
|
||||
if (argc > 3)
|
||||
scheme_check_proc_arity("environment-variables-set!", 0, 3, argc, argv);
|
||||
|
||||
varbs = scheme_char_string_to_byte_string_locale(argv[0]);
|
||||
if (argc > 2)
|
||||
ev = argv[2];
|
||||
else
|
||||
ev = scheme_get_param(scheme_current_config(), MZCONFIG_CURRENT_ENV_VARS);
|
||||
ht = SCHEME_ENVVARS_TABLE(ev);
|
||||
|
||||
if (ht) {
|
||||
if (SCHEME_FALSEP(valbs)) {
|
||||
scheme_hash_set_atomic(ht, varbs, NULL);
|
||||
} else {
|
||||
varbs = byte_string_to_immutable(1, &varbs);
|
||||
valbs = byte_string_to_immutable(1, &valbs);
|
||||
scheme_hash_set_atomic(ht, varbs, valbs);
|
||||
}
|
||||
|
||||
return scheme_void;
|
||||
} else {
|
||||
var = SCHEME_BYTE_STR_VAL(varbs);
|
||||
|
||||
valbs = scheme_char_string_to_byte_string_locale(argv[1]);
|
||||
if (SCHEME_FALSEP(valbs)) {
|
||||
val = NULL;
|
||||
} else {
|
||||
val = SCHEME_BYTE_STR_VAL(valbs);
|
||||
}
|
||||
|
||||
#ifdef GETENV_FUNCTION
|
||||
#ifdef DOS_FILE_SYSTEM
|
||||
rc = !SetEnvironmentVariable(var, val);
|
||||
if (rc)
|
||||
errid = GetLastError();
|
||||
#else
|
||||
rc = sch_unix_putenv(var, val, SCHEME_BYTE_STRLEN_VAL(varbs), SCHEME_BYTE_STRLEN_VAL(valbs));
|
||||
rc = sch_unix_putenv(var, val, SCHEME_BYTE_STRLEN_VAL(varbs), (val ? SCHEME_BYTE_STRLEN_VAL(valbs) : 0));
|
||||
errid = errno;
|
||||
#endif
|
||||
|
||||
if (rc) {
|
||||
if (argc > 3)
|
||||
return _scheme_tail_apply(argv[3], 0, NULL);
|
||||
else {
|
||||
scheme_raise_exn(MZEXN_FAIL,
|
||||
"environment-variables-set!: change failed\n"
|
||||
" system error: %e",
|
||||
errid);
|
||||
}
|
||||
}
|
||||
|
||||
return scheme_void;
|
||||
}
|
||||
}
|
||||
|
||||
static Scheme_Object *env_copy(int argc, Scheme_Object *argv[])
|
||||
{
|
||||
Scheme_Hash_Table *ht;
|
||||
|
||||
if (!SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_environment_variables_type))
|
||||
scheme_wrong_contract("environment-variables-copy", "environment-variables?", 0, argc, argv);
|
||||
|
||||
ht = SCHEME_ENVVARS_TABLE(argv[0]);
|
||||
if (ht)
|
||||
return scheme_make_environment_variables(scheme_clone_hash_table(ht));
|
||||
|
||||
/* copy system environment variables into a hash table: */
|
||||
ht = scheme_make_hash_table_equal();
|
||||
|
||||
#ifdef DOS_FILE_SYSTEM
|
||||
{
|
||||
char *p;
|
||||
wchar_t *e;
|
||||
int i, start, j;
|
||||
Scheme_Object *var, *val;
|
||||
|
||||
e = GetEnvironmentStringsW();
|
||||
|
||||
for (i = 0; e[i]; ) {
|
||||
start = i;
|
||||
while (e[i]) {
|
||||
i++;
|
||||
}
|
||||
p = NARROW_PATH(e XFORM_OK_PLUS start);
|
||||
for (j = 0; p[j] && p[j] != '='; j++) {
|
||||
}
|
||||
if (p[j]) {
|
||||
var = scheme_make_immutable_sized_byte_string(p, j, 1);
|
||||
val = scheme_make_immutable_sized_byte_string(p XFORM_OK_PLUS j + 1, -1, 1);
|
||||
scheme_hash_set(ht, var, val);
|
||||
}
|
||||
i++;
|
||||
}
|
||||
|
||||
FreeEnvironmentStringsW(e);
|
||||
}
|
||||
#else
|
||||
putenv_str_table_put_name_value(argv[0], argv[1]);
|
||||
{
|
||||
int i, j;
|
||||
char **ea, *p;
|
||||
Scheme_Object *var, *val;
|
||||
|
||||
ea = GET_ENVIRON_ARRAY;
|
||||
|
||||
for (i = 0; ea[i]; i++) {
|
||||
p = ea[i];
|
||||
for (j = 0; p[j] && p[j] != '='; j++) {
|
||||
}
|
||||
if (p[j]) {
|
||||
var = scheme_make_immutable_sized_byte_string(p, j, 1);
|
||||
val = scheme_make_immutable_sized_byte_string(p XFORM_OK_PLUS j + 1, -1, 1);
|
||||
scheme_hash_set(ht, var, val);
|
||||
}
|
||||
}
|
||||
}
|
||||
#endif
|
||||
|
||||
return scheme_make_environment_variables(ht);
|
||||
}
|
||||
|
||||
static Scheme_Object *sch_getenv_names(int argc, Scheme_Object *argv[])
|
||||
{
|
||||
Scheme_Object *ev, *r = scheme_null;
|
||||
Scheme_Hash_Table *ht;
|
||||
int i;
|
||||
|
||||
ev = argv[0];
|
||||
if (!SAME_TYPE(SCHEME_TYPE(ev), scheme_environment_variables_type))
|
||||
scheme_wrong_contract("environment-variables-keys", "environment-variables?", 0, argc, argv);
|
||||
|
||||
ht = SCHEME_ENVVARS_TABLE(ev);
|
||||
if (!ht) {
|
||||
ev = env_copy(1, argv);
|
||||
ht = SCHEME_ENVVARS_TABLE(ev);
|
||||
}
|
||||
|
||||
for (i = ht->size; i--; ) {
|
||||
if (ht->vals[i]) {
|
||||
r = scheme_make_pair(ht->keys[i], r);
|
||||
}
|
||||
}
|
||||
|
||||
return r;
|
||||
}
|
||||
|
||||
#ifdef DOS_FILE_SYSTEM
|
||||
static int wc_strlen(const wchar_t *ws)
|
||||
{
|
||||
int l;
|
||||
for (l =0; ws[l]; l++) { }
|
||||
return l;
|
||||
}
|
||||
#endif
|
||||
|
||||
void *scheme_environment_variables_to_block(Scheme_Object *ev, int *_need_free)
|
||||
{
|
||||
Scheme_Hash_Table *ht;
|
||||
|
||||
ht = SCHEME_ENVVARS_TABLE(ev);
|
||||
if (!ht) {
|
||||
*_need_free = 0;
|
||||
#ifdef DOS_FILE_SYSTEM
|
||||
return NULL;
|
||||
#else
|
||||
return GET_ENVIRON_ARRAY;
|
||||
#endif
|
||||
}
|
||||
|
||||
*_need_free = 1;
|
||||
|
||||
#ifdef DOS_FILE_SYSTEM
|
||||
{
|
||||
int i;
|
||||
int len = 0, slen;
|
||||
GC_CAN_IGNORE wchar_t *r, *s;
|
||||
|
||||
for (i = ht->size; i--; ) {
|
||||
if (ht->vals[i]) {
|
||||
len += wc_strlen(WIDE_PATH(SCHEME_BYTE_STR_VAL(ht->keys[i])));
|
||||
len += wc_strlen(WIDE_PATH(SCHEME_BYTE_STR_VAL(ht->vals[i])));
|
||||
len += 2;
|
||||
}
|
||||
}
|
||||
|
||||
r = (wchar_t *)malloc((len + 1) * sizeof(wchar_t));
|
||||
|
||||
len = 0;
|
||||
|
||||
for (i = ht->size; i--; ) {
|
||||
if (ht->vals[i]) {
|
||||
s = WIDE_PATH(SCHEME_BYTE_STR_VAL(ht->keys[i]));
|
||||
slen = wc_strlen(s);
|
||||
memcpy(r XFORM_OK_PLUS len, s, slen * sizeof(wchar_t));
|
||||
len += slen;
|
||||
r[len++] = '=';
|
||||
s = WIDE_PATH(SCHEME_BYTE_STR_VAL(ht->vals[i]));
|
||||
slen = wc_strlen(s);
|
||||
memcpy(r XFORM_OK_PLUS len, s, slen * sizeof(wchar_t));
|
||||
len += slen;
|
||||
r[len++] = 0;
|
||||
}
|
||||
}
|
||||
r[len] = 0;
|
||||
|
||||
return r;
|
||||
}
|
||||
#else
|
||||
{
|
||||
GC_CAN_IGNORE char **r, *s;
|
||||
intptr_t i, len = 0, slen, c;
|
||||
|
||||
for (i = ht->size; i--; ) {
|
||||
if (ht->vals[i]) {
|
||||
len += SCHEME_BYTE_STRLEN_VAL(ht->keys[i]);
|
||||
len += SCHEME_BYTE_STRLEN_VAL(ht->vals[i]);
|
||||
len += 2;
|
||||
}
|
||||
}
|
||||
|
||||
r = (char **)malloc((ht->count+1) * sizeof(char*) + len);
|
||||
s = (char *)(r + (ht->count+1));
|
||||
for (i = ht->size, c = 0; i--; ) {
|
||||
if (ht->vals[i]) {
|
||||
r[c++] = s;
|
||||
slen = SCHEME_BYTE_STRLEN_VAL(ht->keys[i]);
|
||||
memcpy(s, SCHEME_BYTE_STR_VAL(ht->keys[i]), slen);
|
||||
s[slen] = '=';
|
||||
s = s XFORM_OK_PLUS (slen + 1);
|
||||
slen = SCHEME_BYTE_STRLEN_VAL(ht->vals[i]);
|
||||
memcpy(s, SCHEME_BYTE_STR_VAL(ht->vals[i]), slen);
|
||||
s[slen] = 0;
|
||||
s = s XFORM_OK_PLUS (slen + 1);
|
||||
}
|
||||
}
|
||||
|
||||
return r;
|
||||
}
|
||||
#endif
|
||||
return rc ? scheme_false : scheme_true;
|
||||
}
|
||||
|
||||
/***********************************************************************/
|
||||
|
|
|
|||
|
|
@ -207,83 +207,84 @@ enum {
|
|||
scheme_proc_shape_type, /* 183 */
|
||||
scheme_struct_proc_shape_type, /* 184 */
|
||||
scheme_phantom_bytes_type, /* 185 */
|
||||
scheme_environment_variables_type, /* 186 */
|
||||
|
||||
#ifdef MZTAG_REQUIRED
|
||||
_scheme_last_normal_type_, /* 186 */
|
||||
_scheme_last_normal_type_, /* 187 */
|
||||
|
||||
scheme_rt_weak_array, /* 187 */
|
||||
scheme_rt_weak_array, /* 188 */
|
||||
|
||||
scheme_rt_comp_env, /* 188 */
|
||||
scheme_rt_constant_binding, /* 189 */
|
||||
scheme_rt_resolve_info, /* 190 */
|
||||
scheme_rt_unresolve_info, /* 191 */
|
||||
scheme_rt_optimize_info, /* 192 */
|
||||
scheme_rt_compile_info, /* 193 */
|
||||
scheme_rt_cont_mark, /* 194 */
|
||||
scheme_rt_saved_stack, /* 195 */
|
||||
scheme_rt_reply_item, /* 196 */
|
||||
scheme_rt_closure_info, /* 197 */
|
||||
scheme_rt_overflow, /* 198 */
|
||||
scheme_rt_overflow_jmp, /* 199 */
|
||||
scheme_rt_meta_cont, /* 200 */
|
||||
scheme_rt_dyn_wind_cell, /* 201 */
|
||||
scheme_rt_dyn_wind_info, /* 202 */
|
||||
scheme_rt_dyn_wind, /* 203 */
|
||||
scheme_rt_dup_check, /* 204 */
|
||||
scheme_rt_thread_memory, /* 205 */
|
||||
scheme_rt_input_file, /* 206 */
|
||||
scheme_rt_input_fd, /* 207 */
|
||||
scheme_rt_oskit_console_input, /* 208 */
|
||||
scheme_rt_tested_input_file, /* 209 */
|
||||
scheme_rt_tested_output_file, /* 210 */
|
||||
scheme_rt_indexed_string, /* 211 */
|
||||
scheme_rt_output_file, /* 212 */
|
||||
scheme_rt_load_handler_data, /* 213 */
|
||||
scheme_rt_pipe, /* 214 */
|
||||
scheme_rt_beos_process, /* 215 */
|
||||
scheme_rt_system_child, /* 216 */
|
||||
scheme_rt_tcp, /* 217 */
|
||||
scheme_rt_write_data, /* 218 */
|
||||
scheme_rt_tcp_select_info, /* 219 */
|
||||
scheme_rt_param_data, /* 220 */
|
||||
scheme_rt_will, /* 221 */
|
||||
scheme_rt_linker_name, /* 222 */
|
||||
scheme_rt_param_map, /* 223 */
|
||||
scheme_rt_finalization, /* 224 */
|
||||
scheme_rt_finalizations, /* 225 */
|
||||
scheme_rt_cpp_object, /* 226 */
|
||||
scheme_rt_cpp_array_object, /* 227 */
|
||||
scheme_rt_stack_object, /* 228 */
|
||||
scheme_rt_preallocated_object, /* 229 */
|
||||
scheme_thread_hop_type, /* 230 */
|
||||
scheme_rt_srcloc, /* 231 */
|
||||
scheme_rt_evt, /* 232 */
|
||||
scheme_rt_syncing, /* 233 */
|
||||
scheme_rt_comp_prefix, /* 234 */
|
||||
scheme_rt_user_input, /* 235 */
|
||||
scheme_rt_user_output, /* 236 */
|
||||
scheme_rt_compact_port, /* 237 */
|
||||
scheme_rt_read_special_dw, /* 238 */
|
||||
scheme_rt_regwork, /* 239 */
|
||||
scheme_rt_rx_lazy_string, /* 240 */
|
||||
scheme_rt_buf_holder, /* 241 */
|
||||
scheme_rt_parameterization, /* 242 */
|
||||
scheme_rt_print_params, /* 243 */
|
||||
scheme_rt_read_params, /* 244 */
|
||||
scheme_rt_native_code, /* 245 */
|
||||
scheme_rt_native_code_plus_case, /* 246 */
|
||||
scheme_rt_jitter_data, /* 247 */
|
||||
scheme_rt_module_exports, /* 248 */
|
||||
scheme_rt_delay_load_info, /* 249 */
|
||||
scheme_rt_marshal_info, /* 250 */
|
||||
scheme_rt_unmarshal_info, /* 251 */
|
||||
scheme_rt_runstack, /* 252 */
|
||||
scheme_rt_sfs_info, /* 253 */
|
||||
scheme_rt_validate_clearing, /* 254 */
|
||||
scheme_rt_avl_node, /* 255 */
|
||||
scheme_rt_lightweight_cont, /* 256 */
|
||||
scheme_rt_export_info, /* 257 */
|
||||
scheme_rt_cont_jmp, /* 258 */
|
||||
scheme_rt_comp_env, /* 189 */
|
||||
scheme_rt_constant_binding, /* 190 */
|
||||
scheme_rt_resolve_info, /* 191 */
|
||||
scheme_rt_unresolve_info, /* 192 */
|
||||
scheme_rt_optimize_info, /* 193 */
|
||||
scheme_rt_compile_info, /* 194 */
|
||||
scheme_rt_cont_mark, /* 195 */
|
||||
scheme_rt_saved_stack, /* 196 */
|
||||
scheme_rt_reply_item, /* 197 */
|
||||
scheme_rt_closure_info, /* 198 */
|
||||
scheme_rt_overflow, /* 199 */
|
||||
scheme_rt_overflow_jmp, /* 200 */
|
||||
scheme_rt_meta_cont, /* 201 */
|
||||
scheme_rt_dyn_wind_cell, /* 202 */
|
||||
scheme_rt_dyn_wind_info, /* 203 */
|
||||
scheme_rt_dyn_wind, /* 204 */
|
||||
scheme_rt_dup_check, /* 205 */
|
||||
scheme_rt_thread_memory, /* 206 */
|
||||
scheme_rt_input_file, /* 207 */
|
||||
scheme_rt_input_fd, /* 208 */
|
||||
scheme_rt_oskit_console_input, /* 209 */
|
||||
scheme_rt_tested_input_file, /* 210 */
|
||||
scheme_rt_tested_output_file, /* 211 */
|
||||
scheme_rt_indexed_string, /* 212 */
|
||||
scheme_rt_output_file, /* 213 */
|
||||
scheme_rt_load_handler_data, /* 214 */
|
||||
scheme_rt_pipe, /* 215 */
|
||||
scheme_rt_beos_process, /* 216 */
|
||||
scheme_rt_system_child, /* 217 */
|
||||
scheme_rt_tcp, /* 218 */
|
||||
scheme_rt_write_data, /* 219 */
|
||||
scheme_rt_tcp_select_info, /* 220 */
|
||||
scheme_rt_param_data, /* 221 */
|
||||
scheme_rt_will, /* 222 */
|
||||
scheme_rt_linker_name, /* 223 */
|
||||
scheme_rt_param_map, /* 224 */
|
||||
scheme_rt_finalization, /* 225 */
|
||||
scheme_rt_finalizations, /* 226 */
|
||||
scheme_rt_cpp_object, /* 227 */
|
||||
scheme_rt_cpp_array_object, /* 228 */
|
||||
scheme_rt_stack_object, /* 229 */
|
||||
scheme_rt_preallocated_object, /* 230 */
|
||||
scheme_thread_hop_type, /* 231 */
|
||||
scheme_rt_srcloc, /* 232 */
|
||||
scheme_rt_evt, /* 233 */
|
||||
scheme_rt_syncing, /* 234 */
|
||||
scheme_rt_comp_prefix, /* 235 */
|
||||
scheme_rt_user_input, /* 236 */
|
||||
scheme_rt_user_output, /* 237 */
|
||||
scheme_rt_compact_port, /* 238 */
|
||||
scheme_rt_read_special_dw, /* 239 */
|
||||
scheme_rt_regwork, /* 240 */
|
||||
scheme_rt_rx_lazy_string, /* 241 */
|
||||
scheme_rt_buf_holder, /* 242 */
|
||||
scheme_rt_parameterization, /* 243 */
|
||||
scheme_rt_print_params, /* 244 */
|
||||
scheme_rt_read_params, /* 245 */
|
||||
scheme_rt_native_code, /* 246 */
|
||||
scheme_rt_native_code_plus_case, /* 247 */
|
||||
scheme_rt_jitter_data, /* 248 */
|
||||
scheme_rt_module_exports, /* 249 */
|
||||
scheme_rt_delay_load_info, /* 250 */
|
||||
scheme_rt_marshal_info, /* 251 */
|
||||
scheme_rt_unmarshal_info, /* 252 */
|
||||
scheme_rt_runstack, /* 253 */
|
||||
scheme_rt_sfs_info, /* 254 */
|
||||
scheme_rt_validate_clearing, /* 255 */
|
||||
scheme_rt_avl_node, /* 256 */
|
||||
scheme_rt_lightweight_cont, /* 257 */
|
||||
scheme_rt_export_info, /* 258 */
|
||||
scheme_rt_cont_jmp, /* 259 */
|
||||
#endif
|
||||
|
||||
_scheme_last_type_
|
||||
|
|
|
|||
|
|
@ -4414,7 +4414,7 @@ void scheme_break_kind_thread(Scheme_Thread *p, int kind)
|
|||
|
||||
void scheme_break_thread(Scheme_Thread *p)
|
||||
{
|
||||
return scheme_break_kind_thread(p, MZEXN_BREAK);
|
||||
scheme_break_kind_thread(p, MZEXN_BREAK);
|
||||
}
|
||||
|
||||
static void call_on_atomic_timeout(int must)
|
||||
|
|
@ -7404,6 +7404,12 @@ static void make_initial_config(Scheme_Thread *p)
|
|||
scheme_set_original_dir(s);
|
||||
}
|
||||
|
||||
{
|
||||
Scheme_Object *ev;
|
||||
ev = scheme_make_environment_variables(NULL);
|
||||
init_param(cells, paramz, MZCONFIG_CURRENT_ENV_VARS, ev);
|
||||
}
|
||||
|
||||
{
|
||||
Scheme_Object *rs;
|
||||
rs = scheme_make_random_state(scheme_get_milliseconds());
|
||||
|
|
|
|||
|
|
@ -311,6 +311,8 @@ scheme_init_type ()
|
|||
|
||||
set_name(scheme_phantom_bytes_type, "<phantom-bytes>");
|
||||
|
||||
set_name(scheme_environment_variables_type, "<environment-variables>");
|
||||
|
||||
#ifdef MZ_GC_BACKTRACE
|
||||
set_name(scheme_rt_meta_cont, "<meta-continuation>");
|
||||
#endif
|
||||
|
|
@ -720,6 +722,8 @@ void scheme_register_traversers(void)
|
|||
|
||||
GC_REG_TRAV(scheme_proc_shape_type, small_object);
|
||||
GC_REG_TRAV(scheme_struct_proc_shape_type, small_atomic_obj);
|
||||
|
||||
GC_REG_TRAV(scheme_environment_variables_type, small_object);
|
||||
}
|
||||
|
||||
END_XFORM_SKIP;
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user