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-2023, 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 3, 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. --
18 -- As a special exception under Section 7 of GPL version 3, you are granted --
19 -- additional permissions described in the GCC Runtime Library Exception, --
20 -- version 3.1, as published by the Free Software Foundation. --
22 -- You should have received a copy of the GNU General Public License and --
23 -- a copy of the GCC Runtime Library Exception along with this program; --
24 -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
25 -- <http://www.gnu.org/licenses/>. --
27 -- GNAT was originally developed by the GNAT team at New York University. --
28 -- Extensive contributions were provided by Ada Core Technologies Inc. --
30 ------------------------------------------------------------------------------
32 with Ada
.Calendar
; use Ada
.Calendar
;
33 with Ada
.Characters
.Handling
; use Ada
.Characters
.Handling
;
34 with Ada
.Containers
.Vectors
;
35 with Ada
.Directories
.Validity
; use Ada
.Directories
.Validity
;
36 with Ada
.Directories
.Hierarchical_File_Names
;
37 use Ada
.Directories
.Hierarchical_File_Names
;
38 with Ada
.Strings
.Fixed
;
39 with Ada
.Strings
.Maps
; use Ada
.Strings
.Maps
;
40 with Ada
.Strings
.Unbounded
; use Ada
.Strings
.Unbounded
;
41 with Ada
.Unchecked_Deallocation
;
45 with System
; use System
;
46 with System
.CRTL
; use System
.CRTL
;
47 with System
.File_Attributes
; use System
.File_Attributes
;
48 with System
.File_IO
; use System
.File_IO
;
49 with System
.OS_Constants
; use System
.OS_Constants
;
50 with System
.OS_Lib
; use System
.OS_Lib
;
51 with System
.Regexp
; use System
.Regexp
;
53 package body Ada
.Directories
is
55 type Dir_Type_Value
is new Address
;
56 -- This is the low-level address directory structure as returned by the C
59 No_Dir
: constant Dir_Type_Value
:= Dir_Type_Value
(Null_Address
);
60 -- Null directory value
62 Dir_Separator
: constant Character;
63 pragma Import
(C
, Dir_Separator
, "__gnat_dir_separator");
64 -- Running system default directory separator
66 Dir_Seps
: constant Character_Set
:= Strings
.Maps
.To_Set
("/\");
67 -- UNIX and DOS style directory separators
70 pragma Import (C, Max_Path, "__gnat_max_path_len
");
71 -- The maximum length of a path
73 function C_Modification_Time (N : System.Address) return Ada.Calendar.Time;
74 pragma Import (C, C_Modification_Time, "__gnat_file_time
");
75 -- Get modification time for file with name referenced by N
77 Invalid_Time : constant Ada.Calendar.Time :=
78 C_Modification_Time (System.Null_Address);
79 -- Result returned from C_Modification_Time call when routine unable to get
80 -- file modification time.
82 Empty_String : constant String := "";
83 -- Empty string, returned by function Extension when there is no extension
85 ----------------------------
86 -- Directory Search Types --
87 ----------------------------
89 package Directory_Vectors is new
90 Ada.Containers.Vectors
91 (Index_Type => Natural,
92 Element_Type => Directory_Entry_Type);
93 use Directory_Vectors;
94 -- Used to store the results of the directory search
96 type Dir_Contents_Ptr is access Directory_Vectors.Vector;
98 procedure Free is new Ada.Unchecked_Deallocation
99 (Directory_Vectors.Vector, Dir_Contents_Ptr);
100 -- Directory_Vectors.Vector deallocation routine
102 type Search_State is new Ada.Finalization.Controlled with record
103 Dir_Contents : Dir_Contents_Ptr;
106 -- The Search_State consists of a vector of directory items that match the
107 -- search pattern and filter, and a cursor pointing to the next item of the
108 -- vector to be returned to the user.
110 procedure Free is new Ada.Unchecked_Deallocation (Search_State, Search_Ptr);
111 -- Search_State deallocation routine
113 Dir_Vector_Initial_Size : constant := 100;
114 -- Initial size for the Dir_Contents vector, sized to ensure the vector
115 -- does not need to be reallocated for reasonably sized directory searches.
117 ------------------------
118 -- Helper Subprograms --
119 ------------------------
121 function File_Exists (Name : String) return Boolean;
122 -- Returns True if the named file exists
124 procedure Start_Search_Internal
125 (Search : in out Search_Type;
128 Filter : Filter_Type := [others => True];
129 Case_Insensitive : Boolean);
130 -- Similar to Start_Search except we can specify a case-insensitive search.
131 -- This enables detecting the name-case equivalence for a given directory.
137 function Base_Name (Name : String) return String is
138 Simple : constant String := Simple_Name (Name);
139 -- Simple'First is guaranteed to be 1
142 -- Look for the last dot in the file name and return the part of the
143 -- file name preceding this last dot. If the first dot is the first
144 -- character of the file name, the base name is the empty string.
146 for Pos in reverse Simple'Range loop
147 if Simple (Pos) = '.' then
148 return Simple (1 .. Pos - 1);
152 -- If there is no dot, return the complete file name
162 (Containing_Directory : String := "";
164 Extension : String := "") return String
166 Result : String (1 .. Containing_Directory'Length +
167 Name'Length + Extension'Length + 2);
171 -- First, deal with the invalid cases
173 if Containing_Directory /= ""
174 and then not Is_Valid_Path_Name (Containing_Directory)
176 raise Name_Error with
177 "invalid directory path name
""" & Containing_Directory & '"';
179 elsif Extension'Length = 0 and then not Is_Valid_Simple_Name (Name) then
180 raise Name_Error with
181 "invalid simple name """ & Name & '"';
183 elsif Extension'Length /= 0
184 and then not Is_Valid_Simple_Name (Name & '.' & Extension)
186 raise Name_Error with
187 "invalid file name
""" & Name & '.' & Extension & '"';
189 -- This is not an invalid case so build the path name
192 Last := Containing_Directory'Length;
193 Result (1 .. Last) := Containing_Directory;
195 -- Add a directory separator if needed
197 if Last /= 0 and then not Is_In (Result (Last), Dir_Seps) then
199 Result (Last) := Dir_Separator;
204 Result (Last + 1 .. Last + Name'Length) := Name;
205 Last := Last + Name'Length;
207 -- If extension was specified, add dot followed by this extension
209 if Extension'Length /= 0 then
211 Result (Last) := '.';
212 Result (Last + 1 .. Last + Extension'Length) := Extension;
213 Last := Last + Extension'Length;
216 return Result (1 .. Last);
220 --------------------------
221 -- Containing_Directory --
222 --------------------------
224 function Containing_Directory (Name : String) return String is
226 -- First, the invalid case
228 if not Is_Valid_Path_Name (Name) then
229 raise Name_Error with "invalid path name """ & Name & '"';
233 Last_DS : constant Natural :=
234 Strings.Fixed.Index (Name, Dir_Seps, Going => Strings.Backward);
237 -- If Name indicates a root directory, raise Use_Error, because
238 -- it has no containing directory.
240 if Is_Parent_Directory_Name (Name)
241 or else Is_Current_Directory_Name (Name)
242 or else Is_Root_Directory_Name (Name)
245 "directory
""" & Name & """ has no containing directory
";
247 elsif Last_DS = 0 then
248 -- There is no directory separator, so return ".", representing
249 -- the current working directory.
255 Last : Positive := Last_DS - Name'First + 1;
256 Result : String (1 .. Last);
259 Result := Name (Name'First .. Last_DS);
261 -- Remove any trailing directory separator, except as the
262 -- first character or the first character following a drive
263 -- number on Windows.
266 exit when Is_Root_Directory_Name (Result (1 .. Last))
267 or else (Result (Last) /= Directory_Separator
268 and then Result (Last) /= '/');
273 return Result (1 .. Last);
278 end Containing_Directory;
285 (Source_Name : String;
286 Target_Name : String;
290 Mode : Copy_Mode := Overwrite;
291 Preserve : Attribute := None;
294 -- First, the invalid cases
296 if not Is_Valid_Path_Name (Source_Name) then
297 raise Name_Error with
298 "invalid source path name
""" & Source_Name & '"';
300 elsif not Is_Valid_Path_Name (Target_Name) then
301 raise Name_Error with
302 "invalid target path name """ & Target_Name & '"';
304 elsif not Is_Regular_File (Source_Name) then
305 raise Name_Error with '"' & Source_Name & """ is not a file";
307 elsif Is_Directory (Target_Name) then
308 raise Use_Error with "target """ & Target_Name & """ is a directory";
311 if Form'Length > 0 then
313 Formstr : String (1 .. Form'Length + 1);
317 -- Acquire form string, setting required NUL terminator
319 Formstr (1 .. Form'Length) := Form;
320 Formstr (Formstr'Last) := ASCII.NUL;
322 -- Convert form string to lower case
324 for J in Formstr'Range loop
325 if Formstr (J) in 'A
' .. 'Z
' then
327 Character'Val (Character'Pos (Formstr (J)) + 32);
333 Form_Parameter (Formstr, "mode", V1, V2);
337 elsif Formstr (V1 .. V2) = "copy" then
339 elsif Formstr (V1 .. V2) = "overwrite" then
341 elsif Formstr (V1 .. V2) = "append" then
344 raise Use_Error with "invalid Form";
347 Form_Parameter (Formstr, "preserve", V1, V2);
351 elsif Formstr (V1 .. V2) = "timestamps" then
352 Preserve := Time_Stamps;
353 elsif Formstr (V1 .. V2) = "all_attributes" then
355 elsif Formstr (V1 .. V2) = "no_attributes" then
358 raise Use_Error with "invalid Form";
363 -- Do actual copy using System.OS_Lib.Copy_File
365 Copy_File (Source_Name, Target_Name, Success, Mode, Preserve);
368 raise Use_Error with "copy of """ & Source_Name & """ failed";
373 ----------------------
374 -- Create_Directory --
375 ----------------------
377 procedure Create_Directory
378 (New_Directory : String;
381 Dir_Name_C : constant String := New_Directory & ASCII.NUL;
384 -- First, the invalid case
386 if not Is_Valid_Path_Name (New_Directory) then
387 raise Name_Error with
388 "invalid new directory path name """ & New_Directory & '"';
391 -- Acquire setting of encoding parameter
394 Formstr : constant String := To_Lower (Form);
396 Encoding : CRTL.Filename_Encoding;
397 -- Filename encoding specified into the form parameter
402 Form_Parameter (Formstr, "encoding
", V1, V2);
405 Encoding := CRTL.Unspecified;
406 elsif Formstr (V1 .. V2) = "utf8
" then
407 Encoding := CRTL.UTF8;
408 elsif Formstr (V1 .. V2) = "8bits
" then
409 Encoding := CRTL.ASCII_8bits;
411 raise Use_Error with "invalid Form
";
414 if CRTL.mkdir (Dir_Name_C, Encoding) /= 0 then
416 "creation
of new directory
""" & New_Directory & """ failed
";
420 end Create_Directory;
426 procedure Create_Path
427 (New_Directory : String;
430 New_Dir : String (1 .. New_Directory'Length + 1);
431 Last : Positive := 1;
432 Start : Positive := 1;
435 -- First, the invalid case
437 if not Is_Valid_Path_Name (New_Directory) then
438 raise Name_Error with
439 "invalid
new directory path name
""" & New_Directory & '"';
442 -- Build New_Dir with a directory separator at the end, so that the
443 -- complete path will be found in the loop below.
445 New_Dir (1 .. New_Directory'Length) := New_Directory;
446 New_Dir (New_Dir'Last) := Directory_Separator;
448 -- If host is windows, and the first two characters are directory
449 -- separators, we have an UNC path. Skip it.
451 if Directory_Separator = '\
'
452 and then New_Dir'Length > 2
453 and then Is_In (New_Dir (1), Dir_Seps)
454 and then Is_In (New_Dir (2), Dir_Seps)
459 exit when Start = New_Dir'Last
460 or else Is_In (New_Dir (Start), Dir_Seps);
464 -- Create, if necessary, each directory in the path
466 for J in Start + 1 .. New_Dir'Last loop
468 -- Look for the end of an intermediate directory
470 if not Is_In (New_Dir (J), Dir_Seps) then
473 -- We have found a new intermediate directory each time we find
474 -- a first directory separator.
476 elsif not Is_In (New_Dir (J - 1), Dir_Seps) then
478 -- No need to create the directory if it already exists
480 if not Is_Directory (New_Dir (1 .. Last)) then
483 (New_Directory => New_Dir (1 .. Last), Form => Form);
487 if File_Exists (New_Dir (1 .. Last)) then
489 -- A file with such a name already exists. If it is
490 -- a directory, then it was apparently just created
491 -- by another process or thread, and all is well.
492 -- If it is of some other kind, report an error.
494 if not Is_Directory (New_Dir (1 .. Last)) then
496 "file """ & New_Dir (1 .. Last) &
497 """ already exists and is not a directory";
501 -- Create_Directory failed for some other reason:
502 -- propagate the exception.
513 -----------------------
514 -- Current_Directory --
515 -----------------------
517 function Current_Directory return String is
518 Path_Len : Natural := Max_Path;
519 Buffer : String (1 .. 1 + Max_Path + 1);
521 procedure Local_Get_Current_Dir (Dir : Address; Length : Address);
522 pragma Import (C, Local_Get_Current_Dir, "__gnat_get_current_dir");
525 Local_Get_Current_Dir (Buffer'Address, Path_Len'Address);
528 raise Use_Error with "current directory does not exist";
531 -- We need to resolve links because of RM A.16(47), which requires
532 -- that we not return alternative names for files.
534 return Normalize_Pathname (Buffer (1 .. Path_Len));
535 end Current_Directory;
537 ----------------------
538 -- Delete_Directory --
539 ----------------------
541 procedure Delete_Directory (Directory : String) is
543 -- First, the invalid cases
545 if not Is_Valid_Path_Name (Directory) then
546 raise Name_Error with
547 "invalid directory path name """ & Directory & '"';
549 elsif not Is_Directory (Directory) then
550 raise Name_Error with '"' & Directory & """ not a directory";
552 -- Do the deletion, checking for error
556 Dir_Name_C : constant String := Directory & ASCII.NUL;
558 if rmdir (Dir_Name_C) /= 0 then
560 "deletion of directory """ & Directory & """ failed";
564 end Delete_Directory;
570 procedure Delete_File (Name : String) is
574 -- First, the invalid cases
576 if not Is_Valid_Path_Name (Name) then
577 raise Name_Error with "invalid path name """ & Name & '"';
579 elsif not Is_Regular_File (Name)
580 and then not Is_Symbolic_Link (Name)
582 raise Name_Error with "file
""" & Name & """ does
not exist
";
585 -- Do actual deletion using System.OS_Lib.Delete_File
587 Delete_File (Name, Success);
590 raise Use_Error with "file
""" & Name & """ could
not be deleted
";
599 procedure Delete_Tree (Directory : String) is
600 Search : Search_Type;
601 Dir_Ent : Directory_Entry_Type;
603 -- First, the invalid cases
605 if not Is_Valid_Path_Name (Directory) then
606 raise Name_Error with
607 "invalid directory path name
""" & Directory & '"';
609 elsif not Is_Directory (Directory) then
610 raise Name_Error with '"' & Directory & """ not a directory
";
614 -- We used to change the current directory to Directory here,
615 -- allowing the use of a local Simple_Name for all references. This
616 -- turned out unfriendly to multitasking programs, where tasks
617 -- running in parallel of this Delete_Tree could see their current
618 -- directory change unpredictably. We now resort to Full_Name
619 -- computations to reach files and subdirs instead.
621 Start_Search (Search, Directory => Directory, Pattern => "");
622 while More_Entries (Search) loop
623 Get_Next_Entry (Search, Dir_Ent);
626 Fname : constant String := Full_Name (Dir_Ent);
627 Sname : constant String := Simple_Name (Dir_Ent);
630 if OS_Lib.Is_Directory (Fname) then
631 if Sname /= "." and then Sname /= ".." then
643 Dir_Name_C : constant String := Directory & ASCII.NUL;
646 if rmdir (Dir_Name_C) /= 0 then
648 "directory tree rooted
at """ &
649 Directory & """ could
not be deleted
";
659 function Exists (Name : String) return Boolean is
661 -- First, the invalid case
663 if not Is_Valid_Path_Name (Name) then
664 raise Name_Error with "invalid path name
""" & Name & '"';
667 -- The implementation is in File_Exists
669 return File_Exists (Name);
677 function Extension (Name : String) return String is
679 -- First, the invalid case
681 if not Is_Valid_Path_Name (Name) then
682 raise Name_Error with "invalid path name """ & Name & '"';
685 -- Look for first dot that is not followed by a directory separator
687 for Pos in reverse Name'Range loop
689 -- If a directory separator is found before a dot, there is no
692 if Is_In (Name (Pos), Dir_Seps) then
695 elsif Name (Pos) = '.' then
697 -- We found a dot, build the return value with lower bound 1
700 subtype Result_Type is String (1 .. Name'Last - Pos);
702 return Result_Type (Name (Pos + 1 .. Name'Last));
707 -- No dot were found, there is no extension
717 function File_Exists (Name : String) return Boolean is
718 function C_File_Exists (A : Address) return Integer;
719 pragma Import (C, C_File_Exists, "__gnat_file_exists
");
721 C_Name : String (1 .. Name'Length + 1);
724 C_Name (1 .. Name'Length) := Name;
725 C_Name (C_Name'Last) := ASCII.NUL;
726 return C_File_Exists (C_Name'Address) = 1;
733 procedure Finalize (Search : in out Search_Type) is
735 if Search.State /= null then
736 Free (Search.State.Dir_Contents);
745 function Full_Name (Name : String) return String is
747 -- First, the invalid case
749 if not Is_Valid_Path_Name (Name) then
750 raise Name_Error with "invalid path name
""" & Name & '"';
753 -- Build the return value with lower bound 1
755 -- Use System.OS_Lib.Normalize_Pathname
758 -- We need to resolve links because of (RM A.16(47)), which says
759 -- we must not return alternative names for files.
761 Value : constant String := Normalize_Pathname (Name);
762 subtype Result is String (1 .. Value'Length);
765 return Result (Value);
770 function Full_Name (Directory_Entry : Directory_Entry_Type) return String is
772 -- If the Directory_Entry is valid return the full name contained in the
775 if not Directory_Entry.Valid then
776 raise Status_Error with "invalid directory entry";
778 return To_String (Directory_Entry.Full_Name);
786 procedure Get_Next_Entry
787 (Search : in out Search_Type;
788 Directory_Entry : out Directory_Entry_Type)
791 -- A Search with no state implies the user has not called Start_Search
793 if Search.State = null then
794 raise Status_Error with "search not started";
797 -- If the next entry is No_Element it means the search is finished and
798 -- there are no more entries to return.
800 if Search.State.Next_Entry = No_Element then
801 raise Status_Error with "no more entries";
804 -- Populate Directory_Entry with the next entry and update the search
807 Directory_Entry := Element (Search.State.Next_Entry);
808 Next (Search.State.Next_Entry);
810 -- If Start_Search received a non-zero error code when trying to read
811 -- the file attributes of this entry, raise an Use_Error so the user
812 -- is aware that it was not possible to retrieve the attributes of this
815 if Directory_Entry.Attr_Error_Code /= 0 then
817 with To_String (Directory_Entry.Full_Name) & ": " &
818 Errno_Message (Err => Directory_Entry.Attr_Error_Code);
826 function Kind (Name : String) return File_Kind is
828 -- First, the invalid case
830 if not File_Exists (Name) then
831 raise Name_Error with "file """ & Name & """ does not exist";
833 -- If OK, return appropriate kind
835 elsif Is_Regular_File (Name) then
836 return Ordinary_File;
838 elsif Is_Directory (Name) then
846 function Kind (Directory_Entry : Directory_Entry_Type) return File_Kind is
848 if not Directory_Entry.Valid then
849 raise Status_Error with "invalid directory entry";
851 return Directory_Entry.Kind;
855 -----------------------
856 -- Modification_Time --
857 -----------------------
859 function Modification_Time (Name : String) return Time is
862 C_Name : aliased String (1 .. Name'Length + 1);
864 -- First, the invalid cases
866 if not (Is_Regular_File (Name) or else Is_Directory (Name)) then
867 raise Name_Error with '"' & Name & """ not a file
or directory
";
870 C_Name := Name & ASCII.NUL;
871 Date := C_Modification_Time (C_Name'Address);
873 if Date = Invalid_Time then
875 "Unable to get modification time
of the file
""" & Name & '"';
880 end Modification_Time;
882 function Modification_Time
883 (Directory_Entry : Directory_Entry_Type) return Ada.Calendar.Time
886 -- If the Directory_Entry is valid return the modification time
887 -- contained in the entry record. The modification time is recorded in
888 -- the entry since its cheap to query all the file the attributes in
889 -- one read when the directory is searched.
891 if not Directory_Entry.Valid then
892 raise Status_Error with "invalid directory entry";
894 return Directory_Entry.Modification_Time;
896 end Modification_Time;
902 function More_Entries (Search : Search_Type) return Boolean is
904 -- If the vector cursor Search.State.Next_Entry points to an element in
905 -- Search.State.Dir_Contents then there is another entry to return.
906 -- Otherwise, we return False.
908 if Search.State = null then
910 elsif Search.State.Next_Entry = No_Element then
917 ---------------------------
918 -- Name_Case_Equivalence --
919 ---------------------------
921 function Name_Case_Equivalence (Name : String) return Name_Case_Kind is
922 Dir_Path : Unbounded_String := To_Unbounded_String (Name);
924 Test_File : Directory_Entry_Type;
926 function GNAT_name_case_equivalence return Interfaces.C.int;
927 pragma Import (C, GNAT_name_case_equivalence,
928 "__gnat_name_case_equivalence");
931 -- Check for the invalid case
933 if not Is_Valid_Path_Name (Name) then
934 raise Name_Error with "invalid path name """ & Name & '"';
937 -- We were passed a "full path
" to a file and not a directory, so obtain
938 -- the containing directory.
940 if Is_Regular_File (Name) then
941 Dir_Path := To_Unbounded_String (Containing_Directory (Name));
944 -- Since we must obtain a file within the Name directory, let's grab the
945 -- first for our test. When the directory is empty, Get_Next_Entry will
946 -- fall through to a Status_Error where we then take the imprecise
947 -- default for the host OS.
951 Directory => To_String (Dir_Path),
953 Filter => [Directory => False, others => True]);
956 Get_Next_Entry (S, Test_File);
958 -- Check if we have found a "caseable
" file
960 exit when To_Lower (Simple_Name (Test_File)) /=
961 To_Upper (Simple_Name (Test_File));
966 -- Search for files within the directory with the same name, but
969 Start_Search_Internal
971 Directory => To_String (Dir_Path),
972 Pattern => Simple_Name (Test_File),
973 Filter => [Directory => False, others => True],
974 Case_Insensitive => True);
976 -- We will find at least one match due to the search hitting our test
979 Get_Next_Entry (S, Test_File);
982 -- If we hit two then we know we have a case-sensitive directory
984 Get_Next_Entry (S, Test_File);
987 return Case_Sensitive;
993 -- Finally, we have a file in the directory whose name is unique and
994 -- "caseable
". Let's test to see if the OS is able to identify the file
995 -- in multiple cases, which will give us our result without having to
996 -- resort to defaults.
998 if Exists (To_String (Dir_Path) & Directory_Separator
999 & To_Lower (Simple_Name (Test_File)))
1000 and then Exists (To_String (Dir_Path) & Directory_Separator
1001 & To_Upper (Simple_Name (Test_File)))
1003 return Case_Preserving;
1006 return Case_Sensitive;
1008 when Status_Error =>
1010 -- There is no unobtrusive way to check for the directory's casing so
1011 -- return the OS default.
1013 return Name_Case_Kind'Val (Integer (GNAT_name_case_equivalence));
1014 end Name_Case_Equivalence;
1020 procedure Rename (Old_Name, New_Name : String) is
1024 -- First, the invalid cases
1026 if not Is_Valid_Path_Name (Old_Name) then
1027 raise Name_Error with "invalid old path name
""" & Old_Name & '"';
1029 elsif not Is_Valid_Path_Name (New_Name) then
1030 raise Name_Error with "invalid new path name """ & New_Name & '"';
1032 elsif not Is_Regular_File (Old_Name)
1033 and then not Is_Directory (Old_Name)
1035 raise Name_Error with "old file
""" & Old_Name & """ does
not exist
";
1037 elsif Is_Regular_File (New_Name) or else Is_Directory (New_Name) then
1038 raise Use_Error with
1039 "new name
""" & New_Name
1040 & """ designates a file that already exists
";
1042 -- Do actual rename using System.OS_Lib.Rename_File
1045 Rename_File (Old_Name, New_Name, Success);
1049 -- AI05-0231-1: Name_Error should be raised in case a directory
1050 -- component of New_Name does not exist (as in New_Name =>
1051 -- "/no
-such
-dir
/new-filename
"). ENOENT indicates that. ENOENT
1052 -- also indicate that the Old_Name does not exist, but we already
1053 -- checked for that above. All other errors are Use_Error.
1055 if Errno = ENOENT then
1056 raise Name_Error with
1057 "file
""" & Containing_Directory (New_Name) & """ not found
";
1060 raise Use_Error with
1061 "file
""" & Old_Name & """ could
not be renamed
";
1072 (Directory : String;
1074 Filter : Filter_Type := [others => True];
1075 Process : not null access procedure
1076 (Directory_Entry : Directory_Entry_Type))
1079 Directory_Entry : Directory_Entry_Type;
1082 Start_Search (Srch, Directory, Pattern, Filter);
1083 while More_Entries (Srch) loop
1084 Get_Next_Entry (Srch, Directory_Entry);
1085 Process (Directory_Entry);
1095 procedure Set_Directory (Directory : String) is
1096 Dir_Name_C : constant String := Directory & ASCII.NUL;
1098 if not Is_Valid_Path_Name (Directory) then
1099 raise Name_Error with
1100 "invalid directory path name
& """ & Directory & '"';
1102 elsif not Is_Directory (Directory) then
1103 raise Name_Error with
1104 "directory """ & Directory & """ does not exist";
1106 elsif chdir (Dir_Name_C) /= 0 then
1107 raise Name_Error with
1108 "could not set to designated directory """ & Directory & '"';
1116 function Simple_Name (Name : String) return String is
1118 function Simple_Name_Internal (Path : String) return String;
1119 -- This function does the job
1121 --------------------------
1122 -- Simple_Name_Internal --
1123 --------------------------
1125 function Simple_Name_Internal (Path : String) return String is
1126 Cut_Start : Natural :=
1127 Strings.Fixed.Index (Path, Dir_Seps, Going => Strings.Backward);
1129 -- Cut_End points to the last simple name character
1131 Cut_End : Natural := Path'Last;
1134 -- Root directories are considered simple
1136 if Is_Root_Directory_Name (Path) then
1140 -- Handle trailing directory separators
1142 if Cut_Start = Path'Last then
1143 Cut_End := Path'Last - 1;
1144 Cut_Start := Strings.Fixed.Index
1145 (Path (Path'First .. Path'Last - 1),
1146 Dir_Seps, Going => Strings.Backward);
1149 -- Cut_Start points to the first simple name character
1151 Cut_Start := (if Cut_Start = 0 then Path'First else Cut_Start + 1);
1153 Check_For_Standard_Dirs : declare
1154 BN : constant String := Path (Cut_Start .. Cut_End);
1156 Has_Drive_Letter : constant Boolean :=
1157 OS_Lib.Path_Separator /= ':';
1158 -- If Path separator is not ':' then we are on a DOS based OS
1159 -- where this character is used as a drive letter separator.
1162 if BN = "." or else BN = ".." then
1165 elsif Has_Drive_Letter
1166 and then BN'Length > 2
1167 and then Characters.Handling.Is_Letter (BN (BN'First))
1168 and then BN (BN'First + 1) = ':'
1170 -- We have a DOS drive letter prefix, remove it
1172 return BN (BN'First + 2 .. BN'Last);
1177 end Check_For_Standard_Dirs;
1178 end Simple_Name_Internal;
1180 -- Start of processing for Simple_Name
1183 -- First, the invalid case
1185 if not Is_Valid_Path_Name (Name) then
1186 raise Name_Error with "invalid path name
""" & Name & '"';
1189 -- Build the value to return with lower bound 1
1192 Value : constant String := Simple_Name_Internal (Name);
1193 subtype Result is String (1 .. Value'Length);
1195 return Result (Value);
1200 function Simple_Name
1201 (Directory_Entry : Directory_Entry_Type) return String is
1203 -- If the Directory_Entry is valid return the simple name contained in
1204 -- the entry record.
1206 if not Directory_Entry.Valid then
1207 raise Status_Error with "invalid directory entry";
1209 return To_String (Directory_Entry.Name);
1217 function Size (Name : String) return File_Size is
1218 C_Name : String (1 .. Name'Length + 1);
1220 function C_Size (Name : Address) return int64;
1221 pragma Import (C, C_Size, "__gnat_named_file_length");
1224 -- First, the invalid case
1226 if not Is_Regular_File (Name) then
1227 raise Name_Error with "file """ & Name & """ does not exist";
1230 C_Name (1 .. Name'Length) := Name;
1231 C_Name (C_Name'Last) := ASCII.NUL;
1232 return File_Size (C_Size (C_Name'Address));
1236 function Size (Directory_Entry : Directory_Entry_Type) return File_Size is
1238 -- If the Directory_Entry is valid return the size contained in the
1239 -- entry record. The size is recorded in the entry since it is cheap to
1240 -- query all the file the attributes in one read when the directory is
1243 if not Directory_Entry.Valid then
1244 raise Status_Error with "invalid directory entry";
1246 return Directory_Entry.Size;
1254 procedure Start_Search
1255 (Search : in out Search_Type;
1258 Filter : Filter_Type := [others => True])
1261 Start_Search_Internal (Search, Directory, Pattern, Filter, False);
1264 ---------------------------
1265 -- Start_Search_Internal --
1266 ---------------------------
1268 procedure Start_Search_Internal
1269 (Search : in out Search_Type;
1272 Filter : Filter_Type := [others => True];
1273 Case_Insensitive : Boolean)
1275 function closedir (Directory : DIRs) return Integer
1276 with Import, External_Name => "__gnat_closedir", Convention => C;
1277 -- C lib function to close Directory
1279 function opendir (Directory : String) return DIRs
1280 with Import, External_Name => "__gnat_opendir", Convention => C;
1281 -- C lib function to open Directory
1283 function readdir_gnat
1284 (Directory : Address;
1286 Last : not null access Integer) return Address
1287 with Import, External_Name => "__gnat_readdir", Convention => C;
1288 -- Read the next item in Directory
1290 Dir_Name_C : constant String := Directory & ASCII.NUL;
1291 Dir_Entry_Buffer : array (1 .. SIZEOF_struct_dirent_alloc) of Character;
1292 Dir_Pointer : Dir_Type_Value;
1293 File_Name_Addr : Address;
1294 File_Name_Len : aliased Integer;
1295 Pattern_Regex : Regexp;
1297 Call_Result : Integer;
1298 pragma Warnings (Off, Call_Result);
1299 -- Result of calling a C function that returns a status
1302 -- Check that Directory is a valid directory
1304 if not Is_Directory (Directory) then
1305 raise Name_Error with
1306 "unknown directory """ & Simple_Name (Directory) & '"';
1309 -- Check and compile the pattern
1312 Case_Sensitive : Boolean := Is_Path_Name_Case_Sensitive;
1314 if Case_Insensitive then
1315 Case_Sensitive := False;
1319 Compile (Pattern, Glob => True, Case_Sensitive => Case_Sensitive);
1321 when Error_In_Regexp =>
1322 raise Name_Error with "invalid pattern
""" & Pattern & '"';
1327 Dir_Pointer := Dir_Type_Value (opendir (Dir_Name_C));
1329 if Dir_Pointer = No_Dir then
1330 raise Use_Error with
1331 "unreadable directory """ & Simple_Name (Directory) & '"';
1334 -- If needed, finalize Search. Note: we should probably raise an
1335 -- exception here if Search belongs to an existing search rather than
1336 -- quietly end it. However, we first need to check that it won't break
1337 -- existing software.
1341 -- Allocate and initialize the search state
1343 Search.State := new Search_State'
1344 (Ada.Finalization.Controlled with
1345 Dir_Contents => new Vector,
1346 Next_Entry => No_Element);
1348 -- Increase the size of the Dir_Contents vector so it does not need to
1349 -- grow for most reasonable directory searches.
1351 Search.State.Dir_Contents.Reserve_Capacity (Dir_Vector_Initial_Size);
1353 -- Read the contents of Directory into Search.State
1356 -- Get next item in the directory
1360 (Address (Dir_Pointer),
1361 Dir_Entry_Buffer'Address,
1362 File_Name_Len'Access);
1364 exit when File_Name_Addr = Null_Address;
1366 -- If the file name matches the Pattern and the file type matches
1367 -- the Filter add it to our search vector.
1370 subtype File_Name_String is String (1 .. File_Name_Len);
1372 File_Name : constant File_Name_String
1373 with Import, Address => File_Name_Addr;
1376 if Match (File_Name, Pattern_Regex) then
1378 Path_C : constant String :=
1379 Compose (Directory, File_Name) & ASCII.NUL;
1380 Path : String renames
1381 Path_C (Path_C'First .. Path_C'Last - 1);
1382 Attr : aliased File_Attributes;
1386 type Result (Found : Boolean := False) is record
1396 Res : Result := (Found => False);
1398 -- Get the file attributes for the directory item
1400 Reset_Attributes (Attr'Access);
1401 Exists := File_Exists_Attr (Path_C'Address, Attr'Access);
1402 Error := Error_Attributes (Attr'Access);
1404 -- If there was an error when trying to read the attributes
1405 -- of a Directory entry, record the error so it can be
1406 -- propagated to the user when they interate through the
1407 -- directory results.
1410 Search.State.Dir_Contents.Append
1411 (Directory_Entry_Type'
1413 Name => To_Unbounded_String (File_Name),
1414 Full_Name => To_Unbounded_String (Path),
1415 Attr_Error_Code => Error,
1418 -- Otherwise, if the file exists and matches the file kind
1419 -- Filter, add the file to the search results. We capture
1420 -- the size and modification time here as we have already
1421 -- the entry's attributes above.
1423 elsif Exists = 1 then
1424 if Is_Regular_File_Attr (Path_C'Address, Attr'Access) = 1
1426 if Filter (Ordinary_File) then
1427 Res := (Found => True,
1428 Kind => Ordinary_File,
1431 (-1, Path_C'Address, Attr'Access)));
1434 elsif Is_Directory_Attr (Path_C'Address, Attr'Access) = 1
1436 if Filter (File_Kind'First) then
1437 Res := (Found => True,
1438 Kind => File_Kind'First,
1442 elsif Filter (Special_File) then
1443 Res := (Found => True,
1444 Kind => Special_File,
1449 Search.State.Dir_Contents.Append
1450 (Directory_Entry_Type'
1453 To_Unbounded_String (File_Name),
1454 Full_Name => To_Unbounded_String (Path),
1455 Attr_Error_Code => 0,
1457 Modification_Time => Modification_Time (Path),
1466 -- Set the first entry to be returned to the user to be the first
1467 -- element of the Dir_Contents vector. If no items were found, First
1468 -- will return No_Element, which signals
1469 Search.State.Next_Entry := Search.State.Dir_Contents.First;
1471 -- Search is finished, close Directory
1473 Call_Result := closedir (DIRs (Dir_Pointer));
1475 end Start_Search_Internal;
1477 end Ada.Directories;