-- --
-- B o d y --
-- --
--- $Revision: 1.2 $
--- --
--- Copyright (C) 1998-2001 Ada Core Technologies, Inc. --
+-- Copyright (C) 1998-2005 Ada Core Technologies, Inc. --
-- --
-- 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- --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
with Ada.Characters.Handling;
with Ada.Strings.Fixed;
-with Ada.Strings.Unbounded;
with Ada.Strings.Maps;
+
with Unchecked_Deallocation;
with Unchecked_Conversion;
-with System; use System;
-with GNAT.Regexp;
+with System; use System;
+with System.CRTL; use System.CRTL;
+
with GNAT.OS_Lib;
package body GNAT.Directory_Operations is
-- This is the low-level address directory structure as returned by the C
-- opendir routine.
- Dir_Seps : constant Strings.Maps.Character_Set :=
- Strings.Maps.To_Set ("/\");
- -- UNIX and DOS style directory separators.
+ 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);
function Base_Name
(Path : Path_Name;
- Suffix : String := "")
- return String
+ Suffix : String := "") return String
is
function Get_File_Names_Case_Sensitive return Integer;
pragma Import
function Basename
(Path : Path_Name;
- Suffix : String := "")
- return String;
+ Suffix : String := "") return String;
-- This function does the job. The only difference between Basename
-- and Base_Name (the parent function) is that the former is case
-- sensitive, while the latter is not. Path and Suffix are adjusted
function Basename
(Path : Path_Name;
- Suffix : String := "")
- return String
+ Suffix : String := "") return String
is
Cut_Start : Natural :=
Strings.Fixed.Index
Base_Name.Path (Cut_Start - Offset .. Cut_End - Offset);
-- Here we use Base_Name.Path to keep the original casing
+ Has_Drive_Letter : constant Boolean :=
+ OS_Lib.Path_Separator /= ':';
+ -- If Path separator is not ':' then we are on a DOS based OS
+ -- where this character is used as a drive letter separator.
+
begin
if BN = "." or else BN = ".." then
return "";
- elsif BN'Length > 2
+ elsif Has_Drive_Letter
+ and then BN'Length > 2
and then Characters.Handling.Is_Letter (BN (BN'First))
and then BN (BN'First + 1) = ':'
then
-- Start processing for Base_Name
begin
+ if Path'Length <= Suffix'Length then
+ return Path;
+ end if;
+
if Case_Sensitive_File_Name then
return Basename (Path, Suffix);
-
else
return Basename
(Characters.Handling.To_Lower (Path),
----------------
procedure Change_Dir (Dir_Name : Dir_Name_Str) is
- C_Dir_Name : String := Dir_Name & ASCII.NUL;
+ C_Dir_Name : constant String := Dir_Name & ASCII.NUL;
function chdir (Dir_Name : String) return Integer;
pragma Import (C, chdir, "chdir");
-----------
procedure Close (Dir : in out Dir_Type) is
-
- function closedir (Directory : System.Address) return Integer;
- pragma Import (C, closedir, "closedir");
-
Discard : Integer;
+ pragma Warnings (Off, Discard);
begin
if not Is_Open (Dir) then
raise Directory_Error;
end if;
- Discard := closedir (System.Address (Dir.all));
+ Discard := closedir (DIRs (Dir.all));
Free (Dir);
end Close;
-- Expand_Path --
-----------------
- function Expand_Path (Path : Path_Name) return String is
- use Ada.Strings.Unbounded;
+ function Expand_Path
+ (Path : Path_Name;
+ Mode : Environment_Style := System_Default) return Path_Name
+ is
+ Environment_Variable_Char : Character;
+ pragma Import (C, Environment_Variable_Char, "__gnat_environment_char");
+
+ Result : OS_Lib.String_Access := new String (1 .. 200);
+ Result_Last : Natural := 0;
+
+ procedure Append (C : Character);
+ procedure Append (S : String);
+ -- Append to Result
+
+ procedure Double_Result_Size;
+ -- Reallocate Result, doubling its size
+
+ function Is_Var_Prefix (C : Character) return Boolean;
+ pragma Inline (Is_Var_Prefix);
procedure Read (K : in out Positive);
-- Update Result while reading current Path starting at position K. If
-- Translate variable name starting at position K with the associated
-- environment value.
- procedure Free is
- new Unchecked_Deallocation (String, OS_Lib.String_Access);
+ ------------
+ -- Append --
+ ------------
- Result : Unbounded_String;
+ procedure Append (C : Character) is
+ begin
+ if Result_Last = Result'Last then
+ Double_Result_Size;
+ end if;
+
+ Result_Last := Result_Last + 1;
+ Result (Result_Last) := C;
+ end Append;
+
+ procedure Append (S : String) is
+ begin
+ while Result_Last + S'Length - 1 > Result'Last loop
+ Double_Result_Size;
+ end loop;
+
+ Result (Result_Last + 1 .. Result_Last + S'Length) := S;
+ Result_Last := Result_Last + S'Length;
+ end Append;
+
+ ------------------------
+ -- Double_Result_Size --
+ ------------------------
+
+ procedure Double_Result_Size is
+ New_Result : constant OS_Lib.String_Access :=
+ new String (1 .. 2 * Result'Last);
+
+ begin
+ New_Result (1 .. Result_Last) := Result (1 .. Result_Last);
+ OS_Lib.Free (Result);
+ Result := New_Result;
+ end Double_Result_Size;
+
+ -------------------
+ -- Is_Var_Prefix --
+ -------------------
+
+ function Is_Var_Prefix (C : Character) return Boolean is
+ begin
+ return (C = Environment_Variable_Char and then Mode = System_Default)
+ or else
+ (C = '$' and then (Mode = UNIX or else Mode = Both))
+ or else
+ (C = '%' and then (Mode = DOS or else Mode = Both));
+ end Is_Var_Prefix;
----------
-- Read --
----------
procedure Read (K : in out Positive) is
+ P : Character;
begin
For_All_Characters : loop
- if Path (K) = '$' then
+ if Is_Var_Prefix (Path (K)) then
+ P := Path (K);
-- Could be a variable
if K < Path'Last then
- if Path (K + 1) = '$' then
+ if Path (K + 1) = P then
- -- Not a variable after all, this is a double $, just
- -- insert one in the result string.
+ -- Not a variable after all, this is a double $ or %,
+ -- just insert one in the result string.
- Append (Result, '$');
+ Append (P);
K := K + 1;
else
-- Let's parse the variable
- K := K + 1;
Var (K);
end if;
else
- -- We have an ending $ sign
+ -- We have an ending $ or % sign
- Append (Result, '$');
+ Append (P);
end if;
else
-- This is a standard character, just add it to the result
- Append (Result, Path (K));
+ Append (Path (K));
end if;
-- Skip to next character
---------
procedure Var (K : in out Positive) is
+ P : constant Character := Path (K);
+ T : Character;
E : Positive;
begin
- if Path (K) = '{' then
+ K := K + 1;
+
+ if P = '%' or else Path (K) = '{' then
+
+ -- Set terminator character
+
+ if P = '%' then
+ T := '%';
+ else
+ T := '}';
+ K := K + 1;
+ end if;
- -- Look for closing } (curly bracket).
+ -- Look for terminator character, k point to the first character
+ -- for the variable name.
E := K;
loop
E := E + 1;
- exit when Path (E) = '}' or else E = Path'Last;
+ exit when Path (E) = T or else E = Path'Last;
end loop;
- if Path (E) = '}' then
+ if Path (E) = T then
-- OK found, translate with environment value
declare
Env : OS_Lib.String_Access :=
- OS_Lib.Getenv (Path (K + 1 .. E - 1));
+ OS_Lib.Getenv (Path (K .. E - 1));
begin
- Append (Result, Env.all);
- Free (Env);
+ Append (Env.all);
+ OS_Lib.Free (Env);
end;
else
- -- No closing curly bracket, not a variable after all or a
+ -- No terminator character, not a variable after all or a
-- syntax error, ignore it, insert string as-is.
- Append (Result, '$' & Path (K .. E));
+ Append (P); -- Add prefix character
+
+ if T = '}' then -- If we were looking for curly bracket
+ Append ('{'); -- terminator, add the curly bracket
+ end if;
+
+ Append (Path (K .. E));
end if;
else
E := E + 1;
Var_Name : loop
- exit Var_Name when E = Path'Last;
+ exit Var_Name when E > Path'Last;
if Characters.Handling.Is_Letter (Path (E))
or else Characters.Handling.Is_Digit (Path (E))
then
E := E + 1;
else
- E := E - 1;
exit Var_Name;
end if;
end loop Var_Name;
+ E := E - 1;
+
declare
Env : OS_Lib.String_Access := OS_Lib.Getenv (Path (K .. E));
begin
- Append (Result, Env.all);
- Free (Env);
+ Append (Env.all);
+ OS_Lib.Free (Env);
end;
else
-- This is not a variable after all
- Append (Result, '$' & Path (E));
+ Append ('$');
+ Append (Path (E));
end if;
end if;
begin
Read (K);
- return To_String (Result);
+
+ declare
+ Returned_Value : constant String := Result (1 .. Result_Last);
+
+ begin
+ OS_Lib.Free (Result);
+ return Returned_Value;
+ end;
end;
end Expand_Path;
return Base_Name (Path);
end File_Name;
- ----------
- -- Find --
- ----------
+ ---------------------
+ -- Format_Pathname --
+ ---------------------
- procedure Find
- (Root_Directory : Dir_Name_Str;
- File_Pattern : String)
+ function Format_Pathname
+ (Path : Path_Name;
+ Style : Path_Style := System_Default) return String
is
- File_Regexp : constant Regexp.Regexp := Regexp.Compile (File_Pattern);
- Index : Natural := 0;
+ N_Path : String := Path;
+ K : Positive := N_Path'First;
+ Prev_Dirsep : Boolean := False;
- procedure Read_Directory (Directory : Dir_Name_Str);
- -- Open Directory and read all entries. This routine is called
- -- recursively for each sub-directories.
-
- function Make_Pathname (Dir, File : String) return String;
- -- Returns the pathname for File by adding Dir as prefix.
-
- -------------------
- -- Make_Pathname --
- -------------------
-
- function Make_Pathname (Dir, File : String) return String is
- begin
- if Dir (Dir'Last) = '/' or else Dir (Dir'Last) = '\' then
- return Dir & File;
- else
- return Dir & Dir_Separator & File;
+ begin
+ if Dir_Separator = '\'
+ and then Path'Length > 1
+ and then Path (K .. K + 1) = "\\"
+ then
+ if Style = UNIX then
+ N_Path (K .. K + 1) := "//";
end if;
- end Make_Pathname;
-
- --------------------
- -- Read_Directory --
- --------------------
-
- procedure Read_Directory (Directory : Dir_Name_Str) is
- Dir : Dir_Type;
- Buffer : String (1 .. 2_048);
- Last : Natural;
- Quit : Boolean;
- begin
- Open (Dir, Directory);
-
- loop
- Read (Dir, Buffer, Last);
- exit when Last = 0;
+ K := K + 2;
+ end if;
- declare
- Dir_Entry : constant String := Buffer (1 .. Last);
- Pathname : constant String
- := Make_Pathname (Directory, Dir_Entry);
- begin
- if Regexp.Match (Dir_Entry, File_Regexp) then
- Quit := False;
- Index := Index + 1;
-
- begin
- Action (Pathname, Index, Quit);
- exception
- when others =>
- Close (Dir);
- raise;
- end;
-
- exit when Quit;
- end if;
+ for J in K .. Path'Last loop
+ if Strings.Maps.Is_In (Path (J), Dir_Seps) then
+ if not Prev_Dirsep then
+ case Style is
+ when UNIX => N_Path (K) := '/';
+ when DOS => N_Path (K) := '\';
+ when System_Default => N_Path (K) := Dir_Separator;
+ end case;
- -- Recursively call for sub-directories, except for . and ..
+ K := K + 1;
+ end if;
- if not (Dir_Entry = "." or else Dir_Entry = "..")
- and then OS_Lib.Is_Directory (Pathname)
- then
- Read_Directory (Pathname);
- end if;
- end;
- end loop;
+ Prev_Dirsep := True;
- Close (Dir);
- end Read_Directory;
+ else
+ N_Path (K) := Path (J);
+ K := K + 1;
+ Prev_Dirsep := False;
+ end if;
+ end loop;
- begin
- Read_Directory (Root_Directory);
- end Find;
+ return N_Path (N_Path'First .. K - 1);
+ end Format_Pathname;
---------------------
-- Get_Current_Dir --
---------------------
Max_Path : Integer;
- pragma Import (C, Max_Path, "max_path_len");
+ pragma Import (C, Max_Path, "__gnat_max_path_len");
function Get_Current_Dir return Dir_Name_Str is
Current_Dir : String (1 .. Max_Path + 1);
--------------
procedure Make_Dir (Dir_Name : Dir_Name_Str) is
- C_Dir_Name : String := Dir_Name & ASCII.NUL;
+ C_Dir_Name : constant String := Dir_Name & ASCII.NUL;
function mkdir (Dir_Name : String) return Integer;
pragma Import (C, mkdir, "__gnat_mkdir");
end if;
end Make_Dir;
- ------------------------
- -- Normalize_Pathname --
- ------------------------
-
- function Normalize_Pathname
- (Path : Path_Name;
- Style : Path_Style := System_Default)
- return String
- is
- N_Path : String := Path;
- K : Positive := N_Path'First;
- Prev_Dirsep : Boolean := False;
-
- begin
- for J in Path'Range loop
-
- if Strings.Maps.Is_In (Path (J), Dir_Seps) then
- if not Prev_Dirsep then
-
- case Style is
- when UNIX => N_Path (K) := '/';
- when DOS => N_Path (K) := '\';
- when System_Default => N_Path (K) := Dir_Separator;
- end case;
-
- K := K + 1;
- end if;
-
- Prev_Dirsep := True;
-
- else
- N_Path (K) := Path (J);
- K := K + 1;
- Prev_Dirsep := False;
- end if;
- end loop;
-
- return N_Path (N_Path'First .. K - 1);
- end Normalize_Pathname;
-
----------
-- Open --
----------
(Dir : out Dir_Type;
Dir_Name : Dir_Name_Str)
is
- C_File_Name : String := Dir_Name & ASCII.NUL;
-
- function opendir
- (File_Name : String)
- return Dir_Type_Value;
- pragma Import (C, opendir, "opendir");
+ C_File_Name : constant String := Dir_Name & ASCII.NUL;
begin
- Dir := new Dir_Type_Value'(opendir (C_File_Name));
+ Dir := new Dir_Type_Value'(Dir_Type_Value (opendir (C_File_Name)));
if not Is_Open (Dir) then
Free (Dir);
Filename_Addr : Address;
Filename_Len : Integer;
- Buffer : array (0 .. 1024) of Character;
- -- 1024 is the value of FILENAME_MAX in stdio.h
+ Buffer : array (0 .. Filename_Max + 12) of Character;
+ -- 12 is the size of the dirent structure (see dirent.h), without the
+ -- field for the filename.
function readdir_gnat
(Directory : System.Address;
- Buffer : System.Address)
- return System.Address;
+ Buffer : System.Address) return System.Address;
pragma Import (C, readdir_gnat, "__gnat_readdir");
function strlen (S : Address) return Integer;
(Source => Address,
Target => Path_String_Access);
- Path_Access : Path_String_Access := Address_To_Access (Filename_Addr);
+ Path_Access : constant Path_String_Access :=
+ Address_To_Access (Filename_Addr);
begin
for J in Str'First .. Last loop
-- Remove_Dir --
----------------
- procedure Remove_Dir (Dir_Name : Dir_Name_Str) is
- C_Dir_Name : String := Dir_Name & ASCII.NUL;
-
- procedure rmdir (Dir_Name : String);
- pragma Import (C, rmdir, "rmdir");
+ procedure Remove_Dir
+ (Dir_Name : Dir_Name_Str;
+ Recursive : Boolean := False)
+ is
+ C_Dir_Name : constant String := Dir_Name & ASCII.NUL;
+ Current_Dir : constant Dir_Name_Str := Get_Current_Dir;
+ Last : Integer;
+ Str : String (1 .. Filename_Max);
+ Success : Boolean;
+ Working_Dir : Dir_Type;
begin
- rmdir (C_Dir_Name);
- end Remove_Dir;
-
- -----------------------
- -- Wildcard_Iterator --
- -----------------------
-
- procedure Wildcard_Iterator (Path : Path_Name) is
-
- Index : Natural := 0;
-
- procedure Read
- (Directory : String;
- File_Pattern : String;
- Suffix_Pattern : String);
- -- Read entries in Directory and call user's callback if the entry
- -- match File_Pattern and Suffix_Pattern is empty otherwise it will go
- -- down one more directory level by calling Next_Level routine above.
-
- procedure Next_Level
- (Current_Path : String;
- Suffix_Path : String);
- -- Extract next File_Pattern from Suffix_Path and call Read routine
- -- above.
-
- ----------------
- -- Next_Level --
- ----------------
-
- procedure Next_Level
- (Current_Path : String;
- Suffix_Path : String)
- is
- DS : Natural;
- SP : String renames Suffix_Path;
-
- begin
- if SP'Length > 2
- and then SP (SP'First) = '.'
- and then Strings.Maps.Is_In (SP (SP'First + 1), Dir_Seps)
- then
- -- Starting with "./"
-
- DS := Strings.Fixed.Index
- (SP (SP'First + 2 .. SP'Last),
- Dir_Seps);
-
- if DS = 0 then
-
- -- We have "./"
-
- Read (Current_Path & ".", "*", "");
-
- else
- -- We have "./dir"
-
- Read (Current_Path & ".",
- SP (SP'First + 2 .. DS - 1),
- SP (DS .. SP'Last));
- end if;
-
- elsif SP'Length > 3
- and then SP (SP'First .. SP'First + 1) = ".."
- and then Strings.Maps.Is_In (SP (SP'First + 2), Dir_Seps)
- then
- -- Starting with "../"
-
- DS := Strings.Fixed.Index
- (SP (SP'First + 3 .. SP'Last),
- Dir_Seps);
-
- if DS = 0 then
-
- -- We have "../"
-
- Read (Current_Path & "..", "*", "");
+ -- Remove the directory only if it is empty
- else
- -- We have "../dir"
-
- Read (Current_Path & "..",
- SP (SP'First + 4 .. DS - 1),
- SP (DS .. SP'Last));
- end if;
-
- elsif Current_Path = ""
- and then SP'Length > 1
- and then Characters.Handling.Is_Letter (SP (SP'First))
- and then SP (SP'First + 1) = ':'
- then
- -- Starting with "<drive>:"
-
- if SP'Length > 2
- and then Strings.Maps.Is_In (SP (SP'First + 2), Dir_Seps)
- then
- -- Starting with "<drive>:\"
+ if not Recursive then
+ rmdir (C_Dir_Name);
- DS := Strings.Fixed.Index
- (SP (SP'First + 3 .. SP'Last), Dir_Seps);
-
- if DS = 0 then
+ if GNAT.OS_Lib.Is_Directory (Dir_Name) then
+ raise Directory_Error;
+ end if;
- -- Se have "<drive>:\dir"
+ -- Remove directory and all files and directories that it may contain
- Read (SP (SP'First .. SP'First + 1),
- SP (SP'First + 3 .. SP'Last),
- "");
+ else
+ Change_Dir (Dir_Name);
+ Open (Working_Dir, ".");
- else
- -- We have "<drive>:\dir\kkk"
+ loop
+ Read (Working_Dir, Str, Last);
+ exit when Last = 0;
- Read (SP (SP'First .. SP'First + 1),
- SP (SP'First + 3 .. DS - 1),
- SP (DS .. SP'Last));
+ 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;
else
- -- Starting with "<drive>:"
-
- DS := Strings.Fixed.Index
- (SP (SP'First + 2 .. SP'Last), Dir_Seps);
+ GNAT.OS_Lib.Delete_File (Str (1 .. Last), Success);
- if DS = 0 then
-
- -- We have "<drive>:dir"
-
- Read (SP (SP'First .. SP'First + 1),
- SP (SP'First + 2 .. SP'Last),
- "");
-
- else
- -- We have "<drive>:dir/kkk"
-
- Read (SP (SP'First .. SP'First + 1),
- SP (SP'First + 2 .. DS - 1),
- SP (DS .. SP'Last));
+ if not Success then
+ Change_Dir (Current_Dir);
+ raise Directory_Error;
end if;
-
end if;
+ end loop;
- elsif Strings.Maps.Is_In (SP (SP'First), Dir_Seps) then
-
- -- Starting with a /
-
- DS := Strings.Fixed.Index
- (SP (SP'First + 1 .. SP'Last),
- Dir_Seps);
-
- if DS = 0 then
-
- -- We have "/dir"
-
- Read (Current_Path,
- SP (SP'First + 1 .. SP'Last),
- "");
- else
- -- We have "/dir/kkk"
-
- Read (Current_Path,
- SP (SP'First + 1 .. DS - 1),
- SP (DS .. SP'Last));
- end if;
-
- else
- -- Starting with a name
-
- DS := Strings.Fixed.Index (SP, Dir_Seps);
-
- if DS = 0 then
-
- -- We have "dir"
-
- Read (Current_Path & '.',
- SP,
- "");
- else
- -- We have "dir/kkk"
-
- Read (Current_Path & '.',
- SP (SP'First .. DS - 1),
- SP (DS .. SP'Last));
- end if;
-
- end if;
- end Next_Level;
-
- ----------
- -- Read --
- ----------
-
- Quit : Boolean := False;
- -- Global state to be able to exit all recursive calls.
-
- procedure Read
- (Directory : String;
- File_Pattern : String;
- Suffix_Pattern : String)
- is
- File_Regexp : constant Regexp.Regexp :=
- Regexp.Compile (File_Pattern, Glob => True);
- Dir : Dir_Type;
- Buffer : String (1 .. 2_048);
- Last : Natural;
-
- begin
- if OS_Lib.Is_Directory (Directory) then
- Open (Dir, Directory);
-
- Dir_Iterator : loop
- Read (Dir, Buffer, Last);
- exit Dir_Iterator when Last = 0;
-
- declare
- Dir_Entry : constant String := Buffer (1 .. Last);
- Pathname : constant String :=
- Directory & Dir_Separator & Dir_Entry;
- begin
- -- Handle "." and ".." only if explicit use in the
- -- File_Pattern.
-
- if not
- ((Dir_Entry = "." and then File_Pattern /= ".")
- or else
- (Dir_Entry = ".." and then File_Pattern /= ".."))
- then
- if Regexp.Match (Dir_Entry, File_Regexp) then
-
- if Suffix_Pattern = "" then
-
- -- No more matching needed, call user's callback
-
- Index := Index + 1;
-
- begin
- Action (Pathname, Index, Quit);
-
- exception
- when others =>
- Close (Dir);
- raise;
- end;
-
- exit Dir_Iterator when Quit;
-
- else
- -- Down one level
-
- Next_Level
- (Directory & Dir_Separator & Dir_Entry,
- Suffix_Pattern);
- end if;
- end if;
- end if;
- end;
-
- exit Dir_Iterator when Quit;
-
- end loop Dir_Iterator;
-
- Close (Dir);
- end if;
- end Read;
-
- begin
- Next_Level ("", Path);
- end Wildcard_Iterator;
+ Change_Dir (Current_Dir);
+ Close (Working_Dir);
+ Remove_Dir (Dir_Name);
+ end if;
+ end Remove_Dir;
end GNAT.Directory_Operations;
OSDN Git Service
