FormularArray den richtigen Create aufrufen! Wie?

[himitsu]

Es scheint in der RTTI keine Markierung/Info für "abstract" zu geben.

Delphi-Quellcode:

function MethodIsImplemented_Mavarik(const AClass: TClass; const MethodName: string): Boolean;
var
  M: TRttiMethod;
begin
  M := TRttiContext.Create.GetType(AClass.ClassInfo).GetMethod(MethodName);
  //Result := Assigned(M) and SameText(AClass.ClassName, M.Parent.Name);
  Result := Assigned(M) and (AClass.ClassInfo = M.Parent.Handle);
end;

var
  AbstractAddress: Pointer;  // global, da einmal Suchen ja ausreichend ist

function MethodIsImplemented(const AClass: TClass; const MethodName: string): Boolean; overload;
type
  TVtable = array[0..MaxInt div 4 - 1] of Pointer;
  PVtable = ^TVtable;
var
  M: TRttiMethod;
begin
  if not Assigned(AbstractAddress) then
    //AbstractAddress := TRttiContext.Create.GetType(TStream.ClassInfo).GetMethod('Read').CodeAddress;
    AbstractAddress := PVtable(TStream)^[TRttiContext.Create.GetType(TStream.ClassInfo).GetMethod('Read').VirtualIndex];

  M := TRttiContext.Create.GetType(AClass.ClassInfo).GetMethod(MethodName);
  //Result := Assigned(M) and ((M.DispatchKind <> dkVtable) or (M.CodeAddress <> AbstractAddress));
  Result := Assigned(M) and ((M.DispatchKind <> dkVtable) or (PVtable(AClass)^[M.VirtualIndex] <> AbstractAddress));
end;

function MethodIsImplemented(const AObject: TObject; const MethodName: string): Boolean; overload;
begin
  Result := Assigned(AObject) and MethodIsImplemented(AObject.ClassType, MethodName);
end;

type
  TStringTest = class(TStringList)
  end;

procedure Test;
begin
  if MethodIsImplemented(TStringList, 'Free') then
    Beep;
  if MethodIsImplemented_Mavarik(TStringList, 'Free') then
    Beep;  // Falsch - ist schon komplett in TObject implementiert

  if MethodIsImplemented(TStringList, 'Clear') then
    Beep;
  if MethodIsImplemented_Mavarik(TStringList, 'Clear') then
    Beep;

  if MethodIsImplemented(TStrings, 'Clear') then
    Beep;
  if MethodIsImplemented_Mavarik(TStrings, 'Clear') then
    Beep;  // Falsch - ja, Clear ist genau hier implementiert, aber das ist leider die abstrakte Methode

  if MethodIsImplemented(TStringTest, 'Clear') then
    Beep;
  if MethodIsImplemented_Mavarik(TStringTest, 'Clear') then
    Beep;  // Falsch - siehe "Free", denn auch hier ist es schon TStringList implementiert und korrect überschrieben
end;

als class function IsMethodImplemented(const MethodName: string): Boolean; läßt sich das bestimmt auch schön in einem Klass-Helper unterbringen.