lib/I18N/LangTags/Detect.pm

   1
   2 # Time-stamp: "2004-06-20 21:47:55 ADT"
   3
   4 require 5;
   5 package I18N::LangTags::Detect;
   6 use strict;
   7
   8 use vars qw( @ISA $VERSION $MATCH_SUPERS $USING_LANGUAGE_TAGS
   9              $USE_LITERALS $MATCH_SUPERS_TIGHTLY);
  10
  11 BEGIN { unless(defined &DEBUG) { *DEBUG = sub () {0} } }
  12  # define the constant 'DEBUG' at compile-time
  13
  14 $VERSION = "1.03";
  15 @ISA = ();
  16 use I18N::LangTags qw(alternate_language_tags locale2language_tag);
  17
  18 sub _uniq { my %seen; return grep(!($seen{$_}++), @_); }
  19 sub _normalize {
  20   my(@languages) =
  21     map lc($_),
  22     grep $_,
  23     map {; $_, alternate_language_tags($_) } @_;
  24   return _uniq(@languages) if wantarray;
  25   return $languages[0];
  26 }
  27
  28 #---------------------------------------------------------------------------
  29 # The extent of our functional interface:
  30
  31 sub detect () { return __PACKAGE__->ambient_langprefs; }
  32
  33 #===========================================================================
  34
  35 sub ambient_langprefs { # always returns things untainted
  36   my $base_class = $_[0];
  37
  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
  41
  42   # Not running as a CGI: try to puzzle out from the environment
  43   my @languages;
  44
  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";
  48     push @languages,
  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),
  52         # otherwise nix it.
  53
  54       split m/[,:]/,
  55       $ENV{$envname}
  56     ;
  57     last; # first one wins
  58   }
  59
  60   if($ENV{'IGNORE_WIN32_LOCALE'}) {
  61     # no-op
  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;
  66   }
  67   return _normalize @languages;
  68 }
  69
  70 #---------------------------------------------------------------------------
  71
  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?
  76   no integer;
  77
  78   my $in = (@_ > 1) ? $_[1] : $ENV{'HTTP_ACCEPT_LANGUAGE'};
  79   # (always ends up untainting)
  80
  81   return() unless defined $in and length $in;
  82
  83   $in =~ s/\([^\)]*\)//g; # nix just about any comment
  84
  85   if( $in =~ m/^\s*([a-zA-Z][-a-zA-Z]+)\s*$/s ) {
  86     # Very common case: just one language tag
  87     return _normalize $1;
  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 );
  91   }
  92
  93   # Else it's complicated...
  94
  95   $in =~ s/\s+//g;  # Yes, we can just do without the WS!
  96   my @in = $in =~ m/([^,]+)/g;
  97   my %pref;
  98
  99   my $q;
 100   foreach my $tag (@in) {
 101     next unless $tag =~
 102      m/^([a-zA-Z][-a-zA-Z]+)
 103         (?:
 104          ;q=
 105          (
 106           \d*   # a bit too broad of a RE, but so what.
 107           (?:
 108             \.\d+
 109           )?
 110          )
 111         )?
 112        $
 113       /sx
 114     ;
 115     $q = (defined $2 and length $2) ? $2 : 1;
 116     #print "$1 with q=$q\n";
 117     push @{ $pref{$q} }, lc $1;
 118   }
 119
 120   return _normalize(
 121     # Read off %pref, in descending key order...
 122     map @{$pref{$_}},
 123     sort {$b <=> $a}
 124     keys %pref
 125   );
 126 }
 127
 128 #===========================================================================
 129
 130 my %tried = ();
 131   # memoization of whether we've used this module, or found it unusable.
 132
 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
 136
 137   my $module = $_[0];   # ASSUME sane module name!
 138   { no strict 'refs';
 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!
 142   }
 143
 144   print " About to use $module ...\n" if DEBUG;
 145   {
 146     local $SIG{'__DIE__'};
 147     eval "require $module"; # used to be "use $module", but no point in that.
 148   }
 149   if($@) {
 150     print "Error using $module \: $@\n" if DEBUG > 1;
 151     return $tried{$module} = 0;
 152   } else {
 153     print " OK, $module is used\n" if DEBUG;
 154     return $tried{$module} = 1;
 155   }
 156 }
 157
 158 #---------------------------------------------------------------------------
 159 1;
 160 __END__
 161
 162
 163 =head1 NAME
 164
 165 I18N::LangTags::Detect - detect the user's language preferences
 166
 167 =head1 SYNOPSIS
 168
 169   use I18N::LangTags::Detect;
 170   my @user_wants = I18N::LangTags::Detect::detect();
 171
 172 =head1 DESCRIPTION
 173
 174 It is a common problem to want to detect what language(s) the user would
 175 prefer output in.
 176
 177 =head1 FUNCTIONS
 178
 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.
 182
 183 In scalar context, the function returns the most preferred language
 184 tag (or undef if no preference was seen).
 185
 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(...)>
 192 or
 193 C<I18N::LangTags::implicate_supers(...)>, like so:
 194
 195   my @languages =
 196     I18N::LangTags::implicate_supers_tightly(
 197       I18N::LangTags::Detect::detect()
 198     );
 199
 200
 201 =head1 ENVIRONMENT
 202
 203 This module looks for several environment variables, including
 204 REQUEST_METHOD, HTTP_ACCEPT_LANGUAGE,
 205 LANGUAGE, LC_ALL, LC_MESSAGES, and LANG.
 206
 207 It will also use the L<Win32::Locale> module, if it's installed.
 208
 209
 210 =head1 SEE ALSO
 211
 212 L<I18N::LangTags>, L<Win32::Locale>, L<Locale::Maketext>.
 213
 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.)
 216
 217
 218 =head1 COPYRIGHT
 219
 220 Copyright (c) 1998-2004 Sean M. Burke. All rights reserved.
 221
 222 This library is free software; you can redistribute it and/or
 223 modify it under the same terms as Perl itself.
 224
 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
 228 particular purpose.
 229
 230
 231 =head1 AUTHOR
 232
 233 Sean M. Burke C<sburke@cpan.org>
 234
 235 =cut
 236
 237 # a tip: Put a bit of chopped up pickled ginger in your salad. It's tasty!