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
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   -- 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
313end GNAT.Expect.TTY;
314