Is it possible to have a get and set value for TMyRecord when you have the name of the record member? something similar to RTTI.
I cannot use an array as the members may have different data types.
type
TMyRecord = record
X: Integer;
Y: Integer;
Z: DateTime;
end;
var MyRecord: TMyRecord;
procedure UpdateValue(aRecordMemberName: string; AValue: Integer);
begin
MyRecord[aRecordmemberName] := AValue;
end;
function GetValue(aRecordMemberName: string): Integer;
begin
Result := MyRecord[aRecordmemberName];
end;
procedure Main();
begin
SetValue('X', 5);
showmessage( GetValue('Y').ToString );
end;
On an additional note, is it possible to iterate through all members of a Record, similar to iterating through TFields or TFieldDefs?
thanks.
Using Delphi 11 in Firemonkey
If you have a fixed number of fields of different types, it is somewhat strange that you need to access these by string names. Still, let's assume this is the right thing to do.
RTTI is a bit complicated (meaning that you need to write "many" lines of code) and rather slow. Sure, it will probably be fast enough in your case, so it will probably be good enough. But it isn't ideal.
In my experience, people are often too eager to resort to RTTI. In most cases, there are better solutions.
One non-RTTI solution would be to use a TDictionary<string, Variant>.
Another would be like this:
type
EFrogException = class(Exception);
TFrogProperty = (fpName, fpBirthDate, fpWeight);
TFrogPropertyHelper = record helper for TFrogProperty
strict private
const PropNames: array[TFrogProperty] of string = ('Name', 'Birth date', 'Weight');
public
function ToString: string;
class function FromString(const APropName: string): TFrogProperty; static;
end;
TFrog = record
strict private
FProperties: array[TFrogProperty] of Variant;
private
function GetProp(Prop: TFrogProperty): Variant;
procedure SetProp(Prop: TFrogProperty; const Value: Variant);
function GetPropByName(APropName: string): Variant;
procedure SetPropByName(APropName: string; const Value: Variant);
public
property Prop[Prop: TFrogProperty]: Variant read GetProp write SetProp;
property PropByName[Prop: string]: Variant read GetPropByName write SetPropByName; default;
end;
where
{ TFrogPropertyHelper }
class function TFrogPropertyHelper.FromString(
const APropName: string): TFrogProperty;
begin
for var Prop := Low(TFrogProperty) to High(TFrogProperty) do
if SameText(Prop.ToString, APropName) then
Exit(Prop);
raise EFrogException.CreateFmt('Invalid frog property: "%s".', [APropName]);
end;
function TFrogPropertyHelper.ToString: string;
begin
if InRange(Ord(Self), Ord(Low(TFrogProperty)), Ord(High(TFrogProperty))) then
Result := PropNames[Self]
else
Result := '';
end;
{ TFrog }
function TFrog.GetProp(Prop: TFrogProperty): Variant;
begin
Result := FProperties[Prop];
end;
function TFrog.GetPropByName(APropName: string): Variant;
begin
Result := Prop[TFrogProperty.FromString(APropName)];
end;
procedure TFrog.SetProp(Prop: TFrogProperty; const Value: Variant);
begin
FProperties[Prop] := Value;
end;
procedure TFrog.SetPropByName(APropName: string; const Value: Variant);
begin
Prop[TFrogProperty.FromString(APropName)] := Value;
end;
Then you can do things like this:
procedure TForm1.FormCreate(Sender: TObject);
begin
var James: TFrog;
James['Name'] := 'James';
James['Birth date'] := EncodeDate(2016, 05, 10);
James['Weight'] := 2.4;
ShowMessage(James['Name']);
James['Name'] := 'Sir James';
ShowMessage(James['Name']);
// And you can still be type safe if you want to:
James.Prop[fpName] := 'Sir James Doe';
ShowMessage(James.Prop[fpName]);
end;
Related
Let suppose I have dynamic array
type TCharArr = Array of byte;
type PcharArr = ^TCharArr;
var charArr: PcharArr;
Which I want to allocate memory in Heap in the way of New(charArr);
However, how can I specify size and indexes? Is it possible dynamic array to have indexes eg. from 512.. to 1024?
Assuming a more recent Delphi version, you can mimic that with a generic record:
type
TDynArray<T> = record
private
FData: TArray<T>;
FOffset: Integer;
function GetData(Index: Integer): T;
function GetHigh: Integer;
function GetLength: Integer;
function GetLow: Integer;
procedure SetData(Index: Integer; const Value: T);
public
constructor Create(ALow, AHigh: Integer);
property Data[Index: Integer]: T read GetData write SetData; default;
property High: Integer read GetHigh;
property Length: Integer read GetLength;
property Low: Integer read GetLow;
end;
constructor TDynArray<T>.Create(ALow, AHigh: Integer);
begin
FOffset := ALow;
SetLength(FData, AHigh - ALow + 1);
end;
function TDynArray<T>.GetData(Index: Integer): T;
begin
Result := FData[Index - FOffset];
end;
function TDynArray<T>.GetHigh: Integer;
begin
Result := FOffset + System.High(FData);
end;
function TDynArray<T>.GetLength: Integer;
begin
Result := System.Length(FData);
end;
function TDynArray<T>.GetLow: Integer;
begin
Result := FOffset;
end;
procedure TDynArray<T>.SetData(Index: Integer; const Value: T);
begin
FData[Index - FOffset] := Value;
end;
The usage could look then like this:
var
arr: TDynArray<Integer>;
I: Integer;
begin
arr := TDynArray<Integer>.Create(512, 1024);
for I := arr.Low to arr.High do
arr[I] := I;
for I := arr.Low to arr.High do
Writeln(I, '=', arr[I]);
Readln;
end;
Dynamic arrays are always zero based. If you want to use array indices with a different base, then you would need to encapsulate the array access accounting for the offset to the indices. Something like this:
const
Offset = 512;
function GetValue(Index: Integer): Byte;
begin
Result := Arr[Index - Offset];
end;
procedure SetValue(Index: Integer; Value: Byte);
begin
Arr[Index - Offset] := Value;
end;
In addition there is the concept of a sparse array (sparse matrix). Delphi does not support it out of the box, but there were implementations in TurboPower SysTools, if I remember correctly.
The source was put on SourceForge, when the company closed about 15 years ago:
https://sourceforge.net/projects/tpsystools/
But these have not been updated for a looooong time.
This also seems to be the same library, maybe a bit more up to date:
https://github.com/TurboPack/SysTools
Can the object of (TObjectList) know when some values of (TMyObject) was changed?
Some example:
TMyObject = class
oName: string;
end;
TMyObjectList = class(TObjectList<TMyObject>)
end;
procedure Form1.Button1.Click(Sender: TObject);
var
Obj: TMyObject;
List: TMyObjectList;
Begin
List:= TMyObjectList.Create;
Obj:= TMyObject.Create;
List.Add(Obj);
List[0].oName:= 'Test'; // here a want to know from var (List) when this object (Obj or List[0]) changed his value..
end;
Thanks for any help.
I just added the TObservableList<T> type to Spring4D (feature/observablelist branch). It is mostly modeled after .NET and uses the INotifyPropertyChanged interface to attach its event handler to any objects that support it. This class has been part of DSharp for quite some time and is used in production. It might change a bit in the future and become full part of the library.
Here is a small example how to use it so you get an idea:
program Project60;
{$APPTYPE CONSOLE}
uses
Spring,
Spring.Collections,
SysUtils;
type
TNotifyPropertyChangedBase = class(TInterfaceBase, INotifyPropertyChanged)
private
fOnPropertyChanged: Event<TPropertyChangedEvent>;
function GetOnPropertyChanged: IPropertyChangedEvent;
protected
procedure PropertyChanged(const propertyName: string);
end;
TMyObject = class(TNotifyPropertyChangedBase)
private
fName: string;
procedure SetName(const Value: string);
public
property Name: string read fName write SetName;
end;
TMain = class
procedure ListChanged(Sender: TObject; const item: TMyObject;
action: TCollectionChangedAction);
end;
{ TNotifyPropertyChangedBase }
function TNotifyPropertyChangedBase.GetOnPropertyChanged: IPropertyChangedEvent;
begin
Result := fOnPropertyChanged;
end;
procedure TNotifyPropertyChangedBase.PropertyChanged(
const propertyName: string);
begin
fOnPropertyChanged.Invoke(Self,
TPropertyChangedEventArgs.Create(propertyName) as IPropertyChangedEventArgs);
end;
{ TMyObject }
procedure TMyObject.SetName(const Value: string);
begin
fName := Value;
PropertyChanged('Name');
end;
{ TMain }
procedure TMain.ListChanged(Sender: TObject; const item: TMyObject;
action: TCollectionChangedAction);
begin
case action of
caAdded: Writeln('item added ', item.Name);
caRemoved, caExtracted: Writeln('item removed ', item.Name);
caChanged: Writeln('item changed ', item.Name);
end;
end;
var
main: TMain;
list: IList<TMyObject>;
o: TMyObject;
begin
list := TCollections.CreateObservableList<TMyObject>;
list.OnChanged.Add(main.ListChanged);
o := TMyObject.Create;
o.Name := 'o1';
list.Add(o);
o := TMyObject.Create;
o.Name := 'o2';
list.Add(o);
list[1].Name := 'o3';
Readln;
end.
There is nothing built in that can do what you ask. You will need to implement a notification mechanism yourself. This is the classic scenario for the Observer Pattern.
There are many implementations of this pattern already in existence. One obvious choice would be to use the implementation in Spring4D. Nick Hodges recent book, More Coding in Delphi, includes a chapter on this pattern which I would recommend.
Found the way, how to call method of TObjectList from TMyObject. Using TNotifyEvent in base Object.
Example:
TMyClass = class(TObject)
private
FName: string;
FOnNameEvent: TNotifyEvent;
procedure SetName(value: string);
public
property Name: string read FName write SetName;
property OnNameEvent: TNotifyEvent read FOnNameEvent write FOnNameEvent;
end;
procedure TMyClass.SetName(value: string);
begin
FName := value;
if Assigned(FOnNameEvent) then
FOnNameEvent(Self);
end;
procedure MyNameEvent(Sender: TObject);
var
i: Integer;
begin
for i := 0 to MyListOfMyClassObjects.Count -1 do
if Sender = MyListOfMyClassObjects.Item[i] then
begin
MessageBox(0, PChar(TMyClass(MyListOfMyClassObjects.Item[i]).Name), nil, MB_OK);
break;
end;
end;
procedure MyProc;
var
MyObject: TMyClass;
begin
MyObject := TMyClass.Create;
MyObject.OnNameEvent := MyNameEvent;
MyListOfMyClassObjects.Add(MyObject);
end;
When I use TObjectDictionary, where TKey is object, my application work uncorrectly.
I have two units, thats contain two classes. First unit:
unit RubTerm;
interface
type
TRubTerm = Class(TObject)
private
FRubricName: String;
FTermName: String;
public
property RubricName: String read FRubricName;
property TermName: String read FTermName;
constructor Create(ARubricName, ATermName: String);
end;
implementation
constructor TRubTerm.Create(ARubricName, ATermName: String);
begin
Self.FRubricName := ARubricName;
Self.FTermName := ATermName;
end;
end;
And second unit:
unit ClassificationMatrix;
interface
uses
System.Generics.Collections, System.Generics.Defaults, System.SysUtils, RubTerm;
type
TClassificationMatrix = class(TObject)
private
FTable: TObjectDictionary<TRubTerm, Integer>;
public
constructor Create;
procedure TClassificationMatrix.AddCount(ADocsCount: Integer; ARubName, ATermName: String);
function TClassificationMatrix.GetCount(ARubName, ATermName: String): Integer;
end;
implementation
constructor TClassificationMatrix.Create;
begin
FTable := TObjectDictionary<TRubTerm, Integer>.Create;
end;
procedure TClassificationMatrix.AddCount(ADocsCount: Integer; ARubName, ATermName: String);
var
ARubTerm: TRubTerm;
begin
ARubTerm := TRubTerm.Create(ARubName, ATermName);
FTable.Add(ARubTerm, ADocsCount);
end;
function TClassificationMatrix.GetCount(ARubName, ATermName: String): Integer;
var
ARubTerm: TRubTerm;
begin
ARubTerm := TRubTerm.Create(ARubName, ATermName);
FTable.TryGetValue(ARubTerm, Result);
end;
end;
But this fragment of code work unnormal:
procedure TestTClassificationMatrix.TestGetCount;
var
DocsCountTest: Integer;
begin
FClassificationMatrix.AddCount(10, 'R', 'T');
DocsCountTest := FClassificationMatrix.GetCount('R', 'T');
end;
// DocsCountTest = 0! Why not 10? Where is problem?
Thanks!
The fundamental issue here is that the default equality comparer for your type does not behave the way you want it to. You want equality to mean value equality, but the default comparison gives reference equality.
The very fact that you are hoping for value equality is a strong indication that you should be using a value type rather than a reference type. And that's the first change that I would suggest.
type
TRubTerm = record
RubricName: string;
TermName: string;
class function New(const RubricName, TermName: string): TRubTerm; static;
class operator Equal(const A, B: TRubTerm): Boolean;
class operator NotEqual(const A, B: TRubTerm): Boolean;
end;
class function TRubTerm.New(const RubricName, TermName: string): TRubTerm;
begin
Result.RubricName := RubricName;
Result.TermName := TermName;
end;
class operator TRubTerm.Equal(const A, B: TRubTerm): Boolean;
begin
Result := (A.RubricName=B.RubricName) and (A.TermName=B.TermName);
end;
class operator TRubTerm.NotEqual(const A, B: TRubTerm): Boolean;
begin
Result := not (A=B);
end;
I've added TRubTerm.New as a helper method to make it easy to initialize new instances of the record. And for convenience, you may also find it useful to overload the equality and inequality operators, as I have done above.
Once you switch to a value type, then you would also change the dictionary to match. Use TDictionary<TRubTerm, Integer> instead of TObjectDictionary<TRubTerm, Integer>. Switching to a value type will also have the benefit of fixing all the memory leaks in your existing code. Your existing code creates objects but never destroys them.
This gets you part way home, but you still need to define an equality comparer for your dictionary. The default comparer for a record will be based on reference equality since strings, despite behaving as value types, are stored as references.
To make a suitable equality comparer you need to implement the following comparison functions, where T is replaced by TRubTerm:
TEqualityComparison<T> = reference to function(const Left, Right: T): Boolean;
THasher<T> = reference to function(const Value: T): Integer;
I'd implement these as static class methods of the record.
type
TRubTerm = record
RubricName: string;
TermName: string;
class function New(const RubricName, TermName: string): TRubTerm; static;
class function EqualityComparison(const Left,
Right: TRubTerm): Boolean; static;
class function Hasher(const Value: TRubTerm): Integer; static;
class operator Equal(const A, B: TRubTerm): Boolean;
class operator NotEqual(const A, B: TRubTerm): Boolean;
end;
Implementing EqualityComparison is easy enough:
class function TRubTerm.EqualityComparison(const Left, Right: TRubTerm): Boolean;
begin
Result := Left=Right;
end;
But the hasher requires a little more thought. You need to hash each field individually and then combine the hashes. For reference:
Quick and Simple Hash Code Combinations
What is the canonical way to write a hasher function for TEqualityComparer.Construct?
The code looks like this:
{$IFOPT Q+}
{$DEFINE OverflowChecksEnabled}
{$Q-}
{$ENDIF}
function CombinedHash(const Values: array of Integer): Integer;
var
Value: Integer;
begin
Result := 17;
for Value in Values do begin
Result := Result*37 + Value;
end;
end;
{$IFDEF OverflowChecksEnabled}
{$Q+}
{$ENDIF}
function GetHashCodeString(const Value: string): Integer;
begin
Result := BobJenkinsHash(PChar(Value)^, SizeOf(Char) * Length(Value), 0);
end;
class function TRubTerm.Hasher(const Value: TRubTerm): Integer;
begin
Result := CombinedHash([GetHashCodeString(Value.RubricName),
GetHashCodeString(Value.TermName)]);
end;
Finally, when you instantiate your dictionary, you need to provide an IEqualityComparison<TRubTerm>. Instantiate your dictionary like this:
Dict := TDictionary<TRubTerm,Integer>.Create(
TEqualityComparer<TRubTerm>.Construct(
TRubTerm.EqualityComparison,
TRubTerm.Hasher
)
);
A Dictionary depends on a key value. You are storing a reference to an object in the key. If you create two objects that are setup identically the have different values and hence different keys.
var
ARubTerm1: TRubTerm;
ARubTerm2: TRubTerm;
begin
ARubTerm1 := TRubTerm.Create('1', '1');
ARubTerm2 := TRubTerm.Create('1', '1');
// ARubTerm1 = ARubTerm2 is not possible here as ARubTerm1 points to a different address than ARubTerm2
end;
Instead you could uses a String as the First Type Parameter in the TObjectDictonary that is based on RubricName and TermName. With this you would then get back the same value.
It should also be noted, that above code in XE2 creates two memory leaks. Every object created must be freed. Hence this section of code also is leaking memory
function TClassificationMatrix.GetCount(ARubName, ATermName: String): Integer;
var
ARubTerm: TRubTerm;
begin
ARubTerm := TRubTerm.Create(ARubName, ATermName);
FTable.TryGetValue(ARubTerm, Result);
end;
Given all of that. If you want to use an Object as a Key you can do it with a Custom Equality Comparer. Here is your example changed to implement IEqualityComparer<T>, and fix a few memory leaks.
unit ClassificationMatrix;
interface
uses
Generics.Collections, Generics.Defaults, SysUtils, RubTerm;
type
TClassificationMatrix = class(TObject)
private
FTable: TObjectDictionary<TRubTerm, Integer>;
public
constructor Create;
procedure AddCount(ADocsCount: Integer; ARubName, ATermName: String);
function GetCount(ARubName, ATermName: String): Integer;
end;
implementation
constructor TClassificationMatrix.Create;
var
Comparer : IEqualityComparer<RubTerm.TRubTerm>;
begin
Comparer := TRubTermComparer.Create;
FTable := TObjectDictionary<TRubTerm, Integer>.Create([doOwnsKeys],TRubTermComparer.Create);
end;
procedure TClassificationMatrix.AddCount(ADocsCount: Integer; ARubName, ATermName: String);
var
ARubTerm: TRubTerm;
begin
ARubTerm := TRubTerm.Create(ARubName, ATermName);
FTable.Add(ARubTerm, ADocsCount);
end;
function TClassificationMatrix.GetCount(ARubName, ATermName: String): Integer;
var
ARubTerm: TRubTerm;
begin
ARubTerm := TRubTerm.Create(ARubName, ATermName);
try
if Not FTable.TryGetValue(ARubTerm, Result) then
result := 0;
finally
ARubTerm.Free;
end;
end;
end.
And the RubTerm.pas unit
unit RubTerm;
interface
uses Generics.Defaults;
type
TRubTerm = Class(TObject)
private
FRubricName: String;
FTermName: String;
public
property RubricName: String read FRubricName;
property TermName: String read FTermName;
constructor Create(ARubricName, ATermName: String);
function GetHashCode: Integer; override;
end;
TRubTermComparer = class(TInterfacedObject, IEqualityComparer<TRubTerm>)
public
function Equals(const Left, Right: TRubTerm): Boolean;
function GetHashCode(const Value: TRubTerm): Integer;
end;
implementation
constructor TRubTerm.Create(ARubricName, ATermName: String);
begin
Self.FRubricName := ARubricName;
Self.FTermName := ATermName;
end;
{ TRubTermComparer }
function TRubTermComparer.Equals(const Left, Right: TRubTerm): Boolean;
begin
result := (Left.RubricName = Right.RubricName) and (Left.TermName = Right.TermName);
end;
function TRubTermComparer.GetHashCode(const Value: TRubTerm): Integer;
begin
result := Value.GetHashCode;
end;
//The Hashing code was taken from David's Answer to make this a complete answer.
{$IFOPT Q+}
{$DEFINE OverflowChecksEnabled}
{$Q-}
{$ENDIF}
function CombinedHash(const Values: array of Integer): Integer;
var
Value: Integer;
begin
Result := 17;
for Value in Values do begin
Result := Result*37 + Value;
end;
end;
{$IFDEF OverflowChecksEnabled}
{$Q+}
{$ENDIF}
function GetHashCodeString(const Value: string): Integer;
begin
Result := BobJenkinsHash(PChar(Value)^, SizeOf(Char) * Length(Value), 0);
end;
function TRubTerm.GetHashCode: Integer;
begin
Result := CombinedHash([GetHashCodeString(Value.RubricName),
GetHashCodeString(Value.TermName)]);
end;
end.
I have a Delphi generic class that exposes a function with an argument of the generic type. Inside this function, I need to pass an instance of the generic type on to another object expecting a Variant type. Similar to this:
type
IMyInterface = interface
DoStuff(Value: Variant);
end;
TMyClass<T> = class
FMyIntf: IMyInterface
procedure DoStuff(SomeValue: T);
end;
[...]
procedure MyClass<T>.DoStuff(SomeValue: T);
begin
FMyIntf.DoStuff((*convert SomeValue to Variant here*));
end;
I tried using Rtti.TValue.From(SomeValue).AsVariant. This worked for integral types, but blew up for Booleans. I don't quite see why, since normally I'd be able to assign a Boolean value to a Variant...
Is there a better way to make this conversion? I only need it to work for simple built-in types (excluding enumerations and records)
I think there is no direct way to convert generic type to variant because variant cannot hold all the possible types. You must write your specific conversion routine. E.g.:
interface
//...
type
TDemo = class
public
class function GetAsVariant<T>(const AValue: T): Variant;
end;
//...
implementation
uses
Rtti,
TypInfo;
//...
{ TDemo}
class function TDemo.GetAsVariant<T>(const AValue: T): Variant;
var
val: TValue;
bRes: Boolean;
begin
val := TValue.From<T>(AValue);
case val.Kind of
tkInteger: Result := val.AsInteger;
tkInt64: Result := val.AsInt64;
tkEnumeration:
begin
if val.TryAsType<Boolean>(bRes) then
Result := bRes
else
Result := val.AsOrdinal;
end;
tkFloat: Result := val.AsExtended;
tkString, tkChar, tkWChar, tkLString, tkWString, tkUString:
Result := val.AsString;
tkVariant: Result := val.AsVariant
else
begin
raise Exception.Create('Unsupported type');
end;
end;
end;
Because TValue.AsVariant handles most of the type conversions internally, this function can be simplified. I will handle enumerations in case you could need them later:
class function TDemo.GetAsVariant<T>(const AValue: T): Variant;
var
val: TValue;
begin
val := TValue.From<T>(AValue);
case val.Kind of
tkEnumeration:
begin
if val.TypeInfo = TypeInfo(Boolean) then
Result := val.AsBoolean
else
Result := val.AsOrdinal;
end
else
begin
Result := val.AsVariant;
end;
end;
Possible usage:
var
vValue: Variant;
begin
vValue := TDemo.GetAsVariant<Boolean>(True);
Assert(vValue = True); //now vValue is a correct Boolean
Looks like in my Delphi version 10.2 the Boolean problem is gone and TValue.From<T>(FValue).AsVariant is enough.
Here an example with some other helpful things like comparing the generic type:
TMyValue<T> = class(TPersistent)
private
FValue: T;
procedure SetValue(const AValue: T);
function GetAsVariant: Variant; override;
public
procedure Assign(Source: TPersistent); override;
property Value: T read FValue write SetValue;
property AsVariant: Variant read GetAsVariant;
end;
function TMyValue<T>.GetAsVariant: Variant;
begin
Result:= TValue.From<T>(FValue).AsVariant;
end;
procedure TMyValue<T>.SetValue(const AValue: T);
begin
if TEqualityComparer<T>.Default.Equals(AValue, FValue) then Exit;
FValue:= AValue;
//do something
end;
procedure TMyValue<T>.Assign(Source: TPersistent);
begin
if Source is TMyValue<T> then Value:= (Source as TMyValue<T>).Value
else inherited;
end;
Another way (tested XE10)
Var
old : variant;
val : TValue;
Begin
val := TValue.FromVariant(old);
End;
From the research I've done so far, I'm already guessing the answer is no but just to make sure... (also, this entry can be updated once support for this is available).
The question title should already be self-sufficient I think, but FWIW what I'm trying to do is this: I have a configuration framework built around record constants: Every configuration option available in my app is defined in a central place in the form of a typed constant, which contains the name of the registry (or INI) key, its data type and its default value. These constants are what I pass to the accessor methods in my framework which then implements the necessary logic for retrieving and storing the option values.
I'd now like to extend the information in those records to also include meta data that I can use to auto-generate ADM/ADMX files (ifdef'ed out in the release builds) describing those options.
But for that I'd need to be able to enumerate those constants, unless I add some sort of explicit registration mechanism which seems like unnecessary duplication.
Ideally, instead of adding additional fields to the record type I would have preferred to declare the meta info in the form of attributes but those cannot (yet?) be applied to constants. Also, this wouldn't change anything about the necessity of enumerating the constants in the first place.
Assuming that this currently isn't possible via RTTI, I will probably consider putting the meta data into comments and somehow parsing that out. That'll likely be another question here.
[platform info: currently using Delphi 2010, but I already have an XE license - just didn't have time to install it, yet]
Long answer coming up .... :-)
Instead of trying to enumerate global constants, you might want to try a different approach to what you're doing.
Some time ago, Robert Love had a very interesting idea.
He uses custom attributes and RTTI to specify how to store and retrieve values from a .ini file.
In his blog he's got a great explanation on how it works:
http://robstechcorner.blogspot.com/2009/10/ini-persistence-rtti-way.html
I've expanded on that a bit in the code below:
You can now have other types than strings only (string, integer, double, boolean).
You can specify a default value in your attributes.
There's a base settings class to inherit from. You can set a filename for the inifile here, and it does loading and saving for you.
Base AppSettings class.. TAppSettings automatically stores settings in a file in this format: <yourappname>.config.ini
Example... When I want to have database settings stored in an ini file, all I need to do is instantiate a TDbSettings. You don't need to know how or where the values are actually stored, and access is really fast.
var
DbSettings : TDbSettings
begin
DbSettings := TDbSettings.Create;
try
// show some settings
WriteLn(DbSettings.Host);
WriteLn(DbSettings.Port);
// write setting
DbSettings.UserName := 'Me';
// store it in the ini file
DbSettings.Save;
finally
DbSettings.Free;
end;
end;
If you want to specify a new set of settings, it's really easy.
TServiceSettings=class(TAppSettings)
public
[IniValue('Service','Description','MyServiceDesc')]
ServiceDescription: String;
[IniValue('Service','DisplayName','MyServiceName')]
ServiceDisplayName: String;
end;
This is so much cleaner than directly reading and writing an inifile. Robert, if you read this: thanks for making my life much easier!
Here's the updated code:
unit WvN.Configuration.Persist.Ini;
// MIT License
//
// Copyright (c) 2009 - Robert Love
//
// Permission is hereby granted, free of charge, to any person obtaining a copy
// of this software and associated documentation files (the "Software"), to deal
// in the Software without restriction, including without limitation the rights
// to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
// copies of the Software, and to permit persons to whom the Software is
// furnished to do so, subject to the following conditions:
//
// The above copyright notice and this permission notice shall be included in
// all copies or substantial portions of the Software.
//
// 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 OR COPYRIGHT HOLDERS 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
//
// Wouter van Nifterick: 2010-11: added TSettings abstract class and some derivatives to load database and cs settings
interface
uses SysUtils,Classes, Rtti,TypInfo;
type
IniValueAttribute = class(TCustomAttribute)
private
FName: string;
FDefaultValue: string;
FSection: string;
public
constructor Create(const aSection : String;const aName : string;const aDefaultValue : Integer = 0);overload;
constructor Create(const aSection : String;const aName : string;const aDefaultValue : Double = 0.0);overload;
constructor Create(const aSection : String;const aName : string;const aDefaultValue : Boolean = false);overload;
constructor Create(const aSection : String;const aName : string;const aDefaultValue : String = '');overload;
property Section : string read FSection write FSection;
property Name : string read FName write FName;
property DefaultValue : string read FDefaultValue write FDefaultValue;
end;
EIniPersist = class(Exception);
TIniPersist = class (TObject)
private
class procedure SetValue(aData : String;var aValue : TValue);
class function GetValue(var aValue : TValue) : String;
class function GetIniAttribute(Obj : TRttiObject) : IniValueAttribute;
public
class procedure Load(FileName : String;obj : TObject);
class procedure Save(FileName : String;obj : TObject);
end;
TSettings=class abstract(TComponent)
private
FOnChange: TNotifyEvent;
FFileName:String;
procedure SetOnChange(const Value: TNotifyEvent);
function GetFileName: String;virtual;
procedure SetFileName(const Value: String);virtual;
public
property FileName:String read GetFileName write SetFileName;
procedure CreateDefaults;
procedure Load;virtual;
procedure Save;virtual;
constructor Create(AOwner: TComponent); override;
procedure DoOnChange;
property OnChange:TNotifyEvent read FOnChange write SetOnChange;
end;
TAppSettings=class abstract(TSettings)
function GetFileName: String;override;
end;
TServiceSettings=class(TAppSettings)
public
[IniValue('Service','Description','')]
ServiceDescription: String;
[IniValue('Service','DisplayName','')]
ServiceDisplayName: String;
end;
TCsSettings=class(TAppSettings)
public
[IniValue('CS','SourceAppId',9999)]
SourceAppId: LongWord;
[IniValue('CS','SourceCSId',9999)]
SourceCSId: LongWord;
[IniValue('CS','Host','Localhost')]
Host: String;
[IniValue('CS','Port',42000)]
Port: LongWord;
[IniValue('CS','ReconnectInvervalMs',30000)]
ReconnectInvervalMs: Integer;
end;
TFTPSettings=class(TAppSettings)
public
[IniValue('FTP','Host','Localhost')]
Host: String;
[IniValue('FTP','Port',21)]
Port: LongWord;
[IniValue('FTP','RemotePath','/')]
RemotePath: String;
[IniValue('FTP','LocalPath','.')]
LocalPath: String;
[IniValue('FTP','Username','')]
Username: String;
[IniValue('FTP','Password','')]
Password: String;
[IniValue('FTP','BlockSize',4096)]
BlockSize: Cardinal;
end;
TDbSettings=class(TAppSettings)
private
function GetURL: String;
public
[IniValue('DB','Host','Localhost')]
Host: String;
[IniValue('DB','Port',3306)]
Port: LongWord;
[IniValue('DB','Database','')]
Database: String;
[IniValue('DB','Username','root')]
Username: String;
[IniValue('DB','Password','')]
Password: String;
[IniValue('DB','Protocol','mysql-5')]
Protocol: String;
[IniValue('DB','UseSSL',True)]
UseSSL: Boolean;
[IniValue('DB','Compress',True)]
Compress: Boolean;
[IniValue('DB','TimeOutSec',0)]
TimeOutSec: Integer;
[IniValue('DB','SSL_CA','U:\Efkon2\AMM_mysql_cas.crt')]
SSL_CA: String;
[IniValue('DB','SSL_CERT','U:\Efkon2\AMM_ARS_mysql_user.pem')]
SSL_CERT: String;
[IniValue('DB','SSL_KEY','U:\Efkon2\AMM_ARS_mysql_user_key.pem')]
SSL_KEY: String;
property URL:String read GetURL;
end;
TPathSettings=class(TAppSettings)
public
[IniValue('Paths','StartPath','.')]
StartPath: String;
[IniValue('Paths','InPath','In')]
InPath: String;
[IniValue('Paths','OutPath','Out')]
OutPath: String;
[IniValue('Paths','ErrorPath','Error')]
ErrorPath: String;
end;
implementation
uses IniFiles;
{ TIniValue }
constructor IniValueAttribute.Create(const aSection, aName, aDefaultValue: String);
begin
FSection := aSection;
FName := aName;
FDefaultValue := aDefaultValue;
end;
{ TIniPersist }
class function TIniPersist.GetIniAttribute(Obj: TRttiObject): IniValueAttribute;
var
Attr: TCustomAttribute;
begin
for Attr in Obj.GetAttributes do
begin
if Attr is IniValueAttribute then
begin
exit(IniValueAttribute(Attr));
end;
end;
result := nil;
end;
class procedure TIniPersist.Load(FileName: String; obj: TObject);
var
ctx : TRttiContext;
objType : TRttiType;
Field : TRttiField;
Prop : TRttiProperty;
Value : TValue;
IniValue: IniValueAttribute;
Ini : TIniFile;
Data : string;
begin
ctx := TRttiContext.Create;
try
Ini := TIniFile.Create(FileName);
try
objType := ctx.GetType(Obj.ClassInfo);
for Prop in objType.GetProperties do
begin
IniValue := GetIniAttribute(Prop);
if Assigned(IniValue) then
begin
Data := Ini.ReadString(IniValue.Section, IniValue.Name, IniValue.DefaultValue);
Value := Prop.GetValue(Obj);
SetValue(Data, Value);
Prop.SetValue(Obj, Value);
end;
end;
for Field in objType.GetFields do
begin
IniValue := GetIniAttribute(Field);
if Assigned(IniValue) then
begin
Data := Ini.ReadString(IniValue.Section, IniValue.Name, IniValue.DefaultValue);
Value := Field.GetValue(Obj);
SetValue(Data, Value);
Field.SetValue(Obj, Value);
end;
end;
finally
Ini.Free;
end;
finally
ctx.Free;
end;
end;
class procedure TIniPersist.SetValue(aData: String;var aValue: TValue);
var
I : Integer;
begin
case aValue.Kind of
tkWChar,
tkLString,
tkWString,
tkString,
tkChar,
tkUString : aValue := aData;
tkInteger,
tkInt64 : aValue := StrToInt(aData);
tkFloat : aValue := StrToFloat(aData);
tkEnumeration: aValue := TValue.FromOrdinal(aValue.TypeInfo,GetEnumValue(aValue.TypeInfo,aData));
tkSet: begin
i := StringToSet(aValue.TypeInfo,aData);
TValue.Make(#i, aValue.TypeInfo, aValue);
end;
else raise EIniPersist.Create('Type not Supported');
end;
end;
class procedure TIniPersist.Save(FileName: String; obj: TObject);
var
ctx : TRttiContext;
objType : TRttiType;
Field : TRttiField;
Prop : TRttiProperty;
Value : TValue;
IniValue: IniValueAttribute;
Ini : TIniFile;
Data : string;
begin
ctx := TRttiContext.Create;
try
Ini := TIniFile.Create(FileName);
try
objType := ctx.GetType(Obj.ClassInfo);
for Prop in objType.GetProperties do
begin
IniValue := GetIniAttribute(Prop);
if Assigned(IniValue) then
begin
Value := Prop.GetValue(Obj);
Data := GetValue(Value);
Ini.WriteString(IniValue.Section, IniValue.Name, Data);
end;
end;
for Field in objType.GetFields do
begin
IniValue := GetIniAttribute(Field);
if Assigned(IniValue) then
begin
Value := Field.GetValue(Obj);
Data := GetValue(Value);
Ini.WriteString(IniValue.Section, IniValue.Name, Data);
end;
end;
finally
Ini.Free;
end;
finally
ctx.Free;
end;
end;
class function TIniPersist.GetValue(var aValue: TValue): string;
begin
if aValue.Kind in [tkWChar, tkLString, tkWString, tkString, tkChar, tkUString,
tkInteger, tkInt64, tkFloat, tkEnumeration, tkSet] then
result := aValue.ToString
else
raise EIniPersist.Create('Type not Supported');
end;
constructor IniValueAttribute.Create(const aSection, aName: string;
const aDefaultValue: Integer);
begin
FSection := aSection;
FName := aName;
FDefaultValue := IntToStr(aDefaultValue);
end;
constructor IniValueAttribute.Create(const aSection, aName: string;
const aDefaultValue: Double);
begin
FSection := aSection;
FName := aName;
FDefaultValue := FloatToStr(aDefaultValue);
end;
constructor IniValueAttribute.Create(const aSection, aName: string;
const aDefaultValue: Boolean);
begin
FSection := aSection;
FName := aName;
FDefaultValue := BoolToStr(aDefaultValue);
end;
{ TAppSettings }
procedure TSettings.CreateDefaults;
begin
Load;
Save;
end;
procedure TSettings.DoOnChange;
begin
if Assigned(FOnChange) then
FOnChange(Self)
end;
procedure TSettings.SetOnChange(const Value: TNotifyEvent);
begin
FOnChange := Value;
end;
{ TAppSettings }
function TAppSettings.GetFileName: String;
begin
Result := ChangeFileExt(ParamStr(0),'.config.ini')
end;
{ TSettings }
constructor TSettings.Create(AOwner: TComponent);
begin
inherited;
end;
function TSettings.GetFileName: String;
begin
Result := FFileName
end;
procedure TSettings.Load;
begin
TIniPersist.Load(FileName,Self);
DoOnChange;
end;
procedure TSettings.Save;
begin
TIniPersist.Save(FileName,Self);
end;
procedure TSettings.SetFileName(const Value: String);
begin
FFileName := Value
end;
{ TDbSettings }
function TDbSettings.GetURL: String;
begin
Result := Format('%s://%s:%s#%s:%d/%s?compress=%s&timeout=%d',
[
self.Protocol,
self.Username,
self.Password,
self.Host,
self.Port,
self.Database,
booltostr(self.Compress),
self.TimeOutSec
]);
end;
end.