diff --git a/src/c/error.d b/src/c/error.d index 20c0f4b4b..4ed815b1e 100644 --- a/src/c/error.d +++ b/src/c/error.d @@ -234,9 +234,17 @@ FEreader_error(const char *s, cl_object stream, int narg, ...) void -FEcannot_open(cl_object fn) +FEcannot_open(cl_object file) { - cl_error(3, @'file-error', @':pathname', fn); + cl_object c_error = _ecl_strerror(errno); + si_signal_simple_error + (6, @'file-error', /* condition */ + ECL_NIL, /* continuable */ + ecl_make_constant_base_string("Cannot open ~S.~%C library error: ~A",-1), /* format */ + cl_list(2, file, c_error), /* format args */ + @':pathname', /* file-error options */ + file); + _ecl_unexpected_return(); } void diff --git a/src/c/file.d b/src/c/file.d index 13ad5748e..3f72dba91 100755 --- a/src/c/file.d +++ b/src/c/file.d @@ -2615,17 +2615,6 @@ safe_close(int f) return output; } -static FILE * -safe_fopen(const char *filename, const char *mode) -{ - const cl_env_ptr the_env = ecl_process_env(); - FILE *output; - ecl_disable_interrupts_env(the_env); - output = fopen(filename, mode); - ecl_enable_interrupts_env(the_env); - return output; -} - static FILE * safe_fdopen(int fildes, const char *mode) { @@ -5250,14 +5239,30 @@ FEinvalid_option(cl_object option, cl_object value) FEerror("Invalid value op option ~A: ~A", 2, option, value); } +static int +smmode_to_open_flag(enum ecl_smmode smm) +{ + switch (smm) { + case ecl_smm_probe: + case ecl_smm_input: + return O_RDONLY; + case ecl_smm_output: + return O_WRONLY; + case ecl_smm_io: + return O_RDWR; + default: + FEerror("Illegal stream mode ~S", 1, ecl_make_fixnum(smm)); + } +} + cl_object ecl_open_stream(cl_object fn, enum ecl_smmode smm, cl_object if_exists, cl_object if_does_not_exist, cl_fixnum byte_size, int flags, cl_object external_format) { - cl_object output, file_kind; - int fd; - bool appending = 0, exists; + cl_object output; + int fd, open_flags = smmode_to_open_flag(smm) | O_BINARY; + bool appending = 0; #if defined(ECL_MS_WINDOWS_HOST) ecl_mode_t mode = _S_IREAD | _S_IWRITE; #else @@ -5267,91 +5272,93 @@ ecl_open_stream(cl_object fn, enum ecl_smmode smm, cl_object if_exists, remembers the original pathname FN. -- jd 2020-03-27 */ cl_object filename = si_coerce_to_filename(fn); char *fname = (char*)filename->base_string.self; - file_kind = si_file_kind(filename, ECL_T); - exists = file_kind != ECL_NIL; - if (!exists) { - if (if_does_not_exist == ECL_NIL) return ECL_NIL; - if (if_does_not_exist == @':error') FEcannot_open(fn); - if (if_does_not_exist != @':create') - FEinvalid_option(@':if-does-not-exist', if_does_not_exist); - fd = safe_open(fname, O_WRONLY|O_CREAT, mode); - unlikely_if (fd < 0) FEcannot_open(fn); - safe_close(fd); - fd = -1; + + if (if_does_not_exist == @':create') { + open_flags |= O_CREAT; + if ((smm == ecl_smm_output || smm == ecl_smm_io) && + (if_exists == ECL_NIL || if_exists == @':error' || if_exists == @':rename')) { + open_flags |= O_EXCL; + } + } else if (if_does_not_exist != ECL_NIL && if_does_not_exist != @':error') { + FEinvalid_option(@':if-does-not-exist', if_does_not_exist); } - switch (smm) { - case ecl_smm_probe: + if (if_exists == @':rename_and_delete' || + if_exists == @':new_version' || + if_exists == @':supersede' || + if_exists == @':truncate') { + if (smm == ecl_smm_output || smm == ecl_smm_io) { + open_flags |= O_TRUNC; + } + } else if (if_exists == @':append') { + if (smm == ecl_smm_output || smm == ecl_smm_io) { + appending = 1; + } + } else if (if_exists != ECL_NIL && + if_exists != @':error' && + if_exists != @':rename' && + if_exists != @':overwrite') { + FEinvalid_option(@':if-exists', if_exists); + } + if (flags & ECL_STREAM_CLOSE_ON_EXEC) { + open_flags |= O_CLOEXEC; + } + if (flags & ECL_STREAM_NONBLOCK) { + open_flags |= O_NONBLOCK; + } + + fd = safe_open(fname, open_flags, mode); + if (fd < 0) { + if (errno == ENOENT && if_does_not_exist == ECL_NIL) { + return ECL_NIL; + } else if (errno == EEXIST) { + if (if_exists == ECL_NIL) { + safe_close(fd); + return ECL_NIL; + } else if (if_exists == @':error') { + safe_close(fd); + FEcannot_open(fn); + } else if (if_exists == @':rename') { + safe_close(fd); + fd = ecl_backup_open(fname, smmode_to_open_flag(smm)|O_CREAT, mode); + unlikely_if (fd < 0) FEcannot_open(fn); + } + } else { + FEcannot_open(fn); + } + } + + if (smm == ecl_smm_probe) { + safe_close(fd); output = ecl_make_file_stream_from_fd(fn, -1, smm, byte_size, flags, external_format); generic_close(output); return output; - case ecl_smm_input: - fd = safe_open(fname, O_RDONLY|O_NONBLOCK, mode); - unlikely_if (fd < 0) FEcannot_open(fn); - break; - case ecl_smm_output: - /* For output we could have used O_WRONLY, but this doesn't matter because - we fopen with OPEN_RW later anyway. stream opts enforce things. */ - case ecl_smm_io: { - if (exists) { - if (if_exists == ECL_NIL) return ECL_NIL; - if (if_exists == @':error') FEcannot_open(fn); - if (if_exists == @':rename') { - fd = ecl_backup_open(fname, O_RDWR|O_CREAT, mode); - unlikely_if (fd < 0) FEcannot_open(fn); - } else if (if_exists == @':rename_and_delete' || - if_exists == @':new_version' || - if_exists == @':supersede' || - if_exists == @':truncate') { - fd = safe_open(fname, O_RDWR|O_TRUNC, mode); - unlikely_if (fd < 0) FEcannot_open(fn); - } else if (if_exists == @':overwrite' || if_exists == @':append') { - fd = safe_open(fname, O_RDWR, mode); - unlikely_if (fd < 0) FEcannot_open(fn); - appending = (if_exists == @':append'); - } else { - FEinvalid_option(@':if-exists', if_exists); - } - } - break; - } - default: - FEerror("Illegal stream mode ~S", 1, ecl_make_fixnum(smm)); } if (flags & ECL_STREAM_C_STREAM) { FILE *fp = 0; - /* We do not use fdopen() because Windows seems to have problems with the - * resulting streams. Furthermore, even for output we open with w+ because - * we do not want to overwrite the file. */ switch (smm) { case ecl_smm_probe: /* never happens (returns earlier) */ case ecl_smm_input: - if (file_kind == @':fifo') { - fp = safe_fdopen(fd, OPEN_R); - } else { - if (fd >= 0) - safe_close(fd); - fp = safe_fopen(fname, OPEN_R); - } + fp = safe_fdopen(fd, OPEN_R); break; case ecl_smm_output: + fp = safe_fdopen(fd, OPEN_W); + break; case ecl_smm_io: - if (file_kind == @':fifo') { - fp = safe_fdopen(fd, OPEN_RW); - } else { - if (fd >= 0) - safe_close(fd); - fp = safe_fopen(fname, OPEN_RW); - } + fp = safe_fdopen(fd, OPEN_RW); break; default:; /* never reached (errors earlier) */ } + if (fp == NULL) { + FEcannot_open(fn); + } output = ecl_make_stream_from_FILE(fn, fp, smm, byte_size, flags, external_format); si_set_buffering_mode(output, byte_size? @':full' : @':line'); } else { output = ecl_make_file_stream_from_fd(fn, fd, smm, byte_size, flags, external_format); } + output->stream.flags |= ECL_STREAM_MIGHT_SEEK; si_set_finalizer(output, ECL_T); /* Set file pointer to the correct position */ @@ -5366,6 +5373,8 @@ ecl_open_stream(cl_object fn, enum ecl_smmode smm, cl_object if_exists, (if_does_not_exist ECL_NIL idnesp) (external_format @':default') (cstream ECL_T) + (close_on_exec ECL_T) + (nonblock ECL_NIL) &aux strm) enum ecl_smmode smm; int flags = 0; @@ -5413,6 +5422,12 @@ ecl_open_stream(cl_object fn, enum ecl_smmode smm, cl_object if_exists, if (!Null(cstream)) { flags |= ECL_STREAM_C_STREAM; } + if (!Null(close_on_exec)) { + flags |= ECL_STREAM_CLOSE_ON_EXEC; + } + if (!Null(nonblock)) { + flags |= ECL_STREAM_NONBLOCK; + } strm = ecl_open_stream(filename, smm, if_exists, if_does_not_exist, byte_size, flags, external_format); @(return strm); @@ -5703,7 +5718,7 @@ file_libc_error(cl_object error_type, cl_object stream, rest = cl_grab_rest_args(args); ecl_va_end(args); - si_signal_simple_error(4, (cl_object)(cl_symbols + ecl_fixnum(error_type)), Cnil, + si_signal_simple_error(4, (cl_object)(cl_symbols + ecl_fixnum(error_type)), ECL_NIL, ecl_make_constant_base_string("~?~%C library explanation: ~A.",-1), cl_list(3, ecl_make_constant_base_string(msg,-1), rest, error)); diff --git a/src/c/symbols_list.h b/src/c/symbols_list.h index 4666ba636..d18cdd07f 100755 --- a/src/c/symbols_list.h +++ b/src/c/symbols_list.h @@ -1359,6 +1359,7 @@ cl_symbols[] = { {KEY_ "CATCH" ECL_FUN(NULL, NULL, -1) ECL_VAR(KEYWORD, OBJNULL)}, {KEY_ "CASE" ECL_FUN(NULL, NULL, -1) ECL_VAR(KEYWORD, OBJNULL)}, {KEY_ "CIRCLE" ECL_FUN(NULL, NULL, -1) ECL_VAR(KEYWORD, OBJNULL)}, +{KEY_ "CLOSE-ON-EXEC" ECL_FUN(NULL, NULL, -1) ECL_VAR(KEYWORD, OBJNULL)}, {KEY_ "COMPILE-TOPLEVEL" ECL_FUN(NULL, NULL, -1) ECL_VAR(KEYWORD, OBJNULL)}, {KEY_ "COMMON" ECL_FUN(NULL, NULL, -1) ECL_VAR(KEYWORD, OBJNULL)}, {KEY_ "CONC-NAME" ECL_FUN(NULL, NULL, -1) ECL_VAR(KEYWORD, OBJNULL)}, @@ -1435,6 +1436,7 @@ cl_symbols[] = { {KEY_ "NEW-VERSION" ECL_FUN(NULL, NULL, -1) ECL_VAR(KEYWORD, OBJNULL)}, {KEY_ "NEWEST" ECL_FUN(NULL, NULL, -1) ECL_VAR(KEYWORD, OBJNULL)}, {KEY_ "NICKNAMES" ECL_FUN(NULL, NULL, -1) ECL_VAR(KEYWORD, OBJNULL)}, +{KEY_ "NONBLOCK" ECL_FUN(NULL, NULL, -1) ECL_VAR(KEYWORD, OBJNULL)}, {KEY_ "OBJECT" ECL_FUN(NULL, NULL, -1) ECL_VAR(KEYWORD, OBJNULL)}, {KEY_ "OFFSET" ECL_FUN(NULL, NULL, -1) ECL_VAR(KEYWORD, OBJNULL)}, {KEY_ "OPERATION" ECL_FUN(NULL, NULL, -1) ECL_VAR(KEYWORD, OBJNULL)}, diff --git a/src/doc/manual/extensions/osi.txi b/src/doc/manual/extensions/osi.txi index 68a225096..1fe6495f1 100644 --- a/src/doc/manual/extensions/osi.txi +++ b/src/doc/manual/extensions/osi.txi @@ -293,11 +293,11 @@ Controls escaping of the arguments passed to @code{CreateProcess}. @subsection FIFO files (named pipes) Named pipe (known as fifo) may be created on UNIX with a shell command -mkfifo. ECL opens such files in non-blocking -mode. @coderef{ext:file-kind} will return for such file -@code{:fifo}. Since it is impossible to guess how many characters are -available in this special file @code{file-length} function will return -NIL. +mkfifo. They can be opened in non-blocking mode by using @code{:nonblock +t} option for @coderef{open}. @coderef{ext:file-kind} will return for +such file @code{:fifo}. Since it is impossible to guess how many +characters are available in this special file @code{file-length} +function will return @code{nil}. @node Operating System Interface Reference @subsection Operating System Interface Reference diff --git a/src/doc/manual/standards/streams.txi b/src/doc/manual/standards/streams.txi index 56cbc1494..698578d08 100644 --- a/src/doc/manual/standards/streams.txi +++ b/src/doc/manual/standards/streams.txi @@ -108,59 +108,23 @@ and the table of known symbols is shown below. Note how some symbols (@code{:cr} @node Streams - Dictionary @subsection Dictionary -@subsubsection Sequence Streams - -@lspdef ext:sequence-stream -@deftp {System Class} ext:sequence-stream - -@paragraph Class Precedence List -@coderef{ext:sequence-stream}, @code{stream}, @code{t} - -@paragraph Description -Sequence streams work similar to string streams for vectors. The -supplied vectors that the streams read from or write to must have a -byte sized element type, i.e. @code{(signed-byte 8)}, -@code{(unsigned-byte 8)} or @code{base-char}. - -The semantics depend on the vector element type and the external -format of the stream. If no external format is supplied and the -element type is an integer type, the stream is a binary stream and -accepts only integers of the same type as the element type of the -vector. Otherwise, the stream accepts both characters and integers and -converts them using the given external format. If the element type is -@code{base-char}, the elements of the vectors are treated as bytes. -This means that writing a character may use multiple elements of the -vector, whose @code{char-code}s will be equal to the values of the -bytes comprising the character in the given external format. -@end deftp - -@lspdef ext:make-sequence-input-stream -@defun ext:make-sequence-input-stream vector &key (start 0) (end nil) (external-format nil) -Create a sequence input stream with the subsequence bounded by -@var{start} and @var{end} of the given vector. -@end defun -@lspdef ext:make-sequence-output-stream -@defun ext:make-sequence-output-stream vector &key (external-format nil) -Create a sequence output stream. -@end defun - -@exindex Using sequence streams -Example: - -Using sequence streams to convert to a UTF8 encoded base string -@lisp -CL-USER> (defvar *output* (make-array 20 :element-type 'base-char :adjustable t :fill-pointer 0)) -*OUTPUT* -CL-USER> (defvar *stream* (ext:make-sequence-output-stream *output* :external-format :utf-8)) -*STREAM* -CL-USER> (write-string "Spätzle mit Soß'" *stream*) -"Spätzle mit Soß'" -CL-USER> *output* -"Spätzle mit SoÃ\237'" -@end lisp - @subsubsection File Stream Extensions +@lspdef open +@defun open filespec &key direction element-type if-exists if-does-not-exist external-format close-on-exec nonblock +Additional options for @clhs{f_open.htm,open} include: +@table @code +@item :close-on-exec +Child processes don't inherit a copy of this stream: new processes +created by @code{fork} and @code{exec} (for example by calling +@coderef{ext:run-program}) close the stream after calling @code{exec}. +Defaults to @code{t}. +@item :nonblock +Open fifos or device files in nonblocking mode. Defaults to @code{nil}. +@end table +These options are ignored on operating systems which do not support them. +@end defun + @lspdef ext:set-buffering-mode @defun ext:set-buffering-mode stream mode Control the buffering mode of a stream @@ -303,6 +267,56 @@ that the error can be ignored or the octets can be replaced with a character. @end defun +@subsubsection Sequence Streams + +@lspdef ext:sequence-stream +@deftp {System Class} ext:sequence-stream + +@paragraph Class Precedence List +@coderef{ext:sequence-stream}, @code{stream}, @code{t} + +@paragraph Description +Sequence streams work similar to string streams for vectors. The +supplied vectors that the streams read from or write to must have a +byte sized element type, i.e. @code{(signed-byte 8)}, +@code{(unsigned-byte 8)} or @code{base-char}. + +The semantics depend on the vector element type and the external +format of the stream. If no external format is supplied and the +element type is an integer type, the stream is a binary stream and +accepts only integers of the same type as the element type of the +vector. Otherwise, the stream accepts both characters and integers and +converts them using the given external format. If the element type is +@code{base-char}, the elements of the vectors are treated as bytes. +This means that writing a character may use multiple elements of the +vector, whose @code{char-code}s will be equal to the values of the +bytes comprising the character in the given external format. +@end deftp + +@lspdef ext:make-sequence-input-stream +@defun ext:make-sequence-input-stream vector &key (start 0) (end nil) (external-format nil) +Create a sequence input stream with the subsequence bounded by +@var{start} and @var{end} of the given vector. +@end defun +@lspdef ext:make-sequence-output-stream +@defun ext:make-sequence-output-stream vector &key (external-format nil) +Create a sequence output stream. +@end defun + +@exindex Using sequence streams +Example: + +Using sequence streams to convert to a UTF8 encoded base string +@lisp +CL-USER> (defvar *output* (make-array 20 :element-type 'base-char :adjustable t :fill-pointer 0)) +*OUTPUT* +CL-USER> (defvar *stream* (ext:make-sequence-output-stream *output* :external-format :utf-8)) +*STREAM* +CL-USER> (write-string "Spätzle mit Soß'" *stream*) +"Spätzle mit Soß'" +CL-USER> *output* +"Spätzle mit SoÃ\237'" +@end lisp @node Streams - C Reference @subsection C Reference diff --git a/src/h/internal.h b/src/h/internal.h index 9237241ce..6a0a7abb2 100755 --- a/src/h/internal.h +++ b/src/h/internal.h @@ -234,9 +234,16 @@ extern enum ecl_ffi_tag ecl_foreign_type_code(cl_object type); #define OPEN_RA "a+b" /* Windows does not have this flag (POSIX thing) */ +#ifndef O_CLOEXEC +#define O_CLOEXEC 0 +#endif #ifndef O_NONBLOCK #define O_NONBLOCK 0 #endif +/* Windows needs to be told explicitely to open files in binary mode */ +#ifndef O_BINARY +#define O_BINARY 0 +#endif #define ECL_FILE_STREAM_P(strm) \ (ECL_ANSI_STREAM_P(strm) && (strm)->stream.mode < ecl_smm_synonym) diff --git a/src/h/object.h b/src/h/object.h index 69023bc9a..4b2ebd3e1 100644 --- a/src/h/object.h +++ b/src/h/object.h @@ -634,7 +634,9 @@ enum { ECL_STREAM_LITTLE_ENDIAN = 128, ECL_STREAM_C_STREAM = 256, ECL_STREAM_MIGHT_SEEK = 512, - ECL_STREAM_CLOSE_COMPONENTS = 1024 + ECL_STREAM_CLOSE_COMPONENTS = 1024, + ECL_STREAM_CLOSE_ON_EXEC = 2048, + ECL_STREAM_NONBLOCK = 4096 }; /* buffer points to an array of bytes ending at buffer_end. Decode one diff --git a/src/tests/normal-tests/mixed.lsp b/src/tests/normal-tests/mixed.lsp index b1e9cd262..1c108dbad 100644 --- a/src/tests/normal-tests/mixed.lsp +++ b/src/tests/normal-tests/mixed.lsp @@ -256,42 +256,29 @@ ;;; Date: 2018-05-08 ;;; Description: ;;; -;;; Better handling of fifos. This test will most likely fail on Windows (this -;;; is not confirmed yet) because it does not support non-blocking -;;; operations. -;;; -;;; When we figure out what would be correct semantics for Windows this test -;;; should be disabled for that platform and a separate test case ought to be -;;; created. It is possible that it won't fail (because cygwin will handle it -;;; gracefully and/or WinAPI does not support file-pipes). +;;; Better handling of fifos. ;;; ;;; Bug: https://gitlab.com/embeddable-common-lisp/ecl/issues/242 +#-windows (test mix.0016.fifo-tests (ext:run-program "mkfifo" '("my-fifo") :output t) ;; 1) reader (first) and writer (inside) - (with-open-file (stream "my-fifo") + (with-open-file (stream "my-fifo" :nonblock t) (is (null (file-length stream))) (is (null (listen stream))) (is (eql :foo (read-line stream nil :foo))) (is (eql :fifo (ext:file-kind stream nil))) - (with-open-file (stream2 "my-fifo" :direction :output) - ;; Even for output it should not block on Linux. + (with-open-file (stream2 "my-fifo" :direction :output :nonblock t) + ;; Even for output it should not block on Unix. (finishes (write-line "foobar" stream2))) - (is (equal "foobar" (read-line stream nil :foo)))) - ;; 2) writer (first) and reader (second) - (with-open-file (stream "my-fifo" :direction :output) - (finishes (write-line "foobar" stream))) - (with-open-file (stream "my-fifo" :direction :input) ;; there is nobody on the other side, data is lost + (is (equal :foo (read-line stream nil :foo)))) + ;; 2) writer (first) and reader (second) + (signals file-error (open "my-fifo" :direction :output :nonblock t)) + (with-open-file (stream "my-fifo" :direction :input :nonblock t) (is (eql :foo (read-line stream nil :foo)))) - ;; 3) writer (first) and reader (inside) - (with-open-file (stream "my-fifo" :direction :output) - (finishes (write-line "foobar" stream)) - (with-open-file (stream2 "my-fifo" :direction :input) - ;; Even for output it should not block on Linux. - (is (equal "foobar" (read-line stream2 nil :foo))))) ;; clean up - (ext:run-program "rm" '("-rf" "my-fifo") :output t)) + (delete-file "my-fifo")) ;;; Date: 2018-12-02