Skip to content

Inline clsStringAppend #101

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

Merged
merged 5 commits into from
Jun 7, 2018
Merged

Inline clsStringAppend #101

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
5 commits
Select commit Hold shift + click to select a range
17ceebe
json_BufferAppend replaced with clsStringAppend
PGS62 Jan 26, 2018
d79a44a
Remove test modules
timhall Jun 7, 2018
cf4e164
Inline clsStringAppend
timhall Jun 7, 2018
bc913ff
Cleanup
timhall Jun 7, 2018
45aff20
Fix failing test on Mac
timhall Jun 7, 2018
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
156 changes: 54 additions & 102 deletions JsonConverter.bas
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -140,19 +140,6 @@ End Type
#End If
' === End VBA-UTC

#If Mac Then
#ElseIf VBA7 Then

Private Declare PtrSafe Sub json_CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
(json_MemoryDestination As Any, json_MemorySource As Any, ByVal json_ByteLength As Long)

#Else

Private Declare Sub json_CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
(json_MemoryDestination As Any, json_MemorySource As Any, ByVal json_ByteLength As Long)

#End If

Private Type json_Options
' VBA only stores 15 significant digits, so any numbers larger than that are truncated
' This can lead to issues when BIGINT's are used (e.g. for Ids or Credit Cards), as they will be invalid above 15 digits
Expand Down Expand Up @@ -210,7 +197,7 @@ 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
Dim json_buffer As String
Dim json_Buffer As String
Dim json_BufferPosition As Long
Dim json_BufferLength As Long
Dim json_Index As Long
Expand Down Expand Up @@ -271,7 +258,7 @@ Public Function ConvertToJson(ByVal JsonValue As Variant, Optional ByVal Whitesp
End If

' Array
json_BufferAppend json_buffer, "[", json_BufferPosition, json_BufferLength
json_BufferAppend json_Buffer, "[", json_BufferPosition, json_BufferLength

On Error Resume Next

Expand All @@ -286,21 +273,21 @@ Public Function ConvertToJson(ByVal JsonValue As Variant, Optional ByVal Whitesp
json_IsFirstItem = False
Else
' Append comma to previous line
json_BufferAppend json_buffer, ",", json_BufferPosition, json_BufferLength
json_BufferAppend json_Buffer, ",", json_BufferPosition, json_BufferLength
End If

If json_LBound2D >= 0 And json_UBound2D >= 0 Then
' 2D Array
If json_PrettyPrint Then
json_BufferAppend json_buffer, vbNewLine, json_BufferPosition, json_BufferLength
json_BufferAppend json_Buffer, vbNewLine, json_BufferPosition, json_BufferLength
End If
json_BufferAppend json_buffer, json_Indentation & "[", json_BufferPosition, json_BufferLength
json_BufferAppend json_Buffer, json_Indentation & "[", json_BufferPosition, json_BufferLength

For json_Index2D = json_LBound2D To json_UBound2D
If json_IsFirstItem2D Then
json_IsFirstItem2D = False
Else
json_BufferAppend json_buffer, ",", json_BufferPosition, json_BufferLength
json_BufferAppend json_Buffer, ",", json_BufferPosition, json_BufferLength
End If

json_Converted = ConvertToJson(JsonValue(json_Index, json_Index2D), Whitespace, json_CurrentIndentation + 2)
Expand All @@ -317,14 +304,14 @@ Public Function ConvertToJson(ByVal JsonValue As Variant, Optional ByVal Whitesp
json_Converted = vbNewLine & json_InnerIndentation & json_Converted
End If

json_BufferAppend json_buffer, json_Converted, json_BufferPosition, json_BufferLength
json_BufferAppend json_Buffer, json_Converted, json_BufferPosition, json_BufferLength
Next json_Index2D

If json_PrettyPrint Then
json_BufferAppend json_buffer, vbNewLine, json_BufferPosition, json_BufferLength
json_BufferAppend json_Buffer, vbNewLine, json_BufferPosition, json_BufferLength
End If

json_BufferAppend json_buffer, json_Indentation & "]", json_BufferPosition, json_BufferLength
json_BufferAppend json_Buffer, json_Indentation & "]", json_BufferPosition, json_BufferLength
json_IsFirstItem2D = True
Else
' 1D Array
Expand All @@ -342,15 +329,15 @@ Public Function ConvertToJson(ByVal JsonValue As Variant, Optional ByVal Whitesp
json_Converted = vbNewLine & json_Indentation & json_Converted
End If

json_BufferAppend json_buffer, json_Converted, json_BufferPosition, json_BufferLength
json_BufferAppend json_Buffer, json_Converted, json_BufferPosition, json_BufferLength
End If
Next json_Index
End If

On Error GoTo 0

If json_PrettyPrint Then
json_BufferAppend json_buffer, vbNewLine, json_BufferPosition, json_BufferLength
json_BufferAppend json_Buffer, vbNewLine, json_BufferPosition, json_BufferLength

If VBA.VarType(Whitespace) = VBA.vbString Then
json_Indentation = VBA.String$(json_CurrentIndentation, Whitespace)
Expand All @@ -359,9 +346,9 @@ Public Function ConvertToJson(ByVal JsonValue As Variant, Optional ByVal Whitesp
End If
End If

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

ConvertToJson = json_BufferToString(json_buffer, json_BufferPosition, json_BufferLength)
ConvertToJson = json_BufferToString(json_Buffer, json_BufferPosition)

' Dictionary or Collection
Case VBA.vbObject
Expand All @@ -375,7 +362,7 @@ Public Function ConvertToJson(ByVal JsonValue As Variant, Optional ByVal Whitesp

' Dictionary
If VBA.TypeName(JsonValue) = "Dictionary" Then
json_BufferAppend json_buffer, "{", json_BufferPosition, json_BufferLength
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)
Expand All @@ -389,7 +376,7 @@ Public Function ConvertToJson(ByVal JsonValue As Variant, Optional ByVal Whitesp
If json_IsFirstItem Then
json_IsFirstItem = False
Else
json_BufferAppend json_buffer, ",", json_BufferPosition, json_BufferLength
json_BufferAppend json_Buffer, ",", json_BufferPosition, json_BufferLength
End If

If json_PrettyPrint Then
Expand All @@ -398,12 +385,12 @@ Public Function ConvertToJson(ByVal JsonValue As Variant, Optional ByVal Whitesp
json_Converted = """" & json_Key & """:" & json_Converted
End If

json_BufferAppend json_buffer, json_Converted, json_BufferPosition, json_BufferLength
json_BufferAppend json_Buffer, json_Converted, json_BufferPosition, json_BufferLength
End If
Next json_Key

If json_PrettyPrint Then
json_BufferAppend json_buffer, vbNewLine, json_BufferPosition, json_BufferLength
json_BufferAppend json_Buffer, vbNewLine, json_BufferPosition, json_BufferLength

If VBA.VarType(Whitespace) = VBA.vbString Then
json_Indentation = VBA.String$(json_CurrentIndentation, Whitespace)
Expand All @@ -412,16 +399,16 @@ Public Function ConvertToJson(ByVal JsonValue As Variant, Optional ByVal Whitesp
End If
End If

json_BufferAppend json_buffer, json_Indentation & "}", json_BufferPosition, json_BufferLength
json_BufferAppend json_Buffer, json_Indentation & "}", json_BufferPosition, json_BufferLength

' Collection
ElseIf VBA.TypeName(JsonValue) = "Collection" Then
json_BufferAppend json_buffer, "[", json_BufferPosition, json_BufferLength
json_BufferAppend json_Buffer, "[", json_BufferPosition, json_BufferLength
For Each json_Value In JsonValue
If json_IsFirstItem Then
json_IsFirstItem = False
Else
json_BufferAppend json_buffer, ",", json_BufferPosition, json_BufferLength
json_BufferAppend json_Buffer, ",", json_BufferPosition, json_BufferLength
End If

json_Converted = ConvertToJson(json_Value, Whitespace, json_CurrentIndentation + 1)
Expand All @@ -438,11 +425,11 @@ Public Function ConvertToJson(ByVal JsonValue As Variant, Optional ByVal Whitesp
json_Converted = vbNewLine & json_Indentation & json_Converted
End If

json_BufferAppend json_buffer, json_Converted, json_BufferPosition, json_BufferLength
json_BufferAppend json_Buffer, json_Converted, json_BufferPosition, json_BufferLength
Next json_Value

If json_PrettyPrint Then
json_BufferAppend json_buffer, vbNewLine, json_BufferPosition, json_BufferLength
json_BufferAppend json_Buffer, vbNewLine, json_BufferPosition, json_BufferLength

If VBA.VarType(Whitespace) = VBA.vbString Then
json_Indentation = VBA.String$(json_CurrentIndentation, Whitespace)
Expand All @@ -451,10 +438,10 @@ Public Function ConvertToJson(ByVal JsonValue As Variant, Optional ByVal Whitesp
End If
End If

json_BufferAppend json_buffer, json_Indentation & "]", json_BufferPosition, json_BufferLength
json_BufferAppend json_Buffer, json_Indentation & "]", json_BufferPosition, json_BufferLength
End If

ConvertToJson = json_BufferToString(json_buffer, json_BufferPosition, json_BufferLength)
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, ",", ".")
Expand Down Expand Up @@ -558,7 +545,7 @@ Private Function json_ParseString(json_String As String, ByRef json_Index As Lon
Dim json_Quote As String
Dim json_Char As String
Dim json_Code As String
Dim json_buffer As String
Dim json_Buffer As String
Dim json_BufferPosition As Long
Dim json_BufferLength As Long

Expand All @@ -579,36 +566,36 @@ Private Function json_ParseString(json_String As String, ByRef json_Index As Lon

Select Case json_Char
Case """", "\", "/", "'"
json_BufferAppend json_buffer, json_Char, json_BufferPosition, json_BufferLength
json_BufferAppend json_Buffer, json_Char, json_BufferPosition, json_BufferLength
json_Index = json_Index + 1
Case "b"
json_BufferAppend json_buffer, vbBack, json_BufferPosition, json_BufferLength
json_BufferAppend json_Buffer, vbBack, json_BufferPosition, json_BufferLength
json_Index = json_Index + 1
Case "f"
json_BufferAppend json_buffer, vbFormFeed, json_BufferPosition, json_BufferLength
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, vbCrLf, json_BufferPosition, json_BufferLength
json_Index = json_Index + 1
Case "r"
json_BufferAppend json_buffer, vbCr, json_BufferPosition, json_BufferLength
json_BufferAppend json_Buffer, vbCr, json_BufferPosition, json_BufferLength
json_Index = json_Index + 1
Case "t"
json_BufferAppend json_buffer, vbTab, json_BufferPosition, json_BufferLength
json_BufferAppend json_Buffer, vbTab, json_BufferPosition, json_BufferLength
json_Index = json_Index + 1
Case "u"
' Unicode character escape (e.g. \u00a9 = Copyright)
json_Index = json_Index + 1
json_Code = VBA.Mid$(json_String, json_Index, 4)
json_BufferAppend json_buffer, VBA.ChrW(VBA.Val("&h" + json_Code)), json_BufferPosition, json_BufferLength
json_BufferAppend json_Buffer, VBA.ChrW(VBA.Val("&h" + json_Code)), json_BufferPosition, json_BufferLength
json_Index = json_Index + 4
End Select
Case json_Quote
json_ParseString = json_BufferToString(json_buffer, json_BufferPosition, json_BufferLength)
json_ParseString = json_BufferToString(json_Buffer, json_BufferPosition)
json_Index = json_Index + 1
Exit Function
Case Else
json_BufferAppend json_buffer, json_Char, json_BufferPosition, json_BufferLength
json_BufferAppend json_Buffer, json_Char, json_BufferPosition, json_BufferLength
json_Index = json_Index + 1
End Select
Loop
Expand Down Expand Up @@ -694,7 +681,7 @@ Private Function json_Encode(ByVal json_Text As Variant) As String
Dim json_Index As Long
Dim json_Char As String
Dim json_AscCode As Long
Dim json_buffer As String
Dim json_Buffer As String
Dim json_BufferPosition As Long
Dim json_BufferLength As Long

Expand Down Expand Up @@ -743,10 +730,10 @@ Private Function json_Encode(ByVal json_Text As Variant) As String
json_Char = "\u" & VBA.Right$("0000" & VBA.Hex$(json_AscCode), 4)
End Select

json_BufferAppend json_buffer, json_Char, json_BufferPosition, json_BufferLength
json_BufferAppend json_Buffer, json_Char, json_BufferPosition, json_BufferLength
Next json_Index

json_Encode = json_BufferToString(json_buffer, json_BufferPosition, json_BufferLength)
json_Encode = json_BufferToString(json_Buffer, json_BufferPosition)
End Function

Private Function json_Peek(json_String As String, ByVal json_Index As Long, Optional json_NumberOfCharacters As Long = 1) As String
Expand All @@ -773,7 +760,6 @@ Private Function json_StringIsLargeNumber(json_String As Variant) As Boolean
' Length with be at least 16 characters and assume will be less than 100 characters
If json_Length >= 16 And json_Length <= 100 Then
Dim json_CharCode As String
Dim json_Index As Long

json_StringIsLargeNumber = True

Expand Down Expand Up @@ -819,13 +805,10 @@ Private Function json_ParseErrorMessage(json_String As String, ByRef json_Index
ErrorMessage
End Function

Private Sub json_BufferAppend(ByRef json_buffer As String, _
Private Sub json_BufferAppend(ByRef json_Buffer As String, _
ByRef json_Append As Variant, _
ByRef json_BufferPosition As Long, _
ByRef json_BufferLength As Long)
#If Mac Then
json_buffer = json_buffer & json_Append
#Else
' VBA can be slow to append strings due to allocating a new string for each append
' Instead of using the traditional append, allocate a large empty string and then copy string at append position
'
Expand All @@ -839,71 +822,40 @@ Private Sub json_BufferAppend(ByRef json_buffer As String, _
' Buffer: "abc "
' Buffer Length: 10
'
' Copy memory for "def" into buffer at position 3 (0-based)
' Put "def" into buffer at position 3 (0-based)
' Buffer: "abcdef "
'
' Approach based on cStringBuilder from vbAccelerator
' http://www.vbaccelerator.com/home/VB/Code/Techniques/RunTime_Debug_Tracing/VB6_Tracer_Utility_zip_cStringBuilder_cls.asp
'
' and clsStringAppend from Philip Swannell
' https://github.com/VBA-tools/VBA-JSON/pull/82

Dim json_AppendLength As Long
Dim json_LengthPlusPosition As Long

json_AppendLength = VBA.LenB(json_Append)
json_AppendLength = VBA.Len(json_Append)
json_LengthPlusPosition = json_AppendLength + json_BufferPosition

If json_LengthPlusPosition > json_BufferLength Then
' Appending would overflow buffer, add chunks until buffer is long enough
Dim json_TemporaryLength As Long

json_TemporaryLength = json_BufferLength
Do While json_TemporaryLength < json_LengthPlusPosition
' Initially, initialize string with 255 characters,
' then add large chunks (8192) after that
'
' Size: # Characters x 2 bytes / character
If json_TemporaryLength = 0 Then
json_TemporaryLength = json_TemporaryLength + 510
Else
json_TemporaryLength = json_TemporaryLength + 16384
End If
Loop
' Appending would overflow buffer, add chunk
' (double buffer length or append length, whichever is bigger)
Dim json_AddedLength As Long
json_AddedLength = IIf(json_AppendLength > json_BufferLength, json_AppendLength, json_BufferLength)

json_buffer = json_buffer & VBA.Space$((json_TemporaryLength - json_BufferLength) \ 2)
json_BufferLength = json_TemporaryLength
json_Buffer = json_Buffer & VBA.Space$(json_AddedLength)
json_BufferLength = json_BufferLength + json_AddedLength
End If

' Copy memory from append to buffer at buffer position
json_CopyMemory ByVal json_UnsignedAdd(StrPtr(json_buffer), _
json_BufferPosition), _
ByVal StrPtr(json_Append), _
json_AppendLength

' Note: Namespacing with VBA.Mid$ doesn't work properly here, throwing compile error:
' Function call on left-hand side of assignment must return Variant or Object
Mid$(json_Buffer, json_BufferPosition + 1, json_AppendLength) = CStr(json_Append)
json_BufferPosition = json_BufferPosition + json_AppendLength
#End If
End Sub

Private Function json_BufferToString(ByRef json_buffer As String, ByVal json_BufferPosition As Long, ByVal json_BufferLength As Long) As String
#If Mac Then
json_BufferToString = json_buffer
#Else
Private Function json_BufferToString(ByRef json_Buffer As String, ByVal json_BufferPosition As Long) As String
If json_BufferPosition > 0 Then
json_BufferToString = VBA.Left$(json_buffer, json_BufferPosition \ 2)
End If
#End If
End Function

#If VBA7 Then
Private Function json_UnsignedAdd(json_Start As LongPtr, json_Increment As Long) As LongPtr
#Else
Private Function json_UnsignedAdd(json_Start As Long, json_Increment As Long) As Long
#End If

If json_Start And &H80000000 Then
json_UnsignedAdd = json_Start + json_Increment
ElseIf (json_Start Or &H80000000) < -json_Increment Then
json_UnsignedAdd = json_Start + json_Increment
Else
json_UnsignedAdd = (json_Start + &H80000000) + (json_Increment + &H80000000)
json_BufferToString = VBA.Left$(json_Buffer, json_BufferPosition)
End If
End Function

Expand Down
2 changes: 1 addition & 1 deletion specs/Specs.bas
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -258,7 +258,7 @@ Public Function Specs() As SpecSuite

With Specs.It("should json-encode strings")
Dim Strings As Variant
Strings = Array("""\" & vbCrLf & vbTab & vbBack & vbFormFeed, ChrW(128) & ChrW(32767), "#$%&{|}~")
Strings = Array("""\" & vbCr & vbLf & vbTab & vbBack & vbFormFeed, ChrW(128) & ChrW(32767), "#$%&{|}~")

JsonString = JsonConverter.ConvertToJson(Strings)
.Expect(JsonString).ToEqual "[""\""\\\r\n\t\b\f"",""\u0080\u7FFF"",""#$%&{|}~""]"
Expand Down