Implement handling of process redirection to Null_FD file descriptor

Part V114-021

Change-Id: I16631e549e591f3676abf292b070f63e222b6b0c

Author: Nikokrock

src/os/gnatcoll-os-process.adb

@@ -228,26 +228,20 @@ package body GNATCOLL.OS.Process is
       Status            : out Integer)
       return Ada.Strings.Unbounded.Unbounded_String
    is
-      use type FS.File_Descriptor;
       use Ada.Strings.Unbounded;
 
       Pipe_Read, Pipe_Write : OS.FS.File_Descriptor;
       Output                : Unbounded_String;
-      Real_Stderr_Fd        : OS.FS.File_Descriptor := Stderr;
       Buffer                : String (1 .. 4096);
       Pid                   : Process_Handle;
       N                     : Integer;
    begin
       --  Allocate a PIPE to retrieve the output
       FS.Open_Pipe (Pipe_Read, Pipe_Write);
 
-      if Stderr = FS.To_Stdout then
-         Real_Stderr_Fd := Pipe_Write;
-      end if;
-
       --  Start the process.
       Pid := Start
-        (Args, Env, Cwd, Stdin, Pipe_Write, Real_Stderr_Fd, Priority);
+        (Args, Env, Cwd, Stdin, Pipe_Write, Stderr, Priority);
 
       --  Be sure to close Pipe_Write otherwise following reads on Pipe_Read
       --  will block even if the child process ends.
@@ -461,24 +455,75 @@ package body GNATCOLL.OS.Process is
       Priority : Priority_Class        := INHERIT)
       return Process_Handle
    is
-      Result  : Process_Handle;
+      Result      : Process_Handle;
+
+      --  By default final file descriptors are the one passed by the user
+      Real_Stdin   : OS.FS.File_Descriptor := Stdin;
+      Real_Stdout  : OS.FS.File_Descriptor := Stdout;
+      Real_Stderr  : OS.FS.File_Descriptor := Stderr;
+      Close_Stdin  : Boolean := False;
+      Close_Stdout : Boolean := False;
+      Close_Stderr : Boolean := False;
+
+      use type OS.FS.File_Descriptor;
    begin
       GNAT.Task_Lock.Lock;
 
-      FS.Set_Close_On_Exec (Stdin, False);
-      FS.Set_Close_On_Exec (Stdout, False);
-      FS.Set_Close_On_Exec (Stderr, False);
+      --  Handle special cases for file descriptors
+      --  First ensure all file descriptors are valid
+      if Stdout = OS.FS.Invalid_FD then
+         raise OS_Error with "invalid fd for process stdout";
+      elsif Stdout = OS.FS.Null_FD then
+         Real_Stdout := OS.FS.Open (OS.FS.Null_File, OS.FS.Write_Mode);
+         Close_Stdout := True;
+      elsif Stdout = OS.FS.To_Stdout then
+         raise OS_Error with "cannot redirect stdout to stdout";
+      end if;
+
+      if Stdin = OS.FS.Invalid_FD then
+         raise OS_Error with "invalid fd for process stdin";
+      elsif Stdin = OS.FS.Null_FD then
+         Real_Stdin := OS.FS.Open (OS.FS.Null_File, OS.FS.Read_Mode);
+         Close_Stdin := True;
+      elsif Stdin = OS.FS.To_Stdout then
+         raise OS_Error with "cannot redirect stdin to stdout";
+      end if;
+
+      if Stderr = OS.FS.Invalid_FD then
+         raise OS_Error with "invalid fd for process stderr";
+      elsif Stderr = OS.FS.Null_FD then
+         Real_Stderr := OS.FS.Open (OS.FS.Null_File, OS.FS.Write_Mode);
+         Close_Stderr := True;
+      elsif Stderr = OS.FS.To_Stdout then
+         Real_Stderr := Real_Stdout;
+      end if;
+
+      FS.Set_Close_On_Exec (Real_Stdin, False);
+      FS.Set_Close_On_Exec (Real_Stdout, False);
+      FS.Set_Close_On_Exec (Real_Stderr, False);
 
       Result := Internal_Spawn
         (Args,
          Cwd,
          Env,
-         Stdin, Stdout, Stderr,
+         Real_Stdin, Real_Stdout, Real_Stderr,
          Priority);
 
-      FS.Set_Close_On_Exec (Stdin, True);
-      FS.Set_Close_On_Exec (Stdout, True);
-      FS.Set_Close_On_Exec (Stderr, True);
+      FS.Set_Close_On_Exec (Real_Stdin, True);
+      FS.Set_Close_On_Exec (Real_Stdout, True);
+      FS.Set_Close_On_Exec (Real_Stderr, True);
+
+      if Close_Stdout then
+         OS.FS.Close (Real_Stdout);
+      end if;
+
+      if Close_Stderr then
+         OS.FS.Close (Real_Stderr);
+      end if;
+
+      if Close_Stdin then
+         OS.FS.Close (Real_Stdin);
+      end if;
 
       GNAT.Task_Lock.Unlock;
       return Result;

testsuite/tests/os/process/redirections/test.adb

@@ -0,0 +1,71 @@
+with GNATCOLL.OS.Process;
+with GNATCOLL.OS.Process_Types;
+with GNATCOLL.OS.FS;
+with Test_Assert;
+with Ada.Strings.Unbounded; use Ada.Strings.Unbounded;
+with Ada.Command_Line;
+with GNAT.IO;
+
+function Test return Integer is
+   package A renames Test_Assert;
+   package IO renames GNAT.IO;
+   package OS renames GNATCOLL.OS;
+   package PT renames GNATCOLL.OS.Process_Types;
+   package FS renames GNATCOLL.OS.FS;
+
+   Args   : PT.Arguments;
+   Env    : PT.Environ;
+   Status : Integer;
+   Output : Unbounded_String;
+begin
+   PT.Inherit (Env);
+
+   if Ada.Command_Line.Argument_Count = 0 then
+      --  This the topelevel program that check redirections
+      IO.Put_Line ("Test redirection to null file");
+      PT.Add_Argument (Args, Ada.Command_Line.Command_Name);
+      PT.Add_Argument (Args, "to_dev_null");
+      Output := OS.Process.Run
+         (Args, Env, Status => Status, Stderr => FS.To_Stdout);
+      A.Assert (Status, 0, Msg => "program should return 0 as status");
+      --  This ensure that redirection of stdout and stderr to /dev/null by the
+      --  child process is not leaked on stdout and or stderr
+      A.Assert (To_String (Output), "");
+      PT.Deallocate (Args);
+
+      IO.Put_Line ("Test redirection of stderr to stdout");
+      PT.Add_Argument (Args, Ada.Command_Line.Command_Name);
+      PT.Add_Argument (Args, "to_stdout");
+      Output := OS.Process.Run
+         (Args, Env,
+          Status            => Status,
+          Stderr            => FS.Null_FD,
+          Strip             => True,
+          Universal_Newline => True);
+      A.Assert (Status, 0, Msg => "program should return 0 as status");
+      A.Assert
+         (To_String (Output), "hello stdout" & ASCII.LF & "hello stderr");
+
+      PT.Deallocate (Args);
+
+      return A.Report;
+
+   elsif Ada.Command_Line.Argument (1) = "to_dev_null" then
+      --  This the version of the program spawned by itself
+      PT.Add_Argument (Args, Ada.Command_Line.Command_Name);
+      PT.Add_Argument (Args, "write_to_stdout_and_stderr");
+      Status := OS.Process.Run
+         (Args, Env, Stdout => FS.Null_FD, Stderr => FS.To_Stdout);
+
+   elsif Ada.Command_Line.Argument (1) = "to_stdout" then
+      PT.Add_Argument (Args, Ada.Command_Line.Command_Name);
+      PT.Add_Argument (Args, "write_to_stdout_and_stderr");
+      Status := OS.Process.Run (Args, Env, Stderr => FS.To_Stdout);
+
+   elsif Ada.Command_Line.Argument (1) = "write_to_stdout_and_stderr" then
+      IO.Put_Line (IO.Standard_Output, "hello stdout");
+      IO.Put_Line (IO.Standard_Error, "hello stderr");
+   end if;
+
+   return 0;
+end Test;

testsuite/tests/os/process/redirections/test.yaml

@@ -0,0 +1 @@
+title: GNATCOLL.OS.Process Redirections test