package WebserverTester; use base qw(Exporter); # Copied and adapted from the CPAN-Mini-Webserver-0.51 distribution use strict; use warnings; use HTTP::Request; use Plack::Test; use Test::Builder; use URI; use URI::QueryParam; our @EXPORT; my $app; { # create a bunch of testing routines that we use internally # these SILENTLY return 1 on success, but on failure return 0 # and spit out a failing test case # # This allows us to easily write compound tests my $Tester = Test::Builder->new; sub is_num($$;$) { local $Test::Builder::Level = $Test::Builder::Level + 1; return 1 if $_[0] == $_[1]; $Tester->is_num( $_[0], $_[1], $Test::name ); $Tester->diag( $_[2] ) if $_[2]; return 0; } sub is_eq($$;$) { local $Test::Builder::Level = $Test::Builder::Level + 1; return 1 if $_[0] eq $_[1]; $Tester->is_eq( $_[0], $_[1], $Test::name ); $Tester->diag( $_[2] ) if $_[2]; return 0; } sub like($$;$) { local $Test::Builder::Level = $Test::Builder::Level + 1; return 1 if $_[0] =~ $_[1]; $Tester->like( $_[0], $_[1], $Test::name ); $Tester->diag( $_[2] ) if $_[2]; return 0; } sub ok() { $Tester->ok( 1, $Test::name ); return 1; } sub skip_all() { $Tester->plan( skip_all => "CPAN::Mini mirror must be installed for testing: $@" ); exit; } } sub set_app { ( $app ) = @_; } push @EXPORT, "set_app"; sub html_page_ok { my $path = shift; my ( $code, $mime, $content ) = make_request( $path, @_ ); # basic "is my response correct" tests local $Test::name = "html page from '$path'"; return unless is_num $code, 200, "when checking status"; return unless like $mime, qr{^text/html}, "when checking html mimetype"; return unless like $content, qr/header( "Status" ), "302 Found", "when checking Status"; return unless is_eq $response->header( "Location" ), $location, "when checking went to the right place"; ok; return $response; } push @EXPORT, "redirect_ok"; sub error404_ok { my $path = shift; my ( $code, $mime, $content, $response ) = make_request( $path, @_ ); local $Test::name = "error 404 for '$path'"; return unless is_num $code, 404, "when checking status"; ok; return $response; } push @EXPORT, "error404_ok"; sub download_ok { my $path = shift; my ( $code, $mime, $content ) = make_request( $path, @_ ); local $Test::name = "download for '$path'"; return unless is_num $code, 200, "when checking status"; return unless like $mime, qr{^text/plain}, "when checking plain mimetype"; ok; return $content; } push @EXPORT, "download_ok"; sub download_gzip_ok { my $path = shift; my ( $code, $mime, $content ) = make_request( $path, @_ ); local $Test::name = "download for '$path'"; return unless is_num $code, 200, "when checking status"; return unless like $mime, qr{^application/x-gzip}, "when checking plain mimetype"; ok; return $content; } push @EXPORT, "download_gzip_ok"; sub make_request { my $path = shift; my $uri = URI->new($path, 'http'); while ( @_ ) { my $name = shift; my $value = shift; $uri->query_param($name, $value); } my $req = HTTP::Request->new(GET => $uri); my $res; test_psgi $app, sub { my ( $cb ) = @_; $res = $cb->($req); }; return wantarray ? ( $res->code || "", $res->header( "Content-Type" ) || "", $res->content || "", $res ) : $res->as_string; } "I wonder if dom's script that looks for true values at the end of modules looks in test modules too?";