But I can subclass already by doing:

In the case of this strategy pattern I don't think I would gain much. Maybe you know of other cases?

Suppose I want to subclass your original class to add a single attribute. What does the code look like to do that? What does the code look like to use the object?

Something like this I'd guess:

sub new {
    my $class   = shift;

    my $extends = $class->SUPER::new(@_);
    $extends->setFlyBehaviour( src::bo::CannotFly->new() );
    $extends->setQuackBehaviour( src::bo::CanSqeek->new() );
    
    my $self = {
        COLOR   => undef,
    };
    my @protected = qw/COLOR/;
    my @private   = qw//;

    my $closure = sub {
        my $field = shift;
        if ( exists $self->{$field} ) {
            grep( /$field$/, @private ) and caller(0) eq __PACKAGE__ 
                || confess "$field is private";
            grep( /$field/, @protected ) and caller(0)->isa(__PACKAGE_
+_)
                || confess "$field is protected";
            if (@_) { $self->{$field} = shift; }
            return $self->{$field};
        }
        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;
    return &{ $closure }("COLOR");
}
[download]

Ok, I have to repeat the incantation to mark the private and protected fields as such... for as long as I want to go that far. Here I don't use privates so I could drop the @private and the grep for private fields. In fact I could drop the grep as well and just test on the name before calling confess.

It would be neat to have a cpan class that would do this automagically though...

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

To use the class:

my $duck = src::bo::Duck->new();
is( ref($duck), "src::bo::Duck", "A duck object" );
throws_ok { $duck->setFlyBehaviour( src::bo::CannotFly->new() ) }
  qr/setFlyBehaviour is protected/, "setFlyBehaviour is protected";
throws_ok { $duck->( "FLYBEHAVIOUR", src::bo::CannotFly->new() ) }
  qr/FLYBEHAVIOUR is protected/, "FLYBEHAVIOUR is protected";

#is( $duck->doFly(), "cannot fly", "the duck cannot fly" );

my $rubber = src::bo::Rubber->new();
is( ref($rubber),       "src::bo::Rubber", "A rubber duck object" );
is( $rubber->doFly(),   "cannot fly",      "the rubber duck cannot fly
+" );
is( $rubber->doQuack(), "can sqeek",       "the rubber duck sqeeks" );

my $whistle = src::bo::Whistle->new();
is( ref($whistle),       "src::bo::Whistle", "A whistle object" );
is( $whistle->doFly(),   "cannot fly",       "the whistle doesn't fly"
+ );
is( $whistle->doQuack(), "cannot quack",     "the whistle doesn't quac
+k" );

throws_ok { $whistle->setQuackBehaviour( src::bo::CanQuack->new() ) }
  qr/setQuackBehaviour is protected/, "setQuackBehaviour is protected"
+;
throws_ok { $whistle->( "QUACKBEHAVIOUR", src::bo::CanQuack->new() ) }
  qr/QUACKBEHAVIOUR is protected/, "QUACKBEHAVIOUR is protected";

$rubber->setColor("green");
is( $rubber->getColor(), "green", "it's a green rubber duck!" );
[download]

Ok, you have to imagine the 'use strict, use warnings, use Test::More, use Test::Exception, and all the use src::bo::somethings...

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