File Coverage

blib/lib/Tie/REHash.pm

Criterion	Covered	Total	%
statement	191	243	78.6
branch	138	284	48.5
condition	47	102	46.0
subroutine	22	23	95.6
pod	3	13	23.0
total	401	665	60.3

package Tie::REHash;

use 5.006;

use strict qw[vars subs];
$Tie::REHash::VERSION = '1.06';

no warnings;

sub CDUP () { 0 }
sub CMIS () { 1 }
sub CHIT () { 1 }
sub OFFSET () { 0 }
our (%Global_options, %AD);
our $qr_fragment = qr{(subcall[\w\d]+)(?:\(\))?};

$AD{croak} = 'use Carp;';

$AD{import} = <<'SUBCODE';
sub import {
	my $self = shift;
	%Global_options = ref $_[0] eq 'HASH' ? %{$_[0]} : @_;

	$Global_options{precompile}
	and $self->precompile;

	exists $Global_options{stringref_bug_is_fixed}
	and $self->stringref_bug_is_fixed;
}
SUBCODE

*tiehash = \&new;
*TIEHASH = \&new;
*STORE = \&store;
*FETCH = \&fetch;
*EXISTS = \&exists;
*DELETE = \&delete;
*FIRSTKEY = \&firstkey;
*NEXTKEY = \&nextkey;
*SCALAR = \&scalar;
*CLEAR = \&clear;

$AD{new} = <<'SUBCODE';
sub new {
	return $_[0]
	if ref $_[0];

	my $self = bless {}, $_[0];

	if (ref $_[1]) {
		$_[1] =~ /HASH/
		or croak("Wrong $_[1] argument to tie()");

		$self->{REGX} = [ $_[1] ];
		$self->{DELIM} = $_[2] if @_ == 3;
	}
	else {
		shift @_;

		$self->{DELIM} = pop @_
		if @_ - 2*int(@_/2);

		$self->{REGX} = [ {@_} ];
	}

	$self->{ESC} = {};

	$self->{DELIM} = $Global_options{autodelete_limit}
	if exists $Global_options{autodelete_limit};

	$self->{OFFSET2} = $Global_options{_offset2}
	if exists $Global_options{_offset2};

	$self->{REMOD}
	= exists $Global_options{remove_dups}
	? $Global_options{remove_dups}
	: 1;

	$self->{CACH}
	= ref $Global_options{do_cache} eq 'HASH'
	? $Global_options{do_cache} : {}
	if exists $Global_options{do_cache};

	$self->{CMIS2}
	= exists $Global_options{do_cache_miss}
	? $Global_options{do_cache_miss}
	: 1;

	$self->{CHIT2}
	= exists $Global_options{do_cache_hit}
	? $Global_options{do_cache_hit}
	: 1;

	return $self
}
SUBCODE

$AD{store} = <<'SUBCODE';
sub store {
	my $self = $_[0];

	$self->{IS_NORMALIZED} = undef;

	my $cach = $self->{CACH} if !CDUP;

	my ($k, $esc, $dyn);

	!ref $_[1] ? $k = $_[1]
	: do{
		($k, $esc, $dyn)
		= (ref $_[1] eq 'REF'
		or ref $_[1] eq 'SCALAR')
		? ref $_[2] eq 'CODE'
		? ( ${$_[1]}, undef, 1 )
		: ( ${$_[1]}, 1 )
		: ( $_[1] );

		if (ref $k eq 'Regexp') {
			$dyn
			? $self->{DYN2}{$k} = 1
			: delete $self->{DYN2}{$k};
			$esc
			? $self->{ESC2}{$k} = 1
			: delete $self->{ESC2}{$k};

			if (exists $self->{REGX2}{$k}) {
				my $regx = $self->{REGX};

				$k eq $regx->[$_]
				and splice(@$regx, $_, 1)
				foreach reverse 0..$#$regx;
			}

			my (@upfront, $element);
			while (@{$self->{REGX}}) {
				$element = $self->{REGX}[0];

				last
				if ref $element eq 'Regexp'
				or $self->{DELIM}
				and $self->{DELIM} <= keys %$element;

				shift @{$self->{REGX}};

				$_ =~ $k
				and delete $element->{$_}
				foreach keys %$element;

				push @upfront, $element;
			}
			unshift @{$self->{REGX}}, @upfront, $k;

			if (!CDUP and $cach) {
				$_ =~ $k
				and delete $cach->{$_}
				foreach keys %$cach;
			}

			return $self->{REGX2}{$k} = $esc ? undef : $_[2]
		}

		_examine($self)
		if @{$self->{REGX}} > 1;
	};

	!CDUP
	and $cach
	and delete $cach->{$k};

	$esc
	and @{$self->{REGX}} == 1
	and ref $self->{REGX}[0] eq 'HASH'
	and delete $self->{REGX}[0]{$k}
	, delete $self->{ESC}{$k}
	, delete $self->{DYN}{$k}
	, return undef;

	$dyn
	? $self->{DYN}{$k} = 1
	: delete $self->{DYN}{$k};
	$esc
	? $self->{ESC}{$k} = 1
	: delete $self->{ESC}{$k};

	my $offset;
	foreach (@{$self->{REGX}}) {
		last
		if ref $_ eq 'Regexp'
		and $k =~ $_;

		return $_->{$k} = $esc ? undef : $_[2]
		if ref $_ eq 'HASH';

		last if OFFSET
		and $self->{OFFSET2}
		and $self->{OFFSET2} <= ++$offset;
	}

	unshift @{$self->{REGX}}, {$k => $esc ? undef : $_[2] };

	return $esc ? undef : $_[2]
}
SUBCODE

$AD{subcall_match} = <<'SUBCODE';
SUBCODE
$AD{subcall_match2} = <<'SUBCODE';
	!$cach2
	? $self->{REGX2}{ $_}
	: ( CDUP
	? $self->{REGX}[0]{$k}
	: ${ $cach2->{$k}
	 = \$self->{REGX2}{ $_} } )
SUBCODE
$AD{subcall_match0} = <<'SUBCODE';
	!$cach2
	? undef
	: ( CDUP
	? $self->{REGX}[0]{$k}
	: $cach2->{$k} = undef
	, $self->{ESC}{$k} = 1 )[0]
SUBCODE

$AD{subcall_fetch} = <<'SUBCODE';
	($_ eq $cach ? ${$_->{$k}}
	 : $_->{$k})
SUBCODE
$AD{subcall_fetch2} = <<'SUBCODE';
	!$cach2
	? $_ eq $cach ? ${$_->{$k}}
	 : $_->{$k}
	: ( CDUP
	? $self->{REGX}[0]{$k}
	: ${ $cach2->{$k}
	 = \$_->{$k} } )
SUBCODE
$AD{subcall_fetch0} = <<'SUBCODE';
	!$cach2
	? undef
	: ( CDUP
	? $self->{REGX}[0]{$k}
	: $cach2->{$k}
	 = undef )
SUBCODE

$AD{fetch} = <<'SUBCODE';
sub fetch {
	my $self = $_[0];
	my $type = $_[2];

	my ($k, $esc);

	!ref $_[1] ? $k = $_[1]
	: do{
		($k, $esc)
		= (ref $_[1] eq 'REF'
		or ref $_[1] eq 'SCALAR')
		? ( ${$_[1]}, 1 )
		: ( $_[1] );

		if (ref $k eq 'Regexp') {
			return
			 exists $self->{ESC2}{$k}
			? undef
			: $type eq 'ex'
			? 1
			: exists $self->{DYN2}{$k} && !$esc
			? $type eq 'sr'
			? \$self->{REGX2}{$k}($self, $k, @_[2..$#_])
			: $self->{REGX2}{$k}($self, $k, @_[2..$#_])
			: $type eq 'sr'
			? \$self->{REGX2}{$k}
			: $self->{REGX2}{$k}
			if exists $self->{REGX2}{$k};

			return undef;
		}
	};

	my $cach = $self->{CACH};

	my $first_element2;
	ref ($first_element2 = $self->{REGX}[0]) eq 'HASH'
	or $first_element2 = undef ;
	foreach (CDUP || !$cach ? () : $cach, @{$self->{REGX}}) {
		my $cach2 = $cach
		if $_ ne $cach
		and $_ ne $first_element2;

		if (ref $_ eq 'Regexp') {
			next if $k !~ $_;

			if ( CHIT
			and $self->{CHIT2}
			) {
				CDUP
				and ref $self->{REGX}[0] eq 'HASH'
				|| unshift @{$self->{REGX}}, {};

				return
				 exists $self->{ESC2}{$_}
				? subcall_match0()
				: $type eq 'ex'
				? 1
				: exists $self->{DYN2}{$_} && !$esc
				? $type eq 'sr'
				? \(subcall_match2()->($self, $k, @_[2..$#_]))
				: subcall_match2()->($self, $k, @_[2..$#_])
				: $type eq 'sr'
				? \(subcall_match2())
				: subcall_match2();
			}
			else {
				return
				 exists $self->{ESC2}{$_}
				? undef
				: $type eq 'ex'
				? 1
				: exists $self->{DYN2}{$_} && !$esc
				? $type eq 'sr'
				? \$self->{REGX2}{ $_}($self, $k, @_[2..$#_])
				: $self->{REGX2}{ $_}($self, $k, @_[2..$#_])
				: $type eq 'sr'
				? \$self->{REGX2}{ $_}
				: $self->{REGX2}{ $_};
			}
		}
		else {
			next if !exists $_->{$k};

			if ( CHIT
			and $self->{CHIT2}
			) {
				CDUP
				and ref $self->{REGX}[0] eq 'HASH'
				|| unshift @{$self->{REGX}}, {};

				return
				 exists $self->{ESC}{$k}
				? subcall_fetch0()
				: $type eq 'ex'
				? 1
				: exists $self->{DYN}{$k} && !$esc
				? $type eq 'sr'
				? \(subcall_fetch2()->($self, $k, @_[2..$#_]))
				: subcall_fetch2()->($self, $k, @_[2..$#_])
				: $type eq 'sr'
				? \(subcall_fetch2())
				: subcall_fetch2();
			}
			else {
				return
				 exists $self->{ESC}{$k}
				? undef
				: $type eq 'ex'
				? 1
				: exists $self->{DYN}{$k} && !$esc
				? $type eq 'sr'
				? \(subcall_fetch()->($self, $k, @_[2..$#_]))
				: subcall_fetch()->($self, $k, @_[2..$#_])
				: $type eq 'sr'
				? \subcall_fetch()
				: subcall_fetch();

			}
		}
	}

	!CDUP
	? ( $cach
	 and $self->{ESC}{$k} = 1
	 and $cach->{$k} = undef )
	: ( ref $self->{REGX}[0] eq 'HASH'
	? $self->{REGX}[0]{$k} = undef
	: unshift(@{$self->{REGX}}, {$k => undef})
	, $self->{ESC}{$k} = 1 )
	if CMIS
	and $self->{CMIS2}
	and $self->{CMIS2} < @{$self->{REGX}};

	return undef
}
SUBCODE

$AD{_examine} = <<'SUBCODE';
sub _examine {
	my $self = $_[0];

	my $element;
	while (1) {
		last
		unless
		exists $self->{ESC2}{$element =
		 $self->{REGX}[-1]};

		pop @{$self->{REGX}};
		delete $self->{REGX2}{ $element};
		delete $self->{ESC2}{$element};
		delete $self->{DYN2}{$element};
	}
}
SUBCODE

$AD{exists} = <<'SUBCODE';
sub exists {
	$_[2] = 'ex';
	goto &FETCH
}
SUBCODE

$AD{delete} = <<'SUBCODE';
sub delete {
	my ($k, $esc, $dyn);

	!ref $_[1] ? $k = $_[1]
	: do{
		($k, $esc, $dyn)
		= (ref $_[1] eq 'REF'
		or ref $_[1] eq 'SCALAR')
		? ref $_[2] eq 'CODE'
		? ( ${$_[1]}, undef, 1 )
		: ( ${$_[1]}, 1 )
		: ( $_[1] );

		if (ref $k eq 'Regexp') {
			return( ( $_[0]->FETCH( $k)
			 , $_[0]->STORE(\$k) )[0] )
		}
	};

	return undef
	unless my $value = $_[0]->FETCH( $k, 'sr');
	$value = $$value;
	$_[0]->STORE(\$k);
	return $value
}
SUBCODE

$AD{normalize} = <<'SUBCODE';
sub normalize {
	my $self = $_[0];

	my ($element, $element2);

	my $regx = \@{$self->{REGX}};
	my $esc = \%{$self->{ESC}};
	my $esc2 = \%{$self->{ESC2}};
	my $regx2 = \%{$self->{REGX2}};

	my $rem_esc_2;
	my $rem_all_2;
	my $rem_2 = $self->{REMOD};
	 $rem_2 == 3
	? $rem_all_2 = 1
	: $rem_2 == 2
	? $rem_esc_2 = 1
	: $rem_2 && !($self)->SCALAR()
	? $rem_esc_2 = 1
	: ();

	foreach $element2 (@$regx) {
		next unless ref $element2 eq 'HASH';

		foreach my $k (keys %$element2) {
			my $in_over;
			if ($rem_all_2
			or $rem_esc_2 and my $esc_key = $esc->{$k}
			) {
				my $over_element2;
				my $element2_k_is_2;
				foreach $element (@$regx) {
					$in_over
					and ref $element eq 'HASH'
					? delete $element->{$k}
					:( !defined $element2_k_is_2
					and $over_element2
					and exists $element2->{$k}
					and $k =~ $element
					and $element2_k_is_2
					= $esc_key
					? exists $esc2->{$element} ? 1 : 0
					: $element2->{$k} eq $regx2->{$element} )
					, next;

					$over_element2 = 1 if $element eq $element2;

					$in_over = 1
					if ref $element eq 'Regexp'
					? $k =~ $element
					: $over_element2;
				}

				!defined $element2_k_is_2
				and $esc_key
				and exists $element2->{$k}
				and $element2_k_is_2 = 1;

				delete $element2->{$k}
				if $element2_k_is_2;
			}
			else {
				foreach $element (@$regx) {
					$in_over
					and ( ref $element eq 'HASH'
					and delete $element->{$k} )
					, next;

					$in_over = 1
					if ref $element eq 'Regexp'
					? $k =~ $element
					: $element eq $element2;
				}
			}

		}
	}

	@$regx = (
		{ map ref $_ eq 'HASH' ? %$_ : (), @$regx },
		( map ref $_ ne 'HASH' ? $_ : (), @$regx ),
	);

	_examine($self)
	if @$regx > 1;

	$self->{IS_NORMALIZED} = 1;
}
SUBCODE

$AD{firstkey} = <<'SUBCODE';
sub firstkey {
	my $self = $_[0];

	($self)->normalize unless $self->{IS_NORMALIZED};

	$self->{EACH} = [	0, [reverse @{$self->{REGX}}] ];

	return( ($self)->NEXTKEY)
}
SUBCODE

$AD{nextkey} = <<'SUBCODE';
sub nextkey {
	my $self = $_[0];

	return( ($self)->firstkey)
	if !$self->{EACH};

	NEXT: {

	delete $self->{EACH}
	, return wantarray ? () : undef
	if $#{$self->{EACH}[1]}
	< $self->{EACH}[0];

	my $element = $self->{EACH}[1]->[$self->{EACH}[0]];

	if (ref $element eq 'Regexp') {
		++$self->{EACH}[0];

		return( ( exists $self->{DYN2}{$element}
		 || exists $self->{ESC2}{$element} ? \$element : $element
		, wantarray ? $self->{REGX2}{ $element} : ()
		)[0, wantarray ? 1 : ()] )
	}
	else {
		my ($k, $value);
		wantarray ? ($k, $value) = each %$element
		: ($k = each %$element);

		++$self->{EACH}[0]
		, redo NEXT
		if !defined $k;

		return(	( exists $self->{DYN}{$k}
		 || exists $self->{ESC}{$k} ? \$k : $k
		, wantarray ? $value : ()
		)[0, wantarray ? 1 : ()] )
	}

	}

}
SUBCODE

$AD{keys} = <<'SUBCODE';
sub keys {
	(my $self, my $as_arrayref) = @_;

	($self)->normalize unless $self->{IS_NORMALIZED};

	my (@list, $count);

	if (wantarray or $as_arrayref) {
		my $element;
		foreach $element (reverse @{$self->{REGX}}) {
			if (ref $element eq 'Regexp') {
				push @list
				, exists $self->{DYN2}{$element}
				|| exists $self->{ESC2}{$element} ? \$element : $element;
			}
			else {
				push @list
				, map exists $self->{DYN}{$_}
				 || exists $self->{ESC}{$_} ? \$_ : $_
				, keys %$element;
			}
		}
	}
	else {
		ref $_ eq 'Regexp' ? $count++ : ($count += keys %$_)
		foreach @{$self->{REGX}};
	}

	wantarray ? @list : $as_arrayref ? \@list : $count
}
SUBCODE

$AD{values} = <<'SUBCODE';
sub values {
	(my $self, my $as_arrayref) = @_;

	($self)->normalize unless $self->{IS_NORMALIZED};

	my (@list, $count);

	if (wantarray or $as_arrayref) {
		my $element;
		foreach $element (reverse @{$self->{REGX}}) {
			if (ref $element eq 'Regexp') {
				push @list, $self->{REGX2}{$element};
			}
			else {
				push @list, values %$element;
			}
		}
	}
	else {
		ref $_ eq 'Regexp' ? $count++ : ($count += keys %$_)
		foreach @{$self->{REGX}};
	}

	wantarray ? @list : $as_arrayref ? \@list : $count
}
SUBCODE

$AD{list} = <<'SUBCODE';
sub list {
	my $as_arrayref = $_[1];

	my $ks = $_[0]->keys( 'as_arrayref');
	my $values = $_[0]->values('as_arrayref');
	my @list = map +($ks->[$_], $values->[$_]), 0..$#$ks;

	wantarray ? @list : $as_arrayref ? \@list : @list
}
SUBCODE

$AD{scalar} = <<'SUBCODE';
sub scalar {
	my $self = $_[0];

	return scalar %{$self->{REGX}[0]}
	if @{$self->{REGX}} == 1
	and ref $self->{REGX}[0] eq 'HASH'
	and !%{$self->{ESC}};

	ref $_ eq 'Regexp'
	and !exists $self->{ESC2}{$_}
	and return 1
	foreach @{$self->{REGX}};

	my $cach = $self->{CACH} if !CDUP;

	my ($element, $element2, $k);
	foreach $element2 ($cach||(), @{$self->{REGX}}) {
		next if ref $element2 eq 'Regexp';

		KEY: foreach $k (keys %$element2) {
			next if exists $self->{ESC}{$k};

			foreach $element ($cach||(), @{$self->{REGX}}) {
				$element eq $element2
				and return 1;

				ref $element eq 'Regexp'
				? $k =~ $element
					? !exists $self->{ESC2}{$element}
						? return 1
						: next KEY
					: next
				: exists $element->{$k}
					? !exists $self->{ESC}{$k}
						? return 1
						: next KEY
					: next;
			}

			return 1
		}
	}

	return 0
}
SUBCODE

$AD{clear} = <<'SUBCODE';
sub clear {
	my $self = $_[0];

	@{$self->{REGX}} = ();
	%{$self->{ESC}} = ();
	%{$self->{DYN}} = ();
	%{$self->{ESC2}} = ();
	%{$self->{DYN2}} = ();
	%{$self->{REGX2}} = ();
	%{$self->{CACH}} = () if $self->{CACH};
}
SUBCODE

sub DESTROY {
	%{$_[0]} = ();
}

*storable = \&freeze;
$AD{freeze} = <<'SUBCODE';
sub freeze {
	my $what = $_[1];
	my $selffreeze = ( $what =~ /self/i );
	my $self = $selffreeze ? $_[0] : {%{$_[0]}};
	if (!$selffreeze) {
		$self->{REGX} = [@{$self->{REGX}}];
		$self->{REGX2} = {%{$self->{REGX2}}};
		$self->{ESC2} = {%{$self->{ESC2}}};
		$self->{DYN2} = {%{$self->{DYN2}}};

		bless $self, ref($_[0])||$_[0]
		if $what =~ /clone/i;
	}

	my ($wraps_removed, $old);
	ref $_ eq 'Regexp'
	and $old = $_ , $_ = "$_"
	#,( $wraps_removed = ($_ =~ s/(\(\?[a-z\-]+:)(?=\1)//g)
	,( $wraps_removed = ($_ =~ s/(\(\?(?:\^|[a-z\-]+):)(?=\1)//g) # perl 5.14 switches to (?^:) wrap
	 and $_ =~ s/\){$wraps_removed}$// )
	,( exists $self->{REGX2}{$old}
	 and $self->{REGX2}{$_}
	 = delete $self->{REGX2}{$old} )
	,( exists $self->{ESC2}{$old}
	 and $self->{ESC2}{$_}
	 = delete $self->{ESC2}{$old} )
	,( exists $self->{DYN2}{$old}
	 and $self->{DYN2}{$_}
	 = delete $self->{DYN2}{$old} )
	foreach @{$self->{REGX}};

	return $self
}
SUBCODE

*thaw = \&unfreeze;
*restore = \&unfreeze;
$AD{unfreeze} = <<'SUBCODE';
sub unfreeze {
	my $do_not_bless = $_[2];
	my $self = ref $_[1] ? $_[1] : ref $_[0] ? $_[0] : return undef;

	bless $self, ref($_[0])||$_[0]
	unless $self =~ /=/
	or $do_not_bless;

	my $old;
	!ref $_
	and $old = $_ , $_ = qr{$_}
	,( exists $self->{REGX2}{$old}
	 and $self->{REGX2}{$_}
	 = delete $self->{REGX2}{$old} )
	,( exists $self->{ESC2}{$old}
	 and $self->{ESC2}{$_}
	 = delete $self->{ESC2}{$old} )
	,( exists $self->{DYN2}{$old}
	 and $self->{DYN2}{$_}
	 = delete $self->{DYN2}{$old} )
	foreach @{$self->{REGX}};

	return $self
}
SUBCODE

$AD{STORABLE_freeze} = <<'SUBCODE';
sub STORABLE_freeze {
	return (undef, $_[0]->freeze)
}
SUBCODE

$AD{STORABLE_thaw} = <<'SUBCODE';
sub STORABLE_thaw {
	my $self = $_[3];
 $_[0]->unfreeze($self);
 %{$_[0]} = %$self;
}
SUBCODE

$AD{autodelete_limit} = <<'SUBCODE';
sub autodelete_limit {
	my $self = $_[0];

	return $self->{DELIM} = $_[1] if @_ > 1;
	return $self->{DELIM}
}
SUBCODE

$AD{_offset2} = <<'SUBCODE';
sub _offset2 {
	my $self = $_[0];

	return $self->{OFFSET2} = $_[1] if @_ > 1;
	return $self->{OFFSET2}
}
SUBCODE

$AD{do_cache} = <<'SUBCODE';
sub do_cache {
	my $self = $_[0];

	return $self->{CACH} ||= ref $_[1] eq 'HASH' ? $_[1] : {} if $_[1];
	return delete $self->{CACH}
}
SUBCODE

$AD{do_cache_miss} = <<'SUBCODE';
sub do_cache_miss {
	my $self = $_[0];

	return $self->{CMIS2} = $_[1] if @_ > 1;
	return $self->{CMIS2}
}
SUBCODE

$AD{do_cache_hit} = <<'SUBCODE';
sub do_cache_hit {
	my $self = $_[0];

	return $self->{CHIT2} = $_[1] if @_ > 1;
	return $self->{CHIT2}
}
SUBCODE

$AD{flush_cache} = <<'SUBCODE';
sub flush_cache {
	 my $self = $_[0];

	%{ $self->{CACH}} = ()
	if $self->{CACH};
}
SUBCODE

$AD{remove_dups} = <<'SUBCODE';
sub remove_dups {
	my $self = $_[0];

	return $self->{REMOD} = $_[1] if @_ > 1;
	return $self->{REMOD}
}
SUBCODE

$AD{die_on_stringref_bug} = $AD{stringref_bug_is_fixed} = <<'SUBCODE';
sub die_on_stringref_bug {
	my $bugtxt = 'Due to bug (rt.perl.org ticket 79178) in your instance of perl, storing/fetching to/from the rehash should avoid escaped literal keys (as well as stringified scalarref keys), like $hash{\"foo"} (or in one statement: $regx2{$k = \"foo"}), or fatal error will result. The workaround: $k = \"foo"; $hash{$k}.';
	#warn("BUG WARNING: $bugtxt");

	*FETCH2 = \&FETCH;
	*STORE2 = \&STORE;

	my $qr_scalaref = qr{^SCALAR\(0x[\dabcdef]+\)$};
	my $errmess = "Tie::REHash: Aborting due to Perl bug - escaped literal (or stringified scalarref) key has been used. $bugtxt";

	*FETCH = sub{
		!ref $_[1]
		and $_[1] =~ $qr_scalaref
		and croak($errmess);

		goto &FETCH2;
	};
	*STORE = sub{
		!ref $_[1]
		and $_[1] =~ $qr_scalaref
		and croak($errmess);

		goto &STORE2;
	};
}

sub stringref_bug_is_fixed {
	*FETCH = \&FETCH2;
	*STORE = \&STORE2;
}
SUBCODE

$AD{precompile} = <<'SUBCODE';
sub precompile {
	foreach (keys %AD) {
		next
		if $_ =~ $qr_fragment;
		 $AD{$_} =~ s/$qr_fragment/($AD{$1})/g;
		eval $AD{$_};
		!$@ or croak( "Compilation error: $@ in code: $AD{$_}")
	}

	return 1
}
SUBCODE

eval join '', map "sub $_;", keys %AD;

sub is_precompiled { 0 }
$AD{is_precompiled} = <<'SUBCODE';
sub is_precompiled { 1 }
SUBCODE

sub AUTOLOAD {
	my $code = \( $AD{$Tie::REHash::AUTOLOAD}
	 || scalar( $Tie::REHash::AUTOLOAD =~ /::(\w+)$/, $AD{$1} ) );
	eval{ $$code =~ s/$qr_fragment/($AD{$1})/g; };
	eval $$code;
	!$@ or die("$@ evaluating $$code");

	goto &$Tie::REHash::AUTOLOAD
	if defined &$Tie::REHash::AUTOLOAD;
}

{
	package Tie::REHash::StringrefBug;
	sub TIEHASH { bless {}, $_[0] }
	sub STORE { ref $_[1] }
	sub FETCH { ref $_[1] }
}
tie my %detector, 'Tie::REHash::StringrefBug';
( $detector{\'foo'} = 1 ) eq 'SCALAR'
and $detector{\'foo'} eq 'SCALAR'
#$] >= 5.012
or die_on_stringref_bug();

1

__END__