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