Вызовите виртуальный конструктор по id в классах Delphi старого стиля - PullRequest
Новая
       15

Вызовите виртуальный конструктор по id в классах Delphi старого стиля

0 голосов
/ 31 октября 2018

Прежде чем прочитать содержимое объекта из потока, я читаю идентификатор, чтобы определить тип объекта. Для этого мне нужно хранить потоковые записи (TStreamRec), чтобы связать типы классов с идентификаторами. Когда я загружаю идентификатор, мне нужно искать правильную потоковую запись, чтобы вызвать правильный конструктор, а затем правильный тип.

К сожалению, мне приходится использовать классы Delphi старого типа (TMyClass = object).

Мое существующее решение с object s вызывает аномалии управления памятью, когда я использую FastMM4 в Delphi 7. Он использует typeOf (X) для получения адреса VMT класса и использует код asm для вызова конструктора. 

 Asm
    mov eax,vi                  // versionID parameter
    push eax
    mov ecx,self                // the stream prameter
    mov ebx,p                   // the TStreamRec pointer
    mov    edx,[ebx].TStreamRec.classType
    xor eax, eax
    call [ebx].TStreamRec.Load // The stored pointer to the load constructor
    mov result, eax
 End;

Он регистрирует ошибку, когда тот же блок памяти перераспределяется. (Объект, созданный оператором new, выпущенный его деструктором и чуть позже этот вызов конструктора asm возвращает тот же указатель).

Ниже приведен рабочий код с классами. Для примера я создал базовый класс и два класса-потомка с конструктором с именем load. Объявлены TStreamRec и TMyClassRepository для потоковой передачи объекта.

Вы должны начать исследование кода с TForm2.button1Click (в самом конце прикрепленного исходного кода). Событие триггера для проверки моего решения с типами классов «новый» (не древний старый).

Есть ли способ сделать то же самое с типами классов Delphi старого стиля без сообщений об ошибках FastMM4?

Pas файл рабочего примера с классами: 

unit Unit2;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls;

type
  TForm2 = class(TForm)
    Button1: TButton;
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form2: TForm2;

implementation

uses
  Generics.Collections
  ;

{$R *.dfm}

type
  CMyBaseClass = class of TMyBaseClass;
  TMyBaseClass = class
    constructor load( stream_ : TStream; versionID_ : integer ); virtual;
  end;

  TMyClass1 = class ( TMyBaseClass )
    constructor load( stream_ : TStream; versionID_ : integer ); override;
  end;

  TMyClass2 = class ( TMyBaseClass )
    constructor load( stream_ : TStream; versionID_ : integer ); override;
  end;

  PStreamRec = ^TStreamRec;
  TStreamRec = packed record
    id : cardinal;
    classType : CMyBaseClass;
  end;

  TStreamRecList = TList<PStreamRec>;

  TMyClassRepository = class
    private
      fStreamRecs : TStreamRecList;

    protected
      function createStreamRecList : TStreamRecList; virtual;
      procedure releaseStreamRecsList; virtual;
      procedure createStreamRecs; virtual;
      procedure releaseStreamRecs; virtual;
      function getClassTypeById( id_ : cardinal ) : CMyBaseClass;

    public
      constructor create;
      destructor destroy; override;
      function loadObject( strm_ : TStream; versionID_ : integer ) : TMyBaseClass;

  end;

constructor TMyBaseClass.load( stream_ : TStream; versionID_ : integer );
begin
  inherited create;
  // Load TMyBaseClass attributes
end;

constructor TMyClass1.load( stream_ : TStream; versionID_ : integer );
begin
  inherited load( stream_, versionID_ );
  // Load TMyClass1 attributes
end;

constructor TMyClass2.load( stream_ : TStream; versionID_ : integer );
begin
  inherited load( stream_, versionID_ );
  // Load TMyClass2 attributes
end;

function TMyClassRepository.createStreamRecList : TStreamRecList;
begin
  result := TStreamRecList.Create;
end;

procedure TMyClassRepository.releaseStreamRecsList;
begin
  if ( fStreamRecs <> NIL ) then
  begin
    releaseStreamRecs;
    fStreamRecs.Free;
    fStreamRecs := NIL;
  end;
end;

procedure TMyClassRepository.createStreamRecs;

    function createStreamRec( id_ : cardinal; classType_ : CMyBaseClass ) : PStreamRec;
    begin
      getMem( result, sizeOf( TStreamRec ) );
      result^.id := id_;
      result^.classType := classType_;
    end;

begin
  fStreamRecs.Add( createStreamRec( 1, TMyClass1 ) );
  fStreamRecs.Add( createStreamRec( 2, TMyClass2 ) );
end;

procedure TMyClassRepository.releaseStreamRecs;
var
  pSR : PStreamRec;
begin
  for pSR in fStreamRecs do
    freeMem( pSR );
end;

function TMyClassRepository.getClassTypeById( id_ : cardinal ) : CMyBaseClass;
var
  i : integer;
  pSR : PStreamRec;
begin
  result := NIL;
  i := fStreamRecs.Count;
  while ( ( result = NIL ) and ( i > 0 ) ) do
  begin
    dec( i );
    pSR := fStreamRecs[i];
    if ( pSR^.id = id_ ) then
      result := pSR^.classType;
  end;
end;

constructor TMyClassRepository.create;
begin
  inherited create;
  fStreamRecs := createStreamRecList;
  createStreamRecs;
end;

destructor TMyClassRepository.Destroy;
begin
  releaseStreamRecsList;
  inherited destroy;
end;

function TMyClassRepository.loadObject( strm_ : TStream; versionID_ : integer ) : TMyBaseClass;
var
  id : cardinal;
  cMBC : CMyBaseClass;
  aMBC : TMyBaseClass;
begin
  strm_.Read( id, sizeOf( cardinal ) );
  cMBC := getClassTypeById( id );
  if ( cMBC <> NIL ) then
    result := cMBC.load( strm_, versionID_ )
  else
    result := NIL;
end;

procedure TForm2.Button1Click(Sender: TObject);
var
  mcRepository : TMyClassRepository;
  strm : TStream;
  cMBC : CMyBaseClass;

  function createInitializedStream : TStream;

    procedure initStreamByIDs( versionID_ : integer; ids_ : array of cardinal );
    var
      id : cardinal;
    begin
      result.Write( versionID_, sizeOf( integer ) );
      for id in ids_ do
        result.Write( id, sizeOf( cardinal ) );
      result.position := 0;
    end;

  begin
    result := TMemoryStream.create;
    initStreamByIDs( 1, [1,2] );
  end;

  procedure loadObjects;
  var
    versionID : integer;
    aMBC : TMyBaseClass;
  begin
    strm.read( versionID, sizeOf( integer ) );
    while ( strm.Position < strm.Size ) do
    begin
      aMBC := mcRepository.loadObject( strm, versionID );
      if ( aMBC <> NIL ) then
        // In this test I don't need the objects so I just release them right now
        aMBC.free;
    end;
  end;

begin
  mcRepository := TMyClassRepository.create;
  try
    strm := createInitializedStream;
    try
      loadObjects;
    finally
      strm.free;
      strm := NIL;
    end;
  finally
    mcRepository.Free;
    mcRepository := NIL;
  end;
end;

Файл dfm: 

object Form2: TForm2
  Left = 479
  Top = 112
  Caption = 'Form2'
  ClientHeight = 637
  ClientWidth = 1289
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'Tahoma'
  Font.Style = []
  OldCreateOrder = False
  Visible = True
  PixelsPerInch = 96
  TextHeight = 13
  object Button1: TButton
    Left = 840
    Top = 88
    Width = 75
    Height = 25
    Caption = 'Button1'
    TabOrder = 0
    OnClick = Button1Click
  end
end
...