=head1 OVERLOADED METHODS
-This class overloads some methods from C<Catalyst>.
+This class overloads some methods from C<Catalyst::Engine>.
=over 4
--- /dev/null
+package Catalyst::Engine::HTTP;
+
+use strict;
+use base 'Catalyst::Engine';
+
+use CGI::Simple::Cookie;
+use Class::Struct ();
+use HTTP::Headers::Util 'split_header_words';
+use HTTP::Request;
+use HTTP::Response;
+use IO::File;
+use URI;
+
+__PACKAGE__->mk_accessors(qw/http/);
+
+Class::Struct::struct 'Catalyst::Engine::HTTP::LWP' => {
+ request => 'HTTP::Request',
+ response => 'HTTP::Response',
+ hostname => '$',
+ address => '$'
+};
+
+
+=head1 NAME
+
+Catalyst::Engine::HTTP - Catalyst HTTP Engine
+
+=head1 SYNOPSIS
+
+L<Catalyst>.
+
+=head1 DESCRIPTION
+
+This Catalyst engine is meant to be subclassed.
+
+=head1 OVERLOADED METHODS
+
+This class overloads some methods from C<Catalyst::Engine>.
+
+=over 4
+
+=item $c->finalize_headers
+
+=cut
+
+sub finalize_headers {
+ my $c = shift;
+
+ my $status = $c->response->status || 200;
+ my $headers = $c->response->headers;
+ my $response = HTTP::Response->new( $status, undef, $headers );
+
+ while ( my ( $name, $cookie ) = each %{ $c->response->cookies } ) {
+ my $cookie = CGI::Simple::Cookie->new(
+ -name => $name,
+ -value => $cookie->{value},
+ -expires => $cookie->{expires},
+ -domain => $cookie->{domain},
+ -path => $cookie->{path},
+ -secure => $cookie->{secure} || 0
+ );
+
+ $response->header( 'Set-Cookie' => $cookie->as_string );
+ }
+
+ $c->http->response($response);
+}
+
+=item $c->finalize_output
+
+=cut
+
+sub finalize_output {
+ my $c = shift;
+ $c->http->response->content_ref( \$c->response->{output} );
+}
+
+=item $c->prepare_connection
+
+=cut
+
+sub prepare_connection {
+ my $c = shift;
+ $c->req->hostname( $c->http->hostname );
+ $c->req->address( $c->http->address );
+}
+
+=item $c->prepare_cookies
+
+=cut
+
+sub prepare_cookies {
+ my $c = shift;
+
+ if ( my $header = $c->http->request->header('Cookie') ) {
+ $c->req->cookies( { CGI::Simple::Cookie->parse($header) } );
+ }
+}
+
+=item $c->prepare_headers
+
+=cut
+
+sub prepare_headers {
+ my $c = shift;
+ $c->req->method( $c->http->request->method );
+ $c->req->headers( $c->http->request->headers );
+}
+
+=item $c->prepare_parameters
+
+=cut
+
+sub prepare_parameters {
+ my $c = shift;
+
+ my @params = ();
+ my $request = $c->http->request;
+
+ push( @params, $request->uri->query_form );
+
+ if ( $request->content_type eq 'application/x-www-form-urlencoded' ) {
+ my $uri = URI->new('http:');
+ $uri->query( $request->content );
+ push( @params, $uri->query_form );
+ }
+
+ if ( $request->content_type eq 'multipart/form-data' ) {
+
+ for my $part ( $request->parts ) {
+
+ my $disposition = $part->header('Content-Disposition');
+ my %parameters = @{ ( split_header_words($disposition) )[0] };
+
+ if ( $parameters{filename} ) {
+
+ my $fh = IO::File->new_tmpfile;
+ $fh->write( $part->content ) or die $!;
+ $fh->seek( SEEK_SET, 0 ) or die $!;
+
+ $c->req->uploads->{ $parameters{filename} } = {
+ fh => $fh,
+ size => ( stat $fh )[7],
+ type => $part->content_type
+ };
+
+ push( @params, $parameters{filename}, $fh );
+ }
+ else {
+ push( @params, $parameters{name}, $part->content );
+ }
+ }
+ }
+
+ my $parameters = $c->req->parameters;
+
+ while ( my ( $name, $value ) = splice( @params, 0, 2 ) ) {
+
+ if ( exists $parameters->{$name} ) {
+ for ( $parameters->{$name} ) {
+ $_ = [$_] unless ref($_) eq "ARRAY";
+ push( @$_, $value );
+ }
+ }
+ else {
+ $parameters->{$name} = $value;
+ }
+ }
+}
+
+=item $c->prepare_path
+
+=cut
+
+sub prepare_path {
+ my $c = shift;
+
+ my $base;
+ {
+ my $scheme = $c->http->request->uri->scheme;
+ my $host = $c->http->request->uri->host;
+ my $port = $c->http->request->uri->port;
+
+ $base = URI->new;
+ $base->scheme($scheme);
+ $base->host($host);
+ $base->port($port);
+
+ $base = $base->canonical->as_string;
+ }
+
+ my $path = $c->http->request->uri->path || '/';
+ $path =~ s/^\///;
+
+ $c->req->base($base);
+ $c->req->path($path);
+}
+
+=item $c->prepare_request($r)
+
+=cut
+
+sub prepare_request {
+ my ( $c, $http ) = @_;
+ $c->http($http);
+}
+
+=item $c->prepare_uploads
+
+=cut
+
+sub prepare_uploads {
+ my $c = shift;
+}
+
+=back
+
+=head1 SEE ALSO
+
+L<Catalyst>.
+
+=head1 AUTHOR
+
+Sebastian Riedel, C<sri@cpan.org>
+Christian Hansen, C<ch@ngmedia.com>
+
+=head1 COPYRIGHT
+
+This program is free software, you can redistribute it and/or modify it under
+the same terms as Perl itself.
+
+=cut
+
+1;
--- /dev/null
+package Catalyst::Engine::HTTP::Daemon;
+
+use strict;
+use base 'Catalyst::Engine::HTTP';
+
+use IO::Socket qw(AF_INET);
+
+=head1 NAME
+
+Catalyst::Engine::HTTP::Daemon - Catalyst HTTP Daemon Engine
+
+=head1 SYNOPSIS
+
+A script using the Catalyst::Engine::HTTP::Daemon module might look like:
+
+ #!/usr/bin/perl -w
+
+ BEGIN {
+ $ENV{CATALYST_ENGINE} = 'HTTP::Daemon';
+ }
+
+ use strict;
+ use lib '/path/to/MyApp/lib';
+ use MyApp;
+
+ MyApp->run;
+
+=head1 DESCRIPTION
+
+This is the Catalyst engine specialized for development and testing.
+
+=head1 OVERLOADED METHODS
+
+This class overloads some methods from C<Catalyst::Engine::HTTP>.
+
+=over 4
+
+=item $c->run
+
+=cut
+
+$SIG{'PIPE'} = 'IGNORE';
+
+sub run {
+ my $class = shift;
+ my $port = shift || 3000;
+
+ my $daemon = Catalyst::Engine::HTTP::Daemon::Catalyst->new(
+ LocalPort => $port,
+ ReuseAddr => 1
+ );
+
+ unless ( $daemon ) {
+ die( "Failed to create daemon: $!\n" );
+ }
+
+ printf( "You can connect to your server at %s\n", $daemon->url );
+
+ while ( my $connection = $daemon->accept ) {
+
+ while ( my $request = $connection->get_request ) {
+
+ $request->uri->scheme('http'); # Force URI::http
+
+ my $http = Catalyst::Engine::HTTP::LWP->new(
+ request => $request,
+ address => $connection->peerhost,
+ hostname => gethostbyaddr( $connection->peeraddr, AF_INET )
+ );
+
+ $class->handler($http);
+ $connection->send_response( $http->response );
+ }
+
+ $connection->close;
+ undef($connection);
+ }
+}
+
+=back
+
+=head1 SEE ALSO
+
+L<Catalyst>, L<HTTP::Daemon>.
+
+=head1 AUTHOR
+
+Sebastian Riedel, C<sri@cpan.org>
+Christian Hansen, C<ch@ngmedia.com>
+
+=head1 COPYRIGHT
+
+This program is free software, you can redistribute it and/or modify it under
+the same terms as Perl itself.
+
+=cut
+
+package Catalyst::Engine::HTTP::Daemon::Catalyst;
+
+use strict;
+use base 'HTTP::Daemon';
+
+sub product_tokens {
+ "Catalyst/$Catalyst::VERSION";
+}
+
+1;
+
--- /dev/null
+package Catalyst::Engine::HTTP::Server;
+
+use strict;
+use base 'Catalyst::Engine::CGI::NPH';
+
+=head1 NAME
+
+Catalyst::Engine::HTTP::Server - Catalyst HTTP Server Engine
+
+=head1 SYNOPSIS
+
+A script using the Catalyst::Engine::HTTP::Server module might look like:
+
+ #!/usr/bin/perl -w
+
+ BEGIN {
+ $ENV{CATALYST_ENGINE} = 'HTTP::Server';
+ }
+
+ use strict;
+ use lib '/path/to/MyApp/lib';
+ use MyApp;
+
+ MyApp->run;
+
+=head1 DESCRIPTION
+
+This is the Catalyst engine specialized for development and testing.
+
+=head1 OVERLOADED METHODS
+
+This class overloads some methods from C<Catalyst::Engine::CGI::NPH>.
+
+=over 4
+
+=item $c->run
+
+=cut
+
+sub run {
+ my $class = shift;
+ my $port = shift || 3000;
+
+ my $server = Catalyst::Engine::Server::Simple->new($port);
+
+ $server->handler( sub { $class->handler } );
+ $server->run;
+}
+
+=back
+
+=head1 SEE ALSO
+
+L<Catalyst>, L<HTTP::Server::Simple>.
+
+=head1 AUTHOR
+
+Sebastian Riedel, C<sri@cpan.org>
+Christian Hansen, C<ch@ngmedia.com>
+
+=head1 COPYRIGHT
+
+This program is free software, you can redistribute it and/or modify it under
+the same terms as Perl itself.
+
+=cut
+
+package Catalyst::Engine::Server::Simple;
+
+use strict;
+use base 'HTTP::Server::Simple';
+
+my %CLEAN_ENV = %ENV;
+
+sub handler {
+ my $self = shift;
+
+ if (@_) {
+ $self->{handler} = shift;
+ }
+
+ else {
+ $self->{handler}->();
+ }
+}
+
+sub print_banner {
+ my $self = shift;
+
+ printf(
+ "You can connect to your server at http://%s:%d/\n",
+ $self->host || 'localhost',
+ $self->port
+ );
+}
+
+sub accept_hook {
+ %ENV = ( %CLEAN_ENV, SERVER_SOFTWARE => "Catalyst/$Catalyst::VERSION" );
+}
+
+our %env_mapping = (
+ protocol => "SERVER_PROTOCOL",
+ localport => "SERVER_PORT",
+ localname => "SERVER_NAME",
+ path => "PATH_INFO",
+ request_uri => "REQUEST_URI",
+ method => "REQUEST_METHOD",
+ peeraddr => "REMOTE_ADDR",
+ peername => "REMOTE_HOST",
+ query_string => "QUERY_STRING",
+);
+
+sub setup {
+ no warnings 'uninitialized';
+ my $self = shift;
+
+ while ( my ( $item, $value ) = splice @_, 0, 2 ) {
+ if ( $self->can($item) ) {
+ $self->$item($value);
+ }
+ elsif ( my $k = $env_mapping{$item} ) {
+ $ENV{$k} = $value;
+ }
+ }
+}
+
+sub headers {
+ my $self = shift;
+ my $headers = shift;
+
+ while ( my ( $tag, $value ) = splice @{$headers}, 0, 2 ) {
+ $tag = uc($tag);
+ $tag =~ s/^COOKIES$/COOKIE/;
+ $tag =~ s/-/_/g;
+ $tag = "HTTP_" . $tag
+ unless $tag =~ m/^CONTENT_(?:LENGTH|TYPE)$/;
+
+ if ( exists $ENV{$tag} ) {
+ $ENV{$tag} .= "; $value";
+ }
+ else {
+ $ENV{$tag} = $value;
+ }
+ }
+}
+
+1;
package Catalyst::Engine::Server;
use strict;
-use base 'Catalyst::Engine::CGI::NPH';
+use base 'Catalyst::Engine::HTTP::Daemon';
=head1 NAME
This is the Catalyst engine specialized for development and testing.
-=head1 OVERLOADED METHODS
-
-This class overloads some methods from C<Catalyst::Engine::CGI::NPH>.
-
-=over 4
-
-=item $c->run
-
-=cut
-
-sub run {
- my $class = shift;
- my $port = shift || 3000;
-
- my $server = Catalyst::Engine::Server::Simple->new($port);
-
- $server->handler( sub { $class->handler } );
- $server->run;
-}
-
-=back
-
=head1 SEE ALSO
-L<Catalyst>, L<HTTP::Server::Simple>.
+L<Catalyst>, L<Catalyst::Engine::HTTP::Daemon>.
=head1 AUTHOR
=cut
-package Catalyst::Engine::Server::Simple;
-
-use strict;
-use base 'HTTP::Server::Simple';
-
-my %CLEAN_ENV = %ENV;
-
-sub handler {
- my $self = shift;
-
- if (@_) {
- $self->{handler} = shift;
- }
-
- else {
- $self->{handler}->();
- }
-}
-
-sub print_banner {
- my $self = shift;
-
- printf(
- "You can connect to your server at http://%s:%d/\n",
- $self->host || 'localhost',
- $self->port
- );
-}
-
-sub accept_hook {
- %ENV = ( %CLEAN_ENV, SERVER_SOFTWARE => "Catalyst/$Catalyst::VERSION" );
-}
-
-our %env_mapping = (
- protocol => "SERVER_PROTOCOL",
- localport => "SERVER_PORT",
- localname => "SERVER_NAME",
- path => "PATH_INFO",
- request_uri => "REQUEST_URI",
- method => "REQUEST_METHOD",
- peeraddr => "REMOTE_ADDR",
- peername => "REMOTE_HOST",
- query_string => "QUERY_STRING",
-);
-
-sub setup {
- no warnings 'uninitialized';
- my $self = shift;
-
- while ( my ( $item, $value ) = splice @_, 0, 2 ) {
- if ( $self->can($item) ) {
- $self->$item($value);
- }
- elsif ( my $k = $env_mapping{$item} ) {
- $ENV{$k} = $value;
- }
- }
-}
-
-sub headers {
- my $self = shift;
- my $headers = shift;
-
- while ( my ( $tag, $value ) = splice @{$headers}, 0, 2 ) {
- $tag = uc($tag);
- $tag =~ s/^COOKIES$/COOKIE/;
- $tag =~ s/-/_/g;
- $tag = "HTTP_" . $tag
- unless $tag =~ m/^CONTENT_(?:LENGTH|TYPE)$/;
-
- if ( exists $ENV{$tag} ) {
- $ENV{$tag} .= "; $value";
- }
- else {
- $ENV{$tag} = $value;
- }
- }
-}
-
1;
package Catalyst::Engine::Test;
use strict;
-use base 'Catalyst::Engine::CGI::NPH';
-
-use HTTP::Request;
-use HTTP::Response;
-use IO::File;
-use URI;
+use base 'Catalyst::Engine::HTTP';
=head1 NAME
=head1 OVERLOADED METHODS
-This class overloads some methods from C<Catalyst::Engine::CGI::NPH>.
+This class overloads some methods from C<Catalyst::Engine::HTTP>.
=over 4
my $request = shift || '/';
unless ( ref $request ) {
- $request = URI->new( $request, 'http' );
+
+ my $uri = ( $request =~ m/http/i )
+ ? URI->new($request)
+ : URI->new( 'http://localhost' . $request );
+
+ $request = $uri->canonical;
}
+
unless ( ref $request eq 'HTTP::Request' ) {
$request = HTTP::Request->new( 'GET', $request );
}
- local ( *STDIN, *STDOUT );
-
- my %clean = %ENV;
- my $output = '';
- $ENV{CONTENT_TYPE} ||= $request->header('Content-Type') || '';
- $ENV{CONTENT_LENGTH} ||= $request->header('Content-Length') || '';
- $ENV{GATEWAY_INTERFACE} ||= 'CGI/1.1';
- $ENV{HTTP_USER_AGENT} ||= 'Catalyst';
- $ENV{HTTP_HOST} ||= $request->uri->host || 'localhost';
- $ENV{QUERY_STRING} ||= $request->uri->query || '';
- $ENV{REQUEST_METHOD} ||= $request->method;
- $ENV{PATH_INFO} ||= $request->uri->path || '/';
- $ENV{SCRIPT_NAME} ||= '/';
- $ENV{SERVER_NAME} ||= $request->uri->host || 'localhost';
- $ENV{SERVER_PORT} ||= $request->uri->port;
- $ENV{SERVER_PROTOCOL} ||= 'HTTP/1.1';
-
- for my $field ( $request->header_field_names ) {
- if ( $field =~ /^Content-(Length|Type)$/ ) {
- next;
- }
- $field =~ s/-/_/g;
- $ENV{ 'HTTP_' . uc($field) } = $request->header($field);
- }
+ my $http = Catalyst::Engine::HTTP::LWP->new(
+ request => $request,
+ address => '127.0.0.1',
+ hostname => 'localhost'
+ );
- if ( $request->content_length ) {
- my $body = IO::File->new_tmpfile;
- $body->print( $request->content ) or die $!;
- $body->seek( 0, SEEK_SET ) or die $!;
- open( STDIN, "<&=", $body->fileno )
- or die("Failed to dup \$body: $!");
- }
+ $class->handler($http);
- open( STDOUT, '>', \$output );
- $class->handler;
- %ENV = %clean;
- return HTTP::Response->parse($output);
+ return $http->response;
}
=back
=head1 DESCRIPTION
-No questions yet, everything perfect...
+Frequently Asked Questions
+
+=head2 How do I regenerate the helper scripts?
+
+Create a new app with the same name and copy scripts/ to app directory
=head1 AUTHOR
request('index.html');
get('index.html');
+ # Run tests against a remote server
+ CATALYST_REMOTE='http://localhost:3000/' prove -l lib/ t/
+
# Tests with inline apps need to use Catalyst::Engine::Test
package TestApp;
sub import {
my $self = shift;
- if ( my $class = shift ) {
+ my $class = shift;
+
+ my ( $get, $request );
+
+ if ( $ENV{CATALYST_REMOTE} ) {
+ $request = sub { remote_request(@_) };
+ $get = sub { remote_request(@_)->content };
+ }
+
+ else {
$class->require;
unless ( $INC{'Test/Builder.pm'} ) {
die qq/Couldn't load "$class", "$@"/ if $@;
}
- no strict 'refs';
- my $caller = caller(0);
- *{"$caller\::request"} = sub { $class->run(@_) };
- *{"$caller\::get"} = sub { $class->run(@_)->content };
+ $request = sub { $class->run(@_) };
+ $get = sub { $class->run(@_)->content };
}
+
+ no strict 'refs';
+ my $caller = caller(0);
+ *{"$caller\::request"} = $request;
+ *{"$caller\::get"} = $get;
+}
+
+sub remote_request {
+ my $request = shift;
+
+ require LWP::UserAgent;
+
+ my $remote = URI->new( $ENV{CATALYST_REMOTE} );
+
+ unless ( ref $request ) {
+
+ my $uri = ( $request =~ m/http/i )
+ ? URI->new($request)
+ : URI->new( 'http://localhost' . $request );
+
+ $request = $uri->canonical;
+ }
+
+ $request->scheme( $remote->scheme );
+ $request->host( $remote->host );
+ $request->port( $remote->port );
+
+ unless ( ref $request eq 'HTTP::Request' ) {
+ $request = HTTP::Request->new( 'GET', $request );
+ }
+
+ my $agent = LWP::UserAgent->new;
+
+ return $agent->request($request);
}
=head1 SEE ALSO
package main;
-use Test::More tests => 9;
+use Test::More tests => 6;
use Catalyst::Test 'TestApp';
{
local %ENV;
- $ENV{SCRIPT_NAME} = '/nph-catalyst.cgi';
- $ENV{PATH_INFO} = '/index';
-
- my $response = request('/nph-catalyst.cgi/index');
-
- ok( $response->headers->header('X-Base') eq 'http://localhost/nph-catalyst.cgi' );
- ok( $response->headers->header('X-Arguments') eq 'index' );
- ok( $response->headers->header('X-Path') eq 'index' );
-}
-
-{
- local %ENV;
-
my $response = request('/index?a=a&b=b');
ok( $response->headers->header('X-Base') eq 'http://localhost/' );
projects / catagits/Catalyst-Runtime.git / commitdiff