delphi - 使用 poPropagateChanges 和 poFetchDetailsOnDemand 避免 ClientDataSets 中的内存损坏？

Question

提前道歉，因为需要一个相当大的简化程序来显示问题...完整的代码在我的问题末尾。

我有一个广泛使用TClientDataSet的程序，有时会导致错误消息，据我所知是正确的代码。我已将其简化为在 .\SQLEXPRESS MSSQL 实例、tempdb 数据库上运行的示例程序，并使用 TClientDataSet 访问三个带有主从链接的表。数据库结构如下所示:

╔═══════════╗    ╔═══════════╗    ╔═══════════╗║ Test1     ║    ║ Test2     ║    ║ Test3     ║╟───────────╢    ╟───────────╢    ╟───────────╢║ id        ║─┐  ║ id        ║─┐  ║ id        ║║ datafield ║ └──║ Test1     ║ └──║ Test2     ║╚═══════════╝    ║ datafield ║    ║ datafield ║                 ╚═══════════╝    ╚═══════════╝

In this simplified version, the three id fields are simple integer fields, but in my real code, they are identity columns. This is not directly relevant, except for the invariable "why are you doing this?" question.

When pushing a record into Test3, in the provider's BeforeUpdateRecord event, I set its Test2 value to the corresponding record's id field. This is necessary, as it does not happen automatically when a real identity column is used and the Test2 record is newly inserted. I also use NewValue for other server-calculated values.

After I've called ApplyUpdates, which succeeds, I attempt to fetch the detail records for the next master record. This succeeds, the details get loaded, but: the detail record is marked as usModified, even though the data set's ChangeCount is zero. In other words, the last assert fails.

Delphi 2010 behaves the same, and comes with MIDAS sources, allowing me to trace to figure out what's going wrong. In short, OverWriteRecord is used when pushing the NewValue back into the database. OverWriteRecord uses record iRecNoNext as a temporary buffer, and leaves its attr field trashed. FetchDetails later ends up calling InsertRecord, which assumes the new record buffer's attr is still 0. It isn't 0, and everything goes wrong after that.

Knowing that, I could solve it by changing the MIDAS sources to always reset attr. Except Delphi XE Pro doesn't include them. So, my questions:

• Is this problem fixed in Delphi XE3?
  • If so, is its midas.dll freely redistributable?
    • If so, where can I get it?
• If not, is there any way to avoid the problem without changing the MIDAS sources?

Note that having the problem occur less frequently (by avoiding setting NewValue except when strictly necessary) is insufficient.

Both the use of poPropagateChanges to move the NewValues back into the original ClientDataSet, and the use of poFetchDetailsOnDemand to not load all detail records in one go, are essential to the application.

New observation: the code in InsertRecord (in dsupd.cpp):

if (!bDisableLog) // Nov. -97
{
    piAttr[iRecNoNext-1] = dsRecNew;
}

故意不清除该属性。当从 ReadRows(在 dsinmem2.cpp 中)调用它时，该属性会在调用 InsertRecord 之前设置，因此在这种情况下重置该属性会错的。无论需要改变什么，无论如何都不应该在那时改变。

完整代码:

DBClientTest.dpr:

program DBClientTest;

uses
  Forms,
  MainForm in 'MainForm.pas' {frmMain};

{$R *.res}

begin
  Application.Initialize;
  Application.CreateForm(TfrmMain, frmMain);
  Application.Run;
end.

MainForm.dfm:

object frmMain: TfrmMain
  Left = 0
  Top = 0
  Caption = 'frmMain'
  ClientHeight = 297
  ClientWidth = 297
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'Tahoma'
  Font.Style = []
  OldCreateOrder = False
  OnCreate = FormCreate
  PixelsPerInch = 96
  TextHeight = 13
  object ADOConnection: TADOConnection
    Connected = True
    ConnectionString =
      'Provider=SQLNCLI10.1;Integrated Security=SSPI;Persist Security I' +
      'nfo=False;User ID="";Initial Catalog=tempdb;Data Source=.\SQLEXP' +
      'RESS;Initial File Name="";Server SPN=SSPI'
    LoginPrompt = False
    Provider = 'SQLNCLI10.1'
    Left = 32
    Top = 8
  end
  object DropTablesCommand: TADOCommand
    CommandText =
      'if object_id('#39'Test3'#39') is not null'#13#10#9'drop table Test3;'#13#10#13#10'if obje' +
      'ct_id('#39'Test2'#39') is not null'#13#10#9'drop table Test2;'#13#10#13#10'if object_id('#39 +
      'Test1'#39') is not null'#13#10#9'drop table Test1;'
    Connection = ADOConnection
    ExecuteOptions = [eoExecuteNoRecords]
    Parameters = <>
    Left = 32
    Top = 56
  end
  object CreateTablesCommand: TADOCommand
    CommandText =
      'create table Test1 ('#13#10#9'id int not null identity(1, 1) primary ke' +
      'y,'#13#10#9'datafield int not null );'#13#10#13#10'create table Test2 ('#13#10#9'id int ' +
      'not null identity(1, 1) primary key,'#13#10#9'Test1 int not null'#13#10#9#9'con' +
      'straint FK_Test2_Test1 foreign key references Test1 ( id ),'#13#10#9'da' +
      'tafield int not null );'#13#10#13#10'create table Test3 ('#13#10#9'id int not nul' +
      'l identity(1, 1) primary key,'#13#10#9'Test2 int not null'#13#10#9#9'constraint' +
      ' FK_Test3_Test2 foreign key references Test2 ( id ),'#13#10#9'datafield' +
      ' int not null );'
    Connection = ADOConnection
    ExecuteOptions = [eoExecuteNoRecords]
    Parameters = <>
    Left = 32
    Top = 104
  end
  object Test1ADO: TADODataSet
    Connection = ADOConnection
    CursorType = ctStatic
    CommandText = 'select id, datafield from Test1;'
    IndexFieldNames = 'id'
    Parameters = <>
    Left = 32
    Top = 152
    object Test1ADOid: TIntegerField
      FieldName = 'id'
      ProviderFlags = [pfInUpdate, pfInWhere, pfInKey]
    end
    object Test1ADOdatafield: TIntegerField
      FieldName = 'datafield'
    end
  end
  object Test2ADO: TADODataSet
    Connection = ADOConnection
    CursorType = ctStatic
    CommandText = 'select id, Test1, datafield from Test2 where Test1 = :id;'
    DataSource = Test1ADODS
    IndexFieldNames = 'Test1;id'
    MasterFields = 'id'
    Parameters = <
      item
        Name = 'id'
        Attributes = [paSigned]
        DataType = ftInteger
        Precision = 10
        Value = 1
      end>
    Left = 32
    Top = 200
    object Test2ADOid: TIntegerField
      FieldName = 'id'
      ProviderFlags = [pfInUpdate, pfInWhere, pfInKey]
    end
    object Test2ADOTest1: TIntegerField
      FieldName = 'Test1'
    end
    object Test2ADOdatafield: TIntegerField
      FieldName = 'datafield'
    end
  end
  object Test3ADO: TADODataSet
    Connection = ADOConnection
    CursorType = ctStatic
    CommandText = 'select id, Test2, datafield from Test3 where Test2 = :id;'
    DataSource = Test2ADODS
    IndexFieldNames = 'Test2;id'
    MasterFields = 'id'
    Parameters = <
      item
        Name = 'id'
        Attributes = [paSigned]
        DataType = ftInteger
        Precision = 10
        Value = 1
      end>
    Left = 32
    Top = 248
    object Test3ADOid: TIntegerField
      FieldName = 'id'
      ProviderFlags = [pfInUpdate, pfInWhere, pfInKey]
    end
    object Test3ADOTest2: TIntegerField
      FieldName = 'Test2'
    end
    object Test3ADOdatafield: TIntegerField
      FieldName = 'datafield'
    end
  end
  object Test1ADODS: TDataSource
    DataSet = Test1ADO
    Left = 104
    Top = 152
  end
  object Test2ADODS: TDataSource
    DataSet = Test2ADO
    Left = 104
    Top = 200
  end
  object DataSetProvider: TDataSetProvider
    DataSet = Test1ADO
    Options = [poFetchDetailsOnDemand, poPropogateChanges, poUseQuoteChar]
    BeforeUpdateRecord = DataSetProviderBeforeUpdateRecord
    Left = 184
    Top = 152
  end
  object Test1CDS: TClientDataSet
    Aggregates = <>
    FetchOnDemand = False
    Params = <>
    ProviderName = 'DataSetProvider'
    Left = 256
    Top = 152
    object Test1CDSid: TIntegerField
      FieldName = 'id'
      ProviderFlags = [pfInUpdate, pfInWhere, pfInKey]
    end
    object Test1CDSdatafield: TIntegerField
      FieldName = 'datafield'
    end
    object Test1CDSTest2ADO: TDataSetField
      FieldName = 'Test2ADO'
    end
  end
  object Test2CDS: TClientDataSet
    Aggregates = <>
    DataSetField = Test1CDSTest2ADO
    FetchOnDemand = False
    Params = <>
    Left = 256
    Top = 200
    object Test2CDSid: TIntegerField
      FieldName = 'id'
      ProviderFlags = [pfInUpdate, pfInWhere, pfInKey]
    end
    object Test2CDSTest1: TIntegerField
      FieldName = 'Test1'
    end
    object Test2CDSdatafield: TIntegerField
      FieldName = 'datafield'
    end
    object Test2CDSTest3ADO: TDataSetField
      FieldName = 'Test3ADO'
    end
  end
  object Test3CDS: TClientDataSet
    Aggregates = <>
    DataSetField = Test2CDSTest3ADO
    FetchOnDemand = False
    Params = <>
    Left = 256
    Top = 248
    object Test3CDSid: TIntegerField
      FieldName = 'id'
      ProviderFlags = [pfInUpdate, pfInWhere, pfInKey]
    end
    object Test3CDSTest2: TIntegerField
      FieldName = 'Test2'
    end
    object Test3CDSdatafield: TIntegerField
      FieldName = 'datafield'
    end
  end
end

MainForm.pas:

unit MainForm;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, DB, ADODB, DBClient, Provider;

type
  TfrmMain = class(TForm)
    ADOConnection: TADOConnection;
    DropTablesCommand: TADOCommand;
    CreateTablesCommand: TADOCommand;
    Test1ADO: TADODataSet;
    Test1ADOid: TIntegerField;
    Test1ADOdatafield: TIntegerField;
    Test2ADO: TADODataSet;
    Test2ADOid: TIntegerField;
    Test2ADOTest1: TIntegerField;
    Test2ADOdatafield: TIntegerField;
    Test3ADO: TADODataSet;
    Test3ADOid: TIntegerField;
    Test3ADOTest2: TIntegerField;
    Test3ADOdatafield: TIntegerField;
    Test1ADODS: TDataSource;
    Test2ADODS: TDataSource;
    DataSetProvider: TDataSetProvider;
    Test1CDS: TClientDataSet;
    Test1CDSid: TIntegerField;
    Test1CDSdatafield: TIntegerField;
    Test1CDSTest2ADO: TDataSetField;
    Test2CDS: TClientDataSet;
    Test2CDSid: TIntegerField;
    Test2CDSTest1: TIntegerField;
    Test2CDSdatafield: TIntegerField;
    Test2CDSTest3ADO: TDataSetField;
    Test3CDS: TClientDataSet;
    Test3CDSid: TIntegerField;
    Test3CDSTest2: TIntegerField;
    Test3CDSdatafield: TIntegerField;
    procedure DataSetProviderBeforeUpdateRecord(Sender: TObject;
      SourceDS: TDataSet; DeltaDS: TCustomClientDataSet;
      UpdateKind: TUpdateKind; var Applied: Boolean);
    procedure FormCreate(Sender: TObject);
  end;

var
  frmMain: TfrmMain;

implementation

{$R *.dfm}

{ TfrmMain }

procedure TfrmMain.DataSetProviderBeforeUpdateRecord(Sender: TObject;
  SourceDS: TDataSet; DeltaDS: TCustomClientDataSet; UpdateKind: TUpdateKind;
  var Applied: Boolean);
begin
  if SourceDS = Test3ADO then
  begin
    with DeltaDS.FieldByName(Test3CDSTest2.FieldName) do
      NewValue := DeltaDS.DataSetField.DataSet.FieldByName(Test2CDSid.FieldName).Value;
  end;
end;

procedure TfrmMain.FormCreate(Sender: TObject);
begin
  DropTablesCommand.Execute;
  try
    CreateTablesCommand.Execute;

    Test1ADO.Open;
    Test2ADO.Open;
    Test3ADO.Open;

    Assert(Test1ADO.IsEmpty);
    Test1ADO.AppendRecord([ nil, 1 ]);

      Assert(Test2ADO.IsEmpty);
      Test2ADO.AppendRecord([ nil, Test1ADOid.Value, 2 ]);

        Assert(Test3ADO.IsEmpty);
        Test3ADO.AppendRecord([ nil, Test2ADOid.Value, 3 ]);

    Test1ADO.AppendRecord([ nil, 4 ]);

      Assert(Test2ADO.IsEmpty);
      Test2ADO.AppendRecord([ nil, Test1ADOid.Value, 5 ]);

        Assert(Test3ADO.IsEmpty);
        Test3ADO.AppendRecord([ nil, Test2ADOid.Value, 6 ]);

    Test3ADO.Close;
    Test2ADO.Close;
    Test1ADO.Close;

    Test1CDS.Open;

    Test1CDS.First;
    Assert(Test1CDSdatafield.Value = 1);

    Assert(Test2CDS.IsEmpty);
    Test1CDS.FetchDetails;
    Assert(Test2CDS.RecordCount = 1);

    Assert(Test3CDS.IsEmpty);
    Test2CDS.FetchDetails;
    Assert(Test3CDS.RecordCount = 1);

    Test3CDS.First;
    Assert(Test3CDSdatafield.Value = 3);
    Test3CDS.Edit;
    Test3CDSdatafield.Value := -3;
    Test3CDS.Post;

    Test1CDS.ApplyUpdates(0);

    Assert(Test3CDSdatafield.Value = -3);

    Test1CDS.Last;
    Assert(Test1CDSdatafield.Value = 4);

    Assert(Test2CDS.IsEmpty);
    Test1CDS.FetchDetails;
    Assert(Test2CDS.RecordCount = 1);
    Assert(Test2CDS.UpdateStatus = usUnmodified);

    Assert(Test3CDS.IsEmpty);
    Test2CDS.FetchDetails;
    Assert(Test3CDS.RecordCount = 1);
    Assert(Test3CDS.UpdateStatus = usUnmodified);
  finally
    DropTablesCommand.Execute;
  end;
end;

end.

Answer 1

在对 D2010 MIDAS 代码进行广泛搜索后，我确定对于我的应用程序中的使用，InsertRecord 存在三种可能性:

• 该属性已设置为 0
• 该属性未设置且不会设置
• 该属性需要设置为dsRecNew

第四种可能性，即属性已被设置为 0 以外的值，在我的应用程序中不会出现。因此，总是在此时设置属性对我来说不是问题。我赌了一点，说 XE 的 MIDAS DLL 仍然是这样。

我选择手动加载 MIDAS.DLL，并在内存中修补它。基于D2010代码:

if (!bDisableLog) // Nov. -97
{
    piAttr[iRecNoNext-1] = dsRecNew;
}

编译为

837B2400   cmp dword ptr [ebx+$24],$00
750B       jnz skip
8B4338     mov eax,[ebx+$38]
8B537C     mov edx,[ebx+$7c]
C64410FF04 mov byte ptr [edx+eax-$01],$04
           skip:

知道 bDisableLog 为 0 或 1，我已将代码更改为以下效果

piAttr[iRecNoNext-1] = (bDisableLog - 1) & dsRecNew;

可以编译为

8B4324     mov eax,[ebx+$24]
48         dec eax
83E004     and eax,$04
8B5338     mov edx,[ebx+$38]
8B737C     mov esi,[ebx+$7c]
884432FF   mov [edx+esi-$01],al

这是完全相同的字节数。 esi 没有保存需要保留的值。

所以在我的代码中:

• 我调用LoadLibrary('midas.dll')
• 我调用 GetProcAddress(handle, 'DllGetClassObject')
• 我发现上面的代码在DllGetClassObject之后有$24094字节
• 我验证读取 17 个字节会产生 17 个预期字节
• 我调用VirtualProtect来确保内存可写(准确地说，是写时复制)
• 我覆盖内存
• 我再次调用VirtualProtect来恢复内存保护
• 最后，我将 DllGetClassObject 的地址传递给 RegisterMidasLib，以防止 DBClient 再次尝试加载 MIDAS.DLL，甚至可能不同的 MIDAS.DLL

是的，这很脆弱，会随着新版本的 MIDAS.DLL 的出现而崩溃。如果这成为一个问题，我可以确保从应用程序目录加载 XE 的 MIDAS.DLL，从而绕过系统范围内恰好安装的任何 MIDAS。如果/当我升级到较新版本的Delphi时，无论这个错误是否会被修复，我都会确保它是包含MIDAS源代码的版本，这样我就可以避免陷入这样的问题。