FormularArray den richtigen Create aufrufen! Wie?

[Mavarik]

Zitat von himitsu:

Grundsätzlich meckert der Compilier, wenn man eine Instanz 'ner Klasse erstellen will, wo noch abstrakte Methoden drin sind.
Demnach könnte man sagen, daß es garnicht nötig ist, das zu prüfen.

Nein, da ich ja nur den Klassentype als Class of habe...

[himitsu]

Da ja nur der Compiler prüft, kann er nur auf direkte Typen prüfen.
Im laufenden Programm ist es ja nicht verboten ... es gibt halt nur eine Exception, wenn man diese Methoden aufrufen will.

Der Code im TStream macht eigentlich nichts Anderes, als die Procedur-Adressen zu vergleichen.

Für abstrakte Mtehoden leitet Delphi das auf eine Dummy-Methode um, wo die EAbstract-Exception dann ausgelöst wird. (wäre schöner gewesen, wenn Delphi dort auch noch den Methoden Namen übergeben hätte, damit man auch erfährt wo es knallt).

Also der holt sich die Eintrittspunkte einmal aus seiner Instanz, bzw. aus der VMT des Typs, welcher grade der Objektinstanz zugeordnet ist.
Und dann noch die Adresse der Vergleichsmethode, direkt aus dem gewünschten Typ, welche dann Beide verglichen werden ... wenn gleich, dann wurde nicht überschrieben.
(es sei den jemand trickst, ändert auch die RTTI des Ursprungstypen und verschleiert so die Änderung, aber sowas macht man ja nicht )

[Mavarik]

Zitat von himitsu:

Und dann noch die Adresse der Vergleichsmethode, direkt aus dem gewünschten Typ, welche dann Beide verglichen werden ... wenn gleich, dann wurde nicht überschrieben.

Wo steht das Beispiel?

Mavarik


PS: Gibt es echt kein "hasImplemented(SetFoo)"

[himitsu]

Zitat von Mavarik:

PS: Gibt es echt kein "hasImplemented(SetFoo)"

Nicht daß ich wüsste.

Da aber vermutlich alle abstrakten Methoden auf die selbe Methode zeigen, könnte man das damit vergleichen.


Man kann über die neue große RTTI gehen und genauer nachsehn was wie wo implementiert ist.

Wenn du von beiden Typen eine Instanz hast, dann ganz billig so.

Delphi-Quellcode:

if @Self.MyProc = @Vorfahr.MyProc then  // Wobei man hier natürlich noch den Self-Pointer aus dem Vergleich ausschließen muß.
  ShowMessage('boom');

// also

if TMethod(@Self.MyProc).Code = TMethod(@Vorfahr.MyProc).Code then  // OK, und für den Typecast muß alles noch in Variablen kopiert werden.
  ShowMessage('boom');

Bei Published-Methoden könnte man auch einfach über TObject.MethodAddress gehen.

Delphi-Quellcode:

uses
  Rtti;

type
  TTestParent = class
    procedure VirtualProc;  virtual; abstract;
    procedure AbstractProc; virtual; abstract;
  published
    procedure PubVirtualProc;  virtual; abstract;
    procedure PubAbstractProc; virtual; abstract;
    procedure PubCompareDummy; virtual; abstract;
  end;

  TTest = class(TTestParent)
    procedure VirtualProc; override;
  published
    procedure PubVirtualProc; override;
  end;

procedure TTest.VirtualProc;
begin
end;

procedure TTest.PubVirtualProc;
begin
end;

procedure TForm21.FormCreate(Sender: TObject);
var
  TestObj: TTest;
  ErrorProc: Pointer;
  Temp1, Temp2: procedure of object;
  TestC: TClass;
begin
  TestObj := TTest.Create;

  asm
    //MOV &ErrorProc, @AbstractError
    MOV &ErrorProc, OFFSET System.@AbstractError
  end;
  //if TestObj.MethodAddress('PubVirtualProc') = @System._AbstractError then
  if TestObj.MethodAddress('PubVirtualProc') = ErrorProc then
    ShowMessage('boom 1');  // geht nicht .... wie was das nochmal mit den Adressen im Assembler?
  //if TestObj.MethodAddress('PubAbstractProc') = @System._AbstractError then
  if TestObj.MethodAddress('PubAbstractProc') = ErrorProc then
    ShowMessage('boom 2');

  if TestObj.MethodAddress('PubVirtualProc') = TTestParent.MethodAddress('PubVirtualProc') then
    ShowMessage('boom 3');
  if TestObj.MethodAddress('PubAbstractProc') = TTestParent.MethodAddress('PubAbstractProc') then
    ShowMessage('boom 4');

  TestC := TTestParent;
  Temp1 := TestObj.VirtualProc;
  Temp2 := TTestParent(@TestC).VirtualProc;
  if TMethod(Temp1).Code = TMethod(Temp2).Code then
    ShowMessage('boom 5');
  TestC := TTestParent;
  Temp1 := TestObj.AbstractProc;
  Temp2 := TTestParent(@TestC).AbstractProc;
  if TMethod(Temp1).Code = TMethod(Temp2).Code then
    ShowMessage('boom 6');

  TestC := TTestParent;
  Temp1 := TestObj.VirtualProc;
  Temp2 := TTestParent(@TestC).VirtualProc;
  if TMethod(Temp1).Code = TMethod(Temp2).Code then
    ShowMessage('boom 7');
  TestC := TTestParent;
  Temp1 := TestObj.AbstractProc;
  Temp2 := TTestParent(@TestC).AbstractProc;
  if TMethod(Temp1).Code = TMethod(Temp2).Code then
    ShowMessage('boom 8');

  with TRttiContext.Create do begin
    if GetType(TTest).GetMethod('VirtualProc').CodeAddress = GetType(TTestParent).GetMethod('VirtualProc').CodeAddress then
      ShowMessage('boom 9');
    if GetType(TTest).GetMethod('AbstractProc').CodeAddress = GetType(TTestParent).GetMethod('AbstractProc').CodeAddress then
      ShowMessage('boom 10');
  end;

  TestObj.VirtualProc;
  TestObj.PubVirtualProc;
  TestObj.AbstractProc;
  TestObj.PubAbstractProc;

[Mavarik]

Untested!

Delphi-Quellcode:

function MethodIsImplemented(const AClass:TClass;MethodName : string): Boolean;
var
  m   : TRttiMethod;
begin
  Result := False;
  m:=TRttiContext.Create.GetType(AClass.ClassInfo).GetMethod(MethodName);
  if m<>nil then
   Result:=CompareText(AClass.ClassName,m.Parent.Name)=0; 
end;

Mavarik

[himitsu]

Auf den Namen solltest du besser nicht prüfen, sondern besser auf den Klassentyp. (Namen sind nicht eindeutig)

Aber damit prüfst du nur, ob die Methode in dieser Klasse implementiert wurde, was aber auch auf die abstrakte Methode zutreffen würde, wenn sie direkt in dieser Klasse drin steht.

[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.