CBase *p;
p = new(CDerived);
p->virtual_function();

##</code><code>##

package Dog::Proxy;

use strict;
use Dog::Base;
use Dog::Cocker;
use Dog::CattleDog;

my %derived_classes = (
	cocker => 'Dog::Cocker',
	cattledog => 'Dog::CattleDog',
);

sub new {
	my $class = shift;
	die if ref $class;
	my $type = shift;
	die "Cant create Dog::Base without breed" unless $type;
	die "Type $type not registered" unless exists $derived_classes{$type};
	my $class = $derived_classes{$type};
	return $class->new();
}

1;

##</code><code>##

package Dog::Base;

use strict;
my %basic_attr = (
	legs=>4,
	tail=>1,
	nose=>'wet',
);
sub new {
	my $class = shift;
	my $self = {} unless ref $class;
	$self = {
			base=>{%basic_attr},
			breed=>{},
	};
	return bless($self, $class);
}

1;

##</code><code>##

package Dog::Cocker;

use strict;
require Dog::Base;
use vars '@ISA';
@ISA = 'Dog::Base';

my %cocker_attr = (
	habits => 'barks at strangers',
	size => 'small',
	temperment => 'very loyal'
);

sub new {
	my $class = shift;
	my $self = Dog::Base->new() unless ref $class;
	$self->{breed} = {%cocker_attr};
	return bless($self, $class);
}

sub bark {
	my $self = shift;
	print "yarf\n";
}

sub wag_tail {
	my $self = shift;
	print "tail wagging\n";
}

1;

package Dog::CattleDog;

use strict;
require Dog::Base;
use vars '@ISA';
@ISA = 'Dog::Base';

my %cattledog_attr = (
	temperment => 'fiercley loyal',
	habits => 'leary of strangers',
	size => 'medium',
);

sub new {
	my $class = shift;
	my $self = Dog::Base->new() unless ref $class;
	$self->{breed} = {%cattledog_attr};
	return bless($self, $class);
}

sub bark {
	my $self = shift;
	print "shriek\n";
}

sub wag_tail {
	my $self = shift;
	print "tail over back\n";
}

1;

##</code><code>##

#!/usr/local/bin/perl -wT
# test.pl

use Dog::Proxy;
use Data::Dumper;
use strict;

my $cosette= Dog::Proxy->new('cattledog');
my $moose= Dog::Proxy->new('cocker');

print Dumper($cosette,$moose);

$cosette->bark; $cosette->wag_tail;
$moose->bark; $moose->wag_tail;

##</code><code>##

$VAR1 = bless( {
                 'breed' => {
                              'habits' => 'barks at strangers',
                              'temperment' => 'very loyal',
                              'size' => 'small'
                            },
                 'base' => {
                             'legs' => 4,
                             'nose' => 'wet',
                             'tail' => 1
                           }
               }, 'Dog::Cocker' );
$VAR1 = bless( {
                 'breed' => {
                              'habits' => 'leary of strangers',
                              'temperment' => 'fiercley loyal',
                              'size' => 'medium'
                            },
                 'base' => {
                             'legs' => 4,
                             'nose' => 'wet',
                             'tail' => 1
                           }
               }, 'Dog::CattleDog' );
yarf
tail wagging
shriek
tail over back