From e0c5ac1682d1e42c0e41e88c5d12d00a62e859f8 Mon Sep 17 00:00:00 2001 From: michael Date: Thu, 28 May 2020 09:39:35 +0000 Subject: [PATCH] * Add nullable (bug ID 0037128) git-svn-id: trunk@45520 - --- .gitattributes | 2 + packages/rtl-objpas/fpmake.pp | 1 + packages/rtl-objpas/src/inc/nullable.pp | 129 ++++++++++++++ tests/test/units/nullable/tnull.pp | 224 ++++++++++++++++++++++++ 4 files changed, 356 insertions(+) create mode 100644 packages/rtl-objpas/src/inc/nullable.pp create mode 100644 tests/test/units/nullable/tnull.pp diff --git a/.gitattributes b/.gitattributes index 245acfe350..9326cba0fd 100644 --- a/.gitattributes +++ b/.gitattributes @@ -8880,6 +8880,7 @@ packages/rtl-objpas/src/inc/dateutil.inc svneol=native#text/plain packages/rtl-objpas/src/inc/dateutil.pp svneol=native#text/plain packages/rtl-objpas/src/inc/dateutils.pp svneol=native#text/plain packages/rtl-objpas/src/inc/fmtbcd.pp svneol=native#text/plain +packages/rtl-objpas/src/inc/nullable.pp svneol=native#text/plain packages/rtl-objpas/src/inc/rtti.pp svneol=native#text/plain packages/rtl-objpas/src/inc/stdconvs.pp svneol=native#text/plain packages/rtl-objpas/src/inc/strutils.pp svneol=native#text/plain @@ -15902,6 +15903,7 @@ tests/test/units/math/troundm.pp svneol=native#text/plain tests/test/units/math/tsincos.pp svneol=native#text/pascal tests/test/units/math/ttrig1.pp svneol=native#text/plain tests/test/units/matrix/tinv1.pp svneol=native#text/pascal +tests/test/units/nullable/tnull.pp svneol=native#text/plain tests/test/units/objects/testobj.pp svneol=native#text/plain tests/test/units/objects/testobj1.pp svneol=native#text/plain tests/test/units/objects/testobj2.pp svneol=native#text/plain diff --git a/packages/rtl-objpas/fpmake.pp b/packages/rtl-objpas/fpmake.pp index e6d67cd598..de44d5fc5d 100644 --- a/packages/rtl-objpas/fpmake.pp +++ b/packages/rtl-objpas/fpmake.pp @@ -126,6 +126,7 @@ begin // AddUnit('Math'); end; + T:=P.Targets.AddUnit('nullable.pp',VariantsOSes); T:=P.Targets.AddUnit('rtti.pp',RttiOSes); with T.Dependencies do begin diff --git a/packages/rtl-objpas/src/inc/nullable.pp b/packages/rtl-objpas/src/inc/nullable.pp new file mode 100644 index 0000000000..3b625ff20f --- /dev/null +++ b/packages/rtl-objpas/src/inc/nullable.pp @@ -0,0 +1,129 @@ +unit nullable; + +{$mode objfpc} +{$modeswitch advancedrecords} + +interface + +uses sysutils; + +Type + + { TNullable } + + generic TNullable = record + private + FValue: T; + FHasValue: Boolean; // Default False + function GetIsNull: Boolean; + function GetValue: T; + function GetValueOrDefault: T; + procedure SetHasValue(AValue: Boolean); + procedure SetValue(AValue: T); + Public + // Make things more readable + Type + TMyType = specialize TNullable; + // Clear value, no value present after this. + procedure Clear; + // Is a value present ? + property HasValue: Boolean read FHasValue write SetHasValue; + // Is No value present + property IsNull: Boolean read GetIsNull; + // return the value. + property Value: T read GetValue write SetValue; + // If a value is present, return it, otherwise return the default. + property ValueOrDefault: T read GetValueOrDefault; + // Return an empty value + class function Empty: TMyType; static; + // management operator + class operator Initialize(var aSelf : TNullable); + // Conversion. + class operator Explicit(aValue: T): TMyType; + class operator Explicit(aValue: TMyType): T; + class operator := (aValue: T): TMyType; + class operator := (aValue: TMyType): T; + end; + +implementation + +uses typinfo; + +{ TNullable } + +function TNullable.GetIsNull: Boolean; +begin + Result:=Not HasValue; +end; + +function TNullable.GetValue: T; +begin + if not FHasValue then + raise EConvertError.CreateFmt('Cannot convert Null to type %s',[PtypeInfo(TypeInfo(T))^.Name]); + Result:=FValue; +end; + +function TNullable.GetValueOrDefault: T; +begin + if HasValue then + Result:=Value + else + Result:=Default(T); +end; + +procedure TNullable.SetHasValue(AValue: Boolean); +begin + if FHasValue=AValue then Exit; + if aValue then + Value:=Default(T) + else + FHasValue:=False; +end; + +procedure TNullable.SetValue(AValue: T); +begin + FValue:=aValue; + FHasValue:=True; +end; + +procedure TNullable.Clear; +begin + HasValue:=False; +end; + +class operator TNullable.Initialize(var aSelf: TNullable); +begin + aSelf.FHasValue:=False; +end; + +class function TNullable.Empty: TMyType; static; + +begin + Result.HasValue:=False; +end; + +class operator TNullable.Explicit(aValue: T): TMyType; + +begin + Result.Value:=aValue; +end; + +class operator TNullable.Explicit(aValue: TMyType): T; + +begin + Result:=aValue.Value; +end; + +class operator TNullable.:= (aValue: T): TMyType; +begin + Result.Value:=aValue; +end; + +class operator TNullable.:= (aValue: TMyType): T; + +begin + // We could use :=This is in line with TField's behaviour. + Result:=aValue.Value; +end; + +end. diff --git a/tests/test/units/nullable/tnull.pp b/tests/test/units/nullable/tnull.pp new file mode 100644 index 0000000000..c22084882a --- /dev/null +++ b/tests/test/units/nullable/tnull.pp @@ -0,0 +1,224 @@ +program testnullable; + +{$mode objfpc} +{$h+} + +uses sysutils, nullable; + +Const + Val1 = 'Value 1'; + Val2 = 'Value 2'; + +Function Testinit : String; + +Var + A : specialize TNullable; + +begin + Result:=''; + If a.HasValue then + Exit('May not have a value at start'); + If Not a.IsNull then + Exit('May not have a value at start (null)'); +end; + +Function TestSetValue : String; + +Var + A : specialize TNullable; + +begin + Result:=''; + a.Value:=Val1; + If Not a.HasValue then + Exit('Setting value does not result in hasvalue'); + If a.Value<>Val1 then + Exit('Setting value does not result in correct value stored'); +end; + +Function TestIsnull : String; + +Var + A : specialize TNullable; + +begin + Result:=''; + If Not a.IsNull then + Exit('Not null on init'); + a.Value:=Val1; + If a.IsNull then + Exit('Setting value does not result in Not isNull'); +end; + +Function TestClear : String; + +Var + A : specialize TNullable; + +begin + Result:=''; + a.Value:=Val1; + If Not a.HasValue then + Exit('Setting value does not result in hasvalue'); + A.Clear; + If a.HasValue then + Exit('Clear does not result in no value'); +end; + +Function TestGetEmptyValue : String; + +Var + A : specialize TNullable; + B : String; + +begin + Result:=''; + try + B:=a.Value; + Exit('Getting empty value does not result in exception : '+B); + except + on E : Exception do + if not (E is EConvertError) then + Exit('Getting empty value does not result in correct exception class'); + end; +end; + +Function TestGetEmptyValueOrDefault : String; + +Var + A : specialize TNullable; + B : String; + +begin + Result:=''; + try + B:=a.ValueOrDefault; + if B<>'' then + Exit('Getting empty value does not get empty value'); + a.Value:=Val2; + B:=a.ValueOrDefault; + if B<>Val2 then + Exit('Getting set value does not get empty value'); + except + on E : Exception do + Exit('Getting empty value or default results in exception !'); + end; +end; + + +Function TestSetHasValue : String; + +Var + A : specialize TNullable; + +begin + Result:=''; + a.HasValue:=true; + if Not A.HasValue then + Exit('Setting hasvalue to true does not result in correct hasvalue value'); + if Not (A.Value='') then + Exit('Setting hasvalue does not result in correct empty value'); + A.HasValue:=False; + if A.HasValue then + Exit('Setting hasvalue to false does not result in correct hasvalue value'); +end; + + +Function TestTypecast1 : string; + +Var + A : specialize TNullable; + B : String; +begin + Result:=''; + a.Value:=Val1; + B:=String(A); + If not (B=Val1) then + Exit('Typecast not correct'); + A.clear; + try + B:=String(A); + Exit('No exception raised'); + Except + on E : Exception do + if not (E is EConvertError) then + Exit('Getting empty value does not result in correct exception class'); + end; +end; + +Function TestTypecast2 : string; + +Var + A : specialize TNullable; + B : String; +begin + Result:=''; + B:=Val1; + A:=specialize TNullable(B); + If Not (A.HasValue and (A.Value=Val1)) then + Exit('Typecast not correct'); +end; + +Function TestAssign : string; + +Var + A : specialize TNullable; + B : String; +begin + Result:=''; + B:=Val1; + A:=B; + If Not (A.HasValue and (A.Value=Val1)) then + Exit('Assign not correct'); +end; + +Function TestAssign2 : string; + +Var + A : specialize TNullable; + B : String; +begin + Result:=''; + A.Value:=Val1; + B:=A; + If Not (B=Val1) then + Exit('Assign not correct'); + A.Clear; + try + B:=A; + Exit('No exception raised'); + Except + on E : Exception do + if not (E is EConvertError) then + Exit('Getting empty value does not result in correct exception class'); + end; +end; + + +Procedure DoTest(aTest,aResult : String); + +begin + if aResult<>'' then + begin + writeln(aTest,' failed : ',aResult); + Halt(1); + end + else + Writeln(aTest,' OK.'); +end; + + +begin + DoTest('TestInit',TestInit); + DoTest('TestSetValue',TestSetValue); + DoTest('TestClear',TestClear); + DoTest('TestSetHasValue',TestSetHasValue); + DoTest('TestIsNull',TestIsNull); + DoTest('TestTypeCast1',TestTypecast1); + DoTest('TestTypeCast2',TestTypecast2); + DoTest('TestAssign',TestAssign); + DoTest('TestAssign2',TestAssign2); + DoTest('TestGetEmptyValue',TestGetEmptyValue); + DoTest('TestGetEmptyValueOrDefault',TestGetEmptyValueOrDefault); +end. +