VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "CXMLRPCRequest"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Public Sub decodeResponse(ByRef xml As MSXML2.DOMDocument, ByRef argv As Variant, ByRef fault As Boolean)
    Dim nodes As MSXML2.IXMLDOMNodeList
    Dim av As New CAssocItem

    Set nodes = xml.selectNodes("/methodResponse/fault/value/*")

    If nodes.length() > 0 Then
        fault = True
        Set av = decodeData(nodes.item(0))
    Else
        fault = False
        Set nodes = xml.selectNodes("/methodResponse/params/param/value/*")
        
        If nodes.length() > 0 Then
            Set av = decodeData(nodes.item(0))
        Else
            Call Err.Raise(-1, , "Invalid XML response.")
        End If
    End If

    If IsObject(av.value) Then
        Set argv = av.value
    Else
        argv = av.value
    End If

    Set nodes = Nothing
    Set av = Nothing
End Sub

Private Function decodeData(ByRef node As MSXML2.IXMLDOMNode) As CAssocItem
    Dim i As Long
    Dim nodes As MSXML2.IXMLDOMNodeList
    Dim key As String
    Dim value As CAssocItem
    Dim itime As New CInetTime
    Dim b64 As New CBase64

    Set decodeData = New CAssocItem

    If node.nodeName = "array" Then
        Set nodes = node.selectNodes("data/value")
        Set decodeData.value = New Collection

        For i = 0 To nodes.length() - 1
            Set value = decodeData(nodes.item(i).firstChild)
            Call decodeData.value.Add(value.value)
        Next
    ElseIf node.nodeName = "struct" Then
        Set nodes = node.selectNodes("member")
        Set decodeData.value = New CAssocArray

        For i = 0 To nodes.length() - 1
            key = nodes.item(i).selectSingleNode("name/text()").nodeValue
            Set value = decodeData(nodes.item(i).selectSingleNode("value/*"))
            Call decodeData.value.Add(key, value.value)
        Next
    ElseIf node.nodeName = "boolean" Or node.nodeName = "int" Or node.nodeName = "i4" Then
        decodeData.value = node.selectSingleNode("text()").nodeValue
    ElseIf node.nodeName = "double" Then
        decodeData.value = node.selectSingleNode("text()").nodeValue
    ElseIf node.nodeName = "dateTime.iso8601" Then
        decodeData.value = itime.InternetTimeToVbLocalTime(node.selectSingleNode("text()").nodeValue)
    ElseIf node.nodeName = "base64" Then
        decodeData.value = b64.DecodeBase64(node.selectSingleNode("text()").nodeValue)
    ElseIf node.nodeName = "string" Then
        decodeData.value = CStr(node.selectSingleNode("text()").nodeValue)
    Else
        Call Err.Raise("Unknown type.", , -1)
    End If
    
    Set itime = Nothing
    Set b64 = Nothing
    Set nodes = Nothing
    Set value = Nothing
End Function

Public Sub encodeRequest(ByVal method As String, ByRef request As Variant, ByRef xml As String)
    Dim av As New CAssocItem

    If IsObject(request) Then
        Set av.value = request
    Else
        av.value = request
    End If

    xml = "<?xml version=""1.0"" encoding=""utf-8""?>" & _
        "<methodCall>" & _
            "<methodName>" & escapeXMLString(method) & "</methodName>" & _
            "<params><param><value>" & _
                encodeData(av) & _
            "</value></param></params>" & _
        "</methodCall>"
    Set av = Nothing
End Sub

Private Function encodeData(ByRef item As CAssocItem) As String
    Dim itime As New CInetTime
    Dim av As New CAssocItem
    Dim v As Variant
    Dim b64 As CBase64
    Dim itemType As VariantTypeConstants
    Dim itemObjType As String
    
    itemType = VarType(item.value)
    
    If itemType = vbObject Then
        itemObjType = TypeName(item.value)

        If itemObjType = "CAssocArray" Then
            encodeData = "<struct>"

            For Each av In item.value
                encodeData = encodeData & "<member>" & _
                        "<name>" & escapeXMLString(av.key) & "</name>" & _
                        "<value>" & encodeData(av) & "</value>" & _
                    "</member>"
            Next

            encodeData = encodeData & "</struct>"
        ElseIf itemObjType = "Collection" Then
            encodeData = "<array><data>"

            For Each v In item.value
                av.value = v
                encodeData = encodeData & "<value>" & encodeData(av) & "</value>"
            Next

            encodeData = encodeData & "</data></array>"
        Else
            Call Err.Raise(-1, , "Unsupported object type: " + itemObjType)
        End If
    ElseIf itemType = vbBoolean Then
        encodeData = "<i4>" & IIf(item.value, "1", "0") & "</i4>"
    ElseIf itemType = vbInteger Or itemType = vbLong Then
        encodeData = "<i4>" & Trim(CStr(item.value)) & "</i4>"
    ElseIf itemType = vbSingle Or itemType = vbDouble Then
        encodeData = "<double>" & Trim(CStr(item.value)) & "</double>"
    ElseIf itemType = vbDate Then
        encodeData = "<dateTime.iso8601>" & _
            escapeXMLString(itime.VbLocalTimeToInternetTime(item.value, "iso8601")) & _
            "</dateTime.iso8601>"
    ElseIf itemType = vbString Or itemType = vbCurrency Or itemType = vbDecimal Then
        encodeData = "<string>" & escapeXMLString(item.value) & "</string>"
'    ElseIf itemType = vbByte + vbArray Then
'        encodeData = b64.EncodeBase64(item.value)
'' !!!!!!!!! Base64 not supported
    Else
        Call Err.Raise(-1, , "Unknown type: " + CStr(itemType))
    End If

    Set v = Nothing
End Function

Private Function escapeXMLString(str As String)
    str = Replace(str, "&", "&amp;")
    str = Replace(str, "<", "&lt;")
    str = Replace(str, ">", "&gt;")
    str = Replace(str, Chr(34), "&quot;")
    escapeXMLString = Replace(str, "'", "&apos;")
End Function

Public Function doCall(url As String, method As String, ByRef params As Variant, ByRef result As Variant) As Boolean
    Dim http As New MSXML2.XMLHTTP
    Dim xml As String

    Call encodeRequest(method, params, xml)
    Call http.Open("POST", url, False)
    Call http.send(xml)

    If http.Status <> 200 Then
        Set http = Nothing
        doCall = False
        Call Err.Raise(-1, , "Ошибка зароса на сервер XML-RPC.")
    End If

    Call decodeResponse(http.responseXML, result, doCall)
    Set http = Nothing
End Function