AccessLock

Common.Classes.AccessLock.pas

unit Common.Classes.AccessLock;
{$Include 'default.inc'}

interface uses
	System.SyncObjs,
	System.TimeSpan,
	Common.Types.AccessLock;

type
	ILockableResourceControl = interface
	['{21971BDB-F68E-483E-9324-0CA924EE14CE}']
		procedure UnRegisterLock(const lock: ILock);
	end;

	TLock = class(TInterfacedObject, ILock)
		private var
			wasUnlocked: Boolean;
		protected var
			control: ILockableResourceControl;
		public
			constructor Create(const control: ILockableResourceControl);
            destructor Destroy(); override;
			procedure UnLock();
	end;

	TLockableResource = class(TInterfacedObject, ILockableResource, ILockableResourceControl)
		private type
			/// <summary>
            ///     Use raw pointers to circumvent reference counting
			/// </summary>
			{$If CompilerVersion >= 31}{$Message 'Consider [Weak] attribute'}{$EndIf}
			PLock = ^ILock;
		private var
			mutex: TCriticalSection;
			currentLockPointer: PLock;
			lockAvailableEvent: TEvent;
		protected
			function getCurrentLock(): ILock;
		public
			constructor Create();
			destructor Destroy(); override;
			procedure UnregisterLock(const lock: ILock);
			function TryLock(out lock: ILock): Boolean; overload;
			function TryLock(out lock: ILock; const timeout: TTimeSpan): Boolean; overload;
	end;

implementation uses
  System.SysUtils,
  System.Classes,
  System.Threading;

{ TLock }

constructor TLock.Create(const control: ILockableResourceControl);
begin
	inherited Create();
	if not Assigned(control) then
		raise EArgumentNilException.Create('"control" must be assigned');
	self.control := control;
end;

destructor TLock.Destroy();
begin
	if (not wasUnlocked) then
		UnLock();
	inherited;
end;

procedure TLock.UnLock();
begin
	control.UnRegisterLock(self);
	wasUnlocked := true;
end;

{ TLockableResource }

constructor TLockableResource.Create();
begin
	inherited Create();
	mutex := TCriticalSection.Create();
	lockAvailableEvent := TSimpleEvent.Create();
end;

destructor TLockableResource.Destroy();
begin
	mutex.Acquire();
	if Assigned(getCurrentLock()) then
		getCurrentLock().UnLock();
	lockAvailableEvent.Free();
	mutex.Free();
	inherited;
end;

function TLockableResource.getCurrentLock(): ILock;
begin
	Result := ILock(currentLockPointer);
end;

function TLockableResource.TryLock(out lock: ILock): Boolean;
begin
	mutex.Acquire();
	try
		if Assigned(getCurrentLock()) then
			Result := False
		else
			begin
				lock := TLock.Create(self);
				currentLockPointer := PLock(lock);
				Result := True;
            end;
	finally
		mutex.Release();
    end;
end;

function TLockableResource.tryLock(
	out lock: ILock;
	const timeout: TTimeSpan): Boolean;
var
	future: IFuture<ILock>;
begin
	future := TTask.Future<ILock>(
		function(): ILock
		begin
			while not TryLock(Result) do
				begin
					lockAvailableEvent.WaitFor();
					TTask.CurrentTask().CheckCanceled();
				end;
		end
	);
	Result := future.Wait(timeout);
	if Result then
		lock := future.Value
	else
		future.Cancel();
end;

procedure TLockableResource.UnregisterLock(const lock: ILock);
begin
	mutex.Acquire();
	try
		if (lock <> getCurrentLock()) then
			raise ELockException.Create(String.Empty);
		currentLockPointer := nil;
		lockAvailableEvent.SetEvent();
	finally
		mutex.Release();
    end;
end;

end.

Common.Classes.AccessLock.Test.pas

unit Common.Classes.AccessLock.Test;

interface uses
	TestFramework,
	Common.Types.AccessLock,
	Common.Classes.AccessLock;

type
	TestLockableResource = class(TTestCase)
		protected var
			SUT: ILockableResource;
		protected
			procedure SetUp(); override;
			procedure TearDown(); override;
		published
			procedure CanNotLockTwice();
			procedure CanNotLockTwice_Threaded();
			procedure TryLockTimeout();
			procedure CanNotUnlockMultipleTimes();
			procedure SeveralConsumersWaitingForTimeout();
	end;

implementation uses
	System.TimeSpan,
	System.Classes,
	System.SyncObjs,
	System.Threading;

{ TestLockableResource }

procedure TestLockableResource.CanNotLockTwice();
var
	lock1: ILock;
	lock2: ILock;
begin
	Check( SUT.TryLock(lock1) );
	CheckFalse( SUT.TryLock(lock2) );

	lock1.UnLock();
	CheckTrue( SUT.TryLock(lock2) );
end;

procedure TestLockableResource.CanNotLockTwice_Threaded();
var
	lock: ILock;
begin
	Check(SUT.TryLock(lock));
	TTask.Run(
		procedure()
		var
			taskLock: ILock;
		begin
			CheckFalse( SUT.TryLock(taskLock) );
		end
	).Wait();

	lock.UnLock();

	TTask.Run(
		procedure()
		var
			taskLock: ILock;
		begin
			Check( SUT.TryLock(taskLock) );
			taskLock.UnLock();
		end
	).Wait();

	Check( SUT.TryLock(lock) );
end;

procedure TestLockableResource.CanNotUnlockMultipleTimes();
var
	lock: ILock;
begin
	Check( SUT.TryLock(lock) );
	lock.UnLock();

	ExpectedException := ELockException;
	lock.UnLock();
end;

procedure TestLockableResource.SetUp();
begin
	SUT := TLockableResource.Create();
end;

procedure TestLockableResource.SeveralConsumersWaitingForTimeout();
var
	originalLock: ILock;
	rival1, rival2, rival3: ILock;
	timeout: TTimeSpan;
begin
	Check( SUT.TryLock(originalLock) );
	timeout := TTimeSpan.FromMilliseconds(250);

	TTask.Run(
		procedure()
		begin
			SUT.TryLock(rival1, timeout);
		end
	);
	TTask.Run(
		procedure()
		begin
			SUT.TryLock(rival2, timeout);
		end
	);
	TTask.Run(
		procedure()
		begin
			SUT.TryLock(rival3, timeout);
		end
	);
	originalLock.UnLock();
	TThread.Sleep( timeout.Milliseconds );

	Check( Assigned(rival1) or Assigned(rival2) or Assigned(rival3) );
end;

procedure TestLockableResource.TearDown();
begin
	SUT := nil;
end;

procedure TestLockableResource.TryLockTimeout();
var
	lock1, lock2: ILock;
begin
	Check( SUT.TryLock(lock1) );
	CheckFalse( SUT.TryLock(lock2, TTimeSpan.FromMilliseconds(50)) );

	TTask.Run(
		procedure()
		begin
			TThread.Sleep(50);
			lock1.UnLock();
		end
	);
	Check( SUT.TryLock(lock2, TTimeSpan.FromMilliseconds(250)) );
end;

{ TestClass }
initialization
	TestFramework.RegisterTest('Common.Classes', TestLockableResource.Suite());
end.

Common.Types.AccessLock.pas

unit Common.Types.AccessLock;

interface uses
	System.SysUtils,
	System.SyncObjs,
	System.TimeSpan;

type
	ELockException = System.SyncObjs.ELockException;

	ILock = interface
	['{57CCCDE4-63F8-41F6-A6F0-39B4159B06FF}']
		/// <exception cref="ELockException" />
		procedure UnLock();
	end;

	ILockableResource = interface
	['{88085418-BD27-4B5D-AD00-B456C8E017A7}']
		function TryLock(out lock: ILock; const timeout: TTimeSpan): Boolean; overload;
		function TryLock(out lock: ILock): Boolean; overload;
	end;

implementation

end.