diff --git a/aaa_base/aaa.gpr b/aaa_base/aaa.gpr index 5001c83..65485aa 100644 --- a/aaa_base/aaa.gpr +++ b/aaa_base/aaa.gpr @@ -5,7 +5,19 @@ project Aaa is for Library_Name use "aaa"; for Library_Version use Project'Library_Name & ".so." & Aaa_Config.Crate_Version; - for Source_Dirs use ("src/"); + -- OS-specific sources, autodetected from environment + + OS_Sources := (); + Detect_Windows := external ("SystemRoot", "not_windows"); + + case Detect_Windows is + when "not_windows" => + OS_Sources := OS_Sources & ("src/unix/"); + when others => + OS_Sources := OS_Sources & ("src/windows/"); + end case; + + for Source_Dirs use ("src/") & OS_Sources; for Object_Dir use "obj/" & Aaa_Config.Build_Profile; for Create_Missing_Dirs use "True"; for Library_Dir use "lib"; diff --git a/aaa_base/alire.toml b/aaa_base/alire.toml index 430d832..74ae415 100644 --- a/aaa_base/alire.toml +++ b/aaa_base/alire.toml @@ -1,6 +1,7 @@ name = "aaa" -version = "0.3.1-dev" description = "Alex's Ada Assortment (of miscellaneous utilities)" +version = "0.3.2-dev" +# 0.3.2: file-based locking long-description = """ Alex's Ada Assortment of Utilities @@ -12,6 +13,7 @@ Alex's Ada Assortment of Utilities - String containers and utilities. - Simple subprocess spawning. - Write-through minimal cache for objects stored in files +- Advisory file locks that the OS releases when a process ends. """ authors = ["Alejandro R. Mosteo"] diff --git a/aaa_base/src/aaa-filesystem-locks.adb b/aaa_base/src/aaa-filesystem-locks.adb new file mode 100644 index 0000000..9bfcd30 --- /dev/null +++ b/aaa_base/src/aaa-filesystem-locks.adb @@ -0,0 +1,112 @@ +with Ada.IO_Exceptions; + +package body AAA.Filesystem.Locks is + + package OS renames GNAT.OS_Lib; + + use type OS.File_Descriptor; + + type Outcomes is (Locked, Busy, Unsupported); + + function Lock_File (File : OS.File_Descriptor; + Wait : Boolean) + return Outcomes is separate; + -- Lock File exclusively with the OS facility, which differs between Unix + -- and Windows. Without Wait, returns Busy at once if already locked. + + ---------- + -- Open -- + ---------- + + procedure Open (This : in out Lock; Path : String) is + Unused : Boolean; + begin + This.File := OS.Open_Read_Write (Path, OS.Binary); + + if This.File = OS.Invalid_FD then + This.File := OS.Create_New_File (Path, OS.Binary); + end if; + + -- Another process may have created it in the meantime + if This.File = OS.Invalid_FD then + This.File := OS.Open_Read_Write (Path, OS.Binary); + end if; + + if This.File = OS.Invalid_FD then + raise Ada.IO_Exceptions.Use_Error with + "Cannot open lock file " & Path & ": " & OS.Errno_Message; + end if; + + OS.Set_Close_On_Exec (This.File, True, Unused); + end Open; + + ---------------- + -- Lock_Using -- + ---------------- + + function Lock_Using (This : in out Lock; + Path : String; + Wait : Boolean) + return Boolean + is + begin + Open (This, Path); + + case Lock_File (This.File, Wait) is + when Locked | Unsupported => + return True; + when Busy => + This.Release; + return False; + end case; + end Lock_Using; + + ----------------- + -- Try_Acquire -- + ----------------- + + function Try_Acquire (This : in out Lock; Path : String) return Boolean + is (Lock_Using (This, Path, Wait => False)); + + ------------- + -- Acquire -- + ------------- + + procedure Acquire (This : in out Lock; Path : String) is + begin + if not Lock_Using (This, Path, Wait => True) then + raise Program_Error with "Lock reported as busy after waiting"; + end if; + end Acquire; + + ------------- + -- Is_Held -- + ------------- + + function Is_Held (This : Lock) return Boolean + is (This.File /= OS.Invalid_FD); + + ------------- + -- Release -- + ------------- + + procedure Release (This : in out Lock) is + begin + -- Closing the file releases its lock + + if This.Is_Held then + OS.Close (This.File); + This.File := OS.Invalid_FD; + end if; + end Release; + + -------------- + -- Finalize -- + -------------- + + overriding procedure Finalize (This : in out Lock) is + begin + This.Release; + end Finalize; + +end AAA.Filesystem.Locks; diff --git a/aaa_base/src/aaa-filesystem-locks.ads b/aaa_base/src/aaa-filesystem-locks.ads new file mode 100644 index 0000000..de2b3c9 --- /dev/null +++ b/aaa_base/src/aaa-filesystem-locks.ads @@ -0,0 +1,42 @@ +private with Ada.Finalization; +private with GNAT.OS_Lib; + +package AAA.Filesystem.Locks is + + -- Exclusive advisory locks on files, to keep processes off a resource that + -- another process is using. Only processes that lock the same file notice + -- them. A lock belongs to an open file of the process holding it, so the + -- OS releases it when that process ends, whatever the reason, and no lock + -- can be left behind. Two Lock objects exclude each other also within one + -- process. Programs spawned by the holder don't inherit the lock. + + -- On filesystems where the OS can't lock files, and on NFS under Linux, + -- where trying may hang, the lock is taken as held without excluding + -- anyone. + + type Lock is tagged limited private; + + function Is_Held (This : Lock) return Boolean; + + function Try_Acquire (This : in out Lock; Path : String) return Boolean + with Pre => not This.Is_Held; + -- Lock Path, which is created empty if missing. Returns False without + -- waiting if another Lock holds it. Raises Ada.IO_Exceptions.Use_Error if + -- the file can't be opened or created. + + procedure Acquire (This : in out Lock; Path : String) + with Pre => not This.Is_Held; + -- As Try_Acquire, but waits for as long as another Lock holds the file + + procedure Release (This : in out Lock); + -- Nothing to do if not held. Also done on finalization. + +private + + type Lock is new Ada.Finalization.Limited_Controlled with record + File : GNAT.OS_Lib.File_Descriptor := GNAT.OS_Lib.Invalid_FD; + end record; + + overriding procedure Finalize (This : in out Lock); + +end AAA.Filesystem.Locks; diff --git a/aaa_base/src/unix/aaa-filesystem-locks-lock_file.adb b/aaa_base/src/unix/aaa-filesystem-locks-lock_file.adb new file mode 100644 index 0000000..0dad94e --- /dev/null +++ b/aaa_base/src/unix/aaa-filesystem-locks-lock_file.adb @@ -0,0 +1,71 @@ +with Interfaces.C; + +with System; + +separate (AAA.Filesystem.Locks) +function Lock_File (File : OS.File_Descriptor; + Wait : Boolean) + return Outcomes +is + use Interfaces.C; + + -- Same values on Linux, macOS and the BSDs + + LOCK_EX : constant := 2; + LOCK_NB : constant := 4; + EINTR : constant := 4; + + -- EWOULDBLOCK is 11 on Linux and 35 on macOS and the BSDs. On each of + -- them, the other value is EDEADLK, which flock doesn't report. + + function Is_Would_Block (Error : Integer) return Boolean + is (Error = 11 or else Error = 35); + + NFS_Super_Magic : constant := 16#6969#; + + function Flock (File : int; Operation : int) return int; + pragma Import (C, Flock, "flock"); + + function Fstatfs (File : int; Buffer : System.Address) return int; + pragma Import (C, Fstatfs, "fstatfs"); + + ------------ + -- On_NFS -- + ------------ + + function On_NFS return Boolean is + Buffer : array (1 .. 512) of aliased long := (others => 0); + -- Bigger than struct statfs on any of them (2168 bytes on macOS) + begin + -- Only Linux has f_type as the first field. Elsewhere, the first word + -- holds block sizes or a version, never equal to the NFS magic number. + + return Fstatfs (int (File), Buffer'Address) = 0 + and then Buffer (Buffer'First) = NFS_Super_Magic; + end On_NFS; + +begin + -- flock on NFS may wait forever even when told not to, so don't try + + if On_NFS then + return Unsupported; + end if; + + loop + if Flock (int (File), + LOCK_EX + (if Wait then 0 else LOCK_NB)) = 0 + then + return Locked; + end if; + + declare + Error : constant Integer := OS.Errno; + begin + if Is_Would_Block (Error) then + return Busy; + elsif Error /= EINTR then + return Unsupported; + end if; + end; + end loop; +end Lock_File; diff --git a/aaa_base/src/windows/aaa-filesystem-locks-lock_file.adb b/aaa_base/src/windows/aaa-filesystem-locks-lock_file.adb new file mode 100644 index 0000000..1db2c66 --- /dev/null +++ b/aaa_base/src/windows/aaa-filesystem-locks-lock_file.adb @@ -0,0 +1,63 @@ +with Interfaces.C; + +with System; + +separate (AAA.Filesystem.Locks) +function Lock_File (File : OS.File_Descriptor; + Wait : Boolean) + return Outcomes +is + use Interfaces.C; + + subtype DWORD is unsigned_long; -- 32 bits on Windows + + LOCKFILE_FAIL_IMMEDIATELY : constant := 1; + LOCKFILE_EXCLUSIVE_LOCK : constant := 2; + ERROR_LOCK_VIOLATION : constant := 33; + + type OVERLAPPED is record + Internal : System.Address := System.Null_Address; + Internal_High : System.Address := System.Null_Address; + Offset : DWORD := 0; + Offset_High : DWORD := 0; + Event : System.Address := System.Null_Address; + end record + with Convention => C; + -- Unused but required, for the start of the region to lock (0) + + function Get_OS_Handle (File : int) return System.Address; + pragma Import (C, Get_OS_Handle, "_get_osfhandle"); + + function Lock_File_Ex (File : System.Address; + Flags : DWORD; + Reserved : DWORD; + Length_Low : DWORD; + Length_High : DWORD; + Start : access OVERLAPPED) + return int; + pragma Import (Stdcall, Lock_File_Ex, "LockFileEx"); + + function Get_Last_Error return DWORD; + pragma Import (Stdcall, Get_Last_Error, "GetLastError"); + + Region : aliased OVERLAPPED; + +begin + -- Lock the first byte, which is enough as everybody locks that one + + if Lock_File_Ex + (Get_OS_Handle (int (File)), + Flags => LOCKFILE_EXCLUSIVE_LOCK + + (if Wait then 0 else LOCKFILE_FAIL_IMMEDIATELY), + Reserved => 0, + Length_Low => 1, + Length_High => 0, + Start => Region'Access) /= 0 + then + return Locked; + elsif Get_Last_Error = ERROR_LOCK_VIOLATION then + return Busy; + else + return Unsupported; + end if; +end Lock_File; diff --git a/aaa_base/tests/src/aaa_tests-filesystem-locks.adb b/aaa_base/tests/src/aaa_tests-filesystem-locks.adb new file mode 100644 index 0000000..9cf5cee --- /dev/null +++ b/aaa_base/tests/src/aaa_tests-filesystem-locks.adb @@ -0,0 +1,48 @@ +with AAA.Filesystem.Locks; + +with Ada.Directories; + +pragma Alire_Test; + +procedure Aaa_Tests.Filesystem.Locks is + + package Locks renames AAA.Filesystem.Locks; + + Temp : AAA.Filesystem.Temp_File := AAA.Filesystem.New_Name; + Path : constant String := Temp.Filename; + + First, Second : Locks.Lock; + -- Declared after Temp, so released before it deletes the file + +begin + -- The file is created when missing + + Assert (First.Try_Acquire (Path), "Could not lock a new file"); + Assert (First.Is_Held, "Lock not reported as held"); + Assert (Ada.Directories.Exists (Path), "Lock file not created"); + + -- Nobody else gets it while held, also within the same process + + Assert (not Second.Try_Acquire (Path), "Lock held twice"); + Assert (not Second.Is_Held, "Failed lock reported as held"); + + -- Until released + + First.Release; + Assert (not First.Is_Held, "Released lock reported as held"); + Assert (Second.Try_Acquire (Path), "Released lock not available"); + + -- Finalization releases it too + + Second.Release; + + declare + Third : Locks.Lock; + begin + Third.Acquire (Path); -- Free, so it doesn't wait + Assert (not First.Try_Acquire (Path), "Lock held twice by Acquire"); + end; + + Assert (First.Try_Acquire (Path), "Lock not released on finalization"); + First.Release; +end Aaa_Tests.Filesystem.Locks;