Merge branch 'file-stream-improvements' into 'develop'

File stream improvements

Closes #511

See merge request embeddable-common-lisp/ecl!245

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

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));

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)},

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

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

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)

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

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