Initial Commit
This commit is contained in:
Riley Schneider
283
database/perl/lib/Tie/Array.pm
Normal file
283
database/perl/lib/Tie/Array.pm
Normal file
@@ -0,0 +1,283 @@
|
||||
package Tie::Array;
|
||||
|
||||
use 5.006_001;
|
||||
use strict;
|
||||
use Carp;
|
||||
our $VERSION = '1.07';
|
||||
|
||||
# Pod documentation after __END__ below.
|
||||
|
||||
sub DESTROY { }
|
||||
sub EXTEND { }
|
||||
sub UNSHIFT { scalar 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;
|
||||
$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;
|
||||
our @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 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,@_);
|
||||
}
|
||||
|
||||
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'.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Nick Ing-Simmons E<lt>nik@tiuk.ti.comE<gt>
|
||||
|
||||
=cut
|
||||
2639
database/perl/lib/Tie/File.pm
Normal file
2639
database/perl/lib/Tie/File.pm
Normal file
File diff suppressed because it is too large
Load Diff
201
database/perl/lib/Tie/Handle.pm
Normal file
201
database/perl/lib/Tie/Handle.pm
Normal file
@@ -0,0 +1,201 @@
|
||||
package Tie::Handle;
|
||||
|
||||
use 5.006_001;
|
||||
our $VERSION = '4.2';
|
||||
|
||||
# Tie::StdHandle used to be inside Tie::Handle. For backwards compatibility
|
||||
# loading Tie::Handle has to make Tie::StdHandle available.
|
||||
use Tie::StdHandle;
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Tie::Handle - 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 $, ? $, : "",@_);
|
||||
$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,@_);
|
||||
$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;
|
||||
270
database/perl/lib/Tie/Hash.pm
Normal file
270
database/perl/lib/Tie/Hash.pm
Normal file
@@ -0,0 +1,270 @@
|
||||
package Tie::Hash;
|
||||
|
||||
our $VERSION = '1.05';
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Tie::Hash, Tie::StdHash, Tie::ExtraHash - base class definitions for tied hashes
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
package NewHash;
|
||||
require Tie::Hash;
|
||||
|
||||
@ISA = qw(Tie::Hash);
|
||||
|
||||
sub DELETE { ... } # Provides needed method
|
||||
sub CLEAR { ... } # Overrides inherited method
|
||||
|
||||
|
||||
package NewStdHash;
|
||||
require Tie::Hash;
|
||||
|
||||
@ISA = qw(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 = qw(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<perltie/"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;
|
||||
my $pkg_new = $pkg -> can ('new');
|
||||
|
||||
if ($pkg_new and $pkg ne __PACKAGE__) {
|
||||
my $my_new = __PACKAGE__ -> can ('new');
|
||||
if ($pkg_new == $my_new) {
|
||||
#
|
||||
# Prevent recursion
|
||||
#
|
||||
croak "$pkg must define either a TIEHASH() or a new() method";
|
||||
}
|
||||
|
||||
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;
|
||||
49
database/perl/lib/Tie/Hash/NamedCapture.pm
Normal file
49
database/perl/lib/Tie/Hash/NamedCapture.pm
Normal file
@@ -0,0 +1,49 @@
|
||||
use strict;
|
||||
package Tie::Hash::NamedCapture;
|
||||
|
||||
our $VERSION = "0.13";
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Tie::Hash::NamedCapture - Named regexp capture buffers
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
tie my %hash, "Tie::Hash::NamedCapture";
|
||||
# %hash now behaves like %+
|
||||
|
||||
tie my %hash, "Tie::Hash::NamedCapture", all => 1;
|
||||
# %hash now access buffers from regexp in $qr like %-
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This module is used to implement the special hashes C<%+> and C<%->, but it
|
||||
can be used to tie other variables as you choose.
|
||||
|
||||
When the C<all> parameter is provided, then the tied hash elements will be
|
||||
array refs listing the contents of each capture buffer whose name is the
|
||||
same as the associated hash key. If none of these buffers were involved in
|
||||
the match, the contents of that array ref will be as many C<undef> values
|
||||
as there are capture buffers with that name. In other words, the tied hash
|
||||
will behave as C<%->.
|
||||
|
||||
When the C<all> parameter is omitted or false, then the tied hash elements
|
||||
will be the contents of the leftmost defined buffer with the name of the
|
||||
associated hash key. In other words, the tied hash will behave as
|
||||
C<%+>.
|
||||
|
||||
The keys of C<%->-like hashes correspond to all buffer names found in the
|
||||
regular expression; the keys of C<%+>-like hashes list only the names of
|
||||
buffers that have captured (and that are thus associated to defined values).
|
||||
|
||||
This implementation has been moved into the core executable, but you
|
||||
can still load this module for backward compatibility.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<perlreapi>, L<re>, L<perlmodlib/Pragmatic Modules>, L<perlvar/"%+">,
|
||||
L<perlvar/"%-">.
|
||||
|
||||
=cut
|
||||
128
database/perl/lib/Tie/Memoize.pm
Normal file
128
database/perl/lib/Tie/Memoize.pm
Normal file
@@ -0,0 +1,128 @@
|
||||
use strict;
|
||||
package Tie::Memoize;
|
||||
use Tie::Hash;
|
||||
our @ISA = 'Tie::ExtraHash';
|
||||
our $VERSION = '1.1';
|
||||
|
||||
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]);
|
||||
$a->[1]{$key} = 0, return unless @res; # Cache non-existence
|
||||
# Now we know it exists
|
||||
return ($a->[1]{$key} = 1) if $a->[5]; # Only existence reported
|
||||
# Now know the value
|
||||
$a->[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@ilyaz.org>.
|
||||
|
||||
=cut
|
||||
|
||||
375
database/perl/lib/Tie/RefHash.pm
Normal file
375
database/perl/lib/Tie/RefHash.pm
Normal file
@@ -0,0 +1,375 @@
|
||||
package Tie::RefHash; # git description: Tie-RefHash-1.39-10-g2cfa4bd
|
||||
# ABSTRACT: Use references as hash keys
|
||||
|
||||
our $VERSION = '1.40';
|
||||
|
||||
#pod =head1 SYNOPSIS
|
||||
#pod
|
||||
#pod require 5.004;
|
||||
#pod use Tie::RefHash;
|
||||
#pod tie HASHVARIABLE, 'Tie::RefHash', LIST;
|
||||
#pod tie HASHVARIABLE, 'Tie::RefHash::Nestable', LIST;
|
||||
#pod
|
||||
#pod untie HASHVARIABLE;
|
||||
#pod
|
||||
#pod =head1 DESCRIPTION
|
||||
#pod
|
||||
#pod This module provides the ability to use references as hash keys if you
|
||||
#pod first C<tie> the hash variable to this module. Normally, only the
|
||||
#pod keys of the tied hash itself are preserved as references; to use
|
||||
#pod references as keys in hashes-of-hashes, use Tie::RefHash::Nestable,
|
||||
#pod included as part of Tie::RefHash.
|
||||
#pod
|
||||
#pod It is implemented using the standard perl TIEHASH interface. Please
|
||||
#pod see the C<tie> entry in perlfunc(1) and perltie(1) for more information.
|
||||
#pod
|
||||
#pod The Nestable version works by looking for hash references being stored
|
||||
#pod and converting them to tied hashes so that they too can have
|
||||
#pod references as keys. This will happen without warning whenever you
|
||||
#pod store a reference to one of your own hashes in the tied hash.
|
||||
#pod
|
||||
#pod =head1 EXAMPLE
|
||||
#pod
|
||||
#pod use Tie::RefHash;
|
||||
#pod tie %h, 'Tie::RefHash';
|
||||
#pod $a = [];
|
||||
#pod $b = {};
|
||||
#pod $c = \*main;
|
||||
#pod $d = \"gunk";
|
||||
#pod $e = sub { 'foo' };
|
||||
#pod %h = ($a => 1, $b => 2, $c => 3, $d => 4, $e => 5);
|
||||
#pod $a->[0] = 'foo';
|
||||
#pod $b->{foo} = 'bar';
|
||||
#pod for (keys %h) {
|
||||
#pod print ref($_), "\n";
|
||||
#pod }
|
||||
#pod
|
||||
#pod tie %h, 'Tie::RefHash::Nestable';
|
||||
#pod $h{$a}->{$b} = 1;
|
||||
#pod for (keys %h, keys %{$h{$a}}) {
|
||||
#pod print ref($_), "\n";
|
||||
#pod }
|
||||
#pod
|
||||
#pod =head1 THREAD SUPPORT
|
||||
#pod
|
||||
#pod L<Tie::RefHash> fully supports threading using the C<CLONE> method.
|
||||
#pod
|
||||
#pod =head1 STORABLE SUPPORT
|
||||
#pod
|
||||
#pod L<Storable> hooks are provided for semantically correct serialization and
|
||||
#pod cloning of tied refhashes.
|
||||
#pod
|
||||
#pod =head1 AUTHORS
|
||||
#pod
|
||||
#pod Gurusamy Sarathy <gsar@activestate.com>
|
||||
#pod
|
||||
#pod Tie::RefHash::Nestable by Ed Avis <ed@membled.com>
|
||||
#pod
|
||||
#pod =head1 SEE ALSO
|
||||
#pod
|
||||
#pod perl(1), perlfunc(1), perltie(1)
|
||||
#pod
|
||||
#pod =cut
|
||||
|
||||
use Tie::Hash;
|
||||
our @ISA = qw(Tie::Hash);
|
||||
use strict;
|
||||
use Carp ();
|
||||
|
||||
BEGIN {
|
||||
local $@;
|
||||
# determine whether we need to take care of threads
|
||||
use Config ();
|
||||
my $usethreads = $Config::Config{usethreads}; # && exists $INC{"threads.pm"}
|
||||
*_HAS_THREADS = $usethreads ? sub () { 1 } : sub () { 0 };
|
||||
*_HAS_SCALAR_UTIL = eval { require Scalar::Util; 1 } ? sub () { 1 } : sub () { 0 };
|
||||
*_HAS_WEAKEN = defined(&Scalar::Util::weaken) ? sub () { 1 } : sub () { 0 };
|
||||
}
|
||||
|
||||
BEGIN {
|
||||
# create a refaddr function
|
||||
|
||||
local $@;
|
||||
|
||||
if ( _HAS_SCALAR_UTIL ) {
|
||||
*refaddr = sub { goto \&Scalar::Util::refaddr }
|
||||
} else {
|
||||
require overload;
|
||||
|
||||
*refaddr = sub {
|
||||
if ( overload::StrVal($_[0]) =~ /\( 0x ([a-zA-Z0-9]+) \)$/x) {
|
||||
return $1;
|
||||
} else {
|
||||
die "couldn't parse StrVal: " . overload::StrVal($_[0]);
|
||||
}
|
||||
};
|
||||
}
|
||||
}
|
||||
|
||||
my (@thread_object_registry, $count); # used by the CLONE method to rehash the keys after their refaddr changed
|
||||
|
||||
sub TIEHASH {
|
||||
my $c = shift;
|
||||
my $s = [];
|
||||
bless $s, $c;
|
||||
while (@_) {
|
||||
$s->STORE(shift, shift);
|
||||
}
|
||||
|
||||
if (_HAS_THREADS ) {
|
||||
|
||||
if ( _HAS_WEAKEN ) {
|
||||
# remember the object so that we can rekey it on CLONE
|
||||
push @thread_object_registry, $s;
|
||||
# but make this a weak reference, so that there are no leaks
|
||||
Scalar::Util::weaken( $thread_object_registry[-1] );
|
||||
|
||||
if ( ++$count > 1000 ) {
|
||||
# this ensures we don't fill up with a huge array dead weakrefs
|
||||
@thread_object_registry = grep defined, @thread_object_registry;
|
||||
$count = 0;
|
||||
}
|
||||
} else {
|
||||
$count++; # used in the warning
|
||||
}
|
||||
}
|
||||
|
||||
return $s;
|
||||
}
|
||||
|
||||
my $storable_format_version = join("/", __PACKAGE__, "0.01");
|
||||
|
||||
sub STORABLE_freeze {
|
||||
my ( $self, $is_cloning ) = @_;
|
||||
my ( $refs, $reg ) = @$self;
|
||||
return ( $storable_format_version, [ values %$refs ], $reg || {} );
|
||||
}
|
||||
|
||||
sub STORABLE_thaw {
|
||||
my ( $self, $is_cloning, $version, $refs, $reg ) = @_;
|
||||
Carp::croak "incompatible versions of Tie::RefHash between freeze and thaw"
|
||||
unless $version eq $storable_format_version;
|
||||
|
||||
@$self = ( {}, $reg );
|
||||
$self->_reindex_keys( $refs );
|
||||
}
|
||||
|
||||
sub CLONE {
|
||||
my $pkg = shift;
|
||||
|
||||
if ( $count and not _HAS_WEAKEN ) {
|
||||
warn "Tie::RefHash is not threadsafe without Scalar::Util::weaken";
|
||||
}
|
||||
|
||||
# when the thread has been cloned all the objects need to be updated.
|
||||
# dead weakrefs are undefined, so we filter them out
|
||||
@thread_object_registry = grep defined && do { $_->_reindex_keys; 1 }, @thread_object_registry;
|
||||
$count = 0; # we just cleaned up
|
||||
}
|
||||
|
||||
sub _reindex_keys {
|
||||
my ( $self, $extra_keys ) = @_;
|
||||
# rehash all the ref keys based on their new StrVal
|
||||
%{ $self->[0] } = map +(Scalar::Util::refaddr($_->[0]) => $_), (values(%{ $self->[0] }), @{ $extra_keys || [] });
|
||||
}
|
||||
|
||||
sub FETCH {
|
||||
my($s, $k) = @_;
|
||||
if (ref $k) {
|
||||
my $kstr = Scalar::Util::refaddr($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]{Scalar::Util::refaddr($k)} = [$k, $v];
|
||||
}
|
||||
else {
|
||||
$s->[1]{$k} = $v;
|
||||
}
|
||||
$v;
|
||||
}
|
||||
|
||||
sub DELETE {
|
||||
my($s, $k) = @_;
|
||||
(ref $k)
|
||||
? (delete($s->[0]{Scalar::Util::refaddr($k)}) || [])->[1]
|
||||
: delete($s->[1]{$k});
|
||||
}
|
||||
|
||||
sub EXISTS {
|
||||
my($s, $k) = @_;
|
||||
(ref $k) ? exists($s->[0]{Scalar::Util::refaddr($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 # hide from PAUSE
|
||||
Tie::RefHash::Nestable;
|
||||
our @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;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Tie::RefHash - Use references as hash keys
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
version 1.40
|
||||
|
||||
=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 THREAD SUPPORT
|
||||
|
||||
L<Tie::RefHash> fully supports threading using the C<CLONE> method.
|
||||
|
||||
=head1 STORABLE SUPPORT
|
||||
|
||||
L<Storable> hooks are provided for semantically correct serialization and
|
||||
cloning of tied refhashes.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
perl(1), perlfunc(1), perltie(1)
|
||||
|
||||
=head1 SUPPORT
|
||||
|
||||
Bugs may be submitted through L<the RT bug tracker|https://rt.cpan.org/Public/Dist/Display.html?Name=Tie-RefHash>
|
||||
(or L<bug-Tie-RefHash@rt.cpan.org|mailto:bug-Tie-RefHash@rt.cpan.org>).
|
||||
|
||||
=head1 AUTHORS
|
||||
|
||||
Gurusamy Sarathy <gsar@activestate.com>
|
||||
|
||||
Tie::RefHash::Nestable by Ed Avis <ed@membled.com>
|
||||
|
||||
=head1 CONTRIBUTORS
|
||||
|
||||
=for stopwords Yuval Kogman Karen Etheridge Florian Ragwitz Jerry D. Hedden
|
||||
|
||||
=over 4
|
||||
|
||||
=item *
|
||||
|
||||
Yuval Kogman <nothingmuch@woobling.org>
|
||||
|
||||
=item *
|
||||
|
||||
Karen Etheridge <ether@cpan.org>
|
||||
|
||||
=item *
|
||||
|
||||
Florian Ragwitz <rafl@debian.org>
|
||||
|
||||
=item *
|
||||
|
||||
Jerry D. Hedden <jdhedden@cpan.org>
|
||||
|
||||
=back
|
||||
|
||||
=head1 COPYRIGHT AND LICENCE
|
||||
|
||||
This software is copyright (c) 2006 by יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org>.
|
||||
|
||||
This is free software; you can redistribute it and/or modify it under
|
||||
the same terms as the Perl 5 programming language system itself.
|
||||
|
||||
=cut
|
||||
164
database/perl/lib/Tie/Scalar.pm
Normal file
164
database/perl/lib/Tie/Scalar.pm
Normal file
@@ -0,0 +1,164 @@
|
||||
package Tie::Scalar;
|
||||
|
||||
our $VERSION = '1.05';
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Tie::Scalar, Tie::StdScalar - base class definitions for tied scalars
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
package NewScalar;
|
||||
require Tie::Scalar;
|
||||
|
||||
@ISA = qw(Tie::Scalar);
|
||||
|
||||
sub FETCH { ... } # Provide a needed method
|
||||
sub TIESCALAR { ... } # Overrides inherited method
|
||||
|
||||
|
||||
package NewStdScalar;
|
||||
require Tie::Scalar;
|
||||
|
||||
@ISA = qw(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
|
||||
|
||||
=head2 Tie::Scalar vs Tie::StdScalar
|
||||
|
||||
C<< Tie::Scalar >> provides all the necessary methods, but one should realize
|
||||
they do not do anything useful. Calling C<< Tie::Scalar::FETCH >> or
|
||||
C<< Tie::Scalar::STORE >> results in a (trappable) croak. And if you inherit
|
||||
from C<< Tie::Scalar >>, you I<must> provide either a C<< new >> or a
|
||||
C<< TIESCALAR >> method.
|
||||
|
||||
If you are looking for a class that does everything for you that you don't
|
||||
define yourself, use the C<< Tie::StdScalar >> class, not the
|
||||
C<< Tie::Scalar >> one.
|
||||
|
||||
=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;
|
||||
my $pkg_new = $pkg -> can ('new');
|
||||
|
||||
if ($pkg_new and $pkg ne __PACKAGE__) {
|
||||
my $my_new = __PACKAGE__ -> can ('new');
|
||||
if ($pkg_new == $my_new) {
|
||||
#
|
||||
# Prevent recursion
|
||||
#
|
||||
croak "$pkg must define either a TIESCALAR() or a new() method";
|
||||
}
|
||||
|
||||
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 = qw(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;
|
||||
71
database/perl/lib/Tie/StdHandle.pm
Normal file
71
database/perl/lib/Tie/StdHandle.pm
Normal file
@@ -0,0 +1,71 @@
|
||||
package Tie::StdHandle;
|
||||
|
||||
use strict;
|
||||
|
||||
use Tie::Handle;
|
||||
our @ISA = 'Tie::Handle';
|
||||
our $VERSION = '4.6';
|
||||
|
||||
=head1 NAME
|
||||
|
||||
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
|
||||
|
||||
The B<Tie::StdHandle> package provide most methods for file handles described
|
||||
in L<perltie> (the exceptions are C<UNTIE> and C<DESTROY>). It causes tied
|
||||
file handles to behave exactly like standard file handles and allow for
|
||||
selective overwriting of methods.
|
||||
|
||||
=cut
|
||||
|
||||
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 { &CORE::binmode(shift, @_) }
|
||||
|
||||
sub OPEN
|
||||
{
|
||||
$_[0]->CLOSE if defined($_[0]->FILENO);
|
||||
@_ == 2 ? open($_[0], $_[1]) : open($_[0], $_[1], $_[2]);
|
||||
}
|
||||
|
||||
sub READ { &CORE::read(shift, \shift, @_) }
|
||||
sub READLINE { my $fh = $_[0]; <$fh> }
|
||||
sub GETC { getc($_[0]) }
|
||||
|
||||
sub WRITE
|
||||
{
|
||||
my $fh = $_[0];
|
||||
local $\; # don't print any line terminator
|
||||
print $fh substr($_[1], $_[3], $_[2]);
|
||||
}
|
||||
|
||||
|
||||
1;
|
||||
215
database/perl/lib/Tie/SubstrHash.pm
Normal file
215
database/perl/lib/Tie/SubstrHash.pm
Normal file
@@ -0,0 +1,215 @@
|
||||
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;
|
||||
Reference in New Issue
Block a user