X
xingyanlin
Unregistered / Unconfirmed
GUEST, unregistred user!
下面这个控件很是好用，在Delphi5下可用，但就是在D6下安装好后也不能用！
当拖到窗体上时出错：access violation at address 51002ce3 in module 'dclusr60.bpl',read of address 00000030
谁能解决！以下源码！
=============================
unit MultiTasker;
interface
uses
SysUtils, Classes, Windows, Messages;
type
EMultiTaskerError = Exception;
TCustomThread = class;
TCustomThreadList = class;
TMultiTasker = class(TComponent)
private
FCriticalSection: TRTLCriticalSection;
FInternalCriticalSection: TRTLCriticalSection;
FMainThread: TCustomThread;
FActiveThreads: TCustomThreadList;
FQueue: TList;
FMaxTask: Integer;
FDefaultPriority: TThreadPriority;
FLaunchCounter: Integer;
{}
FOnError: TThreadMethod;
FOnTaskLaunched: TThreadMethod;
FOnTaskFinished: TThreadMethod;
FOnAllFinished: TThreadMethod;
FOnWaiting: TThreadMethod;
{}
FWaiting: Boolean;
FEventQueue: TList;
{}
FLastError: string;
FLastTaskId: string;
{}
procedure SetMaxTask(Value: Integer);
procedure SetDefaultPriority(Value: TThreadPriority);
{}
function GetExecuting: Boolean;
function GetSuspended: Boolean;
protected
procedure HandleQueue;
{}
procedure AddEvent(SyncThread: TCustomThread;
Proc: TThreadMethod;
ThreadId, ErrorMessage: string);
procedure HandleSharedEvents;
{}
proceduredo
SuspendAll;
proceduredo
ResumeAll;
{}
procedure InternalLock;
procedure InternalUnLock;
public
constructor Create(AOwner: TComponent);
override;
destructor Destroy;
override;
{}
procedure SuspendAll;
procedure ResumeAll;
{}
function LaunchTask(Method: TThreadMethod): string;
function LaunchCustomTask(Method: TThreadMethod;
Priority: TThreadPriority;
TaskId: string): string;
procedure Synchronize(Method: TThreadMethod);
{}
function WaitTermination(MsLimit: Integer): Boolean;
{}
procedure LockExecution;
procedure UnLockExecution;
{}
function CurrentTaskId: string;
{}
function SuspendTask(TaskId: string): Boolean;
function ResumeTask(TaskId: string): Boolean;
function TerminateTask(TaskId: string): Boolean;
{}
procedure GetActiveTasks(Strings: TStrings);
procedure GetQueuedTasks(Strings: TStrings);
function TaskActive(TaskId: string): Boolean;
function TaskSuspended(TaskId: string): Boolean;
function TaskHandle(TaskId: string): Integer;
{}
property Suspended: Boolean read GetSuspended;
property Executing: Boolean read GetExecuting;
{}
property LastError: string read FLastError;
property LastTaskId: string read FLastTaskId;
{}
property MainThread: TCustomThread read FMainThread;
{}
published
property MaxSimultaneousTask: Integer read FMaxTask write SetMaxTask;
property DefaultPriority: TThreadPriority read FDefaultPriority write SetDefaultPriority;
{}
property OnError: TThreadMethod read FOnError write FOnError;
property OnTaskLaunched: TThreadMethod read FOnTaskLaunched write FOnTaskLaunched;
property OnTaskFinished: TThreadMethod read FOnTaskFinished write FOnTaskFinished;
property OnAllTaskFinished: TThreadMethod read FOnAllFinished write FOnAllFinished;
property OnWaiting: TThreadMethod read FOnWaiting write FOnWaiting;
end;
{ Note : the Suspended property of TCustomThread is rewritten because I
have experienced problems with the Suspended property of TThread }
TCustomThread = class(TThread)
private
FExecuting: Boolean;
FMultiTaskerId: DWORD;
FSuspended: Boolean;
FMethod: TThreadMethod;
FThreadId: string;
FError: string;
{}
function GetSystemId: DWORD;
protected
procedure Execute;
override;
{}
procedure Notifyend;
public
constructor Create(Method: TThreadMethod;
Priority: TThreadPriority;
Id: string;
ParentMultiTasker: DWORD);
{}
property SystemId: DWORD read GetSystemId;
{}
property Executing: Boolean read FExecuting write FExecuting;
property Suspended: Boolean read FSuspended write FSuspended;
property Method: TThreadMethod read FMethod write FMethod;
property ThreadId: string read FThreadId write FThreadId;
property LastError: string read FError write FError;
end;
TCustomThreadList = class(TList)
private
function GetItem(Idx: Integer): TCustomThread;
function GetItemByName(ThreadId: string): TCustomThread;
function GetItemBySystemId(SystemId: DWORD): TCustomThread;
public
function IndexOfId(ThreadId: string): Integer;
function Last: TCustomThread;
{}
property ItemBySystemId[SystemId: DWORD]: TCustomThread read GetItemBySystemId;
property ItemByName[ThreadId: string]: TCustomThread read GetItemByName;
property Items[Idx: Integer]: TCustomThread read GetItem;
default;
end;
procedure Register;
const
msgThreadExecuting = 'Thread currently executing !';
msgInvalidTaskId = 'Task "%s" not found !';
msgWaitInAppThreadOnly = 'The WaitTermination procedure can only be called ' +
'in the main application thread';
msgUnableToSynchronize = 'Impossible to synchronize a thread while the ' +
'WaitTermination procedure is active !';
msgImpossibleToChangeWhileExecuting = 'Impossible to modify the MaxTask property' +
' while the Tasks are executing !';
msgThreadIdAlreadyRunning = 'A task named "%s" is already running !';
msgNoTaskRunning = 'There are no task currently running !';
msgThreadIdReserved = 'The "%s" identifier is not a valid identifier (reserved by MultiTasker).';
msgTaskCantSelfTerminate = 'Task "%s" is not allowed to initiate self-destruct';
{ French consts :
msgThreadExecuting = 'Thread en cours d''閤閏ution !';
msgInvalidTaskId = 'T鈉he "%s" non trouv閑 !';
msgWaitInAppThreadOnly = 'La proc閐ure WaitForTermination ne peut 阾re appel閑' +
' que dans le Thread principal de l''application';
msgUnableToSynchronize = 'Impossible de synchroniser un thread lorsque la ' +
'proc閐ure WaitTermination est active !';
msgImpossibleToChangeWhileExecuting = 'Impossible de modifier la propri閠?MaxTask' +
' lorsque des t鈉hes sont en cours d''閤閏ution !';
msgThreadIdAlreadyRunning = 'Une t鈉he nomm閑 "%s" est d閖?en cours d''閤閏ution !';
msgNoTaskRunning = 'Il n''y a pas de t鈉he en cours d''閤閏ution !';
msgThreadIdReserved = 'L''identificateur "%s" n''est pas valide (r閟erv?par le MultiTasker).';
msgTaskCantSelfTerminate = 'La t鈉he "%s" n''est pas autoris閑 ?s''auto-d閠ruire';
}
implementation
var HAppThread: DWORD;
type
TThreadParams = record
Method: TThreadMethod;
Priority: TThreadPriority;
ThreadId: string[255];
end;
PThreadParams = ^TThreadParams;
TSharedEvent = record
SyncThread: TCustomThread;
EventProc: TThreadMethod;
ErrorMessage: string[255];
TaskId: string[255];
end;
PSharedEvent = ^TSharedEvent;
procedure TMultiTasker.HandleQueue;
var i: Integer;
Msg : TMsg;
P: PThreadParams;
procedure TryProcessEvents;
begin
if not FWaiting then
HandleSharedEvents;
end;
function GetMessage: Boolean;
begin
Result:= PeekMessage(Msg, 0, 0, High(Integer), PM_REMOVE);
end;
begin
while not FMainThread.Terminateddo
begin
FMainThread.FExecuting:= True;
{}
repeat
{ 0 - Wait for messages ... empty the message queue }
WaitMessage;
if GetMessage then
repeat until not GetMessage;
{}
{ 1- Check if threads have finished }
for i:= FActiveThreads.Count - 1do
wnto 0do
begin
if not FActiveThreads.Executing then
begin
if FActiveThreads.LastError <> '' then
begin
if Assigned(OnError) then
begin
AddEvent(FMainThread, OnError, FActiveThreads.ThreadId, FActiveThreads.LastError);
TryProcessEvents;
end;
FActiveThreads.LastError:= '';
end;
if Assigned(OnTaskFinished) then
begin
AddEvent(FMainThread, OnTaskFinished, FActiveThreads.ThreadId, '');
TryProcessEvents;
end;
FActiveThreads.Free;
FActiveThreads.Delete(i);
end;
end;
{ 2- Check queue for procs to execute and launch them if any }
while (FQueue.Count > 0) and (FActiveThreads.Count < MaxSimultaneousTask)do
begin
P:= FQueue[0];
FQueue.Delete(0);
try
FActiveThreads.Add(TCustomThread.Create(P^.Method, P^.Priority, P^.ThreadId,
FMainThread.SystemId));
if Assigned(FOnTaskLaunched) then
begin
AddEvent(FMainThread, FOnTaskLaunched, P^.ThreadId, '');
TryProcessEvents;
end;
finally
Dispose(P);
end;
end;
TryProcessEvents;
until FActiveThreads.Count = 0;
if Assigned(OnAllTaskFinished) then
AddEvent(FMainThread, OnAllTaskFinished, Name, '');
TryProcessEvents;
{}
FMainThread.FExecuting:= False;
SuspendThread(FMainThread.Handle);
end;
end;
procedure TMultiTasker.AddEvent(SyncThread: TCustomThread;
Proc: TThreadMethod;
ThreadId, ErrorMessage: string);
var P: PSharedEvent;
begin
New(P);
P^.SyncThread:= SyncThread;
P^.EventProc:= Proc;
P^.TaskId:= ThreadId;
P^.ErrorMessage:= ErrorMessage;
FEventQueue.Add(P);
end;
procedure TMultiTasker.HandleSharedEvents;
var P: PSharedEvent;
S: TSharedEvent;
begin
while FEventQueue.Count > 0do
begin
InternalLock;
try
P:= FEventQueue[0];
S:= P^;
Dispose(P);
FEventQueue.Delete(0);
finally
InternalUnLock;
end;
{}
FLastError:= S.ErrorMessage;
FLastTaskId:= S.TaskId;
if FWaiting or (S.SyncThread = nil) then
S.EventProc // Execute in the main thread
else
S.SyncThread.Synchronize(S.EventProc);
FLastTaskId:= '';
FLastError:= '';
end;
end;
procedure TMultiTasker.DoSuspendAll;
var i: Integer;
begin
if not Executing then
raise EMultiTaskerError.Create(msgNoTaskRunning);
if Suspended then
Exit;
FMainThread.Suspended:= True;
for i:= 0 to FActiveThreads.Count - 1do
begin
FActiveThreads.Suspended:= True;
SuspendThread(FActiveThreads.Handle);
end;
SuspendThread(FMainThread.Handle);
end;
procedure TMultiTasker.DoResumeAll;
var i: Integer;
begin
if not Suspended then
Exit;
FMainThread.Suspended:= False;
ResumeThread(FMainThread.Handle);
for i:= 0 to FActiveThreads.Count - 1do
begin
FActiveThreads.Suspended:= False;
ResumeThread(FActiveThreads.Handle);
end;
end;
procedure TMultiTasker.SuspendAll;
begin
// Synchronize if used to avoid a thread from suspending itself before the others ...
if not FMainThread.Suspended then
Synchronize(DoSuspendAll);
end;
procedure TMultiTasker.ResumeAll;
begin
if FMainThread.Suspended then
Synchronize(DoResumeAll);
end;
function TMultiTasker.SuspendTask(TaskId: string): Boolean;
var Thread: TCustomThread;
begin
InternalLock;
try
Thread:= FActiveThreads.ItemByName[TaskId];
Result:= Thread <> nil;
if Result then
begin
Thread.Suspended:= True;
SuspendThread(Thread.Handle);
end;
finally
InternalUnLock;
end;
end;
function TMultiTasker.ResumeTask(TaskId: string): Boolean;
var Thread: TCustomThread;
begin
InternalLock;
try
Thread:= FActiveThreads.ItemByName[TaskId];
Result:= Thread <> nil;
if Result then
Thread.Suspended:= ResumeThread(Thread.Handle) in [0, 1]
else
raise EMultiTaskerError.Create(Format(msgInvalidTaskId, [TaskId]));
finally
InternalUnLock;
end;
end;
function TMultiTasker.TerminateTask(TaskId: string): Boolean;
var Thread: TCustomThread;
begin
InternalLock;
try
Thread:= FActiveThreads.ItemByName[TaskId];
Result:= Thread <> nil;
if Result then
begin
if Thread.Handle = GetCurrentThreadId then
raise EMultiTaskerError.Create(Format(msgTaskCantSelfTerminate, [TaskId]));
Result:= TerminateThread(Thread.Handle, 0);
if Result then
Thread.Notifyend;
end else
raise EMultiTaskerError.Create(Format(msgInvalidTaskId, [TaskId]));
finally
InternalUnLock;
end;
end;
function TMultiTasker.LaunchTask(Method: TThreadMethod): string;
begin
Result:= LaunchCustomTask(Method, DefaultPriority, '');
end;
function TMultiTasker.LaunchCustomTask(Method: TThreadMethod;
Priority: TThreadPriority;
TaskId: string): string;
var P: PThreadParams;
begin
InternalLock;
try
if TaskId = '' then
TaskId:= IntToStr(FLaunchCounter);
if FActiveThreads.IndexOfId(TaskId) <> -1 then
raise EMultiTaskerError.Create(Format(msgThreadIdAlreadyRunning, [TaskId]));
if (CompareText(TaskId, 'MULTITASKER') = 0) or (CompareText(TaskId, 'UNKNOWN') = 0) or
(CompareText(TaskId, 'MAIN') = 0) then
raise EMultiTaskerError.Create(Format(msgThreadIdReserved, [TaskId]));
New(P);
P^.Method:= Method;
P^.Priority:= Priority;
P^.ThreadId:= TaskId;
Result:= P^.ThreadId;
Inc(FLaunchCounter);
FQueue.Add(P);
if not FMainThread.Executing then
ResumeThread(FMainThread.Handle);
while not PostThreadMessage(FMainThread.SystemId, WM_USER, 0, 0)do
Sleep(0);
// Necessary for the first launch
finally
InternalUnLock;
end;
end;
procedure TMultiTasker.Synchronize(Method: TThreadMethod);
var HThread: DWORD;
Thread: TCustomThread;
begin
HThread:= GetCurrentThreadId;
if HThread = HAppThread then
Thread:= nil
else
if HThread = FMainThread.SystemId then
Thread:= FMainThread
else
begin
InternalLock;
try
Thread:= FActiveThreads.ItemBySystemId[HThread];
finally
InternalUnLock;
end;
end;
if Thread <> nil then
begin
if FWaiting then
raise EMultiTaskerError.Create(msgUnableToSynchronize)
else
Thread.Synchronize(Method);
end else
Method;
// We are in the main AppThread or in an unknown thread ...
end;
function TMultiTasker.WaitTermination(MsLimit: Integer): Boolean;
var P: Integer;
H: Integer;
D: TDateTime;
begin
Result:= not Executing;
if Result then
Exit;
if GetCurrentThreadId <> HAppThread then
raise EMultiTaskerError.Create(msgWaitInAppThreadOnly);
FWaiting:= True;
try
H:= GetCurrentThread;
P:= GetThreadPriority(H);
SetThreadPriority(H, THREAD_PRIORITY_IDLE);
D:= Now;
while Executingdo
begin
if (MsLimit >= 0) and (MsLimit - (Now - D) * 24 * 60 * 60 * 1000 <= 0) then
Break;
HandleSharedEvents;
if Assigned(OnWaiting) then
OnWaiting;
end;
SetThreadPriority(H, P);
HandleSharedEvents;
Result:= not Executing;
finally
FWaiting:= False;
end;
end;
procedure TMultiTasker.LockExecution;
begin
EnterCriticalSection(FCriticalSection);
end;
procedure TMultiTasker.UnLockExecution;
begin
LeaveCriticalSection(FCriticalSection);
end;
procedure TMultiTasker.InternalLock;
begin
EnterCriticalSection(FInternalCriticalSection);
end;
procedure TMultiTasker.InternalUnLock;
begin
LeaveCriticalSection(FInternalCriticalSection);
end;
function TMultiTasker.CurrentTaskId: string;
var H: DWORD;
T: TCustomThread;
begin
H:= GetCurrentThreadId;
if H = HAppThread then
Result:= 'MAIN'
else
if H = FMainThread.SystemId then
Result:= 'MULTITASKER'
else
begin
InternalLock;
try
T:= FActiveThreads.ItemBySystemId[H];
if T = nil then
Result:= 'UNKNOWN'
else
Result:= T.ThreadId;
finally
InternalUnLock;
end;
end;
end;
procedure TMultiTasker.GetActiveTasks(Strings: TStrings);
var i: Integer;
begin
InternalLock;
try
for i:= FActiveThreads.Count - 1do
wnto 0do
begin
if FActiveThreads.Suspended then
Strings.Add(FActiveThreads.ThreadId + ' Suspended')
else
Strings.Add(FActiveThreads.ThreadId + ' not Suspended');
end;
finally
InternalUnLock;
end;
end;
procedure TMultiTasker.GetQueuedTasks(Strings: TStrings);
var i: Integer;
begin
InternalLock;
try
for i:= 0 to FQueue.Count - 1do
Strings.Add(PThreadParams(FQueue)^.ThreadId);
finally
InternalUnLock;
end;
end;
function TMultiTasker.TaskActive(TaskId: string): Boolean;
begin
InternalLock;
try
Result:= FActiveThreads.ItemByName[TaskId] <> nil;
finally
InternalUnLock;
end;
end;
function TMultiTasker.TaskSuspended(TaskId: string): Boolean;
var Thread: TCustomThread;
begin
{$WARNINGS OFF} // Removes a stupid warning.
InternalLock;
try
Thread:= FActiveThreads.ItemByName[TaskId];
if Thread <> nil then
raise EMultiTaskerError.Create(Format(msgInvalidTaskId, [TaskId]));
Result:= Thread.Suspended;
finally
InternalUnLock;
end;
end;
{$WARNINGS OFF}
function TMultiTasker.TaskHandle(TaskId: string): Integer;
var Thread: TCustomThread;
begin
InternalLock;
try
Thread:= FActiveThreads.ItemByName[TaskId];
if Thread <> nil then
raise EMultiTaskerError.Create(Format(msgInvalidTaskId, [TaskId]));
Result:= Thread.Handle;
finally
InternalUnLock;
end;
end;
function TMultiTasker.GetExecuting: Boolean;
begin
Result:= FMainThread.Executing;
end;
function TMultiTasker.GetSuspended: Boolean;
begin
Result:= FMainThread.Suspended;
end;
procedure TMultiTasker.SetMaxTask(Value: Integer);
begin
if Executing then
raise EMultiTaskerError.Create(msgImpossibleToChangeWhileExecuting);
if Value <= 0 then
Value:= 1;
FMaxTask:= Value;
end;
procedure TMultiTasker.SetDefaultPriority(Value: TThreadPriority);
var i: Integer;
begin
InternalLock;
try
for i:= 0 to FActiveThreads.Count - 1do
//do
not modify custom priority threads
if FActiveThreads.Priority = DefaultPriority then
FActiveThreads.Priority:= Value;
FDefaultPriority:= Value;
finally
InternalUnLock;
end;
end;
constructor TMultiTasker.Create(AOwner: TComponent);
begin
FLaunchCounter:= 1;
FWaiting:= False;
InitializeCriticalSection(FCriticalSection);
InitializeCriticalSection(FInternalCriticalSection);
FActiveThreads:= TCustomThreadList.Create;
FQueue:= TList.Create;
FEventQueue:= TList.Create;
FDefaultPriority:= tpNormal;
FMainThread:= TCustomThread.Create(HandleQueue, tpTimeCritical, 'MAIN', 0);
MaxSimultaneousTask:= 3;
inherited Create(AOwner);
end;
destructor TMultiTasker.Destroy;
var i: Integer;
begin
if Executing then
SuspendAll;
for i:= 0 to FActiveThreads.Count - 1do
begin
FActiveThreads.Suspend;
// Necessary to free it
FActiveThreads.Free;
end;
FMainThread.Suspend;
// To ensure its destruction
FMainThread.Free;
FActiveThreads.Free;
for i:= 0 to FQueue.Count - 1do
Dispose(FQueue);
FQueue.Free;
for i:= 0 to FEventQueue.Count - 1do
Dispose(FEventQueue);
FEventQueue.Free;
DeleteCriticalSection(FInternalCriticalSection);
DeleteCriticalSection(FCriticalSection);
inherited Destroy;
end;
{ TCustomThread }
constructor TCustomThread.Create(Method: TThreadMethod;
Priority: TThreadPriority;
Id: string;
ParentMultiTasker: DWORD);
begin
FMethod:= Method;
Self.Priority:= Priority;
Self.ThreadId:= Id;
FMultiTaskerId:= ParentMultiTasker;
FExecuting:= False;
if ParentMultiTasker = 0 then
inherited Create(True)
else
inherited Create(False);
end;
function TCustomThread.GetSystemId: DWORD;
begin
Result:= inherited ThreadId;
end;
procedure TCustomThread.Notifyend;
begin
FExecuting:= False;
if FMultiTaskerId <> 0 then
while not PostThreadMessage(FMultiTaskerId, WM_USER, 0, 0)do
Sleep(0);
end;
procedure TCustomThread.Execute;
begin
FExecuting:= True;
if Assigned(Method) then
try
Method;
except
on E: Exceptiondo
begin
LastError:= E.Message;
Notifyend;
Terminate;
Exit;
end;
end;
Notifyend;
end;
{ TCustomThreadList }
function TCustomThreadList.GetItem(Idx: Integer): TCustomThread;
begin
Result:= inherited Items[Idx];
end;
function TCustomThreadList.GetItemBySystemId(SystemId: DWORD): TCustomThread;
var i: Integer;
begin
i:= 0;
while (i < Count) and (Items.SystemId <> SystemId)do
Inc(i);
if i <> Count then
Result:= Items
else
Result:= nil;
end;
function TCustomThreadList.GetItemByName(ThreadId: string): TCustomThread;
var Idx: Integer;
begin
Idx:= IndexOfId(ThreadId);
if Idx = -1 then
Result:= nil
else
Result:= inherited Items[Idx];
end;
function TCustomThreadList.IndexOfId(ThreadId: string): Integer;
var i: Integer;
begin
i:= 0;
while (i < Count) and (CompareText(Items.ThreadId, ThreadId) <> 0)do
Inc(i);
if i <> Count then
Result:= i
else
Result:= -1;
end;
function TCustomThreadList.Last: TCustomThread;
begin
Result:= inherited Last;
end;
{ Register }
procedure Register;
begin
RegisterComponents('XYLsys', [TMultiTasker]);
end;
initialization
HAppThread:= GetCurrentThreadId;
end.
当拖到窗体上时出错：access violation at address 51002ce3 in module 'dclusr60.bpl',read of address 00000030
谁能解决！以下源码！
=============================
unit MultiTasker;
interface
uses
SysUtils, Classes, Windows, Messages;
type
EMultiTaskerError = Exception;
TCustomThread = class;
TCustomThreadList = class;
TMultiTasker = class(TComponent)
private
FCriticalSection: TRTLCriticalSection;
FInternalCriticalSection: TRTLCriticalSection;
FMainThread: TCustomThread;
FActiveThreads: TCustomThreadList;
FQueue: TList;
FMaxTask: Integer;
FDefaultPriority: TThreadPriority;
FLaunchCounter: Integer;
{}
FOnError: TThreadMethod;
FOnTaskLaunched: TThreadMethod;
FOnTaskFinished: TThreadMethod;
FOnAllFinished: TThreadMethod;
FOnWaiting: TThreadMethod;
{}
FWaiting: Boolean;
FEventQueue: TList;
{}
FLastError: string;
FLastTaskId: string;
{}
procedure SetMaxTask(Value: Integer);
procedure SetDefaultPriority(Value: TThreadPriority);
{}
function GetExecuting: Boolean;
function GetSuspended: Boolean;
protected
procedure HandleQueue;
{}
procedure AddEvent(SyncThread: TCustomThread;
Proc: TThreadMethod;
ThreadId, ErrorMessage: string);
procedure HandleSharedEvents;
{}
proceduredo
SuspendAll;
proceduredo
ResumeAll;
{}
procedure InternalLock;
procedure InternalUnLock;
public
constructor Create(AOwner: TComponent);
override;
destructor Destroy;
override;
{}
procedure SuspendAll;
procedure ResumeAll;
{}
function LaunchTask(Method: TThreadMethod): string;
function LaunchCustomTask(Method: TThreadMethod;
Priority: TThreadPriority;
TaskId: string): string;
procedure Synchronize(Method: TThreadMethod);
{}
function WaitTermination(MsLimit: Integer): Boolean;
{}
procedure LockExecution;
procedure UnLockExecution;
{}
function CurrentTaskId: string;
{}
function SuspendTask(TaskId: string): Boolean;
function ResumeTask(TaskId: string): Boolean;
function TerminateTask(TaskId: string): Boolean;
{}
procedure GetActiveTasks(Strings: TStrings);
procedure GetQueuedTasks(Strings: TStrings);
function TaskActive(TaskId: string): Boolean;
function TaskSuspended(TaskId: string): Boolean;
function TaskHandle(TaskId: string): Integer;
{}
property Suspended: Boolean read GetSuspended;
property Executing: Boolean read GetExecuting;
{}
property LastError: string read FLastError;
property LastTaskId: string read FLastTaskId;
{}
property MainThread: TCustomThread read FMainThread;
{}
published
property MaxSimultaneousTask: Integer read FMaxTask write SetMaxTask;
property DefaultPriority: TThreadPriority read FDefaultPriority write SetDefaultPriority;
{}
property OnError: TThreadMethod read FOnError write FOnError;
property OnTaskLaunched: TThreadMethod read FOnTaskLaunched write FOnTaskLaunched;
property OnTaskFinished: TThreadMethod read FOnTaskFinished write FOnTaskFinished;
property OnAllTaskFinished: TThreadMethod read FOnAllFinished write FOnAllFinished;
property OnWaiting: TThreadMethod read FOnWaiting write FOnWaiting;
end;
{ Note : the Suspended property of TCustomThread is rewritten because I
have experienced problems with the Suspended property of TThread }
TCustomThread = class(TThread)
private
FExecuting: Boolean;
FMultiTaskerId: DWORD;
FSuspended: Boolean;
FMethod: TThreadMethod;
FThreadId: string;
FError: string;
{}
function GetSystemId: DWORD;
protected
procedure Execute;
override;
{}
procedure Notifyend;
public
constructor Create(Method: TThreadMethod;
Priority: TThreadPriority;
Id: string;
ParentMultiTasker: DWORD);
{}
property SystemId: DWORD read GetSystemId;
{}
property Executing: Boolean read FExecuting write FExecuting;
property Suspended: Boolean read FSuspended write FSuspended;
property Method: TThreadMethod read FMethod write FMethod;
property ThreadId: string read FThreadId write FThreadId;
property LastError: string read FError write FError;
end;
TCustomThreadList = class(TList)
private
function GetItem(Idx: Integer): TCustomThread;
function GetItemByName(ThreadId: string): TCustomThread;
function GetItemBySystemId(SystemId: DWORD): TCustomThread;
public
function IndexOfId(ThreadId: string): Integer;
function Last: TCustomThread;
{}
property ItemBySystemId[SystemId: DWORD]: TCustomThread read GetItemBySystemId;
property ItemByName[ThreadId: string]: TCustomThread read GetItemByName;
property Items[Idx: Integer]: TCustomThread read GetItem;
default;
end;
procedure Register;
const
msgThreadExecuting = 'Thread currently executing !';
msgInvalidTaskId = 'Task "%s" not found !';
msgWaitInAppThreadOnly = 'The WaitTermination procedure can only be called ' +
'in the main application thread';
msgUnableToSynchronize = 'Impossible to synchronize a thread while the ' +
'WaitTermination procedure is active !';
msgImpossibleToChangeWhileExecuting = 'Impossible to modify the MaxTask property' +
' while the Tasks are executing !';
msgThreadIdAlreadyRunning = 'A task named "%s" is already running !';
msgNoTaskRunning = 'There are no task currently running !';
msgThreadIdReserved = 'The "%s" identifier is not a valid identifier (reserved by MultiTasker).';
msgTaskCantSelfTerminate = 'Task "%s" is not allowed to initiate self-destruct';
{ French consts :
msgThreadExecuting = 'Thread en cours d''閤閏ution !';
msgInvalidTaskId = 'T鈉he "%s" non trouv閑 !';
msgWaitInAppThreadOnly = 'La proc閐ure WaitForTermination ne peut 阾re appel閑' +
' que dans le Thread principal de l''application';
msgUnableToSynchronize = 'Impossible de synchroniser un thread lorsque la ' +
'proc閐ure WaitTermination est active !';
msgImpossibleToChangeWhileExecuting = 'Impossible de modifier la propri閠?MaxTask' +
' lorsque des t鈉hes sont en cours d''閤閏ution !';
msgThreadIdAlreadyRunning = 'Une t鈉he nomm閑 "%s" est d閖?en cours d''閤閏ution !';
msgNoTaskRunning = 'Il n''y a pas de t鈉he en cours d''閤閏ution !';
msgThreadIdReserved = 'L''identificateur "%s" n''est pas valide (r閟erv?par le MultiTasker).';
msgTaskCantSelfTerminate = 'La t鈉he "%s" n''est pas autoris閑 ?s''auto-d閠ruire';
}
implementation
var HAppThread: DWORD;
type
TThreadParams = record
Method: TThreadMethod;
Priority: TThreadPriority;
ThreadId: string[255];
end;
PThreadParams = ^TThreadParams;
TSharedEvent = record
SyncThread: TCustomThread;
EventProc: TThreadMethod;
ErrorMessage: string[255];
TaskId: string[255];
end;
PSharedEvent = ^TSharedEvent;
procedure TMultiTasker.HandleQueue;
var i: Integer;
Msg : TMsg;
P: PThreadParams;
procedure TryProcessEvents;
begin
if not FWaiting then
HandleSharedEvents;
end;
function GetMessage: Boolean;
begin
Result:= PeekMessage(Msg, 0, 0, High(Integer), PM_REMOVE);
end;
begin
while not FMainThread.Terminateddo
begin
FMainThread.FExecuting:= True;
{}
repeat
{ 0 - Wait for messages ... empty the message queue }
WaitMessage;
if GetMessage then
repeat until not GetMessage;
{}
{ 1- Check if threads have finished }
for i:= FActiveThreads.Count - 1do
wnto 0do
begin
if not FActiveThreads.Executing then
begin
if FActiveThreads.LastError <> '' then
begin
if Assigned(OnError) then
begin
AddEvent(FMainThread, OnError, FActiveThreads.ThreadId, FActiveThreads.LastError);
TryProcessEvents;
end;
FActiveThreads.LastError:= '';
end;
if Assigned(OnTaskFinished) then
begin
AddEvent(FMainThread, OnTaskFinished, FActiveThreads.ThreadId, '');
TryProcessEvents;
end;
FActiveThreads.Free;
FActiveThreads.Delete(i);
end;
end;
{ 2- Check queue for procs to execute and launch them if any }
while (FQueue.Count > 0) and (FActiveThreads.Count < MaxSimultaneousTask)do
begin
P:= FQueue[0];
FQueue.Delete(0);
try
FActiveThreads.Add(TCustomThread.Create(P^.Method, P^.Priority, P^.ThreadId,
FMainThread.SystemId));
if Assigned(FOnTaskLaunched) then
begin
AddEvent(FMainThread, FOnTaskLaunched, P^.ThreadId, '');
TryProcessEvents;
end;
finally
Dispose(P);
end;
end;
TryProcessEvents;
until FActiveThreads.Count = 0;
if Assigned(OnAllTaskFinished) then
AddEvent(FMainThread, OnAllTaskFinished, Name, '');
TryProcessEvents;
{}
FMainThread.FExecuting:= False;
SuspendThread(FMainThread.Handle);
end;
end;
procedure TMultiTasker.AddEvent(SyncThread: TCustomThread;
Proc: TThreadMethod;
ThreadId, ErrorMessage: string);
var P: PSharedEvent;
begin
New(P);
P^.SyncThread:= SyncThread;
P^.EventProc:= Proc;
P^.TaskId:= ThreadId;
P^.ErrorMessage:= ErrorMessage;
FEventQueue.Add(P);
end;
procedure TMultiTasker.HandleSharedEvents;
var P: PSharedEvent;
S: TSharedEvent;
begin
while FEventQueue.Count > 0do
begin
InternalLock;
try
P:= FEventQueue[0];
S:= P^;
Dispose(P);
FEventQueue.Delete(0);
finally
InternalUnLock;
end;
{}
FLastError:= S.ErrorMessage;
FLastTaskId:= S.TaskId;
if FWaiting or (S.SyncThread = nil) then
S.EventProc // Execute in the main thread
else
S.SyncThread.Synchronize(S.EventProc);
FLastTaskId:= '';
FLastError:= '';
end;
end;
procedure TMultiTasker.DoSuspendAll;
var i: Integer;
begin
if not Executing then
raise EMultiTaskerError.Create(msgNoTaskRunning);
if Suspended then
Exit;
FMainThread.Suspended:= True;
for i:= 0 to FActiveThreads.Count - 1do
begin
FActiveThreads.Suspended:= True;
SuspendThread(FActiveThreads.Handle);
end;
SuspendThread(FMainThread.Handle);
end;
procedure TMultiTasker.DoResumeAll;
var i: Integer;
begin
if not Suspended then
Exit;
FMainThread.Suspended:= False;
ResumeThread(FMainThread.Handle);
for i:= 0 to FActiveThreads.Count - 1do
begin
FActiveThreads.Suspended:= False;
ResumeThread(FActiveThreads.Handle);
end;
end;
procedure TMultiTasker.SuspendAll;
begin
// Synchronize if used to avoid a thread from suspending itself before the others ...
if not FMainThread.Suspended then
Synchronize(DoSuspendAll);
end;
procedure TMultiTasker.ResumeAll;
begin
if FMainThread.Suspended then
Synchronize(DoResumeAll);
end;
function TMultiTasker.SuspendTask(TaskId: string): Boolean;
var Thread: TCustomThread;
begin
InternalLock;
try
Thread:= FActiveThreads.ItemByName[TaskId];
Result:= Thread <> nil;
if Result then
begin
Thread.Suspended:= True;
SuspendThread(Thread.Handle);
end;
finally
InternalUnLock;
end;
end;
function TMultiTasker.ResumeTask(TaskId: string): Boolean;
var Thread: TCustomThread;
begin
InternalLock;
try
Thread:= FActiveThreads.ItemByName[TaskId];
Result:= Thread <> nil;
if Result then
Thread.Suspended:= ResumeThread(Thread.Handle) in [0, 1]
else
raise EMultiTaskerError.Create(Format(msgInvalidTaskId, [TaskId]));
finally
InternalUnLock;
end;
end;
function TMultiTasker.TerminateTask(TaskId: string): Boolean;
var Thread: TCustomThread;
begin
InternalLock;
try
Thread:= FActiveThreads.ItemByName[TaskId];
Result:= Thread <> nil;
if Result then
begin
if Thread.Handle = GetCurrentThreadId then
raise EMultiTaskerError.Create(Format(msgTaskCantSelfTerminate, [TaskId]));
Result:= TerminateThread(Thread.Handle, 0);
if Result then
Thread.Notifyend;
end else
raise EMultiTaskerError.Create(Format(msgInvalidTaskId, [TaskId]));
finally
InternalUnLock;
end;
end;
function TMultiTasker.LaunchTask(Method: TThreadMethod): string;
begin
Result:= LaunchCustomTask(Method, DefaultPriority, '');
end;
function TMultiTasker.LaunchCustomTask(Method: TThreadMethod;
Priority: TThreadPriority;
TaskId: string): string;
var P: PThreadParams;
begin
InternalLock;
try
if TaskId = '' then
TaskId:= IntToStr(FLaunchCounter);
if FActiveThreads.IndexOfId(TaskId) <> -1 then
raise EMultiTaskerError.Create(Format(msgThreadIdAlreadyRunning, [TaskId]));
if (CompareText(TaskId, 'MULTITASKER') = 0) or (CompareText(TaskId, 'UNKNOWN') = 0) or
(CompareText(TaskId, 'MAIN') = 0) then
raise EMultiTaskerError.Create(Format(msgThreadIdReserved, [TaskId]));
New(P);
P^.Method:= Method;
P^.Priority:= Priority;
P^.ThreadId:= TaskId;
Result:= P^.ThreadId;
Inc(FLaunchCounter);
FQueue.Add(P);
if not FMainThread.Executing then
ResumeThread(FMainThread.Handle);
while not PostThreadMessage(FMainThread.SystemId, WM_USER, 0, 0)do
Sleep(0);
// Necessary for the first launch
finally
InternalUnLock;
end;
end;
procedure TMultiTasker.Synchronize(Method: TThreadMethod);
var HThread: DWORD;
Thread: TCustomThread;
begin
HThread:= GetCurrentThreadId;
if HThread = HAppThread then
Thread:= nil
else
if HThread = FMainThread.SystemId then
Thread:= FMainThread
else
begin
InternalLock;
try
Thread:= FActiveThreads.ItemBySystemId[HThread];
finally
InternalUnLock;
end;
end;
if Thread <> nil then
begin
if FWaiting then
raise EMultiTaskerError.Create(msgUnableToSynchronize)
else
Thread.Synchronize(Method);
end else
Method;
// We are in the main AppThread or in an unknown thread ...
end;
function TMultiTasker.WaitTermination(MsLimit: Integer): Boolean;
var P: Integer;
H: Integer;
D: TDateTime;
begin
Result:= not Executing;
if Result then
Exit;
if GetCurrentThreadId <> HAppThread then
raise EMultiTaskerError.Create(msgWaitInAppThreadOnly);
FWaiting:= True;
try
H:= GetCurrentThread;
P:= GetThreadPriority(H);
SetThreadPriority(H, THREAD_PRIORITY_IDLE);
D:= Now;
while Executingdo
begin
if (MsLimit >= 0) and (MsLimit - (Now - D) * 24 * 60 * 60 * 1000 <= 0) then
Break;
HandleSharedEvents;
if Assigned(OnWaiting) then
OnWaiting;
end;
SetThreadPriority(H, P);
HandleSharedEvents;
Result:= not Executing;
finally
FWaiting:= False;
end;
end;
procedure TMultiTasker.LockExecution;
begin
EnterCriticalSection(FCriticalSection);
end;
procedure TMultiTasker.UnLockExecution;
begin
LeaveCriticalSection(FCriticalSection);
end;
procedure TMultiTasker.InternalLock;
begin
EnterCriticalSection(FInternalCriticalSection);
end;
procedure TMultiTasker.InternalUnLock;
begin
LeaveCriticalSection(FInternalCriticalSection);
end;
function TMultiTasker.CurrentTaskId: string;
var H: DWORD;
T: TCustomThread;
begin
H:= GetCurrentThreadId;
if H = HAppThread then
Result:= 'MAIN'
else
if H = FMainThread.SystemId then
Result:= 'MULTITASKER'
else
begin
InternalLock;
try
T:= FActiveThreads.ItemBySystemId[H];
if T = nil then
Result:= 'UNKNOWN'
else
Result:= T.ThreadId;
finally
InternalUnLock;
end;
end;
end;
procedure TMultiTasker.GetActiveTasks(Strings: TStrings);
var i: Integer;
begin
InternalLock;
try
for i:= FActiveThreads.Count - 1do
wnto 0do
begin
if FActiveThreads.Suspended then
Strings.Add(FActiveThreads.ThreadId + ' Suspended')
else
Strings.Add(FActiveThreads.ThreadId + ' not Suspended');
end;
finally
InternalUnLock;
end;
end;
procedure TMultiTasker.GetQueuedTasks(Strings: TStrings);
var i: Integer;
begin
InternalLock;
try
for i:= 0 to FQueue.Count - 1do
Strings.Add(PThreadParams(FQueue)^.ThreadId);
finally
InternalUnLock;
end;
end;
function TMultiTasker.TaskActive(TaskId: string): Boolean;
begin
InternalLock;
try
Result:= FActiveThreads.ItemByName[TaskId] <> nil;
finally
InternalUnLock;
end;
end;
function TMultiTasker.TaskSuspended(TaskId: string): Boolean;
var Thread: TCustomThread;
begin
{$WARNINGS OFF} // Removes a stupid warning.
InternalLock;
try
Thread:= FActiveThreads.ItemByName[TaskId];
if Thread <> nil then
raise EMultiTaskerError.Create(Format(msgInvalidTaskId, [TaskId]));
Result:= Thread.Suspended;
finally
InternalUnLock;
end;
end;
{$WARNINGS OFF}
function TMultiTasker.TaskHandle(TaskId: string): Integer;
var Thread: TCustomThread;
begin
InternalLock;
try
Thread:= FActiveThreads.ItemByName[TaskId];
if Thread <> nil then
raise EMultiTaskerError.Create(Format(msgInvalidTaskId, [TaskId]));
Result:= Thread.Handle;
finally
InternalUnLock;
end;
end;
function TMultiTasker.GetExecuting: Boolean;
begin
Result:= FMainThread.Executing;
end;
function TMultiTasker.GetSuspended: Boolean;
begin
Result:= FMainThread.Suspended;
end;
procedure TMultiTasker.SetMaxTask(Value: Integer);
begin
if Executing then
raise EMultiTaskerError.Create(msgImpossibleToChangeWhileExecuting);
if Value <= 0 then
Value:= 1;
FMaxTask:= Value;
end;
procedure TMultiTasker.SetDefaultPriority(Value: TThreadPriority);
var i: Integer;
begin
InternalLock;
try
for i:= 0 to FActiveThreads.Count - 1do
//do
not modify custom priority threads
if FActiveThreads.Priority = DefaultPriority then
FActiveThreads.Priority:= Value;
FDefaultPriority:= Value;
finally
InternalUnLock;
end;
end;
constructor TMultiTasker.Create(AOwner: TComponent);
begin
FLaunchCounter:= 1;
FWaiting:= False;
InitializeCriticalSection(FCriticalSection);
InitializeCriticalSection(FInternalCriticalSection);
FActiveThreads:= TCustomThreadList.Create;
FQueue:= TList.Create;
FEventQueue:= TList.Create;
FDefaultPriority:= tpNormal;
FMainThread:= TCustomThread.Create(HandleQueue, tpTimeCritical, 'MAIN', 0);
MaxSimultaneousTask:= 3;
inherited Create(AOwner);
end;
destructor TMultiTasker.Destroy;
var i: Integer;
begin
if Executing then
SuspendAll;
for i:= 0 to FActiveThreads.Count - 1do
begin
FActiveThreads.Suspend;
// Necessary to free it
FActiveThreads.Free;
end;
FMainThread.Suspend;
// To ensure its destruction
FMainThread.Free;
FActiveThreads.Free;
for i:= 0 to FQueue.Count - 1do
Dispose(FQueue);
FQueue.Free;
for i:= 0 to FEventQueue.Count - 1do
Dispose(FEventQueue);
FEventQueue.Free;
DeleteCriticalSection(FInternalCriticalSection);
DeleteCriticalSection(FCriticalSection);
inherited Destroy;
end;
{ TCustomThread }
constructor TCustomThread.Create(Method: TThreadMethod;
Priority: TThreadPriority;
Id: string;
ParentMultiTasker: DWORD);
begin
FMethod:= Method;
Self.Priority:= Priority;
Self.ThreadId:= Id;
FMultiTaskerId:= ParentMultiTasker;
FExecuting:= False;
if ParentMultiTasker = 0 then
inherited Create(True)
else
inherited Create(False);
end;
function TCustomThread.GetSystemId: DWORD;
begin
Result:= inherited ThreadId;
end;
procedure TCustomThread.Notifyend;
begin
FExecuting:= False;
if FMultiTaskerId <> 0 then
while not PostThreadMessage(FMultiTaskerId, WM_USER, 0, 0)do
Sleep(0);
end;
procedure TCustomThread.Execute;
begin
FExecuting:= True;
if Assigned(Method) then
try
Method;
except
on E: Exceptiondo
begin
LastError:= E.Message;
Notifyend;
Terminate;
Exit;
end;
end;
Notifyend;
end;
{ TCustomThreadList }
function TCustomThreadList.GetItem(Idx: Integer): TCustomThread;
begin
Result:= inherited Items[Idx];
end;
function TCustomThreadList.GetItemBySystemId(SystemId: DWORD): TCustomThread;
var i: Integer;
begin
i:= 0;
while (i < Count) and (Items.SystemId <> SystemId)do
Inc(i);
if i <> Count then
Result:= Items
else
Result:= nil;
end;
function TCustomThreadList.GetItemByName(ThreadId: string): TCustomThread;
var Idx: Integer;
begin
Idx:= IndexOfId(ThreadId);
if Idx = -1 then
Result:= nil
else
Result:= inherited Items[Idx];
end;
function TCustomThreadList.IndexOfId(ThreadId: string): Integer;
var i: Integer;
begin
i:= 0;
while (i < Count) and (CompareText(Items.ThreadId, ThreadId) <> 0)do
Inc(i);
if i <> Count then
Result:= i
else
Result:= -1;
end;
function TCustomThreadList.Last: TCustomThread;
begin
Result:= inherited Last;
end;
{ Register }
procedure Register;
begin
RegisterComponents('XYLsys', [TMultiTasker]);
end;
initialization
HAppThread:= GetCurrentThreadId;
end.