diff --git a/JsonConverter.bas b/JsonConverter.bas index f3476b2..34e99af 100644 --- a/JsonConverter.bas +++ b/JsonConverter.bas @@ -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 @@ -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 @@ -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 @@ -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) @@ -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 @@ -342,7 +329,7 @@ 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 @@ -350,7 +337,7 @@ Public Function ConvertToJson(ByVal JsonValue As Variant, Optional ByVal Whitesp 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) @@ -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 @@ -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) @@ -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 @@ -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) @@ -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) @@ -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) @@ -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, ",", ".") @@ -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 @@ -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 @@ -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 @@ -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 @@ -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 @@ -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 ' @@ -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 diff --git a/specs/Specs.bas b/specs/Specs.bas index 6f0a28d..893f878 100644 --- a/specs/Specs.bas +++ b/specs/Specs.bas @@ -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"",""#$%&{|}~""]"