[Catalyst-commits] r9204 - in Test-WWW-Mechanize-Catalyst/trunk: . lib/Test/WWW/Mechanize t t/lib

[ash at dev.catalyst.perl.org]

Author: ash
Date: 2009-02-04 20:10:25 +0000 (Wed, 04 Feb 2009)
New Revision: 9204

Added:
   Test-WWW-Mechanize-Catalyst/trunk/t/white_label.t
Modified:
   Test-WWW-Mechanize-Catalyst/trunk/CHANGES
   Test-WWW-Mechanize-Catalyst/trunk/lib/Test/WWW/Mechanize/Catalyst.pm
   Test-WWW-Mechanize-Catalyst/trunk/t/lib/Catty.pm
Log:
TWMC: Add white label (Host header) testing

Modified: Test-WWW-Mechanize-Catalyst/trunk/CHANGES
===================================================================
--- Test-WWW-Mechanize-Catalyst/trunk/CHANGES	2009-02-04 20:10:18 UTC (rev 9203)
+++ Test-WWW-Mechanize-Catalyst/trunk/CHANGES	2009-02-04 20:10:25 UTC (rev 9204)
@@ -8,6 +8,7 @@
        interpreter due to the above change
      - Removed Test::WWW::Mechanize::Catalyst::Aux package as it isn't needed
        any more
+     - Add 'host' accessor for white-label testing 
 
 0.45 Mon Nov 24 20:39:19 GMT 2008
      - be forwards-compatible with Catalyst 5.80's virtual 

Modified: Test-WWW-Mechanize-Catalyst/trunk/lib/Test/WWW/Mechanize/Catalyst.pm
===================================================================
--- Test-WWW-Mechanize-Catalyst/trunk/lib/Test/WWW/Mechanize/Catalyst.pm	2009-02-04 20:10:18 UTC (rev 9203)
+++ Test-WWW-Mechanize-Catalyst/trunk/lib/Test/WWW/Mechanize/Catalyst.pm	2009-02-04 20:10:25 UTC (rev 9204)
@@ -28,6 +28,13 @@
   default => 0
 );
 
+has host => (
+  is => 'rw',
+  isa => 'Str',
+  clearer => 'clear_host',
+  predicate => 'has_host',
+);
+
 sub new {
   my $class = shift;
 
@@ -47,6 +54,21 @@
     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 @@
         }
     }
   
-    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 @@
 
   $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

Modified: Test-WWW-Mechanize-Catalyst/trunk/t/lib/Catty.pm
===================================================================
--- Test-WWW-Mechanize-Catalyst/trunk/t/lib/Catty.pm	2009-02-04 20:10:18 UTC (rev 9203)
+++ Test-WWW-Mechanize-Catalyst/trunk/t/lib/Catty.pm	2009-02-04 20:10:25 UTC (rev 9204)
@@ -92,6 +92,15 @@
     $c->response->output($html);
 }
 
+sub host : Global {
+    my ($self, $c) = @_;
+
+    my $host = $c->req->header('Host') || "<undef>";
+    my $html = html( $c->config->{name}, "Host: $host" );
+    $c->response->content_type("text/html");
+    $c->response->output($html);
+}
+
 sub html {
     my ( $title, $body ) = @_;
     return qq{

Added: Test-WWW-Mechanize-Catalyst/trunk/t/white_label.t
===================================================================
--- Test-WWW-Mechanize-Catalyst/trunk/t/white_label.t	                        (rev 0)
+++ Test-WWW-Mechanize-Catalyst/trunk/t/white_label.t	2009-02-04 20:10:25 UTC (rev 9204)
@@ -0,0 +1,16 @@
+use strict;
+use warnings;
+
+use Test::More tests => 4;
+use lib 't/lib';
+use Test::WWW::Mechanize::Catalyst;
+
+my $m = Test::WWW::Mechanize::Catalyst->new(catalyst_app => 'Catty');
+
+$m->host('foo.com');
+$m->get_ok('/host');
+$m->content_contains('Host: foo.com:80');
+
+$m->clear_host;
+$m->get_ok('/host');
+$m->content_contains('Host: localhost:80') or diag $m->content;