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-2014, 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_tty_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          --  Send a Ctrl-C to the process first. This way, if the launched
  70          --  process is a "sh" or "cmd", the child processes will get
  71          --  terminated as well. Otherwise, terminating the main process
  72          --  brutally will leave the children running.
  73
  74          --  Note: special characters are sent to the terminal to generate the
  75          --  signal, so this needs to be done while the file descriptors are
  76          --  still open (it used to be after the closes and that was wrong).
  77
  78          Interrupt (Descriptor);
  79          delay (0.05);
  80
  81          if Descriptor.Input_Fd /= Invalid_FD then
  82             Close (Descriptor.Input_Fd);
  83          end if;
  84
  85          if Descriptor.Error_Fd /= Descriptor.Output_Fd
  86            and then Descriptor.Error_Fd /= Invalid_FD
  87          then
  88             Close (Descriptor.Error_Fd);
  89          end if;
  90
  91          if Descriptor.Output_Fd /= Invalid_FD then
  92             Close (Descriptor.Output_Fd);
  93          end if;
  94
  95          Terminate_Process (Descriptor.Process);
  96          Status := Waitpid (Descriptor.Process);
  97
  98          if not On_Windows then
  99             Close_TTY (Descriptor.Process);
 100          end if;
 101
 102          Free_Process (Descriptor.Process'Address);
 103          Descriptor.Process := System.Null_Address;
 104
 105          GNAT.OS_Lib.Free (Descriptor.Buffer);
 106          Descriptor.Buffer_Size := 0;
 107       end if;
 108    end Close;
 109
 110    overriding procedure Close (Descriptor : in out TTY_Process_Descriptor) is
 111       Status : Integer;
 112    begin
 113       Close (Descriptor, Status);
 114    end Close;
 115
 116    -----------------------------
 117    -- Close_Pseudo_Descriptor --
 118    -----------------------------
 119
 120    procedure Close_Pseudo_Descriptor
 121      (Descriptor : in out TTY_Process_Descriptor)
 122    is
 123    begin
 124       Descriptor.Buffer_Size := 0;
 125       GNAT.OS_Lib.Free (Descriptor.Buffer);
 126    end Close_Pseudo_Descriptor;
 127
 128    ---------------
 129    -- Interrupt --
 130    ---------------
 131
 132    overriding procedure Interrupt
 133      (Descriptor : in out TTY_Process_Descriptor)
 134    is
 135       procedure Internal (Process : System.Address);
 136       pragma Import (C, Internal, "__gnat_interrupt_process");
 137    begin
 138       if Descriptor.Process /= System.Null_Address then
 139          Internal (Descriptor.Process);
 140       end if;
 141    end Interrupt;
 142
 143    procedure Interrupt (Pid : Integer) is
 144       procedure Internal (Pid : Integer);
 145       pragma Import (C, Internal, "__gnat_interrupt_pid");
 146    begin
 147       Internal (Pid);
 148    end Interrupt;
 149
 150    -----------------------
 151    -- Pseudo_Descriptor --
 152    -----------------------
 153
 154    procedure Pseudo_Descriptor
 155      (Descriptor  : out TTY_Process_Descriptor'Class;
 156       TTY         : GNAT.TTY.TTY_Handle;
 157       Buffer_Size : Natural := 4096) is
 158    begin
 159       Descriptor.Input_Fd  := GNAT.TTY.TTY_Descriptor (TTY);
 160       Descriptor.Output_Fd := Descriptor.Input_Fd;
 161
 162       --  Create the buffer
 163
 164       Descriptor.Buffer_Size := Buffer_Size;
 165
 166       if Buffer_Size /= 0 then
 167          Descriptor.Buffer := new String (1 .. Positive (Buffer_Size));
 168       end if;
 169    end Pseudo_Descriptor;
 170
 171    ----------
 172    -- Send --
 173    ----------
 174
 175    overriding procedure Send
 176      (Descriptor   : in out TTY_Process_Descriptor;
 177       Str          : String;
 178       Add_LF       : Boolean := True;
 179       Empty_Buffer : Boolean := False)
 180    is
 181       Header : String (1 .. 5);
 182       Length : Natural;
 183       Ret    : Natural;
 184
 185       procedure Internal
 186         (Process : System.Address;
 187          S       : in out String;
 188          Length  : Natural;
 189          Ret     : out Natural);
 190       pragma Import (C, Internal, "__gnat_send_header");
 191
 192    begin
 193       Length := Str'Length;
 194
 195       if Add_LF then
 196          Length := Length + 1;
 197       end if;
 198
 199       Internal (Descriptor.Process, Header, Length, Ret);
 200
 201       if Ret = 1 then
 202
 203          --  Need to use the header
 204
 205          GNAT.Expect.Send
 206            (Process_Descriptor (Descriptor),
 207             Header & Str, Add_LF, Empty_Buffer);
 208
 209       else
 210          GNAT.Expect.Send
 211            (Process_Descriptor (Descriptor),
 212             Str, Add_LF, Empty_Buffer);
 213       end if;
 214    end Send;
 215
 216    --------------
 217    -- Set_Size --
 218    --------------
 219
 220    procedure Set_Size
 221      (Descriptor : in out TTY_Process_Descriptor'Class;
 222       Rows       : Natural;
 223       Columns    : Natural)
 224    is
 225       procedure Internal (Process : System.Address; R, C : Integer);
 226       pragma Import (C, Internal, "__gnat_setup_winsize");
 227    begin
 228       if Descriptor.Process /= System.Null_Address then
 229          Internal (Descriptor.Process, Rows, Columns);
 230       end if;
 231    end Set_Size;
 232
 233    ---------------------------
 234    -- Set_Up_Communications --
 235    ---------------------------
 236
 237    overriding procedure Set_Up_Communications
 238      (Pid        : in out TTY_Process_Descriptor;
 239       Err_To_Out : Boolean;
 240       Pipe1      : access Pipe_Type;
 241       Pipe2      : access Pipe_Type;
 242       Pipe3      : access Pipe_Type)
 243    is
 244       pragma Unreferenced (Err_To_Out, Pipe1, Pipe2, Pipe3);
 245
 246       function Internal (Process : System.Address) return Integer;
 247       pragma Import (C, Internal, "__gnat_setup_communication");
 248
 249    begin
 250       if Internal (Pid.Process'Address) /= 0 then
 251          raise Invalid_Process with "cannot setup communication.";
 252       end if;
 253    end Set_Up_Communications;
 254
 255    ---------------------------------
 256    -- Set_Up_Child_Communications --
 257    ---------------------------------
 258
 259    overriding procedure Set_Up_Child_Communications
 260      (Pid   : in out TTY_Process_Descriptor;
 261       Pipe1 : in out Pipe_Type;
 262       Pipe2 : in out Pipe_Type;
 263       Pipe3 : in out Pipe_Type;
 264       Cmd   : String;
 265       Args  : System.Address)
 266    is
 267       pragma Unreferenced (Pipe1, Pipe2, Pipe3, Cmd);
 268       function Internal
 269         (Process : System.Address; Argv : System.Address; Use_Pipes : Integer)
 270          return Process_Id;
 271       pragma Import (C, Internal, "__gnat_setup_child_communication");
 272
 273    begin
 274       Pid.Pid := Internal (Pid.Process, Args, Boolean'Pos (Pid.Use_Pipes));
 275    end Set_Up_Child_Communications;
 276
 277    ----------------------------------
 278    -- Set_Up_Parent_Communications --
 279    ----------------------------------
 280
 281    overriding procedure Set_Up_Parent_Communications
 282      (Pid   : in out TTY_Process_Descriptor;
 283       Pipe1 : in out Pipe_Type;
 284       Pipe2 : in out Pipe_Type;
 285       Pipe3 : in out Pipe_Type)
 286    is
 287       pragma Unreferenced (Pipe1, Pipe2, Pipe3);
 288
 289       procedure Internal
 290         (Process  : System.Address;
 291          Inputfp  : out File_Descriptor;
 292          Outputfp : out File_Descriptor;
 293          Errorfp  : out File_Descriptor;
 294          Pid      : out Process_Id);
 295       pragma Import (C, Internal, "__gnat_setup_parent_communication");
 296
 297    begin
 298       Internal
 299         (Pid.Process, Pid.Input_Fd, Pid.Output_Fd, Pid.Error_Fd, Pid.Pid);
 300    end Set_Up_Parent_Communications;
 301
 302    -------------------
 303    -- Set_Use_Pipes --
 304    -------------------
 305
 306    procedure Set_Use_Pipes
 307      (Descriptor : in out TTY_Process_Descriptor;
 308       Use_Pipes  : Boolean) is
 309    begin
 310       Descriptor.Use_Pipes := Use_Pipes;
 311    end Set_Use_Pipes;
 312
 313 end GNAT.Expect.TTY;