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-2006, 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.Calendar; use Ada.Calendar;
35 with Ada.Calendar.Formatting; use Ada.Calendar.Formatting;
36 with Ada.Directories.Validity; use Ada.Directories.Validity;
37 with Ada.Strings.Unbounded; use Ada.Strings.Unbounded;
38 with Ada.Unchecked_Deallocation;
39 with Ada.Characters.Handling; use Ada.Characters.Handling;
41 with GNAT.Directory_Operations; use GNAT.Directory_Operations;
42 with GNAT.OS_Lib; use GNAT.OS_Lib;
43 with GNAT.Regexp; use GNAT.Regexp;
44 -- ??? Ada units should not depend on GNAT units
48 package body Ada.Directories is
50 type Search_Data is record
51 Is_Valid : Boolean := False;
52 Name : Ada.Strings.Unbounded.Unbounded_String;
56 Entry_Fetched : Boolean := False;
57 Dir_Entry : Directory_Entry_Type;
59 -- The current state of a search
61 Empty_String : constant String := (1 .. 0 => ASCII.NUL);
62 -- Empty string, returned by function Extension when there is no extension
64 procedure Free is new Ada.Unchecked_Deallocation (Search_Data, Search_Ptr);
66 function File_Exists (Name : String) return Boolean;
67 -- Returns True if the named file exists
69 procedure Fetch_Next_Entry (Search : Search_Type);
70 -- Get the next entry in a directory, setting Entry_Fetched if successful
71 -- or resetting Is_Valid if not.
73 procedure To_Lower_If_Case_Insensitive (S : in out String);
74 -- Put S in lower case if file and path names are case-insensitive
80 function Base_Name (Name : String) return String is
81 Simple : String := Simple_Name (Name);
82 -- Simple'First is guaranteed to be 1
85 To_Lower_If_Case_Insensitive (Simple);
87 -- Look for the last dot in the file name and return the part of the
88 -- file name preceding this last dot. If the first dot is the first
89 -- character of the file name, the base name is the empty string.
91 for Pos in reverse Simple'Range loop
92 if Simple (Pos) = '.' then
93 return Simple (1 .. Pos - 1);
97 -- If there is no dot, return the complete file name
107 (Containing_Directory : String := "";
109 Extension : String := "") return String
111 Result : String (1 .. Containing_Directory'Length +
112 Name'Length + Extension'Length + 2);
116 -- First, deal with the invalid cases
118 if not Is_Valid_Path_Name (Containing_Directory) then
122 Extension'Length = 0 and then (not Is_Valid_Simple_Name (Name))
126 elsif Extension'Length /= 0 and then
127 (not Is_Valid_Simple_Name (Name & '.' & Extension))
131 -- This is not an invalid case so build the path name
134 Last := Containing_Directory'Length;
135 Result (1 .. Last) := Containing_Directory;
137 -- Add a directory separator if needed
139 if Result (Last) /= Dir_Separator then
141 Result (Last) := Dir_Separator;
146 Result (Last + 1 .. Last + Name'Length) := Name;
147 Last := Last + Name'Length;
149 -- If extension was specified, add dot followed by this extension
151 if Extension'Length /= 0 then
153 Result (Last) := '.';
154 Result (Last + 1 .. Last + Extension'Length) := Extension;
155 Last := Last + Extension'Length;
158 To_Lower_If_Case_Insensitive (Result (1 .. Last));
159 return Result (1 .. Last);
163 --------------------------
164 -- Containing_Directory --
165 --------------------------
167 function Containing_Directory (Name : String) return String is
169 -- First, the invalid case
171 if not Is_Valid_Path_Name (Name) then
175 -- Get the directory name using GNAT.Directory_Operations.Dir_Name
178 Value : constant String := Dir_Name (Path => Name);
179 Result : String (1 .. Value'Length);
180 Last : Natural := Result'Last;
185 -- Remove any trailing directory separator, except as the first
188 while Last > 1 and then Result (Last) = Dir_Separator loop
192 -- Special case of current directory, identified by "."
194 if Last = 1 and then Result (1) = '.' then
195 return Get_Current_Dir;
198 To_Lower_If_Case_Insensitive (Result (1 .. Last));
199 return Result (1 .. Last);
203 end Containing_Directory;
210 (Source_Name : String;
211 Target_Name : String;
214 pragma Unreferenced (Form);
218 -- First, the invalid cases
220 if not Is_Valid_Path_Name (Source_Name)
221 or else not Is_Valid_Path_Name (Target_Name)
222 or else not Is_Regular_File (Source_Name)
226 elsif Is_Directory (Target_Name) then
230 -- The implementation uses GNAT.OS_Lib.Copy_File, with parameters
231 -- suitable for all platforms.
234 (Source_Name, Target_Name, Success, Overwrite, None);
242 ----------------------
243 -- Create_Directory --
244 ----------------------
246 procedure Create_Directory
247 (New_Directory : String;
250 pragma Unreferenced (Form);
253 -- First, the invalid case
255 if not Is_Valid_Path_Name (New_Directory) then
259 -- The implementation uses GNAT.Directory_Operations.Make_Dir
262 Make_Dir (Dir_Name => New_Directory);
265 when Directory_Error =>
269 end Create_Directory;
275 procedure Create_Path
276 (New_Directory : String;
279 pragma Unreferenced (Form);
281 New_Dir : String (1 .. New_Directory'Length + 1);
282 Last : Positive := 1;
285 -- First, the invalid case
287 if not Is_Valid_Path_Name (New_Directory) then
291 -- Build New_Dir with a directory separator at the end, so that the
292 -- complete path will be found in the loop below.
294 New_Dir (1 .. New_Directory'Length) := New_Directory;
295 New_Dir (New_Dir'Last) := Directory_Separator;
297 -- Create, if necessary, each directory in the path
299 for J in 2 .. New_Dir'Last loop
301 -- Look for the end of an intermediate directory
303 if New_Dir (J) /= Dir_Separator then
306 -- We have found a new intermediate directory each time we find
307 -- a first directory separator.
309 elsif New_Dir (J - 1) /= Dir_Separator then
311 -- No need to create the directory if it already exists
313 if Is_Directory (New_Dir (1 .. Last)) then
316 -- It is an error if a file with such a name already exists
318 elsif Is_Regular_File (New_Dir (1 .. Last)) then
322 -- The implementation uses
323 -- GNAT.Directory_Operations.Make_Dir.
326 Make_Dir (Dir_Name => New_Dir (1 .. Last));
329 when Directory_Error =>
338 -----------------------
339 -- Current_Directory --
340 -----------------------
342 function Current_Directory return String is
344 -- The implementation uses GNAT.Directory_Operations.Get_Current_Dir
346 Cur : String := Normalize_Pathname (Get_Current_Dir);
349 To_Lower_If_Case_Insensitive (Cur);
351 if Cur'Length > 1 and then Cur (Cur'Last) = Dir_Separator then
352 return Cur (1 .. Cur'Last - 1);
356 end Current_Directory;
358 ----------------------
359 -- Delete_Directory --
360 ----------------------
362 procedure Delete_Directory (Directory : String) is
364 -- First, the invalid cases
366 if not Is_Valid_Path_Name (Directory) then
369 elsif not Is_Directory (Directory) then
373 -- The implementation uses GNAT.Directory_Operations.Remove_Dir
376 Remove_Dir (Dir_Name => Directory, Recursive => False);
379 when Directory_Error =>
383 end Delete_Directory;
389 procedure Delete_File (Name : String) is
393 -- First, the invalid cases
395 if not Is_Valid_Path_Name (Name) then
398 elsif not Is_Regular_File (Name) then
402 -- The implementation uses GNAT.OS_Lib.Delete_File
404 Delete_File (Name, Success);
416 procedure Delete_Tree (Directory : String) is
418 -- First, the invalid cases
420 if not Is_Valid_Path_Name (Directory) then
423 elsif not Is_Directory (Directory) then
427 -- The implementation uses GNAT.Directory_Operations.Remove_Dir
430 Remove_Dir (Directory, Recursive => True);
433 when Directory_Error =>
443 function Exists (Name : String) return Boolean is
445 -- First, the invalid case
447 if not Is_Valid_Path_Name (Name) then
451 -- The implementation is in File_Exists
453 return File_Exists (Name);
461 function Extension (Name : String) return String is
463 -- First, the invalid case
465 if not Is_Valid_Path_Name (Name) then
469 -- Look for first dot that is not followed by a directory separator
471 for Pos in reverse Name'Range loop
473 -- If a directory separator is found before a dot, there
476 if Name (Pos) = Dir_Separator then
479 elsif Name (Pos) = '.' then
481 -- We found a dot, build the return value with lower bound 1
484 Result : String (1 .. Name'Last - Pos);
486 Result := Name (Pos + 1 .. Name'Last);
488 -- This should be done with a subtype conversion, avoiding
489 -- the unnecessary junk copy ???
494 -- No dot were found, there is no extension
500 ----------------------
501 -- Fetch_Next_Entry --
502 ----------------------
504 procedure Fetch_Next_Entry (Search : Search_Type) is
505 Name : String (1 .. 255);
508 Kind : File_Kind := Ordinary_File;
509 -- Initialized to avoid a compilation warning
512 -- Search.Value.Is_Valid is always True when Fetch_Next_Entry is called
515 Read (Search.Value.Dir, Name, Last);
517 -- If no matching entry is found, set Is_Valid to False
520 Search.Value.Is_Valid := False;
524 -- Check if the entry matches the pattern
526 if Match (Name (1 .. Last), Search.Value.Pattern) then
528 Full_Name : constant String :=
531 (Search.Value.Name), Name (1 .. Last));
532 Found : Boolean := False;
535 if File_Exists (Full_Name) then
537 -- Now check if the file kind matches the filter
539 if Is_Regular_File (Full_Name) then
540 if Search.Value.Filter (Ordinary_File) then
541 Kind := Ordinary_File;
545 elsif Is_Directory (Full_Name) then
546 if Search.Value.Filter (Directory) then
551 elsif Search.Value.Filter (Special_File) then
552 Kind := Special_File;
556 -- If it does, update Search and return
559 Search.Value.Entry_Fetched := True;
560 Search.Value.Dir_Entry :=
562 Simple => To_Unbounded_String (Name (1 .. Last)),
563 Full => To_Unbounded_String (Full_Name),
571 end Fetch_Next_Entry;
577 function File_Exists (Name : String) return Boolean is
578 function C_File_Exists (A : System.Address) return Integer;
579 pragma Import (C, C_File_Exists, "__gnat_file_exists");
581 C_Name : String (1 .. Name'Length + 1);
584 C_Name (1 .. Name'Length) := Name;
585 C_Name (C_Name'Last) := ASCII.NUL;
586 return C_File_Exists (C_Name (1)'Address) = 1;
593 procedure Finalize (Search : in out Search_Type) is
595 if Search.Value /= null then
597 -- Close the directory, if one is open
599 if Is_Open (Search.Value.Dir) then
600 Close (Search.Value.Dir);
611 function Full_Name (Name : String) return String is
613 -- First, the invalid case
615 if not Is_Valid_Path_Name (Name) then
619 -- Build the return value with lower bound 1
621 -- Use GNAT.OS_Lib.Normalize_Pathname
624 Value : String := Normalize_Pathname (Name);
625 subtype Result is String (1 .. Value'Length);
627 To_Lower_If_Case_Insensitive (Value);
628 return Result (Value);
633 function Full_Name (Directory_Entry : Directory_Entry_Type) return String is
635 -- First, the invalid case
637 if not Directory_Entry.Is_Valid then
641 -- The value to return has already been computed
643 return To_String (Directory_Entry.Full);
651 procedure Get_Next_Entry
652 (Search : in out Search_Type;
653 Directory_Entry : out Directory_Entry_Type)
656 -- First, the invalid case
658 if Search.Value = null or else not Search.Value.Is_Valid then
662 -- Fetch the next entry, if needed
664 if not Search.Value.Entry_Fetched then
665 Fetch_Next_Entry (Search);
668 -- It is an error if no valid entry is found
670 if not Search.Value.Is_Valid then
674 -- Reset Entry_Fatched and return the entry
676 Search.Value.Entry_Fetched := False;
677 Directory_Entry := Search.Value.Dir_Entry;
685 function Kind (Name : String) return File_Kind is
687 -- First, the invalid case
689 if not File_Exists (Name) then
692 elsif Is_Regular_File (Name) then
693 return Ordinary_File;
695 elsif Is_Directory (Name) then
703 function Kind (Directory_Entry : Directory_Entry_Type) return File_Kind is
705 -- First, the invalid case
707 if not Directory_Entry.Is_Valid then
711 -- The value to return has already be computed
713 return Directory_Entry.Kind;
717 -----------------------
718 -- Modification_Time --
719 -----------------------
721 function Modification_Time (Name : String) return Time is
727 Minute : Minute_Type;
728 Second : Second_Type;
732 -- First, the invalid cases
734 if not (Is_Regular_File (Name) or else Is_Directory (Name)) then
738 Date := File_Time_Stamp (Name);
740 -- Break down the time stamp into its constituents relative to GMT.
741 -- This version of Split does not recognize leap seconds or buffer
742 -- space for time zone processing.
744 GM_Split (Date, Year, Month, Day, Hour, Minute, Second);
746 -- On OpenVMS, the resulting time value must be in the local time
747 -- zone. Ada.Calendar.Time_Of is exactly what we need. Note that
748 -- in both cases, the sub seconds are set to zero (0.0) because the
749 -- time stamp does not store them in its value.
754 (Year, Month, Day, Seconds_Of (Hour, Minute, Second, 0.0));
756 -- On Unix and Windows, the result must be in GMT. Ada.Calendar.
757 -- Formatting.Time_Of with default time zone of zero (0) is the
758 -- routine of choice.
761 Result := Time_Of (Year, Month, Day, Hour, Minute, Second, 0.0);
766 end Modification_Time;
768 function Modification_Time
769 (Directory_Entry : Directory_Entry_Type) return Ada.Calendar.Time
772 -- First, the invalid case
774 if not Directory_Entry.Is_Valid then
778 -- The value to return has already be computed
780 return Modification_Time (To_String (Directory_Entry.Full));
782 end Modification_Time;
788 function More_Entries (Search : Search_Type) return Boolean is
790 if Search.Value = null then
793 elsif Search.Value.Is_Valid then
795 -- Fetch the next entry, if needed
797 if not Search.Value.Entry_Fetched then
798 Fetch_Next_Entry (Search);
802 return Search.Value.Is_Valid;
809 procedure Rename (Old_Name, New_Name : String) is
813 -- First, the invalid cases
815 if not Is_Valid_Path_Name (Old_Name)
816 or else not Is_Valid_Path_Name (New_Name)
817 or else (not Is_Regular_File (Old_Name)
818 and then not Is_Directory (Old_Name))
822 elsif Is_Regular_File (New_Name) or Is_Directory (New_Name) then
826 -- The implementation uses GNAT.OS_Lib.Rename_File
828 Rename_File (Old_Name, New_Name, Success);
843 Filter : Filter_Type := (others => True);
844 Process : not null access procedure
845 (Directory_Entry : Directory_Entry_Type))
848 Directory_Entry : Directory_Entry_Type;
850 Start_Search (Srch, Directory, Pattern, Filter);
852 while More_Entries (Srch) loop
853 Get_Next_Entry (Srch, Directory_Entry);
854 Process (Directory_Entry);
864 procedure Set_Directory (Directory : String) is
866 -- The implementation uses GNAT.Directory_Operations.Change_Dir
868 Change_Dir (Dir_Name => Directory);
871 when Directory_Error =>
879 function Simple_Name (Name : String) return String is
881 -- First, the invalid case
883 if not Is_Valid_Path_Name (Name) then
887 -- Build the value to return with lower bound 1
889 -- The implementation uses GNAT.Directory_Operations.Base_Name
892 Value : String := GNAT.Directory_Operations.Base_Name (Name);
893 subtype Result is String (1 .. Value'Length);
895 To_Lower_If_Case_Insensitive (Value);
896 return Result (Value);
902 (Directory_Entry : Directory_Entry_Type) return String
905 -- First, the invalid case
907 if not Directory_Entry.Is_Valid then
911 -- The value to return has already be computed
913 return To_String (Directory_Entry.Simple);
921 function Size (Name : String) return File_Size is
922 C_Name : String (1 .. Name'Length + 1);
924 function C_Size (Name : System.Address) return Long_Integer;
925 pragma Import (C, C_Size, "__gnat_named_file_length");
928 -- First, the invalid case
930 if not Is_Regular_File (Name) then
934 C_Name (1 .. Name'Length) := Name;
935 C_Name (C_Name'Last) := ASCII.NUL;
936 return File_Size (C_Size (C_Name'Address));
940 function Size (Directory_Entry : Directory_Entry_Type) return File_Size is
942 -- First, the invalid case
944 if not Directory_Entry.Is_Valid then
948 -- The value to return has already be computed
950 return Size (To_String (Directory_Entry.Full));
958 procedure Start_Search
959 (Search : in out Search_Type;
962 Filter : Filter_Type := (others => True))
965 -- First, the invalid case
967 if not Is_Directory (Directory) then
971 -- If needed, finalize Search
975 -- Allocate the default data
977 Search.Value := new Search_Data;
982 Search.Value.Pattern := Compile (Pattern, Glob => True);
985 when Error_In_Regexp =>
990 -- Initialize some Search components
992 Search.Value.Filter := Filter;
993 Search.Value.Name := To_Unbounded_String (Full_Name (Directory));
994 Open (Search.Value.Dir, Directory);
995 Search.Value.Is_Valid := True;
998 ----------------------------------
999 -- To_Lower_If_Case_Insensitive --
1000 ----------------------------------
1002 procedure To_Lower_If_Case_Insensitive (S : in out String) is
1004 if not Is_Path_Name_Case_Sensitive then
1005 for J in S'Range loop
1006 S (J) := To_Lower (S (J));
1009 end To_Lower_If_Case_Insensitive;
1011 end Ada.Directories;