Command objects manage the processing that occurs when a user
manipulates the application in some way.
Objectifying a command admits all kinds of interesting possibilities.
You can put the command on a stack to implement undo and redo, or write
the command to disk to implement record/playback.
You don't even have to execute the command right away. In a simulation
each command has a scenario time. You put the command on a queue and
execute the command later, when the simulation reaches that point in the
scenario.
In the example here, a menu-based application manages a group of open
documents. Each menu item contains a command object, bound at creation
time to a document object, which when executed calls a document
operation.
Implementation
In C++, you can bind a command to a document by passing the document as
a parameter in the constructor for the command.
For binding one object to another in Ada95 we use access discriminants,
a language feature created specifically for this purpose. The advantage
of this approach over C++ constructors is that the language guarantees
that a dangling reference cannot occur.
In order to have an access discriminant, the type must be limited. This
was already the case for the command class, because we used the
limited-and-indefinite idiom to control instance creation:
package Commands is
type Root_Command_Type (<>) is abstract tagged limited private;
That the type is also indefinite means we can hide the access
discriminant, by declaring it only in the full view of the type:
package Commands.Open is
type Open_Command_Type is
new Root_Command_Type with private;
...
private
type Open_Command_Type (App : access Application_Type'Class) is
new Root_Command_Type with null record;
...
end Commands.Open;
We bind an open command to an application instance by passing the
reference in the constructor for the type (very similar, actually, to
the C++ mechanism):
function New_Open_Command (App : access Application_Type'Class)
return Open_Command_Access is
begin
return new Open_Command_Type (App);
end;
When an open command is executed, the command creates a new document and
opens it, and adds it to the application:
procedure Execute (Command : access Open_Command) is
...
Add (Doc, To => Command.App.all);
The paste command is implemented similarly, except that it is bound to a
document instance:
type Paste_Command_Type (Doc : access Document_Type'Class) is
new Root_Command_Type with private;
When you execute a paste command, it calls the paste operation of the
document to which it is bound:
procedure Execute (Command : access Paste_Command_Type) is
begin
Documents.Paste (Command.Doc);
end;
You can generalize this idea by creating a generic package, allowing a
command to be bound to any kind of type:
generic
type Receiver_Type (<>) is limited private;
with procedure Action (Receiver : in out Receiver_Type);
package Commands.Simple is
type Simple_Command_Type (Receiver : access Receiver_Type) is
new Root_Command_Type with private;
The generic formal procedure Action specifies what you do to the object
when you execute the command:
procedure Execute (Command : access Simple_Command_Type) is
begin
Action (Command.Receiver.all);
end;
In the sample code, I use the simple command generic to create a command
that counts the number of documents in an application.
We want to be able to count the number of documents for any type in the
class, so we will instantiate the generic on the class-wide type.
Actual types that are indefinite (like Application_Type'Class) are
allowed because the formal type (Receiver_Type) was declared with
unknown discriminants.
There was no existing class-wide operation for applications that counts
documents, so we just extend package Applications with a public child
subprogram:
procedure Applications.Count_Docs
(App : in out Application_Type'Class);
Because it is a child, Count_Docs has access to the representation of
Application_Type, and it can therefore be implemented by iterating over
the documents in the collection maintained by the application.
A macro command maintains a list of commands, and so doesn't need an
access discriminant of its own. When you execute a macro command, it
calls the execute operation for all the commands on the list:
procedure Execute (Command : access Macro_Command_Type) is
Index : Root_Command_Access := Command.Next;
begin
while Index /= null loop
Execute (Index);
Index := Index.Next;
end loop;
end Execute;
This is an example of the Composite pattern.
Note that if you have a well-known object (singleton or otherwise) that
is the recipient of command activity, then you don't need to bind the
command to anything. In the implementation of Execute, you just call
the well-known object directly.
The code below is in a format suitable for use with gnatchop.
--STX
with Ada.Text_IO; use Ada.Text_IO;
procedure Applications.Count_Docs
(App : in out Application_Type'Class) is
Count : Natural := 0;
procedure Inc_Count (Doc : access Document_Type'Class) is
begin
Count := Count + 1;
end;
procedure Do_Count_Docs is
new For_Every_Document (Inc_Count);
begin
Do_Count_Docs (App.Container);
case Count is
when 0 =>
Put_Line ("There are no docs in the app.");
when 1 =>
Put_Line ("There is 1 doc in the app.");
when others =>
Put_Line
("There are" &
Integer'Image (Count) &
" docs in the app.");
end case;
end Applications.Count_Docs;
procedure Applications.Count_Docs
(App : in out Application_Type'Class);
package body Applications is
procedure Add
(Document : access Document_Type'Class;
To : in out Application_Type) is
App : Application_Type renames To;
begin
Add (Document, To => App.Container);
end;
end Applications;
with Documents; use Documents;
with Documents.Containers;
package Applications is
type Application_Type is tagged limited private;
procedure Add
(Document : access Document_Type'Class;
To : in out Application_Type);
private
use Documents.Containers;
type Application_Type is
tagged limited record
Container : Document_Container;
end record;
end Applications;
with Applications.Count_Docs; use Applications;
with Commands.Simple;
package Commands.App is
new Simple (Application_Type'Class, Count_Docs);
with Ada.Unchecked_Deallocation;
package body Commands.Macro is
procedure Deallocate is
new Ada.Unchecked_Deallocation
(Macro_Command_Type,
Macro_Command_Access);
function New_Macro_Command return Macro_Command_Access is
begin
return new Macro_Command_Type;
end;
procedure Do_Free (Command : access Macro_Command_Type) is
Index : Root_Command_Access := Command.Next;
Item : Root_Command_Access;
begin
while Index /= null loop
Item := Index;
Index := Index.Next;
Free (Item);
end loop;
declare
CA : Macro_Command_Access :=
Macro_Command_Access (Command);
begin
Deallocate (CA);
end;
end Do_Free;
procedure Execute (Command : access Macro_Command_Type) is
Index : Root_Command_Access := Command.Next;
begin
while Index /= null loop
Execute (Index);
Index := Index.Next;
end loop;
end Execute;
procedure Add (Command : access Root_Command_Type'Class;
To : access Macro_Command_Type) is
begin
Command.Next := To.Next;
To.Next := Root_Command_Access (Command);
end;
end Commands.Macro;
package Commands.Macro is
type Macro_Command_Type is new Root_Command_Type with private;
type Macro_Command_Access is access all Macro_Command_Type;
function New_Macro_Command return Macro_Command_Access;
procedure Execute (Command : access Macro_Command_Type);
procedure Add (Command : access Root_Command_Type'Class;
To : access Macro_Command_Type);
private
type Macro_Command_Type is new Root_Command_Type with null record;
--
-- We've already got a Next pointer that we (can) use for storage
-- management of commands, so let's just use that as the head of our
-- command list.
--
procedure Do_Free (Command : access Macro_Command_Type);
end Commands.Macro;
with Documents; use Documents;
with Ada.Text_IO; use Ada.Text_IO;
with Ada.Unchecked_Deallocation;
package body Commands.Open is
procedure Deallocate is
new Ada.Unchecked_Deallocation
(Open_Command_Type,
Open_Command_Access);
function New_Open_Command (App : access Application_Type'Class)
return Open_Command_Access is
begin
return new Open_Command_Type (App);
end;
procedure Do_Free (Command : access Open_Command_Type) is
CA : Open_Command_Access :=
Open_Command_Access (Command);
begin
Deallocate (CA);
end;
function Ask_User_For_Name return String is
Line : String (1 .. 80);
Last : Natural;
begin
Put ("Name: ");
Get_Line (Line, Last);
return Line (1 .. Last);
end;
procedure Execute (Command : access Open_Command_Type) is
Doc : Document_Access;
Name : constant String := Ask_User_For_Name;
begin
if Name /= "" then
Doc := New_Doc (Name);
Add (Doc, To => Command.App.all);
Documents.Open (Doc);
end if;
end Execute;
end Commands.Open;
with Applications; use Applications;
package Commands.Open is
type Open_Command_Type is
new Root_Command_Type with private;
type Open_Command_Access is access all Open_Command_Type;
function New_Open_Command (App : access Application_Type'Class)
return Open_Command_Access;
procedure Execute (Command : access Open_Command_Type);
private
type Open_Command_Type (App : access Application_Type'Class) is
new Root_Command_Type with null record;
function Ask_User_For_Name return String;
procedure Do_Free (Command : access Open_Command_Type);
end Commands.Open;
with Ada.Unchecked_Deallocation;
package body Commands.Paste is
procedure Deallocate is
new Ada.Unchecked_Deallocation
(Paste_Command_Type,
Paste_Command_Access);
function New_Paste_Command (Doc : access Document_Type'Class)
return Paste_Command_Access is
begin
return new Paste_Command_Type (Doc);
end;
procedure Do_Free (Command : access Paste_Command_Type) is
CA : Paste_Command_Access :=
Paste_Command_Access (Command);
begin
Deallocate (CA);
end;
procedure Execute (Command : access Paste_Command_Type) is
begin
Documents.Paste (Command.Doc);
end;
end Commands.Paste;
with Documents; use Documents;
package Commands.Paste is
type Paste_Command_Type is
new Root_Command_Type with private;
type Paste_Command_Access is access all Paste_Command_Type;
function New_Paste_Command (Doc : access Document_Type'Class)
return Paste_Command_Access;
procedure Execute (Command : access Paste_Command_Type);
private
type Paste_Command_Type (Doc : access Document_Type'Class) is
new Root_Command_Type with null record;
procedure Do_Free (Command : access Paste_Command_Type);
end Commands.Paste;
with Ada.Unchecked_Deallocation;
package body Commands.Simple is
procedure Deallocate is
new Ada.Unchecked_Deallocation
(Simple_Command_Type,
Simple_Command_Access);
function New_Simple_Command (Receiver : access Receiver_Type)
return Simple_Command_Access is
begin
return new Simple_Command_Type (Receiver);
end;
procedure Do_Free (Command : access Simple_Command_Type) is
CA : Simple_Command_Access :=
Simple_Command_Access (Command);
begin
Deallocate (CA);
end;
procedure Execute (Command : access Simple_Command_Type) is
begin
Action (Command.Receiver.all);
end;
end Commands.Simple;
generic
type Receiver_Type (<>) is limited private;
with procedure Action (Receiver : in out Receiver_Type);
package Commands.Simple is
type Simple_Command_Type (Receiver : access Receiver_Type) is
new Root_Command_Type with private;
type Simple_Command_Access is access all Simple_Command_Type;
function New_Simple_Command (Receiver : access Receiver_Type)
return Simple_Command_Access;
procedure Execute (Command : access Simple_Command_Type);
private
type Simple_Command_Type (Receiver : access Receiver_Type) is
new Root_Command_Type with null record;
procedure Do_Free (Command : access Simple_Command_Type);
end Commands.Simple;
package body Commands is
procedure Free (Command : in out Root_Command_Access) is
begin
Do_Free (Command);
Command := null;
end;
procedure Do_Free (Command : access Root_Command_Type) is
begin
null;
end;
end Commands;
package Commands is
type Root_Command_Type (<>) is abstract tagged limited private;
type Root_Command_Access is access all Root_Command_Type'Class;
procedure Execute
(Command : access Root_Command_Type) is abstract;
procedure Free (Command : in out Root_Command_Access);
private
type Root_Command_Type is
abstract tagged limited record
Next : Root_Command_Access;
end record;
procedure Do_Free (Command : access Root_Command_Type);
end Commands;
package body Documents.Containers is
procedure Add (Document : access Document_Type'Class;
To : in out Document_Container) is
Container : Document_Container renames To;
begin
Document.Next := Container.Head;
Container.Head := Document_Class_Access (Document);
end;
procedure For_Every_Document (Container : in Document_Container) is
Index : Document_Class_Access := Container.Head;
begin
while Index /= null loop
Process (Index);
Index := Index.Next;
end loop;
end For_Every_Document;
end Documents.Containers;
package Documents.Containers is
type Document_Container is limited private;
procedure Add (Document : access Document_Type'Class;
To : in out Document_Container);
generic
with procedure Process (Doc : access Document_Type'Class);
procedure For_Every_Document (Container : in Document_Container);
private
type Document_Container is
limited record
Head : Document_Class_Access;
end record;
end Documents.Containers;
with Ada.Unchecked_Deallocation;
with Ada.Text_IO; use Ada.Text_IO;
package body Documents is
procedure Deallocate is
new Ada.Unchecked_Deallocation
(Document_Type, Document_Access);
function New_Doc (Name : String) return Document_Access is
Doc : constant Document_Access :=
Document_Access'(new Document_Type);
begin
Doc.Name := To_Unbounded_String (Name);
return Doc;
end;
procedure Do_Free (Doc : access Document_Type) is
DA : Document_Access := Document_Access (Doc);
begin
Deallocate (DA);
end;
procedure Open
(Document : access Document_Type) is
begin
Put_Line
("opening document named '" &
To_String (Document.Name) &
"'");
end;
procedure Close
(Document : access Document_Type) is
begin
Put_Line ("closing document");
end;
procedure Cut
(Document : access Document_Type) is
begin
Put_Line
("cut text from doc named '" &
To_String (Document.Name) &
"'");
end;
procedure Copy
(Document : access Document_Type) is
begin
Put_Line ("copy text from doc");
end;
procedure Paste
(Document : access Document_Type) is
begin
Put_Line
("paste text into doc named '" &
To_String (Document.Name) &
"'");
end;
procedure Free (Document : in out Document_Class_Access) is
begin
Do_Free (Document);
Document := null;
end;
end Documents;
with Ada.Strings.Unbounded;
package Documents is
type Document_Type (<>) is tagged limited private;
type Document_Class_Access is access all Document_Type'Class;
type Document_Access is access all Document_Type;
function New_Doc (Name : String) return Document_Access;
procedure Open
(Document : access Document_Type);
procedure Close
(Document : access Document_Type);
procedure Cut
(Document : access Document_Type);
procedure Copy
(Document : access Document_Type);
procedure Paste
(Document : access Document_Type);
procedure Free (Document : in out Document_Class_Access);
private
use Ada.Strings.Unbounded;
type Document_Type is
tagged limited record
Next : Document_Class_Access;
Name : Unbounded_String;
end record;
procedure Do_Free (Doc : access Document_Type);
end Documents;
with Documents; use Documents;
with Applications; use Applications;
with Commands.Paste;
with Commands.Open;
with Commands.App; use Commands.App;
procedure Test_Commands is
App : aliased Application_Type;
App_Command : constant Commands.App.Simple_Command_Access :=
New_Simple_Command (App'Access);
begin
Execute (App_Command);
declare
use Commands.Open;
Command : Open_Command_Access :=
New_Open_Command (App'Access);
begin
Execute (Command);
end;
Execute (App_Command);
declare
use Commands.Paste;
Doc : constant Document_Access :=
New_Doc ("pastedoc.dat");
Command : constant Paste_Command_Access :=
New_Paste_Command (Doc);
begin
Execute (Command);
Add (Doc, To => App);
end;
Execute (App_Command);
end Test_Commands;
|
