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
+
+
+
+
+ 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.