1------------------------------------------------------------------------------ 2-- -- 3-- GNAT LIBRARY COMPONENTS -- 4-- -- 5-- G N A T . E X P E C T . T T Y -- 6-- -- 7-- S p e c -- 8-- -- 9-- Copyright (C) 2000-2019, AdaCore -- 10-- -- 11-- GNAT is free software; you can redistribute it and/or modify it under -- 12-- terms of the GNU General Public License as published by the Free Soft- -- 13-- ware Foundation; either version 3, or (at your option) any later ver- -- 14-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- 15-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- 16-- or FITNESS FOR A PARTICULAR PURPOSE. -- 17-- -- 18-- As a special exception under Section 7 of GPL version 3, you are granted -- 19-- additional permissions described in the GCC Runtime Library Exception, -- 20-- version 3.1, as published by the Free Software Foundation. -- 21-- -- 22-- You should have received a copy of the GNU General Public License and -- 23-- a copy of the GCC Runtime Library Exception along with this program; -- 24-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- 25-- <http://www.gnu.org/licenses/>. -- 26-- -- 27-- GNAT was originally developed by the GNAT team at New York University. -- 28-- Extensive contributions were provided by Ada Core Technologies Inc. -- 29-- -- 30------------------------------------------------------------------------------ 31 32with GNAT.OS_Lib; use GNAT.OS_Lib; 33 34with System; use System; 35 36package body GNAT.Expect.TTY is 37 38 On_Windows : constant Boolean := Directory_Separator = '\'; 39 -- True when on Windows 40 41 function Waitpid 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 46 47 ------------------------ 48 -- Is_Process_Running -- 49 ------------------------ 50 51 function Is_Process_Running 52 (Descriptor : in out TTY_Process_Descriptor) return Boolean 53 is 54 begin 55 if Descriptor.Process = System.Null_Address then 56 return False; 57 end if; 58 59 Descriptor.Exit_Status := Waitpid (Descriptor.Process, Blocking => 0); 60 61 return Descriptor.Exit_Status = Still_Active; 62 end Is_Process_Running; 63 64 ----------- 65 -- Close -- 66 ----------- 67 68 overriding procedure Close 69 (Descriptor : in out TTY_Process_Descriptor; 70 Status : out Integer) 71 is 72 procedure Terminate_Process (Process : System.Address); 73 pragma Import (C, Terminate_Process, "__gnat_terminate_process"); 74 75 procedure Free_Process (Process : System.Address); 76 pragma Import (C, Free_Process, "__gnat_free_process"); 77 78 begin 79 -- If we haven't already closed the process 80 81 if Descriptor.Process = System.Null_Address then 82 Status := Descriptor.Exit_Status; 83 84 else 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. 89 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). 93 94 Close_Input (Descriptor); 95 96 if Descriptor.Error_Fd /= Descriptor.Output_Fd 97 and then Descriptor.Error_Fd /= Invalid_FD 98 then 99 Close (Descriptor.Error_Fd); 100 end if; 101 102 if Descriptor.Output_Fd /= Invalid_FD then 103 Close (Descriptor.Output_Fd); 104 end if; 105 106 if Descriptor.Exit_Status = Still_Active then 107 Status := Waitpid (Descriptor.Process, Blocking => 0); 108 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. 112 113 Interrupt (Descriptor); 114 delay (0.05); 115 Terminate_Process (Descriptor.Process); 116 Status := Waitpid (Descriptor.Process, Blocking => 1); 117 Descriptor.Exit_Status := Status; 118 end if; 119 120 else 121 -- If Exit_Status is not STILL_ACTIVE just retrieve the saved 122 -- exit status. 123 124 Status := Descriptor.Exit_Status; 125 end if; 126 127 Free_Process (Descriptor.Process'Address); 128 Descriptor.Process := System.Null_Address; 129 130 GNAT.OS_Lib.Free (Descriptor.Buffer); 131 Descriptor.Buffer_Size := 0; 132 end if; 133 end Close; 134 135 overriding procedure Close (Descriptor : in out TTY_Process_Descriptor) is 136 Status : Integer; 137 begin 138 Close (Descriptor, Status); 139 end Close; 140 141 ----------------- 142 -- Close_Input -- 143 ----------------- 144 145 overriding procedure Close_Input 146 (Descriptor : in out TTY_Process_Descriptor) 147 is 148 function TTY_FD 149 (Handle : System.Address) return GNAT.OS_Lib.File_Descriptor; 150 pragma Import (C, TTY_FD, "__gnat_tty_fd"); 151 152 procedure Close_TTY (Process : System.Address); 153 pragma Import (C, Close_TTY, "__gnat_close_tty"); 154 155 begin 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. 159 160 if Descriptor.Input_Fd = TTY_FD (Descriptor.Process) then 161 Descriptor.Input_Fd := Invalid_FD; 162 end if; 163 164 if Descriptor.Output_Fd = TTY_FD (Descriptor.Process) then 165 Descriptor.Output_Fd := Invalid_FD; 166 end if; 167 168 if Descriptor.Error_Fd = TTY_FD (Descriptor.Process) then 169 Descriptor.Error_Fd := Invalid_FD; 170 end if; 171 172 -- Close master descriptor. 173 174 Close_TTY (Descriptor.Process); 175 end if; 176 177 -- Call parent's implementation to close all remaining descriptors. 178 179 Process_Descriptor (Descriptor).Close_Input; 180 end Close_Input; 181 182 ----------------------------- 183 -- Close_Pseudo_Descriptor -- 184 ----------------------------- 185 186 procedure Close_Pseudo_Descriptor 187 (Descriptor : in out TTY_Process_Descriptor) 188 is 189 begin 190 Descriptor.Buffer_Size := 0; 191 GNAT.OS_Lib.Free (Descriptor.Buffer); 192 end Close_Pseudo_Descriptor; 193 194 --------------- 195 -- Interrupt -- 196 --------------- 197 198 overriding procedure Interrupt 199 (Descriptor : in out TTY_Process_Descriptor) 200 is 201 procedure Internal (Process : System.Address); 202 pragma Import (C, Internal, "__gnat_interrupt_process"); 203 begin 204 if Descriptor.Process /= System.Null_Address then 205 Internal (Descriptor.Process); 206 end if; 207 end Interrupt; 208 209 procedure Interrupt (Pid : Integer) is 210 procedure Internal (Pid : Integer); 211 pragma Import (C, Internal, "__gnat_interrupt_pid"); 212 begin 213 Internal (Pid); 214 end Interrupt; 215 216 ----------------------- 217 -- Terminate_Process -- 218 ----------------------- 219 220 procedure Terminate_Process (Pid : Integer) is 221 procedure Internal (Pid : Integer); 222 pragma Import (C, Internal, "__gnat_terminate_pid"); 223 begin 224 Internal (Pid); 225 end Terminate_Process; 226 227 ----------------------- 228 -- Pseudo_Descriptor -- 229 ----------------------- 230 231 procedure Pseudo_Descriptor 232 (Descriptor : out TTY_Process_Descriptor'Class; 233 TTY : GNAT.TTY.TTY_Handle; 234 Buffer_Size : Natural := 4096) is 235 begin 236 Descriptor.Input_Fd := GNAT.TTY.TTY_Descriptor (TTY); 237 Descriptor.Output_Fd := Descriptor.Input_Fd; 238 239 -- Create the buffer 240 241 Descriptor.Buffer_Size := Buffer_Size; 242 243 if Buffer_Size /= 0 then 244 Descriptor.Buffer := new String (1 .. Positive (Buffer_Size)); 245 end if; 246 end Pseudo_Descriptor; 247 248 ---------- 249 -- Send -- 250 ---------- 251 252 overriding procedure Send 253 (Descriptor : in out TTY_Process_Descriptor; 254 Str : String; 255 Add_LF : Boolean := True; 256 Empty_Buffer : Boolean := False) 257 is 258 Header : String (1 .. 5); 259 Length : Natural; 260 Ret : Natural; 261 262 procedure Internal 263 (Process : System.Address; 264 S : in out String; 265 Length : Natural; 266 Ret : out Natural); 267 pragma Import (C, Internal, "__gnat_send_header"); 268 269 begin 270 Length := Str'Length; 271 272 if Add_LF then 273 Length := Length + 1; 274 end if; 275 276 Internal (Descriptor.Process, Header, Length, Ret); 277 278 if Ret = 1 then 279 280 -- Need to use the header 281 282 GNAT.Expect.Send 283 (Process_Descriptor (Descriptor), 284 Header & Str, Add_LF, Empty_Buffer); 285 286 else 287 GNAT.Expect.Send 288 (Process_Descriptor (Descriptor), 289 Str, Add_LF, Empty_Buffer); 290 end if; 291 end Send; 292 293 -------------- 294 -- Set_Size -- 295 -------------- 296 297 procedure Set_Size 298 (Descriptor : in out TTY_Process_Descriptor'Class; 299 Rows : Natural; 300 Columns : Natural) 301 is 302 procedure Internal (Process : System.Address; R, C : Integer); 303 pragma Import (C, Internal, "__gnat_setup_winsize"); 304 begin 305 if Descriptor.Process /= System.Null_Address then 306 Internal (Descriptor.Process, Rows, Columns); 307 end if; 308 end Set_Size; 309 310 --------------------------- 311 -- Set_Up_Communications -- 312 --------------------------- 313 314 overriding procedure Set_Up_Communications 315 (Pid : in out TTY_Process_Descriptor; 316 Err_To_Out : Boolean; 317 Pipe1 : access Pipe_Type; 318 Pipe2 : access Pipe_Type; 319 Pipe3 : access Pipe_Type) 320 is 321 pragma Unreferenced (Err_To_Out, Pipe1, Pipe2, Pipe3); 322 323 function Internal (Process : System.Address) return Integer; 324 pragma Import (C, Internal, "__gnat_setup_communication"); 325 326 begin 327 Pid.Exit_Status := Still_Active; 328 if Internal (Pid.Process'Address) /= 0 then 329 raise Invalid_Process with "cannot setup communication."; 330 end if; 331 end Set_Up_Communications; 332 333 --------------------------------- 334 -- Set_Up_Child_Communications -- 335 --------------------------------- 336 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; 342 Cmd : String; 343 Args : System.Address) 344 is 345 pragma Unreferenced (Pipe1, Pipe2, Pipe3, Cmd); 346 function Internal 347 (Process : System.Address; Argv : System.Address; Use_Pipes : Integer) 348 return Process_Id; 349 pragma Import (C, Internal, "__gnat_setup_child_communication"); 350 351 begin 352 Pid.Pid := Internal (Pid.Process, Args, Boolean'Pos (Pid.Use_Pipes)); 353 end Set_Up_Child_Communications; 354 355 ---------------------------------- 356 -- Set_Up_Parent_Communications -- 357 ---------------------------------- 358 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) 364 is 365 pragma Unreferenced (Pipe1, Pipe2, Pipe3); 366 367 procedure Internal 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"); 374 375 begin 376 Internal 377 (Pid.Process, Pid.Input_Fd, Pid.Output_Fd, Pid.Error_Fd, Pid.Pid); 378 end Set_Up_Parent_Communications; 379 380 ------------------- 381 -- Set_Use_Pipes -- 382 ------------------- 383 384 procedure Set_Use_Pipes 385 (Descriptor : in out TTY_Process_Descriptor; 386 Use_Pipes : Boolean) is 387 begin 388 Descriptor.Use_Pipes := Use_Pipes; 389 end Set_Use_Pipes; 390 391end GNAT.Expect.TTY; 392