unit PowerThread;
{ MERCVRHYO }
{ version 0.5 }
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, contnrs, syncobjs;
type
PThreadParams = ^TThreadParams;
TThreadParams = array of TVarRec;
TThreadMethod = procedure(Args: TThreadParams) of object;
TThreadCallBack = procedure(Data: Pointer) of object;
{ TPowerThread }
TPowerThread = class(TThread)
private
type
PCmdRec = ^TcmdRec;
TCmdRec = record
method: TThreadMethod;
params: TThreadParams;
Done: PBoolean;
CallBack: TThreadCallBack;
Data: Pointer;
end;
{ TLockQueue }
TLockQueue = class(TQueue)
private
FLock: TCriticalSection;
FReady: TEvent;
FEvName: string;
protected
procedure PushItem(AItem: Pointer); override;
function PopItem: Pointer; override;
function PeekItem: Pointer; override;
public
constructor Create;
destructor Destroy; override;
end;
private
var
FJobQueue: TLockQueue;
FSyncCall: TThreadCallBack;
FData: Pointer;
procedure DoSyncCallBack;
protected
procedure Execute; override;
public
constructor Create(CreateSuspended: boolean;
const StackSize: SizeUInt = DefaultStackSize);
destructor Destroy; override;
procedure Post(aMethod: TThreadMethod; Args: array of const;
var Done: boolean; aCallBack: TThreadCallBack = nil; aData: Pointer = nil);
end;
{ TThreadedComponent }
TThreadedComponent = class(TComponent)
private
FThread: TPowerThread;
function GetSuspended: boolean; inline;
procedure SetSuspended(AValue: boolean); inline;
public
constructor Create(AOwner: TComponent; CreateSuspended: boolean;
const StackSize: SizeUInt = DefaultStackSize); virtual;
destructor Destroy; override;
procedure Post(aMethod: TThreadMethod; Args: array of const;
var Done: boolean; aCallBack: TThreadCallBack = nil; aData: Pointer = nil);
property Suspended: boolean read GetSuspended write SetSuspended;
end;
implementation
var
EvQueueFmt: PChar = 'EvPTQ_%.5d';
EvRef: smallint;
{ TPowerThread.TCmdQueue }
procedure TPowerThread.TLockQueue.PushItem(AItem: Pointer);
var
chkev: TEvent;
begin
FLock.Enter;
chkev := TEvent.Create(nil, True, True, FEvName);
if chkev.WaitFor(10) <> wrSignaled then
begin
chkev.Free;
FLock.Leave;
raise ESyncObjectException.Create('PowerThread Queue error');
end;
FReady.ResetEvent;
chkev.Free;
inherited PushItem(AItem);
FReady.SetEvent;
FLock.Leave;
end;
function TPowerThread.TLockQueue.PopItem: Pointer;
var
chkev: TEvent;
begin
FLock.Enter;
chkev := TEvent.Create(nil, True, True, FEvName);
if chkev.WaitFor(10) <> wrSignaled then
begin
chkev.Free;
FLock.Leave;
raise ESyncObjectException.Create('PowerThread Queue error');
end;
FReady.ResetEvent;
chkev.Free;
Result := inherited PopItem;
FReady.SetEvent;
FLock.Leave;
end;
function TPowerThread.TLockQueue.PeekItem: Pointer;
var
chkev: TEvent;
begin
FLock.Enter;
chkev := TEvent.Create(nil, True, True, FEvName);
if chkev.WaitFor(10) <> wrSignaled then
begin
chkev.Free;
FLock.Leave;
raise ESyncObjectException.Create('PowerThread Queue error');
end;
FReady.ResetEvent;
chkev.Free;
Result := inherited PeekItem;
FReady.SetEvent;
FLock.Leave;
end;
constructor TPowerThread.TLockQueue.Create;
begin
FLock := TCriticalSection.Create;
Inc(EvRef);
FEvName := Format(EvQueueFmt, [EvRef]);
FReady := TEvent.Create(nil, True, True, FEvName);
inherited Create;
end;
destructor TPowerThread.TLockQueue.Destroy;
begin
FReady.Free;
FLock.Free;
inherited Destroy;
end;
{ TPowerThread }
procedure TPowerThread.DoSyncCallBack;
begin
FSyncCall(FData);
end;
procedure TPowerThread.Execute;
var
c: PCmdRec;
begin
while not Terminated do
begin
c := FJobQueue.Pop;
if Assigned(c) then
begin
c^.method(c^.params);
c^.Done^ := True;
if Assigned(c^.CallBack) then
begin
FSyncCall := c^.CallBack;
FData := c^.Data;
Synchronize(@DoSyncCallBack);
end;
SetLength(c^.params,0);
Dispose(c);
end;
Sleep(1); // ThreadSwitch doesn't work on all platforms
end;
end;
constructor TPowerThread.Create(CreateSuspended: boolean; const StackSize: SizeUInt);
begin
FJobQueue := TLockQueue.Create;
inherited Create(CreateSuspended, StackSize);
end;
destructor TPowerThread.Destroy;
var
c: PCmdRec;
begin
while FJobQueue.Count > 0 do
begin
c := FJobQueue.Pop;
SetLength(c^.params, 0); // ;-)
Dispose(c);
end;
inherited Destroy;
end;
procedure TPowerThread.Post(aMethod: TThreadMethod; Args: array of const;
var Done: boolean; aCallBack: TThreadCallBack; aData: Pointer);
var
c: PCmdRec;
i: smallint;
begin
New(c);
with c^ do
begin
method := aMethod;
SetLength(params, 1 + High(Args));
for i := 0 to High(Args) do
params[i] := Args[i];
CallBack := aCallBack;
Data := aData;
end;
c^.Done := @Done;
c^.Done^ := False;
FJobQueue.Push(c);
end;
{ TThreadedComponent }
function TThreadedComponent.GetSuspended: boolean;
begin
Result := FThread.Suspended;
end;
procedure TThreadedComponent.SetSuspended(AValue: boolean);
begin
FThread.Suspended := AValue;
end;
constructor TThreadedComponent.Create(AOwner: TComponent;
CreateSuspended: boolean; const StackSize: SizeUInt);
begin
inherited Create(AOwner);
FThread := TPowerThread.Create(True, StackSize);
FThread.FreeOnTerminate := True;
FThread.Suspended := CreateSuspended;
end;
destructor TThreadedComponent.Destroy;
begin
FThread.Terminate;
inherited Destroy;
end;
procedure TThreadedComponent.Post(aMethod: TThreadMethod; Args: array of const;
var Done: boolean; aCallBack: TThreadCallBack; aData: Pointer);
begin
FThread.Post(aMethod, Args, Done, aCallBack, aData);
end;
end.