File Coverage

blib/lib/XML/Struct/Simple.pm

Criterion	Covered	Total	%
statement	51	57	89.4
branch	25	32	78.1
condition	10	12	83.3
subroutine	7	8	87.5
pod	3	3	100.0
total	96	112	85.7

package XML::Struct::Simple;
use strict;
use Moo;
use List::Util qw(first);
use Scalar::Util qw(reftype blessed);

our $VERSION = '0.26';

has root => (
    is => 'rw',
    default => sub { 0 },
);

has attributes => (
    is => 'rw',
    default => sub { 1 },
    coerce => sub { !defined $_[0] or ($_[0] and $_[0] ne 'remove') },
);

has content => (
    is => 'rw',
    default => sub { 'content' },
);

has depth => (
    is => 'rw',
    coerce => sub { (defined $_[0] and $_[0] >= 0) ? $_[0] : undef },
);

sub transform {
    my ($self, $element) = @_;

    my $simple = $self->transform_content($element,0);

    # enforce root for special case text
    if ($self->root or !ref $simple) {
        my $root = $self->root !~ /^[+-]?[0-9]+$/ ? $self->root : $element->[0];
        return { $root => $simple };
    } else {
        return $simple;
    }
}

# returns a (possibly empty) hash or a scalar
sub transform_content {
    my ($self, $element, $depth) = @_;
    $depth = 0 if !defined $depth;

    if (defined $self->depth and $depth >= $self->depth) {
        return $element;
    } elsif ( @$element == 1 ) { # empty tag
        return { };
    }

    my $attributes = {};
    my $children;

    if ( reftype $element->[1] eq 'HASH' ) { # [ $tag, \%attributes, \@children ]
        $attributes = $element->[1] if $self->attributes;
        $children   = $element->[2];
    } else {                                 # [ $tag, \@children ]
        $children   = $element->[1];
    }

    # no element children
    unless ( first { ref $_ } @$children ) {
        my $content = join "", @$children;
        if ($content eq '') {
            return { %$attributes };
        } elsif (!%$attributes) {
            return $content;
        } else {
            return { %$attributes, $self->content => $content };
        }
    }

    my $simple = { map {$_ => [$attributes->{$_}] } keys %$attributes };

    foreach my $child ( @$children ) {
        next unless ref $child; # skip mixed content text

        my $name    = $child->[0];
        my $content = $self->transform_content($child, $depth+1);

        if ( $simple->{$name} ) {
            push @{$simple->{$name}}, $content;
        } else {
            $simple->{$name} = [$content];
        }
    }

    foreach my $name (keys %$simple) {
        next if @{$simple->{$name}} != 1;
        my $c = $simple->{$name}->[0];
        if (!ref $c or (!blessed $c and reftype $c eq 'HASH')) {
            $simple->{$name} = $c;
        }
    }

    return $simple;
}

sub removeXMLAttr {
    my $node = shift;
    ref $node
        ? ( $node->[2]
            ? [ $node->[0], [ map { removeXMLAttr($_) } @{$node->[2]} ] ]
            : [ $node->[0] ] ) # empty element
        : $node;               # text node
}


1;
__END__