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