package Catalyst::Engine;
use Moose;
with 'MooseX::Emulate::Class::Accessor::Fast';
use CGI::Simple::Cookie;
use Data::Dump qw/dump/;
use Errno 'EWOULDBLOCK';
use HTML::Entities;
use HTTP::Body;
use HTTP::Headers;
use URI::QueryParam;
use Plack::Loader;
use Catalyst::EngineLoader;
use Encode ();
use Plack::Request::Upload;
use Hash::MultiValue;
use utf8;
use namespace::clean -except => 'meta';
# Amount of data to read from input on each pass
our $CHUNKSIZE = 64 * 1024;
# XXX - this is only here for compat, do not use!
has env => ( is => 'rw', writer => '_set_env' );
my $WARN_ABOUT_ENV = 0;
around env => sub {
my ($orig, $self, @args) = @_;
if(@args) {
warn "env as a writer is deprecated, you probably need to upgrade Catalyst::Engine::PSGI"
unless $WARN_ABOUT_ENV++;
return $self->_set_env(@args);
}
return $self->$orig;
};
# XXX - Only here for Engine::PSGI compat
sub prepare_connection {
my ($self, $ctx) = @_;
$ctx->request->prepare_connection;
}
=head1 NAME
Catalyst::Engine - The Catalyst Engine
=head1 SYNOPSIS
See L.
=head1 DESCRIPTION
=head1 METHODS
=head2 $self->finalize_body($c)
Finalize body. Prints the response output as blocking stream if it looks like
a filehandle, otherwise write it out all in one go. If there is no body in
the response, we assume you are handling it 'manually', such as for nonblocking
style or asynchronous streaming responses. You do this by calling L
several times (which sends HTTP headers if needed) or you close over
C<< $response->write_fh >>.
See L and L for more.
=cut
sub finalize_body {
my ( $self, $c ) = @_;
my $res = $c->response; # We use this all over
## If we've asked for the write 'filehandle' that means the application is
## doing something custom and is expected to close the response
return if $res->_has_write_fh;
my $body = $res->body; # save some typing
if($res->_has_response_cb) {
## we have not called the response callback yet, so we are safe to send
## the whole body to PSGI
my @headers;
$res->headers->scan(sub { push @headers, @_ });
# We need to figure out what kind of body we have and normalize it to something
# PSGI can deal with
if(defined $body) {
# Handle objects first
if(blessed($body)) {
if($body->can('getline')) {
# Body is an IO handle that meets the PSGI spec. Nothing to normalize
} elsif($body->can('read')) {
# In the past, Catalyst only looked for ->read not ->getline. It is very possible
# that one might have an object that respected read but did not have getline.
# As a result, we need to handle this case for backcompat.
# We will just do the old loop for now. In a future version of Catalyst this support
# will be removed and one will have to rewrite their custom object or use
# Plack::Middleware::AdaptFilehandleRead. In anycase support for this is officially
# deprecated and described as such as of 5.90060
my $got;
do {
$got = read $body, my ($buffer), $CHUNKSIZE;
$got = 0 unless $self->write($c, $buffer );
} while $got > 0;
close $body;
return;
} else {
# Looks like for backcompat reasons we need to be able to deal
# with stringyfiable objects.
$body = ["$body"];
}
} elsif(ref $body) {
if( (ref($body) eq 'GLOB') or (ref($body) eq 'ARRAY')) {
# Again, PSGI can just accept this, no transform needed. We don't officially
# document the body as arrayref at this time (and there's not specific test
# cases. we support it because it simplifies some plack compatibility logic
# and we might make it official at some point.
} else {
$c->log->error("${\ref($body)} is not a valid value for Response->body");
return;
}
} else {
# Body is defined and not an object or reference. We assume a simple value
# and wrap it in an array for PSGI
$body = [$body];
}
} else {
# There's no body...
$body = [];
}
$res->_response_cb->([ $res->status, \@headers, $body]);
$res->_clear_response_cb;
} else {
## Now, if there's no response callback anymore, that means someone has
## called ->write in order to stream 'some stuff along the way'. I think
## for backcompat we still need to handle a ->body. I guess I could see
## someone calling ->write to presend some stuff, and then doing the rest
## via ->body, like in a template.
## We'll just use the old, existing code for this (or most of it)
if(my $body = $res->body) {
if ( blessed($body) && $body->can('read') or ref($body) eq 'GLOB' ) {
## In this case we have no choice and will fall back on the old
## manual streaming stuff. Not optimal. This is deprecated as of 5.900560+
my $got;
do {
$got = read $body, my ($buffer), $CHUNKSIZE;
$got = 0 unless $self->write($c, $buffer );
} while $got > 0;
close $body;
}
else {
# Case where body was set afgter calling ->write. We'd prefer not to
# support this, but I can see some use cases with the way most of the
# views work.
$self->write($c, $body );
}
}
$res->_writer->close;
$res->_clear_writer;
}
return;
}
=head2 $self->finalize_cookies($c)
Create CGI::Simple::Cookie objects from $c->res->cookies, and set them as
response headers.
=cut
sub finalize_cookies {
my ( $self, $c ) = @_;
my @cookies;
my $response = $c->response;
foreach my $name (keys %{ $response->cookies }) {
my $val = $response->cookies->{$name};
my $cookie = (
blessed($val)
? $val
: CGI::Simple::Cookie->new(
-name => $name,
-value => $val->{value},
-expires => $val->{expires},
-domain => $val->{domain},
-path => $val->{path},
-secure => $val->{secure} || 0,
-httponly => $val->{httponly} || 0,
)
);
if (!defined $cookie) {
$c->log->warn("undef passed in '$name' cookie value - not setting cookie")
if $c->debug;
next;
}
push @cookies, $cookie->as_string;
}
for my $cookie (@cookies) {
$response->headers->push_header( 'Set-Cookie' => $cookie );
}
}
=head2 $self->finalize_error($c)
Output an appropriate error message. Called if there's an error in $c
after the dispatch has finished. Will output debug messages if Catalyst
is in debug mode, or a `please come back later` message otherwise.
=cut
sub _dump_error_page_element {
my ($self, $i, $element) = @_;
my ($name, $val) = @{ $element };
# This is fugly, but the metaclass is _HUGE_ and demands waaay too much
# scrolling. Suggestions for more pleasant ways to do this welcome.
local $val->{'__MOP__'} = "Stringified: "
. $val->{'__MOP__'} if ref $val eq 'HASH' && exists $val->{'__MOP__'};
my $text = encode_entities( dump( $val ));
sprintf <%s