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-2001 Ada Core Technologies, 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 2, 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. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING. If not, write --
19 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
20 -- MA 02111-1307, USA. --
22 -- As a special exception, if other files instantiate generics from this --
23 -- unit, or you link this unit with other files to produce an executable, --
24 -- this unit does not by itself cause the resulting executable to be --
25 -- covered by the GNU General Public License. This exception does not --
26 -- however invalidate any other reasons why the executable file might be --
27 -- covered by the GNU Public License. --
29 -- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
31 ------------------------------------------------------------------------------
33 with Ada.Characters.Handling;
34 with Ada.Strings.Fixed;
35 with Ada.Strings.Maps;
36 with Unchecked_Deallocation;
37 with Unchecked_Conversion;
38 with System; use System;
42 package body GNAT.Directory_Operations is
46 type Dir_Type_Value is new System.Address;
47 -- This is the low-level address directory structure as returned by the C
51 Unchecked_Deallocation (Dir_Type_Value, Dir_Type);
59 Suffix : String := "")
62 function Get_File_Names_Case_Sensitive return Integer;
64 (C, Get_File_Names_Case_Sensitive,
65 "__gnat_get_file_names_case_sensitive");
67 Case_Sensitive_File_Name : constant Boolean :=
68 Get_File_Names_Case_Sensitive = 1;
72 Suffix : String := "")
74 -- This function does the job. The only difference between Basename
75 -- and Base_Name (the parent function) is that the former is case
76 -- sensitive, while the latter is not. Path and Suffix are adjusted
77 -- appropriately before calling Basename under platforms where the
78 -- file system is not case sensitive.
86 Suffix : String := "")
89 Cut_Start : Natural :=
91 (Path, Dir_Seps, Going => Strings.Backward);
95 -- Cut_Start point to the first basename character
98 Cut_Start := Path'First;
101 Cut_Start := Cut_Start + 1;
104 -- Cut_End point to the last basename character.
106 Cut_End := Path'Last;
108 -- If basename ends with Suffix, adjust Cut_End.
111 and then Path (Path'Last - Suffix'Length + 1 .. Cut_End) = Suffix
113 Cut_End := Path'Last - Suffix'Length;
116 Check_For_Standard_Dirs : declare
117 Offset : constant Integer := Path'First - Base_Name.Path'First;
118 BN : constant String :=
119 Base_Name.Path (Cut_Start - Offset .. Cut_End - Offset);
120 -- Here we use Base_Name.Path to keep the original casing
123 if BN = "." or else BN = ".." then
127 and then Characters.Handling.Is_Letter (BN (BN'First))
128 and then BN (BN'First + 1) = ':'
130 -- We have a DOS drive letter prefix, remove it
132 return BN (BN'First + 2 .. BN'Last);
137 end Check_For_Standard_Dirs;
140 -- Start processing for Base_Name
143 if Case_Sensitive_File_Name then
144 return Basename (Path, Suffix);
148 (Characters.Handling.To_Lower (Path),
149 Characters.Handling.To_Lower (Suffix));
157 procedure Change_Dir (Dir_Name : Dir_Name_Str) is
158 C_Dir_Name : String := Dir_Name & ASCII.NUL;
160 function chdir (Dir_Name : String) return Integer;
161 pragma Import (C, chdir, "chdir");
164 if chdir (C_Dir_Name) /= 0 then
165 raise Directory_Error;
173 procedure Close (Dir : in out Dir_Type) is
175 function closedir (Directory : System.Address) return Integer;
176 pragma Import (C, closedir, "closedir");
181 if not Is_Open (Dir) then
182 raise Directory_Error;
185 Discard := closedir (System.Address (Dir.all));
193 function Dir_Name (Path : Path_Name) return Dir_Name_Str is
194 Last_DS : constant Natural :=
196 (Path, Dir_Seps, Going => Strings.Backward);
201 -- There is no directory separator, returns current working directory
203 return "." & Dir_Separator;
206 return Path (Path'First .. Last_DS);
214 function Expand_Path (Path : Path_Name) return String is
216 Result : OS_Lib.String_Access := new String (1 .. 200);
217 Result_Last : Natural := 0;
219 procedure Append (C : Character);
220 procedure Append (S : String);
223 procedure Double_Result_Size;
224 -- Reallocate Result, doubling its size
226 procedure Read (K : in out Positive);
227 -- Update Result while reading current Path starting at position K. If
228 -- a variable is found, call Var below.
230 procedure Var (K : in out Positive);
231 -- Translate variable name starting at position K with the associated
232 -- environment value.
238 procedure Append (C : Character) is
240 if Result_Last = Result'Last then
244 Result_Last := Result_Last + 1;
245 Result (Result_Last) := C;
248 procedure Append (S : String) is
250 while Result_Last + S'Length - 1 > Result'Last loop
254 Result (Result_Last + 1 .. Result_Last + S'Length) := S;
255 Result_Last := Result_Last + S'Length;
258 ------------------------
259 -- Double_Result_Size --
260 ------------------------
262 procedure Double_Result_Size is
263 New_Result : constant OS_Lib.String_Access :=
264 new String (1 .. 2 * Result'Last);
267 New_Result (1 .. Result_Last) := Result (1 .. Result_Last);
268 OS_Lib.Free (Result);
269 Result := New_Result;
270 end Double_Result_Size;
276 procedure Read (K : in out Positive) is
278 For_All_Characters : loop
279 if Path (K) = '$' then
281 -- Could be a variable
283 if K < Path'Last then
285 if Path (K + 1) = '$' then
287 -- Not a variable after all, this is a double $, just
288 -- insert one in the result string.
294 -- Let's parse the variable
301 -- We have an ending $ sign
307 -- This is a standard character, just add it to the result
312 -- Skip to next character
316 exit For_All_Characters when K > Path'Last;
317 end loop For_All_Characters;
324 procedure Var (K : in out Positive) is
328 if Path (K) = '{' then
330 -- Look for closing } (curly bracket).
336 exit when Path (E) = '}' or else E = Path'Last;
339 if Path (E) = '}' then
341 -- OK found, translate with environment value
344 Env : OS_Lib.String_Access :=
345 OS_Lib.Getenv (Path (K + 1 .. E - 1));
353 -- No closing curly bracket, not a variable after all or a
354 -- syntax error, ignore it, insert string as-is.
357 Append (Path (K .. E));
361 -- The variable name is everything from current position to first
362 -- non letter/digit character.
366 -- Check that first chartacter is a letter
368 if Characters.Handling.Is_Letter (Path (E)) then
372 exit Var_Name when E > Path'Last;
374 if Characters.Handling.Is_Letter (Path (E))
375 or else Characters.Handling.Is_Digit (Path (E))
386 Env : OS_Lib.String_Access := OS_Lib.Getenv (Path (K .. E));
394 -- This is not a variable after all
405 -- Start of processing for Expand_Path
409 K : Positive := Path'First;
415 Returned_Value : constant String := Result (1 .. Result_Last);
418 OS_Lib.Free (Result);
419 return Returned_Value;
428 function File_Extension (Path : Path_Name) return String is
431 (Path, Dir_Seps, Going => Strings.Backward);
440 Dot := Strings.Fixed.Index (Path (First .. Path'Last),
442 Going => Strings.Backward);
444 if Dot = 0 or else Dot = Path'Last then
447 return Path (Dot .. Path'Last);
455 function File_Name (Path : Path_Name) return String is
457 return Base_Name (Path);
460 ---------------------
461 -- Format_Pathname --
462 ---------------------
464 function Format_Pathname
466 Style : Path_Style := System_Default)
469 N_Path : String := Path;
470 K : Positive := N_Path'First;
471 Prev_Dirsep : Boolean := False;
474 for J in Path'Range loop
476 if Strings.Maps.Is_In (Path (J), Dir_Seps) then
477 if not Prev_Dirsep then
479 when UNIX => N_Path (K) := '/';
480 when DOS => N_Path (K) := '\';
481 when System_Default => N_Path (K) := Dir_Separator;
490 N_Path (K) := Path (J);
492 Prev_Dirsep := False;
496 return N_Path (N_Path'First .. K - 1);
499 ---------------------
500 -- Get_Current_Dir --
501 ---------------------
504 pragma Import (C, Max_Path, "__gnat_max_path_len");
506 function Get_Current_Dir return Dir_Name_Str is
507 Current_Dir : String (1 .. Max_Path + 1);
511 Get_Current_Dir (Current_Dir, Last);
512 return Current_Dir (1 .. Last);
515 procedure Get_Current_Dir (Dir : out Dir_Name_Str; Last : out Natural) is
516 Path_Len : Natural := Max_Path;
517 Buffer : String (Dir'First .. Dir'First + Max_Path + 1);
519 procedure Local_Get_Current_Dir
520 (Dir : System.Address;
521 Length : System.Address);
522 pragma Import (C, Local_Get_Current_Dir, "__gnat_get_current_dir");
525 Local_Get_Current_Dir (Buffer'Address, Path_Len'Address);
527 if Dir'Length > Path_Len then
528 Last := Dir'First + Path_Len - 1;
533 Dir (Buffer'First .. Last) := Buffer (Buffer'First .. Last);
540 function Is_Open (Dir : Dir_Type) return Boolean is
542 return Dir /= Null_Dir
543 and then System.Address (Dir.all) /= System.Null_Address;
550 procedure Make_Dir (Dir_Name : Dir_Name_Str) is
551 C_Dir_Name : String := Dir_Name & ASCII.NUL;
553 function mkdir (Dir_Name : String) return Integer;
554 pragma Import (C, mkdir, "__gnat_mkdir");
557 if mkdir (C_Dir_Name) /= 0 then
558 raise Directory_Error;
568 Dir_Name : Dir_Name_Str)
570 C_File_Name : String := Dir_Name & ASCII.NUL;
574 return Dir_Type_Value;
575 pragma Import (C, opendir, "opendir");
578 Dir := new Dir_Type_Value'(opendir (C_File_Name));
580 if not Is_Open (Dir) then
583 raise Directory_Error;
592 (Dir : in out Dir_Type;
596 Filename_Addr : Address;
597 Filename_Len : Integer;
599 Buffer : array (0 .. 1024) of Character;
600 -- 1024 is the value of FILENAME_MAX in stdio.h
602 function readdir_gnat
603 (Directory : System.Address;
604 Buffer : System.Address)
605 return System.Address;
606 pragma Import (C, readdir_gnat, "__gnat_readdir");
608 function strlen (S : Address) return Integer;
609 pragma Import (C, strlen, "strlen");
612 if not Is_Open (Dir) then
613 raise Directory_Error;
617 readdir_gnat (System.Address (Dir.all), Buffer'Address);
619 if Filename_Addr = System.Null_Address then
624 Filename_Len := strlen (Filename_Addr);
626 if Str'Length > Filename_Len then
627 Last := Str'First + Filename_Len - 1;
633 subtype Path_String is String (1 .. Filename_Len);
634 type Path_String_Access is access Path_String;
636 function Address_To_Access is new
639 Target => Path_String_Access);
641 Path_Access : Path_String_Access := Address_To_Access (Filename_Addr);
644 for J in Str'First .. Last loop
645 Str (J) := Path_Access (J - Str'First + 1);
650 -------------------------
651 -- Read_Is_Thread_Sage --
652 -------------------------
654 function Read_Is_Thread_Safe return Boolean is
656 function readdir_is_thread_safe return Integer;
658 (C, readdir_is_thread_safe, "__gnat_readdir_is_thread_safe");
661 return (readdir_is_thread_safe /= 0);
662 end Read_Is_Thread_Safe;
668 procedure Remove_Dir (Dir_Name : Dir_Name_Str) is
669 C_Dir_Name : String := Dir_Name & ASCII.NUL;
671 procedure rmdir (Dir_Name : String);
672 pragma Import (C, rmdir, "rmdir");
678 end GNAT.Directory_Operations;