Merge pull request #101 from VBA-tools/append

timhall · web-flow · commit 284dc7242407 · 2018-06-07T10:49:23.000-04:00
Inline clsStringAppend
diff --git 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,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)
@@ -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
@@ -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"",""#$%&{|}~""]"
