1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
|
#!/usr/bin/env perl -w
use strict;
use warnings;
use vars qw( $VERSION $SILENT );
BEGIN {
$ENV{PARSE_HTTP_USERAGENT_TEST_SUITE} = 1;
}
use constant TERMINAL_WIDTH => 80;
use Test::More qw( no_plan );
use File::Spec;
use Getopt::Long;
use Parse::HTTP::UserAgent;
# Work-around for the removal of "." from @INC in Perl 5.26
if (! grep { $_ eq '.' } @INC) {
require FindBin;
no warnings 'once';
push @INC, $FindBin::Bin . '/..';
}
require_ok( File::Spec->catfile( t => 'db.pl' ) );
GetOptions(\my %opt, qw(
dump
debug
supported
));
$SILENT = 1;
my(@todo,@wrong, %supported);
run();
sub run {
if ( @todo ) {
diag q{-} x TERMINAL_WIDTH;
diag 'UserAgents not yet recognized:';
diag $_ for @todo;
}
if ( @wrong ) {
diag q{-} x TERMINAL_WIDTH;
diag 'BOGUS parse results:';
diag $_ for @wrong;
}
if ( $opt{supported} ) {
diag 'Supported user agents are:';
foreach my $name ( sort { lc $a cmp lc $b } keys %supported ) {
diag "\t$name";
}
}
_tests();
return;
}
sub _tests {
foreach my $test ( database() ) {
my $str = $test->{string};
my $ua = Parse::HTTP::UserAgent->new( $str );
_basic( $ua, $str );
_extended( $ua, $str );
}
return;
}
sub _extended {
my($ua, $str) = @_;
if ( $ua->name eq 'MSIE' ) {
my @net = $ua->dotnet;
@net ? ok( scalar @net, "We got .NET CLR: @net")
: $opt{debug} && diag("No .NET identifier in the MSIE Agent: $str");
}
$ua->os ? ok(1, sprintf q{The Operating System is '%s'}, $ua->os )
: $opt{debug} && diag("No operating system from $str");
$ua->lang ? ok(1, sprintf q{"The Interface Language is '%s'}, $ua->lang )
: $opt{debug} && diag("No language identifier from $str");
my @mozilla = $ua->mozilla;
my @toolkit = $ua->toolkit;
my @extras = $ua->extras;
if ( $opt{debug} ) {
diag "Extras are: @extras" if @extras;
diag "Toolkit: @toolkit" if @toolkit;
diag "Mozilla: @mozilla" if @mozilla;
}
# dump the parsed structure
ok( my $dump = $ua->dumper, 'It can dump');
diag $dump if $opt{dump};
$supported{ $ua->original_name || $ua->name }++ if $opt{supported};
return;
}
sub _basic {
my($ua, $str) = @_;
ok( defined $ua, 'We got an object');
my $oops = $ua->unknown ? 1 : 0;
if ( ! $ua->robot && ! $ua->generic && $oops ) {
my $e = sprintf qq{%s instead of %s\t'%s'},
$oops ? 'unknown' : lc $ua->name,
'???',
$str;
push @wrong, $e;
fail("Bogus parse result! $e");
}
ok(1, "Found a robot: $str") if $ua->robot;
# interface
ok( $ua->name, 'It has name' );
ok( defined $ua->version , "It has version - $str" );
ok( defined $ua->version('raw'), 'It has raw version' );
return;
}
1;
__END__
|
