Skip to content

json_BufferAppend replaced with clsStringAppend #82

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

Closed
wants to merge 1 commit into from
Closed

json_BufferAppend replaced with clsStringAppend #82

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
1 commit
Select commit
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
184 changes: 43 additions & 141 deletions JsonConverter.bas
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -140,18 +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
Expand Down Expand Up @@ -210,9 +198,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_BufferPosition As Long
Dim json_BufferLength As Long
Dim cSA As New clsStringAppend
Dim json_Index As Long
Dim json_LBound As Long
Dim json_UBound As Long
Expand Down Expand Up @@ -271,7 +257,7 @@ Public Function ConvertToJson(ByVal JsonValue As Variant, Optional ByVal Whitesp
End If

' Array
json_BufferAppend json_buffer, "[", json_BufferPosition, json_BufferLength
cSA.Append "["

On Error Resume Next

Expand All @@ -286,21 +272,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
cSA.Append ","
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
cSA.Append vbNewLine
End If
json_BufferAppend json_buffer, json_Indentation & "[", json_BufferPosition, json_BufferLength
cSA.Append json_Indentation & "["

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

json_Converted = ConvertToJson(JsonValue(json_Index, json_Index2D), Whitespace, json_CurrentIndentation + 2)
Expand All @@ -317,14 +303,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
cSA.Append json_Converted
Next json_Index2D

If json_PrettyPrint Then
json_BufferAppend json_buffer, vbNewLine, json_BufferPosition, json_BufferLength
cSA.Append vbNewLine
End If

json_BufferAppend json_buffer, json_Indentation & "]", json_BufferPosition, json_BufferLength
cSA.Append json_Indentation & "]"
json_IsFirstItem2D = True
Else
' 1D Array
Expand All @@ -342,15 +328,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
cSA.Append json_Converted
End If
Next json_Index
End If

On Error GoTo 0

If json_PrettyPrint Then
json_BufferAppend json_buffer, vbNewLine, json_BufferPosition, json_BufferLength
cSA.Append vbNewLine

If VBA.VarType(Whitespace) = VBA.vbString Then
json_Indentation = VBA.String$(json_CurrentIndentation, Whitespace)
Expand All @@ -359,9 +345,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
cSA.Append json_Indentation & "]"

ConvertToJson = json_BufferToString(json_buffer, json_BufferPosition, json_BufferLength)
ConvertToJson = cSA.Report

' Dictionary or Collection
Case VBA.vbObject
Expand All @@ -375,7 +361,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
cSA.Append "{"
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 +375,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
cSA.Append ","
End If

If json_PrettyPrint Then
Expand All @@ -398,12 +384,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
cSA.Append json_Converted
End If
Next json_Key

If json_PrettyPrint Then
json_BufferAppend json_buffer, vbNewLine, json_BufferPosition, json_BufferLength
cSA.Append vbNewLine

If VBA.VarType(Whitespace) = VBA.vbString Then
json_Indentation = VBA.String$(json_CurrentIndentation, Whitespace)
Expand All @@ -412,16 +398,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
cSA.Append json_Indentation & "}"

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

json_Converted = ConvertToJson(json_Value, Whitespace, json_CurrentIndentation + 1)
Expand All @@ -438,11 +424,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
cSA.Append json_Converted
Next json_Value

If json_PrettyPrint Then
json_BufferAppend json_buffer, vbNewLine, json_BufferPosition, json_BufferLength
cSA.Append vbNewLine

If VBA.VarType(Whitespace) = VBA.vbString Then
json_Indentation = VBA.String$(json_CurrentIndentation, Whitespace)
Expand All @@ -451,10 +437,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
cSA.Append json_Indentation & "]"
End If

ConvertToJson = json_BufferToString(json_buffer, json_BufferPosition, json_BufferLength)
ConvertToJson = cSA.Report
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,9 +544,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_BufferPosition As Long
Dim json_BufferLength As Long
Dim cSA As New clsStringAppend

json_SkipSpaces json_String, json_Index

Expand All @@ -579,36 +563,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
cSA.Append json_Char
json_Index = json_Index + 1
Case "b"
json_BufferAppend json_buffer, vbBack, json_BufferPosition, json_BufferLength
cSA.Append vbBack
json_Index = json_Index + 1
Case "f"
json_BufferAppend json_buffer, vbFormFeed, json_BufferPosition, json_BufferLength
cSA.Append vbFormFeed
json_Index = json_Index + 1
Case "n"
json_BufferAppend json_buffer, vbCrLf, json_BufferPosition, json_BufferLength
cSA.Append vbCrLf
json_Index = json_Index + 1
Case "r"
json_BufferAppend json_buffer, vbCr, json_BufferPosition, json_BufferLength
cSA.Append vbCr
json_Index = json_Index + 1
Case "t"
json_BufferAppend json_buffer, vbTab, json_BufferPosition, json_BufferLength
cSA.Append vbTab
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
cSA.Append VBA.ChrW(VBA.Val("&h" + json_Code))
json_Index = json_Index + 4
End Select
Case json_Quote
json_ParseString = json_BufferToString(json_buffer, json_BufferPosition, json_BufferLength)
json_ParseString = cSA.Report
json_Index = json_Index + 1
Exit Function
Case Else
json_BufferAppend json_buffer, json_Char, json_BufferPosition, json_BufferLength
cSA.Append json_Char
json_Index = json_Index + 1
End Select
Loop
Expand Down Expand Up @@ -694,9 +678,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_BufferPosition As Long
Dim json_BufferLength As Long
Dim cSA As New clsStringAppend

For json_Index = 1 To VBA.Len(json_Text)
json_Char = VBA.Mid$(json_Text, json_Index, 1)
Expand Down Expand Up @@ -743,10 +725,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
cSA.Append json_Char
Next json_Index

json_Encode = json_BufferToString(json_buffer, json_BufferPosition, json_BufferLength)
json_Encode = cSA.Report
End Function

Private Function json_Peek(json_String As String, ByVal json_Index As Long, Optional json_NumberOfCharacters As Long = 1) As String
Expand Down Expand Up @@ -819,93 +801,7 @@ Private Function json_ParseErrorMessage(json_String As String, ByRef json_Index
ErrorMessage
End Function

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
'
' Example:
' Buffer: "abc "
' Append: "def"
' Buffer Position: 3
' Buffer Length: 5
'
' Buffer position + Append length > Buffer length -> Append chunk of blank space to buffer
' Buffer: "abc "
' Buffer Length: 10
'
' Copy memory for "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

Dim json_AppendLength As Long
Dim json_LengthPlusPosition As Long

json_AppendLength = VBA.LenB(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

json_buffer = json_buffer & VBA.Space$((json_TemporaryLength - json_BufferLength) \ 2)
json_BufferLength = json_TemporaryLength
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

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
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)
End If
End Function

''
' VBA-UTC v1.0.3
Expand Down Expand Up @@ -1169,3 +1065,9 @@ Private Function utc_SystemTimeToDate(utc_Value As utc_SYSTEMTIME) As Date
End Function

#End If






Loading