作者：RCDMK - rcdmk[at]hotmail[dot]com
许可证：
使用方法：
在页面顶部的页声明中设置它以应用于整个页面（例如：
<%@ LCID=1046 %>)设置
Session对象以便在整个会话中的所有页面中生效（例如：Session.LCID = 1046）或者在使用类之前设置
Response对象，以在页面的这个点之后生效（例如：Response.LCID = 1046）
Response.LCID = 1046 ' 必须！在这里设置你的LCID（1046代表巴西）。也可以是页面声明的LCID属性或Session.LCID属性' 实例化类set JSON = New JSONobject' 添加属性JSON.Add "prop1", "someString"JSON.Add "prop2", 12.3JSON.Add "prop3", Array(1, 2, "three")' 移除属性JSON.Remove "prop2"JSON.Remove "thisDoesNotExistsAndWillDoNothing"' 更改值JSON.Change "prop1", "someOtherString"JSON.Change "prop4", "thisWillBeCreated" ' 这个属性不存在，将会自动生成' 获取值Response.Write JSON.Value("prop1") & "<br>"Response.Write JSON.Value("prop2") & "<br>"Response.Write JSON("prop3").Serialize() & "<br>" ' 默认函数相当于 `.Value(propName)` - 此属性返回一个JSON数组对象Response.Write JSON("prop4") & "<br>"' 获取格式化的JSON输出Dim jsonString
jsonString = JSON.Serialize() ' 将包含JSON对象的字符串表示形式JSON.Write() ' 相当于：Response.Write JSON.Serialize()' 加载并解析JSON格式的字符串jsonString = "[{ ""strings"" : ""valorTexto"", ""numbers"": 123.456, ""arrays"": [1, ""2"", 3.4, [5, 6, [7, 8]]], ""objects"": { ""prop1"": ""outroTexto"", ""prop2"": [ { ""id"": 1, ""name"": ""item1"" }, { ""id"": 2, ""name"": ""item2"", ""teste"": { ""maisum"": [1, 2, 3] } } ] } }]" ' 因VBScript引号转义而使用双双引号set oJSONoutput = JSON.Parse(jsonString) ' 这个方法返回已解析的对象。数组会被解析成JSONarray对象JSON.Write() ' 输出：'{"data":[{"strings":"valorTexto","numbers":123.456,"arrays":[1,"2",3.4,[5,6,[7,8]]],"objects":{"prop1":"outroTexto","prop2":[{"id":1,"name":"item1"},{"id":2,"name":"item2","teste":{"maisum":[1,2,3]}}]}}]}'oJSONoutput.Write() ' 输出：'[{"strings":"valorTexto","numbers":123.456,"arrays":[1,"2",3.4,[5,6,[7,8]]],"objects":{"prop1":"outroTexto","prop2":[{"id":1,"name":"item1"},{"id":2,"name":"item2","teste":{"maisum":[1,2,3]}}]}}]'' 如果字符串表示的是一个对象（不是对象数组），则当前对象会被返回，因此不需要将结果赋给新变量jsonString = "{ ""strings"" : ""valorTexto"", ""numbers"": 123.456, ""arrays"": [1, ""2"", 3.4, [5, 6, [7, 8]]] }"JSON.Parse(jsonString)
JSON.Write() ' 输出：'{"strings":"valorTexto","numbers":123.456,"arrays":[1,"2",3.4,[5,6,[7,8]]]}'
' 从ADODB.Recordset加载记录dim cn, rsset cn = CreateObject("ADODB.Connection")
cn.Open "yourConnectionStringGoesHere"set rs = cn.execute("SELECT id, nome, valor FROM pedidos ORDER BY id ASC")' 也可以是：' set rs = CreateObject("ADODB.Recordset")' rs.Open "SELECT id, nome, valor FROM pedidos ORDER BY id ASC", cn JSON.LoadRecordset rs
JSONarr.LoadRecordset rs
rs.Close
cn.Closeset rs = Nothingset cn = NothingJSON.Write() ' 输出：'{"data":[{"id":1,"nome":"nome 1","valor":10.99},{"id":2,"nome":"nome 2","valor":19.1}]}'JSONarr.Write() ' 输出：'[{"id":1,"nome":"nome 1","valor":10.99},{"id":2,"nome":"nome 2","valor":19.1}]'
JSON.defaultPropertyName = "CustomName"JSON.Write() ' 输出：'{"CustomName":[{"id":1,"nome":"nome 1","valor":10.99},{"id":2,"nome":"nome 2","valor":19.1}]}'
' 实例化类set JSONarr = New JSONarray' 向数组中添加元素JSONarr.Push JSON ' 可以为JSON对象，甚至是JSON数组JSONarr.Push 1.25 ' 可以为数字JSONarr.Push "and strings too"' 写入到页面JSONarr.Write() ' 你会猜到吗？这与JSON对象的Write方法的效果相同
dim i, item' 易读的循环for each item in JSONarr.items if isObject(item) and typeName(item) = "JSONobject" then item.write() elseif typeOf item Is JSONobject then ' For clarity, since VBA doesn't support "typeName" item.write() else Response.Write item end if Response.Write "<br>"next' 速度快但可读性较差for i = 0 to JSONarr.length - 1 if isObject(JSONarr(i)) then set item = JSONarr(i) if typeOf item Is JSONobject then ' For clarity, since VBA doesn't support "typeName" item.write() else Response.Write item end if elseif Not IsEmpty(JSONarr(i)) Then ' Avoid error when accessing array elements directly item = JSONarr(i) Response.Write item end if Response.Write "<br>"next
使用示例：
<%
Option Explicit
Response.LCID = 1046 ' Brazilian LCID (use your locale code here).
' Could also be the LCID property of the page declaration or Session.LCID to set it to the entire session.
%>
<!--#include file="jsonObject.class.asp" -->
<!DOCTYPE html>
<html>
<head>
<meta charset="UTF-8">
<title>ASPJSON</title>
<style type="text/css">
body {
font-family: Arial, Helvetica, sans-serif;
}
pre {
border: solid 1px #CCCCCC;
background-color: #EEE;
padding: 5px;
text-indent: 0;
width: 90%;
white-space: pre-wrap;
word-wrap: break-word;
}
</style>
</head>
<body>
<h1>JSON Object and Array Tests</h1>
<%
server.ScriptTimeout = 10
dim jsonObj, jsonString, jsonArr, outputObj
dim testLoad, testAdd, testRemove, testValue, testChange, testArrayPush, testLoadRecordset
dim testLoadArray, testChangeDefaultPropertyName, testGetItemAt
testLoad = true
testLoadArray = true
testAdd = true
testRemove = true
testValue = true
testChange = true
testArrayPush = true
testLoadRecordset = true
testChangeDefaultPropertyName = true
set jsonObj = new JSONobject
set jsonArr = new jsonArray
jsonObj.debug = false
if testLoad then
jsonString = "{ ""strings"" : ""valorTexto"", ""numbers"": 123.456, ""bools"": true, ""arrays"": [1, ""2"", 3.4, [5, -6, [7, 8, [[[""9"", ""10""]]]]]], ""emptyArray"": [], ""emptyObject"": {}, ""objects"": { ""prop1"": ""outroTexto"", ""prop2"": [ { ""id"": 1, ""name"": ""item1"" }, { ""id"": 2, ""name"": ""item2"", ""teste"": { ""maisum"": [1, 2, 3] } } ] }, ""multiline"": ""Texto com\r\nMais de\r\numa linha e escapado com \\."" }"
if testLoadArray then jsonString = "[" & jsonString & "]"
set outputObj = jsonObj.parse(jsonString)
%>
<h3>Parse Input</h3>
<pre><%= jsonString %></pre>
<%
end if
if testAdd then
dim arr, multArr, nestedObject
arr = Array(1, "teste", 234.56, "mais teste", "234", now)
redim multArr(2, 3)
multArr(0, 0) = "0,0"
multArr(0, 1) = "0,1"
multArr(0, 2) = "0,2"
multArr(0, 3) = "0,3"
multArr(1, 0) = "1,0"
multArr(1, 1) = "1,1"
multArr(1, 2) = "1,2"
multArr(1, 3) = "1,3"
multArr(2, 0) = "2,0"
multArr(2, 1) = "2,1"
multArr(2, 2) = "2,2"
multArr(2, 3) = "2,3"
jsonObj.add "nome", "Jozé"
jsonObj.add "ficticio", true
jsonObj.add "idade", 25
jsonObj.add "saldo", -52
jsonObj.add "bio", "Nascido em São Paulo\Brasil" & vbcrlf & "Sem filhos" & vbcrlf & vbtab & "Jogador de WoW"
jsonObj.add "data", now
jsonObj.add "lista", arr
jsonObj.add "lista2", multArr
set nestedObject = new JSONobject
nestedObject.add "sub1", "value of sub1"
nestedObject.add "sub2", "value of ""sub2"""
jsonObj.add "nested", nestedObject
end if
if testRemove then
jsonObj.remove "numbers"
jsonObj.remove "aNonExistantPropertyName" ' this sould run silently, even to non existant properties
end if
if testValue then
%><h3>Get Values</h3><%
response.write "nome: " & jsonObj.value("nome") & "<br>"
response.write "idade: " & jsonObj("idade") & "<br>" ' short syntax
response.write "non existant property:" & jsonObj("aNonExistantPropertyName") & "(" & typeName(jsonObj("aNonExistantPropertyName")) & ")<br>"
end if
if testChange then
%><h3>Change Values</h3><%
response.write "nome before: " & jsonObj.value("nome") & "<br>"
jsonObj.change "nome", "Mario"
response.write "nome after: " & jsonObj.value("nome") & "<br>"
jsonObj.change "nonExisting", -1
response.write "Non existing property is created with: " & jsonObj.value("nonExisting") & "<br>"
end if
if testArrayPush then
jsonArr.Push jsonObj
jsonArr.Push 1
jsonArr.Push "strings too"
end if
if testLoadRecordset then
%><h3>Load a Recordset</h3>
<!--
METADATA
TYPE="TypeLib"
NAME="Microsoft ActiveX Data Objects 2.5 Library"
UUID="{00000205-0000-0010-8000-00AA006D2EA4}"
VERSION="2.5"
-->
<%
dim rs
set rs = createObject("ADODB.Recordset")
' prepera an in memory recordset
' could be, and mostly, loaded from a database
rs.CursorType = adOpenKeyset
rs.CursorLocation = adUseClient
rs.LockType = adLockOptimistic
rs.Fields.Append "ID", adInteger, , adFldKeyColumn
rs.Fields.Append "Nome", adVarChar, 50, adFldMayBeNull
rs.Fields.Append "Valor", adDecimal, 14, adFldMayBeNull
rs.Fields("Valor").NumericScale = 2
rs.Open
rs.AddNew
rs("ID") = 1
rs("Nome") = "Nome 1"
rs("Valor") = 10.99
rs.Update
rs.AddNew
rs("ID") = 2
rs("Nome") = "Nome 2"
rs("Valor") = 29.90
rs.Update
rs.moveFirst
jsonObj.LoadFirstRecord rs
' or
rs.moveFirst
jsonArr.LoadRecordSet rs
rs.Close
set rs = nothing
end if
if testLoad then
%>
<h3>Parse Output</h3>
<pre><%= outputObj.write %></pre>
<%
end if
if testChangeDefaultPropertyName then
jsonObj.defaultPropertyName = "CustomName"
jsonArr.defaultPropertyName = "CustomArrName"
end if
%>
<h3>JSON Object Output<% if testLoad then %> (Same as parse output: <% if typeName(jsonObj) = typeName(outputObj) then %>yes<% else %>no<% end if %>)<% end if %></h3>
<pre><%= jsonObj.write %></pre>
<h3>Array Output</h3>
<pre><%= jsonArr.write %></pre>
<h3>Array Loop</h3>
<pre><%
dim i, items, item
' more readable loop
i = 0
response.write "For Each Loop (readability):<br>==============<br>"
for each item in jsonArr.items
response.write "Index "
response.write i
response.write ": "
if isObject(item) and typeName(item) = "JSONobject" then
item.write()
else
response.write item
end if
response.write "<br>"
i = i + 1
next
response.write "<br><br>For Loop (speed):<br>=========<br>"
' faster but less readable
for i = 0 to jsonArr.length - 1
response.write "Index "
response.write i
response.write ": "
if isObject(jsonArr(i)) then
set item = jsonArr(i)
if typeName(item) = "JSONobject" then
item.write()
else
response.write item
end if
else
item = jsonArr(i)
response.write item
end if
response.write "<br>"
next
set outputObj = nothing
set jsonObj = nothing
set jsonArr = nothing
%></pre>
<h3>JSON Script Output</h3>
<%
dim realOutput
dim expectedOutput
dim javascriptCode
dim javascriptkey
dim jsonScr
javascriptCode = "function() { alert('test'); }"
javascriptKey = "script"
expectedOutput = "{""" & javascriptKey & """:" & javascriptCode & "}"
set jsonScr = new JSONscript
jsonScr.value = javascriptCode
set jsonObj = new JSONobject
jsonObj.Add javascriptKey, jsonScr
realOutput = jsonObj.Serialize()
%><h4>Output<% if (realOutput = expectedOutput) then %> (correct)<% else %> (INCORRECT!)<% end if %></h4>
<pre><%= realOutput %></pre>
</body>
</html>
类库文件jsonObject.class.asp：
<%
' JSON object class 3.8.1 May, 29th - 2016
' https://github.com/rcdmk/aspJSON
'
' License MIT - see LICENCE.txt for details
const JSON_ROOT_KEY = "[[JSONroot]]"
const JSON_DEFAULT_PROPERTY_NAME = "data"
const JSON_SPECIAL_VALUES_REGEX = "^(?:(?:t(?:r(?:ue?)?)?)|(?:f(?:a(?:l(?:se?)?)?)?)|(?:n(?:u(?:ll?)?))|(?:u(?:n(?:d(?:e(?:f(?:i(?:n(?:ed?)?)?)?)?)?)?)?))$"
const JSON_ERROR_PARSE = 1
const JSON_ERROR_PROPERTY_ALREADY_EXISTS = 2
const JSON_ERROR_PROPERTY_DOES_NOT_EXISTS = 3 ' DEPRECATED
const JSON_ERROR_NOT_AN_ARRAY = 4
const JSON_ERROR_NOT_A_STRING = 5
const JSON_ERROR_INDEX_OUT_OF_BOUNDS = 9 ' Numbered to have the same error number as the default "Subscript out of range" exeption
class JSONobject
dim i_debug, i_depth, i_parent
dim i_properties, i_version, i_defaultPropertyName
private vbback
' Set to true to show the internals of the parsing mecanism
public property get debug
debug = i_debug
end property
public property let debug(value)
i_debug = value
end property
' Gets/sets the default property name generated when loading recordsets and arrays (default "data")
public property get defaultPropertyName
defaultPropertyName = i_defaultPropertyName
end property
public property let defaultPropertyName(value)
i_defaultPropertyName = value
end property
' The depth of the object in the chain, starting with 1
public property get depth
depth = i_depth
end property
' The property pairs ("name": "value" - pairs)
public property get pairs
pairs = i_properties
end property
' The parent object
public property get parent
set parent = i_parent
end property
public property set parent(value)
set i_parent = value
i_depth = i_parent.depth + 1
end property
' Constructor and destructor
private sub class_initialize()
i_version = "3.8.1"
i_depth = 0
i_debug = false
i_defaultPropertyName = JSON_DEFAULT_PROPERTY_NAME
set i_parent = nothing
redim i_properties(-1)
vbback = Chr(8)
end sub
private sub class_terminate()
dim i
for i = 0 to ubound(i_properties)
set i_properties(i) = nothing
next
redim i_properties(-1)
end sub
' Parse a JSON string and populate the object
public function parse(byval strJson)
dim regex, i, size, char, prevchar, quoted
dim mode, item, key, value, openArray, openObject
dim actualLCID, tmpArray, tmpObj, addedToArray
dim root, currentObject, currentArray
log("Load string: """ & strJson & """")
' Store the actual LCID and use the en-US to conform with the JSON standard
actualLCID = Response.LCID
Response.LCID = 1033
strJson = trim(strJson)
size = len(strJson)
' At least 2 chars to continue
if size < 2 then err.raise JSON_ERROR_PARSE, TypeName(me), "Invalid JSON string to parse"
' Init the regex to be used in the loop
set regex = new regexp
regex.global = true
regex.ignoreCase = true
regex.pattern = "\w"
' setup initial values
i = 0
set root = me
key = JSON_ROOT_KEY
mode = "init"
quoted = false
set currentObject = root
' main state machine
do while i < size
i = i + 1
char = mid(strJson, i, 1)
' root, object or array start
if mode = "init" then
log("Enter init")
' if we are in root, clear previous object properties
if key = JSON_ROOT_KEY and TypeName(currentArray) <> "JSONarray" then redim i_properties(-1)
' Init object
if char = "{" then
log("Create object<ul>")
if key <> JSON_ROOT_KEY or TypeName(root) = "JSONarray" then
' creates a new object
set item = new JSONobject
set item.parent = currentObject
addedToArray = false
' Object is inside an array
if TypeName(currentArray) = "JSONarray" then
if currentArray.depth > currentObject.depth then
' Add it to the array
set item.parent = currentArray
currentArray.Push item
addedToArray = true
log("Added to the array")
end if
end if
if not addedToArray then
currentObject.add key, item
log("Added to parent object: """ & key & """")
end if
set currentObject = item
end if
openObject = openObject + 1
mode = "openKey"
' Init Array
elseif char = "[" then
log("Create array<ul>")
set item = new JSONarray
addedToArray = false
' Array is inside an array
if isobject(currentArray) and openArray > 0 then
if currentArray.depth > currentObject.depth then
' Add it to the array
set item.parent = currentArray
currentArray.Push item
addedToArray = true
log("Added to parent array")
end if
end if
if not addedToArray then
set item.parent = currentObject
currentObject.add key, item
log("Added to parent object")
end if
if key = JSON_ROOT_KEY and item.depth = 1 then
set root = item
log("Set as root")
end if
set currentArray = item
openArray = openArray + 1
mode = "openValue"
end if
' Init a key
elseif mode = "openKey" then
key = ""
if char = """" then
log("Open key")
mode = "closeKey"
elseif char = "}" then ' empty objects
log("Empty object")
mode = "next"
i = i - 1 ' we backup one char to make the next iteration get the closing bracket
end if
' Fill in the key until finding a double quote "
elseif mode = "closeKey" then
' If it finds a non scaped quotation, change to value mode
if char = """" and prevchar <> "\" then
log("Close key: """ & key & """")
mode = "preValue"
else
key = key & char
end if
' Wait until a colon char (:) to begin the value
elseif mode = "preValue" then
if char = ":" then
mode = "openValue"
log("Open value for """ & key & """")
end if
' Begining of value
elseif mode = "openValue" then
value = ""
' If the next char is a closing square barcket (]), its closing an empty array
if char = "]" then
log("Closing empty array")
quoted = false
mode = "next"
i = i - 1 ' we backup one char to make the next iteration get the closing bracket
' If it begins with a double quote, its a string value
elseif char = """" then
log("Open string value")
quoted = true
mode = "closeValue"
' If it begins with open square bracket ([), its an array
elseif char = "[" then
log("Open array value")
quoted = false
mode = "init"
i = i - 1 ' we backup one char to init with '['
' If it begins with open a bracket ({), its an object
elseif char = "{" then
log("Open object value")
quoted = false
mode = "init"
i = i - 1 ' we backup one char to init with '{'
else
' If its a number, start a numeric value
if regex.pattern <> "\d" then regex.pattern = "\d"
if regex.test(char) then
log("Open numeric value")
quoted = false
value = char
mode = "closeValue"
if prevchar = "-" then
value = prevchar & char
end if
' special values: null, true, false and undefined
elseif char = "n" or char = "t" or char = "f" or char = "u" then
log("Open special value")
quoted = false
value = char
mode = "closeValue"
end if
end if
' Fill in the value until finish
elseif mode = "closeValue" then
if quoted then
if char = """" and prevchar <> "\" then
log("Close string value: """ & value & """")
mode = "addValue"
' special and escaped chars
elseif prevchar = "\" then
select case char
case "n"
value = value & vblf
case "r"
value = value & vbcr
case "t"
value = value & vbtab
case "b"
value = value & vbback
' escaped chars fix by @IT-Portal
case "\"
'for \\t we must have \t (not \tab)
'here we're resetting prevchar for next iteration
value = value & char
char = ""
' escaped unicode syntax by @IT-Portal
case "u"
'\uxxxx support
if IsNumeric("&H" & mid(strJson, i + 1, 4)) then
value = value & ChrW("&H" & mid(strJson, i + 1, 4))
i = i + 4
else
value = value & char
end if
case else
value = value & char
end select
elseif char <> "\" then
value = value & char
end if
else
' possible boolean and null values
if regex.pattern <> JSON_SPECIAL_VALUES_REGEX then regex.pattern = JSON_SPECIAL_VALUES_REGEX
if regex.test(char) or regex.test(value) then
value = value & char
if value = "true" or value = "false" or value = "null" or value = "undefined" then mode = "addValue"
else
char = lcase(char)
' If is a numeric char
if regex.pattern <> "\d" then regex.pattern = "\d"
if regex.test(char) then
value = value & char
' If it's not a numeric char, but the prev char was a number
' used to catch separators and special numeric chars
elseif regex.test(prevchar) or prevchar = "e" then
if char = "." or char = "e" or (prevchar = "e" and (char = "-" or char = "+")) then
value = value & char
else
log("Close numeric value: " & value)
mode = "addValue"
i = i - 1
end if
else
log("Close numeric value: " & value)
mode = "addValue"
i = i - 1
end if
end if
end if
' Add the value to the object or array
elseif mode = "addValue" then
if key <> "" then
dim useArray
useArray = false
if not quoted then
if isNumeric(value) then
log("Value converted to number")
value = cdbl(value)
else
log("Value converted to " & value)
value = eval(value)
end if
end if
quoted = false
' If it's inside an array
if openArray > 0 and isObject(currentArray) then
useArray = true
' If it's a property of an object that is inside the array
' we add it to the object instead
if isObject(currentObject) then
if currentObject.depth >= currentArray.depth + 1 then useArray = false
end if
' else, we add it to the array
if useArray then
tmpArray = currentArray.items
ArrayPush tmpArray, value
currentArray.items = tmpArray
log("Value added to array: """ & key & """: " & value)
end if
end if
if not useArray then
currentObject.add key, value
log("Value added: """ & key & """")
end if
end if
mode = "next"
i = i - 1
' Change the current mode according to the current state
elseif mode = "next" then
if char = "," then
' If it's an array
if openArray > 0 and isObject(currentArray) then
' and the current object is a parent or sibling object
if currentArray.depth >= currentObject.depth then
' start an array value
log("New value")
mode = "openValue"
else
' start an object key
log("New key")
mode = "openKey"
end if
else
' start an object key
log("New key")
mode = "openKey"
end if
elseif char = "]" then
log("Close array</ul>")
' If it's and open array, we close it and set the current array as its parent
if isobject(currentArray.parent) then
if TypeName(currentArray.parent) = "JSONarray" then
set currentArray = currentArray.parent
' if the parent is an object
elseif TypeName(currentArray.parent) = "JSONobject" then
set tmpObj = currentArray.parent
' we search for the next parent array to set the current array
while isObject(tmpObj) and TypeName(tmpObj) = "JSONobject"
if isObject(tmpObj.parent) then
set tmpObj = tmpObj.parent
else
tmpObj = tmpObj.parent
end if
wend
set currentArray = tmpObj
end if
else
currentArray = currentArray.parent
end if
openArray = openArray - 1
mode = "next"
elseif char = "}" then
log("Close object</ul>")
' If it's an open object, we close it and set the current object as it's parent
if isobject(currentObject.parent) then
if TypeName(currentObject.parent) = "JSONobject" then
set currentObject = currentObject.parent
' If the parent is and array
elseif TypeName(currentObject.parent) = "JSONarray" then
set tmpObj = currentObject.parent
' we search for the next parent object to set the current object
while isObject(tmpObj) and TypeName(tmpObj) = "JSONarray"
set tmpObj = tmpObj.parent
wend
set currentObject = tmpObj
end if
else
currentObject = currentObject.parent
end if
openObject = openObject - 1
mode = "next"
end if
end if
prevchar = char
loop
set regex = nothing
Response.LCID = actualLCID
set parse = root
end function
' Add a new property (key-value pair)
public sub add(byval prop, byval obj)
dim p
getProperty prop, p
if GetTypeName(p) = "JSONpair" then
err.raise JSON_ERROR_PROPERTY_ALREADY_EXISTS, TypeName(me), "A property already exists with the name: " & prop & "."
else
dim item
set item = new JSONpair
item.name = prop
set item.parent = me
dim itemType
itemType = GetTypeName(obj)
if isArray(obj) then
dim item2
set item2 = new JSONarray
item2.items = obj
set item2.parent = me
set item.value = item2
elseif itemType = "Field" then
item.value = obj.value
elseif isObject(obj) and itemType <> "IStringList" then
set item.value = obj
else
item.value = obj
end if
ArrayPush i_properties, item
end if
end sub
' Remove a property from the object (key-value pair)
public sub remove(byval prop)
dim p, i
i = getProperty(prop, p)
' property exists
if i > -1 then ArraySlice i_properties, i
end sub
' Return the value of a property by its key
public default function value(byval prop)
dim p
getProperty prop, p
if GetTypeName(p) = "JSONpair" then
if isObject(p.value) then
set value = p.value
else
value = p.value
end if
else
value = null
end if
end function
' Change the value of a property
' Creates the property if it didn't exists
public sub change(byval prop, byval obj)
dim p
getProperty prop, p
if GetTypeName(p) = "JSONpair" then
if isArray(obj) then
set item = new JSONarray
item.items = obj
set item.parent = me
p.value = item
elseif isObject(obj) then
set p.value = obj
else
p.value = obj
end if
else
add prop, obj
end if
end sub
' Returns the index of a property if it exists, else -1
' @param prop as string - the property name
' @param out outProp as variant - will be filled with the property value, nothing if not found
private function getProperty(byval prop, byref outProp)
dim i, p, found
set outProp = nothing
found = false
i = 0
do while i <= ubound(i_properties)
set p = i_properties(i)
if p.name = prop then
set outProp = p
found = true
exit do
end if
i = i + 1
loop
if not found then i = -1
getProperty = i
end function
' Serialize the current object to a JSON formatted string
public function Serialize()
dim actualLCID, out
actualLCID = Response.LCID
Response.LCID = 1033
out = serializeObject(me)
Response.LCID = actualLCID
Serialize = out
end function
' Writes the JSON serialized object to the response
public sub write()
response.write Serialize
end sub
' Helpers
' Serializes a JSON object to JSON formatted string
public function serializeObject(obj)
dim out, prop, value, i, pairs, valueType
out = "{"
pairs = obj.pairs
for i = 0 to ubound(pairs)
set prop = pairs(i)
if out <> "{" then out = out & ","
if isobject(prop.value) then
set value = prop.value
else
value = prop.value
end if
if prop.name = JSON_ROOT_KEY then
out = out & """" & obj.defaultPropertyName & """:"
else
out = out & """" & prop.name & """:"
end if
if isArray(value) or GetTypeName(value) = "JSONarray" then
out = out & serializeArray(value)
elseif isObject(value) and GetTypeName(value) = "JSONscript" then
out = out & value.Serialize()
elseif isObject(value) then
out = out & serializeObject(value)
else
out = out & serializeValue(value)
end if
next
out = out & "}"
serializeObject = out
end function
' Serializes a value to a valid JSON formatted string representing the value
' (quoted for strings, the type name for objects, null for nothing and null values)
public function serializeValue(byval value)
dim out
select case lcase(GetTypeName(value))
case "null"
out = "null"
case "nothing"
out = "undefined"
case "boolean"
if value then
out = "true"
else
out = "false"
end if
case "byte", "integer", "long", "single", "double", "currency", "decimal"
out = value
case "date"
out = """" & year(value) & "-" & padZero(month(value), 2) & "-" & padZero(day(value), 2) & "T" & padZero(hour(value), 2) & ":" & padZero(minute(value), 2) & ":" & padZero(second(value), 2) & """"
case "string", "char", "empty"
out = """" & EscapeCharacters(value) & """"
case else
out = """" & GetTypeName(value) & """"
end select
serializeValue = out
end function
' Pads a numeric string with zeros at left
private function padZero(byval number, byval length)
dim result
result = number
while len(result) < length
result = "0" & result
wend
padZero = result
end function
' Serializes an array item to JSON formatted string
private function serializeArrayItem(byref elm)
dim out, val
if isobject(elm) then
if GetTypeName(elm) = "JSONobject" then
set val = elm
elseif GetTypeName(elm) = "JSONarray" then
val = elm.items
elseif isObject(elm.value) then
set val = elm.value
else
val = elm.value
end if
else
val = elm
end if
if isArray(val) or GetTypeName(val) = "JSONarray" then
out = out & serializeArray(val)
elseif isObject(val) then
out = out & serializeObject(val)
else
out = out & serializeValue(val)
end if
serializeArrayItem = out
end function
' Serializes an array or JSONarray object to JSON formatted string
public function serializeArray(byref arr)
dim i, j, k, dimensions, out, innerArray, elm, val
out = "["
if isobject(arr) then
log("Serializing jsonArray object")
innerArray = arr.items
else
log("Serializing VB array")
innerArray = arr
end if
dimensions = NumDimensions(innerArray)
if dimensions > 1 then
log("Multidimensional array")
for j = 0 to ubound(innerArray, 1)
out = out & "["
for k = 0 to ubound(innerArray, 2)
if k > 0 then out = out & ","
if isObject(innerArray(j, k)) then
set elm = innerArray(j, k)
else
elm = innerArray(j, k)
end if
out = out & serializeArrayItem(elm)
next
out = out & "]"
next
else
for j = 0 to ubound(innerArray)
if j > 0 then out = out & ","
if isobject(innerArray(j)) then
set elm = innerArray(j)
else
elm = innerArray(j)
end if
out = out & serializeArrayItem(elm)
next
end if
out = out & "]"
serializeArray = out
end function
' Returns the number of dimensions an array has
public Function NumDimensions(byref arr)
Dim dimensions
dimensions = 0
On Error Resume Next
Do While Err.number = 0
dimensions = dimensions + 1
UBound arr, dimensions
Loop
On Error Goto 0
NumDimensions = dimensions - 1
End Function
' Pushes (adds) a value to an array, expanding it
public function ArrayPush(byref arr, byref value)
redim preserve arr(ubound(arr) + 1)
if isobject(value) then
set arr(ubound(arr)) = value
else
arr(ubound(arr)) = value
end if
ArrayPush = arr
end function
' Removes a value from an array
private function ArraySlice(byref arr, byref index)
dim i, upperBound
i = index
upperBound = ubound(arr)
do while i < upperBound
if isObject(arr(i)) then
set arr(i) = arr(i + 1)
else
arr(i) = arr(i + 1)
end if
i = i + 1
loop
redim preserve arr(upperBound - 1)
ArraySlice = arr
end function
' Load properties from an ADO RecordSet object into an array
' @param rs as ADODB.RecordSet
public sub LoadRecordSet(byref rs)
dim arr, obj, field
set arr = new JSONArray
while not rs.eof
set obj = new JSONobject
for each field in rs.fields
obj.Add field.name, field.value
next
arr.Push obj
rs.movenext
wend
set obj = nothing
add JSON_ROOT_KEY, arr
end sub
' Load properties from the first record of an ADO RecordSet object
' @param rs as ADODB.RecordSet
public sub LoadFirstRecord(byref rs)
dim field
for each field in rs.fields
add field.name, field.value
next
end sub
' Returns the value's type name (usefull for types not supported by VBS)
public function GetTypeName(byval value)
dim valueType
on error resume next
valueType = TypeName(value)
if err.number <> 0 then
if varType(value) = 14 then valueType = "Decimal"
end if
on error goto 0
GetTypeName = valueType
end function
' Escapes special characters in the text
' @param text as String
public function EscapeCharacters(byval text)
dim result
result = text
if not isNull(text) then
result = cstr(result)
result = replace(result, "\", "\\")
result = replace(result, """", "\""")
result = replace(result, vbcr, "\r")
result = replace(result, vblf, "\n")
result = replace(result, vbtab, "\t")
result = replace(result, vbback, "\b")
end if
EscapeCharacters = result
end function
' Used to write the log messages to the response on debug mode
private sub log(byval msg)
if i_debug then response.write "<li>" & msg & "</li>" & vbcrlf
end sub
end class
' JSON array class
' Represents an array of JSON objects and values
class JSONarray
dim i_items, i_depth, i_parent, i_version, i_defaultPropertyName
' The class version
public property get version
version = i_version
end property
' The actual array items
public property get items
items = i_items
end property
public property let items(value)
if isArray(value) then
i_items = value
else
err.raise JSON_ERROR_NOT_AN_ARRAY, TypeName(me), "The value assigned is not an array."
end if
end property
' The length of the array
public property get length
length = ubound(i_items) + 1
end property
' The depth of the array in the chain (starting with 1)
public property get depth
depth = i_depth
end property
' The parent object or array
public property get parent
set parent = i_parent
end property
public property set parent(value)
set i_parent = value
i_depth = i_parent.depth + 1
i_defaultPropertyName = i_parent.defaultPropertyName
end property
' Gets/sets the default property name generated when loading recordsets and arrays (default "data")
public property get defaultPropertyName
defaultPropertyName = i_defaultPropertyName
end property
public property let defaultPropertyName(value)
i_defaultPropertyName = value
end property
' Constructor and destructor
private sub class_initialize
i_version = "2.3.5"
i_defaultPropertyName = JSON_DEFAULT_PROPERTY_NAME
redim i_items(-1)
i_depth = 0
end sub
private sub class_terminate
dim i, j, js, dimensions
dimensions = 0
On Error Resume Next
Do While Err.number = 0
dimensions = dimensions + 1
UBound i_items, dimensions
Loop
On Error Goto 0
dimensions = dimensions - 1
for i = 1 to dimensions
for j = 0 to ubound(i_items, i)
if dimensions = 1 then
set i_items(j) = nothing
else
set i_items(i - 1, j) = nothing
end if
next
next
end sub
' Adds a value to the array
public sub Push(byref value)
dim js, instantiated
if typeName(i_parent) = "JSONobject" then
set js = i_parent
i_defaultPropertyName = i_parent.defaultPropertyName
else
set js = new JSONobject
js.defaultPropertyName = i_defaultPropertyName
instantiated = true
end if
js.ArrayPush i_items, value
if instantiated then set js = nothing
end sub
' Load properties from a ADO RecordSet object
public sub LoadRecordSet(byref rs)
dim obj, field
while not rs.eof
set obj = new JSONobject
for each field in rs.fields
obj.Add field.name, field.value
next
Push obj
rs.movenext
wend
set obj = nothing
end sub
' Returns the item at the specified index
' @param index as int - the desired item index
public default function ItemAt(byval index)
dim len
len = me.length
if len > 0 and index < len then
if isObject(i_items(index)) then
set ItemAt = i_items(index)
else
ItemAt = i_items(index)
end if
else
err.raise JSON_ERROR_INDEX_OUT_OF_BOUNDS, TypeName(me), "Index out of bounds."
end if
end function
' Serializes this JSONarray object in JSON formatted string value
' (uses the JSONobject.SerializeArray method)
public function Serialize()
dim js, out, instantiated, actualLCID
actualLCID = Response.LCID
Response.LCID = 1033
if not isEmpty(i_parent) then
if TypeName(i_parent) = "JSONobject" then
set js = i_parent
i_defaultPropertyName = i_parent.defaultPropertyName
end if
end if
if isEmpty(js) then
set js = new JSONobject
js.defaultPropertyName = i_defaultPropertyName
instantiated = true
end if
out = js.SerializeArray(me)
if instantiated then set js = nothing
Response.LCID = actualLCID
Serialize = out
end function
' Writes the serialized array to the response
public function Write()
Response.Write Serialize()
end function
end class
class JSONscript
dim i_version
dim s_value, s_nullString
' The value
public property get value
value = s_value
end property
public property let value(newValue)
if (TypeName(newValue) <> "String") then
err.raise JSON_ERROR_NOT_A_STRING, TypeName(me), "The value assigned is not a string."
end if
if (len(newValue) = 0) then newValue = s_nullString
s_value = newValue
end property
' Constructor and destructor
private sub class_initialize()
i_version = "1.0.0"
s_nullString = "null"
s_value = s_nullString
end sub
' Serializes this object by outputting the raw value
public function Serialize()
Serialize = s_value
end function
' Writes the serialized object to the response
public function Write()
Response.Write Serialize()
end function
end class
' JSON pair class
' represents a name/value pair of a JSON object
class JSONpair
dim i_name, i_value
dim i_parent
' The name or key of the pair
public property get name
name = i_name
end property
public property let name(val)
i_name = val
end property
' The value of the pair
public property get value
if isObject(i_value) then
set value = i_value
else
value = i_value
end if
end property
public property let value(val)
i_value = val
end property
public property set value(val)
set i_value = val
end property
' The parent object
public property get parent
set parent = i_parent
end property
public property set parent(val)
set i_parent = val
end property
' Constructor and destructor
private sub class_initialize
end sub
private sub class_terminate
if isObject(value) then set value = nothing
end sub
end class
%>
来源：https://gitcode.com/gh_mirrors/as/aspJSON/blob/master/jsonObject.class.asp