xmlworksrpc.pas

delphi的XMPRPC通讯例子

function RPCValueToInt(const value: string): integer;
begin
  result := StrToInt(getRPCValue(value, rpcInt));
end;


{ TXMLRPCMethodCall }

{
****************************** TXMLRPCMethodCall *******************************
}
constructor TXMLRPCMethodCall.Create(p_sXML: String = '');
begin
  fParams := TXMLRPCParams.Create;
  inherited;
end;

class function TXMLRPCMethodCall.getTagName: string;
begin
  result := 'methodCall';
end;

{
******************************** TXMLRPCParams *********************************
}
constructor TXMLRPCParams.Create(p_sXML: String = '');
begin
  fParam := TXMLRPCParam.Create;
  inherited;
end;

{
********************************* TXMLRPCParam *********************************
}
function TXMLRPCParam.AddBase64(const value: string): Integer;
begin
  result := Add(StrToRPCBase64(value));
end;

function TXMLRPCParam.AddBoolean(const value: boolean): Integer;
begin
  result := Add(StrToRPCBoolean(value));
end;

function TXMLRPCParam.AddDateTime(const value: TDateTime): Integer;
begin
  result := Add(StrToRPCDateTime(value));
end;

function TXMLRPCParam.AddDouble(const value: double): Integer;
begin
  result := Add(StrToRPCDouble(value));
end;

function TXMLRPCParam.AddInteger(const value: integer): Integer;
begin
  result := Add(StrToRPCInteger(value));
end;

function TXMLRPCParam.AddString(const value: string): Integer;
begin
  result := Add(StrToRPCString(value));
end;

function TXMLRPCParam.getBase64(const Index: integer): string;
begin
  result := RPCValueToBase64(get(Index));
end;

function TXMLRPCParam.getBoolean(const Index: integer): Boolean;
begin
  result := RPCValueToBoolean(get(Index));
end;

function TXMLRPCParam.getDateTime(const Index: integer): TDateTime;
begin
  result := RPCValueToDateTime(get(Index));
end;

function TXMLRPCParam.getDouble(const Index: integer): Double;
begin
  result := RPCValueToDouble(get(Index));
end;

function TXMLRPCParam.getInteger(const Index: integer): Integer;
begin
  result := RPCValueToInt(get(Index));
end;

function TXMLRPCParam.getString(const Index: integer): string;
begin
  result := RPCValueToString(get(Index));
end;

function TXMLRPCParam.getType(Index: integer): TRPCType;
begin
  result := getRPCType(get(Index));
end;

{
******************************** TXMLRPCStruct *********************************
}
constructor TXMLRPCStruct.Create(const value: string = '');
begin
  inherited Create(TXMLRPCStructMember);
  if (value <> '') then
    setElementText(value);
end;

function TXMLRPCStruct.AddBase64(const value: string): TXMLRPCStructMember;
begin
  result := Add as TXMLRPCStructMember;
  result.AsBase64 := value;
end;

function TXMLRPCStruct.AddBoolean(const value: boolean): TXMLRPCStructMember;
begin
  result := Add as TXMLRPCStructMember;
  result.AsBoolean := value;
end;

function TXMLRPCStruct.AddDateTime(const value: TDateTime): TXMLRPCStructMember;
begin
  result := Add as TXMLRPCStructMember;
  result.AsDateTime := value;
end;

function TXMLRPCStruct.AddDouble(const value: double): TXMLRPCStructMember;
begin
  result := Add as TXMLRPCStructMember;
  result.AsDouble := value;
end;

function TXMLRPCStruct.AddInteger(const value: integer): TXMLRPCStructMember;
begin
  result := Add as TXMLRPCStructMember;
  result.AsInteger:= value;
end;

function TXMLRPCStruct.AddString(const value: string): TXMLRPCStructMember;
begin
  result := Add as TXMLRPCStructMember;
  result.AsString := value;
end;

class function TXMLRPCStruct.getTagName: string;
begin
  result := gstr_RPCStructType;
end;

{
***************************** TXMLRPCStructMember ******************************
}
function TXMLRPCStructMember.GetAsBase64: string;
begin
  result := RPCValueToBase64(fValue);
end;

function TXMLRPCStructMember.GetAsBoolean: Boolean;
begin
  result := RPCValueToBoolean(fValue);
end;

function TXMLRPCStructMember.GetAsDateTime: TDateTime;
begin
  result := RPCValueToDateTime(fValue);
end;

function TXMLRPCStructMember.GetAsDouble: Double;
begin
  result := RPCValueToDouble(fValue);
end;

function TXMLRPCStructMember.GetAsInteger: Integer;
begin
  result := RPCValueToInt(fValue);
end;

function TXMLRPCStructMember.GetAsString: string;
begin
  result := RPCValueToString(fValue);
end;

class function TXMLRPCStructMember.getTagName: string;
begin
  result := gstr_RPCStructMember;
end;

function TXMLRPCStructMember.getType: TRPCType;
begin
  result := getRPCType(fValue);
end;

procedure TXMLRPCStructMember.SetAsBase64(const Value: string);
begin
  fValue := StrToRPCBase64(value);
end;

procedure TXMLRPCStructMember.SetAsBoolean(Value: Boolean);
begin
  fValue := StrToRPCBoolean(value);
end;

procedure TXMLRPCStructMember.SetAsDateTime(Value: TDateTime);
begin
  fValue := StrToRPCDateTime(value);
end;

procedure TXMLRPCStructMember.SetAsDouble(Value: Double);
begin
  fValue := StrToRPCDouble(value);
end;

procedure TXMLRPCStructMember.SetAsInteger(Value: Integer);
begin
  fValue := StrToRPCInteger(value);
end;

procedure TXMLRPCStructMember.SetAsString(const Value: string);
begin
  fValue := StrToRPCString(value);
end;

{
********************************* TXMLRPCArray *********************************
}
constructor TXMLRPCArray.Create(p_sXML: String = '');
begin
  fData := TXMLRPCParam.Create;
  inherited;
end;

class function TXMLRPCArray.getTagName: string;
begin
  result := gstr_RPCArrayType;
end;

{
************************** TXMLRPCMethodResponseBase ***************************
}
constructor TXMLRPCMethodResponseBase.Create(p_sXML: string = '');
begin
  fParams := TXMLRPCParams.Create;
  fFault := TXMLRPCStruct.Create;
  inherited;
end;

class function TXMLRPCMethodResponseBase.getTagName: string;
begin
  result := 'methodResponse';
end;

function TXMLRPCMethodResponseBase.IsFault: Boolean;
begin
  result := fault.Count > 0;
end;

procedure TXMLRPCMethodResponseBase.ProcessRequest(p_Request: 
        TXMLRPCMethodCall);
var
  XMLStream, ResponseStream: TStringStream;
  HTTPConnection: TIdHTTP;
begin
  XMLStream := TSTringStream.Create('<?xml version="1.0" encoding="utf-8"?>'+UTF8Encode(p_Request.XML));
//  XMLStream := TSTringStream.Create(p_Request.XML);
  ResponseStream := TStringStream.Create('');
  HTTPConnection := TidHTTP.Create(nil);
  HTTPConnection.ReadTimeout:=30000;
  HTTPConnection.Post(p_Request.URL, XMLStream, ResponseStream);
  HTTPConnection.Free;
  XMLStream.Free;
  //ResponseXML:='';
 // XML :='';
  ResponseXML := UTF8Decode(ResponseStream.DataString);
  XML := ResponseXML;
  ResponseStream.Free;
end;

{
******************************** TXMLRPCServer *********************************
}
constructor TXMLRPCServer.Create(const p_iPort: Integer);
begin
  Server := TIdHTTPServer.Create(nil);
  Server.OnCommandGet := ServerCommandGet;
  Server.OnConnect := DoConnect;
  Server.OnDisconnect := DoDisconnect;
  Server.OnException := DoException;
  UpdateBindings(p_iPort);
end;

destructor TXMLRPCServer.Destroy;
begin
  Server.Free;
  inherited;
end;

procedure TXMLRPCServer.DoConnect(AThread: TIdPeerThread);
begin
  if assigned(f_OnConnect) then
    f_OnConnect(AThread);
end;

procedure TXMLRPCServer.DoDisconnect(AThread: TIdPeerThread);
begin
  if assigned(f_OnDisconnect) then
    f_OnDisconnect(AThread);
end;

procedure TXMLRPCServer.DoException(AThread: TIdPeerThread; AException: 
        Exception);
begin
  if assigned(f_OnException) then
    f_OnException(AThread, AException);
end;

function TXMLRPCServer.GetActive: Boolean;
begin
  result := Server.Active;
end;

function TXMLRPCServer.GetActiveConnections: Integer;
begin
  with Server.ThreadMgr.ActiveThreads.LockList do
  try
    result := Count - 1;
  finally
    Server.ThreadMgr.ActiveThreads.UnlockList;
  end;
end;

procedure TXMLRPCServer.ServerCommandGet(AThread: TIdPeerThread; RequestInfo: 
        TIdHTTPRequestInfo; ResponseInfo: TIdHTTPResponseInfo);
var
  ResponseXML: string;
begin
  if Assigned(fOnRequest) then
  begin
    try
      fOnRequest(AThread, RequestInfo.RemoteIP, RequestInfo.UnparsedParams, ResponseXML);
      ResponseInfo.ResponseNo := 200;
      ResponseInfo.ContentText := ResponseXML;
    except
      on e: exception do
      begin
        ResponseInfo.ResponseNo := 500;
        ResponseInfo.ContentText := '(' + e.ClassName + ') ' + e.Message;
      end;
    end;
  end
  else
  begin
    ResponseInfo.ResponseNo := 500;
    ResponseInfo.ContentText := 'Invalid Server Configuration - No Request handler Defined';
  end;
end;

procedure TXMLRPCServer.SetActive(const Value: Boolean);
begin
  Server.Active := Value;
end;

procedure TXMLRPCServer.UpdateBindings(p_iPort: Integer);
var
  Binding: TIdSocketHandle;
begin
  // Set the TIdTCPServer's port to the chosen value
  Server.DefaultPort := p_iPort;
  // Remove all bindings that currently exist
  Server.Bindings.Clear;
  // Create a new binding
  Binding := Server.Bindings.Add;
  // Assign that bindings port to our new port
  Binding.Port := p_iPort;
end;

end.