| blob | d660b69dcb805d8137421a48e17f4d5ffdb96ebd |
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT RUN-TIME COMPONENTS --
4 -- --
5 -- A D A . D I R E C T O R I E S --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 2004-2023, Free Software Foundation, Inc. --
10 -- --
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. --
17 -- --
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. --
21 -- --
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/>. --
26 -- --
27 -- GNAT was originally developed by the GNAT team at New York University. --
28 -- Extensive contributions were provided by Ada Core Technologies Inc. --
29 -- --
30 ------------------------------------------------------------------------------
56 -- This is the low-level address directory structure as returned by the C
57 -- opendir routine.
60 -- Null directory value
64 -- Running system default directory separator
67 -- UNIX and DOS style directory separators
69 Max_Path : Integer;
71 -- The maximum length of a path
73 function C_Modification_Time (N : System.Address) return Ada.Calendar.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.
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;
104 Next_Entry : Cursor;
105 end record;
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;
126 Directory : String;
127 Pattern : String;
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.
133 ---------------
134 -- Base_Name --
135 ---------------
137 function Base_Name (Name : String) return String is
138 Simple : constant String := Simple_Name (Name);
139 -- Simple'First is guaranteed to be 1
141 begin
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);
149 end if;
150 end loop;
152 -- If there is no dot, return the complete file name
154 return Simple;
155 end Base_Name;
157 -------------
158 -- Compose --
159 -------------
161 function Compose
163 Name : String;
165 is
166 Result : String (1 .. Containing_Directory'Length +
167 Name'Length + Extension'Length + 2);
168 Last : Natural;
170 begin
171 -- First, deal with the invalid cases
174 and then not Is_Valid_Path_Name (Containing_Directory)
175 then
176 raise Name_Error with
179 elsif
180 Extension'Length = 0 and then (not Is_Valid_Simple_Name (Name))
181 then
182 raise Name_Error with
185 elsif Extension'Length /= 0
186 and then not Is_Valid_Simple_Name (Name & '.' & Extension)
187 then
188 raise Name_Error with
191 -- This is not an invalid case so build the path name
193 else
194 Last := Containing_Directory'Length;
195 Result (1 .. Last) := Containing_Directory;
197 -- Add a directory separator if needed
199 if Last /= 0 and then not Is_In (Result (Last), Dir_Seps) then
200 Last := Last + 1;
201 Result (Last) := Dir_Separator;
202 end if;
204 -- Add the file name
206 Result (Last + 1 .. Last + Name'Length) := Name;
207 Last := Last + Name'Length;
209 -- If extension was specified, add dot followed by this extension
211 if Extension'Length /= 0 then
212 Last := Last + 1;
214 Result (Last + 1 .. Last + Extension'Length) := Extension;
215 Last := Last + Extension'Length;
216 end if;
218 return Result (1 .. Last);
219 end if;
220 end Compose;
222 --------------------------
223 -- Containing_Directory --
224 --------------------------
226 function Containing_Directory (Name : String) return String is
227 begin
228 -- First, the invalid case
230 if not Is_Valid_Path_Name (Name) then
233 else
234 declare
235 Last_DS : constant Natural :=
236 Strings.Fixed.Index (Name, Dir_Seps, Going => Strings.Backward);
238 begin
239 -- If Name indicates a root directory, raise Use_Error, because
240 -- it has no containing directory.
242 if Is_Parent_Directory_Name (Name)
243 or else Is_Current_Directory_Name (Name)
244 or else Is_Root_Directory_Name (Name)
245 then
246 raise Use_Error with
249 elsif Last_DS = 0 then
251 -- the current working directory.
255 else
256 declare
257 Last : Positive := Last_DS - Name'First + 1;
258 Result : String (1 .. Last);
260 begin
261 Result := Name (Name'First .. Last_DS);
263 -- Remove any trailing directory separator, except as the
264 -- first character or the first character following a drive
265 -- number on Windows.
267 while Last > 1 loop
268 exit when Is_Root_Directory_Name (Result (1 .. Last))
269 or else (Result (Last) /= Directory_Separator
270 and then Result (Last) /= '/');
272 Last := Last - 1;
273 end loop;
275 return Result (1 .. Last);
276 end;
277 end if;
278 end;
279 end if;
280 end Containing_Directory;
282 ---------------
283 -- Copy_File --
284 ---------------
286 procedure Copy_File
287 (Source_Name : String;
288 Target_Name : String;
290 is
291 Success : Boolean;
292 Mode : Copy_Mode := Overwrite;
293 Preserve : Attribute := None;
295 begin
296 -- First, the invalid cases
298 if not Is_Valid_Path_Name (Source_Name) then
299 raise Name_Error with
302 elsif not Is_Valid_Path_Name (Target_Name) then
303 raise Name_Error with
306 elsif not Is_Regular_File (Source_Name) then
309 elsif Is_Directory (Target_Name) then
310 raise Use_Error with "target """ & Target_Name & """ is a directory";
312 else
313 if Form'Length > 0 then
314 declare
315 Formstr : String (1 .. Form'Length + 1);
316 V1, V2 : Natural;
318 begin
319 -- Acquire form string, setting required NUL terminator
321 Formstr (1 .. Form'Length) := Form;
322 Formstr (Formstr'Last) := ASCII.NUL;
324 -- Convert form string to lower case
326 for J in Formstr'Range loop
328 Formstr (J) :=
329 Character'Val (Character'Pos (Formstr (J)) + 32);
330 end if;
331 end loop;
333 -- Check Form
335 Form_Parameter (Formstr, "mode", V1, V2);
337 if V1 = 0 then
338 Mode := Overwrite;
339 elsif Formstr (V1 .. V2) = "copy" then
340 Mode := Copy;
341 elsif Formstr (V1 .. V2) = "overwrite" then
342 Mode := Overwrite;
343 elsif Formstr (V1 .. V2) = "append" then
344 Mode := Append;
345 else
346 raise Use_Error with "invalid Form";
347 end if;
349 Form_Parameter (Formstr, "preserve", V1, V2);
351 if V1 = 0 then
352 Preserve := None;
353 elsif Formstr (V1 .. V2) = "timestamps" then
354 Preserve := Time_Stamps;
355 elsif Formstr (V1 .. V2) = "all_attributes" then
356 Preserve := Full;
357 elsif Formstr (V1 .. V2) = "no_attributes" then
358 Preserve := None;
359 else
360 raise Use_Error with "invalid Form";
361 end if;
362 end;
363 end if;
365 -- Do actual copy using System.OS_Lib.Copy_File
367 Copy_File (Source_Name, Target_Name, Success, Mode, Preserve);
369 if not Success then
370 raise Use_Error with "copy of """ & Source_Name & """ failed";
371 end if;
372 end if;
373 end Copy_File;
375 ----------------------
376 -- Create_Directory --
377 ----------------------
379 procedure Create_Directory
380 (New_Directory : String;
381 Form : String := "")
382 is
383 Dir_Name_C : constant String := New_Directory & ASCII.NUL;
385 begin
386 -- First, the invalid case
388 if not Is_Valid_Path_Name (New_Directory) then
389 raise Name_Error with
392 else
393 -- Acquire setting of encoding parameter
395 declare
396 Formstr : constant String := To_Lower (Form);
398 Encoding : CRTL.Filename_Encoding;
399 -- Filename encoding specified into the form parameter
401 V1, V2 : Natural;
403 begin
406 if V1 = 0 then
407 Encoding := CRTL.Unspecified;
409 Encoding := CRTL.UTF8;
411 Encoding := CRTL.ASCII_8bits;
412 else
414 end if;
416 if CRTL.mkdir (Dir_Name_C, Encoding) /= 0 then
417 raise Use_Error with
419 end if;
420 end;
421 end if;
422 end Create_Directory;
424 -----------------
425 -- Create_Path --
426 -----------------
428 procedure Create_Path
429 (New_Directory : String;
431 is
432 New_Dir : String (1 .. New_Directory'Length + 1);
433 Last : Positive := 1;
434 Start : Positive := 1;
436 begin
437 -- First, the invalid case
439 if not Is_Valid_Path_Name (New_Directory) then
440 raise Name_Error with
443 else
444 -- Build New_Dir with a directory separator at the end, so that the
445 -- complete path will be found in the loop below.
447 New_Dir (1 .. New_Directory'Length) := New_Directory;
448 New_Dir (New_Dir'Last) := Directory_Separator;
450 -- If host is windows, and the first two characters are directory
451 -- separators, we have an UNC path. Skip it.
454 and then New_Dir'Length > 2
455 and then Is_In (New_Dir (1), Dir_Seps)
456 and then Is_In (New_Dir (2), Dir_Seps)
457 then
458 Start := 2;
459 loop
460 Start := Start + 1;
461 exit when Start = New_Dir'Last
462 or else Is_In (New_Dir (Start), Dir_Seps);
463 end loop;
464 end if;
466 -- Create, if necessary, each directory in the path
468 for J in Start + 1 .. New_Dir'Last loop
470 -- Look for the end of an intermediate directory
472 if not Is_In (New_Dir (J), Dir_Seps) then
473 Last := J;
475 -- We have found a new intermediate directory each time we find
476 -- a first directory separator.
478 elsif not Is_In (New_Dir (J - 1), Dir_Seps) then
480 -- No need to create the directory if it already exists
482 if not Is_Directory (New_Dir (1 .. Last)) then
483 begin
484 Create_Directory
485 (New_Directory => New_Dir (1 .. Last), Form => Form);
487 exception
488 when Use_Error =>
489 if File_Exists (New_Dir (1 .. Last)) then
491 -- A file with such a name already exists. If it is
492 -- a directory, then it was apparently just created
493 -- by another process or thread, and all is well.
494 -- If it is of some other kind, report an error.
496 if not Is_Directory (New_Dir (1 .. Last)) then
497 raise Use_Error with
498 "file """ & New_Dir (1 .. Last) &
499 """ already exists and is not a directory";
500 end if;
502 else
503 -- Create_Directory failed for some other reason:
504 -- propagate the exception.
506 raise;
507 end if;
508 end;
509 end if;
510 end if;
511 end loop;
512 end if;
513 end Create_Path;
515 -----------------------
516 -- Current_Directory --
517 -----------------------
519 function Current_Directory return String is
520 Path_Len : Natural := Max_Path;
521 Buffer : String (1 .. 1 + Max_Path + 1);
523 procedure Local_Get_Current_Dir (Dir : Address; Length : Address);
524 pragma Import (C, Local_Get_Current_Dir, "__gnat_get_current_dir");
526 begin
527 Local_Get_Current_Dir (Buffer'Address, Path_Len'Address);
529 if Path_Len = 0 then
530 raise Use_Error with "current directory does not exist";
531 end if;
533 -- We need to resolve links because of RM A.16(47), which requires
534 -- that we not return alternative names for files.
536 return Normalize_Pathname (Buffer (1 .. Path_Len));
537 end Current_Directory;
539 ----------------------
540 -- Delete_Directory --
541 ----------------------
543 procedure Delete_Directory (Directory : String) is
544 begin
545 -- First, the invalid cases
547 if not Is_Valid_Path_Name (Directory) then
548 raise Name_Error with
551 elsif not Is_Directory (Directory) then
554 -- Do the deletion, checking for error
556 else
557 declare
558 Dir_Name_C : constant String := Directory & ASCII.NUL;
559 begin
560 if rmdir (Dir_Name_C) /= 0 then
561 raise Use_Error with
562 "deletion of directory """ & Directory & """ failed";
563 end if;
564 end;
565 end if;
566 end Delete_Directory;
568 -----------------
569 -- Delete_File --
570 -----------------
572 procedure Delete_File (Name : String) is
573 Success : Boolean;
575 begin
576 -- First, the invalid cases
578 if not Is_Valid_Path_Name (Name) then
581 elsif not Is_Regular_File (Name)
582 and then not Is_Symbolic_Link (Name)
583 then
586 else
587 -- Do actual deletion using System.OS_Lib.Delete_File
589 Delete_File (Name, Success);
591 if not Success then
593 end if;
594 end if;
595 end Delete_File;
597 -----------------
598 -- Delete_Tree --
599 -----------------
601 procedure Delete_Tree (Directory : String) is
602 Search : Search_Type;
603 Dir_Ent : Directory_Entry_Type;
604 begin
605 -- First, the invalid cases
607 if not Is_Valid_Path_Name (Directory) then
608 raise Name_Error with
611 elsif not Is_Directory (Directory) then
614 else
616 -- We used to change the current directory to Directory here,
617 -- allowing the use of a local Simple_Name for all references. This
618 -- turned out unfriendly to multitasking programs, where tasks
619 -- running in parallel of this Delete_Tree could see their current
620 -- directory change unpredictably. We now resort to Full_Name
621 -- computations to reach files and subdirs instead.
624 while More_Entries (Search) loop
625 Get_Next_Entry (Search, Dir_Ent);
627 declare
628 Fname : constant String := Full_Name (Dir_Ent);
629 Sname : constant String := Simple_Name (Dir_Ent);
631 begin
632 if OS_Lib.Is_Directory (Fname) then
634 Delete_Tree (Fname);
635 end if;
636 else
637 Delete_File (Fname);
638 end if;
639 end;
640 end loop;
642 End_Search (Search);
644 declare
645 Dir_Name_C : constant String := Directory & ASCII.NUL;
647 begin
648 if rmdir (Dir_Name_C) /= 0 then
649 raise Use_Error with
652 end if;
653 end;
654 end if;
655 end Delete_Tree;
657 ------------
658 -- Exists --
659 ------------
661 function Exists (Name : String) return Boolean is
662 begin
663 -- First, the invalid case
665 if not Is_Valid_Path_Name (Name) then
668 else
669 -- The implementation is in File_Exists
671 return File_Exists (Name);
672 end if;
673 end Exists;
675 ---------------
676 -- Extension --
677 ---------------
679 function Extension (Name : String) return String is
680 begin
681 -- First, the invalid case
683 if not Is_Valid_Path_Name (Name) then
686 else
687 -- Look for first dot that is not followed by a directory separator
689 for Pos in reverse Name'Range loop
691 -- If a directory separator is found before a dot, there is no
692 -- extension.
694 if Is_In (Name (Pos), Dir_Seps) then
695 return Empty_String;
697 elsif Name (Pos) = '.' then
699 -- We found a dot, build the return value with lower bound 1
701 declare
702 subtype Result_Type is String (1 .. Name'Last - Pos);
703 begin
704 return Result_Type (Name (Pos + 1 .. Name'Last));
705 end;
706 end if;
707 end loop;
709 -- No dot were found, there is no extension
711 return Empty_String;
712 end if;
713 end Extension;
715 -----------------
716 -- File_Exists --
717 -----------------
719 function File_Exists (Name : String) return Boolean is
720 function C_File_Exists (A : Address) return Integer;
723 C_Name : String (1 .. Name'Length + 1);
725 begin
726 C_Name (1 .. Name'Length) := Name;
727 C_Name (C_Name'Last) := ASCII.NUL;
728 return C_File_Exists (C_Name'Address) = 1;
729 end File_Exists;
731 --------------
732 -- Finalize --
733 --------------
735 procedure Finalize (Search : in out Search_Type) is
736 begin
737 if Search.State /= null then
738 Free (Search.State.Dir_Contents);
739 Free (Search.State);
740 end if;
741 end Finalize;
743 ---------------
744 -- Full_Name --
745 ---------------
747 function Full_Name (Name : String) return String is
748 begin
749 -- First, the invalid case
751 if not Is_Valid_Path_Name (Name) then
754 else
755 -- Build the return value with lower bound 1
757 -- Use System.OS_Lib.Normalize_Pathname
759 declare
760 -- We need to resolve links because of (RM A.16(47)), which says
761 -- we must not return alternative names for files.
763 Value : constant String := Normalize_Pathname (Name);
764 subtype Result is String (1 .. Value'Length);
766 begin
767 return Result (Value);
768 end;
769 end if;
770 end Full_Name;
772 function Full_Name (Directory_Entry : Directory_Entry_Type) return String is
773 begin
774 -- If the Directory_Entry is valid return the full name contained in the
775 -- entry record.
777 if not Directory_Entry.Valid then
778 raise Status_Error with "invalid directory entry";
779 else
780 return To_String (Directory_Entry.Full_Name);
781 end if;
782 end Full_Name;
784 --------------------
785 -- Get_Next_Entry --
786 --------------------
788 procedure Get_Next_Entry
789 (Search : in out Search_Type;
790 Directory_Entry : out Directory_Entry_Type)
791 is
792 begin
793 -- A Search with no state implies the user has not called Start_Search
795 if Search.State = null then
796 raise Status_Error with "search not started";
797 end if;
799 -- If the next entry is No_Element it means the search is finished and
800 -- there are no more entries to return.
802 if Search.State.Next_Entry = No_Element then
803 raise Status_Error with "no more entries";
804 end if;
806 -- Populate Directory_Entry with the next entry and update the search
807 -- state.
809 Directory_Entry := Element (Search.State.Next_Entry);
810 Next (Search.State.Next_Entry);
812 -- If Start_Search received a non-zero error code when trying to read
813 -- the file attributes of this entry, raise an Use_Error so the user
814 -- is aware that it was not possible to retrieve the attributes of this
815 -- entry.
817 if Directory_Entry.Attr_Error_Code /= 0 then
818 raise Use_Error
819 with To_String (Directory_Entry.Full_Name) & ": " &
820 Errno_Message (Err => Directory_Entry.Attr_Error_Code);
821 end if;
822 end Get_Next_Entry;
824 ----------
825 -- Kind --
826 ----------
828 function Kind (Name : String) return File_Kind is
829 begin
830 -- First, the invalid case
832 if not File_Exists (Name) then
833 raise Name_Error with "file """ & Name & """ does not exist";
835 -- If OK, return appropriate kind
837 elsif Is_Regular_File (Name) then
838 return Ordinary_File;
840 elsif Is_Directory (Name) then
841 return Directory;
843 else
844 return Special_File;
845 end if;
846 end Kind;
848 function Kind (Directory_Entry : Directory_Entry_Type) return File_Kind is
849 begin
850 if not Directory_Entry.Valid then
851 raise Status_Error with "invalid directory entry";
852 else
853 return Directory_Entry.Kind;
854 end if;
855 end Kind;
857 -----------------------
858 -- Modification_Time --
859 -----------------------
861 function Modification_Time (Name : String) return Time is
863 Date : Time;
864 C_Name : aliased String (1 .. Name'Length + 1);
865 begin
866 -- First, the invalid cases
868 if not (Is_Regular_File (Name) or else Is_Directory (Name)) then
871 else
872 C_Name := Name & ASCII.NUL;
873 Date := C_Modification_Time (C_Name'Address);
875 if Date = Invalid_Time then
876 raise Use_Error with
878 end if;
880 return Date;
881 end if;
882 end Modification_Time;
884 function Modification_Time
885 (Directory_Entry : Directory_Entry_Type) return Ada.Calendar.Time
886 is
887 begin
888 -- If the Directory_Entry is valid return the modification time
889 -- contained in the entry record. The modification time is recorded in
890 -- the entry since its cheap to query all the file the attributes in
891 -- one read when the directory is searched.
893 if not Directory_Entry.Valid then
894 raise Status_Error with "invalid directory entry";
895 else
896 return Directory_Entry.Modification_Time;
897 end if;
898 end Modification_Time;
900 ------------------
901 -- More_Entries --
902 ------------------
904 function More_Entries (Search : Search_Type) return Boolean is
905 begin
906 -- If the vector cursor Search.State.Next_Entry points to an element in
907 -- Search.State.Dir_Contents then there is another entry to return.
908 -- Otherwise, we return False.
910 if Search.State = null then
911 return False;
912 elsif Search.State.Next_Entry = No_Element then
913 return False;
914 else
915 return True;
916 end if;
917 end More_Entries;
919 ---------------------------
920 -- Name_Case_Equivalence --
921 ---------------------------
923 function Name_Case_Equivalence (Name : String) return Name_Case_Kind is
924 Dir_Path : Unbounded_String := To_Unbounded_String (Name);
925 S : Search_Type;
926 Test_File : Directory_Entry_Type;
928 function GNAT_name_case_equivalence return Interfaces.C.int;
929 pragma Import (C, GNAT_name_case_equivalence,
930 "__gnat_name_case_equivalence");
932 begin
933 -- Check for the invalid case
935 if not Is_Valid_Path_Name (Name) then
937 end if;
940 -- the containing directory.
942 if Is_Regular_File (Name) then
943 Dir_Path := To_Unbounded_String (Containing_Directory (Name));
944 end if;
946 -- Since we must obtain a file within the Name directory, let's grab the
947 -- first for our test. When the directory is empty, Get_Next_Entry will
948 -- fall through to a Status_Error where we then take the imprecise
949 -- default for the host OS.
951 Start_Search
952 (Search => S,
953 Directory => To_String (Dir_Path),
955 Filter => [Directory => False, others => True]);
957 loop
958 Get_Next_Entry (S, Test_File);
962 exit when To_Lower (Simple_Name (Test_File)) /=
963 To_Upper (Simple_Name (Test_File));
964 end loop;
966 End_Search (S);
968 -- Search for files within the directory with the same name, but
969 -- differing cases.
971 Start_Search_Internal
972 (Search => S,
973 Directory => To_String (Dir_Path),
974 Pattern => Simple_Name (Test_File),
975 Filter => [Directory => False, others => True],
976 Case_Insensitive => True);
978 -- We will find at least one match due to the search hitting our test
979 -- file.
981 Get_Next_Entry (S, Test_File);
983 begin
984 -- If we hit two then we know we have a case-sensitive directory
986 Get_Next_Entry (S, Test_File);
987 End_Search (S);
989 return Case_Sensitive;
990 exception
991 when Status_Error =>
992 null;
993 end;
995 -- Finally, we have a file in the directory whose name is unique and
997 -- in multiple cases, which will give us our result without having to
998 -- resort to defaults.
1000 if Exists (To_String (Dir_Path) & Directory_Separator
1001 & To_Lower (Simple_Name (Test_File)))
1002 and then Exists (To_String (Dir_Path) & Directory_Separator
1003 & To_Upper (Simple_Name (Test_File)))
1004 then
1005 return Case_Preserving;
1006 end if;
1008 return Case_Sensitive;
1009 exception
1010 when Status_Error =>
1012 -- There is no unobtrusive way to check for the directory's casing so
1013 -- return the OS default.
1015 return Name_Case_Kind'Val (Integer (GNAT_name_case_equivalence));
1016 end Name_Case_Equivalence;
1018 ------------
1019 -- Rename --
1020 ------------
1022 procedure Rename (Old_Name, New_Name : String) is
1023 Success : Boolean;
1025 begin
1026 -- First, the invalid cases
1028 if not Is_Valid_Path_Name (Old_Name) then
1031 elsif not Is_Valid_Path_Name (New_Name) then
1034 elsif not Is_Regular_File (Old_Name)
1035 and then not Is_Directory (Old_Name)
1036 then
1039 elsif Is_Regular_File (New_Name) or else Is_Directory (New_Name) then
1040 raise Use_Error with
1044 -- Do actual rename using System.OS_Lib.Rename_File
1046 else
1047 Rename_File (Old_Name, New_Name, Success);
1049 if not Success then
1051 -- AI05-0231-1: Name_Error should be raised in case a directory
1052 -- component of New_Name does not exist (as in New_Name =>
1054 -- also indicate that the Old_Name does not exist, but we already
1055 -- checked for that above. All other errors are Use_Error.
1057 if Errno = ENOENT then
1058 raise Name_Error with
1061 else
1062 raise Use_Error with
1064 end if;
1065 end if;
1066 end if;
1067 end Rename;
1069 ------------
1070 -- Search --
1071 ------------
1073 procedure Search
1074 (Directory : String;
1075 Pattern : String;
1076 Filter : Filter_Type := [others => True];
1077 Process : not null access procedure
1078 (Directory_Entry : Directory_Entry_Type))
1079 is
1080 Srch : Search_Type;
1081 Directory_Entry : Directory_Entry_Type;
1083 begin
1084 Start_Search (Srch, Directory, Pattern, Filter);
1085 while More_Entries (Srch) loop
1086 Get_Next_Entry (Srch, Directory_Entry);
1087 Process (Directory_Entry);
1088 end loop;
1090 End_Search (Srch);
1091 end Search;
1093 -------------------
1094 -- Set_Directory --
1095 -------------------
1097 procedure Set_Directory (Directory : String) is
1098 Dir_Name_C : constant String := Directory & ASCII.NUL;
1099 begin
1100 if not Is_Valid_Path_Name (Directory) then
1101 raise Name_Error with
1104 elsif not Is_Directory (Directory) then
1105 raise Name_Error with
1106 "directory """ & Directory & """ does not exist";
1108 elsif chdir (Dir_Name_C) /= 0 then
1109 raise Name_Error with
1111 end if;
1112 end Set_Directory;
1114 -----------------
1115 -- Simple_Name --
1116 -----------------
1118 function Simple_Name (Name : String) return String is
1120 function Simple_Name_Internal (Path : String) return String;
1121 -- This function does the job
1123 --------------------------
1124 -- Simple_Name_Internal --
1125 --------------------------
1127 function Simple_Name_Internal (Path : String) return String is
1128 Cut_Start : Natural :=
1129 Strings.Fixed.Index (Path, Dir_Seps, Going => Strings.Backward);
1131 -- Cut_End points to the last simple name character
1133 Cut_End : Natural := Path'Last;
1135 begin
1136 -- Root directories are considered simple
1138 if Is_Root_Directory_Name (Path) then
1139 return Path;
1140 end if;
1142 -- Handle trailing directory separators
1144 if Cut_Start = Path'Last then
1145 Cut_End := Path'Last - 1;
1146 Cut_Start := Strings.Fixed.Index
1147 (Path (Path'First .. Path'Last - 1),
1148 Dir_Seps, Going => Strings.Backward);
1149 end if;
1151 -- Cut_Start points to the first simple name character
1153 Cut_Start := (if Cut_Start = 0 then Path'First else Cut_Start + 1);
1155 Check_For_Standard_Dirs : declare
1156 BN : constant String := Path (Cut_Start .. Cut_End);
1158 Has_Drive_Letter : constant Boolean :=
1159 OS_Lib.Path_Separator /= ':';
1160 -- If Path separator is not ':' then we are on a DOS based OS
1161 -- where this character is used as a drive letter separator.
1163 begin
1165 return BN;
1167 elsif Has_Drive_Letter
1168 and then BN'Length > 2
1169 and then Characters.Handling.Is_Letter (BN (BN'First))
1170 and then BN (BN'First + 1) = ':'
1171 then
1172 -- We have a DOS drive letter prefix, remove it
1174 return BN (BN'First + 2 .. BN'Last);
1176 else
1177 return BN;
1178 end if;
1179 end Check_For_Standard_Dirs;
1180 end Simple_Name_Internal;
1182 -- Start of processing for Simple_Name
1184 begin
1185 -- First, the invalid case
1187 if not Is_Valid_Path_Name (Name) then
1190 else
1191 -- Build the value to return with lower bound 1
1193 declare
1194 Value : constant String := Simple_Name_Internal (Name);
1195 subtype Result is String (1 .. Value'Length);
1196 begin
1197 return Result (Value);
1198 end;
1199 end if;
1200 end Simple_Name;
1202 function Simple_Name
1203 (Directory_Entry : Directory_Entry_Type) return String is
1204 begin
1205 -- If the Directory_Entry is valid return the simple name contained in
1206 -- the entry record.
1208 if not Directory_Entry.Valid then
1209 raise Status_Error with "invalid directory entry";
1210 else
1211 return To_String (Directory_Entry.Name);
1212 end if;
1213 end Simple_Name;
1215 ----------
1216 -- Size --
1217 ----------
1219 function Size (Name : String) return File_Size is
1220 C_Name : String (1 .. Name'Length + 1);
1222 function C_Size (Name : Address) return int64;
1223 pragma Import (C, C_Size, "__gnat_named_file_length");
1225 begin
1226 -- First, the invalid case
1228 if not Is_Regular_File (Name) then
1229 raise Name_Error with "file """ & Name & """ does not exist";
1231 else
1232 C_Name (1 .. Name'Length) := Name;
1233 C_Name (C_Name'Last) := ASCII.NUL;
1234 return File_Size (C_Size (C_Name'Address));
1235 end if;
1236 end Size;
1238 function Size (Directory_Entry : Directory_Entry_Type) return File_Size is
1239 begin
1240 -- If the Directory_Entry is valid return the size contained in the
1241 -- entry record. The size is recorded in the entry since it is cheap to
1242 -- query all the file the attributes in one read when the directory is
1243 -- searched.
1245 if not Directory_Entry.Valid then
1246 raise Status_Error with "invalid directory entry";
1247 else
1248 return Directory_Entry.Size;
1249 end if;
1250 end Size;
1252 ------------------
1253 -- Start_Search --
1254 ------------------
1256 procedure Start_Search
1257 (Search : in out Search_Type;
1258 Directory : String;
1259 Pattern : String;
1260 Filter : Filter_Type := [others => True])
1261 is
1262 begin
1263 Start_Search_Internal (Search, Directory, Pattern, Filter, False);
1264 end Start_Search;
1266 ---------------------------
1267 -- Start_Search_Internal --
1268 ---------------------------
1270 procedure Start_Search_Internal
1271 (Search : in out Search_Type;
1272 Directory : String;
1273 Pattern : String;
1274 Filter : Filter_Type := [others => True];
1275 Case_Insensitive : Boolean)
1276 is
1277 function closedir (Directory : DIRs) return Integer
1278 with Import, External_Name => "__gnat_closedir", Convention => C;
1279 -- C lib function to close Directory
1281 function opendir (Directory : String) return DIRs
1282 with Import, External_Name => "__gnat_opendir", Convention => C;
1283 -- C lib function to open Directory
1285 function readdir_gnat
1286 (Directory : Address;
1287 Buffer : Address;
1288 Last : not null access Integer) return Address
1289 with Import, External_Name => "__gnat_readdir", Convention => C;
1290 -- Read the next item in Directory
1292 Dir_Name_C : constant String := Directory & ASCII.NUL;
1293 Dir_Entry_Buffer : array (1 .. SIZEOF_struct_dirent_alloc) of Character;
1294 Dir_Pointer : Dir_Type_Value;
1295 File_Name_Addr : Address;
1296 File_Name_Len : aliased Integer;
1297 Pattern_Regex : Regexp;
1299 Call_Result : Integer;
1300 pragma Warnings (Off, Call_Result);
1301 -- Result of calling a C function that returns a status
1303 begin
1304 -- Check that Directory is a valid directory
1306 if not Is_Directory (Directory) then
1307 raise Name_Error with
1309 end if;
1311 -- Check and compile the pattern
1313 declare
1314 Case_Sensitive : Boolean := Is_Path_Name_Case_Sensitive;
1315 begin
1316 if Case_Insensitive then
1317 Case_Sensitive := False;
1318 end if;
1320 Pattern_Regex :=
1321 Compile (Pattern, Glob => True, Case_Sensitive => Case_Sensitive);
1322 exception
1323 when Error_In_Regexp =>
1325 end;
1327 -- Open Directory
1329 Dir_Pointer := Dir_Type_Value (opendir (Dir_Name_C));
1331 if Dir_Pointer = No_Dir then
1332 raise Use_Error with
1334 end if;
1336 -- If needed, finalize Search. Note: we should probably raise an
1337 -- exception here if Search belongs to an existing search rather than
1338 -- quietly end it. However, we first need to check that it won't break
1339 -- existing software.
1341 Finalize (Search);
1343 -- Allocate and initialize the search state
1345 Search.State := new Search_State'
1346 (Ada.Finalization.Controlled with
1347 Dir_Contents => new Vector,
1348 Next_Entry => No_Element);
1350 -- Increase the size of the Dir_Contents vector so it does not need to
1351 -- grow for most reasonable directory searches.
1353 Search.State.Dir_Contents.Reserve_Capacity (Dir_Vector_Initial_Size);
1355 -- Read the contents of Directory into Search.State
1357 loop
1358 -- Get next item in the directory
1360 File_Name_Addr :=
1361 readdir_gnat
1362 (Address (Dir_Pointer),
1363 Dir_Entry_Buffer'Address,
1364 File_Name_Len'Access);
1366 exit when File_Name_Addr = Null_Address;
1368 -- If the file name matches the Pattern and the file type matches
1369 -- the Filter add it to our search vector.
1371 declare
1372 subtype File_Name_String is String (1 .. File_Name_Len);
1374 File_Name : constant File_Name_String
1375 with Import, Address => File_Name_Addr;
1377 begin
1378 if Match (File_Name, Pattern_Regex) then
1379 declare
1380 Path_C : constant String :=
1381 Compose (Directory, File_Name) & ASCII.NUL;
1382 Path : String renames
1383 Path_C (Path_C'First .. Path_C'Last - 1);
1384 Found : Boolean := False;
1385 Attr : aliased File_Attributes;
1386 Exists : Integer;
1387 Error : Integer;
1388 Kind : File_Kind;
1389 Size : File_Size;
1391 begin
1392 -- Get the file attributes for the directory item
1394 Reset_Attributes (Attr'Access);
1395 Exists := File_Exists_Attr (Path_C'Address, Attr'Access);
1396 Error := Error_Attributes (Attr'Access);
1398 -- If there was an error when trying to read the attributes
1399 -- of a Directory entry, record the error so it can be
1400 -- propagated to the user when they interate through the
1401 -- directory results.
1403 if Error /= 0 then
1404 Search.State.Dir_Contents.Append
1405 (Directory_Entry_Type'
1406 (Valid => True,
1407 Name => To_Unbounded_String (File_Name),
1408 Full_Name => To_Unbounded_String (Path),
1409 Attr_Error_Code => Error,
1410 others => <>));
1412 -- Otherwise, if the file exists and matches the file kind
1413 -- Filter, add the file to the search results. We capture
1414 -- the size and modification time here as we have already
1415 -- the entry's attributes above.
1417 elsif Exists = 1 then
1418 if Is_Regular_File_Attr (Path_C'Address, Attr'Access) = 1
1419 and then Filter (Ordinary_File)
1420 then
1421 Found := True;
1422 Kind := Ordinary_File;
1423 Size :=
1424 File_Size
1425 (File_Length_Attr
1426 (-1, Path_C'Address, Attr'Access));
1428 elsif Is_Directory_Attr (Path_C'Address, Attr'Access) = 1
1429 and then Filter (File_Kind'First)
1430 then
1431 Found := True;
1432 Kind := File_Kind'First;
1433 -- File_Kind'First is used instead of Directory due
1434 -- to a name overload issue with the procedure
1435 -- parameter Directory.
1436 Size := 0;
1438 elsif Filter (Special_File) then
1439 Found := True;
1440 Kind := Special_File;
1441 Size := 0;
1442 end if;
1444 if Found then
1445 Search.State.Dir_Contents.Append
1446 (Directory_Entry_Type'
1447 (Valid => True,
1448 Name =>
1449 To_Unbounded_String (File_Name),
1450 Full_Name => To_Unbounded_String (Path),
1451 Attr_Error_Code => 0,
1452 Kind => Kind,
1453 Modification_Time => Modification_Time (Path),
1454 Size => Size));
1455 end if;
1456 end if;
1457 end;
1458 end if;
1459 end;
1460 end loop;
1462 -- Set the first entry to be returned to the user to be the first
1463 -- element of the Dir_Contents vector. If no items were found, First
1464 -- will return No_Element, which signals
1465 Search.State.Next_Entry := Search.State.Dir_Contents.First;
1467 -- Search is finished, close Directory
1469 Call_Result := closedir (DIRs (Dir_Pointer));
1471 end Start_Search_Internal;
1473 end Ada.Directories;