ClassFactory ähnlich wie Spring Framework, Hilfe gesucht!

[Mavarik]

Hallo Zusammen!

Ich möchte in einer GlobalenListe einen Bezug vom Interface zu Klasse herstellen.

Delphi-Quellcode:

Unit MyFooImp;

Interface
Implementation

Uses MyContainer,MyInterfaces; // Defionition von IFoo

Type 
    TFoo = class(TInheritedObject,iFoo);
      Procedure bla; // bla bla
    end;

Initialization
  GlobalContainer.Registerclass<IFoo,TFoo>; // Dictionary
end.

Um dann an einer anderen Stelle:

Delphi-Quellcode:

Procedure DoFoo;
var
  Foo : IFoo;
begin
  Foo := GlobalContainer.GetClass<IFoo>;  // Result unterschiedlich IFoo & TObject
  Foo.Bla;
end;

Bei der Formfactory war das irgentwie kein Problem mit der Class of TForm, aber hier bekomme ich es einfach nicht hin, aus GlobalContainer.GetClass<IFoo> logisch TFoo.Create zu machen.

Hat jemand ne Idee?

[mkinzler]

Dann wäre doch DSPING etwas für dich, bzw. kannst du dort nachschauen, wie das dort gelöst wird.

[Mavarik]

Zitat von mkinzler:

Dann wäre doch DSPING etwas für dich, bzw. kannst du dort nachschauen, wie das dort gelöst wird.

emm tja kapiere es leider nicht was die da machen

[mkinzler]

http://code.google.com/p/delphi-spring-framework/

[Sir Rufo]

Damit geht das

Delphi-Quellcode:

unit Container;

interface

uses
  System.Generics.Collections;

type
  GlobalContainer = class
  private
    class var _ClassDict : TDictionary<TGUID, TClass>;
  protected
    class constructor Create;
    class destructor Destroy;
  public
    class procedure RegisterClass<TInterface : IInterface; TRegClass : class>;
    class function GetClass<T : IInterface> : T;
  end;

implementation

uses
  System.SysUtils,
  System.TypInfo;

{ GlobalContainer }

class constructor GlobalContainer.Create;
begin
  _ClassDict := TDictionary<TGUID, TClass>.Create;
end;

class destructor GlobalContainer.Destroy;
begin
  _ClassDict.Free;
end;

class function GlobalContainer.GetClass<T> : T;
var
  LGUID : TGUID;
  LClass : TClass;
  LObj : TObject;
begin
  LGUID := GetTypeData( TypeInfo( T ) ).Guid;
  if _ClassDict.ContainsKey( LGUID ) then
  begin
    LClass := _ClassDict.Items[LGUID];
    LObj := LClass.Create;
    Supports( LObj, LGUID, Result );
  end;
end;

class procedure GlobalContainer.RegisterClass<TInterface, TRegClass>;
var
  LGUID : TGUID;
begin
  LGUID := GetTypeData( TypeInfo( TInterface ) ).Guid;
  _ClassDict.AddOrSetValue( LGUID, TRegClass );
end;

end.

[Sir Rufo]

Wenn man auch noch das hier

Delphi-Quellcode:

type
  IFoo = interface
    ['{4C53C006-737E-4F3C-A424-D5A34335EC0C}']
    procedure Bar;
  end;

  TFoo = class( TInterfacedObject, IFoo )
  private
    procedure Bar;
  end;

  TAnotherFoo = class( TFoo )
  private
    procedure Bar;
  end;

  { TFoo }

procedure TFoo.Bar;
begin
  Writeln( Self.ClassName + '.Bar' );
end;

{ TAnotherFoo }

procedure TAnotherFoo.Bar;
begin
  Writeln( Self.ClassName + '.Bar' );
end;

procedure Test;
var
  LFoo : IFoo;
begin
  GlobalContainer.RegisterClass<IFoo, TFoo>;
  GlobalContainer.RegisterClass<IFoo, TAnotherFoo>( 'Another' );
  LFoo := GlobalContainer.GetClass<IFoo>;
  LFoo.Bar; // -> TFoo.Bar
  LFoo := GlobalContainer.GetClass<IFoo>( 'Another' );
  LFoo.Bar; // -> TAnotherFoo.Bar
end;

abgetütet haben will, dann so

Delphi-Quellcode:

unit Container;

interface

uses
  System.SysUtils,
  System.Generics.Collections;

type
  EContainerException = class( Exception );

  GlobalContainer = class
  private
    class var _ClassDict : TDictionary<string, TClass>;
  protected
    class constructor Create;
    class destructor Destroy;
  public
    class procedure RegisterClass<TInterface : IInterface; TRegClass : class>( const Name : string = '' );
    class function GetClass<T : IInterface>( const Name : string = '' ) : T;
  end;

implementation

uses
  System.TypInfo;

{ GlobalContainer }

class constructor GlobalContainer.Create;
begin
  _ClassDict := TDictionary<string, TClass>.Create;
end;

class destructor GlobalContainer.Destroy;
begin
  _ClassDict.Free;
end;

class function GlobalContainer.GetClass<T>( const Name : string ) : T;
var
  LGUID : TGUID;
  LKey : string;
  LClass : TClass;
  LObj : TObject;
begin
  LGUID := GetTypeData( TypeInfo( T ) ).Guid;
  LKey := LGUID.ToString + Name.ToUpper;
  if _ClassDict.ContainsKey( LKey ) then
  begin
    LClass := _ClassDict.Items[LKey];
    LObj := LClass.Create;
    Supports( LObj, LGUID, Result );
  end
  else
    raise EContainerException.CreateFmt( 'Keine Klasse zum Interface%s(%s) gefunden', [LGUID.ToString, Name] );
end;

class procedure GlobalContainer.RegisterClass<TInterface, TRegClass>( const Name : string );
var
  LGUID : TGUID;
  LKey : string;
begin
  LGUID := GetTypeData( TypeInfo( TInterface ) ).Guid;
  LKey := LGUID.ToString + Name.ToUpper;
  _ClassDict.AddOrSetValue( LKey, TRegClass );
end;

end.

[Mavarik]

Zitat von Sir Rufo:

Delphi-Quellcode:

if _ClassDict.ContainsKey( LGUID ) then
  begin
    LClass := _ClassDict.Items[LGUID];
    LObj := LClass.Create;
    Supports( LObj, LGUID, Result ); // <-- das fehlte mir einfach...
  end;

Oh man... Yes Sir! Darauf muss man kommen? Du bist echt der DUKE... Vielen Dank...

Musste noch meinen GlobalContainer umbauen, das war auch ein Interface und da wollte Generics nicht.

Mavarik

[Sir Rufo]

Zitat von Mavarik:

Zitat von Sir Rufo:

Delphi-Quellcode:

if _ClassDict.ContainsKey( LGUID ) then
  begin
    LClass := _ClassDict.Items[LGUID];
    LObj := LClass.Create;
    Supports( LObj, LGUID, Result );
  end;

Oh man... Yes Sir! Darauf muss man kommen? Du bist echt der DUKE... Vielen Dank...

Musste noch meinen GlobalContainer umbauen, das war auch ein Interface und da wollte Generics nicht.

Mavarik

Büdde, büdde

Es fehlt allerdings bei der Registrierung die Prüfung, ob die Klasse das Interface unterstützt.
Aber war auch nur auf die Schnelle

[Mavarik]

Zitat von Sir Rufo:

Es fehlt allerdings bei der Registrierung die Prüfung, ob die Klasse das Interface unterstützt.
Aber war auch nur auf die Schnelle

Nicht so?

Delphi-Quellcode:

if _ClassDict.ContainsKey( LGUID ) then
  begin
    LClass := _ClassDict.Items[LGUID];
    LObj := LClass.Create;
    if not(Supports( LObj, LGUID, Result )) then
      raise EContainerException.CreateFmt( 'Keine Klasse zum Interface%s(%s) gefunden', [LGUID.ToString, Name] );    
  end;

Mavarik

[Stevie]

Zitat von Sir Rufo:

Damit geht das

Delphi-Quellcode:

class function GlobalContainer.GetClass<T> : T;
var
  LGUID : TGUID;
  LClass : TClass;
  LObj : TObject;
begin
  LGUID := GetTypeData( TypeInfo( T ) ).Guid;
  if _ClassDict.ContainsKey( LGUID ) then
  begin
    LClass := _ClassDict.Items[LGUID];
    LObj := LClass.Create;
    Supports( LObj, LGUID, Result );
  end;
end;

Leider geht das so nicht. Deshalb gibt es in Spring4d auch relativ komplexe Logik, um den "best matching" Konstruktor zu finden.
Es ist nämlich nicht immer richtig den Parameterlosen Standardkonstruktor aufzurufen, da er eigentlich versteckt wurde (z.B. bei TComponent)
Über deine Logik würde zwar der richtige Speicher allokiert aber niemals die ganzen Dinge aus dem Create(AOwner: TComponent) durchlaufen. Auch Spring4d ist nicht komplett wasserdicht, da die RTTI keine Möglichkeit bietet zu ermitteln, ob eine Methode überschrieben oder verdeckt wurde. Auch der constructor Constraint bei generics leidet unter dieser Macke, so dass ein T.Create ziemlich böse Folgen haben kann.

Aktueller Source von Spring4d liegt übrigens hier: https://bitbucket.org/sglienke/spring4d (das Google Code Repo wird nicht mehr aktualisiert)

Mein Vorschlag wäre übrigens, nicht Interface/Klasse als Kombination zu registrieren, sondern Interface/Factory.

Somit würde aus deinem Dictionary ein TDictionary<string, TFunc<IInterface>> .

Die RegisterClass Methode würd ich dann so schreiben (nicht Compiler checked):

Delphi-Quellcode:

class procedure GlobalContainer.RegisterClass<TInterface: IInterface, TRegClass: class, constructor>( const Name : string );
var
  LGUID : TGUID;
  LKey : string;
begin
  // hier aufpassen, kann auch keine guid haben, dann sollte man hier einen Fehler werfen, denn das resolven wird nicht ohne funktionieren
  // ebenfalls sollte man checken, ob die Klasse, das Interface überhaupt supported
  LGUID := GetTypeData( TypeInfo( TInterface ) ).Guid; 
  LKey := LGUID.ToString + Name.ToUpper;
  _ClassDict.AddOrSetValue( LKey, 
    function: IInterface 
    var
      obj: TObject;
    begin 
      // wie gesagt, hier aufpassen, kann sein, dass das den falschen Konstruktor aufruft, das fängt auch der constructor Contraint nicht korrekt ab
      obj := TRegClass.Create; 
      // kein if notwendig, wenn oben geschaut wurde, ob das hier auch funktioniert
      Supports(obj, LGUID, Result);
    end);
end;

Das hat nun den Vorteil, dass du auch eine RegisterClass<IMyIntf>(function: IMyIntf begin Result := GetMyIntfFromSomewhere() end) schreiben kannst und nicht nur auf Zuordnung von Interface zu Klasse beschränkt bist.