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-2010, 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
.Calendar
.Formatting
; use Ada
.Calendar
.Formatting
;
34 with Ada
.Directories
.Validity
; use Ada
.Directories
.Validity
;
35 with Ada
.Strings
.Maps
;
36 with Ada
.Strings
.Fixed
;
37 with Ada
.Strings
.Unbounded
; use Ada
.Strings
.Unbounded
;
38 with Ada
.Unchecked_Conversion
;
39 with Ada
.Unchecked_Deallocation
;
40 with Ada
.Characters
.Handling
; use Ada
.Characters
.Handling
;
42 with System
.CRTL
; use System
.CRTL
;
43 with System
.OS_Lib
; use System
.OS_Lib
;
44 with System
.Regexp
; use System
.Regexp
;
45 with System
.File_IO
; use System
.File_IO
;
48 package body Ada
.Directories
is
50 Filename_Max
: constant Integer := 1024;
51 -- 1024 is the value of FILENAME_MAX in stdio.h
53 type Dir_Type_Value
is new System
.Address
;
54 -- This is the low-level address directory structure as returned by the C
57 No_Dir
: constant Dir_Type_Value
:= Dir_Type_Value
(System
.Null_Address
);
59 Dir_Separator
: constant Character;
60 pragma Import
(C
, Dir_Separator
, "__gnat_dir_separator");
61 -- Running system default directory separator
63 Dir_Seps
: constant Ada
.Strings
.Maps
.Character_Set
:=
64 Ada
.Strings
.Maps
.To_Set
("/\");
65 -- UNIX and DOS style directory separators
68 pragma Import (C, Max_Path, "__gnat_max_path_len
");
69 -- The maximum length of a path
71 type Search_Data is record
72 Is_Valid : Boolean := False;
73 Name : Unbounded_String;
76 Dir : Dir_Type_Value := No_Dir;
77 Entry_Fetched : Boolean := False;
78 Dir_Entry : Directory_Entry_Type;
80 -- The current state of a search
82 Empty_String : constant String := (1 .. 0 => ASCII.NUL);
83 -- Empty string, returned by function Extension when there is no extension
85 procedure Free is new Ada.Unchecked_Deallocation (Search_Data, Search_Ptr);
87 procedure Close (Dir : Dir_Type_Value);
89 function File_Exists (Name : String) return Boolean;
90 -- Returns True if the named file exists
92 procedure Fetch_Next_Entry (Search : Search_Type);
93 -- Get the next entry in a directory, setting Entry_Fetched if successful
94 -- or resetting Is_Valid if not.
100 function Base_Name (Name : String) return String is
101 Simple : constant String := Simple_Name (Name);
102 -- Simple'First is guaranteed to be 1
105 -- Look for the last dot in the file name and return the part of the
106 -- file name preceding this last dot. If the first dot is the first
107 -- character of the file name, the base name is the empty string.
109 for Pos in reverse Simple'Range loop
110 if Simple (Pos) = '.' then
111 return Simple (1 .. Pos - 1);
115 -- If there is no dot, return the complete file name
124 procedure Close (Dir : Dir_Type_Value) is
126 pragma Warnings (Off, Discard);
128 function closedir (directory : DIRs) return Integer;
129 pragma Import (C, closedir, "__gnat_closedir
");
132 Discard := closedir (DIRs (Dir));
140 (Containing_Directory : String := "";
142 Extension : String := "") return String
144 Result : String (1 .. Containing_Directory'Length +
145 Name'Length + Extension'Length + 2);
149 -- First, deal with the invalid cases
151 if Containing_Directory /= ""
152 and then not Is_Valid_Path_Name (Containing_Directory)
154 raise Name_Error with
155 "invalid directory path name
""" & Containing_Directory & '"';
158 Extension'Length = 0 and then (not Is_Valid_Simple_Name (Name))
160 raise Name_Error with
161 "invalid simple name """ & Name & '"';
163 elsif Extension'Length /= 0
164 and then not Is_Valid_Simple_Name (Name & '.' & Extension)
166 raise Name_Error with
167 "invalid file name
""" & Name & '.' & Extension & '"';
169 -- This is not an invalid case so build the path name
172 Last := Containing_Directory'Length;
173 Result (1 .. Last) := Containing_Directory;
175 -- Add a directory separator if needed
177 if Last /= 0 and then Result (Last) /= Dir_Separator then
179 Result (Last) := Dir_Separator;
184 Result (Last + 1 .. Last + Name'Length) := Name;
185 Last := Last + Name'Length;
187 -- If extension was specified, add dot followed by this extension
189 if Extension'Length /= 0 then
191 Result (Last) := '.';
192 Result (Last + 1 .. Last + Extension'Length) := Extension;
193 Last := Last + Extension'Length;
196 return Result (1 .. Last);
200 --------------------------
201 -- Containing_Directory --
202 --------------------------
204 function Containing_Directory (Name : String) return String is
206 -- First, the invalid case
208 if not Is_Valid_Path_Name (Name) then
209 raise Name_Error with "invalid path name """ & Name & '"';
213 -- We need to resolve links because of A.16(47), since we must not
214 -- return alternative names for files.
216 Norm : constant String := Normalize_Pathname (Name);
217 Last_DS : constant Natural :=
219 (Name, Dir_Seps, Going => Strings.Backward);
224 -- There is no directory separator, returns current working
227 return Current_Directory;
229 -- If Name indicates a root directory, raise Use_Error, because
230 -- it has no containing directory.
239 and then Norm
(Norm
'Last - 1 .. Norm
'Last) = ":\"
240 and then (Norm (Norm'First) in 'a' .. 'z'
241 or else Norm (Norm'First) in 'A' .. 'Z'))))
244 "directory
""" & Name & """ has no containing directory
";
248 Last : Positive := Last_DS - Name'First + 1;
249 Result : String (1 .. Last);
252 Result := Name (Name'First .. Last_DS);
254 -- Remove any trailing directory separator, except as the
255 -- first character or the first character following a drive
256 -- number on Windows.
262 Result (Last) /= Directory_Separator;
266 and then Result (2) = ':'
268 (Result (1) in 'A' .. 'Z'
270 Result (1) in 'a' .. 'z');
275 -- Special case of current directory, identified by "."
277 if Last = 1 and then Result (1) = '.' then
278 return Current_Directory;
280 -- Special case of "..": the current directory may be a root
283 elsif Last = 2 and then Result (1 .. 2) = ".." then
284 return Containing_Directory (Current_Directory);
287 return Result (1 .. Last);
293 end Containing_Directory;
300 (Source_Name : String;
301 Target_Name : String;
305 Mode : Copy_Mode := Overwrite;
306 Preserve : Attribute := None;
309 -- First, the invalid cases
311 if not Is_Valid_Path_Name (Source_Name) then
312 raise Name_Error with
313 "invalid source path name
""" & Source_Name & '"';
315 elsif not Is_Valid_Path_Name (Target_Name) then
316 raise Name_Error with
317 "invalid target path name """ & Target_Name & '"';
319 elsif not Is_Regular_File (Source_Name) then
320 raise Name_Error with '"' & Source_Name & """ is not a file";
322 elsif Is_Directory (Target_Name) then
323 raise Use_Error with "target """ & Target_Name & """ is a directory";
326 if Form'Length > 0 then
328 Formstr : String (1 .. Form'Length + 1);
332 -- Acquire form string, setting required NUL terminator
334 Formstr (1 .. Form'Length) := Form;
335 Formstr (Formstr'Last) := ASCII.NUL;
337 -- Convert form string to lower case
339 for J in Formstr'Range loop
340 if Formstr (J) in 'A
' .. 'Z
' then
342 Character'Val (Character'Pos (Formstr (J)) + 32);
348 Form_Parameter (Formstr, "mode", V1, V2);
353 elsif Formstr (V1 .. V2) = "copy" then
356 elsif Formstr (V1 .. V2) = "overwrite" then
359 elsif Formstr (V1 .. V2) = "append" then
363 raise Use_Error with "invalid Form";
366 Form_Parameter (Formstr, "preserve", V1, V2);
371 elsif Formstr (V1 .. V2) = "timestamps" then
372 Preserve := Time_Stamps;
374 elsif Formstr (V1 .. V2) = "all_attributes" then
377 elsif Formstr (V1 .. V2) = "no_attributes" then
381 raise Use_Error with "invalid Form";
386 -- The implementation uses System.OS_Lib.Copy_File
388 Copy_File (Source_Name, Target_Name, Success, Mode, Preserve);
391 raise Use_Error with "copy of """ & Source_Name & """ failed";
396 ----------------------
397 -- Create_Directory --
398 ----------------------
400 procedure Create_Directory
401 (New_Directory : String;
404 pragma Unreferenced (Form);
406 C_Dir_Name : constant String := New_Directory & ASCII.NUL;
408 function mkdir (Dir_Name : String) return Integer;
409 pragma Import (C, mkdir, "__gnat_mkdir");
412 -- First, the invalid case
414 if not Is_Valid_Path_Name (New_Directory) then
415 raise Name_Error with
416 "invalid new directory path name """ & New_Directory & '"';
419 if mkdir (C_Dir_Name) /= 0 then
421 "creation
of new directory
""" & New_Directory & """ failed
";
424 end Create_Directory;
430 procedure Create_Path
431 (New_Directory : String;
434 pragma Unreferenced (Form);
436 New_Dir : String (1 .. New_Directory'Length + 1);
437 Last : Positive := 1;
440 -- First, the invalid case
442 if not Is_Valid_Path_Name (New_Directory) then
443 raise Name_Error with
444 "invalid
new directory path name
""" & New_Directory & '"';
447 -- Build New_Dir with a directory separator at the end, so that the
448 -- complete path will be found in the loop below.
450 New_Dir (1 .. New_Directory'Length) := New_Directory;
451 New_Dir (New_Dir'Last) := Directory_Separator;
453 -- Create, if necessary, each directory in the path
455 for J in 2 .. New_Dir'Last loop
457 -- Look for the end of an intermediate directory
459 if New_Dir (J) /= Dir_Separator and then
464 -- We have found a new intermediate directory each time we find
465 -- a first directory separator.
467 elsif New_Dir (J - 1) /= Dir_Separator and then
468 New_Dir (J - 1) /= '/'
471 -- No need to create the directory if it already exists
473 if Is_Directory (New_Dir (1 .. Last)) then
476 -- It is an error if a file with such a name already exists
478 elsif Is_Regular_File (New_Dir (1 .. Last)) then
480 "file """ & New_Dir (1 .. Last) & """ already exists";
483 Create_Directory (New_Directory => New_Dir (1 .. Last));
490 -----------------------
491 -- Current_Directory --
492 -----------------------
494 function Current_Directory return String is
495 Path_Len : Natural := Max_Path;
496 Buffer : String (1 .. 1 + Max_Path + 1);
498 procedure Local_Get_Current_Dir
499 (Dir : System.Address;
500 Length : System.Address);
501 pragma Import (C, Local_Get_Current_Dir, "__gnat_get_current_dir");
504 Local_Get_Current_Dir (Buffer'Address, Path_Len'Address);
507 -- We need to resolve links because of A.16(47), since we must not
508 -- return alternative names for files
509 Cur : constant String := Normalize_Pathname (Buffer (1 .. Path_Len));
512 if Cur'Length > 1 and then Cur (Cur'Last) = Dir_Separator then
513 return Cur (1 .. Cur'Last - 1);
518 end Current_Directory;
520 ----------------------
521 -- Delete_Directory --
522 ----------------------
524 procedure Delete_Directory (Directory : String) is
526 -- First, the invalid cases
528 if not Is_Valid_Path_Name (Directory) then
529 raise Name_Error with
530 "invalid directory path name """ & Directory & '"';
532 elsif not Is_Directory (Directory) then
533 raise Name_Error with '"' & Directory & """ not a directory";
537 C_Dir_Name : constant String := Directory & ASCII.NUL;
540 if rmdir (C_Dir_Name) /= 0 then
542 "deletion of directory """ & Directory & """ failed";
546 end Delete_Directory;
552 procedure Delete_File (Name : String) is
556 -- First, the invalid cases
558 if not Is_Valid_Path_Name (Name) then
559 raise Name_Error with "invalid path name """ & Name & '"';
561 elsif not Is_Regular_File (Name) then
562 raise Name_Error with "file
""" & Name & """ does
not exist
";
565 -- The implementation uses System.OS_Lib.Delete_File
567 Delete_File (Name, Success);
570 raise Use_Error with "file
""" & Name & """ could
not be deleted
";
579 procedure Delete_Tree (Directory : String) is
580 Current_Dir : constant String := Current_Directory;
581 Search : Search_Type;
582 Dir_Ent : Directory_Entry_Type;
584 -- First, the invalid cases
586 if not Is_Valid_Path_Name (Directory) then
587 raise Name_Error with
588 "invalid directory path name
""" & Directory & '"';
590 elsif not Is_Directory (Directory) then
591 raise Name_Error with '"' & Directory & """ not a directory
";
594 Set_Directory (Directory);
595 Start_Search (Search, Directory => ".", Pattern => "");
597 while More_Entries (Search) loop
598 Get_Next_Entry (Search, Dir_Ent);
601 File_Name : constant String := Simple_Name (Dir_Ent);
604 if System.OS_Lib.Is_Directory (File_Name) then
605 if File_Name /= "." and then File_Name /= ".." then
606 Delete_Tree (File_Name);
610 Delete_File (File_Name);
615 Set_Directory (Current_Dir);
619 C_Dir_Name : constant String := Directory & ASCII.NUL;
622 if rmdir (C_Dir_Name) /= 0 then
624 "directory tree rooted
at """ &
625 Directory & """ could
not be deleted
";
635 function Exists (Name : String) return Boolean is
637 -- First, the invalid case
639 if not Is_Valid_Path_Name (Name) then
640 raise Name_Error with "invalid path name
""" & Name & '"';
643 -- The implementation is in File_Exists
645 return File_Exists (Name);
653 function Extension (Name : String) return String is
655 -- First, the invalid case
657 if not Is_Valid_Path_Name (Name) then
658 raise Name_Error with "invalid path name """ & Name & '"';
661 -- Look for first dot that is not followed by a directory separator
663 for Pos in reverse Name'Range loop
665 -- If a directory separator is found before a dot, there is no
668 if Name (Pos) = Dir_Separator then
671 elsif Name (Pos) = '.' then
673 -- We found a dot, build the return value with lower bound 1
676 subtype Result_Type is String (1 .. Name'Last - Pos);
678 return Result_Type (Name (Pos + 1 .. Name'Last));
683 -- No dot were found, there is no extension
689 ----------------------
690 -- Fetch_Next_Entry --
691 ----------------------
693 procedure Fetch_Next_Entry (Search : Search_Type) is
694 Name : String (1 .. 255);
697 Kind : File_Kind := Ordinary_File;
698 -- Initialized to avoid a compilation warning
700 Filename_Addr : System.Address;
701 Filename_Len : aliased Integer;
703 Buffer : array (0 .. Filename_Max + 12) of Character;
704 -- 12 is the size of the dirent structure (see dirent.h), without the
705 -- field for the filename.
707 function readdir_gnat
708 (Directory : System.Address;
709 Buffer : System.Address;
710 Last : not null access Integer) return System.Address;
711 pragma Import (C, readdir_gnat, "__gnat_readdir
");
716 -- Search.Value.Is_Valid is always True when Fetch_Next_Entry is called
721 (System.Address (Search.Value.Dir),
723 Filename_Len'Access);
725 -- If no matching entry is found, set Is_Valid to False
727 if Filename_Addr = System.Null_Address then
728 Search.Value.Is_Valid := False;
733 subtype Path_String is String (1 .. Filename_Len);
734 type Path_String_Access is access Path_String;
736 function Address_To_Access is new
737 Ada.Unchecked_Conversion
739 Target => Path_String_Access);
741 Path_Access : constant Path_String_Access :=
742 Address_To_Access (Filename_Addr);
745 Last := Filename_Len;
746 Name (1 .. Last) := Path_Access.all;
749 -- Check if the entry matches the pattern
751 if Match (Name (1 .. Last), Search.Value.Pattern) then
753 Full_Name : constant String :=
756 (Search.Value.Name), Name (1 .. Last));
757 Found : Boolean := False;
760 if File_Exists (Full_Name) then
762 -- Now check if the file kind matches the filter
764 if Is_Regular_File (Full_Name) then
765 if Search.Value.Filter (Ordinary_File) then
766 Kind := Ordinary_File;
770 elsif Is_Directory (Full_Name) then
771 if Search.Value.Filter (Directory) then
776 elsif Search.Value.Filter (Special_File) then
777 Kind := Special_File;
781 -- If it does, update Search and return
784 Search.Value.Entry_Fetched := True;
785 Search.Value.Dir_Entry :=
787 Simple => To_Unbounded_String (Name (1 .. Last)),
788 Full => To_Unbounded_String (Full_Name),
796 end Fetch_Next_Entry;
802 function File_Exists (Name : String) return Boolean is
803 function C_File_Exists (A : System.Address) return Integer;
804 pragma Import (C, C_File_Exists, "__gnat_file_exists
");
806 C_Name : String (1 .. Name'Length + 1);
809 C_Name (1 .. Name'Length) := Name;
810 C_Name (C_Name'Last) := ASCII.NUL;
811 return C_File_Exists (C_Name (1)'Address) = 1;
818 procedure Finalize (Search : in out Search_Type) is
820 if Search.Value /= null then
822 -- Close the directory, if one is open
824 if Search.Value.Dir /= No_Dir then
825 Close (Search.Value.Dir);
836 function Full_Name (Name : String) return String is
838 -- First, the invalid case
840 if not Is_Valid_Path_Name (Name) then
841 raise Name_Error with "invalid path name
""" & Name & '"';
844 -- Build the return value with lower bound 1
846 -- Use System.OS_Lib.Normalize_Pathname
849 -- We need to resolve links because of A.16(47), since we must not
850 -- return alternative names for files
851 Value : constant String := Normalize_Pathname (Name);
852 subtype Result is String (1 .. Value'Length);
854 return Result (Value);
859 function Full_Name (Directory_Entry : Directory_Entry_Type) return String is
861 -- First, the invalid case
863 if not Directory_Entry.Is_Valid then
864 raise Status_Error with "invalid directory entry";
867 -- The value to return has already been computed
869 return To_String (Directory_Entry.Full);
877 procedure Get_Next_Entry
878 (Search : in out Search_Type;
879 Directory_Entry : out Directory_Entry_Type)
882 -- First, the invalid case
884 if Search.Value = null or else not Search.Value.Is_Valid then
885 raise Status_Error with "invalid search";
888 -- Fetch the next entry, if needed
890 if not Search.Value.Entry_Fetched then
891 Fetch_Next_Entry (Search);
894 -- It is an error if no valid entry is found
896 if not Search.Value.Is_Valid then
897 raise Status_Error with "no next entry";
900 -- Reset Entry_Fetched and return the entry
902 Search.Value.Entry_Fetched := False;
903 Directory_Entry := Search.Value.Dir_Entry;
911 function Kind (Name : String) return File_Kind is
913 -- First, the invalid case
915 if not File_Exists (Name) then
916 raise Name_Error with "file """ & Name & """ does not exist";
918 elsif Is_Regular_File (Name) then
919 return Ordinary_File;
921 elsif Is_Directory (Name) then
929 function Kind (Directory_Entry : Directory_Entry_Type) return File_Kind is
931 -- First, the invalid case
933 if not Directory_Entry.Is_Valid then
934 raise Status_Error with "invalid directory entry";
937 -- The value to return has already be computed
939 return Directory_Entry.Kind;
943 -----------------------
944 -- Modification_Time --
945 -----------------------
947 function Modification_Time (Name : String) return Time is
953 Minute : Minute_Type;
954 Second : Second_Type;
958 -- First, the invalid cases
960 if not (Is_Regular_File (Name) or else Is_Directory (Name)) then
961 raise Name_Error with '"' & Name & """ not a file
or directory
";
964 Date := File_Time_Stamp (Name);
966 -- Break down the time stamp into its constituents relative to GMT.
967 -- This version of Split does not recognize leap seconds or buffer
968 -- space for time zone processing.
970 GM_Split (Date, Year, Month, Day, Hour, Minute, Second);
972 -- On OpenVMS, the resulting time value must be in the local time
973 -- zone. Ada.Calendar.Time_Of is exactly what we need. Note that
974 -- in both cases, the sub seconds are set to zero (0.0) because the
975 -- time stamp does not store them in its value.
980 (Year, Month, Day, Seconds_Of (Hour, Minute, Second, 0.0));
982 -- On Unix and Windows, the result must be in GMT. Ada.Calendar.
983 -- Formatting.Time_Of with default time zone of zero (0) is the
984 -- routine of choice.
987 Result := Time_Of (Year, Month, Day, Hour, Minute, Second, 0.0);
992 end Modification_Time;
994 function Modification_Time
995 (Directory_Entry : Directory_Entry_Type) return Ada.Calendar.Time
998 -- First, the invalid case
1000 if not Directory_Entry.Is_Valid then
1001 raise Status_Error with "invalid directory
entry";
1004 -- The value to return has already be computed
1006 return Modification_Time (To_String (Directory_Entry.Full));
1008 end Modification_Time;
1014 function More_Entries (Search : Search_Type) return Boolean is
1016 if Search.Value = null then
1019 elsif Search.Value.Is_Valid then
1021 -- Fetch the next entry, if needed
1023 if not Search.Value.Entry_Fetched then
1024 Fetch_Next_Entry (Search);
1028 return Search.Value.Is_Valid;
1035 procedure Rename (Old_Name, New_Name : String) is
1039 -- First, the invalid cases
1041 if not Is_Valid_Path_Name (Old_Name) then
1042 raise Name_Error with "invalid old path name
""" & Old_Name & '"';
1044 elsif not Is_Valid_Path_Name (New_Name) then
1045 raise Name_Error with "invalid new path name """ & New_Name & '"';
1047 elsif not Is_Regular_File (Old_Name)
1048 and then not Is_Directory (Old_Name)
1050 raise Name_Error with "old file
""" & Old_Name & """ does
not exist
";
1052 elsif Is_Regular_File (New_Name) or else Is_Directory (New_Name) then
1053 raise Use_Error with
1054 "new name
""" & New_Name
1055 & """ designates a file that already exists
";
1058 -- The implementation uses System.OS_Lib.Rename_File
1060 Rename_File (Old_Name, New_Name, Success);
1063 raise Use_Error with
1064 "file
""" & Old_Name & """ could
not be renamed
";
1074 (Directory : String;
1076 Filter : Filter_Type := (others => True);
1077 Process : not null access procedure
1078 (Directory_Entry : Directory_Entry_Type))
1081 Directory_Entry : Directory_Entry_Type;
1084 Start_Search (Srch, Directory, Pattern, Filter);
1086 while More_Entries (Srch) loop
1087 Get_Next_Entry (Srch, Directory_Entry);
1088 Process (Directory_Entry);
1098 procedure Set_Directory (Directory : String) is
1099 C_Dir_Name : constant String := Directory & ASCII.NUL;
1101 if not Is_Valid_Path_Name (Directory) then
1102 raise Name_Error with
1103 "invalid directory path name
& """ & Directory & '"';
1105 elsif not Is_Directory (Directory) then
1106 raise Name_Error with
1107 "directory """ & Directory & """ does not exist";
1109 elsif chdir (C_Dir_Name) /= 0 then
1110 raise Name_Error with
1111 "could not set to designated directory """ & Directory & '"';
1119 function Simple_Name (Name : String) return String is
1121 function Simple_Name_Internal (Path : String) return String;
1122 -- This function does the job
1124 --------------------------
1125 -- Simple_Name_Internal --
1126 --------------------------
1128 function Simple_Name_Internal (Path : String) return String is
1129 Cut_Start : Natural :=
1131 (Path, Dir_Seps, Going => Strings.Backward);
1135 -- Cut_Start pointS to the first simple name character
1137 Cut_Start := (if Cut_Start = 0 then Path'First else Cut_Start + 1);
1139 -- Cut_End point to the last simple name character
1141 Cut_End := Path'Last;
1143 Check_For_Standard_Dirs : declare
1144 BN : constant String := Path (Cut_Start .. Cut_End);
1145 Has_Drive_Letter : constant Boolean :=
1146 System.OS_Lib.Path_Separator /= ':';
1147 -- If Path separator is not ':' then we are on a DOS based OS
1148 -- where this character is used as a drive letter separator.
1151 if BN = "." or else BN = ".." then
1154 elsif Has_Drive_Letter
1155 and then BN'Length > 2
1156 and then Characters.Handling.Is_Letter (BN (BN'First))
1157 and then BN (BN'First + 1) = ':'
1159 -- We have a DOS drive letter prefix, remove it
1161 return BN (BN'First + 2 .. BN'Last);
1166 end Check_For_Standard_Dirs;
1167 end Simple_Name_Internal;
1169 -- Start of processing for Simple_Name
1172 -- First, the invalid case
1174 if not Is_Valid_Path_Name (Name) then
1175 raise Name_Error with "invalid path name
""" & Name & '"';
1178 -- Build the value to return with lower bound 1
1181 Value : constant String := Simple_Name_Internal (Name);
1182 subtype Result is String (1 .. Value'Length);
1184 return Result (Value);
1189 function Simple_Name
1190 (Directory_Entry : Directory_Entry_Type) return String is
1192 -- First, the invalid case
1194 if not Directory_Entry.Is_Valid then
1195 raise Status_Error with "invalid directory entry";
1198 -- The value to return has already be computed
1200 return To_String (Directory_Entry.Simple);
1208 function Size (Name : String) return File_Size is
1209 C_Name : String (1 .. Name'Length + 1);
1211 function C_Size (Name : System.Address) return Long_Integer;
1212 pragma Import (C, C_Size, "__gnat_named_file_length");
1215 -- First, the invalid case
1217 if not Is_Regular_File (Name) then
1218 raise Name_Error with "file """ & Name & """ does not exist";
1221 C_Name (1 .. Name'Length) := Name;
1222 C_Name (C_Name'Last) := ASCII.NUL;
1223 return File_Size (C_Size (C_Name'Address));
1227 function Size (Directory_Entry : Directory_Entry_Type) return File_Size is
1229 -- First, the invalid case
1231 if not Directory_Entry.Is_Valid then
1232 raise Status_Error with "invalid directory entry";
1235 -- The value to return has already be computed
1237 return Size (To_String (Directory_Entry.Full));
1245 procedure Start_Search
1246 (Search : in out Search_Type;
1249 Filter : Filter_Type := (others => True))
1251 function opendir (file_name : String) return DIRs;
1252 pragma Import (C, opendir, "__gnat_opendir");
1254 C_File_Name : constant String := Directory & ASCII.NUL;
1256 Dir : Dir_Type_Value;
1259 -- First, the invalid case Name_Error
1261 if not Is_Directory (Directory) then
1262 raise Name_Error with
1263 "unknown directory """ & Simple_Name (Directory) & '"';
1266 -- Check the pattern
1272 Case_Sensitive => Is_Path_Name_Case_Sensitive);
1274 when Error_In_Regexp =>
1275 Free (Search.Value);
1276 raise Name_Error with "invalid pattern
""" & Pattern & '"';
1279 Dir := Dir_Type_Value (opendir (C_File_Name));
1281 if Dir = No_Dir then
1282 raise Use_Error with
1283 "unreadable directory """ & Simple_Name (Directory) & '"';
1286 -- If needed, finalize Search
1290 -- Allocate the default data
1292 Search.Value := new Search_Data;
1294 -- Initialize some Search components
1296 Search.Value.Filter := Filter;
1297 Search.Value.Name := To_Unbounded_String (Full_Name (Directory));
1298 Search.Value.Pattern := Pat;
1299 Search.Value.Dir := Dir;
1300 Search.Value.Is_Valid := True;
1303 end Ada.Directories;