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 60     60   315 use strict;
  60         68  
  60         1384  
4 60     60   185 use warnings;
  60         62  
  60         1328  
5              
6 60     60   188 use Text::Template::Simple::Util qw(:all);
  60         65  
  60         6949  
7 60     60   260 use Text::Template::Simple::Constants qw(:all);
  60         63  
  60         21960  
8 60         3116 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 60     60   269 .'command: %s~';
  60         64  
12 60     60   217 use constant E_IN_DIR => q(q~%s '%s' is a directory~);
  60         68  
  60         2270  
13 60     60   195 use constant E_IN_SLURP => 'q~%s %s~';
  60         65  
  60         2522  
14 60         60058 use constant TYPE_MAP => qw(
15             @ ARRAY
16             % HASH
17             * GLOB
18             \ REFERENCE
19 60     60   220 );
  60         66  
20              
21             our $VERSION = '0.90';
22              
23             sub _include_no_monolith {
24             # no monolith eh?
25 248     248   275 my($self, $type, $file, $opt) = @_;
26              
27 248         613 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         608 ++$self->[NEEDS_OBJECT];
37 248         520 return $rv;
38             }
39              
40             sub _include_static {
41 18     18   32 my($self, $file, $text, $err, $opt) = @_;
42 18 50       96 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   294 my($self, $file, $text, $err, $opt) = @_;
50 236         224 my $rv = EMPTY_STRING;
51              
52 236         235 ++$self->[INSIDE_INCLUDE];
53 236   100     577 $self->[COUNTER_INCLUDE] ||= {};
54              
55             # ++$self->[COUNTER_INCLUDE]{ $file } if $self->[TYPE_FILE] eq $file;
56              
57 236 100       549 if ( ++$self->[COUNTER_INCLUDE]{ $file } >= MAX_RECURSION ) {
58             # failsafe
59 2         4 $self->[DEEP_RECURSION] = 1;
60 2 50       6 LOG( DEEP_RECURSION => $file ) if DEBUG;
61 2         8 my $w = L( warning => 'tts.base.include.dynamic.recursion',
62             $err, MAX_RECURSION, $file );
63 2         6 $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       546 $rv .= $self->[MONOLITH]
68             ? $self->_include_dynamic_monolith( $file, $text )
69             : $self->_include_no_monolith( T_DYNAMIC, $file, $opt )
70             ;
71             }
72              
73 236         237 --$self->[INSIDE_INCLUDE]; # critical: always adjust this
74 236         846 return $rv;
75             }
76              
77             sub _include_dynamic_monolith {
78 4     4   6 my($self,$file, $text) = @_;
79 4         4 my $old = $self->[FILENAME];
80 4         5 $self->[FILENAME] = $file;
81 4         18 my $result = $self->_parse( $text );
82 4         4 $self->[FILENAME] = $old;
83 4         9 return $result;
84             }
85              
86             sub include {
87 274     274 1 216 my $self = shift;
88 274   50     414 my $type = shift || 0;
89 274         260 my $file = shift;
90 274         302 my $opt = shift;
91 274 100       392 my $is_static = T_STATIC == $type ? 1 : 0;
92 274 100       339 my $is_dynamic = T_DYNAMIC == $type ? 1 : 0;
93 274   66     663 my $known = $is_static || $is_dynamic;
94              
95 274 50       420 fatal('tts.base.include._include.unknown', $type) if not $known;
96              
97 274         485 $file = trim $file;
98              
99 274         544 my $err = $self->_include_error( $type );
100 274         542 my $exists = $self->io->file_exists( $file );
101 274         355 my $interpolate;
102              
103 274 100       355 if ( $exists ) {
104 254         250 $file = $exists; # file path correction
105             }
106             else {
107 20         20 $interpolate = 1; # just guessing ...
108 20 100       66 return sprintf E_IN_MONOLITH, $err, $file if $self->[MONOLITH];
109             }
110              
111 272 50       481 if ( $self->io->is_dir( $file ) ) {
112 0         0 return sprintf E_IN_DIR, $err, escape(q{~} => $file);
113             }
114              
115 272 50       511 $self->_debug_include_type( $file, $type ) if DEBUG;
116              
117 272 100       414 if ( $interpolate ) {
118 18         62 my $rv = $self->_interpolate( $file, $type );
119 18         51 $self->[NEEDS_OBJECT]++;
120 18 50       40 LOG(INTERPOLATE_INC => "TYPE: $type; DATA: $file; RV: $rv") if DEBUG;
121 18         66 return $rv;
122             }
123              
124 254         277 my $text = eval { $self->io->slurp($file); };
  254         369  
125 254 50       502 if ( $@ ) {
126 0         0 return sprintf E_IN_SLURP, $err, $@;
127             }
128              
129 254 100       502 my $meth = '_include_' . ($is_dynamic ? 'dynamic' : 'static');
130 254         844 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             my $toke = Text::Template::Simple::Tokenizer->new(
137 0         0 @{ $self->[DELIMITERS] },
  0         0  
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   19 my $self = shift;
147 18         17 my $file = shift;
148 18         16 my $type = shift;
149 18         25 my $etitle = $self->_include_error($type);
150              
151             # so that, you can pass parameters, apply filters etc.
152 18         106 my %inc = (INCLUDE => map { trim $_ } split RE_PIPE_SPLIT, $file );
  42         67  
153              
154 18 100       44 if ( $self->io->file_exists( $inc{INCLUDE} ) ) {
155             # well... constantly working around :p
156 10         30 $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       60 $self->_interpolate_share_setup( \%inc ) if $inc{SHARE};
164              
165 18 100       56 my $share = $inc{SHARE} ? sprintf(q{'%s', %s}, ($inc{SHARE}) x 2) : 'undef';
166 18 100       37 my $filter = $inc{FILTER} ? escape( q{'} => $inc{FILTER} ) : EMPTY_STRING;
167              
168             return
169             $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 18 100       82 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   6 my($self, $inc) = @_;
186 6         23 my @vars = map { trim $_ } split RE_FILTER_SPLIT, $inc->{SHARE};
  10         17  
187 6         21 my %type = TYPE_MAP;
188 6         5 my @buf;
189 6         9 foreach my $var ( @vars ) {
190 10 50       31 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         14 $var =~ tr/;//d;
196 10 50       23 if ( $var =~ m{ [^a-zA-Z0-9_\$] }xms ) { ## no critic (ProhibitEnumeratedClasses)
197 0         0 fatal('tts.base.include._interpolate.bogus_share_notbare', $var);
198             }
199 10         13 push @buf, $var;
200             }
201 6         13 $inc->{SHARE} = join q{,}, @buf;
202 6         13 return;
203             }
204              
205             sub _include_error {
206 558     558   559 my($self, $type) = @_;
207 558 50       794 my $val = T_DYNAMIC == $type ? 'dynamic'
    100          
208             : T_STATIC == $type ? 'static'
209             : 'unknown'
210             ;
211 558         1881 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.90> of C<Text::Template::Simple::Base::Include>
233             released on C<5 July 2016>.
234              
235             Private module.
236              
237             =head1 AUTHOR
238              
239             Burak Gursoy <burak@cpan.org>.
240              
241             =head1 COPYRIGHT
242              
243             Copyright 2004 - 2016 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.24.0 or,
249             at your option, any later version of Perl 5 you may have available.
250             =cut