File Coverage

File:blib/lib/Test/XPath.pm
Coverage:93.4%

linestmtbrancondsubcode
1package Test::XPath;
2
3
7
7
7
use strict;
4
7
7
7
use 5.6.2;
5
7
7
7
use XML::LibXML '1.69';
6
7
7
7
use Test::Builder;
7
8our $VERSION = '0.16';
9
10sub new {
11
18
    my ($class, %p) = @_;
12
18
    my $doc = delete $p{doc} || _doc(\%p);
13
17
    my $xpc = XML::LibXML::XPathContext->new( $doc->documentElement );
14
17
    if (my $ns = $p{xmlns}) {
15
3
7
        while (my ($k, $v) = each %{ $ns }) {
16
4
            $xpc->registerNs( $k => $v );
17        }
18    }
19    return bless {
20        xpc    => $xpc,
21        node   => $doc->documentElement,
22
17
        filter => do {
23
17
            if (my $f = $p{filter}) {
24
1
                if (ref $f eq 'CODE') {
25
0
                    $f;
26                } elsif ($f eq 'css_selector') {
27
1
1
1
1
                    eval 'use HTML::Selector::XPath 0.06';
28
1
                    die 'Please install HTML::Selector::XPath to use CSS selectors'
29                        if $@;
30                    sub {
31
22
                        my $xpath = do {
32
22
                            my $xp = HTML::Selector::XPath->new(shift)->to_xpath(root => '//');
33
22
22
                            if (eval { $_->isa(__PACKAGE__) } && $_->node ne $doc->documentElement) {
34                                # Make it relative to the current node.
35
4
                                $xp =~ s{^///[*]}{.};
36                            } else {
37                                # Start from the top.
38
18
                                $xp =~ s{^///[*]}{};
39                            }
40
22
                            $xp;
41                        };
42
22
                        return $xpath;
43                    }
44
1
                } else {
45
0
                    die "Unknown filter: $f\n";
46                }
47            } else {
48
101
                sub { shift },
49
16
            }
50        },
51    }, $class;
52}
53
54sub ok {
55
72
    my ($self, $xpath, $code, $desc) = @_;
56
72
    my $xpc  = $self->{xpc};
57
72
    my $Test = Test::Builder->new;
58
72
    $xpath   = $self->{filter}->($xpath, $self);
59
60    # Code and desc can be reversed, to support PerlX::MethodCallWithBlock.
61
72
    ($code, $desc) = ($desc, $code) if ref $desc eq 'CODE';
62
63
72
    if (ref $code eq 'CODE') {
64        # Gonna do some recursive testing.
65
15
        my @nodes = $xpc->findnodes($xpath, $self->{node})
66            or return $Test->ok(0, $desc);
67
68        # Record the current test result.
69
15
        my $ret  = $Test->ok(1, $desc);
70
71        # Call the code ref on each found node.
72
15
        local $_ = $self;
73
15
        for my $node (@nodes) {
74
29
            local $self->{node} = $node;
75
29
            $code->($self);
76        }
77
15
        return $ret;
78    } else {
79        # We're just testing for existence ($code is description).
80
57
        $Test->ok( $xpc->exists($xpath, $self->{node}), $code);
81    }
82
83}
84
85sub not_ok {
86
4
    my ($self, $xpath, $desc) = @_;
87
4
    $xpath = $self->{filter}->($xpath);
88
4
    my $Test = Test::Builder->new;
89
4
    $Test->ok( !$self->{xpc}->exists($xpath, $self->{node}), $desc);
90}
91
92
26
sub is     { Test::Builder::new->is_eq(   shift->find_value(shift), @_) }
93
5
sub isnt   { Test::Builder::new->isnt_eq( shift->find_value(shift), @_) }
94
5
sub like   { Test::Builder::new->like(    shift->find_value(shift), @_) }
95
5
sub unlike { Test::Builder::new->unlike(  shift->find_value(shift), @_) }
96
5
sub cmp_ok { Test::Builder::new->cmp_ok(  shift->find_value(shift), @_) }
97
98
4
sub node   { shift->{node} }
99
1
sub xpc    { shift->{xpc}  }
100
101sub find_value {
102
47
    my $self = shift;
103
47
    $self->{xpc}->findvalue( $self->{filter}->(shift), $self->{node} );
104}
105
106sub _doc {
107
17
    my $p = shift;
108
109    # Create and configure the parser.
110
17
    my $parser = XML::LibXML->new;
111
112    # Apply any parser options.
113
17
    if (my $opts = $p->{options}) {
114
3
10
        while (my ($k, $v) = each %{ $opts }) {
115
7
            if (my $meth = $parser->can($k)) {
116
6
                $parser->$meth($v)
117            } else {
118
1
                $parser->set_option($k => $v);
119            }
120        }
121    }
122
123    # Parse and return the document.
124
17
    if ($p->{xml}) {
125
11
        return $p->{is_html}
126            ? $parser->parse_html_string($p->{xml})
127            : $parser->parse_string($p->{xml});
128    }
129
130
6
    if ($p->{file}) {
131
5
        return $p->{is_html}
132            ? $parser->parse_html_file($p->{file})
133            : $parser->parse_file($p->{file});
134    }
135
136
1
    require Carp;
137
1
    Carp::croak(
138        'Test::XPath->new requires the "xml", "file", or "doc" parameter'
139    );
140}
141
142# Add Test::XML::XPath compatibility?
143# sub like_xpath($$;$)   { __PACKAGE__->new( xml => shift )->ok(     @_ ) }
144# sub unlike_xpath($$;$) { __PACKAGE__->new( xml => shift )->not_ok( @_ ) }
145# sub is_xpath($$$;$)    { __PACKAGE__->new( xml => shift )->is(     @_ ) }
146
1471;