X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=catagits%2FCatalyst-Runtime.git;a=blobdiff_plain;f=lib%2FCatalyst%2FEngine.pm;h=fdd3df9046f4fd849e12fabc04e78ecafb402128;hp=f378d57d6f4de367b7ac872bcaa21c7c0f20f61b;hb=fbd5d4fa65e4e10dd160ae5637e4b94a5b0d54f4;hpb=fbcc39ad23f2bbecf5d84c9ba581e6af86fcd460 diff --git a/lib/Catalyst/Engine.pm b/lib/Catalyst/Engine.pm index f378d57..fdd3df9 100644 --- a/lib/Catalyst/Engine.pm +++ b/lib/Catalyst/Engine.pm @@ -1,18 +1,42 @@ package Catalyst::Engine; -use strict; -use base 'Class::Accessor::Fast'; -use CGI::Cookie; -use Data::Dumper; +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; - -# input position and length -__PACKAGE__->mk_accessors( qw/read_position read_length/ ); - -# Stringify to class -use overload '""' => sub { return ref shift }, fallback => 1; +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 @@ -26,25 +50,134 @@ See L. =head1 METHODS -=over 4 - -=item $self->finalize_output -, see finalize_body +=head2 $self->finalize_body($c) -=item $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 >>. -Finalize body. Prints the response output. +See L and L for more. =cut sub finalize_body { my ( $self, $c ) = @_; - - $self->write( $c, $c->response->output ); + 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; } -=item $self->finalize_cookies($c) +=head2 $self->finalize_cookies($c) + +Create CGI::Simple::Cookie objects from $c->res->cookies, and set them as +response headers. =cut @@ -52,68 +185,106 @@ sub finalize_cookies { my ( $self, $c ) = @_; my @cookies; - while ( my ( $name, $cookie ) = each %{ $c->response->cookies } ) { - - my $cookie = CGI::Cookie->new( - -name => $name, - -value => $cookie->{value}, - -expires => $cookie->{expires}, - -domain => $cookie->{domain}, - -path => $cookie->{path}, - -secure => $cookie->{secure} || 0 + 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; } - if (@cookies) { - $c->res->headers->push_header( 'Set-Cookie' => join ',', @cookies ); + for my $cookie (@cookies) { + $response->headers->push_header( 'Set-Cookie' => $cookie ); } } -=item $self->finalize_error($c) +=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 <<"EOF", $name, $text; +

%s

+
+ 
%s
+
+EOF +} + sub finalize_error { my ( $self, $c ) = @_; - $c->res->headers->content_type('text/html'); - my $name = $c->config->{name} || 'Catalyst Application'; + $c->res->content_type('text/html; charset=utf-8'); + my $name = ref($c)->config->{name} || join(' ', split('::', ref $c)); + + # Prevent Catalyst::Plugin::Unicode::Encoding from running. + # This is a little nasty, but it's the best way to be clean whether or + # not the user has an encoding plugin. + + if ($c->can('encoding')) { + $c->{encoding} = ''; + } my ( $title, $error, $infos ); if ( $c->debug ) { # For pretty dumps - local $Data::Dumper::Terse = 1; - $error = join '', - map { '' . encode_entities($_) . '' } - @{ $c->error }; + $error = join '', map { + '

' + . encode_entities($_) + . '

' + } @{ $c->error }; $error ||= 'No output'; + $error = qq{
$error
}; $title = $name = "$name on Catalyst $Catalyst::VERSION"; + $name = "

$name

"; # Don't show context in the dump - delete $c->req->{_context}; - delete $c->res->{_context}; + $c->res->_clear_context; # Don't show body parser in the dump - delete $c->req->{_body}; - - # Don't show response header state in dump - delete $c->res->{_finalized_headers}; - - my $req = encode_entities Dumper $c->req; - my $res = encode_entities Dumper $c->res; - my $stash = encode_entities Dumper $c->stash; - $infos = <<""; -
-Request
-
$req
-Response
-
$res
-Stash
-
$stash
+ $c->req->_clear_body; + my @infos; + my $i = 0; + for my $dump ( $c->dump_these ) { + push @infos, $self->_dump_error_page_element($i, $dump); + $i++; + } + $infos = join "\n", @infos; } else { $title = $name; @@ -121,65 +292,107 @@ sub finalize_error { $infos = <<""; 
 (en) Please come back later
+(fr) SVP veuillez revenir plus tard
 (de) Bitte versuchen sie es spaeter nocheinmal
-(nl) Gelieve te komen later terug
+(at) Konnten's bitt'schoen spaeter nochmal reinschauen
 (no) Vennligst prov igjen senere
-(fr) Veuillez revenir plus tard
-(es) Vuelto por favor mas adelante
-(pt) Voltado por favor mais tarde
-(it) Ritornato prego più successivamente
+(dk) Venligst prov igen senere
+(pl) Prosze sprobowac pozniej
+(pt) Por favor volte mais tarde
+(ru) Попробуйте еще раз позже
+(ua) Спробуйте ще раз пізніше
+(it) Per favore riprova più tardi
$name = ''; } $c->res->body( <<"" ); - + + + + $title + @@ -192,271 +405,441 @@ sub finalize_error { -} + # Trick IE. Old versions of IE would display their own error page instead + # of ours if we'd give it less than 512 bytes. + $c->res->{body} .= ( ' ' x 512 ); -=item $self->finalize_headers($c) + $c->res->{body} = Encode::encode("UTF-8", $c->res->{body}); -=cut + # Return 500 + $c->res->status(500); +} -sub finalize_headers { } +=head2 $self->finalize_headers($c) -=item $self->finalize_read($c) +Allows engines to write headers to response =cut -sub finalize_read { - my ( $self, $c ) = @_; - - undef $self->{_prepared_read}; +sub finalize_headers { + my ($self, $ctx) = @_; + + $ctx->finalize_headers unless $ctx->response->finalized_headers; + return; } -=item $self->finalize_uploads($c) +=head2 $self->finalize_uploads($c) + +Clean up after uploads, deleting temp files. =cut sub finalize_uploads { my ( $self, $c ) = @_; - if ( keys %{ $c->request->uploads } ) { - for my $key ( keys %{ $c->request->uploads } ) { - my $upload = $c->request->uploads->{$key}; - unlink map { $_->tempname } - grep { -e $_->tempname } - ref $upload eq 'ARRAY' ? @{$upload} : ($upload); - } + # N.B. This code is theoretically entirely unneeded due to ->cleanup(1) + # on the HTTP::Body object. + my $request = $c->request; + foreach my $key (keys %{ $request->uploads }) { + my $upload = $request->uploads->{$key}; + unlink grep { -e $_ } map { $_->tempname } + (ref $upload eq 'ARRAY' ? @{$upload} : ($upload)); } + } -=item $self->prepare_body($c) +=head2 $self->prepare_body($c) + +sets up the L object body using L =cut sub prepare_body { my ( $self, $c ) = @_; - $self->read_length( $c->request->header('Content-Length') || 0 ); - my $type = $c->request->header('Content-Type'); - - unless ( $c->request->{_body} ) { - $c->request->{_body} = HTTP::Body->new( $type, $self->read_length ); - } - - if ( $self->read_length > 0 ) { - while ( my $buffer = $self->read( $c ) ) { - $c->request->{_body}->add( $buffer ); - } - } + $c->request->prepare_body; } -=item $self->prepare_body_parameters($c) +=head2 $self->prepare_body_chunk($c) + +Add a chunk to the request body. =cut -sub prepare_body_parameters { - my ( $self, $c ) = @_; - $c->request->body_parameters( $c->request->{_body}->param ); +# XXX - Can this be deleted? +sub prepare_body_chunk { + my ( $self, $c, $chunk ) = @_; + + $c->request->prepare_body_chunk($chunk); } -=item $self->prepare_connection($c) +=head2 $self->prepare_body_parameters($c) + +Sets up parameters from body. =cut -sub prepare_connection { } +sub prepare_body_parameters { + my ( $self, $c ) = @_; + + $c->request->prepare_body_parameters; +} -=item $self->prepare_cookies($c) +=head2 $self->prepare_parameters($c) + +Sets up parameters from query and post parameters. +If parameters have already been set up will clear +existing parameters and set up again. =cut -sub prepare_cookies { +sub prepare_parameters { my ( $self, $c ) = @_; - if ( my $header = $c->request->header('Cookie') ) { - $c->req->cookies( { CGI::Cookie->parse($header) } ); - } + $c->request->_clear_parameters; + return $c->request->parameters; } -=item $self->prepare_headers($c) +=head2 $self->prepare_path($c) -=cut +abstract method, implemented by engines. -sub prepare_headers { } +=cut -=item $self->prepare_parameters($c) +sub prepare_path { + my ($self, $ctx) = @_; -=cut + my $env = $ctx->request->env; -sub prepare_parameters { - my ( $self, $c ) = @_; + my $scheme = $ctx->request->secure ? 'https' : 'http'; + my $host = $env->{HTTP_HOST} || $env->{SERVER_NAME}; + my $port = $env->{SERVER_PORT} || 80; + my $base_path = $env->{SCRIPT_NAME} || "/"; - # We copy, no references - while ( my ( $name, $param ) = each %{ $c->request->query_parameters } ) { - $param = ref $param eq 'ARRAY' ? [ @{$param} ] : $param; - $c->request->parameters->{$name} = $param; + # set the request URI + my $path; + if (!$ctx->config->{use_request_uri_for_path}) { + my $path_info = $env->{PATH_INFO}; + if ( exists $env->{REDIRECT_URL} ) { + $base_path = $env->{REDIRECT_URL}; + $base_path =~ s/\Q$path_info\E$//; + } + $path = $base_path . $path_info; + $path =~ s{^/+}{}; + $path =~ s/([^$URI::uric])/$URI::Escape::escapes{$1}/go; + $path =~ s/\?/%3F/g; # STUPID STUPID SPECIAL CASE + } + else { + my $req_uri = $env->{REQUEST_URI}; + $req_uri =~ s/\?.*$//; + $path = $req_uri; + $path =~ s{^/+}{}; } - # Merge query and body parameters - while ( my ( $name, $param ) = each %{ $c->request->body_parameters } ) { - $param = ref $param eq 'ARRAY' ? [ @{$param} ] : $param; - if ( my $old_param = $c->request->parameters->{$name} ) { - if ( ref $old_param eq 'ARRAY' ) { - push @{ $c->request->parameters->{$name} }, - ref $param eq 'ARRAY' ? @$param : $param; - } - else { $c->request->parameters->{$name} = [ $old_param, $param ] } - } - else { $c->request->parameters->{$name} = $param } + # Using URI directly is way too slow, so we construct the URLs manually + my $uri_class = "URI::$scheme"; + + # HTTP_HOST will include the port even if it's 80/443 + $host =~ s/:(?:80|443)$//; + + if ($port !~ /^(?:80|443)$/ && $host !~ /:/) { + $host .= ":$port"; } + + my $query = $env->{QUERY_STRING} ? '?' . $env->{QUERY_STRING} : ''; + my $uri = $scheme . '://' . $host . '/' . $path . $query; + + $ctx->request->uri( (bless \$uri, $uri_class)->canonical ); + + # set the base URI + # base must end in a slash + $base_path .= '/' unless $base_path =~ m{/$}; + + my $base_uri = $scheme . '://' . $host . $base_path; + + $ctx->request->base( bless \$base_uri, $uri_class ); + + return; } -=item $self->prepare_path($c) +=head2 $self->prepare_request($c) + +=head2 $self->prepare_query_parameters($c) + +process the query string and extract query parameters. =cut -sub prepare_path { } +sub prepare_query_parameters { + my ($self, $c) = @_; + my $env = $c->request->env; + my $do_not_decode_query = $c->config->{do_not_decode_query}; + my $default_query_encoding = $c->config->{default_query_encoding} || + ($c->config->{decode_query_using_global_encoding} ? + $c->encoding : 'UTF-8'); + + my $decoder = sub { + my $str = shift; + return $str if $do_not_decode_query; + return $str unless $default_query_encoding; + return decode( $default_query_encoding, $str); + }; + + my $query_string = exists $env->{QUERY_STRING} + ? $env->{QUERY_STRING} + : ''; + + # Check for keywords (no = signs) + # (yes, index() is faster than a regex :)) + if ( index( $query_string, '=' ) < 0 ) { + my $keywords = $self->unescape_uri($query_string); + $keywords = $decoder->($keywords); + $c->request->query_keywords($keywords); + return; + } -=item $self->prepare_request($c) + $query_string =~ s/\A[&;]+//; -=item $self->prepare_query_parameters($c) + my $p = Hash::MultiValue->new( + map { defined $_ ? $decoder->($self->unescape_uri($_)) : $_ } + map { ( split /=/, $_, 2 )[0,1] } # slice forces two elements + split /[&;]+/, $query_string + ); -=cut + $c->request->query_parameters( $c->request->_use_hash_multivalue ? $p : $p->mixed ); +} -sub prepare_query_parameters { } +=head2 $self->prepare_read($c) -=item $self->prepare_read($c) +Prepare to read by initializing the Content-Length from headers. =cut sub prepare_read { my ( $self, $c ) = @_; - - # Reset the read position - $self->read_position( 0 ); + + # Initialize the amount of data we think we need to read + $c->request->_read_length; } -=item $self->prepare_request(@arguments) +=head2 $self->prepare_request(@arguments) + +Populate the context object from the request object. =cut -sub prepare_request { } +sub prepare_request { + my ($self, $ctx, %args) = @_; + $ctx->log->psgienv($args{env}) if $ctx->log->can('psgienv'); + $ctx->request->_set_env($args{env}); + $self->_set_env($args{env}); # Nasty back compat! + $ctx->response->_set_response_cb($args{response_cb}); +} -=item $self->prepare_uploads($c) +=head2 $self->prepare_uploads($c) =cut sub prepare_uploads { my ( $self, $c ) = @_; - my $uploads = $c->request->{_body}->upload; - for my $name ( keys %$uploads ) { + + my $request = $c->request; + return unless $request->_body; + + my $enc = $c->encoding; + my $uploads = $request->_body->upload; + my $parameters = $request->parameters; + foreach my $name (keys %$uploads) { my $files = $uploads->{$name}; - $files = ref $files eq 'ARRAY' ? $files : [$files]; + $name = $c->_handle_unicode_decoding($name) if $enc; my @uploads; - for my $upload (@$files) { - my $u = Catalyst::Request::Upload->new; - $u->headers( HTTP::Headers->new( %{ $upload->{headers} } ) ); - $u->type( $u->headers->content_type ); - $u->tempname( $upload->{tempname} ); - $u->size( $upload->{size} ); - $u->filename( $upload->{filename} ); + for my $upload (ref $files eq 'ARRAY' ? @$files : ($files)) { + my $headers = HTTP::Headers->new( %{ $upload->{headers} } ); + my $filename = $upload->{filename}; + $filename = $c->_handle_unicode_decoding($filename) if $enc; + + my $u = Catalyst::Request::Upload->new + ( + size => $upload->{size}, + type => scalar $headers->content_type, + charset => scalar $headers->content_type_charset, + headers => $headers, + tempname => $upload->{tempname}, + filename => $filename, + ); push @uploads, $u; } - $c->request->uploads->{$name} = @uploads > 1 ? \@uploads : $uploads[0]; + $request->uploads->{$name} = @uploads > 1 ? \@uploads : $uploads[0]; + + # support access to the filename as a normal param + my @filenames = map { $_->{filename} } @uploads; + # append, if there's already params with this name + if (exists $parameters->{$name}) { + if (ref $parameters->{$name} eq 'ARRAY') { + push @{ $parameters->{$name} }, @filenames; + } + else { + $parameters->{$name} = [ $parameters->{$name}, @filenames ]; + } + } + else { + $parameters->{$name} = @filenames > 1 ? \@filenames : $filenames[0]; + } } } -=item $self->prepare_write($c) +=head2 $self->write($c, $buffer) + +Writes the buffer to the client. + +=cut + +sub write { + my ( $self, $c, $buffer ) = @_; + + $c->response->write($buffer); +} + +=head2 $self->unencoded_write($c, $buffer) + +Writes the buffer to the client without encoding. Necessary for +already encoded buffers. Used when a $c->write has been done +followed by $c->res->body. =cut -sub prepare_write { } +sub unencoded_write { + my ( $self, $c, $buffer ) = @_; + + $c->response->unencoded_write($buffer); +} + +=head2 $self->read($c, [$maxlength]) + +Reads from the input stream by calling C<< $self->read_chunk >>. -=item $self->read($c, [$maxlength]) +Maintains the read_length and read_position counters as data is read. =cut sub read { my ( $self, $c, $maxlength ) = @_; - - unless ( $self->{_prepared_read} ) { - $self->prepare_read( $c ); - $self->{_prepared_read} = 1; - } - - my $remaining = $self->read_length - $self->read_position; - $maxlength ||= $self->read_length; - - # Are we done reading? - if ( $remaining <= 0 ) { - $self->finalize_read( $c ); - return; - } - my $readlen = ( $remaining > $maxlength ) ? $maxlength : $remaining; - my $rc = $self->read_chunk( $c, my $buffer, $readlen ); - if ( defined $rc ) { - $self->read_position( $self->read_position + $rc ); - return $buffer; - } - else { - Catalyst::Exception->throw( - message => "Unknown error reading input: $!" - ); - } + $c->request->read($maxlength); } -=item $self->read_chunk($c, $buffer, $length) +=head2 $self->read_chunk($c, \$buffer, $length) -Each engine inplements read_chunk as its preferred way of reading a chunk -of data. +Each engine implements read_chunk as its preferred way of reading a chunk +of data. Returns the number of bytes read. A return of 0 indicates that +there is no more data to be read. =cut -sub read_chunk { } +sub read_chunk { + my ($self, $ctx) = (shift, shift); + return $ctx->request->read_chunk(@_); +} -=item $self->read_length +=head2 $self->run($app, $server) -The length of input data to be read. This is obtained from the Content-Length -header. +Start the engine. Builds a PSGI application and calls the +run method on the server passed in, which then causes the +engine to loop, handling requests.. -=item $self->read_position +=cut -The amount of input data that has already been read. +sub run { + my ($self, $app, $psgi, @args) = @_; + # @args left here rather than just a $options, $server for back compat with the + # old style scripts which send a few args, then a hashref + + # They should never actually be used in the normal case as the Plack engine is + # passed in got all the 'standard' args via the loader in the script already. + + # FIXME - we should stash the options in an attribute so that custom args + # like Gitalist's --git_dir are possible to get from the app without stupid tricks. + my $server = pop @args if (scalar @args && blessed $args[-1]); + my $options = pop @args if (scalar @args && ref($args[-1]) eq 'HASH'); + # Back compat hack for applications with old (non Catalyst::Script) scripts to work in FCGI. + if (scalar @args && !ref($args[0])) { + if (my $listen = shift @args) { + $options->{listen} ||= [$listen]; + } + } + if (! $server ) { + $server = Catalyst::EngineLoader->new(application_name => ref($self))->auto(%$options); + # We're not being called from a script, so auto detect what backend to + # run on. This should never happen, as mod_perl never calls ->run, + # instead the $app->handle method is called per request. + $app->log->warn("Not supplied a Plack engine, falling back to engine auto-loader (are your scripts ancient?)") + } + $app->run_options($options); + $server->run($psgi, $options); +} + +=head2 build_psgi_app ($app, @args) -=item $self->run($c) +Builds and returns a PSGI application closure. (Raw, not wrapped in middleware) =cut -sub run { } +sub build_psgi_app { + my ($self, $app, @args) = @_; -=item $self->write($c, $buffer) + return sub { + my ($env) = @_; + + return sub { + my ($respond) = @_; + confess("Did not get a response callback for writer, cannot continue") unless $respond; + $app->handle_request(env => $env, response_cb => $respond); + }; + }; +} + +=head2 $self->unescape_uri($uri) + +Unescapes a given URI using the most efficient method available. Engines such +as Apache may implement this using Apache's C-based modules, for example. =cut -sub write { - my ( $self, $c, $buffer ) = @_; - - unless ( $self->{_prepared_write} ) { - $self->prepare_write( $c ); - $self->{_prepared_write} = 1; - } - - my $handle = $c->response->handle; - - print $handle $buffer; +sub unescape_uri { + my ( $self, $str ) = @_; + + $str =~ s/(?:%([0-9A-Fa-f]{2})|\+)/defined $1 ? chr(hex($1)) : ' '/eg; + + return $str; } -=back +=head2 $self->finalize_output -=head1 AUTHORS +, see finalize_body + +=head2 $self->env + +Hash containing environment variables including many special variables inserted +by WWW server - like SERVER_*, REMOTE_*, HTTP_* ... -Sebastian Riedel, +Before accessing environment variables consider whether the same information is +not directly available via Catalyst objects $c->request, $c->engine ... -Andy Grundman, +BEWARE: If you really need to access some environment variable from your Catalyst +application you should use $c->engine->env->{VARNAME} instead of $ENV{VARNAME}, +as in some environments the %ENV hash does not contain what you would expect. + +=head1 AUTHORS + +Catalyst Contributors, see Catalyst.pm =head1 COPYRIGHT -This program is free software, you can redistribute it and/or modify it under +This library is free software. You can redistribute it and/or modify it under the same terms as Perl itself. =cut +__PACKAGE__->meta->make_immutable; + 1;