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