Subversion Repositories openrisc

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

--                                                                          --

--                         GNAT LIBRARY COMPONENTS                          --

--                                                                          --

--                      G N A T . E X P E C T . T T Y                       --

--                                                                          --

--                                 S p e c                                  --

--                                                                          --

--                    Copyright (C) 2000-2011, AdaCore                      --

--                                                                          --

-- GNAT is free software;  you can  redistribute it  and/or modify it under --

-- terms of the  GNU General Public License as published  by the Free Soft- --

-- ware  Foundation;  either version 3,  or (at your option) any later ver- --

-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --

-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --

-- or FITNESS FOR A PARTICULAR PURPOSE.                                     --

--                                                                          --

-- As a special exception under Section 7 of GPL version 3, you are granted --

-- additional permissions described in the GCC Runtime Library Exception,   --

-- version 3.1, as published by the Free Software Foundation.               --

--                                                                          --

-- You should have received a copy of the GNU General Public License and    --

-- a copy of the GCC Runtime Library Exception along with this program;     --

-- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --

-- <http://www.gnu.org/licenses/>.                                          --

--                                                                          --

-- GNAT was originally developed  by the GNAT team at  New York University. --

-- Extensive contributions were provided by Ada Core Technologies Inc.      --

--                                                                          --

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

with GNAT.OS_Lib; use GNAT.OS_Lib;

with System; use System;

package body GNAT.Expect.TTY is

   On_Windows : constant Boolean := Directory_Separator = '\';

   --  True when on Windows

   -----------

   -- Close --

   -----------

   overriding procedure Close

     (Descriptor : in out TTY_Process_Descriptor;

      Status     : out Integer)

   is

      procedure Terminate_Process (Process : System.Address);

      pragma Import (C, Terminate_Process, "__gnat_terminate_process");

      function Waitpid (Process : System.Address) return Integer;

      pragma Import (C, Waitpid, "__gnat_waitpid");

      --  Wait for a specific process id, and return its exit code

      procedure Free_Process (Process : System.Address);

      pragma Import (C, Free_Process, "__gnat_free_process");

      procedure Close_TTY (Process : System.Address);

      pragma Import (C, Close_TTY, "__gnat_close_tty");

   begin

      --  If we haven't already closed the process

      if Descriptor.Process = System.Null_Address then

         Status := -1;

      else

         if Descriptor.Input_Fd /= Invalid_FD then

            Close (Descriptor.Input_Fd);

         end if;

         if Descriptor.Error_Fd /= Descriptor.Output_Fd

           and then Descriptor.Error_Fd /= Invalid_FD

         then

            Close (Descriptor.Error_Fd);

         end if;

         if Descriptor.Output_Fd /= Invalid_FD then

            Close (Descriptor.Output_Fd);

         end if;

         --  Send a Ctrl-C to the process first. This way, if the

         --  launched process is a "sh" or "cmd", the child processes

         --  will get terminated as well. Otherwise, terminating the

         --  main process brutally will leave the children running.

         Interrupt (Descriptor);

         delay 0.05;

         Terminate_Process (Descriptor.Process);

         Status := Waitpid (Descriptor.Process);

         if not On_Windows then

            Close_TTY (Descriptor.Process);

         end if;

         Free_Process (Descriptor.Process'Address);

         Descriptor.Process := System.Null_Address;

         GNAT.OS_Lib.Free (Descriptor.Buffer);

         Descriptor.Buffer_Size := 0;

      end if;

   end Close;

   overriding procedure Close (Descriptor : in out TTY_Process_Descriptor) is

      Status : Integer;

   begin

      Close (Descriptor, Status);

   end Close;

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

   -- Close_Pseudo_Descriptor --

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

   procedure Close_Pseudo_Descriptor

     (Descriptor : in out TTY_Process_Descriptor)

   is

   begin

      Descriptor.Buffer_Size := 0;

      GNAT.OS_Lib.Free (Descriptor.Buffer);

   end Close_Pseudo_Descriptor;

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

   -- Interrupt --

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

   overriding procedure Interrupt

     (Descriptor : in out TTY_Process_Descriptor)

   is

      procedure Internal (Process : System.Address);

      pragma Import (C, Internal, "__gnat_interrupt_process");

   begin

      if Descriptor.Process /= System.Null_Address then

         Internal (Descriptor.Process);

      end if;

   end Interrupt;

   procedure Interrupt (Pid : Integer) is

      procedure Internal (Pid : Integer);

      pragma Import (C, Internal, "__gnat_interrupt_pid");

   begin

      Internal (Pid);

   end Interrupt;

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

   -- Pseudo_Descriptor --

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

   procedure Pseudo_Descriptor

     (Descriptor  : out TTY_Process_Descriptor'Class;

      TTY         : GNAT.TTY.TTY_Handle;

      Buffer_Size : Natural := 4096) is

   begin

      Descriptor.Input_Fd  := GNAT.TTY.TTY_Descriptor (TTY);

      Descriptor.Output_Fd := Descriptor.Input_Fd;

      --  Create the buffer

      Descriptor.Buffer_Size := Buffer_Size;

      if Buffer_Size /= 0 then

         Descriptor.Buffer := new String (1 .. Positive (Buffer_Size));

      end if;

   end Pseudo_Descriptor;

   ----------

   -- Send --

   ----------

   overriding procedure Send

     (Descriptor   : in out TTY_Process_Descriptor;

      Str          : String;

      Add_LF       : Boolean := True;

      Empty_Buffer : Boolean := False)

   is

      Header : String (1 .. 5);

      Length : Natural;

      Ret    : Natural;

      procedure Internal

        (Process : System.Address;

         S       : in out String;

         Length  : Natural;

         Ret     : out Natural);

      pragma Import (C, Internal, "__gnat_send_header");

   begin

      Length := Str'Length;

      if Add_LF then

         Length := Length + 1;

      end if;

      Internal (Descriptor.Process, Header, Length, Ret);

      if Ret = 1 then

         --  Need to use the header

         GNAT.Expect.Send

           (Process_Descriptor (Descriptor),

            Header & Str, Add_LF, Empty_Buffer);

      else

         GNAT.Expect.Send

           (Process_Descriptor (Descriptor),

            Str, Add_LF, Empty_Buffer);

      end if;

   end Send;

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

   -- Set_Size --

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

   procedure Set_Size

     (Descriptor : in out TTY_Process_Descriptor'Class;

      Rows       : Natural;

      Columns    : Natural)

   is

      procedure Internal (Process : System.Address; R, C : Integer);

      pragma Import (C, Internal, "__gnat_setup_winsize");

   begin

      if Descriptor.Process /= System.Null_Address then

         Internal (Descriptor.Process, Rows, Columns);

      end if;

   end Set_Size;

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

   -- Set_Up_Communications --

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

   overriding procedure Set_Up_Communications

     (Pid        : in out TTY_Process_Descriptor;

      Err_To_Out : Boolean;

      Pipe1      : access Pipe_Type;

      Pipe2      : access Pipe_Type;

      Pipe3      : access Pipe_Type)

   is

      pragma Unreferenced (Err_To_Out, Pipe1, Pipe2, Pipe3);

      function Internal (Process : System.Address) return Integer;

      pragma Import (C, Internal, "__gnat_setup_communication");

   begin

      if Internal (Pid.Process'Address) /= 0 then

         raise Invalid_Process with "cannot setup communication.";

      end if;

   end Set_Up_Communications;

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

   -- Set_Up_Child_Communications --

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

   overriding procedure Set_Up_Child_Communications

     (Pid   : in out TTY_Process_Descriptor;

      Pipe1 : in out Pipe_Type;

      Pipe2 : in out Pipe_Type;

      Pipe3 : in out Pipe_Type;

      Cmd   : String;

      Args  : System.Address)

   is

      pragma Unreferenced (Pipe1, Pipe2, Pipe3, Cmd);

      function Internal

        (Process : System.Address; Argv : System.Address; Use_Pipes : Integer)

         return Process_Id;

      pragma Import (C, Internal, "__gnat_setup_child_communication");

   begin

      Pid.Pid := Internal (Pid.Process, Args, Boolean'Pos (Pid.Use_Pipes));

   end Set_Up_Child_Communications;

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

   -- Set_Up_Parent_Communications --

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

   overriding procedure Set_Up_Parent_Communications

     (Pid   : in out TTY_Process_Descriptor;

      Pipe1 : in out Pipe_Type;

      Pipe2 : in out Pipe_Type;

      Pipe3 : in out Pipe_Type)

   is

      pragma Unreferenced (Pipe1, Pipe2, Pipe3);

      procedure Internal

        (Process  : System.Address;

         Inputfp  : out File_Descriptor;

         Outputfp : out File_Descriptor;

         Errorfp  : out File_Descriptor;

         Pid      : out Process_Id);

      pragma Import (C, Internal, "__gnat_setup_parent_communication");

   begin

      Internal

        (Pid.Process, Pid.Input_Fd, Pid.Output_Fd, Pid.Error_Fd, Pid.Pid);

   end Set_Up_Parent_Communications;

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

   -- Set_Use_Pipes --

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

   procedure Set_Use_Pipes

     (Descriptor : in out TTY_Process_Descriptor;

      Use_Pipes  : Boolean) is

   begin

      Descriptor.Use_Pipes := Use_Pipes;

   end Set_Use_Pipes;

end GNAT.Expect.TTY;