1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
5 -- G N A T . D I R E C T O R Y _ O P E R A T I O N S --
9 -- Copyright (C) 1998-2020, AdaCore --
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.IO_Exceptions;
33 with Ada.Characters.Handling;
34 with Ada.Strings.Fixed;
36 with Ada.Unchecked_Deallocation;
37 with Ada.Unchecked_Conversion;
39 with System; use System;
40 with System.CRTL; use System.CRTL;
44 package body GNAT.Directory_Operations is
48 Filename_Max : constant Integer := 1024;
49 -- 1024 is the value of FILENAME_MAX in stdio.h
52 Ada.Unchecked_Deallocation (Dir_Type_Value, Dir_Type);
54 On_Windows : constant Boolean := GNAT.OS_Lib.Directory_Separator = '\';
55 -- An indication that we are on Windows. Used in Get_Current_Dir, to
56 -- deal with drive letters in the beginning of absolute paths.
64 Suffix : String := "") return String
66 function Get_File_Names_Case_Sensitive return Integer;
68 (C, Get_File_Names_Case_Sensitive,
69 "__gnat_get_file_names_case_sensitive");
71 Case_Sensitive_File_Name : constant Boolean :=
72 Get_File_Names_Case_Sensitive = 1;
76 Suffix : String := "") return String;
77 -- This function does the job. The only difference between Basename
78 -- and Base_Name (the parent function) is that the former is case
79 -- sensitive, while the latter is not. Path and Suffix are adjusted
80 -- appropriately before calling Basename under platforms where the
81 -- file system is not case sensitive.
89 Suffix : String := "") return String
91 Cut_Start : Natural :=
93 (Path, Dir_Seps, Going => Strings.Backward);
97 -- Cut_Start point to the first basename character
99 Cut_Start := (if Cut_Start = 0 then Path'First else Cut_Start + 1);
101 -- Cut_End point to the last basename character
103 Cut_End := Path'Last;
105 -- If basename ends with Suffix, adjust Cut_End
108 and then Path (Path'Last - Suffix'Length + 1 .. Cut_End) = Suffix
110 Cut_End := Path'Last - Suffix'Length;
113 Check_For_Standard_Dirs : declare
114 Offset : constant Integer := Path'First - Base_Name.Path'First;
115 BN : constant String :=
116 Base_Name.Path (Cut_Start - Offset .. Cut_End - Offset);
117 -- Here we use Base_Name.Path to keep the original casing
119 Has_Drive_Letter : constant Boolean :=
120 OS_Lib.Path_Separator /= ':';
121 -- If Path separator is not ':' then we are on a DOS based OS
122 -- where this character is used as a drive letter separator.
125 if BN = "." or else BN = ".." then
128 elsif Has_Drive_Letter
129 and then BN'Length > 2
130 and then Characters.Handling.Is_Letter (BN (BN'First))
131 and then BN (BN'First + 1) = ':'
133 -- We have a DOS drive letter prefix, remove it
135 return BN (BN'First + 2 .. BN'Last);
140 end Check_For_Standard_Dirs;
143 -- Start of processing for Base_Name
146 if Path'Length <= Suffix'Length then
150 if Case_Sensitive_File_Name then
151 return Basename (Path, Suffix);
154 (Characters.Handling.To_Lower (Path),
155 Characters.Handling.To_Lower (Suffix));
163 procedure Change_Dir (Dir_Name : Dir_Name_Str) is
164 C_Dir_Name : constant String := Dir_Name & ASCII.NUL;
166 if chdir (C_Dir_Name) /= 0 then
167 raise Directory_Error;
175 procedure Close (Dir : in out Dir_Type) is
177 pragma Warnings (Off, Discard);
179 function closedir (directory : DIRs) return Integer;
180 pragma Import (C, closedir, "__gnat_closedir");
183 if not Is_Open (Dir) then
184 raise Directory_Error;
187 Discard := closedir (DIRs (Dir.all));
195 function Dir_Name (Path : Path_Name) return Dir_Name_Str is
196 Last_DS : constant Natural :=
198 (Path, Dir_Seps, Going => Strings.Backward);
203 -- There is no directory separator, returns current working directory
205 return "." & Dir_Separator;
208 return Path (Path'First .. Last_DS);
218 Mode : Environment_Style := System_Default) return Path_Name
220 Environment_Variable_Char : Character;
221 pragma Import (C, Environment_Variable_Char, "__gnat_environment_char");
223 Result : OS_Lib.String_Access := new String (1 .. 200);
224 Result_Last : Natural := 0;
226 procedure Append (C : Character);
227 procedure Append (S : String);
230 procedure Double_Result_Size;
231 -- Reallocate Result, doubling its size
233 function Is_Var_Prefix (C : Character) return Boolean;
234 pragma Inline (Is_Var_Prefix);
236 procedure Read (K : in out Positive);
237 -- Update Result while reading current Path starting at position K. If
238 -- a variable is found, call Var below.
240 procedure Var (K : in out Positive);
241 -- Translate variable name starting at position K with the associated
242 -- environment value.
248 procedure Append (C : Character) is
250 if Result_Last = Result'Last then
254 Result_Last := Result_Last + 1;
255 Result (Result_Last) := C;
258 procedure Append (S : String) is
260 while Result_Last + S'Length - 1 > Result'Last loop
264 Result (Result_Last + 1 .. Result_Last + S'Length) := S;
265 Result_Last := Result_Last + S'Length;
268 ------------------------
269 -- Double_Result_Size --
270 ------------------------
272 procedure Double_Result_Size is
273 New_Result : constant OS_Lib.String_Access :=
274 new String (1 .. 2 * Result'Last);
276 New_Result (1 .. Result_Last) := Result (1 .. Result_Last);
277 OS_Lib.Free (Result);
278 Result := New_Result;
279 end Double_Result_Size;
285 function Is_Var_Prefix (C : Character) return Boolean is
287 return (C = Environment_Variable_Char and then Mode = System_Default)
289 (C = '$' and then (Mode = UNIX or else Mode = Both))
291 (C = '%' and then (Mode = DOS or else Mode = Both));
298 procedure Read (K : in out Positive) is
302 For_All_Characters : loop
303 if Is_Var_Prefix (Path (K)) then
306 -- Could be a variable
308 if K < Path'Last then
309 if Path (K + 1) = P then
311 -- Not a variable after all, this is a double $ or %,
312 -- just insert one in the result string.
318 -- Let's parse the variable
324 -- We have an ending $ or % sign
330 -- This is a standard character, just add it to the result
335 -- Skip to next character
339 exit For_All_Characters when K > Path'Last;
340 end loop For_All_Characters;
347 procedure Var (K : in out Positive) is
348 P : constant Character := Path (K);
355 pragma Annotate (CodePeer, Modified, P);
357 if P = '%' or else Path (K) = '{' then
359 -- Set terminator character
368 -- Look for terminator character, k point to the first character
369 -- for the variable name.
375 exit when Path (E) = T or else E = Path'Last;
380 -- OK found, translate with environment value
383 Env : OS_Lib.String_Access :=
384 OS_Lib.Getenv (Path (K .. E - 1));
392 -- No terminator character, not a variable after all or a
393 -- syntax error, ignore it, insert string as-is.
395 Append (P); -- Add prefix character
397 if T = '}' then -- If we were looking for curly bracket
398 Append ('{'); -- terminator, add the curly bracket
401 Append (Path (K .. E));
405 -- The variable name is everything from current position to first
406 -- non letter/digit character.
410 -- Check that first character is a letter
412 if Characters.Handling.Is_Letter (Path (E)) then
416 exit Var_Name when E > Path'Last;
418 if Characters.Handling.Is_Letter (Path (E))
419 or else Characters.Handling.Is_Digit (Path (E))
430 Env : OS_Lib.String_Access := OS_Lib.Getenv (Path (K .. E));
438 -- This is not a variable after all
449 -- Start of processing for Expand_Path
453 K : Positive := Path'First;
459 Returned_Value : constant String := Result (1 .. Result_Last);
462 OS_Lib.Free (Result);
463 return Returned_Value;
472 function File_Extension (Path : Path_Name) return String is
475 (Path, Dir_Seps, Going => Strings.Backward);
484 Dot := Strings.Fixed.Index (Path (First .. Path'Last),
486 Going => Strings.Backward);
488 if Dot = 0 or else Dot = Path'Last then
491 return Path (Dot .. Path'Last);
499 function File_Name (Path : Path_Name) return String is
501 return Base_Name (Path);
504 ---------------------
505 -- Format_Pathname --
506 ---------------------
508 function Format_Pathname
510 Style : Path_Style := System_Default) return String
512 N_Path : String := Path;
513 K : Positive := N_Path'First;
514 Prev_Dirsep : Boolean := False;
517 if Dir_Separator = '\'
518 and then Path'Length > 1
519 and then Path (K .. K + 1) = "\\"
522 N_Path (K .. K + 1) := "//";
528 for J in K .. Path'Last loop
529 if Strings.Maps.Is_In (Path (J), Dir_Seps) then
530 if not Prev_Dirsep then
532 when UNIX => N_Path (K) := '/';
533 when DOS => N_Path (K) := '\';
534 when System_Default => N_Path (K) := Dir_Separator;
543 N_Path (K) := Path (J);
545 Prev_Dirsep := False;
549 return N_Path (N_Path'First .. K - 1);
552 ---------------------
553 -- Get_Current_Dir --
554 ---------------------
557 pragma Import (C, Max_Path, "__gnat_max_path_len");
559 function Get_Current_Dir return Dir_Name_Str is
560 Current_Dir : String (1 .. Max_Path + 1);
563 Get_Current_Dir (Current_Dir, Last);
564 return Current_Dir (1 .. Last);
567 procedure Get_Current_Dir (Dir : out Dir_Name_Str; Last : out Natural) is
568 Path_Len : Natural := Max_Path;
569 Buffer : String (Dir'First .. Dir'First + Max_Path + 1);
571 procedure Local_Get_Current_Dir
572 (Dir : System.Address;
573 Length : System.Address);
574 pragma Import (C, Local_Get_Current_Dir, "__gnat_get_current_dir");
577 Local_Get_Current_Dir (Buffer'Address, Path_Len'Address);
580 raise Ada.IO_Exceptions.Use_Error
581 with "current directory does not exist";
585 (if Dir'Length > Path_Len then Dir'First + Path_Len - 1 else Dir'Last);
587 Dir (Buffer'First .. Last) := Buffer (Buffer'First .. Last);
589 -- By default, the drive letter on Windows is in upper case
591 if On_Windows and then Last > Dir'First and then
592 Dir (Dir'First + 1) = ':'
595 Ada.Characters.Handling.To_Upper (Dir (Dir'First));
603 function Is_Open (Dir : Dir_Type) return Boolean is
605 return Dir /= Null_Dir
606 and then System.Address (Dir.all) /= System.Null_Address;
613 procedure Make_Dir (Dir_Name : Dir_Name_Str) is
614 C_Dir_Name : constant String := Dir_Name & ASCII.NUL;
616 if CRTL.mkdir (C_Dir_Name, Unspecified) /= 0 then
617 raise Directory_Error;
627 Dir_Name : Dir_Name_Str)
629 function opendir (file_name : String) return DIRs;
630 pragma Import (C, opendir, "__gnat_opendir");
632 C_File_Name : constant String := Dir_Name & ASCII.NUL;
635 Dir := new Dir_Type_Value'(Dir_Type_Value (opendir (C_File_Name)));
637 if not Is_Open (Dir) then
640 raise Directory_Error;
653 Filename_Addr : Address;
654 Filename_Len : aliased Integer;
656 Buffer : array (0 .. Filename_Max + 12) of Character;
657 -- 12 is the size of the dirent structure (see dirent.h), without the
658 -- field for the filename.
660 function readdir_gnat
661 (Directory : System.Address;
662 Buffer : System.Address;
663 Last : not null access Integer) return System.Address;
664 pragma Import (C, readdir_gnat, "__gnat_readdir");
667 if not Is_Open (Dir) then
668 raise Directory_Error;
673 (System.Address (Dir.all), Buffer'Address, Filename_Len'Access);
675 if Filename_Addr = System.Null_Address then
681 (if Str'Length > Filename_Len then Str'First + Filename_Len - 1
685 subtype Path_String is String (1 .. Filename_Len);
686 type Path_String_Access is access Path_String;
688 function Address_To_Access is new
689 Ada.Unchecked_Conversion
691 Target => Path_String_Access);
693 Path_Access : constant Path_String_Access :=
694 Address_To_Access (Filename_Addr);
697 for J in Str'First .. Last loop
698 Str (J) := Path_Access (J - Str'First + 1);
703 -------------------------
704 -- Read_Is_Thread_Safe --
705 -------------------------
707 function Read_Is_Thread_Safe return Boolean is
708 function readdir_is_thread_safe return Integer;
710 (C, readdir_is_thread_safe, "__gnat_readdir_is_thread_safe");
712 return (readdir_is_thread_safe /= 0);
713 end Read_Is_Thread_Safe;
720 (Dir_Name : Dir_Name_Str;
721 Recursive : Boolean := False)
723 C_Dir_Name : constant String := Dir_Name & ASCII.NUL;
725 Str : String (1 .. Filename_Max);
727 Current_Dir : Dir_Type;
730 -- Remove the directory only if it is empty
732 if not Recursive then
733 if rmdir (C_Dir_Name) /= 0 then
734 raise Directory_Error;
737 -- Remove directory and all files and directories that it may contain
740 Open (Current_Dir, Dir_Name);
743 Read (Current_Dir, Str, Last);
746 if GNAT.OS_Lib.Is_Directory
747 (Dir_Name & Dir_Separator & Str (1 .. Last))
749 if Str (1 .. Last) /= "."
751 Str (1 .. Last) /= ".."
753 -- Recursive call to remove a subdirectory and all its
757 (Dir_Name & Dir_Separator & Str (1 .. Last),
762 GNAT.OS_Lib.Delete_File
763 (Dir_Name & Dir_Separator & Str (1 .. Last),
767 raise Directory_Error;
773 Remove_Dir (Dir_Name);
777 end GNAT.Directory_Operations;