由VCL代码理解VCL的消息机制.doc

Delphi，一个非常优秀的开发工具，拥有强大的可视化开发环境、面向组件的快速开发模式、优秀的VCL类库、快速的代码编译器、强大的数据库和WEB开发能力、还有众多的第三方控件支持.（此处省略x千字，既然大家都知道了，不浪费口水了 _）说到VCL的优秀就不能不提到其对Windows消息及API的较全面和完美的封装，正因为如此开发者在大多数情况下甚至不需理会Windows消息处理的细节，而只需要写几行事件驱动代码即可！但如果做为开发人员你还是想对此做些了解的话，那么就继续，通过VCL代码本身来体会VCL中的消息处理机制。(以下代码取自Delphi 6)说到VCL中的消息处理就不能不提到TApplication，Windows会为每一个当前运行的程序建立一个消息队列，用来完成用户与程序的交互，正是通过Application完成了对Windows消息的集中处理！首先通过Application.Run进入消息循环进行消息的处理，其中调用了HandleMcedure 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;endelse 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.CreateFObjectInstance := Classes.MakeObjectInstance(MainWndProc);找到关键所在了，也许有些朋友对MakeObjectInstance这个函数很熟了，它的作用就是将一个成员过程转换为标准过程。绕了个圈子？为什么呢？很简单，因为窗体成员过程包括一隐含参数传递Self指针，所以需要转化为标准过程。const InstanceCount = 313;/这个不难理解吧？314*13+10=4092，再大的话，记录TInstanceBlock的大小就超过了下面定义的PageSizetype 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: array1.2 of Byte; WndProcPtr: Pointer; Instances: array0.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.Longint4 ;传递Self指针给EAX，类中的Self指针也就是指向VMT入口地址 CALL ECX.Pointer ;调用MainWndProc方法 ADD ESP,12 POP EAXend;function CalcJmpOffset(Src, Dest: Pointer): Longint;begin Result := Longint(Dest) - (Longint(Src) + 5);end;function MakeObjectInstance(Method: TWndMethod): Pointer;const BlockCode: array1.2 of Byte = ( $59, POP ECX $E9); JMP StdWndProc PageSize = 4096;var Block: PInstanceBlock; Instance: PObjectInstance;begin if InstFreeList = nil then begin Block := VirtualAlloc(nil, PageSize, MEM_COMMIT, PAGE_EXECUTE_READWRITE);/分配虚拟内存，并指定这块内存为可读写并可执行 Block.Next := InstBlockList; Move(BlockCode, Block.Code, SizeOf(BlockCode); Block.WndProcPtr := Pointer(CalcJmpOffset(Block.Code2, StdWndProc); Instance := Block.Instances; repeat Instance.Code := $E8; CALL NEAR PTR Offset Instance.Offset := CalcJmpOffset(Instance, Block.Code); Instance.Next := InstFreeList; InstFreeList := Instance; Inc(Longint(Instance), SizeOf(TObjectInstance); until Longint(Instance) - Longint(Block) = SizeOf(TInstanceBlock); InstBlockList := Block; end; Result := InstFreeList; Instance := InstFreeList; InstFreeList := Instance.Next; Instance.Method := Method;end;（注：上面出现的那些16进制代码其实就是些16进制的机器代码 $59=Pop ECX $E8=Call $E9=Jmp）以上代码看起来有点乱，但综合起来看也很好理解！MakeObjectInstance实际上就是构建了一个Block链表其结构看看记录TInstanceBlock的结构可知其结构如下：Next/下一页指针Code/Pop ECX和JmpWndProcPtr/和StdWndProc间的地址偏移Instances/接下来是314个Instance链表Instance链表通过记录TObjectInstance也很好理解其内容Code/CallOffset/地址偏移Method/指向对象方法的指针（结合TMethod很好理解TWndMethod这类对象方法指针指向数据的结构）好现在来把这个流程回顾一遍，Windows回调的是什么呢？其实是转到并执行一段动态生成的代码：先是执行Call offset ，根据偏移量转去执行Pop ECX，当然由于在Call这之前会将下一条指令入栈，所以这里弹出的就是指向对象方法的指针。接下来就是执行jmp StdWndProc，其中将堆栈中构造的记录TMessage指针赋给了EDX，而根据上面的解释结合TMethod去理解，很容易理解MOV EAX,ECX.Longint4 ;传递Self指针给EAX，类中的Self指针也就是指向VMT入口地址CALL ECX.Pointer ;调用MainWndProc方法现在终于豁然开朗了，Windows消息就是这样被传递到了TWinControl.MainWndProc，相比MFC中的回调全局函数AfxWndProc来根据窗体句柄检索对应的对象指针的方法效率要高的多！VCL比MFC优秀的又一佐证！ _现在终于找到了VCL接收消息的方法MainWndProcprocedure 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.WndProcprocedure 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) thenbegin Check HandleAllocated because IsControlMouseMsg might have freed thewindow if user code executed something like Parent := nil. if (Message.Result = 0) and HandleAllocated thenDefWindowProc(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消息，所以会触发Idleprocedure 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);asmPUSH ESIMOV SI,EDX ;消息号，也就是记录TMessage中Msg的值，对应CM_MOUSEENTER就是$B013(45075)OR SI,SIJE defaultCMP SI,0C000HJAE defaultPUSH EAXMOV EAX,EAX ;VMT入口地址CALL GetDynaMethod ;调用GetDynaMethod查找POP EAXJE default ;在GetDynaMethod中如果找到会将标志位寄存器的值置为0，如果是1，表示未找到，执行跳转MOV ECX,ESI ;传递指针给ECXPOP ESIJMP ECX ;跳转到ECX所指向的位置，也就完成了通过消息号调用CMMouseEnter的过程default:POP ESIMOV ECX,EAXJMP 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 EDIXCHG EAX,ESI ;交换EAX和ESI的值，这之后ESI中为VMT入口地址，EAX为消息号，即对应动态方法的代号JMP haveVMTouterLoop:MOV ESI,ESIhaveVMT:MOV EDI,ESI.vmtDynamicTable ;尝试着将DMT的入口地址传递给EDITEST EDI,EDI ;通过EDI是否为0来判断是否存在DMTJE parent ;不存在跳转到父类继续MOVZX ECX,word ptr EDI ;取EDI，即DMT的头两个字节的值传递给ECX，即动态方法的个数PUSH ECXADD EDI,2 ;地址加2,即跳过DMT中存储动态方法的个数的部分REPNE SCASW ;EAX与EDI指向的数据按字依次比较，直到找到（ZF=1）或ECX=0为止JE foundPOP ECXparent:MOV ESI,ESI.vmtParent ;尝试获得父类TEST ESI,ESI ;通过EDI是否为0来判断是否存在父类JNE outerLoop ;存在就跳转到outerLoop进行查找JMP exit ;退出found:POP EAXADD EAX,EAXSUB EAX,ECX this will always clear the Z-flag ! ;这句的用途就上上面说到的将标志位ZF置0MOV ESI,EDI+EAX*2-4 ;将获得的方法指针传递给ESI，理解这句先要对DMT结构的内容做些了解exit:POP EDIend;在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);begininherited;if Assigned(FOnMouseEnter) thenFOnMouseEnter(Self);end;在跳转到CMMouseEnter执行后，判断方法指针FOnMouseEnter是否是nil，如果不为空，就执行相应的事件处理方法！通过以上的一个看似复杂的过程，我们这些用Delphi的开发人员只需要很简单的在类似procedure TFormX.XXXMouseEnter(Sender: TObject);begin/end;(XXX.OnMouseEnter:=XXXMouseEnter;)的过程中写两行简单的代码，就能很容易的实现所谓的事件驱动！很多人也许只看中结果，并不在乎过程，从这不能简单评论谁对谁错，对于这些知识的了解是否有用，我们每个人都可以自己去体会继续消息机制那么知道了这些，究竟VCL是怎样调用CreateWnd呢我从Application.Initialize;Application.CreateForm(TMainForm, MainForm);Application.Run;一开始调试记录一下主要的过程当Application.CreateForm时执行到constructor TCustomForm.Create(AOwner: TComponent);beginGlobalNameSpace.BeginWrite;tryCreateNew(AOwner);if (ClassType TForm) and not (csDesigning in ComponentState) thenbeginInclude(FFormState, fsCreating);tryif not InitInheritedComponent(Self, TForm) thenraise EResNotFound.CreateFmt(SResNotFound, ClassName);finallyExclude(FFormState, fsCreating);end;if OldCreateOrder then DoCreate;end;finallyGlobalNameSpace.EndWrite;end;end;关键一处InitInheritedComponent由调试看出的调用顺序，关键的部分InitInheritedComponentInternalReadComponentRes /读取窗体资源，也就是准备根据DFM描述建立窗体控件TResourceStream.ReadComponentTReader.ReadRootComponentTCustomForm.ReadState TComponent.ReadStateTReader.ReadDataTReader.ReadDataInner这个比较让人感兴趣的procedure TReader.ReadDataInner(Instance: TComponent);varOldParent, OldOwner: TComponent;beginwhile not EndOfList do ReadProperty(Instance);ReadListEnd;OldParent := Parent;OldOwner := Owner;Parent := Instance.GetChildParent;tryOwner := Instance.GetChildOwner;if not Assigned(Owner) then Owner := Root;while not EndOfList do ReadComponent(nil);ReadListEnd;finallyParent := OldParent;Owner := OldOwner;end;end;这句ReadProperty(Instance);就是读取MainForm上的属性并设置属性值ReadComponent就是读取MainForm上的控件描述并建立之并设置相应的控件属性值这些操作做完之后，回到procedure TCustomForm.ReadState(Reader: TReader);varNewTextHeight: Integer;Scaled: Boolean;beginDisableAlign;tryFClientWidth := 0;FClientHeight := 0;FTextHeight := 0;Scaled := False;FOldCreateOrder := not ModuleIsCpp;inherited ReadState(Reader); /回到这if (FPixelsPerInch 0) and (FTextHeight 0) thenbeginif (sfFont in ScalingFlags) and (FPixelsPerInch Screen.PixelsPerInch) thenFont.Height := MulDiv(Font.Height, Screen.PixelsPerInch, FPixelsPerInch);FPixelsPerInch := Screen.PixelsPerInch;NewTextHeight := GetTextHeight;if FTextHeight NewTextHeight thenbeginScaled := True;ScaleScrollBars(NewTextHeight, FTextHeight);ScaleControls(NewTextHeight, FTextHeight);if sfWidth in ScalingFlags thenFClientWidth := MulDiv(FClientWidth, NewTextHeight, FTextHeight);if sfHeight in ScalingFlags thenFClientHeight := MulDiv(FClientHeight, NewTextHeight, FTextHeight);if sfDesignSize in ScalingFlags thenbeginFDesignSize.X := MulDiv(FDesignSize.X, NewTextHeight, FTextHeight);FDesignSize.Y := MulDiv(FDesignSize.Y, NewTextHeight, FTextHeight);end;end;end;if FClientWidth 0 then inherited ClientWidth := FClientWidth;if FClientHeight 0 then inherited ClientHeight := FClientHeight;ScalingFlags := ;if not Scaled thenbegin Forces all ScalingFlags to ScaleScrollBars(1, 1);ScaleControls(1, 1);end;Perform(CM_PARENTBIDIMODECHANGED, 0, 0);finallyEnableAlign;end;end;注意：我这边调试了好几遍窗体的创建就在这个属性设置NewTextHeight := GetTextHeight;调用GetTextHeight,跟踪function TCustomForm.GetTextHeight: Integer;beginResult := Canvas.TextHeight(0);end;到达function TCanvas.TextHeight(const Text: string): Integer;beginResult := TextExtent(Text).cY;end;function TCanvas.TextExtent(const Text: string): TSize;beginRequiredState(csHandleValid, csFontValid);Result.cX := 0;Result.cY := 0;Windows.GetTextExtentPoint32(FHandle, PChar(Text), Length(Text), Result);end;procedure TCanvas.RequiredState(ReqState: TCanvasState);varNeededState: TCanvasState;beginNeededState := ReqState - State;if NeededState thenbeginif csHandleValid in NeededState thenbeginCreateHandle;if FHandle = 0 thenraise EInvalidOperation.CreateRes(SNoCanvasHandle);end;if csFontValid in NeededState then CreateFont;if csPenValid in NeededState then CreatePen;if csBrushValid in NeededState then CreateBrush;State := State + NeededState;end;end;好了，主角慢慢快出来了由于NeededState包含csHandleValid一句所以procedure TControlCanvas.CreateHandle;beginif FControl = nil then inherited CreateHandle elsebeginif FDeviceContext = 0 thenbeginwith CanvasList.LockList dotryif Count = CanvasListCacheSize then FreeDeviceContext;FDeviceContext := FControl.GetDeviceContext(FWindowHandle);Add(Self);finallyCanvasList.UnlockList;end;end;Handle := FDeviceContext;UpdateTextFlags;end;end;继续执行到了function TWinControl.GetDeviceContext(var WindowHandle: HWnd): HDC;beginif csDesigning in ComponentState thenResult := GetDCEx(Handle, 0, DCX_CACHE or DCX_CLIPSIBLINGS)elseResult := GetDC(Handle);if Result = 0 then raise EOutOfResources.CreateRes(SWindowDCError);WindowHandle := FHandle;end;执行到了Result := GetDC(Handle);Handle为TWinControl的属性这样定义的property Handle: HWnd read GetHandle;所以function TWinControl.GetHandle: HWnd;beginHandleNeeded;Result := FHandle;end;procedure TWinControl.HandleNeeded;beginif FHandle = 0 thenbeginif Parent nil then Parent.HandleNeeded;CreateHandle;end;end;而这时窗体没有创建FHandle = 0;执行到CreateHandleprocedure TWinControl.CreateHandle;varI: Integer;beginif FHandle = 0 thenbeginCreateWnd;SetProp(FHandle, MakeIntAtom(ControlAtom), THandle(Self);SetProp(FHandle, MakeIntAtom(WindowAtom), THandl