unit Semaphores;
{
  .d8888. d88888b .88b  d88.  .d8b.  d8888b. db   db  .d88b.  d8888b. d88888b 
  88'  YP 88'     88'YbdP`88 d8' `8b 88  `8D 88   88 .8P  Y8. 88  `8D 88'
  `8bo.   88ooooo 88  88  88 88ooo88 88oodD' 88ooo88 88    88 88oobY' 88ooooo
    `Y8b. 88~~~~~ 88  88  88 88~~~88 88~~~   88~~~88 88    88 88`8b   88~~~~~
  db   8D 88.     88  88  88 88   88 88      88   88 `8b  d8' 88 `88. 88.
  `8888Y' Y88888P YP  YP  YP YP   YP 88      YP   YP  `Y88P'  88   YD Y88888P


                                    .d8888.
                                    88'  YP
                                    `8bo.   
                                      `Y8b. 
                                    db   8D 
                                    `8888Y'

Author: Sean B. Durkin (c) 2000
   (http://people.myoffice.net.au/~sean/index.html  and
    mailto:sdurkin@siliconrose.com.au)

Acknoledgements:
  This unit was inspired by Misha Charrett's SyncObjUnt unit. Misha's unit is
  available at http://www.adug.org.au/DownLoads/default.htm . Thank-you Misha.
  Thanks also to Shannon Broskie (sbroskie@tagfolio.com) who gave me the
  OpenSemaphore access flags by the borland.public.delphi.winapi newsgroup;
  and to Graham Meintjes (meintjesg@centretech.com.au) and  Pak Tse
  (tsea@centretech.com.au) who formally inspected the unit.

Version: 1.1

Date of version 1.0: 30-Mar-00

Date this version:   31-Mar-00

Abstract:
  This unit provides classes providing the functionality of semaphores.
  Two flavours of semaphore are provided TNativeSemaphore and TLightSemaphore.
  Both are concrete classses which descend from the abstract TSemaphore class.

  Semaphores count resources; acquire and release resources one at a time
  from a pool of resources (real or conceptual). When no resources are
  available, attempting to acquire a resource will put the requesting thread
  into an efficient wait state until a resource is released or the specified
  time-out period has expired.

  TNativeSemaphore is a wrapper around the win api semaphore. It has the
  advantage of being able to be used accross process boundaries, shared
  between processes, and being located by name string.

  TLightSemaphore is a light weight emulation of the win api semaphore,
  and is constructed from critical sections and win api events. It is more
  efficient and has the capability to expose the current unallocated resource
  level.

  Both classes can be economically subclassed to write semaphores whose counting,
  acquisition and release actions are closely coupled to particular classes
  of resource pools.

Classes exposed:
  ESemaphore, TSemaphore, TNativeSemaphore & TLightSemaphore

Inheritance diagram:
                TObject
                   |
             TSynchroObject
                   |
             THandleObject
                   |
                 TEvent
                   |
               TSemaphore
                |       |
  TNativeSemaphore   TLightSemaphore

TSemaphore public properties:
  * LastError: Integer       (NOT thread-safe!)
  * Handle: THandle          (NOT thread-safe!)
  * ResourceCount: Integer   (read only)
  * MaximumCount: Integer    (NOT thread-safe!)
  * Name: string             (NOT thread-safe!)
  * AcquireTimeOut: Cardinal (NOT thread-safe!)

  LastError returns the win api last error number from invocations of
   Wait, Acquire or OpenExisting. This property overloads one from THandleEvent.
  Handle exposes the underlying windows handle for the event (a semaphore
   in the case of TNativeSemaphore, and an event in the case of TLightSemaphore).
   This property overloads one from THandleEvent.
  ResourceCount exposes the current resource level. It is only supported by
   TLightSemaphore.
  MaximumCount is the pool size. It is assumed that you do not change this
   after calling OpenNew or OpenExising. Must be positive. Defaults to 1.
  Name is the string name for the underlying win api handle. It is assumed that
   you do not change this after calling OpenNew or OpenExising. It should be
   unique or null. It really only has relevance for TNativeSemaphore.
  AcquireTimeOut is the time-out value in milliseconds used by Acquire. It
   should be positive. Do not read/write this property in a non-thread-safe
   context. Defaults to Forever (meaning "no time-out")

TSemaphore public methods:
  * constructor Create      (NOT thread-safe!) (virtual)
  * destructor Destroy      (NOT thread-safe!) (virtual from TObject)
  * procedure OpenNew;      (NOT thread-safe!) (virtual)
  * procedure OpenExisting; (NOT thread-safe!) (virtual)
  * function Wait (TimeOut: Cardinal): TWaitResult; (virtual)
  * function Signal: Boolean;                       (virtual)
  * procedure Acquire; (virtual from TSynchroObject)
  * procedure Release; (virtual from TSynchroObject)

  You must call OpenNew or OpenExisting exactly once (either not both) before
   calling Wait,Signal,Acquire or Release. After calling OpenNew or OpenExising,
   do not change the MaximumCount or name properties. OpenNew creates a new
   underlying win api object. OpenExisting opens a handle to a pre-exising
   win api semaphore by reference to its name. TLightSemaphore does not support
   OpenExisting.
  The Wait function attempts to acquire a resource. If successfull it returns
   wrSignaled (refer SyncObjs for defn of TWaitResult). If no resources are
   currently available the thread is placed in an efficient wait state until
   such time as a resource is available or a time-out occurs.
  The Acquire procedure is the same as Wait but it raised an exception if no
   resource was acquired. The time-out used is the Time-Out property. Beware,
   this property is not thread-safe.
  The Signal function attempts to release a resource. It will succeed and
   return True if the pool will stay at or below the maximum, otherwise it will
   return False.
  The Release procedure is the same as Signal but raises an exception of the
   signalling failed.

TSemaphore protected methods and data members:
  All protected methods are virtual;
  * FHandle: THandle
  * FLastError: Integer
  * procedure IncrementResource
  * procedure DecrementResource
  * function InternalResourceCount: Integer
  * procedure LockResourceCount
  * procedure UnlockResourceCount

  These methods are applicable for the writers of custom variations of
   TNativeSemaphore and TLightSemaphore.
  Procedures Inc/Dec~rementResource are called by Wait/Acquire/Signal/Release
   to effect the representational and non-sychronising part of changing the
   resource level. Similary the InternalResourceCount function is used
   to measure the actual resource level. It can be assumed that all 3 methods
   are only ever called in a thread-safe context and protected by
   Un/~LockResourceCount.
  The default behaviour of TLightSemaphore.~Inc/Dec~rementResource is to
   increment/decrement an internal counter - the same one returned by the
   default behaviour of InternalResourceCount. Because the underlying resource
   level is not available in a win api semaphore, these methods are empty
   for the default behaviour of TNativeSemaphore.


TLightSemaphore example employment:
  Here follows is an example employment of a TLightSemaphore. Say we have
  a collection of letters, and a number of threads are contending for
  exclusive use of the letters. We are allowed to have up to half of our
  pool of letters being exclusively used by client threads. When the full
  quota is already be exclusively used by client threads, and another thread
  requires a letter, that thread is to be blocked (put into an efficient wait
  state) until such time as a letter is released or until time-out.

  var
    PoolSemaphore: TSemaphore;
    Letters: TStrings;
    Ch: Char;
    Children: TObjectList;
    ThreadCounter: Integer;
    ChildThread: TChildThread; // TChildThread inherits from TThread.
    LettersAccess: TCriticalSection;

  begin // Executive level code ...
  Letters := TStringList.Create;
  LettersAccess := TCriticalSection.Create;
  for Ch := 'A' to 'Z' do
    Letters.Add(Ch);
  PoolSemaphore := TLightSemaphore.Create;
  PoolSemaphore.MaximumCount := Letters.Count div 2; // only half the letters
                                     // may be accessed at any one time.
  PoolSemaphore.AcquireTimeOut := 10000; // 10 seconds
  PoolSemaphore.OpenNew;
  Children := TObjectList.Create;
  for ThreadCounter := 1 to Random(1000) do
    begin
    ChildThread := TChildThread.Create;
    Children.Add(ChildThread)
    end;
  Sleep(1000000);  // Let the children work.
  for ThreadCounter := 0 to Children.Count-1 do
    begin
    ChildThread := Children[j]) as TChildThread;
    ChildThread.Terminate
    end;
  Sleep(100000); // buffer time to make sure terminations have been effected.
  Children.Free;
  poolSemaphore.Free;
  LettersAccess.Free;
  Letters.Free
  end;

  procedure TChildThread.Execute;
  var
    Idx: Integer;
    MyLetter: string;
  begin
  while not Terminated do
    begin
    try // except
      PoolSemaphore.Acquire;
      try // then release
        LettersAccess.Enter;
        try // then finally leave
          Idx := Random(Letters.Count);
          MyLetter := Letters[Idx];
          Letters.Delete(Idx)
          finally
          LettersAccess.Leave
          end;

        // Now play with the letter ...
        Sleep(100);

        // Now put it back ...
        LettersAccess.Enter;
        try // then finally leave
          Letters.Add(MyLetter)
          finally
          LettersAccess.Leave
          end
        finally
        PoolSemaphore.Release;
        end
      except on E:ESemaphore do
        // If you time-out, don't worry about it; just try again.
      end
    end
  end;




Compilation notes:
  Normally, TLightSemaphore uses InterlockedExchange for internal thread
  synchronisation. By defining ($DEFINE) the "UsingCriticalSection" conditional
  symbol, a critical section will instead be used. Normally it is more efficient
  left undefined, but you might want to apply it in curcumstances where
  there will be a great many threads really hammering the semaphore.
==============================================================================}

interface
uses SyncObjs, Windows, SysUtils;

const
  Forever = windows.INFINITE; // Apply to the wait function to wait without
                              //  time-out.

type

  // ESemaphore may be raised by TSemaphore methods.
  TSemaphoreExceptionSubtype = (eAcquire,  // Raised in an attempt to Acquire
                                eRelease,  // Raised in an attempt to Release
                                eMethodNotSupported);
  ESemaphore = class(Exception)
    public
      Subtype   : TSemaphoreExceptionSubtype;
      WaitResult: TWaitResult;
      LastError : Integer;
      constructor Create (const Msg:string; SubType1:TSemaphoreExceptionSubtype;
                          WaitRes: TWaitResult; Err: Integer);
    end;

  // TSemaphore: abstract base class for TNativeSemaphore and TLightSemaphore
  TSemaphore = class(TEvent)
  private
    FMaxCount: Integer;
    FName: string;
    FTimeOut: Cardinal;

    function GetResourceCount: Integer;
    procedure WaitReleased; virtual; abstract; // Action to be taken after a
                                               //  successfull TSemaphore.Wait.
    function ResourceAvailable: Boolean;

  protected
    FHandle: THandle;   // Beware: THandleEvent has a private of the same name.
    FLastError: Integer;// Beware: THandleEvent has a private of the same name.

    procedure IncrementResource; virtual; abstract;
    procedure DecrementResource; virtual; abstract;
    function InternalResourceCount: Integer; virtual; abstract;
    procedure LockResourceCount; virtual; abstract;
    procedure UnlockResourceCount; virtual; abstract;

  public
    constructor Create; virtual;
    procedure OpenNew; virtual; abstract;      // not thread-safe
    procedure OpenExisting; virtual; abstract;  // not thread-safe
    destructor Destroy; override;

    function Wait (TimeOut: Cardinal): TWaitResult; virtual;
    function Signal: Boolean;                       virtual; abstract;

    procedure Acquire; override;
    procedure Release; override;

    property LastError: Integer read FLastError;       // not thread-safe
    property Handle: THandle read FHandle;             // not thread-safe
    property ResourceCount: Integer read GetResourceCount;
    property MaximumCount: Integer read FMaxCount write FMaxCount; // not thread-safe
    property Name: string read FName write FName;      // not thread-safe
    property AcquireTimeOut: Cardinal read FTimeOut write FTimeOut; // not thread-safe
  end;

  TNativeSemaphore = class(TSemaphore)
  private
    procedure WaitReleased; override;

  protected
    procedure IncrementResource; override;
    procedure DecrementResource; override;
    function InternalResourceCount: Integer; override;
    procedure LockResourceCount; override;
    procedure UnlockResourceCount; override;

  public
    procedure OpenNew; override;      // not thread-safe
    procedure OpenExisting; override;  // not thread-safe

    function Signal: Boolean;                       override;
  end;

  TLightSemaphore = class(TSemaphore)
  private
    Acquired: Boolean;    // True iff Acquisition succeeded.
    FResourceCount: Integer;  // Underly resource measure.
    FCounterGate:  // For control of access to FResourceCount.
                  {$IFDEF UsingCriticalSection}
                    TRTLCriticalSection
                  {$ELSE}
                    Integer // 0 means unlocked.
                  {$ENDIF};
    FWaitGate: TRTLCriticalSection;    // For mutual exclusion to Wait procedure.
    procedure WaitReleased; override;

  protected
    procedure IncrementResource; override;
    procedure DecrementResource; override;
    function InternalResourceCount: Integer; override;
    procedure LockResourceCount; override;
    procedure UnlockResourceCount; override;

  public
    constructor Create; override;
    procedure OpenNew; override;      // not thread-safe
    procedure OpenExisting; override;  // not thread-safe
    destructor Destroy; override;

    function Wait (TimeOut: Cardinal): TWaitResult; override;
    function Signal: Boolean; override;
  end;


implementation











const
  // windows.OpenSemaphore access flags ...
  SYNCHRONIZE              = $00100000;
  STANDARD_RIGHTS_REQUIRED = $000F0000;
  SEMAPHORE_MODIFY_STATE   =     $0002;
  SEMAPHORE_ALL_ACCESS =(STANDARD_RIGHTS_REQUIRED or SYNCHRONIZE or $0003);
{Thanks to Shannon who said: ...
   I found these definitions in winnt.h
   #define STANDARD_RIGHTS_REQUIRED         (0x000F0000L)
   #define SYNCHRONIZE                      (0x00100000L)
   #define SEMAPHORE_MODIFY_STATE      0x0002
   #define SEMAPHORE_ALL_ACCESS (STANDARD_RIGHTS_REQUIRED|SYNCHRONIZE|0x3)}

  // Exception messages ...
  sAcquireFailed         = 'Acquire failed';
  sReleaseFailed         = 'Release failed';
  sNativeResCountNotSupp = 'TNativeSemaphore.ResourceCount not supported';
  sLightOpenExistNotSupp = 'TLightSemaphore.OpenExisting not supported';

constructor ESemaphore.Create (const Msg:string;
  SubType1:TSemaphoreExceptionSubtype; WaitRes: TWaitResult; Err: Integer);
begin
inherited Create(Msg);
Subtype   := SubType1;
WaitResult:= WaitRes;
LastError := Err
end;


function TSemaphore.GetResourceCount: Integer;
begin
LockResourceCount;
try
  result := InternalResourceCount
  finally
  UnlockResourceCount
  end
end;



constructor TSemaphore.Create;
begin
FMaxCount := 1;
FTimeOut := Forever
end;



destructor TSemaphore.Destroy;
begin
CloseHandle(FHandle);
inherited
end;



function TSemaphore.Wait (TimeOut: Cardinal): TWaitResult;
begin
result := WaitFor(TimeOut);
case result of
  wrSignaled:
    WaitReleased;

  wrError:
    FLastError := inherited LastError;

  else
    begin end
  end
end;


function TSemaphore.ResourceAvailable: Boolean;
begin
result := InternalResourceCount > 0
end;

procedure TSemaphore.Acquire;
var
  WResult: TWaitResult;
begin
WResult := Wait(FTimeOut);
if WResult <> wrSignaled then
  raise ESemaphore.Create (sAcquireFailed,eAcquire,WResult,LastError)
end;



procedure TSemaphore.Release;
begin
if not Signal then
  raise ESemaphore.Create (sReleaseFailed,eRelease,wrSignaled,LastError)
end;



procedure TNativeSemaphore.IncrementResource;
begin
end;



procedure TNativeSemaphore.DecrementResource;
begin
end;



function TNativeSemaphore.InternalResourceCount: Integer;
begin
raise ESemaphore.Create (sNativeResCountNotSupp, eMethodNotSupported,
                         wrSignaled, 0)
end;



procedure TNativeSemaphore.LockResourceCount;
begin
end;



procedure TNativeSemaphore.UnlockResourceCount;
begin
end;



procedure TNativeSemaphore.OpenNew;
begin
FHandle := windows.CreateSemaphore(
  {pointer to security attributes }  nil,
  {initial count}                    FMaxCount,
  {maximum count}                    FMaxCount,
  {pointer to semaphore-object name} PChar(FName))
end;



procedure TNativeSemaphore.OpenExisting;
begin
FHandle := windows.OpenSemaphore(
  {Specifies all possible access flags
             for the semaphore object.} SEMAPHORE_ALL_ACCESS,
  {If TRUE, a process created by the CreateProcess function
            can inherit the handle}     True,
  {names the semaphore to be opened. Name comparisons
             are case sensitive} PChar(FName));
if FHandle = 0 then
  FLastError := GetLastError
end;


procedure TNativeSemaphore.WaitReleased;
begin
LockResourceCount;
try
  DecrementResource
  finally
  UnlockResourceCount
  end
end;




function TNativeSemaphore.Signal: Boolean;
begin
result := windows.ReleaseSemaphore(FHandle,1,nil);
if not result then exit;
LockResourceCount;
try
  IncrementResource
  finally
  UnlockResourceCount
  end
end;



procedure TLightSemaphore.IncrementResource;
begin
Inc(FResourceCount)
end;



procedure TLightSemaphore.DecrementResource;
begin
Dec(FResourceCount)
end;



function TLightSemaphore.InternalResourceCount: Integer;
begin
result := FResourceCount
end;



procedure TLightSemaphore.LockResourceCount;
begin
{$IFDEF UsingCriticalSection}
windows.EnterCriticalSection(FCounterGate)
{$ELSE}
// The below technique is more efficient as long as the lock is only on
//  for a short period of time.
while windows.InterlockedExchange(FCounterGate, -1) <> 0 do  Sleep(0)
{$ENDIF}
end;



procedure TLightSemaphore.UnlockResourceCount;
begin
{$IFDEF UsingCriticalSection}
windows.LeaveCriticalSection(FCounterGate)
{$ELSE}
// VCL code which uses the InterlockedExchange technique does
//  an unlock simply by the statement "FCounterGate := 0" .
//  I don't see how this can possibly work. I prefer the statement following
//  to unlock ...
windows.InterlockedExchange(FCounterGate, 0)
{$ENDIF}
end;



constructor TLightSemaphore.Create;
begin
inherited;
{$IFDEF UsingCriticalSection}
windows.InitializeCriticalSection(FCounterGate);
{$ENDIF}
windows.InitializeCriticalSection(FWaitGate)
end;



procedure TLightSemaphore.OpenNew;
begin
FHandle := windows.CreateEvent(nil,False,False,PChar(FName));
FResourceCount := FMaxCount
end;



procedure TLightSemaphore.OpenExisting;
begin
raise ESemaphore.Create (sLightOpenExistNotSupp, eMethodNotSupported,
                         wrSignaled, 0)
end;



destructor TLightSemaphore.Destroy;
begin
windows.DeleteCriticalSection(FWaitGate);
{$IFDEF UsingCriticalSection}
windows.DeleteCriticalSection(FCounterGate);
{$ENDIF}
inherited
end;


procedure TLightSemaphore.WaitReleased;
begin
Acquired := True;
LockResourceCount
end;


function TLightSemaphore.Wait (TimeOut: Cardinal): TWaitResult;
begin
result := wrSignaled;
try // outer except
  windows.EnterCriticalSection(FWaitGate); // Only one acquirer at a time here.
  Acquired := False;
  try // finally LeaveCriticalSection
    LockResourceCount;
    try // inner finally to unlock resource count
      Acquired := ResourceAvailable;
      if not Acquired then
        begin
        UnlockResourceCount; // Need to unlock because may be blocked soon!
        result := inherited Wait(TimeOut)// which should set Acquired to True
                                         // and LockResourceCount
        end;
      if Acquired then
        begin
        DecrementResource;
        if not ResourceAvailable then // The cupboard is bare!
          windows.ResetEvent(FHandle) // Reset state represents no resources.
        end
      finally
        if Acquired then
          UnlockResourceCount
      end
    finally
      windows.LeaveCriticalSection(FWaitGate)
    end
  except
  result := wrError
  end
end;



function TLightSemaphore.Signal: Boolean;
var
  Replenish: Boolean; //True if and only if transitioning from 0 to 1 resources.

begin
try
  LockResourceCount;
  try
    result := InternalResourceCount < FMaxCount;
    if result then
      begin
      Replenish := not ResourceAvailable;
      IncrementResource;
      if Replenish then
        windows.SetEvent(FHandle) // Set state represents at least 1 resource.
      end
    finally
      UnlockResourceCount
    end
  except
    result := False
  end
end;




end.