fpc/tests/webtbs/tw9139a.pp

{$mode objfpc}{$H+}
{$define second_test}

type
  TTestClass = class of TTestBase;

  TTestBase = class(TObject)
  public
    class function ClassMetadataStr: string;
    class function InternalMetadataStr: string; virtual;
  end;

  TTestImpl = class(TTestBase)
  public
    class function InternalMetadataStr: string; override;
  end;

class function TTestBase.ClassMetadataStr: string;
var
  VMetadataMethod, VParentMetadataMethod: function: string of object;
{$ifdef second_test}
  VClass: TTestClass;
{$endif}
begin
  if Self <> TTestBase then
  begin
    writeln('pass 1');
    VMetadataMethod := @InternalMetadataStr;
    writeln('pass 2');
{$ifndef second_test}
    VParentMetadataMethod := @TTestClass(ClassParent).InternalMetadataStr;
{$else}
    VClass := TTestClass(ClassParent);
    writeln('pass 2.1');
    VParentMetadataMethod := @VClass.InternalMetadataStr;
{$endif}
    writeln('pass 3');
    if TMethod(VMetadataMethod).Code <> TMethod(VParentMetadataMethod).Code then
      begin
        Result := VParentMetadataMethod();
        writeln('result: ',result);
        if Result<>'parent meth' then
          halt(1);
      end
    else
      halt(2);
    writeln('pass 4');
  end else
    Result := 'base result';
end;

class function TTestBase.InternalMetadataStr: string;
begin
  Result := 'parent meth';
end;

class function TTestImpl.InternalMetadataStr: string;
begin
  Result := 'some stuff';
end;

var
  VTestClass: TTestClass;
begin
  VTestClass := TTestBase;
  writeln('TTestBase result:');
  writeln(VTestClass.ClassMetadataStr);
  writeln;
  VTestClass := TTestImpl;
  writeln('TTestImpl result:');
  writeln(VTestClass.ClassMetadataStr);
end.