delphi 把多个线程的请求阻塞到另一个线程 TElegantThread

转载自：https://www.cnblogs.com/lackey/p/4782777.html

本例是把多个线程访问数据库的请求，全部阻塞到一个线程。

这是实际编程中常见的一种问题。

示例源码下载，所需支持单元均在源码中，且附详细说明。

TElegantThread 的父类是 TSimpleThread。

unit uElegantThread;

interface

uses
  Classes, SysUtils, uSimpleThread, uSimpleList, uSyncObjs;

type

  PSyncRec = ^TSyncRec;

  TSyncRec = record
    FMethod: TThreadMethod;
    FProcedure: TThreadProcedure;
    FSignal: TSuperEvent;
    Queued: boolean;
    DebugInfo: string;
  end;

  TSyncRecList = Class(TSimpleList<PSyncRec>)
  protected
    procedure FreeItem(Item: PSyncRec); override;
  End;

  TElegantThread = class(TSimpleThread)
  private
    FSyncRecList: TSyncRecList;

    procedure LockList;
    procedure UnlockList;

    procedure Check;
    procedure DoCheck;

  public

    // AAllowedActiveX 允许此线程访问 COM 如：IE ,
    // 当然，获取 Ie 的 IHtmlDocument2 接口，也必须在此线程内执行
    constructor Create(AAllowedActiveX: boolean = false);
    destructor Destroy; override;

    // ADebugInfo 是调用者用来查错用，一般可以写上过程名 如：'DoSomeThing';
    procedure Queue(AMethod: TThreadMethod; ADebugInfo: string = ''); overload;
    procedure Queue(AProcedure: TThreadProcedure; ADebugInfo: string = ''); overload;

    procedure Synchronize(AMethod: TThreadMethod; ADebugInfo: string = ''); overload;
    procedure Synchronize(AProcedure: TThreadProcedure; ADebugInfo: string = ''); overload;

  end;

implementation

{ TSyncRecList }

procedure TSyncRecList.FreeItem(Item: PSyncRec);
begin
  inherited;
  if Assigned(Item.FSignal) then
    Item.FSignal.Free;
  Dispose(Item);
end;

{ TElegantThread }

procedure TElegantThread.Check;
begin
  ExeProcInThread(DoCheck);
end;

constructor TElegantThread.Create(AAllowedActiveX: boolean);
begin
  inherited;
  FSyncRecList := TSyncRecList.Create;
end;

destructor TElegantThread.Destroy;
begin
  WaitThreadStop;
  FSyncRecList.Free;
  inherited;
end;

procedure TElegantThread.DoCheck;
var
  p: PSyncRec;
  sErrMsg: string;
begin

  LockList;
  try
    p := FSyncRecList.PopFirst; // 每次从 List 取出一个过程来执行
  finally
    UnlockList;
  end;

  if Assigned(p) then
  begin

    try

      if Assigned(p.FMethod) then
        p.FMethod // 执行
      else if Assigned(p.FProcedure) then
        p.FProcedure(); // 执行

    except
      on E: Exception do // 错误处理
      begin
        sErrMsg := 'DebugInfo:' + p.DebugInfo + #13#10;
        sErrMsg := sErrMsg + 'ErrMsg:' + E.Message;
        DoOnDebugMsg(sErrMsg);
      end;
    end;

    if not p.Queued then // 如果是阻塞，请设为有信号，调用者即可返回
    begin
      p.FSignal.SetEvent;
    end;

    Dispose(p);
    Check; // 继续下一次 DoCheck,也就是本过程。
    // 父类 TSimpleThread 已特殊处理，不会递归。

  end;

end;

procedure TElegantThread.LockList;
begin
  FSyncRecList.Lock;
end;

procedure TElegantThread.Queue(AMethod: TThreadMethod; ADebugInfo: string);
var
  p: PSyncRec;
begin
  // 此过程为排队执行

  new(p);
  p.FProcedure := nil;
  p.FMethod := AMethod;
  p.Queued := true;

  LockList;
  try
    FSyncRecList.Add(p); // 把要执行的过程加入 List
    Check; // 启动线程
  finally
    UnlockList;
  end;

end;

procedure TElegantThread.Queue(AProcedure: TThreadProcedure; ADebugInfo: string);
var
  p: PSyncRec;
begin
  new(p);
  p.FProcedure := AProcedure;
  p.FMethod := nil;
  p.Queued := true;
  LockList;
  try
    FSyncRecList.Add(p);
    Check;
  finally
    UnlockList;
  end;
end;

procedure TElegantThread.Synchronize(AMethod: TThreadMethod; ADebugInfo: string);
var
  p: PSyncRec;
  o: TSuperEvent;
begin

  // 此过程为阻塞执行，即调用者必须等到此过程被执行完成才能返回

  new(p);

  p.FProcedure := nil;
  p.FMethod := AMethod;
  p.Queued := false;
  p.FSignal := TSuperEvent.Create; // 创建一个信号
  p.FSignal.ResetEvent; // 清除信号
  o := p.FSignal;

  LockList;
  try
    FSyncRecList.Add(p);
    Check;
  finally
    UnlockList;
  end;

  o.WaitFor; // 等待信号出现
  o.Free;

end;

procedure TElegantThread.Synchronize(AProcedure: TThreadProcedure; ADebugInfo: string);
var
  p: PSyncRec;
  o: TSuperEvent;
begin
  new(p);

  p.FProcedure := AProcedure;
  p.FMethod := nil;
  p.Queued := false;
  p.FSignal := TSuperEvent.Create;
  p.FSignal.ResetEvent;
  o := p.FSignal;

  LockList;
  try
    FSyncRecList.Add(p);
    Check;
  finally
    UnlockList;
  end;

  o.WaitFor;
  o.Free;

end;

procedure TElegantThread.UnlockList;
begin
  FSyncRecList.Unlock;
end;

end.

uElegantThread.pas

　　

unit uElegantThread;
interface
uses  Classes, SysUtils, uSimpleThread, uSimpleList, uSyncObjs;
type
  PSyncRec = ^TSyncRec;
  TSyncRec = record    FMethod: TThreadMethod;    FProcedure: TThreadProcedure;    FSignal: TSuperEvent;    Queued: boolean;    DebugInfo: string;  end;
  TSyncRecList = Class(TSimpleList<PSyncRec>)  protected    procedure FreeItem(Item: PSyncRec); override;  End;
  TElegantThread = class(TSimpleThread)  private    FSyncRecList: TSyncRecList;
    procedure LockList;    procedure UnlockList;
    procedure Check;    procedure DoCheck;
  public
    // AAllowedActiveX 允许此线程访问 COM 如：IE ,    // 当然，获取 Ie 的 IHtmlDocument2 接口，也必须在此线程内执行    constructor Create(AAllowedActiveX: boolean = false);    destructor Destroy; override;
    // ADebugInfo 是调用者用来查错用，一般可以写上过程名 如：'DoSomeThing';    procedure Queue(AMethod: TThreadMethod; ADebugInfo: string = ''); overload;    procedure Queue(AProcedure: TThreadProcedure; ADebugInfo: string = ''); overload;
    procedure Synchronize(AMethod: TThreadMethod; ADebugInfo: string = ''); overload;    procedure Synchronize(AProcedure: TThreadProcedure; ADebugInfo: string = ''); overload;
  end;
implementation
{ TSyncRecList }
procedure TSyncRecList.FreeItem(Item: PSyncRec);begin  inherited;  if Assigned(Item.FSignal) then    Item.FSignal.Free;  Dispose(Item);end;
{ TElegantThread }
procedure TElegantThread.Check;begin  ExeProcInThread(DoCheck);end;
constructor TElegantThread.Create(AAllowedActiveX: boolean);begin  inherited;  FSyncRecList := TSyncRecList.Create;end;
destructor TElegantThread.Destroy;begin  WaitThreadStop;  FSyncRecList.Free;  inherited;end;
procedure TElegantThread.DoCheck;var  p: PSyncRec;  sErrMsg: string;begin
  LockList;  try    p := FSyncRecList.PopFirst; // 每次从 List 取出一个过程来执行  finally    UnlockList;  end;
  if Assigned(p) then  begin
    try
      if Assigned(p.FMethod) then        p.FMethod // 执行      else if Assigned(p.FProcedure) then        p.FProcedure(); // 执行
    except      on E: Exception do // 错误处理      begin        sErrMsg := 'DebugInfo:' + p.DebugInfo + #13#10;        sErrMsg := sErrMsg + 'ErrMsg:' + E.Message;        DoOnDebugMsg(sErrMsg);      end;    end;
    if not p.Queued then // 如果是阻塞，请设为有信号，调用者即可返回    begin      p.FSignal.SetEvent;    end;
    Dispose(p);    Check; // 继续下一次 DoCheck,也就是本过程。    // 父类 TSimpleThread 已特殊处理，不会递归。
  end;
end;
procedure TElegantThread.LockList;begin  FSyncRecList.Lock;end;
procedure TElegantThread.Queue(AMethod: TThreadMethod; ADebugInfo: string);var  p: PSyncRec;begin  // 此过程为排队执行
  new(p);  p.FProcedure := nil;  p.FMethod := AMethod;  p.Queued := true;
  LockList;  try    FSyncRecList.Add(p); // 把要执行的过程加入 List    Check; // 启动线程  finally    UnlockList;  end;
end;
procedure TElegantThread.Queue(AProcedure: TThreadProcedure; ADebugInfo: string);var  p: PSyncRec;begin  new(p);  p.FProcedure := AProcedure;  p.FMethod := nil;  p.Queued := true;  LockList;  try    FSyncRecList.Add(p);    Check;  finally    UnlockList;  end;end;
procedure TElegantThread.Synchronize(AMethod: TThreadMethod; ADebugInfo: string);var  p: PSyncRec;  o: TSuperEvent;begin
  // 此过程为阻塞执行，即调用者必须等到此过程被执行完成才能返回
  new(p);
  p.FProcedure := nil;  p.FMethod := AMethod;  p.Queued := false;  p.FSignal := TSuperEvent.Create; // 创建一个信号  p.FSignal.ResetEvent; // 清除信号  o := p.FSignal;
  LockList;  try    FSyncRecList.Add(p);    Check;  finally    UnlockList;  end;
  o.WaitFor; // 等待信号出现  o.Free;
end;
procedure TElegantThread.Synchronize(AProcedure: TThreadProcedure; ADebugInfo: string);var  p: PSyncRec;  o: TSuperEvent;begin  new(p);
  p.FProcedure := AProcedure;  p.FMethod := nil;  p.Queued := false;  p.FSignal := TSuperEvent.Create;  p.FSignal.ResetEvent;  o := p.FSignal;
  LockList;  try    FSyncRecList.Add(p);    Check;  finally    UnlockList;  end;
  o.WaitFor;  o.Free;
end;
procedure TElegantThread.UnlockList;begin  FSyncRecList.Unlock;end;
end.
uElegantThread.pas