Skip to content

Add option to preserve Unicode #168

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Open
joyfullservice wants to merge 4 commits into
base: master
Choose a base branch
from
Open

Add option to preserve Unicode #168

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
4 commits
Select commit Hold shift + click to select a range
0ff1ad0
Add option to preserve Unicode
joyfullservice May 25, 2020
45966b6
Fix Line Feed character parsing in multiline value
joyfullservice Jul 24, 2023
4f70c8e
Improve accuracy of Unicode range
joyfullservice May 17, 2025
c89dda4
perf: speed up ConvertToJson without changing serialized bytes
joyfullservice Sep 16, 2026
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
111 changes: 90 additions & 21 deletions JsonConverter.bas
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -154,6 +154,9 @@ Private Type json_Options

' The solidus (/) is not required to be escaped, use this option to escape them as \/ in ConvertToJson
EscapeSolidus As Boolean

' Allow Unicode characters in JSON text. Set to True to use native Unicode or false for escaped values.
AllowUnicodeChars As Boolean
End Type
Public JsonOptions As json_Options

Expand Down Expand Up @@ -197,6 +200,23 @@ End Function
' @return {String}
''
Public Function ConvertToJson(ByVal JsonValue As Variant, Optional ByVal Whitespace As Variant, Optional ByVal json_CurrentIndentation As Long = 0) As String
ConvertToJson = json_ConvertToJson(JsonValue, Whitespace, json_CurrentIndentation, True)
End Function

''
' Benchmark-only reference path that uses the original TypeName dispatch and
' per-character encoder. Production callers should use ConvertToJson.
'
' @method ConvertToJsonReference
' @param {Variant} JsonValue (Dictionary, Collection, or Array)
' @param {Integer|String} Whitespace "Pretty" print json with given number of spaces per indentation (Integer) or given string
' @return {String}
''
Public Function ConvertToJsonReference(ByVal JsonValue As Variant, Optional ByVal Whitespace As Variant) As String
ConvertToJsonReference = json_ConvertToJson(JsonValue, Whitespace, 0, False)
End Function

Private Function json_ConvertToJson(ByVal JsonValue As Variant, Optional ByVal Whitespace As Variant, Optional ByVal json_CurrentIndentation As Long = 0, Optional ByVal json_UseFastPaths As Boolean = True) As String
Dim json_Buffer As String
Dim json_BufferPosition As Long
Dim json_BufferLength As Long
Expand All @@ -216,6 +236,7 @@ Public Function ConvertToJson(ByVal JsonValue As Variant, Optional ByVal Whitesp
Dim json_PrettyPrint As Boolean
Dim json_Indentation As String
Dim json_InnerIndentation As String
Dim json_ObjectType As Long

json_LBound = -1
json_UBound = -1
Expand All @@ -227,24 +248,24 @@ Public Function ConvertToJson(ByVal JsonValue As Variant, Optional ByVal Whitesp

Select Case VBA.VarType(JsonValue)
Case VBA.vbNull
ConvertToJson = "null"
json_ConvertToJson = "null"
Case VBA.vbDate
' Date
json_DateStr = ConvertToIso(VBA.CDate(JsonValue))

ConvertToJson = """" & json_DateStr & """"
json_ConvertToJson = """" & json_DateStr & """"
Case VBA.vbString
' String (or large number encoded as string)
If Not JsonOptions.UseDoubleForLargeNumbers And json_StringIsLargeNumber(JsonValue) Then
ConvertToJson = JsonValue
json_ConvertToJson = JsonValue
Else
ConvertToJson = """" & json_Encode(JsonValue) & """"
json_ConvertToJson = """" & json_Encode(JsonValue, json_UseFastPaths) & """"
End If
Case VBA.vbBoolean
If JsonValue Then
ConvertToJson = "true"
json_ConvertToJson = "true"
Else
ConvertToJson = "false"
json_ConvertToJson = "false"
End If
Case VBA.vbArray To VBA.vbArray + VBA.vbByte
If json_PrettyPrint Then
Expand Down Expand Up @@ -290,7 +311,7 @@ Public Function ConvertToJson(ByVal JsonValue As Variant, Optional ByVal Whitesp
json_BufferAppend json_Buffer, ",", json_BufferPosition, json_BufferLength
End If

json_Converted = ConvertToJson(JsonValue(json_Index, json_Index2D), Whitespace, json_CurrentIndentation + 2)
json_Converted = json_ConvertToJson(JsonValue(json_Index, json_Index2D), Whitespace, json_CurrentIndentation + 2, json_UseFastPaths)

' For Arrays/Collections, undefined (Empty/Nothing) is treated as null
If json_Converted = "" Then
Expand All @@ -315,7 +336,7 @@ Public Function ConvertToJson(ByVal JsonValue As Variant, Optional ByVal Whitesp
json_IsFirstItem2D = True
Else
' 1D Array
json_Converted = ConvertToJson(JsonValue(json_Index), Whitespace, json_CurrentIndentation + 1)
json_Converted = json_ConvertToJson(JsonValue(json_Index), Whitespace, json_CurrentIndentation + 1, json_UseFastPaths)

' For Arrays/Collections, undefined (Empty/Nothing) is treated as null
If json_Converted = "" Then
Expand Down Expand Up @@ -348,7 +369,7 @@ Public Function ConvertToJson(ByVal JsonValue As Variant, Optional ByVal Whitesp

json_BufferAppend json_Buffer, json_Indentation & "]", json_BufferPosition, json_BufferLength

ConvertToJson = json_BufferToString(json_Buffer, json_BufferPosition)
json_ConvertToJson = json_BufferToString(json_Buffer, json_BufferPosition)

' Dictionary or Collection
Case VBA.vbObject
Expand All @@ -360,12 +381,26 @@ Public Function ConvertToJson(ByVal JsonValue As Variant, Optional ByVal Whitesp
End If
End If

If json_UseFastPaths Then
If TypeOf JsonValue Is Dictionary Then
json_ObjectType = 1
ElseIf TypeOf JsonValue Is Collection Then
json_ObjectType = 2
End If
Else
If VBA.TypeName(JsonValue) = "Dictionary" Then
json_ObjectType = 1
ElseIf VBA.TypeName(JsonValue) = "Collection" Then
json_ObjectType = 2
End If
End If

' Dictionary
If VBA.TypeName(JsonValue) = "Dictionary" Then
If json_ObjectType = 1 Then
json_BufferAppend json_Buffer, "{", json_BufferPosition, json_BufferLength
For Each json_Key In JsonValue.Keys
' For Objects, undefined (Empty/Nothing) is not added to object
json_Converted = ConvertToJson(JsonValue(json_Key), Whitespace, json_CurrentIndentation + 1)
json_Converted = json_ConvertToJson(JsonValue(json_Key), Whitespace, json_CurrentIndentation + 1, json_UseFastPaths)
If json_Converted = "" Then
json_SkipItem = json_IsUndefined(JsonValue(json_Key))
Else
Expand Down Expand Up @@ -402,7 +437,7 @@ Public Function ConvertToJson(ByVal JsonValue As Variant, Optional ByVal Whitesp
json_BufferAppend json_Buffer, json_Indentation & "}", json_BufferPosition, json_BufferLength

' Collection
ElseIf VBA.TypeName(JsonValue) = "Collection" Then
ElseIf json_ObjectType = 2 Then
json_BufferAppend json_Buffer, "[", json_BufferPosition, json_BufferLength
For Each json_Value In JsonValue
If json_IsFirstItem Then
Expand All @@ -411,7 +446,7 @@ Public Function ConvertToJson(ByVal JsonValue As Variant, Optional ByVal Whitesp
json_BufferAppend json_Buffer, ",", json_BufferPosition, json_BufferLength
End If

json_Converted = ConvertToJson(json_Value, Whitespace, json_CurrentIndentation + 1)
json_Converted = json_ConvertToJson(json_Value, Whitespace, json_CurrentIndentation + 1, json_UseFastPaths)

' For Arrays/Collections, undefined (Empty/Nothing) is treated as null
If json_Converted = "" Then
Expand Down Expand Up @@ -441,15 +476,15 @@ Public Function ConvertToJson(ByVal JsonValue As Variant, Optional ByVal Whitesp
json_BufferAppend json_Buffer, json_Indentation & "]", json_BufferPosition, json_BufferLength
End If

ConvertToJson = json_BufferToString(json_Buffer, json_BufferPosition)
json_ConvertToJson = json_BufferToString(json_Buffer, json_BufferPosition)
Case VBA.vbInteger, VBA.vbLong, VBA.vbSingle, VBA.vbDouble, VBA.vbCurrency, VBA.vbDecimal
' Number (use decimals for numbers)
ConvertToJson = VBA.Replace(JsonValue, ",", ".")
json_ConvertToJson = VBA.Replace(JsonValue, ",", ".")
Case Else
' vbEmpty, vbError, vbDataObject, vbByte, vbUserDefinedType
' Use VBA's built-in to-string
On Error Resume Next
ConvertToJson = JsonValue
json_ConvertToJson = JsonValue
On Error GoTo 0
End Select
End Function
Expand Down Expand Up @@ -575,7 +610,7 @@ Private Function json_ParseString(json_String As String, ByRef json_Index As Lon
json_BufferAppend json_Buffer, vbFormFeed, json_BufferPosition, json_BufferLength
json_Index = json_Index + 1
Case "n"
json_BufferAppend json_Buffer, vbCrLf, json_BufferPosition, json_BufferLength
json_BufferAppend json_Buffer, vbLf, json_BufferPosition, json_BufferLength
json_Index = json_Index + 1
Case "r"
json_BufferAppend json_Buffer, vbCr, json_BufferPosition, json_BufferLength
Expand Down Expand Up @@ -675,18 +710,47 @@ Private Function json_IsUndefined(ByVal json_Value As Variant) As Boolean
End Select
End Function

Private Function json_Encode(ByVal json_Text As Variant) As String
Private Function json_Encode(ByVal json_Text As Variant, Optional ByVal json_UseFastPath As Boolean = True) As String
' Reference: http://www.ietf.org/rfc/rfc4627.txt
' Escape: ", \, /, backspace, form feed, line feed, carriage return, tab
Dim json_Index As Long
Dim json_Length As Long
Dim json_Char As String
Dim json_AscCode As Long
Dim json_String As String
Dim json_Buffer As String
Dim json_BufferPosition As Long
Dim json_BufferLength As Long
Dim json_Bytes() As Byte

For json_Index = 1 To VBA.Len(json_Text)
json_Char = VBA.Mid$(json_Text, json_Index, 1)
json_String = VBA.CStr(json_Text)
json_Length = VBA.Len(json_String)
If json_Length = 0 Then Exit Function

' Most keys and values need no escaping. Scan their UTF-16 code units without
' allocating a one-character String for each position, then return the original
' String directly. Fall through to the established encoder on the first escape.
If json_UseFastPath Then
json_Bytes = json_String
For json_Index = 0 To UBound(json_Bytes) - 1 Step 2
json_AscCode = CLng(json_Bytes(json_Index)) + _
(CLng(json_Bytes(json_Index + 1)) * 256)
Select Case json_AscCode
Case 0 To 31, 34, 92, 127 To 159
GoTo BuildEscaped
Case 47
If JsonOptions.EscapeSolidus Then GoTo BuildEscaped
Case 160 To 65535
If Not JsonOptions.AllowUnicodeChars Then GoTo BuildEscaped
End Select
Next json_Index
json_Encode = json_String
Exit Function
End If

BuildEscaped:
For json_Index = 1 To json_Length
json_Char = VBA.Mid$(json_String, json_Index, 1)
json_AscCode = VBA.AscW(json_Char)

' When AscW returns a negative number, it returns the twos complement form of that number.
Expand Down Expand Up @@ -725,9 +789,14 @@ Private Function json_Encode(ByVal json_Text As Variant) As String
Case 9
' tab -> 9 -> \t
json_Char = "\t"
Case 0 To 31, 127 To 65535
Case 0 To 31, 127 To 159
' Non-ascii characters -> convert to 4-digit hex
json_Char = "\u" & VBA.Right$("0000" & VBA.Hex$(json_AscCode), 4)
Case 160 To 65535
' Unicode character range
If Not JsonOptions.AllowUnicodeChars Then
json_Char = "\u" & VBA.Right$("0000" & VBA.Hex$(json_AscCode), 4)
End If
End Select

json_BufferAppend json_Buffer, json_Char, json_BufferPosition, json_BufferLength
Expand Down
37 changes: 37 additions & 0 deletions specs/Specs.bas
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -380,6 +380,43 @@ Public Function Specs() As SpecSuite
"]"
End With

With Specs.It("should match reference serializer output")
Dim PreviousAllowUnicode As Boolean
Dim PreviousEscapeSolidus As Boolean
Dim Payload As Object
Dim Nested As Object
Dim Items As Collection

PreviousAllowUnicode = JsonConverter.JsonOptions.AllowUnicodeChars
PreviousEscapeSolidus = JsonConverter.JsonOptions.EscapeSolidus

Set Payload = New Dictionary
Set Nested = New Dictionary
Set Items = New Collection
Nested.Add "enabled", True
Nested.Add "count", 2&
Items.Add "alpha"
Items.Add "quote"" slash/ backslash\" & vbTab & ChrW(233) & ChrW(127)
Items.Add Null
Payload.Add "name", "example"
Payload.Add "child", Nested
Payload.Add "items", Items
Payload.Add "empty", ""

JsonConverter.JsonOptions.AllowUnicodeChars = True
JsonConverter.JsonOptions.EscapeSolidus = False
.Expect(JsonConverter.ConvertToJson(Payload)).ToEqual JsonConverter.ConvertToJsonReference(Payload)
.Expect(JsonConverter.ConvertToJson(Payload, 2)).ToEqual JsonConverter.ConvertToJsonReference(Payload, 2)

JsonConverter.JsonOptions.AllowUnicodeChars = False
JsonConverter.JsonOptions.EscapeSolidus = True
.Expect(JsonConverter.ConvertToJson(Payload)).ToEqual JsonConverter.ConvertToJsonReference(Payload)
.Expect(JsonConverter.ConvertToJson(Payload, VBA.vbTab)).ToEqual JsonConverter.ConvertToJsonReference(Payload, VBA.vbTab)

JsonConverter.JsonOptions.AllowUnicodeChars = PreviousAllowUnicode
JsonConverter.JsonOptions.EscapeSolidus = PreviousEscapeSolidus
End With

' ============================================= '
' Errors
' ============================================= '
Expand Down