File Coverage

blib/lib/Mojolicious/Plugin/PetalTinyRenderer.pm
Criterion Covered Total %
statement 72 91 79.1
branch 21 36 58.3
condition 6 9 66.6
subroutine 14 16 87.5
pod 1 1 100.0
total 114 153 74.5


line stmt bran cond sub pod time code
1             package Mojolicious::Plugin::PetalTinyRenderer;
2             $Mojolicious::Plugin::PetalTinyRenderer::VERSION = '0.04';
3 2     2   2693 use Mojo::Base 'Mojolicious::Plugin';
  2         6  
  2         19  
4 2     2   2340 use Try::Tiny;
  2         3741  
  2         2455  
5              
6             my $tal_ns = q{xmlns:tal="http://purl.org/petal/1.0/"};
7              
8             __PACKAGE__->attr('config');
9              
10             sub register {
11 2     2 1 139 my ($self, $app, $conf) = @_;
12 2         51 $self->config($conf);
13              
14 2   100 8   83 $app->renderer->add_handler($conf->{name} || 'tal' => sub { $self->_petal(@_) } );
  8         213297  
15             }
16              
17             sub _petal {
18 8     8   24 my ($self, $renderer, $c, $output, $options) = @_;
19              
20 8         23 my $inline = $options->{inline};
21 8 100       57 my $name = defined $inline ? "inline" : $renderer->template_name($options);
22 8 50       110 return undef unless defined $name;
23              
24 8         16 $$output = '';
25              
26 8         180 my $log = $c->app->log;
27              
28 8 100       274 if (defined $inline) {
29 1         6 $log->debug(qq{Rendering inline template "$name".});
30 1         22 $$output = $self->_render_xml($inline, $c, $name);
31             }
32             else {
33 7 100       31 if (defined(my $path = $renderer->template_path($options))) {
    50          
34 1         138 $log->debug(qq{Rendering template "$name".});
35              
36 1   50     59 my $encoding = $self->config->{encoding} // ":encoding(UTF-8)";
37              
38 1 50   1   13 if (open my $file, "<$encoding", $path) {
  1         4  
  1         9  
  1         86  
39 1         1930 my $xml = join "", <$file>;
40 1         23 $$output = $self->_render_xml($xml, $c, $name);
41 1         20 close $file;
42             }
43             else {
44 0         0 $log->debug(qq{Template "$name" ($path) not readable.});
45 0         0 return undef;
46             }
47             }
48             elsif (my $d = $renderer->get_data_template($options)) {
49 6         782 $log->debug(qq{Rendering template "$name" from DATA section.});
50 6         222 $$output = $self->_render_xml($d, $c, $name);
51             }
52             else {
53 0         0 $log->debug(qq{Template "$name" not found.});
54 0         0 return undef;
55             }
56             }
57              
58 8         32 return 1;
59             }
60              
61             sub _render_xml {
62 8     8   52 my ($self, $xml, $c, $name) = @_;
63              
64 8         17 my $deldiv = 0;
65 8 100       63 if ($xml !~ /\bxmlns:/) {
66 7         31 $xml = "
$xml
";
67 7         16 $deldiv = 1;
68             }
69              
70 8         77 my $template = Petal::Tiny::_Mojo->new($xml);
71              
72 8         272 my $helper = Mojolicious::Plugin::PetalTinyRenderer::Helper->new(ctx => $c);
73              
74 8         92 my $html;
75             try {
76 8     8   328 $html = $template->process(%{$c->stash}, c => $c, h => $helper);
  8         33  
77             }
78             catch {
79 0     0   0 my $validator;
80 0         0 eval "use XML::Validate; \$validator = XML::Validate->new(Type => 'LibXML');";
81 0 0       0 if ($validator) {
82 0         0 $xml =~ s///;
83 0 0       0 if ($validator->validate($xml)) {
84 0         0 die "Petal::Tiny didn't like the xml in $name, but weirdly XML::Validate did.\n\n$_";
85             }
86             else {
87 0         0 my $e = $validator->last_error;
88 0   0     0 my $message = $e->{message} // "";
89 0         0 die "Petal::Tiny didn't like the xml in $name. XML::Validate reports:\n\n$message";
90             }
91             }
92             else {
93 0         0 die "Petal::Tiny didn't like the xml in $name. Install XML::Validate and XML::LibXML for better diagnostics.\n\n$_";
94             }
95 8         128 };
96              
97 8 100       1751 if ($deldiv) {
98 7         36 $html =~ s,\A
,,;
99 7         36 $html =~ s,\z,,;
100             }
101              
102 8         56 return $html;
103             }
104              
105             1;
106              
107             package
108             Petal::Tiny::_Mojo;
109              
110 2     2   36 use Mojo::Base 'Petal::Tiny';
  2         4  
  2         19  
111 2     2   15604 use Scalar::Util 'blessed';
  2         6  
  2         318  
112              
113             sub reftype {
114 26     26   5309 my ($self, $obj) = @_;
115 26 100 100     170 return 'ARRAY' if blessed $obj and $obj->isa('Mojo::Collection');
116 25         74 return $self->SUPER::reftype($obj);
117             }
118              
119             1;
120              
121             package
122             Mojolicious::Plugin::PetalTinyRenderer::Helper;
123              
124 2     2   14 use Mojo::Base -base;
  2         4  
  2         21  
125              
126             our $AUTOLOAD;
127              
128             __PACKAGE__->attr('ctx');
129              
130             # stolen from Mojolicious::Plugin::TtRenderer::Helper
131             sub AUTOLOAD {
132 1     1   34 my $self = shift;
133              
134 1         3 my $method = $AUTOLOAD;
135              
136 1 50       8 return if $method =~ /^[A-Z]+?$/;
137 1 50       6 return if $method =~ /^_/;
138 1 50       12 return if $method =~ /(?:\:*?)DESTROY$/;
139              
140 1         6 $method = (split '::' => $method)[-1];
141              
142 1 50       23 die qq/Unknown helper: $method/ unless $self->ctx->app->renderer->helpers->{$method};
143              
144 1         76 return $self->ctx->$method(@_);
145             }
146              
147             # lifted from http://www.perlmonks.org/?node_id=44911
148             sub can {
149 1     1   9 my ($self, $method) = @_;
150 1         11 my $subref = $self->SUPER::can($method);
151 1 50       6 return $subref if $subref; # can found it; it's a real method
152              
153             # Method doesn't currently exist; should it, though?
154 1 50       30 return unless exists $self->ctx->app->renderer->helpers->{$method};
155              
156             # Return an anon sub that will work when it's eventually called
157             sub {
158 0     0     my $self = $_[0];
159              
160             # The method is being called. The real method may have been
161             # created in the meantime; if so, don't call AUTOLOAD again
162 0           my $subref = $self->SUPER::can($method);
163 0 0         goto &$subref if $subref;
164              
165 0           $AUTOLOAD=$method;
166 0           goto &AUTOLOAD;
167 1         119 };
168             }
169              
170             1;
171             __END__