|
111
|
1 ------------------------------------------------------------------------------
|
|
|
2 -- --
|
|
|
3 -- GNAT LIBRARY COMPONENTS --
|
|
|
4 -- --
|
|
|
5 -- G N A T . E X P E C T --
|
|
|
6 -- --
|
|
|
7 -- B o d y --
|
|
|
8 -- --
|
|
145
|
9 -- Copyright (C) 2000-2019, AdaCore --
|
|
111
|
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 System; use System;
|
|
|
33 with System.OS_Constants; use System.OS_Constants;
|
|
|
34 with Ada.Calendar; use Ada.Calendar;
|
|
|
35
|
|
|
36 with GNAT.IO; use GNAT.IO;
|
|
|
37 with GNAT.OS_Lib; use GNAT.OS_Lib;
|
|
|
38 with GNAT.Regpat; use GNAT.Regpat;
|
|
|
39
|
|
|
40 with Ada.Unchecked_Deallocation;
|
|
|
41
|
|
|
42 package body GNAT.Expect is
|
|
|
43
|
|
|
44 type Array_Of_Pd is array (Positive range <>) of Process_Descriptor_Access;
|
|
|
45
|
|
|
46 Expect_Process_Died : constant Expect_Match := -100;
|
|
|
47 Expect_Internal_Error : constant Expect_Match := -101;
|
|
|
48 -- Additional possible outputs of Expect_Internal. These are not visible in
|
|
|
49 -- the spec because the user will never see them.
|
|
|
50
|
|
|
51 procedure Expect_Internal
|
|
|
52 (Descriptors : in out Array_Of_Pd;
|
|
|
53 Result : out Expect_Match;
|
|
|
54 Timeout : Integer;
|
|
|
55 Full_Buffer : Boolean);
|
|
|
56 -- Internal function used to read from the process Descriptor.
|
|
|
57 --
|
|
|
58 -- Several outputs are possible:
|
|
|
59 -- Result=Expect_Timeout, if no output was available before the timeout
|
|
|
60 -- expired.
|
|
|
61 -- Result=Expect_Full_Buffer, if Full_Buffer is True and some characters
|
|
|
62 -- had to be discarded from the internal buffer of Descriptor.
|
|
|
63 -- Result=Express_Process_Died if one of the processes was terminated.
|
|
|
64 -- That process's Input_Fd is set to Invalid_FD
|
|
|
65 -- Result=Express_Internal_Error
|
|
|
66 -- Result=<integer>, indicates how many characters were added to the
|
|
|
67 -- internal buffer. These characters are from indexes
|
|
|
68 -- Descriptor.Buffer_Index - Result + 1 .. Descriptor.Buffer_Index
|
|
|
69 -- Process_Died is raised if the process is no longer valid.
|
|
|
70
|
|
|
71 procedure Reinitialize_Buffer
|
|
|
72 (Descriptor : in out Process_Descriptor'Class);
|
|
|
73 -- Reinitialize the internal buffer.
|
|
|
74 -- The buffer is deleted up to the end of the last match.
|
|
|
75
|
|
|
76 procedure Free is new Ada.Unchecked_Deallocation
|
|
|
77 (Pattern_Matcher, Pattern_Matcher_Access);
|
|
|
78
|
|
|
79 procedure Free is new Ada.Unchecked_Deallocation
|
|
|
80 (Filter_List_Elem, Filter_List);
|
|
|
81
|
|
|
82 procedure Call_Filters
|
|
|
83 (Pid : Process_Descriptor'Class;
|
|
|
84 Str : String;
|
|
|
85 Filter_On : Filter_Type);
|
|
|
86 -- Call all the filters that have the appropriate type.
|
|
|
87 -- This function does nothing if the filters are locked
|
|
|
88
|
|
|
89 ------------------------------
|
|
|
90 -- Target dependent section --
|
|
|
91 ------------------------------
|
|
|
92
|
|
|
93 function Dup (Fd : File_Descriptor) return File_Descriptor;
|
|
|
94 pragma Import (C, Dup);
|
|
|
95
|
|
|
96 procedure Dup2 (Old_Fd, New_Fd : File_Descriptor);
|
|
|
97 pragma Import (C, Dup2);
|
|
|
98
|
|
|
99 procedure Kill (Pid : Process_Id; Sig_Num : Integer; Close : Integer);
|
|
|
100 pragma Import (C, Kill, "__gnat_kill");
|
|
|
101 -- if Close is set to 1 all OS resources used by the Pid must be freed
|
|
|
102
|
|
|
103 function Create_Pipe (Pipe : not null access Pipe_Type) return Integer;
|
|
|
104 pragma Import (C, Create_Pipe, "__gnat_pipe");
|
|
|
105
|
|
|
106 function Poll
|
|
|
107 (Fds : System.Address;
|
|
|
108 Num_Fds : Integer;
|
|
|
109 Timeout : Integer;
|
|
|
110 Dead_Process : access Integer;
|
|
|
111 Is_Set : System.Address) return Integer;
|
|
|
112 pragma Import (C, Poll, "__gnat_expect_poll");
|
|
|
113 -- Check whether there is any data waiting on the file descriptors
|
|
|
114 -- Fds, and wait if there is none, at most Timeout milliseconds
|
|
|
115 -- Returns -1 in case of error, 0 if the timeout expired before
|
|
|
116 -- data became available.
|
|
|
117 --
|
|
|
118 -- Is_Set is an array of the same size as FDs and elements are set to 1 if
|
|
|
119 -- data is available for the corresponding File Descriptor, 0 otherwise.
|
|
|
120 --
|
|
|
121 -- If a process dies, then Dead_Process is set to the index of the
|
|
|
122 -- corresponding file descriptor.
|
|
|
123
|
|
|
124 function Waitpid (Pid : Process_Id) return Integer;
|
|
|
125 pragma Import (C, Waitpid, "__gnat_waitpid");
|
|
|
126 -- Wait for a specific process id, and return its exit code
|
|
|
127
|
|
|
128 ---------
|
|
|
129 -- "+" --
|
|
|
130 ---------
|
|
|
131
|
|
|
132 function "+" (S : String) return GNAT.OS_Lib.String_Access is
|
|
|
133 begin
|
|
|
134 return new String'(S);
|
|
|
135 end "+";
|
|
|
136
|
|
|
137 ---------
|
|
|
138 -- "+" --
|
|
|
139 ---------
|
|
|
140
|
|
|
141 function "+"
|
|
|
142 (P : GNAT.Regpat.Pattern_Matcher) return Pattern_Matcher_Access
|
|
|
143 is
|
|
|
144 begin
|
|
|
145 return new GNAT.Regpat.Pattern_Matcher'(P);
|
|
|
146 end "+";
|
|
|
147
|
|
|
148 ----------------
|
|
|
149 -- Add_Filter --
|
|
|
150 ----------------
|
|
|
151
|
|
|
152 procedure Add_Filter
|
|
|
153 (Descriptor : in out Process_Descriptor;
|
|
|
154 Filter : Filter_Function;
|
|
|
155 Filter_On : Filter_Type := Output;
|
|
|
156 User_Data : System.Address := System.Null_Address;
|
|
|
157 After : Boolean := False)
|
|
|
158 is
|
|
|
159 Current : Filter_List := Descriptor.Filters;
|
|
|
160
|
|
|
161 begin
|
|
|
162 if After then
|
|
|
163 while Current /= null and then Current.Next /= null loop
|
|
|
164 Current := Current.Next;
|
|
|
165 end loop;
|
|
|
166
|
|
|
167 if Current = null then
|
|
|
168 Descriptor.Filters :=
|
|
|
169 new Filter_List_Elem'
|
|
|
170 (Filter => Filter, Filter_On => Filter_On,
|
|
|
171 User_Data => User_Data, Next => null);
|
|
|
172 else
|
|
|
173 Current.Next :=
|
|
|
174 new Filter_List_Elem'
|
|
|
175 (Filter => Filter, Filter_On => Filter_On,
|
|
|
176 User_Data => User_Data, Next => null);
|
|
|
177 end if;
|
|
|
178
|
|
|
179 else
|
|
|
180 Descriptor.Filters :=
|
|
|
181 new Filter_List_Elem'
|
|
|
182 (Filter => Filter, Filter_On => Filter_On,
|
|
|
183 User_Data => User_Data, Next => Descriptor.Filters);
|
|
|
184 end if;
|
|
|
185 end Add_Filter;
|
|
|
186
|
|
|
187 ------------------
|
|
|
188 -- Call_Filters --
|
|
|
189 ------------------
|
|
|
190
|
|
|
191 procedure Call_Filters
|
|
|
192 (Pid : Process_Descriptor'Class;
|
|
|
193 Str : String;
|
|
|
194 Filter_On : Filter_Type)
|
|
|
195 is
|
|
|
196 Current_Filter : Filter_List;
|
|
|
197
|
|
|
198 begin
|
|
|
199 if Pid.Filters_Lock = 0 then
|
|
|
200 Current_Filter := Pid.Filters;
|
|
|
201
|
|
|
202 while Current_Filter /= null loop
|
|
|
203 if Current_Filter.Filter_On = Filter_On then
|
|
|
204 Current_Filter.Filter
|
|
|
205 (Pid, Str, Current_Filter.User_Data);
|
|
|
206 end if;
|
|
|
207
|
|
|
208 Current_Filter := Current_Filter.Next;
|
|
|
209 end loop;
|
|
|
210 end if;
|
|
|
211 end Call_Filters;
|
|
|
212
|
|
|
213 -----------
|
|
|
214 -- Close --
|
|
|
215 -----------
|
|
|
216
|
|
|
217 procedure Close
|
|
|
218 (Descriptor : in out Process_Descriptor;
|
|
|
219 Status : out Integer)
|
|
|
220 is
|
|
|
221 Current_Filter : Filter_List;
|
|
|
222 Next_Filter : Filter_List;
|
|
|
223
|
|
|
224 begin
|
|
145
|
225 Close_Input (Descriptor);
|
|
111
|
226
|
|
145
|
227 if Descriptor.Error_Fd /= Descriptor.Output_Fd
|
|
|
228 and then Descriptor.Error_Fd /= Invalid_FD
|
|
|
229 then
|
|
111
|
230 Close (Descriptor.Error_Fd);
|
|
|
231 end if;
|
|
|
232
|
|
145
|
233 if Descriptor.Output_Fd /= Invalid_FD then
|
|
|
234 Close (Descriptor.Output_Fd);
|
|
|
235 end if;
|
|
111
|
236
|
|
|
237 -- ??? Should have timeouts for different signals
|
|
|
238
|
|
|
239 if Descriptor.Pid > 0 then -- see comment in Send_Signal
|
|
|
240 Kill (Descriptor.Pid, Sig_Num => 9, Close => 0);
|
|
|
241 end if;
|
|
|
242
|
|
|
243 GNAT.OS_Lib.Free (Descriptor.Buffer);
|
|
|
244 Descriptor.Buffer_Size := 0;
|
|
|
245
|
|
|
246 Current_Filter := Descriptor.Filters;
|
|
|
247
|
|
|
248 while Current_Filter /= null loop
|
|
|
249 Next_Filter := Current_Filter.Next;
|
|
|
250 Free (Current_Filter);
|
|
|
251 Current_Filter := Next_Filter;
|
|
|
252 end loop;
|
|
|
253
|
|
|
254 Descriptor.Filters := null;
|
|
|
255
|
|
|
256 -- Check process id (see comment in Send_Signal)
|
|
|
257
|
|
|
258 if Descriptor.Pid > 0 then
|
|
|
259 Status := Waitpid (Descriptor.Pid);
|
|
|
260 else
|
|
|
261 raise Invalid_Process;
|
|
|
262 end if;
|
|
|
263 end Close;
|
|
|
264
|
|
|
265 procedure Close (Descriptor : in out Process_Descriptor) is
|
|
|
266 Status : Integer;
|
|
|
267 pragma Unreferenced (Status);
|
|
|
268 begin
|
|
|
269 Close (Descriptor, Status);
|
|
|
270 end Close;
|
|
|
271
|
|
145
|
272 -----------------
|
|
|
273 -- Close_Input --
|
|
|
274 -----------------
|
|
|
275
|
|
|
276 procedure Close_Input (Pid : in out Process_Descriptor) is
|
|
|
277 begin
|
|
|
278 if Pid.Input_Fd /= Invalid_FD then
|
|
|
279 Close (Pid.Input_Fd);
|
|
|
280 end if;
|
|
|
281
|
|
|
282 if Pid.Output_Fd = Pid.Input_Fd then
|
|
|
283 Pid.Output_Fd := Invalid_FD;
|
|
|
284 end if;
|
|
|
285
|
|
|
286 if Pid.Error_Fd = Pid.Input_Fd then
|
|
|
287 Pid.Error_Fd := Invalid_FD;
|
|
|
288 end if;
|
|
|
289
|
|
|
290 Pid.Input_Fd := Invalid_FD;
|
|
|
291 end Close_Input;
|
|
|
292
|
|
111
|
293 ------------
|
|
|
294 -- Expect --
|
|
|
295 ------------
|
|
|
296
|
|
|
297 procedure Expect
|
|
|
298 (Descriptor : in out Process_Descriptor;
|
|
|
299 Result : out Expect_Match;
|
|
|
300 Regexp : String;
|
|
|
301 Timeout : Integer := 10_000;
|
|
|
302 Full_Buffer : Boolean := False)
|
|
|
303 is
|
|
|
304 begin
|
|
|
305 if Regexp = "" then
|
|
|
306 Expect (Descriptor, Result, Never_Match, Timeout, Full_Buffer);
|
|
|
307 else
|
|
|
308 Expect (Descriptor, Result, Compile (Regexp), Timeout, Full_Buffer);
|
|
|
309 end if;
|
|
|
310 end Expect;
|
|
|
311
|
|
|
312 procedure Expect
|
|
|
313 (Descriptor : in out Process_Descriptor;
|
|
|
314 Result : out Expect_Match;
|
|
|
315 Regexp : String;
|
|
|
316 Matched : out GNAT.Regpat.Match_Array;
|
|
|
317 Timeout : Integer := 10_000;
|
|
|
318 Full_Buffer : Boolean := False)
|
|
|
319 is
|
|
|
320 begin
|
|
|
321 pragma Assert (Matched'First = 0);
|
|
|
322 if Regexp = "" then
|
|
|
323 Expect
|
|
|
324 (Descriptor, Result, Never_Match, Matched, Timeout, Full_Buffer);
|
|
|
325 else
|
|
|
326 Expect
|
|
|
327 (Descriptor, Result, Compile (Regexp), Matched, Timeout,
|
|
|
328 Full_Buffer);
|
|
|
329 end if;
|
|
|
330 end Expect;
|
|
|
331
|
|
|
332 procedure Expect
|
|
|
333 (Descriptor : in out Process_Descriptor;
|
|
|
334 Result : out Expect_Match;
|
|
|
335 Regexp : GNAT.Regpat.Pattern_Matcher;
|
|
|
336 Timeout : Integer := 10_000;
|
|
|
337 Full_Buffer : Boolean := False)
|
|
|
338 is
|
|
|
339 Matched : GNAT.Regpat.Match_Array (0 .. 0);
|
|
|
340 pragma Warnings (Off, Matched);
|
|
|
341 begin
|
|
|
342 Expect (Descriptor, Result, Regexp, Matched, Timeout, Full_Buffer);
|
|
|
343 end Expect;
|
|
|
344
|
|
|
345 procedure Expect
|
|
|
346 (Descriptor : in out Process_Descriptor;
|
|
|
347 Result : out Expect_Match;
|
|
|
348 Regexp : GNAT.Regpat.Pattern_Matcher;
|
|
|
349 Matched : out GNAT.Regpat.Match_Array;
|
|
|
350 Timeout : Integer := 10_000;
|
|
|
351 Full_Buffer : Boolean := False)
|
|
|
352 is
|
|
|
353 N : Expect_Match;
|
|
|
354 Descriptors : Array_Of_Pd := (1 => Descriptor'Unrestricted_Access);
|
|
|
355 Try_Until : constant Time := Clock + Duration (Timeout) / 1000.0;
|
|
|
356 Timeout_Tmp : Integer := Timeout;
|
|
|
357
|
|
|
358 begin
|
|
|
359 pragma Assert (Matched'First = 0);
|
|
|
360 Reinitialize_Buffer (Descriptor);
|
|
|
361
|
|
|
362 loop
|
|
|
363 -- First, test if what is already in the buffer matches (This is
|
|
|
364 -- required if this package is used in multi-task mode, since one of
|
|
|
365 -- the tasks might have added something in the buffer, and we don't
|
|
|
366 -- want other tasks to wait for new input to be available before
|
|
|
367 -- checking the regexps).
|
|
|
368
|
|
|
369 Match
|
|
|
370 (Regexp, Descriptor.Buffer (1 .. Descriptor.Buffer_Index), Matched);
|
|
|
371
|
|
|
372 if Descriptor.Buffer_Index >= 1 and then Matched (0).First /= 0 then
|
|
|
373 Result := 1;
|
|
|
374 Descriptor.Last_Match_Start := Matched (0).First;
|
|
|
375 Descriptor.Last_Match_End := Matched (0).Last;
|
|
|
376 return;
|
|
|
377 end if;
|
|
|
378
|
|
|
379 -- Else try to read new input
|
|
|
380
|
|
|
381 Expect_Internal (Descriptors, N, Timeout_Tmp, Full_Buffer);
|
|
|
382
|
|
|
383 case N is
|
|
|
384 when Expect_Internal_Error
|
|
|
385 | Expect_Process_Died
|
|
|
386 =>
|
|
|
387 raise Process_Died;
|
|
|
388
|
|
|
389 when Expect_Full_Buffer
|
|
|
390 | Expect_Timeout
|
|
|
391 =>
|
|
|
392 Result := N;
|
|
|
393 return;
|
|
|
394
|
|
|
395 when others =>
|
|
|
396 null; -- See below
|
|
|
397 end case;
|
|
|
398
|
|
|
399 -- Calculate the timeout for the next turn
|
|
|
400
|
|
|
401 -- Note that Timeout is, from the caller's perspective, the maximum
|
|
|
402 -- time until a match, not the maximum time until some output is
|
|
|
403 -- read, and thus cannot be reused as is for Expect_Internal.
|
|
|
404
|
|
|
405 if Timeout /= -1 then
|
|
|
406 Timeout_Tmp := Integer (Try_Until - Clock) * 1000;
|
|
|
407
|
|
|
408 if Timeout_Tmp < 0 then
|
|
|
409 Result := Expect_Timeout;
|
|
|
410 exit;
|
|
|
411 end if;
|
|
|
412 end if;
|
|
|
413 end loop;
|
|
|
414
|
|
|
415 -- Even if we had the general timeout above, we have to test that the
|
|
|
416 -- last test we read from the external process didn't match.
|
|
|
417
|
|
|
418 Match
|
|
|
419 (Regexp, Descriptor.Buffer (1 .. Descriptor.Buffer_Index), Matched);
|
|
|
420
|
|
|
421 if Matched (0).First /= 0 then
|
|
|
422 Result := 1;
|
|
|
423 Descriptor.Last_Match_Start := Matched (0).First;
|
|
|
424 Descriptor.Last_Match_End := Matched (0).Last;
|
|
|
425 return;
|
|
|
426 end if;
|
|
|
427 end Expect;
|
|
|
428
|
|
|
429 procedure Expect
|
|
|
430 (Descriptor : in out Process_Descriptor;
|
|
|
431 Result : out Expect_Match;
|
|
|
432 Regexps : Regexp_Array;
|
|
|
433 Timeout : Integer := 10_000;
|
|
|
434 Full_Buffer : Boolean := False)
|
|
|
435 is
|
|
|
436 Patterns : Compiled_Regexp_Array (Regexps'Range);
|
|
|
437
|
|
|
438 Matched : GNAT.Regpat.Match_Array (0 .. 0);
|
|
|
439 pragma Warnings (Off, Matched);
|
|
|
440
|
|
|
441 begin
|
|
|
442 for J in Regexps'Range loop
|
|
|
443 Patterns (J) := new Pattern_Matcher'(Compile (Regexps (J).all));
|
|
|
444 end loop;
|
|
|
445
|
|
|
446 Expect (Descriptor, Result, Patterns, Matched, Timeout, Full_Buffer);
|
|
|
447
|
|
|
448 for J in Regexps'Range loop
|
|
|
449 Free (Patterns (J));
|
|
|
450 end loop;
|
|
|
451 end Expect;
|
|
|
452
|
|
|
453 procedure Expect
|
|
|
454 (Descriptor : in out Process_Descriptor;
|
|
|
455 Result : out Expect_Match;
|
|
|
456 Regexps : Compiled_Regexp_Array;
|
|
|
457 Timeout : Integer := 10_000;
|
|
|
458 Full_Buffer : Boolean := False)
|
|
|
459 is
|
|
|
460 Matched : GNAT.Regpat.Match_Array (0 .. 0);
|
|
|
461 pragma Warnings (Off, Matched);
|
|
|
462 begin
|
|
|
463 Expect (Descriptor, Result, Regexps, Matched, Timeout, Full_Buffer);
|
|
|
464 end Expect;
|
|
|
465
|
|
|
466 procedure Expect
|
|
|
467 (Result : out Expect_Match;
|
|
|
468 Regexps : Multiprocess_Regexp_Array;
|
|
|
469 Timeout : Integer := 10_000;
|
|
|
470 Full_Buffer : Boolean := False)
|
|
|
471 is
|
|
|
472 Matched : GNAT.Regpat.Match_Array (0 .. 0);
|
|
|
473 pragma Warnings (Off, Matched);
|
|
|
474 begin
|
|
|
475 Expect (Result, Regexps, Matched, Timeout, Full_Buffer);
|
|
|
476 end Expect;
|
|
|
477
|
|
|
478 procedure Expect
|
|
|
479 (Descriptor : in out Process_Descriptor;
|
|
|
480 Result : out Expect_Match;
|
|
|
481 Regexps : Regexp_Array;
|
|
|
482 Matched : out GNAT.Regpat.Match_Array;
|
|
|
483 Timeout : Integer := 10_000;
|
|
|
484 Full_Buffer : Boolean := False)
|
|
|
485 is
|
|
|
486 Patterns : Compiled_Regexp_Array (Regexps'Range);
|
|
|
487
|
|
|
488 begin
|
|
|
489 pragma Assert (Matched'First = 0);
|
|
|
490
|
|
|
491 for J in Regexps'Range loop
|
|
|
492 Patterns (J) := new Pattern_Matcher'(Compile (Regexps (J).all));
|
|
|
493 end loop;
|
|
|
494
|
|
|
495 Expect (Descriptor, Result, Patterns, Matched, Timeout, Full_Buffer);
|
|
|
496
|
|
|
497 for J in Regexps'Range loop
|
|
|
498 Free (Patterns (J));
|
|
|
499 end loop;
|
|
|
500 end Expect;
|
|
|
501
|
|
|
502 procedure Expect
|
|
|
503 (Descriptor : in out Process_Descriptor;
|
|
|
504 Result : out Expect_Match;
|
|
|
505 Regexps : Compiled_Regexp_Array;
|
|
|
506 Matched : out GNAT.Regpat.Match_Array;
|
|
|
507 Timeout : Integer := 10_000;
|
|
|
508 Full_Buffer : Boolean := False)
|
|
|
509 is
|
|
|
510 N : Expect_Match;
|
|
|
511 Descriptors : Array_Of_Pd := (1 => Descriptor'Unrestricted_Access);
|
|
|
512
|
|
|
513 begin
|
|
|
514 pragma Assert (Matched'First = 0);
|
|
|
515
|
|
|
516 Reinitialize_Buffer (Descriptor);
|
|
|
517
|
|
|
518 loop
|
|
|
519 -- First, test if what is already in the buffer matches (This is
|
|
|
520 -- required if this package is used in multi-task mode, since one of
|
|
|
521 -- the tasks might have added something in the buffer, and we don't
|
|
|
522 -- want other tasks to wait for new input to be available before
|
|
|
523 -- checking the regexps).
|
|
|
524
|
|
|
525 if Descriptor.Buffer /= null then
|
|
|
526 for J in Regexps'Range loop
|
|
|
527 Match
|
|
|
528 (Regexps (J).all,
|
|
|
529 Descriptor.Buffer (1 .. Descriptor.Buffer_Index),
|
|
|
530 Matched);
|
|
|
531
|
|
|
532 if Matched (0) /= No_Match then
|
|
|
533 Result := Expect_Match (J);
|
|
|
534 Descriptor.Last_Match_Start := Matched (0).First;
|
|
|
535 Descriptor.Last_Match_End := Matched (0).Last;
|
|
|
536 return;
|
|
|
537 end if;
|
|
|
538 end loop;
|
|
|
539 end if;
|
|
|
540
|
|
|
541 Expect_Internal (Descriptors, N, Timeout, Full_Buffer);
|
|
|
542
|
|
|
543 case N is
|
|
|
544 when Expect_Internal_Error
|
|
|
545 | Expect_Process_Died
|
|
|
546 =>
|
|
|
547 raise Process_Died;
|
|
|
548
|
|
|
549 when Expect_Full_Buffer
|
|
|
550 | Expect_Timeout
|
|
|
551 =>
|
|
|
552 Result := N;
|
|
|
553 return;
|
|
|
554
|
|
|
555 when others =>
|
|
|
556 null; -- Continue
|
|
|
557 end case;
|
|
|
558 end loop;
|
|
|
559 end Expect;
|
|
|
560
|
|
|
561 procedure Expect
|
|
|
562 (Result : out Expect_Match;
|
|
|
563 Regexps : Multiprocess_Regexp_Array;
|
|
|
564 Matched : out GNAT.Regpat.Match_Array;
|
|
|
565 Timeout : Integer := 10_000;
|
|
|
566 Full_Buffer : Boolean := False)
|
|
|
567 is
|
|
|
568 N : Expect_Match;
|
|
|
569 Descriptors : Array_Of_Pd (Regexps'Range);
|
|
|
570
|
|
|
571 begin
|
|
|
572 pragma Assert (Matched'First = 0);
|
|
|
573
|
|
|
574 for J in Descriptors'Range loop
|
|
|
575 Descriptors (J) := Regexps (J).Descriptor;
|
|
|
576
|
|
|
577 if Descriptors (J) /= null then
|
|
|
578 Reinitialize_Buffer (Regexps (J).Descriptor.all);
|
|
|
579 end if;
|
|
|
580 end loop;
|
|
|
581
|
|
|
582 loop
|
|
|
583 -- First, test if what is already in the buffer matches (This is
|
|
|
584 -- required if this package is used in multi-task mode, since one of
|
|
|
585 -- the tasks might have added something in the buffer, and we don't
|
|
|
586 -- want other tasks to wait for new input to be available before
|
|
|
587 -- checking the regexps).
|
|
|
588
|
|
|
589 for J in Regexps'Range loop
|
|
|
590 if Regexps (J).Regexp /= null
|
|
|
591 and then Regexps (J).Descriptor /= null
|
|
|
592 then
|
|
|
593 Match (Regexps (J).Regexp.all,
|
|
|
594 Regexps (J).Descriptor.Buffer
|
|
|
595 (1 .. Regexps (J).Descriptor.Buffer_Index),
|
|
|
596 Matched);
|
|
|
597
|
|
|
598 if Matched (0) /= No_Match then
|
|
|
599 Result := Expect_Match (J);
|
|
|
600 Regexps (J).Descriptor.Last_Match_Start := Matched (0).First;
|
|
|
601 Regexps (J).Descriptor.Last_Match_End := Matched (0).Last;
|
|
|
602 return;
|
|
|
603 end if;
|
|
|
604 end if;
|
|
|
605 end loop;
|
|
|
606
|
|
|
607 Expect_Internal (Descriptors, N, Timeout, Full_Buffer);
|
|
|
608
|
|
|
609 case N is
|
|
|
610 when Expect_Internal_Error
|
|
|
611 | Expect_Process_Died
|
|
|
612 =>
|
|
|
613 raise Process_Died;
|
|
|
614
|
|
|
615 when Expect_Full_Buffer
|
|
|
616 | Expect_Timeout
|
|
|
617 =>
|
|
|
618 Result := N;
|
|
|
619 return;
|
|
|
620
|
|
|
621 when others =>
|
|
|
622 null; -- Continue
|
|
|
623 end case;
|
|
|
624 end loop;
|
|
|
625 end Expect;
|
|
|
626
|
|
|
627 ---------------------
|
|
|
628 -- Expect_Internal --
|
|
|
629 ---------------------
|
|
|
630
|
|
|
631 procedure Expect_Internal
|
|
|
632 (Descriptors : in out Array_Of_Pd;
|
|
|
633 Result : out Expect_Match;
|
|
|
634 Timeout : Integer;
|
|
|
635 Full_Buffer : Boolean)
|
|
|
636 is
|
|
|
637 Num_Descriptors : Integer;
|
|
|
638 Buffer_Size : Integer := 0;
|
|
|
639
|
|
|
640 N : Integer;
|
|
|
641
|
|
|
642 type File_Descriptor_Array is
|
|
|
643 array (0 .. Descriptors'Length - 1) of File_Descriptor;
|
|
|
644 Fds : aliased File_Descriptor_Array;
|
|
|
645 Fds_Count : Natural := 0;
|
|
|
646
|
|
|
647 Fds_To_Descriptor : array (Fds'Range) of Integer;
|
|
|
648 -- Maps file descriptor entries from Fds to entries in Descriptors.
|
|
|
649 -- They do not have the same index when entries in Descriptors are null.
|
|
|
650
|
|
|
651 type Integer_Array is array (Fds'Range) of Integer;
|
|
|
652 Is_Set : aliased Integer_Array;
|
|
|
653
|
|
|
654 begin
|
|
|
655 for J in Descriptors'Range loop
|
|
145
|
656 if Descriptors (J) /= null
|
|
|
657 and then Descriptors (J).Output_Fd /= Invalid_FD
|
|
|
658 then
|
|
111
|
659 Fds (Fds'First + Fds_Count) := Descriptors (J).Output_Fd;
|
|
|
660 Fds_To_Descriptor (Fds'First + Fds_Count) := J;
|
|
|
661 Fds_Count := Fds_Count + 1;
|
|
|
662
|
|
|
663 if Descriptors (J).Buffer_Size = 0 then
|
|
|
664 Buffer_Size := Integer'Max (Buffer_Size, 4096);
|
|
|
665 else
|
|
|
666 Buffer_Size :=
|
|
|
667 Integer'Max (Buffer_Size, Descriptors (J).Buffer_Size);
|
|
|
668 end if;
|
|
|
669 end if;
|
|
|
670 end loop;
|
|
|
671
|
|
145
|
672 if Fds_Count = 0 then
|
|
|
673 -- There are no descriptors to monitor, it means that process died.
|
|
|
674
|
|
|
675 Result := Expect_Process_Died;
|
|
|
676
|
|
|
677 return;
|
|
|
678 end if;
|
|
|
679
|
|
111
|
680 declare
|
|
|
681 Buffer : aliased String (1 .. Buffer_Size);
|
|
|
682 -- Buffer used for input. This is allocated only once, not for
|
|
|
683 -- every iteration of the loop
|
|
|
684
|
|
|
685 D : aliased Integer;
|
|
|
686 -- Index in Descriptors
|
|
|
687
|
|
|
688 begin
|
|
|
689 -- Loop until we match or we have a timeout
|
|
|
690
|
|
|
691 loop
|
|
145
|
692 -- Poll may be interrupted on Linux by a signal and need to be
|
|
|
693 -- repeated. We don't want to check for errno = EINTER, so just
|
|
|
694 -- attempt to call Poll a few times.
|
|
|
695
|
|
|
696 for J in 1 .. 3 loop
|
|
|
697 Num_Descriptors :=
|
|
|
698 Poll
|
|
|
699 (Fds'Address, Fds_Count, Timeout, D'Access, Is_Set'Address);
|
|
|
700
|
|
|
701 exit when Num_Descriptors /= -1;
|
|
|
702 end loop;
|
|
111
|
703
|
|
|
704 case Num_Descriptors is
|
|
|
705
|
|
|
706 -- Error?
|
|
|
707
|
|
|
708 when -1 =>
|
|
|
709 Result := Expect_Internal_Error;
|
|
|
710
|
|
|
711 if D /= 0 then
|
|
145
|
712 Close_Input (Descriptors (D).all);
|
|
111
|
713 end if;
|
|
|
714
|
|
|
715 return;
|
|
|
716
|
|
|
717 -- Timeout?
|
|
|
718
|
|
|
719 when 0 =>
|
|
|
720 Result := Expect_Timeout;
|
|
|
721 return;
|
|
|
722
|
|
|
723 -- Some input
|
|
|
724
|
|
|
725 when others =>
|
|
|
726 for F in Fds'Range loop
|
|
|
727 if Is_Set (F) = 1 then
|
|
|
728 D := Fds_To_Descriptor (F);
|
|
|
729
|
|
|
730 Buffer_Size := Descriptors (D).Buffer_Size;
|
|
|
731
|
|
|
732 if Buffer_Size = 0 then
|
|
|
733 Buffer_Size := 4096;
|
|
|
734 end if;
|
|
|
735
|
|
145
|
736 -- Read may be interrupted on Linux by a signal and
|
|
|
737 -- need to be repeated. We don't want to check for
|
|
|
738 -- errno = EINTER, so just attempt to read a few
|
|
|
739 -- times.
|
|
|
740
|
|
|
741 for J in 1 .. 3 loop
|
|
|
742 N := Read (Descriptors (D).Output_Fd,
|
|
|
743 Buffer'Address, Buffer_Size);
|
|
|
744
|
|
|
745 exit when N > 0;
|
|
|
746 end loop;
|
|
111
|
747
|
|
|
748 -- Error or End of file
|
|
|
749
|
|
|
750 if N <= 0 then
|
|
145
|
751 Close_Input (Descriptors (D).all);
|
|
|
752 Result := Expect_Process_Died;
|
|
111
|
753
|
|
|
754 return;
|
|
|
755
|
|
|
756 else
|
|
|
757 -- If there is no limit to the buffer size
|
|
|
758
|
|
|
759 if Descriptors (D).Buffer_Size = 0 then
|
|
|
760 declare
|
|
|
761 Tmp : String_Access := Descriptors (D).Buffer;
|
|
|
762
|
|
|
763 begin
|
|
|
764 if Tmp /= null then
|
|
|
765 Descriptors (D).Buffer :=
|
|
|
766 new String (1 .. Tmp'Length + N);
|
|
|
767 Descriptors (D).Buffer (1 .. Tmp'Length) :=
|
|
|
768 Tmp.all;
|
|
|
769 Descriptors (D).Buffer
|
|
|
770 (Tmp'Length + 1 .. Tmp'Length + N) :=
|
|
|
771 Buffer (1 .. N);
|
|
|
772 Free (Tmp);
|
|
|
773 Descriptors (D).Buffer_Index :=
|
|
|
774 Descriptors (D).Buffer'Last;
|
|
|
775
|
|
|
776 else
|
|
|
777 Descriptors (D).Buffer :=
|
|
|
778 new String (1 .. N);
|
|
|
779 Descriptors (D).Buffer.all :=
|
|
|
780 Buffer (1 .. N);
|
|
|
781 Descriptors (D).Buffer_Index := N;
|
|
|
782 end if;
|
|
|
783 end;
|
|
|
784
|
|
|
785 else
|
|
|
786 -- Add what we read to the buffer
|
|
|
787
|
|
|
788 if Descriptors (D).Buffer_Index + N >
|
|
|
789 Descriptors (D).Buffer_Size
|
|
|
790 then
|
|
|
791 -- If the user wants to know when we have
|
|
|
792 -- read more than the buffer can contain.
|
|
|
793
|
|
|
794 if Full_Buffer then
|
|
|
795 Result := Expect_Full_Buffer;
|
|
|
796 return;
|
|
|
797 end if;
|
|
|
798
|
|
|
799 -- Keep as much as possible from the buffer,
|
|
|
800 -- and forget old characters.
|
|
|
801
|
|
|
802 Descriptors (D).Buffer
|
|
|
803 (1 .. Descriptors (D).Buffer_Size - N) :=
|
|
|
804 Descriptors (D).Buffer
|
|
|
805 (N - Descriptors (D).Buffer_Size +
|
|
|
806 Descriptors (D).Buffer_Index + 1 ..
|
|
|
807 Descriptors (D).Buffer_Index);
|
|
|
808 Descriptors (D).Buffer_Index :=
|
|
|
809 Descriptors (D).Buffer_Size - N;
|
|
|
810 end if;
|
|
|
811
|
|
|
812 -- Keep what we read in the buffer
|
|
|
813
|
|
|
814 Descriptors (D).Buffer
|
|
|
815 (Descriptors (D).Buffer_Index + 1 ..
|
|
|
816 Descriptors (D).Buffer_Index + N) :=
|
|
|
817 Buffer (1 .. N);
|
|
|
818 Descriptors (D).Buffer_Index :=
|
|
|
819 Descriptors (D).Buffer_Index + N;
|
|
|
820 end if;
|
|
|
821
|
|
|
822 -- Call each of the output filter with what we
|
|
|
823 -- read.
|
|
|
824
|
|
|
825 Call_Filters
|
|
|
826 (Descriptors (D).all, Buffer (1 .. N), Output);
|
|
|
827
|
|
|
828 Result := Expect_Match (D);
|
|
|
829 return;
|
|
|
830 end if;
|
|
|
831 end if;
|
|
|
832 end loop;
|
|
|
833 end case;
|
|
|
834 end loop;
|
|
|
835 end;
|
|
|
836 end Expect_Internal;
|
|
|
837
|
|
|
838 ----------------
|
|
|
839 -- Expect_Out --
|
|
|
840 ----------------
|
|
|
841
|
|
|
842 function Expect_Out (Descriptor : Process_Descriptor) return String is
|
|
|
843 begin
|
|
|
844 return Descriptor.Buffer (1 .. Descriptor.Last_Match_End);
|
|
|
845 end Expect_Out;
|
|
|
846
|
|
|
847 ----------------------
|
|
|
848 -- Expect_Out_Match --
|
|
|
849 ----------------------
|
|
|
850
|
|
|
851 function Expect_Out_Match (Descriptor : Process_Descriptor) return String is
|
|
|
852 begin
|
|
|
853 return Descriptor.Buffer
|
|
|
854 (Descriptor.Last_Match_Start .. Descriptor.Last_Match_End);
|
|
|
855 end Expect_Out_Match;
|
|
|
856
|
|
|
857 ------------------------
|
|
|
858 -- First_Dead_Process --
|
|
|
859 ------------------------
|
|
|
860
|
|
|
861 function First_Dead_Process
|
|
|
862 (Regexp : Multiprocess_Regexp_Array) return Natural is
|
|
|
863 begin
|
|
|
864 for R in Regexp'Range loop
|
|
|
865 if Regexp (R).Descriptor /= null
|
|
|
866 and then Regexp (R).Descriptor.Input_Fd = GNAT.OS_Lib.Invalid_FD
|
|
|
867 then
|
|
|
868 return R;
|
|
|
869 end if;
|
|
|
870 end loop;
|
|
|
871
|
|
|
872 return 0;
|
|
|
873 end First_Dead_Process;
|
|
|
874
|
|
|
875 -----------
|
|
|
876 -- Flush --
|
|
|
877 -----------
|
|
|
878
|
|
|
879 procedure Flush
|
|
|
880 (Descriptor : in out Process_Descriptor;
|
|
|
881 Timeout : Integer := 0)
|
|
|
882 is
|
|
|
883 Buffer_Size : constant Integer := 8192;
|
|
|
884 Num_Descriptors : Integer;
|
|
|
885 N : aliased Integer;
|
|
|
886 Is_Set : aliased Integer;
|
|
|
887 Buffer : aliased String (1 .. Buffer_Size);
|
|
|
888
|
|
|
889 begin
|
|
|
890 -- Empty the current buffer
|
|
|
891
|
|
|
892 Descriptor.Last_Match_End := Descriptor.Buffer_Index;
|
|
|
893 Reinitialize_Buffer (Descriptor);
|
|
|
894
|
|
|
895 -- Read everything from the process to flush its output
|
|
|
896
|
|
|
897 loop
|
|
|
898 Num_Descriptors :=
|
|
|
899 Poll (Descriptor.Output_Fd'Address,
|
|
|
900 1,
|
|
|
901 Timeout,
|
|
|
902 N'Access,
|
|
|
903 Is_Set'Address);
|
|
|
904
|
|
|
905 case Num_Descriptors is
|
|
|
906
|
|
|
907 -- Error ?
|
|
|
908
|
|
|
909 when -1 =>
|
|
|
910 raise Process_Died;
|
|
|
911
|
|
|
912 -- Timeout => End of flush
|
|
|
913
|
|
|
914 when 0 =>
|
|
|
915 return;
|
|
|
916
|
|
|
917 -- Some input
|
|
|
918
|
|
|
919 when others =>
|
|
|
920 if Is_Set = 1 then
|
|
|
921 N := Read (Descriptor.Output_Fd, Buffer'Address,
|
|
|
922 Buffer_Size);
|
|
|
923
|
|
|
924 if N = -1 then
|
|
|
925 raise Process_Died;
|
|
|
926 elsif N = 0 then
|
|
|
927 return;
|
|
|
928 end if;
|
|
|
929 end if;
|
|
|
930 end case;
|
|
|
931 end loop;
|
|
|
932 end Flush;
|
|
|
933
|
|
|
934 ----------
|
|
|
935 -- Free --
|
|
|
936 ----------
|
|
|
937
|
|
|
938 procedure Free (Regexp : in out Multiprocess_Regexp) is
|
|
|
939 procedure Unchecked_Free is new Ada.Unchecked_Deallocation
|
|
|
940 (Process_Descriptor'Class, Process_Descriptor_Access);
|
|
|
941 begin
|
|
|
942 Unchecked_Free (Regexp.Descriptor);
|
|
|
943 Free (Regexp.Regexp);
|
|
|
944 end Free;
|
|
|
945
|
|
|
946 ------------------------
|
|
|
947 -- Get_Command_Output --
|
|
|
948 ------------------------
|
|
|
949
|
|
|
950 function Get_Command_Output
|
|
|
951 (Command : String;
|
|
|
952 Arguments : GNAT.OS_Lib.Argument_List;
|
|
|
953 Input : String;
|
|
|
954 Status : not null access Integer;
|
|
|
955 Err_To_Out : Boolean := False) return String
|
|
|
956 is
|
|
|
957 Process : Process_Descriptor;
|
|
|
958
|
|
|
959 Output : String_Access := new String (1 .. 1024);
|
|
|
960 -- Buffer used to accumulate standard output from the launched
|
|
|
961 -- command, expanded as necessary during execution.
|
|
|
962
|
|
|
963 Last : Integer := 0;
|
|
|
964 -- Index of the last used character within Output
|
|
|
965
|
|
|
966 begin
|
|
|
967 Non_Blocking_Spawn
|
|
|
968 (Process, Command, Arguments, Err_To_Out => Err_To_Out,
|
|
|
969 Buffer_Size => 0);
|
|
|
970
|
|
|
971 if Input'Length > 0 then
|
|
|
972 Send (Process, Input);
|
|
|
973 end if;
|
|
|
974
|
|
145
|
975 Close_Input (Process);
|
|
111
|
976
|
|
|
977 declare
|
|
|
978 Result : Expect_Match;
|
|
|
979 pragma Unreferenced (Result);
|
|
|
980
|
|
|
981 begin
|
|
|
982 -- This loop runs until the call to Expect raises Process_Died
|
|
|
983
|
|
|
984 loop
|
|
|
985 Expect (Process, Result, ".+", Timeout => -1);
|
|
|
986
|
|
|
987 declare
|
|
|
988 NOutput : String_Access;
|
|
|
989 S : constant String := Expect_Out (Process);
|
|
|
990 pragma Assert (S'Length > 0);
|
|
|
991
|
|
|
992 begin
|
|
|
993 -- Expand buffer if we need more space. Note here that we add
|
|
|
994 -- S'Length to ensure that S will fit in the new buffer size.
|
|
|
995
|
|
|
996 if Last + S'Length > Output'Last then
|
|
|
997 NOutput := new String (1 .. 2 * Output'Last + S'Length);
|
|
|
998 NOutput (Output'Range) := Output.all;
|
|
|
999 Free (Output);
|
|
|
1000
|
|
|
1001 -- Here if current buffer size is OK
|
|
|
1002
|
|
|
1003 else
|
|
|
1004 NOutput := Output;
|
|
|
1005 end if;
|
|
|
1006
|
|
|
1007 NOutput (Last + 1 .. Last + S'Length) := S;
|
|
|
1008 Last := Last + S'Length;
|
|
|
1009 Output := NOutput;
|
|
|
1010 end;
|
|
|
1011 end loop;
|
|
|
1012
|
|
|
1013 exception
|
|
|
1014 when Process_Died =>
|
|
|
1015 Close (Process, Status.all);
|
|
|
1016 end;
|
|
|
1017
|
|
|
1018 if Last = 0 then
|
|
|
1019 Free (Output);
|
|
|
1020 return "";
|
|
|
1021 end if;
|
|
|
1022
|
|
|
1023 declare
|
|
|
1024 S : constant String := Output (1 .. Last);
|
|
|
1025 begin
|
|
|
1026 Free (Output);
|
|
|
1027 return S;
|
|
|
1028 end;
|
|
|
1029 end Get_Command_Output;
|
|
|
1030
|
|
|
1031 ------------------
|
|
|
1032 -- Get_Error_Fd --
|
|
|
1033 ------------------
|
|
|
1034
|
|
|
1035 function Get_Error_Fd
|
|
|
1036 (Descriptor : Process_Descriptor) return GNAT.OS_Lib.File_Descriptor
|
|
|
1037 is
|
|
|
1038 begin
|
|
|
1039 return Descriptor.Error_Fd;
|
|
|
1040 end Get_Error_Fd;
|
|
|
1041
|
|
|
1042 ------------------
|
|
|
1043 -- Get_Input_Fd --
|
|
|
1044 ------------------
|
|
|
1045
|
|
|
1046 function Get_Input_Fd
|
|
|
1047 (Descriptor : Process_Descriptor) return GNAT.OS_Lib.File_Descriptor
|
|
|
1048 is
|
|
|
1049 begin
|
|
|
1050 return Descriptor.Input_Fd;
|
|
|
1051 end Get_Input_Fd;
|
|
|
1052
|
|
|
1053 -------------------
|
|
|
1054 -- Get_Output_Fd --
|
|
|
1055 -------------------
|
|
|
1056
|
|
|
1057 function Get_Output_Fd
|
|
|
1058 (Descriptor : Process_Descriptor) return GNAT.OS_Lib.File_Descriptor
|
|
|
1059 is
|
|
|
1060 begin
|
|
|
1061 return Descriptor.Output_Fd;
|
|
|
1062 end Get_Output_Fd;
|
|
|
1063
|
|
|
1064 -------------
|
|
|
1065 -- Get_Pid --
|
|
|
1066 -------------
|
|
|
1067
|
|
|
1068 function Get_Pid
|
|
|
1069 (Descriptor : Process_Descriptor) return Process_Id
|
|
|
1070 is
|
|
|
1071 begin
|
|
|
1072 return Descriptor.Pid;
|
|
|
1073 end Get_Pid;
|
|
|
1074
|
|
|
1075 -----------------
|
|
|
1076 -- Has_Process --
|
|
|
1077 -----------------
|
|
|
1078
|
|
|
1079 function Has_Process (Regexp : Multiprocess_Regexp_Array) return Boolean is
|
|
|
1080 begin
|
|
|
1081 return Regexp /= (Regexp'Range => (null, null));
|
|
|
1082 end Has_Process;
|
|
|
1083
|
|
|
1084 ---------------
|
|
|
1085 -- Interrupt --
|
|
|
1086 ---------------
|
|
|
1087
|
|
|
1088 procedure Interrupt (Descriptor : in out Process_Descriptor) is
|
|
|
1089 SIGINT : constant := 2;
|
|
|
1090 begin
|
|
|
1091 Send_Signal (Descriptor, SIGINT);
|
|
|
1092 end Interrupt;
|
|
|
1093
|
|
|
1094 ------------------
|
|
|
1095 -- Lock_Filters --
|
|
|
1096 ------------------
|
|
|
1097
|
|
|
1098 procedure Lock_Filters (Descriptor : in out Process_Descriptor) is
|
|
|
1099 begin
|
|
|
1100 Descriptor.Filters_Lock := Descriptor.Filters_Lock + 1;
|
|
|
1101 end Lock_Filters;
|
|
|
1102
|
|
|
1103 ------------------------
|
|
|
1104 -- Non_Blocking_Spawn --
|
|
|
1105 ------------------------
|
|
|
1106
|
|
|
1107 procedure Non_Blocking_Spawn
|
|
|
1108 (Descriptor : out Process_Descriptor'Class;
|
|
|
1109 Command : String;
|
|
|
1110 Args : GNAT.OS_Lib.Argument_List;
|
|
|
1111 Buffer_Size : Natural := 4096;
|
|
|
1112 Err_To_Out : Boolean := False)
|
|
|
1113 is
|
|
|
1114 function Fork return Process_Id;
|
|
|
1115 pragma Import (C, Fork, "__gnat_expect_fork");
|
|
|
1116 -- Starts a new process if possible. See the Unix command fork for more
|
|
|
1117 -- information. On systems that do not support this capability (such as
|
|
|
1118 -- Windows...), this command does nothing, and Fork will return
|
|
|
1119 -- Null_Pid.
|
|
|
1120
|
|
|
1121 Pipe1, Pipe2, Pipe3 : aliased Pipe_Type;
|
|
|
1122
|
|
|
1123 Arg : String_Access;
|
|
|
1124 Arg_List : String_List (1 .. Args'Length + 2);
|
|
|
1125 C_Arg_List : aliased array (1 .. Args'Length + 2) of System.Address;
|
|
|
1126
|
|
|
1127 Command_With_Path : String_Access;
|
|
|
1128
|
|
|
1129 begin
|
|
|
1130 Command_With_Path := Locate_Exec_On_Path (Command);
|
|
|
1131
|
|
|
1132 if Command_With_Path = null then
|
|
|
1133 raise Invalid_Process;
|
|
|
1134 end if;
|
|
|
1135
|
|
|
1136 -- Create the rest of the pipes once we know we will be able to
|
|
|
1137 -- execute the process.
|
|
|
1138
|
|
|
1139 Set_Up_Communications
|
|
|
1140 (Descriptor, Err_To_Out, Pipe1'Access, Pipe2'Access, Pipe3'Access);
|
|
|
1141
|
|
|
1142 -- Fork a new process
|
|
|
1143
|
|
|
1144 Descriptor.Pid := Fork;
|
|
|
1145
|
|
|
1146 -- Are we now in the child (or, for Windows, still in the common
|
|
|
1147 -- process).
|
|
|
1148
|
|
|
1149 if Descriptor.Pid = Null_Pid then
|
|
|
1150 -- Prepare an array of arguments to pass to C
|
|
|
1151
|
|
|
1152 Arg := new String (1 .. Command_With_Path'Length + 1);
|
|
|
1153 Arg (1 .. Command_With_Path'Length) := Command_With_Path.all;
|
|
|
1154 Arg (Arg'Last) := ASCII.NUL;
|
|
|
1155 Arg_List (1) := Arg;
|
|
|
1156
|
|
|
1157 for J in Args'Range loop
|
|
|
1158 Arg := new String (1 .. Args (J)'Length + 1);
|
|
|
1159 Arg (1 .. Args (J)'Length) := Args (J).all;
|
|
|
1160 Arg (Arg'Last) := ASCII.NUL;
|
|
|
1161 Arg_List (J + 2 - Args'First) := Arg.all'Access;
|
|
|
1162 end loop;
|
|
|
1163
|
|
|
1164 Arg_List (Arg_List'Last) := null;
|
|
|
1165
|
|
|
1166 -- Make sure all arguments are compatible with OS conventions
|
|
|
1167
|
|
|
1168 Normalize_Arguments (Arg_List);
|
|
|
1169
|
|
|
1170 -- Prepare low-level argument list from the normalized arguments
|
|
|
1171
|
|
|
1172 for K in Arg_List'Range loop
|
|
|
1173 C_Arg_List (K) :=
|
|
|
1174 (if Arg_List (K) /= null
|
|
|
1175 then Arg_List (K).all'Address
|
|
|
1176 else System.Null_Address);
|
|
|
1177 end loop;
|
|
|
1178
|
|
|
1179 -- This does not return on Unix systems
|
|
|
1180
|
|
|
1181 Set_Up_Child_Communications
|
|
|
1182 (Descriptor, Pipe1, Pipe2, Pipe3, Command_With_Path.all,
|
|
|
1183 C_Arg_List'Address);
|
|
|
1184 end if;
|
|
|
1185
|
|
|
1186 Free (Command_With_Path);
|
|
|
1187
|
|
|
1188 -- Did we have an error when spawning the child ?
|
|
|
1189
|
|
|
1190 if Descriptor.Pid < Null_Pid then
|
|
|
1191 raise Invalid_Process;
|
|
|
1192 else
|
|
|
1193 -- We are now in the parent process
|
|
|
1194
|
|
|
1195 Set_Up_Parent_Communications (Descriptor, Pipe1, Pipe2, Pipe3);
|
|
|
1196 end if;
|
|
|
1197
|
|
|
1198 -- Create the buffer
|
|
|
1199
|
|
|
1200 Descriptor.Buffer_Size := Buffer_Size;
|
|
|
1201
|
|
|
1202 if Buffer_Size /= 0 then
|
|
|
1203 Descriptor.Buffer := new String (1 .. Positive (Buffer_Size));
|
|
|
1204 end if;
|
|
|
1205
|
|
|
1206 -- Initialize the filters
|
|
|
1207
|
|
|
1208 Descriptor.Filters := null;
|
|
|
1209 end Non_Blocking_Spawn;
|
|
|
1210
|
|
|
1211 -------------------------
|
|
|
1212 -- Reinitialize_Buffer --
|
|
|
1213 -------------------------
|
|
|
1214
|
|
|
1215 procedure Reinitialize_Buffer
|
|
|
1216 (Descriptor : in out Process_Descriptor'Class)
|
|
|
1217 is
|
|
|
1218 begin
|
|
|
1219 if Descriptor.Buffer_Size = 0 then
|
|
|
1220 declare
|
|
|
1221 Tmp : String_Access := Descriptor.Buffer;
|
|
|
1222
|
|
|
1223 begin
|
|
|
1224 Descriptor.Buffer :=
|
|
|
1225 new String
|
|
|
1226 (1 .. Descriptor.Buffer_Index - Descriptor.Last_Match_End);
|
|
|
1227
|
|
|
1228 if Tmp /= null then
|
|
|
1229 Descriptor.Buffer.all := Tmp
|
|
|
1230 (Descriptor.Last_Match_End + 1 .. Descriptor.Buffer_Index);
|
|
|
1231 Free (Tmp);
|
|
|
1232 end if;
|
|
|
1233 end;
|
|
|
1234
|
|
|
1235 Descriptor.Buffer_Index := Descriptor.Buffer'Last;
|
|
|
1236
|
|
|
1237 else
|
|
|
1238 Descriptor.Buffer
|
|
|
1239 (1 .. Descriptor.Buffer_Index - Descriptor.Last_Match_End) :=
|
|
|
1240 Descriptor.Buffer
|
|
|
1241 (Descriptor.Last_Match_End + 1 .. Descriptor.Buffer_Index);
|
|
|
1242
|
|
|
1243 if Descriptor.Buffer_Index > Descriptor.Last_Match_End then
|
|
|
1244 Descriptor.Buffer_Index :=
|
|
|
1245 Descriptor.Buffer_Index - Descriptor.Last_Match_End;
|
|
|
1246 else
|
|
|
1247 Descriptor.Buffer_Index := 0;
|
|
|
1248 end if;
|
|
|
1249 end if;
|
|
|
1250
|
|
|
1251 Descriptor.Last_Match_Start := 0;
|
|
|
1252 Descriptor.Last_Match_End := 0;
|
|
|
1253 end Reinitialize_Buffer;
|
|
|
1254
|
|
|
1255 -------------------
|
|
|
1256 -- Remove_Filter --
|
|
|
1257 -------------------
|
|
|
1258
|
|
|
1259 procedure Remove_Filter
|
|
|
1260 (Descriptor : in out Process_Descriptor;
|
|
|
1261 Filter : Filter_Function)
|
|
|
1262 is
|
|
|
1263 Previous : Filter_List := null;
|
|
|
1264 Current : Filter_List := Descriptor.Filters;
|
|
|
1265
|
|
|
1266 begin
|
|
|
1267 while Current /= null loop
|
|
|
1268 if Current.Filter = Filter then
|
|
|
1269 if Previous = null then
|
|
|
1270 Descriptor.Filters := Current.Next;
|
|
|
1271 else
|
|
|
1272 Previous.Next := Current.Next;
|
|
|
1273 end if;
|
|
|
1274 end if;
|
|
|
1275
|
|
|
1276 Previous := Current;
|
|
|
1277 Current := Current.Next;
|
|
|
1278 end loop;
|
|
|
1279 end Remove_Filter;
|
|
|
1280
|
|
|
1281 ----------
|
|
|
1282 -- Send --
|
|
|
1283 ----------
|
|
|
1284
|
|
|
1285 procedure Send
|
|
|
1286 (Descriptor : in out Process_Descriptor;
|
|
|
1287 Str : String;
|
|
|
1288 Add_LF : Boolean := True;
|
|
|
1289 Empty_Buffer : Boolean := False)
|
|
|
1290 is
|
|
|
1291 Line_Feed : aliased constant String := (1 .. 1 => ASCII.LF);
|
|
|
1292 Descriptors : Array_Of_Pd := (1 => Descriptor'Unrestricted_Access);
|
|
|
1293
|
|
|
1294 Result : Expect_Match;
|
|
|
1295 Discard : Natural;
|
|
|
1296 pragma Warnings (Off, Result);
|
|
|
1297 pragma Warnings (Off, Discard);
|
|
|
1298
|
|
|
1299 begin
|
|
|
1300 if Empty_Buffer then
|
|
|
1301
|
|
|
1302 -- Force a read on the process if there is anything waiting
|
|
|
1303
|
|
|
1304 Expect_Internal
|
|
|
1305 (Descriptors, Result, Timeout => 0, Full_Buffer => False);
|
|
|
1306
|
|
|
1307 if Result = Expect_Internal_Error
|
|
|
1308 or else Result = Expect_Process_Died
|
|
|
1309 then
|
|
|
1310 raise Process_Died;
|
|
|
1311 end if;
|
|
|
1312
|
|
|
1313 Descriptor.Last_Match_End := Descriptor.Buffer_Index;
|
|
|
1314
|
|
|
1315 -- Empty the buffer
|
|
|
1316
|
|
|
1317 Reinitialize_Buffer (Descriptor);
|
|
|
1318 end if;
|
|
|
1319
|
|
|
1320 Call_Filters (Descriptor, Str, Input);
|
|
|
1321 Discard :=
|
|
|
1322 Write (Descriptor.Input_Fd, Str'Address, Str'Last - Str'First + 1);
|
|
|
1323
|
|
|
1324 if Add_LF then
|
|
|
1325 Call_Filters (Descriptor, Line_Feed, Input);
|
|
|
1326 Discard :=
|
|
|
1327 Write (Descriptor.Input_Fd, Line_Feed'Address, 1);
|
|
|
1328 end if;
|
|
|
1329 end Send;
|
|
|
1330
|
|
|
1331 -----------------
|
|
|
1332 -- Send_Signal --
|
|
|
1333 -----------------
|
|
|
1334
|
|
|
1335 procedure Send_Signal
|
|
|
1336 (Descriptor : Process_Descriptor;
|
|
|
1337 Signal : Integer)
|
|
|
1338 is
|
|
|
1339 begin
|
|
|
1340 -- A nonpositive process id passed to kill has special meanings. For
|
|
|
1341 -- example, -1 means kill all processes in sight, including self, in
|
|
|
1342 -- POSIX and Windows (and something slightly different in Linux). See
|
|
|
1343 -- man pages for details. In any case, we don't want to do that. Note
|
|
|
1344 -- that Descriptor.Pid will be -1 if the process was not successfully
|
|
|
1345 -- started; we don't want to kill ourself in that case.
|
|
|
1346
|
|
|
1347 if Descriptor.Pid > 0 then
|
|
|
1348 Kill (Descriptor.Pid, Signal, Close => 1);
|
|
|
1349 -- ??? Need to check process status here
|
|
|
1350 else
|
|
|
1351 raise Invalid_Process;
|
|
|
1352 end if;
|
|
|
1353 end Send_Signal;
|
|
|
1354
|
|
|
1355 ---------------------------------
|
|
|
1356 -- Set_Up_Child_Communications --
|
|
|
1357 ---------------------------------
|
|
|
1358
|
|
|
1359 procedure Set_Up_Child_Communications
|
|
|
1360 (Pid : in out Process_Descriptor;
|
|
|
1361 Pipe1 : in out Pipe_Type;
|
|
|
1362 Pipe2 : in out Pipe_Type;
|
|
|
1363 Pipe3 : in out Pipe_Type;
|
|
|
1364 Cmd : String;
|
|
|
1365 Args : System.Address)
|
|
|
1366 is
|
|
|
1367 pragma Warnings (Off, Pid);
|
|
|
1368 pragma Warnings (Off, Pipe1);
|
|
|
1369 pragma Warnings (Off, Pipe2);
|
|
|
1370 pragma Warnings (Off, Pipe3);
|
|
|
1371
|
|
|
1372 Input : File_Descriptor;
|
|
|
1373 Output : File_Descriptor;
|
|
|
1374 Error : File_Descriptor;
|
|
|
1375
|
|
|
1376 No_Fork_On_Target : constant Boolean := Target_OS = Windows;
|
|
|
1377
|
|
|
1378 begin
|
|
|
1379 if No_Fork_On_Target then
|
|
|
1380
|
|
|
1381 -- Since Windows does not have a separate fork/exec, we need to
|
|
|
1382 -- perform the following actions:
|
|
|
1383
|
|
|
1384 -- - save stdin, stdout, stderr
|
|
|
1385 -- - replace them by our pipes
|
|
|
1386 -- - create the child with process handle inheritance
|
|
|
1387 -- - revert to the previous stdin, stdout and stderr.
|
|
|
1388
|
|
|
1389 Input := Dup (GNAT.OS_Lib.Standin);
|
|
|
1390 Output := Dup (GNAT.OS_Lib.Standout);
|
|
|
1391 Error := Dup (GNAT.OS_Lib.Standerr);
|
|
|
1392 end if;
|
|
|
1393
|
|
|
1394 -- Since we are still called from the parent process, there is no way
|
|
|
1395 -- currently we can cleanly close the unneeded ends of the pipes, but
|
|
|
1396 -- this doesn't really matter.
|
|
|
1397
|
|
|
1398 -- We could close Pipe1.Output, Pipe2.Input, Pipe3.Input
|
|
|
1399
|
|
|
1400 Dup2 (Pipe1.Input, GNAT.OS_Lib.Standin);
|
|
|
1401 Dup2 (Pipe2.Output, GNAT.OS_Lib.Standout);
|
|
|
1402 Dup2 (Pipe3.Output, GNAT.OS_Lib.Standerr);
|
|
|
1403
|
|
|
1404 Portable_Execvp (Pid.Pid'Access, Cmd & ASCII.NUL, Args);
|
|
|
1405
|
|
|
1406 -- The following lines are only required for Windows systems and will
|
|
|
1407 -- not be executed on Unix systems, but we use the same condition as
|
|
|
1408 -- above to avoid warnings on uninitialized variables on Unix systems.
|
|
|
1409 -- We are now in the parent process.
|
|
|
1410
|
|
|
1411 if No_Fork_On_Target then
|
|
|
1412
|
|
|
1413 -- Restore the old descriptors
|
|
|
1414
|
|
|
1415 Dup2 (Input, GNAT.OS_Lib.Standin);
|
|
|
1416 Dup2 (Output, GNAT.OS_Lib.Standout);
|
|
|
1417 Dup2 (Error, GNAT.OS_Lib.Standerr);
|
|
|
1418 Close (Input);
|
|
|
1419 Close (Output);
|
|
|
1420 Close (Error);
|
|
|
1421 end if;
|
|
|
1422 end Set_Up_Child_Communications;
|
|
|
1423
|
|
|
1424 ---------------------------
|
|
|
1425 -- Set_Up_Communications --
|
|
|
1426 ---------------------------
|
|
|
1427
|
|
|
1428 procedure Set_Up_Communications
|
|
|
1429 (Pid : in out Process_Descriptor;
|
|
|
1430 Err_To_Out : Boolean;
|
|
|
1431 Pipe1 : not null access Pipe_Type;
|
|
|
1432 Pipe2 : not null access Pipe_Type;
|
|
|
1433 Pipe3 : not null access Pipe_Type)
|
|
|
1434 is
|
|
|
1435 Status : Boolean;
|
|
|
1436 pragma Unreferenced (Status);
|
|
|
1437
|
|
|
1438 begin
|
|
|
1439 -- Create the pipes
|
|
|
1440
|
|
|
1441 if Create_Pipe (Pipe1) /= 0 then
|
|
|
1442 return;
|
|
|
1443 end if;
|
|
|
1444
|
|
|
1445 if Create_Pipe (Pipe2) /= 0 then
|
|
|
1446 Close (Pipe1.Input);
|
|
|
1447 Close (Pipe1.Output);
|
|
|
1448 return;
|
|
|
1449 end if;
|
|
|
1450
|
|
|
1451 -- Record the 'parent' end of the two pipes in Pid:
|
|
|
1452 -- Child stdin is connected to the 'write' end of Pipe1;
|
|
|
1453 -- Child stdout is connected to the 'read' end of Pipe2.
|
|
|
1454 -- We do not want these descriptors to remain open in the child
|
|
|
1455 -- process, so we mark them close-on-exec/non-inheritable.
|
|
|
1456
|
|
|
1457 Pid.Input_Fd := Pipe1.Output;
|
|
|
1458 Set_Close_On_Exec (Pipe1.Output, True, Status);
|
|
|
1459 Pid.Output_Fd := Pipe2.Input;
|
|
|
1460 Set_Close_On_Exec (Pipe2.Input, True, Status);
|
|
|
1461
|
|
|
1462 if Err_To_Out then
|
|
|
1463
|
|
|
1464 -- Reuse the standard output pipe for standard error
|
|
|
1465
|
|
|
1466 Pipe3.all := Pipe2.all;
|
|
|
1467
|
|
|
1468 else
|
|
|
1469 -- Create a separate pipe for standard error
|
|
|
1470
|
|
|
1471 if Create_Pipe (Pipe3) /= 0 then
|
|
|
1472 Pipe3.all := Pipe2.all;
|
|
|
1473 end if;
|
|
|
1474 end if;
|
|
|
1475
|
|
|
1476 -- As above, record the proper fd for the child's standard error stream
|
|
|
1477
|
|
|
1478 Pid.Error_Fd := Pipe3.Input;
|
|
|
1479 Set_Close_On_Exec (Pipe3.Input, True, Status);
|
|
|
1480 end Set_Up_Communications;
|
|
|
1481
|
|
|
1482 ----------------------------------
|
|
|
1483 -- Set_Up_Parent_Communications --
|
|
|
1484 ----------------------------------
|
|
|
1485
|
|
|
1486 procedure Set_Up_Parent_Communications
|
|
|
1487 (Pid : in out Process_Descriptor;
|
|
|
1488 Pipe1 : in out Pipe_Type;
|
|
|
1489 Pipe2 : in out Pipe_Type;
|
|
|
1490 Pipe3 : in out Pipe_Type)
|
|
|
1491 is
|
|
|
1492 pragma Warnings (Off, Pid);
|
|
|
1493 pragma Warnings (Off, Pipe1);
|
|
|
1494 pragma Warnings (Off, Pipe2);
|
|
|
1495 pragma Warnings (Off, Pipe3);
|
|
|
1496
|
|
|
1497 begin
|
|
|
1498 Close (Pipe1.Input);
|
|
|
1499 Close (Pipe2.Output);
|
|
|
1500
|
|
|
1501 if Pipe3.Output /= Pipe2.Output then
|
|
|
1502 Close (Pipe3.Output);
|
|
|
1503 end if;
|
|
|
1504 end Set_Up_Parent_Communications;
|
|
|
1505
|
|
|
1506 ------------------
|
|
|
1507 -- Trace_Filter --
|
|
|
1508 ------------------
|
|
|
1509
|
|
|
1510 procedure Trace_Filter
|
|
|
1511 (Descriptor : Process_Descriptor'Class;
|
|
|
1512 Str : String;
|
|
|
1513 User_Data : System.Address := System.Null_Address)
|
|
|
1514 is
|
|
|
1515 pragma Warnings (Off, Descriptor);
|
|
|
1516 pragma Warnings (Off, User_Data);
|
|
|
1517 begin
|
|
|
1518 GNAT.IO.Put (Str);
|
|
|
1519 end Trace_Filter;
|
|
|
1520
|
|
|
1521 --------------------
|
|
|
1522 -- Unlock_Filters --
|
|
|
1523 --------------------
|
|
|
1524
|
|
|
1525 procedure Unlock_Filters (Descriptor : in out Process_Descriptor) is
|
|
|
1526 begin
|
|
|
1527 if Descriptor.Filters_Lock > 0 then
|
|
|
1528 Descriptor.Filters_Lock := Descriptor.Filters_Lock - 1;
|
|
|
1529 end if;
|
|
|
1530 end Unlock_Filters;
|
|
|
1531
|
|
|
1532 end GNAT.Expect;
|
