xmlrpc.asp

xml文件处理源代码。asp编写

<% 
' David Carter-Tod, [e-mail], June 1999
	' This code is covered by the GNU GPL, http:\//www.opensource.org/licenses/gpl-license.html
' One major issue I am still concerned about is the destruction of Dictionary
	' objects which are created when a struct is returned by the remote function
	' since the function passes around pointers (not deeply tested yet, mind you)
	' the Dictionary object still needs to be set to nothing at some point, doesn't it?
' ----- Client and Server functions -----
Dim xmlText, serverResponseText
sub addTxt(txt)
	xmlText=xmlText & txt & vbNewline
	end sub
function dateToText(el)
	el = CStr(el)
	if Len(el)=1 then
		el = "0" & el
		end if
	dateToText = el
	end function
sub addItem(itm)
	addTxt "<value>"
	Select Case VarType(itm)
		Case vbEmpty
			addTxt "<string></string>"
		Case vbNull
			addTxt "<string></string>"
		Case vbInteger
			addTxt "<i4>" & itm & "</i4>"
		Case vbLong
			addTxt "<i4>" & itm & "</i4>"
		Case vbSingle
			addTxt "<double>" & itm & "</double>"
		Case vbDouble
			addTxt "<double>" & itm & "</double>"
		Case vbCurrency
			addTxt "<double>" & itm & "</double>"
		Case vbDate
			addTxt "<dateTime.iso8601>" & Year(itm) & dateToText(Month(itm)) & dateToText(Day(itm)) & "T" & dateToText(Hour(itm)) & ":" & dateToText(Minute(itm)) & ":" & dateToText(Second(itm))  & "</dateTime.iso8601>"
		Case vbString
			itm = Replace(itm, "<", "&lt;", 1, -1, 1)
			itm = Replace(itm, "&", "&amp;", 1, -1, 1)
			addTxt "<string>" & itm  & "</string>"
		Case vbObject
			if TypeName(itm)="Dictionary" then
				addTxt "<struct>"
				Dim a, b
				a=itm.keys
				b=itm.items
				for x = 0 to itm.count-1
					addTxt "<member>"
					addTxt "<name>" & a(x) & "</name>"
					addItem b(x)
					addTxt "</member>"
					next
				addTxt "</struct>"
			elseif TypeName(itm)="Recordset" then
				addTxt "<array>"
				addTxt "<data>"
				Do While Not itm.EOF
					addTxt "<struct>"
					for each whatever in itm.fields
						addTxt "<member>"
						addTxt "<name>" & whatever.name & "</name>"
						addItem whatever.value
						addTxt "</member>"
					next
					addTxt "</struct>"
					itm.MoveNext
					Loop
				addTxt "</data>"
				addTxt "</array>"
			else
				addTxt "<base64>"
				set base64=Server.createObject("Base64Lib.Base64")
				addItem base64.Encode(itm)
				set base64=nothing
				addTxt "</base64>"
			end if
		Case vbBoolean
			addTxt "<boolean>" & -1*CInt(itm) & "</boolean>"
		Case vbByte
			addTxt "<int>" & CInt(itm) & "</int>"
		Case Else
			if VarType(itm)>vbArray then
				addTxt "<array>"
				addTxt "<data>"
				for x = 0 to Ubound(itm, 1)-1
					addItem itm(x)
					next
				addTxt "</data>"
				addTxt "</array>"
			else
				itm = Replace(Cstr(itm), "<", "&lt;", 1, -1, 1)
				itm = Replace(itm, "&", "&amp;", 1, -1, 1)
				addTxt "<string>" & itm  & "</string>"
			end if
		'Not covered: vbError, vbVariant, vbDataObject
		End Select
	addTxt "</value>"
	end sub
function XMLToValue(xmlNd)
	Dim val
	if NOT xmlNd.childNodes(0).nodeType = 3 then
	Select Case xmlNd.childNodes(0).tagName
		Case "int"
			XMLToValue=CInt(xmlNd.childNodes(0).text)
		Case "i4"
			XMLToValue=CInt(xmlNd.childNodes(0).text)
		Case "boolean"
			XMLToValue=CBool(xmlNd.childNodes(0).text)
		Case "string"
			XMLToValue=CStr(xmlNd.childNodes(0).text)
		Case "double"
			XMLToValue=CDbl(xmlNd.childNodes(0).text)
		Case "dateTime.iso8601"
			Dim dt
			dt=xmlNd.childNodes(0).text
			val = CDate(mid(dt, 1, 4) & "/" & mid(dt, 5, 2) & "/" & mid(dt, 7, 2))
			val = dateadd("h", CInt(mid(dt, 10, 2)), val)
			val = dateadd("n", CInt(mid(dt, 13, 2)), val)
			val = dateadd("s", CInt(mid(dt, 16, 2)), val)
			XMLToValue = val
		Case "array"
			Dim arrLen
			arrLen = xmlNd.childNodes(0).childNodes(0).childNodes.length
			Dim valArr()
			ReDim valArr(arrLen)
			for  i = 0 to arrLen-1
				valArr(i) = XMLToValue(xmlNd.childNodes(0).childNodes(0).childNodes(i))
			next
			XMLToValue = valArr
		Case "struct"
			Set val = Server.CreateObject("Scripting.Dictionary") ' How/when do we destroy this?
			Dim dictLen
			dictLen = xmlNd.childNodes(0).childNodes.length
			for k = 0 to dictLen-1
				val.Add xmlNd.childNodes(0).childNodes(k).childNodes(0).text, XMLToValue(xmlNd.childNodes(0).childNodes(k).childNodes(1))     'Add some  keys and items.
			next
			Set XMLToValue = val
		Case "base64"
			set base64=Server.createObject("Base64Lib.Base64")
			XMLToValue = base64.Decode(xmlNd.childNodes(0).text)
			set base64=nothing
			End Select
	else
		XMLToValue=CStr(xmlNd.text)
	end if
	end function
' ----- Client only functions -----
function functionToXML(methodName, paramArr)
	xmlText=""
	addTxt "<?xml version=""1.0""?>"
	addTxt "<methodCall>"
	addTxt "<methodName>" & methodName & "</methodName>"
	if NOT Ubound(paramArr, 1)=0 then
		addTxt "<params>"
		for i = 0 to Ubound(paramArr, 1)-1
			addTxt "<param>"
			addItem paramArr(i)
			addTxt "</param>"
		next
		addTxt "</params>"
		end if
	addTxt "</methodCall>"
	functionToXML = xmlText
	end function
function xmlRPC(url, methodName, paramArr)
	Dim requestText
	'Create the requestBody from the methodName and paramArr
		requestText = functionToXML(methodName, paramArr)
	'Create and send the XML request
		Set objXML = Server.CreateObject("Microsoft.XMLHTTP")
		Set objLst = Server.CreateObject("Microsoft.XMLDOM")
		objXML.open "POST", url, false
		objXML.send(requestText)
	'Extract data from XML response
		serverResponseText=objXML.responseText
		If objXML.responseXML.parseError.errorCode <> 0 Then
			Err.raise 1, "XML-RPC", "There was an error parsing the response xml received from "& url & vbnewline & vbnewline & objXML.responseText
		End If
		Set objLst = objXML.responseXML.getElementsByTagName("param")
		if objLst.length=0 then 'Something is wrong
			Set objLst = objXML.responseXML.getElementsByTagName("member")
			Err.raise objLst.item(0).childNodes(1).childNodes(0).text, "XML-RPC", "The server at " & url & " generated the following error: " & objLst.item(1).childNodes(1).childNodes(0).text
		else
			if VarType(XMLToValue (objLst.item(0).childNodes(0)))=9 then
				set xmlRPC=XMLToValue (objLst.item(0).childNodes(0))
			else
				xmlRPC=XMLToValue (objLst.item(0).childNodes(0))
			end if
		end if
	'Kill everything
		Set objXML = Nothing
		Set objLst = Nothing
		requestText=""
	end function
' ----- Server only functions -----
function returnValueToXML(returnVal)
	xmlText=""
	addTxt "<?xml version=""1.0""?>"
	addTxt "<methodResponse>"
	addTxt vbTab & "<params>"
	addTxt vbTab & vbTab & "<param>"
	addItem returnVal
	addTxt vbTab & vbTab & vbTab & "</param>"
	addTxt vbTab & vbTab & "</params>"
	addTxt vbTab & "</methodResponse>"
	returnValueToXML = xmlText
	end function
function writeFaultXML(errNum, errDesc)
	xmlText=""
	addTxt "<?xml version=""1.0""?>"
	addTxt "<methodResponse>"
	addTxt "<fault>"
	addTxt "<value>"
	addTxt "<struct>"
	addTxt "<member>"
	addTxt "<name>faultCode</name><value><int>" & errNum & "</int></value>"
	addTxt "</member>"
	addTxt "<member>"
	addTxt "<name>faultString</name><value><string>" & errDesc & "</string></value>"
	addTxt "</member>"
	addTxt "</struct>"
	addTxt "</value>"
	addTxt "</fault>"
	addTxt "</methodResponse>"
	response.write(xmlText)
	response.end
	end function
Dim returnArr(2)
sub rpcserver()
	Response.ContentType = "text/XML" 
	on error resume next
	Set objserveXML = Server.CreateObject("Microsoft.XMLDOM")
	Set objserveLst = Server.CreateObject("Microsoft.XMLDOM")
	objserveXML.async=false
	objserveXML.load(Request)
	'Extract parameters and function from XML
		If objserveXML.parseError.errorCode <> 0 Then
			Call writeFaultXML(objserveXML.parseError.errorCode, "error parsing the xml passed to the server")
		else
			Set objserveLst = objserveXML.getElementsByTagName("param")
			Dim argList()
			ReDim argList(objserveLst.length)
			for i = 0 to objserveLst.length-1
				if VarType(XMLToValue (objserveLst.item(i).childNodes(0)))=9 then
					set argList(i)=XMLToValue (objserveLst.item(i).childNodes(0))
				else
					argList(i)=XMLToValue (objserveLst.item(i).childNodes(0))
				end if
			next
			returnArr(0)=objserveXML.childNodes(1).childNodes(0).text
			returnArr(1)=arglist
		end if
	'kill everything
	set objserveXML = nothing
	set objserveLst = nothing
	Call catchError()
	
	Dim returnVal, stringToEval
	on error resume next
	if NOT returnArr(0)="" then ' A function has been specified
		stringToEval=returnArr(0) & "("
		for j = 0 to UBound(returnArr(1), 1) - 1
			stringToEval = stringToEval & "returnArr(1)(" & j & "),"
			next
		if Right(stringToEval, 1)="," then
			stringToEval=Left(stringToEval, Len(stringToEval)-1)
			end if
		stringToEval = stringToEval & ")"
		returnVal=eval(stringToEval)
		returnVal=returnValueToXML(returnVal)
		Call catchError()
		response.write(returnVal)
	end if
	Call catchError()
	end sub
sub catchError()
	if err.number=0 then
		exit sub
	end if
	Call writeFaultXML(err.number, err.description)
	end sub
%>