[Ada] Add a pseudo-terminal based expect unit
Arnaud Charlet
charlet@adacore.com
Wed Nov 23 11:26:00 GMT 2011
This is new package add support for pseudo-terminals on GNAT.Expect.
Tested on x86_64-pc-linux-gnu, committed on trunk
2011-11-23 Pascal Obry <obry@adacore.com>
* g-exptty.ads, g-exptty.adb, g-tty.ads, g-tty.adb,
terminals.c: New files.
Makefile.rtl: Add these new files.
* gnat_rm.texi: Add documentation for GNAT.Expect.TTY.
* gcc-interface/Makefile.in: Add g-exptty, g-tty, terminals.o
* gcc-interface/Make-lang.in: Update dependencies.
-------------- next part --------------
Index: gnat_rm.texi
===================================================================
--- gnat_rm.texi (revision 181654)
+++ gnat_rm.texi (working copy)
@@ -374,6 +374,7 @@
* GNAT.Exception_Traces (g-exctra.ads)::
* GNAT.Exceptions (g-except.ads)::
* GNAT.Expect (g-expect.ads)::
+* GNAT.Expect.TTY (g-exptty.ads)::
* GNAT.Float_Control (g-flocon.ads)::
* GNAT.Heap_Sort (g-heasor.ads)::
* GNAT.Heap_Sort_A (g-hesora.ads)::
@@ -14187,6 +14188,7 @@
* GNAT.Exception_Traces (g-exctra.ads)::
* GNAT.Exceptions (g-except.ads)::
* GNAT.Expect (g-expect.ads)::
+* GNAT.Expect.TTY (g-exptty.ads)::
* GNAT.Float_Control (g-flocon.ads)::
* GNAT.Heap_Sort (g-heasor.ads)::
* GNAT.Heap_Sort_A (g-hesora.ads)::
@@ -15054,6 +15056,16 @@
It is not implemented for cross ports, and in particular is not
implemented for VxWorks or LynxOS@.
+@node GNAT.Expect.TTY (g-exptty.ads)
+@section @code{GNAT.Expect.TTY} (@file{g-exptty.ads})
+@cindex @code{GNAT.Expect.TTY} (@file{g-exptty.ads})
+
+@noindent
+As GNAT.Expect but using pseudo-terminal.
+Currently @code{GNAT.Expect.TTY} is implemented on all native GNAT
+ports except for OpenVMS@. It is not implemented for cross ports, and
+in particular is not implemented for VxWorks or LynxOS@.
+
@node GNAT.Float_Control (g-flocon.ads)
@section @code{GNAT.Float_Control} (@file{g-flocon.ads})
@cindex @code{GNAT.Float_Control} (@file{g-flocon.ads})
Index: g-exptty.adb
===================================================================
--- g-exptty.adb (revision 0)
+++ g-exptty.adb (revision 0)
@@ -0,0 +1,309 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT LIBRARY COMPONENTS --
+-- --
+-- G N A T . E X P E C T . T T Y --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2000-2011, AdaCore --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+with GNAT.OS_Lib; use GNAT.OS_Lib;
+
+with System; use System;
+
+package body GNAT.Expect.TTY is
+
+ On_Windows : constant Boolean := Directory_Separator = '\';
+ -- True when on Windows
+
+ -----------
+ -- Close --
+ -----------
+
+ overriding procedure Close
+ (Descriptor : in out TTY_Process_Descriptor;
+ Status : out Integer)
+ is
+ procedure Terminate_Process (Process : System.Address);
+ pragma Import (C, Terminate_Process, "__gnat_terminate_process");
+
+ function Waitpid (Process : System.Address) return Integer;
+ pragma Import (C, Waitpid, "__gnat_waitpid");
+ -- Wait for a specific process id, and return its exit code
+
+ procedure Free_Process (Process : System.Address);
+ pragma Import (C, Free_Process, "__gnat_free_process");
+
+ procedure Close_TTY (Process : System.Address);
+ pragma Import (C, Close_TTY, "__gnat_close_tty");
+
+ begin
+ -- If we haven't already closed the process
+
+ if Descriptor.Process = System.Null_Address then
+ Status := -1;
+
+ else
+ if Descriptor.Input_Fd /= Invalid_FD then
+ Close (Descriptor.Input_Fd);
+ end if;
+
+ if Descriptor.Error_Fd /= Descriptor.Output_Fd
+ and then Descriptor.Error_Fd /= Invalid_FD
+ then
+ Close (Descriptor.Error_Fd);
+ end if;
+
+ if Descriptor.Output_Fd /= Invalid_FD then
+ Close (Descriptor.Output_Fd);
+ end if;
+
+ -- Send a Ctrl-C to the process first. This way, if the
+ -- launched process is a "sh" or "cmd", the child processes
+ -- will get terminated as well. Otherwise, terminating the
+ -- main process brutally will leave the children running.
+
+ Interrupt (Descriptor);
+ delay 0.05;
+
+ Terminate_Process (Descriptor.Process);
+ Status := Waitpid (Descriptor.Process);
+
+ if not On_Windows then
+ Close_TTY (Descriptor.Process);
+ end if;
+
+ Free_Process (Descriptor.Process'Address);
+ Descriptor.Process := System.Null_Address;
+
+ GNAT.OS_Lib.Free (Descriptor.Buffer);
+ Descriptor.Buffer_Size := 0;
+ end if;
+ end Close;
+
+ overriding procedure Close (Descriptor : in out TTY_Process_Descriptor) is
+ Status : Integer;
+ begin
+ Close (Descriptor, Status);
+ end Close;
+
+ -----------------------------
+ -- Close_Pseudo_Descriptor --
+ -----------------------------
+
+ procedure Close_Pseudo_Descriptor
+ (Descriptor : in out TTY_Process_Descriptor)
+ is
+ begin
+ Descriptor.Buffer_Size := 0;
+ GNAT.OS_Lib.Free (Descriptor.Buffer);
+ end Close_Pseudo_Descriptor;
+
+ ---------------
+ -- Interrupt --
+ ---------------
+
+ overriding procedure Interrupt
+ (Descriptor : in out TTY_Process_Descriptor)
+ is
+ procedure Internal (Process : System.Address);
+ pragma Import (C, Internal, "__gnat_interrupt_process");
+ begin
+ if Descriptor.Process /= System.Null_Address then
+ Internal (Descriptor.Process);
+ end if;
+ end Interrupt;
+
+ procedure Interrupt (Pid : Integer) is
+ procedure Internal (Pid : Integer);
+ pragma Import (C, Internal, "__gnat_interrupt_pid");
+ begin
+ Internal (Pid);
+ end Interrupt;
+
+ -----------------------
+ -- Pseudo_Descriptor --
+ -----------------------
+
+ procedure Pseudo_Descriptor
+ (Descriptor : out TTY_Process_Descriptor'Class;
+ TTY : GNAT.TTY.TTY_Handle;
+ Buffer_Size : Natural := 4096) is
+ begin
+ Descriptor.Input_Fd := GNAT.TTY.TTY_Descriptor (TTY);
+ Descriptor.Output_Fd := Descriptor.Input_Fd;
+
+ -- Create the buffer
+
+ Descriptor.Buffer_Size := Buffer_Size;
+
+ if Buffer_Size /= 0 then
+ Descriptor.Buffer := new String (1 .. Positive (Buffer_Size));
+ end if;
+ end Pseudo_Descriptor;
+
+ ----------
+ -- Send --
+ ----------
+
+ overriding procedure Send
+ (Descriptor : in out TTY_Process_Descriptor;
+ Str : String;
+ Add_LF : Boolean := True;
+ Empty_Buffer : Boolean := False)
+ is
+ Header : String (1 .. 5);
+ Length : Natural;
+ Ret : Natural;
+
+ procedure Internal
+ (Process : System.Address;
+ S : in out String;
+ Length : Natural;
+ Ret : out Natural);
+ pragma Import (C, Internal, "__gnat_send_header");
+
+ begin
+ Length := Str'Length;
+
+ if Add_LF then
+ Length := Length + 1;
+ end if;
+
+ Internal (Descriptor.Process, Header, Length, Ret);
+
+ if Ret = 1 then
+
+ -- Need to use the header
+
+ GNAT.Expect.Send
+ (Process_Descriptor (Descriptor),
+ Header & Str, Add_LF, Empty_Buffer);
+
+ else
+ GNAT.Expect.Send
+ (Process_Descriptor (Descriptor),
+ Str, Add_LF, Empty_Buffer);
+ end if;
+ end Send;
+
+ --------------
+ -- Set_Size --
+ --------------
+
+ procedure Set_Size
+ (Descriptor : in out TTY_Process_Descriptor'Class;
+ Rows : Natural;
+ Columns : Natural)
+ is
+ procedure Internal (Process : System.Address; R, C : Integer);
+ pragma Import (C, Internal, "__gnat_setup_winsize");
+ begin
+ if Descriptor.Process /= System.Null_Address then
+ Internal (Descriptor.Process, Rows, Columns);
+ end if;
+ end Set_Size;
+
+ ---------------------------
+ -- Set_Up_Communications --
+ ---------------------------
+
+ overriding procedure Set_Up_Communications
+ (Pid : in out TTY_Process_Descriptor;
+ Err_To_Out : Boolean;
+ Pipe1 : access Pipe_Type;
+ Pipe2 : access Pipe_Type;
+ Pipe3 : access Pipe_Type)
+ is
+ pragma Unreferenced (Err_To_Out, Pipe1, Pipe2, Pipe3);
+
+ function Internal (Process : System.Address) return Integer;
+ pragma Import (C, Internal, "__gnat_setup_communication");
+
+ begin
+ if Internal (Pid.Process'Address) /= 0 then
+ raise Invalid_Process with "cannot setup communication.";
+ end if;
+ end Set_Up_Communications;
+
+ ---------------------------------
+ -- Set_Up_Child_Communications --
+ ---------------------------------
+
+ overriding procedure Set_Up_Child_Communications
+ (Pid : in out TTY_Process_Descriptor;
+ Pipe1 : in out Pipe_Type;
+ Pipe2 : in out Pipe_Type;
+ Pipe3 : in out Pipe_Type;
+ Cmd : String;
+ Args : System.Address)
+ is
+ pragma Unreferenced (Pipe1, Pipe2, Pipe3, Cmd);
+ function Internal
+ (Process : System.Address; Argv : System.Address; Use_Pipes : Integer)
+ return Process_Id;
+ pragma Import (C, Internal, "__gnat_setup_child_communication");
+
+ begin
+ Pid.Pid := Internal (Pid.Process, Args, Boolean'Pos (Pid.Use_Pipes));
+ end Set_Up_Child_Communications;
+
+ ----------------------------------
+ -- Set_Up_Parent_Communications --
+ ----------------------------------
+
+ overriding procedure Set_Up_Parent_Communications
+ (Pid : in out TTY_Process_Descriptor;
+ Pipe1 : in out Pipe_Type;
+ Pipe2 : in out Pipe_Type;
+ Pipe3 : in out Pipe_Type)
+ is
+ pragma Unreferenced (Pipe1, Pipe2, Pipe3);
+
+ procedure Internal
+ (Process : System.Address;
+ Inputfp : out File_Descriptor;
+ Outputfp : out File_Descriptor;
+ Errorfp : out File_Descriptor;
+ Pid : out Process_Id);
+ pragma Import (C, Internal, "__gnat_setup_parent_communication");
+
+ begin
+ Internal
+ (Pid.Process, Pid.Input_Fd, Pid.Output_Fd, Pid.Error_Fd, Pid.Pid);
+ end Set_Up_Parent_Communications;
+
+ -------------------
+ -- Set_Use_Pipes --
+ -------------------
+
+ procedure Set_Use_Pipes
+ (Descriptor : in out TTY_Process_Descriptor;
+ Use_Pipes : Boolean) is
+ begin
+ Descriptor.Use_Pipes := Use_Pipes;
+ end Set_Use_Pipes;
+
+end GNAT.Expect.TTY;
Index: g-exptty.ads
===================================================================
--- g-exptty.ads (revision 0)
+++ g-exptty.ads (revision 0)
@@ -0,0 +1,128 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT LIBRARY COMPONENTS --
+-- --
+-- G N A T . E X P E C T . T T Y --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2000-2011, AdaCore --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+with GNAT.TTY;
+
+with System;
+
+package GNAT.Expect.TTY is
+
+ ------------------
+ -- TTY_Process --
+ ------------------
+
+ type TTY_Process_Descriptor is new Process_Descriptor with private;
+ -- Similar to Process_Descriptor, with the parent set up as a full terminal
+ -- (Unix sense, see tty(4)).
+
+ procedure Pseudo_Descriptor
+ (Descriptor : out TTY_Process_Descriptor'Class;
+ TTY : GNAT.TTY.TTY_Handle;
+ Buffer_Size : Natural := 4096);
+ -- Given a terminal descriptor (TTY), create a pseudo process descriptor
+ -- to be used with GNAT.Expect.
+ --
+ -- Note that it is invalid to call Close, Interrupt, Send_Signal on the
+ -- resulting descriptor. To deallocate memory associated with Process,
+ -- call Close_Pseudo_Descriptor instead.
+
+ procedure Close_Pseudo_Descriptor
+ (Descriptor : in out TTY_Process_Descriptor);
+ -- Free memory and ressources associated with Descriptor. Will *not*
+ -- close the associated TTY, it is the caller's responsibility to call
+ -- GNAT.TTY.Close_TTY.
+
+ procedure Interrupt (Pid : Integer);
+ -- Interrupt a process given its pid
+
+ overriding procedure Send
+ (Descriptor : in out TTY_Process_Descriptor;
+ Str : String;
+ Add_LF : Boolean := True;
+ Empty_Buffer : Boolean := False);
+ -- See parent
+ -- What does that comment mean??? what is "parent" here
+
+ procedure Set_Use_Pipes
+ (Descriptor : in out TTY_Process_Descriptor;
+ Use_Pipes : Boolean);
+ -- Tell Expect.TTY whether to use Pipes or Console (on windows). Needs to
+ -- be set before spawning the process. Default is to use Pipes.
+
+ procedure Set_Size
+ (Descriptor : in out TTY_Process_Descriptor'Class;
+ Rows : Natural;
+ Columns : Natural);
+ -- Sets up the size of the terminal as reported to the spawned process
+
+private
+
+ -- All declarations in the private part must be fully commented ???
+
+ overriding procedure Close
+ (Descriptor : in out TTY_Process_Descriptor;
+ Status : out Integer);
+
+ overriding procedure Close
+ (Descriptor : in out TTY_Process_Descriptor);
+
+ overriding procedure Interrupt (Descriptor : in out TTY_Process_Descriptor);
+ -- When we use pseudo-terminals, we do not need to use signals to
+ -- interrupt the debugger, we can simply send the appropriate character.
+ -- This provides a better support for remote debugging for instance.
+
+ procedure Set_Up_Communications
+ (Pid : in out TTY_Process_Descriptor;
+ Err_To_Out : Boolean;
+ Pipe1 : access Pipe_Type;
+ Pipe2 : access Pipe_Type;
+ Pipe3 : access Pipe_Type);
+
+ procedure Set_Up_Parent_Communications
+ (Pid : in out TTY_Process_Descriptor;
+ Pipe1 : in out Pipe_Type;
+ Pipe2 : in out Pipe_Type;
+ Pipe3 : in out Pipe_Type);
+
+ procedure Set_Up_Child_Communications
+ (Pid : in out TTY_Process_Descriptor;
+ Pipe1 : in out Pipe_Type;
+ Pipe2 : in out Pipe_Type;
+ Pipe3 : in out Pipe_Type;
+ Cmd : String;
+ Args : System.Address);
+
+ type TTY_Process_Descriptor is new Process_Descriptor with record
+ Process : System.Address; -- Underlying structure used in C
+ Use_Pipes : Boolean := True;
+ end record;
+
+end GNAT.Expect.TTY;
Index: Makefile.rtl
===================================================================
--- Makefile.rtl (revision 181654)
+++ Makefile.rtl (working copy)
@@ -404,6 +404,7 @@
g-except$(objext) \
g-exctra$(objext) \
g-expect$(objext) \
+ g-exptty$(objext) \
g-flocon$(objext) \
g-heasor$(objext) \
g-hesora$(objext) \
@@ -450,6 +451,7 @@
g-timsta$(objext) \
g-traceb$(objext) \
g-trasym$(objext) \
+ g-tty$(objext) \
g-u3spch$(objext) \
g-utf_32$(objext) \
g-wispch$(objext) \
Index: terminals.c
===================================================================
--- terminals.c (revision 0)
+++ terminals.c (revision 0)
@@ -0,0 +1,1551 @@
+/****************************************************************************
+ * *
+ * GNAT RUN-TIME COMPONENTS *
+ * *
+ * T E R M I N A L S *
+ * *
+ * C Implementation File *
+ * *
+ * Copyright (C) 2008-2011, AdaCore *
+ * *
+ * GNAT is free software; you can redistribute it and/or modify it under *
+ * terms of the GNU General Public License as published by the Free Soft- *
+ * ware Foundation; either version 3, or (at your option) any later ver- *
+ * sion. GNAT is distributed in the hope that it will be useful, but WITH- *
+ * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY *
+ * or FITNESS FOR A PARTICULAR PURPOSE. *
+ * *
+ * As a special exception under Section 7 of GPL version 3, you are granted *
+ * additional permissions described in the GCC Runtime Library Exception, *
+ * version 3.1, as published by the Free Software Foundation. *
+ * *
+ * You should have received a copy of the GNU General Public License and *
+ * a copy of the GCC Runtime Library Exception along with this program; *
+ * see the files COPYING3 and COPYING.RUNTIME respectively. If not, see *
+ * <http://www.gnu.org/licenses/>. *
+ * *
+ * GNAT was originally developed by the GNAT team at New York University. *
+ * Extensive contributions were provided by Ada Core Technologies Inc. *
+ * *
+ ****************************************************************************/
+
+/* First all usupported platforms. Add stubs for exported routines. */
+
+#if defined (VMS) || defined (__vxworks) || defined (__Lynx__)
+
+void * __gnat_new_tty (void) { return (void*)0; }
+char * __gnat_tty_name (void* t) { return (char*)0; }
+int __gnat_interrupt_pid (int pid) { return -1; }
+int __gnat_interrupt_process (void* desc) { return -1; }
+int __gnat_setup_communication (void** desc) { return -1; }
+void __gnat_setup_parent_communication
+ (void* d, int* i, int* o, int*e, int*p) { return -1; }
+int __gnat_setup_child_communication
+ (void* d, char **n, int u) { return -1; }
+int __gnat_terminate_process (void *desc) { return -1; }
+int __gnat_tty_fd (void* t) { return -1; }
+int __gnat_tty_supported (void) { return 0; }
+int __gnat_tty_waitpid (void *desc) { return 1; }
+void __gnat_close_tty (void* t) {}
+void __gnat_free_process (void** process) {}
+void __gnat_reset_tty (void* t) {}
+void __gnat_send_header (void* d, char h[5], int s, int *r) {}
+void __gnat_setup_winsize (void *desc, int rows, int columns) {}
+
+/* For Windows platforms. */
+
+#elif defined(_WIN32)
+
+#include <errno.h>
+#include <stdio.h>
+#include <stdlib.h>
+
+#include <windows.h>
+
+#define MAXPATHLEN 1024
+
+#define NILP(x) ((x) == 0)
+#define Qnil 0
+#define report_file_error(x, y) fprintf (stderr, "Error: %s\n", x);
+#define INTEGERP(x) 1
+#define XINT(x) x
+
+struct TTY_Process {
+ int pid; /* Number of this process */
+ PROCESS_INFORMATION procinfo;
+ HANDLE w_infd, w_outfd;
+ HANDLE w_forkin, w_forkout;
+ BOOL usePipe;
+};
+
+/* Control whether create_child cause the process to inherit GPS'
+ error mode setting. The default is 1, to minimize the possibility of
+ subprocesses blocking when accessing unmounted drives. */
+static int Vw32_start_process_inherit_error_mode = 1;
+
+/* Control whether spawnve quotes arguments as necessary to ensure
+ correct parsing by child process. Because not all uses of spawnve
+ are careful about constructing argv arrays, we make this behaviour
+ conditional (off by default, since a similar operation is already done
+ in g-expect.adb by calling Normalize_Argument). */
+static int Vw32_quote_process_args = 0;
+
+static DWORD AbsoluteSeek(HANDLE, DWORD);
+static VOID ReadBytes(HANDLE, LPVOID, DWORD);
+
+#define XFER_BUFFER_SIZE 2048
+
+/* This tell if the executable we're about to launch uses a GUI interface. */
+/* if we can't determine it, we will return true */
+static int
+is_gui_app (char *exe)
+{
+ HANDLE hImage;
+
+ DWORD bytes;
+ DWORD iSection;
+ DWORD SectionOffset;
+ DWORD CoffHeaderOffset;
+ DWORD MoreDosHeader[16];
+ CHAR *file;
+ size_t nlen;
+
+ ULONG ntSignature;
+
+ IMAGE_DOS_HEADER image_dos_header;
+ IMAGE_FILE_HEADER image_file_header;
+ IMAGE_OPTIONAL_HEADER image_optional_header;
+ IMAGE_SECTION_HEADER image_section_header;
+
+ /*
+ * Open the reference file.
+ */
+ nlen = strlen (exe);
+ file = exe;
+ if (nlen > 2) {
+ if (exe[0] == '"') {
+ /* remove quotes */
+ nlen -= 2;
+ file = malloc ((nlen + 1) * sizeof (char));
+ memcpy (file, &exe[1], nlen);
+ file [nlen] = '\0';
+ }
+ }
+ hImage = CreateFile(file,
+ GENERIC_READ,
+ FILE_SHARE_READ,
+ NULL,
+ OPEN_EXISTING,
+ FILE_ATTRIBUTE_NORMAL,
+ NULL);
+
+ if (file != exe) {
+ free (file);
+ }
+
+ if (INVALID_HANDLE_VALUE == hImage)
+ {
+ report_file_error ("Could not open exe: ", Qnil);
+ report_file_error (exe, Qnil);
+ report_file_error ("\n", Qnil);
+ CloseHandle (hImage);
+ return -1;
+ }
+
+ /*
+ * Read the MS-DOS image header.
+ */
+ ReadBytes(hImage, &image_dos_header, sizeof(IMAGE_DOS_HEADER));
+
+ if (IMAGE_DOS_SIGNATURE != image_dos_header.e_magic)
+ {
+ report_file_error("Sorry, I do not understand this file.\n", Qnil);
+ CloseHandle (hImage);
+ return -1;
+ }
+
+ /*
+ * Read more MS-DOS header. */
+ ReadBytes(hImage, MoreDosHeader, sizeof(MoreDosHeader));
+ /*
+ * Get actual COFF header.
+ */
+ CoffHeaderOffset = AbsoluteSeek(hImage, image_dos_header.e_lfanew) +
+ sizeof(ULONG);
+ if (CoffHeaderOffset < 0) {
+ CloseHandle (hImage);
+ return -1;
+ }
+
+ ReadBytes (hImage, &ntSignature, sizeof(ULONG));
+
+ if (IMAGE_NT_SIGNATURE != ntSignature)
+ {
+ report_file_error ("Missing NT signature. Unknown file type.\n", Qnil);
+ CloseHandle (hImage);
+ return -1;
+ }
+
+ SectionOffset = CoffHeaderOffset + IMAGE_SIZEOF_FILE_HEADER +
+ IMAGE_SIZEOF_NT_OPTIONAL_HEADER;
+
+ ReadBytes(hImage, &image_file_header, IMAGE_SIZEOF_FILE_HEADER);
+
+ /*
+ * Read optional header.
+ */
+ ReadBytes(hImage,
+ &image_optional_header,
+ IMAGE_SIZEOF_NT_OPTIONAL_HEADER);
+
+ CloseHandle (hImage);
+
+ switch (image_optional_header.Subsystem)
+ {
+ case IMAGE_SUBSYSTEM_UNKNOWN:
+ return 1;
+ break;
+
+ case IMAGE_SUBSYSTEM_NATIVE:
+ return 1;
+ break;
+
+ case IMAGE_SUBSYSTEM_WINDOWS_GUI:
+ return 1;
+ break;
+
+ case IMAGE_SUBSYSTEM_WINDOWS_CUI:
+ return 0;
+ break;
+
+ case IMAGE_SUBSYSTEM_OS2_CUI:
+ return 0;
+ break;
+
+ case IMAGE_SUBSYSTEM_POSIX_CUI:
+ return 0;
+ break;
+
+ default:
+ /* Unknown, return GUI app to be preservative: if yes, it will be
+ correctly launched, if no, it will be launched, and a console will
+ be also displayed, which is not a big deal */
+ return 1;
+ break;
+ }
+
+}
+
+static DWORD
+AbsoluteSeek (HANDLE hFile, DWORD offset)
+{
+ DWORD newOffset;
+
+ newOffset = SetFilePointer (hFile, offset, NULL, FILE_BEGIN);
+
+ if (newOffset == 0xFFFFFFFF)
+ return -1;
+ else
+ return newOffset;
+}
+
+static VOID
+ReadBytes (HANDLE hFile, LPVOID buffer, DWORD size)
+{
+ DWORD bytes;
+
+ if (!ReadFile(hFile, buffer, size, &bytes, NULL))
+ {
+ size = 0;
+ return;
+ }
+ else if (size != bytes)
+ {
+ return;
+ }
+}
+
+static int
+nt_spawnve (char *exe, char **argv, char *env, struct TTY_Process *process)
+{
+ STARTUPINFO start;
+ SECURITY_ATTRIBUTES sec_attrs;
+ SECURITY_DESCRIPTOR sec_desc;
+ DWORD flags;
+ char dir[ MAXPATHLEN ];
+ int pid;
+ int is_gui, use_cmd;
+ char *cmdline, *parg, **targ;
+ int do_quoting = 0;
+ char escape_char;
+ int arglen;
+
+ /* we have to do some conjuring here to put argv and envp into the
+ form CreateProcess wants... argv needs to be a space separated/null
+ terminated list of parameters, and envp is a null
+ separated/double-null terminated list of parameters.
+
+ Additionally, zero-length args and args containing whitespace or
+ quote chars need to be wrapped in double quotes - for this to work,
+ embedded quotes need to be escaped as well. The aim is to ensure
+ the child process reconstructs the argv array we start with
+ exactly, so we treat quotes at the beginning and end of arguments
+ as embedded quotes.
+
+ Note that using backslash to escape embedded quotes requires
+ additional special handling if an embedded quote is already
+ preceeded by backslash, or if an arg requiring quoting ends with
+ backslash. In such cases, the run of escape characters needs to be
+ doubled. For consistency, we apply this special handling as long
+ as the escape character is not quote.
+
+ Since we have no idea how large argv and envp are likely to be we
+ figure out list lengths on the fly and allocate them. */
+
+ if (!NILP (Vw32_quote_process_args))
+ {
+ do_quoting = 1;
+ /* Override escape char by binding w32-quote-process-args to
+ desired character, or use t for auto-selection. */
+ if (INTEGERP (Vw32_quote_process_args))
+ escape_char = XINT (Vw32_quote_process_args);
+ else
+ escape_char = '\\';
+ }
+
+ /* do argv... */
+ arglen = 0;
+ targ = argv;
+ while (*targ)
+ {
+ char *p = *targ;
+ int need_quotes = 0;
+ int escape_char_run = 0;
+
+ if (*p == 0)
+ need_quotes = 1;
+ for ( ; *p; p++)
+ {
+ if (*p == '"')
+ {
+ /* allow for embedded quotes to be escaped */
+ arglen++;
+ need_quotes = 1;
+ /* handle the case where the embedded quote is already escaped */
+ if (escape_char_run > 0)
+ {
+ /* To preserve the arg exactly, we need to double the
+ preceding escape characters (plus adding one to
+ escape the quote character itself). */
+ arglen += escape_char_run;
+ }
+ }
+ else if (*p == ' ' || *p == '\t')
+ {
+ need_quotes = 1;
+ }
+
+ if (*p == escape_char && escape_char != '"')
+ escape_char_run++;
+ else
+ escape_char_run = 0;
+ }
+ if (need_quotes)
+ {
+ arglen += 2;
+ /* handle the case where the arg ends with an escape char - we
+ must not let the enclosing quote be escaped. */
+ if (escape_char_run > 0)
+ arglen += escape_char_run;
+ }
+ arglen += strlen (*targ) + 1;
+ targ++;
+ }
+
+ is_gui = is_gui_app (argv[0]);
+ use_cmd = FALSE;
+
+ if (is_gui == -1) {
+ /* could not determine application type. Try launching with "cmd /c" */
+ is_gui = FALSE;
+ arglen += 7;
+ use_cmd = TRUE;
+ }
+
+ cmdline = (char*)malloc (arglen + 1);
+ targ = argv;
+ parg = cmdline;
+
+ if (use_cmd == TRUE) {
+ strcpy (parg, "cmd /c ");
+ parg += 7;
+ }
+
+ while (*targ)
+ {
+ char * p = *targ;
+ int need_quotes = 0;
+
+ if (*p == 0)
+ need_quotes = 1;
+
+ if (do_quoting)
+ {
+ for ( ; *p; p++)
+ if (*p == ' ' || *p == '\t' || *p == '"')
+ need_quotes = 1;
+ }
+ if (need_quotes)
+ {
+ int escape_char_run = 0;
+ char * first;
+ char * last;
+
+ p = *targ;
+ first = p;
+ last = p + strlen (p) - 1;
+ *parg++ = '"';
+ for ( ; *p; p++)
+ {
+ if (*p == '"')
+ {
+ /* double preceding escape chars if any */
+ while (escape_char_run > 0)
+ {
+ *parg++ = escape_char;
+ escape_char_run--;
+ }
+ /* escape all quote chars, even at beginning or end */
+ *parg++ = escape_char;
+ }
+ *parg++ = *p;
+
+ if (*p == escape_char && escape_char != '"')
+ escape_char_run++;
+ else
+ escape_char_run = 0;
+ }
+ /* double escape chars before enclosing quote */
+ while (escape_char_run > 0)
+ {
+ *parg++ = escape_char;
+ escape_char_run--;
+ }
+ *parg++ = '"';
+ }
+ else
+ {
+ strcpy (parg, *targ);
+ parg += strlen (*targ);
+ }
+ *parg++ = ' ';
+ targ++;
+ }
+ *--parg = '\0';
+
+ memset (&start, 0, sizeof (start));
+ start.cb = sizeof (start);
+
+ if (process->usePipe == TRUE) {
+ start.dwFlags = STARTF_USESTDHANDLES;
+ start.hStdInput = process->w_forkin;
+ start.hStdOutput = process->w_forkout;
+ /* child's stderr is always redirected to outfd */
+ start.hStdError = process->w_forkout;
+ } else {
+ start.dwFlags = STARTF_USESTDHANDLES;
+ /* We only need to redirect stderr/stdout here. Stdin will be forced to
+ the spawned process console by explaunch */
+ start.hStdInput = NULL;
+ start.hStdOutput = process->w_forkout;
+ start.hStdError = process->w_forkout;
+ }
+
+ /* Explicitly specify no security */
+ if (!InitializeSecurityDescriptor (&sec_desc, SECURITY_DESCRIPTOR_REVISION))
+ goto EH_Fail;
+ if (!SetSecurityDescriptorDacl (&sec_desc, TRUE, NULL, FALSE))
+ goto EH_Fail;
+ sec_attrs.nLength = sizeof (sec_attrs);
+ sec_attrs.lpSecurityDescriptor = &sec_desc;
+ sec_attrs.bInheritHandle = FALSE;
+
+ /* creating a new console allow easier close. Do not use
+ CREATE_NEW_PROCESS_GROUP as this results in disabling Ctrl+C */
+ flags = CREATE_NEW_CONSOLE;
+ if (NILP (Vw32_start_process_inherit_error_mode))
+ flags |= CREATE_DEFAULT_ERROR_MODE;
+
+ /* if app is not a gui application, hide the console */
+ if (is_gui == FALSE) {
+ start.dwFlags |= STARTF_USESHOWWINDOW;
+ start.wShowWindow = SW_HIDE;
+ }
+
+ /* Set initial directory to null character to use current directory */
+ if (!CreateProcess (NULL, cmdline, &sec_attrs, NULL, TRUE,
+ flags, env, NULL, &start, &process->procinfo))
+ goto EH_Fail;
+
+ pid = (int) process->procinfo.hProcess;
+ process->pid=pid;
+
+ return pid;
+
+ EH_Fail:
+ return -1;
+}
+
+/*************************
+ ** __gnat_send_header ()
+ *************************/
+
+#define EXP_SLAVE_CREATE 'c'
+#define EXP_SLAVE_KEY 'k'
+#define EXP_SLAVE_MOUSE 'm'
+#define EXP_SLAVE_WRITE 'w'
+#define EXP_SLAVE_KILL 'x'
+
+#define EXP_KILL_TERMINATE 0x1
+#define EXP_KILL_CTRL_C 0x2
+#define EXP_KILL_CTRL_BREAK 0x4
+
+void
+__gnat_send_header (struct TTY_Process* p, char header[5], int size, int *ret)
+{
+ if (p->usePipe == FALSE) {
+ header[0] = EXP_SLAVE_WRITE;
+ header[1] = size & 0xff;
+ header[2] = (size & 0xff00) >> 8;
+ header[3] = (size & 0xff0000) >> 16;
+ header[4] = (size & 0xff000000) >> 24;
+ *ret = 1;
+ } else {
+ *ret = 0;
+ }
+}
+
+/**********************************
+ ** __gnat_setup_communication ()
+ **********************************/
+
+int
+__gnat_setup_communication (struct TTY_Process** process_out) /* output param */
+{
+ struct TTY_Process* process;
+
+ process = (struct TTY_Process*)malloc (sizeof (struct TTY_Process));
+ ZeroMemory (process, sizeof (struct TTY_Process));
+ *process_out = process;
+
+ return 0;
+}
+
+#define EXP_PIPE_BASENAME "\\\\.\\pipe\\ExpectPipe"
+
+int
+__gnat_setup_child_communication
+ (struct TTY_Process* process,
+ char** argv,
+ int Use_Pipes)
+{
+ int cpid;
+ HANDLE parent;
+ SECURITY_ATTRIBUTES sec_attrs;
+ char slavePath [MAX_PATH];
+ char **nargv;
+ int argc;
+ int i;
+ char pipeNameIn[100];
+ HANDLE hSlaveInDrv = NULL; /* Handle to communicate with slave driver */
+
+ parent = GetCurrentProcess ();
+
+ /* Set inheritance for the pipe handles */
+ sec_attrs.nLength = sizeof (SECURITY_ATTRIBUTES);
+ sec_attrs.bInheritHandle = TRUE;
+ sec_attrs.lpSecurityDescriptor = NULL;
+
+ if (Use_Pipes) {
+ /* Create in and out pipes */
+ if (!CreatePipe (&process->w_forkin, &process->w_infd, &sec_attrs, 0))
+ report_file_error ("Creation of child's IN handle", Qnil);
+ if (!CreatePipe (&process->w_outfd, &process->w_forkout, &sec_attrs, 0))
+ report_file_error ("Creation of child's OUT handle", Qnil);
+
+ /* Do not inherit the parent's side of the pipes */
+ SetHandleInformation (&process->w_infd, HANDLE_FLAG_INHERIT, 0);
+ SetHandleInformation (&process->w_outfd, HANDLE_FLAG_INHERIT, 0);
+
+ /* use native argv */
+ nargv = argv;
+ process->usePipe = TRUE;
+
+ } else {
+ static int pipeNameId = 0;
+
+ process->w_infd = NULL;
+
+ /* We create a named pipe for Input, as we handle input by sending special
+ commands to the explaunch process, that uses it to feed the actual input
+ of the process */
+ sprintf(pipeNameIn, "%sIn%08x_%08x", EXP_PIPE_BASENAME,
+ GetCurrentProcessId(), pipeNameId);
+ pipeNameId++;
+
+ hSlaveInDrv = CreateNamedPipe(pipeNameIn,
+ PIPE_ACCESS_OUTBOUND,
+ PIPE_TYPE_BYTE | PIPE_WAIT, 1, 8192, 8192,
+ 20000, NULL);
+ if (hSlaveInDrv == NULL) goto end;
+
+ if (!CreatePipe (&process->w_outfd, &process->w_forkout, &sec_attrs, 0))
+ report_file_error ("Creation of child's OUT handle", Qnil);
+
+ if (SearchPath (NULL, "explaunch.exe", NULL,
+ MAX_PATH, slavePath, NULL) == 0) goto end;
+
+ for (argc=0; argv[argc] != NULL; argc++) ;
+ nargv = (char **) malloc (sizeof (char*) * (argc + 3));
+ nargv[0] = slavePath;
+ nargv[1] = pipeNameIn;
+
+ for (i = 0; i <= argc; i++) nargv[i + 2] = argv[i];
+ process->usePipe = FALSE;
+ }
+
+ /* Spawn the child. */
+ cpid = nt_spawnve (nargv[0], nargv, NULL, process);
+
+ /* close the duplicated handles passed to the child */
+ CloseHandle (process->w_forkout);
+
+ if (process->usePipe == TRUE) {
+ CloseHandle (process->w_forkin);
+
+ } else {
+ UCHAR buf[8]; /* enough space for child status info */
+ DWORD count;
+ BOOL bRet;
+ DWORD dwRet;
+
+ /*
+ * Wait for connection with the slave driver
+ */
+ bRet = ConnectNamedPipe(hSlaveInDrv, NULL);
+ if (bRet == FALSE) {
+ dwRet = GetLastError();
+ if (dwRet == ERROR_PIPE_CONNECTED) {
+ ;
+ } else {
+ goto end;
+ }
+ }
+
+ process->w_infd = hSlaveInDrv;
+
+ /*
+ * wait for slave driver to initialize before allowing user to send to it
+ */
+ bRet = ReadFile(process->w_outfd, buf, 8, &count, NULL);
+ if (bRet == FALSE) {
+ cpid = -1;
+ }
+
+ dwRet = buf[0] | (buf[1] << 8) | (buf[2] << 16) | (buf[3] << 24);
+ if (dwRet != 0) {
+ cpid = -1;
+ }
+
+ cpid = buf[4] | (buf[5] << 8) | (buf[6] << 16) | (buf[7] << 24);
+ process->pid = cpid;
+ }
+
+ if (cpid == -1)
+ /* An error occurred while trying to spawn the process. */
+ report_file_error ("Spawning child process", Qnil);
+
+ return cpid;
+ end:
+ if (hSlaveInDrv != NULL)
+ CloseHandle (hSlaveInDrv);
+ return -1;
+}
+
+void
+__gnat_setup_parent_communication
+ (struct TTY_Process* process,
+ int* in,
+ int* out,
+ int* err,
+ int* pid)
+{
+ *in = _open_osfhandle ((long) process->w_infd, 0);
+ *out = _open_osfhandle ((long) process->w_outfd, 0);
+ /* child's stderr is always redirected to outfd */
+ *err = *out;
+ *pid = process->pid;
+}
+
+typedef struct _child_process
+{
+ HWND hwnd;
+ PROCESS_INFORMATION *procinfo;
+} child_process;
+
+/* The major and minor versions of NT. */
+static int w32_major_version;
+static int w32_minor_version;
+
+/* Distinguish between Windows NT and Windows 95. */
+static enum {OS_UNKNOWN, OS_WIN95, OS_NT} os_subtype = OS_UNKNOWN;
+
+/* Cache information describing the NT system for later use. */
+static void
+cache_system_info (void)
+{
+ union
+ {
+ struct info
+ {
+ char major;
+ char minor;
+ short platform;
+ } info;
+ DWORD data;
+ } version;
+
+ /* Cache the version of the operating system. */
+ version.data = GetVersion ();
+ w32_major_version = version.info.major;
+ w32_minor_version = version.info.minor;
+
+ if (version.info.platform & 0x8000)
+ os_subtype = OS_WIN95;
+ else
+ os_subtype = OS_NT;
+}
+
+static BOOL CALLBACK
+find_child_console (HWND hwnd, child_process * cp)
+{
+ DWORD thread_id;
+ DWORD process_id;
+
+ thread_id = GetWindowThreadProcessId (hwnd, &process_id);
+ if (process_id == cp->procinfo->dwProcessId)
+ {
+ char window_class[32];
+
+ GetClassName (hwnd, window_class, sizeof (window_class));
+ if (strcmp (window_class,
+ (os_subtype == OS_WIN95)
+ ? "tty"
+ : "ConsoleWindowClass") == 0)
+ {
+ cp->hwnd = hwnd;
+ return FALSE;
+ }
+ }
+ /* keep looking */
+ return TRUE;
+}
+
+int
+__gnat_interrupt_process (struct TTY_Process* p)
+{
+ char buf[2];
+ DWORD written;
+ BOOL bret;
+
+ if (p->usePipe == TRUE) {
+ bret = FALSE;
+ } else {
+ buf[0] = EXP_SLAVE_KILL;
+ buf[1] = EXP_KILL_CTRL_C;
+ bret = WriteFile (p->w_infd, buf, 2, &written, NULL);
+ }
+
+ if (bret == FALSE) {
+ return __gnat_interrupt_pid (p->procinfo.dwProcessId);
+ }
+ return 0;
+}
+
+int
+__gnat_interrupt_pid (int pid)
+{
+ volatile child_process cp;
+ int rc = 0;
+
+ cp.procinfo = (LPPROCESS_INFORMATION) malloc (sizeof (PROCESS_INFORMATION));
+ cp.procinfo->dwProcessId = pid;
+
+ if (os_subtype == OS_UNKNOWN)
+ cache_system_info ();
+
+ /* Try to locate console window for process. */
+ EnumWindows ((WNDENUMPROC) find_child_console, (LPARAM) &cp);
+
+ if (cp.hwnd)
+ {
+ BYTE control_scan_code = (BYTE) MapVirtualKey (VK_CONTROL, 0);
+ /* Retrieve Ctrl-C scancode */
+ BYTE vk_break_code = 'C';
+ BYTE break_scan_code = (BYTE) MapVirtualKey (vk_break_code, 0);
+ HWND foreground_window;
+
+ foreground_window = GetForegroundWindow ();
+ if (foreground_window)
+ {
+ /* NT 5.0, and apparently also Windows 98, will not allow
+ a Window to be set to foreground directly without the
+ user's involvement. The workaround is to attach
+ ourselves to the thread that owns the foreground
+ window, since that is the only thread that can set the
+ foreground window. */
+ DWORD foreground_thread, child_thread;
+
+ foreground_thread =
+ GetWindowThreadProcessId (foreground_window, NULL);
+ if (foreground_thread == GetCurrentThreadId ()
+ || !AttachThreadInput (GetCurrentThreadId (),
+ foreground_thread, TRUE))
+ foreground_thread = 0;
+
+ child_thread = GetWindowThreadProcessId (cp.hwnd, NULL);
+ if (child_thread == GetCurrentThreadId ()
+ || !AttachThreadInput (GetCurrentThreadId (),
+ child_thread, TRUE))
+ child_thread = 0;
+
+ /* Set the foreground window to the child. */
+ if (SetForegroundWindow (cp.hwnd))
+ {
+ /* Generate keystrokes as if user had typed Ctrl-Break or
+ Ctrl-C. */
+ keybd_event (VK_CONTROL, control_scan_code, 0, 0);
+ keybd_event (vk_break_code, break_scan_code,
+ (vk_break_code == 'C' ? 0 : KEYEVENTF_EXTENDEDKEY), 0);
+ keybd_event (vk_break_code, break_scan_code,
+ (vk_break_code == 'C' ? 0 : KEYEVENTF_EXTENDEDKEY)
+ | KEYEVENTF_KEYUP, 0);
+ keybd_event (VK_CONTROL, control_scan_code, KEYEVENTF_KEYUP, 0);
+
+ /* Sleep for a bit to give time for the main frame to respond
+ to focus change events. */
+ Sleep (100);
+
+ SetForegroundWindow (foreground_window);
+ }
+ /* Detach from the foreground and child threads now that
+ the foreground switching is over. */
+ if (foreground_thread)
+ AttachThreadInput (GetCurrentThreadId (), foreground_thread, FALSE);
+ if (child_thread)
+ AttachThreadInput (GetCurrentThreadId (), child_thread, FALSE);
+ }
+ }
+ /* Ctrl-Break is NT equivalent of SIGINT. */
+ else if (!GenerateConsoleCtrlEvent
+ (CTRL_BREAK_EVENT, cp.procinfo->dwProcessId))
+ {
+ errno = EINVAL;
+ rc = -1;
+ }
+
+ free (cp.procinfo);
+ return rc;
+}
+
+/* kill a process, as this implementation use CreateProcess on Win32 we need
+ to use Win32 TerminateProcess API */
+int
+__gnat_terminate_process (struct TTY_Process* p)
+{
+ char buf[2];
+ DWORD written;
+ BOOL bret;
+
+ if (p->usePipe == TRUE) {
+ bret = FALSE;
+ } else {
+ buf[0] = EXP_SLAVE_KILL;
+ buf[1] = EXP_KILL_TERMINATE;
+ bret = WriteFile (p->w_infd, buf, 2, &written, NULL);
+ }
+
+ if (bret == FALSE) {
+ if (!TerminateProcess (p->procinfo.hProcess, 1))
+ return -1;
+ else
+ return 0;
+ } else
+ return 0;
+}
+
+/* wait for process pid to terminate and return the process status. This
+ implementation is different from the adaint.c one for Windows as it uses
+ the Win32 API instead of the C one. */
+
+int
+__gnat_tty_waitpid (struct TTY_Process* p)
+{
+ DWORD exitcode;
+ DWORD res;
+ HANDLE proc_hand = p->procinfo.hProcess;
+
+ res = WaitForSingleObject (proc_hand, 0);
+ GetExitCodeProcess (proc_hand, &exitcode);
+
+ CloseHandle (p->procinfo.hThread);
+ CloseHandle (p->procinfo.hProcess);
+
+ /* No need to close the handles: they were closed on the ada side */
+
+ return (int) exitcode;
+}
+
+/********************************
+ ** __gnat_free_process ()
+ ********************************/
+
+void
+__gnat_free_process (struct TTY_Process** process)
+{
+ free (*process);
+ *process = NULL;
+}
+
+/* TTY handling */
+
+typedef struct {
+ int tty_fd; /* descriptor for the tty */
+ char tty_name[24]; /* Name of TTY device */
+} TTY_Handle;
+
+int
+__gnat_tty_supported (void)
+{
+ return 0;
+}
+
+/* Return the tty name associated with p */
+
+char *
+__gnat_tty_name (TTY_Handle* t)
+{
+ return t->tty_name;
+}
+
+int
+__gnat_tty_fd (TTY_Handle* t)
+{
+ return t->tty_fd;
+}
+
+TTY_Handle*
+__gnat_new_tty (void)
+{
+ return (TTY_Handle*)0;
+}
+
+void
+__gnat_reset_tty (TTY_Handle* t)
+{
+ return;
+}
+
+void
+__gnat_close_tty (TTY_Handle* t)
+{
+ free (t);
+}
+
+void
+__gnat_setup_winsize (void *desc, int rows, int columns)
+{
+}
+
+#else /* defined(_WIN32, implementatin for all UNIXes */
+
+/* First defined some macro to identify easily some systems */
+#if defined (__FreeBSD__) \
+ || defined (__OpenBSD__) \
+ || defined (__NetBSD__) \
+ || defined (__DragonFly__)
+# define FREEBSD
+#endif
+#if defined (__alpha__) && defined (__osf__)
+# define OSF1
+#endif
+#if defined (__mips) && defined (__sgi)
+# define IRIX
+#endif
+
+/* Include every system header we need */
+#define _GNU_SOURCE
+#include <errno.h>
+#include <stdio.h>
+#include <stdlib.h>
+
+/* On some system termio is either absent or including it will disable termios
+ (HP-UX) */
+#if ! defined (__hpux__) && ! defined (FREEBSD) && ! defined (__APPLE__)
+# include <termio.h>
+#endif
+
+#include <sys/ioctl.h>
+#include <termios.h>
+#include <fcntl.h>
+#include <string.h>
+#include <sys/stat.h>
+#include <sys/types.h>
+#include <sys/wait.h>
+#include <unistd.h>
+#if defined (sun)
+# include <sys/stropts.h>
+#endif
+#if defined (FREEBSD) || defined (sun)
+# include <sys/signal.h>
+#endif
+#if defined (__hpux__)
+# include <sys/termio.h>
+# include <sys/stropts.h>
+#endif
+
+#define CDISABLE _POSIX_VDISABLE
+
+/* On HP-UX and Sun system, there is a bzero function but with a different
+ signature. Use memset instead */
+#if defined (__hpux__) || defined (sun) || defined (_AIX)
+# define bzero(s,n) memset (s,0,n)
+#endif
+
+/* POSIX does not specify how to open the master side of a terminal.Several
+ methods are available (system specific):
+ 1- using a cloning device (USE_CLONE_DEVICE)
+ 2- getpt (USE_GETPT)
+ 3- openpty (USE_OPENPTY)
+ 4- _getpty (USE_GETPTY)
+
+ When using the cloning device method, the macro USE_CLONE_DEVICE should
+ contains a full path to the adequate device.
+
+ When a new system is about to be supported, one of the previous macro should
+ be set otherwise allocate_pty_desc will return an error
+*/
+
+/* Configurable part */
+#if defined (__APPLE__) || defined (FREEBSD)
+#define USE_OPENPTY
+#elif defined (IRIX)
+#define USE_GETPTY
+#elif defined (linux)
+#define USE_GETPT
+#elif defined (sun)
+#define USE_CLONE_DEVICE "/dev/ptmx"
+#elif defined (_AIX)
+#define USE_CLONE_DEVICE "/dev/ptc"
+#elif defined (OSF1)
+/* On Tru64, the systems offers various interfaces to open a terminal:
+ - /dev/ptmx: this the system V driver (stream based),
+ - /dev/ptmx_bsd: the non stream based clone device,
+ - the openpty function which use BSD interface.
+
+ Using directly /dev/ptmx_bsd on Tru64 5.1B seems to consume all the
+ available slave ptys (why ?). When using openpty it seems that the function
+ handles the creation of entries in /dev/pts when necessary and so avoid this
+ starvation issue. The pty man entry suggests also to use openpty.
+*/
+#define USE_OPENPTY
+#elif defined (__hpux__)
+/* On HP-UX we use the streamed version. Using the non streamed version is not
+ recommanded (through "/dev/ptym/clone"). Indeed it seems that there are
+ issues to detect process terminations. */
+#define USE_CLONE_DEVICE "/dev/ptmx"
+#endif
+
+/* structure that holds information about the terminal used and the process
+ connected on the slave side */
+typedef struct pty_desc_struct {
+ int master_fd; /* fd of the master side if the terminal */
+ int slave_fd; /* fd of the slave side */
+ char slave_name[32]; /* filename of the slave side */
+ int child_pid; /* PID of the child process connected to the slave side
+ of the terminal */
+} pty_desc;
+
+/* allocate_pty_desc - allocate a pseudo terminal
+ *
+ * PARAMETERS
+ * out desc returned pointer to a pty_desc structure containing information
+ * about the opened pseudo terminal
+ * RETURN VALUE
+ * -1 if failed
+ * 0 if ok
+ * COMMENTS
+ * If the function is successful we should have at least the master side fd
+ * and the slave side filename. On some system, the slave side will also be
+ * opened. If this is not the case the slave side will be open once we are in
+ * the child process (note that opening the slave side at this stage will
+ * failed...).
+ */
+
+extern char* ptsname (int);
+
+static int
+allocate_pty_desc (pty_desc **desc) {
+
+ pty_desc *result;
+ int status = 0;
+ int slave_fd = -1;
+ int master_fd = -1;
+ char *slave_name = NULL;
+
+#ifdef USE_GETPT
+ master_fd = getpt ();
+#elif defined (USE_OPENPTY)
+ status = openpty (&master_fd, &slave_fd, NULL, NULL, NULL);
+#elif defined (USE_GETPTY)
+ slave_name = _getpty (&master_fd, O_RDWR | O_NDELAY, 0600, 0);
+ if (slave_name == NULL) status = -1;
+#elif defined (USE_CLONE_DEVICE)
+ master_fd = open (USE_CLONE_DEVICE, O_RDWR | O_NONBLOCK, 0);
+#else
+ printf ("[error]: terminal support is not configured\n");
+ return -1;
+#endif
+
+ /* at this stage we should have the master side fd and status should be 0 */
+ if (status != 0 || master_fd < 0)
+ {
+ /* If this is not the case close all opened files and return -1 */
+ printf ("[error]: cannot allocate master side of the pty\n");
+ if (master_fd >= 0) close (master_fd);
+ if (slave_fd >= 0) close (slave_fd);
+ *desc = NULL;
+ return -1;
+ }
+
+ /* retrieve the file name of the slave side if necessary */
+ if (slave_name == NULL) slave_name = (char *) ptsname (master_fd);
+
+ /* Now we should have slave file name */
+ if (slave_name == NULL)
+ {
+ /* If not the case close any opened file and return - 1 */
+ printf ("[error]: cannot allocate slave side of the pty\n");
+ if (master_fd >= 0) close (master_fd);
+ if (slave_fd >= 0) close (slave_fd);
+ *desc = NULL;
+ return -1;
+ }
+
+ /* grant access to the slave side */
+ grantpt (master_fd);
+ /* unlock the terminal */
+ unlockpt (master_fd);
+
+ /* set desc and return 0 */
+ result = malloc (sizeof (pty_desc));
+ result->master_fd = master_fd;
+ result->slave_fd = slave_fd;
+ /* the string returned by ptsname or _getpty is a static allocated string. So
+ we should make a copy */
+ strncpy (result->slave_name, slave_name, sizeof (result->slave_name));
+ result->slave_name[sizeof (result->slave_name) - 1] = '\0';
+ result->child_pid = -1;
+ *desc=result;
+ return 0;
+}
+
+/* some utility macro that make the code of child_setup_tty easier to read */
+#define __enable(a, b) ((a) |= (b))
+#define __disable(a, b) ((a) &= ~(b))
+
+/* some properties do not exist on all systems. Set their value to 0 in that
+ case */
+#ifndef IUCLC
+#define IUCLC 0
+#endif
+#ifndef OLCUC
+#define OLCUC 0
+#endif
+#ifndef NLDLY
+#define NLDLY 0
+#define CRDLY 0
+#define TABDLY 0
+#define BSDLY 0
+#define VTDLY 0
+#define FFDLY 0
+#endif
+
+/* child_setup_tty - set terminal properties
+ *
+ * PARAMETERS
+ * file descriptor of the slave side of the terminal
+ *
+ * RETURN VALUE
+ * 0 if success, any other value if failed.
+ *
+ * COMMENTS
+ * None
+ */
+static int
+child_setup_tty (int fd)
+{
+ struct termios s;
+ int status;
+
+ /* ensure that s is filled with 0 */
+ bzero (&s, sizeof (&s));
+
+ /* Get the current terminal settings */
+ status = tcgetattr (fd, &s);
+ if (status != 0) return -1;
+
+ /* Adjust input modes */
+ __disable (s.c_iflag, IUCLC); /* don't transform to lower case */
+ __disable (s.c_iflag, ISTRIP); /* don't delete 8th bit */
+
+ /* Adjust output modes */
+ __enable (s.c_oflag, OPOST); /* enable postprocessing */
+ __disable (s.c_oflag, ONLCR); /* don't map LF to CR-LF */
+ __disable (s.c_oflag, NLDLY|CRDLY|TABDLY|BSDLY|VTDLY|FFDLY);
+ /* disable delays */
+ __disable (s.c_oflag, OLCUC); /* don't transform to upper case */
+
+ /* Adjust control modes */
+ s.c_cflag = (s.c_cflag & ~CSIZE) | CS8; /* Don't strip 8th bit */
+
+ /* Adjust local modes */
+ __disable (s.c_lflag, ECHO); /* disable echo */
+ __enable (s.c_lflag, ISIG); /* enable signals */
+ __enable (s.c_lflag, ICANON); /* erase/kill/eof processing */
+
+ /* Adjust control characters */
+ /* IMPORTANT: we need to ensure that Ctrl-C will trigger an interrupt signal
+ otherwise send_signal_via_characters will fail */
+ s.c_cc[VEOF] = 04; /* insure that EOF is Control-D */
+ s.c_cc[VERASE] = CDISABLE; /* disable erase processing */
+ s.c_cc[VKILL] = CDISABLE; /* disable kill processing */
+ s.c_cc[VQUIT] = 28; /* Control-\ */
+ s.c_cc[VINTR] = 03; /* Control-C */
+ s.c_cc[VEOL] = CDISABLE;
+ s.c_cc[VSUSP] = 26; /* Control-Z */
+
+ /* push our changes */
+ status = tcsetattr (fd, TCSADRAIN, &s);
+ return status;
+}
+
+/* __gnat_setup_communication - interface to the external world. Should be
+ * called before forking. On Unixes this function only call allocate_pty_desc.
+ * The Windows implementation (in different part of this file) is very
+ * different.
+ *
+ * PARAMETERS
+ * out desc returned pointer to a pty_desc structure
+ * RETURN VALUE
+ * 0 if success, -1 otherwise
+ */
+int __gnat_setup_communication (pty_desc** desc) {
+ return allocate_pty_desc (desc);
+}
+
+/* __gnat_setup_parent_communication - interface to the external world. Should
+ * be called after forking in the parent process
+ *
+ * PARAMETERS
+ * out in_fd
+ out out_fd
+ out err_fd fds corresponding to the parent side of the
+ terminal
+ in pid_out child process pid
+ * RETRUN VALUE
+ * 0
+ */
+void
+__gnat_setup_parent_communication
+ (pty_desc *desc,
+ int* in_fd, /* input */
+ int* out_fd, /* output */
+ int* err_fd, /* error */
+ int* pid_out)
+{
+
+ *in_fd = desc->master_fd;
+ *out_fd= desc->master_fd;
+ *err_fd= desc->master_fd;
+ desc->child_pid = *pid_out;
+}
+
+/* __gnat_setup_winsize - Sets up the size of the terminal
+ * This lets the process know the size of the terminal
+ */
+
+void __gnat_setup_winsize (pty_desc *desc, int rows, int columns) {
+#ifdef TIOCGWINSZ
+ struct winsize s;
+ s.ws_row = (unsigned short)rows;
+ s.ws_col = (unsigned short)columns;
+ s.ws_xpixel = 0;
+ s.ws_ypixel = 0;
+ ioctl (desc->master_fd, TIOCSWINSZ, &s);
+#ifdef SIGWINCH
+ if (desc->child_pid > 0) {
+ /* Let the process know about the change in size */
+ kill (desc->child_pid, SIGWINCH);
+ }
+#endif
+#endif
+}
+
+/* __gnat_setup_child_communication - interface to external world. Should be
+ * called after forking in the child process. On Unixes, this function
+ * first adjust the line setting, set standard output, input and error and
+ * then spawn the program.
+ *
+ * PARAMETERS
+ * desc a pty_desc structure containing the pty parameters
+ * new_argv argv of the program to be spawned
+ * RETURN VALUE
+ * this function should not return
+ */
+int
+__gnat_setup_child_communication
+ (pty_desc *desc,
+ char **new_argv,
+ int Use_Pipes)
+{
+ int status;
+ int pid = getpid ();
+
+ setsid ();
+
+ /* open the slave side of the terminal if necessary */
+ if (desc->slave_fd == -1)
+#if defined (_AIX)
+ /* On AIX, if the slave process is not opened with O_NDELAY or O_NONBLOCK
+ then we might have some processes hanging on I/O system calls. Not sure
+ we can do that for all platforms so do it only on AIX for the moment.
+ On AIX O_NONBLOCK and O_NDELAY have slightly different meanings. When
+ reading on the slave fd, in case there is no data available, if O_NDELAY
+ is set then 0 is returned. If O_NON_BLOCK is -1 is returned. It seems
+ that interactive programs such as GDB prefer the O_NDELAY behavior.
+ We chose O_NONBLOCK because it allows us to make the distinction
+ between a true EOF and an EOF returned because there is no data
+ available to be read. */
+ desc->slave_fd = open (desc->slave_name, O_RDWR | O_NONBLOCK, 0);
+#else
+ desc->slave_fd = open (desc->slave_name, O_RDWR, 0);
+#endif
+
+#if defined (sun) || defined (__hpux__)
+ /* On systems such as Solaris we are using stream. We need to push the right
+ "modules" in order to get the expected terminal behaviors. Otherwise
+ functionalities such as termios are not available. */
+ ioctl (desc->slave_fd, I_PUSH, "ptem");
+ ioctl (desc->slave_fd, I_PUSH, "ldterm");
+ ioctl (desc->slave_fd, I_PUSH, "ttcompat");
+#endif
+
+#ifdef TIOCSCTTY
+ /* make the tty the controling terminal */
+ status = ioctl (desc->slave_fd, TIOCSCTTY, 0);
+#endif
+
+ /* adjust tty settings */
+ child_setup_tty (desc->slave_fd);
+ __gnat_setup_winsize (desc, 24, 80); /* To prevent errors in some shells */
+
+ /* stdin, stdout and stderr should be now our tty */
+ dup2 (desc->slave_fd, 0);
+ dup2 (desc->slave_fd, 1);
+ dup2 (desc->slave_fd, 2);
+ if (desc->slave_fd > 2) close (desc->slave_fd);
+
+ /* adjust process group settings */
+ status = setpgid (pid, pid);
+ status = tcsetpgrp (0, pid);
+
+ /* launch the program */
+ execvp (new_argv[0], new_argv);
+
+ /* return the pid */
+ return pid;
+}
+
+/* send_signal_via_characters - Send a characters that will trigger a signal
+ * in the child process.
+ *
+ * PARAMETERS
+ * desc a pty_desc structure containing terminal information
+ * int a signal number
+ * RETURN VALUE
+ * None
+ */
+static void
+send_signal_via_characters
+ (pty_desc *desc,
+ int signal_number)
+{
+ char ctrl_c = 03;
+ char ctrl_backslash = 28;
+ char ctrl_Z = 26;
+
+ switch (signal_number)
+ {
+ case SIGINT:
+ write (desc->master_fd, &ctrl_c, 1); return;
+ case SIGQUIT:
+ write (desc->master_fd, &ctrl_backslash, 1); return;
+ case SIGTSTP:
+ write (desc->master_fd, &ctrl_Z, 1); return;
+ }
+}
+
+/* __gnat_interrupt_process - interrupt the child process
+ *
+ * PARAMETERS
+ * desc a pty_desc structure
+ */
+int
+__gnat_interrupt_process (pty_desc *desc)
+{
+ send_signal_via_characters (desc, SIGINT);
+ return 0;
+}
+
+/* __gnat_interrupt_pid - interrupt a process group
+ *
+ * PARAMETERS
+ * pid pid of the process to interrupt
+ */
+int
+__gnat_interrupt_pid (int pid)
+{
+ kill (-pid, SIGINT);
+ return 0;
+}
+
+/* __gnat_terminate_process - kill a child process
+ *
+ * PARAMETERS
+ * desc pty_desc structure
+ */
+int __gnat_terminate_process (pty_desc *desc)
+{
+ return kill (desc->child_pid, SIGKILL);
+}
+
+/* __gnat_tty_waitpid - wait for the child proces to die
+ *
+ * PARAMETERS
+ * desc pty_desc structure
+ * RETURN VALUE
+ * exit status of the child process
+ */
+int
+__gnat_tty_waitpid (pty_desc *desc)
+{
+ int status = 0;
+ waitpid (desc->child_pid, &status, 0);
+ return WEXITSTATUS (status);
+}
+
+/* __gnat_tty_supported - Are tty supported ?
+ *
+ * RETURN VALUE
+ * always 1 on Unix systems
+ */
+int
+__gnat_tty_supported (void)
+{
+ return 1;
+}
+
+/* __gnat_free_process - free a pty_desc structure
+ *
+ * PARAMETERS
+ * in out desc: a pty desc structure
+ */
+void
+__gnat_free_process (pty_desc** desc)
+{
+ free (*desc);
+ *desc = NULL;
+}
+
+/* __gnat_send_header - dummy function. this interface is only used on Windows */
+void
+__gnat_send_header (pty_desc* desc, char header[5], int size, int *ret)
+{
+ *ret = 0;
+}
+
+/* __gnat_reset_tty - reset line setting
+ *
+ * PARAMETERS
+ * desc: a pty_desc structure
+ */
+void
+__gnat_reset_tty (pty_desc* desc)
+{
+ child_setup_tty (desc->master_fd);
+}
+
+/* __gnat_new_tty - allocate a new terminal
+ *
+ * RETURN VALUE
+ * a pty_desc structure
+ */
+pty_desc *
+__gnat_new_tty (void)
+{
+ int status;
+ pty_desc* desc;
+ status = allocate_pty_desc (&desc);
+ child_setup_tty (desc->master_fd);
+ return desc;
+}
+
+/* __gnat_close_tty - close a terminal
+ *
+ * PARAMETERS
+ * desc a pty_desc strucure
+ */
+void __gnat_close_tty (pty_desc* desc)
+{
+ if (desc->master_fd >= 0) close (desc->master_fd);
+ if (desc->slave_fd >= 0) close (desc->slave_fd);
+}
+
+/* __gnat_tty_name - return slave side device name
+ *
+ * PARAMETERS
+ * desc a pty_desc strucure
+ * RETURN VALUE
+ * a string
+ */
+char *
+__gnat_tty_name (pty_desc* desc)
+{
+ return desc->slave_name;
+}
+
+/* __gnat_tty_name - return master side fd
+ *
+ * PARAMETERS
+ * desc a pty_desc strucure
+ * RETURN VALUE
+ * a fd
+ */
+int
+__gnat_tty_fd (pty_desc* desc)
+{
+ return desc->master_fd;
+}
+
+#endif /* WIN32 */
Index: g-tty.adb
===================================================================
--- g-tty.adb (revision 0)
+++ g-tty.adb (revision 0)
@@ -0,0 +1,134 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT LIBRARY COMPONENTS --
+-- --
+-- G N A T . T T Y --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2002-2011, AdaCore --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+with Interfaces.C.Strings; use Interfaces.C.Strings;
+
+package body GNAT.TTY is
+
+ use System;
+
+ procedure Check_TTY (Handle : TTY_Handle);
+ -- Check the validity of Handle. Raise Program_Error if ttys are not
+ -- supported. Raise Constraint_Error if Handle is an invalid handle.
+
+ ------------------
+ -- Allocate_TTY --
+ ------------------
+
+ procedure Allocate_TTY (Handle : out TTY_Handle) is
+ function Internal return System.Address;
+ pragma Import (C, Internal, "__gnat_new_tty");
+
+ begin
+ if not TTY_Supported then
+ raise Program_Error;
+ end if;
+
+ Handle.Handle := Internal;
+ end Allocate_TTY;
+
+ ---------------
+ -- Check_TTY --
+ ---------------
+
+ procedure Check_TTY (Handle : TTY_Handle) is
+ begin
+ if not TTY_Supported then
+ raise Program_Error;
+ elsif Handle.Handle = System.Null_Address then
+ raise Constraint_Error;
+ end if;
+ end Check_TTY;
+
+ ---------------
+ -- Close_TTY --
+ ---------------
+
+ procedure Close_TTY (Handle : in out TTY_Handle) is
+ procedure Internal (Handle : System.Address);
+ pragma Import (C, Internal, "__gnat_close_tty");
+ begin
+ Check_TTY (Handle);
+ Internal (Handle.Handle);
+ Handle.Handle := System.Null_Address;
+ end Close_TTY;
+
+ ---------------
+ -- Reset_TTY --
+ ---------------
+
+ procedure Reset_TTY (Handle : TTY_Handle) is
+ procedure Internal (Handle : System.Address);
+ pragma Import (C, Internal, "__gnat_reset_tty");
+ begin
+ Check_TTY (Handle);
+ Internal (Handle.Handle);
+ end Reset_TTY;
+
+ --------------------
+ -- TTY_Descriptor --
+ --------------------
+
+ function TTY_Descriptor
+ (Handle : TTY_Handle) return GNAT.OS_Lib.File_Descriptor
+ is
+ function Internal
+ (Handle : System.Address) return GNAT.OS_Lib.File_Descriptor;
+ pragma Import (C, Internal, "__gnat_tty_fd");
+ begin
+ Check_TTY (Handle);
+ return Internal (Handle.Handle);
+ end TTY_Descriptor;
+
+ --------------
+ -- TTY_Name --
+ --------------
+
+ function TTY_Name (Handle : TTY_Handle) return String is
+ function Internal (Handle : System.Address) return chars_ptr;
+ pragma Import (C, Internal, "__gnat_tty_name");
+ begin
+ Check_TTY (Handle);
+ return Value (Internal (Handle.Handle));
+ end TTY_Name;
+
+ -------------------
+ -- TTY_Supported --
+ -------------------
+
+ function TTY_Supported return Boolean is
+ function Internal return Integer;
+ pragma Import (C, Internal, "__gnat_tty_supported");
+ begin
+ return Internal /= 0;
+ end TTY_Supported;
+
+end GNAT.TTY;
Index: g-tty.ads
===================================================================
--- g-tty.ads (revision 0)
+++ g-tty.ads (revision 0)
@@ -0,0 +1,73 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT LIBRARY COMPONENTS --
+-- --
+-- G N A T . T T Y --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2002-2011, AdaCore --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package provides control over pseudo terminals (ttys)
+
+-- This package is only supported on unix systems. See function TTY_Supported
+-- to test dynamically whether other functions of this package can be called.
+
+with System;
+
+with GNAT.OS_Lib;
+
+package GNAT.TTY is
+
+ type TTY_Handle is private;
+ -- Handle for a tty descriptor
+
+ function TTY_Supported return Boolean;
+ -- If True, the other functions of this package can be called. Otherwise,
+ -- all functions in this package will raise Program_Error if called.
+
+ procedure Allocate_TTY (Handle : out TTY_Handle);
+ -- Allocate a new tty
+
+ procedure Reset_TTY (Handle : TTY_Handle);
+ -- Reset settings of a given tty
+
+ procedure Close_TTY (Handle : in out TTY_Handle);
+ -- Close a given tty
+
+ function TTY_Name (Handle : TTY_Handle) return String;
+ -- Return the external name of a tty. The name depends on the tty handling
+ -- on the given target. It will typically look like: "/dev/ptya1"
+
+ function TTY_Descriptor
+ (Handle : TTY_Handle) return GNAT.OS_Lib.File_Descriptor;
+ -- Return the low level descriptor associated with Handle
+
+private
+
+ type TTY_Handle is record
+ Handle : System.Address := System.Null_Address;
+ end record;
+
+end GNAT.TTY;
Index: gcc-interface/Makefile.in
===================================================================
--- gcc-interface/Makefile.in (revision 181654)
+++ gcc-interface/Makefile.in (working copy)
@@ -2213,12 +2213,13 @@
argv.c cio.c cstreams.c errno.c exit.c cal.c ctrl_c.c env.c env.h \
arit64.c raise.h raise.c sysdep.c aux-io.c init.c initialize.c \
locales.c seh_init.c final.c tracebak.c tb-alvms.c tb-alvxw.c \
- tb-gcc.c expect.c mkdir.c socket.c gsocket.h targext.c $(EXTRA_LIBGNAT_SRCS)
+ tb-gcc.c expect.c mkdir.c socket.c gsocket.h targext.c \
+ terminals.c $(EXTRA_LIBGNAT_SRCS)
LIBGNAT_OBJS = adadecode.o adaint.o argv.o cio.o cstreams.o ctrl_c.o \
errno.o exit.o env.o raise.o sysdep.o aux-io.o init.o initialize.o \
locales.o seh_init.o cal.o arit64.o final.o tracebak.o expect.o \
- mkdir.o socket.o targext.o $(EXTRA_LIBGNAT_OBJS)
+ mkdir.o socket.o targext.o terminals.o $(EXTRA_LIBGNAT_OBJS)
# NOTE ??? - when the -I option for compiling Ada code is made to work,
# the library installation will change and there will be a
@@ -2859,6 +2860,7 @@
sysdep.o : sysdep.c
raise.o : raise.c raise.h
sigtramp-ppcvxw.o : sigtramp-ppcvxw.c sigtramp.h
+terminals.o : terminals.c
vx_stack_info.o : vx_stack_info.c
raise-gcc.o : raise-gcc.c raise.h
Index: gcc-interface/Make-lang.in
===================================================================
--- gcc-interface/Make-lang.in (revision 181654)
+++ gcc-interface/Make-lang.in (working copy)
@@ -2617,9 +2617,9 @@
ada/lib.ads ada/lib.adb ada/lib-list.adb ada/lib-load.ads \
ada/lib-sort.adb ada/lib-util.ads ada/lib-xref.ads ada/namet.ads \
ada/namet.adb ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb \
- ada/opt.ads ada/output.ads ada/put_alfa.ads ada/restrict.ads \
- ada/restrict.adb ada/rident.ads ada/rtsfind.ads ada/scans.ads \
- ada/sem.ads ada/sem.adb ada/sem_attr.ads ada/sem_aux.ads \
+ ada/opt.ads ada/opt.adb ada/output.ads ada/put_alfa.ads \
+ ada/restrict.ads ada/restrict.adb ada/rident.ads ada/rtsfind.ads \
+ ada/scans.ads ada/sem.ads ada/sem.adb ada/sem_attr.ads ada/sem_aux.ads \
ada/sem_aux.adb ada/sem_cat.ads ada/sem_ch10.ads ada/sem_ch11.ads \
ada/sem_ch12.ads ada/sem_ch13.ads ada/sem_ch2.ads ada/sem_ch3.ads \
ada/sem_ch4.ads ada/sem_ch5.ads ada/sem_ch6.ads ada/sem_ch7.ads \
More information about the Gcc-patches
mailing list