perlbot - Bag'o Object Tricks (the BOT)
The Perl motto still holds: There's more than one way to do it.
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;
Note that "SUPER" refers to the superclasses of the current package ("Foo"), not to the superclasses of $self.
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";
This first example illustrates a class which uses a fully-qualified method call to access the ``private'' method BAZ(). The second example will show that it is impossible to override the BAZ() method.
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;
Now we try to override the BAZ() method. We would like FOO::bar() to call GOOP::BAZ(), but this cannot happen because FOO::bar() explicitly calls 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;
To create reusable code we must modify class FOO, flattening class FOO::private. The next example shows a reusable class FOO which allows the method GOOP::BAZ() to be used in place of 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;
A class will sometimes have static or global data to be used by the methods. A subclass may want to override that data and replace it with new data. When this happens the superclass may not know how to find the new copy of the data.
This problem can be solved by using the object to define the context of the method. Let the method look in the object for a reference to the data. The alternative is to force the method to go hunting for the data (``Is it in my class, or in a subclass? Which subclass?''), and this can be inconvenient and will lead to hackery. It is better just to let the object tell the method where that data is located.
package Bar;
%fizzle = ( 'Password' => 'XYZZY' );
sub new { my $type = shift; my $self = {}; $self->{'fizzle'} = \%fizzle; bless $self, $type; }
sub enter { my $self = shift;
# Don't try to guess if we should use %Bar::fizzle # or %Foo::fizzle. The object already knows which # we should use, so just ask it. # 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;
The following example demonstrates delegation using an AUTOLOAD() function to perform message-forwarding. This will allow the Mydbm object to behave exactly like an SDBM_File object. The Mydbm class could now extend the behavior by adding custom FETCH() and STORE() methods, if this is desired.
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;
# The Perl interpreter places the name of the # message in a variable called $AUTOLOAD.
# DESTROY messages should never be propagated. return if $AUTOLOAD =~ /::DESTROY$/;
# Remove the package name. $AUTOLOAD =~ s/^Mydbm:://;
# Pass the message to the delegate. $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";
Закладки на сайте Проследить за страницей |
Created 1996-2024 by Maxim Chirkov Добавить, Поддержать, Вебмастеру |