I've implemented a new version. For this version i created a mock class to
use with FHasValue (the previous implementation uses a hack to the
interface internal layout).
unit NullableTypes;
{$mode delphi}{$H+}
interface
type
{ TMockInterfacedObject }
TMockInterfacedObject = class(TObject, IUnknown)
strict private
class var FInstance: TMockInterfacedObject;
public
class constructor Create;
class destructor Destroy;
class property Instance: TMockInterfacedObject read FInstance;
function QueryInterface({$IFDEF
FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} iid : tguid;out obj) :
longint;{$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
function _AddRef: longint; {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
function _Release: longint; {$IFNDEF
WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
end;
{ TNullable }
TNullable<T> = record
strict private
FValue: T;
FHasValue: IInterface;
function GetValue: T;
function GetHasValue: Boolean;
procedure SetValue(const AValue: T);
procedure SetFlatInterface(var Intf: IInterface);
public
constructor Create(const AValue: T);
procedure Clear;
function GetValueOrDefault: T; overload;
function GetValueOrDefault(Default: T): T; overload;
property HasValue: Boolean read GetHasValue;
property Value: T read GetValue;
class operator Implicit(const AValue: Pointer): TNullable<T>;
class operator Implicit(AValue: TNullable<T>): T;
class operator Implicit(const AValue: T): TNullable<T>;
class operator Explicit(AValue: TNullable<T>): T;
end;
TInteger = TNullable<Integer>;
implementation
uses
SysUtils;
{ TNullable }
procedure TNullable<T>.SetFlatInterface(var Intf: IInterface);
begin
Intf := TMockInterfacedObject.Instance;
end;
class operator TNullable<T>.Explicit(AValue: TNullable<T>): T;
begin
Result := AValue.Value;
end;
function TNullable<T>.GetHasValue: Boolean;
begin
Result := FHasValue <> nil;
end;
function TNullable<T>.GetValue: T;
begin
if not HasValue then
raise Exception.Create('Invalid operation, Nullable type has no value');
Result := FValue;
end;
function TNullable<T>.GetValueOrDefault: T;
begin
if HasValue then
Result := FValue
else
Result := Default(T);
end;
function TNullable<T>.GetValueOrDefault(Default: T): T;
begin
if not HasValue then
Result := Default
else
Result := FValue;
end;
class operator TNullable<T>.Implicit(const AValue: Pointer): TNullable<T>;
begin
if AValue = nil then
Result.Clear
else
raise Exception.Create('Invalid operation, incompatible values.');
end;
class operator TNullable<T>.Implicit(AValue: TNullable<T>): T;
begin
Result := AValue.Value;
end;
class operator TNullable<T>.Implicit(const AValue: T): TNullable<T>;
begin
Result := TNullable<T>.Create(AValue);
end;
procedure TNullable<T>.SetValue(const AValue: T);
begin
FValue := AValue;
SetFlatInterface(FHasValue);
end;
constructor TNullable<T>.Create(const AValue: T);
begin
FValue := AValue;
SetFlatInterface(FHasValue);
end;
procedure TNullable<T>.Clear;
begin
FHasValue := nil;
end;
{ TMockInterfacedObject }
class constructor TMockInterfacedObject.Create;
begin
FInstance := TMockInterfacedObject.Create;
end;
class destructor TMockInterfacedObject.Destroy;
begin
FInstance.Free;
end;
function TMockInterfacedObject.QueryInterface({$IFDEF
FPC_HAS_CONSTREF}constref
{$ELSE}const{$ENDIF} iid : tguid;out obj): longint;
begin
Result := E_NOINTERFACE;
end;
function TMockInterfacedObject._AddRef: longint;
begin
Result := -1;
end;
function TMockInterfacedObject._Release: longint;
begin
Result := -1;
end;
end.
_______________________________________________
fpc-pascal maillist - fpc-pascal@lists.freepascal.org
http://lists.freepascal.org/cgi-bin/mailman/listinfo/fpc-pascal
