VCL消息处理机制的内幕

　2006-02-04 13:39:02　来源：WEB开发网　　　

核心提示： 由VCL中的代码理解VCL中的消息处理机制Delphi，一个非常优秀的开发工具，VCL消息处理机制的内幕，拥有强大的可视化开发环境、面向组件的快速开发模式、优秀的VCL类库、快速的代码编译器、强大的数据库和WEB开发能力、还有众多的第三方控件支持...（此处省略x千字，既然大家都知道了，并不在乎过程，从这不能简单评论

由VCL中的代码理解VCL中的消息处理机制

Delphi，一个非常优秀的开发工具，拥有强大的可视化开发环境、面向组件的快速开发模式、优秀的VCL类库、快速的代码编译器、强大的数据库和WEB开发能力、还有众多的第三方控件支持...（此处省略x千字，既然大家都知道了，不浪费口水了 ^_^）

说到VCL的优秀就不能不提到其对Windows消息及API的较全面和完美的封装，正因为如此开发者在大多数情况下甚至不需理会Windows消息处理的细节，而只需要写几行事件驱动代码即可！

但如果做为开发人员你还是想对此做些了解的话，那么就继续，通过VCL代码本身来体会VCL中的消息处理机制。

(以下代码取自Delphi 6)

说到VCL中的消息处理就不能不提到Tapplication，Windows会为每一个当前运行的程序建立一个消息队列，用来完成用户与程序的交互，正是通过Application完成了对Windows消息的集中处理！

首先通过Application.Run进入消息循环进行消息的处理，其中调用了HandleMessage。

PRocedure TApplication.HandleMessage;
var
Msg: TMsg;
begin
if not ProcessMessage(Msg) then Idle(Msg);//这里先调用ProcessMessage处理，返回值为False调用Idle，就是在空闲时，即消息队列中无消息等待处理时调用Idle。
end;

function TApplication.ProcessMessage(var Msg: TMsg): Boolean;
var
Handled: Boolean;
begin
Result := False;
if PeekMessage(Msg, 0, 0, 0, PM_REMOVE) then//查询消息队列中有无消息等待处理，参数PM_REMOVE使消息在处理完后会被删除。
begin
　 Result := True;
　 if Msg.Message <> WM_QUIT then//如果是WM_QUIT,终止进程，否则执行下面的代码
　 begin
　　 Handled := False;
　　 if Assigned(FOnMessage) then FOnMessage(Msg, Handled);
　　 if not IsHintMsg(Msg) and not Handled and not IsMDIMsg(Msg) and
　　　 not IsKeyMsg(Msg) and not IsDlgMsg(Msg) then
　　 begin
　　　 TranslateMessage(Msg);//将记录Msg传递给Windows进行转换
　　　 DispatchMessage(Msg);//将记录Msg回传给Windows
　　 end;
　 end
　 else
　　 FTerminate := True;
end;
end;

然后程序中的各个VCL对象又是如何接收到Windows消息的呢？这还要从窗体的创建开始！

首先找到TWinControl.CreateWnd中的
Windows.RegisterClass(WindowClass)//调用RegisterClass注册一个窗体类

向上看
WindowClass.lpfnWndProc := @InitWndProc;//这里指定了窗口的消息处理函数的指针为@InitWndProc！

再找到function InitWndProc(HWindow: HWnd; Message, WParam, LParam: Longint): Longint;

发现了
CreationControl.FHandle := HWindow;
SetWindowLong(HWindow, GWL_WNDPROC,Longint(CreationControl.FObjectInstance));
没有？

原来InitWndProc初次被调用时候，又使用API函数SetWindowLong指定处理消息的窗口过程为FObjectInstance。

回到TWinControl.Create
FObjectInstance := Classes.MakeObjectInstance(MainWndProc);
找到关键所在了，也许有些朋友对MakeObjectInstance这个函数很熟了，它的作用就是将一个成员过程转换为标准过程。

绕了个圈子？为什么呢？很简单，因为窗体成员过程包括一隐含参数传递Self指针，所以需要转化为标准过程。

const
InstanceCount = 313;//这个不难理解吧？314*13+10=4092，再大的话，记录TInstanceBlock的大小就超过了下面定义的PageSize

type
PObjectInstance = ^TObjectInstance;
TObjectInstance = packed record
　 Code: Byte;
　 Offset: Integer;
　 case Integer of
　　 0: (Next: PObjectInstance);
　　 1: (Method: TWndMethod);
end;

type
PInstanceBlock = ^TInstanceBlock;
TInstanceBlock = packed record
　 Next: PInstanceBlock;
　 Code: array[1..2] of Byte;
　 WndProcPtr: Pointer;
　 Instances: array[0..InstanceCount] of TObjectInstance;
end;

var
InstBlockList: PInstanceBlock;
InstFreeList: PObjectInstance;

function StdWndProc(Window: HWND; Message, WParam: Longint;
LParam: Longint): Longint; stdcall; assembler;
asm
　　　 XOR　　 EAX,EAX
　　　 PUSH　 EAX
　　　 PUSH　 LParam
　　　 PUSH　 WParam
　　　 PUSH　 Message
　　　 MOV　　 EDX,ESP ;将堆栈中构造的记录TMessage指针传递给EDX
　　　 MOV　　 EAX,[ECX].Longint[4] ;传递Self指针给EAX，类中的Self指针也就是指向VMT入口地址
　　　 CALL　 [ECX].Pointer ;调用MainWndProc方法
　　　 ADD　　 ESP,12
　　　 POP　　 EAX
end;

function CalcJmpOffset(Src, Dest: Pointer): Longint;
begin
Result := Longint(Dest) - (Longint(Src) + 5);
end;

（注：上面出现的那些16进制代码其实就是些16进制的机器代码 $59=Pop ECX $E8=Call $E9=Jmp）

以上代码看起来有点乱，但综合起来看也很好理解！MakeObjectInstance实际上就是构建了一个Block链表

其结构看看记录TInstanceBlock的结构可知其结构如下：

Next//下一页指针
Code//Pop ECX和Jmp
WndProcPtr//和StdWndProc间的地址偏移
Instances//接下来是314个Instance链表

Instance链表通过记录TObjectInstance也很好理解其内容

Code//Call
Offset//地址偏移
Method//指向对象方法的指针（结合TMethod很好理解TWndMethod这类对象方法指针指向数据的结构）

好现在来把这个流程回顾一遍，Windows回调的是什么呢？其实是转到并执行一段动态生成的代码：先是执行Call offset ，根据偏移量转去执行Pop ECX，当然由于在Call这之前会将下一条指令入栈，所以这里弹出的就是指向对象方法的指针。接下来就是执行jmp [StdWndProc]，其中将堆栈中构造的记录TMessage指针赋给了EDX，而根据上面的解释结合TMethod去理解，很容易理解
MOV　　 EAX,[ECX].Longint[4] ;传递Self指针给EAX，类中的Self指针也就是指向VMT入口地址
CALL　 [ECX].Pointer ;调用MainWndProc方法

现在终于豁然开朗了，Windows消息就是这样被传递到了TWinControl.MainWndProc，相比MFC中的回调全局函数AfxWndProc来根据窗体句柄检索对应的对象指针的方法效率要高的多！VCL比MFC优秀的又一佐证！ ^_^

现在终于找到了VCL接收消息的方法MainWndProc

procedure TWinControl.MainWndProc(var Message: TMessage);
begin
try
　 try
　　 WindowProc(Message);//由于TControl创建实例时已经将FWindowProc指向WndProc，所以这里实际也就是调用WndProc
　 finally
　　 FreeDeviceContexts;
　　 FreeMemoryContexts;//调用FreeDeviceContexts和FreeMemoryContexts是为了保证VCL线程安全
　 end;
except
　 Application.HandleException(Self);
end;
end;

这里也不能忽略了TWinControl.WndProc

procedure TControl.WndProc(var Message: TMessage);
var
Form: TCustomForm;
KeyState: TKeyboardState;
WheelMsg: TCMMouseWheel;
begin
...
//省略以上的消息相关处理代码，研究某些特定消息时可自行查看
...
Dispatch(Message);//调用Dispatch处理
end;

接下来，先不急着查看Dispatch中的相应代码。想想看，忘了什么？

上面只是继承于TWinControl的有句柄的控件，那继承于TGraphicControl的没有句柄的控件是如何获得并处理消息的？下面以鼠标消息为例：

TWinControl.WndProc中有下面的代码：

case Message.Msg of
...
　 WM_MOUSEFIRST..WM_MOUSELAST://注1：下面再解释这段
　　 if IsControlMouseMsg(TWMMouse(Message)) then
　　 begin
　　　 { Check HandleAllocated because IsControlMouseMsg might have freed the
　　　　 window if user code executed something like Parent := nil. }
　　　 if (Message.Result = 0) and HandleAllocated then
　　　　 DefWindowProc(Handle, Message.Msg, Message.wParam, Message.lParam);
　　　 Exit;
　　 end;
...
end;
inherited WndProc(Message);//执行祖先类的WndProc方法

function TWinControl.IsControlMouseMsg(var Message: TWMMouse): Boolean;
var
Control: TControl;
P: TPoint;
begin
if GetCapture = Handle then
begin
　 Control := nil;
　 if (CaptureControl <> nil) and (CaptureControl.Parent = Self) then
　　 Control := CaptureControl;
end else
　 Control := ControlAtPos(SmallPointToPoint(Message.Pos), False);//这里通过ControlAtPos获得了鼠标所在控件
Result := False;
if Control <> nil then
begin
　 P.X := Message.XPos - Control.Left;
　 P.Y := Message.YPos - Control.Top;
　 Message.Result := Control.Perform(Message.Msg, Message.Keys, Longint(PointToSmallPoint(P)));//调用Perform方法发送消息给对应的实例
　 Result := True;
end;
end;

property WindowProc: TWndMethod read FWindowProc write FWindowProc;

function TControl.Perform(Msg: Cardinal; WParam, LParam: Longint): Longint;
var
Message: TMessage;
begin
Message.Msg := Msg;
Message.WParam := WParam;
Message.LParam := LParam;
Message.Result := 0;
if Self <> nil then WindowProc(Message);//由于TControl创建实例时已经将FWindowProc指向WndProc，所以这里实际也就是调用WndProc
Result := Message.Result;
end;

VCL中就是这样将消息分发给了那些继承于TGraphicControl的没有句柄的图形控件。

上面说的都是Windows消息（Windows Messages），似乎还应该说说两条经常用到的VCL中自定义消息：CM_MOUSEENTER，CM_MOUSELEAVE（CM = Short of Control Message）

它们是如何被处理的呢？还是看上面的（if not ProcessMessage(Msg) then Idle(Msg);），这两条不是Windows消息，所以会触发Idle

procedure TApplication.Idle(const Msg: TMsg);
var
Control: TControl;
Done: Boolean;
begin
Control := DoMouseIdle;//调用DoMouseIdle方法
...
end;

function TApplication.DoMouseIdle: TControl;
var
CaptureControl: TControl;
P: TPoint;
begin
GetCursorPos(P);
Result := FindDragTarget(P, True);//获取当前鼠标所停留在的控件
if (Result <> nil) and (csDesigning in Result.ComponentState) then
　 Result := nil;
CaptureControl := GetCaptureControl;
if FMouseControl <> Result then//判断以前记录的鼠标指针所指向的控件和现在所指向的控件是否相同
begin
　 if ((FMouseControl <> nil) and (CaptureControl = nil)) or
　　 ((CaptureControl <> nil) and (FMouseControl = CaptureControl)) then
　　 FMouseControl.Perform(CM_MOUSELEAVE, 0, 0);//发送消息CM_MOUSELEAVE给以前记录的鼠标指针所指向的控件
　 FMouseControl := Result;//记录当前鼠标指针所指向的控件
　 if ((FMouseControl <> nil) and (CaptureControl = nil)) or
　　 ((CaptureControl <> nil) and (FMouseControl = CaptureControl)) then
　　 FMouseControl.Perform(CM_MOUSEENTER, 0, 0);//发送消息CM_MOUSEENTER给鼠标指针现在所在的控件
end;
end;

function FindDragTarget(const Pos: TPoint; AllowDisabled: Boolean): TControl;
var
Window: TWinControl;
Control: TControl;
begin
Result := nil;
Window := FindVCLWindow(Pos);//这里返回的是TWinControl，是一个有句柄的控件
if Window <> nil then
begin
　 Result := Window;
　 Control := Window.ControlAtPos(Window.ScreenToClient(Pos), AllowDisabled);//鼠标所指向处可能还存在一继承于TGraphicControl的图形控件，而上面返回的只是其容器控件
　 if Control <> nil then Result := Control;//如果存在就返回用ControlAtPos所得到的控件
end;
end;

于是又转到了上面的TControl.Perform

现在所有的问题又都集中到了Dispatch的身上，消息是如何触发事件的处理方法的呢？

首先看条消息处理方法的申明：
procedure CMMouseEnter(var Message: TMessage); message CM_MOUSEENTER;

这实际可以认为是申明了一个动态方法，调用Dispatch实际上就是通过消息号在DMT（动态方法表）中找到相应的动态方法指针，然后执行

//上面已经提到了，寄存器EAX中是类的Self指针，即VMT入口地址，寄存器EDX中是指向记录Message的指针
procedure TObject.Dispatch(var Message);
asm
　 PUSH　 ESI
　 MOV　　 SI,[EDX] ;消息号，也就是记录TMessage中Msg的值，对应CM_MOUSEENTER就是$B013(45075)
　 OR　　 SI,SI
　 JE　　 @@default
　 CMP　　 SI,0C000H
　 JAE　　 @@default
　 PUSH　 EAX
　 MOV　　 EAX,[EAX] ;VMT入口地址
　 CALL　 GetDynaMethod ;调用GetDynaMethod查找
　 POP　　 EAX
　 JE　　 @@default ;在GetDynaMethod中如果找到会将标志位寄存器的值置为0，如果是1，表示未找到，执行跳转
　 MOV　　 ECX,ESI ;传递指针给ECX
　 POP　　 ESI
　 JMP　　 ECX ;跳转到ECX所指向的位置，也就完成了通过消息号调用CMMouseEnter的过程

@@default:
　 POP　　 ESI
　 MOV　　 ECX,[EAX]
　 JMP　　 dWord ptr [ECX].vmtDefaultHandler ;如果此控件和它的祖先类中都没有对应此消息号的处理方法,调用Defaulthandler
end;

procedure　　　 GetDynaMethod;
{　　　 function　　　 GetDynaMethod(vmt: TClass; selector: Smallint) : Pointer;　　　 }
asm
　　　 { ->　 EAX　　 vmt of class　　　　　 }
　　　 {　　　 SI　　 dynamic method index　 }
　　　 { <-　 ESI pointer to routine }
　　　 {　　　 ZF = 0 if found　　　　 }
　　　 {　　　 trashes: EAX, ECX　　　　　　　 }

　 PUSH　 EDI
　　　 XCHG　 EAX,ESI ;交换EAX和ESI的值，这之后ESI中为VMT入口地址，EAX为消息号，即对应动态方法的代号
　　　 JMP　　 @@haveVMT
@@outerLoop:
　　　 MOV　　 ESI,[ESI]
@@haveVMT:
　　　 MOV　　 EDI,[ESI].vmtDynamicTable ;尝试着将DMT的入口地址传递给EDI

　 TEST　 EDI,EDI ;通过EDI是否为0来判断是否存在DMT
　　　 JE　　 @@parent ;不存在跳转到父类继续
　　　 MOVZX　 ECX,word ptr [EDI] ;取[EDI]，即DMT的头两个字节的值传递给ECX，即动态方法的个数
　　　 PUSH　 ECX
　　　 ADD　　 EDI,2 ;地址加2,即跳过DMT中存储动态方法的个数的部分
　　　 REPNE　 SCASW ;EAX与EDI指向的数据按字依次比较，直到找到（ZF=1）或ECX=0为止
　　　 JE　　 @@found
　　　 POP　　 ECX
@@parent:
　　　 MOV　　 ESI,[ESI].vmtParent ;尝试获得父类
　　　 TEST　 ESI,ESI ;通过EDI是否为0来判断是否存在父类
　　　 JNE　　 @@outerLoop ;存在就跳转到@@outerLoop进行查找
　　　 JMP　　 @@exit ;退出

@@found:
　　　 POP　　 EAX
　　　 ADD　　 EAX,EAX
　　　 SUB　　 EAX,ECX　　　　 { this will always clear the Z-flag ! } ;这句的用途就上上面说到的将标志位ZF置0
　　　 MOV　　 ESI,[EDI+EAX*2-4] ;将获得的方法指针传递给ESI，理解这句先要对DMT结构的内容做些了解

@@exit:
　　　 POP　　 EDI
end;

在VCL中，DMT的结构是这样的，前2个字节储存了DMT中动态方法的个数n，然后是方法代号，共4*n字节，最后是方法指针，也是4*n字节！

这样就很好理解了，EDI-4就是当前方法代号所在地址，EDI-4+4*n=EDI+EAX*2-4（因为已经执行了一句ADD EAX,EAX，所以EAX=2*n）所以，[EDI+EAX*2-4]就是所找到了相应方法指针。

结合下面的

TNotifyEvent = procedure(Sender: TObject) of object;

FOnMouseEnter: TNotifyEvent;

property OnMouseEnter: TNotifyEvent read FOnMouseEnter write FOnMouseEnter;

procedure TXXX.CMMouseEnter(var Message: TMessage);
begin
inherited;
if Assigned(FOnMouseEnter) then
　 FOnMouseEnter(Self);
end;

在跳转到CMMouseEnter执行后，判断方法指针FOnMouseEnter是否是nil，如果不为空，就执行相应的事件处理方法！

通过以上的一个看似复杂的过程，我们这些用Delphi的开发人员只需要很简单的在类似
procedure TFormX.XXXMouseEnter(Sender: TObject);
begin
//
end;

(XXX.OnMouseEnter:=XXXMouseEnter;)

的过程中写两行简单的代码，就能很容易的实现所谓的事件驱动！