Delphi XE7 64位环境下TRichEdit间追加RTF文本访问报错问题

问题描述 #

我需要实现两个TAddictSpellRichEdit富文本控件间的RTF格式内容追加功能，初始编写的代码如下：

unit RTFProcs1;
interface
uses
Windows, classes, comctrls, Messages, RichEdit, vcl.Dialogs, System.SysUtils, ad4Controls, Ad3RicheditDB;


Procedure AppendFromRichEdit(FromRch,ToRch: TAddictSpellRichEdit);

implementation
Type
  TEditStreamCallBack = function (dwCookie: Longint; pbBuff: PByte;
    cb: Longint; var pcb: Longint): DWORD_PTR; stdcall;
  TEditStream = packed record  //David Heffernan建议修改
    dwCookie: DWORD_PTR;       //David Heffernan建议修改
    dwError: Longint;
    pfnCallback: TEditStreamCallBack;
  end;

Procedure AppendFromRichEdit(FromRch,ToRch: TAddictSpellRichEdit); // 实现富文本源控件到目标控件的内容追加
var
  MyMemStream: TMemoryStream;
   rtfStream: TEditStream;
  function EditStreamReader(
    dwCookie: DWORD_PTR;  //David Heffernan建议修改
    pBuff: Pointer;
    cb: LongInt;
    pcb: PLongInt): DWORD_PTR; stdcall;  //David Heffernan建议修改
  begin
    result := $0000;
    try
      pcb^ := TStream(dwCookie).Read(pBuff^, cb) ;
    except
      result := $FFFF;
    end;
  end; (*EditStreamReader*)

begin
   MyMemStream := TMemoryStream.Create;
   FromRch.MaxLength := FromRch.MaxLength + MyMemStream.Size;
   ToRch.MaxLength := ToRch.MaxLength + MyMemStream.Size;
   try
    FromRch.Lines.SaveToStream(MyMemStream);
    MyMemStream.Position := 0;
    rtfStream.dwCookie := DWORD_PTR(MyMemStream) ;
    rtfStream.dwError := $0000;
    rtfStream.pfnCallback := @EditStreamReader;
    Try
      ToRch.Perform(EM_STREAMIN, SFF_SELECTION or SF_RTF,
         LPARAM(@rtfStream)
      ) ;
      if rtfStream.dwError <> $0000 then
        raise Exception.Create('RTF数据追加错误');
    except
      On E: Exception do
       // 暂不处理  MsgBox(E.Message)
    end;
   finally
      MyMemStream.Free;
   end;
end;

这段代码的运行现象：

• 32位编译版本可以无错正常运行
• 编译为64位版本时，执行到EM_STREAMIN消息处理会立刻触发内存访问错误

我最初按照David Heffernan给出的64位适配建议，修正了结构体、回调签名里的指针相关类型，将原本长度不匹配的Longint类型替换为64位下正确的DWORD_PTR，同时把回调函数返回值改为API要求的DWORD类型，修改后代码如下：

implementation
Type
  TEditStreamCallBack = function (dwCookie: DWORD_PTR; pbBuff: PByte;
    cb: Longint; var pcb: Longint): DWORD; stdcall;
  TEditStream = Packed record
    dwCookie: DWORD_PTR;
    dwError: Longint;
    pfnCallback: TEditStreamCallBack;
  end;

Procedure AppendFromRichEdit(FromRch,ToRch: TAddictSpellRichEdit); // 实现富文本源控件到目标控件的内容追加
var
  MyMemStream: TMemoryStream;
   rtfStream: TEditStream;
  function EditStreamReader(
    dwCookie: DWORD_PTR;
    pBuff: Pointer;
    cb: LongInt;
    pcb: PLongInt): DWORD; stdcall;
  begin
    result := $0000;
    try
      pcb^ := TStream(dwCookie).Read(pBuff^, cb) ;
    except
      result := $FFFF;
    end;
  end; (*EditStreamReader*)

begin
   MyMemStream := TMemoryStream.Create;
   FromRch.MaxLength := FromRch.MaxLength + MyMemStream.Size;
   ToRch.MaxLength := ToRch.MaxLength + MyMemStream.Size;
   try
    FromRch.Lines.SaveToStream(MyMemStream);
    MyMemStream.Position := 0;
    rtfStream.dwCookie := DWORD_PTR(MyMemStream) ;
    rtfStream.dwError := $0000;
    rtfStream.pfnCallback := @EditStreamReader;
    Try
      ToRch.Perform(EM_STREAMIN, SFF_SELECTION or SF_RTF,
         LPARAM(@rtfStream)
      ) ;
      if rtfStream.dwError <> $0000 then
        raise Exception.Create('RTF数据追加错误');
    except
      On E: Exception do
       // 暂不处理  MsgBox(E.Message)
    end;
   finally
      MyMemStream.Free;
   end;
end;

但修改完成后64位版本依然会触发访问违规，和David Heffernan提供的可正常运行示例对比始终找不到差异点。

根因定位 #

问题核心是：不能在Delphi过程/函数内部使用嵌套局部函数作为Windows API回调。
Delphi 64位编译器下，嵌套局部函数会隐式携带外层作用域的上下文指针，栈帧结构、调用约定和全局函数存在本质差异，Windows API直接通过函数地址调用回调时，无法正确处理这个隐式上下文，直接触发内存访问错误；32位编译器下因为栈布局的巧合可以勉强运行，但属于未定义行为。

修复方案 #

将流读取回调函数EditStreamReader从AppendFromRichEdit过程内部移出，定义为implementation段的全局函数即可，修复后可同时兼容32位和64位编译环境，完整代码如下：

unit RTFProcs1;
interface
uses
  Windows, classes, comctrls, Messages, RichEdit, vcl.Dialogs, System.SysUtils, ad4Controls, Ad3RicheditDB;


Procedure AppendFromRichEdit(FromRch,ToRch: TAddictSpellRichEdit);

implementation
Type
  TEditStreamCallBack = function (dwCookie: DWORD_PTR; pbBuff: PByte;
    cb: Longint; var pcb: Longint): DWORD; stdcall;
  TEditStream = Packed record
    dwCookie: DWORD_PTR;
    dwError: Longint;
    pfnCallback: TEditStreamCallBack;
  end;

//该回调必须定义在过程外部，不能作为嵌套局部函数
function EditStreamReader(
    dwCookie: DWORD_PTR;
    pBuff: Pointer;
    cb: LongInt;
    pcb: PLongInt): DWORD; stdcall;
  begin
    result := $0000;
    try
      pcb^ := TStream(dwCookie).Read(pBuff^, cb) ;
    except
      result := $FFFF;
    end;
  end; (*EditStreamReader*)

Procedure AppendFromRichEdit(FromRch,ToRch: TAddictSpellRichEdit); // 实现富文本源控件到目标控件的内容追加
var
  MyMemStream: TMemoryStream;
   rtfStream: TEditStream;

begin
   MyMemStream := TMemoryStream.Create;
   FromRch.MaxLength := FromRch.MaxLength + MyMemStream.Size;
   ToRch.MaxLength := ToRch.MaxLength + MyMemStream.Size;
   try
    FromRch.Lines.SaveToStream(MyMemStream);
    MyMemStream.Position := 0;
    rtfStream.dwCookie := DWORD_PTR(MyMemStream) ;
    rtfStream.dwError := $0000;
    rtfStream.pfnCallback := @EditStreamReader;
    Try
      ToRch.Perform(EM_STREAMIN, SFF_SELECTION or SF_RTF,
         LPARAM(@rtfStream)
      ) ;
      if rtfStream.dwError <> $0000 then
        raise Exception.Create('RTF数据追加错误');
    except
      On E: Exception do
       // 暂不处理  MsgBox(E.Message)
    end;
   finally
      MyMemStream.Free;
   end;
end;

非常感谢@DavidHeffernan的专业指导。

此致
TomD

内容的提问来源于stack exchange，提问作者Tom Dalton