Tecsitel_FactuGES2/Source/Base/ClassRegistry/uClassRegistryUtils.pas

unit uClassRegistryUtils;

interface

uses
  Classes, SysUtils, Forms, uGUIBase;

type
  IClassRegistry = Interface
  ['{FD23C946-4103-4C67-9C3F-644B52826833}']
    procedure RegisterClass( aClass: TClass; const aDisplayname: String = '');
    procedure RegisterClasses( const aClasses: array of TClass;
      const aDisplaynames: array of String );
    procedure UnRegisterClass( aClass: TClass );
    function FindClass( const aClassOrDisplayname: String ): Tclass;
    function IsClassRegistered( aClass: TClass ): Boolean; overload;
    function IsClassRegistered( const aDisplayname: String ): Boolean; overload;
    procedure GetRegisteredClasses( aList: TStrings; aMinClass: TClass = nil);
    function CreateObject( const aClassOrDisplayname: String ): TObject;
  end;

  IComponentRegistry = Interface( IClassRegistry )
  ['{04BAA01F-9AF4-4E60-9922-641E127A35C2}']
    function CreateComponent( const aClassOrDisplayname: String;
      aOwner:TComponent = nil ): TComponent;
  end;

  IFormRegistry = Interface( IComponentRegistry )
  ['{28E3BF72-1378-4136-B1FB-027FBB8FE99B}']
    function CreateForm( const aClassOrDisplayname: String;
      aOwner: TComponent = nil ): TForm;
  end;

  IDataModuleRegistry = Interface( IComponentRegistry )
  ['{9D8D1D23-6A5C-4351-9393-093CD8B76788}']
    function CreateDatamodule( const aClassOrDisplayname: String;
      aOwner: TComponent = nil ): TDatamodule;
  end;

  IReportRegistry = Interface( IComponentRegistry )
  ['{49D3C8D5-8FEE-4F15-A6D2-51CB1DB29F8D}']
    function CreateReport( const aClassOrDisplayname: String;
      aOwner: TComponent = nil ): TInterfacedObject;
  end;

  TClassRegistry = class( TInterfacedObject, IClassRegistry )
  private
    FList: TStringlist;
    FMinAcceptableClass: TClass;

    function FindClassByClassname( const aClassname: String ): Tclass;
    function FindClassByDisplayname( const aDisplayname: String ): TClass;
    function IsClassAcceptable( aClass: TClass ): Boolean;
    function GetClasses(index: integer): TClass;
    function GetCount: Integer;
  protected
    procedure ValidateMinAcceptableClass(var aMinAcceptableClass: TClass ); virtual;
    procedure RegisterClass( aClass: TClass; const aDisplayname: String = '');
    procedure RegisterClasses( const aClasses: array of TClass;
      const aDisplaynames: array of String );
    procedure UnRegisterClass( aClass: TClass );
    function FindClass( const aClassOrDisplayname: String ): Tclass;
    function IsClassRegistered( aClass: TClass ): Boolean; overload;
    function IsClassRegistered( const aDisplayname: String ): Boolean; overload;
    procedure GetRegisteredClasses( aList: TStrings; aMinClass: TClass = nil);
    function CreateObject( const aClassOrDisplayname: String ): TObject;
    property MinAcceptableClass: TClass read FMinAcceptableClass;
    property List: TStringlist read FList;
    property Count: Integer read GetCount;
    property Classes[ index: integer ]: TClass read GetClasses;
  public
    constructor Create( minAcceptableClass: TClass = nil ); virtual;
    destructor Destroy; override;
  end;

  TComponentRegistry = class( TClassRegistry, IComponentRegistry )
  protected
    procedure ValidateMinAcceptableClass(var aMinAcceptableClass: TClass ); override;
    function CreateComponent( const aClassOrDisplayname: String;
      aOwner: TComponent = nil ): TComponent;
  end;

  TFormRegistry = class( TComponentRegistry, IFormRegistry )
  protected
    procedure ValidateMinAcceptableClass(var aMinAcceptableClass: TClass ); override;
    function CreateForm( const aClassOrDisplayname: String;
      aOwner: TComponent = nil ): TForm;
  end;

  TDataModuleRegistry = class( TComponentRegistry, IDataModuleRegistry )
  protected
    procedure ValidateMinAcceptableClass(var aMinAcceptableClass: TClass); override;
    function CreateDatamodule( const aClassOrDisplayname: String;
      aOwner: TComponent = nil ): TDatamodule;
  end;

  TReportRegistry = class( TComponentRegistry, IReportRegistry )
  protected
    procedure ValidateMinAcceptableClass(var aMinAcceptableClass: TClass ); override;
    function CreateReport( const aClassOrDisplayname: String;
      aOwner: TComponent = nil ): TInterfacedObject;
  end;

  EClassRegistryError = class( Exception );

implementation

{ TClassRegistry }

ResourceString
  eClassnotFound = 'Class "%s" was not found in the registry.';

constructor TClassRegistry.Create(minAcceptableClass: TClass);
begin
  inherited Create;
  FList := Tstringlist.Create;
  ValidateMinAcceptableClass( minAcceptableClass );
  FMinAcceptableClass := minAcceptableClass;
end;

function TClassRegistry.CreateObject(
  const aClassOrDisplayname: String): TObject;
begin
  Result := FindClass( aClassOrDisplayname ).Create;
end;

destructor TClassRegistry.Destroy;
begin
  Flist.Free;
  inherited;
end;

function TClassRegistry.FindClass(
  const aClassOrDisplayname: String): Tclass;
begin
  Result := FindClassByDisplayname( aClassOrDisplayname );
  If not Assigned( Result ) Then
    Result := FindClassByClassname( aClassOrDisplayname );
  If not Assigned( Result ) Then
    raise EClassRegistryError.CreateFmt
            ( eClassnotFound, [ aClassOrDisplayname ] );
end;

function TClassRegistry.FindClassByClassname(
  const aClassname: String): Tclass;
var
  i: Integer;
begin
  for i:= 0 to count-1 do begin
    Result := classes[i];
    If Result.ClassNameIs( aClassname ) Then
      Exit;
  end;
  Result := nil;
end;

function TClassRegistry.FindClassByDisplayname(
  const aDisplayname: String): TClass;
var
  i: Integer;
begin
  i:= List.IndexOf( aDisplayname );
  If i >= 0 Then
    Result := Classes[i]
  Else
    Result := nil;
end;

function TClassRegistry.GetClasses(index: integer): TClass;
begin
  Result := TClass( List.Objects[index] );
end;

function TClassRegistry.GetCount: Integer;
begin
  Result := List.Count;
end;

procedure TClassRegistry.GetRegisteredClasses(aList: TStrings;
  aMinClass: TClass);
var
  i: Integer;
  aClass: TClass;
begin
  Assert( Assigned( aList ));
  aList.BeginUpdate;
  try
    aList.Clear;
    If not Assigned( aMinClass ) Then
      aList.Assign( List )
    else begin
      For i:= 0 To Count-1 Do Begin
        aClass := Classes[i];
        If aClass.InheritsFrom( aMinClass ) Then
          aList.AddObject( List[i], TObject( aClass ));
      end;
    end;
  finally
    aList.EndUpdate
  end;
end;

function TClassRegistry.IsClassAcceptable(aClass: TClass): Boolean;
begin
  Result := Assigned( aClass ) and
            aClass.InheritsFrom( MinAcceptableClass );
end;

function TClassRegistry.IsClassRegistered(const aDisplayname: String): Boolean;
begin
  Result := List.IndexOf(aDisplayname) >= 0;
end;

function TClassRegistry.IsClassRegistered(aClass: TClass): Boolean;
begin
  Result := List.IndexOfObject( TObject( aClass )) >= 0;
end;

procedure TClassRegistry.RegisterClass(aClass: TClass;
  const aDisplayname: String);
begin
  Assert( Assigned( aClass ), 'Cannot register Nil class' );
  If aDisplayname = '' Then
    RegisterClass( aClass, aClass.Classname )
  else begin
    Assert( IsClassAcceptable( aClass ),
            format('Cannot register %s since it does not inherit from %s',
            [aclass.classname, MinAcceptableClass.classname] ));
    Assert( not IsClassRegistered( aClass ),
            Format('Class %s is already registered.', [aClass.Classname]));
    List.AddObject( aDisplayname, TObject( aClass ));
  end;
end;

procedure TClassRegistry.RegisterClasses(const aClasses: array of TClass;
  const aDisplaynames: array of String);
var
  i: Integer;
begin
  Assert( High( aClasses ) = High( aDisplaynames ),
          'Size of both parameter arrays has to be the same.' );
  for i:= Low( aClasses ) to High( aClasses ) do
    RegisterClass( aClasses[i], aDisplaynames[i] );
end;

procedure TClassRegistry.UnRegisterClass(aClass: TClass);
var
  i: Integer;
begin
  i:= List.IndexOfObject( TObject( aClass ));
  If i >= 0 Then
    List.Delete( i );
  // does not consider attempt to unregister a class that is not
  // registered as an error.
end;

procedure TClassRegistry.ValidateMinAcceptableClass(
  var aMinAcceptableClass: TClass);
begin
  If not Assigned( aMinAcceptableClass ) Then
    aMinAcceptableClass := TObject;
end;

{ TComponentRegistry }

function TComponentRegistry.CreateComponent(
  const aClassOrDisplayname: String; aOwner: TComponent): TComponent;
var
  aClass: TComponentClass;
begin
  aClass := TComponentClass( FindClass( aClassOrDisplayname ));
  Result := aClass.Create( aOwner );
end;

procedure TComponentRegistry.ValidateMinAcceptableClass(
  var aMinAcceptableClass: TClass);
begin
  inherited;
  If not aMinAcceptableClass.InheritsFrom( TComponent )
  Then
    aMinAcceptableClass := TComponent;
end;

{ TFormRegistry }

function TFormRegistry.CreateForm(const aClassOrDisplayname: String;
  aOwner: TComponent): TForm;
begin
  Result := CreateComponent( aClassOrDisplayname, aOwner ) As TForm;
end;

procedure TFormRegistry.ValidateMinAcceptableClass(
  var aMinAcceptableClass: TClass);
begin
  inherited;
  If not aMinAcceptableClass.InheritsFrom( TForm )
  Then
    aMinAcceptableClass := TForm;
end;

{ TDataModuleRegistry }

function TDataModuleRegistry.CreateDatamodule(
  const aClassOrDisplayname: String; aOwner: TComponent): TDatamodule;
begin
  Result := CreateComponent( aClassOrDisplayname, aOwner ) As TDatamodule;
end;

procedure TDataModuleRegistry.ValidateMinAcceptableClass(
  var aMinAcceptableClass: TClass);
begin
  inherited;
  If not aMinAcceptableClass.InheritsFrom( TDatamodule )
  Then
    aMinAcceptableClass := TDatamodule;
end;

{ TReportRegistry }

function TReportRegistry.CreateReport(const aClassOrDisplayname: String;
  aOwner: TComponent): TInterfacedObject;
begin
  Result := CreateObject( aClassOrDisplayname) As TInterfacedObject;
//  Result := CreateComponent( aClassOrDisplayname, aOwner ) As TInterfacedObject;
end;

procedure TReportRegistry.ValidateMinAcceptableClass(
  var aMinAcceptableClass: TClass);
begin
  inherited;
  If not aMinAcceptableClass.InheritsFrom( TInterfacedObject )
  Then
    aMinAcceptableClass := TInterfacedObject;
end;

end.