unit XMLRequestAsync;

interface

uses
SysUtils, Classes,variants,msxml;

type RequestStringArray=array of string;

type eRequestType=(POST,GET,HEAD);

IOnReadyStateChange=interface;
TXMLRequestAsync = class;

TEventObject=class(TInterfacedObject,IDispatch)
private
sObj:XMLHttpRequest;
sEventCallback:IOnReadyStateChange;
value:integer;
RT:eRequestType;
public

function GetTypeInfoCount(out Count: Integer): HResult; stdcall;
function GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult; stdcall;
function GetIDsOfNames(const IID: TGUID; Names: Pointer;
NameCount, LocaleID: Integer; DispIDs: Pointer): HResult; stdcall;
function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer;
Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult; stdcall;
end;

IOnReadyStateChange = interface
procedure OnReadyStateChange (const XMLHttp_obj:XMLHttpRequest;const EventObject:TEventObject);
end;

TRequestNotifyEvent = procedure(Sender:TObject;requestValue:integer;requestType:eRequestType;respondStatus:integer) of object;

TXMLRequestAsync = class(TComponent,IOnReadyStateChange)
private
{ Private declarations }
XMLHTTP:XMLHttpRequest;
HR:TRequestNotifyEvent;
nParamNames,nParamValues:RequestStringArray;

function IsBusy():longbool;
function GetDoc():IXMLDOMDocument;
function GetReq():XMLHttpRequest;
protected
{ Protected declarations }
procedure OnReadyStateChange (const XMLHttp_obj:XMLHttpRequest;const EventObject:TEventObject);
procedure InitRequest(rType:eRequestType;const URL,USR,PWD:string);
function ChangeURLChars(const nS:string):string;
function GetParameters():string;
procedure SendRequest(const rData:string);
public
{ Public declarations }

function SendHTTPRequest(rType:eRequestType;RequestValue:integer;const Url:string;const Username:string='';const Password:string=''):longbool;
property Busy:longbool read IsBusy;
property Document:IXMLDOMDocument read GetDoc;
property Request:XMLHttpRequest read GetReq;
property ParamNames:RequestStringArray read nParamNames write nParamNames;
property ParamValues:RequestStringArray read nParamValues write nParamValues;
published
{ Published declarations }
property OnHTTPRespond :TRequestNotifyEvent read HR write HR;
end;

procedure Register;

implementation

procedure Register;
begin
RegisterComponents('Dodatne kontrole', [TXMLRequestAsync]);
end;

{ TEventObject }

function TEventObject.GetIDsOfNames(const IID: TGUID; Names: Pointer;
NameCount, LocaleID: Integer; DispIDs: Pointer): HResult;
begin

end;

function TEventObject.GetTypeInfo(Index, LocaleID: Integer;
out TypeInfo): HResult;
begin

end;

function TEventObject.GetTypeInfoCount(out Count: Integer): HResult;
begin

end;

function TEventObject.Invoke(DispID: Integer; const IID: TGUID;
LocaleID: Integer; Flags: Word; var Params; VarResult, ExcepInfo,
ArgErr: Pointer): HResult;
begin
sEventCallback.OnReadyStateChange(sObj,self);
result:=-1;
end;

{ TXMLRequestAsync }

function TXMLRequestAsync.ChangeURLChars(const nS: string): string;
begin
result:=stringreplace(nS,'+','%2B',[rfReplaceAll]);
result:=stringreplace(result,'&','%26',[rfReplaceAll]);
result:=stringreplace(result,' ','%20',[rfReplaceAll]);
result:=stringreplace(result,'=','%3D',[rfReplaceAll]);
end;

function TXMLRequestAsync.GetDoc: IXMLDOMDocument;
begin
result:=nil;
if (XMLHTTP<>nil) and (XMLHTTP.readyState=4) then result:=IXMLDOMDocument(XMLHTTP.responseXML);
end;

function TXMLRequestAsync.GetReq: XMLHttpRequest;
begin
result:=nil;
if (XMLHTTP<>nil) then result:=XMLHTTP;
end;

procedure TXMLRequestAsync.InitRequest(rType:eRequestType;const URL,USR,PWD:string);
var
nT:string;
cURL:string;
cP:string;
begin
if rType=POST then nT:='POST'
else if rType=GET then nT:='GET'
else if rType=HEAD then nT:='HEAD';

if rType=GET then
begin
cURL:=URL;
cP:=GetParameters();
if length(cP)<>0 then cURL:=cURL+'?'+cP;
XMLHttp.open(nT,cURL,true,USR,PWD);
end
else
XMLHttp.open(nT,URL,true,USR,PWD);

XMLHttp.setRequestHeader('Content-Type', 'application/x-www-form-urlencoded');

end;

function TXMLRequestAsync.IsBusy: longbool;
begin

if (XMLHTTP=nil) or (XMLHTTP.readyState in [0,4]) then
result:=false
else
result:=true;

end;

procedure TXMLRequestAsync.OnReadyStateChange(
const XMLHttp_obj: XMLHttpRequest; const EventObject: TEventObject);
begin

if XMLHttp_obj.readyState=4 then
begin
if assigned(HR) then HR(TObject(Self),EventObject.Value,EventObject.RT,XMLHttp_obj.status);
XMLHttp_obj.onreadystatechange:=pointer(0); /////----->makni event! inače se pojavljuje memory leaking !
end;

end;

function TXMLRequestAsync.SendHTTPRequest(rType:eRequestType;RequestValue:integer;const Url:string;const Username:string='';const Password:string=''):longbool;
var
EventObject:TEventObject;
begin
result:=false;

if (length(nParamNames)<>length(nParamValues)) or (length(URL)=0) then exit;

try
XMLHttp:=XMLHttpRequest(CoXMLHTTPRequest.Create());
EventObject:=TEventObject.Create;
EventObject.sObj:=XMLHttp;
EventObject.sEventCallback:=self;
EventObject.RT:=rType;
EventObject.Value:=RequestValue;
XMLHttp.onreadystatechange:= IDispatch(EventObject);

InitRequest(rType,Url,Username,Password);

if rType=GET then
SendRequest('')
else
SendRequest(GetParameters());

result:=true;
except
EventObject.FreeInstance;
EventObject:=nil;
end;
end;

function TXMLRequestAsync.GetParameters():string;
var
x:integer;
begin
setlength(result,0);
for x:=0 to high(nParamNames) do begin
result:=result+nParamNames[x]+'='+ChangeURLChars(nParamValues[x]);
if x=high(nParamNames) then break;
result:=result+'&';
end;
end;

procedure TXMLRequestAsync.SendRequest(const rData:string);
begin
XMLHTTP.send(rData);
end;

end.