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, 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.Directories.Validity; use Ada.Directories.Validity;
35 with Ada.Strings.Unbounded; use Ada.Strings.Unbounded;
36 with Ada.Unchecked_Deallocation;
37 with Ada.Unchecked_Conversion;
38 with Ada.Characters.Handling; use Ada.Characters.Handling;
40 with GNAT.Directory_Operations; use GNAT.Directory_Operations;
41 with GNAT.OS_Lib; use GNAT.OS_Lib;
42 with GNAT.Regexp; use GNAT.Regexp;
43 -- ??? Ada units should not depend on GNAT units
47 package body Ada.Directories is
49 function Duration_To_Time is new
50 Ada.Unchecked_Conversion (Duration, Ada.Calendar.Time);
51 function OS_Time_To_Long_Integer is new
52 Ada.Unchecked_Conversion (OS_Time, Long_Integer);
53 -- These two unchecked conversions are used in function Modification_Time
54 -- to convert an OS_Time to a Calendar.Time.
56 type Search_Data is record
57 Is_Valid : Boolean := False;
58 Name : Ada.Strings.Unbounded.Unbounded_String;
62 Entry_Fetched : Boolean := False;
63 Dir_Entry : Directory_Entry_Type;
65 -- The current state of a search
67 Empty_String : constant String := (1 .. 0 => ASCII.NUL);
68 -- Empty string, returned by function Extension when there is no extension
70 procedure Free is new Ada.Unchecked_Deallocation (Search_Data, Search_Ptr);
72 function File_Exists (Name : String) return Boolean;
73 -- Returns True if the named file exists
75 procedure Fetch_Next_Entry (Search : Search_Type);
76 -- Get the next entry in a directory, setting Entry_Fetched if successful
77 -- or resetting Is_Valid if not.
79 procedure To_Lower_If_Case_Insensitive (S : in out String);
80 -- Put S in lower case if file and path names are case-insensitive
86 function Base_Name (Name : String) return String is
87 Simple : String := Simple_Name (Name);
88 -- Simple'First is guaranteed to be 1
91 To_Lower_If_Case_Insensitive (Simple);
93 -- Look for the last dot in the file name and return the part of the
94 -- file name preceding this last dot. If the first dot is the first
95 -- character of the file name, the base name is the empty string.
97 for Pos in reverse Simple'Range loop
98 if Simple (Pos) = '.' then
99 return Simple (1 .. Pos - 1);
103 -- If there is no dot, return the complete file name
113 (Containing_Directory : String := "";
115 Extension : String := "") return String
117 Result : String (1 .. Containing_Directory'Length +
118 Name'Length + Extension'Length + 2);
122 -- First, deal with the invalid cases
124 if not Is_Valid_Path_Name (Containing_Directory) then
128 Extension'Length = 0 and then (not Is_Valid_Simple_Name (Name))
132 elsif Extension'Length /= 0 and then
133 (not Is_Valid_Simple_Name (Name & '.' & Extension))
137 -- This is not an invalid case so build the path name
140 Last := Containing_Directory'Length;
141 Result (1 .. Last) := Containing_Directory;
143 -- Add a directory separator if needed
145 if Result (Last) /= Dir_Separator then
147 Result (Last) := Dir_Separator;
152 Result (Last + 1 .. Last + Name'Length) := Name;
153 Last := Last + Name'Length;
155 -- If extension was specified, add dot followed by this extension
157 if Extension'Length /= 0 then
159 Result (Last) := '.';
160 Result (Last + 1 .. Last + Extension'Length) := Extension;
161 Last := Last + Extension'Length;
164 To_Lower_If_Case_Insensitive (Result (1 .. Last));
165 return Result (1 .. Last);
169 --------------------------
170 -- Containing_Directory --
171 --------------------------
173 function Containing_Directory (Name : String) return String is
175 -- First, the invalid case
177 if not Is_Valid_Path_Name (Name) then
181 -- Get the directory name using GNAT.Directory_Operations.Dir_Name
184 Value : constant String := Dir_Name (Path => Name);
185 Result : String (1 .. Value'Length);
186 Last : Natural := Result'Last;
191 -- Remove any trailing directory separator, except as the first
194 while Last > 1 and then Result (Last) = Dir_Separator loop
198 -- Special case of current directory, identified by "."
200 if Last = 1 and then Result (1) = '.' then
201 return Get_Current_Dir;
204 To_Lower_If_Case_Insensitive (Result (1 .. Last));
205 return Result (1 .. Last);
209 end Containing_Directory;
216 (Source_Name : String;
217 Target_Name : String;
220 pragma Unreferenced (Form);
224 -- First, the invalid cases
226 if not Is_Valid_Path_Name (Source_Name)
227 or else not Is_Valid_Path_Name (Target_Name)
228 or else not Is_Regular_File (Source_Name)
232 elsif Is_Directory (Target_Name) then
236 -- The implementation uses GNAT.OS_Lib.Copy_File, with parameters
237 -- suitable for all platforms.
240 (Source_Name, Target_Name, Success, Overwrite, None);
248 ----------------------
249 -- Create_Directory --
250 ----------------------
252 procedure Create_Directory
253 (New_Directory : String;
256 pragma Unreferenced (Form);
259 -- First, the invalid case
261 if not Is_Valid_Path_Name (New_Directory) then
265 -- The implementation uses GNAT.Directory_Operations.Make_Dir
268 Make_Dir (Dir_Name => New_Directory);
271 when Directory_Error =>
275 end Create_Directory;
281 procedure Create_Path
282 (New_Directory : String;
285 pragma Unreferenced (Form);
287 New_Dir : String (1 .. New_Directory'Length + 1);
288 Last : Positive := 1;
291 -- First, the invalid case
293 if not Is_Valid_Path_Name (New_Directory) then
297 -- Build New_Dir with a directory separator at the end, so that the
298 -- complete path will be found in the loop below.
300 New_Dir (1 .. New_Directory'Length) := New_Directory;
301 New_Dir (New_Dir'Last) := Directory_Separator;
303 -- Create, if necessary, each directory in the path
305 for J in 2 .. New_Dir'Last loop
307 -- Look for the end of an intermediate directory
309 if New_Dir (J) /= Dir_Separator then
312 -- We have found a new intermediate directory each time we find
313 -- a first directory separator.
315 elsif New_Dir (J - 1) /= Dir_Separator then
317 -- No need to create the directory if it already exists
319 if Is_Directory (New_Dir (1 .. Last)) then
322 -- It is an error if a file with such a name already exists
324 elsif Is_Regular_File (New_Dir (1 .. Last)) then
328 -- The implementation uses
329 -- GNAT.Directory_Operations.Make_Dir.
332 Make_Dir (Dir_Name => New_Dir (1 .. Last));
335 when Directory_Error =>
344 -----------------------
345 -- Current_Directory --
346 -----------------------
348 function Current_Directory return String is
350 -- The implementation uses GNAT.Directory_Operations.Get_Current_Dir
352 Cur : String := Normalize_Pathname (Get_Current_Dir);
355 To_Lower_If_Case_Insensitive (Cur);
357 if Cur'Length > 1 and then Cur (Cur'Last) = Dir_Separator then
358 return Cur (1 .. Cur'Last - 1);
362 end Current_Directory;
364 ----------------------
365 -- Delete_Directory --
366 ----------------------
368 procedure Delete_Directory (Directory : String) is
370 -- First, the invalid cases
372 if not Is_Valid_Path_Name (Directory) then
375 elsif not Is_Directory (Directory) then
379 -- The implementation uses GNAT.Directory_Operations.Remove_Dir
382 Remove_Dir (Dir_Name => Directory, Recursive => False);
385 when Directory_Error =>
389 end Delete_Directory;
395 procedure Delete_File (Name : String) is
399 -- First, the invalid cases
401 if not Is_Valid_Path_Name (Name) then
404 elsif not Is_Regular_File (Name) then
408 -- The implementation uses GNAT.OS_Lib.Delete_File
410 Delete_File (Name, Success);
422 procedure Delete_Tree (Directory : String) is
424 -- First, the invalid cases
426 if not Is_Valid_Path_Name (Directory) then
429 elsif not Is_Directory (Directory) then
433 -- The implementation uses GNAT.Directory_Operations.Remove_Dir
436 Remove_Dir (Directory, Recursive => True);
439 when Directory_Error =>
449 function Exists (Name : String) return Boolean is
451 -- First, the invalid case
453 if not Is_Valid_Path_Name (Name) then
457 -- The implementation is in File_Exists
459 return File_Exists (Name);
467 function Extension (Name : String) return String is
469 -- First, the invalid case
471 if not Is_Valid_Path_Name (Name) then
475 -- Look for first dot that is not followed by a directory separator
477 for Pos in reverse Name'Range loop
479 -- If a directory separator is found before a dot, there
482 if Name (Pos) = Dir_Separator then
485 elsif Name (Pos) = '.' then
487 -- We found a dot, build the return value with lower bound 1
490 Result : String (1 .. Name'Last - Pos);
492 Result := Name (Pos + 1 .. Name'Last);
494 -- This should be done with a subtype conversion, avoiding
495 -- the unnecessary junk copy ???
500 -- No dot were found, there is no extension
506 ----------------------
507 -- Fetch_Next_Entry --
508 ----------------------
510 procedure Fetch_Next_Entry (Search : Search_Type) is
511 Name : String (1 .. 255);
514 Kind : File_Kind := Ordinary_File;
515 -- Initialized to avoid a compilation warning
518 -- Search.Value.Is_Valid is always True when Fetch_Next_Entry is called
521 Read (Search.Value.Dir, Name, Last);
523 -- If no matching entry is found, set Is_Valid to False
526 Search.Value.Is_Valid := False;
530 -- Check if the entry matches the pattern
532 if Match (Name (1 .. Last), Search.Value.Pattern) then
534 Full_Name : constant String :=
537 (Search.Value.Name), Name (1 .. Last));
538 Found : Boolean := False;
541 if File_Exists (Full_Name) then
543 -- Now check if the file kind matches the filter
545 if Is_Regular_File (Full_Name) then
546 if Search.Value.Filter (Ordinary_File) then
547 Kind := Ordinary_File;
551 elsif Is_Directory (Full_Name) then
552 if Search.Value.Filter (Directory) then
557 elsif Search.Value.Filter (Special_File) then
558 Kind := Special_File;
562 -- If it does, update Search and return
565 Search.Value.Entry_Fetched := True;
566 Search.Value.Dir_Entry :=
568 Simple => To_Unbounded_String (Name (1 .. Last)),
569 Full => To_Unbounded_String (Full_Name),
577 end Fetch_Next_Entry;
583 function File_Exists (Name : String) return Boolean is
584 function C_File_Exists (A : System.Address) return Integer;
585 pragma Import (C, C_File_Exists, "__gnat_file_exists");
587 C_Name : String (1 .. Name'Length + 1);
590 C_Name (1 .. Name'Length) := Name;
591 C_Name (C_Name'Last) := ASCII.NUL;
592 return C_File_Exists (C_Name (1)'Address) = 1;
599 procedure Finalize (Search : in out Search_Type) is
601 if Search.Value /= null then
603 -- Close the directory, if one is open
605 if Is_Open (Search.Value.Dir) then
606 Close (Search.Value.Dir);
617 function Full_Name (Name : String) return String is
619 -- First, the invalid case
621 if not Is_Valid_Path_Name (Name) then
625 -- Build the return value with lower bound 1
627 -- Use GNAT.OS_Lib.Normalize_Pathname
630 Value : String := Normalize_Pathname (Name);
631 subtype Result is String (1 .. Value'Length);
633 To_Lower_If_Case_Insensitive (Value);
634 return Result (Value);
639 function Full_Name (Directory_Entry : Directory_Entry_Type) return String is
641 -- First, the invalid case
643 if not Directory_Entry.Is_Valid then
647 -- The value to return has already been computed
649 return To_String (Directory_Entry.Full);
657 procedure Get_Next_Entry
658 (Search : in out Search_Type;
659 Directory_Entry : out Directory_Entry_Type)
662 -- First, the invalid case
664 if Search.Value = null or else not Search.Value.Is_Valid then
668 -- Fetch the next entry, if needed
670 if not Search.Value.Entry_Fetched then
671 Fetch_Next_Entry (Search);
674 -- It is an error if no valid entry is found
676 if not Search.Value.Is_Valid then
680 -- Reset Entry_Fatched and return the entry
682 Search.Value.Entry_Fetched := False;
683 Directory_Entry := Search.Value.Dir_Entry;
691 function Kind (Name : String) return File_Kind is
693 -- First, the invalid case
695 if not File_Exists (Name) then
698 elsif Is_Regular_File (Name) then
699 return Ordinary_File;
701 elsif Is_Directory (Name) then
709 function Kind (Directory_Entry : Directory_Entry_Type) return File_Kind is
711 -- First, the invalid case
713 if not Directory_Entry.Is_Valid then
717 -- The value to return has already be computed
719 return Directory_Entry.Kind;
723 -----------------------
724 -- Modification_Time --
725 -----------------------
727 function Modification_Time (Name : String) return Ada.Calendar.Time is
733 Minute : Minute_Type;
734 Second : Second_Type;
736 Result : Ada.Calendar.Time;
739 -- First, the invalid cases
741 if not (Is_Regular_File (Name) or else Is_Directory (Name)) then
745 Date := File_Time_Stamp (Name);
747 -- ??? This implementation should be revisited when AI 00351 has
752 -- On OpenVMS, OS_Time is in local time
754 GM_Split (Date, Year, Month, Day, Hour, Minute, Second);
756 return Ada.Calendar.Time_Of
758 Duration (Second + 60 * (Minute + 60 * Hour)));
761 -- On Unix and Windows, OS_Time is in GMT
764 Duration_To_Time (Duration (OS_Time_To_Long_Integer (Date)));
768 end Modification_Time;
770 function Modification_Time
771 (Directory_Entry : Directory_Entry_Type) return Ada.Calendar.Time
774 -- First, the invalid case
776 if not Directory_Entry.Is_Valid then
780 -- The value to return has already be computed
782 return Modification_Time (To_String (Directory_Entry.Full));
784 end Modification_Time;
790 function More_Entries (Search : Search_Type) return Boolean is
792 if Search.Value = null then
795 elsif Search.Value.Is_Valid then
797 -- Fetch the next entry, if needed
799 if not Search.Value.Entry_Fetched then
800 Fetch_Next_Entry (Search);
804 return Search.Value.Is_Valid;
811 procedure Rename (Old_Name, New_Name : String) is
815 -- First, the invalid cases
817 if not Is_Valid_Path_Name (Old_Name)
818 or else not Is_Valid_Path_Name (New_Name)
819 or else (not Is_Regular_File (Old_Name)
820 and then not Is_Directory (Old_Name))
824 elsif Is_Regular_File (New_Name) or Is_Directory (New_Name) then
828 -- The implementation uses GNAT.OS_Lib.Rename_File
830 Rename_File (Old_Name, New_Name, Success);
842 procedure Set_Directory (Directory : String) is
844 -- The implementation uses GNAT.Directory_Operations.Change_Dir
846 Change_Dir (Dir_Name => Directory);
849 when Directory_Error =>
857 function Simple_Name (Name : String) return String is
859 -- First, the invalid case
861 if not Is_Valid_Path_Name (Name) then
865 -- Build the value to return with lower bound 1
867 -- The implementation uses GNAT.Directory_Operations.Base_Name
870 Value : String := GNAT.Directory_Operations.Base_Name (Name);
871 subtype Result is String (1 .. Value'Length);
873 To_Lower_If_Case_Insensitive (Value);
874 return Result (Value);
880 (Directory_Entry : Directory_Entry_Type) return String
883 -- First, the invalid case
885 if not Directory_Entry.Is_Valid then
889 -- The value to return has already be computed
891 return To_String (Directory_Entry.Simple);
899 function Size (Name : String) return File_Size is
900 C_Name : String (1 .. Name'Length + 1);
902 function C_Size (Name : System.Address) return Long_Integer;
903 pragma Import (C, C_Size, "__gnat_named_file_length");
906 -- First, the invalid case
908 if not Is_Regular_File (Name) then
912 C_Name (1 .. Name'Length) := Name;
913 C_Name (C_Name'Last) := ASCII.NUL;
914 return File_Size (C_Size (C_Name'Address));
918 function Size (Directory_Entry : Directory_Entry_Type) return File_Size is
920 -- First, the invalid case
922 if not Directory_Entry.Is_Valid then
926 -- The value to return has already be computed
928 return Size (To_String (Directory_Entry.Full));
936 procedure Start_Search
937 (Search : in out Search_Type;
940 Filter : Filter_Type := (others => True))
943 -- First, the invalid case
945 if not Is_Directory (Directory) then
949 -- If needed, finalize Search
953 -- Allocate the default data
955 Search.Value := new Search_Data;
960 Search.Value.Pattern := Compile (Pattern, Glob => True);
963 when Error_In_Regexp =>
968 -- Initialize some Search components
970 Search.Value.Filter := Filter;
971 Search.Value.Name := To_Unbounded_String (Full_Name (Directory));
972 Open (Search.Value.Dir, Directory);
973 Search.Value.Is_Valid := True;
976 ----------------------------------
977 -- To_Lower_If_Case_Insensitive --
978 ----------------------------------
980 procedure To_Lower_If_Case_Insensitive (S : in out String) is
982 if not Is_Path_Name_Case_Sensitive then
983 for J in S'Range loop
984 S (J) := To_Lower (S (J));
987 end To_Lower_If_Case_Insensitive;