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