unit XWebLoader;
interface
uses Classes, SysUtils, SyncObjs, IdHTTP, IdComponent, XWebDataTypes;
type
TOnFinishLoadEvent =
procedure(Sender: TObject; LoaderMessage: TXWebLoaderMessage)
of object;
TOnErrorLoadEvent =
procedure(Sender: TObject; LoaderMessage: TXWebLoaderMessage)
of object;
TOnRemoveEvent =
procedure(Sender: TObject)
of object;
TXWebLoader =
class(TThread)
strict private
FCS: TCriticalSection;
FHTTP: TIdHTTP;
FXWebLink:
string;
FParameter:
string;
FCookie:
string;
FDeviceName:
string;
FMessageID: Integer;
FDigit: Integer;
FGoLoading: Boolean;
FOnFinish: TOnFinishLoadEvent;
FOnError: TOnErrorLoadEvent;
FOnRemove: TOnRemoveEvent;
FMsg: TXWebLoaderMessage;
procedure SyncOnFinish;
procedure SyncOnError;
procedure CheckAbort(Sender: TObject; AWorkMode: TWorkMode; AWorkCount: Int64);
protected
procedure Execute;
override;
procedure Remove(Sender: TObject);
public
constructor Create(Suspended: Boolean);
destructor Destroy;
override;
procedure GetData(
const XWebLink,Parameter,Cookie,DeviceName :
string; MessageID,Digit: Integer);
property OnFinish: TOnFinishLoadEvent
read FOnFinish
write FOnFinish;
property OnError: TOnErrorLoadEvent
read FOnError
write FOnError;
property OnRemove: TOnRemoveEvent
read FOnRemove
write FOnRemove;
end;
implementation
{ TXWebLoader }
procedure TXWebLoader.CheckAbort(Sender: TObject; AWorkMode: TWorkMode;
AWorkCount: Int64);
// auch ein Versuch den Socket Error der Indys beim Programm Beenden zu kompensieren
begin // war ein Tipp in einem Beitrag. Hier kommt das Programm gar nicht an. Die Threads werden
if Terminated
then // einfach abgewürgt
FHTTP.Disconnect;
end;
constructor TXWebLoader.Create(Suspended: Boolean);
begin
inherited Create(Suspended);
FCS:= TCriticalSection.Create;
FHTTP:= TIdHTTP.Create;
FHTTP.OnWork:= CheckAbort;
FMsg:= TXWebLoaderMessage.Create;
Self.OnTerminate:= Remove;
end;
destructor TXWebLoader.Destroy;
begin
FHTTP.Free;
FMsg.Free;
FreeAndNil(FCS);
inherited;
end;
procedure TXWebLoader.Execute;
var
XWebParameter: TStringStream;
ResponseStream: TStringStream;
sl: TStringList;
begin
inherited;
if not Terminated
then
begin
sl:= TStringList.Create;
try
XWebParameter:= TStringStream.Create(FParameter);
try
ResponseStream:= TStringStream.Create;
try
try
FHTTP.Request.CustomHeaders.Add(FCookie);
if FParameter = '
'
then
FHTTP.Get(FXWebLink,ResponseStream)
else
FHTTP.Post(FXWebLink,XWebParameter,ResponseStream);
ResponseStream.Position:= 0;
sl.LoadFromStream(ResponseStream,TEncoding.UTF8);
FMsg.Data:= sl.Text;
Synchronize(SyncOnFinish);
except
on e:
Exception do
begin // evt. noch weitere Informationen in Stringlist oder Klasse dafür ?
FMsg.Data:= e.
Message;
Synchronize(SyncOnError);
end;
end;
finally
ResponseStream.Free;
end;
finally
XWebParameter.Free;
end;
finally
sl.Free;
end;
Sleep(100);
// extra eingefügt
end;
end;
procedure TXWebLoader.GetData(
const XWebLink, Parameter, Cookie, DeviceName :
string; MessageID,Digit: Integer);
begin
FCS.Enter;
try
FXWebLink:= XWebLink;
FParameter:= Parameter;
FCookie:= Cookie;
FDeviceName:= DeviceName;
FMessageID:= MessageID;
FDigit:= Digit;
FMsg.ID:= FMessageID;
FMsg.DeviceName:= FDeviceName;
FMsg.Digit:= FDigit;
Self.Start;
finally
FCS.Leave;
end;
end;
procedure TXWebLoader.SyncOnError;
begin
FCS.Enter;
try
if Assigned(FOnError)
then
FOnError(Self,FMsg);
finally
FCS.Leave;
end;
end;
procedure TXWebLoader.SyncOnFinish;
begin
FCS.Enter;
try
if Assigned(FOnFinish)
then
FOnFinish(Self,FMsg);
finally
FCS.Leave;
end;
end;
procedure TXWebLoader.Remove(Sender: TObject);
begin
FCS.Enter;
try
if Assigned(FOnRemove)
then
FOnRemove(Self);
finally
FCS.Leave;
end;
end;
end.