Sean Durkin |
|
jackkcg
站務副站長 發表:891 回覆:1050 積分:848 註冊:2002-03-23 發送簡訊給我 |
此為轉貼資料
http://www.adug.org.au/downloads/default.htm A PAS unit containing classes to support the use of semaphores in Delphi. There are extensive code comments describing theory and usage.
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. *********************************************************
哈哈&兵燹
最會的2大絕招 這個不會與那個也不會 哈哈哈 粉好 Delphi K.Top的K.Top分兩個字解釋Top代表尖端的意思,希望本討論區能提供Delphi的尖端新知
K.表Knowlege 知識,就是本站的標語:Open our mind to make knowledge together!
希望能大家敞開心胸,將知識寶庫結合一起
------
********************************************************** 哈哈&兵燹 最會的2大絕招 這個不會與那個也不會 哈哈哈 粉好 Delphi K.Top的K.Top分兩個字解釋Top代表尖端的意思,希望本討論區能提供Delphi的尖端新知 K.表Knowlege 知識,就是本站的標語:Open our mind |
本站聲明 |
1. 本論壇為無營利行為之開放平台,所有文章都是由網友自行張貼,如牽涉到法律糾紛一切與本站無關。 2. 假如網友發表之內容涉及侵權,而損及您的利益,請立即通知版主刪除。 3. 請勿批評中華民國元首及政府或批評各政黨,是藍是綠本站無權干涉,但這裡不是政治性論壇! |