File Coverage

blib/lib/Plack/Middleware/ExtractUriLanguage.pm

Criterion	Covered	Total	%
statement	53	53	100.0
branch	11	12	91.6
condition	10	14	71.4
subroutine	10	10	100.0
pod	2	2	100.0
total	86	91	94.5

#
# This file is part of Plack-Middleware-ExtractUriLanguage
#
# This software is Copyright (c) 2013 by BURNERSK.
#
# This is free software, licensed under:
#
#   The Artistic License 2.0 (GPL Compatible)
#
package Plack::Middleware::ExtractUriLanguage;
use strict;
use warnings FATAL => 'all';
use utf8;

BEGIN {
  our $VERSION = '0.004'; # VERSION
}

use parent 'Plack::Middleware';
use Plack::Util::Accessor qw(
  ExtractUriLanguageOrig
  ExtractUriLanguageTag
  ExtractUriLanguageList
);
use Plack::Middleware::ExtractUriLanguage::Type ':all';

############################################################################
# Called once.
sub prepare_app {
  my ($self) = @_;

  # Precompose language tag regex.
  if ( my $list = $self->ExtractUriLanguageList ) {
    if ( defined $list && ref($list) ne 'ARRAY' ) {
      my ( $package, $filename, $line ) = caller(6);
      die sprintf "ExtractUriLanguageList is not an array reference at %s line %s.\n", $filename, $line;
    }
    elsif ( defined $list ) {
      my $list_qm = join q{|}, map { quotemeta } @{$list};
      $self->{extracturilanguage_list_qr} = [
        qr{^/($list_qm)/?$},
        qr{^/($list_qm)/(.*)$},
      ];
    }
  }
  if ( !$self->{extracturilanguage_list_qr} ) {
    $self->{extracturilanguage_list_qr} = [
      qr{^/([[:alpha:]]{2}(?:\-[[:alpha:]]{2})?)/?$},
      qr{^/([[:alpha:]]{2}(?:\-[[:alpha:]]{2})?)/(.*)$},
    ];
  }

  return;
}

############################################################################
# Called on every reqeust.
sub call {
  my ( $self, $env ) = @_;
  my $language_tag;
  my $orig_name = $self->ExtractUriLanguageOrig || $DEFAULT_PATH_INFO_ORIG_FIELD;
  my $tag_name  = $self->ExtractUriLanguageTag  || $DEFAULT_LANGUAGE_TAG_FIELD;
  my $list      = $self->ExtractUriLanguageList || undef;
  my $path_info = $env->{$PATH_INFO_FIELD}; # is "/en-us/some-site" when "http://example.com/en-us/some-site".

  my ( $qr1, $qr2 ) = @{ $self->{extracturilanguage_list_qr} };
  if ( $path_info =~ $qr1 || $path_info =~ $qr2 ) {
    my ( $tag, $uri ) = ( $1, $2 );
    {
      no warnings 'uninitialized';
      $uri = "/$uri";
    }
    $language_tag = $tag;
    $path_info    = $uri;
  }

  # Manipulate environment only when a language tag was identified.
  if ($language_tag) {
    $env->{$tag_name}        = $language_tag;             # The language tag wich was found.
    $env->{$orig_name}       = $env->{$PATH_INFO_FIELD};  # The original PATH_INFO.
    $env->{$PATH_INFO_FIELD} = $path_info;                # The new manupulated PATH_INFO.
  }

  # Dispatch request to application.
  return $self->app->($env);
}

############################################################################
1;
__END__