lib/Catalyst/Test.pm

   1 package Catalyst::Test;
   2
   3 use strict;
   4 use UNIVERSAL::require;
   5 use HTTP::Response;
   6 use Socket;
   7 use URI;
   8
   9 my $class;
  10 $ENV{CATALYST_ENGINE} = 'CGI';
  11 $ENV{CATALYST_TEST}   = 1;
  12
  13 =head1 NAME
  14
  15 Catalyst::Test - Test Catalyst applications
  16
  17 =head1 SYNOPSIS
  18
  19     # Tests
  20     use Catalyst::Test 'TestApp';
  21     request('index.html');
  22     get('index.html');
  23
  24     # Request
  25     perl -MCatalyst::Test=MyApp -e1 index.html
  26
  27     # Server
  28     perl -MCatalyst::Test=MyApp -e1 3000
  29
  30 =head1 DESCRIPTION
  31
  32 Test Catalyst applications.
  33
  34 =head2 METHODS
  35
  36 =head3 get
  37
  38 Returns the content.
  39
  40     my $content = get('foo/bar?test=1');
  41
  42 =head3 request
  43
  44 Returns a C<HTTP::Response> object.
  45
  46     my $res =request('foo/bar?test=1');
  47
  48 =cut
  49
  50 {
  51     no warnings;
  52     CHECK {
  53         if ( ( caller(0) )[1] eq '-e' ) {
  54             if ( $ARGV[0] =~ /^\d+$/ ) { server( $ARGV[0] ) }
  55             else { print request( $ARGV[0] || 'http://localhost' )->content }
  56         }
  57     }
  58 }
  59
  60 sub import {
  61     my $self = shift;
  62     $class = shift;
  63     $class->require;
  64     unless ( $INC{'Test/Builder.pm'} ) {
  65         die qq/Couldn't load "$class", "$@"/ if $@;
  66     }
  67     my $caller = caller(0);
  68     no strict 'refs';
  69     *{"$caller\::request"} = \&request;
  70     *{"$caller\::get"} = sub { request(@_)->content };
  71 }
  72
  73 sub request {
  74     my $uri = shift;
  75     local *STDOUT;
  76     my $output = '';
  77     open STDOUT, '>', \$output;
  78     $uri = URI->new($uri);
  79     my %clean = %ENV;
  80     $ENV{REQUEST_METHOD} ||= 'GET';
  81     $ENV{HTTP_HOST}      ||= $uri->authority || 'localhost';
  82     $ENV{SCRIPT_NAME}    ||= $uri->path || '/';
  83     $ENV{QUERY_STRING}   ||= $uri->query || '';
  84     $ENV{CONTENT_TYPE}   ||= 'text/plain';
  85     $class->handler;
  86     %ENV = %clean;
  87     return HTTP::Response->parse($output);
  88 }
  89
  90 =head3 server
  91
  92 Starts a testserver.
  93
  94     Catalyst::Test::server(3000);
  95
  96 =cut
  97
  98 sub server {
  99     my $port = shift;
 100
 101     # Listen
 102     my $tcp = getprotobyname('tcp');
 103     socket( HTTPDaemon, PF_INET, SOCK_STREAM, $tcp ) or die $!;
 104     setsockopt( HTTPDaemon, SOL_SOCKET, SO_REUSEADDR, pack( "l", 1 ) )
 105       or warn $!;
 106     bind( HTTPDaemon, sockaddr_in( $port, INADDR_ANY ) ) or die $!;
 107     listen( HTTPDaemon, SOMAXCONN ) or die $!;
 108
 109     print "You can connect to your server at http://localhost:$port\n";
 110
 111     # Process
 112     my %clean = %ENV;
 113     for ( ; accept( Remote, HTTPDaemon ) ; close Remote ) {
 114         *STDIN  = *Remote;
 115         *STDOUT = *Remote;
 116         my $remote_sockaddr = getpeername(STDIN);
 117         my ( undef, $iaddr ) = sockaddr_in($remote_sockaddr);
 118         my $peername = gethostbyaddr( $iaddr, AF_INET ) || "localhost";
 119         my $peeraddr = inet_ntoa($iaddr) || "127.0.0.1";
 120         my $local_sockaddr = getsockname(STDIN);
 121         my ( undef, $localiaddr ) = sockaddr_in($local_sockaddr);
 122         my $localname = gethostbyaddr( $localiaddr, AF_INET ) || 'localhost';
 123         my $localaddr = inet_ntoa($localiaddr) || '127.0.0.1';
 124         my $chunk;
 125
 126         while ( sysread( STDIN, my $buff, 1 ) ) {
 127             last if $buff eq "\n";
 128             $chunk .= $buff;
 129         }
 130         my ( $method, $request_uri, $proto, undef ) = split /\s+/, $chunk;
 131         my ( $file, undef, $query_string ) =
 132           ( $request_uri =~ /([^?]*)(\?(.*))?/ );
 133         last if ( $method !~ /^(GET|POST|HEAD)$/ );
 134         %ENV = %clean;
 135
 136         $chunk = '';
 137         while ( sysread( STDIN, my $buff, 1 ) ) {
 138             if ( $buff eq "\n" ) {
 139                 $chunk =~ s/[\r\l\n\s]+$//;
 140                 if ( $chunk =~ /^([\w\-]+): (.+)/i ) {
 141                     my $tag = uc($1);
 142                     $tag =~ s/^COOKIES$/COOKIE/;
 143                     my $val = $2;
 144                     $tag =~ s/-/_/g;
 145                     $tag = "HTTP_" . $tag
 146                       unless ( grep /^$tag$/, qw(CONTENT_LENGTH CONTENT_TYPE) );
 147                     if ( $ENV{$tag} ) { $ENV{$tag} .= "; $val" }
 148                     else { $ENV{$tag} = $val }
 149                 }
 150                 last if $chunk =~ /^$/;
 151                 $chunk = '';
 152             }
 153             else { $chunk .= $buff }
 154         }
 155         $ENV{SERVER_PROTOCOL} = $proto;
 156         $ENV{SERVER_PORT}     = $port;
 157         $ENV{SERVER_NAME}     = $localname;
 158         $ENV{SERVER_URL}      = "http://$localname:$port/";
 159         $ENV{PATH_INFO}       = $file;
 160         $ENV{REQUEST_URI}     = $request_uri;
 161         $ENV{REQUEST_METHOD}  = $method;
 162         $ENV{REMOTE_ADDR}     = $peeraddr;
 163         $ENV{REMOTE_HOST}     = $peername;
 164         $ENV{QUERY_STRING}    = $query_string || '';
 165         $ENV{CONTENT_TYPE}    ||= 'multipart/form-data';
 166         $ENV{SERVER_SOFTWARE} ||= "Catalyst/$Catalyst::VERSION";
 167         $class->run;
 168     }
 169 }
 170
 171 =head1 SEE ALSO
 172
 173 L<Catalyst>.
 174
 175 =head1 AUTHOR
 176
 177 Sebastian Riedel, C<sri@cpan.org>
 178
 179 =head1 COPYRIGHT
 180
 181 This program is free software, you can redistribute it and/or modify it under
 182 the same terms as Perl itself.
 183
 184 =cut
 185
 186 1;