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