2 # Time-stamp: "2004-06-20 21:47:55 ADT"
5 package I18N::LangTags::Detect;
8 use vars qw( @ISA $VERSION $MATCH_SUPERS $USING_LANGUAGE_TAGS
9 $USE_LITERALS $MATCH_SUPERS_TIGHTLY);
11 BEGIN { unless(defined &DEBUG) { *DEBUG = sub () {0} } }
12 # define the constant 'DEBUG' at compile-time
16 use I18N::LangTags qw(alternate_language_tags locale2language_tag);
18 sub _uniq { my %seen; return grep(!($seen{$_}++), @_); }
23 map {; $_, alternate_language_tags($_) } @_;
24 return _uniq(@languages) if wantarray;
28 #---------------------------------------------------------------------------
29 # The extent of our functional interface:
31 sub detect () { return __PACKAGE__->ambient_langprefs; }
33 #===========================================================================
35 sub ambient_langprefs { # always returns things untainted
36 my $base_class = $_[0];
38 return $base_class->http_accept_langs
39 if length( $ENV{'REQUEST_METHOD'} || '' ); # I'm a CGI
40 # it's off in its own routine because it's complicated
42 # Not running as a CGI: try to puzzle out from the environment
45 foreach my $envname (qw( LANGUAGE LC_ALL LC_MESSAGES LANG )) {
46 next unless $ENV{$envname};
47 DEBUG and print "Noting \$$envname: $ENV{$envname}\n";
49 map locale2language_tag($_),
50 # if it's a lg tag, fine, pass thru (untainted)
51 # if it's a locale ID, try converting to a lg tag (untainted),
57 last; # first one wins
60 if($ENV{'IGNORE_WIN32_LOCALE'}) {
62 } elsif(&_try_use('Win32::Locale')) {
63 # If we have that module installed...
64 push @languages, Win32::Locale::get_language() || ''
65 if defined &Win32::Locale::get_language;
67 return _normalize @languages;
70 #---------------------------------------------------------------------------
72 sub http_accept_langs {
73 # Deal with HTTP "Accept-Language:" stuff. Hassle.
74 # This code is more lenient than RFC 3282, which you must read.
75 # Hm. Should I just move this into I18N::LangTags at some point?
78 my $in = (@_ > 1) ? $_[1] : $ENV{'HTTP_ACCEPT_LANGUAGE'};
79 # (always ends up untainting)
81 return() unless defined $in and length $in;
83 $in =~ s/\([^\)]*\)//g; # nix just about any comment
85 if( $in =~ m/^\s*([a-zA-Z][-a-zA-Z]+)\s*$/s ) {
86 # Very common case: just one language tag
88 } elsif( $in =~ m/^\s*[a-zA-Z][-a-zA-Z]+(?:\s*,\s*[a-zA-Z][-a-zA-Z]+)*\s*$/s ) {
89 # Common case these days: just "foo, bar, baz"
90 return _normalize( $in =~ m/([a-zA-Z][-a-zA-Z]+)/g );
93 # Else it's complicated...
95 $in =~ s/\s+//g; # Yes, we can just do without the WS!
96 my @in = $in =~ m/([^,]+)/g;
100 foreach my $tag (@in) {
102 m/^([a-zA-Z][-a-zA-Z]+)
106 \d* # a bit too broad of a RE, but so what.
115 $q = (defined $2 and length $2) ? $2 : 1;
116 #print "$1 with q=$q\n";
117 push @{ $pref{$q} }, lc $1;
121 # Read off %pref, in descending key order...
128 #===========================================================================
131 # memoization of whether we've used this module, or found it unusable.
133 sub _try_use { # Basically a wrapper around "require Modulename"
134 # "Many men have tried..." "They tried and failed?" "They tried and died."
135 return $tried{$_[0]} if exists $tried{$_[0]}; # memoization
137 my $module = $_[0]; # ASSUME sane module name!
139 return($tried{$module} = 1)
140 if defined(%{$module . "::Lexicon"}) or defined(@{$module . "::ISA"});
141 # weird case: we never use'd it, but there it is!
144 print " About to use $module ...\n" if DEBUG;
146 local $SIG{'__DIE__'};
147 eval "require $module"; # used to be "use $module", but no point in that.
150 print "Error using $module \: $@\n" if DEBUG > 1;
151 return $tried{$module} = 0;
153 print " OK, $module is used\n" if DEBUG;
154 return $tried{$module} = 1;
158 #---------------------------------------------------------------------------
165 I18N::LangTags::Detect - detect the user's language preferences
169 use I18N::LangTags::Detect;
170 my @user_wants = I18N::LangTags::Detect::detect();
174 It is a common problem to want to detect what language(s) the user would
179 This module defines one public function,
180 C<I18N::LangTags::Detect::detect()>. This function is not exported
181 (nor is even exportable), and it takes no parameters.
183 In scalar context, the function returns the most preferred language
184 tag (or undef if no preference was seen).
186 In list context (which is usually what you want),
187 the function returns a
188 (possibly empty) list of language tags representing (best first) what
189 languages the user apparently would accept output in. You will
190 probably want to pass the output of this through
191 C<I18N::LangTags::implicate_supers_tightly(...)>
193 C<I18N::LangTags::implicate_supers(...)>, like so:
196 I18N::LangTags::implicate_supers_tightly(
197 I18N::LangTags::Detect::detect()
203 This module looks for several environment variables, including
204 REQUEST_METHOD, HTTP_ACCEPT_LANGUAGE,
205 LANGUAGE, LC_ALL, LC_MESSAGES, and LANG.
207 It will also use the L<Win32::Locale> module, if it's installed.
212 L<I18N::LangTags>, L<Win32::Locale>, L<Locale::Maketext>.
214 (This module's core code started out as a routine in Locale::Maketext;
215 but I moved it here once I realized it was more generally useful.)
220 Copyright (c) 1998-2004 Sean M. Burke. All rights reserved.
222 This library is free software; you can redistribute it and/or
223 modify it under the same terms as Perl itself.
225 The programs and documentation in this dist are distributed in
226 the hope that they will be useful, but without any warranty; without
227 even the implied warranty of merchantability or fitness for a
233 Sean M. Burke C<sburke@cpan.org>
237 # a tip: Put a bit of chopped up pickled ginger in your salad. It's tasty!