Decorator Design Pattern in Delphi. Multiple Decorations

In my previous post I introduced the decorator design pattern to you. I used a fairly simple example (a silly example if you wish) in order to give you a flavour of the pattern. I wrote Delphi code for that matter and I focused in having ONE, and only ONE, decorator class.

This was the situation in the original example: we implemented a TConsole class with a Write method that writes a text to the standard output. Then, we used a TUpperCaseConsole class to decorate a TConsole object. The decoration itself was simple: uppercasing the text to be shown.

Now I want to add a second decoration, which is framing the text to be shown within a rectangle of asterisks (*). For that I will create a new decorator class: TFramedConsole.

Let’s present a raw piece of code: (We will refine and refactor the code later)

var

  MyConsole: TConsole;

begin

  MyConsole:= TConsole.Create;

  MyConsole:= TUpperCaseConsole.Create(MyConsole); //first decoration

  MyConsole:= TFramedConsole.Create(MyConsole); //second decoration




  try

    MyConsole.Write('Hello World!');

  finally

    MyConsole.Free;

  end;

  Readln;

end.

In the code above we added a second decoration. The output for that code should be something like this:

**********************
**   HELLO WORLD!   **
**********************

This is cool: We can even add the same decoration several times. For example, to provide a double frame we would do something like this:

var

  MyConsole: TConsole;

begin

  MyConsole:= TConsole.Create;

  MyConsole:= TUpperCaseConsole.Create(MyConsole); //first decoration

  MyConsole:= TFramedConsole.Create(MyConsole); //second decoration

  MyConsole:= TFramedConsole.Create(MyConsole); //third decoration




  try

    MyConsole.Write('Hello World!');

  finally

    MyConsole.Free;

  end;

  Readln;

end

Can you guess the output now? It’s like this:

**********************
**********************
**   HELLO WORLD!   **
**********************
**********************

How are the decorated and decorator classes put together when multiple decorations are needed? There are two key things to remember:

1. The different concrete decorators (TUpperCaseConsole and TFramedConsole) must inherit from a base decorator class. We will introduce the TDecoratedConsole class as the common ancestor for our decorators.
2. The base decorator class forwards the calls to its Write method to the decorated object’s Write method.

The code looks like this:

interface

uses

  SysUtils, Windows;




type

  TConsole = class

  private

    FText: string;

  public

    procedure Write(aText: string); virtual;

  end;




  TDecoratedConsole = class(TConsole) //Base Decorator

  private

    FConsole: TConsole;

  public

    constructor Create(aConsole: TConsole);

    destructor Destroy; override;




    procedure Write(aText: string); override;

  end;




  TUpperCaseConsole = class(TDecoratedConsole) //Concrete Decorator

  public

    procedure Write(aText: string); override;

  end;




  TFramedConsole = class(TDecoratedConsole) //Concrete Decorator

  private

    procedure CreateFrame(var aText: string);

  public

    procedure Write(aText: string); override;

end;




implementation




{ TConsole }




procedure TConsole.Write(aText: string);

begin

  FText:= aText;

  Writeln(FText);

end;




{ TDecoratedConsole }




constructor TDecoratedConsole.Create(aConsole: TConsole);

begin

  inherited Create;

  FConsole:= aConsole;

end;




destructor TDecoratedConsole.Destroy;

begin

  FConsole.Free;

  inherited;

end;




procedure TDecoratedConsole.Write(aText: string);

begin

  FConsole.Write(aText);

end;




{ TUpperCaseConsole }




procedure TUpperCaseConsole.Write(aText: string);

begin

  aText:= UpperCase(aText);

  inherited Write(aText);

end;




{ TFramedConsole }




procedure TFramedConsole.CreateFrame(var aText: string);

var

  TextLength: Integer;

  AsteriskLine: string;

  RealText: string;

begin

  if Pos('*', aText) = 0 then

    aText:= '** ' + aText + ' **';




  RealText:= Trim(StringReplace(aText, '*', '', [rfReplaceAll]));

  TextLength:= Length(RealText);

  AsteriskLine:= StringOfChar('*', TextLength + 10);




  aText:= AsteriskLine + #13#10 +

          aText + #13#10 + AsteriskLine;

end;




procedure TFramedConsole.Write(aText: string);

begin

  CreateFrame(aText);

  inherited Write(aText);

end;

I know you are dying to say: the code above is awful because the decorators are bounded to a specific implementation of the decorated class. Indeed, we are going to fix that by introducing a TAbstractConsole class, which will be the common ancestor of the decorated and decorator classes. The TAbstractConsole class is abstract, meaning it has no implementation. You could have used an Interface type instated, something like IAbstractConsole. I’ll leave that to you.

Finally, I present you the consuming code plus the class definition code:

//Consuming code

var

  MyConsole: TAbstractConsole;

begin

  MyConsole:= TConsole.Create;

  MyConsole:= TUpperCaseConsole.Create(MyConsole); //first decoration

  MyConsole:= TFramedConsole.Create(MyConsole); //second decoration

  MyConsole:= TFramedConsole.Create(MyConsole); //third decoration




  try

    MyConsole.Write('Hello World!');

  finally

    MyConsole.Free;

  end;

  Readln;

end




//Class definition code

interface




uses

  SysUtils, Windows;




type

  TAbstractConsole = class //Abstract class ==> Interface

  public

    procedure Write(aText: string); virtual; abstract;

  end;




  TConsole = class(TAbstractConsole) //Concrete class

  private

    FText: string;

  public

    procedure Write(aText: string); override;

  end;




  TDecoratedConsole = class(TAbstractConsole) //Base Decorator

  private

    FConsole: TAbstractConsole;

  public

    constructor Create(aConsole: TAbstractConsole);

    destructor Destroy; override;




    procedure Write(aText: string); override;

  end;




  TUpperCaseConsole = class(TDecoratedConsole) //Concrete Decorator

  public

    procedure Write(aText: string); override;

  end;




  TFramedConsole = class(TDecoratedConsole) //Concrete Decorator

  private

    procedure CreateFrame(var aText: string);

  public

    procedure Write(aText: string); override;

  end;




implementation




{ TConsole }




procedure TConsole.Write(aText: string);

begin

  FText:= aText;

  Writeln(FText);

end;




{ TDecoratedConsole }




constructor TDecoratedConsole.Create(aConsole: TAbstractConsole);

begin

  inherited Create;

  FConsole:= aConsole;

end;




destructor TDecoratedConsole.Destroy;

begin

  FConsole.Free;

  inherited;

end;




procedure TDecoratedConsole.Write(aText: string);

begin

  FConsole.Write(aText);

end;




{ TUpperCaseConsole }




procedure TUpperCaseConsole.Write(aText: string);

begin

  aText:= UpperCase(aText);

  inherited Write(aText);

end;




{ TFramedConsole }




procedure TFramedConsole.CreateFrame(var aText: string);

var

  TextLength: Integer;

  AsteriskLine: string;

  RealText: string;

begin

  if Pos('*', aText) = 0 then

    aText:= '** ' + aText + ' **';




  RealText:= Trim(StringReplace(aText, '*', '', [rfReplaceAll]));

  TextLength:= Length(RealText);

  AsteriskLine:= StringOfChar('*', TextLength + 10);




  aText:= AsteriskLine + #13#10 +

          aText + #13#10 + AsteriskLine;

end;




procedure TFramedConsole.Write(aText: string);

begin

  CreateFrame(aText);

  inherited Write(aText);

end;




I hope this was useful and I am definitely waiting for you feedback. Corrections and suggestions are welcome in the comment section below. Thanks!

For further reading about design patterns get your hands on these classics:

CodeProject