|
' Licensed to the .NET Foundation under one or more agreements.
' The .NET Foundation licenses this file to you under the MIT license.
Imports System
Imports System.Diagnostics
Imports System.Diagnostics.CodeAnalysis
Imports System.Reflection
Imports Microsoft.VisualBasic.CompilerServices.ExceptionUtils
Namespace Microsoft.VisualBasic.CompilerServices
Friend Interface IRecordEnum
Function Callback(ByVal FieldInfo As System.Reflection.FieldInfo, ByRef Value As Object) As Boolean
End Interface
<System.ComponentModel.EditorBrowsableAttribute(System.ComponentModel.EditorBrowsableState.Never)>
Friend NotInheritable Class StructUtils
' Prevent creation.
Private Sub New()
End Sub
<RequiresUnreferencedCode("Calls Object.GetType which cannot be statically analyzed.")>
Friend Shared Function EnumerateUDT(ByVal oStruct As ValueType, ByVal intfRecEnum As IRecordEnum, ByVal fGet As Boolean) As System.Object
Dim fi() As System.Reflection.FieldInfo
Dim iLowerBound As Integer
Dim iUpperBound As Integer
Dim typ As System.Type
Dim i As Integer
Dim FieldType As System.Type
Dim FieldInfo As System.Reflection.FieldInfo
Dim vt As VariantType
Dim obj As Object
typ = oStruct.GetType()
vt = VarTypeFromComType(typ)
If vt <> VariantType.UserDefinedType OrElse typ.IsPrimitive Then
Throw New ArgumentException(SR.Format(SR.Argument_InvalidValue1, "oStruct"))
End If
fi = typ.GetFields(BindingFlags.Instance Or BindingFlags.Public)
iLowerBound = 0
iUpperBound = fi.GetUpperBound(0)
For i = iLowerBound To iUpperBound
FieldInfo = fi(i)
FieldType = FieldInfo.FieldType
obj = FieldInfo.GetValue(oStruct)
If VarTypeFromComType(FieldType) = VariantType.UserDefinedType Then
If FieldType.IsPrimitive Then
Throw VbMakeException(New ArgumentException(SR.Format(SR.Argument_UnsupportedFieldType2, FieldInfo.Name, FieldType.Name)), vbErrors.IllegalFuncCall)
Else
Call EnumerateUDT(CType(obj, ValueType), intfRecEnum, fGet)
End If
Else
Call intfRecEnum.Callback(FieldInfo, obj)
End If
If fGet Then
FieldInfo.SetValue(oStruct, obj)
End If
Next i
Return Nothing
End Function
<RequiresUnreferencedCode("Calls EnumerateUDT which is unsafe.")>
Friend Shared Function GetRecordLength(ByVal o As Object, Optional ByVal PackSize As Integer = -1) As Integer
If o Is Nothing Then
Return 0
End If
Dim intf As IRecordEnum
Dim ph As StructByteLengthHandler
ph = New StructByteLengthHandler(PackSize)
intf = ph
If intf Is Nothing Then
Throw VbMakeException(vbErrors.IllegalFuncCall)
End If
EnumerateUDT(CType(o, ValueType), intf, False)
Return ph.Length
End Function
Private NotInheritable Class StructByteLengthHandler
Implements IRecordEnum
Private m_StructLength As Integer
Private m_PackSize As Integer
Friend Sub New(ByVal PackSize As Integer)
'PackSize - Only 1 and multiples of 2 allowed
Debug.Assert(PackSize = 1, "PackSize is not actually set to anything other than 1 in the current library. " _
& "If this is changed, care will need to be taken that the current code actually sets alignment correctly.")
m_PackSize = PackSize
End Sub
Friend ReadOnly Property Length() As Integer
Get
If m_PackSize = 1 Then
Return m_StructLength
Else
Return (m_StructLength + (m_StructLength Mod m_PackSize))
End If
End Get
End Property
Friend Sub SetAlignment(ByVal size As Integer)
If m_PackSize <> 1 Then
m_StructLength += (m_StructLength Mod size)
End If
End Sub
Friend Function Callback(ByVal field_info As Reflection.FieldInfo, ByRef vValue As Object) As Boolean Implements IRecordEnum.Callback
Dim FieldType As System.Type
Dim align, size As Integer
FieldType = field_info.FieldType
If FieldType Is Nothing Then
Throw VbMakeException(New ArgumentException(SR.Format(SR.Argument_UnsupportedFieldType2, field_info.Name, "Empty")), vbErrors.IllegalFuncCall)
End If
If FieldType.IsArray() Then
Dim attributeList As Object()
Dim ElementType As System.Type
Dim attrFixedArray As VBFixedArrayAttribute
Dim ElementCount, ElementSize As Integer
attributeList = field_info.GetCustomAttributes(GetType(VBFixedArrayAttribute), False)
If Not attributeList Is Nothing AndAlso attributeList.Length <> 0 Then
attrFixedArray = CType(attributeList(0), VBFixedArrayAttribute)
Else
attrFixedArray = Nothing
End If
ElementType = FieldType.GetElementType()
If attrFixedArray Is Nothing Then
ElementCount = 1
ElementSize = 4
Else
'This kind of mismatch will be ignored in length calculation
' Structure ABC
' Public <VBFixedArray(1, 2)> x As Integer()
' End Structure
'We are going to ignore possible mismatch errors in what the
'attribute has for the dimensions and the actual field declaration is
'The FilePut will catch these problems.
'The array might not be initialized and parsing the name correctly to calculate the dims
'isn't worth the possible bugs we could introduce
ElementCount = attrFixedArray.Length
GetFieldSize(field_info, ElementType, align, ElementSize)
End If
SetAlignment(align)
m_StructLength += (ElementCount * ElementSize)
Return False
End If
GetFieldSize(field_info, FieldType, align, size)
SetAlignment(align)
m_StructLength += size
Return False
End Function
Private Sub GetFieldSize(ByVal field_info As Reflection.FieldInfo, ByVal FieldType As System.Type, ByRef align As Integer, ByRef size As Integer)
Select Case Type.GetTypeCode(FieldType)
Case TypeCode.String
Dim attributeList As Object() = field_info.GetCustomAttributes(GetType(VBFixedStringAttribute), False)
If attributeList Is Nothing OrElse attributeList.Length = 0 Then
align = 4
size = 4
Else
Dim ma As VBFixedStringAttribute
Dim length As Integer
ma = CType(attributeList(0), VBFixedStringAttribute)
length = ma.Length
If length = 0 Then
length = -1
End If
size = length
End If
Case TypeCode.Single
align = 4
size = 4
Case TypeCode.Double
align = 8
size = 8
Case TypeCode.Int16
align = 2
size = 2
Case TypeCode.Int32
align = 4
size = 4
Case TypeCode.Byte
align = 1
size = 1
Case TypeCode.Int64
align = 8
size = 8
Case TypeCode.DateTime
align = 8
size = 8
Case TypeCode.Boolean
align = 2
size = 2
Case TypeCode.Decimal
align = 16
size = 16
Case TypeCode.Char
align = 2
size = 2
Case TypeCode.DBNull
Throw VbMakeException(New ArgumentException(SR.Format(SR.Argument_UnsupportedFieldType2, field_info.Name, "DBNull")), vbErrors.IllegalFuncCall)
End Select
If FieldType Is GetType(System.Exception) Then
Throw VbMakeException(New ArgumentException(SR.Format(SR.Argument_UnsupportedFieldType2, field_info.Name, "Exception")), vbErrors.IllegalFuncCall)
ElseIf FieldType Is GetType(System.Reflection.Missing) Then
Throw VbMakeException(New ArgumentException(SR.Format(SR.Argument_UnsupportedFieldType2, field_info.Name, "Missing")), vbErrors.IllegalFuncCall)
'If type defined for the Field is Object, then throw an exception
'NOTE: THIS IS NOT THE SAME AS "TypeOf FieldType Is Object"
ElseIf FieldType Is GetType(Object) Then
Throw VbMakeException(New ArgumentException(SR.Format(SR.Argument_UnsupportedFieldType2, field_info.Name, "Object")), vbErrors.IllegalFuncCall)
End If
End Sub
End Class
End Class
End Namespace
|