Generic mechanism for instantiating distinct types in Delphi - oop

I'm trying to use generics to 'genericize' a var that instantiates network transports of different types. I'm not sure if the "generic=no RTTI" rule would invalidate the approach or not, as I'm not yet up to speed with generics.
I've read this post:
What is the correct way to structure this generic object creation , which states the following in the question:
One other thing I would like to do if possible, is to change two
creations:
LAdapter := TSQLiteNativeConnectionAdapter.Create(LFilename)
LAdapter := TFireDacConnectionAdapter.Create(FDatabaseLink.FConnection as TFDConnection, FDatabaseLink.OwnedComponent)
to use an abstract "GetAdapterClass" type function in the parent
TModelDatabaseConnection and just declare the class of adapter in the
child to do something like:
LAdapter := GetAdapterClass.Create...
This is exactly what I would like to do as well. So if you can picture this:
type
TTransport<T> = class(TComponent)
private
...
function GetTransport: TTransport;
procedure SetTransport(AValue: TTransport);
...
public
...
property Transport: TTransport read GetTransport write SetTransport;
...
end;
TTCPIPTransport = class(TTransport<T>)
private
function GetSocket(Index: Integer): String;
procedure SetSocket(Index: Integer; AValue: String);
public
property Socket[Index: Integer]: String read GetSocket write SetSocket;
end;
TServiceTransport = class(TTransport<T>)
private
function GetServiceName: String;
procedure SetServiceName(AValue: String);
public
property ServiceName: String read GetServiceName write SetServiceName;
end;
TISAPITransport = class(TServiceTransport<T>);
THTTPSysTransport = class(TServiceTransport<T>)
private
function GetURL(Index: Integer): String;
procedure SetURL(Index: Integer; AValue: String);
public
property URL[Index: Integer]: read GetURL write SetURL;
end;
etc.
The idea is to create a base class that has all fields/properties/methods that are common to all transports, then have intermediate classes that contain fields/methods/properties that are common only to a certain subset of transports, then have the final version of each transport be specific to the type.
So when I call:
var
trans: TTransport<T> // or TTransport<TTCPIPTransport> etc.
begin
trans := TTransport<TTCPIPTransport>.Create(AOwner,....);
trans.Transport.Socket[0] := '127.0.0.1:8523';
OR
trans := TTransport<TISAPITransport>.Create(AOwner,...);
trans.Transport.ServiceName = 'Foo';
...
etc.
end;
or perhaps even more generic then that, but have each instance of trans - without typecasting - have properties/fields/methods that are specific to the subclass automagically show up.
This way I can have a config screen that allows an administrator to select the type of transport say in a combo box, the have that variable value set the type inside the <> in code, and one set of code handles creation of the object by it's type.
Is this possible using generics?

Here is my first (feeble) attempt at a class factory, never done this before. It works partially (generates the correct class) but isn't accessible as a distinct subclass of the base class without typecasting, which defeats the purpose. Please see inline comments
TWSTransport = class(TComponent)
...
public
constructor Create(AOwner: TComponent); virtual;
....
end;
TWSTransportClass = Class of TWSTransport;
TWSTCPIPTransportClass = class of TWSTCPIPTransport;
TWSHTTPSysTransport = class(TWSServiceTransport);
TWSServiceTransport = class(TWSTransport);
TWSTransportStringConversion = class(TWSTransport);
TWSTransportStreamFormat = class(TWSTransportStringConversion);
TTransportFactory = class(TClassList)
private
function GetTransport(Index: TWSTransportClass; AOwner: TkbmMWServer): TWSTransportClass;
public
procedure RegisterTransportClass(ATransportClass: TWSTransportClass);
property Transport[Index: TWSTransportClass; AOwner: TkbmMWServer]: TWSTransportClass read GetTransport;
end;
function TTransportFactory.GetTransport(Index: TWSTransportClass; AOwner: TkbmMWServer): TWSTransportClass;
begin
if IndexOf(Index) > -1 then
Result := TWSTransportClass(Items[IndexOf(Index)])
else
Result := TWSTransportClass(Index.Create(AOwner));
end;
procedure TTransportFactory.RegisterTransportClass(ATransportClass: TWSTransportClass);
var
index: Integer;
begin
// is the transport registered?
index := IndexOf(ATransportClass);
if index < 0 then
// the transport is not registered, add it to the list
Add(ATransportClass);
end;
initialization
factory := TTransportFactory.Create;
factory.RegisterTransportClass(TWSHTTPSysTransport);
factory.RegisterTransportClass(TWSISAPIRESTTransport);
factory.RegisterTransportClass(TWSTCPIPTransport);
finalization
FreeAndNil(factory);
end.
Here's how I tested it:
procedure TForm4.FormCreate(Sender: TObject);
var
//trans: TWSTCPIPTransport; // this doesn't work
trans: TWSTransport; // this works
begin
trans := factory.Transport[TWSTCPIPTransport,Self];
showmessage(trans.classname); // this shows the correct classname - TWSTCPIPTransport
trans.AddSocket('127.0.0.1:80'); // the compiler gives an error here because this call is specific to a subclass of TWSTransport, TWSTCPIPTransport.
end;
So I'm still missing something... anyone see the mistake?

Related

Using Object Orientated subclasses in a separate form

I have created a factory unit that contains multiple subclasses for different functions.
FACTORY UNIT
//parent
type
TfactoryU = class(Tobject)
public
constructor create;
end;
//subclass 1
TFormPosition = class (TfactoryU)
private
fFormName:tform;
public
constructor create (formName:tform);
procedure centerForm(frm:tform);
end;
implementation
{ TfactoryU }
constructor TFormPosition.Create(formName:tform);
begin
Inherited Create;
fFormName:=formname;
end;
procedure TFormPosition.centerForm(frm:tform);
begin
frm.Left := (Screen.Width - frm.Width) div 2;
frm.Top := (Screen.Height - frm.Height) div 2;
end;
constructor TfactoryU.create;
begin
end;
However, I do not know how to call the subclass procedure from a different unit.
MAIN UNIT
procedure TfrmMERCH.FormActivate(Sender: TObject);
var
objfactoryU:TfactoryU;
begin
objfactoryU:=tformposition.create(frmmerch);
objfactoryU.centerForm(frmmerch);
The calling of the procedure centerForm is underlined in red.
centerForm() is not a member of TfactoryU, that is why you get an error when trying to call it via a TfactoryU variable. You need to use a type-cast to reach it, eg:
procedure TfrmMERCH.FormActivate(Sender: TObject);
var
objfactoryU: TfactoryU;
begin
objfactoryU := tformposition.create(frmmerch);
tformposition(objfactoryU).centerForm(frmmerch);
However, since both the declaration of objfactoryU and the call to the centerForm() method are in the same procedure, you should just change the declaration instead:
procedure TfrmMERCH.FormActivate(Sender: TObject);
var
objfactoryU: tformposition;
begin
objfactoryU := tformposition.create(frmmerch);
objfactoryU.centerForm(frmmerch);

How to correct this runtime error and why do i get it in Delphi?

I am trying to call a remote API function in Delphi:
procedure TForm4.Button1Click(Sender: TObject);
var
getBalance1 : getBalance;
type1 : consenttype;
begin
getBalance1.consent.type_ := type1;
getBalance1.consent.target := Edit5.Text;
getBalance1.consent.id := Edit6.Text;
Application.ProcessMessages;
valasz := (HTTPRio1 as AccountInfo_PT).getBalance(getBalance1);
end;
But at runtime, I get this error:
Access violation at address 00791D72 in module generate_xml_exe. Write of address 0000000C.
What is this, and how can I correct it? I get this error when I click on the button at runtime.
getBalance is a class of getBalance_Type:
getBalance_Type = class(TRemotable)
private
Fconsent: consent5;
public
constructor Create; override;
destructor Destroy; override;
published
property consent: consent5 Index (IS_UNQL) read Fconsent write Fconsent;
end;
// ************************************************************************ //
// XML : getBalance, global, <element>
// Namespace : http://bbrt.hu/openApiServices/AccountInfo/1/
// Info : Wrapper
// ************************************************************************ //
getBalance = class(getBalance_Type)
private
published
end;
consent5 = class(TRemotable)
private
Ftype_: consentType;
Ftarget: targetType;
Fid: consentIdType;
published
property type_: consentType Index (IS_UNQL) read Ftype_ write Ftype_;
property target: targetType Index (IS_UNQL) read Ftarget write Ftarget;
property id: consentIdType Index (IS_UNQL) read Fid write Fid;
end;
These lines cause the runtime error:
getBalance1.consent.type_ := type1;
getBalance1.consent.target := Edit5.Text;
getBalance1.consent.id := Edit6.Text;
But I don't know how to correct this.
The immediate cause of your Access Violation is that getBalance1 of type getBalance is not created.
All CLASSes in Delphi need to be created, usually via a CONSTRUCTOR named Create. As you don't implicitly create the getBalance1 variable, it contains a random value, and you cannot (safely) access its content.
So, before you start using the getBalance1 variable, you need to create it, as in:
getBalance1 := getBalance.Create;

Delphi class variables

I have the following code:
// irrelevant code ...
type
Zombie = class
private
...
Age : Integer;
Alive : Boolean;
TotalDeadZombies, TotalZombieAge : Double;
public
...
procedure ZombieGrow();
procedure CheckIfDead();
...
Function AvgLife() : Double;
end;
procedure Zombie.ZombieGrow();
begin
...
if (Alive = false) then
begin
TotalDeadZombies := TotalDeadZombies + 1;
TotalZombieAge := TotalZombieAge + Age;
end;
end;
procedure Zombie.CheckIfDead();
begin
if Random(100) < 20 then
Alive := False;
end;
function Zombie.AvgLife() : Double;
begin
Result := TotalZombieAge / TotalDeadZombie;
end;
The problem I have is I want to display the average age of dead zombies. This would be done via something like :
Write('Average age '+Floattostr(Round(AvgLife)))
However, this is called in another class (not shown here), and from my understanding of OOP, it would require me to specify an instantiated object, e.g zombies[1].AvgLife if they were stored in, say, a Zombies[] array (just an example).
Is there a way of making it so the variables TotalDeadZombies and TotalZombieAge are not tied to any instantiated zombies, but rather to a class variable that I can then just call AvgLife somehow? Is it as simple as just making them global variables? Or can it be done another way?
You just have to declare the variables as class var; then they belong to the class, and not to a particular instance of a class.
type
TZombie = class
public
class var TotalDeadZombies, TotalZombieAge: Double;
end;
You can access these like TZombie.TotalDeadZombies. Similarly, there are class methods, class properties, etc.
Have a look at the official documentation.

Dynamic Dispatching in Ada with Access Types

I am trying to create a package that has Dynamic dispatching using access types. I have achieved Dynamic Dispatching using Class Types using This Q/A as a guide.
I keep getting a compilation error that says: cannot call abstract subprogram. This makes me think that the compiler either doesnt recognize the specialized subprogram, or doesnt recognize the type as a specialized type. But both seem right to me... I dont get it.
main.2.ada
with Ada.Text_IO;
with Animal.Cat;
procedure Main is
Tabby : aliased Animal.Cat.Cat_t;
Animal_Ref : Animal.Any_Animal_Ptr := Tabby'Unchecked_Access;
Result : Boolean;
begin
Animal.Stroke_Fur (Animal => Animal_Ref.all);
Result := Animal.Is_Happy(Ptr => Animal_Ref);
Ada.Text_IO.Put_Line ("Happy Animal = " & Boolean'Image (Result));
end Main;
animal.1.ada
package Animal is
type base_t is abstract tagged limited null record;
type Animal_t is abstract new
base_t with private;
type Any_Animal_Ptr is access all Animal_t'Class;
----
procedure Stroke_Fur (Animal : in out Animal_t) is abstract;
----
function Is_Happy (Ptr : in Any_Animal_Ptr) return boolean is abstract;
private
type Animal_t is abstract new base_t with
record
Index : integer;
end record;
end Animal;
animal.cat.1.ada
package Animal.Cat is
type Cat_t is new Animal.Animal_t with private;
type Cat_Ptr is access all Cat_t;
----
procedure Stroke_Fur (Cat : in out Cat_t);
----
function Is_Happy (Ptr : in Cat_Ptr) return Boolean;
private
type Cat_t is new Animal.Animal_t with
record
Purr : Boolean := False;
end record;
end Animal.Cat;
animal.cat.2.ada
package body Animal.Cat is
----
procedure Stroke_Fur (Cat : in out Cat_t) is
begin
Cat.Purr := True;
end Stroke_Fur;
----
function Is_Happy (Ptr : in Cat_Ptr) return Boolean is
begin
return Ptr.Purr;
end Is_Happy;
end Animal.Cat;
Error
main.2.ada:13:21: cannot call abstract subprogram "Is_Happy"
function Is_Happy (Ptr : in Any_Animal_Ptr) return boolean is abstract;
isn’t a primitive operation (ARM3.2.3(2)) of Animal_t, and so it isn’t dispatching; it’s merely an abstract subprogram (which therefore can’t be called).
Why would you want to make a non-dispatching subprogram abstract? Perhaps you might have a type Metres, in which case the predefined ”*” is inappropriate (multiplying two distances in metres returns an area, not a distance) and you might want to make it abstract to prevent inadvertent misuse.
Anyway, you can declare a primitive operation of Animal_t using accesses as
function Is_Happy (Ptr : access Animal_t) return boolean is abstract;
and then for cats
function Is_Happy (Ptr : access Cat_t) return Boolean;
(or even
overriding
function Is_Happy (Ptr : access Cat_t) return Boolean;
if you want the compiler to check that it really is overriding).
By the way, if you are using Ada 2005 or later you can use the prefixed notation to write the calls as
Animal_Ref.Stroke_Fur;
Result := Animal_Ref.Is_Happy;
which is prettier.

Pascal 'this' reference

I am starting to explore Pascal with an Object Oriented approach. I was wondering if there is a this or self reference to the current object? I have searched around for documentation but I have not come found an answer.
Edit
Through trial and error I found that you can use self. Now my question is can I achieve this (snippet below) without the compiler throwing a 'duplicate identifier error'?
constructor Employee.create(name:String; salary:Real);
begin
self.name := name;
self.salary := salary;
end;
I have a program below which creates 2 employees and displays their information
{$mode objfpc} // directive to be used for defining classes
{$m+} // directive to be used for using constructor
program EmployeeTest;
type
Employee = class
private
name:String;
salary:Real;
public
constructor create(name:String; salary:Real);
procedure setName(name:String);
function getName():String;
procedure setSalary(salary:Real);
function getSalary():Real;
procedure displayEmployee;
end;
var empl1,empl2:Employee;
constructor Employee.create(name:String; salary:Real);
begin
setName(name);
setSalary(salary);
end;
procedure Employee.setName(name:String);
begin
self.name := name;
end;
procedure Employee.setSalary(salary:Real);
begin
self.salary := salary;
end;
function Employee.getName():String;
begin
getName := self.name;
end;
function Employee.getSalary():Real;
begin
getSalary := self.salary;
end;
procedure Employee.displayEmployee;
begin
writeln('Name: ',getName,', Salary: $',getSalary:0:2);
end;
begin
empl1 := Employee.create('Bob', 75000);
empl2 := Employee.create('Joe', 50000);
empl1.displayEmployee();
empl2.displayEmployee();
readln; {pause}
end.
Didn't think that I would be answering my question.
Found the answer here.
You must use {$mode delphi} instead of {$mode objfpc} if you want to duplicate variable names inside nested functions.
Don't use the same name for a parameter and a property. Use the prefix A for a parameter.
Don't implement getter and setter methods. Use in Pascal the property keyword.
Use the prefix F for private fields.
Use the prefix T for a self defined type.
Here is an example for your class:
type
TEmployee = class(TObject)
private
FName: String;
FSalary:Real;
public
constructor Create(AName:String; ASalary:Real);
property Name: String read FName write FName;
property Salary: Real read FSalary write FSalary;
procedure DisplayEmployee;
end;
constructor TEmployee.Create(AName:String; ASalary:Real);
begin
inherited Create;
FName := AName;
FSalary := ASalary;
end;
procedure TEmployee.DisplayEmployee;
begin
WriteLn('Name: ', FName, ', Salary: $', FSalary:0:2);
end;