La devise de Perl reste : il existe plus d'une manière de le faire.
package Foo;
sub new {
my $type = shift;
my %params = @_;
my $self = {};
$self->{'High'} = $params{'High'};
$self->{'Low'} = $params{'Low'};
bless $self, $type;
}
package Bar;
sub new {
my $type = shift;
my %params = @_;
my $self = [];
$self->[0] = $params{'Left'};
$self->[1] = $params{'Right'};
bless $self, $type;
}
package main;
$a = Foo->new( 'High' => 42, 'Low' => 11 );
print "High=$a->{'High'}\n";
print "Low=$a->{'Low'}\n";
$b = Bar->new( 'Left' => 78, 'Right' => 40 );
print "Left=$b->[0]\n";
print "Right=$b->[1]\n";
package Foo;
sub new {
my $type = shift;
my $self;
$self = shift;
bless \$self, $type;
}
package main;
$a = Foo->new( 42 );
print "a=$$a\n";
package Bar;
sub new {
my $type = shift;
my $self = {};
$self->{'buz'} = 42;
bless $self, $type;
}
package Foo;
@ISA = qw( Bar );
sub new {
my $type = shift;
my $self = Bar->new;
$self->{'biz'} = 11;
bless $self, $type;
}
package main;
$a = Foo->new;
print "buz = ", $a->{'buz'}, "\n";
print "biz = ", $a->{'biz'}, "\n";
package Bar;
sub new {
my $type = shift;
my $self = {};
$self->{'buz'} = 42;
bless $self, $type;
}
package Foo;
sub new {
my $type = shift;
my $self = {};
$self->{'Bar'} = Bar->new;
$self->{'biz'} = 11;
bless $self, $type;
}
package main;
$a = Foo->new;
print "buz = ", $a->{'Bar'}->{'buz'}, "\n";
print "biz = ", $a->{'biz'}, "\n";
package Buz;
sub goo { print "here's the goo\n" }
package Bar; @ISA = qw( Buz );
sub google { print "google here\n" }
package Baz;
sub mumble { print "mumbling\n" }
package Foo;
@ISA = qw( Bar Baz );
sub new {
my $type = shift;
bless [], $type;
}
sub grr { print "grumble\n" }
sub goo {
my $self = shift;
$self->SUPER::goo();
}
sub mumble {
my $self = shift;
$self->SUPER::mumble();
}
sub google {
my $self = shift;
$self->SUPER::google();
}
package main;
$foo = Foo->new;
$foo->mumble;
$foo->grr;
$foo->goo;
$foo->google;
package Mydbm;
require SDBM_File;
require Tie::Hash;
@ISA = qw( Tie::Hash );
sub TIEHASH {
my $type = shift;
my $ref = SDBM_File->new(@_);
bless {'dbm' => $ref}, $type;
}
sub FETCH {
my $self = shift;
my $ref = $self->{'dbm'};
$ref->FETCH(@_);
}
sub STORE {
my $self = shift;
if (defined $_[0]){
my $ref = $self->{'dbm'};
$ref->STORE(@_);
} else {
die "Cannot STORE an undefined key in Mydbm\n";
}
}
package main;
use Fcntl qw( O_RDWR O_CREAT );
tie %foo, "Mydbm", "Sdbm", O_RDWR|O_CREAT, 0640;
$foo{'bar'} = 123;
print "foo-bar = $foo{'bar'}\n";
tie %bar, "Mydbm", "Sdbm2", O_RDWR|O_CREAT, 0640;
$bar{'Cathy'} = 456;
print "bar-Cathy = $bar{'Cathy'}\n";
Le premier exemple illustre une classe qui utilise un appel avec une syntaxe complète, d'une méthode afin d'accéder à la méthode privée BAZ(). Le second exemple démontrera qu'il est impossible de remplacer la méthode BAZ().
package FOO;
sub new {
my $type = shift;
bless {}, $type;
}
sub bar {
my $self = shift;
$self->FOO::private::BAZ;
}
package FOO::private;
sub BAZ {
print "in BAZ\n";
}
package main;
$a = FOO->new;
$a->bar;
À présent nous essayons de remplacer la methode BAZ(). Nous souhaiterions que FOO::bar() appelle GOOP::BAZ(), mais ceci ne peut pas se faire car FOO::bar() appelle explicitement FOO::private::BAZ().
package FOO;
sub new {
my $type = shift;
bless {}, $type;
}
sub bar {
my $self = shift;
$self->FOO::private::BAZ;
}
package FOO::private;
sub BAZ {
print "in BAZ\n";
}
package GOOP;
@ISA = qw( FOO );
sub new {
my $type = shift;
bless {}, $type;
}
sub BAZ {
print "in GOOP::BAZ\n";
}
package main;
$a = GOOP->new;
$a->bar;
Afin de créer un code réutilisable, nous devons modifier la classe FOO, en écrasant la classe FOO::private. L'exemple suivant présente une classe FOO réutilisable qui permet à la méthode GOOP::BAZ() d'être utilisée à la place de FOO::BAZ().
package FOO;
sub new {
my $type = shift;
bless {}, $type;
}
sub bar {
my $self = shift;
$self->BAZ;
}
sub BAZ {
print "in BAZ\n";
}
package GOOP;
@ISA = qw( FOO );
sub new {
my $type = shift;
bless {}, $type;
}
sub BAZ {
print "in GOOP::BAZ\n";
}
package main;
$a = GOOP->new;
$a->bar;
Une classe aura parfois des données statiques ou globales qui devront être utilisées par les méthodes. Une classe dérivée peut vouloir remplacer ces données par de nouvelles. Lorsque ceci arrive, la classe de base peut ne pas savoir comment trouver la nouvelle copie de la donnée.
Ce problème peut être résolu en utilisant l'objet pour définir le contexte de la méthode. Laissez la méthode chercher dans l'objet afin de trouver une référence à la donnée. L'autre alternative est d'obliger la méthode d'aller à la chasse à la donnée (« est-ce dans ma classe ou dans une classe dérivée ? Quelle classe dérivée ? »), mais ceci peut être gênant et facilitera le piratage. Il est préférable de laisser l'objet indiquer à la méthode où la donnée est située.
package Bar;
%fizzle = ( 'Password' => 'XYZZY' );
sub new {
my $type = shift;
my $self = {};
$self->{'fizzle'} = \%fizzle;
bless $self, $type;
}
sub enter {
my $self = shift;
# Ne cherchez pas à deviner si on devrait utiliser %Bar::fizzle
# ou %Foo::fizzle. L'objet sait déjà lequel
# on doit utiliser, donc il n'y a qu'à demander.
#
my $fizzle = $self->{'fizzle'};
print "The word is ", $fizzle->{'Password'}, "\n";
}
package Foo;
@ISA = qw( Bar );
%fizzle = ( 'Password' => 'Rumple' );
sub new {
my $type = shift;
my $self = Bar->new;
$self->{'fizzle'} = \%fizzle;
bless $self, $type;
}
package main;
$a = Bar->new;
$b = Foo->new;
$a->enter;
$b->enter;
package FOO;
sub new {
my $type = shift;
my $self = {};
bless $self, $type;
}
sub baz {
print "in FOO::baz()\n";
}
package BAR;
@ISA = qw(FOO);
sub baz {
print "in BAR::baz()\n";
}
package main;
$a = BAR->new;
$a->baz;
L'exemple suivant illustre une délégation utilisant une fonction AUTOLOAD() afin d'accomplir un renvoi de message. Ceci permettra à l'object Mydbm de se conduire exactement comme un objet SDBM_File.
package Mydbm;
require SDBM_File;
require Tie::Hash;
@ISA = qw(Tie::Hash);
sub TIEHASH {
my $type = shift;
my $ref = SDBM_File->new(@_);
bless {'delegate' => $ref};
}
sub AUTOLOAD {
my $self = shift;
# L'interpréteur Perl place le nom
# du message dans une variable appelée $AUTOLOAD.
# Un message de DESTRUCTION (DESTROY) ne doit jamais être exporté.
return if $AUTOLOAD =~ /::DESTROY$/;
# Enlève le nom du package.
$AUTOLOAD =~ s/^Mydbm:://;
# Passe le message au délégué.
$self->{'delegate'}->$AUTOLOAD(@_);
}
package main;
use Fcntl qw( O_RDWR O_CREAT );
tie %foo, "Mydbm", "adbm", O_RDWR|O_CREAT, 0640;
$foo{'bar'} = 123;
print "foo-bar = $foo{'bar'}\n";