File Coverage

blib/lib/XML/Assert.pm

Criterion	Covered	Total	%
statement	1	3	33.3
branch			n/a
condition			n/a
subroutine	1	1	100.0
pod			n/a
total	2	4	50.0

## ----------------------------------------------------------------------------
# Copyright (C) 2010 NZ Registry Services
## ----------------------------------------------------------------------------
package XML::Assert;

use XML::LibXML;
use Any::Moose;

our $VERSION = '0.03';
our $VERBOSE = $ENV{XML_ASSERT_VERBOSE} || 0;

my $PARSER = XML::LibXML->new();

has 'error' =>
    is => "rw",
    isa => "Str",
    clearer => "_clear_error",
    ;

sub _self {
    my $args = shift;
    if ( ref $args->[0] eq __PACKAGE__ ) {
        return shift @$args;
    }
    elsif ( $args->[0] eq __PACKAGE__ ) {
        return do { shift @$args }->new();
    }
    return __PACKAGE__->new();
}

# a hashref of all the namespaces being used (or asked for in the XPath)
has 'xmlns' =>
    is => "rw",
    isa => "HashRef[Str]",
    ;

has 'error' =>
    is => "rw",
    isa => "Str",
    clearer => "_clear_error",
    ;

sub register_ns {
    my ($self, $doc) = @_;

    if ( my $xmlns = $self->xmlns ) {
        my $xpc = XML::LibXML::XPathContext->new($doc);
		$xpc->registerNs($_ => $xmlns->{$_})
		    for keys %$xmlns;
        # do the test against the XPath Context rather than the Document
        $doc = $xpc;
    }
    return $doc;
}

# assert_xpath_count
sub assert_xpath_count {
    my $self = _self(\@_);
    my ($doc, $xpath, $count) = @_;

    $doc = $self->register_ns($doc);

    my ($nodes) = $doc->find($xpath);
    print 'assert_xpath_count: Found ' . (scalar @$nodes) . "\n" if $VERBOSE;
    unless ( @$nodes == $count ) {
        die "XPath '$xpath' has " . (scalar @$nodes) . " " . $self->_plural(scalar @$nodes, 'node') . ", not $count as expected";
    }

    return 1;
}

sub is_xpath_count {
    my $self = _self(\@_);
    my ($doc, $xpath, $count) = @_;

    $self->_clear_error();
    eval { $self->assert_xpath_count($doc, $xpath, $count) };
    if ( $@ ) {
        $self->error($@);
        return;
    }
    return 1;
}

# assert_xpath_value_match
sub assert_xpath_value_match {
    my $self = _self(\@_);
    my ($doc, $xpath, $match) = @_;

    $doc = $self->register_ns($doc);

    # firstly, check that the node actually exists
    my ($nodes) = $doc->find($xpath);
    print 'assert_xpath_value_match: Found ' . (scalar @$nodes) . "\n" if $VERBOSE;
    unless ( @$nodes == 1 ) {
        die "XPath '$xpath' matched " . (scalar @$nodes) . " nodes when we expected to match one";
    }

    # check the value is what we expect
    my $node = $nodes->[0];
    print "assert_xpath_value_match: This node's value : " . $node->string_value() . "\n" if $VERBOSE;
    unless ( $node->string_value() ~~ $match ) {
        die "XPath '$xpath' doesn't match '$match' as expected, instead it is '" . $node->string_value() . "'";
    }

    return 1;
}

sub does_xpath_value_match {
    my $self = _self(\@_);
    my ($doc, $xpath, $match) = @_;

    $self->_clear_error();
    eval { $self->assert_xpath_value_match($doc, $xpath, $match) };
    if ( $@ ) {
        $self->error($@);
        return;
    }
    return 1;
}

# assert_xpath_values_match
sub assert_xpath_values_match {
    my $self = _self(\@_);
    my ($doc, $xpath, $match) = @_;

    $doc = $self->register_ns($doc);

    # firstly, check that the node actually exists
    my ($nodes) = $doc->find($xpath);
    print 'assert_xpath_values_match: Found ' . (scalar @$nodes) . "\n" if $VERBOSE;
    unless ( @$nodes ) {
        die "XPath '$xpath' matched no nodes when we expected to match at least one";
    }

    # check the values are what we expect
    my $i = 0;
    foreach my $node ( @$nodes ) {
	print "assert_xpath_value_match: This node's value : " . $node->string_value() . "\n" if $VERBOSE;
        unless ( $node->string_value() ~~ $match ) {
            die "Elment $i of XPath '$xpath' doesn't match '$match' as expected, instead it is '" . $node->string_value() . "'";
        }
        $i++;
    }

    return 1;
}

sub do_xpath_values_match {
    my $self = _self(\@_);
    my ($doc, $xpath, $match) = @_;

    $self->_clear_error();
    eval { $self->assert_xpath_values_match($doc, $xpath, $match) };
    if ( $@ ) {
        $self->error($@);
        return;
    }
    return 1;
}

# assert_attr_value_match
sub assert_attr_value_match {
    my $self = _self(\@_);
    my ($doc, $xpath, $attr, $match) = @_;

    $doc = $self->register_ns($doc);

    # firstly, check that the node actually exists
    my ($nodes) = $doc->find($xpath);
    print 'assert_attr_value_match: Found ' . (scalar @$nodes) . "\n" if $VERBOSE;
    unless ( @$nodes == 1 ) {
        die "XPath '$xpath' matched " . (scalar @$nodes) . " nodes when we expected to match one";
    }

    # check that this node has this attribute
    my $node = $nodes->[0];
    my $value = $node->getAttribute( $attr );
    print "assert_xpath_value_match: This attr's value : " . $value . "\n" if $VERBOSE;
    unless ( $value ~~ $match ) {
        die "XPath '$xpath', attribute '$attr' doesn't match '$match' as expected, instead it is '" . $value . "'";
    }

    return 1;
}

sub does_attr_value_match {
    my $self = _self(\@_);
    my ($doc, $xpath, $attr, $match) = @_;

    $self->_clear_error();
    eval { $self->assert_attr_value_match($doc, $xpath, $attr, $match) };
    if ( $@ ) {
        $self->error($@);
        return;
    }
    return 1;

}

# assert_attr_values_match
sub assert_attr_values_match {
    my $self = _self(\@_);
    my ($doc, $xpath, $attr, $match) = @_;

    $doc = $self->register_ns($doc);

    # firstly, check that the node actually exists
    my ($nodes) = $doc->find($xpath);
    print 'assert_attr_values_match: Found ' . (scalar @$nodes) . "\n" if $VERBOSE;
    unless ( @$nodes ) {
        die "XPath '$xpath' matched no nodes when we expected to match at least one";
    }

    # check the values are what we expect
    my $i = 0;
    foreach my $node ( @$nodes ) {
        my $value = $node->getAttribute( $attr );
	print "assert_xpath_values_match: This attr's value : " . $value . "\n" if $VERBOSE;
        unless ( $value ~~ $match ) {
            die "Attribute '$attr' of element $i of XPath '$xpath' doesn't match '$match' as expected, instead it is '" . $value . "'";
        }
        $i++;
    }

    return 1;
}

sub do_attr_values_match {
    my $self = _self(\@_);
    my ($doc, $xpath, $attr, $match) = @_;

    $self->_clear_error();
    eval { $self->assert_attr_values_match($doc, $xpath, $attr, $match) };
    if ( $@ ) {
        $self->error($@);
        return;
    }
    return 1;

}

# private functions
sub _plural {
    my ($class, $number, $single, $plural) = @_;

    return $number == 1 ? $single : defined $plural ? $plural : "${single}s";
}

1;
__END__