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;

[download]

./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;

[download]

./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;

[download]

./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;

[download]

./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;

[download]

./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;

[download]

./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;

[download]

./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;

[download]

./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;

[download]

./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;

[download]

./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" );

[download]

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)

[download]
--
if ( 1 ) { $postman->ring() for (1..2); }

In reply to Re: A quicker way to have protected and private fields? by gargle
in thread A quicker way to have protected and private fields? by gargle

Title:
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, details, 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, summary, 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.