view release on metacpan or  search on metacpan

LangURI.pm  view on Meta::CPAN

    *Apache::SERVER_ERROR           = \&Apache::Constants::SERVER_ERROR;
    *Apache::HTTP_MOVED_PERMANENTLY = 
      \&Apache::Constants::HTTP_MOVED_PERMANENTLY;
    
    # blech
    *Apache::OR_ALL = *Apache::TAKE1 = *Apache::ITERATE = sub { 1 };

    *handler = \&_handler_1;
  }
}

our @APACHE_MODULE_COMMANDS = (
  {
    name          => IGNORE_REGEX,
    func          => __PACKAGE__ . '::_ignore_regex',
    req_override  => Apache::OR_ALL,
    args_how      => Apache::ITERATE,
    errmsg        => IGNORE_REGEX . ' pattern [pattern ...]',
  },
  {
    name          => DEFAULT_LANG,
    func          => __PACKAGE__ . '::_default_lang',
    req_override  => Apache::OR_ALL,
    args_how      => Apache::TAKE1,
    errmsg        => DEFAULT_LANG . ' language',
  },
  {
    name          => FORCE_LANG,
    func          => __PACKAGE__ . '::_force_lang',
    req_override  => Apache::OR_ALL,
    args_how      => Apache::TAKE1,
    errmsg        => FORCE_LANG . ' yes|no',
  },
  {
    name          => REDIR_PERM,
    func          => __PACKAGE__ . '::_redir_perm',
    req_override  => Apache::OR_ALL,
    args_how      => Apache::TAKE1,
    errmsg        => REDIR_PERM . ' yes|no',
  },
);

our $A2 = LOCALE_CODE_ALPHA_2;
our $A3 = LOCALE_CODE_ALPHA_3;

sub _ignore_regex { 
  $PARAMS{&IGNORE_REGEX} ||= [];
  my $neg = $_[2] !~ s/^!// || 0;
  my $re = eval { qr{$_[2]} };
  die "Invalid regular expression $_[2]" if ($@);
  push @{$PARAMS{&IGNORE_REGEX}}, sub { $neg == scalar(shift =~ $re) };
}

sub _default_lang { $PARAMS{&DEFAULT_LANG}  =  $_[2]                         }
sub _force_lang   { $PARAMS{&FORCE_LANG}    = ($_[2] =~ /^(1|true|on|yes)$/) }
sub _redir_perm   { $PARAMS{&REDIR_PERM}    = ($_[2] =~ /^(1|true|on|yes)$/) }

sub _handler {
my $r = shift;
  if ($r->is_initial_req) {
    $r->verify_config;
    for my $ignore (@{$PARAMS{&IGNORE_REGEX}}) {
      if ($ignore->($r->uri)) {
        $r->log->debug
          (sprintf("Ignoring %s that matches ignore regex.", $r->uri));
        return Apache::DECLINED;
      }
    }
    $r->set_accept_language;
    return $r->perform_redirection;
  }
  return Apache::DECLINED;
}

sub _handler_1 ($$) {
  my $r = bless { r => $_[1] }, $_[0];
  return $r->_handler;
}

sub _handler_2 : method {
  my $r = bless { r => $_[1] }, $_[0];
  return $r->_handler;
}

sub verify_config {
  my $r = shift;
  $PARAMS{&DEFAULT_LANG} ||= $r->dir_config->get(DEFAULT_LANG);
  for my $bit (FORCE_LANG, REDIR_PERM) {
    my $cfg = $r->dir_config->get($bit) || '';
    $PARAMS{$bit} ||= scalar($cfg =~ /^(1|true|on|yes)$/i);
  }
  map { _ignore_regex(undef,undef,$_) } $r->dir_config->get(IGNORE_REGEX)
    unless @{$PARAMS{&IGNORE_REGEX}};
}

sub get_accept_language {
  my $r   = shift;

  my $hdr = $r->headers_in->get('Accept-Language');
  return Apache::DECLINED unless $hdr;

  # acquire hash of from the Accept-Language header
  my %accept;
  my $seen = 0;
  for (split(/\s*,\s*/, $hdr)) {
    my ($key, @vals) = split /\s*;\s*/;
    $key =~ tr/A-Z_/a-z-/;
    $accept{$key} ||= {};
    unless (@vals) {
      # decrement quality assessment just a bit to indicate order
      $accept{$key}{q} = 1 - ++$seen / 10000;
      #$r->log->debug("$key => '1.0'");
    }
    my $seenq = 0;
    for (@vals) {
      my ($k, $v) = split /\s*=\s*/;
      # some user agents use qs :P
      if ($k =~ /^qs?$/) {
        # no mucking about if the client sent us more than one q parameter.
        next if $seenq;
        $v = 1 - ++$seen / 10000 if (!defined $v or $v eq '' or $v > 1);
        $v = 0 if ($v < 0);
        $accept{$key}{q}  = $v;
        #$r->log->debug("$key => '$v'");
        $seenq = 1;
      }
      else {
        $accept{$key}{$k} = $v;
        #$r->log->debug("$key => '$v'");
      }
    }
  }
  $r->{accept_langs} = \%accept;
  return Apache::OK;
}

sub translate_uri_path {
  my $r = shift;

  $r->get_accept_language unless defined $r->{accept_langs};

  # walk the url path looking for language tags.
  # future note: check for actual on-disk entities corresponding to 
  # language tags via subrequests