|
111
|
1 ------------------------------------------------------------------------------
|
|
|
2 -- --
|
|
|
3 -- GNAT COMPILER COMPONENTS --
|
|
|
4 -- --
|
|
|
5 -- S Y S T E M . O S _ L I B --
|
|
|
6 -- --
|
|
|
7 -- B o d y --
|
|
|
8 -- --
|
|
|
9 -- Copyright (C) 1995-2017, AdaCore --
|
|
|
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 pragma Compiler_Unit_Warning;
|
|
|
33
|
|
|
34 with Ada.Unchecked_Conversion;
|
|
|
35 with Ada.Unchecked_Deallocation;
|
|
|
36 with System; use System;
|
|
|
37 with System.Case_Util;
|
|
|
38 with System.CRTL;
|
|
|
39 with System.Soft_Links;
|
|
|
40
|
|
|
41 package body System.OS_Lib is
|
|
|
42
|
|
|
43 subtype size_t is CRTL.size_t;
|
|
|
44
|
|
|
45 procedure Strncpy (dest, src : System.Address; n : size_t)
|
|
|
46 renames CRTL.strncpy;
|
|
|
47
|
|
|
48 -- Imported procedures Dup and Dup2 are used in procedures Spawn and
|
|
|
49 -- Non_Blocking_Spawn.
|
|
|
50
|
|
|
51 function Dup (Fd : File_Descriptor) return File_Descriptor;
|
|
|
52 pragma Import (C, Dup, "__gnat_dup");
|
|
|
53
|
|
|
54 procedure Dup2 (Old_Fd, New_Fd : File_Descriptor);
|
|
|
55 pragma Import (C, Dup2, "__gnat_dup2");
|
|
|
56
|
|
|
57 function Copy_Attributes
|
|
|
58 (From : System.Address;
|
|
|
59 To : System.Address;
|
|
|
60 Mode : Integer) return Integer;
|
|
|
61 pragma Import (C, Copy_Attributes, "__gnat_copy_attribs");
|
|
|
62 -- Mode = 0 - copy only time stamps.
|
|
|
63 -- Mode = 1 - copy time stamps and read/write/execute attributes
|
|
|
64 -- Mode = 2 - copy read/write/execute attributes
|
|
|
65
|
|
|
66 On_Windows : constant Boolean := Directory_Separator = '\';
|
|
|
67 -- An indication that we are on Windows. Used in Normalize_Pathname, to
|
|
|
68 -- deal with drive letters in the beginning of absolute paths.
|
|
|
69
|
|
|
70 package SSL renames System.Soft_Links;
|
|
|
71
|
|
|
72 -- The following are used by Create_Temp_File
|
|
|
73
|
|
|
74 First_Temp_File_Name : constant String := "GNAT-TEMP-000000.TMP";
|
|
|
75 -- Used to initialize Current_Temp_File_Name and Temp_File_Name_Last_Digit
|
|
|
76
|
|
|
77 Current_Temp_File_Name : String := First_Temp_File_Name;
|
|
|
78 -- Name of the temp file last created
|
|
|
79
|
|
|
80 Temp_File_Name_Last_Digit : constant Positive :=
|
|
|
81 First_Temp_File_Name'Last - 4;
|
|
|
82 -- Position of the last digit in Current_Temp_File_Name
|
|
|
83
|
|
|
84 Max_Attempts : constant := 100;
|
|
|
85 -- The maximum number of attempts to create a new temp file
|
|
|
86
|
|
|
87 -----------------------
|
|
|
88 -- Local Subprograms --
|
|
|
89 -----------------------
|
|
|
90
|
|
|
91 function Args_Length (Args : Argument_List) return Natural;
|
|
|
92 -- Returns total number of characters needed to create a string of all Args
|
|
|
93 -- terminated by ASCII.NUL characters.
|
|
|
94
|
|
|
95 procedure Create_Temp_File_Internal
|
|
|
96 (FD : out File_Descriptor;
|
|
|
97 Name : out String_Access;
|
|
|
98 Stdout : Boolean);
|
|
|
99 -- Internal routine to implement two Create_Temp_File routines. If Stdout
|
|
|
100 -- is set to True the created descriptor is stdout-compatible, otherwise
|
|
|
101 -- it might not be depending on the OS. The first two parameters are as
|
|
|
102 -- in Create_Temp_File.
|
|
|
103
|
|
|
104 function C_String_Length (S : Address) return Integer;
|
|
|
105 -- Returns the length of C (null-terminated) string at S, or 0 for
|
|
|
106 -- Null_Address.
|
|
|
107
|
|
|
108 procedure Spawn_Internal
|
|
|
109 (Program_Name : String;
|
|
|
110 Args : Argument_List;
|
|
|
111 Result : out Integer;
|
|
|
112 Pid : out Process_Id;
|
|
|
113 Blocking : Boolean);
|
|
|
114 -- Internal routine to implement the two Spawn (blocking/non blocking)
|
|
|
115 -- routines. If Blocking is set to True then the spawn is blocking
|
|
|
116 -- otherwise it is non blocking. In this latter case the Pid contains the
|
|
|
117 -- process id number. The first three parameters are as in Spawn. Note that
|
|
|
118 -- Spawn_Internal normalizes the argument list before calling the low level
|
|
|
119 -- system spawn routines (see Normalize_Arguments).
|
|
|
120 --
|
|
|
121 -- Note: Normalize_Arguments is designed to do nothing if it is called more
|
|
|
122 -- than once, so calling Normalize_Arguments before calling one of the
|
|
|
123 -- spawn routines is fine.
|
|
|
124
|
|
|
125 function To_Path_String_Access
|
|
|
126 (Path_Addr : Address;
|
|
|
127 Path_Len : Integer) return String_Access;
|
|
|
128 -- Converts a C String to an Ada String. We could do this making use of
|
|
|
129 -- Interfaces.C.Strings but we prefer not to import that entire package
|
|
|
130
|
|
|
131 ---------
|
|
|
132 -- "<" --
|
|
|
133 ---------
|
|
|
134
|
|
|
135 function "<" (X, Y : OS_Time) return Boolean is
|
|
|
136 begin
|
|
|
137 return Long_Integer (X) < Long_Integer (Y);
|
|
|
138 end "<";
|
|
|
139
|
|
|
140 ----------
|
|
|
141 -- "<=" --
|
|
|
142 ----------
|
|
|
143
|
|
|
144 function "<=" (X, Y : OS_Time) return Boolean is
|
|
|
145 begin
|
|
|
146 return Long_Integer (X) <= Long_Integer (Y);
|
|
|
147 end "<=";
|
|
|
148
|
|
|
149 ---------
|
|
|
150 -- ">" --
|
|
|
151 ---------
|
|
|
152
|
|
|
153 function ">" (X, Y : OS_Time) return Boolean is
|
|
|
154 begin
|
|
|
155 return Long_Integer (X) > Long_Integer (Y);
|
|
|
156 end ">";
|
|
|
157
|
|
|
158 ----------
|
|
|
159 -- ">=" --
|
|
|
160 ----------
|
|
|
161
|
|
|
162 function ">=" (X, Y : OS_Time) return Boolean is
|
|
|
163 begin
|
|
|
164 return Long_Integer (X) >= Long_Integer (Y);
|
|
|
165 end ">=";
|
|
|
166
|
|
|
167 -----------------
|
|
|
168 -- Args_Length --
|
|
|
169 -----------------
|
|
|
170
|
|
|
171 function Args_Length (Args : Argument_List) return Natural is
|
|
|
172 Len : Natural := 0;
|
|
|
173
|
|
|
174 begin
|
|
|
175 for J in Args'Range loop
|
|
|
176 Len := Len + Args (J)'Length + 1; -- One extra for ASCII.NUL
|
|
|
177 end loop;
|
|
|
178
|
|
|
179 return Len;
|
|
|
180 end Args_Length;
|
|
|
181
|
|
|
182 -----------------------------
|
|
|
183 -- Argument_String_To_List --
|
|
|
184 -----------------------------
|
|
|
185
|
|
|
186 function Argument_String_To_List
|
|
|
187 (Arg_String : String) return Argument_List_Access
|
|
|
188 is
|
|
|
189 Max_Args : constant Integer := Arg_String'Length;
|
|
|
190 New_Argv : Argument_List (1 .. Max_Args);
|
|
|
191 Idx : Integer;
|
|
|
192 New_Argc : Natural := 0;
|
|
|
193
|
|
|
194 Cleaned : String (1 .. Arg_String'Length);
|
|
|
195 Cleaned_Idx : Natural;
|
|
|
196 -- A cleaned up version of the argument. This function is taking
|
|
|
197 -- backslash escapes when computing the bounds for arguments. It is
|
|
|
198 -- then removing the extra backslashes from the argument.
|
|
|
199
|
|
|
200 Backslash_Is_Sep : constant Boolean := Directory_Separator = '\';
|
|
|
201 -- Whether '\' is a directory separator (as on Windows), or a way to
|
|
|
202 -- quote special characters.
|
|
|
203
|
|
|
204 begin
|
|
|
205 Idx := Arg_String'First;
|
|
|
206
|
|
|
207 loop
|
|
|
208 exit when Idx > Arg_String'Last;
|
|
|
209
|
|
|
210 declare
|
|
|
211 Backqd : Boolean := False;
|
|
|
212 Quoted : Boolean := False;
|
|
|
213
|
|
|
214 begin
|
|
|
215 Cleaned_Idx := Cleaned'First;
|
|
|
216
|
|
|
217 loop
|
|
|
218 -- An unquoted space is the end of an argument
|
|
|
219
|
|
|
220 if not (Backqd or Quoted)
|
|
|
221 and then Arg_String (Idx) = ' '
|
|
|
222 then
|
|
|
223 exit;
|
|
|
224
|
|
|
225 -- Start of a quoted string
|
|
|
226
|
|
|
227 elsif not (Backqd or Quoted)
|
|
|
228 and then Arg_String (Idx) = '"'
|
|
|
229 then
|
|
|
230 Quoted := True;
|
|
|
231 Cleaned (Cleaned_Idx) := Arg_String (Idx);
|
|
|
232 Cleaned_Idx := Cleaned_Idx + 1;
|
|
|
233
|
|
|
234 -- End of a quoted string and end of an argument
|
|
|
235
|
|
|
236 elsif (Quoted and not Backqd)
|
|
|
237 and then Arg_String (Idx) = '"'
|
|
|
238 then
|
|
|
239 Cleaned (Cleaned_Idx) := Arg_String (Idx);
|
|
|
240 Cleaned_Idx := Cleaned_Idx + 1;
|
|
|
241 Idx := Idx + 1;
|
|
|
242 exit;
|
|
|
243
|
|
|
244 -- Turn off backquoting after advancing one character
|
|
|
245
|
|
|
246 elsif Backqd then
|
|
|
247 Backqd := False;
|
|
|
248 Cleaned (Cleaned_Idx) := Arg_String (Idx);
|
|
|
249 Cleaned_Idx := Cleaned_Idx + 1;
|
|
|
250
|
|
|
251 -- Following character is backquoted
|
|
|
252
|
|
|
253 elsif not Backslash_Is_Sep and then Arg_String (Idx) = '\' then
|
|
|
254 Backqd := True;
|
|
|
255
|
|
|
256 else
|
|
|
257 Cleaned (Cleaned_Idx) := Arg_String (Idx);
|
|
|
258 Cleaned_Idx := Cleaned_Idx + 1;
|
|
|
259 end if;
|
|
|
260
|
|
|
261 Idx := Idx + 1;
|
|
|
262 exit when Idx > Arg_String'Last;
|
|
|
263 end loop;
|
|
|
264
|
|
|
265 -- Found an argument
|
|
|
266
|
|
|
267 New_Argc := New_Argc + 1;
|
|
|
268 New_Argv (New_Argc) :=
|
|
|
269 new String'(Cleaned (Cleaned'First .. Cleaned_Idx - 1));
|
|
|
270
|
|
|
271 -- Skip extraneous spaces
|
|
|
272
|
|
|
273 while Idx <= Arg_String'Last and then Arg_String (Idx) = ' ' loop
|
|
|
274 Idx := Idx + 1;
|
|
|
275 end loop;
|
|
|
276 end;
|
|
|
277 end loop;
|
|
|
278
|
|
|
279 return new Argument_List'(New_Argv (1 .. New_Argc));
|
|
|
280 end Argument_String_To_List;
|
|
|
281
|
|
|
282 ---------------------
|
|
|
283 -- C_String_Length --
|
|
|
284 ---------------------
|
|
|
285
|
|
|
286 function C_String_Length (S : Address) return Integer is
|
|
|
287 begin
|
|
|
288 if S = Null_Address then
|
|
|
289 return 0;
|
|
|
290 else
|
|
|
291 return Integer (CRTL.strlen (S));
|
|
|
292 end if;
|
|
|
293 end C_String_Length;
|
|
|
294
|
|
|
295 -----------
|
|
|
296 -- Close --
|
|
|
297 -----------
|
|
|
298
|
|
|
299 procedure Close (FD : File_Descriptor) is
|
|
|
300 use CRTL;
|
|
|
301 Discard : constant int := close (int (FD));
|
|
|
302 begin
|
|
|
303 null;
|
|
|
304 end Close;
|
|
|
305
|
|
|
306 procedure Close (FD : File_Descriptor; Status : out Boolean) is
|
|
|
307 use CRTL;
|
|
|
308 begin
|
|
|
309 Status := (close (int (FD)) = 0);
|
|
|
310 end Close;
|
|
|
311
|
|
|
312 ---------------
|
|
|
313 -- Copy_File --
|
|
|
314 ---------------
|
|
|
315
|
|
|
316 procedure Copy_File
|
|
|
317 (Name : String;
|
|
|
318 Pathname : String;
|
|
|
319 Success : out Boolean;
|
|
|
320 Mode : Copy_Mode := Copy;
|
|
|
321 Preserve : Attribute := Time_Stamps)
|
|
|
322 is
|
|
|
323 From : File_Descriptor;
|
|
|
324 To : File_Descriptor;
|
|
|
325
|
|
|
326 Copy_Error : exception;
|
|
|
327 -- Internal exception raised to signal error in copy
|
|
|
328
|
|
|
329 function Build_Path (Dir : String; File : String) return String;
|
|
|
330 -- Returns pathname Dir concatenated with File adding the directory
|
|
|
331 -- separator only if needed.
|
|
|
332
|
|
|
333 procedure Copy (From : File_Descriptor; To : File_Descriptor);
|
|
|
334 -- Read data from From and place them into To. In both cases the
|
|
|
335 -- operations uses the current file position. Raises Constraint_Error
|
|
|
336 -- if a problem occurs during the copy.
|
|
|
337
|
|
|
338 procedure Copy_To (To_Name : String);
|
|
|
339 -- Does a straight copy from source to designated destination file
|
|
|
340
|
|
|
341 ----------------
|
|
|
342 -- Build_Path --
|
|
|
343 ----------------
|
|
|
344
|
|
|
345 function Build_Path (Dir : String; File : String) return String is
|
|
|
346 function Is_Dirsep (C : Character) return Boolean;
|
|
|
347 pragma Inline (Is_Dirsep);
|
|
|
348 -- Returns True if C is a directory separator. On Windows we
|
|
|
349 -- handle both styles of directory separator.
|
|
|
350
|
|
|
351 ---------------
|
|
|
352 -- Is_Dirsep --
|
|
|
353 ---------------
|
|
|
354
|
|
|
355 function Is_Dirsep (C : Character) return Boolean is
|
|
|
356 begin
|
|
|
357 return C = Directory_Separator or else C = '/';
|
|
|
358 end Is_Dirsep;
|
|
|
359
|
|
|
360 -- Local variables
|
|
|
361
|
|
|
362 Base_File_Ptr : Integer;
|
|
|
363 -- The base file name is File (Base_File_Ptr + 1 .. File'Last)
|
|
|
364
|
|
|
365 Res : String (1 .. Dir'Length + File'Length + 1);
|
|
|
366
|
|
|
367 -- Start of processing for Build_Path
|
|
|
368
|
|
|
369 begin
|
|
|
370 -- Find base file name
|
|
|
371
|
|
|
372 Base_File_Ptr := File'Last;
|
|
|
373 while Base_File_Ptr >= File'First loop
|
|
|
374 exit when Is_Dirsep (File (Base_File_Ptr));
|
|
|
375 Base_File_Ptr := Base_File_Ptr - 1;
|
|
|
376 end loop;
|
|
|
377
|
|
|
378 declare
|
|
|
379 Base_File : String renames
|
|
|
380 File (Base_File_Ptr + 1 .. File'Last);
|
|
|
381
|
|
|
382 begin
|
|
|
383 Res (1 .. Dir'Length) := Dir;
|
|
|
384
|
|
|
385 if Is_Dirsep (Dir (Dir'Last)) then
|
|
|
386 Res (Dir'Length + 1 .. Dir'Length + Base_File'Length) :=
|
|
|
387 Base_File;
|
|
|
388 return Res (1 .. Dir'Length + Base_File'Length);
|
|
|
389
|
|
|
390 else
|
|
|
391 Res (Dir'Length + 1) := Directory_Separator;
|
|
|
392 Res (Dir'Length + 2 .. Dir'Length + 1 + Base_File'Length) :=
|
|
|
393 Base_File;
|
|
|
394 return Res (1 .. Dir'Length + 1 + Base_File'Length);
|
|
|
395 end if;
|
|
|
396 end;
|
|
|
397 end Build_Path;
|
|
|
398
|
|
|
399 ----------
|
|
|
400 -- Copy --
|
|
|
401 ----------
|
|
|
402
|
|
|
403 procedure Copy (From : File_Descriptor; To : File_Descriptor) is
|
|
|
404 Buf_Size : constant := 200_000;
|
|
|
405 type Buf is array (1 .. Buf_Size) of Character;
|
|
|
406 type Buf_Ptr is access Buf;
|
|
|
407
|
|
|
408 Buffer : Buf_Ptr;
|
|
|
409 R : Integer;
|
|
|
410 W : Integer;
|
|
|
411
|
|
|
412 Status_From : Boolean;
|
|
|
413 Status_To : Boolean;
|
|
|
414 -- Statuses for the calls to Close
|
|
|
415
|
|
|
416 procedure Free is new Ada.Unchecked_Deallocation (Buf, Buf_Ptr);
|
|
|
417
|
|
|
418 begin
|
|
|
419 -- Check for invalid descriptors, making sure that we do not
|
|
|
420 -- accidentally leave an open file descriptor around.
|
|
|
421
|
|
|
422 if From = Invalid_FD then
|
|
|
423 if To /= Invalid_FD then
|
|
|
424 Close (To, Status_To);
|
|
|
425 end if;
|
|
|
426
|
|
|
427 raise Copy_Error;
|
|
|
428
|
|
|
429 elsif To = Invalid_FD then
|
|
|
430 Close (From, Status_From);
|
|
|
431 raise Copy_Error;
|
|
|
432 end if;
|
|
|
433
|
|
|
434 -- Allocate the buffer on the heap
|
|
|
435
|
|
|
436 Buffer := new Buf;
|
|
|
437
|
|
|
438 loop
|
|
|
439 R := Read (From, Buffer (1)'Address, Buf_Size);
|
|
|
440
|
|
|
441 -- On some systems, the buffer may not be full. So, we need to try
|
|
|
442 -- again until there is nothing to read.
|
|
|
443
|
|
|
444 exit when R = 0;
|
|
|
445
|
|
|
446 W := Write (To, Buffer (1)'Address, R);
|
|
|
447
|
|
|
448 if W < R then
|
|
|
449
|
|
|
450 -- Problem writing data, could be a disk full. Close files
|
|
|
451 -- without worrying about status, since we are raising a
|
|
|
452 -- Copy_Error exception in any case.
|
|
|
453
|
|
|
454 Close (From, Status_From);
|
|
|
455 Close (To, Status_To);
|
|
|
456
|
|
|
457 Free (Buffer);
|
|
|
458
|
|
|
459 raise Copy_Error;
|
|
|
460 end if;
|
|
|
461 end loop;
|
|
|
462
|
|
|
463 Close (From, Status_From);
|
|
|
464 Close (To, Status_To);
|
|
|
465
|
|
|
466 Free (Buffer);
|
|
|
467
|
|
|
468 if not (Status_From and Status_To) then
|
|
|
469 raise Copy_Error;
|
|
|
470 end if;
|
|
|
471 end Copy;
|
|
|
472
|
|
|
473 -------------
|
|
|
474 -- Copy_To --
|
|
|
475 -------------
|
|
|
476
|
|
|
477 procedure Copy_To (To_Name : String) is
|
|
|
478 C_From : String (1 .. Name'Length + 1);
|
|
|
479 C_To : String (1 .. To_Name'Length + 1);
|
|
|
480
|
|
|
481 begin
|
|
|
482 From := Open_Read (Name, Binary);
|
|
|
483
|
|
|
484 -- Do not clobber destination file if source file could not be opened
|
|
|
485
|
|
|
486 if From /= Invalid_FD then
|
|
|
487 To := Create_File (To_Name, Binary);
|
|
|
488 end if;
|
|
|
489
|
|
|
490 Copy (From, To);
|
|
|
491
|
|
|
492 -- Copy attributes
|
|
|
493
|
|
|
494 C_From (1 .. Name'Length) := Name;
|
|
|
495 C_From (C_From'Last) := ASCII.NUL;
|
|
|
496
|
|
|
497 C_To (1 .. To_Name'Length) := To_Name;
|
|
|
498 C_To (C_To'Last) := ASCII.NUL;
|
|
|
499
|
|
|
500 case Preserve is
|
|
|
501 when Time_Stamps =>
|
|
|
502 if Copy_Attributes (C_From'Address, C_To'Address, 0) = -1 then
|
|
|
503 raise Copy_Error;
|
|
|
504 end if;
|
|
|
505
|
|
|
506 when Full =>
|
|
|
507 if Copy_Attributes (C_From'Address, C_To'Address, 1) = -1 then
|
|
|
508 raise Copy_Error;
|
|
|
509 end if;
|
|
|
510
|
|
|
511 when None =>
|
|
|
512 null;
|
|
|
513 end case;
|
|
|
514 end Copy_To;
|
|
|
515
|
|
|
516 -- Start of processing for Copy_File
|
|
|
517
|
|
|
518 begin
|
|
|
519 Success := True;
|
|
|
520
|
|
|
521 -- The source file must exist
|
|
|
522
|
|
|
523 if not Is_Regular_File (Name) then
|
|
|
524 raise Copy_Error;
|
|
|
525 end if;
|
|
|
526
|
|
|
527 -- The source file exists
|
|
|
528
|
|
|
529 case Mode is
|
|
|
530
|
|
|
531 -- Copy case, target file must not exist
|
|
|
532
|
|
|
533 when Copy =>
|
|
|
534
|
|
|
535 -- If the target file exists, we have an error
|
|
|
536
|
|
|
537 if Is_Regular_File (Pathname) then
|
|
|
538 raise Copy_Error;
|
|
|
539
|
|
|
540 -- Case of target is a directory
|
|
|
541
|
|
|
542 elsif Is_Directory (Pathname) then
|
|
|
543 declare
|
|
|
544 Dest : constant String := Build_Path (Pathname, Name);
|
|
|
545
|
|
|
546 begin
|
|
|
547 -- If target file exists, we have an error, else do copy
|
|
|
548
|
|
|
549 if Is_Regular_File (Dest) then
|
|
|
550 raise Copy_Error;
|
|
|
551 else
|
|
|
552 Copy_To (Dest);
|
|
|
553 end if;
|
|
|
554 end;
|
|
|
555
|
|
|
556 -- Case of normal copy to file (destination does not exist)
|
|
|
557
|
|
|
558 else
|
|
|
559 Copy_To (Pathname);
|
|
|
560 end if;
|
|
|
561
|
|
|
562 -- Overwrite case (destination file may or may not exist)
|
|
|
563
|
|
|
564 when Overwrite =>
|
|
|
565 if Is_Directory (Pathname) then
|
|
|
566 Copy_To (Build_Path (Pathname, Name));
|
|
|
567 else
|
|
|
568 Copy_To (Pathname);
|
|
|
569 end if;
|
|
|
570
|
|
|
571 -- Append case (destination file may or may not exist)
|
|
|
572
|
|
|
573 when Append =>
|
|
|
574
|
|
|
575 -- Appending to existing file
|
|
|
576
|
|
|
577 if Is_Regular_File (Pathname) then
|
|
|
578
|
|
|
579 -- Append mode and destination file exists, append data at the
|
|
|
580 -- end of Pathname. But if we fail to open source file, do not
|
|
|
581 -- touch destination file at all.
|
|
|
582
|
|
|
583 From := Open_Read (Name, Binary);
|
|
|
584 if From /= Invalid_FD then
|
|
|
585 To := Open_Read_Write (Pathname, Binary);
|
|
|
586 end if;
|
|
|
587
|
|
|
588 Lseek (To, 0, Seek_End);
|
|
|
589
|
|
|
590 Copy (From, To);
|
|
|
591
|
|
|
592 -- Appending to directory, not allowed
|
|
|
593
|
|
|
594 elsif Is_Directory (Pathname) then
|
|
|
595 raise Copy_Error;
|
|
|
596
|
|
|
597 -- Appending when target file does not exist
|
|
|
598
|
|
|
599 else
|
|
|
600 Copy_To (Pathname);
|
|
|
601 end if;
|
|
|
602 end case;
|
|
|
603
|
|
|
604 -- All error cases are caught here
|
|
|
605
|
|
|
606 exception
|
|
|
607 when Copy_Error =>
|
|
|
608 Success := False;
|
|
|
609 end Copy_File;
|
|
|
610
|
|
|
611 procedure Copy_File
|
|
|
612 (Name : C_File_Name;
|
|
|
613 Pathname : C_File_Name;
|
|
|
614 Success : out Boolean;
|
|
|
615 Mode : Copy_Mode := Copy;
|
|
|
616 Preserve : Attribute := Time_Stamps)
|
|
|
617 is
|
|
|
618 Ada_Name : String_Access :=
|
|
|
619 To_Path_String_Access
|
|
|
620 (Name, C_String_Length (Name));
|
|
|
621 Ada_Pathname : String_Access :=
|
|
|
622 To_Path_String_Access
|
|
|
623 (Pathname, C_String_Length (Pathname));
|
|
|
624
|
|
|
625 begin
|
|
|
626 Copy_File (Ada_Name.all, Ada_Pathname.all, Success, Mode, Preserve);
|
|
|
627 Free (Ada_Name);
|
|
|
628 Free (Ada_Pathname);
|
|
|
629 end Copy_File;
|
|
|
630
|
|
|
631 --------------------------
|
|
|
632 -- Copy_File_Attributes --
|
|
|
633 --------------------------
|
|
|
634
|
|
|
635 procedure Copy_File_Attributes
|
|
|
636 (From : String;
|
|
|
637 To : String;
|
|
|
638 Success : out Boolean;
|
|
|
639 Copy_Timestamp : Boolean := True;
|
|
|
640 Copy_Permissions : Boolean := True)
|
|
|
641 is
|
|
|
642 F : aliased String (1 .. From'Length + 1);
|
|
|
643 T : aliased String (1 .. To'Length + 1);
|
|
|
644
|
|
|
645 Mode : Integer;
|
|
|
646
|
|
|
647 begin
|
|
|
648 if Copy_Timestamp then
|
|
|
649 if Copy_Permissions then
|
|
|
650 Mode := 1;
|
|
|
651 else
|
|
|
652 Mode := 0;
|
|
|
653 end if;
|
|
|
654 else
|
|
|
655 if Copy_Permissions then
|
|
|
656 Mode := 2;
|
|
|
657 else
|
|
|
658 Success := True;
|
|
|
659 return; -- nothing to do
|
|
|
660 end if;
|
|
|
661 end if;
|
|
|
662
|
|
|
663 F (1 .. From'Length) := From;
|
|
|
664 F (F'Last) := ASCII.NUL;
|
|
|
665
|
|
|
666 T (1 .. To'Length) := To;
|
|
|
667 T (T'Last) := ASCII.NUL;
|
|
|
668
|
|
|
669 Success := Copy_Attributes (F'Address, T'Address, Mode) /= -1;
|
|
|
670 end Copy_File_Attributes;
|
|
|
671
|
|
|
672 ----------------------
|
|
|
673 -- Copy_Time_Stamps --
|
|
|
674 ----------------------
|
|
|
675
|
|
|
676 procedure Copy_Time_Stamps
|
|
|
677 (Source : String;
|
|
|
678 Dest : String;
|
|
|
679 Success : out Boolean)
|
|
|
680 is
|
|
|
681 begin
|
|
|
682 if Is_Regular_File (Source) and then Is_Writable_File (Dest) then
|
|
|
683 declare
|
|
|
684 C_Source : String (1 .. Source'Length + 1);
|
|
|
685 C_Dest : String (1 .. Dest'Length + 1);
|
|
|
686
|
|
|
687 begin
|
|
|
688 C_Source (1 .. Source'Length) := Source;
|
|
|
689 C_Source (C_Source'Last) := ASCII.NUL;
|
|
|
690
|
|
|
691 C_Dest (1 .. Dest'Length) := Dest;
|
|
|
692 C_Dest (C_Dest'Last) := ASCII.NUL;
|
|
|
693
|
|
|
694 if Copy_Attributes (C_Source'Address, C_Dest'Address, 0) = -1 then
|
|
|
695 Success := False;
|
|
|
696 else
|
|
|
697 Success := True;
|
|
|
698 end if;
|
|
|
699 end;
|
|
|
700
|
|
|
701 else
|
|
|
702 Success := False;
|
|
|
703 end if;
|
|
|
704 end Copy_Time_Stamps;
|
|
|
705
|
|
|
706 procedure Copy_Time_Stamps
|
|
|
707 (Source : C_File_Name;
|
|
|
708 Dest : C_File_Name;
|
|
|
709 Success : out Boolean)
|
|
|
710 is
|
|
|
711 Ada_Source : String_Access :=
|
|
|
712 To_Path_String_Access
|
|
|
713 (Source, C_String_Length (Source));
|
|
|
714 Ada_Dest : String_Access :=
|
|
|
715 To_Path_String_Access
|
|
|
716 (Dest, C_String_Length (Dest));
|
|
|
717
|
|
|
718 begin
|
|
|
719 Copy_Time_Stamps (Ada_Source.all, Ada_Dest.all, Success);
|
|
|
720 Free (Ada_Source);
|
|
|
721 Free (Ada_Dest);
|
|
|
722 end Copy_Time_Stamps;
|
|
|
723
|
|
|
724 -----------------
|
|
|
725 -- Create_File --
|
|
|
726 -----------------
|
|
|
727
|
|
|
728 function Create_File
|
|
|
729 (Name : C_File_Name;
|
|
|
730 Fmode : Mode) return File_Descriptor
|
|
|
731 is
|
|
|
732 function C_Create_File
|
|
|
733 (Name : C_File_Name;
|
|
|
734 Fmode : Mode) return File_Descriptor;
|
|
|
735 pragma Import (C, C_Create_File, "__gnat_open_create");
|
|
|
736 begin
|
|
|
737 return C_Create_File (Name, Fmode);
|
|
|
738 end Create_File;
|
|
|
739
|
|
|
740 function Create_File
|
|
|
741 (Name : String;
|
|
|
742 Fmode : Mode) return File_Descriptor
|
|
|
743 is
|
|
|
744 C_Name : String (1 .. Name'Length + 1);
|
|
|
745 begin
|
|
|
746 C_Name (1 .. Name'Length) := Name;
|
|
|
747 C_Name (C_Name'Last) := ASCII.NUL;
|
|
|
748 return Create_File (C_Name (C_Name'First)'Address, Fmode);
|
|
|
749 end Create_File;
|
|
|
750
|
|
|
751 ---------------------
|
|
|
752 -- Create_New_File --
|
|
|
753 ---------------------
|
|
|
754
|
|
|
755 function Create_New_File
|
|
|
756 (Name : C_File_Name;
|
|
|
757 Fmode : Mode) return File_Descriptor
|
|
|
758 is
|
|
|
759 function C_Create_New_File
|
|
|
760 (Name : C_File_Name;
|
|
|
761 Fmode : Mode) return File_Descriptor;
|
|
|
762 pragma Import (C, C_Create_New_File, "__gnat_open_new");
|
|
|
763 begin
|
|
|
764 return C_Create_New_File (Name, Fmode);
|
|
|
765 end Create_New_File;
|
|
|
766
|
|
|
767 function Create_New_File
|
|
|
768 (Name : String;
|
|
|
769 Fmode : Mode) return File_Descriptor
|
|
|
770 is
|
|
|
771 C_Name : String (1 .. Name'Length + 1);
|
|
|
772 begin
|
|
|
773 C_Name (1 .. Name'Length) := Name;
|
|
|
774 C_Name (C_Name'Last) := ASCII.NUL;
|
|
|
775 return Create_New_File (C_Name (C_Name'First)'Address, Fmode);
|
|
|
776 end Create_New_File;
|
|
|
777
|
|
|
778 -----------------------------
|
|
|
779 -- Create_Output_Text_File --
|
|
|
780 -----------------------------
|
|
|
781
|
|
|
782 function Create_Output_Text_File (Name : String) return File_Descriptor is
|
|
|
783 function C_Create_File (Name : C_File_Name) return File_Descriptor;
|
|
|
784 pragma Import (C, C_Create_File, "__gnat_create_output_file");
|
|
|
785
|
|
|
786 C_Name : String (1 .. Name'Length + 1);
|
|
|
787
|
|
|
788 begin
|
|
|
789 C_Name (1 .. Name'Length) := Name;
|
|
|
790 C_Name (C_Name'Last) := ASCII.NUL;
|
|
|
791 return C_Create_File (C_Name (C_Name'First)'Address);
|
|
|
792 end Create_Output_Text_File;
|
|
|
793
|
|
|
794 ----------------------
|
|
|
795 -- Create_Temp_File --
|
|
|
796 ----------------------
|
|
|
797
|
|
|
798 procedure Create_Temp_File
|
|
|
799 (FD : out File_Descriptor;
|
|
|
800 Name : out Temp_File_Name)
|
|
|
801 is
|
|
|
802 function Open_New_Temp
|
|
|
803 (Name : System.Address;
|
|
|
804 Fmode : Mode) return File_Descriptor;
|
|
|
805 pragma Import (C, Open_New_Temp, "__gnat_open_new_temp");
|
|
|
806
|
|
|
807 begin
|
|
|
808 FD := Open_New_Temp (Name'Address, Binary);
|
|
|
809 end Create_Temp_File;
|
|
|
810
|
|
|
811 procedure Create_Temp_File
|
|
|
812 (FD : out File_Descriptor;
|
|
|
813 Name : out String_Access)
|
|
|
814 is
|
|
|
815 begin
|
|
|
816 Create_Temp_File_Internal (FD, Name, Stdout => False);
|
|
|
817 end Create_Temp_File;
|
|
|
818
|
|
|
819 -----------------------------
|
|
|
820 -- Create_Temp_Output_File --
|
|
|
821 -----------------------------
|
|
|
822
|
|
|
823 procedure Create_Temp_Output_File
|
|
|
824 (FD : out File_Descriptor;
|
|
|
825 Name : out String_Access)
|
|
|
826 is
|
|
|
827 begin
|
|
|
828 Create_Temp_File_Internal (FD, Name, Stdout => True);
|
|
|
829 end Create_Temp_Output_File;
|
|
|
830
|
|
|
831 -------------------------------
|
|
|
832 -- Create_Temp_File_Internal --
|
|
|
833 -------------------------------
|
|
|
834
|
|
|
835 procedure Create_Temp_File_Internal
|
|
|
836 (FD : out File_Descriptor;
|
|
|
837 Name : out String_Access;
|
|
|
838 Stdout : Boolean)
|
|
|
839 is
|
|
|
840 Pos : Positive;
|
|
|
841 Attempts : Natural := 0;
|
|
|
842 Current : String (Current_Temp_File_Name'Range);
|
|
|
843
|
|
|
844 function Create_New_Output_Text_File
|
|
|
845 (Name : String) return File_Descriptor;
|
|
|
846 -- Similar to Create_Output_Text_File, except it fails if the file
|
|
|
847 -- already exists. We need this behavior to ensure we don't accidentally
|
|
|
848 -- open a temp file that has just been created by a concurrently running
|
|
|
849 -- process. There is no point exposing this function, as it's generally
|
|
|
850 -- not particularly useful.
|
|
|
851
|
|
|
852 ---------------------------------
|
|
|
853 -- Create_New_Output_Text_File --
|
|
|
854 ---------------------------------
|
|
|
855
|
|
|
856 function Create_New_Output_Text_File
|
|
|
857 (Name : String) return File_Descriptor
|
|
|
858 is
|
|
|
859 function C_Create_File (Name : C_File_Name) return File_Descriptor;
|
|
|
860 pragma Import (C, C_Create_File, "__gnat_create_output_file_new");
|
|
|
861
|
|
|
862 C_Name : String (1 .. Name'Length + 1);
|
|
|
863
|
|
|
864 begin
|
|
|
865 C_Name (1 .. Name'Length) := Name;
|
|
|
866 C_Name (C_Name'Last) := ASCII.NUL;
|
|
|
867 return C_Create_File (C_Name (C_Name'First)'Address);
|
|
|
868 end Create_New_Output_Text_File;
|
|
|
869
|
|
|
870 -- Start of processing for Create_Temp_File_Internal
|
|
|
871
|
|
|
872 begin
|
|
|
873 -- Loop until a new temp file can be created
|
|
|
874
|
|
|
875 File_Loop : loop
|
|
|
876 Locked : begin
|
|
|
877
|
|
|
878 -- We need to protect global variable Current_Temp_File_Name
|
|
|
879 -- against concurrent access by different tasks.
|
|
|
880
|
|
|
881 SSL.Lock_Task.all;
|
|
|
882
|
|
|
883 -- Start at the last digit
|
|
|
884
|
|
|
885 Pos := Temp_File_Name_Last_Digit;
|
|
|
886
|
|
|
887 Digit_Loop :
|
|
|
888 loop
|
|
|
889 -- Increment the digit by one
|
|
|
890
|
|
|
891 case Current_Temp_File_Name (Pos) is
|
|
|
892 when '0' .. '8' =>
|
|
|
893 Current_Temp_File_Name (Pos) :=
|
|
|
894 Character'Succ (Current_Temp_File_Name (Pos));
|
|
|
895 exit Digit_Loop;
|
|
|
896
|
|
|
897 when '9' =>
|
|
|
898
|
|
|
899 -- For 9, set the digit to 0 and go to the previous digit
|
|
|
900
|
|
|
901 Current_Temp_File_Name (Pos) := '0';
|
|
|
902 Pos := Pos - 1;
|
|
|
903
|
|
|
904 when others =>
|
|
|
905
|
|
|
906 -- If it is not a digit, then there are no available
|
|
|
907 -- temp file names. Return Invalid_FD. There is almost no
|
|
|
908 -- chance that this code will be ever be executed, since
|
|
|
909 -- it would mean that there are one million temp files in
|
|
|
910 -- the same directory.
|
|
|
911
|
|
|
912 SSL.Unlock_Task.all;
|
|
|
913 FD := Invalid_FD;
|
|
|
914 Name := null;
|
|
|
915 exit File_Loop;
|
|
|
916 end case;
|
|
|
917 end loop Digit_Loop;
|
|
|
918
|
|
|
919 Current := Current_Temp_File_Name;
|
|
|
920
|
|
|
921 -- We can now release the lock, because we are no longer accessing
|
|
|
922 -- Current_Temp_File_Name.
|
|
|
923
|
|
|
924 SSL.Unlock_Task.all;
|
|
|
925
|
|
|
926 exception
|
|
|
927 when others =>
|
|
|
928 SSL.Unlock_Task.all;
|
|
|
929 raise;
|
|
|
930 end Locked;
|
|
|
931
|
|
|
932 -- Attempt to create the file
|
|
|
933
|
|
|
934 if Stdout then
|
|
|
935 FD := Create_New_Output_Text_File (Current);
|
|
|
936 else
|
|
|
937 FD := Create_New_File (Current, Binary);
|
|
|
938 end if;
|
|
|
939
|
|
|
940 if FD /= Invalid_FD then
|
|
|
941 Name := new String'(Current);
|
|
|
942 exit File_Loop;
|
|
|
943 end if;
|
|
|
944
|
|
|
945 if not Is_Regular_File (Current) then
|
|
|
946
|
|
|
947 -- If the file does not already exist and we are unable to create
|
|
|
948 -- it, we give up after Max_Attempts. Otherwise, we try again with
|
|
|
949 -- the next available file name.
|
|
|
950
|
|
|
951 Attempts := Attempts + 1;
|
|
|
952
|
|
|
953 if Attempts >= Max_Attempts then
|
|
|
954 FD := Invalid_FD;
|
|
|
955 Name := null;
|
|
|
956 exit File_Loop;
|
|
|
957 end if;
|
|
|
958 end if;
|
|
|
959 end loop File_Loop;
|
|
|
960 end Create_Temp_File_Internal;
|
|
|
961
|
|
|
962 -------------------------
|
|
|
963 -- Current_Time_String --
|
|
|
964 -------------------------
|
|
|
965
|
|
|
966 function Current_Time_String return String is
|
|
|
967 subtype S23 is String (1 .. 23);
|
|
|
968 -- Holds current time in ISO 8601 format YYYY-MM-DD HH:MM:SS.SS + NUL
|
|
|
969
|
|
|
970 procedure Current_Time_String (Time : System.Address);
|
|
|
971 pragma Import (C, Current_Time_String, "__gnat_current_time_string");
|
|
|
972 -- Puts current time into Time in above ISO 8601 format
|
|
|
973
|
|
|
974 Result23 : aliased S23;
|
|
|
975 -- Current time in ISO 8601 format
|
|
|
976
|
|
|
977 begin
|
|
|
978 Current_Time_String (Result23'Address);
|
|
|
979 return Result23 (1 .. 19);
|
|
|
980 end Current_Time_String;
|
|
|
981
|
|
|
982 -----------------
|
|
|
983 -- Delete_File --
|
|
|
984 -----------------
|
|
|
985
|
|
|
986 procedure Delete_File (Name : Address; Success : out Boolean) is
|
|
|
987 R : Integer;
|
|
|
988 begin
|
|
|
989 R := System.CRTL.unlink (Name);
|
|
|
990 Success := (R = 0);
|
|
|
991 end Delete_File;
|
|
|
992
|
|
|
993 procedure Delete_File (Name : String; Success : out Boolean) is
|
|
|
994 C_Name : String (1 .. Name'Length + 1);
|
|
|
995 begin
|
|
|
996 C_Name (1 .. Name'Length) := Name;
|
|
|
997 C_Name (C_Name'Last) := ASCII.NUL;
|
|
|
998 Delete_File (C_Name'Address, Success);
|
|
|
999 end Delete_File;
|
|
|
1000
|
|
|
1001 -------------------
|
|
|
1002 -- Errno_Message --
|
|
|
1003 -------------------
|
|
|
1004
|
|
|
1005 function Errno_Message
|
|
|
1006 (Err : Integer := Errno;
|
|
|
1007 Default : String := "") return String
|
|
|
1008 is
|
|
|
1009 function strerror (errnum : Integer) return System.Address;
|
|
|
1010 pragma Import (C, strerror, "strerror");
|
|
|
1011
|
|
|
1012 C_Msg : constant System.Address := strerror (Err);
|
|
|
1013
|
|
|
1014 begin
|
|
|
1015 if C_Msg = Null_Address then
|
|
|
1016 if Default /= "" then
|
|
|
1017 return Default;
|
|
|
1018
|
|
|
1019 else
|
|
|
1020 -- Note: for bootstrap reasons, it is impractical
|
|
|
1021 -- to use Integer'Image here.
|
|
|
1022
|
|
|
1023 declare
|
|
|
1024 Val : Integer;
|
|
|
1025 First : Integer;
|
|
|
1026
|
|
|
1027 Buf : String (1 .. 20);
|
|
|
1028 -- Buffer large enough to hold image of largest Integer values
|
|
|
1029
|
|
|
1030 begin
|
|
|
1031 Val := abs Err;
|
|
|
1032 First := Buf'Last;
|
|
|
1033 loop
|
|
|
1034 Buf (First) :=
|
|
|
1035 Character'Val (Character'Pos ('0') + Val mod 10);
|
|
|
1036 Val := Val / 10;
|
|
|
1037 exit when Val = 0;
|
|
|
1038 First := First - 1;
|
|
|
1039 end loop;
|
|
|
1040
|
|
|
1041 if Err < 0 then
|
|
|
1042 First := First - 1;
|
|
|
1043 Buf (First) := '-';
|
|
|
1044 end if;
|
|
|
1045
|
|
|
1046 return "errno = " & Buf (First .. Buf'Last);
|
|
|
1047 end;
|
|
|
1048 end if;
|
|
|
1049
|
|
|
1050 else
|
|
|
1051 declare
|
|
|
1052 Msg : String (1 .. Integer (CRTL.strlen (C_Msg)));
|
|
|
1053 for Msg'Address use C_Msg;
|
|
|
1054 pragma Import (Ada, Msg);
|
|
|
1055 begin
|
|
|
1056 return Msg;
|
|
|
1057 end;
|
|
|
1058 end if;
|
|
|
1059 end Errno_Message;
|
|
|
1060
|
|
|
1061 ---------------------
|
|
|
1062 -- File_Time_Stamp --
|
|
|
1063 ---------------------
|
|
|
1064
|
|
|
1065 function File_Time_Stamp (FD : File_Descriptor) return OS_Time is
|
|
|
1066 function File_Time (FD : File_Descriptor) return OS_Time;
|
|
|
1067 pragma Import (C, File_Time, "__gnat_file_time_fd");
|
|
|
1068 begin
|
|
|
1069 return File_Time (FD);
|
|
|
1070 end File_Time_Stamp;
|
|
|
1071
|
|
|
1072 function File_Time_Stamp (Name : C_File_Name) return OS_Time is
|
|
|
1073 function File_Time (Name : Address) return OS_Time;
|
|
|
1074 pragma Import (C, File_Time, "__gnat_file_time_name");
|
|
|
1075 begin
|
|
|
1076 return File_Time (Name);
|
|
|
1077 end File_Time_Stamp;
|
|
|
1078
|
|
|
1079 function File_Time_Stamp (Name : String) return OS_Time is
|
|
|
1080 F_Name : String (1 .. Name'Length + 1);
|
|
|
1081 begin
|
|
|
1082 F_Name (1 .. Name'Length) := Name;
|
|
|
1083 F_Name (F_Name'Last) := ASCII.NUL;
|
|
|
1084 return File_Time_Stamp (F_Name'Address);
|
|
|
1085 end File_Time_Stamp;
|
|
|
1086
|
|
|
1087 ---------------------------
|
|
|
1088 -- Get_Debuggable_Suffix --
|
|
|
1089 ---------------------------
|
|
|
1090
|
|
|
1091 function Get_Debuggable_Suffix return String_Access is
|
|
|
1092 procedure Get_Suffix_Ptr (Length, Ptr : Address);
|
|
|
1093 pragma Import (C, Get_Suffix_Ptr, "__gnat_get_debuggable_suffix_ptr");
|
|
|
1094
|
|
|
1095 Result : String_Access;
|
|
|
1096 Suffix_Length : Integer;
|
|
|
1097 Suffix_Ptr : Address;
|
|
|
1098
|
|
|
1099 begin
|
|
|
1100 Get_Suffix_Ptr (Suffix_Length'Address, Suffix_Ptr'Address);
|
|
|
1101 Result := new String (1 .. Suffix_Length);
|
|
|
1102
|
|
|
1103 if Suffix_Length > 0 then
|
|
|
1104 Strncpy (Result.all'Address, Suffix_Ptr, size_t (Suffix_Length));
|
|
|
1105 end if;
|
|
|
1106
|
|
|
1107 return Result;
|
|
|
1108 end Get_Debuggable_Suffix;
|
|
|
1109
|
|
|
1110 ---------------------------
|
|
|
1111 -- Get_Executable_Suffix --
|
|
|
1112 ---------------------------
|
|
|
1113
|
|
|
1114 function Get_Executable_Suffix return String_Access is
|
|
|
1115 procedure Get_Suffix_Ptr (Length, Ptr : Address);
|
|
|
1116 pragma Import (C, Get_Suffix_Ptr, "__gnat_get_executable_suffix_ptr");
|
|
|
1117
|
|
|
1118 Result : String_Access;
|
|
|
1119 Suffix_Length : Integer;
|
|
|
1120 Suffix_Ptr : Address;
|
|
|
1121
|
|
|
1122 begin
|
|
|
1123 Get_Suffix_Ptr (Suffix_Length'Address, Suffix_Ptr'Address);
|
|
|
1124 Result := new String (1 .. Suffix_Length);
|
|
|
1125
|
|
|
1126 if Suffix_Length > 0 then
|
|
|
1127 Strncpy (Result.all'Address, Suffix_Ptr, size_t (Suffix_Length));
|
|
|
1128 end if;
|
|
|
1129
|
|
|
1130 return Result;
|
|
|
1131 end Get_Executable_Suffix;
|
|
|
1132
|
|
|
1133 -----------------------
|
|
|
1134 -- Get_Object_Suffix --
|
|
|
1135 -----------------------
|
|
|
1136
|
|
|
1137 function Get_Object_Suffix return String_Access is
|
|
|
1138 procedure Get_Suffix_Ptr (Length, Ptr : Address);
|
|
|
1139 pragma Import (C, Get_Suffix_Ptr, "__gnat_get_object_suffix_ptr");
|
|
|
1140
|
|
|
1141 Result : String_Access;
|
|
|
1142 Suffix_Length : Integer;
|
|
|
1143 Suffix_Ptr : Address;
|
|
|
1144
|
|
|
1145 begin
|
|
|
1146 Get_Suffix_Ptr (Suffix_Length'Address, Suffix_Ptr'Address);
|
|
|
1147 Result := new String (1 .. Suffix_Length);
|
|
|
1148
|
|
|
1149 if Suffix_Length > 0 then
|
|
|
1150 Strncpy (Result.all'Address, Suffix_Ptr, size_t (Suffix_Length));
|
|
|
1151 end if;
|
|
|
1152
|
|
|
1153 return Result;
|
|
|
1154 end Get_Object_Suffix;
|
|
|
1155
|
|
|
1156 ----------------------------------
|
|
|
1157 -- Get_Target_Debuggable_Suffix --
|
|
|
1158 ----------------------------------
|
|
|
1159
|
|
|
1160 function Get_Target_Debuggable_Suffix return String_Access is
|
|
|
1161 Target_Exec_Ext_Ptr : Address;
|
|
|
1162 pragma Import
|
|
|
1163 (C, Target_Exec_Ext_Ptr, "__gnat_target_debuggable_extension");
|
|
|
1164
|
|
|
1165 Result : String_Access;
|
|
|
1166 Suffix_Length : Integer;
|
|
|
1167
|
|
|
1168 begin
|
|
|
1169 Suffix_Length := Integer (CRTL.strlen (Target_Exec_Ext_Ptr));
|
|
|
1170 Result := new String (1 .. Suffix_Length);
|
|
|
1171
|
|
|
1172 if Suffix_Length > 0 then
|
|
|
1173 Strncpy
|
|
|
1174 (Result.all'Address, Target_Exec_Ext_Ptr, size_t (Suffix_Length));
|
|
|
1175 end if;
|
|
|
1176
|
|
|
1177 return Result;
|
|
|
1178 end Get_Target_Debuggable_Suffix;
|
|
|
1179
|
|
|
1180 ----------------------------------
|
|
|
1181 -- Get_Target_Executable_Suffix --
|
|
|
1182 ----------------------------------
|
|
|
1183
|
|
|
1184 function Get_Target_Executable_Suffix return String_Access is
|
|
|
1185 Target_Exec_Ext_Ptr : Address;
|
|
|
1186 pragma Import
|
|
|
1187 (C, Target_Exec_Ext_Ptr, "__gnat_target_executable_extension");
|
|
|
1188
|
|
|
1189 Result : String_Access;
|
|
|
1190 Suffix_Length : Integer;
|
|
|
1191
|
|
|
1192 begin
|
|
|
1193 Suffix_Length := Integer (CRTL.strlen (Target_Exec_Ext_Ptr));
|
|
|
1194 Result := new String (1 .. Suffix_Length);
|
|
|
1195
|
|
|
1196 if Suffix_Length > 0 then
|
|
|
1197 Strncpy
|
|
|
1198 (Result.all'Address, Target_Exec_Ext_Ptr, size_t (Suffix_Length));
|
|
|
1199 end if;
|
|
|
1200
|
|
|
1201 return Result;
|
|
|
1202 end Get_Target_Executable_Suffix;
|
|
|
1203
|
|
|
1204 ------------------------------
|
|
|
1205 -- Get_Target_Object_Suffix --
|
|
|
1206 ------------------------------
|
|
|
1207
|
|
|
1208 function Get_Target_Object_Suffix return String_Access is
|
|
|
1209 Target_Object_Ext_Ptr : Address;
|
|
|
1210 pragma Import
|
|
|
1211 (C, Target_Object_Ext_Ptr, "__gnat_target_object_extension");
|
|
|
1212
|
|
|
1213 Result : String_Access;
|
|
|
1214 Suffix_Length : Integer;
|
|
|
1215
|
|
|
1216 begin
|
|
|
1217 Suffix_Length := Integer (CRTL.strlen (Target_Object_Ext_Ptr));
|
|
|
1218 Result := new String (1 .. Suffix_Length);
|
|
|
1219
|
|
|
1220 if Suffix_Length > 0 then
|
|
|
1221 Strncpy
|
|
|
1222 (Result.all'Address, Target_Object_Ext_Ptr, size_t (Suffix_Length));
|
|
|
1223 end if;
|
|
|
1224
|
|
|
1225 return Result;
|
|
|
1226 end Get_Target_Object_Suffix;
|
|
|
1227
|
|
|
1228 ------------
|
|
|
1229 -- Getenv --
|
|
|
1230 ------------
|
|
|
1231
|
|
|
1232 function Getenv (Name : String) return String_Access is
|
|
|
1233 procedure Get_Env_Value_Ptr (Name, Length, Ptr : Address);
|
|
|
1234 pragma Import (C, Get_Env_Value_Ptr, "__gnat_getenv");
|
|
|
1235
|
|
|
1236 Env_Value_Ptr : aliased Address;
|
|
|
1237 Env_Value_Length : aliased Integer;
|
|
|
1238 F_Name : aliased String (1 .. Name'Length + 1);
|
|
|
1239 Result : String_Access;
|
|
|
1240
|
|
|
1241 begin
|
|
|
1242 F_Name (1 .. Name'Length) := Name;
|
|
|
1243 F_Name (F_Name'Last) := ASCII.NUL;
|
|
|
1244
|
|
|
1245 Get_Env_Value_Ptr
|
|
|
1246 (F_Name'Address, Env_Value_Length'Address, Env_Value_Ptr'Address);
|
|
|
1247
|
|
|
1248 Result := new String (1 .. Env_Value_Length);
|
|
|
1249
|
|
|
1250 if Env_Value_Length > 0 then
|
|
|
1251 Strncpy
|
|
|
1252 (Result.all'Address, Env_Value_Ptr, size_t (Env_Value_Length));
|
|
|
1253 end if;
|
|
|
1254
|
|
|
1255 return Result;
|
|
|
1256 end Getenv;
|
|
|
1257
|
|
|
1258 ------------
|
|
|
1259 -- GM_Day --
|
|
|
1260 ------------
|
|
|
1261
|
|
|
1262 function GM_Day (Date : OS_Time) return Day_Type is
|
|
|
1263 D : Day_Type;
|
|
|
1264
|
|
|
1265 Y : Year_Type;
|
|
|
1266 Mo : Month_Type;
|
|
|
1267 H : Hour_Type;
|
|
|
1268 Mn : Minute_Type;
|
|
|
1269 S : Second_Type;
|
|
|
1270 pragma Unreferenced (Y, Mo, H, Mn, S);
|
|
|
1271
|
|
|
1272 begin
|
|
|
1273 GM_Split (Date, Y, Mo, D, H, Mn, S);
|
|
|
1274 return D;
|
|
|
1275 end GM_Day;
|
|
|
1276
|
|
|
1277 -------------
|
|
|
1278 -- GM_Hour --
|
|
|
1279 -------------
|
|
|
1280
|
|
|
1281 function GM_Hour (Date : OS_Time) return Hour_Type is
|
|
|
1282 H : Hour_Type;
|
|
|
1283
|
|
|
1284 Y : Year_Type;
|
|
|
1285 Mo : Month_Type;
|
|
|
1286 D : Day_Type;
|
|
|
1287 Mn : Minute_Type;
|
|
|
1288 S : Second_Type;
|
|
|
1289 pragma Unreferenced (Y, Mo, D, Mn, S);
|
|
|
1290
|
|
|
1291 begin
|
|
|
1292 GM_Split (Date, Y, Mo, D, H, Mn, S);
|
|
|
1293 return H;
|
|
|
1294 end GM_Hour;
|
|
|
1295
|
|
|
1296 ---------------
|
|
|
1297 -- GM_Minute --
|
|
|
1298 ---------------
|
|
|
1299
|
|
|
1300 function GM_Minute (Date : OS_Time) return Minute_Type is
|
|
|
1301 Mn : Minute_Type;
|
|
|
1302
|
|
|
1303 Y : Year_Type;
|
|
|
1304 Mo : Month_Type;
|
|
|
1305 D : Day_Type;
|
|
|
1306 H : Hour_Type;
|
|
|
1307 S : Second_Type;
|
|
|
1308 pragma Unreferenced (Y, Mo, D, H, S);
|
|
|
1309
|
|
|
1310 begin
|
|
|
1311 GM_Split (Date, Y, Mo, D, H, Mn, S);
|
|
|
1312 return Mn;
|
|
|
1313 end GM_Minute;
|
|
|
1314
|
|
|
1315 --------------
|
|
|
1316 -- GM_Month --
|
|
|
1317 --------------
|
|
|
1318
|
|
|
1319 function GM_Month (Date : OS_Time) return Month_Type is
|
|
|
1320 Mo : Month_Type;
|
|
|
1321
|
|
|
1322 Y : Year_Type;
|
|
|
1323 D : Day_Type;
|
|
|
1324 H : Hour_Type;
|
|
|
1325 Mn : Minute_Type;
|
|
|
1326 S : Second_Type;
|
|
|
1327 pragma Unreferenced (Y, D, H, Mn, S);
|
|
|
1328
|
|
|
1329 begin
|
|
|
1330 GM_Split (Date, Y, Mo, D, H, Mn, S);
|
|
|
1331 return Mo;
|
|
|
1332 end GM_Month;
|
|
|
1333
|
|
|
1334 ---------------
|
|
|
1335 -- GM_Second --
|
|
|
1336 ---------------
|
|
|
1337
|
|
|
1338 function GM_Second (Date : OS_Time) return Second_Type is
|
|
|
1339 S : Second_Type;
|
|
|
1340
|
|
|
1341 Y : Year_Type;
|
|
|
1342 Mo : Month_Type;
|
|
|
1343 D : Day_Type;
|
|
|
1344 H : Hour_Type;
|
|
|
1345 Mn : Minute_Type;
|
|
|
1346 pragma Unreferenced (Y, Mo, D, H, Mn);
|
|
|
1347
|
|
|
1348 begin
|
|
|
1349 GM_Split (Date, Y, Mo, D, H, Mn, S);
|
|
|
1350 return S;
|
|
|
1351 end GM_Second;
|
|
|
1352
|
|
|
1353 --------------
|
|
|
1354 -- GM_Split --
|
|
|
1355 --------------
|
|
|
1356
|
|
|
1357 procedure GM_Split
|
|
|
1358 (Date : OS_Time;
|
|
|
1359 Year : out Year_Type;
|
|
|
1360 Month : out Month_Type;
|
|
|
1361 Day : out Day_Type;
|
|
|
1362 Hour : out Hour_Type;
|
|
|
1363 Minute : out Minute_Type;
|
|
|
1364 Second : out Second_Type)
|
|
|
1365 is
|
|
|
1366 procedure To_GM_Time
|
|
|
1367 (P_Time_T : Address;
|
|
|
1368 P_Year : Address;
|
|
|
1369 P_Month : Address;
|
|
|
1370 P_Day : Address;
|
|
|
1371 P_Hours : Address;
|
|
|
1372 P_Mins : Address;
|
|
|
1373 P_Secs : Address);
|
|
|
1374 pragma Import (C, To_GM_Time, "__gnat_to_gm_time");
|
|
|
1375
|
|
|
1376 T : OS_Time := Date;
|
|
|
1377 Y : Integer;
|
|
|
1378 Mo : Integer;
|
|
|
1379 D : Integer;
|
|
|
1380 H : Integer;
|
|
|
1381 Mn : Integer;
|
|
|
1382 S : Integer;
|
|
|
1383
|
|
|
1384 begin
|
|
|
1385 -- Use the global lock because To_GM_Time is not thread safe
|
|
|
1386
|
|
|
1387 Locked_Processing : begin
|
|
|
1388 SSL.Lock_Task.all;
|
|
|
1389 To_GM_Time
|
|
|
1390 (P_Time_T => T'Address,
|
|
|
1391 P_Year => Y'Address,
|
|
|
1392 P_Month => Mo'Address,
|
|
|
1393 P_Day => D'Address,
|
|
|
1394 P_Hours => H'Address,
|
|
|
1395 P_Mins => Mn'Address,
|
|
|
1396 P_Secs => S'Address);
|
|
|
1397 SSL.Unlock_Task.all;
|
|
|
1398
|
|
|
1399 exception
|
|
|
1400 when others =>
|
|
|
1401 SSL.Unlock_Task.all;
|
|
|
1402 raise;
|
|
|
1403 end Locked_Processing;
|
|
|
1404
|
|
|
1405 Year := Y + 1900;
|
|
|
1406 Month := Mo + 1;
|
|
|
1407 Day := D;
|
|
|
1408 Hour := H;
|
|
|
1409 Minute := Mn;
|
|
|
1410 Second := S;
|
|
|
1411 end GM_Split;
|
|
|
1412
|
|
|
1413 ----------------
|
|
|
1414 -- GM_Time_Of --
|
|
|
1415 ----------------
|
|
|
1416
|
|
|
1417 function GM_Time_Of
|
|
|
1418 (Year : Year_Type;
|
|
|
1419 Month : Month_Type;
|
|
|
1420 Day : Day_Type;
|
|
|
1421 Hour : Hour_Type;
|
|
|
1422 Minute : Minute_Type;
|
|
|
1423 Second : Second_Type) return OS_Time
|
|
|
1424 is
|
|
|
1425 procedure To_OS_Time
|
|
|
1426 (P_Time_T : Address;
|
|
|
1427 P_Year : Integer;
|
|
|
1428 P_Month : Integer;
|
|
|
1429 P_Day : Integer;
|
|
|
1430 P_Hours : Integer;
|
|
|
1431 P_Mins : Integer;
|
|
|
1432 P_Secs : Integer);
|
|
|
1433 pragma Import (C, To_OS_Time, "__gnat_to_os_time");
|
|
|
1434
|
|
|
1435 Result : OS_Time;
|
|
|
1436
|
|
|
1437 begin
|
|
|
1438 To_OS_Time
|
|
|
1439 (P_Time_T => Result'Address,
|
|
|
1440 P_Year => Year - 1900,
|
|
|
1441 P_Month => Month - 1,
|
|
|
1442 P_Day => Day,
|
|
|
1443 P_Hours => Hour,
|
|
|
1444 P_Mins => Minute,
|
|
|
1445 P_Secs => Second);
|
|
|
1446 return Result;
|
|
|
1447 end GM_Time_Of;
|
|
|
1448
|
|
|
1449 -------------
|
|
|
1450 -- GM_Year --
|
|
|
1451 -------------
|
|
|
1452
|
|
|
1453 function GM_Year (Date : OS_Time) return Year_Type is
|
|
|
1454 Y : Year_Type;
|
|
|
1455
|
|
|
1456 Mo : Month_Type;
|
|
|
1457 D : Day_Type;
|
|
|
1458 H : Hour_Type;
|
|
|
1459 Mn : Minute_Type;
|
|
|
1460 S : Second_Type;
|
|
|
1461 pragma Unreferenced (Mo, D, H, Mn, S);
|
|
|
1462
|
|
|
1463 begin
|
|
|
1464 GM_Split (Date, Y, Mo, D, H, Mn, S);
|
|
|
1465 return Y;
|
|
|
1466 end GM_Year;
|
|
|
1467
|
|
|
1468 ----------------------
|
|
|
1469 -- Is_Absolute_Path --
|
|
|
1470 ----------------------
|
|
|
1471
|
|
|
1472 function Is_Absolute_Path (Name : String) return Boolean is
|
|
|
1473 function Is_Absolute_Path
|
|
|
1474 (Name : Address;
|
|
|
1475 Length : Integer) return Integer;
|
|
|
1476 pragma Import (C, Is_Absolute_Path, "__gnat_is_absolute_path");
|
|
|
1477 begin
|
|
|
1478 return Is_Absolute_Path (Name'Address, Name'Length) /= 0;
|
|
|
1479 end Is_Absolute_Path;
|
|
|
1480
|
|
|
1481 ------------------
|
|
|
1482 -- Is_Directory --
|
|
|
1483 ------------------
|
|
|
1484
|
|
|
1485 function Is_Directory (Name : C_File_Name) return Boolean is
|
|
|
1486 function Is_Directory (Name : Address) return Integer;
|
|
|
1487 pragma Import (C, Is_Directory, "__gnat_is_directory");
|
|
|
1488 begin
|
|
|
1489 return Is_Directory (Name) /= 0;
|
|
|
1490 end Is_Directory;
|
|
|
1491
|
|
|
1492 function Is_Directory (Name : String) return Boolean is
|
|
|
1493 F_Name : String (1 .. Name'Length + 1);
|
|
|
1494 begin
|
|
|
1495 F_Name (1 .. Name'Length) := Name;
|
|
|
1496 F_Name (F_Name'Last) := ASCII.NUL;
|
|
|
1497 return Is_Directory (F_Name'Address);
|
|
|
1498 end Is_Directory;
|
|
|
1499
|
|
|
1500 -----------------------------
|
|
|
1501 -- Is_Read_Accessible_File --
|
|
|
1502 -----------------------------
|
|
|
1503
|
|
|
1504 function Is_Read_Accessible_File (Name : String) return Boolean is
|
|
|
1505 function Is_Read_Accessible_File (Name : Address) return Integer;
|
|
|
1506 pragma Import
|
|
|
1507 (C, Is_Read_Accessible_File, "__gnat_is_read_accessible_file");
|
|
|
1508 F_Name : String (1 .. Name'Length + 1);
|
|
|
1509
|
|
|
1510 begin
|
|
|
1511 F_Name (1 .. Name'Length) := Name;
|
|
|
1512 F_Name (F_Name'Last) := ASCII.NUL;
|
|
|
1513 return Is_Read_Accessible_File (F_Name'Address) /= 0;
|
|
|
1514 end Is_Read_Accessible_File;
|
|
|
1515
|
|
|
1516 ----------------------------
|
|
|
1517 -- Is_Owner_Readable_File --
|
|
|
1518 ----------------------------
|
|
|
1519
|
|
|
1520 function Is_Owner_Readable_File (Name : C_File_Name) return Boolean is
|
|
|
1521 function Is_Readable_File (Name : Address) return Integer;
|
|
|
1522 pragma Import (C, Is_Readable_File, "__gnat_is_readable_file");
|
|
|
1523 begin
|
|
|
1524 return Is_Readable_File (Name) /= 0;
|
|
|
1525 end Is_Owner_Readable_File;
|
|
|
1526
|
|
|
1527 function Is_Owner_Readable_File (Name : String) return Boolean is
|
|
|
1528 F_Name : String (1 .. Name'Length + 1);
|
|
|
1529 begin
|
|
|
1530 F_Name (1 .. Name'Length) := Name;
|
|
|
1531 F_Name (F_Name'Last) := ASCII.NUL;
|
|
|
1532 return Is_Owner_Readable_File (F_Name'Address);
|
|
|
1533 end Is_Owner_Readable_File;
|
|
|
1534
|
|
|
1535 ------------------------
|
|
|
1536 -- Is_Executable_File --
|
|
|
1537 ------------------------
|
|
|
1538
|
|
|
1539 function Is_Executable_File (Name : C_File_Name) return Boolean is
|
|
|
1540 function Is_Executable_File (Name : Address) return Integer;
|
|
|
1541 pragma Import (C, Is_Executable_File, "__gnat_is_executable_file");
|
|
|
1542 begin
|
|
|
1543 return Is_Executable_File (Name) /= 0;
|
|
|
1544 end Is_Executable_File;
|
|
|
1545
|
|
|
1546 function Is_Executable_File (Name : String) return Boolean is
|
|
|
1547 F_Name : String (1 .. Name'Length + 1);
|
|
|
1548 begin
|
|
|
1549 F_Name (1 .. Name'Length) := Name;
|
|
|
1550 F_Name (F_Name'Last) := ASCII.NUL;
|
|
|
1551 return Is_Executable_File (F_Name'Address);
|
|
|
1552 end Is_Executable_File;
|
|
|
1553
|
|
|
1554 ---------------------
|
|
|
1555 -- Is_Regular_File --
|
|
|
1556 ---------------------
|
|
|
1557
|
|
|
1558 function Is_Regular_File (Name : C_File_Name) return Boolean is
|
|
|
1559 function Is_Regular_File (Name : Address) return Integer;
|
|
|
1560 pragma Import (C, Is_Regular_File, "__gnat_is_regular_file");
|
|
|
1561 begin
|
|
|
1562 return Is_Regular_File (Name) /= 0;
|
|
|
1563 end Is_Regular_File;
|
|
|
1564
|
|
|
1565 function Is_Regular_File (Name : String) return Boolean is
|
|
|
1566 F_Name : String (1 .. Name'Length + 1);
|
|
|
1567 begin
|
|
|
1568 F_Name (1 .. Name'Length) := Name;
|
|
|
1569 F_Name (F_Name'Last) := ASCII.NUL;
|
|
|
1570 return Is_Regular_File (F_Name'Address);
|
|
|
1571 end Is_Regular_File;
|
|
|
1572
|
|
|
1573 ----------------------
|
|
|
1574 -- Is_Symbolic_Link --
|
|
|
1575 ----------------------
|
|
|
1576
|
|
|
1577 function Is_Symbolic_Link (Name : C_File_Name) return Boolean is
|
|
|
1578 function Is_Symbolic_Link (Name : Address) return Integer;
|
|
|
1579 pragma Import (C, Is_Symbolic_Link, "__gnat_is_symbolic_link");
|
|
|
1580 begin
|
|
|
1581 return Is_Symbolic_Link (Name) /= 0;
|
|
|
1582 end Is_Symbolic_Link;
|
|
|
1583
|
|
|
1584 function Is_Symbolic_Link (Name : String) return Boolean is
|
|
|
1585 F_Name : String (1 .. Name'Length + 1);
|
|
|
1586 begin
|
|
|
1587 F_Name (1 .. Name'Length) := Name;
|
|
|
1588 F_Name (F_Name'Last) := ASCII.NUL;
|
|
|
1589 return Is_Symbolic_Link (F_Name'Address);
|
|
|
1590 end Is_Symbolic_Link;
|
|
|
1591
|
|
|
1592 ------------------------------
|
|
|
1593 -- Is_Write_Accessible_File --
|
|
|
1594 ------------------------------
|
|
|
1595
|
|
|
1596 function Is_Write_Accessible_File (Name : String) return Boolean is
|
|
|
1597 function Is_Write_Accessible_File (Name : Address) return Integer;
|
|
|
1598 pragma Import
|
|
|
1599 (C, Is_Write_Accessible_File, "__gnat_is_write_accessible_file");
|
|
|
1600 F_Name : String (1 .. Name'Length + 1);
|
|
|
1601
|
|
|
1602 begin
|
|
|
1603 F_Name (1 .. Name'Length) := Name;
|
|
|
1604 F_Name (F_Name'Last) := ASCII.NUL;
|
|
|
1605 return Is_Write_Accessible_File (F_Name'Address) /= 0;
|
|
|
1606 end Is_Write_Accessible_File;
|
|
|
1607
|
|
|
1608 ----------------------------
|
|
|
1609 -- Is_Owner_Writable_File --
|
|
|
1610 ----------------------------
|
|
|
1611
|
|
|
1612 function Is_Owner_Writable_File (Name : C_File_Name) return Boolean is
|
|
|
1613 function Is_Writable_File (Name : Address) return Integer;
|
|
|
1614 pragma Import (C, Is_Writable_File, "__gnat_is_writable_file");
|
|
|
1615 begin
|
|
|
1616 return Is_Writable_File (Name) /= 0;
|
|
|
1617 end Is_Owner_Writable_File;
|
|
|
1618
|
|
|
1619 function Is_Owner_Writable_File (Name : String) return Boolean is
|
|
|
1620 F_Name : String (1 .. Name'Length + 1);
|
|
|
1621 begin
|
|
|
1622 F_Name (1 .. Name'Length) := Name;
|
|
|
1623 F_Name (F_Name'Last) := ASCII.NUL;
|
|
|
1624 return Is_Owner_Writable_File (F_Name'Address);
|
|
|
1625 end Is_Owner_Writable_File;
|
|
|
1626
|
|
|
1627 ----------
|
|
|
1628 -- Kill --
|
|
|
1629 ----------
|
|
|
1630
|
|
|
1631 procedure Kill (Pid : Process_Id; Hard_Kill : Boolean := True) is
|
|
|
1632 SIGKILL : constant := 9;
|
|
|
1633 SIGINT : constant := 2;
|
|
|
1634
|
|
|
1635 procedure C_Kill (Pid : Process_Id; Sig_Num : Integer; Close : Integer);
|
|
|
1636 pragma Import (C, C_Kill, "__gnat_kill");
|
|
|
1637
|
|
|
1638 begin
|
|
|
1639 if Hard_Kill then
|
|
|
1640 C_Kill (Pid, SIGKILL, 1);
|
|
|
1641 else
|
|
|
1642 C_Kill (Pid, SIGINT, 1);
|
|
|
1643 end if;
|
|
|
1644 end Kill;
|
|
|
1645
|
|
|
1646 -----------------------
|
|
|
1647 -- Kill_Process_Tree --
|
|
|
1648 -----------------------
|
|
|
1649
|
|
|
1650 procedure Kill_Process_Tree
|
|
|
1651 (Pid : Process_Id; Hard_Kill : Boolean := True)
|
|
|
1652 is
|
|
|
1653 SIGKILL : constant := 9;
|
|
|
1654 SIGINT : constant := 2;
|
|
|
1655
|
|
|
1656 procedure C_Kill_PT (Pid : Process_Id; Sig_Num : Integer);
|
|
|
1657 pragma Import (C, C_Kill_PT, "__gnat_killprocesstree");
|
|
|
1658
|
|
|
1659 begin
|
|
|
1660 if Hard_Kill then
|
|
|
1661 C_Kill_PT (Pid, SIGKILL);
|
|
|
1662 else
|
|
|
1663 C_Kill_PT (Pid, SIGINT);
|
|
|
1664 end if;
|
|
|
1665 end Kill_Process_Tree;
|
|
|
1666
|
|
|
1667 -------------------------
|
|
|
1668 -- Locate_Exec_On_Path --
|
|
|
1669 -------------------------
|
|
|
1670
|
|
|
1671 function Locate_Exec_On_Path
|
|
|
1672 (Exec_Name : String) return String_Access
|
|
|
1673 is
|
|
|
1674 function Locate_Exec_On_Path (C_Exec_Name : Address) return Address;
|
|
|
1675 pragma Import (C, Locate_Exec_On_Path, "__gnat_locate_exec_on_path");
|
|
|
1676
|
|
|
1677 C_Exec_Name : String (1 .. Exec_Name'Length + 1);
|
|
|
1678 Path_Addr : Address;
|
|
|
1679 Path_Len : Integer;
|
|
|
1680 Result : String_Access;
|
|
|
1681
|
|
|
1682 begin
|
|
|
1683 C_Exec_Name (1 .. Exec_Name'Length) := Exec_Name;
|
|
|
1684 C_Exec_Name (C_Exec_Name'Last) := ASCII.NUL;
|
|
|
1685
|
|
|
1686 Path_Addr := Locate_Exec_On_Path (C_Exec_Name'Address);
|
|
|
1687 Path_Len := C_String_Length (Path_Addr);
|
|
|
1688
|
|
|
1689 if Path_Len = 0 then
|
|
|
1690 return null;
|
|
|
1691
|
|
|
1692 else
|
|
|
1693 Result := To_Path_String_Access (Path_Addr, Path_Len);
|
|
|
1694 CRTL.free (Path_Addr);
|
|
|
1695
|
|
|
1696 -- Always return an absolute path name
|
|
|
1697
|
|
|
1698 if not Is_Absolute_Path (Result.all) then
|
|
|
1699 declare
|
|
|
1700 Absolute_Path : constant String :=
|
|
|
1701 Normalize_Pathname (Result.all, Resolve_Links => False);
|
|
|
1702 begin
|
|
|
1703 Free (Result);
|
|
|
1704 Result := new String'(Absolute_Path);
|
|
|
1705 end;
|
|
|
1706 end if;
|
|
|
1707
|
|
|
1708 return Result;
|
|
|
1709 end if;
|
|
|
1710 end Locate_Exec_On_Path;
|
|
|
1711
|
|
|
1712 -------------------------
|
|
|
1713 -- Locate_Regular_File --
|
|
|
1714 -------------------------
|
|
|
1715
|
|
|
1716 function Locate_Regular_File
|
|
|
1717 (File_Name : C_File_Name;
|
|
|
1718 Path : C_File_Name) return String_Access
|
|
|
1719 is
|
|
|
1720 function Locate_Regular_File
|
|
|
1721 (C_File_Name, Path_Val : Address) return Address;
|
|
|
1722 pragma Import (C, Locate_Regular_File, "__gnat_locate_regular_file");
|
|
|
1723
|
|
|
1724 Path_Addr : Address;
|
|
|
1725 Path_Len : Integer;
|
|
|
1726 Result : String_Access;
|
|
|
1727
|
|
|
1728 begin
|
|
|
1729 Path_Addr := Locate_Regular_File (File_Name, Path);
|
|
|
1730 Path_Len := C_String_Length (Path_Addr);
|
|
|
1731
|
|
|
1732 if Path_Len = 0 then
|
|
|
1733 return null;
|
|
|
1734
|
|
|
1735 else
|
|
|
1736 Result := To_Path_String_Access (Path_Addr, Path_Len);
|
|
|
1737 CRTL.free (Path_Addr);
|
|
|
1738 return Result;
|
|
|
1739 end if;
|
|
|
1740 end Locate_Regular_File;
|
|
|
1741
|
|
|
1742 function Locate_Regular_File
|
|
|
1743 (File_Name : String;
|
|
|
1744 Path : String) return String_Access
|
|
|
1745 is
|
|
|
1746 C_File_Name : String (1 .. File_Name'Length + 1);
|
|
|
1747 C_Path : String (1 .. Path'Length + 1);
|
|
|
1748 Result : String_Access;
|
|
|
1749
|
|
|
1750 begin
|
|
|
1751 C_File_Name (1 .. File_Name'Length) := File_Name;
|
|
|
1752 C_File_Name (C_File_Name'Last) := ASCII.NUL;
|
|
|
1753
|
|
|
1754 C_Path (1 .. Path'Length) := Path;
|
|
|
1755 C_Path (C_Path'Last) := ASCII.NUL;
|
|
|
1756
|
|
|
1757 Result := Locate_Regular_File (C_File_Name'Address, C_Path'Address);
|
|
|
1758
|
|
|
1759 -- Always return an absolute path name
|
|
|
1760
|
|
|
1761 if Result /= null and then not Is_Absolute_Path (Result.all) then
|
|
|
1762 declare
|
|
|
1763 Absolute_Path : constant String := Normalize_Pathname (Result.all);
|
|
|
1764 begin
|
|
|
1765 Free (Result);
|
|
|
1766 Result := new String'(Absolute_Path);
|
|
|
1767 end;
|
|
|
1768 end if;
|
|
|
1769
|
|
|
1770 return Result;
|
|
|
1771 end Locate_Regular_File;
|
|
|
1772
|
|
|
1773 ------------------------
|
|
|
1774 -- Non_Blocking_Spawn --
|
|
|
1775 ------------------------
|
|
|
1776
|
|
|
1777 function Non_Blocking_Spawn
|
|
|
1778 (Program_Name : String;
|
|
|
1779 Args : Argument_List) return Process_Id
|
|
|
1780 is
|
|
|
1781 Junk : Integer;
|
|
|
1782 pragma Warnings (Off, Junk);
|
|
|
1783 Pid : Process_Id;
|
|
|
1784
|
|
|
1785 begin
|
|
|
1786 Spawn_Internal (Program_Name, Args, Junk, Pid, Blocking => False);
|
|
|
1787 return Pid;
|
|
|
1788 end Non_Blocking_Spawn;
|
|
|
1789
|
|
|
1790 function Non_Blocking_Spawn
|
|
|
1791 (Program_Name : String;
|
|
|
1792 Args : Argument_List;
|
|
|
1793 Output_File_Descriptor : File_Descriptor;
|
|
|
1794 Err_To_Out : Boolean := True) return Process_Id
|
|
|
1795 is
|
|
|
1796 Pid : Process_Id;
|
|
|
1797 Saved_Error : File_Descriptor := Invalid_FD; -- prevent warning
|
|
|
1798 Saved_Output : File_Descriptor;
|
|
|
1799
|
|
|
1800 begin
|
|
|
1801 if Output_File_Descriptor = Invalid_FD then
|
|
|
1802 return Invalid_Pid;
|
|
|
1803 end if;
|
|
|
1804
|
|
|
1805 -- Set standard output and, if specified, error to the temporary file
|
|
|
1806
|
|
|
1807 Saved_Output := Dup (Standout);
|
|
|
1808 Dup2 (Output_File_Descriptor, Standout);
|
|
|
1809
|
|
|
1810 if Err_To_Out then
|
|
|
1811 Saved_Error := Dup (Standerr);
|
|
|
1812 Dup2 (Output_File_Descriptor, Standerr);
|
|
|
1813 end if;
|
|
|
1814
|
|
|
1815 -- Spawn the program
|
|
|
1816
|
|
|
1817 Pid := Non_Blocking_Spawn (Program_Name, Args);
|
|
|
1818
|
|
|
1819 -- Restore the standard output and error
|
|
|
1820
|
|
|
1821 Dup2 (Saved_Output, Standout);
|
|
|
1822
|
|
|
1823 if Err_To_Out then
|
|
|
1824 Dup2 (Saved_Error, Standerr);
|
|
|
1825 end if;
|
|
|
1826
|
|
|
1827 -- And close the saved standard output and error file descriptors
|
|
|
1828
|
|
|
1829 Close (Saved_Output);
|
|
|
1830
|
|
|
1831 if Err_To_Out then
|
|
|
1832 Close (Saved_Error);
|
|
|
1833 end if;
|
|
|
1834
|
|
|
1835 return Pid;
|
|
|
1836 end Non_Blocking_Spawn;
|
|
|
1837
|
|
|
1838 function Non_Blocking_Spawn
|
|
|
1839 (Program_Name : String;
|
|
|
1840 Args : Argument_List;
|
|
|
1841 Output_File : String;
|
|
|
1842 Err_To_Out : Boolean := True) return Process_Id
|
|
|
1843 is
|
|
|
1844 Output_File_Descriptor : constant File_Descriptor :=
|
|
|
1845 Create_Output_Text_File (Output_File);
|
|
|
1846 Result : Process_Id;
|
|
|
1847
|
|
|
1848 begin
|
|
|
1849 -- Do not attempt to spawn if the output file could not be created
|
|
|
1850
|
|
|
1851 if Output_File_Descriptor = Invalid_FD then
|
|
|
1852 return Invalid_Pid;
|
|
|
1853
|
|
|
1854 else
|
|
|
1855 Result :=
|
|
|
1856 Non_Blocking_Spawn
|
|
|
1857 (Program_Name, Args, Output_File_Descriptor, Err_To_Out);
|
|
|
1858
|
|
|
1859 -- Close the file just created for the output, as the file descriptor
|
|
|
1860 -- cannot be used anywhere, being a local value. It is safe to do
|
|
|
1861 -- that, as the file descriptor has been duplicated to form
|
|
|
1862 -- standard output and error of the spawned process.
|
|
|
1863
|
|
|
1864 Close (Output_File_Descriptor);
|
|
|
1865
|
|
|
1866 return Result;
|
|
|
1867 end if;
|
|
|
1868 end Non_Blocking_Spawn;
|
|
|
1869
|
|
|
1870 function Non_Blocking_Spawn
|
|
|
1871 (Program_Name : String;
|
|
|
1872 Args : Argument_List;
|
|
|
1873 Stdout_File : String;
|
|
|
1874 Stderr_File : String) return Process_Id
|
|
|
1875 is
|
|
|
1876 Stderr_FD : constant File_Descriptor :=
|
|
|
1877 Create_Output_Text_File (Stderr_File);
|
|
|
1878 Stdout_FD : constant File_Descriptor :=
|
|
|
1879 Create_Output_Text_File (Stdout_File);
|
|
|
1880
|
|
|
1881 Result : Process_Id;
|
|
|
1882 Saved_Error : File_Descriptor;
|
|
|
1883 Saved_Output : File_Descriptor;
|
|
|
1884
|
|
|
1885 Dummy_Status : Boolean;
|
|
|
1886
|
|
|
1887 begin
|
|
|
1888 -- Do not attempt to spawn if the output files could not be created
|
|
|
1889
|
|
|
1890 if Stdout_FD = Invalid_FD or else Stderr_FD = Invalid_FD then
|
|
|
1891 return Invalid_Pid;
|
|
|
1892 end if;
|
|
|
1893
|
|
|
1894 -- Set standard output and error to the specified files
|
|
|
1895
|
|
|
1896 Saved_Output := Dup (Standout);
|
|
|
1897 Dup2 (Stdout_FD, Standout);
|
|
|
1898
|
|
|
1899 Saved_Error := Dup (Standerr);
|
|
|
1900 Dup2 (Stderr_FD, Standerr);
|
|
|
1901
|
|
|
1902 Set_Close_On_Exec (Saved_Output, True, Dummy_Status);
|
|
|
1903 Set_Close_On_Exec (Saved_Error, True, Dummy_Status);
|
|
|
1904
|
|
|
1905 -- Close the files just created for the output, as the file descriptors
|
|
|
1906 -- cannot be used anywhere, being local values. It is safe to do that,
|
|
|
1907 -- as the file descriptors have been duplicated to form standard output
|
|
|
1908 -- and standard error of the spawned process.
|
|
|
1909
|
|
|
1910 Close (Stdout_FD);
|
|
|
1911 Close (Stderr_FD);
|
|
|
1912
|
|
|
1913 -- Spawn the program
|
|
|
1914
|
|
|
1915 Result := Non_Blocking_Spawn (Program_Name, Args);
|
|
|
1916
|
|
|
1917 -- Restore the standard output and error
|
|
|
1918
|
|
|
1919 Dup2 (Saved_Output, Standout);
|
|
|
1920 Dup2 (Saved_Error, Standerr);
|
|
|
1921
|
|
|
1922 -- And close the saved standard output and error file descriptors
|
|
|
1923
|
|
|
1924 Close (Saved_Output);
|
|
|
1925 Close (Saved_Error);
|
|
|
1926
|
|
|
1927 return Result;
|
|
|
1928 end Non_Blocking_Spawn;
|
|
|
1929
|
|
|
1930 -------------------------------
|
|
|
1931 -- Non_Blocking_Wait_Process --
|
|
|
1932 -------------------------------
|
|
|
1933
|
|
|
1934 procedure Non_Blocking_Wait_Process
|
|
|
1935 (Pid : out Process_Id; Success : out Boolean)
|
|
|
1936 is
|
|
|
1937 Status : Integer;
|
|
|
1938
|
|
|
1939 function Portable_No_Block_Wait (S : Address) return Process_Id;
|
|
|
1940 pragma Import
|
|
|
1941 (C, Portable_No_Block_Wait, "__gnat_portable_no_block_wait");
|
|
|
1942
|
|
|
1943 begin
|
|
|
1944 Pid := Portable_No_Block_Wait (Status'Address);
|
|
|
1945 Success := (Status = 0);
|
|
|
1946
|
|
|
1947 if Pid = 0 then
|
|
|
1948 Pid := Invalid_Pid;
|
|
|
1949 end if;
|
|
|
1950 end Non_Blocking_Wait_Process;
|
|
|
1951
|
|
|
1952 -------------------------
|
|
|
1953 -- Normalize_Arguments --
|
|
|
1954 -------------------------
|
|
|
1955
|
|
|
1956 procedure Normalize_Arguments (Args : in out Argument_List) is
|
|
|
1957 procedure Quote_Argument (Arg : in out String_Access);
|
|
|
1958 -- Add quote around argument if it contains spaces (or HT characters)
|
|
|
1959
|
|
|
1960 C_Argument_Needs_Quote : Integer;
|
|
|
1961 pragma Import (C, C_Argument_Needs_Quote, "__gnat_argument_needs_quote");
|
|
|
1962 Argument_Needs_Quote : constant Boolean := C_Argument_Needs_Quote /= 0;
|
|
|
1963
|
|
|
1964 --------------------
|
|
|
1965 -- Quote_Argument --
|
|
|
1966 --------------------
|
|
|
1967
|
|
|
1968 procedure Quote_Argument (Arg : in out String_Access) is
|
|
|
1969 J : Positive := 1;
|
|
|
1970 Quote_Needed : Boolean := False;
|
|
|
1971 Res : String (1 .. Arg'Length * 2);
|
|
|
1972
|
|
|
1973 begin
|
|
|
1974 if Arg (Arg'First) /= '"' or else Arg (Arg'Last) /= '"' then
|
|
|
1975
|
|
|
1976 -- Starting quote
|
|
|
1977
|
|
|
1978 Res (J) := '"';
|
|
|
1979
|
|
|
1980 for K in Arg'Range loop
|
|
|
1981
|
|
|
1982 J := J + 1;
|
|
|
1983
|
|
|
1984 if Arg (K) = '"' then
|
|
|
1985 Res (J) := '\';
|
|
|
1986 J := J + 1;
|
|
|
1987 Res (J) := '"';
|
|
|
1988 Quote_Needed := True;
|
|
|
1989
|
|
|
1990 elsif Arg (K) = ' ' or else Arg (K) = ASCII.HT then
|
|
|
1991 Res (J) := Arg (K);
|
|
|
1992 Quote_Needed := True;
|
|
|
1993
|
|
|
1994 else
|
|
|
1995 Res (J) := Arg (K);
|
|
|
1996 end if;
|
|
|
1997 end loop;
|
|
|
1998
|
|
|
1999 if Quote_Needed then
|
|
|
2000
|
|
|
2001 -- Case of null terminated string
|
|
|
2002
|
|
|
2003 if Res (J) = ASCII.NUL then
|
|
|
2004
|
|
|
2005 -- If the string ends with \, double it
|
|
|
2006
|
|
|
2007 if Res (J - 1) = '\' then
|
|
|
2008 Res (J) := '\';
|
|
|
2009 J := J + 1;
|
|
|
2010 end if;
|
|
|
2011
|
|
|
2012 -- Put a quote just before the null at the end
|
|
|
2013
|
|
|
2014 Res (J) := '"';
|
|
|
2015 J := J + 1;
|
|
|
2016 Res (J) := ASCII.NUL;
|
|
|
2017
|
|
|
2018 -- If argument is terminated by '\', then double it. Otherwise
|
|
|
2019 -- the ending quote will be taken as-is. This is quite strange
|
|
|
2020 -- spawn behavior from Windows, but this is what we see.
|
|
|
2021
|
|
|
2022 else
|
|
|
2023 if Res (J) = '\' then
|
|
|
2024 J := J + 1;
|
|
|
2025 Res (J) := '\';
|
|
|
2026 end if;
|
|
|
2027
|
|
|
2028 -- Ending quote
|
|
|
2029
|
|
|
2030 J := J + 1;
|
|
|
2031 Res (J) := '"';
|
|
|
2032 end if;
|
|
|
2033
|
|
|
2034 declare
|
|
|
2035 Old : String_Access := Arg;
|
|
|
2036
|
|
|
2037 begin
|
|
|
2038 Arg := new String'(Res (1 .. J));
|
|
|
2039 Free (Old);
|
|
|
2040 end;
|
|
|
2041 end if;
|
|
|
2042
|
|
|
2043 end if;
|
|
|
2044 end Quote_Argument;
|
|
|
2045
|
|
|
2046 -- Start of processing for Normalize_Arguments
|
|
|
2047
|
|
|
2048 begin
|
|
|
2049 if Argument_Needs_Quote then
|
|
|
2050 for K in Args'Range loop
|
|
|
2051 if Args (K) /= null and then Args (K)'Length /= 0 then
|
|
|
2052 Quote_Argument (Args (K));
|
|
|
2053 end if;
|
|
|
2054 end loop;
|
|
|
2055 end if;
|
|
|
2056 end Normalize_Arguments;
|
|
|
2057
|
|
|
2058 ------------------------
|
|
|
2059 -- Normalize_Pathname --
|
|
|
2060 ------------------------
|
|
|
2061
|
|
|
2062 function Normalize_Pathname
|
|
|
2063 (Name : String;
|
|
|
2064 Directory : String := "";
|
|
|
2065 Resolve_Links : Boolean := True;
|
|
|
2066 Case_Sensitive : Boolean := True) return String
|
|
|
2067 is
|
|
|
2068 procedure Get_Current_Dir
|
|
|
2069 (Dir : System.Address;
|
|
|
2070 Length : System.Address);
|
|
|
2071 pragma Import (C, Get_Current_Dir, "__gnat_get_current_dir");
|
|
|
2072
|
|
|
2073 function Get_File_Names_Case_Sensitive return Integer;
|
|
|
2074 pragma Import
|
|
|
2075 (C, Get_File_Names_Case_Sensitive,
|
|
|
2076 "__gnat_get_file_names_case_sensitive");
|
|
|
2077
|
|
|
2078 Max_Path : Integer;
|
|
|
2079 pragma Import (C, Max_Path, "__gnat_max_path_len");
|
|
|
2080 -- Maximum length of a path name
|
|
|
2081
|
|
|
2082 function Readlink
|
|
|
2083 (Path : System.Address;
|
|
|
2084 Buf : System.Address;
|
|
|
2085 Bufsiz : size_t) return Integer;
|
|
|
2086 pragma Import (C, Readlink, "__gnat_readlink");
|
|
|
2087
|
|
|
2088 function To_Canonical_File_Spec
|
|
|
2089 (Host_File : System.Address) return System.Address;
|
|
|
2090 pragma Import
|
|
|
2091 (C, To_Canonical_File_Spec, "__gnat_to_canonical_file_spec");
|
|
|
2092 -- Convert possible foreign file syntax to canonical form
|
|
|
2093
|
|
|
2094 Fold_To_Lower_Case : constant Boolean :=
|
|
|
2095 not Case_Sensitive
|
|
|
2096 and then Get_File_Names_Case_Sensitive = 0;
|
|
|
2097
|
|
|
2098 function Final_Value (S : String) return String;
|
|
|
2099 -- Make final adjustment to the returned string. This function strips
|
|
|
2100 -- trailing directory separators, and folds returned string to lower
|
|
|
2101 -- case if required.
|
|
|
2102
|
|
|
2103 function Get_Directory (Dir : String) return String;
|
|
|
2104 -- If Dir is not empty, return it, adding a directory separator
|
|
|
2105 -- if not already present, otherwise return current working directory
|
|
|
2106 -- with terminating directory separator.
|
|
|
2107
|
|
|
2108 -----------------
|
|
|
2109 -- Final_Value --
|
|
|
2110 -----------------
|
|
|
2111
|
|
|
2112 function Final_Value (S : String) return String is
|
|
|
2113 S1 : String := S;
|
|
|
2114 -- We may need to fold S to lower case, so we need a variable
|
|
|
2115
|
|
|
2116 Last : Natural;
|
|
|
2117
|
|
|
2118 begin
|
|
|
2119 if Fold_To_Lower_Case then
|
|
|
2120 System.Case_Util.To_Lower (S1);
|
|
|
2121 end if;
|
|
|
2122
|
|
|
2123 -- Remove trailing directory separator, if any
|
|
|
2124
|
|
|
2125 Last := S1'Last;
|
|
|
2126
|
|
|
2127 if Last > 1
|
|
|
2128 and then (S1 (Last) = '/'
|
|
|
2129 or else
|
|
|
2130 S1 (Last) = Directory_Separator)
|
|
|
2131 then
|
|
|
2132 -- Special case for Windows: C:\
|
|
|
2133
|
|
|
2134 if Last = 3
|
|
|
2135 and then S1 (1) /= Directory_Separator
|
|
|
2136 and then S1 (2) = ':'
|
|
|
2137 then
|
|
|
2138 null;
|
|
|
2139
|
|
|
2140 else
|
|
|
2141 Last := Last - 1;
|
|
|
2142 end if;
|
|
|
2143 end if;
|
|
|
2144
|
|
|
2145 return S1 (1 .. Last);
|
|
|
2146 end Final_Value;
|
|
|
2147
|
|
|
2148 -------------------
|
|
|
2149 -- Get_Directory --
|
|
|
2150 -------------------
|
|
|
2151
|
|
|
2152 function Get_Directory (Dir : String) return String is
|
|
|
2153 begin
|
|
|
2154 -- Directory given, add directory separator if needed
|
|
|
2155
|
|
|
2156 if Dir'Length > 0 then
|
|
|
2157 declare
|
|
|
2158 Result : String :=
|
|
|
2159 Normalize_Pathname
|
|
|
2160 (Dir, "", Resolve_Links, Case_Sensitive) &
|
|
|
2161 Directory_Separator;
|
|
|
2162 Last : Positive := Result'Last - 1;
|
|
|
2163
|
|
|
2164 begin
|
|
|
2165 -- On Windows, change all '/' to '\'
|
|
|
2166
|
|
|
2167 if On_Windows then
|
|
|
2168 for J in Result'First .. Last - 1 loop
|
|
|
2169 if Result (J) = '/' then
|
|
|
2170 Result (J) := Directory_Separator;
|
|
|
2171 end if;
|
|
|
2172 end loop;
|
|
|
2173 end if;
|
|
|
2174
|
|
|
2175 -- Include additional directory separator, if needed
|
|
|
2176
|
|
|
2177 if Result (Last) /= Directory_Separator then
|
|
|
2178 Last := Last + 1;
|
|
|
2179 end if;
|
|
|
2180
|
|
|
2181 return Result (Result'First .. Last);
|
|
|
2182 end;
|
|
|
2183
|
|
|
2184 -- Directory name not given, get current directory
|
|
|
2185
|
|
|
2186 else
|
|
|
2187 declare
|
|
|
2188 Buffer : String (1 .. Max_Path + 2);
|
|
|
2189 Path_Len : Natural := Max_Path;
|
|
|
2190
|
|
|
2191 begin
|
|
|
2192 Get_Current_Dir (Buffer'Address, Path_Len'Address);
|
|
|
2193
|
|
|
2194 if Path_Len = 0 then
|
|
|
2195 raise Program_Error;
|
|
|
2196 end if;
|
|
|
2197
|
|
|
2198 if Buffer (Path_Len) /= Directory_Separator then
|
|
|
2199 Path_Len := Path_Len + 1;
|
|
|
2200 Buffer (Path_Len) := Directory_Separator;
|
|
|
2201 end if;
|
|
|
2202
|
|
|
2203 -- By default, the drive letter on Windows is in upper case
|
|
|
2204
|
|
|
2205 if On_Windows
|
|
|
2206 and then Path_Len >= 2
|
|
|
2207 and then Buffer (2) = ':'
|
|
|
2208 then
|
|
|
2209 System.Case_Util.To_Upper (Buffer (1 .. 1));
|
|
|
2210 end if;
|
|
|
2211
|
|
|
2212 return Buffer (1 .. Path_Len);
|
|
|
2213 end;
|
|
|
2214 end if;
|
|
|
2215 end Get_Directory;
|
|
|
2216
|
|
|
2217 -- Local variables
|
|
|
2218
|
|
|
2219 Max_Iterations : constant := 500;
|
|
|
2220
|
|
|
2221 Canonical_File_Addr : System.Address;
|
|
|
2222 Canonical_File_Len : Integer;
|
|
|
2223
|
|
|
2224 End_Path : Natural := 0;
|
|
|
2225 Finish : Positive;
|
|
|
2226 Last : Positive;
|
|
|
2227 Link_Buffer : String (1 .. Max_Path + 2);
|
|
|
2228 Path_Buffer : String (1 .. Max_Path + Max_Path + 2);
|
|
|
2229 Start : Natural;
|
|
|
2230 Status : Integer;
|
|
|
2231 The_Name : String (1 .. Name'Length + 1);
|
|
|
2232
|
|
|
2233 -- Start of processing for Normalize_Pathname
|
|
|
2234
|
|
|
2235 begin
|
|
|
2236 -- Special case, return null if name is null, or if it is bigger than
|
|
|
2237 -- the biggest name allowed.
|
|
|
2238
|
|
|
2239 if Name'Length = 0 or else Name'Length > Max_Path then
|
|
|
2240 return "";
|
|
|
2241 end if;
|
|
|
2242
|
|
|
2243 -- First, convert possible foreign file spec to Unix file spec. If no
|
|
|
2244 -- conversion is required, all this does is put Name at the beginning
|
|
|
2245 -- of Path_Buffer unchanged.
|
|
|
2246
|
|
|
2247 File_Name_Conversion : begin
|
|
|
2248 The_Name (1 .. Name'Length) := Name;
|
|
|
2249 The_Name (The_Name'Last) := ASCII.NUL;
|
|
|
2250
|
|
|
2251 Canonical_File_Addr := To_Canonical_File_Spec (The_Name'Address);
|
|
|
2252 Canonical_File_Len := Integer (CRTL.strlen (Canonical_File_Addr));
|
|
|
2253
|
|
|
2254 -- If syntax conversion has failed, return an empty string to
|
|
|
2255 -- indicate the failure.
|
|
|
2256
|
|
|
2257 if Canonical_File_Len = 0 then
|
|
|
2258 return "";
|
|
|
2259 end if;
|
|
|
2260
|
|
|
2261 declare
|
|
|
2262 subtype Path_String is String (1 .. Canonical_File_Len);
|
|
|
2263 Canonical_File : Path_String;
|
|
|
2264 for Canonical_File'Address use Canonical_File_Addr;
|
|
|
2265 pragma Import (Ada, Canonical_File);
|
|
|
2266
|
|
|
2267 begin
|
|
|
2268 Path_Buffer (1 .. Canonical_File_Len) := Canonical_File;
|
|
|
2269 End_Path := Canonical_File_Len;
|
|
|
2270 Last := 1;
|
|
|
2271 end;
|
|
|
2272 end File_Name_Conversion;
|
|
|
2273
|
|
|
2274 -- Replace all '/' by Directory Separators (this is for Windows)
|
|
|
2275
|
|
|
2276 if Directory_Separator /= '/' then
|
|
|
2277 for Index in 1 .. End_Path loop
|
|
|
2278 if Path_Buffer (Index) = '/' then
|
|
|
2279 Path_Buffer (Index) := Directory_Separator;
|
|
|
2280 end if;
|
|
|
2281 end loop;
|
|
|
2282 end if;
|
|
|
2283
|
|
|
2284 -- Resolve directory names for Windows
|
|
|
2285
|
|
|
2286 if On_Windows then
|
|
|
2287
|
|
|
2288 -- On Windows, if we have an absolute path starting with a directory
|
|
|
2289 -- separator, we need to have the drive letter appended in front.
|
|
|
2290
|
|
|
2291 -- On Windows, Get_Current_Dir will return a suitable directory name
|
|
|
2292 -- (path starting with a drive letter on Windows). So we take this
|
|
|
2293 -- drive letter and prepend it to the current path.
|
|
|
2294
|
|
|
2295 if Path_Buffer (1) = Directory_Separator
|
|
|
2296 and then Path_Buffer (2) /= Directory_Separator
|
|
|
2297 then
|
|
|
2298 declare
|
|
|
2299 Cur_Dir : constant String := Get_Directory ("");
|
|
|
2300 -- Get the current directory to get the drive letter
|
|
|
2301
|
|
|
2302 begin
|
|
|
2303 if Cur_Dir'Length > 2
|
|
|
2304 and then Cur_Dir (Cur_Dir'First + 1) = ':'
|
|
|
2305 then
|
|
|
2306 Path_Buffer (3 .. End_Path + 2) :=
|
|
|
2307 Path_Buffer (1 .. End_Path);
|
|
|
2308 Path_Buffer (1 .. 2) :=
|
|
|
2309 Cur_Dir (Cur_Dir'First .. Cur_Dir'First + 1);
|
|
|
2310 End_Path := End_Path + 2;
|
|
|
2311 end if;
|
|
|
2312 end;
|
|
|
2313
|
|
|
2314 -- We have a drive letter, ensure it is upper-case
|
|
|
2315
|
|
|
2316 elsif Path_Buffer (1) in 'a' .. 'z'
|
|
|
2317 and then Path_Buffer (2) = ':'
|
|
|
2318 then
|
|
|
2319 System.Case_Util.To_Upper (Path_Buffer (1 .. 1));
|
|
|
2320 end if;
|
|
|
2321 end if;
|
|
|
2322
|
|
|
2323 -- On Windows, remove all double-quotes that are possibly part of the
|
|
|
2324 -- path but can cause problems with other methods.
|
|
|
2325
|
|
|
2326 if On_Windows then
|
|
|
2327 declare
|
|
|
2328 Index : Natural;
|
|
|
2329
|
|
|
2330 begin
|
|
|
2331 Index := Path_Buffer'First;
|
|
|
2332 for Current in Path_Buffer'First .. End_Path loop
|
|
|
2333 if Path_Buffer (Current) /= '"' then
|
|
|
2334 Path_Buffer (Index) := Path_Buffer (Current);
|
|
|
2335 Index := Index + 1;
|
|
|
2336 end if;
|
|
|
2337 end loop;
|
|
|
2338
|
|
|
2339 End_Path := Index - 1;
|
|
|
2340 end;
|
|
|
2341 end if;
|
|
|
2342
|
|
|
2343 -- Start the conversions
|
|
|
2344
|
|
|
2345 -- If this is not finished after Max_Iterations, give up and return an
|
|
|
2346 -- empty string.
|
|
|
2347
|
|
|
2348 for J in 1 .. Max_Iterations loop
|
|
|
2349
|
|
|
2350 -- If we don't have an absolute pathname, prepend the directory
|
|
|
2351 -- Reference_Dir.
|
|
|
2352
|
|
|
2353 if Last = 1
|
|
|
2354 and then not Is_Absolute_Path (Path_Buffer (1 .. End_Path))
|
|
|
2355 then
|
|
|
2356 declare
|
|
|
2357 Reference_Dir : constant String := Get_Directory (Directory);
|
|
|
2358 Ref_Dir_Len : constant Natural := Reference_Dir'Length;
|
|
|
2359 -- Current directory name specified and its length
|
|
|
2360
|
|
|
2361 begin
|
|
|
2362 Path_Buffer (Ref_Dir_Len + 1 .. Ref_Dir_Len + End_Path) :=
|
|
|
2363 Path_Buffer (1 .. End_Path);
|
|
|
2364 End_Path := Ref_Dir_Len + End_Path;
|
|
|
2365 Path_Buffer (1 .. Ref_Dir_Len) := Reference_Dir;
|
|
|
2366 Last := Ref_Dir_Len;
|
|
|
2367 end;
|
|
|
2368 end if;
|
|
|
2369
|
|
|
2370 Start := Last + 1;
|
|
|
2371 Finish := Last;
|
|
|
2372
|
|
|
2373 -- Ensure that Windows network drives are kept, e.g: \\server\drive-c
|
|
|
2374
|
|
|
2375 if Start = 2
|
|
|
2376 and then Directory_Separator = '\'
|
|
|
2377 and then Path_Buffer (1 .. 2) = "\\"
|
|
|
2378 then
|
|
|
2379 Start := 3;
|
|
|
2380 end if;
|
|
|
2381
|
|
|
2382 -- If we have traversed the full pathname, return it
|
|
|
2383
|
|
|
2384 if Start > End_Path then
|
|
|
2385 return Final_Value (Path_Buffer (1 .. End_Path));
|
|
|
2386 end if;
|
|
|
2387
|
|
|
2388 -- Remove duplicate directory separators
|
|
|
2389
|
|
|
2390 while Path_Buffer (Start) = Directory_Separator loop
|
|
|
2391 if Start = End_Path then
|
|
|
2392 return Final_Value (Path_Buffer (1 .. End_Path - 1));
|
|
|
2393
|
|
|
2394 else
|
|
|
2395 Path_Buffer (Start .. End_Path - 1) :=
|
|
|
2396 Path_Buffer (Start + 1 .. End_Path);
|
|
|
2397 End_Path := End_Path - 1;
|
|
|
2398 end if;
|
|
|
2399 end loop;
|
|
|
2400
|
|
|
2401 -- Find the end of the current field: last character or the one
|
|
|
2402 -- preceding the next directory separator.
|
|
|
2403
|
|
|
2404 while Finish < End_Path
|
|
|
2405 and then Path_Buffer (Finish + 1) /= Directory_Separator
|
|
|
2406 loop
|
|
|
2407 Finish := Finish + 1;
|
|
|
2408 end loop;
|
|
|
2409
|
|
|
2410 -- Remove "." field
|
|
|
2411
|
|
|
2412 if Start = Finish and then Path_Buffer (Start) = '.' then
|
|
|
2413 if Start = End_Path then
|
|
|
2414 if Last = 1 then
|
|
|
2415 return (1 => Directory_Separator);
|
|
|
2416 else
|
|
|
2417 if Fold_To_Lower_Case then
|
|
|
2418 System.Case_Util.To_Lower (Path_Buffer (1 .. Last - 1));
|
|
|
2419 end if;
|
|
|
2420
|
|
|
2421 return Path_Buffer (1 .. Last - 1);
|
|
|
2422 end if;
|
|
|
2423 else
|
|
|
2424 Path_Buffer (Last + 1 .. End_Path - 2) :=
|
|
|
2425 Path_Buffer (Last + 3 .. End_Path);
|
|
|
2426 End_Path := End_Path - 2;
|
|
|
2427 end if;
|
|
|
2428
|
|
|
2429 -- Remove ".." fields
|
|
|
2430
|
|
|
2431 elsif Finish = Start + 1
|
|
|
2432 and then Path_Buffer (Start .. Finish) = ".."
|
|
|
2433 then
|
|
|
2434 Start := Last;
|
|
|
2435 loop
|
|
|
2436 Start := Start - 1;
|
|
|
2437 exit when Start < 1
|
|
|
2438 or else Path_Buffer (Start) = Directory_Separator;
|
|
|
2439 end loop;
|
|
|
2440
|
|
|
2441 if Start <= 1 then
|
|
|
2442 if Finish = End_Path then
|
|
|
2443 return (1 => Directory_Separator);
|
|
|
2444
|
|
|
2445 else
|
|
|
2446 Path_Buffer (1 .. End_Path - Finish) :=
|
|
|
2447 Path_Buffer (Finish + 1 .. End_Path);
|
|
|
2448 End_Path := End_Path - Finish;
|
|
|
2449 Last := 1;
|
|
|
2450 end if;
|
|
|
2451
|
|
|
2452 else
|
|
|
2453 if Finish = End_Path then
|
|
|
2454 return Final_Value (Path_Buffer (1 .. Start - 1));
|
|
|
2455
|
|
|
2456 else
|
|
|
2457 Path_Buffer (Start + 1 .. Start + End_Path - Finish - 1) :=
|
|
|
2458 Path_Buffer (Finish + 2 .. End_Path);
|
|
|
2459 End_Path := Start + End_Path - Finish - 1;
|
|
|
2460 Last := Start;
|
|
|
2461 end if;
|
|
|
2462 end if;
|
|
|
2463
|
|
|
2464 -- Check if current field is a symbolic link
|
|
|
2465
|
|
|
2466 elsif Resolve_Links then
|
|
|
2467 declare
|
|
|
2468 Saved : constant Character := Path_Buffer (Finish + 1);
|
|
|
2469
|
|
|
2470 begin
|
|
|
2471 Path_Buffer (Finish + 1) := ASCII.NUL;
|
|
|
2472 Status :=
|
|
|
2473 Readlink
|
|
|
2474 (Path => Path_Buffer'Address,
|
|
|
2475 Buf => Link_Buffer'Address,
|
|
|
2476 Bufsiz => Link_Buffer'Length);
|
|
|
2477 Path_Buffer (Finish + 1) := Saved;
|
|
|
2478 end;
|
|
|
2479
|
|
|
2480 -- Not a symbolic link, move to the next field, if any
|
|
|
2481
|
|
|
2482 if Status <= 0 then
|
|
|
2483 Last := Finish + 1;
|
|
|
2484
|
|
|
2485 -- Replace symbolic link with its value
|
|
|
2486
|
|
|
2487 else
|
|
|
2488 if Is_Absolute_Path (Link_Buffer (1 .. Status)) then
|
|
|
2489 Path_Buffer (Status + 1 .. End_Path - (Finish - Status)) :=
|
|
|
2490 Path_Buffer (Finish + 1 .. End_Path);
|
|
|
2491 End_Path := End_Path - (Finish - Status);
|
|
|
2492 Path_Buffer (1 .. Status) := Link_Buffer (1 .. Status);
|
|
|
2493 Last := 1;
|
|
|
2494
|
|
|
2495 else
|
|
|
2496 Path_Buffer
|
|
|
2497 (Last + Status + 1 .. End_Path - Finish + Last + Status) :=
|
|
|
2498 Path_Buffer (Finish + 1 .. End_Path);
|
|
|
2499 End_Path := End_Path - Finish + Last + Status;
|
|
|
2500 Path_Buffer (Last + 1 .. Last + Status) :=
|
|
|
2501 Link_Buffer (1 .. Status);
|
|
|
2502 end if;
|
|
|
2503 end if;
|
|
|
2504
|
|
|
2505 else
|
|
|
2506 Last := Finish + 1;
|
|
|
2507 end if;
|
|
|
2508 end loop;
|
|
|
2509
|
|
|
2510 -- Too many iterations: give up
|
|
|
2511
|
|
|
2512 -- This can happen when there is a circularity in the symbolic links: A
|
|
|
2513 -- is a symbolic link for B, which itself is a symbolic link, and the
|
|
|
2514 -- target of B or of another symbolic link target of B is A. In this
|
|
|
2515 -- case, we return an empty string to indicate failure to resolve.
|
|
|
2516
|
|
|
2517 return "";
|
|
|
2518 end Normalize_Pathname;
|
|
|
2519
|
|
|
2520 -----------------
|
|
|
2521 -- Open_Append --
|
|
|
2522 -----------------
|
|
|
2523
|
|
|
2524 function Open_Append
|
|
|
2525 (Name : C_File_Name;
|
|
|
2526 Fmode : Mode) return File_Descriptor
|
|
|
2527 is
|
|
|
2528 function C_Open_Append
|
|
|
2529 (Name : C_File_Name;
|
|
|
2530 Fmode : Mode) return File_Descriptor;
|
|
|
2531 pragma Import (C, C_Open_Append, "__gnat_open_append");
|
|
|
2532 begin
|
|
|
2533 return C_Open_Append (Name, Fmode);
|
|
|
2534 end Open_Append;
|
|
|
2535
|
|
|
2536 function Open_Append
|
|
|
2537 (Name : String;
|
|
|
2538 Fmode : Mode) return File_Descriptor
|
|
|
2539 is
|
|
|
2540 C_Name : String (1 .. Name'Length + 1);
|
|
|
2541 begin
|
|
|
2542 C_Name (1 .. Name'Length) := Name;
|
|
|
2543 C_Name (C_Name'Last) := ASCII.NUL;
|
|
|
2544 return Open_Append (C_Name (C_Name'First)'Address, Fmode);
|
|
|
2545 end Open_Append;
|
|
|
2546
|
|
|
2547 ---------------
|
|
|
2548 -- Open_Read --
|
|
|
2549 ---------------
|
|
|
2550
|
|
|
2551 function Open_Read
|
|
|
2552 (Name : C_File_Name;
|
|
|
2553 Fmode : Mode) return File_Descriptor
|
|
|
2554 is
|
|
|
2555 function C_Open_Read
|
|
|
2556 (Name : C_File_Name;
|
|
|
2557 Fmode : Mode) return File_Descriptor;
|
|
|
2558 pragma Import (C, C_Open_Read, "__gnat_open_read");
|
|
|
2559 begin
|
|
|
2560 return C_Open_Read (Name, Fmode);
|
|
|
2561 end Open_Read;
|
|
|
2562
|
|
|
2563 function Open_Read
|
|
|
2564 (Name : String;
|
|
|
2565 Fmode : Mode) return File_Descriptor
|
|
|
2566 is
|
|
|
2567 C_Name : String (1 .. Name'Length + 1);
|
|
|
2568 begin
|
|
|
2569 C_Name (1 .. Name'Length) := Name;
|
|
|
2570 C_Name (C_Name'Last) := ASCII.NUL;
|
|
|
2571 return Open_Read (C_Name (C_Name'First)'Address, Fmode);
|
|
|
2572 end Open_Read;
|
|
|
2573
|
|
|
2574 ---------------------
|
|
|
2575 -- Open_Read_Write --
|
|
|
2576 ---------------------
|
|
|
2577
|
|
|
2578 function Open_Read_Write
|
|
|
2579 (Name : C_File_Name;
|
|
|
2580 Fmode : Mode) return File_Descriptor
|
|
|
2581 is
|
|
|
2582 function C_Open_Read_Write
|
|
|
2583 (Name : C_File_Name;
|
|
|
2584 Fmode : Mode) return File_Descriptor;
|
|
|
2585 pragma Import (C, C_Open_Read_Write, "__gnat_open_rw");
|
|
|
2586 begin
|
|
|
2587 return C_Open_Read_Write (Name, Fmode);
|
|
|
2588 end Open_Read_Write;
|
|
|
2589
|
|
|
2590 function Open_Read_Write
|
|
|
2591 (Name : String;
|
|
|
2592 Fmode : Mode) return File_Descriptor
|
|
|
2593 is
|
|
|
2594 C_Name : String (1 .. Name'Length + 1);
|
|
|
2595 begin
|
|
|
2596 C_Name (1 .. Name'Length) := Name;
|
|
|
2597 C_Name (C_Name'Last) := ASCII.NUL;
|
|
|
2598 return Open_Read_Write (C_Name (C_Name'First)'Address, Fmode);
|
|
|
2599 end Open_Read_Write;
|
|
|
2600
|
|
|
2601 -------------
|
|
|
2602 -- OS_Exit --
|
|
|
2603 -------------
|
|
|
2604
|
|
|
2605 procedure OS_Exit (Status : Integer) is
|
|
|
2606 begin
|
|
|
2607 OS_Exit_Ptr (Status);
|
|
|
2608 raise Program_Error;
|
|
|
2609 end OS_Exit;
|
|
|
2610
|
|
|
2611 ---------------------
|
|
|
2612 -- OS_Exit_Default --
|
|
|
2613 ---------------------
|
|
|
2614
|
|
|
2615 procedure OS_Exit_Default (Status : Integer) is
|
|
|
2616 procedure GNAT_OS_Exit (Status : Integer);
|
|
|
2617 pragma Import (C, GNAT_OS_Exit, "__gnat_os_exit");
|
|
|
2618 pragma No_Return (GNAT_OS_Exit);
|
|
|
2619 begin
|
|
|
2620 GNAT_OS_Exit (Status);
|
|
|
2621 end OS_Exit_Default;
|
|
|
2622
|
|
|
2623 --------------------
|
|
|
2624 -- Pid_To_Integer --
|
|
|
2625 --------------------
|
|
|
2626
|
|
|
2627 function Pid_To_Integer (Pid : Process_Id) return Integer is
|
|
|
2628 begin
|
|
|
2629 return Integer (Pid);
|
|
|
2630 end Pid_To_Integer;
|
|
|
2631
|
|
|
2632 ----------
|
|
|
2633 -- Read --
|
|
|
2634 ----------
|
|
|
2635
|
|
|
2636 function Read
|
|
|
2637 (FD : File_Descriptor;
|
|
|
2638 A : System.Address;
|
|
|
2639 N : Integer) return Integer
|
|
|
2640 is
|
|
|
2641 begin
|
|
|
2642 return
|
|
|
2643 Integer (System.CRTL.read
|
|
|
2644 (System.CRTL.int (FD),
|
|
|
2645 System.CRTL.chars (A),
|
|
|
2646 System.CRTL.size_t (N)));
|
|
|
2647 end Read;
|
|
|
2648
|
|
|
2649 -----------------
|
|
|
2650 -- Rename_File --
|
|
|
2651 -----------------
|
|
|
2652
|
|
|
2653 procedure Rename_File
|
|
|
2654 (Old_Name : C_File_Name;
|
|
|
2655 New_Name : C_File_Name;
|
|
|
2656 Success : out Boolean)
|
|
|
2657 is
|
|
|
2658 function rename (From, To : Address) return Integer;
|
|
|
2659 pragma Import (C, rename, "__gnat_rename");
|
|
|
2660 R : Integer;
|
|
|
2661
|
|
|
2662 begin
|
|
|
2663 R := rename (Old_Name, New_Name);
|
|
|
2664 Success := (R = 0);
|
|
|
2665 end Rename_File;
|
|
|
2666
|
|
|
2667 procedure Rename_File
|
|
|
2668 (Old_Name : String;
|
|
|
2669 New_Name : String;
|
|
|
2670 Success : out Boolean)
|
|
|
2671 is
|
|
|
2672 C_Old_Name : String (1 .. Old_Name'Length + 1);
|
|
|
2673 C_New_Name : String (1 .. New_Name'Length + 1);
|
|
|
2674
|
|
|
2675 begin
|
|
|
2676 C_Old_Name (1 .. Old_Name'Length) := Old_Name;
|
|
|
2677 C_Old_Name (C_Old_Name'Last) := ASCII.NUL;
|
|
|
2678 C_New_Name (1 .. New_Name'Length) := New_Name;
|
|
|
2679 C_New_Name (C_New_Name'Last) := ASCII.NUL;
|
|
|
2680 Rename_File (C_Old_Name'Address, C_New_Name'Address, Success);
|
|
|
2681 end Rename_File;
|
|
|
2682
|
|
|
2683 -----------------------
|
|
|
2684 -- Set_Close_On_Exec --
|
|
|
2685 -----------------------
|
|
|
2686
|
|
|
2687 procedure Set_Close_On_Exec
|
|
|
2688 (FD : File_Descriptor;
|
|
|
2689 Close_On_Exec : Boolean;
|
|
|
2690 Status : out Boolean)
|
|
|
2691 is
|
|
|
2692 function C_Set_Close_On_Exec
|
|
|
2693 (FD : File_Descriptor; Close_On_Exec : System.CRTL.int)
|
|
|
2694 return System.CRTL.int;
|
|
|
2695 pragma Import (C, C_Set_Close_On_Exec, "__gnat_set_close_on_exec");
|
|
|
2696 begin
|
|
|
2697 Status := C_Set_Close_On_Exec (FD, Boolean'Pos (Close_On_Exec)) = 0;
|
|
|
2698 end Set_Close_On_Exec;
|
|
|
2699
|
|
|
2700 --------------------
|
|
|
2701 -- Set_Executable --
|
|
|
2702 --------------------
|
|
|
2703
|
|
|
2704 procedure Set_Executable (Name : String; Mode : Positive := S_Owner) is
|
|
|
2705 procedure C_Set_Executable (Name : C_File_Name; Mode : Integer);
|
|
|
2706 pragma Import (C, C_Set_Executable, "__gnat_set_executable");
|
|
|
2707 C_Name : aliased String (Name'First .. Name'Last + 1);
|
|
|
2708
|
|
|
2709 begin
|
|
|
2710 C_Name (Name'Range) := Name;
|
|
|
2711 C_Name (C_Name'Last) := ASCII.NUL;
|
|
|
2712 C_Set_Executable (C_Name (C_Name'First)'Address, Mode);
|
|
|
2713 end Set_Executable;
|
|
|
2714
|
|
|
2715 -------------------------------------
|
|
|
2716 -- Set_File_Last_Modify_Time_Stamp --
|
|
|
2717 -------------------------------------
|
|
|
2718
|
|
|
2719 procedure Set_File_Last_Modify_Time_Stamp (Name : String; Time : OS_Time) is
|
|
|
2720 procedure C_Set_File_Time (Name : C_File_Name; Time : OS_Time);
|
|
|
2721 pragma Import (C, C_Set_File_Time, "__gnat_set_file_time_name");
|
|
|
2722 C_Name : aliased String (Name'First .. Name'Last + 1);
|
|
|
2723
|
|
|
2724 begin
|
|
|
2725 C_Name (Name'Range) := Name;
|
|
|
2726 C_Name (C_Name'Last) := ASCII.NUL;
|
|
|
2727 C_Set_File_Time (C_Name'Address, Time);
|
|
|
2728 end Set_File_Last_Modify_Time_Stamp;
|
|
|
2729
|
|
|
2730 ----------------------
|
|
|
2731 -- Set_Non_Readable --
|
|
|
2732 ----------------------
|
|
|
2733
|
|
|
2734 procedure Set_Non_Readable (Name : String) is
|
|
|
2735 procedure C_Set_Non_Readable (Name : C_File_Name);
|
|
|
2736 pragma Import (C, C_Set_Non_Readable, "__gnat_set_non_readable");
|
|
|
2737 C_Name : aliased String (Name'First .. Name'Last + 1);
|
|
|
2738
|
|
|
2739 begin
|
|
|
2740 C_Name (Name'Range) := Name;
|
|
|
2741 C_Name (C_Name'Last) := ASCII.NUL;
|
|
|
2742 C_Set_Non_Readable (C_Name (C_Name'First)'Address);
|
|
|
2743 end Set_Non_Readable;
|
|
|
2744
|
|
|
2745 ----------------------
|
|
|
2746 -- Set_Non_Writable --
|
|
|
2747 ----------------------
|
|
|
2748
|
|
|
2749 procedure Set_Non_Writable (Name : String) is
|
|
|
2750 procedure C_Set_Non_Writable (Name : C_File_Name);
|
|
|
2751 pragma Import (C, C_Set_Non_Writable, "__gnat_set_non_writable");
|
|
|
2752 C_Name : aliased String (Name'First .. Name'Last + 1);
|
|
|
2753
|
|
|
2754 begin
|
|
|
2755 C_Name (Name'Range) := Name;
|
|
|
2756 C_Name (C_Name'Last) := ASCII.NUL;
|
|
|
2757 C_Set_Non_Writable (C_Name (C_Name'First)'Address);
|
|
|
2758 end Set_Non_Writable;
|
|
|
2759
|
|
|
2760 ------------------
|
|
|
2761 -- Set_Readable --
|
|
|
2762 ------------------
|
|
|
2763
|
|
|
2764 procedure Set_Readable (Name : String) is
|
|
|
2765 procedure C_Set_Readable (Name : C_File_Name);
|
|
|
2766 pragma Import (C, C_Set_Readable, "__gnat_set_readable");
|
|
|
2767 C_Name : aliased String (Name'First .. Name'Last + 1);
|
|
|
2768
|
|
|
2769 begin
|
|
|
2770 C_Name (Name'Range) := Name;
|
|
|
2771 C_Name (C_Name'Last) := ASCII.NUL;
|
|
|
2772 C_Set_Readable (C_Name (C_Name'First)'Address);
|
|
|
2773 end Set_Readable;
|
|
|
2774
|
|
|
2775 --------------------
|
|
|
2776 -- Set_Writable --
|
|
|
2777 --------------------
|
|
|
2778
|
|
|
2779 procedure Set_Writable (Name : String) is
|
|
|
2780 procedure C_Set_Writable (Name : C_File_Name);
|
|
|
2781 pragma Import (C, C_Set_Writable, "__gnat_set_writable");
|
|
|
2782 C_Name : aliased String (Name'First .. Name'Last + 1);
|
|
|
2783
|
|
|
2784 begin
|
|
|
2785 C_Name (Name'Range) := Name;
|
|
|
2786 C_Name (C_Name'Last) := ASCII.NUL;
|
|
|
2787 C_Set_Writable (C_Name (C_Name'First)'Address);
|
|
|
2788 end Set_Writable;
|
|
|
2789
|
|
|
2790 ------------
|
|
|
2791 -- Setenv --
|
|
|
2792 ------------
|
|
|
2793
|
|
|
2794 procedure Setenv (Name : String; Value : String) is
|
|
|
2795 F_Name : String (1 .. Name'Length + 1);
|
|
|
2796 F_Value : String (1 .. Value'Length + 1);
|
|
|
2797
|
|
|
2798 procedure Set_Env_Value (Name, Value : System.Address);
|
|
|
2799 pragma Import (C, Set_Env_Value, "__gnat_setenv");
|
|
|
2800
|
|
|
2801 begin
|
|
|
2802 F_Name (1 .. Name'Length) := Name;
|
|
|
2803 F_Name (F_Name'Last) := ASCII.NUL;
|
|
|
2804
|
|
|
2805 F_Value (1 .. Value'Length) := Value;
|
|
|
2806 F_Value (F_Value'Last) := ASCII.NUL;
|
|
|
2807
|
|
|
2808 Set_Env_Value (F_Name'Address, F_Value'Address);
|
|
|
2809 end Setenv;
|
|
|
2810
|
|
|
2811 -----------
|
|
|
2812 -- Spawn --
|
|
|
2813 -----------
|
|
|
2814
|
|
|
2815 function Spawn
|
|
|
2816 (Program_Name : String;
|
|
|
2817 Args : Argument_List) return Integer
|
|
|
2818 is
|
|
|
2819 Junk : Process_Id;
|
|
|
2820 pragma Warnings (Off, Junk);
|
|
|
2821 Result : Integer;
|
|
|
2822
|
|
|
2823 begin
|
|
|
2824 Spawn_Internal (Program_Name, Args, Result, Junk, Blocking => True);
|
|
|
2825 return Result;
|
|
|
2826 end Spawn;
|
|
|
2827
|
|
|
2828 procedure Spawn
|
|
|
2829 (Program_Name : String;
|
|
|
2830 Args : Argument_List;
|
|
|
2831 Success : out Boolean)
|
|
|
2832 is
|
|
|
2833 begin
|
|
|
2834 Success := (Spawn (Program_Name, Args) = 0);
|
|
|
2835 end Spawn;
|
|
|
2836
|
|
|
2837 procedure Spawn
|
|
|
2838 (Program_Name : String;
|
|
|
2839 Args : Argument_List;
|
|
|
2840 Output_File_Descriptor : File_Descriptor;
|
|
|
2841 Return_Code : out Integer;
|
|
|
2842 Err_To_Out : Boolean := True)
|
|
|
2843 is
|
|
|
2844 Saved_Error : File_Descriptor := Invalid_FD; -- prevent compiler warning
|
|
|
2845 Saved_Output : File_Descriptor;
|
|
|
2846
|
|
|
2847 begin
|
|
|
2848 -- Set standard output and error to the temporary file
|
|
|
2849
|
|
|
2850 Saved_Output := Dup (Standout);
|
|
|
2851 Dup2 (Output_File_Descriptor, Standout);
|
|
|
2852
|
|
|
2853 if Err_To_Out then
|
|
|
2854 Saved_Error := Dup (Standerr);
|
|
|
2855 Dup2 (Output_File_Descriptor, Standerr);
|
|
|
2856 end if;
|
|
|
2857
|
|
|
2858 -- Spawn the program
|
|
|
2859
|
|
|
2860 Return_Code := Spawn (Program_Name, Args);
|
|
|
2861
|
|
|
2862 -- Restore the standard output and error
|
|
|
2863
|
|
|
2864 Dup2 (Saved_Output, Standout);
|
|
|
2865
|
|
|
2866 if Err_To_Out then
|
|
|
2867 Dup2 (Saved_Error, Standerr);
|
|
|
2868 end if;
|
|
|
2869
|
|
|
2870 -- And close the saved standard output and error file descriptors
|
|
|
2871
|
|
|
2872 Close (Saved_Output);
|
|
|
2873
|
|
|
2874 if Err_To_Out then
|
|
|
2875 Close (Saved_Error);
|
|
|
2876 end if;
|
|
|
2877 end Spawn;
|
|
|
2878
|
|
|
2879 procedure Spawn
|
|
|
2880 (Program_Name : String;
|
|
|
2881 Args : Argument_List;
|
|
|
2882 Output_File : String;
|
|
|
2883 Success : out Boolean;
|
|
|
2884 Return_Code : out Integer;
|
|
|
2885 Err_To_Out : Boolean := True)
|
|
|
2886 is
|
|
|
2887 FD : File_Descriptor;
|
|
|
2888
|
|
|
2889 begin
|
|
|
2890 Success := True;
|
|
|
2891 Return_Code := 0;
|
|
|
2892
|
|
|
2893 FD := Create_Output_Text_File (Output_File);
|
|
|
2894
|
|
|
2895 if FD = Invalid_FD then
|
|
|
2896 Success := False;
|
|
|
2897 return;
|
|
|
2898 end if;
|
|
|
2899
|
|
|
2900 Spawn (Program_Name, Args, FD, Return_Code, Err_To_Out);
|
|
|
2901
|
|
|
2902 Close (FD, Success);
|
|
|
2903 end Spawn;
|
|
|
2904
|
|
|
2905 --------------------
|
|
|
2906 -- Spawn_Internal --
|
|
|
2907 --------------------
|
|
|
2908
|
|
|
2909 procedure Spawn_Internal
|
|
|
2910 (Program_Name : String;
|
|
|
2911 Args : Argument_List;
|
|
|
2912 Result : out Integer;
|
|
|
2913 Pid : out Process_Id;
|
|
|
2914 Blocking : Boolean)
|
|
|
2915 is
|
|
|
2916 procedure Spawn (Args : Argument_List);
|
|
|
2917 -- Call Spawn with given argument list
|
|
|
2918
|
|
|
2919 N_Args : Argument_List (Args'Range);
|
|
|
2920 -- Normalized arguments
|
|
|
2921
|
|
|
2922 -----------
|
|
|
2923 -- Spawn --
|
|
|
2924 -----------
|
|
|
2925
|
|
|
2926 procedure Spawn (Args : Argument_List) is
|
|
|
2927 type Chars is array (Positive range <>) of aliased Character;
|
|
|
2928 type Char_Ptr is access constant Character;
|
|
|
2929
|
|
|
2930 Command_Len : constant Positive :=
|
|
|
2931 Program_Name'Length + 1 + Args_Length (Args);
|
|
|
2932 Command_Last : Natural := 0;
|
|
|
2933 Command : aliased Chars (1 .. Command_Len);
|
|
|
2934 -- Command contains all characters of the Program_Name and Args, all
|
|
|
2935 -- terminated by ASCII.NUL characters.
|
|
|
2936
|
|
|
2937 Arg_List_Len : constant Positive := Args'Length + 2;
|
|
|
2938 Arg_List_Last : Natural := 0;
|
|
|
2939 Arg_List : aliased array (1 .. Arg_List_Len) of Char_Ptr;
|
|
|
2940 -- List with pointers to NUL-terminated strings of the Program_Name
|
|
|
2941 -- and the Args and terminated with a null pointer. We rely on the
|
|
|
2942 -- default initialization for the last null pointer.
|
|
|
2943
|
|
|
2944 procedure Add_To_Command (S : String);
|
|
|
2945 -- Add S and a NUL character to Command, updating Last
|
|
|
2946
|
|
|
2947 function Portable_Spawn (Args : Address) return Integer;
|
|
|
2948 pragma Import (C, Portable_Spawn, "__gnat_portable_spawn");
|
|
|
2949
|
|
|
2950 function Portable_No_Block_Spawn (Args : Address) return Process_Id;
|
|
|
2951 pragma Import
|
|
|
2952 (C, Portable_No_Block_Spawn, "__gnat_portable_no_block_spawn");
|
|
|
2953
|
|
|
2954 --------------------
|
|
|
2955 -- Add_To_Command --
|
|
|
2956 --------------------
|
|
|
2957
|
|
|
2958 procedure Add_To_Command (S : String) is
|
|
|
2959 First : constant Natural := Command_Last + 1;
|
|
|
2960
|
|
|
2961 begin
|
|
|
2962 Command_Last := Command_Last + S'Length;
|
|
|
2963
|
|
|
2964 -- Move characters one at a time, because Command has aliased
|
|
|
2965 -- components.
|
|
|
2966
|
|
|
2967 -- But not volatile, so why is this necessary ???
|
|
|
2968
|
|
|
2969 for J in S'Range loop
|
|
|
2970 Command (First + J - S'First) := S (J);
|
|
|
2971 end loop;
|
|
|
2972
|
|
|
2973 Command_Last := Command_Last + 1;
|
|
|
2974 Command (Command_Last) := ASCII.NUL;
|
|
|
2975
|
|
|
2976 Arg_List_Last := Arg_List_Last + 1;
|
|
|
2977 Arg_List (Arg_List_Last) := Command (First)'Access;
|
|
|
2978 end Add_To_Command;
|
|
|
2979
|
|
|
2980 -- Start of processing for Spawn
|
|
|
2981
|
|
|
2982 begin
|
|
|
2983 Add_To_Command (Program_Name);
|
|
|
2984
|
|
|
2985 for J in Args'Range loop
|
|
|
2986 Add_To_Command (Args (J).all);
|
|
|
2987 end loop;
|
|
|
2988
|
|
|
2989 if Blocking then
|
|
|
2990 Pid := Invalid_Pid;
|
|
|
2991 Result := Portable_Spawn (Arg_List'Address);
|
|
|
2992 else
|
|
|
2993 Pid := Portable_No_Block_Spawn (Arg_List'Address);
|
|
|
2994 Result := Boolean'Pos (Pid /= Invalid_Pid);
|
|
|
2995 end if;
|
|
|
2996 end Spawn;
|
|
|
2997
|
|
|
2998 -- Start of processing for Spawn_Internal
|
|
|
2999
|
|
|
3000 begin
|
|
|
3001 -- Copy arguments into a local structure
|
|
|
3002
|
|
|
3003 for K in N_Args'Range loop
|
|
|
3004 N_Args (K) := new String'(Args (K).all);
|
|
|
3005 end loop;
|
|
|
3006
|
|
|
3007 -- Normalize those arguments
|
|
|
3008
|
|
|
3009 Normalize_Arguments (N_Args);
|
|
|
3010
|
|
|
3011 -- Call spawn using the normalized arguments
|
|
|
3012
|
|
|
3013 Spawn (N_Args);
|
|
|
3014
|
|
|
3015 -- Free arguments list
|
|
|
3016
|
|
|
3017 for K in N_Args'Range loop
|
|
|
3018 Free (N_Args (K));
|
|
|
3019 end loop;
|
|
|
3020 end Spawn_Internal;
|
|
|
3021
|
|
|
3022 ---------------------------
|
|
|
3023 -- To_Path_String_Access --
|
|
|
3024 ---------------------------
|
|
|
3025
|
|
|
3026 function To_Path_String_Access
|
|
|
3027 (Path_Addr : Address;
|
|
|
3028 Path_Len : Integer) return String_Access
|
|
|
3029 is
|
|
|
3030 subtype Path_String is String (1 .. Path_Len);
|
|
|
3031 type Path_String_Access is access Path_String;
|
|
|
3032
|
|
|
3033 function Address_To_Access is new Ada.Unchecked_Conversion
|
|
|
3034 (Source => Address, Target => Path_String_Access);
|
|
|
3035
|
|
|
3036 Path_Access : constant Path_String_Access :=
|
|
|
3037 Address_To_Access (Path_Addr);
|
|
|
3038
|
|
|
3039 Return_Val : String_Access;
|
|
|
3040
|
|
|
3041 begin
|
|
|
3042 Return_Val := new String (1 .. Path_Len);
|
|
|
3043
|
|
|
3044 for J in 1 .. Path_Len loop
|
|
|
3045 Return_Val (J) := Path_Access (J);
|
|
|
3046 end loop;
|
|
|
3047
|
|
|
3048 return Return_Val;
|
|
|
3049 end To_Path_String_Access;
|
|
|
3050
|
|
|
3051 ------------------
|
|
|
3052 -- Wait_Process --
|
|
|
3053 ------------------
|
|
|
3054
|
|
|
3055 procedure Wait_Process (Pid : out Process_Id; Success : out Boolean) is
|
|
|
3056 Status : Integer;
|
|
|
3057
|
|
|
3058 function Portable_Wait (S : Address) return Process_Id;
|
|
|
3059 pragma Import (C, Portable_Wait, "__gnat_portable_wait");
|
|
|
3060
|
|
|
3061 begin
|
|
|
3062 Pid := Portable_Wait (Status'Address);
|
|
|
3063 Success := (Status = 0);
|
|
|
3064 end Wait_Process;
|
|
|
3065
|
|
|
3066 -----------
|
|
|
3067 -- Write --
|
|
|
3068 -----------
|
|
|
3069
|
|
|
3070 function Write
|
|
|
3071 (FD : File_Descriptor;
|
|
|
3072 A : System.Address;
|
|
|
3073 N : Integer) return Integer
|
|
|
3074 is
|
|
|
3075 begin
|
|
|
3076 return
|
|
|
3077 Integer (System.CRTL.write
|
|
|
3078 (System.CRTL.int (FD),
|
|
|
3079 System.CRTL.chars (A),
|
|
|
3080 System.CRTL.size_t (N)));
|
|
|
3081 end Write;
|
|
|
3082
|
|
|
3083 end System.OS_Lib;
|
