-- --
-- B o d y --
-- --
--- 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.Maps;
+
with Unchecked_Deallocation;
with Unchecked_Conversion;
-with System; use System;
+
+with System; use System;
+with System.CRTL; use System.CRTL;
with GNAT.OS_Lib;
-- 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);
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
+ 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 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
-- a variable is found, call Var below.
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 ('$');
+ 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 ('$');
+ Append (P);
end if;
else
---------
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 (Env.all);
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 ('$');
+ 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;
function Format_Pathname
(Path : Path_Name;
- Style : Path_Style := System_Default)
- return String
+ Style : Path_Style := System_Default) return String
is
- N_Path : String := Path;
- K : Positive := N_Path'First;
- Prev_Dirsep : Boolean := False;
+ N_Path : String := Path;
+ K : Positive := N_Path'First;
+ Prev_Dirsep : Boolean := False;
begin
- for J in Path'Range loop
+ 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;
+
+ K := K + 2;
+ 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
--------------
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");
(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);
+ -- 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
+ raise Directory_Error;
+ end if;
+
+ -- Remove directory and all files and directories that it may contain
+
+ else
+ Change_Dir (Dir_Name);
+ Open (Working_Dir, ".");
+
+ loop
+ Read (Working_Dir, Str, Last);
+ exit when Last = 0;
+
+ 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
+ GNAT.OS_Lib.Delete_File (Str (1 .. Last), Success);
+
+ if not Success then
+ Change_Dir (Current_Dir);
+ raise Directory_Error;
+ end if;
+ end if;
+ end loop;
+
+ Change_Dir (Current_Dir);
+ Close (Working_Dir);
+ Remove_Dir (Dir_Name);
+ end if;
end Remove_Dir;
end GNAT.Directory_Operations;
OSDN Git Service
