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