view release on metacpan or  search on metacpan

t/server_session.t  view on Meta::CPAN

teardown();       #1.

# -----------------------------------------------------------------------------
# shortcut.
# 
sub check_requires() { &t::test_server::check_requires; }
sub start_server()   { &t::test_server::start_server; }
sub request_get(@)   { &t::test_server::request_get; }
sub raw_request(@)   { &t::test_server::raw_request; }
sub rget($)
{
	request_get(
		script  => shift,
		db      => 'DB',
		session => 'Session',
	);
}

sub with_filter($$) {
    my $main   = shift;
    my $filter = shift;

    my $script = q{
        $TL->startCgi(
            -main    => \&main,
            -DB      => 'DB',
            -Session => 'Session'
           );
        sub main {
            $TL->setContentFilter('<&FILTER>');
            <&MAIN>
        }
    };
    $script =~ s/<&FILTER>/$filter/;
    $script =~ s/<&MAIN>/$main/;

    return raw_request(
        method => 'GET',
        script => $script
       )->content;
}

# -----------------------------------------------------------------------------
# setup.
# 
sub setup
{
	my $failmsg = check_requires();
	if( $failmsg )
	{
		plan skip_all => $failmsg;
	}
	
	eval{ require DBD::mysql; };
	$@ and plan skip_all => "no DBD::mysql";
	diag "DBD::mysql ".DBD::mysql->VERSION;
	
	&start_server;
	
	# ini.
	my ($name) = getpwuid($<);
	my $ini = {
		DB => {
			type    => 'mysql',
			defaultset  => 'SET_Default',
			SET_Default => 'DBRW1',
		},
		DBRW1 => {
			host     => $ENV{TEST_DBHOST} || 'localhost',
			dbname   => $ENV{TEST_DBNAME} || 'test',
			user     => $ENV{TEST_DBUSER} || $name,
			password => $ENV{TEST_DBPASS},
		},
		Session => {
			mode         => 'http',
			dbgroup      => 'DB',
			dbset        => 'SET_Default',
			sessiontable => 'TripletaiL_Session_Test',
			csrfkey      => 'TripletaiL_Key',
		},
	};
	
	# check db connection.
	my $ver = eval
	{
		request_get(
			ini     => $ini,
			db      => 'DB', 
			session => 'Session',
			script  => q{ $TL->getDB()->selectRowArray('SELECT version()'); },
		);
	};
	if( $@ )
	{
		if( $@ =~ m{(DBI connect.+?)(<br|\n|$)})
		{
			# DBI connect error.
			$_ = $1;
			s/&#39;/'/g;
			plan skip_all => $_;
		}
		# other error?
		plan skip_all => "request failure: $@";
	}
	$ver &&= $ver->[0];
	diag("MySQL $ver");
}

# -----------------------------------------------------------------------------
# basic.
# 
sub test_01_basic
{
	ok( rget q{ $TL->getSession; }, '[basic] getsession');
	
	ok( rget q{
			my $s = $TL->getSession;
			not $s->isHttps;
		} => '[basic] not isHttps');
	
	# セッションキーの取得.