My language of choice can't decode an URIEncoded string
Problem:
Some time ago I was asked to help in decoding an URI Encoded string from VB6. URL Decoding is simple enough, but when you're working with Greek, Hebrew, etc. that just isn't enough.
Resolution:
A quick search revealed a truckload of samples on how to do URL Decoding, but URI Decoding is a bit harder. I decided to stand on the shoulders of geniuses and ran Reflector on the Microsoft.JScript.dll. The code was fairly easy to convert, but I thought I'd share it in case you don't want to do it yourself. :)
I've commented out (but otherwise left intact) all the spots where .NET would throw an exception, since this would be a good spot to implement your own error handler.
Anyway, bring on the code!
/ Johan
Private Function Encode2(ByVal Text1 As String) As String
Dim builder1 As String
builder1 = ""
Dim num1 As Integer
num1 = 0
Do While (num1 < Len(Text1))
Dim ch1 As String
ch1 = Mid(Text1, num1 + 1, 1)
If InURISet(ch1, 2) Then
builder1 = builder1 & (ch1)
Else
Dim num2 As Integer
num2 = AscW(ch1)
If ((num2 >= 0) And (num2 <= 127)) Then
Call AppendInHex(builder1, num2)
ElseIf ((num2 >= 128) And (num2 <= 2047)) Then
Call AppendInHex(builder1, (RShiftWord(num2, 6) Or 192))
Call AppendInHex(builder1, ((num2 And 63) Or 128))
ElseIf ((num2 < 55296) Or (num2 > 57343)) Then
Call AppendInHex(builder1, (RShiftWord(num2, 12) Or 224))
Call AppendInHex(builder1, ((RShiftWord(num2, 6) And 63) Or 128))
Call AppendInHex(builder1, ((num2 And 63) Or 128))
Else
If ((num2 >= 56320) And (num2 <= 57343)) Then
' Throw New JScriptException(JSError.URIEncodeError)
End If
If (num1 >= Len(Text1)) Then
' Throw New JScriptException(JSError.URIEncodeError)
End If
Dim num3 As Integer
num3 = Mid(Text1, num1 + 1, 1)
If ((num3 < 56320) Or (num3 > 57343)) Then
' Throw New JScriptException(JSError.URIEncodeError)
End If
num2 = ((LShiftWord((num2 - 55296), 10) + num3) + 9216)
Call AppendInHex(builder1, (RShiftWord(num2, 18) Or 240))
Call AppendInHex(builder1, ((RShiftWord(num2, 12) And 63) Or 128))
Call AppendInHex(builder1, ((RShiftWord(num2, 6) And 63) Or 128))
Call AppendInHex(builder1, ((num2 And 63) Or 128))
End If
End If
num1 = num1 + 1
Loop
Encode2 = builder1
End Function
Private Function Decode2(ByVal Text1 As String) As String
Dim builder1 As String
Dim num1 As Integer
num1 = 0
Do While (num1 < Len(Text1))
Dim ch1 As String
ch1 = Mid(Text1, (num1) + 1, 1)
If (ch1 <> "%") Then
builder1 = builder1 & (ch1)
Else
Dim ch2 As String
Dim num2 As Integer
num2 = num1
If ((num1 + 2) >= Len(Text1)) Then
' Throw New JScriptException(JSError.URIDecodeError)
End If
Dim num3 As Byte
num3 = HexValue(Mid(Text1, (num1 + 2), 1), Mid(Text1, (num1 + 3), 1))
num1 = (num1 + 2)
If ((num3 And 128) = 0) Then
ch2 = Chr(num3)
Else
Dim num4 As Integer
num4 = 1
Do While ((LShiftWord(num3, (num4 And 31)) And 128) <> 0)
num4 = num4 + 1
Loop
If (((num4 = 1) Or (num4 > 4)) Or ((num1 + ((num4 - 1) * 3)) >= Len(Text1))) Then
' Throw New JScriptException(JSError.URIDecodeError)
End If
Dim num5 As Integer
num5 = (num3 And RShiftWord(255, ((num4 + 1) And 31)))
Do While (num4 > 1)
If (Mid(Text1, (num1 + 2), 1) <> "%") Then
' Throw New JScriptException(JSError.URIDecodeError)
End If
num3 = HexValue(Mid(Text1, (num1 + 3), 1), Mid(Text1, (num1 + 4), 1))
num1 = (num1 + 3)
If ((num3 And 192) <> 128) Then
' Throw New JScriptException(JSError.URIDecodeError)
End If
num5 = ((LShiftWord(num5, 6)) Or (num3 And 63))
num4 = num4 - 1
Loop
If ((num5 >= 55296) And (num5 < 57344)) Then
' Throw New JScriptException(JSError.URIDecodeError)
End If
If (num5 < 65536) Then
ch2 = (ChrW(num5))
Else
If (num5 > 1114111) Then
' Throw New JScriptException(JSError.URIDecodeError)
End If
builder1 = builder1 & (Chr(((RShiftWord((num5 - 65536), 10) And 1023) + 55296)))
builder1 = builder1 & (Chr((((num5 - 65536) And 1023) + 56320)))
GoTo Label_01D4
End If
End If
If InURISet(ch2, 0) Then ' This can probably be omitted. It looks like it'll never be True.
builder1 = builder1 & Mid(Text1, num2 + 1, ((num1 - num2) + 1))
Else
builder1 = builder1 & ch2
End If
Label_01D4:
End If
num1 = num1 + 1
Loop
Decode2 = builder1
End Function
Private Function HexValue(ByVal ch1 As String, ByVal ch2 As String) As Byte
Dim num1 As Integer
Dim num2 As Integer
num1 = HexDigit(ch1)
num2 = HexDigit(ch2)
If ((num1 < 0) Or (num2 < 0)) Then
' Throw New JScriptException(JSError.URIDecodeError)
End If
HexValue = CByte((LShiftWord(num1, 4) Or num2))
End Function
Private Function HexDigit(ByVal c As String) As Integer
Dim retVal As Integer
retVal = -1
If ((c >= "0") And (c <= "9")) Then
retVal = (Asc(c) - Asc("0"))
End If
If ((c >= "A") And (c <= "F")) Then
retVal = (((10) + Asc(c)) - Asc("A"))
End If
If ((c >= "a") And (c <= "f")) Then
retVal = (((10) + Asc(c)) - Asc("a"))
End If
HexDigit = retVal
End Function
Function LShiftWord(ByVal w As Integer, ByVal c As Integer) As Integer
LShiftWord = w * (2 ^ c)
End Function
Function RShiftWord(w As Integer, c As Integer) As Integer
RShiftWord = w \ (2 ^ c)
End Function
Private Function InURISet(ByVal ch As String, ByVal flags As Integer) As Boolean
Dim bRetval As Boolean
bRetval = False
If (flags = 2) Then
If ((((ch >= "0") And (ch <= "9")) Or ((ch >= "A") And (ch <= "Z"))) Or ((ch >= "a") And (ch <= "z"))) Then
bRetval = True
End If
Select Case ch
Case "_", "~", "'", "(", ")", "*", "-", ".", "!"
bRetval = True
End Select
End If
If (flags = 1) Then
Select Case ch
Case "#", "$", "&", "+", ",", "/", ":", ";", "=", "?", "@"
bRetval = True
End Select
End If
InURISet = bRetval
End Function
Private Sub AppendInHex(ByRef bs As String, ByVal value As Integer)
bs = bs & "%"
Dim num1 As Integer
num1 = (RShiftWord(value, 4) And 15)
bs = bs & (IIf((num1 >= 10), Chr((num1 - 10) + 65), Chr(num1 + 48)))
num1 = (value And 15)
bs = bs & (IIf((num1 >= 10), Chr((num1 - 10) + 65), Chr(num1 + 48)))
End Sub