-- --
-- B o d y --
-- --
--- Copyright (C) 1998-2005 Ada Core Technologies, Inc. --
+-- Copyright (C) 1998-2009, 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- --
with Ada.Characters.Handling;
with Ada.Strings.Fixed;
-with Ada.Strings.Maps;
-with Unchecked_Deallocation;
-with Unchecked_Conversion;
+with Ada.Unchecked_Deallocation;
+with Ada.Unchecked_Conversion;
with System; use System;
with System.CRTL; use System.CRTL;
use Ada;
- type Dir_Type_Value is new System.Address;
- -- This is the low-level address directory structure as returned by the C
- -- opendir routine.
-
Filename_Max : constant Integer := 1024;
-- 1024 is the value of FILENAME_MAX in stdio.h
procedure Free is new
- Unchecked_Deallocation (Dir_Type_Value, Dir_Type);
+ Ada.Unchecked_Deallocation (Dir_Type_Value, Dir_Type);
+
+ On_Windows : constant Boolean := GNAT.OS_Lib.Directory_Separator = '\';
+ -- An indication that we are on Windows. Used in Get_Current_Dir, to
+ -- deal with drive letters in the beginning of absolute paths.
---------------
-- Base_Name --
begin
-- Cut_Start point to the first basename character
- if Cut_Start = 0 then
- Cut_Start := Path'First;
-
- else
- Cut_Start := Cut_Start + 1;
- end if;
+ Cut_Start := (if Cut_Start = 0 then Path'First else Cut_Start + 1);
- -- Cut_End point to the last basename character.
+ -- Cut_End point to the last basename character
Cut_End := Path'Last;
- -- If basename ends with Suffix, adjust Cut_End.
+ -- If basename ends with Suffix, adjust Cut_End
if Suffix /= ""
and then Path (Path'Last - Suffix'Length + 1 .. Cut_End) = Suffix
end Check_For_Standard_Dirs;
end Basename;
- -- Start processing for Base_Name
+ -- Start of processing for Base_Name
begin
if Path'Length <= Suffix'Length then
procedure Change_Dir (Dir_Name : Dir_Name_Str) is
C_Dir_Name : constant String := Dir_Name & ASCII.NUL;
-
- function chdir (Dir_Name : String) return Integer;
- pragma Import (C, chdir, "chdir");
-
begin
if chdir (C_Dir_Name) /= 0 then
raise Directory_Error;
Discard : Integer;
pragma Warnings (Off, Discard);
+ function closedir (directory : DIRs) return Integer;
+ pragma Import (C, closedir, "__gnat_closedir");
+
begin
if not Is_Open (Dir) then
raise Directory_Error;
procedure Double_Result_Size is
New_Result : constant OS_Lib.String_Access :=
- new String (1 .. 2 * Result'Last);
-
+ new String (1 .. 2 * Result'Last);
begin
New_Result (1 .. Result_Last) := Result (1 .. Result_Last);
OS_Lib.Free (Result);
procedure Read (K : in out Positive) is
P : Character;
+
begin
For_All_Characters : loop
if Is_Var_Prefix (Path (K)) then
-- Could be a variable
if K < Path'Last then
-
if Path (K + 1) = P then
-- Not a variable after all, this is a double $ or %,
E := K;
- -- Check that first chartacter is a letter
+ -- Check that first character is a letter
if Characters.Handling.Is_Letter (Path (E)) then
E := E + 1;
function Get_Current_Dir return Dir_Name_Str is
Current_Dir : String (1 .. Max_Path + 1);
Last : Natural;
-
begin
Get_Current_Dir (Current_Dir, Last);
return Current_Dir (1 .. Last);
begin
Local_Get_Current_Dir (Buffer'Address, Path_Len'Address);
- if Dir'Length > Path_Len then
- Last := Dir'First + Path_Len - 1;
- else
- Last := Dir'Last;
- end if;
+ Last :=
+ (if Dir'Length > Path_Len then Dir'First + Path_Len - 1 else Dir'Last);
Dir (Buffer'First .. Last) := Buffer (Buffer'First .. Last);
+
+ -- By default, the drive letter on Windows is in upper case
+
+ if On_Windows and then Last > Dir'First and then
+ Dir (Dir'First + 1) = ':'
+ then
+ Dir (Dir'First) :=
+ Ada.Characters.Handling.To_Upper (Dir (Dir'First));
+ end if;
end Get_Current_Dir;
-------------
(Dir : out Dir_Type;
Dir_Name : Dir_Name_Str)
is
+ function opendir (file_name : String) return DIRs;
+ pragma Import (C, opendir, "__gnat_opendir");
+
C_File_Name : constant String := Dir_Name & ASCII.NUL;
begin
----------
procedure Read
- (Dir : in out Dir_Type;
+ (Dir : Dir_Type;
Str : out String;
Last : out Natural)
is
Filename_Addr : Address;
- Filename_Len : Integer;
+ Filename_Len : aliased Integer;
Buffer : array (0 .. Filename_Max + 12) of Character;
-- 12 is the size of the dirent structure (see dirent.h), without the
function readdir_gnat
(Directory : System.Address;
- Buffer : System.Address) return System.Address;
+ Buffer : System.Address;
+ Last : not null access Integer) return System.Address;
pragma Import (C, readdir_gnat, "__gnat_readdir");
- function strlen (S : Address) return Integer;
- pragma Import (C, strlen, "strlen");
-
begin
if not Is_Open (Dir) then
raise Directory_Error;
end if;
Filename_Addr :=
- readdir_gnat (System.Address (Dir.all), Buffer'Address);
+ readdir_gnat
+ (System.Address (Dir.all), Buffer'Address, Filename_Len'Access);
if Filename_Addr = System.Null_Address then
Last := 0;
return;
end if;
- Filename_Len := strlen (Filename_Addr);
-
- if Str'Length > Filename_Len then
- Last := Str'First + Filename_Len - 1;
- else
- Last := Str'Last;
- end if;
+ Last :=
+ (if Str'Length > Filename_Len then Str'First + Filename_Len - 1
+ else Str'Last);
declare
subtype Path_String is String (1 .. Filename_Len);
type Path_String_Access is access Path_String;
function Address_To_Access is new
- Unchecked_Conversion
+ Ada.Unchecked_Conversion
(Source => Address,
Target => Path_String_Access);
-------------------------
function Read_Is_Thread_Safe return Boolean is
-
function readdir_is_thread_safe return Integer;
pragma Import
(C, readdir_is_thread_safe, "__gnat_readdir_is_thread_safe");
-
begin
return (readdir_is_thread_safe /= 0);
end Read_Is_Thread_Safe;
-- Remove the directory only if it is empty
if not Recursive then
- rmdir (C_Dir_Name);
-
- if GNAT.OS_Lib.Is_Directory (Dir_Name) then
+ if rmdir (C_Dir_Name) /= 0 then
raise Directory_Error;
end if;
-- Remove directory and all files and directories that it may contain
else
- Change_Dir (Dir_Name);
- Open (Working_Dir, ".");
+ -- Substantial comments needed. See RH for revision 1.50 ???
- loop
- Read (Working_Dir, Str, Last);
- exit when Last = 0;
+ begin
+ Change_Dir (Dir_Name);
+ Open (Working_Dir, ".");
- if GNAT.OS_Lib.Is_Directory (Str (1 .. Last)) then
- if Str (1 .. Last) /= "." and then Str (1 .. Last) /= ".." then
- Remove_Dir (Str (1 .. Last), True);
- Remove_Dir (Str (1 .. Last));
- end if;
+ loop
+ Read (Working_Dir, Str, Last);
+ exit when Last = 0;
- else
- GNAT.OS_Lib.Delete_File (Str (1 .. Last), Success);
+ if GNAT.OS_Lib.Is_Directory (Str (1 .. Last)) then
+ if Str (1 .. Last) /= "."
+ and then
+ Str (1 .. Last) /= ".."
+ then
+ Remove_Dir (Str (1 .. Last), True);
+ end if;
+
+ else
+ GNAT.OS_Lib.Delete_File (Str (1 .. Last), Success);
- if not Success then
- Change_Dir (Current_Dir);
- raise Directory_Error;
+ if not Success then
+ Change_Dir (Current_Dir);
+ raise Directory_Error;
+ end if;
end if;
- end if;
- end loop;
+ end loop;
+
+ Change_Dir (Current_Dir);
+ Close (Working_Dir);
+ Remove_Dir (Dir_Name);
- Change_Dir (Current_Dir);
- Close (Working_Dir);
- Remove_Dir (Dir_Name);
+ exception
+ when others =>
+
+ -- An exception occurred. We must make sure the current working
+ -- directory is unchanged.
+
+ Change_Dir (Current_Dir);
+
+ -- What if the Change_Dir raises an exception itself, shouldn't
+ -- that be protected? ???
+
+ raise;
+ end;
end if;
end Remove_Dir;
OSDN Git Service
