home *** CD-ROM | disk | FTP | other *** search
/ PC World 2005 December (Special) / PCWorld_2005-12_Special_cd.bin / Bezpecnost / lsti / lsti.exe / framework-2.5.exe / Detect.pm < prev    next >
Text File  |  2005-01-27  |  7KB  |  238 lines
  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!
  238.