ASP Code Formatting Demo

FormatCode Code Formatter is based on serveral powerful syntax parser engines so you can exactly control the appearance of your source code. Here is the code formatting demo of FormatCode ASP Code Formatter to prove the ability of code formatting functions of FormatCode:

   <%

   '--- Before Code Formatting ---

   const XRPC_RESOLVE_TIMEOUT = 5000
   const XRPC_CONNECT_TIMEOUT = 5000
   const XRPC_SEND_TIMEOUT 		= 5000
   const XRPC_RECEIVE_TIMEOUT = 10000

   Dim xmlText, serverResponseText
   Dim returnArr(2)
   Dim XmlRpcReturnValue

   ' Concatenate new txt to global xmlText
   sub addTxt(txt)
   xmlText = xmlText & txt & vbNewline
   end sub

   ' Turn a numeric (?) date into a purty string
   function dateToText(el)
   el = CStr(el)
   if Len(el)=1 then
   el = "0" & el
   end if
   dateToText = el
   end function

   Class Base64_Wrapper
   Private val
   Public Property Get Item()
   Item = val
   End Property
   Public Property Let Item(newword)
   val = newword
   End Property
   End Class

   function encodeAsBase64(item)
   Dim obj
   Set obj = New Base64_Wrapper
   obj.item=item
   set encodeAsBase64=obj
   end function

   ' Given a VB object, determine its type
   ' and wrap it in XML tags. Calls addTxt to
   ' manipulate global xmlTxt
   sub addItem(itm)

   ' This mistakenly added empty "<string>" tags
   ' for null and empty variables
   'response.write VarType(itm) & " " & vbArray
   Select Case VarType(itm)

   Case vbEmpty

   Case vbNull

   Case vbNothing

   Case vbInteger
   addTxt "<value>"
   addTxt "<i4>" & itm & "</i4>"
   addTxt "</value>"

   Case vbLong
   addTxt "<value>"
   addTxt "<i4>" & itm & "</i4>"
   addTxt "</value>"

   Case vbDecimal
   addTxt "<value>"
   addTxt "<i4>" & itm & "</i4>"
   addTxt "</value>"

   Case vbSingle
   addTxt "<value>"
   addTxt "<double>" & itm & "</double>"
   addTxt "</value>"

   Case vbDouble
   addTxt "<value>"
   addTxt "<double>" & itm & "</double>"
   addTxt "</value>"

   Case vbCurrency
   addTxt "<value>"
   addTxt "<double>" & itm & "</double>"
   addTxt "</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
   addTxt "<value>"
   ' Whoops! These replaces were the wrong way
   ' round - think about it.
   ' should > ' and " also be fixed
   ' (not in spec, but is part of XML spec)
   itm = Replace(itm, "&", "&amp;", 1, -1, 1)
   itm = Replace(itm, "<", "&lt;", 1, -1, 1)
   itm = Replace(itm, ">", "&gt;", 1, -1, 1)
   itm = Replace(itm, "'", "&apos;", 1, -1, 1)
   itm = Replace(itm, """", "&quot;", 1, -1, 1)

   ' if we were able to use Response.BinaryWrite
   ' here I think we'd be fine,
   ' but how do we detect a binary object?
   addTxt "<string>" & itm & "</string>"
   addTxt "</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>"

   elseif TypeName(itm)="Recordset" then
   addTxt "<array>"
   addTxt "<data>"
   Do While Not itm.EOF
   ' was missing the value tags which are a necessary
   ' part of an array.
   addTxt "<value>"
   addTxt "<struct>"
   for each whatever in itm.fields
   addTxt "<member>"
   addTxt "<name>" & _
                              whatever.name & _
                              "</name>"
   addItem whatever.value
   addTxt "</member>"
   next
   addTxt "</struct>"
   addTxt "</value>"
   itm.MoveNext
   Loop
   addTxt "</data>"
   addTxt "</array>"
   elseif TypeName(itm)="Base64_Wrapper" then
   set base64=Server.createObject("Base64Lib.Base64")
   addTxt "<base64>" _
   & base64.Encode(itm.item) _
   & "</base64>"

   ' addItem base64.Encode(itm)
   ' Oh, this is funny how long this bug
   ' was here
   set base64=nothing
   else
   set base64 = _
   Server.createObject("Base64Lib.Base64")
   addTxt "<base64>" _
   & base64.Encode(itm) _
   & "</base64>"
   ' addItem base64.Encode(itm)
   ' Oh, this is funny how long
   ' this bug was here
   set base64=nothing
   end if
   addTxt "</value>"

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

   Case vbByte
   addTxt "<value>"
   addTxt "<int>" & CInt(itm) & "</int>"
   addTxt "</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
   set base64 = _
   Server.createObject("Base64Lib.Base64")

   addTxt "<base64>" _
   & base64.Encode(itm) _
   & "</base64>"

   ' addItem base64.Encode(itm)
   ' Oh, this is funny how long
   ' this bug was here
   set base64=nothing
   end if
   addTxt "</value>"

   'Not covered: vbError, vbVariant, vbDataObject
   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)

   XMLToValue= Null

   if xmlNd.childNodes.length > 0 then
   if NOT xmlNd.childNodes(0).nodeType = 3 then
   Select Case xmlNd.childNodes(0).tagName

   Case "int"
   XMLToValue=CLng(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,val
   dt=xmlNd.childNodes(0).text
   val = 	CDate(mid(dt, 1, 4) & "/"  _
   & mid(dt, 5, 2) _
   & "/" & mid(dt, 7, 2))
   XMLToValue = dateadd("h", CInt(mid(dt, 10, 2)), val)
   XMLToValue = dateadd("n", CInt(mid(dt, 13, 2)), val)
   XMLToValue = dateadd("s", CInt(mid(dt, 16, 2)), val)
   XMLToValue = val

   Case "array"
   dim arrLen
   arrLen = xmlNd.childNodes(0).childNodes(0).childNodes.length
   'response.write "**"&arrLen

   Dim valArr()
   ReDim valArr(arrLen-1)

   dim i
   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?
   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)
   set base64=nothing

   End Select
   else
   XMLToValue=convertStr(xmlNd.text)
   end if
   end if
   end function

   ' ----- 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""?>

   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>" _
   & Server.HTMLEncode(errDesc) & " : " & from _
   & "</string></value>" _
   & "</member>" _
   & "</struct>" _
   & "</value>" _
   & "</fault>" _
   & "</methodResponse>"

   response.write(xmlText)
   response.end
   end function

   %>

   <%

   '--- After Code Formatting ---

   Const XRPC_RESOLVE_TIMEOUT = 5000
   Const XRPC_CONNECT_TIMEOUT = 5000
   Const XRPC_SEND_TIMEOUT    = 5000
   Const XRPC_RECEIVE_TIMEOUT = 10000

   Dim xmlText, serverResponseText
   Dim returnArr(2)
   Dim XmlRpcReturnValue

   ' Concatenate new txt to global xmlText
   Sub addTxt(txt)
       xmlText = xmlText & txt & vbNewLine
   End Sub

   ' Turn a numeric (?) date into a purty string
   Function dateToText(el)
       el = CStr(el)

       If Len(el) = 1 Then
           el = "0" & el
       End If

       dateToText = el
   End Function

   Class Base64_Wrapper
   Private Val

   Public Property Get Item()
       Item = Val
   End Property

   Public Property Let Item(newword)
       Val = newword
   End Property

   End Class

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

   Function encodeAsBase64(Item)
       Dim obj
       Set obj = New Base64_Wrapper
       obj.Item = Item
       Set encodeAsBase64 = obj
   End Function

   ' Given a VB object, determine its type
   ' and wrap it in XML tags. Calls addTxt to
   ' manipulate global xmlTxt

   Sub addItem(itm)

       ' This mistakenly added empty "<string>" tags
       ' for null and empty variables
       'response.write VarType(itm) & " " & vbArray

       Select Case VarType(itm)

           Case vbEmpty

           Case vbNull

           Case vbNothing

           Case vbInteger
               addTxt "<value>"
               addTxt "<i4>" & itm & "</i4>"
               addTxt "</value>"

           Case vbLong
               addTxt "<value>"
               addTxt "<i4>" & itm & "</i4>"
               addTxt "</value>"

           Case vbDecimal
               addTxt "<value>"
               addTxt "<i4>" & itm & "</i4>"
               addTxt "</value>"

           Case vbSingle
               addTxt "<value>"
               addTxt "<double>" & itm & "</double>"
               addTxt "</value>"

           Case vbDouble
               addTxt "<value>"
               addTxt "<double>" & itm & "</double>"
               addTxt "</value>"

           Case vbCurrency
               addTxt "<value>"
               addTxt "<double>" & itm & "</double>"
               addTxt "</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
               addTxt "<value>"
               ' Whoops! These replaces were the wrong way
               ' round - think about it.
               ' should > ' and " also be fixed
               ' (not in spec, but is part of XML spec)
               itm = Replace(itm, "&", "&amp;", 1, - 1, 1)
               itm = Replace(itm, "<", "&lt;", 1, - 1, 1)
               itm = Replace(itm, ">", "&gt;", 1, - 1, 1)
               itm = Replace(itm, "'", "&apos;", 1, - 1, 1)
               itm = Replace(itm, """", "&quot;", 1, - 1, 1)

               ' if we were able to use Response.BinaryWrite
               ' here I think we'd be fine,
               ' but how do we detect a binary object?
               addTxt "<string>" & itm & "</string>"
               addTxt "</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>"

               ElseIf TypeName(itm) = "Recordset" Then
                   addTxt "<array>"
                   addTxt "<data>"

                   Do While Not itm.EOF
                       ' was missing the value tags which are a necessary
                       ' part of an array.
                       addTxt "<value>"
                       addTxt "<struct>"

                       For Each whatever In itm.fields
                           addTxt "<member>"
                           addTxt "<name>" & _
                               whatever.Name & _
                               "</name>"
                           addItem whatever.value
                           addTxt "</member>"
                       Next

                       addTxt "</struct>"
                       addTxt "</value>"
                       itm.MoveNext
                   Loop

                   addTxt "</data>"
                   addTxt "</array>"
               ElseIf TypeName(itm) = "Base64_Wrapper" Then
                   Set base64 = Server.CreateObject("Base64Lib.Base64")
                   addTxt "<base64>" _
                       & base64.Encode(itm.Item) _
                       & "</base64>"

                   ' addItem base64.Encode(itm)
                   ' Oh, this is funny how long this bug
                   ' was here
                   Set base64 = Nothing
               Else
                   Set base64 = _
                                Server.CreateObject("Base64Lib.Base64")
                   addTxt "<base64>" _
                       & base64.Encode(itm) _
                       & "</base64>"
                   ' addItem base64.Encode(itm)
                   ' Oh, this is funny how long
                   ' this bug was here
                   Set base64 = Nothing
               End If

               addTxt "</value>"

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

           Case vbByte
               addTxt "<value>"
               addTxt "<int>" & CInt(itm) & "</int>"
               addTxt "</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
                   Set base64 = _
                                Server.CreateObject("Base64Lib.Base64")

                   addTxt "<base64>" _
                       & base64.Encode(itm) _
                       & "</base64>"

                   ' addItem base64.Encode(itm)
                   ' Oh, this is funny how long
                   ' this bug was here
                   Set base64 = Nothing
               End If

               addTxt "</value>"

               'Not covered: vbError, vbVariant, vbDataObject
       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)

       XMLToValue = Null

       If xmlNd.childNodes.length > 0 Then

           If Not xmlNd.childNodes(0).nodeType = 3 Then

               Select Case xmlNd.childNodes(0).tagName

                   Case "int"
                       XMLToValue = CLng(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, Val
                       dt = xmlNd.childNodes(0).text
                       Val = CDate(Mid(dt, 1, 4) & "/" _
                             & Mid(dt, 5, 2) _
                             & "/" & Mid(dt, 7, 2))
                       XMLToValue = DateAdd("h", CInt(Mid(dt, 10, 2)), Val)
                       XMLToValue = DateAdd("n", CInt(Mid(dt, 13, 2)), Val)
                       XMLToValue = DateAdd("s", CInt(Mid(dt, 16, 2)), Val)
                       XMLToValue = Val

                   Case "array"
                       Dim arrLen
                       arrLen = xmlNd.childNodes(0).childNodes(0).childNodes.length
                       'response.write "**"&arrLen

                       Dim valArr()
                       ReDim valArr(arrLen - 1)

                       Dim i

                       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?
                       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)
                       Set base64 = Nothing

               End Select

           Else
               XMLToValue = convertStr(xmlNd.text)
           End If

       End If

   End Function

   ' ----- 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""?>

       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>" _
           & Server.HTMLEncode(errDesc) & " : " & from _
           & "</string></value>" _
           & "</member>" _
           & "</struct>" _
           & "</value>" _
           & "</fault>" _
           & "</methodResponse>"

       response.Write(xmlText)
       response.End
   End Function

   %>

Click here to preview the ASP Code Formatting Demo 2.

With FormatCode ASP Code Formatters, you can format and transform any foreign ASP source code to meet your preferred coding style or any common code convention in several seconds!