This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
As 2/3rds (or 3/4s) of the SV head structure is rewritten, it doesn't
[perl5.git] / lib / I18N / LangTags / Detect.pm
CommitLineData
8000a3fa
RGS
1
2# Time-stamp: "2004-03-30 17:28:24 AST"
3
4require 5;
5package I18N::LangTags::Detect;
6use strict;
7
8use vars qw( @ISA $VERSION $MATCH_SUPERS $USING_LANGUAGE_TAGS
9 $USE_LITERALS $MATCH_SUPERS_TIGHTLY);
10
11BEGIN { unless(defined &DEBUG) { *DEBUG = sub () {0} } }
12 # define the constant 'DEBUG' at compile-time
13
14$VERSION = "1.01";
15@ISA = ();
16use I18N::LangTags qw(alternate_language_tags locale2language_tag);
17
18sub uniq { my %seen; return grep(!($seen{$_}++), @_); }
19
20#---------------------------------------------------------------------------
21# The extent of our functional interface:
22
23sub detect () { return __PACKAGE__->ambient_langprefs; }
24
25#===========================================================================
26
27sub ambient_langprefs { # always returns things untainted
28 my $base_class = $_[0];
29
30 return $base_class->http_accept_langs
31 if length( $ENV{'REQUEST_METHOD'} || '' ); # I'm a CGI
32 # it's off in its own routine because it's complicated
33
34 # Not running as a CGI: try to puzzle out from the environment
35 my @languages;
36
37 foreach my $envname (qw( LANGUAGE LC_ALL LC_MESSAGES LANG )) {
38 next unless $ENV{$envname};
39 DEBUG and print "Noting \$$envname: $ENV{$envname}\n";
40 push @languages,
41 map locale2language_tag($_),
42 # if it's a lg tag, fine, pass thru (untainted)
43 # if it's a locale ID, try converting to a lg tag (untainted),
44 # otherwise nix it.
45
46 split m/[,:]/,
47 $ENV{$envname}
48 ;
49 last; # first one wins
50 }
51
52 if(&_try_use('Win32::Locale')) {
53 # If we have that module installed...
54 push @languages, Win32::Locale::get_language() || ''
55 if defined &Win32::Locale::get_language;
56 }
57
58 @languages = map {; $_, alternate_language_tags($_) } @languages;
59
60 return uniq(@languages) if wantarray;
61 return $languages[0];
62}
63
64#---------------------------------------------------------------------------
65
66sub http_accept_langs {
67 # Deal with HTTP "Accept-Language:" stuff. Hassle.
68 # This code is more lenient than RFC 3282, which you must read.
69 # Hm. Should I just move this into I18N::LangTags at some point?
70 no integer;
71
72 my $in = (@_ > 1) ? $_[1] : $ENV{'HTTP_ACCEPT_LANGUAGE'};
73 # (always ends up untainting)
74
75 return() unless defined $in and length $in;
76
77 $in =~ s/\([^\)]*\)//g; # nix just about any comment
78
79 if( $in =~ m/^\s*([a-zA-Z][-a-zA-Z]+)\s*$/s ) {
80 # Very common case: just one language tag
81 return lc $1;
82 } elsif( $in =~ m/^\s*[a-zA-Z][-a-zA-Z]+(?:\s*,\s*[a-zA-Z][-a-zA-Z]+)*\s*$/s ) {
83 # Common case these days: just "foo, bar, baz"
84 return map lc($_), $in =~ m/([a-zA-Z][-a-zA-Z]+)/g;
85 }
86
87 # Else it's complicated...
88
89 $in =~ s/\s+//g; # Yes, we can just do without the WS!
90 my @in = $in =~ m/([^,]+)/g;
91 my %pref;
92
93 my $q;
94 foreach my $tag (@in) {
95 next unless $tag =~
96 m/^([a-zA-Z][-a-zA-Z]+)
97 (?:
98 ;q=
99 (
100 \d* # a bit too broad of a RE, but so what.
101 (?:
102 \.\d+
103 )?
104 )
105 )?
106 $
107 /sx
108 ;
109 $q = (defined $2 and length $2) ? $2 : 1;
110 #print "$1 with q=$q\n";
111 push @{ $pref{$q} }, lc $1;
112 }
113
114 return # Read off %pref, in descending key order...
115 map @{$pref{$_}},
116 sort {$b <=> $a}
117 keys %pref;
118}
119
120#===========================================================================
121
122my %tried = ();
123 # memoization of whether we've used this module, or found it unusable.
124
125sub _try_use { # Basically a wrapper around "require Modulename"
126 # "Many men have tried..." "They tried and failed?" "They tried and died."
127 return $tried{$_[0]} if exists $tried{$_[0]}; # memoization
128
129 my $module = $_[0]; # ASSUME sane module name!
130 { no strict 'refs';
131 return($tried{$module} = 1)
132 if defined(%{$module . "::Lexicon"}) or defined(@{$module . "::ISA"});
133 # weird case: we never use'd it, but there it is!
134 }
135
136 print " About to use $module ...\n" if DEBUG;
137 {
138 local $SIG{'__DIE__'};
139 eval "require $module"; # used to be "use $module", but no point in that.
140 }
141 if($@) {
142 print "Error using $module \: $@\n" if DEBUG > 1;
143 return $tried{$module} = 0;
144 } else {
145 print " OK, $module is used\n" if DEBUG;
146 return $tried{$module} = 1;
147 }
148}
149
150#---------------------------------------------------------------------------
1511;
152__END__
153
154
155=head1 NAME
156
157I18N::LangTags::Detect - detect the user's language preferences
158
159=head1 SYNOPSIS
160
161 use I18N::LangTags::Detect;
162 my @user_wants = I18N::LangTags::Detect::detect();
163
164=head1 DESCRIPTION
165
166It is a common problem to want to detect what language(s) the user would
167prefer output in.
168
169=head1 FUNCTIONS
170
171This module defines one public function,
172C<I18N::LangTags::Detect::detect()>. This function is not exported
173(nor is even exportable), and it takes no parameters.
174
175In scalar context, the function returns the most preferred language
176tag (or undef if no preference was seen).
177
178In list context (which is usually what you want),
179the function returns a
180(possibly empty) list of language tags representing (best first) what
181languages the user apparently would accept output in. You will
182probably want to pass the output of this through
183C<I18N::LangTags::implicate_supers_tightly(...)>
184or
185C<I18N::LangTags::implicate_supers(...)>, like so:
186
187 my @languages =
188 I18N::LangTags::implicate_supers_tightly(
189 I18N::LangTags::Detect::detect()
190 );
191
192
193=head1 ENVIRONMENT
194
195This module looks for several environment variables, including
196REQUEST_METHOD, HTTP_ACCEPT_LANGUAGE,
197LANGUAGE, LC_ALL, LC_MESSAGES, and LANG.
198
199It will also use the L<Win32::Locale> module, if it's installed.
200
201
202=head1 SEE ALSO
203
204L<I18N::LangTags>, L<Win32::Locale>, L<Locale::Maketext>.
205
206(This module's core code started out as a routine in Locale::Maketext;
207but I moved it here once I realized it was more generally useful.)
208
209
210=head1 COPYRIGHT
211
212Copyright (c) 1998-2004 Sean M. Burke. All rights reserved.
213
214This library is free software; you can redistribute it and/or
215modify it under the same terms as Perl itself.
216
217The programs and documentation in this dist are distributed in
218the hope that they will be useful, but without any warranty; without
219even the implied warranty of merchantability or fitness for a
220particular purpose.
221
222
223=head1 AUTHOR
224
225Sean M. Burke C<sburke@cpan.org>
226
227=cut
228
229# a tip: Put a bit of chopped up pickled ginger in your salad. It's tasty!