lib/Catalyst/Test.pm

   1 package Catalyst::Test;
   2
   3 use strict;
   4 use UNIVERSAL::require;
   5 use IO::File;
   6 use HTTP::Request;
   7 use HTTP::Response;
   8 use Socket;
   9 use URI;
  10
  11 require Catalyst;
  12
  13 my $class;
  14 $ENV{CATALYST_ENGINE} = 'CGI';
  15 $ENV{CATALYST_TEST}   = 1;
  16
  17 =head1 NAME
  18
  19 Catalyst::Test - Test Catalyst applications
  20
  21 =head1 SYNOPSIS
  22
  23     # Helper
  24     script/test.pl
  25
  26     # Tests
  27     use Catalyst::Test 'TestApp';
  28     request('index.html');
  29     get('index.html');
  30
  31     # Request
  32     perl -MCatalyst::Test=MyApp -e1 index.html
  33
  34 =head1 DESCRIPTION
  35
  36 Test Catalyst applications.
  37
  38 =head2 METHODS
  39
  40 =head3 get
  41
  42 Returns the content.
  43
  44     my $content = get('foo/bar?test=1');
  45
  46 =head3 request
  47
  48 Returns a C<HTTP::Response> object.
  49
  50     my $res =request('foo/bar?test=1');
  51
  52 =cut
  53
  54 {
  55     no warnings;
  56     CHECK {
  57         if ( ( caller(0) )[1] eq '-e' ) {
  58             print request( $ARGV[0] || 'http://localhost' )->content;
  59         }
  60     }
  61 }
  62
  63 sub import {
  64     my $self = shift;
  65     if ( $class = shift ) {
  66         $class->require;
  67         unless ( $INC{'Test/Builder.pm'} ) {
  68             die qq/Couldn't load "$class", "$@"/ if $@;
  69         }
  70         my $caller = caller(0);
  71         no strict 'refs';
  72         *{"$caller\::request"} = \&request;
  73         *{"$caller\::get"} = sub { request(@_)->content };
  74     }
  75 }
  76
  77 sub request {
  78     my $request = shift;
  79     unless ( ref $request ) {
  80         $request = URI->new( $request, 'http' );
  81     }
  82     unless ( ref $request eq 'HTTP::Request' ) {
  83         $request = HTTP::Request->new( 'GET', $request );
  84     }
  85     local ( *STDIN, *STDOUT );
  86     my %clean  = %ENV;
  87     my $output = '';
  88     $ENV{CONTENT_TYPE}   ||= $request->header('Content-Type')   || '';
  89     $ENV{CONTENT_LENGTH} ||= $request->header('Content-Length') || '';
  90     $ENV{GATEWAY_INTERFACE} ||= 'CGI/1.1';
  91     $ENV{HTTP_USER_AGENT}   ||= 'Catalyst';
  92     $ENV{HTTP_HOST}         ||= $request->uri->host || 'localhost';
  93     $ENV{QUERY_STRING}      ||= $request->uri->query || '';
  94     $ENV{REQUEST_METHOD}    ||= $request->method;
  95     $ENV{PATH_INFO}         ||= $request->uri->path || '/';
  96     $ENV{SCRIPT_NAME}       ||= $request->uri->path || '/';
  97     $ENV{SERVER_NAME}       ||= $request->uri->host || 'localhost';
  98     $ENV{SERVER_PORT}       ||= $request->uri->port;
  99     $ENV{SERVER_PROTOCOL}   ||= 'HTTP/1.1';
 100
 101     for my $field ( $request->header_field_names ) {
 102         if ( $field =~ /^Content-(Length|Type)$/ ) {
 103             next;
 104         }
 105         $field =~ s/-/_/g;
 106         $ENV{ 'HTTP_' . uc($field) } = $request->header($field);
 107     }
 108     if ( $request->content_length ) {
 109         my $body = IO::File->new_tmpfile;
 110         $body->print( $request->content ) or die $!;
 111         $body->seek( 0, SEEK_SET ) or die $!;
 112         open( STDIN, "<&=", $body->fileno )
 113           or die("Failed to dup \$body: $!");
 114     }
 115     open( STDOUT, '>', \$output );
 116     $class->handler;
 117     %ENV = %clean;
 118     return HTTP::Response->parse($output);
 119 }
 120
 121 =head1 SEE ALSO
 122
 123 L<Catalyst>.
 124
 125 =head1 AUTHOR
 126
 127 Sebastian Riedel, C<sri@cpan.org>
 128
 129 =head1 COPYRIGHT
 130
 131 This program is free software, you can redistribute it and/or modify it under
 132 the same terms as Perl itself.
 133
 134 =cut
 135
 136 1;