File : a-direct.adb
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-2016, 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 -- --
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.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 -- We need to resolve links because of RM A.16(47), which requires
532 -- that we not return alternative names for files.
533
534 return Normalize_Pathname (Buffer (1 .. Path_Len));
535 end Current_Directory;
536
537 ----------------------
538 -- Delete_Directory --
539 ----------------------
540
541 procedure Delete_Directory (Directory : String) is
542 begin
543 -- First, the invalid cases
544
545 if not Is_Valid_Path_Name (Directory) then
546 raise Name_Error with
547 "invalid directory path name """ & Directory & '"';
548
549 elsif not Is_Directory (Directory) then
550 raise Name_Error with '"' & Directory & """ not a directory";
551
552 -- Do the deletion, checking for error
553
554 else
555 declare
556 C_Dir_Name : constant String := Directory & ASCII.NUL;
557 begin
558 if rmdir (C_Dir_Name) /= 0 then
559 raise Use_Error with
560 "deletion of directory """ & Directory & """ failed";
561 end if;
562 end;
563 end if;
564 end Delete_Directory;
565
566 -----------------
567 -- Delete_File --
568 -----------------
569
570 procedure Delete_File (Name : String) is
571 Success : Boolean;
572
573 begin
574 -- First, the invalid cases
575
576 if not Is_Valid_Path_Name (Name) then
577 raise Name_Error with "invalid path name """ & Name & '"';
578
579 elsif not Is_Regular_File (Name)
580 and then not Is_Symbolic_Link (Name)
581 then
582 raise Name_Error with "file """ & Name & """ does not exist";
583
584 else
585 -- Do actual deletion using System.OS_Lib.Delete_File
586
587 Delete_File (Name, Success);
588
589 if not Success then
590 raise Use_Error with "file """ & Name & """ could not be deleted";
591 end if;
592 end if;
593 end Delete_File;
594
595 -----------------
596 -- Delete_Tree --
597 -----------------
598
599 procedure Delete_Tree (Directory : String) is
600 Search : Search_Type;
601 Dir_Ent : Directory_Entry_Type;
602 begin
603 -- First, the invalid cases
604
605 if not Is_Valid_Path_Name (Directory) then
606 raise Name_Error with
607 "invalid directory path name """ & Directory & '"';
608
609 elsif not Is_Directory (Directory) then
610 raise Name_Error with '"' & Directory & """ not a directory";
611
612 else
613
614 -- We used to change the current directory to Directory here,
615 -- allowing the use of a local Simple_Name for all references. This
616 -- turned out unfriendly to multitasking programs, where tasks
617 -- running in parallel of this Delete_Tree could see their current
618 -- directory change unpredictably. We now resort to Full_Name
619 -- computations to reach files and subdirs instead.
620
621 Start_Search (Search, Directory => Directory, Pattern => "");
622 while More_Entries (Search) loop
623 Get_Next_Entry (Search, Dir_Ent);
624
625 declare
626 Fname : constant String := Full_Name (Dir_Ent);
627 Sname : constant String := Simple_Name (Dir_Ent);
628
629 begin
630 if OS_Lib.Is_Directory (Fname) then
631 if Sname /= "." and then Sname /= ".." then
632 Delete_Tree (Fname);
633 end if;
634 else
635 Delete_File (Fname);
636 end if;
637 end;
638 end loop;
639
640 End_Search (Search);
641
642 declare
643 C_Dir_Name : constant String := Directory & ASCII.NUL;
644
645 begin
646 if rmdir (C_Dir_Name) /= 0 then
647 raise Use_Error with
648 "directory tree rooted at """ &
649 Directory & """ could not be deleted";
650 end if;
651 end;
652 end if;
653 end Delete_Tree;
654
655 ------------
656 -- Exists --
657 ------------
658
659 function Exists (Name : String) return Boolean is
660 begin
661 -- First, the invalid case
662
663 if not Is_Valid_Path_Name (Name) then
664 raise Name_Error with "invalid path name """ & Name & '"';
665
666 else
667 -- The implementation is in File_Exists
668
669 return File_Exists (Name);
670 end if;
671 end Exists;
672
673 ---------------
674 -- Extension --
675 ---------------
676
677 function Extension (Name : String) return String is
678 begin
679 -- First, the invalid case
680
681 if not Is_Valid_Path_Name (Name) then
682 raise Name_Error with "invalid path name """ & Name & '"';
683
684 else
685 -- Look for first dot that is not followed by a directory separator
686
687 for Pos in reverse Name'Range loop
688
689 -- If a directory separator is found before a dot, there is no
690 -- extension.
691
692 if Is_In (Name (Pos), Dir_Seps) then
693 return Empty_String;
694
695 elsif Name (Pos) = '.' then
696
697 -- We found a dot, build the return value with lower bound 1
698
699 declare
700 subtype Result_Type is String (1 .. Name'Last - Pos);
701 begin
702 return Result_Type (Name (Pos + 1 .. Name'Last));
703 end;
704 end if;
705 end loop;
706
707 -- No dot were found, there is no extension
708
709 return Empty_String;
710 end if;
711 end Extension;
712
713 ----------------------
714 -- Fetch_Next_Entry --
715 ----------------------
716
717 procedure Fetch_Next_Entry (Search : Search_Type) is
718 Name : String (1 .. NAME_MAX);
719 Last : Natural;
720
721 Kind : File_Kind := Ordinary_File;
722 -- Initialized to avoid a compilation warning
723
724 Filename_Addr : Address;
725 Filename_Len : aliased Integer;
726
727 Buffer : array (1 .. SIZEOF_struct_dirent_alloc) of Character;
728
729 function readdir_gnat
730 (Directory : Address;
731 Buffer : Address;
732 Last : not null access Integer) return Address;
733 pragma Import (C, readdir_gnat, "__gnat_readdir");
734
735 begin
736 -- Search.Value.Is_Valid is always True when Fetch_Next_Entry is called
737
738 loop
739 Filename_Addr :=
740 readdir_gnat
741 (Address (Search.Value.Dir),
742 Buffer'Address,
743 Filename_Len'Access);
744
745 -- If no matching entry is found, set Is_Valid to False
746
747 if Filename_Addr = Null_Address then
748 Search.Value.Is_Valid := False;
749 exit;
750 end if;
751
752 if Filename_Len > Name'Length then
753 raise Use_Error with "file name too long";
754 end if;
755
756 declare
757 subtype Name_String is String (1 .. Filename_Len);
758 Dent_Name : Name_String;
759 for Dent_Name'Address use Filename_Addr;
760 pragma Import (Ada, Dent_Name);
761
762 begin
763 Last := Filename_Len;
764 Name (1 .. Last) := Dent_Name;
765 end;
766
767 -- Check if the entry matches the pattern
768
769 if Match (Name (1 .. Last), Search.Value.Pattern) then
770 declare
771 C_Full_Name : constant String :=
772 Compose (To_String (Search.Value.Name),
773 Name (1 .. Last)) & ASCII.NUL;
774 Full_Name : String renames
775 C_Full_Name
776 (C_Full_Name'First .. C_Full_Name'Last - 1);
777 Found : Boolean := False;
778 Attr : aliased File_Attributes;
779 Exists : Integer;
780 Error : Integer;
781
782 begin
783 Reset_Attributes (Attr'Access);
784 Exists := File_Exists_Attr (C_Full_Name'Address, Attr'Access);
785 Error := Error_Attributes (Attr'Access);
786
787 if Error /= 0 then
788 raise Use_Error
789 with Full_Name & ": " & Errno_Message (Err => Error);
790 end if;
791
792 if Exists = 1 then
793
794 -- Now check if the file kind matches the filter
795
796 if Is_Regular_File_Attr
797 (C_Full_Name'Address, Attr'Access) = 1
798 then
799 if Search.Value.Filter (Ordinary_File) then
800 Kind := Ordinary_File;
801 Found := True;
802 end if;
803
804 elsif Is_Directory_Attr
805 (C_Full_Name'Address, Attr'Access) = 1
806 then
807 if Search.Value.Filter (Directory) then
808 Kind := Directory;
809 Found := True;
810 end if;
811
812 elsif Search.Value.Filter (Special_File) then
813 Kind := Special_File;
814 Found := True;
815 end if;
816
817 -- If it does, update Search and return
818
819 if Found then
820 Search.Value.Entry_Fetched := True;
821 Search.Value.Dir_Entry :=
822 (Is_Valid => True,
823 Simple => To_Unbounded_String (Name (1 .. Last)),
824 Full => To_Unbounded_String (Full_Name),
825 Kind => Kind);
826 exit;
827 end if;
828 end if;
829 end;
830 end if;
831 end loop;
832 end Fetch_Next_Entry;
833
834 -----------------
835 -- File_Exists --
836 -----------------
837
838 function File_Exists (Name : String) return Boolean is
839 function C_File_Exists (A : Address) return Integer;
840 pragma Import (C, C_File_Exists, "__gnat_file_exists");
841
842 C_Name : String (1 .. Name'Length + 1);
843
844 begin
845 C_Name (1 .. Name'Length) := Name;
846 C_Name (C_Name'Last) := ASCII.NUL;
847 return C_File_Exists (C_Name'Address) = 1;
848 end File_Exists;
849
850 --------------
851 -- Finalize --
852 --------------
853
854 procedure Finalize (Search : in out Search_Type) is
855 begin
856 if Search.Value /= null then
857
858 -- Close the directory, if one is open
859
860 if Search.Value.Dir /= No_Dir then
861 Close (Search.Value.Dir);
862 end if;
863
864 Free (Search.Value);
865 end if;
866 end Finalize;
867
868 ---------------
869 -- Full_Name --
870 ---------------
871
872 function Full_Name (Name : String) return String is
873 begin
874 -- First, the invalid case
875
876 if not Is_Valid_Path_Name (Name) then
877 raise Name_Error with "invalid path name """ & Name & '"';
878
879 else
880 -- Build the return value with lower bound 1
881
882 -- Use System.OS_Lib.Normalize_Pathname
883
884 declare
885 -- We need to resolve links because of (RM A.16(47)), which says
886 -- we must not return alternative names for files.
887
888 Value : constant String := Normalize_Pathname (Name);
889 subtype Result is String (1 .. Value'Length);
890
891 begin
892 return Result (Value);
893 end;
894 end if;
895 end Full_Name;
896
897 function Full_Name (Directory_Entry : Directory_Entry_Type) return String is
898 begin
899 -- First, the invalid case
900
901 if not Directory_Entry.Is_Valid then
902 raise Status_Error with "invalid directory entry";
903
904 else
905 -- The value to return has already been computed
906
907 return To_String (Directory_Entry.Full);
908 end if;
909 end Full_Name;
910
911 --------------------
912 -- Get_Next_Entry --
913 --------------------
914
915 procedure Get_Next_Entry
916 (Search : in out Search_Type;
917 Directory_Entry : out Directory_Entry_Type)
918 is
919 begin
920 -- First, the invalid case
921
922 if Search.Value = null or else not Search.Value.Is_Valid then
923 raise Status_Error with "invalid search";
924 end if;
925
926 -- Fetch the next entry, if needed
927
928 if not Search.Value.Entry_Fetched then
929 Fetch_Next_Entry (Search);
930 end if;
931
932 -- It is an error if no valid entry is found
933
934 if not Search.Value.Is_Valid then
935 raise Status_Error with "no next entry";
936
937 else
938 -- Reset Entry_Fetched and return the entry
939
940 Search.Value.Entry_Fetched := False;
941 Directory_Entry := Search.Value.Dir_Entry;
942 end if;
943 end Get_Next_Entry;
944
945 ----------
946 -- Kind --
947 ----------
948
949 function Kind (Name : String) return File_Kind is
950 begin
951 -- First, the invalid case
952
953 if not File_Exists (Name) then
954 raise Name_Error with "file """ & Name & """ does not exist";
955
956 -- If OK, return appropriate kind
957
958 elsif Is_Regular_File (Name) then
959 return Ordinary_File;
960
961 elsif Is_Directory (Name) then
962 return Directory;
963
964 else
965 return Special_File;
966 end if;
967 end Kind;
968
969 function Kind (Directory_Entry : Directory_Entry_Type) return File_Kind is
970 begin
971 -- First, the invalid case
972
973 if not Directory_Entry.Is_Valid then
974 raise Status_Error with "invalid directory entry";
975
976 else
977 -- The value to return has already be computed
978
979 return Directory_Entry.Kind;
980 end if;
981 end Kind;
982
983 -----------------------
984 -- Modification_Time --
985 -----------------------
986
987 function Modification_Time (Name : String) return Time is
988 Date : OS_Time;
989 Year : Year_Type;
990 Month : Month_Type;
991 Day : Day_Type;
992 Hour : Hour_Type;
993 Minute : Minute_Type;
994 Second : Second_Type;
995
996 begin
997 -- First, the invalid cases
998
999 if not (Is_Regular_File (Name) or else Is_Directory (Name)) then
1000 raise Name_Error with '"' & Name & """ not a file or directory";
1001
1002 else
1003 Date := File_Time_Stamp (Name);
1004
1005 -- Break down the time stamp into its constituents relative to GMT.
1006 -- This version of Split does not recognize leap seconds or buffer
1007 -- space for time zone processing.
1008
1009 GM_Split (Date, Year, Month, Day, Hour, Minute, Second);
1010
1011 -- The result must be in GMT. Ada.Calendar.
1012 -- Formatting.Time_Of with default time zone of zero (0) is the
1013 -- routine of choice.
1014
1015 return Time_Of (Year, Month, Day, Hour, Minute, Second, 0.0);
1016 end if;
1017 end Modification_Time;
1018
1019 function Modification_Time
1020 (Directory_Entry : Directory_Entry_Type) return Ada.Calendar.Time
1021 is
1022 begin
1023 -- First, the invalid case
1024
1025 if not Directory_Entry.Is_Valid then
1026 raise Status_Error with "invalid directory entry";
1027
1028 else
1029 -- The value to return has already be computed
1030
1031 return Modification_Time (To_String (Directory_Entry.Full));
1032 end if;
1033 end Modification_Time;
1034
1035 ------------------
1036 -- More_Entries --
1037 ------------------
1038
1039 function More_Entries (Search : Search_Type) return Boolean is
1040 begin
1041 if Search.Value = null then
1042 return False;
1043
1044 elsif Search.Value.Is_Valid then
1045
1046 -- Fetch the next entry, if needed
1047
1048 if not Search.Value.Entry_Fetched then
1049 Fetch_Next_Entry (Search);
1050 end if;
1051 end if;
1052
1053 return Search.Value.Is_Valid;
1054 end More_Entries;
1055
1056 ------------
1057 -- Rename --
1058 ------------
1059
1060 procedure Rename (Old_Name, New_Name : String) is
1061 Success : Boolean;
1062
1063 begin
1064 -- First, the invalid cases
1065
1066 if not Is_Valid_Path_Name (Old_Name) then
1067 raise Name_Error with "invalid old path name """ & Old_Name & '"';
1068
1069 elsif not Is_Valid_Path_Name (New_Name) then
1070 raise Name_Error with "invalid new path name """ & New_Name & '"';
1071
1072 elsif not Is_Regular_File (Old_Name)
1073 and then not Is_Directory (Old_Name)
1074 then
1075 raise Name_Error with "old file """ & Old_Name & """ does not exist";
1076
1077 elsif Is_Regular_File (New_Name) or else Is_Directory (New_Name) then
1078 raise Use_Error with
1079 "new name """ & New_Name
1080 & """ designates a file that already exists";
1081
1082 -- Do actual rename using System.OS_Lib.Rename_File
1083
1084 else
1085 Rename_File (Old_Name, New_Name, Success);
1086
1087 if not Success then
1088
1089 -- AI05-0231-1: Name_Error should be raised in case a directory
1090 -- component of New_Name does not exist (as in New_Name =>
1091 -- "/no-such-dir/new-filename"). ENOENT indicates that. ENOENT
1092 -- also indicate that the Old_Name does not exist, but we already
1093 -- checked for that above. All other errors are Use_Error.
1094
1095 if Errno = ENOENT then
1096 raise Name_Error with
1097 "file """ & Containing_Directory (New_Name) & """ not found";
1098
1099 else
1100 raise Use_Error with
1101 "file """ & Old_Name & """ could not be renamed";
1102 end if;
1103 end if;
1104 end if;
1105 end Rename;
1106
1107 ------------
1108 -- Search --
1109 ------------
1110
1111 procedure Search
1112 (Directory : String;
1113 Pattern : String;
1114 Filter : Filter_Type := (others => True);
1115 Process : not null access procedure
1116 (Directory_Entry : Directory_Entry_Type))
1117 is
1118 Srch : Search_Type;
1119 Directory_Entry : Directory_Entry_Type;
1120
1121 begin
1122 Start_Search (Srch, Directory, Pattern, Filter);
1123 while More_Entries (Srch) loop
1124 Get_Next_Entry (Srch, Directory_Entry);
1125 Process (Directory_Entry);
1126 end loop;
1127
1128 End_Search (Srch);
1129 end Search;
1130
1131 -------------------
1132 -- Set_Directory --
1133 -------------------
1134
1135 procedure Set_Directory (Directory : String) is
1136 C_Dir_Name : constant String := Directory & ASCII.NUL;
1137 begin
1138 if not Is_Valid_Path_Name (Directory) then
1139 raise Name_Error with
1140 "invalid directory path name & """ & Directory & '"';
1141
1142 elsif not Is_Directory (Directory) then
1143 raise Name_Error with
1144 "directory """ & Directory & """ does not exist";
1145
1146 elsif chdir (C_Dir_Name) /= 0 then
1147 raise Name_Error with
1148 "could not set to designated directory """ & Directory & '"';
1149 end if;
1150 end Set_Directory;
1151
1152 -----------------
1153 -- Simple_Name --
1154 -----------------
1155
1156 function Simple_Name (Name : String) return String is
1157
1158 function Simple_Name_Internal (Path : String) return String;
1159 -- This function does the job
1160
1161 --------------------------
1162 -- Simple_Name_Internal --
1163 --------------------------
1164
1165 function Simple_Name_Internal (Path : String) return String is
1166 Cut_Start : Natural :=
1167 Strings.Fixed.Index (Path, Dir_Seps, Going => Strings.Backward);
1168 Cut_End : Natural;
1169
1170 begin
1171 -- Cut_Start pointS to the first simple name character
1172
1173 Cut_Start := (if Cut_Start = 0 then Path'First else Cut_Start + 1);
1174
1175 -- Cut_End point to the last simple name character
1176
1177 Cut_End := Path'Last;
1178
1179 Check_For_Standard_Dirs : declare
1180 BN : constant String := Path (Cut_Start .. Cut_End);
1181
1182 Has_Drive_Letter : constant Boolean :=
1183 OS_Lib.Path_Separator /= ':';
1184 -- If Path separator is not ':' then we are on a DOS based OS
1185 -- where this character is used as a drive letter separator.
1186
1187 begin
1188 if BN = "." or else BN = ".." then
1189 return "";
1190
1191 elsif Has_Drive_Letter
1192 and then BN'Length > 2
1193 and then Characters.Handling.Is_Letter (BN (BN'First))
1194 and then BN (BN'First + 1) = ':'
1195 then
1196 -- We have a DOS drive letter prefix, remove it
1197
1198 return BN (BN'First + 2 .. BN'Last);
1199
1200 else
1201 return BN;
1202 end if;
1203 end Check_For_Standard_Dirs;
1204 end Simple_Name_Internal;
1205
1206 -- Start of processing for Simple_Name
1207
1208 begin
1209 -- First, the invalid case
1210
1211 if not Is_Valid_Path_Name (Name) then
1212 raise Name_Error with "invalid path name """ & Name & '"';
1213
1214 else
1215 -- Build the value to return with lower bound 1
1216
1217 declare
1218 Value : constant String := Simple_Name_Internal (Name);
1219 subtype Result is String (1 .. Value'Length);
1220 begin
1221 return Result (Value);
1222 end;
1223 end if;
1224 end Simple_Name;
1225
1226 function Simple_Name
1227 (Directory_Entry : Directory_Entry_Type) return String is
1228 begin
1229 -- First, the invalid case
1230
1231 if not Directory_Entry.Is_Valid then
1232 raise Status_Error with "invalid directory entry";
1233
1234 else
1235 -- The value to return has already be computed
1236
1237 return To_String (Directory_Entry.Simple);
1238 end if;
1239 end Simple_Name;
1240
1241 ----------
1242 -- Size --
1243 ----------
1244
1245 function Size (Name : String) return File_Size is
1246 C_Name : String (1 .. Name'Length + 1);
1247
1248 function C_Size (Name : Address) return int64;
1249 pragma Import (C, C_Size, "__gnat_named_file_length");
1250
1251 begin
1252 -- First, the invalid case
1253
1254 if not Is_Regular_File (Name) then
1255 raise Name_Error with "file """ & Name & """ does not exist";
1256
1257 else
1258 C_Name (1 .. Name'Length) := Name;
1259 C_Name (C_Name'Last) := ASCII.NUL;
1260 return File_Size (C_Size (C_Name'Address));
1261 end if;
1262 end Size;
1263
1264 function Size (Directory_Entry : Directory_Entry_Type) return File_Size is
1265 begin
1266 -- First, the invalid case
1267
1268 if not Directory_Entry.Is_Valid then
1269 raise Status_Error with "invalid directory entry";
1270
1271 else
1272 -- The value to return has already be computed
1273
1274 return Size (To_String (Directory_Entry.Full));
1275 end if;
1276 end Size;
1277
1278 ------------------
1279 -- Start_Search --
1280 ------------------
1281
1282 procedure Start_Search
1283 (Search : in out Search_Type;
1284 Directory : String;
1285 Pattern : String;
1286 Filter : Filter_Type := (others => True))
1287 is
1288 function opendir (file_name : String) return DIRs;
1289 pragma Import (C, opendir, "__gnat_opendir");
1290
1291 C_File_Name : constant String := Directory & ASCII.NUL;
1292 Pat : Regexp;
1293 Dir : Dir_Type_Value;
1294
1295 begin
1296 -- First, the invalid case Name_Error
1297
1298 if not Is_Directory (Directory) then
1299 raise Name_Error with
1300 "unknown directory """ & Simple_Name (Directory) & '"';
1301 end if;
1302
1303 -- Check the pattern
1304
1305 begin
1306 Pat := Compile
1307 (Pattern,
1308 Glob => True,
1309 Case_Sensitive => Is_Path_Name_Case_Sensitive);
1310 exception
1311 when Error_In_Regexp =>
1312 Free (Search.Value);
1313 raise Name_Error with "invalid pattern """ & Pattern & '"';
1314 end;
1315
1316 Dir := Dir_Type_Value (opendir (C_File_Name));
1317
1318 if Dir = No_Dir then
1319 raise Use_Error with
1320 "unreadable directory """ & Simple_Name (Directory) & '"';
1321 end if;
1322
1323 -- If needed, finalize Search
1324
1325 Finalize (Search);
1326
1327 -- Allocate the default data
1328
1329 Search.Value := new Search_Data;
1330
1331 -- Initialize some Search components
1332
1333 Search.Value.Filter := Filter;
1334 Search.Value.Name := To_Unbounded_String (Full_Name (Directory));
1335 Search.Value.Pattern := Pat;
1336 Search.Value.Dir := Dir;
1337 Search.Value.Is_Valid := True;
1338 end Start_Search;
1339
1340 end Ada.Directories;