<%
'
'	ASPJSON 2.11 - 2009-10-04
'
'	Copyright (c) 2008 Tuðrul Topuz
'	Copyright (c) 2009 Jean-Sebastien Carle
'	Under the MIT (MIT-LICENSE.txt) license.
'

Const JSON_OBJECT	= 0
Const JSON_ARRAY	= 1

Class jsCore
	Public Collection
	Public Count
	Public QuotedVars
	Public Kind ' 0 = object, 1 = array

	Private Sub Class_Initialize
		Set Collection = CreateObject("Scripting.Dictionary")
		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

	' - 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) <> "jsCore" Then
			Err.Raise &hD, "class: class", "Incompatible types: '" & 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
	Function jsEncode(str)
		Dim i, j, s, l, c, a, cv(127), js()
		cv(8)="\b": cv(9)="\t": cv(10)="\n": cv(12)="\f": cv(13)="\r": cv(34)="\""": cv(47)="\/": cv(92)="\\"
		j = 0: s = 1: l=0
		Redim js(len(str))
		For i = 1 To Len(str)
			c = Mid(str, i, 1)
			a = AscW(c)
			If a > 31 And a < 127  Then
				If IsEmpty(cv(a)) Then
					l = l + 1
				Else
					js(j) = Mid(str, s, l) & cv(a)
					l = 0: j = j + 1: s = i + 1
				End if
			Else
				js(j) = Mid(str, s, l) & "\u" & Right("000" & Hex(a),4)
				l = 0: j = j + 1: s = i + 1
			End If 
		Next
		js(j) = Mid(str, s, l)
		jsEncode = Join(js,"") 
	End Function

	' converting
	Public Function toJSON(vPair)
		Select Case VarType(vPair)
			Case 0	' Empty
				toJSON = ""
			Case 1	' Null
				toJSON = "null"
			Case 7	' Date
				' Summer Time Problem
				' 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
				toJSON = flattenArray(vPair, "", 1, arrayDimensions(vPair))
			Case Else
				toJSON = Replace(vPair, ",", ".")
		End select
	End Function

	Private Function arrayDimensions(ByVal fArray)
		Dim fDepth
		If IsArray(fArray) Then
			For fDepth = 1 To 32
				On Error Resume Next
				UBound fArray, fDepth
				If Err.Number <> 0 Then
					arrayDimensions = fDepth - 1
					Err.Clear
					On Error Goto 0
					Exit Function
				End If
				On Error Goto 0
			Next
			arrayDimensions = fDepth
		Else
			arrayDimensions = 0
		End If
	End Function
	
	Private Function flattenArray(ByVal fArray, ByVal fPosition, ByVal fIndex, ByVal fDepth)
		Dim fReturn, fElement, fCurrentPosition
		fReturn = ""
		For fElement = LBound(fArray, fIndex) To UBound(fArray, fIndex)
			If Len(fReturn) > 0 Then fReturn = fReturn & ","
			If Len(fPosition) > 0 Then
				fCurrentPosition = fPosition & "," & fElement
			Else
				fCurrentPosition = fElement
			End If
			If fIndex < fDepth Then
				fReturn = fReturn & flattenArray(fArray, fCurrentPosition, fIndex + 1, fDepth)
			Else
				fReturn = fReturn & toJSON(Eval("fArray(" & fCurrentPosition & ")"))
			End If
		Next
		flattenArray = "[" & fReturn & "]"
	End Function

	Public Property Get jsString
		jsString = toJSON(Me)
	End Property

	Sub Flush
		If TypeName(Response) <> "Empty" Then 
			Response.Write(jsString)
		ElseIf WScript <> Empty Then 
			WScript.Echo(jsString)
		End If
	End Sub

	Public Function Clone
		Set Clone = ColClone(Me)
	End Function

	Private Function ColClone(core)
		Dim jsc, i
		Set jsc = new jsCore
		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

End Class

Function jsObject
	Set jsObject = new jsCore
	jsObject.Kind = JSON_OBJECT
End Function

Function jsArray
	Set jsArray = new jsCore
	jsArray.Kind = JSON_ARRAY
End Function

Function toJSON(val)
	toJSON = (new jsCore).toJSON(val)
End Function
%>