diff --git a/AuraTrader/TestMethodCallFromRecordParams.pas b/AuraTrader/TestMethodCallFromRecordParams.pas index 4fc90ad..05a52bf 100644 --- a/AuraTrader/TestMethodCallFromRecordParams.pas +++ b/AuraTrader/TestMethodCallFromRecordParams.pas @@ -13,20 +13,36 @@ uses Myc.Data.Records; type - InvokeAttribute = class(TCustomAttribute); - FactoryAttribute = class(TCustomAttribute); + TIndicatorProc = reference to function(const Value: TValue): TResult; + TIndicatorFactoryProc = reference to function(const Params: TParams): TIndicatorProc; - TMyProc = reference to function(const [ref] Value: TValue): TResult; - TFactoryProc = reference to function(const [ref] Params: TParams): TMyProc; + IndicatorFactoryAttribute = class(TCustomAttribute); - TMyWorker = record + TGenericIndicatorFactory = class + private + FParameterLayout: TDataRecord.TLayout; + FFactoryProc: TIndicatorFactoryProc; + public + constructor Create( + const AParameterLayout: TDataRecord.TLayout; + const AFactoryProc: TIndicatorFactoryProc + ); + + class function CreateFromTemplate: TGenericIndicatorFactory; + + function CreateIndicator(const Params: TDataRecord): TIndicatorProc; + property ParameterLayout: TDataRecord.TLayout read FParameterLayout; + end; + + TMyWorker = class + published type TParams = record Log: Int64; text: String; end; - TValue = record + TArgs = record xyz: Double; end; @@ -35,98 +51,187 @@ type desc: String; end; - [Factory] - class function CreateFactory: TFactoryProc; static; + [IndicatorFactory] + class function CreateFactory: TIndicatorFactoryProc; static; end; procedure Test1(const Log: TStrings); implementation -class function TMyWorker.CreateFactory: TFactoryProc; +class function TMyWorker.CreateFactory: TIndicatorFactoryProc; begin Result := - function(const [ref] Params: TParams): TMyProc + function(const Params: TParams): TIndicatorProc begin var Log := TStrings(Params.Log); var text := Params.text; Result := - function(const [ref] Value: TValue): TResult + function(const Args: TArgs): TResult begin // Use Format to avoid locale issues with float conversion - Log.Add(Format('Val=%f (...%s)', [Value.xyz, text])); + Log.Add(Format('Val=%f (...%s)', [Args.xyz, text])); Result.desc := 'done'; end; end; end; -type - TInvokeProc = reference to procedure(const Value, Res: TDataRecord); - -function CreateInvoker(Ctx: TRttiContext; CallFunc: TValue): TInvokeProc; +constructor TGenericIndicatorFactory.Create( + const AParameterLayout: TDataRecord.TLayout; + const AFactoryProc: TIndicatorFactoryProc +); begin - var rttiMyProc := Ctx.GetType(CallFunc.TypeInfo); - var workerInvokeMethod := rttiMyProc.GetMethod('Invoke'); - var workerParamTypeInfo := workerInvokeMethod.GetParameters[0].ParamType.Handle; - var args: array[0..0] of TValue; - Result := - procedure(const Value, Res: TDataRecord) + inherited Create; + FParameterLayout := AParameterLayout; + FFactoryProc := AFactoryProc; +end; + +class function TGenericIndicatorFactory.CreateFromTemplate: TGenericIndicatorFactory; +var + Ctx: TRttiContext; + rttiType: TRttiType; + templateFactoryMethod: TRttiMethod; + parameterLayout: TDataRecord.TLayout; + factoryProc: TIndicatorFactoryProc; + +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 then begin - TValue.MakeWithoutCopy(Value.RawData, workerParamTypeInfo, args[0], true); - workerInvokeMethod.Invoke(CallFunc, args).ExtractRawData(Res.RawData); + 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 + 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) 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 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; +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; + var params := TDataRecord.FromRecord; params.SetValue('Log', Int64(Log)); params.SetValue('text', 'The quick brown fox jumps...'); - var workerValueParam := TDataRecord.FromRecord; - workerValueParam.SetValue('xyz', 3.14159); + var indi := fact.CreateIndicator(params); - var finalResultRec := TDataRecord.FromRecord; + var args := TDataRecord.FromRecord; + args.SetValue('xyz', 3.14159); - var invoke: TInvokeProc; + var res := indi(args); - //////////// - - var Ctx := TRttiContext.Create; - var rttiType := Ctx.GetType(TypeInfo(TMyWorker)); - - // Find and invoke the method marked with [Factory] attribute. - for var method in rttiType.GetMethods do - begin - if method.HasAttribute then - begin - // First invocation returns the factory procedure itself (an interface). - var createFuncValue := method.Invoke(TValue.Empty, []); - // Anonymous methods are interfaces, so we get the TRttiInterfaceType. - var rttiCreateFunc := Ctx.GetType(createFuncValue.TypeInfo) as TRttiInterfaceType; - // The actual code is in the 'Invoke' method of that interface. - var factoryInvokeMethod := rttiCreateFunc.GetMethod('Invoke'); - - // Prepare the argument for the factory proc: a pointer to 'params' - var factoryArg: array[0..0] of TValue; - var factoryParamTypeInfo := factoryInvokeMethod.GetParameters[0].ParamType.Handle; - TValue.Make(params.RawData, factoryParamTypeInfo, factoryArg[0]); - - var myProcValue := factoryInvokeMethod.Invoke(createFuncValue, factoryArg); - - invoke := CreateInvoker(Ctx, myProcValue); - break; - end; - end; - - ////////// - - Assert(Assigned(invoke)); - - invoke(workerValueParam, finalResultRec); - - var desc := finalResultRec.GetValue('desc'); + var desc := res.GetValue('desc'); Log.Add('Final result description: ' + desc); Assert(desc = 'done'); end; diff --git a/Src/Myc.Data.Records.pas b/Src/Myc.Data.Records.pas index 41378c1..ce601e9 100644 --- a/Src/Myc.Data.Records.pas +++ b/Src/Myc.Data.Records.pas @@ -32,10 +32,15 @@ type constructor Create(const AName: string; AFieldType: TFieldType; ATypeInfo: PTypeInfo; AOffset: Integer); + procedure Copy(Src, Dst: Pointer); + function GetSize: Integer; inline; function GetAlignedSize: Integer; inline; public + class operator Equal(const A, B: TField): Boolean; + class operator NotEqual(const A, B: TField): Boolean; inline; + property FieldType: TFieldType read FFieldType; property Name: string read FName; property Size: Integer read GetSize; @@ -54,13 +59,22 @@ type FFields: TArray; constructor Create(const AFields: TArray); + function GetSize: Integer; public - class function FromRecord: TLayout; static; + class function FromRecord: TLayout; overload; static; + class function FromRecord(ATypeInfo: PtypeInfo): TLayout; overload; static; + + class operator Equal(const A, B: TLayout): Boolean; + class operator NotEqual(const A, B: TLayout): Boolean; inline; + class function Construct(const Def: TArray): TLayout; static; + procedure Copy(Src, Dst: Pointer); + function IndexOf(const Name: String): Integer; property Fields: TArray read FFields; + property Size: Integer read GetSize; end; const @@ -110,12 +124,7 @@ constructor TDataRecord.Create(const ALayout: TLayout); begin FLayout := ALayout; - var bufSize := 0; - if Length(FLayout.Fields) > 0 then - with FLayout.Fields[High(FLayout.Fields)] do - bufSize := Offset + AlignedSize; - - SetLength(FBuffer, bufSize); + SetLength(FBuffer, FLayout.Size); for var i := 0 to High(FLayout.Fields) do FLayout.Fields[i].InitField(FBuffer); end; @@ -269,48 +278,7 @@ end; procedure TDataRecord.TField.FromType(const [ref] Buffer: TBytes; const Src); begin Assert(FOffset + Size <= Length(Buffer)); - - var Dst := @Buffer[FOffset]; - case FFieldType of - dfFloat: - begin - Assert(FTypeInfo.Kind = tkFloat); - case GetTypeData(FTypeInfo).FloatType of - ftSingle: PSingle(Dst)^ := PSingle(@Src)^; - ftDouble: PDouble(Dst)^ := PDouble(@Src)^; - else - Assert(false); - end; - end; - dfInteger: - begin - case FTypeInfo.Kind of - tkInteger: PInteger(Dst)^ := PInteger(@Src)^; - tkInt64: PInt64(Dst)^ := PInt64(@Src)^; - else - Assert(false); - end; - end; - dfString: - begin - Assert(FTypeInfo.Kind in [tkString, tkLString, tkUString, tkWString]); - PString(Dst)^ := PString(@Src)^; - end; - dfTimestamp: - begin - Assert(FTypeInfo.Kind = tkFloat); - Assert(FTypeInfo.Name = PTypeInfo(System.TypeInfo(TDateTime)).Name); - PDateTime(Dst)^ := PDateTime(@Src)^; - end; - dfRecord: - begin - Assert(FTypeInfo = System.TypeInfo(TDataRecord)); - Assert(FTypeInfo.Name = PTypeInfo(System.TypeInfo(TDataRecord)).Name); - TDataRecord(Dst^) := TDataRecord(Src); - end; - else - Assert(false); - end; + Copy(@Src, @Buffer[FOffset]); end; function TDataRecord.TField.GetSize: Integer; @@ -390,6 +358,60 @@ begin end; end; +procedure TDataRecord.TField.Copy(Src, Dst: Pointer); +begin + case FFieldType of + dfFloat: + begin + Assert(FTypeInfo.Kind = tkFloat); + case GetTypeData(FTypeInfo).FloatType of + ftSingle: PSingle(Dst)^ := PSingle(Src)^; + ftDouble: PDouble(Dst)^ := PDouble(Src)^; + else + Assert(false); + end; + end; + dfInteger: + begin + case FTypeInfo.Kind of + tkInteger: PInteger(Dst)^ := PInteger(Src)^; + tkInt64: PInt64(Dst)^ := PInt64(Src)^; + else + Assert(false); + end; + end; + dfString: + begin + Assert(FTypeInfo.Kind in [tkString, tkLString, tkUString, tkWString]); + PString(Dst)^ := PString(Src)^; + end; + dfTimestamp: + begin + Assert(FTypeInfo.Kind = tkFloat); + Assert(FTypeInfo.Name = PTypeInfo(System.TypeInfo(TDateTime)).Name); + PDateTime(Dst)^ := PDateTime(Src)^; + end; + dfRecord: + begin + Assert(FTypeInfo = System.TypeInfo(TDataRecord)); + Assert(FTypeInfo.Name = PTypeInfo(System.TypeInfo(TDataRecord)).Name); + TDataRecord(Dst^) := TDataRecord(Src^); + end; + else + Assert(false); + end; +end; + +class operator TDataRecord.TField.Equal(const A, B: TField): Boolean; +begin + Result := (A.FFieldType = B.FFieldType) and (A.FTypeInfo = B.FTypeInfo) and (A.FOffset = B.FOffset) and (A.FName = B.FName); +end; + +class operator TDataRecord.TField.NotEqual(const A, B: TField): Boolean; +begin + Result := not (A = B); +end; + constructor TDataRecord.TLayout.Create(const AFields: TArray); begin FFields := AFields; @@ -419,12 +441,25 @@ begin Result.Create(Fields); end; +procedure TDataRecord.TLayout.Copy(Src, Dst: Pointer); +begin + for var i := 0 to High(FFields) do + begin + var ofs := FFields[i].Offset; + var S: PByte := Src; + inc(S, ofs); + var D: PByte := Dst; + inc(D, ofs); + FFields[i].Copy(S, D); + end; +end; + { TLayout } -class function TDataRecord.TLayout.FromRecord: TLayout; +class function TDataRecord.TLayout.FromRecord(ATypeInfo: PtypeInfo): TLayout; begin var ctx := TRttiContext.Create; - var rttiType := ctx.GetType(TypeInfo(T)); + var rttiType := ctx.GetType(ATypeInfo); var rttiFields := rttiType.GetFields; var fields: TArray; @@ -467,6 +502,21 @@ begin Result.Create(fields); end; +{ TLayout } + +class function TDataRecord.TLayout.FromRecord: TLayout; +begin + Result := FromRecord(TypeInfo(T)); +end; + +function TDataRecord.TLayout.GetSize: Integer; +begin + Result := 0; + if Length(FFields) > 0 then + with FFields[High(FFields)] do + Result := Offset + Size; +end; + function TDataRecord.TLayout.IndexOf(const Name: String): Integer; begin for var i := 0 to High(FFields) do @@ -475,4 +525,20 @@ begin exit(-1); end; +class operator TDataRecord.TLayout.Equal(const A, B: TLayout): Boolean; +begin + if Length(A.FFields) <> Length(B.FFields) then + exit(false); + + for var i := 0 to High(A.FFields) do + if A.FFields[i] <> B.FFields[i] then + exit(false); + exit(true); +end; + +class operator TDataRecord.TLayout.NotEqual(const A, B: TLayout): Boolean; +begin + Result := not (A = B); +end; + end.