File Coverage

blib/lib/Data/LNPath.pm
Criterion Covered Total %
statement 90 90 100.0
branch 50 50 100.0
condition 18 18 100.0
subroutine 9 9 100.0
pod 1 1 100.0
total 168 168 100.0


line stmt bran cond sub pod time code
1             package Data::LNPath;
2              
3 8     8   499557 use 5.006;
  8         86  
4 8     8   37 use strict;
  8         14  
  8         193  
5 8     8   39 use warnings;
  8         11  
  8         225  
6 8     8   47 use Scalar::Util qw/blessed/;
  8         11  
  8         7078  
7              
8             our $VERSION = '1.00';
9              
10             our (%ERROR, %METH, $caller);
11              
12             BEGIN {
13 8     8   59 %ERROR = (
14             invalid_key => 'A miserable death %s - %s - %s',
15             invalid_index => 'A slightly more miserable death %s - %s - %s',
16             invalid_method => 'A horrible horrible miserable death %s - %s - %s',
17             allow_meth_keys => 'jump from a high building',
18             );
19             %METH = (
20             extract_path => sub {
21 120         238 my ($follow, $end, $data, @path) = @_;
22              
23 120 100 100     342 if (scalar @path && !$end) {
24 85         183 my ($key, $ref) = (shift @path, ref $data);
25 85         208 $follow = sprintf "%s/%s", $follow, $key;
26 85 100 100     259 if ($ref eq 'HASH') {
    100          
    100          
27 54         72 $data = $data->{$key};
28 54 100       130 $METH{error}->('invalid_key', $key, $follow) if ! defined $data;
29             }
30             elsif ( $ref eq 'ARRAY' ) {
31 6         16 $data = $data->[$key - 1];
32 6 100       18 $METH{error}->('invalid_index', $key, $follow) if ! defined $data;
33             }
34             elsif ( $ref && blessed $data ) {
35 22         44 my ($meth, $params) = $METH{meth_params}->($key, $data);
36 21         30 $data = $data->$meth(@{ $params });
  21         62  
37 21 100       126 $METH{error}->('invalid_method', $key, $follow) if ! defined $data;
38             }
39             else {
40 3 100       14 $METH{error}->('invalid_path', $key, $follow) if (exists $ERROR{invalid_path});
41 2         3 $end = 1;
42             }
43 79         178 return $METH{extract_path}->($follow, $end, $data, @path);
44             }
45              
46 35         104 return $data;
47             },
48             unescape => sub {
49 46 100       193 return '' unless defined $_[0];
50 45         110 $_[0] =~ s/^\///g;
51 45         79 $_[0] =~ s/\+/ /g;
52 45         70 $_[0] =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
  2         14  
53 45         170 return $_[0];
54             },
55             meth_params => sub {
56 22         36 my ($key, $obj) = @_;
57 22         128 my ($method, $args) = $key =~ /^(.*?)\((.*)\)$/;
58 22         47 $args = $METH{generate_params}->($args, $obj);
59 21         49 return ($method, $args);
60             },
61             generate_params => sub {
62 42         78 my ($string, $obj, @world, $current) = @_;
63 42         121 foreach ( split /(?![^\(\[\{]+[\]\}\)]),/, $string ) {
64 57 100 100     296 if ( $_ =~ m/^\s*\[\s*(.*)\]/ ) {
    100          
    100          
65 6         12 $current = $METH{generate_params}->($1, $obj);
66 6         11 push @world, $current;
67             }
68             elsif ( $_ =~ m/^\s*\{\s*(.*)\s*\}/ ) {
69 5         9 $current = {};
70 5         22 my %temp = split '=>', $1;
71 5 100       17 do { $current->{$METH{generate_params}->(defined $ERROR{allow_meth_keys} ? sprintf("'%s'", $_) : ($_, $obj))->[0] } = $METH{generate_params}->($temp{$_}, $obj)->[0] } for keys %temp;
  5         17  
72 4         10 push @world, $current;
73             }
74             elsif ( ($_ =~ m/^\s*(\d+)\s*$/) || ($_ =~ m/^\s*[\'\"]+\s*(.*?)\s*[\'\"]+\s*$/) ) {
75 33         83 push @world, $1;
76             }
77             else {
78 13         36 my $ex = $_ =~ s/^\s*\&//;
79 13         33 my ($method, $args) = $_ =~ /^\s*(.*?)\((.*)\)$/;
80 13 100       37 ($method) = $_ =~ m/\s*(.*)\s*/ unless $method;
81 13 100       37 $args = $args ? $METH{generate_params}->($args, $obj) : [];
82 8 100   8   62 push @world, $ex ? do { no strict 'refs'; *{"${caller}::${method}"}->(@{ $args }); } : $obj->$method(@{ $args });
  8         12  
  8         1547  
  13         24  
  6         8  
  6         26  
  6         8  
  7         48  
83             }
84             }
85 40         131 return \@world;
86             },
87             error => sub {
88 5         12 my ($error) = @_;
89 5         12 my $find = $ERROR{$error};
90 5 100       52 return ref $find eq 'CODE'
91             ? $find->(@_)
92             : die sprintf $find, @_;
93             }
94 8         1084 );
95             }
96              
97             sub import {
98 10     10   105 my ($pkg, $sub) = shift;
99 10 100       1538 return unless my @export = @_;
100 8 100       33 my $opts = ref $export[scalar @export - 1] ? pop @export : {};
101 8 100       33 $ERROR{no_error} = 1 if $opts->{return_undef};
102 8 100       27 %ERROR = (%ERROR, %{ $opts->{errors} }) if $opts->{errors};
  3         17  
103 8 100 100     46 @export = qw/lnpath/ if scalar @export == 1 && $export[0] eq 'all';
104 8         18 $caller = scalar caller();
105             {
106 8     8   53 no strict 'refs';
  8         14  
  8         1908  
  8         11  
107 8         15 for ( @export ) {
108 9 100 100     1447 if ( $sub = $pkg->can($_) ? $_ : $opts->{as} && $opts->{as}->{$_} ) {
    100          
109 6         10 *{"${caller}::${_}"} = \&{"${pkg}::${sub}"};
  6         5290  
  6         20  
110             }
111             }
112             }
113             }
114              
115             sub lnpath {
116 41     41 1 1187 my ($data, $key) = @_;
117 41         88 my $val = eval {
118 41         100 $METH{extract_path}->('', 0, $data, split('/', $METH{unescape}->($key)))
119             };
120 41 100 100     123 if ($@ && !$ERROR{no_error}) {
121 4         30 die $@;
122             }
123 37         133 return $val;
124             }
125              
126             1;
127              
128             __END__