delphi 線程池基礎 TSimplePool

1. TSimpleThread

2. TSimpleList

3. 以1，2構成 TSimplePool

用法

   先定義: TDoSomeThingThread=class(TSimpleThread) ;

   並給 TDoSomeThingThread reintroduce Create 不帶參數的構造函數。

   再定義  TDoSomeThingPool=class(TSimpleTool<TDoSomeThing>); 

   最后，只需在 TDoSomeThingPool 寫線程調度的代碼就行了，可以省不少事。(這部分有待進一步完善)

  全部源碼下載

unit uSimpleThread;
interface
uses
  System.Classes, System.SysUtils, System.SyncObjs;

type

  // 顯示信息,調用方法 DoOnStatusMsg(AMsg);
  TOnStatusMsg = procedure(AMsg: string) of object;

  // 顯示調試信息,一般用於顯示出錯信息,用法 DoOnDebugMsg(AMsg);
  TOnDebugMsg = TOnStatusMsg;

  TSimpleThread = class(TThread)
  public type // "執行過程"的類別定義

    TGeneralProc = procedure; // 普通的,即 procedure DoSomeThing;
    TObjectProc = procedure of object; // 類的,即 TXxxx.DoSomeThign; 用得多
    TAnonymousProc = reference to procedure; // 匿名的
  private type
    TProcKind = (pkGeneral, pkObject, pkAnonymous); // "執行過程"的類別
  private

    FGeneralProc: TGeneralProc;
    FObjProc: TObjectProc;
    FAnoProc: TAnonymousProc;

    FProcKind: TProcKind;

    FEvent: TEvent; // 用於阻塞，它是一個信號量
    FActiveX: boolean; // 是否在線程中支持 Com ,如果你要在線程中訪問 IE 的話，就設定為 True

    FOnStatusMsg: TOnStatusMsg;
    FOnDebugMsg: TOnDebugMsg;

    FTagID: integer; // 給線程一個代號,在線程池的時候用來作區別
    FParam: integer; // 給線程一個參數，方便識別

    procedure SelfStart; // 觸發線程運行

    procedure DoExecute; // 這個函數里面運行的代碼是“線程空間”
    procedure DoOnException(e: exception); // 異常信息顯示 調用 DoOnDebugMsg(AMsg);

    procedure SetTagID(const Value: integer);
    procedure SetParam(const Value: integer);

    procedure SetOnStatusMsg(const Value: TOnStatusMsg);
    procedure SetOnDebugMsg(const Value: TOnDebugMsg);

  protected

    FWaitStop: boolean; // 結束標志，可以在繼承類中使用它，以確定線程是否停止運行

    procedure DoOnStatusMsg(AMsg: string); // 顯示普通信息
    procedure DoOnDebugMsg(AMsg: string); // 顯示調式信息

    procedure Execute; override; // 重載 TThread.Execute

    procedure OnThreadProcErr(e: exception); virtual; // 異常發生事件

    procedure WaitThreadStop; // 等待線程結束

    procedure BeforeExecute; virtual; // 看名字,不解釋
    Procedure AfterExecute; virtual; // 看名字,不解釋

    procedure SleepExceptStopped(ATimeOut: Cardinal); // 這個高大上了，要解釋一下。
    { 有時線程沒有任務時，就會休息一會兒，但是，休息的時候，可能會接收到退出線程的指令
      此函數就是在休息的時候也檢查一下停止指令
    }

  public

    // 改變一下 Create 的參數,AllowedActiveX：是否允許線程代碼訪問 Com
    constructor Create(AllowedActiveX: boolean = false); reintroduce;

    destructor Destroy; override;

    procedure ExeProcInThread(AProc: TGeneralProc); overload; // 這三個,對外的接口。
    procedure ExeProcInThread(AProc: TObjectProc); overload;
    procedure ExeProcInThread(AProc: TAnonymousProc); overload;

    procedure StartThread; virtual;
    { 啟動線程，一般只調用一次。
      以后就由線程的響應事件來執行了
    }

    procedure StopThread; virtual; // 停止線程

    property OnStatusMsg: TOnStatusMsg read FOnStatusMsg write SetOnStatusMsg;
    property OnDebugMsg: TOnDebugMsg read FOnDebugMsg write SetOnDebugMsg;
    property WaitStop: boolean read FWaitStop;
    property TagID: integer read FTagID write SetTagID;
    property Param: integer read FParam write SetParam;

  end;

implementation

uses
  ActiveX;

procedure TSimpleThread.AfterExecute;
begin
end;

procedure TSimpleThread.BeforeExecute;
begin
end;

constructor TSimpleThread.Create(AllowedActiveX: boolean);
var
  BGUID: TGUID;
begin
  inherited Create(false);
  FActiveX := AllowedActiveX;
  FreeOnTerminate := false; // 我們要手動Free線程
  CreateGUID(BGUID);
  FEvent := TEvent.Create(nil, true, false, GUIDToString(BGUID));
end;

destructor TSimpleThread.Destroy;
begin
  StopThread; // 先停止
  WaitThreadStop; // 再等待線程停止
  {
    在繼承類的 Destroy 中，也要寫上這兩句. 如:
    暫時未找到更好的辦法，這點代碼省不了
    destructor TXXThread.Destroy;
    begin
    StopThread;
    WaitThreadStop;
    xxx.Free;
    Inherited;
    end;
  }
  FEvent.Free;
  inherited;
end;

procedure TSimpleThread.DoExecute; // 此函數內執行的代碼,就是在多線程空間里運行
begin
  BeforeExecute;
  repeat

    FEvent.WaitFor;
    FEvent.ResetEvent; // 下次waitfor 一直等
    { 這里嘗試了很多些，總 SelfStart 覺得有沖突，經過多次修改並使用證明，
      沒有必要在這里加鎖,因為只調用 startThread 一次，剩下的交給線程影應事件
    }

    if not Terminated then // 如果線程需要退出
    begin

      try

        case FProcKind of
          pkGeneral: FGeneralProc;
          pkObject: FObjProc;
          pkAnonymous: FAnoProc;
        end;

      except

        on e: exception do
        begin
          DoOnException(e);
        end;

      end;

    end;

  until Terminated;
  AfterExecute;
  //代碼運行到這里，就表示這個線程不存在了。再也回不去了，必須釋放資源了。
end;

procedure TSimpleThread.DoOnDebugMsg(AMsg: string);
begin
  if Assigned(FOnDebugMsg) then
    FOnDebugMsg(AMsg);
end;

procedure TSimpleThread.DoOnException(e: exception);
var
  sErrMsg: string;
begin
  sErrMsg := 'ClassName:' + ClassName + #13#10;
  sErrMsg := sErrMsg + 'TagID:' + IntToStr(FTagID) + #13#10;
  sErrMsg := sErrMsg + 'Param:' + IntToStr(Param) + #13#10;
  sErrMsg := sErrMsg + 'ErrMsg:' + e.Message + #13#10;
  DoOnDebugMsg(sErrMsg);
  OnThreadProcErr(e);
end;

procedure TSimpleThread.DoOnStatusMsg(AMsg: string);
begin
  if Assigned(FOnStatusMsg) then
    FOnStatusMsg(AMsg);
end;

procedure TSimpleThread.Execute;
begin
  //是否支持 Com
  if FActiveX then
  begin
    CoInitialize(nil);
    try
      DoExecute;
    finally
      CoUninitialize;
    end;
  end
  else
    DoExecute;
end;

procedure TSimpleThread.ExeProcInThread(AProc: TGeneralProc);
begin
  FGeneralProc := AProc;
  FProcKind := pkGeneral;
  SelfStart;
end;

procedure TSimpleThread.ExeProcInThread(AProc: TObjectProc);
begin
  FObjProc := AProc;
  FProcKind := pkObject;
  SelfStart;
end;

procedure TSimpleThread.ExeProcInThread(AProc: TAnonymousProc);
begin
  FAnoProc := AProc;
  FProcKind := pkAnonymous;
  SelfStart;
end;

procedure TSimpleThread.OnThreadProcErr(e: exception);
begin;
end;

procedure TSimpleThread.SelfStart;
begin
  //經常多次嘗試，最終寫成這樣，運行沒有問題
  if FEvent.WaitFor(0) <> wrSignaled then
    FEvent.SetEvent; // 讓waitfor 不再等
end;

procedure TSimpleThread.StopThread;
begin
  //繼承類的代碼中，需要檢查 FWaitStop ，來控制線程結束
  FWaitStop := true;
end;

procedure TSimpleThread.SetOnDebugMsg(const Value: TOnDebugMsg);
begin
  FOnDebugMsg := Value;
end;

procedure TSimpleThread.SetOnStatusMsg(const Value: TOnStatusMsg);
begin
  FOnStatusMsg := Value;
end;

procedure TSimpleThread.SetParam(const Value: integer);
begin
  FParam := Value;
end;

procedure TSimpleThread.SetTagID(const Value: integer);
begin
  FTagID := Value;
end;

procedure TSimpleThread.SleepExceptStopped(ATimeOut: Cardinal);
var
  BOldTime: Cardinal;
begin
  // sleep 時檢測退出指令,以確保線程順序退出
  // 多個線程同時工作，要保證正確退出，確實不容易
  BOldTime := GetTickCount;
  while not WaitStop do
  begin
    sleep(50);
    if (GetTickCount - BOldTime) > ATimeOut then
      break;
  end;
end;

procedure TSimpleThread.StartThread;
begin
  FWaitStop := false;
end;

procedure TSimpleThread.WaitThreadStop;
begin
  //等待線程結束
  StopThread;
  Terminate;
  SelfStart;
  WaitFor;
end;

end.

unit uSimpleList;

interface

uses
  Generics.Collections;

type

  TSimpleList<T> = class(TList<T>)
  private
    FCurIndexPos: integer;
    function DoPopByIndex(Index: integer): T;
    procedure FreeAllItems;
    procedure SetCurIndexPos(const Value: integer);
  protected
    FNeedFreeItem: boolean;
    procedure FreeItem(Item: T); virtual; //子類可以重截這個以確定該如何釋放
  public

    constructor Create;
    destructor Destroy; override;

    procedure Lock; //新版的Lock功能值得學習
    procedure Unlock; //

    function PopFirst: T; //不解釋，下同
    function PopLast: T;
    function PopByIndex(Index: integer): T;

    procedure ClearAndFreeAllItems; //清空並釋放所有的Item
    property CurIndexPos: integer read FCurIndexPos write SetCurIndexPos;

  end;

  //加 Constructor 限制是要求 T 要有一個沒帶參數的Create函數,也就是構造器
  TClassSimpleList<T: Class, Constructor> = class(TSimpleList<T>)
  protected
    procedure FreeItem(Item: T); override;
    function AddNewOne: T;// T有了Create 才能寫這個
  end;

implementation

procedure TSimpleList<T>.ClearAndFreeAllItems;
begin
  FreeAllItems;
  clear;
end;

constructor TSimpleList<T>.Create;
begin
  inherited;
  FNeedFreeItem := true;
  FCurIndexPos := -1;
end;

destructor TSimpleList<T>.Destroy;
begin
  FreeAllItems;
  inherited;
end;

function TSimpleList<T>.DoPopByIndex(Index: integer): T;
begin
  if (index >= 0) and (index <= count - 1) then
  begin
    result := items[index];
    Delete(index);
    Exit;
  end;
  result := T(nil);
end;

procedure TSimpleList<T>.FreeAllItems;
var
  Item: T;
begin
  if FNeedFreeItem then
  begin
    FCurIndexPos := -1;
    for Item in self do
      FreeItem(Item);
  end;
end;

procedure TSimpleList<T>.FreeItem(Item: T);
begin
  // 假設 T 是 PMyRec =^TMyRec  TMyRec=record;
  // 這個寫法對嗎？
  // if GetTypeKind(T) = tkPointer then
  // begin
  // Dispose(Pointer(Pointer(@Item)^));
  // end;
  // 此寫法未認真測試所以不使用。
  // 如果 Item 是指針，我在繼承類中的 FreeItem 中寫 Dispose(Item);
end;

procedure TSimpleList<T>.Lock;
begin
  system.TMonitor.Enter(self);
end;

procedure TSimpleList<T>.Unlock;
begin
  system.TMonitor.Exit(self);
end;

function TSimpleList<T>.PopByIndex(Index: integer): T;
begin
  result := DoPopByIndex(index);
end;

function TSimpleList<T>.PopFirst: T;
begin
  result := DoPopByIndex(0);
end;

function TSimpleList<T>.PopLast: T;
begin
  result := DoPopByIndex(count - 1);
end;

procedure TSimpleList<T>.SetCurIndexPos(const Value: integer);
begin
  FCurIndexPos := Value;
end;

{ TThreadClassList<T> }

function TClassSimpleList<T>.AddNewOne: T;
begin
  result := T.Create();
  Add(result);
end;

procedure TClassSimpleList<T>.FreeItem(Item: T);
begin
  Item.Free;
end;

end.

unit uSimplePool;

interface

uses
  uSimpleThread, uSimpleList, uSyncObjs, System.Generics.Collections;

Type

  TSimplePool<T: TSimpleThread, Constructor> = class
  private Type
    TWorkThreadList = Class(TClassSimpleList<T>);
  private

    FOnStatusMsg: TOnStatusMsg;
    FOnDebugMsg: TOnDebugMsg;
    FMaxThreadCount: integer;

    procedure SetOnDebugMsg(const Value: TOnDebugMsg);
    procedure SetOnStatusMsg(const Value: TOnStatusMsg);
    procedure SetMaxThreadCount(const Value: integer);
    procedure InitThreadList(AThreadCount: integer);

  protected

    FStopThreadCount: integer;
    FWorkThreadList: TWorkThreadList;
    FEvent: TSuperEvent; //提供給繼承類阻塞用

    procedure DoOnStatusMsg(AMsg: string);
    procedure DoOnDebugMsg(AMsg: string);
    procedure OnEachNewWorkThread(AWorkThread: T); virtual;

  public

    property OnStatusMsg: TOnStatusMsg read FOnStatusMsg write SetOnStatusMsg;
    property OnDebugMsg: TOnDebugMsg read FOnDebugMsg write SetOnDebugMsg;

    constructor Create;
    destructor Destroy; override;

    procedure StartWork; virtual;
    procedure StopWork; virtual;

    property MaxThreadCount: integer read FMaxThreadCount write SetMaxThreadCount default 5;

  end;

const
  cnDefaultWorkThreadCount = 5;
  cnLimitedWorkTreadCount = 20;

implementation

{ TSimplePool }

procedure TSimplePool<T>.DoOnDebugMsg(AMsg: string);
begin
  if Assigned(FOnDebugMsg) then
    FOnDebugMsg(AMsg);
end;

procedure TSimplePool<T>.DoOnStatusMsg(AMsg: string);
begin
  if Assigned(FOnStatusMsg) then
    FOnStatusMsg(AMsg);
end;

procedure TSimplePool<T>.InitThreadList(AThreadCount: integer);
var
  i, nTagID: integer;
  B: T;
begin
  nTagID := FWorkThreadList.Count;
  for i := 0 to AThreadCount do
  begin
    B := FWorkThreadList.AddNewOne;
    B.TagID := nTagID;
    B.OnStatusMsg := self.DoOnStatusMsg;
    B.OnDebugMsg := self.DoOnDebugMsg;
    OnEachNewWorkThread(B);
    inc(nTagID);
  end;
end;

procedure TSimplePool<T>.OnEachNewWorkThread(AWorkThread: T);
begin
end;

procedure TSimplePool<T>.SetMaxThreadCount(const Value: integer);
var
  ndiff: integer;
begin
  FMaxThreadCount := Value;
  if FMaxThreadCount > cnLimitedWorkTreadCount then
    FMaxThreadCount := cnLimitedWorkTreadCount;
  if FMaxThreadCount <= 0 then
    FMaxThreadCount := 1;
  ndiff := FMaxThreadCount - FWorkThreadList.Count;
  InitThreadList(ndiff);
end;

procedure TSimplePool<T>.SetOnDebugMsg(const Value: TOnDebugMsg);
begin
  FOnDebugMsg := Value;
end;

procedure TSimplePool<T>.SetOnStatusMsg(const Value: TOnStatusMsg);
begin
  FOnStatusMsg := Value;
end;

procedure TSimplePool<T>.StartWork;
var
  i: integer;
begin
  for i := 1 to MaxThreadCount do
  begin
    FWorkThreadList[i].StartThread;
  end;
end;

procedure TSimplePool<T>.StopWork;
var
  B: T;
begin
  for B in FWorkThreadList do
  begin
    B.StopThread;
  end;
end;

constructor TSimplePool<T>.Create;
begin
  inherited Create;
  FMaxThreadCount := 5;
  FEvent := TSuperEvent.Create;
  FWorkThreadList := TWorkThreadList.Create;
  InitThreadList(cnDefaultWorkThreadCount);
end;

destructor TSimplePool<T>.Destroy;
begin
  FWorkThreadList.Free;
  FEvent.Free;
  inherited Destroy;
end;

end.

unit uSyncObjs;

interface

uses
  SyncObjs;

Type

  TSuperEvent = class(TEvent)
  public
    constructor Create; reintroduce;
  end;

implementation

{ TSuperEvent }
uses
  SysUtils;

constructor TSuperEvent.Create;
var
  BGUID: TGUID;
begin
  CreateGUID(BGUID);
  inherited Create(nil, true, false, GUIDToString(BGUID));
end;

end.

 附：delphi 進階基礎技能說明