File Coverage

blib/lib/Text/MicroTemplate.pm
Criterion Covered Total %
statement 196 229 85.5
branch 81 98 82.6
condition 18 28 64.2
subroutine 29 33 87.8
pod 9 14 64.2
total 333 402 82.8


line stmt bran cond sub pod time code
1             # modified for NanoA by kazuho, some modified by tokuhirom
2             # based on Mojo::Template. Copyright (C) 2008, Sebastian Riedel.
3              
4             package Text::MicroTemplate;
5              
6             require Exporter;
7              
8 15     15   209869 use strict;
  15         27  
  15         492  
9 15     15   51 use warnings;
  15         15  
  15         593  
10 15   50 15   58 use constant DEBUG => $ENV{MICRO_TEMPLATE_DEBUG} || 0;
  15         15  
  15         1097  
11 15     15   331 use 5.00800;
  15         35  
  15         479  
12              
13 15     15   57 use Carp 'croak';
  15         18  
  15         869  
14 15     15   60 use Scalar::Util;
  15         19  
  15         26805  
15              
16             our $VERSION = '0.23';
17             our @ISA = qw(Exporter);
18             our @EXPORT_OK = qw(encoded_string build_mt render_mt);
19             our %EXPORT_TAGS = (
20             all => [ @EXPORT_OK ],
21             );
22             our $_mt_setter = '';
23              
24             sub new {
25 38     38 1 467 my $class = shift;
26 2         18 my $self = bless {
27             code => undef,
28             comment_mark => '#',
29             expression_mark => '=',
30             line_start => '?',
31             template => undef,
32             tree => [],
33             tag_start => '
34             tag_end => '?>',
35             escape_func => \&_inline_escape_html,
36             prepend => '',
37             package_name => undef, # defaults to caller
38 38 100       448 @_ == 1 ? ref($_[0]) ? %{$_[0]} : (template => $_[0]) : @_,
    100          
39             }, $class;
40 38 100       192 if (defined $self->{template}) {
41 30         88 $self->parse($self->{template});
42             }
43 38 100       142 unless (defined $self->{package_name}) {
44 36         49 $self->{package_name} = 'main';
45 36         52 my $i = 0;
46 36         119 while (my $c = caller(++$i)) {
47 58 100       163 if ($c !~ /^Text::MicroTemplate\b/) {
48 32         37 $self->{package_name} = $c;
49 32         129 last;
50             }
51             }
52             }
53 38         66 $self;
54             }
55              
56             sub escape_func {
57 0     0 1 0 my $self = shift;
58 0 0       0 if (@_) {
59 0         0 $self->{escape_func} = shift;
60             }
61 0         0 $self->{escape_func};
62             }
63              
64             sub package_name {
65 1     1 1 2 my $self = shift;
66 1 50       3 if (@_) {
67 0         0 $self->{package_name} = shift;
68             }
69 1         3 $self->{package_name};
70             }
71              
72 0     0 1 0 sub template { shift->{template} }
73              
74             sub code {
75 57     57 1 108 my $self = shift;
76 57 100       118 unless (defined $self->{code}) {
77 54         93 $self->_build();
78             }
79 57         503 $self->{code};
80             }
81              
82             sub _build {
83 54     54   51 my $self = shift;
84            
85 54   100     106 my $escape_func = $self->{escape_func} || '';
86              
87             my $embed_escape_func = ref($escape_func) eq 'CODE'
88             ? $escape_func
89 54 100   1   121 : sub{ $escape_func . "(@_)" };
  1         4  
90              
91             # Compile
92 54         44 my @lines;
93             my $last_was_code;
94 0         0 my $last_text;
95 54         52 for my $line (@{$self->{tree}}) {
  54         90  
96              
97             # New line
98 130         130 push @lines, '';
99 130         144 for (my $j = 0; $j < @{$line}; $j += 2) {
  302         490  
100 172         206 my $type = $line->[$j];
101 172         163 my $value = $line->[$j + 1];
102              
103 172 100 100     405 if ($type ne 'text' && defined $last_text) {
104             # do not mess the start of current line, since it might be
105             # the start of "=pod", etc.
106 46 100 66     224 $lines[
107             $j == 0 && @lines >= 2 ? -2 : -1
108             ] .= "\$_MT .=\"$last_text\";";
109 46         52 undef $last_text;
110             }
111            
112             # Need to fix line ending?
113 172         189 my $newline = chomp $value;
114              
115             # add semicolon to last line of code
116 172 100 100     306 if ($last_was_code && $type ne 'code') {
117 22         24 $lines[-1] .= ';';
118 22         21 undef $last_was_code;
119             }
120              
121             # Text
122 172 100       221 if ($type eq 'text') {
123              
124             # Quote and fix line ending
125 99         88 $value = quotemeta($value);
126 99 100       130 $value .= '\n' if $newline;
127              
128 99 100       164 $last_text = defined $last_text ? "$last_text$value" : $value;
129             }
130              
131             # Code
132 172 100       218 if ($type eq 'code') {
133 30         24 $lines[-1] .= $value;
134 30         27 $last_was_code = 1;
135             }
136              
137             # Expression
138 172 100       275 if ($type eq 'expr') {
139 43         68 my $escaped = $embed_escape_func->('$_MT_T');
140 43 100 66     94 if ($newline && $value =~ /\n/) {
141 1         1 $value .= "\n"; # temporary workaround for t/13-heredoc.t
142             }
143 43         149 $lines[-1] .= "\$_MT_T = $value;\$_MT .= ref \$_MT_T eq 'Text::MicroTemplate::EncodedString' ? \$\$_MT_T : $escaped; \$_MT_T = '';";
144             }
145             }
146             }
147              
148             # add semicolon to last line of code
149 54 100       154 if ($last_was_code) {
150 3         3 $lines[-1] .= "\n;";
151             }
152             # add last text line(s)
153 54 100       84 if (defined $last_text) {
154 35         67 $lines[-1] .= "\$_MT .=\"$last_text\";";
155             }
156            
157             # Wrap
158 54 100       170 $lines[0] = q/sub { my $_MT = ''; local $/ . $self->{package_name} . q/::_MTREF = \$_MT; my $_MT_T = '';/ . (@lines ? $lines[0] : '');
159 54         65 $lines[-1] .= q/return $_MT; }/;
160              
161 54         144 $self->{code} = join "\n", @lines;
162 54         80 return $self;
163             }
164              
165             # I am so smart! I am so smart! S-M-R-T! I mean S-M-A-R-T...
166             sub parse {
167 54     54 0 84 my ($self, $tmpl) = @_;
168 54         72 $self->{template} = $tmpl;
169              
170             # Clean start
171 54         141 delete $self->{tree};
172 54         79 delete $self->{code};
173              
174             # Tags
175 54         93 my $line_start = quotemeta $self->{line_start};
176 54         73 my $tag_start = quotemeta $self->{tag_start};
177 54         86 my $tag_end = quotemeta $self->{tag_end};
178 54         67 my $cmnt_mark = quotemeta $self->{comment_mark};
179 54         62 my $expr_mark = quotemeta $self->{expression_mark};
180              
181             # Tokenize
182 54         48 my $state = 'text';
183 54         362 my @lines = split /(\n)/, $tmpl;
184 54         226 my $tokens = [];
185 54         132 while (@lines) {
186 142         183 my $line = shift @lines;
187 142         110 my $newline = undef;
188 142 100       192 if (@lines) {
189 121         92 shift @lines;
190 121         153 $newline = 1;
191             }
192            
193 142 100       208 if ($state eq 'text') {
194             # Perl line without return value
195 130 100       695 if ($line =~ /^$line_start\s+(.*)$/) {
196 24         21 push @{$self->{tree}}, ['code', $1];
  24         60  
197 24         132 next;
198             }
199             # Perl line with return value
200 106 100       318 if ($line =~ /^$line_start$expr_mark\s+(.+)$/) {
201 7 50       7 push @{$self->{tree}}, [
  7         34  
202             'expr', $1,
203             $newline ? ('text', "\n") : (),
204             ];
205 7         16 next;
206             }
207             # Comment line, dummy token needed for line count
208 99 100       1285 if ($line =~ /^$line_start$cmnt_mark/) {
209 10         9 push @{$self->{tree}}, [];
  10         11  
210 10         14 next;
211             }
212             }
213              
214             # Escaped line ending?
215 101 50       677 if ($line =~ /(\\+)$/) {
216 0         0 my $length = length $1;
217             # Newline escaped
218 0 0       0 if ($length == 1) {
219 0         0 $line =~ s/\\$//;
220             }
221             # Backslash escaped
222 0 0       0 if ($length >= 2) {
223 0         0 $line =~ s/\\\\$/\\/;
224 0         0 $line .= "\n";
225             }
226             } else {
227 101 100       172 $line .= "\n" if $newline;
228             }
229              
230             # Mixed line
231 101         1035 for my $token (split /
232             (
233             $tag_start$expr_mark # Expression
234             |
235             $tag_start$cmnt_mark # Comment
236             |
237             $tag_start # Code
238             |
239             $tag_end # End
240             )
241             /x, $line) {
242              
243             # handle tags and bail out
244 258 100       2167 if ($token eq '') {
    100          
    100          
    100          
    100          
245 26         34 next;
246             } elsif ($token =~ /^$tag_end$/) {
247 42         41 $state = 'text';
248 42         53 next;
249             } elsif ($token =~ /^$tag_start$/) {
250 6         7 $state = 'code';
251 6         4 next;
252             } elsif ($token =~ /^$tag_start$cmnt_mark$/) {
253 2         2 $state = 'cmnt';
254 2         5 next;
255             } elsif ($token =~ /^$tag_start$expr_mark$/) {
256 36         59 $state = 'expr';
257 36         50 next;
258             }
259              
260             # value
261 146 100       681 if ($state eq 'text') {
    100          
    100          
262 92         200 push @$tokens, $state, $token;
263             } elsif ($state eq 'cmnt') {
264 2         2 next; # ignore comments
265             } elsif ($state eq 'cont') {
266 10         20 $tokens->[-1] .= $token;
267             } else {
268             # state is code or expr
269 42         56 push @$tokens, $state, $token;
270 42         61 $state = 'cont';
271             }
272             }
273 101 100       190 if ($state eq 'text') {
274 89         58 push @{$self->{tree}}, $tokens;
  89         154  
275 89         208 $tokens = [];
276             }
277             }
278 54 50       94 push @{$self->{tree}}, $tokens
  0         0  
279             if @$tokens;
280            
281 54         123 return $self;
282             }
283              
284             sub _context {
285 0     0   0 my ($self, $text, $line) = @_;
286 0         0 my @lines = split /\n/, $text;
287            
288 0 0 0     0 join '', map {
289 0         0 0 < $_ && $_ <= @lines ? sprintf("%4d: %s\n", $_, $lines[$_ - 1]) : ''
290             } ($line - 2) .. ($line + 2);
291             }
292              
293             # Debug goodness
294             sub _error {
295 1     1   3 my ($self, $error, $line_offset, $from) = @_;
296            
297             # Line
298 1 50       22 if ($error =~ /^(.*)\s+at\s+\(eval\s+\d+\)\s+line\s+(\d+)/) {
299 0         0 my $reason = $1;
300 0         0 my $line = $2 - $line_offset;
301 0         0 my $delim = '-' x 76;
302            
303 0         0 my $report = "$reason at line $line in template passed from $from.\n";
304 0         0 my $template = $self->_context($self->{template}, $line);
305 0         0 $report .= "$delim\n$template$delim\n";
306              
307             # Advanced debugging
308 0         0 if (DEBUG) {
309             my $code = $self->_context($self->code, $line);
310             $report .= "$code$delim\n";
311             $report .= $error;
312             }
313              
314 0         0 return $report;
315             }
316              
317             # No line found
318 1         5 return "Template error: $error";
319             }
320              
321             # create raw string (that does not need to be escaped)
322             sub encoded_string {
323 59     59 1 227 Text::MicroTemplate::EncodedString->new($_[0]);
324             }
325              
326              
327             sub _inline_escape_html{
328 42     42   50 my($variable) = @_;
329              
330 42         92 my $source = qq{
331             do{
332             $variable =~ s/([&><"'])/\$Text::MicroTemplate::_escape_table{\$1}/ge;
333             $variable;
334             }
335             }; #" for poor editors
336 42         190 $source =~ s/\n//g; # to keep line numbers
337 42         69 return $source;
338             }
339              
340             our %_escape_table = ( '&' => '&', '>' => '>', '<' => '<', q{"} => '"', q{'} => ''' );
341             sub escape_html {
342 0     0 0 0 my $str = shift;
343 0 0       0 return ''
344             unless defined $str;
345 0 0       0 return $str->as_string
346             if ref $str eq 'Text::MicroTemplate::EncodedString';
347 0         0 $str =~ s/([&><"'])/$_escape_table{$1}/ge; #' for poor editors
  0         0  
348 0         0 return $str;
349             }
350              
351             sub build_mt {
352 27     27 1 119 my $mt = Text::MicroTemplate->new(@_);
353 27         68 $mt->build();
354             }
355              
356             sub build {
357 50     50 0 50 my $_mt = shift;
358 50 100       120 Scalar::Util::weaken($_mt) if $_mt_setter;
359 50         88 my $_code = $_mt->code;
360             my $_from = sub {
361 50     50   50 my $i = 0;
362 50         366 while (my @c = caller(++$i)) {
363 104 100       510 return "$c[1] at line $c[2]"
364             if $c[0] ne __PACKAGE__;
365             }
366 0         0 '';
367 50         258 }->();
368 50         227 my $line_offset = (() = ($_mt->{prepend} =~ /\n/sg)) + 5;
369 50         173 my $expr = << "...";
370             package $_mt->{package_name};
371             sub {
372             ${_mt_setter}local \$SIG{__WARN__} = sub { print STDERR \$_mt->_error(shift, $line_offset, \$_from) };
373             $_mt->{prepend}
374             Text::MicroTemplate::encoded_string((
375             $_code
376             )->(\@_));
377             }
378             ...
379              
380 50         46 if(DEBUG >= 2){
381             DEBUG >= 3 ? die $expr : warn $expr;
382             }
383              
384 50         52 my $die_msg;
385             {
386 50         35 local $@;
  50         37  
387 50 100       9748 if (my $_builder = eval($expr)) {
388 49         127 return $_builder;
389             }
390 1         13 $die_msg = $_mt->_error($@, $line_offset, $_from);
391             }
392 1         11 die $die_msg;
393             }
394              
395             sub render_mt {
396 27     27 1 1280 my $builder = build_mt(shift);
397 26         506 $builder->(@_);
398             }
399              
400             # ? $_mt->filter(sub { s/\s+//smg; s/[\r\n]//g; })->(sub { ... ? });
401             sub filter {
402 2     2 1 2 my ($self, $callback) = @_;
403 2         1 my $mtref = do {
404 15     15   89 no strict 'refs';
  15         18  
  15         1113  
405 2         2 ${"$self->{package_name}::_MTREF"};
  2         5  
406             };
407 2         3 my $before = $$mtref;
408 2         2 $$mtref = '';
409             return sub {
410 2     2   2 my $inner_func = shift;
411 2         31 $inner_func->(@_);
412              
413             ## sub { s/foo/bar/g } is a valid filter
414             ## sub { DateTime::Format::Foo->parse_string(shift) } is valid too
415 2         2 local $_ = $$mtref;
416 2         54 my $retval = $callback->($$mtref);
417 15     15   58 no warnings 'uninitialized';
  15         16  
  15         1752  
418 2 100 66     51 if (($retval =~ /^\d+$/ and $_ ne $$mtref) or (defined $retval and !$retval)) {
      33        
      66        
419 1         16 $$mtref = $before . $_;
420             } else {
421 1         22 $$mtref = $before . $retval;
422             }
423             }
424 2         6 }
425              
426             package Text::MicroTemplate::EncodedString;
427              
428 15     15   59 use strict;
  15         14  
  15         365  
429 15     15   148 use warnings;
  15         19  
  15         602  
430              
431 15     15   14068 use overload q{""} => sub { shift->as_string }, fallback => 1;
  15     2   11191  
  15         130  
  2         115  
432              
433             sub new {
434 59     59 0 62 my ($klass, $str) = @_;
435 59         441 bless \$str, $klass;
436             }
437              
438             sub as_string {
439 51     51 0 55 my $self = shift;
440 51         550 $$self;
441             }
442              
443             1;
444             __END__