summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl.straw/lib/Tie/RefHash.pm
diff options
context:
space:
mode:
Diffstat (limited to 'Master/tlpkg/tlperl.straw/lib/Tie/RefHash.pm')
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Tie/RefHash.pm274
1 files changed, 274 insertions, 0 deletions
diff --git a/Master/tlpkg/tlperl.straw/lib/Tie/RefHash.pm b/Master/tlpkg/tlperl.straw/lib/Tie/RefHash.pm
new file mode 100755
index 00000000000..f95bf41efdf
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Tie/RefHash.pm
@@ -0,0 +1,274 @@
+package Tie::RefHash;
+
+use vars qw/$VERSION/;
+
+$VERSION = "1.38";
+
+use 5.005;
+
+=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 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 RELIC SUPPORT
+
+This version of Tie::RefHash seems to no longer work with 5.004. This has not
+been throughly investigated. Patches welcome ;-)
+
+=head1 MAINTAINER
+
+Yuval Kogman E<lt>nothingmuch@woobling.orgE<gt>
+
+=head1 AUTHOR
+
+Gurusamy Sarathy gsar@activestate.com
+
+'Nestable' by Ed Avis ed@membled.com
+
+=head1 SEE ALSO
+
+perl(1), perlfunc(1), perltie(1)
+
+=cut
+
+use Tie::Hash;
+use vars '@ISA';
+@ISA = qw(Tie::Hash);
+use strict;
+use Carp qw/croak/;
+
+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 ) {
+ Scalar::Util->import("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 ) = @_;
+ 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 { refaddr($_->[0]) => $_ } (values(%{ $self->[0] }), @{ $extra_keys || [] });
+}
+
+sub FETCH {
+ my($s, $k) = @_;
+ if (ref $k) {
+ my $kstr = 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]{refaddr($k)} = [$k, $v];
+ }
+ else {
+ $s->[1]{$k} = $v;
+ }
+ $v;
+}
+
+sub DELETE {
+ my($s, $k) = @_;
+ (ref $k)
+ ? (delete($s->[0]{refaddr($k)}) || [])->[1]
+ : delete($s->[1]{$k});
+}
+
+sub EXISTS {
+ my($s, $k) = @_;
+ (ref $k) ? exists($s->[0]{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 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;