I have this object in mind:
TBaseObject = class
private
FEditState: string;
FID: integer;
public
constructor Create;
...
procedure Clone(AObject: TObject); virtual; //I actually want AObject to be generic
property EditState: string read FEditState write FEditState;
property ID: integer read FID write FID;
end;
constructor TBaseObject.Create;
begin
FEditState := 'none';
end;
Here is one descendant class:
TUser = class(TBaseObject)
private
FUsername: string;
public
procedure Clone(AObject: TObject); override;
property Username: string read FUsername write FUsername;
...
end;
...
procedure TUser.Clone(AObject: TObject);
begin
self.id := aobject.id;
...
end;
Then I make a container object as follows:
TBaseObjects<T:class> = class
private
FItems: TObjectList<T>;
FDeletedItems: TObjectList<T>;
function GetItem(Index: Integer): T;
public
function Add(NewItem: T=Default(T)): T; // adds to FItems
function DeleteItem(AObject: T): T; // save to FDeletedItems, delete from FItems
property Items[Index: Integer]: T read GetItem; default;
...
function TBaseObjects<T>.DeleteItem(AObject: T): T;
begin
result := T.Create;
result.Clone(AObject); // ERROR: no member Clone...
FItems.Remove(...);
end;
Used as:
TUsers = TBaseBOMList<TUser>;
var
Users: TUsers;
As can be seen, I try to save a copy of the item to be deleted into FDeletedItems generic list by using the descendant's clone method, then delete from FItems, but fails. The compiler say 'no member Clone'.
If what I'm doing can't be done, how is this supposed to be handled?
As suggested by Dalija, I declared TBaseObjects<T:TBaseObject> instead of TBaseObjects<T:class>.
For anybody curious or interested, the complete test program is available below.
Also, if someone can do this more efficiently with with pure polymorpism rather than generics as implied by DelphiCoder, I'd gladly reconsider, because as it is now, wthout Generics, I would have to declare and define one TBaseBOMList and duplicate every method for every base object (TUser, TRole, etc.) I want to use.
Code:
program ProjTestGenerics;
{$mode delphi}
uses
sysutils, TypInfo, generics.Collections;
type
{ TBaseBOM }
TBaseBOM = class
private
FEditState: string;
FID: integer;
public
constructor Create;
procedure Assign(src: TBaseBOM);
published
property EditState: string read FEditState write FEditState;
property ID: integer read FID write FID;
end;
{ TBaseBOMList }
TBaseBOMList<T:TBaseBOM> = class
private
FItems: TObjectList<T>;
FDeletedItems: TObjectList<T>;
function GetItem(Index: Integer): T;
public
constructor Create;
destructor Destroy; override;
function Add(NewItem: T=Default(T)): T;
function Delete(Index: Integer): Boolean;
function Find(APropertyName: string; const AValue: variant): Integer;
property Items[Index: Integer]: T read GetItem; default;
end;
{ TRole }
TRole = class(TBaseBOM)
private
FRolename: string;
public
procedure Assign( AObject: TBaseBOM );
published
property Rolename: string read FRolename write FRolename;
end;
{ TUser }
TUser = class(TBaseBOM)
private
FUsername: string;
public
procedure Assign( AObject: TBaseBOM );
published
property Username: string read FUsername write FUsername;
end;
{ TUserRole }
TUserRole = class(TBaseBOM)
private
FRolename: string;
FUsername: string;
public
procedure Assign( AObject: TBaseBOM );
published
property Username: string read FUsername write FUsername;
property Rolename: string read FRolename write FRolename;
end;
TUsers = TBaseBOMList<TUser>;
TRoles = TBaseBOMList<TRole>;
TUserRoles = TBaseBOMList<TUserRole>;
function TBaseBOMList<T>.GetItem(Index: Integer): T;
begin
result := FItems[Index];
end;
constructor TBaseBOMList<T>.Create;
begin
inherited Create;
FItems := TObjectList<T>.Create(true);
FDeletedItems := TObjectList<T>.Create(true);
end;
destructor TBaseBOMList<T>.Destroy;
begin
FDeletedItems.Free;
FItems.Free;
inherited Destroy;
end;
function TBaseBOMList<T>.Add(NewItem: T): T;
begin
if NewItem = Default(T) then
result := T.Create
else
result := NewItem;
FItems.Add(result);
end;
function TBaseBOMList<T>.Delete(Index: Integer): Boolean;
var
o: T;
begin
o := T.Create;
o.Assign(FItems[Index]);
FDeletedItems.Add(o);
FItems.Delete(Index); // error if index not valid
result := true;
end;
function TBaseBOMList<T>.Find(APropertyName: string; const AValue: variant
): Integer;
var
value : Variant;
PropList: PPropList;
PropCount, i: integer;
PropExist: Boolean;
begin
Result := -1;
PropExist:= False;
PropCount := GetPropList(T, PropList);
try
for i := 0 to PropCount-1 do
if CompareText(PropList[i].Name, APropertyName) = 0 then
begin
PropExist := True;
break;
end;
finally
Freemem(PropList);
end;
if PropExist then
begin
for i := 0 to FItems.Count-1 do
begin
value := GetStrProp(FItems[i], APropertyName);
if value = AValue then
begin
Result := i;
end;
end;
end
else
Raise Exception.Create(Format('Property name ''%s'' not found.',[APropertyName]));
end;
procedure TUserRole.Assign(AObject: TBaseBOM);
begin
inherited Assign(AObject);
with TUserRole(AObject) do
begin
self.Rolename:= Rolename;
self.Username:= Username;
end;
end;
procedure TRole.Assign(AObject: TBaseBOM);
begin
with TRole(AObject) do
self.Rolename:= Rolename;
end;
procedure TUser.Assign(AObject: TBaseBOM);
begin
with TUser(AObject) do
self.Username:= Username;
end;
{ TBaseBOM }
constructor TBaseBOM.Create;
begin
FEditState:= 'none';
end;
procedure TBaseBOM.Assign(src: TBaseBOM);
begin
with src do
begin
self.ID:= src.ID;
self.EditState:= src.EditState;
end;
end;
var
users: TUsers;
roles: TRoles;
u: TUser;
r: TRole;
urs: TUserRoles;
ur: TUserRole;
i: Integer;
begin
roles := TRoles.Create;
r := TRole.Create;
r.Rolename:= 'admin';
roles.Add(r);
r := roles.Add;
r.rolename := 'processor';
users := TUsers.Create;
u := TUser.Create;
u.Username:= 'magic';
users.Add(u);
urs := TUserRoles.Create;
ur := TUserRole.Create;
ur.ID:= 999;
ur.Username:= 'magic';
ur.Rolename:= 'processor';
urs.Add(ur);
writeln('Find username magic');
i := users.Find('username', 'magic');
writeln(users[i].username);
writeln('Find role ''processor''');
i := roles.Find('rolename', 'processor');
writeln(roles[i].rolename);
writeln('Delete last found role');
roles.Delete(i);
writeln('Deleted roles:');
writeln(roles.FDeletedItems[0].Rolename);
writeln('Find rolename ''processor'' in user roles');
i := urs.Find('rolename', 'processor');
writeln(urs[i].Rolename, ' / ', urs[i].Username);
writeln('Delete rolename ''processor'' in user roles');
urs.Delete(i);
writeln(urs.FDeletedItems[0].Rolename, ' / ', urs.FDeletedItems[0].Username);
writeln(urs.FDeletedItems[0].ID, ' / ', urs.FDeletedItems[0].EditState);
urs.free;
users.free;
roles.free;
writeln('ok');
readln();
end.
Related
I have several classes with properties of simple types (Integer, Boolean, string) and some Nullable's:
Nullable<T> = record
private
FValue: T;
FHasValue: IInterface;
function GetValue: T;
function GetHasValue: Boolean;
public
constructor Create(AValue: T);
property HasValue: Boolean read GetHasValue;
property Value: T read GetValue;
end;
Eg.
TMyClass1 = class(TCommonAncestor)
private
FNumericvalue: Double;
FEventTime: Nullable<TDateTime>;
public
property NumericValue: Double read FNumericValue write FNumericValue;
property EventTime: Nullable<TDateTime> read FEventTime write FEventTime;
end;
and
TMyClass2 = class(TCommonAncestor)
private
FCount: Nullable<Integer>;
FName: string;
public
property Count: Nullable<Integer> read FCount write FCount;
property Name: string read FName write FName;
end;
etc....
Given a descendant of TCommonAncestor, I would like to use RTTI to iterate all public properties and list their name and value, unless it is a Nullable where T.HasValue returns false.
I am using Delphi XE2.
EDIT: added what I have so far.
procedure ExtractValues(Item: TCommonAncestor);
var
c : TRttiContext;
t : TRttiType;
p : TRttiProperty;
begin
c := TRttiContext.Create;
try
t := c.GetType(Item.ClassType);
for p in t.GetProperties do
begin
case p.PropertyType.TypeKind of
tkInteger:
OutputDebugString(PChar(Format('%se=%s', [p.Name,p.GetValue(Item).ToString]));
tkRecord:
begin
// for Nullable<Double> p.PropertyType.Name contains 'Nullable<System.Double>'
// but how do I go about accessing properties of this record-type field?
end;
end;
end;
finally
c.Free;
end;
end;
The following works for me in XE2:
uses
System.SysUtils, System.TypInfo, System.Rtti, System.StrUtils, Winapi.Windows;
type
Nullable<T> = record
private
FValue: T;
FHasValue: IInterface;
function GetHasValue: Boolean;
function GetValue: T;
procedure SetValue(const AValue: T);
public
constructor Create(AValue: T);
function ToString: string; // <-- add this for easier use!
property HasValue: Boolean read GetHasValue;
property Value: T read GetValue write SetValue;
end;
TCommonAncestor = class
end;
TMyClass1 = class(TCommonAncestor)
private
FNumericvalue: Double;
FEventTime: Nullable<TDateTime>;
public
property NumericValue: Double read FNumericValue write FNumericValue;
property EventTime: Nullable<TDateTime> read FEventTime write FEventTime;
end;
TMyClass2 = class(TCommonAncestor)
private
FCount: Nullable<Integer>;
FName: string;
public
property Count: Nullable<Integer> read FCount write FCount;
property Name: string read FName write FName;
end;
...
constructor Nullable<T>.Create(AValue: T);
begin
SetValue(AValue);
end;
function Nullable<T>.GetHasValue: Boolean;
begin
Result := FHasValue <> nil;
end;
function Nullable<T>.GetValue: T;
begin
if HasValue then
Result := FValue
else
Result := Default(T);
end;
procedure Nullable<T>.SetValue(const AValue: T);
begin
FValue := AValue;
FHasValue := TInterfacedObject.Create;
end;
function Nullable<T>.ToString: string;
begin
if HasValue then
begin
// TValue.ToString() does not output T(Date|Time) values as date/time strings,
// it outputs them as floating-point numbers instead, so do it manually...
if TypeInfo(T) = TypeInfo(TDateTime) then
Result := DateTimeToStr(PDateTime(#FValue)^)
else if TypeInfo(T) = TypeInfo(TDate) then
Result := DateToStr(PDateTime(#FValue)^)
else if TypeInfo(T) = TypeInfo(TTime) then
Result := TimeToStr(PDateTime(#FValue)^)
else
Result := TValue.From<T>(FValue).ToString;
end
else
Result := '(null)';
end;
procedure ExtractValues(Item: TCommonAncestor);
var
c : TRttiContext;
t : TRttiType;
p : TRttiProperty;
v : TValue;
m : TRttiMethod;
s : string;
begin
c := TRttiContext.Create;
t := c.GetType(Item.ClassType);
for p in t.GetProperties do
begin
case p.PropertyType.TypeKind of
tkRecord:
begin
if StartsText('Nullable<', p.PropertyType.Name) then
begin
// get Nullable<T> instance...
v := p.GetValue(Item);
// invoke Nullable<T>.ToString() method on that instance...
m := c.GetType(v.TypeInfo).GetMethod('ToString');
s := m.Invoke(v, []).AsString;
end else
s := Format('(record type %s)', [p.PropertyName.Name]);
end;
else
s := p.GetValue(Item).ToString;
end;
OutputDebugString(PChar(Format('%s=%s', [p.Name, s])))
end;
end;
var
Item1: TMyClass1;
Item2: TMyClass2;
begin
Item1 := TMyClass1.Create;
try
Item1.NumericValue := 123.45;
Item1.EventTime.SetValue(Now);
ExtractValues(Item1);
{ Output:
NumericValue=123.45
EventTime=10/19/2017 1:25:05 PM
}
finally
Item1.Free;
end;
Item1 := TMyClass1.Create;
try
Item1.NumericValue := 456.78;
//Item1.EventTime.SetValue(Now);
ExtractValues(Item1);
{ Output:
NumericValue=456.78
EventTime=(null)
}
finally
Item1.Free;
end;
Item2 := TMyClass2.Create;
try
Item2.Count.SetValue(12345);
Item2.Name := 'test';
ExtractValues(Item2);
{ Output:
Count=12345
Name=test
}
finally
Item2.Free;
end;
Item2 := TMyClass2.Create;
try
//Item2.Count.SetValue(12345);
Item2.Name := 'test2';
ExtractValues(Item2);
{ Output:
Count=(null)
Name=test2
}
finally
Item2.Free;
end;
end;
I have the two overload methods:
procedure TProps.SetProp(Value: TObject); overload;
procedure TProps.SetProp(const Value: Variant); overload;
They do pretty much the same repeating code except from minor variations depending on whether the Value is Variant or TObject.
I want to use a common method:
procedure TProps.DoSetProp(Value: <what type here?>); // <--
So I can pass both Variant or TObject from SetProp and be able to distinguish between the two types. what are my options?
Edit: for now I used:
procedure TProps.DoSetProp(Value: Pointer; IsValueObject: Boolean);
begin
// common code...
if IsValueObject then
PropValue.Obj := Value
else
PropValue.V := PVariant(Value)^;
// common code...
if IsValueObject then
PropValue.Obj := Value
else
PropValue.V := PVariant(Value)^;
// etc...
end;
and the overload methods:
procedure TProps.SetProp(const Value: Variant); overload;
begin
DoSetProp(#Value, False);
end;
procedure TProps.SetProp(Value: TObject); overload;
begin
DoSetProp(Value, True);
end;
I'm not sure I like this solution because of the IsValueObject. I would rather detect the type from a common type "container".
I could use TVarRec:
VarRec: TVarRec;
// for Variant:
VarRec.VType := vtVariant;
VarRec.VVariant := #Value;
// for TObject
VarRec.VType := vtObject;
VarRec.VObject := Value;
And pass the VarRec to the common method. but I'm not sure I like it either.
EDIT 2: What I am trying to do? I'm trying to extend properties for any TObject similar to SetProp API.
Here is the entire MCVE:
function ComparePointers(A, B: Pointer): Integer;
begin
if Cardinal(A) = Cardinal(B) then
Result := 0
else if Cardinal(A) < Cardinal(B) then
Result := -1
else
Result := 1
end;
type
TPropValue = class
private
V: Variant;
Obj: TObject;
procedure SetValue(const Value: Pointer; IsValueObject: Boolean);
end;
TPropNameValueList = class(TStringList)
public
destructor Destroy; override;
procedure Delete(Index: Integer); override;
end;
TObjectProps = class
private
BaseObject: TObject;
PropList: TPropNameValueList;
public
constructor Create(AObject: TObject);
destructor Destroy; override;
end;
TProps = class(TComponent)
private
FList: TObjectList;
protected
procedure DoSetProp(AObject: TObject; const PropName: string; const Value: Pointer; IsValueObject: Boolean);
procedure Notification(AComponent: TComponent; Operation: TOperation); override;
public
function Find(AObject: TObject; var Index: Integer): Boolean;
procedure SetProp(AObject: TObject; const PropName: string; const Value: Variant); overload;
procedure SetProp(AObject: TObject; const PropName: string; Value: TObject); overload;
function RemoveProp(AObject: TObject; const PropName: string): Boolean;
function RemoveProps(AObject: TObject): Boolean;
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
end;
{ TPropValue }
procedure TPropValue.SetValue(const Value: Pointer; IsValueObject: Boolean);
begin
if IsValueObject then
Obj := Value
else
V := PVariant(Value)^;
end;
{ TPropNameValueList }
destructor TPropNameValueList.Destroy;
var
I: Integer;
begin
for I := 0 to Count - 1 do
Objects[I].Free; // TPropValue
inherited;
end;
procedure TPropNameValueList.Delete(Index: Integer);
begin
Objects[Index].Free;
inherited;
end;
{ TObjectProps }
constructor TObjectProps.Create(AObject: TObject);
begin
BaseObject := AObject;
PropList := TPropNameValueList.Create;
PropList.Sorted := True;
PropList.Duplicates := dupError;
end;
destructor TObjectProps.Destroy;
begin
PropList.Free;
inherited;
end;
{ TProps }
constructor TProps.Create(AOwner: TComponent);
begin
inherited;
FList := TObjectList.Create(true);
end;
procedure TProps.Notification(AComponent: TComponent; Operation: TOperation);
begin
inherited;
if (Operation = opRemove) and (AComponent <> nil) then
begin
RemoveProps(AComponent);
end;
end;
destructor TProps.Destroy;
begin
FList.Free;
inherited;
end;
function TProps.Find(AObject: TObject; var Index: Integer): Boolean;
var
L, H, I, C: Integer;
begin
Result := False;
L := 0;
H := FList.Count - 1;
while L <= H do
begin
I := (L + H) shr 1;
C := ComparePointers(TObjectProps(FList[I]).BaseObject, AObject);
if C < 0 then L := I + 1 else
begin
H := I - 1;
if C = 0 then
begin
Result := True;
L := I;
end;
end;
end;
Index := L;
end;
procedure TProps.DoSetProp(AObject: TObject; const PropName: string; const Value: Pointer;
IsValueObject: Boolean);
var
OP: TObjectProps;
PropValue: TPropValue;
Index, NameIndex: Integer;
Found: Boolean;
I: Integer;
begin
Found := Find(AObject, Index);
if not Found then
begin
OP := TObjectProps.Create(AObject);
if AObject is TComponent then
TComponent(AObject).FreeNotification(Self);
PropValue := TPropValue.Create;
PropValue.SetValue(Value, IsValueObject);
OP.PropList.AddObject(PropName, PropValue);
FList.Insert(Index, OP);
end
else
begin
OP := TObjectProps(FList[Index]);
NameIndex := OP.PropList.IndexOf(PropName);
if NameIndex <> -1 then
begin
PropValue := TPropValue(OP.PropList.Objects[NameIndex]);
PropValue.SetValue(Value, IsValueObject);
end
else
begin
PropValue := TPropValue.Create;
PropValue.SetValue(Value, IsValueObject);
OP.PropList.AddObject(PropName, PropValue);
end;
end;
end;
procedure TProps.SetProp(AObject: TObject; const PropName: string; const Value: Variant);
begin
DoSetProp(AObject, PropName, #Value, False);
end;
procedure TProps.SetProp(AObject: TObject; const PropName: string; Value: TObject);
begin
DoSetProp(AObject, PropName, Value, True);
end;
function TProps.RemoveProp(AObject: TObject; const PropName: string): Boolean;
var
Index, NameIndex: Integer;
OP: TObjectProps;
begin
Result := False;
if not Find(AObject, Index) then Exit;
OP := TObjectProps(FList[Index]);
NameIndex := OP.PropList.IndexOf(PropName);
if NameIndex <> -1 then
begin
OP.PropList.Delete(NameIndex);
Result := True;
end;
end;
function TProps.RemoveProps(AObject: TObject): Boolean;
var
Index: Integer;
OP: TObjectProps;
begin
if not Find(AObject, Index) then
begin
Result := False;
Exit;
end;
OP := TObjectProps(FList[Index]);
Result := FList.Remove(OP) <> -1;
end;
Usage:
Props := TProps.Create(Self);
Props.SetProp(Button1, 'myprop1', Self); // TObject property
Props.SetProp(Button1, 'myprop2', 666); // variant
Props.SetProp(Button2, 'myprop', 'Hello'); // variant
Props.SetProp(MyObject, 'foo', 123.123);
Note: TProps.GetProp is not yet implemented.
You are fighting the compiler; You should continue to use overloads.
"I would rather detect the type from a common type 'container'."
Your choices are variant or untyped pointer. You are going to have to unpack the "Value" parameter. With an untyped pointer you will have to do all the work; with a variant you will have to do most of the work. Very messy.
"They do pretty much the same repeating code except from minor variations depending on whether the Value is Variant or TObject."
If that is really true then you should still continue to use overloads but add an internal "SetProp" method that takes "normalized" data that does the actual work. Your "repeating" code is the setting of the property values. But you still have specific code to write to crack the incoming "Value" parameter whether you have one method that accepts a "container" type or multiple overloaded methods that take the various types you want to accept. In the one-method-container type you will have a (complex) if-then-else block that cracks the Value. In the overloaded-methods type there is no if-testing; you just crack the Value for the type that each method accepts.
The major advantage is that your object is better documented: you can see what types are acceptable for "Value" and, better still, the compiler helps you because it "knows" what types are acceptable. With your one-method approach the compiler will not be able to help you enforce the type of "Value"; you are doing all the work.
Also, using the overloaded methods, I wouldn't have one that accepts variant (although the example below does). Have an separate overload for each of string, integer, double, etc.
type
TNormalizedPropValue = record
// ....
end;
procedure TProps.internalSetProp(Value : TNormalizedPropValue);
begin
//
// Set the property value from the "Normalized" pieces and parts.
//
end;
procedure TProps.SetProp(Value : TObject);
var
NormalizedObjectPropValue : TNormalizedPropValue;
begin
// Copy the pieces and parts from "Value" into NormalizedObjectPropValue
//
internalSetProp(NormalizedObjectPropValue);
end;
procedure TProps.SetProp(Value : variant);
var
NormalizedVariantPropValue : TNormalizedPropValue;
begin
// Crack "Value" variant and copy the pieces and parts into NormalizedVariantPropValue
//
internalSetProp(NormalizedVariantPropValue);
end;
Rtti accessing fields, properties and invoke method in record structures.
I use the following record types, is from site
type
Nullable<T> = record
public
FValue: T;
FHasValue: boolean;
procedure Clear;
function GetHasValue: boolean;
function GetValue: T;
constructor Create(AValue: T);
property HasValue: boolean read GetHasValue;
property Value: T read GetValue;
class operator Implicit(Value: Nullable<T>): T;
class operator Implicit(Value: T): Nullable<T>;
end;
type
TIntEx = Nullable<integer>;
TSmallintEx = Nullable<smallint>;
implementation
constructor Nullable<T>.Create(AValue: T);
begin
FValue := AValue;
FHasValue := false;
end;
function Nullable<T>.GetHasValue: boolean;
begin
Result := FHasValue;
end;
function Nullable<T>.GetValue: T;
begin
Result := FValue;
end;
class operator Nullable<T>.Implicit(Value: Nullable<T>): T;
begin
Result := Value.Value;
end;
class operator Nullable<T>.Implicit(Value: T): Nullable<T>;
begin
Result := Nullable<T>.Create(Value);
end;
But with a record this code doesn't work
type
[TableName('Record')]
TMyrecord = class(TPersistent)
private
FRecno: TIntEx;
FName: TStringEx;
protected
public
constructor Create();
destructor Destoy();
function GetSqlInsert(): string;
[SqlFieldName('recno')]
property Recno: TIntEx read FRecno write FRecno;
[SqlFieldName('Name')]
property Name: TStringEx read FName write FName;
end;
implementation
{ TMyrecord }
function TMyrecord.GetSqlInsert(): string;
var
vCtx: TRttiContext;
vType: TRttiType;
vProp: TRttiProperty;
vAttr: TCustomAttribute;
vPropValue: TValue;
vRecord: TRttiRecordType;
M: TRttiMethod;
tmpStr: String;
val: TValue;
begin
result := '';
vCtx := TRttiContext.Create;
try
vType := vCtx.GetType(self);
for vProp in vType.GetProperties do
for vAttr in vProp.GetAttributes do
if vAttr is SqlFieldName then
begin
if (vProp.IsReadable) and (vProp.IsWritable) and
(vProp.PropertyType.TypeKind = tkRecord) then
begin
vRecord := vCtx.GetType(vProp.GetValue(self).TypeInfo).AsRecord;
M := vRecord.GetMethod('GetValue');
if Assigned(M) then
vPropValue := (M.Invoke(vPropValue, []));
tmpStr := val.ToString;
end;
end;
finally
freeandnil(vCtx);
end;
end;
I studied all the examples on the internet but in vain.
vType := vCtx.GetType(self);
The GetType method expects to be pass a pointer to type info, or a class, but you pass an instance. Instead you should pass the class like this:
vType := vCtx.GetType(ClassType);
You must not pass a TRttiContext to FreeAndNil. The TRttiContext type is a record. You don't need to call Create on that type. You don't need to call Free.
Further more, your code to invoke the method is just wrong.
Your function might look like this:
function TMyrecord.GetSqlInsert(): string;
var
vCtx: TRttiContext;
vType: TRttiType;
vProp: TRttiProperty;
vAttr: TCustomAttribute;
vRecord: TValue;
M: TRttiMethod;
begin
vType := vCtx.GetType(ClassType);
for vProp in vType.GetProperties do
for vAttr in vProp.GetAttributes do
if vAttr is SqlFieldNameAttribute then
begin
if (vProp.IsReadable) and (vProp.IsWritable) and
(vProp.PropertyType.TypeKind = tkRecord) then
begin
vRecord := vProp.GetValue(self);
M := vProp.PropertyType.GetMethod('GetValue');
if Assigned(M) then
begin
Result := M.Invoke(vRecord, []).ToString;
exit;
end;
end;
end;
Result := '';
end;
That code does at least call the method and retrieve the returned value. I'll let you take it from there.
I'm trying to create a custom component with a collection property. However if I try to open the collection editor during design time by clicking "..." button in object inspector, nothing happens. What I am missing?
Here's my TCollection descendant:
TMyCollection = class(TOwnedCollection)
private
function GetItem(Index: Integer): TMyCollectionItem;
procedure SetItem(Index: Integer; const Value: TMyCollectionItem);
public
function Add : TMyCollectionItem;
property Items[Index: Integer]: TMyCollectionItem read GetItem write SetItem;
end;
And the item:
TMyCollectionItem = class(TCollectionItem)
private
FValue: integer;
protected
function GetDisplayName: string; override;
public
procedure Assign(Source: TPersistent); override;
constructor Create(Collection: TCollection); override;
destructor Destroy; override;
published
property Value : integer read FValue write FValue;
end;
Your class definitions look correct so with out seeing the entire implementation I don't know what the problem is.
Here is a simple unit I've written that uses TOwnedCollection, TCollectionItem and TComponent.
I know this unit works. Use it as a basis for checking your code.
unit rmMultiStrings;
interface
uses classes, sysutils;
type
ErmMultiStringNameException = Exception;
TrmMultiStringsCollection = class;
TrmMultiStringCollectionItem = class(TCollectionItem)
private
fItemDesc: string;
fItemName: string;
fData : TStringList;
fMultiStrings : TrmMultiStringsCollection;
function GetStrings: TStringList;
function GetStringText: String;
procedure SetItemName(const Value: string);
procedure SetStrings(const Value: TStringList);
procedure SetStringText(const Value: String);
public
constructor Create(Collection: TCollection); override;
destructor Destroy; override;
procedure Assign(Source: TPersistent); override;
published
property ItemName : string read fItemName write SetItemName;
property Description : string read fItemDesc write fItemDesc;
property Strings : TStringList read GetStrings write SetStrings stored false;
property Text : String read GetStringText write SetStringText;
end;
TrmMultiStringsCollection = class(TOwnedCollection)
private
function GetItem(AIndex: integer): TrmMultiStringCollectionItem;
procedure SetItem(AIndex: integer; const Value: TrmMultiStringCollectionItem);
public
function Add: TrmMultiStringCollectionItem;
function IndexOf(ItemName:string):integer;
function ValueOf(ItemName:string):String;
function ValueOfIndex(aIndex:integer):string;
procedure Assign(Source: TPersistent); override;
property Items[AIndex: integer] : TrmMultiStringCollectionItem read GetItem write SetItem;
end;
TrmMultiStrings = class(TComponent)
private
fData : TrmMultiStringsCollection;
procedure SetData(const Value: TrmMultiStringsCollection);
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
function IndexOf(ItemName:string):integer;
function ValueOf(ItemName:string):String;
function ValueOfIndex(aIndex:integer):string;
published
property Data : TrmMultiStringsCollection read fData write SetData;
end;
procedure Register;
implementation
procedure Register;
begin
RegisterClass(TrmMultiStringsCollection);
RegisterClass(TrmMultiStringCollectionItem);
RegisterComponents('rmConcordia', [TrmMultiStrings]);
end;
{ TrmMultiStringCollectionItem }
procedure TrmMultiStringCollectionItem.Assign(Source: TPersistent);
var
wSrc : TrmMultiStringCollectionItem;
begin
if Source is TrmMultiStringCollectionItem then
begin
wSrc := TrmMultiStringCollectionItem(Source);
ItemName := wSrc.ItemName;
Description := wSrc.Description;
Text := wSrc.Text;
end
else
inherited;
end;
constructor TrmMultiStringCollectionItem.Create(Collection: TCollection);
begin
inherited;
fMultiStrings := TrmMultiStringsCollection(Collection);
fData := TStringList.create;
end;
destructor TrmMultiStringCollectionItem.Destroy;
begin
fData.free;
inherited;
end;
function TrmMultiStringCollectionItem.GetStrings: TStringList;
begin
result := fData;
end;
function TrmMultiStringCollectionItem.GetStringText: String;
begin
result := fData.Text;
end;
procedure TrmMultiStringCollectionItem.SetItemName(const Value: string);
begin
if (fItemName <> Value) then
begin
if fMultiStrings.IndexOf(Value) = -1 then
fItemName := Value
else
raise ErmMultiStringNameException.Create('Item name already exists');
end;
end;
procedure TrmMultiStringCollectionItem.SetStrings(
const Value: TStringList);
begin
fData.Assign(Value);
end;
procedure TrmMultiStringCollectionItem.SetStringText(const Value: String);
begin
fData.Text := Value;
end;
{ TrmMultiStringsCollection }
function TrmMultiStringsCollection.Add: TrmMultiStringCollectionItem;
begin
result := TrmMultiStringCollectionItem(inherited Add);
result.ItemName := 'Item_'+inttostr(NextID);
end;
procedure TrmMultiStringsCollection.Assign(Source: TPersistent);
var
wSrc : TrmMultiStringsCollection;
loop : integer;
begin
if (source is TrmMultiStringsCollection) then
begin
wSrc := TrmMultiStringsCollection(Source);
Clear;
for loop := 0 to wSrc.Count - 1 do
Add.Assign(wSrc.Items[loop]);
end
else
inherited;
end;
function TrmMultiStringsCollection.GetItem(
AIndex: integer): TrmMultiStringCollectionItem;
begin
result := TrmMultiStringCollectionItem(inherited Items[AIndex]);
end;
function TrmMultiStringsCollection.IndexOf(ItemName: string): integer;
var
loop : integer;
begin
result := -1;
loop := 0;
while (result = -1) and (loop < Count) do
begin
if (CompareText(Items[loop].ItemName, ItemName) = 0) then
result := loop
else
inc(loop);
end;
end;
procedure TrmMultiStringsCollection.SetItem(AIndex: integer; const Value: TrmMultiStringCollectionItem);
begin
inherited SetItem(AIndex, Value)
end;
function TrmMultiStringsCollection.ValueOf(ItemName: string): String;
begin
result := ValueOfIndex(IndexOf(ItemName));
end;
function TrmMultiStringsCollection.ValueOfIndex(aIndex: integer): string;
begin
if (aIndex >= 0) and (aIndex < Count) then
result := Items[aIndex].Text
else
result := '';
end;
{ TrmMultiStrings }
constructor TrmMultiStrings.Create(AOwner: TComponent);
begin
inherited;
fData := TrmMultiStringsCollection.Create(self, TrmMultiStringCollectionItem);
end;
destructor TrmMultiStrings.Destroy;
begin
fData.Free;
inherited;
end;
function TrmMultiStrings.IndexOf(ItemName: string): integer;
begin
result := Data.IndexOf(ItemName);
end;
procedure TrmMultiStrings.SetData(const Value: TrmMultiStringsCollection);
begin
fData.Assign(Value);
end;
function TrmMultiStrings.ValueOf(ItemName: string): String;
begin
result := Data.ValueOf(ItemName);
end;
function TrmMultiStrings.ValueOfIndex(aIndex: integer): string;
begin
result := Data.ValueOfIndex(aIndex);
end;
end.
I need help on this:
im storing object properties in a DataPacket class.
The properties are defined like this
type
TProperty = class
private
FName: string;
public
constructor Create(const AName: string);
property Name: string read FName;
end;
TIntegerProperty = class(TProperty)
private
FValue: Integer;
protected
procedure SetValue(const AValue:integer);
public
property Value: Integer read FValue write SetValue;
end;
the DataPacket class:
type
TDataPacket = class
private
FProperties: TStringList;
public
function GetIntegerValue(const APropertyName: string): integer;
.....
procedure SetIntegerValue(const APropertyName: string; AValue: integer);
end;
and they are implemented like:
function TDataPacket.GetIntegerValue(const APropertyName: string): integer;
var
Pos: integer;
begin
Pos := FProperties.IndexOf(APropertyName);
if Pos > -1 then
Result := TIntegerProperty(FProperties.Objects[Pos]).Value
else
Result := 0;
end;
procedure TDataPacket.SetIntegerValue(const APropertyName: string; AValue: integer);
var
Pos: integer;
AProperty: TIntegerProperty;
begin
Pos := FProperties.IndexOf(APropertyName);
if Pos >- 1 then
TIntegerProperty(FProperties.Objects[Pos]).Value := AValue
else
begin
AProperty:= TIntegerProperty.Create(APropertyName);
AProperty.Value := AValue;
FProperties.AddObject(APropertyName, AProperty);
end;
end;
now the question: i need to define an Status property defined as TObjectStatus where:
type
TStatus = (Deleted, Unchanged, Added , Modified, ChildsModified);
TObjectStatus = Set of TStatus;
any idea on how can i define, store and retrieve it?
sorry for the long explanation and thanks in advance for you help
Michael
First:
Result := TIntegerProperty(FProperties.Objects[Pos]).Value
Is risky because you will crash if it is not a TIntegerProperty.
Use something like:
Pos := FProperties.IndexOf(APropertyName);
if (Pos >= 0) and (FProperties.Objects[Pos] is TIntegerProperty) then
Result := TIntegerProperty(FProperties.Objects[Pos]).Value
else
Result := 0;
Next the status, I don't think you need them al:
For the list
- Deleted a child: Deleted
- Added a child: Added
- Child had been changed: ChildsModified
You don't need unchanged because in that case, the set is empty. And you don't need Modified because in that case the set is not empty.
For the properties you can just add a Changed value.
You can add ChildsModified directly if a child is changed. Or you can use lazy evaluation and walk all children to check for Changed.
Ok you can do something like this:
type
TStatus = (stDeleted, stAdded , stModified, stChildsModified);
TObjectStatus = Set of TStatus;
TDataPacket = class;
TProperty = class
private
FName : string;
FParent : TDataPacket;
protected
procedure NotifyChange(const AStatus: TStatus);
public
constructor Create(const AParent: TDataPacket; const AName: string);
property Name: string read FName;
end;
TIntegerProperty = class(TProperty)
private
FValue: Integer;
procedure SetValue(const AValue:integer);
public
property Value: Integer read FValue write SetValue;
end;
TDataPacket = class
private
FProperties: TStringList;
FStatus : TObjectStatus;
protected
procedure NotifyChange(const AStatus: TStatus);
function GetProperty(const AName: string): TProperty;
public
function GetIntegerValue(const APropertyName: string): integer;
procedure SetIntegerValue(const APropertyName: string; AValue: integer);
end;
procedure TProperty.NotifyChange(const AStatus: TStatus);
begin
FParent.NotifyChange(AStatus);
end;
constructor TProperty.Create(const AParent: TDataPacket; const AName: string);
begin
Assert(AParent<>nil);
FName := AName;
FParent := AParent;
end;
procedure TIntegerProperty.SetValue(const AValue:integer);
begin
if AValue<>FValue then begin
FValue := AValue;
NotifyChange(stChildsModified);
end;
end;
procedure TDataPacket.NotifyChange(const AStatus: TStatus);
begin
if AProp=nil then begin
case AStatus of
TStatus = (stDeleted, stAdded , stModified, stChildsModified);
FStatus := FStatus + [AStatus];
end;
function TDataPacket.GetProperty(const AName: string): TProperty;
var
i : Integer;
begin
i := FProperties.IndexOf(AName);
if i>=0 then
Result := TProperty(FProperties.Objects[i])
else
Result := nil;
end;
function TDataPacket.GetIntegerValue(const APropertyName: string): integer;
var
prop : TProperty;
begin
prop := GetProperty(APropertyName);
if (prop<>nil) and (prop is TIntegerProperty) then
Result := TIntegerProperty(prop).Value
else
Result := 0;
end;
procedure TDataPacket.SetIntegerValue(const APropertyName: string; AValue: integer);
var
prop : TProperty;
intprop : TIntegerProperty;
begin
prop := GetProperty(APropertyName);
if (prop<>nil) and not (AProperty is TIntegerProperty) then begin
// PANIC!
end else begin
if prop=nil then begin
intprop := TIntegerProperty.Create(self, APropertyName);
intprop.Value := AValue;
FProperties.AddObject(APropertyName, intprop);
NotifyChange(stAdded);
end else begin
TIntegerProperty(prop).Value := AValue;
end;
end;
end;
And off course add support for deletion.
You can let the Property handle all changes (Add when constructed and Delete when freed).
If you're storing an object's properties, and one of those properties should be a status property, then all you ultimately need to do is the same as what you did for TIntegerProperty, but replacing Integer with TObjectStatus.
First, define another property class that holds your TObjectStatus value:
type
TObjectStatusProperty = class(TProperty)
private
FValue: TObjectStatus;
protected
procedure SetValue(const AValue: TObjectStatus);
public
property Value: TObjectStatus read FValue write SetValue;
end;
Next, add methods to your data packet to work with that type of property:
function TDataPacket.GetObjectStatusValue(
const APropertyName: string): TObjectStatus;
var
Pos: integer;
Prop: TProperty;
begin
Pos := FProperties.IndexOf(APropertyName);
if Pos >= 0 then begin
Prop := FProperties.Objects[Pos] as TProperty;
Assert(Prop.Name = APropertyName);
if Prop is TObjectStatusProperty then
Result := TObjectStatusProperty(Prop).Value
else
raise EWrongPropertyType.CreateFmt('Expected %s but got %s',
[TObjectStatusProperty.ClassName, Prop.ClassName]);
end else
Result := [];
end;
procedure TDataPacket.SetObjectStatusValue(
const APropertyName: string; AValue: TObjectStatus);
var
Pos: integer;
Prop: TProperty;
begin
Pos := FProperties.IndexOf(APropertyName);
if Pos >= 0 then begin
Prop := FProperties.Objects[Pos] as TProperty;
Assert(Prop.Name = APropertyName);
if Prop is TObjectStatusProperty then
TObjectStatusProperty(Prop).Value := AValue
else
raise EWrongPropertyType.CreateFmt('Expected %s but got %s',
[TObjectStatusProperty.ClassName, Prop.ClassName]);
end else begin
Prop := TObjectStatusProperty.Create(APropertyName);
TObjectStatusProperty(Prop).Value := AValue;
FProperties.AddObject(APropertyName, Prop);
end;
end;
This could be a great opportunity to use generics to reduce the number of TXProperty classes you need to write, if you had Delphi 2009 and if Delphi's generics supported sets.