Delphi:构造不调用重写的虚拟构造函数

Question

我有一个 TBitmap 的示例后代:

TMyBitmap = class(TBitmap)
public
    constructor Create; override;
end;

constructor TMyBitmap.Create;
begin
   inherited;
   Beep;
end;

在运行时，我构造这些 TMyBitmap 对象之一，将图像加载到其中，并将其放入表单上的 TImage 中:

procedure TForm1.Button1Click(Sender: TObject);
var
   g1: TGraphic;
begin
   g1 := TMyBitmap.Create;
   g1.LoadFromFile('C:\...\example.bmp');

   Image1.Picture.Graphic := g1;
end;

在TPicture.SetGraphic内部，您可以看到它通过构造一个新的图形并在新构造的克隆上调用.Assign来创建图形的副本:

procedure TPicture.SetGraphic(Value: TGraphic);
var
   NewGraphic: TGraphic;
begin
   ...
   NewGraphic := TGraphicClass(Value.ClassType).Create;
   NewGraphic.Assign(Value);
   ...
end;

构造新图形类的行:

NewGraphic := TGraphicClass(Value.ClassType).Create;

正确调用我的构造函数，一切都很好。

<小时/>

我想做类似的事情，我想克隆一个TGraphic:

procedure TForm1.Button1Click(Sender: TObject);
var
   g1: TGraphic;
   g2: TGraphic;
begin
   g1 := TMyBitmap.Create;
   g1.LoadFromFile('C:\...\example.bmp');

   //Image1.Picture.Graphic := g1;
   g2 := TGraphicClass(g1.ClassType).Create;
end;

除了这永远不会调用我的构造函数，也不会调用 TBitmap 构造函数。它仅调用 TObject 构造函数。施工后:

g2.ClassName: 'TMyBitmap'
g2.ClassType: TMyBitmap

类型是正确的，但它不会调用我的构造函数，但其​​他地方的相同代码会调用。

为什么？

<小时/>

即使在这个假设的人为示例中，它仍然是一个问题，因为 TBitmap 的构造函数没有被调用；内部状态变量未初始化为有效值:

constructor TBitmap.Create;
begin
  inherited Create;
  FTransparentColor := clDefault;
  FImage := TBitmapImage.Create;
  FImage.Reference;
  if DDBsOnly then HandleType := bmDDB;
end;

<小时/>

TPiccture 中的版本:

NewGraphic := TGraphicClass(Value.ClassType).Create;

反编译为:

mov eax,[ebp-$08]
call TObject.ClassType
mov dl,$01
call dword ptr [eax+$0c]
mov [ebp-$0c],eax

我的版本:

g2 := TGraphicClass(g1.ClassType).Create;

反编译为:

mov eax,ebx
call TObject.ClassType
mov dl,$01
call TObject.Create
mov ebx,eax

更新一个

将“克隆”推送到单独的函数:

function CloneGraphic(Value: TGraphic): TGraphic;
var
    NewGraphic: TGraphic;
begin
   NewGraphic := TGraphicClass(Value.ClassType).Create;
   Result := NewGraphic;
end;

没有帮助。

更新二

显然，我清楚地提供了我的清晰代码的清晰屏幕截图，清楚地表明我的清晰代码显然是清晰的。显然:

更新三

这是带有 OutputDebugString 的明确版本:

{ TMyGraphic }

constructor TMyBitmap.Create;
begin
  inherited Create;
    OutputDebugStringA('Inside TMyBitmap.Create');
end;

function CloneGraphic(Value: TGraphic): TGraphic;
var
    NewGraphic: TGraphic;
begin
    NewGraphic := TGraphicClass(Value.ClassType).Create;
    Result := NewGraphic;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
    g1: TGraphic;
    g2: TGraphic;
begin
    OutputDebugString('Creating g1');
    g1 := TMyBitmap.Create;
    g1.LoadFromFile('C:\Archive\-=Images=-\ChessvDanCheckmateIn38.bmp');
    OutputDebugString(PChar('g1.ClassName: '+g1.ClassName));

    OutputDebugStringA('Assigning g1 to Image.Picture.Graphic');
    Image1.Picture.Graphic := g1;

    OutputDebugString('Creating g2');
    g2 := Graphics.TGraphicClass(g1.ClassType).Create;
    OutputDebugString(PChar('g2.ClassName: '+g2.ClassName));

    OutputDebugString(PChar('Cloning g1 into g2'));
    g2 := CloneGraphic(g1);
    OutputDebugString(PChar('g2.ClassName: '+g2.ClassName));
end;

原始结果:

ODS: Creating g1 Process Project2.exe ($1138)
ODS: Inside TMyBitmap.Create Process Project2.exe ($1138)
ODS: g1.ClassName: TMyBitmap Process Project2.exe ($1138)
ODS: Assigning g1 to Image.Picture.Graphic Process Project2.exe ($1138)
ODS: Inside TMyBitmap.Create Process Project2.exe ($1138)
ODS: Creating g2 Process Project2.exe ($1138)
ODS: g2.ClassName: TMyBitmap Process Project2.exe ($1138)
ODS: Cloning g1 into g2 Process Project2.exe ($1138)
ODS: g2.ClassName: TMyBitmap Process Project2.exe ($1138)
ODS: g1.ClassName: TMyBitmap Process Project2.exe ($1138)

格式化结果:

Creating g1
   Inside TMyBitmap.Create
g1.ClassName: TMyBitmap

Assigning g1 to Image.Picture.Graphic
   Inside TMyBitmap.Create

Creating g2
g2.ClassName: TMyBitmap

Cloning g1 into g2
g2.ClassName: TMyBitmap

g1.ClassName: TMyBitmap

更新四

我尝试关闭所有可以关闭的编译器选项:

注意:不要关闭扩展语法。如果没有它，您就无法分配函数的Result(未声明的标识符结果)。

更新五

按照@David的建议，我尝试在其他一些机器(所有Delphi 5)上编译代码:

• Ian Boyd(我):失败(Windows 7 64 位)
• Dale:失败(Windows 7 64 位)
• Dave:失败(Windows 7 64 位)
• Chris:失败(Windows 7 64 位)
• Jamie:失败(Windows 7 64 位)
• Jay:失败(Windows XP 32 位)
• 客户构建服务器:失败(Windows 7 32 位)

Here's the source.

Answer 1

这似乎是一个范围问题(以下内容来自 D5 Graphics.pas):

TGraphic = class(TPersistent)
...
protected
  constructor Create; virtual;
...
end;

TGraphicClass = class of TGraphic;

覆盖 Create 不会出现任何问题，并且在从内部调用 TGraphicClass(Value.ClassType).Create; 时也不会出现任何问题Graphics.pas单元。

但是，在另一个单元中 TGraphicClass(Value.ClassType).Create; 无权访问 TGraphic 的 protected 成员。因此，您最终会调用 TObject.Create; (这是非虚拟的)。

可能的解决方案

• 编辑并重新编译 Graphics.pas
• 确保您的克隆方法子类处于层次结构的较低位置。 (例如 TBitmap.Create 是公共(public)的)

编辑:附加解决方案

这是访问类的 protected 成员的技术的变体。
无法保证解决方案的稳健性，但它似乎确实有效。 :)
恐怕您必须自己进行大量测试。

type
  TGraphicCracker = class(TGraphic)
  end;

  TGraphicCrackerClass = class of TGraphicCracker;

procedure TForm1.Button1Click(Sender: TObject);
var
  a: TGraphic;
  b: TGraphic;
begin
  a := TMyBitmap.Create;
  b := TGraphicCrackerClass(a.ClassType).Create;
  b.Free;
  a.Free;
end;