337 lines
10 KiB
ObjectPascal
337 lines
10 KiB
ObjectPascal
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.
|