File Coverage

blib/lib/Data/LNPath.pm

Criterion	Covered	Total	%
statement	91	91	100.0
branch	56	56	100.0
condition	19	21	90.4
subroutine	9	9	100.0
pod	1	1	100.0
total	176	178	98.8

package Data::LNPath;

use 5.006;
use strict;
use warnings;
use Scalar::Util qw/blessed/;

our $VERSION = '1.02';

our (%ERROR, %METH, $caller);

BEGIN {
	%ERROR = (
		invalid_key => 'A miserable death %s - %s - %s',
		invalid_index => 'A slightly more miserable death %s - %s - %s',
		invalid_method => 'A horrible horrible miserable death %s - %s - %s',
		allow_meth_keys => 'jump from a high building',
	);
	%METH = (
		extract_path => sub {
			my ($follow, $end, $data, @path) = @_;

			if (scalar @path && !$end) {
				my ($key, $ref) = (shift @path, ref $data);
				$follow = sprintf "%s/%s", $follow, $key;
				if ($ref eq 'HASH') {
					$data = $data->{$key};
					$METH{error}->('invalid_key', $key, $follow) if ! defined $data;
				}
				elsif ( $ref eq 'ARRAY' ) {
					$data = $data->[$key - 1];
					$METH{error}->('invalid_index', $key, $follow) if ! defined $data;
				}
				elsif ( $ref && blessed $data ) {
					my ($meth, $params) = $METH{meth_params}->($key, $data);
					$data = scalar @{ $params || [] } ? $data->$meth(@{ $params }) : $data->$meth;
					$METH{error}->('invalid_method', $key, $follow) if ! defined $data;
				}
				else {
					$METH{error}->('invalid_path', $key, $follow) if (exists $ERROR{invalid_path});
					$end = 1;
				}
				return $METH{extract_path}->($follow, $end, $data, @path);
			}

			return $data;
		},
		unescape => sub {
			return '' unless defined $_[0];
			$_[0] =~ s/^\///g;
			$_[0] =~ s/\+/ /g;
			$_[0] =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
			return $_[0];
		},
		meth_params => sub {
			my ($key, $obj) = @_;
			my ($method, $args) = $key =~ /^(.*?)\((.*)\)$/;
			$args = $METH{generate_params}->($args, $obj) if $args;
			return ($method || $key, $args);
		},
		generate_params => sub {
			my ($string, $obj, @world, $current) = @_;
			foreach ( split /(?![^\(\[\{]+[\]\}\)]),/, $string ) {
				if ( $_ =~ m/^\s*\[\s*(.*)\]/ ) {
					$current = $METH{generate_params}->($1, $obj);
					push @world, $current;
				}
				elsif ( $_ =~ m/^\s*\{\s*(.*)\s*\}/ ) {
					$current = {};
					my %temp = split '=>', $1;
					do { $current->{$METH{generate_params}->(defined $ERROR{allow_meth_keys} ? sprintf("'%s'", $_) : ($_, $obj))->[0] } = $METH{generate_params}->($temp{$_}, $obj)->[0] } for keys %temp;
					push @world, $current;
				}
				elsif ( ($_ =~ m/^\s*(\d+)\s*$/) || ($_ =~ m/^\s*[\'\"]+\s*(.*?)\s*[\'\"]+\s*$/) ) {
					push @world, $1;
				}
				else {
					my $ex = $_ =~ s/^\s*\&//;
					my ($method, $args) = $_ =~ /^\s*(.*?)\((.*)\)$/;
					($method) = $_ =~ m/\s*(.*)\s*/ unless $method;
					$args = $args ? $METH{generate_params}->($args, $obj) : [];
					push @world, $ex ? do { no strict 'refs'; *{"${caller}::${method}"}->(@{ $args }); } : $obj->$method(@{ $args });
				}
			}
			return \@world;
		},
		error => sub {
			my ($error) = @_;
			my $find = $ERROR{$error};
			return ref $find eq 'CODE'
				? $find->(@_)
				: die sprintf $find, @_;
		}
	);
}

sub import {
	my ($pkg, $sub) = shift;
	return unless my @export = @_;
	my $opts = ref $export[scalar @export - 1] ? pop @export : {};
	$ERROR{no_error} = 1 if $opts->{return_undef};
	%ERROR = (%ERROR, %{ $opts->{errors} }) if $opts->{errors};
	@export = qw/lnpath/ if scalar @export == 1 && $export[0] eq 'all';
	$caller = scalar caller();
	{
		no strict 'refs';
		for ( @export ) {
			if ( $sub = $pkg->can($_) ? $_ : $opts->{as} && $opts->{as}->{$_} ) {
				*{"${caller}::${_}"} = \&{"${pkg}::${sub}"};
			}
		}
	}
}

sub lnpath {
	my ($data, $key) = @_;
	my $val = eval {
		$METH{extract_path}->('', 0, $data, split('/', $METH{unescape}->($key)))
	};
	if ($@ && !$ERROR{no_error}) {
		die $@;
	}
	return $val;
}

1;

__END__