option explicit

const dtNumber = 1
const dtString = 2
const dtDate = 3
const dtBool = 4
const dtRecordset = 5
const dtVString = 6
const dtDateTime = 7

dim nInvocationCount

nInvocationCount = 0

function GetPath(path)
	dim arr
	arr = split(window.location.href, "/", 5, 1)
	GetPath = arr(0) & "//" & arr(2) & "/" & arr(3) & "/" & path
end function

function GetType(value)
	GetType = GetType2(value, 0)
end function

function GetType2(value, valueType)
	select case VarType(value)
		case vbInteger
			GetType2 = "Int"
		case vbLong
			GetType2 = "i4"
		case vbSingle
			GetType2 = "r4"
		case vbDouble, vbDecimal
			GetType2 = "r8"
		case vbCurrency
			GetType2 = "Fixed.14.4"
		case vbDate
			GetType2 = "Date"
			if valueType = 7 then
				GetType2 = "dateTime"
			end if
		case vbString
			GetType2 = "string"
		case vbBoolean
			GetType2 = "Boolean"
		case vbByte
			GetType2 = "i1"
		case vbNull
			GetType2 = "int"
		case else
			GetType2 = "string"		
	end select
end function

function SetVarType(value, dt)
	if not IsNull(value) then
		select case dt
			case dtNumber
				if value <> "" then 
					SetVarType = CDbl(value)
				else
					SetVarType = null
				end if
			case dtString
				SetVarType = CStr(value)
			case dtDate, dtDateTime
				if value <> "" then 
					SetVarType = CDate(value)
				else
					SetVarType = null
				end if
			case dtBool
				if value <> "" then 
					SetVarType = CBool(value)
				else
					SetVarType = null
				end if
			case dtVString
				SetVarType = value
		end select
	else
		SetVarType = value
	end if
end function

sub SetVarTypes(values, types)
	dim i
	for i = 0 to UBound(values)
		if not IsArray(types(i)) then
			if types(i) <> dtRecordset then
				values(i) = SetVarType(values(i), types(i))
			end if
		else
			SetVarTypes values(i), types(i)
		end if
	next
end sub

function GetTypeArr(arr, dt)
	dim i, arrType()
	if IsArray(arr) then
		redim arrType(UBound(arr))
		for i = 0 to UBound(arr)
			arrType(i) = dt
		next
		GetTypeArr = arrType
	else
		GetTypeArr = dt
	end if
end function

Function UnmarshalArray(node)
	dim arr(), subNode, i, stream
	if node.childNodes.length > 0 then
		redim arr(node.childNodes.length-1)
		i = 0
		set subNode = node.firstChild
		while not subNode is nothing
			if subNode.nodeName = "Recordset" then
				if subNode.Text <> "nothing" then
					dim rs
					set stream = CreateObject("ADODB.Stream")
					set rs = CreateObject("ADODB.Recordset")
					stream.Open()
					stream.WriteText subNode.Text
					stream.Position = 0
					rs.Open stream
					set arr(i) = rs		
				else
					set arr(i) = nothing
				end if
			elseif subNode.nodeName = "Stream" then
				set stream = CreateObject("ADODB.Stream")
				stream.Type = 1
				stream.Open()
				stream.Write subNode.nodeTypedValue
				stream.Position = 0
				set arr(i) = stream
			elseif subNode.nodeName = "Array" then
				arr(i) = UnmarshalArray(subNode)
			else
				arr(i) = subNode.nodeTypedValue
			end if
			i = i + 1
			set subNode = subNode.nextSibling
		wend
		UnmarshalArray = arr
	else
		UnmarshalArray = null
	end if
End Function

' *** CRemoteObject ***
Class CRemoteObject
	Private Sub Class_Initialize()
		set xmlhttp = CreateObject("Msxml2.XMLHTTP")
		set xmldom = CreateObject("Msxml2.DOMDocument")
		xmldom.preserveWhiteSpace = true
		bAsync = False
	End Sub
	
	Public Sub Init(objName, server)
		sObject = objName	' DEBUG
		url = GetPath("common/remote.asp")
		set root = xmldom.createElement(objName)
		set xmldom.documentElement = root
		root.setAttribute "xmlns:dt", "urn:schemas-microsoft-com:datatypes"	' datatype schema
		root.setAttribute "MLCountry", ""
	End Sub

	Public Sub UseSSL(bUse)
		if bUse then
			url = Replace(url, "http://", "https://")
		else
			url = Replace(url, "https://", "http://")
		end if
	End Sub
	
	Public Sub Async(fxn)
		Reset()
		bAsync = True
		xmlhttp.onreadystatechange = fxn
	End Sub

	Public Sub Method(name, parameters)
		Method2 name, parameters, Array()
	End Sub

	Public Sub Method2(name, parameters, types)
		Dim i, oNode, oMethod, arrParam, arrTypes, valueType
		sMethod = name		' DEBUG
		bAsync = False
        Reset()
		'root.setAttribute "MLCountry", ""
		while not root.firstChild is nothing
			root.removeChild root.firstChild
		wend
		set oNode = xmldom.createElement(name)
		set oMethod = root.appendChild(oNode)
		
		if IsArray(parameters) then arrParam = parameters else arrParam = Array(parameters)
		if IsArray(types) then arrTypes = types else arrTypes = Array(types)
		for i = 0 to UBound(arrParam)
			if IsObject(arrParam(i)) then
				' node with recodset in Text attribute
				set oNode = xmldom.createElement("Recordset")
				MarshalRecordset oNode, arrParam(i)
			elseif IsArray(arrParam(i)) then
				' subnode for array
				set oNode = xmldom.createElement("Array")
				oNode.setAttribute "xmlns:dt", "urn:schemas-microsoft-com:datatypes"
				MarshalArray oNode, arrParam(i)
			else
				set oNode = xmldom.createElement("Parameter")
				if IsNull(oNode.dataType) then 
					if UBound(arrTypes) >= 0 then 'array contains something
						valueType = arrTypes(i)
					else
						valueType = 0
					end if

					oNode.dataType = GetType2(arrParam(i), valueType)
				end if
				oNode.nodeTypedValue = arrParam(i)
			end if
			oMethod.appendChild oNode
		next

        SetSecurityCtx()
	End Sub

	Public Sub MethodEx(name, parameters, types)
		Dim i, oNode, oMethod, arrTypes, arrParam
		' transform to arrays
		if IsArray(parameters) then arrParam = parameters else arrParam = Array(parameters)
		if IsArray(types) then arrTypes = types else arrTypes = Array(types)
		' set Var Types
		SetVarTypes arrParam, arrTypes
		' create XML
		Method2 name, arrParam, arrTypes
	End Sub
	
    Private Sub SetSecurityCtx()
        Dim oCtx, oNode
		on error resume next
        set oCtx = CurrentSecurityCtx()
		if Err.Number <> 0 then
            set oCtx = nothing
            Err.Clear
        end if
        if not oCtx is nothing then
            set oNode = xmldom.createElement("security")
		    oNode.text = oCtx.CTX
		    oNode.setAttribute "SID", oCtx.SID
		    oNode.setAttribute "UserName", oCtx.UserName
            root.appendChild oNode
        end if
    End Sub

	Public Sub SetCountry(country)
		root.setAttribute "MLCountry", country
	End Sub

	Public Sub MethodML(name, parameters, country)
		Method name, parameters
		SetCountry country
	End Sub

	Public Sub MethodMLEx(name, parameters, types, country)
		MethodEx name, parameters, types
		SetCountry country
	End Sub

	Public Function ReturnRecordset()
		Dim node
		set node = xmldom.createElement("ResultType")
		node.text = "Recordset"
		root.appendChild node
		Execute
		if not bAsync then 
			set ReturnRecordset = GetRecordset()
		else
			set ReturnRecordset = nothing
		end if
	End Function

	Public Function ReturnValue()
		Dim node
		set node = xmldom.createElement("ResultType")
		node.text = "Value"
		root.appendChild node
		Execute
		if not bAsync then 
			ReturnValue = GetValue()
		else
			ReturnValue = null
		end if
	End Function
	
	Public Function ReturnValueEx(valType)
		Dim oNode
		set oNode = xmldom.createElement("ResultType")
		oNode.text = "Value"
		oNode.setAttribute "dt", valType
		root.appendChild oNode
		Execute
		if not bAsync then 
			ReturnValue = GetValue()
		else
			ReturnValue = null
		end if
	End Function
	
	Public Function ReturnArray(types)
		Dim i, oNode, oType
		set oNode = xmldom.createElement("ResultType")
		oNode.text = "Array"
		root.appendChild oNode
		for i = 0 to UBound(types)
			set oType = xmldom.createElement("Type")
			oType.setAttribute "dt", types(i)
			oNode.appendChild oType
		next
		Execute
		if not bAsync then 
			ReturnArray = GetArray()
		else
			ReturnArray = null
		end if
	End Function

	Public Function ReturnStream()
		Dim i, oNode
		set oNode = xmldom.createElement("ResultType")
		oNode.text = "Stream"
		root.appendChild oNode
		Execute
		if not bAsync then 
			set ReturnStream = GetStream()
		else
			set ReturnStream = nothing
		end if
	End Function

	Public Function GetRecordset()
		if xmlhttp.getResponseHeader("ErrNumber") <> "" then
			ShowError()
			set GetRecordset = nothing
		else
			if xmlhttp.status = 200 then
				dim stream, rs
				set stream = CreateObject("ADODB.Stream")
				if IsArray(xmlhttp.ResponseBody) then			'not empty response
					if UBound(xmlhttp.ResponseBody) > 50 then	'more then ASP DEBUG
						set rs = CreateObject("ADODB.Recordset")
						stream.Type = 1 'adTypeBinary
						stream.Open()
						stream.Write xmlhttp.ResponseBody
						stream.Position = 0
						rs.Open stream
					else
						set rs = nothing
					end if
				else
					set rs = nothing
				end if
				on error resume next
				if Err.Number <> 0 then
					errStr = Err.Description & vbCrLf & "Error:" & Err.Number
					alert errStr
					Err.Clear
					set GetRecordset = nothing
				else
					set GetRecordset = rs
				end if
			else
				if xmlhttp.status <> 0 then alert xmlhttp.statusText
				set GetRecordset = nothing
			end if
		end if
	End Function

	Public Function GetValue()
		if xmlhttp.getResponseHeader("ErrNumber") <> "" then
			ShowError()
			GetValue = null
		else
			if xmlhttp.status = 200 then
				Dim xml, oRoot, oNode, text, index, bLoad
				set xml = CreateObject("Msxml2.DOMDocument")
				text = xmlhttp.ResponseText
				index = InStr(text, "<xml")
				if index <> 0 then text = Mid(text, index, Len(text))
				bLoad = xml.loadXML(text)
				if bLoad then
					set oRoot = xml.firstChild
					set oNode = oRoot.firstChild
					if oNode.nodeName = "result" then
						' GetValue = oNode.text
						GetValue = oNode.nodeTypedValue
					else
						GetValue = null
					end if
				else
					GetValue = null
				end if
			else
				if xmlhttp.status <> 0 then alert xmlhttp.statusText
				GetValue = null
			end if		
		end if		
	End Function

	Public Function GetArray()
		if xmlhttp.getResponseHeader("ErrNumber") <> "" then
			ShowError()
			GetArray = null
		else
			if xmlhttp.status = 200 then
				Dim xml, retRoot, retNode, text, index, bLoad
				set xml = CreateObject("Msxml2.DOMDocument")
				text = xmlhttp.ResponseText
				index = InStr(text, "<xml")
				if index <> 0 then text = Mid(text, index, Len(text))
				bLoad = xml.loadXML(text)
				if bLoad then
					set retRoot = xml.firstChild
					set retNode = retRoot.firstChild
					if retNode.nodeName = "result" then
						GetArray = UnmarshalArray(retNode)
					else
						GetArray = null
					end if
				else
					GetArray = null
				end if
			else
				if xmlhttp.status <> 0 then alert xmlhttp.statusText
				GetArray = null
			end if		
		end if		
	End Function
	
	Public Function GetStream()
		if xmlhttp.getResponseHeader("ErrNumber") <> "" then
			ShowError()
			set GetStream = nothing
		else
			if xmlhttp.status = 200 then
			    'response contains either array of bytes (binary stream) or an XML file
			    'which is distinguished by the Content-Type header
			    if xmlhttp.getResponseHeader("Content-Type") = "application/xml" then
                    set GetStream = xmlhttp.responseXML
                    exit function
                end if
				dim oStream, txt
				set oStream = CreateObject("ADODB.Stream")
				oStream.Type = 1 'adTypeBinary
				oStream.Open()
				if not IsEmpty(xmlhttp.ResponseBody) then
				    oStream.Write xmlhttp.ResponseBody
					on error resume next
					txt = xmlhttp.ResponseText
					if err.number = 0 then
                        on error goto 0
						if Left(txt, 4) = "<!--" then	' DEBUG
							dim oCopy
							set oCopy = CreateObject("ADODB.Stream")
							oCopy.Type = 1 'adTypeBinary
							oCopy.Open() 
							oStream.Position = InStr(txt, "-->") + 4
							oStream.CopyTo oCopy
							set GetStream = oCopy
						else
							set GetStream = oStream
						end if
					else
						set GetStream = oStream
					end if
				else
					set GetStream = oStream
				end if
			else
				if xmlhttp.status <> 0 then alert xmlhttp.statusText
				set GetStream = nothing
			end if
		end if
	End Function

	Private Sub MarshalRecordset(node, rs)
		Dim stream
		if not rs is nothing then
			set stream = CreateObject("ADODB.Stream")
			'stream.Type = 1
			'rs.Save stream, 0
			'stream.Position = 0
			'node.dataType = "bin.base64"
			'node.nodeTypedValue = stream.Read			
			rs.Save stream, 1
			stream.Position = 0
			node.Text = stream.ReadText
		else
			node.Text = "nothing"
		end if
	End Sub

	Private Sub MarshalArray(oNode, arr)
		dim i, oSubNode
		for i = 0 to UBound(arr)			
			if IsObject(arr(i)) then
				set oSubNode = xmldom.createElement("Recordset")
				MarshalRecordset oSubNode, arr(i)
			elseif IsArray(arr(i)) then
				set oSubNode = xmldom.createElement("SubArr")
				MarshalArray oSubNode, arr(i)
			else
				set oSubNode = xmldom.createElement("Value")
				if IsNull(oSubNode.dataType) then oSubNode.dataType = GetType(arr(i))
				oSubNode.nodeTypedValue = arr(i)
			end if
			oNode.appendChild oSubNode
		next
	End Sub

	Public Sub Execute()
		Wait true
		xmlhttp.open "POST", url, bAsync
		Debug "Execute"
		on error resume next
		xmlhttp.send xmldom	
		if Err.Number <> 0 then 
			MsgBox "Remote call error: " & Err.Description, vbExclamation
			Err.Clear
		end if
		Wait false
	End Sub

	Private Sub Wait(bWait)
		Dim oWait
		if bWait then
			nInvocationCount = nInvocationCount + 1
			if nInvocationCount = 1 then 
				window.status = "Wait please..."	
				on error resume next
				Set oWait = CreateObject("Orisales.WaitCursor")
				if Err.Number = 0 then 
					oWait.SetWaitCursor true
				else
					Err.Clear
				end if
				on error goto 0
			end if
		else
			nInvocationCount = nInvocationCount - 1
			if nInvocationCount = 0 then 
				window.status = "Ready"	
				on error resume next
				Set oWait = CreateObject("Orisales.WaitCursor")
				if Err.Number = 0 then 
					oWait.SetWaitCursor false
				else
					Err.Clear
				end if
				on error goto 0
			end if
		end if
	End Sub
	
	Private Sub ShowError()
		dim errStr, errDetail, errDscr, i, sServer
		'errDscr = xmlhttp.getResponseHeader("ErrDescription")
		errDscr = xmlhttp.ResponseText
		if xmlhttp.getResponseHeader("ServerIP") <> "" then
		    sServer = vbCrLf & "Server: " & xmlhttp.getResponseHeader("ServerIP") & " Time: " & xmlhttp.getResponseHeader("ServerTime")
		end if
		i = InStr(errDscr, "-->")
		if i > 0 then errDscr = Mid(errDscr, i + 5)
		errDetail =  Replace(errDscr, " | ", vbCrLf)
		if InStr(errDetail, vbCrLf) > 0 then
			errStr = Left(errDetail, InStr(errDetail, vbCrLf)-1)
		else
			errStr = errDetail
		end if
		if MsgBox(errStr & sServer & vbCrLf & "Show details?", vbExclamation+vbYesNo+vbDefaultButton2, "Orisales") = vbYes then
			MsgBox errDetail & sServer, vbExclamation, "Orisales"
		end if
	End Sub
	
	Private Sub Reset()
		xmlhttp.abort()
		set xmlhttp = nothing
		set xmlhttp = CreateObject("Msxml2.XMLHTTP")
	End Sub
	
	Private Sub Debug(sDbg)	'DEBUG
		dim sText
		sText = sObject & "." & sMethod
		sText = sText & " (" & FormatDateTime(Now(), 3) & ") - "
		sText = sText & sDbg
        if sMethod <> "TraceClientCall" then
		    window.status = sText
        end if
	End Sub

	Private url
	Private xmldom
	Private root
	Private bAsync
	
	Private sObject
	Private sMethod
	
	Public xmlhttp
end class