Mercurial > hg > CbC > CbC_gcc
comparison gcc/ada/libgnat/a-direct.adb @ 111:04ced10e8804
gcc 7
author | kono |
---|---|
date | Fri, 27 Oct 2017 22:46:09 +0900 |
parents | |
children | 84e7813d76e9 |
comparison
equal
deleted
inserted
replaced
68:561a7518be6b | 111:04ced10e8804 |
---|---|
1 ------------------------------------------------------------------------------ | |
2 -- -- | |
3 -- GNAT RUN-TIME COMPONENTS -- | |
4 -- -- | |
5 -- A D A . D I R E C T O R I E S -- | |
6 -- -- | |
7 -- B o d y -- | |
8 -- -- | |
9 -- Copyright (C) 2004-2017, Free Software Foundation, Inc. -- | |
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 -- 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/>. -- | |
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.Calendar; use Ada.Calendar; | |
33 with Ada.Calendar.Formatting; use Ada.Calendar.Formatting; | |
34 with Ada.Characters.Handling; use Ada.Characters.Handling; | |
35 with Ada.Directories.Validity; use Ada.Directories.Validity; | |
36 with Ada.Strings.Fixed; | |
37 with Ada.Strings.Maps; use Ada.Strings.Maps; | |
38 with Ada.Strings.Unbounded; use Ada.Strings.Unbounded; | |
39 with Ada.Unchecked_Deallocation; | |
40 | |
41 with System; use System; | |
42 with System.CRTL; use System.CRTL; | |
43 with System.File_Attributes; use System.File_Attributes; | |
44 with System.File_IO; use System.File_IO; | |
45 with System.OS_Constants; use System.OS_Constants; | |
46 with System.OS_Lib; use System.OS_Lib; | |
47 with System.Regexp; use System.Regexp; | |
48 | |
49 package body Ada.Directories is | |
50 | |
51 type Dir_Type_Value is new Address; | |
52 -- This is the low-level address directory structure as returned by the C | |
53 -- opendir routine. | |
54 | |
55 No_Dir : constant Dir_Type_Value := Dir_Type_Value (Null_Address); | |
56 -- Null directory value | |
57 | |
58 Dir_Separator : constant Character; | |
59 pragma Import (C, Dir_Separator, "__gnat_dir_separator"); | |
60 -- Running system default directory separator | |
61 | |
62 Dir_Seps : constant Character_Set := Strings.Maps.To_Set ("/\"); | |
63 -- UNIX and DOS style directory separators | |
64 | |
65 Max_Path : Integer; | |
66 pragma Import (C, Max_Path, "__gnat_max_path_len"); | |
67 -- The maximum length of a path | |
68 | |
69 type Search_Data is record | |
70 Is_Valid : Boolean := False; | |
71 Name : Unbounded_String; | |
72 Pattern : Regexp; | |
73 Filter : Filter_Type; | |
74 Dir : Dir_Type_Value := No_Dir; | |
75 Entry_Fetched : Boolean := False; | |
76 Dir_Entry : Directory_Entry_Type; | |
77 end record; | |
78 -- The current state of a search | |
79 | |
80 Empty_String : constant String := (1 .. 0 => ASCII.NUL); | |
81 -- Empty string, returned by function Extension when there is no extension | |
82 | |
83 procedure Free is new Ada.Unchecked_Deallocation (Search_Data, Search_Ptr); | |
84 | |
85 procedure Close (Dir : Dir_Type_Value); | |
86 | |
87 function File_Exists (Name : String) return Boolean; | |
88 -- Returns True if the named file exists | |
89 | |
90 procedure Fetch_Next_Entry (Search : Search_Type); | |
91 -- Get the next entry in a directory, setting Entry_Fetched if successful | |
92 -- or resetting Is_Valid if not. | |
93 | |
94 --------------- | |
95 -- Base_Name -- | |
96 --------------- | |
97 | |
98 function Base_Name (Name : String) return String is | |
99 Simple : constant String := Simple_Name (Name); | |
100 -- Simple'First is guaranteed to be 1 | |
101 | |
102 begin | |
103 -- Look for the last dot in the file name and return the part of the | |
104 -- file name preceding this last dot. If the first dot is the first | |
105 -- character of the file name, the base name is the empty string. | |
106 | |
107 for Pos in reverse Simple'Range loop | |
108 if Simple (Pos) = '.' then | |
109 return Simple (1 .. Pos - 1); | |
110 end if; | |
111 end loop; | |
112 | |
113 -- If there is no dot, return the complete file name | |
114 | |
115 return Simple; | |
116 end Base_Name; | |
117 | |
118 ----------- | |
119 -- Close -- | |
120 ----------- | |
121 | |
122 procedure Close (Dir : Dir_Type_Value) is | |
123 Discard : Integer; | |
124 pragma Warnings (Off, Discard); | |
125 | |
126 function closedir (directory : DIRs) return Integer; | |
127 pragma Import (C, closedir, "__gnat_closedir"); | |
128 | |
129 begin | |
130 Discard := closedir (DIRs (Dir)); | |
131 end Close; | |
132 | |
133 ------------- | |
134 -- Compose -- | |
135 ------------- | |
136 | |
137 function Compose | |
138 (Containing_Directory : String := ""; | |
139 Name : String; | |
140 Extension : String := "") return String | |
141 is | |
142 Result : String (1 .. Containing_Directory'Length + | |
143 Name'Length + Extension'Length + 2); | |
144 Last : Natural; | |
145 | |
146 begin | |
147 -- First, deal with the invalid cases | |
148 | |
149 if Containing_Directory /= "" | |
150 and then not Is_Valid_Path_Name (Containing_Directory) | |
151 then | |
152 raise Name_Error with | |
153 "invalid directory path name """ & Containing_Directory & '"'; | |
154 | |
155 elsif | |
156 Extension'Length = 0 and then (not Is_Valid_Simple_Name (Name)) | |
157 then | |
158 raise Name_Error with | |
159 "invalid simple name """ & Name & '"'; | |
160 | |
161 elsif Extension'Length /= 0 | |
162 and then not Is_Valid_Simple_Name (Name & '.' & Extension) | |
163 then | |
164 raise Name_Error with | |
165 "invalid file name """ & Name & '.' & Extension & '"'; | |
166 | |
167 -- This is not an invalid case so build the path name | |
168 | |
169 else | |
170 Last := Containing_Directory'Length; | |
171 Result (1 .. Last) := Containing_Directory; | |
172 | |
173 -- Add a directory separator if needed | |
174 | |
175 if Last /= 0 and then not Is_In (Result (Last), Dir_Seps) then | |
176 Last := Last + 1; | |
177 Result (Last) := Dir_Separator; | |
178 end if; | |
179 | |
180 -- Add the file name | |
181 | |
182 Result (Last + 1 .. Last + Name'Length) := Name; | |
183 Last := Last + Name'Length; | |
184 | |
185 -- If extension was specified, add dot followed by this extension | |
186 | |
187 if Extension'Length /= 0 then | |
188 Last := Last + 1; | |
189 Result (Last) := '.'; | |
190 Result (Last + 1 .. Last + Extension'Length) := Extension; | |
191 Last := Last + Extension'Length; | |
192 end if; | |
193 | |
194 return Result (1 .. Last); | |
195 end if; | |
196 end Compose; | |
197 | |
198 -------------------------- | |
199 -- Containing_Directory -- | |
200 -------------------------- | |
201 | |
202 function Containing_Directory (Name : String) return String is | |
203 begin | |
204 -- First, the invalid case | |
205 | |
206 if not Is_Valid_Path_Name (Name) then | |
207 raise Name_Error with "invalid path name """ & Name & '"'; | |
208 | |
209 else | |
210 declare | |
211 Last_DS : constant Natural := | |
212 Strings.Fixed.Index (Name, Dir_Seps, Going => Strings.Backward); | |
213 | |
214 begin | |
215 if Last_DS = 0 then | |
216 | |
217 -- There is no directory separator, returns "." representing | |
218 -- the current working directory. | |
219 | |
220 return "."; | |
221 | |
222 -- If Name indicates a root directory, raise Use_Error, because | |
223 -- it has no containing directory. | |
224 | |
225 elsif Name = "/" | |
226 or else | |
227 (Windows | |
228 and then | |
229 (Name = "\" | |
230 or else | |
231 (Name'Length = 3 | |
232 and then Name (Name'Last - 1 .. Name'Last) = ":\" | |
233 and then (Name (Name'First) in 'a' .. 'z' | |
234 or else | |
235 Name (Name'First) in 'A' .. 'Z')))) | |
236 then | |
237 raise Use_Error with | |
238 "directory """ & Name & """ has no containing directory"; | |
239 | |
240 else | |
241 declare | |
242 Last : Positive := Last_DS - Name'First + 1; | |
243 Result : String (1 .. Last); | |
244 | |
245 begin | |
246 Result := Name (Name'First .. Last_DS); | |
247 | |
248 -- Remove any trailing directory separator, except as the | |
249 -- first character or the first character following a drive | |
250 -- number on Windows. | |
251 | |
252 while Last > 1 loop | |
253 exit when | |
254 Result (Last) /= '/' | |
255 and then | |
256 Result (Last) /= Directory_Separator; | |
257 | |
258 exit when Windows | |
259 and then Last = 3 | |
260 and then Result (2) = ':' | |
261 and then | |
262 (Result (1) in 'A' .. 'Z' | |
263 or else | |
264 Result (1) in 'a' .. 'z'); | |
265 | |
266 Last := Last - 1; | |
267 end loop; | |
268 | |
269 -- Special case of "..": the current directory may be a root | |
270 -- directory. | |
271 | |
272 if Last = 2 and then Result (1 .. 2) = ".." then | |
273 return Containing_Directory (Current_Directory); | |
274 | |
275 else | |
276 return Result (1 .. Last); | |
277 end if; | |
278 end; | |
279 end if; | |
280 end; | |
281 end if; | |
282 end Containing_Directory; | |
283 | |
284 --------------- | |
285 -- Copy_File -- | |
286 --------------- | |
287 | |
288 procedure Copy_File | |
289 (Source_Name : String; | |
290 Target_Name : String; | |
291 Form : String := "") | |
292 is | |
293 Success : Boolean; | |
294 Mode : Copy_Mode := Overwrite; | |
295 Preserve : Attribute := None; | |
296 | |
297 begin | |
298 -- First, the invalid cases | |
299 | |
300 if not Is_Valid_Path_Name (Source_Name) then | |
301 raise Name_Error with | |
302 "invalid source path name """ & Source_Name & '"'; | |
303 | |
304 elsif not Is_Valid_Path_Name (Target_Name) then | |
305 raise Name_Error with | |
306 "invalid target path name """ & Target_Name & '"'; | |
307 | |
308 elsif not Is_Regular_File (Source_Name) then | |
309 raise Name_Error with '"' & Source_Name & """ is not a file"; | |
310 | |
311 elsif Is_Directory (Target_Name) then | |
312 raise Use_Error with "target """ & Target_Name & """ is a directory"; | |
313 | |
314 else | |
315 if Form'Length > 0 then | |
316 declare | |
317 Formstr : String (1 .. Form'Length + 1); | |
318 V1, V2 : Natural; | |
319 | |
320 begin | |
321 -- Acquire form string, setting required NUL terminator | |
322 | |
323 Formstr (1 .. Form'Length) := Form; | |
324 Formstr (Formstr'Last) := ASCII.NUL; | |
325 | |
326 -- Convert form string to lower case | |
327 | |
328 for J in Formstr'Range loop | |
329 if Formstr (J) in 'A' .. 'Z' then | |
330 Formstr (J) := | |
331 Character'Val (Character'Pos (Formstr (J)) + 32); | |
332 end if; | |
333 end loop; | |
334 | |
335 -- Check Form | |
336 | |
337 Form_Parameter (Formstr, "mode", V1, V2); | |
338 | |
339 if V1 = 0 then | |
340 Mode := Overwrite; | |
341 elsif Formstr (V1 .. V2) = "copy" then | |
342 Mode := Copy; | |
343 elsif Formstr (V1 .. V2) = "overwrite" then | |
344 Mode := Overwrite; | |
345 elsif Formstr (V1 .. V2) = "append" then | |
346 Mode := Append; | |
347 else | |
348 raise Use_Error with "invalid Form"; | |
349 end if; | |
350 | |
351 Form_Parameter (Formstr, "preserve", V1, V2); | |
352 | |
353 if V1 = 0 then | |
354 Preserve := None; | |
355 elsif Formstr (V1 .. V2) = "timestamps" then | |
356 Preserve := Time_Stamps; | |
357 elsif Formstr (V1 .. V2) = "all_attributes" then | |
358 Preserve := Full; | |
359 elsif Formstr (V1 .. V2) = "no_attributes" then | |
360 Preserve := None; | |
361 else | |
362 raise Use_Error with "invalid Form"; | |
363 end if; | |
364 end; | |
365 end if; | |
366 | |
367 -- Do actual copy using System.OS_Lib.Copy_File | |
368 | |
369 Copy_File (Source_Name, Target_Name, Success, Mode, Preserve); | |
370 | |
371 if not Success then | |
372 raise Use_Error with "copy of """ & Source_Name & """ failed"; | |
373 end if; | |
374 end if; | |
375 end Copy_File; | |
376 | |
377 ---------------------- | |
378 -- Create_Directory -- | |
379 ---------------------- | |
380 | |
381 procedure Create_Directory | |
382 (New_Directory : String; | |
383 Form : String := "") | |
384 is | |
385 C_Dir_Name : constant String := New_Directory & ASCII.NUL; | |
386 | |
387 begin | |
388 -- First, the invalid case | |
389 | |
390 if not Is_Valid_Path_Name (New_Directory) then | |
391 raise Name_Error with | |
392 "invalid new directory path name """ & New_Directory & '"'; | |
393 | |
394 else | |
395 -- Acquire setting of encoding parameter | |
396 | |
397 declare | |
398 Formstr : constant String := To_Lower (Form); | |
399 | |
400 Encoding : CRTL.Filename_Encoding; | |
401 -- Filename encoding specified into the form parameter | |
402 | |
403 V1, V2 : Natural; | |
404 | |
405 begin | |
406 Form_Parameter (Formstr, "encoding", V1, V2); | |
407 | |
408 if V1 = 0 then | |
409 Encoding := CRTL.Unspecified; | |
410 elsif Formstr (V1 .. V2) = "utf8" then | |
411 Encoding := CRTL.UTF8; | |
412 elsif Formstr (V1 .. V2) = "8bits" then | |
413 Encoding := CRTL.ASCII_8bits; | |
414 else | |
415 raise Use_Error with "invalid Form"; | |
416 end if; | |
417 | |
418 if CRTL.mkdir (C_Dir_Name, Encoding) /= 0 then | |
419 raise Use_Error with | |
420 "creation of new directory """ & New_Directory & """ failed"; | |
421 end if; | |
422 end; | |
423 end if; | |
424 end Create_Directory; | |
425 | |
426 ----------------- | |
427 -- Create_Path -- | |
428 ----------------- | |
429 | |
430 procedure Create_Path | |
431 (New_Directory : String; | |
432 Form : String := "") | |
433 is | |
434 New_Dir : String (1 .. New_Directory'Length + 1); | |
435 Last : Positive := 1; | |
436 Start : Positive := 1; | |
437 | |
438 begin | |
439 -- First, the invalid case | |
440 | |
441 if not Is_Valid_Path_Name (New_Directory) then | |
442 raise Name_Error with | |
443 "invalid new directory path name """ & New_Directory & '"'; | |
444 | |
445 else | |
446 -- Build New_Dir with a directory separator at the end, so that the | |
447 -- complete path will be found in the loop below. | |
448 | |
449 New_Dir (1 .. New_Directory'Length) := New_Directory; | |
450 New_Dir (New_Dir'Last) := Directory_Separator; | |
451 | |
452 -- If host is windows, and the first two characters are directory | |
453 -- separators, we have an UNC path. Skip it. | |
454 | |
455 if Directory_Separator = '\' | |
456 and then New_Dir'Length > 2 | |
457 and then Is_In (New_Dir (1), Dir_Seps) | |
458 and then Is_In (New_Dir (2), Dir_Seps) | |
459 then | |
460 Start := 2; | |
461 loop | |
462 Start := Start + 1; | |
463 exit when Start = New_Dir'Last | |
464 or else Is_In (New_Dir (Start), Dir_Seps); | |
465 end loop; | |
466 end if; | |
467 | |
468 -- Create, if necessary, each directory in the path | |
469 | |
470 for J in Start + 1 .. New_Dir'Last loop | |
471 | |
472 -- Look for the end of an intermediate directory | |
473 | |
474 if not Is_In (New_Dir (J), Dir_Seps) then | |
475 Last := J; | |
476 | |
477 -- We have found a new intermediate directory each time we find | |
478 -- a first directory separator. | |
479 | |
480 elsif not Is_In (New_Dir (J - 1), Dir_Seps) then | |
481 | |
482 -- No need to create the directory if it already exists | |
483 | |
484 if not Is_Directory (New_Dir (1 .. Last)) then | |
485 begin | |
486 Create_Directory | |
487 (New_Directory => New_Dir (1 .. Last), Form => Form); | |
488 | |
489 exception | |
490 when Use_Error => | |
491 if File_Exists (New_Dir (1 .. Last)) then | |
492 | |
493 -- A file with such a name already exists. If it is | |
494 -- a directory, then it was apparently just created | |
495 -- by another process or thread, and all is well. | |
496 -- If it is of some other kind, report an error. | |
497 | |
498 if not Is_Directory (New_Dir (1 .. Last)) then | |
499 raise Use_Error with | |
500 "file """ & New_Dir (1 .. Last) & | |
501 """ already exists and is not a directory"; | |
502 end if; | |
503 | |
504 else | |
505 -- Create_Directory failed for some other reason: | |
506 -- propagate the exception. | |
507 | |
508 raise; | |
509 end if; | |
510 end; | |
511 end if; | |
512 end if; | |
513 end loop; | |
514 end if; | |
515 end Create_Path; | |
516 | |
517 ----------------------- | |
518 -- Current_Directory -- | |
519 ----------------------- | |
520 | |
521 function Current_Directory return String is | |
522 Path_Len : Natural := Max_Path; | |
523 Buffer : String (1 .. 1 + Max_Path + 1); | |
524 | |
525 procedure Local_Get_Current_Dir (Dir : Address; Length : Address); | |
526 pragma Import (C, Local_Get_Current_Dir, "__gnat_get_current_dir"); | |
527 | |
528 begin | |
529 Local_Get_Current_Dir (Buffer'Address, Path_Len'Address); | |
530 | |
531 if Path_Len = 0 then | |
532 raise Use_Error with "current directory does not exist"; | |
533 end if; | |
534 | |
535 -- We need to resolve links because of RM A.16(47), which requires | |
536 -- that we not return alternative names for files. | |
537 | |
538 return Normalize_Pathname (Buffer (1 .. Path_Len)); | |
539 end Current_Directory; | |
540 | |
541 ---------------------- | |
542 -- Delete_Directory -- | |
543 ---------------------- | |
544 | |
545 procedure Delete_Directory (Directory : String) is | |
546 begin | |
547 -- First, the invalid cases | |
548 | |
549 if not Is_Valid_Path_Name (Directory) then | |
550 raise Name_Error with | |
551 "invalid directory path name """ & Directory & '"'; | |
552 | |
553 elsif not Is_Directory (Directory) then | |
554 raise Name_Error with '"' & Directory & """ not a directory"; | |
555 | |
556 -- Do the deletion, checking for error | |
557 | |
558 else | |
559 declare | |
560 C_Dir_Name : constant String := Directory & ASCII.NUL; | |
561 begin | |
562 if rmdir (C_Dir_Name) /= 0 then | |
563 raise Use_Error with | |
564 "deletion of directory """ & Directory & """ failed"; | |
565 end if; | |
566 end; | |
567 end if; | |
568 end Delete_Directory; | |
569 | |
570 ----------------- | |
571 -- Delete_File -- | |
572 ----------------- | |
573 | |
574 procedure Delete_File (Name : String) is | |
575 Success : Boolean; | |
576 | |
577 begin | |
578 -- First, the invalid cases | |
579 | |
580 if not Is_Valid_Path_Name (Name) then | |
581 raise Name_Error with "invalid path name """ & Name & '"'; | |
582 | |
583 elsif not Is_Regular_File (Name) | |
584 and then not Is_Symbolic_Link (Name) | |
585 then | |
586 raise Name_Error with "file """ & Name & """ does not exist"; | |
587 | |
588 else | |
589 -- Do actual deletion using System.OS_Lib.Delete_File | |
590 | |
591 Delete_File (Name, Success); | |
592 | |
593 if not Success then | |
594 raise Use_Error with "file """ & Name & """ could not be deleted"; | |
595 end if; | |
596 end if; | |
597 end Delete_File; | |
598 | |
599 ----------------- | |
600 -- Delete_Tree -- | |
601 ----------------- | |
602 | |
603 procedure Delete_Tree (Directory : String) is | |
604 Search : Search_Type; | |
605 Dir_Ent : Directory_Entry_Type; | |
606 begin | |
607 -- First, the invalid cases | |
608 | |
609 if not Is_Valid_Path_Name (Directory) then | |
610 raise Name_Error with | |
611 "invalid directory path name """ & Directory & '"'; | |
612 | |
613 elsif not Is_Directory (Directory) then | |
614 raise Name_Error with '"' & Directory & """ not a directory"; | |
615 | |
616 else | |
617 | |
618 -- We used to change the current directory to Directory here, | |
619 -- allowing the use of a local Simple_Name for all references. This | |
620 -- turned out unfriendly to multitasking programs, where tasks | |
621 -- running in parallel of this Delete_Tree could see their current | |
622 -- directory change unpredictably. We now resort to Full_Name | |
623 -- computations to reach files and subdirs instead. | |
624 | |
625 Start_Search (Search, Directory => Directory, Pattern => ""); | |
626 while More_Entries (Search) loop | |
627 Get_Next_Entry (Search, Dir_Ent); | |
628 | |
629 declare | |
630 Fname : constant String := Full_Name (Dir_Ent); | |
631 Sname : constant String := Simple_Name (Dir_Ent); | |
632 | |
633 begin | |
634 if OS_Lib.Is_Directory (Fname) then | |
635 if Sname /= "." and then Sname /= ".." then | |
636 Delete_Tree (Fname); | |
637 end if; | |
638 else | |
639 Delete_File (Fname); | |
640 end if; | |
641 end; | |
642 end loop; | |
643 | |
644 End_Search (Search); | |
645 | |
646 declare | |
647 C_Dir_Name : constant String := Directory & ASCII.NUL; | |
648 | |
649 begin | |
650 if rmdir (C_Dir_Name) /= 0 then | |
651 raise Use_Error with | |
652 "directory tree rooted at """ & | |
653 Directory & """ could not be deleted"; | |
654 end if; | |
655 end; | |
656 end if; | |
657 end Delete_Tree; | |
658 | |
659 ------------ | |
660 -- Exists -- | |
661 ------------ | |
662 | |
663 function Exists (Name : String) return Boolean is | |
664 begin | |
665 -- First, the invalid case | |
666 | |
667 if not Is_Valid_Path_Name (Name) then | |
668 raise Name_Error with "invalid path name """ & Name & '"'; | |
669 | |
670 else | |
671 -- The implementation is in File_Exists | |
672 | |
673 return File_Exists (Name); | |
674 end if; | |
675 end Exists; | |
676 | |
677 --------------- | |
678 -- Extension -- | |
679 --------------- | |
680 | |
681 function Extension (Name : String) return String is | |
682 begin | |
683 -- First, the invalid case | |
684 | |
685 if not Is_Valid_Path_Name (Name) then | |
686 raise Name_Error with "invalid path name """ & Name & '"'; | |
687 | |
688 else | |
689 -- Look for first dot that is not followed by a directory separator | |
690 | |
691 for Pos in reverse Name'Range loop | |
692 | |
693 -- If a directory separator is found before a dot, there is no | |
694 -- extension. | |
695 | |
696 if Is_In (Name (Pos), Dir_Seps) then | |
697 return Empty_String; | |
698 | |
699 elsif Name (Pos) = '.' then | |
700 | |
701 -- We found a dot, build the return value with lower bound 1 | |
702 | |
703 declare | |
704 subtype Result_Type is String (1 .. Name'Last - Pos); | |
705 begin | |
706 return Result_Type (Name (Pos + 1 .. Name'Last)); | |
707 end; | |
708 end if; | |
709 end loop; | |
710 | |
711 -- No dot were found, there is no extension | |
712 | |
713 return Empty_String; | |
714 end if; | |
715 end Extension; | |
716 | |
717 ---------------------- | |
718 -- Fetch_Next_Entry -- | |
719 ---------------------- | |
720 | |
721 procedure Fetch_Next_Entry (Search : Search_Type) is | |
722 Name : String (1 .. NAME_MAX); | |
723 Last : Natural; | |
724 | |
725 Kind : File_Kind := Ordinary_File; | |
726 -- Initialized to avoid a compilation warning | |
727 | |
728 Filename_Addr : Address; | |
729 Filename_Len : aliased Integer; | |
730 | |
731 Buffer : array (1 .. SIZEOF_struct_dirent_alloc) of Character; | |
732 | |
733 function readdir_gnat | |
734 (Directory : Address; | |
735 Buffer : Address; | |
736 Last : not null access Integer) return Address; | |
737 pragma Import (C, readdir_gnat, "__gnat_readdir"); | |
738 | |
739 begin | |
740 -- Search.Value.Is_Valid is always True when Fetch_Next_Entry is called | |
741 | |
742 loop | |
743 Filename_Addr := | |
744 readdir_gnat | |
745 (Address (Search.Value.Dir), | |
746 Buffer'Address, | |
747 Filename_Len'Access); | |
748 | |
749 -- If no matching entry is found, set Is_Valid to False | |
750 | |
751 if Filename_Addr = Null_Address then | |
752 Search.Value.Is_Valid := False; | |
753 exit; | |
754 end if; | |
755 | |
756 if Filename_Len > Name'Length then | |
757 raise Use_Error with "file name too long"; | |
758 end if; | |
759 | |
760 declare | |
761 subtype Name_String is String (1 .. Filename_Len); | |
762 Dent_Name : Name_String; | |
763 for Dent_Name'Address use Filename_Addr; | |
764 pragma Import (Ada, Dent_Name); | |
765 | |
766 begin | |
767 Last := Filename_Len; | |
768 Name (1 .. Last) := Dent_Name; | |
769 end; | |
770 | |
771 -- Check if the entry matches the pattern | |
772 | |
773 if Match (Name (1 .. Last), Search.Value.Pattern) then | |
774 declare | |
775 C_Full_Name : constant String := | |
776 Compose (To_String (Search.Value.Name), | |
777 Name (1 .. Last)) & ASCII.NUL; | |
778 Full_Name : String renames | |
779 C_Full_Name | |
780 (C_Full_Name'First .. C_Full_Name'Last - 1); | |
781 Found : Boolean := False; | |
782 Attr : aliased File_Attributes; | |
783 Exists : Integer; | |
784 Error : Integer; | |
785 | |
786 begin | |
787 Reset_Attributes (Attr'Access); | |
788 Exists := File_Exists_Attr (C_Full_Name'Address, Attr'Access); | |
789 Error := Error_Attributes (Attr'Access); | |
790 | |
791 if Error /= 0 then | |
792 raise Use_Error | |
793 with Full_Name & ": " & Errno_Message (Err => Error); | |
794 end if; | |
795 | |
796 if Exists = 1 then | |
797 | |
798 -- Now check if the file kind matches the filter | |
799 | |
800 if Is_Regular_File_Attr | |
801 (C_Full_Name'Address, Attr'Access) = 1 | |
802 then | |
803 if Search.Value.Filter (Ordinary_File) then | |
804 Kind := Ordinary_File; | |
805 Found := True; | |
806 end if; | |
807 | |
808 elsif Is_Directory_Attr | |
809 (C_Full_Name'Address, Attr'Access) = 1 | |
810 then | |
811 if Search.Value.Filter (Directory) then | |
812 Kind := Directory; | |
813 Found := True; | |
814 end if; | |
815 | |
816 elsif Search.Value.Filter (Special_File) then | |
817 Kind := Special_File; | |
818 Found := True; | |
819 end if; | |
820 | |
821 -- If it does, update Search and return | |
822 | |
823 if Found then | |
824 Search.Value.Entry_Fetched := True; | |
825 Search.Value.Dir_Entry := | |
826 (Is_Valid => True, | |
827 Simple => To_Unbounded_String (Name (1 .. Last)), | |
828 Full => To_Unbounded_String (Full_Name), | |
829 Kind => Kind); | |
830 exit; | |
831 end if; | |
832 end if; | |
833 end; | |
834 end if; | |
835 end loop; | |
836 end Fetch_Next_Entry; | |
837 | |
838 ----------------- | |
839 -- File_Exists -- | |
840 ----------------- | |
841 | |
842 function File_Exists (Name : String) return Boolean is | |
843 function C_File_Exists (A : Address) return Integer; | |
844 pragma Import (C, C_File_Exists, "__gnat_file_exists"); | |
845 | |
846 C_Name : String (1 .. Name'Length + 1); | |
847 | |
848 begin | |
849 C_Name (1 .. Name'Length) := Name; | |
850 C_Name (C_Name'Last) := ASCII.NUL; | |
851 return C_File_Exists (C_Name'Address) = 1; | |
852 end File_Exists; | |
853 | |
854 -------------- | |
855 -- Finalize -- | |
856 -------------- | |
857 | |
858 procedure Finalize (Search : in out Search_Type) is | |
859 begin | |
860 if Search.Value /= null then | |
861 | |
862 -- Close the directory, if one is open | |
863 | |
864 if Search.Value.Dir /= No_Dir then | |
865 Close (Search.Value.Dir); | |
866 end if; | |
867 | |
868 Free (Search.Value); | |
869 end if; | |
870 end Finalize; | |
871 | |
872 --------------- | |
873 -- Full_Name -- | |
874 --------------- | |
875 | |
876 function Full_Name (Name : String) return String is | |
877 begin | |
878 -- First, the invalid case | |
879 | |
880 if not Is_Valid_Path_Name (Name) then | |
881 raise Name_Error with "invalid path name """ & Name & '"'; | |
882 | |
883 else | |
884 -- Build the return value with lower bound 1 | |
885 | |
886 -- Use System.OS_Lib.Normalize_Pathname | |
887 | |
888 declare | |
889 -- We need to resolve links because of (RM A.16(47)), which says | |
890 -- we must not return alternative names for files. | |
891 | |
892 Value : constant String := Normalize_Pathname (Name); | |
893 subtype Result is String (1 .. Value'Length); | |
894 | |
895 begin | |
896 return Result (Value); | |
897 end; | |
898 end if; | |
899 end Full_Name; | |
900 | |
901 function Full_Name (Directory_Entry : Directory_Entry_Type) return String is | |
902 begin | |
903 -- First, the invalid case | |
904 | |
905 if not Directory_Entry.Is_Valid then | |
906 raise Status_Error with "invalid directory entry"; | |
907 | |
908 else | |
909 -- The value to return has already been computed | |
910 | |
911 return To_String (Directory_Entry.Full); | |
912 end if; | |
913 end Full_Name; | |
914 | |
915 -------------------- | |
916 -- Get_Next_Entry -- | |
917 -------------------- | |
918 | |
919 procedure Get_Next_Entry | |
920 (Search : in out Search_Type; | |
921 Directory_Entry : out Directory_Entry_Type) | |
922 is | |
923 begin | |
924 -- First, the invalid case | |
925 | |
926 if Search.Value = null or else not Search.Value.Is_Valid then | |
927 raise Status_Error with "invalid search"; | |
928 end if; | |
929 | |
930 -- Fetch the next entry, if needed | |
931 | |
932 if not Search.Value.Entry_Fetched then | |
933 Fetch_Next_Entry (Search); | |
934 end if; | |
935 | |
936 -- It is an error if no valid entry is found | |
937 | |
938 if not Search.Value.Is_Valid then | |
939 raise Status_Error with "no next entry"; | |
940 | |
941 else | |
942 -- Reset Entry_Fetched and return the entry | |
943 | |
944 Search.Value.Entry_Fetched := False; | |
945 Directory_Entry := Search.Value.Dir_Entry; | |
946 end if; | |
947 end Get_Next_Entry; | |
948 | |
949 ---------- | |
950 -- Kind -- | |
951 ---------- | |
952 | |
953 function Kind (Name : String) return File_Kind is | |
954 begin | |
955 -- First, the invalid case | |
956 | |
957 if not File_Exists (Name) then | |
958 raise Name_Error with "file """ & Name & """ does not exist"; | |
959 | |
960 -- If OK, return appropriate kind | |
961 | |
962 elsif Is_Regular_File (Name) then | |
963 return Ordinary_File; | |
964 | |
965 elsif Is_Directory (Name) then | |
966 return Directory; | |
967 | |
968 else | |
969 return Special_File; | |
970 end if; | |
971 end Kind; | |
972 | |
973 function Kind (Directory_Entry : Directory_Entry_Type) return File_Kind is | |
974 begin | |
975 -- First, the invalid case | |
976 | |
977 if not Directory_Entry.Is_Valid then | |
978 raise Status_Error with "invalid directory entry"; | |
979 | |
980 else | |
981 -- The value to return has already be computed | |
982 | |
983 return Directory_Entry.Kind; | |
984 end if; | |
985 end Kind; | |
986 | |
987 ----------------------- | |
988 -- Modification_Time -- | |
989 ----------------------- | |
990 | |
991 function Modification_Time (Name : String) return Time is | |
992 Date : OS_Time; | |
993 Year : Year_Type; | |
994 Month : Month_Type; | |
995 Day : Day_Type; | |
996 Hour : Hour_Type; | |
997 Minute : Minute_Type; | |
998 Second : Second_Type; | |
999 | |
1000 begin | |
1001 -- First, the invalid cases | |
1002 | |
1003 if not (Is_Regular_File (Name) or else Is_Directory (Name)) then | |
1004 raise Name_Error with '"' & Name & """ not a file or directory"; | |
1005 | |
1006 else | |
1007 Date := File_Time_Stamp (Name); | |
1008 | |
1009 -- Break down the time stamp into its constituents relative to GMT. | |
1010 -- This version of Split does not recognize leap seconds or buffer | |
1011 -- space for time zone processing. | |
1012 | |
1013 GM_Split (Date, Year, Month, Day, Hour, Minute, Second); | |
1014 | |
1015 -- The result must be in GMT. Ada.Calendar. | |
1016 -- Formatting.Time_Of with default time zone of zero (0) is the | |
1017 -- routine of choice. | |
1018 | |
1019 return Time_Of (Year, Month, Day, Hour, Minute, Second, 0.0); | |
1020 end if; | |
1021 end Modification_Time; | |
1022 | |
1023 function Modification_Time | |
1024 (Directory_Entry : Directory_Entry_Type) return Ada.Calendar.Time | |
1025 is | |
1026 begin | |
1027 -- First, the invalid case | |
1028 | |
1029 if not Directory_Entry.Is_Valid then | |
1030 raise Status_Error with "invalid directory entry"; | |
1031 | |
1032 else | |
1033 -- The value to return has already be computed | |
1034 | |
1035 return Modification_Time (To_String (Directory_Entry.Full)); | |
1036 end if; | |
1037 end Modification_Time; | |
1038 | |
1039 ------------------ | |
1040 -- More_Entries -- | |
1041 ------------------ | |
1042 | |
1043 function More_Entries (Search : Search_Type) return Boolean is | |
1044 begin | |
1045 if Search.Value = null then | |
1046 return False; | |
1047 | |
1048 elsif Search.Value.Is_Valid then | |
1049 | |
1050 -- Fetch the next entry, if needed | |
1051 | |
1052 if not Search.Value.Entry_Fetched then | |
1053 Fetch_Next_Entry (Search); | |
1054 end if; | |
1055 end if; | |
1056 | |
1057 return Search.Value.Is_Valid; | |
1058 end More_Entries; | |
1059 | |
1060 ------------ | |
1061 -- Rename -- | |
1062 ------------ | |
1063 | |
1064 procedure Rename (Old_Name, New_Name : String) is | |
1065 Success : Boolean; | |
1066 | |
1067 begin | |
1068 -- First, the invalid cases | |
1069 | |
1070 if not Is_Valid_Path_Name (Old_Name) then | |
1071 raise Name_Error with "invalid old path name """ & Old_Name & '"'; | |
1072 | |
1073 elsif not Is_Valid_Path_Name (New_Name) then | |
1074 raise Name_Error with "invalid new path name """ & New_Name & '"'; | |
1075 | |
1076 elsif not Is_Regular_File (Old_Name) | |
1077 and then not Is_Directory (Old_Name) | |
1078 then | |
1079 raise Name_Error with "old file """ & Old_Name & """ does not exist"; | |
1080 | |
1081 elsif Is_Regular_File (New_Name) or else Is_Directory (New_Name) then | |
1082 raise Use_Error with | |
1083 "new name """ & New_Name | |
1084 & """ designates a file that already exists"; | |
1085 | |
1086 -- Do actual rename using System.OS_Lib.Rename_File | |
1087 | |
1088 else | |
1089 Rename_File (Old_Name, New_Name, Success); | |
1090 | |
1091 if not Success then | |
1092 | |
1093 -- AI05-0231-1: Name_Error should be raised in case a directory | |
1094 -- component of New_Name does not exist (as in New_Name => | |
1095 -- "/no-such-dir/new-filename"). ENOENT indicates that. ENOENT | |
1096 -- also indicate that the Old_Name does not exist, but we already | |
1097 -- checked for that above. All other errors are Use_Error. | |
1098 | |
1099 if Errno = ENOENT then | |
1100 raise Name_Error with | |
1101 "file """ & Containing_Directory (New_Name) & """ not found"; | |
1102 | |
1103 else | |
1104 raise Use_Error with | |
1105 "file """ & Old_Name & """ could not be renamed"; | |
1106 end if; | |
1107 end if; | |
1108 end if; | |
1109 end Rename; | |
1110 | |
1111 ------------ | |
1112 -- Search -- | |
1113 ------------ | |
1114 | |
1115 procedure Search | |
1116 (Directory : String; | |
1117 Pattern : String; | |
1118 Filter : Filter_Type := (others => True); | |
1119 Process : not null access procedure | |
1120 (Directory_Entry : Directory_Entry_Type)) | |
1121 is | |
1122 Srch : Search_Type; | |
1123 Directory_Entry : Directory_Entry_Type; | |
1124 | |
1125 begin | |
1126 Start_Search (Srch, Directory, Pattern, Filter); | |
1127 while More_Entries (Srch) loop | |
1128 Get_Next_Entry (Srch, Directory_Entry); | |
1129 Process (Directory_Entry); | |
1130 end loop; | |
1131 | |
1132 End_Search (Srch); | |
1133 end Search; | |
1134 | |
1135 ------------------- | |
1136 -- Set_Directory -- | |
1137 ------------------- | |
1138 | |
1139 procedure Set_Directory (Directory : String) is | |
1140 C_Dir_Name : constant String := Directory & ASCII.NUL; | |
1141 begin | |
1142 if not Is_Valid_Path_Name (Directory) then | |
1143 raise Name_Error with | |
1144 "invalid directory path name & """ & Directory & '"'; | |
1145 | |
1146 elsif not Is_Directory (Directory) then | |
1147 raise Name_Error with | |
1148 "directory """ & Directory & """ does not exist"; | |
1149 | |
1150 elsif chdir (C_Dir_Name) /= 0 then | |
1151 raise Name_Error with | |
1152 "could not set to designated directory """ & Directory & '"'; | |
1153 end if; | |
1154 end Set_Directory; | |
1155 | |
1156 ----------------- | |
1157 -- Simple_Name -- | |
1158 ----------------- | |
1159 | |
1160 function Simple_Name (Name : String) return String is | |
1161 | |
1162 function Simple_Name_Internal (Path : String) return String; | |
1163 -- This function does the job | |
1164 | |
1165 -------------------------- | |
1166 -- Simple_Name_Internal -- | |
1167 -------------------------- | |
1168 | |
1169 function Simple_Name_Internal (Path : String) return String is | |
1170 Cut_Start : Natural := | |
1171 Strings.Fixed.Index (Path, Dir_Seps, Going => Strings.Backward); | |
1172 Cut_End : Natural; | |
1173 | |
1174 begin | |
1175 -- Cut_Start pointS to the first simple name character | |
1176 | |
1177 Cut_Start := (if Cut_Start = 0 then Path'First else Cut_Start + 1); | |
1178 | |
1179 -- Cut_End point to the last simple name character | |
1180 | |
1181 Cut_End := Path'Last; | |
1182 | |
1183 Check_For_Standard_Dirs : declare | |
1184 BN : constant String := Path (Cut_Start .. Cut_End); | |
1185 | |
1186 Has_Drive_Letter : constant Boolean := | |
1187 OS_Lib.Path_Separator /= ':'; | |
1188 -- If Path separator is not ':' then we are on a DOS based OS | |
1189 -- where this character is used as a drive letter separator. | |
1190 | |
1191 begin | |
1192 if BN = "." or else BN = ".." then | |
1193 return ""; | |
1194 | |
1195 elsif Has_Drive_Letter | |
1196 and then BN'Length > 2 | |
1197 and then Characters.Handling.Is_Letter (BN (BN'First)) | |
1198 and then BN (BN'First + 1) = ':' | |
1199 then | |
1200 -- We have a DOS drive letter prefix, remove it | |
1201 | |
1202 return BN (BN'First + 2 .. BN'Last); | |
1203 | |
1204 else | |
1205 return BN; | |
1206 end if; | |
1207 end Check_For_Standard_Dirs; | |
1208 end Simple_Name_Internal; | |
1209 | |
1210 -- Start of processing for Simple_Name | |
1211 | |
1212 begin | |
1213 -- First, the invalid case | |
1214 | |
1215 if not Is_Valid_Path_Name (Name) then | |
1216 raise Name_Error with "invalid path name """ & Name & '"'; | |
1217 | |
1218 else | |
1219 -- Build the value to return with lower bound 1 | |
1220 | |
1221 declare | |
1222 Value : constant String := Simple_Name_Internal (Name); | |
1223 subtype Result is String (1 .. Value'Length); | |
1224 begin | |
1225 return Result (Value); | |
1226 end; | |
1227 end if; | |
1228 end Simple_Name; | |
1229 | |
1230 function Simple_Name | |
1231 (Directory_Entry : Directory_Entry_Type) return String is | |
1232 begin | |
1233 -- First, the invalid case | |
1234 | |
1235 if not Directory_Entry.Is_Valid then | |
1236 raise Status_Error with "invalid directory entry"; | |
1237 | |
1238 else | |
1239 -- The value to return has already be computed | |
1240 | |
1241 return To_String (Directory_Entry.Simple); | |
1242 end if; | |
1243 end Simple_Name; | |
1244 | |
1245 ---------- | |
1246 -- Size -- | |
1247 ---------- | |
1248 | |
1249 function Size (Name : String) return File_Size is | |
1250 C_Name : String (1 .. Name'Length + 1); | |
1251 | |
1252 function C_Size (Name : Address) return int64; | |
1253 pragma Import (C, C_Size, "__gnat_named_file_length"); | |
1254 | |
1255 begin | |
1256 -- First, the invalid case | |
1257 | |
1258 if not Is_Regular_File (Name) then | |
1259 raise Name_Error with "file """ & Name & """ does not exist"; | |
1260 | |
1261 else | |
1262 C_Name (1 .. Name'Length) := Name; | |
1263 C_Name (C_Name'Last) := ASCII.NUL; | |
1264 return File_Size (C_Size (C_Name'Address)); | |
1265 end if; | |
1266 end Size; | |
1267 | |
1268 function Size (Directory_Entry : Directory_Entry_Type) return File_Size is | |
1269 begin | |
1270 -- First, the invalid case | |
1271 | |
1272 if not Directory_Entry.Is_Valid then | |
1273 raise Status_Error with "invalid directory entry"; | |
1274 | |
1275 else | |
1276 -- The value to return has already be computed | |
1277 | |
1278 return Size (To_String (Directory_Entry.Full)); | |
1279 end if; | |
1280 end Size; | |
1281 | |
1282 ------------------ | |
1283 -- Start_Search -- | |
1284 ------------------ | |
1285 | |
1286 procedure Start_Search | |
1287 (Search : in out Search_Type; | |
1288 Directory : String; | |
1289 Pattern : String; | |
1290 Filter : Filter_Type := (others => True)) | |
1291 is | |
1292 function opendir (file_name : String) return DIRs; | |
1293 pragma Import (C, opendir, "__gnat_opendir"); | |
1294 | |
1295 C_File_Name : constant String := Directory & ASCII.NUL; | |
1296 Pat : Regexp; | |
1297 Dir : Dir_Type_Value; | |
1298 | |
1299 begin | |
1300 -- First, the invalid case Name_Error | |
1301 | |
1302 if not Is_Directory (Directory) then | |
1303 raise Name_Error with | |
1304 "unknown directory """ & Simple_Name (Directory) & '"'; | |
1305 end if; | |
1306 | |
1307 -- Check the pattern | |
1308 | |
1309 begin | |
1310 Pat := Compile | |
1311 (Pattern, | |
1312 Glob => True, | |
1313 Case_Sensitive => Is_Path_Name_Case_Sensitive); | |
1314 exception | |
1315 when Error_In_Regexp => | |
1316 Free (Search.Value); | |
1317 raise Name_Error with "invalid pattern """ & Pattern & '"'; | |
1318 end; | |
1319 | |
1320 Dir := Dir_Type_Value (opendir (C_File_Name)); | |
1321 | |
1322 if Dir = No_Dir then | |
1323 raise Use_Error with | |
1324 "unreadable directory """ & Simple_Name (Directory) & '"'; | |
1325 end if; | |
1326 | |
1327 -- If needed, finalize Search | |
1328 | |
1329 Finalize (Search); | |
1330 | |
1331 -- Allocate the default data | |
1332 | |
1333 Search.Value := new Search_Data; | |
1334 | |
1335 -- Initialize some Search components | |
1336 | |
1337 Search.Value.Filter := Filter; | |
1338 Search.Value.Name := To_Unbounded_String (Full_Name (Directory)); | |
1339 Search.Value.Pattern := Pat; | |
1340 Search.Value.Dir := Dir; | |
1341 Search.Value.Is_Valid := True; | |
1342 end Start_Search; | |
1343 | |
1344 end Ada.Directories; |