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