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