Funktionsweise Thread.WaitFor

[Sir Rufo]

Generell sollte man das Thread-Thema etwas anders anfassen:

Man stelle sich das als einen zusätzlichen Mitarbeiter vor, dem man eine Aufgabe gibt und wenn die Aufgabe abgeschlossen ist, dann gibt es wieder eine Rückmeldung.

Und wie im wahren Leben hat dieser Mitarbeiter einen Postkorb, wo alle Arbeiten hineinkommen und diese arbeitet der dann der Reihe nach ab.

Der Thread

Delphi-Quellcode:

unit HttpRequestThread;

interface

uses
  System.Generics.Collections,
  System.SyncObjs,
  System.Classes;

type
  TResponseNotify = procedure( const Request, Response : string ) of object;

  THttpRequestThread = class( TThread )
  private
    FCS : TCriticalSection;
    FEvent : TEvent;
    FQueue : TQueue<string>;
    FOnResponse : TResponseNotify;
    procedure SetOnResponse( const Value : TResponseNotify );
    function GetOnResponse : TResponseNotify;
    function GetQueueItem : string;
    procedure ProcessQueueItem;
    procedure DoResponseNotify( const ARequest, AResponse : string );
  protected
    procedure Execute; override;
    procedure TerminatedSet; override;
  public
    constructor Create;
    destructor Destroy; override;

    procedure Add( const ARequest : string );

    property OnResponse : TResponseNotify read GetOnResponse write SetOnResponse;
  end;

implementation

uses
  System.SysUtils,
  IdException,
  IdHTTP;

{ THttpRequestThread }

procedure THttpRequestThread.Add( const ARequest : string );
begin
  FCS.Enter;
  try
    FQueue.Enqueue( ARequest );
    FEvent.SetEvent;
  finally
    FCS.Leave;
  end;
end;

constructor THttpRequestThread.Create;
begin
  FCS := TCriticalSection.Create;
  FEvent := TEvent.Create( nil, False, False, '' );
  FQueue := TQueue<string>.Create;
  inherited Create( False );

end;

destructor THttpRequestThread.Destroy;
begin

  inherited;
  FreeAndNil( FQueue );
  FreeAndNil( FEvent );
  FreeAndNil( FCS );
end;

procedure THttpRequestThread.DoResponseNotify( const ARequest, AResponse : string );
begin
  if MainThreadID = CurrentThread.ThreadID
  then
    begin
      if Assigned( OnResponse )
      then
        OnResponse( ARequest, AResponse );
    end
  else
    Queue(
        procedure
      begin
        DoResponseNotify( ARequest, AResponse );
      end );
end;

procedure THttpRequestThread.Execute;
begin
  inherited;
  while not Terminated do
    begin
      FEvent.WaitFor;
      if not Terminated
      then
        ProcessQueueItem;
    end;
end;

function THttpRequestThread.GetOnResponse : TResponseNotify;
begin
  FCS.Enter;
  try
    Result := FOnResponse;
  finally
    FCS.Leave;
  end;
end;

function THttpRequestThread.GetQueueItem : string;
begin
  FCS.Enter;
  try
    Result := FQueue.Dequeue;
    if FQueue.Count > 0
    then
      FEvent.SetEvent;
  finally
    FCS.Leave;
  end;
end;

procedure THttpRequestThread.ProcessQueueItem;
var
  LRequest : string;
  LResponse : string;
  LHttp : TIdHTTP;
begin
  LHttp := TIdHTTP.Create( nil );
  LHttp.HandleRedirects := True;
  try
    LRequest := GetQueueItem;
    try
      LResponse := LHttp.Get( LRequest );
    except
      on E : EIdException do
        begin
          LResponse := E.ClassName + ': ' + E.Message;
        end;
    end;
    DoResponseNotify( LRequest, LResponse );
  finally
    LHttp.Free;
  end;
end;

procedure THttpRequestThread.SetOnResponse( const Value : TResponseNotify );
begin
  FCS.Enter;
  try
    FOnResponse := Value;
  finally
    FCS.Leave;
  end;
end;

procedure THttpRequestThread.TerminatedSet;
begin
  inherited;
  FEvent.SetEvent;
end;

end.

und ein kleine Anwendung

Delphi-Quellcode:

unit FormMain;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls,
  HttpRequestThread;

type
  TForm1 = class( TForm )
    Button1 : TButton;
    ListBox1 : TListBox;
    procedure Button1Click( Sender : TObject );
  private
    FHttpRequest : THttpRequestThread;
    procedure HttpRequestResponse( const Request, Response : string );
    procedure LogMsg( const AMsgStr : string );
  public
    procedure AfterConstruction; override;
    procedure BeforeDestruction; override;
  end;

var
  Form1 : TForm1;

implementation

{$R *.dfm}

procedure TForm1.AfterConstruction;
begin
  inherited;
  FHttpRequest := THttpRequestThread.Create;
  FHttpRequest.OnResponse := HttpRequestResponse;
end;

procedure TForm1.BeforeDestruction;
begin
  inherited;
  FreeAndNil( FHttpRequest );
end;

procedure TForm1.Button1Click( Sender : TObject );
var
  LUrl : string;
  LIdx : Integer;
begin
  LUrl := 'http://google.de';
  for LIdx := 1 to 10 do
    begin
      LogMsg( 'Request ' + LUrl );
      FHttpRequest.Add( LUrl );
    end;
end;

procedure TForm1.HttpRequestResponse( const Request, Response : string );
begin
  LogMsg( Request + ' => ' + Response );
end;

procedure TForm1.LogMsg( const AMsgStr : string );
begin
  ListBox1.Items.Add( DateTimeToStr( Now ) + ': ' + AMsgStr );
end;

end.