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-2018, 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 ----------- 42 -- Close -- 43 ----------- 44 45 overriding procedure Close 46 (Descriptor : in out TTY_Process_Descriptor; 47 Status : out Integer) 48 is 49 procedure Terminate_Process (Process : System.Address); 50 pragma Import (C, Terminate_Process, "__gnat_terminate_process"); 51 52 function Waitpid (Process : System.Address) return Integer; 53 pragma Import (C, Waitpid, "__gnat_tty_waitpid"); 54 -- Wait for a specific process id, and return its exit code 55 56 procedure Free_Process (Process : System.Address); 57 pragma Import (C, Free_Process, "__gnat_free_process"); 58 59 procedure Close_TTY (Process : System.Address); 60 pragma Import (C, Close_TTY, "__gnat_close_tty"); 61 62 begin 63 -- If we haven't already closed the process 64 65 if Descriptor.Process = System.Null_Address then 66 Status := -1; 67 68 else 69 -- Send a Ctrl-C to the process first. This way, if the launched 70 -- process is a "sh" or "cmd", the child processes will get 71 -- terminated as well. Otherwise, terminating the main process 72 -- brutally will leave the children running. 73 74 -- Note: special characters are sent to the terminal to generate the 75 -- signal, so this needs to be done while the file descriptors are 76 -- still open (it used to be after the closes and that was wrong). 77 78 Interrupt (Descriptor); 79 delay (0.05); 80 81 if Descriptor.Input_Fd /= Invalid_FD then 82 Close (Descriptor.Input_Fd); 83 end if; 84 85 if Descriptor.Error_Fd /= Descriptor.Output_Fd 86 and then Descriptor.Error_Fd /= Invalid_FD 87 then 88 Close (Descriptor.Error_Fd); 89 end if; 90 91 if Descriptor.Output_Fd /= Invalid_FD then 92 Close (Descriptor.Output_Fd); 93 end if; 94 95 Terminate_Process (Descriptor.Process); 96 Status := Waitpid (Descriptor.Process); 97 98 if not On_Windows then 99 Close_TTY (Descriptor.Process); 100 end if; 101 102 Free_Process (Descriptor.Process'Address); 103 Descriptor.Process := System.Null_Address; 104 105 GNAT.OS_Lib.Free (Descriptor.Buffer); 106 Descriptor.Buffer_Size := 0; 107 end if; 108 end Close; 109 110 overriding procedure Close (Descriptor : in out TTY_Process_Descriptor) is 111 Status : Integer; 112 begin 113 Close (Descriptor, Status); 114 end Close; 115 116 ----------------------------- 117 -- Close_Pseudo_Descriptor -- 118 ----------------------------- 119 120 procedure Close_Pseudo_Descriptor 121 (Descriptor : in out TTY_Process_Descriptor) 122 is 123 begin 124 Descriptor.Buffer_Size := 0; 125 GNAT.OS_Lib.Free (Descriptor.Buffer); 126 end Close_Pseudo_Descriptor; 127 128 --------------- 129 -- Interrupt -- 130 --------------- 131 132 overriding procedure Interrupt 133 (Descriptor : in out TTY_Process_Descriptor) 134 is 135 procedure Internal (Process : System.Address); 136 pragma Import (C, Internal, "__gnat_interrupt_process"); 137 begin 138 if Descriptor.Process /= System.Null_Address then 139 Internal (Descriptor.Process); 140 end if; 141 end Interrupt; 142 143 procedure Interrupt (Pid : Integer) is 144 procedure Internal (Pid : Integer); 145 pragma Import (C, Internal, "__gnat_interrupt_pid"); 146 begin 147 Internal (Pid); 148 end Interrupt; 149 150 ----------------------- 151 -- Terminate_Process -- 152 ----------------------- 153 154 procedure Terminate_Process (Pid : Integer) is 155 procedure Internal (Pid : Integer); 156 pragma Import (C, Internal, "__gnat_terminate_pid"); 157 begin 158 Internal (Pid); 159 end Terminate_Process; 160 161 ----------------------- 162 -- Pseudo_Descriptor -- 163 ----------------------- 164 165 procedure Pseudo_Descriptor 166 (Descriptor : out TTY_Process_Descriptor'Class; 167 TTY : GNAT.TTY.TTY_Handle; 168 Buffer_Size : Natural := 4096) is 169 begin 170 Descriptor.Input_Fd := GNAT.TTY.TTY_Descriptor (TTY); 171 Descriptor.Output_Fd := Descriptor.Input_Fd; 172 173 -- Create the buffer 174 175 Descriptor.Buffer_Size := Buffer_Size; 176 177 if Buffer_Size /= 0 then 178 Descriptor.Buffer := new String (1 .. Positive (Buffer_Size)); 179 end if; 180 end Pseudo_Descriptor; 181 182 ---------- 183 -- Send -- 184 ---------- 185 186 overriding procedure Send 187 (Descriptor : in out TTY_Process_Descriptor; 188 Str : String; 189 Add_LF : Boolean := True; 190 Empty_Buffer : Boolean := False) 191 is 192 Header : String (1 .. 5); 193 Length : Natural; 194 Ret : Natural; 195 196 procedure Internal 197 (Process : System.Address; 198 S : in out String; 199 Length : Natural; 200 Ret : out Natural); 201 pragma Import (C, Internal, "__gnat_send_header"); 202 203 begin 204 Length := Str'Length; 205 206 if Add_LF then 207 Length := Length + 1; 208 end if; 209 210 Internal (Descriptor.Process, Header, Length, Ret); 211 212 if Ret = 1 then 213 214 -- Need to use the header 215 216 GNAT.Expect.Send 217 (Process_Descriptor (Descriptor), 218 Header & Str, Add_LF, Empty_Buffer); 219 220 else 221 GNAT.Expect.Send 222 (Process_Descriptor (Descriptor), 223 Str, Add_LF, Empty_Buffer); 224 end if; 225 end Send; 226 227 -------------- 228 -- Set_Size -- 229 -------------- 230 231 procedure Set_Size 232 (Descriptor : in out TTY_Process_Descriptor'Class; 233 Rows : Natural; 234 Columns : Natural) 235 is 236 procedure Internal (Process : System.Address; R, C : Integer); 237 pragma Import (C, Internal, "__gnat_setup_winsize"); 238 begin 239 if Descriptor.Process /= System.Null_Address then 240 Internal (Descriptor.Process, Rows, Columns); 241 end if; 242 end Set_Size; 243 244 --------------------------- 245 -- Set_Up_Communications -- 246 --------------------------- 247 248 overriding procedure Set_Up_Communications 249 (Pid : in out TTY_Process_Descriptor; 250 Err_To_Out : Boolean; 251 Pipe1 : access Pipe_Type; 252 Pipe2 : access Pipe_Type; 253 Pipe3 : access Pipe_Type) 254 is 255 pragma Unreferenced (Err_To_Out, Pipe1, Pipe2, Pipe3); 256 257 function Internal (Process : System.Address) return Integer; 258 pragma Import (C, Internal, "__gnat_setup_communication"); 259 260 begin 261 if Internal (Pid.Process'Address) /= 0 then 262 raise Invalid_Process with "cannot setup communication."; 263 end if; 264 end Set_Up_Communications; 265 266 --------------------------------- 267 -- Set_Up_Child_Communications -- 268 --------------------------------- 269 270 overriding procedure Set_Up_Child_Communications 271 (Pid : in out TTY_Process_Descriptor; 272 Pipe1 : in out Pipe_Type; 273 Pipe2 : in out Pipe_Type; 274 Pipe3 : in out Pipe_Type; 275 Cmd : String; 276 Args : System.Address) 277 is 278 pragma Unreferenced (Pipe1, Pipe2, Pipe3, Cmd); 279 function Internal 280 (Process : System.Address; Argv : System.Address; Use_Pipes : Integer) 281 return Process_Id; 282 pragma Import (C, Internal, "__gnat_setup_child_communication"); 283 284 begin 285 Pid.Pid := Internal (Pid.Process, Args, Boolean'Pos (Pid.Use_Pipes)); 286 end Set_Up_Child_Communications; 287 288 ---------------------------------- 289 -- Set_Up_Parent_Communications -- 290 ---------------------------------- 291 292 overriding procedure Set_Up_Parent_Communications 293 (Pid : in out TTY_Process_Descriptor; 294 Pipe1 : in out Pipe_Type; 295 Pipe2 : in out Pipe_Type; 296 Pipe3 : in out Pipe_Type) 297 is 298 pragma Unreferenced (Pipe1, Pipe2, Pipe3); 299 300 procedure Internal 301 (Process : System.Address; 302 Inputfp : out File_Descriptor; 303 Outputfp : out File_Descriptor; 304 Errorfp : out File_Descriptor; 305 Pid : out Process_Id); 306 pragma Import (C, Internal, "__gnat_setup_parent_communication"); 307 308 begin 309 Internal 310 (Pid.Process, Pid.Input_Fd, Pid.Output_Fd, Pid.Error_Fd, Pid.Pid); 311 end Set_Up_Parent_Communications; 312 313 ------------------- 314 -- Set_Use_Pipes -- 315 ------------------- 316 317 procedure Set_Use_Pipes 318 (Descriptor : in out TTY_Process_Descriptor; 319 Use_Pipes : Boolean) is 320 begin 321 Descriptor.Use_Pipes := Use_Pipes; 322 end Set_Use_Pipes; 323 324end GNAT.Expect.TTY; 325