Jerry.C
05-11-07, 10:59 AM
'********************************* JSON **************************************************
'*** @Usage: The public interface allows you to create JSON using Stringify and
'*** process JSON using the Parse method.
'*** @Version: 1.0.0
'*** @Author: Alan Faubel
'*******************************************************************************************
Class JSON
Sub New()
End Sub
'********************** PUBLIC PROPERTIES *********************
'********************** PUBLIC METHODS ***********************
Public Function Parse(pJSONStr As String) As Variant
Dim returnVal As Variant
Dim firstChar As String
Dim lastChar As String
'// Get the first character
firstChar = Left$(pJSONStr, 1)
lastChar = Right$(pJSONStr, 1)
If (firstChar = "[" And lastChar = "]") Or (firstChar = "{" And lastChar = "}") Then
'// Create either a string or object
If firstChar = "{" Then
Set returnVal = parseObject(pJSONStr)
Elseif firstChar = "[" Then
returnVal = parseArray(pJSONStr)
End If
Else
'// Raise an error
Error 9001, "Format Error: The first and last characters in a JSON string must be either [ and ] for an object or { and } for an array."
End If
'// Return the final result
If Isobject(returnVal) = True Then
Set Parse = returnVal
Else
Parse = returnVal
End If
End Function
Public Function Stringify(pSourceVal As Variant) As String
Dim jsonStr As String
'// Convert to a string
jsonStr = stringifyVariant(pSourceVal)
'// Return the value
Stringify = jsonStr
End Function
'********************** PRIVATE METHODS ***********************
Private Function parseArray(pSourceStr As String) As Variant
Dim resultArr() As Variant
Dim arrayItemCount As Integer
Dim remainingStr As String
Dim arrayItemStr As String
Dim i As Integer
'// Step through the source string looking for the deliminator or close tag
arrayItemCount = 0
'// Remove the leading and ending tags
pSourceStr = Mid$(Left$(pSourceStr, Len(pSourceStr) - 1), 2)
'// Remove leading and training white space
remainingStr = Trim(pSourceStr)
Do While remainingStr <> ""
'// Expand the array
Redim Preserve resultArr(arrayItemCount)
'// Parse the value
If Left$(remainingStr, 1) = "{" Then
Set resultArr(arrayItemCount) = parseValue(remainingStr)
Else
resultArr(arrayItemCount) = parseValue(remainingStr)
End If
'// Increment the count
arrayItemCount = arrayItemCount + 1
'// Step over the next comma
remainingStr = Trim(remainingStr)
If Len(remainingStr) > 0 Then
If Left$(remainingStr, 1) = "," Then
remainingStr = Trim(Mid$(remainingStr, 2))
Else
'// Raise an error. It should be a comma
Error 9000, "Format Error: The comma array item separator was not found."
End If
End If
Loop
'// Return the result
parseArray = resultArr
End Function
Private Function parseObject(pSourceStr As String) As JSONObject
Dim itemName As String
Dim itemValue As Variant
Dim remainingStr As String
Dim oReturnVal As JSONObject
Dim pos As Integer
'// Remove the leading and ending tags
pSourceStr = Mid$(Left$(pSourceStr, Len(pSourceStr) - 1), 2)
'// Create a new object
Set oReturnVal = New JSONObject
'// Remove leading and training white space
itemName = ""
remainingStr = Trim(pSourceStr)
Do While remainingStr <> ""
'// If the item name is blank then extract that
If itemName = "" Then
If Left$(remainingStr, 1) = """" Then
pos = findStringEnd(remainingStr)
If pos > 0 Then
'// Parse the string for the item name
itemName = parseString(Left$(remainingStr, pos))
'// Take the name out of the remaining string
remainingStr = Mid$(remainingStr, pos + 1)
Else
'// Raise an error because the end of the item name cannot be found
Error 9000, "Format Error: Unable to find the close quote for the item name for this object."
End If
Else
'// Raise an error since the item name shoudl be enclosed in quotes
Error 9000, "Format Error: The first character for the expected object property name was not a quote. Object property names need to be enclosed in quotes."
End If
Else
'// Step over the colon and move on
remainingStr = Trim(remainingStr)
If Len(remainingStr) > 0 Then
If Left$(remainingStr, 1) = ":" Then
remainingStr = Trim(Mid$(remainingStr, 2))
Else
'// Raise an error. It should be a colon to separate item name and value
Error 9000, "Format Error: A colon should be used to separate the name and value for an object. The colon for property """ & itemName & """ was not found."
End If
End If
'// Get the item value
itemValue = parseValue(remainingStr)
'// Add the item to the object
Call oReturnVal.AddItem(itemName, itemValue)
'// Reset the item name
itemName = ""
'// Step over the next comma and move on
remainingStr = Trim(remainingStr)
If Len(remainingStr) > 0 Then
If Left$(remainingStr, 1) = "," Then
remainingStr = Trim(Mid$(remainingStr, 2))
Else
'// Raise an error. It should be a comma
Error 9000, "Format Error: A comma shoudl separate comma should be used to separate the name and value pairs for an object. The comma was not found."
End If
End If
End If
Loop
'// Return the created object
Set parseObject = oReturnVal
End Function
Private Function parseValue(pSourceStr As String) As Variant
Dim returnVal As Variant
Dim pos As Integer
Dim firstChar As String
Dim valueStr As String
'// Determine what the item type is
firstChar = Left$(pSourceStr, 1)
If firstChar = "[" Then
'// The first item is a nested array. Find the close tag
pos = findCloseTag(pSourceStr, firstChar, "]")
If pos > 0 Then
'// Parse the object
returnVal = parseArray(Left$(pSourceStr, pos))
Else
'// Raise an error. Unable to find the close tag
Error 9000, "Format Error: Unable to find the close tag for this array."
End If
Elseif firstChar = "{" Then
'// The first item is an object. Find the close tag.
pos = findCloseTag(pSourceStr, firstChar, "}")
If pos > 0 Then
'// Parse the object
Set returnVal = parseObject(Left$(pSourceStr, pos))
'returnVal = parseObject(Left$(pSourceStr, pos))
Else
'// Raise an error. Unable to find the close tag
Error 9000, "Format Error: Unable to find the close tag for this object."
End If
Elseif firstChar = """" Then
'// This is a string. Find the close tag and parse it
pos = findStringEnd(pSourceStr)
If pos > 0 Then
'// Parse the string
returnVal = parseString(Left$(pSourceStr, pos))
Else
'// Raise an error. Unable to find the close quote
Error 9000, "Format Error: Unable to find the close quote for the string."
End If
Elseif Left$(pSourceStr, 9) = "new date(" Then
'// This is a date value. Get the position of the close bracket for the date and then process
pos = Instr(pSourceStr, ")")
If pos > 0 Then
returnVal = parseDate(Left$(pSourceStr, pos))
Else
'// Raise an error because the date value is not valid
Error 9002, "Format Error: Unable to find the close bracket for the 'new date()' value."
End If
Else
'// Get the string up to the comma or the end of the string
pos = Instr(pSourceStr, ",")
If pos = 0 Then
pos = Len( pSourceStr)
Else
pos = pos - 1
End If
'// Get the item string and trim it to remove leading and training spaces
valueStr = Trim(Left$(pSourceStr, pos))
'// Either process this as a number, null or boolean
If firstChar Like "#" Or firstChar = "-" Then
'// This is a number
returnVal = parseNumber(valueStr)
Else
Select Case valueStr
Case "true"
returnVal = True
Case "false"
returnVal = False
Case "null"
returnVal = Null
Case Else
'// Raise an error since this is not recognised
Print firstChar & " is " & Asc(firstChar)
Error 9003, "Format Error: Unable to parse the following string: """ & valueStr & """"
End Select
End If
End If
'// Reset the remaining string
If pos = Len(pSourceStr) Then
pSourceStr = ""
Else
pSourceStr = Mid$(pSourceStr, pos + 1)
End If
'// Return the result
If Isobject(returnVal) = True Then
Set parseValue = returnVal
Else
parseValue = returnVal
End If
End Function
Private Function parseString(pSourceStr As String) As String
'// Remove the leading and ending tags
parseString = Mid$(Left$(pSourceStr, Len(pSourceStr) - 1), 2)
'// NB Need to unespace the string
End Function
Private Function parseNumber(pSourceStr As String) As Double
'// NB This is a very crude way of doing it. OK for now.
parseNumber = Val(pSourceStr)
End Function
Private Function parseDate(pSourceStr As String) As Variant
Dim dateValStr As String
'Dim dateVal As Variant
'// Extract the date string from the date function
dateValStr = Strright(Strleft(pSourceStr , ")"), "(")
'// Now convert this to a data type 7
' NB Again a crude way of doing this
parseDate = Datevalue(dateValStr)
End Function
Private Function findCloseTag(pSourceStr As String, pOpenTag As String, pCloseTag As String) As Integer
Dim stringOpen As Boolean
Dim openTagCount As Integer
Dim c As String
Dim prevChar As String
Dim i As Integer
Dim foundPos As Integer
'// Step through looking for the close tag
foundPos = 0
stringOpen = False
openTagCount = 0
prevChar = ""
For i = 1 To Len(pSourceStr)
c = Mid$(pSourceStr, i, 1)
Select Case c
Case pOpenTag
openTagCount = openTagCount + 1
Case pCloseTag
If openTagCount = 1And stringOpen = False Then
'// Not within another set of tags so this must be it
foundPos = i
Exit For
Elseif stringOpen = True Then
'// Just carry on since this is within a string
Elseif openTagCount > 1 Then
'// Close one of the open tags
openTagCount = openTagCount - 1
Else
'// Raise an error. Found a close, but there was nov corresponding open. Should never get here
Error 9004, "Format Error: Found a close tag """ & pCloseTag & """ without a corresponding open tag."
End If
Case """"
If stringOpen = True Then
If prevChar <> "\" Then
'// This is not an escaped char so close the string
stringOpen = False
End If
Else
'// Start a new string
stringOpen = True
End If
End Select
'// Set the previous character to this one
prevChar = c
Next
'// Return the found position
findCloseTag = foundPos
End Function
Private Function findStringEnd(pSourceStr As String) As Integer
Dim stringOpen As Boolean
Dim c As String
Dim prevChar As String
Dim foundPos As Integer
Dim i As Integer
'// Step through looking for the close tag
foundPos = 0
stringOpen = False
prevChar = ""
For i = 1 To Len(pSourceStr)
c = Mid$(pSourceStr, i, 1)
'// If a double quote is found test to see it is not the open quote and that it is not escaped
If c = """" Then
If stringOpen = False Then
stringOpen = True
Else
If prevChar <> "\" Then
foundPos = i
Exit For
End If
End If
End If
'// Set the previous character to this one
prevChar = c
Next
'// Return the found position
findStringEnd = foundPos
End Function
Private Function stringifyVariant(pSourceVal As Variant) As String
Dim sourceDataType As Long
Dim returnStr As String
'// Determine whether this is an array or an object
If Isarray(pSourceVal) = True Then
returnStr = stringifyArray(pSourceVal)
Else
sourceDataType = Datatype(pSourceVal)
Select Case sourceDataType
Case V_NULL, V_EMPTY
returnStr = stringifyNull(pSourceVal)
Case V_INTEGER, V_LONG, V_SINGLE, V_DOUBLE, V_CURRENCY
returnStr = stringifyNumber(pSourceVal)
Case V_DATE
returnStr = stringifyDate(pSourceVal)
Case V_STRING
returnStr = stringifyString(pSourceVal)
Case V_BOOLEAN
returnStr = stringifyBoolean(pSourceVal)
Case V_LSOBJ
'// Check to see if this is a JSON object
If Typename(pSourceVal) = "JSONOBJECT" Then
returnStr = stringifyJSONObject(pSourceVal)
Else
'// Other objects are not supported. Raise an error
Error 9010, "Value Type Not Supported: The code does not support of conversion of user defined objects other than the JSONObject."
End If
Case V_PRODOBJ
'// This is a product object such as NotesDocument. Not supported in this release.
Error 9010, "Value Type Not Supported: The code does not support of conversion of Notes built in object types."
Case Else
'// Raise an error since this data type is not supported
Error 9010, "Value Type Not Supported: This value type (" & Cstr(sourceDataType) & ") is not supported."
End Select
End If
'// Return the result
stringifyVariant = returnStr
End Function
Private Function stringifyNull(pSourceVal As Variant) As String
stringifyNull = "null"
End Function
Private Function stringifyArray(pSourceVal As Variant) As String
Dim returnStr As String
'// Step through the array and build the string
returnStr = ""
Forall x In pSourceVal
If returnStr = "" Then
'// Start the array string
returnStr = "[" & stringifyVariant(x)
Else
returnStr = returnStr & "," & stringifyVariant(x)
End If
End Forall
'// Close the array string
If returnStr <> "" Then returnStr = returnStr & "]"
'// Return the array
stringifyArray = returnStr
End Function
Private Function stringifyNumber(pSourceVal As Variant) As String
' NB Need to check this !!
stringifyNumber = Cstr(pSourceVal)
End Function
Private Function stringifyDate(pSourceVal As Variant) As String
'NB Need to check this !!
stringifyDate = "new Date(" + Cstr(pSourceVal) + ")"
End Function
Private Function stringifyString(pSourceVal As Variant) As String
'NB Need to check this. Need to replace all the values such as new lines etc
stringifyString = """" & pSourceVal & """"
End Function
Private Function stringifyBoolean(pSourceVal As Variant) As String
If pSourceVal = True Then
stringifyBoolean = "true"
Else
stringifyBoolean = "false"
End If
End Function
Private Function stringifyJSONObject(pSourceVal As Variant) As String
Dim returnStr As String
Dim itemStr As String
'// Step through the array and build the string
returnStr = ""
Forall x In pSourceVal.ItemList
itemStr = """" & Listtag(x) & """" & ":" & stringifyVariant(x)
If returnStr = "" Then
'// Start the array string
returnStr = "{" & itemStr
Else
returnStr = returnStr & "," & itemStr
End If
End Forall
'// Close the array string
If returnStr <> "" Then returnStr = returnStr & "}"
'// Return the array
stringifyJSONObject = returnStr
End Function
End Class
'********************************* JSONObject*******************************************
'*** @Usage: JSON that represents objects are returned as objects of this type
'*** @Version: 1.0.0
'*** @Author: Alan Faubel
'*******************************************************************************************
Class JSONObject
Private mItemList List As Variant
Sub New()
End Sub
'*********************** PUBLIC PROPERTIES ********************
Public Property Get ItemList As Variant
ItemList = Me.mItemList
End Property
'*********************** PUBLIC METHODS ***********************
Public Sub AddItem(pItemName As String, pItemVal As Variant)
Me.mItemList(pItemName) = pItemVal
End Sub
Public Function GetItem(pItemName As String) As Variant
If Iselement(Me.mItemList(pItemName)) = True Then
GetItem = Me.mItemList(pItemName)
Else
GetItem = Null
End If
End Function
'*********************** PRIVATE METHIDS ***********************
End Class
'*** @Usage: The public interface allows you to create JSON using Stringify and
'*** process JSON using the Parse method.
'*** @Version: 1.0.0
'*** @Author: Alan Faubel
'*******************************************************************************************
Class JSON
Sub New()
End Sub
'********************** PUBLIC PROPERTIES *********************
'********************** PUBLIC METHODS ***********************
Public Function Parse(pJSONStr As String) As Variant
Dim returnVal As Variant
Dim firstChar As String
Dim lastChar As String
'// Get the first character
firstChar = Left$(pJSONStr, 1)
lastChar = Right$(pJSONStr, 1)
If (firstChar = "[" And lastChar = "]") Or (firstChar = "{" And lastChar = "}") Then
'// Create either a string or object
If firstChar = "{" Then
Set returnVal = parseObject(pJSONStr)
Elseif firstChar = "[" Then
returnVal = parseArray(pJSONStr)
End If
Else
'// Raise an error
Error 9001, "Format Error: The first and last characters in a JSON string must be either [ and ] for an object or { and } for an array."
End If
'// Return the final result
If Isobject(returnVal) = True Then
Set Parse = returnVal
Else
Parse = returnVal
End If
End Function
Public Function Stringify(pSourceVal As Variant) As String
Dim jsonStr As String
'// Convert to a string
jsonStr = stringifyVariant(pSourceVal)
'// Return the value
Stringify = jsonStr
End Function
'********************** PRIVATE METHODS ***********************
Private Function parseArray(pSourceStr As String) As Variant
Dim resultArr() As Variant
Dim arrayItemCount As Integer
Dim remainingStr As String
Dim arrayItemStr As String
Dim i As Integer
'// Step through the source string looking for the deliminator or close tag
arrayItemCount = 0
'// Remove the leading and ending tags
pSourceStr = Mid$(Left$(pSourceStr, Len(pSourceStr) - 1), 2)
'// Remove leading and training white space
remainingStr = Trim(pSourceStr)
Do While remainingStr <> ""
'// Expand the array
Redim Preserve resultArr(arrayItemCount)
'// Parse the value
If Left$(remainingStr, 1) = "{" Then
Set resultArr(arrayItemCount) = parseValue(remainingStr)
Else
resultArr(arrayItemCount) = parseValue(remainingStr)
End If
'// Increment the count
arrayItemCount = arrayItemCount + 1
'// Step over the next comma
remainingStr = Trim(remainingStr)
If Len(remainingStr) > 0 Then
If Left$(remainingStr, 1) = "," Then
remainingStr = Trim(Mid$(remainingStr, 2))
Else
'// Raise an error. It should be a comma
Error 9000, "Format Error: The comma array item separator was not found."
End If
End If
Loop
'// Return the result
parseArray = resultArr
End Function
Private Function parseObject(pSourceStr As String) As JSONObject
Dim itemName As String
Dim itemValue As Variant
Dim remainingStr As String
Dim oReturnVal As JSONObject
Dim pos As Integer
'// Remove the leading and ending tags
pSourceStr = Mid$(Left$(pSourceStr, Len(pSourceStr) - 1), 2)
'// Create a new object
Set oReturnVal = New JSONObject
'// Remove leading and training white space
itemName = ""
remainingStr = Trim(pSourceStr)
Do While remainingStr <> ""
'// If the item name is blank then extract that
If itemName = "" Then
If Left$(remainingStr, 1) = """" Then
pos = findStringEnd(remainingStr)
If pos > 0 Then
'// Parse the string for the item name
itemName = parseString(Left$(remainingStr, pos))
'// Take the name out of the remaining string
remainingStr = Mid$(remainingStr, pos + 1)
Else
'// Raise an error because the end of the item name cannot be found
Error 9000, "Format Error: Unable to find the close quote for the item name for this object."
End If
Else
'// Raise an error since the item name shoudl be enclosed in quotes
Error 9000, "Format Error: The first character for the expected object property name was not a quote. Object property names need to be enclosed in quotes."
End If
Else
'// Step over the colon and move on
remainingStr = Trim(remainingStr)
If Len(remainingStr) > 0 Then
If Left$(remainingStr, 1) = ":" Then
remainingStr = Trim(Mid$(remainingStr, 2))
Else
'// Raise an error. It should be a colon to separate item name and value
Error 9000, "Format Error: A colon should be used to separate the name and value for an object. The colon for property """ & itemName & """ was not found."
End If
End If
'// Get the item value
itemValue = parseValue(remainingStr)
'// Add the item to the object
Call oReturnVal.AddItem(itemName, itemValue)
'// Reset the item name
itemName = ""
'// Step over the next comma and move on
remainingStr = Trim(remainingStr)
If Len(remainingStr) > 0 Then
If Left$(remainingStr, 1) = "," Then
remainingStr = Trim(Mid$(remainingStr, 2))
Else
'// Raise an error. It should be a comma
Error 9000, "Format Error: A comma shoudl separate comma should be used to separate the name and value pairs for an object. The comma was not found."
End If
End If
End If
Loop
'// Return the created object
Set parseObject = oReturnVal
End Function
Private Function parseValue(pSourceStr As String) As Variant
Dim returnVal As Variant
Dim pos As Integer
Dim firstChar As String
Dim valueStr As String
'// Determine what the item type is
firstChar = Left$(pSourceStr, 1)
If firstChar = "[" Then
'// The first item is a nested array. Find the close tag
pos = findCloseTag(pSourceStr, firstChar, "]")
If pos > 0 Then
'// Parse the object
returnVal = parseArray(Left$(pSourceStr, pos))
Else
'// Raise an error. Unable to find the close tag
Error 9000, "Format Error: Unable to find the close tag for this array."
End If
Elseif firstChar = "{" Then
'// The first item is an object. Find the close tag.
pos = findCloseTag(pSourceStr, firstChar, "}")
If pos > 0 Then
'// Parse the object
Set returnVal = parseObject(Left$(pSourceStr, pos))
'returnVal = parseObject(Left$(pSourceStr, pos))
Else
'// Raise an error. Unable to find the close tag
Error 9000, "Format Error: Unable to find the close tag for this object."
End If
Elseif firstChar = """" Then
'// This is a string. Find the close tag and parse it
pos = findStringEnd(pSourceStr)
If pos > 0 Then
'// Parse the string
returnVal = parseString(Left$(pSourceStr, pos))
Else
'// Raise an error. Unable to find the close quote
Error 9000, "Format Error: Unable to find the close quote for the string."
End If
Elseif Left$(pSourceStr, 9) = "new date(" Then
'// This is a date value. Get the position of the close bracket for the date and then process
pos = Instr(pSourceStr, ")")
If pos > 0 Then
returnVal = parseDate(Left$(pSourceStr, pos))
Else
'// Raise an error because the date value is not valid
Error 9002, "Format Error: Unable to find the close bracket for the 'new date()' value."
End If
Else
'// Get the string up to the comma or the end of the string
pos = Instr(pSourceStr, ",")
If pos = 0 Then
pos = Len( pSourceStr)
Else
pos = pos - 1
End If
'// Get the item string and trim it to remove leading and training spaces
valueStr = Trim(Left$(pSourceStr, pos))
'// Either process this as a number, null or boolean
If firstChar Like "#" Or firstChar = "-" Then
'// This is a number
returnVal = parseNumber(valueStr)
Else
Select Case valueStr
Case "true"
returnVal = True
Case "false"
returnVal = False
Case "null"
returnVal = Null
Case Else
'// Raise an error since this is not recognised
Print firstChar & " is " & Asc(firstChar)
Error 9003, "Format Error: Unable to parse the following string: """ & valueStr & """"
End Select
End If
End If
'// Reset the remaining string
If pos = Len(pSourceStr) Then
pSourceStr = ""
Else
pSourceStr = Mid$(pSourceStr, pos + 1)
End If
'// Return the result
If Isobject(returnVal) = True Then
Set parseValue = returnVal
Else
parseValue = returnVal
End If
End Function
Private Function parseString(pSourceStr As String) As String
'// Remove the leading and ending tags
parseString = Mid$(Left$(pSourceStr, Len(pSourceStr) - 1), 2)
'// NB Need to unespace the string
End Function
Private Function parseNumber(pSourceStr As String) As Double
'// NB This is a very crude way of doing it. OK for now.
parseNumber = Val(pSourceStr)
End Function
Private Function parseDate(pSourceStr As String) As Variant
Dim dateValStr As String
'Dim dateVal As Variant
'// Extract the date string from the date function
dateValStr = Strright(Strleft(pSourceStr , ")"), "(")
'// Now convert this to a data type 7
' NB Again a crude way of doing this
parseDate = Datevalue(dateValStr)
End Function
Private Function findCloseTag(pSourceStr As String, pOpenTag As String, pCloseTag As String) As Integer
Dim stringOpen As Boolean
Dim openTagCount As Integer
Dim c As String
Dim prevChar As String
Dim i As Integer
Dim foundPos As Integer
'// Step through looking for the close tag
foundPos = 0
stringOpen = False
openTagCount = 0
prevChar = ""
For i = 1 To Len(pSourceStr)
c = Mid$(pSourceStr, i, 1)
Select Case c
Case pOpenTag
openTagCount = openTagCount + 1
Case pCloseTag
If openTagCount = 1And stringOpen = False Then
'// Not within another set of tags so this must be it
foundPos = i
Exit For
Elseif stringOpen = True Then
'// Just carry on since this is within a string
Elseif openTagCount > 1 Then
'// Close one of the open tags
openTagCount = openTagCount - 1
Else
'// Raise an error. Found a close, but there was nov corresponding open. Should never get here
Error 9004, "Format Error: Found a close tag """ & pCloseTag & """ without a corresponding open tag."
End If
Case """"
If stringOpen = True Then
If prevChar <> "\" Then
'// This is not an escaped char so close the string
stringOpen = False
End If
Else
'// Start a new string
stringOpen = True
End If
End Select
'// Set the previous character to this one
prevChar = c
Next
'// Return the found position
findCloseTag = foundPos
End Function
Private Function findStringEnd(pSourceStr As String) As Integer
Dim stringOpen As Boolean
Dim c As String
Dim prevChar As String
Dim foundPos As Integer
Dim i As Integer
'// Step through looking for the close tag
foundPos = 0
stringOpen = False
prevChar = ""
For i = 1 To Len(pSourceStr)
c = Mid$(pSourceStr, i, 1)
'// If a double quote is found test to see it is not the open quote and that it is not escaped
If c = """" Then
If stringOpen = False Then
stringOpen = True
Else
If prevChar <> "\" Then
foundPos = i
Exit For
End If
End If
End If
'// Set the previous character to this one
prevChar = c
Next
'// Return the found position
findStringEnd = foundPos
End Function
Private Function stringifyVariant(pSourceVal As Variant) As String
Dim sourceDataType As Long
Dim returnStr As String
'// Determine whether this is an array or an object
If Isarray(pSourceVal) = True Then
returnStr = stringifyArray(pSourceVal)
Else
sourceDataType = Datatype(pSourceVal)
Select Case sourceDataType
Case V_NULL, V_EMPTY
returnStr = stringifyNull(pSourceVal)
Case V_INTEGER, V_LONG, V_SINGLE, V_DOUBLE, V_CURRENCY
returnStr = stringifyNumber(pSourceVal)
Case V_DATE
returnStr = stringifyDate(pSourceVal)
Case V_STRING
returnStr = stringifyString(pSourceVal)
Case V_BOOLEAN
returnStr = stringifyBoolean(pSourceVal)
Case V_LSOBJ
'// Check to see if this is a JSON object
If Typename(pSourceVal) = "JSONOBJECT" Then
returnStr = stringifyJSONObject(pSourceVal)
Else
'// Other objects are not supported. Raise an error
Error 9010, "Value Type Not Supported: The code does not support of conversion of user defined objects other than the JSONObject."
End If
Case V_PRODOBJ
'// This is a product object such as NotesDocument. Not supported in this release.
Error 9010, "Value Type Not Supported: The code does not support of conversion of Notes built in object types."
Case Else
'// Raise an error since this data type is not supported
Error 9010, "Value Type Not Supported: This value type (" & Cstr(sourceDataType) & ") is not supported."
End Select
End If
'// Return the result
stringifyVariant = returnStr
End Function
Private Function stringifyNull(pSourceVal As Variant) As String
stringifyNull = "null"
End Function
Private Function stringifyArray(pSourceVal As Variant) As String
Dim returnStr As String
'// Step through the array and build the string
returnStr = ""
Forall x In pSourceVal
If returnStr = "" Then
'// Start the array string
returnStr = "[" & stringifyVariant(x)
Else
returnStr = returnStr & "," & stringifyVariant(x)
End If
End Forall
'// Close the array string
If returnStr <> "" Then returnStr = returnStr & "]"
'// Return the array
stringifyArray = returnStr
End Function
Private Function stringifyNumber(pSourceVal As Variant) As String
' NB Need to check this !!
stringifyNumber = Cstr(pSourceVal)
End Function
Private Function stringifyDate(pSourceVal As Variant) As String
'NB Need to check this !!
stringifyDate = "new Date(" + Cstr(pSourceVal) + ")"
End Function
Private Function stringifyString(pSourceVal As Variant) As String
'NB Need to check this. Need to replace all the values such as new lines etc
stringifyString = """" & pSourceVal & """"
End Function
Private Function stringifyBoolean(pSourceVal As Variant) As String
If pSourceVal = True Then
stringifyBoolean = "true"
Else
stringifyBoolean = "false"
End If
End Function
Private Function stringifyJSONObject(pSourceVal As Variant) As String
Dim returnStr As String
Dim itemStr As String
'// Step through the array and build the string
returnStr = ""
Forall x In pSourceVal.ItemList
itemStr = """" & Listtag(x) & """" & ":" & stringifyVariant(x)
If returnStr = "" Then
'// Start the array string
returnStr = "{" & itemStr
Else
returnStr = returnStr & "," & itemStr
End If
End Forall
'// Close the array string
If returnStr <> "" Then returnStr = returnStr & "}"
'// Return the array
stringifyJSONObject = returnStr
End Function
End Class
'********************************* JSONObject*******************************************
'*** @Usage: JSON that represents objects are returned as objects of this type
'*** @Version: 1.0.0
'*** @Author: Alan Faubel
'*******************************************************************************************
Class JSONObject
Private mItemList List As Variant
Sub New()
End Sub
'*********************** PUBLIC PROPERTIES ********************
Public Property Get ItemList As Variant
ItemList = Me.mItemList
End Property
'*********************** PUBLIC METHODS ***********************
Public Sub AddItem(pItemName As String, pItemVal As Variant)
Me.mItemList(pItemName) = pItemVal
End Sub
Public Function GetItem(pItemName As String) As Variant
If Iselement(Me.mItemList(pItemName)) = True Then
GetItem = Me.mItemList(pItemName)
Else
GetItem = Null
End If
End Function
'*********************** PRIVATE METHIDS ***********************
End Class