[ Index ]

PHP Cross Reference of Unnamed Project

title

Body

[close]

/se3-unattended/var/se3/unattended/install/linuxaux/opt/perl/lib/5.10.0/I18N/LangTags/ -> Detect.pm (source)

   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!


Generated: Tue Mar 17 22:47:18 2015 Cross-referenced by PHPXref 0.7.1