-------------------------------------------------------------------------------
--
--  <STRONG>Copyright &copy; 2001, 2002 by Thomas Wolf.</STRONG>
--  <BLOCKQUOTE>
--    This piece of software is free software; you can redistribute it and/or
--    modify it under the terms of the  GNU General Public License as published
--    by the Free Software  Foundation; either version 2, or (at your option)
--    any later version. This software is distributed in the hope that it will
--    be useful, but <EM>without any warranty</EM>; without even the implied
--    warranty of <EM>merchantability or fitness for a particular purpose.</EM>
--    See the GNU General Public License for  more details. You should have
--    received a copy of the GNU General Public License with this distribution,
--    see file "<A HREF="GPL.txt">GPL.txt</A>". If not, write to the Free
--    Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307,
--    USA.
--  </BLOCKQUOTE>
--  <BLOCKQUOTE>
--    As a special exception from the GPL, if other files instantiate generics
--    from this unit, or you link this unit with other files to produce an
--    executable, this unit does not by itself cause the resulting executable
--    to be covered by the GPL. This exception does not however invalidate any
--    other reasons why the executable file might be covered by the GPL.
--  </BLOCKQUOTE>
--
--  <AUTHOR>
--    Thomas Wolf  (TW) <E_MAIL>
--  </AUTHOR>
--
--  <PURPOSE>
--    This is a thick binding to the @popen@ and @pclose@ routines available
--    on both Unix and Win32. It gives a convenient way to execute an external
--    program and pass it some input, or read its output.
--  </PURPOSE>
--
--  <TASKING>
--    Neither task- not abortion-safe. All operations here should be
--    considered <EM>potentially blocking</EM>.
--  </TASKING>
--
--  <NO_STORAGE>
--
--  <HISTORY>
--    26-APR-2002   TW  Initial version.
--    29-APR-2002   TW  Added auto-close feature, as well as the 'get_newline'
--                      work-around.
--    24-JUN-2002   TW  Changed 'End_Of_Stream' so that it doesn't use
--                      Std_IO.feof anymore but reads ahead. The reason is that
--                      I had cases where feof returned false, but the next
--                      read got Std_IO.EOF!
--  </HISTORY>
-------------------------------------------------------------------------------

pragma License (Modified_GPL);

with System;

package body Util.Pipes is

   use Interfaces.C;

   type Void_Ptr is new System.Address;

   package Std_IO is

      --  A thin binding to a part of C's stdio.h.

      EOF       : constant Interfaces.C.int;
      New_Line  : constant Interfaces.C.int;

      function popen
        (Command : in Interfaces.C.char_array;
         Mode    : in Interfaces.C.char_array)
        return C_File_Ptr;

      function pclose
        (File : in C_File_Ptr)
        return Interfaces.C.int;

      --  Note that both 'poen' and 'pclose' are *not* in the ISO standard!
      --  However, they're a common extension and are available in both
      --  Windows NT/2k and Linux. Also note that it doesn't matter in what
      --  header file these are defined: as long as they're in some library
      --  and have the right names, the linker can resolve them.

      function fgetc
        (File : in C_File_Ptr)
        return Interfaces.C.int;

      function fputc
        (Ch   : in Interfaces.C.int;
         File : in C_File_Ptr)
        return Interfaces.C.int;

      function fputs
        (String : in Interfaces.C.char_array;
         File   : in C_File_Ptr)
        return Interfaces.C.int;

      function fread
        (Buffer : in Void_Ptr;
         Size   : in Interfaces.C.size_t;
         N      : in Interfaces.C.size_t;
         File   : in C_File_Ptr)
        return Interfaces.C.size_t;

      function fwrite
        (Buffer : in Void_Ptr;
         Size   : in Interfaces.C.size_t;
         N      : in Interfaces.C.size_t;
         File   : in C_File_Ptr)
        return Interfaces.C.size_t;

      function ungetc
        (Ch   : in Interfaces.C.int;
         File : in C_File_Ptr)
        return Interfaces.C.int;

   private

      EOF : constant Interfaces.C.int := -1;

      pragma Import (C, popen);  --  Non-ISO
      pragma Import (C, pclose); --  Non-ISO
      pragma Import (C, fgetc);
      pragma Import (C, fputc);
      pragma Import (C, fputs);
      pragma Import (C, fread);
      pragma Import (C, fwrite);
      pragma Import (C, ungetc);

      --  Note that although some of these may be implemented as macros in
      --  <stdio.h>, the ISO C standard requires that they also be available
      --  as real functions. Hence we may import them directly.

      pragma Linker_Options ("util-nl.o");

      function Get_NL return Interfaces.C.int;
      pragma Import (C, Get_NL, "get_newline");

      New_Line : constant Interfaces.C.int := Get_NL;
      --  '\n' is replaced at compile-time by a C compiler. Hence we cannot
      --  use fputs (To_C ("\n")) to generate whatever C expects as a newline.
      --  Therefore, we have a little C wrapper which just returns '\n', and
      --  we remember that value here.

   end Std_IO;

   ----------------------------------------------------------------------------

   procedure Check
     (Stream : in Pipe_Stream;
      Mode   : in Stream_Mode)
   is
   begin
      if Stream.F = Null_Ptr then raise Use_Error;  end if;
      if Stream.Mode /= Mode then raise Mode_Error; end if;
   end Check;

   ----------------------------------------------------------------------------

   procedure Open
     (Stream  : in out Pipe_Stream;
      Command : in     String;
      Mode    : in     Stream_Mode;
      Close   : in     Boolean := True;
      Std_In  : in     String  := "")
   is
   begin
      if Stream.F /= Null_Ptr then raise Use_Error; end if;
      Stream.Mode := Mode;
      if Mode = In_Stream then
         if Std_In'Last < Std_In'First then
            Stream.F :=
              Std_IO.popen (Interfaces.C.To_C (Command),
                            Interfaces.C.To_C ("r"));
         else
            --  This works well under Win NT/2k. I don't know about other
            --  systems, but I'd expect it to work, too, as long as the
            --  system's default shell uses '<' for input redirection.
            Stream.F :=
              Std_IO.popen (Interfaces.C.To_C (Command & " <" & Std_In),
                            Interfaces.C.To_C ("r"));
         end if;
      else
         Stream.F := Std_IO.popen (Interfaces.C.To_C (Command),
                                   Interfaces.C.To_C ("w"));
      end if;
      if Stream.F = Null_Ptr then raise Name_Error; end if;
      Stream.Close_It := Close or Mode = Out_Stream;
   end Open;

   procedure Close
     (Stream    : in out Pipe_Stream;
      Exit_Code :    out Integer)
   is
   begin
      if Stream.F = Null_Ptr then raise Use_Error; end if;
      Exit_Code := Integer (Std_IO.pclose (Stream.F));
      Stream.F := Null_Ptr;
   end Close;

   function Is_Open
     (Stream : in Pipe_Stream)
     return Boolean
   is
   begin
      return Stream.F /= Null_Ptr;
   end Is_Open;

   function Unchecked_EOF
     (Stream : in Pipe_Stream)
     return Boolean
   is
      Res    : Interfaces.C.int;
      Result : Boolean;
   begin
      --  It appears that Std_IO.feof not always works... I had cases where it
      --  returned False, but the next read raised End_Error because it got
      --  Std_IO.EOF.
      Res    := Std_IO.fgetc (Stream.F);
      Result := Res = Std_IO.EOF;
      if not Result then
         Res := Std_IO.ungetc (Res, Stream.F);
      end if;
      return Result;
   end Unchecked_EOF;

   function End_Of_Stream
     (Stream : in Pipe_Stream)
     return Boolean
   is
   begin
      Check (Stream, In_Stream);
      return Unchecked_EOF (Stream);
   end End_Of_Stream;

   procedure Read
     (Stream : in out Pipe_Stream;
      Item   :    out Ada.Streams.Stream_Element_Array;
      Last   :    out Ada.Streams.Stream_Element_Offset)
   is
   begin
      Check (Stream, In_Stream);
      if Item'Length = 0 then
         Last := Item'Last;
         return;
      end if;
      declare
         N  : Interfaces.C.size_t;
         use type Ada.Streams.Stream_Element_Offset;
      begin
         if Unchecked_EOF (Stream) then raise End_Error; end if;
         N := Std_IO.fread (Void_Ptr (Item (Item'First)'Address),
                            Item (Item'First)'Size / 8, Item'Length,
                            Stream.F);
         Last := Item'First + Ada.Streams.Stream_Element_Offset (N) - 1;
      end;
   end Read;

   procedure Write
     (Stream : in out Pipe_Stream;
      Item   : in     Ada.Streams.Stream_Element_Array)
   is
   begin
      Check (Stream, Out_Stream);
      if Item'Length > 0 then
         declare
            N  : Interfaces.C.size_t;
         begin
            N := Std_IO.fwrite (Void_Ptr (Item (Item'First)'Address),
                                Item (Item'First)'Size / 8, Item'Length,
                                Stream.F);
            if N < Item'Length then raise Device_Error; end if;
         end;
      end if;
   end Write;

   procedure Put
     (Stream : in Pipe_Stream;
      Text   : in String)
   is
      Res : Interfaces.C.int;
   begin
      Check (Stream, Out_Stream);
      Res := Std_IO.fputs (Interfaces.C.To_C (Text), Stream.F);
      if Res < 0 then raise Device_Error; end if;
   end Put;

   procedure Put
     (Stream : in Pipe_Stream;
      Ch     : in Character)
   is
      Res : Interfaces.C.int;
   begin
      Check (Stream, Out_Stream);
      Res := Std_IO.fputc (Character'Pos (Ch), Stream.F);
      if Res = Std_IO.EOF then raise Device_Error; end if;
   end Put;

   procedure Put_Line
     (Stream : in Pipe_Stream;
      Text   : in String)
   is
      Res : Interfaces.C.int;
   begin
      Put (Stream, Text);
      Res := Std_IO.fputc (Std_IO.New_Line, Stream.F);
      if Res = Std_IO.EOF then raise Device_Error; end if;
   end Put_Line;

   procedure Unchecked_Get
     (Stream : in     Pipe_Stream;
      Ch     :    out Character)
   is
      Res : Interfaces.C.int;
   begin
      loop
         Res := Std_IO.fgetc (Stream.F);
         exit when Res /= Std_IO.New_Line;
      end loop;
      if Res = Std_IO.EOF then raise End_Error; end if;
      Ch := Character'Val (Res);
   end Unchecked_Get;

   procedure Get
     (Stream : in     Pipe_Stream;
      Ch     :    out Character)
   is
   begin
      Check (Stream, In_Stream);
      Unchecked_Get (Stream, Ch);
   end Get;

   procedure Get
     (Stream : in     Pipe_Stream;
      Buffer :    out String)
   is
   begin
      Check (Stream, In_Stream);
      for I in Buffer'Range loop
         Unchecked_Get (Stream, Buffer (I));
      end loop;
   end Get;

   procedure Unchecked_Get_Line
     (Stream : in     Pipe_Stream;
      Buffer :    out String;
      Last   :    out Natural)
   is
   begin
      if Buffer'Last < Buffer'First then
         Last := Buffer'Last; return;
      end if;
      Last := Buffer'First - 1;
      declare
         Res : Interfaces.C.int;
      begin
         while Last < Buffer'Last loop
            Res := Std_IO.fgetc (Stream.F);
            exit when Res = Std_IO.New_Line or else Res = Std_IO.EOF;
            Last := Last + 1;
            Buffer (Last) := Character'Val (Res);
         end loop;
         if Last < Buffer'First and then Res = Std_IO.EOF then
            raise End_Error;
         end if;
      end;
   end Unchecked_Get_Line;

   procedure Get_Line
     (Stream : in     Pipe_Stream;
      Buffer :    out String;
      Last   :    out Natural)
   is
   begin
      Check (Stream, In_Stream);
      Unchecked_Get_Line (Stream, Buffer, Last);
   end Get_Line;

   function Unchecked_Get_Line
     (Stream : in Pipe_Stream)
     return String
   is
      Buffer : String (1 .. 100);
      Last   : Natural;
   begin
      Unchecked_Get_Line (Stream, Buffer, Last);
      if Last < Buffer'Last or else Unchecked_EOF (Stream) then
         return Buffer (1 .. Last);
      end if;
      return Buffer & Unchecked_Get_Line (Stream);
   end Unchecked_Get_Line;

   function Get_Line
     (Stream : in Pipe_Stream)
     return String
   is
   begin
      Check (Stream, In_Stream);
      return Unchecked_Get_Line (Stream);
   end Get_Line;

   ----------------------------------------------------------------------------
   --  Automatic closing.

   procedure Finalize (C : in out Closer)
   is
   begin
      if C.Stream.F /= Null_Ptr and then C.Stream.Close_It then
         declare
            Exit_Code : Integer;
         begin
            Close (C.Stream.all, Exit_Code);
         exception
            when others =>
               null;
         end;
      end if;
   end Finalize;

end Util.Pipes;
