Question

在从流中读取对象内容之前，请先读取ID以确定对象类型。为此，我必须存储流记录（TStreamRec）才能将类类型链接到ID。当我加载ID时，我必须搜索正确的流记录以在正确的类型上调用正确的构造函数。

不幸的是，我必须使用旧式的Delphi类类型（TMyClass = object）。

当我在object中使用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（在随附的源代码的最后）开始进行代码调查。触发事件，用于使用“新”（不是古老的旧）样式类类型测试我的解决方案。

在没有FastMM4错误消息的情况下，旧样式的Delphi类类型是否可以执行相同的操作？

具有以下类别的工作示例的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

通过ID在旧式Delphi类上调用虚拟构造函数

0 个答案: