open-output-file et al.: add #:permissions argument

Add a `#:permissions` optional argument that is a permissions integer
in the same style as `file-or-directory-permissions` and that is used
when a file is created. On Unix, the given permissions are combined
with the process's umask.

Closes #1654
This commit is contained in:
Matthew Flatt 2021-04-28 13:12:14 -06:00
parent bff31f0768
commit 09480c86e8
17 changed files with 628 additions and 401 deletions

View File

@ -14,7 +14,7 @@
;; In the Racket source repo, this version should change only when ;; In the Racket source repo, this version should change only when
;; "racket_version.h" changes: ;; "racket_version.h" changes:
(define version "8.1.0.2") (define version "8.1.0.3")
(define deps `("racket-lib" (define deps `("racket-lib"
["racket" #:version ,version])) ["racket" #:version ,version]))

View File

@ -33,6 +33,8 @@
"") "")
@(define default-permissions @racketvalfont{#o666})
@title[#:tag "file-ports"]{File Ports} @title[#:tag "file-ports"]{File Ports}
A port created by @racket[open-input-file], @racket[open-output-file], A port created by @racket[open-input-file], @racket[open-output-file],
@ -123,7 +125,8 @@ then the raised exception is either
[#:mode mode-flag (or/c 'binary 'text) 'binary] [#:mode mode-flag (or/c 'binary 'text) 'binary]
[#:exists exists-flag (or/c 'error 'append 'update 'can-update [#:exists exists-flag (or/c 'error 'append 'update 'can-update
'replace 'truncate 'replace 'truncate
'must-truncate 'truncate/replace) 'error]) 'must-truncate 'truncate/replace) 'error]
[#:permissions permissions (integer-in 0 65535) @#,default-permissions])
output-port?]{ output-port?]{
Opens the file specified by @racket[path] for output. The Opens the file specified by @racket[path] for output. The
@ -183,6 +186,16 @@ files that already exist:
] ]
When the file specified by @racket[path] is created,
@racket[permissions] specifies the permissions of the created file,
where an integer representation of permissions is treated the same as
for @racket[file-or-directory-permissions]. On Unix and Mac OS, these
permissions bits are combined with the process's umask. On Windows,
the only relevant property of @racket[permissions] is whether it has
the @racketvalfont{#o2} bit set for write permission. Note that a
read-only file can be created with @racket[open-output-file], in which
case writing is prohibited only for later attempts to open the file.
The file specified by @racket[path] need not be a regular file. It The file specified by @racket[path] need not be a regular file. It
might be a device that is connected through the filesystem, such as might be a device that is connected through the filesystem, such as
@filepath{aux} on Windows or @filepath{/dev/null} on Unix. The output @filepath{aux} on Windows or @filepath{/dev/null} on Unix. The output
@ -218,12 +231,14 @@ then @exnraise[exn:fail:filesystem:errno].
like @racket['truncate/replace].} like @racket['truncate/replace].}
#:changed "7.4.0.5" @elem{Changed handling of a fifo on Unix and Mac OS to #:changed "7.4.0.5" @elem{Changed handling of a fifo on Unix and Mac OS to
make the port block for output until the fifo has a make the port block for output until the fifo has a
reader.}]} reader.}
#:changed "8.1.0.3" @elem{Added the @racket[#:permissions] argument.}]}
@defproc[(open-input-output-file [path path-string?] @defproc[(open-input-output-file [path path-string?]
[#:mode mode-flag (or/c 'binary 'text) 'binary] [#:mode mode-flag (or/c 'binary 'text) 'binary]
[#:exists exists-flag (or/c 'error 'append 'update 'can-update [#:exists exists-flag (or/c 'error 'append 'update 'can-update
'replace 'truncate 'truncate/replace) 'error]) 'replace 'truncate 'truncate/replace) 'error]
[#:permissions permissions (integer-in 0 65535) @#,default-permissions])
(values input-port? output-port?)]{ (values input-port? output-port?)]{
Like @racket[open-output-file], but producing two values: an input Like @racket[open-output-file], but producing two values: an input
@ -258,10 +273,11 @@ when @racket[proc] returns.
[proc (output-port? . -> . any)] [proc (output-port? . -> . any)]
[#:mode mode-flag (or/c 'binary 'text) 'binary] [#:mode mode-flag (or/c 'binary 'text) 'binary]
[#:exists exists-flag (or/c 'error 'append 'update [#:exists exists-flag (or/c 'error 'append 'update
'replace 'truncate 'truncate/replace) 'error]) 'replace 'truncate 'truncate/replace) 'error]
[#:permissions permissions (integer-in 0 65535) @#,default-permissions])
any]{ any]{
Analogous to @racket[call-with-input-file], but passing @racket[path], Analogous to @racket[call-with-input-file], but passing @racket[path],
@racket[mode-flag] and @racket[exists-flag] to @racket[mode-flag], @racket[exists-flag], and @racket[permissions] to
@racket[open-output-file]. @racket[open-output-file].
@file-examples[ @file-examples[
@ -271,7 +287,9 @@ Analogous to @racket[call-with-input-file], but passing @racket[path],
(call-with-input-file some-file (call-with-input-file some-file
(lambda (in) (lambda (in)
(read-string 5 in))) (read-string 5 in)))
]} ]
@history[#:changed "8.1.0.3" @elem{Added the @racket[#:permissions] argument.}]}
@defproc[(call-with-input-file* [path path-string?] @defproc[(call-with-input-file* [path path-string?]
[proc (input-port? . -> . any)] [proc (input-port? . -> . any)]
@ -286,12 +304,15 @@ return, a continuation application, or a prompt-based abort.}
[proc (output-port? . -> . any)] [proc (output-port? . -> . any)]
[#:mode mode-flag (or/c 'binary 'text) 'binary] [#:mode mode-flag (or/c 'binary 'text) 'binary]
[#:exists exists-flag (or/c 'error 'append 'update [#:exists exists-flag (or/c 'error 'append 'update
'replace 'truncate 'truncate/replace) 'error]) 'replace 'truncate 'truncate/replace) 'error]
[#:permissions permissions (integer-in 0 65535) @#,default-permissions])
any]{ any]{
Like @racket[call-with-output-file], but the newly opened port is Like @racket[call-with-output-file], but the newly opened port is
closed whenever control escapes the dynamic extent of the closed whenever control escapes the dynamic extent of the
@racket[call-with-output-file*] call, whether through @racket[proc]'s @racket[call-with-output-file*] call, whether through @racket[proc]'s
return, a continuation application, or a prompt-based abort.} return, a continuation application, or a prompt-based abort.
@history[#:changed "8.1.0.3" @elem{Added the @racket[#:permissions] argument.}]}
@defproc[(with-input-from-file [path path-string?] @defproc[(with-input-from-file [path path-string?]
[thunk (-> any)] [thunk (-> any)]
@ -313,7 +334,8 @@ the current input port (see @racket[current-input-port]) using
[thunk (-> any)] [thunk (-> any)]
[#:mode mode-flag (or/c 'binary 'text) 'binary] [#:mode mode-flag (or/c 'binary 'text) 'binary]
[#:exists exists-flag (or/c 'error 'append 'update [#:exists exists-flag (or/c 'error 'append 'update
'replace 'truncate 'truncate/replace) 'error]) 'replace 'truncate 'truncate/replace) 'error]
[#:permissions permissions (integer-in 0 65535) @#,default-permissions])
any]{ any]{
Like @racket[call-with-output-file*], but instead of passing the newly Like @racket[call-with-output-file*], but instead of passing the newly
opened port to the given procedure argument, the port is installed as opened port to the given procedure argument, the port is installed as
@ -325,7 +347,9 @@ the current output port (see @racket[current-output-port]) using
(lambda () (printf "hello"))) (lambda () (printf "hello")))
(with-input-from-file some-file (with-input-from-file some-file
(lambda () (read-string 5))) (lambda () (read-string 5)))
]} ]
@history[#:changed "8.1.0.3" @elem{Added the @racket[#:permissions] argument.}]}
@defproc[(port-try-file-lock? [port file-stream-port?] @defproc[(port-try-file-lock? [port file-stream-port?]

View File

@ -2441,6 +2441,42 @@
(delete-file file) (delete-file file)
(delete-directory dir)) (delete-directory dir))
;; Check that permissions for file creation work
(let ()
(define dir (make-temporary-file "~a-tmp" 'directory))
(define file (build-path dir "f"))
(define (check open)
(open file #x444)
(err/rt-test/once (open file #x666) exn:fail:filesystem?)
(delete-file file))
(check (lambda (file perms)
(close-output-port (open-output-file file #:exists 'truncate #:permissions perms))))
(check (lambda (file perms)
(define-values (i o)
(open-input-output-file file #:exists 'truncate #:permissions perms))
(close-input-port i)
(close-output-port o)))
(check (lambda (file perms)
(with-output-to-file file
#:permissions perms
#:exists 'truncate
void)))
(check (lambda (file perms)
(call-with-output-file file
#:permissions perms
#:exists 'truncate
void)))
(check (lambda (file perms)
(call-with-output-file* file
#:permissions perms
#:exists 'truncate
void)))
(delete-directory dir))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(let ([tf (make-temporary-file)]) (let ([tf (make-temporary-file)])

View File

@ -24,6 +24,11 @@
(define binary-or-text-desc (define binary-or-text-desc
"(or/c 'binary 'text)") "(or/c 'binary 'text)")
(define DEFAULT-CREATE-PERMS #o666)
(define (permissions? perms)
(and (exact-integer? perms) (<= 0 perms 65535)))
(define perms-desc "(integer-in 0 65535)")
(define (open-input-file path #:mode [mode 'binary] #:for-module? [for-module? #f]) (define (open-input-file path #:mode [mode 'binary] #:for-module? [for-module? #f])
(unless (path-string? path) (unless (path-string? path)
(raise-argument-error 'open-input-file "path-string?" path)) (raise-argument-error 'open-input-file "path-string?" path))
@ -32,24 +37,30 @@
(k:open-input-file path mode (if for-module? 'module 'none))) (k:open-input-file path mode (if for-module? 'module 'none)))
(define (open-output-file path #:mode [mode 'binary] (define (open-output-file path #:mode [mode 'binary]
#:exists [exists 'error]) #:exists [exists 'error]
#:permissions [perms DEFAULT-CREATE-PERMS])
(unless (path-string? path) (unless (path-string? path)
(raise-argument-error 'open-output-file "path-string?" path)) (raise-argument-error 'open-output-file "path-string?" path))
(unless (memq mode '(binary text)) (unless (memq mode '(binary text))
(raise-argument-error 'open-output-file binary-or-text-desc mode)) (raise-argument-error 'open-output-file binary-or-text-desc mode))
(unless (memq exists exists-syms) (unless (memq exists exists-syms)
(raise-argument-error 'open-output-file exists-desc exists)) (raise-argument-error 'open-output-file exists-desc exists))
(k:open-output-file path mode exists)) (unless (permissions? perms)
(raise-argument-error 'open-output-file perms-desc perms))
(k:open-output-file path mode exists perms))
(define (open-input-output-file path #:mode [mode 'binary] (define (open-input-output-file path #:mode [mode 'binary]
#:exists [exists 'error]) #:exists [exists 'error]
#:permissions [perms DEFAULT-CREATE-PERMS])
(unless (path-string? path) (unless (path-string? path)
(raise-argument-error 'open-input-output-file "path-string?" path)) (raise-argument-error 'open-input-output-file "path-string?" path))
(unless (memq mode '(binary text)) (unless (memq mode '(binary text))
(raise-argument-error 'open-input-output-file binary-or-text-desc mode)) (raise-argument-error 'open-input-output-file binary-or-text-desc mode))
(unless (memq exists exists-syms) (unless (memq exists exists-syms)
(raise-argument-error 'open-input-output-file exists-desc exists)) (raise-argument-error 'open-input-output-file exists-desc exists))
(k:open-input-output-file path mode exists)) (unless (permissions? perms)
(raise-argument-error 'open-input-output-file perms-desc perms))
(k:open-input-output-file path mode exists perms))
(define (call-with-input-file path proc #:mode [mode 'binary]) (define (call-with-input-file path proc #:mode [mode 'binary])
(unless (path-string? path) (unless (path-string? path)
@ -63,7 +74,8 @@
(define (call-with-output-file path proc (define (call-with-output-file path proc
#:mode [mode 'binary] #:mode [mode 'binary]
#:exists [exists 'error]) #:exists [exists 'error]
#:permissions [perms DEFAULT-CREATE-PERMS])
(unless (path-string? path) (unless (path-string? path)
(raise-argument-error 'call-with-output-file "path-string?" path)) (raise-argument-error 'call-with-output-file "path-string?" path))
(unless (and (procedure? proc) (unless (and (procedure? proc)
@ -73,7 +85,9 @@
(raise-argument-error 'call-with-output-file binary-or-text-desc mode)) (raise-argument-error 'call-with-output-file binary-or-text-desc mode))
(unless (memq exists exists-syms) (unless (memq exists exists-syms)
(raise-argument-error 'call-with-output-file exists-desc exists)) (raise-argument-error 'call-with-output-file exists-desc exists))
(k:call-with-output-file path proc mode exists)) (unless (permissions? perms)
(raise-argument-error 'call-with-output-file perms-desc perms))
(k:call-with-output-file path proc mode exists perms))
(define (with-input-from-file path proc #:mode [mode 'binary]) (define (with-input-from-file path proc #:mode [mode 'binary])
(unless (path-string? path) (unless (path-string? path)
@ -87,7 +101,8 @@
(define (with-output-to-file path proc (define (with-output-to-file path proc
#:mode [mode 'binary] #:mode [mode 'binary]
#:exists [exists 'error]) #:exists [exists 'error]
#:permissions [perms DEFAULT-CREATE-PERMS])
(unless (path-string? path) (unless (path-string? path)
(raise-argument-error 'with-output-to-file "path-string?" path)) (raise-argument-error 'with-output-to-file "path-string?" path))
(unless (and (procedure? proc) (unless (and (procedure? proc)
@ -97,7 +112,9 @@
(raise-argument-error 'with-output-to-file binary-or-text-desc mode)) (raise-argument-error 'with-output-to-file binary-or-text-desc mode))
(unless (memq exists exists-syms) (unless (memq exists exists-syms)
(raise-argument-error 'with-output-to-file exists-desc exists)) (raise-argument-error 'with-output-to-file exists-desc exists))
(k:with-output-to-file path proc mode exists)) (unless (permissions? perms)
(raise-argument-error 'with-output-to-file perms-desc perms))
(k:with-output-to-file path proc mode exists perms))
(define (call-with-input-file* path proc #:mode [mode 'binary]) (define (call-with-input-file* path proc #:mode [mode 'binary])
(unless (path-string? path) (unless (path-string? path)
@ -115,7 +132,8 @@
(define (call-with-output-file* path proc (define (call-with-output-file* path proc
#:mode [mode 'binary] #:mode [mode 'binary]
#:exists [exists 'error]) #:exists [exists 'error]
#:permissions [perms DEFAULT-CREATE-PERMS])
(unless (path-string? path) (unless (path-string? path)
(raise-argument-error 'call-with-output-file* "path-string?" path)) (raise-argument-error 'call-with-output-file* "path-string?" path))
(unless (and (procedure? proc) (unless (and (procedure? proc)
@ -125,7 +143,9 @@
(raise-argument-error 'call-with-output-file* binary-or-text-desc mode)) (raise-argument-error 'call-with-output-file* binary-or-text-desc mode))
(unless (memq exists exists-syms) (unless (memq exists exists-syms)
(raise-argument-error 'call-with-output-file* exists-desc exists)) (raise-argument-error 'call-with-output-file* exists-desc exists))
(let ([p (k:open-output-file path mode exists)]) (unless (permissions? perms)
(raise-argument-error 'call-with-output-file* perms-desc perms))
(let ([p (k:open-output-file path mode exists perms)])
(dynamic-wind (dynamic-wind
void void
(lambda () (proc p)) (lambda () (proc p))

View File

@ -3784,6 +3784,7 @@ scheme_do_open_output_file(char *name, int offset, int argc, Scheme_Object *argv
char *filename; char *filename;
char mode[4]; char mode[4];
int typepos; int typepos;
int perms;
rktio_fd_t *fd; rktio_fd_t *fd;
mode[0] = 'w'; mode[0] = 'w';
@ -3791,79 +3792,86 @@ scheme_do_open_output_file(char *name, int offset, int argc, Scheme_Object *argv
mode[2] = 0; mode[2] = 0;
mode[3] = 0; mode[3] = 0;
typepos = 1; typepos = 1;
perms = RKTIO_DEFAULT_PERM_BITS;
if (!SCHEME_PATH_STRINGP(argv[0])) if (!SCHEME_PATH_STRINGP(argv[0]))
scheme_wrong_contract(name, "path-string?", 0, argc, argv); scheme_wrong_contract(name, "path-string?", 0, argc, argv);
for (i = 1 + offset; argc > i; i++) { for (i = 1 + offset; argc > i; i++) {
if (!SCHEME_SYMBOLP(argv[i])) if (SCHEME_INTP(argv[i])
scheme_wrong_contract(name, "symbol?", i, argc, argv); && (SCHEME_INT_VAL(argv[i]) >= 0)
&& (SCHEME_INT_VAL(argv[i]) <= 65535)) {
if (SAME_OBJ(argv[i], append_symbol)) { perms = SCHEME_INT_VAL(argv[i]);
mode[0] = 'a';
open_flags = RKTIO_OPEN_APPEND;
e_set++;
} else if (SAME_OBJ(argv[i], replace_symbol)) {
try_replace = 1;
e_set++;
} else if (SAME_OBJ(argv[i], truncate_symbol)) {
open_flags = RKTIO_OPEN_TRUNCATE | RKTIO_OPEN_CAN_EXIST;
e_set++;
} else if (SAME_OBJ(argv[i], must_truncate_symbol)) {
open_flags = RKTIO_OPEN_MUST_EXIST | RKTIO_OPEN_TRUNCATE;
e_set++;
} else if (SAME_OBJ(argv[i], truncate_replace_symbol)) {
open_flags = RKTIO_OPEN_TRUNCATE | RKTIO_OPEN_CAN_EXIST;
try_replace = 1;
e_set++;
} else if (SAME_OBJ(argv[i], update_symbol)) {
open_flags = RKTIO_OPEN_MUST_EXIST;
if (typepos == 1) {
mode[2] = mode[1];
typepos = 2;
}
mode[0] = 'r';
mode[1] = '+';
e_set++;
} else if (SAME_OBJ(argv[i], can_update_symbol)) {
open_flags = RKTIO_OPEN_CAN_EXIST;
if (typepos == 1) {
mode[2] = mode[1];
typepos = 2;
}
mode[0] = 'r';
mode[1] = '+';
e_set++;
} else if (SAME_OBJ(argv[i], error_symbol)) {
/* This is the default */
e_set++;
} else if (SAME_OBJ(argv[i], text_symbol)) {
mode[typepos] = 't';
m_set++;
} else if (SAME_OBJ(argv[i], binary_symbol)) {
/* This is the default */
m_set++;
} else { } else {
char *astr; if (!SCHEME_SYMBOLP(argv[i]))
intptr_t alen; scheme_wrong_contract(name, "(or/c symbol? (integer-in 0 65535))", i, argc, argv);
astr = scheme_make_args_string("other ", i, argc, argv, &alen); if (SAME_OBJ(argv[i], append_symbol)) {
scheme_raise_exn(MZEXN_FAIL_CONTRACT, mode[0] = 'a';
"%s: bad mode symbol\n" open_flags = RKTIO_OPEN_APPEND;
" given symbol: : %s%s", name, e_set++;
scheme_make_provided_string(argv[i], 1, NULL), } else if (SAME_OBJ(argv[i], replace_symbol)) {
astr, alen); try_replace = 1;
} e_set++;
} else if (SAME_OBJ(argv[i], truncate_symbol)) {
open_flags = RKTIO_OPEN_TRUNCATE | RKTIO_OPEN_CAN_EXIST;
e_set++;
} else if (SAME_OBJ(argv[i], must_truncate_symbol)) {
open_flags = RKTIO_OPEN_MUST_EXIST | RKTIO_OPEN_TRUNCATE;
e_set++;
} else if (SAME_OBJ(argv[i], truncate_replace_symbol)) {
open_flags = RKTIO_OPEN_TRUNCATE | RKTIO_OPEN_CAN_EXIST;
try_replace = 1;
e_set++;
} else if (SAME_OBJ(argv[i], update_symbol)) {
open_flags = RKTIO_OPEN_MUST_EXIST;
if (typepos == 1) {
mode[2] = mode[1];
typepos = 2;
}
mode[0] = 'r';
mode[1] = '+';
e_set++;
} else if (SAME_OBJ(argv[i], can_update_symbol)) {
open_flags = RKTIO_OPEN_CAN_EXIST;
if (typepos == 1) {
mode[2] = mode[1];
typepos = 2;
}
mode[0] = 'r';
mode[1] = '+';
e_set++;
} else if (SAME_OBJ(argv[i], error_symbol)) {
/* This is the default */
e_set++;
} else if (SAME_OBJ(argv[i], text_symbol)) {
mode[typepos] = 't';
m_set++;
} else if (SAME_OBJ(argv[i], binary_symbol)) {
/* This is the default */
m_set++;
} else {
char *astr;
intptr_t alen;
if (m_set > 1 || e_set > 1) { astr = scheme_make_args_string("other ", i, argc, argv, &alen);
char *astr; scheme_raise_exn(MZEXN_FAIL_CONTRACT,
intptr_t alen; "%s: bad mode symbol\n"
" given symbol: : %s%s", name,
scheme_make_provided_string(argv[i], 1, NULL),
astr, alen);
}
astr = scheme_make_args_string("", -1, argc, argv, &alen); if (m_set > 1 || e_set > 1) {
scheme_raise_exn(MZEXN_FAIL_CONTRACT, char *astr;
"%s: conflicting or redundant file modes given%t", intptr_t alen;
name,
astr, alen); astr = scheme_make_args_string("", -1, argc, argv, &alen);
scheme_raise_exn(MZEXN_FAIL_CONTRACT,
"%s: conflicting or redundant file modes given%t",
name,
astr, alen);
}
} }
} }
@ -3890,10 +3898,12 @@ scheme_do_open_output_file(char *name, int offset, int argc, Scheme_Object *argv
scheme_custodian_check_available(NULL, name, "file-stream"); scheme_custodian_check_available(NULL, name, "file-stream");
while (1) { while (1) {
fd = rktio_open(scheme_rktio, filename, (RKTIO_OPEN_WRITE fd = rktio_open_with_create_permissions(scheme_rktio, filename,
(RKTIO_OPEN_WRITE
| open_flags | open_flags
| (and_read ? RKTIO_OPEN_READ : 0) | (and_read ? RKTIO_OPEN_READ : 0)
| ((mode[1] == 't') ? RKTIO_OPEN_TEXT : 0))); | ((mode[1] == 't') ? RKTIO_OPEN_TEXT : 0)),
perms);
if (!fd if (!fd
&& try_replace && try_replace

View File

@ -227,20 +227,20 @@ scheme_init_port_fun(Scheme_Startup_Env *env)
ADD_NONCM_PRIM("open-input-file", open_input_file, 1, 3, env); ADD_NONCM_PRIM("open-input-file", open_input_file, 1, 3, env);
ADD_NONCM_PRIM("open-input-bytes", open_input_byte_string, 1, 2, env); ADD_NONCM_PRIM("open-input-bytes", open_input_byte_string, 1, 2, env);
ADD_NONCM_PRIM("open-input-string", open_input_char_string, 1, 2, env); ADD_NONCM_PRIM("open-input-string", open_input_char_string, 1, 2, env);
ADD_NONCM_PRIM("open-output-file", open_output_file, 1, 3, env); ADD_NONCM_PRIM("open-output-file", open_output_file, 1, 4, env);
ADD_NONCM_PRIM("open-output-bytes", open_output_string, 0, 1, env); ADD_NONCM_PRIM("open-output-bytes", open_output_string, 0, 1, env);
ADD_NONCM_PRIM("open-output-string", open_output_string, 0, 1, env); ADD_NONCM_PRIM("open-output-string", open_output_string, 0, 1, env);
ADD_NONCM_PRIM("get-output-bytes", get_output_byte_string, 1, 4, env); ADD_NONCM_PRIM("get-output-bytes", get_output_byte_string, 1, 4, env);
ADD_NONCM_PRIM("get-output-string", get_output_char_string, 1, 1, env); ADD_NONCM_PRIM("get-output-string", get_output_char_string, 1, 1, env);
ADD_NONCM_PRIM("open-input-output-file", open_input_output_file, 1, 3, env); ADD_NONCM_PRIM("open-input-output-file", open_input_output_file, 1, 4, env);
ADD_NONCM_PRIM("close-input-port", close_input_port, 1, 1, env); ADD_NONCM_PRIM("close-input-port", close_input_port, 1, 1, env);
ADD_NONCM_PRIM("close-output-port", close_output_port, 1, 1, env); ADD_NONCM_PRIM("close-output-port", close_output_port, 1, 1, env);
ADD_NONCM_PRIM("make-input-port", make_input_port, 4, 10, env); ADD_NONCM_PRIM("make-input-port", make_input_port, 4, 10, env);
ADD_NONCM_PRIM("make-output-port", make_output_port, 4, 11, env); ADD_NONCM_PRIM("make-output-port", make_output_port, 4, 11, env);
ADD_PRIM_W_ARITY2("call-with-output-file", call_with_output_file, 2, 4, 0, -1, env); ADD_PRIM_W_ARITY2("call-with-output-file", call_with_output_file, 2, 5, 0, -1, env);
ADD_PRIM_W_ARITY2("call-with-input-file", call_with_input_file, 2, 3, 0, -1, env); ADD_PRIM_W_ARITY2("call-with-input-file", call_with_input_file, 2, 3, 0, -1, env);
ADD_PRIM_W_ARITY2("with-output-to-file", with_output_to_file, 2, 4, 0, -1, env); ADD_PRIM_W_ARITY2("with-output-to-file", with_output_to_file, 2, 5, 0, -1, env);
ADD_PRIM_W_ARITY2("with-input-from-file", with_input_from_file, 2, 3, 0, -1, env); ADD_PRIM_W_ARITY2("with-input-from-file", with_input_from_file, 2, 3, 0, -1, env);
ADD_PRIM_W_ARITY2("make-pipe", sch_pipe, 0, 3, 2, 2, env); ADD_PRIM_W_ARITY2("make-pipe", sch_pipe, 0, 3, 2, 2, env);
ADD_PRIM_W_ARITY2("port-next-location", port_next_location, 1, 1, 3, 3, env); ADD_PRIM_W_ARITY2("port-next-location", port_next_location, 1, 1, 3, 3, env);

View File

@ -2461,12 +2461,12 @@ static const char *startup_source =
"(open-input-file path_0 mode_0(if for-module?_0 'module 'none))))))))))" "(open-input-file path_0 mode_0(if for-module?_0 'module 'none))))))))))"
"(define-values" "(define-values"
"(with-input-from-file.1)" "(with-input-from-file.1)"
"(lambda(mode31_0 path33_0 proc34_0)" "(lambda(mode37_0 path39_0 proc40_0)"
"(begin" "(begin"
" 'with-input-from-file" " 'with-input-from-file"
"(let-values(((path_0) path33_0))" "(let-values(((path_0) path39_0))"
"(let-values(((proc_0) proc34_0))" "(let-values(((proc_0) proc40_0))"
"(let-values(((mode_0) mode31_0))" "(let-values(((mode_0) mode37_0))"
"(let-values()" "(let-values()"
"(begin" "(begin"
"(if(path-string? path_0)" "(if(path-string? path_0)"
@ -2481,12 +2481,12 @@ static const char *startup_source =
"(with-input-from-file path_0 proc_0 mode_0)))))))))" "(with-input-from-file path_0 proc_0 mode_0)))))))))"
"(define-values" "(define-values"
"(call-with-input-file*.1)" "(call-with-input-file*.1)"
"(lambda(mode43_0 path45_0 proc46_0)" "(lambda(mode51_0 path53_0 proc54_0)"
"(begin" "(begin"
" 'call-with-input-file*" " 'call-with-input-file*"
"(let-values(((path_0) path45_0))" "(let-values(((path_0) path53_0))"
"(let-values(((proc_0) proc46_0))" "(let-values(((proc_0) proc54_0))"
"(let-values(((mode_0) mode43_0))" "(let-values(((mode_0) mode51_0))"
"(let-values()" "(let-values()"
"(begin" "(begin"
"(if(path-string? path_0)" "(if(path-string? path_0)"

View File

@ -3431,57 +3431,57 @@
(define with-input-from-file.1 (define with-input-from-file.1
(|#%name| (|#%name|
with-input-from-file with-input-from-file
(lambda (mode31_0 path33_0 proc34_0) (lambda (mode37_0 path39_0 proc40_0)
(begin (begin
(begin (begin
(if (path-string? path33_0) (if (path-string? path39_0)
(void) (void)
(raise-argument-error (raise-argument-error
'with-input-from-file 'with-input-from-file
"path-string?" "path-string?"
path33_0)) path39_0))
(if (if (procedure? proc34_0) (if (if (procedure? proc40_0)
(procedure-arity-includes? proc34_0 0) (procedure-arity-includes? proc40_0 0)
#f) #f)
(void) (void)
(raise-argument-error 'with-input-from-file "(-> any)" proc34_0)) (raise-argument-error 'with-input-from-file "(-> any)" proc40_0))
(if (memq mode31_0 '(binary text)) (if (memq mode37_0 '(binary text))
(void) (void)
(raise-argument-error (raise-argument-error
'with-input-from-file 'with-input-from-file
binary-or-text-desc binary-or-text-desc
mode31_0)) mode37_0))
(with-input-from-file path33_0 proc34_0 mode31_0)))))) (with-input-from-file path39_0 proc40_0 mode37_0))))))
(define call-with-input-file*.1 (define call-with-input-file*.1
(|#%name| (|#%name|
call-with-input-file* call-with-input-file*
(lambda (mode43_0 path45_0 proc46_0) (lambda (mode51_0 path53_0 proc54_0)
(begin (begin
(begin (begin
(if (path-string? path45_0) (if (path-string? path53_0)
(void) (void)
(raise-argument-error (raise-argument-error
'call-with-input-file* 'call-with-input-file*
"path-string?" "path-string?"
path45_0)) path53_0))
(if (if (procedure? proc46_0) (if (if (procedure? proc54_0)
(procedure-arity-includes? proc46_0 1) (procedure-arity-includes? proc54_0 1)
#f) #f)
(void) (void)
(raise-argument-error (raise-argument-error
'call-with-input-file* 'call-with-input-file*
"(input-port? . -> . any)" "(input-port? . -> . any)"
proc46_0)) proc54_0))
(if (memq mode43_0 '(binary text)) (if (memq mode51_0 '(binary text))
(void) (void)
(raise-argument-error (raise-argument-error
'call-with-input-file* 'call-with-input-file*
binary-or-text-desc binary-or-text-desc
mode43_0)) mode51_0))
(let ((p_0 (open-input-file path45_0 mode43_0))) (let ((p_0 (open-input-file path53_0 mode51_0)))
(dynamic-wind (dynamic-wind
void void
(lambda () (|#%app| proc46_0 p_0)) (lambda () (|#%app| proc54_0 p_0))
(lambda () (close-input-port p_0))))))))) (lambda () (close-input-port p_0)))))))))
(define print-value-columns (define print-value-columns
(make-parameter (make-parameter

View File

@ -2964,6 +2964,8 @@
(begin-unsafe (hash-ref rktio-table 'rktio_fd_is_pending_open))) (begin-unsafe (hash-ref rktio-table 'rktio_fd_is_pending_open)))
(define rktio_fd_modes (begin-unsafe (hash-ref rktio-table 'rktio_fd_modes))) (define rktio_fd_modes (begin-unsafe (hash-ref rktio-table 'rktio_fd_modes)))
(define rktio_open (begin-unsafe (hash-ref rktio-table 'rktio_open))) (define rktio_open (begin-unsafe (hash-ref rktio-table 'rktio_open)))
(define rktio_open_with_create_permissions
(begin-unsafe (hash-ref rktio-table 'rktio_open_with_create_permissions)))
(define rktio_close (begin-unsafe (hash-ref rktio-table 'rktio_close))) (define rktio_close (begin-unsafe (hash-ref rktio-table 'rktio_close)))
(define rktio_close_noerr (define rktio_close_noerr
(begin-unsafe (hash-ref rktio-table 'rktio_close_noerr))) (begin-unsafe (hash-ref rktio-table 'rktio_close_noerr)))
@ -25981,12 +25983,12 @@
(1/format app_0 (host-> host-path_0))))) (1/format app_0 (host-> host-path_0)))))
(void)) (void))
(let ((p_0 (let ((p_0
(let ((temp33_0 (host-> host-path_0))) (let ((temp38_0 (host-> host-path_0)))
(open-input-fd.1 (open-input-fd.1
unsafe-undefined unsafe-undefined
unsafe-undefined unsafe-undefined
fd_0 fd_0
temp33_0)))) temp38_0))))
(begin (begin
(unsafe-end-atomic) (unsafe-end-atomic)
(if (1/port-count-lines-enabled) (if (1/port-count-lines-enabled)
@ -26001,284 +26003,334 @@
((path_0 mode1_0 mode22_0) (open-input-file_0 path_0 mode1_0 mode22_0)) ((path_0 mode1_0 mode22_0) (open-input-file_0 path_0 mode1_0 mode22_0))
((path_0 mode11_0) ((path_0 mode11_0)
(open-input-file_0 path_0 mode11_0 unsafe-undefined)))))) (open-input-file_0 path_0 mode11_0 unsafe-undefined))))))
(define permissions?
(lambda (perms_0) (if (exact-integer? perms_0) (<= 0 perms_0 65535) #f)))
(define permissions-desc "(integer-in 0 65535)")
(define do-open-output-file.1 (define do-open-output-file.1
(|#%name| (|#%name|
do-open-output-file do-open-output-file
(lambda (plus-input?4_0 who6_0 path7_0 mode18_0 mode29_0) (lambda (plus-input?4_0 who6_0 path7_0 mode18_0 mode29_0 perms10_0)
(begin (begin
(begin (begin
(if (path-string? path7_0) (if (path-string? path7_0)
(void) (void)
(raise-argument-error who6_0 "path-string?" path7_0)) (raise-argument-error who6_0 "path-string?" path7_0))
(let ((mode->flags_0 (begin
(|#%name| (if (permissions? perms10_0)
mode->flags (void)
(lambda (mode_0) (raise-argument-error who6_0 permissions-desc perms10_0))
(begin (let ((mode->flags_0
(if (eq? mode_0 'text)
4
(if (if (eq? mode_0 'truncate)
#t
(eq? mode_0 'truncate/replace))
72
(if (eq? mode_0 'must-truncate)
40
(if (eq? mode_0 'can-update)
64
(if (eq? mode_0 'update)
32
(if (eq? mode_0 'append) 16 0)))))))))))
(let ((mode?_0
(|#%name| (|#%name|
mode? mode->flags
(lambda (v_0) (lambda (mode_0)
(begin (begin
(let ((or-part_0 (eq? mode18_0 v_0))) (if (eq? mode_0 'text)
(if or-part_0 or-part_0 (eq? mode29_0 v_0)))))))) 4
(let ((host-path_0 (if (if (eq? mode_0 'truncate)
(->host #t
path7_0 (eq? mode_0 'truncate/replace))
who6_0 72
(let ((app_0 (if (eq? mode_0 'must-truncate)
(if (let ((or-part_0 (mode?_0 'replace))) 40
(if or-part_0 (if (eq? mode_0 'can-update)
or-part_0 64
(mode?_0 'truncate/replace))) (if (eq? mode_0 'update)
'(delete) 32
'()))) (if (eq? mode_0 'append) 16 0)))))))))))
(append (let ((mode?_0
'(write) (|#%name|
app_0 mode?
(if (let ((or-part_0 (mode?_0 'append))) (lambda (v_0)
(if or-part_0 (begin
or-part_0 (let ((or-part_0 (eq? mode18_0 v_0)))
(let ((or-part_1 (mode?_0 'update))) (if or-part_0 or-part_0 (eq? mode29_0 v_0))))))))
(if or-part_1 (let ((host-path_0
or-part_1 (->host
(mode?_0 'must-update))))) path7_0
'(read) who6_0
'())))))) (let ((app_0
(begin (if (let ((or-part_0 (mode?_0 'replace)))
(unsafe-start-atomic) (if or-part_0
or-part_0
(mode?_0 'truncate/replace)))
'(delete)
'())))
(append
'(write)
app_0
(if (let ((or-part_0 (mode?_0 'append)))
(if or-part_0
or-part_0
(let ((or-part_1 (mode?_0 'update)))
(if or-part_1
or-part_1
(mode?_0 'must-update)))))
'(read)
'()))))))
(begin (begin
(check-current-custodian who6_0) (unsafe-start-atomic)
(let ((flags_0 (begin
(let ((app_0 (if plus-input?4_0 1 0))) (check-current-custodian who6_0)
(let ((app_1 (mode->flags_0 mode18_0))) (let ((flags_0
(+ 2 app_0 app_1 (mode->flags_0 mode29_0)))))) (let ((app_0 (if plus-input?4_0 1 0)))
(let ((fd0_0 (let ((app_1 (mode->flags_0 mode18_0)))
(|#%app| (+ 2 app_0 app_1 (mode->flags_0 mode29_0))))))
rktio_open (let ((fd0_0
(unsafe-place-local-ref cell.1) (|#%app|
host-path_0 rktio_open_with_create_permissions
flags_0))) (unsafe-place-local-ref cell.1)
(let ((fd_0 host-path_0
(if (not (vector? fd0_0)) flags_0
fd0_0 perms10_0)))
(if (if (let ((or-part_0 (let ((fd_0
(racket-error? fd0_0 4))) (if (not (vector? fd0_0))
fd0_0
(if (if (let ((or-part_0
(racket-error? fd0_0 4)))
(if or-part_0
or-part_0
(racket-error? fd0_0 5)))
(let ((or-part_0 (mode?_0 'replace)))
(if or-part_0 (if or-part_0
or-part_0 or-part_0
(racket-error? fd0_0 5))) (mode?_0 'truncate/replace)))
(let ((or-part_0 (mode?_0 'replace))) #f)
(if or-part_0 (let ((r_0
or-part_0 (|#%app|
(mode?_0 'truncate/replace))) rktio_delete_file
#f) (unsafe-place-local-ref cell.1)
(let ((r_0 host-path_0
(|#%app| (1/current-force-delete-permissions))))
rktio_delete_file (begin
(unsafe-place-local-ref cell.1) (if (vector? r_0)
host-path_0 (begin
(1/current-force-delete-permissions)))) (unsafe-end-atomic)
(begin (raise-filesystem-error
(if (vector? r_0) who6_0
(begin r_0
(unsafe-end-atomic) (let ((app_0
(raise-filesystem-error (string-append
who6_0 "error deleting file\n"
r_0 " path: ~a")))
(let ((app_0 (1/format
(string-append app_0
"error deleting file\n" (host-> host-path_0)))))
" path: ~a"))) (void))
(1/format (|#%app|
app_0 rktio_open
(host-> host-path_0))))) (unsafe-place-local-ref cell.1)
(void)) host-path_0
(|#%app| flags_0)))
rktio_open fd0_0))))
(unsafe-place-local-ref cell.1) (begin
host-path_0 (if (vector? fd_0)
flags_0))) (begin
fd0_0)))) (unsafe-end-atomic)
(begin (raise-filesystem-error
(if (vector? fd_0) who6_0
(begin fd_0
(unsafe-end-atomic) (let ((app_0
(raise-filesystem-error (string-append "~a\n" " path: ~a")))
who6_0 (let ((app_1
fd_0 (if (racket-error? fd0_0 4)
(let ((app_0 "file exists"
(string-append "~a\n" " path: ~a"))) (if (racket-error? fd0_0 9)
(let ((app_1 "path is a directory"
(if (racket-error? fd0_0 4) "error opening file"))))
"file exists" (1/format
(if (racket-error? fd0_0 9) app_0
"path is a directory" app_1
"error opening file")))) (host-> host-path_0))))))
(1/format (void))
app_0 (let ((opened-path_0 (host-> host-path_0)))
app_1 (let ((refcount_0
(host-> host-path_0)))))) (box (if plus-input?4_0 2 1))))
(void)) (let ((op_0
(let ((opened-path_0 (host-> host-path_0))) (open-output-fd.1
(let ((refcount_0 (box (if plus-input?4_0 2 1)))) 'infer
(let ((op_0 unsafe-undefined
(open-output-fd.1 refcount_0
'infer unsafe-undefined
unsafe-undefined fd_0
refcount_0 opened-path_0)))
unsafe-undefined (let ((ip_0
fd_0 (if plus-input?4_0
opened-path_0))) (open-input-fd.1
(let ((ip_0 unsafe-undefined
(if plus-input?4_0 refcount_0
(open-input-fd.1 fd_0
unsafe-undefined opened-path_0)
refcount_0 #f)))
fd_0 (begin
opened-path_0) (unsafe-end-atomic)
#f))) (if (1/port-count-lines-enabled)
(begin (begin
(unsafe-end-atomic) (1/port-count-lines! op_0)
(if (1/port-count-lines-enabled) (if plus-input?4_0
(begin (1/port-count-lines! ip_0)
(1/port-count-lines! op_0) (void)))
(if plus-input?4_0 (void))
(1/port-count-lines! ip_0) (if plus-input?4_0
(void))) (values ip_0 op_0)
(void)) op_0)))))))))))))))))))))
(if plus-input?4_0 (define DEFAULT-CREATE-PERMS 438)
(values ip_0 op_0)
op_0))))))))))))))))))))
(define 1/open-output-file (define 1/open-output-file
(let ((open-output-file_0 (let ((open-output-file_0
(|#%name| (|#%name|
open-output-file open-output-file
(lambda (path13_0 mode111_0 mode212_0) (lambda (path15_0 mode112_0 mode213_0 perms14_0)
(begin (begin
(let ((mode1_0 (let ((mode1_0
(if (eq? mode111_0 unsafe-undefined) none$1 mode111_0))) (if (eq? mode112_0 unsafe-undefined) none$1 mode112_0)))
(let ((mode2_0 (let ((mode2_0
(if (eq? mode212_0 unsafe-undefined) none$1 mode212_0))) (if (eq? mode213_0 unsafe-undefined) none$1 mode213_0)))
(do-open-output-file.1 (let ((perms_0
#f (if (eq? perms14_0 unsafe-undefined) 438 perms14_0)))
'open-output-file (do-open-output-file.1
path13_0 #f
mode1_0 'open-output-file
mode2_0)))))))) path15_0
mode1_0
mode2_0
perms_0)))))))))
(|#%name| (|#%name|
open-output-file open-output-file
(case-lambda (case-lambda
((path_0) ((path_0)
(begin (open-output-file_0 path_0 unsafe-undefined unsafe-undefined))) (begin
((path_0 mode1_0 mode212_0) (open-output-file_0
(open-output-file_0 path_0 mode1_0 mode212_0)) path_0
((path_0 mode111_0) unsafe-undefined
(open-output-file_0 path_0 mode111_0 unsafe-undefined)))))) unsafe-undefined
unsafe-undefined)))
((path_0 mode1_0 mode2_0 perms14_0)
(open-output-file_0 path_0 mode1_0 mode2_0 perms14_0))
((path_0 mode1_0 mode213_0)
(open-output-file_0 path_0 mode1_0 mode213_0 unsafe-undefined))
((path_0 mode112_0)
(open-output-file_0
path_0
mode112_0
unsafe-undefined
unsafe-undefined))))))
(define 1/open-input-output-file (define 1/open-input-output-file
(let ((open-input-output-file_0 (let ((open-input-output-file_0
(|#%name| (|#%name|
open-input-output-file open-input-output-file
(lambda (path16_0 mode114_0 mode215_0) (lambda (path19_0 mode116_0 mode217_0 perms18_0)
(begin (begin
(let ((mode1_0 (let ((mode1_0
(if (eq? mode114_0 unsafe-undefined) none$1 mode114_0))) (if (eq? mode116_0 unsafe-undefined) none$1 mode116_0)))
(let ((mode2_0 (let ((mode2_0
(if (eq? mode215_0 unsafe-undefined) none$1 mode215_0))) (if (eq? mode217_0 unsafe-undefined) none$1 mode217_0)))
(do-open-output-file.1 (let ((perms_0
#t (if (eq? perms18_0 unsafe-undefined) 438 perms18_0)))
'open-input-output-file (do-open-output-file.1
path16_0 #t
mode1_0 'open-input-output-file
mode2_0)))))))) path19_0
mode1_0
mode2_0
perms_0)))))))))
(|#%name| (|#%name|
open-input-output-file open-input-output-file
(case-lambda (case-lambda
((path_0) ((path_0)
(begin (begin
(open-input-output-file_0 path_0 unsafe-undefined unsafe-undefined))) (open-input-output-file_0
((path_0 mode1_0 mode215_0) path_0
(open-input-output-file_0 path_0 mode1_0 mode215_0)) unsafe-undefined
((path_0 mode114_0) unsafe-undefined
(open-input-output-file_0 path_0 mode114_0 unsafe-undefined)))))) unsafe-undefined)))
((path_0 mode1_0 mode2_0 perms18_0)
(open-input-output-file_0 path_0 mode1_0 mode2_0 perms18_0))
((path_0 mode1_0 mode217_0)
(open-input-output-file_0 path_0 mode1_0 mode217_0 unsafe-undefined))
((path_0 mode116_0)
(open-input-output-file_0
path_0
mode116_0
unsafe-undefined
unsafe-undefined))))))
(define 1/call-with-input-file (define 1/call-with-input-file
(let ((call-with-input-file_0 (let ((call-with-input-file_0
(|#%name| (|#%name|
call-with-input-file call-with-input-file
(lambda (path18_0 proc19_0 mode17_0) (lambda (path21_0 proc22_0 mode20_0)
(begin (begin
(let ((mode_0 (let ((mode_0
(if (eq? mode17_0 unsafe-undefined) none$1 mode17_0))) (if (eq? mode20_0 unsafe-undefined) none$1 mode20_0)))
(begin (begin
(if (path-string? path18_0) (if (path-string? path21_0)
(void) (void)
(raise-argument-error (raise-argument-error
'call-with-input-file 'call-with-input-file
"path-string?" "path-string?"
path18_0)) path21_0))
(begin (begin
(if (if (procedure? proc19_0) (if (if (procedure? proc22_0)
(procedure-arity-includes? proc19_0 1) (procedure-arity-includes? proc22_0 1)
#f) #f)
(void) (void)
(raise-argument-error (raise-argument-error
'call-with-input-file 'call-with-input-file
"(procedure-arity-includes/c 1)" "(procedure-arity-includes/c 1)"
proc19_0)) proc22_0))
(let ((i_0 (1/open-input-file path18_0 mode_0))) (let ((i_0 (1/open-input-file path21_0 mode_0)))
(begin0 (begin0
(|#%app| proc19_0 i_0) (|#%app| proc22_0 i_0)
(1/close-input-port i_0))))))))))) (1/close-input-port i_0)))))))))))
(|#%name| (|#%name|
call-with-input-file call-with-input-file
(case-lambda (case-lambda
((path_0 proc_0) ((path_0 proc_0)
(begin (call-with-input-file_0 path_0 proc_0 unsafe-undefined))) (begin (call-with-input-file_0 path_0 proc_0 unsafe-undefined)))
((path_0 proc_0 mode17_0) ((path_0 proc_0 mode20_0)
(call-with-input-file_0 path_0 proc_0 mode17_0)))))) (call-with-input-file_0 path_0 proc_0 mode20_0))))))
(define 1/call-with-output-file (define 1/call-with-output-file
(let ((call-with-output-file_0 (let ((call-with-output-file_0
(|#%name| (|#%name|
call-with-output-file call-with-output-file
(lambda (path22_0 proc23_0 mode120_0 mode221_0) (lambda (path26_0 proc27_0 mode123_0 mode224_0 perms25_0)
(begin (begin
(let ((mode1_0 (let ((mode1_0
(if (eq? mode120_0 unsafe-undefined) none$1 mode120_0))) (if (eq? mode123_0 unsafe-undefined) none$1 mode123_0)))
(let ((mode2_0 (let ((mode2_0
(if (eq? mode221_0 unsafe-undefined) none$1 mode221_0))) (if (eq? mode224_0 unsafe-undefined) none$1 mode224_0)))
(begin (let ((perms_0
(if (path-string? path22_0) (if (eq? perms25_0 unsafe-undefined) 438 perms25_0)))
(void)
(raise-argument-error
'call-with-output-file
"path-string?"
path22_0))
(begin (begin
(if (if (procedure? proc23_0) (if (path-string? path26_0)
(procedure-arity-includes? proc23_0 1)
#f)
(void) (void)
(raise-argument-error (raise-argument-error
'call-with-output-file 'call-with-output-file
"(procedure-arity-includes/c 1)" "path-string?"
proc23_0)) path26_0))
(let ((o_0 (begin
(1/open-output-file path22_0 mode1_0 mode2_0))) (if (if (procedure? proc27_0)
(begin0 (procedure-arity-includes? proc27_0 1)
(|#%app| proc23_0 o_0) #f)
(1/close-output-port o_0)))))))))))) (void)
(raise-argument-error
'call-with-output-file
"(procedure-arity-includes/c 1)"
proc27_0))
(begin
(if (permissions? perms_0)
(void)
(raise-argument-error
'call-with-output-file
permissions-desc
perms_0))
(let ((o_0
(1/open-output-file
path26_0
mode1_0
mode2_0
perms_0)))
(begin0
(|#%app| proc27_0 o_0)
(1/close-output-port o_0))))))))))))))
(|#%name| (|#%name|
call-with-output-file call-with-output-file
(case-lambda (case-lambda
@ -26288,36 +26340,49 @@
path_0 path_0
proc_0 proc_0
unsafe-undefined unsafe-undefined
unsafe-undefined
unsafe-undefined))) unsafe-undefined)))
((path_0 proc_0 mode1_0 mode221_0) ((path_0 proc_0 mode1_0 mode2_0 perms25_0)
(call-with-output-file_0 path_0 proc_0 mode1_0 mode221_0)) (call-with-output-file_0 path_0 proc_0 mode1_0 mode2_0 perms25_0))
((path_0 proc_0 mode120_0) ((path_0 proc_0 mode1_0 mode224_0)
(call-with-output-file_0 path_0 proc_0 mode120_0 unsafe-undefined)))))) (call-with-output-file_0
path_0
proc_0
mode1_0
mode224_0
unsafe-undefined))
((path_0 proc_0 mode123_0)
(call-with-output-file_0
path_0
proc_0
mode123_0
unsafe-undefined
unsafe-undefined))))))
(define 1/with-input-from-file (define 1/with-input-from-file
(let ((with-input-from-file_0 (let ((with-input-from-file_0
(|#%name| (|#%name|
with-input-from-file with-input-from-file
(lambda (path25_0 proc26_0 mode24_0) (lambda (path29_0 proc30_0 mode28_0)
(begin (begin
(let ((mode_0 (let ((mode_0
(if (eq? mode24_0 unsafe-undefined) none$1 mode24_0))) (if (eq? mode28_0 unsafe-undefined) none$1 mode28_0)))
(begin (begin
(if (path-string? path25_0) (if (path-string? path29_0)
(void) (void)
(raise-argument-error (raise-argument-error
'with-input-from-file 'with-input-from-file
"path-string?" "path-string?"
path25_0)) path29_0))
(begin (begin
(if (if (procedure? proc26_0) (if (if (procedure? proc30_0)
(procedure-arity-includes? proc26_0 0) (procedure-arity-includes? proc30_0 0)
#f) #f)
(void) (void)
(raise-argument-error (raise-argument-error
'with-input-from-file 'with-input-from-file
"(procedure-arity-includes/c 0)" "(procedure-arity-includes/c 0)"
proc26_0)) proc30_0))
(let ((i_0 (1/open-input-file path25_0 mode_0))) (let ((i_0 (1/open-input-file path29_0 mode_0)))
(with-continuation-mark* (with-continuation-mark*
authentic authentic
parameterization-key parameterization-key
@ -26327,54 +26392,70 @@
i_0) i_0)
(dynamic-wind (dynamic-wind
void void
proc26_0 proc30_0
(lambda () (1/close-input-port i_0))))))))))))) (lambda () (1/close-input-port i_0)))))))))))))
(|#%name| (|#%name|
with-input-from-file with-input-from-file
(case-lambda (case-lambda
((path_0 proc_0) ((path_0 proc_0)
(begin (with-input-from-file_0 path_0 proc_0 unsafe-undefined))) (begin (with-input-from-file_0 path_0 proc_0 unsafe-undefined)))
((path_0 proc_0 mode24_0) ((path_0 proc_0 mode28_0)
(with-input-from-file_0 path_0 proc_0 mode24_0)))))) (with-input-from-file_0 path_0 proc_0 mode28_0))))))
(define 1/with-output-to-file (define 1/with-output-to-file
(let ((with-output-to-file_0 (let ((with-output-to-file_0
(|#%name| (|#%name|
with-output-to-file with-output-to-file
(lambda (path29_0 proc30_0 mode127_0 mode228_0) (lambda (path34_0 proc35_0 mode131_0 mode232_0 perms33_0)
(begin (begin
(let ((mode1_0 (let ((mode1_0
(if (eq? mode127_0 unsafe-undefined) none$1 mode127_0))) (if (eq? mode131_0 unsafe-undefined) none$1 mode131_0)))
(let ((mode2_0 (let ((mode2_0
(if (eq? mode228_0 unsafe-undefined) none$1 mode228_0))) (if (eq? mode232_0 unsafe-undefined) none$1 mode232_0)))
(begin (let ((perms_0
(if (path-string? path29_0) (if (eq? perms33_0 unsafe-undefined) 438 perms33_0)))
(void)
(raise-argument-error
'with-output-to-file
"path-string?"
path29_0))
(begin (begin
(if (if (procedure? proc30_0) (if (path-string? path34_0)
(procedure-arity-includes? proc30_0 0)
#f)
(void) (void)
(raise-argument-error (raise-argument-error
'with-output-to-file 'with-output-to-file
"(procedure-arity-includes/c 0)" "path-string?"
proc30_0)) path34_0))
(let ((o_0 (begin
(1/open-output-file path29_0 mode1_0 mode2_0))) (if (if (procedure? proc35_0)
(with-continuation-mark* (procedure-arity-includes? proc35_0 0)
authentic #f)
parameterization-key (void)
(extend-parameterization (raise-argument-error
(continuation-mark-set-first #f parameterization-key) 'with-output-to-file
1/current-output-port "(procedure-arity-includes/c 0)"
o_0) proc35_0))
(dynamic-wind (begin
void (if (permissions? perms_0)
proc30_0 (void)
(lambda () (1/close-output-port o_0)))))))))))))) (raise-argument-error
'with-output-to-file
permissions-desc
perms_0))
(let ((o_0
(1/open-output-file
path34_0
mode1_0
mode2_0
perms_0)))
(with-continuation-mark*
authentic
parameterization-key
(extend-parameterization
(continuation-mark-set-first
#f
parameterization-key)
1/current-output-port
o_0)
(dynamic-wind
void
proc35_0
(lambda ()
(1/close-output-port o_0))))))))))))))))
(|#%name| (|#%name|
with-output-to-file with-output-to-file
(case-lambda (case-lambda
@ -26384,11 +26465,24 @@
path_0 path_0
proc_0 proc_0
unsafe-undefined unsafe-undefined
unsafe-undefined
unsafe-undefined))) unsafe-undefined)))
((path_0 proc_0 mode1_0 mode228_0) ((path_0 proc_0 mode1_0 mode2_0 perms33_0)
(with-output-to-file_0 path_0 proc_0 mode1_0 mode228_0)) (with-output-to-file_0 path_0 proc_0 mode1_0 mode2_0 perms33_0))
((path_0 proc_0 mode127_0) ((path_0 proc_0 mode1_0 mode232_0)
(with-output-to-file_0 path_0 proc_0 mode127_0 unsafe-undefined)))))) (with-output-to-file_0
path_0
proc_0
mode1_0
mode232_0
unsafe-undefined))
((path_0 proc_0 mode131_0)
(with-output-to-file_0
path_0
proc_0
mode131_0
unsafe-undefined
unsafe-undefined))))))
(define path-or-fd-identity.1 (define path-or-fd-identity.1
(|#%name| (|#%name|
path-or-fd-identity path-or-fd-identity
@ -34259,11 +34353,11 @@
'subprocess 'subprocess
"(or/c (and/c output-port? file-stream-port?) #f 'stdout)" "(or/c (and/c output-port? file-stream-port?) #f 'stdout)"
stderr_0)) stderr_0))
(let ((lr1323 unsafe-undefined) (let ((lr1324 unsafe-undefined)
(group_0 unsafe-undefined) (group_0 unsafe-undefined)
(command_0 unsafe-undefined) (command_0 unsafe-undefined)
(exact/args_0 unsafe-undefined)) (exact/args_0 unsafe-undefined))
(set! lr1323 (set! lr1324
(call-with-values (call-with-values
(lambda () (lambda ()
(if (path-string? group/command_0) (if (path-string? group/command_0)
@ -34318,9 +34412,9 @@
((group_1 command_1 exact/args_1) ((group_1 command_1 exact/args_1)
(vector group_1 command_1 exact/args_1)) (vector group_1 command_1 exact/args_1))
(args (raise-binding-result-arity-error 3 args))))) (args (raise-binding-result-arity-error 3 args)))))
(set! group_0 (unsafe-vector*-ref lr1323 0)) (set! group_0 (unsafe-vector*-ref lr1324 0))
(set! command_0 (unsafe-vector*-ref lr1323 1)) (set! command_0 (unsafe-vector*-ref lr1324 1))
(set! exact/args_0 (unsafe-vector*-ref lr1323 2)) (set! exact/args_0 (unsafe-vector*-ref lr1324 2))
(call-with-values (call-with-values
(lambda () (lambda ()
(if (if (pair? exact/args_0) (if (if (pair? exact/args_0)

View File

@ -54,8 +54,13 @@
(port-count-lines! p)) (port-count-lines! p))
p) p)
(define (do-open-output-file #:plus-input? [plus-input? #f] who path mode1 mode2) (define (permissions? perms)
(and (exact-integer? perms) (<= 0 perms 65535)))
(define permissions-desc "(integer-in 0 65535)")
(define (do-open-output-file #:plus-input? [plus-input? #f] who path mode1 mode2 perms)
(check who path-string? path) (check who path-string? path)
(check who permissions? #:contract permissions-desc perms)
(define (mode->flags mode) (define (mode->flags mode)
(case mode (case mode
[(text) RKTIO_OPEN_TEXT] [(text) RKTIO_OPEN_TEXT]
@ -87,7 +92,7 @@
(mode->flags mode1) (mode->flags mode1)
(mode->flags mode2))) (mode->flags mode2)))
(define fd0 (define fd0
(rktio_open rktio host-path flags)) (rktio_open_with_create_permissions rktio host-path flags perms))
(define fd (define fd
(cond (cond
[(not (rktio-error? fd0)) fd0] [(not (rktio-error? fd0)) fd0]
@ -135,11 +140,13 @@
(values ip op) (values ip op)
op)) op))
(define/who (open-output-file path [mode1 none] [mode2 none]) (define DEFAULT-CREATE-PERMS #o666)
(do-open-output-file who path mode1 mode2))
(define/who (open-input-output-file path [mode1 none] [mode2 none]) (define/who (open-output-file path [mode1 none] [mode2 none] [perms DEFAULT-CREATE-PERMS])
(do-open-output-file #:plus-input? #t who path mode1 mode2)) (do-open-output-file who path mode1 mode2 perms))
(define/who (open-input-output-file path [mode1 none] [mode2 none] [perms DEFAULT-CREATE-PERMS])
(do-open-output-file #:plus-input? #t who path mode1 mode2 perms))
(define/who (call-with-input-file path proc [mode none]) (define/who (call-with-input-file path proc [mode none])
(check who path-string? path) (check who path-string? path)
@ -149,10 +156,11 @@
(proc i) (proc i)
(close-input-port i))) (close-input-port i)))
(define/who (call-with-output-file path proc [mode1 none] [mode2 none]) (define/who (call-with-output-file path proc [mode1 none] [mode2 none] [perms DEFAULT-CREATE-PERMS])
(check who path-string? path) (check who path-string? path)
(check who (procedure-arity-includes/c 1) proc) (check who (procedure-arity-includes/c 1) proc)
(define o (open-output-file path mode1 mode2)) (check who permissions? #:contract permissions-desc perms)
(define o (open-output-file path mode1 mode2 perms))
(begin0 (begin0
(proc o) (proc o)
(close-output-port o))) (close-output-port o)))
@ -168,10 +176,11 @@
(lambda () (lambda ()
(close-input-port i))))) (close-input-port i)))))
(define/who (with-output-to-file path proc [mode1 none] [mode2 none]) (define/who (with-output-to-file path proc [mode1 none] [mode2 none] [perms DEFAULT-CREATE-PERMS])
(check who path-string? path) (check who path-string? path)
(check who (procedure-arity-includes/c 0) proc) (check who (procedure-arity-includes/c 0) proc)
(define o (open-output-file path mode1 mode2)) (check who permissions? #:contract permissions-desc perms)
(define o (open-output-file path mode1 mode2 perms))
(parameterize ([current-output-port o]) (parameterize ([current-output-port o])
(dynamic-wind (dynamic-wind
void void

View File

@ -88,6 +88,8 @@
[(:seq (:or #\_ (:/ #\A #\Z #\a #\z)) [(:seq (:or #\_ (:/ #\A #\Z #\a #\z))
(:* (:or #\_ (:/ #\A #\Z #\a #\z #\0 #\9)))) (:* (:or #\_ (:/ #\A #\Z #\a #\z #\0 #\9))))
(token-ID (string->symbol lexeme))] (token-ID (string->symbol lexeme))]
[(:seq (:? "-") "0" (:+ (:/ "0" "7")))
(token-NUM (string->number lexeme 8))]
[(:seq (:? "-") (:+ (:/ "0" "9"))) [(:seq (:? "-") (:+ (:/ "0" "9")))
(token-NUM (string->number lexeme))] (token-NUM (string->number lexeme))]
[(:seq "0x" (:+ (:/ "0" "9") (:/ "A" "F") (:/ "a" "f"))) [(:seq "0x" (:+ (:/ "0" "9") (:/ "A" "F") (:/ "a" "f")))

View File

@ -15,6 +15,7 @@ rktio_fd_is_text_converted
rktio_fd_is_pending_open rktio_fd_is_pending_open
rktio_fd_modes rktio_fd_modes
rktio_open rktio_open
rktio_open_with_create_permissions
rktio_close rktio_close
rktio_close_noerr rktio_close_noerr
rktio_dup rktio_dup

View File

@ -227,6 +227,16 @@ RKTIO_EXTERN rktio_fd_t *rktio_open(rktio_t *rktio, rktio_const_string_t src, in
without `RKTIO_OPEN_READ`, then the result may be a file descriptor without `RKTIO_OPEN_READ`, then the result may be a file descriptor
in pending-open mode until the read end is opened. */ in pending-open mode until the read end is opened. */
RKTIO_EXTERN rktio_fd_t *rktio_open_with_create_permissions(rktio_t *rktio,
rktio_const_string_t src,
int modes, int perm_bits);
/* Like `rktio_open`, but accepts permission bits that are used if the
file is created (which is only relevant if `modes` includes
`RKTIO_OPEN_WRITE`). On Unix, perm_bits are adjusted by a umask.
Otherwise, permission bits are treated in the same way as
by `rktio_set_file_or_directory_permissions`. */
#define RKTIO_DEFAULT_PERM_BITS 0666
RKTIO_EXTERN rktio_ok_t rktio_close(rktio_t *rktio, rktio_fd_t *fd); RKTIO_EXTERN rktio_ok_t rktio_close(rktio_t *rktio, rktio_fd_t *fd);
/* Can report `RKTIO_ERROR_EXISTS` in place of system error, /* Can report `RKTIO_ERROR_EXISTS` in place of system error,
and can report `RKTIO_ERROR_UNSUPPORTED_TEXT_MODE` on Windows. and can report `RKTIO_ERROR_UNSUPPORTED_TEXT_MODE` on Windows.

View File

@ -15,6 +15,7 @@ Sforeign_symbol("rktio_fd_is_text_converted", (void *)rktio_fd_is_text_converted
Sforeign_symbol("rktio_fd_is_pending_open", (void *)rktio_fd_is_pending_open); Sforeign_symbol("rktio_fd_is_pending_open", (void *)rktio_fd_is_pending_open);
Sforeign_symbol("rktio_fd_modes", (void *)rktio_fd_modes); Sforeign_symbol("rktio_fd_modes", (void *)rktio_fd_modes);
Sforeign_symbol("rktio_open", (void *)rktio_open); Sforeign_symbol("rktio_open", (void *)rktio_open);
Sforeign_symbol("rktio_open_with_create_permissions", (void *)rktio_open_with_create_permissions);
Sforeign_symbol("rktio_close", (void *)rktio_close); Sforeign_symbol("rktio_close", (void *)rktio_close);
Sforeign_symbol("rktio_close_noerr", (void *)rktio_close_noerr); Sforeign_symbol("rktio_close_noerr", (void *)rktio_close_noerr);
Sforeign_symbol("rktio_dup", (void *)rktio_dup); Sforeign_symbol("rktio_dup", (void *)rktio_dup);

View File

@ -15,6 +15,7 @@
(define-constant RKTIO_OPEN_NOT_DIR (<< 1 12)) (define-constant RKTIO_OPEN_NOT_DIR (<< 1 12))
(define-constant RKTIO_OPEN_INIT (<< 1 13)) (define-constant RKTIO_OPEN_INIT (<< 1 13))
(define-constant RKTIO_OPEN_OWN (<< 1 14)) (define-constant RKTIO_OPEN_OWN (<< 1 14))
(define-constant RKTIO_DEFAULT_PERM_BITS 438)
(define-constant RKTIO_STDIN 0) (define-constant RKTIO_STDIN 0)
(define-constant RKTIO_STDOUT 1) (define-constant RKTIO_STDOUT 1)
(define-constant RKTIO_STDERR 2) (define-constant RKTIO_STDERR 2)
@ -278,6 +279,15 @@
(ref rktio_fd_t) (ref rktio_fd_t)
rktio_open rktio_open
(((ref rktio_t) rktio) (rktio_const_string_t src) (int modes))) (((ref rktio_t) rktio) (rktio_const_string_t src) (int modes)))
(define-function/errno
NULL
()
(ref rktio_fd_t)
rktio_open_with_create_permissions
(((ref rktio_t) rktio)
(rktio_const_string_t src)
(int modes)
(int perm_bits)))
(define-function/errno (define-function/errno
#f #f
() ()

View File

@ -20,7 +20,7 @@ static rktio_fd_t *finish_unix_fd_creation(rktio_t *rktio, int fd, int modes, rk
#endif #endif
#ifdef RKTIO_USE_PENDING_OPEN #ifdef RKTIO_USE_PENDING_OPEN
static rktio_fd_t *open_via_thread(rktio_t *rktio, const char *filename, int modes, int flags); static rktio_fd_t *open_via_thread(rktio_t *rktio, const char *filename, int modes, int flags, int perm_bits);
static int do_pending_open_release(rktio_t *rktio, struct open_in_thread_t *data, int close_fd); static int do_pending_open_release(rktio_t *rktio, struct open_in_thread_t *data, int close_fd);
#endif #endif
@ -113,7 +113,7 @@ static rktio_fd_t *open_read(rktio_t *rktio, const char *filename, int modes)
#endif #endif
} }
static rktio_fd_t *open_write(rktio_t *rktio, const char *filename, int modes) static rktio_fd_t *open_write(rktio_t *rktio, const char *filename, int modes, int perm_bits)
{ {
#ifdef RKTIO_SYSTEM_UNIX #ifdef RKTIO_SYSTEM_UNIX
int fd; int fd;
@ -130,19 +130,19 @@ static rktio_fd_t *open_write(rktio_t *rktio, const char *filename, int modes)
flags |= O_EXCL; flags |= O_EXCL;
do { do {
fd = open(filename, flags | RKTIO_NONBLOCKING | RKTIO_BINARY, 0666); fd = open(filename, flags | RKTIO_NONBLOCKING | RKTIO_BINARY, perm_bits);
} while ((fd == -1) && (errno == EINTR)); } while ((fd == -1) && (errno == EINTR));
if (errno == ENXIO) { if (errno == ENXIO) {
/* FIFO with no reader? */ /* FIFO with no reader? */
#ifdef RKTIO_USE_PENDING_OPEN #ifdef RKTIO_USE_PENDING_OPEN
return open_via_thread(rktio, filename, modes, flags | RKTIO_BINARY); return open_via_thread(rktio, filename, modes, flags | RKTIO_BINARY, perm_bits);
#else #else
/* Try opening in RW mode: */ /* Try opening in RW mode: */
flags -= O_WRONLY; flags -= O_WRONLY;
flags |= O_RDWR; flags |= O_RDWR;
do { do {
fd = open(filename, flags | RKTIO_NONBLOCKING | RKTIO_BINARY, 0666); fd = open(filename, flags | RKTIO_NONBLOCKING | RKTIO_BINARY, perm_bits);
} while ((fd == -1) && (errno == EINTR)); } while ((fd == -1) && (errno == EINTR));
#endif #endif
} }
@ -173,7 +173,10 @@ static rktio_fd_t *open_write(rktio_t *rktio, const char *filename, int modes)
FILE_SHARE_READ | FILE_SHARE_WRITE | FILE_SHARE_DELETE, FILE_SHARE_READ | FILE_SHARE_WRITE | FILE_SHARE_DELETE,
NULL, NULL,
hmode, hmode,
FILE_FLAG_BACKUP_SEMANTICS, /* lets us detect directories in NT */ (FILE_FLAG_BACKUP_SEMANTICS /* lets us detect directories in NT */
| ((perm_bits & RKTIO_PERMISSION_WRITE)
? 0
: FILE_ATTRIBUTE_READONLY)),
NULL); NULL);
if (fd == INVALID_HANDLE_VALUE) { if (fd == INVALID_HANDLE_VALUE) {
@ -268,14 +271,19 @@ static rktio_fd_t *finish_unix_fd_creation(rktio_t *rktio, int fd, int modes, rk
} }
#endif #endif
rktio_fd_t *rktio_open(rktio_t *rktio, const char *filename, int modes) rktio_fd_t *rktio_open_with_create_permissions(rktio_t *rktio, const char *filename, int modes, int perm_bits)
{ {
if (modes & RKTIO_OPEN_WRITE) if (modes & RKTIO_OPEN_WRITE)
return open_write(rktio, filename, modes); return open_write(rktio, filename, modes, perm_bits);
else else
return open_read(rktio, filename, modes); return open_read(rktio, filename, modes);
} }
rktio_fd_t *rktio_open(rktio_t *rktio, const char *filename, int modes)
{
return rktio_open_with_create_permissions(rktio, filename, modes, RKTIO_DEFAULT_PERM_BITS);
}
/*========================================================================*/ /*========================================================================*/
/* File positions */ /* File positions */
/*========================================================================*/ /*========================================================================*/
@ -435,6 +443,7 @@ typedef struct open_in_thread_t {
pthread_cond_t ready_cond; /* wait until helper thread is ready (including cleanup) */ pthread_cond_t ready_cond; /* wait until helper thread is ready (including cleanup) */
char *filename; char *filename;
int flags; int flags;
int perm_bits;
int done; int done;
int fd; int fd;
int errval; int errval;
@ -500,7 +509,7 @@ static void *do_open_in_thread(void *_data)
canceled before `open` returns, but not both (otherwise there canceled before `open` returns, but not both (otherwise there
could be a space leak) */ could be a space leak) */
do { do {
fd = open(data->filename, data->flags, 0666); fd = open(data->filename, data->flags, data->perm_bits);
} while ((fd == -1) && (errno == EINTR)); } while ((fd == -1) && (errno == EINTR));
pthread_setcanceltype(PTHREAD_CANCEL_DISABLE, NULL); pthread_setcanceltype(PTHREAD_CANCEL_DISABLE, NULL);
@ -519,7 +528,7 @@ static void *do_open_in_thread(void *_data)
return NULL; return NULL;
} }
static rktio_fd_t *open_via_thread(rktio_t *rktio, const char *filename, int modes, int flags) static rktio_fd_t *open_via_thread(rktio_t *rktio, const char *filename, int modes, int flags, int perm_bits)
{ {
open_in_thread_t *data; open_in_thread_t *data;
@ -529,6 +538,7 @@ static rktio_fd_t *open_via_thread(rktio_t *rktio, const char *filename, int mod
data->filename = strdup(filename); data->filename = strdup(filename);
data->flags = flags; data->flags = flags;
data->perm_bits = perm_bits;
pthread_mutex_init(&data->lock, NULL); pthread_mutex_init(&data->lock, NULL);
pthread_cond_init(&data->ready_cond, NULL); pthread_cond_init(&data->ready_cond, NULL);

View File

@ -16,7 +16,7 @@
#define MZSCHEME_VERSION_X 8 #define MZSCHEME_VERSION_X 8
#define MZSCHEME_VERSION_Y 1 #define MZSCHEME_VERSION_Y 1
#define MZSCHEME_VERSION_Z 0 #define MZSCHEME_VERSION_Z 0
#define MZSCHEME_VERSION_W 2 #define MZSCHEME_VERSION_W 3
/* A level of indirection makes `#` work as needed: */ /* A level of indirection makes `#` work as needed: */
#define AS_a_STR_HELPER(x) #x #define AS_a_STR_HELPER(x) #x