It's a dog, but what kind? (polymorphism , in Perl OO)

[blue_cowdawg]

My Inspiration for this tutorial

The other day a former student of mine posed a programming problem in Perl to me via email. His problem was he needed to write code to handle some data where there were a lot of the same functions were in common for the multiple data types but some of the underlying behaviors were different. He showed me some code and lo and behold in the year since I had him in my class as a student he had taught himself a modicum of Object Oriented Perl technique from the Damien Conway's book on the subject.

What am I talking about? Well gentle reader, let me use the following example.

        Dog ----------> Cattle Dog
                +-----> Samoyed
                +-----> Cocker Spaniel

The Cocker Spaniel, Cattle Dog and Samoyed are all of type "Dog" and yet they each have different traits and some of the same traits at the same time. For a list of attributes that they have in common (a shortened list here for clarity) are as follows:

• size
• temperment
• habits

Show me the code!

Patience gentle reader! One way I could handle this is to create a base class such that:

package dog;

sub new {
   my $proto=shift;
   my $class=ref($proto)||$proto;
   my $self = { # I'll add attrs later...
         };
   bless $self,$class;
   return $self;
}

1;

Then I would create a subclass for each breed of dog:

package dog::cocker;
use dog;
use vars qw/ @ISA /;
@ISA=qw/dog/;

sub new {
    my $proto=shift;
    my $class=ref($proto)||$proto;
    my $self = { 
            habits => 'barks at strangers',
            size => 'small',
            temperment => 'very loyal'
       };
     bless $self,$class;
}

1;

and then to instantiate my class in a calling environment I would do the following:

use dog::cocker;

my $sasha=new dog::cocker;

Teaching an old dog new tricks

I think there is a better way. What if I could make the base class dog smarter and have it instantiate the subclasses for me? Here is my smarter dog:

package dog; 

sub new {
    my $proto=shift;
    my $class=ref($proto)||$class;
    my $self={};   # We should be overriding this...
    my $breed=shift;  # OK... so what kind of doggie are we?
    if ( $breed ) { # if not nill...
      $breed = "dog::" . $breed;
      eval " use $breed; " ;
      die $@ if $@;
      $self= new $breed;
      bless $self,$breed;
    } else {
      bless $self,$class; # kinda useless but we have to.
      return $self;
    }
}
sub bark { 
    my $self=shift;
    print "Woof!\n";
}
1;

OK... so what is going on here? Well now when we want to instantiate a breed we do the following:

use dog;

my $sasha= new dog('cocker');

$sasha -> bark();

and what is going on internally in the dog base object is is going to attempt to use a Perl module called "dog::cocker" within the eval statement. If the module does not exist we'll catch the error and the instantiation will fail.

So what?

Where this comes in handy is where we want to add a new subclass. You create the new module as before:

package dog::samoyed;
use dog;
use vars qw/ @ISA /;
@ISA=qw/dog/;

sub new {
    my $proto=shift;
    my $class=ref($proto) || $proto;
    my $self => {
         habits => 'generally ignores strangers',
         temperment => 'lazy', 
         size => 'large'
    };
    bless $self, $class;
}


1;

So now we can instantiate a Samoyed similarly.

.
.
.
my $frosty = new dog('samoyed');
.
.
.

Let's kick it up a notch! I'm going to add to the base class some default attribute values.

# after the "my $self" line we add:
     %def_attrs=(
         voice => "woof",
         color => "brown",
         likes_chilren => "yes"
    );

#
# After the $self = new $breed; line we do:
    foreach my $key(keys %def_attrs){
       $self->{$key} = $def_attrs{$key} if not $self->{key};
     }

The associative array %def_attrs contains attributes that our derived objects can over-ride. In our steps where $self gets initialized we test to make sure the derived object has not yet defined the attribute and we set it if it hasn't.

Example of an override:

package dog::cattle_dog;
use dog;
use vars qw /@ISA/;
@ISA=qw/dog/;

sub new { 
      my $proto=shift;
      my $class=ref($proto)|| $proto;
      my $self = {
      temperment => 'fiercley loyal',
      habits => 'leary of strangers',
      size => 'medium',
      voice => 'shriek', 
      loves_children => 'slathered in barbecue sauce'
      }; 
      bless $self, $class;
      return $self;
}

sub wag_tail {  # This is an override.. you'll see why later
     print "Tail raises over back!\n";
}

1;

putting it all together

The base module in its entirety (sort of!):

package dog; 

sub new {
    my $proto=shift;
    my $class=ref($proto)||$class;
    my $self={};   # We should be overriding this...
    my %def_attrs = (
        color => "brown",
        loves_children => "yes",
        voice => "woof"
    );
    my $breed=shift;  # OK... so what kind of doggie are we?
    if ( $breed ) { # if not nill...
      $breed = "dog::" . $breed;
      eval " use $breed; " ;
      die $@ if $@;
      $self= new $breed;
      foreach my $key{keys %def_attrs){
        $self->{$key} = $def_attrs{$key} if not $self->{$key};
      }
      bless $self,$breed;
    } else {
      bless $self,$class; # kinda useless but we have to.
      return $self;
    }
}
sub bark { 
    my $self=shift;
    print "Woof\n" if not $self->{voice};
    printf "%s\n",$self->{voice} if $self->{voice};
}

#
# Late addition
sub wag_tail {
   print "tail wagging\n";
}
1;

and a simple test script:

use dog;
use Data::Dumper;
use strict;

my $frosty = new dog('samoyed');
my $cosette= new dog('cattle_dog');
my $moose= new dog('cocker');

print Dumper($frosty,$cosette,$moose);

$moose->bark; $moose->wag_tail;
$cosette->bark; $cosette->wag_tail;
$frosty->bark; $frosty->wag_tail;

Which when run yields:

$VAR1 = bless( {
                 'voice' => 'yarf',
                 'color' => 'brown',
                 'habits' => 'does not even look  at strangers',
                 'loves_children' => 'yes',
                 'temperment' => 'lazy',
                 'size' => 'large'
               }, 'dog::samoyed' );
$VAR2 = bless( {
                 'voice' => 'shreik',
                 'color' => 'brown',
                 'habits' => 'bites strangers',
                 'loves_children' => 'slathered in barbeque sauce',
                 'temperment' => 'fiercely loyal',
                 'size' => 'medium'
               }, 'dog::cattle_dog' );
$VAR3 = bless( {
                 'voice' => 'harf',
                 'color' => 'brown',
                 'habits' => 'bark at strangers',
                 'loves_children' => 'if well behaved',
                 'temperment' => 'loyal',
                 'size' => 'small'
               }, 'dog::cocker' );
harf
butt wiggles
shreik
tail over back
yarf
tail wagging

Closing thoughts

This is just the tip of the iceburg. There are many ways you can make use of this techique with many real world applications. For instance: you are going to fork off several sets of child processes with common environmental variables that need to be set and common command line parameters plus a few unique ones. Write a base object with the common values and parameters, have the derived objects override parameters or add new ones as needed and have common "execute" method in the base object to tie it all together.

UPDATE:Added "wag_tail" method to the base object and overrode it in two cases.

[adrianh]

What if I could make the base class dog smarter and have it instantiate the subclasses for me?

For those who don't know this approach of having a single class instantiate different subclasses depending on the arguments is a common design pattern called an Abstract Factory (or sometimes Kit). If you keep an eye out you'll start seeing it everywhere (e.g. DBI instantiates different classes depending on the arguments to connect).

Class::Factory provides a little framework for rolling this sort of stuff together if you don't want to do it yourself.

[merlyn]

my $class=ref($proto)||$proto;

See Why ref($proto) should be avoided and ref($proto) - just say no!, please. And read my column that hits it head on when the publisher's embargo is lifted. (This is for future reference.)

[tye]

my $class=ref($proto)||­$proto;

I understand the reasons to avoid this construct.

But if you avoid it, then you need to replace it with something. Unfortunately, although I often see this construct derided, I very seldom see suggestions for what to replace that line with (even when I come out and ask for it). The most straightforward replacement is unacceptable to me. See Re^2: A few Perl OOP questions. (disparaging) for why.

I also consider the objections to this to be rather minor in impact in a lot of practical situations and appreciate the "sloppy" advantages of $obj->new() in a lot of pracitcal situations. So I consider this construct to be a net win for simple OO Perl classes in many cases.

I also provide an alternative to it in (tye)Re: Private Class Methods.

[merlyn]

From the article you can't see yet:

But here's the problem. When I survey experienced object-oriented programmers, and ask them what they expect new means when called on an instance (without looking at the implementation), the result usually divides rather equally into three camps: those that go "huh, why would you do that" and think it should throw an error, those that say that it would clone the object, and those that say it would copy the object's class but not the contents.

So, no matter what you intend if you make your new do one of those three things, two thirds of the people who look at it will be wrong. It's not intuitive. So, don't write code like that, and especially don't just cargo-cult that from the manpage into your code. If you want an object like another object, use ref explicitly, as shown above. If you want a clone, put cloning code into your package, and call clone, as we saw earlier.

[flyingmoose]

      eval " use $breed; " ;

Also, in true merlyn fashion, it looks like eval in this string context makes you have unsafe doggies if you are using your dogs on a web site and allowing input of the doggie type in a text field.

$dog = ' strict; doEvil(); ';

I also think the strange use of dog as a factory class to produce subtypes of dogs is a little odd-form from an OO form, and that most OO purists would frown on the eval and use of reflection to pick subclasses. But I come from a very non-Perlish OO background, so this is just my two cents.

In conclusion, if we want to call this a tutorial, I say this should be a tutorial on the factory pattern, not a tutorial on polymorphism. Polymorphism is a much more general concept, and we skip over that generality by starting with the factory piece first. I would be interested to see if the factory could be made without using eval, as well...I think it can, especially if the dogs were loaded previously in a more-safe matter. But hey, maybe we don't have to worry about unsafe loading of doggies -- they do allright in the back of a pickup truck usually :)

Anyway, cool stuff, just a few ideas thrown out here. *yelp*.

[hardburn]

Polymorphism is a much more general concept, and we skip over that generality by starting with the factory piece first.

See my reply below for why this isn't a good example of polymorphisim anyway. Update: blue_cowdawg's update fix the OP's polymorphisim issue.

I would be interested to see if the factory could be made without using eval, as well...I think it can, especially if the dogs were loaded previously in a more-safe matter.

It can using require $path_to_breed; instead of eval "use $breed;";. But it ammounts to almost the same thing, except that you have to specifiy the path to the breed file instead of the traditional 'module::name' format. As you say, it's also possible to load all the subclasses before anything is called, but that could get very inefficient fast.

My favored solution would be to map a breed via a hash:

my %breeds = (
    cocker   => 'dog::cocker', 
    setter   => 'dog::setter', 
);

sub new 
{
    my $class = shift;
    my $breed = shift;
    
    my $self = { };
    if($breed) {
        my $breed_class = $breeds{$breed};
        eval " use $breed_class ";
        die $@ if $@;
        $self = $breed_class->new();
    }
    else {
        bless $self, $class;
    }

    return $self;
}

[rinceWind]

As you point out, using a constructor on an existing object is something unnatural; I agree that ref($proto) should be avoided in normal cases.

However, there are times when you specifically want to clone or template a new object (e.g. Class::Classless). I you are doing something like this, you should make it clear in the POD that this method call is available, and precisely what it does. This should state (if this is the case) that new can be use both as a class method call and an object method call.

Also, as part of the POD, it forms part of your interface contract. You should write tests which exercise all the options and prove that your code matches what the POD expects to happen.

My $0.02

[hardburn]

$self= new $breed;
. . . 
bless $self,$breed;

I don't think this will do what you want. This will re-bless the reference into the dog package, which means that if you asked for a 'cocker' breed, any methods that dog::cocker overrides won't be called. Instead, the methods in dog will be called. Update: Read the code wrong--ignore this pargraph.

Which is really unfortunate, since it could be quite useful to override the bark method in your final example. Instead of checking if this instance has a voice attribute that is true, the subclass would already know and Do The Right Thing. That's where polymorphism starts becoming powerful.

[blue_cowdawg]

I don't think this will do what you want.

Actually it does. The code was actually tested before I posted it. What you see is what I got.

[hardburn]

I see where I went wrong. I read the above as bless $self, $class instead of bless $self, $breed.

In any case, I still think that if you want this to be a good tutorial on polymorphism, some of the subclasses should override bark. As it is, it doesn't take advantage of polymorphism.