【控件功能】我来做练习-第58课-HTTPPool、PrimePool、ThreadPool，线程池

HTTPPool、PrimePool、ThreadPool，线程池

提示：这里可以添加技术概要

核心源码

提示：这里可以添加技术整体架构
procedure DemandInitProc(Manager:TPoolManager);
begin
if not Assigned(MainForm) then
Exit;

Manager.ConcurrentWorkersCount:=Trunc(MainForm.ConcurrentWorkersEdit.Value);
Manager.SpareWorkersCount:=Trunc(MainForm.SpareWorkersEdit.Value);

if not Manager.RestoreOwners then
	Manager.RegisterOwner(MainForm, MainForm.TasksStatus, MainForm.TasksComplete);

end;

{** TMainForm **}

procedure TMainForm.AddTasksButtonClick(Sender:TObject);
var
cc:Integer;
HTTPTask:THTTPTask;
begin
LogMemo.Clear;
{**
* Create once, assign needed event handlers and make later only clones with some customizing’s
*}
HTTPTask:=THTTPTask.Create(Self);
HTTPTask.OnDone:=TaskDone;
HTTPTask.OnStart:=TaskStart;
HTTPTask.OnCancel:=TaskCanceled;
HTTPTask.OnDownloadStatus:=TaskDownloadStatus;

for cc:=0 to URLMemo.Lines.Count - 1 do
begin
	HTTPTask.URL:=URLMemo.Lines[cc];

	if cc >= (URLMemo.Lines.Count - 3) then
		HTTPTask.Priority:=tpHighest
	else
		HTTPTask.Priority:=tpLowest;

	HTTPManager.AddTask(HTTPTask);

	HTTPTask:=THTTPTask(HTTPTask.Clone);
end;

end;

procedure TMainForm.CancelTasksButtonClick(Sender:TObject);
begin
if THTTPManager.HasSingleton then
HTTPManager.CancelTasksByOwner(Self);
end;

procedure TMainForm.ConcurrentWorkersEditChange(Sender:TObject);
begin
if THTTPManager.HasSingleton then
HTTPManager.ConcurrentWorkersCount:=Trunc(ConcurrentWorkersEdit.Value);
end;

procedure TMainForm.FormCreate(Sender:TObject);
begin
THTTPManager.RegisterSingletonOnDemandProc(DemandInitProc);
end;

procedure TMainForm.FormDestroy(Sender:TObject);
begin
TPoolManager.TerminateSingletonInstances;
end;

procedure TMainForm.SpareWorkersEditChange(Sender:TObject);
begin
if THTTPManager.HasSingleton then
HTTPManager.SpareWorkersCount:=Trunc(SpareWorkersEdit.Value);
end;

procedure TMainForm.TaskCanceled(Sender:TObject);
var
HTTPTask:THTTPTask;
begin
if not (Assigned(Sender) and (Sender is THTTPTask)) then
Exit;
HTTPTask:=THTTPTask(Sender);

LogMemo.Lines.Add(Format('Task canceled for "%s"', [HTTPTask.URL]));

end;

procedure TMainForm.TaskDone(Sender:TObject);
var
HTTPTask:THTTPTask;
ThreadID:Cardinal;
begin
if not (Assigned(Sender) and (Sender is THTTPTask)) then
Exit;
HTTPTask:=THTTPTask(Sender);

if Assigned(HTTPTask.Owner) and (HTTPTask.Owner is TPoolWorker) then
	ThreadID:=TPoolWorker(HTTPTask.Owner).ThreadID
else
	ThreadID:=0;

LogMemo.Lines.Add(Format('Task done for "%s". [HTTP-Code: %d], [Response-Size: %d Bytes], [ThreadID: %d]',
	[HTTPTask.URL, HTTPTask.ResponseCode, HTTPTask.ResponseSize, ThreadID]));

end;

procedure TMainForm.TaskDownloadStatus(Sender:TObject; Progress, MaxProgress:Int64);
var
HTTPTask:THTTPTask;
begin
if not (Assigned(Sender) and (Sender is THTTPTask)) then
Exit;
HTTPTask:=THTTPTask(Sender);
LogMemo.Lines.Add(Format(‘%d %% (%d of %d Bytes) downloaded of “%s”’,
[Round(Progress / MaxProgress * 100), Progress, MaxProgress, HTTPTask.URL]));
end;

procedure TMainForm.TasksComplete(Sender:TObject);
begin

end;

procedure TMainForm.TasksStatus(Sender:TObject; Progress:Single);
begin
ProgressBar.Position:=Round(Progress * 100);
end;

unit ThreadPool;

interface

{$INCLUDE Compile.inc}

uses
SysUtils, Generics.Defaults, Generics.Collections, Contnrs, SyncObjs, Windows, Classes, Forms
{ KaTeX parse error: Expected 'EOF', got '}' at position 16: IFDEF CODE_SITE}̲ , CodeSiteLog…ENDIF};

const
Version = ‘1.0.6’;

type
{**
* Class forward declarations
}
TPoolTask = class;
TPoolWorker = class;
TPoolManager = class;
{ *
* Class type declarations
}
TPoolTaskClass = class of TPoolTask;
TPoolWorkerClass = class of TPoolWorker;
TPoolManagerClass = class of TPoolManager;
{ *
* Derived generic list types
}
TWorkerList = TObjectList;
TTaskList = TObjectList;
{ *
* Enumeration of pissible states of a task
*
* @see TPoolTask
}
TTaskState = (tsUnknown, tsInWork, tsError, tsSuccess);
{ *
* Enumeration for common priorities of a task
*
* @see TPoolTask.Priority
}
TTaskPriority = (
tpLowest = 0, tpLower = 1, tpLow = 2,
tpNormal = 3,
tpHigh = 4, tpHigher = 5, tpHighest = 255,
tpCustom = -1);
{ *
* Enumeration of possible states of a worker
*
* @see TPoolWorker
}
TWorkerState = (wsReady, wsBusy, wsTaskDone);
{ *
* Anonymous method for a task
*
* Compatible to TPoolTask.IsTheSame
}
TTaskFunc = reference to function(Task:TPoolTask):Boolean;
{ *
* Status event
*
* @param Progress Float value between 0 and 1. 1 = 100% = Complete.
*}
TStatusEvent = reference to procedure(Sender:TObject; Progress:Single);

TManagerProc = TProc<TPoolManager>;
{**
 * Anonymous notify event, which is compatible with commonly used TNotifyEvent
 *}
TAnonymousNotifyEvent = reference to procedure(Sender:TObject);

{**
 * TPoolTask represent a dual data holder
 *
 * Derived task classes can add further input fields and also any output fields.
 * But what are input and what are output fields?
 * This is answered by your implementation of the correspondig TPoolWorker.
 *}
TPoolTask = class(TObject)
private
	{**
	 * As long as the task is processed, the reference of the worker stays here
	 *
	 * This info is set and required only by the manager, don't access it from workers at all.
	 *}
	FProcessingBy:TPoolWorker;

	function GetPriority:TTaskPriority;
	procedure SetPriority(Priority:TTaskPriority);
protected
	FOwner:TObject;
	FOnStart:TAnonymousNotifyEvent;
	FOnCancel:TAnonymousNotifyEvent;
	FOnDone:TAnonymousNotifyEvent;
	FState:TTaskState;
	FPriority:Byte;

	class function Compare(const Left, Right:TPoolTask):Integer; virtual;

	procedure Assign(Source:TPoolTask); virtual;
	function IsTheSame(Compare:TPoolTask):Boolean; virtual;

	{**
	 * Both, Priority and PriorityRaw, sets the same field for the priority of the task
	 *
	 * The higher the priority the sooner it's taked for processing, if not all tasks
	 * can be processed at the same time.
	 *
	 * PriorityRaw is introduced for purposes, where you need a finer resolution (range of byte)
	 * Priority is comfortable, but allows only 7 common priorities through a enumeration
	 *
	 * Publish one of them in your derived task, if you need it.
	 *
	 * You must also enable the property SortTasks (disabled by default) in the corresponding
	 * derived manager.
	 *
	 * @see TPoolManager.SortTasks
	 *}
	property Priority:TTaskPriority read GetPriority write SetPriority;
	property PriorityRaw:Byte read FPriority write FPriority;
public
	constructor Create(Owner:TObject); virtual;

	function Clone:TPoolTask;

	property Owner:TObject read FOwner;
	property State:TTaskState read FState;
	{**
	 * Generic event, which is fired, if the processing of the task is started
	 *}
	property OnStart:TAnonymousNotifyEvent read FOnStart write FOnStart;
	{**
	 * Generic event, which is fired, if the task is canceled
	 *}
	property OnCancel:TAnonymousNotifyEvent read FOnCancel write FOnCancel;
	{**
	 * Generic event, which is fired, if the task is done and was not canceled
	 *}
	property OnDone:TAnonymousNotifyEvent read FOnDone write FOnDone;
end;

TThreadProcedures = class;

{**
 * TPoolThread contains only the intersected structures/functionality of TPoolWorker and
 * TPoolManager and act as the base class for them.
 *
 * The Execute method is full implemented and should be not overriden by descendants, instead
 * a simple "Execution Loop" concept is introduced there:
 * - InitializeExecutionLoop is executed once before the loop
 * - ExecutionLoop is so long executed in loop as ExecutionLoopCondition returns TRUE.
 *   But each run of the loop requires a signal on MainSignal (see method TriggerMainSignal).
 * - If ExecutionLoopCondition returns FALSE, the loop will be breaked and FinalizeExecutionLoop
 *   is called finally.
 *
 * Don't create any instances of this class!
 *}
TPoolThread = class(TThread)
private
	FMainSignal:TEvent;
	FInExecutionLoop:Boolean;

	function GetSleeping:Boolean;
protected
	procedure ExecutionLoopInitialize; virtual; abstract;
	function ExecutionLoopCondition:Boolean; virtual;
	procedure ExecutionLoop; virtual; abstract;
	procedure ExecutionLoopFinalize; virtual; abstract;

	procedure Execute; override;

	procedure TriggerMainSignal;

	property MainSignal:TEvent read FMainSignal;
	{**
	 * Says, whether this thread is currently in active execution. It's FALSE, if it waits for
	 * the signal (MainSignal)
	 *}
	property InExecutionLoop:Boolean read FInExecutionLoop;
public
	constructor Create(CreateSuspended:Boolean);
	destructor Destroy; override;

	procedure Terminate; reintroduce; virtual;

	{**
	 * Says, whether this thread is currently sleeping.
	 * It's TRUE, if it waits for the signal (MainSignal).
	 *}
	property Sleeping:Boolean read GetSleeping;
end;

{**
 * TPoolWorker is our workhorse and should do the work to complete a task
 *
 * This implementation contains all needed mechanisms for interacting with the corresponding
 * TPoolManager.
 *
 * Of course, here are no code for doing the whole work. This must be implemented in
 * ExecuteTask by the derived class.
 *}
TPoolWorker = class(TPoolThread)
private

{ KaTeX parse error: Expected 'EOF', got '}' at position 16: IFDEF CODE_SITE}̲ FWorkerIndex…ENDIF}
FOwner:TPoolManager;
FState:TWorkerState;
FCanceled:Boolean;
FProcessTasks:TTaskList;

{ KaTeX parse error: Expected 'EOF', got '}' at position 16: IFDEF CODE_SITE}̲ property Wor…ENDIF}
property ProcessTasks:TTaskList read FProcessTasks;
protected
FContextTask:TPoolTask;

	procedure FireEvent(FireEventProc:TProc<TPoolTask>; HasEventFunc:TTaskFunc);

	procedure InitializeTask(SameTasks:TTaskList);
	{**
	 * ExecuteTask is the right place to implement the main work
	 *
	 * You have to use the property ContextTask for do the job.
	 *
	 * It's important to call the DoneTask method with a corresponding value in any case,
	 * if the task is done.
	 *
	 * As running condition they should check for the property Canceled, not for Terminated.
	 *
	 * For example:
	 * - On error: DoneTask(FALSE);
	 * - On success: DoneTask(TRUE);
	 *}
	procedure ExecuteTask; virtual; abstract;
	procedure DoneTask(Successful:Boolean);

	procedure ExecutionLoopInitialize; override;
	procedure ExecutionLoop; override;
	procedure ExecutionLoopFinalize; override;

	procedure Cancel;

	property Owner:TPoolManager read FOwner;
	property Canceled:Boolean read FCanceled;
	property ContextTask:TPoolTask read FContextTask;
public
	constructor Create(Owner:TPoolManager); virtual;
	destructor Destroy; override;

	procedure Terminate; override;

	property State:TWorkerState read FState write FState;
end;

{**
 * TPoolManager is the key class of the whole concept. It's almost full implemented.
 * Derived managers must only implement the class method WorkerClass.
 * For more comfort it's recommended to reintroduce the class method Singleton.
 * Nothing more is needed, but you can introduce new methods for easier tasks handling.
 *
 * @see TPoolManager.WorkerClass
 * @see TPoolManager.Singleton
 *
 * Singleton pattern
 * -----------------
 *
 * Because it makes no sense, to hold any instances of the manager, the singleton pattern was
 * choosed for rich features (e.g. Demand mode).
 *
 * To access the manager you should call always the class method Singleton on the derived
 * manager class, which always return a valid instance of the corresponding class.
 * On the first call it creates and starts the manager thread and you are instantly able,
 * to add your tasks.
 *
 * Of course you are able to instantiate many instances manually, but this is not a part of
 * concept and the behaviour isn't tested.
 *
 * @see TPoolManager.Singleton
 *
 * Concurrent workers
 * ------------------
 *
 * Each manager is able to manage a amount of workers (TPoolWorker) for processing the added
 * tasks. The workers are created only on demand. Each worker get's the next task from the
 * task queue, after it has done their current one. If there are no further tasks in the queue,
 * all sleeping workers are terminated automatically. But this behaviour is influenced by the
 * property SpareWorkersCount.
 *
 * @see TPoolManager.ConcurrentWorkersCount
 *
 * Spared workers
 * --------------
 *
 * You can define a amount of workers, which are not terminated automatically, unless you
 * decrease the property SpareWorkersCount or terminate the manager manually. This is usefull
 * for often small tasks.
 *
 * The "Demand mode" is disabled, if you define more than 0 SpareWorkersCount.
 *
 * @see TPoolManager.SpareWorkersCount
 *
 * Demand mode
 * -----------
 *
 * By default a single instance/thread for each derived TPoolManager class is created by the
 * first call of the class method Singleton and resist, until your application is closed or
 * you manually terminate it.
 *
 * This bahavior can be changed, by simple passing an "init" procedure, before the first call
 * of Singleton is done. If you do that, the manager terminates himself automatically, if all
 * added tasks are done or get canceled. The property SpareWorkersCount must be zero (0),
 * otherwise the demand mode can't be activated.
 *
 * @see TPoolManager.RegisterSingletonOnDemandProc
 *}
TPoolManager = class(TPoolThread)
private
	{**
	 * I dont't like to waste the global namespace with types, which are only locally required
	 *}
	type
	TTaskComparer = TDelegatedComparer<TPoolTask>;

	TOwner = class
	public
		Owner:TObject;
		TasksTotalCount:Integer;
		TasksDoneCount:Integer;
		OnTasksStatus:TStatusEvent;
		OnTasksComplete:TAnonymousNotifyEvent;
	end;

	TOwnerList = TObjectList<TOwner>;

	TOwnersAssign = class
		ManagerClass:TPoolManagerClass;
		Owners:TOwnerList;
	end;

	TDemandProcAssign = class
		ManagerClass:TPoolManagerClass;
		DemandProc:TManagerProc;
	end;
{**
 * Private section for class related stuff
 *}
private
	class var
	FSingleInstances:array of TPoolManager;
	FDemandProcs:array of TDemandProcAssign;
	FStoredOwners:array of TOwnersAssign;

{ KaTeX parse error: Expected 'EOF', got '}' at position 22: … COMPILER_15_UP}̲ FCPUCount:Ca…ENDIF}

	class function GetDemandProcIndex(ReturnOnFreeIndex:Boolean = FALSE):Integer;
	class function GetCPUCount:Integer;
{**
 * Private section for object related stuff
 *}
private
	FOwners:TOwnerList;
	FOwnersDoneList:TObjectList;
	FContextProcedures:TThreadProcedures;
	FDemandMode:Boolean;
	FComparer:TTaskComparer;
	FTasksSorted:Boolean;
	FDynamicTerminateEnabled:Boolean;
	FWorkers:TWorkerList;
	FTasks:TTaskList;
	FTasksLock:TMultiReadExclusiveWriteSynchronizer;
	FConcurrentWorkersCount:Integer;
	FSpareWorkersCount:Integer;

	function GetOwner(Owner:TObject; AutoAdd:Boolean = TRUE):TOwner;
	procedure UnregisterOwner(Owner:TObject);
	procedure OwnerAddTasksCount(Owner:TObject; AddTotalCount, AddDoneCount:Integer;
		FireEvents:Boolean = TRUE);
	procedure AddOwnerDone(Owner:TObject);
	procedure StoreOwners;

	procedure SetSortTasks(SortTasks:Boolean);
	function GetSortTasks:Boolean;

	property Owners:TOwnerList read FOwners;
	{**
	 * @see TPoolManager.RegisterSingletonOnDemandProc
	 *}
	property DemandMode:Boolean read FDemandMode;
{**
 * Protected section for class related stuff
 *}
protected

	class destructor Destroy;

	class procedure SingletonTerminateGate(Sender:TObject);
	{**
	 * WorkerClass should return the class of the corresponding TPoolWorker
	 *
	 * This is the one and only method, which you _must_ implement in any derived manager.
	 *
	 * Example:
	 * <code>
	 * TMyManager = class(TPoolManager)
	 * protected
	 *   class function WorkerClass:TPoolWorkerClass; override;
	 * end;
	 *
	 * implementation
	 *
	 * class function TMyManager.WorkerClass:TPoolWorkerClass;
	 * begin
	 *   Result:=TMyWorker;
	 * end;
	 * </code>
	 *}
	class function WorkerClass:TPoolWorkerClass; virtual; abstract;
{**
 * Protected section for object related stuff
 *}
protected
	procedure BeginReadTasks;
	procedure EndReadTasks;

	function BeginWriteTasks:Boolean;
	procedure EndWriteTasks;

	function GetTaskIndex(State:TTaskState; StartIndex:Integer):Integer;
	function GetSameTaskIndex(CompareTask:TPoolTask; StartIndex:Integer):Integer;

	function CreateWorker:TPoolWorker; virtual;

	procedure CustomTaskCancel(CompareFunction:TTaskFunc);
	function CustomTaskExists(CompareFunction:TTaskFunc):Boolean;
	function CustomTaskCounter(CompareFunction:TTaskFunc):Integer;

	procedure WorkerTerminated(TerminatedWorker:TPoolWorker); virtual;
	procedure WorkerTaskDone(DoneWorker:TPoolWorker; WorkerState:TWorkerState); virtual;

	procedure ExecutionLoopInitialize; override;
	function ExecutionLoopCondition:Boolean; override;
	procedure ExecutionLoop; override;
	procedure ExecutionLoopFinalize; override;

	procedure SetConcurrentWorkersCount(ConcurrentWorkersCount:Integer);
	procedure SetConcurrentWorkersCountPerCPU(ConcurrentWorkersCountPerCPU:Integer);

	procedure SetSpareWorkersCount(SpareWorkersCount:Integer);
	procedure SetSpareWorkersCountPerCPU(SpareWorkersCountPerCPU:Integer);

	property Workers:TWorkerList read FWorkers;
	property Tasks:TTaskList read FTasks;
	{**
	 * Defines, whether the tasks should be sorted, before the next is picked for processing
	 *
	 * How the tasks are sorted, must be implemented in the class method TPoolTask.Compare.
	 * If you need such sorting mechanism, you must set this property to TRUE in the
	 * derived constructor.
	 *
	 * @see TPoolTask.Compare
	 * @default FALSE
	 *}
	property SortTasks:Boolean read GetSortTasks write SetSortTasks;
	property ContextProcedures:TThreadProcedures read FContextProcedures;
{**
 * Class related public section
 *}
public
	class function Singleton:TPoolManager;
	class function HasSingleton:Boolean;
	class procedure TerminateSingletonInstances(Wait:Boolean = TRUE);

	class procedure RegisterSingletonOnDemandProc(DemandProc:TManagerProc);
	class function HasSingletonOnDemandProc:Boolean;
	class procedure UnregisterSingletonOnDemandProc;

	class procedure DispatchOwnerDestroyed(Owner:TObje