|
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 -- --
|
|
|
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;
|
