| line | stmt | bran | cond | sub | pod | time | code | 
| 1 |  |  |  |  |  |  | package Mojolicious::Plugin::XML::Loy; | 
| 2 | 1 |  |  | 1 |  | 586 | use Mojo::Base 'Mojolicious::Plugin'; | 
|  | 1 |  |  |  |  | 2 |  | 
|  | 1 |  |  |  |  | 8 |  | 
| 3 | 1 |  |  | 1 |  | 148 | use Mojo::Loader qw/load_class/; | 
|  | 1 |  |  |  |  | 1 |  | 
|  | 1 |  |  |  |  | 42 |  | 
| 4 | 1 |  |  | 1 |  | 450 | use XML::Loy; | 
|  | 1 |  |  |  |  | 4418 |  | 
|  | 1 |  |  |  |  | 5 |  | 
| 5 |  |  |  |  |  |  |  | 
| 6 |  |  |  |  |  |  | our $VERSION = '0.13'; | 
| 7 |  |  |  |  |  |  |  | 
| 8 |  |  |  |  |  |  | my %base_classes; | 
| 9 |  |  |  |  |  |  |  | 
| 10 |  |  |  |  |  |  | # Register Plugin | 
| 11 |  |  |  |  |  |  | sub register { | 
| 12 | 2 |  |  | 2 | 1 | 6145 | my ($plugin, $mojo, $param) = @_; | 
| 13 |  |  |  |  |  |  |  | 
| 14 | 2 |  |  |  |  | 3 | my $namespace = 'XML::Loy::'; | 
| 15 | 2 |  |  |  |  | 2 | my $max_size = 1024 * 1024; | 
| 16 |  |  |  |  |  |  |  | 
| 17 |  |  |  |  |  |  | # Load parameter from Config file | 
| 18 | 2 | 50 |  |  |  | 11 | if (my $config_param = $mojo->config('XML-Loy')) { | 
| 19 | 0 |  |  |  |  | 0 | $param = { %$param, %$config_param }; | 
| 20 |  |  |  |  |  |  | }; | 
| 21 |  |  |  |  |  |  |  | 
| 22 | 2 | 100 | 66 |  |  | 39 | if (exists $param->{max_size} && $param->{max_size} =~ /^\d+$/) { | 
| 23 | 1 |  |  |  |  | 3 | $max_size = delete $param->{max_size}; | 
| 24 |  |  |  |  |  |  | }; | 
| 25 |  |  |  |  |  |  |  | 
| 26 |  |  |  |  |  |  | # Create new XML helpers | 
| 27 | 2 |  |  |  |  | 7 | foreach my $helper (keys %$param) { | 
| 28 |  |  |  |  |  |  |  | 
| 29 |  |  |  |  |  |  | # Already defined | 
| 30 | 5 | 100 |  |  |  | 73 | if (exists $mojo->renderer->helpers->{$helper}) { | 
| 31 | 1 |  |  |  |  | 10 | $mojo->log->debug("Helper '$helper' already defined"); | 
| 32 | 1 |  |  |  |  | 21 | next; | 
| 33 |  |  |  |  |  |  | }; | 
| 34 |  |  |  |  |  |  |  | 
| 35 | 4 |  |  |  |  | 34 | my @helper = @{ $param->{ $helper } }; | 
|  | 4 |  |  |  |  | 9 |  | 
| 36 | 4 |  |  |  |  | 6 | my $base = shift @helper; | 
| 37 |  |  |  |  |  |  |  | 
| 38 | 4 | 100 |  |  |  | 8 | $base = 'XML::Loy' if $base eq '-Loy'; | 
| 39 |  |  |  |  |  |  |  | 
| 40 | 4 | 100 |  |  |  | 11 | if (index($base, '-') == 0) { | 
| 41 | 3 |  |  |  |  | 12 | $base =~ s/^-//; | 
| 42 | 3 | 50 |  |  |  | 9 | $base = ($base eq 'Loy' ? 'XML::Loy' : $namespace . "$base"); | 
| 43 |  |  |  |  |  |  | }; | 
| 44 |  |  |  |  |  |  |  | 
| 45 |  |  |  |  |  |  | # Load module if not loaded | 
| 46 | 4 | 100 |  |  |  | 9 | unless (exists $base_classes{$base}) { | 
| 47 |  |  |  |  |  |  |  | 
| 48 |  |  |  |  |  |  | # Load base class | 
| 49 | 3 | 50 |  |  |  | 7 | if (my $e = load_class $base) { | 
| 50 | 0 |  |  |  |  | 0 | for ($mojo->log) { | 
| 51 | 0 | 0 |  |  |  | 0 | $_->error("Exception: $e")  if ref $e; | 
| 52 | 0 |  |  |  |  | 0 | $_->error(qq{Unable to load base class "$base"}); | 
| 53 |  |  |  |  |  |  | }; | 
| 54 | 0 |  |  |  |  | 0 | next; | 
| 55 |  |  |  |  |  |  | }; | 
| 56 |  |  |  |  |  |  |  | 
| 57 | 3 |  |  |  |  | 6061 | my $mime   = $base->mime; | 
| 58 | 3 |  |  |  |  | 25 | my $prefix = $base->_prefix; | 
| 59 |  |  |  |  |  |  |  | 
| 60 |  |  |  |  |  |  | # Establish mime types | 
| 61 | 3 | 100 | 66 |  |  | 19 | if ($mime && $prefix) { | 
| 62 |  |  |  |  |  |  |  | 
| 63 |  |  |  |  |  |  | # Apply mime type | 
| 64 | 2 |  |  |  |  | 9 | $mojo->types->type($prefix => $mime); | 
| 65 |  |  |  |  |  |  | }; | 
| 66 |  |  |  |  |  |  |  | 
| 67 |  |  |  |  |  |  | # module loaded | 
| 68 | 3 |  |  |  |  | 69 | $base_classes{$base} = [$prefix => $mime]; | 
| 69 |  |  |  |  |  |  | }; | 
| 70 |  |  |  |  |  |  |  | 
| 71 |  |  |  |  |  |  | # Code generation for ad-hoc helper | 
| 72 | 4 |  |  |  |  | 6 | my $code = 'sub { shift;' . | 
| 73 |  |  |  |  |  |  | ' { use bytes; return if length("@_") > ' . $max_size . '} ' . | 
| 74 |  |  |  |  |  |  | ' my $doc = ' . $base . '->new( @_ );'; | 
| 75 |  |  |  |  |  |  |  | 
| 76 |  |  |  |  |  |  | # Extend base class | 
| 77 | 4 | 100 |  |  |  | 9 | if (@helper) { | 
| 78 | 3 |  |  |  |  | 10 | $code .= '$doc->extension(' . | 
| 79 |  |  |  |  |  |  | join(',', map( '"' . qq{$_"}, @helper)) . | 
| 80 |  |  |  |  |  |  | ");"; | 
| 81 |  |  |  |  |  |  | }; | 
| 82 | 4 |  |  |  |  | 3 | $code .= 'return $doc };'; | 
| 83 |  |  |  |  |  |  |  | 
| 84 |  |  |  |  |  |  | # Eval code | 
| 85 | 1 |  |  | 1 |  | 5 | my $code_ref = eval $code; | 
|  | 1 |  |  | 1 |  | 1 |  | 
|  | 1 |  |  | 1 |  | 6 |  | 
|  | 1 |  |  | 1 |  | 4 |  | 
|  | 1 |  |  |  |  | 1 |  | 
|  | 1 |  |  |  |  | 3 |  | 
|  | 1 |  |  |  |  | 4 |  | 
|  | 1 |  |  |  |  | 1 |  | 
|  | 1 |  |  |  |  | 3 |  | 
|  | 1 |  |  |  |  | 4 |  | 
|  | 1 |  |  |  |  | 0 |  | 
|  | 1 |  |  |  |  | 3 |  | 
|  | 4 |  |  |  |  | 208 |  | 
| 86 |  |  |  |  |  |  |  | 
| 87 |  |  |  |  |  |  | # Evaluation error | 
| 88 | 4 | 50 | 0 |  |  | 12 | $mojo->log->fatal($@ . ': ' . $!) and next if $@; | 
| 89 |  |  |  |  |  |  |  | 
| 90 |  |  |  |  |  |  | # Create helper | 
| 91 | 4 |  |  |  |  | 14 | $mojo->helper($helper => $code_ref); | 
| 92 |  |  |  |  |  |  | }; | 
| 93 |  |  |  |  |  |  |  | 
| 94 |  |  |  |  |  |  | # Plugin wasn't registered before | 
| 95 | 2 | 100 |  |  |  | 20 | unless (exists $mojo->renderer->helpers->{'new_xml'}) { | 
| 96 |  |  |  |  |  |  |  | 
| 97 |  |  |  |  |  |  | # Default 'new_xml' helper | 
| 98 |  |  |  |  |  |  | $mojo->helper( | 
| 99 |  |  |  |  |  |  | new_xml => sub { | 
| 100 | 3 |  |  | 3 |  | 24968 | shift; | 
| 101 | 3 |  |  |  |  | 17 | return XML::Loy->new( @_ ); | 
| 102 | 1 |  |  |  |  | 9 | }); | 
| 103 |  |  |  |  |  |  |  | 
| 104 |  |  |  |  |  |  |  | 
| 105 |  |  |  |  |  |  | # Add 'render_xml' helper | 
| 106 |  |  |  |  |  |  | $mojo->helper( | 
| 107 |  |  |  |  |  |  | render_xml => sub { | 
| 108 | 5 |  |  | 5 |  | 3258 | my ($c, $xml) = @_; | 
| 109 | 5 |  |  |  |  | 8 | my $format = 'xml'; | 
| 110 |  |  |  |  |  |  |  | 
| 111 |  |  |  |  |  |  | # Check format based on mime type | 
| 112 | 5 |  |  |  |  | 8 | my $class = ref $xml; | 
| 113 | 5 | 50 |  |  |  | 15 | if ($base_classes{$class}) { | 
| 114 | 5 | 100 | 66 |  |  | 24 | if ($base_classes{$class}->[0] && $base_classes{$class}->[1]) { | 
| 115 | 2 |  |  |  |  | 4 | $format = $base_classes{$class}->[0]; | 
| 116 |  |  |  |  |  |  | }; | 
| 117 |  |  |  |  |  |  | }; | 
| 118 |  |  |  |  |  |  |  | 
| 119 |  |  |  |  |  |  | # render XML with correct mime type | 
| 120 | 5 |  |  |  |  | 20 | return $c->render( | 
| 121 |  |  |  |  |  |  | 'data'   => $xml->to_pretty_xml, | 
| 122 |  |  |  |  |  |  | 'format' => $format, | 
| 123 |  |  |  |  |  |  | @_ | 
| 124 |  |  |  |  |  |  | ); | 
| 125 | 1 |  |  |  |  | 15 | }); | 
| 126 |  |  |  |  |  |  | }; | 
| 127 |  |  |  |  |  |  | }; | 
| 128 |  |  |  |  |  |  |  | 
| 129 |  |  |  |  |  |  |  | 
| 130 |  |  |  |  |  |  | 1; | 
| 131 |  |  |  |  |  |  |  | 
| 132 |  |  |  |  |  |  |  | 
| 133 |  |  |  |  |  |  | __END__ |