File : a-clrefi.adb
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT RUN-TIME COMPONENTS --
4 -- --
5 -- A D A . C O M M A N D _ L I N E . R E S P O N S E _ F I L E --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 2007-2015, Free Software Foundation, Inc. --
10 -- --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. --
17 -- --
18 -- --
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_Deallocation;
35
36 with System.OS_Lib; use System.OS_Lib;
37
38 package body Ada.Command_Line.Response_File is
39
40 type File_Rec;
41 type File_Ptr is access File_Rec;
42 type File_Rec is record
43 Name : String_Access;
44 Next : File_Ptr;
45 Prev : File_Ptr;
46 end record;
47 -- To build a stack of response file names
48
49 procedure Free is new Ada.Unchecked_Deallocation (File_Rec, File_Ptr);
50
51 type Argument_List_Access is access Argument_List;
52 procedure Free is new Ada.Unchecked_Deallocation
53 (Argument_List, Argument_List_Access);
54 -- Free only the allocated Argument_List, not allocated String components
55
56 --------------------
57 -- Arguments_From --
58 --------------------
59
60 function Arguments_From
61 (Response_File_Name : String;
62 Recursive : Boolean := False;
63 Ignore_Non_Existing_Files : Boolean := False)
64 return Argument_List
65 is
66 First_File : File_Ptr := null;
67 Last_File : File_Ptr := null;
68 -- The stack of response files
69
70 Arguments : Argument_List_Access := new Argument_List (1 .. 4);
71 Last_Arg : Natural := 0;
72
73 procedure Add_Argument (Arg : String);
74 -- Add argument Arg to argument list Arguments, increasing Arguments
75 -- if necessary.
76
77 procedure Recurse (File_Name : String);
78 -- Get the arguments from the file and call itself recursively if one of
79 -- the argument starts with character '@'.
80
81 ------------------
82 -- Add_Argument --
83 ------------------
84
85 procedure Add_Argument (Arg : String) is
86 begin
87 if Last_Arg = Arguments'Last then
88 declare
89 New_Arguments : constant Argument_List_Access :=
90 new Argument_List (1 .. Arguments'Last * 2);
91 begin
92 New_Arguments (Arguments'Range) := Arguments.all;
93 Arguments.all := (others => null);
94 Free (Arguments);
95 Arguments := New_Arguments;
96 end;
97 end if;
98
99 Last_Arg := Last_Arg + 1;
100 Arguments (Last_Arg) := new String'(Arg);
101 end Add_Argument;
102
103 -------------
104 -- Recurse --
105 -------------
106
107 procedure Recurse (File_Name : String) is
108 FD : File_Descriptor;
109
110 Buffer_Size : constant := 1500;
111 Buffer : String (1 .. Buffer_Size);
112
113 Buffer_Length : Natural;
114
115 Buffer_Cursor : Natural;
116
117 End_Of_File_Reached : Boolean;
118
119 Line : String (1 .. Max_Line_Length + 1);
120 Last : Natural;
121
122 First_Char : Positive;
123 -- Index of the first character of an argument in Line
124
125 Last_Char : Natural;
126 -- Index of the last character of an argument in Line
127
128 In_String : Boolean;
129 -- True when inside a quoted string
130
131 Arg : Positive;
132
133 function End_Of_File return Boolean;
134 -- True when the end of the response file has been reached
135
136 procedure Get_Buffer;
137 -- Read one buffer from the response file
138
139 procedure Get_Line;
140 -- Get one line from the response file
141
142 -----------------
143 -- End_Of_File --
144 -----------------
145
146 function End_Of_File return Boolean is
147 begin
148 return End_Of_File_Reached and then Buffer_Cursor > Buffer_Length;
149 end End_Of_File;
150
151 ----------------
152 -- Get_Buffer --
153 ----------------
154
155 procedure Get_Buffer is
156 begin
157 Buffer_Length := Read (FD, Buffer (1)'Address, Buffer'Length);
158 End_Of_File_Reached := Buffer_Length < Buffer'Length;
159 Buffer_Cursor := 1;
160 end Get_Buffer;
161
162 --------------
163 -- Get_Line --
164 --------------
165
166 procedure Get_Line is
167 Ch : Character;
168
169 begin
170 Last := 0;
171
172 if End_Of_File then
173 return;
174 end if;
175
176 loop
177 Ch := Buffer (Buffer_Cursor);
178
179 exit when Ch = ASCII.CR or else
180 Ch = ASCII.LF or else
181 Ch = ASCII.FF;
182
183 Last := Last + 1;
184 Line (Last) := Ch;
185
186 if Last = Line'Last then
187 return;
188 end if;
189
190 Buffer_Cursor := Buffer_Cursor + 1;
191
192 if Buffer_Cursor > Buffer_Length then
193 Get_Buffer;
194
195 if End_Of_File then
196 return;
197 end if;
198 end if;
199 end loop;
200
201 loop
202 Ch := Buffer (Buffer_Cursor);
203
204 exit when Ch /= ASCII.HT and then
205 Ch /= ASCII.LF and then
206 Ch /= ASCII.FF;
207
208 Buffer_Cursor := Buffer_Cursor + 1;
209
210 if Buffer_Cursor > Buffer_Length then
211 Get_Buffer;
212
213 if End_Of_File then
214 return;
215 end if;
216 end if;
217 end loop;
218 end Get_Line;
219
220 -- Start of processing for Recurse
221
222 begin
223 Last_Arg := 0;
224
225 -- Open the response file. If not found, fail or report a warning,
226 -- depending on the value of Ignore_Non_Existing_Files.
227
228 FD := Open_Read (File_Name, Text);
229
230 if FD = Invalid_FD then
231 if Ignore_Non_Existing_Files then
232 return;
233 else
234 raise File_Does_Not_Exist;
235 end if;
236 end if;
237
238 -- Put the response file name on the stack
239
240 if First_File = null then
241 First_File :=
242 new File_Rec'
243 (Name => new String'(File_Name),
244 Next => null,
245 Prev => null);
246 Last_File := First_File;
247
248 else
249 declare
250 Current : File_Ptr := First_File;
251
252 begin
253 loop
254 if Current.Name.all = File_Name then
255 raise Circularity_Detected;
256 end if;
257
258 Current := Current.Next;
259 exit when Current = null;
260 end loop;
261
262 Last_File.Next :=
263 new File_Rec'
264 (Name => new String'(File_Name),
265 Next => null,
266 Prev => Last_File);
267 Last_File := Last_File.Next;
268 end;
269 end if;
270
271 End_Of_File_Reached := False;
272 Get_Buffer;
273
274 -- Read the response file line by line
275
276 Line_Loop :
277 while not End_Of_File loop
278 Get_Line;
279
280 if Last = Line'Last then
281 raise Line_Too_Long;
282 end if;
283
284 First_Char := 1;
285
286 -- Get each argument on the line
287
288 Arg_Loop :
289 loop
290 -- First, skip any white space
291
292 while First_Char <= Last loop
293 exit when Line (First_Char) /= ' ' and then
294 Line (First_Char) /= ASCII.HT;
295 First_Char := First_Char + 1;
296 end loop;
297
298 exit Arg_Loop when First_Char > Last;
299
300 Last_Char := First_Char;
301 In_String := False;
302
303 -- Get the character one by one
304
305 Character_Loop :
306 while Last_Char <= Last loop
307
308 -- Inside a string, check only for '"'
309
310 if In_String then
311 if Line (Last_Char) = '"' then
312
313 -- Remove the '"'
314
315 Line (Last_Char .. Last - 1) :=
316 Line (Last_Char + 1 .. Last);
317 Last := Last - 1;
318
319 -- End of string is end of argument
320
321 if Last_Char > Last or else
322 Line (Last_Char) = ' ' or else
323 Line (Last_Char) = ASCII.HT
324 then
325 In_String := False;
326
327 Last_Char := Last_Char - 1;
328 exit Character_Loop;
329
330 else
331 -- If there are two consecutive '"', the quoted
332 -- string is not closed
333
334 In_String := Line (Last_Char) = '"';
335
336 if In_String then
337 Last_Char := Last_Char + 1;
338 end if;
339 end if;
340
341 else
342 Last_Char := Last_Char + 1;
343 end if;
344
345 elsif Last_Char = Last then
346
347 -- An opening '"' at the end of the line is an error
348
349 if Line (Last) = '"' then
350 raise No_Closing_Quote;
351
352 else
353 -- The argument ends with the line
354
355 exit Character_Loop;
356 end if;
357
358 elsif Line (Last_Char) = '"' then
359
360 -- Entering a quoted string: remove the '"'
361
362 In_String := True;
363 Line (Last_Char .. Last - 1) :=
364 Line (Last_Char + 1 .. Last);
365 Last := Last - 1;
366
367 else
368 -- Outside quoted strings, white space ends the argument
369
370 exit Character_Loop
371 when Line (Last_Char + 1) = ' ' or else
372 Line (Last_Char + 1) = ASCII.HT;
373
374 Last_Char := Last_Char + 1;
375 end if;
376 end loop Character_Loop;
377
378 -- It is an error to not close a quoted string before the end
379 -- of the line.
380
381 if In_String then
382 raise No_Closing_Quote;
383 end if;
384
385 -- Add the argument to the list
386
387 declare
388 Arg : String (1 .. Last_Char - First_Char + 1);
389 begin
390 Arg := Line (First_Char .. Last_Char);
391 Add_Argument (Arg);
392 end;
393
394 -- Next argument, if line is not finished
395
396 First_Char := Last_Char + 1;
397 end loop Arg_Loop;
398 end loop Line_Loop;
399
400 Close (FD);
401
402 -- If Recursive is True, check for any argument starting with '@'
403
404 if Recursive then
405 Arg := 1;
406 while Arg <= Last_Arg loop
407
408 if Arguments (Arg)'Length > 0 and then
409 Arguments (Arg) (1) = '@'
410 then
411 -- Ignore argument "@" with no file name
412
413 if Arguments (Arg)'Length = 1 then
414 Arguments (Arg .. Last_Arg - 1) :=
415 Arguments (Arg + 1 .. Last_Arg);
416 Last_Arg := Last_Arg - 1;
417
418 else
419 -- Save the current arguments and get those in the new
420 -- response file.
421
422 declare
423 Inc_File_Name : constant String :=
424 Arguments (Arg) (2 .. Arguments (Arg)'Last);
425 Current_Arguments : constant Argument_List :=
426 Arguments (1 .. Last_Arg);
427 begin
428 Recurse (Inc_File_Name);
429
430 -- Insert the new arguments where the new response
431 -- file was imported.
432
433 declare
434 New_Arguments : constant Argument_List :=
435 Arguments (1 .. Last_Arg);
436 New_Last_Arg : constant Positive :=
437 Current_Arguments'Length +
438 New_Arguments'Length - 1;
439
440 begin
441 -- Grow Arguments if it is not large enough
442
443 if Arguments'Last < New_Last_Arg then
444 Last_Arg := Arguments'Last;
445 Free (Arguments);
446
447 while Last_Arg < New_Last_Arg loop
448 Last_Arg := Last_Arg * 2;
449 end loop;
450
451 Arguments := new Argument_List (1 .. Last_Arg);
452 end if;
453
454 Last_Arg := New_Last_Arg;
455
456 Arguments (1 .. Last_Arg) :=
457 Current_Arguments (1 .. Arg - 1) &
458 New_Arguments &
459 Current_Arguments
460 (Arg + 1 .. Current_Arguments'Last);
461
462 Arg := Arg + New_Arguments'Length;
463 end;
464 end;
465 end if;
466
467 else
468 Arg := Arg + 1;
469 end if;
470 end loop;
471 end if;
472
473 -- Remove the response file name from the stack
474
475 if First_File = Last_File then
476 System.Strings.Free (First_File.Name);
477 Free (First_File);
478 First_File := null;
479 Last_File := null;
480
481 else
482 System.Strings.Free (Last_File.Name);
483 Last_File := Last_File.Prev;
484 Free (Last_File.Next);
485 end if;
486
487 exception
488 when others =>
489 Close (FD);
490
491 raise;
492 end Recurse;
493
494 -- Start of processing for Arguments_From
495
496 begin
497 -- The job is done by procedure Recurse
498
499 Recurse (Response_File_Name);
500
501 -- Free Arguments before returning the result
502
503 declare
504 Result : constant Argument_List := Arguments (1 .. Last_Arg);
505 begin
506 Free (Arguments);
507 return Result;
508 end;
509
510 exception
511 when others =>
512
513 -- When an exception occurs, deallocate everything
514
515 Free (Arguments);
516
517 while First_File /= null loop
518 Last_File := First_File.Next;
519 System.Strings.Free (First_File.Name);
520 Free (First_File);
521 First_File := Last_File;
522 end loop;
523
524 raise;
525 end Arguments_From;
526
527 end Ada.Command_Line.Response_File;