суббота, 2 ноября 2013 г.

Ещё про QueryInterface

Про меня - все всё поняли.

http://18delphi.blogspot.ru/2013/11/supports.html?showComment=1383353862701#c88813335274335154
"Странные вещи пишите Александр... Очень странные...
<-- Документация System.SysUtils.Supports
Indicates whether a given object or interface supports a specified interface. 

Call Supports to determine whether the object or interface specified by Instance, or the class specified by AClass, supports the interface identified by the IID parameter. If Instance supports the interface, Supports returns the interface as the Intf parameter and returns True. If AClass supports the interface, Supports does not return an interface, but still returns True. If the interface specified by IID is not supported, Supports returns False. 
--> 
Обратите внимание на упоминание в документации слов objects, class, instance.
Из документации явно следует, что SysUtils.Supports предназначена (задумывалась авторами) для проверки, поддерживает ли данный класс или объект (экземпляр класса) данный интерфейс. Иными словами: умеет ли *данный объект* «делать это»? Обратите внимание — объект, а не кто-то, кто как-то связан с этим объектом или кого можно получить, зная объект."

Ну меня дурака - положим "умный дядя научил".

Но вот незадача.

Других-то - не научил:

function TCustomForm.QueryInterface(const IID: TGUID; out Obj): HResult;
begin
  // Route the QueryInterface throught the DesignerHook first
  if (DesignerHook = nil) or (DesignerHook.QueryInterface(IID, Obj) <> 0) then
    Result := inherited QueryInterface(IID, Obj)
  else
    Result := 0;
end;
...
function TCorbaImplementation.QueryInterface(const IID: TGUID;
  out Obj): HResult;
begin
  if Assigned(FController) then
    Result := IObject(FController).QueryInterface(IID, Obj) else
    Result := ObjQueryInterface(IID, Obj);
end;
...
function TComponent.QueryInterface(const IID: TGUID; out Obj): HResult;
begin

  if FVCLComObject = nil then
  begin

    if GetInterface(IID, Obj) then Result := S_OK
    else Result := E_NOINTERFACE

  end
  else
    Result := IVCLComObject(FVCLComObject).QueryInterface(IID, Obj);

end;
....
function TCustomWebAppDataModule.QueryInterface(const IID: TGUID;
  out Obj): HResult;
begin
  if IsEqualGuid(IID, IGetWebAppComponents) then
    if Supports(AppServices, IGetWebAppComponents, Obj) then
    begin
      Result := S_OK;
      exit;
    end;
  Result := inherited QueryInterface(IID, Obj);
end;
...
function TCustomWebAppPageModule.QueryInterface(const IID: TGUID; out Obj): HResult;
begin
  if IsEqualGuid(IID, IGetWebAppComponents) then
    if Supports(AppServices, IGetWebAppComponents, Obj) then
    begin
      Result := S_OK;
      exit;
    end;
  Result := inherited QueryInterface(IID, Obj);
end;
...
function TXPInterfacedObject.QueryInterface(const IID: TGUID; out Obj): HResult;
begin

  if (FDelegator = nil) or FIntrospective then
    Result := inherited QueryInterface(IID, Obj)
  else
    Result := IInterface(FDelegator).QueryInterface(IID, Obj);

end;
....
function TNestedScope.QueryInterface(const IID: TGUID; out Obj): HResult;
begin
  Result := E_NOINTERFACE;
  if GetInterface(IID, Obj) then
    Result := S_OK
  else
    if Supports(Inner, IID, Obj) or Supports(Outer, IID, Obj) then
      Result := S_OK;
end;
....
function TVirtualObjectMemberInstance.QueryInterface(const IID: TGUID;
  out Obj): HResult;
begin
  // depending on the custom wrapper type, it returns the appropriate interfaces
  // that the virtual wrapper is supposed to support
  if ((IID = IValue) or (IID = IInvokable) or (IID = IArguments)) and
     (not Supports(GetCustomWrapper, IID)) then
    Result := E_NOINTERFACE
  else
    Result := inherited QueryInterface(IID, Obj);
end;
....
procedure TStyledWindowBorder.MouseMove(Shift: TShiftState; X, Y: Single);
var
  P: TPointF;
  Obj: IControl;
  SG: ISizeGrip;
  NewCursor: TCursor;
  CursorService: IFMXCursorService;
begin
  NewCursor := crDefault;
  TPlatformServices.Current.SupportsPlatformService(IFMXCursorService, IInterface(CursorService));
  FMousePos := PointF(X, Y);
  if Assigned(FCaptured) then
  begin
    if Assigned(CursorService) then
    begin
      if ((FCaptured.QueryInterface(ISizeGrip, SG) = 0) and Assigned(SG)) then
        CursorService.SetCursor(crSizeNWSE)
      else
        CursorService.SetCursor(FCaptured.Cursor);
    end;
    P := FCaptured.ScreenToLocal(PointF(FMousePos.X, FMousePos.Y));
    FCaptured.MouseMove(Shift, P.X, P.Y);
    Exit;
  end;

  Obj := ObjectAtPoint(FMousePos);
  if Assigned(Obj) then
  begin
    SetHovered(Obj);
    P := Obj.ScreenToLocal(PointF(FMousePos.X, FMousePos.Y));
    Obj.MouseMove(Shift, P.X, P.Y);
    if ((Obj.QueryInterface(ISizeGrip, SG) = 0) and Assigned(SG)) then
      NewCursor := crSizeNWSE
    else
      NewCursor := Obj.Cursor;
  end
  else
    SetHovered(nil);
  // set cursor
  if Assigned(CursorService) then
    CursorService.SetCursor(NewCursor);
  FDownPos := FMousePos;
end;
....
function TCommonCustomForm.QueryInterface(const IID: TGUID; out Obj): HResult;
begin
  // Route the QueryInterface through the Designer first
  if not Assigned(Designer) or (Designer.QueryInterface(IID, Obj) <> 0) then
    Result := inherited QueryInterface(IID, Obj)
  else
    Result := 0;
end;
....
function TServerEventDispatch.QueryInterface(const IID: TGUID; out Obj): HResult;
begin
  if GetInterface(IID, Obj) then
  begin
    Result := S_OK;
    Exit;
  end;
  if IsEqualIID(IID, FServer.FServerData^.EventIID) then
  begin
    GetInterface(IDispatch, Obj);
    Result := S_OK;
    Exit;
  end;
  Result := E_NOINTERFACE;
end;
....

2 комментария:

  1. Даже не знаю почему, но очень мало людей понимает природу интерфейсов Delphi "в байтах" (как ты любишь говорить). Для многих вообще большой новостью бывает то, что даже VCL с интерфейсами работает совсем не так, как они сами привыкли.

    ОтветитьУдалить
  2. Про "байты" это не я. Это Джоэл Спольски.

    http://russian.joelonsoftware.com/Articles/BacktoBasics.html

    "Основы" или "байты". Переводы просто разные.

    А вообще - да. Считаю полезным, чтобы программисты представляли себе "как это устроено внутри".

    ОтветитьУдалить