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-2011, 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_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         if Descriptor.Input_Fd /= Invalid_FD then
70            Close (Descriptor.Input_Fd);
71         end if;
72
73         if Descriptor.Error_Fd /= Descriptor.Output_Fd
74           and then Descriptor.Error_Fd /= Invalid_FD
75         then
76            Close (Descriptor.Error_Fd);
77         end if;
78
79         if Descriptor.Output_Fd /= Invalid_FD then
80            Close (Descriptor.Output_Fd);
81         end if;
82
83         --  Send a Ctrl-C to the process first. This way, if the
84         --  launched process is a "sh" or "cmd", the child processes
85         --  will get terminated as well. Otherwise, terminating the
86         --  main process brutally will leave the children running.
87
88         Interrupt (Descriptor);
89         delay 0.05;
90
91         Terminate_Process (Descriptor.Process);
92         Status := Waitpid (Descriptor.Process);
93
94         if not On_Windows then
95            Close_TTY (Descriptor.Process);
96         end if;
97
98         Free_Process (Descriptor.Process'Address);
99         Descriptor.Process := System.Null_Address;
100
101         GNAT.OS_Lib.Free (Descriptor.Buffer);
102         Descriptor.Buffer_Size := 0;
103      end if;
104   end Close;
105
106   overriding procedure Close (Descriptor : in out TTY_Process_Descriptor) is
107      Status : Integer;
108   begin
109      Close (Descriptor, Status);
110   end Close;
111
112   -----------------------------
113   -- Close_Pseudo_Descriptor --
114   -----------------------------
115
116   procedure Close_Pseudo_Descriptor
117     (Descriptor : in out TTY_Process_Descriptor)
118   is
119   begin
120      Descriptor.Buffer_Size := 0;
121      GNAT.OS_Lib.Free (Descriptor.Buffer);
122   end Close_Pseudo_Descriptor;
123
124   ---------------
125   -- Interrupt --
126   ---------------
127
128   overriding procedure Interrupt
129     (Descriptor : in out TTY_Process_Descriptor)
130   is
131      procedure Internal (Process : System.Address);
132      pragma Import (C, Internal, "__gnat_interrupt_process");
133   begin
134      if Descriptor.Process /= System.Null_Address then
135         Internal (Descriptor.Process);
136      end if;
137   end Interrupt;
138
139   procedure Interrupt (Pid : Integer) is
140      procedure Internal (Pid : Integer);
141      pragma Import (C, Internal, "__gnat_interrupt_pid");
142   begin
143      Internal (Pid);
144   end Interrupt;
145
146   -----------------------
147   -- Pseudo_Descriptor --
148   -----------------------
149
150   procedure Pseudo_Descriptor
151     (Descriptor  : out TTY_Process_Descriptor'Class;
152      TTY         : GNAT.TTY.TTY_Handle;
153      Buffer_Size : Natural := 4096) is
154   begin
155      Descriptor.Input_Fd  := GNAT.TTY.TTY_Descriptor (TTY);
156      Descriptor.Output_Fd := Descriptor.Input_Fd;
157
158      --  Create the buffer
159
160      Descriptor.Buffer_Size := Buffer_Size;
161
162      if Buffer_Size /= 0 then
163         Descriptor.Buffer := new String (1 .. Positive (Buffer_Size));
164      end if;
165   end Pseudo_Descriptor;
166
167   ----------
168   -- Send --
169   ----------
170
171   overriding procedure Send
172     (Descriptor   : in out TTY_Process_Descriptor;
173      Str          : String;
174      Add_LF       : Boolean := True;
175      Empty_Buffer : Boolean := False)
176   is
177      Header : String (1 .. 5);
178      Length : Natural;
179      Ret    : Natural;
180
181      procedure Internal
182        (Process : System.Address;
183         S       : in out String;
184         Length  : Natural;
185         Ret     : out Natural);
186      pragma Import (C, Internal, "__gnat_send_header");
187
188   begin
189      Length := Str'Length;
190
191      if Add_LF then
192         Length := Length + 1;
193      end if;
194
195      Internal (Descriptor.Process, Header, Length, Ret);
196
197      if Ret = 1 then
198
199         --  Need to use the header
200
201         GNAT.Expect.Send
202           (Process_Descriptor (Descriptor),
203            Header & Str, Add_LF, Empty_Buffer);
204
205      else
206         GNAT.Expect.Send
207           (Process_Descriptor (Descriptor),
208            Str, Add_LF, Empty_Buffer);
209      end if;
210   end Send;
211
212   --------------
213   -- Set_Size --
214   --------------
215
216   procedure Set_Size
217     (Descriptor : in out TTY_Process_Descriptor'Class;
218      Rows       : Natural;
219      Columns    : Natural)
220   is
221      procedure Internal (Process : System.Address; R, C : Integer);
222      pragma Import (C, Internal, "__gnat_setup_winsize");
223   begin
224      if Descriptor.Process /= System.Null_Address then
225         Internal (Descriptor.Process, Rows, Columns);
226      end if;
227   end Set_Size;
228
229   ---------------------------
230   -- Set_Up_Communications --
231   ---------------------------
232
233   overriding procedure Set_Up_Communications
234     (Pid        : in out TTY_Process_Descriptor;
235      Err_To_Out : Boolean;
236      Pipe1      : access Pipe_Type;
237      Pipe2      : access Pipe_Type;
238      Pipe3      : access Pipe_Type)
239   is
240      pragma Unreferenced (Err_To_Out, Pipe1, Pipe2, Pipe3);
241
242      function Internal (Process : System.Address) return Integer;
243      pragma Import (C, Internal, "__gnat_setup_communication");
244
245   begin
246      if Internal (Pid.Process'Address) /= 0 then
247         raise Invalid_Process with "cannot setup communication.";
248      end if;
249   end Set_Up_Communications;
250
251   ---------------------------------
252   -- Set_Up_Child_Communications --
253   ---------------------------------
254
255   overriding procedure Set_Up_Child_Communications
256     (Pid   : in out TTY_Process_Descriptor;
257      Pipe1 : in out Pipe_Type;
258      Pipe2 : in out Pipe_Type;
259      Pipe3 : in out Pipe_Type;
260      Cmd   : String;
261      Args  : System.Address)
262   is
263      pragma Unreferenced (Pipe1, Pipe2, Pipe3, Cmd);
264      function Internal
265        (Process : System.Address; Argv : System.Address; Use_Pipes : Integer)
266         return Process_Id;
267      pragma Import (C, Internal, "__gnat_setup_child_communication");
268
269   begin
270      Pid.Pid := Internal (Pid.Process, Args, Boolean'Pos (Pid.Use_Pipes));
271   end Set_Up_Child_Communications;
272
273   ----------------------------------
274   -- Set_Up_Parent_Communications --
275   ----------------------------------
276
277   overriding procedure Set_Up_Parent_Communications
278     (Pid   : in out TTY_Process_Descriptor;
279      Pipe1 : in out Pipe_Type;
280      Pipe2 : in out Pipe_Type;
281      Pipe3 : in out Pipe_Type)
282   is
283      pragma Unreferenced (Pipe1, Pipe2, Pipe3);
284
285      procedure Internal
286        (Process  : System.Address;
287         Inputfp  : out File_Descriptor;
288         Outputfp : out File_Descriptor;
289         Errorfp  : out File_Descriptor;
290         Pid      : out Process_Id);
291      pragma Import (C, Internal, "__gnat_setup_parent_communication");
292
293   begin
294      Internal
295        (Pid.Process, Pid.Input_Fd, Pid.Output_Fd, Pid.Error_Fd, Pid.Pid);
296   end Set_Up_Parent_Communications;
297
298   -------------------
299   -- Set_Use_Pipes --
300   -------------------
301
302   procedure Set_Use_Pipes
303     (Descriptor : in out TTY_Process_Descriptor;
304      Use_Pipes  : Boolean) is
305   begin
306      Descriptor.Use_Pipes := Use_Pipes;
307   end Set_Use_Pipes;
308
309end GNAT.Expect.TTY;
310