%REM
Copyright 2007, 2008 SNAPPS (Strategic Net Applications, Inc.)
Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at
http://www.apache.org/licenses/LICENSE-2.0
Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and limitations under the License.
%END REM
'
'Globalization constants
Const ERR_INVALID_JSON = "Invalid JSON format."
Const ERR_MOVE_PAST_LAST = "Invalid JSON format. Attempting to move past last character."
Const ERR_MOVE_PAST_FIRST = "Invalid JSON format. Attempting to move past first character."
Const ERR_INFINITE_LOOP = "Invalid JSON format. Parser is inside infinite loop."
Const ERR_CURRENT_CHAR = "Current character = "
Const ERR_PREVIOUS_CHAR = "Previous character = "
Const ERR_REMAINING_STRING = "Remaining string = "
Const ERR_ATLINE = " at line "
Const ERR_PREFIX = "ERROR "
Dim DATEDELIMITER As String '20090430:Cesar - Necessary for the ability to parse dates out of a JSON string
'
Class JSONReader
'*********************************************************************************************<br/>
'* Version: 1.0.2<br/>
'* Purpose: This class provides a way to parse JSON text into either a<br/>
'* JSONObject or JSONArray object or some combination. However,<br/>
'* it will always return some type of object (if the JSON is valid).<br/>
'* Both the JSONObject and JSONArray classes have an Items property.<br/>
'* You can put the value of the returned object Items property into a variant<br/>
'* then step through the results.<br/>
'*<br/>
'* This class uses the ls.class.JSONArray and ls.class.JSONObject classes.<br/>
'*<br/>
'* Example:<br/>
'* dim sJSON as String<br/>
'* dim jsonReader as JSONReader<br/>
'* dim vResults as Variant<br/>
'* dim vPieces as Variant<br/>
'* set jsonReader = New JSONReader<br/>
'* sJSON = |{"a":[15,25],"b":"Some text"}|<br/>
'* vResults = jsonReader.Parse(sJSON) 'this is a JSONObject<br/>
'* vPieces = vResults.Items<br/>
'*<br/>
'* Methods: Parse(JSON string)<br/>
'*<br/>
'* Author: Troy Reimer (treimer@snapps.com)<br/>
'*********************************************************************************************<br/>
<br/>
Private m_sJSON As String 'the original string<br/>
Private m_iIndex As Long 'the current character index<br/>
Private m_iPrevIndex As Long 'the previous character index<br/>
Private m_iLen As Long 'the current string length<br/>
Private m_iOrigLen As Long 'the original string length<br/>
Private m_sChar As String 'the current character<br/>
Private m_sPrev As String 'the previous character<br/>
Private m_sWorking As String 'the remaining string<br/>
Private m_vToken As Variant 'the current token value<br/>
Private m_sEscapes List As String 'a list of escape characters<br/>
<br/>
Private OBJECT_END As ObjectEnd<br/>
Private ARRAY_END As ArrayEnd<br/>
Private COLON As Colon<br/>
Private COMMA As Comma<br/>
<br/>
Public Sub New<br/>
Set OBJECT_END = New ObjectEnd<br/>
Set ARRAY_END = New ArrayEnd<br/>
Set COLON = New Colon<br/>
Set COMMA = New Comma<br/>
<br/>
Me.m_sEscapes(|"|) = |"|<br/>
Me.m_sEscapes(|\|) = |\|<br/>
Me.m_sEscapes(|/|) = |/|<br/>
Me.m_sEscapes(|b|) = Chr(8)<br/>
Me.m_sEscapes(|f|) = Chr(12)<br/>
Me.m_sEscapes(|n|) = Chr(10)<br/>
Me.m_sEscapes(|r|) = Chr(13)<br/>
Me.m_sEscapes(|t|) = Chr(9)<br/>
<br/>
DATEDELIMITER = CVM_GetDateDelimiter '20090430:Cesar - Set the global constant for date delimiters<br/>
End Sub<br/>
<br/>
%REM
Parse
%END REM
Public Function Parse(p_sJSON As String) As Variant<br/>
'*********************************************************************************************<br/>
'* Purpose: This is the only public method for this class. It returns an object<br/>
'* created from parsing the input JSON string.<br/>
'*<br/>
'* Input: p_sJSON: The JSON string to parse<br/>
'*<br/>
'* Output: Either a JSONArray or JSONObject or combination<br/>
'*<br/>
'* Calls: ParseMe <br/>
'*********************************************************************************************<br/>
Dim sFirstChar As String<br/>
Dim sLastChar As String<br/>
<br/>
On Error Goto ErrorHandler<br/>
<br/>
Me.m_sJSON = Trim(p_sJSON)<br/>
Me.m_iIndex = 0<br/>
Me.m_iPrevIndex = -1<br/>
Me.m_iLen = Len(Me.m_sJSON)<br/>
Me.m_iOrigLen = Len(Me.m_sJSON)<br/>
Me.m_sWorking = Me.m_sJSON<br/>
Me.m_sChar = Left(Me.m_sWorking, 1)<br/>
<br/>
sFirstChar = Left(Me.m_sJSON, 1)<br/>
sLastChar = Right(Me.m_sJSON, 1)<br/>
<br/>
If (sFirstChar = "[" And sLastChar = "]") Or (sFirstChar = "{" And sLastChar = "}") Then<br/>
Set Parse = Me.ParseMe<br/>
Else<br/>
Set Parse = Nothing<br/>
Error 1000, ERR_INVALID_JSON<br/>
End If <br/>
<br/>
Done:
Exit Function<br/>
<br/>
ErrorHandler:
On Error Goto 0<br/>
Error Err, Getthreadinfo(10) & ": " & ERR_PREFIX & Err & ": {" & Error$ & "}" & ERR_ATLINE & Erl & ". " & _<br/>
ERR_CURRENT_CHAR & "'" & Me.m_sChar & "'; " & _<br/>
ERR_PREVIOUS_CHAR & "'" & Me.m_sChar & "'; " & _<br/>
ERR_REMAINING_STRING & "'" & Me.m_sWorking & "'"<br/>
End Function<br/>
<br/>
%REM
ParseMe
%END REM
Private Function ParseMe As Variant<br/>
'*********************************************************************************************<br/>
'* Purpose: This function moves to the next character in the remaining string<br/>
'* and returns either a new JSONObject/ JSONArray or the value of the<br/>
'* current token.<br/>
'*<br/>
'* Output: An object or value for the current token<br/>
'*<br/>
'* Calls: CreateJSONArray<br/>
'* CreateJSONObject<br/>
'* GetNext<br/>
'* GetNumericValue<br/>
'* GetPrevious<br/>
'* GetStringValue<br/>
'* SkipWhiteSpace<br/>
'*********************************************************************************************<br/>
Dim sChar As String<br/>
<br/>
Call Me.SkipWhiteSpace<br/>
sChar = Me.m_sChar<br/>
Call Me.GetNext<br/>
If Me.m_iIndex <> Me.m_iPrevIndex Then 'check to make sure we are not in a loop<br/>
Me.m_iPrevIndex = Me.m_iIndex<br/>
Select Case sChar<br/>
Case |{| 'begin object<br/>
Set Me.m_vToken = Me.CreateJSONObject<br/>
<br/>
Case |}| 'end object<br/>
Set Me.m_vToken = Me.OBJECT_END<br/>
<br/>
Case |[| 'begin array <br/>
Set Me.m_vToken = Me.CreateJSONArray<br/>
<br/>
Case |]| 'end array<br/>
Set Me.m_vToken = Me.ARRAY_END<br/>
<br/>
Case |"| 'string<br/>
Me.m_vToken = Me.GetStringValue<br/>
<br/>
Case |,| 'comma<br/>
Set Me.m_vToken = Me.COMMA<br/>
<br/>
Case |:| 'colon<br/>
Set Me.m_vToken = Me.COLON<br/>
<br/>
Case |t| 'true<br/>
Call Me.MoveNextN(3)<br/>
Me.m_vToken = True<br/>
<br/>
Case |f| 'false<br/>
Call Me.MoveNextN(4)<br/>
Me.m_vToken = False <br/>
<br/>
Case |n| 'null<br/>
Call Me.MoveNextN(3)<br/>
Me.m_vToken = Null<br/>
<br/>
Case Else 'probably a numeric value<br/>
Call Me.GetPrevious<br/>
If Isnumeric(Me.m_sChar) Or Me.m_sChar = "-" Then<br/>
'this is a number<br/>
Me.m_vToken = Me.GetNumericValue<br/>
End If<br/>
End Select<br/>
<br/>
If Isobject(Me.m_vToken) Then<br/>
Set ParseMe = Me.m_vToken<br/>
Else<br/>
ParseMe = Me.m_vToken<br/>
End If<br/>
Else<br/>
'error we are in a loop<br/>
Error 1000, ERR_INFINITE_LOOP<br/>
End If <br/>
<br/>
End Function<br/>
<br/>
<br/>
%REM
CreateArray
%END REM
Private Function CreateJSONArray As JSONArray<br/>
'*********************************************************************************************<br/>
'* Purpose: This function creates and populates a JSONArray object with all of its<br/>
'* values.<br/>
'*<br/>
'* Output: A poplated JSONArray object<br/>
'*<br/>
'* Calls: ParseMe<br/>
'* SkipWhiteSpace<br/>
'*********************************************************************************************<br/>
Dim jsonArray As JSONArray<br/>
Dim vValue As Variant <br/>
<br/>
Set jsonArray = New JSONArray<br/>
Call Me.SkipWhiteSpace <br/>
If Me.m_sChar = "{" Or Me.m_sChar = "[" Or Me.m_sChar = "]" Then<br/>
'value is an object<br/>
Set vValue = Me.ParseMe<br/>
Else<br/>
vValue = Me.ParseMe<br/>
End If<br/>
<br/>
While Typename(Me.m_vToken) <> "ARRAYEND"<br/>
Call jsonArray.AddItem(vValue)<br/>
If Typename(Me.ParseMe) = "COMMA" Then<br/>
If Me.m_sChar = "{" Or Me.m_sChar = "[" Then<br/>
Set vValue = Me.ParseMe<br/>
Else<br/>
vValue = Me.ParseMe<br/>
End If <br/>
End If<br/>
Wend<br/>
Set CreateJSONArray = jsonArray<br/>
End Function<br/>
<br/>
%REM
CreateJSONObject
%END REM
Private Function CreateJSONObject As JSONObject<br/>
'*********************************************************************************************<br/>
'* Purpose: This function creates and populates a JSONObject object with all of its<br/>
'* values.<br/>
'*<br/>
'* Output: A poplated JSONObject object<br/>
'*<br/>
'* Calls: ParseMe<br/>
'* SkipWhiteSpace<br/>
'*********************************************************************************************<br/>
Dim jsonObject As JSONObject<br/>
Dim vKey As Variant<br/>
<br/>
Set jsonObject = New JSONObject<br/>
Call Me.SkipWhiteSpace <br/>
vKey = Me.ParseMe<br/>
<br/>
While Typename(Me.m_vToken) <> "OBJECTEND"<br/>
Call Me.ParseMe 'this character should be a colon<br/>
If Typename(Me.m_vToken) <> "OBJECTEND" Then<br/>
Call jsonObject.AddItem(Cstr(vKey), Me.ParseMe)<br/>
If Typename(Me.ParseMe) = "COMMA" Then<br/>
vKey = Me.ParseMe<br/>
End If<br/>
End If<br/>
Wend<br/>
Set CreateJSONObject = jsonObject<br/>
End Function<br/>
<br/>
%REM
GetDigits
%END REM
Private Function GetDigits As String<br/>
'*********************************************************************************************<br/>
'* Purpose: This function walks the remaining string until a non-numeric value<br/>
'* is found. It returns the digits found.<br/>
'*<br/>
'* Output: A string of digits<br/>
'*<br/>
'* Calls: GetNext<br/>
'*********************************************************************************************<br/>
Dim sReturn As String<br/>
While Isnumeric(Me.m_sChar)<br/>
sReturn = sReturn & Me.m_sChar<br/>
Call Me.GetNext<br/>
Wend<br/>
GetDigits = sReturn<br/>
End Function<br/>
<br/>
%REM
GetNext
%END REM
Private Function GetNext As String<br/>
'*********************************************************************************************<br/>
'* Purpose: This function moves the "pointer" to the next character in the string.<br/>
'*<br/>
'* Output: The next character in the string<br/>
'*********************************************************************************************<br/>
Me.m_iLen = Me.m_iLen - 1<br/>
Me.m_iIndex = Me.m_iIndex + 1<br/>
If Me.m_iLen < 0 Then<br/>
'for some reason we are trying to move past the last character.<br/>
Error 1000, ERR_MOVE_PAST_LAST<br/>
End If<br/>
If Me.m_iIndex > Me.m_iOrigLen Then<br/>
Me.m_iIndex = Me.m_iOrigLen<br/>
End If<br/>
Me.m_sPrev = Left(Me.m_sWorking, 1)<br/>
Me.m_sWorking = Right(Me.m_sWorking, Me.m_iLen)<br/>
Me.m_sChar = Left(Me.m_sWorking, 1)<br/>
GetNext = Me.m_sChar<br/>
End Function<br/>
<br/>
%REM 20090430:Cesar - added ability to determine date delimiter
Start of CVM_GetDateDelimiter
===================================================
%END REM
Private Function CVM_GetDateDelimiter As String<br/>
Dim arrSource(0) As String<br/>
Dim arrSearch(3) As String<br/>
Dim arrReplace(0) As String<br/>
Dim varReturn As Variant<br/>
<br/>
arrSource(0) = Format(Dateserial(1999,12,31), "Short Date")<br/>
arrSearch(0) = "1"<br/>
arrSearch(1) = "2"<br/>
arrSearch(2) = "3"<br/>
arrSearch(3) = "9"<br/>
arrReplace(0) = "" 'Technically, not necessary<br/>
<br/>
varReturn = Replace(arrSource, arrSearch, arrReplace)<br/>
<br/>
CVM_GetDateDelimiter = Left$(varReturn(0), 1)<br/>
End Function<br/>
%REM 20090430:Cesar - added ability to determine date delimiter
End of CVM_RemoveWhitespace
===================================================
%END REM
<br/>
%REM
GetNumericValue
%END REM
Private Function GetNumericValue As Variant<br/>
'*********************************************************************************************<br/>
'* Purpose: This function returns either a Long or Double value for the numeric<br/>
'* string being parsed.<br/>
'*<br/>
'* Output: Long or Double number<br/>
'*<br/>
'* Calls: GetDigits<br/>
'* GetNext<br/>
'*********************************************************************************************<br/>
Dim sReturn As String<br/>
Dim bIsFloatingPoint As Boolean<br/>
<br/>
sReturn = Me.m_sChar<br/>
Call Me.GetNext<br/>
sReturn = sReturn & GetDigits<br/>
<br/>
'=============================<br/>
'20090430:Cesar - we may also be processing a date so we should check for date delimiters (and not just floating point indicators)<br/>
Dim bIsDate As Boolean<br/>
While Me.m_sChar = DATEDELIMITER<br/>
sReturn = sReturn & Me.m_sChar<br/>
Call Me.GetNext<br/>
sReturn = sReturn & GetDigits<br/>
bIsDate = True<br/>
Wend<br/>
'=============================<br/>
<br/>
'check to see if this is a floating point number<br/>
If Me.m_sChar = "." Then<br/>
sReturn = sReturn & Me.m_sChar<br/>
Call Me.GetNext<br/>
sReturn = sReturn & GetDigits<br/>
bIsFloatingPoint = True<br/>
End If<br/>
<br/>
If Lcase(Me.m_sChar) = "e" Then<br/>
sReturn = sReturn & Me.m_sChar<br/>
Call Me.GetNext<br/>
If Me.m_sChar = "+" Or Me.m_sChar = "-" Then<br/>
sReturn = sReturn & Me.m_sChar<br/>
Call Me.GetNext<br/>
sReturn = sReturn & GetDigits<br/>
End If<br/>
bIsFloatingPoint = True<br/>
End If<br/>
<br/>
If bIsDate Then '20090430:Cesar - return a date if this is a date string<br/>
GetNumericValue = Cdat(sReturn)<br/>
'return either a double or long value<br/>
Elseif bIsFloatingPoint Then<br/>
GetNumericValue = Cdbl(sReturn)<br/>
Else<br/>
GetNumericValue = Clng(sReturn)<br/>
End If<br/>
<br/>
End Function<br/>
<br/>
%REM
GetPrevious
%END REM
Private Function GetPrevious As String<br/>
'*********************************************************************************************<br/>
'* Purpose: This function moves the "pointer" to the previous character in the string.<br/>
'*<br/>
'* Output: The previous character in the string<br/>
'*********************************************************************************************<br/>
Me.m_iLen = Me.m_iLen + 1<br/>
Me.m_iIndex = Me.m_iIndex - 1<br/>
If Me.m_iLen > Me.m_iOrigLen Then<br/>
Me.m_iLen = Me.m_iOrigLen<br/>
End If<br/>
If Me.m_iIndex < 0 Then<br/>
'for some reason we are trying to move past the first character.<br/>
Error 1000, ERR_MOVE_PAST_FIRST<br/>
End If<br/>
Me.m_sWorking = Me.m_sPrev & Me.m_sWorking<br/>
Me.m_sChar = Left(Me.m_sWorking, 1)<br/>
Me.m_sPrev = Mid(Me.m_sJSON, Me.m_iIndex, 1)<br/>
GetPrevious = Me.m_sChar<br/>
End Function <br/>
<br/>
%REM
GetStringValue
%END REM
Private Function GetStringValue As String<br/>
'*********************************************************************************************<br/>
'* Purpose: This function returns the string value contained within quotes.<br/>
'* It also accounts for unicode characters and escape characters.<br/>
'*<br/>
'* Output: The string value<br/>
'*<br/>
'* Calls: GetNext<br/>
'* GetPrevious<br/>
'*********************************************************************************************<br/>
Dim sReturn As String<br/>
Dim sUnicode As String<br/>
Dim vEval As Variant<br/>
Dim x As Integer<br/>
While Me.m_sChar <> |"|<br/>
If Me.m_sChar = |\| Then<br/>
Call Me.GetNext<br/>
If Me.m_sChar = "u" Then 'unicode character<br/>
sUnicode = ""<br/>
For x = 1 To 4 'retrieve the four digit unicode<br/>
Call Me.GetNext<br/>
If Me.m_sChar = |"| Then<br/>
Call Me.GetPrevious<br/>
Exit For<br/>
Else<br/>
sUnicode = sUnicode & Me.m_sChar<br/>
End If<br/>
Next<br/>
sReturn = sReturn & Uchr$("&h" & sUnicode)<br/>
Else<br/>
'transform if this is an escaped char<br/>
If Iselement(Me.m_sEscapes(Me.m_sChar)) Then<br/>
sReturn = sReturn & Me.m_sEscapes(Me.m_sChar)<br/>
End If <br/>
End If<br/>
Else<br/>
sReturn = sReturn & Me.m_sChar<br/>
End If <br/>
Call Me.GetNext<br/>
Wend<br/>
Call Me.GetNext<br/>
GetStringValue = sReturn<br/>
End Function<br/>
<br/>
%REM
MoveNextN
%END REM
Private Sub MoveNextN(p_iCount As Integer)<br/>
'*********************************************************************************************<br/>
'* Purpose: This sub moves the "pointer" the specified number of places.<br/>
'*********************************************************************************************<br/>
Dim x As Integer<br/>
For x = 1 To p_iCount<br/>
Call Me.GetNext<br/>
Next<br/>
End Sub<br/>
<br/>
%REM
Peek
%END REM
Private Function Peek As String<br/>
'*********************************************************************************************<br/>
'* Purpose: This function looks at the next character in the string but doesn't move there.<br/>
'*<br/>
'* Output: The next character in the string.<br/>
'*********************************************************************************************<br/>
Peek = Left(Me.m_sWorking, 1)<br/>
End Function<br/>
<br/>
%REM
SkipWhiteSpace
%END REM
Private Sub SkipWhiteSpace<br/>
'*********************************************************************************************<br/>
'* Purpose: This sub moves the "pointer" to the next non-space character.<br/>
'*********************************************************************************************<br/>
'While Me.Peek = " "<br/>
While Instr(Chr(13) & Chr(10) & Chr(9) & " ", Me.Peek) > 0 '20090430:Cesar - Remove other types of whiespace in addition to the space character<br/>
Call Me.GetNext<br/>
Wend<br/>
End Sub <br/>
End Class
'
' These classes are used as markers to indicate that a stopping point is reached.
' They are only used for their TypeNames.
'
Class ArrayEnd
End Class
Class ObjectEnd
End Class
Class Colon
End Class
Class Comma
End Class