I hope you can stand up to another page...
Here i want to play with funny features of OP language, something related to the prefix "meta".
We can start from "reflection", supported by a large set of runtime type information, generated by the compiler. It is not as complete as Java, but it's enough for a lot of things. The IDE itself makes a broad use of these information to provide "visual" programming.
For many things there's an easy access: TObject class implements RTTI inquiry
A first group is composed by:
and can be used to "stringify" type and browse thru class inheritance
a second group works with interface support
a third group is more "structural", and it requires {$M+} compiler
option for additional type generation for "published" class section
({$M+} option is inheritable, and it is required only for base classes
like TPersistent )
Except from FieldAddress (that needs to point to instance data), all these
methods are declared "class" and work not only with objects but
also with Delphi "metaclasses".
Another two methods are a little more "meta" than the others:
For an object ClassType return its class "type" as a "value" of TClass "metaclass" type (mm....)
ClassInfo applied to a class returns a pointer to RTTI for the class.
If you remember virtual method call:
AnObjectReference => AnObjectInstance (at offset 0) => AClassVMT
you may see a "value" of a "metaclass" type, as a pointer to the VMT of the class (type) that it refer to:
AMetaClassValue => AClassVMT
But a ClassVMT pointer isn't important just for virtual methods, behind VMT there's a lot of class information with pointers to compiler generated tables. TObject implementation uses this data for its magic.
Additional RTTI information can be reached via ClassInfo pointer, but i don't know this topic, so i can only suggest you to read "Delphi in Nutshell" ("best seller") book.
But a nice ClassInfo features is that you can reach type data with objects and metaclasses and not just with "literal" types in "TypeInfo" function.
but i don't want to be too serious, so here a sample of totally useless code ...
type
{M+}
TBase = class(TObject)
protected
function AdjustMethod(m: TMethod): TMethod;
end;
{M-}
TAObject = class;
TAEqual = function(AObject: TAObject): Boolean of object;
...
TAObject = class(TBase)
private
FAField: Integer;
public
constructor Create(A: Integer); overload;
function CallEqual(e: TAEqual; AObject: TAObject): Boolean;
...
published
function SlicedIsEqual(AObject: TAObject): Boolean; virtual;
...
end;
TBObject = class(TAObject)
private
FBField: Integer;
public
constructor Create(A,B: Integer); overload;
published
function SlicedIsEqual(AObject: TBObject): Boolean; reintroduce; // unsafe type ...
...
end;
...
function TBase.AdjustMethod(m: TMethod): TMethod;
var
methodName: ShortString;
begin
methodName := TObject(m.Data).ClassType.MethodName(m.Code); // unhides hidden
m.Code := TObject(m.Data).ClassType.MethodAddress(methodName); // derived method ...
result := m;
end;
function TAObject.CallEqual(e: TAEqual; AObject: TAObject): Boolean;
begin
e := TAEqual(AdjustMethod(TMethod(e)));
result := e(AObject);
end;
function TAObject.SlicedIsEqual(AObject: TAObject): Boolean;
begin
result := (FAField = AObject.FAField);
end;
function TBObject.SlicedIsEqual(AObject: TBObject): Boolean;
begin
result := (inherited SlicedIsEqual(AObject)) and
(FBField = AObject.FBField);
end;
...
procedure TestUnHide;
var
a1,a2: TAObject;
b1: TBObject;
begin
b1 := TBObject.Create;
b1.BField := 1;
a1 := b1;
a2 := a1.CallClone(a1.SlicedClone);
a2.Dump;
if (a1.CallEqual(a1.SlicedIsEqual,a2)) then WriteLn('Equal ...')
else WriteLn('not Equal ...');
a2 := a1.CallTransform(a1.SlicedTranform,a2);
a2.Dump;
if (a1.CallEqual(a1.SlicedIsEqual,a2)) then WriteLn('Equal ...')
else WriteLn('not Equal ...');
a1.Free;
a2.Free;
end;
this code isn't just useless, it's also type unsafe, because it un-hides method with different signatures ...
you may find a much clever use of TMethod type in Delphi sources ...
this one is still useless, but it is a bit more interesting, working with "virtual constructors" ...
after all, not every OOP language is able to do that (he! he! he!)
type
TA = class(TObject)
private
FValue: Integer;
protected
procedure SetValue(const Value: Integer); virtual;
public
procedure Show;
property Value: Integer read FValue write SetValue;
class function MakeCopy(A: TA): TA; //not virtual
constructor Create; //not virtual
constructor CreateFrom(A: TA); virtual;
end;
TB = class(TA)
public
constructor Create; virtual;
constructor CreateFrom(B: TB); reintroduce; overload; virtual;
end;
TC = class(TB)
public
constructor Create; override;
constructor CreateFrom(C: TA); overload; override;
constructor CreateFrom(C: TB); override;
constructor CreateFrom(C: TC); reintroduce; overload;
end;
TAClass = class of TA;
TBClass = class of TB;
TCClass = class of TC;
implementation
{ TA }
class function TA.MakeCopy(A: TA): TA;
begin
result := CreateFrom(A);
end;
constructor TA.Create;
begin
WriteLn('TA.Create');
inherited; //TObject;
Value := Value + 1;
end;
constructor TA.CreateFrom(A: TA);
begin
WriteLn('TA.CreateFrom:',A.ClassName);
FValue := A.Value + 1000;
end;
procedure TA.SetValue(const Value: Integer);
begin
FValue := Value;
end;
procedure TA.Show;
begin
WriteLn('Class:',ClassName);
WriteLn('Value:',Value);
WriteLn('__________________________');
end;
{ TB }
constructor TB.Create;
begin
WriteLn('TB.Create');
inherited;
Value := Value + 10;
end;
constructor TB.CreateFrom(B: TB);
begin
WriteLn('TB.CreateFrom:',B.ClassName);
inherited CreateFrom(B);
FValue := Value + 10000;
end;
{ TC }
constructor TC.Create;
begin
WriteLn('TC.Create');
inherited;
Value := Value + 100;
end;
constructor TC.CreateFrom(C: TC);
begin
WriteLn('TC.CreateFrom:',C.ClassName);
inherited CreateFrom(C);
FValue := Value + 100000;
end;
constructor TC.CreateFrom(C: TB);
begin
WriteLn('TC.CreateFrom (override):',C.ClassName);
if C is TC then
CreateFrom(TC(C))
else
inherited CreateFrom(C);
FValue := Value + 5000000;
end;
constructor TC.CreateFrom(C: TA);
begin
WriteLn('TC.CreateFrom (override - A):',C.ClassName);
if C is TB then
CreateFrom(TB(C))
else
inherited CreateFrom(C);
FValue := Value + 70000000;
end;
test code...
procedure TestCreateFrom;
var
AClass: TAClass;
BClass: TBClass;
CClass: TCClass;
o: TA;
a: TA;
b: TB;
c: TC;
begin
c := TC.Create; b := c; a := c;
AClass := TAClass(a.ClassType);
BClass := TBClass(a.ClassType);
CClass := TCClass(a.ClassType);
WriteLn('===AClass.MakeCopy======================');
o := AClass.MakeCopy(a); o.Show; o.Free;
o := AClass.MakeCopy(b); o.Show; o.Free;
o := AClass.MakeCopy(c); o.Show; o.Free;
SignUti.Pause;
WriteLn('===BClass.MakeCopy======================');
o := BClass.MakeCopy(a); o.Show; o.Free;
o := BClass.MakeCopy(b); o.Show; o.Free;
o := BClass.MakeCopy(c); o.Show; o.Free;
SignUti.Pause;
WriteLn('===CClass.MakeCopy======================');
o := CClass.MakeCopy(a); o.Show; o.Free;
o := CClass.MakeCopy(b); o.Show; o.Free;
o := CClass.MakeCopy(c); o.Show; o.Free;
SignUti.Pause;
WriteLn('=================================');
c.Free;
end;
and output...
===AClass.MakeCopy====================== TC.CreateFrom (override - A):TC TC.CreateFrom (override):TC TC.CreateFrom:TC TB.CreateFrom:TC TA.CreateFrom:TC Class:TC Value:75111111 __________________________ TC.CreateFrom (override - A):TC TC.CreateFrom (override):TC TC.CreateFrom:TC TB.CreateFrom:TC TA.CreateFrom:TC Class:TC Value:75111111 __________________________ TC.CreateFrom (override - A):TC TC.CreateFrom (override):TC TC.CreateFrom:TC TB.CreateFrom:TC TA.CreateFrom:TC Class:TC Value:75111111 __________________________ ===BClass.MakeCopy====================== TC.CreateFrom (override - A):TC TC.CreateFrom (override):TC TC.CreateFrom:TC TB.CreateFrom:TC TA.CreateFrom:TC Class:TC Value:75111111 __________________________ TC.CreateFrom (override - A):TC TC.CreateFrom (override):TC TC.CreateFrom:TC TB.CreateFrom:TC TA.CreateFrom:TC Class:TC Value:75111111 __________________________ TC.CreateFrom (override - A):TC TC.CreateFrom (override):TC TC.CreateFrom:TC TB.CreateFrom:TC TA.CreateFrom:TC Class:TC Value:75111111 __________________________ ===CClass.MakeCopy====================== TC.CreateFrom (override - A):TC TC.CreateFrom (override):TC TC.CreateFrom:TC TB.CreateFrom:TC TA.CreateFrom:TC Class:TC Value:75111111 __________________________ TC.CreateFrom (override - A):TC TC.CreateFrom (override):TC TC.CreateFrom:TC TB.CreateFrom:TC TA.CreateFrom:TC Class:TC Value:75111111 __________________________ TC.CreateFrom (override - A):TC TC.CreateFrom (override):TC TC.CreateFrom:TC TB.CreateFrom:TC TA.CreateFrom:TC Class:TC Value:75111111 __________________________
you can notice here, how the implementation of (virtual) constructors with calls to derived version before inherited one, let derived class "route" construction path depending on the "true" dynamic type of arguments ...
I confess that i found the name "metaclass" quite strange at first ...
Other languages adopt a more strict "everything is an object" approach, and while every object "is-a" instance of its class, classes in turns are "true" objects inherited from a TObject.
The special metaclass "TClass" could be in the "is-a-(instance-of)" relation root (short-circuited: TClass isa TClass).
In particular, we could have
Sending a "new" message to an "ordinary" class would return an object instance of its type, while a "meta" class "new" method (with a list of classes to inherit from as parameter...) would return a new class type. This class has behavior (class methods) defined in its metaclass, while the objects created by the class inherit behavior (object methods) from the list of classes given as parameters...
This could seem more uniform, and metaclass types could be extended in a orthogonal direction respect to the object they instantiate...
Maybe a dynamic type system is required here, and static "checking" (and speed) don't mix well with this model ....
Yes, having classes as instance of a Com metaclass type could seem a nice thing, but what happens if you need also a SOAP support? You may need multiple (meta)-implementation inheritance...
And class type values? What would mean class value upcasting ? If object of a TFoo class are a kind of objects of TBar type, would it be legal to "cast" a value of TFoo class reference into a TBar reference ?
Quite complex...
Delphi adopts a (very) much simpler solution:
In Delphi, there is only one "hierarchy" of classes and, while different, objects and metaclasses have corresponding ancestors in inheritance tree. Class virtual method table (VMT) is shared by object and class virtual methods and, with single inheritance, upcast resolves in a simple interpretation of a class pointer to a pointer of an higher type (with a "virtual" slicing of VMT). Constructors are the only place where you find a form of type "variance", in fact you may see a (virtual) constructor as a class (and object sometimes) function, returning a new instance of most derived type, but it is completely safe to consider this returned type as a higher type.
But what about COM, XXX, YYY metaclass inheritance?
Being able to treat class types as "first-class" data (with type safety provided by inheritance...), Delphi, wisely, stays away from multiple (implementation) inheritance, and following its "principles" introduce a (strange) form of delegation.
If you look at the generated support code for a simple Com object, you may notice that some code was added in the initialization section of implementing unit.
Something similar to
initialization
begin
TComObjectFactory.Create(ComServ.ComServer, TFirst, Class_First,
'First','First',ciMultiInstance, tmApartment);
TComObjectFactory.Create(ComServ.ComServer, TSecond, Class_Second,
'Second','Second',ciMultiInstance, tmApartment);
TComObjectFactory.Create(ComServ.ComServer, TThird, Class_Third,
'Third','Third',ciMultiInstance, tmApartment);
end;
an instance of T...ObjectFactory is created with a class type and a GUID as a parameter, why?
A Com factory object "implements" com support for your class but it "is-not-a" your class, but equally important your class is not a kind of T...ObjectFactory class (metaclass in the "everything" model ...).
But what is a class for? It must be able to "create" instances of its type, and T...ObjectFactory is a little too generic for that ... so it has to "delegate" to its metaclass field (that stores your class type) for object creation.
Briefly, your class gets Com support by delegating (via metaclass...) another object that delegates back to your class object creation.
Factories are stored (or better, they self store on creation) in a T...Server singleton object, also created in initalization...
"Initialization" is indeed a "meta" feature of Delphi. Here you can build your type repositories, with help of type values and RTTI, considering the well defined initialization call order. You can also have a "meta-compiler hook" provided by InitProc variable, where you can chain a procedure to execute at the end of all initialization sections of you units.
And what if now you need also Corba support... It would be as easy as adding another T...Factory in your initialization ...
No need for multiple inheritance (that was turned upside-down...)
and interfaces ???
classes does not supports interfaces (what GetInterface should do?) but you can write a little delegation ...
interface
type
IMyObject = interface
['{DDF6CE40-55D1-11D5-B57E-00AA00ACFD08}']
procedure AMethod;
end;
IMyObjectClass = interface
['{DDF6CE41-55D1-11D5-B57E-00AA00ACFD08}']
function CreateInstance: IMyObject;
end;
type
TMyObjectBase = class(TInterfacedObject)
public
class function CreateInstance: IMyObject; virtual; abstract;
end;
TMyObjectBaseClass = class of TMyObjectBase;
TMyDelegator = class(TInterfacedObject,IMyObjectClass)
private
FMyObjectClass: TMyObjectBaseClass;
function CreateInstance: IMyObject;
constructor Create(AMyObjectClass: TMyObjectBaseClass);
public
class function CreateInterfaced(AMyObjectClass: TMyObjectBaseClass): IMyObjectClass;
end;
type
TFooObject = class(TMyObjectBase,IMyObject)
private
procedure AMethod;
public
class function CreateInstance: IMyObject; override;
end;
TBarObject = class(TMyObjectBase,IMyObject)
private
procedure AMethod;
public
class function CreateInstance: IMyObject; override;
end;
procedure Test;
implementation
{ TMyDelegator }
class function TMyDelegator.CreateInterfaced(
AMyObjectClass: TMyObjectBaseClass): IMyObjectClass;
begin
result := Create(AMyObjectClass); //hides Free method ...
end;
constructor TMyDelegator.Create(AMyObjectClass: TMyObjectBaseClass);
begin
inherited Create;
FMyObjectClass := AMyObjectClass;
end;
function TMyDelegator.CreateInstance: IMyObject;
begin
result := FMyObjectClass.CreateInstance;
end;
{ TFooObject }
procedure TFooObject.AMethod;
begin
WriteLn(ClassName,'.AMethod');
end;
class function TFooObject.CreateInstance: IMyObject;
begin
result := Create;
end;
{ TBarObject }
procedure TBarObject.AMethod;
begin
WriteLn(ClassName,'.AMethod');
end;
class function TBarObject.CreateInstance: IMyObject;
begin
result := Create;
end;
///////////////////////////////////////////////////////////////////////////////
{ Test }
procedure Test;
var
a: IMyObjectClass;
b: IMyObjectClass;
x: IMyObject;
y: IMyObject;
begin
a := TMyDelegator.CreateInterfaced(TFooObject);
b := TMyDelegator.CreateInterfaced(TBarObject);
x := a.CreateInstance;
y := b.CreateInstance;
x.AMethod;
y.AMethod;
end;
end.
(Delphi classes have a Rock soul...)
more fun?
interfaces and events ( "OP Style" only...)
...
unit SignSauce;
interface
type
TGetStrEvent = function: string of object;
TBindEvent = function(Seq: Integer; Value: string; LazyValue: TGetStrEvent): string of object;
TCallEvent = function(Seq: Integer): string of object;
IBinder = interface
['{4F3B8451-4F00-11D5-B579-00AA00ACFD08}']
function GetEvent: TCallEvent;
property Event: TCallEvent read GetEvent;
end;
TBinder = class(TInterfacedObject,IBinder)
private
FEvent: TBindEvent;
FValue: string;
FLazyValue: TGetStrEvent;
function Callable(Seq: Integer): string;
function GetEvent: TCallEvent;
public
destructor Destroy; override;
class function Bind(Event: TBindEvent; Value: string; LazyValue: TGetStrEvent): IBinder;
end;
TValue = class(TObject)
private
FValue: string;
FLazyValue: string;
function GetValue: string;
function GetLazyValue: string;
public
constructor Create(AValue,ALazyValue: string);
property Value: string read GetValue write FValue;
property LazyValue: string read GetLazyValue write FLazyValue;
end;
TFoo = class(TObject)
public
function AMethod(Seq: Integer; Value: string; LazyValue: TGetStrEvent): string;
end;
TBar = class(TObject)
public
function BMethod(Seq: Integer; Value: string; LazyValue: TGetStrEvent): string;
function CMethod(Seq: Integer; Value: string; LazyValue: TGetStrEvent): string;
end;
procedure Test;
implementation
uses
SysUtils,SignUti;
{ TBinder }
class function TBinder.Bind(Event: TBindEvent; Value: string;
LazyValue: TGetStrEvent): IBinder;
var
o: TBinder;
begin
o := TBinder.Create;
o.FEvent := Event;
o.FValue := Value;
o.FLazyValue := LazyValue;
result := o;
end;
function TBinder.Callable(Seq: Integer): string;
begin
result := FEvent(Seq,FValue,FLazyValue);
end;
destructor TBinder.Destroy;
begin
WriteLn('Bye');
inherited;
end;
function TBinder.GetEvent: TCallEvent;
begin
result := Callable;
end;
{ TValue }
constructor TValue.Create(AValue, ALazyValue: string);
begin
FValue := AValue;
FLazyValue := ALazyValue;
end;
function TValue.GetLazyValue: string;
begin
WriteLn('TValue.GetLazyValue:',FLazyValue);
Result := FLazyValue;
end;
function TValue.GetValue: string;
begin
WriteLn('TValue.GetValue:',FValue);
Result := FValue;
end;
{ TFoo }
function TFoo.AMethod(Seq: Integer; Value: string;
LazyValue: TGetStrEvent): string;
begin
WriteLn('TFoo.AMethod:',IntToStr(Seq));
result := ClassName + ':'+Value+'-'+LazyValue;
end;
{ TBar }
function TBar.BMethod(Seq: Integer; Value: string;
LazyValue: TGetStrEvent): string;
begin
WriteLn('TBar.BMethod:',IntToStr(Seq));
result := ClassName + ':'+Value+'-'+LazyValue;
end;
function TBar.CMethod(Seq: Integer; Value: string;
LazyValue: TGetStrEvent): string;
begin
WriteLn('TBar.CMethod:',IntToStr(Seq));
result := ClassName + ':'+Value+'-'+LazyValue;
end;
Test
///////////////////////////////////////////////////////////////////////////////
{ Test }
procedure TestCall(ABinder: IBinder; Seq: Integer);
var
s: string;
begin
WriteLn('');
s := ABinder.Event(Seq);
WriteLn('result:',s);
WriteLn('');
end;
procedure TestSauce;
var
XValue: TValue;
YValue: TValue;
AFoo: TFoo;
ABar: TBar;
A1: IBinder;
A2: IBinder;
A3: IBinder;
A4: IBinder;
begin
XValue := TValue.Create('X','*X*');
YValue := TValue.Create('Y','*Y*');
AFoo := TFoo.Create;
ABar := TBar.Create;
WriteLn('===Bind=============================');
A1 := TBinder.Bind(AFoo.AMethod,XValue.Value,XValue.GetLazyValue);
A2 := TBinder.Bind(AFoo.AMethod,YValue.Value,YValue.GetLazyValue);
A3 := TBinder.Bind(ABar.BMethod,XValue.Value,XValue.GetLazyValue);
A4 := TBinder.Bind(ABar.CMethod,YValue.Value,YValue.GetLazyValue);
WriteLn('===Call=============================');
TestCall(A1,1);
TestCall(A2,2);
TestCall(A3,3);
TestCall(A4,4);
WriteLn('===Free=============================');
ABar.Free;
AFoo.Free;
YValue.Free;
XValue.Free;
end;
Output...
===Bind============================= TValue.GetValue:X TValue.GetValue:Y TValue.GetValue:X TValue.GetValue:Y ===Call============================= TFoo.AMethod:1 TValue.GetLazyValue:*X* result:TFoo:X-*X* TFoo.AMethod:2 TValue.GetLazyValue:*Y* result:TFoo:Y-*Y* TBar.BMethod:3 TValue.GetLazyValue:*X* result:TBar:X-*X* TBar.CMethod:4 TValue.GetLazyValue:*Y* result:TBar:Y-*Y* ===Free============================= Bye Bye Bye Bye
i find this quite funny, because implementing classes aren't implementing anything, parameter are stored in a reference counted object, that must know only method signature and property getter can be passed instead of property value.
"DNI: a Delphi Native Interface ?"
one reason of success of "is" and "as" operators is in their length!
but they don't work for metaclasses
well, not exactly...
procedure TestIsClass(AClass: TClass);
var
XClass: TBClass;
begin
{
if AClass is TB then // is operator not applicable ...
begin
XClass := AClass as TB; // as operator not applicable ...
WriteLn(XClass.ClassName);
end;
}
{
if AClass is TBClass then // is operator not applicable ...
begin
XClass := AClass as TBClass; // as operator not applicable ...
WriteLn(XClass.ClassName);
end;
}
{
if AClass.InheritsFrom(TB) then
begin
XClass := TB(AClass); // Incompatible Types TBClass and TB
WriteLn(XClass.ClassName);
end;
}
if AClass.InheritsFrom(TB) then
begin
XClass := TBClass(AClass);
WriteLn(XClass.ClassName,' is a kind of ',TB.ClassName);
end
else
WriteLn(AClass.ClassName,' isn''t a kind of ',TB.ClassName);
end;
procedure TestMetaClass;
var
a: TA;
b: TB;
c: TC;
begin
WriteLn('=== Class Test================');
TestIsClass(TA);
TestIsClass(TB);
TestIsClass(TC);
a := TA.Create; b := TB.Create; c := TC.Create;
WriteLn('=== Object Test================');
TestIsClass(a.ClassType); // a is a TA
TestIsClass(b.ClassType);
TestIsClass(c.ClassType);
a.Free; b.Free; c.Free;
end;
and they don't work with interfaces ...
here it is a little more complex ...
the "as" operator is indeed a "wrapper" around "QueryInterface" function, raising a "Interface not supported" exception when the query fails.
you have an alternative way to get an interface ...
the "supports" (overloaded) function
"Supports" comes in two versions, one is for "querying" an interface for another one, the other is for "getting" an interface from an object
and a "is" operator ?
maybe it's better to consider two problems separately:
there are also conflicting "type" values for interfaces:
Suppose we adopt TGUID (Delphi already provides an __uuidof intrinsic (implicit) functionality for type literals)
where we can hope to find type information from a pointer? maybe from its offset ...
another problem is to reach RTTI data with a GUID key
AFAIK, there is no way to do that ... so let's build a repository ...
Could this be enough for Jim Coplien's problem ?.
IReal = interface(IComplex) TComplex = class(TReal,IComplex) // private interface inheritance needed ???
Anyway...
unit MirNative;
interface
uses
TypInfo,SysUtils,Classes;
type {public}
INativeObject = interface
['{98A21171-52D2-11D5-B57D-00AA00ACFD08}']
function _IID(ISelf: INativeObject): TGUID;
end;
IIntfType = interface(INativeObject)
['{98A21172-52D2-11D5-B57D-00AA00ACFD08}']
function IID: TGUID;
function InterfaceUnit: string;
function InterfaceName: string;
function InheritsFrom(const IID: TGUID): Boolean;
end;
IRepository = interface(INativeObject)
['{98A21173-52D2-11D5-B57D-00AA00ACFD08}']
procedure RegisterInterface(IntfTypePtr: PTypeInfo);
function GetIType(const IID: TGUID): IIntfType;
end;
function IIDOF(ISelf: INativeObject): TGUID;
function IType(ISelf: INativeObject): IIntfType;
function IRep: IRepository;
type {protected}
TNativeObject = class(TInterfacedObject,INativeObject)
protected
function _IID(ISelf: INativeObject): TGUID;
class function GetInterfaceEntryByOffSet(
Offset: Integer): PInterfaceEntry;
end;
TIntfType = class(TNativeObject,IIntfType)
private
FInfo: PTypeInfo;
FData: PTypeData;
constructor Create(IntfTypePtr: PTypeInfo);
protected
function _AddRef: Integer; stdcall;
function _Release: Integer; stdcall;
public
function IID: TGUID;
function InterfaceUnit: string;
function InterfaceName: string;
function InheritsFrom(const IID: TGUID): Boolean;
end;
TRepository = class(TNativeObject,IRepository)
private
FList: TStringList; // a RAD container ...
procedure SortList;
protected
function _AddRef: Integer; stdcall;
function _Release: Integer; stdcall;
public
constructor Create;
destructor Destroy; override;
procedure RegisterInterface(IntfTypePtr: PTypeInfo);
function GetIType(const IID: TGUID): IIntfType;
end;
implementation
uses
ComObj, // for GuidToString ...
ActiveX; // for IsEqualGuid ...
{ TNativeObject }
function TNativeObject._IID(ISelf: INativeObject): TGUID;
var
Offset: Integer;
InterfaceEntry: PInterfaceEntry;
begin
OffSet := integer(ISelf) - integer(Self);
InterfaceEntry := GetInterfaceEntryByOffSet(Offset);
if InterfaceEntry <> nil then
result := InterfaceEntry^.IID
else
raise Exception.Create('never ...');
end;
class function TNativeObject.GetInterfaceEntryByOffSet(Offset: Integer): PInterfaceEntry;
asm
PUSH EBX
MOV EBX,EAX
@@1: MOV EAX,[EBX].vmtIntfTable
TEST EAX,EAX
JE @@4
MOV ECX,[EAX].TInterfaceTable.EntryCount
ADD EAX,4
@@2: CMP EDX,[EAX].TInterfaceEntry.IOffset.Integer[0]
JE @@5
@@3: ADD EAX,type TInterfaceEntry
DEC ECX
JNE @@2
@@4: MOV EBX,[EBX].vmtParent
TEST EBX,EBX
JE @@4a
MOV EBX,[EBX]
JMP @@1
@@4a: XOR EAX,EAX
@@5: POP EBX
end;
{ TIntfType }
constructor TIntfType.Create(IntfTypePtr: PTypeInfo);
begin
FInfo := IntfTypePtr;
FData := GetTypeData(FInfo);
end;
function TIntfType.IID: TGUID;
begin
result := FData^.Guid;
end;
function TIntfType.InterfaceName: string;
begin
result := string(FInfo^.Name);
end;
function TIntfType.InterfaceUnit: string;
begin
result := string(FData^.IntfUnit);
end;
function TIntfType.InheritsFrom(const IID: TGUID): Boolean;
var
pInfo: PTypeInfo;
pData: PTypeData;
begin
result := false;
pInfo := FInfo;
while pInfo <> nil do
begin
pData := GetTypeData(pInfo);
if IsEqualGuid(pData.Guid,IID) then
begin
result := true;
break;
end;
pInfo := nil;
if pData.IntfParent <> nil then
pInfo := pData.IntfParent^
end;
end;
function TIntfType._AddRef: Integer;
begin
result := -1;
end;
function TIntfType._Release: Integer;
begin
result := -1;
end;
{ TRepository }
constructor TRepository.Create;
begin
FList := TStringList.Create;
end;
destructor TRepository.Destroy;
var
i: Integer;
begin
for i := 0 to FList.Count -1 do
FList.Objects[i].Free;
FList.Free;
inherited;
end;
function TRepository.GetIType(const IID: TGUID): IIntfType;
var
i: Integer;
begin
i := FList.IndexOf(GuidToString(IID));
if i <> -1 then
result := TIntfType(FList.Objects[i])
else
result := nil;
end;
procedure TRepository.RegisterInterface(IntfTypePtr: PTypeInfo);
var
o: TIntfType;
begin
o := TIntfType.Create(IntfTypePtr);
FList.AddObject(GuidToString(o.IID),o);
end;
procedure TRepository.SortList;
begin
FList.Sorted := true;
end;
function TRepository._AddRef: Integer;
begin
result := -1;
end;
function TRepository._Release: Integer;
begin
result := -1;
end;
function IIDOF(ISelf: INativeObject): TGUID;
begin
result := ISelf._IID(ISelf);
end;
function IType(ISelf: INativeObject): IIntftype;
begin
result := IRep.GetIType(IIDOF(ISelf));
end;
var
IntfRepository: TRepository;
function IRep: IRepository;
begin
if IntfRepository = nil then
IntfRepository := TRepository.Create;
result := IntfRepository;
end;
var
SaveInitProc: Pointer;
procedure InitRepository;
begin
if SaveInitProc <> nil then TProcedure(SaveInitProc);
if Assigned(IntfRepository) then
IntfRepository.SortList;
end;
initialization
begin
SaveInitProc := InitProc;
InitProc := @InitRepository;
IRep.RegisterInterface(TypeInfo(INativeObject));
IRep.RegisterInterface(TypeInfo(IIntfType));
IRep.RegisterInterface(TypeInfo(IRepository));
end;
finalization
begin
if Assigned(IntfRepository) then
IntfRepository.Free;
end;
end.
...
unit MirTest;
interface
uses
TypInfo,SysUtils,MirNative;
type
IBase = interface(INativeObject)
['{98A21174-52D2-11D5-B57D-00AA00ACFD08}']
end;
IADerived = interface(IBase)
['{98A21175-52D2-11D5-B57D-00AA00ACFD08}']
procedure AMethod;
end;
IBDerived = interface(IBase)
['{98A21176-52D2-11D5-B57D-00AA00ACFD08}']
procedure BMethod;
end;
ICDerived = interface(IADerived)
['{98A21177-52D2-11D5-B57D-00AA00ACFD08}']
procedure CMethod;
end;
type
TAObject = class(TNativeObject,IADerived)
public
procedure AMethod;
end;
TBObject = class(TNativeObject,IBDerived)
public
procedure BMethod;
end;
TCObject = class(TNativeObject,ICDerived)
public
procedure AMethod;
procedure CMethod;
end;
procedure Test;
implementation
uses
ActiveX,ComObj,MirUti;
{ TAObject }
procedure TAObject.AMethod;
begin
WriteLn('--- ',ClassName,'.AMethod');
end;
{ TBObject }
procedure TBObject.BMethod;
begin
WriteLn('--- ',ClassName,'.BMethod');
end;
{ TCObject }
procedure TCObject.AMethod;
begin
WriteLn('--- ',ClassName,'.AMethod');
end;
procedure TCObject.CMethod;
begin
WriteLn('--- ',ClassName,'.CMethod');
end;
initialization
begin
IRep.RegisterInterface(TypeInfo(IBase));
IRep.RegisterInterface(TypeInfo(IADerived));
IRep.RegisterInterface(TypeInfo(IBDerived));
IRep.RegisterInterface(TypeInfo(ICDerived));
end;
end.
...
///////////////////////////////////////////////////////////////////////////////
{ Test }
procedure TestBase(b: IBase);
var
IID: TGUID;
InterfaceType: IIntfType;
begin
IID := IIDOF(b);
WriteLn('... IID OF (b: IBase):',GuidToString(IID));
InterfaceType := IType(b);
WriteLn('... Is A:',Format('%s.%s',
[InterfaceType.InterfaceUnit, InterfaceType.InterfaceName]));
if InterfaceType.InheritsFrom(IADerived) then
begin
WriteLn('... A Kind Of: IADerived');
IADerived(b).AMethod;
end;
if InterfaceType.InheritsFrom(IBDerived) then
begin
WriteLn('... A Kind Of: IBDerived');
IBDerived(b).BMethod;
end;
if InterfaceType.InheritsFrom(ICDerived) then
begin
WriteLn('... A Kind Of: ICDerived');
ICDerived(b).AMethod;
ICDerived(b).CMethod;
end;
WriteLn('');
end;
procedure Test;
var
a: IADerived;
b: IBDerived;
c: ICDerived;
x: IBase;
y: IBase;
z: IBase;
begin
a := TAObject.Create;
b := TBObject.Create;
c := TCObject.Create;
x := TAObject.Create as IADerived;
y := TBObject.Create as IBDerived;
z := TCObject.Create as ICDerived;
WriteLn('=== a TAObject ==================');
TestBase(a);
WriteLn('=== a TBObject ==================');
TestBase(b);
WriteLn('=== a TCObject ==================');
TestBase(c);
Pause;
WriteLn('=== a TAObject ==================');
TestBase(x);
WriteLn('=== a TBObject ==================');
TestBase(y);
WriteLn('=== a TCObject ==================');
TestBase(z);
Pause;
end;
...
=== a TAObject ==================
... IID OF (b: IBase):{98A21175-52D2-11D5-B57D-00AA00ACFD08}
... Is A:MirTest.IADerived
... A Kind Of: IADerived
--- TAObject.AMethod
=== a TBObject ==================
... IID OF (b: IBase):{98A21176-52D2-11D5-B57D-00AA00ACFD08}
... Is A:MirTest.IBDerived
... A Kind Of: IBDerived
--- TBObject.BMethod
=== a TCObject ==================
... IID OF (b: IBase):{98A21177-52D2-11D5-B57D-00AA00ACFD08}
... Is A:MirTest.ICDerived
... A Kind Of: IADerived
--- TCObject.AMethod
... A Kind Of: ICDerived
--- TCObject.AMethod
--- TCObject.CMethod
...
What is the big problem with this approach ?
There is the big assumption that behind an interface always lays a Delphi object.
But this is contrary to "IStar" philosophy ...
Then, after a trip on one of the coolest place on the net i figure out why ...
Again, mixing OOP and M$ is always a mess!