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_ClsPublic CollectionPublic CountPublic QuotedVars '是否为变量增加引号Public Kind ' 0 = object, 1 = arrayPrivate Sub Class_InitializeSet Collection = Server.CreateObject(GP_ScriptingDictionary)QuotedVars = TrueCount = 0End SubPrivate Sub Class_TerminateSet Collection = NothingEnd Sub' counterPrivate Property Get Counter Counter = CountCount = Count + 1End Property' 设置对象类型Public Property Let SetKind(ByVal fpKind)Select Case LCase(fpKind)Case "object":Kind=0Case "array":Kind=1End SelectEnd Property' - data maluplation' -- pairPublic Property Let Pair(p, v)If IsNull(p) Then p = CounterCollection(p) = vEnd PropertyPublic Property Set Pair(p, v)If IsNull(p) Then p = CounterIf TypeName(v) <> "Json_Cls" ThenErr.Raise &hD, "class: class", "class object: '" & TypeName(v) & "'"End IfSet Collection(p) = vEnd PropertyPublic Default Property Get Pair(p)If IsNull(p) Then p = Count - 1If IsObject(Collection(p)) ThenSet Pair = Collection(p)ElsePair = Collection(p)End IfEnd Property' -- pairPublic Sub CleanCollection.RemoveAllEnd SubPublic Sub Remove(vProp)Collection.Remove vPropEnd Sub' data maluplation' encodingPublic Function jsEncode(str)Dim i, j, aL1, aL2, c, paL1 = 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 = Truec = Mid(str, i, 1)For j = 0 To 7If c = Chr(aL1(j)) ThenjsEncode = jsEncode & "\" & Chr(aL2(j))p = FalseExit ForEnd IfNextIf p Then Dim aa = AscW(c)If a > 31 And a < 127 ThenjsEncode = jsEncode & cElseIf a > -1 Or a < 65535 ThenjsEncode = jsEncode & "\u" & String(4 - Len(Hex(a)), "0") & Hex(a)End If End IfNextEnd Function' convertingPublic Function toJSON(vPair)Select Case VarType(vPair)Case 1' NulltoJSON = "null"Case 7' Date' yaz saati problemi var' jsValue = "new Date(" & Round((vVal - #01/01/1970 02:00#) * 86400000) & ")"toJSON = """" & CStr(vPair) & """"Case 8' StringtoJSON = """" & jsEncode(vPair) & """"Case 9' ObjectDim bFI,i bFI = TrueIf vPair.Kind Then toJSON = toJSON & "[" Else toJSON = toJSON & "{"For Each i In vPair.CollectionIf bFI Then bFI = False Else toJSON = toJSON & ","If vPair.Kind Then toJSON = toJSON & toJSON(vPair(i))ElseIf QuotedVars ThentoJSON = toJSON & """" & i & """:" & toJSON(vPair(i))ElsetoJSON = toJSON & i & ":" & toJSON(vPair(i))End IfEnd IfNextIf vPair.Kind Then toJSON = toJSON & "]" Else toJSON = toJSON & "}"Case 11If vPair Then toJSON = "true" Else toJSON = "false"Case 12, 8192, 8204Dim sEBtoJSON = MultiArray(vPair, 1, "", sEB)Case ElsetoJSON = Replace(vPair, ",", ".")End selectEnd FunctionPublic Function MultiArray(aBD, iBC, sPS, ByRef sPT)' Array BoDy, Integer BaseCount, String PoSitionDim iDU, iDL, i' Integer DimensionUBound, Integer DimensionLBoundOn Error Resume NextiDL = LBound(aBD, iBC)iDU = UBound(aBD, iBC)Dim sPB1, sPB2' String PointBuffer1, String PointBuffer2If Err = 9 ThensPB1 = sPT & sPSFor i = 1 To Len(sPB1)If i <> 1 Then sPB2 = sPB2 & ","sPB2 = sPB2 & Mid(sPB1, i, 1)NextMultiArray = MultiArray & toJSON(Eval("aBD(" & sPB2 & ")"))ElsesPT = sPT & sPSMultiArray = MultiArray & "["For i = iDL To iDUMultiArray = MultiArray & MultiArray(aBD, iBC + 1, i, sPT)If i < iDU Then MultiArray = MultiArray & ","NextMultiArray = MultiArray & "]"sPT = Left(sPT, iBC - 2)End IfEnd FunctionPublic Property Get ToStringToString = toJSON(Me)End PropertyPublic Sub FlushIf TypeName(Response) <> "Empty" Then Response.Write(ToString)ElseIf WScript <> Empty Then WScript.Echo(ToString)End IfEnd SubPublic Function CloneSet Clone = ColClone(Me)End FunctionPrivate Function ColClone(core)Dim jsc, iSet jsc = New Json_Clsjsc.Kind = core.KindFor Each i In core.CollectionIf IsObject(core(i)) ThenSet jsc(i) = ColClone(core(i))Elsejsc(i) = core(i)End IfNextSet ColClone = jscEnd FunctionPublic 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 = jsaEnd FunctionEnd Class％>