diff mbox

[Ada] Refuse executable with same name as source

Message ID 20100910095758.GA18263@adacore.com
State New
Headers show

Commit Message

Arnaud Charlet Sept. 10, 2010, 9:57 a.m. UTC 
Currently it is possible to accidentally and silently overwrite
a source file with an executable, if the sourcefile has no file
extension and the operating system uses no file extensions for
executables. This fixes that.

The following test case should not overwrite hello with an executable,
but instead exit with an error message:

% cat >hello <<EOF && gnatmake hello
> with Text_IO; use Text_IO;
> procedure Hello is
> begin
>    Put_Line ("This source self-destructs after compilation");
> end Hello;
> EOF
gcc -c -x ada hello
hello:2:11: warning: file name does not match unit name, should be "hello.adb"
gnatbind -x hello.ali
gnatlink hello.ali
gnatlink: executable name "hello" matches source file name "hello"
gnatmake: *** link failed.

Tested on x86_64-pc-linux-gnu, committed on trunk

2010-09-10  Geert Bosch  <bosch@adacore.com>

	* gnatlink.adb (Check_ Existing_Executable): New procedure for checking
	validity of executable name and removing any existing executable
	(Gnatlink): Call Check_Existing_Executable.
diff mbox

Patch

Index: gnatlink.adb
===================================================================
--- gnatlink.adb	(revision 164149)
+++ gnatlink.adb	(working copy)
@@ -199,6 +199,13 @@  procedure Gnatlink is
    function Base_Name (File_Name : String) return String;
    --  Return just the file name part without the extension (if present)
 
+   procedure Check_Existing_Executable (File_Name : String);
+   --  Delete any existing executable to avoid accidentally updating
+   --  the target of a symbolic link, but produce a Fatail_Error if
+   --  File_Name matches any of the source file names. This avoids
+   --  overwriting of extensionless source files by accident on systems
+   --  where executables do not have extensions.
+
    procedure Delete (Name : String);
    --  Wrapper to unlink as status is ignored by this application
 
@@ -258,6 +265,31 @@  procedure Gnatlink is
       return File_Name (Findex1 .. Findex2 - 1);
    end Base_Name;
 
+   -------------------------------
+   -- Check_Existing_Executable --
+   -------------------------------
+
+   procedure Check_Existing_Executable (File_Name : String) is
+      Ename : String := File_Name;
+      Efile : File_Name_Type;
+      Sfile : File_Name_Type;
+   begin
+      Canonical_Case_File_Name (Ename);
+      Name_Len := 0;
+      Add_Str_To_Name_Buffer (Ename);
+      Efile := Name_Find;
+
+      for J in Units.Table'First .. Units.Last loop
+         Sfile := Units.Table (J).Sfile;
+         if Sfile = Efile then
+            Exit_With_Error ("executable name """ & File_Name & """ matches "
+              & "source file name """ & Get_Name_String (Sfile) & """");
+         end if;
+      end loop;
+
+      Delete (File_Name);
+   end Check_Existing_Executable;
+
    ------------
    -- Delete --
    ------------
@@ -1759,16 +1791,7 @@  begin
         new String'(Output_File_Name.all);
    end if;
 
-   --  Delete existing executable, in case it is a symbolic link, to avoid
-   --  modifying the target of the symbolic link.
-
-   declare
-      Dummy : Boolean;
-      pragma Unreferenced (Dummy);
-
-   begin
-      Delete_File (Output_File_Name.all, Dummy);
-   end;
+   Check_Existing_Executable (Output_File_Name.all);
 
    --  Warn if main program is called "test", as that may be a built-in command
    --  on Unix. On non-Unix systems executables have a suffix, so the warning