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