File Coverage

blib/lib/Text/Template/Simple/Base/Compiler.pm
Criterion Covered Total %
statement 118 126 93.6
branch 51 72 70.8
condition 32 48 66.6
subroutine 12 12 100.0
pod n/a
total 213 258 82.5


line stmt bran cond sub pod time code
1             ## no critic (ProhibitUnusedPrivateSubroutines)
2             package Text::Template::Simple::Base::Compiler;
3 62     62   502 use strict;
  62         155  
  62         2972  
4 62     62   363 use warnings;
  62         218  
  62         3442  
5              
6 62     62   539 use Text::Template::Simple::Util qw(:all);
  62         133  
  62         26385  
7 62     62   788 use Text::Template::Simple::Constants qw(:all);
  62         141  
  62         207795  
8              
9             our $VERSION = '0.86';
10              
11             sub _init_compile_opts {
12 506     506   1164 my $self = shift;
13 506   100     2321 my $opt = shift || {};
14              
15 506 50       2445 fatal('tts.base.compiler._compile.opt') if ! ishref( $opt );
16              
17             # set defaults
18 506   100     3788 $opt->{id} ||= EMPTY_STRING; # id is AUTO
19 506   100     4196 $opt->{map_keys} ||= 0; # use normal behavior
20 506   100     2093 $opt->{chkmt} ||= 0; # check mtime of file template?
21 506   100     1914 $opt->{_sub_inc} ||= 0; # are we called from a dynamic include op?
22 506   100     3291 $opt->{_filter} ||= EMPTY_STRING; # any filters?
23              
24             # first element is the shared names. if it's not defined, then there
25             # are no shared variables from top level
26 506 100 100     3849 if ( isaref($opt->{_share}) && ! defined $opt->{_share}[0] ) {
27 12         35 delete $opt->{_share};
28             }
29              
30 506   100     3575 $opt->{as_is} = $opt->{_sub_inc} && $opt->{_sub_inc} == T_STATIC;
31              
32 506         1972 return $opt;
33             }
34              
35             sub _validate_chkmt {
36 250     250   678 my($self, $chkmt_ref, $tmpx) = @_;
37 250         955 ${$chkmt_ref} = $self->[TYPE] eq 'FILE'
38             ? (stat $tmpx)[STAT_MTIME]
39 250 100       11098 : do {
40 2 50       11 DEBUG && LOG( DISABLE_MT =>
41             'Disabling chkmt. Template is not a file');
42 2         6 0;
43             };
44 250         648 return;
45             }
46              
47             sub _compile_cache {
48 18     18   49 my($self, $tmp, $opt, $id_ref, $code_ref) = @_;
49 18         45 my $method = $opt->{id};
50 18   66     80 my $auto_id = ! $method || $method eq 'AUTO';
51 18 100       83 ${ $id_ref } = $self->connector('Cache::ID')->new->generate(
  18         53  
52             $auto_id ? ( $tmp ) : ( $method, 'custom' )
53             );
54              
55             # prevent overwriting the compiled version in cache
56             # since we need the non-compiled version
57 18 50       90 ${ $id_ref } .= '_1' if $opt->{as_is};
  0         0  
58              
59 18         118 ${ $code_ref } = $self->cache->hit( ${$id_ref}, $opt->{chkmt} );
  18         47  
  18         139  
60 18 50 33     78 LOG( CACHE_HIT => ${$id_ref} ) if DEBUG && ${$code_ref};
  0         0  
  0         0  
61 18         51 return;
62             }
63              
64             sub _compile {
65 506     506   2830 my $self = shift;
66 506   33     3411 my $tmpx = shift || fatal('tts.base.compiler._compile.notmp');
67 506   100     3103 my $param = shift || [];
68 506         2678 my $opt = $self->_init_compile_opts( shift );
69              
70 506 50       2119 fatal('tts.base.compiler._compile.param') if ! isaref($param);
71              
72 506         5063 my $tmp = $self->_examine( $tmpx );
73 502 50       2212 return $tmp if $self->[TYPE] eq 'ERROR';
74              
75 502 100       2054 if ( $opt->{_sub_inc} ) {
76             # TODO:generate a single error handler for includes, merge with _include()
77             # tmpx is a "file" included from an upper level compile()
78 266         1381 my $etitle = $self->_include_error( T_DYNAMIC );
79 266         1200 my $exists = $self->io->file_exists( $tmpx );
80 266 50       4812 return $etitle . " '$tmpx' is not a file" if not $exists;
81             # TODO: remove this second call somehow, reduce to a single call
82 266         1394 $tmp = $self->_examine( $exists ); # re-examine
83 266         976 $self->[NEEDS_OBJECT]++; # interpolated includes will need that
84             }
85              
86 502 100       14972 $self->_validate_chkmt( \$opt->{chkmt}, $tmpx ) if $opt->{chkmt};
87              
88 502 50 33     2003 LOG( COMPILE => $opt->{id} ) if DEBUG && defined $opt->{id};
89              
90 502         1260 my $cache_id = EMPTY_STRING;
91              
92 502         1452 my($CODE);
93 502 100       1747 $self->_compile_cache( $tmp, $opt, \$cache_id, \$CODE ) if $self->[CACHE];
94              
95 502         4212 $self->cache->id( $cache_id ); # if $cache_id;
96 502 100       2792 $self->[FILENAME] = $self->[TYPE] eq 'FILE' ? $tmpx : $self->cache->id;
97              
98 502 100       5653 my($shead, @sparam) = $opt->{_share} ? @{$opt->{_share}} : ();
  6         25  
99              
100 502 50 33     1482 LOG(
101             SHARED_VARS => "Adding shared variables ($shead) from a dynamic include"
102             ) if DEBUG && $shead;
103              
104 502 100       3182 $CODE = $self->_cache_miss( $cache_id, $shead, \@sparam, $opt, $tmp ) if ! $CODE;
105              
106 502         1098 my @args;
107 502 100       1914 push @args, $self if $self->[NEEDS_OBJECT]; # must be the first
108 502 100       1880 push @args, @sparam if @sparam;
109 502 100       1669 push @args, @{ $self->[ADD_ARGS] } if $self->[ADD_ARGS];
  12         512  
110 502         896 push @args, @{ $param };
  502         1177  
111 502         16798 my $out = $CODE->( @args );
112              
113 500 100       20107 $self->_call_filters( \$out, split RE_FILTER_SPLIT, $opt->{_filter} )
114             if $opt->{_filter};
115              
116 500         20859 return $out;
117             }
118              
119             sub _cache_miss {
120 498     498   1330 my($self, $cache_id, $shead, $sparam, $opt, $tmp) = @_;
121             # we have a cache miss; parse and compile
122 498 50       1542 LOG( CACHE_MISS => $cache_id ) if DEBUG;
123              
124 498         1142 my $restore_header;
125 498 100       2266 if ( $shead ) {
126 6         14 my $param_x = join q{,}, ('shift') x @{ $sparam };
  6         128  
127 6         29 my $shared = sprintf q~my(%s) = (%s);~, $shead, $param_x;
128 6         16 $restore_header = $self->[HEADER];
129 6   50     48 $self->[HEADER] = $shared . q{;} . ( $self->[HEADER] || EMPTY_STRING );
130             }
131              
132 498         826 my %popt = ( %{ $opt }, cache_id => $cache_id, as_is => $opt->{as_is} );
  498         5591  
133 498         6901 my $parsed = $self->_parse( $tmp, \%popt );
134 498         4042 my $CODE = $self->cache->populate( $cache_id, $parsed, $opt->{chkmt} );
135 498 100       1420 $self->[HEADER] = $restore_header if $shead;
136 498         11645 return $CODE;
137             }
138              
139             sub _call_filters {
140 4     4   12 my($self, $oref, @filters) = @_;
141 4         10 my $fname = $self->[FILENAME];
142              
143 4         10 APPLY_FILTERS: foreach my $filter ( @filters ) {
144 6         93 my $fref = DUMMY_CLASS->can( 'filter_' . $filter );
145 6 50       22 if ( ! $fref ) {
146 0         0 ${$oref} .= "\n[ filter warning ] Can not apply undefined filter"
  0         0  
147             . " $filter to $fname\n";
148 0         0 next;
149             }
150 6         23 $fref->( $self, $oref );
151             }
152              
153 4         57 return;
154             }
155              
156             sub _wrap_compile {
157 500     500   939 my $self = shift;
158 500 50       2478 my $parsed = shift or fatal('tts.base.compiler._wrap_compile.parsed');
159 500 50 33     3971 LOG( CACHE_ID => $self->cache->id ) if $self->[WARN_IDS] && $self->cache->id;
160 500 0       1868 LOG( COMPILER => $self->[SAFE] ? 'Safe' : 'Normal' ) if DEBUG;
    50          
161 500         767 my($CODE, $error);
162              
163 500 100       2073 my $compiler = $self->[SAFE] ? COMPILER_SAFE : COMPILER;
164              
165 500         47195 $CODE = $compiler->compile( $parsed );
166              
167 500 50       6607 if( $error = $@ ) {
168 0         0 my $error2;
169 0 0       0 $error .= $error2 if $error2;
170             }
171              
172 500         3406 return $CODE, $error;
173             }
174              
175             sub _mini_compiler {
176             # little dumb compiler for internal templates
177 280     280   553 my $self = shift;
178 280   33     1019 my $template = shift || fatal('tts.base.compiler._mini_compiler.notmp');
179 280   33     974 my $param = shift || fatal('tts.base.compiler._mini_compiler.noparam');
180 280   100     818 my $opt = shift || {};
181              
182 280 50       1019 fatal('tts.base.compiler._mini_compiler.opt') if ! ishref($opt );
183 280 50       1236 fatal('tts.base.compiler._mini_compiler.param') if ! ishref($param);
184              
185 280         553 foreach my $var ( keys %{ $param } ) {
  280         2061  
186 898         2159 my $str = $param->{$var};
187 898         15738 $template =~ s{<%\Q$var\E%>}{$str}xmsg;
188             }
189              
190 280 100       7254 $template =~ s{\s+}{ }xmsg if $opt->{flatten}; # remove extra spaces
191 280         1530 return $template;
192             }
193              
194             1;
195              
196             __END__
197              
198             =pod
199              
200             =head1 NAME
201              
202             Text::Template::Simple::Base::Compiler - Base class for Text::Template::Simple
203              
204             =head1 SYNOPSIS
205              
206             Private module.
207              
208             =head1 DESCRIPTION
209              
210             This document describes version C<0.86> of C<Text::Template::Simple::Base::Compiler>
211             released on C<5 March 2012>.
212              
213             Private module.
214              
215             =head1 AUTHOR
216              
217             Burak Gursoy <burak@cpan.org>.
218              
219             =head1 COPYRIGHT
220              
221             Copyright 2004 - 2012 Burak Gursoy. All rights reserved.
222              
223             =head1 LICENSE
224              
225             This library is free software; you can redistribute it and/or modify
226             it under the same terms as Perl itself, either Perl version 5.12.3 or,
227             at your option, any later version of Perl 5 you may have available.
228              
229             =cut