此為轉貼資料 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