Delphi 2007中的Duck键入（续）？

这是对此的后续行动

我根据贴出的被接受的答案改进了我的要求

My*.dpr文件：

program DuckD11;

{$APPTYPE CONSOLE}

uses
  SysUtils,
  uDuckTyping in 'uDuckTyping.pas',
  uBirds in 'uBirds.pas';

procedure DoSomething(AObject: TObject);
begin
  Duck(AObject).Quack;
end;

var
  Bird: TBird;
  Ganagana: TGanagana;
  Canard: TCanard;
begin
  Writeln('Duck typing :');
  Writeln;

  Bird := TBird.Create('Bird');
  try
    DoSomething(Bird);
  finally
    Bird.Free;
  end;

  Ganagana := TGanagana.Create;
  try
    DoSomething(Ganagana);
  finally
    Ganagana.Free;
  end;

  Canard := TCanard.Create;
  try
    DoSomething(Canard);
  finally
    Canard.Free;
  end;

  Readln;
end.

unit uBirds;

interface

uses
  SysUtils;

type
  {$METHODINFO ON}
  TBird = class
  private
    FName: string;
  public
    constructor Create(AName: string);
    procedure Quack;
  end;

  TGanagana = class
  private
    const cName = 'Ganagana';
  public
    procedure Quack;
  end;

  TCanard = class
  private
    const cName = 'Canard';
  public
    procedure Quack;
  end;

  {$METHODINFO OFF}

implementation

{ TBird }

constructor TBird.Create(AName: string);
begin
  FName := AName;
end;

procedure TBird.Quack;
begin
  Writeln(Format('  %s->Quack',[Self.FName]));
end;

{ TGanagana }

procedure TGanagana.Quack;
begin
  Writeln(Format('  %s=>Quack',[Self.cName]));
end;

{ TCanard }

procedure TCanard.Quack;
begin
  Writeln(Format('  %s::Quack',[Self.cName]));
end;

end.

unit uDuckTyping;

interface

type
  IDuck = interface
    ['{41780389-7158-49F7-AAA5-A4ED5AE2699E}']
    procedure Quack;
  end;

function Duck(AObject: TObject): IDuck;

implementation

uses
  ObjAuto;

type
  TDuckObject = class(TInterfacedObject, IDuck)
  private
    FObj: TObject;

    // ???

  protected
      procedure Quack;
  public
    constructor Create(AObject: TObject);
  end;

function Duck(AObject: TObject): IDuck;
begin
  Result := TDuckObject.Create(AObject);
end;

{ TDuckObject }

constructor TDuckObject.Create(AObject: TObject);
begin
  FObj := AObject;

  // ???
end;

procedure TDuckObject.Quack;
begin
  // ???
end;

end.

uBirds.pas列表：

program DuckD11;

{$APPTYPE CONSOLE}

uses
  SysUtils,
  uDuckTyping in 'uDuckTyping.pas',
  uBirds in 'uBirds.pas';

procedure DoSomething(AObject: TObject);
begin
  Duck(AObject).Quack;
end;

var
  Bird: TBird;
  Ganagana: TGanagana;
  Canard: TCanard;
begin
  Writeln('Duck typing :');
  Writeln;

  Bird := TBird.Create('Bird');
  try
    DoSomething(Bird);
  finally
    Bird.Free;
  end;

  Ganagana := TGanagana.Create;
  try
    DoSomething(Ganagana);
  finally
    Ganagana.Free;
  end;

  Canard := TCanard.Create;
  try
    DoSomething(Canard);
  finally
    Canard.Free;
  end;

  Readln;
end.

unit uBirds;

interface

uses
  SysUtils;

type
  {$METHODINFO ON}
  TBird = class
  private
    FName: string;
  public
    constructor Create(AName: string);
    procedure Quack;
  end;

  TGanagana = class
  private
    const cName = 'Ganagana';
  public
    procedure Quack;
  end;

  TCanard = class
  private
    const cName = 'Canard';
  public
    procedure Quack;
  end;

  {$METHODINFO OFF}

implementation

{ TBird }

constructor TBird.Create(AName: string);
begin
  FName := AName;
end;

procedure TBird.Quack;
begin
  Writeln(Format('  %s->Quack',[Self.FName]));
end;

{ TGanagana }

procedure TGanagana.Quack;
begin
  Writeln(Format('  %s=>Quack',[Self.cName]));
end;

{ TCanard }

procedure TCanard.Quack;
begin
  Writeln(Format('  %s::Quack',[Self.cName]));
end;

end.

unit uDuckTyping;

interface

type
  IDuck = interface
    ['{41780389-7158-49F7-AAA5-A4ED5AE2699E}']
    procedure Quack;
  end;

function Duck(AObject: TObject): IDuck;

implementation

uses
  ObjAuto;

type
  TDuckObject = class(TInterfacedObject, IDuck)
  private
    FObj: TObject;

    // ???

  protected
      procedure Quack;
  public
    constructor Create(AObject: TObject);
  end;

function Duck(AObject: TObject): IDuck;
begin
  Result := TDuckObject.Create(AObject);
end;

{ TDuckObject }

constructor TDuckObject.Create(AObject: TObject);
begin
  FObj := AObject;

  // ???
end;

procedure TDuckObject.Quack;
begin
  // ???
end;

end.

我尝试编码uDuckTyping.pas:

program DuckD11;

{$APPTYPE CONSOLE}

uses
  SysUtils,
  uDuckTyping in 'uDuckTyping.pas',
  uBirds in 'uBirds.pas';

procedure DoSomething(AObject: TObject);
begin
  Duck(AObject).Quack;
end;

var
  Bird: TBird;
  Ganagana: TGanagana;
  Canard: TCanard;
begin
  Writeln('Duck typing :');
  Writeln;

  Bird := TBird.Create('Bird');
  try
    DoSomething(Bird);
  finally
    Bird.Free;
  end;

  Ganagana := TGanagana.Create;
  try
    DoSomething(Ganagana);
  finally
    Ganagana.Free;
  end;

  Canard := TCanard.Create;
  try
    DoSomething(Canard);
  finally
    Canard.Free;
  end;

  Readln;
end.

unit uBirds;

interface

uses
  SysUtils;

type
  {$METHODINFO ON}
  TBird = class
  private
    FName: string;
  public
    constructor Create(AName: string);
    procedure Quack;
  end;

  TGanagana = class
  private
    const cName = 'Ganagana';
  public
    procedure Quack;
  end;

  TCanard = class
  private
    const cName = 'Canard';
  public
    procedure Quack;
  end;

  {$METHODINFO OFF}

implementation

{ TBird }

constructor TBird.Create(AName: string);
begin
  FName := AName;
end;

procedure TBird.Quack;
begin
  Writeln(Format('  %s->Quack',[Self.FName]));
end;

{ TGanagana }

procedure TGanagana.Quack;
begin
  Writeln(Format('  %s=>Quack',[Self.cName]));
end;

{ TCanard }

procedure TCanard.Quack;
begin
  Writeln(Format('  %s::Quack',[Self.cName]));
end;

end.

unit uDuckTyping;

interface

type
  IDuck = interface
    ['{41780389-7158-49F7-AAA5-A4ED5AE2699E}']
    procedure Quack;
  end;

function Duck(AObject: TObject): IDuck;

implementation

uses
  ObjAuto;

type
  TDuckObject = class(TInterfacedObject, IDuck)
  private
    FObj: TObject;

    // ???

  protected
      procedure Quack;
  public
    constructor Create(AObject: TObject);
  end;

function Duck(AObject: TObject): IDuck;
begin
  Result := TDuckObject.Create(AObject);
end;

{ TDuckObject }

constructor TDuckObject.Create(AObject: TObject);
begin
  FObj := AObject;

  // ???
end;

procedure TDuckObject.Quack;
begin
  // ???
end;

end.

我的问题：

program DuckD11;

{$APPTYPE CONSOLE}

uses
  SysUtils,
  uDuckTyping in 'uDuckTyping.pas',
  uBirds in 'uBirds.pas';

procedure DoSomething(AObject: TObject);
begin
  Duck(AObject).Quack;
end;

var
  Bird: TBird;
  Ganagana: TGanagana;
  Canard: TCanard;
begin
  Writeln('Duck typing :');
  Writeln;

  Bird := TBird.Create('Bird');
  try
    DoSomething(Bird);
  finally
    Bird.Free;
  end;

  Ganagana := TGanagana.Create;
  try
    DoSomething(Ganagana);
  finally
    Ganagana.Free;
  end;

  Canard := TCanard.Create;
  try
    DoSomething(Canard);
  finally
    Canard.Free;
  end;

  Readln;
end.

unit uBirds;

interface

uses
  SysUtils;

type
  {$METHODINFO ON}
  TBird = class
  private
    FName: string;
  public
    constructor Create(AName: string);
    procedure Quack;
  end;

  TGanagana = class
  private
    const cName = 'Ganagana';
  public
    procedure Quack;
  end;

  TCanard = class
  private
    const cName = 'Canard';
  public
    procedure Quack;
  end;

  {$METHODINFO OFF}

implementation

{ TBird }

constructor TBird.Create(AName: string);
begin
  FName := AName;
end;

procedure TBird.Quack;
begin
  Writeln(Format('  %s->Quack',[Self.FName]));
end;

{ TGanagana }

procedure TGanagana.Quack;
begin
  Writeln(Format('  %s=>Quack',[Self.cName]));
end;

{ TCanard }

procedure TCanard.Quack;
begin
  Writeln(Format('  %s::Quack',[Self.cName]));
end;

end.

unit uDuckTyping;

interface

type
  IDuck = interface
    ['{41780389-7158-49F7-AAA5-A4ED5AE2699E}']
    procedure Quack;
  end;

function Duck(AObject: TObject): IDuck;

implementation

uses
  ObjAuto;

type
  TDuckObject = class(TInterfacedObject, IDuck)
  private
    FObj: TObject;

    // ???

  protected
      procedure Quack;
  public
    constructor Create(AObject: TObject);
  end;

function Duck(AObject: TObject): IDuck;
begin
  Result := TDuckObject.Create(AObject);
end;

{ TDuckObject }

constructor TDuckObject.Create(AObject: TObject);
begin
  FObj := AObject;

  // ???
end;

procedure TDuckObject.Quack;
begin
  // ???
end;

end.

我想用

• ObjAuto.GetMethodInfo以确定是否存在包装的江湖郎中方法
• ObjAuto.ObjectInvoke调用包装的江湖郎中方法

---

如何完成代码？

经过多次尝试后，我终于让代码正常工作：

uDucktyping.pas单元中的修改：

program DuckD11;

{$APPTYPE CONSOLE}

uses
  SysUtils,
  uDuckTyping in 'uDuckTyping.pas',
  uBirds in 'uBirds.pas';

procedure DoSomething(AObject: TObject);
begin
  Duck(AObject).Quack;
end;

var
  Bird: TBird;
  Ganagana: TGanagana;
  Canard: TCanard;
begin
  Writeln('Duck typing :');
  Writeln;

  Bird := TBird.Create('Bird');
  try
    DoSomething(Bird);
  finally
    Bird.Free;
  end;

  Ganagana := TGanagana.Create;
  try
    DoSomething(Ganagana);
  finally
    Ganagana.Free;
  end;

  Canard := TCanard.Create;
  try
    DoSomething(Canard);
  finally
    Canard.Free;
  end;

  Readln;
end.

unit uBirds;

interface

uses
  SysUtils;

type
  {$METHODINFO ON}
  TBird = class
  private
    FName: string;
  public
    constructor Create(AName: string);
    procedure Quack;
  end;

  TGanagana = class
  private
    const cName = 'Ganagana';
  public
    procedure Quack;
  end;

  TCanard = class
  private
    const cName = 'Canard';
  public
    procedure Quack;
  end;

  {$METHODINFO OFF}

implementation

{ TBird }

constructor TBird.Create(AName: string);
begin
  FName := AName;
end;

procedure TBird.Quack;
begin
  Writeln(Format('  %s->Quack',[Self.FName]));
end;

{ TGanagana }

procedure TGanagana.Quack;
begin
  Writeln(Format('  %s=>Quack',[Self.cName]));
end;

{ TCanard }

procedure TCanard.Quack;
begin
  Writeln(Format('  %s::Quack',[Self.cName]));
end;

end.

unit uDuckTyping;

interface

type
  IDuck = interface
    ['{41780389-7158-49F7-AAA5-A4ED5AE2699E}']
    procedure Quack;
  end;

function Duck(AObject: TObject): IDuck;

implementation

uses
  ObjAuto;

type
  TDuckObject = class(TInterfacedObject, IDuck)
  private
    FObj: TObject;

    // ???

  protected
      procedure Quack;
  public
    constructor Create(AObject: TObject);
  end;

function Duck(AObject: TObject): IDuck;
begin
  Result := TDuckObject.Create(AObject);
end;

{ TDuckObject }

constructor TDuckObject.Create(AObject: TObject);
begin
  FObj := AObject;

  // ???
end;

procedure TDuckObject.Quack;
begin
  // ???
end;

end.

---

在类定义中添加为私有的字段

FQuackPMethodInfo: PMethodeInfoHeader;
FParamIndexes: array of Integer;
FParams: array of Variant;

---

在TDuckObject.Create实现中初始化FQuackPMethodInfo

FQuackPMethodInfo := GetMethodInfo(AObject, ShortString('Quack'));

if Assigned(FQuackPMethodInfo) then
  ObjectInvoke(FObj, FQuackPMethodInfo, FParamIndexes, FParams);

在FObj初始化语句之后追加

---

在TDuckObject.Quack实现中调用“Quack”

FQuackPMethodInfo := GetMethodInfo(AObject, ShortString('Quack'));

if Assigned(FQuackPMethodInfo) then
  ObjectInvoke(FObj, FQuackPMethodInfo, FParamIndexes, FParams);

---

你为什么不直接调用它，捕捉异常？我不得不笑，你要求使用动态键入，而现在你却不愿意使用它，并且用你唯一能做的方式（异常处理）处理后果。我只是尝试复制

Duck-typing

，就像Daniele Teti在DORM（DORM.utils.TDuckTypedList）中用D2007做的那样。他将trtti方法与Invoke结合使用（目标是Delphi 2010以后的产品）分为两步：1）提取方法Rtti并将其存储在某处，最终在缺少方法或签名不匹配的情况下引发异常2）稍后使用存储的Rtti调用具有适当参数的方法。我猜您在Delphi中进行基于IDispatch的处理，它与Delphi 2010以后的TrtiMethod存储是同态的。我认为您尝试做的与XE2中引入的TVirtualInterface类似。虽然对于这个简单的无参数方法来说很容易，但当您有多个带参数的方法时，这可能会变得更复杂。虽然duck类型基本上是适配器模式，但您所做的更像是一个特定的适配器（受制于IDuck）。@Stefan Glienke：您是对的，我的示例非常集中且有限：我必须研究如何正确处理带有参数的处理方法，并最终返回值。顺便说一句，你提到TVirtualInterface，我知道你已经做了一个备份，如果你能考虑一下这个问题吗？”Stefan Glienke：我仔细检查了代码> d夏普.Cual.PuxIsPaS／代码>，并非常欣赏它。对TVirtualInterface非常有能力。