From 09480c86e8a73602a8c836c9ee55263d3889a3b4 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 28 Apr 2021 13:12:14 -0600 Subject: [PATCH] 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 --- pkgs/base/info.rkt | 2 +- .../scribblings/reference/file-ports.scrbl | 44 +- pkgs/racket-test-core/tests/racket/file.rktl | 36 + racket/collects/racket/private/kw-file.rkt | 40 +- racket/src/bc/src/port.c | 142 ++-- racket/src/bc/src/portfun.c | 8 +- racket/src/bc/src/startup.inc | 16 +- racket/src/cs/schemified/expander.scm | 38 +- racket/src/cs/schemified/io.scm | 616 ++++++++++-------- racket/src/io/port/file-port.rkt | 29 +- racket/src/rktio/parse.rkt | 2 + racket/src/rktio/rktio.def | 1 + racket/src/rktio/rktio.h | 10 + racket/src/rktio/rktio.inc | 1 + racket/src/rktio/rktio.rktl | 10 + racket/src/rktio/rktio_file.c | 32 +- racket/src/version/racket_version.h | 2 +- 17 files changed, 628 insertions(+), 401 deletions(-) diff --git a/pkgs/base/info.rkt b/pkgs/base/info.rkt index 888ca75321..4aa1353dde 100644 --- a/pkgs/base/info.rkt +++ b/pkgs/base/info.rkt @@ -14,7 +14,7 @@ ;; In the Racket source repo, this version should change only when ;; "racket_version.h" changes: -(define version "8.1.0.2") +(define version "8.1.0.3") (define deps `("racket-lib" ["racket" #:version ,version])) diff --git a/pkgs/racket-doc/scribblings/reference/file-ports.scrbl b/pkgs/racket-doc/scribblings/reference/file-ports.scrbl index 7b97e2db07..64cce3452d 100644 --- a/pkgs/racket-doc/scribblings/reference/file-ports.scrbl +++ b/pkgs/racket-doc/scribblings/reference/file-ports.scrbl @@ -33,6 +33,8 @@ "") +@(define default-permissions @racketvalfont{#o666}) + @title[#:tag "file-ports"]{File Ports} 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] [#:exists exists-flag (or/c 'error 'append 'update 'can-update 'replace 'truncate - 'must-truncate 'truncate/replace) 'error]) + 'must-truncate 'truncate/replace) 'error] + [#:permissions permissions (integer-in 0 65535) @#,default-permissions]) output-port?]{ 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 might be a device that is connected through the filesystem, such as @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].} #: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 - reader.}]} + reader.} + #:changed "8.1.0.3" @elem{Added the @racket[#:permissions] argument.}]} @defproc[(open-input-output-file [path path-string?] [#:mode mode-flag (or/c 'binary 'text) 'binary] [#: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?)]{ Like @racket[open-output-file], but producing two values: an input @@ -258,10 +273,11 @@ when @racket[proc] returns. [proc (output-port? . -> . any)] [#:mode mode-flag (or/c 'binary 'text) 'binary] [#: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]{ 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]. @file-examples[ @@ -271,7 +287,9 @@ Analogous to @racket[call-with-input-file], but passing @racket[path], (call-with-input-file some-file (lambda (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?] [proc (input-port? . -> . any)] @@ -286,12 +304,15 @@ return, a continuation application, or a prompt-based abort.} [proc (output-port? . -> . any)] [#:mode mode-flag (or/c 'binary 'text) 'binary] [#: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]{ Like @racket[call-with-output-file], but the newly opened port is closed whenever control escapes the dynamic extent of the @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?] [thunk (-> any)] @@ -313,7 +334,8 @@ the current input port (see @racket[current-input-port]) using [thunk (-> any)] [#:mode mode-flag (or/c 'binary 'text) 'binary] [#: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]{ Like @racket[call-with-output-file*], but instead of passing the newly 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"))) (with-input-from-file some-file (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?] diff --git a/pkgs/racket-test-core/tests/racket/file.rktl b/pkgs/racket-test-core/tests/racket/file.rktl index 2d43c888e9..f84fe4d0b6 100644 --- a/pkgs/racket-test-core/tests/racket/file.rktl +++ b/pkgs/racket-test-core/tests/racket/file.rktl @@ -2441,6 +2441,42 @@ (delete-file file) (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)]) diff --git a/racket/collects/racket/private/kw-file.rkt b/racket/collects/racket/private/kw-file.rkt index d20c972548..81364be22f 100644 --- a/racket/collects/racket/private/kw-file.rkt +++ b/racket/collects/racket/private/kw-file.rkt @@ -24,6 +24,11 @@ (define binary-or-text-desc "(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]) (unless (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))) (define (open-output-file path #:mode [mode 'binary] - #:exists [exists 'error]) + #:exists [exists 'error] + #:permissions [perms DEFAULT-CREATE-PERMS]) (unless (path-string? path) (raise-argument-error 'open-output-file "path-string?" path)) (unless (memq mode '(binary text)) (raise-argument-error 'open-output-file binary-or-text-desc mode)) (unless (memq exists exists-syms) (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] - #:exists [exists 'error]) + #:exists [exists 'error] + #:permissions [perms DEFAULT-CREATE-PERMS]) (unless (path-string? path) (raise-argument-error 'open-input-output-file "path-string?" path)) (unless (memq mode '(binary text)) (raise-argument-error 'open-input-output-file binary-or-text-desc mode)) (unless (memq exists exists-syms) (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]) (unless (path-string? path) @@ -63,7 +74,8 @@ (define (call-with-output-file path proc #:mode [mode 'binary] - #:exists [exists 'error]) + #:exists [exists 'error] + #:permissions [perms DEFAULT-CREATE-PERMS]) (unless (path-string? path) (raise-argument-error 'call-with-output-file "path-string?" path)) (unless (and (procedure? proc) @@ -73,7 +85,9 @@ (raise-argument-error 'call-with-output-file binary-or-text-desc mode)) (unless (memq exists exists-syms) (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]) (unless (path-string? path) @@ -87,7 +101,8 @@ (define (with-output-to-file path proc #:mode [mode 'binary] - #:exists [exists 'error]) + #:exists [exists 'error] + #:permissions [perms DEFAULT-CREATE-PERMS]) (unless (path-string? path) (raise-argument-error 'with-output-to-file "path-string?" path)) (unless (and (procedure? proc) @@ -97,7 +112,9 @@ (raise-argument-error 'with-output-to-file binary-or-text-desc mode)) (unless (memq exists exists-syms) (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]) (unless (path-string? path) @@ -115,7 +132,8 @@ (define (call-with-output-file* path proc #:mode [mode 'binary] - #:exists [exists 'error]) + #:exists [exists 'error] + #:permissions [perms DEFAULT-CREATE-PERMS]) (unless (path-string? path) (raise-argument-error 'call-with-output-file* "path-string?" path)) (unless (and (procedure? proc) @@ -125,7 +143,9 @@ (raise-argument-error 'call-with-output-file* binary-or-text-desc mode)) (unless (memq exists exists-syms) (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 void (lambda () (proc p)) diff --git a/racket/src/bc/src/port.c b/racket/src/bc/src/port.c index eb6a25ed04..7b8c06c359 100644 --- a/racket/src/bc/src/port.c +++ b/racket/src/bc/src/port.c @@ -3784,6 +3784,7 @@ scheme_do_open_output_file(char *name, int offset, int argc, Scheme_Object *argv char *filename; char mode[4]; int typepos; + int perms; rktio_fd_t *fd; 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[3] = 0; typepos = 1; + perms = RKTIO_DEFAULT_PERM_BITS; if (!SCHEME_PATH_STRINGP(argv[0])) scheme_wrong_contract(name, "path-string?", 0, argc, argv); for (i = 1 + offset; argc > i; i++) { - if (!SCHEME_SYMBOLP(argv[i])) - scheme_wrong_contract(name, "symbol?", i, argc, argv); - - if (SAME_OBJ(argv[i], append_symbol)) { - 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++; + if (SCHEME_INTP(argv[i]) + && (SCHEME_INT_VAL(argv[i]) >= 0) + && (SCHEME_INT_VAL(argv[i]) <= 65535)) { + perms = SCHEME_INT_VAL(argv[i]); } else { - char *astr; - intptr_t alen; + if (!SCHEME_SYMBOLP(argv[i])) + scheme_wrong_contract(name, "(or/c symbol? (integer-in 0 65535))", i, argc, argv); - astr = scheme_make_args_string("other ", i, argc, argv, &alen); - scheme_raise_exn(MZEXN_FAIL_CONTRACT, - "%s: bad mode symbol\n" - " given symbol: : %s%s", name, - scheme_make_provided_string(argv[i], 1, NULL), - astr, alen); - } + if (SAME_OBJ(argv[i], append_symbol)) { + 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 { + char *astr; + intptr_t alen; - if (m_set > 1 || e_set > 1) { - char *astr; - intptr_t alen; + astr = scheme_make_args_string("other ", i, argc, argv, &alen); + scheme_raise_exn(MZEXN_FAIL_CONTRACT, + "%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); - scheme_raise_exn(MZEXN_FAIL_CONTRACT, - "%s: conflicting or redundant file modes given%t", - name, - astr, alen); + if (m_set > 1 || e_set > 1) { + char *astr; + intptr_t 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"); 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 | (and_read ? RKTIO_OPEN_READ : 0) - | ((mode[1] == 't') ? RKTIO_OPEN_TEXT : 0))); + | ((mode[1] == 't') ? RKTIO_OPEN_TEXT : 0)), + perms); if (!fd && try_replace diff --git a/racket/src/bc/src/portfun.c b/racket/src/bc/src/portfun.c index 99cbe53301..cc26226e76 100644 --- a/racket/src/bc/src/portfun.c +++ b/racket/src/bc/src/portfun.c @@ -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-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-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-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-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-output-port", close_output_port, 1, 1, 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_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("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("make-pipe", sch_pipe, 0, 3, 2, 2, env); ADD_PRIM_W_ARITY2("port-next-location", port_next_location, 1, 1, 3, 3, env); diff --git a/racket/src/bc/src/startup.inc b/racket/src/bc/src/startup.inc index dc7ebd35ab..0603731823 100644 --- a/racket/src/bc/src/startup.inc +++ b/racket/src/bc/src/startup.inc @@ -2461,12 +2461,12 @@ static const char *startup_source = "(open-input-file path_0 mode_0(if for-module?_0 'module 'none))))))))))" "(define-values" "(with-input-from-file.1)" -"(lambda(mode31_0 path33_0 proc34_0)" +"(lambda(mode37_0 path39_0 proc40_0)" "(begin" " 'with-input-from-file" -"(let-values(((path_0) path33_0))" -"(let-values(((proc_0) proc34_0))" -"(let-values(((mode_0) mode31_0))" +"(let-values(((path_0) path39_0))" +"(let-values(((proc_0) proc40_0))" +"(let-values(((mode_0) mode37_0))" "(let-values()" "(begin" "(if(path-string? path_0)" @@ -2481,12 +2481,12 @@ static const char *startup_source = "(with-input-from-file path_0 proc_0 mode_0)))))))))" "(define-values" "(call-with-input-file*.1)" -"(lambda(mode43_0 path45_0 proc46_0)" +"(lambda(mode51_0 path53_0 proc54_0)" "(begin" " 'call-with-input-file*" -"(let-values(((path_0) path45_0))" -"(let-values(((proc_0) proc46_0))" -"(let-values(((mode_0) mode43_0))" +"(let-values(((path_0) path53_0))" +"(let-values(((proc_0) proc54_0))" +"(let-values(((mode_0) mode51_0))" "(let-values()" "(begin" "(if(path-string? path_0)" diff --git a/racket/src/cs/schemified/expander.scm b/racket/src/cs/schemified/expander.scm index 1caf7cf0d3..c99fd4d90f 100644 --- a/racket/src/cs/schemified/expander.scm +++ b/racket/src/cs/schemified/expander.scm @@ -3431,57 +3431,57 @@ (define with-input-from-file.1 (|#%name| with-input-from-file - (lambda (mode31_0 path33_0 proc34_0) + (lambda (mode37_0 path39_0 proc40_0) (begin (begin - (if (path-string? path33_0) + (if (path-string? path39_0) (void) (raise-argument-error 'with-input-from-file "path-string?" - path33_0)) - (if (if (procedure? proc34_0) - (procedure-arity-includes? proc34_0 0) + path39_0)) + (if (if (procedure? proc40_0) + (procedure-arity-includes? proc40_0 0) #f) (void) - (raise-argument-error 'with-input-from-file "(-> any)" proc34_0)) - (if (memq mode31_0 '(binary text)) + (raise-argument-error 'with-input-from-file "(-> any)" proc40_0)) + (if (memq mode37_0 '(binary text)) (void) (raise-argument-error 'with-input-from-file binary-or-text-desc - mode31_0)) - (with-input-from-file path33_0 proc34_0 mode31_0)))))) + mode37_0)) + (with-input-from-file path39_0 proc40_0 mode37_0)))))) (define call-with-input-file*.1 (|#%name| call-with-input-file* - (lambda (mode43_0 path45_0 proc46_0) + (lambda (mode51_0 path53_0 proc54_0) (begin (begin - (if (path-string? path45_0) + (if (path-string? path53_0) (void) (raise-argument-error 'call-with-input-file* "path-string?" - path45_0)) - (if (if (procedure? proc46_0) - (procedure-arity-includes? proc46_0 1) + path53_0)) + (if (if (procedure? proc54_0) + (procedure-arity-includes? proc54_0 1) #f) (void) (raise-argument-error 'call-with-input-file* "(input-port? . -> . any)" - proc46_0)) - (if (memq mode43_0 '(binary text)) + proc54_0)) + (if (memq mode51_0 '(binary text)) (void) (raise-argument-error 'call-with-input-file* binary-or-text-desc - mode43_0)) - (let ((p_0 (open-input-file path45_0 mode43_0))) + mode51_0)) + (let ((p_0 (open-input-file path53_0 mode51_0))) (dynamic-wind void - (lambda () (|#%app| proc46_0 p_0)) + (lambda () (|#%app| proc54_0 p_0)) (lambda () (close-input-port p_0))))))))) (define print-value-columns (make-parameter diff --git a/racket/src/cs/schemified/io.scm b/racket/src/cs/schemified/io.scm index 27ec9c04a7..e7bc5730ab 100644 --- a/racket/src/cs/schemified/io.scm +++ b/racket/src/cs/schemified/io.scm @@ -2964,6 +2964,8 @@ (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_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_noerr (begin-unsafe (hash-ref rktio-table 'rktio_close_noerr))) @@ -25981,12 +25983,12 @@ (1/format app_0 (host-> host-path_0))))) (void)) (let ((p_0 - (let ((temp33_0 (host-> host-path_0))) + (let ((temp38_0 (host-> host-path_0))) (open-input-fd.1 unsafe-undefined unsafe-undefined fd_0 - temp33_0)))) + temp38_0)))) (begin (unsafe-end-atomic) (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 mode11_0) (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 (|#%name| 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 (if (path-string? path7_0) (void) (raise-argument-error who6_0 "path-string?" path7_0)) - (let ((mode->flags_0 - (|#%name| - mode->flags - (lambda (mode_0) - (begin - (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 + (begin + (if (permissions? perms10_0) + (void) + (raise-argument-error who6_0 permissions-desc perms10_0)) + (let ((mode->flags_0 (|#%name| - mode? - (lambda (v_0) + mode->flags + (lambda (mode_0) (begin - (let ((or-part_0 (eq? mode18_0 v_0))) - (if or-part_0 or-part_0 (eq? mode29_0 v_0)))))))) - (let ((host-path_0 - (->host - path7_0 - who6_0 - (let ((app_0 - (if (let ((or-part_0 (mode?_0 'replace))) - (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 - (unsafe-start-atomic) + (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| + mode? + (lambda (v_0) + (begin + (let ((or-part_0 (eq? mode18_0 v_0))) + (if or-part_0 or-part_0 (eq? mode29_0 v_0)))))))) + (let ((host-path_0 + (->host + path7_0 + who6_0 + (let ((app_0 + (if (let ((or-part_0 (mode?_0 'replace))) + (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 - (check-current-custodian who6_0) - (let ((flags_0 - (let ((app_0 (if plus-input?4_0 1 0))) - (let ((app_1 (mode->flags_0 mode18_0))) - (+ 2 app_0 app_1 (mode->flags_0 mode29_0)))))) - (let ((fd0_0 - (|#%app| - rktio_open - (unsafe-place-local-ref cell.1) - host-path_0 - flags_0))) - (let ((fd_0 - (if (not (vector? fd0_0)) - fd0_0 - (if (if (let ((or-part_0 - (racket-error? fd0_0 4))) + (unsafe-start-atomic) + (begin + (check-current-custodian who6_0) + (let ((flags_0 + (let ((app_0 (if plus-input?4_0 1 0))) + (let ((app_1 (mode->flags_0 mode18_0))) + (+ 2 app_0 app_1 (mode->flags_0 mode29_0)))))) + (let ((fd0_0 + (|#%app| + rktio_open_with_create_permissions + (unsafe-place-local-ref cell.1) + host-path_0 + flags_0 + perms10_0))) + (let ((fd_0 + (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 or-part_0 - (racket-error? fd0_0 5))) - (let ((or-part_0 (mode?_0 'replace))) - (if or-part_0 - or-part_0 - (mode?_0 'truncate/replace))) - #f) - (let ((r_0 - (|#%app| - rktio_delete_file - (unsafe-place-local-ref cell.1) - host-path_0 - (1/current-force-delete-permissions)))) - (begin - (if (vector? r_0) - (begin - (unsafe-end-atomic) - (raise-filesystem-error - who6_0 - r_0 - (let ((app_0 - (string-append - "error deleting file\n" - " path: ~a"))) - (1/format - app_0 - (host-> host-path_0))))) - (void)) - (|#%app| - rktio_open - (unsafe-place-local-ref cell.1) - host-path_0 - flags_0))) - fd0_0)))) - (begin - (if (vector? fd_0) - (begin - (unsafe-end-atomic) - (raise-filesystem-error - who6_0 - fd_0 - (let ((app_0 - (string-append "~a\n" " path: ~a"))) - (let ((app_1 - (if (racket-error? fd0_0 4) - "file exists" - (if (racket-error? fd0_0 9) - "path is a directory" - "error opening file")))) - (1/format - app_0 - app_1 - (host-> host-path_0)))))) - (void)) - (let ((opened-path_0 (host-> host-path_0))) - (let ((refcount_0 (box (if plus-input?4_0 2 1)))) - (let ((op_0 - (open-output-fd.1 - 'infer - unsafe-undefined - refcount_0 - unsafe-undefined - fd_0 - opened-path_0))) - (let ((ip_0 - (if plus-input?4_0 - (open-input-fd.1 - unsafe-undefined - refcount_0 - fd_0 - opened-path_0) - #f))) - (begin - (unsafe-end-atomic) - (if (1/port-count-lines-enabled) - (begin - (1/port-count-lines! op_0) - (if plus-input?4_0 - (1/port-count-lines! ip_0) - (void))) - (void)) - (if plus-input?4_0 - (values ip_0 op_0) - op_0)))))))))))))))))))) + (mode?_0 'truncate/replace))) + #f) + (let ((r_0 + (|#%app| + rktio_delete_file + (unsafe-place-local-ref cell.1) + host-path_0 + (1/current-force-delete-permissions)))) + (begin + (if (vector? r_0) + (begin + (unsafe-end-atomic) + (raise-filesystem-error + who6_0 + r_0 + (let ((app_0 + (string-append + "error deleting file\n" + " path: ~a"))) + (1/format + app_0 + (host-> host-path_0))))) + (void)) + (|#%app| + rktio_open + (unsafe-place-local-ref cell.1) + host-path_0 + flags_0))) + fd0_0)))) + (begin + (if (vector? fd_0) + (begin + (unsafe-end-atomic) + (raise-filesystem-error + who6_0 + fd_0 + (let ((app_0 + (string-append "~a\n" " path: ~a"))) + (let ((app_1 + (if (racket-error? fd0_0 4) + "file exists" + (if (racket-error? fd0_0 9) + "path is a directory" + "error opening file")))) + (1/format + app_0 + app_1 + (host-> host-path_0)))))) + (void)) + (let ((opened-path_0 (host-> host-path_0))) + (let ((refcount_0 + (box (if plus-input?4_0 2 1)))) + (let ((op_0 + (open-output-fd.1 + 'infer + unsafe-undefined + refcount_0 + unsafe-undefined + fd_0 + opened-path_0))) + (let ((ip_0 + (if plus-input?4_0 + (open-input-fd.1 + unsafe-undefined + refcount_0 + fd_0 + opened-path_0) + #f))) + (begin + (unsafe-end-atomic) + (if (1/port-count-lines-enabled) + (begin + (1/port-count-lines! op_0) + (if plus-input?4_0 + (1/port-count-lines! ip_0) + (void))) + (void)) + (if plus-input?4_0 + (values ip_0 op_0) + op_0))))))))))))))))))))) +(define DEFAULT-CREATE-PERMS 438) (define 1/open-output-file (let ((open-output-file_0 (|#%name| open-output-file - (lambda (path13_0 mode111_0 mode212_0) + (lambda (path15_0 mode112_0 mode213_0 perms14_0) (begin (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 - (if (eq? mode212_0 unsafe-undefined) none$1 mode212_0))) - (do-open-output-file.1 - #f - 'open-output-file - path13_0 - mode1_0 - mode2_0)))))))) + (if (eq? mode213_0 unsafe-undefined) none$1 mode213_0))) + (let ((perms_0 + (if (eq? perms14_0 unsafe-undefined) 438 perms14_0))) + (do-open-output-file.1 + #f + 'open-output-file + path15_0 + mode1_0 + mode2_0 + perms_0))))))))) (|#%name| open-output-file (case-lambda ((path_0) - (begin (open-output-file_0 path_0 unsafe-undefined unsafe-undefined))) - ((path_0 mode1_0 mode212_0) - (open-output-file_0 path_0 mode1_0 mode212_0)) - ((path_0 mode111_0) - (open-output-file_0 path_0 mode111_0 unsafe-undefined)))))) + (begin + (open-output-file_0 + path_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 (let ((open-input-output-file_0 (|#%name| open-input-output-file - (lambda (path16_0 mode114_0 mode215_0) + (lambda (path19_0 mode116_0 mode217_0 perms18_0) (begin (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 - (if (eq? mode215_0 unsafe-undefined) none$1 mode215_0))) - (do-open-output-file.1 - #t - 'open-input-output-file - path16_0 - mode1_0 - mode2_0)))))))) + (if (eq? mode217_0 unsafe-undefined) none$1 mode217_0))) + (let ((perms_0 + (if (eq? perms18_0 unsafe-undefined) 438 perms18_0))) + (do-open-output-file.1 + #t + 'open-input-output-file + path19_0 + mode1_0 + mode2_0 + perms_0))))))))) (|#%name| open-input-output-file (case-lambda ((path_0) (begin - (open-input-output-file_0 path_0 unsafe-undefined unsafe-undefined))) - ((path_0 mode1_0 mode215_0) - (open-input-output-file_0 path_0 mode1_0 mode215_0)) - ((path_0 mode114_0) - (open-input-output-file_0 path_0 mode114_0 unsafe-undefined)))))) + (open-input-output-file_0 + path_0 + unsafe-undefined + 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 (let ((call-with-input-file_0 (|#%name| call-with-input-file - (lambda (path18_0 proc19_0 mode17_0) + (lambda (path21_0 proc22_0 mode20_0) (begin (let ((mode_0 - (if (eq? mode17_0 unsafe-undefined) none$1 mode17_0))) + (if (eq? mode20_0 unsafe-undefined) none$1 mode20_0))) (begin - (if (path-string? path18_0) + (if (path-string? path21_0) (void) (raise-argument-error 'call-with-input-file "path-string?" - path18_0)) + path21_0)) (begin - (if (if (procedure? proc19_0) - (procedure-arity-includes? proc19_0 1) + (if (if (procedure? proc22_0) + (procedure-arity-includes? proc22_0 1) #f) (void) (raise-argument-error 'call-with-input-file "(procedure-arity-includes/c 1)" - proc19_0)) - (let ((i_0 (1/open-input-file path18_0 mode_0))) + proc22_0)) + (let ((i_0 (1/open-input-file path21_0 mode_0))) (begin0 - (|#%app| proc19_0 i_0) + (|#%app| proc22_0 i_0) (1/close-input-port i_0))))))))))) (|#%name| call-with-input-file (case-lambda ((path_0 proc_0) (begin (call-with-input-file_0 path_0 proc_0 unsafe-undefined))) - ((path_0 proc_0 mode17_0) - (call-with-input-file_0 path_0 proc_0 mode17_0)))))) + ((path_0 proc_0 mode20_0) + (call-with-input-file_0 path_0 proc_0 mode20_0)))))) (define 1/call-with-output-file (let ((call-with-output-file_0 (|#%name| 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 (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 - (if (eq? mode221_0 unsafe-undefined) none$1 mode221_0))) - (begin - (if (path-string? path22_0) - (void) - (raise-argument-error - 'call-with-output-file - "path-string?" - path22_0)) + (if (eq? mode224_0 unsafe-undefined) none$1 mode224_0))) + (let ((perms_0 + (if (eq? perms25_0 unsafe-undefined) 438 perms25_0))) (begin - (if (if (procedure? proc23_0) - (procedure-arity-includes? proc23_0 1) - #f) + (if (path-string? path26_0) (void) (raise-argument-error 'call-with-output-file - "(procedure-arity-includes/c 1)" - proc23_0)) - (let ((o_0 - (1/open-output-file path22_0 mode1_0 mode2_0))) - (begin0 - (|#%app| proc23_0 o_0) - (1/close-output-port o_0)))))))))))) + "path-string?" + path26_0)) + (begin + (if (if (procedure? proc27_0) + (procedure-arity-includes? proc27_0 1) + #f) + (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| call-with-output-file (case-lambda @@ -26288,36 +26340,49 @@ path_0 proc_0 unsafe-undefined + unsafe-undefined unsafe-undefined))) - ((path_0 proc_0 mode1_0 mode221_0) - (call-with-output-file_0 path_0 proc_0 mode1_0 mode221_0)) - ((path_0 proc_0 mode120_0) - (call-with-output-file_0 path_0 proc_0 mode120_0 unsafe-undefined)))))) + ((path_0 proc_0 mode1_0 mode2_0 perms25_0) + (call-with-output-file_0 path_0 proc_0 mode1_0 mode2_0 perms25_0)) + ((path_0 proc_0 mode1_0 mode224_0) + (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 (let ((with-input-from-file_0 (|#%name| with-input-from-file - (lambda (path25_0 proc26_0 mode24_0) + (lambda (path29_0 proc30_0 mode28_0) (begin (let ((mode_0 - (if (eq? mode24_0 unsafe-undefined) none$1 mode24_0))) + (if (eq? mode28_0 unsafe-undefined) none$1 mode28_0))) (begin - (if (path-string? path25_0) + (if (path-string? path29_0) (void) (raise-argument-error 'with-input-from-file "path-string?" - path25_0)) + path29_0)) (begin - (if (if (procedure? proc26_0) - (procedure-arity-includes? proc26_0 0) + (if (if (procedure? proc30_0) + (procedure-arity-includes? proc30_0 0) #f) (void) (raise-argument-error 'with-input-from-file "(procedure-arity-includes/c 0)" - proc26_0)) - (let ((i_0 (1/open-input-file path25_0 mode_0))) + proc30_0)) + (let ((i_0 (1/open-input-file path29_0 mode_0))) (with-continuation-mark* authentic parameterization-key @@ -26327,54 +26392,70 @@ i_0) (dynamic-wind void - proc26_0 + proc30_0 (lambda () (1/close-input-port i_0))))))))))))) (|#%name| with-input-from-file (case-lambda ((path_0 proc_0) (begin (with-input-from-file_0 path_0 proc_0 unsafe-undefined))) - ((path_0 proc_0 mode24_0) - (with-input-from-file_0 path_0 proc_0 mode24_0)))))) + ((path_0 proc_0 mode28_0) + (with-input-from-file_0 path_0 proc_0 mode28_0)))))) (define 1/with-output-to-file (let ((with-output-to-file_0 (|#%name| 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 (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 - (if (eq? mode228_0 unsafe-undefined) none$1 mode228_0))) - (begin - (if (path-string? path29_0) - (void) - (raise-argument-error - 'with-output-to-file - "path-string?" - path29_0)) + (if (eq? mode232_0 unsafe-undefined) none$1 mode232_0))) + (let ((perms_0 + (if (eq? perms33_0 unsafe-undefined) 438 perms33_0))) (begin - (if (if (procedure? proc30_0) - (procedure-arity-includes? proc30_0 0) - #f) + (if (path-string? path34_0) (void) (raise-argument-error 'with-output-to-file - "(procedure-arity-includes/c 0)" - proc30_0)) - (let ((o_0 - (1/open-output-file path29_0 mode1_0 mode2_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 - proc30_0 - (lambda () (1/close-output-port o_0)))))))))))))) + "path-string?" + path34_0)) + (begin + (if (if (procedure? proc35_0) + (procedure-arity-includes? proc35_0 0) + #f) + (void) + (raise-argument-error + 'with-output-to-file + "(procedure-arity-includes/c 0)" + proc35_0)) + (begin + (if (permissions? perms_0) + (void) + (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| with-output-to-file (case-lambda @@ -26384,11 +26465,24 @@ path_0 proc_0 unsafe-undefined + unsafe-undefined unsafe-undefined))) - ((path_0 proc_0 mode1_0 mode228_0) - (with-output-to-file_0 path_0 proc_0 mode1_0 mode228_0)) - ((path_0 proc_0 mode127_0) - (with-output-to-file_0 path_0 proc_0 mode127_0 unsafe-undefined)))))) + ((path_0 proc_0 mode1_0 mode2_0 perms33_0) + (with-output-to-file_0 path_0 proc_0 mode1_0 mode2_0 perms33_0)) + ((path_0 proc_0 mode1_0 mode232_0) + (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 (|#%name| path-or-fd-identity @@ -34259,11 +34353,11 @@ 'subprocess "(or/c (and/c output-port? file-stream-port?) #f 'stdout)" stderr_0)) - (let ((lr1323 unsafe-undefined) + (let ((lr1324 unsafe-undefined) (group_0 unsafe-undefined) (command_0 unsafe-undefined) (exact/args_0 unsafe-undefined)) - (set! lr1323 + (set! lr1324 (call-with-values (lambda () (if (path-string? group/command_0) @@ -34318,9 +34412,9 @@ ((group_1 command_1 exact/args_1) (vector group_1 command_1 exact/args_1)) (args (raise-binding-result-arity-error 3 args))))) - (set! group_0 (unsafe-vector*-ref lr1323 0)) - (set! command_0 (unsafe-vector*-ref lr1323 1)) - (set! exact/args_0 (unsafe-vector*-ref lr1323 2)) + (set! group_0 (unsafe-vector*-ref lr1324 0)) + (set! command_0 (unsafe-vector*-ref lr1324 1)) + (set! exact/args_0 (unsafe-vector*-ref lr1324 2)) (call-with-values (lambda () (if (if (pair? exact/args_0) diff --git a/racket/src/io/port/file-port.rkt b/racket/src/io/port/file-port.rkt index d3b02ea862..98ee1935c5 100644 --- a/racket/src/io/port/file-port.rkt +++ b/racket/src/io/port/file-port.rkt @@ -54,8 +54,13 @@ (port-count-lines! 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 permissions? #:contract permissions-desc perms) (define (mode->flags mode) (case mode [(text) RKTIO_OPEN_TEXT] @@ -87,7 +92,7 @@ (mode->flags mode1) (mode->flags mode2))) (define fd0 - (rktio_open rktio host-path flags)) + (rktio_open_with_create_permissions rktio host-path flags perms)) (define fd (cond [(not (rktio-error? fd0)) fd0] @@ -135,11 +140,13 @@ (values ip op) op)) -(define/who (open-output-file path [mode1 none] [mode2 none]) - (do-open-output-file who path mode1 mode2)) +(define DEFAULT-CREATE-PERMS #o666) -(define/who (open-input-output-file path [mode1 none] [mode2 none]) - (do-open-output-file #:plus-input? #t who path mode1 mode2)) +(define/who (open-output-file path [mode1 none] [mode2 none] [perms DEFAULT-CREATE-PERMS]) + (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]) (check who path-string? path) @@ -149,10 +156,11 @@ (proc 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 (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 (proc o) (close-output-port o))) @@ -168,10 +176,11 @@ (lambda () (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 (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]) (dynamic-wind void diff --git a/racket/src/rktio/parse.rkt b/racket/src/rktio/parse.rkt index 5e4fb43659..44adad0836 100644 --- a/racket/src/rktio/parse.rkt +++ b/racket/src/rktio/parse.rkt @@ -88,6 +88,8 @@ [(:seq (:or #\_ (:/ #\A #\Z #\a #\z)) (:* (:or #\_ (:/ #\A #\Z #\a #\z #\0 #\9)))) (token-ID (string->symbol lexeme))] + [(:seq (:? "-") "0" (:+ (:/ "0" "7"))) + (token-NUM (string->number lexeme 8))] [(:seq (:? "-") (:+ (:/ "0" "9"))) (token-NUM (string->number lexeme))] [(:seq "0x" (:+ (:/ "0" "9") (:/ "A" "F") (:/ "a" "f"))) diff --git a/racket/src/rktio/rktio.def b/racket/src/rktio/rktio.def index e65e4cb1fa..1171a650b2 100644 --- a/racket/src/rktio/rktio.def +++ b/racket/src/rktio/rktio.def @@ -15,6 +15,7 @@ rktio_fd_is_text_converted rktio_fd_is_pending_open rktio_fd_modes rktio_open +rktio_open_with_create_permissions rktio_close rktio_close_noerr rktio_dup diff --git a/racket/src/rktio/rktio.h b/racket/src/rktio/rktio.h index a11714cc6f..98687d058c 100644 --- a/racket/src/rktio/rktio.h +++ b/racket/src/rktio/rktio.h @@ -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 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); /* Can report `RKTIO_ERROR_EXISTS` in place of system error, and can report `RKTIO_ERROR_UNSUPPORTED_TEXT_MODE` on Windows. diff --git a/racket/src/rktio/rktio.inc b/racket/src/rktio/rktio.inc index 05055a569f..d2c5dc2e66 100644 --- a/racket/src/rktio/rktio.inc +++ b/racket/src/rktio/rktio.inc @@ -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_modes", (void *)rktio_fd_modes); 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_noerr", (void *)rktio_close_noerr); Sforeign_symbol("rktio_dup", (void *)rktio_dup); diff --git a/racket/src/rktio/rktio.rktl b/racket/src/rktio/rktio.rktl index 8f0af4d187..0dce830e83 100644 --- a/racket/src/rktio/rktio.rktl +++ b/racket/src/rktio/rktio.rktl @@ -15,6 +15,7 @@ (define-constant RKTIO_OPEN_NOT_DIR (<< 1 12)) (define-constant RKTIO_OPEN_INIT (<< 1 13)) (define-constant RKTIO_OPEN_OWN (<< 1 14)) +(define-constant RKTIO_DEFAULT_PERM_BITS 438) (define-constant RKTIO_STDIN 0) (define-constant RKTIO_STDOUT 1) (define-constant RKTIO_STDERR 2) @@ -278,6 +279,15 @@ (ref rktio_fd_t) rktio_open (((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 #f () diff --git a/racket/src/rktio/rktio_file.c b/racket/src/rktio/rktio_file.c index 227de53a73..17d0dc9853 100644 --- a/racket/src/rktio/rktio_file.c +++ b/racket/src/rktio/rktio_file.c @@ -20,7 +20,7 @@ static rktio_fd_t *finish_unix_fd_creation(rktio_t *rktio, int fd, int modes, rk #endif #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); #endif @@ -113,7 +113,7 @@ static rktio_fd_t *open_read(rktio_t *rktio, const char *filename, int modes) #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 int fd; @@ -130,19 +130,19 @@ static rktio_fd_t *open_write(rktio_t *rktio, const char *filename, int modes) flags |= O_EXCL; 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)); if (errno == ENXIO) { /* FIFO with no reader? */ #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 /* Try opening in RW mode: */ flags -= O_WRONLY; flags |= O_RDWR; 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)); #endif } @@ -167,13 +167,16 @@ static rktio_fd_t *open_write(rktio_t *rktio, const char *filename, int modes) wp = WIDE_PATH_temp(filename); if (!wp) return NULL; - + fd = CreateFileW(wp, GENERIC_WRITE | ((modes & RKTIO_OPEN_READ) ? GENERIC_READ : 0), FILE_SHARE_READ | FILE_SHARE_WRITE | FILE_SHARE_DELETE, NULL, 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); 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 -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) - return open_write(rktio, filename, modes); + return open_write(rktio, filename, modes, perm_bits); else 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 */ /*========================================================================*/ @@ -435,6 +443,7 @@ typedef struct open_in_thread_t { pthread_cond_t ready_cond; /* wait until helper thread is ready (including cleanup) */ char *filename; int flags; + int perm_bits; int done; int fd; int errval; @@ -500,7 +509,7 @@ static void *do_open_in_thread(void *_data) canceled before `open` returns, but not both (otherwise there could be a space leak) */ do { - fd = open(data->filename, data->flags, 0666); + fd = open(data->filename, data->flags, data->perm_bits); } while ((fd == -1) && (errno == EINTR)); pthread_setcanceltype(PTHREAD_CANCEL_DISABLE, NULL); @@ -519,7 +528,7 @@ static void *do_open_in_thread(void *_data) 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; @@ -529,6 +538,7 @@ static rktio_fd_t *open_via_thread(rktio_t *rktio, const char *filename, int mod data->filename = strdup(filename); data->flags = flags; + data->perm_bits = perm_bits; pthread_mutex_init(&data->lock, NULL); pthread_cond_init(&data->ready_cond, NULL); diff --git a/racket/src/version/racket_version.h b/racket/src/version/racket_version.h index 3b00fd65b1..7c1097c42e 100644 --- a/racket/src/version/racket_version.h +++ b/racket/src/version/racket_version.h @@ -16,7 +16,7 @@ #define MZSCHEME_VERSION_X 8 #define MZSCHEME_VERSION_Y 1 #define MZSCHEME_VERSION_Z 0 -#define MZSCHEME_VERSION_W 2 +#define MZSCHEME_VERSION_W 3 /* A level of indirection makes `#` work as needed: */ #define AS_a_STR_HELPER(x) #x