ASP JSON类源码分享

dly · 发表于 2011-9-7 12:34:52

<%
'============================================================
' 文件名称 : /Cls_Json.asp
' 文件作用 : 系统JSON类文件
' 文件版本 : VBS JSON(JavaScript Object Notation) Version 2.0.2
' 程序修改 : Cloud.L
' 最后更新 : 2009-05-12
'============================================================
' 程序核心 : JSON官方　[url]http://www.json.org/[/url]
' 作者博客 : [url]Http://www.cnode.cn[/url]
'============================================================
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
%>

复制代码