File Coverage

blib/lib/Catalyst/Plugin/Redirect.pm

Criterion	Covered	Total	%
statement	3	21	14.2
branch	0	6	0.0
condition	0	2	0.0
subroutine	1	3	33.3
pod	2	2	100.0
total	6	34	17.6

package Catalyst::Plugin::Redirect;

use strict;

our $VERSION = '0.02';

my($Revision) = '$Id: Redirect.pm,v 1.4 2006/01/07 13:44:47 Sho Exp $';



=head1 NAME

Catalyst::Plugin::Redirect - Redirect for Catalyst used easily is offered.

=head1 SYNOPSIS

  use Catalyst 'Redirect';

  $c->get_baseurl;

  $c->redirect('redirect_url');
  $c->redirect('/redirect_url');
  $c->redirect('http://www.perl.org/');


=head1 DESCRIPTION

Redirect for Catalyst used easily is offered.

=head1 METHODS

=over 2

=item get_baseurl

Basic URL of your application is returned.
If your application is executed by "http://myhost/myapp/"
it returns "/myapp/" .

=back

=cut

sub get_baseurl {
    my $c = shift;
    my $base = $c->req->base;
    my $host = $c->req->base->host;
    my $port = $c->req->base->port;
    $base =~ s!^https?://$host:$port!!;
    $base =~ s!^https?://$host!!;
    return $base;
}

=over 2

=item redirect

$c->redirect('redirect_url');
$c->res->redirect('redirect_url') is executed.

$c->redirect('/redirect_url');
$c->res->redirect($c->get_baseurl.'redirect_url') is executed.

$c->redirect('http://www.perl.org/');
$c->res->redirect('http://www.perl.org/') is executed.

=back

=cut

sub redirect {
    my $c = shift;

    if (@_) {
	my $location = shift;
	my $status   = shift || 302;
	if ($location =~ m!^https?://!) {
	    return $c->res->redirect($location,$status);
	} elsif ($location =~ m!^/!) {
	    my $base = $c->get_baseurl;
	    $location = $base . $location;
	    $location =~ s!//!/!g;
	    return $c->res->redirect($location, $status);
	} else {
	    return $c->res->redirect($location,$status);
	}
    }
}

=BUGS

When Reverse Proxy is used, get_baseurl returns the backend server's base.
For example, "/" will be returned when http://www.mydomain.com/myapp/ is a proxy for http://appserver.local.server/.

=head1 SEE ALSO

L<Catalyst>

=head1 AUTHOR

Shota Takayama, C<shot[atmark]bindstorm.jp>

=head1 COPYRIGHT AND LICENSE

This program is free software, you can redistribute it and/or modify it under
the same terms as Perl itself.

=cut


1;