From: Florian Ragwitz <rafl@debian.org>
Date: Fri, 18 Mar 2011 14:53:07 +0000 (+0100)
Subject: Merge branch 'master' into psgi
X-Git-Tag: 5.89003~86
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=catagits%2FCatalyst-Runtime.git;a=commitdiff_plain;h=db522412c578a200f448706e80284ebcf942e53b;hp=-c

Merge branch 'master' into psgi

* master:
  Make default test names reflect reality more and fix a buglet, rafl++
  Give action_ok, action_redirect and action_notfound default test names
---

db522412c578a200f448706e80284ebcf942e53b
diff --combined lib/Catalyst/Test.pm
index 9f10905,7befe99..a976811
--- a/lib/Catalyst/Test.pm
+++ b/lib/Catalyst/Test.pm
@@@ -4,60 -4,51 +4,60 @@@ use strict
  use warnings;
  use Test::More ();
  
 +use Plack::Test;
  use Catalyst::Exception;
  use Catalyst::Utils;
  use Class::MOP;
  use Sub::Exporter;
 +use Carp 'croak', 'carp';
  
 -my $build_exports = sub {
 -    my ($self, $meth, $args, $defaults) = @_;
 +sub _build_request_export {
 +    my ($self, $args) = @_;
 +
 +    return sub { _remote_request(@_) }
 +        if $args->{remote};
  
 -    my $request;
      my $class = $args->{class};
  
 -    if ( $ENV{CATALYST_SERVER} ) {
 -        $request = sub { remote_request(@_) };
 -    } elsif (! $class) {
 -        $request = sub { Catalyst::Exception->throw("Must specify a test app: use Catalyst::Test 'TestApp'") };
 -    } else {
 -        unless (Class::MOP::is_class_loaded($class)) {
 -            Class::MOP::load_class($class);
 -        }
 -        $class->import;
 +    # Here we should be failing right away, but for some stupid backcompat thing
 +    # I don't quite remember we fail lazily here. Needs a proper deprecation and
 +    # then removal.
 +    return sub { croak "Must specify a test app: use Catalyst::Test 'TestApp'" }
 +        unless $class;
  
 -        $request = sub { local_request( $class, @_ ) };
 -    }
 +    Class::MOP::load_class($class) unless Class::MOP::is_class_loaded($class);
 +    $class->import;
  
 -    my $get = sub { $request->(@_)->content };
 +    return sub { _local_request( $class, @_ ) };
 +}
 +
 +sub _build_get_export {
 +    my ($self, $args) = @_;
 +    my $request = $args->{request};
 +
 +    return sub { $request->(@_)->content };
 +}
 +sub _build_ctx_request_export {
 +    my ($self, $args) = @_;
 +    my ($class, $request) = @{ $args }{qw(class request)};
  
 -    my $ctx_request = sub {
 +    return sub {
          my $me = ref $self || $self;
  
 -        ### throw an exception if ctx_request is being used against a remote
 -        ### server
 +        # fail if ctx_request is being used against a remote server
          Catalyst::Exception->throw("$me only works with local requests, not remote")
              if $ENV{CATALYST_SERVER};
  
 -        ### check explicitly for the class here, or the Cat->meta call will blow
 -        ### up in our face
 +        # check explicitly for the class here, or the Cat->meta call will blow
 +        # up in our face
          Catalyst::Exception->throw("Must specify a test app: use Catalyst::Test 'TestApp'") unless $class;
  
 -        ### place holder for $c after the request finishes; reset every time
 -        ### requests are done.
 +        # place holder for $c after the request finishes; reset every time
 +        # requests are done.
          my $ctx_closed_over;
  
 -        ### hook into 'dispatch' -- the function gets called after all plugins
 -        ### have done their work, and it's an easy place to capture $c.
 -
 +        # hook into 'dispatch' -- the function gets called after all plugins
 +        # have done their work, and it's an easy place to capture $c.
          my $meta = Class::MOP::get_metaclass_by_name($class);
          $meta->make_mutable;
          $meta->add_after_method_modifier( "dispatch", sub {
@@@ -65,10 -56,9 +65,10 @@@
          });
          $meta->make_immutable( replace_constructor => 1 );
          Class::C3::reinitialize(); # Fixes RT#46459, I've failed to write a test for how/why, but it does.
 -        ### do the request; C::T::request will know about the class name, and
 -        ### we've already stopped it from doing remote requests above.
 -        my $res = $request->( @_ );
 +
 +        # do the request; C::T::request will know about the class name, and
 +        # we've already stopped it from doing remote requests above.
 +        my $res = $args->{request}->( @_ );
  
          # Make sure not to leave a reference $ctx hanging around.
          # This means that the context will go out of scope as soon as the
@@@ -80,25 -70,9 +80,25 @@@
          my $ctx = $ctx_closed_over;
          undef $ctx_closed_over;
  
 -        ### return both values
          return ( $res, $ctx );
      };
 +}
 +
 +my $build_exports = sub {
 +    my ($self, $meth, $args, $defaults) = @_;
 +    my $class = $args->{class};
 +
 +    my $request = $self->_build_request_export({
 +        class  => $class,
 +        remote => $ENV{CATALYST_SERVER},
 +    });
 +
 +    my $get = $self->_build_get_export({ request => $request });
 +
 +    my $ctx_request = $self->_build_ctx_request_export({
 +        class   => $class,
 +        request => $request,
 +    });
  
      return {
          request      => $request,
@@@ -110,15 -84,21 +110,21 @@@
          },
          action_ok => sub {
              my $action = shift;
-             return Test::More->builder->ok($request->($action)->is_success, @_);
+             my $meth = $request->($action)->request->method;
+             my @args = @_ ? @_ : ("$meth $action returns successfully");
+             return Test::More->builder->ok($request->($action)->is_success,@args);
          },
          action_redirect => sub {
              my $action = shift;
-             return Test::More->builder->ok($request->($action)->is_redirect,@_);
+             my $meth = $request->($action)->request->method;
+             my @args = @_ ? @_ : ("$meth $action returns a redirect");
+             return Test::More->builder->ok($request->($action)->is_redirect,@args);
          },
          action_notfound => sub {
              my $action = shift;
-             return Test::More->builder->is_eq($request->($action)->code,404,@_);
+             my $meth = $request->($action)->request->method;
+             my @args = @_ ? @_ : ("$meth $action returns a 404");
+             return Test::More->builder->is_eq($request->($action)->code,404,@args);
          },
          contenttype_is => sub {
              my $action = shift;
@@@ -249,58 -229,60 +255,58 @@@ header configuration; currently only su
      my $res = request('foo/bar?test=1');
      my $virtual_res = request('foo/bar?test=1', {host => 'virtualhost.com'});
  
 -=head1 FUNCTIONS
 -
  =head2 ($res, $c) = ctx_request( ... );
  
  Works exactly like L<request|/"$res = request( ... );">, except it also returns the Catalyst context object,
  C<$c>. Note that this only works for local requests.
  
 -=head2 $res = Catalyst::Test::local_request( $AppClass, $url );
 -
 -Simulate a request using L<HTTP::Request::AsCGI>.
 -
  =cut
  
 -sub local_request {
 +sub _local_request {
      my $class = shift;
  
 -    require HTTP::Request::AsCGI;
 +    my $app = ref($class) eq "CODE" ? $class : $class->_finalized_psgi_app;
  
 -    my $request = Catalyst::Utils::request( shift(@_) );
 -    _customize_request($request, @_);
 -    my $cgi     = HTTP::Request::AsCGI->new( $request, %ENV )->setup;
 +    my $request = Catalyst::Utils::request(shift);
 +    my %extra_env;
 +    _customize_request($request, \%extra_env, @_);
  
 -    $class->handle_request( env => \%ENV );
 +    my $ret;
 +    test_psgi
 +        app    => sub { $app->({ %{ $_[0] }, %extra_env }) },
 +        client => sub {
 +            my $psgi_app = shift;
  
 -    my $response = $cgi->restore->response;
 -    $response->request( $request );
 +            my $resp = $psgi_app->($request);
  
 -    # HTML head parsing based on LWP::UserAgent
 +            # HTML head parsing based on LWP::UserAgent
 +            #
 +            # This is not just horrible and possibly broken, but also really
 +            # doesn't belong here. Whoever wants this should be working on
 +            # getting it into Plack::Test, or make a middleware out of it, or
 +            # whatever. Seriously - horrible.
  
 -    require HTML::HeadParser;
 +            require HTML::HeadParser;
  
 -    my $parser = HTML::HeadParser->new();
 -    $parser->xml_mode(1) if $response->content_is_xhtml;
 -    $parser->utf8_mode(1) if $] >= 5.008 && $HTML::Parser::VERSION >= 3.40;
 +            my $parser = HTML::HeadParser->new();
 +            $parser->xml_mode(1) if $resp->content_is_xhtml;
 +            $parser->utf8_mode(1) if $] >= 5.008 && $HTML::Parser::VERSION >= 3.40;
  
 -    $parser->parse( $response->content );
 -    my $h = $parser->header;
 -    for my $f ( $h->header_field_names ) {
 -        $response->init_header( $f, [ $h->header($f) ] );
 -    }
 +            $parser->parse( $resp->content );
 +            my $h = $parser->header;
 +            for my $f ( $h->header_field_names ) {
 +                $resp->init_header( $f, [ $h->header($f) ] );
 +            }
  
 -    return $response;
 +            $ret = $resp;
 +        };
 +
 +    return $ret;
  }
  
  my $agent;
  
 -=head2 $res = Catalyst::Test::remote_request( $url );
 -
 -Do an actual remote request using LWP.
 -
 -=cut
 -
 -sub remote_request {
 -
 +sub _remote_request {
      require LWP::UserAgent;
  
      my $request = Catalyst::Utils::request( shift(@_) );
@@@ -359,33 -341,13 +365,33 @@@
      return $agent->request($request);
  }
  
 +for my $name (qw(local_request remote_request)) {
 +    my $fun = sub {
 +        carp <<"EOW";
 +Calling Catalyst::Test::${name}() directly is deprecated.
 +
 +Please import Catalyst::Test into your namespace and use the provided request()
 +function instead.
 +EOW
 +        return __PACKAGE__->can("_${name}")->(@_);
 +    };
 +
 +    no strict 'refs';
 +    *$name = $fun;
 +}
 +
  sub _customize_request {
      my $request = shift;
 +    my $extra_env = shift;
      my $opts = pop(@_) || {};
      $opts = {} unless ref($opts) eq 'HASH';
      if ( my $host = exists $opts->{host} ? $opts->{host} : $default_host  ) {
          $request->header( 'Host' => $host );
      }
 +
 +    if (my $extra = $opts->{extra_env}) {
 +        @{ $extra_env }{keys %{ $extra }} = values %{ $extra };
 +    }
  }
  
  =head2 action_ok($url [, $test_name ])
@@@ -426,14 -388,6 +432,14 @@@ Catalyst Contributors, see Catalyst.p
  This library is free software. You can redistribute it and/or modify it under
  the same terms as Perl itself.
  
 +=begin Pod::Coverage
 +
 +local_request
 +
 +remote_request
 +
 +=end Pod::Coverage
 +
  =cut
  
  1;