File Coverage

blib/lib/Text/Template/Simple/Base/Parser.pm
Criterion Covered Total %
statement 147 153 96.0
branch 67 92 72.8
condition 26 34 76.4
subroutine 24 25 96.0
pod n/a
total 264 304 86.8


line stmt bran cond sub pod time code
1             ## no critic (ProhibitUnusedPrivateSubroutines)
2             package Text::Template::Simple::Base::Parser;
3 62     62   518 use strict;
  62         140  
  62         2776  
4 62     62   455 use warnings;
  62         155  
  62         8175  
5              
6             our $VERSION = '0.86';
7              
8 62     62   389 use Text::Template::Simple::Util qw(:all);
  62         299  
  62         30936  
9 62     62   543 use Text::Template::Simple::Constants qw(:all);
  62         141  
  62         58481  
10 62     62   1801 use constant MAPKEY_NUM => 5;
  62         178  
  62         282321  
11              
12             my %INTERNAL = __PACKAGE__->_set_internal_templates;
13              
14             sub _needs_object {
15 274     274   525 my $self = shift;
16 274         601 $self->[NEEDS_OBJECT]++;
17 274         2107 return $self;
18             }
19              
20             sub _internal {
21 280     280   1013 my $self = shift;
22 280   33     846 my $id = shift || fatal('tts.base.parser._internal.id');
23 280   33     47998 my $rv = $INTERNAL{ $id } || fatal('tts.base.parser._internal.id');
24 280 50       942 LOG( INTERNAL => "TEMPLATE: $id" ) if DEBUG;
25 280         1651 return $rv;
26             }
27              
28             sub _parse {
29 502     502   1177 my($self, $raw, $opt) = @_;
30              
31             # $opt->
32             # map_keys: code sections are hash keys
33             # as_is : i.e.: do not parse -> static include
34              
35             #$self->[NEEDS_OBJECT] = 0; # reset
36              
37 502         2036 my($ds, $de) = @{ $self->[DELIMITERS] };
  502         1724  
38 502 100       3877 my $faker = $self->[INSIDE_INCLUDE] ? $self->_output_buffer_var
39             : $self->[FAKER]
40             ;
41 502         14914 my $buf_hash = $self->[FAKER_HASH];
42 502         3713 my($mko, $mkc) = $self->_parse_mapkeys( $opt->{map_keys}, $faker, $buf_hash );
43              
44 502 50       1961 LOG( RAW => $raw ) if DEBUG > DEBUG_LEVEL_INSANE;
45              
46             my $h = {
47 410     410   2470 raw => sub { ";$faker .= q~$_[0]~;" },
48 498     498   5445 capture => sub { ";$faker .= sub {" . $_[0] . '}->();'; },
49 70     70   325 code => sub { $_[0] . q{;} },
50 502         34969 };
51              
52             # little hack to convert delims into escaped delims for static inclusion
53 502 100       2977 $raw =~ s{\Q$ds}{$ds!}xmsg if $opt->{as_is};
54              
55 502         2495 my($code, $inside) = $self->_walk( $raw, $opt, $h, $mko, $mkc );
56              
57 502   100     2280 $self->[FILENAME] ||= '<ANON>';
58              
59 502 0       1691 fatal(
    50          
60             'tts.base.parser._parse.unbalanced',
61             abs($inside),
62             ($inside > 0 ? 'opening' : 'closing'),
63             $self->[FILENAME]
64             ) if $inside;
65              
66 502         3840 return $self->_wrapper( $code, $opt->{cache_id}, $faker, $opt->{map_keys}, $h );
67             }
68              
69             sub _walk {
70 502     502   1273 my($self, $raw, $opt, $h, $mko, $mkc) = @_;
71 502         1769 my $uth = $self->[USER_THANDLER];
72 502         1172 my $code = EMPTY_STRING;
73 502         1517 my $inside = 0;
74 502         6320 my $toke = $self->connector('Tokenizer')->new(
75 502         2655 @{ $self->[DELIMITERS] },
76             $self->[PRE_CHOMP],
77             $self->[POST_CHOMP]
78             );
79              
80 502 100   988   2576 my $is_raw = sub { my($id) = @_; T_RAW == $id || T_NOTADELIM == $id };
  988         1554  
  988         11872  
81 502 100   286   2453 my $is_inc = sub { my($id) = @_; T_DYNAMIC == $id || T_STATIC == $id };
  286         667  
  286         8631  
82              
83             # fetch and walk the tree
84 502         8041 PARSER: foreach my $token ( @{ $toke->tokenize( $raw, $opt->{map_keys} ) } ) {
  502         2881  
85 2190         4027 my($str, $id, $chomp, undef) = @{ $token };
  2190         6147  
86              
87 2190 50       6863 LOG( TOKEN => $toke->_visualize_tid($id) . " => $str" )
88             if DEBUG >= DEBUG_LEVEL_VERBOSE;
89              
90 2190 100 100     16560 next PARSER if T_DISCARD == $id || T_COMMENT == $id;
91              
92 2164 100       5717 if ( T_DELIMSTART == $id ) { $inside++; next PARSER; }
  588         986  
  588         4081  
93 1576 100       3865 if ( T_DELIMEND == $id ) { $inside--; next PARSER; }
  588         4007  
  588         2068  
94              
95             $code .= $is_raw->($id) ? $h->{raw }->( $self->_chomp( $str, $chomp ) )
96             : T_COMMAND == $id ? $h->{raw }->( $self->_parse_command( $str ) )
97 988 50       2603 : T_CODE == $id ? $h->{code }->( $str )
    100          
    100          
    100          
    100          
    100          
98             : T_CAPTURE == $id ? $h->{capture}->( $str )
99             : $is_inc->($id) ? $h->{capture}->( $self->_walk_inc( $opt, $id, $str) )
100             : T_MAPKEY == $id ? $self->_walk_mapkey( $mko, $mkc, $str )
101             : $self->_walk_unknown( $h, $uth, $id, $str )
102             ;
103             }
104 502         15847 return $code, $inside;
105             }
106              
107             sub _walk_mapkey {
108 12     12   29 my($self, $mko, $mkc, $str) = @_;
109 12 50       104 return sprintf $mko, $mkc ? ( ($str) x MAPKEY_NUM ) : $str;
110             }
111              
112             sub _walk_inc {
113 274     274   699 my($self, $opt, $id, $str) = @_;
114 274         11893 return $self->_needs_object->include($id, $str, $opt);
115             }
116              
117             sub _walk_unknown {
118 0     0   0 my($self, $h, $uth, $id, $str) = @_;
119 0 0       0 if ( DEBUG ) {
120 0 0       0 LOG(
121             $uth ? ( USER_THANDLER => "$id" )
122             : ( UNKNOWN_TOKEN => "Adding unknown token as RAW: $id($str)" )
123             );
124             }
125              
126 0 0       0 return $uth ? $uth->( $self, $id ,$str, $h ) : $h->{raw}->( $str );
127             }
128              
129             sub _parse_command {
130 2     2   3 my $self = shift;
131 2         3 my $str = shift;
132 2         15 my($head, $raw_block) = split m{;}xms, $str, 2;
133 2         10 my @buf = split RE_PIPE_SPLIT, q{|} . trim($head);
134 2         4 shift @buf;
135 2         5 my %com = map { trim $_ } @buf;
  4         8  
136              
137 2 50       12 if ( DEBUG >= DEBUG_LEVEL_INSANE ) {
138 0         0 require Data::Dumper;
139 0         0 LOG(
140             PARSE_COMMAND => Data::Dumper::Dumper(
141             {
142             string => $str,
143             header => $head,
144             raw => $raw_block,
145             command => \%com,
146             }
147             )
148             );
149             }
150              
151 2 50       13 if ( $com{FILTER} ) {
152             # embed into the template & NEEDS_OBJECT++ ???
153 2         10 my $old = $self->[FILENAME];
154 2         6 $self->[FILENAME] = '<ANON BLOCK>';
155 2         22 $self->_call_filters( \$raw_block, split RE_FILTER_SPLIT, $com{FILTER} );
156 2         5 $self->[FILENAME] = $old;
157             }
158              
159 2         8 return $raw_block;
160             }
161              
162             sub _chomp {
163             # remove the unnecessary white space
164 408     408   1071 my($self, $str, $chomp) = @_;
165              
166             # NEXT: discard: left; right -> left
167             # PREV: discard: right; left -> right
168 408         756 my($next, $prev) = @{ $chomp };
  408         926  
169 408   100     1682 $next ||= CHOMP_NONE;
170 408   100     1703 $prev ||= CHOMP_NONE;
171              
172 408   100     1897 my $left_collapse = ( $next & COLLAPSE_ALL ) || ( $next & COLLAPSE_RIGHT);
173 408   100     1825 my $left_chomp = ( $next & CHOMP_ALL ) || ( $next & CHOMP_RIGHT );
174              
175 408   100     1600 my $right_collapse = ( $prev & COLLAPSE_ALL ) || ( $prev & COLLAPSE_LEFT );
176 408   100     1667 my $right_chomp = ( $prev & CHOMP_ALL ) || ( $prev & CHOMP_LEFT );
177              
178 408 100       1378 $str = $left_collapse ? ltrim($str, q{ })
    100          
179             : $left_chomp ? ltrim($str)
180             : $str
181             ;
182              
183 408 100       1193 $str = $right_collapse ? rtrim($str, q{ })
    100          
184             : $right_chomp ? rtrim($str)
185             : $str
186             ;
187              
188 408         13363 return $str;
189             }
190              
191             sub _wrapper {
192             # this'll be tricky to re-implement around a template
193 502     502   1319 my($self, $code, $cache_id, $faker, $map_keys, $h) = @_;
194 502         1607 my $buf_hash = $self->[FAKER_HASH];
195 502         1099 my $wrapper = EMPTY_STRING;
196 502 100       1580 my $inside_inc = $self->[INSIDE_INCLUDE] != RESET_FIELD ? 1 : 0;
197              
198             # build the anonymous sub
199 502 100       1673 if ( ! $inside_inc ) {
200             # don't duplicate these if we're including something
201 498         12179 $wrapper .= 'package ' . DUMMY_CLASS . q{;};
202 498 50       1849 $wrapper .= 'use strict;' if $self->[STRICT];
203             }
204 502         1069 $wrapper .= 'sub { ';
205 502         2355 $wrapper .= sprintf q~local $0 = '%s';~, escape( q{'} => $self->[FILENAME] );
206 502 100       2508 if ( $self->[NEEDS_OBJECT] ) {
207 418         629 --$self->[NEEDS_OBJECT];
208 418         1800 $wrapper .= 'my ' . $self->[FAKER_SELF] . ' = shift;';
209             }
210 502 100       1691 $wrapper .= $self->[HEADER].q{;} if $self->[HEADER];
211 502         1356 $wrapper .= "my $faker = '';";
212 502 100       3187 $wrapper .= $self->_add_stack( $cache_id ) if $self->[STACK];
213 502 100       1343 $wrapper .= "my $buf_hash = {\@_};" if $map_keys;
214 502 100       1421 $wrapper .= $self->_add_sigwarn if $self->[CAPTURE_WARNINGS];
215 502         1899 $wrapper .= "\n#line 1 " . $self->[FILENAME] . "\n";
216 502         1539 $wrapper .= $code . q{;};
217 502 100       2010 $wrapper .= $self->_dump_sigwarn($h) if $self->[CAPTURE_WARNINGS];
218 502         1286 $wrapper .= "return $faker;";
219 502         9921 $wrapper .= '}';
220             # make this a capture sub if we're including
221 502 100       1372 $wrapper .= '->()' if $inside_inc;
222              
223 502 50       1543 LOG( COMPILED => $self->_mini_compiler(
224             $self->_internal('fragment'),
225             { FRAGMENT => $self->_tidy($wrapper) }
226             )
227             ) if DEBUG >= DEBUG_LEVEL_VERBOSE;
228             #LOG( OUTPUT => $wrapper );
229             # reset
230 502         1282 $self->[DEEP_RECURSION] = 0; # reset
231 502         10171 return $wrapper;
232             }
233              
234             sub _parse_mapkeys {
235 502     502   2324 my($self, $map_keys, $faker, $buf_hash) = @_;
236 502 100       3008 return( undef, undef ) if ! $map_keys;
237              
238 4         17 my $mkc = $map_keys eq 'check';
239 4         10 my $mki = $map_keys eq 'init';
240 4 50       24 my $t = $mki ? 'map_keys_init'
    50          
241             : $mkc ? 'map_keys_check'
242             : 'map_keys_default'
243             ;
244 4         67 my $mko = $self->_mini_compiler(
245             $self->_internal( $t ) => {
246             BUF => $faker,
247             HASH => $buf_hash,
248             KEY => '%s',
249             } => {
250             flatten => 1,
251             }
252             );
253 4         27 return $mko, $mkc;
254             }
255              
256             sub _add_sigwarn {
257 2     2   3 my $self = shift;
258 2         11 $self->[FAKER_WARN] = $self->_output_buffer_var('array');
259 2         29 my $rv = $self->_mini_compiler(
260             $self->_internal('add_sigwarn'),
261             { BUF => $self->[FAKER_WARN] },
262             { flatten => 1 }
263             );
264 2         10 return $rv;
265             }
266              
267             sub _dump_sigwarn {
268 2     2   3 my $self = shift;
269 2         4 my $h = shift;
270 2         9 my $rv = $h->{capture}->(
271             $self->_mini_compiler(
272             $self->_internal('dump_sigwarn'),
273             { BUF => $self->[FAKER_WARN] },
274             { flatten => 1 }
275             )
276             );
277 2         14 return $rv;
278             }
279              
280             sub _add_stack {
281 8     8   15 my $self = shift;
282 8   50     43 my $cs_name = shift || '<ANON TEMPLATE>';
283 8   50     31 my $stack = $self->[STACK] || EMPTY_STRING;
284              
285 8 50       35 return if lc($stack) eq 'off';
286              
287 8 50 33     72 my $check = ($stack eq '1' || $stack eq 'yes' || $stack eq 'on')
288             ? 'string'
289             : $stack
290             ;
291              
292 8         33 my($type, $channel) = split m{:}xms, $check;
293 8 0       27 $channel = ! $channel ? 'warn'
    50          
294             : $channel eq 'buffer' ? $self->[FAKER] . ' .= '
295             : 'warn'
296             ;
297              
298 8         19 foreach my $e ( $cs_name, $type, $channel ) {
299 24         55 $e =~ s{'}{\\'}xmsg;
300             }
301              
302 8         51 return "$channel stack( { type => '$type', name => '$cs_name' } );";
303             }
304              
305             sub _set_internal_templates {
306             return
307             # we need string eval in this template to catch syntax errors
308 62     62   914 sub_include => <<'TEMPLATE_CONSTANT',
309             <%OBJECT%>->_compile(
310             do {
311             local $@;
312             my $file = eval '<%INCLUDE%>';
313             my $rv;
314             if ( my $e = $@ ) {
315             chomp $e;
316             $file ||= '<%INCLUDE%>';
317             my $m = "The parameter ($file) is not a file. "
318             . "Error from sub-include ($file): $e";
319             $rv = [ ERROR => '<%ERROR_TITLE%> ' . $m ]
320             }
321             else {
322             $rv = $file;
323             }
324             $rv;
325             },
326             <%PARAMS%>,
327             {
328             _sub_inc => '<%TYPE%>',
329             _filter => '<%FILTER%>',
330             _share => [<%SHARE%>],
331             }
332             )
333             TEMPLATE_CONSTANT
334              
335             no_monolith => <<'TEMPLATE_CONSTANT',
336             <%OBJECT%>->compile(
337             q~<%FILE%>~,
338             undef,
339             {
340             chkmt => 1,
341             _sub_inc => q~<%TYPE%>~,
342             }
343             );
344             TEMPLATE_CONSTANT
345              
346             # see _parse()
347             map_keys_check => <<'TEMPLATE_CONSTANT',
348             <%BUF%> .= exists <%HASH%>->{"<%KEY%>"}
349             ? (
350             defined <%HASH%>->{"<%KEY%>"}
351             ? <%HASH%>->{"<%KEY%>"}
352             : "[ERROR] Key not defined: <%KEY%>"
353             )
354             : "[ERROR] Invalid key: <%KEY%>"
355             ;
356             TEMPLATE_CONSTANT
357              
358             map_keys_init => <<'TEMPLATE_CONSTANT',
359             <%BUF%> .= <%HASH%>->{"<%KEY%>"} || '';
360             TEMPLATE_CONSTANT
361              
362             map_keys_default => <<'TEMPLATE_CONSTANT',
363             <%BUF%> .= <%HASH%>->{"<%KEY%>"};
364             TEMPLATE_CONSTANT
365              
366             add_sigwarn => <<'TEMPLATE_CONSTANT',
367             my <%BUF%>;
368             local $SIG{__WARN__} = sub {
369             push @{ <%BUF%> }, $_[0];
370             };
371             TEMPLATE_CONSTANT
372              
373             dump_sigwarn => <<'TEMPLATE_CONSTANT',
374             join("\n",
375             map {
376             s{ \A \s+ }{}xms;
377             s{ \s+ \z }{}xms;
378             "[warning] $_\n"
379             } @{ <%BUF%> }
380             );
381             TEMPLATE_CONSTANT
382              
383             compile_error => <<'TEMPLATE_CONSTANT',
384             Error compiling code fragment (cache id: <%CID%>):
385              
386             <%ERROR%>
387             -------------------------------
388             PARSED CODE (VERBATIM):
389             -------------------------------
390              
391             <%PARSED%>
392              
393             -------------------------------
394             PARSED CODE (tidied):
395             -------------------------------
396              
397             <%TIDIED%>
398             TEMPLATE_CONSTANT
399              
400             fragment => <<'TEMPLATE_CONSTANT',
401              
402             # BEGIN TIDIED FRAGMENT
403              
404             <%FRAGMENT%>
405              
406             # END TIDIED FRAGMENT
407             TEMPLATE_CONSTANT
408              
409             disk_cache_comment => <<'TEMPLATE_CONSTANT',
410             # !!! W A R N I N G W A R N I N G W A R N I N G !!!
411             # This file was automatically generated by <%NAME%> on <%DATE%>.
412             # This file is a compiled template cache.
413             # Any changes you make here will be lost.
414             #
415             TEMPLATE_CONSTANT
416             }
417              
418             1;
419              
420             __END__
421              
422             =head1 NAME
423              
424             Text::Template::Simple::Base::Parser - Base class for Text::Template::Simple
425              
426             =head1 SYNOPSIS
427              
428             Private module.
429              
430             =head1 DESCRIPTION
431              
432             This document describes version C<0.86> of C<Text::Template::Simple::Base::Parser>
433             released on C<5 March 2012>.
434              
435             Private module.
436              
437             =begin CHOMPING
438              
439             The tokenizer uses a cursor to mark the chomping around a RAW token. Only RAW
440             tokens can be chomped. Basically, a RAW token can be imagined like this:
441              
442             _________
443             |N| |P|
444             |E| STR |R|
445             |X| |E|
446             |T| |V|
447             ---------
448              
449             It'll have two labels on sides and the content in the center. When a chomp
450             directive is placed to the left delimiter, this affects the previous RAW token
451             and when it is placed to the right delimiter, it'll affect the next RAW token.
452             If the previous or next is not raw, nothing will happen. You need to swap sides
453             when handling the chomping. i.e.: left chomping affects the right side of the
454             RAW, and right chomping affects the left side of the RAW. _chomp() method in
455             the parser swaps sides to handle chomping. See Text::Template::Simple::Tokenizer
456             to have an idea on how pre-parsing happens.
457              
458             =end CHOMPING
459              
460             =head1 AUTHOR
461              
462             Burak Gursoy <burak@cpan.org>.
463              
464             =head1 COPYRIGHT
465              
466             Copyright 2004 - 2012 Burak Gursoy. All rights reserved.
467              
468             =head1 LICENSE
469              
470             This library is free software; you can redistribute it and/or modify
471             it under the same terms as Perl itself, either Perl version 5.12.3 or,
472             at your option, any later version of Perl 5 you may have available.
473              
474             =cut