diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..f5d342c --- /dev/null +++ b/.gitignore @@ -0,0 +1,6 @@ +__history +Win32 + +*.local +*.identcache +*.res \ No newline at end of file diff --git a/DaintyGroupDXE2.groupproj b/DaintyGroupDXE2.groupproj new file mode 100644 index 0000000..c50db5c --- /dev/null +++ b/DaintyGroupDXE2.groupproj @@ -0,0 +1,48 @@ + + + {CE176D45-2767-4150-B737-D72F170B25C3} + + + + + + + + + + + Default.Personality.12 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/Packages/DaintyDXE2.dpk b/Packages/DaintyDXE2.dpk new file mode 100644 index 0000000..e78cae1 --- /dev/null +++ b/Packages/DaintyDXE2.dpk @@ -0,0 +1,39 @@ +package DaintyDXE2; + +{$R *.res} +{$IFDEF IMPLICITBUILDING This IFDEF should not be used by users} +{$ALIGN 8} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} +{$DEBUGINFO ON} +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION OFF} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES ON} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST OFF} +{$MINENUMSIZE 1} +{$IMAGEBASE $400000} +{$DEFINE DEBUG} +{$ENDIF IMPLICITBUILDING} +{$RUNONLY} +{$IMPLICITBUILD ON} + +requires + rtl, + dbrtl; + +contains + Dainty in '..\Source\Dainty.pas', + Dainty.ValueSetter.Default in '..\Source\Dainty.ValueSetter.Default.pas'; + +end. diff --git a/Packages/DaintyDXE2.dproj b/Packages/DaintyDXE2.dproj new file mode 100644 index 0000000..6fc8834 --- /dev/null +++ b/Packages/DaintyDXE2.dproj @@ -0,0 +1,140 @@ + + + {EFB63B96-967A-4C05-BD7C-50D48E7E8E43} + DaintyDXE2.dpk + 13.4 + None + True + Debug + Win32 + 1 + Package + + + true + + + true + Base + true + + + true + Base + true + + + true + Cfg_1 + true + true + + + true + Base + true + + + true + 1043 + CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments= + $(DELPHIBIN) + $(DELPHIBIN) + All + System;Xml;Data;Datasnap;Web;Soap;$(DCC_Namespace) + true + true + $(DELPHILIB) + .\$(Platform)\$(Config) + + + true + Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace) + 1033 + CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments= + + + DEBUG;$(DCC_Define) + false + true + true + true + + + true + 1033 + false + + + false + RELEASE;$(DCC_Define) + 0 + false + + + + MainSource + + + + + + + Cfg_2 + Base + + + Base + + + Cfg_1 + Base + + + + Delphi.Personality.12 + Package + + + + DaintyDXE2.dpk + + + True + False + 1 + 0 + 0 + 0 + False + False + False + False + False + 1043 + 1252 + + + + + 1.0.0.0 + + + + + + 1.0.0.0 + + + + + + False + True + + + 12 + + + + diff --git a/Source/Dainty.ValueSetter.Default.pas b/Source/Dainty.ValueSetter.Default.pas new file mode 100644 index 0000000..eb2bbf0 --- /dev/null +++ b/Source/Dainty.ValueSetter.Default.pas @@ -0,0 +1,118 @@ +{ + Dainty + Simple object mapper for Delphi + + Copyright (c) 2020 M. van Renswoude + https://github.com/MvRens/Dainty + + + This is free and unencumbered software released into the public domain. + + Anyone is free to copy, modify, publish, use, compile, sell, or + distribute this software, either in source code form or as a compiled + binary, for any purpose, commercial or non-commercial, and by any + means. + + In jurisdictions that recognize copyright laws, the author or authors + of this software dedicate any and all copyright interest in the + software to the public domain. We make this dedication for the benefit + of the public at large and to the detriment of our heirs and + successors. We intend this dedication to be an overt act of + relinquishment in perpetuity of all present and future rights to this + software under copyright law. + + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, + EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF + MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. + IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY CLAIM, DAMAGES OR + OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, + ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR + OTHER DEALINGS IN THE SOFTWARE. + + For more information, please refer to +} +unit Dainty.ValueSetter.Default; + +interface +implementation +uses + Data.DB, + System.Rtti, + System.TypInfo, + + Dainty; + + +type + TDaintyDefaultValueSetterFactory = class(TDaintyAbstractValueSetterFactory) + public + class function Construct(AMember: TDaintyRttiMember): TDaintyValueSetter; override; + end; + + +{ TDaintyDefaultValueSetterFactory } +class function TDaintyDefaultValueSetterFactory.Construct(AMember: TDaintyRttiMember): TDaintyValueSetter; +begin + Result := nil; + + case AMember.RttiType.TypeKind of + tkString, + tkLString, + tkWString, + tkUString, + tkChar, + tkWChar: + Result := + procedure(AInstance: TObject; AField: TField) + begin + AMember.SetValue(AInstance, AField.AsString); + end; + + tkInteger: + Result := + procedure(AInstance: TObject; AField: TField) + begin + AMember.SetValue(AInstance, AField.AsInteger); + end; + + tkEnumeration: + if AMember.RttiType.Handle = TypeInfo(Boolean) then + Result := + procedure(AInstance: TObject; AField: TField) + begin + AMember.SetValue(AInstance, AField.AsBoolean); + end + else + Result := + procedure(AInstance: TObject; AField: TField) + begin + AMember.SetValue(AInstance, AField.AsInteger); + end; + + tkInt64: + Result := + procedure(AInstance: TObject; AField: TField) + begin + AMember.SetValue(AInstance, AField.AsLargeInt); + end; + + tkFloat: + Result := + procedure(AInstance: TObject; AField: TField) + begin + AMember.SetValue(AInstance, AField.AsFloat); + end; + + tkVariant: + Result := + procedure(AInstance: TObject; AField: TField) + begin + AMember.SetValue(AInstance, TValue.FromVariant(AField.Value)); + end; + end; +end; + +initialization + TDaintyRttiMapperFactory.RegisterValueSetterFactory(TDaintyDefaultValueSetterFactory); + +end. diff --git a/Source/Dainty.pas b/Source/Dainty.pas new file mode 100644 index 0000000..462832a --- /dev/null +++ b/Source/Dainty.pas @@ -0,0 +1,845 @@ +{ + Dainty + Simple object mapper for Delphi + + Copyright (c) 2020 M. van Renswoude + https://github.com/MvRens/Dainty + + + This is free and unencumbered software released into the public domain. + + Anyone is free to copy, modify, publish, use, compile, sell, or + distribute this software, either in source code form or as a compiled + binary, for any purpose, commercial or non-commercial, and by any + means. + + In jurisdictions that recognize copyright laws, the author or authors + of this software dedicate any and all copyright interest in the + software to the public domain. We make this dedication for the benefit + of the public at large and to the detriment of our heirs and + successors. We intend this dedication to be an overt act of + relinquishment in perpetuity of all present and future rights to this + software under copyright law. + + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, + EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF + MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. + IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY CLAIM, DAMAGES OR + OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, + ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR + OTHER DEALINGS IN THE SOFTWARE. + + For more information, please refer to +} +unit Dainty; + +interface +uses + Data.DB, + System.Generics.Collections, + System.Rtti, + System.SysUtils, + + Dainty.ValueSetter.Default; + + +type + TDaintyMapper = class; + + + /// + /// Annotates a field or property to change it's field name in the DataSet + /// as used for the Dainty methods. + /// + FieldName = class(TCustomAttribute) + private + FFieldName: string; + public + constructor Create(const AFieldName: string); + + property FieldName: string read FFieldName; + end; + + + /// + /// Allows for direct calls to TDainty methods from any DataSet instance, for example + /// DataSet.Rows<> or DataSet.GetFirstOrDefault<>. + /// + /// + /// Because class helpers are not exactly extension methods and only one can apply, + /// if you're having conflicts you can call TDainty.Rows<>(DataSet) instead. + /// + TDaintyDataSetHelper = class helper for TDataSet + public + /// + /// Returns a typed enumerable which iterates the DataSet and returns the mapped + /// object for each row. + /// + /// + /// Note that the DataSet is not reset to First and will instead start at the current record. + /// + function Rows: TEnumerable; + + /// + /// Provides access to the mapper which allows control over the DataSet loop. + /// + function GetMapper: TDaintyMapper; + + + /// + /// Returns the current row mapped to the specified class. Throws an exception if no + /// row is active. + /// + function GetFirst: T; + + /// + /// Returns the current row mapped to the specified class. Returns the value of + /// ADefault if no row is active. + /// + function GetFirstOrDefault(const ADefault: T): T; + + + /// + /// Returns the current row mapped to the specified class. Throws an exception if no + /// row is active or if more than one row is remaining. + /// + function GetSingle: T; + + /// + /// Returns the current row mapped to the specified class. Returns the value of + /// ADefault if no row is active or if more than one row is remaining. + /// + function GetSingleOrDefault(const ADefault: T): T; + end; + + + /// + /// Provides row to object mapping functionality. Usually accessed using the TDaintyDataSetHelper. + /// + TDainty = class + public + /// + /// Returns a typed enumerable which iterates the DataSet and returns the mapped + /// object for each row. + /// + /// + /// Note that the DataSet is not reset to First and will instead start at the current record. + /// + class function Rows(ADataSet: TDataSet): TEnumerable; + + /// + /// Provides access to the mapper which allows control over the DataSet loop. + /// + class function GetMapper(ADataSet: TDataSet): TDaintyMapper; + + + /// + /// Returns the current row mapped to the specified class. Throws an exception if no + /// row is active. + /// + class function GetFirst(ADataSet: TDataSet): T; + + /// + /// Returns the current row mapped to the specified class. Returns the value of + /// ADefault if no row is active. + /// + class function GetFirstOrDefault(ADataSet: TDataSet; const ADefault: T): T; + + + /// + /// Returns the current row mapped to the specified class. Throws an exception if no + /// row is active or if more than one row is remaining. + /// + class function GetSingle(ADataSet: TDataSet): T; + + /// + /// Returns the current row mapped to the specified class. Returns the value of + /// ADefault if no row is active or if more than one row is remaining. + /// + class function GetSingleOrDefault(ADataSet: TDataSet; const ADefault: T): T; + end; + + + + /// + /// Performs the mapping of the current row to the specified type. + /// + TDaintyMapper = class + public + function MapRow: T; virtual; abstract; + end; + + + /// + /// Enumerates over the rows of a DataSet and returns the mapped objects. + /// Returned by the Rows<> method. + /// + TDaintyEnumerable = class(TEnumerable) + private + FMapper: TDaintyMapper; + FDataSet: TDataSet; + protected + function DoGetEnumerator: TEnumerator; override; + public + constructor Create(AMapper: TDaintyMapper; ADataSet: TDataSet); + end; + + + /// + /// Internal enumerator returned by TDaintyEnumerable. + /// + /// + /// For internal use only. It's only in the interface section to prevent "Method of parameterized type declared in interface section must not use local symbol" error. + /// + TDaintyEnumerator = class(TEnumerator) + private + FMapper: TDaintyMapper; + FDataSet: TDataSet; + FCurrent: T; + protected + function DoGetCurrent: T; override; + function DoMoveNext: Boolean; override; + public + constructor Create(AMapper: TDaintyMapper; ADataSet: TDataSet); + end; + + + TDaintyValueSetter = reference to procedure(AInstance: TObject; AField: TField); + + + TDaintyRttiFieldNameMapping = record + FieldName: string; + ValueSetter: TDaintyValueSetter; + + constructor Create(const AFieldName: string; const AValueSetter: TDaintyValueSetter); + end; + + TDaintyRttiClassMapping = class + private + FConstruct: TFunc; + FFieldNameMapping: TList; + public + constructor Create(AConstruct: TFunc); + destructor Destroy; override; + + property Construct: TFunc read FConstruct; + property FieldNameMapping: TList read FFieldNameMapping; + end; + + TDaintyRttiFieldMapping = record + Field: TField; + ValueSetter: TDaintyValueSetter; + + constructor Create(const AField: TField; const AValueSetter: TDaintyValueSetter); + end; + + + TDaintyRttiMapper = class(TDaintyMapper) + private + FConstruct: TFunc; + FFieldMapping: TList; + public + constructor Create(AClassMapping: TDaintyRttiClassMapping; ADataSet: TDataSet); + + function MapRow: T; override; + end; + + + TDaintyRttiMember = class + private + FRttiMember: TRttiMember; + protected + function GetRttiType: TRttiType; virtual; abstract; + public + constructor Create(ARttiMember: TRttiMember); + + procedure SetValue(AInstance: TObject; const AValue: TValue); virtual; abstract; + + property RttiMember: TRttiMember read FRttiMember; + property RttiType: TRttiType read GetRttiType; + end; + + + TDaintyRttiFieldMember = class(TDaintyRttiMember) + private + FField: TRttiField; + protected + function GetRttiType: TRttiType; override; + public + constructor Create(AField: TRttiField); + + procedure SetValue(AInstance: TObject; const AValue: TValue); override; + end; + + TDaintyRttiPropertyMember = class(TDaintyRttiMember) + private + FProperty: TRttiProperty; + protected + function GetRttiType: TRttiType; override; + public + constructor Create(AProperty: TRttiProperty); + + procedure SetValue(AInstance: TObject; const AValue: TValue); override; + end; + + + TDaintyAbstractValueSetterFactoryClass = class of TDaintyAbstractValueSetterFactory; + + TDaintyAbstractValueSetterFactory = class + public + class function Construct(AMember: TDaintyRttiMember): TDaintyValueSetter; virtual; abstract; + end; + + + TDaintyRttiMapperFactory = class + private type + TValueSetterRegistration = record + Factory: TDaintyAbstractValueSetterFactoryClass; + Priority: Integer; + + constructor Create(AFactory: TDaintyAbstractValueSetterFactoryClass; APriority: Integer); + end; + private class var + SContext: TRttiContext; + SClassMappingCacheLock: TMultiReadExclusiveWriteSynchronizer; + SClassMappingCache: TDictionary; + SValueSettersLock: TMultiReadExclusiveWriteSynchronizer; + SValueSetters: TList; + SMembers: TObjectList; + private + class function GetClassMapping: TDaintyRttiClassMapping; + class function GetFieldName(AMember: TRttiNamedObject): string; + class function GetValueSetter(AMember: TRttiMember): TDaintyValueSetter; + protected + class procedure Initialize; + class procedure Finalize; + public + class function Construct(ADataSet: TDataSet): TDaintyRttiMapper; + + class procedure RegisterValueSetterFactory(AFactory: TDaintyAbstractValueSetterFactoryClass; APriority: Integer = 0); + class procedure UnregisterValueSetterFactory(AFactory: TDaintyAbstractValueSetterFactoryClass); + end; + + + +implementation +uses + System.TypInfo; + + +{ TDaintyDataSetHelper } +function TDaintyDataSetHelper.Rows: TEnumerable; +begin + Result := TDainty.Rows(Self); +end; + + +function TDaintyDataSetHelper.GetMapper: TDaintyMapper; +begin + Result := TDainty.GetMapper(Self); +end; + + +function TDaintyDataSetHelper.GetFirst: T; +begin + Result := TDainty.GetFirst(Self); +end; + + +function TDaintyDataSetHelper.GetFirstOrDefault(const ADefault: T): T; +begin + Result := TDainty.GetFirstOrDefault(Self, ADefault); +end; + + +function TDaintyDataSetHelper.GetSingle: T; +begin + Result := TDainty.GetSingle(Self); +end; + + +function TDaintyDataSetHelper.GetSingleOrDefault(const ADefault: T): T; +begin + Result := TDainty.GetSingleOrDefault(Self, ADefault); +end; + + +{ TDainty } +class function TDainty.Rows(ADataSet: TDataSet): TEnumerable; +var + mapper: TDaintyMapper; + +begin + mapper := GetMapper(ADataSet); + Result := TDaintyEnumerable.Create(mapper, ADataSet); +end; + + +class function TDainty.GetMapper(ADataSet: TDataSet): TDaintyMapper; +begin + Result := TDaintyRttiMapperFactory.Construct(ADataSet); +end; + + +class function TDainty.GetFirst(ADataSet: TDataSet): T; +var + enumerator: TEnumerator; + +begin + enumerator := Rows(ADataSet).GetEnumerator; + try + if not enumerator.MoveNext then + raise EDatabaseError.Create('Expected at least 1 record but none found'); + + Result := enumerator.Current; + finally + FreeAndNil(enumerator); + end; +end; + + +class function TDainty.GetFirstOrDefault(ADataSet: TDataSet; const ADefault: T): T; +var + enumerator: TEnumerator; + +begin + enumerator := Rows(ADataSet).GetEnumerator; + try + if enumerator.MoveNext then + Result := enumerator.Current + else + Result := ADefault; + finally + FreeAndNil(enumerator); + end; +end; + + +class function TDainty.GetSingle(ADataSet: TDataSet): T; +var + enumerator: TEnumerator; + +begin + enumerator := Rows(ADataSet).GetEnumerator; + try + if not enumerator.MoveNext then + raise EDatabaseError.Create('Expected 1 record but none found'); + + Result := enumerator.Current; + + if enumerator.MoveNext then + raise EDatabaseError.Create('Expected 1 record but more found'); + finally + FreeAndNil(enumerator); + end; +end; + + +class function TDainty.GetSingleOrDefault(ADataSet: TDataSet; const ADefault: T): T; +var + enumerator: TEnumerator; + +begin + enumerator := Rows(ADataSet).GetEnumerator; + try + if not enumerator.MoveNext then + Exit(ADefault); + + Result := enumerator.Current; + + if enumerator.MoveNext then + Exit(ADefault); + finally + FreeAndNil(enumerator); + end; +end; + + +{ TDaintyEnumerable } +constructor TDaintyEnumerable.Create(AMapper: TDaintyMapper; ADataSet: TDataSet); +begin + inherited Create; + + FMapper := AMapper; + FDataSet := ADataSet; +end; + + +function TDaintyEnumerable.DoGetEnumerator: TEnumerator; +begin + Result := TDaintyEnumerator.Create(FMapper, FDataSet); +end; + + +{ TDaintyEnumerator } +constructor TDaintyEnumerator.Create(AMapper: TDaintyMapper; ADataSet: TDataSet); +begin + inherited Create; + + FMapper := AMapper; + FDataSet := ADataSet; +end; + + +function TDaintyEnumerator.DoGetCurrent: T; +begin + Result := FCurrent; +end; + + +function TDaintyEnumerator.DoMoveNext: Boolean; +begin + if FDataSet.Eof then + Exit(False); + + FCurrent := FMapper.MapRow; + Result := True; + + FDataSet.Next; +end; + + +{ TDaintyRttiMapper } +constructor TDaintyRttiMapper.Create(AClassMapping: TDaintyRttiClassMapping; ADataSet: TDataSet); +var + fieldNameMapping: TDaintyRttiFieldNameMapping; + +begin + inherited Create; + + FConstruct := AClassMapping.Construct; + FFieldMapping := TList.Create; + + for fieldNameMapping in AClassMapping.FieldNameMapping do + FFieldMapping.Add(TDaintyRttiFieldMapping.Create(ADataSet.FieldByName(fieldNameMapping.FieldName), fieldNameMapping.ValueSetter)); +end; + + +{ TDaintyRttiMember } +constructor TDaintyRttiMember.Create(ARttiMember: TRttiMember); +begin + inherited Create; + + FRttiMember := ARttiMember; +end; + + +{ TDaintyRttiFieldMember } +constructor TDaintyRttiFieldMember.Create(AField: TRttiField); +begin + inherited Create(AField); + + FField := AField; +end; + + +function TDaintyRttiFieldMember.GetRttiType: TRttiType; +begin + Result := FField.FieldType; +end; + + +procedure TDaintyRttiFieldMember.SetValue(AInstance: TObject; const AValue: TValue); +begin + FField.SetValue(AInstance, AValue); +end; + + +{ TDaintyRttiPropertyMember } +constructor TDaintyRttiPropertyMember.Create(AProperty: TRttiProperty); +begin + inherited Create(AProperty); + + FProperty := AProperty; +end; + + +function TDaintyRttiPropertyMember.GetRttiType: TRttiType; +begin + Result := FProperty.PropertyType; +end; + + +procedure TDaintyRttiPropertyMember.SetValue(AInstance: TObject; const AValue: TValue); +begin + FProperty.SetValue(AInstance, AValue); +end; + + + +{ TDaintyRttiMapperFactory } +class procedure TDaintyRttiMapperFactory.Initialize; +begin + if Assigned(SClassMappingCache) then + Exit; + + SContext := TRttiContext.Create; + SClassMappingCacheLock := TMultiReadExclusiveWriteSynchronizer.Create; + SClassMappingCache := TObjectDictionary.Create([doOwnsValues]); + SValueSettersLock := TMultiReadExclusiveWriteSynchronizer.Create; + SValueSetters := TList.Create; + SMembers := TObjectList.Create; +end; + + +class procedure TDaintyRttiMapperFactory.RegisterValueSetterFactory(AFactory: TDaintyAbstractValueSetterFactoryClass; APriority: Integer); +var + registration: TValueSetterRegistration; + registrationIndex: Integer; + +begin + { Initialization for Dainty.ValueSetter.Default runs before ours, make sure we are initialized } + Initialize; + + SValueSettersLock.BeginWrite; + try + registration := TValueSetterRegistration.Create(AFactory, APriority); + + for registrationIndex := 0 to Pred(SValueSetters.Count) do + if SValueSetters[registrationIndex].Priority <= APriority then + begin + SValueSetters.Insert(registrationIndex, registration); + Exit; + end; + + SValueSetters.Add(registration); + finally + SValueSettersLock.EndWrite; + end; +end; + + +class procedure TDaintyRttiMapperFactory.UnregisterValueSetterFactory(AFactory: TDaintyAbstractValueSetterFactoryClass); +var + registrationIndex: Integer; + +begin + SValueSettersLock.BeginWrite; + try + for registrationIndex := Pred(SValueSetters.Count) downto 0 do + if SValueSetters[registrationIndex].Factory = AFactory then + SValueSetters.Delete(registrationIndex); + finally + SValueSettersLock.EndWrite; + end; +end; + + +class procedure TDaintyRttiMapperFactory.Finalize; +begin + FreeAndNil(SValueSetters); + FreeAndNil(SValueSettersLock); + FreeAndNil(SClassMappingCache); + FreeAndNil(SClassMappingCacheLock); + SContext.Free; +end; + + +class function TDaintyRttiMapperFactory.Construct(ADataSet: TDataSet): TDaintyRttiMapper; +var + mapping: TDaintyRttiClassMapping; + +begin + mapping := GetClassMapping; + Result := TDaintyRttiMapper.Create(mapping, ADataSet); +end; + + +class function TDaintyRttiMapperFactory.GetClassMapping: TDaintyRttiClassMapping; +var + typeInfoHandle: Pointer; + classInfo: TRttiType; + method: TRttiMethod; + instanceClassType: TClass; + fieldInfo: TRttiField; + propertyInfo: TRttiProperty; + valueSetter: TProc; + +begin + SClassMappingCacheLock.BeginRead; + try + typeInfoHandle := TypeInfo(T); + if SClassMappingCache.TryGetValue(typeInfoHandle, Result) then + Exit; + + SClassMappingCacheLock.BeginWrite; + try + { Between the call to BeginWrite and actually acquiring the lock the state + may have changed. Check again to be sure. } + if SClassMappingCache.TryGetValue(typeInfoHandle, Result) then + Exit; + + classInfo := SContext.GetType(typeInfoHandle); + Result := nil; + + for method in classInfo.GetMethods do + begin + if method.IsConstructor and (Length(method.GetParameters) = 0) then + begin + instanceClassType := classInfo.AsInstance.MetaclassType; + Result := TDaintyRttiClassMapping.Create( + function: TObject + begin + Result := method.Invoke(instanceClassType, []).AsObject; + end); + + Break; + end; + end; + + if not Assigned(Result) then + raise ENoConstructException.Create('A constructor with no parameter is required for Dainty'); + + + for fieldInfo in classInfo.GetFields do + begin + if not (fieldInfo.Visibility in [mvPublic, mvPublished]) then + Continue; + + Result.FieldNameMapping.Add(TDaintyRttiFieldNameMapping.Create(GetFieldName(fieldInfo), GetValueSetter(fieldInfo))); + end; + + + for propertyInfo in classInfo.GetProperties do + begin + if not (propertyInfo.Visibility in [mvPublic, mvPublished]) then + Continue; + + if not propertyInfo.IsWritable then + Continue; + + Result.FieldNameMapping.Add(TDaintyRttiFieldNameMapping.Create(GetFieldName(propertyInfo), GetValueSetter(propertyInfo))); + end; + + SClassMappingCache.Add(typeInfoHandle, Result); + finally + SClassMappingCacheLock.EndWrite; + end; + finally + SClassMappingCacheLock.EndRead; + end; +end; + + +class function TDaintyRttiMapperFactory.GetFieldName(AMember: TRttiNamedObject): string; +var + attribute: TCustomAttribute; + +begin + for attribute in AMember.GetAttributes do + begin + if attribute is FieldName then + Exit(FieldName(attribute).FieldName); + end; + + Result := AMember.Name; +end; + + +class function TDaintyRttiMapperFactory.GetValueSetter(AMember: TRttiMember): TDaintyValueSetter; +var + member: TDaintyRttiMember; + registration: TValueSetterRegistration; + +begin + if AMember is TRttiField then + member := TDaintyRttiFieldMember.Create(TRttiField(AMember)) + else if AMember is TRttiProperty then + member := TDaintyRttiPropertyMember.Create(TRttiProperty(AMember)) + else + raise EInvalidOpException.CreateFmt('Member type not supported: %s', [AMember.ClassName]); + + SValueSettersLock.BeginRead; + try + for registration in SValueSetters do + begin + Result := registration.Factory.Construct(member); + if Assigned(Result) then + begin + SMembers.Add(member); + Break; + end; + end; + finally + SValueSettersLock.EndRead; + end; + + if not Assigned(Result) then + begin + FreeAndNil(member); + raise ENotSupportedException.CreateFmt('Member %s has unsupported type for Dainty: %d', [AMember.Name, Ord(member.RttiType.TypeKind)]); + end; +end; + + +{ TDaintyRttiMapperFactory.TValueSetterRegistration } +constructor TDaintyRttiMapperFactory.TValueSetterRegistration.Create(AFactory: TDaintyAbstractValueSetterFactoryClass; APriority: Integer); +begin + Factory := AFactory; + Priority := APriority; +end; + + +{ TDaintyRttiMapper } +function TDaintyRttiMapper.MapRow: T; +var + fieldMapping: TDaintyRttiFieldMapping; + +begin + Result := FConstruct() as T; + + for fieldMapping in FFieldMapping do + fieldMapping.ValueSetter(Result, fieldMapping.Field); +end; + + +{ TDaintyRttiFieldNameMapping } +constructor TDaintyRttiFieldNameMapping.Create(const AFieldName: string; const AValueSetter: TDaintyValueSetter); +begin + FieldName := AFieldName; + ValueSetter := AValueSetter; +end; + + +{ TDaintyRttiFieldMapping } +constructor TDaintyRttiFieldMapping.Create(const AField: TField; const AValueSetter: TDaintyValueSetter); +begin + Field := AField; + ValueSetter := AValueSetter; +end; + + +{ TDaintyRttiClassMapping } +constructor TDaintyRttiClassMapping.Create(AConstruct: TFunc); +begin + inherited Create; + + FConstruct := AConstruct; + FFieldNameMapping := TList.Create; +end; + + +destructor TDaintyRttiClassMapping.Destroy; +begin + FreeAndNil(FFieldNameMapping); + + inherited Destroy; +end; + + +{ FieldName } +constructor FieldName.Create(const AFieldName: string); +begin + inherited Create; + + FFieldName := AFieldName; +end; + + +initialization + TDaintyRttiMapperFactory.Initialize; + +finalization + TDaintyRttiMapperFactory.Finalize; + +end. diff --git a/UnitTests/DaintyTests.pas b/UnitTests/DaintyTests.pas new file mode 100644 index 0000000..4ebed20 --- /dev/null +++ b/UnitTests/DaintyTests.pas @@ -0,0 +1,316 @@ +unit DaintyTests; + +interface +uses + Data.DB, + Datasnap.DBClient, + MidasLib, + TestFramework, + + Dainty; + + +type + TDaintyTest = class(TTestCase) + private + FDataSet: TClientDataSet; + protected + procedure SetUp; override; + procedure TearDown; override; + + procedure FillTestData(ARowCount: Integer); + + property DataSet: TClientDataSet read FDataSet; + published + procedure SimpleTypes; + + procedure GetFirst; + procedure GetFirstMultipleRows; + procedure GetFirstNoData; + procedure GetFirstOrDefault; + + procedure GetSingle; + procedure GetSingleMultipleRows; + procedure GetSingleNoData; + procedure GetSingleOrDefaultMultipleRows; + procedure GetSingleOrDefaultNoData; + + procedure FieldNameAttribute; + procedure FieldNameAttributeProperty; + end; + + +implementation +uses + System.SysUtils; + + +{ TDaintyTest } +procedure TDaintyTest.SetUp; +begin + inherited SetUp; + + FDataSet := TClientDataSet.Create(nil); +end; + + +procedure TDaintyTest.TearDown; +begin + FreeAndNil(FDataSet); + + inherited TearDown; +end; + + + +type + TSimpleTypesRecord = class + StringField: string; + IntegerField: Integer; + DateTimeField: TDateTime; + BooleanField: Boolean; + FloatField: Double; + end; + + +procedure TDaintyTest.SimpleTypes; + + procedure AddRow(const AStringValue: string; AIntegerValue: Integer; ADateTimeValue: TDateTime; ABooleanValue: Boolean; AFloatValue: Double); + begin + DataSet.Append; + DataSet.FieldByName('STRINGFIELD').AsString := AStringValue; + DataSet.FieldByName('INTEGERFIELD').AsInteger := AIntegerValue; + DataSet.FieldByName('DATETIMEFIELD').AsDateTime := ADateTimeValue; + DataSet.FieldByName('BOOLEANFIELD').AsBoolean := ABooleanValue; + DataSet.FieldByName('FLOATFIELD').AsFloat := AFloatValue; + DataSet.Post; + end; + +var + row: TSimpleTypesRecord; + rowIndex: Integer; + +begin + DataSet.FieldDefs.Add('STRINGFIELD', ftString, 50); + DataSet.FieldDefs.Add('INTEGERFIELD', ftInteger); + DataSet.FieldDefs.Add('DATETIMEFIELD', ftDate); + DataSet.FieldDefs.Add('BOOLEANFIELD', ftBoolean); + DataSet.FieldDefs.Add('FLOATFIELD', ftFloat); + DataSet.CreateDataSet; + DataSet.LogChanges := False; + + AddRow('Hello', 42, EncodeDate(2020, 9, 7), True, 3.1415); + AddRow('world!', 69, EncodeDate(2006, 1, 1), False, 1.618); + + + DataSet.First; + rowIndex := 0; + + for row in DataSet.Rows do + begin + case rowIndex of + 0: + begin + CheckEquals('Hello', row.StringField, 'StringField'); + CheckEquals(42, row.IntegerField, 'IntegerField'); + CheckEquals(EncodeDate(2020, 9, 7), row.DateTimeField, 0.9, 'DateTimeField'); + CheckEquals(True, row.BooleanField, 'BooleanField'); + CheckEquals(3.1415, row.FloatField, 0.0001, 'FloatField'); + end; + + 1: + begin + CheckEquals('world!', row.StringField); + CheckEquals(69, row.IntegerField, 'IntegerField'); + CheckEquals(EncodeDate(2006, 1, 1), row.DateTimeField, 0.9, 'DateTimeField'); + CheckEquals(False, row.BooleanField, 'BooleanField'); + CheckEquals(1.618, row.FloatField, 0.0001, 'FloatField'); + end; + end; + + Inc(rowIndex); + end; +end; + + + +type + TTestRow = class + RowNumber: Integer; + end; + + +procedure TDaintyTest.FillTestData(ARowCount: Integer); +var + rowNumber: Integer; + +begin + DataSet.FieldDefs.Add('ROWNUMBER', ftInteger); + DataSet.CreateDataSet; + DataSet.LogChanges := False; + + for rowNumber := 1 to ARowCount do + begin + DataSet.Append; + DataSet.FieldByName('ROWNUMBER').AsInteger := rowNumber; + DataSet.Post; + end; + + DataSet.First; +end; + + +procedure TDaintyTest.GetFirst; +var + row: TTestRow; + +begin + FillTestData(1); + row := DataSet.GetFirst; + + CheckEquals(1, row.RowNumber); +end; + + +procedure TDaintyTest.GetFirstMultipleRows; +var + row: TTestRow; + +begin + FillTestData(2); + row := DataSet.GetFirst; + + CheckEquals(1, row.RowNumber); +end; + + +procedure TDaintyTest.GetFirstNoData; +begin + FillTestData(0); + ExpectedException := EDatabaseError; + DataSet.GetFirst; +end; + + +procedure TDaintyTest.GetFirstOrDefault; +var + row: TTestRow; + +begin + FillTestData(0); + row := DataSet.GetFirstOrDefault(nil); + CheckNull(row); +end; + + +procedure TDaintyTest.GetSingle; +var + row: TTestRow; + +begin + FillTestData(1); + row := DataSet.GetSingle; + CheckEquals(1, row.RowNumber); +end; + + +procedure TDaintyTest.GetSingleMultipleRows; +begin + ExpectedException := EDatabaseError; + FillTestData(2); + DataSet.GetSingle; +end; + + +procedure TDaintyTest.GetSingleNoData; +begin + ExpectedException := EDatabaseError; + FillTestData(0); + DataSet.GetSingle; +end; + + +procedure TDaintyTest.GetSingleOrDefaultMultipleRows; +var + row: TTestRow; + +begin + FillTestData(2); + row := DataSet.GetSingleOrDefault(nil); + CheckNull(row); +end; + + +procedure TDaintyTest.GetSingleOrDefaultNoData; +var + row: TTestRow; + +begin + FillTestData(0); + row := DataSet.GetSingleOrDefault(nil); + CheckNull(row); +end; + + + +type + TAttributeTestRow = class + [FieldName('STRING_FIELD')] + StringField: string; + end; + + +procedure TDaintyTest.FieldNameAttribute; +var + row: TAttributeTestRow; + +begin + DataSet.FieldDefs.Add('STRING_FIELD', ftString, 50); + DataSet.CreateDataSet; + DataSet.LogChanges := False; + + DataSet.Append; + DataSet.FieldByName('STRING_FIELD').AsString := 'Hello world!'; + DataSet.Post; + + row := DataSet.GetFirst; + CheckEquals('Hello world!', row.StringField); +end; + + + +type + TPropertyAttributeTestRow = class + private + FStringField: string; + public + [FieldName('STRING_FIELD')] + property StringField: string read FStringField write FStringField; + end; + + +procedure TDaintyTest.FieldNameAttributeProperty; +var + row: TPropertyAttributeTestRow; + +begin + DataSet.FieldDefs.Add('STRING_FIELD', ftString, 50); + DataSet.CreateDataSet; + DataSet.LogChanges := False; + + DataSet.Append; + DataSet.FieldByName('STRING_FIELD').AsString := 'Hello world!'; + DataSet.Post; + + row := DataSet.GetFirst; + CheckEquals('Hello world!', row.StringField); +end; + + + + +initialization + RegisterTest(TDaintyTest.Suite); + +end. + diff --git a/UnitTests/DaintyUnitTests.dpr b/UnitTests/DaintyUnitTests.dpr new file mode 100644 index 0000000..0888744 --- /dev/null +++ b/UnitTests/DaintyUnitTests.dpr @@ -0,0 +1,14 @@ +program DaintyUnitTests; + +{$R *.res} + +uses + GUITestRunner, + Dainty in '..\Source\Dainty.pas', + DaintyTests in 'DaintyTests.pas', + Dainty.ValueSetter.Default in '..\Source\Dainty.ValueSetter.Default.pas', + DaintyValueSetterTests in 'DaintyValueSetterTests.pas'; + +begin + RunRegisteredTests; +end. diff --git a/UnitTests/DaintyUnitTests.dproj b/UnitTests/DaintyUnitTests.dproj new file mode 100644 index 0000000..566e682 --- /dev/null +++ b/UnitTests/DaintyUnitTests.dproj @@ -0,0 +1,142 @@ + + + {79A2C681-52DB-432C-B68F-67E68341B6C3} + 13.4 + None + DaintyUnitTests.dpr + True + Debug + Win32 + 1 + Console + + + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Cfg_1 + true + true + + + true + Base + true + + + System;Xml;Data;Datasnap;Web;Soap;$(DCC_Namespace) + DBXInterBaseDriver;DataSnapServer;DataSnapCommon;DbxCommonDriver;dbxcds;CustomIPTransport;dsnap;IndyCore;FmxTeeUI;IPIndyImpl;bindcompfmx;dbrtl;bindcomp;inetdb;xmlrtl;ibxpress;soaprtl;FMXTee;bindengine;DBXInformixDriver;DBXFirebirdDriver;inet;DBXSybaseASADriver;dbexpress;fmx;IndySystem;DataSnapClient;DataSnapProviderClient;DBXOracleDriver;inetdbxpress;rtl;DbxClientDriver;IndyProtocols;DBXMySQLDriver;DataSnapIndy10ServerTransport;$(DCC_UsePackage) + .\$(Platform)\$(Config) + .\$(Platform)\$(Config) + + + dxTileControlRS16;cxLibraryRS16;dxPsPrVwAdvRS16;dxRibbonCustomizationFormRS16;dxPSCoreRS16;dxRichEditInplaceRS16;dxPScxTLLnkRS16;dxPSdxSpreadSheetLnkRS16;cxPageControlRS16;dxPScxGridLnkRS16;vclimg;dxComnRS16;vcldb;dxOfficeCoreRS16;dxBarExtDBItemsRS16;dxSpreadSheetInplaceRichEditRS16;dxSpreadSheetCoreRS16;cxDataRS16;dxDockingRS16;dxPSDBTeeChartRS16;dxSpreadSheetReportDesignerRS16;dxBarExtItemsRS16;dxPSLnksRS16;dxPSdxPDFViewerLnkRS16;dxPSTeeChartRS16;dxPSdxLCLnkRS16;cxVerticalGridRS16;dxorgcRS16;dxWizardControlRS16;dxPScxExtCommonRS16;dxNavBarRS16;dxSpreadSheetCoreDialogsRS16;dxSpreadSheetCoreConditionalFormattingDialogsRS16;cxSchedulerTreeBrowserRS16;DBXOdbcDriver;dxdbtrRS16;dxRichEditCoreRS16;dxPSdxDBTVLnkRS16;vclactnband;dxPScxSchedulerLnkRS16;dxServerModeRS16;bindcompvcl;vclie;dsnapcon;dxHttpIndyRequestRS16;vclx;dxFlowChartRS16;dxGDIPlusRS16;dxdborRS16;dxPDFViewerRS16;dxEMFRS16;dxLayoutControlRS16;dxSpreadSheetRS16;dxPScxPivotGridLnkRS16;dxCoreRS16;dxPScxVGridLnkRS16;cxExportRS16;dxPSdxMapControlLnkRS16;dxBarRS16;TeeDB;dxDBXServerModeRS16;cxTreeListdxBarPopupMenuRS16;dxPSdxGaugeControlLnkRS16;dxRibbonRS16;DBXSybaseASEDriver;dxSpreadSheetConditionalFormattingDialogsRS16;cxTreeListRS16;vcldsnap;dxGaugeControlRS16;DBXDb2Driver;vcl;DBXMSSQLDriver;cxSchedulerGridRS16;dxRichEditControlCoreRS16;webdsnap;dxtrmdRS16;adortl;dxRichEditControlRS16;dxRichEditDocumentModelRS16;dxPSdxDBOCLnkRS16;Tee;cxPivotGridChartRS16;dxmdsRS16;dxSpellCheckerRS16;dxMapControlRS16;cxGridRS16;dxPScxCommonRS16;dxPSPrVwRibbonRS16;cxEditorsRS16;TeeUI;cxPivotGridRS16;cxSchedulerRibbonStyleEventEditorRS16;cxSchedulerRS16;vcltouch;websnap;dxFlowChartAdvancedCustomizeFormRS16;VclSmp;dxTabbedMDIRS16;dxPSRichEditControlLnkRS16;dxPSdxOCLnkRS16;dxPSdxFCLnkRS16;dxThemeRS16;dxPScxPCProdRS16;dxBarDBNavRS16;$(DCC_UsePackage) + + + dxTileControlRS16;JvGlobus;JvMM;cxLibraryRS16;JvManagedThreads;JvCrypt;rbDIDE1516;dxPsPrVwAdvRS16;dxRibbonCustomizationFormRS16;rbTCUI1516;dxPSCoreRS16;dxRichEditInplaceRS16;dxPScxTLLnkRS16;dxPSdxSpreadSheetLnkRS16;JvNet;cxPageControlRS16;dxPScxGridLnkRS16;JvDotNetCtrls;vclimg;rbDAD1516;dxComnRS16;JvXPCtrls;rbRCL1516;vcldb;dxOfficeCoreRS16;dxBarExtDBItemsRS16;rbIBE1516;dxSpreadSheetInplaceRichEditRS16;dclRBIBE1516;dclRBADO1516;dxSpreadSheetCoreRS16;CloudService;rbRAP1516;cxDataRS16;dxDockingRS16;dxPSDBTeeChartRS16;JvDB;JvRuntimeDesign;dxSpreadSheetReportDesignerRS16;X2CLMB;dxBarExtItemsRS16;dxPSLnksRS16;dxPSdxPDFViewerLnkRS16;JclDeveloperTools;dxPSTeeChartRS16;dxPSdxLCLnkRS16;cxVerticalGridRS16;dxorgcRS16;dxWizardControlRS16;dxPScxExtCommonRS16;vcldbx;rbDBDE1516;dxNavBarRS16;dclRBE1516;dxSpreadSheetCoreDialogsRS16;rbIDE1516;JvPluginSystem;dxSpreadSheetCoreConditionalFormattingDialogsRS16;cxSchedulerTreeBrowserRS16;DBXOdbcDriver;JvCmp;dxdbtrRS16;madDisAsm_;dxRichEditCoreRS16;JvTimeFramework;dxPSdxDBTVLnkRS16;vclactnband;dxPScxSchedulerLnkRS16;dxServerModeRS16;bindcompvcl;Jcl;vclie;madExcept_;dsnapcon;dxHttpIndyRequestRS16;JvPascalInterpreter;vclx;rbDBE1516;dxFlowChartRS16;dxGDIPlusRS16;JvBDE;dxdborRS16;dxPDFViewerRS16;dxEMFRS16;dxLayoutControlRS16;dxSpreadSheetRS16;dxPScxPivotGridLnkRS16;dxCoreRS16;dxPScxVGridLnkRS16;cxExportRS16;dxPSdxMapControlLnkRS16;dxBarRS16;JvDlgs;cxSchedulerWebServiceStorageRS16;TeeDB;dxDBXServerModeRS16;cxTreeListdxBarPopupMenuRS16;dxPSdxGaugeControlLnkRS16;vclib;inetdbbde;dxRibbonRS16;DBXSybaseASEDriver;dxSpreadSheetConditionalFormattingDialogsRS16;rbTC1516;cxTreeListRS16;vcldsnap;X2CLGL;dxGaugeControlRS16;DBXDb2Driver;dclRBBDE1516;rbDB1516;JvCore;vcl;DBXMSSQLDriver;JvAppFrm;cxSchedulerGridRS16;dxRichEditControlCoreRS16;webdsnap;dxtrmdRS16;rbRIDE1516;JvDocking;adortl;JvWizards;dxRichEditControlRS16;rbADO1516;madBasic_;JvHMI;dxRichEditDocumentModelRS16;JvBands;dxPSdxDBOCLnkRS16;Tee;rbUSERDesign1516;JvSystem;svnui;cxPivotGridChartRS16;JvControls;dxmdsRS16;dxSpellCheckerRS16;dxMapControlRS16;cxGridRS16;dxPScxCommonRS16;dxPSPrVwRibbonRS16;cxEditorsRS16;TeeUI;cxPivotGridRS16;rbUSER1516;JvJans;JvPrintPreview;JvPageComps;dclRBDBE1516;JvStdCtrls;JvCustom;cxSchedulerRibbonStyleEventEditorRS16;rbBDE1516;cxSchedulerRS16;vcltouch;websnap;dxFlowChartAdvancedCustomizeFormRS16;VclSmp;dxTabbedMDIRS16;dxPSRichEditControlLnkRS16;DataSnapConnectors;dxPSdxOCLnkRS16;dxPSdxFCLnkRS16;dxThemeRS16;JclVcl;dxPScxPCProdRS16;rbCIDE1516;svn;bdertl;VirtualTreesR;dxAuthorizationAgentsRS16;dxBarDBNavRS16;$(DCC_UsePackage) + Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace) + 1033 + CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments= + + + DEBUG;$(DCC_Define) + false + true + true + true + + + true + None + 1033 + false + + + false + RELEASE;$(DCC_Define) + 0 + false + + + + MainSource + + + + + + + Cfg_2 + Base + + + Base + + + Cfg_1 + Base + + + + Delphi.Personality.12 + + + + + False + False + 1 + 0 + 0 + 0 + False + False + False + False + False + 1043 + 1252 + + + + + 1.0.0.0 + + + + + + 1.0.0.0 + + + + DaintyUnitTests.dpr + + + + + False + True + + + 12 + + + + diff --git a/UnitTests/DaintyValueSetterTests.pas b/UnitTests/DaintyValueSetterTests.pas new file mode 100644 index 0000000..3b963b9 --- /dev/null +++ b/UnitTests/DaintyValueSetterTests.pas @@ -0,0 +1,171 @@ +unit DaintyValueSetterTests; + +interface +uses + Data.DB, + DataSnap.DBClient, + MidasLib, + TestFramework, + + Dainty; + + +type + TDaintyValueSetterTest = class(TTestCase) + private + FDataSet: TClientDataSet; + protected + procedure SetUp; override; + procedure TearDown; override; + + property DataSet: TClientDataSet read FDataSet; + published + procedure CustomRecordMapping; + procedure GenericCustomRecordMapping; + end; + + +implementation +uses + System.Rtti, + System.SysUtils, + System.TypInfo, + System.Variants; + + +{ TDaintyValueSetterTest } +procedure TDaintyValueSetterTest.SetUp; +begin + inherited SetUp; + + FDataSet := TClientDataSet.Create(nil); +end; + + +procedure TDaintyValueSetterTest.TearDown; +begin + FreeAndNil(FDataSet); + + inherited TearDown; +end; + + +type + TCustomRecord = record + Value: string; + end; + + TCustomRecordRow = class + StringField: TCustomRecord; + end; + + + { Mimics our proprietary implementation of generic nullables, which is based on: + https://community.embarcadero.com/blogs/entry/a-andquotnullableandquot-post-38869 } + TGenericCustomRecord = record + Value: T; + end; + + TGenericCustomRecordRow = class + StringField: TGenericCustomRecord; + end; + + + TCustomRecordValueSetterFactory = class(TDaintyAbstractValueSetterFactory) + public + class function Construct(AMember: TDaintyRttiMember): TDaintyValueSetter; override; + end; + + +{ TCustomRecordValueSetterFactory } +class function TCustomRecordValueSetterFactory.Construct(AMember: TDaintyRttiMember): TDaintyValueSetter; +begin + if AMember.RttiType.TypeKind <> tkRecord then + Exit(nil); + + if AMember.RttiType.Handle = TypeInfo(TCustomRecord) then + begin + Result := + procedure(AInstance: TObject; AField: TField) + var + customRecord: TCustomRecord; + + begin + customRecord.Value := AField.AsString; + AMember.SetValue(AInstance, TValue.From(customRecord)); + end; + + { Unfortunately I have not found a way to make this generic, if you do let me know! + The workaround is to handle all types you want to support explicitly, which is + good enough for our use case with nullable implementations. } + end else if AMember.RttiType.Handle = TypeInfo(TGenericCustomRecord) then + begin + Result := + procedure(AInstance: TObject; AField: TField) + var + value: TGenericCustomRecord; + + begin + value.Value := AField.AsString; + AMember.SetValue(AInstance, TValue.From(value)); + end; + end; +end; + + +procedure TDaintyValueSetterTest.CustomRecordMapping; +var + row: TCustomRecordRow; + +begin + DataSet.FieldDefs.Add('STRINGFIELD', ftString, 50); + DataSet.CreateDataSet; + DataSet.LogChanges := False; + + DataSet.Append; + DataSet.FieldByName('STRINGFIELD').AsString := 'Hello world!'; + DataSet.Post; + + + TDaintyRttiMapperFactory.RegisterValueSetterFactory(TCustomRecordValueSetterFactory, 1); + try + DataSet.First; + row := DataSet.GetFirst; + + CheckEquals('Hello world!', row.StringField.Value); + finally + TDaintyRttiMapperFactory.UnregisterValueSetterFactory(TCustomRecordValueSetterFactory); + end; +end; + + +procedure TDaintyValueSetterTest.GenericCustomRecordMapping; +var + row: TGenericCustomRecordRow; + +begin + DataSet.FieldDefs.Add('STRINGFIELD', ftString, 50); + DataSet.CreateDataSet; + DataSet.LogChanges := False; + + DataSet.Append; + DataSet.FieldByName('STRINGFIELD').AsString := 'Hello world!'; + DataSet.Post; + + + TDaintyRttiMapperFactory.RegisterValueSetterFactory(TCustomRecordValueSetterFactory, 1); + try + DataSet.First; + row := DataSet.GetFirst; + + CheckEquals('Hello world!', row.StringField.Value); + finally + TDaintyRttiMapperFactory.UnregisterValueSetterFactory(TCustomRecordValueSetterFactory); + end; +end; + + +initialization + RegisterTest(TDaintyValueSetterTest.Suite); + +end.