gcc/ada/libgnat/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-2017, 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    -- Terminate_Process --
 152    -----------------------
 153
 154    procedure Terminate_Process (Pid : Integer) is
 155       procedure Internal (Pid : Integer);
 156       pragma Import (C, Internal, "__gnat_terminate_pid");
 157    begin
 158       Internal (Pid);
 159    end Terminate_Process;
 160
 161    -----------------------
 162    -- Pseudo_Descriptor --
 163    -----------------------
 164
 165    procedure Pseudo_Descriptor
 166      (Descriptor  : out TTY_Process_Descriptor'Class;
 167       TTY         : GNAT.TTY.TTY_Handle;
 168       Buffer_Size : Natural := 4096) is
 169    begin
 170       Descriptor.Input_Fd  := GNAT.TTY.TTY_Descriptor (TTY);
 171       Descriptor.Output_Fd := Descriptor.Input_Fd;
 172
 173       --  Create the buffer
 174
 175       Descriptor.Buffer_Size := Buffer_Size;
 176
 177       if Buffer_Size /= 0 then
 178          Descriptor.Buffer := new String (1 .. Positive (Buffer_Size));
 179       end if;
 180    end Pseudo_Descriptor;
 181
 182    ----------
 183    -- Send --
 184    ----------
 185
 186    overriding procedure Send
 187      (Descriptor   : in out TTY_Process_Descriptor;
 188       Str          : String;
 189       Add_LF       : Boolean := True;
 190       Empty_Buffer : Boolean := False)
 191    is
 192       Header : String (1 .. 5);
 193       Length : Natural;
 194       Ret    : Natural;
 195
 196       procedure Internal
 197         (Process : System.Address;
 198          S       : in out String;
 199          Length  : Natural;
 200          Ret     : out Natural);
 201       pragma Import (C, Internal, "__gnat_send_header");
 202
 203    begin
 204       Length := Str'Length;
 205
 206       if Add_LF then
 207          Length := Length + 1;
 208       end if;
 209
 210       Internal (Descriptor.Process, Header, Length, Ret);
 211
 212       if Ret = 1 then
 213
 214          --  Need to use the header
 215
 216          GNAT.Expect.Send
 217            (Process_Descriptor (Descriptor),
 218             Header & Str, Add_LF, Empty_Buffer);
 219
 220       else
 221          GNAT.Expect.Send
 222            (Process_Descriptor (Descriptor),
 223             Str, Add_LF, Empty_Buffer);
 224       end if;
 225    end Send;
 226
 227    --------------
 228    -- Set_Size --
 229    --------------
 230
 231    procedure Set_Size
 232      (Descriptor : in out TTY_Process_Descriptor'Class;
 233       Rows       : Natural;
 234       Columns    : Natural)
 235    is
 236       procedure Internal (Process : System.Address; R, C : Integer);
 237       pragma Import (C, Internal, "__gnat_setup_winsize");
 238    begin
 239       if Descriptor.Process /= System.Null_Address then
 240          Internal (Descriptor.Process, Rows, Columns);
 241       end if;
 242    end Set_Size;
 243
 244    ---------------------------
 245    -- Set_Up_Communications --
 246    ---------------------------
 247
 248    overriding procedure Set_Up_Communications
 249      (Pid        : in out TTY_Process_Descriptor;
 250       Err_To_Out : Boolean;
 251       Pipe1      : access Pipe_Type;
 252       Pipe2      : access Pipe_Type;
 253       Pipe3      : access Pipe_Type)
 254    is
 255       pragma Unreferenced (Err_To_Out, Pipe1, Pipe2, Pipe3);
 256
 257       function Internal (Process : System.Address) return Integer;
 258       pragma Import (C, Internal, "__gnat_setup_communication");
 259
 260    begin
 261       if Internal (Pid.Process'Address) /= 0 then
 262          raise Invalid_Process with "cannot setup communication.";
 263       end if;
 264    end Set_Up_Communications;
 265
 266    ---------------------------------
 267    -- Set_Up_Child_Communications --
 268    ---------------------------------
 269
 270    overriding procedure Set_Up_Child_Communications
 271      (Pid   : in out TTY_Process_Descriptor;
 272       Pipe1 : in out Pipe_Type;
 273       Pipe2 : in out Pipe_Type;
 274       Pipe3 : in out Pipe_Type;
 275       Cmd   : String;
 276       Args  : System.Address)
 277    is
 278       pragma Unreferenced (Pipe1, Pipe2, Pipe3, Cmd);
 279       function Internal
 280         (Process : System.Address; Argv : System.Address; Use_Pipes : Integer)
 281          return Process_Id;
 282       pragma Import (C, Internal, "__gnat_setup_child_communication");
 283
 284    begin
 285       Pid.Pid := Internal (Pid.Process, Args, Boolean'Pos (Pid.Use_Pipes));
 286    end Set_Up_Child_Communications;
 287
 288    ----------------------------------
 289    -- Set_Up_Parent_Communications --
 290    ----------------------------------
 291
 292    overriding procedure Set_Up_Parent_Communications
 293      (Pid   : in out TTY_Process_Descriptor;
 294       Pipe1 : in out Pipe_Type;
 295       Pipe2 : in out Pipe_Type;
 296       Pipe3 : in out Pipe_Type)
 297    is
 298       pragma Unreferenced (Pipe1, Pipe2, Pipe3);
 299
 300       procedure Internal
 301         (Process  : System.Address;
 302          Inputfp  : out File_Descriptor;
 303          Outputfp : out File_Descriptor;
 304          Errorfp  : out File_Descriptor;
 305          Pid      : out Process_Id);
 306       pragma Import (C, Internal, "__gnat_setup_parent_communication");
 307
 308    begin
 309       Internal
 310         (Pid.Process, Pid.Input_Fd, Pid.Output_Fd, Pid.Error_Fd, Pid.Pid);
 311    end Set_Up_Parent_Communications;
 312
 313    -------------------
 314    -- Set_Use_Pipes --
 315    -------------------
 316
 317    procedure Set_Use_Pipes
 318      (Descriptor : in out TTY_Process_Descriptor;
 319       Use_Pipes  : Boolean) is
 320    begin
 321       Descriptor.Use_Pipes := Use_Pipes;
 322    end Set_Use_Pipes;
 323
 324 end GNAT.Expect.TTY;