File Coverage

blib/lib/Dancer/Serializer/XML.pm

Criterion	Covered	Total	%
statement	24	58	41.3
branch	0	10	0.0
condition	0	10	0.0
subroutine	8	18	44.4
pod	4	8	50.0
total	36	104	34.6

package Dancer::Serializer::XML;
our $AUTHORITY = 'cpan:SUKRIA';
#ABSTRACT: serializer for handling XML data
$Dancer::Serializer::XML::VERSION = '1.3514_04'; # TRIAL
$Dancer::Serializer::XML::VERSION = '1.351404';
use strict;
use warnings;
use Carp;
use Dancer::ModuleLoader;
use Dancer::Config 'setting';
use base 'Dancer::Serializer::Abstract';

# singleton for the XML::Simple object
my $_xs;

# helpers

sub from_xml {
    my $s = Dancer::Serializer::XML->new;
    $s->deserialize(@_);
}

sub to_xml {
    my $s = Dancer::Serializer::XML->new;
    $s->serialize(@_);
}

# class definition

sub loaded_xmlsimple {
    Dancer::ModuleLoader->load('XML::Simple');
}

sub loaded_xmlbackends {
    # we need either XML::Parser or XML::SAX too
    Dancer::ModuleLoader->load('XML::Parser') or
    Dancer::ModuleLoader->load('XML::SAX');
}

sub init {
    my ($self) = @_;
    die 'XML::Simple is needed and is not installed'
      unless $self->loaded_xmlsimple;
    die 'XML::Simple needs XML::Parser or XML::SAX and neither is installed'
      unless $self->loaded_xmlbackends;
    # Disable fetching external entities, as that's a security hole: this allows
    # someone to fetch remote websites from the server, or to read local files.
    # This only works for XML::Parser when called directly from XML::Simple;
    # for XML::SAX we'll need to do some even *more* horrible stuff later on.
    $_xs = XML::Simple->new(
        ParserOpts => [
            Handlers => {
                ExternEnt => sub {
                    return '';
                }
            }
        ],
    );
}

sub serialize {
    my $self    = shift;
    my $entity  = shift;
    my %options = (RootName => 'data');

    my $s = setting('engines') || {};
    if (exists($s->{XMLSerializer}) && exists($s->{XMLSerializer}{serialize})) {
        %options = (%options, %{$s->{XMLSerializer}{serialize}});
    }

    %options = (%options, @_);


    $_xs->XMLout($entity, %options);
}

sub deserialize {
    my $self = shift;
    my $xml = shift;
    my %options = ();

    my $s = setting('engines') || {};
    if (exists($s->{XMLSerializer}) && exists($s->{XMLSerializer}{deserialize})) {
        %options = (%options, %{$s->{XMLSerializer}{deserialize}});
    }

    %options = (%options, @_);
    # This is the promised terrible hack: claim that the LWP-talking code has
    # already been loaded, and make sure that the handler that's called when
    # we're dealing with an external entity does nothing.
    # For whichever reason, this handler is called despite XML::Parser
    # (which on my machine is the only XML::SAX backend that can handle
    # external entities) having a ParseParamEnt option which is off by default,
    # but appears to only be used deep in the XML::Parser XS guts.
    no warnings 'redefine';
    local *XML::Parser::lwp_ext_ent_handler = sub { return };
    local $INC{'XML/Parser/LWPExternEnt.pl'}
        = 'Dancer::Serializer::XML disabled loading this to patch around '
        . 'XXE vulnerabilities';
    $_xs->XMLin($xml, %options);
    use warnings 'redefine';
}

sub content_type {'text/xml'}

1;

__END__