Skip to content

Instantly share code, notes, and snippets.

@florentbr
Last active January 7, 2020 17:21
Show Gist options
  • Save florentbr/e89b6b77ede7cb92367698d86c830b20 to your computer and use it in GitHub Desktop.
Save florentbr/e89b6b77ede7cb92367698d86c830b20 to your computer and use it in GitHub Desktop.
Attribute VB_Name = "JsonIO"
'
' Version: 2019/09/10
'
' Module to read and write the JSON format (https://www.json.org)
' By default `{ }` is parsed as a `Dictionary` and `[ ]` as a base 1 Array.
'
' Usage:
'
' ' Parse a JSON string '
'
' Dim obj
'
' For Each obj In JsonIO.Parse("[{a:1, b:'v1'}, {a:2, b:'v2'}]")
' Debug.Print obj!a, obj!b
' Next
'
' ' Stringify to a JSON string '
'
' Dim obj As New Dictionary
' obj.Add "a", 1
' obj.Add "b", Array("v1", 786.99, Now)
'
' Debug.Print JsonIO.Stringify(obj, Indent:=2)
' Debug.Print JsonIO.Stringify(obj, Indent:=vbTab)
' Debug.Print JsonIO.Stringify(obj, Indent:=" ")
'
Option Explicit
Option Base 1
Private Type TReader
Text As String
Chars() As Byte
Length As Long
Index As Long
End Type
Private Type TWriter
Text As String
Index As Long
Indent As Long
Padding As Long
DateFormat As String
Escape(0 To 255) As Byte
End Type
Public Function Parse(Text) As Variant
Dim self As TReader
self.Text = Text
self.Length = Len(self.Text)
' to array, 1 byte per character, capped to 255 '
x_to_chars (Text), self.Chars
' parse recursively '
x_peek_next self
x_parse_item self, Parse
' check no more characters '
For self.Index = self.Index + 1 To self.Length
If self.Chars(self.Index) >= 33 Then Err.Raise x_err("unexpected character", self.Index)
Next
End Function
Public Function Stringify(Item, Optional ByVal Indent = "", Optional DateFormat As String) As String
Dim self As TWriter, i&
If VarType(Indent) <> vbString Then Indent = String$(Indent, " ")
self.Indent = Len(Indent)
self.Text = String$(1024, Indent & " ")
self.DateFormat = IIf(Len(DateFormat), DateFormat, "yyyy-mm-ddTHH:mm:ss")
self.Index = 1
' build the lookup table for the escaped characters '
For i = 0 To 31: self.Escape(i) = 117: Next ' controls -> \u.... '
For i = 127 To 159: self.Escape(i) = 117: Next ' controls -> \u.... '
self.Escape(8) = 98 ' BS -> \b '
self.Escape(9) = 116 ' TAB -> \t '
self.Escape(10) = 110 ' LF -> \n '
self.Escape(12) = 102 ' FF -> \f '
self.Escape(13) = 114 ' CR -> \r '
self.Escape(34) = 34 ' " -> \" '
self.Escape(92) = 92 ' \ -> \\ '
' write recusively '
x_write_item self, Item, Nothing
Stringify = Left$(self.Text, self.Index - 1)
End Function
Private Sub x_parse_item(self As TReader, out)
Select Case self.Chars(self.Index)
Case 34, 39: x_parse_text self, out ' quote '
Case 43, 45, 48 To 57: x_parse_number self, out ' +-0123456789 '
Case 91: x_parse_array self, out ' [ '
Case 123: x_parse_object self, out ' { '
Case 102: x_parse_value self, "false", False, out ' f '
Case 110: x_parse_value self, "null", Empty, out ' n '
Case 116: x_parse_value self, "true", True, out ' t '
Case Else: Err.Raise x_err("unexpected character", self.Index)
End Select
End Sub
Private Sub x_parse_text(self As TReader, out)
Dim Quote As Byte, i&, n&, buffer$
Quote = self.Chars(self.Index)
i = self.Index + 1
For self.Index = i To self.Length
Select Case self.Chars(self.Index)
Case Quote ' if end quoting '
out = Left$(buffer, n) & Mid$(self.Text, i, self.Index - i)
Exit Sub
Case 92 ' if escape '
n = n + self.Index - i
If n >= Len(buffer) Then buffer = buffer & String$(64 + n, 0)
Mid$(buffer, 1 + n - self.Index + i) = Mid$(self.Text, i, self.Index - i)
self.Index = self.Index + 1 ' next char '
If self.Index > self.Length Then Exit For
Select Case self.Chars(self.Index)
Case 98: Mid$(self.Text, self.Index) = vbBack ' \b -> BS '
Case 102: Mid$(self.Text, self.Index) = vbFormFeed ' \f -> FF '
Case 110: Mid$(self.Text, self.Index) = vbLf ' \n -> LF '
Case 114: Mid$(self.Text, self.Index) = vbCr ' \r -> CR '
Case 116: Mid$(self.Text, self.Index) = vbTab ' \t -> TAB '
Case 117:
self.Index = self.Index + 4
Mid$(self.Text, self.Index) = x_parse_unicode(self.Text, self.Index - 3) ' \u.... '
End Select
i = self.Index
End Select
Next
Err.Raise x_err("unexpected termination", self.Index)
End Sub
Private Function x_parse_unicode(Text As String, ByVal Index As Long) As String
On Error GoTo Catch
x_parse_unicode = ChrW$(CInt("&h" & Mid$(Text, Index, 4)))
Exit Function
Catch:
Err.Raise x_err("invalid unicode", Index)
End Function
Private Sub x_parse_object(self As TReader, out)
Dim Key$, Item
Set out = New Dictionary
Do
' parse key or `}` and exit '
Select Case x_peek_next(self)
Case 39, 34: x_parse_text self, Key ' continue if `'` or `"` '
Case 125: Exit Sub ' return if `}` '
Case Else: x_parse_key self, Key ' else key without quoting '
End Select
' parse `:` '
If x_peek_next(self) <> 58 Then Err.Raise x_err("unexpected char", self.Index) ' if not : '
' parse item '
x_peek_next self
x_parse_item self, Item
out.Add Key:=Key, Item:=Item
' parse either `,` or `}` '
Select Case x_peek_next(self)
Case 44: ' continue if , '
Case 125: Exit Sub ' return if `}` '
Case Else: Err.Raise x_err("unexpected char", self.Index)
End Select
Loop
End Sub
Private Sub x_parse_array(self As TReader, out)
Dim Item, n&
out = Array()
n = UBound(out)
Do While x_peek_next(self) - 93 ' while not `]` '
n = n + 1
If n > UBound(out) Then ReDim Preserve out(5 + n * 2)
x_parse_item self, out(n)
Select Case x_peek_next(self)
Case 44: ' continue if `,` '
Case 93: Exit Do ' break if `]` '
Case Else: Err.Raise x_err("unexpected char", self.Index)
End Select
Loop
If n - UBound(out) Then ReDim Preserve out(n)
End Sub
Private Sub x_parse_key(self As TReader, out$)
Dim i&
For i = self.Index To self.Length
Select Case self.Chars(i)
Case 0 To 33, 58: ' if control, space or colon '
out = Mid$(self.Text, self.Index, i - self.Index)
self.Index = i - 1
Exit Sub
End Select
Next
Err.Raise x_err("unexpected termination", self.Index)
End Sub
Private Sub x_parse_number(self As TReader, out)
Dim i&, n&
For i = self.Index To self.Length
Select Case self.Chars(i)
Case 48 To 57: n = n + 1 ' [0-9] '
Case 43, 45, 46: ' [+-.] '
Case 69, 101: n = 0 ' [eE] '
Case Else: Exit For ' other '
End Select
Next
out = Mid$(self.Text, self.Index, i - self.Index)
If n < 16 Then out = Conversion.Val(out)
self.Index = i - 1
End Sub
Private Sub x_parse_value(self As TReader, txt$, Val, out)
If InStr(self.Index, self.Text, txt) - self.Index Then Err.Raise x_err("invalid value", self.Index)
self.Index = self.Index + Len(txt) - 1
If IsObject(Val) Then Set out = Val Else out = Val
End Sub
Private Function x_peek_next(self As TReader) As Long
For self.Index = self.Index + 1 To self.Length
If self.Chars(self.Index) >= 33 Then ' if not basic latin control or space '
x_peek_next = self.Chars(self.Index)
Exit Function
End If
Next
Err.Raise x_err("unexpected termination", self.Index)
End Function
Private Sub x_to_chars(Vector() As Byte, Chars() As Byte)
Dim i&
ReDim Chars(1 To (UBound(Vector) + 1) \ 2)
For i = 1 To UBound(Vector) Step 2
If Vector(i) Then Chars(i \ 2 + 1) = 255 Else Chars(i \ 2 + 1) = Vector(i - 1)
Next
End Sub
Private Sub x_write_item(self As TWriter, Item, ByVal Ref As Object)
If VBA.IsObject(Item) Then
If Item Is Nothing Then
x_write self, "null"
ElseIf TypeOf Item Is Collection Then
x_write_array self, Item, Ref
Else
If Item Is Ref Then Err.Raise x_err("recursive reference")
Set Ref = Item
On Error GoTo CatchWriteObject
x_write_object self, Item.Keys, Item.Items, Ref
End If
Else
Select Case VBA.VarType(Item)
Case vbString: x_write_text self, CStr(Item)
Case 2 To 6, 17, 20: x_write self, Trim$(Conversion.str$(Item)) ' number '
Case vbDate: x_write_date self, CDate(Item)
Case vbBoolean: x_write self, LCase(Item)
Case Is >= vbArray: x_write_array self, Item, Ref
Case vbNull, vbEmpty: x_write self, "null"
Case Else: Err.Raise x_err("unsupported type " & VBA.typeName(Item))
End Select
End If
Exit Sub
CatchWriteObject:
If Err.Number = 438 Then Err.Raise x_err("unsupported object " & VBA.typeName(Item))
On Error GoTo 0
Resume
End Sub
Private Sub x_write_date(self As TWriter, Item As Date)
x_write self, """" & VBA.Format$(Item, self.DateFormat, 1, 1) & """"
End Sub
Private Sub x_write_text(self As TWriter, Item As String)
Dim Bytes() As Byte, i&, j&
x_write self, """"
Bytes = Item
For j = 0 To UBound(Bytes) Step 2
If Bytes(j + 1) Then ' skips upper byte is set '
ElseIf self.Escape(Bytes(j)) Then ' if char needs escaping '
x_write self, MidB$(Item, i + 1, j - i)
i = j + 2
If self.Escape(Bytes(j)) - 117 Then ' if simple escape (not `u`) '
x_write self, "\" & ChrW$(self.Escape(Bytes(j)))
Else ' unicode escaping '
x_write self, VBA.Hex$(&HFF0000 + Bytes(j))
Mid$(self.Text, self.Index - 6) = "\u"
End If
End If
Next
x_write self, MidB$(Item, i + 1, j - i)
x_write self, """"
End Sub
Private Sub x_write_object(self As TWriter, Keys, Items, ByVal Ref As Object)
Dim i&, some%
x_write self, "{"
self.Padding = self.Padding + self.Indent
For i = LBound(Keys) To UBound(Keys)
If some Then x_write self, ","
If self.Indent Then x_write_indent self
x_write_text self, CStr(Keys(i))
If self.Indent Then x_write self, ": " Else x_write self, ":"
x_write_item self, Items(i), Ref
some = True
Next
self.Padding = self.Padding - self.Indent
If some And self.Indent Then x_write_indent self
x_write self, "}"
End Sub
Private Sub x_write_array(self As TWriter, Items, ByVal Ref As Object)
Dim Item, some%
x_write self, "["
self.Padding = self.Padding + self.Indent
For Each Item In Items
If some Then x_write self, ","
If self.Indent Then x_write_indent self
x_write_item self, Item, Ref
some = True
Next
self.Padding = self.Padding - self.Indent
If some And self.Indent Then x_write_indent self
x_write self, "]"
End Sub
Private Sub x_write_indent(self As TWriter)
self.Index = self.Index + self.Padding + 1
If self.Index >= Len(self.Text) Then x_increase_buffer self
Mid$(self.Text, self.Index - self.Padding - 1) = vbLf
End Sub
Private Sub x_write(self As TWriter, str As String)
self.Index = self.Index + Len(str)
If self.Index >= Len(self.Text) Then x_increase_buffer self
Mid$(self.Text, self.Index - Len(str)) = str
End Sub
Private Sub x_increase_buffer(self As TWriter)
self.Text = self.Text & VBA.String$(self.Index, VBA.Right$(self.Text, 1))
End Sub
Private Function x_err(Message$, Optional i As Long) As Long
x_err = 5
Err.Source = "Json"
Err.Number = x_err
Err.Description = "Json, " & Message & IIf(i, " at " & i, "")
End Function
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment