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     my $caller = ( caller(0) )[1];
  65     unless ( $INC{'Test/Builder.pm'} ) {
  66         die qq/Couldn't load "$class", "$@"/ if $@;
  67     }
  68     my $caller = caller(0);
  69     no strict 'refs';
  70     *{"$caller\::request"} = \&request;
  71     *{"$caller\::get"} = sub { request(@_)->content };
  72 }
  73
  74 sub request {
  75     my $uri = shift;
  76     local *STDOUT;
  77     my $output = '';
  78     open STDOUT, '>', \$output;
  79     $uri = URI->new($uri);
  80     my %clean = %ENV;
  81     $ENV{REQUEST_METHOD} ||= 'GET';
  82     $ENV{HTTP_HOST}      ||= $uri->authority || 'localhost';
  83     $ENV{SCRIPT_NAME}    ||= $uri->path || '/';
  84     $ENV{QUERY_STRING}   ||= $uri->query || '';
  85     $ENV{CONTENT_TYPE}   ||= 'text/plain';
  86     $class->handler;
  87     %ENV = %clean;
  88     return HTTP::Response->parse($output);
  89 }
  90
  91 =head3 server
  92
  93 Starts a testserver.
  94
  95     Catalyst::Test::server(3000);
  96
  97 =cut
  98
  99 sub server {
 100     my $port = shift;
 101
 102     # Listen
 103     my $tcp = getprotobyname('tcp');
 104     socket( HTTPDaemon, PF_INET, SOCK_STREAM, $tcp ) or die $!;
 105     setsockopt( HTTPDaemon, SOL_SOCKET, SO_REUSEADDR, pack( "l", 1 ) )
 106       or warn $!;
 107     bind( HTTPDaemon, sockaddr_in( $port, INADDR_ANY ) ) or die $!;
 108     listen( HTTPDaemon, SOMAXCONN ) or die $!;
 109
 110     print "You can connect to your server at http://localhost:$port\n";
 111
 112     # Process
 113     my %clean = %ENV;
 114     for ( ; accept( Remote, HTTPDaemon ) ; close Remote ) {
 115         *STDIN  = *Remote;
 116         *STDOUT = *Remote;
 117         my $remote_sockaddr = getpeername(STDIN);
 118         my ( undef, $iaddr ) = sockaddr_in($remote_sockaddr);
 119         my $peername = gethostbyaddr( $iaddr, AF_INET ) || "localhost";
 120         my $peeraddr = inet_ntoa($iaddr) || "127.0.0.1";
 121         my $local_sockaddr = getsockname(STDIN);
 122         my ( undef, $localiaddr ) = sockaddr_in($local_sockaddr);
 123         my $localname = gethostbyaddr( $localiaddr, AF_INET ) || 'localhost';
 124         my $localaddr = inet_ntoa($localiaddr) || '127.0.0.1';
 125         my $chunk;
 126
 127         while ( sysread( STDIN, my $buff, 1 ) ) {
 128             last if $buff eq "\n";
 129             $chunk .= $buff;
 130         }
 131         my ( $method, $request_uri, $proto, undef ) = split /\s+/, $chunk;
 132         my ( $file, undef, $query_string ) =
 133           ( $request_uri =~ /([^?]*)(\?(.*))?/ );
 134         last if ( $method !~ /^(GET|POST|HEAD)$/ );
 135         %ENV = %clean;
 136
 137         $chunk = '';
 138         while ( sysread( STDIN, my $buff, 1 ) ) {
 139             if ( $buff eq "\n" ) {
 140                 $chunk =~ s/[\r\l\n\s]+$//;
 141                 if ( $chunk =~ /^([\w\-]+): (.+)/i ) {
 142                     my $tag = uc($1);
 143                     $tag =~ s/^COOKIES$/COOKIE/;
 144                     my $val = $2;
 145                     $tag =~ s/-/_/g;
 146                     $tag = "HTTP_" . $tag
 147                       unless ( grep /^$tag$/, qw(CONTENT_LENGTH CONTENT_TYPE) );
 148                     if ( $ENV{$tag} ) { $ENV{$tag} .= "; $val" }
 149                     else { $ENV{$tag} = $val }
 150                 }
 151                 last if $chunk =~ /^$/;
 152                 $chunk = '';
 153             }
 154             else { $chunk .= $buff }
 155         }
 156         $ENV{SERVER_PROTOCOL} = $proto;
 157         $ENV{SERVER_PORT}     = $port;
 158         $ENV{SERVER_NAME}     = $localname;
 159         $ENV{SERVER_URL}      = "http://$localname:$port/";
 160         $ENV{PATH_INFO}       = $file;
 161         $ENV{REQUEST_URI}     = $request_uri;
 162         $ENV{REQUEST_METHOD}  = $method;
 163         $ENV{REMOTE_ADDR}     = $peeraddr;
 164         $ENV{REMOTE_HOST}     = $peername;
 165         $ENV{QUERY_STRING}    = $query_string || '';
 166         $ENV{CONTENT_TYPE}    ||= 'multipart/form-data';
 167         $ENV{SERVER_SOFTWARE} ||= "Catalyst/$Catalyst::VERSION";
 168         $class->run;
 169     }
 170 }
 171
 172 =head1 SEE ALSO
 173
 174 L<Catalyst>.
 175
 176 =head1 AUTHOR
 177
 178 Sebastian Riedel, C<sri@cpan.org>
 179
 180 =head1 COPYRIGHT
 181
 182 This program is free software, you can redistribute it and/or modify it under
 183 the same terms as Perl itself.
 184
 185 =cut
 186
 187 1;