line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package Template::Perlish; |
2
|
|
|
|
|
|
|
|
3
|
|
|
|
|
|
|
# vim: ts=3 sts=3 sw=3 et ai : |
4
|
|
|
|
|
|
|
|
5
|
16
|
|
|
16
|
|
804453
|
use 5.008_000; |
|
16
|
|
|
|
|
149
|
|
6
|
16
|
|
|
16
|
|
618
|
use warnings; |
|
16
|
|
|
|
|
36
|
|
|
16
|
|
|
|
|
307
|
|
7
|
16
|
|
|
15
|
|
134
|
use strict; |
|
15
|
|
|
|
|
26
|
|
|
15
|
|
|
|
|
236
|
|
8
|
15
|
|
|
15
|
|
346
|
use Carp; |
|
15
|
|
|
|
|
25
|
|
|
15
|
|
|
|
|
786
|
|
9
|
15
|
|
|
15
|
|
5572
|
use English qw( -no_match_vars ); |
|
15
|
|
|
|
|
41280
|
|
|
15
|
|
|
|
|
65
|
|
10
|
15
|
|
|
15
|
|
4518
|
use constant ERROR_CONTEXT => 3; |
|
15
|
|
|
|
|
32
|
|
|
15
|
|
|
|
|
1804
|
|
11
|
|
|
|
|
|
|
{ our $VERSION = '1.64'; } |
12
|
15
|
|
|
15
|
|
139
|
use Scalar::Util qw< blessed reftype >; |
|
15
|
|
|
|
|
28
|
|
|
15
|
|
|
|
|
1261
|
|
13
|
|
|
|
|
|
|
|
14
|
|
|
|
|
|
|
# Function-oriented interface |
15
|
|
|
|
|
|
|
sub import { |
16
|
15
|
|
|
15
|
|
125
|
my ($package, @list) = @_; |
17
|
|
|
|
|
|
|
|
18
|
15
|
|
|
|
|
302
|
for my $sub (@list) { |
19
|
|
|
|
|
|
|
croak "subroutine '$sub' not exportable" |
20
|
6
|
50
|
|
|
|
17
|
unless grep { $sub eq $_ } qw< crumble render traverse >; |
|
16
|
|
|
|
|
42
|
|
21
|
|
|
|
|
|
|
|
22
|
6
|
|
|
|
|
64
|
my $caller = caller(); |
23
|
|
|
|
|
|
|
|
24
|
15
|
|
|
15
|
|
346
|
no strict 'refs'; ## no critic (ProhibitNoStrict) |
|
15
|
|
|
|
|
30
|
|
|
15
|
|
|
|
|
2828
|
|
25
|
6
|
|
|
|
|
28
|
local $SIG{__WARN__} = \&Carp::carp; |
26
|
6
|
|
|
|
|
11
|
*{$caller . q<::> . $sub} = \&{$package . q<::> . $sub}; |
|
6
|
|
|
|
|
321
|
|
|
6
|
|
|
|
|
25
|
|
27
|
|
|
|
|
|
|
} ## end for my $sub (@list) |
28
|
|
|
|
|
|
|
|
29
|
15
|
|
|
|
|
197170
|
return; |
30
|
|
|
|
|
|
|
} ## end sub import |
31
|
|
|
|
|
|
|
|
32
|
|
|
|
|
|
|
sub render { |
33
|
19
|
|
|
19
|
1
|
10745
|
my ($template, @rest) = @_; |
34
|
19
|
|
|
|
|
36
|
my ($variables, %params); |
35
|
19
|
100
|
|
|
|
51
|
if (@rest) { |
36
|
14
|
50
|
|
|
|
314
|
$variables = ref($rest[0]) ? shift(@rest) : {splice @rest, 0}; |
37
|
14
|
100
|
|
|
|
35
|
%params = %{shift @rest} if @rest; |
|
2
|
|
|
|
|
6
|
|
38
|
|
|
|
|
|
|
} |
39
|
19
|
|
|
|
|
134
|
return __PACKAGE__->new(%params)->process($template, $variables); |
40
|
|
|
|
|
|
|
} ## end sub render |
41
|
|
|
|
|
|
|
|
42
|
|
|
|
|
|
|
# Object-oriented interface |
43
|
|
|
|
|
|
|
{ |
44
|
|
|
|
|
|
|
my (%preset_for, %inhibits_defaults); |
45
|
|
|
|
|
|
|
BEGIN { |
46
|
15
|
|
|
15
|
|
168
|
%preset_for = ( |
47
|
|
|
|
|
|
|
'default' => { |
48
|
|
|
|
|
|
|
method_over_key => 0, |
49
|
|
|
|
|
|
|
start => '[%', |
50
|
|
|
|
|
|
|
stdout => 1, |
51
|
|
|
|
|
|
|
stop => '%]', |
52
|
|
|
|
|
|
|
strict_blessed => 0, |
53
|
|
|
|
|
|
|
traverse_methods => 0, |
54
|
|
|
|
|
|
|
utf8 => 1, |
55
|
|
|
|
|
|
|
}, |
56
|
|
|
|
|
|
|
'1.52' => { |
57
|
|
|
|
|
|
|
method_over_key => 1, |
58
|
|
|
|
|
|
|
stdout => 0, |
59
|
|
|
|
|
|
|
traverse_methods => 1, |
60
|
|
|
|
|
|
|
}, |
61
|
|
|
|
|
|
|
); |
62
|
|
|
|
|
|
|
|
63
|
|
|
|
|
|
|
# some defaults are inhibited by the presence of certain input |
64
|
|
|
|
|
|
|
# parameters. These parameters can still be put externally, though. |
65
|
15
|
|
|
|
|
33931
|
%inhibits_defaults = ( |
66
|
|
|
|
|
|
|
binmode => [qw< utf8 >], |
67
|
|
|
|
|
|
|
); |
68
|
|
|
|
|
|
|
} |
69
|
|
|
|
|
|
|
sub new { |
70
|
29
|
|
|
29
|
1
|
2210
|
my $package = shift; |
71
|
|
|
|
|
|
|
|
72
|
29
|
|
|
|
|
45
|
my %external; |
73
|
29
|
50
|
|
|
|
381
|
if (@_ == 1) { |
|
|
50
|
|
|
|
|
|
74
|
1
|
|
|
|
|
6
|
%external = %{$_[0]}; |
|
1
|
|
|
|
|
3
|
|
75
|
|
|
|
|
|
|
} |
76
|
|
|
|
|
|
|
elsif (scalar(@_) % 2 == 0) { |
77
|
29
|
|
|
|
|
214
|
while (@_) { |
78
|
5
|
|
|
|
|
20
|
my ($key, $value) = splice @_, 0, 2; |
79
|
5
|
50
|
|
|
|
14
|
if ($key eq '-preset') { |
80
|
|
|
|
|
|
|
croak "invalid preset $value in new()" |
81
|
1
|
0
|
|
|
|
275
|
unless exists $preset_for{$value}; |
82
|
1
|
|
|
|
|
6
|
%external = (%external, %{$preset_for{$value}}); |
|
1
|
|
|
|
|
2
|
|
83
|
|
|
|
|
|
|
} |
84
|
|
|
|
|
|
|
else { |
85
|
5
|
|
|
|
|
55
|
$external{$key} = $value; |
86
|
|
|
|
|
|
|
} |
87
|
|
|
|
|
|
|
} |
88
|
|
|
|
|
|
|
} |
89
|
|
|
|
|
|
|
else { |
90
|
1
|
|
|
|
|
6
|
croak 'invalid number of input arguments for constructor'; |
91
|
|
|
|
|
|
|
} |
92
|
|
|
|
|
|
|
|
93
|
|
|
|
|
|
|
# compute defaults, removing inhibitions |
94
|
29
|
|
|
|
|
53
|
my %defaults =(%{$preset_for{'default'}}, variables => {}); |
|
29
|
|
|
|
|
449
|
|
95
|
29
|
|
|
|
|
92
|
for my $inhibitor (keys %inhibits_defaults) { |
96
|
29
|
100
|
|
|
|
86
|
next unless exists $external{$inhibitor}; |
97
|
2
|
|
|
|
|
43
|
delete $defaults{$_} for @{$inhibits_defaults{$inhibitor}}; |
|
2
|
|
|
|
|
10
|
|
98
|
|
|
|
|
|
|
} |
99
|
|
|
|
|
|
|
|
100
|
29
|
|
|
|
|
247
|
return bless {%defaults, %external}, $package; |
101
|
|
|
|
|
|
|
} ## end sub new |
102
|
|
|
|
|
|
|
} |
103
|
|
|
|
|
|
|
|
104
|
|
|
|
|
|
|
sub process { |
105
|
74
|
|
|
74
|
1
|
34982
|
my ($self, $template, $vars) = @_; |
106
|
74
|
|
|
|
|
246
|
return $self->evaluate($self->compile($template), $vars); |
107
|
|
|
|
|
|
|
} |
108
|
|
|
|
|
|
|
|
109
|
|
|
|
|
|
|
sub evaluate { |
110
|
74
|
|
|
74
|
1
|
194
|
my ($self, $compiled, $vars) = @_; |
111
|
|
|
|
|
|
|
$self->_compile_sub($compiled) |
112
|
74
|
50
|
|
|
|
211
|
unless exists $compiled->{sub}; |
113
|
74
|
|
|
|
|
1663
|
return $compiled->{sub}->($vars); |
114
|
|
|
|
|
|
|
} ## end sub evaluate |
115
|
|
|
|
|
|
|
|
116
|
|
|
|
|
|
|
sub compile { ## no critic (RequireArgUnpacking) |
117
|
77
|
|
|
77
|
1
|
146
|
my ($self, undef, %args) = @_; |
118
|
77
|
|
|
|
|
443
|
my $outcome = $self->_compile_code_text($_[1]); |
119
|
77
|
50
|
|
|
|
187
|
return $outcome if $args{no_check}; |
120
|
77
|
|
|
|
|
170
|
return $self->_compile_sub($outcome); |
121
|
|
|
|
|
|
|
} ## end sub compile |
122
|
|
|
|
|
|
|
|
123
|
|
|
|
|
|
|
sub compile_as_sub { ## no critic (RequireArgUnpacking) |
124
|
4
|
|
|
4
|
1
|
1589
|
my $self = shift; |
125
|
4
|
|
|
|
|
21
|
return $self->compile($_[0])->{'sub'}; |
126
|
|
|
|
|
|
|
} |
127
|
|
|
|
|
|
|
|
128
|
|
|
|
|
|
|
sub _compile_code_text { |
129
|
77
|
|
|
77
|
|
135
|
my ($self, $template) = @_; |
130
|
|
|
|
|
|
|
|
131
|
77
|
|
|
|
|
617
|
my $starter = $self->{start}; |
132
|
77
|
|
|
|
|
165
|
my $stopper = $self->{stop}; |
133
|
|
|
|
|
|
|
|
134
|
77
|
|
|
|
|
109
|
my $compiled = "# line 1 'input'\n"; |
135
|
77
|
100
|
|
|
|
283
|
$compiled .= "use utf8;\n\n" if $self->{utf8}; |
136
|
77
|
|
|
|
|
123
|
$compiled .= "P('');\n\n"; |
137
|
77
|
|
|
|
|
105
|
my $pos = 0; |
138
|
77
|
|
|
|
|
366
|
my $line_no = 1; |
139
|
77
|
|
|
|
|
192
|
while ($pos < length $template) { |
140
|
|
|
|
|
|
|
|
141
|
|
|
|
|
|
|
# Find starter and emit all previous text as simple text |
142
|
144
|
|
|
|
|
259
|
my $start = index $template, $starter, $pos; |
143
|
144
|
100
|
|
|
|
310
|
last if $start < 0; |
144
|
88
|
|
|
|
|
175
|
my $chunk = substr $template, $pos, $start - $pos; |
145
|
88
|
100
|
|
|
|
198
|
$compiled .= _simple_text($chunk) |
146
|
|
|
|
|
|
|
if $start > $pos; |
147
|
|
|
|
|
|
|
|
148
|
|
|
|
|
|
|
# Update scanning variables. The line counter is advanced for |
149
|
|
|
|
|
|
|
# the chunk but not yet for the $starter, so that error reporting |
150
|
|
|
|
|
|
|
# for unmatched $starter will point to the correct line |
151
|
88
|
|
|
|
|
388
|
$pos = $start + length $starter; |
152
|
88
|
|
|
|
|
165
|
$line_no += ($chunk =~ tr/\n//); |
153
|
|
|
|
|
|
|
|
154
|
|
|
|
|
|
|
# Grab code |
155
|
88
|
|
|
|
|
139
|
my $stop = index $template, $stopper, $pos; |
156
|
88
|
50
|
|
|
|
233
|
if ($stop < 0) { # no matching $stopper, bummer! |
157
|
1
|
|
|
|
|
6
|
my $section = _extract_section({template => $template}, $line_no); |
158
|
1
|
|
|
|
|
2
|
croak "unclosed starter '$starter' at line $line_no\n$section"; |
159
|
|
|
|
|
|
|
} |
160
|
88
|
|
|
|
|
456
|
my $code = substr $template, $pos, $stop - $pos; |
161
|
|
|
|
|
|
|
|
162
|
|
|
|
|
|
|
# Now I can advance the line count considering the $starter too |
163
|
88
|
|
|
|
|
128
|
$line_no += ($starter =~ tr/\n//); |
164
|
|
|
|
|
|
|
|
165
|
88
|
100
|
|
|
|
171
|
if (length $code) { |
166
|
84
|
100
|
|
|
|
193
|
if (my $path = crumble($code)) { |
|
|
50
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
167
|
33
|
|
|
|
|
77
|
$compiled .= _variable($path); |
168
|
|
|
|
|
|
|
} |
169
|
|
|
|
|
|
|
elsif (my ($scalar) = |
170
|
|
|
|
|
|
|
$code =~ m{\A\s* (\$ [[:alpha:]_]\w*) \s*\z}mxs) |
171
|
|
|
|
|
|
|
{ |
172
|
1
|
|
|
|
|
2
|
$compiled .= |
173
|
|
|
|
|
|
|
"\nP($scalar); ### straight scalar\n\n"; |
174
|
|
|
|
|
|
|
} ## end elsif (my ($scalar) = $code...) |
175
|
|
|
|
|
|
|
elsif (substr($code, 0, 1) eq q<=>) { |
176
|
25
|
|
|
|
|
361
|
$compiled .= "\n# line $line_no 'template<3,$line_no>'\n" |
177
|
|
|
|
|
|
|
. _expression(substr $code, 1); |
178
|
|
|
|
|
|
|
} |
179
|
|
|
|
|
|
|
else { |
180
|
28
|
|
|
|
|
98
|
$compiled .= |
181
|
|
|
|
|
|
|
"\n# line $line_no 'template<0,$line_no>'\n" . $code; |
182
|
|
|
|
|
|
|
} |
183
|
|
|
|
|
|
|
} ## end if (length $code) |
184
|
|
|
|
|
|
|
|
185
|
|
|
|
|
|
|
# Update scanning variables |
186
|
88
|
|
|
|
|
149
|
$pos = $stop + length $stopper; |
187
|
88
|
|
|
|
|
303
|
$line_no += (($code . $stopper) =~ tr/\n//); |
188
|
|
|
|
|
|
|
|
189
|
|
|
|
|
|
|
} ## end while ($pos < length $template) |
190
|
|
|
|
|
|
|
|
191
|
|
|
|
|
|
|
# put last part of input string as simple text |
192
|
77
|
|
100
|
|
|
251
|
$compiled .= _simple_text(substr($template, $pos || 0)); |
193
|
|
|
|
|
|
|
|
194
|
|
|
|
|
|
|
return { |
195
|
77
|
|
|
|
|
277
|
template => $template, |
196
|
|
|
|
|
|
|
code_text => $compiled, |
197
|
|
|
|
|
|
|
}; |
198
|
|
|
|
|
|
|
} ## end sub _compile_code_text |
199
|
|
|
|
|
|
|
|
200
|
|
|
|
|
|
|
# The following function is long and complex because it deals with many |
201
|
|
|
|
|
|
|
# different cases. It is kept as-is to avoid too many calls to other |
202
|
|
|
|
|
|
|
# subroutines; for this reason, it's reasonably commented. |
203
|
|
|
|
|
|
|
sub traverse { ## no critic (RequireArgUnpacking,ProhibitExcessComplexity) |
204
|
|
|
|
|
|
|
|
205
|
|
|
|
|
|
|
## no critic (ProhibitDoubleSigils) |
206
|
94
|
|
|
94
|
1
|
22162
|
my $iref = ref($_[0]); |
207
|
94
|
|
100
|
|
|
375
|
my $ref_wanted = ($iref eq 'SCALAR') || ($iref eq 'REF'); |
208
|
94
|
100
|
|
|
|
192
|
my $ref_to_value = $ref_wanted ? shift : \shift; |
209
|
|
|
|
|
|
|
|
210
|
|
|
|
|
|
|
# early detection of options, remove them from args list |
211
|
94
|
100
|
100
|
|
|
388
|
my $opts = (@_ && (ref($_[-1]) eq 'HASH')) ? pop(@_) : {}; |
212
|
|
|
|
|
|
|
my $missing = $ref_wanted ? undef |
213
|
94
|
100
|
|
|
|
226
|
: exists($opts->{missing}) ? $opts->{missing} : ''; |
|
|
100
|
|
|
|
|
|
214
|
|
|
|
|
|
|
|
215
|
|
|
|
|
|
|
# if there's not $path provided, just don't bother going on. Actually, |
216
|
|
|
|
|
|
|
# no $path means just return root, undefined path is always "not |
217
|
|
|
|
|
|
|
# present" though. |
218
|
94
|
100
|
|
|
|
250
|
return ($ref_wanted ? $ref_to_value : $$ref_to_value) unless @_; |
|
|
100
|
|
|
|
|
|
219
|
92
|
|
|
|
|
391
|
my $path_input = shift; |
220
|
92
|
50
|
|
|
|
175
|
return $missing unless defined $path_input; |
221
|
|
|
|
|
|
|
|
222
|
92
|
|
|
|
|
120
|
my $crumbs; |
223
|
92
|
100
|
|
|
|
209
|
if (ref $path_input) { |
224
|
63
|
|
|
|
|
89
|
$crumbs = $path_input; |
225
|
|
|
|
|
|
|
} |
226
|
|
|
|
|
|
|
else { |
227
|
30
|
0
|
33
|
|
|
94
|
return ($ref_wanted ? $ref_to_value : $$ref_to_value) |
|
|
50
|
|
|
|
|
|
228
|
|
|
|
|
|
|
if defined($path_input) && !length($path_input); |
229
|
30
|
|
|
|
|
364
|
$crumbs = crumble($path_input); |
230
|
|
|
|
|
|
|
} |
231
|
92
|
50
|
|
|
|
157
|
return $missing unless defined $crumbs; # undef on crumble parse error |
232
|
|
|
|
|
|
|
|
233
|
|
|
|
|
|
|
# go down the rabbit hole |
234
|
92
|
|
100
|
|
|
260
|
my $use_method = $opts->{traverse_methods} || 0; |
235
|
92
|
|
|
|
|
189
|
my ($strict_blessed, $method_pre) = (0, 0); |
236
|
92
|
100
|
|
|
|
163
|
if ($use_method) { |
237
|
11
|
|
100
|
|
|
27
|
$strict_blessed = $opts->{strict_blessed} || 0; |
238
|
11
|
|
100
|
|
|
291
|
$method_pre = (! $strict_blessed && $opts->{method_over_key}) || 0; |
239
|
|
|
|
|
|
|
} |
240
|
92
|
|
|
|
|
150
|
for my $crumb (@$crumbs) { |
241
|
|
|
|
|
|
|
|
242
|
|
|
|
|
|
|
# $key is what we will look into $$ref_to_value. We don't use |
243
|
|
|
|
|
|
|
# $crumb directly as we might change $key in the loop, and we |
244
|
|
|
|
|
|
|
# don't want to spoil $crumbs |
245
|
180
|
|
|
|
|
253
|
my $key = $crumb; |
246
|
|
|
|
|
|
|
|
247
|
|
|
|
|
|
|
# $ref tells me how to look down into $$ref_to_value, i.e. as |
248
|
|
|
|
|
|
|
# an ARRAY or a HASH... or object |
249
|
180
|
|
|
|
|
408
|
my $ref = reftype $$ref_to_value; |
250
|
|
|
|
|
|
|
|
251
|
|
|
|
|
|
|
# if $ref is not true, we hit a wall. How we proceed depends on |
252
|
|
|
|
|
|
|
# whether we were asked to auto-vivify or not. |
253
|
180
|
100
|
|
|
|
278
|
if (!$ref) { |
254
|
8
|
100
|
|
|
|
16
|
return $missing unless $ref_wanted; # don't bother going on |
255
|
|
|
|
|
|
|
|
256
|
|
|
|
|
|
|
# auto-vivification requested! $key will tell us how to |
257
|
|
|
|
|
|
|
# proceed further, hopefully |
258
|
7
|
|
|
|
|
263
|
$ref = ref $key; |
259
|
|
|
|
|
|
|
} ## end if (!$ref) |
260
|
|
|
|
|
|
|
|
261
|
|
|
|
|
|
|
# if $key is a reference, it will tell us what's expected now |
262
|
179
|
100
|
|
|
|
316
|
if (my $key_ref = ref $key) { |
263
|
|
|
|
|
|
|
|
264
|
|
|
|
|
|
|
# if $key_ref is not the same as $ref there is a mismatch |
265
|
|
|
|
|
|
|
# between what's available ($ref) and what' expected ($key_ref) |
266
|
10
|
100
|
|
|
|
18
|
return $missing if $key_ref ne $ref; |
267
|
|
|
|
|
|
|
|
268
|
|
|
|
|
|
|
# OK, data and expectations agree. Get the "real" key |
269
|
9
|
50
|
|
|
|
62
|
if ($key_ref eq 'ARRAY') { |
|
|
50
|
|
|
|
|
|
270
|
1
|
|
|
|
|
6
|
$key = $crumb->[0]; # it's an array, key is (only) element |
271
|
|
|
|
|
|
|
} |
272
|
|
|
|
|
|
|
elsif ($key_ref eq 'HASH') { |
273
|
9
|
|
|
|
|
22
|
($key) = keys %$crumb; # hash... key is (only) key |
274
|
|
|
|
|
|
|
} |
275
|
|
|
|
|
|
|
} ## end if (my $key_ref = ref ...) |
276
|
|
|
|
|
|
|
|
277
|
|
|
|
|
|
|
# if $ref is still not true at this point, we're doing |
278
|
|
|
|
|
|
|
# auto-vivification and we have a plain key. Some guessing |
279
|
|
|
|
|
|
|
# will be needed! Plain non-negative integers resolve to ARRAY, |
280
|
|
|
|
|
|
|
# otherwise we'll consider $key as a HASH key |
281
|
178
|
100
|
66
|
|
|
538
|
$ref ||= ($key =~ m{\A (?: 0 | [1-9]\d*) \z}mxs) ? 'ARRAY' : 'HASH'; |
282
|
|
|
|
|
|
|
|
283
|
|
|
|
|
|
|
# time to actually do the next step |
284
|
178
|
|
|
|
|
282
|
my $is_blessed = blessed $$ref_to_value; |
285
|
178
|
|
100
|
|
|
310
|
my $method = $is_blessed && $$ref_to_value->can($key); |
286
|
178
|
100
|
100
|
|
|
883
|
if ($is_blessed && $strict_blessed) { |
|
|
100
|
100
|
|
|
|
|
|
|
100
|
66
|
|
|
|
|
|
|
100
|
66
|
|
|
|
|
|
|
100
|
66
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
287
|
1
|
50
|
|
|
|
6
|
return $missing unless $method; |
288
|
0
|
|
|
|
|
0
|
$ref_to_value = \($$ref_to_value->$method()); |
289
|
|
|
|
|
|
|
} |
290
|
|
|
|
|
|
|
elsif ($method && $method_pre) { |
291
|
2
|
|
|
|
|
6
|
$ref_to_value = \($$ref_to_value->$method()); |
292
|
|
|
|
|
|
|
} |
293
|
|
|
|
|
|
|
elsif (($ref eq 'HASH') && exists($$ref_to_value->{$key})) { |
294
|
138
|
|
|
|
|
283
|
$ref_to_value = \($$ref_to_value->{$key}); |
295
|
|
|
|
|
|
|
} |
296
|
|
|
|
|
|
|
elsif (($ref eq 'ARRAY') && exists($$ref_to_value->[$key])) { |
297
|
17
|
|
|
|
|
41
|
$ref_to_value = \($$ref_to_value->[$key]); |
298
|
|
|
|
|
|
|
} |
299
|
|
|
|
|
|
|
elsif ($method && $use_method) { |
300
|
1
|
|
|
|
|
5
|
$ref_to_value = \($$ref_to_value->$method()); |
301
|
|
|
|
|
|
|
} |
302
|
|
|
|
|
|
|
elsif (! $ref_wanted) { # block unwanted autovivification |
303
|
11
|
|
|
|
|
113
|
return $missing; |
304
|
|
|
|
|
|
|
} |
305
|
|
|
|
|
|
|
# autovivification goes here eventually |
306
|
|
|
|
|
|
|
elsif ($ref eq 'HASH') { |
307
|
5
|
|
|
|
|
12
|
$ref_to_value = \($$ref_to_value->{$key}); |
308
|
|
|
|
|
|
|
} |
309
|
|
|
|
|
|
|
elsif ($ref eq 'ARRAY') { |
310
|
2
|
|
|
|
|
5
|
$ref_to_value = \($$ref_to_value->[$key]); |
311
|
|
|
|
|
|
|
} |
312
|
|
|
|
|
|
|
else { # don't know what to do with other references! |
313
|
0
|
|
|
|
|
0
|
return $missing; |
314
|
|
|
|
|
|
|
} |
315
|
|
|
|
|
|
|
} ## end for my $crumb (@$crumbs) |
316
|
|
|
|
|
|
|
|
317
|
|
|
|
|
|
|
# normalize output, substitute undef with '' unless $ref_wanted |
318
|
|
|
|
|
|
|
return |
319
|
|
|
|
|
|
|
$ref_wanted ? $ref_to_value |
320
|
|
|
|
|
|
|
: defined($$ref_to_value) ? $$ref_to_value |
321
|
|
|
|
|
|
|
: exists($opts->{undef}) ? $opts->{undef} |
322
|
77
|
50
|
|
|
|
1444
|
: ''; |
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
323
|
|
|
|
|
|
|
|
324
|
|
|
|
|
|
|
## use critic |
325
|
|
|
|
|
|
|
} ## end sub traverse |
326
|
|
|
|
|
|
|
|
327
|
0
|
|
|
1
|
1
|
0
|
sub V { return '' } |
328
|
0
|
|
|
1
|
1
|
0
|
sub A { return } |
329
|
0
|
|
|
1
|
1
|
0
|
sub H { return } |
330
|
0
|
|
|
1
|
1
|
0
|
sub HK { return } |
331
|
0
|
|
|
1
|
1
|
0
|
sub HV { return } |
332
|
|
|
|
|
|
|
|
333
|
|
|
|
|
|
|
sub _compile_sub { |
334
|
76
|
|
|
77
|
|
140
|
my ($self, $outcome) = @_; |
335
|
|
|
|
|
|
|
|
336
|
76
|
|
|
|
|
96
|
my @warnings; |
337
|
|
|
|
|
|
|
{ |
338
|
76
|
100
|
|
|
|
86
|
my $utf8 = $self->{utf8} ? 1 : 0; |
|
76
|
|
|
|
|
201
|
|
339
|
76
|
100
|
|
|
|
141
|
my $stdout = $self->{stdout} ? 1 : 0; |
340
|
76
|
|
|
3
|
|
423
|
local $SIG{__WARN__} = sub { push @warnings, @_ }; |
|
2
|
|
|
|
|
240
|
|
341
|
76
|
|
|
|
|
130
|
my @code; |
342
|
76
|
|
|
|
|
129
|
push @code, <<'END_OF_CODE'; |
343
|
|
|
|
|
|
|
sub { |
344
|
|
|
|
|
|
|
my %variables = %{$self->{variables}}; |
345
|
|
|
|
|
|
|
my $V = \%variables; # generic kid, as before by default |
346
|
|
|
|
|
|
|
|
347
|
|
|
|
|
|
|
{ |
348
|
|
|
|
|
|
|
my $vars = shift || {}; |
349
|
|
|
|
|
|
|
if (ref($vars) eq 'HASH') { # old case |
350
|
|
|
|
|
|
|
%variables = (%variables, %$vars); |
351
|
|
|
|
|
|
|
} |
352
|
|
|
|
|
|
|
else { |
353
|
|
|
|
|
|
|
$V = $vars; |
354
|
|
|
|
|
|
|
%variables = (HASH => { %variables }, REF => $V); |
355
|
|
|
|
|
|
|
} |
356
|
|
|
|
|
|
|
} |
357
|
|
|
|
|
|
|
|
358
|
|
|
|
|
|
|
my $buffer = ''; # output variable |
359
|
|
|
|
|
|
|
my $OFH; |
360
|
|
|
|
|
|
|
END_OF_CODE |
361
|
|
|
|
|
|
|
|
362
|
76
|
|
|
|
|
101
|
my $handle = '$OFH'; |
363
|
76
|
100
|
|
|
|
116
|
if ($stdout) { |
364
|
67
|
|
|
|
|
82
|
$handle = 'STDOUT'; |
365
|
67
|
|
|
|
|
91
|
push @code, <<'END_OF_CODE'; |
366
|
|
|
|
|
|
|
local *STDOUT; |
367
|
|
|
|
|
|
|
open STDOUT, '>', \$buffer or croak "open(): $OS_ERROR"; |
368
|
|
|
|
|
|
|
$OFH = select(STDOUT); |
369
|
|
|
|
|
|
|
END_OF_CODE |
370
|
|
|
|
|
|
|
} |
371
|
|
|
|
|
|
|
else { |
372
|
9
|
|
|
|
|
15
|
push @code, <<'END_OF_CODE'; |
373
|
|
|
|
|
|
|
open $OFH, '>', \$buffer or croak "open(): $OS_ERROR"; |
374
|
|
|
|
|
|
|
END_OF_CODE |
375
|
|
|
|
|
|
|
} |
376
|
|
|
|
|
|
|
|
377
|
76
|
100
|
|
|
|
196
|
push @code, "binmode $handle, ':encoding(utf8)';\n" |
378
|
|
|
|
|
|
|
if $utf8; |
379
|
|
|
|
|
|
|
push @code, "binmode $handle, '$self->{binmode}';\n" |
380
|
76
|
100
|
|
|
|
166
|
if defined $self->{binmode}; |
381
|
|
|
|
|
|
|
|
382
|
|
|
|
|
|
|
# add functions that can be seen only within the compiled code |
383
|
76
|
|
|
|
|
180
|
push @code, $self->_compile_code_localsubs($handle); |
384
|
|
|
|
|
|
|
|
385
|
76
|
|
|
|
|
110
|
push @code, <<'END_OF_CODE'; |
386
|
|
|
|
|
|
|
{ # double closure to free "my" variables |
387
|
|
|
|
|
|
|
my ($buffer, $OFH); # hide external ones |
388
|
|
|
|
|
|
|
END_OF_CODE |
389
|
|
|
|
|
|
|
|
390
|
|
|
|
|
|
|
# the real code! one additional scope indentation to ensure we |
391
|
|
|
|
|
|
|
# can "my" variables again |
392
|
|
|
|
|
|
|
push @code, |
393
|
|
|
|
|
|
|
"{\n", # this enclusure allows using "my" again |
394
|
|
|
|
|
|
|
$outcome->{code_text}, |
395
|
76
|
|
|
|
|
133
|
"}\n}\n\n"; |
396
|
|
|
|
|
|
|
|
397
|
76
|
100
|
|
|
|
149
|
push @code, "select(\$OFH);\n" if $stdout; |
398
|
76
|
|
|
|
|
132
|
push @code, "close $handle;\n\n"; |
399
|
|
|
|
|
|
|
|
400
|
76
|
100
|
|
|
|
123
|
if ($utf8) { |
401
|
74
|
|
|
|
|
103
|
push @code, <<'END_OF_CODE'; |
402
|
|
|
|
|
|
|
require Encode; |
403
|
|
|
|
|
|
|
$buffer = Encode::decode(utf8 => $buffer); |
404
|
|
|
|
|
|
|
|
405
|
|
|
|
|
|
|
END_OF_CODE |
406
|
|
|
|
|
|
|
} |
407
|
|
|
|
|
|
|
|
408
|
76
|
|
|
|
|
94
|
push @code, "return \$buffer;\n}\n"; |
409
|
|
|
|
|
|
|
|
410
|
76
|
|
|
|
|
401
|
my $code = join '', @code; |
411
|
|
|
|
|
|
|
#print {*STDOUT} $code, "\n\n\n\n\n"; exit 0; |
412
|
76
|
|
|
12
|
|
13411
|
$outcome->{sub} = eval $code; ## no critic (ProhibitStringyEval) |
|
11
|
|
|
12
|
|
77
|
|
|
11
|
|
|
12
|
|
32
|
|
|
11
|
|
|
12
|
|
3389
|
|
|
11
|
|
|
8
|
|
95
|
|
|
11
|
|
|
8
|
|
39
|
|
|
11
|
|
|
7
|
|
1802
|
|
|
11
|
|
|
7
|
|
57
|
|
|
11
|
|
|
6
|
|
28
|
|
|
11
|
|
|
6
|
|
353
|
|
|
11
|
|
|
6
|
|
56
|
|
|
11
|
|
|
6
|
|
47
|
|
|
11
|
|
|
6
|
|
89
|
|
|
7
|
|
|
6
|
|
100
|
|
|
7
|
|
|
5
|
|
15
|
|
|
7
|
|
|
4
|
|
2212
|
|
|
7
|
|
|
4
|
|
45
|
|
|
7
|
|
|
4
|
|
12
|
|
|
7
|
|
|
4
|
|
378
|
|
|
6
|
|
|
4
|
|
35
|
|
|
6
|
|
|
|
|
32
|
|
|
6
|
|
|
|
|
1716
|
|
|
6
|
|
|
|
|
39
|
|
|
6
|
|
|
|
|
10
|
|
|
6
|
|
|
|
|
272
|
|
|
5
|
|
|
|
|
31
|
|
|
5
|
|
|
|
|
9
|
|
|
5
|
|
|
|
|
1426
|
|
|
5
|
|
|
|
|
30
|
|
|
5
|
|
|
|
|
9
|
|
|
5
|
|
|
|
|
213
|
|
|
5
|
|
|
|
|
29
|
|
|
5
|
|
|
|
|
10
|
|
|
5
|
|
|
|
|
1407
|
|
|
5
|
|
|
|
|
30
|
|
|
5
|
|
|
|
|
9
|
|
|
5
|
|
|
|
|
222
|
|
|
5
|
|
|
|
|
29
|
|
|
5
|
|
|
|
|
10
|
|
|
5
|
|
|
|
|
1448
|
|
|
5
|
|
|
|
|
39
|
|
|
5
|
|
|
|
|
10
|
|
|
5
|
|
|
|
|
207
|
|
|
4
|
|
|
|
|
25
|
|
|
4
|
|
|
|
|
7
|
|
|
4
|
|
|
|
|
1462
|
|
|
4
|
|
|
|
|
25
|
|
|
4
|
|
|
|
|
6
|
|
|
4
|
|
|
|
|
168
|
|
|
4
|
|
|
|
|
26
|
|
|
4
|
|
|
|
|
7
|
|
|
4
|
|
|
|
|
1141
|
|
|
4
|
|
|
|
|
25
|
|
|
4
|
|
|
|
|
8
|
|
|
4
|
|
|
|
|
172
|
|
|
4
|
|
|
|
|
55
|
|
|
4
|
|
|
|
|
9
|
|
|
4
|
|
|
|
|
1158
|
|
|
4
|
|
|
|
|
24
|
|
|
4
|
|
|
|
|
6
|
|
|
4
|
|
|
|
|
177
|
|
413
|
76
|
100
|
|
|
|
21315
|
return $outcome if $outcome->{sub}; |
414
|
|
|
|
|
|
|
} |
415
|
|
|
|
|
|
|
|
416
|
2
|
|
|
|
|
5
|
my $error = $EVAL_ERROR; |
417
|
2
|
|
|
|
|
20
|
my ($offset, $starter, $line_no) = |
418
|
|
|
|
|
|
|
$error =~ m{at[ ]'template<(\d+),(\d+)>'[ ]line[ ](\d+)}mxs; |
419
|
2
|
|
|
|
|
5
|
$line_no -= $offset; |
420
|
3
|
|
|
|
|
20
|
s{at[ ]'template<\d+,\d+>'[ ]line[ ](\d+)} |
421
|
2
|
|
|
|
|
16
|
{'at line ' . ($1 - $offset)}egmxs |
422
|
2
|
50
|
|
|
|
6
|
for @warnings, $error; |
423
|
|
|
|
|
|
|
if ($line_no == $starter) { |
424
|
0
|
|
|
|
|
0
|
s{,[ ]near[ ]"[#][ ]line.*?\n\s+}{, near "}gmxs |
425
|
|
|
|
|
|
|
for @warnings, $error; |
426
|
|
|
|
|
|
|
} |
427
|
2
|
|
|
|
|
5
|
|
428
|
2
|
|
|
|
|
34
|
my $section = _extract_section($outcome, $line_no); |
429
|
|
|
|
|
|
|
$error = join '', @warnings, $error, "\n", $section; |
430
|
2
|
|
|
|
|
227
|
|
431
|
|
|
|
|
|
|
croak $error; |
432
|
|
|
|
|
|
|
} ## end sub _compile_sub |
433
|
|
|
|
|
|
|
|
434
|
76
|
|
|
77
|
|
136
|
sub _compile_code_localsubs { |
435
|
76
|
|
|
|
|
89
|
my ($self, $handle) = @_; |
436
|
76
|
|
|
|
|
149
|
my @code; |
437
|
|
|
|
|
|
|
push @code, <<'END_OF_CODE'; |
438
|
|
|
|
|
|
|
|
439
|
|
|
|
|
|
|
no warnings 'redefine'; |
440
|
|
|
|
|
|
|
|
441
|
|
|
|
|
|
|
END_OF_CODE |
442
|
|
|
|
|
|
|
|
443
|
76
|
100
|
|
|
|
163
|
# custom functions to be injected |
444
|
|
|
|
|
|
|
if (defined(my $custom = $self->{functions})) { |
445
|
1
|
|
|
|
|
4
|
push @code, map { |
|
2
|
|
|
|
|
7
|
|
446
|
|
|
|
|
|
|
" local *$_ = \$self->{functions}{$_};\n" |
447
|
|
|
|
|
|
|
} keys %$custom; |
448
|
|
|
|
|
|
|
} |
449
|
|
|
|
|
|
|
|
450
|
76
|
|
|
|
|
103
|
# input data structure traversing facility |
451
|
|
|
|
|
|
|
push @code, <<'END_OF_CODE'; |
452
|
|
|
|
|
|
|
|
453
|
|
|
|
|
|
|
local *V = sub { |
454
|
|
|
|
|
|
|
my $path = scalar(@_) ? shift : []; |
455
|
|
|
|
|
|
|
my $input = scalar(@_) ? shift : $V; |
456
|
|
|
|
|
|
|
return traverse($input, $path, $self); |
457
|
|
|
|
|
|
|
}; |
458
|
|
|
|
|
|
|
local *A = sub { |
459
|
|
|
|
|
|
|
my $path = scalar(@_) ? shift : []; |
460
|
|
|
|
|
|
|
my $input = scalar(@_) ? shift : $V; |
461
|
|
|
|
|
|
|
return @{traverse($input, $path, $self) || []}; |
462
|
|
|
|
|
|
|
}; |
463
|
|
|
|
|
|
|
local *H = sub { |
464
|
|
|
|
|
|
|
my $path = scalar(@_) ? shift : []; |
465
|
|
|
|
|
|
|
my $input = scalar(@_) ? shift : $V; |
466
|
|
|
|
|
|
|
return %{traverse($input, $path, $self) || {}}; |
467
|
|
|
|
|
|
|
}; |
468
|
|
|
|
|
|
|
local *HK = sub { |
469
|
|
|
|
|
|
|
my $path = scalar(@_) ? shift : []; |
470
|
|
|
|
|
|
|
my $input = scalar(@_) ? shift : $V; |
471
|
|
|
|
|
|
|
return keys %{traverse($input, $path, $self) || {}}; |
472
|
|
|
|
|
|
|
}; |
473
|
|
|
|
|
|
|
local *HV = sub { |
474
|
|
|
|
|
|
|
my $path = scalar(@_) ? shift : []; |
475
|
|
|
|
|
|
|
my $input = scalar(@_) ? shift : $V; |
476
|
|
|
|
|
|
|
return values %{traverse($input, $path, $self) || {}}; |
477
|
|
|
|
|
|
|
}; |
478
|
|
|
|
|
|
|
|
479
|
|
|
|
|
|
|
END_OF_CODE |
480
|
|
|
|
|
|
|
|
481
|
76
|
|
|
|
|
154
|
# this comes separated because we need $handle |
482
|
|
|
|
|
|
|
push @code, <<"END_OF_CODE"; |
483
|
|
|
|
|
|
|
local *P = sub { return print $handle \@_; }; |
484
|
|
|
|
|
|
|
|
485
|
|
|
|
|
|
|
use warnings 'redefine'; |
486
|
|
|
|
|
|
|
|
487
|
|
|
|
|
|
|
END_OF_CODE |
488
|
76
|
|
|
|
|
175
|
|
489
|
|
|
|
|
|
|
return @code; |
490
|
|
|
|
|
|
|
} |
491
|
|
|
|
|
|
|
|
492
|
2
|
|
|
3
|
|
5
|
sub _extract_section { |
493
|
2
|
|
|
|
|
2
|
my ($hash, $line_no) = @_; |
494
|
2
|
|
|
|
|
3
|
$line_no--; # for proper comparison with 0-based array |
495
|
2
|
|
|
|
|
3
|
my $start = $line_no - ERROR_CONTEXT; |
496
|
|
|
|
|
|
|
my $end = $line_no + ERROR_CONTEXT; |
497
|
2
|
|
|
|
|
12
|
|
498
|
2
|
100
|
|
|
|
5
|
my @lines = split /\n/mxs, $hash->{template}; |
499
|
2
|
100
|
|
|
|
6
|
$start = 0 if $start < 0; |
500
|
2
|
|
|
|
|
4
|
$end = $#lines if $end > $#lines; |
501
|
|
|
|
|
|
|
my $n_chars = length($end + 1); |
502
|
2
|
100
|
|
|
|
5
|
return join '', map { |
|
11
|
|
|
|
|
44
|
|
503
|
|
|
|
|
|
|
sprintf "%s%${n_chars}d| %s\n", |
504
|
|
|
|
|
|
|
(($_ == $line_no) ? '>>' : ' '), ($_ + 1), $lines[$_]; |
505
|
|
|
|
|
|
|
} $start .. $end; |
506
|
|
|
|
|
|
|
} ## end sub _extract_section |
507
|
|
|
|
|
|
|
|
508
|
140
|
|
|
141
|
|
249
|
sub _simple_text { |
509
|
|
|
|
|
|
|
my $text = shift; |
510
|
140
|
100
|
|
|
|
475
|
|
511
|
|
|
|
|
|
|
return "P('$text');\n\n" if $text !~ /[\n'\\]/mxs; |
512
|
106
|
|
|
|
|
417
|
|
513
|
106
|
|
|
|
|
307
|
$text =~ s/^/ /gmxs; # indent, trick taken from diff -u |
514
|
|
|
|
|
|
|
return <<"END_OF_CHUNK"; |
515
|
|
|
|
|
|
|
### Verbatim text |
516
|
|
|
|
|
|
|
P(do { |
517
|
|
|
|
|
|
|
my \$text = <<'END_OF_INDENTED_TEXT'; |
518
|
|
|
|
|
|
|
$text |
519
|
|
|
|
|
|
|
END_OF_INDENTED_TEXT |
520
|
|
|
|
|
|
|
\$text =~ s/^ //gms; # de-indent |
521
|
|
|
|
|
|
|
substr \$text, -1, 1, ''; # get rid of added newline |
522
|
|
|
|
|
|
|
\$text; |
523
|
|
|
|
|
|
|
}); |
524
|
|
|
|
|
|
|
|
525
|
|
|
|
|
|
|
END_OF_CHUNK |
526
|
|
|
|
|
|
|
} ## end sub _simple_text |
527
|
|
|
|
|
|
|
|
528
|
139
|
|
|
140
|
1
|
14690
|
sub crumble { |
529
|
139
|
50
|
|
|
|
262
|
my ($input, $allow_partial) = @_; |
530
|
|
|
|
|
|
|
return unless defined $input; |
531
|
139
|
|
|
|
|
732
|
|
532
|
139
|
100
|
|
|
|
280
|
$input =~ s{\A\s+|\s+\z}{}gmxs; |
533
|
|
|
|
|
|
|
return [] unless length $input; |
534
|
138
|
|
|
|
|
585
|
|
535
|
138
|
|
|
|
|
268
|
my $sq = qr{(?mxs: ' [^']* ' )}mxs; |
536
|
138
|
|
|
|
|
247
|
my $dq = qr{(?mxs: " (?:[^\\"] | \\.)* " )}mxs; |
537
|
138
|
|
|
|
|
1353
|
my $ud = qr{(?mxs: \w+ )}mxs; |
538
|
|
|
|
|
|
|
my $chunk = qr{(?mxs: $sq | $dq | $ud)+}mxs; |
539
|
|
|
|
|
|
|
|
540
|
138
|
|
|
|
|
263
|
# save and reset current pos() on $input |
541
|
138
|
|
|
|
|
264
|
my $prepos = pos($input); |
542
|
|
|
|
|
|
|
pos($input) = undef; |
543
|
138
|
|
|
|
|
204
|
|
544
|
|
|
|
|
|
|
my @path; |
545
|
138
|
|
|
|
|
1929
|
## no critic (RegularExpressions::ProhibitCaptureWithoutTest) |
546
|
|
|
|
|
|
|
push @path, $1 while $input =~ m{\G [.]? ($chunk) }cgmxs; |
547
|
|
|
|
|
|
|
## use critic |
548
|
|
|
|
|
|
|
|
549
|
138
|
|
|
|
|
241
|
# save and restore pos() on $input |
550
|
138
|
|
|
|
|
211
|
my $postpos = pos($input); |
551
|
|
|
|
|
|
|
pos($input) = $prepos; |
552
|
138
|
100
|
|
|
|
383
|
|
553
|
111
|
100
|
100
|
|
|
483
|
return unless defined $postpos; |
554
|
|
|
|
|
|
|
return if ($postpos != length($input)) && ! ($allow_partial); |
555
|
|
|
|
|
|
|
|
556
|
85
|
|
|
|
|
136
|
# cleanup @path components |
557
|
151
|
|
|
|
|
180
|
for my $part (@path) { |
558
|
151
|
|
100
|
|
|
453
|
my @subparts; |
559
|
151
|
100
|
|
|
|
1829
|
while ((pos($part) || 0) < length($part)) { |
|
|
100
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
560
|
21
|
|
|
|
|
81
|
if ($part =~ m{\G ($sq) }cgmxs) { |
561
|
|
|
|
|
|
|
push @subparts, substr $1, 1, length($1) - 2; |
562
|
|
|
|
|
|
|
} |
563
|
16
|
|
|
|
|
39
|
elsif ($part =~ m{\G ($dq) }cgmxs) { |
564
|
16
|
|
|
|
|
43
|
my $subpart = substr $1, 1, length($1) - 2; |
565
|
16
|
|
|
|
|
47
|
$subpart =~ s{\\(.)}{$1}gmxs; |
566
|
|
|
|
|
|
|
push @subparts, $subpart; |
567
|
|
|
|
|
|
|
} |
568
|
114
|
|
|
|
|
413
|
elsif ($part =~ m{\G ($ud) }cgmxs) { |
569
|
|
|
|
|
|
|
push @subparts, $1; |
570
|
|
|
|
|
|
|
} |
571
|
0
|
|
|
|
|
0
|
else { # shouldn't happen ever |
572
|
|
|
|
|
|
|
return; |
573
|
|
|
|
|
|
|
} |
574
|
151
|
|
|
|
|
367
|
} ## end while ((pos($part) || 0) ...) |
575
|
|
|
|
|
|
|
$part = join '', @subparts; |
576
|
|
|
|
|
|
|
} ## end for my $part (@path) |
577
|
85
|
100
|
66
|
|
|
185
|
|
578
|
83
|
|
|
|
|
312
|
return (\@path, $postpos) if $allow_partial && wantarray; |
579
|
|
|
|
|
|
|
return \@path; |
580
|
|
|
|
|
|
|
} ## end sub crumble |
581
|
|
|
|
|
|
|
|
582
|
32
|
|
|
33
|
|
47
|
sub _variable { |
583
|
32
|
|
|
|
|
48
|
my $path = shift; |
584
|
32
|
|
|
|
|
43
|
my $DQ = q<">; # double quotes |
|
48
|
|
|
|
|
146
|
|
|
32
|
|
|
|
|
64
|
|
585
|
|
|
|
|
|
|
$path = join ', ', map { $DQ . quotemeta($_) . $DQ } @{$path}; |
586
|
32
|
|
|
|
|
103
|
|
587
|
|
|
|
|
|
|
return <<"END_OF_CHUNK"; |
588
|
|
|
|
|
|
|
### Variable from the stash (\$V) |
589
|
|
|
|
|
|
|
P(V([$path])); |
590
|
|
|
|
|
|
|
|
591
|
|
|
|
|
|
|
END_OF_CHUNK |
592
|
|
|
|
|
|
|
} ## end sub _variable |
593
|
|
|
|
|
|
|
|
594
|
24
|
|
|
25
|
|
53
|
sub _expression { |
595
|
24
|
|
|
|
|
81
|
my $expression = shift; |
596
|
|
|
|
|
|
|
return <<"END_OF_CHUNK"; |
597
|
|
|
|
|
|
|
# Expression to be evaluated and printed out |
598
|
|
|
|
|
|
|
{ |
599
|
|
|
|
|
|
|
my \$value = do {{ |
600
|
|
|
|
|
|
|
$expression |
601
|
|
|
|
|
|
|
}}; |
602
|
|
|
|
|
|
|
P(\$value) if defined \$value; |
603
|
|
|
|
|
|
|
} |
604
|
|
|
|
|
|
|
|
605
|
|
|
|
|
|
|
END_OF_CHUNK |
606
|
|
|
|
|
|
|
|
607
|
|
|
|
|
|
|
} ## end sub _expression |
608
|
|
|
|
|
|
|
|
609
|
|
|
|
|
|
|
1; |