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; |