| blob | adff12277e89aedd11ef4863577dbcb492bab6b7 |
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-2024, 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 Extension'Length = 0 and then not Is_Valid_Simple_Name (Name) then
180 raise Name_Error with
183 elsif Extension'Length /= 0
184 and then not Is_Valid_Simple_Name (Name & '.' & Extension)
185 then
186 raise Name_Error with
189 -- This is not an invalid case so build the path name
191 else
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
198 Last := Last + 1;
199 Result (Last) := Dir_Separator;
200 end if;
202 -- Add the file name
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
210 Last := Last + 1;
212 Result (Last + 1 .. Last + Extension'Length) := Extension;
213 Last := Last + Extension'Length;
214 end if;
216 return Result (1 .. Last);
217 end if;
218 end Compose;
220 --------------------------
221 -- Containing_Directory --
222 --------------------------
224 function Containing_Directory (Name : String) return String is
225 begin
226 -- First, the invalid case
228 if not Is_Valid_Path_Name (Name) then
231 else
232 declare
233 Last_DS : constant Natural :=
234 Strings.Fixed.Index (Name, Dir_Seps, Going => Strings.Backward);
236 begin
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)
243 then
244 raise Use_Error with
247 elsif Last_DS = 0 then
249 -- the current working directory.
253 else
254 declare
255 Last : Positive := Last_DS - Name'First + 1;
256 Result : String (1 .. Last);
258 begin
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.
265 while Last > 1 loop
266 exit when Is_Root_Directory_Name (Result (1 .. Last))
267 or else (Result (Last) /= Directory_Separator
268 and then Result (Last) /= '/');
270 Last := Last - 1;
271 end loop;
273 return Result (1 .. Last);
274 end;
275 end if;
276 end;
277 end if;
278 end Containing_Directory;
280 ---------------
281 -- Copy_File --
282 ---------------
284 procedure Copy_File
285 (Source_Name : String;
286 Target_Name : String;
288 is
289 Success : Boolean;
290 Mode : Copy_Mode := Overwrite;
291 Preserve : Attribute := None;
293 begin
294 -- First, the invalid cases
296 if not Is_Valid_Path_Name (Source_Name) then
297 raise Name_Error with
300 elsif not Is_Valid_Path_Name (Target_Name) then
301 raise Name_Error with
304 elsif not Is_Regular_File (Source_Name) then
307 elsif Is_Directory (Target_Name) then
308 raise Use_Error with "target """ & Target_Name & """ is a directory";
310 else
311 if Form'Length > 0 then
312 declare
313 Formstr : String (1 .. Form'Length + 1);
314 V1, V2 : Natural;
316 begin
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
326 Formstr (J) :=
327 Character'Val (Character'Pos (Formstr (J)) + 32);
328 end if;
329 end loop;
331 -- Check Form
333 Form_Parameter (Formstr, "mode", V1, V2);
335 if V1 = 0 then
336 Mode := Overwrite;
337 elsif Formstr (V1 .. V2) = "copy" then
338 Mode := Copy;
339 elsif Formstr (V1 .. V2) = "overwrite" then
340 Mode := Overwrite;
341 elsif Formstr (V1 .. V2) = "append" then
342 Mode := Append;
343 else
344 raise Use_Error with "invalid Form";
345 end if;
347 Form_Parameter (Formstr, "preserve", V1, V2);
349 if V1 = 0 then
350 Preserve := None;
351 elsif Formstr (V1 .. V2) = "timestamps" then
352 Preserve := Time_Stamps;
353 elsif Formstr (V1 .. V2) = "all_attributes" then
354 Preserve := Full;
355 elsif Formstr (V1 .. V2) = "no_attributes" then
356 Preserve := None;
357 else
358 raise Use_Error with "invalid Form";
359 end if;
360 end;
361 end if;
363 -- Do actual copy using System.OS_Lib.Copy_File
365 Copy_File (Source_Name, Target_Name, Success, Mode, Preserve);
367 if not Success then
368 raise Use_Error with "copy of """ & Source_Name & """ failed";
369 end if;
370 end if;
371 end Copy_File;
373 ----------------------
374 -- Create_Directory --
375 ----------------------
377 procedure Create_Directory
378 (New_Directory : String;
379 Form : String := "")
380 is
381 Dir_Name_C : constant String := New_Directory & ASCII.NUL;
383 begin
384 -- First, the invalid case
386 if not Is_Valid_Path_Name (New_Directory) then
387 raise Name_Error with
390 else
391 -- Acquire setting of encoding parameter
393 declare
394 Formstr : constant String := To_Lower (Form);
396 Encoding : CRTL.Filename_Encoding;
397 -- Filename encoding specified into the form parameter
399 V1, V2 : Natural;
401 begin
404 if V1 = 0 then
405 Encoding := CRTL.Unspecified;
407 Encoding := CRTL.UTF8;
409 Encoding := CRTL.ASCII_8bits;
410 else
412 end if;
414 if CRTL.mkdir (Dir_Name_C, Encoding) /= 0 then
415 raise Use_Error with
417 end if;
418 end;
419 end if;
420 end Create_Directory;
422 -----------------
423 -- Create_Path --
424 -----------------
426 procedure Create_Path
427 (New_Directory : String;
429 is
430 New_Dir : String (1 .. New_Directory'Length + 1);
431 Last : Positive := 1;
432 Start : Positive := 1;
434 begin
435 -- First, the invalid case
437 if not Is_Valid_Path_Name (New_Directory) then
438 raise Name_Error with
441 else
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.
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)
455 then
456 Start := 2;
457 loop
458 Start := Start + 1;
459 exit when Start = New_Dir'Last
460 or else Is_In (New_Dir (Start), Dir_Seps);
461 end loop;
462 end if;
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
471 Last := J;
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
481 begin
482 Create_Directory
483 (New_Directory => New_Dir (1 .. Last), Form => Form);
485 exception
486 when Use_Error =>
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
495 raise Use_Error with
496 "file """ & New_Dir (1 .. Last) &
497 """ already exists and is not a directory";
498 end if;
500 else
501 -- Create_Directory failed for some other reason:
502 -- propagate the exception.
504 raise;
505 end if;
506 end;
507 end if;
508 end if;
509 end loop;
510 end if;
511 end Create_Path;
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");
524 begin
525 Local_Get_Current_Dir (Buffer'Address, Path_Len'Address);
527 if Path_Len = 0 then
528 raise Use_Error with "current directory does not exist";
529 end if;
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
542 begin
543 -- First, the invalid cases
545 if not Is_Valid_Path_Name (Directory) then
546 raise Name_Error with
549 elsif not Is_Directory (Directory) then
552 -- Do the deletion, checking for error
554 else
555 declare
556 Dir_Name_C : constant String := Directory & ASCII.NUL;
557 begin
558 if rmdir (Dir_Name_C) /= 0 then
559 raise Use_Error with
560 "deletion of directory """ & Directory & """ failed";
561 end if;
562 end;
563 end if;
564 end Delete_Directory;
566 -----------------
567 -- Delete_File --
568 -----------------
570 procedure Delete_File (Name : String) is
571 Success : Boolean;
573 begin
574 -- First, the invalid cases
576 if not Is_Valid_Path_Name (Name) then
579 elsif not Is_Regular_File (Name)
580 and then not Is_Symbolic_Link (Name)
581 then
584 else
585 -- Do actual deletion using System.OS_Lib.Delete_File
587 Delete_File (Name, Success);
589 if not Success then
591 end if;
592 end if;
593 end Delete_File;
595 -----------------
596 -- Delete_Tree --
597 -----------------
599 procedure Delete_Tree (Directory : String) is
600 Search : Search_Type;
601 Dir_Ent : Directory_Entry_Type;
602 begin
603 -- First, the invalid cases
605 if not Is_Valid_Path_Name (Directory) then
606 raise Name_Error with
609 elsif not Is_Directory (Directory) then
612 else
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.
622 while More_Entries (Search) loop
623 Get_Next_Entry (Search, Dir_Ent);
625 declare
626 Fname : constant String := Full_Name (Dir_Ent);
627 Sname : constant String := Simple_Name (Dir_Ent);
629 begin
630 if OS_Lib.Is_Directory (Fname) then
632 Delete_Tree (Fname);
633 end if;
634 else
635 Delete_File (Fname);
636 end if;
637 end;
638 end loop;
640 End_Search (Search);
642 declare
643 Dir_Name_C : constant String := Directory & ASCII.NUL;
645 begin
646 if rmdir (Dir_Name_C) /= 0 then
647 raise Use_Error with
650 end if;
651 end;
652 end if;
653 end Delete_Tree;
655 ------------
656 -- Exists --
657 ------------
659 function Exists (Name : String) return Boolean is
660 begin
661 -- First, the invalid case
663 if not Is_Valid_Path_Name (Name) then
666 else
667 -- The implementation is in File_Exists
669 return File_Exists (Name);
670 end if;
671 end Exists;
673 ---------------
674 -- Extension --
675 ---------------
677 function Extension (Name : String) return String is
678 begin
679 -- First, the invalid case
681 if not Is_Valid_Path_Name (Name) then
684 else
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
690 -- extension.
692 if Is_In (Name (Pos), Dir_Seps) then
693 return Empty_String;
695 elsif Name (Pos) = '.' then
697 -- We found a dot, build the return value with lower bound 1
699 declare
700 subtype Result_Type is String (1 .. Name'Last - Pos);
701 begin
702 return Result_Type (Name (Pos + 1 .. Name'Last));
703 end;
704 end if;
705 end loop;
707 -- No dot were found, there is no extension
709 return Empty_String;
710 end if;
711 end Extension;
713 -----------------
714 -- File_Exists --
715 -----------------
717 function File_Exists (Name : String) return Boolean is
718 function C_File_Exists (A : Address) return Integer;
721 C_Name : String (1 .. Name'Length + 1);
723 begin
724 C_Name (1 .. Name'Length) := Name;
725 C_Name (C_Name'Last) := ASCII.NUL;
726 return C_File_Exists (C_Name'Address) = 1;
727 end File_Exists;
729 --------------
730 -- Finalize --
731 --------------
733 procedure Finalize (Search : in out Search_Type) is
734 begin
735 if Search.State /= null then
736 Free (Search.State.Dir_Contents);
737 Free (Search.State);
738 end if;
739 end Finalize;
741 ---------------
742 -- Full_Name --
743 ---------------
745 function Full_Name (Name : String) return String is
746 begin
747 -- First, the invalid case
749 if not Is_Valid_Path_Name (Name) then
752 else
753 -- Build the return value with lower bound 1
755 -- Use System.OS_Lib.Normalize_Pathname
757 declare
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);
764 begin
765 return Result (Value);
766 end;
767 end if;
768 end Full_Name;
770 function Full_Name (Directory_Entry : Directory_Entry_Type) return String is
771 begin
772 -- If the Directory_Entry is valid return the full name contained in the
773 -- entry record.
775 if not Directory_Entry.Valid then
776 raise Status_Error with "invalid directory entry";
777 else
778 return To_String (Directory_Entry.Full_Name);
779 end if;
780 end Full_Name;
782 --------------------
783 -- Get_Next_Entry --
784 --------------------
786 procedure Get_Next_Entry
787 (Search : in out Search_Type;
788 Directory_Entry : out Directory_Entry_Type)
789 is
790 begin
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";
795 end if;
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";
802 end if;
804 -- Populate Directory_Entry with the next entry and update the search
805 -- state.
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
813 -- entry.
815 if Directory_Entry.Attr_Error_Code /= 0 then
816 raise Use_Error
817 with To_String (Directory_Entry.Full_Name) & ": " &
818 Errno_Message (Err => Directory_Entry.Attr_Error_Code);
819 end if;
820 end Get_Next_Entry;
822 ----------
823 -- Kind --
824 ----------
826 function Kind (Name : String) return File_Kind is
827 begin
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
839 return Directory;
841 else
842 return Special_File;
843 end if;
844 end Kind;
846 function Kind (Directory_Entry : Directory_Entry_Type) return File_Kind is
847 begin
848 if not Directory_Entry.Valid then
849 raise Status_Error with "invalid directory entry";
850 else
851 return Directory_Entry.Kind;
852 end if;
853 end Kind;
855 -----------------------
856 -- Modification_Time --
857 -----------------------
859 function Modification_Time (Name : String) return Time is
861 Date : Time;
862 C_Name : aliased String (1 .. Name'Length + 1);
863 begin
864 -- First, the invalid cases
866 if not (Is_Regular_File (Name) or else Is_Directory (Name)) then
869 else
870 C_Name := Name & ASCII.NUL;
871 Date := C_Modification_Time (C_Name'Address);
873 if Date = Invalid_Time then
874 raise Use_Error with
876 end if;
878 return Date;
879 end if;
880 end Modification_Time;
882 function Modification_Time
883 (Directory_Entry : Directory_Entry_Type) return Ada.Calendar.Time
884 is
885 begin
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";
893 else
894 return Directory_Entry.Modification_Time;
895 end if;
896 end Modification_Time;
898 ------------------
899 -- More_Entries --
900 ------------------
902 function More_Entries (Search : Search_Type) return Boolean is
903 begin
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
909 return False;
910 elsif Search.State.Next_Entry = No_Element then
911 return False;
912 else
913 return True;
914 end if;
915 end More_Entries;
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);
923 S : Search_Type;
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");
930 begin
931 -- Check for the invalid case
933 if not Is_Valid_Path_Name (Name) then
935 end if;
938 -- the containing directory.
940 if Is_Regular_File (Name) then
941 Dir_Path := To_Unbounded_String (Containing_Directory (Name));
942 end if;
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.
949 Start_Search
950 (Search => S,
951 Directory => To_String (Dir_Path),
953 Filter => [Directory => False, others => True]);
955 loop
956 Get_Next_Entry (S, Test_File);
960 exit when To_Lower (Simple_Name (Test_File)) /=
961 To_Upper (Simple_Name (Test_File));
962 end loop;
964 End_Search (S);
966 -- Search for files within the directory with the same name, but
967 -- differing cases.
969 Start_Search_Internal
970 (Search => S,
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
977 -- file.
979 Get_Next_Entry (S, Test_File);
981 begin
982 -- If we hit two then we know we have a case-sensitive directory
984 Get_Next_Entry (S, Test_File);
985 End_Search (S);
987 return Case_Sensitive;
988 exception
989 when Status_Error =>
990 null;
991 end;
993 -- Finally, we have a file in the directory whose name is unique and
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)))
1002 then
1003 return Case_Preserving;
1004 end if;
1006 return Case_Sensitive;
1007 exception
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;
1016 ------------
1017 -- Rename --
1018 ------------
1020 procedure Rename (Old_Name, New_Name : String) is
1021 Success : Boolean;
1023 begin
1024 -- First, the invalid cases
1026 if not Is_Valid_Path_Name (Old_Name) then
1029 elsif not Is_Valid_Path_Name (New_Name) then
1032 elsif not Is_Regular_File (Old_Name)
1033 and then not Is_Directory (Old_Name)
1034 then
1037 elsif Is_Regular_File (New_Name) or else Is_Directory (New_Name) then
1038 raise Use_Error with
1042 -- Do actual rename using System.OS_Lib.Rename_File
1044 else
1045 Rename_File (Old_Name, New_Name, Success);
1047 if not Success then
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 =>
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
1059 else
1060 raise Use_Error with
1062 end if;
1063 end if;
1064 end if;
1065 end Rename;
1067 ------------
1068 -- Search --
1069 ------------
1071 procedure Search
1072 (Directory : String;
1073 Pattern : String;
1074 Filter : Filter_Type := [others => True];
1075 Process : not null access procedure
1076 (Directory_Entry : Directory_Entry_Type))
1077 is
1078 Srch : Search_Type;
1079 Directory_Entry : Directory_Entry_Type;
1081 begin
1082 Start_Search (Srch, Directory, Pattern, Filter);
1083 while More_Entries (Srch) loop
1084 Get_Next_Entry (Srch, Directory_Entry);
1085 Process (Directory_Entry);
1086 end loop;
1088 End_Search (Srch);
1089 end Search;
1091 -------------------
1092 -- Set_Directory --
1093 -------------------
1095 procedure Set_Directory (Directory : String) is
1096 Dir_Name_C : constant String := Directory & ASCII.NUL;
1097 begin
1098 if not Is_Valid_Path_Name (Directory) then
1099 raise Name_Error with
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
1109 end if;
1110 end Set_Directory;
1112 -----------------
1113 -- Simple_Name --
1114 -----------------
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;
1133 begin
1134 -- Root directories are considered simple
1136 if Is_Root_Directory_Name (Path) then
1137 return Path;
1138 end if;
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);
1147 end if;
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.
1161 begin
1163 return BN;
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) = ':'
1169 then
1170 -- We have a DOS drive letter prefix, remove it
1172 return BN (BN'First + 2 .. BN'Last);
1174 else
1175 return BN;
1176 end if;
1177 end Check_For_Standard_Dirs;
1178 end Simple_Name_Internal;
1180 -- Start of processing for Simple_Name
1182 begin
1183 -- First, the invalid case
1185 if not Is_Valid_Path_Name (Name) then
1188 else
1189 -- Build the value to return with lower bound 1
1191 declare
1192 Value : constant String := Simple_Name_Internal (Name);
1193 subtype Result is String (1 .. Value'Length);
1194 begin
1195 return Result (Value);
1196 end;
1197 end if;
1198 end Simple_Name;
1200 function Simple_Name
1201 (Directory_Entry : Directory_Entry_Type) return String is
1202 begin
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";
1208 else
1209 return To_String (Directory_Entry.Name);
1210 end if;
1211 end Simple_Name;
1213 ----------
1214 -- Size --
1215 ----------
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");
1223 begin
1224 -- First, the invalid case
1226 if not Is_Regular_File (Name) then
1227 raise Name_Error with "file """ & Name & """ does not exist";
1229 else
1230 C_Name (1 .. Name'Length) := Name;
1231 C_Name (C_Name'Last) := ASCII.NUL;
1232 return File_Size (C_Size (C_Name'Address));
1233 end if;
1234 end Size;
1236 function Size (Directory_Entry : Directory_Entry_Type) return File_Size is
1237 begin
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
1241 -- searched.
1243 if not Directory_Entry.Valid then
1244 raise Status_Error with "invalid directory entry";
1245 else
1246 return Directory_Entry.Size;
1247 end if;
1248 end Size;
1250 ------------------
1251 -- Start_Search --
1252 ------------------
1254 procedure Start_Search
1255 (Search : in out Search_Type;
1256 Directory : String;
1257 Pattern : String;
1258 Filter : Filter_Type := [others => True])
1259 is
1260 begin
1261 Start_Search_Internal (Search, Directory, Pattern, Filter, False);
1262 end Start_Search;
1264 ---------------------------
1265 -- Start_Search_Internal --
1266 ---------------------------
1268 procedure Start_Search_Internal
1269 (Search : in out Search_Type;
1270 Directory : String;
1271 Pattern : String;
1272 Filter : Filter_Type := [others => True];
1273 Case_Insensitive : Boolean)
1274 is
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;
1285 Buffer : 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
1301 begin
1302 -- Check that Directory is a valid directory
1304 if not Is_Directory (Directory) then
1305 raise Name_Error with
1307 end if;
1309 -- Check and compile the pattern
1311 declare
1312 Case_Sensitive : Boolean := Is_Path_Name_Case_Sensitive;
1313 begin
1314 if Case_Insensitive then
1315 Case_Sensitive := False;
1316 end if;
1318 Pattern_Regex :=
1319 Compile (Pattern, Glob => True, Case_Sensitive => Case_Sensitive);
1320 exception
1321 when Error_In_Regexp =>
1323 end;
1325 -- Open Directory
1327 Dir_Pointer := Dir_Type_Value (opendir (Dir_Name_C));
1329 if Dir_Pointer = No_Dir then
1330 raise Use_Error with
1332 end if;
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.
1339 Finalize (Search);
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
1355 loop
1356 -- Get next item in the directory
1358 File_Name_Addr :=
1359 readdir_gnat
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.
1369 declare
1370 File_Name : constant String (1 .. File_Name_Len)
1371 with Import, Address => File_Name_Addr;
1373 begin
1374 if Match (File_Name, Pattern_Regex) then
1375 declare
1376 Path_C : constant String :=
1377 Compose (Directory, File_Name) & ASCII.NUL;
1378 Path : String renames
1379 Path_C (Path_C'First .. Path_C'Last - 1);
1380 Attr : aliased File_Attributes;
1381 Exists : Integer;
1382 Error : Integer;
1384 type Result (Found : Boolean := False) is record
1385 case Found is
1386 when True =>
1387 Kind : File_Kind;
1388 Size : File_Size;
1389 when False =>
1390 null;
1391 end case;
1392 end record;
1394 Res : Result := (Found => False);
1396 -- This declaration of No_Time copied from GNAT.Calendar
1398 -- results in problems.
1400 No_Time : constant Ada.Calendar.Time :=
1401 Ada.Calendar.Formatting.Time_Of
1402 (Ada.Calendar.Year_Number'First,
1403 Ada.Calendar.Month_Number'First,
1404 Ada.Calendar.Day_Number'First,
1405 Time_Zone => 0);
1406 begin
1407 -- Get the file attributes for the directory item
1409 Reset_Attributes (Attr'Access);
1410 Exists := File_Exists_Attr (Path_C'Address, Attr'Access);
1411 Error := Error_Attributes (Attr'Access);
1413 -- If there was an error when trying to read the attributes
1414 -- of a Directory entry, record the error so it can be
1415 -- propagated to the user when they interate through the
1416 -- directory results.
1418 if Error /= 0 then
1419 Search.State.Dir_Contents.Append
1420 (Directory_Entry_Type'
1421 (Valid => True,
1422 Name => To_Unbounded_String (File_Name),
1423 Full_Name => To_Unbounded_String (Path),
1424 Attr_Error_Code => Error,
1425 others => <>));
1427 -- Otherwise, if the file exists and matches the file kind
1428 -- Filter, add the file to the search results. We capture
1429 -- the size and modification time here as we have already
1430 -- the entry's attributes above.
1432 elsif Exists = 1 then
1433 if Is_Regular_File_Attr (Path_C'Address, Attr'Access) = 1
1434 then
1435 if Filter (Ordinary_File) then
1436 Res := (Found => True,
1437 Kind => Ordinary_File,
1438 Size => File_Size
1439 (File_Length_Attr
1440 (-1, Path_C'Address, Attr'Access)));
1442 end if;
1443 elsif Is_Directory_Attr (Path_C'Address, Attr'Access) = 1
1444 then
1445 if Filter (File_Kind'First) then
1446 Res := (Found => True,
1447 Kind => File_Kind'First,
1448 Size => 0);
1449 end if;
1451 elsif Filter (Special_File) then
1452 Res := (Found => True,
1453 Kind => Special_File,
1454 Size => 0);
1455 end if;
1457 if Res.Found then
1458 Search.State.Dir_Contents.Append
1459 (Directory_Entry_Type'
1460 (Valid => True,
1461 Name =>
1462 To_Unbounded_String (File_Name),
1463 Full_Name => To_Unbounded_String (Path),
1464 Attr_Error_Code => 0,
1465 Kind => Res.Kind,
1466 Modification_Time =>
1467 (if Res.Kind = Special_File
1468 then No_Time
1469 else Modification_Time (Path)),
1470 Size => Res.Size));
1471 end if;
1472 end if;
1473 end;
1474 end if;
1475 end;
1476 end loop;
1478 -- Set the first entry to be returned to the user to be the first
1479 -- element of the Dir_Contents vector. If no items were found, First
1480 -- will return No_Element, which signals
1481 Search.State.Next_Entry := Search.State.Dir_Contents.First;
1483 -- Search is finished, close Directory
1485 Call_Result := closedir (DIRs (Dir_Pointer));
1487 end Start_Search_Internal;
1489 end Ada.Directories;