File Coverage

blib/lib/DTL/Fast/Context.pm
Criterion Covered Total %
statement 74 77 96.1
branch 25 28 89.2
condition 17 34 50.0
subroutine 12 12 100.0
pod 0 8 0.0
total 128 159 80.5


line stmt bran cond sub pod time code
1             package DTL::Fast::Context;
2 99     99   394911 use strict; use utf8; use warnings FATAL => 'all';
  99     99   189  
  99     99   2604  
  99         2030  
  99         184  
  99         630  
  99         2422  
  99         236  
  99         4205  
3              
4 99     99   494 use Scalar::Util qw(reftype blessed);
  99         165  
  99         116731  
5              
6             sub new
7             {
8 617     617 0 233643 my( $proto, $context ) = @_;
9 617   100     1838 $context //= {};
10              
11 617 50       2030 die "Context should be a HASH reference"
12             if ref $context ne 'HASH';
13              
14 617         3308 return bless {
15             'ns' => [$context]
16             }, $proto;
17             }
18              
19             sub get
20             {
21 1263     1263 0 6259 my( $self, $variable_path, $source_object ) = @_;
22              
23 1263 100       2456 if( ref $variable_path ne 'ARRAY' ) # suppose that raw variable invoked, period separated
24             {
25 1010         2770 $variable_path = [split /\.+/x, $variable_path];
26             }
27             else
28             {
29 253         637 $variable_path = [@$variable_path]; # cloning for re-use
30             }
31              
32 1263         2199 my $variable_name = shift @$variable_path;
33              
34             # faster version
35 1263         2058 my $namespace = $self->{'ns'}->[-1];
36             my $variable = exists $namespace->{$variable_name} ?
37 1263 100       2986 $namespace->{$variable_name}
38             : undef;
39              
40 1263         2880 while( ref $variable eq 'CODE' )
41             {
42 0         0 $variable = $variable->();
43             }
44              
45 1263 100 100     4342 $variable = $self->traverse($variable, $variable_path, $source_object)
46             if
47             defined $variable
48             and scalar @$variable_path;
49              
50 1259         3558 return $variable;
51             }
52              
53             # tracing variable path
54             sub traverse
55             {
56 284     284 0 447 my( $self, $variable, $path, $source_object ) = @_;
57              
58 284         382 my $variable_original = $variable;
59            
60 284         457 foreach my $step (@$path)
61             {
62 339         892 my $current_type = reftype $variable;
63 339 100 66     2270 if(
    100 66        
    100          
    100          
64             blessed($variable)
65             and $variable->can($step) )
66             {
67 3         13 $variable = $variable->$step();
68             }
69             elsif( not defined $current_type )
70             {
71 2   50     24 die $self->get_error(
72             $source_object
73             , sprintf( "non-reference value encountered on step `%s` while traversing context path", $step // 'undef' )
74             , 'Traversing path' => join( '.', @$path )
75             , 'Traversed variable' => $self->dump_with_indent($variable_original)
76             );
77             }
78             elsif( $current_type eq 'HASH' )
79             {
80 214         491 $variable = $variable->{$step};
81             }
82             elsif(
83             $current_type eq 'ARRAY'
84             and $step =~ /^\-?\d+$/x
85             )
86             {
87 118         346 $variable = $variable->[$step];
88             }
89             else
90             {
91 2   50     24 die $self->get_error(
      50        
      50        
92             $source_object
93             , sprintf(
94             "don't know how continue traversing %s (%s) with step `%s`"
95             , ref $variable || 'SCALAR'
96             , reftype $variable // 'not blessed'
97             , $step // 'undef'
98             )
99             , 'Traversing path' => join( '.', @$path )
100             , 'Traversable variable' => $self->dump_with_indent($variable_original)
101             );
102             }
103             }
104              
105 280         699 while( ref $variable eq 'CODE' )
106             {
107 4         13 $variable = $variable->();
108             }
109              
110 280         681 return $variable;
111             }
112              
113             sub dump_with_indent
114             {
115 4     4 0 8 my ($self, $object ) = @_;
116 4         21 require Data::Dumper;
117 4         21 my $result = Data::Dumper->Dump([$object]);
118             # $result =~ s/^/ /mg; # now done in Entity::compile_error_messages
119 4         294 return $result;
120             }
121              
122             sub set
123             {
124 1501     1501 0 565011 my( $self, @sets ) = @_;
125              
126 1501         4406 while( scalar @sets > 1 )
127             {
128 2486         4291 my $key = shift @sets;
129 2486         3907 my $val = shift @sets;
130 2486 100       6417 if( $key =~ /\./x ) # traversed set
131             {
132 4         21 my @key = split /\.+/x, $key;
133 4         8 my $variable_name = pop @key;
134 4         16 my $variable = $self->get([@key]);
135              
136 4 100 50     25 die sprintf('Unable to set variable %s because parent %s is not defined.'
      50        
137             , $key // 'undef'
138             , join('.', @key) // 'undef'
139             ) if not defined $variable;
140              
141 3         7 my $variable_type = ref $variable;
142 3 100 33     19 if( $variable_type eq 'HASH' )
    50          
143             {
144 1         5 $variable->{$variable_name} = $val;
145             }
146             elsif(
147             $variable_type eq 'ARRAY'
148             and $variable_name =~ /^\-?\d+$/x
149             )
150             {
151 2         10 $variable->[$variable_name] = $val;
152             }
153             else
154             {
155 0   0     0 die sprintf("Don't know how to set variable %s for parent node of type %s"
      0        
156             , $variable_name // 'undef'
157             , $variable_type // 'undef'
158             );
159             }
160             }
161             else
162             {
163 2482         9264 $self->{'ns'}->[-1]->{$key} = $val;
164             }
165             }
166 1500         3263 return $self;
167             }
168              
169             sub get_error
170             {
171 4     4 0 11 my ($self, $source_object, $message, @messages) = @_;
172            
173 4         5 my $result;
174 4 50 33     39 if (
175             blessed $source_object
176             and $source_object->can('get_render_error')
177             ){
178 4         14 $result = $source_object->get_render_error(
179             $self
180             , $message
181             , @messages
182             );
183             } else {
184 0         0 $result = sprintf <<'_EOT_'
185             Rendering error: %s
186             %s
187             _EOT_
188             , $message
189             , join '', @messages
190             ;
191             }
192 4         60 return $result;
193             }
194              
195             sub push_scope
196             {
197 2432     2432 0 3590 my( $self ) = @_;
198 2432   50     3053 push @{$self->{'ns'}}, {%{$self->{'ns'}->[-1] // {}}};
  2432         4907  
  2432         13494  
199 2432         6838 return $self;
200             }
201              
202             sub pop_scope
203             {
204 2399     2399 0 3466 my( $self ) = @_;
205             die "It's a last context layer available."
206 2399 100       3040 if scalar @{$self->{'ns'}} == 1;
  2399         6788  
207 2398         3202 pop @{$self->{'ns'}};
  2398         4095  
208 2398         9149 return $self;
209             }
210              
211             1;