line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
# $rcs = ' $Id: Test.pm,v 2.293 2015-06-06 20:55:31 Martin Exp $ ' ; |
2
|
|
|
|
|
|
|
|
3
|
|
|
|
|
|
|
=head1 NAME |
4
|
|
|
|
|
|
|
|
5
|
|
|
|
|
|
|
WWW::Search::Test - utilities to aid in testing WWW::Search backends |
6
|
|
|
|
|
|
|
|
7
|
|
|
|
|
|
|
=head1 SYNOPSIS |
8
|
|
|
|
|
|
|
|
9
|
|
|
|
|
|
|
$oTest = new WWW::Search::Test('HotBot,Yahoo,Excite'); |
10
|
|
|
|
|
|
|
$oTest->test('HotBot', 'Kingpin', 'one', $sQuery, $TEST_RANGE, 1, 10); |
11
|
|
|
|
|
|
|
|
12
|
|
|
|
|
|
|
=head1 DESCRIPTION |
13
|
|
|
|
|
|
|
|
14
|
|
|
|
|
|
|
See file test.pl in the WWW-Search-HotBot distribution for a detailed |
15
|
|
|
|
|
|
|
"real-world" example. |
16
|
|
|
|
|
|
|
|
17
|
|
|
|
|
|
|
=head1 METHODS AND FUNCTIONS |
18
|
|
|
|
|
|
|
|
19
|
|
|
|
|
|
|
=cut |
20
|
|
|
|
|
|
|
|
21
|
|
|
|
|
|
|
package WWW::Search::Test; |
22
|
|
|
|
|
|
|
|
23
|
3
|
|
|
3
|
|
64499
|
use strict; |
|
3
|
|
|
|
|
7
|
|
|
3
|
|
|
|
|
74
|
|
24
|
3
|
|
|
3
|
|
12
|
use warnings; |
|
3
|
|
|
|
|
6
|
|
|
3
|
|
|
|
|
70
|
|
25
|
|
|
|
|
|
|
|
26
|
3
|
|
|
3
|
|
1041
|
use Bit::Vector; |
|
3
|
|
|
|
|
2430
|
|
|
3
|
|
|
|
|
153
|
|
27
|
3
|
|
|
3
|
|
21
|
use Carp; |
|
3
|
|
|
|
|
7
|
|
|
3
|
|
|
|
|
460
|
|
28
|
3
|
|
|
3
|
|
17
|
use Config; |
|
3
|
|
|
|
|
6
|
|
|
3
|
|
|
|
|
94
|
|
29
|
3
|
|
|
3
|
|
13
|
use Cwd; |
|
3
|
|
|
|
|
7
|
|
|
3
|
|
|
|
|
140
|
|
30
|
3
|
|
|
3
|
|
1396
|
use Data::Dumper; # for debugging only |
|
3
|
|
|
|
|
16119
|
|
|
3
|
|
|
|
|
180
|
|
31
|
3
|
|
|
3
|
|
989
|
use Date::Manip; |
|
3
|
|
|
|
|
336264
|
|
|
3
|
|
|
|
|
362
|
|
32
|
3
|
|
|
3
|
|
29
|
use base 'Exporter'; |
|
3
|
|
|
|
|
8
|
|
|
3
|
|
|
|
|
304
|
|
33
|
3
|
|
|
3
|
|
29
|
use File::Path; |
|
3
|
|
|
|
|
7
|
|
|
3
|
|
|
|
|
166
|
|
34
|
3
|
|
|
3
|
|
1547
|
use File::Slurp; |
|
3
|
|
|
|
|
31866
|
|
|
3
|
|
|
|
|
210
|
|
35
|
3
|
|
|
3
|
|
34
|
use File::Spec::Functions qw( :ALL ); |
|
3
|
|
|
|
|
9
|
|
|
3
|
|
|
|
|
517
|
|
36
|
3
|
|
|
3
|
|
19
|
use Test::More; |
|
3
|
|
|
|
|
6
|
|
|
3
|
|
|
|
|
41
|
|
37
|
3
|
|
|
3
|
|
1263
|
use WWW::Search; |
|
3
|
|
|
|
|
8
|
|
|
3
|
|
|
|
|
113
|
|
38
|
|
|
|
|
|
|
|
39
|
3
|
|
|
3
|
|
17
|
use vars qw( $MODE_DUMMY $MODE_INTERNAL $MODE_EXTERNAL $MODE_UPDATE ); |
|
3
|
|
|
|
|
7
|
|
|
3
|
|
|
|
|
152
|
|
40
|
3
|
|
|
3
|
|
14
|
use vars qw( $TEST_DUMMY $TEST_EXACTLY $TEST_BY_COUNTING $TEST_GREATER_THAN $TEST_RANGE ); |
|
3
|
|
|
|
|
6
|
|
|
3
|
|
|
|
|
145
|
|
41
|
3
|
|
|
3
|
|
16
|
use vars qw( $iTest $oSearch $sEngine ); |
|
3
|
|
|
|
|
7
|
|
|
3
|
|
|
|
|
122
|
|
42
|
|
|
|
|
|
|
# If set, will be used as a filename to save HTML when a test fails: |
43
|
3
|
|
|
3
|
|
22
|
use vars qw( $sSaveOnError ); |
|
3
|
|
|
|
|
7
|
|
|
3
|
|
|
|
|
100
|
|
44
|
|
|
|
|
|
|
|
45
|
3
|
|
|
3
|
|
20
|
use vars qw( @EXPORT ); |
|
3
|
|
|
|
|
5
|
|
|
3
|
|
|
|
|
186
|
|
46
|
|
|
|
|
|
|
@EXPORT = qw( eval_test test |
47
|
|
|
|
|
|
|
no_test not_working not_working_with_tests not_working_and_abandoned |
48
|
|
|
|
|
|
|
$MODE_DUMMY $MODE_INTERNAL $MODE_EXTERNAL $MODE_UPDATE |
49
|
|
|
|
|
|
|
$TEST_DUMMY $TEST_EXACTLY $TEST_BY_COUNTING $TEST_GREATER_THAN $TEST_RANGE |
50
|
|
|
|
|
|
|
new_engine run_test run_gui_test skip_test count_results |
51
|
|
|
|
|
|
|
tm_new_engine tm_run_test tm_run_test_no_approx |
52
|
|
|
|
|
|
|
); |
53
|
|
|
|
|
|
|
|
54
|
3
|
|
|
3
|
|
17
|
use vars qw( $VERSION $bogus_query $websearch ); |
|
3
|
|
|
|
|
4
|
|
|
3
|
|
|
|
|
345
|
|
55
|
|
|
|
|
|
|
|
56
|
|
|
|
|
|
|
$VERSION = do { my @r = (q$Revision: 2.293 $ =~ /\d+/g); sprintf "%d."."%03d" x $#r, @r }; |
57
|
|
|
|
|
|
|
$bogus_query = "Bogus" . $$ . "NoSuchWord" . time; |
58
|
|
|
|
|
|
|
|
59
|
|
|
|
|
|
|
($MODE_DUMMY, $MODE_INTERNAL, $MODE_EXTERNAL, $MODE_UPDATE) = qw(dummy internal external update); |
60
|
|
|
|
|
|
|
($TEST_DUMMY, $TEST_EXACTLY, $TEST_BY_COUNTING, $TEST_GREATER_THAN, $TEST_RANGE) = (1..10); |
61
|
|
|
|
|
|
|
|
62
|
3
|
|
|
3
|
|
18
|
use constant DEBUG => 0; |
|
3
|
|
|
|
|
6
|
|
|
3
|
|
|
|
|
8388
|
|
63
|
|
|
|
|
|
|
|
64
|
|
|
|
|
|
|
=head2 find_websearch |
65
|
|
|
|
|
|
|
|
66
|
|
|
|
|
|
|
Returns the full path of an executable WebSearch program, |
67
|
|
|
|
|
|
|
or undef if none can be found. |
68
|
|
|
|
|
|
|
|
69
|
|
|
|
|
|
|
=cut |
70
|
|
|
|
|
|
|
|
71
|
|
|
|
|
|
|
sub find_websearch |
72
|
|
|
|
|
|
|
{ |
73
|
2
|
100
|
|
2
|
1
|
1152
|
unless ($websearch) |
74
|
|
|
|
|
|
|
{ |
75
|
|
|
|
|
|
|
# Try to find a working WebSearch: |
76
|
1
|
|
|
|
|
3
|
my $sProg = 'WebSearch'; |
77
|
1
|
|
|
|
|
4
|
my @asTry = ( $sProg ); |
78
|
|
|
|
|
|
|
# Try local directory, in case . is not in the path: |
79
|
1
|
|
|
|
|
9
|
push @asTry, catfile(curdir, $sProg); |
80
|
1
|
|
|
|
|
6
|
push @asTry, catfile(qw( blib script ), $sProg); |
81
|
|
|
|
|
|
|
# See if WebSearch.BAT has been created/installed, and try it with |
82
|
|
|
|
|
|
|
# explicit 'perl' in front: |
83
|
1
|
|
|
|
|
3
|
push @asTry, map { ("$_.bat", "$Config{perlpath} $_") } @asTry; |
|
3
|
|
|
|
|
91
|
|
84
|
1
|
|
|
|
|
2
|
DEBUG && print STDERR Dumper(\@asTry); |
85
|
|
|
|
|
|
|
WEBSEARCH_TRY: |
86
|
1
|
|
|
|
|
4
|
foreach my $sTry (@asTry) |
87
|
|
|
|
|
|
|
{ |
88
|
1
|
|
|
|
|
3
|
my $sCmd = "$sTry --VERSION"; |
89
|
1
|
|
|
|
|
2
|
DEBUG && print STDERR " + W::S::T::find_websearch() cmd ==$sCmd==\n"; |
90
|
|
|
|
|
|
|
# Turn off warnings: |
91
|
1
|
|
|
|
|
5
|
local $^W = 0; |
92
|
|
|
|
|
|
|
# Wrap it in an eval so we don't die if it fails: |
93
|
1
|
|
|
|
|
3
|
my @as = split(/\s/, eval{`$sCmd`}); |
|
1
|
|
|
|
|
119220
|
|
94
|
1
|
|
50
|
|
|
23
|
$websearch = shift(@as) || undef; |
95
|
1
|
50
|
|
|
|
29
|
last WEBSEARCH_TRY if $websearch; |
96
|
|
|
|
|
|
|
} # foreach |
97
|
|
|
|
|
|
|
# Prevent undef warning: |
98
|
1
|
|
50
|
|
|
7
|
$websearch ||= ''; |
99
|
1
|
50
|
|
|
|
22
|
undef $websearch unless ($websearch =~ m/WebSearch/); |
100
|
|
|
|
|
|
|
# print STDERR "in WWW::Search::Test, websearch is $websearch\n"; |
101
|
|
|
|
|
|
|
} # unless |
102
|
2
|
|
|
|
|
14
|
return $websearch; |
103
|
|
|
|
|
|
|
} # find_websearch |
104
|
|
|
|
|
|
|
|
105
|
|
|
|
|
|
|
|
106
|
|
|
|
|
|
|
=head2 new |
107
|
|
|
|
|
|
|
|
108
|
|
|
|
|
|
|
Create a new WWW::Search::Test object. |
109
|
|
|
|
|
|
|
All arguments are strings, names of backends that this object will be able to test. |
110
|
|
|
|
|
|
|
If no arguments are given, will be able to test all backends. |
111
|
|
|
|
|
|
|
|
112
|
|
|
|
|
|
|
=cut |
113
|
|
|
|
|
|
|
|
114
|
|
|
|
|
|
|
sub new |
115
|
|
|
|
|
|
|
{ |
116
|
0
|
|
|
0
|
1
|
|
my $class = shift; |
117
|
0
|
|
|
|
|
|
my $sEngines = join(',', '', @_, ''); |
118
|
|
|
|
|
|
|
|
119
|
0
|
|
|
|
|
|
return bless { |
120
|
|
|
|
|
|
|
debug => 0, |
121
|
|
|
|
|
|
|
engines => $sEngines, |
122
|
|
|
|
|
|
|
error_count => 0, |
123
|
|
|
|
|
|
|
mode => $MODE_DUMMY, |
124
|
|
|
|
|
|
|
verbose => 0, |
125
|
|
|
|
|
|
|
# websearch => $websearch, # why do we need this? |
126
|
|
|
|
|
|
|
}, $class; |
127
|
|
|
|
|
|
|
} # new |
128
|
|
|
|
|
|
|
|
129
|
|
|
|
|
|
|
|
130
|
|
|
|
|
|
|
=head2 mode |
131
|
|
|
|
|
|
|
|
132
|
|
|
|
|
|
|
Set / get the test mode of this object. |
133
|
|
|
|
|
|
|
If an argument is given, sets the mode to that value. |
134
|
|
|
|
|
|
|
Returns the current (or newly set) value. |
135
|
|
|
|
|
|
|
|
136
|
|
|
|
|
|
|
There are three test modes available. They are: |
137
|
|
|
|
|
|
|
|
138
|
|
|
|
|
|
|
$MODE_INTERNAL: parse URLs out of saved pages (as a sanity check or regression test); |
139
|
|
|
|
|
|
|
$MODE_EXTERNAL: send the query to the search engine "live", parse the results, and compare them to the previously saved results; |
140
|
|
|
|
|
|
|
and |
141
|
|
|
|
|
|
|
$MODE_UPDATE: send the query to the search engine "live", parse the results, and save them for future testing. |
142
|
|
|
|
|
|
|
|
143
|
|
|
|
|
|
|
=cut |
144
|
|
|
|
|
|
|
|
145
|
|
|
|
|
|
|
sub mode |
146
|
|
|
|
|
|
|
{ |
147
|
0
|
|
|
0
|
1
|
|
my $self = shift; |
148
|
0
|
|
|
|
|
|
my $new_mode = shift; |
149
|
0
|
0
|
|
|
|
|
if ($new_mode) |
150
|
|
|
|
|
|
|
{ |
151
|
0
|
|
|
|
|
|
$self->{'mode'} = $new_mode; |
152
|
|
|
|
|
|
|
} |
153
|
0
|
|
|
|
|
|
return $self->{'mode'}; |
154
|
|
|
|
|
|
|
} # mode |
155
|
|
|
|
|
|
|
|
156
|
|
|
|
|
|
|
=head2 relevant_test |
157
|
|
|
|
|
|
|
|
158
|
|
|
|
|
|
|
Given the name of a backend, |
159
|
|
|
|
|
|
|
returns true if this Test object is able to test that backend. |
160
|
|
|
|
|
|
|
|
161
|
|
|
|
|
|
|
=cut |
162
|
|
|
|
|
|
|
|
163
|
|
|
|
|
|
|
sub relevant_test |
164
|
|
|
|
|
|
|
{ |
165
|
0
|
|
|
0
|
1
|
|
my $self = shift; |
166
|
0
|
0
|
|
|
|
|
return 1 if ($self->{engines} eq ',,'); |
167
|
0
|
|
|
|
|
|
my $e = ','.shift().','; |
168
|
|
|
|
|
|
|
# print STDERR " + relevant_test($e|", $self->{engines}, ")\n"; |
169
|
0
|
|
|
|
|
|
return ($self->{engines} =~ m/$e/); |
170
|
|
|
|
|
|
|
} # relevant_test |
171
|
|
|
|
|
|
|
|
172
|
|
|
|
|
|
|
|
173
|
|
|
|
|
|
|
=head2 eval_test |
174
|
|
|
|
|
|
|
|
175
|
|
|
|
|
|
|
Given the name of a backend, |
176
|
|
|
|
|
|
|
grabs the $TEST_CASES variable from that backend and evaluates it. |
177
|
|
|
|
|
|
|
|
178
|
|
|
|
|
|
|
=cut |
179
|
|
|
|
|
|
|
|
180
|
|
|
|
|
|
|
sub eval_test |
181
|
|
|
|
|
|
|
{ |
182
|
0
|
|
|
0
|
1
|
|
my $self = shift; |
183
|
0
|
|
|
|
|
|
my $sSE = shift; |
184
|
0
|
0
|
|
|
|
|
return unless $self->relevant_test($sSE); |
185
|
0
|
|
|
|
|
|
my $o = new WWW::Search($sSE); |
186
|
0
|
|
|
|
|
|
my $iVersion = $o->version; |
187
|
0
|
|
|
|
|
|
my $code = $o->test_cases; |
188
|
0
|
|
0
|
|
|
|
$code ||= ''; |
189
|
0
|
0
|
|
|
|
|
unless ($code ne '') |
190
|
|
|
|
|
|
|
{ |
191
|
0
|
|
|
|
|
|
print " $sSE version $iVersion contains no TEST_CASES\n"; |
192
|
0
|
|
|
|
|
|
$self->{error_count}++; |
193
|
|
|
|
|
|
|
} |
194
|
|
|
|
|
|
|
# print STDERR " BEFORE SUBST: $code\n"; |
195
|
0
|
|
|
|
|
|
$code =~ s!&test\(!\$self->test\(!g; |
196
|
0
|
|
|
|
|
|
$code =~ s/&no_test\(/\$self->no_test\(/g; |
197
|
0
|
|
|
|
|
|
$code =~ s/¬_working\(/\$self->not_working\(/g; |
198
|
0
|
|
|
|
|
|
$code =~ s/¬_working_and_abandoned\(/\$self->not_working_and_abandoned\(/g; |
199
|
0
|
|
|
|
|
|
$code =~ s/¬_working_with_tests\(/\$self->not_working_with_tests\(/g; |
200
|
|
|
|
|
|
|
# print STDERR " AFTER SUBST: $code\n"; |
201
|
0
|
|
|
|
|
|
print "\n"; # put a little space between each engine's results |
202
|
0
|
|
|
|
|
|
eval $code; |
203
|
0
|
0
|
|
|
|
|
warn $@ if $@; |
204
|
|
|
|
|
|
|
} # eval_test |
205
|
|
|
|
|
|
|
|
206
|
|
|
|
|
|
|
|
207
|
|
|
|
|
|
|
=head2 test |
208
|
|
|
|
|
|
|
|
209
|
|
|
|
|
|
|
Run test(s) for a backend. |
210
|
|
|
|
|
|
|
Arguments are, in order: |
211
|
|
|
|
|
|
|
name of a backend to test (string, required); |
212
|
|
|
|
|
|
|
name of backend maintainer (string, if undef $backend::MAINTAINER will be used); |
213
|
|
|
|
|
|
|
filename for results storage/comparison (string, required); |
214
|
|
|
|
|
|
|
query to be sent to backend (string, required); |
215
|
|
|
|
|
|
|
test method (required, one of the following). |
216
|
|
|
|
|
|
|
|
217
|
|
|
|
|
|
|
Several test methods are possible: |
218
|
|
|
|
|
|
|
|
219
|
|
|
|
|
|
|
$TEST_EXACTLY: list of URLs must match exactly (line for line, in order); |
220
|
|
|
|
|
|
|
$TEST_BY_COUNTING: test passes if number of resulting URLs is equal; |
221
|
|
|
|
|
|
|
$TEST_GREATER_THAN: test passes if we get more than N result URLs; |
222
|
|
|
|
|
|
|
and |
223
|
|
|
|
|
|
|
$TEST_RANGE: like $TEST_GREATER_THAN but constrained on both ends. |
224
|
|
|
|
|
|
|
|
225
|
|
|
|
|
|
|
=cut |
226
|
|
|
|
|
|
|
|
227
|
|
|
|
|
|
|
sub test |
228
|
|
|
|
|
|
|
{ |
229
|
0
|
|
|
0
|
1
|
|
my $self = shift; |
230
|
0
|
|
|
|
|
|
my $sSE = shift; |
231
|
0
|
|
|
|
|
|
my $sM = shift; |
232
|
0
|
|
|
|
|
|
my $file = shift; |
233
|
0
|
|
|
|
|
|
my $query = shift; |
234
|
0
|
|
|
|
|
|
my $test_method = shift; |
235
|
0
|
0
|
|
|
|
|
print STDERR " + test($sSE,$sM,$file,$query,$test_method)\n" if $self->{debug}; |
236
|
0
|
|
|
|
|
|
my ($low_end, $high_end) = @_; |
237
|
0
|
|
0
|
|
|
|
$low_end ||= 0; |
238
|
0
|
|
0
|
|
|
|
$high_end ||= 0; |
239
|
0
|
|
|
|
|
|
my $sExpected = $low_end; |
240
|
0
|
0
|
|
|
|
|
if ($test_method == $TEST_GREATER_THAN) |
241
|
|
|
|
|
|
|
{ |
242
|
0
|
|
|
|
|
|
$low_end++; |
243
|
0
|
|
|
|
|
|
$sExpected = "$low_end.."; |
244
|
|
|
|
|
|
|
} |
245
|
0
|
0
|
|
|
|
|
if (0 < $high_end) |
246
|
|
|
|
|
|
|
{ |
247
|
0
|
|
|
|
|
|
$sExpected = "$low_end..$high_end"; |
248
|
|
|
|
|
|
|
} |
249
|
0
|
0
|
|
|
|
|
return if (!$self->relevant_test($sSE)); |
250
|
0
|
|
|
|
|
|
print " trial $file (", $self->{'mode'}, ")\n"; |
251
|
0
|
0
|
0
|
|
|
|
if (($self->{'mode'} eq $MODE_INTERNAL) && ($query =~ m/$bogus_query/)) |
252
|
|
|
|
|
|
|
{ |
253
|
0
|
|
|
|
|
|
print " skipping test on this platform.\n"; |
254
|
0
|
|
|
|
|
|
return; |
255
|
|
|
|
|
|
|
} # if |
256
|
|
|
|
|
|
|
|
257
|
0
|
|
|
|
|
|
my $pwd = curdir(); |
258
|
0
|
|
|
|
|
|
my @asSE = split(/::/, $sSE); |
259
|
0
|
|
|
|
|
|
my $path = catdir($pwd, 'Test-Pages', @asSE); |
260
|
0
|
|
|
|
|
|
mkpath $path; |
261
|
0
|
0
|
|
|
|
|
if ($self->{'mode'} eq $MODE_UPDATE) |
262
|
|
|
|
|
|
|
{ |
263
|
|
|
|
|
|
|
# Delete all existing test result files for this Engine: |
264
|
0
|
|
|
|
|
|
opendir DIR, $path; |
265
|
0
|
|
|
|
|
|
foreach my $afile (readdir DIR) |
266
|
|
|
|
|
|
|
{ |
267
|
0
|
0
|
|
|
|
|
unlink catfile($path, $afile) if $afile =~ m/^$file/; |
268
|
|
|
|
|
|
|
} # foreach |
269
|
0
|
|
|
|
|
|
closedir DIR; |
270
|
|
|
|
|
|
|
} # if MODE_UPDATE |
271
|
|
|
|
|
|
|
# Look at the filename argument we got: |
272
|
0
|
|
|
|
|
|
my ($v,$d,$f) = splitpath($file); |
273
|
|
|
|
|
|
|
# If it contains no path element (file name only): |
274
|
0
|
0
|
|
|
|
|
if ($d eq '') |
275
|
|
|
|
|
|
|
{ |
276
|
|
|
|
|
|
|
# Prepend path onto file: |
277
|
0
|
|
|
|
|
|
$file = catfile($path, $file); |
278
|
|
|
|
|
|
|
} # if |
279
|
0
|
|
|
|
|
|
my $o = new WWW::Search($sSE); |
280
|
0
|
|
|
|
|
|
my $version = $o->version; |
281
|
0
|
|
|
|
|
|
print " ($sSE $version, $sM)\n"; |
282
|
0
|
0
|
|
|
|
|
print STDERR " expect to find results in $file\n" if $self->{debug}; |
283
|
0
|
|
|
|
|
|
my %src = ( |
284
|
|
|
|
|
|
|
$MODE_INTERNAL => "--option search_from_file=$file", |
285
|
|
|
|
|
|
|
$MODE_EXTERNAL => '', |
286
|
|
|
|
|
|
|
$MODE_UPDATE => "--option search_to_file=$file", |
287
|
|
|
|
|
|
|
); |
288
|
|
|
|
|
|
|
# --max 209 added by Martin Thurn 1999-09-27. We never want to |
289
|
|
|
|
|
|
|
# fetch more than three pages, if we can at all help it (or do we?) |
290
|
0
|
|
|
|
|
|
my $websearch = &find_websearch; |
291
|
0
|
|
0
|
|
|
|
$websearch ||= catfile($pwd, 'blib', 'script', 'WebSearch'); |
292
|
0
|
|
|
|
|
|
my $cmd = $Config{'perlpath'} . " -MExtUtils::testlib $websearch "; |
293
|
0
|
0
|
|
|
|
|
$cmd .= $self->{debug} ? '--debug '.$self->{debug} : ''; |
294
|
0
|
|
|
|
|
|
$cmd .= " --max 209 --engine $sSE ". $src{$self->{'mode'}} ." -- $query"; |
295
|
0
|
0
|
0
|
|
|
|
print " $cmd\n" if ($self->{verbose} || $self->{debug}); |
296
|
0
|
0
|
|
|
|
|
open(TRIALSTREAM, "$cmd|") || die "$0: cannot run test ($!)\n"; |
297
|
0
|
0
|
|
|
|
|
open(TRIALFILE, ">$file.trial") || die "$0: cannot open $file.trial for writing ($!)\n"; |
298
|
0
|
0
|
0
|
|
|
|
open(OUTFILE, ">$file.out") || die "$0: cannot open $file.out for writing ($!)\n" if ($self->{'mode'} eq $MODE_UPDATE); |
299
|
0
|
|
|
|
|
|
my $iActual = 0; |
300
|
0
|
|
|
|
|
|
while () |
301
|
|
|
|
|
|
|
{ |
302
|
0
|
|
|
|
|
|
print TRIALFILE $_; |
303
|
0
|
|
|
|
|
|
$iActual++; |
304
|
0
|
0
|
|
|
|
|
print OUTFILE $_ if ($self->{'mode'} eq $MODE_UPDATE); |
305
|
|
|
|
|
|
|
} |
306
|
0
|
|
|
|
|
|
close TRIALSTREAM; |
307
|
0
|
|
|
|
|
|
close TRIALFILE; |
308
|
0
|
0
|
|
|
|
|
if ($self->{'mode'} eq $MODE_UPDATE) |
309
|
|
|
|
|
|
|
{ |
310
|
0
|
|
|
|
|
|
close OUTFILE; |
311
|
0
|
0
|
|
|
|
|
if (open TS, ">$file.README") |
312
|
|
|
|
|
|
|
{ |
313
|
0
|
|
|
|
|
|
print TS "This set of test-result pages was created on ", scalar(localtime(time)), "\n"; |
314
|
0
|
|
|
|
|
|
close TS; |
315
|
|
|
|
|
|
|
} # if |
316
|
0
|
|
|
|
|
|
my $iPageCount = &wc_l($file); |
317
|
0
|
|
|
|
|
|
my $iURLCount = &wc_l("$file.out"); |
318
|
0
|
|
|
|
|
|
print " $query --> $iURLCount urls (should be $sExpected) on $iPageCount pages\n"; |
319
|
0
|
|
|
|
|
|
return; |
320
|
|
|
|
|
|
|
} # if |
321
|
|
|
|
|
|
|
|
322
|
0
|
0
|
|
|
|
|
if (-f "$file.out") |
323
|
|
|
|
|
|
|
{ |
324
|
0
|
|
|
|
|
|
my ($e, $sMsg) = (0, ''); |
325
|
0
|
0
|
|
|
|
|
if ($test_method == $TEST_GREATER_THAN) |
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
326
|
|
|
|
|
|
|
{ |
327
|
0
|
0
|
|
|
|
|
if ($iActual <= $low_end) |
328
|
|
|
|
|
|
|
{ |
329
|
0
|
|
|
|
|
|
$sMsg .= "expected more than $low_end, but got $iActual; "; |
330
|
0
|
|
|
|
|
|
$e = 1; |
331
|
|
|
|
|
|
|
} |
332
|
|
|
|
|
|
|
} # TEST_GREATER_THAN |
333
|
|
|
|
|
|
|
elsif ($test_method == $TEST_RANGE) |
334
|
|
|
|
|
|
|
{ |
335
|
0
|
0
|
|
|
|
|
$sMsg .= "INTERNAL ERROR, low_end has no value; " unless defined($low_end); |
336
|
0
|
0
|
|
|
|
|
$sMsg .= "INTERNAL ERROR, high_end has no value; " unless defined($high_end); |
337
|
0
|
0
|
|
|
|
|
$sMsg .= "INTERNAL ERROR, high_end is zero; " unless 0 < $high_end; |
338
|
0
|
0
|
|
|
|
|
if ($iActual < $low_end) |
339
|
|
|
|
|
|
|
{ |
340
|
0
|
|
|
|
|
|
$sMsg .= "expected $low_end..$high_end, but got $iActual; "; |
341
|
0
|
|
|
|
|
|
$e = 1; |
342
|
|
|
|
|
|
|
} |
343
|
0
|
0
|
|
|
|
|
if ($high_end < $iActual) |
344
|
|
|
|
|
|
|
{ |
345
|
0
|
|
|
|
|
|
$sMsg .= "expected $low_end..$high_end, but got $iActual; "; |
346
|
0
|
|
|
|
|
|
$e = 1; |
347
|
|
|
|
|
|
|
} |
348
|
|
|
|
|
|
|
} # TEST_RANGE |
349
|
|
|
|
|
|
|
elsif ($test_method == $TEST_EXACTLY) |
350
|
|
|
|
|
|
|
{ |
351
|
0
|
0
|
|
|
|
|
$e = &diff("$file.out", "$file.trial") ? 1 : 0; |
352
|
|
|
|
|
|
|
} # TEST_EXACTLY |
353
|
|
|
|
|
|
|
elsif ($test_method == $TEST_BY_COUNTING) |
354
|
|
|
|
|
|
|
{ |
355
|
0
|
|
|
|
|
|
my $iExpected = shift; |
356
|
0
|
|
|
|
|
|
my $iActual = &wc_l("$file.trial"); |
357
|
0
|
0
|
|
|
|
|
if ($iActual != $iExpected) |
358
|
|
|
|
|
|
|
{ |
359
|
0
|
|
|
|
|
|
$sMsg .= "expected $iExpected, but got $iActual; "; |
360
|
0
|
|
|
|
|
|
$e = 1; |
361
|
|
|
|
|
|
|
} |
362
|
|
|
|
|
|
|
} |
363
|
|
|
|
|
|
|
else |
364
|
|
|
|
|
|
|
{ |
365
|
0
|
|
|
|
|
|
$e = 0; |
366
|
0
|
|
|
|
|
|
$sMsg = "INTERNAL ERROR, unknown test method $test_method; "; |
367
|
|
|
|
|
|
|
} |
368
|
|
|
|
|
|
|
|
369
|
0
|
0
|
|
|
|
|
if ($e == 0) |
|
|
0
|
|
|
|
|
|
370
|
|
|
|
|
|
|
{ |
371
|
0
|
|
|
|
|
|
print " ok.\n"; |
372
|
0
|
|
|
|
|
|
unlink("$file.trial"); # clean up |
373
|
|
|
|
|
|
|
} |
374
|
|
|
|
|
|
|
elsif ($e == 1) |
375
|
|
|
|
|
|
|
{ |
376
|
0
|
|
|
|
|
|
print "DIFFERENCE DETECTED: $query --> $sMsg\n"; |
377
|
0
|
|
|
|
|
|
$self->{error_count}++; |
378
|
|
|
|
|
|
|
} |
379
|
|
|
|
|
|
|
else |
380
|
|
|
|
|
|
|
{ |
381
|
0
|
|
|
|
|
|
print "INTERNAL ERROR $query --> e is $e.\n"; |
382
|
0
|
|
|
|
|
|
$self->{error_count}++; |
383
|
|
|
|
|
|
|
} |
384
|
|
|
|
|
|
|
} |
385
|
|
|
|
|
|
|
else |
386
|
|
|
|
|
|
|
{ |
387
|
0
|
|
|
|
|
|
print "NO SAVED OUTPUT, can not evaluate test results.\n"; |
388
|
0
|
|
|
|
|
|
$self->{error_count}++; |
389
|
|
|
|
|
|
|
} |
390
|
|
|
|
|
|
|
} # test |
391
|
|
|
|
|
|
|
|
392
|
|
|
|
|
|
|
=head2 no_test |
393
|
|
|
|
|
|
|
|
394
|
|
|
|
|
|
|
Prints a message stating that this backend does not have a test suite. |
395
|
|
|
|
|
|
|
Takes two arguments, the backend name and the name of the maintainer. |
396
|
|
|
|
|
|
|
|
397
|
|
|
|
|
|
|
=cut |
398
|
|
|
|
|
|
|
|
399
|
|
|
|
|
|
|
sub no_test |
400
|
|
|
|
|
|
|
{ |
401
|
0
|
|
|
0
|
1
|
|
my $self = shift; |
402
|
0
|
|
|
|
|
|
my ($engine, $maint) = @_; |
403
|
0
|
0
|
|
|
|
|
return unless ($self->relevant_test($engine)); |
404
|
0
|
|
|
|
|
|
print <<"NONE"; |
405
|
|
|
|
|
|
|
trial none ($engine) |
406
|
|
|
|
|
|
|
This search engine does not have any tests, |
407
|
|
|
|
|
|
|
but report problems with it to $maint. |
408
|
|
|
|
|
|
|
NONE |
409
|
|
|
|
|
|
|
} # no_test |
410
|
|
|
|
|
|
|
|
411
|
|
|
|
|
|
|
|
412
|
|
|
|
|
|
|
=head2 not_working |
413
|
|
|
|
|
|
|
|
414
|
|
|
|
|
|
|
Prints a message stating that this backend is known to be broken. |
415
|
|
|
|
|
|
|
Takes two arguments, the backend name and the name of the maintainer. |
416
|
|
|
|
|
|
|
|
417
|
|
|
|
|
|
|
=cut |
418
|
|
|
|
|
|
|
|
419
|
|
|
|
|
|
|
sub not_working |
420
|
|
|
|
|
|
|
{ |
421
|
0
|
|
|
0
|
1
|
|
my $self = shift; |
422
|
0
|
|
|
|
|
|
my ($engine, $maint) = @_; |
423
|
0
|
0
|
|
|
|
|
return unless ($self->relevant_test($engine)); |
424
|
0
|
|
|
|
|
|
print <<"BROKEN"; |
425
|
|
|
|
|
|
|
trial none ($engine) |
426
|
|
|
|
|
|
|
This search engine is known to be non-functional. |
427
|
|
|
|
|
|
|
You are encouraged to investigate the problem and email its maintainer, |
428
|
|
|
|
|
|
|
$maint. |
429
|
|
|
|
|
|
|
BROKEN |
430
|
|
|
|
|
|
|
} # not_working |
431
|
|
|
|
|
|
|
|
432
|
|
|
|
|
|
|
|
433
|
|
|
|
|
|
|
=head2 not_working_with_tests |
434
|
|
|
|
|
|
|
|
435
|
|
|
|
|
|
|
Prints a message stating that this backend is known to be broken |
436
|
|
|
|
|
|
|
even though it has a test suite. |
437
|
|
|
|
|
|
|
Takes two arguments, the backend name and the name of the maintainer. |
438
|
|
|
|
|
|
|
|
439
|
|
|
|
|
|
|
=cut |
440
|
|
|
|
|
|
|
|
441
|
|
|
|
|
|
|
sub not_working_with_tests |
442
|
|
|
|
|
|
|
{ |
443
|
0
|
|
|
0
|
1
|
|
my $self = shift; |
444
|
0
|
|
|
|
|
|
my ($engine, $maint) = @_; |
445
|
0
|
0
|
|
|
|
|
return if (!$self->relevant_test($engine)); |
446
|
0
|
|
|
|
|
|
print <<"KNOWNFAILURE"; |
447
|
|
|
|
|
|
|
trial none ($engine) |
448
|
|
|
|
|
|
|
Test cases for this search engine are known to fail. |
449
|
|
|
|
|
|
|
You are encouraged to investigate the problem and email its maintainer, |
450
|
|
|
|
|
|
|
$maint. |
451
|
|
|
|
|
|
|
KNOWNFAILURE |
452
|
|
|
|
|
|
|
} # not_working_with_tests |
453
|
|
|
|
|
|
|
|
454
|
|
|
|
|
|
|
|
455
|
|
|
|
|
|
|
=head2 not_working_and_abandoned |
456
|
|
|
|
|
|
|
|
457
|
|
|
|
|
|
|
Prints a message stating that this backend is known to be broken |
458
|
|
|
|
|
|
|
and is not being actively maintained. |
459
|
|
|
|
|
|
|
Takes two arguments, the backend name and the name of the maintainer. |
460
|
|
|
|
|
|
|
|
461
|
|
|
|
|
|
|
=cut |
462
|
|
|
|
|
|
|
|
463
|
|
|
|
|
|
|
sub not_working_and_abandoned |
464
|
|
|
|
|
|
|
{ |
465
|
0
|
|
|
0
|
1
|
|
my $self = shift; |
466
|
0
|
|
|
|
|
|
my ($engine, $maint) = @_; |
467
|
0
|
0
|
|
|
|
|
return if (!$self->relevant_test($engine)); |
468
|
0
|
|
|
|
|
|
print <<"ADOPT"; |
469
|
|
|
|
|
|
|
trial none ($engine) |
470
|
|
|
|
|
|
|
This search engine is known to be non-functional. |
471
|
|
|
|
|
|
|
You are encouraged to adopt it from its last known maintainer, |
472
|
|
|
|
|
|
|
$maint. |
473
|
|
|
|
|
|
|
ADOPT |
474
|
|
|
|
|
|
|
} # not_working_and_abandoned |
475
|
|
|
|
|
|
|
|
476
|
|
|
|
|
|
|
|
477
|
|
|
|
|
|
|
=head2 reset_error_count |
478
|
|
|
|
|
|
|
|
479
|
|
|
|
|
|
|
Reset the counter of errors to zero. |
480
|
|
|
|
|
|
|
You probably want to call this before each call to test() or eval_test(). |
481
|
|
|
|
|
|
|
|
482
|
|
|
|
|
|
|
=cut |
483
|
|
|
|
|
|
|
|
484
|
|
|
|
|
|
|
sub reset_error_count |
485
|
|
|
|
|
|
|
{ |
486
|
0
|
|
|
0
|
1
|
|
my $self = shift; |
487
|
0
|
|
|
|
|
|
$self->{error_count} = 0; |
488
|
|
|
|
|
|
|
} # reset_error_count |
489
|
|
|
|
|
|
|
|
490
|
|
|
|
|
|
|
|
491
|
|
|
|
|
|
|
=head2 wc_l (private, not a method) |
492
|
|
|
|
|
|
|
|
493
|
|
|
|
|
|
|
Given a filename, count the number of lines of text contained |
494
|
|
|
|
|
|
|
within the file. |
495
|
|
|
|
|
|
|
(I.e. simulate running UNIX command C on a file) |
496
|
|
|
|
|
|
|
|
497
|
|
|
|
|
|
|
=cut |
498
|
|
|
|
|
|
|
|
499
|
|
|
|
|
|
|
sub wc_l |
500
|
|
|
|
|
|
|
{ |
501
|
|
|
|
|
|
|
# SPECIAL CASE: If first line is "Nothing found.", report 0 lines. |
502
|
0
|
0
|
|
0
|
1
|
|
open WC, shift or return 0; |
503
|
0
|
|
|
|
|
|
$/ = "\n"; |
504
|
0
|
|
|
|
|
|
my $i = 0; |
505
|
0
|
|
|
|
|
|
while () |
506
|
|
|
|
|
|
|
{ |
507
|
0
|
0
|
|
|
|
|
last if /Nothing found./; |
508
|
0
|
|
|
|
|
|
$i++; |
509
|
|
|
|
|
|
|
} # while |
510
|
0
|
|
|
|
|
|
return $i; |
511
|
|
|
|
|
|
|
} # wc_l |
512
|
|
|
|
|
|
|
|
513
|
|
|
|
|
|
|
|
514
|
|
|
|
|
|
|
=head2 diff (private, not a method) |
515
|
|
|
|
|
|
|
|
516
|
|
|
|
|
|
|
Given two files, returns TRUE if contents are line-by-line |
517
|
|
|
|
|
|
|
different, or FALSE if contents are line-by-line same. |
518
|
|
|
|
|
|
|
(I.e. like the UNIX command diff, but just reports true or false) |
519
|
|
|
|
|
|
|
|
520
|
|
|
|
|
|
|
=cut |
521
|
|
|
|
|
|
|
|
522
|
|
|
|
|
|
|
sub diff |
523
|
|
|
|
|
|
|
{ |
524
|
0
|
0
|
|
0
|
1
|
|
open DIFF1, shift or return 91; |
525
|
0
|
0
|
|
|
|
|
open DIFF2, shift or return 92; |
526
|
0
|
|
|
|
|
|
my $iResult = 0; |
527
|
0
|
|
|
|
|
|
$/ = "\n"; |
528
|
0
|
|
0
|
|
|
|
while ((defined(my $s1 = )) && |
529
|
|
|
|
|
|
|
($iResult ne 1)) |
530
|
|
|
|
|
|
|
{ |
531
|
0
|
|
|
|
|
|
my $s2 = ; |
532
|
0
|
0
|
|
|
|
|
unless (defined($s2)) |
533
|
|
|
|
|
|
|
{ |
534
|
0
|
|
|
|
|
|
$iResult = 1; |
535
|
0
|
|
|
|
|
|
last; |
536
|
|
|
|
|
|
|
} |
537
|
0
|
|
|
|
|
|
chomp $s1; |
538
|
0
|
|
|
|
|
|
chomp $s2; |
539
|
0
|
0
|
|
|
|
|
if ($s1 ne $s2) |
540
|
|
|
|
|
|
|
{ |
541
|
0
|
|
|
|
|
|
$iResult = 1; |
542
|
0
|
|
|
|
|
|
last; |
543
|
|
|
|
|
|
|
} |
544
|
|
|
|
|
|
|
} # while |
545
|
0
|
|
|
|
|
|
close DIFF1; |
546
|
0
|
|
|
|
|
|
close DIFF2; |
547
|
0
|
|
|
|
|
|
return $iResult; |
548
|
|
|
|
|
|
|
} # diff |
549
|
|
|
|
|
|
|
|
550
|
|
|
|
|
|
|
|
551
|
|
|
|
|
|
|
=head2 Shortcuts for running backend tests |
552
|
|
|
|
|
|
|
|
553
|
|
|
|
|
|
|
WWW::Search::Test keeps its own count of test numbers, |
554
|
|
|
|
|
|
|
so if you want to mix-and-match these functions with your own tests, |
555
|
|
|
|
|
|
|
use the $WWW::Search::Test::iTest counter. |
556
|
|
|
|
|
|
|
|
557
|
|
|
|
|
|
|
=head2 new_engine |
558
|
|
|
|
|
|
|
|
559
|
|
|
|
|
|
|
One argument: the name of a backend suitable to be passed to WWW::Search::new(). |
560
|
|
|
|
|
|
|
Prints 'ok' or 'not ok' and the test number. |
561
|
|
|
|
|
|
|
Creates a WWW::Search object internally, |
562
|
|
|
|
|
|
|
to be used for all subsequent calls to run_test and run_gui_test (see below). |
563
|
|
|
|
|
|
|
|
564
|
|
|
|
|
|
|
=cut |
565
|
|
|
|
|
|
|
|
566
|
|
|
|
|
|
|
sub new_engine |
567
|
|
|
|
|
|
|
{ |
568
|
0
|
|
|
0
|
1
|
|
$iTest++; |
569
|
0
|
|
|
|
|
|
$sEngine = shift; |
570
|
0
|
|
|
|
|
|
$oSearch = new WWW::Search($sEngine); |
571
|
0
|
0
|
|
|
|
|
print ref($oSearch) ? '' : 'not '; |
572
|
0
|
|
|
|
|
|
print "ok $iTest\n"; |
573
|
0
|
|
|
|
|
|
$oSearch->env_proxy('yes'); |
574
|
|
|
|
|
|
|
} # new_engine |
575
|
|
|
|
|
|
|
|
576
|
|
|
|
|
|
|
=head2 tm_new_engine |
577
|
|
|
|
|
|
|
|
578
|
|
|
|
|
|
|
Same as new_engine(), but uses Test::More instead of just printing 'ok'. |
579
|
|
|
|
|
|
|
|
580
|
|
|
|
|
|
|
=cut |
581
|
|
|
|
|
|
|
|
582
|
|
|
|
|
|
|
sub tm_new_engine |
583
|
|
|
|
|
|
|
{ |
584
|
0
|
|
|
0
|
1
|
|
my $sEngine = shift; |
585
|
0
|
|
|
|
|
|
$oSearch = new WWW::Search($sEngine); |
586
|
0
|
|
|
|
|
|
Test::More::ok(ref($oSearch), "instantiate WWW::Search::$sEngine object"); |
587
|
0
|
|
|
|
|
|
$oSearch->env_proxy('yes'); |
588
|
|
|
|
|
|
|
} # tm_new_engine |
589
|
|
|
|
|
|
|
|
590
|
|
|
|
|
|
|
=head2 run_test |
591
|
|
|
|
|
|
|
|
592
|
|
|
|
|
|
|
Three arguments: a query string, NOT escaped; |
593
|
|
|
|
|
|
|
a minimum number of expected results; and |
594
|
|
|
|
|
|
|
a maximum number of expected results. |
595
|
|
|
|
|
|
|
Optional fourth argument: integer value to be used as the search_debug. |
596
|
|
|
|
|
|
|
Optional fifth argument: send any true value to dump the search results. |
597
|
|
|
|
|
|
|
Optional sixth argument: reference to hash of search options (see backend documentation). |
598
|
|
|
|
|
|
|
Optional seventh argument: send any true value to NOT escape the query string. |
599
|
|
|
|
|
|
|
|
600
|
|
|
|
|
|
|
If the minimum is undef, assumes zero. |
601
|
|
|
|
|
|
|
If the maximum is undef, does not check. |
602
|
|
|
|
|
|
|
|
603
|
|
|
|
|
|
|
Prints 'ok' or 'not ok' and the test number. |
604
|
|
|
|
|
|
|
|
605
|
|
|
|
|
|
|
=cut |
606
|
|
|
|
|
|
|
|
607
|
|
|
|
|
|
|
sub run_test |
608
|
|
|
|
|
|
|
{ |
609
|
0
|
|
|
0
|
1
|
|
return &_run_our_test('normal', @_); |
610
|
|
|
|
|
|
|
} # run_test |
611
|
|
|
|
|
|
|
|
612
|
|
|
|
|
|
|
=head2 run_gui_test |
613
|
|
|
|
|
|
|
|
614
|
|
|
|
|
|
|
Same as run_test(), but calls gui_query() instead of native_query(). |
615
|
|
|
|
|
|
|
|
616
|
|
|
|
|
|
|
=cut |
617
|
|
|
|
|
|
|
|
618
|
|
|
|
|
|
|
sub run_gui_test |
619
|
|
|
|
|
|
|
{ |
620
|
0
|
|
|
0
|
1
|
|
return &_run_our_test('gui', @_); |
621
|
|
|
|
|
|
|
} # run_gui_test |
622
|
|
|
|
|
|
|
|
623
|
|
|
|
|
|
|
|
624
|
|
|
|
|
|
|
=head2 tm_run_test |
625
|
|
|
|
|
|
|
|
626
|
|
|
|
|
|
|
Same as run_test(), but uses Test::More rather than just printing 'ok'. |
627
|
|
|
|
|
|
|
|
628
|
|
|
|
|
|
|
Note: If you use this function inside a TODO block, |
629
|
|
|
|
|
|
|
you must set global variable $TODO rather than a local $TODO, |
630
|
|
|
|
|
|
|
and you must set the global $TODO back to empty-string (or undef) at the end of your TODO block. |
631
|
|
|
|
|
|
|
For example: |
632
|
|
|
|
|
|
|
|
633
|
|
|
|
|
|
|
TODO: |
634
|
|
|
|
|
|
|
{ |
635
|
|
|
|
|
|
|
$TODO = 'I have not fixed this yet'; |
636
|
|
|
|
|
|
|
tm_run_test(...); |
637
|
|
|
|
|
|
|
$TODO = ''; |
638
|
|
|
|
|
|
|
} # end of TODO block |
639
|
|
|
|
|
|
|
|
640
|
|
|
|
|
|
|
=cut |
641
|
|
|
|
|
|
|
|
642
|
|
|
|
|
|
|
sub tm_run_test |
643
|
|
|
|
|
|
|
{ |
644
|
0
|
|
|
0
|
1
|
|
_tm_run_test(@_, 1); |
645
|
|
|
|
|
|
|
} # tm_run_test |
646
|
|
|
|
|
|
|
|
647
|
|
|
|
|
|
|
sub _tm_run_test |
648
|
|
|
|
|
|
|
{ |
649
|
|
|
|
|
|
|
# Last argument is boolean, whether to check approx_result_count: |
650
|
0
|
|
0
|
0
|
|
|
my $iApprox = pop(@_) || 0; |
651
|
|
|
|
|
|
|
# Remaining args, same as count_results(): |
652
|
0
|
|
|
|
|
|
my ($sType, $sQuery, $iMin, $iMax) = @_; |
653
|
0
|
|
|
|
|
|
my $iCount = count_results(@_); |
654
|
0
|
|
|
|
|
|
my $iAnyFailure = 0; |
655
|
0
|
0
|
|
|
|
|
$iAnyFailure++ unless Test::More::is($oSearch->response->code, 200, 'got valid HTTP response'); |
656
|
0
|
0
|
|
|
|
|
if (defined $iMin) |
657
|
|
|
|
|
|
|
{ |
658
|
0
|
0
|
|
|
|
|
$iAnyFailure++ unless Test::More::cmp_ok($iMin, '<=', $iCount, |
659
|
|
|
|
|
|
|
qq{lower-bound num-hits for query=$sQuery}); |
660
|
0
|
0
|
|
|
|
|
if ($iApprox) |
661
|
|
|
|
|
|
|
{ |
662
|
0
|
0
|
|
|
|
|
$iAnyFailure++ unless Test::More::cmp_ok($iMin, '<=', $oSearch->approximate_result_count, |
663
|
|
|
|
|
|
|
qq{lower-bound approximate_result_count}); |
664
|
|
|
|
|
|
|
} # if |
665
|
|
|
|
|
|
|
} # if |
666
|
0
|
0
|
|
|
|
|
if (defined $iMax) |
667
|
|
|
|
|
|
|
{ |
668
|
0
|
0
|
|
|
|
|
$iAnyFailure++ unless Test::More::cmp_ok($iCount, '<=', $iMax, |
669
|
|
|
|
|
|
|
qq{upper-bound num-hits for query=$sQuery}); |
670
|
0
|
0
|
|
|
|
|
if ($iApprox) |
671
|
|
|
|
|
|
|
{ |
672
|
0
|
0
|
|
|
|
|
$iAnyFailure++ unless Test::More::cmp_ok($oSearch->approximate_result_count, '<=', $iMax, |
673
|
|
|
|
|
|
|
qq{upper-bound approximate_result_count}); |
674
|
|
|
|
|
|
|
} # if |
675
|
|
|
|
|
|
|
} # if |
676
|
0
|
|
0
|
|
|
|
$sSaveOnError ||= q''; |
677
|
0
|
0
|
0
|
|
|
|
if ($iAnyFailure && ($sSaveOnError ne q'')) |
678
|
|
|
|
|
|
|
{ |
679
|
0
|
|
|
|
|
|
write_file($sSaveOnError, { err_mode => 'quiet'}, $oSearch->response->content); |
680
|
0
|
|
|
|
|
|
Test::More::diag(qq'HTML was saved in $sSaveOnError'); |
681
|
|
|
|
|
|
|
} # if |
682
|
|
|
|
|
|
|
} # _tm_run_test |
683
|
|
|
|
|
|
|
|
684
|
|
|
|
|
|
|
=head2 tm_run_test_no_approx |
685
|
|
|
|
|
|
|
|
686
|
|
|
|
|
|
|
Same as tm_run_test, but does NOT check the approximate_result_count. |
687
|
|
|
|
|
|
|
|
688
|
|
|
|
|
|
|
=cut |
689
|
|
|
|
|
|
|
|
690
|
|
|
|
|
|
|
sub tm_run_test_no_approx |
691
|
|
|
|
|
|
|
{ |
692
|
0
|
|
|
0
|
1
|
|
_tm_run_test(@_, 0); |
693
|
|
|
|
|
|
|
} # tm_run_test_no_approx |
694
|
|
|
|
|
|
|
|
695
|
|
|
|
|
|
|
=head2 count_results |
696
|
|
|
|
|
|
|
|
697
|
|
|
|
|
|
|
Run a query, and return the actual (not approximate) number of hits. |
698
|
|
|
|
|
|
|
Required first argument determines which backend query method to call: 'gui' to call gui_query(), anything else to call native_query(). |
699
|
|
|
|
|
|
|
Remaining arguments are same as all the run_test() arguments. |
700
|
|
|
|
|
|
|
|
701
|
|
|
|
|
|
|
=cut |
702
|
|
|
|
|
|
|
|
703
|
|
|
|
|
|
|
sub count_results |
704
|
|
|
|
|
|
|
{ |
705
|
0
|
|
|
0
|
1
|
|
my ($sType, $sQuery, $iMin, $iMax, $iDebug, $iPrintResults, $rh, $iDoNotEscape) = @_; |
706
|
|
|
|
|
|
|
# print STDERR qq{ DDD count_results raw args($sType,$sQuery,$iMin,$iMax,$iDebug,$iPrintResults,$rh,$iDoNotEscape)\n}; |
707
|
0
|
|
0
|
|
|
|
$iDebug ||= 0; |
708
|
0
|
|
0
|
|
|
|
$iPrintResults ||= 0; |
709
|
0
|
|
|
|
|
|
$rh->{'search_debug'} = $iDebug; |
710
|
0
|
0
|
0
|
|
|
|
carp ' --- min/max values out of order?' if (defined($iMin) && defined($iMax) && ($iMax < $iMin)); |
|
|
|
0
|
|
|
|
|
711
|
0
|
|
|
|
|
|
$oSearch->reset_search; |
712
|
0
|
|
0
|
|
|
|
$iMin ||= 0; |
713
|
|
|
|
|
|
|
# While $iMax is the number the user wants to compare, $iMaxAbs is |
714
|
|
|
|
|
|
|
# the actual number we apply to the search: |
715
|
0
|
|
|
|
|
|
my $iMaxAbs; |
716
|
0
|
0
|
|
|
|
|
if (! defined($iMax)) |
717
|
|
|
|
|
|
|
{ |
718
|
|
|
|
|
|
|
# User said upper limit is 'undef'; just make sure we get the |
719
|
|
|
|
|
|
|
# mininum: |
720
|
0
|
|
|
|
|
|
$iMaxAbs = $iMin + 1; |
721
|
|
|
|
|
|
|
} # if |
722
|
|
|
|
|
|
|
else |
723
|
|
|
|
|
|
|
{ |
724
|
|
|
|
|
|
|
# Give a little breathing room, so we'll notice if there are too |
725
|
|
|
|
|
|
|
# many returned: |
726
|
0
|
|
|
|
|
|
$iMaxAbs = $iMax + 1; |
727
|
|
|
|
|
|
|
} |
728
|
0
|
|
|
|
|
|
$oSearch->maximum_to_retrieve($iMaxAbs); |
729
|
0
|
|
|
|
|
|
$iTest++; |
730
|
0
|
0
|
|
|
|
|
$sQuery = WWW::Search::escape_query($sQuery) unless $iDoNotEscape; |
731
|
|
|
|
|
|
|
# print STDERR " + in WWW::Search::Test::count_results, iDebug = $iDebug\n"; |
732
|
0
|
0
|
|
|
|
|
if ($sType eq 'gui') |
733
|
|
|
|
|
|
|
{ |
734
|
0
|
|
|
|
|
|
$oSearch->gui_query($sQuery, $rh); |
735
|
|
|
|
|
|
|
} |
736
|
|
|
|
|
|
|
else |
737
|
|
|
|
|
|
|
{ |
738
|
0
|
|
|
|
|
|
$oSearch->native_query($sQuery, $rh); |
739
|
|
|
|
|
|
|
} |
740
|
0
|
|
|
|
|
|
$oSearch->login($ENV{WWW_SEARCH_USERNAME}, $ENV{WWW_SEARCH_PASSWORD}); |
741
|
0
|
|
|
|
|
|
my @aoResults = $oSearch->results(); |
742
|
0
|
0
|
|
|
|
|
if ($iPrintResults) |
743
|
|
|
|
|
|
|
{ |
744
|
0
|
|
|
|
|
|
my $i = 1; |
745
|
0
|
|
|
|
|
|
foreach my $oResult (@aoResults) |
746
|
|
|
|
|
|
|
{ |
747
|
0
|
|
|
|
|
|
print $i++, '. ', $oResult->url, "\n"; |
748
|
0
|
|
|
|
|
|
foreach my $sField (qw( title description score change_date index_date size company location source )) |
749
|
|
|
|
|
|
|
{ |
750
|
0
|
0
|
|
|
|
|
print " $sField==", $oResult->$sField, "==\n" if defined($oResult->$sField); |
751
|
|
|
|
|
|
|
} # foreach |
752
|
|
|
|
|
|
|
} # foreach |
753
|
|
|
|
|
|
|
} # if |
754
|
0
|
|
|
|
|
|
return scalar(@aoResults); |
755
|
|
|
|
|
|
|
} # count_results |
756
|
|
|
|
|
|
|
|
757
|
|
|
|
|
|
|
|
758
|
|
|
|
|
|
|
sub _run_our_test |
759
|
|
|
|
|
|
|
{ |
760
|
0
|
|
|
0
|
|
|
my ($sType, $sQuery, $iMin, $iMax, $iDebug, $iPrintResults) = @_; |
761
|
0
|
|
|
|
|
|
my $iResults = &count_results(@_); |
762
|
0
|
|
|
|
|
|
my $sExpect; |
763
|
0
|
0
|
|
|
|
|
if (! defined($iMax)) |
|
|
0
|
|
|
|
|
|
764
|
|
|
|
|
|
|
{ |
765
|
0
|
|
|
|
|
|
$sExpect = "more than $iMin"; |
766
|
|
|
|
|
|
|
} |
767
|
|
|
|
|
|
|
elsif (! defined($iMin)) |
768
|
|
|
|
|
|
|
{ |
769
|
0
|
|
|
|
|
|
$sExpect = "fewer than $iMax"; |
770
|
|
|
|
|
|
|
} |
771
|
|
|
|
|
|
|
else |
772
|
|
|
|
|
|
|
{ |
773
|
0
|
|
|
|
|
|
$sExpect = "$iMin..$iMax"; |
774
|
|
|
|
|
|
|
} |
775
|
0
|
0
|
|
|
|
|
$iMax = 999999 unless defined ($iMax); |
776
|
0
|
0
|
0
|
|
|
|
if (($iResults < $iMin) || ($iMax < $iResults)) |
777
|
|
|
|
|
|
|
{ |
778
|
0
|
|
|
|
|
|
print STDERR " --- got $iResults results for $sType $sEngine query '$sQuery', but expected $sExpect\n"; |
779
|
0
|
|
|
|
|
|
print STDOUT 'not '; |
780
|
|
|
|
|
|
|
} # if |
781
|
0
|
|
|
|
|
|
print STDOUT "ok $iTest\n"; |
782
|
|
|
|
|
|
|
} # _run_our_test |
783
|
|
|
|
|
|
|
|
784
|
|
|
|
|
|
|
|
785
|
|
|
|
|
|
|
=head2 skip_test |
786
|
|
|
|
|
|
|
|
787
|
|
|
|
|
|
|
You can call this function instead of run_test() or run_gui_test() |
788
|
|
|
|
|
|
|
if the current test must be skipped for any reason. |
789
|
|
|
|
|
|
|
|
790
|
|
|
|
|
|
|
=cut |
791
|
|
|
|
|
|
|
|
792
|
|
|
|
|
|
|
sub skip_test |
793
|
|
|
|
|
|
|
{ |
794
|
0
|
|
|
0
|
1
|
|
$iTest++; |
795
|
0
|
|
|
|
|
|
print STDOUT "skip $iTest\n"; |
796
|
|
|
|
|
|
|
} # skip_test |
797
|
|
|
|
|
|
|
|
798
|
|
|
|
|
|
|
|
799
|
|
|
|
|
|
|
=head2 test_most_results |
800
|
|
|
|
|
|
|
|
801
|
|
|
|
|
|
|
Given an arrayref of things to test, |
802
|
|
|
|
|
|
|
runs all those things against all the results of the most-recently executed test search. |
803
|
|
|
|
|
|
|
|
804
|
|
|
|
|
|
|
=cut |
805
|
|
|
|
|
|
|
|
806
|
|
|
|
|
|
|
sub test_most_results |
807
|
|
|
|
|
|
|
{ |
808
|
0
|
|
|
0
|
1
|
|
my $rara = shift; |
809
|
0
|
|
0
|
|
|
|
my $fPct = shift || 0.80; |
810
|
0
|
|
|
|
|
|
my $iCount = scalar(@$rara); |
811
|
0
|
|
|
|
|
|
my $iAnyFailed = my $iResult = 0; |
812
|
0
|
|
|
|
|
|
my %hioExemplar; |
813
|
|
|
|
|
|
|
my %hiiFailed; |
814
|
|
|
|
|
|
|
# Create a bit vector large enough to hold one bit for each test: |
815
|
0
|
|
|
|
|
|
my $oV = new Bit::Vector($iCount); |
816
|
|
|
|
|
|
|
# Turn on all the bits (we will turn off bits when tests fail): |
817
|
0
|
|
|
|
|
|
$oV->Fill; |
818
|
0
|
|
|
|
|
|
my $iVall = $oV->to_Dec; |
819
|
0
|
|
|
|
|
|
my $sCodeAll = q{}; |
820
|
0
|
|
|
|
|
|
my $iTest = 0; |
821
|
|
|
|
|
|
|
TEST: |
822
|
0
|
|
|
|
|
|
foreach my $ra (@$rara) |
823
|
|
|
|
|
|
|
{ |
824
|
|
|
|
|
|
|
# print STDERR " DDD ra is ", Dumper($ra); |
825
|
0
|
|
|
|
|
|
my ($sField, $sCmp, $sValue, $sDesc) = @$ra; |
826
|
0
|
|
0
|
|
|
|
$sDesc ||= qq{test #$iTest}; |
827
|
0
|
|
|
|
|
|
my $sCode; |
828
|
0
|
0
|
|
|
|
|
if ($sCmp eq 'like') |
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
829
|
|
|
|
|
|
|
{ |
830
|
0
|
|
|
|
|
|
$sCode = "(\$oResult->$sField =~ m!$sValue!)"; |
831
|
|
|
|
|
|
|
} # if |
832
|
|
|
|
|
|
|
elsif ($sCmp eq 'unlike') |
833
|
|
|
|
|
|
|
{ |
834
|
0
|
|
|
|
|
|
$sCode = "(\$oResult->$sField !~ m!$sValue!)"; |
835
|
|
|
|
|
|
|
} # if |
836
|
|
|
|
|
|
|
elsif ($sCmp eq 'date') |
837
|
|
|
|
|
|
|
{ |
838
|
0
|
|
|
|
|
|
$sCode = "((ParseDate(\$oResult->$sField) || '') ne q{})"; |
839
|
|
|
|
|
|
|
} # if |
840
|
|
|
|
|
|
|
else |
841
|
|
|
|
|
|
|
{ |
842
|
0
|
|
|
|
|
|
$sCode = "(\$oResult->$sField $sCmp $sValue)"; |
843
|
|
|
|
|
|
|
} |
844
|
0
|
|
|
|
|
|
$sCode = <<"ENDCODE"; |
845
|
|
|
|
|
|
|
if (! $sCode) |
846
|
|
|
|
|
|
|
{ |
847
|
|
|
|
|
|
|
\$oV->Bit_Off($iTest); |
848
|
|
|
|
|
|
|
\$hiiFailed{'$sDesc'}++; |
849
|
|
|
|
|
|
|
} # if |
850
|
|
|
|
|
|
|
ENDCODE |
851
|
0
|
|
|
|
|
|
$sCodeAll .= $sCode; |
852
|
0
|
|
|
|
|
|
$iTest++; |
853
|
|
|
|
|
|
|
} # foreach TEST |
854
|
0
|
|
|
|
|
|
$sCodeAll .= "1;\n"; |
855
|
|
|
|
|
|
|
# print STDERR " DDD the test is ===$sCodeAll===\n"; |
856
|
|
|
|
|
|
|
RESULT: |
857
|
0
|
|
|
|
|
|
foreach my $oResult ($oSearch->results()) |
858
|
|
|
|
|
|
|
{ |
859
|
0
|
|
|
|
|
|
$iResult++; |
860
|
|
|
|
|
|
|
# Turn on all the bits (we will turn off bits when tests fail): |
861
|
0
|
|
|
|
|
|
$oV->Fill; |
862
|
|
|
|
|
|
|
# print STDERR " DDD eval the test...\n"; |
863
|
0
|
0
|
|
|
|
|
if (! eval $sCodeAll) |
864
|
|
|
|
|
|
|
{ |
865
|
0
|
|
|
|
|
|
print STDERR $@; |
866
|
|
|
|
|
|
|
} # if |
867
|
|
|
|
|
|
|
# Now look at the value of the Bit::Vector after running the tests: |
868
|
0
|
|
|
|
|
|
my $iV = $oV->to_Dec; |
869
|
0
|
0
|
|
|
|
|
if ($iV < $iVall) |
870
|
|
|
|
|
|
|
{ |
871
|
|
|
|
|
|
|
# At least one of the bits got turned off (i.e. a test failed): |
872
|
0
|
|
|
|
|
|
$hioExemplar{$iV} = $oResult; |
873
|
0
|
|
|
|
|
|
$iAnyFailed++; |
874
|
|
|
|
|
|
|
# For debugging: |
875
|
|
|
|
|
|
|
# print STDERR Dumper($oResult); |
876
|
|
|
|
|
|
|
# last RESULT; |
877
|
|
|
|
|
|
|
} # if |
878
|
|
|
|
|
|
|
} # foreach RESULT |
879
|
0
|
|
|
|
|
|
ok($iResult, qq{got more than zero results ($iResult, to be exact)}); |
880
|
|
|
|
|
|
|
# Now make sure all the sub-tests passed at least N% of the time. |
881
|
|
|
|
|
|
|
# We only need to look at sub-tests that had any failures (sub-tests |
882
|
|
|
|
|
|
|
# with no failures are 100% correct, so there's no need to check |
883
|
|
|
|
|
|
|
# them 8-) |
884
|
0
|
|
|
|
|
|
while (my ($sItem, $iFailed) = each %hiiFailed) |
885
|
|
|
|
|
|
|
{ |
886
|
0
|
|
|
|
|
|
my $fPctFailed = ($iFailed / $iResult); |
887
|
0
|
|
|
|
|
|
ok($fPctFailed < (1 - $fPct), sprintf(qq{%0.1f%% of '%s' tests failed}, $fPctFailed * 100, $sItem)); |
888
|
|
|
|
|
|
|
} # while |
889
|
0
|
0
|
|
|
|
|
if ($iAnyFailed) |
890
|
|
|
|
|
|
|
{ |
891
|
0
|
|
|
|
|
|
Test::More::diag(" Here are result(s) that exemplify test failure(s):"); |
892
|
0
|
|
|
|
|
|
foreach my $oResult (values %hioExemplar) |
893
|
|
|
|
|
|
|
{ |
894
|
0
|
|
|
|
|
|
Test::More::diag(Dumper($oResult)); |
895
|
|
|
|
|
|
|
} # while |
896
|
|
|
|
|
|
|
} # if |
897
|
|
|
|
|
|
|
} # test_most_results |
898
|
|
|
|
|
|
|
|
899
|
|
|
|
|
|
|
1; |
900
|
|
|
|
|
|
|
|
901
|
|
|
|
|
|
|
__END__ |