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-2020, 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    function Waitpid
  42      (Process  : System.Address;
  43       Blocking : Integer) return Integer;
  44    pragma Import (C, Waitpid, "__gnat_tty_waitpid");
  45    --  Wait for a specific process id, and return its exit code
  46
  47    ------------------------
  48    -- Is_Process_Running --
  49    ------------------------
  50
  51    function Is_Process_Running
  52      (Descriptor : in out TTY_Process_Descriptor) return Boolean
  53    is
  54    begin
  55       if Descriptor.Process = System.Null_Address then
  56          return False;
  57       end if;
  58
  59       Descriptor.Exit_Status := Waitpid (Descriptor.Process, Blocking => 0);
  60
  61       return Descriptor.Exit_Status = Still_Active;
  62    end Is_Process_Running;
  63
  64    -----------
  65    -- Close --
  66    -----------
  67
  68    overriding procedure Close
  69      (Descriptor : in out TTY_Process_Descriptor;
  70       Status     : out Integer)
  71    is
  72       procedure Terminate_Process (Process : System.Address);
  73       pragma Import (C, Terminate_Process, "__gnat_terminate_process");
  74
  75       procedure Free_Process (Process : System.Address);
  76       pragma Import (C, Free_Process, "__gnat_free_process");
  77
  78    begin
  79       --  If we haven't already closed the process
  80
  81       if Descriptor.Process = System.Null_Address then
  82          Status := Descriptor.Exit_Status;
  83
  84       else
  85          --  Send a Ctrl-C to the process first. This way, if the launched
  86          --  process is a "sh" or "cmd", the child processes will get
  87          --  terminated as well. Otherwise, terminating the main process
  88          --  brutally will leave the children running.
  89
  90          --  Note: special characters are sent to the terminal to generate the
  91          --  signal, so this needs to be done while the file descriptors are
  92          --  still open (it used to be after the closes and that was wrong).
  93
  94          Close_Input (Descriptor);
  95
  96          if Descriptor.Error_Fd /= Descriptor.Output_Fd
  97            and then Descriptor.Error_Fd /= Invalid_FD
  98          then
  99             Close (Descriptor.Error_Fd);
 100          end if;
 101
 102          if Descriptor.Output_Fd /= Invalid_FD then
 103             Close (Descriptor.Output_Fd);
 104          end if;
 105
 106          if Descriptor.Exit_Status = Still_Active then
 107             Status := Waitpid (Descriptor.Process, Blocking => 0);
 108
 109             if Status = Still_Active then
 110                --  In theory the process might have died since the check. In
 111                --  practice the following calls should not cause any issue.
 112
 113                Interrupt (Descriptor);
 114                delay (0.05);
 115                Terminate_Process (Descriptor.Process);
 116                Status := Waitpid (Descriptor.Process, Blocking => 1);
 117                Descriptor.Exit_Status := Status;
 118             end if;
 119
 120          else
 121             --  If Exit_Status is not STILL_ACTIVE just retrieve the saved
 122             --  exit status.
 123
 124             Status := Descriptor.Exit_Status;
 125          end if;
 126
 127          Free_Process (Descriptor.Process'Address);
 128          Descriptor.Process := System.Null_Address;
 129
 130          GNAT.OS_Lib.Free (Descriptor.Buffer);
 131          Descriptor.Buffer_Size := 0;
 132       end if;
 133    end Close;
 134
 135    overriding procedure Close (Descriptor : in out TTY_Process_Descriptor) is
 136       Status : Integer;
 137    begin
 138       Close (Descriptor, Status);
 139    end Close;
 140
 141    -----------------
 142    -- Close_Input --
 143    -----------------
 144
 145    overriding procedure Close_Input
 146      (Descriptor : in out TTY_Process_Descriptor)
 147    is
 148       function TTY_FD
 149         (Handle : System.Address) return GNAT.OS_Lib.File_Descriptor;
 150       pragma Import (C, TTY_FD, "__gnat_tty_fd");
 151
 152       procedure Close_TTY (Process : System.Address);
 153       pragma Import (C, Close_TTY, "__gnat_close_tty");
 154
 155    begin
 156       if not On_Windows and then Descriptor.Process /= System.Null_Address then
 157          --  Check whether input/output/error streams use master descriptor and
 158          --  reset corresponding members.
 159
 160          if Descriptor.Input_Fd = TTY_FD (Descriptor.Process) then
 161             Descriptor.Input_Fd := Invalid_FD;
 162          end if;
 163
 164          if Descriptor.Output_Fd = TTY_FD (Descriptor.Process) then
 165             Descriptor.Output_Fd := Invalid_FD;
 166          end if;
 167
 168          if Descriptor.Error_Fd = TTY_FD (Descriptor.Process) then
 169             Descriptor.Error_Fd := Invalid_FD;
 170          end if;
 171
 172          --  Close master descriptor.
 173
 174          Close_TTY (Descriptor.Process);
 175       end if;
 176
 177       --  Call parent's implementation to close all remaining descriptors.
 178
 179       Process_Descriptor (Descriptor).Close_Input;
 180    end Close_Input;
 181
 182    -----------------------------
 183    -- Close_Pseudo_Descriptor --
 184    -----------------------------
 185
 186    procedure Close_Pseudo_Descriptor
 187      (Descriptor : in out TTY_Process_Descriptor)
 188    is
 189    begin
 190       Descriptor.Buffer_Size := 0;
 191       GNAT.OS_Lib.Free (Descriptor.Buffer);
 192    end Close_Pseudo_Descriptor;
 193
 194    ---------------
 195    -- Interrupt --
 196    ---------------
 197
 198    overriding procedure Interrupt
 199      (Descriptor : in out TTY_Process_Descriptor)
 200    is
 201       procedure Internal (Process : System.Address);
 202       pragma Import (C, Internal, "__gnat_interrupt_process");
 203    begin
 204       if Descriptor.Process /= System.Null_Address then
 205          Internal (Descriptor.Process);
 206       end if;
 207    end Interrupt;
 208
 209    procedure Interrupt (Pid : Integer) is
 210       procedure Internal (Pid : Integer);
 211       pragma Import (C, Internal, "__gnat_interrupt_pid");
 212    begin
 213       Internal (Pid);
 214    end Interrupt;
 215
 216    -----------------------
 217    -- Terminate_Process --
 218    -----------------------
 219
 220    procedure Terminate_Process (Pid : Integer) is
 221       procedure Internal (Pid : Integer);
 222       pragma Import (C, Internal, "__gnat_terminate_pid");
 223    begin
 224       Internal (Pid);
 225    end Terminate_Process;
 226
 227    -----------------------
 228    -- Pseudo_Descriptor --
 229    -----------------------
 230
 231    procedure Pseudo_Descriptor
 232      (Descriptor  : out TTY_Process_Descriptor'Class;
 233       TTY         : GNAT.TTY.TTY_Handle;
 234       Buffer_Size : Natural := 4096) is
 235    begin
 236       Descriptor.Input_Fd  := GNAT.TTY.TTY_Descriptor (TTY);
 237       Descriptor.Output_Fd := Descriptor.Input_Fd;
 238
 239       --  Create the buffer
 240
 241       Descriptor.Buffer_Size := Buffer_Size;
 242
 243       if Buffer_Size /= 0 then
 244          Descriptor.Buffer := new String (1 .. Positive (Buffer_Size));
 245       end if;
 246    end Pseudo_Descriptor;
 247
 248    ----------
 249    -- Send --
 250    ----------
 251
 252    overriding procedure Send
 253      (Descriptor   : in out TTY_Process_Descriptor;
 254       Str          : String;
 255       Add_LF       : Boolean := True;
 256       Empty_Buffer : Boolean := False)
 257    is
 258       Header : String (1 .. 5);
 259       Length : Natural;
 260       Ret    : Natural;
 261
 262       procedure Internal
 263         (Process : System.Address;
 264          S       : in out String;
 265          Length  : Natural;
 266          Ret     : out Natural);
 267       pragma Import (C, Internal, "__gnat_send_header");
 268
 269    begin
 270       Length := Str'Length;
 271
 272       if Add_LF then
 273          Length := Length + 1;
 274       end if;
 275
 276       Internal (Descriptor.Process, Header, Length, Ret);
 277
 278       if Ret = 1 then
 279
 280          --  Need to use the header
 281
 282          GNAT.Expect.Send
 283            (Process_Descriptor (Descriptor),
 284             Header & Str, Add_LF, Empty_Buffer);
 285
 286       else
 287          GNAT.Expect.Send
 288            (Process_Descriptor (Descriptor),
 289             Str, Add_LF, Empty_Buffer);
 290       end if;
 291    end Send;
 292
 293    --------------
 294    -- Set_Size --
 295    --------------
 296
 297    procedure Set_Size
 298      (Descriptor : in out TTY_Process_Descriptor'Class;
 299       Rows       : Natural;
 300       Columns    : Natural)
 301    is
 302       procedure Internal (Process : System.Address; R, C : Integer);
 303       pragma Import (C, Internal, "__gnat_setup_winsize");
 304    begin
 305       if Descriptor.Process /= System.Null_Address then
 306          Internal (Descriptor.Process, Rows, Columns);
 307       end if;
 308    end Set_Size;
 309
 310    ---------------------------
 311    -- Set_Up_Communications --
 312    ---------------------------
 313
 314    overriding procedure Set_Up_Communications
 315      (Pid        : in out TTY_Process_Descriptor;
 316       Err_To_Out : Boolean;
 317       Pipe1      : not null access Pipe_Type;
 318       Pipe2      : not null access Pipe_Type;
 319       Pipe3      : not null access Pipe_Type)
 320    is
 321       pragma Unreferenced (Err_To_Out, Pipe1, Pipe2, Pipe3);
 322
 323       function Internal (Process : System.Address) return Integer;
 324       pragma Import (C, Internal, "__gnat_setup_communication");
 325
 326    begin
 327       Pid.Exit_Status := Still_Active;
 328       if Internal (Pid.Process'Address) /= 0 then
 329          raise Invalid_Process with "cannot setup communication.";
 330       end if;
 331    end Set_Up_Communications;
 332
 333    ---------------------------------
 334    -- Set_Up_Child_Communications --
 335    ---------------------------------
 336
 337    overriding procedure Set_Up_Child_Communications
 338      (Pid   : in out TTY_Process_Descriptor;
 339       Pipe1 : in out Pipe_Type;
 340       Pipe2 : in out Pipe_Type;
 341       Pipe3 : in out Pipe_Type;
 342       Cmd   : String;
 343       Args  : System.Address)
 344    is
 345       pragma Unreferenced (Pipe1, Pipe2, Pipe3, Cmd);
 346       function Internal
 347         (Process : System.Address; Argv : System.Address; Use_Pipes : Integer)
 348          return Process_Id;
 349       pragma Import (C, Internal, "__gnat_setup_child_communication");
 350
 351    begin
 352       Pid.Pid := Internal (Pid.Process, Args, Boolean'Pos (Pid.Use_Pipes));
 353    end Set_Up_Child_Communications;
 354
 355    ----------------------------------
 356    -- Set_Up_Parent_Communications --
 357    ----------------------------------
 358
 359    overriding procedure Set_Up_Parent_Communications
 360      (Pid   : in out TTY_Process_Descriptor;
 361       Pipe1 : in out Pipe_Type;
 362       Pipe2 : in out Pipe_Type;
 363       Pipe3 : in out Pipe_Type)
 364    is
 365       pragma Unreferenced (Pipe1, Pipe2, Pipe3);
 366
 367       procedure Internal
 368         (Process  : System.Address;
 369          Inputfp  : out File_Descriptor;
 370          Outputfp : out File_Descriptor;
 371          Errorfp  : out File_Descriptor;
 372          Pid      : out Process_Id);
 373       pragma Import (C, Internal, "__gnat_setup_parent_communication");
 374
 375    begin
 376       Internal
 377         (Pid.Process, Pid.Input_Fd, Pid.Output_Fd, Pid.Error_Fd, Pid.Pid);
 378    end Set_Up_Parent_Communications;
 379
 380    -------------------
 381    -- Set_Use_Pipes --
 382    -------------------
 383
 384    procedure Set_Use_Pipes
 385      (Descriptor : in out TTY_Process_Descriptor;
 386       Use_Pipes  : Boolean) is
 387    begin
 388       Descriptor.Use_Pipes := Use_Pipes;
 389    end Set_Use_Pipes;
 390
 391 end GNAT.Expect.TTY;