TWMC: Add white label (Host header) testing

[catagits/Test-WWW-Mechanize-Catalyst.git] / lib / Test / WWW / Mechanize / Catalyst.pm

diff --git a/lib/Test/WWW/Mechanize/Catalyst.pm b/lib/Test/WWW/Mechanize/Catalyst.pm
index 74e4758..4a40089 100644 (file)
--- a/lib/Test/WWW/Mechanize/Catalyst.pm
+++ b/lib/Test/WWW/Mechanize/Catalyst.pm
@@ -28,6 +28,13 @@ has allow_external => (
   default => 0
 );
 
+has host => (
+  is => 'rw',
+  isa => 'Str',
+  clearer => 'clear_host',
+  predicate => 'has_host',
+);
+
 sub new {
   my $class = shift;
 
@@ -47,6 +54,21 @@ sub _make_request {
     my ( $self, $request ) = @_;
     $self->cookie_jar->add_cookie_header($request) if $self->cookie_jar;
 
+    my $uri = $request->uri;
+    if ($uri->as_string =~ m{^/}) {
+      $uri->scheme('http');
+      $uri->host('localhost');
+    }
+
+    # If there's no Host header, set one.
+    unless ($request->header('Host')) {
+      my $host = $self->has_host
+               ? $self->host
+               : $uri->host;
+
+      $request->header('Host', $host);
+    }
+
     if ( $self->{allow_external} ) {
         unless ( $request->uri->as_string =~ m{^/}
             || $request->uri->host eq 'localhost' )
@@ -55,14 +77,10 @@ sub _make_request {
         }
     }
   
-    my $uri = $request->uri;
-    if ($uri->as_string =~ m{^/}) {
-      $uri->scheme('http');
-      $uri->host('localhost');
-    }
     my @creds = $self->get_basic_credentials( "Basic", $uri );
     $request->authorization_basic( @creds ) if @creds;
 
+
     my $response = Catalyst::Test::local_request($self->{catalyst_app}, $request);
     $response->header( 'Content-Base', $request->uri );
     $response->request($request);
@@ -229,6 +247,24 @@ single sign-on system. You must set allow_external to true for this:
 
   $m->allow_external(1);
 
+head2 catalyst_app
+
+The name of the Catalyst app which we are testing against. Read-only.
+
+=head2 host
+
+The host value to set the "Host:" HTTP header to, if none is present already in
+the request. If not set (default) then Catalyst::Test will set this to
+localhost:80
+
+=head2 clear_host
+
+Unset the host attribute.
+
+=head2 has_host
+
+Do we have a value set for the host attribute
+
 =head2 $mech->get_ok($url, [ \%LWP_options ,] $desc)
 
 A wrapper around WWW::Mechanize's get(), with similar options, except the