dslinux/user/perl/lib/Tie Array.pm File.pm Handle.pm Hash.pm Memoize.pm Memoize.t RefHash.pm RefHash.t Scalar.pm Scalar.t SubstrHash.pm SubstrHash.t
cayenne
dslinux_cayenne at user.in-berlin.de
Mon Dec 4 18:01:14 CET 2006
Update of /cvsroot/dslinux/dslinux/user/perl/lib/Tie
In directory antilope:/tmp/cvs-serv17422/lib/Tie
Added Files:
Array.pm File.pm Handle.pm Hash.pm Memoize.pm Memoize.t
RefHash.pm RefHash.t Scalar.pm Scalar.t SubstrHash.pm
SubstrHash.t
Log Message:
Adding fresh perl source to HEAD to branch from
--- NEW FILE: File.pm ---
package Tie::File;
require 5.005;
use Carp ':DEFAULT', 'confess';
use POSIX 'SEEK_SET';
use Fcntl 'O_CREAT', 'O_RDWR', 'LOCK_EX', 'LOCK_SH', 'O_WRONLY', 'O_RDONLY';
sub O_ACCMODE () { O_RDONLY | O_RDWR | O_WRONLY }
$VERSION = "0.97";
my $DEFAULT_MEMORY_SIZE = 1<<21; # 2 megabytes
my $DEFAULT_AUTODEFER_THRESHHOLD = 3; # 3 records
my $DEFAULT_AUTODEFER_FILELEN_THRESHHOLD = 65536; # 16 disk blocksful
my %good_opt = map {$_ => 1, "-$_" => 1}
qw(memory dw_size mode recsep discipline
autodefer autochomp autodefer_threshhold concurrent);
sub TIEARRAY {
[...2593 lines suppressed...]
For example, a program that inserts a single record, or that scans the
file once, will have a cache hit rate of zero. This suggests a major
optimization: The cache should be initially disabled. Here's a hybrid
approach: Initially, the cache is disabled, but the cache code
maintains statistics about how high the hit rate would be *if* it were
enabled. When it sees the hit rate get high enough, it enables
itself. The STAT comments in this code are the beginning of an
implementation of this.
Record locking with fcntl()? Then the module might support an undo
log and get real transactions. What a tour de force that would be.
Keeping track of the highest cached record. This would allow reads-in-a-row
to skip the cache lookup faster (if reading from 1..N with empty cache at
start, the last cached value will be always N-1).
More tests.
=cut
--- NEW FILE: Hash.pm ---
package Tie::Hash;
our $VERSION = '1.02';
=head1 NAME
Tie::Hash, Tie::StdHash, Tie::ExtraHash - base class definitions for tied hashes
=head1 SYNOPSIS
package NewHash;
require Tie::Hash;
@ISA = (Tie::Hash);
sub DELETE { ... } # Provides needed method
sub CLEAR { ... } # Overrides inherited method
package NewStdHash;
require Tie::Hash;
@ISA = (Tie::StdHash);
# All methods provided by default, define only those needing overrides
# Accessors access the storage in %{$_[0]};
# TIEHASH should return a reference to the actual storage
sub DELETE { ... }
package NewExtraHash;
require Tie::Hash;
@ISA = (Tie::ExtraHash);
# All methods provided by default, define only those needing overrides
# Accessors access the storage in %{$_[0][0]};
# TIEHASH should return an array reference with the first element being
# the reference to the actual storage
sub DELETE {
$_[0][1]->('del', $_[0][0], $_[1]); # Call the report writer
delete $_[0][0]->{$_[1]}; # $_[0]->SUPER::DELETE($_[1])
}
package main;
tie %new_hash, 'NewHash';
tie %new_std_hash, 'NewStdHash';
tie %new_extra_hash, 'NewExtraHash',
sub {warn "Doing \U$_[1]\E of $_[2].\n"};
=head1 DESCRIPTION
This module provides some skeletal methods for hash-tying classes. See
L<perltie> for a list of the functions required in order to tie a hash
to a package. The basic B<Tie::Hash> package provides a C<new> method, as well
as methods C<TIEHASH>, C<EXISTS> and C<CLEAR>. The B<Tie::StdHash> and
B<Tie::ExtraHash> packages
provide most methods for hashes described in L<perltie> (the exceptions
are C<UNTIE> and C<DESTROY>). They cause tied hashes to behave exactly like standard hashes,
and allow for selective overwriting of methods. B<Tie::Hash> grandfathers the
C<new> method: it is used if C<TIEHASH> is not defined
in the case a class forgets to include a C<TIEHASH> method.
For developers wishing to write their own tied hashes, the required methods
are briefly defined below. See the L<perltie> section for more detailed
descriptive, as well as example code:
=over 4
=item TIEHASH classname, LIST
The method invoked by the command C<tie %hash, classname>. Associates a new
hash instance with the specified class. C<LIST> would represent additional
arguments (along the lines of L<AnyDBM_File> and compatriots) needed to
complete the association.
=item STORE this, key, value
Store datum I<value> into I<key> for the tied hash I<this>.
=item FETCH this, key
Retrieve the datum in I<key> for the tied hash I<this>.
=item FIRSTKEY this
Return the first key in the hash.
=item NEXTKEY this, lastkey
Return the next key in the hash.
=item EXISTS this, key
Verify that I<key> exists with the tied hash I<this>.
The B<Tie::Hash> implementation is a stub that simply croaks.
=item DELETE this, key
Delete the key I<key> from the tied hash I<this>.
=item CLEAR this
Clear all values from the tied hash I<this>.
=item SCALAR this
Returns what evaluating the hash in scalar context yields.
B<Tie::Hash> does not implement this method (but B<Tie::StdHash>
and B<Tie::ExtraHash> do).
=back
=head1 Inheriting from B<Tie::StdHash>
The accessor methods assume that the actual storage for the data in the tied
hash is in the hash referenced by C<tied(%tiedhash)>. Thus overwritten
C<TIEHASH> method should return a hash reference, and the remaining methods
should operate on the hash referenced by the first argument:
package ReportHash;
our @ISA = 'Tie::StdHash';
sub TIEHASH {
my $storage = bless {}, shift;
warn "New ReportHash created, stored in $storage.\n";
$storage
}
sub STORE {
warn "Storing data with key $_[1] at $_[0].\n";
$_[0]{$_[1]} = $_[2]
}
=head1 Inheriting from B<Tie::ExtraHash>
The accessor methods assume that the actual storage for the data in the tied
hash is in the hash referenced by C<(tied(%tiedhash))-E<gt>[0]>. Thus overwritten
C<TIEHASH> method should return an array reference with the first
element being a hash reference, and the remaining methods should operate on the
hash C<< %{ $_[0]->[0] } >>:
package ReportHash;
our @ISA = 'Tie::ExtraHash';
sub TIEHASH {
my $class = shift;
my $storage = bless [{}, @_], $class;
warn "New ReportHash created, stored in $storage.\n";
$storage;
}
sub STORE {
warn "Storing data with key $_[1] at $_[0].\n";
$_[0][0]{$_[1]} = $_[2]
}
The default C<TIEHASH> method stores "extra" arguments to tie() starting
from offset 1 in the array referenced by C<tied(%tiedhash)>; this is the
same storage algorithm as in TIEHASH subroutine above. Hence, a typical
package inheriting from B<Tie::ExtraHash> does not need to overwrite this
method.
=head1 C<SCALAR>, C<UNTIE> and C<DESTROY>
The methods C<UNTIE> and C<DESTROY> are not defined in B<Tie::Hash>,
B<Tie::StdHash>, or B<Tie::ExtraHash>. Tied hashes do not require
presence of these methods, but if defined, the methods will be called in
proper time, see L<perltie>.
C<SCALAR> is only defined in B<Tie::StdHash> and B<Tie::ExtraHash>.
If needed, these methods should be defined by the package inheriting from
B<Tie::Hash>, B<Tie::StdHash>, or B<Tie::ExtraHash>. See L<pertie/"SCALAR">
to find out what happens when C<SCALAR> does not exist.
=head1 MORE INFORMATION
The packages relating to various DBM-related implementations (F<DB_File>,
F<NDBM_File>, etc.) show examples of general tied hashes, as does the
L<Config> module. While these do not utilize B<Tie::Hash>, they serve as
good working examples.
=cut
use Carp;
use warnings::register;
sub new {
my $pkg = shift;
$pkg->TIEHASH(@_);
}
# Grandfather "new"
sub TIEHASH {
my $pkg = shift;
if (defined &{"${pkg}::new"}) {
warnings::warnif("WARNING: calling ${pkg}->new since ${pkg}->TIEHASH is missing");
$pkg->new(@_);
}
else {
croak "$pkg doesn't define a TIEHASH method";
}
}
sub EXISTS {
my $pkg = ref $_[0];
croak "$pkg doesn't define an EXISTS method";
}
sub CLEAR {
my $self = shift;
my $key = $self->FIRSTKEY(@_);
my @keys;
while (defined $key) {
push @keys, $key;
$key = $self->NEXTKEY(@_, $key);
}
foreach $key (@keys) {
$self->DELETE(@_, $key);
}
}
# The Tie::StdHash package implements standard perl hash behaviour.
# It exists to act as a base class for classes which only wish to
# alter some parts of their behaviour.
package Tie::StdHash;
# @ISA = qw(Tie::Hash); # would inherit new() only
sub TIEHASH { bless {}, $_[0] }
sub STORE { $_[0]->{$_[1]} = $_[2] }
sub FETCH { $_[0]->{$_[1]} }
sub FIRSTKEY { my $a = scalar keys %{$_[0]}; each %{$_[0]} }
sub NEXTKEY { each %{$_[0]} }
sub EXISTS { exists $_[0]->{$_[1]} }
sub DELETE { delete $_[0]->{$_[1]} }
sub CLEAR { %{$_[0]} = () }
sub SCALAR { scalar %{$_[0]} }
package Tie::ExtraHash;
sub TIEHASH { my $p = shift; bless [{}, @_], $p }
sub STORE { $_[0][0]{$_[1]} = $_[2] }
sub FETCH { $_[0][0]{$_[1]} }
sub FIRSTKEY { my $a = scalar keys %{$_[0][0]}; each %{$_[0][0]} }
sub NEXTKEY { each %{$_[0][0]} }
sub EXISTS { exists $_[0][0]->{$_[1]} }
sub DELETE { delete $_[0][0]->{$_[1]} }
sub CLEAR { %{$_[0][0]} = () }
sub SCALAR { scalar %{$_[0][0]} }
1;
--- NEW FILE: Scalar.t ---
#!./perl
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
}
# this must come before main, or tests will fail
package TieTest;
use Tie::Scalar;
use vars qw( @ISA );
@ISA = qw( Tie::Scalar );
sub new { 'Fooled you.' }
package main;
use vars qw( $flag );
use Test::More tests => 13;
use_ok( 'Tie::Scalar' );
# these are "abstract virtual" parent methods
for my $method qw( TIESCALAR FETCH STORE ) {
eval { Tie::Scalar->$method() };
like( $@, qr/doesn't define a $method/, "croaks on inherited $method()" );
}
# the default value is undef
my $scalar = Tie::StdScalar->TIESCALAR();
is( $$scalar, undef, 'used TIESCALAR, default value is still undef' );
# Tie::StdScalar redirects to TIESCALAR
$scalar = Tie::StdScalar->new();
is( $$scalar, undef, 'used new(), default value is still undef' );
# this approach should work as well
tie $scalar, 'Tie::StdScalar';
is( $$scalar, undef, 'tied a scalar, default value is undef' );
# first set, then read
$scalar = 'fetch me';
is( $scalar, 'fetch me', 'STORE() and FETCH() verified with one test!' );
# test DESTROY with an object that signals its destruction
{
my $scalar = 'foo';
tie $scalar, 'Tie::StdScalar', DestroyAction->new();
ok( $scalar, 'tied once more' );
is( $flag, undef, 'destroy flag not set' );
}
# $scalar out of scope, Tie::StdScalar::DESTROY() called, DestroyAction set flag
is( $flag, 1, 'and DESTROY() works' );
# we want some noise, and some way to capture it
use warnings;
my $warn;
local $SIG{__WARN__} = sub {
$warn = $_[0];
};
# Tie::Scalar::TIEHANDLE should find and call TieTest::new and complain
is( tie( my $foo, 'TieTest'), 'Fooled you.', 'delegated to new()' );
like( $warn, qr/WARNING: calling TieTest->new/, 'caught warning fine' );
package DestroyAction;
sub new {
bless( \(my $self), $_[0] );
}
sub DESTROY {
$main::flag = 1;
}
--- NEW FILE: RefHash.pm ---
package Tie::RefHash;
our $VERSION = 1.32;
=head1 NAME
Tie::RefHash - use references as hash keys
=head1 SYNOPSIS
require 5.004;
use Tie::RefHash;
tie HASHVARIABLE, 'Tie::RefHash', LIST;
tie HASHVARIABLE, 'Tie::RefHash::Nestable', LIST;
untie HASHVARIABLE;
=head1 DESCRIPTION
This module provides the ability to use references as hash keys if you
first C<tie> the hash variable to this module. Normally, only the
keys of the tied hash itself are preserved as references; to use
references as keys in hashes-of-hashes, use Tie::RefHash::Nestable,
included as part of Tie::RefHash.
It is implemented using the standard perl TIEHASH interface. Please
see the C<tie> entry in perlfunc(1) and perltie(1) for more information.
The Nestable version works by looking for hash references being stored
and converting them to tied hashes so that they too can have
references as keys. This will happen without warning whenever you
store a reference to one of your own hashes in the tied hash.
=head1 EXAMPLE
use Tie::RefHash;
tie %h, 'Tie::RefHash';
$a = [];
$b = {};
$c = \*main;
$d = \"gunk";
$e = sub { 'foo' };
%h = ($a => 1, $b => 2, $c => 3, $d => 4, $e => 5);
$a->[0] = 'foo';
$b->{foo} = 'bar';
for (keys %h) {
print ref($_), "\n";
}
tie %h, 'Tie::RefHash::Nestable';
$h{$a}->{$b} = 1;
for (keys %h, keys %{$h{$a}}) {
print ref($_), "\n";
}
=head1 AUTHOR
Gurusamy Sarathy gsar at activestate.com
'Nestable' by Ed Avis ed at membled.com
=head1 VERSION
Version 1.32
=head1 SEE ALSO
perl(1), perlfunc(1), perltie(1)
=cut
use Tie::Hash;
use vars '@ISA';
@ISA = qw(Tie::Hash);
use strict;
require overload; # to support objects with overloaded ""
sub TIEHASH {
my $c = shift;
my $s = [];
bless $s, $c;
while (@_) {
$s->STORE(shift, shift);
}
return $s;
}
sub FETCH {
my($s, $k) = @_;
if (ref $k) {
my $kstr = overload::StrVal($k);
if (defined $s->[0]{$kstr}) {
$s->[0]{$kstr}[1];
}
else {
undef;
}
}
else {
$s->[1]{$k};
}
}
sub STORE {
my($s, $k, $v) = @_;
if (ref $k) {
$s->[0]{overload::StrVal($k)} = [$k, $v];
}
else {
$s->[1]{$k} = $v;
}
$v;
}
sub DELETE {
my($s, $k) = @_;
(ref $k)
? (delete($s->[0]{overload::StrVal($k)}) || [])->[1]
: delete($s->[1]{$k});
}
sub EXISTS {
my($s, $k) = @_;
(ref $k) ? exists($s->[0]{overload::StrVal($k)}) : exists($s->[1]{$k});
}
sub FIRSTKEY {
my $s = shift;
keys %{$s->[0]}; # reset iterator
keys %{$s->[1]}; # reset iterator
$s->[2] = 0; # flag for iteration, see NEXTKEY
$s->NEXTKEY;
}
sub NEXTKEY {
my $s = shift;
my ($k, $v);
if (!$s->[2]) {
if (($k, $v) = each %{$s->[0]}) {
return $v->[0];
}
else {
$s->[2] = 1;
}
}
return each %{$s->[1]};
}
sub CLEAR {
my $s = shift;
$s->[2] = 0;
%{$s->[0]} = ();
%{$s->[1]} = ();
}
package Tie::RefHash::Nestable;
use vars '@ISA';
@ISA = 'Tie::RefHash';
sub STORE {
my($s, $k, $v) = @_;
if (ref($v) eq 'HASH' and not tied %$v) {
my @elems = %$v;
tie %$v, ref($s), @elems;
}
$s->SUPER::STORE($k, $v);
}
1;
--- NEW FILE: Memoize.t ---
#!./perl -w
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
}
use strict;
use Tie::Memoize;
use Test::More tests => 28;
use File::Spec;
sub slurp {
my ($key, $dir) = @_;
open my $h, '<', File::Spec->catfile($dir, $key) or return;
local $/;
<$h> # slurp it all
}
sub exists { my ($key, $dir) = @_; return -f File::Spec->catfile($dir, $key) }
my $directory = File::Spec->catdir(File::Spec->updir, 'lib');
tie my %hash, 'Tie::Memoize', \&slurp, $directory, \&exists,
{ fake_file1 => 123, fake_file2 => 45678 },
{ 'strict.pm' => 0, known_to_exist => 1 };
ok(not exists $hash{'strict.pm'});
ok(exists $hash{known_to_exist});
ok($hash{fake_file2} eq 45678);
ok($hash{fake_file1} eq 123);
ok(exists $hash{known_to_exist});
ok(not exists $hash{'strict.pm'});
ok(not defined $hash{fake_file3});
ok(not defined $hash{known_to_exist});
ok(not exists $hash{known_to_exist});
ok(not exists $hash{'strict.pm'});
my $c = slurp('constant.pm', $directory);
ok($c);
ok($hash{'constant.pm'} eq $c);
ok($hash{'constant.pm'} eq $c);
ok(not exists $hash{'strict.pm'});
ok(exists $hash{'blib.pm'});
untie %hash;
tie %hash, 'Tie::Memoize', \&slurp, $directory;
ok(exists $hash{'strict.pm'}, 'existing file');
ok(not exists $hash{fake_file2});
ok(not exists $hash{fake_file1});
ok(not exists $hash{known_to_exist});
ok(exists $hash{'strict.pm'}, 'existing file again');
ok(not defined $hash{fake_file3});
ok(not defined $hash{known_to_exist});
ok(not exists $hash{known_to_exist});
ok(exists $hash{'strict.pm'}, 'existing file again');
ok($hash{'constant.pm'} eq $c);
ok($hash{'constant.pm'} eq $c);
ok(exists $hash{'strict.pm'}, 'existing file again');
ok(exists $hash{'blib.pm'}, 'another existing file');
--- NEW FILE: SubstrHash.t ---
#!/usr/bin/perl -w
#
BEGIN {
chdir 't' if -d 't';
@INC = '.';
push @INC, '../lib';
}
print "1..20\n";
use strict;
require Tie::SubstrHash;
my %a;
tie %a, 'Tie::SubstrHash', 3, 3, 3;
$a{abc} = 123;
$a{bcd} = 234;
print "not " unless $a{abc} == 123;
print "ok 1\n";
print "not " unless keys %a == 2;
print "ok 2\n";
delete $a{abc};
print "not " unless $a{bcd} == 234;
print "ok 3\n";
print "not " unless (values %a)[0] == 234;
print "ok 4\n";
eval { $a{abcd} = 123 };
print "not " unless $@ =~ /Key "abcd" is not 3 characters long/;
print "ok 5\n";
eval { $a{abc} = 1234 };
print "not " unless $@ =~ /Value "1234" is not 3 characters long/;
print "ok 6\n";
eval { $a = $a{abcd}; $a++ };
print "not " unless $@ =~ /Key "abcd" is not 3 characters long/;
print "ok 7\n";
@a{qw(abc cde)} = qw(123 345);
print "not " unless $a{cde} == 345;
print "ok 8\n";
eval { $a{def} = 456 };
print "not " unless $@ =~ /Table is full \(3 elements\)/;
print "ok 9\n";
%a = ();
print "not " unless keys %a == 0;
print "ok 10\n";
# Tests 11..16 by Linc Madison.
my $hashsize = 119; # arbitrary values from my data
my %test;
tie %test, "Tie::SubstrHash", 13, 86, $hashsize;
for (my $i = 1; $i <= $hashsize; $i++) {
my $key1 = $i + 100_000; # fix to uniform 6-digit numbers
my $key2 = "abcdefg$key1";
$test{$key2} = ("abcdefgh" x 10) . "$key1";
}
for (my $i = 1; $i <= $hashsize; $i++) {
my $key1 = $i + 100_000;
my $key2 = "abcdefg$key1";
unless ($test{$key2}) {
print "not ";
last;
}
}
print "ok 11\n";
print "not " unless Tie::SubstrHash::findgteprime(1) == 2;
print "ok 12\n";
print "not " unless Tie::SubstrHash::findgteprime(2) == 2;
print "ok 13\n";
print "not " unless Tie::SubstrHash::findgteprime(5.5) == 7;
print "ok 14\n";
print "not " unless Tie::SubstrHash::findgteprime(13) == 13;
print "ok 15\n";
print "not " unless Tie::SubstrHash::findgteprime(13.000001) == 17;
print "ok 16\n";
print "not " unless Tie::SubstrHash::findgteprime(114) == 127;
print "ok 17\n";
print "not " unless Tie::SubstrHash::findgteprime(1000) == 1009;
print "ok 18\n";
print "not " unless Tie::SubstrHash::findgteprime(1024) == 1031;
print "ok 19\n";
print "not " unless Tie::SubstrHash::findgteprime(10000) == 10007;
print "ok 20\n";
--- NEW FILE: Scalar.pm ---
package Tie::Scalar;
our $VERSION = '1.00';
=head1 NAME
Tie::Scalar, Tie::StdScalar - base class definitions for tied scalars
=head1 SYNOPSIS
package NewScalar;
require Tie::Scalar;
@ISA = (Tie::Scalar);
sub FETCH { ... } # Provide a needed method
sub TIESCALAR { ... } # Overrides inherited method
package NewStdScalar;
require Tie::Scalar;
@ISA = (Tie::StdScalar);
# All methods provided by default, so define only what needs be overridden
sub FETCH { ... }
package main;
tie $new_scalar, 'NewScalar';
tie $new_std_scalar, 'NewStdScalar';
=head1 DESCRIPTION
This module provides some skeletal methods for scalar-tying classes. See
L<perltie> for a list of the functions required in tying a scalar to a
package. The basic B<Tie::Scalar> package provides a C<new> method, as well
as methods C<TIESCALAR>, C<FETCH> and C<STORE>. The B<Tie::StdScalar>
package provides all the methods specified in L<perltie>. It inherits from
B<Tie::Scalar> and causes scalars tied to it to behave exactly like the
built-in scalars, allowing for selective overloading of methods. The C<new>
method is provided as a means of grandfathering, for classes that forget to
provide their own C<TIESCALAR> method.
For developers wishing to write their own tied-scalar classes, the methods
are summarized below. The L<perltie> section not only documents these, but
has sample code as well:
=over 4
=item TIESCALAR classname, LIST
The method invoked by the command C<tie $scalar, classname>. Associates a new
scalar instance with the specified class. C<LIST> would represent additional
arguments (along the lines of L<AnyDBM_File> and compatriots) needed to
complete the association.
=item FETCH this
Retrieve the value of the tied scalar referenced by I<this>.
=item STORE this, value
Store data I<value> in the tied scalar referenced by I<this>.
=item DESTROY this
Free the storage associated with the tied scalar referenced by I<this>.
This is rarely needed, as Perl manages its memory quite well. But the
option exists, should a class wish to perform specific actions upon the
destruction of an instance.
=back
=head1 MORE INFORMATION
The L<perltie> section uses a good example of tying scalars by associating
process IDs with priority.
=cut
use Carp;
use warnings::register;
sub new {
my $pkg = shift;
$pkg->TIESCALAR(@_);
}
# "Grandfather" the new, a la Tie::Hash
sub TIESCALAR {
my $pkg = shift;
if ($pkg->can('new') and $pkg ne __PACKAGE__) {
warnings::warnif("WARNING: calling ${pkg}->new since ${pkg}->TIESCALAR is missing");
$pkg->new(@_);
}
else {
croak "$pkg doesn't define a TIESCALAR method";
}
}
sub FETCH {
my $pkg = ref $_[0];
croak "$pkg doesn't define a FETCH method";
}
sub STORE {
my $pkg = ref $_[0];
croak "$pkg doesn't define a STORE method";
}
#
# The Tie::StdScalar package provides scalars that behave exactly like
# Perl's built-in scalars. Good base to inherit from, if you're only going to
# tweak a small bit.
#
package Tie::StdScalar;
@ISA = (Tie::Scalar);
sub TIESCALAR {
my $class = shift;
my $instance = shift || undef;
return bless \$instance => $class;
}
sub FETCH {
return ${$_[0]};
}
sub STORE {
${$_[0]} = $_[1];
}
sub DESTROY {
undef ${$_[0]};
}
1;
--- NEW FILE: SubstrHash.pm ---
package Tie::SubstrHash;
our $VERSION = '1.00';
=head1 NAME
Tie::SubstrHash - Fixed-table-size, fixed-key-length hashing
=head1 SYNOPSIS
require Tie::SubstrHash;
tie %myhash, 'Tie::SubstrHash', $key_len, $value_len, $table_size;
=head1 DESCRIPTION
The B<Tie::SubstrHash> package provides a hash-table-like interface to
an array of determinate size, with constant key size and record size.
Upon tying a new hash to this package, the developer must specify the
size of the keys that will be used, the size of the value fields that the
keys will index, and the size of the overall table (in terms of key-value
pairs, not size in hard memory). I<These values will not change for the
duration of the tied hash>. The newly-allocated hash table may now have
data stored and retrieved. Efforts to store more than C<$table_size>
elements will result in a fatal error, as will efforts to store a value
not exactly C<$value_len> characters in length, or reference through a
key not exactly C<$key_len> characters in length. While these constraints
may seem excessive, the result is a hash table using much less internal
memory than an equivalent freely-allocated hash table.
=head1 CAVEATS
Because the current implementation uses the table and key sizes for the
hashing algorithm, there is no means by which to dynamically change the
value of any of the initialization parameters.
The hash does not support exists().
=cut
use Carp;
sub TIEHASH {
my $pack = shift;
my ($klen, $vlen, $tsize) = @_;
my $rlen = 1 + $klen + $vlen;
$tsize = [$tsize,
findgteprime($tsize * 1.1)]; # Allow 10% empty.
local $self = bless ["\0", $klen, $vlen, $tsize, $rlen, 0, -1];
$$self[0] x= $rlen * $tsize->[1];
$self;
}
sub CLEAR {
local($self) = @_;
$$self[0] = "\0" x ($$self[4] * $$self[3]->[1]);
$$self[5] = 0;
$$self[6] = -1;
}
sub FETCH {
local($self,$key) = @_;
local($klen, $vlen, $tsize, $rlen) = @$self[1..4];
&hashkey;
for (;;) {
$offset = $hash * $rlen;
$record = substr($$self[0], $offset, $rlen);
if (ord($record) == 0) {
return undef;
}
elsif (ord($record) == 1) {
}
elsif (substr($record, 1, $klen) eq $key) {
return substr($record, 1+$klen, $vlen);
}
&rehash;
}
}
sub STORE {
local($self,$key,$val) = @_;
local($klen, $vlen, $tsize, $rlen) = @$self[1..4];
croak("Table is full ($tsize->[0] elements)") if $$self[5] > $tsize->[0];
croak(qq/Value "$val" is not $vlen characters long/)
if length($val) != $vlen;
my $writeoffset;
&hashkey;
for (;;) {
$offset = $hash * $rlen;
$record = substr($$self[0], $offset, $rlen);
if (ord($record) == 0) {
$record = "\2". $key . $val;
die "panic" unless length($record) == $rlen;
$writeoffset = $offset unless defined $writeoffset;
substr($$self[0], $writeoffset, $rlen) = $record;
++$$self[5];
return;
}
elsif (ord($record) == 1) {
$writeoffset = $offset unless defined $writeoffset;
}
elsif (substr($record, 1, $klen) eq $key) {
$record = "\2". $key . $val;
die "panic" unless length($record) == $rlen;
substr($$self[0], $offset, $rlen) = $record;
return;
}
&rehash;
}
}
sub DELETE {
local($self,$key) = @_;
local($klen, $vlen, $tsize, $rlen) = @$self[1..4];
&hashkey;
for (;;) {
$offset = $hash * $rlen;
$record = substr($$self[0], $offset, $rlen);
if (ord($record) == 0) {
return undef;
}
elsif (ord($record) == 1) {
}
elsif (substr($record, 1, $klen) eq $key) {
substr($$self[0], $offset, 1) = "\1";
return substr($record, 1+$klen, $vlen);
--$$self[5];
}
&rehash;
}
}
sub FIRSTKEY {
local($self) = @_;
$$self[6] = -1;
&NEXTKEY;
}
sub NEXTKEY {
local($self) = @_;
local($klen, $vlen, $tsize, $rlen, $entries, $iterix) = @$self[1..6];
for (++$iterix; $iterix < $tsize->[1]; ++$iterix) {
next unless substr($$self[0], $iterix * $rlen, 1) eq "\2";
$$self[6] = $iterix;
return substr($$self[0], $iterix * $rlen + 1, $klen);
}
$$self[6] = -1;
undef;
}
sub EXISTS {
croak "Tie::SubstrHash does not support exists()";
}
sub hashkey {
croak(qq/Key "$key" is not $klen characters long/)
if length($key) != $klen;
$hash = 2;
for (unpack('C*', $key)) {
$hash = $hash * 33 + $_;
&_hashwrap if $hash >= 1e13;
}
&_hashwrap if $hash >= $tsize->[1];
$hash = 1 unless $hash;
$hashbase = $hash;
}
sub _hashwrap {
$hash -= int($hash / $tsize->[1]) * $tsize->[1];
}
sub rehash {
$hash += $hashbase;
$hash -= $tsize->[1] if $hash >= $tsize->[1];
}
# using POSIX::ceil() would be too heavy, and not all platforms have it.
sub ceil {
my $num = shift;
$num = int($num + 1) unless $num == int $num;
return $num;
}
# See:
#
# http://www-groups.dcs.st-andrews.ac.uk/~history/HistTopics/Prime_numbers.html
#
sub findgteprime { # find the smallest prime integer greater than or equal to
use integer;
my $num = ceil(shift);
return 2 if $num <= 2;
$num++ unless $num % 2;
my $i;
my $sqrtnum = int sqrt $num;
my $sqrtnumsquared = $sqrtnum * $sqrtnum;
NUM:
for (;; $num += 2) {
if ($sqrtnumsquared < $num) {
$sqrtnum++;
$sqrtnumsquared = $sqrtnum * $sqrtnum;
}
for ($i = 3; $i <= $sqrtnum; $i += 2) {
next NUM unless $num % $i;
}
return $num;
}
}
1;
--- NEW FILE: RefHash.t ---
#!/usr/bin/perl -w
#
# Basic test suite for Tie::RefHash and Tie::RefHash::Nestable.
#
# The testing is in two parts: first, run lots of tests on both a tied
# hash and an ordinary un-tied hash, and check they give the same
# answer. Then there are tests for those cases where the tied hashes
# should behave differently to normal hashes, that is, when using
# references as keys.
#
BEGIN {
chdir 't' if -d 't';
@INC = '.';
push @INC, '../lib';
require Config;
if (($Config::Config{'extensions'} !~ m!\bData/Dumper\b!) ){
print "1..0 # Skip -- Perl configured without Data::Dumper module\n";
exit 0;
}
}
use strict;
use Tie::RefHash;
use Data::Dumper;
my $numtests = 39;
my $currtest = 1;
print "1..$numtests\n";
my $ref = []; my $ref1 = [];
package Boustrophedon; # A class with overloaded "".
sub new { my ($c, $s) = @_; bless \$s, $c }
use overload '""' => sub { ${$_[0]} . reverse ${$_[0]} };
package main;
my $ox = Boustrophedon->new("foobar");
# Test standard hash functionality, by performing the same operations
# on a tied hash and on a normal hash, and checking that the results
# are the same. This does of course assume that Perl hashes are not
# buggy :-)
#
my @tests = standard_hash_tests();
my @ordinary_results = runtests(\@tests, undef);
foreach my $class ('Tie::RefHash', 'Tie::RefHash::Nestable') {
my @tied_results = runtests(\@tests, $class);
my $all_ok = 1;
die if @ordinary_results != @tied_results;
foreach my $i (0 .. $#ordinary_results) {
my ($or, $ow, $oe) = @{$ordinary_results[$i]};
my ($tr, $tw, $te) = @{$tied_results[$i]};
my $ok = 1;
local $^W = 0;
$ok = 0 if (defined($or) != defined($tr)) or ($or ne $tr);
$ok = 0 if (defined($ow) != defined($tw)) or ($ow ne $tw);
$ok = 0 if (defined($oe) != defined($te)) or ($oe ne $te);
if (not $ok) {
print STDERR
"failed for $class: $tests[$i]\n",
"ordinary hash gave:\n",
defined $or ? "\tresult: $or\n" : "\tundef result\n",
defined $ow ? "\twarning: $ow\n" : "\tno warning\n",
defined $oe ? "\texception: $oe\n" : "\tno exception\n",
"tied $class hash gave:\n",
defined $tr ? "\tresult: $tr\n" : "\tundef result\n",
defined $tw ? "\twarning: $tw\n" : "\tno warning\n",
defined $te ? "\texception: $te\n" : "\tno exception\n",
"\n";
$all_ok = 0;
}
}
test($all_ok);
}
# Now test Tie::RefHash's special powers
my (%h, $h);
$h = eval { tie %h, 'Tie::RefHash' };
warn $@ if $@;
test(not $@);
test(ref($h) eq 'Tie::RefHash');
test(defined(tied(%h)) and tied(%h) =~ /^Tie::RefHash/);
$h{$ref} = 'cholet';
test($h{$ref} eq 'cholet');
test(exists $h{$ref});
test((keys %h) == 1);
test(ref((keys %h)[0]) eq 'ARRAY');
test((keys %h)[0] eq $ref);
test((values %h) == 1);
test((values %h)[0] eq 'cholet');
my $count = 0;
while (my ($k, $v) = each %h) {
if ($count++ == 0) {
test(ref($k) eq 'ARRAY');
test($k eq $ref);
}
}
test($count == 1);
delete $h{$ref};
test(not defined $h{$ref});
test(not exists($h{$ref}));
test((keys %h) == 0);
test((values %h) == 0);
$h{$ox} = "bellow"; # overloaded ""
test(exists $h{$ox});
test($h{$ox} eq "bellow");
test(not exists $h{"foobarraboof"});
undef $h;
untie %h;
# And now Tie::RefHash::Nestable's differences from Tie::RefHash.
$h = eval { tie %h, 'Tie::RefHash::Nestable' };
warn $@ if $@;
test(not $@);
test(ref($h) eq 'Tie::RefHash::Nestable');
test(defined(tied(%h)) and tied(%h) =~ /^Tie::RefHash::Nestable/);
$h{$ref}->{$ref1} = 'bungo';
test($h{$ref}->{$ref1} eq 'bungo');
# Test that the nested hash is also tied (for current implementation)
test(defined(tied(%{$h{$ref}}))
and tied(%{$h{$ref}}) =~ /^Tie::RefHash::Nestable=/ );
test((keys %h) == 1);
test((keys %h)[0] eq $ref);
test((keys %{$h{$ref}}) == 1);
test((keys %{$h{$ref}})[0] eq $ref1);
{
# Tests that delete returns the deleted element [perl #32193]
my $ref = \(my $var = "oink");
tie my %oink, 'Tie::RefHash';
$oink{$ref} = "ding";
test($oink{$ref} eq "ding");
test(delete($oink{$ref}) eq "ding");
}
die "expected to run $numtests tests, but ran ", $currtest - 1
if $currtest - 1 != $numtests;
@tests = ();
undef $ref;
undef $ref1;
exit();
# Print 'ok X' if true, 'not ok X' if false
# Uses global $currtest.
#
sub test {
my $t = shift;
print 'not ' if not $t;
print 'ok ', $currtest++, "\n";
}
# Wrapper for Data::Dumper to 'dump' a scalar as an EXPR string.
sub dumped {
my $s = shift;
my $d = Dumper($s);
$d =~ s/^\$VAR1 =\s*//;
$d =~ s/;$//;
chomp $d;
return $d;
}
# Crudely dump a hash into a canonical string representation (because
# hash keys can appear in any order, Data::Dumper may give different
# strings for the same hash).
#
sub dumph {
my $h = shift;
my $r = '';
foreach (sort keys %$h) {
$r = dumped($_) . ' => ' . dumped($h->{$_}) . "\n";
}
return $r;
}
# Run the tests and give results.
#
# Parameters: reference to list of tests to run
# name of class to use for tied hash, or undef if not tied
#
# Returns: list of [R, W, E] tuples, one for each test.
# R is the return value from running the test, W any warnings it gave,
# and E any exception raised with 'die'. E and W will be tidied up a
# little to remove irrelevant details like line numbers :-)
#
# Will also run a few of its own 'ok N' tests.
#
sub runtests {
my ($tests, $class) = @_;
my @r;
my (%h, $h);
if (defined $class) {
$h = eval { tie %h, $class };
warn $@ if $@;
test(not $@);
test(ref($h) eq $class);
test(defined(tied(%h)) and tied(%h) =~ /^\Q$class\E/);
}
foreach (@$tests) {
my ($result, $warning, $exception);
local $SIG{__WARN__} = sub { $warning .= $_[0] };
$result = scalar(eval $_);
if ($@)
{
die "$@:$_" unless defined $class;
$exception = $@;
}
foreach ($warning, $exception) {
next if not defined;
s/ at .+ line \d+\.$//mg;
s/ at .+ line \d+, at .*//mg;
s/ at .+ line \d+, near .*//mg;
}
my (@warnings, %seen);
foreach (split /\n/, $warning) {
push @warnings, $_ unless $seen{$_}++;
}
$warning = join("\n", @warnings);
push @r, [ $result, $warning, $exception ];
}
return @r;
}
# Things that should work just the same for an ordinary hash and a
# Tie::RefHash.
#
# Each test is a code string to be eval'd, it should do something with
# %h and give a scalar return value. The global $ref and $ref1 may
# also be used.
#
# One thing we don't test is that the ordering from 'keys', 'values'
# and 'each' is the same. You can't reasonably expect that.
#
sub standard_hash_tests {
my @r;
# Library of standard tests on keys, values and each
my $STD_TESTS = <<'END'
join $;, sort keys %h;
join $;, sort values %h;
{ my ($v, %tmp); $tmp{$v}++ while (defined($v = each %h)); dumph(\%tmp) }
{ my ($k, $v, %tmp); $tmp{"$k$;$v"}++ while (($k, $v) = each %h); dumph(\%tmp) }
END
;
# Tests on the existence of the element 'foo'
my $FOO_TESTS = <<'END'
defined $h{foo};
exists $h{foo};
$h{foo};
END
;
# Test storing and deleting 'foo'
push @r, split /\n/, <<"END"
$STD_TESTS;
$FOO_TESTS;
\$h{foo} = undef;
$STD_TESTS;
$FOO_TESTS;
\$h{foo} = 'hello';
$STD_TESTS;
$FOO_TESTS;
delete \$h{foo};
$STD_TESTS;
$FOO_TESTS;
END
;
# Test storing and removing under ordinary keys
my @things = ('boink', 0, 1, '', undef);
foreach my $key (map { dumped($_) } @things) {
foreach my $value ((map { dumped($_) } @things), '$ref') {
push @r, split /\n/, <<"END"
\$h{$key} = $value;
$STD_TESTS;
defined \$h{$key};
exists \$h{$key};
\$h{$key};
delete \$h{$key};
$STD_TESTS;
defined \$h{$key};
exists \$h{$key};
\$h{$key};
END
;
}
}
# Test hash slices
my @slicetests;
@slicetests = split /\n/, <<'END'
@h{'b'} = ();
@h{'c'} = ('d');
@h{'e'} = ('f', 'g');
@h{'h', 'i'} = ();
@h{'j', 'k'} = ('l');
@h{'m', 'n'} = ('o', 'p');
@h{'q', 'r'} = ('s', 't', 'u');
END
;
my @aaa = @slicetests;
foreach (@slicetests) {
push @r, $_;
push @r, split(/\n/, $STD_TESTS);
}
# Test CLEAR
push @r, '%h = ();', split(/\n/, $STD_TESTS);
return @r;
}
--- NEW FILE: Handle.pm ---
package Tie::Handle;
use 5.006_001;
our $VERSION = '4.1';
=head1 NAME
Tie::Handle, Tie::StdHandle - base class definitions for tied handles
=head1 SYNOPSIS
package NewHandle;
require Tie::Handle;
@ISA = qw(Tie::Handle);
sub READ { ... } # Provide a needed method
sub TIEHANDLE { ... } # Overrides inherited method
package main;
tie *FH, 'NewHandle';
=head1 DESCRIPTION
This module provides some skeletal methods for handle-tying classes. See
L<perltie> for a list of the functions required in tying a handle to a package.
The basic B<Tie::Handle> package provides a C<new> method, as well as methods
C<TIEHANDLE>, C<PRINT>, C<PRINTF> and C<GETC>.
For developers wishing to write their own tied-handle classes, the methods
are summarized below. The L<perltie> section not only documents these, but
has sample code as well:
=over 4
=item TIEHANDLE classname, LIST
The method invoked by the command C<tie *glob, classname>. Associates a new
glob instance with the specified class. C<LIST> would represent additional
arguments (along the lines of L<AnyDBM_File> and compatriots) needed to
complete the association.
=item WRITE this, scalar, length, offset
Write I<length> bytes of data from I<scalar> starting at I<offset>.
=item PRINT this, LIST
Print the values in I<LIST>
=item PRINTF this, format, LIST
Print the values in I<LIST> using I<format>
=item READ this, scalar, length, offset
Read I<length> bytes of data into I<scalar> starting at I<offset>.
=item READLINE this
Read a single line
=item GETC this
Get a single character
=item CLOSE this
Close the handle
=item OPEN this, filename
(Re-)open the handle
=item BINMODE this
Specify content is binary
=item EOF this
Test for end of file.
=item TELL this
Return position in the file.
=item SEEK this, offset, whence
Position the file.
Test for end of file.
=item DESTROY this
Free the storage associated with the tied handle referenced by I<this>.
This is rarely needed, as Perl manages its memory quite well. But the
option exists, should a class wish to perform specific actions upon the
destruction of an instance.
=back
=head1 MORE INFORMATION
The L<perltie> section contains an example of tying handles.
=head1 COMPATIBILITY
This version of Tie::Handle is neither related to nor compatible with
the Tie::Handle (3.0) module available on CPAN. It was due to an
accident that two modules with the same name appeared. The namespace
clash has been cleared in favor of this module that comes with the
perl core in September 2000 and accordingly the version number has
been bumped up to 4.0.
=cut
use Carp;
use warnings::register;
sub new {
my $pkg = shift;
$pkg->TIEHANDLE(@_);
}
# "Grandfather" the new, a la Tie::Hash
sub TIEHANDLE {
my $pkg = shift;
if (defined &{"{$pkg}::new"}) {
warnings::warnif("WARNING: calling ${pkg}->new since ${pkg}->TIEHANDLE is missing");
$pkg->new(@_);
}
else {
croak "$pkg doesn't define a TIEHANDLE method";
}
}
sub PRINT {
my $self = shift;
if($self->can('WRITE') != \&WRITE) {
my $buf = join(defined $, ? $, : "", at _);
$buf .= $\ if defined $\;
$self->WRITE($buf,length($buf),0);
}
else {
croak ref($self)," doesn't define a PRINT method";
}
}
sub PRINTF {
my $self = shift;
if($self->can('WRITE') != \&WRITE) {
my $buf = sprintf(shift, at _);
$self->WRITE($buf,length($buf),0);
}
else {
croak ref($self)," doesn't define a PRINTF method";
}
}
sub READLINE {
my $pkg = ref $_[0];
croak "$pkg doesn't define a READLINE method";
}
sub GETC {
my $self = shift;
if($self->can('READ') != \&READ) {
my $buf;
$self->READ($buf,1);
return $buf;
}
else {
croak ref($self)," doesn't define a GETC method";
}
}
sub READ {
my $pkg = ref $_[0];
croak "$pkg doesn't define a READ method";
}
sub WRITE {
my $pkg = ref $_[0];
croak "$pkg doesn't define a WRITE method";
}
sub CLOSE {
my $pkg = ref $_[0];
croak "$pkg doesn't define a CLOSE method";
}
package Tie::StdHandle;
our @ISA = 'Tie::Handle';
use Carp;
sub TIEHANDLE
{
my $class = shift;
my $fh = \do { local *HANDLE};
bless $fh,$class;
$fh->OPEN(@_) if (@_);
return $fh;
}
sub EOF { eof($_[0]) }
sub TELL { tell($_[0]) }
sub FILENO { fileno($_[0]) }
sub SEEK { seek($_[0],$_[1],$_[2]) }
sub CLOSE { close($_[0]) }
sub BINMODE { binmode($_[0]) }
sub OPEN
{
$_[0]->CLOSE if defined($_[0]->FILENO);
@_ == 2 ? open($_[0], $_[1]) : open($_[0], $_[1], $_[2]);
}
sub READ { read($_[0],$_[1],$_[2]) }
sub READLINE { my $fh = $_[0]; <$fh> }
sub GETC { getc($_[0]) }
sub WRITE
{
my $fh = $_[0];
print $fh substr($_[1],0,$_[2])
}
1;
--- NEW FILE: Memoize.pm ---
use strict;
package Tie::Memoize;
use Tie::Hash;
our @ISA = 'Tie::ExtraHash';
our $VERSION = '1.0';
our $exists_token = \undef;
sub croak {require Carp; goto &Carp::croak}
# Format: [0: STORAGE, 1: EXISTS-CACHE, 2: FETCH_function;
# 3: EXISTS_function, 4: DATA, 5: EXISTS_different ]
sub FETCH {
my ($h,$key) = ($_[0][0], $_[1]);
my $res = $h->{$key};
return $res if defined $res; # Shortcut if accessible
return $res if exists $h->{$key}; # Accessible, but undef
my $cache = $_[0][1]{$key};
return if defined $cache and not $cache; # Known to not exist
my @res = $_[0][2]->($key, $_[0][4]); # Autoload
$_[0][1]{$key} = 0, return unless @res; # Cache non-existence
delete $_[0][1]{$key}; # Clear existence cache, not needed any more
$_[0][0]{$key} = $res[0]; # Store data and return
}
sub EXISTS {
my ($a,$key) = (shift, shift);
return 1 if exists $a->[0]{$key}; # Have data
my $cache = $a->[1]{$key};
return $cache if defined $cache; # Existence cache
my @res = $a->[3]($key,$a->[4]);
$_[0][1]{$key} = 0, return unless @res; # Cache non-existence
# Now we know it exists
return ($_[0][1]{$key} = 1) if $a->[5]; # Only existence reported
# Now know the value
$_[0][0]{$key} = $res[0]; # Store data
return 1
}
sub TIEHASH {
croak 'syntax: tie %hash, \'Tie::AutoLoad\', \&fetch_subr' if @_ < 2;
croak 'syntax: tie %hash, \'Tie::AutoLoad\', \&fetch_subr, $data, \&exists_subr, \%data_cache, \%existence_cache' if @_ > 6;
push @_, undef if @_ < 3; # Data
push @_, $_[1] if @_ < 4; # exists
push @_, {} while @_ < 6; # initial value and caches
bless [ @_[4,5,1,3,2], $_[1] ne $_[3]], $_[0]
}
1;
=head1 NAME
Tie::Memoize - add data to hash when needed
=head1 SYNOPSIS
require Tie::Memoize;
tie %hash, 'Tie::Memoize',
\&fetch, # The rest is optional
$DATA, \&exists,
{%ini_value}, {%ini_existence};
=head1 DESCRIPTION
This package allows a tied hash to autoload its values on the first access,
and to use the cached value on the following accesses.
Only read-accesses (via fetching the value or C<exists>) result in calls to
the functions; the modify-accesses are performed as on a normal hash.
The required arguments during C<tie> are the hash, the package, and
the reference to the C<FETCH>ing function. The optional arguments are
an arbitrary scalar $data, the reference to the C<EXISTS> function,
and initial values of the hash and of the existence cache.
Both the C<FETCH>ing function and the C<EXISTS> functions have the
same signature: the arguments are C<$key, $data>; $data is the same
value as given as argument during tie()ing. Both functions should
return an empty list if the value does not exist. If C<EXISTS>
function is different from the C<FETCH>ing function, it should return
a TRUE value on success. The C<FETCH>ing function should return the
intended value if the key is valid.
=head1 Inheriting from B<Tie::Memoize>
The structure of the tied() data is an array reference with elements
0: cache of known values
1: cache of known existence of keys
2: FETCH function
3: EXISTS function
4: $data
The rest is for internal usage of this package. In particular, if
TIEHASH is overwritten, it should call SUPER::TIEHASH.
=head1 EXAMPLE
sub slurp {
my ($key, $dir) = shift;
open my $h, '<', "$dir/$key" or return;
local $/; <$h> # slurp it all
}
sub exists { my ($key, $dir) = shift; return -f "$dir/$key" }
tie %hash, 'Tie::Memoize', \&slurp, $directory, \&exists,
{ fake_file1 => $content1, fake_file2 => $content2 },
{ pretend_does_not_exists => 0, known_to_exist => 1 };
This example treats the slightly modified contents of $directory as a
hash. The modifications are that the keys F<fake_file1> and
F<fake_file2> fetch values $content1 and $content2, and
F<pretend_does_not_exists> will never be accessed. Additionally, the
existence of F<known_to_exist> is never checked (so if it does not
exists when its content is needed, the user of %hash may be confused).
=head1 BUGS
FIRSTKEY and NEXTKEY methods go through the keys which were already read,
not all the possible keys of the hash.
=head1 AUTHOR
Ilya Zakharevich L<mailto:perl-module-hash-memoize at ilyaz.org>.
=cut
--- NEW FILE: Array.pm ---
package Tie::Array;
use 5.006_001;
use strict;
use Carp;
our $VERSION = '1.03';
# Pod documentation after __END__ below.
sub DESTROY { }
sub EXTEND { }
sub UNSHIFT { scalar shift->SPLICE(0,0, at _) }
sub SHIFT { shift->SPLICE(0,1) }
sub CLEAR { shift->STORESIZE(0) }
sub PUSH
{
my $obj = shift;
my $i = $obj->FETCHSIZE;
$obj->STORE($i++, shift) while (@_);
}
sub POP
{
my $obj = shift;
my $newsize = $obj->FETCHSIZE - 1;
my $val;
if ($newsize >= 0)
{
$val = $obj->FETCH($newsize);
$obj->STORESIZE($newsize);
}
$val;
}
sub SPLICE {
my $obj = shift;
my $sz = $obj->FETCHSIZE;
my $off = (@_) ? shift : 0;
$off += $sz if ($off < 0);
my $len = (@_) ? shift : $sz - $off;
$len += $sz - $off if $len < 0;
my @result;
for (my $i = 0; $i < $len; $i++) {
push(@result,$obj->FETCH($off+$i));
}
$off = $sz if $off > $sz;
$len -= $off + $len - $sz if $off + $len > $sz;
if (@_ > $len) {
# Move items up to make room
my $d = @_ - $len;
my $e = $off+$len;
$obj->EXTEND($sz+$d);
for (my $i=$sz-1; $i >= $e; $i--) {
my $val = $obj->FETCH($i);
$obj->STORE($i+$d,$val);
}
}
elsif (@_ < $len) {
# Move items down to close the gap
my $d = $len - @_;
my $e = $off+$len;
for (my $i=$off+$len; $i < $sz; $i++) {
my $val = $obj->FETCH($i);
$obj->STORE($i-$d,$val);
}
$obj->STORESIZE($sz-$d);
}
for (my $i=0; $i < @_; $i++) {
$obj->STORE($off+$i,$_[$i]);
}
return wantarray ? @result : pop @result;
}
sub EXISTS {
my $pkg = ref $_[0];
croak "$pkg doesn't define an EXISTS method";
}
sub DELETE {
my $pkg = ref $_[0];
croak "$pkg doesn't define a DELETE method";
}
package Tie::StdArray;
use vars qw(@ISA);
@ISA = 'Tie::Array';
sub TIEARRAY { bless [], $_[0] }
sub FETCHSIZE { scalar @{$_[0]} }
sub STORESIZE { $#{$_[0]} = $_[1]-1 }
sub STORE { $_[0]->[$_[1]] = $_[2] }
sub FETCH { $_[0]->[$_[1]] }
sub CLEAR { @{$_[0]} = () }
sub POP { pop(@{$_[0]}) }
sub PUSH { my $o = shift; push(@$o, at _) }
sub SHIFT { shift(@{$_[0]}) }
sub UNSHIFT { my $o = shift; unshift(@$o, at _) }
sub EXISTS { exists $_[0]->[$_[1]] }
sub DELETE { delete $_[0]->[$_[1]] }
sub SPLICE
{
my $ob = shift;
my $sz = $ob->FETCHSIZE;
my $off = @_ ? shift : 0;
$off += $sz if $off < 0;
my $len = @_ ? shift : $sz-$off;
return splice(@$ob,$off,$len, at _);
}
1;
__END__
=head1 NAME
Tie::Array - base class for tied arrays
=head1 SYNOPSIS
package Tie::NewArray;
use Tie::Array;
@ISA = ('Tie::Array');
# mandatory methods
sub TIEARRAY { ... }
sub FETCH { ... }
sub FETCHSIZE { ... }
sub STORE { ... } # mandatory if elements writeable
sub STORESIZE { ... } # mandatory if elements can be added/deleted
sub EXISTS { ... } # mandatory if exists() expected to work
sub DELETE { ... } # mandatory if delete() expected to work
# optional methods - for efficiency
sub CLEAR { ... }
sub PUSH { ... }
sub POP { ... }
sub SHIFT { ... }
sub UNSHIFT { ... }
sub SPLICE { ... }
sub EXTEND { ... }
sub DESTROY { ... }
package Tie::NewStdArray;
use Tie::Array;
@ISA = ('Tie::StdArray');
# all methods provided by default
package main;
$object = tie @somearray,Tie::NewArray;
$object = tie @somearray,Tie::StdArray;
$object = tie @somearray,Tie::NewStdArray;
=head1 DESCRIPTION
This module provides methods for array-tying classes. See
L<perltie> for a list of the functions required in order to tie an array
to a package. The basic B<Tie::Array> package provides stub C<DESTROY>,
and C<EXTEND> methods that do nothing, stub C<DELETE> and C<EXISTS>
methods that croak() if the delete() or exists() builtins are ever called
on the tied array, and implementations of C<PUSH>, C<POP>, C<SHIFT>,
C<UNSHIFT>, C<SPLICE> and C<CLEAR> in terms of basic C<FETCH>, C<STORE>,
C<FETCHSIZE>, C<STORESIZE>.
The B<Tie::StdArray> package provides efficient methods required for tied arrays
which are implemented as blessed references to an "inner" perl array.
It inherits from B<Tie::Array>, and should cause tied arrays to behave exactly
like standard arrays, allowing for selective overloading of methods.
For developers wishing to write their own tied arrays, the required methods
are briefly defined below. See the L<perltie> section for more detailed
descriptive, as well as example code:
=over 4
=item TIEARRAY classname, LIST
The class method is invoked by the command C<tie @array, classname>. Associates
an array instance with the specified class. C<LIST> would represent
additional arguments (along the lines of L<AnyDBM_File> and compatriots) needed
to complete the association. The method should return an object of a class which
provides the methods below.
=item STORE this, index, value
Store datum I<value> into I<index> for the tied array associated with
object I<this>. If this makes the array larger then
class's mapping of C<undef> should be returned for new positions.
=item FETCH this, index
Retrieve the datum in I<index> for the tied array associated with
object I<this>.
=item FETCHSIZE this
Returns the total number of items in the tied array associated with
object I<this>. (Equivalent to C<scalar(@array)>).
=item STORESIZE this, count
Sets the total number of items in the tied array associated with
object I<this> to be I<count>. If this makes the array larger then
class's mapping of C<undef> should be returned for new positions.
If the array becomes smaller then entries beyond count should be
deleted.
=item EXTEND this, count
Informative call that array is likely to grow to have I<count> entries.
Can be used to optimize allocation. This method need do nothing.
=item EXISTS this, key
Verify that the element at index I<key> exists in the tied array I<this>.
The B<Tie::Array> implementation is a stub that simply croaks.
=item DELETE this, key
Delete the element at index I<key> from the tied array I<this>.
The B<Tie::Array> implementation is a stub that simply croaks.
=item CLEAR this
Clear (remove, delete, ...) all values from the tied array associated with
object I<this>.
=item DESTROY this
Normal object destructor method.
=item PUSH this, LIST
Append elements of LIST to the array.
=item POP this
Remove last element of the array and return it.
=item SHIFT this
Remove the first element of the array (shifting other elements down)
and return it.
=item UNSHIFT this, LIST
Insert LIST elements at the beginning of the array, moving existing elements
up to make room.
=item SPLICE this, offset, length, LIST
Perform the equivalent of C<splice> on the array.
I<offset> is optional and defaults to zero, negative values count back
from the end of the array.
I<length> is optional and defaults to rest of the array.
I<LIST> may be empty.
Returns a list of the original I<length> elements at I<offset>.
=back
=head1 CAVEATS
There is no support at present for tied @ISA. There is a potential conflict
between magic entries needed to notice setting of @ISA, and those needed to
implement 'tie'.
Very little consideration has been given to the behaviour of tied arrays
when C<$[> is not default value of zero.
=head1 AUTHOR
Nick Ing-Simmons E<lt>nik at tiuk.ti.comE<gt>
=cut
More information about the dslinux-commit
mailing list