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;