File Coverage

blib/lib/Template/Perlish.pm
Criterion Covered Total %
statement 302 311 97.1
branch 120 144 83.3
condition 39 46 84.7
subroutine 51 51 100.0
pod 13 13 100.0
total 525 565 92.9


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;