view release on metacpan or  search on metacpan

lib/Catalyst/Engine.pm  view on Meta::CPAN

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::Headers;
use Plack::Loader;
use Catalyst::EngineLoader;
use Encode 2.21 'decode_utf8', 'encode', 'decode';
use Plack::Request::Upload;
use Hash::MultiValue;
use namespace::clean -except => 'meta';
use utf8;

# 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' , weak_ref=>1);
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<Catalyst>.

=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</write>
several times (which sends HTTP headers if needed) or you close over
C<< $response->write_fh >>.

See L<Catalyst::Response/write> and L<Catalyst::Response/write_fh> 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 after calling ->write.  We'd prefer not to
              # support this, but I can see some use cases with the way most of the
              # views work. Since body has already been encoded, we need to do
              # an 'unencoded_write' here.
              $self->unencoded_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,
                -samesite => $val->{samesite},
            )
        );
        if (!defined $cookie) {
            $c->log->warn("undef passed in '$name' cookie value - not setting cookie")
                if $c->debug;