File Coverage

blib/lib/Test/XML/Ordered.pm

Criterion	Covered	Total	%
statement	132	151	87.4
branch	51	72	70.8
condition	9	14	64.2
subroutine	23	23	100.0
pod	3	3	100.0
total	218	263	82.8

package Test::XML::Ordered;
$Test::XML::Ordered::VERSION = '0.2.0';
use strict;
use warnings;

use 5.010;

use XML::LibXML::Reader;

use Test::More;

use base 'Exporter';

use vars '@EXPORT_OK';

@EXPORT_OK = (qw(is_xml_ordered));

sub new
{
    my $class = shift;
    my $self = {};

    bless $self, $class;

    $self->_init(@_);

    return $self;
}

sub _got
{
    return shift->{got_reader};
}

sub _expected
{
    return shift->{expected_reader};
}

sub _init
{
    my ($self, $args) = @_;

    $self->{got_reader} =
        XML::LibXML::Reader->new(@{$args->{got_params}});
    $self->{expected_reader} =
        XML::LibXML::Reader->new(@{$args->{expected_params}});

    $self->{diag_message} = $args->{diag_message};

    $self->{got_end} = 0;
    $self->{expected_end} = 0;

    return;
}

sub _got_end
{
    return shift->{got_end};
}

sub _expected_end
{
    return shift->{expected_end};
}

sub _read_got
{
    my $self = shift;

    if ($self->_got->read() <= 0)
    {
        $self->{got_end} = 1;
    }

    return;
}

sub _read_expected
{
    my $self = shift;

    if ($self->_expected->read() <= 0)
    {
        $self->{expected_end} = 1;
    }

    return;
}

sub _next_elem
{
    my $self = shift;

    $self->_read_got();
    $self->_read_expected();

    return;
}

sub _ns
{
    my $elem = shift;
    my $ns = $elem->namespaceURI();

    return defined($ns) ? $ns : "";
}

sub _compare_loop
{
    my $self = shift;

    my $calc_prob = sub {
        my $args = shift;

        if (!exists($args->{param}))
        {
            die "No 'param' specified.";
        }
        return
        {
            verdict => 0,
            param => $args->{param},
            (exists($args->{got})
                ? (got => $args->{got}, expected => $args->{expected})
                : ()
            ),
        }
    };

    NODE_LOOP:
    while ((!$self->_got_end()) && (!$self->_expected_end()))
    {
        my $type = $self->_got->nodeType();
        my $exp_type = $self->_expected->nodeType();

        if ($type == XML_READER_TYPE_SIGNIFICANT_WHITESPACE())
        {
            $self->_read_got();
            redo NODE_LOOP;
        }
        elsif ($exp_type == XML_READER_TYPE_SIGNIFICANT_WHITESPACE())
        {
            $self->_read_expected();
            redo NODE_LOOP;
        }
        elsif ($type != $exp_type)
        {
            return $calc_prob->({param => "nodeType"});
        }
        elsif ($type == XML_READER_TYPE_TEXT())
        {
            my $got_text = $self->_got->value();
            my $expected_text = $self->_expected->value();

            foreach my $t ($got_text, $expected_text)
            {
                $t =~ s{\A\s+}{}ms;
                $t =~ s{\s+\z}{}ms;
                $t =~ s{\s+}{ }gms;
            }
            if ($got_text ne $expected_text)
            {
                return $calc_prob->(
                    {
                        param => "text",
                        got => $got_text,
                        expected => $expected_text,
                    }
                );
            }
        }
        elsif ($type == XML_READER_TYPE_ELEMENT())
        {
            my $check = sub {
                if ($self->_got->localName() ne $self->_expected->localName())
                {
                    return $calc_prob->({param => "element_name"});
                }
                if (_ns($self->_got) ne _ns($self->_expected))
                {
                    return $calc_prob->({param => "mismatch_ns"});
                }

                my $list_attrs = sub {
                    my ($elem) = @_;

                    my @list;

                    if ($elem->moveToFirstAttribute())
                    {
                        my $add = sub {

                            my $ns = _ns($elem);
                            if ($ns ne 'http://www.w3.org/2000/xmlns/')
                            {
                                push @list,
                                { ns => $ns, localName => $elem->localName() };
                            }
                        };

                        $add->();
                        while ($elem->moveToNextAttribute() > 0)
                        {
                            $add->();
                        }
                        if ($elem->moveToElement() <= 0)
                        {
                            die "Cannot move back to element.";
                        }
                    }

                    foreach my $attr (@list)
                    {
                        $attr->{value} = ((length($attr->{ns})
                            ?  $elem->getAttributeNs(
                                $attr->{localName},
                                $attr->{ns},
                            )
                            : $elem->getAttribute($attr->{localName})
                        ) // '');
                    }

                    return
                    [
                        sort {
                            ($a->{ns} cmp $b->{ns})
                                or
                            ($a->{localName} cmp $b->{localName})
                        } @list
                    ]
                    ;
                };

                my @got_attrs = @{$list_attrs->($self->_got())};
                my @exp_attrs = @{$list_attrs->($self->_expected())};

                while (@got_attrs and @exp_attrs)
                {
                    my $got_a = shift(@got_attrs);
                    my $exp_a = shift(@exp_attrs);

                    if ($got_a->{ns} ne $exp_a->{ns})
                    {
                        return
                            $calc_prob->(
                                {
                                    param => "attr_ns",
                                    got => $got_a->{ns},
                                    expected => $exp_a->{ns},
                                }
                            );
                    }
                    if ($got_a->{localName} ne $exp_a->{localName})
                    {
                        return
                            $calc_prob->(
                                {
                                    param => "attr_localName",
                                    got => $got_a->{localName},
                                    expected => $exp_a->{localName},
                                }
                            );
                    }
                    if ($got_a->{value} ne $exp_a->{value})
                    {
                        return
                            $calc_prob->(
                                {
                                    param => "attr_value",
                                    got => $got_a->{value},
                                    expected => $exp_a->{value},
                                }
                            );
                    }
                }
                if (@got_attrs)
                {
                    return $calc_prob->(
                        {
                            param => "extra_attr_got",
                            got => $self->_got,
                            expected => $self->_expected,
                        }
                    );
                }
                if (@exp_attrs)
                {
                    return $calc_prob->(
                        {
                            param => "extra_attr_expected",
                            got => $self->_got,
                            expected => $self->_expected,
                        }
                    );
                }
                return;
            };

            if (my $ret = $check->())
            {
                return $ret;
            }

            my $is_got_empty = $self->_got->isEmptyElement;
            my $is_expected_empty = $self->_expected->isEmptyElement;

            if ($is_got_empty && (!$is_expected_empty))
            {
                $self->_read_expected();
                if (my $ret = $check->())
                {
                    return $ret;
                }
            }
            elsif ($is_expected_empty && (!$is_got_empty))
            {
                $self->_read_got();
                if (my $ret = $check->())
                {
                    return $ret;
                }
            }
        }
    }
    continue
    {
        $self->_next_elem();
    }

    return { verdict => 1};
}

sub _get_diag_message
{
    my ($self, $status_struct) = @_;

    if ($status_struct->{param} eq "nodeType")
    {
        return
            "Different Node Type!\n"
            . "Got: " . $self->_got->nodeType() . " at line " . $self->_got->lineNumber()
            . "\n"
            . "Expected: " . $self->_expected->nodeType() . " at line " . $self->_expected->lineNumber()
            ;
    }
    elsif ($status_struct->{param} eq "text")
    {
        return
            "Texts differ: Got <<$status_struct->{got}>> at " . $self->_got->lineNumber(). " ; Expected <<$status_struct->{expected}>> at ". $self->_expected->lineNumber();
    }
    elsif ($status_struct->{param} eq "element_name")
    {
        return
            "Got name: " . $self->_got->localName(). " at " . $self->_got->lineNumber() .
            " ; " .
            "Expected name: " . $self->_expected->localName() . " at " .$self->_expected->lineNumber();
    }
    elsif ($status_struct->{param} eq "mismatch_ns")
    {
        return
            "Got Namespace: " . _ns($self->_got). " at " . $self->_got->lineNumber() .
            " ; " .
            "Expected Namespace: " . _ns($self->_expected) . " at " .$self->_expected->lineNumber();
    }
    elsif ($status_struct->{param} eq "extra_attr_got")
    {
        return
            "Extra attribute for got at " . $self->_got->lineNumber() .
            " ; " .
            "Expected at " .$self->_expected->lineNumber();
    }
    elsif ($status_struct->{param} eq "attr_localName")
    {
        return
            "Got Attribute localName: <<$status_struct->{got}>> at " . $self->_got->lineNumber() .
            " ; " .
            "Expected Attribute localName: <<$status_struct->{expected}>> at  " .$self->_expected->lineNumber();
    }
    elsif ($status_struct->{param} eq "attr_value")
    {
        return
            "Got Attribute value: <<$status_struct->{got}>> at " . $self->_got->lineNumber() .
            " ; " .
            "Expected Attribute value: <<$status_struct->{expected}>> at  " .$self->_expected->lineNumber();
    }
    else
    {
        die "Unknown param: $status_struct->{param}";
    }
}

sub compare
{
    local $Test::Builder::Level = $Test::Builder::Level+1;

    my $self = shift;

    $self->_next_elem();

    my $status_struct = $self->_compare_loop();
    my $verdict = $status_struct->{verdict};

    if (!$verdict)
    {
        diag($self->_get_diag_message($status_struct));
    }

    return ok($verdict, $self->{diag_message});
}

sub is_xml_ordered
{
    local $Test::Builder::Level = $Test::Builder::Level+1;

    my ($got_params, $expected_params, $args, $message) = @_;

    my $comparator =
        Test::XML::Ordered->new(
            {
                got_params => $got_params,
                expected_params => $expected_params,
                diag_message => $message,
            }
        );

    return $comparator->compare();
}

1;

__END__