Mercurial > hg > CbC > CbC_gcc
comparison gcc/ada/libgnat/s-os_lib.adb @ 111:04ced10e8804
gcc 7
author | kono |
---|---|
date | Fri, 27 Oct 2017 22:46:09 +0900 |
parents | |
children | 84e7813d76e9 |
comparison
equal
deleted
inserted
replaced
68:561a7518be6b | 111:04ced10e8804 |
---|---|
1 ------------------------------------------------------------------------------ | |
2 -- -- | |
3 -- GNAT 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; |