1 ------------------------------------------------------------------------------
3 -- GNAT RUN-TIME COMPONENTS --
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 --
9 -- Copyright (C) 2007, Free Software Foundation, Inc. --
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 2, 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. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING. If not, write --
19 -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
20 -- Boston, MA 02110-1301, USA. --
22 -- As a special exception, if other files instantiate generics from this --
23 -- unit, or you link this unit with other files to produce an executable, --
24 -- this unit does not by itself cause the resulting executable to be --
25 -- covered by the GNU General Public License. This exception does not --
26 -- however invalidate any other reasons why the executable file might be --
27 -- covered by the GNU Public License. --
29 -- GNAT was originally developed by the GNAT team at New York University. --
30 -- Extensive contributions were provided by Ada Core Technologies Inc. --
32 ------------------------------------------------------------------------------
34 with Ada.Unchecked_Deallocation;
36 with System.OS_Lib; use System.OS_Lib;
38 package body Ada.Command_Line.Response_File is
41 type File_Ptr is access File_Rec;
42 type File_Rec is record
47 -- To build a stack of response file names
49 procedure Free is new Ada.Unchecked_Deallocation (File_Rec, File_Ptr);
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 the allocated String
61 function Arguments_From
62 (Response_File_Name : String;
63 Recursive : Boolean := False;
64 Ignore_Non_Existing_Files : Boolean := False)
67 First_File : File_Ptr := null;
68 Last_File : File_Ptr := null;
69 -- The stack of response files
71 Arguments : Argument_List_Access := new Argument_List (1 .. 4);
72 Last_Arg : Natural := 0;
74 procedure Add_Argument (Arg : String);
75 -- Add argument Arg to argument list Arguments, increasing Arguments
78 procedure Recurse (File_Name : String);
79 -- Get the arguments from the file and call itself recursively if
80 -- one of the argument starts with character '@'.
86 procedure Add_Argument (Arg : String) is
88 if Last_Arg = Arguments'Last then
90 New_Arguments : constant Argument_List_Access :=
91 new Argument_List (1 .. Arguments'Last * 2);
93 New_Arguments (Arguments'Range) := Arguments.all;
94 Arguments.all := (others => null);
96 Arguments := New_Arguments;
100 Last_Arg := Last_Arg + 1;
101 Arguments (Last_Arg) := new String'(Arg);
108 procedure Recurse (File_Name : String) is
109 FD : File_Descriptor;
111 Buffer_Size : constant := 1500;
112 Buffer : String (1 .. Buffer_Size);
114 Buffer_Length : Natural;
116 Buffer_Cursor : Natural;
118 End_Of_File_Reached : Boolean;
120 Line : String (1 .. Max_Line_Length + 1);
123 First_Char : Positive;
124 -- Index of the first character of an argument in Line
127 -- Index of the last character of an argument in Line
130 -- True when inside a quoted string
134 function End_Of_File return Boolean;
135 -- True when the end of the response file has been reached
137 procedure Get_Buffer;
138 -- Read one buffer from the response file
141 -- Get one line from the response file
147 function End_Of_File return Boolean is
149 return End_Of_File_Reached and then Buffer_Cursor > Buffer_Length;
156 procedure Get_Buffer is
158 Buffer_Length := Read (FD, Buffer (1)'Address, Buffer'Length);
159 End_Of_File_Reached := Buffer_Length < Buffer'Length;
167 procedure Get_Line is
177 Ch := Buffer (Buffer_Cursor);
179 exit when Ch = ASCII.CR or else
180 Ch = ASCII.LF or else
186 if Last = Line'Last then
190 Buffer_Cursor := Buffer_Cursor + 1;
192 if Buffer_Cursor > Buffer_Length then
202 Ch := Buffer (Buffer_Cursor);
204 exit when Ch /= ASCII.HT and then
205 Ch /= ASCII.LF and then
208 Buffer_Cursor := Buffer_Cursor + 1;
210 if Buffer_Cursor > Buffer_Length then
225 -- Open the response file. If not found, fail or report a warning,
226 -- depending on the value of Ignore_Non_Existing_Files.
228 FD := Open_Read (File_Name, Text);
230 if FD = Invalid_FD then
231 if Ignore_Non_Existing_Files then
235 raise File_Does_Not_Exist;
239 -- Put the response file name on the stack
241 if First_File = null then
244 (Name => new String'(File_Name),
247 Last_File := First_File;
250 Current : File_Ptr := First_File;
253 if Current.Name.all = File_Name then
254 raise Circularity_Detected;
257 Current := Current.Next;
258 exit when Current = null;
263 (Name => new String'(File_Name),
266 Last_File := Last_File.Next;
270 End_Of_File_Reached := False;
273 -- Read the response file line by line
276 while not End_Of_File loop
279 if Last = Line'Last then
285 -- Get each argument on the line
289 -- First, skip any white space
291 while First_Char <= Last loop
292 exit when Line (First_Char) /= ' ' and then
293 Line (First_Char) /= ASCII.HT;
294 First_Char := First_Char + 1;
297 exit Arg_Loop when First_Char > Last;
299 Last_Char := First_Char;
302 -- Get the character one by one
305 while Last_Char <= Last loop
306 -- Inside a string, check only for '"'
309 if Line (Last_Char) = '"' then
312 Line (Last_Char .. Last - 1) :=
313 Line (Last_Char + 1 .. Last);
316 -- End of string is end of argument
317 if Last_Char > Last or else
318 Line (Last_Char) = ' ' or else
319 Line (Last_Char) = ASCII.HT
323 Last_Char := Last_Char - 1;
327 -- If there are two consecutive '"', the quoted
328 -- string is not closed
330 In_String := Line (Last_Char) = '"';
333 Last_Char := Last_Char + 1;
338 Last_Char := Last_Char + 1;
341 elsif Last_Char = Last then
342 -- An opening '"' at the end of the line is an error
344 if Line (Last) = '"' then
345 raise No_Closing_Quote;
348 -- The argument ends with the line
353 elsif Line (Last_Char) = '"' then
354 -- Entering a quoted string: remove the '"'
357 Line (Last_Char .. Last - 1) :=
358 Line (Last_Char + 1 .. Last);
362 -- Outside of quoted strings, white space ends the
366 when Line (Last_Char + 1) = ' ' or else
367 Line (Last_Char + 1) = ASCII.HT;
369 Last_Char := Last_Char + 1;
371 end loop Character_Loop;
373 -- It is an error to not close a quoted string before the end
377 raise No_Closing_Quote;
380 -- Add the argument to the list
383 Arg : String (1 .. Last_Char - First_Char + 1);
385 Arg := Line (First_Char .. Last_Char);
389 -- Next argument, if line is not finished
391 First_Char := Last_Char + 1;
397 -- If Recursive is True, check for any argument starting with '@'
401 while Arg <= Last_Arg loop
403 if Arguments (Arg)'Length > 0 and then
404 Arguments (Arg) (1) = '@'
406 -- Ignore argument "@" with no file name
408 if Arguments (Arg)'Length = 1 then
409 Arguments (Arg .. Last_Arg - 1) :=
410 Arguments (Arg + 1 .. Last_Arg);
411 Last_Arg := Last_Arg - 1;
414 -- Save the current arguments and get those in the
415 -- new response file.
418 Inc_File_Name : constant String :=
420 (2 .. Arguments (Arg)'Last);
421 Current_Arguments : constant Argument_List :=
422 Arguments (1 .. Last_Arg);
424 Recurse (Inc_File_Name);
426 -- Insert the new arguments where the new response
427 -- file was imported.
430 New_Arguments : constant Argument_List :=
431 Arguments (1 .. Last_Arg);
432 New_Last_Arg : constant Positive :=
433 Current_Arguments'Length +
434 New_Arguments'Length - 1;
437 -- Grow Arguments if it is not large enough
438 if Arguments'Last < New_Last_Arg then
439 Last_Arg := Arguments'Last;
442 while Last_Arg < New_Last_Arg loop
443 Last_Arg := Last_Arg * 2;
446 Arguments := new Argument_List (1 .. Last_Arg);
449 Last_Arg := New_Last_Arg;
451 Arguments (1 .. Last_Arg) :=
452 Current_Arguments (1 .. Arg - 1) &
455 (Arg + 1 .. Current_Arguments'Last);
457 Arg := Arg + New_Arguments'Length;
468 -- Remove the response file name from the stack
470 if First_File = Last_File then
471 System.Strings.Free (First_File.Name);
477 System.Strings.Free (Last_File.Name);
478 Last_File := Last_File.Prev;
479 Free (Last_File.Next);
489 -- Start of Arguments_From
492 -- The job is done by procedure Recurse
494 Recurse (Response_File_Name);
496 -- Free Arguments before returning the result
499 Result : constant Argument_List := Arguments (1 .. Last_Arg);
507 -- When an exception occurs, deallocate everything
511 while First_File /= null loop
512 Last_File := First_File.Next;
513 System.Strings.Free (First_File.Name);
515 First_File := Last_File;
521 end Ada.Command_Line.Response_File;