* Add nullable (bug ID 0037128)

git-svn-id: trunk@45520 -

.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

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

packages/rtl-objpas/src/inc/nullable.pp

@@ -0,0 +1,129 @@
+unit nullable;
+
+{$mode objfpc}
+{$modeswitch advancedrecords}
+
+interface
+
+uses sysutils;
+
+Type
+
+  { TNullable }
+
+  generic TNullable<T> = 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<T>;
+    // 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.

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<String>;
+
+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<String>;
+
+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<String>;
+
+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<String>;
+
+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<String>;
+  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<String>;
+  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<String>;
+
+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<String>;
+  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<String>;
+  B : String;
+begin
+  Result:='';
+  B:=Val1;
+  A:=specialize TNullable<String>(B);
+  If Not (A.HasValue and (A.Value=Val1)) then
+    Exit('Typecast not correct');
+end;
+
+Function TestAssign : string;
+
+Var
+  A : specialize TNullable<String>;
+  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<String>;
+  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.
+