ucomm

unit uComm;

interface
  uses classes,msxml2_tlb,Windows;

type
  TPubToolKit = class(TObject)
  private
    FXmlHttp : IXMLHTTPRequest;
  public
    class function NewInstance: TObject; override;
    procedure FreeInstance; override;
    class function RefCount: Integer;
    function isHttpSerOk(sTestUrl: string): boolean;
    function doGet(sUrl: string): OleVariant;
    function doGet2(sUrl: string): string;
    function ProcPost(sUrl:string; PostStream,rtnStream: TStream):boolean;overload;
    function ProcPost(sUrl: string; PostStream: TStream): TStream;overload;
    property xmlHttpReq : IXMLHTTPRequest read FXmlHttp;
  end;

var
    Ptk : TPubToolKit;
    Ref_Count : Integer = 0;
    HTTPCS: TRTLCriticalSection ;

implementation
uses variants,axctrls,Activex,SysUtils;

procedure SaveXMLHttpResponseToStream(xmlHttp : IXMLHTTPRequest;AStream: TStream);
var
  OleStream: TOleStream;
begin
  OleStream := TOleStream.Create(IStream(IUnknown(xmlHttp.responseStream)));
  try
    try
      AStream.CopyFrom(OleStream, OleStream.Size);
    except
      on e : exception do
        showmessage(e.Message);
    end;
  finally
    OleStream.Free;
  end;
end;

function TPubToolKit.isHttpSerOk(sTestUrl:string):boolean;
begin
  EnterCriticalSection(HTTPCS);
  Result := false;
  try
    try
      //向服务器发送一个Test请求，只要状态为200，则表示跟服务器是可连通的状态
      FXmlHttp.open('GET',sTestUrl,false,EmptyParam,EmptyParam);
      FXmlHttp.send( EmptyParam );
      result := FXmlHttp.status = 200;
    except
      on e:Exception do
      begin
        e.Message := '连接失败：' + e.Message ;
        raise;
      end;
    end;
  finally
    LeaveCriticalSection(HTTPCS);
  end;
end;

function TPubToolKit.ProcPost(sUrl:string; PostStream,rtnStream: TStream):boolean;
begin
  result :=false;
  EnterCriticalSection(HTTPCS);
  try
    try
      FXmlHttp.open('POST',sURL,false,EmptyParam,EmptyParam);
      FXmlHttp.send( StreamToVariant(PostStream) );
      if FXmlHttp.status = 200 then begin
        SaveXMLHttpResponseToStream(FXmlHttp,rtnStream);
        result := true;
      end else
        StringToStream(rtnStream,FXmlHttp.statusText);
    except
      on e:Exception do
      begin
        e.Message := '连接失败：' + e.Message ;
        raise;
      end;
    end;
  finally
     LeaveCriticalSection(HTTPCS);
  end;
end;

function TPubToolKit.ProcPost(sUrl:string; PostStream: TStream):TStream;
begin
  try
    Result := TMemoryStream.Create;
    ProcPost(sUrl,PostStream,Result);
  except
    if Assigned(Result) then FreeAndNil(Result);
    raise;
  end;
end;

function TPubToolKit.doGet(sUrl:string): OleVariant;
begin
  EnterCriticalSection(HTTPCS);
  try
    try
      FXmlHttp.open('GET',sURL,false,EmptyParam,EmptyParam);
      FXmlHttp.send(EmptyParam);
      Result := FXmlHttp.responseBody;
    except
      on e:Exception do
      begin
        e.Message := '连接失败：' + e.Message ;
        raise;
      end;
    end;
  finally
    LeaveCriticalSection(HTTPCS);
  end;
end;

function TPubToolKit.doGet2(sUrl: string): string;
begin
  EnterCriticalSection(HTTPCS);
  try
    try
      FXmlHttp.open('GET',sURL,false,EmptyParam,EmptyParam);
      FXmlHttp.send(EmptyParam);
      Result := FXmlHttp.responseText;
    except
      on e:Exception do
      begin
        e.Message := '连接失败：' + e.Message ;
        raise;
      end;
    end;
  finally
    LeaveCriticalSection(HTTPCS);
  end;
end;

{ TChObj }
procedure TPubToolKit.FreeInstance;
begin
    // 减少引用计数
  Dec(Ref_Count);
    //当引用计数为0时，释放该对象实例
  if (Ref_Count = 0) then
  begin
    DeleteCriticalSection(HTTPCS);
    Ptk := nil;
    FXmlHttp := nil;
    inherited FreeInstance;
  end;
end;

class function TPubToolKit.NewInstance: TObject;
begin
  if (not Assigned(Ptk) ) then
  begin
    Ptk := inherited NewInstance as TPubToolKit;
    // 在这里可以初始化些局部变量例如：
    with Ptk do
    begin
      FXmlHttp := CoXMLHTTP.Create;
    end;
    InitializeCriticalSection(HTTPCS);
  end 
  Result := Ptk;
  // 增加引用计数
  Inc( Ref_Count );
end;

class function TPubToolKit.RefCount: Integer;
begin
  //返回引用计数
  Result := Ref_Count;
end;

end.