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-2014, 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 -- Pseudo_Descriptor -- 152 ----------------------- 153 154 procedure Pseudo_Descriptor 155 (Descriptor : out TTY_Process_Descriptor'Class; 156 TTY : GNAT.TTY.TTY_Handle; 157 Buffer_Size : Natural := 4096) is 158 begin 159 Descriptor.Input_Fd := GNAT.TTY.TTY_Descriptor (TTY); 160 Descriptor.Output_Fd := Descriptor.Input_Fd; 161 162 -- Create the buffer 163 164 Descriptor.Buffer_Size := Buffer_Size; 165 166 if Buffer_Size /= 0 then 167 Descriptor.Buffer := new String (1 .. Positive (Buffer_Size)); 168 end if; 169 end Pseudo_Descriptor; 170 171 ---------- 172 -- Send -- 173 ---------- 174 175 overriding procedure Send 176 (Descriptor : in out TTY_Process_Descriptor; 177 Str : String; 178 Add_LF : Boolean := True; 179 Empty_Buffer : Boolean := False) 180 is 181 Header : String (1 .. 5); 182 Length : Natural; 183 Ret : Natural; 184 185 procedure Internal 186 (Process : System.Address; 187 S : in out String; 188 Length : Natural; 189 Ret : out Natural); 190 pragma Import (C, Internal, "__gnat_send_header"); 191 192 begin 193 Length := Str'Length; 194 195 if Add_LF then 196 Length := Length + 1; 197 end if; 198 199 Internal (Descriptor.Process, Header, Length, Ret); 200 201 if Ret = 1 then 202 203 -- Need to use the header 204 205 GNAT.Expect.Send 206 (Process_Descriptor (Descriptor), 207 Header & Str, Add_LF, Empty_Buffer); 208 209 else 210 GNAT.Expect.Send 211 (Process_Descriptor (Descriptor), 212 Str, Add_LF, Empty_Buffer); 213 end if; 214 end Send; 215 216 -------------- 217 -- Set_Size -- 218 -------------- 219 220 procedure Set_Size 221 (Descriptor : in out TTY_Process_Descriptor'Class; 222 Rows : Natural; 223 Columns : Natural) 224 is 225 procedure Internal (Process : System.Address; R, C : Integer); 226 pragma Import (C, Internal, "__gnat_setup_winsize"); 227 begin 228 if Descriptor.Process /= System.Null_Address then 229 Internal (Descriptor.Process, Rows, Columns); 230 end if; 231 end Set_Size; 232 233 --------------------------- 234 -- Set_Up_Communications -- 235 --------------------------- 236 237 overriding procedure Set_Up_Communications 238 (Pid : in out TTY_Process_Descriptor; 239 Err_To_Out : Boolean; 240 Pipe1 : access Pipe_Type; 241 Pipe2 : access Pipe_Type; 242 Pipe3 : access Pipe_Type) 243 is 244 pragma Unreferenced (Err_To_Out, Pipe1, Pipe2, Pipe3); 245 246 function Internal (Process : System.Address) return Integer; 247 pragma Import (C, Internal, "__gnat_setup_communication"); 248 249 begin 250 if Internal (Pid.Process'Address) /= 0 then 251 raise Invalid_Process with "cannot setup communication."; 252 end if; 253 end Set_Up_Communications; 254 255 --------------------------------- 256 -- Set_Up_Child_Communications -- 257 --------------------------------- 258 259 overriding procedure Set_Up_Child_Communications 260 (Pid : in out TTY_Process_Descriptor; 261 Pipe1 : in out Pipe_Type; 262 Pipe2 : in out Pipe_Type; 263 Pipe3 : in out Pipe_Type; 264 Cmd : String; 265 Args : System.Address) 266 is 267 pragma Unreferenced (Pipe1, Pipe2, Pipe3, Cmd); 268 function Internal 269 (Process : System.Address; Argv : System.Address; Use_Pipes : Integer) 270 return Process_Id; 271 pragma Import (C, Internal, "__gnat_setup_child_communication"); 272 273 begin 274 Pid.Pid := Internal (Pid.Process, Args, Boolean'Pos (Pid.Use_Pipes)); 275 end Set_Up_Child_Communications; 276 277 ---------------------------------- 278 -- Set_Up_Parent_Communications -- 279 ---------------------------------- 280 281 overriding procedure Set_Up_Parent_Communications 282 (Pid : in out TTY_Process_Descriptor; 283 Pipe1 : in out Pipe_Type; 284 Pipe2 : in out Pipe_Type; 285 Pipe3 : in out Pipe_Type) 286 is 287 pragma Unreferenced (Pipe1, Pipe2, Pipe3); 288 289 procedure Internal 290 (Process : System.Address; 291 Inputfp : out File_Descriptor; 292 Outputfp : out File_Descriptor; 293 Errorfp : out File_Descriptor; 294 Pid : out Process_Id); 295 pragma Import (C, Internal, "__gnat_setup_parent_communication"); 296 297 begin 298 Internal 299 (Pid.Process, Pid.Input_Fd, Pid.Output_Fd, Pid.Error_Fd, Pid.Pid); 300 end Set_Up_Parent_Communications; 301 302 ------------------- 303 -- Set_Use_Pipes -- 304 ------------------- 305 306 procedure Set_Use_Pipes 307 (Descriptor : in out TTY_Process_Descriptor; 308 Use_Pipes : Boolean) is 309 begin 310 Descriptor.Use_Pipes := Use_Pipes; 311 end Set_Use_Pipes; 312 313end GNAT.Expect.TTY; 314