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-2018, 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   -----------
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
324end GNAT.Expect.TTY;
325