How can I avoid EInvalidPointer error when using TObjectDictionary in Delphi? - delphi

The program receives product information datas through window message.
Incoming datas processed in TProductInstance.PutProductData procedure.
Product information contains date, name, price.
I want to store datas as TObjectDictionary. The key is same date of the product and value is product information data list as TObjectList.
Also I want to maintain datas only in latest 7 days.
By the way, when I remove the item from TObjectDictionary for maintaining, error occurs like below.
First chance exception at $75214598.Exception class EInvalidPointer with message 'Invalid pointer operation'. Process product.exe (3848).
This is caused by FProductDictionary.Remove(StringKey);.
How can I avoid EInvalidPointer error with maintain latest 7 days datas?
type
TProductItem = class(TObject)
private
FDate: String;
FName: String;
FPrice: Integer;
procedure SetDate(const value: String);
procedure SetName(const value: String);
procedure SetPrice(const value: Integer);
public
property Date: String read FDate write SetDate;
property Name: String read FName write SetName;
property Price: Integer read FPrice write SetPrice;
constructor Create(const date, name: String; const price: Integer);
end;
TProductItemList = class(TObjectList<TProductItem>);
type
TProductInstance = class(TObject)
private
public
FLatestDate: String;
FProductList: TProductItemList;
FProductDictionary: TObjectDictionary<String, TProductItemList>;
constructor Create;
destructor Destroy; override;
procedure PutProductData(var Data: LP_Data);
end;
implementation
constructor TProductInstance.Create;
begin
FLatestDate := '';
FProductList := TProductItemList.Create;
FProductDictionary := TObjectDictionary<String, TProductItemList>.Create([doOwnsValues]);
end;
procedure TProductInstance.PutProductData(var Data: LP_Data);
var
StringKey: String;
begin
if (Trim(LP_Data^.date) <> FLatestDate) then
begin
FProductDictionary.AddOrSetValue(Trim(LP_Data^.date), FProductList);
for StringKey in FProductDictionary.Keys do
begin
if (GetDateToInt(Trim(LP_Data^.date)) - GetDateToInt(FLatestDate) > 7) then
FProductDictionary.Remove(StringKey);
end;
FProductList.Free;
end;
FProductList.Add(TProductItem.Create(Trim(LP_Data^.date), Trim(LP_Data^.name), Trim(LP_Data^.price)));
FLatestDate := Trim(LP_Data^.date);
end;
UPDATED
type
TProductItem = class(TObject)
private
FDate: String;
FName: String;
FPrice: Integer;
procedure SetDate(const value: String);
procedure SetName(const value: String);
procedure SetPrice(const value: Integer);
public
property Date: String read FDate write SetDate;
property Name: String read FName write SetName;
property Price: Integer read FPrice write SetPrice;
constructor Create(const date, name: String; const price: Integer);
end;
type
TProductInstance = class(TObject)
private
public
FLatestDate: String;
FProductList: TObjectList<TProductItem>;
FProductDictionary: TObjectDictionary<String, TObjectList<TProductItem>>;
constructor Create;
destructor Destroy; override;
procedure PutProductData(var Data: LP_Data);
end;
implementation
constructor TProductInstance.Create;
var
LProductItem: TProductItem;
LProductItemList: TObjectList<TProductItem>;
LStringList: TStringList;
begin
FLatestDate := '';
FProductList := TObjectList<TProductItem>.Create;
FProductDictionary := TObjectDictionary<String, TObjectList<TProductItem>>.Create([doOwnsValues]);
end;
procedure TProductInstance.PutProductData(var Data: LP_Data);
var
StringKey: String;
begin
FProductList.Add(TProductItem.Create(Trim(LP_Data^.date), Trim(LP_Data^.name), Trim(LP_Data^.price)));
if (Trim(LP_Data^.date) <> FLatestDate) then
begin
LProductItemList := TObjectList<ProductItem>.Create;
for LProductItem in FProductList do
begin
LProductItemList.Add(LProductItem);
end;
FProductDictionary.AddOrSetValue(Trim(LP_Data^.date), LProductItemList);
FProductList.Clear;
LStringList := TStringList.Create;
for StringKey in FProductDictionary.Keys do
begin
if (GetDateToInt(Trim(LP_Data^.date)) - GetDateToInt(FLatestDate) > 7) then
begin
LStringList.Add(StringKey);
end;
end;
for StringKey in LStringList do
begin
FProductDictionary.Remove(StringKey);
end;
FreeAndNil(LStringList);
end;
end;
Updated code occurs EInvalidPointer error on FProductDictionary.Remove(StringKey); What did I wrong?

The code you present is incomplete. You did not show the destructor for TProductInstance. For a question such as this you should always supply a simple MCVE. This is quite easy to achieve in a single console .dpr file.
Looking at what we can see, it is clear that the lifetime management in the code is broken. Let us critique this method.
procedure TProductInstance.PutProductData(var Data: LP_Data);
var
StringKey: String;
begin
if (Trim(LP_Data^.date) <> FLatestDate) then
begin
FProductDictionary.AddOrSetValue(Trim(LP_Data^.date), FProductList);
for StringKey in FProductDictionary.Keys do
begin
if (GetDateToInt(Trim(LP_Data^.date)) - GetDateToInt(FLatestDate) > 7) then
FProductDictionary.Remove(StringKey);
end;
FProductList.Free;
end;
FProductList.Add(TProductItem.Create(Trim(LP_Data^.date), Trim(LP_Data^.name),
Trim(LP_Data^.price)));
FLatestDate := Trim(LP_Data^.date);
end;
Because FProductDictionary owns its values, when you do
FProductDictionary.AddOrSetValue(Trim(LP_Data^.date), FProductList);
then FProductDictionary becomes the owner of FProductList. That means that you should not destroy FProductList ever. However, you do exactly that:
FProductList.Free;
So you are going to be destroying FProductList multiple times which is a clear error.
What to do next? You need to deal with the lifetime issues. I cannot know from the code presented here what you are trying to achieve, and how the lifetime should be managed. You will need to work out who is responsible for owning what, and make sure that you stick to a clear lifetime management policy.
On the face of it, my best guess would be that you need to remove the FProductList field. When you need to add a new item to FProductDictionary, instantiate a new instance of TProductItemList, populate it, and add it to the dictionary. At that point the dictionary takes control of the lifetime of the TProductItemList.
As one final comment, I would suggest that the type TProductItemList is pointless. I would remove it. Use TObjectList<TProductItem> to make the code clearer to the reader. The reader can look at TObjectList<TProductItem> and know immediately what it is, since TObjectList<T> is such a ubiquitous type.

Related

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.

Delphi DefineProperties unpublished property DFM order

I'm developing a component for Query. It works like the "Properties" feature of DevExpress, but I need to place the order of the Unpublished Property I wrote to DFM with DefineProperties in the DFM file at the top of the TCollectionItem.
It works the same way in DevExpress. If you add a Field to the cxGrid and assign a value to the Properties property, you will see the value "PropertiesClassName" in the DFM file at the top.
When I open the DFM file and bring this Property to the top, the setter property of the "PropertiesClassName" Property works and I create that Class. It works seamlessly when reading data from the DFM stream. But no matter what I did I couldn't get the "PropertiesClassName" Property value to the top.
If you create a cxGrid on the form and add Field, and then take the "PropertiesClassName" property from DFM to the bottom of the DFM file, when you open the form again, you will see that it cannot find the relevant Class and an error occurs.
To change the DFM flow, I first assigned a value to the "PropertiesClassName" Property and then created the Class, but the problem was not solved. I did the opposite of this but the problem is still the same.
DFM Context
object QuerySearchEngine1: TQuerySearchEngine
SearchFields = <
item
FieldName = 'TestField'
Properties.Convert2String = True
PropertiesClassName = 'TSearchBooleanProperties'
end>
DFM Context should be like
object QuerySearchEngine1: TQuerySearchEngine
SearchFields = <
item
PropertiesClassName = 'TSearchBooleanProperties'
FieldName = 'TestField'
Properties.Convert2String = True
end>
Classes
TSearchField = class(TCollectionItem)
private
FFieldName: string;
FProperties: TSearchFieldProperties;
FPropertiesClassName: string;
private
procedure SetFieldName(const Value: string);
procedure SetProperties(const Value: TSearchFieldProperties);
private
procedure ReaderProc(Reader: TReader);
procedure WriterProc(Writer: TWriter);
procedure SetPropertiesClassName(const Value: string);
protected
constructor Create(Collection: TCollection); override;
procedure DefineProperties(Filer: TFiler); override;
public
property PropertiesClassName: string read FPropertiesClassName write SetPropertiesClassName;
published
property FieldName: string read FFieldName write SetFieldName;
property Properties: TSearchFieldProperties read FProperties write SetProperties;
end;
procedure TSearchField.DefineProperties(Filer: TFiler);
begin
inherited;
Filer.DefineProperty('PropertiesClassName', ReaderProc, WriterProc, FPropertiesClassName <> '');
end;
procedure TSearchField.SetPropertiesClassName(const Value: string);
begin
var Item: TSearchFieldPropertiesItem;
if TryValidateSearchFieldPropertiesClassName(Value, Item) then
begin
if not Assigned(FProperties) or not (FProperties.ClassType = Item.ClassType) then
begin
if Assigned(FProperties) then
begin
FProperties.Free;
FProperties := nil;
end;
FPropertiesClassName := Item.ClassType.ClassName;
FProperties := Item.ClassType.Create;
end;
end
else
begin
FPropertiesClassName := '';
if Assigned(FProperties) then
begin
FProperties.Free;
FProperties := nil;
end;
end;
end;
Property Editor
type
TSearchFieldPropertiesProperty = class(TClassProperty)
private
function GetInstance: TPersistent;
public
function GetAttributes: TPropertyAttributes; override;
procedure GetValues(Proc: TGetStrProc); override;
function GetValue: string; override;
procedure SetValue(const Value: string); override;
end;
function TSearchFieldPropertiesProperty.GetValue: string;
begin
for var I := 0 to Self.PropCount - 1 do
begin
var Inst := Self.GetComponent(I);
if Assigned(Inst) and Self.HasInstance(Inst) then
begin
if Inst is TSearchField then
begin
var PropInst := GetObjectProp(Inst, Self.GetPropInfo);
if Assigned(PropInst) then
begin
for var Item in SearchFieldPropertiesList do
begin
if PropInst.ClassType = Item.ClassType then
begin
Result := Item.Name;
Exit;
end;
end;
end;
end;
end;
end;
end;
procedure TSearchFieldPropertiesProperty.SetValue(const Value: string);
begin
var Item: TSearchFieldPropertiesItem;
if TryValidateSearchFieldPropertiesName(Value, Item) then
begin
var Inst := GetInstance;
if Assigned(Inst) then
begin
var Context := TRttiContext.Create;
var Rtype := Context.GetType(Inst.ClassType);
for var Prop in Rtype.GetProperties do
begin
if SameText(Prop.Name, 'PropertiesClassName') then
begin
Prop.SetValue(Inst, TValue.From<string>(Item.ClassType.ClassName));
Break;
end;
end;
end;
end;
end;
Pic for Design Time
The only problem is changing the order of the Property in that DFM flow.
Original answer at the bottom, here is a new suggestion:
We actually have something very similar in the JVCL where TJvHotTrackPersistent publishes a HotTrackOptions property.
This property is backed by an instance of TJvHotTrackOptions that gets derived in other classes that need specialized versions of it.
To tell the streaming subsystem to use the actual class found at streaming time, the constructor of that options class calls SetSubComponent(True); which places csSubComponent in the ComponentStyle property.
So what you should do is get rid of your DefineProperties, have TSearchFieldProperties inherit from TComponent and call SetSubComponent(True) in its constructor.
Then you create as many classes derived from TSearchFieldProperties as you need, each with its own set of published properties.
This means you should also get rid of the methods you showed in your submission.
In the end, you should have something along those lines:
type
TSearchFieldProperties = class(TComponent)
public
constructor Create(AOwner: TComponent); override;
end;
TIntegerSearchFieldProperties = class(TSearchFieldProperties)
private
FIntValue: Integer;
published
property IntValue: Integer read FIntValue write FIntValue;
end;
constructor TSearchFieldProperties.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
SetSubComponent(True);
end;
With this you do not fight against the streaming system but rather work with it in the way it is meant to be used.
But if you stop there, you'll notice there is no way for you to specify the actual class name to be used for the TSearchFieldProperties instance used for the TSearchField.Properties property.
The only way to get the class name to be streamed before the subcomponent is streamed is to actually declare the class name as a published property, declared before the subcomponent like this:
type
TSearchField = class(TCollectionItem)
published
// DO NOT change the order of those two properties, PropertiesClassName must come BEFORE Properties for DFM streaming to work properly
property PropertiesClassName: string read GetPropertiesClassName write SetPropertiesClassName;
property Properties: TSearchFieldProperties read FProperties write SetProperties;
end;
function TSearchField.GetPropertiesClassName: string;
begin
Result := Properties.ClassName;
end;
procedure TSearchField.SetPropertiesClassName(const AValue: string);
begin
FProperties.Free; // no need to test for nil, Free already does it
FProperties := TSearchFieldPropertiesClass(FindClass(AValue)).Create(self);
end;
It might work if you just declare the published property like without creating a csSubComponent hierarchy but you'll most likely stumble on other hurdles along the way.
Note: this answer is wrong because DefineProperties is called last in TWriter.WriteProperties and so there is no way to change the order properties defined like this are written.
What if you change your DefineProperties override from this:
procedure TSearchField.DefineProperties(Filer: TFiler);
begin
inherited;
Filer.DefineProperty('PropertiesClassName', ReaderProc, WriterProc, FPropertiesClassName <> '');
end;
to this:
procedure TSearchField.DefineProperties(Filer: TFiler);
begin
Filer.DefineProperty('PropertiesClassName', ReaderProc, WriterProc, FPropertiesClassName <> '');
inherited DefineProperties(Filer);
end;
Basically, call the inherited method AFTER you have defined your own property.
Note that I also specified which inherited method is called. I know it's not required, but it makes intent clearer and allows for Ctrl-Click navigation.

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;

Use DefineProperties to replace TPersistent properties e.g. TFont

I'm updating some properties in a component. In order to avoid missing property errors I'm using DefineProperties to read the old properties from the stream. Most properties work fine e.g. Integer, but I can't get properties based on TPersistent to work. The ReadProperty(TPersistent) procedure in TReader is protected, not public and requires a hack to access it. Even then, the ReadFontProperty procedure is never called and the missing property exception occurs.
How do I read the TFont property?
Here's some sample code of how I'm trying to do it.
...
type
TMyComponent = class(TComponent)
strict private
// Removed
//FIntegerProperty: Integer;
//FFontProperty: TFont;
// New
FNewIntegerProperty: Integer;
FNewFontProperty: TFont;
procedure ReadIntegerProperty(Reader: TReader);
procedure ReadFontProperty(Reader: TReader);
protected
procedure DefineProperties(Filer: TFiler); override;
published
// Removed properties
//property IntegerProperty: Integer read FIntegerProperty write FIntegerProperty;
//property FontProperty: TFont read FFontProperty write SetFontProperty;
// New properties
property NewIntegerProperty: Integer read FNewIntegerProperty write FNewIntegerProperty;
property NewFontProperty: TFont read FNewFontProperty write SetNewFontProperty;
end;
implementation
procedure TMyComponent.DefineProperties(Filer: TFiler);
begin
inherited;
// This works
Filer.DefineProperty('IntegerProperty', ReadIntegerProperty, nil, FALSE);
// This doesn't
Filer.DefineProperty('FontProperty', ReadFontProperty, nil, FALSE);
end;
procedure TMyComponent.ReadIntegerProperty(Reader: TReader);
begin
FNewIntegerProperty:= Reader.ReadInteger;
end;
type
THackReader = class(TReader);
procedure TMyComponent.ReadFontProperty(Reader: TReader);
begin
{ TODO : This doesn't work. How do we read fonts? }
THackReader(Reader).ReadProperty(FNewFontProperty);
end;
...
Update 1
Tried David's suggestion using the following code:
Filer.DefineProperty('Font.CharSet', ReadFontCharSet, nil, False);
...
procedure TMyComponent.ReadFontCharSet(Reader: TReader);
begin
Reader.ReadInteger;
end;
I get an Invalid Property Value error. I guess it's something to do with Charset being of type TFontCharset (= System.UITypes.TFontCharset = 0..255). How do I read this type of property?
In order to do this you need to work with each individual published property of TFont and you will need to use fully qualified names.
Filer.DefineProperty('FontProperty.Name', ReadFontName, nil, False);
Filer.DefineProperty('FontProperty.Height', ReadFontHeight, nil, False);
Filer.DefineProperty('FontProperty.Size', ReadFontSize, nil, False);
// and so on for all the other published properties of TFont
ReadFontName, ReadFontHeight etc. should read the old property values into the newly named component.
procedure TMyComponent.ReadFontName(Reader: TReader);
begin
FNewFontProperty.Name := Reader.ReadString;
end;
// etc. etc.
Update
You ask how to read the Charset property. This is complex because it can be written either as a textual identifier (see the FontCharsets constant in Graphics.pas), or as a plain integer value. Here is some rapidly hacked together code that will read your Charset.
procedure TMyComponent.ReadFontCharset(Reader: TReader);
function ReadIdent: string;
var
L: Byte;
LResult: AnsiString;
begin
Reader.Read(L, SizeOf(Byte));
SetString(LResult, PAnsiChar(nil), L);
Reader.Read(LResult[1], L);
Result := UTF8ToString(LResult);
end;
function ReadInt8: Shortint;
begin
Reader.Read(Result, SizeOf(Result));
end;
function ReadInt16: Smallint;
begin
Reader.Read(Result, SizeOf(Result));
end;
var
Ident: string;
CharsetOrdinal: Integer;
begin
Beep;
case Reader.ReadValue of
vaIdent:
begin
Ident := ReadIdent;
if not IdentToCharset(Ident, CharsetOrdinal) then begin
raise EReadError.Create('Could not read MyFont.Charset');
end;
FNewFontProperty.Charset := CharsetOrdinal;
end;
vaInt8:
FNewFontProperty.Charset := ReadInt8;
vaInt16:
FNewFontProperty.Charset := ReadInt16;
else
raise EReadError.Create('Could not read FontProperty.Charset');
end;
end;

Enumerate global methods of a unit using delphi

suppose i have a unit like this
unit sample;
interface
function Test1:Integer;
procedure Test2;
implementation
function Test1:Integer;
begin
result:=0;
end;
procedure Test2;
begin
end;
end.
Is possible enumerate all the procedures and functions of the unit sample in runtime?
No. RTTI is not generated for standalone methods. Hopefully this will be fixed in a later version, (they'd probably need a TRttiUnit type to do that,) but for now it's not available.
You could extract that information from some kind of debug info (TD32, Map file, Jdbg, etc.) using JCL and their great JclDebug.pas.
Try this:
uses
JclDebug;
type
TProc = record
name: string;
addr: Pointer;
end;
TProcArray = array of TProc;
TMapLoader = class
private
FModule: Cardinal;
FProcs: TProcArray;
FMapFileName: string;
FUnitName: string;
procedure HandleOnPublicsByValue(Sender: TObject; const Address: TJclMapAddress; const Name: string);
public
constructor Create(const AFileName: string; AModule: Cardinal; const AUnitName: string);
procedure Scan();
property Procs: TProcArray read FProcs;
end;
constructor TMapLoader.Create(const AFileName: string; AModule: Cardinal; const AUnitName: string);
begin
inherited Create;
FMapFileName := AFileName;
FModule := AModule;
FUnitName := AUnitName;
end;
procedure TMapLoader.HandleOnPublicsByValue(Sender: TObject; const Address: TJclMapAddress; const Name: string);
var
l: Integer;
begin
if Pos(FUnitName + '.', Name) = 1 then
begin
l := Length(FProcs);
SetLength(FProcs, l + 1);
FProcs[l].name := Name;
FProcs[l].addr := Pointer(Address.Offset + FModule + $1000);
end;
end;
procedure TMapLoader.Scan();
var
parser: TJclMapParser;
begin
parser := TJclMapParser.Create(FMapFileName, FModule);
try
parser.OnPublicsByValue := HandleOnPublicsByValue;
parser.Parse;
finally
parser.Free;
end;
end;
I don't think so.
That is a compile-time config, it's used so as the compiler knows which function name is being called or not. As far as I know, there is nothing at runtime which comes close to listing these functions.
Delphi's excellent runtime features come from RTTI, you might want to see what it offers in relation to this. But as I said, I don't think it's possible (know that I've delved in RTTI for quite some time...).
Edit: Oh and by the way, after compilation, functions lose their human-readable names (to addresses). There are some tables which pinpoint those names to addresses, most notably, RTTI and the Debug info.

Resources