File Coverage

blib/lib/XML/RSS/LibXML.pm

Criterion	Covered	Total	%
statement	16	18	88.8
branch			n/a
condition			n/a
subroutine	6	6	100.0
pod			n/a
total	22	24	91.6

package XML::RSS::LibXML;
use strict;
use warnings;
use base qw(Class::Accessor::Fast);
use Carp;
use UNIVERSAL::require;
use XML::LibXML;
use XML::LibXML::XPathContext;
use XML::RSS::LibXML::Namespaces qw(NS_RSS10);

our $VERSION = '0.3105';

__PACKAGE__->mk_accessors($_) for qw(impl encoding strict namespaces modules output stylesheets _internal num_items);

sub new
{
    my $class = shift;
    my %args  = @_;

    my $impl  = $class->create_impl($args{version});
    my $self = bless {
        impl       => $impl,
        version    => $args{version},
        base       => $args{base},
        encoding   => $args{encoding} || 'UTF-8',
        strict     => exists $args{strict} ? $args{strict} : 0,
        namespaces => {},
        modules    => {},
        _internal  => {},
        stylesheets => $args{stylesheet} ? (ref ($args{stylesheet}) eq 'ARRAY' ? $args{stylesheet} : [ $args{stylesheet} ]) : [],
        num_items   => 0,
        libxml_opts => $args{libxml_opts} || {
            recover => 1,
            load_ext_dtd => 0
        },
    }, $class;

    $self->impl->reset($self);
    return $self;
}

{
    # Proxy methods
    foreach my $method (qw(reset channel image add_item textinput skipDays skipHours)) {
        no strict 'refs';
        *{$method} = sub { my $self = shift; $self->impl->$method($self, @_) };
    }
}

sub internal
{
    my $self = shift;
    my $name = shift;

    my $value = $self->{_internal}{$name};
    if (@_) {
        $self->{_internal}{$name} = $_[0];
    }
    return $value;
}

sub version
{
    my $self = shift;
    my $version = $self->{version};
    if (@_) {
        $self->{version} = $_[0];
        $self->internal('version', $_[0]);
    }
    return $version;
}

sub base
{
    my $self = shift;
    my $base = $self->{base};
    if (@_) {
        $self->{base} = $_[0];
        $self->internal('base', $_[0]);
    }
    return $base;
}

sub add_module
{
    my $self = shift;
    my %args = @_;

    if ($args{prefix} eq '#default') {
        # no op
    } else {
        $args{prefix} =~ /^[a-zA-Z_][a-zA-Z0-9.\-_]*$/
            or croak "a namespace prefix should look like [a-z_][a-z0-9.\\-_]*";
    }

    $args{uri}
        or croak "a URI must be provided in a namespace declaration";

    $self->namespaces->{$args{prefix}} = $args{uri};
    $self->modules->{$args{uri}} = $args{prefix};
}

sub items
{
    my $self = shift;
    my $items = $self->{items};
    $items ?
        (wantarray ? @$items : $items) :
        (wantarray ? ()      : undef);
}

sub create_impl
{
    my $self = shift;
    my $version = shift;
    my $module = "Null";
    if ($version) {
        $module = $version;
        $module =~ s/\./_/g;
        $module = "V$module";
    }

    my $pkg;
    REQUIRE: {
        $pkg = "XML::RSS::LibXML::$module";
        eval {
            $pkg->require or die;
        };
        if (my $e = $@) {
            if ($e =~ /Can't locate/) {
                $module = "V1_0";
                $version = '1.0';
                redo REQUIRE;
            }
        }
    }
    return $pkg->new;
}

sub create_libxml
{
    my $self = shift;
    my $p    = XML::LibXML->new;
    my $opts = $self->{libxml_opts} || {};
    while (my($key, $value) = each %$opts) {
        $p->$key($value);
    }

    return $p;
}

sub parse
{
    my $self = shift;
    $self->reset();
    my $p    = $self->create_libxml;
    my $dom  = $p->parse_string($_[0]);
    $self->parse_dom($dom);
    $self;
}

sub parsefile
{
    my $self = shift;
    $self->reset();
    my $p    = $self->create_libxml;
    my $dom  = $p->parse_file($_[0]);
    $self->parse_dom($dom);
    $self;
}

sub parse_dom
{
    my $self = shift;
    my $dom  = shift;
    my $version = $self->guess_version_from_dom($dom);
    my $impl = $self->create_impl($version);
    $self->impl($impl);
    $self->impl->parse_dom($self, $dom);
    $self;
}

sub get_namespaces
{
    my $self = shift;
    my $node = shift;
    my %h = map {
        (($_->getLocalName() || '#default') => $_->getData)
    } $node->getNamespaces();

    if ($h{rdf} && ! $h{'#default'}) {
        $h{'#default'} = NS_RSS10;
    }

    return wantarray ? %h : \%h;
}

sub create_xpath_context
{
    my $self = shift;
    my $namespaces = shift || {};
    my $xc = XML::LibXML::XPathContext->new;
    foreach my $prefix (keys %$namespaces) {
        my $namespace = $namespaces->{$prefix};
        $xc->registerNs($prefix, $namespace);
    }
    return $xc;
}

sub guess_version_from_dom
{
    my $self = shift;
    my $dom = shift;
    my $root = $dom->documentElement();
    my $namespaces = $self->get_namespaces($root);
    # Check if we have non-default RSS namespace
    my $rss10_prefix = 'rss10';
    while (my($prefix, $uri) = each %$namespaces) {
        if ($uri eq NS_RSS10) {
            $rss10_prefix = $prefix;
            last;
        }
    }

    if ($rss10_prefix && $rss10_prefix eq '#default') {
        $rss10_prefix = 'rss10';
        $namespaces->{$rss10_prefix} = NS_RSS10;
        $root->setNamespace(NS_RSS10, $rss10_prefix, 0);
    }

    keys %{$namespaces}; # reset iterator

    my $xc  = $self->create_xpath_context(
        # use the minimum required to guess
        $namespaces
    );

    my $version = 'UNKNOWN';

    # Test starting from the most likely candidate
    if (eval { $xc->findnodes('/rdf:RDF', $dom) }) {
        # 1.0 or 0.9.
        # Wrap up in evail, because we may not have registered rss10
        # namespace prefix
        if (eval { $xc->findnodes("/rdf:RDF/$rss10_prefix:channel", $dom) }) {
            $version = '1.0';
        } else {
            $version = '0.9';
        }
    } elsif (eval { $xc->findnodes('/rss', $dom) }) {
        # 0.91 or 2.0 -ish
        $version = $xc->findvalue('/rss/@version', $dom);
    } else {
        die "Failed to guess version";
    }
    $version = "$1.0" if $version =~ /^(\d)$/;
    return $version;
}

sub as_string
{
    my $self = shift;
    my $format = @_ ? $_[0] : 1;
    my $impl = $self->create_impl($self->output || $self->version);
    $self->impl($impl);
    $self->impl->as_string($self, $format);
}

sub save
{
    my $self = shift;
    my $file = shift;

    open(OUT, ">$file") or Carp::croak("Cannot open file $file for write: $!");
    print OUT $self->as_string;
    close(OUT);
}

1;

__END__