gcc/ada/libgnat/g-locfil.adb

   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-2017, 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
  32 with System;
  33
  34 package 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
 134 end GNAT.Lock_Files;