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-2019, 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
32with GNAT.OS_Lib; use GNAT.OS_Lib;
33
34with System; use System;
35
36package 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      : access Pipe_Type;
318      Pipe2      : access Pipe_Type;
319      Pipe3      : 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
391end GNAT.Expect.TTY;
392