I am programming an MDIChild form in Delphi with the Action = caFree in OnClose event. Now I want that at one time there will only be one instance of a form. For this I used a class variable:
type
TMyForm = class(TForm)
...
class var CurInstance: TMyForm;
...
end;
constructor TMyForm.Create();
begin
inherited Create(nil);
if Assigned(TMyForm.CurInstance) then
TMyForm.CurInstance.Destroy
TMyForm.CurInstance := Self;
end;
destructor TMyForm.Destroy();
begin
TMyForm.CurInstance := nil;
inherited Destroy;
end;
The code above works pretty well and does what it should be. But I have a bad feeling about calling destructor from constructor, even through this is a different instance. Is this a correct way? Is there something else I need to consider about this?
Many thanks.
Related
I am trying to use a class to display a progress indicator.
If I declare ProgressIndicator as a variable within the calling procedure, everything works fine, and ANewForm displays as I would expect.
However, the following code produces an access violation. Can anyone help me to understand why?
unit Main;
interface
*uses
Winapi.Windows, Vcl.Forms,
System.Classes, Vcl.Controls, Vcl.StdCtrls,
Progress;
type
TProgressIndicator = class
private
public
ANewForm : TForm;
constructor Create;
end;
type
TfmMain = class(TForm)
Button1: TButton;
Button2: TButton;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
ProgressIndicator : TProgressIndicator;
end;
var
fmMain: TfmMain;
implementation
{$R *.dfm}
constructor TProgressIndicator.Create;
begin
ANewForm := TForm.Create(Application);
ANewForm.Show;
end;
procedure TfmMain.Button1Click(Sender: TObject);
begin
ProgressIndicator.Create;
end;
end.
There's a difference between ProgressIndicator.Create and TProgressIndicator.Create. Usually, you want to use the second form which says, "create a new instance of class TProgressIndicator". The first form says, "take an instance of TProgressIndicator which is stored in the variable ProgressIndicator and call its Create method". The problem is, it doesn't create that instance. In your case, ProgressIndicator is nil, because all class members are initialized to a zero-like value at the construction time, which is not a problem per-se - it still is linked to the class data so it can actually call the Create method. The method tries to create the form, which succeeds, and then tries to store it to the ANewForm field, because the in-memory address of ANewForm is Self + offset; for your code, the offset is probably 0, Self is nil, which gives a final address of (nil + 0) = 0 and the memory location 0 is located in a memory page which is prohibited from all access. That's why you get an Access Violation.
What you want is:
procedure TfmMain.Button1Click(Sender: TObject);
begin
ProgressIndicator := TProgressIndicator.Create;
end;
That will first create a new instance and then work with that.
Consider this interfaces and its implementations.
unit utest;
interface
{$MODE OBJFPC}
type
IIntfA = interface
procedure writeA();
end;
IIntfB = interface(IIntfA)
procedure writeB();
end;
TADelegateClass = class(TInterfacedObject, IIntfA)
public
procedure writeA();
end;
TAClass = class(TInterfacedObject, IIntfA)
private
delegateA : IIntfA;
public
constructor create(const AInst : IIntfA);
destructor destroy(); override;
property A : IIntfA read delegateA implements IIntfA;
end;
TBClass = class(TAClass, IIntfB)
public
procedure writeB();
end;
implementation
procedure TADelegateClass.writeA();
begin
writeln('Implement IIntfA through delegation');
end;
constructor TAClass.create(const AInst : IIntfA);
begin
delegateA := AInst;
end;
destructor TAClass.destroy();
begin
inherited destroy();
delegateA := nil;
end;
procedure TBClass.writeB();
begin
writeln('Implement IIntfB');
end;
end.
Following program will not compile.
program test;
{$MODE OBJFPC}
uses
utest;
var b : IIntfB;
begin
b := TBClass.create(TADelegateClass.create());
b.writeA();
b.writeB();
end.
Free Pascal (version 3.0.4) complains
Error: No matching implementation for interface method "writeA;" found.
at line where TBClass is declared.
Of course, I can compile it successfully by implementing writeA either in TAClass or TBClass and call writeA method of TADelegateClass from there.
TAClass is concrete implementation of IIntfA interface through interface delegation but why TBClass, which is descendant of TAClass, is not considered a concrete implementation of IIntfA interface?
TAClass is concrete implementation of IIntfA interface through
interface delegation but why TBClass, which is descendant of TAClass,
is not considered a concrete implementation of IIntfA interface?
Short answer: it's not IIntfA that is the problem, it is IIntfB that is incomplete.
Long answer: Interface inheritance is C++ vtable inheritance, which is sometimes not intuitive.
In the example:
IIntfB = interface(IIntfA)
procedure writeB();
end;
could actually be written as
IIntfB = interface
procedure writeA();
procedure writeB();
end;
When implementing multiple interfaces, common parts are not reused. The compiler sets up individual tables from the implementing methods, such as:
TADelegateClass:
QueryInterface(IIntfA) = Self.vtable_IIntfA
vtable_IIntfA.writeA <- Self.writeA
TAClass:
QueryInterface(IIntfA) = delegateA.vtable_IIntfA
TBClass:
QueryInterface(IIntfA) = inherited delegateA.vtable_IIntfA
QueryInterface(IIntfB) = vtable_IIntfB
vtable_IIntfB.writeA <- (this is missing!)
vtable_IIntfB.writeB <- Self.writeB
TBClass does indeed not have an implementation of IIntfB.writeA.
This can be verified by manually assigning a method to the specific interface and observe the error disappearing:
TBClass = class(TAClass, IIntfB)
public
procedure IIntfB.writeA = writeB;
// dummy method, shows IIntfB.writeA is missing
Sadly, I don't know of any way to tell the compiler to access a mapping from another interface. FWIW, Delphi has the same bug/shortcoming.
I have a component with bellow properties:
property Form: TForm read FForm write SetForm
property BtnOK: TButton read FBtnOK write SetBtnOK
and a procedure behind like this:
procedure Execute_FormShowModal;
I would like to open the associated form (eg. FormUser) when the Execute_FormShowModal is executed.
I would like to mention that, the associated form is already defined and exist, but is not created.
Is there any possibility to do this?
procedure TMyComp.Execute_FormShowModal;
var
frm: TForm;
begin
frm:= TForm(FForm.ClassName).Create(FParentForm); //Access Violation...
//... here I would like to play also this the elements from this form
//like: BtnOK.Enabled:= False;
frm.ShowModal;
frm.Free;
end;
You added in the comments that you are setting FForm to be equal to a valid existing form. If so, you may not need to create anything:
procedure TMyComp.Execute_FormShowModal;
var
frm: TFormUser;
begin
frm:= TFormUser(FForm);
frm.BtnOK.Enabled:=False;
frm.ShowModal;
//frm.Free;
end;
This assumes that this valid instance you are referring to is declared
type
TFormUser = class(TForm)
BtnOK : TButton;
// etc...
end;
If you trying to make a copy of the form you might use this:
procedure TMyComp.Execute_FormShowModal;
var
frm: TFormUser;
begin
frm:= TFormUser(TFormClass(FForm.ClassType).Create(FParentForm));
// which is no different than:
frm:= TFormUser.Create(FParentForm));
frm.BtnOK.Enabled:=False;
frm.ShowModal;
frm.Free;
end;
If you want to manipulate the controls on the form (i.e. BtnOK), then you need to know the class type of the Form (TFormUser in this case). So it is contradictory to be required to know the exact class type of the form and yet want to instanciate a form from a design-time established type.
Since you may be trying to instanciate the form without "knowing" its absolute type, your FForm property should be the class for the form.
Assuming you weren't publishing the "Form" property in your component, I would make these changes to your component:
TMyComp = class(TComponent)
FFormClass : TFormClass;
procedure SetFormClass(Value : TFormClass);
property FormClass: TFormClass read FFormClass write SetFormClass;
procedure Execute_FormShowModal;
end;
The initialization code you referred to might look like this:
begin
// .....
//MyComp.Form := FormUser1;
MyComp.FormClass := TFormUser;
// .....
end;
And then "Execute_FormShowModal" becomes:
procedure TMyComp.Execute_FormShowModal;
var
frm: TForm;
begin
// Check that FFormClass is not nil and perform some alternate
// action.
// if FFormClass = nil then ......
//
frm:= FFormClass.Create(FParentForm);
frm.ShowModal;
frm.Free;
end;
Of course, you may also want to add some code to check if FFormClass is nil and preform some alternate behavior if so, like raise an exception or showing some message or even instanciating a default form.
If you were publishing the Form property then it won't be able to handle the case where your FForm field value is nil because you don't know or have a specific class type to instanciate the Form. That is:
frm:= TFormClass(FForm.ClassType).Create(FParentForm);
will simply display a blank, empty form.
If you want to publish this property, you could try making it a string type that carries the name of the form class you want to instanciate and then use RTTI to find the class:
uses RTTI;
TMyComp = class(TComponent)
FFormClassName : string;
procedure SetFormClassName(const Value : string);
property FormClassName: string read FFormClassName write SetFormClassName;
procedure Execute_FormShowModal;
end;
procedure TMyComp.Execute_FormShowModal;
var
frmCls : TFormClass;
frm: TForm;
RTTI : TRTTIContext;
RTTIType : TRTTIType;
begin
frmCls := nil;
for RTTIType in RTTI.GetTypes do
begin
if (RTTIType.Name = FFormClassName) and (RTTIType.TypeKind = tkClass) then
begin
if RTTIType.Handle.TypeData.ClassType.InheritsFrom(TForm) then
begin
frmClass := TFormClass(RTTIType.Handle.TypeData.ClassType);
break;
end;
end;
end;
// Check that frmCls is not nil and perform some alternate
// action.
// if frmCls = nil then ......
//
frm:= frmCls.Create(FParentForm);
frm.ShowModal;
frm.Free;
end;
Is there any possibility to do this?
Yes
Try something like this
uses uFForm; // Add the unit name that defined the associated form to your (TMyComp) unit uses clause
procedure TMyComp.Execute_FormShowModal;
begin
with TFForm.Create(Self) do //TFForm is the child form
begin
//... here I would like to play also this the elements from this form
BtnOK.Enabled:= False;
Show;
end;
end;
First problem is that you are trying to typecast the ClassName to a class type that you're trying to instantiate. Instead you want to work with the metaclass that can be obtained by the ClassType method from an object instance. The next issue is that with such metaclass you need to typecast to a metaclass, not to a class, so instead of typecasting to TForm class cast to its metaclass TFormClass.
To the next part of your question, if you can generally access a specific class members of an object that is declared as a common class ancestor, no, that is not possible. As a workaround you must determine the object class type and access it by typecasting to that class, or use RTTI which is more difficult.
Try something like this:
procedure TMyComp.Execute_FormShowModal;
var
frm: TForm;
begin
frm := TFormClass(FForm.ClassType).Create(FParentForm);
{ to acess the class specific members you will have to typecast to a
specific class (or use RTTI, which is even more difficult) }
if frm is TMyForm then
TMyForm(frm).BtnOK.Enabled := False;
frm.ShowModal;
frm.Free;
end;
program Project1;
type
ob = class
num: integer;
constructor init(id: integer);
destructor done();
end;
constructor ob.init(id: integer);
begin
self.num := id;
end;
destructor ob.done();
begin
end;
type
plist = ^list;
list = record
myob: ^ob;
Next: plist;
end;
var start:plist;
begin
start:=nil;
new(start);
start^.myob^:=ob.init(1);
new(start^.next);
start^.Next^.myob^:=ob.init(2);
start^.next^.myob^.done();
dispose(start^.Next);
start^.myob^.done();
dispose(start);
end.
this code results in
Error: Project project1 raised exception class 'External: SIGSEGV'. At address 405B32
when i try to run in debug i get the assembler screen popup and display
SYSTEM_$$_SYSGETMEM$LONGWORD$$POINTER(147)
00405B23 b890e44000 mov $0x40e490,%eax
00405B28 e813080000 call 0x406340 <SYSTEM_$$_ENTERCRITICALSECTION$TRTLCRITICALSECTION>
00405B2D 89d8 mov %ebx,%eax
00405B2F 8b5004 mov 0x4(%eax),%edx <-error here
00405B32 8b92a0000000 mov 0xa0(%edx),%edx <-or it might be here
00405B38 89500c mov %edx,0xc(%eax)
00405B3B 8b5004 mov 0x4(%eax),%edx
00405B3E 8982a0000000 mov %eax,0xa0(%edx)
00405B44 b890e44000 mov $0x40e490,%eax
00405B49 e802080000 call 0x406350 <SYSTEM_$$_LEAVECRITICALSECTION$TRTLCRITICALSECTION>
any help would be appreciated
how do i go about fixing this it seems to only happen when i try to use dispose
thank you in advance
First of all, you should not take a pointer of a class instance (a.k.a. object). A class instance is already a reference type:
plist = ^list;
list = record
myob: ob;
next: plist;
end;
Now you can do:
start^.myob := ob.init(1);
...
start^.next^.myob := ob.init(2);
and you will not get a crash anymore.
And now some remarks
It is not obligatory, but it is usual to use Create as the name for the constructor. And the destructor is generally called Destroy, and should be an override (of the virtual TObject.Destroy):
ob = class
num: Integer;
constructor Create(id: Integer);
destructor Destroy; override;
end;
Also, it is usually a good idea to call the inherited constructor in the constructor and the inherited destructor in the destructor. Even if your class (implicitly) derives from TObject directly, this may not be the case in a less trivial program.
And finally, it is a good habit to never call the destructor directly. Use Free instead (this presupposes that your destructor is override and called Destroy). This checks for Self being nil first, which is good for class instances stored in other classes (if the outer class constructor fails, some of the contained classes may not have been initialized when the outer class' destructor is called).
Look at this sample:
//----------------------------------------------------------------------------
type
ISomeInterface = interface
procedure SomeMethod;
end;
// this is wrong, but illustrates that, what i need:
TSomeClassWhichImplementsSomeInterface = class of ISomeInterface;
var
gHardCodedPointer: Pointer; // no matter
procedure Dummy(ASomeClassToWorkWith: TSomeClassWhichImplementsSomeInterface);
begin
// actually, type of ASomeClassToWorkWith is unknown (at least TObject), but it
// must implement SomeMethod, so i can make something like this:
ASomeClassToWorkWith(gHardCodedPointer).SomeMethod;
end;
...
type
TMyClass = class(TInterfacedObject, ISomeInterface)
end;
...
// TMyClass implements ISomeInterface, so i can pass it into Dummy:
Dummy(TMyClass);
//----------------------------------------------------------------------------
Of course i can inherit TMyClass and use it childs, but I don't need this. I want to use another classes with their own hierarchy, just adding into them implementation of ISomeInterface (because there are no multiple-inheritance avaiable in Object Pascal, like in C++).
I know it may be looked crazy, don't ask me why I need this, just say - it is possibly to implement or not. Thanks a lot!
I think what you are looking for is this:
procedure Dummy;
var Intf : ISomeInterface;
begin
if Assigned(gHardCodedPointer) and Supports(gHardCodedPointer,ISomeInterface,Intf) then
Intf.SomeMethod
end;
If it's not, I have no clue about what you are trying to achieve there...
You can declare metaclasses, but you cannot define them in terms of what interfaces the base class implements. Interface implementation can only be checked at run time.
You can pass your Dummy function a metaclass, but you cannot use that metaclass to type-cast your plain pointer to a more specific type. Type-casting is a compile-time operation, but the actual value of the metaclass parameter isn't known until run time. The best you can do is type-cast it to the metaclass's base class. Then you can call all the methods that are defined in that base class.
But it seems you don't actually care what the base class is, as long as the class implements your interface. In that case, you can ignore the metaclass parameter. Type-cast your pointer to be a TObject (or, better yet, declare gHardCodedPointer to be a TObject in the first place), and then use the Supports function to get the interface reference.
var
SupportsInterface: Boolean;
Some: ISomeInterface;
begin
SupportsInterface := Supports(TObject(gHardCodedPointer), ISomeInterface, Some);
Assert(SupportsInterface, 'Programmer stored bad class instance in gHardCodedPointer');
Some.SomeMethod;
end;
If you really care about the metaclass parameter, you can add some enforcement for it, too. You can check whether the given class implements your interface, and you can check whether the object in gHardCodedPointer is an instance of that class:
Assert(ASomeClassToWorkWith.GetInterfaceEntry(ISomeInterface) <> nil);
Assert(TObject(gHardCodedPointer).InheritsFrom(ASomeClassToWorkWith));
But notice that you don't need to check either of those results to be able to call SomeMethod on gHardCodedPointer. They don't really matter.
By the way, the only hard-coded pointer value you can hope to have in Delphi is nil. All other pointer values are addresses that are very hard to predict at compile time because the compiler, the linker, and the loader all determine where everything really goes in memory. I suggest you come up with some other name for that variable that more accurately describes what it really holds.
Why can't you use the interface reference?
But, assuming there is a good reason for that, this might help.
As you have found out, you can't do class of on an interface.
What's more you can't use a variable value to cast anything to anything else. Casting is hardwired telling the compiler that you know the reference you are casting is of a specific type. Trying to do that with a var such as your ASomeClassToWorkWith parameter is going to produce errors as it goes against the very nature of casting.
Code below is not something I'd recommend, but it compiles and I think it does what you want. What it does is use a "dummy" ancestor and employs polymorfism to get the compiler to call the method on the correct type. If you do not mark SomeMethod as virtual, you will get the dummy ancestor's message on both button clicks.
The Instance function in the interface is there to show you a means of getting to the implementing instance of an interface without using RTTI. Just be aware of the caveat of this when using interface delegation: you may not get the instance you are expecting.
type
TForm1 = class(TForm)
TSomethingBtn: TButton;
TMyClassBtn: TButton;
procedure FormCreate(Sender: TObject);
procedure TSomethingBtnClick(Sender: TObject);
procedure TMyClassBtnClick(Sender: TObject);
private
{ Private declarations }
FSomething: TObject;
FMyClass: TObject;
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
type
TSomething = class; // forward;
TSomethingClass = class of TSomething;
ISomeInterface = interface
procedure SomeMethod;
function Instance: TSomething;
end;
TSomething = class(TInterfacedObject, ISomeInterface)
procedure SomeMethod; virtual;
function Instance: TSomething;
end;
var
gHardCodedPointer: Pointer; // no matter
procedure Dummy(aSomething: TSomething);
begin
// actually, type of ASomeClassToWorkWith is unknown (at least TObject), but it
// must implement SomeMethod, so i can make something like this:
aSomething.SomeMethod;
end;
type
TMyClass = class(TInterfacedObject, ISomeInterface)
procedure SomeMethod; virtual;
function Instance: TSomething;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
FSomething := TSomething.Create;
FMyClass := TMyClass.Create;
end;
{ TMyClass }
function TMyClass.Instance: TSomething;
begin
Result := TSomething(Self);
end;
procedure TMyClass.SomeMethod;
begin
ShowMessage('This comes from TMyClass');
end;
{ TSomething }
function TSomething.Instance: TSomething;
begin
Result := Self;
end;
procedure TSomething.SomeMethod;
begin
ShowMessage('This comes from the "dummy" ancestor TSomething');
end;
procedure TForm1.TMyClassBtnClick(Sender: TObject);
begin
// Presume this has been set elsewhere
gHardCodedPointer := FMyClass;
Dummy(TSomething(gHardCodedPointer));
end;
procedure TForm1.TSomethingBtnClick(Sender: TObject);
begin
// Presume this has been set elsewhere
gHardCodedPointer := FSomething;
Dummy(TSomething(gHardCodedPointer));
end;
It seems I see what you want to do. You just have to use what MS and partners implemented in the core of interfaces, use guids. Below is the example, but you should definitely use your own guid with CTRL+SHIFT+G in IDE
...
type
ITestInterface = interface
['{2EA2580F-E5E5-4F3D-AF90-2BBCD65B917B}']
procedure DoSomething;
end;
TTestObject = class(TInterfacedObject, ITestInterface)
procedure DoSomething;
end;
TTestObject2 = class(TInterfacedObject, ITestInterface)
procedure DoSomething;
end;
...
procedure TestMethod(Obj: TInterfacedObject);
var
Intf: ITestInterface;
begin
if (Obj as IUnknown).QueryInterface(ITestInterface, Intf) = S_OK then
Intf.DoSomething;
end;
{ TTestObject }
procedure TTestObject.DoSomething;
begin
MessageDlg('This is TTestObject showing something', mtInformation, [mbOk], 0)
end;
{ TTestObject2 }
procedure TTestObject2.DoSomething;
begin
MessageDlg('This is TTestObject2 showing something', mtInformation, [mbOk], 0)
end;
procedure TForm2.Button1Click(Sender: TObject);
var
Obj1, Obj2: TInterfacedObject;
begin
Obj1:=TTestObject.Create;
Obj2:=TTestObject2.Create;
TestMethod(Obj1);
TestMethod(Obj2);
end;
Even if you could, you couldn't typecast the interface with a interface-var anyway.
Same as with classes when you typecast a pointer to a metaclass, you'll get something of type metaclass (class of), not something of the type that is in metaclass.
With classes you solve this by typecast to the lowest common class in the hierachy. You can do the same with interfaces. ... If they inherit from eachother.
I think you have to use the interface, not the class:
procedure Dummy(ASomeClassToWorkWith: ISomeInterface);
begin
// actually, type of ASomeClassToWorkWith is unknown (at least TObject), but it
// must implement SomeMethod, so i can make something like this:
ASomeClassToWorkWith.SomeMethod;
end;
You just have to think amout reference counting
If you realy want the object instance you could change the interface like this:
type
ISomeInterface = interface
procedure SomeMethod;
function ImplementedInObject: TObject;
end;
procedure Dummy(ASomeInterfaceToWorkWith: ISomeInterface);
var
ASomeObjectToWorkWith: TObject;
begin
ASomeInterfaceToWorkWith.SomeMethod;
ASomeObjectToWorkWith := ASomeInterfaceToWorkWith.ImplementedInObject;
// Do what is needed with object
end;
...
type
TMyClass = class(TInterfacedObject, ISomeInterface)
function ImplementedInObject: TObject;
end;
function TMyClass.ImplementedInObject: TObject;
begin
Result := Self;
end;
The difference when calling code via interface variable or via variable pointing to an instance of a class that implements methods of the same interface is that different virtual method tables (VMT) are used, i.e. in a VMTs of an interface there will be only interface methods (plus AddRef, Release and QI, of course), in a VMT of a class there will be all virtual methods of that class.
That means that your code
ASomeClassToWorkWith(gHardCodedPointer).SomeMethod;
will be compiled to call TSomeClassWhichImplementsSomeInterface.SomeMethod directly instead of virtual method in VMT of ISomeInterface through interface pointer.
Even more, since interfaces cannot declare class methods and class attributes, an interface type is not a object (while class is an object), therefore "class of interface" does not make any sence.
You can add intermediate abstract class and declare you "class of interface" as class of the intermediate class:
type
TInterfacedObjectWithISomeInterface = class(TInterfacedObject, ISomeInterface)
procedure SomeMethod; virtual; abstract;
end;
TSomeClassWhichImplementsSomeInterface = class of TInterfacedObjectWithISomeInterface;
procedure Dummy(ASomeClassToWorkWith: TSomeClassWhichImplementsSomeInterface);
...
type
TMyClass = class(TInterfacedObjectWithISomeInterface)
procedure SomeMethod; override;
end;