Merge -r 127928:132243 from trunk
[official-gcc.git] / gcc / ada / g-dirope.adb
blob774444d08266356d4daac66963277a11435a3492
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- G N A T . D I R E C T O R Y _ O P E R A T I O N S --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 1998-2007, AdaCore --
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 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, 51 Franklin Street, Fifth Floor, --
20 -- Boston, MA 02110-1301, USA. --
21 -- --
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. --
28 -- --
29 -- GNAT was originally developed by the GNAT team at New York University. --
30 -- Extensive contributions were provided by Ada Core Technologies Inc. --
31 -- --
32 ------------------------------------------------------------------------------
34 with Ada.Characters.Handling;
35 with Ada.Strings.Fixed;
37 with Ada.Unchecked_Deallocation;
38 with Ada.Unchecked_Conversion;
40 with System; use System;
41 with System.CRTL; use System.CRTL;
43 with GNAT.OS_Lib;
45 package body GNAT.Directory_Operations is
47 use Ada;
49 type Dir_Type_Value is new System.Address;
50 -- This is the low-level address directory structure as returned by the C
51 -- opendir routine.
53 Filename_Max : constant Integer := 1024;
54 -- 1024 is the value of FILENAME_MAX in stdio.h
56 procedure Free is new
57 Ada.Unchecked_Deallocation (Dir_Type_Value, Dir_Type);
59 On_Windows : constant Boolean := GNAT.OS_Lib.Directory_Separator = '\';
60 -- An indication that we are on Windows. Used in Get_Current_Dir, to
61 -- deal with drive letters in the beginning of absolute paths.
63 ---------------
64 -- Base_Name --
65 ---------------
67 function Base_Name
68 (Path : Path_Name;
69 Suffix : String := "") return String
71 function Get_File_Names_Case_Sensitive return Integer;
72 pragma Import
73 (C, Get_File_Names_Case_Sensitive,
74 "__gnat_get_file_names_case_sensitive");
76 Case_Sensitive_File_Name : constant Boolean :=
77 Get_File_Names_Case_Sensitive = 1;
79 function Basename
80 (Path : Path_Name;
81 Suffix : String := "") return String;
82 -- This function does the job. The only difference between Basename
83 -- and Base_Name (the parent function) is that the former is case
84 -- sensitive, while the latter is not. Path and Suffix are adjusted
85 -- appropriately before calling Basename under platforms where the
86 -- file system is not case sensitive.
88 --------------
89 -- Basename --
90 --------------
92 function Basename
93 (Path : Path_Name;
94 Suffix : String := "") return String
96 Cut_Start : Natural :=
97 Strings.Fixed.Index
98 (Path, Dir_Seps, Going => Strings.Backward);
99 Cut_End : Natural;
101 begin
102 -- Cut_Start point to the first basename character
104 if Cut_Start = 0 then
105 Cut_Start := Path'First;
107 else
108 Cut_Start := Cut_Start + 1;
109 end if;
111 -- Cut_End point to the last basename character
113 Cut_End := Path'Last;
115 -- If basename ends with Suffix, adjust Cut_End
117 if Suffix /= ""
118 and then Path (Path'Last - Suffix'Length + 1 .. Cut_End) = Suffix
119 then
120 Cut_End := Path'Last - Suffix'Length;
121 end if;
123 Check_For_Standard_Dirs : declare
124 Offset : constant Integer := Path'First - Base_Name.Path'First;
125 BN : constant String :=
126 Base_Name.Path (Cut_Start - Offset .. Cut_End - Offset);
127 -- Here we use Base_Name.Path to keep the original casing
129 Has_Drive_Letter : constant Boolean :=
130 OS_Lib.Path_Separator /= ':';
131 -- If Path separator is not ':' then we are on a DOS based OS
132 -- where this character is used as a drive letter separator.
134 begin
135 if BN = "." or else BN = ".." then
136 return "";
138 elsif Has_Drive_Letter
139 and then BN'Length > 2
140 and then Characters.Handling.Is_Letter (BN (BN'First))
141 and then BN (BN'First + 1) = ':'
142 then
143 -- We have a DOS drive letter prefix, remove it
145 return BN (BN'First + 2 .. BN'Last);
147 else
148 return BN;
149 end if;
150 end Check_For_Standard_Dirs;
151 end Basename;
153 -- Start processing for Base_Name
155 begin
156 if Path'Length <= Suffix'Length then
157 return Path;
158 end if;
160 if Case_Sensitive_File_Name then
161 return Basename (Path, Suffix);
162 else
163 return Basename
164 (Characters.Handling.To_Lower (Path),
165 Characters.Handling.To_Lower (Suffix));
166 end if;
167 end Base_Name;
169 ----------------
170 -- Change_Dir --
171 ----------------
173 procedure Change_Dir (Dir_Name : Dir_Name_Str) is
174 C_Dir_Name : constant String := Dir_Name & ASCII.NUL;
176 function chdir (Dir_Name : String) return Integer;
177 pragma Import (C, chdir, "chdir");
179 begin
180 if chdir (C_Dir_Name) /= 0 then
181 raise Directory_Error;
182 end if;
183 end Change_Dir;
185 -----------
186 -- Close --
187 -----------
189 procedure Close (Dir : in out Dir_Type) is
190 Discard : Integer;
191 pragma Warnings (Off, Discard);
193 function closedir (directory : DIRs) return Integer;
194 pragma Import (C, closedir, "__gnat_closedir");
196 begin
197 if not Is_Open (Dir) then
198 raise Directory_Error;
199 end if;
201 Discard := closedir (DIRs (Dir.all));
202 Free (Dir);
203 end Close;
205 --------------
206 -- Dir_Name --
207 --------------
209 function Dir_Name (Path : Path_Name) return Dir_Name_Str is
210 Last_DS : constant Natural :=
211 Strings.Fixed.Index
212 (Path, Dir_Seps, Going => Strings.Backward);
214 begin
215 if Last_DS = 0 then
217 -- There is no directory separator, returns current working directory
219 return "." & Dir_Separator;
221 else
222 return Path (Path'First .. Last_DS);
223 end if;
224 end Dir_Name;
226 -----------------
227 -- Expand_Path --
228 -----------------
230 function Expand_Path
231 (Path : Path_Name;
232 Mode : Environment_Style := System_Default) return Path_Name
234 Environment_Variable_Char : Character;
235 pragma Import (C, Environment_Variable_Char, "__gnat_environment_char");
237 Result : OS_Lib.String_Access := new String (1 .. 200);
238 Result_Last : Natural := 0;
240 procedure Append (C : Character);
241 procedure Append (S : String);
242 -- Append to Result
244 procedure Double_Result_Size;
245 -- Reallocate Result, doubling its size
247 function Is_Var_Prefix (C : Character) return Boolean;
248 pragma Inline (Is_Var_Prefix);
250 procedure Read (K : in out Positive);
251 -- Update Result while reading current Path starting at position K. If
252 -- a variable is found, call Var below.
254 procedure Var (K : in out Positive);
255 -- Translate variable name starting at position K with the associated
256 -- environment value.
258 ------------
259 -- Append --
260 ------------
262 procedure Append (C : Character) is
263 begin
264 if Result_Last = Result'Last then
265 Double_Result_Size;
266 end if;
268 Result_Last := Result_Last + 1;
269 Result (Result_Last) := C;
270 end Append;
272 procedure Append (S : String) is
273 begin
274 while Result_Last + S'Length - 1 > Result'Last loop
275 Double_Result_Size;
276 end loop;
278 Result (Result_Last + 1 .. Result_Last + S'Length) := S;
279 Result_Last := Result_Last + S'Length;
280 end Append;
282 ------------------------
283 -- Double_Result_Size --
284 ------------------------
286 procedure Double_Result_Size is
287 New_Result : constant OS_Lib.String_Access :=
288 new String (1 .. 2 * Result'Last);
289 begin
290 New_Result (1 .. Result_Last) := Result (1 .. Result_Last);
291 OS_Lib.Free (Result);
292 Result := New_Result;
293 end Double_Result_Size;
295 -------------------
296 -- Is_Var_Prefix --
297 -------------------
299 function Is_Var_Prefix (C : Character) return Boolean is
300 begin
301 return (C = Environment_Variable_Char and then Mode = System_Default)
302 or else
303 (C = '$' and then (Mode = UNIX or else Mode = Both))
304 or else
305 (C = '%' and then (Mode = DOS or else Mode = Both));
306 end Is_Var_Prefix;
308 ----------
309 -- Read --
310 ----------
312 procedure Read (K : in out Positive) is
313 P : Character;
315 begin
316 For_All_Characters : loop
317 if Is_Var_Prefix (Path (K)) then
318 P := Path (K);
320 -- Could be a variable
322 if K < Path'Last then
323 if Path (K + 1) = P then
325 -- Not a variable after all, this is a double $ or %,
326 -- just insert one in the result string.
328 Append (P);
329 K := K + 1;
331 else
332 -- Let's parse the variable
334 Var (K);
335 end if;
337 else
338 -- We have an ending $ or % sign
340 Append (P);
341 end if;
343 else
344 -- This is a standard character, just add it to the result
346 Append (Path (K));
347 end if;
349 -- Skip to next character
351 K := K + 1;
353 exit For_All_Characters when K > Path'Last;
354 end loop For_All_Characters;
355 end Read;
357 ---------
358 -- Var --
359 ---------
361 procedure Var (K : in out Positive) is
362 P : constant Character := Path (K);
363 T : Character;
364 E : Positive;
366 begin
367 K := K + 1;
369 if P = '%' or else Path (K) = '{' then
371 -- Set terminator character
373 if P = '%' then
374 T := '%';
375 else
376 T := '}';
377 K := K + 1;
378 end if;
380 -- Look for terminator character, k point to the first character
381 -- for the variable name.
383 E := K;
385 loop
386 E := E + 1;
387 exit when Path (E) = T or else E = Path'Last;
388 end loop;
390 if Path (E) = T then
392 -- OK found, translate with environment value
394 declare
395 Env : OS_Lib.String_Access :=
396 OS_Lib.Getenv (Path (K .. E - 1));
398 begin
399 Append (Env.all);
400 OS_Lib.Free (Env);
401 end;
403 else
404 -- No terminator character, not a variable after all or a
405 -- syntax error, ignore it, insert string as-is.
407 Append (P); -- Add prefix character
409 if T = '}' then -- If we were looking for curly bracket
410 Append ('{'); -- terminator, add the curly bracket
411 end if;
413 Append (Path (K .. E));
414 end if;
416 else
417 -- The variable name is everything from current position to first
418 -- non letter/digit character.
420 E := K;
422 -- Check that first chartacter is a letter
424 if Characters.Handling.Is_Letter (Path (E)) then
425 E := E + 1;
427 Var_Name : loop
428 exit Var_Name when E > Path'Last;
430 if Characters.Handling.Is_Letter (Path (E))
431 or else Characters.Handling.Is_Digit (Path (E))
432 then
433 E := E + 1;
434 else
435 exit Var_Name;
436 end if;
437 end loop Var_Name;
439 E := E - 1;
441 declare
442 Env : OS_Lib.String_Access := OS_Lib.Getenv (Path (K .. E));
444 begin
445 Append (Env.all);
446 OS_Lib.Free (Env);
447 end;
449 else
450 -- This is not a variable after all
452 Append ('$');
453 Append (Path (E));
454 end if;
456 end if;
458 K := E;
459 end Var;
461 -- Start of processing for Expand_Path
463 begin
464 declare
465 K : Positive := Path'First;
467 begin
468 Read (K);
470 declare
471 Returned_Value : constant String := Result (1 .. Result_Last);
473 begin
474 OS_Lib.Free (Result);
475 return Returned_Value;
476 end;
477 end;
478 end Expand_Path;
480 --------------------
481 -- File_Extension --
482 --------------------
484 function File_Extension (Path : Path_Name) return String is
485 First : Natural :=
486 Strings.Fixed.Index
487 (Path, Dir_Seps, Going => Strings.Backward);
489 Dot : Natural;
491 begin
492 if First = 0 then
493 First := Path'First;
494 end if;
496 Dot := Strings.Fixed.Index (Path (First .. Path'Last),
497 ".",
498 Going => Strings.Backward);
500 if Dot = 0 or else Dot = Path'Last then
501 return "";
502 else
503 return Path (Dot .. Path'Last);
504 end if;
505 end File_Extension;
507 ---------------
508 -- File_Name --
509 ---------------
511 function File_Name (Path : Path_Name) return String is
512 begin
513 return Base_Name (Path);
514 end File_Name;
516 ---------------------
517 -- Format_Pathname --
518 ---------------------
520 function Format_Pathname
521 (Path : Path_Name;
522 Style : Path_Style := System_Default) return String
524 N_Path : String := Path;
525 K : Positive := N_Path'First;
526 Prev_Dirsep : Boolean := False;
528 begin
529 if Dir_Separator = '\'
530 and then Path'Length > 1
531 and then Path (K .. K + 1) = "\\"
532 then
533 if Style = UNIX then
534 N_Path (K .. K + 1) := "//";
535 end if;
537 K := K + 2;
538 end if;
540 for J in K .. Path'Last loop
541 if Strings.Maps.Is_In (Path (J), Dir_Seps) then
542 if not Prev_Dirsep then
543 case Style is
544 when UNIX => N_Path (K) := '/';
545 when DOS => N_Path (K) := '\';
546 when System_Default => N_Path (K) := Dir_Separator;
547 end case;
549 K := K + 1;
550 end if;
552 Prev_Dirsep := True;
554 else
555 N_Path (K) := Path (J);
556 K := K + 1;
557 Prev_Dirsep := False;
558 end if;
559 end loop;
561 return N_Path (N_Path'First .. K - 1);
562 end Format_Pathname;
564 ---------------------
565 -- Get_Current_Dir --
566 ---------------------
568 Max_Path : Integer;
569 pragma Import (C, Max_Path, "__gnat_max_path_len");
571 function Get_Current_Dir return Dir_Name_Str is
572 Current_Dir : String (1 .. Max_Path + 1);
573 Last : Natural;
574 begin
575 Get_Current_Dir (Current_Dir, Last);
576 return Current_Dir (1 .. Last);
577 end Get_Current_Dir;
579 procedure Get_Current_Dir (Dir : out Dir_Name_Str; Last : out Natural) is
580 Path_Len : Natural := Max_Path;
581 Buffer : String (Dir'First .. Dir'First + Max_Path + 1);
583 procedure Local_Get_Current_Dir
584 (Dir : System.Address;
585 Length : System.Address);
586 pragma Import (C, Local_Get_Current_Dir, "__gnat_get_current_dir");
588 begin
589 Local_Get_Current_Dir (Buffer'Address, Path_Len'Address);
591 if Dir'Length > Path_Len then
592 Last := Dir'First + Path_Len - 1;
593 else
594 Last := Dir'Last;
595 end if;
597 Dir (Buffer'First .. Last) := Buffer (Buffer'First .. Last);
599 -- By default, the drive letter on Windows is in upper case
601 if On_Windows and then Last > Dir'First and then
602 Dir (Dir'First + 1) = ':'
603 then
604 Dir (Dir'First) :=
605 Ada.Characters.Handling.To_Upper (Dir (Dir'First));
606 end if;
607 end Get_Current_Dir;
609 -------------
610 -- Is_Open --
611 -------------
613 function Is_Open (Dir : Dir_Type) return Boolean is
614 begin
615 return Dir /= Null_Dir
616 and then System.Address (Dir.all) /= System.Null_Address;
617 end Is_Open;
619 --------------
620 -- Make_Dir --
621 --------------
623 procedure Make_Dir (Dir_Name : Dir_Name_Str) is
624 C_Dir_Name : constant String := Dir_Name & ASCII.NUL;
626 function mkdir (Dir_Name : String) return Integer;
627 pragma Import (C, mkdir, "__gnat_mkdir");
629 begin
630 if mkdir (C_Dir_Name) /= 0 then
631 raise Directory_Error;
632 end if;
633 end Make_Dir;
635 ----------
636 -- Open --
637 ----------
639 procedure Open
640 (Dir : out Dir_Type;
641 Dir_Name : Dir_Name_Str)
643 function opendir (file_name : String) return DIRs;
644 pragma Import (C, opendir, "__gnat_opendir");
646 C_File_Name : constant String := Dir_Name & ASCII.NUL;
648 begin
649 Dir := new Dir_Type_Value'(Dir_Type_Value (opendir (C_File_Name)));
651 if not Is_Open (Dir) then
652 Free (Dir);
653 Dir := Null_Dir;
654 raise Directory_Error;
655 end if;
656 end Open;
658 ----------
659 -- Read --
660 ----------
662 procedure Read
663 (Dir : Dir_Type;
664 Str : out String;
665 Last : out Natural)
667 Filename_Addr : Address;
668 Filename_Len : aliased Integer;
670 Buffer : array (0 .. Filename_Max + 12) of Character;
671 -- 12 is the size of the dirent structure (see dirent.h), without the
672 -- field for the filename.
674 function readdir_gnat
675 (Directory : System.Address;
676 Buffer : System.Address;
677 Last : not null access Integer) return System.Address;
678 pragma Import (C, readdir_gnat, "__gnat_readdir");
680 begin
681 if not Is_Open (Dir) then
682 raise Directory_Error;
683 end if;
685 Filename_Addr :=
686 readdir_gnat
687 (System.Address (Dir.all), Buffer'Address, Filename_Len'Access);
689 if Filename_Addr = System.Null_Address then
690 Last := 0;
691 return;
692 end if;
694 if Str'Length > Filename_Len then
695 Last := Str'First + Filename_Len - 1;
696 else
697 Last := Str'Last;
698 end if;
700 declare
701 subtype Path_String is String (1 .. Filename_Len);
702 type Path_String_Access is access Path_String;
704 function Address_To_Access is new
705 Ada.Unchecked_Conversion
706 (Source => Address,
707 Target => Path_String_Access);
709 Path_Access : constant Path_String_Access :=
710 Address_To_Access (Filename_Addr);
712 begin
713 for J in Str'First .. Last loop
714 Str (J) := Path_Access (J - Str'First + 1);
715 end loop;
716 end;
717 end Read;
719 -------------------------
720 -- Read_Is_Thread_Sage --
721 -------------------------
723 function Read_Is_Thread_Safe return Boolean is
724 function readdir_is_thread_safe return Integer;
725 pragma Import
726 (C, readdir_is_thread_safe, "__gnat_readdir_is_thread_safe");
727 begin
728 return (readdir_is_thread_safe /= 0);
729 end Read_Is_Thread_Safe;
731 ----------------
732 -- Remove_Dir --
733 ----------------
735 procedure Remove_Dir
736 (Dir_Name : Dir_Name_Str;
737 Recursive : Boolean := False)
739 C_Dir_Name : constant String := Dir_Name & ASCII.NUL;
740 Current_Dir : constant Dir_Name_Str := Get_Current_Dir;
741 Last : Integer;
742 Str : String (1 .. Filename_Max);
743 Success : Boolean;
744 Working_Dir : Dir_Type;
746 begin
747 -- Remove the directory only if it is empty
749 if not Recursive then
750 rmdir (C_Dir_Name);
752 if GNAT.OS_Lib.Is_Directory (Dir_Name) then
753 raise Directory_Error;
754 end if;
756 -- Remove directory and all files and directories that it may contain
758 else
759 -- Substantial comments needed. See RH for revision 1.50 ???
761 begin
762 Change_Dir (Dir_Name);
763 Open (Working_Dir, ".");
765 loop
766 Read (Working_Dir, Str, Last);
767 exit when Last = 0;
769 if GNAT.OS_Lib.Is_Directory (Str (1 .. Last)) then
770 if Str (1 .. Last) /= "."
771 and then
772 Str (1 .. Last) /= ".."
773 then
774 Remove_Dir (Str (1 .. Last), True);
775 Remove_Dir (Str (1 .. Last));
776 end if;
778 else
779 GNAT.OS_Lib.Delete_File (Str (1 .. Last), Success);
781 if not Success then
782 Change_Dir (Current_Dir);
783 raise Directory_Error;
784 end if;
785 end if;
786 end loop;
788 Change_Dir (Current_Dir);
789 Close (Working_Dir);
790 Remove_Dir (Dir_Name);
792 exception
793 when others =>
795 -- An exception occurred. We must make sure the current working
796 -- directory is unchanged.
798 Change_Dir (Current_Dir);
800 -- What if the Change_Dir raises an exception itself, shouldn't
801 -- that be protected? ???
803 raise;
804 end;
805 end if;
806 end Remove_Dir;
808 end GNAT.Directory_Operations;