ClassFactory ähnlich wie Spring Framework, Hilfe gesucht!

[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.