1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
5 -- G N A T . D I R E C T O R Y _ O P E R A T I O N S --
9 -- Copyright (C) 1998-2006, AdaCore --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 2, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING. If not, write --
19 -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
20 -- Boston, MA 02110-1301, USA. --
22 -- As a special exception, if other files instantiate generics from this --
23 -- unit, or you link this unit with other files to produce an executable, --
24 -- this unit does not by itself cause the resulting executable to be --
25 -- covered by the GNU General Public License. This exception does not --
26 -- however invalidate any other reasons why the executable file might be --
27 -- covered by the GNU Public License. --
29 -- GNAT was originally developed by the GNAT team at New York University. --
30 -- Extensive contributions were provided by Ada Core Technologies Inc. --
32 ------------------------------------------------------------------------------
34 with Ada
.Characters
.Handling
;
35 with Ada
.Strings
.Fixed
;
37 with Unchecked_Deallocation
;
38 with Unchecked_Conversion
;
40 with System
; use System
;
41 with System
.CRTL
; use System
.CRTL
;
45 package body GNAT
.Directory_Operations
is
49 type Dir_Type_Value
is new System
.Address
;
50 -- This is the low-level address directory structure as returned by the C
53 Filename_Max
: constant Integer := 1024;
54 -- 1024 is the value of FILENAME_MAX in stdio.h
57 Unchecked_Deallocation
(Dir_Type_Value
, Dir_Type
);
65 Suffix
: String := "") return String
67 function Get_File_Names_Case_Sensitive
return Integer;
69 (C
, Get_File_Names_Case_Sensitive
,
70 "__gnat_get_file_names_case_sensitive");
72 Case_Sensitive_File_Name
: constant Boolean :=
73 Get_File_Names_Case_Sensitive
= 1;
77 Suffix
: String := "") return String;
78 -- This function does the job. The only difference between Basename
79 -- and Base_Name (the parent function) is that the former is case
80 -- sensitive, while the latter is not. Path and Suffix are adjusted
81 -- appropriately before calling Basename under platforms where the
82 -- file system is not case sensitive.
90 Suffix
: String := "") return String
92 Cut_Start
: Natural :=
94 (Path
, Dir_Seps
, Going
=> Strings
.Backward
);
98 -- Cut_Start point to the first basename character
100 if Cut_Start
= 0 then
101 Cut_Start
:= Path
'First;
104 Cut_Start
:= Cut_Start
+ 1;
107 -- Cut_End point to the last basename character
109 Cut_End
:= Path
'Last;
111 -- If basename ends with Suffix, adjust Cut_End
114 and then Path
(Path
'Last - Suffix
'Length + 1 .. Cut_End
) = Suffix
116 Cut_End
:= Path
'Last - Suffix
'Length;
119 Check_For_Standard_Dirs
: declare
120 Offset
: constant Integer := Path
'First - Base_Name
.Path
'First;
121 BN
: constant String :=
122 Base_Name
.Path
(Cut_Start
- Offset
.. Cut_End
- Offset
);
123 -- Here we use Base_Name.Path to keep the original casing
125 Has_Drive_Letter
: constant Boolean :=
126 OS_Lib
.Path_Separator
/= ':';
127 -- If Path separator is not ':' then we are on a DOS based OS
128 -- where this character is used as a drive letter separator.
131 if BN
= "." or else BN
= ".." then
134 elsif Has_Drive_Letter
135 and then BN
'Length > 2
136 and then Characters
.Handling
.Is_Letter
(BN
(BN
'First))
137 and then BN
(BN
'First + 1) = ':'
139 -- We have a DOS drive letter prefix, remove it
141 return BN
(BN
'First + 2 .. BN
'Last);
146 end Check_For_Standard_Dirs
;
149 -- Start processing for Base_Name
152 if Path
'Length <= Suffix
'Length then
156 if Case_Sensitive_File_Name
then
157 return Basename
(Path
, Suffix
);
160 (Characters
.Handling
.To_Lower
(Path
),
161 Characters
.Handling
.To_Lower
(Suffix
));
169 procedure Change_Dir
(Dir_Name
: Dir_Name_Str
) is
170 C_Dir_Name
: constant String := Dir_Name
& ASCII
.NUL
;
172 function chdir
(Dir_Name
: String) return Integer;
173 pragma Import
(C
, chdir
, "chdir");
176 if chdir
(C_Dir_Name
) /= 0 then
177 raise Directory_Error
;
185 procedure Close
(Dir
: in out Dir_Type
) is
187 pragma Warnings
(Off
, Discard
);
189 function closedir
(directory
: DIRs
) return Integer;
190 pragma Import
(C
, closedir
, "__gnat_closedir");
193 if not Is_Open
(Dir
) then
194 raise Directory_Error
;
197 Discard
:= closedir
(DIRs
(Dir
.all));
205 function Dir_Name
(Path
: Path_Name
) return Dir_Name_Str
is
206 Last_DS
: constant Natural :=
208 (Path
, Dir_Seps
, Going
=> Strings
.Backward
);
213 -- There is no directory separator, returns current working directory
215 return "." & Dir_Separator
;
218 return Path
(Path
'First .. Last_DS
);
228 Mode
: Environment_Style
:= System_Default
) return Path_Name
230 Environment_Variable_Char
: Character;
231 pragma Import
(C
, Environment_Variable_Char
, "__gnat_environment_char");
233 Result
: OS_Lib
.String_Access
:= new String (1 .. 200);
234 Result_Last
: Natural := 0;
236 procedure Append
(C
: Character);
237 procedure Append
(S
: String);
240 procedure Double_Result_Size
;
241 -- Reallocate Result, doubling its size
243 function Is_Var_Prefix
(C
: Character) return Boolean;
244 pragma Inline
(Is_Var_Prefix
);
246 procedure Read
(K
: in out Positive);
247 -- Update Result while reading current Path starting at position K. If
248 -- a variable is found, call Var below.
250 procedure Var
(K
: in out Positive);
251 -- Translate variable name starting at position K with the associated
252 -- environment value.
258 procedure Append
(C
: Character) is
260 if Result_Last
= Result
'Last then
264 Result_Last
:= Result_Last
+ 1;
265 Result
(Result_Last
) := C
;
268 procedure Append
(S
: String) is
270 while Result_Last
+ S
'Length - 1 > Result
'Last loop
274 Result
(Result_Last
+ 1 .. Result_Last
+ S
'Length) := S
;
275 Result_Last
:= Result_Last
+ S
'Length;
278 ------------------------
279 -- Double_Result_Size --
280 ------------------------
282 procedure Double_Result_Size
is
283 New_Result
: constant OS_Lib
.String_Access
:=
284 new String (1 .. 2 * Result
'Last);
286 New_Result
(1 .. Result_Last
) := Result
(1 .. Result_Last
);
287 OS_Lib
.Free
(Result
);
288 Result
:= New_Result
;
289 end Double_Result_Size
;
295 function Is_Var_Prefix
(C
: Character) return Boolean is
297 return (C
= Environment_Variable_Char
and then Mode
= System_Default
)
299 (C
= '$' and then (Mode
= UNIX
or else Mode
= Both
))
301 (C
= '%' and then (Mode
= DOS
or else Mode
= Both
));
308 procedure Read
(K
: in out Positive) is
312 For_All_Characters
: loop
313 if Is_Var_Prefix
(Path
(K
)) then
316 -- Could be a variable
318 if K
< Path
'Last then
319 if Path
(K
+ 1) = P
then
321 -- Not a variable after all, this is a double $ or %,
322 -- just insert one in the result string.
328 -- Let's parse the variable
334 -- We have an ending $ or % sign
340 -- This is a standard character, just add it to the result
345 -- Skip to next character
349 exit For_All_Characters
when K
> Path
'Last;
350 end loop For_All_Characters
;
357 procedure Var
(K
: in out Positive) is
358 P
: constant Character := Path
(K
);
365 if P
= '%' or else Path
(K
) = '{' then
367 -- Set terminator character
376 -- Look for terminator character, k point to the first character
377 -- for the variable name.
383 exit when Path
(E
) = T
or else E
= Path
'Last;
388 -- OK found, translate with environment value
391 Env
: OS_Lib
.String_Access
:=
392 OS_Lib
.Getenv
(Path
(K
.. E
- 1));
400 -- No terminator character, not a variable after all or a
401 -- syntax error, ignore it, insert string as-is.
403 Append
(P
); -- Add prefix character
405 if T
= '}' then -- If we were looking for curly bracket
406 Append
('{'); -- terminator, add the curly bracket
409 Append
(Path
(K
.. E
));
413 -- The variable name is everything from current position to first
414 -- non letter/digit character.
418 -- Check that first chartacter is a letter
420 if Characters
.Handling
.Is_Letter
(Path
(E
)) then
424 exit Var_Name
when E
> Path
'Last;
426 if Characters
.Handling
.Is_Letter
(Path
(E
))
427 or else Characters
.Handling
.Is_Digit
(Path
(E
))
438 Env
: OS_Lib
.String_Access
:= OS_Lib
.Getenv
(Path
(K
.. E
));
446 -- This is not a variable after all
457 -- Start of processing for Expand_Path
461 K
: Positive := Path
'First;
467 Returned_Value
: constant String := Result
(1 .. Result_Last
);
470 OS_Lib
.Free
(Result
);
471 return Returned_Value
;
480 function File_Extension
(Path
: Path_Name
) return String is
483 (Path
, Dir_Seps
, Going
=> Strings
.Backward
);
492 Dot
:= Strings
.Fixed
.Index
(Path
(First
.. Path
'Last),
494 Going
=> Strings
.Backward
);
496 if Dot
= 0 or else Dot
= Path
'Last then
499 return Path
(Dot
.. Path
'Last);
507 function File_Name
(Path
: Path_Name
) return String is
509 return Base_Name
(Path
);
512 ---------------------
513 -- Format_Pathname --
514 ---------------------
516 function Format_Pathname
518 Style
: Path_Style
:= System_Default
) return String
520 N_Path
: String := Path
;
521 K
: Positive := N_Path
'First;
522 Prev_Dirsep
: Boolean := False;
525 if Dir_Separator
= '\'
526 and then Path
'Length > 1
527 and then Path
(K
.. K
+ 1) = "\\"
530 N_Path
(K
.. K
+ 1) := "//";
536 for J
in K
.. Path
'Last loop
537 if Strings
.Maps
.Is_In
(Path
(J
), Dir_Seps
) then
538 if not Prev_Dirsep
then
540 when UNIX
=> N_Path
(K
) := '/';
541 when DOS
=> N_Path
(K
) := '\';
542 when System_Default
=> N_Path
(K
) := Dir_Separator
;
551 N_Path
(K
) := Path
(J
);
553 Prev_Dirsep
:= False;
557 return N_Path
(N_Path
'First .. K
- 1);
560 ---------------------
561 -- Get_Current_Dir --
562 ---------------------
565 pragma Import
(C
, Max_Path
, "__gnat_max_path_len");
567 function Get_Current_Dir
return Dir_Name_Str
is
568 Current_Dir
: String (1 .. Max_Path
+ 1);
571 Get_Current_Dir
(Current_Dir
, Last
);
572 return Current_Dir
(1 .. Last
);
575 procedure Get_Current_Dir
(Dir
: out Dir_Name_Str
; Last
: out Natural) is
576 Path_Len
: Natural := Max_Path
;
577 Buffer
: String (Dir
'First .. Dir
'First + Max_Path
+ 1);
579 procedure Local_Get_Current_Dir
580 (Dir
: System
.Address
;
581 Length
: System
.Address
);
582 pragma Import
(C
, Local_Get_Current_Dir
, "__gnat_get_current_dir");
585 Local_Get_Current_Dir
(Buffer
'Address, Path_Len
'Address);
587 if Dir
'Length > Path_Len
then
588 Last
:= Dir
'First + Path_Len
- 1;
593 Dir
(Buffer
'First .. Last
) := Buffer
(Buffer
'First .. Last
);
600 function Is_Open
(Dir
: Dir_Type
) return Boolean is
602 return Dir
/= Null_Dir
603 and then System
.Address
(Dir
.all) /= System
.Null_Address
;
610 procedure Make_Dir
(Dir_Name
: Dir_Name_Str
) is
611 C_Dir_Name
: constant String := Dir_Name
& ASCII
.NUL
;
613 function mkdir
(Dir_Name
: String) return Integer;
614 pragma Import
(C
, mkdir
, "__gnat_mkdir");
617 if mkdir
(C_Dir_Name
) /= 0 then
618 raise Directory_Error
;
628 Dir_Name
: Dir_Name_Str
)
630 function opendir
(file_name
: String) return DIRs
;
631 pragma Import
(C
, opendir
, "__gnat_opendir");
633 C_File_Name
: constant String := Dir_Name
& ASCII
.NUL
;
636 Dir
:= new Dir_Type_Value
'(Dir_Type_Value (opendir (C_File_Name)));
638 if not Is_Open (Dir) then
641 raise Directory_Error;
650 (Dir : in out Dir_Type;
654 Filename_Addr : Address;
655 Filename_Len : aliased Integer;
657 Buffer : array (0 .. Filename_Max + 12) of Character;
658 -- 12 is the size of the dirent structure (see dirent.h), without the
659 -- field for the filename.
661 function readdir_gnat
662 (Directory : System.Address;
663 Buffer : System.Address;
664 Last : access Integer) return System.Address;
665 pragma Import (C, readdir_gnat, "__gnat_readdir");
668 if not Is_Open (Dir) then
669 raise Directory_Error;
674 (System.Address (Dir.all), Buffer'Address, Filename_Len'Access);
676 if Filename_Addr = System.Null_Address then
681 if Str'Length > Filename_Len then
682 Last := Str'First + Filename_Len - 1;
688 subtype Path_String is String (1 .. Filename_Len);
689 type Path_String_Access is access Path_String;
691 function Address_To_Access is new
694 Target => Path_String_Access);
696 Path_Access : constant Path_String_Access :=
697 Address_To_Access (Filename_Addr);
700 for J in Str'First .. Last loop
701 Str (J) := Path_Access (J - Str'First + 1);
706 -------------------------
707 -- Read_Is_Thread_Sage --
708 -------------------------
710 function Read_Is_Thread_Safe return Boolean is
711 function readdir_is_thread_safe return Integer;
713 (C, readdir_is_thread_safe, "__gnat_readdir_is_thread_safe");
715 return (readdir_is_thread_safe /= 0);
716 end Read_Is_Thread_Safe;
723 (Dir_Name : Dir_Name_Str;
724 Recursive : Boolean := False)
726 C_Dir_Name : constant String := Dir_Name & ASCII.NUL;
727 Current_Dir : constant Dir_Name_Str := Get_Current_Dir;
729 Str : String (1 .. Filename_Max);
731 Working_Dir : Dir_Type;
734 -- Remove the directory only if it is empty
736 if not Recursive then
739 if GNAT.OS_Lib.Is_Directory (Dir_Name) then
740 raise Directory_Error;
743 -- Remove directory and all files and directories that it may contain
746 Change_Dir (Dir_Name);
747 Open (Working_Dir, ".");
750 Read (Working_Dir, Str, Last);
753 if GNAT.OS_Lib.Is_Directory (Str (1 .. Last)) then
754 if Str (1 .. Last) /= "." and then Str (1 .. Last) /= ".." then
755 Remove_Dir (Str (1 .. Last), True);
756 Remove_Dir (Str (1 .. Last));
760 GNAT.OS_Lib.Delete_File (Str (1 .. Last), Success);
763 Change_Dir (Current_Dir);
764 raise Directory_Error;
769 Change_Dir (Current_Dir);
771 Remove_Dir (Dir_Name);
775 end GNAT.Directory_Operations;