-
-
Save iFeelPixel/2fcb59bda548f52e1c974833886e8548 to your computer and use it in GitHub Desktop.
JSON parsing and dumping functions in VB6
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Option Explicit | |
DefObj A-Z | |
Private Const MODULE_NAME As String = "mdJson" | |
'========================================================================= | |
' API | |
'========================================================================= | |
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long) | |
Private Type JsonContext | |
Text() As Integer | |
Pos As Long | |
Error As String | |
LastChar As Integer | |
End Type | |
'========================================================================= | |
' Error management | |
'========================================================================= | |
Private Sub RaiseError(sFunction As String) | |
' PushError | |
' PopRaiseError sFunction, MODULE_NAME | |
Err.Raise Err.Number, MODULE_NAME & "." & sFunction & vbCrLf & Err.Source, Err.Description | |
End Sub | |
Private Sub PrintError(sFunction As String) | |
' PushError | |
' PopPrintError sFunction, MODULE_NAME | |
Debug.Print MODULE_NAME & "." & sFunction & ": " & Err.Description, Timer | |
End Sub | |
'========================================================================= | |
' Functions | |
'========================================================================= | |
Public Function JsonParse(sText As String, vResult As Variant, Optional Error As String) As Boolean | |
Const FUNC_NAME As String = "JsonParse" | |
Dim uCtx As JsonContext | |
Dim oResult As Object | |
On Error GoTo EH | |
With uCtx | |
ReDim .Text(0 To Len(sText)) As Integer | |
Call CopyMemory(.Text(0), ByVal StrPtr(sText), LenB(sText)) | |
JsonParse = pvJsonParse(uCtx, vResult, oResult) | |
If Not oResult Is Nothing Then | |
Set vResult = oResult | |
End If | |
Error = .Error | |
End With | |
Exit Function | |
EH: | |
PrintError FUNC_NAME | |
Resume Next | |
End Function | |
Private Function pvJsonMissing(Optional vMissing As Variant) As Variant | |
pvJsonMissing = vMissing | |
End Function | |
Private Function pvJsonParse(uCtx As JsonContext, vResult As Variant, oResult As Object) As Boolean | |
'--- note: when using collections change type of parameter oResult to Collection | |
#Const USE_RICHCLIENT = False | |
#Const USE_COLLECTION = False | |
Const FUNC_NAME As String = "pvJsonParse" | |
Dim lIdx As Long | |
Dim vKey As Variant | |
Dim vValue As Variant | |
Dim oValue As Object | |
Dim sText As String | |
On Error GoTo EH | |
vValue = pvJsonMissing | |
With uCtx | |
Select Case pvJsonGetChar(uCtx) | |
Case 34 ' " | |
vResult = pvJsonGetString(uCtx) | |
Case 91 ' [ | |
#If USE_RICHCLIENT Then | |
#If USE_COLLECTION Then | |
Set oResult = New cCollection | |
#Else | |
Set oResult = New cSortedDictionary | |
#End If | |
#Else | |
#If USE_COLLECTION Then | |
Set oResult = New Collection | |
#Else | |
Set oResult = CreateObject("Scripting.Dictionary") | |
#End If | |
#End If | |
Do | |
Select Case pvJsonGetChar(uCtx) | |
Case 0, 44, 93 ' , ] | |
If Not oValue Is Nothing Then | |
#If USE_COLLECTION Then | |
oResult.Add oValue | |
#Else | |
oResult.Add lIdx, oValue | |
#End If | |
ElseIf Not IsMissing(vValue) Then | |
#If USE_COLLECTION Then | |
oResult.Add vValue | |
#Else | |
oResult.Add lIdx, vValue | |
#End If | |
End If | |
If .LastChar <> 44 Then ' , | |
Exit Do | |
End If | |
lIdx = lIdx + 1 | |
vValue = pvJsonMissing | |
Set oValue = Nothing | |
Case Else | |
.Pos = .Pos - 1 | |
If Not pvJsonParse(uCtx, vValue, oValue) Then | |
GoTo QH | |
End If | |
End Select | |
Loop | |
Case 123 ' { | |
#If USE_RICHCLIENT Then | |
#If USE_COLLECTION Then | |
Set oResult = New cCollection | |
#Else | |
Set oResult = New cSortedDictionary | |
oResult.StringCompareMode = 1 ' TextCompare | |
#End If | |
#Else | |
#If USE_COLLECTION Then | |
Set oResult = New Collection | |
#Else | |
Set oResult = CreateObject("Scripting.Dictionary") | |
oResult.CompareMode = 1 ' TextCompare | |
#End If | |
#End If | |
Do | |
Select Case pvJsonGetChar(uCtx) | |
Case 34 ' " | |
vKey = pvJsonGetString(uCtx) | |
Case 58 ' : | |
If Not oValue Is Nothing Then | |
.Error = "Value already specified at position " & .Pos | |
GoTo QH | |
ElseIf Not IsMissing(vValue) Then | |
vKey = vValue | |
vValue = pvJsonMissing | |
End If | |
lIdx = .Pos | |
If Not pvJsonParse(uCtx, vValue, oValue) Then | |
.Pos = lIdx | |
vValue = Empty | |
Set oValue = Nothing | |
End If | |
Case 0, 44, 125 ' , } | |
If IsMissing(vValue) And oValue Is Nothing Then | |
If IsEmpty(vKey) Then | |
GoTo NoProp | |
End If | |
vValue = vKey | |
vKey = vbNullString | |
End If | |
If IsEmpty(vKey) Then | |
vKey = vbNullString | |
ElseIf IsNull(vKey) Then | |
vKey = "null" | |
End If | |
If Not oValue Is Nothing Then | |
#If USE_COLLECTION Then | |
oResult.Add oValue, vKey & "" | |
#Else | |
oResult.Add vKey & "", oValue | |
#End If | |
Else | |
#If USE_COLLECTION Then | |
oResult.Add vValue, vKey & "" | |
#Else | |
oResult.Add vKey & "", vValue | |
#End If | |
End If | |
NoProp: | |
If .LastChar = 0 Then | |
GoTo QH | |
ElseIf .LastChar <> 44 Then ' , | |
Exit Do | |
End If | |
vKey = Empty | |
vValue = pvJsonMissing | |
Set oValue = Nothing | |
Case Else | |
.Pos = .Pos - 1 | |
If Not pvJsonParse(uCtx, vValue, oValue) Then | |
GoTo QH | |
End If | |
End Select | |
Loop | |
Case 116, 84 ' "t", "T" | |
If Not ((.Text(.Pos + 0) Or &H20) = 114 And (.Text(.Pos + 1) Or &H20) = 117 And (.Text(.Pos + 2) Or &H20) = 101) Then | |
GoTo UnexpectedSymbol | |
End If | |
.Pos = .Pos + 3 | |
vResult = True | |
Case 102, 70 ' "f", "F" | |
If Not ((.Text(.Pos + 0) Or &H20) = 97 And (.Text(.Pos + 1) Or &H20) = 108 And (.Text(.Pos + 2) Or &H20) = 115 And (.Text(.Pos + 3) Or &H20) = 101) Then | |
GoTo UnexpectedSymbol | |
End If | |
.Pos = .Pos + 4 | |
vResult = False | |
Case 110, 78 ' "n", "N" | |
If Not ((.Text(.Pos + 0) Or &H20) = 117 And (.Text(.Pos + 1) Or &H20) = 108 And (.Text(.Pos + 2) Or &H20) = 108) Then | |
GoTo UnexpectedSymbol | |
End If | |
.Pos = .Pos + 3 | |
vResult = Null | |
Case 48 To 57, 43, 45, 46 ' 0-9 + - . | |
For lIdx = 0 To 1000 | |
Select Case .Text(.Pos + lIdx) | |
Case 48 To 57, 43, 45, 46, 101, 69, 120, 88, 97 To 102, 65 To 70 ' 0-9 + - . e E x X a-f A-F | |
Case Else | |
Exit For | |
End Select | |
Next | |
sText = Space$(lIdx + 1) | |
Call CopyMemory(ByVal StrPtr(sText), .Text(.Pos - 1), LenB(sText)) | |
If LCase$(Left$(sText, 2)) = "0x" Then | |
sText = "&H" & Mid$(sText, 3) | |
End If | |
On Error GoTo ErrorConvert | |
vResult = CDbl(sText) | |
On Error GoTo 0 | |
.Pos = .Pos + lIdx | |
Case 0 | |
If LenB(.Error) <> 0 Then | |
GoTo QH | |
End If | |
Case Else | |
GoTo UnexpectedSymbol | |
End Select | |
pvJsonParse = True | |
QH: | |
Exit Function | |
UnexpectedSymbol: | |
.Error = "Unexpected symbol '" & ChrW$(.LastChar) & "' at position " & .Pos | |
Exit Function | |
ErrorConvert: | |
.Error = Err.Description & " at position " & .Pos | |
End With | |
Exit Function | |
EH: | |
RaiseError FUNC_NAME | |
End Function | |
Private Function pvJsonGetChar(uCtx As JsonContext) As Integer | |
Const FUNC_NAME As String = "pvJsonGetChar" | |
Dim lIdx As Long | |
On Error GoTo EH | |
With uCtx | |
Do While .Pos <= UBound(.Text) | |
.LastChar = .Text(.Pos) | |
.Pos = .Pos + 1 | |
Select Case .LastChar | |
Case 0 | |
Exit Function | |
Case 9, 10, 13, 32 ' vbTab, vbCr, vbLf, " " | |
'--- do nothing | |
Case 47 ' / | |
Select Case .Text(.Pos) | |
Case 47 ' // | |
.Pos = .Pos + 1 | |
Do | |
.LastChar = .Text(.Pos) | |
.Pos = .Pos + 1 | |
If .LastChar = 0 Then | |
Exit Function | |
End If | |
Loop While Not (.LastChar = 10 Or .LastChar = 13) ' vbLf or vbCr | |
Case 42 ' /* | |
lIdx = .Pos + 1 | |
Do | |
.LastChar = .Text(lIdx) | |
lIdx = lIdx + 1 | |
If .LastChar = 0 Then | |
.Error = "Unterminated comment at position " & .Pos | |
Exit Function | |
End If | |
Loop While Not (.LastChar = 42 And .Text(lIdx) = 47) ' */ | |
.LastChar = .Text(lIdx) | |
.Pos = lIdx + 1 | |
Case Else | |
pvJsonGetChar = .LastChar | |
Exit Do | |
End Select | |
Case Else | |
pvJsonGetChar = .LastChar | |
Exit Do | |
End Select | |
Loop | |
End With | |
Exit Function | |
EH: | |
RaiseError FUNC_NAME | |
End Function | |
Private Function pvJsonGetString(uCtx As JsonContext) As String | |
Const FUNC_NAME As String = "pvJsonGetString" | |
Dim lIdx As Long | |
Dim nChar As Integer | |
Dim sText As String | |
On Error GoTo EH | |
With uCtx | |
For lIdx = 0 To &H7FFFFFFF | |
nChar = .Text(.Pos + lIdx) | |
Select Case nChar | |
Case 0, 34, 92 ' " \ | |
sText = Space$(lIdx) | |
Call CopyMemory(ByVal StrPtr(sText), .Text(.Pos), LenB(sText)) | |
pvJsonGetString = pvJsonGetString & sText | |
If nChar <> 92 Then ' \ | |
.Pos = .Pos + lIdx + 1 | |
Exit For | |
End If | |
lIdx = lIdx + 1 | |
nChar = .Text(.Pos + lIdx) | |
Select Case nChar | |
Case 0 | |
Exit For | |
Case 98 ' b | |
pvJsonGetString = pvJsonGetString & Chr$(8) | |
Case 102 ' f | |
pvJsonGetString = pvJsonGetString & Chr$(12) | |
Case 110 ' n | |
pvJsonGetString = pvJsonGetString & vbLf | |
Case 114 ' r | |
pvJsonGetString = pvJsonGetString & vbCr | |
Case 116 ' t | |
pvJsonGetString = pvJsonGetString & vbTab | |
Case 117 ' u | |
pvJsonGetString = pvJsonGetString & ChrW$(CLng("&H" & ChrW$(.Text(.Pos + lIdx + 1)) & ChrW$(.Text(.Pos + lIdx + 2)) & ChrW$(.Text(.Pos + lIdx + 3)) & ChrW$(.Text(.Pos + lIdx + 4)))) | |
lIdx = lIdx + 4 | |
Case 120 ' x | |
pvJsonGetString = pvJsonGetString & ChrW$(CLng("&H" & ChrW$(.Text(.Pos + lIdx + 1)) & ChrW$(.Text(.Pos + lIdx + 2)))) | |
lIdx = lIdx + 2 | |
Case Else | |
pvJsonGetString = pvJsonGetString & ChrW$(nChar) | |
End Select | |
.Pos = .Pos + lIdx + 1 | |
lIdx = -1 | |
End Select | |
Next | |
End With | |
Exit Function | |
EH: | |
RaiseError FUNC_NAME | |
End Function | |
Public Function JsonDump(vJson As Variant, Optional ByVal Level As Long, Optional ByVal Minimize As Boolean) As String | |
Const FUNC_NAME As String = "JsonDump" | |
Const STR_CODES As String = "\u0000|\u0001|\u0002|\u0003|\u0004|\u0005|\u0006|\u0007|\b|\t|\n|\u000B|\f|\r|\u000E|\u000F|\u0010|\u0011|\u0012|\u0013|\u0014|\u0015|\u0016|\u0017|\u0018|\u0019|\u001A|\u001B|\u001C|\u001D|\u001E|\u001F" | |
Const INDENT As Long = 4 | |
Static vTranscode As Variant | |
Dim vKeys As Variant | |
Dim vItems As Variant | |
Dim lIdx As Long | |
Dim lSize As Long | |
Dim sCompound As String | |
Dim sSpace As String | |
Dim lAsc As Long | |
On Error GoTo EH | |
Select Case VarType(vJson) | |
Case vbObject | |
sCompound = IIf(vJson.CompareMode = 0, "[]", "{}") | |
sSpace = IIf(Minimize, vbNullString, " ") | |
If vJson.Count = 0 Then | |
JsonDump = sCompound | |
Else | |
vKeys = vJson.Keys | |
vItems = vJson.Items | |
For lIdx = 0 To vJson.Count - 1 | |
vItems(lIdx) = JsonDump(vItems(lIdx), Level + 1, Minimize) | |
If vJson.CompareMode = 1 Then | |
vItems(lIdx) = JsonDump(vKeys(lIdx)) & ":" & sSpace & vItems(lIdx) | |
End If | |
lSize = lSize + Len(vItems(lIdx)) | |
Next | |
If lSize > 100 And Not Minimize Then | |
JsonDump = Left$(sCompound, 1) & vbCrLf & _ | |
Space$((Level + 1) * INDENT) & Join(vItems, "," & vbCrLf & Space$((Level + 1) * INDENT)) & vbCrLf & _ | |
Space$(Level * INDENT) & Right$(sCompound, 1) | |
Else | |
JsonDump = Left$(sCompound, 1) & sSpace & Join(vItems, "," & sSpace) & sSpace & Right$(sCompound, 1) | |
End If | |
End If | |
Case vbNull | |
JsonDump = "Null" | |
Case vbEmpty | |
JsonDump = "Empty" | |
Case vbString | |
'--- one-time initialization of transcoding array | |
If IsEmpty(vTranscode) Then | |
vTranscode = Split(STR_CODES, "|") | |
End If | |
For lIdx = 1 To Len(vJson) | |
lAsc = AscW(Mid$(vJson, lIdx, 1)) | |
If lAsc = 92 Or lAsc = 34 Then '--- \ and " | |
JsonDump = JsonDump & "\" & Chr$(lAsc) | |
ElseIf lAsc >= 32 And lAsc < 256 Then | |
JsonDump = JsonDump & Chr$(lAsc) | |
ElseIf lAsc >= 0 And lAsc < 32 Then | |
JsonDump = JsonDump & vTranscode(lAsc) | |
ElseIf Asc(Mid$(vJson, lIdx, 1)) <> 63 Then '--- ? | |
JsonDump = JsonDump & Chr$(Asc(Mid$(vJson, lIdx, 1))) | |
Else | |
JsonDump = JsonDump & "\u" & Right$("0000" & Hex(lAsc), 4) | |
End If | |
Next | |
JsonDump = """" & JsonDump & """" | |
Case Else | |
JsonDump = vJson & "" | |
End Select | |
Exit Function | |
EH: | |
PrintError FUNC_NAME | |
Resume Next | |
End Function |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment