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;

---

Версия в TPicture:

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

декомпилируется в:

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

Myверсия:

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

декомпилируется в:

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

Update One

Перемещение "клонирования" в отдельную функцию:

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

не помогает.

Обновление два

Очевидно, я четко предоставляю четкий снимок экрана с моим отчетливым кодом, который ясно показывает, что мой явно код - это все, что есть.Понятно:

Обновление три

Вот однозначная версия с OutputDebugString s:

{ 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

Обновление 4

Я попытался отключить все опции компиляторов, которые мог:

Примечание: Не выключать Extended syntax.Без него вы не можете присвоить Result функции ( Необъявленный идентификатор Результат ).

Обновление Five

Следуя совету Дэвида, я попытался скомпилировать код на некоторыхдругие машины (все Delphi 5):

• Ян Бойд (я): Сбои (64-битная Windows 7)
• Дейл: Сбои (64-битная Windows 7)
• Дейв: не работает (64-разрядная версия Windows 7)
• Крис: не работает (64-разрядная версия Windows 7)
• Джейми: не работает (64-разрядная версия Windows 7)
• Jay: сбои (32-разрядная версия Windows XP)
• Сервер сборки клиента: сбои (32-разрядная версия Windows 7)

Вот источник.

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.Поэтому вы в итоге вызываете TObject.Create; (который не является виртуальным).

Возможные решения

• Редактируйте и перекомпилируйте Graphics.pas
• Убедитесь, что ваш метод клонированияподклассы опускаются вниз по иерархии.(например, TBitmap.Create является общедоступным)

РЕДАКТИРОВАТЬ: дополнительное решение

Это изменение в методике получения доступа к защищенным членам класса.
Нет гарантийна надежность решения, но, кажется, работает.:)
Боюсь, вам придется провести собственное обширное тестирование.

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;

Answer 2

Для чего это стоит: я скачал ваш источник (ZIP-файл), запустил CannotCloneGraphics.exe и получил «Недействительно». сообщение об ошибке. Затем я открыл проект (файл DPR) в Delphi 2009, скомпилировал его и запустил. Тогда я не получил никакого сообщения об ошибке, и пользовательский конструктор запустился четыре раза, как и должно.

Таким образом, может показаться, что это проблема с вашими установками Delphi 5. Действительно, все ваши машины имели Delphi 5 (время для обновления ?!). Либо есть какая-то проблема с Delphi 5, либо все ваши машины были «подделаны» одинаково.

Я почти уверен, что у меня где-то есть старый Delphi 4 Personal . Я мог бы установить его и посмотреть, что там происходит ...

Обновление

Я только что установил Delphi 4 Standard в виртуальную систему Windows 95. Я попробовал этот код:

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

  ...

  constructor TMyBitmap.Create;
  begin
    inherited;
    ShowMessage('Constructor constructing!');
  end;

  ...

  procedure TForm1.Button1Click(Sender: TObject);
  var
    g, g2: TGraphic;
  begin
    g := TMyBitmap.Create;
    g2 := TGraphicClass(g.ClassType).Create;
    g.Free;
    g2.Free;
  end;

и Я получил только одно окно сообщения! Следовательно, это - это проблема с Delphi 4 (и 5), в конце концов. (Извини, Дэвид!)