unit jRegister;
interface
uses classes;
type TJobRegister =
class(TComponent)
private
FRegister : TStringList;
public
Constructor Create(aOwner : TComponent);
override;
Destructor Destroy;
override;
procedure RegisterObjectMethods
(Instance : TObject;
const methods : TStrings);
virtual;
procedure RegisterObjectMethodByName
(
const registeredName :
String; Instance : TObject;
const method :
String);
virtual;
procedure RegisterObjectMethod
(
const registeredName :
String; instance : TObject; addr : Pointer);
virtual;
procedure RegisterCall (
const registeredName :
String; m : pMethod);
virtual;
procedure UnRegisterCall (
const registeredName :
String);
virtual;
procedure Call(
const aFunctionToCall :
String);
virtual;
end;
TExecute =
procedure of object;
function jobRegister : TJobRegister;
implementation
uses sysUtils;
var reg : TJobRegister =
nil;
function jobRegister : TJobRegister;
begin
if not Assigned(reg)
then
reg := TJobRegister.Create(Application);
result := reg;
end;
Constructor TJobRegister.Create(aOwner : TComponent);
begin
inherited Create(aOwner);
FRegister := TStringList.Create;
FRegister.Sorted := True;
end;
Destructor TJobRegister.Destroy;
var i : Integer;
p : pMethod;
begin
for i := 0
to FRegister.Count-1
do
begin
p := pMethod(FRegister.Objects[i]);
FreeMem(p);
end;
end;
procedure TJobRegister.RegisterObjectMethods
(Instance : TObject;
const methods : TStrings);
var i : Integer;
n,v :
String;
begin
for i := 0
to methods.count-1
do
begin
n := methods.Names[i];
v := methods.Values[n];
if (n<>'
')
and
(v<>'
')
then
RegisterObjectMethodByName(n,instance,v);
end;
end;
procedure TJobRegister.RegisterObjectMethodByName
(
const registeredName :
String; Instance : TObject;
const method :
String);
var p : Pointer;
begin
if Assigned(instance)
then
begin
p := Instance.MethodAddress(method);
if (Assigned(p))
then
RegisterObjectMethod(registeredName,Instance,p);
end;
end;
procedure TJobRegister.RegisterObjectMethod
(
const registeredName :
String; instance : TObject; addr : Pointer);
var p : pMethod;
begin
GetMem(p,SizeOf(TMethod));
p.Data := instance;
p.Code := addr;
RegisterCall(registeredName,p);
end;
procedure TJobRegister.RegisterCall (
const registeredName :
String; m : pMethod);
begin
if (FRegister.IndexOf(registeredName)<0)
then
FRegister.AddObject(registeredName,Pointer(m))
else raise Exception.Create('
Funktion [' + registeredName + '
] bereits registriert');
end;
procedure TJobRegister.UnRegisterCall (
const registeredName :
String);
var idx : Integer;
p : pMethod;
begin
idx := FRegister.IndexOf(registeredName);
if (idx >= 0 )
then begin
p := pMethod(FRegister.Objects[idx]);
FreeMem(p);
end
else raise Exception.Create('
Ungültiger Versuch [' + registeredName + '
] freizugeben');
end;
procedure TJobRegister.Call(
const aFunctionToCall :
String);
var idx : Integer;
p : pMethod;
e : TExecute;
begin
idx := FRegister.IndexOf(aFunctionToCall);
if (idx >= 0 )
then begin
p := Pointer(FRegister.Objects[idx]);
e := TExecute(p^);
e();
end
else begin
raise Exception.Create('
Funtkion [' + aFunctionToCall + '
] nicht vorhanden');
end;
end;