← Index
NYTProf Performance Profile   « line view »
For starman worker -M FindBin --max-requests 50 --workers 2 --user=kohadev-koha --group kohadev-koha --pid /var/run/koha/kohadev/plack.pid --daemonize --access-log /var/log/koha/kohadev/plack.log --error-log /var/log/koha/kohadev/plack-error.log -E deployment --socket /var/run/koha/kohadev/plack.sock /etc/koha/sites/kohadev/plack.psgi
  Run on Fri Jan 8 14:16:49 2016
Reported on Fri Jan 8 14:23:06 2016

Filename/usr/share/perl5/Text/MicroTemplate.pm
StatementsExecuted 0 statements in 0s
Line State
ments
Time
on line
Calls Time
in subs
Code
1# modified for NanoA by kazuho, some modified by tokuhirom
2# based on Mojo::Template. Copyright (C) 2008, Sebastian Riedel.
3
4package Text::MicroTemplate;
5
6require Exporter;
7
8use strict;
9use warnings;
10use constant DEBUG => $ENV{MICRO_TEMPLATE_DEBUG} || 0;
11use 5.00800;
12
13use Carp 'croak';
14use Scalar::Util;
15
16our $VERSION = '0.20';
17our @ISA = qw(Exporter);
18our @EXPORT_OK = qw(encoded_string build_mt render_mt);
19our %EXPORT_TAGS = (
20 all => [ @EXPORT_OK ],
21);
22our $_mt_setter = '';
23
24sub new {
25 my $class = shift;
26 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 package_name => undef, # defaults to caller
37 @_ == 1 ? ref($_[0]) ? %{$_[0]} : (template => $_[0]) : @_,
38 }, $class;
39 if (defined $self->{template}) {
40 $self->parse($self->{template});
41 }
42 unless (defined $self->{package_name}) {
43 $self->{package_name} = 'main';
44 my $i = 0;
45 while (my $c = caller(++$i)) {
46 if ($c !~ /^Text::MicroTemplate\b/) {
47 $self->{package_name} = $c;
48 last;
49 }
50 }
51 }
52 $self;
53}
54
55sub escape_func {
56 my $self = shift;
57 if (@_) {
58 $self->{escape_func} = shift;
59 }
60 $self->{escape_func};
61}
62
63sub package_name {
64 my $self = shift;
65 if (@_) {
66 $self->{package_name} = shift;
67 }
68 $self->{package_name};
69}
70
71sub template { shift->{template} }
72
73sub code {
74 my $self = shift;
75 unless (defined $self->{code}) {
76 $self->_build();
77 }
78 $self->{code};
79}
80
81sub _build {
82 my $self = shift;
83
84 my $escape_func = $self->{escape_func} || '';
85
86 my $embed_escape_func = ref($escape_func) eq 'CODE'
87 ? $escape_func
88 : sub{ $escape_func . "(@_)" };
89
90 # Compile
91 my @lines;
92 my $last_was_code;
93 my $last_text;
94 for my $line (@{$self->{tree}}) {
95
96 # New line
97 push @lines, '';
98 for (my $j = 0; $j < @{$line}; $j += 2) {
99 my $type = $line->[$j];
100 my $value = $line->[$j + 1];
101
102 if ($type ne 'text' && defined $last_text) {
103 # do not mess the start of current line, since it might be
104 # the start of "=pod", etc.
105 $lines[
106 $j == 0 && @lines >= 2 ? -2 : -1
107 ] .= "\$_MT .=\"$last_text\";";
108 undef $last_text;
109 }
110
111 # Need to fix line ending?
112 my $newline = chomp $value;
113
114 # add semicolon to last line of code
115 if ($last_was_code && $type ne 'code') {
116 $lines[-1] .= ';';
117 undef $last_was_code;
118 }
119
120 # Text
121 if ($type eq 'text') {
122
123 # Quote and fix line ending
124 $value = quotemeta($value);
125 $value .= '\n' if $newline;
126
127 $last_text = defined $last_text ? "$last_text$value" : $value;
128 }
129
130 # Code
131 if ($type eq 'code') {
132 $lines[-1] .= $value;
133 $last_was_code = 1;
134 }
135
136 # Expression
137 if ($type eq 'expr') {
138 my $escaped = $embed_escape_func->('$_MT_T');
139 $lines[-1] .= "\$_MT_T = $value;\$_MT .= ref \$_MT_T eq 'Text::MicroTemplate::EncodedString' ? \$\$_MT_T : $escaped; \$_MT_T = '';";
140 }
141 }
142 }
143
144 # add semicolon to last line of code
145 if ($last_was_code) {
146 $lines[-1] .= "\n;";
147 }
148 # add last text line(s)
149 if (defined $last_text) {
150 $lines[-1] .= "\$_MT .=\"$last_text\";";
151 }
152
153 # Wrap
154 $lines[0] = q/sub { my $_MT = ''; local $/ . $self->{package_name} . q/::_MTREF = \$_MT; my $_MT_T = '';/ . (@lines ? $lines[0] : '');
155 $lines[-1] .= q/return $_MT; }/;
156
157 $self->{code} = join "\n", @lines;
158 return $self;
159}
160
161# I am so smart! I am so smart! S-M-R-T! I mean S-M-A-R-T...
162sub parse {
163 my ($self, $tmpl) = @_;
164 $self->{template} = $tmpl;
165
166 # Clean start
167 delete $self->{tree};
168 delete $self->{code};
169
170 # Tags
171 my $line_start = quotemeta $self->{line_start};
172 my $tag_start = quotemeta $self->{tag_start};
173 my $tag_end = quotemeta $self->{tag_end};
174 my $cmnt_mark = quotemeta $self->{comment_mark};
175 my $expr_mark = quotemeta $self->{expression_mark};
176
177 # Tokenize
178 my $state = 'text';
179 my $multiline_expression = 0;
180 my @lines = split /(\n)/, $tmpl;
181 while (@lines) {
182 my $line = shift @lines;
183 my $newline = undef;
184 if (@lines) {
185 shift @lines;
186 $newline = 1;
187 }
188
189 # Perl line without return value
190 if ($line =~ /^$line_start\s+(.*)$/) {
191 push @{$self->{tree}}, ['code', $1];
192 $multiline_expression = 0;
193 next;
194 }
195
196 # Perl line with return value
197 if ($line =~ /^$line_start$expr_mark\s+(.+)$/) {
198 push @{$self->{tree}}, [
199 'expr', $1,
200 $newline ? ('text', "\n") : (),
201 ];
202 $multiline_expression = 0;
203 next;
204 }
205
206 # Comment line, dummy token needed for line count
207 if ($line =~ /^$line_start$cmnt_mark/) {
208 push @{$self->{tree}}, [];
209 $multiline_expression = 0;
210 next;
211 }
212
213 # Escaped line ending?
214 if ($line =~ /(\\+)$/) {
215 my $length = length $1;
216
217 # Newline escaped
218 if ($length == 1) {
219 $line =~ s/\\$//;
220 }
221
222 # Backslash escaped
223 if ($length >= 2) {
224 $line =~ s/\\\\$/\\/;
225 $line .= "\n";
226 }
227 }
228
229 # Normal line ending
230 else { $line .= "\n" if $newline }
231
232 # Mixed line
233 my @token;
234 for my $token (split /
235 (
236 $tag_start$expr_mark # Expression
237 |
238 $tag_start$cmnt_mark # Comment
239 |
240 $tag_start # Code
241 |
242 $tag_end # End
243 )
244 /x, $line) {
245
246 # Garbage
247 next if $token eq '';
248
249 # End
250 if ($token =~ /^$tag_end$/) {
251 $state = 'text';
252 $multiline_expression = 0;
253 }
254
255 # Code
256 elsif ($token =~ /^$tag_start$/) { $state = 'code' }
257
258 # Comment
259 elsif ($token =~ /^$tag_start$cmnt_mark$/) { $state = 'cmnt' }
260
261 # Expression
262 elsif ($token =~ /^$tag_start$expr_mark$/) {
263 $state = 'expr';
264 }
265
266 # Value
267 else {
268
269 # Comments are ignored
270 next if $state eq 'cmnt';
271
272 # Multiline expressions are a bit complicated,
273 # only the first line can be compiled as 'expr'
274 $state = 'code' if $multiline_expression;
275 $multiline_expression = 1
276 if $state eq 'expr';
277
278 # Store value
279 push @token, $state, $token;
280 }
281 }
282 push @{$self->{tree}}, \@token;
283 }
284
285 return $self;
286}
287
288sub _context {
289 my ($self, $text, $line) = @_;
290 my @lines = split /\n/, $text;
291
292 join '', map {
293 0 < $_ && $_ <= @lines ? sprintf("%4d: %s\n", $_, $lines[$_ - 1]) : ''
294 } ($line - 2) .. ($line + 2);
295}
296
297# Debug goodness
298sub _error {
299 my ($self, $error, $line_offset, $from) = @_;
300
301 # Line
302 if ($error =~ /^(.*)\s+at\s+\(eval\s+\d+\)\s+line\s+(\d+)/) {
303 my $reason = $1;
304 my $line = $2 - $line_offset;
305 my $delim = '-' x 76;
306
307 my $report = "$reason at line $line in template passed from $from.\n";
308 my $template = $self->_context($self->{template}, $line);
309 $report .= "$delim\n$template$delim\n";
310
311 # Advanced debugging
312 if (DEBUG) {
313 my $code = $self->_context($self->code, $line);
314 $report .= "$code$delim\n";
315 $report .= $error;
316 }
317
318 return $report;
319 }
320
321 # No line found
322 return "Template error: $error";
323}
324
325# create raw string (that does not need to be escaped)
326sub encoded_string {
327 Text::MicroTemplate::EncodedString->new($_[0]);
328}
329
330
331sub _inline_escape_html{
332 my($variable) = @_;
333
334 my $source = qq{
335 do{
336 $variable =~ s/([&><"'])/\$Text::MicroTemplate::_escape_table{\$1}/ge;
337 $variable;
338 }
339 }; #" for poor editors
340 $source =~ s/\n//g; # to keep line numbers
341 return $source;
342}
343
344our %_escape_table = ( '&' => '&amp;', '>' => '&gt;', '<' => '&lt;', q{"} => '&quot;', q{'} => '&#39;' );
345sub escape_html {
346 my $str = shift;
347 return ''
348 unless defined $str;
349 return $str->as_string
350 if ref $str eq 'Text::MicroTemplate::EncodedString';
351 $str =~ s/([&><"'])/$_escape_table{$1}/ge; #' for poor editors
352 return $str;
353}
354
355sub build_mt {
356 my $mt = Text::MicroTemplate->new(@_);
357 $mt->build();
358}
359
360sub build {
361 my $_mt = shift;
362 Scalar::Util::weaken($_mt) if $_mt_setter;
363 my $_code = $_mt->code;
364 my $_from = sub {
365 my $i = 0;
366 while (my @c = caller(++$i)) {
367 return "$c[1] at line $c[2]"
368 if $c[0] ne __PACKAGE__;
369 }
370 '';
371 }->();
372 my $expr = << "...";
373package $_mt->{package_name};
374sub {
375 ${_mt_setter}local \$SIG{__WARN__} = sub { print STDERR \$_mt->_error(shift, 4, \$_from) };
376 Text::MicroTemplate::encoded_string((
377 $_code
378 )->(\@_));
379}
380...
381
382 if(DEBUG >= 2){
383 DEBUG >= 3 ? die $expr : warn $expr;
384 }
385
386 my $die_msg;
387 {
388 local $@;
389 if (my $_builder = eval($expr)) {
390 return $_builder;
391 }
392 $die_msg = $_mt->_error($@, 4, $_from);
393 }
394 die $die_msg;
395}
396
397sub render_mt {
398 my $builder = build_mt(shift);
399 $builder->(@_);
400}
401
402# ? $_mt->filter(sub { s/\s+//smg; s/[\r\n]//g; })->(sub { ... ? });
403sub filter {
404 my ($self, $callback) = @_;
405 my $mtref = do {
406 no strict 'refs';
407 ${"$self->{package_name}::_MTREF"};
408 };
409 my $before = $$mtref;
410 $$mtref = '';
411 return sub {
412 my $inner_func = shift;
413 $inner_func->(@_);
414
415 ## sub { s/foo/bar/g } is a valid filter
416 ## sub { DateTime::Format::Foo->parse_string(shift) } is valid too
417 local $_ = $$mtref;
418 my $retval = $callback->($$mtref);
419 no warnings 'uninitialized';
420 if (($retval =~ /^\d+$/ and $_ ne $$mtref) or (defined $retval and !$retval)) {
421 $$mtref = $before . $_;
422 } else {
423 $$mtref = $before . $retval;
424 }
425 }
426}
427
428package Text::MicroTemplate::EncodedString;
429
430use strict;
431use warnings;
432
433use overload q{""} => sub { shift->as_string }, fallback => 1;
434
435sub new {
436 my ($klass, $str) = @_;
437 bless \$str, $klass;
438}
439
440sub as_string {
441 my $self = shift;
442 $$self;
443}
444
4451;
446__END__
447
448=head1 NAME
449
450Text::MicroTemplate - Micro template engine with Perl5 language
451
452=head1 SYNOPSIS
453
454 use Text::MicroTemplate qw(:all);
455
456 # compile template, and render
457 $renderer = build_mt('hello, <?= $_[0] ?>');
458 $html = $renderer->('John')->as_string;
459
460 # or in one line
461 $html = render_mt('hello, <?= $_[0] ?>', 'John')->as_string;
462
463 # complex form
464 $mt = Text::MicroTemplate->new(
465 template => 'hello, <?= $query->param('user') ?>',
466 );
467 $code = $mt->code;
468 $renderer = eval << "..." or die $@;
469 sub {
470 my \$query = shift;
471 $code->();
472 }
473 ...
474 $html = $renderer->(CGI->new)->as_string;
475
476=head1 DESCRIPTION
477
478Text::MicroTemplate is a standalone, fast, intelligent, extensible template engine with following features.
479
480=head2 standalone
481
482Text::MicroTemplate does not rely on other CPAN modules.
483
484=head2 fast
485
486Based on L<Mojo::Template>, expressions in the template is perl code.
487
488=head2 intelligent
489
490Text::MicroTemplate automatically escapes variables when and only when necessary.
491
492=head2 extensible
493
494Text::MicroTemplate does not provide features like template cache or including other files by itself. However, it is easy to add you own (that suites the most to your application), by wrapping the result of the module (which is a perl expression).
495
496The module only provides basic building blocks for a template engine. Refer to L<Text::MicroTemplate::File> for higher-level interface.
497
498=head1 TEMPLATE SYNTAX
499
500The template language is Perl5 itself!
501
502 # output the result of expression with automatic escape
503 <?= $expr ?> (tag style)
504 ?= $expr (per-line)
505
506 # execute perl code (tag style)
507 <? foo() ?>
508 ? foo()
509
510 # comment (tag style)
511 <?# comment ?>
512 ?# comment
513
514 # loops
515 <ul>
516 ? for my $item (@list) {
517 <li><?= $item ?></li>
518 ? }
519 </ul>
520
521=head1 EXPORTABLE FUNCTIONS
522
523=head2 build_mt($template)
524
525Returns a subref that renders given template. Parameters are equivalent to Text::MicroTemplate->new.
526
527 # build template renderer at startup time and use it multiple times
528 my $renderer = build_mt('hello, <?= $_[0] ?>!');
529
530 sub run {
531 ...
532 my $hello = $renderer->($query->param('user'));
533 ...
534 }
535
536=head2 render_mt($template, @args)
537
538Utility function that combines build_mt and call to the generated template builder.
539
540 # render
541 $hello = render_mt('hello, <?= $_[0] ?>!', 'John');
542
543 # print as HTML
544 print $hello->as_string;
545
546 # use the result in another template (no double-escapes)
547 $enc = render_mt('<h1><?= $_[0] ?></h1>', $hello);
548
549Intertally, the function is equivalent to:
550
551 build_mt($template)->(@_);
552
553=head2 encoded_string($str)
554
555wraps given string to an object that will not be escaped by the template engine
556
557=head1 OO-STYLE INTERFACE
558
559Text::MicroTemplate provides OO-style interface to handle more complex cases.
560
561=head2 new($template)
562
563=head2 new(%args)
564
565=head2 new(\%args)
566
567Constructs template renderer. In the second or third form, parameters below are recognized.
568
569=head3 template
570
571template string (mandatory)
572
573=head3 escape_func
574
575escape function (defaults to L<Text::MicroTemplate::escape_html>), no escape when set to undef
576
577=head3 package_name
578
579package under where the renderer is compiled (defaults to caller package)
580
581=head2 code()
582
583returns perl code that renders the template when evaluated
584
585=head2 filter(sub filter_func { ... })->(sub { template lines })
586
587filters given template lines
588
589 ? $_mt->filter(sub { s/Hello/Good bye/g })->(sub {
590 Hello, John!
591 ? })
592
593=head1 DEBUG
594
595The C<MICRO_TEMPLATE_DEBUG> environment variable helps debugging.
596The value C<1> extends debugging messages, C<2> reports compiled
597Perl code with C<warn()>, C<3> is like C<2> but uses C<die()>.
598
599=head1 SEE ALSO
600
601L<Text::MicroTemplate::File>
602
603L<Text::MicroTemplate::Extended>
604
605=head1 AUTHOR
606
607Kazuho Oku E<lt>kazuhooku gmail.comE<gt>
608
609Tokuhiro Matsuno E<lt>tokuhirom AAJKLFJEF GMAIL COME<gt>
610
611The module is based on L<Mojo::Template> by Sebastian Riedel.
612
613=head1 LICENSE
614
615This program is free software, you can redistribute it and/or modify it under the same terms as Perl itself.
616
617=cut