diff options
Diffstat (limited to 'contrib/perl5/lib/Tie')
| -rw-r--r-- | contrib/perl5/lib/Tie/Array.pm | 262 | ||||
| -rw-r--r-- | contrib/perl5/lib/Tie/Handle.pm | 161 | ||||
| -rw-r--r-- | contrib/perl5/lib/Tie/Hash.pm | 158 | ||||
| -rw-r--r-- | contrib/perl5/lib/Tie/RefHash.pm | 123 | ||||
| -rw-r--r-- | contrib/perl5/lib/Tie/Scalar.pm | 138 | ||||
| -rw-r--r-- | contrib/perl5/lib/Tie/SubstrHash.pm | 180 |
6 files changed, 1022 insertions, 0 deletions
diff --git a/contrib/perl5/lib/Tie/Array.pm b/contrib/perl5/lib/Tie/Array.pm new file mode 100644 index 000000000000..4041b00e8603 --- /dev/null +++ b/contrib/perl5/lib/Tie/Array.pm @@ -0,0 +1,262 @@ +package Tie::Array; +use vars qw($VERSION); +use strict; +$VERSION = '1.00'; + +# Pod documentation after __END__ below. + +sub DESTROY { } +sub EXTEND { } +sub UNSHIFT { shift->SPLICE(0,0,@_) } +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; + my @result; + for (my $i = 0; $i < $len; $i++) + { + push(@result,$obj->FETCH($off+$i)); + } + 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 @result; +} + +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,@_) } +sub SHIFT { shift(@{$_[0]}) } +sub UNSHIFT { my $o = shift; unshift(@$o,@_) } + +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,@_); +} + +1; + +__END__ + +=head1 NAME + +Tie::Array - base class for tied arrays + +=head1 SYNOPSIS + + package 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 + + # optional methods - for efficiency + sub CLEAR { ... } + sub PUSH { ... } + sub POP { ... } + sub SHIFT { ... } + sub UNSHIFT { ... } + sub SPLICE { ... } + sub EXTEND { ... } + sub DESTROY { ... } + + package 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<DELETE> +and C<EXTEND> methods, 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 + +=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 assoicated 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 assoicated with +object I<this>. + +=item FETCHSIZE this + +Returns the total number of items in the tied array assoicated with +object I<this>. (Equivalent to C<scalar(@array)>). + +=item STORESIZE this, count + +Sets the total number of items in the tied array assoicated 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 CLEAR this + +Clear (remove, delete, ...) all values from the tied array assoicated 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 begining 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@tiuk.ti.comE<gt> + +=cut + diff --git a/contrib/perl5/lib/Tie/Handle.pm b/contrib/perl5/lib/Tie/Handle.pm new file mode 100644 index 000000000000..c7550530b87e --- /dev/null +++ b/contrib/perl5/lib/Tie/Handle.pm @@ -0,0 +1,161 @@ +package Tie::Handle; + +=head1 NAME + +Tie::Handle - base class definitions for tied handles + +=head1 SYNOPSIS + + package NewHandle; + require Tie::Handle; + + @ISA = (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<TIESCALAR>, C<FETCH> and C<STORE>. 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-handle classes, the methods +are summarized below. The L<perltie> section not only documents these, but +has sample code as well: + +=over + +=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 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. + +=cut + +use Carp; + +sub new { + my $pkg = shift; + $pkg->TIEHANDLE(@_); +} + +# "Grandfather" the new, a la Tie::Hash + +sub TIEHANDLE { + my $pkg = shift; + if (defined &{"{$pkg}::new"}) { + carp "WARNING: calling ${pkg}->new since ${pkg}->TIEHANDLE is missing" + if $^W; + $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 $, ? $, : "",@_); + $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(@_); + $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"; +} + +1; diff --git a/contrib/perl5/lib/Tie/Hash.pm b/contrib/perl5/lib/Tie/Hash.pm new file mode 100644 index 000000000000..7ed18962e9e7 --- /dev/null +++ b/contrib/perl5/lib/Tie/Hash.pm @@ -0,0 +1,158 @@ +package Tie::Hash; + +=head1 NAME + +Tie::Hash, Tie::StdHash - 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 + sub DELETE { ... } + + + package main; + + tie %new_hash, 'NewHash'; + tie %new_std_hash, 'NewStdHash'; + +=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> package +provides most methods required for hashes in L<perltie>. It inherits from +B<Tie::Hash>, and causes tied hashes to behave exactly like standard hashes, +allowing for selective overloading of methods. The C<new> method is provided +as grandfathering 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 + +=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 (key, value) pair for the first key in the hash. + +=item NEXTKEY this, lastkey + +Return the next key for the hash. + +=item EXISTS this, key + +Verify that I<key> exists with the tied hash I<this>. + +=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>. + +=back + +=head1 CAVEATS + +The L<perltie> documentation includes a method called C<DESTROY> as +a necessary method for tied hashes. Neither B<Tie::Hash> nor B<Tie::StdHash> +define a default for this method. This is a standard for class packages, +but may be omitted in favor of a simple default. + +=head1 MORE INFORMATION + +The packages relating to various DBM-related implemetations (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; + +sub new { + my $pkg = shift; + $pkg->TIEHASH(@_); +} + +# Grandfather "new" + +sub TIEHASH { + my $pkg = shift; + if (defined &{"${pkg}::new"}) { + carp "WARNING: calling ${pkg}->new since ${pkg}->TIEHASH is missing" + if $^W; + $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); + +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]} = () } + +1; diff --git a/contrib/perl5/lib/Tie/RefHash.pm b/contrib/perl5/lib/Tie/RefHash.pm new file mode 100644 index 000000000000..66de2572fcd4 --- /dev/null +++ b/contrib/perl5/lib/Tie/RefHash.pm @@ -0,0 +1,123 @@ +package Tie::RefHash; + +=head1 NAME + +Tie::RefHash - use references as hash keys + +=head1 SYNOPSIS + + require 5.004; + use Tie::RefHash; + tie HASHVARIABLE, 'Tie::RefHash', 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. + +It is implemented using the standard perl TIEHASH interface. Please +see the C<tie> entry in perlfunc(1) and perltie(1) for more information. + +=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"; + } + + +=head1 AUTHOR + +Gurusamy Sarathy gsar@umich.edu + +=head1 VERSION + +Version 1.2 15 Dec 1996 + +=head1 SEE ALSO + +perl(1), perlfunc(1), perltie(1) + +=cut + +require 5.003_11; +use Tie::Hash; +@ISA = qw(Tie::Hash); +use strict; + +sub TIEHASH { + my $c = shift; + my $s = []; + bless $s, $c; + while (@_) { + $s->STORE(shift, shift); + } + return $s; +} + +sub FETCH { + my($s, $k) = @_; + (ref $k) ? $s->[0]{"$k"}[1] : $s->[1]{$k}; +} + +sub STORE { + my($s, $k, $v) = @_; + if (ref $k) { + $s->[0]{"$k"} = [$k, $v]; + } + else { + $s->[1]{$k} = $v; + } + $v; +} + +sub DELETE { + my($s, $k) = @_; + (ref $k) ? delete($s->[0]{"$k"}) : delete($s->[1]{$k}); +} + +sub EXISTS { + my($s, $k) = @_; + (ref $k) ? exists($s->[0]{"$k"}) : exists($s->[1]{$k}); +} + +sub FIRSTKEY { + my $s = shift; + my $a = scalar(keys %{$s->[0]}) + scalar(keys %{$s->[1]}); + $s->[2] = 0; + $s->NEXTKEY; +} + +sub NEXTKEY { + my $s = shift; + my ($k, $v); + if (!$s->[2]) { + if (($k, $v) = each %{$s->[0]}) { + return $s->[0]{"$k"}[0]; + } + else { + $s->[2] = 1; + } + } + return each %{$s->[1]}; +} + +sub CLEAR { + my $s = shift; + $s->[2] = 0; + %{$s->[0]} = (); + %{$s->[1]} = (); +} + +1; diff --git a/contrib/perl5/lib/Tie/Scalar.pm b/contrib/perl5/lib/Tie/Scalar.pm new file mode 100644 index 000000000000..ef27dc1398c8 --- /dev/null +++ b/contrib/perl5/lib/Tie/Scalar.pm @@ -0,0 +1,138 @@ +package Tie::Scalar; + +=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 + +=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; + +sub new { + my $pkg = shift; + $pkg->TIESCALAR(@_); +} + +# "Grandfather" the new, a la Tie::Hash + +sub TIESCALAR { + my $pkg = shift; + if (defined &{"{$pkg}::new"}) { + carp "WARNING: calling ${pkg}->new since ${pkg}->TIESCALAR is missing" + if $^W; + $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; diff --git a/contrib/perl5/lib/Tie/SubstrHash.pm b/contrib/perl5/lib/Tie/SubstrHash.pm new file mode 100644 index 000000000000..44c2140c7beb --- /dev/null +++ b/contrib/perl5/lib/Tie/SubstrHash.pm @@ -0,0 +1,180 @@ +package Tie::SubstrHash; + +=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. + +=cut + +use Carp; + +sub TIEHASH { + my $pack = shift; + my ($klen, $vlen, $tsize) = @_; + my $rlen = 1 + $klen + $vlen; + $tsize = findprime($tsize * 1.1); # Allow 10% empty. + $self = bless ["\0", $klen, $vlen, $tsize, $rlen, 0, -1]; + $$self[0] x= $rlen * $tsize; + $self; +} + +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") if $self[5] == $tsize; + 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; ++$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 hashkey { + croak(qq/Key "$key" is not $klen characters long.\n/) + if length($key) != $klen; + $hash = 2; + for (unpack('C*', $key)) { + $hash = $hash * 33 + $_; + &_hashwrap if $hash >= 1e13; + } + &_hashwrap if $hash >= $tsize; + $hash = 1 unless $hash; + $hashbase = $hash; +} + +sub _hashwrap { + $hash -= int($hash / $tsize) * $tsize; +} + +sub rehash { + $hash += $hashbase; + $hash -= $tsize if $hash >= $tsize; +} + +sub findprime { + use integer; + + my $num = shift; + $num++ unless $num % 2; + + $max = int sqrt $num; + + NUM: + for (;; $num += 2) { + for ($i = 3; $i <= $max; $i += 2) { + next NUM unless $num % $i; + } + return $num; + } +} + +1; |