Michael Schimmel
240 lines
9.7 KiB
ObjectPascal
240 lines
9.7 KiB
ObjectPascal
unit TestMethodCallFromRecordParams;
|
|
|
|
interface
|
|
|
|
// We need RTTI here!
|
|
{$M+}
|
|
|
|
uses
|
|
System.Rtti,
|
|
System.SysUtils,
|
|
System.TypInfo,
|
|
System.Classes,
|
|
Myc.Data.Records;
|
|
|
|
type
|
|
TIndicatorProc<TValue, TResult> = reference to function(const Value: TValue): TResult;
|
|
TIndicatorFactoryProc<TParams, TValue, TResult> = reference to function(const Params: TParams): TIndicatorProc<TValue, TResult>;
|
|
|
|
IndicatorFactoryAttribute = class(TCustomAttribute);
|
|
|
|
TGenericIndicatorFactory = class
|
|
private
|
|
FParameterLayout: TDataRecord.TLayout;
|
|
FFactoryProc: TIndicatorFactoryProc<TDataRecord, TDataRecord, TDataRecord>;
|
|
public
|
|
constructor Create(
|
|
const AParameterLayout: TDataRecord.TLayout;
|
|
const AFactoryProc: TIndicatorFactoryProc<TDataRecord, TDataRecord, TDataRecord>
|
|
);
|
|
|
|
class function CreateFromTemplate<T>: TGenericIndicatorFactory;
|
|
|
|
function CreateIndicator(const Params: TDataRecord): TIndicatorProc<TDataRecord, TDataRecord>;
|
|
property ParameterLayout: TDataRecord.TLayout read FParameterLayout;
|
|
end;
|
|
|
|
TMyWorker = class
|
|
published
|
|
type
|
|
TParams = record
|
|
Log: Int64;
|
|
text: String;
|
|
end;
|
|
|
|
TArgs = record
|
|
xyz: Double;
|
|
end;
|
|
|
|
TResult = record
|
|
val: Int64;
|
|
desc: String;
|
|
end;
|
|
|
|
[IndicatorFactory]
|
|
class function CreateFactory: TIndicatorFactoryProc<TParams, TArgs, TResult>; static;
|
|
end;
|
|
|
|
procedure Test1(const Log: TStrings);
|
|
|
|
implementation
|
|
|
|
class function TMyWorker.CreateFactory: TIndicatorFactoryProc<TParams, TArgs, TResult>;
|
|
begin
|
|
Result :=
|
|
function(const Params: TParams): TIndicatorProc<TArgs, TResult>
|
|
begin
|
|
var Log := TStrings(Params.Log);
|
|
var text := Params.text;
|
|
|
|
Result :=
|
|
function(const Args: TArgs): TResult
|
|
begin
|
|
// Use Format to avoid locale issues with float conversion
|
|
Log.Add(Format('Val=%f (...%s)', [Args.xyz, text]));
|
|
Result.desc := 'done';
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
constructor TGenericIndicatorFactory.Create(
|
|
const AParameterLayout: TDataRecord.TLayout;
|
|
const AFactoryProc: TIndicatorFactoryProc<TDataRecord, TDataRecord, TDataRecord>
|
|
);
|
|
begin
|
|
inherited Create;
|
|
FParameterLayout := AParameterLayout;
|
|
FFactoryProc := AFactoryProc;
|
|
end;
|
|
|
|
class function TGenericIndicatorFactory.CreateFromTemplate<T>: TGenericIndicatorFactory;
|
|
var
|
|
Ctx: TRttiContext;
|
|
rttiType: TRttiType;
|
|
templateFactoryMethod: TRttiMethod;
|
|
parameterLayout: TDataRecord.TLayout;
|
|
factoryProc: TIndicatorFactoryProc<TDataRecord, TDataRecord, TDataRecord>;
|
|
|
|
begin
|
|
// This function creates a generic factory from a template class (like TMyWorker).
|
|
// It uses RTTI to find the necessary types (TParams, TValue, TResult) and the
|
|
// factory method, and then constructs a set of wrappers to adapt the specific
|
|
// types of the template to the generic TDataRecord used by this factory.
|
|
Ctx := TRttiContext.Create;
|
|
rttiType := Ctx.GetType(TypeInfo(T));
|
|
|
|
// Find nested record types for parameters, values, and results.
|
|
var paramsType := Ctx.FindType(rttiType.QualifiedName + '.' + 'TParams');
|
|
if not Assigned(paramsType) then
|
|
raise EArgumentException.CreateFmt('TParams not found in "%s"', [rttiType.Name]);
|
|
|
|
var argsType := Ctx.FindType(rttiType.QualifiedName + '.' + 'TArgs');
|
|
if not Assigned(paramsType) then
|
|
raise EArgumentException.CreateFmt('TArgs not found in "%s"', [rttiType.Name]);
|
|
|
|
var resultType := Ctx.FindType(rttiType.QualifiedName + '.' + 'TResult');
|
|
if not Assigned(paramsType) then
|
|
raise EArgumentException.CreateFmt('TResult not found in "%s"', [rttiType.Name]);
|
|
|
|
// Find the static factory method marked with the [Factory] attribute.
|
|
templateFactoryMethod := nil;
|
|
for var method in rttiType.GetMethods do
|
|
begin
|
|
if method.HasAttribute<IndicatorFactoryAttribute> then
|
|
begin
|
|
templateFactoryMethod := method;
|
|
break;
|
|
end;
|
|
end;
|
|
if not Assigned(templateFactoryMethod) then
|
|
raise EArgumentException.CreateFmt('[Factory] attribute not found on any method in "%s"', [rttiType.Name]);
|
|
|
|
// Create the layout for the parameters, which will be exposed by this factory.
|
|
parameterLayout := TDataRecord.TLayout.FromRecord(paramsType.Handle);
|
|
|
|
// Create the main factory procedure. This is a double-nested anonymous method
|
|
// that wraps the template's specific factory and worker functions.
|
|
factoryProc :=
|
|
function(const Params: TDataRecord): TIndicatorProc<TDataRecord, TDataRecord>
|
|
var
|
|
// Capture the created worker proc from the original factory as a TValue to manage its lifetime.
|
|
workerProcAsValue: TValue;
|
|
begin
|
|
// Outer anonymous method: This is the factory proc.
|
|
// It gets called with a TDataRecord of parameters.
|
|
|
|
// 1. Invoke the template's static factory method (e.g., TMyWorker.CreateFactory)
|
|
var factoryProcAsValue := templateFactoryMethod.Invoke(TValue.Empty, []);
|
|
|
|
// 2. Invoke the factory proc itself to get the actual worker proc.
|
|
var rttiFactoryProc := Ctx.GetType(factoryProcAsValue.TypeInfo) as TRttiInterfaceType;
|
|
var factoryInvokeMethod := rttiFactoryProc.GetMethod('Invoke');
|
|
|
|
// The parameter for this 'Invoke' call is the TParams record.
|
|
// Wrap the incoming TDataRecord 'Params' into a TValue for the call.
|
|
var factoryParamTypeInfo := factoryInvokeMethod.GetParameters[0].ParamType.Handle;
|
|
Assert(factoryParamTypeInfo = paramsType.Handle);
|
|
|
|
var factoryArg: array[0..0] of TValue;
|
|
TValue.Make(Params.RawData, factoryParamTypeInfo, factoryArg[0]);
|
|
|
|
// This call returns the worker proc (e.g., a TIndicatorProc<TValue, TResult>) as a TValue.
|
|
workerProcAsValue := factoryInvokeMethod.Invoke(factoryProcAsValue, factoryArg);
|
|
|
|
// 3. Return a new anonymous method that wraps the worker proc.
|
|
// This wrapper conforms to the generic TIndicatorProc<TDataRecord, TDataRecord> signature.
|
|
var rttiWorkerProc := Ctx.GetType(workerProcAsValue.TypeInfo);
|
|
var indicatorInvokeMethod := rttiWorkerProc.GetMethod('Invoke');
|
|
var indicatorParamTypeInfo := indicatorInvokeMethod.GetParameters[0].ParamType.Handle;
|
|
var indicatorResultTypeInfo := indicatorInvokeMethod.ReturnType.Handle;
|
|
|
|
Assert(indicatorParamTypeInfo = argsType.Handle);
|
|
Assert(indicatorResultTypeInfo = resultType.Handle);
|
|
|
|
var valueLayout := TDataRecord.TLayout.FromRecord(indicatorParamTypeInfo);
|
|
var resultLayout := TDataRecord.TLayout.FromRecord(indicatorResultTypeInfo);
|
|
|
|
Result :=
|
|
function(const Value: TDataRecord): TDataRecord
|
|
begin
|
|
// Inner anonymous method: This is the actual indicator proc wrapper.
|
|
Assert(Value.Layout = valueLayout);
|
|
|
|
// Prepare argument for the worker proc invocation.
|
|
var args: array[0..0] of TValue;
|
|
TValue.MakeWithoutCopy(Value.RawData, indicatorParamTypeInfo, args[0], true);
|
|
|
|
// Invoke the actual worker proc.
|
|
var resultAsTValue := indicatorInvokeMethod.Invoke(workerProcAsValue, args);
|
|
|
|
// The result is a TValue containing the result record (e.g., TMyWorker.TResult).
|
|
// Copy its contents into a new TDataRecord to return it.
|
|
Assert(TDataRecord.TLayout.FromRecord(resultAsTValue.TypeInfo) = resultLayout);
|
|
|
|
Result := TDataRecord.Create(resultLayout);
|
|
var src := resultAsTValue.GetReferenceToRawData;
|
|
resultLayout.Copy(src, Result.RawData);
|
|
|
|
// Erase all raw data in the TValue, leaving it as an empty capsule. Ownership it taken
|
|
// over to the resulting TDataRecord.
|
|
FillChar(src^, resultLayout.Size, 0);
|
|
end;
|
|
end;
|
|
|
|
// Create the final factory instance with the generated layout and wrapper procedure.
|
|
Result := TGenericIndicatorFactory.Create(parameterLayout, factoryProc);
|
|
end;
|
|
|
|
function TGenericIndicatorFactory.CreateIndicator(const Params: TDataRecord): TIndicatorProc<TDataRecord, TDataRecord>;
|
|
begin
|
|
// The factory proc does all the heavy lifting. We just need to call it.
|
|
// A real implementation might add checks, e.g., that the layout of Params matches.
|
|
Assert(
|
|
(not Assigned(FParameterLayout.Fields)) or (Params.Layout = FParameterLayout),
|
|
'Invalid parameter layout for indicator creation'
|
|
);
|
|
Result := FFactoryProc(Params);
|
|
end;
|
|
|
|
procedure Test1(const Log: TStrings);
|
|
begin
|
|
var fact := TGenericIndicatorFactory.CreateFromTemplate<TMyWorker>;
|
|
|
|
var params := TDataRecord.FromRecord<TMyWorker.TParams>;
|
|
params.SetValue<Int64>('Log', Int64(Log));
|
|
params.SetValue<String>('text', 'The quick brown fox jumps...');
|
|
|
|
var indi := fact.CreateIndicator(params);
|
|
|
|
var args := TDataRecord.FromRecord<TMyWorker.TArgs>;
|
|
args.SetValue<Double>('xyz', 3.14159);
|
|
|
|
var res := indi(args);
|
|
|
|
var desc := res.GetValue<String>('desc');
|
|
Log.Add('Final result description: ' + desc);
|
|
Assert(desc = 'done');
|
|
end;
|
|
|
|
end.
|