mirror of
https://github.com/AdaCore/PolyORB.git
synced 2026-02-12 13:01:15 -08:00
0e656db21a
[Imported from Perforce change 10420 at 2006-12-01 22:55:28] Subversion-branch: /trunk/polyorb Subversion-revision: 37879
238 lines
8.5 KiB
Ada
238 lines
8.5 KiB
Ada
------------------------------------------------------------------------------
|
|
-- --
|
|
-- POLYORB COMPONENTS --
|
|
-- --
|
|
-- R U N _ S C R I P T --
|
|
-- --
|
|
-- B o d y --
|
|
-- --
|
|
-- Copyright (C) 1999-2004 Free Software Foundation, Inc. --
|
|
-- --
|
|
-- PolyORB is free software; you can redistribute it and/or modify it --
|
|
-- under terms of the GNU General Public License as published by the Free --
|
|
-- Software Foundation; either version 2, or (at your option) any later --
|
|
-- version. PolyORB is distributed in the hope that it will be useful, --
|
|
-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- --
|
|
-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public --
|
|
-- License for more details. You should have received a copy of the GNU --
|
|
-- General Public License distributed with PolyORB; see file COPYING. If --
|
|
-- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, --
|
|
-- Boston, MA 02111-1307, USA. --
|
|
-- --
|
|
-- As a special exception, if other files instantiate generics from this --
|
|
-- unit, or you link this unit with other files to produce an executable, --
|
|
-- this unit does not by itself cause the resulting executable to be --
|
|
-- covered by the GNU General Public License. This exception does not --
|
|
-- however invalidate any other reasons why the executable file might be --
|
|
-- covered by the GNU Public License. --
|
|
-- --
|
|
-- PolyORB is maintained by ACT Europe. --
|
|
-- (email: sales@act-europe.fr) --
|
|
-- --
|
|
------------------------------------------------------------------------------
|
|
|
|
-- Wrapper to run shell scripts under Windows.
|
|
|
|
-- This runs the script with the same name as its own executable file without
|
|
-- the .exe extension. For example, we copy run_script.exe to
|
|
-- native_linker.exe. When native_linker.exe runs, it runs the script called
|
|
-- native_linker using an appropriate Unix-like shell, passing along all
|
|
-- arguments. The native_linker will start with something like "#! /bin/sh" in
|
|
-- the usual Unix convention. If we're running under cygwin, then this:
|
|
-- native_linker.exe arg1 arg2
|
|
-- will run something like this:
|
|
-- C:\cygwin\bin\sh.exe C:/.../support/native-linker arg1 arg2
|
|
|
|
-- This is needed because we sometimes pass something like this:
|
|
-- --LINK=../../support/native-linker
|
|
-- to gnatlink, where native-linker is a shell script starting with
|
|
-- "#! /bin/sh". But on windows, gnatlink is a windows program, and therefore
|
|
-- does not understand the "#!" convention.
|
|
|
|
with Ada.Command_Line;
|
|
with Ada.Text_IO;
|
|
with GNAT.OS_Lib;
|
|
with GNAT.Registry;
|
|
with GNAT.Directory_Operations;
|
|
|
|
procedure Run_Script is
|
|
|
|
use Ada.Command_Line;
|
|
use Ada.Text_IO;
|
|
use GNAT.OS_Lib;
|
|
use GNAT.Directory_Operations;
|
|
|
|
function All_Arguments return Argument_List;
|
|
-- Return an argument list corresponding to the command line.
|
|
-- All backslashes are changed to slashes.
|
|
|
|
function MinGW_Resolve (Filename : String) return String;
|
|
-- Resolve filename, for MinGW
|
|
|
|
function Cygwin_Resolve (Filename : String) return String;
|
|
-- Resolve a name relative to Cygwin mount points to the
|
|
-- corresponding native path.
|
|
|
|
function Strip_Exe (Filename : String) return String;
|
|
-- Strip the ".exe" extension off the end of Filename
|
|
|
|
-------------------
|
|
-- All_Arguments --
|
|
-------------------
|
|
|
|
function All_Arguments return Argument_List is
|
|
Result : Argument_List (1 .. Argument_Count);
|
|
begin
|
|
for J in Result'Range loop
|
|
Result (J) := new String'(Argument (J));
|
|
for K in Result (J)'Range loop
|
|
if Result (J) (K) = '\' then
|
|
Result (J) (K) := '/';
|
|
end if;
|
|
end loop;
|
|
end loop;
|
|
return Result;
|
|
end All_Arguments;
|
|
|
|
-------------------
|
|
-- MinGW_Resolve --
|
|
-------------------
|
|
|
|
function MinGW_Resolve (Filename : String) return String is
|
|
Split : Integer := Filename'Last;
|
|
begin
|
|
while Split > Filename'First and then Filename (Split) /= '/' loop
|
|
Split := Split - 1;
|
|
end loop;
|
|
|
|
return Filename (Split + 1 .. Filename'Last);
|
|
end MinGW_Resolve;
|
|
|
|
--------------------
|
|
-- Cygwin_Resolve --
|
|
--------------------
|
|
|
|
function Cygwin_Resolve (Filename : String) return String is
|
|
|
|
use GNAT.Registry;
|
|
|
|
Mounts_Keys_Base : constant String
|
|
:= "SOFTWARE\Cygnus Solutions\Cygwin\mounts v2\";
|
|
|
|
Split : Integer := Filename'Last;
|
|
begin
|
|
loop
|
|
while Split > Filename'First and then Filename (Split) /= '/' loop
|
|
Split := Split - 1;
|
|
end loop;
|
|
if Split > Filename'First then
|
|
Split := Split - 1;
|
|
end if;
|
|
exit when Split < Filename'First;
|
|
begin
|
|
declare
|
|
K : constant HKEY := Open_Key (HKEY_LOCAL_MACHINE,
|
|
Mounts_Keys_Base & Filename (Filename'First .. Split));
|
|
Native_Path : constant String := Query_Value (K, "native");
|
|
begin
|
|
-- Key found!
|
|
return Native_Path & Filename (Split + 1 .. Filename'Last);
|
|
end;
|
|
exception
|
|
when Registry_Error =>
|
|
null;
|
|
end;
|
|
end loop;
|
|
return Filename;
|
|
end Cygwin_Resolve;
|
|
|
|
---------------
|
|
-- Strip_Exe --
|
|
---------------
|
|
|
|
function Strip_Exe (Filename : String) return String is
|
|
begin
|
|
if
|
|
Filename'Length < 4
|
|
or else Filename (Filename'Last - 3 .. Filename'Last) /= ".exe"
|
|
then
|
|
Put_Line ("run_script: " & Filename & " should end in '.exe'");
|
|
OS_Exit (-1);
|
|
end if;
|
|
|
|
return Filename (Filename'First .. Filename'Last - 4);
|
|
end Strip_Exe;
|
|
|
|
Self : constant String := Format_Pathname (Command_Name, UNIX);
|
|
-- Name of this executable file
|
|
|
|
Script_Name : constant String := Strip_Exe (Self);
|
|
-- Name of this executable with ".exe" removed.
|
|
|
|
Script : Ada.Text_IO.File_Type;
|
|
|
|
Line : String (1 .. 256);
|
|
First, Last : Integer;
|
|
|
|
begin
|
|
begin
|
|
Open (Script, In_file, Script_Name);
|
|
exception
|
|
when Name_Error | Use_Error =>
|
|
Put_Line ("run_script: cannot open " & Script_Name);
|
|
OS_Exit (-1);
|
|
end;
|
|
Get_Line (Script, Line, Last);
|
|
if Last < 2 or else Line (1 .. 2) /= "#!" then
|
|
Put_Line ("run_script: file " & Script_Name & " must start with '#!'");
|
|
Put_Line ("found '" & Line (Line'First .. Last) & "'");
|
|
OS_Exit (-1);
|
|
end if;
|
|
|
|
First := 3;
|
|
while First < Last
|
|
and then (Line (First) = ' ' or else Line (First) = ASCII.HT)
|
|
loop
|
|
First := First + 1;
|
|
end loop;
|
|
|
|
declare
|
|
Interp_Command : constant String := Line (First .. Last);
|
|
Args : constant Argument_List_Access
|
|
:= Argument_String_To_List (Interp_Command);
|
|
|
|
New_Args : constant Argument_List
|
|
:= Args (Args'First + 1 .. Args'Last)
|
|
& new String'(Script_Name)
|
|
& All_Arguments;
|
|
|
|
Interp : String renames Args (Args'First).all;
|
|
Interp_Path : String_Access;
|
|
|
|
begin
|
|
Interp_Path := Locate_Exec_On_Path (Interp);
|
|
|
|
if Interp_Path = null then
|
|
Interp_Path := Locate_Exec_On_Path (Cygwin_Resolve (Interp));
|
|
end if;
|
|
|
|
if Interp_Path = null then
|
|
Interp_Path := Locate_Exec_On_Path (MinGW_Resolve (Interp));
|
|
end if;
|
|
|
|
if Interp_Path = null then
|
|
Put_Line ("run_script: Interp = """ & Interp & """ not found ");
|
|
Put_Line ("Tried:");
|
|
Put_Line (" normal resolv = " & Interp);
|
|
Put_Line (" for Cygwin = " & Cygwin_Resolve (Interp));
|
|
Put_Line (" for MinGW = " & MinGW_Resolve (Interp));
|
|
OS_Exit (-1);
|
|
end if;
|
|
|
|
OS_Exit (Spawn (Interp_Path.all, New_Args));
|
|
end;
|
|
|
|
-- Can't get here!
|
|
|
|
end Run_Script;
|