ASP JSON类源码分享

<%
'============================================================
' 文件名称 : /cls_json.asp
' 文件作用 : 系统json类文件
' 文件版本 : vbs json(javascript object notation) version 2.0.2
' 程序修改 : cloud.l
' 最后更新 : 2009-05-12
'============================================================
' 程序核心 : json官方　http://www.json.org/
' 作者博客 : http://www.cnode.cn
'============================================================
class json_cls

public collection
public count
public quotedvars '是否为变量增加引号
public kind ' 0 = object, 1 = array

private sub class_initialize
set collection = server.createobject(gp_scriptingdictionary)
quotedvars = true
count = 0
end sub

private sub class_terminate
set collection = nothing
end sub

' counter
private property get counter
counter = count
count = count + 1
end property

' 设置对象类型
public property let setkind(byval fpkind)
select case lcase(fpkind)
case "object":kind=0
case "array":kind=1
end select
end property

' - data maluplation
' -- pair
public property let pair(p, v)
if isnull(p) then p = counter
collection(p) = v
end property

public property set pair(p, v)
if isnull(p) then p = counter
if typename(v) <> "json_cls" then
err.raise &hd, "class: class", "class object: '" & typename(v) & "'"
end if
set collection(p) = v
end property

public default property get pair(p)
if isnull(p) then p = count - 1
if isobject(collection(p)) then
set pair = collection(p)
else
pair = collection(p)
end if
end property
' -- pair
public sub clean
collection.removeall
end sub

public sub remove(vprop)
collection.remove vprop
end sub
' data maluplation

' encoding
public function jsencode(str)
dim i, j, al1, al2, c, p

al1 = array(&h22, &h5c, &h2f, &h08, &h0c, &h0a, &h0d, &h09)
al2 = array(&h22, &h5c, &h2f, &h62, &h66, &h6e, &h72, &h74)
for i = 1 to len(str)
p = true
c = mid(str, i, 1)
for j = 0 to 7
if c = chr(al1(j)) then
jsencode = jsencode & "\" & chr(al2(j))
p = false
exit for
end if
next

if p then
dim a
a = ascw(c)
if a > 31 and a < 127 then
jsencode = jsencode & c
elseif a > -1 or a < 65535 then
jsencode = jsencode & "\u" & string(4 - len(hex(a)), "0") & hex(a)
end if
end if
next
end function

' converting
public function tojson(vpair)
select case vartype(vpair)
case 1 ' null
tojson = "null"
case 7 ' date
' yaz saati problemi var
' jsvalue = "new date(" & round((vval - #01/01/1970 02:00#) * 86400000) & ")"
tojson = """" & cstr(vpair) & """"
case 8 ' string
tojson = """" & jsencode(vpair) & """"
case 9 ' object
dim bfi,i
bfi = true
if vpair.kind then tojson = tojson & "[" else tojson = tojson & "{"
for each i in vpair.collection
if bfi then bfi = false else tojson = tojson & ","

if vpair.kind then
tojson = tojson & tojson(vpair(i))
else
if quotedvars then
tojson = tojson & """" & i & """:" & tojson(vpair(i))
else
tojson = tojson & i & ":" & tojson(vpair(i))
end if
end if
next
if vpair.kind then tojson = tojson & "]" else tojson = tojson & "}"
case 11
if vpair then tojson = "true" else tojson = "false"
case 12, 8192, 8204
dim seb
tojson = multiarray(vpair, 1, "", seb)
case else
tojson = replace(vpair, ",", ".")
end select
end function

public function multiarray(abd, ibc, sps, byref spt) ' array body, integer basecount, string position
dim idu, idl, i ' integer dimensionubound, integer dimensionlbound
on error resume next
idl = lbound(abd, ibc)
idu = ubound(abd, ibc)

dim spb1, spb2 ' string pointbuffer1, string pointbuffer2
if err = 9 then
spb1 = spt & sps
for i = 1 to len(spb1)
if i <> 1 then spb2 = spb2 & ","
spb2 = spb2 & mid(spb1, i, 1)
next
multiarray = multiarray & tojson(eval("abd(" & spb2 & ")"))
else
spt = spt & sps
multiarray = multiarray & "["
for i = idl to idu
multiarray = multiarray & multiarray(abd, ibc + 1, i, spt)
if i < idu then multiarray = multiarray & ","
next
multiarray = multiarray & "]"
spt = left(spt, ibc - 2)
end if
end function

public property get tostring
tostring = tojson(me)
end property

public sub flush
if typename(response) <> "empty" then
response.write(tostring)
elseif wscript <> empty then
wscript.echo(tostring)
end if
end sub

public function clone
set clone = colclone(me)
end function

private function colclone(core)
dim jsc, i
set jsc = new json_cls
jsc.kind = core.kind
for each i in core.collection
if isobject(core(i)) then
set jsc(i) = colclone(core(i))
else
jsc(i) = core(i)
end if
next
set colclone = jsc
end function

public function querytojson(dbc, sql)
dim rs, jsa,col
set rs = dbc.execute(sql)
set jsa = new json_cls
jsa.setkind="array"
while not (rs.eof or rs.bof)
set jsa(null) = new json_cls
jsa(null).setkind="object"
for each col in rs.fields
jsa(null)(col.name) = col.value
next
rs.movenext
wend
set querytojson = jsa
end function

end class
%>