File : g-dirope.adb
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-2014, 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 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 -- --
19 -- --
20 -- --
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 ------------------------------------------------------------------------------
31
32 with Ada.Characters.Handling;
33 with Ada.Strings.Fixed;
34
35 with Ada.Unchecked_Deallocation;
36 with Ada.Unchecked_Conversion;
37
38 with System; use System;
39 with System.CRTL; use System.CRTL;
40
41 with GNAT.OS_Lib;
42
43 package body GNAT.Directory_Operations is
44
45 use Ada;
46
47 Filename_Max : constant Integer := 1024;
48 -- 1024 is the value of FILENAME_MAX in stdio.h
49
50 procedure Free is new
51 Ada.Unchecked_Deallocation (Dir_Type_Value, Dir_Type);
52
53 On_Windows : constant Boolean := GNAT.OS_Lib.Directory_Separator = '\';
54 -- An indication that we are on Windows. Used in Get_Current_Dir, to
55 -- deal with drive letters in the beginning of absolute paths.
56
57 ---------------
58 -- Base_Name --
59 ---------------
60
61 function Base_Name
62 (Path : Path_Name;
63 Suffix : String := "") return String
64 is
65 function Get_File_Names_Case_Sensitive return Integer;
66 pragma Import
67 (C, Get_File_Names_Case_Sensitive,
68 "__gnat_get_file_names_case_sensitive");
69
70 Case_Sensitive_File_Name : constant Boolean :=
71 Get_File_Names_Case_Sensitive = 1;
72
73 function Basename
74 (Path : Path_Name;
75 Suffix : String := "") return String;
76 -- This function does the job. The only difference between Basename
77 -- and Base_Name (the parent function) is that the former is case
78 -- sensitive, while the latter is not. Path and Suffix are adjusted
79 -- appropriately before calling Basename under platforms where the
80 -- file system is not case sensitive.
81
82 --------------
83 -- Basename --
84 --------------
85
86 function Basename
87 (Path : Path_Name;
88 Suffix : String := "") return String
89 is
90 Cut_Start : Natural :=
91 Strings.Fixed.Index
92 (Path, Dir_Seps, Going => Strings.Backward);
93 Cut_End : Natural;
94
95 begin
96 -- Cut_Start point to the first basename character
97
98 Cut_Start := (if Cut_Start = 0 then Path'First else Cut_Start + 1);
99
100 -- Cut_End point to the last basename character
101
102 Cut_End := Path'Last;
103
104 -- If basename ends with Suffix, adjust Cut_End
105
106 if Suffix /= ""
107 and then Path (Path'Last - Suffix'Length + 1 .. Cut_End) = Suffix
108 then
109 Cut_End := Path'Last - Suffix'Length;
110 end if;
111
112 Check_For_Standard_Dirs : declare
113 Offset : constant Integer := Path'First - Base_Name.Path'First;
114 BN : constant String :=
115 Base_Name.Path (Cut_Start - Offset .. Cut_End - Offset);
116 -- Here we use Base_Name.Path to keep the original casing
117
118 Has_Drive_Letter : constant Boolean :=
119 OS_Lib.Path_Separator /= ':';
120 -- If Path separator is not ':' then we are on a DOS based OS
121 -- where this character is used as a drive letter separator.
122
123 begin
124 if BN = "." or else BN = ".." then
125 return "";
126
127 elsif Has_Drive_Letter
128 and then BN'Length > 2
129 and then Characters.Handling.Is_Letter (BN (BN'First))
130 and then BN (BN'First + 1) = ':'
131 then
132 -- We have a DOS drive letter prefix, remove it
133
134 return BN (BN'First + 2 .. BN'Last);
135
136 else
137 return BN;
138 end if;
139 end Check_For_Standard_Dirs;
140 end Basename;
141
142 -- Start of processing for Base_Name
143
144 begin
145 if Path'Length <= Suffix'Length then
146 return Path;
147 end if;
148
149 if Case_Sensitive_File_Name then
150 return Basename (Path, Suffix);
151 else
152 return Basename
153 (Characters.Handling.To_Lower (Path),
154 Characters.Handling.To_Lower (Suffix));
155 end if;
156 end Base_Name;
157
158 ----------------
159 -- Change_Dir --
160 ----------------
161
162 procedure Change_Dir (Dir_Name : Dir_Name_Str) is
163 C_Dir_Name : constant String := Dir_Name & ASCII.NUL;
164 begin
165 if chdir (C_Dir_Name) /= 0 then
166 raise Directory_Error;
167 end if;
168 end Change_Dir;
169
170 -----------
171 -- Close --
172 -----------
173
174 procedure Close (Dir : in out Dir_Type) is
175 Discard : Integer;
176 pragma Warnings (Off, Discard);
177
178 function closedir (directory : DIRs) return Integer;
179 pragma Import (C, closedir, "__gnat_closedir");
180
181 begin
182 if not Is_Open (Dir) then
183 raise Directory_Error;
184 end if;
185
186 Discard := closedir (DIRs (Dir.all));
187 Free (Dir);
188 end Close;
189
190 --------------
191 -- Dir_Name --
192 --------------
193
194 function Dir_Name (Path : Path_Name) return Dir_Name_Str is
195 Last_DS : constant Natural :=
196 Strings.Fixed.Index
197 (Path, Dir_Seps, Going => Strings.Backward);
198
199 begin
200 if Last_DS = 0 then
201
202 -- There is no directory separator, returns current working directory
203
204 return "." & Dir_Separator;
205
206 else
207 return Path (Path'First .. Last_DS);
208 end if;
209 end Dir_Name;
210
211 -----------------
212 -- Expand_Path --
213 -----------------
214
215 function Expand_Path
216 (Path : Path_Name;
217 Mode : Environment_Style := System_Default) return Path_Name
218 is
219 Environment_Variable_Char : Character;
220 pragma Import (C, Environment_Variable_Char, "__gnat_environment_char");
221
222 Result : OS_Lib.String_Access := new String (1 .. 200);
223 Result_Last : Natural := 0;
224
225 procedure Append (C : Character);
226 procedure Append (S : String);
227 -- Append to Result
228
229 procedure Double_Result_Size;
230 -- Reallocate Result, doubling its size
231
232 function Is_Var_Prefix (C : Character) return Boolean;
233 pragma Inline (Is_Var_Prefix);
234
235 procedure Read (K : in out Positive);
236 -- Update Result while reading current Path starting at position K. If
237 -- a variable is found, call Var below.
238
239 procedure Var (K : in out Positive);
240 -- Translate variable name starting at position K with the associated
241 -- environment value.
242
243 ------------
244 -- Append --
245 ------------
246
247 procedure Append (C : Character) is
248 begin
249 if Result_Last = Result'Last then
250 Double_Result_Size;
251 end if;
252
253 Result_Last := Result_Last + 1;
254 Result (Result_Last) := C;
255 end Append;
256
257 procedure Append (S : String) is
258 begin
259 while Result_Last + S'Length - 1 > Result'Last loop
260 Double_Result_Size;
261 end loop;
262
263 Result (Result_Last + 1 .. Result_Last + S'Length) := S;
264 Result_Last := Result_Last + S'Length;
265 end Append;
266
267 ------------------------
268 -- Double_Result_Size --
269 ------------------------
270
271 procedure Double_Result_Size is
272 New_Result : constant OS_Lib.String_Access :=
273 new String (1 .. 2 * Result'Last);
274 begin
275 New_Result (1 .. Result_Last) := Result (1 .. Result_Last);
276 OS_Lib.Free (Result);
277 Result := New_Result;
278 end Double_Result_Size;
279
280 -------------------
281 -- Is_Var_Prefix --
282 -------------------
283
284 function Is_Var_Prefix (C : Character) return Boolean is
285 begin
286 return (C = Environment_Variable_Char and then Mode = System_Default)
287 or else
288 (C = '$' and then (Mode = UNIX or else Mode = Both))
289 or else
290 (C = '%' and then (Mode = DOS or else Mode = Both));
291 end Is_Var_Prefix;
292
293 ----------
294 -- Read --
295 ----------
296
297 procedure Read (K : in out Positive) is
298 P : Character;
299
300 begin
301 For_All_Characters : loop
302 if Is_Var_Prefix (Path (K)) then
303 P := Path (K);
304
305 -- Could be a variable
306
307 if K < Path'Last then
308 if Path (K + 1) = P then
309
310 -- Not a variable after all, this is a double $ or %,
311 -- just insert one in the result string.
312
313 Append (P);
314 K := K + 1;
315
316 else
317 -- Let's parse the variable
318
319 Var (K);
320 end if;
321
322 else
323 -- We have an ending $ or % sign
324
325 Append (P);
326 end if;
327
328 else
329 -- This is a standard character, just add it to the result
330
331 Append (Path (K));
332 end if;
333
334 -- Skip to next character
335
336 K := K + 1;
337
338 exit For_All_Characters when K > Path'Last;
339 end loop For_All_Characters;
340 end Read;
341
342 ---------
343 -- Var --
344 ---------
345
346 procedure Var (K : in out Positive) is
347 P : constant Character := Path (K);
348 T : Character;
349 E : Positive;
350
351 begin
352 K := K + 1;
353
354 if P = '%' or else Path (K) = '{' then
355
356 -- Set terminator character
357
358 if P = '%' then
359 T := '%';
360 else
361 T := '}';
362 K := K + 1;
363 end if;
364
365 -- Look for terminator character, k point to the first character
366 -- for the variable name.
367
368 E := K;
369
370 loop
371 E := E + 1;
372 exit when Path (E) = T or else E = Path'Last;
373 end loop;
374
375 if Path (E) = T then
376
377 -- OK found, translate with environment value
378
379 declare
380 Env : OS_Lib.String_Access :=
381 OS_Lib.Getenv (Path (K .. E - 1));
382
383 begin
384 Append (Env.all);
385 OS_Lib.Free (Env);
386 end;
387
388 else
389 -- No terminator character, not a variable after all or a
390 -- syntax error, ignore it, insert string as-is.
391
392 Append (P); -- Add prefix character
393
394 if T = '}' then -- If we were looking for curly bracket
395 Append ('{'); -- terminator, add the curly bracket
396 end if;
397
398 Append (Path (K .. E));
399 end if;
400
401 else
402 -- The variable name is everything from current position to first
403 -- non letter/digit character.
404
405 E := K;
406
407 -- Check that first character is a letter
408
409 if Characters.Handling.Is_Letter (Path (E)) then
410 E := E + 1;
411
412 Var_Name : loop
413 exit Var_Name when E > Path'Last;
414
415 if Characters.Handling.Is_Letter (Path (E))
416 or else Characters.Handling.Is_Digit (Path (E))
417 then
418 E := E + 1;
419 else
420 exit Var_Name;
421 end if;
422 end loop Var_Name;
423
424 E := E - 1;
425
426 declare
427 Env : OS_Lib.String_Access := OS_Lib.Getenv (Path (K .. E));
428
429 begin
430 Append (Env.all);
431 OS_Lib.Free (Env);
432 end;
433
434 else
435 -- This is not a variable after all
436
437 Append ('$');
438 Append (Path (E));
439 end if;
440
441 end if;
442
443 K := E;
444 end Var;
445
446 -- Start of processing for Expand_Path
447
448 begin
449 declare
450 K : Positive := Path'First;
451
452 begin
453 Read (K);
454
455 declare
456 Returned_Value : constant String := Result (1 .. Result_Last);
457
458 begin
459 OS_Lib.Free (Result);
460 return Returned_Value;
461 end;
462 end;
463 end Expand_Path;
464
465 --------------------
466 -- File_Extension --
467 --------------------
468
469 function File_Extension (Path : Path_Name) return String is
470 First : Natural :=
471 Strings.Fixed.Index
472 (Path, Dir_Seps, Going => Strings.Backward);
473
474 Dot : Natural;
475
476 begin
477 if First = 0 then
478 First := Path'First;
479 end if;
480
481 Dot := Strings.Fixed.Index (Path (First .. Path'Last),
482 ".",
483 Going => Strings.Backward);
484
485 if Dot = 0 or else Dot = Path'Last then
486 return "";
487 else
488 return Path (Dot .. Path'Last);
489 end if;
490 end File_Extension;
491
492 ---------------
493 -- File_Name --
494 ---------------
495
496 function File_Name (Path : Path_Name) return String is
497 begin
498 return Base_Name (Path);
499 end File_Name;
500
501 ---------------------
502 -- Format_Pathname --
503 ---------------------
504
505 function Format_Pathname
506 (Path : Path_Name;
507 Style : Path_Style := System_Default) return String
508 is
509 N_Path : String := Path;
510 K : Positive := N_Path'First;
511 Prev_Dirsep : Boolean := False;
512
513 begin
514 if Dir_Separator = '\'
515 and then Path'Length > 1
516 and then Path (K .. K + 1) = "\\"
517 then
518 if Style = UNIX then
519 N_Path (K .. K + 1) := "//";
520 end if;
521
522 K := K + 2;
523 end if;
524
525 for J in K .. Path'Last loop
526 if Strings.Maps.Is_In (Path (J), Dir_Seps) then
527 if not Prev_Dirsep then
528 case Style is
529 when UNIX => N_Path (K) := '/';
530 when DOS => N_Path (K) := '\';
531 when System_Default => N_Path (K) := Dir_Separator;
532 end case;
533
534 K := K + 1;
535 end if;
536
537 Prev_Dirsep := True;
538
539 else
540 N_Path (K) := Path (J);
541 K := K + 1;
542 Prev_Dirsep := False;
543 end if;
544 end loop;
545
546 return N_Path (N_Path'First .. K - 1);
547 end Format_Pathname;
548
549 ---------------------
550 -- Get_Current_Dir --
551 ---------------------
552
553 Max_Path : Integer;
554 pragma Import (C, Max_Path, "__gnat_max_path_len");
555
556 function Get_Current_Dir return Dir_Name_Str is
557 Current_Dir : String (1 .. Max_Path + 1);
558 Last : Natural;
559 begin
560 Get_Current_Dir (Current_Dir, Last);
561 return Current_Dir (1 .. Last);
562 end Get_Current_Dir;
563
564 procedure Get_Current_Dir (Dir : out Dir_Name_Str; Last : out Natural) is
565 Path_Len : Natural := Max_Path;
566 Buffer : String (Dir'First .. Dir'First + Max_Path + 1);
567
568 procedure Local_Get_Current_Dir
569 (Dir : System.Address;
570 Length : System.Address);
571 pragma Import (C, Local_Get_Current_Dir, "__gnat_get_current_dir");
572
573 begin
574 Local_Get_Current_Dir (Buffer'Address, Path_Len'Address);
575
576 Last :=
577 (if Dir'Length > Path_Len then Dir'First + Path_Len - 1 else Dir'Last);
578
579 Dir (Buffer'First .. Last) := Buffer (Buffer'First .. Last);
580
581 -- By default, the drive letter on Windows is in upper case
582
583 if On_Windows and then Last > Dir'First and then
584 Dir (Dir'First + 1) = ':'
585 then
586 Dir (Dir'First) :=
587 Ada.Characters.Handling.To_Upper (Dir (Dir'First));
588 end if;
589 end Get_Current_Dir;
590
591 -------------
592 -- Is_Open --
593 -------------
594
595 function Is_Open (Dir : Dir_Type) return Boolean is
596 begin
597 return Dir /= Null_Dir
598 and then System.Address (Dir.all) /= System.Null_Address;
599 end Is_Open;
600
601 --------------
602 -- Make_Dir --
603 --------------
604
605 procedure Make_Dir (Dir_Name : Dir_Name_Str) is
606 C_Dir_Name : constant String := Dir_Name & ASCII.NUL;
607 begin
608 if CRTL.mkdir (C_Dir_Name, Unspecified) /= 0 then
609 raise Directory_Error;
610 end if;
611 end Make_Dir;
612
613 ----------
614 -- Open --
615 ----------
616
617 procedure Open
618 (Dir : out Dir_Type;
619 Dir_Name : Dir_Name_Str)
620 is
621 function opendir (file_name : String) return DIRs;
622 pragma Import (C, opendir, "__gnat_opendir");
623
624 C_File_Name : constant String := Dir_Name & ASCII.NUL;
625
626 begin
627 Dir := new Dir_Type_Value'(Dir_Type_Value (opendir (C_File_Name)));
628
629 if not Is_Open (Dir) then
630 Free (Dir);
631 Dir := Null_Dir;
632 raise Directory_Error;
633 end if;
634 end Open;
635
636 ----------
637 -- Read --
638 ----------
639
640 procedure Read
641 (Dir : Dir_Type;
642 Str : out String;
643 Last : out Natural)
644 is
645 Filename_Addr : Address;
646 Filename_Len : aliased Integer;
647
648 Buffer : array (0 .. Filename_Max + 12) of Character;
649 -- 12 is the size of the dirent structure (see dirent.h), without the
650 -- field for the filename.
651
652 function readdir_gnat
653 (Directory : System.Address;
654 Buffer : System.Address;
655 Last : not null access Integer) return System.Address;
656 pragma Import (C, readdir_gnat, "__gnat_readdir");
657
658 begin
659 if not Is_Open (Dir) then
660 raise Directory_Error;
661 end if;
662
663 Filename_Addr :=
664 readdir_gnat
665 (System.Address (Dir.all), Buffer'Address, Filename_Len'Access);
666
667 if Filename_Addr = System.Null_Address then
668 Last := 0;
669 return;
670 end if;
671
672 Last :=
673 (if Str'Length > Filename_Len then Str'First + Filename_Len - 1
674 else Str'Last);
675
676 declare
677 subtype Path_String is String (1 .. Filename_Len);
678 type Path_String_Access is access Path_String;
679
680 function Address_To_Access is new
681 Ada.Unchecked_Conversion
682 (Source => Address,
683 Target => Path_String_Access);
684
685 Path_Access : constant Path_String_Access :=
686 Address_To_Access (Filename_Addr);
687
688 begin
689 for J in Str'First .. Last loop
690 Str (J) := Path_Access (J - Str'First + 1);
691 end loop;
692 end;
693 end Read;
694
695 -------------------------
696 -- Read_Is_Thread_Safe --
697 -------------------------
698
699 function Read_Is_Thread_Safe return Boolean is
700 function readdir_is_thread_safe return Integer;
701 pragma Import
702 (C, readdir_is_thread_safe, "__gnat_readdir_is_thread_safe");
703 begin
704 return (readdir_is_thread_safe /= 0);
705 end Read_Is_Thread_Safe;
706
707 ----------------
708 -- Remove_Dir --
709 ----------------
710
711 procedure Remove_Dir
712 (Dir_Name : Dir_Name_Str;
713 Recursive : Boolean := False)
714 is
715 C_Dir_Name : constant String := Dir_Name & ASCII.NUL;
716 Last : Integer;
717 Str : String (1 .. Filename_Max);
718 Success : Boolean;
719 Current_Dir : Dir_Type;
720
721 begin
722 -- Remove the directory only if it is empty
723
724 if not Recursive then
725 if rmdir (C_Dir_Name) /= 0 then
726 raise Directory_Error;
727 end if;
728
729 -- Remove directory and all files and directories that it may contain
730
731 else
732 Open (Current_Dir, Dir_Name);
733
734 loop
735 Read (Current_Dir, Str, Last);
736 exit when Last = 0;
737
738 if GNAT.OS_Lib.Is_Directory
739 (Dir_Name & Dir_Separator & Str (1 .. Last))
740 then
741 if Str (1 .. Last) /= "."
742 and then
743 Str (1 .. Last) /= ".."
744 then
745 -- Recursive call to remove a subdirectory and all its
746 -- files.
747
748 Remove_Dir
749 (Dir_Name & Dir_Separator & Str (1 .. Last),
750 True);
751 end if;
752
753 else
754 GNAT.OS_Lib.Delete_File
755 (Dir_Name & Dir_Separator & Str (1 .. Last),
756 Success);
757
758 if not Success then
759 raise Directory_Error;
760 end if;
761 end if;
762 end loop;
763
764 Close (Current_Dir);
765 Remove_Dir (Dir_Name);
766 end if;
767 end Remove_Dir;
768
769 end GNAT.Directory_Operations;