'=================================================
' This program created by Christopher Mahan
' http://www.christophermahan.com/
'=================================================


'=================================================
' This system is designed to get information from
' an xml-rpc web server, then connect to the
' www.ffiec.gov web site, enter information
' and then retrieve information from this site
' and then send that information back to the
' xml-rpc server.
'
' NOTE: THIS PROGRAM WILL NOT WORK IF THE XML-RPC SERVER
' IT IS DESIGNED TO WORK WITH IS OFFLINE
'=================================================


'=================================================
' RUNTIME OPTIONS
'=================================================

'set debugit to true to get a debug report
debugit=false
public XML_RPC_SERVICE
XML_RPC_SERVICE="http://www.christophermahan.com/xmlservice/resources/resources.asp"
abortcleaner=false
totalresp="Service at: " & XML_RPC_SERVICE & vbnewline & "-------------------" & vbnewline
'tell the server to reprocess

redim ParamList(0)

methodname="status"
myresp = xmlRPC (XML_RPC_SERVICE, methodname, paramList)
totalresp=totalresp & vbnewline & methodname & vbnewline & myresp & vbnewline

methodname="status_code"
myresp = xmlRPC (XML_RPC_SERVICE, methodname, paramList)
totalresp=totalresp & vbnewline & methodname & vbnewline & myresp & vbnewline


methodname="server_time"
myresp = xmlRPC (XML_RPC_SERVICE, methodname, paramList)
totalresp=totalresp & vbnewline & methodname & vbnewline & myresp & vbnewline

methodname="server_date"
myresp = xmlRPC (XML_RPC_SERVICE, methodname, paramList)
totalresp=totalresp & vbnewline & methodname & vbnewline & myresp & vbnewline

methodname="server_ip"
myresp = xmlRPC (XML_RPC_SERVICE, methodname, paramList)
totalresp=totalresp & vbnewline & methodname & vbnewline & myresp & vbnewline

methodname="client_ip"
myresp = xmlRPC (XML_RPC_SERVICE, methodname, paramList)
totalresp=totalresp & vbnewline & methodname & vbnewline & myresp & vbnewline

methodname="echo"
redim ParamList(1)
paramList(1)="some weird string..."
myresp = xmlRPC (XML_RPC_SERVICE, methodname, paramList)
totalresp=totalresp & vbnewline & methodname & vbnewline & myresp & vbnewline


methodname="addnumbers"
redim ParamList(2)
paramlist(1)=36
paramList(2)=12
myresp = xmlRPC (XML_RPC_SERVICE, methodname, paramList)
totalresp=totalresp & vbnewline & methodname & vbnewline & myresp & vbnewline



msgbox totalresp





'   !!  DO NOT MODIFY THE CODE BELOW   !!



'===========================================================================
'===========================================================================
'===========================================================================
'===========================================================================
'============================+---------+====================================
'============================|         |====================================
'============================| XML-RPC |====================================
'============================|         |====================================
'============================+---------+====================================
'===========================================================================
'===========================================================================
'===========================================================================
'===========================================================================
'===========================================================================
'===========================================================================






'=================================================
' ------------------LICENSE-----------------------
' This code is covered by the GNU GPL,
' http://www.opensource.org/licenses/gpl-license.html

'- - - - - - - - - - - - - - - - - - - - - - - - -

' Chris Mahan July 2002 chris@christophermahan.com
' find the latest at:
' http://www.christophermahan.com/xmlservice/xmlrpc/
' Reworked to get structs to work
'=================================================

'------------------HOW TO-------------------------
' I will explain here how to implement the thing

' in order to use the encryption, the following function
' needs to be implemented by the server:

' function xmlRPCAESGetUserPassword(username)
'   ...
'     get userpassord based on name
'   ...
'    xmlRPCAESGetUserPassword=userpassword
' end function
'
' this function allows the server to authenticate the
' user.

'-------------------TO DO-------------------------
'tested FTP from RH 7.3

' test base64 encoding

' Add a function name and parameter list returner.
' as an array,
' first element,  method name
' second element, method parameters and type
' third element,  method return value and type
'  methods(i,0)="methodname"
'  methods(i,1)="String name, Int age, Date DateOfBirth"
'  methods(i,2)="String AccountNumber"
'  methods(i,3)="Description"

' ------------------CHANGELOG---------------------

' 2001 12 06
' Basic cleanup

' 2001 12 07
' Added the Base64 ASP

' 2001 12 24
' Added MD5, MD5, and AES support
' Added XMLRPCMethodManager
'    but this might go

' 2002 07 19
' formalization of the server.createobject for MSXML to support MSXML 4.0




'=================================================
'Previous contribution. Most of the xml-rpc code was
'written by:
' David Carter-Tod, wccartd@wc.cc.va.us, June 1999
' This code is covered by the GNU GPL,
' http://www.opensource.org/licenses/gpl-license.html


'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'
'                       XML-RPC COMPONENT IN ASP
'
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++


'-------------------------------------------------
'Global Variables for XMLRPC
      Dim xmlText, serverResponseText, ReturnedThing
      Dim returnArr(2)

'-------------------------------------------------


'=================================================
' ----- Utility functions -----

'functions to get the best Microsoft XML Core Services available on the machine
' HTTPRequest
function getHTTPRequest()

  'disable error checking
  on error resume next


    Set tempobject = Server.Createobject("MSXML2.ServerXMLHTTP.4.0")
    if not (isobject(tempobject)) then Set tempobject=CreateObject("MSXML2.ServerXMLHTTP.4.0")
    if not (isobject(tempobject)) then Set tempobject=Server.Createobject("MSXML2.ServerXMLHTTP")
    if not (isobject(tempobject)) then Set tempobject=Createobject("MSXML2.ServerXMLHTTP")
    if not (isobject(tempobject)) then Set tempobject=Server.Createobject("microsoft.xmlhttp.4.0")
    if not (isobject(tempobject)) then Set tempobject=Createobject("microsoft.xmlhttp.4.0")
    if not (isobject(tempobject)) then Set tempobject=Server.createobject("microsoft.xmlhttp")
    if not (isobject(tempobject)) then Set tempobject=createobject("microsoft.xmlhttp")

  'assign return value
  set getHTTPRequest= tempobject
  'resume error checking
  on error goto 0
end function
'========================
' DOMDocument

function getDOMDocument()
  'disable error checking
  on error resume next

    Set tempobject = Server.Createobject("MSXML2.DOMDocument.4.0")
    if not (isobject(tempobject)) then Set tempobject=Createobject("MSXML2.DOMDocument.4.0")
    if not (isobject(tempobject)) then Set tempobject=Server.createobject("MSXML2.DOMDocument")
    if not (isobject(tempobject)) then Set tempobject=Createobject("MSXML2.DOMDocument")
    if not (isobject(tempobject)) then Set tempobject=Server.Createobject("microsoft.DOMDocument.4.0")
    if not (isobject(tempobject)) then Set tempobject=Createobject("microsoft.DOMDocument.4.0")
    if not (isobject(tempobject)) then Set tempobject=Server.Createobject("microsoft.DOMDocument")
    if not (isobject(tempobject)) then Set tempobject=Createobject("microsoft.DOMDocument")

  'assign return value
  set getDOMDocument= tempobject
  'resume error checking
  on error goto 0
end function


'=================================================
' Concatenate new txt to global xmlText
'=================================================
sub addTxt(txt)
  xmlText = xmlText & txt & vbNewline
end sub
'=================================================
' Buffer "0" to date/time numbers if needed
'=================================================
function dateToText(el)
  el = CStr(el)
  if Len(el)=1 then
    el = "0" & el
  end if
  dateToText = el
end function


'=================================================
' Given a VB object, determine its type
' and wrap it in XML tags. Calls addTxt to
' manipulate global xmlTxt
'=================================================
sub addItem(itm)
  Select Case VarType(itm)
    Case vbEmpty
      'do nothing
    Case vbNull
      'do nothing
    Case vbNothing
      'do nothing
    Case vbInteger
      addTxt "<value><i4>" & itm & "</i4></value>"
    Case vbLong
      addTxt "<value><i4>" & itm & "</i4></value>"
    Case vbDecimal
      addTxt "<value><i4>" & itm & "</i4></value>"
    Case vbSingle
      addTxt "<value><double>" & itm & "</double></value>"
    Case vbDouble
      addTxt "<value><double>" & itm & "</double></value>"
    Case vbCurrency
      addTxt "<value><double>" & itm & "</double></value>"
    Case vbDate
      addTxt "<value>"
      addTxt "<dateTime.iso8601>" & Year(itm) & dateToText(Month(itm)) & dateToText(Day(itm)) & "T" & dateToText(Hour(itm)) & ":" & dateToText(Minute(itm)) & ":" & dateToText(Second(itm)) & "</dateTime.iso8601>"
      addTxt "</value>"
    Case vbString
      ' if we were able to use Response.BinaryWrite here I think we'd be fine, but how do we detect a binary object?
      addTxt "<value><string>" & convertStr(itm) & "</string></value>"

    Case vbObject
      addTxt "<value>"
      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>"
       else
        addTxt "<base64>" & base64Encode(itm) & "</base64>"
      end if
      addTxt "</value>"

    Case vbBoolean
      addTxt "<value><boolean>" & -1*CInt(itm) & "</boolean></value>"

    Case vbByte
      addTxt "<value><int>" & CInt(itm) & "</int></value>"

    Case else
      addTxt "<value>"
      if VarType(itm) > vbArray then
        addTxt "<array>"
        addTxt "<data>"

        for x = 0 to Ubound(itm, 1)
          addItem itm(x)
        next
        addTxt "</data>"
        addTxt "</array>"
       else
        'do nothing
      end if
      addTxt "</value>"

    'Not covered: vbError, vbVariant, vbDataObject
    'if vbvariant, what to do?
    'answer from chris: detect the data type
  end Select
end sub

'=================================================

' addendum to string conversion for recognized entities
function convertStr(str)
  convertStr=CStr(str)
  convertStr=Replace(convertStr, "&quot;", """", 1, -1, 1)
  convertStr=Replace(convertStr, "&apos;", "'", 1, -1, 1)
  convertStr=Replace(convertStr, "&gt;", ">", 1, -1, 1)
  convertStr=Replace(convertStr, "&lt;", "<", 1, -1, 1)
  convertStr=Replace(convertStr, "&amp;", "&", 1, -1, 1)
end function

'=================================================

' Extract values VB can use from XML input
' Tries to return an object of the appropriate type
function XMLToValue(xmlNd)
  on error resume next
  Dim val

  'why childnodes 3?
  if NOT xmlNd.childNodes(0).nodeType = 3 then

    Select Case xmlNd.childNodes(0).tagName

      Case "int"
        XMLToValue=CInt(xmlNd.childNodes(0).text)

      Case "i4"
        ' changed CInt to CLng for values over 32K ?
        XMLToValue=CLng(xmlNd.childNodes(0).text)

      Case "boolean"
        XMLToValue=CBool(xmlNd.childNodes(0).text)

      Case "string"
        XMLToValue=convertStr(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-1)

        For i = 0 to arrLen-1
          ' Might get back a Dictionary
          Dim tmp
          Set tmp = capture_eval( XMLToValue( xmlNd.childNodes(0).childNodes(0).childNodes(i) ))

          if tmp.Item("is_object") then
            Set valArr(i) = tmp.Item("data")
           else
            valArr(i) = tmp.Item("data")
          end if

        Next

        XMLToValue = valArr

      Case "struct"
        ' How/when do we destroy this?
        'cm 20020719 I think this gets destroyed in the actual implemetation. Maybe create a cleanobjects function to be called at the end.
        Set val = Server.CreateObject("Scripting.Dictionary")
        Dim dictLen

        dictLen = xmlNd.childNodes(0).childNodes.length
        For k = 0 to dictLen-1
          'Add keys and items to dictionary
          val.Add xmlNd.childNodes(0).childNodes(k).childNodes(0).text, XMLToValue(xmlNd.childNodes(0).childNodes(k).childNodes(1))

        Next

        Set XMLToValue = val

      Case "base64"
        'set base64=Server.createObject("Base64Lib.Base64")
        'XMLToValue = base64.Decode(xmlNd.childNodes(0).text)
        XMLToValue = base64Decode(xmlNd.childNodes(0).text)
        'set base64=nothing

    end Select
   else
    XMLToValue=convertStr(xmlNd.text)
  end if
  on error goto 0
end function

'=================================================

' ----- Client only functions -----
' Wrap the incoming method and args into XML
' Return new XML request in xmlText
function functionToXML(methodName, paramArr)
  ' Clear the global return string
  xmlText=""

  ' Begin header, method call
  addTxt "<?xml version=""1.0""?>" & vbnewline &  "<methodCall>" & "<methodName>" & methodName & "</methodName>"
  ' if we have arguments, add them
  addTxt "<params>"
  if NOT UBound(paramArr, 1)=0 then
    for i = 0 to UBound(paramArr, 1)
      if Not IsEmpty(paramArr(i)) then
        addTxt "<param>"
        addItem paramArr(i)
        addTxt "</param>"
      end IF
    next
  end if
  addTxt "</params>"
  addTxt "</methodCall>"

  functionToXML = xmlText
end function


'=================================================
'
'      CLIENT FUNCTIONS
'
'=================================================

' Called by clients, this "public" function passes
' method calls and arguments to be wrapped up in XML,
' the requested method called, the response returned
' appropriately.

function xmlRPC(url, methodName, paramArr)
  Dim requestText
  ' go from simple ASCII to xmlrpc
  ' Create the requestBody from the methodName and paramArr
  requestText = functionToXML(methodName, paramArr)

  '===============================================
  'do the request. if from win 98 box, use
  ' Microsoft.XMLHTTP, otherwise use Microsoft.serverXMLHTTP

  'disable error checking
  on error resume next

  'Use redistributable, server-safe XMLHTTP
  Set objXML = getHTTPRequest
  Set objLst = getDOMDocument


  're-enable error checking
  on error goto 0


  ' Call the remote machine the request
  objXML.open "POST", url, false

  ' This is necessary for some implementations (ZOPE).
  'send content-type header as text/xml
  objXML.setRequestHeader "CONTENT_TYPE", "text/xml"

  objXML.send(requestText)

  Call catchError( "xmlRPC(1): XMLHTTP object creation" )

  'Extract data from XML response
  serverResponseText = objXML.responseText

  'PREVIOUSLY ENTERED, need to check if implementation needed.
  ' Here and further on in this function
  ' you're call the writeFaultXML sub
  ' but in this function, we're the client.
  ' Should we just err.raise and let
  ' the coder get a standard error message?
  ' Why write XML to a web page?
  '
  ' You're right. This error should be handled
  ' better --jjohn

  'return HTTP header check
  'if 200, then OK, if not, return error to application
  if not objXML.status = 200 then
    writeFaultXML objXML.status, "Problem on remote machine [" & serverResponseText & "]", "xmlRPC(1.5)"
  end if

  'check for response parsing error.
  'If error, return error to application
  if objXML.responseXML.parseError.errorCode <> 0 then
    writeFaultXML objXML.responseXML.parseError.errorCode, "There was an error parsing the response " & "from " & methodName & " xml {" & serverResponseText & "} received from " & url & "*" & requestText & "*", "xmlRPC(2)"
  end if

  ' Parsing response.
  Set objLst = objXML.responseXML.getElementsByTagName("param")

  if objLst.length = 0 then
    ' There were *no* <param> tags passed back
    Set objLst = objXML.responseXML.getElementsByTagName("member")

    Call writeFaultXML("(unknown)", " [The server at " & url & " generated the following error]: <BR>" & "[request: " & requestText & "]<BR>" & "<BR>[answer: " & serverResponseText & "]", "xmlRPC(4)")

   else
    ' if I have a struct, make sure the vbDictionary
    ' gets assigned correctly for this function's return value

    'also, the client application needs to check whether the return type of this function is an object.
    Dim tmp
    Set tmp = capture_eval(XMLToValue(objLst.item(0).childNodes(0)))
    if tmp.Item("is_object") then
      Set xmlRPC = tmp.Item("data")
     else
      xmlRPC = tmp.Item("data")
    end if
  end if

  'deinstantiate objects
  Set objXML = Nothing
  Set objLst = Nothing
  'reset variable
  requestText=""
end function




'0000000000000000000000000000000000000000000000000000000000000000000000000000000
'function to wrap the call


function xmlRPCAES(url, methodName, paramArr, UserName, UserPassword)
  '=====================
  'things to do
  dim AESarray(2)
  'hash the userpassword using MD5
  hashedpassword=md5(UserPassword)
  if xmlrpcdebugger=true then
    response.write "<br />Userpassword: " & userpassword & "<br />MD5 Hash: " & hashedpassword
  end if

  'hash the AES Key
  AESHashKey=MD5(UserName & UserPassword)

  if xmlrpcdebugger=true then
    response.write "<br />UserName & Userpassword: " & UserName & userpassword & "<br />MD5 Hash: " & AESHashKey
  end if


  Dim requestText
  ' go from simple ASCII to xmlrpc
  ' Create the requestBody from the methodName and paramArr
  requestText = functionToXML(methodName, paramArr)
  if xmlrpcdebugger=true then
    response.write "<p><br />requestText : " & requestText & "</p>"
  end if
  if xmlrpcdebugger=true then
    response.write "<p>Doing encryption</p>"
  end if
  'encrypt the requestText
  requestText=AES_Encrypt(requestText,AESHashKey)
  if xmlrpcdebugger=true then
    response.write "<p><br />requestText : " & requestText & "<br />MD5 Hash: " & AESHashKey & "</p>"
  end if

  if xmlrpcdebugger=true then
    response.write "<p><br />Request text decrypted : " & AES_Decrypt(requestText,AESHashKey) & "<br />MD5 Hash: " & AESHashKey & "</p>"
  end if

  AESarray(0)=requestText
  AESarray(1)=UserName
  AESarray(2)=HashedPassword

  requestText=functionToXML("xmlRPC_AESDecrypt", AESarray)
  if xmlrpcdebugger=true then
    response.write "<p><br />Ready to send requestText : " & requestText & "</p>"
  end if


  'get msxml objects
  Set objXML = getHTTPRequest
  Set objLst = getDOMDocument
  Set objXMLDOM = getDOMDocument





  're-enable error checking
  on error goto 0


  ' Call the remote machine the request
  objXML.open "POST", url, false

  ' This is necessary for some implementations (ZOPE).
  'send content-type header as text/xml
  objXML.setRequestHeader "CONTENT_TYPE", "text/xml"

  objXML.send(requestText)

  Call catchError( "xmlRPC(1): XMLHTTP object creation" )

  'Extract data from XML response
  serverResponseText = objXML.responseText
  objXMLDOM.loadxml(serverResponseText)
  'here decode
  if xmlrpcdebugger=true then
    response.write "<p><br />Response : " & serverResponseText & "</p>"
  end if

  if instr(1,serverResponseText,"faultCode")>0 then
      'do not decrypt there is an error
    else
      AESk1=instr(1, serverResponseText ,"<value><string>")
      if AESk1<1 then
        response.end
      end if
      AESk2=instr(AESk1, serverResponseText ,"/string")
      serverResponseText=mid(serverResponseText,AESk1+15, AESk2-2)
      serverResponseText=left(serverResponseText,len(serverResponseText)-59)
      if xmlrpcdebugger=true then
         response.write "<p><br />Response after extract: [" & serverResponseText & "]</p>"
         response.write "<p><br />Hash key to be used for decryption: [" & AESHashKey & "]</p>"
      end if

      serverResponseText=AES_Decrypt (serverResponseText, AESHashKey)
      objXMLDOM.loadxml(serverResponseText)
       if xmlrpcdebugger=true then
         response.write "<p><br />Response after decrypt: " & serverResponseText & "</p>"
       end if
  end if

  'PREVIOUSLY ENTERED, need to check if implementation needed.
  ' Here and further on in this function
  ' you're call the writeFaultXML sub
  ' but in this function, we're the client.
  ' Should we just err.raise and let
  ' the coder get a standard error message?
  ' Why write XML to a web page?
  '
  ' You're right. This error should be handled
  ' better --jjohn

  'return HTTP header check
  'if 200, then OK, if not, return error to application
  if not objXML.status = 200 then
    writeFaultXML objXML.status, "Problem on remote machine [" & serverResponseText & "]", "xmlRPC(1.5)"
  end if

  'check for response parsing error.
  'If error, return error to application
  if objXMLDOM.parseError.errorCode <> 0 then
    writeFaultXML objXMLDOM.parseError.errorCode, "There was an error parsing the response " & "from " & methodName & " xml {" & serverResponseText & "} received from " & url & "*" & requestText & "*", "xmlRPC(2)"
  end if



  ' DO: change the parsing to something else when getting back an encrypted response.

  ' Parsing response.
  Set objLst = objXMLDOM.getElementsByTagName("param")

  if objLst.length = 0 then
    ' There were *no* <param> tags passed back
    Set objLst = objXMLDOM.getElementsByTagName("member")

    Call writeFaultXML("(unknown)", " [The server at " & url & " generated the following error]: <BR>" & "[request: " & requestText & "]<BR>" & "<BR>[answer: " & serverResponseText & "]", "xmlRPC(4)")

   else
    ' if I have a struct, make sure the vbDictionary
    ' gets assigned correctly for this function's return value

    'also, the client application needs to check whether the return type of this function is an object.
    Dim tmp
    Set tmp = capture_eval(XMLToValue(objLst.item(0).childNodes(0)))
    '=============================================
    'finally, check if isobject, and send back to the program
    if tmp.Item("is_object") then
      Set xmlRPCAES = tmp.Item("data")
     else
      xmlRPCAES = tmp.Item("data")
    end if






  end if

  'deinstantiate objects
  Set objXML = Nothing
  Set objLst = Nothing
  set objXMLDOM = Nothing
  'reset variable
  requestText=""
end function
'end of xmlRPCAES function
'OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO












'=================================================

' ----- Server only functions -----

' Wrap response from method into XML
' return to requester

function returnValueToXML(returnVal)
  xmlText=""

  ' I think we need to worry about character encoding here
  ' e.g. encoding=""UTF-16""?>

  'possibly encoding utf-8? CM

  addTxt "<?xml version=""1.0""?>"
  addTxt "<methodResponse>"
  addTxt "<params>"
  addTxt "<param>"
  addItem returnVal
  addTxt "</param>"
  addTxt "</params>"
  addTxt "</methodResponse>"
  returnValueToXML = xmlText
end function

'=================================================
' In case of error, send a note in XML
'=================================================

function writeFaultXML(errNum, errDesc, from)
  xmlText=""

  addTxt "<?xml version=""1.0""?>" & "<methodResponse>" & "<fault>" & "<value>" & "<struct>" & "<member>" & "<name>faultCode</name><value><int>" & errNum & "</int></value>" & "</member>" & "<member>" & "<name>faultString</name><value><string>" & errDesc & " : " & from & "</string></value>" & "</member>" & "</struct>" & "</value>" & "</fault>" & "</methodResponse>"

  msgbox xmlText
  
end function

'=================================================


' create a dictionary of valid server functions and their mappings
dim serverMappings
Set serverMappings = CreateObject("Scripting.Dictionary")

sub addServerFunction(functionName, exposedName)
  serverMappings.Add functionName, exposedName
end sub


'=================================================

' Called by server (listener) piece.

  'xmlrpc server element

sub rpcserver()
  Response.ContentType = "text/XML"
  'on error resume next

  ' Use MS redistributable parser
  Set objserveXML = getDOMDocument
  Set objserveLst = getDOMDocument

  objserveXML.async=false
  objserveXML.load(Request)


  'Extract parameters and function from XML
  'reDim returnArr(2)
  if objserveXML.parseError.errorCode <> 0 then
    Call writeFaultXML(objserveXML.parseError.errorCode, "error parsing the xml passed to the server", "rpcserver(1)" )
   else
    ' procedure to call
    returnArr(0) = objserveXML.childNodes(1).childNodes(0).text

    'is it valid and does it map to something
    'if serverMappings.exists(returnArr(0)) then
    '  returnArr(0)=serverMappings.item(returnArr(0))
    '  set serverMappings=nothing
    ' else
    '  set serverMappings=nothing
    '  Call writeFaultXML("1.2", "No such function", "This is not a valid function call for this server" )
    'end if

    ' Placeholder for args (good when params are lacking
    redim placeholder(1)
    returnArr(1) = placeholder

    ' Argument list
    ' This could be a zero length list
    Set objserveLst = objserveXML.getElementsByTagName("param")

    if (objserveLst.length > 0 ) then
      Dim argList()

      ReDim argList(objserveLst.length)

      For i = 0 to objserveLst.length - 1
        ' Make sure I have the correct assignment
        ' if I get an object!
        Dim tmp
        Set tmp = capture_eval(XMLToValue( objserveLst.item(i).childNodes(0)))

        if tmp.Item("is_object") then
          Set argList(i) = tmp.Item("data")
         else
          argList(i) = tmp.Item("data")
        end if

        Call catchError ("rpcserver(1.5): args to XML " & "[value was " & typename(argList(i)) & "]")
      Next
      returnArr(1) = argList
    end if

  end if

  ' "free" objects
  'set objserveXML = nothing
  'set objserveLst = nothing
  'Call catchError("rpcserver(2): freeing objects ")

    '*********************************************
    '  FIND OUT IF I HAVE ENCRYPTED PAYLOAD
    '*********************************************
    '  check if procedure is xmlRPC_AESDecrypt
    '  we have encrypted payload. do something
    if returnArr(0)="xmlRPC_AESDecrypt" then
      payload_is_encrypted=true
     else
      payload_is_encrypted=false
    end if
    '*********************************************
    ' NOW WE KNOW IF IT'S ENCRYPTED OR NOT
    '*********************************************

  'do payload decrypt
  if payload_is_encrypted=true then
    'get username

    encrypted_payload=returnArr(1)(0)
    temp_user_name=returnArr(1)(1)
    hashedpassword=returnArr(1)(2)
    xmlrpcAESWriteIncoming "encrypted received", temp_user_name

    user_password=xmlRPCAESGetUserPassword(temp_user_name)

    ' this function should return a blank password if the username is not found
    'do the md5 hash of the password
    realpasswordhash=md5(user_password)
    'compare the passwords
    if realpasswordhash=hashedpassword then
      passwords_match=true
     else
      passwords_match=false
      'if passwords don't match, send the error message back. Use the incoming hash.
      addTxt=""
      addTxt "<?xml version=""1.0""?>" & "<methodResponse>" & "<fault>" & "<value>" & "<struct>" & "<member>" & "<name>faultCode</name><value><int>" & 10001 & "</int></value>" & "</member>" & "<member>" & "<name>faultString</name><value><string>" & Server.HTMLEncode("Incorrect username/password") & from & "</string></value>" & "</member>" & "</struct>" & "</value>" & "</fault>" & "</methodResponse>"
      response.write(xmlText)
      response.end
    end if


    'Calculate the MD5 Hash
    MD5HashKey=temp_user_name & user_password
    MD5Hash=MD5(MD5HashKey)
    xmlrpcAESWriteEncryptionKey MD5Hash, temp_user_name
    xmlrpcAESWriteIncomingString MD5HashKey, temp_user_name
    'decrypt payload
    decrypted_payload=AES_Decrypt(encrypted_payload, MD5Hash)
    xmlrpcAESWriteIncoming "Decrypted payload:" & decrypted_payload, temp_user_name
    'now we need to extract the function name and parameters from the decrypted payload
    'Extract parameters and function from XML

            'objserveXML.load(decrypted_payload)
            Set objserverXMLDOM = getDOMDocument
            objServerXMLDOM.loadxml decrypted_payload
            'reDim returnArr(2)
            if objserveXML.parseError.errorCode <> 0 then
              Call writeFaultXML(objServerXMLDOM.parseError.errorCode, "error parsing the xml passed to the server", "rpcserver(1)" )
             else
              ' procedure to call
              returnArr(0) = objServerXMLDOM.childNodes(1).childNodes(0).text

              'is it valid and does it map to something
              'if serverMappings.exists(returnArr(0)) then
              '  returnArr(0)=serverMappings.item(returnArr(0))
              '  set serverMappings=nothing
              ' else
              '  set serverMappings=nothing
              '  Call writeFaultXML("1.2", "No such function", "This is not a valid function call for this server" )
              'end if

              ' Placeholder for args (good when params are lacking
              redim placeholder(1)
              returnArr(1) = placeholder

              ' Argument list
              ' This could be a zero length list
              Set objserveLst = objServerXMLDOM.getElementsByTagName("param")

              if (objserveLst.length > 0 ) then
                'reDim argList()

                ReDim argList(objserveLst.length)

                For i = 0 to objserveLst.length - 1
                  ' Make sure I have the correct assignment
                  ' if I get an object!
                  'Dim tmp
                  Set tmp = capture_eval(XMLToValue( objserveLst.item(i).childNodes(0)))

                  if tmp.Item("is_object") then
                    Set argList(i) = tmp.Item("data")
                   else
                    argList(i) = tmp.Item("data")
                  end if

                  Call catchError ("rpcserver(1.5): args to XML " & "[value was " & typename(argList(i)) & "]")
                Next
                returnArr(1) = argList
              end if

            end if

  end if

  ' "free" objects
  set objserveXML = nothing
  set objserveLst = nothing
  set objServerXMLDOM = nothing
  Call catchError("rpcserver(2): freeing objects ")




  Dim returnVal, stringToEval
  'on error resume next

  if NOT returnArr(0) = "" then

    ' A function has been specified, build the call

    ' HOWEVER, not all functions will be called with
    ' parameters. In this case, the eval string must
    ' not have any parameters either (even empty ones)
    stringToEval = returnArr(0) & "("

    if not IsEmpty(returnArr(1)(0)) then
      ' recall that the params are in an array in the
      ' second element of the array

      for j = 0 to UBound(returnArr(1), 1) - 1
        stringToEval = stringToEval & "returnArr(1)(" & j & "),"
      next

      ' Remove trailing comma
      if Right(stringToEval, 1)="," then
        stringToEval = Left(stringToEval, Len(stringToEval)-1)
      end if
    end if

    stringToEval = stringToEval & ")"

    ' Function call is built up, let's try to call it
    ' Ok. if the function returns an object (like a dictionary)
    'then we need to do something else.
    'maybe there should be a different function
    'for returning the content of the dictionary object
    'also, there should be a dictionary cleanup.

    Dim eval_ret
    Set eval_ret = capture_eval( eval(stringToEval) )
    'check if item returned is object
    if eval_ret.item("is_object")=1 then
        set returnVal=eval_ret.item("data")
      else
        returnVal=eval_ret.item("data")
    end if

    return_payload=returnValuetoXML(returnVal)

    if payload_is_encrypted=true then
        tagger=" encrypted:" & encrypted_payload & " : " & stringToEval & " : " & return_payload
        xmlrpcAESWriteOutgoing tagger , temp_user_name
        return_payload=AES_encrypt(return_payload, MD5Hash)
        return_payload=returnValuetoXML(return_payload)
        response.write return_payload
      else
        response.write return_payload
    end if

    'remmed out... to be fixed, maybe
    'Call catchError("rpcserver(3)(return from eval) :[" & " in function " & returnArr(0) & " {evaled string: " & server.htmlencode(stringToEval) & "}" & "{returnArr(1)(0) was " & typename(returnArr(1)(0)) & "}" & " (TypeName was: " & TypeName(eval_ret) & ")" & "]")
    'Call catchError("rpcserver(4) :[" & " in function " & stringToEval & "]" & "{arg 1: " & TypeName(returnArr(1)(0)) & "}" )
   else
    'Do nothing on the else
  end if

  Call catchError("rpcserver(5) :[" & " in function " & stringToEval & "]" & "{arg 1: " & TypeName(returnArr(1)(0)) & "}" )
end sub

'=================================================

'catch errors
sub catchError(from)
  if err.number=0 then
    exit sub
  end if
  Call writeFaultXML(err.number, err.description, from )
end sub


'=================================================
' function written to test whether the eval
' returns a dictionary object
'=================================================
function capture_eval( eval_in )
  ' This is a workaround to capture the arbitrary return value
  ' from an eval statement and use the *right* assignment operator.
  ' This function returns a dictionary object which has two fields
  ' - is_object: 1 if the returned data is an object, 0 otherwise
  ' - data: whatever the actual return of the eval was

  Dim ret
  on error resume next
  Set ret = Server.CreateObject("Scripting.Dictionary")
  if not(isobject(ret)) then set ret = CreateObject("Scripting.Dictionary")
  on error goto 0
  ret.Add "data", eval_in
  if VarType( ret.Item("data") ) = 9 then
    ret.Add "is_object", 1
  else
    ret.Add "is_object", 0
  end if
  Set capture_eval = ret
end function

'-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
'+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-


'=================================================
' BASE64 Encoding module. Picked up off the web.
' at:
' http://www.15seconds.com/howto/pg000062.htm
' Unattributed otherwise
'=================================================

'-------------------------------------------------
'  CONSTANTS for Base64 encoding/decoding
      const BASE_64_MAP_INIT = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"
      dim nl
      ' zero based arrays
      dim Base64EncMap(63)
      dim Base64DecMap(127)
      CODEC_INIT=false
'-------------------------------------------------

'=================================================
' Initialization function. Must be called before anything else
'=================================================

PUBLIC SUB initCodecs()
  ' init vars
  nl = "<P>" & chr(13) & chr(10)
  ' setup base 64
  dim max, idx
  max = len(BASE_64_MAP_INIT)
  for idx = 0 to max - 1
    ' one based string
    Base64EncMap(idx) = mid(BASE_64_MAP_INIT, idx + 1, 1)
  next
  for idx = 0 to max - 1
    Base64DecMap(ASC(Base64EncMap(idx))) = idx
  next
  CODEC_INIT=true
END SUB
'=================================================
' encode base 64 encoded string
'=================================================

PUBLIC FUNCTION base64Encode(plain)
  if CODEC_INIT=false then initCodecs
  if len(plain) = 0 then
    base64Encode = ""
    exit function
  end if

  dim ret, ndx, by3, first, second, third
  by3 = (len(plain) \ 3) * 3
  ndx = 1
  do while ndx <= by3
    first  = asc(mid(plain, ndx+0, 1))
    second = asc(mid(plain, ndx+1, 1))
    third  = asc(mid(plain, ndx+2, 1))
    ret = ret & Base64EncMap(  (first \ 4) AND 63 )
    ret = ret & Base64EncMap( ((first * 16) AND 48) + ((second \ 16) AND 15) )
    ret = ret & Base64EncMap( ((second * 4) AND 60) + ((third \ 64) AND 3) )
    ret = ret & Base64EncMap( third AND 63)
    ndx = ndx + 3
  loop
  ' check for stragglers
  if by3 < len(plain) then
    first  = asc(mid(plain, ndx+0, 1))
    ret = ret & Base64EncMap(  (first \ 4) AND 63 )
    if (len(plain) MOD 3 ) = 2 then
      second = asc(mid(plain, ndx+1, 1))
      ret = ret & Base64EncMap( ((first * 16) AND 48) + ((second \16) AND 15) )
      ret = ret & Base64EncMap( ((second * 4) AND 60) )
     else
      ret = ret & Base64EncMap( (first * 16) AND 48)
      ret = ret & "="
    end if
    ret = ret & "="
  end if

  base64Encode = ret
END FUNCTION

' decode base 64 encoded string
PUBLIC FUNCTION base64Decode(scrambled)
  if CODEC_INIT=false then initCodecs
  if len(scrambled) = 0 then
    base64Decode = ""
    exit function
  end if
  ' ignore padding
  dim realLen
  realLen = len(scrambled)
  do while mid(scrambled, realLen, 1) = "="
    realLen = realLen - 1
  loop
  dim ret, ndx, by4, first, second, third, fourth
  ret = ""
  by4 = (realLen \ 4) * 4
  ndx = 1
  do while ndx <= by4
    first  = Base64DecMap(asc(mid(scrambled, ndx+0, 1)))
    second = Base64DecMap(asc(mid(scrambled, ndx+1, 1)))
    third  = Base64DecMap(asc(mid(scrambled, ndx+2, 1)))
    fourth = Base64DecMap(asc(mid(scrambled, ndx+3, 1)))
    ret = ret & chr( ((first * 4) AND 255) +   ((second \ 16) AND 3))
    ret = ret & chr( ((second * 16) AND 255) + ((third \ 4) AND 15))
    ret = ret & chr( ((third * 64) AND 255) +  (fourth AND 63) )
    ndx = ndx + 4
  loop
  ' check for stragglers, will be 2 or 3 characters
  if ndx < realLen then
    first  = Base64DecMap(asc(mid(scrambled, ndx+0, 1)))
    second = Base64DecMap(asc(mid(scrambled, ndx+1, 1)))
    ret = ret & chr( ((first * 4) AND 255) +   ((second \ 16) AND 3))
    if realLen MOD 4 = 3 then
      third = Base64DecMap(asc(mid(scrambled,ndx+2,1)))
      ret = ret & chr( ((second * 16) AND 255) + ((third \ 4) AND 15) )
    end if
  end if
  base64Decode = ret
END FUNCTION


'===============================================================================

'  MD5 Component, taken as-is and in full from

'  CALLED AS
'  MD5(sMessage)
'  RETURNS A STRING


'===============================================================================

' Derived from the RSA Data Security, Inc. MD5 Message-Digest Algorithm,
' as set out in the memo RFC1321.
'
' See the VB6 project that accompanies this sample for full code comments on how
' it works.
'
' ASP VBScript code for generating an MD5 'digest' or 'signature' of a string. The
' MD5 algorithm is one of the industry standard methods for generating digital
' signatures. It is generically known as a digest, digital signature, one-way
' encryption, hash or checksum algorithm. A common use for MD5 is for password
' encryption as it is one-way in nature, that does not mean that your passwords
' are not free from a dictionary attack.
'
' This is 'free' software with the following restrictions:
'
' You may not redistribute this code as a 'sample' or 'demo'. However, you are free
' to use the source code in your own code, but you may not claim that you created
' the sample code. It is expressly forbidden to sell or profit from this source code
' other than by the knowledge gained or the enhanced value added by your own code.
'
' Use of this software is also done so at your own risk. The code is supplied as
' is without warranty or guarantee of any kind.
'
' Should you wish to commission some derivative work based on this code provided
' here, or any consultancy work, please do not hesitate to contact us.
'
' Web Site:  http://www.frez.co.uk
' E-mail:    sales@frez.co.uk

Const BITS_TO_A_BYTE = 8
Const BYTES_TO_A_WORD = 4
Const BITS_TO_A_WORD = 32

dim m_lOnBitsMD5(30)
dim m_l2PowerMD5(30)

    m_lOnBitsMD5(0) = CLng(1)
    m_lOnBitsMD5(1) = CLng(3)
    m_lOnBitsMD5(2) = CLng(7)
    m_lOnBitsMD5(3) = CLng(15)
    m_lOnBitsMD5(4) = CLng(31)
    m_lOnBitsMD5(5) = CLng(63)
    m_lOnBitsMD5(6) = CLng(127)
    m_lOnBitsMD5(7) = CLng(255)
    m_lOnBitsMD5(8) = CLng(511)
    m_lOnBitsMD5(9) = CLng(1023)
    m_lOnBitsMD5(10) = CLng(2047)
    m_lOnBitsMD5(11) = CLng(4095)
    m_lOnBitsMD5(12) = CLng(8191)
    m_lOnBitsMD5(13) = CLng(16383)
    m_lOnBitsMD5(14) = CLng(32767)
    m_lOnBitsMD5(15) = CLng(65535)
    m_lOnBitsMD5(16) = CLng(131071)
    m_lOnBitsMD5(17) = CLng(262143)
    m_lOnBitsMD5(18) = CLng(524287)
    m_lOnBitsMD5(19) = CLng(1048575)
    m_lOnBitsMD5(20) = CLng(2097151)
    m_lOnBitsMD5(21) = CLng(4194303)
    m_lOnBitsMD5(22) = CLng(8388607)
    m_lOnBitsMD5(23) = CLng(16777215)
    m_lOnBitsMD5(24) = CLng(33554431)
    m_lOnBitsMD5(25) = CLng(67108863)
    m_lOnBitsMD5(26) = CLng(134217727)
    m_lOnBitsMD5(27) = CLng(268435455)
    m_lOnBitsMD5(28) = CLng(536870911)
    m_lOnBitsMD5(29) = CLng(1073741823)
    m_lOnBitsMD5(30) = CLng(2147483647)

    m_l2PowerMD5(0) = CLng(1)
    m_l2PowerMD5(1) = CLng(2)
    m_l2PowerMD5(2) = CLng(4)
    m_l2PowerMD5(3) = CLng(8)
    m_l2PowerMD5(4) = CLng(16)
    m_l2PowerMD5(5) = CLng(32)
    m_l2PowerMD5(6) = CLng(64)
    m_l2PowerMD5(7) = CLng(128)
    m_l2PowerMD5(8) = CLng(256)
    m_l2PowerMD5(9) = CLng(512)
    m_l2PowerMD5(10) = CLng(1024)
    m_l2PowerMD5(11) = CLng(2048)
    m_l2PowerMD5(12) = CLng(4096)
    m_l2PowerMD5(13) = CLng(8192)
    m_l2PowerMD5(14) = CLng(16384)
    m_l2PowerMD5(15) = CLng(32768)
    m_l2PowerMD5(16) = CLng(65536)
    m_l2PowerMD5(17) = CLng(131072)
    m_l2PowerMD5(18) = CLng(262144)
    m_l2PowerMD5(19) = CLng(524288)
    m_l2PowerMD5(20) = CLng(1048576)
    m_l2PowerMD5(21) = CLng(2097152)
    m_l2PowerMD5(22) = CLng(4194304)
    m_l2PowerMD5(23) = CLng(8388608)
    m_l2PowerMD5(24) = CLng(16777216)
    m_l2PowerMD5(25) = CLng(33554432)
    m_l2PowerMD5(26) = CLng(67108864)
    m_l2PowerMD5(27) = CLng(134217728)
    m_l2PowerMD5(28) = CLng(268435456)
    m_l2PowerMD5(29) = CLng(536870912)
    m_l2PowerMD5(30) = CLng(1073741824)

Function LShift(lValue, iShiftBits)
    If iShiftBits = 0 Then
        LShift = lValue
        Exit Function
    ElseIf iShiftBits = 31 Then
        If lValue And 1 Then
            LShift = &H80000000
        Else
            LShift = 0
        End If
        Exit Function
    ElseIf iShiftBits < 0 Or iShiftBits > 31 Then
        Err.Raise 6
    End If

    If (lValue And m_l2PowerMD5(31 - iShiftBits)) Then
        LShift = ((lValue And m_lOnBitsMD5(31 - (iShiftBits + 1))) * m_l2PowerMD5(iShiftBits)) Or &H80000000
    Else
        LShift = ((lValue And m_lOnBitsMD5(31 - iShiftBits)) * m_l2PowerMD5(iShiftBits))
    End If
End Function

Function RShift(lValue, iShiftBits)
    If iShiftBits = 0 Then
        RShift = lValue
        Exit Function
    ElseIf iShiftBits = 31 Then
        If lValue And &H80000000 Then
            RShift = 1
        Else
            RShift = 0
        End If
        Exit Function
    ElseIf iShiftBits < 0 Or iShiftBits > 31 Then
        Err.Raise 6
    End If

    RShift = (lValue And &H7FFFFFFE) \ m_l2PowerMD5(iShiftBits)

    If (lValue And &H80000000) Then
        RShift = (RShift Or (&H40000000 \ m_l2PowerMD5(iShiftBits - 1)))
    End If
End Function

Function RotateLeft(lValue, iShiftBits)
    RotateLeft = LShift(lValue, iShiftBits) Or RShift(lValue, (32 - iShiftBits))
End Function

Function AddUnsigned(lX, lY)
    Dim lX4
    Dim lY4
    Dim lX8
    Dim lY8
    Dim lResult

    lX8 = lX And &H80000000
    lY8 = lY And &H80000000
    lX4 = lX And &H40000000
    lY4 = lY And &H40000000

    lResult = (lX And &H3FFFFFFF) + (lY And &H3FFFFFFF)

    If lX4 And lY4 Then
        lResult = lResult Xor &H80000000 Xor lX8 Xor lY8
    ElseIf lX4 Or lY4 Then
        If lResult And &H40000000 Then
            lResult = lResult Xor &HC0000000 Xor lX8 Xor lY8
        Else
            lResult = lResult Xor &H40000000 Xor lX8 Xor lY8
        End If
    Else
        lResult = lResult Xor lX8 Xor lY8
    End If

    AddUnsigned = lResult
End Function

Function F(x, y, z)
    F = (x And y) Or ((Not x) And z)
End Function

Function G(x, y, z)
    G = (x And z) Or (y And (Not z))
End Function

Function H(x, y, z)
    H = (x Xor y Xor z)
End Function

Function IMD5(x, y, z)
    IMD5 = (y Xor (x Or (Not z)))
End Function

Sub FF(a, b, c, d, x, s, ac)
    a = AddUnsigned(a, AddUnsigned(AddUnsigned(F(b, c, d), x), ac))
    a = RotateLeft(a, s)
    a = AddUnsigned(a, b)
End Sub

Sub GG(a, b, c, d, x, s, ac)
    a = AddUnsigned(a, AddUnsigned(AddUnsigned(G(b, c, d), x), ac))
    a = RotateLeft(a, s)
    a = AddUnsigned(a, b)
End Sub

Sub HH(a, b, c, d, x, s, ac)
    a = AddUnsigned(a, AddUnsigned(AddUnsigned(H(b, c, d), x), ac))
    a = RotateLeft(a, s)
    a = AddUnsigned(a, b)
End Sub

Sub II(a, b, c, d, x, s, ac)
    a = AddUnsigned(a, AddUnsigned(AddUnsigned(IMD5(b, c, d), x), ac))
    a = RotateLeft(a, s)
    a = AddUnsigned(a, b)
End Sub

Function ConvertToWordArray(sMessage)
    Dim lMessageLength
    Dim lNumberOfWords
    Dim lWordArray()
    Dim lBytePosition
    Dim lByteCount
    Dim lWordCount

    Const MODULUS_BITS = 512
    Const CONGRUENT_BITS = 448

    lMessageLength = Len(sMessage)

    lNumberOfWords = (((lMessageLength + ((MODULUS_BITS - CONGRUENT_BITS) \ BITS_TO_A_BYTE)) \ (MODULUS_BITS \ BITS_TO_A_BYTE)) + 1) * (MODULUS_BITS \ BITS_TO_A_WORD)
    ReDim lWordArray(lNumberOfWords - 1)

    lBytePosition = 0
    lByteCount = 0
    Do Until lByteCount >= lMessageLength
        lWordCount = lByteCount \ BYTES_TO_A_WORD
        lBytePosition = (lByteCount Mod BYTES_TO_A_WORD) * BITS_TO_A_BYTE
        lWordArray(lWordCount) = lWordArray(lWordCount) Or LShift(Asc(Mid(sMessage, lByteCount + 1, 1)), lBytePosition)
        lByteCount = lByteCount + 1
    Loop

    lWordCount = lByteCount \ BYTES_TO_A_WORD
    lBytePosition = (lByteCount Mod BYTES_TO_A_WORD) * BITS_TO_A_BYTE

    lWordArray(lWordCount) = lWordArray(lWordCount) Or LShift(&H80, lBytePosition)

    lWordArray(lNumberOfWords - 2) = LShift(lMessageLength, 3)
    lWordArray(lNumberOfWords - 1) = RShift(lMessageLength, 29)

    ConvertToWordArray = lWordArray
End Function

Function WordToHex(lValue)
    Dim lByte
    Dim lCount

    For lCount = 0 To 3
        lByte = RShift(lValue, lCount * BITS_TO_A_BYTE) And m_lOnBitsMD5(BITS_TO_A_BYTE - 1)
        WordToHex = WordToHex & Right("0" & Hex(lByte), 2)
    Next
End Function

Public Function MD5(sMessage)
    Dim x
    Dim k
    Dim AA
    Dim BB
    Dim CC
    Dim DD
    Dim a
    Dim b
    Dim c
    Dim d

    Const S11 = 7
    Const S12 = 12
    Const S13 = 17
    Const S14 = 22
    Const S21 = 5
    Const S22 = 9
    Const S23 = 14
    Const S24 = 20
    Const S31 = 4
    Const S32 = 11
    Const S33 = 16
    Const S34 = 23
    Const S41 = 6
    Const S42 = 10
    Const S43 = 15
    Const S44 = 21

    x = ConvertToWordArray(sMessage)

    a = &H67452301
    b = &HEFCDAB89
    c = &H98BADCFE
    d = &H10325476

    For k = 0 To UBound(x) Step 16
        AA = a
        BB = b
        CC = c
        DD = d

        FF a, b, c, d, x(k + 0), S11, &HD76AA478
        FF d, a, b, c, x(k + 1), S12, &HE8C7B756
        FF c, d, a, b, x(k + 2), S13, &H242070DB
        FF b, c, d, a, x(k + 3), S14, &HC1BDCEEE
        FF a, b, c, d, x(k + 4), S11, &HF57C0FAF
        FF d, a, b, c, x(k + 5), S12, &H4787C62A
        FF c, d, a, b, x(k + 6), S13, &HA8304613
        FF b, c, d, a, x(k + 7), S14, &HFD469501
        FF a, b, c, d, x(k + 8), S11, &H698098D8
        FF d, a, b, c, x(k + 9), S12, &H8B44F7AF
        FF c, d, a, b, x(k + 10), S13, &HFFFF5BB1
        FF b, c, d, a, x(k + 11), S14, &H895CD7BE
        FF a, b, c, d, x(k + 12), S11, &H6B901122
        FF d, a, b, c, x(k + 13), S12, &HFD987193
        FF c, d, a, b, x(k + 14), S13, &HA679438E
        FF b, c, d, a, x(k + 15), S14, &H49B40821

        GG a, b, c, d, x(k + 1), S21, &HF61E2562
        GG d, a, b, c, x(k + 6), S22, &HC040B340
        GG c, d, a, b, x(k + 11), S23, &H265E5A51
        GG b, c, d, a, x(k + 0), S24, &HE9B6C7AA
        GG a, b, c, d, x(k + 5), S21, &HD62F105D
        GG d, a, b, c, x(k + 10), S22, &H2441453
        GG c, d, a, b, x(k + 15), S23, &HD8A1E681
        GG b, c, d, a, x(k + 4), S24, &HE7D3FBC8
        GG a, b, c, d, x(k + 9), S21, &H21E1CDE6
        GG d, a, b, c, x(k + 14), S22, &HC33707D6
        GG c, d, a, b, x(k + 3), S23, &HF4D50D87
        GG b, c, d, a, x(k + 8), S24, &H455A14ED
        GG a, b, c, d, x(k + 13), S21, &HA9E3E905
        GG d, a, b, c, x(k + 2), S22, &HFCEFA3F8
        GG c, d, a, b, x(k + 7), S23, &H676F02D9
        GG b, c, d, a, x(k + 12), S24, &H8D2A4C8A

        HH a, b, c, d, x(k + 5), S31, &HFFFA3942
        HH d, a, b, c, x(k + 8), S32, &H8771F681
        HH c, d, a, b, x(k + 11), S33, &H6D9D6122
        HH b, c, d, a, x(k + 14), S34, &HFDE5380C
        HH a, b, c, d, x(k + 1), S31, &HA4BEEA44
        HH d, a, b, c, x(k + 4), S32, &H4BDECFA9
        HH c, d, a, b, x(k + 7), S33, &HF6BB4B60
        HH b, c, d, a, x(k + 10), S34, &HBEBFBC70
        HH a, b, c, d, x(k + 13), S31, &H289B7EC6
        HH d, a, b, c, x(k + 0), S32, &HEAA127FA
        HH c, d, a, b, x(k + 3), S33, &HD4EF3085
        HH b, c, d, a, x(k + 6), S34, &H4881D05
        HH a, b, c, d, x(k + 9), S31, &HD9D4D039
        HH d, a, b, c, x(k + 12), S32, &HE6DB99E5
        HH c, d, a, b, x(k + 15), S33, &H1FA27CF8
        HH b, c, d, a, x(k + 2), S34, &HC4AC5665

        II a, b, c, d, x(k + 0), S41, &HF4292244
        II d, a, b, c, x(k + 7), S42, &H432AFF97
        II c, d, a, b, x(k + 14), S43, &HAB9423A7
        II b, c, d, a, x(k + 5), S44, &HFC93A039
        II a, b, c, d, x(k + 12), S41, &H655B59C3
        II d, a, b, c, x(k + 3), S42, &H8F0CCC92
        II c, d, a, b, x(k + 10), S43, &HFFEFF47D
        II b, c, d, a, x(k + 1), S44, &H85845DD1
        II a, b, c, d, x(k + 8), S41, &H6FA87E4F
        II d, a, b, c, x(k + 15), S42, &HFE2CE6E0
        II c, d, a, b, x(k + 6), S43, &HA3014314
        II b, c, d, a, x(k + 13), S44, &H4E0811A1
        II a, b, c, d, x(k + 4), S41, &HF7537E82
        II d, a, b, c, x(k + 11), S42, &HBD3AF235
        II c, d, a, b, x(k + 2), S43, &H2AD7D2BB
        II b, c, d, a, x(k + 9), S44, &HEB86D391

        a = AddUnsigned(a, AA)
        b = AddUnsigned(b, BB)
        c = AddUnsigned(c, CC)
        d = AddUnsigned(d, DD)
    Next

    MD5 = LCase(WordToHex(a) & WordToHex(b) & WordToHex(c) & WordToHex(d))
End Function
'=================================================
' End of md5
'=================================================


'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' AES Encryption / Decryption
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

'Option Explicit
' Rijndael.asp
' Copyright 2001 Phil Fresle
' phil@frez.co.uk
' http://www.frez.co.uk
' Implementation of the AES Rijndael Block Cipher. Inspired by Mike Scott's
' implementation in C. Permission for free direct or derivative use is granted
' subject to compliance with any conditions that the originators of the
' algorithm place on its exploitation.
' 3-Apr-2001: Functions added to the bottom for encrypting/decrypting large
' arrays of data. The entire length of the array is inserted as the first four
' bytes onto the front of the first block of the resultant byte array before
' encryption.
' 19-Apr-2001: Thanks to Paolo Migliaccio for finding a bug with 256 bit
' key. Problem was in the gkey function. Now properly matches NIST values.



'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' WRAPPER FUNCTIONS FOR ENCODING AND DECODING
' INCORPORATED 12/24/2001 (YES I WAS WORKING)
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'   THE FUNCTION AES_ENCRYPT AND AES_DECRYPT
'   TAKE BOTH A STRING AND A KEY


'  in order to get this stupid thing to work, i need to make the following changes:
'  make sure all the global variables are declared globally. This means the
'  variables that
    'Dim i
    'Dim nb
    'Dim nk
    'Dim key(31)
    'Dim block(31)
    'Dim sTemp
    'Dim sPlain
    'Dim sPassword
    'Dim bytIn()
    'Dim bytPassword()
    'Dim lCount

    'gentables
    'as well as
'=================================================
'  GLOBAL VARIABLES FOR AES ECRYPTION/DECRYPTION
'=================================================

'Option Explicit
' Rijndael.asp
' Copyright 2001 Phil Fresle
' phil@frez.co.uk
' http://www.frez.co.uk
' Implementation of the AES Rijndael Block Cipher. Inspired by Mike Scott's
' implementation in C. Permission for free direct or derivative use is granted
' subject to compliance with any conditions that the originators of the
' algorithm place on its exploitation.
' 3-Apr-2001: Functions added to the bottom for encrypting/decrypting large
' arrays of data. The entire length of the array is inserted as the first four
' bytes onto the front of the first block of the resultant byte array before
' encryption.
' 19-Apr-2001: Thanks to Paolo Migliaccio for finding a bug with 256 bit
' key. Problem was in the gkey function. Now properly matches NIST values.

Private m_lOnBits(30)
Private m_l2Power(30)
Private m_bytOnBits(7)
Private m_byt2Power(7)

Private m_InCo(3)

Private m_fbsub(255)
Private m_rbsub(255)
Private m_ptab(255)
Private m_ltab(255)
Private m_ftable(255)
Private m_rtable(255)
Private m_rco(29)

Private m_Nk
Private m_Nb
Private m_Nr
Private m_fi(23)
Private m_ri(23)
Private m_fkey(119)
Private m_rkey(119)

m_InCo(0) = &HB
m_InCo(1) = &HD
m_InCo(2) = &H9
m_InCo(3) = &HE

m_bytOnBits(0) = 1
m_bytOnBits(1) = 3
m_bytOnBits(2) = 7
m_bytOnBits(3) = 15
m_bytOnBits(4) = 31
m_bytOnBits(5) = 63
m_bytOnBits(6) = 127
m_bytOnBits(7) = 255

m_byt2Power(0) = 1
m_byt2Power(1) = 2
m_byt2Power(2) = 4
m_byt2Power(3) = 8
m_byt2Power(4) = 16
m_byt2Power(5) = 32
m_byt2Power(6) = 64
m_byt2Power(7) = 128

m_lOnBits(0) = 1
m_lOnBits(1) = 3
m_lOnBits(2) = 7
m_lOnBits(3) = 15
m_lOnBits(4) = 31
m_lOnBits(5) = 63
m_lOnBits(6) = 127
m_lOnBits(7) = 255
m_lOnBits(8) = 511
m_lOnBits(9) = 1023
m_lOnBits(10) = 2047
m_lOnBits(11) = 4095
m_lOnBits(12) = 8191
m_lOnBits(13) = 16383
m_lOnBits(14) = 32767
m_lOnBits(15) = 65535
m_lOnBits(16) = 131071
m_lOnBits(17) = 262143
m_lOnBits(18) = 524287
m_lOnBits(19) = 1048575
m_lOnBits(20) = 2097151
m_lOnBits(21) = 4194303
m_lOnBits(22) = 8388607
m_lOnBits(23) = 16777215
m_lOnBits(24) = 33554431
m_lOnBits(25) = 67108863
m_lOnBits(26) = 134217727
m_lOnBits(27) = 268435455
m_lOnBits(28) = 536870911
m_lOnBits(29) = 1073741823
m_lOnBits(30) = 2147483647

m_l2Power(0) = 1
m_l2Power(1) = 2
m_l2Power(2) = 4
m_l2Power(3) = 8
m_l2Power(4) = 16
m_l2Power(5) = 32
m_l2Power(6) = 64
m_l2Power(7) = 128
m_l2Power(8) = 256
m_l2Power(9) = 512
m_l2Power(10) = 1024
m_l2Power(11) = 2048
m_l2Power(12) = 4096
m_l2Power(13) = 8192
m_l2Power(14) = 16384
m_l2Power(15) = 32768
m_l2Power(16) = 65536
m_l2Power(17) = 131072
m_l2Power(18) = 262144
m_l2Power(19) = 524288
m_l2Power(20) = 1048576
m_l2Power(21) = 2097152
m_l2Power(22) = 4194304
m_l2Power(23) = 8388608
m_l2Power(24) = 16777216
m_l2Power(25) = 33554432
m_l2Power(26) = 67108864
m_l2Power(27) = 134217728
m_l2Power(28) = 268435456
m_l2Power(29) = 536870912
m_l2Power(30) = 1073741824

Private Function LShift(lValue, iShiftBits)
    If iShiftBits = 0 Then
        LShift = lValue
        Exit Function
    ElseIf iShiftBits = 31 Then
        If lValue And 1 Then
            LShift = &H80000000
        Else
            LShift = 0
        End If
        Exit Function
    ElseIf iShiftBits < 0 Or iShiftBits > 31 Then
        Err.Raise 6
    End If

    If (lValue And m_l2Power(31 - iShiftBits)) Then
        LShift = ((lValue And m_lOnBits(31 - (iShiftBits + 1))) * m_l2Power(iShiftBits)) Or &H80000000
    Else
        LShift = ((lValue And m_lOnBits(31 - iShiftBits)) * m_l2Power(iShiftBits))
    End If
End Function

Private Function RShift(lValue, iShiftBits)
    If iShiftBits = 0 Then
        RShift = lValue
        Exit Function
    ElseIf iShiftBits = 31 Then
        If lValue And &H80000000 Then
            RShift = 1
        Else
            RShift = 0
        End If
        Exit Function
    ElseIf iShiftBits < 0 Or iShiftBits > 31 Then
        Err.Raise 6
    End If

    RShift = (lValue And &H7FFFFFFE) \ m_l2Power(iShiftBits)

    If (lValue And &H80000000) Then
        RShift = (RShift Or (&H40000000 \ m_l2Power(iShiftBits - 1)))
    End If
End Function

Private Function LShiftByte(bytValue, bytShiftBits)
    If bytShiftBits = 0 Then
        LShiftByte = bytValue
        Exit Function
    ElseIf bytShiftBits = 7 Then
        If bytValue And 1 Then
            LShiftByte = &H80
        Else
            LShiftByte = 0
        End If
        Exit Function
    ElseIf bytShiftBits < 0 Or bytShiftBits > 7 Then
        Err.Raise 6
    End If

    LShiftByte = ((bytValue And m_bytOnBits(7 - bytShiftBits)) * m_byt2Power(bytShiftBits))
End Function

Private Function RShiftByte(bytValue, bytShiftBits)
    If bytShiftBits = 0 Then
        RShiftByte = bytValue
        Exit Function
    ElseIf bytShiftBits = 7 Then
        If bytValue And &H80 Then
            RShiftByte = 1
        Else
            RShiftByte = 0
        End If
        Exit Function
    ElseIf bytShiftBits < 0 Or bytShiftBits > 7 Then
        Err.Raise 6
    End If

    RShiftByte = bytValue \ m_byt2Power(bytShiftBits)
End Function

Private Function RotateLeft(lValue, iShiftBits)
    RotateLeft = LShift(lValue, iShiftBits) Or RShift(lValue, (32 - iShiftBits))
End Function

Private Function RotateLeftByte(bytValue, bytShiftBits)
    RotateLeftByte = LShiftByte(bytValue, bytShiftBits) Or RShiftByte(bytValue, (8 - bytShiftBits))
End Function

Private Function Pack(b())
    Dim lCount
    Dim lTemp

    For lCount = 0 To 3
        lTemp = b(lCount)
        Pack = Pack Or LShift(lTemp, (lCount * 8))
    Next
End Function

Private Function PackFrom(b(), k)
    Dim lCount
    Dim lTemp

    For lCount = 0 To 3
        lTemp = b(lCount + k)
        PackFrom = PackFrom Or LShift(lTemp, (lCount * 8))
    Next
End Function

Private Sub Unpack(a, b())
    b(0) = a And m_lOnBits(7)
    b(1) = RShift(a, 8) And m_lOnBits(7)
    b(2) = RShift(a, 16) And m_lOnBits(7)
    b(3) = RShift(a, 24) And m_lOnBits(7)
End Sub

Private Sub UnpackFrom(a, b(), k)
    b(0 + k) = a And m_lOnBits(7)
    b(1 + k) = RShift(a, 8) And m_lOnBits(7)
    b(2 + k) = RShift(a, 16) And m_lOnBits(7)
    b(3 + k) = RShift(a, 24) And m_lOnBits(7)
End Sub

Private Function xtime(a)
    Dim b

    If (a And &H80) Then
        b = &H1B
    Else
        b = 0
    End If

    xtime = LShiftByte(a, 1)
    xtime = xtime Xor b
End Function

Private Function bmul(x, y)
    If x <> 0 And y <> 0 Then
        bmul = m_ptab((CLng(m_ltab(x)) + CLng(m_ltab(y))) Mod 255)
    Else
        bmul = 0
    End If
End Function

Private Function SubByte(a)
    Dim b(3)

    Unpack a, b
    b(0) = m_fbsub(b(0))
    b(1) = m_fbsub(b(1))
    b(2) = m_fbsub(b(2))
    b(3) = m_fbsub(b(3))

    SubByte = Pack(b)
End Function

Private Function product(x, y)
    Dim xb(3)
    Dim yb(3)

    Unpack x, xb
    Unpack y, yb
    product = bmul(xb(0), yb(0)) Xor bmul(xb(1), yb(1)) Xor bmul(xb(2), yb(2)) Xor bmul(xb(3), yb(3))
End Function

Private Function InvMixCol(x)
    Dim y
    Dim m
    Dim b(3)

    m = Pack(m_InCo)
    b(3) = product(m, x)
    m = RotateLeft(m, 24)
    b(2) = product(m, x)
    m = RotateLeft(m, 24)
    b(1) = product(m, x)
    m = RotateLeft(m, 24)
    b(0) = product(m, x)
    y = Pack(b)

    InvMixCol = y
End Function

Private Function ByteSub(x)
    Dim y
    Dim z

    z = x
    y = m_ptab(255 - m_ltab(z))
    z = y
    z = RotateLeftByte(z, 1)
    y = y Xor z
    z = RotateLeftByte(z, 1)
    y = y Xor z
    z = RotateLeftByte(z, 1)
    y = y Xor z
    z = RotateLeftByte(z, 1)
    y = y Xor z
    y = y Xor &H63

    ByteSub = y
End Function

Public Sub gentables()
    Dim i
    Dim y
    Dim b(3)
    Dim ib

    m_ltab(0) = 0
    m_ptab(0) = 1
    m_ltab(1) = 0
    m_ptab(1) = 3
    m_ltab(3) = 1

    For i = 2 To 255
        m_ptab(i) = m_ptab(i - 1) Xor xtime(m_ptab(i - 1))
        m_ltab(m_ptab(i)) = i
    Next

    m_fbsub(0) = &H63
    m_rbsub(&H63) = 0

    For i = 1 To 255
        ib = i
        y = ByteSub(ib)
        m_fbsub(i) = y
        m_rbsub(y) = i
    Next

    y = 1
    For i = 0 To 29
        m_rco(i) = y
        y = xtime(y)
    Next

    For i = 0 To 255
        y = m_fbsub(i)
        b(3) = y Xor xtime(y)
        b(2) = y
        b(1) = y
        b(0) = xtime(y)
        m_ftable(i) = Pack(b)

        y = m_rbsub(i)
        b(3) = bmul(m_InCo(0), y)
        b(2) = bmul(m_InCo(1), y)
        b(1) = bmul(m_InCo(2), y)
        b(0) = bmul(m_InCo(3), y)
        m_rtable(i) = Pack(b)
    Next
End Sub

Public Sub gkey(nb, nk, key())
    Dim i
    Dim j
    Dim k
    Dim m
    Dim N
    Dim C1
    Dim C2
    Dim C3
    Dim CipherKey(7)

    m_Nb = nb
    m_Nk = nk

    If m_Nb >= m_Nk Then
        m_Nr = 6 + m_Nb
    Else
        m_Nr = 6 + m_Nk
    End If

    C1 = 1
    If m_Nb < 8 Then
        C2 = 2
        C3 = 3
    Else
        C2 = 3
        C3 = 4
    End If

    For j = 0 To nb - 1
        m = j * 3

        m_fi(m) = (j + C1) Mod nb
        m_fi(m + 1) = (j + C2) Mod nb
        m_fi(m + 2) = (j + C3) Mod nb
        m_ri(m) = (nb + j - C1) Mod nb
        m_ri(m + 1) = (nb + j - C2) Mod nb
        m_ri(m + 2) = (nb + j - C3) Mod nb
    Next

    N = m_Nb * (m_Nr + 1)

    For i = 0 To m_Nk - 1
        j = i * 4
        CipherKey(i) = PackFrom(key, j)
    Next

    For i = 0 To m_Nk - 1
        m_fkey(i) = CipherKey(i)
    Next

    j = m_Nk
    k = 0
    Do While j < N
        m_fkey(j) = m_fkey(j - m_Nk) Xor _
            SubByte(RotateLeft(m_fkey(j - 1), 24)) Xor m_rco(k)
        If m_Nk <= 6 Then
            i = 1
            Do While i < m_Nk And (i + j) < N
                m_fkey(i + j) = m_fkey(i + j - m_Nk) Xor _
                    m_fkey(i + j - 1)
                i = i + 1
            Loop
        Else
            i = 1
            Do While i < 4 And (i + j) < N
                m_fkey(i + j) = m_fkey(i + j - m_Nk) Xor _
                    m_fkey(i + j - 1)
                i = i + 1
            Loop
            If j + 4 < N Then
                m_fkey(j + 4) = m_fkey(j + 4 - m_Nk) Xor _
                    SubByte(m_fkey(j + 3))
            End If
            i = 5
            Do While i < m_Nk And (i + j) < N
                m_fkey(i + j) = m_fkey(i + j - m_Nk) Xor _
                    m_fkey(i + j - 1)
                i = i + 1
            Loop
        End If

        j = j + m_Nk
        k = k + 1
    Loop

    For j = 0 To m_Nb - 1
        m_rkey(j + N - nb) = m_fkey(j)
    Next

    i = m_Nb
    Do While i < N - m_Nb
        k = N - m_Nb - i
        For j = 0 To m_Nb - 1
            m_rkey(k + j) = InvMixCol(m_fkey(i + j))
        Next
        i = i + m_Nb
    Loop

    j = N - m_Nb
    Do While j < N
        m_rkey(j - N + m_Nb) = m_fkey(j)
        j = j + 1
    Loop
End Sub

Public Sub encrypt(buff())
    Dim i
    Dim j
    Dim k
    Dim m
    Dim a(7)
    Dim b(7)
    Dim x
    Dim y
    Dim t

    For i = 0 To m_Nb - 1
        j = i * 4

        a(i) = PackFrom(buff, j)
        a(i) = a(i) Xor m_fkey(i)
    Next

    k = m_Nb
    x = a
    y = b

    For i = 1 To m_Nr - 1
        For j = 0 To m_Nb - 1
            m = j * 3
            y(j) = m_fkey(k) Xor m_ftable(x(j) And m_lOnBits(7)) Xor _
                RotateLeft(m_ftable(RShift(x(m_fi(m)), 8) And m_lOnBits(7)), 8) Xor _
                RotateLeft(m_ftable(RShift(x(m_fi(m + 1)), 16) And m_lOnBits(7)), 16) Xor _
                RotateLeft(m_ftable(RShift(x(m_fi(m + 2)), 24) And m_lOnBits(7)), 24)
            k = k + 1
        Next
        t = x
        x = y
        y = t
    Next

    For j = 0 To m_Nb - 1
        m = j * 3
        y(j) = m_fkey(k) Xor m_fbsub(x(j) And m_lOnBits(7)) Xor _
            RotateLeft(m_fbsub(RShift(x(m_fi(m)), 8) And m_lOnBits(7)), 8) Xor _
            RotateLeft(m_fbsub(RShift(x(m_fi(m + 1)), 16) And m_lOnBits(7)), 16) Xor _
            RotateLeft(m_fbsub(RShift(x(m_fi(m + 2)), 24) And m_lOnBits(7)), 24)
        k = k + 1
    Next

    For i = 0 To m_Nb - 1
        j = i * 4
        UnpackFrom y(i), buff, j
        x(i) = 0
        y(i) = 0
    Next
End Sub

Public Sub decrypt(buff())
    Dim i
    Dim j
    Dim k
    Dim m
    Dim a(7)
    Dim b(7)
    Dim x
    Dim y
    Dim t

    For i = 0 To m_Nb - 1
        j = i * 4
        a(i) = PackFrom(buff, j)
        a(i) = a(i) Xor m_rkey(i)
    Next

    k = m_Nb
    x = a
    y = b

    For i = 1 To m_Nr - 1
        For j = 0 To m_Nb - 1
            m = j * 3
            y(j) = m_rkey(k) Xor m_rtable(x(j) And m_lOnBits(7)) Xor _
                RotateLeft(m_rtable(RShift(x(m_ri(m)), 8) And m_lOnBits(7)), 8) Xor _
                RotateLeft(m_rtable(RShift(x(m_ri(m + 1)), 16) And m_lOnBits(7)), 16) Xor _
                RotateLeft(m_rtable(RShift(x(m_ri(m + 2)), 24) And m_lOnBits(7)), 24)
            k = k + 1
        Next
        t = x
        x = y
        y = t
    Next

    For j = 0 To m_Nb - 1
        m = j * 3

        y(j) = m_rkey(k) Xor m_rbsub(x(j) And m_lOnBits(7)) Xor _
            RotateLeft(m_rbsub(RShift(x(m_ri(m)), 8) And m_lOnBits(7)), 8) Xor _
            RotateLeft(m_rbsub(RShift(x(m_ri(m + 1)), 16) And m_lOnBits(7)), 16) Xor _
            RotateLeft(m_rbsub(RShift(x(m_ri(m + 2)), 24) And m_lOnBits(7)), 24)
        k = k + 1
    Next

    For i = 0 To m_Nb - 1
        j = i * 4

        UnpackFrom y(i), buff, j
        x(i) = 0
        y(i) = 0
    Next
End Sub

Private Function IsInitialized(vArray)
    On Error Resume Next

    IsInitialized = IsNumeric(UBound(vArray))
End Function

Private Sub CopyBytesASP(bytDest, lDestStart, bytSource(), lSourceStart, lLength)
    Dim lCount

    lCount = 0
    Do
        bytDest(lDestStart + lCount) = bytSource(lSourceStart + lCount)
        lCount = lCount + 1
    Loop Until lCount = lLength
End Sub

Public Function EncryptData(bytMessage, bytPassword)
    Dim bytKey(31)
    Dim bytIn()
    Dim bytOut()
    Dim bytTemp(31)
    Dim lCount
    Dim lLength
    Dim lEncodedLength
    Dim bytLen(3)
    Dim lPosition

    If Not IsInitialized(bytMessage) Then
        Exit Function
    End If
    If Not IsInitialized(bytPassword) Then
        Exit Function
    End If

    For lCount = 0 To UBound(bytPassword)
        bytKey(lCount) = bytPassword(lCount)
        If lCount = 31 Then
            Exit For
        End If
    Next

    gentables
    gkey 8, 8, bytKey

    lLength = UBound(bytMessage) + 1
    lEncodedLength = lLength + 4

    If lEncodedLength Mod 32 <> 0 Then
        lEncodedLength = lEncodedLength + 32 - (lEncodedLength Mod 32)
    End If
    ReDim bytIn(lEncodedLength - 1)
    ReDim bytOut(lEncodedLength - 1)

    Unpack lLength, bytIn
    CopyBytesASP bytIn, 4, bytMessage, 0, lLength

    For lCount = 0 To lEncodedLength - 1 Step 32
        CopyBytesASP bytTemp, 0, bytIn, lCount, 32
        Encrypt bytTemp
        CopyBytesASP bytOut, lCount, bytTemp, 0, 32
    Next

    EncryptData = bytOut
End Function

Public Function DecryptData(bytIn, bytPassword)
    Dim bytMessage()
    Dim bytKey(31)
    Dim bytOut()
    Dim bytTemp(31)
    Dim lCount
    Dim lLength
    Dim lEncodedLength
    Dim bytLen(3)
    Dim lPosition

    If Not IsInitialized(bytIn) Then
        Exit Function
    End If
    If Not IsInitialized(bytPassword) Then
        Exit Function
    End If

    lEncodedLength = UBound(bytIn) + 1

    If lEncodedLength Mod 32 <> 0 Then
        Exit Function
    End If

    For lCount = 0 To UBound(bytPassword)
        bytKey(lCount) = bytPassword(lCount)
        If lCount = 31 Then
            Exit For
        End If
    Next

    gentables
    gkey 8, 8, bytKey

    ReDim bytOut(lEncodedLength - 1)

    For lCount = 0 To lEncodedLength - 1 Step 32
        CopyBytesASP bytTemp, 0, bytIn, lCount, 32
        Decrypt bytTemp
        CopyBytesASP bytOut, lCount, bytTemp, 0, 32
    Next

    lLength = Pack(bytOut)

    If lLength > lEncodedLength - 4 Then
        Exit Function
    End If

    ReDim bytMessage(lLength - 1)
    CopyBytesASP bytMessage, 0, bytOut, 4, lLength

    DecryptData = bytMessage
End Function


'=================================================
'   BEGIN FUNCTION AES_Encrypt
'   This function is called by the system
'=================================================
function AES_Encrypt (sPlain,sPassword)

  lLength = Len(sPlain)

  ReDim bytIn(lLength-1)
  For lCount = 1 To lLength
    bytIn(lCount-1)=CByte(AscB(Mid(sPlain,lCount,1)))
  Next
  lLength = Len(sPassword)
  ReDim bytPassword(lLength-1)
  For lCount = 1 To lLength
    bytPassword(lCount-1)=CByte(AscB(Mid(sPassword,lCount,1)))
  Next

  bytOut = EncryptData(bytIn, bytPassword)

  sTemp = ""
  For lCount = 0 To UBound(bytOut)
    sTemp = sTemp & Right("0" & Hex(bytOut(lCount)), 2)
  Next
  AES_Encrypt= stemp
end function

'=================================================
'     END FUNCTION AES_Encrypt
'=================================================


'=================================================
'   BEGIN FUNCTION AES_Decrypt
'     INPUT:
'       sEncrypted: the encrypted string
'       sPassword: the password string
'     OUTPUT:
'       string decrypted, or zero-length string if not decrypted
'=================================================

function AES_Decrypt(sEncrypted, sPassword)

    lLength = Len(sEncrypted)/2
    ReDim bytIn(lLength-1)
    counter=1
    For lCount = 1 To lLength
        k="&H" & (Mid(sEncrypted,counter,2))
        counter=counter+2
    bytIn(lCount-1)=CByte(k)

    Next
    lLength = Len(sPassword)
    ReDim bytPassword(lLength-1)
    For lCount = 1 To lLength
        bytPassword(lCount-1)=CByte(AscB(Mid(sPassword,lCount,1)))
    Next

    bytClear = DecryptData(bytIn, bytPassword)


    lLength = UBound(bytClear) + 1
    sTemp = ""
    For lCount = 0 To lLength - 1
        sTemp = sTemp & Chr(bytClear(lCount))
    Next

  AES_Decrypt=sTemp
end function
'=================================================
'     END FUNCTION AES_Decrypt
'=================================================




'=================================================
' Extra added function
' Do not forget to add, at the end of the thing:
'    End Select
'  Function end



'Function XMLRPCMethodManager(methodname, paramarray)
'  Select case methodname