[Catalyst-dev] PATCH: enable virtual hosts in Catalyst::Test

[Jason Gottshall]

Here's my first stab at a Catalyst contrib. Patch against 5.80/trunk. 
Tests and pod included. Let me know how I did! Remainder of message is 
svn diff:

Index: t/unit_load_catalyst_test.t
===================================================================
--- t/unit_load_catalyst_test.t	(revision 8583)
+++ t/unit_load_catalyst_test.t	(working copy)
@@ -4,8 +4,9 @@
  use warnings;

  use Test::More;
+use Catalyst::Utils;

-plan tests => 3;
+plan tests => 8;

  use_ok('Catalyst::Test');

@@ -14,3 +15,38 @@

  eval "request('http://localhost')";
  isnt( $@, "", "request returns an error message with no app specified");
+
+sub customize { Catalyst::Test::_customize_request(@_) }
+
+{
+    my $req = Catalyst::Utils::request('/dummy');
+    customize( $req );
+    is( $req->header('Host'), undef, 'normal request is unmodified' );
+}
+
+{
+    my $req = Catalyst::Utils::request('/dummy');
+    customize( $req, { host => 'customized.com' } );
+    like( $req->header('Host'), qr/customized.com/, 'request is 
customizable via opts hash' );
+}
+
+{
+    my $req = Catalyst::Utils::request('/dummy');
+    local $Catalyst::Test::default_host = 'localized.com';
+    customize( $req );
+    like( $req->header('Host'), qr/localized.com/, 'request is 
customizable via package var' );
+}
+
+{
+    my $req = Catalyst::Utils::request('/dummy');
+    local $Catalyst::Test::default_host = 'localized.com';
+    customize( $req, { host => 'customized.com' } );
+    like( $req->header('Host'), qr/customized.com/, 'opts hash takes 
precedence over package var' );
+}
+
+{
+    my $req = Catalyst::Utils::request('/dummy');
+    local $Catalyst::Test::default_host = 'localized.com';
+    customize( $req, { host => '' } );
+    is( $req->header('Host'), undef, 'default value can be temporarily 
cleared via opts hash' );
+}
Index: t/live_catalyst_test.t
===================================================================
--- t/live_catalyst_test.t	(revision 8583)
+++ t/live_catalyst_test.t	(working copy)
@@ -1,11 +1,32 @@
  use FindBin;
  use lib "$FindBin::Bin/lib";
-use Catalyst::Test 'TestApp';
+use Catalyst::Test 'TestApp', {default_host => 'default.com'};
+use Catalyst::Request;

-use Test::More tests => 5;
+use Test::More tests => 8;

  content_like('/',qr/root/,'content check');
  action_ok('/','Action ok ok','normal action ok');
  action_redirect('/engine/response/redirect/one','redirect check');
  action_notfound('/engine/response/status/s404','notfound check');
-contenttype_is('/action/local/one','text/plain','Contenttype check');
\ No newline at end of file
+contenttype_is('/action/local/one','text/plain','Contenttype check');
+
+my $creq;
+my $req = '/dump/request';
+
+{
+    eval '$creq = ' . request($req)->content;
+    is( $creq->uri->host, 'default.com', 'request targets default host 
set via import' );
+}
+
+{
+    local $Catalyst::Test::default_host = 'localized.com';
+    eval '$creq = ' . request($req)->content;
+    is( $creq->uri->host, 'localized.com', 'target host is mutable via 
package var' );
+}
+
+{
+    my %opts = ( host => 'opthash.com' );
+    eval '$creq = ' . request($req, \%opts)->content;
+    is( $creq->uri->host, $opts{host}, 'target host is mutable via 
options hashref' );
+}
Index: lib/Catalyst/Test.pm
===================================================================
--- lib/Catalyst/Test.pm	(revision 8583)
+++ lib/Catalyst/Test.pm	(working copy)
@@ -63,9 +63,13 @@
          into_level => 1,
      });

+    our $default_host;
+
      sub import {
-        my ($self, $class) = @_;
+        my ($self, $class, $opts) = @_;
          $import->($self, '-all' => { class => $class });
+        $opts ||= {};
+        $default_host = $opts->{default_host} if exists 
$opts->{default_host};
      }
  }

@@ -111,6 +115,15 @@

      ok( get('/foo') =~ /bar/ );

+    # mock virtual hosts
+    use Catalyst::Test 'MyApp', { default_host => 'myapp.com' };
+    like( get('/whichhost'), qr/served by myapp.com/ );
+    like( get( '/whichhost', { host => 'yourapp.com' } ), qr/served by 
yourapp.com/ );
+    {
+        local $Catalyst::Test::default_host = 'otherapp.com';
+        like( get('/whichhost'), qr/served by otherapp.com/ );
+    }
+
  =head1 DESCRIPTION

  This module allows you to make requests to a Catalyst application 
either without
@@ -143,9 +156,11 @@

  =head2 request

-Returns a C<HTTP::Response> object.
+Returns a C<HTTP::Response> object. Accepts an optional hashref for 
request
+header configuration; currently only supports setting 'host' value.

      my $res = request('foo/bar?test=1');
+    my $virtual_res = request('foo/bar?test=1', {host => 
'virtualhost.com'});

  =head2 local_request

@@ -159,6 +174,7 @@
      require HTTP::Request::AsCGI;

      my $request = Catalyst::Utils::request( shift(@_) );
+    _customize_request($request, @_);
      my $cgi     = HTTP::Request::AsCGI->new( $request, %ENV )->setup;

      $class->handle_request;
@@ -181,6 +197,8 @@
      my $request = Catalyst::Utils::request( shift(@_) );
      my $server  = URI->new( $ENV{CATALYST_SERVER} );

+    _customize_request($request, @_);
+
      if ( $server->path =~ m|^(.+)?/$| ) {
          my $path = $1;
          $server->path("$path") if $path;    # need to be quoted
@@ -228,6 +246,14 @@
      return $agent->request($request);
  }

+sub _customize_request {
+    my $request = shift;
+    my $opts = pop(@_) || {};
+    if ( my $host = exists $opts->{host} ? $opts->{host} : 
$default_host  ) {
+        $request->header( 'Host' => $host );
+    }
+}
+
  =head2 action_ok

  Fetches the given url and check that the request was successful