From 4fb77b71ecc10cb48a00433ea560cb9d81ef9e62 Mon Sep 17 00:00:00 2001 From: svenbarth Date: Wed, 30 Nov 2016 19:32:41 +0000 Subject: [PATCH] =?UTF-8?q?*=20fix=20for=20Mantis=20#31029,=20based=20on?= =?UTF-8?q?=20the=20patch=20provided=20by=20Silvio=20Cl=C3=A9cio:=20PArray?= =?UTF-8?q?OfByte=20is=20not=20necessary=20and=20in=20fact=20the=20purpose?= =?UTF-8?q?=20of=20TArrayOfByte=20is=20a=20different=20one=20from=20refere?= =?UTF-8?q?nce=20counting=20(namely=20to=20ensure=20correct=20passing=20of?= =?UTF-8?q?=20the=20parameter),=20so=20renamed=20accordingly=20(plus=20a?= =?UTF-8?q?=20comment);=20similar=20change=20in=20SetDynArrayProp.=20Also?= =?UTF-8?q?=20Get-/SetPropValue=20in=20Variants=20unit=20has=20been=20adju?= =?UTF-8?q?sted=20to=20make=20use=20of=20Get-/SetDynArrayProp.=20+=20added?= =?UTF-8?q?=20adjusted=20test?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit git-svn-id: trunk@35025 - --- .gitattributes | 1 + packages/rtl-objpas/src/inc/variants.pp | 11 +- rtl/objpas/typinfo.pp | 82 +++++++++++ tests/webtbs/tw31029.pp | 177 ++++++++++++++++++++++++ 4 files changed, 270 insertions(+), 1 deletion(-) create mode 100644 tests/webtbs/tw31029.pp diff --git a/.gitattributes b/.gitattributes index ffb0b3fb48..36fd26bb83 100644 --- a/.gitattributes +++ b/.gitattributes @@ -15283,6 +15283,7 @@ tests/webtbs/tw30948.pp svneol=native#text/plain tests/webtbs/tw30978.pp svneol=native#text/pascal tests/webtbs/tw30978a.pp svneol=native#text/pascal tests/webtbs/tw3101.pp svneol=native#text/plain +tests/webtbs/tw31029.pp svneol=native#text/pascal tests/webtbs/tw3104.pp svneol=native#text/plain tests/webtbs/tw3109.pp svneol=native#text/plain tests/webtbs/tw3111.pp svneol=native#text/plain diff --git a/packages/rtl-objpas/src/inc/variants.pp b/packages/rtl-objpas/src/inc/variants.pp index 56559f203a..90952b138f 100644 --- a/packages/rtl-objpas/src/inc/variants.pp +++ b/packages/rtl-objpas/src/inc/variants.pp @@ -4536,6 +4536,8 @@ begin Result := GetInt64Prop(Instance, PropInfo); tkQWord: Result := QWord(GetInt64Prop(Instance, PropInfo)); + tkDynArray: + DynArrayToVariant(Result,GetDynArrayProp(Instance, PropInfo), PropInfo^.PropType); else raise EPropertyConvertError.CreateFmt('Invalid Property Type: %s',[PropInfo^.PropType^.Name]); end; @@ -4550,6 +4552,7 @@ var Qw: QWord; S: String; B: Boolean; + dynarr: Pointer; begin TypeData := GetTypeData(PropInfo^.PropType); @@ -4638,7 +4641,13 @@ begin if (QwTypeData^.MaxQWordValue) then raise ERangeError.Create(SRangeError); SetInt64Prop(Instance, PropInfo,Qw); - end + end; + tkDynArray: + begin + dynarr:=Nil; + DynArrayFromVariant(dynarr, Value, PropInfo^.PropType); + SetDynArrayProp(Instance, PropInfo, dynarr); + end; else raise EPropertyConvertError.CreateFmt('SetPropValue: Invalid Property Type %s', [PropInfo^.PropType^.Name]); diff --git a/rtl/objpas/typinfo.pp b/rtl/objpas/typinfo.pp index d9b32f9ed1..e20fa321d1 100644 --- a/rtl/objpas/typinfo.pp +++ b/rtl/objpas/typinfo.pp @@ -491,6 +491,11 @@ function GetRawInterfaceProp(Instance: TObject; PropInfo: PPropInfo): Pointer; procedure SetRawInterfaceProp(Instance: TObject; const PropName: string; const Value: Pointer); procedure SetRawInterfaceProp(Instance: TObject; PropInfo: PPropInfo; const Value: Pointer); +function GetDynArrayProp(Instance: TObject; const PropName: string): Pointer; +function GetDynArrayProp(Instance: TObject; PropInfo: PPropInfo): Pointer; +procedure SetDynArrayProp(Instance: TObject; const PropName: string; const Value: Pointer); +procedure SetDynArrayProp(Instance: TObject; PropInfo: PPropInfo; const Value: Pointer); + // Auxiliary routines, which may be useful Function GetEnumName(TypeInfo : PTypeInfo;Value : Integer) : string; Function GetEnumValue(TypeInfo : PTypeInfo;const Name : string) : Integer; @@ -1506,6 +1511,83 @@ begin end; end; +{ --------------------------------------------------------------------- + Dynamic array properties + ---------------------------------------------------------------------} + +function GetDynArrayProp(Instance: TObject; const PropName: string): Pointer; +begin + Result:=GetDynArrayProp(Instance,FindPropInfo(Instance,PropName)); +end; + +function GetDynArrayProp(Instance: TObject; PropInfo: PPropInfo): Pointer; +type + { we need a dynamic array as that type is usually passed differently from + a plain pointer } + TDynArray=array of Byte; + TGetDynArrayProc=function:TDynArray of object; + TGetDynArrayProcIndex=function(index:longint):TDynArray of object; +var + AMethod : TMethod; +begin + Result:=nil; + if PropInfo^.PropType^.Kind<>tkDynArray then + Exit; + case (PropInfo^.PropProcs) and 3 of + ptField: + Result:=PPointer(Pointer(Instance)+PtrUInt(PropInfo^.GetProc))^; + ptStatic, + ptVirtual: + begin + if (PropInfo^.PropProcs and 3)=ptStatic then + AMethod.Code:=PropInfo^.GetProc + else + AMethod.Code:=PCodePointer(Pointer(Instance.ClassType)+PtrUInt(PropInfo^.GetProc))^; + AMethod.Data:=Instance; + if ((PropInfo^.PropProcs shr 6) and 1)<>0 then + Result:=Pointer(TGetDynArrayProcIndex(AMethod)(PropInfo^.Index)) + else + Result:=Pointer(TGetDynArrayProc(AMethod)()); + end; + end; +end; + +procedure SetDynArrayProp(Instance: TObject; const PropName: string; const Value: Pointer); +begin + SetDynArrayProp(Instance,FindPropInfo(Instance,PropName),Value); +end; + +procedure SetDynArrayProp(Instance: TObject; PropInfo: PPropInfo; const Value: Pointer); +type + { we need a dynamic array as that type is usually passed differently from + a plain pointer } + TDynArray=array of Byte; + TSetDynArrayProcIndex=procedure(index:longint;const i:TDynArray) of object; + TSetDynArrayProc=procedure(i:TDynArray) of object; +var + AMethod: TMethod; +begin + if PropInfo^.PropType^.Kind<>tkDynArray then + Exit; + case (PropInfo^.PropProcs shr 2) and 3 of + ptField: + CopyArray(PPointer(Pointer(Instance)+PtrUInt(PropInfo^.SetProc)), @Value, PropInfo^.PropType, 1); + ptStatic, + ptVirtual: + begin + if ((PropInfo^.PropProcs shr 2) and 3)=ptStatic then + AMethod.Code:=PropInfo^.SetProc + else + AMethod.Code:=PCodePointer(Pointer(Instance.ClassType)+PtrUInt(PropInfo^.SetProc))^; + AMethod.Data:=Instance; + if ((PropInfo^.PropProcs shr 6) and 1)<>0 then + TSetDynArrayProcIndex(AMethod)(PropInfo^.Index,TDynArray(Value)) + else + TSetDynArrayProc(AMethod)(TDynArray(Value)); + end; + end; +end; + { --------------------------------------------------------------------- String properties ---------------------------------------------------------------------} diff --git a/tests/webtbs/tw31029.pp b/tests/webtbs/tw31029.pp new file mode 100644 index 0000000000..e880f0d519 --- /dev/null +++ b/tests/webtbs/tw31029.pp @@ -0,0 +1,177 @@ +program tw31029; + +{$ifdef fpc} +{$mode objfpc}{$H+} +{$endif} + +uses + TypInfo, + variants; + +type + TBytes = array of Byte; + + {$M+} + TMyObject = class + private + FDynArr1: TBytes; + FDynArr2: TBytes; + FDynArr3: TBytes; + FDynArr4: TBytes; + function GetDynArr2: TBytes; + function GetDynArr3(AIndex: Integer): TBytes; + procedure SetDynArr2(AValue: TBytes); + procedure SetDynArr3(AIndex: Integer; AValue: TBytes); + protected + procedure CheckIndex(AIndex: Integer); inline; + function GetDynArr4: TBytes; virtual; + procedure SetDynArr4(AValue: TBytes); virtual; + published + property DynArr1: TBytes read FDynArr1 write FDynArr1; + property DynArr2: TBytes read GetDynArr2 write SetDynArr2; + property DynArr3: TBytes index 1 read GetDynArr3 write SetDynArr3; + property DynArr4: TBytes read GetDynArr4 write SetDynArr4; + end; + {$M-} + + function TMyObject.GetDynArr2: TBytes; + begin + Result := FDynArr2; + end; + + procedure TMyObject.SetDynArr2(AValue: TBytes); + begin + FDynArr2 := AValue; + end; + + function TMyObject.GetDynArr3(AIndex: Integer): TBytes; + begin + Result := FDynArr3; + CheckIndex(AIndex); + end; + + procedure TMyObject.SetDynArr3(AIndex: Integer; AValue: TBytes); + begin + FDynArr3 := AValue; + CheckIndex(AIndex); + end; + + function TMyObject.GetDynArr4: TBytes; + begin + Result := FDynArr4; + end; + + procedure TMyObject.SetDynArr4(AValue: TBytes); + begin + FDynArr4 := AValue; + end; + + procedure TMyObject.CheckIndex(AIndex: Integer); + begin + if AIndex <> 1 then begin + Writeln('Invalid property index: ', AIndex); + Halt(1); + end; + end; + + procedure CheckArr(const A1, A2: TBytes; const AMsg: string; ACode: LongInt); inline; + begin + //Writeln(HexStr(Pointer(A1)), ' ', HexStr(Pointer(A2))); + if A1 <> A2 then begin + Writeln(AMsg); + Halt(ACode); + end; + end; + + procedure CheckArrContents(const A1, A2: TBytes; const AMsg: string; ACode: LongInt); + var + valid: Boolean; + i: LongInt; + begin + valid := True; + if Length(A1) <> Length(A2) then + valid := False; + if valid then begin + for i := Low(A1) to High(A1) do begin + if A1[i] <> A2[i] then begin + valid := False; + Break; + end; + end; + end; + if not valid then begin + Writeln(AMsg); + Halt(ACode); + end; + end; + +var + VMyObject: TMyObject; + VDynArr1, VDynArr2, VDynArr3, VDynArr4: TBytes; + V: Variant; +begin + VMyObject := TMyObject.Create; + try + { direct use of SetDynArrayProp } + + VMyObject.DynArr1 := nil; + VDynArr1 := TBytes.Create(65, 66, 64); + SetDynArrayProp(VMyObject, 'DynArr1', Pointer(VDynArr1)); + CheckArr(VMyObject.DynArr1, VDynArr1, + 'SetDynArrayProp: VMyObject.DynArr1 <> VDynArr1', 2); + VMyObject.DynArr1 := TBytes.Create(65, 66, 64); + VDynArr1 := GetDynArrayProp(VMyObject, 'DynArr1'); + CheckArr(VMyObject.DynArr1, VDynArr1, + 'GetDynArrayProp: VMyObject.DynArr1 <> VDynArr1', 3); + + VMyObject.DynArr2 := nil; + VDynArr2 := TBytes.Create(65, 66, 64); + SetDynArrayProp(VMyObject, 'DynArr2', Pointer(VDynArr2)); + CheckArr(VMyObject.DynArr2, VDynArr2, + 'SetDynArrayProp: VMyObject.DynArr2 <> VDynArr2', 4); + VMyObject.DynArr2 := TBytes.Create(65, 66, 64); + VDynArr2 := GetDynArrayProp(VMyObject, 'DynArr2'); + CheckArr(VMyObject.DynArr2, VDynArr2, + 'GetDynArrayProp: VMyObject.DynArr2 <> VDynArr2', 5); + + VMyObject.DynArr3 := nil; + VDynArr3 := TBytes.Create(65, 66, 64); + SetDynArrayProp(VMyObject, 'DynArr3', Pointer(VDynArr3)); + CheckArr(VMyObject.DynArr3, VDynArr3, + 'SetDynArrayProp: VMyObject.DynArr3 <> VDynArr3', 6); + VMyObject.DynArr3 := TBytes.Create(65, 66, 64); + VDynArr3 := GetDynArrayProp(VMyObject, 'DynArr3'); + CheckArr(VMyObject.DynArr3, VDynArr3, + 'GetDynArrayProp: VMyObject.DynArr3 <> VDynArr3', 7); + + VMyObject.DynArr4 := nil; + VDynArr4 := TBytes.Create(65, 66, 64); + SetDynArrayProp(VMyObject, 'DynArr4', Pointer(VDynArr4)); + CheckArr(VMyObject.DynArr4, VDynArr4, + 'SetDynArrayProp: VMyObject.DynArr4 <> VDynArr4', 8); + VMyObject.DynArr4 := TBytes.Create(65, 66, 64); + VDynArr4 := GetDynArrayProp(VMyObject, 'DynArr4'); + CheckArr(VMyObject.DynArr4, VDynArr4, + 'GetDynArrayProp: VMyObject.DynArr4 <> VDynArr4', 9); + + { indirect use through a variant (a single test should be enough) } + VMyObject.DynArr1 := nil; + VDynArr1 := TBytes.Create(65, 66, 64); + V := Null; + DynArrayToVariant(V, Pointer(VDynArr1), TypeInfo(VDynArr1)); + SetPropValue(VMyObject, 'DynArr1', V); + CheckArrContents(VMyObject.DynArr1, VDynArr1, + 'SetPropValue: VMyObject.DynArr1 <> VDynArr1', 10); + VMyObject.DynArr1 := TBytes.Create(65, 66, 64); + V := GetPropValue(VMyObject, 'DynArr1'); + VDynArr1 := nil; + DynArrayFromVariant(Pointer(VDynArr1), V, TypeInfo(VDynArr1)); + CheckArrContents(VMyObject.DynArr1, VDynArr1, + 'GetPropValue: VMyObject.DynArr1 <> VDynArr1', 10); + + WriteLn('All tests OK'); + finally + VMyObject.Free; + end; +end. +