1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- G N A T . L O C K _ F I L E S -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1998-2009, 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 32with System; 33 34package body GNAT.Lock_Files is 35 36 Dir_Separator : Character; 37 pragma Import (C, Dir_Separator, "__gnat_dir_separator"); 38 39 --------------- 40 -- Lock_File -- 41 --------------- 42 43 procedure Lock_File 44 (Directory : Path_Name; 45 Lock_File_Name : Path_Name; 46 Wait : Duration := 1.0; 47 Retries : Natural := Natural'Last) 48 is 49 Dir : aliased String := Directory & ASCII.NUL; 50 File : aliased String := Lock_File_Name & ASCII.NUL; 51 52 function Try_Lock (Dir, File : System.Address) return Integer; 53 pragma Import (C, Try_Lock, "__gnat_try_lock"); 54 55 begin 56 -- If a directory separator was provided, just remove the one we have 57 -- added above. 58 59 if Directory (Directory'Last) = Dir_Separator 60 or else Directory (Directory'Last) = '/' 61 then 62 Dir (Dir'Last - 1) := ASCII.NUL; 63 end if; 64 65 -- Try to lock the file Retries times 66 67 for I in 0 .. Retries loop 68 if Try_Lock (Dir'Address, File'Address) = 1 then 69 return; 70 end if; 71 72 exit when I = Retries; 73 delay Wait; 74 end loop; 75 76 raise Lock_Error; 77 end Lock_File; 78 79 --------------- 80 -- Lock_File -- 81 --------------- 82 83 procedure Lock_File 84 (Lock_File_Name : Path_Name; 85 Wait : Duration := 1.0; 86 Retries : Natural := Natural'Last) 87 is 88 begin 89 for J in reverse Lock_File_Name'Range loop 90 if Lock_File_Name (J) = Dir_Separator 91 or else Lock_File_Name (J) = '/' 92 then 93 Lock_File 94 (Lock_File_Name (Lock_File_Name'First .. J - 1), 95 Lock_File_Name (J + 1 .. Lock_File_Name'Last), 96 Wait, 97 Retries); 98 return; 99 end if; 100 end loop; 101 102 Lock_File (".", Lock_File_Name, Wait, Retries); 103 end Lock_File; 104 105 ----------------- 106 -- Unlock_File -- 107 ----------------- 108 109 procedure Unlock_File (Lock_File_Name : Path_Name) is 110 S : aliased String := Lock_File_Name & ASCII.NUL; 111 112 procedure unlink (A : System.Address); 113 pragma Import (C, unlink, "unlink"); 114 115 begin 116 unlink (S'Address); 117 end Unlock_File; 118 119 ----------------- 120 -- Unlock_File -- 121 ----------------- 122 123 procedure Unlock_File (Directory : Path_Name; Lock_File_Name : Path_Name) is 124 begin 125 if Directory (Directory'Last) = Dir_Separator 126 or else Directory (Directory'Last) = '/' 127 then 128 Unlock_File (Directory & Lock_File_Name); 129 else 130 Unlock_File (Directory & Dir_Separator & Lock_File_Name); 131 end if; 132 end Unlock_File; 133 134end GNAT.Lock_Files; 135