1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- G N A T . D I R E C T O R Y _ O P E R A T I O N S -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1998-2012, 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-- 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 32with Ada.Characters.Handling; 33with Ada.Strings.Fixed; 34 35with Ada.Unchecked_Deallocation; 36with Ada.Unchecked_Conversion; 37 38with System; use System; 39with System.CRTL; use System.CRTL; 40 41with GNAT.OS_Lib; 42 43package body GNAT.Directory_Operations is 44 45 use Ada; 46 47 Filename_Max : constant Integer := 1024; 48 -- 1024 is the value of FILENAME_MAX in stdio.h 49 50 procedure Free is new 51 Ada.Unchecked_Deallocation (Dir_Type_Value, Dir_Type); 52 53 On_Windows : constant Boolean := GNAT.OS_Lib.Directory_Separator = '\'; 54 -- An indication that we are on Windows. Used in Get_Current_Dir, to 55 -- deal with drive letters in the beginning of absolute paths. 56 57 --------------- 58 -- Base_Name -- 59 --------------- 60 61 function Base_Name 62 (Path : Path_Name; 63 Suffix : String := "") return String 64 is 65 function Get_File_Names_Case_Sensitive return Integer; 66 pragma Import 67 (C, Get_File_Names_Case_Sensitive, 68 "__gnat_get_file_names_case_sensitive"); 69 70 Case_Sensitive_File_Name : constant Boolean := 71 Get_File_Names_Case_Sensitive = 1; 72 73 function Basename 74 (Path : Path_Name; 75 Suffix : String := "") return String; 76 -- This function does the job. The only difference between Basename 77 -- and Base_Name (the parent function) is that the former is case 78 -- sensitive, while the latter is not. Path and Suffix are adjusted 79 -- appropriately before calling Basename under platforms where the 80 -- file system is not case sensitive. 81 82 -------------- 83 -- Basename -- 84 -------------- 85 86 function Basename 87 (Path : Path_Name; 88 Suffix : String := "") return String 89 is 90 Cut_Start : Natural := 91 Strings.Fixed.Index 92 (Path, Dir_Seps, Going => Strings.Backward); 93 Cut_End : Natural; 94 95 begin 96 -- Cut_Start point to the first basename character 97 98 Cut_Start := (if Cut_Start = 0 then Path'First else Cut_Start + 1); 99 100 -- Cut_End point to the last basename character 101 102 Cut_End := Path'Last; 103 104 -- If basename ends with Suffix, adjust Cut_End 105 106 if Suffix /= "" 107 and then Path (Path'Last - Suffix'Length + 1 .. Cut_End) = Suffix 108 then 109 Cut_End := Path'Last - Suffix'Length; 110 end if; 111 112 Check_For_Standard_Dirs : declare 113 Offset : constant Integer := Path'First - Base_Name.Path'First; 114 BN : constant String := 115 Base_Name.Path (Cut_Start - Offset .. Cut_End - Offset); 116 -- Here we use Base_Name.Path to keep the original casing 117 118 Has_Drive_Letter : constant Boolean := 119 OS_Lib.Path_Separator /= ':'; 120 -- If Path separator is not ':' then we are on a DOS based OS 121 -- where this character is used as a drive letter separator. 122 123 begin 124 if BN = "." or else BN = ".." then 125 return ""; 126 127 elsif Has_Drive_Letter 128 and then BN'Length > 2 129 and then Characters.Handling.Is_Letter (BN (BN'First)) 130 and then BN (BN'First + 1) = ':' 131 then 132 -- We have a DOS drive letter prefix, remove it 133 134 return BN (BN'First + 2 .. BN'Last); 135 136 else 137 return BN; 138 end if; 139 end Check_For_Standard_Dirs; 140 end Basename; 141 142 -- Start of processing for Base_Name 143 144 begin 145 if Path'Length <= Suffix'Length then 146 return Path; 147 end if; 148 149 if Case_Sensitive_File_Name then 150 return Basename (Path, Suffix); 151 else 152 return Basename 153 (Characters.Handling.To_Lower (Path), 154 Characters.Handling.To_Lower (Suffix)); 155 end if; 156 end Base_Name; 157 158 ---------------- 159 -- Change_Dir -- 160 ---------------- 161 162 procedure Change_Dir (Dir_Name : Dir_Name_Str) is 163 C_Dir_Name : constant String := Dir_Name & ASCII.NUL; 164 begin 165 if chdir (C_Dir_Name) /= 0 then 166 raise Directory_Error; 167 end if; 168 end Change_Dir; 169 170 ----------- 171 -- Close -- 172 ----------- 173 174 procedure Close (Dir : in out Dir_Type) is 175 Discard : Integer; 176 pragma Warnings (Off, Discard); 177 178 function closedir (directory : DIRs) return Integer; 179 pragma Import (C, closedir, "__gnat_closedir"); 180 181 begin 182 if not Is_Open (Dir) then 183 raise Directory_Error; 184 end if; 185 186 Discard := closedir (DIRs (Dir.all)); 187 Free (Dir); 188 end Close; 189 190 -------------- 191 -- Dir_Name -- 192 -------------- 193 194 function Dir_Name (Path : Path_Name) return Dir_Name_Str is 195 Last_DS : constant Natural := 196 Strings.Fixed.Index 197 (Path, Dir_Seps, Going => Strings.Backward); 198 199 begin 200 if Last_DS = 0 then 201 202 -- There is no directory separator, returns current working directory 203 204 return "." & Dir_Separator; 205 206 else 207 return Path (Path'First .. Last_DS); 208 end if; 209 end Dir_Name; 210 211 ----------------- 212 -- Expand_Path -- 213 ----------------- 214 215 function Expand_Path 216 (Path : Path_Name; 217 Mode : Environment_Style := System_Default) return Path_Name 218 is 219 Environment_Variable_Char : Character; 220 pragma Import (C, Environment_Variable_Char, "__gnat_environment_char"); 221 222 Result : OS_Lib.String_Access := new String (1 .. 200); 223 Result_Last : Natural := 0; 224 225 procedure Append (C : Character); 226 procedure Append (S : String); 227 -- Append to Result 228 229 procedure Double_Result_Size; 230 -- Reallocate Result, doubling its size 231 232 function Is_Var_Prefix (C : Character) return Boolean; 233 pragma Inline (Is_Var_Prefix); 234 235 procedure Read (K : in out Positive); 236 -- Update Result while reading current Path starting at position K. If 237 -- a variable is found, call Var below. 238 239 procedure Var (K : in out Positive); 240 -- Translate variable name starting at position K with the associated 241 -- environment value. 242 243 ------------ 244 -- Append -- 245 ------------ 246 247 procedure Append (C : Character) is 248 begin 249 if Result_Last = Result'Last then 250 Double_Result_Size; 251 end if; 252 253 Result_Last := Result_Last + 1; 254 Result (Result_Last) := C; 255 end Append; 256 257 procedure Append (S : String) is 258 begin 259 while Result_Last + S'Length - 1 > Result'Last loop 260 Double_Result_Size; 261 end loop; 262 263 Result (Result_Last + 1 .. Result_Last + S'Length) := S; 264 Result_Last := Result_Last + S'Length; 265 end Append; 266 267 ------------------------ 268 -- Double_Result_Size -- 269 ------------------------ 270 271 procedure Double_Result_Size is 272 New_Result : constant OS_Lib.String_Access := 273 new String (1 .. 2 * Result'Last); 274 begin 275 New_Result (1 .. Result_Last) := Result (1 .. Result_Last); 276 OS_Lib.Free (Result); 277 Result := New_Result; 278 end Double_Result_Size; 279 280 ------------------- 281 -- Is_Var_Prefix -- 282 ------------------- 283 284 function Is_Var_Prefix (C : Character) return Boolean is 285 begin 286 return (C = Environment_Variable_Char and then Mode = System_Default) 287 or else 288 (C = '$' and then (Mode = UNIX or else Mode = Both)) 289 or else 290 (C = '%' and then (Mode = DOS or else Mode = Both)); 291 end Is_Var_Prefix; 292 293 ---------- 294 -- Read -- 295 ---------- 296 297 procedure Read (K : in out Positive) is 298 P : Character; 299 300 begin 301 For_All_Characters : loop 302 if Is_Var_Prefix (Path (K)) then 303 P := Path (K); 304 305 -- Could be a variable 306 307 if K < Path'Last then 308 if Path (K + 1) = P then 309 310 -- Not a variable after all, this is a double $ or %, 311 -- just insert one in the result string. 312 313 Append (P); 314 K := K + 1; 315 316 else 317 -- Let's parse the variable 318 319 Var (K); 320 end if; 321 322 else 323 -- We have an ending $ or % sign 324 325 Append (P); 326 end if; 327 328 else 329 -- This is a standard character, just add it to the result 330 331 Append (Path (K)); 332 end if; 333 334 -- Skip to next character 335 336 K := K + 1; 337 338 exit For_All_Characters when K > Path'Last; 339 end loop For_All_Characters; 340 end Read; 341 342 --------- 343 -- Var -- 344 --------- 345 346 procedure Var (K : in out Positive) is 347 P : constant Character := Path (K); 348 T : Character; 349 E : Positive; 350 351 begin 352 K := K + 1; 353 354 if P = '%' or else Path (K) = '{' then 355 356 -- Set terminator character 357 358 if P = '%' then 359 T := '%'; 360 else 361 T := '}'; 362 K := K + 1; 363 end if; 364 365 -- Look for terminator character, k point to the first character 366 -- for the variable name. 367 368 E := K; 369 370 loop 371 E := E + 1; 372 exit when Path (E) = T or else E = Path'Last; 373 end loop; 374 375 if Path (E) = T then 376 377 -- OK found, translate with environment value 378 379 declare 380 Env : OS_Lib.String_Access := 381 OS_Lib.Getenv (Path (K .. E - 1)); 382 383 begin 384 Append (Env.all); 385 OS_Lib.Free (Env); 386 end; 387 388 else 389 -- No terminator character, not a variable after all or a 390 -- syntax error, ignore it, insert string as-is. 391 392 Append (P); -- Add prefix character 393 394 if T = '}' then -- If we were looking for curly bracket 395 Append ('{'); -- terminator, add the curly bracket 396 end if; 397 398 Append (Path (K .. E)); 399 end if; 400 401 else 402 -- The variable name is everything from current position to first 403 -- non letter/digit character. 404 405 E := K; 406 407 -- Check that first character is a letter 408 409 if Characters.Handling.Is_Letter (Path (E)) then 410 E := E + 1; 411 412 Var_Name : loop 413 exit Var_Name when E > Path'Last; 414 415 if Characters.Handling.Is_Letter (Path (E)) 416 or else Characters.Handling.Is_Digit (Path (E)) 417 then 418 E := E + 1; 419 else 420 exit Var_Name; 421 end if; 422 end loop Var_Name; 423 424 E := E - 1; 425 426 declare 427 Env : OS_Lib.String_Access := OS_Lib.Getenv (Path (K .. E)); 428 429 begin 430 Append (Env.all); 431 OS_Lib.Free (Env); 432 end; 433 434 else 435 -- This is not a variable after all 436 437 Append ('$'); 438 Append (Path (E)); 439 end if; 440 441 end if; 442 443 K := E; 444 end Var; 445 446 -- Start of processing for Expand_Path 447 448 begin 449 declare 450 K : Positive := Path'First; 451 452 begin 453 Read (K); 454 455 declare 456 Returned_Value : constant String := Result (1 .. Result_Last); 457 458 begin 459 OS_Lib.Free (Result); 460 return Returned_Value; 461 end; 462 end; 463 end Expand_Path; 464 465 -------------------- 466 -- File_Extension -- 467 -------------------- 468 469 function File_Extension (Path : Path_Name) return String is 470 First : Natural := 471 Strings.Fixed.Index 472 (Path, Dir_Seps, Going => Strings.Backward); 473 474 Dot : Natural; 475 476 begin 477 if First = 0 then 478 First := Path'First; 479 end if; 480 481 Dot := Strings.Fixed.Index (Path (First .. Path'Last), 482 ".", 483 Going => Strings.Backward); 484 485 if Dot = 0 or else Dot = Path'Last then 486 return ""; 487 else 488 return Path (Dot .. Path'Last); 489 end if; 490 end File_Extension; 491 492 --------------- 493 -- File_Name -- 494 --------------- 495 496 function File_Name (Path : Path_Name) return String is 497 begin 498 return Base_Name (Path); 499 end File_Name; 500 501 --------------------- 502 -- Format_Pathname -- 503 --------------------- 504 505 function Format_Pathname 506 (Path : Path_Name; 507 Style : Path_Style := System_Default) return String 508 is 509 N_Path : String := Path; 510 K : Positive := N_Path'First; 511 Prev_Dirsep : Boolean := False; 512 513 begin 514 if Dir_Separator = '\' 515 and then Path'Length > 1 516 and then Path (K .. K + 1) = "\\" 517 then 518 if Style = UNIX then 519 N_Path (K .. K + 1) := "//"; 520 end if; 521 522 K := K + 2; 523 end if; 524 525 for J in K .. Path'Last loop 526 if Strings.Maps.Is_In (Path (J), Dir_Seps) then 527 if not Prev_Dirsep then 528 case Style is 529 when UNIX => N_Path (K) := '/'; 530 when DOS => N_Path (K) := '\'; 531 when System_Default => N_Path (K) := Dir_Separator; 532 end case; 533 534 K := K + 1; 535 end if; 536 537 Prev_Dirsep := True; 538 539 else 540 N_Path (K) := Path (J); 541 K := K + 1; 542 Prev_Dirsep := False; 543 end if; 544 end loop; 545 546 return N_Path (N_Path'First .. K - 1); 547 end Format_Pathname; 548 549 --------------------- 550 -- Get_Current_Dir -- 551 --------------------- 552 553 Max_Path : Integer; 554 pragma Import (C, Max_Path, "__gnat_max_path_len"); 555 556 function Get_Current_Dir return Dir_Name_Str is 557 Current_Dir : String (1 .. Max_Path + 1); 558 Last : Natural; 559 begin 560 Get_Current_Dir (Current_Dir, Last); 561 return Current_Dir (1 .. Last); 562 end Get_Current_Dir; 563 564 procedure Get_Current_Dir (Dir : out Dir_Name_Str; Last : out Natural) is 565 Path_Len : Natural := Max_Path; 566 Buffer : String (Dir'First .. Dir'First + Max_Path + 1); 567 568 procedure Local_Get_Current_Dir 569 (Dir : System.Address; 570 Length : System.Address); 571 pragma Import (C, Local_Get_Current_Dir, "__gnat_get_current_dir"); 572 573 begin 574 Local_Get_Current_Dir (Buffer'Address, Path_Len'Address); 575 576 Last := 577 (if Dir'Length > Path_Len then Dir'First + Path_Len - 1 else Dir'Last); 578 579 Dir (Buffer'First .. Last) := Buffer (Buffer'First .. Last); 580 581 -- By default, the drive letter on Windows is in upper case 582 583 if On_Windows and then Last > Dir'First and then 584 Dir (Dir'First + 1) = ':' 585 then 586 Dir (Dir'First) := 587 Ada.Characters.Handling.To_Upper (Dir (Dir'First)); 588 end if; 589 end Get_Current_Dir; 590 591 ------------- 592 -- Is_Open -- 593 ------------- 594 595 function Is_Open (Dir : Dir_Type) return Boolean is 596 begin 597 return Dir /= Null_Dir 598 and then System.Address (Dir.all) /= System.Null_Address; 599 end Is_Open; 600 601 -------------- 602 -- Make_Dir -- 603 -------------- 604 605 procedure Make_Dir (Dir_Name : Dir_Name_Str) is 606 C_Dir_Name : constant String := Dir_Name & ASCII.NUL; 607 begin 608 if CRTL.mkdir (C_Dir_Name, Unspecified) /= 0 then 609 raise Directory_Error; 610 end if; 611 end Make_Dir; 612 613 ---------- 614 -- Open -- 615 ---------- 616 617 procedure Open 618 (Dir : out Dir_Type; 619 Dir_Name : Dir_Name_Str) 620 is 621 function opendir (file_name : String) return DIRs; 622 pragma Import (C, opendir, "__gnat_opendir"); 623 624 C_File_Name : constant String := Dir_Name & ASCII.NUL; 625 626 begin 627 Dir := new Dir_Type_Value'(Dir_Type_Value (opendir (C_File_Name))); 628 629 if not Is_Open (Dir) then 630 Free (Dir); 631 Dir := Null_Dir; 632 raise Directory_Error; 633 end if; 634 end Open; 635 636 ---------- 637 -- Read -- 638 ---------- 639 640 procedure Read 641 (Dir : Dir_Type; 642 Str : out String; 643 Last : out Natural) 644 is 645 Filename_Addr : Address; 646 Filename_Len : aliased Integer; 647 648 Buffer : array (0 .. Filename_Max + 12) of Character; 649 -- 12 is the size of the dirent structure (see dirent.h), without the 650 -- field for the filename. 651 652 function readdir_gnat 653 (Directory : System.Address; 654 Buffer : System.Address; 655 Last : not null access Integer) return System.Address; 656 pragma Import (C, readdir_gnat, "__gnat_readdir"); 657 658 begin 659 if not Is_Open (Dir) then 660 raise Directory_Error; 661 end if; 662 663 Filename_Addr := 664 readdir_gnat 665 (System.Address (Dir.all), Buffer'Address, Filename_Len'Access); 666 667 if Filename_Addr = System.Null_Address then 668 Last := 0; 669 return; 670 end if; 671 672 Last := 673 (if Str'Length > Filename_Len then Str'First + Filename_Len - 1 674 else Str'Last); 675 676 declare 677 subtype Path_String is String (1 .. Filename_Len); 678 type Path_String_Access is access Path_String; 679 680 function Address_To_Access is new 681 Ada.Unchecked_Conversion 682 (Source => Address, 683 Target => Path_String_Access); 684 685 Path_Access : constant Path_String_Access := 686 Address_To_Access (Filename_Addr); 687 688 begin 689 for J in Str'First .. Last loop 690 Str (J) := Path_Access (J - Str'First + 1); 691 end loop; 692 end; 693 end Read; 694 695 ------------------------- 696 -- Read_Is_Thread_Sage -- 697 ------------------------- 698 699 function Read_Is_Thread_Safe return Boolean is 700 function readdir_is_thread_safe return Integer; 701 pragma Import 702 (C, readdir_is_thread_safe, "__gnat_readdir_is_thread_safe"); 703 begin 704 return (readdir_is_thread_safe /= 0); 705 end Read_Is_Thread_Safe; 706 707 ---------------- 708 -- Remove_Dir -- 709 ---------------- 710 711 procedure Remove_Dir 712 (Dir_Name : Dir_Name_Str; 713 Recursive : Boolean := False) 714 is 715 C_Dir_Name : constant String := Dir_Name & ASCII.NUL; 716 Last : Integer; 717 Str : String (1 .. Filename_Max); 718 Success : Boolean; 719 Current_Dir : Dir_Type; 720 721 begin 722 -- Remove the directory only if it is empty 723 724 if not Recursive then 725 if rmdir (C_Dir_Name) /= 0 then 726 raise Directory_Error; 727 end if; 728 729 -- Remove directory and all files and directories that it may contain 730 731 else 732 Open (Current_Dir, Dir_Name); 733 734 loop 735 Read (Current_Dir, Str, Last); 736 exit when Last = 0; 737 738 if GNAT.OS_Lib.Is_Directory 739 (Dir_Name & Dir_Separator & Str (1 .. Last)) 740 then 741 if Str (1 .. Last) /= "." 742 and then 743 Str (1 .. Last) /= ".." 744 then 745 -- Recursive call to remove a subdirectory and all its 746 -- files. 747 748 Remove_Dir 749 (Dir_Name & Dir_Separator & Str (1 .. Last), 750 True); 751 end if; 752 753 else 754 GNAT.OS_Lib.Delete_File 755 (Dir_Name & Dir_Separator & Str (1 .. Last), 756 Success); 757 758 if not Success then 759 raise Directory_Error; 760 end if; 761 end if; 762 end loop; 763 764 Close (Current_Dir); 765 Remove_Dir (Dir_Name); 766 end if; 767 end Remove_Dir; 768 769end GNAT.Directory_Operations; 770