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-2021, 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 pragma Annotate (CodePeer, Modified, P); 356 357 if P = '%' or else Path (K) = '{' then 358 359 -- Set terminator character 360 361 if P = '%' then 362 T := '%'; 363 else 364 T := '}'; 365 K := K + 1; 366 end if; 367 368 -- Look for terminator character, k point to the first character 369 -- for the variable name. 370 371 E := K; 372 373 loop 374 E := E + 1; 375 exit when Path (E) = T or else E = Path'Last; 376 end loop; 377 378 if Path (E) = T then 379 380 -- OK found, translate with environment value 381 382 declare 383 Env : OS_Lib.String_Access := 384 OS_Lib.Getenv (Path (K .. E - 1)); 385 386 begin 387 Append (Env.all); 388 OS_Lib.Free (Env); 389 end; 390 391 else 392 -- No terminator character, not a variable after all or a 393 -- syntax error, ignore it, insert string as-is. 394 395 Append (P); -- Add prefix character 396 397 if T = '}' then -- If we were looking for curly bracket 398 Append ('{'); -- terminator, add the curly bracket 399 end if; 400 401 Append (Path (K .. E)); 402 end if; 403 404 else 405 -- The variable name is everything from current position to first 406 -- non letter/digit character. 407 408 E := K; 409 410 -- Check that first character is a letter 411 412 if Characters.Handling.Is_Letter (Path (E)) then 413 E := E + 1; 414 415 Var_Name : loop 416 exit Var_Name when E > Path'Last; 417 418 if Characters.Handling.Is_Letter (Path (E)) 419 or else Characters.Handling.Is_Digit (Path (E)) 420 then 421 E := E + 1; 422 else 423 exit Var_Name; 424 end if; 425 end loop Var_Name; 426 427 E := E - 1; 428 429 declare 430 Env : OS_Lib.String_Access := OS_Lib.Getenv (Path (K .. E)); 431 432 begin 433 Append (Env.all); 434 OS_Lib.Free (Env); 435 end; 436 437 else 438 -- This is not a variable after all 439 440 Append ('$'); 441 Append (Path (E)); 442 end if; 443 444 end if; 445 446 K := E; 447 end Var; 448 449 -- Start of processing for Expand_Path 450 451 begin 452 declare 453 K : Positive := Path'First; 454 455 begin 456 Read (K); 457 458 declare 459 Returned_Value : constant String := Result (1 .. Result_Last); 460 461 begin 462 OS_Lib.Free (Result); 463 return Returned_Value; 464 end; 465 end; 466 end Expand_Path; 467 468 -------------------- 469 -- File_Extension -- 470 -------------------- 471 472 function File_Extension (Path : Path_Name) return String is 473 First : Natural := 474 Strings.Fixed.Index 475 (Path, Dir_Seps, Going => Strings.Backward); 476 477 Dot : Natural; 478 479 begin 480 if First = 0 then 481 First := Path'First; 482 end if; 483 484 Dot := Strings.Fixed.Index (Path (First .. Path'Last), 485 ".", 486 Going => Strings.Backward); 487 488 if Dot = 0 or else Dot = Path'Last then 489 return ""; 490 else 491 return Path (Dot .. Path'Last); 492 end if; 493 end File_Extension; 494 495 --------------- 496 -- File_Name -- 497 --------------- 498 499 function File_Name (Path : Path_Name) return String is 500 begin 501 return Base_Name (Path); 502 end File_Name; 503 504 --------------------- 505 -- Format_Pathname -- 506 --------------------- 507 508 function Format_Pathname 509 (Path : Path_Name; 510 Style : Path_Style := System_Default) return String 511 is 512 N_Path : String := Path; 513 K : Positive := N_Path'First; 514 Prev_Dirsep : Boolean := False; 515 516 begin 517 if Dir_Separator = '\' 518 and then Path'Length > 1 519 and then Path (K .. K + 1) = "\\" 520 then 521 if Style = UNIX then 522 N_Path (K .. K + 1) := "//"; 523 end if; 524 525 K := K + 2; 526 end if; 527 528 for J in K .. Path'Last loop 529 if Strings.Maps.Is_In (Path (J), Dir_Seps) then 530 if not Prev_Dirsep then 531 case Style is 532 when UNIX => N_Path (K) := '/'; 533 when DOS => N_Path (K) := '\'; 534 when System_Default => N_Path (K) := Dir_Separator; 535 end case; 536 537 K := K + 1; 538 end if; 539 540 Prev_Dirsep := True; 541 542 else 543 N_Path (K) := Path (J); 544 K := K + 1; 545 Prev_Dirsep := False; 546 end if; 547 end loop; 548 549 return N_Path (N_Path'First .. K - 1); 550 end Format_Pathname; 551 552 --------------------- 553 -- Get_Current_Dir -- 554 --------------------- 555 556 Max_Path : Integer; 557 pragma Import (C, Max_Path, "__gnat_max_path_len"); 558 559 function Get_Current_Dir return Dir_Name_Str is 560 Current_Dir : String (1 .. Max_Path + 1); 561 Last : Natural; 562 begin 563 Get_Current_Dir (Current_Dir, Last); 564 return Current_Dir (1 .. Last); 565 end Get_Current_Dir; 566 567 procedure Get_Current_Dir (Dir : out Dir_Name_Str; Last : out Natural) is 568 Path_Len : Natural := Max_Path; 569 Buffer : String (Dir'First .. Dir'First + Max_Path + 1); 570 571 procedure Local_Get_Current_Dir 572 (Dir : System.Address; 573 Length : System.Address); 574 pragma Import (C, Local_Get_Current_Dir, "__gnat_get_current_dir"); 575 576 begin 577 Local_Get_Current_Dir (Buffer'Address, Path_Len'Address); 578 579 if Path_Len = 0 then 580 raise Ada.IO_Exceptions.Use_Error 581 with "current directory does not exist"; 582 end if; 583 584 Last := 585 (if Dir'Length > Path_Len then Dir'First + Path_Len - 1 else Dir'Last); 586 587 Dir (Buffer'First .. Last) := Buffer (Buffer'First .. Last); 588 589 -- By default, the drive letter on Windows is in upper case 590 591 if On_Windows and then Last > Dir'First and then 592 Dir (Dir'First + 1) = ':' 593 then 594 Dir (Dir'First) := 595 Ada.Characters.Handling.To_Upper (Dir (Dir'First)); 596 end if; 597 end Get_Current_Dir; 598 599 ------------- 600 -- Is_Open -- 601 ------------- 602 603 function Is_Open (Dir : Dir_Type) return Boolean is 604 begin 605 return Dir /= Null_Dir 606 and then System.Address (Dir.all) /= System.Null_Address; 607 end Is_Open; 608 609 -------------- 610 -- Make_Dir -- 611 -------------- 612 613 procedure Make_Dir (Dir_Name : Dir_Name_Str) is 614 C_Dir_Name : constant String := Dir_Name & ASCII.NUL; 615 begin 616 if CRTL.mkdir (C_Dir_Name, Unspecified) /= 0 then 617 raise Directory_Error; 618 end if; 619 end Make_Dir; 620 621 ---------- 622 -- Open -- 623 ---------- 624 625 procedure Open 626 (Dir : out Dir_Type; 627 Dir_Name : Dir_Name_Str) 628 is 629 function opendir (file_name : String) return DIRs; 630 pragma Import (C, opendir, "__gnat_opendir"); 631 632 C_File_Name : constant String := Dir_Name & ASCII.NUL; 633 634 begin 635 Dir := new Dir_Type_Value'(Dir_Type_Value (opendir (C_File_Name))); 636 637 if not Is_Open (Dir) then 638 Free (Dir); 639 Dir := Null_Dir; 640 raise Directory_Error; 641 end if; 642 end Open; 643 644 ---------- 645 -- Read -- 646 ---------- 647 648 procedure Read 649 (Dir : Dir_Type; 650 Str : out String; 651 Last : out Natural) 652 is 653 Filename_Addr : Address; 654 Filename_Len : aliased Integer; 655 656 Buffer : array (0 .. Filename_Max + 12) of Character; 657 -- 12 is the size of the dirent structure (see dirent.h), without the 658 -- field for the filename. 659 660 function readdir_gnat 661 (Directory : System.Address; 662 Buffer : System.Address; 663 Last : not null access Integer) return System.Address; 664 pragma Import (C, readdir_gnat, "__gnat_readdir"); 665 666 begin 667 if not Is_Open (Dir) then 668 raise Directory_Error; 669 end if; 670 671 Filename_Addr := 672 readdir_gnat 673 (System.Address (Dir.all), Buffer'Address, Filename_Len'Access); 674 675 if Filename_Addr = System.Null_Address then 676 Last := 0; 677 return; 678 end if; 679 680 Last := 681 (if Str'Length > Filename_Len then Str'First + Filename_Len - 1 682 else Str'Last); 683 684 declare 685 subtype Path_String is String (1 .. Filename_Len); 686 type Path_String_Access is access Path_String; 687 688 function Address_To_Access is new 689 Ada.Unchecked_Conversion 690 (Source => Address, 691 Target => Path_String_Access); 692 693 Path_Access : constant Path_String_Access := 694 Address_To_Access (Filename_Addr); 695 696 begin 697 for J in Str'First .. Last loop 698 Str (J) := Path_Access (J - Str'First + 1); 699 end loop; 700 end; 701 end Read; 702 703 ------------------------- 704 -- Read_Is_Thread_Safe -- 705 ------------------------- 706 707 function Read_Is_Thread_Safe return Boolean is 708 function readdir_is_thread_safe return Integer; 709 pragma Import 710 (C, readdir_is_thread_safe, "__gnat_readdir_is_thread_safe"); 711 begin 712 return (readdir_is_thread_safe /= 0); 713 end Read_Is_Thread_Safe; 714 715 ---------------- 716 -- Remove_Dir -- 717 ---------------- 718 719 procedure Remove_Dir 720 (Dir_Name : Dir_Name_Str; 721 Recursive : Boolean := False) 722 is 723 C_Dir_Name : constant String := Dir_Name & ASCII.NUL; 724 Last : Integer; 725 Str : String (1 .. Filename_Max); 726 Success : Boolean; 727 Current_Dir : Dir_Type; 728 729 begin 730 -- Remove the directory only if it is empty 731 732 if not Recursive then 733 if rmdir (C_Dir_Name) /= 0 then 734 raise Directory_Error; 735 end if; 736 737 -- Remove directory and all files and directories that it may contain 738 739 else 740 Open (Current_Dir, Dir_Name); 741 742 loop 743 Read (Current_Dir, Str, Last); 744 exit when Last = 0; 745 746 if GNAT.OS_Lib.Is_Directory 747 (Dir_Name & Dir_Separator & Str (1 .. Last)) 748 then 749 if Str (1 .. Last) /= "." 750 and then 751 Str (1 .. Last) /= ".." 752 then 753 -- Recursive call to remove a subdirectory and all its 754 -- files. 755 756 Remove_Dir 757 (Dir_Name & Dir_Separator & Str (1 .. Last), 758 True); 759 end if; 760 761 else 762 GNAT.OS_Lib.Delete_File 763 (Dir_Name & Dir_Separator & Str (1 .. Last), 764 Success); 765 766 if not Success then 767 raise Directory_Error; 768 end if; 769 end if; 770 end loop; 771 772 Close (Current_Dir); 773 Remove_Dir (Dir_Name); 774 end if; 775 end Remove_Dir; 776 777end GNAT.Directory_Operations; 778