如果在包内访问 RTTI，则访问冲突

Question

我写了一个简单的控制台程序来施展一些 RTTI 魔法：

program TypeCast;

{$APPTYPE CONSOLE}

{$R *.res}

uses
  System.SysUtils, System.RTTI, Generics.Collections;

type
  TSpr = class
  public
    s: string;
    i: Integer;
    b: Boolean;
  end;

var
  Spr: TSpr;
  vCtx: TRTTIContext;
  vType: TRTTIType;
  vField: TRTTIField;
  Dict: TDictionary<string, TRTTIField>;

begin
  try
    Spr := TSpr.Create;
    vType := vCtx.GetType(TSpr.ClassInfo);
    Dict := TDictionary<string, TRTTIField>.Create;
    for vField in vType.GetFields do
      Dict.AddOrSetValue(vField.Name, vField);
    Dict['s'].SetValue(Spr, 'Hello World!');
    Dict['i'].SetValue(Spr, 123);
    Dict['b'].SetValue(Spr, True);
    Writeln(Spr.s);
    Writeln(Spr.i);
    Writeln(Spr.b);
    Spr.Free;
  except
    on E: Exception do
      Writeln(E.ClassName, ': ', E.Message);
  end;
  Readln;
end.

输出：

Hello World!
123
TRUE

如果我编译并运行这个程序，它工作正常。但是如果我使用这种技术将这些类型的变量转发到在另一个包中定义的对象，它会给我带来很多麻烦。

MCVE 内容/重现步骤：
^{...假设您是从空环境开始...}

1. 创建PluginInterface 包。在那里添加UClassManager

   unit UClassManager;
   
   interface
   
   uses
     Classes, Contnrs;
   
   type
     TClassManager = class(TClassList);
   
   function ClassManager: TClassManager;
   
   implementation
   
   var
     Manager: TClassManager;
   
   function ClassManager: TClassManager;
   begin
     Result := Manager;
   end;
   
   initialization
   Manager := TClassManager.Create;
   
   finalization
   Manager.Free;
   
   end.
   

   和UPlugin 单位。

   unit UPlugin;
   
   interface
   
   uses RTTI;
   
   type
     TPlugin = class
     public
       procedure Init; virtual; abstract;
       function SetProp(Key: string; Value: TValue): Boolean; virtual; abstract;
     end;
   
     TPluginClass = class of TPlugin;
     IPluginHost = interface
       function RunPlugin(PluginName: string): TPlugin; // Run Plugin by it's ClassName
     end;
   
   var
     Host: IPluginHost;
   
   implementation
   
   end.
   

2. 创建VCL Forms Application，启用运行时包，添加对PluginInterface的引用并在其上添加TButton。为相应的事件制作这些处理程序：

   procedure TForm1.FormCreate(Sender: TObject);
   begin
     LoadPackage('UniversalSpr.bpl');
     Host := Self;
   end;
   
   procedure TForm1.Button1Click(Sender: TObject);
   var
     Plugin: TPlugin;
   begin
     Plugin := Host.RunPlugin('TSprPlugin');
     Plugin.Init;
     Plugin.SetProp('SprTableName', 'MATERIALS');
     Plugin.SetProp('EditRights', True);
     Plugin.SetProp('BeforePostValue1', 3);
   end;
   
   function TForm1.RunPlugin(PluginName: string): TPlugin;
   var
     I: Integer;
   begin
     Result := nil;
     for I := 0 to ClassManager.Count - 1 do
       if ClassManager[I].ClassNameIs(PluginName) then begin
         Result := TPluginClass(ClassManager[I]).Create;
         Break;
       end;
   end;
   

   粗略地说，TForm1 应该是IPluginHost 的后代。并且不要忘记将UClassManager 和UPlugin 添加到uses 子句中。其他单元将由 IDE 自动添加。

3. 创建包UniversalSpr 并将其输出文件放置到您的应用程序所在的同一目录中。在TSprPlugin 中实现UPlugin：

   unit USprPlugin;
   
   interface
   
   uses
     UPlugin, RTTI, Generics.Collections;
   
   type
     TSpr = class
       SprTableName: string;
       BeforePostValue1: int64;
       EditRights: boolean;
     end;
     TSprPlugin = class(TPlugin)
       procedure Init; override;
       function SetProp(Key: string; Value: TValue): Boolean; override;
       private
         Spr: TSpr;
         PropDict: TDictionary<string, TRTTIField>;
     end;
   
   implementation
   
   procedure TSprPlugin.Init;
   var
     vCtx: TRTTIContext;
     vType: TRTTIType;
     vField: TRTTIField;
   begin
     if not Assigned(Spr) then
       Spr := TSpr.Create;
     vType := vCtx.GetType(Spr.ClassInfo);
     if not Assigned(PropDict) then
       PropDict := TDictionary<string, TRTTIField>.Create;
     for vField in vType.GetFields do
       PropDict.Add(vField.Name, vField);
   end;
   
   function TSprPlugin.SetProp(Key: string; Value: TValue): Boolean;
   var
     Field: TRTTIField;
   begin
     Result := PropDict.TryGetValue(Key, Field);
     if Result then
       // here I get Access Violation
       Field.SetValue(Spr, Value);
   end;
   
   end.
   

单击Button1 后，您可以将指定的值传递给属性设置器/修改器，但如果您尝试在例程中重复我的TypeCast 技巧，您将在尝试访问00000004 时遇到访问冲突。

此外，调查和高级调试表明 Field.FieldType 评估正确（这解释了为什么不抛出 InsufficientRTTI），但如果我想得到 Field.Fieldtype.Handle，我会得到臭名昭著的 AV。

我可以设置从原始SetValue 方法中跳过Cast 的值：

function TSprPlugin.SetProp(Key: string; Value: TValue): Boolean;
var
  Field: TRTTIField;
begin
  Result := PropDict.TryGetValue(Key, Field);
  if Result then
    Value.ExtractRawData(PByte(Spr) + Field.Offset);
end;

Dalija 建议避免使用包，我已经考虑到这一点，这就是我创建TypeCast 来测试 RTTI 的原因。但是我需要包，因为我的应用程序的设计，我不能只是将它重写为单一的。我可以做些什么来避免这种访问冲突不放弃包？

Answer 1

无论您是否使用运行时包，您当前的代码都有一些问题。您的 MCVE 并不完全是最小的，并且您从工作的控制台应用程序中添加了太多步骤到无法工作的打包代码中。

在调试您的问题时，您应该从将逻辑封装到 TSprPlugin 类中并直接测试该类开始，而不会弄乱运行时包。当您确定TSprPlugin 代码正常运行时，您可以添加包并查看它的运行情况。

现在您的代码因以下简单的测试项目而失败

program test;

{$APPTYPE CONSOLE}

{$R *.res}

uses
  System.SysUtils,
  USprPlugin in 'USprPlugin.pas',
  UPlugin in 'UPlugin.pas';

var
  Plugin: TPlugin;

begin
  Plugin := TSprPlugin.Create;
  Plugin.Init;

  Plugin.SetProp('SprTableName', 'MATERIALS');
  Plugin.SetProp('EditRights', True);
  Plugin.SetProp('BeforePostValue1', 3);
end.

将vCtx 从局部变量移动到TSprPlugin 字段解决了上述测试用例的问题。

unit USprPlugin;

interface

uses
  UPlugin, RTTI, UniversalSprUnit, Generics.Collections;

type
  TSprPlugin = class(TPlugin)
    vCtx: TRTTIContext;
    procedure Init; override;
    function SetProp(Key: string; Value: TValue): Boolean; override;
    private
      Spr: TSpr;
      PropDict: TDictionary<string, TRTTIField>;
  end;

implementation

procedure TSprPlugin.Init;
var
  vType: TRTTIType;
  vField: TRTTIField;
begin
  vCtx := TRttiContext.Create;
  if not Assigned(Spr) then
    Spr := TSpr.Create;
  vType := vCtx.GetType(Spr.ClassInfo);
  if not Assigned(PropDict) then
    PropDict := TDictionary<string, TRTTIField>.Create;
  for vField in vType.GetFields do
    PropDict.Add(vField.Name, vField);
end;

function TSprPlugin.SetProp(Key: string; Value: TValue): Boolean;
var
  Field: TRTTIField;
begin
  Result := PropDict.TryGetValue(Key, Field);
  if Result then
    // here I get Access Violation
    Field.SetValue(Spr, Value);
end;

end.

从那里开始，您可以逐步添加其他功能，确保每个步骤都不会破坏功能。

此外，您没有释放 Spr 和 PropDict 字段，从而造成内存泄漏，但我不确定是否不包含该代码只是因为它与您遇到的问题没有直接关系，或者您真的那里有内存泄漏。