gcc/ada/g-exptty.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT LIBRARY COMPONENTS                          --
   4 --                                                                          --
   5 --                      G N A T . E X P E C T . T T Y                       --
   6 --                                                                          --
   7 --                                 S p e c                                  --
   8 --                                                                          --
   9 --                    Copyright (C) 2000-2011, AdaCore                      --
  10 --                                                                          --
  11 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  12 -- terms of the  GNU General Public License as published  by the Free Soft- --
  13 -- ware  Foundation;  either version 3,  or (at your option) any later ver- --
  14 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  15 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  16 -- or FITNESS FOR A PARTICULAR PURPOSE.                                     --
  17 --                                                                          --
  18 -- As a special exception under Section 7 of GPL version 3, you are granted --
  19 -- additional permissions described in the GCC Runtime Library Exception,   --
  20 -- version 3.1, as published by the Free Software Foundation.               --
  21 --                                                                          --
  22 -- You should have received a copy of the GNU General Public License and    --
  23 -- a copy of the GCC Runtime Library Exception along with this program;     --
  24 -- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
  25 -- <http://www.gnu.org/licenses/>.                                          --
  26 --                                                                          --
  27 -- GNAT was originally developed  by the GNAT team at  New York University. --
  28 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  29 --                                                                          --
  30 ------------------------------------------------------------------------------
  31
  32 with GNAT.OS_Lib; use GNAT.OS_Lib;
  33
  34 with System; use System;
  35
  36 package body GNAT.Expect.TTY is
  37
  38    On_Windows : constant Boolean := Directory_Separator = '\';
  39    --  True when on Windows
  40
  41    -----------
  42    -- Close --
  43    -----------
  44
  45    overriding procedure Close
  46      (Descriptor : in out TTY_Process_Descriptor;
  47       Status     : out Integer)
  48    is
  49       procedure Terminate_Process (Process : System.Address);
  50       pragma Import (C, Terminate_Process, "__gnat_terminate_process");
  51
  52       function Waitpid (Process : System.Address) return Integer;
  53       pragma Import (C, Waitpid, "__gnat_waitpid");
  54       --  Wait for a specific process id, and return its exit code
  55
  56       procedure Free_Process (Process : System.Address);
  57       pragma Import (C, Free_Process, "__gnat_free_process");
  58
  59       procedure Close_TTY (Process : System.Address);
  60       pragma Import (C, Close_TTY, "__gnat_close_tty");
  61
  62    begin
  63       --  If we haven't already closed the process
  64
  65       if Descriptor.Process = System.Null_Address then
  66          Status := -1;
  67
  68       else
  69          if Descriptor.Input_Fd /= Invalid_FD then
  70             Close (Descriptor.Input_Fd);
  71          end if;
  72
  73          if Descriptor.Error_Fd /= Descriptor.Output_Fd
  74            and then Descriptor.Error_Fd /= Invalid_FD
  75          then
  76             Close (Descriptor.Error_Fd);
  77          end if;
  78
  79          if Descriptor.Output_Fd /= Invalid_FD then
  80             Close (Descriptor.Output_Fd);
  81          end if;
  82
  83          --  Send a Ctrl-C to the process first. This way, if the
  84          --  launched process is a "sh" or "cmd", the child processes
  85          --  will get terminated as well. Otherwise, terminating the
  86          --  main process brutally will leave the children running.
  87
  88          Interrupt (Descriptor);
  89          delay 0.05;
  90
  91          Terminate_Process (Descriptor.Process);
  92          Status := Waitpid (Descriptor.Process);
  93
  94          if not On_Windows then
  95             Close_TTY (Descriptor.Process);
  96          end if;
  97
  98          Free_Process (Descriptor.Process'Address);
  99          Descriptor.Process := System.Null_Address;
 100
 101          GNAT.OS_Lib.Free (Descriptor.Buffer);
 102          Descriptor.Buffer_Size := 0;
 103       end if;
 104    end Close;
 105
 106    overriding procedure Close (Descriptor : in out TTY_Process_Descriptor) is
 107       Status : Integer;
 108    begin
 109       Close (Descriptor, Status);
 110    end Close;
 111
 112    -----------------------------
 113    -- Close_Pseudo_Descriptor --
 114    -----------------------------
 115
 116    procedure Close_Pseudo_Descriptor
 117      (Descriptor : in out TTY_Process_Descriptor)
 118    is
 119    begin
 120       Descriptor.Buffer_Size := 0;
 121       GNAT.OS_Lib.Free (Descriptor.Buffer);
 122    end Close_Pseudo_Descriptor;
 123
 124    ---------------
 125    -- Interrupt --
 126    ---------------
 127
 128    overriding procedure Interrupt
 129      (Descriptor : in out TTY_Process_Descriptor)
 130    is
 131       procedure Internal (Process : System.Address);
 132       pragma Import (C, Internal, "__gnat_interrupt_process");
 133    begin
 134       if Descriptor.Process /= System.Null_Address then
 135          Internal (Descriptor.Process);
 136       end if;
 137    end Interrupt;
 138
 139    procedure Interrupt (Pid : Integer) is
 140       procedure Internal (Pid : Integer);
 141       pragma Import (C, Internal, "__gnat_interrupt_pid");
 142    begin
 143       Internal (Pid);
 144    end Interrupt;
 145
 146    -----------------------
 147    -- Pseudo_Descriptor --
 148    -----------------------
 149
 150    procedure Pseudo_Descriptor
 151      (Descriptor  : out TTY_Process_Descriptor'Class;
 152       TTY         : GNAT.TTY.TTY_Handle;
 153       Buffer_Size : Natural := 4096) is
 154    begin
 155       Descriptor.Input_Fd  := GNAT.TTY.TTY_Descriptor (TTY);
 156       Descriptor.Output_Fd := Descriptor.Input_Fd;
 157
 158       --  Create the buffer
 159
 160       Descriptor.Buffer_Size := Buffer_Size;
 161
 162       if Buffer_Size /= 0 then
 163          Descriptor.Buffer := new String (1 .. Positive (Buffer_Size));
 164       end if;
 165    end Pseudo_Descriptor;
 166
 167    ----------
 168    -- Send --
 169    ----------
 170
 171    overriding procedure Send
 172      (Descriptor   : in out TTY_Process_Descriptor;
 173       Str          : String;
 174       Add_LF       : Boolean := True;
 175       Empty_Buffer : Boolean := False)
 176    is
 177       Header : String (1 .. 5);
 178       Length : Natural;
 179       Ret    : Natural;
 180
 181       procedure Internal
 182         (Process : System.Address;
 183          S       : in out String;
 184          Length  : Natural;
 185          Ret     : out Natural);
 186       pragma Import (C, Internal, "__gnat_send_header");
 187
 188    begin
 189       Length := Str'Length;
 190
 191       if Add_LF then
 192          Length := Length + 1;
 193       end if;
 194
 195       Internal (Descriptor.Process, Header, Length, Ret);
 196
 197       if Ret = 1 then
 198
 199          --  Need to use the header
 200
 201          GNAT.Expect.Send
 202            (Process_Descriptor (Descriptor),
 203             Header & Str, Add_LF, Empty_Buffer);
 204
 205       else
 206          GNAT.Expect.Send
 207            (Process_Descriptor (Descriptor),
 208             Str, Add_LF, Empty_Buffer);
 209       end if;
 210    end Send;
 211
 212    --------------
 213    -- Set_Size --
 214    --------------
 215
 216    procedure Set_Size
 217      (Descriptor : in out TTY_Process_Descriptor'Class;
 218       Rows       : Natural;
 219       Columns    : Natural)
 220    is
 221       procedure Internal (Process : System.Address; R, C : Integer);
 222       pragma Import (C, Internal, "__gnat_setup_winsize");
 223    begin
 224       if Descriptor.Process /= System.Null_Address then
 225          Internal (Descriptor.Process, Rows, Columns);
 226       end if;
 227    end Set_Size;
 228
 229    ---------------------------
 230    -- Set_Up_Communications --
 231    ---------------------------
 232
 233    overriding procedure Set_Up_Communications
 234      (Pid        : in out TTY_Process_Descriptor;
 235       Err_To_Out : Boolean;
 236       Pipe1      : access Pipe_Type;
 237       Pipe2      : access Pipe_Type;
 238       Pipe3      : access Pipe_Type)
 239    is
 240       pragma Unreferenced (Err_To_Out, Pipe1, Pipe2, Pipe3);
 241
 242       function Internal (Process : System.Address) return Integer;
 243       pragma Import (C, Internal, "__gnat_setup_communication");
 244
 245    begin
 246       if Internal (Pid.Process'Address) /= 0 then
 247          raise Invalid_Process with "cannot setup communication.";
 248       end if;
 249    end Set_Up_Communications;
 250
 251    ---------------------------------
 252    -- Set_Up_Child_Communications --
 253    ---------------------------------
 254
 255    overriding procedure Set_Up_Child_Communications
 256      (Pid   : in out TTY_Process_Descriptor;
 257       Pipe1 : in out Pipe_Type;
 258       Pipe2 : in out Pipe_Type;
 259       Pipe3 : in out Pipe_Type;
 260       Cmd   : String;
 261       Args  : System.Address)
 262    is
 263       pragma Unreferenced (Pipe1, Pipe2, Pipe3, Cmd);
 264       function Internal
 265         (Process : System.Address; Argv : System.Address; Use_Pipes : Integer)
 266          return Process_Id;
 267       pragma Import (C, Internal, "__gnat_setup_child_communication");
 268
 269    begin
 270       Pid.Pid := Internal (Pid.Process, Args, Boolean'Pos (Pid.Use_Pipes));
 271    end Set_Up_Child_Communications;
 272
 273    ----------------------------------
 274    -- Set_Up_Parent_Communications --
 275    ----------------------------------
 276
 277    overriding procedure Set_Up_Parent_Communications
 278      (Pid   : in out TTY_Process_Descriptor;
 279       Pipe1 : in out Pipe_Type;
 280       Pipe2 : in out Pipe_Type;
 281       Pipe3 : in out Pipe_Type)
 282    is
 283       pragma Unreferenced (Pipe1, Pipe2, Pipe3);
 284
 285       procedure Internal
 286         (Process  : System.Address;
 287          Inputfp  : out File_Descriptor;
 288          Outputfp : out File_Descriptor;
 289          Errorfp  : out File_Descriptor;
 290          Pid      : out Process_Id);
 291       pragma Import (C, Internal, "__gnat_setup_parent_communication");
 292
 293    begin
 294       Internal
 295         (Pid.Process, Pid.Input_Fd, Pid.Output_Fd, Pid.Error_Fd, Pid.Pid);
 296    end Set_Up_Parent_Communications;
 297
 298    -------------------
 299    -- Set_Use_Pipes --
 300    -------------------
 301
 302    procedure Set_Use_Pipes
 303      (Descriptor : in out TTY_Process_Descriptor;
 304       Use_Pipes  : Boolean) is
 305    begin
 306       Descriptor.Use_Pipes := Use_Pipes;
 307    end Set_Use_Pipes;
 308
 309 end GNAT.Expect.TTY;