File Coverage

blib/lib/Petal/CodePerl/Expr/DerefTAL.pm

Criterion	Covered	Total	%
statement	32	37	86.4
branch	8	22	36.3
condition	2	6	33.3
subroutine	7	7	100.0
pod	0	2	0.0
total	49	74	66.2

use strict;
use warnings;

package Petal::CodePerl::Expr::DerefTAL;

use base qw( Code::Perl::Expr::Base );

use Class::MethodMaker (
	get_set => [qw( -java Key Ref Strict )]
);

use Scalar::Util qw(blessed reftype );

sub eval
{
	my $self = shift;

	my $ref = $self->getRef->eval;
	my $key = $self->getKey;

	ref($ref) || die "Not a ref";

	if ($self->getStrict)
	{
		return Scalar::Util::blessed($ref) ?
			$ref->$key() :
			reftype($ref) eq 'ARRAY' ? $ref->[$key] : $ref->{$key};
	}
	else
	{
		return Scalar::Util::blessed(\$ref) && (UNIVERSAL::can($ref, $key) or UNIVERSAL::can($ref, "AUTOLOAD")) ?
			$ref->$key() :
			reftype($ref) eq 'ARRAY' ? $ref->[$key] : $ref->{$key};
	}
}

sub perl
{
	my $self = shift;

	my $ref_perl = "(".$self->getRef->perl.")";
	my $key = $self->getKey;

	my $method = 0;
	my $number = 0;
	if ($key =~ /^[a-z_][a-z0-9_-]*/i)
	{
		$method = 1;
	}
	elsif($key =~ /^\d+$/)
	{
		$number = 1;
	}

	my $assign = qq{ref(my \$ref = $ref_perl) || die "Not a ref"};

	if (! $number and ! $method)
	{
		# it must be a hash key
		return qq{($ref_perl)->{"$key"}};
	}
	elsif($number)
	{
		# look like a number but could be a hash key
		return qq{do{$assign; Scalar::Util::reftype(\$ref) eq 'ARRAY' ? \$ref->[$key] : \$ref->{$key}}};
	}
	else
	{
		# looks like a method name but could be a hash key

		if($self->getStrict)
		{
			# strict mode means NEVER treat a blessed object as just a hash

			return qq{Scalar::Util::blessed(\$ref) ? \$ref->$key() : \$ref->{"$key"}};
		}
		else
		{
			# non-strict means check to see if the method exists, if not then fall
			# back to using hash

			return qq{do{$assign; Scalar::Util::blessed(\$ref) && (UNIVERSAL::can(\$ref, "$key") or UNIVERSAL::can(\$ref, "AUTOLOAD")) ? \$ref->$key() : \$ref->{"$key"}}};
		}
	}
}

1;