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