![]() ![]() |
![]() ![]() |
![]() ![]() | |
© 1997 The McGraw-Hill Companies, Inc. All rights reserved. Any use of this Beta Book is subject to the rules stated in the Terms of Use. |
This chapter deals with Layering, the second major technique for scaling up projects (the first being Inheritance.) Layering is one of the great, unsung hero techniques of object oriented programming. When C++ came out, people went ga-ga over inheritance, thinking it was the great blessing that would cure all their programming woes. Of course, this is an exaggeration, but only a slight one.
What tended to get forgotten in all of the excitement is that perfectly reasonable object languages existed before C++. The oriented part of Object Oriented is due to inheritance; languages such as Ada and Modula were around for quite a while programming in an object paradigm and doing just fine.
The technique that these languages used for making objects work with each other was called layering. And I predict that layering will be used ninety percent of the time that you are creating object oriented projects.
We have not formally discussed the layering technique up to this point. However, we have actually used it; it is hard to do organized programming without using layering. This chapter will be one of formal recognition of layering, and expansion on the concept. The first thing we need to do is understand what layering is by giving a formal definition, and see how we applied layering to programs in previous chapters.
The second thing to do is to go into detailed examples about the concepts of which layering is composed. There are quite a few. We will cover:
HASA, Uses, modifies
Polymorphism
Delegation
In addition, there is a are classes of design patterns which determine how you piece your objects together. We will go over:
Singletons
Containers
Iterators
and go through examples of their use.
Finally, we will give real examples of how to use layering which draw on earlier examples, and extend and enhance them. We will then consider a small but very viable (and useful) Object oriented project in perltk, which will set the stage for the chapters to come.
Since you are doing 90% of your project building via layering, it would probably be a good idea for you to understand what layering is. Layering (or composition or component-based programming) is a technique of object oriented programming in which an object is built up of several different sub-objects, each with its own role and functionality.
Here are some terms that are associated with layering: HASA, Modifies, Uses.
We saw HASA last chapter. HASA sums up the layering relationship quite well. A cat ISA mammal, but a cat HASA tongue, claws, and a tail. A watch ISA clock, but a watch HASA dial, face, buttons, etc.
Modifies is a relationship between two objects such that one does not contain another, but instead one object changes another. A cat HASA tongue, and a cat HASA hair, but the tongue does not HASA hair. Instead, the tongue modifies the hair (i.e.: it could clean it.).
Likewise, uses is a less intrusive version of modifies; instead of changing another object's state, it gets information from that object. A piece of paper uses a paperclip; i.e. it takes from it the property to be able to bind paper. But it does not modify the properties of the paperclip itself.
Polymorphism and Delegation are the relevant process terms, how layering is accomplished.
Polymorphism is the ability to be able to call an object's method without knowing the actual object's type when you call it. Since Perl could care less about the type of the object and does all of its method checking at run-time, Perl is known as being polymorphously perverse. This means that it probably has more polymorphism than you would ever care to use!
Delegation is the process of passing functionality from one class to another, sort of like a manager handing out work to his or her employees. The manager may not know how to get the work done, but knows which employees are suited to do the job the best. Delegation is often used in conjunction with polymorphism.
In addition, there are design patterns which you will use to construct your object oriented projects. There are quite a few of these, so we will talk about a couple of major ones and let you discover the others on your own.
Singleton, Container, and Iterator are three of these design patterns. These design patterns are by no means exhaustive, of course. In fact, you could spend a long time learning all the possible design patterns (just ask Grady Booch.)*
If you are interested in exactly which ones are available, the best resource is called 'Design Patterns: Elements of Reusable Object-Oriented Software'. If you want to learn object terms with many Object Diagrams, this is the text for you. |
However, you can get by pretty far with just these three, and we give capsule definitions below:
Singleton: A class that insures that there is one and only one instance of itself (i.e.: one and only one object created). Usually, this one instance is then available via a global pointer.
Container: An object whose primary purposes are twofold. First, to hold other objects or data. Second, to provide a user interface to manipulate these objects or user data without exposing their underlying representations.
Iterator: A class whose main task is to provide a user interface to access a list of contained objects, and which keeps track of its position inside that object list so the user of that class can cycle through them.
All of these terms could get their own chapter, but instead, I will give some simple expansions of these capsule definitions, and then rely on examples to actually flesh out their definitions. *
*
*
Some might argue with this, saying that I am short changing the patterns for the sake of space. However, I have found that writing Perl contains a lot of 'reverse understanding', and that examples are the best way of teaching this. First, discover a concept due to Perl's rich language, its rubberband syntax. Then, one day you are rummaging through your favorite object oriented textbook, and you say 'Hey, I did that!' Of course there are tons of things you can do in Perl which don't have technical names in the literature, because generally they can't be done in any other object oriented language. But then again, they get the job done. |
Of course, the first thing that you need to know about layering is how to notice the layering relationship when you see it. To that end, there are three dead giveaways that something is in a layering relationship. The following cases go from the strongest type of layering relationship to the weakest.*
In this case strong means the type of relationship which binds the two objects close together, whereas weak means a looser relationship that can be pulled apart easier. |
When you have an object which is stored inside another object, you are making a very strong tie between the two. Our LogObjectInh object of the last chapter had this type of relationship. When we said (in LogObjectInh::open() ):
49 sub open
50 {
######
54 my $fh = new FileHandle("$action $filename")
||die "Couldn't open $filename";
######
56 $self->{filehandle} = $fh;
57 }
Line 56 is the point at which the object was layered. LogObjectInh object now contains the FileHandle $fh.
When you use callbacks and functions of another module or object inside an object, you are tying those two objects together in a very strong way, too.
If, for example, you have an object which so happens to use another object inside a callback, as in this example taken from the mail-filter program in chapter 12:
38 my $field = $textwindow->Scrolled
39 ( 'Text',
40 '-scrollbars' => 'e',
41 '-wrap' => 'word',
42 'relief' => 'sunken',
43 'borderwidth' => 2,
44 'setgrid' => '1'
45 );
###### CODE #####
50 my $save = $textwindow->Button
51 (
52 'text' => 'Save',
53 'command' =>
54 [ \&savetext, $field, $file ]
55 )
Line 54 is a callback internal to the Button object $save, which uses the $field object created by '$textwindow->Scrolled()' in line 38. $save uses the $field object, implying a dependency of the Button object on the Scrolled object up above.
We do not have to store objects inside other objects in order to have a layering relationship. The simple use of one object or module inside another is sufficient. In our Expect.pm object, there was the following call:
356 sub _execCode
357 {
######
365 print "Enter password for $opt->{'user'}\n";
366 ReadMode 2; $opt->{'pass'} = <STDIN>; ReadMode 0;
######
382 }
Here, line 366 made use of the ReadLine module (available via CPAN and on the CD) in order to make the input invisible so that we could enter a password. The Expect module is therefore using the ReadLine module.
As you can see, the layering relationship comes in many forms:
1. storing objects in other objects
2. having objects be used in functions or callbacks within an object
3. making an instance of a module or object inside another object
Each one of these forms is a use of layering, since by having or using one object inside another implies a dependency of one on the other. And, if there is a dependency such as object A being dependent on object B, any even insignificant change to the interface of object B could cause object A to break.
Therefore, the question is, what do we do now that we recognize what layering looks like? Well, we understand the concepts behind the forms, and of course since we are computer engineers, we make drawings of the concepts we see.
Let's put some substance to the concepts that we listed in the section above. Here are some more detailed explanations, as well as simple examples of how these concepts play out when you see them in code.
As we stated in the last chapter, HASA is not really a programming technique, but a relationship between two objects. One contains another, much in the same way that sentences contain words, or books contain pages. Hence, the meaning of the phrase 'component-based programming.' One object has other objects as components.
Likewise, Modifies is not really a programming technique. Instead, modifies indicates when one object changes another's state through its methods. Uses is where one object gets another's data, without modifying it.
So the best way to understand the HASA relationship is to be able to take code and turn it into a Object Diagram, or vice versa. Remember our 'script running' example of chapter 12? We wrote it in Tk, which is an interesting combination of inheritance and layering. It consisted of several method calls which 'packed' windows with things such as Buttons, Frames, etc.
If we distill the code into these function calls, getting rid of the arguments that have nothing to do with the layering relationship, the result looks something like this:
12 my $window = new MainWindow();
20 foreach $text (@labels)
21 {
22 my $frame = $window->Frame( )-> pack( );
23
24 my $entry = $frame->Entry( ) -> pack( );
32 my $label = $frame->Label( ) -> pack( );
37 $entries{$text} = $entry;
40 }
42 my $frame = $window->Frame( )->pack( );
43
45 $text = $window->Scrolled( );
46
47 my $runbutton = $frame->Button ('command'=>[ \&run, \%entries, $text ] )
48 $runbutton->pack( );
55 my $savetextbutton = $frame->Button('command'=>[ \&saveas, \%entries, $text])
56 $savetextbutton->pack( );
62 my $scbutton = $frame->Button('command'=>[\&scommand, \%entries,$text] )
63 $scbutton->pack( );
70 my $lcbutton = $frame->Button('command'=>[\&loadcommand,\%entries, $text ] )
71 $lcbutton->pack( );
78 my $clearbutton = $frame->Button ( 'command' => [\&clear => $text ] )
79 $clearbutton->pack( );
85 my $quitbutton = $frame->Button( 'command' => [$window => 'destroy'] )
86 $quitbutton->pack( );
Now, the one thing special about this skeleton code is that - from the point of view of layering - each time the code says '->pack()', it actually affects the object which created it.
In other words, when you say:
my $button = $frame->Button();
the frame $frame doesn't actually have the button yet. It has just created a button which is sort of 'floating in space'. The frame can't use it because it doesn't know what properties it has yet. When you say:
$button->pack();
this actually puts the button in the frame, with the desired look and feel.
What does this have to do with HASA, modifies, et al? Well, it is a good example of both. $button->pack() creates the HASA relationship here, where the Frame HASA Button. It also shows modifies in action. The button modifies the frame by more or less inserting itself into the frame. The resulting, Booch-like diagram looks something like Figure 21.1:
211.fig
Figure 21.1
Diagram showing HASA, modifies relationship
This is a pretty unusual object oriented relationship. In any other language besides Perl that is! It was built this way so we could do
my $frame = $window->Frame()->pack();
which basically does the same thing as:
my $frame = $window->Frame();
$frame->pack();
In other words it lets you 'do two things in one'.* Instead of having to split the statement in two, we chain the statements together, in a very Perl-ish way.
*
This is not the only way that this design could have been done. Nick Ing-Simmons, the developer of perltk, could have done something more conventional like:
in which the window is passed the frame that would be then configured by the window's pack function. Or even:
which is the equivalent one liner statement that would create a frame. However, by doing the packing this way, this puts a lot of burden on the Window::pack() subroutine. If we add a widget, say, 'widget1', then the pack() function will need to know about how to pack it. Nonetheless, there are difficulties with the current design, too. It all comes down to a design choice. GUI development, especially the very flexible GUI development that perltk provides, is very difficult to do and perltk does it admirably. |
Looking at the pseudo-code then, we could make the following Object Diagram, in Figure 21.2:
212.fig
Figure 21.2
Fuller diagram showing HASA, Modifies Diagram
Hence, a window HASA frame, a frame HASA Button, and a Button HASA Toplevel. (We have stripped all of the '->pack()' modifies relationships for clarity.)
Now, what can we say about the quality of this design? Just like when we were dealing with @ISA and inheritance, we want to have nice, hierarchical designs, with few loops, few places where an object reaches out horizontally to modify its neighbor objects directly.
Unfortunately, when dealing with pretty much any GUI program, this type of diagram does not give nearly enough detail about the quality of the program. The problem is that this diagram is at a class level. And since individual objects in a GUI are 'windows', 'frames', 'buttons', etc. there is an incentive to make a object-level diagram. Something like Figure 21.3:
213.fig
Figure 21.3
Object level HASA diagram
which then gives an idea of how the actual program works. You can almost see how the GUI functions at this level of detail: when each button is pressed what things it does, which windows it generates, and so forth. For example, when we push the Save button, we generate a 'FileDialog' box which is connected with its parent entry window. As you can see, we do have some loops - it is unavoidable in GUIs not to - but they are kept local to one another.
What level of detail you desire in your projects is up to you. When I am working with non-GUI projects, I settle for a class diagram, and try to make it as hierarchical as possible. When I am doing GUI development, however, it is almost necessary to make a class level diagram and lay out the relationships between buttons, windows, entries, frames, and other associated widgets. Again, it is desirable to keep things hierarchical. When you have loops - almost a necessity in GUI development - you should make them as tight as possible.
Polymorphism has three different meanings in the computing world. The non-technical meaning is of polymorphism is one entity that has many different forms. Which, ironically, means that polymorphism is a polymorphic term in itself!
The three types of polymorphism in the computing world are:
argument polymorphism - making many different types of an argument mean the same thing to a function.
functional polymorphism - using some criteria (argument list, environment) in order to determine what that function is going to do.
Object/Class polymorphism - being able to call a different object method or class method based on the type of the object or class.
Most of this chapter will deal with Object/Class polymorphism, but it would not be fair to ignore the other types. We have actually used them before in this book - again it is difficult to program Perl without them - and now it is time to give these techniques justice.
Argument polymorphism is the process of making a function user friendly by letting multiple versions of a given argument be translated for a given function so the function knows what to do. One of the chief techniques for making programs more user friendly is to incorporate some good, clean Argument Polymorphism into the function. The classic example is a date function, that translates a user-supplied date into seconds:
use Date::Format;
my $secs = str2time('Jun 27, 1997');
How much more user friendly this function is with Argument Polymorphism! Since the first argument of str2time can contain pretty much any date format under the sun, you can blithely use any date that you want (absolute dates, that is) and Perl will understand it! This is an actual module, available via CPAN, and it is a lifesaver (thank Graham Barr for this little gem.) Likewise, when we say:
my $fh = new FileHandle(" > file");
how much easier it would be if FileHandle stripped out the spaces for us, so that we would not need to be concerned about them. (It doesn't do this right now, a hint to Perl developers out there!)
All of these statements use argument polymorphism, 'normalizing' a argument of a function into a form that the function can handle. Since the function is doing the job of recognizing that spaces, format, or whatever else is unimportant, this makes it so the user of the function has to know less detail.
Functional Polymorphism is pretty much akin to argument polymorphism, only it is much more ingrained into the language. Functional polymorphism allows a function to have multiple meanings based on what is passed to it, or have the return value have multiple meanings based on the context in which it was called. For example, the built in:
$arg1++;
lets you have either integers, floats, or strings passed to it. If $arg1 is an integer, Perl knows that it should increment that argument, that is, set $arg1 to be one greater than it is right now. However, if $arg1 is a string, then the natural action is to increment 'aa' to 'ab'.
Perl's internals are pretty much built around functional polymorphism. Another example, which we covered in detail in the first section of this book, were contexts. When we said something like:
my $length = @array;
it was showing off the functional polymorphism in Perl. Since @array is in scalar context, $length becomes the length of the array. If you say:
my $scalar = $otherscalar;
then Perl does a regular assignment.
Of course you probably recognize a lot of this now from the earlier part of the book. Indeed, built-in functions show the same duality, doing different (but related) acts based on what you pass to them: reverse(), < >, chop() all use functional polymorphism.
Most user-built functional polymorphism is based on the two following operators: defined(), and ref(). defined() is used to create functions that have optional arguments. If you say:
sub myFunc
{
my ($arg1, $arg2) = @_;
if (defined ($arg2)) { doSomething($arg1, $arg2); }
else { doSomethingElse($arg1); }
}
then you are defining myFunc to have two different usages: myFunc($arg1); and myFunc($arg1, $arg2);. Both usages are legitimate, they just do different things based on the number of arguments. Likewise, if you say:
sub myFunc
{
my ($arg1) = @_;
if (ref($arg1) eq 'ARRAY') { doSomethingArrayRef($arg1)); }
elsif (ref($arg1) eq 'HASH') { doSomethingHashRef($arg1)); }
elsif (ref($arg1) eq 'SCALAR') { doSomethingScalarRef($arg1));}
elsif (!ref($arg1)) { doSomethingScalar($arg1); }
}
you are making myFunc actually do the job of four functions. Or, more accurately, you are making myFunc a wrapper that hides the complexity of four separate functions from the user. Again, this benefits user friendliness dramatically, since programmers do not need to remember four functions, only the one.
Example of Functional Polymorphism: a Dual Delete Method
You can use functional polymorphism to create methods which have a dual purpose. They may be both object and class functions depending on how they are called. In the process of creating these dual purpose methods, we will deal with a couple of the issues that can arise when you implement them.
For example, suppose we wanted to create a delete method that had this dual purpose. We would want it to be able to be called:
1) as an object method. The syntax
my $obj = new Object();
$obj->delete();
would delete the object referenced to by $obj.
Object->delete();
would delete all the objects known by the class Object.
To do this, Perl checks the first argument of the delete function:
1 package Object;
##### constructor code deleted.. see below
14 sub delete
15 {
16 my ($classOrObject) = @_;
17 if (ref($classOrObject))
18 {
19 splice(@$_objects, $self->{'position'}, 1);
20 delete ($classOrObject);
21 }
22 else
23 {
24 my $obj;
25 foreach $obj (@$_objects) { $obj->delete(); }
26 undef (@$_objects);
27 }
28 }
When making an object method call, the first argument will be a reference, and lines 18 through 21 will get called, deleting the one object. If the first argument is not a reference, lines 11 through 15 will get called, and all the objects that the package knows about will get deleted.
Now, in this particular instance, there are a couple of side effects that we need to keep track of. First, we have to now keep track of all the objects we create in the constructor. The list of objects that are deleted in line 24 has to come from somewhere.
Second, we need to manage the list of objects each time we delete one. Each time an object goes away, we need to modify @$_objects as in line 20. The object has to know about its position in the list @$_objects.
In this case, the easiest way to keep track of these two lists is in the constructor:
1 package Object;
2 my $_objects = [];
3
4 sub new
5 {
6 my($type) = @_;
7 my $self = bless {}, $type;
8 $self->{'position'} = @$_objects;
9 push(@$_objects, $self);
10 # code....
11 $self;
12 }
Line 9 keeps a list of all the objects that we have created, and line 8 keeps track of the position where our object is in our grand, list of objects (@$_objects).
Although the two techniques described above are invaluable, they should be relatively 'old hat' to you by now. The type of polymorphism which we shall use here is called Class or Object Polymorphism. Another common name for it is called 'true polymorphism' since it is the most commonly discussed of the three techniques.
Class or Object Polymorphism is a technique that makes classes more streamlined by letting the object reference discern which method it needs to call, rather than having the user figure it out. Let me explain. Suppose that you made a Polygon class, with the idea to have different shapes being drawn. You could make an interface like:
package Polygon;
sub create_circle { }
sub create_square { }
sub create_triangle { }
sub draw_circle { }
sub draw_square { }
sub draw_triangle { }
1;
where 'create_*****' are constructor functions, and 'draw_****' are functions which actually draw the shape to the screen. You could then write something like:
my $shape1 = create_circle Polygon();
my $shape2 = create_square Polygon();
my $shape3 = create_triangle Polygon();
$shape1->draw_circle();
$shape2->draw_square();
$shape3->draw_triangle();
This is not good! Just because you can do something does not mean that it should be done. In fact - we covered this in great detail in the last couple of chapters - this interface sins in three major ways:
It has non-generic functions: create_* and draw_* are difficult to remember, which means it will be difficult to use.
It is monolithic: we will find this code hard to split apart. If we add other shapes, we will have to add more functions to our one class.
It is complicated and error prone: the user needs to remember which draw function goes with which reference. It is perfectly legal to create a circle and then try to draw it as a square!
Polymorphism can help here in a major way. We take the monolithic interface above and change it into three separate objects:
Polygon/Circle.pm
package Polygon::Circle;
sub new { }
sub draw { }
Polygon/Square.pm
package Polygon::Square;
sub new { }
sub draw { }
Polygon/Triangle.pm
package Polygon::Triangle;
sub new { }
sub draw { }
Notice the simple names for the methods. Simple names, simple usage. By splitting up the code in this way, we have pretty much taken care of the other two drawbacks as well. Our usage becomes:
1 my ( @shapes ) = (
2 new Polygon::Circle(),
3 new Polygon::Square(),
4 new Polygon::Triangle()
5 );
6
7 foreach $shape (@shapes) { $shape->draw(); }
which, as you can see, is much cleaner; the user doesn't need to keep track of what variable is which type. The program does it. Line 7 is where Object Polymorphism comes in. Perl does not care what object is calling the draw() method. It just cares that the method is attached to the given object. Hence, $shape could be any type of object that has a draw() method. The user is spared the mental effort in having to coordinate the method name with the type of object.
This, by the way, is the reason that we want simple methods for objects. If we have simple methods, then our user interface is consistent. The more consistent the user interface is, the more usable it becomes. The usability will directly determine how popular your code is.
Polymorphism is a term that, ironically, has many definitions in computer science. The three main ones that we discussed above were:
Argument polymorphism - which is used to make functions easier to use by taking many forms of arguments which are basically the same to the human eye, and being able to process them in the same function
Functional Polymorphism - which is used to make one function the gateway of many other functions based on the type of arguments passed to that function.
Object/Class Polymorphism - which is the most commonly used definition of Polymorphism, making many different objects' methods (with the same name) be called transparently, depending on the object's type
We shall see below, that Polymorphism is used in many different ways, especially with Graphic User Interface code such as Tk.
Delegation and object polymorphism go hand in hand. In fact, Delegation is a way for a programmer to use Object Polymorphism.
Consider the scenario that we used in our small definition of delegation up above. A manager has several employees: an accountant, a programmer, a driver, and a masseuse. Of course, the job of the programmer is different from the driver's job, which is different from the driver's, and so forth. However, we want to have the manager be the focal point that forwards requests to his employees. The relationship might look something like Figure 21.4. We might model this relationship looking something like:
214.fig
Figure 21.4
HASA diagram for delegation
This is fairly straightforward: the Manager HASA group of employees, each with his or her own set of skills. The diagram turns into the following pseudo-code
Listing 21.1 Employee Packages (Accountant, Programmer, Driver, Masseuse ):
1 package Employee; # Dummy package for Employees.
2 1;
3
4 package Accountant;
5 sub new { bless {}, $_[0]; }
6 sub add { print "Adding!\n"; }
7 sub subtract { print "Subtracting!\n"; }
8 sub fudge { print "Fudging!\n"; };
9 1;
10
11 package Programmer;
12 sub new { bless {}, $_[0]; }
13 sub program { print "Programming!\n"; }
14 sub debug { print "Debugging!\n"; }
15 sub surfInternet { print "Surfing Internet!\n"; }
16 1;
17
18 package Driver;
19 sub new { bless {}, $_[0]; }
20 sub driveHome { print "Driving Home!\n"; }
21 sub driveWork { print "Driving to Work\n"; }
22 1;
23
24 package Masseuse;
25
26 sub new { bless {}, $_[0]; }
27 sub therapy { print "Doing therapy!\n"; }
28 1;
We have filled in each one of the methods for you here, simply for the sake of making things complete. We have also made it a little bit easier to see what is going on by putting all the employees into one file.*
You are not going to want to do this very often. One package, one namespace, one file should be the general rule that you should hold. It is just helpful in this case for the sake of testing. |
The only file, though, that we need to define here for the delegation relationship is the Manager. Now there are three basic ways to define this relationship:
1. smart delegation: the Manager object knows which the correct jobs of each of the employees.
2. blind delegation: the employees themselves take the jobs off the manager's desk so to speak. They basically tell the manager 'I can do this job' and then go and do it.
3. wily delegation: the manager takes credit for his employees' efforts. From the outside world, it looks for all the world that the manager is the one doing the job.
In addition, you can have 'smart wily' delegation and 'blind, yet wily' delegation. So item #3 is really a characteristic of the delegation relationship, rather than a type in itself. So let's see how to implement each of them.
In smart delegation, the Manager object has some built-in information in which he knows which task his Employee objects can perform. In this case, simply make this information a hash, something like Listing 21.2:
Listing 21.2 Manager::Smart
Manager/Smart.pm:
1 package Manager::Smart;
2 use Employee;
3
4 my $_delegateInfo =
5 {
6 'add' => 'Accountant',
7 'subtract' => 'Accountant',
8 'fudge' => 'Accountant',
9 'program' => 'Programmer',
10 'debug' => 'Programmer',
11 'surfInternet' => 'Programmer',
12 'driveHome' => 'Driver',
13 'driveWork' => 'Driver',
14 'therapy' => 'Masseuse'
15 };
16
17 sub new
18 {
19 my ($type) = @_;
20 my $self = bless {}, $type;
21 $self->{'Accountant'} = new Accountant();
22 $self->{'Programmer'} = new Programmer();
23 $self->{'Driver'} = new Driver();
24 $self->{'Masseuse'} = new Masseuse();
25 $self;
26 }
27
28 sub delegate
29 {
30 my ($self, $function, @arguments) = @_;
31 my $employee = $_delegateInfo->{$function};
32 print "Sorry... can't do $function! No employee I know can do it!\n"
33 if (!defined($employee));
34 return ($employee->$function(@arguments));
35 }
Here, lines 4 through 15 define the hash for us. It is merely a dictionary of what functions are available, and who does them. This is the 'smart' part of the smart delegation. When we get to the constructor (lines 17 through 26), we form the layering relationship. The Manager::Smart constructs an Accountant, Programmer, Driver and Masseuse and stores them inside itself in the Fields 'Accountant', 'Programmer', 'Driver', 'Masseuse'.
When we then get to delegation (lines 28 - 35), we simply take the function that was passed in and look up the employee that performs this task (line 30). Line 31 then calls the function passed in along with the associated arguments. Notice in line 32, we do not need to know the name of the function a priori in order to call the correct function.
In the client then, we would say something like this:
1 my $manager = new Manager::Smart();
2 foreach $task ('program', 'add', 'subtract', 'surfInternet')
3 {
4 my $status = $manager->delegate($task);
5 }
Very simple. Line 4 takes each of the tasks that we require to be done, and then passes it to Manager::Smart, which then goes ahead and passes it to one of the Employees.
Once you have smart delegation down, it is not a far leap to understand the concept of Blind Delegation. In Smart Delegation, there was a hash of who could do what. Blind Delegation does away with this necessity, instead letting each component class (i.e.: the employees) figure out what to do. The Manager::Blind can't see what his employees do for him. Listing 21.3 shows the Manager::Blind model in practice:
Listing 21.3 Manager::Blind
Manager/Blind.pm:
1 package Manager::Blind;
2 use Employee;
3
4 sub new
5 {
6 my ($type) = @_;
7 my $self = bless {}, $type;
8 $self->{'Accountant'} = new Accountant();
9 $self->{'Programmer'} = new Programmer();
10 $self->{'Driver'} = new Driver();
11 $self->{'Masseuse'} = new Masseuse();
12 $self->{'employees'}=
13 [ 'Accountant', 'Programmer' , 'Driver' , 'Masseuse'];
14 $self;
15 }
16
17 sub delegate
18 {
19 my ($self, $function, @arguments) = @_;
20 my $employees = $self->{'employees'};
21 my $employee;
22 foreach $employee (@$employees)
23 {
24 if ($employee->can($function))
25 {
26 return($employee->$function(@arguments));
27 }
28 }
29 return ($employee->$function(@arguments));
30 }
Notice that the constructor is exactly the same here as in Smart Delegation, except for the fact that it explicitly lists out the employee types in lines 12 and 13.
We then use this list in the actual delegation. In lines 22 through 28, we cycle through all the employees that the package knows about and query them if they know how to do the given function. The UNIVERSAL function can comes in very handy here. It simply returns whether or not the given employee can do the passed function.
The first employee that we find that knows how to do the function is then asked to do the job in line 26.
Advantages/Disadvantages of Blind Delegation
What can be said about this type of delegation as compared with smart delegation? This form has three advantages. We can control which component classes are tried first, and which ones are tried last. This is, in OO design terms, a chain of responsibility. The accountant component is tried first, the programmer second, and so forth. If one isn't responsible for a certain task, we check the next.
Second, this form is more flexible than smart delegation. We could have just as easily told all the employees that knew how to do something to just 'go do it'.
Finally, this form is easier to maintain than smart delegation. The manager class does not even know what types of employees that it has and can still process requests!
Likewise, there are a couple of disadvantages:
In short, if you can learn not to abuse the power that dumb delegation gives you, it can be a useful technique.
Dynamic Layering with Blind Delegation
In practice, it is advantage #3 which makes blind delegation a lot smarter than smart delegation. Let's add a 'secretary' type which looks something like:
package Secretary;
sub new { bless {}, $type; }
sub scheduling { print "Scheduling!\n"; }
1;
What we want to do is to add the secretary to the Manager::Blind's list of employees, but we do not want to make the Manager::Blind responsible for the employees that are added. We therefore add an assign function to the Manager::Blind, that looks something like:
Listing 21.4 Manager::Blind continued
32 sub assign
33 {
34 my ($self, $employee) = @_;
35 my ($employees) = $self->{'employees'};
36 if ( grep (ref($employee) eq $_, @$employees))
37 {
38 print "Already have an employee of type $employee!!!\n";
39 }
40 else
41 {
42 $self->{ref($employee)} = $employee;
43 push (@$employees, $employee);
44 }
45 }
which adds the employee to the manager's object (line 42) and then adds the fact that the employee has been registered with the manager to the list (line 43).
The important thing here is that nothing else in the object has to change. Since each employee figures out what they are going to do, when we say in a client:
1 my $manager = new DumbManager();
2 my $secretary = new Secretary();
3
4 $manager->assign($secretary);
5 $manager->delegate('scheduling');
then inside the delegate function we run into logic looking like:
22 foreach $employee (@$employees)
23 {
24 if ($employee->can($function))
25 {
26 return($employee->$function(@arguments));
27 }
28 }
Since we have assigned the secretary to the manager, line 22 now has a 'secretary' at the end of the array. When line 24 comes up and the $employee is a secretary, then the routine finds out that the secretary can now do 'scheduling'. This is all automatic. Pretty cool, huh?
Let's briefly consider wily delegation (my own term, but I like it a lot), in which the manager class pretty much takes all of the credit for what its employees (component classes) do. In other words, we will have no delegate function. Instead, when we say:
my $wilyManager = new WilyManager();
my $status = $wilyManager->add(1,1);
then magic will happen. Even though it looks like the manager is doing the adding, he is actually calling on the accountant to do it. So here's a wily manager in print:
Listing 21.5 Manager::Wily
Manager/Wily.pm:
1 package Manager::Wily;
2 use Employee;
3
4 sub AUTOLOAD
5 {
6 my ($self, @arguments) = @_;
7 my $function = $AUTOLOAD;
8 $function =~ s"(.*)::""g;
9 return if ($function =~ m"^DESTROY$"); # we don't want to delegate
10 # any DESTROY functions.
11 foreach $employee (@{$self->{'employees'}})
12 {
13 if ($employee->can($function))
14 {
15 return($employee->$function(@arguments));
16 }
17 }
18 print "Couldn't do the function $function!\n";
19 }
This is where all of the delegation happens in the wily manager package. The $AUTOLOAD variable holds the method name that was called:
$wilyManager->add(1,1);
However, $AUTOLOAD does not simply contain the string 'add'. Instead, the $AUTOLOAD variable contains a fully qualified version of 'add', something like 'WilyManager::add', which shows where Perl thinks the method is supposed to be applied. So in line #8 we take the name of the package from $AUTOLOAD, storing it in the more generic variable $function.
Line #9 takes away the DESTROY functions (we don't want to propagate these.) If we wanted to, we could add functions that we do not want to propagate, something like:
(print ("Sorry I don't fudge books!\n"), return())
if ($function =~ m"fudge");
and this would act as a sort of gateway to prevent dangerous functions. Lines 11-15 then do the delegation, by dynamically figuring out the function to call in line 13.
The rest of the listing is exactly the same, looking like:
Listing 21.6 Manager::Wily continued
20 sub new
21 {
22 my ($type) = @_;
23 my $self = bless {}, $type;
24 $self->{'Accountant'} = new Accountant();
25 $self->{'Programmer'} = new Programmer();
26 $self->{'Driver'} = new Driver();
27 $self->{'Masseuse'} = new Masseuse();
28 $self->{'employees'}=
29 [ 'Accountant', 'Programmer' , 'Driver' , 'Masseuse'];
30 $self;
31 }
32
33 sub assign
34 {
35 my ($self, $employee) = @_;
36 my ($employees) = $self->{'employees'};
37 if ( grep (ref($employee) eq $_, @$employees))
38 {
39 print "Already have an employee of type $employee!!!\n";
40 }
41 else
42 {
43 $self->{ref($employee)} = $employee;
44 push (@$employees, $employee);
45 }
46 }
What can we say about wily delegation? Well, in a way it is nothing but syntactic sugar. Instead of
my $mgr = new Manager::Blind();
$mgr->delegate('driveHome', 'address');
there is:
my $mgr = new Manager::Wily();
$mgr->driveHome('address');
which at least looks cleaner. Whether or not I use the first form, which is explicit about the delegation it performs, or the second in which the delegation is implicit, depends on what problem I am trying to solve; it is a stylistic choice.
These concepts go a long way in building up the larger structures in a project. Objects can:
1) own other objects through a HASA relationship
From there, we can diagram the structure of our project in the large by making Class diagrams, and labeling each place where classes interact with each other.
Making these relationships effective is the job of the other two techniques that we talked about: polymorphism and delegation. Polymorphism's job is to make an interface more user friendly by having users of the class not have to:
Class polymorphism is used quite heavily in delegation. In delegation, if one object does not know how to do something, it delegates the job to another object. For kicks, we gave three forms of this delegation (smart, dumb and wily).
In summary, these are the major syntactic techniques that we are going to use in putting together patterns in software development.
Design Patterns are the stock and trade of the Object Oriented industry. Design patterns are recurring forms of logic and code. It is through design patterns that the object oriented programming world turns ideas into applications, making such staple products as spreadsheets, word processors, and Web browsers.
There are two points that you need to know about using design patterns in Perl. These points are polar in thought and use. First, the fact that Perl is so syntactically flexible means you can make simple designs that translate into complicated projects that work. If we rewrote the delegation examples in C++, for example, we would have a lot more complicated syntax on our hands than we did with Perl.
Second, conversely, the syntactic flexibility of Perl means that you can have much more complicated designs in Perl than in a language such as C++! Supposedly then, these complicated designs would lead to very complicated projects indeed.
But this is beyond the scope of this book. Let's concentrate instead on simple patterns. The three we are going to consider are the Singleton, the Container and the Iterator.
A Singleton Class is a class which enforces the fact that there is only one instance in a given program. Usually, a Singleton Object (an instance of a singleton) is kept in a global variable, so everybody can access it.
Singletons are useful in two instances:
1. when you want to restrict the access to a resource within the process to only one copy of the object (or one copy of the underlying resource)
2. when you are not sure whether something should be a module or an object, but you don't want to limit yourself to the module approach
Point two is fairly uninteresting. Writing the Diff module so it looked like:
my $Global::diff = new Diff();
my $diffs = $Global::diff->array($a, $b);
pretty much sums it up. We expect Diff to only have one instance, in fact we program it with the expectation that it will. However, just to be safe we wrap it in an object, which does not make much sense in Perl because it is so easy to translate modules into objects.
Hence, we will concentrate on the first usage, which shows some of the interesting things about implementing singletons.
Suppose you wanted to make sure that you do not have two file handles pointing to the same file at the same time. In fact, that you wanted to make it a fatal error to say something like:
my $fh = new FileHandle("> write");
print $fh "Hello\n";
my $fh2 = new FileHandle("> write");
print $fh2 "Hello2\n";
which makes sense because the second write ('print $fh2') will overwrite the first.
The simple singleton class approach is to insure that there is only one FileHandle object at the same time. Let's call this FileHandle::Single:
Listing 21.7 FileHandle::Single
1 package FileHandle::Single;
2 use FileHandle;
3 use vars qw($AUTOLOAD)
4 use strict;
5
6 my $_count = 0;
7 sub AUTOLOAD
8 {
9 my ($self, @arguments) = @_;
10 my $fh = $self->{fh};
11 my $function = $AUTOLOAD;
12 $function =~ s"(.*)::""g;
13 return() if ($function =~ m"^DESTROY$");
14 $fh->$function(@arguments);
15 }
16
17 sub new
18 {
19 my ($type, @arguments) = @_;
20 (print("Can't create more than one filehandle!\n"), return())
21 if ($_count == 1);
22 $_count = 1;
23 my $self = bless {} , $type;
24 $self->{fh} = new FileHandle(@arguments);
25 return($self);
26 }
This is not only a good example of the Singleton concept, but it also shows delegation quite well. We do not want to have to write all of the FileHandle methods, as a filehandle knows how to do its job quite well, thank you very much. Instead, we use the AUTOLOAD mechanism to intercept the function that is being called and redirect it to the FileHandle stored in memory.
So, when a user types:
my $fh = new FileHandle("a");
my $fh2 = new FileHandle("bb");
the second call will cause the message
Can't create more than one filehandle!
and then return the undef value into $fh2.
This is the simple type of singleton, but it is not very usable in this instance. Sometimes we need more than one filehandle, so we could look at having ten filehandles as the limit. In other words, we should have the $_count variable give an error when it reaches ten rather than on the first instance.
A much more usable solution would be something that keeps track of FileHandle pollution. Everybody does this at one time or another. It is easy to be careless with filehandles, and we sometimes step on ourselves in the process. If you did something such as:
my $fh = new FileHandle("> file");
my $fh2 = new FileHandle("> file");
you are asking for a catastrophe to happen. This is because writes to the second filehandle will overwrite the first. Much better would be something like:
my $fh = new FileHandle::Cached("> file");
my $fh = new FileHandle::Cached("> file");
which would make sure when one file was opened, that subsequent calls to open the same file would insure that there is only one filehandle per given file. We economize on filehandles, and we insure that simple problems like this do not occur.
What is the best way to do this? Well, Perl provides the ideal method: through the hash. Listing 20.8 shows more detail. The first part is the same:
Listing 20.9 - FileHandle::Cached (AUTOLOAD)
1 package FileHandle::Cached;
2
3 use FileHandle;
4 use vars qw($AUTOLOAD);
5 use strict;
6
7 my %_fhCache = ();
8 my %_fhType = ();
9
10 sub AUTOLOAD
11 {
12 my ($self, @arguments) = @_;
13
14 my $fh = $self->{fh};
15 my $function = $AUTOLOAD;
16 $function =~ s"(.*)::""g;
17 return() if ($function =~ m"^DESTROY$");
18 $fh->$function(@arguments);
19 }
The first part is the same; delegation as usual. However, notice that there are a couple of hashes here in lines 7 and 8. The %_fhCache is going to contain the filehandles that we want; the %_fhType is going to contain the type of filehandles (append, read, overwrite).
We need to keep track of the types like this because it would be disastrous if we opened an 'overwrite' filehandle on top of a 'read' filehandle, for then we would trash whatever data was there!
These hashes are then used in the constructor, where we fill up the cache based on whether or not we have seen the file before:
Listing 20.10 - FileHandle::Cached (new())
20
21 sub new
22 {
23 my ($type, @arguments) = @_;
24
25 my ($file) = $arguments[0];
26
27 my $writetype = ($file =~ m">\s*>")? 'append' :
28 ($file =~ m">")? 'overwrite' :
29 'read';
30
31 my $self = bless {}, $type;
32 $self->{'fh'} = _getFH( $file, $writetype, \@arguments);
33 return($self);
34 }
35
Here, lines 27-29 determine what type of filehandle the code is opening. By looking at the file, we see if the file has two '>>' (meaning append) or one '>' (meaning overwrite) or else we assume it is a read. Note that this means that this class only supports usages that look like:
my $fh = new FileHandle::Cached("> file");
and it will not work (as it is) on things that look like:
my $fh = new FileHandle::Cached("file", "r");
although we could make it work that way. Line #32 stuffs Cached with filehandles, in a private function called _getFH. It looks like:
Listing 20.11 - FileHandle::Cached (_getFH())
36 sub _getFH
37 {
38 my ($file, $type, $arguments) = @_;
39
40 $file =~ s"[>\s]*""g;
41
42 if (defined($_fhCache{$file}) && ($_fhType{$file} eq $type))
43 {
44 return($_fhCache{$file});
45 }
46 elsif (defined($_fhCache{$file}))
47 {
48 print "You already have a filehandle of type $_fhType{$file} open!
49 You requested a file of type $type which is incompatible.\n";
50 }
51 else
52 {
53 $_fhCache{$file} = new FileHandle(@$arguments);
54 $_fhType{$file} = $type;
55 return($_fhCache{$file});
56 }
57 }
58 1;
This functions sole purpose is to make sure that we do not step on ourselves by opening the same file two different ways. (lines #46-50). It also makes sure that we reuse all the filehandles we possibly can. (lines 43-45).
Lines 53-55 are the ones that actually keep the cache. If we have not seen the file before, 53 makes a new FileHandle. We then store the type of file we created in line 54, and return the new filehandle, with the result that have a copy of the reference stored in the object itself.
That's it! By going this route, we guarantee a minimum amount of filehandle usage, of course, but there are couple of drawbacks you should be aware of. By keeping this cache, we have minimized the number of filehandles we create, but we also keep the filehandles that we have for the duration of the program. Why? Again, with Perl's garbage collection, keeping a filehandle in line 54 makes sure that the reference count never goes down to zero.
The usage as written is limited. You need to say:
my $fh = new FileHandle::Cached("> file");
$fh->print("HERE!\n");
instead of:
my $fh = new FileHandle::Cached("> file");
print $fh "HERE!!!\n";
because print expects a glob reference. It is an internal function, and it is hard-wired to expect globs in the first parameter.
So, to sum up, this approach works quite well to limit resources (filehandles, directory handles, memory, whatever) because the codes are hardwired into it.
The second type of pattern we shall consider is the container pattern. A container object is one whose main job is to hold other items so that the access to those items is easier, structured, or more streamlined.
There are two basic types of container objects:
1. Containers that are used to hold a group of other objects and simplify their access.
2. Containers that are used to hold and simplify access to physical items such as files and databases.
We have come across quite a few containers of each type in this book so far, but again have only got to name them as containers here.
For the type in which objects are used to simplify access to a certain physical object, there was the LogObject class which managed a log file. Likewise, the Expect object was (in a way) a container class, because it managed the connection to other machines via the Expect program.*
Some people would say it is not, and think of a container class as something that simplifies access to data. I disagree; in fact, one of the coolest things you can do is make it so that you don't care whether the place you are sending your data is a file, a pipe, over the network or whatever. The IO:: modules of the central distribution do this quite well). |
Good examples of the type of containers that hold a group of other objects was the Manager objects up above. Also good examples were the smart file handles which controlled the access to FileHandle objects.
In any case, the effect of using a container object is to simplify the interface. Instead of saying:
my $accountant = new Accountant();
my $driver = new Driver();
$driver->driveHome('2001 park avenue');
$accountant->add(1,1);
where we know what each object does, we instead say:
my $manager = new Manager::Wily();
$manager->driveHome('2001 park avenue');
$manager->add(1,1);
to do the equivalent. This is much cleaner; when the number of objects that you need to keep of track of becomes great enough, it is often worth it to pack information into a centralized place. Following are more examples of container objects.
The first example to consider is one that shows a container that simplifies access to several sub-objects. The example is the password entry screen so common to applications which need to vet (in other words, validate) access into a system.
Problem Domain
If you have used any browser, or had an account on a Unix or NT machine, you are probably familiar with a password screen. The screen that looks something like Figure 21.5:
21.5
Figure 21.5
Password Protection Screen
As you enter the password your characters are shadowed, they do not show up on the screen as is, but instead show up as asterisks (or blanks, or whatever).Furthermore, when you hit the 'clear' button, the text in the 'user' and 'password' fields gets emptied.
This looks simple enough. Now notice that this screen consists of at least five types of widgets or objects. They are listed below, with their Tk names:
Window - the whole conglomeration is a window, with links into the windowing system (try resizing the window once and see what happens).
Frame - the screen is partitioned into sections. Each of these sections is nailed down to a certain region of the window, which makes up the object.
Label - The 'Enter Password', 'User', and 'Password' text is packed onto a Label, which is then packed onto a frame.
Entry - The place where the user enters text is in an entry window, which is in turn on a frame, which is in a window.
Buttons - The 'OK', 'clear', and 'cancel' buttons are all nailed to a frame, which is in turn nailed to a window.
As you can see, this apparent simplicity is quite misleading. There is a lot of complexity in this application and it does not stop here. Since 'clear' affects the user and password entries, there has to be some sort of link between the clear button and the entry buttons. When the smoke clears, there is a Booch diagram that looks something like Figure 21.6:
216.fig
Figure 21.6
Password entry screen Object Diagram
The whole point of this is that it would be a very difficult to have to recreate this window every single time we needed to have a password screen! If we look at this complexity, if we wanted to have a screen like this in our program, all we have to care about is:
The 'user' and 'password' fields that the person entered in the application.
Whether or not the user hit the cancel button.
In addition, we may want to do a little customization of the screen by having a different title, different caption on top, or link callbacks to each of the buttons. These are trivial compared with having to rewrite the password screen from scratch.
Hence, this is the perfect place for a container object which packs the windows, frames, buttons, and so forth in a very reusable fashion. First, we need to consider the interface.
Interface Issues
How do we want to structure this object? First, notice that the Password object is going to have to be associated with a Tk widget (that is just a very basic fact about how Tk works.) This means the constructor call is going to look something like:
my $passwordWindow = new Tk::Password($window);
which then associates the password window with a widget that we pass in ($window). This call will make a vanilla password window object.
Next, we need to display the password window. This should be simple:
$passwordWindow->show();
however, we are missing a good opportunity for making this very simple to use. Since we only care about the return values (user, password, whether user pressed cancel), we can tie the return value with the fact we are showing the window. This code:
my $enteredValues = $passwordWindow->show();
says 'show the window, wait for the user to enter in some values, and then and only then return the value setting it inside $enteredValues'. We therefore want to have the code wait for a 'OK', or 'cancel' event before continuing with the rest of the code.
Following is a complete program, which creates a password window, waits for the user to enter in some value, and performs a simple validation of what the user typed. It continues only if the user enters in the correct values:
1 my $window = new MainWindow();
2 my $passwordWindow = new Tk::Password($window);
3 my $values = $passwordWindow->show();
4
5 (print ("Got it right"), exit())
6 if (($values->{'user'} eq 'hephaestus') &&
7 ($values->{'password'} eq 'godoffire'));
8 print "Got it Wrong!\n";
The key to this short program is lines 2 and 3. By encapsulating the complexity of the password window, and sticking it into the variable $passwordWindow, we allow for simple programming. More importantly, this allows a common interface between all of our programs.
Implementation
Let's implement this code. It will be helpful to have two things handy whilst going through this exercise:
Tk documentation online. You can use a browser to view this. ( go to /perl/html/lib/site/Tk/UserGuide.html on NT, or <TkDistribution>/doc/Tk-UserGuide.htm on Unix )
the sample tk applications. If you say 'widget' at the command line, you should get a menu of the different widgets available.
Let's use sample tk applications in order to find some code to use as a template. After all, the password screen exercise is not the most complicated problem, and one of these pre-built applications might just fit the bill to be modified to create the password screen.
Look at the widget demo called 'Simple Rolodex Demo'. The screen looks like Figure 21.7:
217.fig
Figure 21.7
Simple Rolodex Demo
Click on the button 'See Code', which then spills the contents of what makes this particular demo tick. In this case, the code looks like:
Listing 21.12 ( form.pl from demonstration Tk widgets )
1 sub form {
2 # form.pl
3
4 use vars qw/$TOP/;
5
6 sub form {
7
8 # Create a top-level window that displays a bunch of entries with
9 # tabs set up to move between them.
10
11 my($demo) = @ARG;
12 my $demo_widget = $MW->WidgetDemo(
13 -name => $demo,
14 -text => 'This window contains a simple form where you can type in 15 the various entries and use tabs to move circularly between the entries.',
16 -title => 'Form Demonstration',
17 -iconname => 'form',
18 );
19 $TOP = $demo_widget->Top; # get geometry master
20
21 foreach ('Name:', 'Address:', '', '', 'Phone:') {
22 my $f = $TOP->Frame(qw/-borderwidth 2/);
23 my $e = $f->Entry(qw/-relief sunken -width 40/);
24 my $l = $f->Label(-text => $ARG);
25 $f->pack(qw/-side top -fill x/);
26 $e->pack(qw/-side right/);
27 $l->pack(qw/-side left/);
28 $e->focus if $ARG eq 'Name:';
29 }
30 $TOP->bind('<Return>' => [$TOP => 'destroy']);
31
32 } # end form
Even if we knew nothing about Tk, this gives a wealth of information about how to program in it. We simply compare the code that we have below, with the Rolodex form that we have above, and we can see that:
1. To make a place to enter text, make a frame, make an entry, and finally make a label (lines 22-24 )
2. 'Pack' the objects to give them a location on the screen (line 25 - 27). Starting at line 21, each loop packs a frame at the top, and stacks the frames on the window from top to bottom.
3. If we want to bind a key to something, use the term 'bind' (line 30.)
4. To place the cursor in a certain place, 'focus' it (line 28).
This is the first line of attack. The difficult part of making a working tk object has been done for us. All we have to do is modify something that already works. Only if we need to do something outside the scope of the sample application do we fail over to the documentation.
The implementation follows pretty closely to the template that we just created. We only need to deal with the following issues:
configuration. Since the demo app is not an object, we have to come up with a good interface that is not overly complicated, yet gives enough power to do the job.
object storage. Again, we need to store object in an easy to access form.
These two issues will play themselves out when we actually create the object. So let's go ahead and start coding, and see how we solve these issues as we go along. First, we make the constructor and headers:
Listing 21.13 - Tk::Password constructor and headers.
Tk/Password.pm
1 package Tk::Password;
2 use strict;
3 use Carp;
4
5
6 sub new
7 {
8 my ($type, $widget, $desc, $title) = @_;
9
10 my $self = bless {}, $type;
11 $self->{'callbacks'} = {};
12
13 $self->{'title'} = $title || 'Password Screen';
14 $self->{'desc'} = $desc || 'Enter Password to get in.';
15
16 $self->{'widget'} = $widget;
17 my $window = $self->{'window'} = $widget->Toplevel();
18 $window->title($title);
19 $self;
20 }
This is fairly straightforward. We take the name of
a widget to tie the newly created window.
the title and description with which we will tag the window.
In the bare bones usage of this module, we only need the widget. However, I can see why people might want to have a different title to their password screen, depending on their application .
The description and title are optional and configurable in lines #13 and #14. The window's title is set in line 18.
Next, we must draw the object with the show() function:
Listing 21.14 ( Tk::Password() show() )
21
22 sub show
23 {
24 my ($self) = @_;
25
26 my $window = $self->{'window'};
27 my $attrib = $self->{'attrib'};
28 $self->_packCallbacks();
29 $self->_pack();
30
31 $window->waitVariable(\$self->{'pass'});
32
33 return
34 (
35 {
36 'user' => $self->{'user'},
37 'pass' => $self->{'pass'},
38 'cancel' => $self->{'cancel'}
39 }
40 );
41 }
42
This is mostly wrapper code. Wrapper code is called for because we are not exactly sure how we are going to implement the _pack() and _packCallbacks() functions. The two main things to realize here is that the calls in lines 28 and lines 29 are doing all of the work (stuffing all of the details into private functions), and that line 31 does a really cool thing.
What is that cool thing? Well, if you think about how GUI code works, it usually follows this pattern:
set up everything
and
wait for the user to input events.
The screen is set up by saying:
1 my $screen = new MainWindow();
2 my $button = $screen->Button('text' =>'ok','command' => [\&doSomething, @args]);
and:
3 MainLoop();
is an infinite loop to process any user events. When the button with the text 'ok' is pressed, then (and only then) is the function doSomething executed.
Now, this is usually a good thing. However, it does mean that 100% of the time, the code is looping in line #3, waiting for events to happen. Code objects are redrawn, redisplayed in this time, out of the control of the programmer except through callbacks as in line 2. This means that getting a 'return value' from a window will not work as is. If the main loop is always being executed in order to display GUI objects, that means that each call to create a GUI object has to be transparent - it has to be registered with the MainLoop and the code has to go on.
This statement:
31 $window->waitVariable(\$self->{'pass'});
commandeers the event loop. It tells Perl 'wait here for the $self->{'user'} variable to change. When it does change, you can go on, but not before then.' The basic idea is to draw the password screen, wait until one of the callbacks inside the password screen changes the value of $self->{'user'}, and then return the values after this event has occurred.
Where did we get this idea? Again, we looked at the code that came along with Tk, in this case inside the FileDialog.pm box. This is another reason to keep your eyes open and dig through other people's code; you learn a lot! Now let's implement the configure function:
Listing 21.15 - Configure function
43 sub configure
44 {
45 my ($self, @config ) = @_;
46 my $xx;
47 my $callbacks = $self->{'callbacks'};
48
49 for ($xx = 0; $xx < @config; $xx++)
50 {
51 my $type = $config[$xx];
52 my $cb = $config[$xx+1];
53 push(@{$callbacks->{$type}}, $cb);
54 }
55 }
56
57 sub _packCallbacks
58 {
59 my ($self) = @_;
60
61 my $callbacks = $self->{'callbacks'};
62 push(@{$callbacks->{'ok'}}, [ \&_setpass, $self, 'ok' ]);
63 push(@{$callbacks->{'ok'}}, [ $self->{'window'}, 'withdraw' ]);
64
65 push(@{$callbacks->{'clear'}}, [ \&_setpass, $self, 'clear' ] );
66
67 push(@{$callbacks->{'cancel'}}, [ \&_setpass, $self, 'cancel' ]);
68 push(@{$callbacks->{'cancel'}},[ $self->{'window'}, 'withdraw']);
69 }
70
The idea is that we can configure our object by adding callbacks that will do extra things once someone hits a button, whether the button is 'ok', 'clear', or 'cancel'.
This functionality should not be needed very often: 99% of the time all you have to do is check the return hash that comes out of the show function, and then do something from there. This functionality is added as insurance for unusual circumstances. All we have to do is draw the object and set up how this drawing interacts. Again, this code comes almost straight out of the form object from above:
Listing 21.16 - _pack function
71 sub _pack
72 {
73 my ($self) = @_;
74
75 my $window = $self->{'window'};
76 my $attribs = $self->{'attribs'} = {};
77
78 my $labelFrame= $window->Frame( 'borderwidth' => 2 )->pack('side' => 'top');
79 my $userFrame = $window->Frame( 'borderwidth' => 2 )->pack('side' => 'top');
80 my $passFrame = $window->Frame( 'borderwidth' => 2 )->pack('side' => 'top');
81
82 my $topLabel = $labelFrame->Label('text' => $self->{'desc'} )
83 ->pack( 'side'=>'left' );
84
85 my $userLabel =
86 $userFrame->Label('text' => "User\t\t")->pack('side' => 'left');
87
88 my $passLabel =
89 $passFrame->Label( 'text' => "Password:\t")
90 ->pack('side' => 'left');
91 my $userEntry = $userFrame->Entry( 'relief' => 'sunken', 'width' => 20 )
92 ->pack('side' => 'left');
93
94 my $passEntry = $passFrame->Entry(
95 'relief'=> 'sunken',
96 'width' =>20,
97 '-show' => '*')
98 ->pack('side' => 'left');
99 my $buttonFrame =
100 $window->Frame('borderwidth' => 2 )->pack('side' => 'left');
101
102 my $okButton = $buttonFrame->Button
103 (
104 'text' => 'ok',
105 'command' =>[$self, 'packedSubs','ok']
106 )
107 ->pack('side' => 'left');
108
109 my $clearButton = $buttonFrame->Button
110 (
111 'text' => 'clear',
112 'command' =>
113 [$self, 'packedSubs', 'clear']
114 )
115 ->pack('side' => 'left');
116
117 my $cancelButton = $buttonFrame->Button
118 (
119 'text' => 'cancel',
120 'command' =>
121 [ $self, 'packedSubs', 'cancel']
122 )
123 ->pack('side' => 'left');
124
125 $self->{'attrib'} = {
126 'labelFrame' => $labelFrame,
127 'userFrame' => $userFrame,
128 'passFrame' => $passFrame,
129 'topLabel' => $topLabel,
130 'userLabel' => $userLabel,
131 'passLabel' => $passLabel,
132 'userEntry' => $userEntry,
133 'passEntry' => $passEntry,
134 'buttonFrame' => $buttonFrame,
135 'okButton' => $okButton,
136 'cancelButton' => $cancelButton
137 };
138 }
The first thing to realize about this code is that it pretty much resembles building the window via lego-blocks. Again, each frame is positioned relative to another; when we say something like:
my $frame1 = $window->Frame() -> pack ('-side' => 'top');
my $frame1 = $window->Frame() -> pack ('-side' => 'top');
my $frame1 = $window->Frame() -> pack ('-side' => 'top');
we are making a structure that looks something like Figure 21.8:
218.fig
Figure 21.8
Structure built via packing frames.
The second thing to realize is the actual code which glues the object together, the bulk of the work, is done by callbacks that look like:
117 my $cancelButton = $buttonFrame->Button
118 (
119 'text' => 'cancel',
120 'command' =>
121 [$self,'packedSubs','cancel']
122 );
which says if the 'cancel' button is hit, the command 'packedSubs' is executed with the arguments '$self' and 'cancel'. The rest of the module is devoted to writing these callbacks:
Listing 21.17 - callbacks (_packedSubs())
139
140 sub packedSubs
141 {
142 my ($self, $type) = @_;
143
144 my $callbacks = $self->{'callbacks'};
145 my $buttoncallbacks = $callbacks->{$type};
146
147 my $call;
148 foreach $call (@$buttoncallbacks) { my ($cb, @args) =@$call; &$cb(@args);}
149 }
150
The subroutine _packedSubs() is actually a subroutine dispatcher. Since this object has configurable callbacks associated with each button, what _packedSubs does is actually figure out which subroutines to call, and then call them. When we say:
$self->_packedSubs('cancel');
it looks inside the callbacks that are configured for that particular button:
144 my $callbacks = $self->{'callbacks'};
145 my $buttoncallbacks = $callbacks->{$type};
and then goes ahead and executes them without even knowing what they are:
148 foreach $call (@$buttoncallbacks) { my ($cb, @args) =@$call; &$cb(@args);}
In other words, the result is a meta callback: a callback that calls callbacks! And one of the callbacks that _packedSubs() calls is one that is essential to how the module works: _setpass().
Listing 21.18 - callbacks (_setpass())
151 sub _setpass
152 {
153 my ($self, $type) = @_;
154
155 my $userEntry = $self->{'attrib'}->{'userEntry'};
156 my $passEntry = $self->{'attrib'}->{'passEntry'};
157
158 if ($type eq 'ok')
159 {
160 $self->{'cancel'} = '';
161 $self->{'user'} = $userEntry->get();
162 $self->{'pass'} = $passEntry->get();
163 }
164 if ($type eq 'clear')
165 {
166 $userEntry->delete('0', 'end');
167 $passEntry->delete('0', 'end');
168 }
169 if ($type eq 'cancel')
170 {
171 $self->{'cancel'} = 1;
172 $self->{'user'} = '';
173 $self->{'pass'} = '';
174 }
175 }
176 1;
This is actually the main function of our module, the one that makes the whole thing come together. How does it work? Well, when we actually created the windows with the statement:
my $password = $passWindow->show();
the code froze at the statement:
31 $window->waitVariable(\$self->{'pass'});
with the intent to wait for the variable $self->{'pass'} to change (it is now undefined). When somebody hits the 'OK' button, the code:
102 my $okButton = $buttonFrame->Button
103 (
104 'text' => 'ok',
105 'command' =>[$self, 'packedSubs','ok']
106 )
is executed. It translates into $self->packedSubs('ok'). Since we 'packed the Subs' in _packCallbacks(), this turns into the following two subroutine calls:
62 push(@{$callbacks->{'ok'}}, [ \&_setpass, $self, 'ok' ]);
63 push(@{$callbacks->{'ok'}}, [ $self->{'window'}, 'withdraw' ]);
which in turn executes the following code in _setpass():
155 my $userEntry = $self->{'attrib'}->{'userEntry'};
156 my $passEntry = $self->{'attrib'}->{'passEntry'};
157
158 if ($type eq 'ok')
159 {
160 $self->{'cancel'} = '';
161 $self->{'user'} = $userEntry->get();
162 $self->{'pass'} = $passEntry->get();
163 }
which then sets the user and pass variables to whatever the user has set them. Finally, since the pass variable has changed. The statement:
31 $window->waitVariable(\$self->{'pass'});
senses this, and lets the code continue on, which then triggers:
33 return
34 (
35 {
36 'user' => $self->{'user'},
37 'pass' => $self->{'pass'},
38 'cancel' => $self->{'cancel'}
39 }
40 );
which returns the values to the main subroutine.
Whew! Writing GUIs requires you to sort of disassociate the GUI part of the code with the non-GUI part. The GUI part simply consists of a big loop which keeps spinning, looking for the user to do something. When the user does something, the callbacks associated with that code fire off, and do the actual work, but they return the control to the Main Loop, which then looks for more user input.
The second container example we will look at is making an OO interface into a physical resource, in this case, a piece of Unix mail. (Note that you will probably be better off using MailTools and MailFilter which come with this disk since they work transparently between NT and Unix, but this sure does make a good example.)
We saw this filtering example in Chapter 12, but we did not really touch on how the filter worked. This example is intended to fill in that gap a bit, as well as show how you might build physical containers of your own.
Problem Domain
This problem is one that a lot of people are familiar with: they want processes to be able to read and sort mail, and even get rid of certain mail. Perl's text processing abilities will come in very handy in order to do this. We will want to make our interface as flexible as possible, considering the amount of things people use mail for. We will also need to use a couple of old Perl tricks to make the interface a lot easier.
Interface issues
To make a good interface, we need to consider how the source data looks. The average Unix mail message looks something like:
From prince_of_darkness@satco.com Wed May 15 14:03 MDT 1996
Date: Wed, 15 May 1996 14:02:58 -0600
From: prince_of_darkness@satco.com
To: who_it_may_concern@above.com
Subject: Late on payment
Content-Length: 1219
X-Lines: 39
Status: O
This is the second notice in a series of three. You are again late on your contractual payments, and if you persist in this manner, dire consquences will occur.
Yours,
B.B
Note that this message consists of three parts. First is the 'From ' header, which tells the subject of the message. Second, there is a series of lines that look like:
Date:
From:
To:
In other words, these are tags that have values. You might also think of them as keys that have values, which immediately suggests storing them in a hash. The lines are separated by ':'.
Third is the actual message. So what does this imply for our interface? First, the constructor should be fairly simple. We shall say something like:
my $message = new UnixMail::Letter($text);
which converts the Unix mail $text into a message object which we then can manipulate. When we actually get around to manipulating it, we will say:
my $subject = $message->get('subject');
and this retrieves the Subject header from the given message.
The essence of the physical container object is to take a piece of physical data and turn it into an internal format that can be manipulated. It can spit out the data that we want. If we were truly going to make this a read-and-write container, we would be able to say:
$message->set('Subject', 'forgery');
$message->write();
which would then set the internal format, and write it out to either a text representation of the mail message, or write it out to disk. However, for now we will make it a read only object. If you want to play around with a read and write container, you can take a look at MailTools on the disk.
Implementation
We are now ready to actually implement the UnixMail::Letter object. There will be two major functions, new and get. new will make the internal representation of the mail message as a hash, and get will retrieve pieces of that object for us to look at. First, let's make the constructor and the headers:
Listing 21.19 - UnixMail::Letter ( new() constructor )
1 package UnixMail::Letter;
2
3 use Date::Parse qw (str2time);
4
5
6 sub new
7 {
8 my ($type, $text) = @_;
9 my $self = {};
10 my $header;
11
12 if ($text =~ m{
13 (
14 (?:^|\n) # beginning
15 From (\S+) (.+?) # From header, actual te
xt
16 )(?=\n) # up to next '\n'
17 }sgx)
18 {
19 $self->{'from'} = $2;
20 $self->{'date'} = $3;
21 $header = $1;
22 }
23 while
24 ($text =~ m{
25 (
26 \n([A-Za-z\-]+?): \s*(.*?) # from tag.
27 )
28 (?=\n[^\n]+:|\n\n) # up to next tag.
29 }sgx
30 )
31 {
32 my $tag = $2;
33 my $value = $3;
34 $tag =~ tr"A-Z"a-z";
35 $self->{$tag} = $value;
36 $header .= $1;
37 }
38
39 $text =~ m"(.*?\n\n)"sg;
40
41 $header .= $1;
42 $self->{'header'} = $header;
43 if ($text =~ m"(.*)"sg) { $self->{'text'} = $1; }
44
45 if (!$self->{'from'})
46 {
47 return(undef);
48 }
49 if (!$self->{'subject'})
50 {
51 $self->{'subject'} = "*BLANK*";
52 }
53 bless $self, $type;
54 }
55
This code is performing quite a bit of work, but most of it has to do with the actual translation of the text into a hash. The constructor is split into three parts.
Lines 12 through 22 actually find out what the subject is going to be, along with the date. This allows sorting the mail by the date if we so desire. The 'g' modifier to the regular expression keeps track of where we are, and stores what we have found about the header inside the variable $header.
Lines 23 through 37 go to the next step, takes all of those tags that we were talking about ('From: Ed', 'Subject: hmm' , etc. ) and turns them into actual hash values. Line #34 turns the tags into lower-cases so it is easier to remember which tag is which.
Lines 38 through the end of the code does the clean up, taking the rest of the text - the body - and turning it into another hash element. The whole header is then saved, and a check for a 'from' element if performed. If there is no 'from' element, chances are that it isn't a legal mail message. If there is no subject associated with the mail message, one is given.
All of this is done to standardize the mail message into a hash. Notice that we have taken great pains to create code so that embedded mail messages are allowed. If there is junk in front of a mail message, we eliminate it by virtue of the regular expression in line 12-17, which starts the parsing at the first 'From' it meets.
If there are other mail messages at the end of the message, line 39 gets rid of them, since mail messages are always delimited by two newlines and then a 'From'.
Once we put the mail into this format, the 'get' function is trivial:
Listing 21.20 - UnixMail::Letter ( get() )
56 sub get
57 {
58 my ($self, $criteria) = @_;
59
60 if (!$self->{$criteria})
61 {
62 warn "The only criteria that are available are ",
63 "@{[keys(%$self)]}\n";
64 }
65 return($self->{$criteria});
66 }
67
Not only is this a generic function (we don't care about what type of tags that a mail message has) it is self-documenting. The number of attributes that a mail message can have is not fixed: there are no set 'tags' (other than subject and from) that can be fixed.
Lines 62 and 63 output the possible tags for that given mail message rather than giving a fixed message.
The only other function that we have is a seconds function:
68
69 sub seconds
70 {
71 my ($self) = @_;
72 my $date = $self->{date};
73
74 return(str2time($date));
75 }
76
77 1;
This gives the number of seconds since 1970 since a given message was written. This will come in handy when we get to Iterator objects.
Container objects are handy for simplifying an interface. As we saw in the two examples above, we could:
take a complicated mesh of objects, logic, and functionality, (the Tk::Password screen) and make it look like one, simple object from the point of view of the client.
take a file format, and make it look like a simple hash (UnixMail::Letter)
In both cases, the key to the Container's success was simplicity of interface. From the point of view of a client, it should not care how the internal workings of the Container operate.
In a sense, the Container is the pattern in OO where the 'buck stops here'. Any project which used the Tk::Password object could really simplify the Object Diagram that they had from:
219.fig
Figure 21.9
Project with Password entry screen Object Diagram
to something that looks like
2110.fig
Figure 21.10
Simplified Password Object Diagram
After all, we know that the Tk::Password has buttons, objects, etc. but what do we care? Putting all of the detail in the Object Diagram just muddles the overall design of the program.
The last type of pattern we shall consider is the Iterator pattern. The Iterator is a specialized container, and is quite common. Its job is to simplify access to a list of simpler objects. It also manages issues such as boundary conditions, such as 'what happens when the last object is gone through (in the iterator?' or 'what happens when the number of objects stored in the iterator goes to zero?'.
The Object Diagram for the iterator looks something like Figure 21.11.
2111.fig
Figure 21.11
Simplified Password Object Diagram
It is common to see methods in the iterator pattern such as next and previous. The methods keep track of an internal counter which tells the iterator where it is in the list of objects it controls. Likewise, there is usually a 'reset' function.
The best way to look at the iterator is by example. So let's continue along the same lines as the UnixMail::Letter object implemented above.
The UnixMail::Letter object listed above is not all that useful, unless you have it in context. Usually, letters reside in a mailbox, with each mailbox containing several letters. What we would like to do is have a structured way of accessing, sorting, and otherwise manipulating those letters so we can pick them out at will.
This points to the need for a Iterator which takes a mail box, opens it up, and then looks at its contents. Once we have these letters in the form of an array of lower level objects, we can look through them using the UnixMail::Letters accessor functions, and we should be doing OK.
Problem Domain
This problem domain is pretty much the same as the UnixMail::Letter problem domain up above. The difference this time is that we are dealing with it from a higher level, through the mechanism of a mailbox.
Interface Issues
What interface do we want to have for the letter iterator? It would be nice to create a simple, simple version of the constructor:
my $mailiter = new UnixMail::LetterIter('mbox');
which then creates the $mailiter object for us, tying it to the file mbox. However, we may want to have a little bit complicated usage, something that looks like:
my $mailiter = new UnixMail::LetterIter
(
'mbox',
{ 'CRITERIA' =>
sub {
my ($message) = @_;
return(1) if ($message->get('subject') !~ m"junk");
return(0);
}
}
);
This should probably be in its own subroutine (rather than an anonymous sub) but you get the idea. The CRITERIA determines which messages are going to be included in the $mailiter based on each message's attributes. This is incredibly powerful; by having this simple filter mechanism, you can use any piece of Perl syntax to sort through your mailbox.
Finally, we have the next function. To actually go through the LetterIter object, say something like:
my $mbox = new UnixMail::LetterIter('mbox');
while ($message = $mbox->next())
{
# do something with each message.
}
which gives internal access to each and every UnixMail::Letter the LetterIter knows about. We then can manipulate these messages through the UnixMail::Letter methods.
Implementation
This implementation is pretty easy since most of the details about mail messages are being handled by UnixMail::Letter. All we have to do is be able to take a Unix mail box, chop it up into messages, and then feed these messages to UnixMail::Letter. Again, there are only have two functions: new() and next(). new handles parsing, and next returns the next UnixMail::Letter object in the chain. First the constructor:
Listing 21.21 - UnixMail::LetterIter ( constructor )
1 package UnixMail::LetterIter;
2
3
4 use strict;
5 use UnixMail::Letter;
6 use Carp;
7
8 sub new
9 {
10 my ($type, $mbox, $config) = @_;
11 my $self = {};
12 my (@messages, $message);
13
14 bless $self, $type;
15
16 $self->{filename} = $mbox;
17 my $fh = new FileHandle($mbox) || die "couldn't open $mbox\n";
18 local($/) = undef;
19
20 my $msgtext = <$fh>;
21 close($fh);
22
23 while ($msgtext =~ m{
24 (.*?) # actual message text
25 (?=\nFrom [^\n]*\d\d\d\d\n\S+:|$) # next header.
26 }sgx
27 )
28 {
29 my $message = new UnixMail::Letter($1);
30 if ($config->{CRITERIA})
31 {
32 my $callback = $config->{CRITERIA};
33 if (&$callback($message))
34 {
35 push (@messages, $message);
36 }
37 }
38 else
39 {
40 push(@messages, $message);
41 }
42 }
43
44
45 @messages = sort { $b->secs() <=> $a->secs() } @messages;
46
47 $self->{'messages'} = [@messages];
48 $self->{'messageno'} = 0;
49 bless $self, $type;
50 }
The major piece of logic that does the splitting up of a mailbox into its component messages is line 23 - 41. We read the whole mailbox into one scalar (line 20), and then look for everything up to and including 'From [^\n]*\d\d\d\d\n\S+:'. More informally, this is looking for the lines of the form:
From prince_of_darkness@satco.com Wed May 15 14:03 MDT 1996
where the four digits and then a newline are a dead giveaway that this is an actual mail header. The text that we get from the while loop goes into the constructor in line 29, and gets filtered through the callback mechanism in line 33.
We finally sort the messages by their respective dates (str2time comes in so useful!) and set the internal iterator that we are going to use in next to 0.
Listing 21.22 - UnixMail::Letter ( next )
51
52 sub next
53 {
54 my ($self, $config) = @_;
55
56 my @messages = @{$self->{messages}};
57 my $messageno = $self->{'messageno'};
58
59 my $return = $messages[$self->{'messageno'}];
60
61 if (defined($return)
62 {
63 $self->{'messageno'} = 0;
64 }
65 else
66 {
67 $self->{'messageno'}++;
68 }
69 return($return);
70 }
71 1;
What we have here is your basic 'ring' structure. We keep track of where we are in the ring by the internal messageno pointer, and increment it in 67. If we run out of mail messages, this is sensed in line 61. The message number is reset to zero. We, however, do return undef; this short-circuits any loop that is calling the next function.
- Summary of the Iterator Pattern
The iterator pattern is a simple, but widely used pattern in object oriented programming. Whenever you have something that is directly composed of a bunch of similar subcomponents, that is a clue that you might want to make an iterator on top of it.
In this case it was pretty obvious. Mailboxes are composed of messages, therefore it makes sense to split modeling into two objects and make one the handler of the other. Other places where iterators are helpful are:
database accesses, in which each 'row' can be thought of as part of an overall 'query'
graphical objects, which can be thought to compose a graphical canvas
various file formats (of which Mailboxes can be thought as an example)
In all these cases, the iterator is the natural method of modeling patterns.
Final Layering Example
Let's take a look at how we could use the concepts of layering in order to make a true-to-life application, rather than just components of applications as we have done heretofore. Going from the 'write object' stage to thinking about writing object oriented projects seems like it would be a big jump to make, but it actually is not that big a deal.
We have been creating applications, pretty much the whole time. The automation of telnet and ftp in chapter 17 is a sample of a non-trivial application through the use of an object. However, this is not how most people think of applications. When people think of applications, they usually think of the GUI environment. This is really quite a pity because there is a lot of overhead in the GUI approach and you can often do more for less with a text based approach.
Ah well. There's no way to change minds about the type of applications they'd like to use, so you might as well put GUI's on things. And this is what we are going to do here.
Problem Domain
The problem domain that we are going to consider here is the 'personal data assistant' (PDA). The particular personal data assistant we are interested in here is the calendar application. Users enter in plans that they have for a certain day and the computer remembers these plans for them.
Interface and Design Issues
Since this is a GUI application, the interface and design issues for it go pretty much hand-in-hand. Our Calendar application should be:
simple
robust
flexible
Simple means that there should only be a couple of buttons on the Calendar at most and not too many options in menu-bars. The calendar will not do everything under the sun. It will just be a reliable way of putting calendar notes in a safe place.
Robust means that there is no way of fooling the calendar into losing information, and there are few if any loose holes that lead to weird behavior.
Flexible means the application can adapt to different individual's needs. Some people can have a lot of different activities going at the same time, or might need several scheduled days concurrently visible. Flexibility requires that the interface does not get in the way of using the calendar. These are touchy-feely terms, I'll grant. However, it is the job of the programmer to turn these touchy-feely terms into a concrete design and that is what we are going to do.
Again, to find role-models for the application that we are going to write, type:
C:\> widget
which brings up that awesome list of sample applications from which we can safely steal data. The one that we look at this time is called 'A 15-puzzle made up of buttons', which has an interface looking something like Figure 21.12:
2112.fig
Figure 21.12
15-Puzzle interface made up of buttons
Again, a perfect fit! You can see the calendar forming already. The 'trough' for the tiles becomes the calendar border, as well as the colors for the calendar. The buttons at the bottom become scrolling elements, and so forth and so on. Hit 'See Code' and the following pops up (in part):
my($i, $num, $frame_num);
for ($i=0; $i<15; $i++) {
$num = $order[$i];
$xpos{$num} = ($i%4) * 0.25;
$ypos{$num} = (int($i/4)) * 0.25;
$frame_num = $frame->Button(
-relief => 'raised',
-text => $num,
-highlightthickness => 0,
);
$frame_num->configure(
-command => [\&puzzle_switch, $frame_num, $num, \%xpos, \%ypos],
);
$frame_num->place(
-relx => $xpos{$num},
-rely => $ypos{$num},
-relwidth => 0.25,
-relheight => 0.25,
);
}
Here, this shows us how to put the buttons in the format that we want. We use the place command, and then have four elements to define:
'-relx' which is the relative x position in the frame from 0 to 1
'-rely' which is the relative y position in the frame from 0 to 1
'-relwidth' which is the relative width compared to the frame that the button is in, from 0 to 1
'-relheight' which is the relative height compared to the frame that the button is in, from 0 to 1
Again, the metaphor is the same. We blatantly mimic the code that we get for free in the standard distribution, and adapt it to our needs. There are several possible designs, but this one pops to mind first (in Figure 21.13):
2113.fig
Figure 21.13
Object Diagram for Calendar Application
This is straightforward and extremely linear. A calendar object HASA bunch of Month Objects, which in turn HASA bunch of Date Objects.
By making it this way, we should have few of the surprise behaviors that we mentioned in our discussion on robustness. With a simple design, we facilitate a simple application. As for flexibility, this is where perltk comes in. It is difficult not to design a flexible application in perltk. Since each object can have almost any other object in the tklibrary combined with the flexibility of Perl's syntax, you can easily create programs that look like they took about 20 to 100 times equivalent C-code.
So let's look at how the above Object Diagram translates into graphics. First we have the Calendar Object:
2114.fig
Figure 21.14
Calendar Object
This object contains all of the menus, buttons, and so forth of the final product. Right now, there are only two buttons - forward and back - and one menu which consists of Save and Done. Nice and simple. Each calendar consists of several month objects:
2115.fig
Figure 21.15
Month Object
which consist of the trough where the month is defined, the headers (Su Mo Tu We, etc.) and the position of the first days of the month as well as the last days. Finally, the Month object has a bunch of Days objects, which look something like:
2116.fig
Figure 21.16
Day Object
which have a button. The button knows when it has been pressed by the user, whether or not anything is scheduled on that day, and whether or not that day is the current day. (in which case there are different color codes). All of this translates into the final interface in Figure 21.17:
2117.fig
Figure 21.17
Final Calendar Object
which shows a calendar at work with the shaded squares being days that have text associated with them and an opened day (which shows how people make appointments.)
It is important to consider how the calendar object will actually be used in code. The usage should be as flexible as possible. Unlike such entities as the Password screen that we implemented earlier, we want to have the calendar object be able to stand on its own, or be a sub-object of another window. Therefore, we will want one usage that looks like:
my ($window) = new MainWindow();
my $calendar = new Tk::Calendar($window);
$calendar->draw();
MainLoop();
which ties the $calendar object to a certain window. The other usage we will want to have is something that looks like:
my $calendar = new Tk::Calendar();
$calendar->draw();
MainLoop();
in which the calendar stands by itself. While this looks easy enough, the question is if the implementation is as easy as it looks.
Implementation
We cannot possibly go into as much detail as we have previously about the code that is about to follow as it is just too long. We can, however, point out certain stumbling blocks that we had in implementing it as well as pointing out the tricky places in the code that we came across. We point out where the different design patterns that we have discussed made a difference while we were implementing the code.
We have three separate files: Tk::Calendar.pm, Tk::Month.pm, and Tk::Date.pm. I implemented them in that order it was easier to have a framework (Tk::Calendar.pm) in which I could place Months and Dates. We shall start with Tk::Calendar.pm and work downward.
Tk::Calendar
Tk::Calendar.pm is responsible for the high level interface issues in the calendar. It handles, for example, the way the next button is going to move to the next month, and how save is going to save and exit the application.
In rough terms, then, Tk::Calendar then is a container for Tk:Months, although it does more than that. Figure 21.18 shows the Object Diagram that was generated by Tk::Calendar:
2118.fig
Figure 21.18
Tk::Calendar Hierarchy
The only thing that was difficult about this design was the switching of the months. When a user had windows open, and pressed the forward key, the previous month's windows would close without saving. Therefore, I needed to implement a function called _closeScreens() which called the function:
my $dates = Tk::Date::getopen();
which is a class function in Tk::Date. It gets a list of open dates that which then get closed (and saved) before proceeding to the next month, via a FileDialog box.
Here is the code:
1 package Tk::Calendar;
2
3 use Tk::Month;
4 use strict;
5
6 sub new
7 {
8 my ($type, $widget, $title, $descript, $date) = @_;
9 my $self = bless {}, $type;
10
11 $title ||= 'My calendar';
12 $descript ||= 'Appointment listings';
13 $date ||= localtime();
14
15 if ($widget)
16 {
17 $self->{'widget'} = $widget;
18 $self->{'window'} = $widget->Toplevel();
19 }
20 else
21 {
22 $self->{'widget'} = 'me';
23 $self->{'window'} = new MainWindow();
24 }
25 $self->{'window'}->title($title);
26 $self->{'description'} = $descript;
27 $self->{'date'} = $date;
28 $self;
29 }
30
Note the dual constructor in lines 15-24. If we are given a widget, tie the Calendar to the widget. Otherwise, make a new main window.
31 sub draw
32 {
33 my ($self) = @_;
34 $self->_pack();
35 }
36
37 sub _pack
38 {
39 my ($self) = @_;
40
41 my $window = $self->{'window'};
42 my $attribs = $self->{'attribs'} = {};
43 my $date = $self->{'date'};
44
45 ###############################################################################
46
47 my $menuBar = $window->Frame('-borderwidth' => 2, -relief => 'raised' )
48 ->pack( '-side' => 'top', '-fill' => 'x' );
49
50 my $menu = $menuBar->Menubutton
51 (
52 '-text' => 'File',
53 '-underline' => 0,
54 '-borderwidth' => 2,
55 ) -> pack (
56 '-side' => 'left',
57 '-padx' => 2
58 );
59
60 $menu->command
61 (
62 '-label' => 'Save',
63 '-accelerator' => 'Meta+S',
64 '-underline' => 0,
65 '-command' => [ $self, '_savecheck' ]
66 );
67
68 $menu->command
69 (
70 '-label' => 'Done',
71 '-accelerator' => 'Meta+D',
72 '-underline' => 0,
73 '-command' => [ $self, '_donecheck' ]
74 );
75
76 ###############################################################################
77
78 my $labelFrame= $window->Frame( 'borderwidth' => 2 )->pack('-side' =>'top');
79
80 my $topLabel = $labelFrame->Label('text' => $self->{'description'} )
81 ->pack( '-side'=>'left' );
82
83 $self->{'currentmonth'} = new Tk::Month($window, $date);
84 $self->{'currentmonth'}->draw();
85
86 my $buttonFrame= $window->Frame( 'borderwidth'=> 2 )
87 ->pack ( 'side' => 'top' );
88
89 my $backButton = $buttonFrame->Button
90 (
91 'text' => '<--',
92 'command' => [ $self, 'backamonth']
93 ) -> pack ( 'side' => 'left' );
94
95 my $forwardButton = $buttonFrame->Button
96 (
97 'text' => '-->',
98 'command' => [ $self, 'forwardamonth']
99 ) -> pack ('side' => 'right' );
100
101 $self->{'attrib'} = {
102 'labelFrame' => $labelFrame,
103 'topLabel' => $topLabel,
104 'month' => {
105 "$self->{'currentmonth'}" =>
106 $self->{'currentmonth'}
107 },
108 'menubar' => $menuBar,
109 'menu' => $menu,
110 'backButton' => $backButton,
111 'forwardButton' => $forwardButton
112 };
113 }
This is the main guts of the GUI code. The menu is associated with two callbacks (shown below) which exit the application. The forward and back buttons are associated with moving the calendar backwards and forward a month, given the time.
114
115 sub backamonth
116 {
117 my ($self) = @_;
118
119 my $month = $self->{'currentmonth'};
120 my $window = $self->{'window'};
121
122 my $ok = _closeScreens($window, 'peaceful');
123 return() if (!$ok);
124
125 $month->undraw();
126 my $time = $month->last();
127 my $newmonth = new Tk::Month( $window, $time );
128 $newmonth->draw();
129
130 $self->{'currentmonth'} = $newmonth;
131
132 $self->{'attribs'}{'month'}{"$newmonth"} = $newmonth;
133 }
134
135 sub forwardamonth
136 {
137 my ($self) = @_;
138
139 my $month = $self->{'currentmonth'};
140
141 my $window = $self->{'window'};
142
143 my $ok = _closeScreens($window, 'peaceful');
144 return() if (!$ok);
145
146 $month->undraw();
147
148 my $time = $month->next();
149 my $newmonth = new Tk::Month( $window, $time );
150 $newmonth->draw();
151
152 $self->{'currentmonth'} = $newmonth;
153
154 $self->{'attribs'}{'month'}{"$newmonth"} = $newmonth;
155
156 }
Note the heavy use of Month methods in order to figure out what the next month is, to actually draw the new month being displayed and to 'undraw' the old month. Months know their time and place, and have methods to return this information.
157 sub _donecheck
158 {
159 my ($self) = @_;
160
161 my $window = $self->{'window'};
162 my $ok = _closeScreens($window, 'destructive');
163 $window->destroy() if ($ok);
164 }
165
166 sub _savecheck
167 {
168 my ($self) = @_;
169
170 my $window = $self->{'window'};
171 my $ok = _closeScreens($window, 'peaceful');
172 $window->destroy() if ($ok);
173 }
174
This is the code associated with the two buttons. Again, lines 162 and lines 171 both have the _closeScreens() function which directly reaches into the Dates of the months to figure out what to close. (This function could probably be moved to the month itself, but I was lazy.)
175 sub _closeScreens
176 {
177 my ($window, $type) = @_;
178
179 my $dates = Tk::Date::getopen();
180 my $kill;
181 if ($type eq 'destructive') { $kill = "Text will be lost in them."; }
182 else { $kill = ''; }
183
184 if ($dates)
185 {
186 my @titles = map ($_->get('dbmstring'), @$dates);
187
188 my $dialog = $window->DialogBox
189 (
190 '-title' => 'Open Screens',
191 '-buttons' => [ 'OK', 'Cancel' ],
192 '-default_button' => 'Cancel'
193 );
194 my $text = $dialog->add ( 'Text' ) -> pack('side' => 'top');
195
196 $text->insert( '0.0',
197 "The following windows are still open: @titles. $kill Close them?"
198 );
199
200 my $grab = $dialog->Show();
201
202 return(0) if ($grab eq 'Cancel');
203
204 my ($date);
205 if ($type eq 'destructive')
206 {
207 foreach $date(@$dates) { $date->cancel(); }
208 }
209 else
210 {
211 foreach $date (@$dates) { $date->savetext(); }
212 }
213 }
214 return(1);
215 }
216 1;
Finally, this is the _closeScreens() function which gets the data for each date that is open (i.e.. has an open screen) and closes them all. Tk::Calendar relied quite heavily on the Tk::Month methods to fill in the gaps of functionality that Tk::Calendar did not know (such as which month is last, etc.) That is where we turn next.
- Tk::Month
Tk::Month goes to the next level of detail. It provides the GUI and informational support about what a Month is supposed to look like inside the Calendar widget. If you think about it, months are tricky items to program. They are non-standard (some months have 28 days, 29 days, etc.) There is no standard about which day of the week is the first day of the month. Just when you get this figured out there are several exceptions to rules, anything from leap years to the 'add a day every four hundred years' rule.
What do we do about this? We let the operating system handle this, through Perl. Perl has a function called localtime() which returns a string for a given time, expressed in seconds since 1970. This function works cross platform and is very easy to program.
We know that there are 86400 seconds in a day, and that never varies. Therefore, when we are given the constructor for a new month:
my $month = new Month($widget, 'Jun 15, 1998');
we take that date, turn it into seconds, and then in the function _getStartDate(), subtract days from this date until we reach the starting day of the month. From there, we can tell where to draw the first day of the month. The Date::Parse and Date::Format modules provided by CPAN are instrumental in making this a user-friendly operation. By using str2time(), we can take almost any form of date and turn it into seconds. By using time2str() we can take the seconds and extract any type of information out of the date we want (the year, name of the day in the week, etc.)
The second problem that I came across while programming this was that some of the items (such as the background of the calendar and the days of the week for the calendar) really did not merit having multiple copies of themselves, one per month. After all, they only were drawn once, and drawing them again would be wasteful.
To that end, I made a few class variables (%_cachedMonths, $_cachedFrame, $_cachedBody, $_cachedLabel, $_cachedWeekLabels) which did the job of preventing excess copying. I needed to cache the months because I really did not want two copies of the same month floating around; that would mean that there could be two entries for the same date which is not what I wanted.
Listing 21.23 shows Tk::Month.
Listing 21.23 - Tk::Month
1 package Tk::Month;
2
3 use Date::Parse;
4 use Date::Format;
5 use Tk::Date;
6
7 use strict;
8
9 my $_cachedMonths = {};
10 my $_cachedFrame = undef;
11 my $_cachedLabel = undef;
12 my $_cachedBody = undef;
13 my $_cachedWeekLabels = [];
14
15 sub new
16 {
17 my ($type, $widget, $date) = @_;
18 my $self = {};
19
20 if (ref($widget) eq 'Tk::Toplevel')
21 {
22
23
24 my ( $startingday, $secs, $monthstring ) = _getStartDate($date);
25 if ( defined($_cachedMonths->{ $monthstring }) )
26 {
27 return ($_cachedMonths->{$monthstring});
28 }
29 else
30 {
31 ( $self->{'startingday'}, $self->{'secs'}, $self->{'monthstring'})
32 = ( $startingday, $secs, $monthstring );
33
34 $self->{'xcoord'} = .1428571428571428;
35 $self->{'ycoord'} = .1428571428571428;
36
37 $self->{'widget'} = $widget;
38 }
39 }
40 else
41 {
42 print "You need to have a Frame widget to fill!\n";
43 return();
44 }
45
46 bless $self, $type;
47 }
48
Again, new caches the months that it has already seen (lines 25-28) and calculates a lot of information about the month that has been passed via the constructor by calling _getStartDate();.
49 sub next
50 {
51 my ($self) = @_;
52
53 my $secs = $self->{'secs'};
54 do { $secs += 86400 } while (!_diffMonth($secs, '+'));
55 $secs+=86400;
56
57 return(scalar(localtime($secs)));
58 }
59
60 sub last
61 {
62 my ($self) = @_;
63 my $secs = $self->{'secs'};
64 while (!_diffMonth($secs, '-')) { $secs -= 86400; }
65 $secs -=86400;
66
67 return(scalar(localtime($secs)));
68 }
69
These functions will be used by Tk::Calendar.pm to increment and decrement the month.
70
71 sub draw
72 {
73 my ($self) = @_;
74 $self->_packLabel();
75 $self->_drawButtons();
76 }
77
78 sub undraw
79 {
80 my ($self) = @_;
81 $self->_undrawButtons();
82 }
83
84 sub _packLabel
85 {
86 my ($self) = @_;
87
88 my ($widget, $monthstring, $xcoord, $ycoord ) =
89 (
90 $self->{'widget'}, $self->{'monthstring'},
91 $self->{'xcoord'}, $self->{'ycoord'}
92 );
93
94
95 my $header = _getTopFrame($widget);
96 my $topLabel = _getTopLabel($header, $monthstring);
97 my $body = _getBody ($widget);
98
99 my $weekLabels = _getWeekLabels($body, $xcoord, $ycoord);
100
101 $self->{'attribs'}{'weeklabels'} = $weekLabels;
102 $self->{'attribs'}{'body'} = $body;
103 $self->{'attribs'}{'header'} = $header;
104 $self->{'attribs'}{'topLabel'} = $topLabel;
105 }
106
Here is where we actually draw and undraw the Month. Lines 95-97 are actually calls to functions which determine whether or not a Month has been drawn prior. If so, then the header, body and what not are not drawn again.
107 sub _drawButtons
108 {
109 my ($self) = @_;
110
111 my ($secs, $startingday, $monthstring, $xcoord, $ycoord, $body) =
112 (
113 $self->{'secs'}, $self->{'startingday'},
114 $self->{'monthstring'},
115 $self->{'xcoord'}, $self->{'ycoord'},
116 $self->{'attribs'}{'body'}
117 );
118
119 my $newsecs = $secs;
120 my $day = $startingday;
121 my $oldday = $startingday - 1;
122 my $date = 1;
123 my (@buttons);
124 my $row = 1;
125
126 for (
127 $day = $startingday;;
128 ( $secs+=86400, $day++, $day = $day%7, $date++ )
129 )
130 {
131 $row++ if ($day != ($oldday + 1));
132 push (
133 @buttons, new Tk::Date
134 (
135 $body, $monthstring, $day,
136 $date, $row, $xcoord, $ycoord
137 )
138 );
139
140 $oldday = $day;
141 last if (_diffMonth($secs, '+'));
142 }
143
144 $self->{'attrib'}{'buttons'} = \@buttons;
145 grep($_->draw(), @buttons);
146 }
147
Here is where the buttons are actually drawn. This is very closely related to the place function that we mentioned earlier, but the details are held inside Tk::Date. Note that we start with $startingday and then have logic for figuring out which row and day each button holds.
148 sub _undrawButtons
149 {
150 my ($self) = @_;
151 my $buttons = $self->{'attrib'}{'buttons'};
152
153 my $button;
154 foreach $button (@$buttons) { $button->undraw(); }
155 }
156
157 sub _getStartDate
158 {
159
160 my ($date) = @_;
161
162 my $secs= str2time($date);
163
164 my $year = time2str("%Y", $secs);
165 my $month = time2str("%b", $secs);
166
167 while (!_diffMonth($secs, '-')) { $secs -= 86400; }
168
169 my $startingday = time2str("%w", $secs);
170
171 my $monthstring = "Calendar Month: $month $year";
172 return( $startingday, $secs, $monthstring );
173 }
174
175 sub _diffMonth
176 {
177 my ($secs, $type) = @_;
178 my $month= time2str("%b", $secs);
179 $secs = ($type eq '+')? $secs + 86400 : $secs - 86400;
180 my $newmonth= time2str("%b", $secs);
181
182 return(1) if ($month ne $newmonth);
183 }
184
185 sub _getTopFrame
186 {
187 my ($widget) = @_;
188
189 if (defined($_cachedFrame))
190 {
191 return($_cachedFrame);
192 }
193 else
194 {
195 my $frame = $widget->Frame( 'borderwidth' => 2)
196 ->pack('side' => 'top');
197 $_cachedFrame = $frame;
198 return($frame);
199 }
200 }
201 sub _getTopLabel
202 {
203 my ($widget, $monthstring) = @_;
204
205 if (defined($_cachedLabel))
206 {
207 $_cachedLabel->configure( '-text' => $monthstring );
208 return($_cachedLabel);
209 }
210 else
211 {
212 my $label = $widget->Label( 'text' => $monthstring );
213
214 $label->Label('text' =>$monthstring );
215 $label->grid ( '-row' => 0, '-column' => 0);
216
217 $_cachedLabel = $label;
218 return($_cachedLabel);
219 }
220 }
221
222 sub _getBody
223 {
224 my ($widget,$scroll) = @_;
225
226
227 if (defined ($_cachedBody))
228 {
229 return($_cachedBody);
230 }
231 else
232 {
233 my $scroll = $widget->Scrollbar();
234 my $body = $widget->Frame
235 (
236 '-width' => 210,
237 '-height' => 210,
238 '-borderwidth' => 2,
239 '-relief' => 'sunken',
240 '-background' => $scroll->cget('-troughcolor')
241 ) ->pack
242 (
243 '-side' => 'top', '-padx' => '1c',
244 '-pady' => '1c'
245 );
246
247
248 $scroll->destroy();
249
250 $_cachedBody = $body;
251
252 return($_cachedBody);
253 }
254 }
255
256 sub _getWeekLabels
257 {
258 my ($widget, $xcoord, $ycoord) = @_;
259
260 my @dayarray = ('Su', 'Mo ', 'Tu ', 'We ', 'Th ', 'Fr ', 'Sa ' );
261
262 my ($xx, @weekLabels);
263
264 if (@$_cachedWeekLabels)
265 {
266 return($_cachedWeekLabels);
267 }
268 else
269 {
270 my ($xx);
271
272 for ($xx = 0; $xx < 7; $xx++)
273 {
274 push (@weekLabels, $widget->Label ( 'text' => $dayarray[$xx] ));
275 $weekLabels[-1]->place
276 (
277 '-relx' => ($xx%7) * $xcoord , '-rely' => 0,
278 '-relwidth' => $xcoord, '-relheight' => $ycoord
279 );
280 }
281 $_cachedWeekLabels = \@weekLabels;
282 }
283 }
284 1;
This is where we draw all the month information. _getWeekLabels draws the 'Mo', 'Tu', 'We', 'Th', etc. top header, and _getBody draws the frame where the calendar is kept.
- Tk::Date
Tk::Date contains the lowest level of detail. I had to concern myself with several things here. We want to have each of the buttons be an entity unto itself, such that when the user presses the button, it pops up a screen that looks something like Figure 21.19:
2119.fig
Figure 21.19
Opening up a button for a certain Date
Now the question is: how do we store all of that data, in a way which is easy to use, portable, and moreover doesn't have a lot of overhead to manipulate? We could have multiple files, but that seems to fall into the 'lots of overhead' category. I chose to make the storage mechanism a single DBM hash ($_dbm) stored in a single DBM file ($_dbmfile).
Since it is a single DBM file, there is no overhead on storing it. Moreover, DBM files can update, delete, and insert entries without any difficulty. Since DBM files are stored on disk, they are persistent. They are also portable, and do not require any specialty software like SQL databases to implement. Perfect!
The second issue I hit was how to distinguish between dates that had no information associated with them and dates that did. I chose to color the buttons differently:
firebrickred1 if the date is equal to the current date and there are appointments on it.
chartreuse4 (green) if the date is greater than the current date and there are appointments on it.
gray90 elsewhere.*
In addition, I added the touch that the button flashed, once a second, if you so happened to have an appointment on the current date.
These colors came out of the widget demonstration package again (through
when Perl is installed. As I said, that is one useful tool. |
Third, there was the issue of open entries, and maintaining the color scheme which showed which dates had appointments. If a date had no appointment, when the user clicked the button associated with that date and then closed that date, then the color had to be updated as well.
Fourth, there was the issue of open windows when the month switched or when either the save or cancel button was hit. In this case, I ended up maintaining an open list of all the dates which had open windows associated with them.
That was about it for the design challenges. Date was the most difficult object of the three to program, and I've found that it usually is that way: the highest level is easiest, and it gets more difficult on the way down. The code follows:
Listing 21.24 - Tk::Date
Tk/Date.pm
1 package Tk::Date;
2
3 use AnyDBM_File;
4 use Fcntl;
5 use Tk::Dialog;
6 use strict;
7 use Date::Parse;
8
9 my $_dbm;
10 my $_dbmfile = $ENV{'CALENDAR_DBM'} || "$ENV{'HOME'}/.calendar";
11 my %_open;
12
13 sub new
14 {
15 my ($type, $widget, $monthstring, $day, $date, $row, $xcoord,
16 $ycoord) = @_;
17 my $self = bless {}, $type;
18
19 if (!defined ($_dbm))
20 {
21 $_dbm = {};
22 tie(%$_dbm, 'AnyDBM_File', $_dbmfile, O_RDWR|O_CREAT, 0640);
23 }
24
25 (
26 $self->{'monthstring'}, $self->{'day'},
27 $self->{'date'}, $self->{'row'},
28 $self->{'xcoord'}, $self->{'ycoord'}, $self->{'widget'}
29
30 ) = ($monthstring, $day, $date, $row, $xcoord, $ycoord,$widget);
31
32 my $string = $self->{'monthstring'};
33 $string =~ s"Calendar Month:""g;
34 $string = $self->{'date'} . " $string";
35
36 $self->{'secs'} = _getSecs($string);
37 $self->{'dbmstring'} = $string;
38
39 return ($self);
40 }
Again, here is where we set up the access mechanism. Lines 19-23 are a very portable way of setting up a DBM (database file). We use AnyDBM_File which means 'hey - I don't care what type of DBM file we use, just use one!' Since SDBM comes with the standard distribution, we are guaranteed that this will work.
41
42 sub getopen
43 {
44 my $key;
45 my $return = undef;
46
47 foreach $key (sort keys %_open)
48 {
49 push(@$return, $_open{$key});
50 }
51
52 return($return);
53 }
54
getopen() is the class method that we mentioned above. %_open maintains which of the dates have open screens. We simply cycle through all of them and return the associated %_open record.
55 sub get
56 {
57 my ($self, $attrib) = @_;
58 print "'$attrib' is not an element!\n" if (!defined($self->{$attrib}));
59 return($self->{$attrib});
60 }
61
Generic accessor function.
62
63 sub draw
64 {
65
66 my ($self) = @_;
67
68 my ($monthstring,$day, $date, $row, $xcoord, $ycoord, $dbmstring,$widget ) =
69 (
70 $self->{'monthstring'}, $self->{'day'}, $self->{'date'},
71 $self->{'row'}, $self->{'xcoord'}, $self->{'ycoord'},
72 $self->{'dbmstring'}, $self->{'widget'}
73 );
74
75 my $xpos = ($day%7) * $xcoord;
76 my $ypos = $row * $ycoord;
77
78 my $button = $self->{'button'} = $widget->Button
79 (
80 '-relief' => 'raised',
81 '-text' => $date,
82 '-highlightthickness' => 0,
83 '-command' =>[ $self, 'press']
84 );
85
86 $button->place (
87 '-relx' => $xpos, '-rely' => $ypos,
88 '-relwidth' => $xcoord,
89 '-relheight' => $ycoord
90 );
91
92 $self->_makeCurrent();
93 }
94
This is where the bulk of the drawing is done. Lines 75-76 figure out what the relative position of the button is going to be; line 86 then actually places the button in the correct spot. Line 92 then calls _makeCurrent() which is a method for doing the shading (if the button corresponds to a date which has information and is above the current calendar day.)
95 sub undraw
96 {
97 my ($self) = @_;
98 $self->{'button'}->destroy();
99 }
Simple function to get rid of buttons so the next month can come in.
100
101 sub press
102 {
103 my ($self) = @_;
104 my $button = $self->{'button'};
105
106 my $string = $self->{'dbmstring'};
107
108 my $error;
109
110 if ($self->{'ispressed'})
111 {
112 my $dialog = $button->Dialog
113 (
114 '-title' => 'Error',
115 '-text' =>
116 "Button '$string $self->{'date'}' is already pressed" ,
117 '-bitmap'=> 'error'
118 ) ->Show();
119 return();
120 }
121 $self->{'ispressed'} = 1;
122 $_open{$string} = $self;
123
124 $self->_makeScreen($string);
125 }
126
Main callback, which happens if a Date button is pressed. We issue an error if the button is already pressed, in the form of a 'Dialog' widget.
127 sub lightup
128 {
129 my ($self, $color) = @_;
130 my $button = $self->{'button'};
131
132 $button->configure('-background' => $color);
133 }
134
135 sub lightoff
136 {
137 my ($self) = @_;
138 my $button = $self->{'button'};
139 $button->configure('-background' => '#d9d9d9');
140 }
141
Two major functions which do lighting of the methods. Lightup is called if the day is after the present day, and has scheduling information.
142 sub _makeScreen
143 {
144 my ($self,$string) = @_;
145 my $button = $self->{'button'};
146
147 my $screen = $self->{'screen'} = $button->Toplevel();
148
149 $screen->title("For the day '$string'");
150
151 my $field = $self->{'field'} = $screen->Scrolled
152 ( 'Text',
153 '-scrollbars' => 'e',
154 '-wrap' => 'word',
155 '-relief' => 'sunken',
156 '-borderwidth' => 2,
157 '-setgrid' => '1'
158 ) -> pack ('-expand' => 'yes', '-fill' => 'both');
159
160 $field->insert('0.0', $_dbm->{$string});
161 my ($save) = $screen->Button
162 (
163 'text' => 'Save',
164 'command' => [$self, 'savetext'],
165 ) -> pack ( 'side' => 'left' );
166
167 my ($cancel) = $screen->Button
168 (
169 'text' => 'Cancel',
170 'command' => [ $self, 'cancel'],
171 ) -> pack ( 'side' => 'left' );
172
173 my ($delete) = $screen->Button
174 (
175 'text' => 'Delete',
176 'command' => [ $self, 'deletetext'],
177 ) -> pack ( 'side' => 'left' );
178 }
179
The main code that makes a screen if the button is pressed. We tie the three Buttons to callbacks which save, delete or cancel the changes made in the window.
180 sub savetext
181 {
182 my ($self) = @_;
183
184 my $field = $self->{'field'};
185 my $screen = $self->{'screen'};
186 my $string = $self->{'dbmstring'};
187
188 $_dbm->{$string} = $field->get('0.0', 'end' );
189
190 delete $_open{$string};
191
192 $self->{'ispressed'} = 0;
193 $screen->destroy();
194
195 $self->_makeCurrent();
196 }
197
198 sub cancel
199 {
200 my ($self) = @_;
201
202 $self->{'ispressed'} = 0;
203
204 my $string = $self->{'dbmstring'};
205 my $screen = $self->{'screen'};
206
207 delete $_open{$string};
208
209 $screen->destroy();
210
211 $self->_makeCurrent();
212 }
213
214 sub deletetext
215 {
216 my ($self) = @_;
217 my $field = $self->{'field'};
218
219 $field->delete('0.0', 'end');
220 }
221
These are the main functions for doing callbacks, which manipulate the text inside the windows. This is because we are maintaining a list of screens that are open we need to modify the %_open hash (lines 190 and 207 ).
228 sub _makeCurrent
229 {
230 my ($self) = @_;
231 my $dbmstring = $self->{'dbmstring'};
232 return() if (!defined($_dbm->{$dbmstring}));
233
234 $self->unflash();
235 if (($_dbm->{$dbmstring} =~ m"\S" ) && $self->_sameday())
236 {
237 $self->lightup('firebrick1');
238 $self->flash();
239 }
240 elsif (($_dbm->{$dbmstring} =~ m"\S") && !$self->_pastdate())
241 {
242 $self->lightup('chartreuse4');
243 }
244 else
245 {
246 $self->lightoff();
247 }
248 }
This is the function to make a button light up if it is ahead of the present and has data in it. Notice also, the hooks into flashing (line 238) and unflashing (line 234). We assume the button is flashing and turn the flashing property off, and then determine whether it actually should be flashing or not. This simplifies the logic. Below are the functions that we call, flash() and unflash():
249
250 sub flash
251 {
252 my ($self) = @_;
253 my $button = $self->{'button'};
254 $self->{'flashid'} = $button->repeat(1000, [$button, 'flash']);
255 }
256 sub unflash
257 {
258 my ($self) = @_;
259 my $flashid = $self->{'flashid'};
260 if ($flashid)
261 {
262 my ($button = $self->{'button'};
263 $button->afterCancel($flashid);
264 }
265 }
The key to these two functions is in line 254, which solves the problem of animation in a very clean way. Remember how Tk works with the 'event loop', which essentially puts the computer on standby, waiting for events to occur? Well, line 254 takes advantage of this, registering the button to flash every 1000 milliseconds, with a function called repeat().
When it registers this code, it also saves an id inside $self->{'flashid'}. When we want the button to stop flashing, line #263 cancels this affect, with the function called afterCancel(). More than one piece of code can be happening at a time, and afterCancel() uses the id made by repeat() to determine which piece of code to cancel.*
The code continues.
This trick can be used to do quite a few things, not just controlling animation. If we wanted to warn the user, every five minutes that he/she had an appointment on the same day, we could say:
where warn does this updating. We could also use this code to solve a subtle bug that this program has. Right now, as it is, there is no way of telling the program that 'hey - a day has passed. Sept 27 is no longer the current date, you have to move forward!' We could put a function in the constructor that looks like this:
Now, without any intervention at all, our program will update the buttons' flashing status. Every hour, Tk will check for us whether or not our buttons have the current date. If so, buttons that weren't flashing the day before will all of a sudden flash when the correct day rolls around. |
266 sub _getSecs
267 {
268
269 my ($string) = @_;
270 return(str2time($string));
271 }
272
273 sub _pastdate
274 {
275 my ($self) = @_;
276 my $secs = $self->{'secs'};
277 my $button = $self->{'button'};
278 my $today = time;
279 if (($secs - $today) < -86400) { return(1); }
280 return(0);
281 }
282
283
284 sub _sameday
285 {
286 my ($self) = @_;
287 my $secs = $self->{'secs'};
288 my $button = $self->{'button'};
289 my $today = time;
290 if (abs($secs - $today) < 86400) { return(1) }
291 return(0);
292 }
293
294 1;
These are generic functions that deal with time issues such as whether or not a button is on the same day as the current system time, or past the current date.
That is it! Overall, the server piece of the code takes 777 lines. However, from the client side of the code, all we have to do is add the following 6 lines of code to a file:
use Tk;
use strict;
my $date = localtime();
my $calendar = new Tk::Calendar($date);
$calendar->draw();
MainLoop();
which goes ahead and draws the calendar. We can now go ahead and try out our application. We save these six lines inside 'calendar.p' and say something like:
C:\> perl calendar.p
which then displays our application, looking something like Figure 21.20:
2120.fig
Figure 21.20
Calendar startup.
We've seen this before, however, so we start clicking on various buttons. First, we click the next button, and we get the next month in the calendar:
2121.fig
Figure 21.21
Next calendar month
Then, we proceed to open a couple of windows, and type some text into them:
2122.fig
Figure 21.22
Adding text to windows.
Saving the calendar dates makes the colors of the dates change, notifying us that we have a calendar appointment on that particular day:
2123.fig
Figure 21.23
After some entries have been made to the calendar
This is just too cool! We have spent about 1/10 of the effort we would have taken if we were to do the application in C, and about 1/100 of the effort of doing it in X-windows. In fact, the difficulty level is comparable to Visual Basic, and probably easier due to the tricky date issues. Moreover, the application is completely portable to Mac, OS/2, Unix, NT and Windows 95! With the compiler, we can make a binary for each of these systems, which saves on start up times, and lessens the dependencies on the Tk GUI libraries.
This has been the longest chapter in the book so far, but with reason. This is probably the most important chapter in this OO section. You will want to learn the following concepts before you go on to the next section of the book:
HASA - basic layering relationship
Modifies - the relationship between objects where one object modifies another without owning it
uses - the relationship between objects in which one object uses the parts of another object without owning it
polymorphism - the process of having one piece of syntax stand for many different things, or many different pieces of syntax stand for one thing
delegation - the process of passing methods that a certain object doesn't know how to handle to objects that know how to handle them.
In addition, there were three types of objects that we discussed: singleton, container, and iterator, as well as a bunch of examples of their application. Quite the handful.
This is the last of the theoretical chapters. The next section concentrates on real Perl projects and the tools/programming methods for making your Perl programming the most effective possible.
![]() ![]() |
![]() ![]() |
![]() ![]() |
COMPUTING MCGRAW-HILL | Beta Books | Contact Us | Order Information | Online Catalog
HTML conversions by Mega Space.
This page updated on October 14, 1997 by Webmaster.
Computing McGraw-Hill is an imprint of the McGraw-Hill Professional Book Group.
Copyright ©1997 The McGraw-Hill Companies, Inc. All Rights Reserved.
Any use is subject to the rules stated in the
Terms of Use.