File Coverage

blib/lib/Text/Forge.pm
Criterion Covered Total %
statement 278 292 95.2
branch 81 88 92.0
condition 17 26 65.3
subroutine 70 70 100.0
pod 12 12 100.0
total 458 488 93.8


line stmt bran cond sub pod time code
1             package Text::Forge;
2             # ABSTRACT: Templates with embedded Perl
3              
4              
5             #{{{ test
6              
7              
8             #}}}
9              
10 1     1   1323 use 5.16.0; # unicode eval
  1         4  
  1         56  
11 1     1   6 use strict;
  1         2  
  1         44  
12 1     1   6 use warnings;
  1         1  
  1         855  
13 1     1   13 use utf8;
  1         1  
  1         25  
14 1     1   30 use autodie qw/ :all /;
  1         1  
  1         9  
15 1     1   5084 use Carp;
  1         3  
  1         106  
16 1     1   1193 use Encode ();
  1         11655  
  1         23  
17 1     1   9 use File::Spec ();
  1         2  
  1         14  
18 1     1   791 use HTML::Entities ();
  1         5926  
  1         41  
19 1     1   923 use URI::Escape ();
  1         1110  
  1         1077  
20              
21             our $VERSION = '6.02';
22              
23             our @FINC = ('.'); # default search paths
24             our %FINC; # compiled template cache
25              
26             our $CACHE = 1; # cache compiled templates by default
27              
28             our $CHARSET = 'utf8';
29              
30             our $INTERPOLATE = 0; # deprecated; leave off
31              
32              
33             # define template block operators
34             our %OPS;
35             {
36              
37             my $code = sub { qq{ $_[0]; } };
38              
39             %OPS = (
40             '$' => sub {
41             qq{ print $_[0]; }
42             },
43            
44             '%' => $code,
45             " " => $code,
46             "\n" => $code,
47             "\r" => $code,
48             "\t" => $code,
49            
50             '=' => sub {
51             # Call method as function; faster
52             qq{ print Text::Forge::escape_html(undef, $_[0]); }
53             },
54              
55             '?' => sub {
56             # Call method as function; faster
57             qq{ print Text::Forge::escape_uri(undef, $_[0]); }
58             },
59              
60             '#' => sub { $_[0] =~ s/[^\r\n]//g; $_[0]; },
61             );
62             }
63              
64              
65             #{{{ test
66              
67              
68             #}}}
69              
70             sub new {
71 22     22 1 12296 my $class = shift;
72 22         55 my %args = @_;
73            
74 22   66     97 $class = ref($class) || $class;
75 22         80 my $self = bless {}, $class;
76              
77 22         64 while (@_) {
78 9         24 my ($method, $args) = splice @_, 0, 2;
79 9 100       43 $self->$method(ref $args eq 'ARRAY' ? @$args : $args);
80             }
81              
82 22         101 return $self;
83             }
84              
85              
86             #{{{ test
87              
88              
89             #}}}
90              
91             sub _list {
92 9     9   449 my $class = shift;
93              
94 9 100       16 return map { ref $_ eq 'ARRAY' ? @$_ : $_ } @_;
  16         54  
95             }
96              
97              
98             #{{{ test
99              
100              
101             #}}}
102              
103             sub search_paths {
104 17     17 1 32 my $self = shift;
105              
106 17 100       33 if (@_) {
107 7 100       30 $self->{search} = [
108 4         10 grep { defined && length }
109             $self->_list(@_)
110             ];
111             }
112              
113 17 100       37 my $paths = exists $self->{search} ? $self->{search} : \@FINC;
114 17 100       69 return wantarray ? @$paths : $paths;
115             }
116              
117              
118             #{{{ test
119              
120              
121             #}}}
122              
123             sub cache {
124 43     43 1 1601 my $self= shift;
125              
126 43 100       108 $self->{cache} = shift if @_;
127 43   66     210 return $self->{cache} // $CACHE;
128             }
129              
130              
131             #{{{ test
132              
133              
134             #}}}
135              
136             sub charset {
137 24     24 1 758 my $self= shift;
138              
139 24 100       68 $self->{charset} = shift if @_;
140 24   66     93 return $self->{charset} // $CHARSET;
141             }
142              
143              
144             #{{{ test
145              
146              
147             #}}}
148              
149             sub layout {
150 16     16 1 33 my $self= shift;
151              
152 16 100       37 $self->{layout} = shift if @_;
153 16         58 return $self->{layout};
154             }
155              
156              
157             #{{{ test
158              
159              
160             #}}}
161              
162             sub _find_template {
163 4     4   763 my $self = shift;
164 4         7 my $path = shift;
165              
166 4         8 foreach my $search ($self->search_paths, undef) {
167 5         111 my $fpath = File::Spec->rel2abs($path, $search);
168 5 100 66     118 return $fpath if $fpath and -f $fpath;
169             }
170              
171 1         4 my @search = $self->search_paths;
172 1         40 croak "Can't locate template '$path' (search paths: @search)";
173             }
174              
175              
176 21     21   382 sub _namespace_prefix { 'TF' }
177              
178              
179             #{{{ test
180              
181              
182             #}}}
183              
184             # From Apache::Registry
185             # Assumes: $fpath is absolute, normalized path as returned by _find_template()
186             sub _namespace {
187 20     20   33 my $self = shift;
188 20         30 my $fpath = shift;
189              
190             # Escape everything into valid perl identifiers
191 20         119 $fpath =~ s/([^A-Za-z0-9_\/])/sprintf("_%02x", ord $1)/eg;
  36         160  
192              
193             # second pass cares for slashes and words starting with a digit
194 20         44 $fpath =~
195             s{ (/+)(\d?) }
196 6 100       29 { '::' . (length $2 ? sprintf("_%02x", ord $2) : '') }egx;
197              
198 20         48 return $self->_namespace_prefix . $fpath;
199             }
200              
201              
202             #{{{ test
203              
204              
205             #}}}
206              
207             # This parsing technique is discussed in perlop
208             sub _parse {
209 25     25   2954 my $class = shift;
210 25         36 local $_ = shift;
211              
212 1     1   5 no warnings 'uninitialized';
  1         2  
  1         2182  
213              
214 25         33 my @code;
215 25         28 my $line = 0;
216             LOOP: {
217             # Match token
218 25 100       27 if (/\G<%(.)(.*?)(?([ \t\r\f]*\n)?/sgc) {
  49         189  
219 16 100       62 exists $OPS{ $1 } or die "unknown forge token '$1' at line $line\n";
220              
221             # If the op is a linefeed we have to keep it to get line numbers right
222 15 100       46 push @code, $OPS{'%'}->($1) if $1 eq "\n";
223              
224 15         43 push @code, $OPS{ $1 }->(map { s/\\%>/%>/g; $_ } "$2");
  15         28  
  15         56  
225 15 100       53 push @code, $OPS{'%'}->($3) if length $3; # maintain line numbers
226 15         49 $line += "$1$2$3" =~ tr/\n//;
227 15         25 redo LOOP;
228             }
229              
230             # Match anything up to the beginning of a token
231 33 100       143 if (/\G(.+?)(?
232 9         20 my $str = $1;
233 9 100       31 $str =~ s/((?:\\.)|(?:\|))/$1 eq '|' ? '\\|' : $1/eg;
  2         9  
234 9 100       42 push @code, $OPS{'$'}->($INTERPOLATE ? "qq|$str|" : "q|$str|");
235 9         20 $line += $1 =~ tr/\n//;
236 9         15 redo LOOP;
237             }
238              
239 24         50 my $str = substr $_, pos;
240 24 100       66 $str =~ s/((?:\\.)|(?:\|))/$1 eq '|' ? '\\|' : $1/eg;
  3         19  
241 24 100       57 if (length $str) {
242 18 100       79 push @code, $OPS{'$'}->($INTERPOLATE ? "qq|$str|" : "q|$str|");
243             }
244             }
245              
246 24         90 return join '', @code;
247             }
248              
249              
250             #{{{ test
251              
252              
253             #}}}
254              
255             sub _named_sub {
256 1     1   338 my($self, $package, $path, $code) = @_;
257              
258 1         7 return join '',
259             "package $package;\n\n",
260             "use strict;\n",
261             "use Carp;\n\n",
262             "sub run {\n",
263             " my \$self = shift;\n",
264             qq{\n# line 1 "$path"\n},
265             " $code",
266             "\n}\n",
267             "\\&run;", # return reference to sub
268             ;
269             }
270              
271              
272             #{{{ test
273              
274              
275             #}}}
276              
277             sub _anon_sub {
278 18     18   3522 my($self, $package, $path, $code) = @_;
279              
280 18         98 return join '',
281             "return sub {\n",
282             " package $package;\n",
283             "use strict;\n",
284             "use Carp;\n\n",
285             " my \$self = shift;\n",
286             qq{# line 1 "$path"\n},
287             " $code",
288             "\n}\n",
289             ;
290             }
291              
292              
293             #{{{ test
294              
295              
296             #}}}
297              
298             # we isolate this to prevent closures in the new sub. better way?
299 1     1   9 sub _mksub { eval $_[0] }
  1     1   2  
  1     1   36  
  1     1   7  
  1     1   3  
  1     1   712  
  1     1   8  
  1     1   2  
  1     1   33  
  1     1   5  
  1     1   3  
  1     1   511  
  1     1   8  
  1     1   3  
  1     1   82  
  1     1   7  
  1     1   1  
  1     1   99  
  1     1   5  
  1     1   2  
  1     1   46  
  1     1   4  
  1     1   2  
  1     1   615  
  1     1   9  
  1     1   2  
  1     1   30  
  1     1   5  
  1     1   1  
  1     1   561  
  1     1   7  
  1     1   2  
  1     1   38  
  1     1   5  
  1     18   2  
  1         527  
  1         6  
  1         1  
  1         28  
  1         4  
  1         2  
  1         524  
  1         6  
  1         1  
  1         23  
  1         4  
  1         2  
  1         84  
  1         6  
  1         2  
  1         29  
  1         5  
  1         2  
  1         499  
  1         6  
  1         2  
  1         35  
  1         5  
  1         1  
  1         568  
  1         7  
  1         3  
  1         39  
  1         6  
  1         2  
  1         588  
  1         6  
  1         2  
  1         42  
  1         5  
  1         3  
  1         499  
  1         11  
  1         3  
  1         32  
  1         5  
  1         2  
  1         445  
  1         5  
  1         2  
  1         43  
  1         6  
  1         1  
  1         486  
  1         5  
  1         1  
  1         29  
  1         9  
  1         2  
  1         461  
  1         10  
  1         1  
  1         36  
  1         6  
  1         2  
  1         551  
  1         13  
  1         2  
  1         24  
  1         4  
  1         3  
  1         469  
  18         10055  
300              
301              
302             #{{{ test
303              
304              
305             #}}}
306              
307             sub _compile {
308 18     18   1125 my($self, $path) = @_;
309              
310 18         34 my $ref = ref $path;
311              
312 18 100       47 return $path if $ref eq 'CODE';
313              
314 17 50       45 if ($ref eq 'SCALAR') { # inline template?
315 17         44 my $package = $self->_namespace($path);
316 17         47 my $code = $self->_parse($$path);
317 17         64 $code = $self->_anon_sub($package, $path, $code);
318             #warn "\n\nCODE:\n$code\n\n";
319 17         34 my $sub = Text::Forge::_mksub($code);
320 17 100       264 croak "compilation of inline template failed: $@" if $@;
321              
322             # XXX Should we clear the cache if it becomes too large?
323 15 100       46 $FINC{ $path } = $sub if $self->cache;
324 15         65 return $sub;
325             }
326              
327 0         0 my $fpath = $self->_find_template($path);
328 0         0 my $package = $self->_namespace($fpath);
329              
330 0         0 my $charset = $self->charset;
331 0 0       0 $charset = ":encoding($charset)" if $charset;
332              
333 0         0 open my $fh, "<$charset", $fpath;
334 0         0 my $source = do { local $/; <$fh> };
  0         0  
  0         0  
335 0         0 my $code = $self->_parse($source, $fpath);
336 0         0 $code = $self->_named_sub($package, $fpath, $code);
337              
338             #warn "CODE\n#########################\n$code\n############################\n";
339 0         0 my $sub = Text::Forge::_mksub($code);
340 0 0       0 croak "compilation of forge template '$fpath' failed: $@" if $@;
341              
342 0 0       0 $FINC{ $path } = $sub if $self->cache;
343 0         0 return $sub;
344             }
345              
346              
347             #{{{ test
348              
349              
350             #}}}
351              
352             sub include {
353 19     19 1 506 my $self = shift;
354 19         26 my $path = shift;
355              
356 19 100       39 delete $FINC{ $path } unless $self->cache;
357              
358 19 100 33     95 my $sub = ref $path eq 'CODE'
359             ? $path
360             : $FINC{ $path } || $self->_compile($path);
361              
362 18         367 $sub->($self, @_);
363             }
364              
365              
366             #{{{ test
367              
368              
369             #}}}
370              
371             sub content {
372 4     4 1 15 my $self = shift;
373              
374 4 100       17 $self->{content} = join '', $self->_list(@_) if @_;
375 4         18 return $self->{content};
376             }
377              
378              
379              
380             #{{{ test
381              
382              
383             #}}}
384              
385             sub capture {
386 16     16 1 1183 my $self = shift;
387              
388 16         34 my $charset = $self->charset;
389              
390 16 100       43 my $enc = $charset ? ":$charset" : '';
391              
392 16         17 my $content;
393             {
394 16         17 local *STDOUT;
  16         89  
395 16         62 open STDOUT, ">$enc", \$content;
396 16         4860 my $ofh = select STDOUT;
397              
398 16         48 $self->include(@_);
399              
400 15         119 select $ofh;
401             }
402              
403 15 100       72 return $charset ? Encode::decode($charset, $content) : $content;
404             }
405              
406              
407             #{{{ test
408              
409              
410             #}}}
411              
412             sub content_for {
413 13     13 1 41 my $self = shift;
414              
415 13 100       53 @_ or croak "no capture name supplied";
416              
417 12   100     34 $self->{captures} ||= {};
418              
419 12 100       45 return $self->{captures}{ shift() } if 1 == @_;
420              
421 4         10 while (@_) {
422 4         9 my ($name, $val) = splice @_, 0, 2;
423 4         5 my $type = ref $val;
424 4 100       14 if ($type eq 'CODE') {
    100          
425 1         4 $val = $self->capture($val);
426             } elsif ($type eq 'ARRAY') {
427 1         2 $val = join '', @$val;
428             }
429 4         44 $self->{captures}{ $name } .= $val;
430             }
431             }
432              
433              
434             #{{{ test
435              
436              
437             #}}}
438              
439             # Note that layouts may be called recursively.
440             sub _apply_layout {
441 8     8   15 my $self = shift;
442 8 100 66     28 my $layout = shift || $self->layout or return;
443              
444 4         11 local $self->{layout} = $layout;
445              
446 4         11 while (my $layout = $self->{layout}) {
447 5         8 $self->{layout} = undef;
448 5         12 local $_ = $self->{captures}{main} = $self->{content};
449 5         8 eval { $self->{content} = $self->capture($layout) };
  5         8  
450 5 100       478 croak "Layout '$layout' failed: $@" if $@;
451             }
452             }
453              
454              
455             #{{{ test
456              
457              
458             #}}}
459              
460             sub run {
461 6     6 1 18 my $self = shift;
462              
463 6         16 $self->{content} = $self->capture(@_);
464 6         208 $self->_apply_layout;
465              
466 6 100       33 return $self->{content} if defined wantarray;
467             }
468              
469              
470             #{{{ test
471              
472              
473             #}}}
474              
475             sub escape_uri {
476 3     3 1 1761 my $class = shift;
477              
478             my @str = map {
479 3 100 66     9 (ref $_ and eval { $_->can('as_uri') })
  4         43  
480             ? $_->as_uri : URI::Escape::uri_escape_utf8($_)
481             } @_;
482              
483 3 100       111 return wantarray ? @str : join '', @str;
484             }
485             *u = \&escape_uri;
486              
487              
488             #{{{ test
489              
490              
491             #}}}
492              
493             {
494             # "unsafe" chars and all ascii control chars except for tab,
495             # line feed, and carriage return
496             my $chars = q{<>&"'\x00-\x08\x0B\x0C\x0E-\x1F\x7F};
497              
498             sub escape_html {
499 4     4 1 1900 my $class = shift;
500              
501             my @str = map {
502 4 100 66     10 (ref $_ and eval { $_->can('as_html') })
  5         81  
503             ? $_->as_html : HTML::Entities::encode_entities($_, $chars)
504             } @_;
505              
506 4 100       349 return wantarray ? @str : join '', @str;
507             }
508             }
509             *h = \&escape_html;
510              
511              
512             #{{{ test
513              
514              
515             #}}}
516              
517             # Deprecated
518             {
519 1     1   7 no warnings qw/ prototype redefine /; # conflicts with core::send()
  1         2  
  1         102  
520              
521             sub send {
522 1     1   2 my $self = shift;
523            
524 1         5 print $self->run(@_)
525             }
526             }
527              
528              
529             #{{{ test
530              
531              
532             #}}}
533              
534             # Deprecated
535 1     1   966 use Method::Alias trap_send => 'run';
  1         315  
  1         5  
536              
537              
538             1;
539              
540             =pod
541              
542             =encoding UTF-8
543              
544             =head1 NAME
545              
546             Text::Forge - Templates with embedded Perl
547              
548             =head1 VERSION
549              
550             version 6.02
551              
552             =head1 SYNOPSIS
553              
554             use Text::Forge;
555              
556             my $forge = Text::Forge->new;
557              
558             # template in external file
559             print $forge->run('path/to/template');
560              
561             # template passed as reference
562             print $forge->run(\'
563             <% my $d = scalar localtime %>The date is <%= $d %>
564             ');
565             # Outputs: The date is Fri Nov 26 11:32:22 2010
566              
567             =head1 DESCRIPTION
568              
569             This module uses templates to generate documents dynamically. Templates
570             are normal text files with a bit of special syntax that allows Perl code
571             to be embedded.
572              
573             The following tags are supported:
574              
575             <% %> code block (no output)
576             <%= %> interpolate, result is HTML escaped
577             <%? %> interpolate, result is URI escaped
578             <%$ %> interpolate, no escaping (let's be careful)
579             <%# %> comment
580              
581             All blocks are evaluated within the same lexical scope (so my
582             variables declared in one block are visible in subsequent blocks).
583              
584             Code blocks contain straight Perl code; it is executed, but nothing
585             is output.
586              
587             Interpolation blocks are evaluated and the result inserted into
588             the template.
589              
590             Templates are compiled into normal Perl methods. They can
591             be passed arguments, as you might expect:
592              
593             print $forge->run(
594             \'<% my %args = @_ %>Name is <%= $args{name} %>',
595             name => 'foo'
596             );
597              
598             The $self variable is available within all templates, and is a reference
599             to the Text::Forge instance that is generating the document. This allows
600             subclasses to provide customization and context to templates.
601              
602             Anything printed to standard output (STDOUT) becomes part of the template.
603              
604             Any errors in compiling or executing a template raises an exception.
605             Errors should correctly reference the template line causing the problem.
606              
607             If a block is followed solely by whitespace up to the next newline,
608             that whitespace (including the newline) will be suppressed from the output.
609             If you really want a newline, add another newline after the block.
610             The idea is that the blocks themselves shouldn't affect the formatting.
611              
612             =for testing use_ok $CLASS;
613              
614             =begin testing
615              
616             isa_ok $CLASS->new, $CLASS, 'constructor on class name';
617             isa_ok $CLASS->new->new, $CLASS, 'constructor on instance';
618              
619             my $forge = $CLASS->new(charset => 'iso-8859-1');
620             ok $forge, 'object created';
621             is $forge->charset, 'iso-8859-1', 'method called from constructor';
622              
623             my @search = ('.', '/tmp');
624             $forge = $CLASS->new(search_paths => \@search);
625             is_deeply scalar $forge->search_paths, \@search,
626             'method called from constructor with arrayref';
627              
628             =end testing
629              
630             =for testing my @list = qw/ a b c /;
631             is_deeply [ $CLASS->_list ], [], 'empty list';
632             is_deeply [ $CLASS->_list(@list), ], \@list, '_list';
633             is_deeply [ $CLASS->_list(\@list) ], \@list, '_list arrayref flattened';
634             is_deeply [ $CLASS->_list(@list, \@list) ], [@list, @list], '_list multi';
635              
636             =begin testing
637              
638             my $forge = $CLASS->new;
639             is_deeply [ $forge->search_paths ], \@Text::Forge::FINC,
640             'search_paths, defaults to \@FINC';
641              
642              
643             my @search = ('/tmp/view');
644             $forge = $CLASS->new(search_paths => [@search, undef]);
645              
646             is_deeply [ $forge->search_paths ], \@search,
647             'search_paths, list context';
648              
649             is_deeply scalar $forge->search_paths, \@search,
650             'search_paths, scalar context';
651              
652              
653             push @search, '/tmp/fallback';
654             is_deeply [ $forge->search_paths(\@search) ], \@search,
655             'search_paths, set';
656              
657             is_deeply [ $forge->search_paths ], \@search,
658             'search_paths, list context';
659              
660             is_deeply scalar $forge->search_paths, \@search,
661             'search_paths, scalar context';
662              
663             =end testing
664              
665             =begin testing
666              
667             my $forge = $CLASS->new;
668             is $forge->cache, $Text::Forge::CACHE, 'cache, defaults to $CACHE';
669              
670             foreach (0, 1) {
671             is $forge->cache($_), $_, "cache, set $_";
672             is $forge->cache, $_, 'cache, get';
673             }
674              
675             =end testing
676              
677             =begin testing
678              
679             my $forge = $CLASS->new;
680             is $forge->charset, $Text::Forge::CHARSET,
681             'charset, defaults to $CHARSET';
682              
683             my $charset= 'iso-8859-1';
684             is $forge->charset($charset), $charset, "charset, set to '$charset'";
685             is $forge->charset, $charset, 'charset, get';
686              
687             =end testing
688              
689             =begin testing
690              
691             my $forge = $CLASS->new;
692             is $forge->layout, undef, 'layout, default undefined';
693              
694             my $layout = '/tmp/foo';
695             is $forge->layout($layout), $layout, "layout, set to '$layout'";
696             is $forge->layout, $layout, 'layout, get';
697              
698             =end testing
699              
700             =begin testing
701              
702             use File::Temp qw/ tempdir /;
703              
704             my $tmpdir = tempdir;
705             chdir $tmpdir;
706             mkdir 'templates';
707              
708             my $template_path = "$tmpdir/templates/home";
709             open my $fh, '>', $template_path;
710             print $fh "my path is $template_path";
711              
712             my $forge = $CLASS->new(search_paths => []);
713             eval { $forge->_find_template('foo') };
714             ok $@, '_find_template, no search paths defined';
715              
716             ok $forge->_find_template("$tmpdir/templates/home"),
717             '_find_template, absolute path';
718              
719             $forge = $CLASS->new(search_paths => "$tmpdir/templates");
720             ok $forge->_find_template('home'), '_find_template using search path';
721              
722             chdir "$tmpdir/templates";
723             $forge = $CLASS->new(search_paths => []);
724             ok $forge->_find_template('home'), '_find_template always searches cwd';
725              
726             =end testing
727              
728             =begin testing
729              
730             my $prefix = $CLASS->_namespace_prefix;
731              
732             is $CLASS->_namespace('/tmp'), "${prefix}::tmp", '_namespace';
733             is $CLASS->_namespace('/tmp/F$
734             '_namespace, escaped';
735             is $CLASS->_namespace('/tmp/123/foo'), "${prefix}::tmp::_3123::foo",
736             '_namespace, numeric';
737              
738             =end testing
739              
740             =begin testing
741              
742             my $code = $CLASS->_parse('hello');
743             is $code, ' print q|hello|; ', '_parse, literal string';
744              
745             $code = $CLASS->_parse('hello|there|');
746             is $code, ' print q|hello\|there\||; ',
747             '_parse, literal string, pipes escaped';
748              
749             $code = $CLASS->_parse("<%\n my \$i = 0 %>");
750             is $code, " \n; my \$i = 0 ; ", '_parse, code block';
751              
752             $code = $CLASS->_parse('<%= "hello >>" %>');
753             is $code, ' print Text::Forge::escape_html(undef, "hello >>" ); ',
754             '_parse, html block';
755              
756             $code = $CLASS->_parse('<%? "hello \%>" %>');
757             is $code, ' print Text::Forge::escape_uri(undef, "hello %>" ); ',
758             '_parse, escaped closing tag';
759              
760             eval { $CLASS->_parse('<%Z "foo" %>') };
761             ok $@, '_parse, unknown block type raises exception';
762              
763             $code = $CLASS->_parse(
764             'hello |<%= "world" %> foo \<<% my $i = 0 %> zort\<'
765             );
766             is $code,
767             (
768             ' print q|hello \||; ' .
769             ' print Text::Forge::escape_html(undef, "world" ); ' .
770             ' print q| foo \<|; ' .
771             ' my $i = 0 ; ' .
772             ' print q| zort\<|; '
773             ),
774             '_parse, complex multi-block'
775             ;
776              
777              
778             {
779             local $Text::Forge::INTERPOLATE = 1;
780            
781             my $code = $CLASS->_parse('<% my $i = 5 %>hello $i there <% %> $i');
782             is $code, ' my $i = 5 ; print qq|hello $i there |; ; print qq| $i|; ',
783             '_parse, interpolation enabled [DEPRECATED]';
784             }
785              
786             =end testing
787              
788             =begin testing
789              
790             my $package = "${CLASS}::Test::NamedSub";
791             my $code = "return 'foo'";
792              
793             my $template = $CLASS->_named_sub($package, '/tmp/test', $code);
794             ok $template, '_named_sub, wrap template';
795              
796             my $sub = eval $template;
797             ok !$@ && ref $sub eq 'CODE', '_named_sub, eval code';
798              
799             is $sub->(), 'foo', '_named_sub, call returned code reference';
800             is $package->run(), 'foo', '_named_sub, call named sub';
801              
802             =end testing
803              
804             =begin testing
805              
806             my $package = "${CLASS}::Test::AnonSub";
807             my $code = "return 'foo2'";
808              
809             my $template = $CLASS->_anon_sub($package, '/tmp/test2', $code);
810             ok $template, '_anon_sub, wrap template';
811              
812             my $sub = eval $template;
813             ok !$@ && ref $sub eq 'CODE', '_anon_sub, eval code';
814              
815             is $sub->(), 'foo2', 'call template';
816              
817             =end testing
818              
819             =begin testing
820              
821             my $mksub = eval { $CLASS->can('_mksub') };
822             ok !$@ && ref $mksub eq 'CODE', '_mksub, get sub reference';
823              
824             my $rv = $mksub->("return 'foo'");
825             is $rv, 'foo', '_mksub, eval code';
826              
827             =end testing
828              
829             =begin testing
830              
831             my $forge = $CLASS->new(cache => 1, charset => 'utf8');
832              
833             my $sub = $forge->_compile(\'foo');
834             is ref $sub, 'CODE', '_compile, inline template';
835              
836             $forge->cache(0);
837             $sub = $forge->_compile(\'foo');
838             is ref $sub, 'CODE', '_compile, inline template with caching disabled';
839              
840             my $sub2 = $forge->_compile($sub);
841             is ref $sub2, 'CODE', '_compile, returns code if passed code';
842              
843             eval { $forge->_compile(\'<% BAREWORD %>') };
844             ok $@, '_compile, compile error should raise exception';
845              
846             =end testing
847              
848             =begin testing
849              
850             use Scalar::Util qw/ refaddr /;
851              
852             my $forge = $CLASS->new(cache => 1);
853              
854             eval { $forge->include(\'') };
855             ok !$@, 'include, inline template';
856              
857             is $forge->include(sub { return 12 }), 12, 'include, code reference';
858              
859             $forge->cache(0);
860             is $forge->include(sub { return 22 }), 22, 'include, with caching off';
861              
862             =end testing
863              
864             =begin testing
865              
866             my $forge = $CLASS->new;
867             is $forge->content, undef, 'content, initially undefined';
868            
869             $forge->content('test', [1, 2, 3]);
870             is $forge->content, 'test123', 'content, set';
871              
872             =end testing
873              
874             =begin testing
875              
876             my $forge = $CLASS->new;
877             $forge->charset('utf8');
878              
879             is $forge->capture(\'<% print "foo" %>'), 'foo', 'capture, inline template';
880              
881             is $forge->capture(sub { print 'foo' }), 'foo', 'capture, code ref';
882              
883             is $forge->capture(sub { print 'exposé, Zoë, à propos' }),
884             'exposé, Zoë, à propos', 'capture, unicode';
885              
886             $forge->charset('');
887             is $forge->capture(\'hi'), 'hi', 'capture, no charset set';
888              
889             =end testing
890              
891             =begin testing
892              
893             my $forge = $CLASS->new;
894              
895             $forge->content_for('nav', 'foo');
896             is $forge->content_for('nav'), 'foo', 'content_for, string';
897              
898             $forge->content_for('nav', 'zort');
899             is $forge->content_for('nav'), 'foozort', 'content_for, content appended';
900              
901             $forge->content_for('nav', sub { print 'blort' });
902             is $forge->content_for('nav'), 'foozortblort', 'content_for, code ref';
903              
904             $forge->content_for('nav', [qw/ a b c /]);
905             is $forge->content_for('nav'), 'foozortblortabc', 'content_for, array ref';
906              
907             eval { $forge->content_for };
908             ok $@, 'content_for, name required';
909              
910             =end testing
911              
912             =begin testing
913              
914             my $forge = $CLASS->new;
915              
916             $forge->{content} = 'document';
917             $forge->layout(\'<%= $self->content_for("main") %>');
918             $forge->_apply_layout;
919             is $forge->content, 'document', '_apply_layout';
920              
921             $forge->layout(\'<% BAREWORD %>');
922             eval { $forge->_apply_layout };
923             ok $@, '_apply_layout, layout compile error should raise exception';
924              
925             =end testing
926              
927             =begin testing
928              
929             my $forge = $CLASS->new;
930              
931             is $forge->run(\'content'), 'content', 'run, no blocks';
932             $forge->run(\'content'); # call in null context for test coverage
933              
934             # with layout
935             $forge->layout(\'<%$ $self->content_for("main") %>');
936             is $forge->run(\'content'), 'content', 'run, with layout';
937              
938             # nested layouts
939             $forge->layout(\q{
940             <% $self->layout(\'<%$ $self->content_for("main") \%>') %>
941            
942             });
943             my $content = $forge->run(\'menu');
944             $content =~ s/^\s*//mg;
945             is $content, "\n\n",
946             'run, nested layouts';
947              
948             =end testing
949              
950             =begin testing
951              
952             {
953             package Text::Forge::Test::Object;
954              
955             sub new { my $class = shift; bless { @_ }, ref($class) || $class }
956              
957             sub as_html { $_[0]->{content} }
958             sub as_uri { $_[0]->{content} }
959             }
960              
961              
962             my $escaped = $CLASS->escape_uri('name=foo?<>');
963             is $escaped, 'name%3Dfoo%3F%3C%3E', 'escape_uri, unsafe chars escaped';
964              
965             my @escaped = $CLASS->escape_uri('?foo', 'zort=');
966             is_deeply \@escaped, ['%3Ffoo', 'zort%3D'], 'escape_uri, wantarray';
967              
968             my $o = Text::Forge::Test::Object->new(content => '?name=foo');
969             is $CLASS->escape_uri($o), '?name=foo',
970             'escape_uri, object provides uri-escaped content with as_uri()';
971              
972             =end testing
973              
974             =begin testing
975              
976             my $escaped = $CLASS->escape_html(
977             q{}
978             );
979             is $escaped,
980             '<script type='text/javascript' ' .
981             'id="xss">hi</script>',
982             'escape_html, unsafe chars escaped';
983              
984             my @escaped = $CLASS->escape_html('
985             is_deeply \@escaped, ['<foo', 'zort"'], 'escape_uri, wantarray';
986              
987             my $o = Text::Forge::Test::Object->new(content => '

Header

');
988             is $CLASS->escape_html($o), '

Header

',
989             'escape_html, object provides html-escaped content with as_html()';
990              
991             =end testing
992              
993             =begin testing
994              
995             my $output;
996             {
997             local *STDOUT;
998             open STDOUT, '>', \$output;
999              
1000             $CLASS->new->send(\'content');
1001             }
1002              
1003             is $output, 'content', 'send [DEPRECATED]';
1004              
1005             =end testing
1006              
1007             =for testing is $CLASS->new->trap_send(\'foo'), 'foo', 'trap_send [DEPRECATED]';
1008              
1009             =head1 METHODS
1010              
1011             =head2 new
1012              
1013             Constructor. Returns a Text::Forge instance.
1014              
1015             my $forge = Text::Forge->new(%options);
1016              
1017             =head2 run
1018              
1019             Generate a template. The first argument is the template, which may be
1020             either a file path or a reference to a scalar. Any additional arguments
1021             are passed to the template.
1022              
1023             my $content = $forge->run('path/to/my/template', name => 'foo');
1024              
1025             If a path is supplied and is not absolute, it will be searched for within
1026             the list of L.
1027              
1028             The generated output is returned.
1029              
1030             =head2 cache
1031              
1032             my $forge = Text::Forge->new;
1033             $forge->cache(1);
1034              
1035             Specifies whether templates should be cached. Defaults to true.
1036              
1037             If caching is enabled, templates are compiled into subroutines once and
1038             then reused.
1039              
1040             If you want to ensure templates always reflect the latest changes
1041             on disk (such as during development), set cache() to false.
1042              
1043             If you want to maximize performance, set cache() to true.
1044              
1045             =head2 charset
1046              
1047             my $forge = Text::Forge->new;
1048             $forge->charset('iso-8859-1');
1049              
1050             Specifies the character encoding to use for templates.
1051             Defaults to Unicode (utf8).
1052              
1053             =head2 search_paths
1054              
1055             The list of directories to search for relative template paths.
1056              
1057             my $forge = Text::Forge->new;
1058             $forge->search_paths('/app/templates', '.');
1059              
1060             # will look for /app/templates/header and ./header
1061             $forge->run('header');
1062              
1063             =head2 content
1064              
1065             Returns the result of the last call to run().
1066              
1067             =head1 TEMPLATE METHODS
1068              
1069             The following methods are intended for use I templates. It's all the
1070             same object though, so knock yourself out.
1071              
1072             =head2 include
1073              
1074             Include one template within another.
1075              
1076             For example, if you want to insert a "header" template within another
1077             template. Note that arguments can be passed to included templates and
1078             values can be returned (like normal function calls).
1079              
1080             my $forge = Text::Forge->new;
1081             $forge->run(\'<% $self->include("header", title => 'Hi') %>Hello');
1082              
1083             =head2 capture
1084              
1085             Capture the output of a template.
1086              
1087             Used to capture (but not necessarily include) one template within another.
1088             For example:
1089              
1090             my $forge = Text::Forge->new;
1091             $forge->run(\'
1092             <% my $pagination = $self->capture(sub { %>
1093             Page
1094            
1095             <% foreach (1..10) { %>
1096            
  • <%= $_ %>
  • 1097             <% } %>
    1098            
    1099             <% }) %>
    1100              
    1101            

    Title

    1102             <%$ $pagination %>
    1103             Results...
    1104             <%$ $pagination %>
    1105             ');
    1106              
    1107             In this case the "pagination" content has been captured into the variable
    1108             $pagination, which is then inserted in multiple locations elsewhere in
    1109             the document.
    1110              
    1111             =head2 content_for
    1112              
    1113             Capture the output into a named placeholder. Same as L except the
    1114             result in stored internally as $forge->{captures}{ $name }.
    1115              
    1116             Note that multiple calls to content_for() with the same name are concatenated
    1117             together (not overwritten); this allows, for example, multiple calls
    1118             to something like content_for('head', ...), which are then aggregated and
    1119             inserted elsewhere in the document.
    1120              
    1121             When called with two arguments, this method stores the specified content in
    1122             the named location:
    1123              
    1124             my $forge = Text::Forge->new;
    1125             $forge->run(\'
    1126            

    Title

    1127              
    1128             <% $self->capture_for('nav', sub { %>
    1129            
    1130            
  • ...
  • 1131            
    1132             <% }) %>
    1133             ');
    1134              
    1135             When called with one argument, it returns the previously stored content, if any:
    1136              
    1137             my $nav = $self->content_for('nav');
    1138              
    1139             =head2 layout
    1140              
    1141             Specifies a layout template to apply. Defaults to none.
    1142              
    1143             If defined, the layout template is applied after the primary template
    1144             has been generated. The layout template may then "wrap" the primary template
    1145             with additional content.
    1146              
    1147             For example, rather than have each template L a separate header
    1148             and footer template explicitly, a layout() template can be used more
    1149             simply:
    1150              
    1151             my $forge = Text::Forge->new;
    1152             $forge->layout(\'<%$ $_ %>');
    1153             print $forge->run(\'

    Hello, World!

    ');
    1154              
    1155             # results in:
    1156             #

    Hello, World!

    1157              
    1158             Within the layout, the primary template content is available as $_ (as well
    1159             as through $self->content_for('main')).
    1160              
    1161             =head2 escape_html, h
    1162              
    1163             Returns HTML encoded versions of its arguments. This method is used internally
    1164             to encode the result of <%= %> blocks, but can be used directly:
    1165              
    1166             my $forge = Text::Forge->new;
    1167             print $forge->run(\'<% print $self->escape_html("") %>');
    1168             # outputs: <strong>
    1169              
    1170             The h() method is just an alias for convenience.
    1171              
    1172             If a blessed reference is passed that provides an as_html() method, the
    1173             result of that method will be returned instead. This allows objects to
    1174             be constructed that keep track of their own encoding state.
    1175              
    1176             =head2 escape_uri, u
    1177              
    1178             Returns URI escaped versions of its arguments. This method is used internally
    1179             to encode the result of <%? %> blocks, but can be used directly:
    1180              
    1181             my $forge = Text::Forge->new;
    1182             print $forge->run(\'<% print $self->escape_uri("name=foo") %>');
    1183             # outputs: name%3Dfoo
    1184              
    1185             The u() method is just an alias for convenience.
    1186              
    1187             If a blessed reference is passed that provides an as_uri() method, the
    1188             result of that method will be returned instead. This allows objects to
    1189             be constructed that keep track of their own encoding state.
    1190              
    1191             =head1 AUTHOR
    1192              
    1193             Maurice Aubrey
    1194              
    1195             =head1 COPYRIGHT AND LICENSE
    1196              
    1197             This software is copyright (c) 2014 by Maurice Aubrey.
    1198              
    1199             This is free software; you can redistribute it and/or modify it under
    1200             the same terms as the Perl 5 programming language system itself.
    1201              
    1202             =cut
    1203              
    1204             __END__