Design Patterns - продължение...

Публикуваното по долу и в допълненията на темата е взето от тук, както и от други източници(*). Не претендирам за подробност, обстоятелственост още по-малко за някакви авторски права !

--------------------------------------------------------------------------------------------
Introduction
Design patterns are frequently recurring structures and relationships in object-oriented design. Getting to know them can help you design better, more reusable code and also help you learn to design more complex systems.


Much of the ground-breaking work on design patterns was presented in the book Design Patterns: Elements of Reusable Object-Oriented Software by Gamma, Helm, Johnson and Vlissides. You might also have heard of the authors referred to as "the Gang of Four". If you haven't read this book before and you're designing objects, it's an excellent primer to help structure your design. To get the most out of these examples, I recommend reading the book as well.


This paper takes some sample patterns from Design Patterns and discusses their implementation in Delphi.


Another good source of pattern concepts is the book Object Models: Strategies, Patterns and Applications by Peter Coad. Coad's examples are more business oriented and he emphasises learning strategies to identify patterns in your own work.



--------------------------------------------------------------------------------

How Delphi Helps You Define Patterns
Delphi implements a fully object-oriented language with many practical refinements that simplify development.


A summary of Delphi class concepts can be found in the following appendix.


The most important class attributes from a pattern perspective are the basic inheritance of classes; virtual and abstract methods; and use of protected and public scope. These give you the tools to create patterns that can be reused and extended, and let you isolate varying functionality from base attributes that are unchanging.


Delphi is a great example of an extensible application, through its component architecture, IDE interfaces and tool interfaces. These interfaces define many virtual and abstract constructors and operations.



--------------------------------------------------------------------------------

Delphi Examples of Design Patterns
I should note from the outset, there may be alternative or better ways to implement these patterns and I welcome your suggestions on ways to improve the design. The following patterns from the book Design Patterns are discussed and illustrated in Delphi to give you a starting point for implementing your own Delphi patterns.


Pattern Name Definition

Singleton "Ensure a class has only one instance, and provide a global point of access to it."

Adapter "Convert the interface of a class into another interface clients expect. Adapter lets classes work together that couldn't otherwise because of incompatible interfaces."

Template Method "Define the skeleton of an algorithm in an operation, deferring some steps to subclasses. Template Method lets subclasses redefine certain steps of an algorithm without changing the algorithm's structure."

Builder "Separate the construction of a complex object from its representation so that the same construction process can create different representations."

Abstract Factory "Provide an interface for creating families of related or dependant objects without specifying their concrete classes."

Factory Method "Define an interface for creating an object, but let subclasses decide which class to instantiate. Factory method lets a class defer instantiation to subclasses."

Iterators


Singleton пример 2

Mediator

Simpe Observer

Observer

Observer

State

State

Delegate actions and operations


-----------------------------------------------------------------------------------
Bibliography

Design Patterns: Elements of Reusable Object-Oriented Software, Erich Gamma et al., Addison-Wesley, Massachusetts, 1995.
Object Models: Strategies, Patterns and Applications, Peter Coad et al., Prentice-Hall, New Jersey, 1995.
Copyright © 1996, Objective Software Technology Pty Limited. This paper may be freely distributed in its entirety, providing the source is acknowledged.

Pattern: Singleton
Definition
"Ensure a class has only one instance, and provide a global point of access to it."


This is one of the easiest patterns to implement.

Applications in Delphi
There are several examples of this sort of class in the Delphi VCL, such as TApplication, TScreen or TClipboard. The pattern is useful whenever you want a single global object in your application. Other uses might include a global exception handler, application security, or a single point of interface to another application.

Implementation Example
To implement a class of this type, override the constructor and destructor of the class to refer to a global (interface) variable of the class.


Abort the constructor if the variable is assigned, otherwise create the instance and assign the variable.

In the destructor, clear the variable if it refers to the instance being destroyed.


Note: To make the creation and destruction of the single instance automatic, include its creation in the initialization section of the unit. To destroy the instance, include its destruction in an ExitProc (Delphi 1) or in the finalization section of the unit (Delphi 2).


The following Delphi 1 example illustrates two singleton classes, one derived from TComponent and another derived from TObject.


unit Singletn;

interface

uses
SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
Forms, Dialogs;

type
TCSingleton = class(TComponent)
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
end;

TOSingleton = class(TObject)
public
constructor Create;
destructor Destroy; override;
end;


var
Global_CSingleton: TCSingleton;
Global_OSingleton: TOSingleton;



procedure Register;

implementation

procedure Register;
begin
RegisterComponents('Design Patterns', [TCSingleton]);
end;



{ TCSingleton }
constructor TCSingleton.Create(AOwner: TComponent);

begin
if Global_CSingleton <> nil then
{NB could show a message or raise a different exception here}
Abort
else begin
inherited Create(AOwner);
Global_CSingleton := Self;
end;
end;

destructor TCSingleton.Destroy;
begin
if Global_CSingleton = Self then
Global_CSingleton := nil;
inherited Destroy;
end;

{ TOSingleton }

constructor TOSingleton.Create;
begin
if Global_OSingleton <> nil then
{NB could show a message or raise a different exception here}
Abort
else
Global_OSingleton := Self;
end;

destructor TOSingleton.Destroy;
begin
if Global_OSingleton = Self then
Global_OSingleton := nil;
inherited Destroy;
end;

procedure FreeGlobalObjects; far;
begin
if Global_CSingleton <> nil then
Global_CSingleton.Free;
if Global_OSingleton <> nil then
Global_OSingleton.Free;
end;


begin
AddExitProc(FreeGlobalObjects);
end.

---
Е т'ва е живот!

Pattern: Adapter
Definition
"Convert the interface of a class into another interface clients expect. Adapter lets classes work together that couldn't otherwise because of incompatible interfaces."

Applications in Delphi
A typical example of this is the wrapper Delphi generates when you import a VBX or OCX. Delphi generates a new class which translates the interface of the external control into a Pascal compatible interface. Another typical case is when you want to build a single interface to old and new systems.


Note Delphi does not allow class adaption through multiple inheritance in the way described in Design Patterns. Instead, the adapter needs to refer to a specific instance of the old class.

Implementation Example

The following example is a simple (read only) case of a new customer class, an adapter class and an old customer class. The adapter illustrates handling the year 2000 problem, translating an old customer record containing two digit years into a new date format. The client using this wrapper only knows about the new customer class. Translation between classes is handled by the use of virtual access methods for the properties. The old customer class and adapter class are hidden in the implementation of the unit.


unit Adapter;

interface

uses SysUtils, Classes;

type

{ The new class }
TNewCustomer = class
private
FCustomerID: Longint;
FFirstName: string;
FLastName: string;
FDOB: TDateTime;
protected
function GetCustomerID: Longint; virtual;
function GetFirstName: string; virtual;
function GetLastName: string; virtual;
function GetDOB: TDateTime; virtual;
public
constructor Create(CustID: Longint); virtual;
property CustomerID: Longint read GetCustomerID;
property FirstName: string read GetFirstName;
property LastName: string read GetLastName;
property DOB: TDateTime read GetDOB;
end;



{ An interface method }
{ Lets us hide details of TOldCustomer from the client }
function GetCustomer(CustomerID: Longint): TNewCustomer;

implementation

const
Last_OldCustomer_At_Year_2000 = 15722;
Last_OldCustomer_In_Database = 30000;

{ The new class }

constructor TNewCustomer.Create(CustID: Longint);
begin
FCustomerID := CustID;
FFirstName := 'A';
FLastName := 'New_Customer';
FDOB := Now;
end;


function TNewCustomer.GetCustomerID: Longint;
begin
Result := FCustomerID;
end;

function TNewCustomer.GetFirstName: string;
begin
Result := FFirstName;
end;

function TNewCustomer.GetLastName: string;
begin
Result := FLastName;
end;

function TNewCustomer.GetDOB: TDateTime;
begin
Result := FDOB;
end;

type
{ The old class }
TOldDOB = record
Day: 0..31;
Month: 1..12;
Year: 0..99;
end;


TOldCustomer = class
FCustomerID: Integer;
FName: string;
FDOB: TOldDOB;
public
constructor Create(CustID: Integer);
property CustomerID: Integer read FCustomerID;
property Name: string read FName;
property DOB: TOldDOB read FDOB;
end;

constructor TOldCustomer.Create(CustID: Integer);
begin
FCustomerID := CustomerID;
FName := 'An Old_Customer';
with FDOB do begin
Day := 1;
Month := 1;
Year := 1;
end;
end;

type
{ The Adapter class }
TAdaptedCustomer = class(TNewCustomer)
private
FOldCustomer: TOldCustomer;
protected
function GetCustomerID: Longint; override;
function GetFirstName: string; override;
function GetLastName: string; override;
function GetDOB: TDateTime; override;
public
constructor Create(CustID: Longint); override;
destructor Destroy; override;
end;

{ The Adapter class }
constructor TAdaptedCustomer.Create(CustID: Longint);
begin
inherited Create(CustID);
FOldCustomer := TOldCustomer.Create(CustID);
end;

destructor TAdaptedCustomer.Destroy;
begin
FOldCustomer.Free;
inherited Destroy;
end;

function TAdaptedCustomer.GetCustomerID: Longint;
begin
Result := FOldCustomer.CustomerID;
end;

function TAdaptedCustomer.GetFirstName: string;
var
SpacePos: integer;
begin
SpacePos := Pos(' ', FOldCustomer.Name);
if SpacePos = 0 then
Result := ''
else
Result := Copy(FOldCustomer.Name,1,SpacePos-1);
end;

function TAdaptedCustomer.GetLastName: string;
var
SpacePos: integer;
begin
SpacePos := Pos(' ', FOldCustomer.Name);
if SpacePos = 0 then
Result := FOldCustomer.Name
else
Result := Copy(FOldCustomer.Name,SpacePos+1,255);
end;

function TAdaptedCustomer.GetDOB: TDateTime;
var
FullYear: Word;
begin
if CustomerID > Last_OldCustomer_At_Year_2000 then
FullYear := 2000 + FOldCustomer.DOB.Year
else
FullYear := 1900 + FOldCustomer.DOB.Year;
Result := EncodeDate(FullYear, FOldCustomer.DOB.Month, FOldCustomer.DOB.Day);
end;

function GetCustomer(CustomerID: Longint): TNewCustomer;
begin
if CustomerID > Last_OldCustomer_In_Database then
Result := TNewCustomer.Create(CustomerID)
else
Result := TAdaptedCustomer.Create(CustomerID) as TNewCustomer;
end;

end.

---
Е т'ва е живот!

Pattern: Template Method
Definition
"Define the skeleton of an algorithm in an operation, deferring some steps to subclasses. Template Method lets subclasses redefine certain steps of an algorithm without changing the algorithm's structure."


This pattern is essentially an extension of abstract methods to more complex algorithms.

Applications in Delphi
Abstraction is implemented in Delphi by abstract virtual methods. Abstract methods differ from virtual methods by the base class not providing any implementation. The descendant class is completely responsible for implementing an abstract method. Calling an abstract method that has not been overridden will result in a runtime error.


A typical example of abstraction is the TGraphic class.

TGraphic is an abstract class used to implement TBitmap, TIcon and TMetafile. Other developers have frequently used TGraphic as the basis for other graphics objects such as PCX, GIF, JPG representations. TGraphic defines abstract methods such as Draw, LoadFromFile and SaveToFile which are then overridden in the concrete classes. Other objects that use TGraphic, such as a TCanvas only know about the abstract Draw method, yet are used with the concrete class at runtime.


Many classes that use complex algorithms are likely to benefit from abstraction using the template method approach. Typical examples include data compression, encryption and advanced graphics processing.

Implementation Example
To implement template methods you need an abstract class and concrete classes for each alternate implementation. Define a public interface to an algorithm in an abstract base class. In that public method, implement the steps of the algorithm in calls to protected abstract methods of the class. In concrete classes derived from the base class, override each step of the algorithm with a concrete implementation specific to that class.


This example shows some very simple alogrithm steps, but illustrates the principle of deferring implementation to a subclass.





unit Tpl_meth;

interface

type
TAbstractTemplateClass = class(TObject)
protected
function Algorithm_StepA: Integer; virtual; abstract;
function Algorithm_StepB: Integer; virtual; abstract;
function Algorithm_StepC: Integer; virtual; abstract;
public
function Algorithm: Integer;
end;

TConcreteClassA = class(TAbstractTemplateClass)
protected
function Algorithm_StepA: Integer; override;
function Algorithm_StepB: Integer; override;
function Algorithm_StepC: Integer; override;
end;

TConcreteClassB = class(TAbstractTemplateClass)
protected
function Algorithm_StepA: Integer; override;
function Algorithm_StepB: Integer; override;
function Algorithm_StepC: Integer; override;
end;

---
Е т'ва е живот!

Pattern: Builder
Definition
"Separate the construction of a complex object from its representation so that the same construction process can create different representations."


A Builder seems similar in concept to the Abstract Factory. The difference as I see it is the Builder refers to single complex objects of different concrete classes but containing multiple parts, whereas the abstract factory lets you create whole families of concrete classes. For example, a builder might construct a house, cottage or office. You might employ a different builder for a brick house or a timber house, though you would give them both similar instructions about the size and shape of the house. On the other hand the factory generates parts and not the whole. It might produce a range of windows for buildings, or it might produce a quite different range of windows for cars.

Applications in Delphi
The functionality used in Delphi's VCL to create forms and components is similar in concept to the builder. Delphi creates forms using a common interface, through Application.CreateForm and through the TForm class constructor. TForm implements a common constructor using the resource information (DFM file) to instantiate the components owned by the form. Many descendant classes reuse this same construction process to create different representations. Delphi also makes developer extensions easy. TForm's OnCreate event also adds a hook into the builder process to make the functionality easy to extend.

Implementation Example
The following example includes a class TAbstractFormBuilder and two concrete classes TRedFormBuilder and TBlueFormBuilder. For ease of development some common functionality of the concrete classes has been moved into the shared TAbstractFormBuilder class.



type
TAbstractFormBuilder = class
private
FForm: TForm;
procedure BuilderFormClose(Sender: TObject; var Action: TCloseAction);
protected
function GetForm: TForm; virtual;
public
procedure CreateForm(AOwner: TComponent); virtual;
procedure CreateSpeedButton; virtual; abstract;
procedure CreateEdit; virtual; abstract;
procedure CreateLabel; virtual; abstract;
property Form: TForm read GetForm;
end;

type
TRedFormBuilder = class(TAbstractFormBuilder)
private
FNextLeft, FNextTop: Integer;
public
procedure CreateForm(AOwner: TComponent); override;
procedure CreateSpeedButton; override;
procedure CreateEdit; override;
procedure CreateLabel; override;
end;

type
TBlueFormBuilder = class(TAbstractFormBuilder)
private
FNextLeft, FNextTop: Integer;
public
procedure CreateForm(AOwner: TComponent); override;
procedure CreateSpeedButton; override;
procedure CreateEdit; override;
procedure CreateLabel; override;
end;


At runtime the client application instructs one of the concrete classes to create parts using the public part creation procedures. The concrete builder instance is passed to the folliwing procedure:


procedure TForm1.Create3ComponentFormUsingBuilder(ABuilder: TAbstractFormBuilder);
var
NewForm: TForm;
begin
with ABuilder do begin
CreateForm(Application);
CreateEdit;
CreateSpeedButton;
CreateLabel;
NewForm := Form;
if NewForm <> nil then NewForm.Show;
end;
end;

---
Е т'ва е живот!

Pattern: Abstract Factory
Definition
"Provide an interface for creating families of related or dependant objects without specifying their concrete classes."

The Factory Method pattern below is commonly used in this pattern.

Applications in Delphi
This pattern is ideal where you want to isolate your application from the implementation of the concrete classes. For example if you wanted to overlay Delphi's VCL with a common VCL layer for both 16 and 32 bit applications, you might start with the abstract factory as a base.

Implementation Example
The following example uses an abstract factory and two concrete factory classes to implement different styles of user interface components. TOAbstractFactory is a singleton class, since we usually want one factory to be used for the whole application.


TOAbstractFactory = class(TObject)
public
constructor Create;
destructor Destroy; override;
{ abstract widget constructors }
function CreateSpeedButton(AOwner: TComponent): TSpeedButton; virtual; abstract;
function CreateEdit(AOwner: TComponent): TEdit; virtual; abstract;
function CreateLabel(AOwner: TComponent): TLabel; virtual; abstract;
end;

TORedFactory and TOBlueFactory override the abstract interface to support different widget styles.

TORedFactory = class(TOAbstractFactory)
public
{ concrete widget constructors }
function CreateSpeedButton(AOwner: TComponent): TSpeedButton; override;
function CreateEdit(AOwner: TComponent): TEdit; override;
function CreateLabel(AOwner: TComponent): TLabel; override;
end;

TOBlueFactory = class(TOAbstractFactory)
public
{ concrete widget constructors }
function CreateSpeedButton(AOwner: TComponent): TSpeedButton; override;
function CreateEdit(AOwner: TComponent): TEdit; override;
function CreateLabel(AOwner: TComponent): TLabel; override;
end;

At runtime, our client application instantiates the abstract factory with a concrete class and then uses the abstract interface. Parts of the client application that use the factory don't need to know which concrete class is actually in use.

---
Е т'ва е живот!

Pattern: Factory Method
Definition
"Define an interface for creating an object, but let subclasses decide which class to instantiate. Factory method lets a class defer instantiation to subclasses."

The Abstact Factory pattern can be viewed as a collection of Factory Methods.

Applications in Delphi
This pattern is useful when you want to encapsulate the construction of a class and isolate knowledge of the concrete class from the client application through an abstract interface.

One example of this might arise if you had an object oriented business application potentially interfacing to multiple target DBMS. The client application only wants to know about the business classes, not about their implementation-specific storage and retrieval.

Implementation Example

In the Abstract Factory example, each of the virtual widget constructor functions is a Factory Method. In their implementation we define a specific widget class to return.


TRedSpeedButton = class(TSpeedButton)
public
constructor Create(AOwner: TComponent); override;
end;

constructor TRedSpeedButton.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
Font.Color := clRed;
end;

function TORedFactory.CreateSpeedButton(AOwner: TComponent): TSpeedButton;
begin
Result := TRedSpeedButton.Create(AOwner);
end;

---
Е т'ва е живот!

Iterators provide an elegant way to iterate lists and other data structures. For those in the know, Iterators are a Design Pattern (see [GAM95]). Design PATTERNS capture good practices of designing software systems. I strongly recommend reading this book.

In order to demonstrate the iterator pattern, I designed the following classes:

TMyItem = class
private
FValue: boolean;
FName: string;
public
property Name: string read FName write FName;
property Value: boolean read FValue write FValue;
end;

TMyListIterator = class
private
FList: TMyList;
FIndex: integer;
protected
constructor Create(List: TMyList);
public
procedure First;
procedure Next;
function IsDone: boolean;
function CurrentItem: TMyItem;
end;

TMyList = class
private
FList: TList;
function GetItem(Index: integer): TMyItem;
procedure SetItem(Index: integer; const Value: TMyItem);
function GetCount: integer;
public
constructor Create;
destructor Destroy; override;
procedure Add(Item: TMyItem);
procedure Delete(const Index: integer);
procedure Clear;
procedure Iterator(var Iter: TMyListIterator);
property Count: integer read GetCount;
property Items[Index: integer]: TMyItem read GetItem write SetItem; default;
end;

As you can see, the TMyList class is a simple type-safe list wrapper that has the capability of handing out an iterator to the client (the code which uses the list).

But how do we use the iterator? Letдs take a look at the way we normally would traverse this list:

procedure OldFashioned;
var
idx: integer;
item: TMyItem;
begin
for idx := 0 to
item := FMyList[idx];
Listbxo1.Items.Add(item.Name);
end;
end;

The problem with the above code is that we cannot see what is really happening. A for loop can have many meanings, for example adding some numbers. But we cannot judge from the mere existance of a for loop that the code traverses a list.

Enter iterator!
The same code fragment using an iterator looks like this:

procedure TheRightWay;
var
iter: TMyIterator;
item: TMyItem;
begin
FMyList.Iterator(Iter);

while not Iter.IsDone do begin
item := iter.CurrentItem;
Listbox1.Items.Add(item.Name);
Iter.Next;
end;

end;

We can judge from the presence of the iterator that this must be some code that traverses a list or some other structure. Those of you who already have used the FindFirst/FindNext functions will see the resemblance of this code fragment with the one used commonly to list the contents of a directory.

In my opinion, iterators are much easier to use than for loops once you understand them. One of their advantages is that you can write for example a reverse iterator that traverses the list in reverse order. If you do so, you won't have to chaneg the client code, since all the traversation logic is handled by the iterator.

Sample code:

///////////////////////////////
unit ListIterator;
///////////////////////////////

interface

uses Classes;

type

TMyItem = class;
TMyList = class;
TMyListIterator = class;

TMyItem = class
private
FValue: boolean;
FName: string;
public
property Name: string read FName write FName;
property Value: boolean read FValue write FValue;
end;

TMyListIterator = class
private
FList: TMyList;
FIndex: integer;
protected
constructor Create(List: TMyList);
public
procedure First;
procedure Next;
function IsDone: boolean;
function CurrentItem: TMyItem;
end;

TMyList = class
private
FList: TList;
function GetItem(Index: integer): TMyItem;
procedure SetItem(Index: integer; const Value: TMyItem);
function GetCount: integer;
public
constructor Create;
destructor Destroy; override;
procedure Add(Item: TMyItem);
procedure Delete(const Index: integer);
procedure Clear;
procedure Iterator(var Iter: TMyListIterator);
property Count: integer read GetCount;
property Items[Index: integer]: TMyItem read GetItem write SetItem; default;
end;

implementation

{ TMyListIterator }

constructor TMyListIterator.Create(List: TMyList);
begin
inherited Create;
FList := List;
FIndex := 0;
end;

procedure TMyListIterator.First;
begin
FIndex := 0;
end;

procedure TMyListIterator.Next;
begin
inc(FIndex);
end;

function TMyListIterator.IsDone: boolean;
begin
Result := FIndex >= FList.Count;
end;

function TMyListIterator.CurrentItem: TMyItem;
begin
Result := nil;
if FIndex < FList.Count then
Result := FList[FIndex];
end;

{ TMyList }

constructor TMyList.Create;
begin
inherited Create;
FList := TList.Create;
end;

destructor TMyList.Destroy;
begin
FList.Free;
inherited;
end;

procedure TMyList.Add(Item: TMyItem);
begin
FList.Add(Item);
end;

procedure TMyList.Clear;
begin
FList.Clear;
end;

procedure TMyList.Delete(const Index: integer);
begin
FList.Delete(Index);
end;

function TMyList.GetCount: integer;
begin
Result := FList.Count;
end;

function TMyList.GetItem(Index: integer): TMyItem;
begin
Result := FList[Index];
end;

procedure TMyList.SetItem(Index: integer; const Value: TMyItem);
begin
if FList[Index] <> nil then
TMyItem(FList[Index]).Free;

FList[Index] := Value;
end;

procedure TMyList.Iterator(var Iter: TMyListIterator);
begin
Iter := TMyListIterator.Create(self);
end;

end.


///////////////////////////////
unit TestMain;
///////////////////////////////

interface

uses
Windows, Messages, SysUtils,
Classes, Graphics, Controls,
Forms, Dialogs, StdCtrls,
ListIterator;

type
TForm1 = class(TForm)
Button1: TButton;
Button2: TButton;
ListBox1: TListBox;
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
private
FMyList: TMyList;
public
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.Button1Click(Sender: TObject);
var
item: TMyItem;
i: integer;
begin
if FMyList = nil then
FMyList := TMyList.Create;

for i := 0 to 10 do begin
item := TMyItem.Create;
item.Name := 'Test' + inttostr(i);
item.Value := true;
FMyList.Add(item);
end;
end;

procedure TForm1.Button2Click(Sender: TObject);
var
iter: TMyListIterator;
item: TMyItem;
begin

FMyList.Iterator(Iter);

while not Iter.IsDone do begin
item := iter.CurrentItem;
Listbox1.Items.Add(item.Name);
Iter.Next;
end;

end;

end.

References:
[GAM95] Gamma, Erich; Helm, Richard; Johnson, Ralph; Vlissides, John: Design PATTERNS - Elements of Reusable Object-Oriented Software. Reading, MA: Addison-Wesley, 1995

---
Е т'ва е живот!

The singleton design pattern defines a variation to the normal Object - Class relation. The variation is that the class creates only one object for all the application, and returns that one object any time someone requests an object of that class.
Note that TComponent cannot be singleton, as TComponent object lifetime is handled by a owner, and a TComponent can have only one owner. Two owners cannot share the same object, so TComponent cannot be Singleton.

Implementing singleton:

There are two ways to implement singleton objects:
1. Add a class function GetInstance, that returns the singleton instance.
This method has the problem of allowing users to create new object using
the Create function.
2. Change the Create function to return the singleton instance.

I have taken the second way. Why? Any function in delphi must have a return type, and this return type for a base singleton class can only be TSingelton. This will force users to typecast the result of the GetInstance function to the tree type of the singleton.

MySingleton := (TMySingleton.GetInstance) as TMySingleton;

However, a constructor allways returns the class beeing constructed. This removes the need to typecast.

MySingleton := TMySingleton.create;

You can also add a new constructor to the TSingleton class called GetInstance, then you will get the following result.

MySingleton := TMySingleton.GetInstance;

So I selected to change the behaviour of the constructors of the TSingleton class. I want the constructor to return a single instance of the object, allways.

In order to make an object singleton, one need to override some functions
of the TObject class:

class Function NewInstance: TObject;
This function allocates memory for a new object. It is called each time a client calls any constructor. This function should allocate memory only the first time an object is created, and return this memory at each following call.

Procedure FreeInstance;
This function free's the memory allocated for the object. It is called
each time a destructor is called.
Normaly a singleton object is destroyed in the Finalization of the unit, so
override this function and leave it empty.

Example:

The example is a two classes I use in some applications, and it includes two classes:
TSingleton - a class that implements the singleton pattern making any decendant classes singletons.
TInterfacedSingleton - The same as TSingleton, only implementing the IUnknown interface (Objects of this class are freed at the Finalization or later if there is another reference to them). This singleton class was usefull at one time, and I thought that it is a nice idea.

How to use the two following classes - Derive a new class from one. If you need any initialization done for you're singleton class, override the Init function. If you need any finalization, override the BeforeDestroy function. To get an instance of the singleton, simply write TMySingletonClass.Create;

Notes:

1. The singelton idea does not require to inherit from one TSingleton base class. The code is just one example, and the implementation is not the pattern. The pattern is the idea itself.

2. The following example is not thread safe. In order to create a thread safe version, you need to make the following functions thread safe:
* TSingleton.NewInstance
* TInterfacedSingleton.NewInstance
* ClearSingletons



The code:


unit uSingleton;

interface

Uses
SysUtils;

Type
TSingleton = class(TObject)
Private
Procedure Dispose;
protected
Procedure Init; Virtual;
Procedure BeforeDestroy; Virtual;
Public
class Function NewInstance: TObject; Override;
Procedure FreeInstance; Override;
End;

TInterfacedSingleton = class(TInterfacedObject, IUnknown)
Private
Procedure Dispose;
protected
Procedure Init; Virtual;
Public
class Function NewInstance: TObject; Override;
Procedure FreeInstance; Override;
Function _AddRef: Integer; stdcall;
Function _Release: Integer; stdcall;
End;


implementation

Var
SingletonHash: TStringList;
// In my original code I use a true Hash Table, but as delphi does not provide
// one built it, I replaced it here with a TStringList. It should be easy
// to replace with a true hash table if you have one.

{ General}

Procedure ClearSingletons;
Var
I: Integer;
Begin
// call BeforeDestroy for all singleton objects.
For I := 0 to SingletonHash.Count - 1 do
Begin
If SingletonHash.Objects Is TSingleton then
Begin
TSingleton(SingletonHash.Objects).BeforeDestroy;
End
End;

// free all singleton and InterfacedSingleton objects.
For I := 0 to SingletonHash.Count - 1 do
Begin
If SingletonHash.Objects Is TSingleton then
Begin
TSingleton(SingletonHash.Objects).Dispose;
End
Else
TInterfacedSingleton(SingletonHash.Objects)._Release;
End;
End;

{ TSingleton }


Procedure TSingleton.BeforeDestroy;
Begin

End;

Procedure TSingleton.Dispose;
Begin
Inherited FreeInstance;
End;

Procedure TSingleton.FreeInstance;
Begin
//
End;


Procedure TSingleton.Init;
Begin

End;

class function TSingleton.NewInstance: TObject;
Var
Singleton: TSingleton;
Begin
If SingletonHash = Nil then
SingletonHash := TStringList.Create;
If SingletonHash.IndexOf(Self.ClassName) = -1 then
Begin
Singleton := TSingleton(Inherited NewInstance);
Try
Singleton.Init;
SingletonHash.AddObject(Self.ClassName, singleton);
Except
Singleton.Dispose;
Raise;
End;
End;
Result := SingletonHash.Objects[SingletonHash.IndexOf(Self.ClassName)] as TSingleton;
End;

{ TInterfacedSingleton }

procedure TInterfacedSingleton.Dispose;
Begin
Inherited FreeInstance;
End;

procedure TInterfacedSingleton.FreeInstance;
Begin
//
End;

procedure TInterfacedSingleton.Init;
Begin

End;

class function TInterfacedSingleton.NewInstance: TObject;
Var
Singleton: TInterfacedSingleton;
Begin
If SingletonHash = Nil then
SingletonHash := TStringList.Create;
If SingletonHash.IndexOf(Self.ClassName) = -1 then
Begin
Singleton := TInterfacedSingleton(Inherited NewInstance);
Try
Singleton.Init;
SingletonHash.AddObject(Self.ClassName, singleton);
Singleton._AddRef;
Except
Singleton.Dispose;
Raise;
End;
End;
Result := SingletonHash.Objects[SingletonHash.IndexOf(Self.ClassName)] as TInterfacedSingleton;
End;

function TInterfacedSingleton._AddRef: Integer;
Begin
Result := Inherited _AddRef;
End;

function TInterfacedSingleton._Release: Integer;
Begin
Result := Inherited _Release;
End;

Initialization
SingletonHash := Nil;

Finalization
If SingletonHash <> Nil then
ClearSingletons;
SingletonHash.Free;

End.

---
Е т'ва е живот!

'Object oriented design encourages the distribution of behaviour among objects. Such distribution can result in an object structure with many connections between objects; in the worst case, every object ends up knowing about every other.

Though partitioning a system into many objects generally enhances reusability, proliferating interconnections tend to reduce it again. Lots of interconnections make it less likely that an object can work without the support of others - the system acts as though it were monolithic. Moreover it can be difficult to change the systems' behaviour in any significant way, since behaviour is distributed among many objects. As a result, you may be forced to define many subclasses to customise the system's behaviour.' [Gam+ page 273].

Although there's a lot more to tell about mediators, we won't get into details here, please refer to [Gam+]. That's not because you don't need mediators, but because you already are familiar with them: Delphi provides great mediators.

Developers at Borland probably were aware of the above mentioned paragraphs when designing the Delphi Object Pascal language and the VCL components. Their solution to this problem is essentially: events (or method pointers). The use of events makes de-coupling of objects possible. The class TForm is their standard mediator class which handles (wires) events from components put on the form. They even delivered a great tool with it: the Object Inspector. Being able to delegate behaviour to another class using events, saves you, for example, from subclassing TButton when you need a button that interacts with an TEdit control. The mediator is the form which handles all events and takes corresponding actions, coupling all related components together with snippets of code. Great. So what's the need for a Mediator pattern?

Delphi's Object Inspector uses RTTI and form designers to create event handlers on forms and Delphi's component streaming mechanism takes care of actually wiring these events at run time.

If you ever manually created event handlers you know that you have to:
Create a event handler method with the correct parameter list and possibly the correct function result. Wire the event handler to the event with code like:

FSample.OnChange := SampleChange;
Make sure you unwire the event again in appropriate cases to avoid wired objects from calling destroyed or otherwise illegal objects.

In order to construct a correct event handler method it needs the event type definition. The mediator pattern relies on these event type definitions to construct and update event handlers.

Implementation

Suppose we've created a class TComPort which encapsulates a serial port device driver. This class defines a series of events to asynchronously inform clients of state changes: data triggers, line errors etc. A TController class could 'use a' TComPort class to transmit data through a serial port.
__________ _____________
| TController| <>-------------- | TComPort |
---------------- ComPort --------------------

This TController class would typically wire and handle the Comport events to update it’s internal state. Here’s an abstract of the interface and implementation of TComport and TController without the mediator:

type
TLineEvent = procedure (Sender: TObject; Error: TLineError) of object;
TTriggerEvent = procedure (Sender: TObject; Trigger: TTrigger) of object;

TComPort = class (TObject)
published
property OnDataReceived: TTriggerEvent read FOnDataReceived
write FOnDataReceived;
property OnLineEvent: TLineEvent read FOnLineEvent write FOnLineEvent;
property OnTimeOut: TNotifyEvent read FOnTimeOut write FOnTimeOut;
property OnTransmitted: TNotifyEvent read FOnTransmitted write
FOnTransmitted;
end;

TController = class (TObject)
private
FComPort: TComPort;
public
constructor Create;
destructor Destroy; override;
property ComPort: TComPort read FComPort;
end;

implementation

constructor TController.Create;
begin
inherited Create;
FComPort := TComPort.Create;
end;

destructor TController.Destroy;
begin
FComPort.Free;
inherited Destroy;
end;

Now have a look at the same abstract for class TController with the mediator applied to this structure:

TController = class (TObject)
private
FComPort: TComPort;
protected
procedure ComPortDataReceived(Sender: TObject; Trigger: TTrigger);
procedure ComPortLineEvent(Sender: TObject; Error: TLineError);
procedure ComPortTimeOut(Sender: TObject);
procedure ComPortTransmitted(Sender: TObject);
procedure UnwireComPort;
procedure WireComPort;
public
constructor Create;
destructor Destroy; override;
property ComPort: TComPort read FComPort;
end;

implementation

constructor TController.Create;
begin
inherited Create;
FComPort := TComPort.Create;
{ now wire comport calling the method created by the mediator }
WireComport;
end;

destructor TController.Destroy;
begin
{ make sure the comport is unwired again }
UnwireComport;
FComPort.Free;
inherited Destroy;
end;

procedure TController.ComPortDataReceived(Sender: TObject; Trigger: TTrigger);
begin
end;

procedure TController.ComPortLineEvent(Sender: TObject; Error: TLineError);
begin
end;

procedure TController.ComPortTimeOut(Sender: TObject);
begin
end;

procedure TController.ComPortTransmitted(Sender: TObject);
begin
end;

procedure TController.UnwireComPort;
begin
FComPort.OnDataReceived := nil;
FComPort.OnLineEvent := nil;
FComPort.OnTimeOut := nil;
FComPort.OnTransmitted := nil;
end;

procedure TController.WireComPort;
begin
FComPort.OnDataReceived := ComPortDataReceived;
FComPort.OnLineEvent := ComPortLineEvent;
FComPort.OnTimeOut := ComPortTimeOut;
FComPort.OnTransmitted := ComPortTransmitted;
end;

In this example notice: The wiring of the comport in constructor Create by a call to WireComPort. This method is optionally created by the mediator. The corresponding unwiring in destructor Destroy by a call to UnwireComPort. This method is optionally created by the mediator. The event handler methods which all have the correct signature (as defined in the event library), just like the Object Inspector would do.


Literature:
Design PATTERNS, Elements of Reusable Object-Oriented Software
from Erich Gamma, Richard Helm, Ralph Johnson, John Vlissides
Addison Wesley; ISBN 0-201-63361-2

---
Е т'ва е живот!

To make, for example a form, avare of changes in another object we can
add a notify event to that object and implement some method to it. But
in that case only one observer can exist for that class. If more than
one class has to get notified of changes in the class, we have to implement some kind of list with events. This is best implemented with an Observer-pattern.

And here we have our little version of the pattern :).

The unit Observer_un consists of two classes
TObserverItem wich is the container for one "observation" event
TObserverMgr Maintains a list of TObserverItem and has a method for
running registered observers

For clarity we call the classes thats going to use these for observation
TObserver : The class that want to get notified of changes
TChanger : The class that changes

To use this you start with the class you want others to be able to
observe (TChanger), and implement a private field for TObserverMgr.
Then to avoid need for coupling between observer and TObserverMgr you
implement two methods, AddObserver and RemoveObserver in the changer
which just forwards the methods to TObserverMgr.

procedure TChanger.AddObserver(aNotifyEvent: TNotifyEvent; Observer: TObject);
begin
// Forwarding method call, Observer should not need to know about fObserverMgr
fObserverMgr.AddObserver(aNotifyEvent, Observer);
end;

Now if you want to observe the field FMyString in changer you implement
a property MyString with a set method

Could look like this

procedure TChanger.SetMyStr( value : String )
begin
FMyString := Value ;
// And now we want to call all the observers
FObserverMgr.RunObservers ;
end;


Ok its esier for you to understand the source so look below or in Observer.zip
which has an example also.

/Christer & Fredrik

unit Observers_un;

interface
uses
contnrs, classes;

type

{{
Item for holding an observer and one of its TNotifyEvents.
}
TObserverItem = class
private
FObserved: TObject;
FObserver: TObject;
FOnChange: TNotifyEvent;
protected
constructor Create(theObserved: TObject);
public
procedure Change;
property Observer: TObject read FObserver write FObserver;
property OnChange: TNotifyEvent read FOnChange write FOnChange;
end;

{{
Class for managing ObserverItems.

Holds methods for inserting deleting and running
ObserverItems.
}
TObserverMgr = class (TObject)
private
FObserved: TObject;
FObserverList: TObjectList;
function FindMatch(aNotifyEvent: TNotifyEvent; Observer: TObject): Integer;
public
constructor Create(Owner : TObject);
procedure AddObserver(aNotifyEvent : TNotifyEvent ; Observer : TObject);
procedure RemoveObserver(aNotifyEvent : TNotifyEvent ; Observer : TObject);
procedure RunObservers;
end;

implementation

{
****************************************** TObserverItem *******************************************
}
constructor TObserverItem.Create(theObserved: TObject);
begin
inherited Create ;

FObserved := theObserved ;
end;

procedure TObserverItem.Change;
begin
if Assigned(FOnChange) then
FOnChange( FObserved ) ;
end;

{
******************************************* TObserverMgr *******************************************
}
constructor TObserverMgr.Create(Owner : TObject);
begin
inherited Create ;
FObserved := Owner ;
FObserverList := TObjectList.Create;
FObserverList.OwnsObjects := true;
end;

procedure TObserverMgr.AddObserver(aNotifyEvent : TNotifyEvent ; Observer : TObject);
var
anItem: TObserverItem;
begin
if (0 > FindMatch(aNotifyEvent, Observer)) then
begin
anItem := TObserverItem.Create(FObserved) ;
anItem.OnChange := aNotifyEvent ;
anItem.Observer := Observer ;
FObserverList.Add(anItem) ;
end ;
end;

function TObserverMgr.FindMatch(aNotifyEvent: TNotifyEvent; Observer: TObject): Integer;
var
I: Integer;
anItem: TObserverItem;

// Check if this Observer and notify event exists in FObserverList
// Result is -1 if not present, else it's the index in FObserverList
//
// If aNotifyEvent is Nil then the first item with the same observer will
// return it's index
//

begin
result := -1 ;

For I := 0 to FObserverList.count-1 do
begin
anItem := TObserverItem( FObserverList.Items ) ;

if anItem.Observer = Observer then
begin
if @aNotifyEvent = nil then
begin
result := I ;
exit ;
end
else if (@anItem.OnChange = @aNotifyEvent) then
begin
result := I ;
exit ;
end ;
end ;
end ;
end;

procedure TObserverMgr.RemoveObserver(aNotifyEvent : TNotifyEvent ; Observer : TObject);
var
I: Integer;
begin
// If aNotifyEvent is Nil then we loop through the list
// and removes all items with this observer
repeat
I := FindMatch(aNotifyEvent, Observer) ;
if (I >= 0) then FObserverList.Delete(I) ;
until (I < 0) ;
end;

procedure TObserverMgr.RunObservers;
var
I: Integer;
anObserver: TObserverItem;
begin
For I := 0 to FObserverList.Count - 1 do
begin
anObserver := TObserverItem( FObserverList.items );
anObserver.Change ;
end ;
end;

end.

---
Е т'ва е живот!

Sometimes, there is a need to notify many different objects about a state change. My favorite solution to this problem is the Observer pattern, described in Design PATTERNS. (I highly recommend this book). Roughly, this PATTERNS describe a way for objects that want to be notified of a change (called the Observers) to register themselves with the subject (called the Subject :). This subject then has the responsability to notify all it's observers when it's internal state changes.



And this is where we encounter our first problem. How does the Subject notify it's Observers? By calling one of the Observer's method. But this means the Subject has to know the Observer somehow, not very flexible. We could use an abstract Observer class, in that way our Subject would always be able to call a known method, but this would force us to always descend observers from the same hiearchy, which is not very practical (and sometimes completely impossible).



Fortunately, for each problem there is a solution, and in our case there are at least TWO!



The first solution is to use Interfaces. Our Subject would accept an IObserver interface. The neat thing about interfaces is that any class can implement any interface, and as long as an object would implement IObserver, it would be able to connect to any subject. (If anyone is interested in this implementation, let me know and I'll post another article, but there are gazillions of examples on the net if you search a little). This works perfectly, but after working with interfaces a little, I decided not to use them. The main reason for this is that code navigation in the IDE is harder, Ctrl-Click brings you to the interface definition, not the implementation. No big deal. But I wanted something better.



The second solution, the one I'm describing in this article, is a little different. The Observer is no longer an object, it's a method. Just like standard VCL events. This means that a single event handler could be used with a component and a Subject at the same time.



Let say we have a TSubject with an event called OnChange. This event is of type TMultiNotifyEvent. Here is how a user would connect to this event. ChangeHandler is a procedure matching a TNotifyEvent.

MySubject.OnChange.Attach(ChangeHandler);

From that point on, every time MySubject changes, it will call ChangeHandler, just like a normal OnChange event. The difference is that there might be many observers of that event. When the object no longer wish to receive updates from MySubject, it detaches:

MySubject.OnChange.Detach(ChangeHandler);

In order for TMySubject to use a TMultiNotifyEvent, it must create it like this:


type
TMySubject = class
private
FOnChange: TMultiNotifyEvent;
protected
procedure DoChange; virtual;
public
constructor Create;
destructor Destroy; override;
property OnChange: TMultiNotifyEvent read FOnChange;
end;

implementation

constructor TMySubject.Create;
begin
inherited;
FOnChange := TMultiNotifyEvent.Create;
end;

destructor TMySubject.Destroy;
begin
FOnChange.Free;
inherited;
end;

procedure TMySubject.DoChange;
begin
{ Signal is the method that notify every observers }
OnChange.Signal(Self);
end;




In order to use a new type of event, one must declare a new class inheriting from TMultiEvent. Why am I doing this? Because TMultiEvent only stores and knows about TMethod records, it does not know what type of event is used, what are it's parameters, etc. By having the SignalObserver method Abstract, each concrete class can typecast it to the type of events it handles and pass all the required parameters. Also, creating a new class provices a certain level of type by making sure you register a compatible method with the subject. See TMultiNotifyEvent at the end of this article to see how to create customized events, it's pretty straight forward.



That's it for the explication, if you have any questions just leave a comment and I'll try to update the article accordingly.




--------------------------------------------------------------------------------


unit uMultiEvent;

interface

uses
Classes, SysUtils;

type
TMultiEvent = class
private
FObservers: TList;
protected
function FindObserver(Observer: TMethod): integer;
function GetObserver(Index: integer): TMethod;
procedure SignalObserver(Observer: TMethod); virtual;
public
constructor Create;
destructor Destroy; override;

procedure Attach(Observer: TMethod);
procedure Detach(Observer: TMethod);

procedure Signal;
end;

TMultiNotifyEvent = class(TMultiEvent)
private
FSender: TObject;
protected
procedure SignalObserver(Observer: TMethod); override;
public
procedure Attach(Observer: TNotifyEvent);
procedure Detach(Observer: TNotifyEvent);

procedure Signal(Sender: TObject);
end;

implementation

{ TEvent }

procedure TMultiEvent.Attach(Observer: TMethod);
var
Index: integer;
begin
Index := FindObserver(Observer);

{ This assertion is facultative, we could just ignore observers }
{ already attached, but it's a good way to detect problems early }
{ and avoid unnecessary processing. }

Assert(Index < 0, 'This observer was already attached to this event');

{ A method contains two pointers: }
{ - The code pointer, that's where the procedure is in memory }
{ - The data pointer, this tells Delphi what instance of the }
{ object calls the procedure }
{ We must store both pointers in order to use that callback. }

if Index < 0 then
begin
FObservers.Add(Observer.Code);
FObservers.Add(Observer.Data);
end;
end;

constructor TMultiEvent.Create;
begin
inherited;
FObservers := TList.Create;
end;

destructor TMultiEvent.Destroy;
begin
{ This assertion is facultative, but I prefer when all my objects }
{ are "clean" when they are destroyed. }
Assert(FObservers.Count = 0, 'Not all observers were detached');
FreeAndNil(FObservers);
inherited;
end;

procedure TMultiEvent.Detach(Observer: TMethod);
var
Index: integer;
begin
Index := FindObserver(Observer) * 2;

{ Again, the assertion is facultative, nothing would be broken }
{ if we just ignored it. }
Assert(Index >= 0, 'The observer was not attached to this event');

if Index >= 0 then
begin
FObservers.Delete(Index); // Delete code pointer
FObservers.Delete(Index); // Delete data pointer
end;
end;

function TMultiEvent.FindObserver(Observer: TMethod): integer;
var
i: integer;
begin
{ Search fails by default, if there is a match, result will be updated. }
Result := -1;
for i := (FObservers.Count div 2)-1 downto 0 do
begin
{ We have a match only if both the Code and Data pointers are the same. }
if (Observer.Code = FObservers[i * 2 ]) and (Observer.Data = FObservers[i * 2 + 1]) then
begin
Result := i;
break;
end;
end;
end;

function TMultiEvent.GetObserver(Index: integer): TMethod;
begin
{ Fill the TMethod record with the code and data pointers. }
Result.Code := FObservers[Index * 2];
Result.Data := FObservers[Index * 2 + 1];
end;

procedure TMultiEvent.SignalObserver(Observer: TMethod);
begin
{ Descendants must take care to notify the Observer by themselves }
{ because we cannot know the parameters required by the event. }

Assert(Assigned(@Observer));
{ We could make this method Abstract and force descendants, but }
{ I prefer to do a run-time check to validate the passe methods }
end;


procedure TMultiEvent.Signal;
var
i: integer;
begin
{ Call SignalObserver for each stored observers in reverse order. }

{ SignalObserver (which is declared in sub-classes) will typecast }
{ the TMethod record into whatever procedure type it handles. }
{ See the TMultiNotifyEvent below for an example. }

for i := (FObservers.Count div 2)-1 downto 0 do
begin
SignalObserver(GetObserver(i));
end;
end;

{ TMultiNotifyEvent }

procedure TMultiNotifyEvent.Attach(Observer: TNotifyEvent);
begin
inherited Attach(TMethod(Observer));
end;

procedure TMultiNotifyEvent.Detach(Observer: TNotifyEvent);
begin
inherited Detach(TMethod(Observer));
end;

procedure TMultiNotifyEvent.Signal(Sender: TObject);
begin
FSender := Sender;
inherited Signal;
end;

procedure TMultiNotifyEvent.SignalObserver(Observer: TMethod);
begin
inherited;
TNotifyEvent(Observer)(FSender);
end;

end.

---
Е т'ва е живот!

A Memento is an object that stores a snapshot of the
internal state of another object - the memento's originator,
according to Gamma, Helm, Johnson and Vlissides
("Design PATTERNS", Addision-Wesley, 1995)

In the following example the originator class is a class that
does some calculations named "tCalculator". The recall-class
must be a friend class of the originator class in order to
access the private variables that characterize the current state.
In delphi you can realize this if the two classes are defined
in the same unit.

A concrete implementation of the Memento design pattern looks
like this :

tCalculator = class
private
ValueA,ValueB,Interval : extended;
Strings : TStringList;
public
...
end;

tCalculatorRecall = class
private
RefObject : tCalculator;
ValueA,ValueB,Interval : extended;
Strings : TStringList;
public
constructor Create(Calculator : tCalculator);
destructor Destroy; override;
end;

constructor tCalculatorRecall.Create(Calculator: tCalculator);
begin
inherited Create;
RefObject := Calculator;
ValueA := RefObject.ValueA;
ValueB := RefObject.ValueB;
Interval := RefObject.Interval;

Strings := TStringList.Create;
Strings.Assign(RefObject.Strings);
end;

destructor tCalculatorRecall.Destroy;
begin
RefObject.ValueA := ValueA;
RefObject.ValueB := ValueB;
RefObject.Interval := Interval;

RefObject.Strings.Assign(Strings);
Strings.Free;
inherited Destroy;
end;


The following lines demonstrate how to use this class :

// Store state of object
CalculatorRecall:=tCalculatorRecall.Create(Calculator);

// Change the state of object to do some calculations
Calculator.ValueA := ...
Calculator.DoSomething;

// Restore the original state
CalculatorRecall.Destroy;



Examples from the VCL for the Memento Design Pattern
are tFontRecall, tPenRecall and tBrushRecall, three
new available classes in Delphi 6 that are derived from TRecall.
Of course you can also define your own classes in this way.
If you do this, consider two important points :

* Derive the originator class from TPersistent
* Implement the Assign procedure

Then our example looks like this :

TCalculator = class(TPersistent)
private
ValueA,ValueB,Interval : extended;
Strings : TStringList;
...
public
...
procedure Assign(Source: TPersistent); override;
...
end;

TCalculatorRecall = class(TRecall)
public
constructor Create(ACalculator : TCalculator);
end;

procedure tCalculator.Assign(Source: TPersistent);
var RefObject : tCalculator;
begin
if Source is tCalculator then
begin
RefObject := Source as tCalculator;
ValueA := RefObject.ValueA;
ValueB := RefObject.ValueB;
Interval := RefObject.Interval;
...
Strings.Assign(RefObject.Strings);
...
end else
inherited Assign(Source);
end;

constructor TCalculatorRecall.Create(ACalculator: TCalculator);
begin
inherited Create(TCalculator.Create, ACalculator);
end;

---
Е т'ва е живот!

Most programs provide toolbars with different tools. For
example Zoom-Buttons, Paint-Buttons (drawing of circles,
rectangles,.. ). When the Zoom-Button is pressed, the
user can zoom in or out, when the Paint-Button is pressed,
the user can paint s.th : each tool changes the behavior of
the program. You can realize this through different flags :

procedure TForm.FormMouseDown/FormMouseMove/FormMouseUp
begin
..
if fZoomFlag then
begin
...
end else
if fPaintFlag then
begin
...
end;
..
end;

Even if we want to create a simple program like MSPaint,
we will need a lot of flags :
fPenFlag, fDrawRectFlag, fDrawCircleFlag, fEraserFlag,...
This results in 'elephant'-procedures and a general view
becomes difficult.

You can avoid such 'elephant'-procedures through the state
design pattern. Gamma, Helm, Johnson and Vlissides
("Design PATTERNS", Addision-Wesley, 1995) define the
STATE design pattern in this way : it allows an object
to alter its behavior when its internal state changes.
The object will appear to change its class.

In our example, the behavior for each tool is encapsulated
in a different class :


tTool = class
private
fForm : tForm;
public
constructor Create(Form : TForm);
destructor Destroy; override;

procedure SetCursor; virtual;
procedure HandleMouseDown(x,y : integer); virtual;
procedure HandleMouseMove(x,y : integer); virtual;
procedure HandleMouseUp(x,y : integer); virtual;

procedure StopAction; virtual;
end;

tZoomTool = class(tTool)
public
procedure SetCursor; override;
procedure HandleMouseDown(x,y : integer); override;
procedure HandleMouseMove(x,y : integer); override;
procedure HandleMouseUp(x,y : integer); override;
end;

tPaintTool = class(tTool)
public
procedure SetCursor; override;
procedure HandleMouseDown(x,y : integer); override;
procedure HandleMouseMove(x,y : integer); override;
procedure HandleMouseUp(x,y : integer); override;
end;

Now we can replace all the flags by a simple parameter
fTool of class tTool. Instead of setting different flags,
an object of a derived class is created :

procedure TForm.SetZoomModus;
begin
fTool.Destroy;
fTool := tZoomTool.Create(Self);
end;

procedure TForm.SetPaintModus;
begin
fTool.Destroy;
fTool := tPaintTool.Create(Self);
end;


So that in the MouseDown/MouseMove/MouseUp events the
appropriate method is called :

procedure TForm.FormMouseDown(... X, Y: Integer);
begin
fTool.HandleMouseDown(x,y);
end;

procedure TForm.FormMouseMove(... X, Y: Integer);
begin
fTool.HandleMouseMove(x,y);
end;

procedure TForm.FormMouseUp(... X, Y: Integer);
begin
fTool.HandleMouseUp(x,y);
end;

---
Е т'ва е живот!

The Choice Pattern needs one interface, n-classes which supports the interface and a worker-class to provide the choice of an algorithm at runtime. The Choice Pattern is like the Strategy Pattern, but smaller and more runtime in his behaviour.

With interfaces we don't have to concern about memory management.
Interface references are managed through reference-counting, which depends on the _AddRef and _Release methods inherited from IUnknown. When an object is referenced only through interfaces, there is no need to destroy it manually; the object is automatically destroyed when the last reference
to it goes out of scope.

The following restrictions apply.
- The member List can include only methods and properties.
- Fields are not allowed in interfaces.
- Interfaces have no constructors or destructors. They cannot be instantiated, except through classes that implement their methods.

Methods cannot be declared as virtual, dynamic, abstract, or override. Since interfaces do not implement their own methods, these bindings have no meaning. So let's practice the Choice Pattern in 5 steps:


1. We need an Interface in order to be type-compatible.

IChoicePattern = Interface
procedure doPATTERNSearch;
end;


2. We declare 2 or n classes.
A class from an Interface can support/implement multiple interfaces. TInterfacedObject implements the methods of IUnknown, so TInterfacedObject automatically handles reference counting and memory management of interfaced objects.
One of the concepts behind the design of interfaces is ensuring the lifetime management of the objects that implement them. The AddRef and Release methods of IUnknown provide a way of implementing this functionality.


TCheckFormatA = class(TInterfacedObject, IChoicePattern)
public
procedure doPATTERNSearch;
end;

TCheckFormatB = class(TInterfacedObject, IChoicePattern)
public
procedure doPATTERNSearch;
end;


3. We need a worker-class which calls the runtime Interface-methods:

TDirWorker = class
procedure callCheck(myInst: IChoicePattern);
end;



4. Now we implement the Interface Classes and the Worker Class too:

procedure TCheckFormatA.doPATTERNSearch;
var ldbPath: string;
begin
if FileExists(extractFileDir(application.exeName)+'\'+ DBNAME) then
ldbPath:=extractFileDir(application.exeName)+'\'+DBNAME;
messageDlg('formatASearch doing', mtInformation,[mbok],0);
end;


procedure TCheckFormatB.doPATTERNSearch;
var ldbPath: string;
begin
if OpenDialog1.Execute then
ldbPath:=openDialog1.FileName;
messageDlg('formatBSearch doing', mtInformation,[mbok],0);
end;


procedure TDirWorker.callCheck(myInst: IChoicePattern);
begin
myInst.doPATTERNSearch;
messageDlg('do_some_Work', mtInformation,[mbok],0);
end;

Here we can see, no myInst.Free is needed. Each object from TCheckFormatA or TCheckFormatB is automatically destroyed. Interfaces track the lifetime of an object by incrementing the reference count on the object when an interface reference is passed, and will destroy the object when that reference count is zero.


5. At least the client calls the Choice Pattern and every object is local at runtime:

procedure TMainFrm.Button1Click(Sender: TObject);
begin
with(TDirWorker.Create) do begin
callCheck(TCheckFormatA.create);
callCheck(TCheckFormatB.create);
Free;
end;
end;

---
Е т'ва е живот!

Question/Problem/Abstract:

How do you delegate actions and operations in Delphi ? How do you use a stand-alone procedure as an event handler ?
Answer:


The basic types of reuse mechanisms are
(see Gamma, Helm, Johnson and Vlissides,
"Design PATTERNS",
Addision-Wesley, 1995)

Inheritance :
reuse by subclassing, lets you define the
implementation of one class in terms of another's
Aggregation (or Composition):
reuse by assembling or composing objects to get
more complex functionality
Delegation :
reuse by connecting methods : a object that
receives a request, delegates operations to
another object
(special kind of composition, two or more objects
are involved to produce a behavior)

The difference between inheritance and delegation
is the same as between to "be" and to "have",
for instance a rectangular windows-class "is" a
subclass of a general window, or a window can
"have" access to a class that knows how to
draw a rectangular window.

Delegation is used for example in the "State"
and "Strategy" design PATTERNS, which change
the behavior of an object by changing the
objects to which it delegates requests.

In delphi, inheritance is a feature of the
language, and its obvious how to compose
objects. How does delegation work in delphi ?
Delegation within a class is done by defining
objects for a state or a strategy (see "State"
and "Stategy" design pattern).
Delegation between different classes is done by
method pointers, variables that point to methods.

I want to show this by an example :
Let us suppose that you want to display the
progress of a calculation in a progress-form.
To do this, you can use messages or method pointers.
Using messages, you can send messages with

SendMessage(ProgressForm.Handle,WM_ProgressMsg,Progress,0);

The progress-form can receive this message and
respond to it with WndProc or own procedures like

procedure WMProgress(var msg : TMessage); message WM_Progress;

This is the "windows-way". The "delphi-way"
is to use method pointers : Delphi uses them to
manage and to hide the processing of messages :
if a window-message like WM_Activate is received,
the corresponding event OnActivate is triggered.
An event encapsulates the response for a certain message,
and is implemented by a method pointer.

Instead of using SendMessage, we can define a
"ProgressMessage" event with a method pointer :

TProgressMsg = procedure(Msg : string;Progress : integer) of object;

constructor TProgressForm.Create(LCID : integer;CompressClass : TCompressClass);
begin
inherited create(nil);
fCompressClass:=CompressClass;
fCompressClass.ProgressMsg:=ProgressMsg;
...
end;

Now we can delegate the process of displaying
the progress to the progress-form :

procedure TCompressClass.SendProgressMsg(Msg: string;Progress: integer);
begin
if Assigned(fProgressMsg) then
fProgressMsg(Msg,Progress);
end;

The calling class knows, *when* the action is
triggered, the class that rents the method knows
exactly *what* to do in this case.

procedure TProgressForm.ProgressMsg(Msg : string;Progress : integer);
var s : string;
k : integer;
begin
StepLabel.Caption:=Format(sProgress+' %s',[IntToStr(Progress)])+'%';
StepLabel.Refresh;
end;

...

Delegating or Event handling is done with
Method Pointers. They allow you to change and
to extend an object's >> behavior << simply by
assigning new methods to the pointers.
With method pointers, actions can be delegated
to other classes.
(-> Events page of the Object-Inspector)

Properties allow to change an object's
>> state << by assigning new values to
the properties.
(-> Properties page of the Object-Inspector)

Normal properties encapsulate elementary
blocks of states (access to object-data),
"event properties" encapsulate elementary
blocks of behavior (access to message-handling).


All method variables, including the event
properties, are defined in the unit System
(former in SysUtils) as follows :

TMethod = record
Code, Data: Pointer;
end;

If you know that, you can do tricks like
accessing methods by the method-name with
(see Artikel 2644)

Method.Code := Class.MethodAddress(MethodName);

or using a Stand-alone procedure as an event handler
Normally an event handler for the OnClick event would
look like this :

procedure TForm1.ClassProc(Sender: TObject);
begin
...
end;

Because a Stand-alone procedure has no relation
to a certain class, we have to add an additional
Data parameter of type pointer (for methods, the
first parameter is always Self (passed in EAX),
and the first parameter explicitly declared is
in fact the second parameter (passed in EDX)):

procedure StandAloneProc(Data: Pointer; Sender: TObject);
begin
...
end;

procedure TForm1.FormCreate(Sender: TObject);
var
Event: TNotifyEvent;
begin
TMethod(Event).Code := @StandAloneProc;
TMethod(Event).Data := nil; // or Button1
Button1.OnClick := Event;
end;

---
Е т'ва е живот!