1 #Region "Microsoft.VisualBasic::e1ca747bde173dcbf510af436c988de4, Microsoft.VisualBasic.Core\Serialization\ShadowsCopy.vb"
2
3     ' Author:
4     
5     '       asuka (amethyst.asuka@gcmodeller.org)
6     '       xie (genetics@smrucc.org)
7     '       xieguigang (xie.guigang@live.com)
8     
9     ' Copyright (c) 2018 GPL3 Licensed
10     
11     
12     ' GNU GENERAL PUBLIC LICENSE (GPL3)
13     
14     
15     ' This program is free software: you can redistribute it and/or modify
16     ' it under the terms of the GNU General Public License as published by
17     ' the Free Software Foundation, either version 3 of the License, or
18     ' (at your option) any later version.
19     
20     ' This program is distributed in the hope that it will be useful,
21     ' but WITHOUT ANY WARRANTY; without even the implied warranty of
22     ' MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
23     ' GNU General Public License for more details.
24     
25     ' You should have received a copy of the GNU General Public License
26     ' along with this program. If not, see <http://www.gnu.org/licenses/>.
27
28
29
30     ' /********************************************************************************/
31
32     ' Summaries:
33
34     '     Module ShadowsCopy
35     
36     '         Function: __shadowsCopy, DeepCopy, (+2 Overloads) ShadowCopy, (+2 OverloadsShadowsCopy
37     
38     '     Class ShadowsCopyOpr
39     
40     '         Constructor: (+1 OverloadsSub New
41     '         Function: (+2 Overloads) ShadowCopy, ToString
42     
43     '     Class ShadowsCopyOpr
44     
45     '         Constructor: (+1 OverloadsSub New
46     '         Function: ShadowCopy, ToString
47     
48     
49     ' /********************************************************************************/
50
51 #End Region
52
53 Imports System.IO
54 Imports System.Reflection
55 Imports System.Runtime.CompilerServices
56 Imports System.Runtime.Serialization
57 Imports System.Runtime.Serialization.Formatters.Binary
58
59 #If NET_40 = 0 Then
60
61 Namespace Serialization
62
63     Public Module ShadowsCopy
64
65         ''' <summary>
66         ''' Perform a deep Copy of the object.
67         ''' </summary>
68         ''' <typeparam name="T">The type of object being copied.</typeparam>
69         ''' <param name="source">The object instance to copy.</param>
70         ''' <returns>The copied object.</returns>
71         <Extension> Public Function DeepCopy(Of T)(source As T) As T
72             If (Not GetType(T).IsSerializable) Then
73                 Throw New ArgumentException("The type must be serializable."NameOf(source))
74             End If
75
76             Don't serialize a null object, simply return the default for that object
77             If (Object.ReferenceEquals(source, null)) Then
78                 Return Nothing
79             End If
80
81             Using stream As New MemoryStream()
82                 With New BinaryFormatter()
83                     Call .Serialize(stream, source)
84                     Call stream.Seek(0, SeekOrigin.Begin)
85                     Return DirectCast(.Deserialize(stream), T)
86                 End With
87             End Using
88         End Function
89
90         ''' <summary>
91         ''' 将目标对象之中的属性按值复制
92         ''' </summary>
93         ''' <typeparam name="T"></typeparam>
94         ''' <param name="obj"></param>
95         ''' <returns></returns>
96         ''' <remarks>对外函数接口,为了防止无限递归的出现</remarks>
97         <Extension> Public Function ShadowsCopy(Of T As Class)(obj As T) As T
98             Dim CopiedToTarget As T = DirectCast(__shadowsCopy(GetType(T), obj), T)
99             Return CopiedToTarget
100         End Function
101
102         ''' <summary>
103         ''' 将目标对象之中的属性按值复制
104         ''' </summary>
105         ''' <param name="obj"></param>
106         ''' <returns></returns>
107         ''' <remarks>对外函数接口,为了防止无限递归的出现</remarks>
108         <Extension> Public Function ShadowsCopy(obj As ObjectAs Object
109             Dim CopiedToTarget As Object = __shadowsCopy(obj.GetType, obj)
110             Return CopiedToTarget
111         End Function
112
113         ''' <summary>
114         ''' 递归使用的,基本数据类型直接复制,引用类型则首先创建一个新的对象,在对该对象进行递归复制,假若目标对象没有可用的无参数的构造函数,则直接赋值
115         ''' </summary>
116         ''' <param name="obj"></param>
117         ''' <returns></returns>
118         ''' <remarks></remarks>
119         Private Function __shadowsCopy(typeinfo As Type, obj As ObjectAs Object
120             If ComponentModel.DataSourceModel.DataFramework.StringParsers.ContainsKey(typeinfo) Then
121                 Return obj    '首先查看是否为基本类型,是的话则直接返回值,否在使用反射进行递归复制
122             End If
123
124             Dim OptParameter As System.Reflection.ParameterInfo = Nothing
125             Dim NonParamCtor = (From ctor As System.Reflection.ConstructorInfo
126                                 In typeinfo.GetConstructors
127                                 Where ctor.GetParameters.IsNullOrEmpty
128                                 Select ctor).FirstOrDefault
129
130             If NonParamCtor Is Nothing Then
131                 NonParamCtor = (From ctor As System.Reflection.ConstructorInfo
132                                 In typeinfo.GetConstructors
133                                 Let p = ctor.GetParameters
134                                 Where p.Length = 1 AndAlso p.First.IsOptional
135                                 Select ctor).FirstOrDefault
136
137                 If NonParamCtor Is Nothing Then
138                     Return obj '目标类型没有无参数的构造函数,则直接返回目标对象
139                 Else
140                     OptParameter = NonParamCtor.GetParameters.First     '有一个可选的默认参数,则直接使用默认值进行构造
141                 End If
142             End If
143
144             Dim Target As Object = If(OptParameter Is Nothing, Activator.CreateInstance(typeinfo), Activator.CreateInstance(typeinfo, OptParameter.DefaultValue))
145
146             For Each [Property] In (From p In typeinfo.GetProperties Where p.CanRead AndAlso p.CanWrite Select p).ToArray
147                 Dim CopiedValue = __shadowsCopy([Property].PropertyType, [Property].GetValue(obj))
148                 Call [Property].SetValue(Target, CopiedValue)
149             Next
150
151             Return Target
152         End Function
153
154         ''' <summary>
155         ''' 请使用这个函数来对CSV序列化的对象进行浅拷贝。将<paramref name="source"/>之中的第一层的属性值拷贝到<paramref name="target"/>对应的属性值之中,然后返回<paramref name="target"/>
156         ''' </summary>
157         ''' <typeparam name="T"></typeparam>
158         ''' <param name="source"></param>
159         ''' <param name="Target"></param>
160         ''' <returns></returns>
161         Public Function ShadowCopy(Of T As Class)(source As T, ByRef Target As T) As T
162             Dim opr As New ShadowsCopyOpr(Of T)
163             Return opr.ShadowCopy(source, Target)
164         End Function
165
166         ''' <summary>
167         ''' 将第一层的属性值从基本类复制给继承类
168         ''' </summary>
169         ''' <typeparam name="Tbase"></typeparam>
170         ''' <typeparam name="TInherits"></typeparam>
171         ''' <param name="source"></param>
172         ''' <returns></returns>
173         Public Function ShadowCopy(Of Tbase As Class, TInherits As Tbase)(source As Tbase) As TInherits
174             Dim opr As New ShadowsCopyOpr(Of Tbase, TInherits)
175             Dim value As TInherits = opr.ShadowCopy(source)
176             Return value
177         End Function
178     End Module
179
180     ''' <summary>
181     ''' 批量拷贝需要使用这个模块来执行
182     ''' </summary>
183     ''' <typeparam name="T"></typeparam>
184     Public Class ShadowsCopyOpr(Of T As Class)
185
186         ReadOnly prop As PropertyInfo()
187
188         Sub New()
189             Me.prop = (From [Property] As PropertyInfo
190                        In GetType(T).GetProperties(System.Reflection.BindingFlags.Public Or System.Reflection.BindingFlags.Instance)
191                        Where [Property].CanRead AndAlso [Property].CanWrite
192                        Select [Property]).ToArray
193         End Sub
194
195         Public Function ShadowCopy(source As T) As T
196             Dim copyTo As T = Activator.CreateInstance(Of T)
197             Return ShadowCopy(source, copyTo)
198         End Function
199
200         Public Function ShadowCopy(source As T, copyTo As T) As T
201             For Each [property] As PropertyInfo In prop
202                 Dim value As Object = [property].GetValue(source)
203                 Call [property].SetValue(obj:=copyTo, value:=value)
204             Next
205
206             Return copyTo
207         End Function
208
209         Public Overrides Function ToString() As String
210             Return $"[{NameOf(ShadowsCopy)}] -->> {GetType(T).FullName}"
211         End Function
212     End Class
213
214     ''' <summary>
215     ''' 批量拷贝需要使用这个模块来执行
216     ''' </summary>
217     ''' <typeparam name="Tbase"></typeparam>
218     ''' <typeparam name="TInherits"></typeparam>
219     Public Class ShadowsCopyOpr(Of Tbase As Class, TInherits As Tbase)
220
221         ReadOnly baseProp As PropertyInfo()
222         ReadOnly inheritsHash As Dictionary(Of StringPropertyInfo)
223
224         Sub New()
225             Dim baseProp = GetType(Tbase).GetProperties(BindingFlags.Public Or BindingFlags.Instance)
226             Dim inheritsProp = GetType(TInherits).GetProperties(BindingFlags.Public Or BindingFlags.Instance)
227             Dim inheritsHash = (From prop As PropertyInfo In inheritsProp Where prop.CanWrite Select prop).ToDictionary(Function(x) x.Name)
228
229             Me.baseProp = (From prop As PropertyInfo In baseProp Where prop.CanRead Select prop).ToArray
230             Me.inheritsHash = inheritsHash
231         End Sub
232
233         Public Function ShadowCopy(source As Tbase) As TInherits
234             Dim copyTo As TInherits = Activator.CreateInstance(GetType(TInherits))  ' 需要Object类型进行复制
235
236             For Each prop As PropertyInfo In baseProp
237                 Dim value As Object = prop.GetValue(source)
238                 Call prop.SetValue(obj:=copyTo, value:=value)
239             Next
240
241             Return DirectCast(copyTo, TInherits)
242         End Function
243
244         Public Overrides Function ToString() As String
245             Return $"{GetType(Tbase).FullName} -->> {GetType(TInherits).FullName}"
246         End Function
247     End Class
248 End Namespace
249 #End If