TClientDataSet Custom compare field function - delphi

I am using an in-memory TClientDataSet with a TStringField column which contains folders path (Delphi 7).
When I create an index on this column the order is not what I am looking for.
As an example I get :
c:\foo
c:\fôo\a
c:\foo\b
when I would like this order :
c:\foo
c:\foo\b
c:\fôo\a
So I searched a way to use my own compare field function.
Based on this RRUZ answer How to change the implementation (detour) of an externally declared function I tried the following :
type
TClientDataSetHelper = class(DBClient.TClientDataSet);
...
MyCDS : TClientDataSet;
...
// My custom compare field function
function FldCmpHack
(
iFldType : LongWord;
pFld1 : Pointer;
pFld2 : Pointer;
iUnits1 : LongWord;
iUnits2 : LongWord
): Integer; stdcall;
begin
// Just to test
Result := -1;
end;
...
---RRUZ code here---
...
procedure HookDataCompare;
begin
HookProc
(
(MyCDs as TClientDataSetHelper).DSBase.FldCmp, <== do not compile !!!
#FldCmpHack,
FldCmpBackup
);
end;
When I try to compile I get an error (MyCDs as TClientDataSetHelper).DSBase.FldCmp : not enough actual parameters
I do not understand why this does not compile. Could you please help me ?
Is it even possible to "detour" IDSBase.FldCmp in DSIntf.pas ? Am i totally wrong ?
Thank you
EDIT
Finally, thanks to Dsm answer, I transformed the TStringFieldcolumn into a TVarBytesField in order to avoid doubling the buffer. Plus, when a TVarBytesField is indexed the order is based on the bytes value so I get the order I want. For having all child folders after a parent folder and before the next parent folder (c:\foo.new after c:\foo\b), I patched TVarBytesFieldlike this :
TVarBytesField = class(DB.TVarBytesField)
protected
function GetAsString: string; override;
procedure GetText(var Text: string; DisplayText: Boolean); override;
procedure SetAsString(const Value: string); override;
end;
function TVarBytesField.GetAsString: string;
var
vBuffer : PAnsiChar;
vTaille : WORD;
vTexte : PAnsiChar;
vI : WORD;
begin
Result := '';
GetMem(vBuffer, DataSize);
try
if GetData(vBuffer) then
begin
vTaille := PWORD(vBuffer)^;
vTexte := vBuffer + 2;
SetLength(Result, vTaille);
for vI := 1 to vTaille do
begin
if vTexte^ = #2 then
begin
Result[vI] := '\';
end
else
begin
Result[vI] := vTexte^;
end;
Inc(vTexte);
end;
end;
finally
FreeMem(vBuffer);
end;
end;
procedure TVarBytesField.GetText(var Text: string; DisplayText: Boolean);
begin
Text := GetAsString;
end;
procedure TVarBytesField.SetAsString(const Value: string);
var
vBuffer : PAnsiChar;
vTaille : WORD;
vTexte : PAnsiChar;
vI : WORD;
begin
vBuffer := AllocMem(DataSize);
try
vTaille := WORD(Length(Value));
PWORD(vBuffer)^ := vTaille;
vTexte := vBuffer + 2;
for vI := 1 to vTaille do
begin
if Value[vI] = '\' then
begin
vTexte^ := #2
end
else
begin
vTexte^ := Value[vI];
end;
Inc(vTexte);
end;
SetData(vBuffer);
finally
FreeMem(vBuffer);
end;
end;

The message is telling you that FldCmp is a function, and it is expecting you to execute it, but it has not got enough parameters. I am sure that you already realised that and probably already tried to get the address of the function with the # (like you do for FldCmpHack) and found that that does not work.
The reason for that is, I am afraid, that FldCmp is not a normal function. DSBase is actually an interface, which will have been assigned (looking at the source code) by a class factory. What you actually need is the real function itself and for that you need the real object that the class factory creates. And I am sorry, but I can't see any realistic way of doing that.
However, the DSBase field is only created if it has not been assigned, so you could, in theory, create your own IDSBase interface object, which is the way this type of problem is meant to be handled. That is a lot of work, though, unless you know class that the class factory produces and can descend from that.
A sneakier alternative is to override the Translate property and create some sort of hash (perhaps by translating the ASCII codes to their HEX values) so that the database keeps them in the right order
TClientDataSetHelper = class(TClientDataSet)
public
function Translate(Src, Dest: PAnsiChar; ToOem: Boolean): Integer; override;
end;

Related

Record type to temporary variable

How to store record to temporary variable and pass it through function?
If I have two records like:
TMyRec1 = packed record
SomeValue : Integer;
end;
TMyRec2 = packed record
ThisIsMessage : String;
end;
And now I want to be able to do something like this:
function GetRec(recId: Integer) : Variant;
begin
case (recId) of
1 : Result := TMyRec1.Create();
2 : Result := TMyRec2.Create();
//... many
else
end;
end;
And also to return it back to original type like:
function GetRec1(rec: Variant) : TMyRec1;
begin
Result := TMyRec1(rec);
// here I do lots of default things with this record type
end;
function GetRec2(rec: Variant) : TMyRec2;
begin
Result := TMyRec2(rec);
// here I do lots of default things with this record type
end;
Finally an complete function should be able to do the following:
procedure MainFunction();
var myRec : Variant; //I want to avoid to specify each T here
begin
myRec := GetRec(1);
PrintRec1(GetRec1(myRec));
myRec := GetRec(2);
PrintRec2(GetRec2(myRec));
end;
procedure PrintRec1(rec: TMyRec1);
begin
Print(IntToStr(rec.SomeValue));
end;
procedure PrintRec2(rec: TMyRec2);
begin
Print(rec.ThisIsMessage);
end;
I have tried with Variant, TObject, NativeUInt casting but nothing seem to work.
Thank you for any help.
EDIT
TMyRec = record
end;
TMyRec1 = TMyRec
SomeValue : Integer;
end;
TMyRec2 = TMyRec
ThisIsMessage : String;
end;
Can be done something like this?
I don't need safety checking and rising exceptions I will take care of that to make sure I pass correct one where required.
A record does not have a Create() constructor by default, like a class does, so TMyRec1.Create() and TMyRec2.Create() will not work as shown.
But, in Delphi 2006 and later, you can manually add a static Create() method that returns a new record instance (several of Delphi's own native RTL records do this, such as TFormatSettings, TRttiContext, etc), eg:
TMyRec1 = packed record
SomeValue : Integer;
class function Create: TMyRec1; static;
end;
TMyRec2 = packed record
ThisIsMessage : String;
class function Create: TMyRec2; static;
end;
...
class function TMyRec1.Create: TMyRec1;
begin
Result.SomeValue := ...;
end;
class function TMyRec2.Create: TMyRec2;
begin
Result.ThisIsMessage := ...;
end;
Otherwise, for earlier versions, you will have to use standalone functions, eg:
TMyRec1 = packed record
SomeValue : Integer;
end;
TMyRec2 = packed record
ThisIsMessage : String;
end;
function CreateRec1: TMyRec1;
function CreateRec2: TMyRec2;
...
function CreateRec1: TMyRec1;
begin
Result.SomeValue := ...;
end;
function CreateRec2: TMyRec2;
begin
Result.ThisIsMessage := ...;
end;
But, either way, know that by default you can't just store arbitrary record types in a Variant, it doesn't know how to store and retrieve them. You have to teach it how to do that. You do that by deriving a class from TCustomVariantType and override its various operational methods for casting, comparing, etc, and then register that class with the RTL so that the Variant infrastructure knows about it. See Defining Custom Variants in Delphi's documentation for more details about that. Only then will your GetRec(), GetRec1(), and GetRec2() functions be able to work exactly as you have coded them.
Otherwise, consider an alternative approach, for instance defining a custom tagged record, similar to how Variant works internally, eg:
PMyRec1 = ^TMyRec1;
TMyRec1 = packed record
SomeValue : Integer;
end;
PMyRec2 = ^TMyRec2;
TMyRec2 = packed record
ThisIsMessage : String;
end;
TMyRec = record
case Tag: Integer of
1 : (Rec1: PMyRec1);
2 : (Rec2: PMyRec2);
...
end;
function GetRec(recId: Integer) : TMyRec;
begin
Result.Tag := recId;
case recId of
1 : New(Result.Rec1);
2 : New(Result.Rec2);
...
else
raise ...;
end;
end;
function DisposeRec(var rec: TMyRec);
begin
case rec.Tag of
1 : Dispose(rec.Rec1);
2 : Dispose(rec.Rec2);
...
end;
rec.Tag := 0;
end;
function GetRec1(var rec: TMyRec) : TMyRec1;
begin
if rec.Tag <> 1 then raise ...;
Result := rec.Rec1^;
// here I do lots of default things with this record type
end;
function GetRec2(var rec: TMyRec) : TMyRec2;
begin
if rec.Tag <> 2 then raise ...;
Result := rec.Rec2^;
// here I do lots of default things with this record type
end;
procedure MainFunction;
var
myRec : TMyRec;
begin
myRec := GetRec(1);
try
PrintRec1(GetRec1(myRec));
finally
DisposeRec(myRec);
end;
myRec := GetRec(2);
try
PrintRec2(GetRec2(myRec));
finally
DisposeRec(myRec);
end;
end;
procedure PrintRec1(const rec: TMyRec1);
begin
Print(IntToStr(rec.SomeValue));
end;
procedure PrintRec2(const rec: TMyRec2);
begin
Print(rec.ThisIsMessage);
end;

Delphi TStringList as object field

This may very well have been asked many times before but, if so, I cannot for the life of me find the answer. So I apologise in advance if this is the case.
I have this object in a Delphi unit. I'm collating a list of employers from one source which are of type TEmployerData as below.
Once I've collated a list of employers, I will then collect employee and payslips data from other sources which belong to each individual employer.
unit EmployerObjUnit;
interface
uses
Classes, SysUtils, Variants,Types, Generics.Collections, Generics.Defaults, EmployeeObjUnit, PayObjUnit;
type
TEmployerData = class
private
FErID: string;
FErName: string;
FErAccsRef: string;
FErPAYE: string;
FErAddr1: string;
FErAddr2: string;
FErAddr3: string;
FErAddr4: string;
FErPostCd: string;
FErPath: string;
FErEesList: TObjectList<TFPSEmployee>;
FErPayList: TObjectList<TFPSPayment>;
FErYears: TStringList;
procedure SetErID (const Value: string);
procedure SetErName (const Value: string);
procedure SetErAccsRef (const Value: string);
procedure SetErPAYE (const Value: string);
procedure SetErAddr1 (const Value: string);
procedure SetErAddr2 (const Value: string);
procedure SetErAddr3 (const Value: string);
procedure SetErAddr4 (const Value: string);
procedure SetErPostCd (const Value: string);
procedure SetErPath (const Value: string);
constructor Create; overload;
published
property ErID:string read FErID write SetErID;
property ErName:string read FErName write SetErName;
property ErAccsRef:string read FErAccsRef write SetErAccsRef;
property ErPAYE:string read FErPAYE write SetErPAYE;
property ErAddr1:string read FErAddr1 write SetErAddr1;
property ErAddr2:string read FErAddr2 write SetErAddr2;
property ErAddr3:string read FErAddr3 write SetErAddr3;
property ErAddr4:string read FErAddr4 write SetErAddr4;
property ErPostCd:string read FErPostCd write SetErPostCd;
property ErPath: string read FErPath write SetErPath;
property ErEesList: TObjectList<TFPSEmployee> read FErEesList;
property ErPayList: TObjectList<TFPSPayment> read FErPayList;
property ErYears: TStringList read FErYears;
public
procedure AddEmployee(const FPSEmployee: TFPSEmployee);
procedure AddPayslip(const FPSPayslip: TFPSPayment);
procedure AddYear(const Year: string);
end;
All well and dandy so far.
I want to store the employee and payslip data in the ErEEsList and ErPayList ObjectLists, and the relevant years these relate to in the ErYears StringList.
The rest of the class code is:
constructor TEmployerData.Create;
begin
inherited;
FErEesList:=TObjectList<TFPSEmployee>.Create(True);
FErPayList:=TObjectList<TFPSPayment>.Create(True);
FErYears:=TStringList.Create;
end;
procedure TEmployerData.SetErAccsRef(const Value: string);
begin
// all the other setters are in here
end;
procedure TEmployerData.AddEmployee(const FPSEmployee: TFPSEmployee);
var
IsDupe: Boolean;
i: integer;
begin
if FErEesList.Count=0 then
FErEesList.Add(FPSEmployee)
else
begin
IsDupe:=False;
for i := 0 to FErEesList.Count-1 do
begin
if (FErEesList[i].PayID=FPSEmployee.PayID)
AND (FErEesList[i].AccountsRef=FPSEmployee.AccountsRef)
AND (FErEesList[i].TaxYear=FPSEmployee.TaxYear) then
IsDupe:=True;
end;
if IsDupe=False then
FErEesList.Add(FPSEmployee);
if IsDupe=True then
FPSEmployee.Free;
end;
FErEesList.Sort(TComparer<TFPSEmployee>.Construct(
function(const A, B :TFPSEmployee): integer
begin
if A.TaxYear=B.TaxYear then
Result:=0
else if A.TaxYear<B.TaxYear then
Result:=-1
else
Result:=1;
end
));
end;
procedure TEmployerData.AddPayslip(const FPSPayslip: TFPSPayment);
begin
FErPayList.Add(FPSPayslip);
FErPayList.Sort(TComparer<TFPSPayment>.Construct(
function(const A, B :TFPSPayment): integer
begin
if A.TaxYear=B.TaxYear then
Result:=0
else if A.TaxYear<B.TaxYear then
Result:=-1
else
Result:=1;
end
));
end;
procedure TEmployerData.AddYear(const Year: string);
var
i: integer;
GotYr: Boolean;
begin
GotYr:=False;
if FErYears.Count=0 then
FErYears.Add(Year)
else
begin
for i := 0 to FErYears.Count-1 do
begin
if Year=FErYears[i] then
GotYr:=True;
end;
if GotYr=False then
FErYears.Add(Year);
end;
end;
end.
Now, I can collate my list of employers without issue. I can get the information I need for each employee and payslip, BUT when I try to write anything using AddEmployee() or AddYear(), I keep getting Access Violation errors (not even got as far as AddPayslip() yet!). Unfortunately, I'm not fluent enough to figure out why.
The above class is used in one Form unit.
ErsObjList: TObjectList<TEmployerData>;
The above is declared in the Private section of the form unit.
It is created when the form is created. It is freed when the form closes.
Then this is used to fill ErsObjList.
procedure TGetXMLForm.Button1Click(Sender: TObject);
var
//more XML variables
ANode, BNode, CNode: IXMLNode;
NumDir: string;
Employer: TEmployerData;
begin
ErStream:=TFileStream.Create('Employer List.xml', fmOpenRead);
// load of xml setup
try
if Length(XList)>0 then
begin
for i := 0 to Length(XList)-1 do
begin
SetLength(FPSList, 0);
FPSList:=TDirectory.GetFiles(XList[i], 'FPS*.xml', TSearchOption.soAllDirectories);
try
if Length(FPSList)>0 then
begin
// scan through ErListXML for the corresponding number
ErNodes:=ErListXML.DocumentElement.ChildNodes;
if ErNodes.Count>0 then
begin
for x:= 0 to Ernodes.Count-1 do
begin
ANode:=ErNodes[x].ChildNodes.FindNode('Number');
if StrToInt(ANode.Text)=StrToInt(NumDir) then
begin
// create an employer obj from ErListXML
Employer:=TEmployerData.Create;
Employer.ErID:=ANode.Text;
Employer.ErName:=ErNodes[x].ChildNodes.FindNode('Name').Text;
// and so on until
Employer.ErPath:=XList[i];
ErsObjList.Add(Employer);
end;
end;
end;
end;
except
ShowMessage('Exception class name :- '+E.ClassName);
Exit;
end;
end;
end;
ErListXML.Free;
except
ShowMessage('Error reading Employer List xml file');
end;
end;
Button1 gets my employer data from a source, and builds an ObjectList (ErsObjList) without issue.
Then I use this when Button2 is clicked:
procedure TGetXMLForm.Button2Click(Sender: TObject);
var
i: integer;
FPSStream: TStream;
begin
for i := 0 to ErsObjList.Count-1 do
begin
GetPayDetails(ErsObjList[i]);
WriteData;
end;
end;
Which in turn triggers a fuller version of this (I've just removed some basic code for readability - nothing which would affect the issue):
procedure TGetXMLForm.GetRTIDetails(const Employer: TEmployerData);
var
FpsList: TStringDynArray;
// other items
TaxYear: string;
Employee: TFPSEmployee;
Payslip: TFPSPayment;
DateConInf: TFormatSettings;
TaxCd: string;
begin
SetLength(FpsList, 0);
FpsList:=TDirectory.GetFiles(Employer.ErPath, 'FPS*.xml', TSearchOption.soAllDirectories);
if Length(FpsList)>0 then
begin
try
for i := 0 to Length(FpsList)-1 do
begin
// loading some data from XML files
TaxYear:=CNode.ChildNodes.FindNode('RelatedYear').Text;
Employer.AddYear(TaxYear);
// my code then triggers an AV in the "AddYear" procedure
This where it goes wrong.
It does call the procedure AddYear() with the correct value for TaxYear.
It does not flag up any compilation errors.
I would appreciate any help.
edited
For all the code I was trying to cycle through the answer should have been very obvious. But as I said I'm not experienced enough to know.
The TEmployerData class constructor was declared in the wrong place so these
FErEesList: TObjectList<TFPSEmployee>;
FErPayList: TObjectList<TFPSPayment>;
FErYears: TStringList;
were not being initialised correctly when an Employer object was being created. This then caused the runtime AVs.

Unexpected failure of custom registered Reverter using TJSONUnMarshal

The code below is from the JSonMarshall project in chapter 7 of Marco Cantu's Delphi 2010 Handbook. The source code is available from here http://cc.embarcadero.com/item/27600. I have made two changes to it:
Add JSon to the implementation Uses clause to get it to compile.
Added the line
theName := 'XXX'; // added by me
to the TDataWithList.Create constructor to assist debugging
I am running the code in Delphi Seattle (without update 1)
The purpose of the project is to demo a custom converter and reverter for the TDataWithList declared type. The custom converter seems to work fine, judging by the result output to Memo1.
However, attempting to run the reverter results in a "Read of address 00000000" AV on the line
sList.Add (Args[I]);
in btnUnmarshalReverterClick. The immediate cause of this is that contrary to what
the author evidently intended, when the above line executes, sList is Nil.
My question is simply why is sList Nil and how to fix this problem?
I have tried, not entirely successfully, to trace through the DBXJSONReflect source
to find out why.
After
Obj := ObjectInstance(FRTTICtx, objType);
in function TJSONUnMarshal.CreateObject, TDataWithList(obj).theName is 'XXX'
as I'd expect and TDataWithList(obj).theLList is an initialized, but empty,
TStringList.
However, by the time the anonymous method in btnUnmarshalReverterClick is called, TDataWithList(Data).theList is Nil.
Update: The reason that TDataWithList(Data).theList (incorrectly, imo) becomes Nil is that it is set to Nil in TJSONPopulationCustomizer.PrePopulate by a call to PrePopulateObjField. So I suppose the question is, why does PrePopulate allow an object's field which has been initialized in its constructor to be overwritten as if it knows better that the object's constructor.
Update2:
There may be an additional problem, in that as far as I can tell, in
TInternalJSONPopulationCustomizer.PrePopulateObjField, the assignment which overwrites TListWithData.theList with Nil, namely
rttiField.SetValue(Data, TValue.Empty);
does not seem to result in the TStringlist destructor being called.
Btw, I get the same error running the project in XE4, which is the earliest version I have which includes JSonUnMarshal.
Code:
type
[...]
TDataWithList = class
private
theName: String;
theList: TStringList;
public
constructor Create (const aName: string); overload;
constructor Create; overload;
function ToString: string; override;
destructor Destroy; override;
end;
[...]
procedure TFormJson.btnMarshalConverterClick(Sender: TObject);
var
theData: TDataWithList;
jMarshal: TJSONMarshal;
jValue: TJSONValue;
begin
theData := TDataWithList.Create('john');
try
jMarshal := TJSONMarshal.Create(
TJSONConverter.Create); // converter is owned
try
jMarshal.RegisterConverter(TDataWithList, 'theList',
function (Data: TObject; Field: string): TListOfStrings
var
I: Integer;
sList: TStringList;
begin
sList := TDataWithList(Data).theList;
SetLength(Result, sList.Count);
for I := 0 to sList.Count - 1 do
Result[I] := sList[I];
end);
jValue := jMarshal.Marshal(theData);
try
Memo1.Lines.Text := jValue.ToString;
finally
jValue.Free;
end;
finally
jMarshal.Free;
end;
finally
theData.Free;
end;
end;
procedure TFormJson.btnUnmarshalReverterClick(Sender: TObject);
var
jUnmarshal: TJSONUnMarshal;
jValue: TJSONValue;
anObject: TObject;
begin
jValue := TJSONObject.ParseJSONValue(
TEncoding.ASCII.GetBytes (Memo1.Lines.Text), 0);
try
jUnmarshal := TJSONUnMarshal.Create;
try
jUnmarshal.RegisterReverter(TDataWithList, 'theList',
procedure (Data: TObject; Field: string; Args: TListOfStrings)
var
I: Integer;
sList: TStringList;
begin
sList := TDataWithList(Data).theList;
for I := 0 to Length(Args) - 1 do
sList.Add (Args[I]);
end);
anObject := jUnmarshal.Unmarshal(jValue);
try
ShowMessage ('Class: ' + anObject.ClassName +
sLineBreak + anObject.ToString);
finally
anObject.Free;
end;
finally
jUnmarshal.Free;
end;
finally
jValue.Free;
end;
end;
function TMyData.ToString: string;
begin
Result := theName + ':' + IntToStr (theValue);
end;
{ TDataWithList }
constructor TDataWithList.Create(const aName: string);
var
I: Integer;
begin
theName := aName;
theList := TStringList.Create;
for I := 0 to 9 do
theList.Add(IntToStr (Random (1000)));
end;
constructor TDataWithList.Create;
begin
// core initialization, used for default construction
theName := 'XXX'; // added by me
theList := TStringList.Create;
end;
destructor TDataWithList.Destroy;
begin
theList.Free;
inherited;
end;
function TDataWithList.ToString: string;
begin
Result := theName + sLineBreak + theList.Text;
end;
rttiField.SetValue(Data, TValue.Empty); simply overrides the field value because as the name implies it's a field, not a property with get / set methods. The destructor of TStringList is not called due to simple pointer assignment.
The solution here is to declare a property:
TDataWithList = class
...
strict private
theList: TStringList;
...
public
property Data: TStringList read ... write SetData
...
end;
TDataWithList.SetData(TStringList aValue);
begin
theList.Assign(aValue);
end;

Spring4d: How to "force" the container to believe a class implements an interface

I am using RemObjects DataAbstract along with Spring4d. RemObjects generates a SchemaServer_Intf.pas file that contains interfaces for every kind of table that exists in it's schema. It allows for "Strongly typed" datasets, allowing one to access a field using
(aDataSet as IMyDataSet).MyField := aValue
Here is a snapshot of one of the interfaces generated by DataAbstract
IEntiteType = interface(IDAStronglyTypedDataTable)
['{96B82FF7-D087-403C-821A-0323034B4B99}']
{ Property getters and setters }
function GetEntiteIdValue: String;
procedure SetEntiteIdValue(const aValue: String);
function GetEntiteIdIsNull: Boolean;
procedure SetEntiteIdIsNull(const aValue: Boolean);
function GetNameValue: WideString;
procedure SetNameValue(const aValue: WideString);
function GetNameIsNull: Boolean;
procedure SetNameIsNull(const aValue: Boolean);
function GetIsSystemValue: SmallInt;
procedure SetIsSystemValue(const aValue: SmallInt);
function GetIsSystemIsNull: Boolean;
procedure SetIsSystemIsNull(const aValue: Boolean);
{ Properties }
property EntiteId: String read GetEntiteIdValue write SetEntiteIdValue;
property EntiteIdIsNull: Boolean read GetEntiteIdIsNull write SetEntiteIdIsNull;
property Name: WideString read GetNameValue write SetNameValue;
property NameIsNull: Boolean read GetNameIsNull write SetNameIsNull;
property IsSystem: SmallInt read GetIsSystemValue write SetIsSystemValue;
property IsSystemIsNull: Boolean read GetIsSystemIsNull write SetIsSystemIsNull;
end;
Though, there is one problem. If you cast a dataTable like so:
aDataTable := IEntiteType(TDAMemDataTable.Create(nil));
You'll have an "Interface not supported error"
But, as soon as you do:
aDataTable.LogicalName := 'EntiteType';
aDataTable.BusinessRulesId := MyBusinessRuleID;
You can safely write
aDataTable := IEntiteType(TDAMemDataTable.Create(nil));
And you don't get any error.
So, with Spring4d, I thought of writing this in my registration unit:
aContainer.RegisterType<TDAMemDataTable>.Implements<IEntiteType>.DelegateTo(
function : TDAMemDataTable
var aDataTable : TDAMemDataTable;
begin
Result:= TDAMemDataTable.Create(nil);
Result.LogicalName := 'EntiteType';
Result.BusinessRulesId := MyBusinessRuleId;
end
)
But then, Spring4d throws (with reason) error :
Exception 'first chance' à $762D5B68. Classe d'exception ERegistrationException avec un message 'Component type "uDAMemDataTable.TDAMemDataTable" incompatible with service type "SchemaClient_Intf.IEntiteType".'. Processus EntiteREM2.exe (3088)
Is there a way to override this check?
Ok I've found a way to do that. Super simple actually :
aContainer.RegisterType<IAddress>.DelegateTo(
function : IAddress
var aTable : TDAMemDataTable;
begin
aTable := TDAMemDataTable.Create(nil);
aTable.LogicalName := nme_Address;
aTable.BusinessRulesID := RID_Address;
Result := aTable as IAddress;
end
);
Also, for people interested in registering many tables in an elegant fashion :
aContainer.RegisterType<IAddress>.DelegateTo(TableConfigurator.GetTableDelegate<IAddress>(nme_Address, RID_Address));
// Registering other tables here...
Just create some "Helper" class with this method :
class function TableConfigurator.GetTableDelegate<T>(aLogicalName, aBusinessRulesId: string): TActivatorDelegate<T>;
begin
Result := (function: T
var
aTable: TDAMemDataTable;
begin
aTable := TDAMemDataTable.Create(nil);
aTable.LogicalName := aLogicalName;
aTable.BusinessRulesID := aBusinessRulesId;
Result := T(TValue.From(aTable).AsInterface);
end);
end;

Read from Stringlist as read from a File

I have a function which works on reading data from a file like :
procedure ReadDatafromFile (const aFilename : String; aparameterList : TList );
var aIniFile : TInifile;
begin
aIniFile :=TInifile.create(aFilename);
data1 := ReadInteger(......);
.....
....
end;
Now the contents of this file exists at a different location in my program as a StringList. I would like to reuse the existing code, and I would like to program it in a way like:
...
MydataStringList.SaveToFile('c:\temp\tempfile.txt');
ReadDatafromFile( MydataStringList, myparameterList);
...
Is there any smart solution to reuse the existing function and create an overloaded version which is accepting the StringList as a parameter?
That is doable:
procedure ReadDataFromStrings(aFileStrings: TStrings; aParameterList: TList);
overload;
begin
if aParameterList <> nil then
// Add aFileStrings to aParameterList
end;
procedure ReadDataFromFile(const aFileName: TFileName; aParameterList: TList);
overload;
var
Strings: TStringList;
begin
Strings := TStringList.Create;
try
Strings.LoadFromFile(aFileName);
ReadDataFromStrings(Strings, aParameterList);
finally
Strings.Free;
end;
end;
Instead of creating this local Strings variable, you could also use the already present global MydataStringList variable, whichever suits your needs.

Resources