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

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

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

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

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.

附：delphi 进阶基础技能说明