ASP JSON类源码分享

　　复制代码 代码如下:
<%
============================================================
文件名称 : /Cls_Json.asp
文件作用 : 系统JSON类文件
文件版本 : VBS JSON(JavaScript Object Notation) Version 2.0.2
程序修改 : Cloud.L
最后更新 : 2009-05-12
============================================================
程序核心 : JSON官方
作者博客 :
============================================================
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 & {
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
Next
rs.MoveNext
Wend
Set QueryToJSON = jsa
End Function

End Class
%>