File Coverage

blib/lib/XML/Atom/Syndication/Object.pm

Criterion	Covered	Total	%
statement	134	141	95.0
branch	52	78	66.6
condition	2	2	100.0
subroutine	30	30	100.0
pod	14	16	87.5
total	232	267	86.8

package XML::Atom::Syndication::Object;
use strict;

use base qw( Class::ErrorHandler );

use constant XMLNS => 'http://www.w3.org/XML/1998/namespace';

use Carp;
use XML::Elemental 2.01;
use XML::Elemental::Util qw( process_name );
use XML::Atom::Syndication::Util qw( nodelist utf8_off );
use XML::Atom::Syndication::Writer;

sub new {
    my $class = shift;
    my $atom = bless {}, $class;
    $atom->init(@_) or return $class->error($atom->errstr);
    $atom;
}

sub init {
    my $atom = shift;
    my %param = @_ == 1 ? (Elem => $_[0]) : @_;
    $atom->set_ns(\%param);
    unless ($atom->{elem} = $param{Elem}) {
        unless ($atom->element_name) {
            $atom->{name} = $param{Name}
              or croak('An Elem or Name parameter is required.');
        }
        $atom->{elem} = XML::Elemental::Element->new;
        $atom->{elem}->name('{' . $atom->ns . '}' . $atom->element_name);
    } else {
        unless ($atom->element_name) {
            my ($ns, $name) = process_name($atom->{elem}->name);
            $atom->{name} = $name;
        }
    }
    $atom;
}

sub ns           { $_[0]->{ns} }
sub elem         { $_[0]->{elem} }
sub element_name { $_[0]->{name} }

sub remove {
    my $atom = shift;
    _remove($atom->elem, @_);
}

sub as_xml {
    my $w = XML::Atom::Syndication::Writer->new;
    $w->set_prefix('', $_[0]->ns);
    $w->as_xml($_[0]->elem, 1);
}

#--- Atom common attributes

sub base {
    @_ > 1
      ? $_[0]->set_attribute(XMLNS, 'base', @_[1 .. $#_])
      : $_[0]->get_attribute(XMLNS, 'base');
}

sub lang {
    @_ > 1
      ? $_[0]->set_attribute(XMLNS, 'lang', @_[1 .. $#_])
      : $_[0]->get_attribute(XMLNS, 'lang');
}

#--- accessors

sub mk_accessors {
    my $class = shift;
    my $type  = shift;
    no strict 'refs';
    foreach my $e (@_) {
        my $accessor = join '::', $class, $e;
        if ($type eq 'element') {
            *$accessor = sub {
                @_ > 1
                  ? $_[0]->set_element($_[0]->ns, $e, @_[1 .. $#_])
                  : $_[0]->get_element($_[0]->ns, $e);
            };
        } elsif ($type eq 'attribute') {
            *$accessor = sub {
                @_ > 1
                  ? $_[0]->set_attribute($_[0]->ns, $e, @_[1 .. $#_])
                  : $_[0]->get_attribute($_[0]->ns, $e);
            };
        } else {    # type is the class to instaniate
            *$accessor = sub {
                @_ > 1
                  ? $_[0]->set_element($_[0]->ns, $e, @_[1 .. $#_])
                  : $_[0]->get_class($type, $_[0]->ns, $e);
            };
        }
    }
}

sub get_element {
    my ($atom, $ns, $name) = @_;
    my $ns_uri =
      ref($ns) eq 'XML::Atom::Syndication::Namespace' ? $ns->{uri} : $ns;
    my @nodes = nodelist($atom, $ns_uri, $name);
    return unless @nodes;
    wantarray
      ? map { utf8_off($_->text_content) } @nodes
      : utf8_off($nodes[0]->text_content);
}

sub get_class {
    my ($atom, $class, $ns, $name) = @_;
    my $ns_uri =
      ref($ns) eq 'XML::Atom::Syndication::Namespace' ? $ns->{uri} : $ns;
    my @nodes = nodelist($atom, $ns_uri, $name);
    return unless @nodes;
    eval "require $class";
    croak("Error creating accessor {$ns}$name: $@") if $@;
    wantarray
      ? map { $class->new(Elem => $_, Namespace => $ns_uri) } @nodes
      : $class->new(Elem => $nodes[0], Namespace => $ns_uri);
}

sub get_attribute {
    my $atom = shift;
    my ($val);
    if (@_ == 1) {
        my ($attr) = @_;
        $val = $atom->{elem}->attributes->{"{}$attr"};
    } elsif (@_ == 2) {
        my ($ns, $attr) = @_;
        $ns = '' if $atom->ns eq $ns;
        $val = $atom->{elem}->attributes->{"{$ns}$attr"};
    }
    utf8_off($val);
}

sub set_element {
    my $atom = shift;
    my ($ns, $name, $val, $attr, $add) = @_;
    $add = $attr if ref $val;
    my $ns_uri =
      ref($ns) eq 'XML::Atom::Syndication::Namespace' ? $ns->{uri} : $ns;
    unless ($add) {
        my @nodes = nodelist($atom, $ns_uri, $name);
        foreach my $node (@nodes) {
            _remove($node) || return $atom->error($node->errstr);
        }
    }
    if (my $class = ref $val) {
        $val = $val->elem if $class =~ /^XML::Atom::Syndication::/;
        $val->parent($atom->elem);
        push @{$atom->elem->contents}, $val;
    } elsif (defined $val) {
        my $elem = XML::Elemental::Element->new;
        $elem->name("{$ns_uri}$name");
        $elem->attributes($attr) if $attr;
        $elem->parent($atom->elem);
        push @{$atom->elem->contents}, $elem;
        use XML::Elemental::Characters;
        my $chars = XML::Elemental::Characters->new;
        $chars->data($val);
        $chars->parent($elem);
        push @{$elem->contents}, $chars;
    }
    $val;
}

sub set_attribute {
    my $atom = shift;
    if (@_ == 2) {
        my ($attr, $val) = @_;
        $atom->{elem}->attributes->{"{}$attr"} = $val;
    } elsif (@_ == 3) {
        my ($ns, $attr, $val) = @_;
        my $ns_uri =
          ref($ns) eq 'XML::Atom::Syndication::Namespace' ? $ns->{uri} : $ns;
        $ns_uri = '' if $atom->ns eq $ns_uri;
        $atom->{elem}->attributes->{"{$ns_uri}$attr"} = $val;
    }
}

#--- utility

sub _remove {
    my $elem   = shift;
    my $parent = $elem->parent
      or die 'Element parent is not defined';
    my @contents = grep { $elem ne $_ } @{$parent->contents};
    $parent->contents(\@contents);
    $elem->parent(undef);
    1;
}

our %NS_MAP = (
               '0.3' => 'http://purl.org/atom/ns#',
               '1.0' => 'http://www.w3.org/2005/Atom',
);
our %NS_VERSION = reverse %NS_MAP;

sub set_ns {
    my $atom  = shift;
    my $param = shift;
    if (my $ns = delete $param->{Namespace}) {
        $atom->{ns}      = $ns;
        $atom->{version} = $NS_VERSION{$ns};
    } else {
        my $version = delete $param->{Version} || '1.0';
        $version = '1.0' if $version == 1;
        my $ns = $NS_MAP{$version}
          or return $atom->error("Unknown version: $version");
        $atom->{ns}      = $ns;
        $atom->{version} = $version;
    }
}

1;

__END__