File Coverage

blib/lib/Text/Template/Simple/Base/Include.pm
Criterion Covered Total %
statement 103 115 89.5
branch 38 48 79.1
condition 5 9 55.5
subroutine 16 17 94.1
pod 1 1 100.0
total 163 190 85.7


line stmt bran cond sub pod time code
1             ## no critic (ProhibitUnusedPrivateSubroutines)
2             package Text::Template::Simple::Base::Include;
3 62     62   525 use strict;
  62         141  
  62         2305  
4 62     62   393 use warnings;
  62         128  
  62         2690  
5              
6 62     62   5999 use Text::Template::Simple::Util qw(:all);
  62         135  
  62         13609  
7 62     62   404 use Text::Template::Simple::Constants qw(:all);
  62         229  
  62         51343  
8 62         7397 use constant E_IN_MONOLITH =>
9             'qq~%s Interpolated includes don\'t work under monolith option. '
10             .'Please disable monolith and use the \'SHARE\' directive in the include '
11 62     62   2037 .'command: %s~';
  62         129  
12 62     62   394 use constant E_IN_DIR => q(q~%s '%s' is a directory~);
  62         130  
  62         13059  
13 62     62   370 use constant E_IN_SLURP => 'q~%s %s~';
  62         129  
  62         5582  
14 62         190026 use constant TYPE_MAP => qw(
15             @ ARRAY
16             % HASH
17             * GLOB
18             \ REFERENCE
19 62     62   377 );
  62         161  
20              
21             our $VERSION = '0.86';
22              
23             sub _include_no_monolith {
24             # no monolith eh?
25 248     248   548 my($self, $type, $file, $opt) = @_;
26              
27 248         1369 my $rv = $self->_mini_compiler(
28             $self->_internal('no_monolith') => {
29             OBJECT => $self->[FAKER_SELF],
30             FILE => escape(q{~} => $file),
31             TYPE => escape(q{~} => $type),
32             } => {
33             flatten => 1,
34             }
35             );
36 248         3358 ++$self->[NEEDS_OBJECT];
37 248         1045 return $rv;
38             }
39              
40             sub _include_static {
41 18     18   63 my($self, $file, $text, $err, $opt) = @_;
42 18 50       162 return $self->[MONOLITH]
43             ? sprintf('q~%s~;', escape(q{~} => $text))
44             : $self->_include_no_monolith( T_STATIC, $file, $opt )
45             ;
46             }
47              
48             sub _include_dynamic {
49 236     236   636 my($self, $file, $text, $err, $opt) = @_;
50 236         441 my $rv = EMPTY_STRING;
51              
52 236         487 ++$self->[INSIDE_INCLUDE];
53 236   100     1089 $self->[COUNTER_INCLUDE] ||= {};
54              
55             # ++$self->[COUNTER_INCLUDE]{ $file } if $self->[TYPE_FILE] eq $file;
56              
57 236 100       2734 if ( ++$self->[COUNTER_INCLUDE]{ $file } >= MAX_RECURSION ) {
58             # failsafe
59 2         6 $self->[DEEP_RECURSION] = 1;
60 2 50       7 LOG( DEEP_RECURSION => $file ) if DEBUG;
61 2         12 my $w = L( warning => 'tts.base.include.dynamic.recursion',
62             $err, MAX_RECURSION, $file );
63 2         8 $rv .= sprintf 'q~%s~', escape( q{~} => $w );
64             }
65             else {
66             # local stuff is for file name access through $0 in templates
67 234 100       1519 $rv .= $self->[MONOLITH]
68             ? $self->_include_dynamic_monolith( $file, $text )
69             : $self->_include_no_monolith( T_DYNAMIC, $file, $opt )
70             ;
71             }
72              
73 236         677 --$self->[INSIDE_INCLUDE]; # critical: always adjust this
74 236         2236 return $rv;
75             }
76              
77             sub _include_dynamic_monolith {
78 4     4   39 my($self,$file, $text) = @_;
79 4         11 my $old = $self->[FILENAME];
80 4         8 $self->[FILENAME] = $file;
81 4         87 my $result = $self->_parse( $text );
82 4         10 $self->[FILENAME] = $old;
83 4         21 return $result;
84             }
85              
86             sub include {
87 274     274 1 4396 my $self = shift;
88 274   50     813 my $type = shift || 0;
89 274         495 my $file = shift;
90 274         498 my $opt = shift;
91 274 100       762 my $is_static = T_STATIC == $type ? 1 : 0;
92 274 100       716 my $is_dynamic = T_DYNAMIC == $type ? 1 : 0;
93 274   66     2577 my $known = $is_static || $is_dynamic;
94              
95 274 50       889 fatal('tts.base.include._include.unknown', $type) if not $known;
96              
97 274         2334 $file = trim $file;
98              
99 274         4508 my $err = $self->_include_error( $type );
100 274         1141 my $exists = $self->io->file_exists( $file );
101 274         618 my $interpolate;
102              
103 274 100       790 if ( $exists ) {
104 254         490 $file = $exists; # file path correction
105             }
106             else {
107 20         39 $interpolate = 1; # just guessing ...
108 20 100       91 return sprintf E_IN_MONOLITH, $err, $file if $self->[MONOLITH];
109             }
110              
111 272 50       2660 if ( $self->io->is_dir( $file ) ) {
112 0         0 return sprintf E_IN_DIR, $err, escape(q{~} => $file);
113             }
114              
115 272 50       1188 $self->_debug_include_type( $file, $type ) if DEBUG;
116              
117 272 100       779 if ( $interpolate ) {
118 18         139 my $rv = $self->_interpolate( $file, $type );
119 18         89 $self->[NEEDS_OBJECT]++;
120 18 50       63 LOG(INTERPOLATE_INC => "TYPE: $type; DATA: $file; RV: $rv") if DEBUG;
121 18         115 return $rv;
122             }
123              
124 254         580 my $text = eval { $self->io->slurp($file); };
  254         1040  
125 254 50       874 if ( $@ ) {
126 0         0 return sprintf E_IN_SLURP, $err, $@;
127             }
128              
129 254 100       1077 my $meth = '_include_' . ($is_dynamic ? 'dynamic' : 'static');
130 254         1662 return $self->$meth( $file, $text, $err, $opt );
131             }
132              
133             sub _debug_include_type {
134 0     0   0 my($self, $file, $type) = @_;
135 0         0 require Text::Template::Simple::Tokenizer;
136 0         0 my $toke = Text::Template::Simple::Tokenizer->new(
137 0         0 @{ $self->[DELIMITERS] },
138             $self->[PRE_CHOMP],
139             $self->[POST_CHOMP]
140             );
141 0         0 LOG( INCLUDE => $toke->_visualize_tid($type) . " => '$file'" );
142 0         0 return;
143             }
144              
145             sub _interpolate {
146 18     18   33 my $self = shift;
147 18         45 my $file = shift;
148 18         26 my $type = shift;
149 18         55 my $etitle = $self->_include_error($type);
150              
151             # so that, you can pass parameters, apply filters etc.
152 18         150 my %inc = (INCLUDE => map { trim $_ } split RE_PIPE_SPLIT, $file );
  42         152  
153              
154 18 100       77 if ( $self->io->file_exists( $inc{INCLUDE} ) ) {
155             # well... constantly working around :p
156 10         45 $inc{INCLUDE} = qq{'$inc{INCLUDE}'};
157             }
158              
159             # die "You can not pass parameters to static includes"
160             # if $inc{PARAM} && T_STATIC == $type;
161              
162              
163 18 100       103 $self->_interpolate_share_setup( \%inc ) if $inc{SHARE};
164              
165 18 100       86 my $share = $inc{SHARE} ? sprintf(q{'%s', %s}, ($inc{SHARE}) x 2) : 'undef';
166 18 100       67 my $filter = $inc{FILTER} ? escape( q{'} => $inc{FILTER} ) : EMPTY_STRING;
167              
168             return
169 18 100       376 $self->_mini_compiler(
170             $self->_internal('sub_include') => {
171             OBJECT => $self->[FAKER_SELF],
172             INCLUDE => escape( q{'} => $inc{INCLUDE} ),
173             ERROR_TITLE => escape( q{'} => $etitle ),
174             TYPE => $type,
175             PARAMS => $inc{PARAM} ? qq{[$inc{PARAM}]} : 'undef',
176             FILTER => $filter,
177             SHARE => $share,
178             } => {
179             flatten => 1,
180             }
181             );
182             }
183              
184             sub _interpolate_share_setup {
185 6     6   14 my($self, $inc) = @_;
186 6         42 my @vars = map { trim $_ } split RE_FILTER_SPLIT, $inc->{SHARE};
  10         28  
187 6         48 my %type = TYPE_MAP;
188 6         12 my @buf;
189 6         15 foreach my $var ( @vars ) {
190 10 50       49 if ( $var !~ m{ \A \$ }xms ) {
191 0         0 my($char) = $var =~ m{ \A (.) }xms;
192 0   0     0 my $type_name = $type{ $char } || '<UNKNOWN>';
193 0         0 fatal('tts.base.include._interpolate.bogus_share', $type_name, $var);
194             }
195 10         24 $var =~ tr/;//d;
196 10 50       40 if ( $var =~ m{ [^a-zA-Z0-9_\$] }xms ) {
197 0         0 fatal('tts.base.include._interpolate.bogus_share_notbare', $var);
198             }
199 10         30 push @buf, $var;
200             }
201 6         24 $inc->{SHARE} = join q{,}, @buf;
202 6         23 return;
203             }
204              
205             sub _include_error {
206 558     558   1765 my($self, $type) = @_;
207 558 50       11551 my $val = T_DYNAMIC == $type ? 'dynamic'
    100          
208             : T_STATIC == $type ? 'static'
209             : 'unknown'
210             ;
211 558         3523 return sprintf '[ %s include error ]', $val;
212             }
213              
214             1;
215              
216             __END__
217              
218             =head1 NAME
219              
220             Text::Template::Simple::Base::Include - Base class for Text::Template::Simple
221              
222             =head1 SYNOPSIS
223              
224             Private module.
225              
226             =head1 METHODS
227              
228             =head2 include
229              
230             =head1 DESCRIPTION
231              
232             This document describes version C<0.86> of C<Text::Template::Simple::Base::Include>
233             released on C<5 March 2012>.
234              
235             Private module.
236              
237             =head1 AUTHOR
238              
239             Burak Gursoy <burak@cpan.org>.
240              
241             =head1 COPYRIGHT
242              
243             Copyright 2004 - 2012 Burak Gursoy. All rights reserved.
244              
245             =head1 LICENSE
246              
247             This library is free software; you can redistribute it and/or modify
248             it under the same terms as Perl itself, either Perl version 5.12.3 or,
249             at your option, any later version of Perl 5 you may have available.
250              
251             =cut