21404401524

Committed 27 Jan 2026 04:10PM UTC coverage: 83.384% (-0.2%) from 83.616%

Build # 21404401524

Build Type

push

github

Committed by

Commit Message

Run Details

8421 of 10099 relevant lines covered (83.38%)

471.03 hits per line

Source File
Press 'n' to go to next uncovered line, 'b' for previous

67.5

/lib/HTFeed/XPathValidator.pm

package HTFeed::XPathValidator;

use warnings;
use strict;
use Carp;
use Log::Log4perl qw(get_logger);
use Exporter;

use base qw(HTFeed::SuccessOrFailure Exporter);

use XML::LibXML;

sub _xpathInit{
    my $self = shift;

    $$self{contexts} = {};
    $$self{fail} = 0;

    $self->_set_required_querylib();

    unless(Log::Log4perl->initialized()){
        croak 'Log4Perl not initialized, cannot report errors';
    }

    return 1;
}

# ** methods to impliment SuccessOrFailure **

# returns 0 if tests succeeded, non-0 if tests failed
sub failed{
    my $self = shift;
    return $$self{fail};
}

# set fail, log errors
# absract
sub set_error{
    croak("This is an abstract method");
}

#
# ** Methods for Running XPath Queries **
# 
# subclasses should stick to these methods to run XPath queries
# if they aren't sufficient, extend these if possible, rather than directly running queries
#
# qn = query name (to search for)
# base = query base, the context to search in
# cn = context name (to search for)
# 

# (base, qn)
# returns nodelist object
sub _findnodes{
    my $self = shift;
    my $base = shift;
    my $qn = shift;

    # get query out of qlib
    my $query = $self->{qlib}->query($base,$qn);

    my $base_node = $self->{contexts}->{$base}->{node};
    my $xpc = $self->{contexts}->{$base}->{xpc};

    if ($xpc && $query){
        my $nodelist = $xpc->findnodes($query,$base_node);
        return $nodelist;
    }

    $self->set_error("MissingField", $self->get_details($base,$qn));
    return;
}

# (cn)
# returns nodelist object
sub _findcontexts{
    my $self = shift;
    my $cn = shift;
    my $base = $self->{qlib}->context_parent($cn);

    # get query out of qlib
    my $query = $self->{qlib}->context($cn);

    my $base_node = $self->{contexts}->{$base}->{node};
    my $xpc = $self->{contexts}->{$base}->{xpc};

    if ($xpc && $query){
        my $nodelist = $xpc->findnodes($query,$base_node);
        return $nodelist;
    }

    return;
}

# (base, qn)
# returns only node found or
# sets error and returns undef
sub _findonenode{
    my $self = shift;
    my ($base,$qn) = @_ or croak("_findonenode: invalid args");

    # run query
    my $nodelist = $self->_findnodes(@_);

    # detect error in _findnodes, fail
    unless ($nodelist){
        $self->set_error("MissingField", $self->get_details($base,$qn));
        return;
    }

    # if hit count != 1 fail
    unless ($nodelist->size() == 1){
        my $error_msg = "";
        $error_msg .= $nodelist->size();
        $error_msg .= " hits for context query; exactly one expected";
        $self->set_error("BadField", $self->get_details($base,$qn), detail => $error_msg);
        return;
    }

    my $node = $nodelist->pop();
    return $node;
}

# (base, qn)
# returns scalar value (generally a string)
sub _findvalue{
    my $self = shift;
    my $base = shift;
    my $query = shift;

    # check/get query
    my $query_info = $self->{qlib}->query_info($base, $query) or croak ("_findvalue: invalid args");
    my $queryObj = $query_info->{query};
    my $context_name = $self->{qlib}->context_name($base);

    my $context_info = 
    # verbose logging for debug
    get_logger()->trace("  looking for value of $query_info->{desc} in $context_name (remediable=$query_info->{remediable})...");

    # get root xpc, context node
    my $context_node = $self->{contexts}->{$base}->{node};
    my $xpc = $self->{contexts}->{$base}->{xpc};

    return unless defined $xpc;
    # run query
    if($xpc && $queryObj) {
        return $xpc->findvalue($queryObj,$context_node);
    }
    $self->set_error("MissingField", $self->get_details($base,$query));
    return;
}

# (base, qn)
# returns scalar value of only node found or
# sets error and returns false
sub _findone{
    my $self = shift;
    unless($self->_findonenode(@_)){ 
        return;
    }
    else{
        return $self->_findvalue(@_);
    }
}

# (base, qn, text)
# "text" is the expected output of the query
# returns 1 or sets error and returns false
sub _validateone{
    my ($self,$base,$qn,$expected) = @_;

    my $actual = $self->_findone($base,$qn);
    if (defined($actual) and $expected eq $actual){
        return 1;
    }
    else{
        $self->set_error("BadValue", $self->get_details($base,$qn), actual => $actual, expected => $expected);
        return 0;
    }
}

# (base1, qn1, base2, qn2)
# requires that value of query 1 equal value of query2
sub _require_same {
    my $self = shift;
    my ($base1, $qn1, $base2, $qn2) = @_;
    my $found1 = $self->_findone($base1,$qn1);
    my $found2 = $self->_findone($base2,$qn2);
    if(defined($found1) and defined($found2) and $found1 eq $found2) {
        return 1;
    } elsif(defined($found1) and defined($found2)) {
        $self->set_error("NotEqualValues", $self->get_details($base1,$qn1,$base2,$qn2), 
            actual => {"${base1}_${qn1}" => $found1,
                "${base2}_${qn2}" => $found2});
    }
    return 0;
}

# (name => "name",node => $node,xpc => $xpc)
# xpc required unless we can get it from a parent
# node required if you don't want to always be searching from the root
#
# saves node, xpc as context of record for cn
sub _setcontext{
    my $self = shift;
    my %arg_hash = (
        name        => undef,
        node        => undef,
        xpc                => undef,
        @_,
    );
    my $cn = $arg_hash{name};
    my $node = $arg_hash{node};
    my $xpc = $arg_hash{xpc};

    # check parameters
    croak "_setcontext: context name undef" unless($cn);
    croak "_setcontext: can't set context to undef" unless(defined($node) or defined($xpc));

    if (! $xpc){
        # get root xpc from parent
        my $parent_name = $self->{qlib}->context_parent($cn);
        $xpc = $self->{contexts}->{$parent_name}->{xpc};
    }
    # set
    $self->{contexts}->{$cn} = {node => $node, xpc => $xpc};
    return 1;

}

# (cn)
# finds and saves a node as context node of record for cn
# or returns false and sets error
sub _openonecontext{
    my $self = shift;
    my ($cn) = @_ or croak("_openonecontext: invalid args");

    # run query
    my $nodelist = $self->_findcontexts(@_);

    # if hit count != 1 fail
    unless ($nodelist and $nodelist->size() == 1){
        my $error_msg = "";
        $error_msg .= $nodelist->size();
        $error_msg .= " hits for context query: $cn exactly one expected";
        $self->set_error("BadValue", detail => $error_msg, $self->get_details($cn));
        return;
    }
    my $node = $nodelist->pop();

    $self->_setcontext(name => $cn, node => $node);
    return 1;
}

# Validation closures

our @EXPORT_OK = qw(v_and v_exists v_same v_gt v_lt v_ge v_le v_eq v_between v_in);
our %EXPORT_TAGS = ( 'closures' => \@EXPORT_OK );

# Returns a sub that returns true if all of the parameter subs return true
sub v_and {
    my @subs = @_;

    return sub {
        my $self = shift;
        my $ok = 1;
        # don't short circuit
        foreach my $sub (@subs) {
            &$sub($self) or $ok = 0;
        }
        return $ok;
    }

}

sub v_exists {
    my @params = @_;
    return sub {
        my $self = shift;
        return $self->_findone(@params);
    }
}

sub v_same {
    my @params = @_;
    return sub {
        my $self = shift;
        return $self->_require_same(@params);
    }
}

sub _make_op_compare {
    my ($ctx,$query,$expected,$op) = @_;
    croak('Usage: _make_op_compare $ctx $query $expected $op') unless defined $ctx and defined $query and defined $expected and defined $op;
    return eval <<EOT;
sub {
    my \$self = shift;
    my \$actual = \$self->_findone(\$ctx, \$query);
    if('$op' ne 'eq' and \$actual =~ /^(\\d+)/) {
        \$actual = \$1;
    }
    if (\$actual $op \$expected) {
    return 1;
    } else {
        my \$report_op = '$op ';
        \$report_op = '' if \$report_op eq 'eq ';
    \$self->set_error("BadValue", \$self->get_details(\$ctx, \$query), actual => \$actual, expected => "\$report_op\$expected");
    return;
    }
}
EOT

}

# Numeric greater/less/greater-or-equal/less-or-equal
sub v_gt { return _make_op_compare(@_,">"); }
sub v_lt { return _make_op_compare(@_,"<"); }
sub v_ge { return _make_op_compare(@_,">="); }
sub v_le { return _make_op_compare(@_,"<="); }
# String equality
sub v_eq { return _make_op_compare(@_,"eq"); }

# Inclusive range
sub v_between {
    my ($ctx,$query,$lower,$upper) = @_;
    return v_and(v_ge($ctx,$query,$lower), v_le($ctx,$query,$upper));
}

# actual must be string-equal to one in @$allowed
sub v_in { 
    my ($ctx,$query,$allowed) = @_;

    return sub {
        my $self = shift;
        my $actual = $self->_findone($ctx,$query);
        foreach my $expected (@$allowed) {
            return 1 if ($actual eq $expected);
        }

        $self->set_error("BadValue", $self->get_details($ctx,$query), actual => $actual, expected => "one of (" . join(", ",@$allowed) . ")");
    }
}

# get additional information about fields that failed from the querylib module
# for logging errors
sub get_details {
    my $self = shift;
    my $ctx = shift;
    my $query = shift;
    my $ctx2 = shift;
    my $query2 = shift;

    my $desc = $self->{qlib}->context_name($ctx);
    my $remediable = 0;
    if(defined $query) {
        my $query_info = $self->{qlib}->query_info($ctx, $query) or croak ("_findvalue: invalid args");
        $desc = "in $desc - $query_info->{desc}";
        $remediable = $query_info->{remediable} if $query_info->{remediable};
    }

    if(defined $ctx2) {
        my $desc2 = $self->{qlib}->context_name($ctx2);
        if(defined $query2) {
            my $query_info = $self->{qlib}->query_info($ctx2, $query2) or croak ("_findvalue: invalid args");
            $desc2 = "in $desc2 - $query_info->{desc}";
            if( ($query_info->{remediable} or $remediable)
                and not ($query_info->{remediable} and $remediable)) {
                # if one or the other field is remediable, say 'possibly remediable'
                $remediable = 2;
            } 
        }
        $desc .= ", $desc2";
    }


    return (field => $desc, remediable => $remediable);

}


1;

__END__;

1	package HTFeed::XPathValidator;
2
3	use warnings;	23✔
4	use strict;	23✔
5	use Carp;	23✔
6	use Log::Log4perl qw(get_logger);	23✔
7	use Exporter;	23✔
8
9	use base qw(HTFeed::SuccessOrFailure Exporter);	23✔
10
11	use XML::LibXML;	23✔
12
13	sub _xpathInit{
14	my $self = shift;	15✔
15
16	$$self{contexts} = {};	15✔
17	$$self{fail} = 0;	15✔
18
19	$self->_set_required_querylib();	15✔
20
21	unless(Log::Log4perl->initialized()){	15✔
22	croak 'Log4Perl not initialized, cannot report errors';	×
23	}
24
25	return 1;	15✔
26	}
27
28	# methods to impliment SuccessOrFailure
29
30	# returns 0 if tests succeeded, non-0 if tests failed
31	sub failed{
32	my $self = shift;	40✔
33	return $$self{fail};	40✔
34	}
35
36	# set fail, log errors
37	# absract
38	sub set_error{
39	croak("This is an abstract method");	×
40	}
41
42	#
43	# Methods for Running XPath Queries
44	#
45	# subclasses should stick to these methods to run XPath queries
46	# if they aren't sufficient, extend these if possible, rather than directly running queries
47	#
48	# qn = query name (to search for)
49	# base = query base, the context to search in
50	# cn = context name (to search for)
51	#
52
53	# (base, qn)
54	# returns nodelist object
55	sub _findnodes{
56	my $self = shift;	416✔
57	my $base = shift;	416✔
58	my $qn = shift;	416✔
59
60	# get query out of qlib
61	my $query = $self->{qlib}->query($base,$qn);	416✔
62
63	my $base_node = $self->{contexts}->{$base}->{node};	416✔
64	my $xpc = $self->{contexts}->{$base}->{xpc};	416✔
65
66	if ($xpc && $query){	416✔
67	my $nodelist = $xpc->findnodes($query,$base_node);	416✔
68	return $nodelist;	416✔
69	}
70
71	$self->set_error("MissingField", $self->get_details($base,$qn));	×
72	return;	×
73	}
74
75	# (cn)
76	# returns nodelist object
77	sub _findcontexts{
78	my $self = shift;	75✔
79	my $cn = shift;	75✔
80	my $base = $self->{qlib}->context_parent($cn);	75✔
81
82	# get query out of qlib
83	my $query = $self->{qlib}->context($cn);	75✔
84
85	my $base_node = $self->{contexts}->{$base}->{node};	75✔
86	my $xpc = $self->{contexts}->{$base}->{xpc};	75✔
87
88	if ($xpc && $query){	75✔
89	my $nodelist = $xpc->findnodes($query,$base_node);	75✔
90	return $nodelist;	75✔
91	}
92
93	return;	×
94	}
95
96	# (base, qn)
97	# returns only node found or
98	# sets error and returns undef
99	sub _findonenode{
100	my $self = shift;	379✔
101	my ($base,$qn) = @_ or croak("_findonenode: invalid args");	379✔
102
103	# run query
104	my $nodelist = $self->_findnodes(@_);	379✔
105
106	# detect error in _findnodes, fail
107	unless ($nodelist){	379✔
108	$self->set_error("MissingField", $self->get_details($base,$qn));	×
109	return;	×
110	}
111
112	# if hit count != 1 fail
113	unless ($nodelist->size() == 1){	379✔
114	my $error_msg = "";	×
115	$error_msg .= $nodelist->size();	×
116	$error_msg .= " hits for context query; exactly one expected";	×
117	$self->set_error("BadField", $self->get_details($base,$qn), detail => $error_msg);	×
118	return;	×
119	}
120
121	my $node = $nodelist->pop();	379✔
122	return $node;	379✔
123	}
124
125	# (base, qn)
126	# returns scalar value (generally a string)
127	sub _findvalue{
128	my $self = shift;	409✔
129	my $base = shift;	409✔
130	my $query = shift;	409✔
131
132	# check/get query
133	my $query_info = $self->{qlib}->query_info($base, $query) or croak ("_findvalue: invalid args");	409✔
134	my $queryObj = $query_info->{query};	409✔
135	my $context_name = $self->{qlib}->context_name($base);	409✔
136
137	my $context_info =	409✔
138	# verbose logging for debug
139	get_logger()->trace(" looking for value of $query_info->{desc} in $context_name (remediable=$query_info->{remediable})...");
140
141	# get root xpc, context node
142	my $context_node = $self->{contexts}->{$base}->{node};	409✔
143	my $xpc = $self->{contexts}->{$base}->{xpc};	409✔
144
145	return unless defined $xpc;	409✔
146	# run query
147	if($xpc && $queryObj) {	409✔
148	return $xpc->findvalue($queryObj,$context_node);	409✔
149	}
150	$self->set_error("MissingField", $self->get_details($base,$query));	×
151	return;	×
152	}
153
154	# (base, qn)
155	# returns scalar value of only node found or
156	# sets error and returns false
157	sub _findone{
158	my $self = shift;	379✔
159	unless($self->_findonenode(@_)){	379✔
160	return;	×
161	}
162	else{
163	return $self->_findvalue(@_);	379✔
164	}
165	}
166
167	# (base, qn, text)
168	# "text" is the expected output of the query
169	# returns 1 or sets error and returns false
170	sub _validateone{
171	my ($self,$base,$qn,$expected) = @_;	×
172
173	my $actual = $self->_findone($base,$qn);	×
174	if (defined($actual) and $expected eq $actual){	×
175	return 1;	×
176	}
177	else{
178	$self->set_error("BadValue", $self->get_details($base,$qn), actual => $actual, expected => $expected);	×
179	return 0;	×
180	}
181	}
182
183	# (base1, qn1, base2, qn2)
184	# requires that value of query 1 equal value of query2
185	sub _require_same {
186	my $self = shift;	10✔
187	my ($base1, $qn1, $base2, $qn2) = @_;	10✔
188	my $found1 = $self->_findone($base1,$qn1);	10✔
189	my $found2 = $self->_findone($base2,$qn2);	10✔
190	if(defined($found1) and defined($found2) and $found1 eq $found2) {	10✔
191	return 1;	10✔
192	} elsif(defined($found1) and defined($found2)) {
193	$self->set_error("NotEqualValues", $self->get_details($base1,$qn1,$base2,$qn2),	×
194	actual => {"${base1}_${qn1}" => $found1,
195	"${base2}_${qn2}" => $found2});
196	}
197	return 0;	×
198	}
199
200	# (name => "name",node => $node,xpc => $xpc)
201	# xpc required unless we can get it from a parent
202	# node required if you don't want to always be searching from the root
203	#
204	# saves node, xpc as context of record for cn
205	sub _setcontext{
206	my $self = shift;	112✔
207	my %arg_hash = (	112✔
208	name => undef,
209	node => undef,
210	xpc => undef,
211	@_,
212	);
213	my $cn = $arg_hash{name};	112✔
214	my $node = $arg_hash{node};	112✔
215	my $xpc = $arg_hash{xpc};	112✔
216
217	# check parameters
218	croak "_setcontext: context name undef" unless($cn);	112✔
219	croak "_setcontext: can't set context to undef" unless(defined($node) or defined($xpc));	112✔
220
221	if (! $xpc){	112✔
222	# get root xpc from parent
223	my $parent_name = $self->{qlib}->context_parent($cn);	87✔
224	$xpc = $self->{contexts}->{$parent_name}->{xpc};	87✔
225	}
226	# set
227	$self->{contexts}->{$cn} = {node => $node, xpc => $xpc};	112✔
228	return 1;	112✔
229
230	}
231
232	# (cn)
233	# finds and saves a node as context node of record for cn
234	# or returns false and sets error
235	sub _openonecontext{
236	my $self = shift;	65✔
237	my ($cn) = @_ or croak("_openonecontext: invalid args");	65✔
238
239	# run query
240	my $nodelist = $self->_findcontexts(@_);	65✔
241
242	# if hit count != 1 fail
243	unless ($nodelist and $nodelist->size() == 1){	65✔
244	my $error_msg = "";	×
245	$error_msg .= $nodelist->size();	×
246	$error_msg .= " hits for context query: $cn exactly one expected";	×
247	$self->set_error("BadValue", detail => $error_msg, $self->get_details($cn));	×
248	return;	×
249	}
250	my $node = $nodelist->pop();	65✔
251
252	$self->_setcontext(name => $cn, node => $node);	65✔
253	return 1;	65✔
254	}
255
256	# Validation closures
257
258	our @EXPORT_OK = qw(v_and v_exists v_same v_gt v_lt v_ge v_le v_eq v_between v_in);
259	our %EXPORT_TAGS = ( 'closures' => \@EXPORT_OK );
260
261	# Returns a sub that returns true if all of the parameter subs return true
262	sub v_and {
263	my @subs = @_;	101✔
264
265	return sub {
266	my $self = shift;	39✔
267	my $ok = 1;	39✔
268	# don't short circuit
269	foreach my $sub (@subs) {	39✔
270	&$sub($self) or $ok = 0;	78✔
271	}
272	return $ok;	39✔
273	}
274
275	}	101✔
276
277	sub v_exists {
278	my @params = @_;	20✔
279	return sub {
280	my $self = shift;	×
281	return $self->_findone(@params);	×
282	}
283	}	20✔
284
285	sub v_same {
286	my @params = @_;	34✔
287	return sub {
288	my $self = shift;	10✔
289	return $self->_require_same(@params);	10✔
290	}
291	}	34✔
292
293	sub _make_op_compare {
294	my ($ctx,$query,$expected,$op) = @_;	309✔
295	croak('Usage: _make_op_compare $ctx $query $expected $op') unless defined $ctx and defined $query and defined $expected and defined $op;	309✔
296	return eval <<EOT;	309✔
297	sub {
298	my \$self = shift;
299	my \$actual = \$self->_findone(\$ctx, \$query);
300	if('$op' ne 'eq' and \$actual =~ /^(\\d+)/) {
301	\$actual = \$1;
302	}
303	if (\$actual $op \$expected) {
304	return 1;
305	} else {
306	my \$report_op = '$op ';
307	\$report_op = '' if \$report_op eq 'eq ';
308	\$self->set_error("BadValue", \$self->get_details(\$ctx, \$query), actual => \$actual, expected => "\$report_op\$expected");
309	return;
310	}
311	}
312	EOT
313
314	}
315
316	# Numeric greater/less/greater-or-equal/less-or-equal
317	sub v_gt { return _make_op_compare(@_,">"); }	10✔
318	sub v_lt { return _make_op_compare(@_,"<"); }	×
319	sub v_ge { return _make_op_compare(@_,">="); }	76✔
320	sub v_le { return _make_op_compare(@_,"<="); }	42✔
321	# String equality
322	sub v_eq { return _make_op_compare(@_,"eq"); }	181✔
323
324	# Inclusive range
325	sub v_between {
326	my ($ctx,$query,$lower,$upper) = @_;	42✔
327	return v_and(v_ge($ctx,$query,$lower), v_le($ctx,$query,$upper));	42✔
328	}
329
330	# actual must be string-equal to one in @$allowed
331	sub v_in {
332	my ($ctx,$query,$allowed) = @_;	8✔
333
334	return sub {
335	my $self = shift;	6✔
336	my $actual = $self->_findone($ctx,$query);	6✔
337	foreach my $expected (@$allowed) {	6✔
338	return 1 if ($actual eq $expected);	12✔
339	}
340
341	$self->set_error("BadValue", $self->get_details($ctx,$query), actual => $actual, expected => "one of (" . join(", ",@$allowed) . ")");	×
342	}
343	}	8✔
344
345	# get additional information about fields that failed from the querylib module
346	# for logging errors
347	sub get_details {
348	my $self = shift;	×
349	my $ctx = shift;	×
350	my $query = shift;	×
351	my $ctx2 = shift;	×
352	my $query2 = shift;	×
353
354	my $desc = $self->{qlib}->context_name($ctx);	×
355	my $remediable = 0;	×
356	if(defined $query) {	×
357	my $query_info = $self->{qlib}->query_info($ctx, $query) or croak ("_findvalue: invalid args");	×
358	$desc = "in $desc - $query_info->{desc}";	×
359	$remediable = $query_info->{remediable} if $query_info->{remediable};	×
360	}
361
362	if(defined $ctx2) {	×
363	my $desc2 = $self->{qlib}->context_name($ctx2);	×
364	if(defined $query2) {	×
365	my $query_info = $self->{qlib}->query_info($ctx2, $query2) or croak ("_findvalue: invalid args");	×
366	$desc2 = "in $desc2 - $query_info->{desc}";	×
367	if( ($query_info->{remediable} or $remediable)	×
368	and not ($query_info->{remediable} and $remediable)) {
369	# if one or the other field is remediable, say 'possibly remediable'
370	$remediable = 2;	×
371	}
372	}
373	$desc .= ", $desc2";	×
374	}
375
376
377	return (field => $desc, remediable => $remediable);	×
378
379	}
380
381
382	1;
383
384	__END__;

hathitrust / feed / 21404401524

Source File Press 'n' to go to next uncovered line, 'b' for previous

Source File
Press 'n' to go to next uncovered line, 'b' for previous