Verständnisproblem: Globale, gruppierte Konstanten

[Sir Rufo]

Hier ein ValueObject in Aktion:

Delphi-Quellcode:

program dp_181169;

{$APPTYPE CONSOLE}
{$R *.res}

uses
  System.SysUtils,
  Tier in 'Tier.pas';

procedure Test;
var
  LTier : TTier;
begin
  for LTier in TTier._All do // <- alle Tiere anzeigen
    begin
      WriteLn( LTier.name );
    end;

  LTier := TTier.Create( 5 ); // <- erzeugen mit einer TierId
  try
    if LTier.Equals( TTier.Hund ) // <- vergleichen mit Hund
    then
      WriteLn( 'Wie ein/e ' + TTier.Hund.name );
    if LTier.Equals( TTier.Katze ) // <- vergleichen mit Katze
    then
      WriteLn( 'Wie ein/e ' + TTier.Katze.name );
    if LTier.Equals( TTier.Maus ) // <- vergleichen mit Maus
    then
      WriteLn( 'Wie ein/e ' + TTier.Maus.name );
  finally
    LTier.Free; // <- Instanz wird entfernt
  end;

  LTier := TTier.Hund; // <- Instanz über Klassen-Eigenschaft
  try
    WriteLn( 'Hier ist ein/e ', LTier.name );
  finally
    LTier.Free; // <- macht nichts
  end;

  WriteLn( 'Hier ist immer noch ein/e ', LTier.name ); // <- Kein Problem

  FreeAndNil( LTier ); // <- wird nur auf nil gesetzt

  LTier := TTier.Create( 0815 ); // <- Exception, weil ungültige TierId

end;

begin
  ReportMemoryLeaksOnShutdown := True;
  try
    Test;
  except
    on E : Exception do
      WriteLn( E.ClassName, ': ', E.Message );
  end;
  ReadLn;

end.

und die Ausgabe

Code:

Hund
Katze
Maus
Wie ein/e Maus
Hier ist ein/e Hund
Hier ist immer noch ein/e Hund
EArgumentOutOfRangeException: Ungültige TierId

Ein robustes ValueObject bedarf unter Delphi allerdings einiges an zusätzlichem Gebimmel-Bammel, da wir ja auf die lifetime der Instanzen achtgeben müssen.

Dafür kann aber auch der DAP (Dümmste Anzunehmende Programmierer) es niemals schaffen eine ungültige Instanz dieses ValueObjects zu erzeugen (solange er den Source dieser Klasse nicht anfasst).

Ob die einzelnen möglichen Werte direkt in der Klasse/im Quelltext hinterlegt werden hängt hierbei immer vom jeweiligen Kontext/Einsatzgebiet ab.

Wenn neue mögliche Werte hinzukommen und diese auch noch eine weitere Berücksichtigung in der Anwendung benötigen, dann baut man die Werte tatsächlich fest ein (Diese Anwendung kann halt nur mit Hund, Katze, Maus umgehen, aber nicht mit dem neu hinzugekommen Elefanten, dazu muss noch mehr angepasst werden).

Delphi-Quellcode:

unit Tier;

interface

uses
  System.Generics.Collections;

type
  TValueObject = class abstract
  public
    function SameValueAs( Other : TValueObject ) : Boolean; virtual; abstract;
    function Equals( Obj : TObject ) : Boolean; override;
  end;

  TTier = class( TValueObject )
{$REGION 'values'}
  private type
    TValue = record
      Id : Integer;
      Name : string;
    end;

  const
    _Values : array [0 .. 2] of TValue = ( ( Id : 0; name : 'Hund' ), ( Id : 12; name : 'Katze' ), ( Id : 5;
        name : 'Maus' ) );
    class procedure BuildItems;
{$ENDREGION}
{$REGION 'class'}
  private
    class var _Items : TList<TTier>;
    class var _ItemsDict : TDictionary<Integer, TTier>;
    class var _Shutdown : Boolean;
    class function GetTier( const Index : Integer ) : TTier; static;
    class function GetAll : TArray<TTier>; static;
  protected
    class constructor Create;
    class destructor Destroy;
  public
    class property _All : TArray<TTier> read GetAll;
    class property Hund : TTier index 0 read GetTier;
    class property Katze : TTier index 12 read GetTier;
    class property Maus : TTier index 5 read GetTier;
{$ENDREGION}
{$REGION 'instance'}
  private
    FId : Integer;
    FName : string;
    function SameTierAs( Other : TTier ) : Boolean;
    constructor CreateItem( );
{$ENDREGION}
  public
    constructor Create( TierId : Integer );
    destructor Destroy; override;

    function SameValueAs( Other : TValueObject ) : Boolean; override;
    function GetHashCode : Integer; override;
    function ToString : string; override;
    procedure FreeInstance; override;

    property Id : Integer read FId;
    property name : string read FName;

  end;

implementation

uses
  System.SysUtils;

{ TValueObject }

function TValueObject.Equals( Obj : TObject ) : Boolean;
begin
  Result := ( Self = Obj ) or Assigned( Obj ) and ( Self.ClassType = Obj.ClassType ) and
    SameValueAs( Obj as TValueObject );
end;

{ TTier }

class procedure TTier.BuildItems;
var
  LValue : TValue;
  LItem : TTier;
begin
  if Assigned( _ItemsDict )
  then
    Exit;

  _Items := TObjectList<TTier>.Create( True );
  _ItemsDict := TDictionary<Integer, TTier>.Create( );

  for LValue in _Values do
    begin
      LItem := Self.CreateItem;
      LItem.FId := LValue.Id;
      LItem.FName := LValue.Name;
      _Items.Add( LItem );
      _ItemsDict.Add( LValue.Id, LItem );
    end;
end;

constructor TTier.Create( TierId : Integer );
begin
  inherited Create;
  if not _ItemsDict.ContainsKey( TierId )
  then
    raise EArgumentOutOfRangeException.Create( 'Ungültige TierId' );
  FId := TierId;
  FName := _ItemsDict[TierId].Name;
end;

constructor TTier.CreateItem;
begin
  inherited;
end;

class constructor TTier.Create;
begin
  BuildItems;
end;

destructor TTier.Destroy;
begin
  if _Items.Contains( Self ) and not _Shutdown
  then
    Exit;
  inherited;
end;

procedure TTier.FreeInstance;
begin
  if _Items.Contains( Self ) and not _Shutdown
  then
    Exit;
  inherited;
end;

class function TTier.GetAll : TArray<TTier>;
begin
  Result := TTier._Items.ToArray;
end;

function TTier.GetHashCode : Integer;
begin
  Result := FId;
end;

class function TTier.GetTier( const Index : Integer ) : TTier;
begin
  Result := TTier._ItemsDict[index]
end;

class destructor TTier.Destroy;
begin
  TTier._Shutdown := True;
  TTier._ItemsDict.Free;
  TTier._Items.Free;
end;

function TTier.SameTierAs( Other : TTier ) : Boolean;
begin
  Result := Assigned( Other ) and ( Self.FId = Other.FId );
end;

function TTier.SameValueAs( Other : TValueObject ) : Boolean;
begin
  Result := ( Self = Other ) or Assigned( Other ) and ( Self.ClassType = Other.ClassType ) and
    SameTierAs( Other as TTier );
end;

function TTier.ToString : string;
begin
  Result := FName;
end;

end.