File Coverage

blib/lib/CGI/BrowserDetect.pm
Criterion Covered Total %
statement 34 34 100.0
branch 5 12 41.6
condition 4 9 44.4
subroutine 11 11 100.0
pod 7 7 100.0
total 61 73 83.5


line stmt bran cond sub pod time code
1             package CGI::BrowserDetect;
2              
3 2     2   108999 use 5.006;
  2         16  
4 2     2   10 use strict;
  2         3  
  2         36  
5 2     2   8 use warnings;
  2         2  
  2         66  
6              
7 2     2   16 use base qw/HTTP::BrowserDetect/;
  2         4  
  2         1101  
8              
9             =head1 NAME
10              
11             CGI::BrowserDetect - Browser Detect
12              
13             =head1 VERSION
14              
15             Version 0.02
16              
17             =cut
18              
19             our $VERSION = '0.02';
20              
21             sub new {
22 1     1 1 91 my $pkg = shift;
23 1         4 my $count = scalar @_;
24            
25 1 0       7 my %args = $count == 2
    50          
26             ? (HTTP_USER_AGENT => shift, HTTP_ACCEPT_LANGUAGE => shift)
27             : $count == 1
28             ? (HTTP_USER_AGENT => shift)
29             : @_;
30              
31 1         9 my $self = $pkg->SUPER::new($args{HTTP_USER_AGENT});
32            
33 1 50       88 if ($args{HTTP_ACCEPT_LANGUAGE}) {
34 1         2 $self->{accept_language} = $args{HTTP_ACCEPT_LANGUAGE};
35 1         7 ($self->{_lang}, $self->{_cnty}) = $self->{accept_language} =~ /([a-z]{2})\-([A-Z]{2})/;
36             }
37 1         3 return $self;
38             }
39              
40             sub detect {
41 1     1 1 8 my ($self, @want) = @_;
42 1         2 my %provide;
43              
44 1   66     7 $self->$_ && do { $provide{$_} = $self->$_ } for @want;
  6         90  
45              
46 1 50       35 return wantarray ? %provide : \%provide;
47             }
48              
49             sub device_type {
50 2     2 1 174 my ($self) = @_;
51            
52 2 50       8 return $self->mobile
    50          
53             ? 'mobile'
54             : $self->tablet
55             ? 'tablet'
56             : 'computer';
57             }
58              
59 2     2 1 12 sub lang { language(@_); }
60              
61             sub language {
62 4     4 1 6 my ($self) = @_;
63 4         12 my $language = $self->SUPER::language();
64 4   33     133 return $language || $self->{_lang};
65             }
66              
67 2     2 1 5 sub cnty { country(@_); }
68              
69             sub country {
70 4     4 1 6 my ($self) = @_;
71 4         8 my $country = $self->SUPER::country();
72 4   33     110 return $country || $self->{_cnty};
73             }
74              
75             1;
76              
77             =head1 SYNOPSIS
78              
79             Quick summary of what the module does.
80              
81             Perhaps a little code snippet.
82              
83             use CGI::BrowserDetect;
84              
85             my $ua = CGI::BrowserDetect->new($ENV{HTTP_USER_AGENT}, $ENV{HTTP_ACCEPT_LANGUAGE});
86             ...
87              
88             my $hash = $ua->detect(qw/os browser type language country/);
89              
90              
91             =head1 SUBROUTINES/METHODS
92              
93             =head2 detect
94              
95             pass in keys and returns a hash or reference.
96              
97             =head2 device_type
98              
99             return the type of device
100              
101             =head2 lang
102              
103             return the language if not found in HTTP_USER_AGENT using HTTP_ACCEPT_LANGUAGE
104              
105             =head2 cnty
106              
107             returns the country IF NOT FOUND IN HTTP_USER_AGENT using HTTP_ACCEPT_LANGUAGE
108              
109             =head2
110              
111             =head1 AUTHOR
112              
113             Robert Acock, C<< >>
114              
115             =head1 BUGS
116              
117             Please report any bugs or feature requests to C, or through
118             the web interface at L. I will be notified, and then you'll
119             automatically be notified of progress on your bug as I make changes.
120              
121             =head1 SUPPORT
122              
123             You can find documentation for this module with the perldoc command.
124              
125             perldoc CGI::BrowserDetect
126              
127              
128             You can also look for information at:
129              
130             =over 4
131              
132             =item * RT: CPAN's request tracker (report bugs here)
133              
134             L
135              
136             =item * AnnoCPAN: Annotated CPAN documentation
137              
138             L
139              
140             =item * CPAN Ratings
141              
142             L
143              
144             =item * Search CPAN
145              
146             L
147              
148             =back
149              
150              
151             =head1 ACKNOWLEDGEMENTS
152              
153              
154             =head1 LICENSE AND COPYRIGHT
155              
156             Copyright 2017 Robert Acock.
157              
158             This program is free software; you can redistribute it and/or modify it
159             under the terms of the the Artistic License (2.0). You may obtain a
160             copy of the full license at:
161              
162             L
163              
164             Any use, modification, and distribution of the Standard or Modified
165             Versions is governed by this Artistic License. By using, modifying or
166             distributing the Package, you accept this license. Do not use, modify,
167             or distribute the Package, if you do not accept this license.
168              
169             If your Modified Version has been derived from a Modified Version made
170             by someone other than you, you are nevertheless required to ensure that
171             your Modified Version complies with the requirements of this license.
172              
173             This license does not grant you the right to use any trademark, service
174             mark, tradename, or logo of the Copyright Holder.
175              
176             This license includes the non-exclusive, worldwide, free-of-charge
177             patent license to make, have made, use, offer to sell, sell, import and
178             otherwise transfer the Package with respect to any patent claims
179             licensable by the Copyright Holder that are necessarily infringed by the
180             Package. If you institute patent litigation (including a cross-claim or
181             counterclaim) against any party alleging that the Package constitutes
182             direct or contributory patent infringement, then this Artistic License
183             to you shall terminate on the date that such litigation is filed.
184              
185             Disclaimer of Warranty: THE PACKAGE IS PROVIDED BY THE COPYRIGHT HOLDER
186             AND CONTRIBUTORS "AS IS' AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES.
187             THE IMPLIED WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR
188             PURPOSE, OR NON-INFRINGEMENT ARE DISCLAIMED TO THE EXTENT PERMITTED BY
189             YOUR LOCAL LAW. UNLESS REQUIRED BY LAW, NO COPYRIGHT HOLDER OR
190             CONTRIBUTOR WILL BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, OR
191             CONSEQUENTIAL DAMAGES ARISING IN ANY WAY OUT OF THE USE OF THE PACKAGE,
192             EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
193              
194              
195             =cut
196              
197             1; # End of CGI::BrowserDetect