Visual Basic:
%REM
Исходный код классов: https://github.com/dpastov/jsonparser-ls
Доработано: VladSh (2020.02.14)
Версия: 2.0
%END REM
Option Public
Option Declare
'Globalization constants
Public Const ERRc_INVALID_JSON = 1000
Private Const ERR_INVALID_JSON = "Invalid JSON format"
Private Const JSON_FIELD_MASK_DEFAULT = "[a-zA-Z_]"
Public Const JSON_FIELD_MASK_DOMINO = "[@$#%a-zA-Z0-9_]"
Public Const DDS_JSON_DT_PATTERN = "####-##-##T##:##:##Z" 'Domino Data Service JSON datetime format
Const DDS_JSON_UNID_TAG = "@unid"
Const DDS_JSON_FORM_TAG = "@form"
Class JSONArray
Private m_items() As Variant
Private m_size As Long
Sub New()
End Sub
Public Property Get Items As Variant
Items = Me.m_items
End Property
Public Property Get Size As Long
Size = Me.m_size
End Property
Public Sub AddItem(itemVal As Variant)
ReDim Preserve m_items(0 To m_size)
If IsObject(itemVal) Then
Set m_items(m_size) = itemVal
Else
m_items(m_size) = itemVal
End If
m_size = m_size + 1
End Sub
End Class
Class JSONObject
Private m_items List As Variant
Private m_size As Long
Sub New()
End Sub
Public Property Get Items As Variant
Items = Me.m_items
End Property
Public Property Get Size As Long
Size = Me.m_size
End Property
Public Sub AddItem(itemName As String, itemVal As Variant)
If Not Me.HasItem(itemName) Then m_size = m_size + 1
If IsObject(itemVal) Then
Set Me.m_items(itemName) = itemVal
Else
Me.m_items(itemName) = itemVal
End If
End Sub
Public Function HasItem(itemName As String) As Boolean
HasItem = IsElement(m_items(itemName))
End Function
%REM
Function getItemFromObject
Description: возвращает значение (типы см. GetItemByPath) переданного списка, либо Null
%END REM
Private Function getItemFromObject(obj As Variant, itemName As String) As Variant
If IsElement(obj(itemName)) Then
If IsObject(obj(itemName)) Then
getItemFromObject = obj(itemName).Items()
Else
getItemFromObject = obj(itemName)
End If
Else
getItemFromObject = Null
End If
End Function
%REM
Возвращает возвращает содержимое элемента по переданному пути;
Типы возвращаемых значений: String-значение | VARIANT( ) | VARIANT LIST, либо Null - в случае отсутствия элемента.
Может быть небезопасно:
v = jsonObj.GetItemByPath("object")("nonexistent") - вернёт ошибку!
лучше так:
v = jsonObj.GetItemByPath("object.nonexistent") - вернёт Null
либо так:
v = jsonObj.GetItemByPath("object") - и проверить на наличие: IsElement(v("nonexistent"))
%END REM
Public Function GetItemByPath(path As String) As Variant
On Error GoTo ErrH
Dim arr As Variant, i As Integer, entry As String
arr = Split(path, ".")
Dim data As Variant
data = Me.m_items
For i = 0 To UBound(arr)
entry = arr(i)
If Not IsElement(data(entry)) Then Exit For
data = getItemFromObject(data, entry)
If i = UBound(arr) Then
GetItemByPath = data
Exit Function
End If
Next
GetItemByPath = Null
Quit:
Exit Function
ErrH:
Error Err, GetThreadInfo(1) & " (" & Erl & ") -> " & Error$
End Function
%REM
Function IsObjectItem
Description: добавлено для полноценного использования оригинальной GetItem, -
чтобы можно было понять, как присваивать результат переменной, - с помощью Set или прямым присваиванием
%END REM
Public Function IsObjectItem(itemName As String) As Boolean
If HasItem(itemName) Then
IsObjectItem = IsObject(me.Items(itemName))
End If
End Function
%REM
Оригинальный метод; оставлен для старой возможности использования
%END REM
Public Function GetItem(itemName As String) As Variant
If HasItem(itemName) Then
If IsObject(me.Items(itemName)) Then
Set GetItem = me.Items(itemName)
Else
GetItem = me.Items(itemName)
End If
Else
GetItem = Null
End If
End Function
End Class
Class JSONParser
Private m_length As Long
Private m_decimalSep As String
Private m_fieldMask As String
Sub New()
m_fieldMask = JSON_FIELD_MASK_DEFAULT
End Sub
%REM
Property Set fieldNameMask
Description: установка маски допустимых символов в именах полей
%END REM
Public Property Set fieldNameMask As String
m_fieldMask = fieldNameMask
End Property
Private Property Get getDecimalSep As String
Dim session As NotesSession
Dim international As NotesInternational
If m_decimalSep = "" Then
Set session = New NotesSession()
Set international = session.International
m_decimalSep = international.DecimalSep
End If
getDecimalSep = m_decimalSep
End Property
Private Property Get length As Long
length = m_length
End Property
Function parse(jsonString As String) As Variant
On Error GoTo ErrH
Dim res As Variant
Dim index1 As Long
Dim index2 As Long
m_length = Len(jsonString)
index1 = InStr(jsonString, "{")
index2 = InStr(jsonString, "[")
If index1 > 0 And (index1 < index2 Or index2 = 0) Then
Set res = parseObject(jsonString, index1 + 1)
ElseIf index2 > 0 And (index2 < index1 Or index1 = 0) Then
Set res = parseArray(jsonString, index2 + 1)
End If
Set parse = res
Exit Function
ErrH:
Error ERRc_INVALID_JSON, GetThreadInfo(1) & " (" & Erl & ") -> " + ERR_INVALID_JSON + ": " + Error$ + " (" & Err & ")"
End Function
Private Function parseObject(jsonString As String, index As Long) As JSONObject
Dim res As JSONObject
Dim propertyValue As Variant
Dim propertyName As String
Dim objectEnd As Long
Dim nextPair As Long
Set res = New JSONObject()
nextPair = InStr(index, jsonString, ":")
objectEnd = InStr(index, jsonString, "}")
While nextPair < objectEnd And nextPair > 0 And objectEnd > 0
propertyName = findPropertyName(jsonString, index)
index = InStr(index, jsonString, ":")
index = index + 1
Call renderValue(jsonString, index, propertyValue)
Call res.AddItem(propertyName, propertyValue)
nextPair = InStr(index, jsonString, ":")
objectEnd = InStr(index, jsonString, "}")
Wend
index = objectEnd + 1
Set parseObject = res
End Function
Private Function parseArray(jsonString As String, index As Long) As JSONArray
Dim res As JSONArray
Dim propertyValue As Variant
Dim arrEnd As Long
Dim nextVal As Long
Set res = New JSONArray()
nextVal = InStr(index, jsonString, ",")
arrEnd = InStr(index, jsonString, "]")
Do
Call renderValue(jsonString, index, propertyValue)
If Not IsEmpty(propertyValue) Then
Call res.AddItem(propertyValue)
End If
nextVal = InStr(index, jsonString, ",")
arrEnd = InStr(index, jsonString, "]")
Loop While nextVal < arrEnd And nextVal > 0 And arrEnd > 0
index = arrEnd + 1
Set parseArray = res
End Function
Private Function renderValue(jsonString As String, index As Long, propertyValue As Variant) As Variant
Dim char As String
Dim i As Long
For i = index To length
char = Mid(jsonString, i, 1)
If char = {"} Then
index = i
propertyValue = findElementString(jsonString, index)
i = length
ElseIf char Like {#} Or char = {-} Then
index = i
propertyValue = findElementNumber(jsonString, index)
i = length
ElseIf char Like {[tfn]} Then
index = i
propertyValue = findElementLiteral(jsonString, index)
i = length
ElseIf char = "{" Then
index = i
Set propertyValue = parseObject(jsonString, index)
i = length
ElseIf char = "[" Then
index = i + 1
Set propertyValue = parseArray(jsonString, index)
i = length
End If
Next
End Function
Private Function findElementNumber(jsonString As String, index As Long) As Variant
Dim res As Variant
Dim elementEnd As String
Dim char As String
Dim i As Long
elementEnd = |, ]}| 'to catch: close bracket, comma, space or }
For i = index To length
char = Mid(jsonString, i, 1)
If InStr(elementEnd, char) Then
res = Mid(jsonString, index, i - index)
index = i
i = length
End If
Next
If InStr(res, ".") And getDecimalSep()<>"." Then
res = Replace(res, ".", getDecimalSep())
End If
findElementNumber = CDbl(res)
End Function
Private Function findElementLiteral(jsonString As String, index As Long) As Variant
Dim res As String
Dim elementEnd As String
Dim char As String
Dim i As Long
elementEnd = |, ]}| 'to catch: close bracket, comma, space or }
For i = index To length
char = Mid(jsonString, i, 1)
If InStr(elementEnd, char) Then
res = Mid(jsonString, index, i - index)
index = i
i = length
End If
Next
Select Case res:
Case "null":
findElementLiteral = Null
Case "true":
findElementLiteral = True
Case "false":
findElementLiteral = False
End Select
End Function
'find element in json string
Private Function findElementString(jsonString As String, index As Long) As String
Dim value As String
Dim index1 As Long, index1tmp As Long, index2 As Long
Dim bRecover As Boolean
index1 = InStr(index, jsonString, {"})
If index1 = 0 Then Exit Function
index1tmp = index1
Do
index2 = InStr(index1tmp + 1, jsonString, {"})
'проверяем наличие экранирующего символа перед найденной закрывающей кавычкой
If Mid$(jsonString, index2 - 1, 1) <> "\" Then Exit Do Else bRecover = True
index1tmp = index2
Loop
value = Mid(jsonString, index1 + 1, index2 - index1 - 1)
If bRecover Then
Call recoveryString(value)
Else
If InStr(value, "\") <> 0 Then Call recoveryString(value)
End If
index = index2 + 1
findElementString = value
End Function
%REM
Sub recoveryStringValue
Description: восстановление значения параметра из JSON (убирает все спецсимволы)
%END REM
Private Sub recoveryString(sValue As String)
sValue = Replace(sValue, {\b}, Chr(8))
sValue = Replace(sValue, "\t", Chr(9))
sValue = Replace(sValue, "\n", Chr(10))
sValue = Replace(sValue, "\r", Chr(13))
sValue = Replace(sValue, {\f}, Chr(12))
sValue = Replace(sValue, {\u0001}, Chr(1))
sValue = Replace(sValue, {\u0002}, Chr(2))
sValue = Replace(sValue, {\u001a}, Chr(26))
sValue = Replace(sValue, {\"}, {"})
sValue = Replace(sValue, {\/}, {/})
sValue = Replace(sValue, {\\}, {\})
End Sub
'find property name
Private Function findPropertyName(jsonString As String, index As Long) As String
Dim res As String
Dim propertyNameEnd As String
Dim char As String
Dim i As Long
'property start with character
For i = index To length
char = Mid(jsonString, i, 1)
If char Like m_fieldMask Then
res = char
index = i + 1
i = length
End If
Next
'rest of property could be characters and numbers etcx
propertyNameEnd = | :"'|
For i = index To length
char = Mid(jsonString, i, 1)
If InStr(propertyNameEnd, char) Then
index = i
i = length
Else
res = res + char
End If
Next
findPropertyName = res
End Function
End Class
%REM
Function JSON_parseToDocument
Description:
%END REM
Public Function JSON_parseToDocument(sJSON As String, ndbTrg As NotesDatabase) As NotesDocument
On Error GoTo ErrH
Dim oJson As JSONObject
Set oJson = JSON_parse(sJSON, True)
Dim ndNew As NotesDocument
Set ndNew = ndbTrg.CreateDocument()
If JSON_setToDocument(oJson, ndNew) Then
Set JSON_parseToDocument = ndNew
End If
Exit Function
ErrH:
Error Err, GetThreadInfo(1) & " (" & Erl & ") -> " & Error$
End Function
%REM
Обёртка над oJSON.GetItem() для удобства возврата "" в случае отсутствия элемента.
Параметры:
oJSON - JSONObject, полученный в результате разбора JSON
sElementPath - путь к элементу в стуктуре json, разделённый "."
Перечень возможных возвращаемых значений:
- "" - в случае отсутствия элемента;
- скаляр (строка/число);
- VARIANT( );
- VARIANT LIST.
%END REM
Public Function JSON_getItemValue(oJSON As JSONObject, sElementPath As String) As Variant
On Error GoTo ErrH
JSON_getItemValue = oJSON.GetItemByPath(sElementPath)
If IsNull(JSON_getItemValue) Then JSON_getItemValue = ""
Exit Function
ErrH:
Error Err, GetThreadInfo(1) & " (" & Erl & ") -> " & Error$
End Function
%REM
Правильная обработка системмных свойств Domino-документа, возвращаемых в значениях полей
%END REM
Public Function JSON_setToDocument(oJson As JSONObject, ndTo As NotesDocument) As Boolean
On Error GoTo ErrH
If oJson.Size <> 0 Then
Dim sItemName As String
ForAll vItemValue In oJson.Items()
sItemName = ListTag(vItemValue)
If Left(sItemName, 1) = "@" Then
'обработка системмных свойств NotesDocument'а, полученных в json'е
Select Case sItemName
Case DDS_JSON_UNID_TAG:
ndTo.UniversalID = vItemValue
Case DDS_JSON_FORM_TAG:
Call ndTo.ReplaceItemValue("Form", vItemValue)
Case Else:
ndTo.ReplaceItemValue(sItemName, vItemValue).SaveToDisk = False
End Select
Else
If IsObject(vItemValue) Then 'JSONArray
Call ndTo.ReplaceItemValue(sItemName, vItemValue.Items())
Else
Call ndTo.ReplaceItemValue(sItemName, vItemValue)
End If
End If
End ForAll
JSON_setToDocument = True
End If
Exit Function
ErrH:
Error Err, GetThreadInfo(1) & " (" & Erl & ") -> " & Error$
End Function
%REM
Function JSON_parse
Description: Разбирает JSON и возвращает JSONObject либо JSONArray
bDominoJson = True - установит маску допустимых символов в именах полей для Lotus Domino, иначе будет использована маска по умолчанию
%END REM
Public Function JSON_parse(sJSON As String, bDominoJson As Boolean) As Variant
On Error GoTo ErrH
Dim oJParser As New JSONParser
If bDominoJson Then oJParser.fieldNameMask = JSON_FIELD_MASK_DOMINO
Set JSON_parse = oJParser.Parse(sJSON)
Exit Function
ErrH:
Error Err, GetThreadInfo(1) & " (" & Erl & ") -> " & Error$
End FunctionОтличия от оригинальной версии:
1. JSONObject: добавлен метод GetItemByPath, позволяющий получать значение элемента по пути в виде Lotus-типов.
2. JSONObject: добавлены сервисные методы (IsObjectItem и др.) для правильного присваивания возвращаемого элемента при использовании оригинального метода GetItem, который был оставлен для обратной совместимости.
3. JSONObject: добавлено свойство Size для возможности анализа объекта на пустоту.
4. JSONParser: класс при разборе JSON теперь выдаёт ошибку "Invalid JSON format" {1000}, а не каждый раз неизвестно что.
5. JSONParser: добавлена поддержка кавычек и экранирующих символов внутри текстовых значений, - будет произведено обратное преобразование.
6. JSONParser: добавлено свойство fieldNameMask для установки маски допустимых символов, т.к. спецсимволы, разрешённые в именах полей документов Lotus, вырезались, из-за чего имена таких полей возвращались некорректно.
7. Добавлено несколько приятных функций.
Добавлено: обсуждение ведётся в теме Разбор JSON.
