现在抓取网页数据的时候,经常会遇到JSON的数据,相对于繁杂无标签名的HTML源,用JSON传回的数据比较直观好看点.
但是从其中提炼数据也让人觉得很烦躁,基本上就是不断的查找,截取,或者组装成JS代码执行返回值,很麻烦
写一个方便的JSON模块还是很有必要的
先把构思图保存下,明天有时间再写实现方法...
Public Function SubEDI_FMSQuotation(ByVal G_objService As AWSysBase.SysServer, ByVal strEDI As String, ByVal oResult As EDIResult, ByVal oEDIOpType As Tatium.AWSysPrevlige.SysEDIOpMTType) As Boolean
Try
Dim strErrorMsg As String = ""
Dim oJObject As Newtonsoft.Json.Linq.JObject = Newtonsoft.Json.JsonConvert.DeserializeObject(strEDI)
If oJObject Is Nothing Then
oResult.OK = False
oResult.ErrorMessage = "解析Json错误!"
Return False
End If
Dim strMyUserCode As String = ""
Dim strMyUserPwd As String = ""
Dim QuotationCode As String = ""Dim oToken As Newtonsoft.Json.Linq.JToken
oToken = oJObject(SubMakeInKeyWord("UserCode"))
If Not oToken Is Nothing Then
strMyUserCode = oToken.ToString()
End If
oToken = oJObject(SubMakeInKeyWord("UserPwd"))
If Not oToken Is Nothing Then
strMyUserPwd = oToken.ToString()
End If
oToken = oJObject(SubMakeInKeyWord("QuotationCode"))
If Not oToken Is Nothing Then
QuotationCode = oToken.ToString()
End If
Dim QuotationCodenum As Integer = QuotationCode.Length
Dim QuotationCod As String = ""
If QuotationCodenum = 11 Then
QuotationCod = "'" & QuotationCode & "'"
Else
Dim num As Integer = 0
While QuotationCodenum > 0 And num < 120
QuotationCod += "'" & QuotationCode.Substring(num, 11) & "'" & ","
num += 12
QuotationCodenum -= 12
End While
QuotationCod = QuotationCod.Substring(0, QuotationCod.Length - 1)
End If
If EDI_FMSCheckUser(strMyUserCode, strMyUserPwd) = False Then
oResult.OK = False
oResult.ErrorMessage = "不是合法ID,不能调用当前接口,请联系供应商确认相关问题!"
Return False
End If
'Dim strSQL As String = "select OfferUsedID from OfferUsed where UsedCode='" & QuotationCode & "'"'Dim oData As ADODB.Recordset = G_objService.DB_ExecSelectSQLTable(strSQL)
'Dim OfferUse As New AWFMSMain.OfferUsed
'OfferUse.SetService(G_objService)
'If OfferUse.LoadFromDB(G_objService.SB_MyTrim(oData.Fields("OfferUsedID").Value)) = False Then
' oResult.OK = False
' oResult.ErrorMessage = "未能查到相关数据!"
' Return False
'End If
Dim oStringBuilder As New System.Text.StringBuilder()
Dim oStringWriter As New System.IO.StringWriter(oStringBuilder)
'If OfferUse.LoadFromDB(G_objService.SB_MyTrim(oData.Fields("OfferUsedID").Value)) = True Then
Using oJsonWriter As New Newtonsoft.Json.JsonTextWriter(oStringWriter)
oJsonWriter.Formatting = Newtonsoft.Json.Formatting.None
'oJsonWriter.WriteStartArray()
oJsonWriter.WriteStartObject()
oJsonWriter.WritePropertyName("RetStatus")
oJsonWriter.WriteValue("1")
oJsonWriter.WritePropertyName("RetMsg")
oJsonWriter.WriteValue("成功!")
oJsonWriter.WritePropertyName("RetMsgCode")
oJsonWriter.WriteValue("")
oJsonWriter.WritePropertyName("RetOrderCode")
oJsonWriter.WriteValue("")
oJsonWriter.WritePropertyName("RetID")
oJsonWriter.WriteValue("")
oJsonWriter.WritePropertyName("RetData")
oJsonWriter.WriteStartObject()
oJsonWriter.WritePropertyName("Quotation")
oJsonWriter.WriteStartArray()Dim strSQL As String = "select * from OfferUsed where UsedCode in (" & QuotationCod & ")"
Dim OfferUse As ADODB.Recordset = G_objService.DB_ExecSelectSQL(strSQL)
If OfferUse.RecordCount >= 1 ThenWhile Not OfferUse.EOF
oJsonWriter.WriteStartObject()
oJsonWriter.WritePropertyName("QuotationCode")
oJsonWriter.WriteValue(G_objService.SB_MyTrim(OfferUse.Fields("UsedCode").Value))
oJsonWriter.WritePropertyName("Creator")
oJsonWriter.WriteValue(G_objService.SB_MyTrim(OfferUse.Fields("Creator").Value))
oJsonWriter.WritePropertyName("Create_Date")
oJsonWriter.WriteValue(G_objService.SB_MyTrim(OfferUse.Fields("CreateDate").Value))
oJsonWriter.WritePropertyName("Origin_Country")
oJsonWriter.WriteValue(G_objService.SB_MyTrim(OfferUse.Fields("LoadCountryNo").Value))
oJsonWriter.WritePropertyName("Origin_City")
oJsonWriter.WriteValue(G_objService.SB_MyTrim(OfferUse.Fields("UsedLoad").Value))
oJsonWriter.WritePropertyName("Destination_Country")
oJsonWriter.WriteValue(G_objService.SB_MyTrim(OfferUse.Fields("DestCountryNo").Value))
oJsonWriter.WritePropertyName("Destination_ZipCode")
oJsonWriter.WriteValue(G_objService.SB_MyTrim(OfferUse.Fields("DestZipCode").Value))
oJsonWriter.WritePropertyName("Container_Type")
oJsonWriter.WriteValue(G_objService.SB_MyTrim(OfferUse.Fields("ContainerTypeNo").Value))
oJsonWriter.WritePropertyName("Container_Number")
oJsonWriter.WriteValue(G_objService.SB_MyTrim(OfferUse.Fields("ContainerNum").Value))
oJsonWriter.WritePropertyName("Quantity")
oJsonWriter.WriteValue(G_objService.SB_MyTrim(OfferUse.Fields("FCLLCLFlag").Value))
oJsonWriter.WritePropertyName("Volumn")
oJsonWriter.WriteValue(G_objService.SB_MyTrim(OfferUse.Fields("Volumn").Value))
oJsonWriter.WritePropertyName("Weight")
oJsonWriter.WriteValue(G_objService.SB_MyTrim(OfferUse.Fields("Weight").Value))
oJsonWriter.WritePropertyName("Pallet")
oJsonWriter.WriteValue(G_objService.SB_MyTrim(OfferUse.Fields("Pallet").Value))
oJsonWriter.WritePropertyName("Agent_NameC")
oJsonWriter.WriteValue(G_objService.SB_MyTrim(OfferUse.Fields("CustomerName").Value))
Dim str1 As String = "select PortNameE as A from MTPort where PortNo='" & G_objService.SB_MyTrim(OfferUse.Fields("AgentNo").Value) & "'"Dim num As ADODB.Recordset = G_objService.DB_ExecSelectSQL(str1)
oJsonWriter.WritePropertyName("Agent_NameE")
If num.RecordCount >= 1 Then
oJsonWriter.WriteValue(G_objService.SB_MyTrim(num.Fields("A").Value))
Else
oJsonWriter.WriteValue("")
End IfoJsonWriter.WritePropertyName("Agent_Contact")
oJsonWriter.WriteValue(G_objService.SB_MyTrim(OfferUse.Fields("Contactor").Value))
oJsonWriter.WritePropertyName("Agent_Tel")
oJsonWriter.WriteValue(G_objService.SB_MyTrim(OfferUse.Fields("Phone").Value))
oJsonWriter.WritePropertyName("Agent_Email")
oJsonWriter.WriteValue(G_objService.SB_MyTrim(OfferUse.Fields("Mail").Value))
oJsonWriter.WritePropertyName("Agent_Address")
oJsonWriter.WriteValue(G_objService.SB_MyTrim(OfferUse.Fields("CustomerAddress").Value))
oJsonWriter.WritePropertyName("Freight_Amount")
str1 = "select SUM(Amount) as A from OfferUsedItem where OfferUsedID='" & G_objService.SB_MyTrim(OfferUse.Fields("OfferUsedID").Value) & "' and OfferSundryFlag=0"num = G_objService.DB_ExecSelectSQL(str1)
If num.RecordCount >= 1 Then
oJsonWriter.WriteValue(G_objService.SB_MyTrim(num.Fields("A").Value))
Else
oJsonWriter.WriteValue("")
End If
oJsonWriter.WritePropertyName("Incidental_Amount")
str1 = "select SUM(Amount) as A from OfferUsedItem where OfferUsedID='" & G_objService.SB_MyTrim(OfferUse.Fields("OfferUsedID").Value) & "' and OfferSundryFlag=1"
num = G_objService.DB_ExecSelectSQL(str1)
If num.RecordCount >= 1 Then
oJsonWriter.WriteValue(G_objService.SB_MyTrim(num.Fields("A").Value))
Else
oJsonWriter.WriteValue("")
End If
oJsonWriter.WritePropertyName("Total_Amount")
str1 = "select SUM(Amount) as A from OfferUsedItem where OfferUsedID='" & G_objService.SB_MyTrim(OfferUse.Fields("OfferUsedID").Value) & "'"
num = G_objService.DB_ExecSelectSQL(str1)
If num.RecordCount >= 1 Then
oJsonWriter.WriteValue(G_objService.SB_MyTrim(num.Fields("A").Value))
Else
oJsonWriter.WriteValue("")
End If
oJsonWriter.WritePropertyName("Amount_Remark")
oJsonWriter.WriteValue("此报价中不包含税金、代收代付等相关实报实销费用。")
oJsonWriter.WritePropertyName("Transport")
oJsonWriter.WriteStartArray()
Dim strSQLm As String = "select * from OfferMain where OfferMainID in (" & G_objService.SB_MyTrim(OfferUse.Fields("OfferOneID").Value) & "," & G_objService.SB_MyTrim(OfferUse.Fields("OfferTwoID").Value) & "," & G_objService.SB_MyTrim(OfferUse.Fields("OfferThreeID").Value) & ")"Dim OfferMai As ADODB.Recordset = G_objService.DB_ExecSelectSQL(strSQLm)
If OfferMai.RecordCount >= 1 ThenWhile Not OfferMai.EOF
oJsonWriter.WriteStartObject()
oJsonWriter.WritePropertyName("POL_Country")
oJsonWriter.WriteValue(G_objService.SB_MyTrim(OfferMai.Fields("LoadCountyNo").Value))
oJsonWriter.WritePropertyName("POL")
str1 = "select PortNameE as A from MTPort where PortNo='" & G_objService.SB_MyTrim(OfferMai.Fields("LoadPortNo").Value) & "'"
num = G_objService.DB_ExecSelectSQL(str1)
If num.RecordCount >= 1 Then
oJsonWriter.WriteValue(G_objService.SB_MyTrim(num.Fields("A").Value))
Else
oJsonWriter.WriteValue("")
End If
oJsonWriter.WritePropertyName("POD_Country")
oJsonWriter.WriteValue(G_objService.SB_MyTrim(OfferMai.Fields("DestCountyNo").Value))
oJsonWriter.WritePropertyName("POD")
str1 = "select PortNameE as A from MTPort where PortNo='" & G_objService.SB_MyTrim(OfferMai.Fields("DestinationPortNo").Value) & "'"
num = G_objService.DB_ExecSelectSQL(str1)
If num.RecordCount >= 1 Then
oJsonWriter.WriteValue(G_objService.SB_MyTrim(num.Fields("A").Value))
Else
oJsonWriter.WriteValue("")
End If
oJsonWriter.WritePropertyName("Carrier")
oJsonWriter.WriteValue(G_objService.SB_MyTrim(OfferMai.Fields("CarrierNo").Value))
oJsonWriter.WritePropertyName("Mode_Of_Transport")
oJsonWriter.WriteValue(G_objService.SB_MyTrim(OfferMai.Fields("TransitPortNo").Value))
oJsonWriter.WritePropertyName("Valid_Date")
oJsonWriter.WriteValue(G_objService.SB_MyTrim(OfferMai.Fields("ValidOverDate").Value))
oJsonWriter.WritePropertyName("Note")
oJsonWriter.WriteValue(G_objService.SB_MyTrim(OfferMai.Fields("Note").Value))
oJsonWriter.WritePropertyName("FeeList")
oJsonWriter.WriteStartArray()
Dim strSQLit As String = "select (Amount*Rate) as A,*from OfferUsedItem where OfferUsedID='" & G_objService.SB_MyTrim(OfferUse.Fields("OfferUsedID").Value) & "'"Dim ooData As ADODB.Recordset = G_objService.DB_ExecSelectSQL(strSQLit)
If ooData.RecordCount >= 1 ThenWhile Not ooData.EOF
oJsonWriter.WriteStartObject()
oJsonWriter.WritePropertyName("Fee_Name")
oJsonWriter.WriteValue(G_objService.SB_MyTrim(ooData.Fields("FeeTypeNo").Value))
oJsonWriter.WritePropertyName("Fee_Type")
oJsonWriter.WriteValue(G_objService.SB_MyTrim(ooData.Fields("TransType").Value))
oJsonWriter.WritePropertyName("Currency")
oJsonWriter.WriteValue(G_objService.SB_MyTrim(ooData.Fields("CurrencyType").Value))
oJsonWriter.WritePropertyName("Price")
oJsonWriter.WriteValue(G_objService.SB_MyTrim(ooData.Fields("Price").Value))
oJsonWriter.WritePropertyName("Unit_Type")
oJsonWriter.WriteValue(G_objService.SB_MyTrim(ooData.Fields("UnitType").Value))
oJsonWriter.WritePropertyName("Unit")
oJsonWriter.WriteValue(G_objService.SB_MyTrim(ooData.Fields("Unit").Value))
oJsonWriter.WritePropertyName("Amount")
oJsonWriter.WriteValue(G_objService.SB_MyTrim(ooData.Fields("Amount").Value))
oJsonWriter.WritePropertyName("Exchange_Rate")
oJsonWriter.WriteValue(G_objService.SB_MyTrim(ooData.Fields("Rate").Value))
oJsonWriter.WritePropertyName("Amount_USD")
oJsonWriter.WriteValue(G_objService.SB_MyTrim(ooData.Fields("A").Value))
oJsonWriter.WriteEndObject()
ooData.MoveNext()
End While
End If
oJsonWriter.WriteEndArray()
oJsonWriter.WriteEndObject()
OfferMai.MoveNext()
End While
End If
oJsonWriter.WriteEndArray()
oJsonWriter.WriteEndObject()
OfferUse.MoveNext()
End While
End If
oJsonWriter.WriteEndArray()
oJsonWriter.WriteEndObject()
oJsonWriter.WriteEndObject()
End UsingoResult.OK = True
oResult.DataContent = oStringBuilder.ToString()Dim oSendResult As New EDIResult
'不需要发送给客户,该接口为客户自己调
'Dim bRet As Boolean = SubHTTPPostData(G_objService, oEDIOpType.MTSendURL, oEDIOpType.MTSendParaOther, oEDIOpType.MTSendParaData, strRet, oSendResult)Dim oEDILog As New Tatium.AWSysPrevlige.SysEDIOpMain
oEDILog.SetService(G_objService)oEDILog.MakeEDIResult(oEDIOpType.EDIOpTypeIdx, True, 1, "生成数据成功!", -1, -1, oResult.MainKey, oStringBuilder.ToString(), "", "URL:" & oEDIOpType.MTSendURL)
Return True
Catch ex As Exception
G_objService.Sys_WriteDebug("FMS.GetQuotation", ex.Message)
oResult.OK = False
oResult.ErrorMessage = ex.Message
Return False
End TryEnd Function
VB NET JSON解析
这几天在做MQTT消息订阅的应用,消息公司采用JSON数据格式,于是意识兴起,自己写了一个JSON解析类,代码大部分参考JAVA的JSON解析类完成,类的命名都与JAVA的解析类完全已有,里面的方法也几乎一样,仅有少量差异。可能在一些转义符上会有点问题,这个我没有完整验证,如果右问题修改一下转义符的地方就可以了,其它都做过验证了,应该没啥大问题。完整代码如下:
JSON 类,与JAVA的JSON基本一样
Public Class JSON ''' <summary> ''' 如果输入是JSON允许的值,则返回该输入;否则抛出。 ''' </summary> ''' <param name="d"></param> ''' <returns></returns> ''' <remarks></remarks> Public Shared Function checkDouble(ByVal d As Double) As Double If Double.IsInfinity(d) Or Double.IsNaN(d) Then Throw New Exception("Forbidden numeric value: " + d) End If Return d End Function ''' <summary> ''' 转为布尔型数据 ''' </summary> ''' <param name="value"></param> ''' <returns></returns> ''' <remarks></remarks> Public Shared Function toBoolean(ByVal value As Object) As Boolean If value.GetType.Equals(GetType(Boolean)) Then Return value ElseIf value.GetType.Equals(GetType(String)) Then Dim stringValue As String = value If stringValue.ToLower.Equals("true") Or stringValue.ToLower.Equals("yes") Or stringValue.ToLower.Equals("on") Then Return True ElseIf stringValue.ToLower.Equals("false") Or stringValue.ToLower.Equals("no") Or stringValue.ToLower.Equals("off") Then Return False End If ElseIf IsNumeric(value.GetType) Then Return IIf(value <> 0, True, False) End If Return Nothing End Function ''' <summary> ''' 转为双精度数字 ''' </summary> ''' <param name="value"></param> ''' <returns></returns> ''' <remarks></remarks> Public Shared Function toDouble(ByVal value As Object) As Double If value.GetType.Equals(GetType(Double)) Then Return value ElseIf IsNumeric(value.GetType) Then Return CDbl(value) ElseIf value.GetType.Equals(GetType(String)) Then Return Double.Parse(value) Else Return Nothing End If End Function ''' <summary> ''' 转为单精度数字 ''' </summary> ''' <param name="value"></param> ''' <returns></returns> ''' <remarks></remarks> Public Shared Function toSingle(ByVal value As Object) As Single If value.GetType.Equals(GetType(Single)) Then Return value ElseIf IsNumeric(value.GetType) Then Return CSng(value) ElseIf value.GetType.Equals(GetType(String)) Then Return Double.Parse(value) Else Return Nothing End If End Function ''' <summary> ''' 转为短整型数字 ''' </summary> ''' <param name="value"></param> ''' <returns></returns> ''' <remarks></remarks> Public Shared Function toShort(ByVal value As Object) As Short If value.GetType.Equals(GetType(Short)) Then Return value ElseIf IsNumeric(value.GetType) Then Return CShort(value) ElseIf value.GetType.Equals(GetType(String)) Then Return Short.Parse(value) Else Return Nothing End If End Function ''' <summary> ''' 转为无符号短整型数字 ''' </summary> ''' <param name="value"></param> ''' <returns></returns> ''' <remarks></remarks> Public Shared Function toUShort(ByVal value As Object) As UShort If value.GetType.Equals(GetType(UShort)) Then Return value ElseIf IsNumeric(value.GetType) Then Return CUShort(value) ElseIf value.GetType.Equals(GetType(String)) Then Return UShort.Parse(value) Else Return Nothing End If End Function ''' <summary> ''' 转为整型数字 ''' </summary> ''' <param name="value"></param> ''' <returns></returns> ''' <remarks></remarks> Public Shared Function toInteger(ByVal value As Object) As Integer If value.GetType.Equals(GetType(Integer)) Then Return value ElseIf IsNumeric(value.GetType) Then Return CInt(value) ElseIf value.GetType.Equals(GetType(String)) Then Return Integer.Parse(value) Else Return Nothing End If End Function ''' <summary> ''' 转为无符号整型数字 ''' </summary> ''' <param name="value"></param> ''' <returns></returns> ''' <remarks></remarks> Public Shared Function toUInteger(ByVal value As Object) As UInteger If value.GetType.Equals(GetType(UInteger)) Then Return value ElseIf IsNumeric(value.GetType) Then Return CUInt(value) ElseIf value.GetType.Equals(GetType(String)) Then Return UInteger.Parse(value) Else Return Nothing End If End Function ''' <summary> ''' 转为长整型数字 ''' </summary> ''' <param name="value"></param> ''' <returns></returns> ''' <remarks></remarks> Public Shared Function toLong(ByVal value As Object) As Long If value.GetType.Equals(GetType(Long)) Then Return value ElseIf IsNumeric(value.GetType) Then Return CLng(value) ElseIf value.GetType.Equals(GetType(String)) Then Return Long.Parse(value) Else Return Nothing End If End Function ''' <summary> ''' 转为无符号长整型数字 ''' </summary> ''' <param name="value"></param> ''' <returns></returns> ''' <remarks></remarks> Public Shared Function toULong(ByVal value As Object) As ULong If value.GetType.Equals(GetType(ULong)) Then Return value ElseIf IsNumeric(value.GetType) Then Return CULng(value) ElseIf value.GetType.Equals(GetType(String)) Then Return ULong.Parse(value) Else Return Nothing End If End Function ''' <summary> ''' 转为字节型数字 ''' </summary> ''' <param name="value"></param> ''' <returns></returns> ''' <remarks></remarks> Public Shared Function toByte(ByVal value As Object) As Byte If value.GetType.Equals(GetType(Byte)) Then Return value ElseIf IsNumeric(value.GetType) Then Return CByte(value) ElseIf value.GetType.Equals(GetType(String)) Then Return Byte.Parse(value) Else Return Nothing End If End Function ''' <summary> ''' 转为无符号字节型数字 ''' </summary> ''' <param name="value"></param> ''' <returns></returns> ''' <remarks></remarks> Public Shared Function toSByte(ByVal value As Object) As SByte If value.GetType.Equals(GetType(SByte)) Then Return value ElseIf IsNumeric(value.GetType) Then Return CSByte(value) ElseIf value.GetType.Equals(GetType(String)) Then Return SByte.Parse(value) Else Return Nothing End If End Function ''' <summary> ''' 转为字符型 ''' </summary> ''' <param name="value"></param> ''' <returns></returns> ''' <remarks></remarks> Public Shared Function toChar(ByVal value As Object) As Char If value.GetType.Equals(GetType(SByte)) Then Return value ElseIf IsNumeric(value.GetType) Then Return CChar(value) ElseIf value.GetType.Equals(GetType(String)) Then Return Char.Parse(value) Else Return Nothing End If End Function ''' <summary> ''' 转为字符串 ''' </summary> ''' <param name="value"></param> ''' <returns></returns> ''' <remarks></remarks> Public Overloads Shared Function toString(ByVal value As Object) As String If value.GetType.Equals(GetType(String)) Then Return value ElseIf Not IsNothing(value) Then Return value.ToString() Else Return Nothing End If End Function Public Shared Function typeMismatch(ByVal indexOrName As Object, ByVal actual As Object, ByVal requiredType As String) As Exception If IsNumeric(actual) Then Throw New Exception("Value at " + indexOrName + " is null.") Else Throw New Exception("Value " + actual + " at " + indexOrName + " of type " + actual.getClass().getName() + " cannot be converted to " + requiredType) End If End Function Public Shared Function typeMismatch(ByVal actual As Object, ByVal requiredType As String) As Exception If IsNumeric(actual) Then Throw New Exception("Value is null.") Else Throw New Exception("Value " + actual + " of type " + actual.getClass().getName() + " cannot be converted to " + requiredType) End If End Function ''' <summary> ''' 类型是数字类型 ''' </summary> ''' <param name="dataType">类型</param> ''' <returns></returns> ''' <remarks></remarks> Private Shared Function IsNumeric(ByVal dataType As Type) As Boolean If Microsoft.VisualBasic.IsNothing(dataType) Then Return False Else Return dataType.Equals(GetType(Byte)) Or dataType.Equals(GetType(SByte)) Or dataType.Equals(GetType(Char)) Or _ dataType.Equals(GetType(Short)) Or dataType.Equals(GetType(UShort)) Or dataType.Equals(GetType(Integer)) Or _ dataType.Equals(GetType(UInteger)) Or dataType.Equals(GetType(Long)) Or dataType.Equals(GetType(ULong)) Or _ dataType.Equals(GetType(Single)) Or dataType.Equals(GetType(Double)) Or dataType.Equals(GetType(Int16)) Or _ dataType.Equals(GetType(Int32)) Or dataType.Equals(GetType(Int64)) Or dataType.Equals(GetType(UInt16)) Or _ dataType.Equals(GetType(UInt32)) Or dataType.Equals(GetType(UInt64)) Or dataType.Equals(GetType(UIntPtr)) End If End Function End Class
JSONTokener类。与JAVA的JSONTokener一致。主要是用于将json字符串解析为JSONObject或JSONArray类数据
Imports System.Text Public Class JSONTokener ''' <summary>输入JSON </summary> Private input As String ''' <summary>返回的下一个字符的索引。当输入用尽时,这等于输入的长度。</summary> Private pos As Integer ''' <summary> ''' 构造函数 ''' </summary> ''' <param name="json">JSON编码字符串。不允许Null,它将产生一个令牌,在调用方法时抛出<code>Exceptions</code>。</param> ''' <remarks></remarks> Public Sub New(ByVal json As String) If Not IsNothing(json) Then '如果存在,则使用可选的字节顺序标记(BOM)。 If json.StartsWith((Chr(254) + Chr(255))) Then '"\ufeff" json = json.Substring(1) End If End If Me.input = json End Sub ''' <summary> ''' 返回输入的下一个值。 ''' </summary> ''' <returns> ''' <code>JSONObject</code>、<code>JSONArray</code>、String、Boolean、Integer、Long、Double或<code>JSONObject.NULL</code>。 ''' </returns> ''' <remarks></remarks> ''' <exception cref="Exception"></exception> Public Function NextValue() As Object Dim c As Integer = NextCleanInternal() Select Case c Case -1 Throw syntaxError("End of input") Case Asc("{") Return ReadObject() Case Asc("[") Return ReadArray() Case Asc("'"), Asc("""") Return NextString(Chr(c)) Case Else pos -= 1 Return ReadLiteral() End Select End Function Private Function NextCleanInternal() As Integer While pos < input.Length Dim c As Char = input.Chars(pos) pos += 1 Select Case c Case vbTab, " ", vbLf, vbCr Continue While Case "/" If pos = input.Length Then Return Asc(c) End If Dim peek As Char = input.Chars(pos) Select Case peek Case "*" '跳过/*C样式的注释*/ pos += 1 Dim commentEnd As Integer = input.IndexOf("*/", pos) If commentEnd = -1 Then Throw syntaxError("Unterminated comment") End If pos = commentEnd + 2 Continue While Case "/" pos += 1 SkipToEndOfLine() Continue While Case Else Return Asc(c) End Select Case "#" '跳过#散列行尾注释。JSON RFC没有指定这种行为,但是需要解析现有文档。参见:http://b/2571423。 SkipToEndOfLine() Continue While Case Else Return Asc(c) End Select End While Return -1 End Function ''' <summary> ''' 将位置前进到下一个换行符之后。如果该行以"\r\n"结尾,则调用者必须将"\n"用作空白。 ''' </summary> ''' <remarks></remarks> Private Sub SkipToEndOfLine() Do While pos < input.Length Dim c As Char = input.Chars(pos) If c = vbCr Or c = vbLf Then pos += 1 Exit Do End If pos += 1 Loop End Sub ''' <summary> ''' 返回到但不包括<code>quote</code>的字符串,不跳过沿途遇到的任何字符转义序列。开场白应该已经读过了。这将使用结束引号,但不会将其包含在返回的字符串中。 ''' </summary> ''' <param name="quote">'或"</param> ''' <returns></returns> ''' <remarks></remarks> Private Function NextString(ByVal quote As Char) As String '对于没有转义序列的字符串,我们可以将结果提取为输入的子字符串。但如果遇到转义序列,则需要使用StringBuilder来合成结果。 Dim builder As StringBuilder = Nothing '尚未附加到生成器的第一个字符的索引 Dim start As Integer = pos While pos < input.Length Dim c As Char = input.Chars(pos) pos += 1 If c = quote Then If IsNothing(builder) Then '新字符串避免内存泄漏 Return New String(input.Substring(start, (pos - 1) - start)) Else builder.Append(input, start, pos - 1) Return builder.ToString() End If End If If c = "\" Then If pos = input.Length Then Throw syntaxError("Unterminated escape sequence") End If If IsNothing(builder) Then builder = New StringBuilder() End If builder.Append(input, start, pos - 1) builder.Append(ReadEscapeCharacter()) start = pos End If End While Throw syntaxError("Unterminated string") End Function ''' <summary> ''' 取消由紧跟在反斜杠后面的一个或多个字符标识的字符。应该已经读取了反斜杠“\”。这支持unicode转义“u000A”和两个字符转义“\n”。 ''' </summary> ''' <returns></returns> ''' <remarks></remarks> Private Function ReadEscapeCharacter() As Char Dim escaped As Char = input.Chars(pos) pos += 1 Select Case escaped Case "u" If pos + 4 > input.Length Then Throw syntaxError("Unterminated escape sequence") End If Dim hex As String = input.Substring(pos, 4) pos += 4 Try Return Chr(Integer.Parse(hex, 16)) Catch ex As Exception Throw syntaxError("Invalid escape sequence: " + hex) End Try Case "t" Return vbTab Case "b" Return vbBack Case "n" Return vbLf Case "r" Return vbCr Case "f" Return vbFormFeed Case "'", """", "\" Return escaped Case Else Return escaped End Select End Function ''' <summary> ''' 读取空值、布尔值、数值或无引号的字符串文本值。数值将以整数、Long或Double的形式按优先顺序返回。 ''' </summary> ''' <returns></returns> ''' <remarks></remarks> Private Function ReadLiteral() As Object Dim literal As String = NextToInternal("{}[]/\:,=;# tf") If literal.Length = 0 Then Throw syntaxError("Expected literal value") ElseIf literal.ToLower = "null" Then Return "null" ElseIf literal.ToLower = "true" Then Return "true" ElseIf literal.ToLower = "false" Then Return "false" End If '尝试作为整型进行分析 If literal.IndexOf(".") = -1 Then Dim base As Integer = 10 Dim number As String = literal If (number.StartsWith("0x") Or number.StartsWith("0X")) Then number = number.Substring(2) base = 16 ElseIf (number.StartsWith("0") And number.Length() > 1) Then number = number.Substring(1) base = 8 End If Try Dim longValue As Long = Long.Parse(number, base) If longValue <= Integer.MaxValue And longValue >= Integer.MinValue Then Return CInt(longValue) Else Return longValue End If Catch ex As Exception '这只发生在大于长最大值,指数形式的数字(5e-10)和不带引号的字符串。尝试浮点运算。 End Try End If Try Return Double.Parse(literal) Catch ex As Exception End Try '最后放弃。我们有一个未引号的字符串 Return New String(literal) '新字符串可避免内存泄漏 End Function ''' <summary> ''' 返回字符串,但不包括给定字符或换行符中的任何字符。这不会消耗被排除的字符。 ''' </summary> ''' <param name="excluded"></param> ''' <returns></returns> ''' <remarks></remarks> Private Function NextToInternal(excluded As String) As String Dim start As Integer = pos Do While pos < input.Length Dim c As Char = input.Chars(pos) If c = vbCr Or c = vbLf Or excluded.IndexOf(c) <> -1 Then 'Substring(start, pos)修改为下面。因为在net中Substring(开始,长度),java中Substring(开始,结束),所以这里应该是用结束位置-开始位置 Return input.Substring(start, pos - start) End If pos += 1 Loop Return input.Substring(start) End Function ''' <summary> ''' 读取对象的键/值对序列和尾随右大括号'}'。应该已经读取了左大括号“{”。 ''' </summary> ''' <returns></returns> ''' <remarks></remarks> Private Function ReadObject() As JSONObject Dim result As JSONObject = New JSONObject() Dim first As Integer = NextCleanInternal() If Chr(first) = "}" Then Return result ElseIf first <> -1 Then pos -= 1 End If While True Dim name As Object = NextValue() If Not name.GetType.Equals(GetType(String)) Then If IsNothing(name) Then Throw syntaxError("Names cannot be null") Else Throw syntaxError("Names must be strings, but " + name.ToString + " is of type " + name.GetType.Name) End If End If Dim separator As Integer = NextCleanInternal() If Chr(separator) <> ":" And Chr(separator) <> "=" Then Throw syntaxError("Expected ':' after " + name) End If If pos < input.Length Then If input.Chars(pos) = ">" Then pos += 1 End If End If result.put(name, NextValue()) Dim ci As Integer = NextCleanInternal() Select Case ci Case Asc("}") Return result Case Asc(";"), Asc(",") Continue While Case Else Throw syntaxError("Unterminated object") End Select End While Return result End Function ''' <summary> ''' 读取数组的值序列和尾随右大括号']'。应该已经读取了左大括号“[”。注意,“[]”产生一个空数组,但是“[,]”返回一个与“[null,null]”等价的两元素数组。 ''' </summary> ''' <returns></returns> ''' <remarks></remarks> Private Function ReadArray() As Object Dim result As JSONArray = New JSONArray() Dim hasTrailingSeparator As Boolean = False While True Dim ci As Integer = NextCleanInternal() Select Case ci Case -1 Throw syntaxError("Unterminated array") Case Asc("]") If hasTrailingSeparator Then Dim obj As Object = Nothing result.put(obj) End If Return result Case Asc(","), Asc(";") '没有值的分隔符首先表示“null”。 Dim obj As Object = Nothing result.put(obj) hasTrailingSeparator = True Continue While Case Else pos -= 1 End Select result.put(NextValue()) ci = NextCleanInternal() Select Case ci Case Asc("]") Return result Case Asc(","), Asc(";") hasTrailingSeparator = True Continue While Case Else Throw syntaxError("Unterminated array") End Select End While Return result End Function Private Function syntaxError(ByVal message As String) As Exception Return New Exception(message + Me.GetType.Name) End Function ''' <summary> ''' 返回当前位置和整个输入字符串。 ''' </summary> ''' <returns></returns> ''' <remarks></remarks> Public Overrides Function toString() As String Return " at character " + pos + " of " + input End Function ''' <summary> ''' 返回true,直到输入用尽为止。 ''' </summary> ''' <returns></returns> ''' <remarks></remarks> Public Function more() As Boolean Return pos < input.Length() End Function ''' <summary> ''' 返回下一个可用字符,如果已用尽所有输入,则返回空字符“\0”。对于包含字符“\0”的JSON字符串,此方法的返回值不明确。 ''' </summary> ''' <returns></returns> ''' <remarks></remarks> Public Function nextChar() As Char Dim result As Char = IIf(pos < input.Length(), input.Chars(pos), Chr(0)) pos += 1 Return result End Function ''' <summary> ''' 如果下一个可用字符等于<code>c</code>,则返回该字符。否则会引发异常。 ''' </summary> ''' <param name="c"></param> ''' <returns></returns> ''' <remarks></remarks> Public Function nextChar(ByVal c As Char) As Char Dim result As Char = nextChar() If result <> c Then Throw syntaxError("Expected " + c + " but was " + result) End If Return result End Function ''' <summary> ''' 返回下一个非空白且不属于注释的字符。如果在找到这样一个字符之前输入已用尽,则返回空字符'\0'。对于包含字符“\0”的JSON字符串,此方法的返回值不明确。 ''' </summary> ''' <returns></returns> ''' <remarks></remarks> Public Function nextClean() As Char Dim nextCleanInt As Integer = NextCleanInternal() Return IIf(nextCleanInt = -1, Chr(0), Chr(nextCleanInt)) End Function ''' <summary> ''' 返回输入的下一个{@code length}字符。 ''' 返回的字符串与此标记器的输入字符串共享其支持字符数组。 ''' 如果对返回字符串的引用可能被无限保留,那么应该首先使用{@code new string(result)}复制它, ''' 以避免内存泄漏。 ''' </summary> ''' <param name="length"></param> ''' <returns></returns> ''' <remarks></remarks> Public Function nextString(ByVal length As Integer) As String If pos + length > input.Length Then Throw syntaxError(length + " is out of bounds") End If Dim result As String = input.Substring(pos, length) pos += length Return result End Function ''' <summary> ''' 返回{@link String#trim trimmed}字符串,其中包含最多但不包括以下第一个字符: ''' {@code excluded}中的任何字符 ''' 换行符“\n” ''' 回车“\r” ''' 返回的字符串与此标记器的输入字符串共享其支持字符数组。 ''' 如果对返回字符串的引用可能被无限期保留,那么应该首先 ''' 使用{@code new string(result)}复制它,以避免内存泄漏。 ''' </summary> ''' <param name="excluded"></param> ''' <returns></returns> ''' <remarks></remarks> Public Function nextStringTo(ByVal excluded As String) As String If excluded Is Nothing Then Throw New Exception("excluded == null") End If Return NextToInternal(excluded).Trim() End Function ''' <summary> ''' 相当于{@code nextStringTo(String.valueOf值(不包括在内)。 ''' </summary> ''' <param name="excluded"></param> ''' <returns></returns> ''' <remarks></remarks> Public Function nextCharTo(ByVal excluded As Char) As String Return NextToInternal(excluded) End Function ''' <summary> ''' 将所有输入向前推进,直到并包括下一次出现的{@code thru}。如果剩余的输入不包含{@code thru},则输入将用尽。 ''' </summary> ''' <param name="thru"></param> ''' <remarks></remarks> Public Sub skipPast(ByVal thru As String) Dim thruStart As Integer = input.IndexOf(thru, pos) pos = IIf(thruStart = -1, input.Length(), (thruStart + thru.Length())) End Sub ''' <summary> ''' 超过所有输入,但不包括下一次出现的{@code to}。如果剩余的输入不包含{@code to},则输入不变。 ''' </summary> ''' <param name="charto"></param> ''' <returns></returns> ''' <remarks></remarks> Public Function skipTo(ByVal charto As Char) As Char Dim index As Integer = input.IndexOf(charto, pos) If index <> -1 Then pos = index Return charto Else Return Chr(Asc(0)) End If End Function ''' <summary> ''' 未读输入的最新字符。如果没有读取输入字符,则输入不变。 ''' </summary> ''' <remarks></remarks> Public Sub back() pos -= 1 If (pos = -1) Then pos = 0 End If End Sub ''' <summary> ''' 对于给定的十六进制字符,返回整数[0..15]值;对于非十六进制输入,返回-1。 ''' </summary> ''' <param name="hex">在[0-9]、[a-F]或[a-f]范围内的字符。任何其他字符将产生-1结果。</param> ''' <returns></returns> ''' <remarks></remarks> Public Shared Function dehexchar(ByVal hex As Char) As Integer ' Dim zero As Char = "0" Dim intHex As Integer = Asc(hex) If intHex >= Asc("0") And intHex <= Asc("0") Then Return Asc(hex) - Asc("0") ElseIf intHex >= Asc("A") And intHex <= Asc("F") Then Return Asc(hex) - Asc("A") + 10 ElseIf intHex >= Asc("a") And intHex <= Asc("f") Then Return Asc(hex) - Asc("a") + 10 Else Return -1 End If End Function End Class
JSONStringer类。与javaJSONStringer类相同,主要是将JSONObject解析为json字符串。
Imports System.Text Public Class JSONStringer ''' <summary> ''' 输出数据,最多包含一个顶级数组或对象。 ''' </summary> ''' <remarks></remarks> Friend out As StringBuilder = New StringBuilder() ''' <summary>左方括号</summary> Private Const BRACKETS_CURLY_LEFT = "{" ''' <summary>右方括号</summary> Private Const BRACKETS_CURLY_RIGHT = "}" ''' <summary>左方括号</summary> Private Const BRACKETS_SQUARE_LEFT = "[" ''' <summary>右方括号</summary> Private Const BRACKETS_SQUARE_RIGHT = "]" ''' <summary>双引号</summary> Private Const DOUNLE_QUOTATION_MARK = """" ''' <summary>逗号</summary> Private Const COMMA = "," ''' <summary>冒号</summary> Private Const COLON = ":" ''' <summary>冒号和空格</summary> Private Const COLON_AND_SPACE = ": " ''' <summary>空格</summary> Private Const SPACE = " " ''' <summary> ''' 范围 ''' </summary> ''' <remarks></remarks> Enum Scope ''' <summary>没有元素的数组在关闭之前不需要分隔符或换行符。</summary> EMPTY_ARRAY = 0 ''' <summary>至少有一个值的数组需要在下一个元素前加逗号和换行符。</summary> NONEMPTY_ARRAY = 1 ''' <summary>没有键或值的对象在关闭前不需要分隔符或换行符。</summary> EMPTY_OBJECT = 2 ''' <summary>其最新元素是键的对象。下一个元素必须是值。</summary> DANGLING_KEY = 3 ''' <summary>至少有一个名称/值对的对象在下一个元素之前需要逗号和换行符。</summary> NONEMPTY_OBJECT = 4 ''' <summary>一种特殊的无支架数组JSONStringer.join连接()和JSONObject.quote文件()仅限。不用于JSON编码。</summary> NULL = 5 End Enum ''' <summary> ''' 与最初的实现不同,这个堆栈不限于20层嵌套。 ''' </summary> ''' <remarks></remarks> Dim stack As List(Of Scope) = New List(Of Scope) ''' <summary> ''' 一个字符串,包含一个完整的空格集,用于一个缩进级别,如果没有漂亮的打印,则为nothing。 ''' </summary> ''' <remarks></remarks> Dim indent As String Public Sub New() indent = Nothing End Sub Public Sub New(ByVal indentSpaces As Integer) Dim indentChars(indentSpaces) As Char For i = 0 To indentChars.Count - 1 indentChars(i) = SPACE Next indent = New String(indentChars) End Sub ''' <summary> ''' 开始编码新数组。对该方法的每个调用必须与对<code>endArray</code>的调用配对。 ''' </summary> ''' <returns></returns> ''' <remarks></remarks> Public Function startArray() As JSONStringer Return open(Scope.EMPTY_ARRAY, BRACKETS_SQUARE_LEFT) End Function ''' <summary> ''' 结束对当前数组的编码。 ''' </summary> ''' <returns></returns> ''' <remarks></remarks> Public Function endArray() As JSONStringer Return close(Scope.EMPTY_ARRAY, Scope.NONEMPTY_ARRAY, BRACKETS_SQUARE_RIGHT) End Function ''' <summary> ''' 开始编码新对象。对该方法的每个调用必须与对<code>endObject</code>的调用配对。 ''' </summary> ''' <returns></returns> ''' <remarks></remarks> Public Function startObject() As JSONStringer Return open(Scope.EMPTY_OBJECT, BRACKETS_CURLY_LEFT) End Function ''' <summary> ''' 结束对当前对象的编码。 ''' </summary> ''' <returns></returns> ''' <remarks></remarks> Public Function endObject() As JSONStringer Return close(Scope.EMPTY_OBJECT, Scope.NONEMPTY_OBJECT, BRACKETS_CURLY_RIGHT) '"}") End Function ''' <summary> ''' 编码<code>val</code>。 ''' </summary> ''' <param name="val"> ''' <code>JSONObject</code>、<code>JSONArray</code>、String、Boolean、Integer、Long、Double或null。。 ''' </param> ''' <returns></returns> ''' <remarks></remarks> Public Function value(ByVal val As Object) As JSONStringer If stack.Count = 0 Then Throw New Exception("嵌套问题") End If If val.GetType.Equals(GetType(JSONArray)) Then val.writeTo(Me) Return Me ElseIf val.GetType.Equals(GetType(JSONObject)) Then val.writeTo(Me) Return Me ElseIf val.GetType.Equals(GetType(Dictionary(Of String, Object))) Or val.GetType.Equals(GetType(SortedDictionary(Of String, Object))) Or _ val.GetType.Equals(GetType(SortedList(Of String, Object))) Or val.GetType.Equals(GetType(Hashtable)) Then Dim jsObject As JSONObject = New JSONObject(val) jsObject.writeTo(Me) Return Me ElseIf IsArray(val) Or val.GetType.Equals(GetType(IList(Of Object))) Or val.GetType.Equals(GetType(List(Of Object))) Or _ val.GetType.Equals(GetType(HashSet(Of Object))) Or val.GetType.Equals(GetType(SortedSet(Of Object))) Or _ val.GetType.Equals(GetType(ArrayList)) Then Dim jsArray As JSONArray = New JSONArray(val) jsArray.writeTo(Me) Return Me End If beforeValue() If IsNothing(val) Or (val.GetType.Equals(GetType(Boolean))) Then out.Append(val) ElseIf Numeric(val.GetType) Then out.Append(JSONObject.numberToString(val)) Else setString(val.ToString()) End If Return Me End Function Public Function value(ByVal val As Boolean) As JSONStringer If stack.Count = 0 Then Throw New Exception("嵌套问题") End If beforeValue() out.Append(val) Return Me End Function Public Function value(ByVal val As Double) As JSONStringer If stack.Count = 0 Then Throw New Exception("嵌套问题") End If beforeValue() out.Append(val) Return Me End Function Public Function value(ByVal val As Long) As JSONStringer If stack.Count = 0 Then Throw New Exception("嵌套问题") End If beforeValue() out.Append(val) Return Me End Function Public Function value(ByVal val As Integer) As JSONStringer If stack.Count = 0 Then Throw New Exception("嵌套问题") End If beforeValue() out.Append(val) Return Me End Function Public Function value(ByVal val As UInteger) As JSONStringer If stack.Count = 0 Then Throw New Exception("嵌套问题") End If beforeValue() out.Append(val) Return Me End Function Public Function value(ByVal val As Short) As JSONStringer If stack.Count = 0 Then Throw New Exception("嵌套问题") End If beforeValue() out.Append(val) Return Me End Function Public Function value(ByVal val As UShort) As JSONStringer If stack.Count = 0 Then Throw New Exception("嵌套问题") End If beforeValue() out.Append(val) Return Me End Function ''' <summary> ''' 对该字符串的键(属性名)进行编码。 ''' </summary> ''' <param name="name">即将出现的值的名称。不能为空。</param> ''' <returns></returns> ''' <remarks></remarks> Public Function key(ByVal name As String) As JSONStringer If String.IsNullOrEmpty(name) Then Throw New Exception("名称必须为非空或长度不能为0") End If beforeKey() setString(name) Return Me End Function ''' <summary> ''' 返回编码的JSON字符串。 ''' </summary> ''' <returns></returns> ''' <remarks></remarks> Public Overloads Function toString() As String If out.Length = 0 Then Return Nothing Else Return out.ToString() End If End Function ''' <summary> ''' 通过附加任何必要的空格和给定的括号来输入新的范围。 ''' </summary> ''' <param name="empty"></param> ''' <param name="openBracket">用于开始的符号,只能是:{或[</param> ''' <returns></returns> ''' <remarks></remarks> Friend Function open(ByVal empty As Scope, ByVal openBracket As String) As JSONStringer If stack.Count = 0 And out.Length > 0 Then Throw New Exception("嵌套问题:多个顶级根") End If beforeValue() stack.Add(empty) out.Append(openBracket) Return Me End Function ''' <summary> ''' 通过附加任何必要的空白和给定的括号来关闭当前范围。 ''' </summary> ''' <param name="empty"></param> ''' <param name="nonempty"></param> ''' <param name="closeBracket">用于关闭的符号,必须与<code>open</code>时使用的符号时一对并且只能是:}或]</param> ''' <returns></returns> ''' <remarks></remarks> Friend Function close(ByVal empty As Scope, ByVal nonempty As Scope, ByVal closeBracket As String) As JSONStringer Dim context As Scope = peek() If (context <> nonempty) And (context <> empty) Then Throw New Exception("嵌套问题") End If ' stack.Remove(stack.Count - 1) stack.RemoveAt(stack.Count - 1) If context = empty Then newline() End If out.Append(closeBracket) Return Me End Function ''' <summary> ''' 在名称前插入任何必要的分隔符和空格。还调整堆栈以期望键的值。 ''' </summary> ''' <remarks></remarks> Friend Sub beforeKey() Dim context As Scope = peek() If context = Scope.NONEMPTY_OBJECT Then out.Append(COMMA) '添加逗号 ElseIf context <> Scope.EMPTY_OBJECT Then Throw New Exception("嵌套问题") End If newline() replaceTop(Scope.DANGLING_KEY) End Sub ''' <summary> ''' 在文字值、行数组或内联对象之前插入任何必要的分隔符和空格。同时调整堆栈以期望右括号或其他元素。 ''' </summary> ''' <remarks></remarks> Friend Sub beforeValue() If stack.Count = 0 Then Return End If Dim context As Scope = peek() If context = Scope.EMPTY_ARRAY Then '数组中的第一 replaceTop(Scope.NONEMPTY_ARRAY) newline() ElseIf context = Scope.NONEMPTY_ARRAY Then '数组中的另一个 out.Append(COMMA) '添加逗号 newline() ElseIf context = Scope.DANGLING_KEY Then '键的值 out.Append(IIf(IsNothing(indent), COLON, COLON_AND_SPACE)) replaceTop(Scope.NONEMPTY_OBJECT) ElseIf context <> Scope.NULL Then Throw New Exception("嵌套问题") End If End Sub ''' <summary> ''' 返回堆栈顶部的值。 ''' </summary> ''' <returns></returns> ''' <remarks></remarks> Friend Function peek() As Scope If IsNothing(stack) Then Throw New Exception("嵌套问题") ElseIf stack.Count = 0 Then Throw New Exception("嵌套问题") End If Return stack.Item(stack.Count - 1) End Function ''' <summary> ''' 用给定值替换堆栈顶部的值。 ''' </summary> ''' <param name="topOfStack"></param> ''' <remarks></remarks> Friend Sub replaceTop(ByVal topOfStack As Scope) stack.Item(stack.Count - 1) = topOfStack End Sub Friend Sub newline() If IsNothing(indent) Then Return End If out.Append(vbLf) '附加换行符 For i = 0 To stack.Count - 1 out.Append(indent) Next End Sub Friend Sub setString(ByVal val As String) out.Append(DOUNLE_QUOTATION_MARK) For i As Integer = 0 To val.Length - 1 Dim c As Char = val.Chars(i) Select Case c Case DOUNLE_QUOTATION_MARK, "\", "/" ''\\' out.Append("\").Append(c) Case vbTab ' '\t' out.Append("\t") Case vbBack ''\b' out.Append("\b") Case vbLf ''\n' out.Append("\n") Case vbCr ''\r' out.Append("\r") Case vbFormFeed ''\f' out.Append("\f") Case Else If Asc(c) <= &H1F Then out.Append(String.Format("\u%04x", Asc(c))) Else out.Append(c) End If End Select Next out.Append(DOUNLE_QUOTATION_MARK) End Sub ''' <summary> ''' 类型是数字类型 ''' </summary> ''' <param name="dataType">类型</param> ''' <returns></returns> ''' <remarks></remarks> Private Function Numeric(ByVal dataType As Type) As Boolean If Microsoft.VisualBasic.IsNothing(dataType) Then Return False Else Return dataType.Equals(GetType(Byte)) Or dataType.Equals(GetType(SByte)) Or dataType.Equals(GetType(Char)) Or _ dataType.Equals(GetType(Short)) Or dataType.Equals(GetType(UShort)) Or dataType.Equals(GetType(Integer)) Or _ dataType.Equals(GetType(UInteger)) Or dataType.Equals(GetType(Long)) Or dataType.Equals(GetType(ULong)) Or _ dataType.Equals(GetType(Single)) Or dataType.Equals(GetType(Double)) Or dataType.Equals(GetType(Int16)) Or _ dataType.Equals(GetType(Int32)) Or dataType.Equals(GetType(Int64)) Or dataType.Equals(GetType(UInt16)) Or _ dataType.Equals(GetType(UInt32)) Or dataType.Equals(GetType(UInt64)) Or dataType.Equals(GetType(UIntPtr)) End If End Function End Class
JSONArray类。与java JSONArray相同,用于存储json数组
Public Class JSONArray Dim values As ArrayList Public Sub New() values = New ArrayList() End Sub ''' <summary> ''' 通过Object对象构造实体 ''' </summary> ''' <param name="obj"></param> ''' <remarks></remarks> Public Sub New(ByVal obj As Object) If IsArray(obj) Or obj.GetType.Equals(GetType(IList(Of Object))) Or obj.GetType.Equals(GetType(List(Of Object))) Then values = ArrayList.Adapter(obj) ElseIf obj.GetType.Equals(GetType(HashSet(Of Object))) Or obj.GetType.Equals(GetType(SortedSet(Of Object))) Then values = ArrayList.Adapter(obj.ToArray()) ElseIf obj.GetType.Equals(GetType(ArrayList)) Then values = obj Else values = New ArrayList() values.Add(obj) End If End Sub ''' <summary> ''' 通过数组列表构造实体 ''' </summary> ''' <param name="arrBuff"></param> ''' <remarks></remarks> Public Sub New(ByVal arrBuff As ArrayList) values = arrBuff End Sub ''' <summary> ''' 通过数组构造实体 ''' </summary> ''' <param name="arrBuff"></param> ''' <remarks></remarks> Public Sub New(ByVal arrBuff As Array) values = ArrayList.Adapter(arrBuff) End Sub ''' <summary> ''' 通过列表构造实体 ''' </summary> ''' <param name="list"></param> ''' <remarks></remarks> Public Sub New(ByVal list As List(Of Object)) values = ArrayList.Adapter(list) End Sub ''' <summary> ''' 通过列表构造实体 ''' </summary> ''' <param name="hSet"></param> ''' <remarks></remarks> Public Sub New(ByVal hSet As HashSet(Of Object)) values = ArrayList.Adapter(hSet.ToArray()) End Sub ''' <summary> ''' 通过列表构造实体 ''' </summary> ''' <param name="sSet"></param> ''' <remarks></remarks> Public Sub New(ByVal sSet As SortedSet(Of Object)) values = ArrayList.Adapter(sSet.ToArray()) End Sub ''' <summary> ''' 将<code>value</code>追加到此数组的结尾。 ''' </summary> ''' <param name="value"></param> ''' <returns></returns> ''' <remarks></remarks> Public Function Put(ByVal value As Boolean) As JSONArray values.Add(value) ' Me.Add(value) Return Me End Function ''' <summary> ''' 将<code>value</code>追加到此数组的结尾。 ''' </summary> ''' <param name="value"></param> ''' <returns></returns> ''' <remarks></remarks> Public Function Put(ByVal value As Byte) As JSONArray values.Add(value) 'Me.Add(value) Return Me End Function ''' <summary> ''' 将<code>value</code>追加到此数组的结尾。 ''' </summary> ''' <param name="value"></param> ''' <returns></returns> ''' <remarks></remarks> Public Function Put(ByVal value As SByte) As JSONArray values.Add(value) 'Me.Add(value) Return Me End Function ''' <summary> ''' 将<code>value</code>追加到此数组的结尾。 ''' </summary> ''' <param name="value"></param> ''' <returns></returns> ''' <remarks></remarks> Public Function Put(ByVal value As Char) As JSONArray values.Add(value) 'Me.Add(value) Return Me End Function ''' <summary> ''' 将<code>value</code>追加到此数组的结尾。 ''' </summary> ''' <param name="value"></param> ''' <returns></returns> ''' <remarks></remarks> Public Function Put(ByVal value As Double) As JSONArray values.Add(value) 'Me.Add(value) Return Me End Function ''' <summary> ''' 将<code>value</code>追加到此数组的结尾。 ''' </summary> ''' <param name="value"></param> ''' <returns></returns> ''' <remarks></remarks> Public Function Put(ByVal value As Single) As JSONArray values.Add(value) 'Me.Add(value) Return Me End Function ''' <summary> ''' 将<code>value</code>追加到此数组的结尾。 ''' </summary> ''' <param name="value"></param> ''' <returns></returns> ''' <remarks></remarks> Public Function Put(ByVal value As Short) As JSONArray values.Add(value) 'Me.Add(value) Return Me End Function ''' <summary> ''' 将<code>value</code>追加到此数组的结尾。 ''' </summary> ''' <param name="value"></param> ''' <returns></returns> ''' <remarks></remarks> Public Function Put(ByVal value As UShort) As JSONArray values.Add(value) ' Me.Add(value) Return Me End Function ''' <summary> ''' 将<code>value</code>追加到此数组的结尾。 ''' </summary> ''' <param name="value"></param> ''' <returns></returns> ''' <remarks></remarks> Public Function Put(ByVal value As Integer) As JSONArray values.Add(value) 'Me.Add(value) Return Me End Function ''' <summary> ''' 将<code>value</code>追加到此数组的结尾。 ''' </summary> ''' <param name="value"></param> ''' <returns></returns> ''' <remarks></remarks> Public Function Put(ByVal value As UInteger) As JSONArray values.Add(value) ' Me.Add(value) Return Me End Function ''' <summary> ''' 将<code>value</code>追加到此数组的结尾。 ''' </summary> ''' <param name="value"></param> ''' <returns></returns> ''' <remarks></remarks> Public Function Put(ByVal value As Long) As JSONArray values.Add(value) 'Me.Add(value) Return Me End Function ''' <summary> ''' 将<code>value</code>追加到此数组的结尾。 ''' </summary> ''' <param name="value"></param> ''' <returns></returns> ''' <remarks></remarks> Public Function Put(ByVal value As ULong) As JSONArray values.Add(value) ' Me.Add(value) Return Me End Function ''' <summary> ''' 将<code>value</code>追加到此数组的结尾。 ''' </summary> ''' <param name="value"></param> ''' <returns></returns> ''' <remarks></remarks> Public Function Put(ByVal value As String) As JSONArray values.Add(value) 'Me.Add(value) Return Me End Function ''' <summary> ''' 将<code>value</code>追加到此数组的结尾。 ''' </summary> ''' <param name="value"></param> ''' <returns></returns> ''' <remarks></remarks> Public Function Put(ByVal value As Object) As JSONArray values.Add(value) ' Me.Add(value) Return Me End Function ''' <summary> ''' 与<c>put</c>相同,增加了有效性检查。 ''' </summary> ''' <param name="value"></param> ''' <remarks></remarks> Public Sub CheckedPut(ByVal value As Object) If IsNumeric(value) Then JSON.checkDouble(value) End If Put(value) End Sub Public Function Put(ByVal index As Integer, ByVal value As Object) As JSONArray If IsNumeric(value) Then JSON.checkDouble(value) End If While values.Count <= index values.Add(Nothing) End While values.Insert(index, value) Return Me End Function Public Function Put(ByVal index As Integer, ByVal value As Boolean) As JSONArray Dim obj As Object = value Return Put(index, obj) End Function ''' <summary> ''' 将<code>value</code>追加到此数组的结尾。 ''' </summary> ''' <param name="value"></param> ''' <returns></returns> ''' <remarks></remarks> Public Function Put(ByVal index As Integer, ByVal value As Byte) As JSONArray Dim obj As Object = value Return Put(index, obj) End Function ''' <summary> ''' 将<code>value</code>追加到此数组的结尾。 ''' </summary> ''' <param name="value"></param> ''' <returns></returns> ''' <remarks></remarks> Public Function Put(ByVal index As Integer, ByVal value As SByte) As JSONArray Dim obj As Object = value Return Put(index, obj) End Function ''' <summary> ''' 将<code>value</code>追加到此数组的结尾。 ''' </summary> ''' <param name="value"></param> ''' <returns></returns> ''' <remarks></remarks> Public Function Put(ByVal index As Integer, ByVal value As Char) As JSONArray Dim obj As Object = value Return Put(index, obj) End Function ''' <summary> ''' 将<code>value</code>追加到此数组的结尾。 ''' </summary> ''' <param name="value"></param> ''' <returns></returns> ''' <remarks></remarks> Public Function Put(ByVal index As Integer, ByVal value As Double) As JSONArray Dim obj As Object = value Return Put(index, obj) End Function ''' <summary> ''' 将<code>value</code>追加到此数组的结尾。 ''' </summary> ''' <param name="value"></param> ''' <returns></returns> ''' <remarks></remarks> Public Function Put(ByVal index As Integer, ByVal value As Single) As JSONArray Dim obj As Object = value Return Put(index, obj) End Function ''' <summary> ''' 将<code>value</code>追加到此数组的结尾。 ''' </summary> ''' <param name="value"></param> ''' <returns></returns> ''' <remarks></remarks> Public Function Put(ByVal index As Integer, ByVal value As Short) As JSONArray Dim obj As Object = value Return Put(index, obj) End Function ''' <summary> ''' 将<code>value</code>追加到此数组的结尾。 ''' </summary> ''' <param name="value"></param> ''' <returns></returns> ''' <remarks></remarks> Public Function Put(ByVal index As Integer, ByVal value As UShort) As JSONArray Dim obj As Object = value Return Put(index, obj) End Function ''' <summary> ''' 将<code>value</code>追加到此数组的结尾。 ''' </summary> ''' <param name="value"></param> ''' <returns></returns> ''' <remarks></remarks> Public Function Put(ByVal index As Integer, ByVal value As Integer) As JSONArray Dim obj As Object = value Return Put(index, obj) End Function ''' <summary> ''' 将<code>value</code>追加到此数组的结尾。 ''' </summary> ''' <param name="value"></param> ''' <returns></returns> ''' <remarks></remarks> Public Function Put(ByVal index As Integer, ByVal value As UInteger) As JSONArray Dim obj As Object = value Return Put(index, obj) End Function ''' <summary> ''' 将<code>value</code>追加到此数组的结尾。 ''' </summary> ''' <param name="value"></param> ''' <returns></returns> ''' <remarks></remarks> Public Function Put(ByVal index As Integer, ByVal value As Long) As JSONArray Dim obj As Object = value Return Put(index, obj) End Function ''' <summary> ''' 将<code>value</code>追加到此数组的结尾。 ''' </summary> ''' <param name="value"></param> ''' <returns></returns> ''' <remarks></remarks> Public Function Put(ByVal index As Integer, ByVal value As ULong) As JSONArray Dim obj As Object = value Return Put(index, obj) End Function ''' <summary> ''' 将<code>value</code>追加到此数组的结尾。 ''' </summary> ''' <param name="value"></param> ''' <returns></returns> ''' <remarks></remarks> Public Function Put(ByVal index As Integer, ByVal value As String) As JSONArray Dim obj As Object = value Return Put(index, obj) End Function ''' <summary> ''' 返回一个 Boolean 值,指示数组指定位置是否未被指派对象。 ''' </summary> ''' <param name="index"></param> ''' <returns></returns> ''' <remarks></remarks> Public Function IsNothing(ByVal index As Integer) As Boolean Dim val As Object = Opt(index) Return val = Nothing End Function Public Function GetItem(ByVal index As Integer) As Object Try Dim val As Object = values.Item(index) If Microsoft.VisualBasic.IsNothing(val) Then Throw New Exception("Value at " + index + " is null.") End If Return val Catch ex As Exception Throw New Exception("Index " + index + " out of range [0.." + values.Count() + ")", ex) End Try End Function Public Function Opt(ByVal index As Integer) As Object If index < 0 Or index >= values.Count Then Return Nothing End If Return values.Item(index) End Function ''' <summary> ''' 删除并返回<code>index</code>处的值,如果数组在<code>index</code>处没有值,则返回nothing。 ''' </summary> ''' <param name="index"></param> ''' <returns></returns> ''' <remarks></remarks> Public Function Remove(ByVal index As Integer) As Object Dim val As Object = Opt(index) If Microsoft.VisualBasic.IsNothing(val) Then Return Nothing Else 'Me.Remove(val) values.Remove(val) Return val End If End Function ''' <summary> ''' 返回<code>index</code>处的值(如果它存在且是布尔值或可以强制为布尔值)。 ''' </summary> ''' <param name="index"></param> ''' <returns></returns> ''' <remarks></remarks> ''' <exception cref="Exception">如果<code>index</code>处的值不存在或无法强制为布尔值。</exception> Public Function GetBoolean(ByVal index As Integer) As Boolean Dim val As Object = GetItem(index) Dim result As Boolean = JSON.toBoolean(val) If Microsoft.VisualBasic.IsNothing(result) Then Throw JSON.typeMismatch(index, val, GetType(Boolean).Name) End If Return result End Function ''' <summary> ''' 返回<code>index</code>处的值(如果该值存在并且是布尔值或可以*强制为布尔值)。否则返回<code>defaultVal</code>。 ''' </summary> ''' <param name="index"></param> ''' <param name="defaultVal"></param> ''' <returns></returns> ''' <remarks></remarks> Public Function OptBoolean(ByVal index As Integer, Optional ByVal defaultVal As Boolean = False) As Boolean Dim val As Object = Opt(index) Dim result As Boolean = JSON.toBoolean(val) Return IIf(Microsoft.VisualBasic.IsNothing(result), defaultVal, result) End Function ''' <summary> ''' 返回<code>index</code>处的值(如果它存在且是Byte或可以强制为Byte)。 ''' </summary> ''' <param name="index"></param> ''' <returns></returns> ''' <remarks></remarks> ''' <exception cref="Exception">如果<code>index</code>处的值不存在或无法强制为Byte。</exception> Public Function GetByte(ByVal index As Integer) As Byte Dim val As Object = GetItem(index) Dim result As Byte = JSON.toByte(val) If Microsoft.VisualBasic.IsNothing(result) Then Throw JSON.typeMismatch(index, val, GetType(Byte).Name) End If Return result End Function ''' <summary> ''' 返回<code>index</code>处的值(如果该值存在并且是Byte或可以*强制为Byte)。否则返回<code>defaultVal</code>。 ''' </summary> ''' <param name="index"></param> ''' <param name="defaultVal"></param> ''' <returns></returns> ''' <remarks></remarks> Public Function OptByte(ByVal index As Integer, Optional ByVal defaultVal As Byte = 0) As Byte Dim val As Object = Opt(index) Dim result As Byte = JSON.toByte(val) Return IIf(Microsoft.VisualBasic.IsNothing(result), defaultVal, result) End Function ''' <summary> ''' 返回<code>index</code>处的值(如果它存在且是Char或可以强制为Char)。 ''' </summary> ''' <param name="index"></param> ''' <returns></returns> ''' <remarks></remarks> ''' <exception cref="Exception">如果<code>index</code>处的值不存在或无法强制为Char。</exception> Public Function GetChar(ByVal index As Integer) As Char Dim val As Object = GetItem(index) Dim result As Char = JSON.toChar(val) If Microsoft.VisualBasic.IsNothing(result) Then Throw JSON.typeMismatch(index, val, GetType(Char).Name) End If Return result End Function ''' <summary> ''' 返回<code>index</code>处的值(如果该值存在并且是Char或可以*强制为Char)。否则返回<code>defaultVal</code>。 ''' </summary> ''' <param name="index"></param> ''' <param name="defaultVal"></param> ''' <returns></returns> ''' <remarks></remarks> Public Function OptByte(ByVal index As Integer, Optional ByVal defaultVal As Char = Chr(0)) As Char Dim val As Object = Opt(index) Dim result As Char = JSON.toChar(val) Return IIf(Microsoft.VisualBasic.IsNothing(result), defaultVal, result) End Function ''' <summary> ''' 返回<code>index</code>处的值(如果它存在且是SByte或可以强制为SByte)。 ''' </summary> ''' <param name="index"></param> ''' <returns></returns> ''' <remarks></remarks> ''' <exception cref="Exception">如果<code>index</code>处的值不存在或无法强制为SByte。</exception> Public Function GetSByte(ByVal index As Integer) As SByte Dim val As Object = GetItem(index) Dim result As SByte = JSON.toSByte(val) If Microsoft.VisualBasic.IsNothing(result) Then Throw JSON.typeMismatch(index, val, GetType(SByte).Name) End If Return result End Function ''' <summary> ''' 返回<code>index</code>处的值(如果该值存在并且是SByte或可以*强制为SByte)。否则返回<code>defaultVal</code>。 ''' </summary> ''' <param name="index"></param> ''' <param name="defaultVal"></param> ''' <returns></returns> ''' <remarks></remarks> Public Function OptSByte(ByVal index As Integer, Optional ByVal defaultVal As SByte = 0) As SByte Dim val As Object = Opt(index) Dim result As SByte = JSON.toSByte(val) Return IIf(Microsoft.VisualBasic.IsNothing(result), defaultVal, result) End Function ''' <summary> ''' 返回<code>index</code>处的值(如果它存在且是Short或可以强制为Short)。 ''' </summary> ''' <param name="index"></param> ''' <returns></returns> ''' <remarks></remarks> ''' <exception cref="Exception">如果<code>index</code>处的值不存在或无法强制为Short。</exception> Public Function GetShort(ByVal index As Integer) As Short Dim val As Object = GetItem(index) Dim result As Short = JSON.toShort(val) If Microsoft.VisualBasic.IsNothing(result) Then Throw JSON.typeMismatch(index, val, GetType(Short).Name) End If Return result End Function ''' <summary> ''' 返回<code>index</code>处的值(如果该值存在并且是Short或可以*强制为Short)。否则返回<code>defaultVal</code>。 ''' </summary> ''' <param name="index"></param> ''' <param name="defaultVal"></param> ''' <returns></returns> ''' <remarks></remarks> Public Function OptShort(ByVal index As Integer, Optional ByVal defaultVal As Short = 0) As Short Dim val As Object = Opt(index) Dim result As Short = JSON.toShort(val) Return IIf(Microsoft.VisualBasic.IsNothing(result), defaultVal, result) End Function ''' <summary> ''' 返回<code>index</code>处的值(如果它存在且是UShort或可以强制为UShort)。 ''' </summary> ''' <param name="index"></param> ''' <returns></returns> ''' <remarks></remarks> ''' <exception cref="Exception">如果<code>index</code>处的值不存在或无法强制为UShort。</exception> Public Function GetUShort(ByVal index As Integer) As UShort Dim val As Object = GetItem(index) Dim result As UShort = JSON.toUShort(val) If Microsoft.VisualBasic.IsNothing(result) Then Throw JSON.typeMismatch(index, val, GetType(UShort).Name) End If Return result End Function ''' <summary> ''' 返回<code>index</code>处的值(如果该值存在并且是UShort或可以*强制为UShort)。否则返回<code>defaultVal</code>。 ''' </summary> ''' <param name="index"></param> ''' <param name="defaultVal"></param> ''' <returns></returns> ''' <remarks></remarks> Public Function OptUShort(ByVal index As Integer, Optional ByVal defaultVal As UShort = 0) As UShort Dim val As Object = Opt(index) Dim result As UShort = JSON.toUShort(val) Return IIf(Microsoft.VisualBasic.IsNothing(result), defaultVal, result) End Function ''' <summary> ''' 返回<code>index</code>处的值(如果它存在且是Integer或可以强制为Integer)。 ''' </summary> ''' <param name="index"></param> ''' <returns></returns> ''' <remarks></remarks> ''' <exception cref="Exception">如果<code>index</code>处的值不存在或无法强制为Integer。</exception> Public Function GetInteger(ByVal index As Integer) As Integer Dim val As Object = GetItem(index) Dim result As Integer = JSON.toInteger(val) If Microsoft.VisualBasic.IsNothing(result) Then Throw JSON.typeMismatch(index, val, GetType(Integer).Name) End If Return result End Function ''' <summary> ''' 返回<code>index</code>处的值(如果该值存在并且是Integer或可以*强制为Integer)。否则返回<code>defaultVal</code>。 ''' </summary> ''' <param name="index"></param> ''' <param name="defaultVal"></param> ''' <returns></returns> ''' <remarks></remarks> Public Function OptInteger(ByVal index As Integer, Optional ByVal defaultVal As Integer = 0) As Integer Dim val As Object = Opt(index) Dim result As Integer = JSON.toInteger(val) Return IIf(Microsoft.VisualBasic.IsNothing(result), defaultVal, result) End Function ''' <summary> ''' 返回<code>index</code>处的值(如果它存在且是UInteger或可以强制为UInteger)。 ''' </summary> ''' <param name="index"></param> ''' <returns></returns> ''' <remarks></remarks> ''' <exception cref="Exception">如果<code>index</code>处的值不存在或无法强制为UInteger。</exception> Public Function GetUInteger(ByVal index As Integer) As UInteger Dim val As Object = GetItem(index) Dim result As UInteger = JSON.toUInteger(val) If Microsoft.VisualBasic.IsNothing(result) Then Throw JSON.typeMismatch(index, val, GetType(UInteger).Name) End If Return result End Function ''' <summary> ''' 返回<code>index</code>处的值(如果该值存在并且是UInteger或可以*强制为UInteger)。否则返回<code>defaultVal</code>。 ''' </summary> ''' <param name="index"></param> ''' <param name="defaultVal"></param> ''' <returns></returns> ''' <remarks></remarks> Public Function OptUInteger(ByVal index As Integer, Optional ByVal defaultVal As UInteger = 0) As UInteger Dim val As Object = Opt(index) Dim result As UInteger = JSON.toUInteger(val) Return IIf(Microsoft.VisualBasic.IsNothing(result), defaultVal, result) End Function ''' <summary> ''' 返回<code>index</code>处的值(如果它存在且是Long或可以强制为Long)。 ''' </summary> ''' <param name="index"></param> ''' <returns></returns> ''' <remarks></remarks> ''' <exception cref="Exception">如果<code>index</code>处的值不存在或无法强制为Long。</exception> Public Function GetLong(ByVal index As Integer) As Long Dim val As Object = GetItem(index) Dim result As Long = JSON.toLong(val) If Microsoft.VisualBasic.IsNothing(result) Then Throw JSON.typeMismatch(index, val, GetType(Long).Name) End If Return result End Function ''' <summary> ''' 返回<code>index</code>处的值(如果该值存在并且是Long或可以*强制为Long)。否则返回<code>defaultVal</code>。 ''' </summary> ''' <param name="index"></param> ''' <param name="defaultVal"></param> ''' <returns></returns> ''' <remarks></remarks> Public Function OptLong(ByVal index As Integer, Optional ByVal defaultVal As Long = 0) As Long Dim val As Object = Opt(index) Dim result As Long = JSON.toLong(val) Return IIf(Microsoft.VisualBasic.IsNothing(result), defaultVal, result) End Function ''' <summary> ''' 返回<code>index</code>处的值(如果它存在且是ULong或可以强制为ULong)。 ''' </summary> ''' <param name="index"></param> ''' <returns></returns> ''' <remarks></remarks> ''' <exception cref="Exception">如果<code>index</code>处的值不存在或无法强制为ULong。</exception> Public Function GetULong(ByVal index As Integer) As ULong Dim val As Object = GetItem(index) Dim result As ULong = JSON.toULong(val) If Microsoft.VisualBasic.IsNothing(result) Then Throw JSON.typeMismatch(index, val, GetType(ULong).Name) End If Return result End Function ''' <summary> ''' 返回<code>index</code>处的值(如果该值存在并且是ULong或可以*强制为ULong)。否则返回<code>defaultVal</code>。 ''' </summary> ''' <param name="index"></param> ''' <param name="defaultVal"></param> ''' <returns></returns> ''' <remarks></remarks> Public Function OptULong(ByVal index As Integer, Optional ByVal defaultVal As ULong = 0) As ULong Dim val As Object = Opt(index) Dim result As ULong = JSON.toULong(val) Return IIf(Microsoft.VisualBasic.IsNothing(result), defaultVal, result) End Function ''' <summary> ''' 返回<code>index</code>处的值(如果它存在且是Single或可以强制为Single)。 ''' </summary> ''' <param name="index"></param> ''' <returns></returns> ''' <remarks></remarks> ''' <exception cref="Exception">如果<code>index</code>处的值不存在或无法强制为Single。</exception> Public Function GetSingle(ByVal index As Integer) As Single Dim val As Object = GetItem(index) Dim result As Single = JSON.toSingle(val) If Microsoft.VisualBasic.IsNothing(result) Then Throw JSON.typeMismatch(index, val, GetType(Single).Name) End If Return result End Function ''' <summary> ''' 返回<code>index</code>处的值(如果该值存在并且是Single或可以*强制为Single)。否则返回<code>defaultVal</code>。 ''' </summary> ''' <param name="index"></param> ''' <param name="defaultVal"></param> ''' <returns></returns> ''' <remarks></remarks> Public Function OptSingle(ByVal index As Integer, Optional ByVal defaultVal As Single = 0.0) As Single Dim val As Object = Opt(index) Dim result As Single = JSON.toSingle(val) Return IIf(Microsoft.VisualBasic.IsNothing(result), defaultVal, result) End Function ''' <summary> ''' 返回<code>index</code>处的值(如果它存在且是Double或可以强制为Double)。 ''' </summary> ''' <param name="index"></param> ''' <returns></returns> ''' <remarks></remarks> ''' <exception cref="Exception">如果<code>index</code>处的值不存在或无法强制为Double。</exception> Public Function GetDouble(ByVal index As Integer) As Double Dim val As Object = GetItem(index) Dim result As Double = JSON.toDouble(val) If Microsoft.VisualBasic.IsNothing(result) Then Throw JSON.typeMismatch(index, val, GetType(Double).Name) End If Return result End Function ''' <summary> ''' 返回<code>index</code>处的值(如果该值存在并且是Double或可以*强制为Double)。否则返回<code>defaultVal</code>。 ''' </summary> ''' <param name="index"></param> ''' <param name="defaultVal"></param> ''' <returns></returns> ''' <remarks></remarks> Public Function OptDouble(ByVal index As Integer, Optional ByVal defaultVal As Double = 0.0) As Double Dim val As Object = Opt(index) Dim result As Double = JSON.toDouble(val) Return IIf(Microsoft.VisualBasic.IsNothing(result), defaultVal, result) End Function ''' <summary> ''' 返回<code>index</code>处的值(如果它存在且是String或可以强制为String)。 ''' </summary> ''' <param name="index"></param> ''' <returns></returns> ''' <remarks></remarks> ''' <exception cref="Exception">如果<code>index</code>处的值不存在或无法强制为String。</exception> Public Function GetString(ByVal index As Integer) As String Dim val As Object = GetItem(index) Dim result As String = JSON.ToString(val) If Microsoft.VisualBasic.IsNothing(result) Then Throw JSON.typeMismatch(index, val, GetType(String).Name) End If Return result End Function ''' <summary> ''' 返回<code>index</code>处的值(如果该值存在并且是String或可以*强制为String)。否则返回<code>defaultVal</code>。 ''' </summary> ''' <param name="index"></param> ''' <param name="defaultVal"></param> ''' <returns></returns> ''' <remarks></remarks> Public Function OptString(ByVal index As Integer, Optional ByVal defaultVal As String = Nothing) As String Dim val As Object = Opt(index) Dim result As String = JSON.ToString(val) Return IIf(Microsoft.VisualBasic.IsNothing(result), defaultVal, result) End Function ''' <summary> ''' 返回<code>index</code>处的值(如果该值存在并且是或可以强制为<code>JSONArray</code>)。 ''' </summary> ''' <param name="index"></param> ''' <returns></returns> ''' <remarks></remarks> Public Function GetJSONArray(ByVal index As Integer) As JSONArray Dim val As Object = GetItem(index) If val.GetType.Equals(GetType(JSONArray)) Then Return val ElseIf IsArray(val) Or val.GetType.Equals(GetType(ArrayList)) Or val.GetType.Equals(GetType(IList(Of Object))) Or val.GetType.Equals(GetType(List(Of Object))) Then Return New JSONArray(val) Else Throw JSON.typeMismatch(index, val, "JSONArray") End If End Function ''' <summary> ''' 返回<code>index</code>处的值(如果该值存在并且是或可以强制为<code>JSONArray</code>)。否则返回Nothing。 ''' </summary> ''' <param name="index"></param> ''' <returns></returns> ''' <remarks></remarks> Public Function OptJSONArray(ByVal index As Integer) As JSONArray Dim val As Object = Opt(index) If val.GetType.Equals(GetType(JSONArray)) Then Return val ElseIf IsArray(val) Or val.GetType.Equals(GetType(ArrayList)) Or val.GetType.Equals(GetType(IList(Of Object))) Or val.GetType.Equals(GetType(List(Of Object))) Then Return New JSONArray(val) Else Return Nothing End If End Function ''' <summary> ''' 返回<code>index</code>处的值(如果该值存在并且是或者强制转换为<code>JSONObject</code>)。 ''' </summary> ''' <param name="index"></param> ''' <returns></returns> ''' <remarks></remarks> Public Function GetJSONObject(ByVal index As Integer) As JSONObject Dim val As Object = GetItem(index) If val.GetType.Equals(GetType(JSONObject)) Then Return val ElseIf val.GetType.Equals(GetType(Dictionary(Of String, Object))) Then Dim d As Dictionary(Of String, Object) = val Return New JSONObject(d) ElseIf val.GetType.Equals(GetType(SortedDictionary(Of String, Object))) Then Dim sd As SortedDictionary(Of String, Object) = val Dim d As Dictionary(Of String, Object) = New Dictionary(Of String, Object) For Each kvp As KeyValuePair(Of String, Object) In sd '遍历元素 d.Add(kvp.Key, kvp.Value) Next Return New JSONObject(d) ElseIf val.GetType.Equals(GetType(String)) Then Return New JSONObject(CStr(val)) Else Throw JSON.typeMismatch(index, val, "JSONObject") End If End Function ''' <summary> ''' 返回<code>index</code>处的值(如果该值存在并且是或可以强制为<code>JSONObject</code>)。否则返回Nothing。 ''' </summary> ''' <param name="index"></param> ''' <returns></returns> ''' <remarks></remarks> Public Function OptJSONObject(ByVal index As Integer) As JSONObject Dim val As Object = GetItem(index) Try If val.GetType.Equals(GetType(JSONObject)) Then Return val ElseIf val.GetType.Equals(GetType(Dictionary(Of String, Object))) Then Dim d As Dictionary(Of String, Object) = val Return New JSONObject(d) ElseIf val.GetType.Equals(GetType(SortedDictionary(Of String, Object))) Then Dim sd As SortedDictionary(Of String, Object) = val Dim d As Dictionary(Of String, Object) = New Dictionary(Of String, Object) For Each kvp As KeyValuePair(Of String, Object) In sd '遍历元素 d.Add(kvp.Key, kvp.Value) Next Return New JSONObject(d) ElseIf val.GetType.Equals(GetType(String)) Then Return New JSONObject(CStr(val)) Else Return Nothing End If Catch ex As Exception Return Nothing End Try End Function ''' <summary> ''' 返回一个新对象,其值是此数组中的值,其名称是<code>names</code>中的值。名称和值按索引从0到较短数组长度配对。不是字符串的名称将强制为字符串。如果任一数组为空,则此方法返回Nothing。 ''' </summary> ''' <param name="names"></param> ''' <returns></returns> ''' <remarks></remarks> Public Function toJSONObject(ByVal names As JSONArray) As JSONObject Dim result As JSONObject = New JSONObject() Dim length As Integer = Math.Min(names.Count, values.Count) If length = 0 Then Return Nothing End If For i = 0 To length - 1 Dim name As String = JSON.ToString(names.Opt(i)) result.put(name, Opt(i)) Next Return result End Function ''' <summary> ''' 通过将此数组的值与<code>separator</code>交替返回新字符串。此数组的字符串值被引用,并对其特殊字符进行转义。例如,包含字符串'12" pizza', 'taco' 和 'soda' 的数组在'+'上连接返回: ''' "12\" pizza"+"taco"+"soda" ''' </summary> ''' <param name="separator"></param> ''' <returns></returns> ''' <remarks></remarks> Public Function Join(ByVal separator As String) As String Dim stringer As JSONStringer = New JSONStringer() stringer.open(JSONStringer.Scope.NULL, "") For i As Integer = 0 To values.Count - 1 If i > 0 Then stringer.out.Append(separator) End If stringer.value(values.Item(i)) Next stringer.close(JSONStringer.Scope.NULL, JSONStringer.Scope.NULL, "") Return stringer.out.ToString() End Function ''' <summary> ''' 将此数组编码为紧凑的JSON字符串,例如:[94043,90210] ''' </summary> ''' <returns></returns> ''' <remarks></remarks> Public Overrides Function toString() As String Try Dim stringer As JSONStringer = New JSONStringer() writeTo(stringer) Return stringer.toString() Catch ex As Exception Return Nothing End Try End Function ''' <summary> ''' 将此数组编码为用于调试的可读JSON字符串,例如:[94043, 90210] ''' </summary> ''' <param name="indentSpaces">嵌套的每个级别缩进的空格数。</param> ''' <returns></returns> ''' <remarks></remarks> Public Overloads Function toString(ByVal indentSpaces As Integer) As String Dim stringer As JSONStringer = New JSONStringer(indentSpaces) writeTo(stringer) Return stringer.toString() End Function Friend Sub writeTo(stringer As JSONStringer) stringer.startArray() For Each val As Object In values stringer.value(val) Next stringer.endArray() End Sub Public Overloads Function Equals(ByVal obj As Object) As Boolean If obj.GetType.Equals(GetType(JSONArray)) Then Return obj.values.Equals(values) End If Return False End Function Public Overloads Function GetHashCode() As Integer Return values.GetHashCode() End Function ''' <summary> ''' 类型是数字类型 ''' </summary> ''' <param name="dataType">类型</param> ''' <returns></returns> ''' <remarks></remarks> Private Function IsNumeric(ByVal dataType As Type) As Boolean If Microsoft.VisualBasic.IsNothing(dataType) Then Return False Else Return dataType.Equals(GetType(Byte)) Or dataType.Equals(GetType(SByte)) Or dataType.Equals(GetType(Char)) Or _ dataType.Equals(GetType(Short)) Or dataType.Equals(GetType(UShort)) Or dataType.Equals(GetType(Integer)) Or _ dataType.Equals(GetType(UInteger)) Or dataType.Equals(GetType(Long)) Or dataType.Equals(GetType(ULong)) Or _ dataType.Equals(GetType(Single)) Or dataType.Equals(GetType(Double)) Or dataType.Equals(GetType(Int16)) Or _ dataType.Equals(GetType(Int32)) Or dataType.Equals(GetType(Int64)) Or dataType.Equals(GetType(UInt16)) Or _ dataType.Equals(GetType(UInt32)) Or dataType.Equals(GetType(UInt64)) Or dataType.Equals(GetType(UIntPtr)) End If End Function ''' <summary> ''' 返回此数组中的值数。 ''' </summary> ''' <value></value> ''' <returns></returns> ''' <remarks></remarks> Public ReadOnly Property Count() As Integer ' Implements ICollection(Of Object).Count Get Return values.Count End Get End Property Public Sub Clear() values.Clear() End Sub Public Sub CopyTo(array As Object(), arrayIndex As Integer) If array Is Nothing Then Throw New ArgumentNullException("The array cannot be null.") ElseIf arrayIndex < 0 Then Throw New ArgumentOutOfRangeException("The starting array index cannot be negative.") ElseIf Count > array.Length - arrayIndex + 1 Then Throw New ArgumentException("The destination array has fewer elements than the collection.") End If ' For i As Integer = 0 To listArray.Length - 1 'array(i + arrayIndex) = listArray(i) ' Next values.CopyTo(array, arrayIndex) End Sub End Class
JSONObject类。与java JSONObject相同。json的主类,用于接收json字符串和输出json字符串
Imports System.Web.Script.Serialization Public Class JSONObject Const NEGATIVE_ZERO = -0D Dim nameValuePairs As Dictionary(Of String, Object) Public Sub New() nameValuePairs = New Dictionary(Of String, Object) End Sub Public Sub New(ByVal d As Dictionary(Of String, Object)) nameValuePairs = d End Sub Public Sub New(ByVal sd As SortedDictionary(Of String, Object)) nameValuePairs = New Dictionary(Of String, Object) For Each kvp As KeyValuePair(Of String, Object) In sd '遍历元素 nameValuePairs.Add(kvp.Key, kvp.Value) Next End Sub Public Sub New(ByVal sl As SortedList(Of String, Object)) nameValuePairs = New Dictionary(Of String, Object) For Each kvp As KeyValuePair(Of String, Object) In sl '遍历元素 nameValuePairs.Add(kvp.Key, kvp.Value) Next End Sub Public Sub New(ByVal hash As Hashtable) nameValuePairs = New Dictionary(Of String, Object) For Each de As DictionaryEntry In hash nameValuePairs.Add(de.Key, de.Value) Next End Sub Public Sub New(ByVal o As Object) If o.GetType.Equals(GetType(Dictionary(Of String, Object))) Then nameValuePairs = o ElseIf o.GetType.Equals(GetType(SortedDictionary(Of String, Object))) Then Dim sd As SortedDictionary(Of String, Object) = o nameValuePairs = New Dictionary(Of String, Object) For Each kvp As KeyValuePair(Of String, Object) In sd '遍历元素 nameValuePairs.Add(kvp.Key, kvp.Value) Next ElseIf o.GetType.Equals(GetType(SortedList(Of String, Object))) Then Dim sl As SortedList(Of String, Object) = o For Each kvp As KeyValuePair(Of String, Object) In sl '遍历元素 nameValuePairs.Add(kvp.Key, kvp.Value) Next ElseIf o.GetType.Equals(GetType(Hashtable)) Then Dim hash As Hashtable = o nameValuePairs = New Dictionary(Of String, Object) For Each de As DictionaryEntry In hash nameValuePairs.Add(de.Key, de.Value) Next End If End Sub ''' <summary> ''' 使用标记器中下一个对象的名称/值映射创建一个新的<code>JSONTokener</code>。 ''' </summary> ''' <param name="readFrom"></param> ''' <remarks></remarks> Public Sub New(ByVal readFrom As JSONTokener) Dim obj As Object = readFrom.NextValue() If obj.GetType.Equals(GetType(JSONObject)) Then nameValuePairs = obj Else Throw JSON.typeMismatch(obj, "JSONObject") End If End Sub ''' <summary> ''' 使用JSON字符串中的名称/值映射创建一个新的<code>JSONTokener</code>。 ''' </summary> ''' <param name="js"></param> ''' <remarks></remarks> Public Sub New(ByVal js As String) Try Dim readFrom As JSONTokener = New JSONTokener(js) Dim obj As Object = readFrom.NextValue() If obj.GetType.Equals(GetType(JSONObject)) Then nameValuePairs = obj Else Throw JSON.typeMismatch(obj, "JSONObject") End If Catch ex As Exception nameValuePairs = New JavaScriptSerializer().DeserializeObject(js) End Try End Sub ''' <summary> ''' 通过从给定对象复制列出的名称的映射,创建一个新的<code>JSONObject</code>。将跳过<code>copyFrom</code>中不存在的名称。 ''' </summary> ''' <param name="copyFrom">要复制的JSONObject对象</param> ''' <param name="names">新的名称</param> ''' <remarks></remarks> Public Sub New(ByVal copyFrom As JSONObject, ByVal names() As String) Me.New() For Each name As String In names Dim val As Object = copyFrom.opt(name) If Not Microsoft.VisualBasic.IsNothing(val) Then nameValuePairs.Add(name, val) End If Next End Sub ' ''' <summary> ' ''' 返回此对象中名称/值映射的数目。 ' ''' </summary> ' ''' <returns></returns> ' ''' <remarks></remarks> 'Public Function length() As Integer ' Return nameValuePairs.Count() 'End Function ''' <summary> ''' 将指定值与此映射中的指定键相关联。如果映射以前包含键的映射,则替换旧值。 ''' </summary> ''' <param name="name">与指定值关联的键</param> ''' <param name="value">要与指定键关联的值</param> ''' <returns></returns> ''' <remarks></remarks> Public Function put(ByVal name As String, ByVal value As Boolean) As JSONObject If checkName(name) Then If nameValuePairs.ContainsKey(name) Then nameValuePairs.Item(name) = value 'Me.Item(name) = value Else nameValuePairs.Add(name, value) ' Me.Add(name, value) End If Return Me Else Return Me End If End Function ''' <summary> ''' 将指定值与此映射中的指定键相关联。如果映射以前包含键的映射,则替换旧值。 ''' </summary> ''' <param name="name">与指定值关联的键</param> ''' <param name="value">要与指定键关联的值</param> ''' <returns></returns> ''' <remarks></remarks> Public Function put(ByVal name As String, ByVal value As Byte) As JSONObject If checkName(name) Then If nameValuePairs.ContainsKey(name) Then nameValuePairs.Item(name) = value ' Me.Item(name) = value Else nameValuePairs.Add(name, value) 'Me.Add(name, value) End If Return Me Else Return Me End If End Function ''' <summary> ''' 将指定值与此映射中的指定键相关联。如果映射以前包含键的映射,则替换旧值。 ''' </summary> ''' <param name="name">与指定值关联的键</param> ''' <param name="value">要与指定键关联的值</param> ''' <returns></returns> ''' <remarks></remarks> Public Function put(ByVal name As String, ByVal value As Char) As JSONObject If checkName(name) Then If nameValuePairs.ContainsKey(name) Then nameValuePairs.Item(name) = value 'Me.Item(name) = value Else nameValuePairs.Add(name, value) ' Me.Add(name, value) End If Return Me Else Return Me End If End Function ''' <summary> ''' 将指定值与此映射中的指定键相关联。如果映射以前包含键的映射,则替换旧值。 ''' </summary> ''' <param name="name">与指定值关联的键</param> ''' <param name="value">要与指定键关联的值</param> ''' <returns></returns> ''' <remarks></remarks> Public Function put(ByVal name As String, ByVal value As Double) As JSONObject If checkName(name) Then If nameValuePairs.ContainsKey(name) Then nameValuePairs.Item(name) = value ' Me.Item(name) = value Else nameValuePairs.Add(name, value) 'Me.Add(name, value) End If Return Me Else Return Me End If End Function ''' <summary> ''' 将指定值与此映射中的指定键相关联。如果映射以前包含键的映射,则替换旧值。 ''' </summary> ''' <param name="name">与指定值关联的键</param> ''' <param name="value">要与指定键关联的值</param> ''' <returns></returns> ''' <remarks></remarks> Public Function put(ByVal name As String, ByVal value As Integer) As JSONObject If checkName(name) Then If nameValuePairs.ContainsKey(name) Then nameValuePairs.Item(name) = value 'Me.Item(name) = value Else nameValuePairs.Add(name, value) 'Me.Add(name, value) End If Return Me Else Return Me End If End Function ''' <summary> ''' 将指定值与此映射中的指定键相关联。如果映射以前包含键的映射,则替换旧值。 ''' </summary> ''' <param name="name">与指定值关联的键</param> ''' <param name="value">要与指定键关联的值</param> ''' <returns></returns> ''' <remarks></remarks> Public Function put(ByVal name As String, ByVal value As UInteger) As JSONObject If checkName(name) Then If nameValuePairs.ContainsKey(name) Then nameValuePairs.Item(name) = value 'Me.Item(name) = value Else nameValuePairs.Add(name, value) ' Me.Add(name, value) End If Return Me Else Return Me End If End Function ''' <summary> ''' 将指定值与此映射中的指定键相关联。如果映射以前包含键的映射,则替换旧值。 ''' </summary> ''' <param name="name">与指定值关联的键</param> ''' <param name="value">要与指定键关联的值</param> ''' <returns></returns> ''' <remarks></remarks> Public Function put(ByVal name As String, ByVal value As Long) As JSONObject If checkName(name) Then If nameValuePairs.ContainsKey(name) Then nameValuePairs.Item(name) = value 'Me.Item(name).Values(= value Else nameValuePairs.Add(name, value) ' Me.Add(name, value) End If Return Me Else Return Me End If End Function ''' <summary> ''' 将指定值与此映射中的指定键相关联。如果映射以前包含键的映射,则替换旧值。 ''' </summary> ''' <param name="name">与指定值关联的键</param> ''' <param name="value">要与指定键关联的值</param> ''' <returns></returns> ''' <remarks></remarks> Public Function put(ByVal name As String, ByVal value As ULong) As JSONObject If checkName(name) Then If nameValuePairs.ContainsKey(name) Then nameValuePairs.Item(name) = value ' Me.Item(name) = value Else nameValuePairs.Add(name, value) 'Me.Add(name, value) End If Return Me Else Return Me End If End Function ''' <summary> ''' 将指定值与此映射中的指定键相关联。如果映射以前包含键的映射,则替换旧值。 ''' </summary> ''' <param name="name">与指定值关联的键</param> ''' <param name="value">要与指定键关联的值</param> ''' <returns></returns> ''' <remarks></remarks> Public Function put(ByVal name As String, ByVal value As Short) As JSONObject If checkName(name) Then If nameValuePairs.ContainsKey(name) Then nameValuePairs.Item(name) = value 'Me.Item(name) = value Else nameValuePairs.Add(name, value) 'Me.Add(name, value) End If Return Me Else Return Me End If End Function ''' <summary> ''' 将指定值与此映射中的指定键相关联。如果映射以前包含键的映射,则替换旧值。 ''' </summary> ''' <param name="name">与指定值关联的键</param> ''' <param name="value">要与指定键关联的值</param> ''' <returns></returns> ''' <remarks></remarks> Public Function put(ByVal name As String, ByVal value As UShort) As JSONObject If checkName(name) Then If nameValuePairs.ContainsKey(name) Then nameValuePairs.Item(name) = value 'Me.Item(name) = value Else nameValuePairs.Add(name, value) 'Me.Add(name, value) End If Return Me Else Return Me End If End Function ''' <summary> ''' 将指定值与此映射中的指定键相关联。如果映射以前包含键的映射,则替换旧值。 ''' </summary> ''' <param name="name">与指定值关联的键</param> ''' <param name="value">要与指定键关联的值</param> ''' <returns></returns> ''' <remarks></remarks> Public Function put(ByVal name As String, ByVal value As Single) As JSONObject If checkName(name) Then If nameValuePairs.ContainsKey(name) Then nameValuePairs.Item(name) = value 'Me.Item(name) = value Else nameValuePairs.Add(name, value) 'Me.Add(name, value) End If Return Me Else Return Me End If End Function ''' <summary> ''' 将指定值与此映射中的指定键相关联。如果映射以前包含键的映射,则替换旧值。 ''' </summary> ''' <param name="name">与指定值关联的键</param> ''' <param name="value">要与指定键关联的值</param> ''' <returns></returns> ''' <remarks></remarks> Public Function put(ByVal name As String, ByVal value As Object) As JSONObject If value Is Nothing Then ' nameValuePairs.Remove(name) Return Me.Remove(name) 'Return Me End If If checkName(name) Then If nameValuePairs.ContainsKey(name) Then nameValuePairs.Item(name) = value ' Me.Item(name) = value Else nameValuePairs.Add(name, value) 'Me.Add(name, value) End If Return Me Else Return Me End If End Function ''' <summary> ''' 当两个参数都为非null时,等效于<code> put(name,value)</code>;否则不执行任何操作。 ''' </summary> ''' <param name="name"></param> ''' <param name="value"></param> ''' <returns></returns> ''' <remarks></remarks> Public Function putOpt(ByVal name As String, ByVal value As Object) As JSONObject If Microsoft.VisualBasic.IsNothing(name) Or Microsoft.VisualBasic.IsNothing(value) Then Return Me Else If name.Length = 0 Then Return Me End If End If Return put(name, value) End Function ''' <summary> ''' 将<code>value</code>追加到已映射到<code>name</code>的数组。 ''' 如果此对象没有<code>name</code>的映射,则会插入一个新映射。 ''' 如果映射存在,但其值不是数组,则按顺序将现有值和新值插入一个新数组,该数组本身映射到<code>name</code>。 ''' 总的来说,这允许一次向一个映射添加一个值。 ''' </summary> ''' <param name="name"></param> ''' <param name="value"></param> ''' <returns></returns> ''' <remarks></remarks> Public Function Accumulate(ByVal name As String, ByVal value As Object) As JSONObject Dim current As Object = nameValuePairs.Item(checkName(name)) If Microsoft.VisualBasic.IsNothing(current) Then Return put(name, value) End If If current.GetType.Equals(GetType(JSONArray)) Then Dim array As JSONArray = current array.CheckedPut(value) Else Dim array As JSONArray = New JSONArray() array.CheckedPut(current) array.CheckedPut(value) nameValuePairs.Add(name, array) End If Return Me End Function ''' <summary> ''' 将值附加到映射到<code>name</code>的数组。如果不存在映射,<code>name</code>的新<code>JSONArray</code>映射将被插入。 ''' 如果<code>name</code>的现有映射不是<code>JSONArray</code>,则将抛出<code>Exception</code> 。 ''' </summary> ''' <param name="name"></param> ''' <param name="value"></param> ''' <returns></returns> ''' <remarks></remarks> Public Function Append(ByVal name As String, ByVal value As Object) As JSONObject Dim current As Object = nameValuePairs.Item(checkName(name)) Dim array As JSONArray If current Is Nothing Then Dim newArray As JSONArray = New JSONArray() nameValuePairs.Add(name, newArray) array = newArray ElseIf current.GetType.Equals(GetType(JSONArray)) Then array = current Else Throw New Exception("Key " + name + " is not a JSONArray") End If array.CheckedPut(value) Return Me End Function ''' <summary> ''' 如果存在,则移除命名映射;否则不执行任何操作。 ''' </summary> ''' <param name="name"></param> ''' <returns></returns> ''' <remarks></remarks> Public Function Remove(ByVal name As String) As Object Dim val As Object = nameValuePairs.Item(name) nameValuePairs.Remove(name) Return val End Function ''' <summary> ''' 如果此对象没有{@code name}的映射或其值为{@link#NULL}的映射,则返回true。 ''' </summary> ''' <param name="name"></param> ''' <returns></returns> ''' <remarks></remarks> Public Function IsNothing(ByVal name As String) As Boolean Dim value As Object = nameValuePairs(name) Return IIf(Microsoft.VisualBasic.IsNothing(value), True, False) End Function ''' <summary> ''' 如果此对象具有{@code name}的映射,则返回true。映射可能是{@link#NULL}。 ''' </summary> ''' <param name="name"></param> ''' <returns></returns> ''' <remarks></remarks> Public Function has(ByVal name As String) As Boolean Return nameValuePairs.ContainsKey(name) End Function ''' <summary> ''' 返回由{@code name}映射的值,如果不存在这样的映射,则抛出。 ''' </summary> ''' <param name="name"></param> ''' <returns></returns> ''' <remarks></remarks> Public Function getItem(name As String) As Object Dim result As Object = nameValuePairs.Item(name) If result Is Nothing Then Throw New Exception("No value for " + name) End If Return result End Function ' Public Shared Function numberToString() ''' <summary> ''' 返回由{@code name}映射的值,如果不存在此类映射,则返回nothing。 ''' </summary> ''' <param name="name"></param> ''' <returns></returns> ''' <remarks></remarks> Public Function opt(name As String) As Object Return nameValuePairs.Item(name) End Function ''' <summary> ''' 返回由{@code name}映射的值(如果该值存在并且是布尔值,或者可以强制为布尔值,或者抛出其他值)。 ''' </summary> ''' <param name="name"></param> ''' <returns></returns> ''' <remarks></remarks> Public Function getBoolean(ByVal name As String) As Boolean Dim val As Object = getItem(name) Dim result As Boolean = JSON.toBoolean(val) If Microsoft.VisualBasic.IsNothing(result) Then Throw JSON.typeMismatch(name, val, "boolean") End If Return result End Function ''' <summary> ''' 返回由{@code name}映射的值(如果该值存在并且是布尔值或可以强制为布尔值),否则返回{@code fallback}。 ''' </summary> ''' <param name="name"></param> ''' <param name="defaultVal"></param> ''' <returns></returns> ''' <remarks></remarks> Public Function optBoolean(ByVal name As String, Optional ByVal defaultVal As Boolean = False) As Boolean Dim val As Object = getItem(name) Dim result As Boolean = JSON.toBoolean(val) If Microsoft.VisualBasic.IsNothing(result) Then Return defaultVal Else Return val End If End Function ''' <summary> ''' 返回由{@code name}映射的值(如果该值存在并且是Byte值,或者可以强制为Byte值,或者抛出其他值)。 ''' </summary> ''' <param name="name"></param> ''' <returns></returns> ''' <remarks></remarks> Public Function getByte(ByVal name As String) As Byte Dim val As Object = getItem(name) Dim result As Byte = JSON.toByte(val) If Microsoft.VisualBasic.IsNothing(result) Then Throw JSON.typeMismatch(name, val, "Byte") End If Return result End Function ''' <summary> ''' 返回由{@code name}映射的值(如果该值存在并且是布尔值或可以强制为Byte值),否则返回{@code defaultVal}。 ''' </summary> ''' <param name="name"></param> ''' <param name="defaultVal"></param> ''' <returns></returns> ''' <remarks></remarks> Public Function optByte(ByVal name As String, Optional ByVal defaultVal As Byte = 0) As Byte Dim val As Object = getItem(name) Dim result As Byte = JSON.toByte(val) If Microsoft.VisualBasic.IsNothing(result) Then Return defaultVal Else Return val End If End Function ''' <summary> ''' 返回由{@code name}映射的值(如果该值存在并且是SByte值,或者可以强制为SByte值,或者抛出其他值)。 ''' </summary> ''' <param name="name"></param> ''' <returns></returns> ''' <remarks></remarks> Public Function getSByte(ByVal name As String) As SByte Dim val As Object = getItem(name) Dim result As SByte = JSON.toSByte(val) If Microsoft.VisualBasic.IsNothing(result) Then Throw JSON.typeMismatch(name, val, "SByte") End If Return result End Function ''' <summary> ''' 返回由{@code name}映射的值(如果该值存在并且是布尔值或可以强制为SByte值),否则返回{@code defaultVal}。 ''' </summary> ''' <param name="name"></param> ''' <param name="defaultVal"></param> ''' <returns></returns> ''' <remarks></remarks> Public Function optSByte(ByVal name As String, Optional ByVal defaultVal As SByte = 0) As SByte Dim val As Object = getItem(name) Dim result As SByte = JSON.toSByte(val) If Microsoft.VisualBasic.IsNothing(result) Then Return defaultVal Else Return val End If End Function ''' <summary> ''' 返回由{@code name}映射的值(如果该值存在并且是Short值,或者可以强制为Short值,或者抛出其他值)。 ''' </summary> ''' <param name="name"></param> ''' <returns></returns> ''' <remarks></remarks> Public Function getShort(ByVal name As String) As Short Dim val As Object = getItem(name) Dim result As Short = JSON.toShort(val) If Microsoft.VisualBasic.IsNothing(result) Then Throw JSON.typeMismatch(name, val, "Short") End If Return result End Function ''' <summary> ''' 返回由{@code name}映射的值(如果该值存在并且是布尔值或可以强制为Short值),否则返回{@code defaultVal}。 ''' </summary> ''' <param name="name"></param> ''' <param name="defaultVal"></param> ''' <returns></returns> ''' <remarks></remarks> Public Function optShort(ByVal name As String, Optional ByVal defaultVal As Short = 0) As Short Dim val As Object = getItem(name) Dim result As Short = JSON.toShort(val) If Microsoft.VisualBasic.IsNothing(result) Then Return defaultVal Else Return val End If End Function ''' <summary> ''' 返回由{@code name}映射的值(如果该值存在并且是UShort值,或者可以强制为UShort值,或者抛出其他值)。 ''' </summary> ''' <param name="name"></param> ''' <returns></returns> ''' <remarks></remarks> Public Function getUShort(ByVal name As String) As UShort Dim val As Object = getItem(name) Dim result As UShort = JSON.toUShort(val) If Microsoft.VisualBasic.IsNothing(result) Then Throw JSON.typeMismatch(name, val, "UShort") End If Return result End Function ''' <summary> ''' 返回由{@code name}映射的值(如果该值存在并且是布尔值或可以强制为UShort值),否则返回{@code defaultVal}。 ''' </summary> ''' <param name="name"></param> ''' <param name="defaultVal"></param> ''' <returns></returns> ''' <remarks></remarks> Public Function optUShort(ByVal name As String, Optional ByVal defaultVal As UShort = 0) As UShort Dim val As Object = getItem(name) Dim result As UShort = JSON.toUShort(val) If Microsoft.VisualBasic.IsNothing(result) Then Return defaultVal Else Return val End If End Function ''' <summary> ''' 返回由{@code name}映射的值(如果该值存在并且是Char值,或者可以强制为Char值,或者抛出其他值)。 ''' </summary> ''' <param name="name"></param> ''' <returns></returns> ''' <remarks></remarks> Public Function getChar(ByVal name As String) As Char Dim val As Object = getItem(name) Dim result As Char = JSON.toChar(val) If Microsoft.VisualBasic.IsNothing(result) Then Throw JSON.typeMismatch(name, val, "Char") End If Return result End Function ''' <summary> ''' 返回由{@code name}映射的值(如果该值存在并且是布尔值或可以强制为Char值),否则返回{@code defaultVal}。 ''' </summary> ''' <param name="name"></param> ''' <param name="defaultVal"></param> ''' <returns></returns> ''' <remarks></remarks> Public Function optChar(ByVal name As String, Optional ByVal defaultVal As Char = Chr(0)) As Char Dim val As Object = getItem(name) Dim result As Char = JSON.toChar(val) If Microsoft.VisualBasic.IsNothing(result) Then Return defaultVal Else Return val End If End Function ''' <summary> ''' 返回由{@code name}映射的值(如果该值存在并且是Integer值,或者可以强制为Integer值,或者抛出其他值)。 ''' </summary> ''' <param name="name"></param> ''' <returns></returns> ''' <remarks></remarks> Public Function getInteger(ByVal name As String) As Integer Dim val As Object = getItem(name) Dim result As Integer = JSON.toInteger(val) If Microsoft.VisualBasic.IsNothing(result) Then Throw JSON.typeMismatch(name, val, "UShort") End If Return result End Function ''' <summary> ''' 返回由{@code name}映射的值(如果该值存在并且是布尔值或可以强制为Integer值),否则返回{@code defaultVal}。 ''' </summary> ''' <param name="name"></param> ''' <param name="defaultVal"></param> ''' <returns></returns> ''' <remarks></remarks> Public Function optInteger(ByVal name As String, Optional ByVal defaultVal As Integer = 0) As Integer Dim val As Object = getItem(name) Dim result As Integer = JSON.toInteger(val) If Microsoft.VisualBasic.IsNothing(result) Then Return defaultVal Else Return val End If End Function ''' <summary> ''' 返回由{@code name}映射的值(如果该值存在并且是UInteger值,或者可以强制为UInteger值,或者抛出其他值)。 ''' </summary> ''' <param name="name"></param> ''' <returns></returns> ''' <remarks></remarks> Public Function getUInteger(ByVal name As String) As UInteger Dim val As Object = getItem(name) Dim result As UInteger = JSON.toUInteger(val) If Microsoft.VisualBasic.IsNothing(result) Then Throw JSON.typeMismatch(name, val, "UInteger") End If Return result End Function ''' <summary> ''' 返回由{@code name}映射的值(如果该值存在并且是布尔值或可以强制为UInteger值),否则返回{@code defaultVal}。 ''' </summary> ''' <param name="name"></param> ''' <param name="defaultVal"></param> ''' <returns></returns> ''' <remarks></remarks> Public Function optUInteger(ByVal name As String, Optional ByVal defaultVal As UInteger = 0) As UInteger Dim val As Object = getItem(name) Dim result As UInteger = JSON.toUInteger(val) If Microsoft.VisualBasic.IsNothing(result) Then Return defaultVal Else Return val End If End Function ''' <summary> ''' 返回由{@code name}映射的值(如果该值存在并且是Long值,或者可以强制为Long值,或者抛出其他值)。 ''' </summary> ''' <param name="name"></param> ''' <returns></returns> ''' <remarks></remarks> Public Function getLong(ByVal name As String) As Long Dim val As Object = getItem(name) Dim result As Long = JSON.toLong(val) If Microsoft.VisualBasic.IsNothing(result) Then Throw JSON.typeMismatch(name, val, "Long") End If Return result End Function ''' <summary> ''' 返回由{@code name}映射的值(如果该值存在并且是布尔值或可以强制为Long值),否则返回{@code defaultVal}。 ''' </summary> ''' <param name="name"></param> ''' <param name="defaultVal"></param> ''' <returns></returns> ''' <remarks></remarks> Public Function optLong(ByVal name As String, Optional ByVal defaultVal As Long = 0) As Long Dim val As Object = getItem(name) Dim result As Long = JSON.toLong(val) If Microsoft.VisualBasic.IsNothing(result) Then Return defaultVal Else Return val End If End Function ''' <summary> ''' 返回由{@code name}映射的值(如果该值存在并且是ULong值,或者可以强制为ULong值,或者抛出其他值)。 ''' </summary> ''' <param name="name"></param> ''' <returns></returns> ''' <remarks></remarks> Public Function getULong(ByVal name As String) As ULong Dim val As Object = getItem(name) Dim result As ULong = JSON.toULong(val) If Microsoft.VisualBasic.IsNothing(result) Then Throw JSON.typeMismatch(name, val, "ULong") End If Return result End Function ''' <summary> ''' 返回由{@code name}映射的值(如果该值存在并且是布尔值或可以强制为ULong值),否则返回{@code defaultVal}。 ''' </summary> ''' <param name="name"></param> ''' <param name="defaultVal"></param> ''' <returns></returns> ''' <remarks></remarks> Public Function optULong(ByVal name As String, Optional ByVal defaultVal As ULong = 0) As ULong Dim val As Object = getItem(name) Dim result As ULong = JSON.toULong(val) If Microsoft.VisualBasic.IsNothing(result) Then Return defaultVal Else Return val End If End Function ''' <summary> ''' 返回由{@code name}映射的值(如果该值存在并且是Single值,或者可以强制为Single值,或者抛出其他值)。 ''' </summary> ''' <param name="name"></param> ''' <returns></returns> ''' <remarks></remarks> Public Function getSingle(ByVal name As String) As Single Dim val As Object = getItem(name) Dim result As Single = JSON.toSingle(val) If Microsoft.VisualBasic.IsNothing(result) Then Throw JSON.typeMismatch(name, val, "Single") End If Return result End Function ''' <summary> ''' 返回由{@code name}映射的值(如果该值存在并且是布尔值或可以强制为Single值),否则返回{@code defaultVal}。 ''' </summary> ''' <param name="name"></param> ''' <param name="defaultVal"></param> ''' <returns></returns> ''' <remarks></remarks> Public Function optSingle(ByVal name As String, Optional ByVal defaultVal As Single = 0) As Single Dim val As Object = getItem(name) Dim result As Single = JSON.toSingle(val) If Microsoft.VisualBasic.IsNothing(result) Then Return defaultVal Else Return val End If End Function ''' <summary> ''' 返回由{@code name}映射的值(如果该值存在并且是Double值,或者可以强制为Double值,或者抛出其他值)。 ''' </summary> ''' <param name="name"></param> ''' <returns></returns> ''' <remarks></remarks> Public Function getDouble(ByVal name As String) As Double Dim val As Object = getItem(name) Dim result As Double = JSON.toDouble(val) If Microsoft.VisualBasic.IsNothing(result) Then Throw JSON.typeMismatch(name, val, "Double") End If Return result End Function ''' <summary> ''' 返回由{@code name}映射的值(如果该值存在并且是布尔值或可以强制为Double值),否则返回{@code defaultVal}。 ''' </summary> ''' <param name="name"></param> ''' <param name="defaultVal"></param> ''' <returns></returns> ''' <remarks></remarks> Public Function optDouble(ByVal name As String, Optional ByVal defaultVal As Double = 0) As Double Dim val As Object = getItem(name) Dim result As Double = JSON.toDouble(val) If Microsoft.VisualBasic.IsNothing(result) Then Return defaultVal Else Return val End If End Function ''' <summary> ''' 返回由{@code name}映射的值(如果该值存在并且是String值,或者可以强制为String值,或者抛出其他值)。 ''' </summary> ''' <param name="name"></param> ''' <returns></returns> ''' <remarks></remarks> Public Function getString(ByVal name As String) As String Dim val As Object = getItem(name) Dim result As String = JSON.ToString(val) If Microsoft.VisualBasic.IsNothing(result) Then Throw JSON.typeMismatch(name, val, "String") End If Return result End Function ''' <summary> ''' 返回由{@code name}映射的值(如果该值存在并且是布尔值或可以强制为String值),否则返回{@code defaultVal}。 ''' </summary> ''' <param name="name"></param> ''' <param name="defaultVal"></param> ''' <returns></returns> ''' <remarks></remarks> Public Function optString(ByVal name As String, Optional ByVal defaultVal As String = Nothing) As String Dim val As Object = getItem(name) Dim result As String = JSON.ToString(val) If Microsoft.VisualBasic.IsNothing(result) Then Return defaultVal Else Return val End If End Function ''' <summary> ''' 返回由{@code name}映射的值(如果它存在并且是{@code JSONArray}),否则抛出。 ''' </summary> ''' <param name="name"></param> ''' <returns></returns> ''' <remarks></remarks> Public Function getJSONArray(ByVal name As String) As JSONArray Dim val As Object = getItem(name) If val.GetType.Equals(GetType(JSONArray)) Then Return val ElseIf IsArray(val) Or val.GetType.Equals(GetType(ArrayList)) Or val.GetType.Equals(GetType(IList(Of Object))) Or val.GetType.Equals(GetType(List(Of Object))) Then Return New JSONArray(val) Else Throw JSON.typeMismatch(name, val, "JSONArray") End If End Function ''' <summary> ''' 返回由{@code name}映射的值(如果该值存在并且是{@code JSONArray}),否则返回nothing。 ''' </summary> ''' <param name="name"></param> ''' <returns></returns> ''' <remarks></remarks> Public Function optJSONArray(ByVal name As String) As JSONArray Dim val As Object = getItem(name) If val.GetType.Equals(GetType(JSONArray)) Then Return val ElseIf IsArray(val) Or val.GetType.Equals(GetType(ArrayList)) Or val.GetType.Equals(GetType(IList(Of Object))) Or val.GetType.Equals(GetType(List(Of Object))) Then Return New JSONArray(val) Else Return Nothing End If End Function ''' <summary> ''' 返回由{@code name}处的值(如果该值存在并且是或者强制转换为<code>JSONObject</code>),否则抛出。 ''' </summary> ''' <param name="name"></param> ''' <returns></returns> ''' <remarks></remarks> Public Function getJSONObject(ByVal name As String) As JSONObject Dim val As Object = getItem(name) If val.GetType.Equals(GetType(JSONObject)) Then Return val ElseIf val.GetType.Equals(GetType(Dictionary(Of String, Object))) Then Dim d As Dictionary(Of String, Object) = val Return New JSONObject(d) ElseIf val.GetType.Equals(GetType(SortedDictionary(Of String, Object))) Then Dim sd As SortedDictionary(Of String, Object) = val Dim d As Dictionary(Of String, Object) = New Dictionary(Of String, Object) For Each kvp As KeyValuePair(Of String, Object) In sd '遍历元素 d.Add(kvp.Key, kvp.Value) Next Return New JSONObject(d) ElseIf val.GetType.Equals(GetType(String)) Then Return New JSONObject(CStr(val)) Else Throw JSON.typeMismatch(name, val, "JSONObject") End If End Function ''' <summary> ''' 返回<code>name</code>处的值(如果该值存在并且是或可以强制为<code>JSONObject</code>)。否则返回Nothing。 ''' </summary> ''' <param name="name"></param> ''' <returns></returns> ''' <remarks></remarks> Public Function optJSONObject(ByVal name As String) As JSONObject Dim val As Object = getItem(name) Try If val.GetType.Equals(GetType(JSONObject)) Then Return val ElseIf val.GetType.Equals(GetType(Dictionary(Of String, Object))) Then Dim d As Dictionary(Of String, Object) = val Return New JSONObject(d) ElseIf val.GetType.Equals(GetType(SortedDictionary(Of String, Object))) Then Dim sd As SortedDictionary(Of String, Object) = val Dim d As Dictionary(Of String, Object) = New Dictionary(Of String, Object) For Each kvp As KeyValuePair(Of String, Object) In sd '遍历元素 d.Add(kvp.Key, kvp.Value) Next Return New JSONObject(d) ElseIf val.GetType.Equals(GetType(String)) Then Return New JSONObject(CStr(val)) Else Return Nothing End If Catch ex As Exception Return Nothing End Try End Function ''' <summary> ''' 返回值与{@code names}对应的数组。对于未映射的名称,数组包含null。如果{@code names}为null或空,则此方法返回null。 ''' </summary> ''' <param name="names"></param> ''' <returns></returns> ''' <remarks></remarks> Public Function toJSONArray(ByVal names As JSONArray) As JSONArray Dim result As JSONArray = New JSONArray() If names Is Nothing Then Return Nothing End If If names.Count = 0 Then Return Nothing End If For i As Integer = 0 To names.Count - 1 Dim name As String = JSON.ToString(names.Opt(i)) result.Put(opt(name)) Next Return result End Function ''' <summary> ''' 将此对象编码为压缩JSON字符串,例如: ''' {"query":"Pizza","locations":[94043,90210]} ''' </summary> ''' <returns></returns> ''' <remarks></remarks> Public Overloads Function toString() As String Try Dim stringer As JSONStringer = New JSONStringer() writeTo(stringer) Return stringer.toString() Catch ex As Exception Return Nothing End Try End Function ''' <summary> ''' 将此数组编码为用于调试的可读JSON字符串,例如:[94043, 90210] ''' </summary> ''' <param name="indentSpaces">嵌套的每个级别缩进的空格数。</param> ''' <returns></returns> ''' <remarks></remarks> Public Overloads Function toString(ByVal indentSpaces As Integer) As String Dim stringer As JSONStringer = New JSONStringer(indentSpaces) writeTo(stringer) Return stringer.toString() End Function ''' <summary> ''' 检测键名是否有效 ''' </summary> ''' <param name="name"></param> ''' <returns></returns> ''' <remarks></remarks> Friend Function checkName(ByVal name As String) As Boolean Dim isNotNull As Boolean = False If Not Microsoft.VisualBasic.IsNothing(name) Then If name.Length > 0 Then isNotNull = True End If End If Return isNotNull End Function Friend Sub writeTo(stringer As JSONStringer) stringer.startObject() For Each entry In nameValuePairs stringer.key(entry.Key).value(entry.Value) Next stringer.endObject() End Sub ''' <summary> ''' 将数字编码为JSON字符串。 ''' </summary> ''' <param name="number"></param> ''' <returns></returns> ''' <remarks></remarks> Public Shared Function numberToString(ByVal number As Object) As String If number Is Nothing Then Throw New Exception("Number must be non-null") End If Dim doubleValue As Double = CDbl(number) If number.Equals(NEGATIVE_ZERO) Then Return "-0" End If Dim longValue As Long = CLng(number) If doubleValue = CDbl(longValue) Then Return longValue.ToString End If Return number.ToString() End Function ''' <summary> ''' 将{@code data}编码为JSON字符串。这将应用引号和任何必要的字符转义。 ''' </summary> ''' <param name="data">要编码的字符串。Nothing将被解释为空</param> ''' <returns></returns> ''' <remarks></remarks> Public Shared Function quote(ByVal data As String) As String If data Is Nothing Then Return """""" '返回两个双引号 End If Try Dim stringer As JSONStringer = New JSONStringer() stringer.open(JSONStringer.Scope.NULL, "") stringer.value(data) stringer.close(JSONStringer.Scope.NULL, JSONStringer.Scope.NULL, "") Return stringer.toString() Catch ex As Exception Throw New Exception(ex.Message) End Try End Function ''' <summary> ''' 如有必要,包装给定对象。 ''' 如果对象是<code>JSONArray</code>或<code>JSONObject</code>,则不需要包装。 ''' 如果对象是<code>Array</code>、<code>ArrayList</code>或<code>List(Of Object)</code>,则返回等效的<code>JSONArray</code>。 ''' 如果对象是原始包装类型或<code>String</code>,则返回对象。 ''' </summary> ''' <param name="o"></param> ''' <returns>如果包装失败,则返回Nothing。</returns> ''' <remarks></remarks> Public Shared Function wrap(ByVal o As Object) As Object If o Is Nothing Then Return "null" End If If o.GetType.Equals(GetType(JSONArray)) Or o.GetType.Equals(GetType(JSONObject)) Then Return o End If Try If o.GetType.Equals(GetType(ArrayList)) Then Dim aList As ArrayList = o Return New JSONArray(aList) ElseIf o.GetType.Equals(GetType(Array)) Then Dim a As Array = o Return New JSONArray(a) ElseIf o.GetType.Equals(GetType(List(Of Object))) Then Dim l As List(Of Object) = o Return New JSONArray(l) ElseIf o.GetType.Equals(GetType(HashSet(Of Object))) Then Dim l As HashSet(Of Object) = o Return New JSONArray(l) ElseIf o.GetType.Equals(GetType(SortedSet(Of Object))) Then Dim l As SortedSet(Of Object) = o Return New JSONArray(l) ElseIf o.GetType.Equals(GetType(Boolean)) Or o.GetType.Equals(GetType(Byte)) Or _ o.GetType.Equals(GetType(SByte)) Or o.GetType.Equals(GetType(Short)) Or _ o.GetType.Equals(GetType(UShort)) Or o.GetType.Equals(GetType(Integer)) Or _ o.GetType.Equals(GetType(UInteger)) Or o.GetType.Equals(GetType(Long)) Or _ o.GetType.Equals(GetType(ULong)) Or o.GetType.Equals(GetType(Single)) Or _ o.GetType.Equals(GetType(Double)) Or o.GetType.Equals(GetType(Char)) Or _ o.GetType.Equals(GetType(String)) Then Return o End If Catch ex As Exception End Try Return Nothing End Function ''''''''''''''''''''''''''''''''''''接口实现属性及方法'''''''''''''''''''''''''''''''''''''''' '''''''''''''''属性''''''''''''''''''' ''' <summary> ''' 返回列表长度 ''' </summary> ''' <value></value> ''' <returns></returns> ''' <remarks></remarks> Public ReadOnly Property Count() As Integer Get Return nameValuePairs.Count End Get End Property ''' <summary> ''' 返回包含此对象中的字符串名称的数组。 ''' </summary> ''' <value></value> ''' <returns></returns> ''' <remarks></remarks> Public ReadOnly Property NamesAt() As Dictionary(Of String, Object).KeyCollection Get Return nameValuePairs.Keys() End Get End Property ''' <summary> ''' 返回包含此对象中的字符串名称的数组。如果此对象不包含映射,则此方法返回Nothing。 ''' </summary> ''' <returns></returns> ''' <remarks></remarks> Public ReadOnly Property Names() As JSONArray Get If nameValuePairs Is Nothing Then Return Nothing Else Dim arr As Array = nameValuePairs.Keys().ToArray Return New JSONArray(arr) End If End Get End Property Public ReadOnly Property IsReadOnly As Boolean Get Return False End Get End Property Public ReadOnly Property Values As ICollection(Of Object) Get Return nameValuePairs.Values End Get End Property Public Function Contains(ByVal k As KeyValuePair(Of String, Object)) As Boolean Return nameValuePairs.Contains(k) End Function Public Sub Clear() nameValuePairs.Clear() End Sub Public Sub CopyTo(array() As KeyValuePair(Of String, Object), arrayIndex As Integer) If array Is Nothing Then Throw New ArgumentNullException("The array cannot be null.") ElseIf arrayIndex < 0 Then Throw New ArgumentOutOfRangeException("The starting array index cannot be negative.") ElseIf Count > array.Length - arrayIndex + 1 Then Throw New ArgumentException("The destination array has fewer elements than the collection.") End If Dim keyList As List(Of KeyValuePair(Of String, Object)) = nameValuePairs.ToList For i As Integer = 0 To nameValuePairs.Count - 1 ' Dim key As String = nameValuePairs. array(i + arrayIndex) = keyList.Item(i) Next End Sub End Class
其中的Public Sub New(ByVal js As String)中使用了一个第三方类JavaScriptSerializer,主要是防止自己写的解析类出而做的备选,其实是可以不用的,代码如下:
Public Sub New(ByVal js As String) Try Dim readFrom As JSONTokener = New JSONTokener(js) Dim obj As Object = readFrom.NextValue() If obj.GetType.Equals(GetType(JSONObject)) Then nameValuePairs = obj Else Throw JSON.typeMismatch(obj, "JSONObject") End If Catch ex As Exception nameValuePairs = New JavaScriptSerializer().DeserializeObject(js) End Try End Sub
测试代码如下:
Private Sub test() Dim s As String = "{""UserName"":""admin"",""Pwd"":{""as"":""df"",""va"":""gh""},""ID"":1234,""Array"":[{""a"":""dc"",""b"":""ca""},{""a"":""gf"",""b"":""ta""}]}" dim jsonObj as JSONObject=new JSONObject(s) end sub
这里提供的方式只是个人的摸索,肯定不是正常的方法。由于vb实在缺例子,学习正经的json读写方法有点花时间,而且我也不是专业写程序的,所以秉着“速度要紧,能用就好”宗旨,决定自写json的解析。
======正文=====
对于json文件的解析,我的思路是:
1.字符串去格式化,将无意义的字符去掉(空格、换行等)
2.将字符串对象化,生成为三个数组(因为对类模块使用不熟练,所以用了一个非常土的方法),第一个是Key的名字集合,第二个是数值的集合,第三个是数值类型的集合。
3.能将对象化后的数据,进行修改/添加/删除的操作。
4.将json对象转换为json字符串。
5.将json字符串格式化,转换为便于阅读的格式。
=====数组函数============
Class Arr Function Cut(ArrayObject, Index) '将指定位置的元素cong Dim ArrCount, OArr(), i, ci ArrCount = UBound(ArrayObject) If ArrCount = 0 Then Cut = Reset() Exit Function End If ReDim OArr(ArrCount - 1) ci = 0 For i = 0 To ArrCount If Index <> i Then OArr(ci) = ArrayObject(i) ci = ci + 1 End If Next Cut = OArr End Function Function Reset() '将变量初始化为数组 Dim arr(0) arr(0) = "***Arr*initial***" Reset = arr End Function Function Add(ArrayObject, item) Dim ArrCount, OArr(), i If TypeName(ArrayObject(0)) = "String" Then If ArrayObject(0) = "***Arr*initial***" Then ReDim OArr(0) OArr(0) = item Else ArrCount = UBound(ArrayObject) ReDim OArr(ArrCount + 1) For i = 0 To ArrCount OArr(i) = ArrayObject(i) Next OArr(ArrCount + 1) = item End If Else ArrCount = UBound(ArrayObject) ReDim OArr(ArrCount + 1) For i = 0 To ArrCount OArr(i) = ArrayObject(i) Next OArr(ArrCount + 1) = item End If Add = OArr End Function Function IsExistInArray(ArrayObject, MatchingValue) '判断数组中是否存在某一元素 Dim i Dim RB As Boolean RB = False For i = 0 To UBound(ArrayObject) If MatchingValue = ArrayObject(i) Then RB = True Exit For End If Next IsExistInArray = RB End Function Function GetIndex(ArrayObject, MatchingValue) '返回元素所在的位置 Dim i Dim RB, IndexArr IndexArr = Reset() For i = 0 To UBound(ArrayObject) If MatchingValue = ArrayObject(i) Then IndexArr = i Exit For End If Next GetIndex = IndexArr End Function Function GetIndexs(ArrayObject, MatchingValue) '返回元素所在的位置(数组) Dim i Dim RB, IndexArr IndexArr = Reset() For i = 0 To UBound(ArrayObject) If MatchingValue = ArrayObject(i) Then IndexArr = Add(IndexArr, i) End If Next GetIndexs = IndexArr End Function End Class
======读写文件函数====
======json========Class text Sub swrite(filename, content) Dim stream stream = CreateObject("Adodb.Stream") stream.Open stream.Type = 2 '"adTypeText" stream.Charset = "utf-8" stream.WriteText(content) '移除前三个字节(0xEF,0xBB,0xBF) stream.Position = 3 Dim newStream newStream = CreateObject("Adodb.Stream") newStream.Type = 1 '"adTypeBinary" newStream.Mode = 3 '"adModeReadWrite" newStream.Open stream.CopyTo(newStream) stream.Flush stream.Close newStream.SaveToFile(filename, 2) '"adSaveCreateOverWrite" newStream.Flush newStream.Close End Sub Function sread(Path) Dim stm stm = CreateObject("Adodb.Stream") stm.Type = 2 stm.Mode = 3 stm.Charset = "UTF-8" stm.Open stm.LoadFromFile(Path) sread = stm.ReadText() stm.close() 'stm = Nothing End Function Function Read(filePath As String) Dim txt As StreamReader Dim st As String, isComment As Boolean = False Dim isMutiLineComment As Boolean = False Dim isInString As Boolean = False txt = New StreamReader(filePath) st = txt.ReadToEnd Read = st txt.Close() End Function Sub save(path As String, str As String) Using logObject As System.IO.StreamWriter = New System.IO.StreamWriter(path) logObject.Write(str) logObject.Close() End Using End Sub End Class
========调用例子========Class json Dim arr As New Arr Function jsStrToRead(jsStr) '将json字符串转换为便于阅读的格式 Dim thisChar As Char Dim NodeCount As Int64 = 0 Dim isInString As Boolean = False Dim ns = "" For Each thisChar In jsStr Select Case thisChar Case "{" ns = ns & thisChar & Chr(13) NodeCount = NodeCount + 1 ns = ns & writeBlank(NodeCount) Case "}" NodeCount = NodeCount - 1 ns = ns & Chr(13) & writeBlank(NodeCount) & thisChar Case "[" NodeCount = NodeCount + 1 ns = ns & thisChar & Chr(13) & writeBlank(NodeCount) Case "]" NodeCount = NodeCount - 1 ns = ns & Chr(13) & writeBlank(NodeCount) & thisChar Case "," If isInString = False Then ns = ns & thisChar & Chr(13) & writeBlank(NodeCount) Else ns = ns & thisChar End If Case ":" If isInString = False Then ns = ns & " " & thisChar & " " Else ns = ns & thisChar End If Case """" isInString = Not isInString ns = ns & thisChar Case Else ns = ns & thisChar End Select 'Stop Next Return ns End Function Function writeBlank(nodecount) '根据层数,返回用于首行缩进的字符串 Dim s = "" For i = 1 To nodecount s = s & Chr(9) Next 'Stop Return s End Function Function jsObjectToStr(JsObject) '将json对象转换为json字符串 Dim ItemKey, ItemVal, ItemType, ValSt, NameSt Dim jst As String = "{" For i = 0 To UBound(JsObject(0)) ItemKey = JsObject(0)(i) ItemVal = JsObject(1)(i) ItemType = JsObject(2)(i) ValSt = "" Select Case ItemType Case "string" ValSt = """" & ItemVal & """" Case "value" ValSt = ItemVal Case "array_Str" ValSt = "[" For j = 0 To UBound(ItemVal) ValSt = ValSt & """" & ItemVal(j) & """" & "," Next ValSt = Left(ValSt, Len(ValSt) - 1) & "]" Case "array_Val" ValSt = "[" For j = 0 To UBound(ItemVal) ValSt = ValSt & ItemVal(j) & "," Next ValSt = Left(ValSt, Len(ValSt) - 1) & "]" Case "object" ValSt = ItemVal End Select NameSt = """" & ItemKey & """" jst = jst & NameSt & ":" & ValSt & "," Next jst = Left(jst, Len(jst) - 1) & "}" Return jst End Function Function setValue(jsObject, KeyName, NewValue, NewType) '输入Key的名称,并修改对于的数值 Dim jsName, njsObject njsObject = jsObject For i = 0 To UBound(njsObject(0)) jsName = njsObject(0)(i) If jsName = KeyName Then njsObject(1)(i) = NewValue If NewType <> "" Then njsObject(2)(i) = NewType End If Exit For End If Next Return njsObject End Function Function Formate(st) '去掉json字符串中的空格/换行符等无意义的字符 Dim thisChar As Char Dim isInString As Boolean = False Dim nst = "" For Each thisChar In st Select Case thisChar Case " " If isInString = True Then nst = nst & thisChar End If Case Chr(13) Case Chr(10) Case Chr(9) Case """" isInString = Not isInString nst = nst & thisChar Case Else nst = nst & thisChar End Select Next Return nst End Function Function GetValueType(jsValue) '获取一个json字符中,值的类型 Dim firstChar, SecondChar, tt firstChar = Mid(jsValue, 1, 1) SecondChar = Mid(jsValue, 2, 1) If firstChar = """" Then tt = "string" ElseIf IsNumeric(jsValue) = True tt = "value" ElseIf firstChar = "[" Then If SecondChar = """" Then tt = "array_Str" Else tt = "array_Val" End If ElseIf firstChar = "{" Then tt = "object" Else tt = "error" End If GetValueType = tt End Function Function GetJsKeyValue(jsonObject) Dim thisChar Dim mmp = 0 Dim isInstring As Boolean = False For i = 1 To Len(jsonObject) thisChar = Mid(jsonObject, i, 1) Select Case thisChar Case """" isInstring = Not isInstring Case ":" If isInstring = False Then mmp = i Exit For End If End Select Next Dim keyValue keyValue = Mid(jsonObject, mmp + 1, Len(jsonObject) - mmp) Return keyValue End Function Function GetJsKeyName(jsonObject) '获取key的名字 Dim thisChar Dim mmp = 0 Dim isInstring As Boolean = False For i = 1 To Len(jsonObject) thisChar = Mid(jsonObject, i, 1) Select Case thisChar Case """" isInstring = Not isInstring Case ":" If isInstring = False Then MMP = i Exit For End If End Select Next Dim keyname keyname = Mid(jsonObject, 2, mmp - 3) Return keyname End Function Function GetJsValueByName(jsObject, KeyName) Dim v v = "" For i = 0 To UBound(jsObject(0)) If KeyName = jsObject(0)(i) Then v = jsObject(1)(i) Exit For End If Next Return v End Function Function GetJsItemObjectArr(jsonValue) Dim njsVal = Formate(jsonValue) Dim thisChar As Char Dim NodeCount As Int64 = 0 Dim isInString As Boolean = False Dim SplitPositon, jsObject SplitPositon = arr.Reset() jsObject = arr.Reset() SplitPositon = arr.Add(SplitPositon, 1) For i = 1 To Len(njsVal) thisChar = Mid(njsVal, i, 1) Select Case thisChar Case "{" NodeCount = NodeCount + 1 Case "}" NodeCount = NodeCount - 1 If NodeCount = 0 Then SplitPositon = arr.Add(SplitPositon, i) End If Case "[" NodeCount = NodeCount + 1 Case "]" NodeCount = NodeCount - 1 Case """" isInString = Not isInString Case "," If isInString = False And NodeCount = 1 Then SplitPositon = arr.Add(SplitPositon, i) End If End Select Next Dim SP, EP, Stlenth For i = 0 To UBound(SplitPositon) - 1 SP = SplitPositon(i) + 1 EP = SplitPositon(i + 1) Stlenth = EP - SP jsObject = arr.Add(jsObject, Mid(njsVal, SP, Stlenth)) Next 'Stop Return jsObject End Function Function jsonReader(st) Dim isInString As Boolean = False Dim jsobject = GetJsItemObjectArr(st) Dim KeyNameArr, KeyName, KeyValue, ValueType, KeyValueArr, ValueTypeArr Dim jsonReaderObj KeyNameArr = arr.Reset() KeyValueArr = arr.Reset() ValueTypeArr = arr.Reset() jsonReaderObj = arr.Reset() For i = 0 To UBound(jsobject) KeyName = GetJsKeyName(jsobject(i)) KeyValue = GetJsKeyValue(jsobject(i)) ValueType = GetValueType(KeyValue) Select Case ValueType Case "string" KeyValue = Mid(KeyValue, 2, Len(KeyValue) - 2) Case "value" KeyValue = Val(KeyValue) Case "array_Str" KeyValue = Mid(KeyValue, 3, Len(KeyValue) - 4) KeyValue = Split(KeyValue, """,""") Case "array_Val" KeyValue = Mid(KeyValue, 2, Len(KeyValue) - 2) KeyValue = Split(KeyValue, ",") For j = 0 To UBound(KeyValue) KeyValue(j) = Val(KeyValue(j)) Next Case "object" KeyValue = KeyValue End Select KeyNameArr = arr.Add(KeyNameArr, KeyName) KeyValueArr = arr.Add(KeyValueArr, KeyValue) ValueTypeArr = arr.Add(ValueTypeArr, ValueType) Next jsonReaderObj = arr.Add(jsonReaderObj, KeyNameArr) jsonReaderObj = arr.Add(jsonReaderObj, KeyValueArr) jsonReaderObj = arr.Add(jsonReaderObj, ValueTypeArr) Return jsonReaderObj End Function End Class
dim t as new text, js as new json
dim FilePath as string = "json的文件路径\json.dat"
dim jsonObject = js.jsonReader(FilePath)
dim JsKeyArr = jsonObject(0) 'json的key的数组
dim JsValueArr = jsonObject(1) 'json的值的数组
dim JsTypeArr = jsonObject(2) 'json的各个值的类型数组
dim KVal = js.GetJsValueByName(jsonObject, "Key的名称")
jsonObject = js.setValue(jsonObject, "Key的名称" , 新的值 , 值的类型)
现在抓取网页数据的时候,经常会遇到JSON的数据,相对于繁杂无标签名的HTML源,用JSON传回的数据比较直观好看点.
但是从其中提炼数据也让人觉得很烦躁,基本上就是不断的查找,截取,或者组装成JS代码执行返回值,很麻烦
写一个方便的JSON模块还是很有必要的
先把构思图保存下,明天有时间再写实现方法...
转载于:https://www.cnblogs.com/xiii/p/4987334.html