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;
44 package body Ada.Directories is
46 type Search_Data is record
47 Is_Valid : Boolean := False;
48 Name : Ada.Strings.Unbounded.Unbounded_String;
52 Entry_Fetched : Boolean := False;
53 Dir_Entry : Directory_Entry_Type;
56 Empty_String : constant String := (1 .. 0 => ASCII.NUL);
58 procedure Free is new Ada.Unchecked_Deallocation (Search_Data, Search_Ptr);
60 function File_Exists (Name : String) return Boolean;
61 -- Returns True if the named file exists.
63 procedure Fetch_Next_Entry (Search : Search_Type);
64 -- Get the next entry in a directory, setting Entry_Fetched if successful
65 -- or resetting Is_Valid if not.
71 function Base_Name (Name : String) return String is
72 Simple : constant String := Simple_Name (Name);
73 -- Simple'First is guaranteed to be 1
76 -- Look for the last dot in the file name and return the part of the
77 -- file name preceding this last dot. If the first dot is the first
78 -- character of the file name, the base name is the empty string.
80 for Pos in reverse Simple'Range loop
81 if Simple (Pos) = '.' then
82 return Simple (1 .. Pos - 1);
86 -- If there is no dot, return the complete file name
96 (Containing_Directory : String := "";
98 Extension : String := "") return String
100 Result : String (1 ..
101 Containing_Directory'Length +
102 Name'Length + Extension'Length + 2);
106 -- First, deal with the invalid cases
108 if not Is_Valid_Path_Name (Containing_Directory) then
112 Extension'Length = 0 and then (not Is_Valid_Simple_Name (Name))
116 elsif Extension'Length /= 0 and then
117 (not Is_Valid_Simple_Name (Name & '.' & Extension))
121 -- This is not an invalid case. Build the path name.
124 Last := Containing_Directory'Length;
125 Result (1 .. Last) := Containing_Directory;
127 -- Add a directory separator if needed
129 if Result (Last) /= Dir_Separator then
131 Result (Last) := Dir_Separator;
136 Result (Last + 1 .. Last + Name'Length) := Name;
137 Last := Last + Name'Length;
139 -- If extension was specified, add dot followed by this extension
141 if Extension'Length /= 0 then
143 Result (Last) := '.';
144 Result (Last + 1 .. Last + Extension'Length) := Extension;
145 Last := Last + Extension'Length;
148 return Result (1 .. Last);
152 --------------------------
153 -- Containing_Directory --
154 --------------------------
156 function Containing_Directory (Name : String) return String is
158 -- First, the invalid case
160 if not Is_Valid_Path_Name (Name) then
164 -- Get the directory name using GNAT.Directory_Operations.Dir_Name
167 Value : constant String := Dir_Name (Path => Name);
168 Result : String (1 .. Value'Length);
169 Last : Natural := Result'Last;
174 -- Remove any trailing directory separator, except as the first
177 while Last > 1 and then Result (Last) = Dir_Separator loop
181 -- Special case of current directory, identified by "."
183 if Last = 1 and then Result (1) = '.' then
184 return Get_Current_Dir;
187 return Result (1 .. Last);
191 end Containing_Directory;
198 (Source_Name : String;
199 Target_Name : String;
202 pragma Unreferenced (Form);
206 -- First, the invalid cases
208 if (not Is_Valid_Path_Name (Source_Name)) or else
209 (not Is_Valid_Path_Name (Target_Name)) or else
210 (not Is_Regular_File (Source_Name))
214 elsif Is_Directory (Target_Name) then
218 -- The implementation uses GNAT.OS_Lib.Copy_File, with parameters
219 -- suitable for all platforms.
222 (Source_Name, Target_Name, Success, Overwrite, None);
230 ----------------------
231 -- Create_Directory --
232 ----------------------
234 procedure Create_Directory
235 (New_Directory : String;
238 pragma Unreferenced (Form);
241 -- First, the invalid case
243 if not Is_Valid_Path_Name (New_Directory) then
247 -- The implementation uses GNAT.Directory_Operations.Make_Dir
250 Make_Dir (Dir_Name => New_Directory);
253 when Directory_Error =>
257 end Create_Directory;
263 procedure Create_Path
264 (New_Directory : String;
267 pragma Unreferenced (Form);
269 New_Dir : String (1 .. New_Directory'Length + 1);
270 Last : Positive := 1;
273 -- First, the invalid case
275 if not Is_Valid_Path_Name (New_Directory) then
279 -- Build New_Dir with a directory separator at the end, so that the
280 -- complete path will be found in the loop below.
282 New_Dir (1 .. New_Directory'Length) := New_Directory;
283 New_Dir (New_Dir'Last) := Directory_Separator;
285 -- Create, if necessary, each directory in the path
287 for J in 2 .. New_Dir'Last loop
289 -- Look for the end of an intermediate directory
291 if New_Dir (J) /= Dir_Separator then
294 -- We have found a new intermediate directory each time we find
295 -- a first directory separator.
297 elsif New_Dir (J - 1) /= Dir_Separator then
299 -- No need to create the directory if it already exists
301 if Is_Directory (New_Dir (1 .. Last)) then
304 -- It is an error if a file with such a name already exists
306 elsif Is_Regular_File (New_Dir (1 .. Last)) then
310 -- The implementation uses
311 -- GNAT.Directory_Operations.Make_Dir.
314 Make_Dir (Dir_Name => New_Dir (1 .. Last));
317 when Directory_Error =>
326 -----------------------
327 -- Current_Directory --
328 -----------------------
330 function Current_Directory return String is
332 -- The implementation uses GNAT.Directory_Operations.Get_Current_Dir
334 return Get_Current_Dir;
335 end Current_Directory;
337 ----------------------
338 -- Delete_Directory --
339 ----------------------
341 procedure Delete_Directory (Directory : String) is
343 -- First, the invalid case
345 if not Is_Valid_Path_Name (Directory) then
349 -- The implementation uses GNAT.Directory_Operations.Remove_Dir
352 Remove_Dir (Dir_Name => Directory, Recursive => False);
355 when Directory_Error =>
359 end Delete_Directory;
365 procedure Delete_File (Name : String) is
369 -- First, the invalid cases
371 if not Is_Valid_Path_Name (Name) then
374 elsif not Is_Regular_File (Name) then
378 -- The implementation uses GNAT.OS_Lib.Delete_File
380 Delete_File (Name, Success);
392 procedure Delete_Tree (Directory : String) is
394 -- First, the invalid case
396 if not Is_Valid_Path_Name (Directory) then
400 -- The implementation uses GNAT.Directory_Operations.Remove_Dir
403 Remove_Dir (Directory, Recursive => True);
406 when Directory_Error =>
416 function Exists (Name : String) return Boolean is
418 -- First, the invalid case
420 if not Is_Valid_Path_Name (Name) then
424 -- The implementation is in File_Exists
426 return File_Exists (Name);
434 function Extension (Name : String) return String is
436 -- First, the invalid case
438 if not Is_Valid_Path_Name (Name) then
442 -- Look fir the first dot that is not followed by a directory
445 for Pos in reverse Name'Range loop
447 -- If a directory separator is found before a dot, there is no
450 if Name (Pos) = Dir_Separator then
453 elsif Name (Pos) = '.' then
455 -- We found a dot, build the return value with lower bound 1
458 Result : String (1 .. Name'Last - Pos);
460 Result := Name (Pos + 1 .. Name'Last);
466 -- No dot were found, there is no extension
472 ----------------------
473 -- Fetch_Next_Entry --
474 ----------------------
476 procedure Fetch_Next_Entry (Search : Search_Type) is
477 Name : String (1 .. 255);
482 -- Search.Value.Is_Valid is always True when Fetch_Next_Entry is called
485 Read (Search.Value.Dir, Name, Last);
487 -- If no matching entry is found, set Is_Valid to False
490 Search.Value.Is_Valid := False;
494 -- Check if the entry matches the pattern
496 if Match (Name (1 .. Last), Search.Value.Pattern) then
498 Full_Name : constant String :=
501 (Search.Value.Name), Name (1 .. Last));
502 Found : Boolean := False;
505 if File_Exists (Full_Name) then
507 -- Now check if the file kind matches the filter
509 if Is_Regular_File (Full_Name) then
510 if Search.Value.Filter (Ordinary_File) then
511 Kind := Ordinary_File;
515 elsif Is_Directory (Full_Name) then
516 if Search.Value.Filter (Directory) then
521 elsif Search.Value.Filter (Special_File) then
522 Kind := Special_File;
526 -- If it does, update Search and return
529 Search.Value.Entry_Fetched := True;
530 Search.Value.Dir_Entry :=
532 Simple => To_Unbounded_String (Name (1 .. Last)),
533 Full => To_Unbounded_String (Full_Name),
541 end Fetch_Next_Entry;
547 function File_Exists (Name : String) return Boolean is
548 function C_File_Exists (A : System.Address) return Integer;
549 pragma Import (C, C_File_Exists, "__gnat_file_exists");
551 C_Name : String (1 .. Name'Length + 1);
554 C_Name (1 .. Name'Length) := Name;
555 C_Name (C_Name'Last) := ASCII.NUL;
557 return C_File_Exists (C_Name (1)'Address) = 1;
564 procedure Finalize (Search : in out Search_Type) is
566 if Search.Value /= null then
568 -- Close the directory, if one is open
570 if Is_Open (Search.Value.Dir) then
571 Close (Search.Value.Dir);
582 function Full_Name (Name : String) return String is
584 -- First, the invalid case
586 if not Is_Valid_Path_Name (Name) then
590 -- Build the return value with lower bound 1.
591 -- Use GNAT.OS_Lib.Normalize_Pathname.
594 Value : constant String := Normalize_Pathname (Name);
595 Result : String (1 .. Value'Length);
603 function Full_Name (Directory_Entry : Directory_Entry_Type) return String is
605 -- First, the invalid case
607 if not Directory_Entry.Is_Valid then
611 -- The value to return has already been computed
613 return To_String (Directory_Entry.Full);
621 procedure Get_Next_Entry
622 (Search : in out Search_Type;
623 Directory_Entry : out Directory_Entry_Type)
626 -- First, the invalid case
628 if Search.Value = null or else not Search.Value.Is_Valid then
632 -- Fetch the next entry, if needed
634 if not Search.Value.Entry_Fetched then
635 Fetch_Next_Entry (Search);
638 -- It is an error if no valid entry is found
640 if not Search.Value.Is_Valid then
644 -- Reset Entry_Fatched and return the entry
646 Search.Value.Entry_Fetched := False;
647 Directory_Entry := Search.Value.Dir_Entry;
655 function Kind (Name : String) return File_Kind is
657 -- First, the invalid case
659 if not File_Exists (Name) then
662 elsif Is_Regular_File (Name) then
663 return Ordinary_File;
665 elsif Is_Directory (Name) then
673 function Kind (Directory_Entry : Directory_Entry_Type) return File_Kind is
675 -- First, the invalid case
677 if not Directory_Entry.Is_Valid then
681 -- The value to return has already be computed
683 return Directory_Entry.Kind;
687 -----------------------
688 -- Modification_Time --
689 -----------------------
691 function Modification_Time (Name : String) return Ada.Calendar.Time is
697 Minute : Minute_Type;
698 Second : Second_Type;
701 -- First, the invalid cases
704 if not (Is_Regular_File (Name) or else Is_Directory (Name)) then
708 Date := File_Time_Stamp (Name);
709 -- ???? We need to be able to convert OS_Time to Ada.Calendar.Time
710 -- For now, use the component of the OS_Time to create the
711 -- Calendar.Time value.
713 GM_Split (Date, Year, Month, Day, Hour, Minute, Second);
715 return Ada.Calendar.Time_Of
716 (Year, Month, Day, Duration (Second + 60 * (Minute + 60 * Hour)));
718 end Modification_Time;
720 function Modification_Time
721 (Directory_Entry : Directory_Entry_Type) return Ada.Calendar.Time
724 -- First, the invalid case
726 if not Directory_Entry.Is_Valid then
730 -- The value to return has already be computed
732 return Modification_Time (To_String (Directory_Entry.Full));
734 end Modification_Time;
740 function More_Entries (Search : Search_Type) return Boolean is
742 if Search.Value = null then
745 elsif Search.Value.Is_Valid then
747 -- Fetch the next entry, if needed
749 if not Search.Value.Entry_Fetched then
750 Fetch_Next_Entry (Search);
754 return Search.Value.Is_Valid;
761 procedure Rename (Old_Name, New_Name : String) is
765 -- First, the invalid cases
767 if not Is_Valid_Path_Name (Old_Name)
768 or else not Is_Valid_Path_Name (New_Name)
769 or else (not Is_Regular_File (Old_Name)
770 and then not Is_Directory (Old_Name))
774 elsif Is_Regular_File (New_Name) or Is_Directory (New_Name) then
778 -- The implemewntation uses GNAT.OS_Lib.Rename_File
780 Rename_File (Old_Name, New_Name, Success);
792 procedure Set_Directory (Directory : String) is
794 -- The implementation uses GNAT.Directory_Operations.Change_Dir
796 Change_Dir (Dir_Name => Directory);
799 when Directory_Error =>
807 function Simple_Name (Name : String) return String is
809 -- First, the invalid case
811 if not Is_Valid_Path_Name (Name) then
815 -- Build the value to return with lower bound 1.
816 -- The implementation uses GNAT.Directory_Operations.Base_Name.
819 Value : constant String :=
820 GNAT.Directory_Operations.Base_Name (Name);
821 Result : String (1 .. Value'Length);
830 (Directory_Entry : Directory_Entry_Type) return String
833 -- First, the invalid case
835 if not Directory_Entry.Is_Valid then
839 -- The value to return has already be computed
841 return To_String (Directory_Entry.Simple);
849 function Size (Name : String) return File_Size is
850 C_Name : String (1 .. Name'Length + 1);
852 function C_Size (Name : System.Address) return File_Size;
853 pragma Import (C, C_Size, "__gnat_named_file_length");
856 -- First, the invalid case
858 if not Is_Regular_File (Name) then
862 C_Name (1 .. Name'Length) := Name;
863 C_Name (C_Name'Last) := ASCII.NUL;
864 return C_Size (C_Name'Address);
868 function Size (Directory_Entry : Directory_Entry_Type) return File_Size is
870 -- First, the invalid case
872 if not Directory_Entry.Is_Valid then
876 -- The value to return has already be computed
878 return Size (To_String (Directory_Entry.Full));
886 procedure Start_Search
887 (Search : in out Search_Type;
890 Filter : Filter_Type := (others => True))
893 -- First, the invalid case
895 if not Is_Directory (Directory) then
899 -- If needed, finalize Search
903 -- Allocate the default data
905 Search.Value := new Search_Data;
910 Search.Value.Pattern := Compile (Pattern, Glob => True);
913 when Error_In_Regexp =>
917 -- Initialize some Search components
919 Search.Value.Filter := Filter;
920 Search.Value.Name := To_Unbounded_String (Full_Name (Directory));
921 Open (Search.Value.Dir, Directory);
922 Search.Value.Is_Valid := True;