1 ------------------------------------------------------------------------------
3 -- GNAT LIBRARY COMPONENTS --
5 -- G N A T . E X P E C T . T T Y --
9 -- Copyright (C) 2000-2023, AdaCore --
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. --
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. --
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/>. --
27 -- GNAT was originally developed by the GNAT team at New York University. --
28 -- Extensive contributions were provided by Ada Core Technologies Inc. --
30 ------------------------------------------------------------------------------
32 with GNAT
.OS_Lib
; use GNAT
.OS_Lib
;
34 with System
; use System
;
36 package body GNAT
.Expect
.TTY
is
38 On_Windows
: constant Boolean := Directory_Separator
= '\';
39 -- True when on Windows
42 (Process
: System
.Address
;
43 Blocking
: Integer) return Integer;
44 pragma Import
(C
, Waitpid
, "__gnat_tty_waitpid");
45 -- Wait for a specific process id, and return its exit code
47 ------------------------
48 -- Is_Process_Running --
49 ------------------------
51 function Is_Process_Running
52 (Descriptor
: in out TTY_Process_Descriptor
) return Boolean
55 if Descriptor
.Process
= System
.Null_Address
then
59 Descriptor
.Exit_Status
:= Waitpid
(Descriptor
.Process
, Blocking
=> 0);
61 return Descriptor
.Exit_Status
= Still_Active
;
62 end Is_Process_Running
;
68 overriding
procedure Close
69 (Descriptor
: in out TTY_Process_Descriptor
;
72 procedure Terminate_Process
(Process
: System
.Address
);
73 pragma Import
(C
, Terminate_Process
, "__gnat_terminate_process");
75 procedure Free_Process
(Process
: System
.Address
);
76 pragma Import
(C
, Free_Process
, "__gnat_free_process");
79 -- If we haven't already closed the process
81 if Descriptor
.Process
= System
.Null_Address
then
82 Status
:= Descriptor
.Exit_Status
;
85 -- Send a Ctrl-C to the process first. This way, if the launched
86 -- process is a "sh" or "cmd", the child processes will get
87 -- terminated as well. Otherwise, terminating the main process
88 -- brutally will leave the children running.
90 -- Note: special characters are sent to the terminal to generate the
91 -- signal, so this needs to be done while the file descriptors are
92 -- still open (it used to be after the closes and that was wrong).
94 Close_Input
(Descriptor
);
96 if Descriptor
.Error_Fd
/= Descriptor
.Output_Fd
97 and then Descriptor
.Error_Fd
/= Invalid_FD
99 Close
(Descriptor
.Error_Fd
);
102 if Descriptor
.Output_Fd
/= Invalid_FD
then
103 Close
(Descriptor
.Output_Fd
);
106 if Descriptor
.Exit_Status
= Still_Active
then
107 Status
:= Waitpid
(Descriptor
.Process
, Blocking
=> 0);
109 if Status
= Still_Active
then
110 -- In theory the process might have died since the check. In
111 -- practice the following calls should not cause any issue.
113 Interrupt
(Descriptor
);
115 Terminate_Process
(Descriptor
.Process
);
116 Status
:= Waitpid
(Descriptor
.Process
, Blocking
=> 1);
117 Descriptor
.Exit_Status
:= Status
;
121 -- If Exit_Status is not STILL_ACTIVE just retrieve the saved
124 Status
:= Descriptor
.Exit_Status
;
127 Free_Process
(Descriptor
.Process
'Address);
128 Descriptor
.Process
:= System
.Null_Address
;
130 GNAT
.OS_Lib
.Free
(Descriptor
.Buffer
);
131 Descriptor
.Buffer_Size
:= 0;
135 overriding
procedure Close
(Descriptor
: in out TTY_Process_Descriptor
) is
138 Close
(Descriptor
, Status
);
145 overriding
procedure Close_Input
146 (Descriptor
: in out TTY_Process_Descriptor
)
149 (Handle
: System
.Address
) return GNAT
.OS_Lib
.File_Descriptor
;
150 pragma Import
(C
, TTY_FD
, "__gnat_tty_fd");
152 procedure Close_TTY
(Process
: System
.Address
);
153 pragma Import
(C
, Close_TTY
, "__gnat_close_tty");
156 if not On_Windows
and then Descriptor
.Process
/= System
.Null_Address
then
157 -- Check whether input/output/error streams use master descriptor and
158 -- reset corresponding members.
160 if Descriptor
.Input_Fd
= TTY_FD
(Descriptor
.Process
) then
161 Descriptor
.Input_Fd
:= Invalid_FD
;
164 if Descriptor
.Output_Fd
= TTY_FD
(Descriptor
.Process
) then
165 Descriptor
.Output_Fd
:= Invalid_FD
;
168 if Descriptor
.Error_Fd
= TTY_FD
(Descriptor
.Process
) then
169 Descriptor
.Error_Fd
:= Invalid_FD
;
172 -- Close master descriptor.
174 Close_TTY
(Descriptor
.Process
);
177 -- Call parent's implementation to close all remaining descriptors.
179 Process_Descriptor
(Descriptor
).Close_Input
;
182 -----------------------------
183 -- Close_Pseudo_Descriptor --
184 -----------------------------
186 procedure Close_Pseudo_Descriptor
187 (Descriptor
: in out TTY_Process_Descriptor
)
190 Descriptor
.Buffer_Size
:= 0;
191 GNAT
.OS_Lib
.Free
(Descriptor
.Buffer
);
192 end Close_Pseudo_Descriptor
;
198 overriding
procedure Interrupt
199 (Descriptor
: in out TTY_Process_Descriptor
)
201 procedure Internal
(Process
: System
.Address
);
202 pragma Import
(C
, Internal
, "__gnat_interrupt_process");
204 if Descriptor
.Process
/= System
.Null_Address
then
205 Internal
(Descriptor
.Process
);
209 procedure Interrupt
(Pid
: Integer) is
210 procedure Internal
(Pid
: Integer);
211 pragma Import
(C
, Internal
, "__gnat_interrupt_pid");
216 -----------------------
217 -- Terminate_Process --
218 -----------------------
220 procedure Terminate_Process
(Pid
: Integer) is
221 procedure Internal
(Pid
: Integer);
222 pragma Import
(C
, Internal
, "__gnat_terminate_pid");
225 end Terminate_Process
;
227 -----------------------
228 -- Pseudo_Descriptor --
229 -----------------------
231 procedure Pseudo_Descriptor
232 (Descriptor
: out TTY_Process_Descriptor
'Class;
233 TTY
: GNAT
.TTY
.TTY_Handle
;
234 Buffer_Size
: Natural := 4096) is
236 Descriptor
.Input_Fd
:= GNAT
.TTY
.TTY_Descriptor
(TTY
);
237 Descriptor
.Output_Fd
:= Descriptor
.Input_Fd
;
241 Descriptor
.Buffer_Size
:= Buffer_Size
;
243 if Buffer_Size
/= 0 then
244 Descriptor
.Buffer
:= new String (1 .. Positive (Buffer_Size
));
246 end Pseudo_Descriptor
;
252 overriding
procedure Send
253 (Descriptor
: in out TTY_Process_Descriptor
;
255 Add_LF
: Boolean := True;
256 Empty_Buffer
: Boolean := False)
258 Header
: String (1 .. 5);
263 (Process
: System
.Address
;
267 pragma Import
(C
, Internal
, "__gnat_send_header");
270 Length
:= Str
'Length;
273 Length
:= Length
+ 1;
276 Internal
(Descriptor
.Process
, Header
, Length
, Ret
);
280 -- Need to use the header
283 (Process_Descriptor
(Descriptor
),
284 Header
& Str
, Add_LF
, Empty_Buffer
);
288 (Process_Descriptor
(Descriptor
),
289 Str
, Add_LF
, Empty_Buffer
);
298 (Descriptor
: in out TTY_Process_Descriptor
'Class;
302 procedure Internal
(Process
: System
.Address
; R
, C
: Integer);
303 pragma Import
(C
, Internal
, "__gnat_setup_winsize");
305 if Descriptor
.Process
/= System
.Null_Address
then
306 Internal
(Descriptor
.Process
, Rows
, Columns
);
310 ---------------------------
311 -- Set_Up_Communications --
312 ---------------------------
314 overriding
procedure Set_Up_Communications
315 (Pid
: in out TTY_Process_Descriptor
;
316 Err_To_Out
: Boolean;
317 Pipe1
: not null access Pipe_Type
;
318 Pipe2
: not null access Pipe_Type
;
319 Pipe3
: not null access Pipe_Type
)
321 pragma Unreferenced
(Err_To_Out
, Pipe1
, Pipe2
, Pipe3
);
323 function Internal
(Process
: System
.Address
) return Integer;
324 pragma Import
(C
, Internal
, "__gnat_setup_communication");
327 Pid
.Exit_Status
:= Still_Active
;
328 if Internal
(Pid
.Process
'Address) /= 0 then
329 raise Invalid_Process
with "cannot setup communication.";
331 end Set_Up_Communications
;
333 ---------------------------------
334 -- Set_Up_Child_Communications --
335 ---------------------------------
337 overriding
procedure Set_Up_Child_Communications
338 (Pid
: in out TTY_Process_Descriptor
;
339 Pipe1
: in out Pipe_Type
;
340 Pipe2
: in out Pipe_Type
;
341 Pipe3
: in out Pipe_Type
;
343 Args
: System
.Address
)
345 pragma Unreferenced
(Pipe1
, Pipe2
, Pipe3
, Cmd
);
347 (Process
: System
.Address
; Argv
: System
.Address
; Use_Pipes
: Integer)
349 pragma Import
(C
, Internal
, "__gnat_setup_child_communication");
352 Pid
.Pid
:= Internal
(Pid
.Process
, Args
, Boolean'Pos (Pid
.Use_Pipes
));
353 end Set_Up_Child_Communications
;
355 ----------------------------------
356 -- Set_Up_Parent_Communications --
357 ----------------------------------
359 overriding
procedure Set_Up_Parent_Communications
360 (Pid
: in out TTY_Process_Descriptor
;
361 Pipe1
: in out Pipe_Type
;
362 Pipe2
: in out Pipe_Type
;
363 Pipe3
: in out Pipe_Type
)
365 pragma Unreferenced
(Pipe1
, Pipe2
, Pipe3
);
368 (Process
: System
.Address
;
369 Inputfp
: out File_Descriptor
;
370 Outputfp
: out File_Descriptor
;
371 Errorfp
: out File_Descriptor
;
372 Pid
: out Process_Id
);
373 pragma Import
(C
, Internal
, "__gnat_setup_parent_communication");
377 (Pid
.Process
, Pid
.Input_Fd
, Pid
.Output_Fd
, Pid
.Error_Fd
, Pid
.Pid
);
378 end Set_Up_Parent_Communications
;
384 procedure Set_Use_Pipes
385 (Descriptor
: in out TTY_Process_Descriptor
;
386 Use_Pipes
: Boolean) is
388 Descriptor
.Use_Pipes
:= Use_Pipes
;