Json for asp
1
'
2' VBS JSON 2.0.2
3' Copyright (c) 2008 Turul Topuz
4' Under the MIT (MIT-LICENSE.txt) license.
5'
6
7Const JSON_OBJECT = 0
8Const JSON_ARRAY = 1
9
10Class jsCore
11 Public Collection
12 Public Count
13 Public QuotedVars
14 Public Kind ' 0 = object, 1 = array
15
16 Private Sub Class_Initialize
17 Set Collection = CreateObject("Scripting.Dictionary")
18 QuotedVars = True
19 Count = 0
20 End Sub
21
22 Private Sub Class_Terminate
23 Set Collection = Nothing
24 End Sub
25
26 ' counter
27 Private Property Get Counter
28 Counter = Count
29 Count = Count + 1
30 End Property
31
32 ' - data maluplation
33 ' -- pair
34 Public Property Let Pair(p, v)
35 If IsNull(p) Then p = Counter
36 Collection(p) = v
37 End Property
38
39 Public Property Set Pair(p, v)
40 If IsNull(p) Then p = Counter
41 If TypeName(v) <> "jsCore" Then
42 Err.Raise &hD, "class: class", "Tr uyumsuz: '" & TypeName(v) & "'"
43 End If
44 Set Collection(p) = v
45 End Property
46
47 Public Default Property Get Pair(p)
48 If IsNull(p) Then p = Count - 1
49 If IsObject(Collection(p)) Then
50 Set Pair = Collection(p)
51 Else
52 Pair = Collection(p)
53 End If
54 End Property
55 ' -- pair
56 Public Sub Clean
57 Collection.RemoveAll
58 End Sub
59
60 Public Sub Remove(vProp)
61 Collection.Remove vProp
62 End Sub
63 ' data maluplation
64
65 ' encoding
66 Function jsEncode(str)
67 Dim i, j, aL1, aL2, c, p
68
69 aL1 = Array(&h22, &h5C, &h2F, &h08, &h0C, &h0A, &h0D, &h09)
70 aL2 = Array(&h22, &h5C, &h2F, &h62, &h66, &h6E, &h72, &h74)
71 For i = 1 To Len(str)
72 p = True
73 c = Mid(str, i, 1)
74 For j = 0 To 7
75 If c = Chr(aL1(j)) Then
76 jsEncode = jsEncode & "\" & Chr(aL2(j))
77 p = False
78 Exit For
79 End If
80 Next
81
82 If p Then
83 Dim a
84 a = AscW(c)
85 If a > 31 And a < 127 Then
86 jsEncode = jsEncode & c
87 ElseIf a > -1 Or a < 65535 Then
88 jsEncode = jsEncode & "\u" & String(4 - Len(Hex(a)), "0") & Hex(a)
89 End If
90 End If
91 Next
92 End Function
93
94 ' converting
95 Public Function toJSON(vPair)
96 Select Case VarType(vPair)
97 Case 1 ' Null
98 toJSON = "null"
99 Case 7 ' Date
100 ' yaz saati problemi var
101 ' jsValue = "new Date(" & Round((vVal - #01/01/1970 02:00#) * 86400000) & ")"
102 toJSON = """" & CStr(vPair) & """"
103 Case 8 ' String
104 toJSON = """" & jsEncode(vPair) & """"
105 Case 9 ' Object
106 Dim bFI,i
107 bFI = True
108 If vPair.Kind Then toJSON = toJSON & "[" Else toJSON = toJSON & "{"
109 For Each i In vPair.Collection
110 If bFI Then bFI = False Else toJSON = toJSON & ","
111
112 If vPair.Kind Then
113 toJSON = toJSON & toJSON(vPair(i))
114 Else
115 If QuotedVars Then
116 toJSON = toJSON & """" & i & """:" & toJSON(vPair(i))
117 Else
118 toJSON = toJSON & i & ":" & toJSON(vPair(i))
119 End If
120 End If
121 Next
122 If vPair.Kind Then toJSON = toJSON & "]" Else toJSON = toJSON & "}"
123 Case 11
124 If vPair Then toJSON = "true" Else toJSON = "false"
125 Case 12, 8192, 8204
126 Dim sEB
127 toJSON = MultiArray(vPair, 1, "", sEB)
128 Case Else
129 toJSON = Replace(vPair, ",", ".")
130 End select
131 End Function
132
133 Function MultiArray(aBD, iBC, sPS, ByRef sPT) ' Array BoDy, Integer BaseCount, String PoSition
134 Dim iDU, iDL, i ' Integer DimensionUBound, Integer DimensionLBound
135 On Error Resume Next
136 iDL = LBound(aBD, iBC)
137 iDU = UBound(aBD, iBC)
138
139 Dim sPB1, sPB2 ' String PointBuffer1, String PointBuffer2
140 If Err = 9 Then
141 sPB1 = sPT & sPS
142 For i = 1 To Len(sPB1)
143 If i <> 1 Then sPB2 = sPB2 & ","
144 sPB2 = sPB2 & Mid(sPB1, i, 1)
145 Next
146 MultiArray = MultiArray & toJSON(Eval("aBD(" & sPB2 & ")"))
147 Else
148 sPT = sPT & sPS
149 MultiArray = MultiArray & "["
150 For i = iDL To iDU
151 MultiArray = MultiArray & MultiArray(aBD, iBC + 1, i, sPT)
152 If i < iDU Then MultiArray = MultiArray & ","
153 Next
154 MultiArray = MultiArray & "]"
155 sPT = Left(sPT, iBC - 2)
156 End If
157 End Function
158
159 Public Property Get jsString
160 jsString = toJSON(Me)
161 End Property
162
163 Sub Flush
164 If TypeName(Response) <> "Empty" Then
165 Response.Write(jsString)
166 ElseIf WScript <> Empty Then
167 WScript.Echo(jsString)
168 End If
169 End Sub
170
171 Public Function Clone
172 Set Clone = ColClone(Me)
173 End Function
174
175 Private Function ColClone(core)
176 Dim jsc, i
177 Set jsc = new jsCore
178 jsc.Kind = core.Kind
179 For Each i In core.Collection
180 If IsObject(core(i)) Then
181 Set jsc(i) = ColClone(core(i))
182 Else
183 jsc(i) = core(i)
184 End If
185 Next
186 Set ColClone = jsc
187 End Function
188
189End Class
190
191Function jsObject
192 Set jsObject = new jsCore
193 jsObject.Kind = JSON_OBJECT
194End Function
195
196Function jsArray
197 Set jsArray = new jsCore
198 jsArray.Kind = JSON_ARRAY
199End Function
200
201Function toJSON(val)
202 toJSON = (new jsCore).toJSON(val)
203End Function
'2
' VBS JSON 2.0.23
' Copyright (c) 2008 Turul Topuz4
' Under the MIT (MIT-LICENSE.txt) license.5
'6
7
Const JSON_OBJECT = 08
Const JSON_ARRAY = 19
10
Class jsCore11
Public Collection12
Public Count13
Public QuotedVars14
Public Kind ' 0 = object, 1 = array15
16
Private Sub Class_Initialize17
Set Collection = CreateObject("Scripting.Dictionary")18
QuotedVars = True19
Count = 020
End Sub21
22
Private Sub Class_Terminate23
Set Collection = Nothing24
End Sub25
26
' counter27
Private Property Get Counter 28
Counter = Count29
Count = Count + 130
End Property31
32
' - data maluplation33
' -- pair34
Public Property Let Pair(p, v)35
If IsNull(p) Then p = Counter36
Collection(p) = v37
End Property38
39
Public Property Set Pair(p, v)40
If IsNull(p) Then p = Counter41
If TypeName(v) <> "jsCore" Then42
Err.Raise &hD, "class: class", "Tr uyumsuz: '" & TypeName(v) & "'"43
End If44
Set Collection(p) = v45
End Property46
47
Public Default Property Get Pair(p)48
If IsNull(p) Then p = Count - 149
If IsObject(Collection(p)) Then50
Set Pair = Collection(p)51
Else52
Pair = Collection(p)53
End If54
End Property55
' -- pair56
Public Sub Clean57
Collection.RemoveAll58
End Sub59
60
Public Sub Remove(vProp)61
Collection.Remove vProp62
End Sub63
' data maluplation64
65
' encoding66
Function jsEncode(str)67
Dim i, j, aL1, aL2, c, p68
69
aL1 = Array(&h22, &h5C, &h2F, &h08, &h0C, &h0A, &h0D, &h09)70
aL2 = Array(&h22, &h5C, &h2F, &h62, &h66, &h6E, &h72, &h74)71
For i = 1 To Len(str)72
p = True73
c = Mid(str, i, 1)74
For j = 0 To 775
If c = Chr(aL1(j)) Then76
jsEncode = jsEncode & "\" & Chr(aL2(j))77
p = False78
Exit For79
End If80
Next81
82
If p Then 83
Dim a84
a = AscW(c)85
If a > 31 And a < 127 Then86
jsEncode = jsEncode & c87
ElseIf a > -1 Or a < 65535 Then88
jsEncode = jsEncode & "\u" & String(4 - Len(Hex(a)), "0") & Hex(a)89
End If 90
End If91
Next92
End Function93
94
' converting95
Public Function toJSON(vPair)96
Select Case VarType(vPair)97
Case 1 ' Null98
toJSON = "null"99
Case 7 ' Date100
' yaz saati problemi var101
' jsValue = "new Date(" & Round((vVal - #01/01/1970 02:00#) * 86400000) & ")"102
toJSON = """" & CStr(vPair) & """"103
Case 8 ' String104
toJSON = """" & jsEncode(vPair) & """"105
Case 9 ' Object106
Dim bFI,i 107
bFI = True108
If vPair.Kind Then toJSON = toJSON & "[" Else toJSON = toJSON & "{"109
For Each i In vPair.Collection110
If bFI Then bFI = False Else toJSON = toJSON & ","111
112
If vPair.Kind Then 113
toJSON = toJSON & toJSON(vPair(i))114
Else115
If QuotedVars Then116
toJSON = toJSON & """" & i & """:" & toJSON(vPair(i))117
Else118
toJSON = toJSON & i & ":" & toJSON(vPair(i))119
End If120
End If121
Next122
If vPair.Kind Then toJSON = toJSON & "]" Else toJSON = toJSON & "}"123
Case 11124
If vPair Then toJSON = "true" Else toJSON = "false"125
Case 12, 8192, 8204126
Dim sEB127
toJSON = MultiArray(vPair, 1, "", sEB)128
Case Else129
toJSON = Replace(vPair, ",", ".")130
End select131
End Function132
133
Function MultiArray(aBD, iBC, sPS, ByRef sPT) ' Array BoDy, Integer BaseCount, String PoSition134
Dim iDU, iDL, i ' Integer DimensionUBound, Integer DimensionLBound135
On Error Resume Next136
iDL = LBound(aBD, iBC)137
iDU = UBound(aBD, iBC)138
139
Dim sPB1, sPB2 ' String PointBuffer1, String PointBuffer2140
If Err = 9 Then141
sPB1 = sPT & sPS142
For i = 1 To Len(sPB1)143
If i <> 1 Then sPB2 = sPB2 & ","144
sPB2 = sPB2 & Mid(sPB1, i, 1)145
Next146
MultiArray = MultiArray & toJSON(Eval("aBD(" & sPB2 & ")"))147
Else148
sPT = sPT & sPS149
MultiArray = MultiArray & "["150
For i = iDL To iDU151
MultiArray = MultiArray & MultiArray(aBD, iBC + 1, i, sPT)152
If i < iDU Then MultiArray = MultiArray & ","153
Next154
MultiArray = MultiArray & "]"155
sPT = Left(sPT, iBC - 2)156
End If157
End Function158
159
Public Property Get jsString160
jsString = toJSON(Me)161
End Property162
163
Sub Flush164
If TypeName(Response) <> "Empty" Then 165
Response.Write(jsString)166
ElseIf WScript <> Empty Then 167
WScript.Echo(jsString)168
End If169
End Sub170
171
Public Function Clone172
Set Clone = ColClone(Me)173
End Function174
175
Private Function ColClone(core)176
Dim jsc, i177
Set jsc = new jsCore178
jsc.Kind = core.Kind179
For Each i In core.Collection180
If IsObject(core(i)) Then181
Set jsc(i) = ColClone(core(i))182
Else183
jsc(i) = core(i)184
End If185
Next186
Set ColClone = jsc187
End Function188
189
End Class190
191
Function jsObject192
Set jsObject = new jsCore193
jsObject.Kind = JSON_OBJECT194
End Function195
196
Function jsArray197
Set jsArray = new jsCore198
jsArray.Kind = JSON_ARRAY199
End Function200
201
Function toJSON(val)202
toJSON = (new jsCore).toJSON(val)203
End Function
补充：
Function QueryToJSON(dbc, sql)
Dim rs, jsa
Set rs = dbc.Execute(sql)
Set jsa = jsArray()
While Not (rs.EOF Or rs.BOF)
Set jsa(Null) = jsObject()
For Each col In rs.Fields
jsa(Null)(col.Name) = col.Value
Next
rs.MoveNext
Wend
Set QueryToJSON = jsa
End Function
浙公网安备 33010602011771号