The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
#!/usr/bin/perl

use strict;
use warnings;

use Test::More tests => 28;
use Test::MockObject::Extends;
use URI;

my $m;
BEGIN { use_ok( $m = "Catalyst::Plugin::Session::State::URI" ) }

{
    package HashObj;
    use base qw/Class::Accessor/;
    __PACKAGE__->mk_accessors(qw/body path base content_type status/);
}

my $req = Test::MockObject::Extends->new( HashObj->new );
$req->base( URI->new( "http://myapp/" ) );

my $res = Test::MockObject::Extends->new( HashObj->new );

my $cxt =
  Test::MockObject::Extends->new("Catalyst::Plugin::Session::State::URI");

$cxt->set_always( config => { session => { param => 'sid' } } );
$cxt->set_always( request  => $req );
$cxt->set_always( response => $res );
$cxt->set_false("debug");

my $sessionid;
$cxt->mock( sessionid => sub { shift; $sessionid = shift if @_; $sessionid } );
$cxt->mock( _sessionid_from_uri => sub { shift; $sessionid = shift if @_; $sessionid } );
$cxt->mock( _sessionid_to_rewrite => sub { shift; $sessionid = shift if @_; $sessionid } );

$sessionid = 'qux';
my $session_string = $cxt->config->{ session }{ param } . '=' . $sessionid;

my $external_uri    = "http://www.woobling.org/";
my $internal_uri    = $req->base . "action01";
my $relative_uri    = "action02";
my $rel_with_slash  = "/action03";
my $rel_with_dot    = "./action04";
my $int_with_id     = $internal_uri . '?' . $session_string;
my $int_with_ext    = $internal_uri . '/logo.png';

$cxt->setup_session;

my %rewritten = (
    'http://myapp/'         => 'http://myapp/?' . $session_string,
	'http://myapp/?foo=bar' => 'http://myapp/?foo=bar&' . $session_string,
);

can_ok( $m, "uri_with_sessionid" );

foreach my $uri ( keys %rewritten ) {
    is( $cxt->uri_with_sessionid($uri), $rewritten{ $uri }, 'URI is rewritten as expected');
}

can_ok( $m, "session_should_rewrite_uri" );

ok(
    !$cxt->session_should_rewrite_uri( $external_uri ),
    "external URIs should not be rewritten"
);

ok(
    $cxt->session_should_rewrite_uri( $internal_uri ),
    "internal URIs should be rewritten"
);

foreach my $uri ( $relative_uri, $rel_with_slash, $rel_with_dot ) {
    ok(
        $cxt->session_should_rewrite_uri( $uri ),
        "relative URIs should be rewritten"
    );
}

ok(
    !$cxt->session_should_rewrite_uri( $int_with_id),
    "already rewritten internal URIs should not be rewritten again"
);

ok(
    !$cxt->session_should_rewrite_uri( $int_with_ext ),
    "binary media type should not be rewritten"
);

can_ok( $m, "prepare_action" );

can_ok( $m, "finalize" );

$res->body("foo");
$cxt->finalize;
is( $res->body, "foo", "body unchanged with no URLs" );

$res->body( my $body_ext_url = qq{foo <a href="$external_uri"></a> blah} );
$cxt->finalize;
is( $res->body, $body_ext_url, "external URL stays untouched" );

$res->content_type("text/html");

foreach my $uri ( $internal_uri, $relative_uri, $rel_with_slash, $rel_with_dot ) {

    $res->body( my $body_internal = qq{foo <a href="$uri"></a> bar} );
    $cxt->finalize;

    like( $res->body, qr#^foo <a href="$uri.*"></a> bar$#, "body was rewritten" );

    my @uris = ( $res->body =~ /href="(.*?)"/g );

    is( @uris, 1, "one uri was changed" );
    is(
        "$uris[0]",
        $cxt->uri_with_sessionid($uri),
        "rewritten to output of uri_with_sessionid"
    );
}