#Region "Microsoft.VisualBasic::822ce310a13c2d350e6b19e5f24521a6, Google.Protobuf\JSON\JsonFormatter.vb"
' Author:
'
' asuka (amethyst.asuka@gcmodeller.org)
' xie (genetics@smrucc.org)
' xieguigang (xie.guigang@live.com)
'
' Copyright (c) 2018 GPL3 Licensed
'
'
' GNU GENERAL PUBLIC LICENSE (GPL3)
'
'
' This program is free software: you can redistribute it and/or modify
' it under the terms of the GNU General Public License as published by
' the Free Software Foundation, either version 3 of the License, or
' (at your option) any later version.
'
' This program is distributed in the hope that it will be useful,
' but WITHOUT ANY WARRANTY; without even the implied warranty of
' MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
' GNU General Public License for more details.
'
' You should have received a copy of the GNU General Public License
' along with this program. If not, see .
' /********************************************************************************/
' Summaries:
' Class JsonFormatter
'
' Properties: [Default], DiagnosticOnly
'
' Constructor: (+2 Overloads) Sub New
'
' Function: Format, IsDefaultValue, ToCamelCase, ToCamelCaseForFieldMask, ToDiagnosticString
' WriteMessageFields
'
' Sub: Format, HexEncodeUtf16CodeUnit, WriteAny, WriteDiagnosticOnlyAny, WriteDictionary
' WriteDuration, WriteFieldMask, WriteList, WriteMessage, WriteNull
' WriteString, WriteStruct, WriteStructFieldValue, WriteTimestamp, WriteValue
' WriteWellKnownTypeValue
' Class Settings
'
' Properties: [Default], FormatDefaultValues, TypeRegistry
'
' Constructor: (+3 Overloads) Sub New
'
' Class OriginalEnumValueHelper
'
' Function: GetNameMapping, GetOriginalName
'
'
'
'
' /********************************************************************************/
#End Region
#Region "Copyright notice and license"
' Protocol Buffers - Google's data interchange format
' Copyright 2015 Google Inc. All rights reserved.
' https://developers.google.com/protocol-buffers/
'
' Redistribution and use in source and binary forms, with or without
' modification, are permitted provided that the following conditions are
' met:
'
' * Redistributions of source code must retain the above copyright
' notice, this list of conditions and the following disclaimer.
' * Redistributions in binary form must reproduce the above
' copyright notice, this list of conditions and the following disclaimer
' in the documentation and/or other materials provided with the
' distribution.
' * Neither the name of Google Inc. nor the names of its
' contributors may be used to endorse or promote products derived from
' this software without specific prior written permission.
'
' THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
' "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
' LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
' A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
' OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
' SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
' LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
' DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
' THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
' (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
' OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
#End Region
Imports System
Imports System.Collections
Imports System.Globalization
Imports System.Text
Imports Google.Protobuf.Reflection
Imports Google.Protobuf.WellKnownTypes
Imports System.IO
Imports System.Linq
Imports System.Collections.Generic
Imports System.Reflection
Imports Microsoft.VisualBasic.Language
Namespace Google.Protobuf
'''
''' Reflection-based converter from messages to JSON.
'''
'''
'''
''' Instances of this class are thread-safe, with no mutable state.
'''
'''
''' This is a simple start to get JSON formatting working. As it's reflection-based,
''' it's not as quick as baking calls into generated messages - but is a simpler implementation.
''' (This code is generally not heavily optimized.)
'''
'''
Public NotInheritable Class JsonFormatter
Friend Const AnyTypeUrlField As String = "@type"
Friend Const AnyDiagnosticValueField As String = "@value"
Friend Const AnyWellKnownTypeValueField As String = "value"
Private Const TypeUrlPrefix As String = "type.googleapis.com"
Private Const NameValueSeparator As String = ": "
Private Const PropertySeparator As String = ", "
'''
''' Returns a formatter using the default settings.
'''
Public Shared ReadOnly Property [Default] As JsonFormatter = New JsonFormatter(Settings.Default)
' A JSON formatter which *only* exists
Private Shared ReadOnly diagnosticFormatter As JsonFormatter = New JsonFormatter(Settings.Default)
'''
''' The JSON representation of the first 160 characters of Unicode.
''' Empty strings are replaced by the static constructor.
'''
' C0 (ASCII and derivatives) control characters
' Escaping of " and \ are required by www.json.org string definition.
' Escaping of < and > are required for HTML security.
' C1 (ISO 8859 and Unicode) extended control characters
Private Shared ReadOnly CommonRepresentations As String() = {"\u0000", "\u0001", "\u0002", "\u0003", "\u0004", "\u0005", "\u0006", "\u0007", "\b", "\t", "\n", "\u000b", "\f", "\r", "\u000e", "\u000f", "\u0010", "\u0011", "\u0012", "\u0013", "\u0014", "\u0015", "\u0016", "\u0017", "\u0018", "\u0019", "\u001a", "\u001b", "\u001c", "\u001d", "\u001e", "\u001f", "", "", "\""", "", "", "", "", "", "", "", "", "", "", "", "", "", "", "", "", "", "", "", "", "", "", "", "", "", "\u003c", "", "\u003e", "", "", "", "", "", "", "", "", "", "", "", "", "", "", "", "", "", "", "", "", "", "", "", "", "", "", "", "", "", "\\", "", "", "", "", "", "", "", "", "", "", "", "", "", "", "", "", "", "", "", "", "", "", "", "", "", "", "", "", "", "", "", "", "", "", "\u007f", "\u0080", "\u0081", "\u0082", "\u0083", "\u0084", "\u0085", "\u0086", "\u0087", "\u0088", "\u0089", "\u008a", "\u008b", "\u008c", "\u008d", "\u008e", "\u008f", "\u0090", "\u0091", "\u0092", "\u0093", "\u0094", "\u0095", "\u0096", "\u0097", "\u0098", "\u0099", "\u009a", "\u009b", "\u009c", "\u009d", "\u009e", "\u009f"} ' 0x00
' 0x10
' 0x20
' 0x30
' 0x40
' 0x50
' 0x60
' 0x70
' 0x80
' 0x90
Shared Sub New()
For i = 0 To CommonRepresentations.Length - 1
If Equals(CommonRepresentations(i), "") Then
CommonRepresentations(i) = Microsoft.VisualBasic.ChrW(i).ToString()
End If
Next
End Sub
Private ReadOnly settingsField As Settings
Private ReadOnly Property DiagnosticOnly As Boolean
Get
Return ReferenceEquals(Me, diagnosticFormatter)
End Get
End Property
'''
''' Creates a new formatted with the given settings.
'''
''' The settings.
Public Sub New(settings As Settings)
settingsField = settings
End Sub
'''
''' Formats the specified message as JSON.
'''
''' The message to format.
''' The formatted message.
Public Function Format(message As IMessage) As String
Dim writer = New StringWriter()
Format(message, writer)
Return writer.ToString()
End Function
'''
''' Formats the specified message as JSON.
'''
''' The message to format.
''' The TextWriter to write the formatted message to.
''' The formatted message.
Public Sub Format(message As IMessage, writer As TextWriter)
CheckNotNull(message, NameOf(message))
CheckNotNull(writer, NameOf(writer))
If message.Descriptor.IsWellKnownType Then
WriteWellKnownTypeValue(writer, message.Descriptor, message)
Else
WriteMessage(writer, message)
End If
End Sub
'''
''' Converts a message to JSON for diagnostic purposes with no extra context.
'''
'''
'''
''' This differs from calling on the default JSON
''' formatter in its handling of . As no type registry is available
''' in calls, the normal way of resolving the type of
''' an Any message cannot be applied. Instead, a JSON property named @value
''' is included with the base64 data from the property of the message.
'''
''' The value returned by this method is only designed to be used for diagnostic
''' purposes. It may not be parsable by , and may not be parsable
''' by other Protocol Buffer implementations.
'''
''' The message to format for diagnostic purposes.
''' The diagnostic-only JSON representation of the message
Public Shared Function ToDiagnosticString(message As IMessage) As String
CheckNotNull(message, NameOf(message))
Return diagnosticFormatter.Format(message)
End Function
Private Sub WriteMessage(writer As TextWriter, message As IMessage)
If message Is Nothing Then
WriteNull(writer)
Return
End If
If DiagnosticOnly Then
Dim customDiagnosticMessage As ICustomDiagnosticMessage = TryCast(message, ICustomDiagnosticMessage)
If customDiagnosticMessage IsNot Nothing Then
writer.Write(customDiagnosticMessage.ToDiagnosticString())
Return
End If
End If
writer.Write("{ ")
Dim writtenFields = WriteMessageFields(writer, message, False)
writer.Write(If(writtenFields, " }", "}"))
End Sub
Private Function WriteMessageFields(writer As TextWriter, message As IMessage, assumeFirstFieldWritten As Boolean) As Boolean
Dim fields = message.Descriptor.Fields
Dim first = Not assumeFirstFieldWritten
' First non-oneof fields
For Each field In fields.InFieldNumberOrder()
Dim accessor = field.Accessor
If field.ContainingOneof IsNot Nothing AndAlso field.ContainingOneof.Accessor.GetCaseFieldDescriptor(message) IsNot field Then
Continue For
End If
' Omit default values unless we're asked to format them, or they're oneofs (where the default
' value is still formatted regardless, because that's how we preserve the oneof case).
Dim value = accessor.GetValue(message)
If field.ContainingOneof Is Nothing AndAlso Not settingsField.FormatDefaultValues AndAlso IsDefaultValue(accessor, value) Then
Continue For
End If
' Okay, all tests complete: let's write the field value...
If Not first Then
writer.Write(PropertySeparator)
End If
WriteString(writer, accessor.Descriptor.JsonName)
writer.Write(NameValueSeparator)
WriteValue(writer, value)
first = False
Next
Return Not first
End Function
'''
''' Camel-case converter with added strictness for field mask formatting.
'''
''' The field mask is invalid for JSON representation
Private Shared Function ToCamelCaseForFieldMask(input As String) As String
For i = 0 To input.Length - 1
Dim c = input(i)
If c >= "A"c AndAlso c <= "Z"c Then
Throw New InvalidOperationException($"Invalid field mask to be converted to JSON: {input}")
End If
If c = "_"c AndAlso i < input.Length - 1 Then
Dim [next] = input(i + 1)
If [next] < "a"c OrElse [next] > "z"c Then
Throw New InvalidOperationException($"Invalid field mask to be converted to JSON: {input}")
End If
End If
Next
Return ToCamelCase(input)
End Function
' Converted from src/google/protobuf/util/internal/utility.cc ToCamelCase
' TODO: Use the new field in FieldDescriptor.
Friend Shared Function ToCamelCase(input As String) As String
Dim capitalizeNext = False
Dim wasCap = True
Dim isCap = False
Dim firstWord = True
Dim result As StringBuilder = New StringBuilder(input.Length)
Dim i = 0
While i < input.Length
isCap = Char.IsUpper(input(i))
If input(i) = "_"c Then
capitalizeNext = True
If result.Length <> 0 Then
firstWord = False
End If
Continue While
ElseIf firstWord Then
' Consider when the current character B is capitalized,
' first word ends when:
' 1) following a lowercase: "...aB..."
' 2) followed by a lowercase: "...ABc..."
If result.Length <> 0 AndAlso isCap AndAlso (Not wasCap OrElse i + 1 < input.Length AndAlso Char.IsLower(input(i + 1))) Then
firstWord = False
Else
result.Append(Char.ToLowerInvariant(input(i)))
Continue While
End If
ElseIf capitalizeNext Then
capitalizeNext = False
If Char.IsLower(input(i)) Then
result.Append(Char.ToUpperInvariant(input(i)))
Continue While
End If
End If
result.Append(input(i))
i += 1
wasCap = isCap
End While
Return result.ToString()
End Function
Private Shared Sub WriteNull(writer As TextWriter)
writer.Write("null")
End Sub
Private Shared Function IsDefaultValue(accessor As IFieldAccessor, value As Object) As Boolean
If accessor.Descriptor.IsMap Then
Dim dictionary = CType(value, IDictionary)
Return dictionary.Count = 0
End If
If accessor.Descriptor.IsRepeated Then
Dim list = CType(value, IList)
Return list.Count = 0
End If
Select Case accessor.Descriptor.FieldType
Case FieldType.Bool
Return CBool(value) = False
Case FieldType.Bytes
Return CType(value, ByteString) Is ByteString.Empty
Case FieldType.String
Return Equals(CStr(value), "")
Case FieldType.Double
Return CDbl(value) = 0.0
Case FieldType.SInt32, FieldType.Int32, FieldType.SFixed32, FieldType.Enum
Return CInt(value) = 0
Case FieldType.Fixed32, FieldType.UInt32
Return CUInt(value) = 0
Case FieldType.Fixed64, FieldType.UInt64
Return CULng(value) = 0
Case FieldType.SFixed64, FieldType.Int64, FieldType.SInt64
Return CLng(value) = 0
Case FieldType.Float
Return CSng(value) = 0F
Case FieldType.Message, FieldType.Group ' Never expect to get this, but...
Return value Is Nothing
Case Else
Throw New ArgumentException("Invalid field type")
End Select
End Function
'''
''' Writes a single value to the given writer as JSON. Only types understood by
''' Protocol Buffers can be written in this way. This method is only exposed for
''' advanced use cases; most users should be using
''' or .
'''
''' The writer to write the value to. Must not be null.
''' The value to write. May be null.
Public Sub WriteValue(writer As TextWriter, value As Object)
If value Is Nothing Then
WriteNull(writer)
ElseIf TypeOf value Is Boolean Then
writer.Write(If(value, "true", "false"))
ElseIf TypeOf value Is ByteString Then
' Nothing in Base64 needs escaping
writer.Write(""""c)
writer.Write(CType(value, ByteString).ToBase64())
writer.Write(""""c)
ElseIf TypeOf value Is String Then
WriteString(writer, CStr(value))
ElseIf TypeOf value Is IDictionary Then
WriteDictionary(writer, CType(value, IDictionary))
ElseIf TypeOf value Is IList Then
WriteList(writer, CType(value, IList))
ElseIf TypeOf value Is Integer OrElse TypeOf value Is UInteger Then
Dim formattable = CType(value, IFormattable)
writer.Write(formattable.ToString("d", CultureInfo.InvariantCulture))
ElseIf TypeOf value Is Long OrElse TypeOf value Is ULong Then
writer.Write(""""c)
Dim formattable = CType(value, IFormattable)
writer.Write(formattable.ToString("d", CultureInfo.InvariantCulture))
writer.Write(""""c)
ElseIf TypeOf value Is System.Enum Then
Dim name = OriginalEnumValueHelper.GetOriginalName(value)
If Not Equals(name, Nothing) Then
WriteString(writer, name)
Else
WriteValue(writer, CInt(value))
End If
ElseIf TypeOf value Is Single OrElse TypeOf value Is Double Then
Dim text = CType(value, IFormattable).ToString("r", CultureInfo.InvariantCulture)
If Equals(text, "NaN") OrElse Equals(text, "Infinity") OrElse Equals(text, "-Infinity") Then
writer.Write(""""c)
writer.Write(text)
writer.Write(""""c)
Else
writer.Write(text)
End If
ElseIf TypeOf value Is IMessage Then
Format(CType(value, IMessage), writer)
Else
Throw New ArgumentException("Unable to format value of type " & value.GetType().ToString)
End If
End Sub
'''
''' Central interception point for well-known type formatting. Any well-known types which
''' don't need special handling can fall back to WriteMessage. We avoid assuming that the
''' values are using the embedded well-known types, in order to allow for dynamic messages
''' in the future.
'''
Private Sub WriteWellKnownTypeValue(writer As TextWriter, descriptor As MessageDescriptor, value As Object)
' Currently, we can never actually get here, because null values are always handled by the caller. But if we *could*,
' this would do the right thing.
If value Is Nothing Then
WriteNull(writer)
Return
End If
' For wrapper types, the value will either be the (possibly boxed) "native" value,
' or the message itself if we're formatting it at the top level (e.g. just calling ToString on the object itself).
' If it's the message form, we can extract the value first, which *will* be the (possibly boxed) native value,
' and then proceed, writing it as if we were definitely in a field. (We never need to wrap it in an extra string...
' WriteValue will do the right thing.)
If descriptor.IsWrapperType Then
If TypeOf value Is IMessage Then
Dim message = CType(value, IMessage)
value = message.Descriptor.Fields(WrapperValueFieldNumber).Accessor.GetValue(message)
End If
WriteValue(writer, value)
Return
End If
If Equals(descriptor.FullName, Timestamp.DescriptorProp.FullName) Then
WriteTimestamp(writer, CType(value, IMessage))
Return
End If
If Equals(descriptor.FullName, Duration.DescriptorProp.FullName) Then
WriteDuration(writer, CType(value, IMessage))
Return
End If
If Equals(descriptor.FullName, FieldMask.DescriptorProp.FullName) Then
WriteFieldMask(writer, CType(value, IMessage))
Return
End If
If Equals(descriptor.FullName, Struct.DescriptorProp.FullName) Then
WriteStruct(writer, CType(value, IMessage))
Return
End If
If Equals(descriptor.FullName, ListValue.DescriptorProp.FullName) Then
Dim fieldAccessor = descriptor.Fields(ListValue.ValuesFieldNumber).Accessor
WriteList(writer, CType(fieldAccessor.GetValue(CType(value, IMessage)), IList))
Return
End If
If Equals(descriptor.FullName, WellKnownTypes.Value.DescriptorProp.FullName) Then
WriteStructFieldValue(writer, CType(value, IMessage))
Return
End If
If Equals(descriptor.FullName, Any.DescriptorProp.FullName) Then
WriteAny(writer, CType(value, IMessage))
Return
End If
WriteMessage(writer, CType(value, IMessage))
End Sub
Private Sub WriteTimestamp(writer As TextWriter, value As IMessage)
' TODO: In the common case where this *is* using the built-in Timestamp type, we could
' avoid all the reflection at this point, by casting to Timestamp. In the interests of
' avoiding subtle bugs, don't do that until we've implemented DynamicMessage so that we can prove
' it still works in that case.
Dim nanos As Integer = value.Descriptor.Fields(Timestamp.NanosFieldNumber).Accessor.GetValue(value)
Dim seconds As Long = value.Descriptor.Fields(Timestamp.SecondsFieldNumber).Accessor.GetValue(value)
writer.Write(Timestamp.ToJson(seconds, nanos, DiagnosticOnly))
End Sub
Private Sub WriteDuration(writer As TextWriter, value As IMessage)
' TODO: Same as for WriteTimestamp
Dim nanos As Integer = value.Descriptor.Fields(Duration.NanosFieldNumber).Accessor.GetValue(value)
Dim seconds As Long = value.Descriptor.Fields(Duration.SecondsFieldNumber).Accessor.GetValue(value)
writer.Write(Duration.ToJson(seconds, nanos, DiagnosticOnly))
End Sub
Private Sub WriteFieldMask(writer As TextWriter, value As IMessage)
Dim paths = CType(value.Descriptor.Fields(FieldMask.PathsFieldNumber).Accessor.GetValue(value), IList(Of String))
writer.Write(FieldMask.ToJson(paths, DiagnosticOnly))
End Sub
Private Sub WriteAny(writer As TextWriter, value As IMessage)
If DiagnosticOnly Then
WriteDiagnosticOnlyAny(writer, value)
Return
End If
Dim typeUrl = CStr(value.Descriptor.Fields(Any.TypeUrlFieldNumber).Accessor.GetValue(value))
Dim data = CType(value.Descriptor.Fields(Any.ValueFieldNumber).Accessor.GetValue(value), ByteString)
Dim typeName = Any.GetTypeName(typeUrl)
Dim descriptor = settingsField.TypeRegistry.Find(typeName)
If descriptor Is Nothing Then
Throw New InvalidOperationException($"Type registry has no descriptor for type name '{typeName}'")
End If
Dim message = descriptor.Parser.ParseFrom(data)
writer.Write("{ ")
WriteString(writer, AnyTypeUrlField)
writer.Write(NameValueSeparator)
WriteString(writer, typeUrl)
If descriptor.IsWellKnownType Then
writer.Write(PropertySeparator)
WriteString(writer, AnyWellKnownTypeValueField)
writer.Write(NameValueSeparator)
WriteWellKnownTypeValue(writer, descriptor, message)
Else
WriteMessageFields(writer, message, True)
End If
writer.Write(" }")
End Sub
Private Sub WriteDiagnosticOnlyAny(writer As TextWriter, value As IMessage)
Dim typeUrl = CStr(value.Descriptor.Fields(Any.TypeUrlFieldNumber).Accessor.GetValue(value))
Dim data = CType(value.Descriptor.Fields(Any.ValueFieldNumber).Accessor.GetValue(value), ByteString)
writer.Write("{ ")
WriteString(writer, AnyTypeUrlField)
writer.Write(NameValueSeparator)
WriteString(writer, typeUrl)
writer.Write(PropertySeparator)
WriteString(writer, AnyDiagnosticValueField)
writer.Write(NameValueSeparator)
writer.Write(""""c)
writer.Write(data.ToBase64())
writer.Write(""""c)
writer.Write(" }")
End Sub
Private Sub WriteStruct(writer As TextWriter, message As IMessage)
writer.Write("{ ")
Dim fields = CType(message.Descriptor.Fields(Struct.FieldsFieldNumber).Accessor.GetValue(message), IDictionary)
Dim first = True
For Each entry As DictionaryEntry In fields
Dim key = CStr(entry.Key)
Dim value = CType(entry.Value, IMessage)
If String.IsNullOrEmpty(key) OrElse value Is Nothing Then
Throw New InvalidOperationException("Struct fields cannot have an empty key or a null value.")
End If
If Not first Then
writer.Write(PropertySeparator)
End If
WriteString(writer, key)
writer.Write(NameValueSeparator)
WriteStructFieldValue(writer, value)
first = False
Next
writer.Write(If(first, "}", " }"))
End Sub
Private Sub WriteStructFieldValue(writer As TextWriter, message As IMessage)
Dim specifiedField = message.Descriptor.Oneofs(0).Accessor.GetCaseFieldDescriptor(message)
If specifiedField Is Nothing Then
Throw New InvalidOperationException("Value message must contain a value for the oneof.")
End If
Dim value = specifiedField.Accessor.GetValue(message)
Select Case specifiedField.FieldNumber
Case WellKnownTypes.Value.BoolValueFieldNumber, WellKnownTypes.Value.StringValueFieldNumber, WellKnownTypes.Value.NumberValueFieldNumber
WriteValue(writer, value)
Return
Case WellKnownTypes.Value.StructValueFieldNumber, WellKnownTypes.Value.ListValueFieldNumber
' Structs and ListValues are nested messages, and already well-known types.
Dim nestedMessage = CType(specifiedField.Accessor.GetValue(message), IMessage)
WriteWellKnownTypeValue(writer, nestedMessage.Descriptor, nestedMessage)
Return
Case WellKnownTypes.Value.NullValueFieldNumber
WriteNull(writer)
Return
Case Else
Throw New InvalidOperationException("Unexpected case in struct field: " & specifiedField.FieldNumber)
End Select
End Sub
Friend Sub WriteList(writer As TextWriter, list As IList)
writer.Write("[ ")
Dim first = True
For Each value In list
If Not first Then
writer.Write(PropertySeparator)
End If
WriteValue(writer, value)
first = False
Next
writer.Write(If(first, "]", " ]"))
End Sub
Friend Sub WriteDictionary(writer As TextWriter, dictionary As IDictionary)
writer.Write("{ ")
Dim first = True
' This will box each pair. Could use IDictionaryEnumerator, but that's ugly in terms of disposal.
For Each pair As DictionaryEntry In dictionary
If Not first Then
writer.Write(PropertySeparator)
End If
Dim keyText As String
If TypeOf pair.Key Is String Then
keyText = CStr(pair.Key)
ElseIf TypeOf pair.Key Is Boolean Then
keyText = If(pair.Key, "true", "false")
ElseIf TypeOf pair.Key Is Integer OrElse TypeOf pair.Key Is UInteger Or TypeOf pair.Key Is Long OrElse TypeOf pair.Key Is ULong Then
keyText = CType(pair.Key, IFormattable).ToString("d", CultureInfo.InvariantCulture)
Else
If pair.Key Is Nothing Then
Throw New ArgumentException("Dictionary has entry with null key")
End If
Throw New ArgumentException("Unhandled dictionary key type: " & pair.Key.GetType().ToString)
End If
WriteString(writer, keyText)
writer.Write(NameValueSeparator)
WriteValue(writer, pair.Value)
first = False
Next
writer.Write(If(first, "}", " }"))
End Sub
'''
''' Writes a string (including leading and trailing double quotes) to a builder, escaping as required.
'''
'''
''' Other than surrogate pair handling, this code is mostly taken from src/google/protobuf/util/internal/json_escaping.cc.
'''
Friend Shared Sub WriteString(writer As TextWriter, text As String)
writer.Write(""""c)
For i = 0 To text.Length - 1
Dim c As chr = text(i)
If c < &HA0 Then
writer.Write(CommonRepresentations(c))
Continue For
End If
If Char.IsHighSurrogate(c) Then
' Encountered first part of a surrogate pair.
' Check that we have the whole pair, and encode both parts as hex.
i += 1
If i = text.Length OrElse Not Char.IsLowSurrogate(text(i)) Then
Throw New ArgumentException("String contains low surrogate not followed by high surrogate")
End If
HexEncodeUtf16CodeUnit(writer, c)
HexEncodeUtf16CodeUnit(writer, text(i))
Continue For
ElseIf Char.IsLowSurrogate(c) Then
Throw New ArgumentException("String contains high surrogate not preceded by low surrogate")
End If
Select Case CInt(c)
' These are not required by json spec
' but used to prevent security bugs in javascript.
Case &HFEFF, &HFFF9, &HFFFA, &HFFFB, &HAD, &H6DD, &H70F, &H17B4, &H17B5 ' Zero width no-break space
' Interlinear annotation anchor
' Interlinear annotation separator
' Interlinear annotation terminator
' Soft-hyphen
' Arabic end of ayah
' Syriac abbreviation mark
' Khmer vowel inherent Aq
' Khmer vowel inherent Aa
HexEncodeUtf16CodeUnit(writer, c)
Case Else
If c >= &H600 AndAlso c <= &H603 OrElse c >= &H200B AndAlso c <= &H200F OrElse c >= &H2028 AndAlso c <= &H202E OrElse c >= &H2060 AndAlso c <= &H2064 OrElse c >= &H206A AndAlso c <= &H206F Then ' Arabic signs
' Zero width etc.
' Separators etc.
' Invisible etc.
HexEncodeUtf16CodeUnit(writer, c)
Else
' No handling of surrogates here - that's done earlier
writer.Write(c)
End If
End Select
Next
writer.Write(""""c)
End Sub
Private Const Hex As String = "0123456789abcdef"
Private Shared Sub HexEncodeUtf16CodeUnit(writer As TextWriter, c As chr)
writer.Write("\u")
writer.Write(Hex(c >> 12 And &HF))
writer.Write(Hex(c >> 8 And &HF))
writer.Write(Hex(c >> 4 And &HF))
writer.Write(Hex(c >> 0 And &HF))
End Sub
'''
''' Settings controlling JSON formatting.
'''
Public NotInheritable Class Settings
'''
''' Default settings, as used by
'''
Public Shared ReadOnly Property [Default] As Settings
' Workaround for the Mono compiler complaining about XML comments not being on
' valid language elements.
Shared Sub New()
[Default] = New Settings(False)
End Sub
'''
''' Whether fields whose values are the default for the field type (e.g. 0 for integers)
''' should be formatted (true) or omitted (false).
'''
Public ReadOnly Property FormatDefaultValues As Boolean
'''
''' The type registry used to format messages.
'''
Public ReadOnly Property TypeRegistry As TypeRegistry
' TODO: Work out how we're going to scale this to multiple settings. "WithXyz" methods?
'''
''' Creates a new object with the specified formatting of default values
''' and an empty type registry.
'''
''' true if default values (0, empty strings etc) should be formatted; false otherwise.
Public Sub New(formatDefaultValues As Boolean)
Me.New(formatDefaultValues, TypeRegistry.Empty)
End Sub
'''
''' Creates a new object with the specified formatting of default values
''' and type registry.
'''
''' true if default values (0, empty strings etc) should be formatted; false otherwise.
''' The to use when formatting messages.
Public Sub New(formatDefaultValues As Boolean, typeRegistry As TypeRegistry)
Me.FormatDefaultValues = formatDefaultValues
Me.TypeRegistry = CheckNotNull(typeRegistry, NameOf(typeRegistry))
End Sub
End Class
' Effectively a cache of mapping from enum values to the original name as specified in the proto file,
' fetched by reflection.
' The need for this is unfortunate, as is its unbounded size, but realistically it shouldn't cause issues.
Private NotInheritable Class OriginalEnumValueHelper
' TODO: In the future we might want to use ConcurrentDictionary, at the point where all
' the platforms we target have it.
Private Shared ReadOnly dictionaries As Dictionary(Of System.Type, Dictionary(Of Object, String)) = New Dictionary(Of System.Type, Dictionary(Of Object, String))()
Friend Shared Function GetOriginalName(value As Object) As String
Dim enumType = value.GetType()
Dim nameMapping As Dictionary(Of Object, String)
SyncLock dictionaries
If Not dictionaries.TryGetValue(enumType, nameMapping) Then
nameMapping = GetNameMapping(enumType)
dictionaries(enumType) = nameMapping
End If
End SyncLock
Dim originalName As String
' If this returns false, originalName will be null, which is what we want.
nameMapping.TryGetValue(value, originalName)
Return originalName
End Function
#If DOTNET35
// TODO: Consider adding functionality to TypeExtensions to avoid this difference.
private static Dictionary GetNameMapping(System.Type enumType) =>
enumType.GetFields(BindingFlags.NonPublic | BindingFlags.Public | BindingFlags.Static)
.ToDictionary(f => f.GetValue(null),
f => (f.GetCustomAttributes(typeof(OriginalNameAttribute), false)
.FirstOrDefault() as OriginalNameAttribute)
// If the attribute hasn't been applied, fall back to the name of the field.
?.Name ?? f.Name);
#Else
Private Shared Function GetNameMapping(enumType As System.Type) As Dictionary(Of Object, String)
' If the attribute hasn't been applied, fall back to the name of the field.
Return enumType.GetTypeInfo().DeclaredFields.Where(Function(f) f.IsStatic).ToDictionary(Function(f) f.GetValue(Nothing), Function(f) If(f.GetCustomAttributes(Of OriginalNameAttribute)().FirstOrDefault()?.Name, f.Name))
End Function
#End If
End Class
End Class
End Namespace