File Coverage

blib/lib/Test/XPath.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


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