XMLRPC clients and servers can be easily written in purebasic without the use of components. The advantage is that only 1 executable has to be installed and no dll's or com's. I wrote a small OOish includefile that can be used to program XMLTPC clients or servers. The design is not fully OO and therefor the programmer should be aware of what he is doing (no errors are returned if methods are nit used in the intended order). The following files are in this message :
OO_XMLRPC.pb ---- The XIncludeFile
TimeServer.pb ---- a server that returns the current time
usage : TimeServer <portnr>
example : TimeServer 8000
TimeClient.pb ---- a client that retrieves the current time
usage : TimeClient <URL> <portnr>
example : TimeClient
www.xmlrpc.com 80
example : TimeClient localhost 8000
TotalServer.pb ---- a server that totalises an array of floating point numbers
usage : TotalServer <portnr>
example : TotalServer 8000
TotalClient.pb ---- a client that receives the total
usage : TotalClient <URL> <portnr>
example : TotalClient localhost 8000
The software is not extensively tested against XMLRPC servers on the Web so that there still some shortcomings but the idea works.
The XIncludeFile
Code: Select all
;****************************************
;
; XML-RPC inclidefile OO_XMLRPC
; Author : Leo Mijnders
; Date : Nov 2004
;
;****************************************
; TAG Definitions
;****************************************
#CRF = Chr(13)
#HTF = Chr(9)
#LFF = Chr(10)
#CRLF = Chr(13)+Chr(10)
#MAXDEPTH = 20
#POST = "POST "
#HTTP = "HTTP 1.0"
#USERAGENT = "User-Agent: "
#HOST = "Host: "
#CONTENTTYPE = "Content-Type: text/html"
#CONTENTLENGTH = "Content-length: "
#PARAM_TAG = "<param>"
#PARAM_ETAG = "</param>"
#VALUE_TAG = "<value>"
#VALUE_ETAG = "</value>"
#BOOLEAN_TAG = "<boolean>"
#BOOLEAN_ETAG = "</boolean>"
#DOUBLE_TAG = "<double>"
#DOUBLE_ETAG = "</double>"
#INT_TAG = "<int>"
#INT_ETAG = "</int>"
#I4_TAG = "<i4>"
#I4_ETAG = "</i4>"
#STRING_TAG = "<string>"
#STRING_ETAG = "</string>"
#DATETIME_TAG = "<dateTime.iso8601>"
#DATETIME_ETAG = "</dateTime.iso8601>"
#BASE64_TAG = "<base64>"
#BASE64_ETAG = "</base64>"
#NIL_TAG = "<nil/>"
#ARRAY_TAG = "<array>"
#DATA_TAG = "<data>"
#DATA_ETAG = "</data>"
#ARRAY_ETAG = "</array>"
#STRUCT_TAG = "<struct>"
#MEMBER_TAG = "<member>"
#NAME_TAG = "<name>"
#NAME_ETAG = "</name>"
#MEMBER_ETAG = "</member>"
#STRUCT_ETAG = "</struct>"
;****************************************
; XMLRPCSend
;****************************************
Interface XMLRPCSend
AddBase64(Addr.l, Long.l)
AddBoolean(Boolean.b)
AddDateTime(Seconds.l)
AddDouble(Float.f, Decimals.l)
AddInteger(Integer.l)
AddString(String.s)
AddNil()
OpenArray()
CloseArray()
OpenStruct()
CloseStruct()
OpenMember(Name.s)
CloseMember()
Submit.s(Caddr.l)
EndInterface
Structure XMLRPCSendInstance
vTable.l
Functions.l[SizeOf(XMLRPCSend)/4]
HostName.s
HostPort.l
HostUri.s
MethodName.s
Server.s
UserAgent.s
XMLBody.s
Nested.b
Fault.b
EndStructure
Procedure AddBase64(*self.XMLRPCSendInstance, Addr.l, Long.l)
*self\XMLBody+Space(2 * *self\Nested)
*OutputBuffer=AllocateMemory(2*Long+64)
Base64Encoder(Addr, Long, *OutputBuffer, 2*Long+64)
If *self\Nested | *self\Fault = 0
*self\XMLBody+#PARAM_TAG
EndIf
*self\XMLBody+#VALUE_TAG+#BASE64_TAG
*self\XMLBody+PeekS(*OutputBuffer)
*self\XMLBody+#BASE64_ETAG+#VALUE_ETAG
FreeMemory(*OutputBuffer)
If *self\Nested | *self\Fault = 0
*self\XMLBody+#PARAM_ETAG
EndIf
*self\XMLBody+#CRLF
EndProcedure
Procedure AddBoolean(*self.XMLRPCSendInstance, Boolean.b)
*self\XMLBody+Space(2 * *self\Nested)
If *self\Nested | *self\Fault = 0
*self\XMLBody+#PARAM_TAG
EndIf
*self\XMLBody+#VALUE_TAG+#BOOLEAN_TAG
*self\XMLBody+Str(Boolean)
*self\XMLBody+#BOOLEAN_ETAG+#VALUE_ETAG
If *self\Nested | *self\Fault = 0
*self\XMLBody+#PARAM_ETAG
EndIf
*self\XMLBody+#CRLF
EndProcedure
Procedure AddDateTime(*self.XMLRPCSendInstance, Seconds.l)
*self\XMLBody+Space(2 * *self\Nested)
If *self\Nested | *self\Fault = 0
*self\XMLBody+#PARAM_TAG
EndIf
*self\XMLBody+#VALUE_TAG+#DATETIME_TAG
*self\XMLBody+FormatDate("%yyyy%mm%ddT%hh:%ii:%ss",Seconds)
*self\XMLBody+#DATETIME_ETAG+#VALUE_ETAG
If *self\Nested | *self\Fault = 0
*self\XMLBody+#PARAM_ETAG
EndIf
*self\XMLBody+#CRLF
EndProcedure
Procedure AddDouble(*self.XMLRPCSendInstance, Float.f, Decimals.l)
*self\XMLBody+Space(2 * *self\Nested)
If *self\Nested | *self\Fault = 0
*self\XMLBody+#PARAM_TAG
EndIf
*self\XMLBody+#VALUE_TAG+#DOUBLE_TAG
*self\XMLBody+StrF(Float, Decimals)
*self\XMLBody+#DOUBLE_ETAG+#VALUE_ETAG
If *self\Nested | *self\Fault = 0
*self\XMLBody+#PARAM_ETAG
EndIf
*self\XMLBody+#CRLF
EndProcedure
Procedure AddInteger(*self.XMLRPCSendInstance, Long.l)
*self\XMLBody+Space(2 * *self\Nested)
If *self\Nested | *self\Fault = 0
*self\XMLBody+#PARAM_TAG
EndIf
*self\XMLBody+#VALUE_TAG+#I4_TAG
*self\XMLBody+Str(Long)
*self\XMLBody+#I4_ETAG+#VALUE_ETAG
If *self\Nested | *self\Fault = 0
*self\XMLBody+#PARAM_ETAG
EndIf
*self\XMLBody+#CRLF
EndProcedure
Procedure AddString(*self.XMLRPCSendInstance, String.s)
*self\XMLBody+Space(2 * *self\Nested)
If *self\Nested | *self\Fault = 0
*self\XMLBody+#PARAM_TAG
EndIf
*self\XMLBody+#VALUE_TAG+#STRING_TAG
*self\XMLBody+String
*self\XMLBody+#STRING_ETAG+#VALUE_ETAG
If *self\Nested | *self\Fault = 0
*self\XMLBody+#PARAM_ETAG
EndIf
*self\XMLBody+#CRLF
EndProcedure
Procedure AddNil(*self.XMLRPCSendInstance)
*self\XMLBody+Space(2 * *self\Nested)
If *self\Nested | *self\Fault = 0
*self\XMLBody+#PARAM_TAG
EndIf
*self\XMLBody+#VALUE_TAG+#NIL_TAG+#VALUE_ETAG
If *self\Nested | *self\Fault = 0
*self\XMLBody+#PARAM_ETAG
EndIf
*self\XMLBody+#CRLF
EndProcedure
Procedure OpenArray(*self.XMLRPCSendInstance)
*self\XMLBody+Space(2 * *self\Nested)
If *self\Nested | *self\Fault = 0
*self\XMLBody+#PARAM_TAG
EndIf
*self\XMLBody+#VALUE_TAG+#ARRAY_TAG+#DATA_TAG
*self\XMLBody+#CRLF
*self\Nested+1
EndProcedure
Procedure CloseArray(*self.XMLRPCSendInstance)
*self\XMLBody+Space(2 * *self\Nested)
*self\XMLBody+#DATA_ETAG+#ARRAY_ETAG+#VALUE_ETAG
If *self\Nested = 1 And *self\Fault=0
*self\XMLBody+#PARAM_ETAG
EndIf
*self\XMLBody+#CRLF
*self\Nested-1
EndProcedure
Procedure OpenStruct(*self.XMLRPCSendInstance)
*self\XMLBody+Space(2 * *self\Nested)
If *self\Nested | *self\Fault = 0
*self\XMLBody+#PARAM_TAG
EndIf
*self\XMLBody+#VALUE_TAG+#STRUCT_TAG
*self\XMLBody+#CRLF
*self\Nested+1
EndProcedure
Procedure CloseStruct(*self.XMLRPCSendInstance)
*self\XMLBody+Space(2 * *self\Nested)
*self\XMLBody+#STRUCT_ETAG+#VALUE_ETAG
If *self\Nested = 1 And *self\Fault = 0
*self\XMLBody+#PARAM_ETAG
EndIf
*self\XMLBody+#CRLF
*self\Nested-1
EndProcedure
Procedure OpenMember(*self.XMLRPCSendInstance, Name.s)
*self\XMLBody+Space(2 * *self\Nested)
*self\XMLBody+#MEMBER_TAG+#CRLF+Space(2* *self\Nested)+#NAME_TAG+Name+#NAME_ETAG
*self\XMLBody+#CRLF
EndProcedure
Procedure CloseMember(*self.XMLRPCSendInstance)
*self\XMLBody+Space(2 * *self\Nested)
*self\XMLBody+#MEMBER_ETAG
*self\XMLBody+#CRLF
EndProcedure
Procedure.s Submit(*self.XMLRPCSendInstance, caddr.l)
If *self\Fault
*self\Nested=1
EndIf
ReturnString.s=""
If *self\Server=""
naddr.l=OpenNetworkConnection(*self\HostName,*self\HostPort)
Else
naddr.l=caddr
EndIf
If naddr
xml.s="<?xml version="+Chr(34)+"1.0"+Chr(34)+"?>"+#CRLF
If *self\Server=""
xml+"<methodCall>"
Else
xml+"<methodResponse>"
EndIf
xml+#CRLF
If *self\Server=""
xml+"<methodName>"+*self\MethodName+"</methodName>"+#CRLF
EndIf
If *self\Fault
xml+"<fault>"+#CRLF
Else
xml+"<params>"+#CRLF
EndIf
xml+*self\XMLBody
If *self\Fault
xml+"</fault>"+#CRLF
Else
xml+"</params>"+#CRLF
EndIf
If *self\Server=""
xml+"</methodCall>"
Else
xml+"</methodResponse>"
EndIf
xml+#CRLF
If *self\Server=""
com$="POST /RPC2 HTTP/1.0"+#CRLF
com$=com$+"User-Agent: HTTP-For-PureBasic"+#CRLF
com$=com$+"Host: "+*self\HostName+#CRLF
com$=com$+"Content-Type: text/html"+#CRLF
com$=com$+"Content-Length: "+Str(Len(xml))+#CRLF
com$=com$+ #CRLF
com$+xml
Else
com$="HTTP/1.1 200 OK"+#CRLF
com$+"Connection: close"+#CRLF
com$+"Content-Length: "+Str(Len(xml))+#CRLF
com$+"Content-Type: text/html"+#CRLF
com$+"Date: "+"To do"+#CRLF
com$+"Server: "+*self\Server+#CRLF
com$+ #CRLF
com$+xml
EndIf
SendNetworkString(naddr,com$)
If *self\Server=""
Buffer.s=Space(4999)
Repeat
result=ReceiveNetworkData(naddr,@Buffer,Len(Buffer))
ReturnString+Left(PeekS(@Buffer),result)
Until result=0
CloseNetworkConnection(naddr)
EndIf
EndIf
ProcedureReturn ReturnString
EndProcedure
Procedure.l CreateInstance_XMLRPCSend()
*Instance.XMLRPCSendInstance = AllocateMemory(SizeOf(XMLRPCSendInstance))
*Instance\vTable = *Instance + OffsetOf(XMLRPCSendInstance, Functions)
*Instance\Functions[0] = @AddBase64()
*Instance\Functions[1] = @AddBoolean()
*Instance\Functions[2] = @AddDateTime()
*Instance\Functions[3] = @AddDouble()
*Instance\Functions[4] = @AddInteger()
*Instance\Functions[5] = @AddString()
*Instance\Functions[6] = @AddNil()
*Instance\Functions[7] = @OpenArray()
*Instance\Functions[8] = @CloseArray()
*Instance\Functions[9] = @OpenStruct()
*Instance\Functions[10] = @CloseStruct()
*Instance\Functions[11] = @OpenMember()
*Instance\Functions[12] = @CloseMember()
*Instance\Functions[13] = @Submit()
*Instance\HostName = ""
*Instance\HostPort = 0
*Instance\HostUri = ""
*Instance\MethodName = ""
*Instance\XMLBody = ""
*Instance\Server = ""
*Instance\Nested = 0
*Instance\Fault = 0
ProcedureReturn *Instance
EndProcedure
;****************************************
; XMLRPCRecieve
;****************************************
Interface XMLRPCRecieve
FirstContent()
NextContent()
CheckWellFormed()
GetCurrentPos.l()
EndInterface
Structure ParseStructure
Tag.s
Nr.l
EndStructure
Structure XMLRPCRecieveInstance
vTable.l
Functions.l[SizeOf(XMLRPCRecieve)/4]
Response.s
Header.s
XMLBody.s
Content.s
ContentPresent.b
ContentLevel.l
StringFieldNr.l
Parse.ParseStructure[#MaxDepth]
XMLVersion.s
XMLWellFormed.b
EndStructure
Procedure Content(*self.XMLRPCRecieveInstance, StringFieldNr.l)
i=StringFieldNr
Repeat
Tag.s=StringField(*self\XMLBody,i,#CRF)
*self\ContentPresent=0
*self\XMLWellFormed=1
If Tag="" ; end of XML
*self\StringFieldNr=i+1
ProcedureReturn
ElseIf Trim(Tag)="" ; space
*self\StringFieldNr=i+1
ElseIf Left(Tag,1)="<" And Right(Tag,1)<>">"
*self\XMLWellFormed=0
*self\StringFieldNr=i
ProcedureReturn
ElseIf Left(Tag,1)<>"<" And Right(Tag,1)=">"
*self\XMLWellFormed=0
*self\StringFieldNr=i
ProcedureReturn
ElseIf Left(Tag,13)="<?xml version" ; set XML version
*self\XMLVersion=Tag
ElseIf Left(Tag,2)="<?" ; ignore comment tags
ElseIf Left(Tag,3)="</>" ; handle the NIL Tag
*self\ContentLevel-1
*self\Content=""
*self\ContentPresent=1
ElseIf Left(Tag,2)="</" ; handle end tag
*self\ContentLevel-1
If *self\Parse[*self\ContentLevel]\Tag <> ReplaceString(Tag,"</","<")
*self\XMLWellFormed=0
*self\StringFieldNr=i
ProcedureReturn
EndIf
ElseIf Left(Tag,1)="<" ; handle tag
*self\Parse[*self\ContentLevel]\Tag=Tag
*self\Parse[*self\ContentLevel]\Nr+1
*self\ContentLevel+1
*self\Parse[*self\ContentLevel]\Nr=0
Else ; handle content
*self\Content=Tag
*self\ContentPresent=1
EndIf
i+1
Until *self\ContentPresent=1
*self\StringFieldNr=i
EndProcedure
Procedure FirstContent(*self.XMLRPCRecieveInstance)
Content(*self,1)
EndProcedure
Procedure NextContent(*self.XMLRPCRecieveInstance)
Content(*self,*self\StringFieldNr)
EndProcedure
Procedure CheckWellFormed(*self.XMLRPCRecieveInstance)
*self\StringFieldNr=1
Repeat
Content(*self,*self\StringFieldNr)
Until *self\ContentPresent=0 Or *self\XMLWellFormed=0
EndProcedure
Procedure.l GetCurrentPos(*self.XMLRPCRecieveInstance)
For i=1 To *self\StringFieldNr
Tag.s =StringField(*self\XMLBody, i, #CRF)
StartPos.l=1
If Tag="</>"
ElseIf Left(Tag,1)="<"
StartPos=FindString(*self\Response, Tag, StartPos)
EndIf
Next
ProcedureReturn StartPos
EndProcedure
Procedure.l CreateInstance_XMLRPCRecieve(Response.s)
*Instance.XMLRPCRecieveInstance = AllocateMemory(SizeOf(XMLRPCRecieveInstance))
*Instance\vTable = *Instance + OffsetOf(XMLRPCRecieveInstance, Functions)
*Instance\Functions[0] = @FirstContent()
*Instance\Functions[1] = @NextContent()
*Instance\Functions[2] = @CheckWellFormed()
*Instance\Functions[3] = @GetCurrentPos()
*Instance\Response = Response
ContentLength=Val(Mid(Response,FindString(Response,"Content-Length:",1)+15,10))
*Instance\Header = Left(Response,Len(Response)-ContentLength)
Temp.s=Right(Response, ContentLength)
Temp=ReplaceString(Temp,"/>","></>")
Temp=ReplaceString(Temp,#CRF,"")
Temp=ReplaceString(Temp,#LFF,"")
Temp=ReplaceString(Temp,#HTF,"")
Temp=ReplaceString(Temp,"<",#CRF+"<")
Temp=ReplaceString(Temp,">",">"+#CRF)
Temp=ReplaceString(Temp,#CRF+#CRF,#CRF)
*Instance\XMLBody=Right(Temp,Len(Temp)-FindString(Temp,"<",1)+1)
*Instance\Content=""
*Instance\ContentPresent=0
*Instance\ContentLevel=0
*Instance\StringFieldNr=0
*Instance\XMLVersion=""
*Instance\XMLWellFormed=0
ProcedureReturn *Instance
EndProcedure
The Examples
Code: Select all
;****************************************
;
; XML-RPC example TimeServer
; Author : Leo Mijnders
; Date : Nov 2004
;
;****************************************
XIncludeFile "OO_XMLRPC.pb"
Enumeration
#NOTWELLFORMED
#UNKNOWNMETHOD
#NOMETHODNAMETAG
#NOCONTENT
#TOMUCHPARAMETERS
#LASTENUM
EndEnumeration
; Global Errors.s
Dim Errors.s(#LASTENUM)
Errors(#NOTWELLFORMED)="XML not well formed"
Errors(#UNKNOWNMETHOD)="The methodName is unknown"
Errors(#NOMETHODNAMETAG)="There is no methodName tag"
Errors(#NOCONTENT)="There is no content"
Errors(#TOMUCHPARAMETERS)="This method has to much parameters"
Procedure FaultHandling(Error.l,ClientNaddr.l)
Response.XMLRPCSend=CreateInstance_XMLRPCSend()
*Response.XMLRPCSendInstance=Response
*Response\Server="Leo's TimeServer"
*Response\Fault=1
Response\OpenStruct()
Response\OpenMember("faultCode")
Response\AddInteger(Error)
Response\CloseMember()
Response\OpenMember("faultString")
Response\AddString(Errors(Error))
Response\CloseMember()
Response\CloseStruct()
Response\Submit(ClientNaddr)
FreeMemory(*Response)
CloseNetworkConnection(ClientNaddr)
EndProcedure
Procedure ProcessRequest(Buffer.l, Length.l, ClientNaddr.l)
Request.XMLRPCRecieve=CreateInstance_XMLRPCRecieve(Left(PeekS(Buffer),Length))
*Request.XMLRPCRecieveInstance=Request
Request\CheckWellFormed()
If *Request\XMLWellFormed
; MessageRequester("","Well Formed",0)
Request\FirstContent()
If *Request\ContentPresent
If *Request\Parse[1]\Tag="<methodName>"
If *Request\Content="currentTime.getCurrentTime"
Else
FaultHandling(#UNKNOWNMETHOD, ClientNaddr)
FreeMemory(*Request)
ProcedureReturn
EndIf
Else
FaultHandling(#NOMETHODNAMETAG, ClientNaddr)
FreeMemory(*Request)
ProcedureReturn
EndIf
Else
FaultHandling(#NOCONTENT, ClientNaddr)
FreeMemory(*Request)
ProcedureReturn
EndIf
Request\NextContent()
If *Request\ContentPresent
FaultHandling(#TOMUCHPARAMETERS, ClientNaddr)
FreeMemory(*Request)
ProcedureReturn
Else
FreeMemory(*Request)
Response.XMLRPCSend=CreateInstance_XMLRPCSend()
*Response.XMLRPCSendInstance=Response
*Response\Server="Leo's TimeServer"
Response\AddString(FormatDate("%yyyy%mm%ddT%hh:%ii:%ss",Date()))
Response\Submit(ClientNaddr)
FreeMemory(*Response)
CloseNetworkConnection(ClientNaddr)
EndIf
Else
FaultHandling(#NOTWELLFORMED, ClientNaddr)
FreeMemory(*Request)
ProcedureReturn
EndIf
EndProcedure
If InitNetwork() = 0
MessageRequester("Error", "Can't initialize the network !", 0)
End
EndIf
Port = Val(ProgramParameter())
Buffer = AllocateMemory(5000)
OpenConsole() ; First we must open a console
ConsoleTitle ("PureBasic - XML-RPC Server at port "+Str(Port)) ; Now we can give the opened console a Titlename ;)
Print("Press Esc to shut down the server !")
If CreateNetworkServer(Port)
Repeat
SEvent.l = NetworkServerEvent()
If SEvent
ClientID = NetworkClientID()
Select SEvent
Case 1
; MessageRequester("PureBasic - Server", "A new client has connected !", 0)
Case 2
; MessageRequester("PureBasic - Server", "Client "+Str(ClientID)+" has send a packet !", 0)
Length.l=ReceiveNetworkData(ClientID, Buffer, 5000)
; MessageRequester("Info", "String: "+PeekS(Buffer), 0)
ProcessRequest(Buffer, Length, ClientID)
Case 3
; MessageRequester("PureBasic - Server", "Client "+Str(ClientID)+" has send a file via the network !", 0)
; ReceiveNetworkFile(ClientID, "C:\TEST_Network.ftp3")
Case 4
; MessageRequester("PureBasic - Server", "Client "+Str(ClientID)+" has closed the connexion...", 0)
; Quit = 1
EndSelect
EndIf
EscPressed.s=Inkey()
If Asc(EscPressed)=27
Quit=1
EndIf
Until Quit = 1
; MessageRequester("PureBasic - Server", "Click to quit the server.", 0)
CloseNetworkServer()
Else
MessageRequester("Error", "Can't create the server (port in use ?).", 0)
EndIf
CloseConsole()
End
Code: Select all
;****************************************
;
; XML-RPC example TimeClient
; Author : Leo Mijnders
; Date : Nov 2004
;
;****************************************
XIncludeFile "OO_XMLRPC.pb"
InitNetwork()
Request.XMLRPCSend=CreateInstance_XMLRPCSend()
*Request.XMLRPCSendInstance=Request
;*Request\HostName="time.xmlrpc.com"
;*Request\HostPort=80
;*Request\HostName="localhost"
;*Request\HostPort=8000
*Request\HostName=ProgramParameter()
*Request\HostPort=Val(ProgramParameter())
*Request\HostUri="/RPC2"
*Request\MethodName="currentTime.getCurrentTime"
*Request\UserAgent="XML-RPC-For-PureBasic"
Result.s=Request\Submit(0)
If Result=""
MessageRequester("","No Response, possibly network error",0)
End
EndIf
Response.XMLRPCRecieve=CreateInstance_XMLRPCRecieve(Result)
*Response.XMLRPCRecieveInstance=Response
;MessageRequester("Response",*Response\Header,0)
;MessageRequester("Response",*Response\XMLBody,0)
Response\CheckWellFormed()
;MessageRequester("", Str(*Response\XMLWellFormed),0)
Response\FirstContent()
MessageRequester("Response",*Response\Content,0)
;MessageRequester("Response",Str(*Response\ContentLevel),0)
;MessageRequester("Response",*Response\Parse[*Response\ContentLevel-1]\Tag,0)
Repeat
Response\NextContent()
If *Response\ContentPresent=0
Break
EndIf
MessageRequester("Response", "Content : "+*Response\Content,0)
; MessageRequester("Response","ContentLevel : "+Str(*Response\ContentLevel),0)
; MessageRequester("Response","Content Tag : "+*Response\Parse[*Response\ContentLevel-1]\Tag,0)
Until #FALSE
MessageRequester("Response","No more Contents",0)
FreeMemory(*Request)
FreeMemory(*Response)
Code: Select all
;****************************************
;
; XML-RPC example TotalServer
; Author : Leo Mijnders
; Date : Nov 2004
;
;****************************************
XIncludeFile "OO_XMLRPC.pb"
Enumeration
#NOTWELLFORMED
#UNKNOWNMETHOD
#NOMETHODNAMETAG
#NOCONTENT
#NONAMEPARAMETER
#WRONGPARAMETER
#NOTHINGTOTOTALIZE
#LASTENUM
EndEnumeration
; Global Errors.s
Dim Errors.s(#LASTENUM)
Errors(#NOTWELLFORMED)="XML not well formed"
Errors(#UNKNOWNMETHOD)="The methodName is unknown"
Errors(#NOMETHODNAMETAG)="There is no methodName tag"
Errors(#NOCONTENT)="There is no content"
Errors(#NONAMEPARAMETER)="The name parameter is missing"
Errors(#WRONGPARAMETER)="The parameter is not allowed "
Errors(#NOTHINGTOTOTALIZE)="There is nothing to totalize"
Procedure FaultHandling(Error.l,ClientNaddr.l)
Response.XMLRPCSend=CreateInstance_XMLRPCSend()
*Response.XMLRPCSendInstance=Response
*Response\Server="Leo's TimeServer"
*Response\Fault=1
Response\OpenStruct()
Response\OpenMember("faultCode")
Response\AddInteger(Error)
Response\CloseMember()
Response\OpenMember("faultString")
Response\AddString(Errors(Error))
Response\CloseMember()
Response\CloseStruct()
Response\Submit(ClientNaddr)
FreeMemory(*Response)
CloseNetworkConnection(ClientNaddr)
EndProcedure
Procedure ProcessRequest(Buffer.l, Length.l, ClientNaddr.l)
Request.XMLRPCRecieve=CreateInstance_XMLRPCRecieve(Left(PeekS(Buffer),Length))
*Request.XMLRPCRecieveInstance=Request
Request\CheckWellFormed()
If *Request\XMLWellFormed
Request\FirstContent()
If *Request\ContentPresent
If *Request\Parse[1]\Tag="<methodName>"
If *Request\Content="CalculateTotal"
Else
FaultHandling(#UNKNOWNMETHOD, ClientNaddr)
FreeMemory(*Request)
ProcedureReturn
EndIf
Else
FaultHandling(#NOMETHODNAMETAG, ClientNaddr)
FreeMemory(*Request)
ProcedureReturn
EndIf
Else
FaultHandling(#NOCONTENT, ClientNaddr)
FreeMemory(*Request)
ProcedureReturn
EndIf
Name.s=""
Total.f=0.0
Nr.l=0
Repeat
Request\NextContent()
If *Request\ContentPresent=0
Break
ElseIf *Request\Parse[*Request\ContentLevel-1]\Tag="<name>"
Name=*Request\Content
ElseIf *Request\Parse[*Request\ContentLevel-1]\Tag="<double>"
Total+ValF(*Request\Content)
Nr+1
Else
FaultHandling(#WRONGPARAMETER, ClientNaddr)
FreeMemory(*Request)
ProcedureReturn
EndIf
Until #FALSE
If Name=""
FaultHandling(#NONAMEPARAMETER, ClientNaddr)
FreeMemory(*Request)
ProcedureReturn
EndIf
If Nr=0
FaultHandling(#NOTHINGTOTOTALIZE, ClientNaddr)
FreeMemory(*Request)
ProcedureReturn
EndIf
FreeMemory(*Request)
Response.XMLRPCSend=CreateInstance_XMLRPCSend()
*Response.XMLRPCSendInstance=Response
*Response\Server="Leo's TimeServer"
Response\OpenStruct()
Response\OpenMember("Total "+Name)
Response\AddDouble(Total,2)
Response\CloseMember()
Response\CloseStruct()
Response\Submit(ClientNaddr)
FreeMemory(*Response)
CloseNetworkConnection(ClientNaddr)
Else
FaultHandling(#NOTWELLFORMED, ClientNaddr)
FreeMemory(*Request)
ProcedureReturn
EndIf
EndProcedure
If InitNetwork() = 0
MessageRequester("Error", "Can't initialize the network !", 0)
End
EndIf
Port = Val(ProgramParameter())
Buffer = AllocateMemory(5000)
OpenConsole() ; First we must open a console
ConsoleTitle ("PureBasic - XML-RPC Server at port "+Str(Port)) ; Now we can give the opened console a Titlename ;)
Print("Press Esc to shut down the server !")
If CreateNetworkServer(Port)
Repeat
SEvent.l = NetworkServerEvent()
If SEvent
ClientID = NetworkClientID()
Select SEvent
Case 1
; MessageRequester("PureBasic - Server", "A new client has connected !", 0)
Case 2
; MessageRequester("PureBasic - Server", "Client "+Str(ClientID)+" has send a packet !", 0)
Length.l=ReceiveNetworkData(ClientID, Buffer, 5000)
; MessageRequester("Info", "String: "+PeekS(Buffer), 0)
ProcessRequest(Buffer, Length, ClientID)
Case 3
; MessageRequester("PureBasic - Server", "Client "+Str(ClientID)+" has send a file via the network !", 0)
; ReceiveNetworkFile(ClientID, "C:\TEST_Network.ftp3")
Case 4
; MessageRequester("PureBasic - Server", "Client "+Str(ClientID)+" has closed the connexion...", 0)
; Quit = 1
EndSelect
EndIf
EscPressed.s=Inkey()
If Asc(EscPressed)=27
Quit=1
EndIf
Until Quit = 1
; MessageRequester("PureBasic - Server", "Click to quit the server.", 0)
CloseNetworkServer()
Else
MessageRequester("Error", "Can't create the server (port in use ?).", 0)
EndIf
CloseConsole()
End
Code: Select all
;****************************************
;
; XML-RPC example TotalClient
; Author : Leo Mijnders
; Date : Nov 2004
;
;****************************************
XIncludeFile "OO_XMLRPC.pb"
InitNetwork()
Request.XMLRPCSend=CreateInstance_XMLRPCSend()
*Request.XMLRPCSendInstance=Request
Request\OpenStruct()
Request\OpenMember("Prices")
Request\OpenArray()
Request\AddDouble(14.2,2)
Request\AddDouble(16.7,2)
Request\AddDouble(13.8,2)
Request\AddDouble(17.1,2)
Request\CloseArray()
Request\CloseMember()
Request\CloseStruct()
*Request\HostName=ProgramParameter()
*Request\HostPort=Val(ProgramParameter())
*Request\HostUri="/RPC2"
*Request\MethodName="CalculateTotal"
*Request\UserAgent="XML-RPC-For-PureBasic"
Result.s=Request\Submit(0)
If Result=""
MessageRequester("","No Response, possibly network error",0)
End
EndIf
Response.XMLRPCRecieve=CreateInstance_XMLRPCRecieve(Result)
*Response.XMLRPCRecieveInstance=Response
;MessageRequester("Response",*Response\Header,0)
;MessageRequester("Response",*Response\XMLBody,0)
Response\CheckWellFormed()
;MessageRequester("", Str(*Response\XMLWellFormed),0)
Response\FirstContent()
MessageRequester("Response",*Response\Content,0)
;MessageRequester("Response",Str(*Response\ContentLevel),0)
;MessageRequester("Response",*Response\Parse[*Response\ContentLevel-1]\Tag,0)
Repeat
Response\NextContent()
If *Response\ContentPresent=0
Break
EndIf
MessageRequester("Response", "Content : "+*Response\Content,0)
; MessageRequester("Response","ContentLevel : "+Str(*Response\ContentLevel),0)
; MessageRequester("Response","Content Tag : "+*Response\Parse[*Response\ContentLevel-1]\Tag,0)
Until #FALSE
MessageRequester("Response","No more Contents",0)
FreeMemory(*Request)
FreeMemory(*Response)
