326 lines
8.3 KiB
Perl
326 lines
8.3 KiB
Perl
|
#!/usr/bin/perl
|
||
|
|
#
|
||
|
|
# DW::Routing::Test
|
||
|
|
#
|
||
|
|
# Testing class for DW::Routing core tests
|
||
|
|
#
|
||
|
|
# Authors:
|
||
|
|
# Andrea Nall <anall@andreanall.com>
|
||
|
|
#
|
||
|
|
# Copyright (c) 2011-2012 by Dreamwidth Studios, LLC.
|
||
|
|
#
|
||
|
|
# This program is free software; you may redistribute it and/or modify it under
|
||
|
|
# the same terms as Perl itself. For a copy of the license, please reference
|
||
|
|
# 'perldoc perlartistic' or 'perldoc perlgpl'.
|
||
|
|
#
|
||
|
|
package DW::Routing::Test;
|
||
|
|
use strict;
|
||
|
|
|
||
|
|
require 'ljlib.pl';
|
||
|
|
use DW::Request::Standard;
|
||
|
|
use HTTP::Request;
|
||
|
|
|
||
|
|
use Test::Builder::Module;
|
||
|
|
our @ISA = qw(Test::Builder::Module);
|
||
|
|
our @EXPORT = qw(
|
||
|
|
begin_tests got_result expected_format
|
||
|
|
handle_request handle_server_error handle_redirect handle_custom
|
||
|
|
handler regex_handler
|
||
|
|
okay is todo_skip skip plan
|
||
|
|
$TODO
|
||
|
|
|
||
|
|
ok is
|
||
|
|
);
|
||
|
|
|
||
|
|
my $CLASS = __PACKAGE__;
|
||
|
|
|
||
|
|
my $Test = $CLASS->builder;
|
||
|
|
|
||
|
|
my $caller = undef;
|
||
|
|
|
||
|
|
sub import_extra {
|
||
|
|
my ( $self, $data ) = @_;
|
||
|
|
|
||
|
|
my %args = @$data;
|
||
|
|
|
||
|
|
$args{tests}++ if exists $args{tests};
|
||
|
|
|
||
|
|
$DW::Routing::DONT_LOAD = 1 unless $args{load_table};
|
||
|
|
|
||
|
|
@$data = %args;
|
||
|
|
|
||
|
|
require DW::Routing;
|
||
|
|
DW::Routing->import;
|
||
|
|
$DW::Routing::T_TESTING_ERRORS = 1;
|
||
|
|
}
|
||
|
|
|
||
|
|
sub begin_tests {
|
||
|
|
my $ct = scalar keys %DW::Routing::string_choices;
|
||
|
|
|
||
|
|
$ct += scalar @$_ foreach values %DW::Routing::regex_choices;
|
||
|
|
|
||
|
|
$Test->is_eq( $ct, 0, "routing table empty" );
|
||
|
|
}
|
||
|
|
|
||
|
|
my $expected_format = 'html';
|
||
|
|
my $result;
|
||
|
|
|
||
|
|
sub expected_format { $expected_format = $_[0]; }
|
||
|
|
|
||
|
|
sub got_result {
|
||
|
|
$result = $_[0];
|
||
|
|
}
|
||
|
|
|
||
|
|
sub handle_request {
|
||
|
|
my ( $name, $uri, $valid, $expected, %opts ) = @_;
|
||
|
|
$CLASS->builder->subtest(
|
||
|
|
$name,
|
||
|
|
sub {
|
||
|
|
DW::Request->reset;
|
||
|
|
|
||
|
|
my $tb = $CLASS->builder;
|
||
|
|
$tb->plan( tests => 3 );
|
||
|
|
|
||
|
|
my $method = $opts{method} || 'GET';
|
||
|
|
|
||
|
|
my $req = HTTP::Request->new( $method => "$uri" );
|
||
|
|
my $r = DW::Request::Standard->new($req);
|
||
|
|
|
||
|
|
my $ret;
|
||
|
|
my $fail = 0;
|
||
|
|
subtest(
|
||
|
|
"handler call",
|
||
|
|
sub {
|
||
|
|
$ret = DW::Routing->call(%opts);
|
||
|
|
if ( $tb->current_test == 0 ) {
|
||
|
|
plan( tests => 1 );
|
||
|
|
ok( 1, "no tests to run" );
|
||
|
|
}
|
||
|
|
else {
|
||
|
|
$fail = !$tb->is_passing;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
);
|
||
|
|
|
||
|
|
if ($fail) {
|
||
|
|
_skip("overall failure");
|
||
|
|
_skip("overall failure");
|
||
|
|
return 1;
|
||
|
|
}
|
||
|
|
|
||
|
|
if ( !$valid ) {
|
||
|
|
ok( !defined $ret, "return value defined when invalid" );
|
||
|
|
_skip("non-valid test");
|
||
|
|
return 1;
|
||
|
|
}
|
||
|
|
|
||
|
|
my $expected_ret = $opts{expected_error} || $r->OK;
|
||
|
|
is( $ret, $expected_ret, "wrong return" );
|
||
|
|
if ( $ret != $r->OK ) {
|
||
|
|
_skip("non-expected return");
|
||
|
|
return 0;
|
||
|
|
}
|
||
|
|
is( $result, $expected, "handler set wrong value." );
|
||
|
|
}
|
||
|
|
);
|
||
|
|
}
|
||
|
|
|
||
|
|
sub handle_custom {
|
||
|
|
my ( $uri, %test_opts ) = @_;
|
||
|
|
$CLASS->builder->subtest(
|
||
|
|
$test_opts{name} || $uri,
|
||
|
|
sub {
|
||
|
|
my $tb = $CLASS->builder;
|
||
|
|
$tb->plan( tests => 1 );
|
||
|
|
|
||
|
|
my $schema = $test_opts{schema} || "http";
|
||
|
|
my $method = ( $test_opts{method} || "GET" );
|
||
|
|
|
||
|
|
my $req = HTTP::Request->new( $method => "$schema://www.example.com$uri" );
|
||
|
|
$req->header( Host => 'www.example.com' );
|
||
|
|
DW::Request->reset;
|
||
|
|
my $r = DW::Request::Standard->new($req);
|
||
|
|
|
||
|
|
my $opts = DW::Routing->get_call_opts( %{ $test_opts{opts} || {} } );
|
||
|
|
|
||
|
|
unless ($opts) {
|
||
|
|
ok( 0, "opts exists" );
|
||
|
|
_skip("opts is undef");
|
||
|
|
return;
|
||
|
|
}
|
||
|
|
|
||
|
|
my $hash = $opts->call_opts;
|
||
|
|
|
||
|
|
unless ( $hash && $hash->{sub} ) {
|
||
|
|
ok( 0, "improper opts" );
|
||
|
|
_skip("opts are improper");
|
||
|
|
return;
|
||
|
|
}
|
||
|
|
|
||
|
|
if ( $test_opts{final} ) {
|
||
|
|
my $rv = DW::Routing->call_hash($opts);
|
||
|
|
|
||
|
|
$CLASS->builder->subtest(
|
||
|
|
"custom sub",
|
||
|
|
sub {
|
||
|
|
$test_opts{final}->( $r, $rv );
|
||
|
|
}
|
||
|
|
);
|
||
|
|
}
|
||
|
|
else {
|
||
|
|
_skip("no final sub");
|
||
|
|
}
|
||
|
|
}
|
||
|
|
);
|
||
|
|
}
|
||
|
|
|
||
|
|
sub handle_redirect {
|
||
|
|
my ( $uri, $expected ) = @_;
|
||
|
|
$CLASS->builder->subtest(
|
||
|
|
$uri,
|
||
|
|
sub {
|
||
|
|
my $tb = $CLASS->builder;
|
||
|
|
$tb->plan( tests => 3 );
|
||
|
|
|
||
|
|
my $req = HTTP::Request->new( GET => "http://www.example.com$uri" );
|
||
|
|
$req->header( Host => 'www.example.com' );
|
||
|
|
DW::Request->reset;
|
||
|
|
my $r = DW::Request::Standard->new($req);
|
||
|
|
|
||
|
|
my $opts = DW::Routing->get_call_opts();
|
||
|
|
|
||
|
|
unless ($opts) {
|
||
|
|
ok( 0, "opts exists" );
|
||
|
|
_skip("opts is undef");
|
||
|
|
return;
|
||
|
|
}
|
||
|
|
|
||
|
|
my $hash = $opts->call_opts;
|
||
|
|
|
||
|
|
unless ( $hash && $hash->{sub} ) {
|
||
|
|
ok( 0, "improper opts" );
|
||
|
|
_skip("opts are improper");
|
||
|
|
return;
|
||
|
|
}
|
||
|
|
|
||
|
|
is( $hash->{sub}, \&DW::Routing::_redirect_helper );
|
||
|
|
|
||
|
|
# Safe to call!
|
||
|
|
|
||
|
|
my $rv = DW::Routing->call_hash($opts);
|
||
|
|
|
||
|
|
is( $rv, $r->REDIRECT );
|
||
|
|
if ( substr( $expected, 0, 1 ) == '/' ) {
|
||
|
|
is( $r->header_out('Location'), "$LJ::PROTOCOL://www.example.com$expected" );
|
||
|
|
}
|
||
|
|
else {
|
||
|
|
is( $r->header_out('Location'), $expected );
|
||
|
|
}
|
||
|
|
|
||
|
|
}
|
||
|
|
);
|
||
|
|
}
|
||
|
|
|
||
|
|
sub handle_server_error {
|
||
|
|
my ( $name, $uri, $format, %opts ) = @_;
|
||
|
|
$CLASS->builder->subtest(
|
||
|
|
$name,
|
||
|
|
sub {
|
||
|
|
DW::Request->reset;
|
||
|
|
|
||
|
|
my $tb = $CLASS->builder;
|
||
|
|
$tb->plan( tests => 3 );
|
||
|
|
|
||
|
|
my $method = $opts{method} || 'GET';
|
||
|
|
|
||
|
|
my $req = HTTP::Request->new( $method => "$uri" );
|
||
|
|
my $r = DW::Request::Standard->new($req);
|
||
|
|
|
||
|
|
my $ret;
|
||
|
|
my $fail = 0;
|
||
|
|
subtest(
|
||
|
|
"handler call",
|
||
|
|
sub {
|
||
|
|
eval { $ret = DW::Routing->call(%opts) };
|
||
|
|
if ( !defined $ret ) {
|
||
|
|
plan( tests => 1 );
|
||
|
|
ok( 0, "test did not run" );
|
||
|
|
$fail = 1;
|
||
|
|
}
|
||
|
|
elsif ( $tb->current_test == 0 ) {
|
||
|
|
plan( tests => 1 );
|
||
|
|
ok( 1, "no tests to run" );
|
||
|
|
}
|
||
|
|
else {
|
||
|
|
$fail = !$tb->is_passing;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
);
|
||
|
|
|
||
|
|
if ($fail) {
|
||
|
|
_skip("overall failure");
|
||
|
|
_skip("overall failure");
|
||
|
|
return 1;
|
||
|
|
}
|
||
|
|
|
||
|
|
my $content_type = $r->content_type;
|
||
|
|
is( $r->status, $r->HTTP_SERVER_ERROR, "wrong return" );
|
||
|
|
is(
|
||
|
|
$content_type,
|
||
|
|
{
|
||
|
|
html => "text/html",
|
||
|
|
json => "application/json",
|
||
|
|
}->{$format}
|
||
|
|
|| "text/plain",
|
||
|
|
"wrong returned content type for $format"
|
||
|
|
);
|
||
|
|
}
|
||
|
|
);
|
||
|
|
}
|
||
|
|
|
||
|
|
sub handler {
|
||
|
|
my $r = DW::Request->get;
|
||
|
|
got_result( $_[0]->args );
|
||
|
|
is( $_[0]->format, $expected_format, "format wrong!" );
|
||
|
|
return $r->OK;
|
||
|
|
}
|
||
|
|
|
||
|
|
sub regex_handler {
|
||
|
|
my $r = DW::Request->get;
|
||
|
|
got_result( $_[0]->args->[1] );
|
||
|
|
is( $_[0]->format, $expected_format, "format wrong!" );
|
||
|
|
is( $_[0]->subpatterns->[0], $_[0]->args->[0], "capture wrong!" );
|
||
|
|
return $r->OK;
|
||
|
|
}
|
||
|
|
|
||
|
|
sub _skip { return $CLASS->builder->skip(@_); }
|
||
|
|
|
||
|
|
sub subtest { return $CLASS->builder->subtest(@_); }
|
||
|
|
sub plan { return $CLASS->builder->plan(@_); }
|
||
|
|
sub ok { return $CLASS->builder->ok(@_); }
|
||
|
|
sub is { return $CLASS->builder->is_eq(@_); }
|
||
|
|
|
||
|
|
sub skip {
|
||
|
|
my ( $why, $how_many ) = @_;
|
||
|
|
my $tb = $CLASS->builder;
|
||
|
|
|
||
|
|
$how_many = 1 unless defined $how_many;
|
||
|
|
$tb->skip($why) for ( 1 .. $how_many );
|
||
|
|
|
||
|
|
no warnings 'exiting';
|
||
|
|
last SKIP;
|
||
|
|
}
|
||
|
|
|
||
|
|
sub todo_skip {
|
||
|
|
my ( $why, $how_many ) = @_;
|
||
|
|
my $tb = $CLASS->builder;
|
||
|
|
|
||
|
|
$how_many = 1 unless defined $how_many;
|
||
|
|
$tb->todo_skip($why) for ( 1 .. $how_many );
|
||
|
|
|
||
|
|
no warnings 'exiting';
|
||
|
|
last TODO;
|
||
|
|
}
|
||
|
|
|
||
|
|
1;
|