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-2013, 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 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 or 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 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 527end Ada.Command_Line.Response_File; 528