Beefy Boxes and Bandwidth Generously Provided by pair Networks
Perl: the Markov chain saw

Comment on

( #3333=superdoc: print w/replies, xml ) Need Help??

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.

In reply to It's a dog, but what kind? (polymorphism , in Perl OO) by blue_cowdawg

Use:  <p> text here (a paragraph) </p>
and:  <code> code here </code>
to format your post; it's "PerlMonks-approved HTML":

  • Posts are HTML formatted. Put <p> </p> tags around your paragraphs. Put <code> </code> tags around your code and data!
  • Titles consisting of a single word are discouraged, and in most cases are disallowed outright.
  • Read Where should I post X? if you're not absolutely sure you're posting in the right place.
  • Please read these before you post! —
  • Posts may use any of the Perl Monks Approved HTML tags:
    a, abbr, b, big, blockquote, br, caption, center, col, colgroup, dd, del, div, dl, dt, em, font, h1, h2, h3, h4, h5, h6, hr, i, ins, li, ol, p, pre, readmore, small, span, spoiler, strike, strong, sub, sup, table, tbody, td, tfoot, th, thead, tr, tt, u, ul, wbr
  • You may need to use entities for some characters, as follows. (Exception: Within code tags, you can put the characters literally.)
            For:     Use:
    & &amp;
    < &lt;
    > &gt;
    [ &#91;
    ] &#93;
  • Link using PerlMonks shortcuts! What shortcuts can I use for linking?
  • See Writeup Formatting Tips and other pages linked from there for more info.
  • Log In?

    What's my password?
    Create A New User
    [Discipulus]: good morning folks!

    How do I use this? | Other CB clients
    Other Users?
    Others browsing the Monastery: (4)
    As of 2017-09-25 06:50 GMT
    Find Nodes?
      Voting Booth?
      During the recent solar eclipse, I:

      Results (276 votes). Check out past polls.