372 lines
7.4 KiB
Text
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
|
|
|