1------------------------------------------------------------------------------ 2-- -- 3-- GNAT RUN-TIME COMPONENTS -- 4-- -- 5-- S Y S T E M . R E S P O N S E _ F I L E -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 2007-2018, 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-- As a special exception under Section 7 of GPL version 3, you are granted -- 19-- additional permissions described in the GCC Runtime Library Exception, -- 20-- version 3.1, as published by the Free Software Foundation. -- 21-- -- 22-- You should have received a copy of the GNU General Public License and -- 23-- a copy of the GCC Runtime Library Exception along with this program; -- 24-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- 25-- <http://www.gnu.org/licenses/>. -- 26-- -- 27-- GNAT was originally developed by the GNAT team at New York University. -- 28-- Extensive contributions were provided by Ada Core Technologies Inc. -- 29-- -- 30------------------------------------------------------------------------------ 31 32pragma Compiler_Unit_Warning; 33 34with Ada.Unchecked_Deallocation; 35 36with System.OS_Lib; use System.OS_Lib; 37 38package body System.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 arguments 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 -- Open the response file. If not found, fail or report a warning, 109 -- depending on the value of Ignore_Non_Existing_Files. 110 111 FD : constant File_Descriptor := Open_Read (File_Name, Text); 112 113 Buffer_Size : constant := 1500; 114 Buffer : String (1 .. Buffer_Size); 115 116 Buffer_Length : Natural; 117 118 Buffer_Cursor : Natural; 119 120 End_Of_File_Reached : Boolean; 121 122 Line : String (1 .. Max_Line_Length + 1); 123 Last : Natural; 124 125 First_Char : Positive; 126 -- Index of the first character of an argument in Line 127 128 Last_Char : Natural; 129 -- Index of the last character of an argument in Line 130 131 In_String : Boolean; 132 -- True when inside a quoted string 133 134 Arg : Positive; 135 136 function End_Of_File return Boolean; 137 -- True when the end of the response file has been reached 138 139 procedure Get_Buffer; 140 -- Read one buffer from the response file 141 142 procedure Get_Line; 143 -- Get one line from the response file 144 145 ----------------- 146 -- End_Of_File -- 147 ----------------- 148 149 function End_Of_File return Boolean is 150 begin 151 return End_Of_File_Reached and then Buffer_Cursor > Buffer_Length; 152 end End_Of_File; 153 154 ---------------- 155 -- Get_Buffer -- 156 ---------------- 157 158 procedure Get_Buffer is 159 begin 160 Buffer_Length := Read (FD, Buffer (1)'Address, Buffer'Length); 161 End_Of_File_Reached := Buffer_Length < Buffer'Length; 162 Buffer_Cursor := 1; 163 end Get_Buffer; 164 165 -------------- 166 -- Get_Line -- 167 -------------- 168 169 procedure Get_Line is 170 Ch : Character; 171 172 begin 173 Last := 0; 174 175 if End_Of_File then 176 return; 177 end if; 178 179 loop 180 Ch := Buffer (Buffer_Cursor); 181 182 exit when Ch = ASCII.CR or else 183 Ch = ASCII.LF or else 184 Ch = ASCII.FF; 185 186 Last := Last + 1; 187 Line (Last) := Ch; 188 189 if Last = Line'Last then 190 return; 191 end if; 192 193 Buffer_Cursor := Buffer_Cursor + 1; 194 195 if Buffer_Cursor > Buffer_Length then 196 Get_Buffer; 197 198 if End_Of_File then 199 return; 200 end if; 201 end if; 202 end loop; 203 204 loop 205 Ch := Buffer (Buffer_Cursor); 206 207 exit when Ch /= ASCII.HT and then 208 Ch /= ASCII.LF and then 209 Ch /= ASCII.FF; 210 211 Buffer_Cursor := Buffer_Cursor + 1; 212 213 if Buffer_Cursor > Buffer_Length then 214 Get_Buffer; 215 216 if End_Of_File then 217 return; 218 end if; 219 end if; 220 end loop; 221 end Get_Line; 222 223 -- Start of processing for Recurse 224 225 begin 226 Last_Arg := 0; 227 228 if FD = Invalid_FD then 229 if Ignore_Non_Existing_Files then 230 return; 231 else 232 raise File_Does_Not_Exist; 233 end if; 234 end if; 235 236 -- Put the response file name on the stack 237 238 if First_File = null then 239 First_File := 240 new File_Rec' 241 (Name => new String'(File_Name), 242 Next => null, 243 Prev => null); 244 Last_File := First_File; 245 246 else 247 declare 248 Current : File_Ptr := First_File; 249 250 begin 251 loop 252 if Current.Name.all = File_Name then 253 raise Circularity_Detected; 254 end if; 255 256 Current := Current.Next; 257 exit when Current = null; 258 end loop; 259 260 Last_File.Next := 261 new File_Rec' 262 (Name => new String'(File_Name), 263 Next => null, 264 Prev => Last_File); 265 Last_File := Last_File.Next; 266 end; 267 end if; 268 269 End_Of_File_Reached := False; 270 Get_Buffer; 271 272 -- Read the response file line by line 273 274 Line_Loop : 275 while not End_Of_File loop 276 Get_Line; 277 278 if Last = Line'Last then 279 raise Line_Too_Long; 280 end if; 281 282 First_Char := 1; 283 284 -- Get each argument on the line 285 286 Arg_Loop : 287 loop 288 -- First, skip any white space 289 290 while First_Char <= Last loop 291 exit when Line (First_Char) /= ' ' and then 292 Line (First_Char) /= ASCII.HT; 293 First_Char := First_Char + 1; 294 end loop; 295 296 exit Arg_Loop when First_Char > Last; 297 298 Last_Char := First_Char; 299 In_String := False; 300 301 -- Get the character one by one 302 303 Character_Loop : 304 while Last_Char <= Last loop 305 306 -- Inside a string, check only for '"' 307 308 if In_String then 309 if Line (Last_Char) = '"' then 310 311 -- Remove the '"' 312 313 Line (Last_Char .. Last - 1) := 314 Line (Last_Char + 1 .. Last); 315 Last := Last - 1; 316 317 -- End of string is end of argument 318 319 if Last_Char > Last or else 320 Line (Last_Char) = ' ' or else 321 Line (Last_Char) = ASCII.HT 322 then 323 In_String := False; 324 325 Last_Char := Last_Char - 1; 326 exit Character_Loop; 327 328 else 329 -- If there are two consecutive '"', the quoted 330 -- string is not closed 331 332 In_String := Line (Last_Char) = '"'; 333 334 if In_String then 335 Last_Char := Last_Char + 1; 336 end if; 337 end if; 338 339 else 340 Last_Char := Last_Char + 1; 341 end if; 342 343 elsif Last_Char = Last then 344 345 -- An opening '"' at the end of the line is an error 346 347 if Line (Last) = '"' then 348 raise No_Closing_Quote; 349 350 else 351 -- The argument ends with the line 352 353 exit Character_Loop; 354 end if; 355 356 elsif Line (Last_Char) = '"' then 357 358 -- Entering a quoted string: remove the '"' 359 360 In_String := True; 361 Line (Last_Char .. Last - 1) := 362 Line (Last_Char + 1 .. Last); 363 Last := Last - 1; 364 365 else 366 -- Outside quoted strings, white space ends the argument 367 368 exit Character_Loop 369 when Line (Last_Char + 1) = ' ' or else 370 Line (Last_Char + 1) = ASCII.HT; 371 372 Last_Char := Last_Char + 1; 373 end if; 374 end loop Character_Loop; 375 376 -- It is an error to not close a quoted string before the end 377 -- of the line. 378 379 if In_String then 380 raise No_Closing_Quote; 381 end if; 382 383 -- Add the argument to the list 384 385 declare 386 Arg : String (1 .. Last_Char - First_Char + 1); 387 begin 388 Arg := Line (First_Char .. Last_Char); 389 Add_Argument (Arg); 390 end; 391 392 -- Next argument, if line is not finished 393 394 First_Char := Last_Char + 1; 395 end loop Arg_Loop; 396 end loop Line_Loop; 397 398 Close (FD); 399 400 -- If Recursive is True, check for any argument starting with '@' 401 402 if Recursive then 403 Arg := 1; 404 while Arg <= Last_Arg loop 405 406 if Arguments (Arg)'Length > 0 and then 407 Arguments (Arg) (1) = '@' 408 then 409 -- Ignore argument '@' with no file name 410 411 if Arguments (Arg)'Length = 1 then 412 Arguments (Arg .. Last_Arg - 1) := 413 Arguments (Arg + 1 .. Last_Arg); 414 Last_Arg := Last_Arg - 1; 415 416 else 417 -- Save the current arguments and get those in the new 418 -- response file. 419 420 declare 421 Inc_File_Name : constant String := 422 Arguments (Arg) (2 .. Arguments (Arg)'Last); 423 Current_Arguments : constant Argument_List := 424 Arguments (1 .. Last_Arg); 425 begin 426 Recurse (Inc_File_Name); 427 428 -- Insert the new arguments where the new response 429 -- file was imported. 430 431 declare 432 New_Arguments : constant Argument_List := 433 Arguments (1 .. Last_Arg); 434 New_Last_Arg : constant Positive := 435 Current_Arguments'Length + 436 New_Arguments'Length - 1; 437 438 begin 439 -- Grow Arguments if it is not large enough 440 441 if Arguments'Last < New_Last_Arg then 442 Last_Arg := Arguments'Last; 443 Free (Arguments); 444 445 while Last_Arg < New_Last_Arg loop 446 Last_Arg := Last_Arg * 2; 447 end loop; 448 449 Arguments := new Argument_List (1 .. Last_Arg); 450 end if; 451 452 Last_Arg := New_Last_Arg; 453 454 Arguments (1 .. Last_Arg) := 455 Current_Arguments (1 .. Arg - 1) & 456 New_Arguments & 457 Current_Arguments 458 (Arg + 1 .. Current_Arguments'Last); 459 460 Arg := Arg + New_Arguments'Length; 461 end; 462 end; 463 end if; 464 465 else 466 Arg := Arg + 1; 467 end if; 468 end loop; 469 end if; 470 471 -- Remove the response file name from the stack 472 473 if First_File = Last_File then 474 System.Strings.Free (First_File.Name); 475 Free (First_File); 476 First_File := null; 477 Last_File := null; 478 479 else 480 System.Strings.Free (Last_File.Name); 481 Last_File := Last_File.Prev; 482 Free (Last_File.Next); 483 end if; 484 485 exception 486 when others => 487 Close (FD); 488 489 raise; 490 end Recurse; 491 492 -- Start of processing for Arguments_From 493 494 begin 495 -- The job is done by procedure Recurse 496 497 Recurse (Response_File_Name); 498 499 -- Free Arguments before returning the result 500 501 declare 502 Result : constant Argument_List := Arguments (1 .. Last_Arg); 503 begin 504 Free (Arguments); 505 return Result; 506 end; 507 508 exception 509 when others => 510 511 -- When an exception occurs, deallocate everything 512 513 Free (Arguments); 514 515 while First_File /= null loop 516 Last_File := First_File.Next; 517 System.Strings.Free (First_File.Name); 518 Free (First_File); 519 First_File := Last_File; 520 end loop; 521 522 raise; 523 end Arguments_From; 524 525end System.Response_File; 526