File Coverage

blib/lib/HTTP/ClientDetect/Location.pm
Criterion Covered Total %
statement 34 36 94.4
branch 6 12 50.0
condition n/a
subroutine 7 7 100.0
pod 1 1 100.0
total 48 56 85.7


line stmt bran cond sub pod time code
1             package HTTP::ClientDetect::Location;
2              
3 2     2   1221 use 5.006;
  2         6  
  2         60  
4 2     2   7 use strict;
  2         2  
  2         55  
5 2     2   8 use warnings FATAL => 'all';
  2         2  
  2         57  
6 2     2   1390 use Module::Load;
  2         1614  
  2         11  
7 2     2   70 use Moo;
  2         2  
  2         10  
8              
9             =head1 NAME
10              
11             HTTP::ClientDetect::Location - Lookup the country of the client using Geo::IP
12              
13             =head1 VERSION
14              
15             Version 0.01
16              
17             =cut
18              
19             our $VERSION = '0.01';
20              
21              
22             =head1 SYNOPSIS
23              
24             use HTTP::ClientDetect::Location;
25             my $geo = HTTP::ClientDetect::Location->new(db => "/path/to/geo-ip");
26             # inside a Dancer route
27             get '/detect' => sub {
28             my $req = request;
29             my $country_code = $geo->country_code($req);
30             }
31              
32              
33             =head1 ACCESSORS
34              
35             =head2 db
36              
37             Path to the geoip database, which can be retrieved from
38             http://dev.maxmind.com/geoip/legacy/geolite/
39              
40             C must be passed to the constructor.
41              
42             =cut
43              
44             has db => (is => 'ro',
45             required => 1,
46             isa => sub {
47             die "db is not a file" unless -f $_[0];
48             });
49              
50              
51             =head2 geo
52              
53             This accessor wraps L or L. Calling
54             $geo->geo will return an instantiated object, and you can call, e.g.
55             C<$geo->geo->country_code_by_addr("128.31.0.51")> or
56             C<$geo->geo->country_code_by_name("linuxia.de")>.
57              
58             =cut
59              
60             has geo => (is => 'rwp',
61             builder => 1);
62              
63             sub _build_geo {
64 1     1   13 my $self = shift;
65 1         1 my $module = "Geo::IP";
66 1         2 eval {
67 1         3 load $module;
68             };
69 1 50       2612 if ($@) {
70 1         3 $module .= "::PurePerl";
71             # if we die here too bad
72 1         3 load $module;
73             }
74 1         22584 my $gi = $module->open($self->db);
75 1         195 return $gi;
76             }
77              
78             =head1 SUBROUTINES/METHODS
79              
80             =head2 request_country($request_obj)
81              
82             Return the country of the request. The request should be a string with
83             the ip or L object (or something that respond to the
84             method "remote_address").
85              
86             =cut
87              
88             sub request_country {
89 2     2 1 206 my ($self, $arg) = @_;
90 2         3 my $ip;
91 2 100       5 if (ref($arg)) {
92             # Dancer
93 1 50       8 if ($arg->can("remote_address")) {
    0          
94 1         4 $ip = $arg->remote_address;
95             }
96             # Catalyst
97             elsif ($arg->can("address")) {
98 0         0 $ip = $arg->address;
99             }
100             }
101             else {
102 1         2 $ip = $arg;
103             }
104 2 50       5 return unless $ip;
105 2 50       11 if ($ip =~ m/(([0-9]{1,3}\.){3}([0-9]{1,3}))/) {
106 2         3 $ip = $1;
107 2         8 return $self->geo->country_code_by_addr($ip);
108             }
109             else {
110 0           return;
111             }
112             }
113              
114             =head1 AUTHOR
115              
116             Marco Pessotto, C<< >>
117              
118             =head1 BUGS
119              
120             Please report any bugs or feature requests to C, or through
121             the web interface at L. I will be notified, and then you'll
122             automatically be notified of progress on your bug as I make changes.
123              
124              
125              
126              
127             =head1 SUPPORT
128              
129             You can find documentation for this module with the perldoc command.
130              
131             perldoc HTTP::ClientDetect::Location
132              
133              
134             You can also look for information at:
135              
136             =over 4
137              
138             =item * RT: CPAN's request tracker (report bugs here)
139              
140             L
141              
142             =item * AnnoCPAN: Annotated CPAN documentation
143              
144             L
145              
146             =item * CPAN Ratings
147              
148             L
149              
150             =item * Search CPAN
151              
152             L
153              
154             =back
155              
156              
157             =head1 ACKNOWLEDGEMENTS
158              
159              
160             =head1 LICENSE AND COPYRIGHT
161              
162             Copyright 2013 Marco Pessotto.
163              
164             This program is free software; you can redistribute it and/or modify it
165             under the terms of either: the GNU General Public License as published
166             by the Free Software Foundation; or the Artistic License.
167              
168             See L for more information.
169              
170              
171             =cut
172              
173             1; # End of HTTP::ClientDetect::Location