File Coverage

blib/lib/Plack/Middleware/Redirect.pm

Criterion	Covered	Total	%
statement	18	51	35.2
branch	0	14	0.0
condition	0	5	0.0
subroutine	6	9	66.6
pod	2	2	100.0
total	26	81	32.1

package Plack::Middleware::Redirect;
use 5.008001;
use strict;
use warnings;
use Carp qw/croak/;

use parent 'Plack::Middleware';

our $VERSION = "0.01";

use Plack::Util::Accessor qw/url_patterns/;

my $BODY = {
    301 => "Moved Permanently",
    302 => "Found"
};

sub prepare_app {
    my $self = shift;
    my $url_patterns = $self->url_patterns;

    for (my $i = 0; $i < scalar(@$url_patterns); $i += 2) {
        my ($from, $to) = _fetch_url_pattern($url_patterns, $i);

        my $type = ref $from;
        if ($type ne 'Regexp' && $type ne "") {
            croak "$from is invalid parameter";
        }
        if ($type ne 'Regexp') {
            $url_patterns->[$i] = qr/$from/;
        }
    }

}

sub call {
    my ($self, $env) = @_;

    my $url_patterns = $self->url_patterns;

    my $path = $env->{PATH_INFO};
    my $body = "";

    for ( my $i = 0; $i < scalar(@$url_patterns); $i += 2 ) {
        my ($from, $to) = _fetch_url_pattern($url_patterns, $i);

        next unless $path =~ m#$from#;

        my $type = ref $to;

        if ($type ne 'ARRAY') {
            my $to = [$to, 301];
        }

        my ($to_path, $status_code) = @$to;
        $type = ref $to_path;
        if ($type eq 'CODE') {
            $path = &$to_path($env, $from);
        }
        else {
            $path =~ s#$from#"\"$to_path\""#iee;
        }
        my $query = $env->{QUERY_STRING};
        if ($query) {
            $path .= $path =~ /\?/
                ? '&' . $query
                : '?' . $query;
        }
        my $body = $BODY->{$status_code} || "";
        return [$status_code, ['Location' => $path], [$body] ];
    }

    return $self->app->($env);
}


sub _fetch_url_pattern {
    my ($url_patterns, $i) = @_;
    return ($url_patterns->[$i], $url_patterns->[$i+1]);
}

1;
__END__