File Coverage

blib/lib/Test/XPath.pm

Criterion	Covered	Total	%
statement	78	80	97.5
branch	25	30	83.3
condition	4	6	66.6
subroutine	19	19	100.0
pod	11	11	100.0
total	137	146	93.8

package Test::XPath;

use strict;
use 5.6.2;
use XML::LibXML '1.69';
use Test::Builder;

our $VERSION = '0.20';

sub new {
    my ($class, %p) = @_;
    my $doc = delete $p{doc} || _doc(\%p);
    my $xpc = XML::LibXML::XPathContext->new( $doc->documentElement );
    if (my $ns = $p{xmlns}) {
        while (my ($k, $v) = each %{ $ns }) {
            $xpc->registerNs( $k => $v );
        }
    }
    return bless {
        xpc    => $xpc,
        node   => $doc->documentElement,
        filter => do {
            if (my $f = $p{filter}) {
                if (ref $f eq 'CODE') {
                    $f;
                } elsif ($f eq 'css_selector') {
                    eval 'use HTML::Selector::XPath 0.06';
                    die 'Please install HTML::Selector::XPath to use CSS selectors'
                        if $@;
                    sub {
                        my $xpath = do {
                            my $xp = HTML::Selector::XPath->new(shift)->to_xpath(root => '//');
                            if (eval { $_->isa(__PACKAGE__) } && $_->node ne $doc->documentElement) {
                                # Make it relative to the current node.
                                $xp =~ s{^///[*]}{.};
                            } else {
                                # Start from the top.
                                $xp =~ s{^///[*]}{};
                            }
                            $xp;
                        };
                        return $xpath;
                    }
                } else {
                    die "Unknown filter: $f\n";
                }
            } else {
                sub { shift },
            }
        },
    }, $class;
}

sub ok {
    my ($self, $xpath, $code, $desc) = @_;
    my $xpc  = $self->{xpc};
    my $Test = Test::Builder->new;
    $xpath   = $self->{filter}->($xpath, $self);

    # Code and desc can be reversed, to support PerlX::MethodCallWithBlock.
    ($code, $desc) = ($desc, $code) if ref $desc eq 'CODE';

    if (ref $code eq 'CODE') {
        # Gonna do some recursive testing.
        my @nodes = $xpc->findnodes($xpath, $self->{node})
            or return $Test->ok(0, $desc);

        # Record the current test result.
        my $ret  = $Test->ok(1, $desc);

        # Call the code ref on each found node.
        local $_ = $self;
        for my $node (@nodes) {
            local $self->{node} = $node;
            $code->($self);
        }
        return $ret;
    } else {
        # We're just testing for existence ($code is description).
        $Test->ok( $xpc->exists($xpath, $self->{node}), $code);
    }

}

sub not_ok {
    my ($self, $xpath, $desc) = @_;
    $xpath = $self->{filter}->($xpath);
    my $Test = Test::Builder->new;
    $Test->ok( !$self->{xpc}->exists($xpath, $self->{node}), $desc);
}

sub is     { Test::Builder::new->is_eq(   shift->find_value(shift), @_) }
sub isnt   { Test::Builder::new->isnt_eq( shift->find_value(shift), @_) }
sub like   { Test::Builder::new->like(    shift->find_value(shift), @_) }
sub unlike { Test::Builder::new->unlike(  shift->find_value(shift), @_) }
sub cmp_ok { Test::Builder::new->cmp_ok(  shift->find_value(shift), @_) }

sub node   { shift->{node} }
sub xpc    { shift->{xpc}  }

sub find_value {
    my $self = shift;
    $self->{xpc}->findvalue( $self->{filter}->(shift), $self->{node} );
}

sub _doc {
    my $p = shift;

    # Create and configure the parser.
    my $parser = XML::LibXML->new;

    # Apply any parser options.
    if (my $opts = $p->{options}) {
        while (my ($k, $v) = each %{ $opts }) {
            if (my $meth = $parser->can($k)) {
                $parser->$meth($v)
            } else {
                $parser->set_option($k => $v);
            }
        }
    }

    # Parse and return the document.
    if ($p->{xml}) {
        return $p->{is_html}
            ? $parser->parse_html_string($p->{xml})
            : $parser->parse_string($p->{xml});
    }

    if ($p->{file}) {
        return $p->{is_html}
            ? $parser->parse_html_file($p->{file})
            : $parser->parse_file($p->{file});
    }

    require Carp;
    Carp::croak(
        'Test::XPath->new requires the "xml", "file", or "doc" parameter'
    );
}

# Add Test::XML::XPath compatibility?
# sub like_xpath($$;$)   { __PACKAGE__->new( xml => shift )->ok(     @_ ) }
# sub unlike_xpath($$;$) { __PACKAGE__->new( xml => shift )->not_ok( @_ ) }
# sub is_xpath($$$;$)    { __PACKAGE__->new( xml => shift )->is(     @_ ) }

1;
__END__