So assume this code work.
{***Start declaration of TMakeProd ***}
TListMakeProd = class (TListNF)
procedure SortProcProdSeqNum;
procedure LoadFromRep(aFileRep, aNo : String);
function Find(aMakeProdID : Integer) : TMakeProd;
function FindObj(aMakeProd : TMakeProd) : TMakeProd;
end;
TMakeProd = class (TProduct)
private
FMakeProductID : Integer;
FProdLotSize : Longint;
public
LiProcProd : TListProcProd;
{Load from a database.}
{ procedure SortLiProcProdSeqNum; }
constructor Init(aMakeProductID: Integer; aProdLotSize: Longint);
destructor Done; override;
destructor Destroy; override;
property MakeProductID : Integer read FMakeProductID write FMakeProductID ;
property ProdLotSize : Longint read FProdLotSize write FProdLotSize ;
function findNextProcProd(aProcProd: TProcProd) : TProcProd;
{ create function with return if required. }
end;
What I don't understand is this declaration LiProcProd : TListProcProd;
I know that TListProcProd is a class, everything else I understand it but this part I don't also this is just a class declaration and assume all the class have been properly declared
type
TMakeProd = class(TProduct)
....
LiProcProd : TListProcProd;
....
end;
In this declaration, LiProcProd is a public field. This is described by the documentation.
Related
I encountered some error for which i just can't find a proper hint on the net. Hopefully one of you can point me to the right direction.
Simple Problem: I've got a class inheriting from TObject. I've got a constructor named Create and i want to call Inherited on the very first line of the very only constructor.
Does not work!
On compile i get a
[dcc32 Fehler] ULSRAware.pas(58): E2008 Inkompatible Typen
If I comment the inherited out it compiles fine but on runtime on creating the object, while I can access methods regulary (like some private _InitAdo method), every access to a property yields an access violation error.
I guess it's coming from calling the inherited nonetheless but without any sufficient success.
This is the declaration at the head of the Unit. Just to mention it, it's just this class in the unit. And of course in the implementation section the implementation.
type TLAConnect = class( TObject )
private
_mailHost : String;
_mailPort : Integer;
_mailUsername : String;
_mailPassword : String;
_mailAddress : String;
_sql_script_sms : String;
_sql_script_mail: String;
_sms_mail_addon : String;
//connection : TADOConnection;
(*
procedure SendMessage( recp:String; subj, body : String );
procedure _InitAdo( config_filename : String; path: String );
function GetMsgId( msg : String ) : Integer;
function GetMsgIdFromByteBit( byte, bit : String ) : Integer;
function ProcessMessage( msgId : Integer ): String;
procedure Trigger( msgId : Integer );
procedure QuittMsg( msgId : Integer );
procedure MakeMessage( _msgid : Integer; _fsms, _fmail : Boolean; _smsgl, _smsgs : String );
function CreateNewByteTrigger( byte, bit : String ) : Integer;
*)
public
Constructor Create( config : String );
Destructor Destroy; override;
//function Call( msg:String ) : Boolean;
end;
And the implementation of the constructor and the desctructor.
Constructor TLAConnect.Create( config : String );
begin
inherited.Create;
//self._InitAdo( config, 'lsraware ado' );
_mailHost := 'blabla';
_mailPort := 587;
_mailUsername := 'blabla_user';
_mailPassword := 'blabla_pass';
_mailAddress := 'blabal';
end;
Destructor TLAConnect.Destroy;
begin
self.connection.Free;
Inherited;
end;
Howdey,
I am using TVirtualInterface to implement some interfaces. Those interfaes represent Keys that can be found in a DB. I generate the interface definitions with a custom made code generator. For example :
// Base code
IKey = interface
function KeyFields : string;
function KeyValues : Variant;
function GetKeyValue(const aKeyName : string) : Variant;
procedure SetKeyValue(const aKeyName : string; Value : Variant);
end;
// Generated code
ITable1Key = interface(IKey)
end;
ITable1Key1 = interface(ITable1Key)
procedure SetField1(const Value : string);
function GetField1 : string;
property Field1 : string read GetField1 write SetField1;
end;
ITable1Key2 = interface(ITable1Key)
procedure SetField1(const Value : string);
function GetField1 : string;
property Field1 : string read GetField1 write SetField1;
procedure SetField2(const Value : string);
function GetField2 : string;
property Field2 : string read GetField1 write SetField1;
end;
// Other generated declarations
I use the TVirtualInterface to implement each IKey interface instead of implementing them one by one.
Though, in my TVirtualInterface :
TKey = TVirtualInterface
public
constructor Create(aType : PTypeInfo);
function Cast : IKey;
end;
TKey<T : IKey>
public
constructor Create; reintroduce;
function Cast : T;
end;
constructor TKey.Create(aType : PTypeInfo)
begin
inherited Create(aType, aHandlerMethod);
end;
function TKey.Cast;
var
pInfo: PTypeInfo;
begin
pInfo := TypeInfo(IKey);
if QueryInterface(GetTypeData(pInfo).Guid, Result) <> 0 then
begin
raise Exception.CreateFmt('Sorry, TKey is unable to cast %s to its interface ', [string(pInfo.Name)]);
end;
end;
constructor TKey<T>.Create;
begin
inherited Create(TypeInfo(T));
end;
function TKey<T>.Cast;
var
pInfo: PTypeInfo;
begin
pInfo := TypeInfo(T);
if QueryInterface(GetTypeData(pInfo).Guid, Result) <> 0 then
begin
raise Exception.CreateFmt('Sorry, TKey<T> is unable to cast %s to its interface ', [string(pInfo.Name)]);
end;
end;
I have no problem casting the TKey virtual interface to the T type using the TKey.Cast method, though TKey.Cast returns a Interface not supported error.
I checked in System.Rtti for the part that wasn't working the way I wanted it to :
function TVirtualInterface.QueryInterface(const IID: TGUID; out Obj): HResult;
begin
if iid = FIID then
begin
_AddRef;
Pointer(Obj) := #VTable;
Result := S_OK;
end
else
Result := inherited
end;
Now, how can I force the TVirtualInterface to cast itself to a IID that is a parent interface of the FIID field ? Do I have to create another instance of the TVirtualInterface for the IKey interface ?
Thank you very much.
You are misusing TVirtualInterface. It is just an RTTI helper, you should not be deriving from it at all. You should be deriving from TInterfacedObject instead.
Also, both of your TKey classes are ignoring the PTypeInfo that is passed to the constructor. The non-Generic TKey.Cast() is always querying for IKey only, never a descendant interface. And the Generic TKey<T>.Cast is always re-querying T's RTTI to get its IID. So get rid of the PTypeInfo in the constructor, it is wasted.
Since the non-Generic TKey is just a base class that doesn't actually implement any derived interfaces at all, TKey.QueryInterface() will always fail for any interface other than IKey itself. At least the Generic TKey can query a derived interface.
Your Cast functions are redundant anyway, since you can use the as operator, or the SysUtils.Supports() function, to cast one interface to another. These are the preferred methods, not using QueryInterface() manually.
In any case, your interfaces are missing IIDs in their declarations, so you can't cast between interfaces anyway.
Try something more like this:
// Base code
IKey = interface
['{D6D212E0-C173-468C-8267-962CFC3FECF5}']
function KeyFields : string;
function KeyValues : Variant;
function GetKeyValue(const aKeyName : string) : Variant;
procedure SetKeyValue(const aKeyName : string; Value : Variant);
end;
// Generated code
ITable1Key = interface(IKey)
['{B8E44C43-7248-442C-AE1B-6B9E426372C1}']
end;
ITable1Key1 = interface(ITable1Key)
['{0C86ECAA-A8E7-49EB-834F-77DE62BE1D28}']
procedure SetField1(const Value : string);
function GetField1 : string;
property Field1 : string read GetField1 write SetField1;
end;
ITable1Key2 = interface(ITable1Key)
['{82226DE9-221C-4268-B971-CD72617C19C7}']
procedure SetField1(const Value : string);
function GetField1 : string;
property Field1 : string read GetField1 write SetField1;
procedure SetField2(const Value : string);
function GetField2 : string;
property Field2 : string read GetField1 write SetField1;
end;
// Other generated declarations
type
TKey = class(TInterfacedObject, IKey)
public
function Cast : IKey;
// IKey methods...
end;
TKey<T : IKey> = class(TInterfacedObject, IKey, T)
public
function Cast : T;
end;
TTable1Key = class(TKey, IKey, ITable1Key)
end;
TTable1Key1 = class(TTable1Key, IKey, ITable1Key, ITable1Key1)
public
// ITable1Key1 methods...
end;
TTable1Key2 = class(TTable1Key, IKey, ITable1Key, ITable1Key2)
public
// Table1Key2 methods...
end;
// and so on ...
function TKey.Cast: IKey;
begin
if not Supports(Self, IKey, Result) then
raise Exception.Create('Sorry, unable to cast to IKey');
end;
function TKey<T>.Cast: T;
begin
if not Supports(Self, GetTypeData(TypeInfo(T)).Guid, Result) then
raise Exception.CreateFmt('Sorry, unable to cast to %s', [string(TypeInfo(T).Name)]);
end;
// other class methods as needed ...
Also note how the derived classes have to repeat the interfaces implemented by their base classes. That is a known Delphi limitation. Derived classes do not inherit base class interfaces. Each class has to explicitly specify the interfaces it implements, even if the actual implementation is in a base class.
I'm an newbee concerning interfaces. I googled a lot but i can't figure out what to do in the following situation.
i created serveral interfaces, which use each other:
IPart = interface(IInterface)
Function getName: string;
procedure setName(aValue: string)
property Name: string read getName write setname;
end;
IOfferLine= interface(iInterface)
Function getPart: IPart;
function getAmount: double;
procedure setPart(aPart: IPart);
procedure setAmount(value: double);
property Amount: double read getAmount write setAmount;
property Part: IPart read GetPart write setPart;
end;
IOffer= interface(iInterface)
function getOffLines: tList<IOfferline>;
procedure setOffLines(aList: tList<IOfferline>);
property OffLines: tList<IOfferlines> read getOffLines write setOfflines;
end;
Now i want to implement those interface.
TPart = class(TInterfacedObject, IPart)
private
_Name: string;
function getName: string;
procedure setName(aValue: string);
public
property Name: string read getName write setName;
end;
TOfferLine = class(TInterfacedObject, IOfferLine)
private
_amount: double;
_part: TPart;
function getAmount: double;
function getPart: tPart;
procedure setAmount(aValue: double);
procedure setPart(aPart: TPart);
public
property Amount: double read getAmount write setAmount;
property Part: TPart read GetPart write SetPart;
end;
TOffer = class(TInterfacedObject, IOffer)
private
_OfferLines: tList<TOfferline>;
function getOffLines: tList<tOfferline>;
procedure setOffLines(aList: tList<tOfferline>);
public
property offLines: tList<TOfferline> read getOffLines write setOffLines;
end;
I have added the implementation.
function TOfferLine.getPart: tPart;
begin
result := _part;
end;
But i still get 'Missing implementation of interface method IOfferline.GetPart;'
And i Can't figure out why.
I dont know what you are trying to to but if you didn't write you code so messy it would be easier to read. But thank God we have a Source formatter.
There are seval problems in you code:
First You have your property declared as property OffLines: TList<IOfferline**s**> while your interface is named IOfferline
Then TOfferline you have a method procedure setPart(aPart: TPart); that should be procedure setPart(aPart: IPart); because thats how you declared your interface. And all the other places where you Use TPart should be IPart.
And the same goes for TOffer
Here is a cleaned up version of your code :
unit Unit20;
interface
uses
Generics.Collections;
type
IPart = interface(IInterface)
function getName: string;
procedure setName(aValue: string);
property Name: string read getName write setName;
end;
IOfferLine = interface(IInterface)
function getPart: IPart;
function getAmount: double;
procedure setPart(aPart: IPart);
procedure setAmount(value: double);
property Amount: double read getAmount write setAmount;
property Part: IPart read getPart write setPart;
end;
IOffer = interface(IInterface)
function getOffLines: TList<IOfferLine>;
procedure setOffLines(aList: TList<IOfferLine>);
property OffLines: TList < IOfferLine > read getOffLines write setOffLines;
end;
TPart = class(TInterfacedObject, IPart)
private
_Name: string;
function getName: string;
procedure setName(aValue: string);
public
property Name: string read getName write setName;
end;
TOfferline = class(TInterfacedObject, IOfferLine)
private
_amount: double;
_part: TPart;
function getAmount: double;
function getPart: IPart;
procedure setAmount(aValue: double);
procedure setPart(aPart: IPart);
public
property Amount: double read getAmount write setAmount;
property Part: IPart read getPart write setPart;
end;
TOffer = class(TInterfacedObject, IOffer)
private
_OfferLines: TList<TOfferline>;
function getOffLines: TList<IOfferLine>;
procedure setOffLines(aList: TList<IOfferLine>);
public
property OffLines: TList < IOfferLine > read getOffLines write setOffLines;
end;
implementation
{ TOfferline }
function TOfferline.getAmount: double;
begin
end;
function TOfferline.getPart: IPart;
begin
end;
procedure TOfferline.setAmount(aValue: double);
begin
end;
procedure TOfferline.setPart(aPart: IPart);
begin
end;
{ TOffer }
function TOffer.getOffLines: TList<IOfferLine>;
begin
end;
procedure TOffer.setOffLines(aList: TList<IOfferLine>);
begin
end;
{ TPart }
function TPart.getName: string;
begin
end;
procedure TPart.setName(aValue: string);
begin
end;
end.
The reason the compiler is saying that the implementation is missing is simply because the implementation is missing.
Your interface for IOfferLine declares this getPart method:
IOfferLine= interface(iInterface)
..
function getPart: IPart;
..
end;
But your implementing class does not provide this method. The getPart method in your class is implemented to return an object reference, not an interface reference:
TOfferLine = class(TInterfacedObject, IOfferLine)
private
..
function getPart: tPart;
..
end;
You need to ensure that your implementing class actually provides the members required by the interfaces that it implements, exactly and precisely:
TOfferLine = class(TInterfacedObject, IOfferLine)
private
..
function getPart: IPart;
..
end;
function TOfferline.getPart: IPart;
begin
result := _part as IPart;
end;
However, since the reference to the Part maintained by the OfferLine object (in the _part variable) is an object reference, then references to that object obtained using interfaces (via the getPart: IPart method) could result in that Part object being destroyed since the object reference in OfferLine is not counted (literally).
You can of course avoid this by making the Part reference held by OfferLine an interface reference itself, but whether this is valid is difficult to say with out a complete picture of your entire object model. If the lifetimes of your objects are ensured by some other mechanism not apparent from the question then it may not be an issue, but if it is not something that has been specifically considered thus far then it probably does need addressing.
Although it is possible to do safely, as a general rule mixing object references and interface references to the same objects is a recipe for problems.
i have a base class and 10 class derived from that class. Base class contain a function that except parameter of type procedure of object. like this
mytype = procedure (a : integer) of object;
baseclass = class
public
procedure myproc(cont handler : mytype ) ;
end;
procedure baseclass.myproc(cont handler : mytype ) ;
begin
// do something
end;
i am overloading this function in derived class i.e derived class contain same function but with different parameter (procedure ( const handler : integer ) of object ). like this
base1mytype = procedure (a : string) of object;
derivedclass1 = class(baseclass)
public
procedure myproc(cont handler : base1mytype ) ;overload;
end;
base2mytype = procedure (a : boolean) of object;
derivedclass1 = class(baseclass)
public
procedure myproc(cont handler : base2mytype ) ;overload;
end;
and so on.........
All i want a generic class that implement this function and i derive my classes from that function eg
mytype = procedure (a : integer) of object;
baseclass<T> = class
public
procedure myproc(cont handler : T) ;
end;
procedure baseclass<T>.myproc(cont handler : T ) ;
begin
// do something
end;
and derive classes are like this
deriveclass1 = class<baseclass <string>>
public
procedure myproc(cont handler : T) ;
end;
Since generic constraint does not support constrain of type procedure of object
You need a generic class with an internal type definition:
type
TBaseClass<T> = class
public
type
THandler = procedure(Arg: T) of object;
public
procedure CallHandler(Handler: THandler; Arg: T);
end;
procedure TBaseClass<T>.CallHandler(Handler: THandler; Arg: T);
begin
Handler(Arg);
end;
Consider an interface like
IMyInterface = interface
procedure DoSomethingRelevant;
procedure Load (Stream : TStream);
procedure Save (Stream : TStream);
end;
and several classes that implement the interface:
TImplementingClass1 = class (TInterfacedObject, IMyInterface)
...
end;
TImplementingClass2 = class (TInterfacedObject, IMyInterface)
...
end;
...
I have a class that has a list of IMyInterface implementors:
TMainClass = class
strict private
FItems : TList <IMyInterface>;
public
procedure LoadFromFile (const FileName : String);
procedure SaveToFile (const FileName : String);
end;
Now to the question: how can I load the main class and especially the item list in an object-oriented manner? Before I can call the virtual Load method for the items, I have to create them and thus have to know their type. In my current implementation I store the number of items and then for each item
a type identifier (IMyInterface gets an additional GetID function)
call the Save method of the item
But that means that during loading I have to do something like
ID := Reader.ReadInteger;
case ID of
itClass1 : Item := TImplementingClass1.Create;
itClass2 : Item := TImplementingClass2.Create;
...
end;
Item.Load (Stream);
But that doesn't seem to be very object-oriented since I have to fiddle with existing code every time I add a new implementor. Is there a better way to handle this situation?
One solution would be to implement a factory where all classes register themselve with a unique ID.
TCustomClassFactory = class(TObject)
public
procedure Register(AClass: TClass; ID: Integer);
function Create(const ID: Integer): IMyInterface;
end;
TProductionClassFactory = class(TCustomClassFactory)
public
constructor Create; override;
end;
TTestcase1ClassFactory = class(TCustomClassFactory);
public
constructor Create; override;
end;
var
//***** Set to TProductionClassFactory for you production code,
// TTestcaseXFactory for testcases or pass a factory to your loader object.
GlobalClassFactory: TCustomClassFactory;
implementation
constructor TProductionClassFactory.Create;
begin
inherited Create;
Register(TMyImplementingClass1, 1);
Register(TMyImplementingClass2, 2);
end;
constructor TTestcase1ClassFactory.Create;
begin
inherited Create;
Register(TMyImplementingClass1, 1);
Register(TDoesNotImplementIMyInterface, 2);
Register(TDuplicateID, 1);
Register(TGap, 4);
...
end;
Advantages
You can remove the conditional logic from your current load method.
One place to check for duplicate or missing ID's.
You need a class registry, where you store every class reference together with their unique ID. The classes register themselves in the initialization section of their unit.
TImplementingClass1 = class (TInterfacedObject, IMyInterface)
...
end;
TImplementingClass2 = class (TInterfacedObject, IMyInterface)
...
end;
TMainClass = class
public
procedure LoadFromFile (const FileName : String);
procedure SaveToFile (const FileName : String);
end;
Edit: moved the class registry into a separate class:
TMyInterfaceContainer = class
strict private
class var
FItems : TList <IMyInterface>;
FIDs: TList<Integer>;
public
class procedure RegisterClass(TClass, Integer);
class function GetMyInterface(ID: Integer): IMyInterface;
end;
procedure TMainClass.LoadFromFile (const FileName : String);
...
ID := Reader.ReadInteger;
// case ID of
// itClass1 : Item := TImplementingClass1.Create;
// itClass2 : Item := TImplementingClass2.Create;
// ...
// end;
Item := TMyInterfaceContainer.GetMyInterface(ID);
Item.Load (Stream);
...
initialization
TMyInterfaceContainer.RegisterClass(TImplementingClass1, itClass1);
TMyInterfaceContainer.RegisterClass(TImplementingClass2, itClass2);
This should point you into the direction, for a very good introduction into these methods read the famous Martin Fowler article, esp. the section about Interface Injection