File Coverage

blib/lib/XML/Struct/Writer.pm

Criterion	Covered	Total	%
statement	7	9	77.7
branch			n/a
condition			n/a
subroutine	3	3	100.0
pod			n/a
total	10	12	83.3

package XML::Struct::Writer;
use strict;

use Moo;
use XML::LibXML::SAX::Builder;
use XML::Struct::Writer::Stream;
use Scalar::Util qw(blessed reftype);
use Carp;

our $VERSION = '0.26';

has attributes => (is => 'rw', default => sub { 1 });
has encoding   => (is => 'rw', default => sub { 'UTF-8' });
has version    => (is => 'rw', default => sub { '1.0' });
has standalone => (is => 'rw');
has pretty     => (is => 'rw', default => sub { 0 }); # 0|1|2
has xmldecl    => (is => 'rw', default => sub { 1 });
has handler    => (is => 'lazy', builder => 1);

has to => (
    is => 'rw',
    coerce => sub {
        if (!ref $_[0]) {
            return IO::File->new($_[0], 'w');
        } elsif (reftype($_[0]) eq 'SCALAR') {
            open my $io,">:utf8",$_[0];
            return $io;
        } else { # IO::Handle, GLOB, ...
            return $_[0];
        }
    },
    trigger => sub { delete $_[0]->{handler} }
);

sub _build_handler {
    $_[0]->to ? XML::Struct::Writer::Stream->new(
        fh       => $_[0]->to,
        encoding => $_[0]->encoding,
        version  => $_[0]->version,
        pretty   => $_[0]->pretty,
    ) : XML::LibXML::SAX::Builder->new( handler => $_[0] );
}

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

    $self->writeStart;
    $self->writeElement(
        $self->microXML($element, $name // 'root')
    );
    $self->writeEnd;

    $self->handler->can('result') ? $self->handler->result : 1;
}

*writeDocument = \&write;

# TODO: Make available as function in XML::Struct or XML::Struct::Simple
sub microXML {
    my ($self, $element, $name) = @_;

    my $type = reftype($element);
    if ($type) {
        # MicroXML
        if ($type eq 'ARRAY') {
            if (@$element == 1) {
                return $element;
            } elsif (@$element == 2) {
                if ( (reftype($element->[1]) // '') eq 'ARRAY') {
                    return [ $element->[0], {}, $element->[1] ];
                } elsif (!$self->attributes and %{$element->[1]}) {
                    return [ $element->[0] ];
                } else {
                    return $element;
                }
            } else {
                if (!$self->attributes and %{$element->[1]}) {
                    return [ $element->[0], {}, $element->[2] ];
                } else {
                    return $element;
                }
            }
        # SimpleXML
        } elsif ($type eq 'HASH') {
            my $children = [
                map {
                    my ($tag, $content) = ($_, $element->{$_});
                    # text
                    if (!ref $content) {
                        [ $tag, {}, [$content] ]
                    } elsif (reftype($content) eq 'ARRAY') {
                        @$content
                            ? map { [ $tag, {}, [$_] ] } @$content
                            : [ $tag ];
                    } elsif (reftype $content  eq 'HASH' ) {
                        [ $tag, {}, [ $content ] ];
                    } else {
                        ();
                    }
                }
                grep { defined $element->{$_} }
                sort keys %$element
            ];
            return $name ? [ $name, {}, $children ] : @$children;
        }
    }

    croak "expected XML as ARRAY or HASH reference";
}

sub writeElement {
    my $self = shift;

    foreach my $element (@_) {
        $self->writeStartElement($element);
        foreach my $child ( @{ $element->[2] // [] } ) {
            if (ref $child) {
                $self->writeElement( $self->microXML($child) );
            } else {
                $self->writeCharacters($child);
            }
        }

        $self->writeEndElement($element);
    }
}

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

    my $args = { Name => $element->[0] };
    $args->{Attributes} = $element->[1] if $element->[1];

    $self->handler->start_element($args);
}

sub writeEndElement {
    my ($self, $element) = @_;
    $self->handler->end_element({ Name => $element->[0] });
}

sub writeCharacters {
    $_[0]->handler->characters({ Data => $_[1] });
}

sub writeStart {
    my $self = shift;
    $self->handler->start_document;
    if ($self->handler->can('xml_decl') && $self->xmldecl) {
        $self->handler->xml_decl({
            Version => $self->version,
            Encoding => $self->encoding,
            Standalone => $self->standalone,
        });
    }
    $self->writeStartElement(@_) if @_;
}

sub writeEnd {
    my $self = shift;
    $self->writeEndElement(@_) if @_;
    $self->handler->end_document;
}

1;
__END__