Mailing List Archive

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


_______________________________________________
Catalyst-dev mailing list
Catalyst-dev@lists.scsys.co.uk
http://lists.scsys.co.uk/cgi-bin/mailman/listinfo/catalyst-dev