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