Perl Cd Bookshelf [Electronic resources] نسخه متنی

13.15. Creating Magic Variables with tie

13.15.1. Problem

You
want to add special processing to a variable or
handle.

13.15.2. Solution

Use the
tie function to give your ordinary variables
object hooks.

13.15.3. Discussion

Anyone who's ever used a DBM file under Perl has already used tied
objects. Perhaps the most excellent way of using objects is such that
the user need never notice them. With tie, you can
bind a variable or handle to a class, after which all access to the
tied variable or handle is transparently intercepted by specially
named object methods (see Table 13-2).

The most
important tie methods are FETCH to intercept read
access, STORE to intercept write access, and the constructor, which
is one of TIESCALAR, TIEARRAY, TIEHASH, or TIEHANDLE.

Table 13-2. How tied variables are interpreted

Where did that $obj come from? The
tie triggers an invocation of the class's
TIESCALAR constructor method. Perl squirrels away the object returned
and surreptitiously uses it for later access.

Here's a simple example of a tie class that
implements a value ring. Every time the variable is read from, the
next value on the ring is displayed. When it's written to, a new
value is pushed on the ring. Here's an example:

#!/usr/bin/perl
# demo_valuering - show tie class
use ValueRing;
tie $color, "ValueRing", qw(red blue);
print "$color $color $color $color $color $color\n";
red blue red blue red blue
$color = "green";
print "$color $color $color $color $color $color\n";
green red blue green red blue

The simple implementation is shown in Example 13-3.

Example 13-3. ValueRing

  package ValueRing;
# this is the constructor for scalar ties
sub TIESCALAR {
my ($class, @values) = @_;
bless  \@values, $class;
return \@values;
}
# this intercepts read accesses
sub FETCH {
my $self =       push(@$self, shift(@$self));
return $self->[-1];
}
# this intercepts write accesses
sub STORE {
my ($self, $value) = @_;
unshift @$self, $value;
return $value;
}
1;

This example might not be compelling, but it illustrates how easy it
is to write ties of arbitrary complexity. To the user,
$color is just a plain old variable, not an
object. All the magic is hidden beneath the tie. You don't have to
use a scalar reference just because you're tying a scalar. Here we've
used an array reference, but you can use anything you'd like. Usually
a hash reference will be used no matter what's being tied because
hashes provide the most flexible object representation.

For arrays and hashes, more elaborate operations are possible.
Because so many object methods are needed to fully support tied
variables (except perhaps for scalars), most users choose to inherit
from standard modules that provide base class definitions of
customary methods for operations on that variable type. They then
selectively override only those whose behaviors they wish to alter.

These
four modules are Tie::Scalar, Tie::Array, Tie::Hash, and Tie::Handle.
Each module provides two different classes: a bare-bones class by the
name of the module itself, as well as a more fleshed out class named
Tie::StdTYPE, where TYPE is
one of the four types.

Following are numerous examples of interesting uses of ties.

13.15.4. Tie Example: Outlaw $_

This
curious tie class is used to outlaw unlocalized uses of the implicit
variable, $_. Instead of pulling it in with
use, which implicitly invokes the class's
import( ) method, this one should be loaded with
no to call invoke the seldom-used
unimport( ) method. The user says:

no UnderScore;

Then, all uses of the unlocalized global $_ will
raise an exception.

Here's a little test suite for the module:

#!/usr/bin/perl
#nounder_demo - show how to ban $_ from your program
no UnderScore;
@tests = (
"Assignment"  => sub { $_ = "Bad" },
"Reading"     => sub { print },
"Matching"    => sub { $x = /badness/ },
"Chop"        => sub { chop },
"Filetest"    => sub { -x },
"Nesting"     => sub { for (1..3) { print } },
);
while ( ($name, $code) = splice(@tests, 0, 2) ) {
print "Testing $name: ";
eval { &$code };
print $@ ? "detected" : "missed!";
print "\n";
}

The result is the following:

Testing Assignment: detected
Testing Reading: detected
Testing Matching: detected
Testing Chop: detected
Testing Filetest: detected
Testing Nesting: 123missed!

The reason the last one was missed is that it was properly localized
by the for loop, so it was considered safe.

The UnderScore module itself is shown in Example 13-4. Notice how small it is. The module itself
does the tie in its initialization code.

Example 13-4. UnderScore

  package UnderScore;
use Carp;
sub TIESCALAR {
my $class =       my $dummy;
return bless \$dummy => $class;
}
sub FETCH { croak "Read access to \$_ forbidden"  }
sub STORE { croak "Write access to \$_ forbidden" }
sub unimport { tie($_, _ _PACKAGE_ _) }
sub import { untie $_ }
tie($_, _ _PACKAGE_ _) unless tied $_;
1;

You can't usefully mix calls to use and
no for this class in your program, because they
all happen at compile time, not runtime. To renege and let yourself
use $_ again, local ize it.

13.15.5. Tie Example: Make a Hash That Always Appends

The class shown here produces a hash whose
keys accumulate in an array.

#!/usr/bin/perl
#appendhash_demo - show magic hash that autoappends
use Tie::AppendHash;
tie %tab, "Tie::AppendHash";
$tab{beer} = "guinness";
$tab{food} = "potatoes";
$tab{food} = "peas";
while (my($k, $v) = each %tab) {
print "$k => [@$v]\n";
}

Here is the result:

food => [potatoes peas]
beer => [guinness]

To make this class easy, we use the boilerplate hash tying module
from the standard distribution, shown in Example 13-5. To do this, we load the Tie::Hash module and
then inherit from the Tie::StdHash class. (Yes, those are different
names. The file Tie/Hash.pm provides both the
Tie::Hash and Tie::StdHash classes, which are slightly different.)

Example 13-5. Tie::AppendHash

  package Tie::AppendHash;
use strict;
use Tie::Hash;
use Carp;
our @ISA = qw(Tie::StdHash);
sub STORE {
my ($self, $key, $value) = @_;
push @{$self->{$key}}, $value;
}
1;

13.15.6. Tie Example: Case-Insensitive Hash

Here's
a fancier hash tie called Tie::Folded. It provides a hash with
case-insensitive keys.

#!/usr/bin/perl
#folded_demo - demo hash that magically folds case
use Tie::Folded;
tie %tab, "Tie::Folded";
$tab{VILLAIN}  = "big ";
$tab{herOine}  = "red riding hood";
$tab{villain} .= "bad wolf";
while ( my($k, $v) = each %tab ) {
print "$k is $v\n";
}

The following is the output of this demo program:

heroine is red riding hood
villain is big bad wolf

Because we have to trap more accesses, the class in Example 13-6 is slightly more complicated than the one in
Example 13-5.

Example 13-6. Tie::Folded

  package Tie::Folded;
use strict;
use Tie::Hash;
our @ISA = qw(Tie::StdHash);
sub STORE {
my ($self, $key, $value) = @_;
return $self->{lc $key} = $value;
}
sub FETCH {
my ($self, $key) = @_;
return $self->{lc $key};
}
sub EXISTS {
my ($self, $key) = @_;
return exists $self->{lc $key};
}
sub DEFINED {
my ($self, $key) = @_;
return defined $self->{lc $key};
}
1;

13.15.7. Tie Example: Hash That Allows Lookups by Key or Value

Here is a hash that lets you look up
members by key or by value. It does this by having a store method
that uses not only the key to store the value, but also uses the
value to store the key.

Normally there could be a
problem if the value being stored were a reference, since you can't
normally use a reference as a key. The standard distribution comes
with the Tie::RefHash class that avoids this problem. We'll inherit
from it so that we can also avoid this difficulty.

#!/usr/bin/perl -w
#revhash_demo - show hash that permits key *or* value lookups
use strict;
use Tie::RevHash;
my %tab;
tie %tab, "Tie::RevHash";
%tab = qw{
Red         Rojo
Blue        Azul
Green       Verde
};
$tab{EVIL} = [ "No way!", "Way!!" ];
while ( my($k, $v) = each %tab ) {
print ref($k) ? "[@$k]" : $k, " => ",
ref($v) ? "[@$v]" : $v, "\n";
}

When run, revhash_demo produces this:

[No way! Way!!] => EVIL
EVIL => [No way! Way!!]
Blue => Azul
Green => Verde
Rojo => Red
Red => Rojo
Azul => Blue
Verde => Green

The module is shown in Example 13-7. Notice how small
it is!

Example 13-7. Tie::RevHash

  package Tie::RevHash;
use Tie::RefHash;
our @ISA = qw(Tie::RefHash);
sub STORE {
my ($self, $key, $value) = @_;
$self->SUPER::STORE($key, $value);
$self->SUPER::STORE($value, $key);
}
sub DELETE {
my ($self, $key) = @_;
my $value = $self->SUPER::FETCH($key);
$self->SUPER::DELETE($key);
$self->SUPER::DELETE($value);
}
1;

13.15.8. Tie Example: Handle That Counts Access

Here's an example of tying a filehandle:

use Counter;
tie *CH, "Counter";
while (<CH>) {
print "Got $_\n";
}

When run, that program keeps printing Got
1, Got 2,
and so on until the universe collapses, you hit an interrupt, or your
computer reboots, whichever comes first. Its simple implementation is
shown in Example 13-8.

Example 13-8. Counter

  package Counter;
sub TIEHANDLE {
my $class =       my $start =       return bless \$start => $class;
}
sub READLINE {
my $self =       return ++$$self;
}
1;

13.15.9. Tie Example: Multiple Sink Filehandles

Finally, here's an example of a tied handle that implements a
tee-like functionality by twinning standard out
and standard error:

use Tie::Tee;
tie *TEE, "Tie::Tee", *STDOUT, *STDERR;
print TEE "This line goes both places.\n";

Or, more elaborately:

#!/usr/bin/perl
# demo_tietee
use Tie::Tee;
use Symbol;
@handles = (*STDOUT);
for $i ( 1 .. 10 ) {
push(@handles, $handle = gensym( ));
open($handle, ">/tmp/teetest.$i");
}
tie *TEE, "Tie::Tee", @handles;
print TEE "This lines goes many places.\n";

The Tie/Tee.pm file is shown in Example 13-9.

Example 13-9. Tie::Tee

  package Tie::Tee;
sub TIEHANDLE {
my $class   =       my $handles = [@_];
bless $handles, $class;
return $handles;
}
sub PRINT {
my $href =       my $handle;
my $success = 0;
foreach $handle (@$href) {
$success += print $handle @_;
}
return $success =  = @$href;
}
1;

13.15.10. See Also

The tie function in
perlfunc(1); perltie(1);
Chapter 14 of Programming Perl