<%@ LANGUAGE = VBScript CodePage = 65001%>
<%
class JSON
private output, innerCall
public toResponse ''[bool] should generated results be directly written to the response? default = false
public sub class_initialize()
newGeneration()
toResponse = false
end sub
public function escape(val)
dim cDoubleQuote, cRevSolidus, cSolidus
cDoubleQuote = &h22
cRevSolidus = &h5C
cSolidus = &h2F
dim i, currentDigit
for i = 1 to (len(val))
currentDigit = mid(val, i, 1)
if ascw(currentDigit) > &h00 and ascw(currentDigit) < &h1F then
currentDigit = escapequence(currentDigit)
elseif ascw(currentDigit) >= &hC280 and ascw(currentDigit) <= &hC2BF then
currentDigit = "\u00" + right(padLeft(hex(asc(currentDigit) - &hC200), 2, 0), 2)
elseif ascw(currentDigit) >= &hC380 and ascw(currentDigit) <= &hC3BF then
currentDigit = "\u00" + right(padLeft(hex(ascw(currentDigit) - &hC2C0), 2, 0), 2)
else
select case ascw(currentDigit)
case cDoubleQuote: currentDigit = escapequence(currentDigit)
case cRevSolidus: currentDigit = escapequence(currentDigit)
case cSolidus: currentDigit = escapequence(currentDigit)
end select
end if
escape = escape & currentDigit
next
end function
public function toJSON(name, val, nested)
if not nested and not isEmpty(name) then write("{")
if not isEmpty(name) then write("""" & escape(name) & """: ")
generateValue(val)
if not nested and not isEmpty(name) then write("}")
toJSON = output
if innerCall = 0 then newGeneration()
end function
private function generateValue(val)
if isNull(val) then
write("null")
elseif isArray(val) then
generateArray(val)
elseif isObject(val) then
if val is nothing then
write("null")
elseif typename(val) = "Dictionary" then
generateDictionary(val)
elseif typename(val) = "Recordset" then
generateRecordset(val)
else
generateObject(val)
end if
else
'bool
varTyp = varType(val)
if varTyp = 11 then
if val then write("true") else write("false")
'int, long, byte
elseif varTyp = 2 or varTyp = 3 or varTyp = 17 or varTyp = 19 then
write(cLng(val))
'single, double, currency
elseif varTyp = 4 or varTyp = 5 or varTyp = 6 or varTyp = 14 then
write(replace(cDbl(val), ",", "."))
else
write("""" & escape(val & "") & """")
end if
end if
generateValue = output
end function
private sub generateArray(val)
dim item, i
write("[")
i = 0
'the for each allows us to support also multi dimensional arrays
for each item in val
if i > 0 then write(",")
generateValue(item)
i = i + 1
next
write("]")
end sub
private sub generateDictionary(val)
dim keys, i
innerCall = innerCall + 1
write("{")
keys = val.keys
for i = 0 to uBound(keys)
if i > 0 then write(",")
toJSON keys(i), val(keys(i)), true
next
write("}")
innerCall = innerCall - 1
end sub
'*******************************************************************
'* generateRecordset
'*******************************************************************
private sub generateRecordset(val)
dim i
write("[")
while not val.eof
innerCall = innerCall + 1
write("{")
for i = 0 to val.fields.count - 1
if i > 0 then write(",")
toJSON lCase(val.fields(i).name), val.fields(i).value, true
next
write("}")
val.movenext()
if not val.eof then write(",")
innerCall = innerCall - 1
wend
write("]")
end sub
'*******************************************************************************
'* generateObject
'*******************************************************************************
private sub generateObject(val)
dim props
on error resume next
set props = val.reflect()
if err = 0 then
on error goto 0
innerCall = innerCall + 1
toJSON empty, props, true
innerCall = innerCall - 1
else
on error goto 0
write("""" & escape(typename(val)) & """")
end if
end sub
'*******************************************************************************
'* newGeneration
'*******************************************************************************
private sub newGeneration()
output = empty
innerCall = 0
end sub
'*******************************************************************************
'* JsonEscapeSquence
'*******************************************************************************
private function escapequence(digit)
escapequence = "\u00" + right(padLeft(hex(asc(digit)), 2, 0), 2)
end function
'*****************************************************************************
'* padLeft
'*****************************************************************************
private function padLeft(value, totalLength, paddingChar)
padLeft = right(clone(paddingChar, totalLength) & value, totalLength)
end function
'*****************************************************************************
'* clone
'******************************************************************************************
public function clone(byVal str, n)
dim i
for i = 1 to n : clone = clone & str : next
end function
'******************************************************************************************
'* write
'******************************************************************************************
private sub write(val)
if toResponse then
response.write(val)
else
output = output & val
end if
end sub
end class
response.ContentType="text/json"
dim j
'多重嵌套的JSON,要使用Dictionary才能实现
set j=new json
set jso=server.createobject("scripting.dictionary")
dbstr = request("dbstr") '设置每页显示的记录数
if dbstr = "" then dbstr = "driver={SQL Server};Server=;UID=yxbl;PWD=yxbl;database=GlassQualityTest"
'if dbstr = "" then dbstr = "DSN=sql;Database=GlassQualityTest;UID=yxbl;PWD=yxbl;"
conn()
function conn()
dim conn1,connstr
on error resume next
set conn1 = Server.CreateObject("ADODB.Connection")
conn1.open dbstr
if err <> 0 then
jso.add "dbstr",dbstr
jso.add "err",err.description
response.write j.toJSON(empty,jso,false)
response.end
end if
set conn = conn1
end function
Sub echo(str)
Response.Write(str)
End Sub
'正则表达式函数，用于删除注释
'-------------------------------------
Function RegExpReplace(strng, patrn, replStr)
Dim regEx,match,matches ' 建立变量。
Set regEx = New RegExp ' 建立正则表达式。
regEx.Pattern = patrn ' 设置模式。
regEx.IgnoreCase = True ' 设置是否区分大小写。
regEx.Global = True ' 设置全局可用性。
RegExpReplace = regEx.Replace(strng, replStr) ' 作替换。
End Function
'==================================================================显示查询
sub showselect(sql)
dim page,pageUrl,strdel,geturl
pageSize = request("pageSize") '设置每页显示的记录数
if pageSize = "" or not isNumeric(pageSize) then pageSize = 500
page = request("page") '设置当前显示的页数
if page="" or not isNumeric(page) then page=1
pageUrl = "?sql=" & Server.URLEncode(sql)
dim rs
set rs = Server.CreateObject("ADODB.Recordset")
rs.Open sql,conn,3
if not rs.eof then
rs.pageSize = pageSize
if cint(page) < 1 then page = 1
if cint(page) > rs.PageCount then page = rs.PageCount
rs.absolutePage = page
end if
set pag=server.createobject("scripting.dictionary")
pag.add "page",page
pag.add "pageSize",pageSize
pag.add "recordCount",rs.recordCount
pag.add "PageCount",rs.PageCount
jso.add "page",pag
jso.add "rs",rs
end sub
sub exesql(sql)
on error resume next
if sql = "" then exit sub
sql = RegExpReplace(sql, "(--)(.)*\n", "") '替换注释
sql = RegExpReplace(sql, "\n[\s| ]*\r", "") '替换空行
sql = RegExpReplace(sql, "\n", "") '替换换行符
sql = RegExpReplace(sql, "\r", "") '替换回车符
if (LCase(left(sql,len("select"))) = "select") and instr(sql,"into") = 0 then '只允许select
Call showSelect (sql)
if err <> 0 then
jso.add "sql",trim(request("sql"))
jso.add "err",err.description
response.write j.toJSON(empty,jso,false)
response.end
end if
end if
end sub
call exesql(trim(request("sql")))
response.write j.toJSON(empty,jso,false)
%>
