Delphi TStringList as object field - delphi

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.

Related

TClientDataSet Custom compare field function

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;

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;

How can I avoid EInvalidPointer error when using TObjectDictionary in 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.

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