Here's the complete code, after a little change in the constructor method. I dropped the lists and implemented the protected and or private access as a field in the $self hash. It's an implementation of the strategy pattern (yeah, just bought the Head First Design Patterns).
./src/bo/behaviour/FlyBehaviour.pm
package src::bo::behaviour::FlyBehaviour;
use strict;
use warnings;
use Carp;
sub new {
my $class = shift;
my $self = {
};
my $closure = sub {
my $field = shift;
if (@_) { $self->{$field} = shift; }
return $self->{$field};
};
bless ($closure, $class);
return $closure;
}
sub fly() {
confess "FlyBehaviour is an abstract base class";
}
1;
./src/bo/behaviour/QuackBehaviour.pm
package src::bo::behaviour::QuackBehaviour;
use strict;
use warnings;
use Carp;
sub new {
my $class = shift;
my $self = {
};
my $closure = sub {
my $field = shift;
if (@_) { $self->{$field} = shift; }
return $self->{$field};
};
bless ($closure, $class);
return $closure;
}
sub quack() {
confess "QuackBehaviour is an abstract base class";
}
1;
./src/bo/behaviour/fly/CanFly.pm
package src::bo::behaviour::fly::CanFly;
use strict;
use warnings;
use Carp;
use src::bo::behaviour::FlyBehaviour;
use base qw/src::bo::behaviour::FlyBehaviour/;
sub fly() {
return "can fly";
}
1;
./src/bo/behaviour/fly/CannotFly.pm
package src::bo::behaviour::fly::CannotFly;
use strict;
use warnings;
use Carp;
use src::bo::behaviour::FlyBehaviour;
use base qw/src::bo::behaviour::FlyBehaviour/;
sub fly() {
return "cannot fly";
}
1;
./src/bo/behaviour/quack/CanQuack.pm
package src::bo::behaviour::quack::CanQuack;
use strict;
use warnings;
use Carp;
use src::bo::behaviour::QuackBehaviour;
use base qw/src::bo::behaviour::QuackBehaviour/;
sub quack() {
return "can quack";
}
1;
./src/bo/behaviour/quack/CannotQuack.pm
package src::bo::behaviour::quack::CannotQuack;
use strict;
use warnings;
use Carp;
use src::bo::behaviour::QuackBehaviour;
use base qw/src::bo::behaviour::QuackBehaviour/;
sub quack() {
return "cannot quack";
}
1;
./src/bo/behaviour/quack/CanSqeek.pm
package src::bo::behaviour::quack::CanSqeek;
use strict;
use warnings;
use Carp;
use src::bo::behaviour::QuackBehaviour;
use base qw/src::bo::behaviour::QuackBehaviour/;
sub quack() {
return "can sqeek";
}
1;
./src/bo/Duck.pm
package src::bo::Duck;
use strict;
use warnings;
use Carp;
sub new {
my $class = shift;
my $self = {
FLYBEHAVIOUR => { 'VALUE' => undef, 'ACCESS' => 'protected' },
QUACKBEHAVIOUR => { 'VALUE' => undef, 'ACCESS' => 'protected'
+},
};
my $closure = sub {
my $field = shift;
$self->{$field}->{'ACCESS'} eq 'private'
and caller(0) eq __PACKAGE__
|| confess "$field is private";
$self->{$field}->{'ACCESS'} eq 'protected'
and caller(0)->isa(__PACKAGE__)
|| confess "$field is protected";
if ( @_ ) { $self->{$field}->{'VALUE'} = shift; }
return $self->{$field}->{'VALUE'};
};
bless ($closure, $class);
return $closure;
}
sub setFlyBehaviour {
# caller(0)->isa(__PACKAGE__) || confess "setFlyBehaviour is protec
+ted";
my $closure = shift;
my $flyBehaviour = shift;
&{ $closure }("FLYBEHAVIOUR", $flyBehaviour);
}
sub setQuackBehaviour {
# caller(0)->isa(__PACKAGE__) || confess "setQuackBehaviour is prot
+ected";
my $closure = shift;
my $quackBehaviour = shift;
&{ $closure }("QUACKBEHAVIOUR", $quackBehaviour);
}
sub doFly {
my $closure = shift;
&{ $closure }("FLYBEHAVIOUR")->fly();
}
sub doQuack() {
my $closure = shift;
&{ $closure }("QUACKBEHAVIOUR")->quack();
}
1;
./src/bo/Rubber.pm
package src::bo::Rubber;
use strict;
use warnings;
use Carp;
use src::bo::Duck;
use base qw/src::bo::Duck/;
use src::bo::behaviour::fly::CannotFly;
use src::bo::behaviour::quack::CanSqeek;
sub new {
my $class = shift;
my $extends = $class->SUPER::new( @_ );
$extends->setFlyBehaviour( src::bo::behaviour::fly::CannotFly->new
+() );
$extends->setQuackBehaviour( src::bo::behaviour::quack::CanSqeek->
+new() );
my $self = {
COLOR => { 'VALUE' => undef, 'ACCESS' => 'protected' },
};
my $closure = sub {
my $field = shift;
if ( exists $self->{$field} ) {
$self->{$field}->{'ACCESS'} eq 'private'
and caller(0) eq __PACKAGE__
|| confess "$field is private";
$self->{$field}->{'ACCESS'} eq 'protected'
and caller(0)->isa(__PACKAGE__)
|| confess "$field is protected";
if ( @_ ) { $self->{$field}->{'VALUE'} = shift; }
return $self->{$field}->{'VALUE'};
}
else {
return $extends->($field,@_);
}
};
bless ($closure, $class);
return $closure;
}
sub setColor {
my $closure = shift;
my $color = shift;
&{ $closure }("COLOR", $color );
}
sub getColor {
my $closure = shift;
&{ $closure }("COLOR");
}
1;
./src/bo/Whistle.pm
package src::bo::Whistle;
use strict;
use warnings;
use Carp;
use src::bo::Duck;
use base qw/src::bo::Duck/;
use src::bo::behaviour::fly::CannotFly;
use src::bo::behaviour::quack::CannotQuack;
sub new {
my $class = shift;
my $flyBehaviour = src::bo::behaviour::fly::CannotFly->new();
my $quackBehaviour = src::bo::behaviour::quack::CannotQuack->new()
+;
my $extends = $class->SUPER::new( @_ );
$extends->setFlyBehaviour( $flyBehaviour );
$extends->setQuackBehaviour( $quackBehaviour );
bless ( $extends, $class );
return $extends;
}
1;
./t/bo/Duck.t
#!/usr/bin/perl
use strict;
use warnings;
#use Test::More tests => 10;
use Test::More qw(no_plan);
use Test::Exception;
use src::bo::Duck;
use src::bo::Rubber;
use src::bo::Whistle;
use src::bo::behaviour::fly::CanFly;
use src::bo::behaviour::fly::CannotFly;
use src::bo::behaviour::quack::CanQuack;
use src::bo::behaviour::quack::CannotQuack;
my $duck = src::bo::Duck->new( );
# a quick check if it's a src::bo::Duck object
is ( ref ($duck), "src::bo::Duck", "A duck object" );
# setFlyBehaviour is public so should be callable
lives_ok { $duck->setFlyBehaviour( src::bo::behaviour::fly::CannotFly-
+>new() ) }
"setFlyBehaviour is public";
# impossible to modify FLYBEHAVIOUR as it is protected
throws_ok { $duck->("FLYBEHAVIOUR", src::bo::behaviour::fly::CannotFly
+->new() ) }
qr/FLYBEHAVIOUR is protected/, "FLYBEHAVIOUR is protected";
my $rubber = src::bo::Rubber->new();
# a quick check if it's a src::bo::Rubber object
is ( ref ($rubber), "src::bo::Rubber", "A rubber duck object" );
# a rubber duck cannot fly
is ( $rubber->doFly(), "cannot fly", "the rubber duck cannot fly" );
# a rubber duck sqeeks
is ( $rubber->doQuack(), "can sqeek", "the rubber duck sqeeks" );
my $whistle = src::bo::Whistle->new();
# a quick check if it's a src::bo::Whistle object
is ( ref ($whistle), "src::bo::Whistle", "A whistle object" );
# a whistle duck cannot fly
is ( $whistle->doFly(), "cannot fly", "the whistle doesn't fly" );
# a whistle cannot quack
is ( $whistle->doQuack(), "cannot quack", "the whistle doesn't quack"
+);
# setQuackBehaviour is public so should be callable
lives_ok { $whistle->setQuackBehaviour( src::bo::behaviour::quack::Can
+Quack->new() ) }
"setQuackBehaviour is public";
# impossible to modify QUACKBEHAVIOUR as it is protected
throws_ok { $whistle->("QUACKBEHAVIOUR", src::bo::behaviour::quack::Ca
+nQuack->new() ) }
qr/QUACKBEHAVIOUR is protected/, "QUACKBEHAVIOUR is protected";
# a whistle does quack now because we use a strategy pattern
is ( $whistle->doQuack(), "can quack", "the whistle does quack" );
$rubber->setColor("red");
is ( $rubber->getColor(), "red", "rubber is a red color" );
Running all gives me:
bash-3.00$ prove -v -r
t/bo/Duck....ok 1 - A duck object
ok 2 - setFlyBehaviour is public
ok 3 - FLYBEHAVIOUR is protected
ok 4 - A rubber duck object
ok 5 - the rubber duck cannot fly
ok 6 - the rubber duck sqeeks
ok 7 - A whistle object
ok 8 - the whistle doesn't fly
ok 9 - the whistle doesn't quack
ok 10 - setQuackBehaviour is public
ok 11 - QUACKBEHAVIOUR is protected
ok 12 - the whistle does quack
ok 13 - rubber is a red color
1..13
ok
All tests successful.
Files=1, Tests=13, 1 wallclock secs ( 0.28 cusr + 0.35 csys = 0.63
+CPU)