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-2005 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;
37 with Ada.Characters.Handling; use Ada.Characters.Handling;
39 with GNAT.Directory_Operations; use GNAT.Directory_Operations;
40 with GNAT.OS_Lib; use GNAT.OS_Lib;
41 with GNAT.Regexp; use GNAT.Regexp;
42 -- ??? Ada units should not depend on GNAT units
46 package body Ada.Directories is
48 type Search_Data is record
49 Is_Valid : Boolean := False;
50 Name : Ada.Strings.Unbounded.Unbounded_String;
54 Entry_Fetched : Boolean := False;
55 Dir_Entry : Directory_Entry_Type;
57 -- Comment required ???
59 Empty_String : constant String := (1 .. 0 => ASCII.NUL);
60 -- Comment required ???
62 procedure Free is new Ada.Unchecked_Deallocation (Search_Data, Search_Ptr);
64 function File_Exists (Name : String) return Boolean;
65 -- Returns True if the named file exists.
67 procedure Fetch_Next_Entry (Search : Search_Type);
68 -- Get the next entry in a directory, setting Entry_Fetched if successful
69 -- or resetting Is_Valid if not.
71 procedure To_Lower_If_Case_Insensitive (S : in out String);
72 -- Put S in lower case if file and path names are case-insensitive
78 function Base_Name (Name : String) return String is
79 Simple : String := Simple_Name (Name);
80 -- Simple'First is guaranteed to be 1
83 To_Lower_If_Case_Insensitive (Simple);
85 -- Look for the last dot in the file name and return the part of the
86 -- file name preceding this last dot. If the first dot is the first
87 -- character of the file name, the base name is the empty string.
89 for Pos in reverse Simple'Range loop
90 if Simple (Pos) = '.' then
91 return Simple (1 .. Pos - 1);
95 -- If there is no dot, return the complete file name
105 (Containing_Directory : String := "";
107 Extension : String := "") return String
109 Result : String (1 .. Containing_Directory'Length +
110 Name'Length + Extension'Length + 2);
114 -- First, deal with the invalid cases
116 if not Is_Valid_Path_Name (Containing_Directory) then
120 Extension'Length = 0 and then (not Is_Valid_Simple_Name (Name))
124 elsif Extension'Length /= 0 and then
125 (not Is_Valid_Simple_Name (Name & '.' & Extension))
129 -- This is not an invalid case. Build the path name.
132 Last := Containing_Directory'Length;
133 Result (1 .. Last) := Containing_Directory;
135 -- Add a directory separator if needed
137 if Result (Last) /= Dir_Separator then
139 Result (Last) := Dir_Separator;
144 Result (Last + 1 .. Last + Name'Length) := Name;
145 Last := Last + Name'Length;
147 -- If extension was specified, add dot followed by this extension
149 if Extension'Length /= 0 then
151 Result (Last) := '.';
152 Result (Last + 1 .. Last + Extension'Length) := Extension;
153 Last := Last + Extension'Length;
156 To_Lower_If_Case_Insensitive (Result (1 .. Last));
157 return Result (1 .. Last);
161 --------------------------
162 -- Containing_Directory --
163 --------------------------
165 function Containing_Directory (Name : String) return String is
167 -- First, the invalid case
169 if not Is_Valid_Path_Name (Name) then
173 -- Get the directory name using GNAT.Directory_Operations.Dir_Name
176 Value : constant String := Dir_Name (Path => Name);
177 Result : String (1 .. Value'Length);
178 Last : Natural := Result'Last;
183 -- Remove any trailing directory separator, except as the first
186 while Last > 1 and then Result (Last) = Dir_Separator loop
190 -- Special case of current directory, identified by "."
192 if Last = 1 and then Result (1) = '.' then
193 return Get_Current_Dir;
196 To_Lower_If_Case_Insensitive (Result (1 .. Last));
197 return Result (1 .. Last);
201 end Containing_Directory;
208 (Source_Name : String;
209 Target_Name : String;
212 pragma Unreferenced (Form);
216 -- First, the invalid cases
218 if not Is_Valid_Path_Name (Source_Name)
219 or else not Is_Valid_Path_Name (Target_Name)
220 or else not Is_Regular_File (Source_Name)
224 elsif Is_Directory (Target_Name) then
228 -- The implementation uses GNAT.OS_Lib.Copy_File, with parameters
229 -- suitable for all platforms.
232 (Source_Name, Target_Name, Success, Overwrite, None);
240 ----------------------
241 -- Create_Directory --
242 ----------------------
244 procedure Create_Directory
245 (New_Directory : String;
248 pragma Unreferenced (Form);
251 -- First, the invalid case
253 if not Is_Valid_Path_Name (New_Directory) then
257 -- The implementation uses GNAT.Directory_Operations.Make_Dir
260 Make_Dir (Dir_Name => New_Directory);
263 when Directory_Error =>
267 end Create_Directory;
273 procedure Create_Path
274 (New_Directory : String;
277 pragma Unreferenced (Form);
279 New_Dir : String (1 .. New_Directory'Length + 1);
280 Last : Positive := 1;
283 -- First, the invalid case
285 if not Is_Valid_Path_Name (New_Directory) then
289 -- Build New_Dir with a directory separator at the end, so that the
290 -- complete path will be found in the loop below.
292 New_Dir (1 .. New_Directory'Length) := New_Directory;
293 New_Dir (New_Dir'Last) := Directory_Separator;
295 -- Create, if necessary, each directory in the path
297 for J in 2 .. New_Dir'Last loop
299 -- Look for the end of an intermediate directory
301 if New_Dir (J) /= Dir_Separator then
304 -- We have found a new intermediate directory each time we find
305 -- a first directory separator.
307 elsif New_Dir (J - 1) /= Dir_Separator then
309 -- No need to create the directory if it already exists
311 if Is_Directory (New_Dir (1 .. Last)) then
314 -- It is an error if a file with such a name already exists
316 elsif Is_Regular_File (New_Dir (1 .. Last)) then
320 -- The implementation uses
321 -- GNAT.Directory_Operations.Make_Dir.
324 Make_Dir (Dir_Name => New_Dir (1 .. Last));
327 when Directory_Error =>
336 -----------------------
337 -- Current_Directory --
338 -----------------------
340 function Current_Directory return String is
342 -- The implementation uses GNAT.Directory_Operations.Get_Current_Dir
344 Cur : String := Normalize_Pathname (Get_Current_Dir);
347 To_Lower_If_Case_Insensitive (Cur);
349 if Cur'Length > 1 and then Cur (Cur'Last) = Dir_Separator then
350 return Cur (1 .. Cur'Last - 1);
354 end Current_Directory;
356 ----------------------
357 -- Delete_Directory --
358 ----------------------
360 procedure Delete_Directory (Directory : String) is
362 -- First, the invalid cases
364 if not Is_Valid_Path_Name (Directory) then
367 elsif not Is_Directory (Directory) then
371 -- The implementation uses GNAT.Directory_Operations.Remove_Dir
374 Remove_Dir (Dir_Name => Directory, Recursive => False);
377 when Directory_Error =>
381 end Delete_Directory;
387 procedure Delete_File (Name : String) is
391 -- First, the invalid cases
393 if not Is_Valid_Path_Name (Name) then
396 elsif not Is_Regular_File (Name) then
400 -- The implementation uses GNAT.OS_Lib.Delete_File
402 Delete_File (Name, Success);
414 procedure Delete_Tree (Directory : String) is
416 -- First, the invalid cases
418 if not Is_Valid_Path_Name (Directory) then
421 elsif not Is_Directory (Directory) then
425 -- The implementation uses GNAT.Directory_Operations.Remove_Dir
428 Remove_Dir (Directory, Recursive => True);
431 when Directory_Error =>
441 function Exists (Name : String) return Boolean is
443 -- First, the invalid case
445 if not Is_Valid_Path_Name (Name) then
449 -- The implementation is in File_Exists
451 return File_Exists (Name);
459 function Extension (Name : String) return String is
461 -- First, the invalid case
463 if not Is_Valid_Path_Name (Name) then
467 -- Look for first dot that is not followed by a directory separator
469 for Pos in reverse Name'Range loop
471 -- If a directory separator is found before a dot, there
474 if Name (Pos) = Dir_Separator then
477 elsif Name (Pos) = '.' then
479 -- We found a dot, build the return value with lower bound 1
482 Result : String (1 .. Name'Last - Pos);
484 Result := Name (Pos + 1 .. Name'Last);
486 -- This should be done with a subtype conversion, avoiding
487 -- the unnecessary junk copy ???
492 -- No dot were found, there is no extension
498 ----------------------
499 -- Fetch_Next_Entry --
500 ----------------------
502 procedure Fetch_Next_Entry (Search : Search_Type) is
503 Name : String (1 .. 255);
506 Kind : File_Kind := Ordinary_File;
507 -- Initialized to avoid a compilation warning
510 -- Search.Value.Is_Valid is always True when Fetch_Next_Entry is called
513 Read (Search.Value.Dir, Name, Last);
515 -- If no matching entry is found, set Is_Valid to False
518 Search.Value.Is_Valid := False;
522 -- Check if the entry matches the pattern
524 if Match (Name (1 .. Last), Search.Value.Pattern) then
526 Full_Name : constant String :=
529 (Search.Value.Name), Name (1 .. Last));
530 Found : Boolean := False;
533 if File_Exists (Full_Name) then
535 -- Now check if the file kind matches the filter
537 if Is_Regular_File (Full_Name) then
538 if Search.Value.Filter (Ordinary_File) then
539 Kind := Ordinary_File;
543 elsif Is_Directory (Full_Name) then
544 if Search.Value.Filter (Directory) then
549 elsif Search.Value.Filter (Special_File) then
550 Kind := Special_File;
554 -- If it does, update Search and return
557 Search.Value.Entry_Fetched := True;
558 Search.Value.Dir_Entry :=
560 Simple => To_Unbounded_String (Name (1 .. Last)),
561 Full => To_Unbounded_String (Full_Name),
569 end Fetch_Next_Entry;
575 function File_Exists (Name : String) return Boolean is
576 function C_File_Exists (A : System.Address) return Integer;
577 pragma Import (C, C_File_Exists, "__gnat_file_exists");
579 C_Name : String (1 .. Name'Length + 1);
582 C_Name (1 .. Name'Length) := Name;
583 C_Name (C_Name'Last) := ASCII.NUL;
584 return C_File_Exists (C_Name (1)'Address) = 1;
591 procedure Finalize (Search : in out Search_Type) is
593 if Search.Value /= null then
595 -- Close the directory, if one is open
597 if Is_Open (Search.Value.Dir) then
598 Close (Search.Value.Dir);
609 function Full_Name (Name : String) return String is
611 -- First, the invalid case
613 if not Is_Valid_Path_Name (Name) then
617 -- Build the return value with lower bound 1
619 -- Use GNAT.OS_Lib.Normalize_Pathname
622 Value : String := Normalize_Pathname (Name);
623 subtype Result is String (1 .. Value'Length);
625 To_Lower_If_Case_Insensitive (Value);
626 return Result (Value);
631 function Full_Name (Directory_Entry : Directory_Entry_Type) return String is
633 -- First, the invalid case
635 if not Directory_Entry.Is_Valid then
639 -- The value to return has already been computed
641 return To_String (Directory_Entry.Full);
649 procedure Get_Next_Entry
650 (Search : in out Search_Type;
651 Directory_Entry : out Directory_Entry_Type)
654 -- First, the invalid case
656 if Search.Value = null or else not Search.Value.Is_Valid then
660 -- Fetch the next entry, if needed
662 if not Search.Value.Entry_Fetched then
663 Fetch_Next_Entry (Search);
666 -- It is an error if no valid entry is found
668 if not Search.Value.Is_Valid then
672 -- Reset Entry_Fatched and return the entry
674 Search.Value.Entry_Fetched := False;
675 Directory_Entry := Search.Value.Dir_Entry;
683 function Kind (Name : String) return File_Kind is
685 -- First, the invalid case
687 if not File_Exists (Name) then
690 elsif Is_Regular_File (Name) then
691 return Ordinary_File;
693 elsif Is_Directory (Name) then
701 function Kind (Directory_Entry : Directory_Entry_Type) return File_Kind is
703 -- First, the invalid case
705 if not Directory_Entry.Is_Valid then
709 -- The value to return has already be computed
711 return Directory_Entry.Kind;
715 -----------------------
716 -- Modification_Time --
717 -----------------------
719 function Modification_Time (Name : String) return Ada.Calendar.Time is
725 Minute : Minute_Type;
726 Second : Second_Type;
729 -- First, the invalid cases
731 if not (Is_Regular_File (Name) or else Is_Directory (Name)) then
735 Date := File_Time_Stamp (Name);
736 -- ???? We need to be able to convert OS_Time to Ada.Calendar.Time
737 -- For now, use the component of the OS_Time to create the
738 -- Calendar.Time value.
740 GM_Split (Date, Year, Month, Day, Hour, Minute, Second);
742 return Ada.Calendar.Time_Of
743 (Year, Month, Day, Duration (Second + 60 * (Minute + 60 * Hour)));
745 end Modification_Time;
747 function Modification_Time
748 (Directory_Entry : Directory_Entry_Type) return Ada.Calendar.Time
751 -- First, the invalid case
753 if not Directory_Entry.Is_Valid then
757 -- The value to return has already be computed
759 return Modification_Time (To_String (Directory_Entry.Full));
761 end Modification_Time;
767 function More_Entries (Search : Search_Type) return Boolean is
769 if Search.Value = null then
772 elsif Search.Value.Is_Valid then
774 -- Fetch the next entry, if needed
776 if not Search.Value.Entry_Fetched then
777 Fetch_Next_Entry (Search);
781 return Search.Value.Is_Valid;
788 procedure Rename (Old_Name, New_Name : String) is
792 -- First, the invalid cases
794 if not Is_Valid_Path_Name (Old_Name)
795 or else not Is_Valid_Path_Name (New_Name)
796 or else (not Is_Regular_File (Old_Name)
797 and then not Is_Directory (Old_Name))
801 elsif Is_Regular_File (New_Name) or Is_Directory (New_Name) then
805 -- The implementation uses GNAT.OS_Lib.Rename_File
807 Rename_File (Old_Name, New_Name, Success);
819 procedure Set_Directory (Directory : String) is
821 -- The implementation uses GNAT.Directory_Operations.Change_Dir
823 Change_Dir (Dir_Name => Directory);
826 when Directory_Error =>
834 function Simple_Name (Name : String) return String is
836 -- First, the invalid case
838 if not Is_Valid_Path_Name (Name) then
842 -- Build the value to return with lower bound 1
844 -- The implementation uses GNAT.Directory_Operations.Base_Name
847 Value : String := GNAT.Directory_Operations.Base_Name (Name);
848 subtype Result is String (1 .. Value'Length);
850 To_Lower_If_Case_Insensitive (Value);
851 return Result (Value);
857 (Directory_Entry : Directory_Entry_Type) return String
860 -- First, the invalid case
862 if not Directory_Entry.Is_Valid then
866 -- The value to return has already be computed
868 return To_String (Directory_Entry.Simple);
876 function Size (Name : String) return File_Size is
877 C_Name : String (1 .. Name'Length + 1);
879 function C_Size (Name : System.Address) return Long_Integer;
880 pragma Import (C, C_Size, "__gnat_named_file_length");
883 -- First, the invalid case
885 if not Is_Regular_File (Name) then
889 C_Name (1 .. Name'Length) := Name;
890 C_Name (C_Name'Last) := ASCII.NUL;
891 return File_Size (C_Size (C_Name'Address));
895 function Size (Directory_Entry : Directory_Entry_Type) return File_Size is
897 -- First, the invalid case
899 if not Directory_Entry.Is_Valid then
903 -- The value to return has already be computed
905 return Size (To_String (Directory_Entry.Full));
913 procedure Start_Search
914 (Search : in out Search_Type;
917 Filter : Filter_Type := (others => True))
920 -- First, the invalid case
922 if not Is_Directory (Directory) then
926 -- If needed, finalize Search
930 -- Allocate the default data
932 Search.Value := new Search_Data;
937 Search.Value.Pattern := Compile (Pattern, Glob => True);
940 when Error_In_Regexp =>
945 -- Initialize some Search components
947 Search.Value.Filter := Filter;
948 Search.Value.Name := To_Unbounded_String (Full_Name (Directory));
949 Open (Search.Value.Dir, Directory);
950 Search.Value.Is_Valid := True;
953 ----------------------------------
954 -- To_Lower_If_Case_Insensitive --
955 ----------------------------------
957 procedure To_Lower_If_Case_Insensitive (S : in out String) is
959 if not Is_Path_Name_Case_Sensitive then
960 for J in S'Range loop
961 S (J) := To_Lower (S (J));
964 end To_Lower_If_Case_Insensitive;