如何将对象函数(of object)赋给普通函数指针?(50)

  • 主题发起人 wind_2005
  • 开始时间
W

wind_2005

Unregistered / Unconfirmed
GUEST, unregistred user!
我写了如下一段代码,在procedure TForm1.Button1Click(Sender: TObject);的最后一句报异常,该语句是想实现:将一对象函数(of object)赋给普通函数指针,并调用该对象函数。请问各们,如何实现上述功?先在这里谢谢大家了!unit Unit1;interfaceuses Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls;type TFunctionType = function: string of object
//定义对象函数指针 TFunctionType1 = function: string
//定义函数指针 TForm1 = class(TForm) Button1: TButton
procedure Button1Click(Sender: TObject)
private { Private declarations } function selfFunciotn: string
public { Public declarations } end;var Form1: TForm1;procedure CallFunction(ft: TFunctionType)
//以函数指针为参数,调用指定函数procedure CallFunction1(ft: TFunctionType1)
//以函数指针为参数,调用指定函数function GFunction(obj: TObject): string;function GFunction1(): string;implementation{$R *.dfm}//以对象函数指针为参数,过程中调用传入函数procedure CallFunction(ft: TFunctionType);begin ShowMessage(ft);end;//以普通函数指针为参数,过程中调用传入函数procedure CallFunction1(ft: TFunctionType1);begin ShowMessage(ft);end;//普通函数,多了一个参数,用以与 对象函数指针 兼容function GFunction(obj: TObject): string;begin Result:= 'GFunction';end;//普通函数function GFunction1(): string;begin Result:= 'GFunction1';end;procedure TForm1.Button1Click(Sender: TObject);var M: TMethod;begin //以对象函数指针为参数,调用普通函数,成功 M.Code := @GFunction
M.Data := nil
CallFunction(TFunctionType(M))
//以对象函数指针为参数,调用对象函数,成功 CallFunction(self.selfFunciotn)
//以普通函数指针为参数,调用普通函数,成功 CallFunction1(GFunction1)
//以普通函数指针为参数,调用对象函数,失败 CallFunction1(MethodAddress('selfFunciotn'));end;function TForm1.selfFunciotn: string;begin Result:= 'selfFunciotn';end;end.
 
W

wind_2005

Unregistered / Unconfirmed
GUEST, unregistred user!
自己顶一下,谢谢大家了!
 
Z

znxia

Unregistered / Unconfirmed
GUEST, unregistred user!
我只知道你的 MethodAddress('selfFunciotn')返回nil;需要将selfFunciotn定义在published区域才能返回函数地址,但调试时仍然会异常。
 
L

liuls

Unregistered / Unconfirmed
GUEST, unregistred user!
//以普通函数指针为参数,调用对象函数,失败 CallFunction1(MethodAddress('selfFunciotn'));失败是因为: TFunctionType 与 TFunctionType1 不等价! --- 相当于两种过程所传的参数不同,不能相互转换! 如果定义如下的话就可以了 TFunctionType = function: string of object
// 定义对象函数指针 TFunctionType1 = function(Sender: TObject): string
// 定义函数指针
 
N

newnewer

Unregistered / Unconfirmed
GUEST, unregistred user!
有办法的!of object ,只不过是先压入了一个self,再加上函数地址,用汇编直接取出,就可以搞定!cnpack的这个单元CnCallBack,貌似也可以搞定的!///////////////////////////////////////////////////{******************************************************************************}{ CnPack For Delphi/C++Builder }{ 中国人自己的开放源码第三方开发包 }{ (C)Copyright 2001-2009 CnPack 开发组 }{ ------------------------------------ }{ }{ 本开发包是开源的自由软件,您可以遵照 CnPack 的发布协议来修 }{ 改和重新发布这一程序。 }{ }{ 发布这一开发包的目的是希望它有用,但没有任何担保。甚至没有 }{ 适合特定目的而隐含的担保。更详细的情况请参阅 CnPack 发布协议。 }{ }{ 您应该已经和开发包一起收到一份 CnPack 发布协议的副本。如果 }{ 还没有,可访问我们的网站: }{ }{ 网站地址:http://www.cnpack.org }{ 电子邮件:master@cnpack.org }{ }{******************************************************************************}unit CnCallBack;{* |<PRE>================================================================================* 软件名称:CnPack 组件包* 单元名称:回调转换的工具单元* 单元作者:CnPack开发组 savetime (savetime2k@yahoo.com)* 刘啸 (liuxiao@cnpack.org)* 备 注:该单元是回调转换等的代码单元* 包装的代码部分在自行分配的可执行的内存空间,避免了 DEP 下出错。* 开发平台:PWin2000 + Delphi 5.0* 兼容测试:PWin9X/2000/XP + Delphi 5/6/7* 本 地 化:该单元中的字符串均符合本地化处理方式* 单元标识:$Id: CnCallBack.pas,v 1.7 2009/01/02 08:27:38 liuxiao Exp $* 修改记录:2006.10.13 V1.0* 创建单元,实现功能================================================================================|</PRE>}interface{$I CnPack.inc}uses Classes, Windows, SysUtils;type ECallBackException = class(Exception) end;function StdcallMethodToCallBack(ASelf: Pointer
AMethodAddr: Pointer): Pointer;{* 将 stdcall 的类成员函数和实例加以包装,返回一个新的 stdcall 的回调函数地址 }{* 使用语法: @AStdCallbackFunc := StdcallMethodToCallBack(AObject, @TAObject.CallbackMethod)
其中 AStdCallbackFunc 和 CallbackMethod 都必须使用 stdcall 声明。}implementationtype TCnCallback = array [1..18] of Byte
// 按代码中最长的来 PCnCallback = ^TCnCallback
const THUNK_SIZE = 4096
// x86 页大小,目前只弄一个页面 StdcallCode: TCnCallback = ($8B,$04,$24,$50,$B8,$00,$00,$00,$00,$89,$44,$24,$04,$E9,$00,$00,$00,$00)
{----------------------------} { Stdcall CallbackCode ASM } {----------------------------} { MOV EAX, [ESP]
} { PUSH EAX
} { MOV EAX, ASelf
} { MOV [ESP+4], EAX
} { JMP AMethodAddr
} {----------------------------}var FCallBackPool: Pointer = nil
FEmptyPtr: Integer = 0
FCS: TRTLCriticalSection;procedure InitCallBackPool;begin FCallBackPool := VirtualAlloc(nil, THUNK_SIZE, MEM_COMMIT, PAGE_EXECUTE_READWRITE)
if FCallBackPool = nil then raise ECallBackException.Create('Callback Pool Init Error!');end;function StdcallMethodToCallBack(ASelf: Pointer
AMethodAddr: Pointer): Pointer;var Instance: PCnCallback;begin Result := nil
Instance := nil
try EnterCriticalSection(FCS)
if FCallBackPool = nil then begin InitCallBackPool
Instance := FCallBackPool
end else begin if FEmptyPtr = (THUNK_SIZE div SizeOf(TCnCallback)) then raise ECallBackException.Create('Callback Pool Overflow!')
Instance := PCnCallback(Integer(FCallBackPool) + FEmptyPtr * SizeOf(TCnCallback))
Inc(FEmptyPtr)
end
finally LeaveCriticalSection(FCS)
end
if Instance <> nil then begin Move(StdcallCode, Instance^, SizeOf(TCnCallback))
PInteger(@(Instance^[6]))^ := Integer(ASelf)
PInteger(@(Instance^[15]))^ := Integer(Integer(AMethodAddr) - Integer(Instance) - 18)
Result := Instance
end;end;initialization InitializeCriticalSection(FCS);finalization DeleteCriticalSection(FCS)
if FCallBackPool <> nil then VirtualFree(FCallBackPool, 0, MEM_RELEASE);end.
 
W

wind_2005

Unregistered / Unconfirmed
GUEST, unregistred user!
谢谢大家的回复,有没有类似像下面: //以对象函数指针为参数,调用普通函数,成功 M.Code := @GFunction
M.Data := nil
CallFunction(TFunctionType(M));这样简单的处理方法不知道能不能通过TMethod来实现,谢谢!
 
W

wind_2005

Unregistered / Unconfirmed
GUEST, unregistred user!
自己顶一下,谁知道还望告诉我,谢谢了!
 
W

wind_2005

Unregistered / Unconfirmed
GUEST, unregistred user!
找了个折中的办法,同时声明对象函数类型和普通函数类型,通过overload来实现同一个函数功能,没有找到我想要的答案,但问题也算解决了,大家来领分吧
 
W

wind_2005

Unregistered / Unconfirmed
GUEST, unregistred user!
多人接受答案了。
 

Similar threads

S
回复
0
查看
912
SUNSTONE的Delphi笔记
S
S
回复
0
查看
743
SUNSTONE的Delphi笔记
S
S
回复
0
查看
2K
SUNSTONE的Delphi笔记
S
S
回复
0
查看
2K
SUNSTONE的Delphi笔记
S
顶部