File Coverage

blib/lib/Catalyst/Plugin/I18N/PathPrefixGeoIP.pm
Criterion Covered Total %
statement 20 110 18.1
branch 0 28 0.0
condition 0 6 0.0
subroutine 7 19 36.8
pod 6 6 100.0
total 33 169 19.5


line stmt bran cond sub pod time code
1             package Catalyst::Plugin::I18N::PathPrefixGeoIP;
2              
3 6     6   10199353 use 5.008;
  6         25  
4              
5 6     6   815 use Moose::Role;
  6         490490  
  6         57  
6 6     6   34429 use namespace::autoclean;
  6         8542  
  6         58  
7              
8             requires
9             # from Catalyst
10             'config', 'prepare_path', 'req', 'uri_for', 'log',
11             # from Catalyst::Plugin::I18N
12             'languages', 'loc';
13              
14 6     6   622 use List::Util qw(first);
  6         12  
  6         453  
15 6     6   4698 use Scope::Guard;
  6         2602  
  6         253  
16 6     6   17184 use I18N::LangTags::List;
  6         83983  
  6         264  
17 6     6   10004 use Geo::IP;
  6         271238  
  6         12135  
18              
19             our $VERSION = '0.09';
20              
21             =head1 NAME
22              
23             Catalyst::Plugin::I18N::PathPrefixGeoIP - A drop in for atalyst::Plugin::I18N::PathPrefix that uses GeoIP
24              
25              
26             =head1 SYNOPSIS
27              
28             # in MyApp.pm
29             use Catalyst qw/
30             I18N I18N::PathPrefixGeoIP
31             /;
32             __PACKAGE__->config('Plugin::I18N::PathPrefixGeoIP' => {
33             valid_languages => [qw/en de fr/],
34             fallback_language => 'en',
35             language_independent_paths => qr{
36             ^( votes/ | captcha/numeric/ )
37             }x,
38             geoip_db => 'data/GeoLiteCity.dat',
39             });
40             __PACKAGE__->setup;
41              
42             # now the language is selected based on requests paths:
43             #
44             # http://www.example.com/en/foo/bar -> sets $c->language to 'en',
45             # dispatcher sees /foo/bar
46             #
47             # http://www.example.com/de/foo/bar -> sets $c->language to 'de',
48             # dispatcher sees /foo/bar
49             #
50             # http://www.example.com/fr/foo/bar -> sets $c->language to 'fr',
51             # dispatcher sees /foo/bar
52            
53              
54             # http://www.example.com/foo/bar -> used GeoIP to sets $c->language
55             # If GeoIp dos not fain a mach it fails
56             # over to use language from
57             # Accept-Language header,
58             # dispatcher sees /foo/bar
59             #
60             # or if redirect_to_language_url == 1:
61             #
62             # http://www.example.com/foo/bar -> redirect to http://www.example.com/xx/foo/bar
63             # where xx is language from Accept-Language header
64              
65             # in a controller
66             sub language_switch : Private
67             {
68             # the template will display the language switch
69             $c->stash('language_switch' => $c->language_switch_options);
70             }
71              
72             =head1 DESCRIPTION
73              
74             This module allows you to put the language selector as a prefix to the path part of
75             the request URI without requiring any modifications to the controllers (like
76             restructuring all the controllers to chain from a common base controller).
77              
78             (Internally it strips the language code from C<< $c->req->path >> and appends
79             it to C<< $c->req->base >> so that the invariant C<< $c->req->uri eq
80             $c->req->base . $c->req->path >> still remains valid, but the dispatcher does
81             not see the language code - it uses C<< $c->req->path >> only.)
82              
83             Throughout this document 'language code' means ISO 639-1 2-letter language
84             codes, case insensitively (eg. 'en', 'de', 'it', 'EN'), just like
85             L<I18N::LangTags> supports them.
86              
87             Note: You have to load L<Catalyst::Plugin::I18N> if you load this plugin.
88              
89             Note: HTTP already have a standard way (ie. Accept-Language header) to allow
90             the user specify the language (s)he prefers the page to be delivered in.
91             Unfortunately users often don't set it properly, but more importantly Googlebot
92             does not really support it (but requires that you always serve documents of the
93             same language on the same URI). So if you want a SEO-optimized multi-lingual
94             site, you have to have different (sub)domains for the different languages, or
95             resort to putting the language selector into the URL.
96              
97             =head1 CONFIGURATION
98              
99             You can use these configuration options under the C<'Plugin::I18N::PathPrefixGeoIP'>
100             key:
101              
102             =head2 valid_languages
103              
104             valid_languages => \@language_codes
105              
106             The language codes that are accepted as path prefix.
107              
108             =head2 fallback_language
109              
110             fallback_language => $language_code
111              
112             The fallback language code used if the URL contains no language prefix and
113             L<Catalyst::Plugin::I18N> cannot auto-detect the preferred language from the
114             C<Accept-Language> header or none of the detected languages are found in
115             L</valid_languages>.
116              
117             =head2 language_independent_paths
118              
119             language_independent_paths => $regex
120              
121             If the URI path is matched by C<$regex>, do not add language prefix and ignore
122             if there's one (and pretend as if the URI did not contain any language prefix,
123             ie. rewrite C<< $c->req->uri >>, C<< $c->req->base >> and C<< $c->req->path >>
124             to remove the prefix from them).
125              
126             Use a regex that matches all your paths that return language independent
127             information.
128              
129             If you don't set this config option or you set it to an undefined value, no
130             paths will be handled as language independent ones.
131              
132             =head2 redirect_to_language_url
133              
134             redirect_to_language_url => 1
135              
136             Redirect users to url with language prefix.
137              
138             Without redirect_to_language_url users may access your site using bout urls with a
139             language selector and without. This may be bad for search engine optimization because
140             search engines will have a hard time determine the original source for documents.
141             Setting redirect_to_language_url will redirect users to a url with language prefix.
142              
143             =head2 debug
144              
145             debug => $boolean
146              
147             If set to a true value, L</prepare_path_prefix> logs its actions (using C<<
148             $c->log->debug(...) >>).
149              
150             =head1 METHODS
151              
152             =cut
153              
154             =head2 setup_finalize
155              
156             Overridden (wrapped with an an C<after> modifier) from
157             L<Catalyst/setup_finalize>.
158              
159             Sets up the package configuration.
160              
161             =cut
162              
163             after setup_finalize => sub {
164             my ($c) = (shift, @_);
165              
166             my $config = $c->config->{'Plugin::I18N::PathPrefixGeoIP'};
167              
168             $config->{fallback_language} = lc $config->{fallback_language};
169              
170             my @valid_language_codes = map { lc $_ }
171             @{ $config->{valid_languages} };
172              
173             # fill the hash for quick lookups
174             @{ $config->{_valid_language_codes}}{ @valid_language_codes } = ();
175              
176             if (!defined $config->{language_independent_paths}) {
177             $config->{language_independent_paths} = qr/(?!)/; # never matches anything
178             }
179              
180             # Load GeoIP db
181             if (!$config->{geoip_db}) {
182             die ("Pleas set the geoip_db config option for Plugin::I18N::PathPrefixGeoIP.");
183             }
184              
185             $config->{geoip} = Geo::IP->open($config->{geoip_db}) or die("Can not open GeiIP db '" . $config->{geoip_db} . "'");
186              
187             };
188              
189             =head2 prepare_path
190              
191             Overridden (wrapped with an an C<after> modifier) from
192             L<Catalyst/prepare_path>.
193              
194             Calls C<< $c->prepare_path_prefix >> after the original method.
195              
196             =cut
197              
198             after prepare_path => sub {
199             my ($c) = (shift, @_);
200              
201             $c->prepare_path_prefix;
202             };
203              
204             =head2 prepare_path_prefix
205              
206             $c->prepare_path_prefix()
207              
208             Returns: N/A
209              
210             If C<< $c->req->path >> is matched by the L</language_independent_paths>
211             configuration option then calls C<< $c->set_languages_from_language_prefix >>
212             with the value of the L</fallback_language> configuration option and
213             returns.
214              
215             Otherwise, if C<< $c->req->path >> starts with a language code listed in the
216             L</valid_languages> configuration option, then splits language prefix from C<<
217             $c->req->path >> then appends it to C<< $c->req->base >> and calls C<<
218             $c->set_languages_from_language_prefix >> with this language prefix.
219              
220             Otherwise, it tries to select an appropriate language code:
221              
222             =over
223              
224             =item *
225              
226             It picks the first language code C<< $c->languages >> that is also present in
227             the L</valid_languages> configuration option.
228              
229             =item *
230              
231             If no such language code, uses the value of the L</fallback_language>
232             configuration option.
233              
234             =back
235              
236             Then appends this language code to C<< $c->req->base >> and the path part of
237             C<< $c->req->uri >>, finally calls C<< $c->set_languages_from_language_prefix >>
238             with that language code.
239              
240             =cut
241              
242             sub prepare_path_prefix
243             {
244 0     0 1   my ($c) = (shift, @_);
245              
246 0           my $config = $c->config->{'Plugin::I18N::PathPrefixGeoIP'};
247              
248 0           my $language_code = $config->{fallback_language};
249              
250 0           my $valid_language_codes = $config->{_valid_language_codes};
251              
252 0           my $req_path = $c->req->path;
253              
254 0 0         if ($req_path !~ $config->{language_independent_paths}) {
255 0           my ($prefix, $path) = split m{/}, $req_path, 2;
256 0 0         $prefix = lc $prefix if defined $prefix;
257 0 0         $path = '' if !defined $path;
258              
259 0 0 0       if (defined $prefix && exists $valid_language_codes->{$prefix}) {
260 0           $language_code = $prefix;
261              
262 0           $c->_language_prefix_debug("found language prefix '$language_code' "
263             . "in path '$req_path'");
264              
265             # can be a language independent path with surplus language prefix
266 0 0         if ($path =~ $config->{language_independent_paths}) {
267 0           $c->_language_prefix_debug("path '$path' is language independent");
268              
269             # bust the language prefix completely
270 0           $c->req->uri->path($path);
271              
272 0           $language_code = $config->{fallback_language};
273             }
274             else {
275             # replace the language prefix with the known lowercase one in $c->req->uri
276 0           $c->req->uri->path($language_code . '/' . $path);
277              
278             # since $c->req->path returns such a string that satisfies
279             # << $c->req->uri->path eq $c->req->base->path . $c->req->path >>
280             # this strips the language code prefix from $c->req->path
281 0           my $req_base = $c->req->base;
282 0           $req_base->path($req_base->path . $language_code . '/');
283             }
284             }
285             else {
286 0           my $detected_language_code;
287              
288 0           my $geocountry = _ip2contry($config->{geoip}, $c->req->address);
289              
290 0 0 0       if ($geocountry && exists $valid_language_codes->{$geocountry}) {
291 0           $detected_language_code = $geocountry;
292 0           $c->_language_prefix_debug("Detected valid language by GeoIP. Ip: " . $c->req->address . " -> Country: '$detected_language_code'");
293             }
294             else {
295 0           $c->_language_prefix_debug("Did not find valid language by GeoIP. Failing over to languages request header. Ip Address: " . $c->req->address);
296             $detected_language_code =
297 0     0     first { exists $valid_language_codes->{$_} }
298 0           map { lc $_ }
299 0           @{ $c->languages };
  0            
300             }
301              
302 0 0         $c->_language_prefix_debug("detected language: "
303             . ($detected_language_code ? "'$detected_language_code'" : "N/A"));
304              
305 0 0         $language_code = $detected_language_code if $detected_language_code;
306              
307             # fake that the request path already contained the language code prefix
308 0           my $req_uri = $c->req->uri;
309 0           $req_uri->path($language_code . $req_uri->path);
310              
311             # so that it strips the language code prefix from $c->req->path
312 0           my $req_base = $c->req->base;
313 0           $req_base->path($req_base->path . $language_code . '/');
314              
315 0 0         if ($config->{redirect_to_language_url}) {
316 0           $c->_language_prefix_debug("redirect to language url '$req_uri'");
317 0           $c->response->redirect( $req_uri );
318 0           return;
319             }
320             else {
321 0           $c->_language_prefix_debug("set language prefix to '$language_code'");
322             }
323             }
324              
325 0           $c->req->_clear_path;
326             }
327             else {
328 0           $c->_language_prefix_debug("path '$req_path' is language independent");
329             }
330              
331 0           $c->set_languages_from_language_prefix($language_code);
332             }
333              
334              
335             =head2 set_languages_from_language_prefix
336              
337             $c->set_languages_from_language_prefix($language_code)
338              
339             Returns: N/A
340              
341             Sets C<< $c->languages >> to C<$language_code>.
342              
343             Called from both L</prepare_path_prefix> and L</switch_language> (ie.
344             always called when C<< $c->languages >> is set by this module).
345              
346             You can wrap this method (using eg. the L<Moose/after> method modifier) so you
347             can store the language code into the stash if you like:
348              
349             after set_languages_from_language_prefix => sub {
350             my $c = shift;
351              
352             $c->stash('language' => $c->language);
353             };
354              
355             =cut
356              
357             sub set_languages_from_language_prefix
358             {
359 0     0 1   my ($c, $language_code) = (shift, @_);
360              
361 0           $language_code = lc $language_code;
362              
363 0           $c->languages([$language_code]);
364             }
365              
366              
367             =head2 uri_for_in_language
368              
369             $c->uri_for_in_language($language_code => @uri_for_args)
370              
371             Returns: C<$uri_object>
372              
373             The same as L<Catalyst/uri_for> but returns the URI with the C<$language_code>
374             path prefix (independently of what the current language is).
375              
376             Internally this method temporarily sets the paths in C<< $c->req >>, calls
377             L<Catalyst/uri_for> then resets the paths. Ineffective, but you usually call it
378             very infrequently.
379              
380             Note: You should not call this method to generate language-independent paths,
381             as it will generate invalid URLs currently (ie. the language independent path
382             prefixed with the language prefix).
383              
384             Note: This module intentionally does not override L<Catalyst/uri_for> but
385             provides this method instead: L<Catalyst/uri_for> is usually called many times
386             per request, and most of the cases you want it to use the current language; not
387             overriding it can be a significant performance saving. YMMV.
388              
389             =cut
390              
391             sub uri_for_in_language
392             {
393 0     0 1   my ($c, $language_code, @uri_for_args) = (shift, @_);
394              
395 0           $language_code = lc $language_code;
396              
397 0           my $scope_guard = $c->_set_language_prefix_temporarily($language_code);
398              
399 0           return $c->uri_for(@uri_for_args);
400             }
401              
402              
403             =head2 switch_language
404              
405             $c->switch_language($language_code)
406              
407             Returns: N/A
408              
409             Changes C<< $c->req->base >> to end with C<$language_code> and calls C<<
410             $c->set_languages_from_language_prefix >> with C<$language_code>.
411              
412             Useful if you want to switch the language later in the request processing (eg.
413             from a request parameter, from the session or from the user object).
414              
415             =cut
416              
417             sub switch_language
418             {
419 0     0 1   my ($c, $language_code) = (shift, @_);
420              
421 0           $language_code = lc $language_code;
422              
423 0           $c->_set_language_prefix($language_code);
424              
425 0           $c->set_languages_from_language_prefix($language_code);
426             }
427              
428              
429             =head2 language_switch_options
430              
431             $c->language_switch_options()
432              
433             Returns: C<< { $language_code => { name => $language_name, uri => $uri }, ... } >>
434              
435             Returns a data structure that contains all the necessary data (language code,
436             name, URL of the same page) for displaying a language switch widget on the
437             page.
438              
439             The data structure is a hashref with one key for each valid language code (see
440             the L</valid_languages> config option) (in all-lowercase format) and the value
441             is a hashref that contains the following key-value pairs:
442              
443             =over
444              
445             =item name
446              
447             The localized (translated) name of the language. (The actual msgid used in C<<
448             $c->loc() >> is the English name of the language, returned by
449             L<I18N::LangTags::List/name>.)
450              
451             =item url
452              
453             The URL of the equivalent of the current page in that language (ie. the
454             language prefix replaced).
455              
456             =back
457              
458             You can find an example TT2 HTML template for the language switch included in
459             the distribution.
460              
461             =cut
462              
463             sub language_switch_options
464             {
465 0     0 1   my ($c) = (shift, @_);
466              
467             return {
468             map {
469 0           $_ => {
470             name => $c->loc(I18N::LangTags::List::name($_)),
471             uri => $c->uri_for_in_language($_ => '/' . $c->req->path, $c->req->params),
472             }
473 0           } map { lc $_ }
474 0           @{ $c->config->{'Plugin::I18N::PathPrefixGeoIP'}->{valid_languages} }
  0            
475             };
476             }
477              
478              
479             =head2 valid_languages
480              
481             $c->valid_languages
482              
483             Returns: Array of valid language codes
484              
485             C<< valid_languages >> returns the language codes you configured in the valid_languages configuration.
486              
487             Useful if you want to go through all valid languages. For example to make a sitemap.
488              
489             =cut
490              
491             sub valid_languages
492             {
493 0     0 1   my ($c) = (shift, @_);
494              
495 0           return @{ $c->config->{'Plugin::I18N::PathPrefixGeoIP'}->{valid_languages} }
  0            
496             }
497              
498             =begin internal
499              
500             $c->_set_language_prefix($language_code)
501              
502             Sets the language to C<$language_code>: Mangles C<< $c->req->uri >> and C<<
503             $c->req->base >>.
504              
505             =end internal
506              
507             =cut
508              
509             sub _set_language_prefix
510             {
511 0     0     my ($c, $language_code) = (shift, @_);
512              
513 0 0         if ($c->req->path !~
514             $c->config->{'Plugin::I18N::PathPrefixGeoIP'}->{language_independent_paths}) {
515 0           my ($actual_base_path) = $c->req->base->path =~ m{ ^ / [^/]+ (.*) $ }x;
516 0           $c->req->base->path($language_code . $actual_base_path);
517              
518 0           my ($actual_uri_path) = $c->req->uri->path =~ m{ ^ / [^/]+ (.*) $ }x;
519 0           $c->req->uri->path($language_code . $actual_uri_path);
520              
521 0           $c->req->_clear_path;
522             }
523             }
524              
525              
526             =begin internal
527              
528             my $scope_guard = $c->_set_language_prefix_temporarily($language_code)
529              
530             Sets the language prefix temporarily (does the same as L</_set_language_prefix>
531             but returns a L<Scope::Guard> instance that resets the these on destruction).
532              
533             =end internal
534              
535             =cut
536              
537             sub _set_language_prefix_temporarily
538             {
539 0     0     my ($c, $language_code) = (shift, @_);
540              
541 0           my $old_req_uri_path = $c->req->uri->path;
542 0           my $old_req_base_path = $c->req->base->path;
543              
544             my $scope_guard = Scope::Guard->new(sub {
545 0     0     $c->req->uri->path($old_req_uri_path);
546 0           $c->req->base->path($old_req_base_path);
547 0           });
548              
549 0           $c->_set_language_prefix($language_code);
550              
551 0           return $scope_guard;
552             }
553              
554              
555             =begin internal
556              
557             $c->_language_prefix_debug($message)
558              
559             Logs C<$message> using C<< $c->log->debug("Plugin::I18N::PathPrefixGeoIP: $message") >> if the
560             L</debug> config option is true.
561              
562             =end internal
563              
564             =cut
565              
566             sub _language_prefix_debug
567             {
568 0     0     my ($c, $message) = (shift, @_);
569              
570             $c->log->debug("Plugin::I18N::PathPrefixGeoIP: $message")
571 0 0         if $c->config->{'Plugin::I18N::PathPrefixGeoIP'}->{debug};
572             }
573              
574             =begin internal
575              
576             _ip2contry($geoip_obj, $ipadress)
577              
578             Find contry for ip
579              
580             =end internal
581              
582             =cut
583              
584             sub _ip2contry {
585 0     0     my ($geoip, $ip) = (@_);
586              
587 0 0         if (!$ip) {return undef;}
  0            
588              
589 0           my $record = $geoip->record_by_addr($ip);
590 0 0         if (!$record) {return undef;}
  0            
591              
592 0           my $geocountry = $record->country_code;
593 0 0         if (!$geocountry) {return undef;}
  0            
594              
595 0           $geocountry = lc($geocountry);
596              
597 0           return $geocountry;
598             }
599              
600             =head1 SEE ALSO
601              
602             L<Catalyst::Plugin::I18N::PathPrefix>, L<Catalyst::Plugin::I18N>, L<Catalyst::TraitFor::Request::PerLanguageDomains>
603              
604             =head1 AUTHOR
605              
606             PathPrefix: Norbert Buchmuller, C<<norbi at nix.hu>>
607             PathPrefixGeoIP: Runar Buvik: C<<runarb at gmail.com>>
608             =head1 TODO
609              
610             =over
611              
612             =item make L</uri_for_in_language> work on language-independent URIs
613              
614             =item support locales instead of language codes
615              
616             =back
617              
618             =head1 BUGS
619              
620             Please report any bugs or feature requests to
621             C<bug-catalyst-plugin-i18n-pathprefix at rt.cpan.org>, or through the web
622             interface at
623             L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Catalyst-Plugin-I18N-PathPrefixGeoIP>.
624             I will be notified, and then you'll automatically be notified of progress on
625             your bug as I make changes.
626              
627             =head1 SUPPORT
628              
629             You can find documentation for this module with the perldoc command.
630              
631             perldoc Catalyst::Plugin::I18N::PathPrefixGeoIP
632              
633             You can also look for information at:
634              
635             =over 4
636              
637             =item * RT: CPAN's request tracker
638              
639             L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Catalyst-Plugin-I18N-PathPrefixGeoIP>
640              
641             =item * AnnoCPAN: Annotated CPAN documentation
642              
643             L<http://annocpan.org/dist/Catalyst-Plugin-I18N-PathPrefixGeoIP>
644              
645             =item * CPAN Ratings
646              
647             L<http://cpanratings.perl.org/d/Catalyst-Plugin-I18N-PathPrefixGeoIP>
648              
649             =item * Search CPAN
650              
651             L<http://search.cpan.org/dist/Catalyst-Plugin-I18N-PathPrefixGeoIP/>
652              
653             =back
654              
655             =head1 ACKNOWLEDGEMENTS
656              
657             Thanks for Larry Leszczynski for the idea of appending the language prefix to
658             C<< $c->req->base >> after it's split off of C<< $c->req->path >>
659             (L<http://dev.catalystframework.org/wiki/wikicookbook/urlpathprefixing>).
660              
661             Thanks for Tomas (t0m) Doran <bobtfish@bobtfish.net> for the code reviews,
662             improvement ideas and mentoring in general.
663              
664             =head1 COPYRIGHT & LICENSE
665              
666             Copyright 2010 Norbert Buchmuller, Runar Buvik, all rights reserved.
667              
668             This program is free software; you can redistribute it and/or modify it
669             under the same terms as Perl itself.
670              
671             =cut
672              
673             1; # End of Catalyst::Plugin::I18N::PathPrefixGeoIP