Add Out_channel.{is,set}_buffered to control buffering of output ch…

…annels (#10538)

Changes

@@ -58,6 +58,11 @@ Working version
   (Nicolás Ojeda Bär, review by Daniel Bünzli, Simon Cruanes, Gabriel Scherer,
   Guillaume Munch-Maccagnoni, Alain Frisch and Xavier Leroy)
 
+- #10538: add Out_channel.set_buffered and Out_channel.is_buffered to control
+  the buffering mode of output channels.
+  (Nicolás Ojeda Bär, review by John Whitington, Daniel Bünzli, David Allsopp
+  and Xavier Leroy)
+
 ### Other libraries:
 
 - #10192: Add support for Unix domain sockets on Windows and use them

runtime/caml/io.h

@@ -52,6 +52,7 @@ enum {
   CHANNEL_FLAG_FROM_SOCKET = 1,  /* For Windows */
   CHANNEL_FLAG_MANAGED_BY_GC = 4,  /* Free and close using GC finalization */
   CHANNEL_TEXT_MODE = 8,           /* "Text mode" for Windows and Cygwin */
+  CHANNEL_FLAG_UNBUFFERED = 16     /* Unbuffered (for output channels only) */
 };
 
 /* For an output channel:
@@ -109,6 +110,8 @@ CAMLextern struct channel * caml_all_opened_channels;
   if (caml_channel_mutex_unlock != NULL) (*caml_channel_mutex_unlock)(channel)
 #define Unlock_exn() \
   if (caml_channel_mutex_unlock_exn != NULL) (*caml_channel_mutex_unlock_exn)()
+#define Flush_if_unbuffered(channel) \
+  if (channel->flags & CHANNEL_FLAG_UNBUFFERED) caml_flush(channel)
 
 /* Conversion between file_offset and int64_t */
 

runtime/extern.c

@@ -899,6 +899,7 @@ void caml_output_val(struct channel *chan, value v, value flags)
     caml_stat_free(blk);
     blk = nextblk;
   }
+  Flush_if_unbuffered(chan);
 }
 
 CAMLprim value caml_output_value(value vchan, value v, value flags)

runtime/io.c

@@ -669,13 +669,32 @@ CAMLprim value caml_ml_flush(value vchannel)
   CAMLreturn (Val_unit);
 }
 
+CAMLprim value caml_ml_set_buffered(value vchannel, value mode)
+{
+  struct channel * channel = Channel(vchannel);
+  if (Bool_val(mode)) {
+    channel->flags &= ~CHANNEL_FLAG_UNBUFFERED;
+  } else {
+    channel->flags |= CHANNEL_FLAG_UNBUFFERED;
+    caml_ml_flush(vchannel);
+  }
+  return Val_unit;
+}
+
+CAMLprim value caml_ml_is_buffered(value vchannel)
+{
+  struct channel * channel = Channel(vchannel);
+  return Val_bool( ! (channel->flags & CHANNEL_FLAG_UNBUFFERED));
+}
+
 CAMLprim value caml_ml_output_char(value vchannel, value ch)
 {
   CAMLparam2 (vchannel, ch);
   struct channel * channel = Channel(vchannel);
 
   Lock(channel);
   Putch(channel, Long_val(ch));
+  Flush_if_unbuffered(channel);
   Unlock(channel);
   CAMLreturn (Val_unit);
 }
@@ -687,6 +706,7 @@ CAMLprim value caml_ml_output_int(value vchannel, value w)
 
   Lock(channel);
   caml_putword(channel, (uint32_t) Long_val(w));
+  Flush_if_unbuffered(channel);
   Unlock(channel);
   CAMLreturn (Val_unit);
 }
@@ -707,6 +727,7 @@ CAMLprim value caml_ml_output_bytes(value vchannel, value buff, value start,
       pos += written;
       len -= written;
     }
+    Flush_if_unbuffered(channel);
   Unlock(channel);
   CAMLreturn (Val_unit);
 }

stdlib/out_channel.ml

@@ -45,3 +45,7 @@ let output_bytes = Stdlib.output_bytes
 let output = Stdlib.output
 let output_substring = Stdlib.output_substring
 let set_binary_mode = Stdlib.set_binary_mode_out
+
+external set_buffered : t -> bool -> unit = "caml_ml_set_buffered"
+
+external is_buffered : t -> bool = "caml_ml_is_buffered"

stdlib/out_channel.mli

@@ -129,3 +129,19 @@ val set_binary_mode : t -> bool -> unit
 
     This function has no effect under operating systems that do not distinguish
     between text mode and binary mode. *)
+
+val set_buffered : t -> bool -> unit
+(** [set_buffered oc true] sets the channel [oc] to {e buffered} mode. In this
+    mode, data output on [oc] will be buffered until either the internal buffer
+    is full or the function {!flush} or {!flush_all} is called, at which point
+    it will be sent to the output device.
+
+    [set_buffered oc false] sets the channel [oc] to {e unbuffered} mode. In
+    this mode, data output on [oc] will be sent to the output device
+    immediately.
+
+    All channels are open in {e buffered} mode by default. *)
+
+val is_buffered : t -> bool
+(** [is_buffered oc] returns whether the channel [oc] is buffered (see
+    {!set_buffered}). *)

testsuite/tests/lib-channels/buffered.ml

@@ -0,0 +1,34 @@
+(* TEST *)
+
+(* baseline *)
+let () =
+  print_string "stdout 1\n";
+  prerr_string "stderr 1\n";
+  flush stdout;
+  flush stderr
+
+(* stderr unbuffered *)
+let () =
+  Out_channel.set_buffered stderr false;
+  print_string "stdout 2\n";
+  prerr_string "stderr 2\n";
+  print_string (Bool.to_string (Out_channel.is_buffered stderr));
+  print_char '\n';
+  flush stdout
+
+(* switching to unbuffered flushes the channel *)
+let () =
+  print_string "stdout 3\n";
+  prerr_string "stderr 3\n";
+  Out_channel.set_buffered stderr false;
+  flush stdout
+
+(* stderr back to buffered *)
+let () =
+  Out_channel.set_buffered stderr true;
+  print_string "stdout 4\n";
+  prerr_string "stderr 4\n";
+  print_string (Bool.to_string (Out_channel.is_buffered stderr));
+  print_char '\n';
+  flush stdout;
+  flush stderr

testsuite/tests/lib-channels/buffered.reference

@@ -0,0 +1,10 @@
+stdout 1
+stderr 1
+stderr 2
+stdout 2
+false
+stderr 3
+stdout 3
+stdout 4
+true
+stderr 4