OO Inheritence

[Limbic~Region]

All:
I was looking at Sprad's question and thinking this was a good excuse to try inheritence out for the first time. Since most problems here at the Monastery do not involve "how should I implement inheritence", I figured Meditations was the appropriate place. Here is how I did it:

The parent class Vehicle

package Vehicle;
use strict;
use warnings;
use Carp;
use vars '$AUTOLOAD';

sub new {
    my $class = shift;
    croak "Incorrect number of parameters" if @_ % 2;
    my $self = bless {}, $class;
    $self->_init( @_ );
    return $self;
}

sub AUTOLOAD {
    return   if $AUTOLOAD =~ /::DESTROY$/;
    no strict 'refs';
    my ($key) = $AUTOLOAD =~ /::(\w+)$/;
    *{$AUTOLOAD} = sub {
        my $self = shift;
        if ( exists $self->{$key} ) {
            if ( defined $_[0] ) {
                croak "$key is read only" if $self->_read_only( $key )
+;
                $self->{$key} = $_[0];
            }
            else {
                return $self->{$key};
            }
        }
        else {
            croak "$key is not valid for this class" if ! $self->_vali
+d( $key );
            return undef if ! defined $_[0];
            $self->{$key} = $_[0];
        }
    };
    $AUTOLOAD->( @_ );
}
1;

The Bike class

package Bike;
use base Vehicle;
@ISA = 'Vehicle';

use strict;
use warnings;
use Carp;


my %valid = map { $_ => 1 } qw( Wheels Doors Color Passengers );
my %ro    = map { $_ => 1 } qw( Wheels Passengers );

sub _init {
    my ($self, %arg) = @_;
    for my $option ( keys %arg ) {
        croak "$option is not valid" if ! $self->_valid( $option );
        $self->{$option} = $arg{$option};
    }
    $self->{Wheels}     = 2;
    $self->{Passengers} = 1; # More than 1 is dangerous afterall
    return;
}

sub _read_only {
    my ($self, $option) = @_;
    return defined $ro{$option} ? 1 : 0;
}

sub _valid {
    my ($self, $option) = @_;
    return defined $valid{$option} ? 1 : 0;
}
1;

The Car class

package Car;
use base Vehicle;
@ISA = 'Vehicle';

use strict;
use warnings;
use Carp;


my %valid = map { $_ => 1 } qw( Wheels Doors Color Passengers );
my %ro    = map { $_ => 1 } qw( Wheels );

sub _init {
    my ($self, %arg) = @_;
    for my $option ( keys %arg ) {
        croak "$option is not valid" if ! $self->_valid( $option );
        $self->{$option} = $arg{$option};
    }
    $self->{Wheels} = 4;
    return;
}

sub _read_only {
    my ($self, $option) = @_;
    return defined $ro{$option} ? 1 : 0;
}

sub _valid {
    my ($self, $option) = @_;
    return defined $valid{$option} ? 1 : 0;
}
1;

And finally a script that uses some of the functionality.

#!/usr/bin/perl
use strict;
use warnings;
use Bike;
use Car;

my $bike_1 = Bike->new();

# Shows setting default values;
print "My first bike had ", $bike_1->Wheels, " wheels\n";

# Automatically create an accessor/mutator method
$bike_1->Color('red');
print "My first bike was ", $bike_1->Color, "\n";

# Going to croak - unicycles aren't allowed
$bike_1->Wheels(1);
print "My first bike had ", $bike_1->Wheels, " wheels\n";

# Going to croak - Price is not valid for this class
print "My first bike was ", $bike_1->Price(), " dollars\n";

my $car_1 = Car->new(
    'Wheels'     => 7,
    'Color'      => 'blue',
    'Passengers' => 2,
);

# We don't allow Frankestein cars
print "My first car had ", $car_1->Wheels, " wheels\n";

So here is the meditation:

• What have I done right?
• What have I done wrong?
• What have I left out?
• What would you have done differently (syntax and implementation)?
• If you think it is all wrong - how would you do it?
• If I have done anything you think is particularly clever, what and why?

Looking forward to a better understanding of inheritence!

Cheers - L~R

[chromatic]

use base Vehicle;
@ISA = 'Vehicle';

Pick one or the other, not both. I prefer base.

croak "$option is not valid" if ! $self->_valid( $option );

Use unless.

my %valid = map { $_ => 1 } qw( Wheels Doors Color Passengers );
my %ro    = map { $_ => 1 } qw( Wheels );

sub _read_only {
    my ($self, $option) = @_;
    return defined $ro{$option} ? 1 : 0;
}

If you elided the lexicals in favor of class methods, you wouldn't have to repeat this code in both subclasses:

sub _attributes
{
    return
    {
        map { $_ => 1 } qw( Wheels Doors Color Passengers )
    };
}

sub _valid
{
    my ($self, $attribute) = @_;
    return exists $self->_attributes()->{ $attribute };
}

Finally, aside from inheriting a constructor and an AUTOLOAD, I don't see any reason why you need to inherit here. You'd probably be better off using a module that autogenerated your accessors. It's not wrong, but I don't see any real benefits to this approach.

I did it this way when I was first learning, though. It won't cause you any real trouble; it's just a bit more complication that doesn't add very much. ~shrug~

[exussum0]

Croaking in your constructor is a bit harsh. How about undef? As chromatic said, if you dont' read documentation about something, like this, you get what you deserve. I don't agree with that, because if someone carelessly creates something great that ignores croak, and then you use that, you may find yourself with a bug 'cause of some odd situation.

At least w/ undef, you can be more forgiving.

[stvn]

At least w/ undef, you can be more forgiving.

But it also requires that it be checked for. I think returning undef has its place, but so does throwing an exception (a.k.a. - croaking). I see the logic in allowing the user of your object/class/module to choose to die or not, after all, this...

my $o = Class->new(@arg) || die "cannot create new Class";

is a common enough idiom. But I can also see the logic in throwing an exception and just requiring the user to catch that exception. For me, it really comes down to how you plan to structure the error handling in the rest of your code.

[tilly]

And you never mistype a parameter name?

When I've done something wrong, I like informative error messages. Think of error checks like that as being kind of like strict.pm in effect. It saves me time in development. That someone who shoots themselves in the foot deliberately won't see the benefit is not a problem for me.

[mstone]

Inheri-tance, actually.. you had a typo. ;-)

By my standards, there's exactly one reason to use inheritance: to define the shared interface and default behavior for a family of similar classes.

The code you gave doesn't quite do that. The default interface for Vehicle is 'pretty much anything'. You've tried to roll your own way of making the interfaces stable, but it doesn't work as well as it could. There's no guarantee Bike and Car will share the same data members (and, by extension, the same access methods), for instance. You've forced the interfaces to be the same by defining the '%valid' hash redundantly, but you'd be better off sinking that information down to the Vehicle class.

In fact, I'd suggest getting rid of AUTOLOAD entirely, defining the methods you want explicitly in Vehicle, then scrapping the '%ro' hash and overriding the subclass methods to get the behavior you want:

    package Vehicle;
    
    sub new {
        my ($type, $data) = @_;
        
        my $O = bless $type->_defaults(), $type;                # [1]
        
        for $k (keys %$O) {
            $O->{$k} = $data->{$k} if defined ($data->{$k});    # [2]
        }
        $O->_sanity_check();                                    # [3]
        
        return $O;
    }
    
    =item new (hash-ref: data) : Vehicle-ref
    
    [1] We start from a prototype data structure known to be good.
    
    [2] Now we override any values defined by the arguments.  We
        only override values that are already in the prototype, 
        though.  We don't want to add anomalous data members by 
        just copying everything straight over.
    
    [3] Now we run the new values through a hygiene filter to make
        sure everything's still good.
    
    =cut
    
    
    sub _defaults {
        return ({
            'wheels'        =>  0,
            'doors'         =>  0,
            'color'         =>  'none',
            'passengers'    =>  0,
        });
    }
    
    =item _defaults (nil) : hash-ref
    
    This method takes no input, and returns a pre-filled hash of valid
    attributes for a given vehicle type.
    
    Technically, this is a lobotomized version of the Factory Method
    design pattern.
    
    =cut
    
    sub _sanity_check {
        my $O = shift;
        
        if ($O->{'wheels'}) {
            print STDERR "I ran into a problem.. "
                . "a generic vehicle shouldn't have "
                . $O->{'wheels'} . ' '
                . "wheels.\n"
            ;
        }
        if ($O->{'doors'}) {
            print STDERR "I ran into a problem.. "
                . "a generic vehicle shouldn't have "
                . $O->{'doors'} . ' '
                . "doors.\n"
            ;
        }
        if ('none' ne $O->{'color'}) {
            print STDERR "I ran into a problem.. "
                . "a generic vehicle shouldn't be colored "
                . $O->{'color'}
                . ".\n"
            ;
        }
        if ($O->{'passengers'}) {
            print STDERR "I ran into a problem.. "
                . "a generic vehicle doesn't carry "
                . $O->{'passengers'} . ' '
                . "passengers.\n"
            ;
        }
        return;
    }
    
    =item _sanity_check (nil) : nil
    
    This method doesn't take any input or return any value as
    output, but it does print any errors it sees to STDERR.  In
    a real program, we'd use some kind of trace to see when and
    where the error occured.
    
    =cut
    
    sub _access {
        my ($O, $item, $value) = @_;
        
        if (defined ($value)) {
            $O->{$item} = $value;
            $O->_sanity_check();
        }
        
        return ($O->{$item});
    }
    
    =item _access (item, value) : value
    
    This is a generic back-end for the accessor functions.  It
    takes the attribute name and an optional value as input, and
    returns the item's value as output.
    
    I've thrown in a sanity check every time an item's value is
    changed, just for the sake of paranoia.
    
    =cut
    
    sub Wheels { return ($_[0]->_access ('wheels', $_[1])); }
    sub Doors { return ($_[0]->_access ('doors', $_[1])); }
    sub Color { return ($_[0]->_access ('color', $_[1])); }
    sub Passengers { return ($_[0]->_access ('passengers', $_[1])); }
    
    =item accessor methods
    
    These are trivial methods that handle get-and-set operations
    for the attributes.  The fact that _access() does an
    automatic sanity check after setting any new value means we
    don't have to put sanity checks in each of these methods..
    though we probably would do individual sanity checks in a
    real application.
    
    This is one of those cases where 'lazy' means 'doing lots
    of work now so we won't have to do even more work later'.
    
    =cut
    
    
    package Bike;
    @ISA = qw( Vehicle );
    
    =item Class Bike
    
    This class will override _defaults(), _sanity_check(), and
    possibly some of the access methods if we want to make
    'wheels' always equal 2, for instance:
    
    sub Wheels {
        if ((defined $_[1]) && (2 != $_[1])) {
            print "You can't do that.  I won't let you.  So there.\n";
        }
    }
    
    =cut
    
    
    package Car;
    @ISA = qw( Vehicle );
    
    =item Class Car
    
    Again, this class will override _defaults(),
    _sanity_check(), and any access methods we want to harden
    against changes.
    
    =cut

[eric256]

I was recently playing with inheritance and built an object.pm because i was tired of haveing to remake those bits everytime. Here is my object.pm followed by your modified Car and Bike objects. I wish that inherited modules also used the same modules that there parent used....if that makes since. So that i wouldn't need strict, warnings,and Carp because they are all part of the parent object. Anyway here it is.

Read more... (2 kB)

package Car;
use base object;

use strict;
use warnings;
use Carp;

sub defaults {{   Wheels => 4,
                  Doors => undef,
                  Color => undef,
                  Passengers => undef
               }};

sub readonly { qw/Wheels/ };                 
1;

package Bike;
use base object;

use strict;
use warnings;
use Carp;

sub defaults {{ Wheels => 2,
                Doors => undef,
                Color => undef,
                Passengers => 2,
               }};

sub readonly { qw/Wheels Passengers/ };
1;

[rir]

It is not suitable to use AUTOLOAD in a module for general use. Two AUTOLOADs cannot coexist amicably in the same inheritance tree. Try it, one masks the other.

[adrianh]

Two AUTOLOADs cannot coexist amicably in the same inheritance tree. Try it, one masks the other

While I am not a fan of AUTOLOAD it is perfectly possibly to have multiple AUTOLOADs coexisting amicably in the same inheritance tree. (using SUPER and NEXT).

[dragonchild]

--! Bad saint, no cookie.

Yes, it's perfectly possible to have AUTOLOADs in the same inheritance tree. You can even have them dispatch to one another. And, this would be a very obfuscated version of spaghetti programming. (Yes, spaghetti that's further obfu'ed!)

Think for a second about how you would go about maintaining that kind of programming. I know which one I'd prefer to maintain!

(By maintain, I mean that there was a wizard who wrote the software, N normal humans who extended it, and now I am handed the mess.)

[ihb]

it is perfectly possibly

Remove "perfectly" from that sentence and I'll agree with you. From NEXT's documentation:

Because it's a module, not an integral part of the interpreter, NEXT.pm has to guess where the surrounding call was found in the method look-up sequence. In the presence of diamond inheritance patterns it occasionally guesses wrong.

It's also too slow (despite caching).

I repeat what I've said earlier, that using AUTOLOAD may very well cause you a bigger problem than the one you tried to solve. (Re: is autoload bad style?)

ihb

[runrig]

Two AUTOLOADs cannot coexist amicably in the same inheritance tree. Try it, one masks the other.

The OP only has one AUTOLOAD, in the base class. IMHO, this is fine, as long as all derived classes play nicely.

[rir]

Agreed, but I say playing nicely is a practice that does not scale. If you won't distribute the code there is nothing wrong with using AUTOLOAD.

I am saying that AUTOLOAD does not scale well. Every use of AUTOLOAD in a program should be under the control of one party. If two separate authors use AUTOLOAD in the same program breakage is likely.

Being conservative, I would be suspicious of any program with more than one AUTOLOAD. If two AUTOLOAD routines exist in a hierarchy there is a problem. (Don't forget UNIVERSAL.)

This is a known problem. Consider:

#!/usr/bin/perl
use strict;
use warnings;

# I decide to use a module
package Vehicle;
use vars '$AUTOLOAD';

sub new { return bless {}, $_[0]; }

# handle all "V*" calls
sub AUTOLOAD {
        my ($key) =  $AUTOLOAD =~/::(\w+)/;
        return if $key =~ /^[A-Z]+$/;
        die "Vehicle::AUTOLOAD can't cope as $key"
                unless $key =~ /^[vV]/;
        print "Leaving  Vehicle::AUTOLOAD as $key$/";
}


# with my program below

package Animal;
use vars '$AUTOLOAD';

sub new { return bless {}, $_[0]; }

# handle all "A*" calls
sub AUTOLOAD {
        my ($key) =  $AUTOLOAD =~/::(\w+)/;
        return if $key =~ /^[A-Z]+$/;
        die "Animal::AUTOLOAD can't cope as $key"
                unless $key =~ /^[aA]/;
        print "Leaving  Animal::AUTOLOAD as $key$/";
}


package Horse;
use vars qw/ @ISA /;
@ISA = qw/ Vehicle  Animal /;



package  main;

# the two usages cannot work together,  I needed to
# know that Vehicle used AUTOLOAD so I could avoid it
# or rewrite my code to eliminate AUTOLOAD.

my $h = Horse->new;
$h->Veh();
$h->Ani();  # call intercepted by Vehicle AUTOLOAD

Be well.

[EdwardG]

Learning in public++