1 ------------------------------------------------------------------------------
3 -- GNAT RUN-TIME COMPONENTS --
5 -- A D A . D I R E C T O R I E S --
9 -- Copyright (C) 2004 Free Software Foundation, Inc. --
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, 59 Temple Place - Suite 330, Boston, --
20 -- MA 02111-1307, 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
.Directories
.Validity
; use Ada
.Directories
.Validity
;
35 with Ada
.Strings
.Unbounded
; use Ada
.Strings
.Unbounded
;
36 with Ada
.Unchecked_Deallocation
;
38 with GNAT
.Directory_Operations
; use GNAT
.Directory_Operations
;
39 with GNAT
.OS_Lib
; use GNAT
.OS_Lib
;
40 with GNAT
.Regexp
; use GNAT
.Regexp
;
41 -- ??? Ada units cannot depend on GNAT units
45 package body Ada
.Directories
is
47 type Search_Data
is record
48 Is_Valid
: Boolean := False;
49 Name
: Ada
.Strings
.Unbounded
.Unbounded_String
;
53 Entry_Fetched
: Boolean := False;
54 Dir_Entry
: Directory_Entry_Type
;
56 -- Comment required ???
58 Empty_String
: constant String := (1 .. 0 => ASCII
.NUL
);
59 -- Comment required ???
61 procedure Free
is new Ada
.Unchecked_Deallocation
(Search_Data
, Search_Ptr
);
63 function File_Exists
(Name
: String) return Boolean;
64 -- Returns True if the named file exists.
66 procedure Fetch_Next_Entry
(Search
: Search_Type
);
67 -- Get the next entry in a directory, setting Entry_Fetched if successful
68 -- or resetting Is_Valid if not.
74 function Base_Name
(Name
: String) return String is
75 Simple
: constant String := Simple_Name
(Name
);
76 -- Simple'First is guaranteed to be 1
79 -- Look for the last dot in the file name and return the part of the
80 -- file name preceding this last dot. If the first dot is the first
81 -- character of the file name, the base name is the empty string.
83 for Pos
in reverse Simple
'Range loop
84 if Simple
(Pos
) = '.' then
85 return Simple
(1 .. Pos
- 1);
89 -- If there is no dot, return the complete file name
99 (Containing_Directory
: String := "";
101 Extension
: String := "") return String
103 Result
: String (1 .. Containing_Directory
'Length +
104 Name
'Length + Extension
'Length + 2);
108 -- First, deal with the invalid cases
110 if not Is_Valid_Path_Name
(Containing_Directory
) then
114 Extension
'Length = 0 and then (not Is_Valid_Simple_Name
(Name
))
118 elsif Extension
'Length /= 0 and then
119 (not Is_Valid_Simple_Name
(Name
& '.' & Extension
))
123 -- This is not an invalid case. Build the path name.
126 Last
:= Containing_Directory
'Length;
127 Result
(1 .. Last
) := Containing_Directory
;
129 -- Add a directory separator if needed
131 if Result
(Last
) /= Dir_Separator
then
133 Result
(Last
) := Dir_Separator
;
138 Result
(Last
+ 1 .. Last
+ Name
'Length) := Name
;
139 Last
:= Last
+ Name
'Length;
141 -- If extension was specified, add dot followed by this extension
143 if Extension
'Length /= 0 then
145 Result
(Last
) := '.';
146 Result
(Last
+ 1 .. Last
+ Extension
'Length) := Extension
;
147 Last
:= Last
+ Extension
'Length;
150 return Result
(1 .. Last
);
154 --------------------------
155 -- Containing_Directory --
156 --------------------------
158 function Containing_Directory
(Name
: String) return String is
160 -- First, the invalid case
162 if not Is_Valid_Path_Name
(Name
) then
166 -- Get the directory name using GNAT.Directory_Operations.Dir_Name
169 Value
: constant String := Dir_Name
(Path
=> Name
);
170 Result
: String (1 .. Value
'Length);
171 Last
: Natural := Result
'Last;
176 -- Remove any trailing directory separator, except as the first
179 while Last
> 1 and then Result
(Last
) = Dir_Separator
loop
183 -- Special case of current directory, identified by "."
185 if Last
= 1 and then Result
(1) = '.' then
186 return Get_Current_Dir
;
189 return Result
(1 .. Last
);
193 end Containing_Directory
;
200 (Source_Name
: String;
201 Target_Name
: String;
204 pragma Unreferenced
(Form
);
208 -- First, the invalid cases
210 if not Is_Valid_Path_Name
(Source_Name
)
211 or else not Is_Valid_Path_Name
(Target_Name
)
212 or else not Is_Regular_File
(Source_Name
)
216 elsif Is_Directory
(Target_Name
) then
220 -- The implementation uses GNAT.OS_Lib.Copy_File, with parameters
221 -- suitable for all platforms.
224 (Source_Name
, Target_Name
, Success
, Overwrite
, None
);
232 ----------------------
233 -- Create_Directory --
234 ----------------------
236 procedure Create_Directory
237 (New_Directory
: String;
240 pragma Unreferenced
(Form
);
243 -- First, the invalid case
245 if not Is_Valid_Path_Name
(New_Directory
) then
249 -- The implementation uses GNAT.Directory_Operations.Make_Dir
252 Make_Dir
(Dir_Name
=> New_Directory
);
255 when Directory_Error
=>
259 end Create_Directory
;
265 procedure Create_Path
266 (New_Directory
: String;
269 pragma Unreferenced
(Form
);
271 New_Dir
: String (1 .. New_Directory
'Length + 1);
272 Last
: Positive := 1;
275 -- First, the invalid case
277 if not Is_Valid_Path_Name
(New_Directory
) then
281 -- Build New_Dir with a directory separator at the end, so that the
282 -- complete path will be found in the loop below.
284 New_Dir
(1 .. New_Directory
'Length) := New_Directory
;
285 New_Dir
(New_Dir
'Last) := Directory_Separator
;
287 -- Create, if necessary, each directory in the path
289 for J
in 2 .. New_Dir
'Last loop
291 -- Look for the end of an intermediate directory
293 if New_Dir
(J
) /= Dir_Separator
then
296 -- We have found a new intermediate directory each time we find
297 -- a first directory separator.
299 elsif New_Dir
(J
- 1) /= Dir_Separator
then
301 -- No need to create the directory if it already exists
303 if Is_Directory
(New_Dir
(1 .. Last
)) then
306 -- It is an error if a file with such a name already exists
308 elsif Is_Regular_File
(New_Dir
(1 .. Last
)) then
312 -- The implementation uses
313 -- GNAT.Directory_Operations.Make_Dir.
316 Make_Dir
(Dir_Name
=> New_Dir
(1 .. Last
));
319 when Directory_Error
=>
328 -----------------------
329 -- Current_Directory --
330 -----------------------
332 function Current_Directory
return String is
334 -- The implementation uses GNAT.Directory_Operations.Get_Current_Dir
336 Cur
: constant String := Get_Current_Dir
;
339 if Cur
'Length > 1 and then Cur
(Cur
'Last) = Dir_Separator
then
340 return Cur
(1 .. Cur
'Last - 1);
344 end Current_Directory
;
346 ----------------------
347 -- Delete_Directory --
348 ----------------------
350 procedure Delete_Directory
(Directory
: String) is
352 -- First, the invalid cases
354 if not Is_Valid_Path_Name
(Directory
) then
357 elsif not Is_Directory
(Directory
) then
361 -- The implementation uses GNAT.Directory_Operations.Remove_Dir
364 Remove_Dir
(Dir_Name
=> Directory
, Recursive
=> False);
367 when Directory_Error
=>
371 end Delete_Directory
;
377 procedure Delete_File
(Name
: String) is
381 -- First, the invalid cases
383 if not Is_Valid_Path_Name
(Name
) then
386 elsif not Is_Regular_File
(Name
) then
390 -- The implementation uses GNAT.OS_Lib.Delete_File
392 Delete_File
(Name
, Success
);
404 procedure Delete_Tree
(Directory
: String) is
406 -- First, the invalid cases
408 if not Is_Valid_Path_Name
(Directory
) then
411 elsif not Is_Directory
(Directory
) then
415 -- The implementation uses GNAT.Directory_Operations.Remove_Dir
418 Remove_Dir
(Directory
, Recursive
=> True);
421 when Directory_Error
=>
431 function Exists
(Name
: String) return Boolean is
433 -- First, the invalid case
435 if not Is_Valid_Path_Name
(Name
) then
439 -- The implementation is in File_Exists
441 return File_Exists
(Name
);
449 function Extension
(Name
: String) return String is
451 -- First, the invalid case
453 if not Is_Valid_Path_Name
(Name
) then
457 -- Look for first dot that is not followed by a directory separator
459 for Pos
in reverse Name
'Range loop
461 -- If a directory separator is found before a dot, there
464 if Name
(Pos
) = Dir_Separator
then
467 elsif Name
(Pos
) = '.' then
469 -- We found a dot, build the return value with lower bound 1
472 Result
: String (1 .. Name
'Last - Pos
);
474 Result
:= Name
(Pos
+ 1 .. Name
'Last);
476 -- This should be done with a subtype conversion, avoiding
477 -- the unnecessary junk copy ???
482 -- No dot were found, there is no extension
488 ----------------------
489 -- Fetch_Next_Entry --
490 ----------------------
492 procedure Fetch_Next_Entry
(Search
: Search_Type
) is
493 Name
: String (1 .. 255);
496 Kind
: File_Kind
:= Ordinary_File
;
497 -- Initialized to avoid a compilation warning
500 -- Search.Value.Is_Valid is always True when Fetch_Next_Entry is called
503 Read
(Search
.Value
.Dir
, Name
, Last
);
505 -- If no matching entry is found, set Is_Valid to False
508 Search
.Value
.Is_Valid
:= False;
512 -- Check if the entry matches the pattern
514 if Match
(Name
(1 .. Last
), Search
.Value
.Pattern
) then
516 Full_Name
: constant String :=
519 (Search
.Value
.Name
), Name
(1 .. Last
));
520 Found
: Boolean := False;
523 if File_Exists
(Full_Name
) then
525 -- Now check if the file kind matches the filter
527 if Is_Regular_File
(Full_Name
) then
528 if Search
.Value
.Filter
(Ordinary_File
) then
529 Kind
:= Ordinary_File
;
533 elsif Is_Directory
(Full_Name
) then
534 if Search
.Value
.Filter
(Directory
) then
539 elsif Search
.Value
.Filter
(Special_File
) then
540 Kind
:= Special_File
;
544 -- If it does, update Search and return
547 Search
.Value
.Entry_Fetched
:= True;
548 Search
.Value
.Dir_Entry
:=
550 Simple
=> To_Unbounded_String
(Name
(1 .. Last
)),
551 Full
=> To_Unbounded_String
(Full_Name
),
559 end Fetch_Next_Entry
;
565 function File_Exists
(Name
: String) return Boolean is
566 function C_File_Exists
(A
: System
.Address
) return Integer;
567 pragma Import
(C
, C_File_Exists
, "__gnat_file_exists");
569 C_Name
: String (1 .. Name
'Length + 1);
572 C_Name
(1 .. Name
'Length) := Name
;
573 C_Name
(C_Name
'Last) := ASCII
.NUL
;
574 return C_File_Exists
(C_Name
(1)'Address) = 1;
581 procedure Finalize
(Search
: in out Search_Type
) is
583 if Search
.Value
/= null then
585 -- Close the directory, if one is open
587 if Is_Open
(Search
.Value
.Dir
) then
588 Close
(Search
.Value
.Dir
);
599 function Full_Name
(Name
: String) return String is
601 -- First, the invalid case
603 if not Is_Valid_Path_Name
(Name
) then
607 -- Build the return value with lower bound 1
609 -- Use GNAT.OS_Lib.Normalize_Pathname
612 Value
: constant String := Normalize_Pathname
(Name
);
613 Result
: String (1 .. Value
'Length);
617 -- Should use subtype conversion, not junk copy ???
622 function Full_Name
(Directory_Entry
: Directory_Entry_Type
) return String is
624 -- First, the invalid case
626 if not Directory_Entry
.Is_Valid
then
630 -- The value to return has already been computed
632 return To_String
(Directory_Entry
.Full
);
640 procedure Get_Next_Entry
641 (Search
: in out Search_Type
;
642 Directory_Entry
: out Directory_Entry_Type
)
645 -- First, the invalid case
647 if Search
.Value
= null or else not Search
.Value
.Is_Valid
then
651 -- Fetch the next entry, if needed
653 if not Search
.Value
.Entry_Fetched
then
654 Fetch_Next_Entry
(Search
);
657 -- It is an error if no valid entry is found
659 if not Search
.Value
.Is_Valid
then
663 -- Reset Entry_Fatched and return the entry
665 Search
.Value
.Entry_Fetched
:= False;
666 Directory_Entry
:= Search
.Value
.Dir_Entry
;
674 function Kind
(Name
: String) return File_Kind
is
676 -- First, the invalid case
678 if not File_Exists
(Name
) then
681 elsif Is_Regular_File
(Name
) then
682 return Ordinary_File
;
684 elsif Is_Directory
(Name
) then
692 function Kind
(Directory_Entry
: Directory_Entry_Type
) return File_Kind
is
694 -- First, the invalid case
696 if not Directory_Entry
.Is_Valid
then
700 -- The value to return has already be computed
702 return Directory_Entry
.Kind
;
706 -----------------------
707 -- Modification_Time --
708 -----------------------
710 function Modification_Time
(Name
: String) return Ada
.Calendar
.Time
is
716 Minute
: Minute_Type
;
717 Second
: Second_Type
;
720 -- First, the invalid cases
723 if not (Is_Regular_File
(Name
) or else Is_Directory
(Name
)) then
727 Date
:= File_Time_Stamp
(Name
);
728 -- ???? We need to be able to convert OS_Time to Ada.Calendar.Time
729 -- For now, use the component of the OS_Time to create the
730 -- Calendar.Time value.
732 GM_Split
(Date
, Year
, Month
, Day
, Hour
, Minute
, Second
);
734 return Ada
.Calendar
.Time_Of
735 (Year
, Month
, Day
, Duration (Second
+ 60 * (Minute
+ 60 * Hour
)));
737 end Modification_Time
;
739 function Modification_Time
740 (Directory_Entry
: Directory_Entry_Type
) return Ada
.Calendar
.Time
743 -- First, the invalid case
745 if not Directory_Entry
.Is_Valid
then
749 -- The value to return has already be computed
751 return Modification_Time
(To_String
(Directory_Entry
.Full
));
753 end Modification_Time
;
759 function More_Entries
(Search
: Search_Type
) return Boolean is
761 if Search
.Value
= null then
764 elsif Search
.Value
.Is_Valid
then
766 -- Fetch the next entry, if needed
768 if not Search
.Value
.Entry_Fetched
then
769 Fetch_Next_Entry
(Search
);
773 return Search
.Value
.Is_Valid
;
780 procedure Rename
(Old_Name
, New_Name
: String) is
784 -- First, the invalid cases
786 if not Is_Valid_Path_Name
(Old_Name
)
787 or else not Is_Valid_Path_Name
(New_Name
)
788 or else (not Is_Regular_File
(Old_Name
)
789 and then not Is_Directory
(Old_Name
))
793 elsif Is_Regular_File
(New_Name
) or Is_Directory
(New_Name
) then
797 -- The implementation uses GNAT.OS_Lib.Rename_File
799 Rename_File
(Old_Name
, New_Name
, Success
);
811 procedure Set_Directory
(Directory
: String) is
813 -- The implementation uses GNAT.Directory_Operations.Change_Dir
815 Change_Dir
(Dir_Name
=> Directory
);
818 when Directory_Error
=>
826 function Simple_Name
(Name
: String) return String is
828 -- First, the invalid case
830 if not Is_Valid_Path_Name
(Name
) then
834 -- Build the value to return with lower bound 1
836 -- The implementation uses GNAT.Directory_Operations.Base_Name
839 Value
: constant String :=
840 GNAT
.Directory_Operations
.Base_Name
(Name
);
841 Result
: String (1 .. Value
'Length);
845 -- Should use subtype conversion instead of junk copy ???
851 (Directory_Entry
: Directory_Entry_Type
) return String
854 -- First, the invalid case
856 if not Directory_Entry
.Is_Valid
then
860 -- The value to return has already be computed
862 return To_String
(Directory_Entry
.Simple
);
870 function Size
(Name
: String) return File_Size
is
871 C_Name
: String (1 .. Name
'Length + 1);
873 function C_Size
(Name
: System
.Address
) return Long_Integer;
874 pragma Import
(C
, C_Size
, "__gnat_named_file_length");
877 -- First, the invalid case
879 if not Is_Regular_File
(Name
) then
883 C_Name
(1 .. Name
'Length) := Name
;
884 C_Name
(C_Name
'Last) := ASCII
.NUL
;
885 return File_Size
(C_Size
(C_Name
'Address));
889 function Size
(Directory_Entry
: Directory_Entry_Type
) return File_Size
is
891 -- First, the invalid case
893 if not Directory_Entry
.Is_Valid
then
897 -- The value to return has already be computed
899 return Size
(To_String
(Directory_Entry
.Full
));
907 procedure Start_Search
908 (Search
: in out Search_Type
;
911 Filter
: Filter_Type
:= (others => True))
914 -- First, the invalid case
916 if not Is_Directory
(Directory
) then
920 -- If needed, finalize Search
924 -- Allocate the default data
926 Search
.Value
:= new Search_Data
;
931 Search
.Value
.Pattern
:= Compile
(Pattern
, Glob
=> True);
934 when Error_In_Regexp
=>
938 -- Initialize some Search components
940 Search
.Value
.Filter
:= Filter
;
941 Search
.Value
.Name
:= To_Unbounded_String
(Full_Name
(Directory
));
942 Open
(Search
.Value
.Dir
, Directory
);
943 Search
.Value
.Is_Valid
:= True;