学步园

TControl = class(TComponent)

 private

procedure WMLButtonDblClk(var Message: TWMLButtonDblClk); message WM_LBUTTONDBLCLK;

    procedure WMRButtonDblClk(var Message: TWMRButtonDblClk); message WM_RBUTTONDBLCLK;

procedure WMMButtonDblClk(var Message: TWMMButtonDblClk); message WM_MBUTTONDBLCLK;

...

end;

procedure TControl.WMLButtonDown(var Message: TWMLButtonDown);

begin

  SendCancelMode(Self);

  inherited;

  if csCaptureMouse in ControlStyle then MouseCapture := True;

  if csClickEvents in ControlStyle then Include(FControlState, csClicked);

  DoMouseDown(Message, mbLeft, []);

end;

procedure TControl.DoMouseDown(var Message: TWMMouse; Button: TMouseButton;

  Shift: TShiftState);

begin

  if not (csNoStdEvents in ControlStyle) then

    with Message do

      if (Width > 32768) or (Height > 32768) then

        with CalcCursorPos do

          MouseDown(Button, KeysToShiftState(Keys) + Shift, X, Y)

      else

        MouseDown(Button, KeysToShiftState(Keys) + Shift, Message.XPos, Message.YPos);

end;

声明：

   procedure MouseDown(Button: TMouseButton; Shift: TShiftState;

      X, Y: Integer); dynamic;

procedure TControl.MouseDown(Button: TMouseButton;

  Shift: TShiftState; X, Y: Integer);

begin

  if Assigned(FOnMouseDown) then FOnMouseDown(Self, Button, Shift, X, Y);

end;

VCL Framework中最后对于未处理的窗口消息的处理函数是DefaultHandler。在传统的Windows程序设计中DefWindowProc这个Windows API是窗口回调函数调用来处理窗口应用程序不处理的窗口消息的处理函数。在VCL Framework中使用VCL组件处理其它VCL组件不处理的窗口消息，以提供VCL Framework一些基础的功能。对于DefaultHandler最后仍然不处理的窗口消息，DefaultHandler最后也是调用Windows Api的DefWindowProc来处理。

TObject = class

procedure DefaultHandler(var Message); virtual;

end;

TObject以虚拟方法定义DefaultHandler就是为了让VCL Framework中的派生类能够重载DefaultHandler以便让VCL组件能够在把未处理的窗口消息转回给DefWindowProc之前有机会进行处理，以便让特定VCL组件能够提供基础服务，因此在TObject中的虚拟方法DefaultHandler是一个空白的方法：

procedure TObject.DefaultHandler(var Message);

begin

end;

其目的在于提供一个Placeholder，让派生类重载使用。而在TWinControl类中提供了最重要的DefaultHandler重载程序代码。TWinControl.DefaultHandler为所有从TWinControl类继承的VCL组件提供了通用的实现程序代码，以提供基础的服务并且调用DefWindowProc处理最后VCL Framework不处理的窗口消息：

procedure TWinControl.DefaultHandler(var Message);

begin

  if FHandle <> 0 then

  begin

    with TMessage(Message) do

    begin

      if (Msg = WM_CONTEXTMENU) and (Parent <> nil) then

      begin

        Result := Parent.Perform(Msg, WParam, LParam);

        if Result <> 0 then Exit;

      end;

      case Msg of

        WM_CTLCOLORMSGBOX..WM_CTLCOLORSTATIC:

          Result := SendMessage(LParam, CN_BASE + Msg, WParam, LParam);

        CN_CTLCOLORMSGBOX..CN_CTLCOLORSTATIC:

          begin

            SetTextColor(WParam, ColorToRGB(FFont.Color));

            SetBkColor(WParam, ColorToRGB(FBrush.Color));

            Result := FBrush.Handle;

          end;

      else

        if Msg = RM_GetObjectInstance then

          Result := Integer(Self)

        else

          Result := CallWindowProc(FDefWndProc, FHandle, Msg, WParam, LParam);//调用DefWindowProc

      end;

      if Msg = WM_SETTEXT then

        SendDockNotification(Msg, WParam, LParam);

    end;

  end

  else

    inherited DefaultHandler(Message);

end;

TWinControl只处理VCL自定义的消息，TCustomForm也重载了TWinControl的DefaultHandler，以便为TForm提供额外需要的功能。

TCustomForm = class(TScrollingWinControl)

  ...

 public

procedure DefaultHandler(var Message); override;

end;

procedure TCustomForm.DefaultHandler(var Message);

begin

  if ClientHandle <> 0 then

    with TMessage(Message) do

      if Msg = WM_SIZE then

        Result := DefWindowProc(Handle, Msg, wParam, lParam) else

        Result := DefFrameProc(Handle, ClientHandle, Msg, wParam, lParam)

  else

    inherited DefaultHandler(Message)

end;

Dispatcher设计模式

Dispatcher设计模式是TObject使用的分派消息设计模式，其主要的功能是提供自动消息分派并且把应用程序的执行权自动转移到相对的消息处理函数。

P257再看看回头

type

  IInterface = interface

    ['{00000000-0000-0000-C000-000000000046}']

    function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;

    function _AddRef: Integer; stdcall;

    function _Release: Integer; stdcall;

  end;

在Object Pascal中接口服务是由类来实现的。由于在接口的程序区块中只有服务的声明而没有任何存取限制符（Accessor）的声明，即private、protect或是public，因此当类实现接口时可以结合类的存取限制符来限制接口之中的服务。

类名=class(父类，实现接口1，实现接口2，...)

接口只是服务的声明，而真正的服务是由对象提供，因此一般来说接口不应该控制对象的生命周期，也不应该会造成内存泄漏，因为接口说穿了只是一个指针。接口也不应该会造成存取违规错误，因为只要实现接口的对象存在就可以正确地使用接口。

在日常的开发应用中，对象的生命周期可分为两种类型：

·对象生命周期掌握在他人手中

·对象生命周期掌握在程序员手中

·对象生命周期掌握在他人手中

在COM中当程序员使用COM　API或是Delphi提供的CreateComObject/CreateOleObject/CreateRemoteComObject等方法创建了COM对象之后，创建的COM对象的生命周期是控制在COM的执行环境手中的。程序员只能遵照COM的规范来使用COM对象，最后释放COM对象的接口来建议COM的执行环境释放COM对象。不过当程序员建议COM的执行环境释放COM对象时，COM的执行环境并不一定会马上释放，而会在考虑许多的情形后才决定是否释放COM对象，其中最重要的条件是COM接口的引用计数值是否为０。

在这种对象生命周期由他人控制的应用中，必须有一种方式让客户端来帮助执行环境一起正确地管理对象生命周期，通常使用的机制就是接口和Proxy/Stub，COM使用了接口而EJB则使用Stub。

由于在这种对象生命周期由他人控制的应用中对象可能会因为客户端没有正确地遵照使用规范因此造成执行环境不能释放对象而形成内存泄漏，因此读者只要记住在这种应用中切实遵照使用规范就不会造成内存泄漏错误。

不过在这种情形中很可能发生的错误就是存取违规错误，这个意思是指由于客户端以接口/Proxy来建议对象释放的，因此如果客户端不小心额外释放了接口/Proxy，就会造成执行环境过早释放对象而造成其他客户端存取违规错误。

·对象生命周期掌握在程序员手中

另一种情形是实现接口的对象完全掌握在程序的代码中，那么我们可以更简化使用接口可能产生的问题，那就是程序员只要思考对象本身的生命周期即可，完全不须多虑接口的影响，因为在这种应用中本来就不应该让接口来干扰对象的生命周期。这种应用应该注重的是接口的服务而不是接口的引用计数机制，而且由于对象是掌握在程序员手中，因此最后只要释放对象即可，接口只是指针，不会造成内存泄漏。如果程序又把接口的引用计数值引入这种应用中，那么反而会造成存取违规错误。

所谓使用接口委托是指声明实现接口的类在接受客户端调用时，是使用内部的一个其他接口变量来调用真正提供服务的接口。而使用类对象委托则是调用内部的一个其他对象变量来调用真正提供服务的接口。

TInterfacedObject = class(TObject, IInterface)

  protected

    FRefCount: Integer;

    function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;

    function _AddRef: Integer; stdcall;

    function _Release: Integer; stdcall;

  public

    procedure AfterConstruction; override;

    procedure BeforeDestruction; override;

    class function NewInstance: TObject; override;

    property RefCount: Integer read FRefCount;

  end;

function TInterfacedObject.QueryInterface(const IID: TGUID; out Obj): HResult;

begin

  if GetInterface(IID, Obj) then

    Result := 0

  else

    Result := E_NOINTERFACE;

end;

function TInterfacedObject._AddRef: Integer;

begin

  Result := InterlockedIncrement(FRefCount);

end;

function TInterfacedObject._Release: Integer;

begin

  Result := InterlockedDecrement(FRefCount);

  if Result = 0 then

    Destroy;

end;

回传对象本身

IInterfaceComponentReference = interface

    ['{E28B1858-EC86-4559-8FCD-6B4F824151ED}']

    function GetComponent: TComponent;

  end;

TComponent = class(TPersistent, IInterface, IInterfaceComponentReference)

  private

...

function IInterfaceComponentReference.GetComponent = IntfGetComponent;

function IntfGetComponent: TComponent;

end;

function TComponent.IntfGetComponent: TComponent;

begin

  Result := Self;

end;