File Coverage

blib/lib/HTTP/ClientDetect/Language.pm
Criterion Covered Total %
statement 73 74 98.6
branch 27 32 84.3
condition 5 7 71.4
subroutine 10 10 100.0
pod 4 4 100.0
total 119 127 93.7


line stmt bran cond sub pod time code
1             package HTTP::ClientDetect::Language;
2              
3 2     2   6020 use 5.006;
  2         5  
  2         66  
4 2     2   7 use strict;
  2         4  
  2         63  
5 2     2   7 use warnings FATAL => 'all';
  2         2  
  2         76  
6 2     2   532 use Moo;
  2         15330  
  2         14  
7              
8 2     2   2392 use Locale::Language;
  2         440220  
  2         146  
9 2     2   1051 use Locale::Country;
  2         38525  
  2         1648  
10              
11             my @languages = all_language_codes();
12             my @countries = all_country_codes();
13              
14             my %langs = map { $_ => 1 } @languages;
15             my %countrs = map { $_ => 1 } @countries;
16              
17             =head1 NAME
18              
19             HTTP::ClientDetect::Language - Lookup the client's preferred language
20              
21             =head1 VERSION
22              
23             Version 0.01
24              
25             =cut
26              
27             our $VERSION = '0.01';
28              
29              
30             =head1 SYNOPSIS
31              
32             use HTTP::ClientDetect::Language;
33             my $lang_detect = HTTP::ClientDetect::Language->new(server_default => "en_US");
34             # inside a Dancer route
35             get '/detect' => sub {
36             my $req = request;
37             my $lang = $lang_detect->language($req);
38             }
39              
40              
41             =head1 ACCESSORS
42              
43             =head2 server_default
44              
45             The C should be set in the constructor and defaults to
46             C. This will be always returned if the lookup fails
47              
48             =cut
49              
50              
51             has server_default => (is => 'rw',
52             default => sub { return "en_US" },
53             isa => sub {
54             die "Bad language $_[0]\n"
55             unless __PACKAGE__->check_language_name($_[0]);
56             });
57              
58              
59             =head2 available_languages
60              
61             Accessor to an arrayref of languages available on the server side.
62             Please use the short version (C, not C), otherwise the
63             check will be too restrictive.
64              
65             =cut
66              
67             has available_languages => (is => 'rw',
68             isa => sub {
69             my $aref = $_[0];
70             die "Not an arrayref" unless ref($aref) eq 'ARRAY';
71             foreach my $l (@$aref) {
72             die "Bad language $l\n"
73             unless __PACKAGE__->check_language_name($l);
74             }
75             },
76             default => sub { [] },
77             );
78              
79              
80             =head1 SUBROUTINES/METHODS
81              
82             =head2 language($request_obj)
83              
84             Return the preferred language of the request. The request object
85             should an object which has the methods C or C
86              
87             From L:
88              
89             The Accept-Language request-header field is similar to Accept, but
90             restricts the set of natural languages that are preferred as a
91             response to the request. Language tags are defined in section 3.10.
92              
93             Accept-Language = "Accept-Language" ":"
94             1#( language-range [ ";" "q" "=" qvalue ] )
95             language-range = ( ( 1*8ALPHA *( "-" 1*8ALPHA ) ) | "*" )
96              
97             Each language-range MAY be given an associated quality value which
98             represents an estimate of the user's preference for the languages
99             specified by that range. The quality value defaults to "q=1". For
100             example,
101              
102             Accept-Language: da, en-gb;q=0.8, en;q=0.7
103              
104             would mean: "I prefer Danish, but will accept British English and
105             other types of English." A language-range matches a language-tag if
106             it exactly equals the tag, or if it exactly equals a prefix of the
107             tag such that the first tag character following the prefix is "-".
108             The special range "*", if present in the Accept-Language field,
109             matches every tag not matched by any other range present in the
110             Accept-Language field.
111              
112             Note: This use of a prefix matching rule does not imply that
113             language tags are assigned to languages in such a way that it is
114             always true that if a user understands a language with a certain
115             tag, then this user will also understand all languages with tags
116             for which this tag is a prefix. The prefix rule simply allows the
117             use of prefix tags if this is the case.
118              
119             The language quality factor assigned to a language-tag by the
120             Accept-Language field is the quality value of the longest language-
121             range in the field that matches the language-tag. If no language-
122             range in the field matches the tag, the language quality factor
123             assigned is 0. If no Accept-Language header is present in the
124             request, the server
125              
126             SHOULD assume that all languages are equally acceptable. If an
127             Accept-Language header is present, then all languages which are
128             assigned a quality factor greater than 0 are acceptable.
129              
130             It might be contrary to the privacy expectations of the user to send
131             an Accept-Language header with the complete linguistic preferences
132             of the user in every request
133              
134             =cut
135              
136             sub language {
137 60     60 1 233 my ($self, $obj) = @_;
138 60         127 my @browser_langs = $self->browser_languages($obj);
139 60         590 my @avail = @{$self->available_languages};
  60         1493  
140 60 100       847 if (@avail) {
141 36         52 foreach my $ua_lang (@browser_langs) {
142 97         95 foreach my $avail_lang (@avail) {
143 117 100       1158 if ($ua_lang =~ m/^\Q$avail_lang\E(_[A-Z]+)?$/) {
144 13         81 return $ua_lang;
145             }
146             }
147             }
148             # nothing? then return the server default
149 23         435 return $self->server_default;
150             }
151             else {
152 24         77 return $browser_langs[0];
153             }
154             }
155              
156             =head2 browser_languages($request)
157              
158             This method returns the parsed and sorted list of language preferences
159             set in the browser, when the first element has higher priority.
160              
161             =cut
162              
163             sub browser_languages {
164 60     60 1 68 my ($self, $obj) = @_;
165 60 50       138 return $self->server_default unless $obj;
166 60         56 my $accept_str;
167 60 50       262 if ($obj->can("accept_language")) {
168 60         149 $accept_str = $obj->accept_language;
169             }
170             # nothing? try with header, but don't count too much on this
171 60 50 33     151 if (!$accept_str and $obj->can("header")) {
172 0         0 $accept_str = $obj->header('Accept-Language');
173             }
174 60 50       102 return $self->server_default unless $accept_str;
175            
176             # split the string at ,
177 60         504 my @langs = split(/\s*,\s*/, $accept_str);
178 60         81 my @to_order;
179 60         87 foreach my $lang_str (@langs) {
180 235 100       346 next unless $lang_str;
181 190         157 my ($q, $code);
182 190 100       850 if ($lang_str =~ m/([a-zA-Z]+([-_][a-zA-Z]+)?)\s*(;\s*q\s*=\s*([0-9\.]+))?/) {
183 180         333 $code = $self->check_language_name($1);
184 180   100     554 $q = $4 || 1;
185             }
186 190 100       292 next unless $code;
187 165         649 push @to_order, [ $code => $q ];
188             # sort by q
189             }
190 60 100       345 return $self->server_default unless @to_order;
191 50         161 my @ordered = sort { $b->[1] <=> $a->[1] } @to_order;
  170         407  
192 50         74 return map { $_->[0] } @ordered;
  165         453  
193             }
194              
195             =head3 language_short($request_obj)
196              
197             Return the short language version (i.e.), the language name without
198             the country part.
199              
200             =cut
201              
202             sub language_short {
203 36     36 1 7246 my ($self, $obj) = @_;
204 36         70 my $lang = $self->language($obj);
205             # strip the second part
206 36         192 $lang =~ s/_.*$//;
207 36         173 return $lang;
208             }
209              
210              
211             =head3 check_language_name
212              
213             Returns a normalized version of the language name, lower case for the
214             language, upper case for the country. Undef it was not possible to
215             validate it.
216              
217             =cut
218              
219             sub check_language_name {
220 188     188 1 357 my ($self, $code) = @_;
221 188         180 my ($lang, $country);
222 188 50       306 return unless $code;
223 188 100       556 if ($code =~ m/([a-zA-Z]{2})([_-]([a-zA-Z]*))?/) {
224 183         265 $lang = $1;
225 183   100     645 $country = $3 || "";
226             }
227             else {
228 5         8 $lang = $code;
229 5         7 $country = $code; # eg. fr fr
230             }
231             # lowercase;
232 188         236 $lang = lc($lang);
233 188         170 $country = lc($country);
234             # check the lang;
235 188 100       436 return unless $langs{$lang};
236             # if the country doesn't validate, we fix the common scenario (en
237             # => US), and append the same
238 171 100       318 if ($countrs{$country}) {
239 46         144 return $lang . "_" . uc($country);
240             }
241             # then do some heuristics, if the country didn't match
242 125 100       231 if ($lang eq 'en') {
243 45         118 return $lang . "_US";
244             }
245             # then try the language as a country
246 80 100       151 if ($countrs{$lang}) {
247 50         233 return $lang . "_" . uc($lang);
248             }
249             # if we are still here, return the language, there are cases we
250             # can't catch, like ja_JP
251 30         63 return $lang;
252             }
253              
254              
255             =head1 AUTHOR
256              
257             Marco Pessotto, C<< >>
258              
259             =head1 BUGS
260              
261             Please report any bugs or feature requests to C, or through
262             the web interface at L. I will be notified, and then you'll
263             automatically be notified of progress on your bug as I make changes.
264              
265              
266              
267              
268             =head1 SUPPORT
269              
270             You can find documentation for this module with the perldoc command.
271              
272             perldoc HTTP::ClientDetect::Language
273              
274              
275             You can also look for information at:
276              
277             =over 4
278              
279             =item * RT: CPAN's request tracker (report bugs here)
280              
281             L
282              
283             =item * AnnoCPAN: Annotated CPAN documentation
284              
285             L
286              
287             =item * CPAN Ratings
288              
289             L
290              
291             =item * Search CPAN
292              
293             L
294              
295             =back
296              
297              
298             =head1 ACKNOWLEDGEMENTS
299              
300              
301             =head1 LICENSE AND COPYRIGHT
302              
303             Copyright 2013 Marco Pessotto.
304              
305             This program is free software; you can redistribute it and/or modify it
306             under the terms of either: the GNU General Public License as published
307             by the Free Software Foundation; or the Artistic License.
308              
309             See L for more information.
310              
311              
312             =cut
313              
314             1; # End of HTTP::ClientDetect::Language