Skip to content

Commit 4e28101

Browse files
timhalltimhall
committed
Merge pull request #16 from VBA-tools/add-options
Add Options
2 parents 9b3ecf8 + 75609cd commit 4e28101

File tree

3 files changed

+102
-39
lines changed

3 files changed

+102
-39
lines changed

‎JsonConverter.bas

Lines changed: 69 additions & 35 deletions
Original file line numberDiff line numberDiff line change
@@ -47,10 +47,14 @@ Attribute VB_Name = "JsonConverter"
4747
' === VBA-UTC Headers
4848
#If Mac Then
4949

50-
Private Declare Function utc_popen Lib "libc.dylib" Alias "popen" (ByVal utc_Command As String, ByVal utc_Mode As String) As Long
51-
Private Declare Function utc_pclose Lib "libc.dylib" Alias "pclose" (ByVal utc_File As Long) As Long
52-
Private Declare Function utc_fread Lib "libc.dylib" Alias "fread" (ByVal utc_Buffer As String, ByVal utc_Size As Long, ByVal utc_Number As Long, ByVal utc_File As Long) As Long
53-
Private Declare Function utc_feof Lib "libc.dylib" Alias "feof" (ByVal utc_File As Long) As Long
50+
Private Declare Function utc_popen Lib "libc.dylib" Alias "popen" _
51+
(ByVal utc_Command As String, ByVal utc_Mode As String) As Long
52+
Private Declare Function utc_pclose Lib "libc.dylib" Alias "pclose" _
53+
(ByVal utc_File As Long) As Long
54+
Private Declare Function utc_fread Lib "libc.dylib" Alias "fread" _
55+
(ByVal utc_Buffer As String, ByVal utc_Size As Long, ByVal utc_Number As Long, ByVal utc_File As Long) As Long
56+
Private Declare Function utc_feof Lib "libc.dylib" Alias "feof" _
57+
(ByVal utc_File As Long) As Long
5458

5559
#ElseIf VBA7 Then
5660

@@ -121,6 +125,19 @@ Private Declare Sub json_CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
121125

122126
#End If
123127

128+
Private Type json_Options
129+
' VBA only stores 15 significant digits, so any numbers larger than that are truncated
130+
' 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
131+
' See: http://support.microsoft.com/kb/269370
132+
'
133+
' By default, VBA-JSON will use String for numbers longer than 15 characters that contain only digits
134+
' to override set `JsonConverter.JsonOptions.UseDoubleForLargeNumbers = True`
135+
UseDoubleForLargeNumbers As Boolean
136+
AllowUnquotedKeys As Boolean
137+
EscapeSolidus As Boolean
138+
End Type
139+
Public JsonOptions As json_Options
140+
124141
' ============================================= '
125142
' Public Methods
126143
' ============================================= '
@@ -133,7 +150,7 @@ Private Declare Sub json_CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
133150
' @return {Object} (Dictionary or Collection)
134151
' @throws 10001 - JSON parse error
135152
''
136-
Public Function ParseJson(ByVal json_String As String, Optional json_ConvertLargeNumbersToString As Boolean = True) As Object
153+
Public Function ParseJson(ByVal json_String As String) As Object
137154
Dim json_Index As Long
138155
json_Index = 1
139156

@@ -143,9 +160,9 @@ Public Function ParseJson(ByVal json_String As String, Optional json_ConvertLarg
143160
json_SkipSpaces json_String, json_Index
144161
Select Case VBA.Mid$(json_String, json_Index, 1)
145162
Case "{"
146-
Set ParseJson = json_ParseObject(json_String, json_Index, json_ConvertLargeNumbersToString)
163+
Set ParseJson = json_ParseObject(json_String, json_Index)
147164
Case "["
148-
Set ParseJson = json_ParseArray(json_String, json_Index, json_ConvertLargeNumbersToString)
165+
Set ParseJson = json_ParseArray(json_String, json_Index)
149166
Case Else
150167
' Error: Invalid JSON string
151168
Err.Raise 10001, "JSONConverter", json_ParseErrorMessage(json_String, json_Index, "Expecting '{' or '['")
@@ -159,7 +176,7 @@ End Function
159176
' @param {Variant} json_DictionaryCollectionOrArray (Dictionary, Collection, or Array)
160177
' @return {String}
161178
''
162-
Public Function ConvertToJson(ByVal json_DictionaryCollectionOrArray As Variant, Optional json_ConvertLargeNumbersFromString As Boolean = True) As String
179+
Public Function ConvertToJson(ByVal json_DictionaryCollectionOrArray As Variant) As String
163180
Dim json_buffer As String
164181
Dim json_BufferPosition As Long
165182
Dim json_BufferLength As Long
@@ -192,7 +209,7 @@ Public Function ConvertToJson(ByVal json_DictionaryCollectionOrArray As Variant,
192209
ConvertToJson = """" & json_DateStr & """"
193210
Case VBA.vbString
194211
' String (or large number encoded as string)
195-
If json_ConvertLargeNumbersFromString And json_StringIsLargeNumber(json_DictionaryCollectionOrArray) Then
212+
If Not JsonConverter.JsonOptions.UseDoubleForLargeNumbers And json_StringIsLargeNumber(json_DictionaryCollectionOrArray) Then
196213
ConvertToJson = json_DictionaryCollectionOrArray
197214
Else
198215
ConvertToJson = """" & json_Encode(json_DictionaryCollectionOrArray) & """"
@@ -233,17 +250,15 @@ Public Function ConvertToJson(ByVal json_DictionaryCollectionOrArray As Variant,
233250
End If
234251

235252
json_BufferAppend json_buffer, _
236-
ConvertToJson(json_DictionaryCollectionOrArray(json_Index, json_Index2D), _
237-
json_ConvertLargeNumbersFromString), _
253+
ConvertToJson(json_DictionaryCollectionOrArray(json_Index, json_Index2D)), _
238254
json_BufferPosition, json_BufferLength
239255
Next json_Index2D
240256

241257
json_BufferAppend json_buffer, "]", json_BufferPosition, json_BufferLength
242258
json_IsFirstItem2D = True
243259
Else
244260
json_BufferAppend json_buffer, _
245-
ConvertToJson(json_DictionaryCollectionOrArray(json_Index), _
246-
json_ConvertLargeNumbersFromString), _
261+
ConvertToJson(json_DictionaryCollectionOrArray(json_Index)), _
247262
json_BufferPosition, json_BufferLength
248263
End If
249264
Next json_Index
@@ -268,7 +283,7 @@ Public Function ConvertToJson(ByVal json_DictionaryCollectionOrArray As Variant,
268283
End If
269284

270285
json_BufferAppend json_buffer, _
271-
"""" & json_Key & """:" & ConvertToJson(json_DictionaryCollectionOrArray(json_Key), json_ConvertLargeNumbersFromString), _
286+
"""" & json_Key & """:" & ConvertToJson(json_DictionaryCollectionOrArray(json_Key)), _
272287
json_BufferPosition, json_BufferLength
273288
Next json_Key
274289
json_BufferAppend json_buffer, "}", json_BufferPosition, json_BufferLength
@@ -284,7 +299,7 @@ Public Function ConvertToJson(ByVal json_DictionaryCollectionOrArray As Variant,
284299
End If
285300

286301
json_BufferAppend json_buffer, _
287-
ConvertToJson(json_Value, json_ConvertLargeNumbersFromString), _
302+
ConvertToJson(json_Value), _
288303
json_BufferPosition, json_BufferLength
289304
Next json_Value
290305
json_BufferAppend json_buffer, "]", json_BufferPosition, json_BufferLength
@@ -303,7 +318,7 @@ End Function
303318
' Private Functions
304319
' ============================================= '
305320

306-
Private Function json_ParseObject(json_String As String, ByRef json_Index As Long, Optional json_ConvertLargeNumbersToString As Boolean = True) As Dictionary
321+
Private Function json_ParseObject(json_String As String, ByRef json_Index As Long) As Dictionary
307322
Dim json_Key As String
308323
Dim json_NextChar As String
309324

@@ -327,15 +342,15 @@ Private Function json_ParseObject(json_String As String, ByRef json_Index As Lon
327342
json_Key = json_ParseKey(json_String, json_Index)
328343
json_NextChar = json_Peek(json_String, json_Index)
329344
If json_NextChar = "[" Or json_NextChar = "{" Then
330-
Set json_ParseObject.Item(json_Key) = json_ParseValue(json_String, json_Index, json_ConvertLargeNumbersToString)
345+
Set json_ParseObject.Item(json_Key) = json_ParseValue(json_String, json_Index)
331346
Else
332-
json_ParseObject.Item(json_Key) = json_ParseValue(json_String, json_Index, json_ConvertLargeNumbersToString)
347+
json_ParseObject.Item(json_Key) = json_ParseValue(json_String, json_Index)
333348
End If
334349
Loop
335350
End If
336351
End Function
337352

338-
Private Function json_ParseArray(json_String As String, ByRef json_Index As Long, Optional json_ConvertLargeNumbersToString As Boolean = True) As Collection
353+
Private Function json_ParseArray(json_String As String, ByRef json_Index As Long) As Collection
339354
Set json_ParseArray = New Collection
340355

341356
json_SkipSpaces json_String, json_Index
@@ -354,12 +369,12 @@ Private Function json_ParseArray(json_String As String, ByRef json_Index As Long
354369
json_SkipSpaces json_String, json_Index
355370
End If
356371

357-
json_ParseArray.Add json_ParseValue(json_String, json_Index, json_ConvertLargeNumbersToString)
372+
json_ParseArray.Add json_ParseValue(json_String, json_Index)
358373
Loop
359374
End If
360375
End Function
361376

362-
Private Function json_ParseValue(json_String As String, ByRef json_Index As Long, Optional json_ConvertLargeNumbersToString As Boolean = True) As Variant
377+
Private Function json_ParseValue(json_String As String, ByRef json_Index As Long) As Variant
363378
json_SkipSpaces json_String, json_Index
364379
Select Case VBA.Mid$(json_String, json_Index, 1)
365380
Case "{"
@@ -379,7 +394,7 @@ Private Function json_ParseValue(json_String As String, ByRef json_Index As Long
379394
json_ParseValue = Null
380395
json_Index = json_Index + 4
381396
ElseIf VBA.InStr("+-0123456789", VBA.Mid$(json_String, json_Index, 1)) Then
382-
json_ParseValue = json_ParseNumber(json_String, json_Index, json_ConvertLargeNumbersToString)
397+
json_ParseValue = json_ParseNumber(json_String, json_Index)
383398
Else
384399
Err.Raise 10001, "JSONConverter", json_ParseErrorMessage(json_String, json_Index, "Expecting 'STRING', 'NUMBER', null, true, false, '{', or '['")
385400
End If
@@ -446,7 +461,7 @@ Private Function json_ParseString(json_String As String, ByRef json_Index As Lon
446461
Loop
447462
End Function
448463

449-
Private Function json_ParseNumber(json_String As String, ByRef json_Index As Long, Optional json_ConvertLargeNumbersToString As Boolean = True) As Variant
464+
Private Function json_ParseNumber(json_String As String, ByRef json_Index As Long) As Variant
450465
Dim json_Char As String
451466
Dim json_Value As String
452467

@@ -465,7 +480,7 @@ Private Function json_ParseNumber(json_String As String, ByRef json_Index As Lon
465480
' See: http://support.microsoft.com/kb/269370
466481
'
467482
' Fix: Parse -> String, Convert -> String longer than 15 characters containing only numbers and decimal points -> Number
468-
If json_ConvertLargeNumbersToString And Len(json_Value) >= 16 Then
483+
If Not JsonConverter.JsonOptions.UseDoubleForLargeNumbers And Len(json_Value) >= 16 Then
469484
json_ParseNumber = json_Value
470485
Else
471486
' VBA.Val does not use regional settings, so guard for comma is not needed
@@ -478,7 +493,22 @@ End Function
478493

479494
Private Function json_ParseKey(json_String As String, ByRef json_Index As Long) As String
480495
' Parse key with single or double quotes
481-
json_ParseKey = json_ParseString(json_String, json_Index)
496+
If VBA.Mid$(json_String, json_Index, 1) = """" Or VBA.Mid$(json_String, json_Index, 1) = "'" Then
497+
json_ParseKey = json_ParseString(json_String, json_Index)
498+
ElseIf JsonConverter.JsonOptions.AllowUnquotedKeys Then
499+
Dim json_Char As String
500+
Do While json_Index > 0 And json_Index <= Len(json_String)
501+
json_Char = VBA.Mid$(json_String, json_Index, 1)
502+
If (json_Char <> " ") And (json_Char <> ":") Then
503+
json_ParseKey = json_ParseKey & json_Char
504+
json_Index = json_Index + 1
505+
Else
506+
Exit Do
507+
End If
508+
Loop
509+
Else
510+
Err.Raise 10001, "JSONConverter", json_ParseErrorMessage(json_String, json_Index, "Expecting '""' or '''")
511+
End If
482512

483513
' Check for colon and skip if present or throw if not present
484514
json_SkipSpaces json_String, json_Index
@@ -510,33 +540,37 @@ Private Function json_Encode(ByVal json_Text As Variant) As String
510540
json_AscCode = json_AscCode + 65536
511541
End If
512542

543+
' From spec, ", \, and control characters must be escaped (solidus is optional)
544+
513545
Select Case json_AscCode
514-
' " -> 34 -> \"
515546
Case 34
547+
' " -> 34 -> \"
516548
json_Char = "\"""
517-
' \ -> 92 -> \\
518549
Case 92
550+
' \ -> 92 -> \\
519551
json_Char = "\\"
520-
' / -> 47 -> \/
521552
Case 47
522-
json_Char = "\/"
523-
' backspace -> 8 -> \b
553+
' / -> 47 -> \/ (optional)
554+
If JsonConverter.JsonOptions.EscapeSolidus Then
555+
json_Char = "\/"
556+
End If
524557
Case 8
558+
' backspace -> 8 -> \b
525559
json_Char = "\b"
526-
' form feed -> 12 -> \f
527560
Case 12
561+
' form feed -> 12 -> \f
528562
json_Char = "\f"
529-
' line feed -> 10 -> \n
530563
Case 10
564+
' line feed -> 10 -> \n
531565
json_Char = "\n"
532-
' carriage return -> 13 -> \r
533566
Case 13
567+
' carriage return -> 13 -> \r
534568
json_Char = "\r"
535-
' tab -> 9 -> \t
536569
Case 9
570+
' tab -> 9 -> \t
537571
json_Char = "\t"
538-
' Non-ascii characters -> convert to 4-digit hex
539572
Case 0 To 31, 127 To 65535
573+
' Non-ascii characters -> convert to 4-digit hex
540574
json_Char = "\u" & VBA.Right$("0000" & VBA.Hex$(json_AscCode), 4)
541575
End Select
542576

‎specs/Specs.bas

Lines changed: 33 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -103,11 +103,13 @@ Public Function Specs() As SpecSuite
103103
.Expect(JsonObject(1)).ToEqual "123456789012345678901234567890"
104104
.Expect(JsonObject(2)).ToEqual "1.123456789012345678901234567890"
105105

106+
JsonConverter.JsonOptions.UseDoubleForLargeNumbers = True
106107
JsonString = "[123456789012345678901234567890]"
107-
Set JsonObject = JsonConverter.ParseJson(JsonString, False)
108+
Set JsonObject = JsonConverter.ParseJson(JsonString)
108109

109110
.Expect(JsonObject).ToNotBeUndefined
110111
.Expect(JsonObject(1)).ToEqual 1.23456789012346E+29
112+
JsonConverter.JsonOptions.UseDoubleForLargeNumbers = False
111113
End With
112114

113115
With Specs.It("should parse double-backslash as backslash")
@@ -139,6 +141,19 @@ Public Function Specs() As SpecSuite
139141
.Expect(JsonObject("a b c")).ToEqual "d e f"
140142
End With
141143

144+
With Specs.It("should allow unquoted keys with option")
145+
JsonConverter.JsonOptions.AllowUnquotedKeys = True
146+
JsonString = "{a:""a"",b :""b""}"
147+
Set JsonObject = JsonConverter.ParseJson(JsonString)
148+
149+
.Expect(JsonObject).ToNotBeUndefined
150+
.Expect(JsonObject.Exists("a")).ToEqual True
151+
.Expect(JsonObject("a")).ToEqual "a"
152+
.Expect(JsonObject.Exists("b")).ToEqual True
153+
.Expect(JsonObject("b")).ToEqual "b"
154+
JsonConverter.JsonOptions.AllowUnquotedKeys = False
155+
End With
156+
142157
' ============================================= '
143158
' ConvertTOJSON
144159
' ============================================= '
@@ -189,8 +204,10 @@ Public Function Specs() As SpecSuite
189204
JsonString = JsonConverter.ConvertToJson(Array("123456789012345678901234567890", "1.123456789012345678901234567890", "1234567890123456F"))
190205
.Expect(JsonString).ToEqual "[123456789012345678901234567890,1.123456789012345678901234567890,""1234567890123456F""]"
191206

192-
JsonString = JsonConverter.ConvertToJson(Array("123456789012345678901234567890"), False)
207+
JsonConverter.JsonOptions.UseDoubleForLargeNumbers = True
208+
JsonString = JsonConverter.ConvertToJson(Array("123456789012345678901234567890"))
193209
.Expect(JsonString).ToEqual "[""123456789012345678901234567890""]"
210+
JsonConverter.JsonOptions.UseDoubleForLargeNumbers = False
194211
End With
195212

196213
With Specs.It("should convert dates to ISO 8601")
@@ -235,10 +252,22 @@ Public Function Specs() As SpecSuite
235252

236253
With Specs.It("should json-encode strings")
237254
Dim Strings As Variant
238-
Strings = Array("""\/" & vbCrLf & vbTab & vbBack & vbFormFeed, ChrW(128) & ChrW(32767), "#$%&{|}~")
255+
Strings = Array("""\" & vbCrLf & vbTab & vbBack & vbFormFeed, ChrW(128) & ChrW(32767), "#$%&{|}~")
256+
257+
JsonString = JsonConverter.ConvertToJson(Strings)
258+
.Expect(JsonString).ToEqual "[""\""\\\r\n\t\b\f"",""\u0080\u7FFF"",""#$%&{|}~""]"
259+
End With
260+
261+
With Specs.It("should escape solidus with option")
262+
Strings = Array("a/b")
263+
264+
JsonString = JsonConverter.ConvertToJson(Strings)
265+
.Expect(JsonString).ToEqual "[""a/b""]"
239266

267+
JsonConverter.JsonOptions.EscapeSolidus = True
240268
JsonString = JsonConverter.ConvertToJson(Strings)
241-
.Expect(JsonString).ToEqual "[""\""\\\/\r\n\t\b\f"",""\u0080\u7FFF"",""#$%&{|}~""]"
269+
.Expect(JsonString).ToEqual "[""a\/b""]"
270+
JsonConverter.JsonOptions.EscapeSolidus = False
242271
End With
243272

244273
' ============================================= '

‎specs/VBA-JSON - Specs.xlsm

8.01 KB
Binary file not shown.

0 commit comments

Comments
 (0)