gambas-source-code/gb.xml/gb.xml.rpc/.src/RpcClient.class
2017-07-30 13:14:48 +02:00

372 lines
7.4 KiB
Text

' Gambas class file
'***************************************************************************
'
' RpcClient.class
'
' (c)2005 - Daniel Campos Fernández
'
' XML-RPC Component
'
' Realizado para la Junta de Extremadura.
' Consejería de Educación Ciencia y Tecnología.
' Proyecto gnuLinEx
'
' This program Is free software; you can redistribute it And / Or modify
' it under the terms OF the GNU General PUBLIC License AS published by
' the Free Software Foundation; either version 1, Or (at your option)
' any later version.
'
' This program Is distributed IN the hope that it will be useful,
' but WITHOUT ANY WARRANTY; WITHOUT even the implied WARRANTY OF
' MERCHANTABILITY Or FITNESS FOR A PARTICULAR PURPOSE.See the
' GNU General PUBLIC License FOR more details.
'
' You should have received a COPY OF the GNU General PUBLIC License
' along WITH this program; IF Not, WRITE TO the Free Software
' Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
'
'***************************************************************************
Export
Private Method As RpcFunction
Private hHttp As HPost
Private hMode As Integer
Private sUrl As String
Private isFault As Boolean
Public Const offLine As Integer = 0
Public Const httpSync As Integer = 1
Public Const httpAsync As Integer = 2
Property Mode As Integer
Property URL As String
Property Read RpcMethod As RpcFunction
Event Reply(Data As Variant)
Event BadReply(Code As String)
Sub URL_Write(Vl As String)
If hHttp Then
If hHttp.Http.Status > 0 Then
Error.Raise("Still active")
Return
End If
End If
If hHttp Then hHttp = Null
sURL = Trim(Vl)
End
Function URL_Read() As String
Return sURL
End
Sub Mode_Write(Vl As Integer)
If hHttp Then
If hHttp.Http.Status > 0 Then
Error.Raise("Still active")
Return
End If
End If
If vl >= 0 And vl < 3 Then
hMode = vl
End If
If vl = 0 Then hHttp = Null
End
Function Mode_Read() As Integer
Return hMode
End
Function RpcMethod_Read() As RpcFunction
Return Method
End
Public Sub _New(remoteFunction As RpcFunction)
hMode = RpcClient.httpSync
If remoteFunction = Null Then Error.Raise("Invalid RpcFunction object")
Method = remoteFunction
End
Private Function testXML(sCad As String) As Integer
Dim Xml As New XmlReader
Try Xml.FromString(sCad)
If Error Then Return 1
Do While Not Xml.Eof
Try Xml.Read()
If Error Then Return 1
If Not Xml.Eof Then
If Xml.Node.Type = XmlReaderNodeType.Element Then
Select Case Xml.Node.Name
Case "methodResponse"
Case "fault"
Case "params"
Case "param"
Case "i4"
Case "int"
Case "boolean"
Case "string"
Case "double"
Case "dateTime.iso8601"
Case "base64"
Case "struct"
Case "array"
Case "data"
Case "member"
Case "value"
Case "name"
Default
Return 2
End Select
End If
End If
Loop
Return 0
End
Public Function EvalReply(sCad As String) As Variant
Dim hAtom As RpcAtom
If hHttp Then
If hHttp.Http.Status > 0 Then
Error.Raise("Still active")
Return
End If
End If
Try hAtom = extractReply(sCad)
If Error Then
Error.Raise(Error.Text)
Return Null
End If
If isFault Then
'//TODO ERROR
Error.Raise("server")
Return Null
End If
If hAtom = Null Then
If Method.ReturnType = Null Then Return Null
Error.Raise("Invalid return type, wanted VOID, got " & XmlRpc.ToString(hAtom.Type))
End If
If Method.ReturnType <> hAtom.Type Then
Error.Raise("Invalid return type, wanted " & XmlRpc.ToString(Method.ReturnType) & ", got " & XmlRpc.ToString(hAtom.Type))
Return
End If
Return hAtom.Data
End
Private Function extractReply(sCad As String) As RpcAtom
Dim Xml As New XmlReader
Dim hAtom As RpcAtom
isFault = False
Select Case testXML(sCad)
Case 1
Error.Raise("Invalid XML data")
Return Null
Case 2
Error.Raise("Invalid XML-RPC format")
Return Null
End Select
Xml.FromString(sCad)
If Tools.Find(Xml, "methodResponse") = False Then
Error.Raise("Invalid XML-RPC format")
Return Null
End If
Do While True
If Not Xml.Eof Then Xml.Read()
If Xml.Eof Then Break
If Xml.Node.Type = XmlReaderNodeType.Element Then
Select Case Xml.Node.Name
Case "params"
Do While True
Xml.Read()
Select Case Xml.Node.Type
Case XmlReaderNodeType.EndElement
Return Null
Case XmlReaderNodeType.Element
If Xml.Node.Name = "param" Then
Xml.Read()
hAtom = Tools.GetParam(Xml)
If hAtom = Null Then
Error.Raise("Invalid XML-RPC format")
Return Null
End If
Return hAtom
Else
Error.Raise("Invalid XML-RPC format")
Return Null
End If
End Select
Loop
Case "fault"
isFault = True
Default
Break
End Select
End If
Loop
Error.Raise("Invalid XML-RPC format")
Return Null
End
Public Sub hHttp_GotData(Data As String)
Dim Dt As Variant
If Last = Null Then
Error.Raise("Invalid method call")
Return
End If
If Me.Mode = RpcClient.httpAsync Then
Try Dt = EvalReply(Data)
If Error Then
Raise BadReply(Error.Text)
Return
End If
Raise Reply(Dt)
End If
End
Public Sub hHttp_GotError()
If Last = Null Then
Error.Raise("Invalid method call")
Return
End If
If Me.Mode = RpcClient.httpAsync Then Raise BadReply("Unable to contact server, or bad reply from server")
End
Public Function Call(Data As Variant[]) As Variant
Dim Xml As New XmlWriter
Dim Bucle As Integer
Dim sCad As String
Dim sData As String
If hHttp Then
If hHttp.Http.Status > 0 Then
Error.Raise("Still active")
Return
End If
End If
If Method = Null Then
Error.Raise("Invalid RpcFunction object")
Return
End If
If Data = Null Then
If Method.Count <> 0 Then
Error.Raise("Wrong parameters number")
Return
End If
Else
If Method.Count <> Data.Count Then
Error.Raise("Wrong parameters number")
Return
End If
End If
Xml.Open("")
Xml.StartElement("methodCall")
Xml.Element("methodName", Method.MethodName)
Xml.StartElement("params")
For Bucle = 0 To Method.Count - 1
Xml.StartElement("param")
If Not Tools.AddValue(Xml, Data[Bucle], Method[Bucle]) Then
Xml.EndDocument()
Error.Raise("Invalid parameter " & Bucle + 1 & " Type : " & XmlRpc.ToString(Method[Bucle]))
Return
End If
Xml.EndElement()
Next
Xml.EndElement()
If hMode = RpcClient.offline Then Return Xml.EndDocument()
If sURL = "" Then
Error.Raise("Invalid URL")
Return
End If
If hHttp = Null Then hHttp = New HPost(sURL) As "hHttp"
If hMode = RpcClient.httpSync Then
hHttp.Mode = False
Else
hHttp.Mode = True
End If
sData = Xml.EndDocument()
If Right(sData) <> "\n" Then sData &= "\n"
sData = Replace(sData, "\n", "\r\n")
sCad = hHttp.PostData(sData)
If hMode = RpcClient.httpSync Then
If sCad = "" Then
Error.Raise("Unable to contact server, or bad reply from server")
Return Null
End If
Return EvalReply(sCad)
End If
Return Null
End